diff --git a/.circleci/config.yml b/.circleci/config.yml index 5c89ea615..6de527ca6 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -1,11 +1,11 @@ version: 2.1 # Anchors in case we need to override the defaults from the orb -#baselibs_version: &baselibs_version v7.17.0 -#bcs_version: &bcs_version v11.4.0 +#baselibs_version: &baselibs_version v7.27.0 +#bcs_version: &bcs_version v11.6.0 orbs: - ci: geos-esm/circleci-tools@2 + ci: geos-esm/circleci-tools@4 workflows: build-test: @@ -45,7 +45,7 @@ workflows: - docker-hub-creds matrix: parameters: - compiler: [gfortran, ifort] + compiler: [ifort] requires: - build-GEOSgcm-on-<< matrix.compiler >> repo: GEOSgcm diff --git a/.github/workflows/spack-ci.yml b/.github/workflows/spack-ci.yml new file mode 100644 index 000000000..4268d3b91 --- /dev/null +++ b/.github/workflows/spack-ci.yml @@ -0,0 +1,123 @@ +name: Spack CI GCC Build + +on: + pull_request: + types: [opened, synchronize, reopened] + # Do not run if the only files changed cannot affect the build + paths-ignore: + - "**.md" + - "**.pro" + - "**.sh" + - "**.perl" + - ".github/CODEOWNERS" + workflow_dispatch: + +concurrency: + group: ${{ github.workflow }}-${{ github.ref }} + cancel-in-progress: ${{ github.ref != 'refs/heads/main' }} + +jobs: + build_gcm: + name: Spack CI GCC Build + runs-on: ubuntu-24.04 + steps: + + - name: Checkout GCM + uses: actions/checkout@v4 + with: + fetch-depth: 1 + filter: blob:none + repository: GEOS-ESM/GEOSgcm + + - name: Set all directories as git safe + run: | + git config --global --add safe.directory '*' + + - name: Setup Python + uses: actions/setup-python@v5 + with: + python-version: '3.13' + + - name: Pip install mepo + run: | + python -m pip install --upgrade pip + pip install mepo + mepo --version + + - name: Mepo clone external repos + run: | + ls + mepo clone --partial blobless + mepo status + + - name: Mepo develop usual suspects + run: | + ls + mepo develop GEOSgcm_GridComp GEOSgcm_App GMAO_Shared GEOS_Util + mepo status + + - name: Debug PR branch + run: echo "PR is coming from ${{ github.event.pull_request.head.ref }}" + + - name: Update other branches + if: ${{ github.event.pull_request.head.ref != 'main' && github.event.pull_request.head.ref != 'develop' }} + run: | + mepo checkout-if-exists ${GITHUB_HEAD_REF} + mepo status + + - name: Set up Spack + uses: spack/setup-spack@v2 + with: + ref: develop # Spack version (examples: develop, releases/v0.21) + color: true # Force color output (SPACK_COLOR=always) + path: spack # Where to clone Spack + buildcache: false # Do not use the spack buildcache + + - name: Find compilers + shell: spack-bash {0} + run: | + spack compiler find + + - name: Set default compiler and target + shell: spack-bash {0} + run: | + spack config add 'packages:all:require:target=x86_64_v3' + + - name: Create Spack environment + shell: spack-bash {0} + run: | + spack env create spack-env + spack env activate spack-env + + - name: Login + shell: spack-bash {0} + run: | + spack -e spack-env mirror add geos-buildcache oci://ghcr.io/GEOS-ESM/geos-buildcache + spack -e spack-env mirror set --oci-username-variable "${{ secrets.BUILDCACHE_USERNAME }}" --oci-password-variable "${{ secrets.BUILDCACHE_TOKEN }}" geos-buildcache + spack -e spack-env mirror list + spack -e spack-env buildcache list --allarch + + - name: Concretize + shell: spack-bash {0} + run: | + spack -e spack-env concretize + + - name: Install + shell: spack-bash {0} + run: | + spack clean -m + spack -e spack-env install --add --no-check-signature --use-buildcache only \ + esmf gftl gftl-shared fargparse pflogger pfunit yafyaml ecbuild udunits openblas + + - name: Build with Cmake + shell: spack-bash {0} + run: | + spack env activate spack-env + spack load \ + esmf gftl gftl-shared fargparse pflogger pfunit yafyaml ecbuild udunits openblas + spack find --loaded + FC=gfortran-14 CC=gcc-14 CXX=g++-14 + cmake -B build -S . -DCMAKE_INSTALL_PREFIX=$PWD/install -DCMAKE_BUILD_TYPE=Debug -DUSE_F2PY=OFF -DCMAKE_Fortran_COMPILER=${FC} -DCMAKE_C_COMPILER=${CC} -DCMAKE_CXX_COMPILER=${CXX} + cmake --build build -j 4 + cmake --install build + diff --git a/.github/workflows/workflow.yml b/.github/workflows/workflow.yml new file mode 100644 index 000000000..90f865944 --- /dev/null +++ b/.github/workflows/workflow.yml @@ -0,0 +1,85 @@ +name: Build Tests + +on: + pull_request: + types: [opened, synchronize, reopened] + # Do not run if the only files changed cannot affect the build + paths-ignore: + - "**.md" + - "**.pro" + - "**.sh" + - "**.perl" + - ".github/CODEOWNERS" + +concurrency: + group: ${{ github.workflow }}-${{ github.ref }} + cancel-in-progress: ${{ github.ref != 'refs/heads/main' }} + +jobs: + build_gcm: + name: Build GEOSgcm + if: "!contains(github.event.pull_request.labels.*.name, '0 diff trivial')" + runs-on: ubuntu-24.04 + container: + image: gmao/ubuntu24-geos-env:v7.33.0-intelmpi_2021.13-ifort_2021.13 + # Per https://github.com/actions/virtual-environments/issues/1445#issuecomment-713861495 + # It seems like we might not need secrets on GitHub Actions which is good for forked + # pull requests + #credentials: + #username: ${{ secrets.DOCKERHUB_USERNAME }} + #password: ${{ secrets.DOCKERHUB_TOKEN }} + + env: + OMPI_ALLOW_RUN_AS_ROOT: 1 + OMPI_ALLOW_RUN_AS_ROOT_CONFIRM: 1 + OMPI_MCA_btl_vader_single_copy_mechanism: none + + steps: + # https://github.com/orgs/community/discussions/25678#discussioncomment-5242449 + - name: Delete huge unnecessary tools folder + run: rm -rf /opt/hostedtoolcache + + - name: Checkout GCM + uses: actions/checkout@v4 + with: + fetch-depth: 1 + filter: blob:none + repository: GEOS-ESM/GEOSgcm + + - name: Set all directories as git safe + run: | + git config --global --add safe.directory '*' + + - name: Versions etc. + run: | + ifort --version + mpirun --version + echo $BASEDIR + + - name: Mepo clone external repos + run: | + mepo clone --partial blobless + mepo status + + - name: Mepo develop usual suspects + run: | + mepo develop GEOSgcm_GridComp GEOSgcm_App GMAO_Shared GEOS_Util + mepo status + + - name: Debug PR branch + run: echo "PR is coming from ${{ github.event.pull_request.head.ref }}" + + - name: Update other branches + if: ${{ github.event.pull_request.head.ref != 'main' && github.event.pull_request.head.ref != 'develop' }} + run: | + mepo checkout-if-exists ${GITHUB_HEAD_REF} + mepo status + + - name: CMake + run: | + cmake -B build -S . --install-prefix=${pwd}/install -DCMAKE_Fortran_COMPILER=ifort -DCMAKE_BUILD_TYPE=Debug -DMPIEXEC_PREFLAGS='--oversubscribe' -DUSE_F2PY=OFF + + - name: Build + run: | + cmake --build build -j 4 + cmake --install build diff --git a/CMakeLists.txt b/CMakeLists.txt index a3b379668..bba3fcd40 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -8,6 +8,11 @@ set (alldirs GEOSwgcm_GridComp ) +option(BUILD_WITH_GIGATRAJ "Build GEOSgcm with Gigatraj" OFF) + +if (BUILD_WITH_GIGATRAJ) + list(APPEND alldirs GEOSgigatraj_GridComp) +endif() if (EXISTS ${CMAKE_CURRENT_SOURCE_DIR}/GEOS_GcmGridComp.F90) @@ -17,6 +22,8 @@ if (EXISTS ${CMAKE_CURRENT_SOURCE_DIR}/GEOS_GcmGridComp.F90) SUBCOMPONENTS ${alldirs} DEPENDENCIES MAPL ESMF::ESMF) + target_compile_definitions (${this} PRIVATE $<$:HAS_GIGATRAJ>) + ecbuild_install_project( NAME GEOSgcm_GridComp) else () diff --git a/GEOS_GcmGridComp.F90 b/GEOS_GcmGridComp.F90 index e46c22ca9..96d183e14 100644 --- a/GEOS_GcmGridComp.F90 +++ b/GEOS_GcmGridComp.F90 @@ -20,6 +20,10 @@ module GEOS_GcmGridCompMod use GEOS_AgcmGridCompMod, only: AGCM_SetServices => SetServices use GEOS_mkiauGridCompMod, only: AIAU_SetServices => SetServices use DFI_GridCompMod, only: ADFI_SetServices => SetServices +#ifdef HAS_GIGATRAJ + use GEOS_GigatrajGridCompMod, only: GigaTraj_SetServices => SetServices +#endif + use GEOS_OgcmGridCompMod, only: OGCM_SetServices => SetServices use GEOS_WgcmGridCompMod, only: WGCM_SetServices => SetServices use MAPL_HistoryGridCompMod, only: Hist_SetServices => SetServices @@ -58,6 +62,7 @@ module GEOS_GcmGridCompMod integer :: ADFI integer :: WGCM integer :: hist +integer :: gigatraj integer :: bypass_ogcm integer :: k @@ -251,6 +256,10 @@ subroutine SetServices ( GC, RC ) else AGCM = MAPL_AddChild(GC, NAME='AGCM', SS=Agcm_SetServices, RC=STATUS) VERIFY_(STATUS) +#ifdef HAS_GIGATRAJ + gigatraj = MAPL_AddChild(GC, NAME='GIGATRAJ', SS=GigaTraj_SetServices, RC=STATUS) + VERIFY_(STATUS) +#endif AIAU = MAPL_AddChild(GC, NAME='AIAU', SS=AIAU_SetServices, RC=STATUS) VERIFY_(STATUS) ADFI = MAPL_AddChild(GC, NAME='ADFI', SS=ADFI_SetServices, RC=STATUS) @@ -955,6 +964,10 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) ! Recursive setup of grids (should be disabled) call ESMF_GridCompSet(GCS(AGCM), grid=agrid, rc=status) VERIFY_(STATUS) +#ifdef HAS_GIGATRAJ + call ESMF_GridCompSet(GCS(gigatraj), grid=agrid, rc=status) + VERIFY_(STATUS) +#endif call ESMF_GridCompSet(GCS(OGCM), grid=ogrid, rc=status) VERIFY_(STATUS) if(.not. DO_DATA_ATM4OCN) then @@ -1308,15 +1321,17 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) result=GCM_INTERNAL_STATE%SURF_IMP, rc=status) VERIFY_(STATUS) - !select TURBULENCE export - call MAPL_ExportStateGet(GEX, name='TURBULENCE', & - result=GCM_INTERNAL_STATE%TURB_EXP, rc=status) - VERIFY_(STATUS) + if(.not. DO_DATA_ATM4OCN) then + !select TURBULENCE export + call MAPL_ExportStateGet(GEX, name='TURBULENCE', & + result=GCM_INTERNAL_STATE%TURB_EXP, rc=status) + VERIFY_(STATUS) - !select SURFACE import - call MAPL_ImportStateGet(GC, import=import, name='TURBULENCE', & - result=GCM_INTERNAL_STATE%TURB_IMP, rc=status) - VERIFY_(STATUS) + !select TURBULENCE import + call MAPL_ImportStateGet(GC, import=import, name='TURBULENCE', & + result=GCM_INTERNAL_STATE%TURB_IMP, rc=status) + VERIFY_(STATUS) + endif !select OCEAN export call MAPL_ExportStateGet(GEX, name='OCEAN', & @@ -2017,10 +2032,23 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) else call MAPL_TimerOn(MAPL,"AGCM" ) endif + +#ifdef HAS_GIGATRAJ + ! use agcm export as gigatraj's import to get the initial state. + ! it only runs at the begining of the first time step + call ESMF_GridCompRun ( GCS(gigatraj), importState=GEX(AGCM), exportState=GEX(gigatraj), clock=clock, phase=1, userRC=status ) + VERIFY_(STATUS) +#endif call ESMF_GridCompRun ( GCS(AGCM), importState=GIM(AGCM), exportState=GEX(AGCM), clock=clock, userRC=status ) VERIFY_(STATUS) +#ifdef HAS_GIGATRAJ + ! use agcm export as gigatraj's import + call ESMF_GridCompRun ( GCS(gigatraj), importState=GEX(AGCM), exportState=GEX(gigatraj), clock=clock, phase=2, userRC=status ) + VERIFY_(STATUS) +#endif + if(DO_DATA_ATM4OCN) then call MAPL_TimerOff(MAPL,"DATAATM" ) else diff --git a/GEOSagcm_GridComp/CMakeLists.txt b/GEOSagcm_GridComp/CMakeLists.txt index 7e0783090..f28aaff0c 100644 --- a/GEOSagcm_GridComp/CMakeLists.txt +++ b/GEOSagcm_GridComp/CMakeLists.txt @@ -20,6 +20,8 @@ elseif (EXISTS ${CMAKE_CURRENT_SOURCE_DIR}/GEOS_AgcmGridComp.F90) SUBCOMPONENTS ${alldirs} DEPENDENCIES MAPL GEOS_Shared Chem_Shared ESMF::ESMF) + target_compile_definitions (${this} PRIVATE $<$:HAS_GIGATRAJ>) + else () esma_add_subdirectories (${alldirs}) diff --git a/GEOSagcm_GridComp/GEOS_AgcmGridComp.F90 b/GEOSagcm_GridComp/GEOS_AgcmGridComp.F90 index 3a3bee32b..26d96fdc2 100644 --- a/GEOSagcm_GridComp/GEOS_AgcmGridComp.F90 +++ b/GEOSagcm_GridComp/GEOS_AgcmGridComp.F90 @@ -790,6 +790,34 @@ subroutine SetServices ( GC, RC ) RC = STATUS) VERIFY_(STATUS) +#ifdef HAS_GIGATRAJ + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'PL', & + CHILD_ID = SDYN, & + RC = STATUS) + VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'OMEGA', & + CHILD_ID = SDYN, & + RC = STATUS) + VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'TH', & + CHILD_ID = SDYN, & + RC = STATUS) + VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DTDTDYN', & + CHILD_ID = SDYN, & + RC = STATUS) + VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'ZL', & + CHILD_ID = SDYN, & + RC = STATUS) + VERIFY_(STATUS) +#endif + call MAPL_AddExportSpec( GC, & SHORT_NAME = 'PS', & CHILD_ID = SDYN, & diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 index 36dd7c3f6..dea0f1a5e 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 @@ -120,6 +120,10 @@ subroutine SetServices ( GC, RC ) character(len=ESMF_MAXSTR) :: SURFRC type(ESMF_Config) :: SCF + ! <<>> MSL DEV + character(len=ESMF_MAXSTR) :: co2provider + real :: co2_ + !============================================================================= ! Begin... @@ -1114,6 +1118,27 @@ subroutine SetServices ( GC, RC ) 'CFC11 ','CFC12 ','HCFC22' /), & DST_ID=RAD, SRC_ID=CHEM, RC=STATUS ) VERIFY_(STATUS) + +! <<>> MSL DEV +! CO2 is not listed as a RAT, so add it here outside of the RATs code logic +! It also doesn't appear in PCHEM, so we can't make it part of the RATs list + ! -- get info from AGCM.rc + call ESMF_ConfigGetAttribute(CF, co2provider, Default='None', & + Label="CO2_PROVIDER:", __RC__ ) + call ESMF_ConfigGetAttribute(CF, co2_, Default=-1.0, & + Label="CO2:", __RC__ ) + if (trim(co2provider) .eq. 'GOCART' .and. CO2_ .eq. -2.0) then + CALL MAPL_AddConnectivity( GC, & + SHORT_NAME = (/'CO2'/), & + DST_ID=RAD, SRC_ID=CHEM, RC=STATUS ) + VERIFY_(STATUS) + endif + if (trim(co2provider) .eq. 'RRG' .and. CO2_ .eq. -2.0) then + CALL MAPL_AddConnectivity( GC, & + SHORT_NAME = (/'CO2'/), & + DST_ID=RAD, SRC_ID=CHEM, RC=STATUS ) + VERIFY_(STATUS) + endif ! ----------------------------------------------------------------- call MAPL_AddConnectivity ( GC, & @@ -1215,8 +1240,8 @@ subroutine SetServices ( GC, RC ) call MAPL_AddConnectivity ( GC, & SHORT_NAME = (/ 'RL ', 'QL ', 'QLTOT ', 'DQLDT ', & 'RI ', 'QI ', 'QITOT ', 'DQIDT ', & - 'QLCN ', 'PFL_CN ', 'PFL_LSAN', & - 'QICN ', 'PFI_CN ', 'PFI_LSAN', & + 'QLCN ', 'PFL_CN ', 'PFL_LSAN', 'ZLCL ', & + 'QICN ', 'PFI_CN ', 'PFI_LSAN', 'ZLFC ', & 'FCLD ', 'QCTOT ', 'CNV_QC ', & 'REV_LS ', 'REV_AN ', 'REV_CN ', 'TPREC ', & 'Q ', 'DQDT ', 'DQRL ', 'DQRC ', & diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/CMakeLists.txt index 01b668323..6959662f9 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/CMakeLists.txt +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/CMakeLists.txt @@ -19,16 +19,23 @@ set (srcs ) set (resource_files - GWD_GridComp.rc - ) - - + GWD_GridComp.rc + ) install( FILES ${resource_files} - DESTINATION etc - ) + DESTINATION etc + ) -esma_add_library (${this} SRCS ${srcs} DEPENDENCIES GEOS_Shared MAPL ESMF::ESMF NetCDF::NetCDF_Fortran) +esma_add_library ( + ${this} + SRCS ${srcs} + DEPENDENCIES GEOS_Shared MAPL ESMF::ESMF NetCDF::NetCDF_Fortran TYPE SHARED + ) + +mapl_acg ( + ${this} GWD_StateSpecs.rc + IMPORT_SPECS EXPORT_SPECS INTERNAL_SPECS GET_POINTERS DECLARE_POINTERS + ) # CMake has an OpenMP issue with NAG Fortran: https://gitlab.kitware.com/cmake/cmake/-/issues/21280 if (NOT CMAKE_Fortran_COMPILER_ID MATCHES "NAG") diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 index 7ba743ce8..60d0f8f41 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 @@ -1,795 +1,271 @@ - ! $Id$ #include "MAPL_Generic.h" module GEOS_GwdGridCompMod -!BOP - -! !MODULE: GEOS_Gwd -- A Module to compute the forcing due to parameterized gravity wave drag - -! !DESCRIPTION: -! -! {\tt GWD} is a light-weight gridded component to compute the forcing -! due to gravity wave drags. It operates on the ESMF grid that appears in the -! gridded component passed to its {\tt Initialize} method. Unlike -! heavier gridded components, it does not enforce its own grid. -! The only restrictions are that it be a 3-dimensional grid -! in which one dimension is aligned with the vertical coordinate and -! only the horizontal dimensions are decomposed. -! -! The gravity wave drag scheme is based on NCAR WACCM1b gw\_drag routine. -! The scheme includes parameterizations for orographic (stationary) gravity -! waves (Kiehl et al. 1996), and for a spectrum of traveling gravity waves -!(Sassi et al. 2003; http://acd.ucar.edu/models/WACCM). Both parameteriz- -! ations are based on Lindzen's [1981] formulation. The interested reader -! is referred to those publications for details of the mathematical -! derivations. -! - -! !USES: - - use ESMF - use MAPL - - use gw_rdg, only : gw_rdg_init - use gw_oro, only : gw_oro_init - use gw_convect, only : gw_beres_init, BeresSourceDesc - use gw_common, only: GWBand, gw_common_init, gw_newtonian_set - use gw_drag_ncar, only: gw_intr_ncar - - use gw_drag, only: gw_intr - - implicit none - private - -! !PUBLIC MEMBER FUNCTIONS: - - public SetServices - -!EOP -! config params - type :: ThreadWorkspace - type(GWBand) :: beres_band - type(BeresSourceDesc) :: beres_dc_desc - type(GWBand) :: oro_band - type(GWBand) :: rdg_band - end type ThreadWorkspace - - type :: GEOS_GwdGridComp - real :: GEOS_BGSTRESS - real :: GEOS_EFFGWBKG - real :: GEOS_EFFGWORO - integer :: GEOS_PGWV - real :: NCAR_EFFGWBKG - real :: NCAR_EFFGWORO - integer :: NCAR_NRDG - real :: Z1 - real :: TAU1 - real :: H0 - real :: HH - real, allocatable :: alpha(:) - type(ThreadWorkspace), allocatable :: workspaces(:) - end type GEOS_GwdGridComp - - type wrap_ - type (GEOS_GwdGridComp), pointer :: PTR - end type wrap_ - - !logical, save :: FIRST_RUN = .true. + !BOP + + ! !MODULE: GEOS_Gwd -- A Module to compute the forcing due to parameterized gravity wave drag + + ! !DESCRIPTION: + ! + ! {\tt GWD} is a light-weight gridded component to compute the forcing + ! due to gravity wave drags. It operates on the ESMF grid that appears in the + ! gridded component passed to its {\tt Initialize} method. Unlike + ! heavier gridded components, it does not enforce its own grid. + ! The only restrictions are that it be a 3-dimensional grid + ! in which one dimension is aligned with the vertical coordinate and + ! only the horizontal dimensions are decomposed. + ! + ! The gravity wave drag scheme is based on NCAR WACCM1b gw\_drag routine. + ! The scheme includes parameterizations for orographic (stationary) gravity + ! waves (Kiehl et al. 1996), and for a spectrum of traveling gravity waves + !(Sassi et al. 2003; http://acd.ucar.edu/models/WACCM). Both parameteriz- + ! ations are based on Lindzen's [1981] formulation. The interested reader + ! is referred to those publications for details of the mathematical + ! derivations. + ! + + ! !USES: + + use ESMF + use MAPL + + use gw_rdg, only : gw_rdg_init + use gw_oro, only : gw_oro_init + use gw_convect, only : gw_beres_init, BeresSourceDesc + use gw_common, only: GWBand, gw_common_init, gw_newtonian_set + use gw_drag_ncar, only: gw_intr_ncar + + use gw_drag, only: gw_intr + + implicit none + private + + ! !PUBLIC MEMBER FUNCTIONS: + + public SetServices + + !EOP + ! config params + type :: ThreadWorkspace + type(GWBand) :: beres_band + type(BeresSourceDesc) :: beres_dc_desc + type(GWBand) :: oro_band + type(GWBand) :: rdg_band + end type ThreadWorkspace + + type :: GEOS_GwdGridComp + real :: GEOS_BGSTRESS + real :: GEOS_EFFGWBKG + real :: GEOS_EFFGWORO + integer :: GEOS_PGWV + real :: NCAR_EFFGWBKG + real :: NCAR_EFFGWORO + integer :: NCAR_NRDG + real :: Z1 + real :: TAU1 + real :: H0 + real :: HH + real, allocatable :: alpha(:) + type(ThreadWorkspace), allocatable :: workspaces(:) + end type GEOS_GwdGridComp + + type wrap_ + type (GEOS_GwdGridComp), pointer :: PTR + end type wrap_ + + !logical, save :: FIRST_RUN = .true. contains -!BOP -! !IROUTINE: SetServices -- Sets ESMF services for this component - -! !INTERFACE: - subroutine SetServices ( GC, RC ) - -! !ARGUMENTS: - type(ESMF_GridComp), intent(INOUT) :: GC ! gridded component - integer, optional :: RC ! return code - -! !DESCRIPTION: This version uses the MAPL\_GenericSetServices. This function sets -! the Initialize and Finalize services, as well as allocating -! our instance of a generic state and putting it in the -! gridded component (GC). Here we only need to set the run method and -! add the state variable specifications (also generic) to our instance -! of the generic state. This is the way our true state variables get into -! the ESMF\_State INTERNAL, which is in the MAPL\_MetaComp. - -!EOP - -!============================================================================= -! -! ErrLog Variables - - character(len=ESMF_MAXSTR) :: IAm - integer :: STATUS - character(len=ESMF_MAXSTR) :: COMP_NAME - type (MAPL_MetaComp), pointer :: MAPL -!============================================================================= - logical :: use_threads - type (ESMF_Config) :: myCF - - type (wrap_) :: wrap - type (GEOS_GwdGridComp), pointer :: self - integer :: num_threads - -! Begin... - -! Get my name and set-up traceback handle -! --------------------------------------- - - Iam = 'SetServices' - call ESMF_GridCompGet( GC, NAME=COMP_NAME, _RC ) - Iam = trim(COMP_NAME) // Iam - -! Wrap internal state for storing in GC -! ------------------------------------- - allocate (self, _STAT) - wrap%ptr => self - - num_threads = MAPL_get_num_threads() - allocate(self%workspaces(0:num_threads-1), _STAT) - -! Set the Run entry point -! ----------------------- - - call MAPL_GridCompSetEntryPoint ( gc, ESMF_METHOD_INITIALIZE, Initialize, _RC) - call MAPL_GridCompSetEntryPoint ( gc, ESMF_METHOD_RUN, Run, _RC) - - call MAPL_GetObjectFromGC ( GC, MAPL, _RC ) - - myCF = ESMF_ConfigCreate (_RC) - call ESMF_ConfigLoadFile (myCF, 'GWD_GridComp.rc', _RC) - call ESMF_ConfigGetAttribute (myCF, use_threads, label='use_threads:', default=.FALSE., _RC) -! set use_threads - call MAPL%set_use_threads(use_threads) - call ESMF_ConfigDestroy(myCF, _RC) - -! Set the state variable specs. -! ----------------------------- - -!BOS -! !IMPORT STATE: - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'PLE', & - LONG_NAME = 'air_pressure', & - UNITS = 'Pa', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, & - RESTART = MAPL_RestartSkip, & - _RC ) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'T', & - LONG_NAME = 'air_temperature', & - UNITS = 'K', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - _RC ) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'Q', & - LONG_NAME = 'specific_humidity', & - UNITS = 'kg kg-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - _RC ) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'U', & - LONG_NAME = 'eastward_wind', & - UNITS = 'm s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - _RC ) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'V', & - LONG_NAME = 'northward_wind', & - UNITS = 'm s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RESTART = MAPL_RestartSkip, & - _RC ) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'PHIS', & - LONG_NAME = 'surface geopotential height', & - UNITS = 'm+2 s-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RESTART = MAPL_RestartSkip, & - _RC ) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'SGH', & - LONG_NAME = 'standard_deviation_of_topography', & - UNITS = 'm', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RESTART = MAPL_RestartSkip, & - _RC ) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'VARFLT', & - LONG_NAME = 'variance_of_the_filtered_topography', & - UNITS = 'm+2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RESTART = MAPL_RestartSkip, & - _RC ) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'PREF', & - LONG_NAME = 'reference_air_pressure', & - UNITS = 'Pa', & - DIMS = MAPL_DimsVertOnly, & - VLOCATION = MAPL_VLocationEdge, & - RESTART = MAPL_RestartSkip, & - _RC ) - - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'AREA', & - LONG_NAME = 'grid_box_area', & - UNITS = 'm^2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RESTART = MAPL_RestartSkip, & - _RC ) - -! from moist - call MAPL_AddImportSpec(GC, & - SHORT_NAME='DTDT_DC', & - LONG_NAME ='T tendency due to deep convection', & - UNITS ='K s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, _RC ) - call MAPL_AddImportSpec(GC, & - SHORT_NAME= 'DQLDT', & - LONG_NAME = 'total_liq_water_tendency_due_to_moist', & - UNITS = 'kg kg-1 s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - _RC ) - call MAPL_AddImportSpec(GC, & - SHORT_NAME= 'DQIDT', & - LONG_NAME = 'total_ice_water_tendency_due_to_moist', & - UNITS = 'kg kg-1 s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - _RC ) - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'CNV_FRC', & - LONG_NAME = 'convective_fraction', & - UNITS = '1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - _RC ) - -! !EXPORT STATE: - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'PLE', & - LONG_NAME = 'air_pressure', & - UNITS = 'Pa', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, _RC ) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'T', & - LONG_NAME = 'air_temperature', & - UNITS = 'K', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, _RC ) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'Q', & - LONG_NAME = 'specific_humidity', & - UNITS = 'kg kg-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, _RC ) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'U', & - LONG_NAME = 'eastward_wind', & - UNITS = 'm s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, _RC ) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'V', & - LONG_NAME = 'northward_wind', & - UNITS = 'm s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, _RC ) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'RDG1_MXDIS', & - LONG_NAME = 'ridge1_mxdis', & - UNITS = '1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, _RC ) - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'RDG1_HWDTH', & - LONG_NAME = 'ridge1_hwdth', & - UNITS = '1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, _RC ) - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'RDG1_CLNGT', & - LONG_NAME = 'ridge1_clngt', & - UNITS = '1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, _RC ) - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'RDG1_ANGLL', & - LONG_NAME = 'ridge1_angll', & - UNITS = '1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, _RC ) - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'RDG1_ANIXY', & - LONG_NAME = 'ridge1_anixy', & - UNITS = '1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, _RC ) - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'RDG1_GBXAR', & - LONG_NAME = 'ridge1_gridbox_area', & - UNITS = 'km^2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, _RC ) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'SGH', & - LONG_NAME = 'standard_deviation_of_topography', & - UNITS = 'm', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, _RC ) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'PREF', & - LONG_NAME = 'reference_air_pressure', & - UNITS = 'Pa', & - DIMS = MAPL_DimsVertOnly, & - VLOCATION = MAPL_VLocationEdge, _RC ) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'DTDT', & - LONG_NAME = 'mass_weighted_air_temperature_tendency_due_to_GWD', & - UNITS = 'Pa K s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, _RC ) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'TTMGW', & - LONG_NAME = 'air_temperature_tendency_due_to_GWD', & - UNITS = 'K s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, _RC ) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'DUDT', & - LONG_NAME = 'tendency_of_eastward_wind_due_to_GWD', & - UNITS = 'm s-2', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, _RC ) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'DVDT', & - LONG_NAME = 'tendency_of_northward_wind_due_to_GWD', & - UNITS = 'm s-2', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, _RC ) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'DTDT_ORO', & - LONG_NAME = 'air_temperature_tendency_due_to_orographic_GWD', & - UNITS = 'K s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, _RC ) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'DUDT_ORO', & - LONG_NAME = 'tendency_of_eastward_wind_due_to_orographic_GWD', & - UNITS = 'm s-2', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, _RC ) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'DVDT_ORO', & - LONG_NAME = 'tendency_of_northward_wind_due_to_orographic_GWD', & - UNITS = 'm s-2', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, _RC ) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'DTDT_BKG', & - LONG_NAME = 'air_temperature_tendency_due_to_background_GWD', & - UNITS = 'K s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, _RC ) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'DUDT_BKG', & - LONG_NAME = 'tendency_of_eastward_wind_due_to_background_GWD', & - UNITS = 'm s-2', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, _RC ) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'DVDT_BKG', & - LONG_NAME = 'tendency_of_northward_wind_due_to_background_GWD', & - UNITS = 'm s-2', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, _RC ) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'DTDT_RAY', & - LONG_NAME = 'air_temperature_tendency_due_to_Rayleigh_friction', & - UNITS = 'K s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, _RC ) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'DUDT_RAY', & - LONG_NAME = 'tendency_of_eastward_wind_due_to_Rayleigh_friction', & - UNITS = 'm s-2', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, _RC ) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'DVDT_RAY', & - LONG_NAME = 'tendency_of_northward_wind_due_to_Rayleigh_friction', & - UNITS = 'm s-2', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, _RC ) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'TAUGWX', & - LONG_NAME = 'surface_eastward_gravity_wave_stress', & - UNITS = 'N m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, _RC ) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'TAUGWY', & - LONG_NAME = 'surface_northward_gravity_wave_stress', & - UNITS = 'N m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, _RC ) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'TAUOROX', & - LONG_NAME = 'surface_eastward_orographic_gravity_wave_stress', & - UNITS = 'N m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, _RC ) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'TAUOROY', & - LONG_NAME = 'surface_northward_orographic_gravity_wave_stress', & - UNITS = 'N m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, _RC ) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'TAUBKGX', & - LONG_NAME = 'surface_eastward_background_gravity_wave_stress', & - UNITS = 'N m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, _RC ) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'TAUBKGY', & - LONG_NAME = 'surface_northward_background_gravity_wave_stress', & - UNITS = 'N m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, _RC ) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'TAUMSTX', & - LONG_NAME = 'surface_eastward_gravity_wave_stress_due_to_Moist_Processes', & - UNITS = 'N m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, _RC ) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'TAUMSTY', & - LONG_NAME = 'surface_northward_gravity_wave_stress_due_to_Moist_Processes', & - UNITS = 'N m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, _RC ) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'CLDSTD', & - LONG_NAME = 'gravity_wave_drag_standard_deviation_due_to_clouds', & - UNITS = 'm', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, _RC ) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'UBASE', & - LONG_NAME = 'eastward_component_of_base_level_wind', & - UNITS = 'm s-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, _RC ) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'VBASE', & - LONG_NAME = 'northward_component_of_base_level_wind', & - UNITS = 'm s-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, _RC ) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'UBAR', & - LONG_NAME = 'eastward_component_of_mean_level_wind', & - UNITS = 'm s-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, _RC ) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'VBAR', & - LONG_NAME = 'northward_component_of_mean_level_wind', & - UNITS = 'm s-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, _RC ) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'PEGWD', & - LONG_NAME = 'vertically_integrated_potential_energy_tendency_across_gwd', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, _RC ) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'PEORO', & - LONG_NAME = 'vertically_integrated_potential_energy_tendency_due_to_orographic_gravity_waves', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, _RC ) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'PEBKG', & - LONG_NAME = 'vertically_integrated_potential_energy_tendency_due_to_gravity_wave_background', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, _RC ) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'PERAY', & - LONG_NAME = 'vertically_integrated_potential_energy_tendency_due_to_Rayleigh_friction', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, _RC ) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'KEGWD', & - LONG_NAME = 'vertically_integrated_kinetic_energy_tendency_across_gwd', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, _RC ) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'KEORO', & - LONG_NAME = 'vertically_integrated_kinetic_energy_dissipation_due_to_orographic_gravity_waves', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, _RC ) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'KERAY', & - LONG_NAME = 'vertically_integrated_kinetic_energy_dissipation_due_to_Rayleigh_friction', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, _RC ) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'KEBKG', & - LONG_NAME = 'vertically_integrated_kinetic_energy_dissipation_due_to_gravity_wave_background', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, _RC ) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'KERES', & - LONG_NAME = 'vertically_integrated_kinetic_energy_residual_for_total_energy_conservation', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, _RC ) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'BKGERR', & - LONG_NAME = 'vertically_integrated_kinetic_energy_residual_for_BKG_energy_conservation', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, _RC ) - - call MAPL_AddInternalSpec(GC, & - SHORT_NAME = 'SGH30', & - LONG_NAME = 'standard deviation of 30s elevation from 3km cube', & - UNITS = 'm', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, _RC ) - call MAPL_AddInternalSpec(GC, & - SHORT_NAME = 'KWVRDG', & - LONG_NAME = 'horizonal wwavenumber of mountain ridges', & - UNITS = 'km', & - UNGRIDDED_DIMS = (/16/), & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, _RC ) - call MAPL_AddInternalSpec(GC, & - SHORT_NAME = 'EFFRDG', & - LONG_NAME = 'efficiency of mountain ridge scheme', & - UNITS = 'km', & - UNGRIDDED_DIMS = (/16/), & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, _RC ) - call MAPL_AddInternalSpec(GC, & - SHORT_NAME = 'GBXAR', & - LONG_NAME = 'grid box area', & - UNITS = 'NA', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, _RC ) - call MAPL_AddInternalSpec(GC, & - SHORT_NAME = 'HWDTH', & - LONG_NAME = 'width of mountain ridges', & - UNITS = 'km', & - UNGRIDDED_DIMS = (/16/), & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, _RC ) - call MAPL_AddInternalSpec(GC, & - SHORT_NAME = 'CLNGT', & - LONG_NAME = 'width of mountain ridges', & - UNITS = 'km', & - UNGRIDDED_DIMS = (/16/), & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, _RC ) - call MAPL_AddInternalSpec(GC, & - SHORT_NAME = 'MXDIS', & - LONG_NAME = 'NA', & - UNITS = 'NA', & - UNGRIDDED_DIMS = (/16/), & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, _RC ) - call MAPL_AddInternalSpec(GC, & - SHORT_NAME = 'ANGLL', & - LONG_NAME = 'NA', & - UNITS = 'NA', & - UNGRIDDED_DIMS = (/16/), & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, _RC ) - call MAPL_AddInternalSpec(GC, & - SHORT_NAME = 'ANIXY', & - LONG_NAME = 'NA', & - UNITS = 'NA', & - UNGRIDDED_DIMS = (/16/), & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, _RC ) - -!EOS - -! Set the Profiling timers -! ------------------------ - - call MAPL_TimerAdd(GC, name="DRIVER" ,_RC) - call MAPL_TimerAdd(GC, name="-DRIVER_RUN" ,_RC) - call MAPL_TimerAdd(GC, name="-INTR" ,_RC) - call MAPL_TimerAdd(GC, name="-INTR_NCAR" ,_RC) - call MAPL_TimerAdd(GC, name="-INTR_GEOS" ,_RC) - call MAPL_TimerAdd(GC, name="-DRIVER_DATA" ,_RC) - call MAPL_TimerAdd(GC, name="--DRIVER_DATA_DEVICE" ,_RC) - call MAPL_TimerAdd(GC, name="--DRIVER_DATA_CONST" ,_RC) - call MAPL_TimerAdd(GC, name="-DRIVER_ALLOC" ,_RC) - call MAPL_TimerAdd(GC, name="-DRIVER_DEALLOC" ,_RC) - -! Store internal state in GC -! -------------------------- - call ESMF_UserCompSetInternalState ( GC, 'GEOS_GwdGridComp', wrap, _RC ) - -! Set generic init and final methods -! ---------------------------------- - - call MAPL_GenericSetServices ( gc, _RC) - - RETURN_(ESMF_SUCCESS) - - end subroutine SetServices + !BOP + ! !IROUTINE: SetServices -- Sets ESMF services for this component + + ! !INTERFACE: + subroutine SetServices ( GC, RC ) + + ! !ARGUMENTS: + type(ESMF_GridComp), intent(INOUT) :: GC ! gridded component + integer, optional :: RC ! return code + + ! !DESCRIPTION: This version uses the MAPL\_GenericSetServices. This function sets + ! the Initialize and Finalize services, as well as allocating + ! our instance of a generic state and putting it in the + ! gridded component (GC). Here we only need to set the run method and + ! add the state variable specifications (also generic) to our instance + ! of the generic state. This is the way our true state variables get into + ! the ESMF\_State INTERNAL, which is in the MAPL\_MetaComp. + + !EOP + + !============================================================================= + ! + ! ErrLog Variables + + character(len=ESMF_MAXSTR) :: IAm + integer :: STATUS + character(len=ESMF_MAXSTR) :: COMP_NAME + type (MAPL_MetaComp), pointer :: MAPL + !============================================================================= + logical :: use_threads + type (ESMF_Config) :: myCF + + type (wrap_) :: wrap + type (GEOS_GwdGridComp), pointer :: self + integer :: num_threads + + ! Begin... + + ! Get my name and set-up traceback handle + ! --------------------------------------- + + Iam = 'SetServices' + call ESMF_GridCompGet( GC, NAME=COMP_NAME, _RC ) + Iam = trim(COMP_NAME) // Iam + + ! Wrap internal state for storing in GC + ! ------------------------------------- + allocate (self, _STAT) + wrap%ptr => self + + num_threads = MAPL_get_num_threads() + allocate(self%workspaces(0:num_threads-1), _STAT) + + ! Set the Run entry point + ! ----------------------- + + call MAPL_GridCompSetEntryPoint ( gc, ESMF_METHOD_INITIALIZE, Initialize, _RC) + call MAPL_GridCompSetEntryPoint ( gc, ESMF_METHOD_RUN, Run, _RC) + + call MAPL_GetObjectFromGC ( GC, MAPL, _RC ) + + myCF = ESMF_ConfigCreate (_RC) + call ESMF_ConfigLoadFile (myCF, 'GWD_GridComp.rc', _RC) + call ESMF_ConfigGetAttribute (myCF, use_threads, label='use_threads:', default=.FALSE., _RC) + ! set use_threads + call MAPL%set_use_threads(use_threads) + call ESMF_ConfigDestroy(myCF, _RC) + + ! Set the state variable specs. + ! ----------------------------- +#include "GWD_Import___.h" +#include "GWD_Export___.h" +#include "GWD_Internal___.h" + + ! Set the Profiling timers + ! ------------------------ + + call MAPL_TimerAdd(GC, name="DRIVER" ,_RC) + call MAPL_TimerAdd(GC, name="-DRIVER_RUN" ,_RC) + call MAPL_TimerAdd(GC, name="-INTR" ,_RC) + call MAPL_TimerAdd(GC, name="-INTR_NCAR" ,_RC) + call MAPL_TimerAdd(GC, name="-INTR_GEOS" ,_RC) + call MAPL_TimerAdd(GC, name="-DRIVER_DATA" ,_RC) + call MAPL_TimerAdd(GC, name="--DRIVER_DATA_DEVICE" ,_RC) + call MAPL_TimerAdd(GC, name="--DRIVER_DATA_CONST" ,_RC) + call MAPL_TimerAdd(GC, name="-DRIVER_ALLOC" ,_RC) + call MAPL_TimerAdd(GC, name="-DRIVER_DEALLOC" ,_RC) + + ! Store internal state in GC + ! -------------------------- + call ESMF_UserCompSetInternalState ( GC, 'GEOS_GwdGridComp', wrap, _RC ) + + ! Set generic init and final methods + ! ---------------------------------- + + call MAPL_GenericSetServices ( gc, _RC) + + RETURN_(ESMF_SUCCESS) + + end subroutine SetServices !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !BOP + !BOP - ! !IROUTINE: Initialize -- Initialize method for the composite Moist Gridded Component + ! !IROUTINE: Initialize -- Initialize method for the composite Moist Gridded Component - ! !INTERFACE: + ! !INTERFACE: - subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) + subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) - ! !ARGUMENTS: + ! !ARGUMENTS: - type(ESMF_GridComp), intent(inout) :: GC ! Gridded component - type(ESMF_State), intent(inout) :: IMPORT ! Import state - type(ESMF_State), intent(inout) :: EXPORT ! Export state - type(ESMF_Clock), intent(inout) :: CLOCK ! The clock - integer, optional, intent( out) :: RC ! Error code + type(ESMF_GridComp), intent(inout) :: GC ! Gridded component + type(ESMF_State), intent(inout) :: IMPORT ! Import state + type(ESMF_State), intent(inout) :: EXPORT ! Export state + type(ESMF_Clock), intent(inout) :: CLOCK ! The clock + integer, optional, intent( out) :: RC ! Error code - ! !DESCRIPTION: The Initialize method of the GWD Physics Gridded Component first - ! calls the Initialize method of the children. Then, if using the NCAR GWD - ! scheme, calls the initialization routines. + ! !DESCRIPTION: The Initialize method of the GWD Physics Gridded Component first + ! calls the Initialize method of the children. Then, if using the NCAR GWD + ! scheme, calls the initialization routines. - !EOP + !EOP -!============================================================================= -! -! ErrLog Variables + !============================================================================= + ! + ! ErrLog Variables - character(len=ESMF_MAXSTR) :: IAm - integer :: STATUS - character(len=ESMF_MAXSTR) :: COMP_NAME + character(len=ESMF_MAXSTR) :: IAm + integer :: STATUS + character(len=ESMF_MAXSTR) :: COMP_NAME -! Local derived type aliases + ! Local derived type aliases - type (MAPL_MetaComp), pointer :: MAPL + type (MAPL_MetaComp), pointer :: MAPL - integer :: IM, JM - real, pointer, dimension(:,:) :: LATS + integer :: IM, JM + real, pointer, dimension(:,:) :: LATS - character(len=ESMF_MAXSTR) :: GRIDNAME - character(len=4) :: imchar - character(len=2) :: dateline - integer :: imsize,nn - integer :: LM - real :: sigma,STRETCH_FACTOR + character(len=ESMF_MAXSTR) :: GRIDNAME + character(len=4) :: imchar + character(len=2) :: dateline + integer :: imsize,nn + integer :: LM + real :: sigma,STRETCH_FACTOR - real, pointer, dimension(:) :: PREF + real, pointer, dimension(:) :: PREF -! NCAR GWD variables + ! NCAR GWD variables - character(len=ESMF_MAXPATHLEN) :: BERES_FILE_NAME - character(len=ESMF_MAXSTR) :: ERRstring + character(len=ESMF_MAXPATHLEN) :: BERES_FILE_NAME + character(len=ESMF_MAXSTR) :: ERRstring - logical :: JASON_BKG, JASON_ORO - logical :: NCAR_TAU_TOP_ZERO - real :: NCAR_PRNDL - real :: NCAR_QBO_HDEPTH_SCALING - integer :: NCAR_ORO_PGWV, NCAR_BKG_PGWV - real :: NCAR_ORO_GW_DC, NCAR_BKG_GW_DC - real :: NCAR_ORO_FCRIT2, NCAR_BKG_FCRIT2 - real :: NCAR_ORO_WAVELENGTH, NCAR_BKG_WAVELENGTH - real :: NCAR_ORO_SOUTH_FAC - real :: NCAR_ORO_TNDMAX - real :: NCAR_BKG_TNDMAX - real :: NCAR_HR_CF ! Grid cell convective conversion factor - real :: NCAR_ET_TAUBGND ! Extratropical background frontal forcing - logical :: NCAR_ET_USELATS - logical :: NCAR_DC_BERES - integer :: GEOS_PGWV - real :: NCAR_EFFGWBKG - real :: NCAR_DC_BERES_SRC_LEVEL + logical :: JASON_BKG, JASON_ORO + logical :: NCAR_TAU_TOP_ZERO + real :: NCAR_PRNDL + real :: NCAR_QBO_HDEPTH_SCALING + integer :: NCAR_ORO_PGWV, NCAR_BKG_PGWV + real :: NCAR_ORO_GW_DC, NCAR_BKG_GW_DC + real :: NCAR_ORO_FCRIT2, NCAR_BKG_FCRIT2 + real :: NCAR_ORO_WAVELENGTH, NCAR_BKG_WAVELENGTH + real :: NCAR_ORO_SOUTH_FAC + real :: NCAR_ORO_TNDMAX + real :: NCAR_BKG_TNDMAX + real :: NCAR_HR_CF ! Grid cell convective conversion factor + real :: NCAR_ET_TAUBGND ! Extratropical background frontal forcing + logical :: NCAR_ET_USELATS + logical :: NCAR_DC_BERES + integer :: GEOS_PGWV + real :: NCAR_EFFGWBKG + real :: NCAR_DC_BERES_SRC_LEVEL - type (wrap_) :: wrap - type (GEOS_GwdGridComp), pointer :: self - integer :: num_threads, thread + type (wrap_) :: wrap + type (GEOS_GwdGridComp), pointer :: self + integer :: num_threads, thread - type(MAPL_Interval), allocatable :: bounds(:) - integer :: JM_thread + type(MAPL_Interval), allocatable :: bounds(:) + integer :: JM_thread -!============================================================================= + !============================================================================= - ! Begin... + ! Begin... - ! Get my name and set-up traceback handle - ! --------------------------------------- + ! Get my name and set-up traceback handle + ! --------------------------------------- Iam = 'Initialize' call ESMF_GridCompGet( GC, NAME=COMP_NAME, _RC ) @@ -799,9 +275,9 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) !----------------------------------- call MAPL_GetObjectFromGC ( GC, MAPL, _RC ) - -! Get my internal private state -! ----------------------------- + + ! Get my internal private state + ! ----------------------------- call ESMF_UserCompGetInternalState(GC, 'GEOS_GwdGridComp', wrap, _RC) self => wrap%ptr @@ -809,12 +285,12 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) !----------------------------------- call MAPL_GenericInitialize ( GC, IMPORT, EXPORT, CLOCK, _RC ) - + call MAPL_Get(MAPL, IM=IM, JM=JM, LM=LM, LATS=LATS, _RC) - - ! Get grid name to determine IMSIZE + + ! Get grid name to determine IMSIZE call MAPL_GetResource(MAPL,GRIDNAME,'AGCM.GRIDNAME:', _RC) - GRIDNAME = AdjustL(GRIDNAME) + GRIDNAME = AdjustL(GRIDNAME) nn = len_trim(GRIDNAME) dateline = GRIDNAME(nn-1:nn) imchar = GRIDNAME(3:index(GRIDNAME,'x')-1) @@ -824,65 +300,65 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) imsize = imsize*CEILING(STRETCH_FACTOR) sigma = 1.0-0.9839*exp(-0.09835*4.e7*0.9/imsize/1000.) ! Based on Arakawa 2011 sigma used in GF2020 -! Background Gravity wave drag -! ---------------------------- + ! Background Gravity wave drag + ! ---------------------------- call MAPL_GetResource(MAPL,JASON_BKG,'JASON_BKG:', default=(LM==72), _RC) if (JASON_BKG) then - GEOS_PGWV = 4 - call MAPL_GetResource( MAPL, self%GEOS_PGWV, Label="GEOS_PGWV:", default=GEOS_PGWV, _RC) - call MAPL_GetResource( MAPL, self%GEOS_BGSTRESS, Label="GEOS_BGSTRESS:", default=0.900, _RC) - call MAPL_GetResource( MAPL, self%GEOS_EFFGWBKG, Label="GEOS_EFFGWBKG:", default=0.125, _RC) - call MAPL_GetResource( MAPL, self%NCAR_EFFGWBKG, Label="NCAR_EFFGWBKG:", default=0.000, _RC) - call MAPL_GetResource( MAPL, self%TAU1, Label="RAYLEIGH_TAU1:", default=172800., _RC) + GEOS_PGWV = 4 + call MAPL_GetResource( MAPL, self%GEOS_PGWV, Label="GEOS_PGWV:", default=GEOS_PGWV, _RC) + call MAPL_GetResource( MAPL, self%GEOS_BGSTRESS, Label="GEOS_BGSTRESS:", default=0.900, _RC) + call MAPL_GetResource( MAPL, self%GEOS_EFFGWBKG, Label="GEOS_EFFGWBKG:", default=0.125, _RC) + call MAPL_GetResource( MAPL, self%NCAR_EFFGWBKG, Label="NCAR_EFFGWBKG:", default=0.000, _RC) + call MAPL_GetResource( MAPL, self%TAU1, Label="RAYLEIGH_TAU1:", default=172800., _RC) else - GEOS_PGWV = NINT(32*LM/181.0) - call MAPL_GetResource( MAPL, self%GEOS_PGWV, Label="GEOS_PGWV:", default=GEOS_PGWV, _RC) - call MAPL_GetResource( MAPL, self%GEOS_BGSTRESS, Label="GEOS_BGSTRESS:", default=0.000, _RC) - call MAPL_GetResource( MAPL, self%GEOS_EFFGWBKG, Label="GEOS_EFFGWBKG:", default=0.000, _RC) - self%NCAR_EFFGWBKG = 1.0 !(1.0 - 0.5*sigma) - call MAPL_GetResource( MAPL, self%NCAR_EFFGWBKG, Label="NCAR_EFFGWBKG:", default=self%NCAR_EFFGWBKG, _RC) - call MAPL_GetResource( MAPL, self%TAU1, Label="RAYLEIGH_TAU1:", default=0.00, _RC) + GEOS_PGWV = NINT(32*LM/181.0) + call MAPL_GetResource( MAPL, self%GEOS_PGWV, Label="GEOS_PGWV:", default=GEOS_PGWV, _RC) + call MAPL_GetResource( MAPL, self%GEOS_BGSTRESS, Label="GEOS_BGSTRESS:", default=0.000, _RC) + call MAPL_GetResource( MAPL, self%GEOS_EFFGWBKG, Label="GEOS_EFFGWBKG:", default=0.000, _RC) + self%NCAR_EFFGWBKG = 1.0 !(1.0 - 0.5*sigma) + call MAPL_GetResource( MAPL, self%NCAR_EFFGWBKG, Label="NCAR_EFFGWBKG:", default=self%NCAR_EFFGWBKG, _RC) + call MAPL_GetResource( MAPL, self%TAU1, Label="RAYLEIGH_TAU1:", default=0.00, _RC) endif -! Orographic Gravity wave drag -! ---------------------------- + ! Orographic Gravity wave drag + ! ---------------------------- call MAPL_GetResource(MAPL,JASON_ORO,'JASON_ORO:', default=(LM==72), _RC) if (JASON_ORO) then - call MAPL_GetResource( MAPL, self%GEOS_EFFGWORO, Label="GEOS_EFFGWORO:", default=0.250, _RC) - call MAPL_GetResource( MAPL, self%NCAR_EFFGWORO, Label="NCAR_EFFGWORO:", default=0.000, _RC) - call MAPL_GetResource( MAPL, self%NCAR_NRDG, Label="NCAR_NRDG:", default=0, _RC) + call MAPL_GetResource( MAPL, self%GEOS_EFFGWORO, Label="GEOS_EFFGWORO:", default=0.250, _RC) + call MAPL_GetResource( MAPL, self%NCAR_EFFGWORO, Label="NCAR_EFFGWORO:", default=0.000, _RC) + call MAPL_GetResource( MAPL, self%NCAR_NRDG, Label="NCAR_NRDG:", default=0, _RC) else - call MAPL_GetResource( MAPL, self%GEOS_EFFGWORO, Label="GEOS_EFFGWORO:", default=0.000, _RC) - call MAPL_GetResource( MAPL, self%NCAR_EFFGWORO, Label="NCAR_EFFGWORO:", default=1.000, _RC) - call MAPL_GetResource( MAPL, self%NCAR_NRDG, Label="NCAR_NRDG:", default=16, _RC) + call MAPL_GetResource( MAPL, self%GEOS_EFFGWORO, Label="GEOS_EFFGWORO:", default=0.000, _RC) + call MAPL_GetResource( MAPL, self%NCAR_EFFGWORO, Label="NCAR_EFFGWORO:", default=1.000, _RC) + call MAPL_GetResource( MAPL, self%NCAR_NRDG, Label="NCAR_NRDG:", default=16, _RC) endif -! Rayleigh friction -! ----------------- + ! Rayleigh friction + ! ----------------- if (self%TAU1 > 0.0) then - call MAPL_GetResource( MAPL, self%Z1, Label="RAYLEIGH_Z1:", default=75000., _RC) - call MAPL_GetResource( MAPL, self%H0, Label="RAYLEIGH_H0:", default=7000., _RC) - call MAPL_GetResource( MAPL, self%HH, Label="RAYLEIGH_HH:", default=7500., _RC) + call MAPL_GetResource( MAPL, self%Z1, Label="RAYLEIGH_Z1:", default=75000., _RC) + call MAPL_GetResource( MAPL, self%H0, Label="RAYLEIGH_H0:", default=7000., _RC) + call MAPL_GetResource( MAPL, self%HH, Label="RAYLEIGH_HH:", default=7500., _RC) endif -! NCAR GWD settings -! ----------------- + ! NCAR GWD settings + ! ----------------- call MAPL_GetResource( MAPL, NCAR_TAU_TOP_ZERO, Label="NCAR_TAU_TOP_ZERO:", default=.true., _RC) call MAPL_GetResource( MAPL, NCAR_PRNDL, Label="NCAR_PRNDL:", default=0.50, _RC) - NCAR_QBO_HDEPTH_SCALING = 1.0 - 0.25*sigma + NCAR_QBO_HDEPTH_SCALING = 1.0 - 0.25*sigma call MAPL_GetResource( MAPL, NCAR_QBO_HDEPTH_SCALING, Label="NCAR_QBO_HDEPTH_SCALING:", default=NCAR_QBO_HDEPTH_SCALING, _RC) - NCAR_HR_CF = CEILING(30.0*sigma) + NCAR_HR_CF = CEILING(30.0*sigma) call MAPL_GetResource( MAPL, NCAR_HR_CF, Label="NCAR_HR_CF:", default=NCAR_HR_CF, _RC) - + call gw_common_init( NCAR_TAU_TOP_ZERO , 1 , & - MAPL_GRAV , & - MAPL_RGAS , & - MAPL_CP , & - NCAR_PRNDL, NCAR_QBO_HDEPTH_SCALING, NCAR_HR_CF, ERRstring ) + MAPL_GRAV , & + MAPL_RGAS , & + MAPL_CP , & + NCAR_PRNDL, NCAR_QBO_HDEPTH_SCALING, NCAR_HR_CF, ERRstring ) ! Beres Scheme File call MAPL_GetResource( MAPL, BERES_FILE_NAME, Label="BERES_FILE_NAME:", & - default='ExtData/g5gcm/gwd/newmfspectra40_dc25.nc', _RC) + default='ExtData/g5gcm/gwd/newmfspectra40_dc25.nc', _RC) call MAPL_GetResource( MAPL, NCAR_BKG_PGWV, Label="NCAR_BKG_PGWV:", default=32, _RC) call MAPL_GetResource( MAPL, NCAR_BKG_GW_DC, Label="NCAR_BKG_GW_DC:", default=2.5, _RC) call MAPL_GetResource( MAPL, NCAR_BKG_FCRIT2, Label="NCAR_BKG_FCRIT2:", default=1.0, _RC) @@ -897,14 +373,14 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) num_threads = MAPL_get_num_threads() bounds = MAPL_find_bounds(JM, num_threads) do thread = 0, num_threads-1 - JM_thread = bounds(thread+1)%max - bounds(thread+1)%min + 1 - call gw_beres_init( BERES_FILE_NAME , & - self%workspaces(thread)%beres_band, & - self%workspaces(thread)%beres_dc_desc, & - NCAR_BKG_PGWV, NCAR_BKG_GW_DC, NCAR_BKG_FCRIT2, & - NCAR_BKG_WAVELENGTH, NCAR_DC_BERES_SRC_LEVEL, & - 1000.0, .TRUE., NCAR_ET_TAUBGND, NCAR_ET_USELATS, NCAR_BKG_TNDMAX, NCAR_DC_BERES, & - IM*JM_thread, LATS(:,bounds(thread+1)%min:bounds(thread+1)%max)) + JM_thread = bounds(thread+1)%max - bounds(thread+1)%min + 1 + call gw_beres_init( BERES_FILE_NAME , & + self%workspaces(thread)%beres_band, & + self%workspaces(thread)%beres_dc_desc, & + NCAR_BKG_PGWV, NCAR_BKG_GW_DC, NCAR_BKG_FCRIT2, & + NCAR_BKG_WAVELENGTH, NCAR_DC_BERES_SRC_LEVEL, & + 1000.0, .TRUE., NCAR_ET_TAUBGND, NCAR_ET_USELATS, NCAR_BKG_TNDMAX, NCAR_DC_BERES, & + IM*JM_thread, LATS(:,bounds(thread+1)%min:bounds(thread+1)%max)) end do ! Orographic Scheme @@ -913,20 +389,20 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetResource( MAPL, NCAR_ORO_FCRIT2, Label="NCAR_ORO_FCRIT2:", default=1.0, _RC) call MAPL_GetResource( MAPL, NCAR_ORO_WAVELENGTH, Label="NCAR_ORO_WAVELENGTH:", default=1.e5, _RC) if (self%NCAR_NRDG > 0) then - ! Ridge Scheme - call MAPL_GetResource( MAPL, NCAR_ORO_TNDMAX, Label="NCAR_ORO_TNDMAX:", default=400.0, _RC) - NCAR_ORO_TNDMAX = NCAR_ORO_TNDMAX/86400.0 - do thread = 0, num_threads-1 - call gw_rdg_init ( self%workspaces(thread)%rdg_band, NCAR_ORO_GW_DC, NCAR_ORO_FCRIT2, NCAR_ORO_WAVELENGTH, NCAR_ORO_TNDMAX, NCAR_ORO_PGWV ) - end do + ! Ridge Scheme + call MAPL_GetResource( MAPL, NCAR_ORO_TNDMAX, Label="NCAR_ORO_TNDMAX:", default=400.0, _RC) + NCAR_ORO_TNDMAX = NCAR_ORO_TNDMAX/86400.0 + do thread = 0, num_threads-1 + call gw_rdg_init ( self%workspaces(thread)%rdg_band, NCAR_ORO_GW_DC, NCAR_ORO_FCRIT2, NCAR_ORO_WAVELENGTH, NCAR_ORO_TNDMAX, NCAR_ORO_PGWV ) + end do else - ! Old Scheme - call MAPL_GetResource( MAPL, NCAR_ORO_SOUTH_FAC, Label="NCAR_ORO_SOUTH_FAC:", default=2.0, _RC) - do thread = 0, num_threads-1 - call gw_oro_init ( self%workspaces(thread)%oro_band, NCAR_ORO_GW_DC, & - NCAR_ORO_FCRIT2, NCAR_ORO_WAVELENGTH, NCAR_ORO_PGWV, & - NCAR_ORO_SOUTH_FAC ) - end do + ! Old Scheme + call MAPL_GetResource( MAPL, NCAR_ORO_SOUTH_FAC, Label="NCAR_ORO_SOUTH_FAC:", default=2.0, _RC) + do thread = 0, num_threads-1 + call gw_oro_init ( self%workspaces(thread)%oro_band, NCAR_ORO_GW_DC, & + NCAR_ORO_FCRIT2, NCAR_ORO_WAVELENGTH, NCAR_ORO_PGWV, & + NCAR_ORO_SOUTH_FAC ) + end do endif allocate(self%alpha(LM+1), _STAT) @@ -940,366 +416,244 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) end subroutine Initialize !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!BOP + !BOP -! !IROUTINE: RUN -- Run method for the GWD component + ! !IROUTINE: RUN -- Run method for the GWD component -! !INTERFACE: -subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) + ! !INTERFACE: + subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) -! !ARGUMENTS: - type(ESMF_GridComp), intent(inout) :: GC ! Gridded component - type(ESMF_State), intent(inout) :: IMPORT ! Import state - type(ESMF_State), intent(inout) :: EXPORT ! Export state - type(ESMF_Clock), intent(inout) :: CLOCK ! The clock - integer, optional, intent( out) :: RC ! Error code: + ! !ARGUMENTS: + type(ESMF_GridComp), intent(inout) :: GC ! Gridded component + type(ESMF_State), intent(inout) :: IMPORT ! Import state + type(ESMF_State), intent(inout) :: EXPORT ! Export state + type(ESMF_Clock), intent(inout) :: CLOCK ! The clock + integer, optional, intent( out) :: RC ! Error code: -! !DESCRIPTION: This version uses the MAPL\_GenericSetServices. This function sets -! the Initialize and Finalize services, as well as allocating + ! !DESCRIPTION: This version uses the MAPL\_GenericSetServices. This function sets + ! the Initialize and Finalize services, as well as allocating -!EOP + !EOP -! ErrLog Variables + ! ErrLog Variables - character(len=ESMF_MAXSTR) :: IAm - integer :: STATUS - character(len=ESMF_MAXSTR) :: COMP_NAME + character(len=ESMF_MAXSTR) :: IAm + integer :: STATUS + character(len=ESMF_MAXSTR) :: COMP_NAME -! Local derived type aliases + ! Local derived type aliases - type (MAPL_MetaComp), pointer :: MAPL - type (ESMF_Alarm ) :: ALARM - type (ESMF_Grid ) :: ESMFGRID + type (MAPL_MetaComp), pointer :: MAPL + type (ESMF_Alarm ) :: ALARM + type (ESMF_Grid ) :: ESMFGRID - integer :: IM, JM, LM - !integer :: pgwv - real :: tcrib - !real :: effgworo, effgwbkg - !real :: CDMBGWD1, CDMBGWD2 - !real :: bgstressmax - real, pointer, dimension(:,:) :: LATS + integer :: IM, JM, LM + !integer :: pgwv + real :: tcrib + !real :: effgworo, effgwbkg + !real :: CDMBGWD1, CDMBGWD2 + !real :: bgstressmax + real, pointer, dimension(:,:) :: LATS -! Rayleigh friction parameters + ! Rayleigh friction parameters - REAL :: H0, HH, Z1, TAU1 + REAL :: H0, HH, Z1, TAU1 - type (wrap_) :: wrap - type (GEOS_GwdGridComp), pointer :: self - type(ThreadWorkspace), pointer :: workspace - integer :: thread + type (wrap_) :: wrap + type (GEOS_GwdGridComp), pointer :: self + type(ThreadWorkspace), pointer :: workspace + integer :: thread -!============================================================================= + !============================================================================= -! Begin... + ! Begin... -! Get the target components name and set-up traceback handle. -! ----------------------------------------------------------- + ! Get the target components name and set-up traceback handle. + ! ----------------------------------------------------------- - Iam = "Run" - !call ESMF_GridCompGet( GC, name=COMP_NAME, grid=ESMFGRID, _RC ) - call ESMF_GridCompGet( GC, name=COMP_NAME, _RC ) - Iam = trim(COMP_NAME) // Iam + Iam = "Run" + !call ESMF_GridCompGet( GC, name=COMP_NAME, grid=ESMFGRID, _RC ) + call ESMF_GridCompGet( GC, name=COMP_NAME, _RC ) + Iam = trim(COMP_NAME) // Iam -! Retrieve the pointer to the state -!---------------------------------- + ! Retrieve the pointer to the state + !---------------------------------- - call MAPL_GetObjectFromGC ( GC, MAPL, _RC) - -! Get my internal private state -! ----------------------------- - call ESMF_UserCompGetInternalState(GC, 'GEOS_GwdGridComp', wrap, _RC) - self => wrap%ptr + call MAPL_GetObjectFromGC ( GC, MAPL, _RC) - H0 = self%H0 - HH = self%HH - Z1 = self%Z1 - TAU1 = self%TAU1 + ! Get my internal private state + ! ----------------------------- + call ESMF_UserCompGetInternalState(GC, 'GEOS_GwdGridComp', wrap, _RC) + self => wrap%ptr -! Local aliases to the state, grid, and configuration -! --------------------------------------------------- + H0 = self%H0 + HH = self%HH + Z1 = self%Z1 + TAU1 = self%TAU1 - !call MAPL_TimerOn(MAPL,"TOTAL") + ! Local aliases to the state, grid, and configuration + ! --------------------------------------------------- -! Get parameters from generic state. -!----------------------------------- + !call MAPL_TimerOn(MAPL,"TOTAL") - call MAPL_Get(MAPL, & - IM=IM, JM=JM, LM=LM, & - RUNALARM=ALARM, LATS=LATS, & - _RC ) + ! Get parameters from generic state. + !----------------------------------- + + call MAPL_Get(MAPL, & + IM=IM, JM=JM, LM=LM, & + RUNALARM=ALARM, LATS=LATS, & + _RC ) -! If its time, recalculate the GWD tendency -! ----------------------------------------- + ! If its time, recalculate the GWD tendency + ! ----------------------------------------- - if ( ESMF_AlarmIsRinging( ALARM ) ) then - !call ESMF_AlarmRingerOff(ALARM, _RC) - !call MAPL_TimerOn (MAPL,"DRIVER") - call Gwd_Driver(_RC) - !call MAPL_TimerOff(MAPL,"DRIVER") - endif + if ( ESMF_AlarmIsRinging( ALARM ) ) then + !call ESMF_AlarmRingerOff(ALARM, _RC) + !call MAPL_TimerOn (MAPL,"DRIVER") + call Gwd_Driver(_RC) + !call MAPL_TimerOff(MAPL,"DRIVER") + endif - !call MAPL_TimerOff(MAPL,"TOTAL") + !call MAPL_TimerOff(MAPL,"TOTAL") - RETURN_(ESMF_SUCCESS) + RETURN_(ESMF_SUCCESS) contains !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine Gwd_Driver(RC) - integer, optional, intent(OUT) :: RC - -! Locals + integer, optional, intent(OUT) :: RC - character(len=ESMF_MAXSTR) :: IAm - integer :: STATUS + ! Locals - type (ESMF_TimeInterval) :: TINT + character(len=ESMF_MAXSTR) :: IAm + integer :: STATUS -! Pointers from Import state + type (ESMF_TimeInterval) :: TINT - real, pointer, dimension(:) :: PREF - real, pointer, dimension(:,:) :: AREA, SGH, VARFLT, PHIS - real, pointer, dimension(:,:,:) :: PLE, T, Q, U, V - ! Array for moist deep conv heating - real, pointer, dimension(:,:,:) :: HT_dc - ! Arrays for QL and QI condensate tendencies from Moist - real, pointer, dimension(:,:,:) :: DQLDT, DQIDT - real, pointer, dimension(:,:) :: CNV_FRC - !++jtb pointers for NCAR Orographic GWP - ! (in Internal State) - real, pointer, dimension(:,:,:) :: MXDIS - real, pointer, dimension(:,:,:) :: CLNGT - real, pointer, dimension(:,:,:) :: HWDTH - real, pointer, dimension(:,:,:) :: ANGLL - real, pointer, dimension(:,:,:) :: ANIXY - real, pointer, dimension(:,:) :: GBXAR - real, pointer, dimension(:,:,:) :: KWVRDG - real, pointer, dimension(:,:,:) :: EFFRDG - -! Pointers to Export state - - real, pointer, dimension(:) :: PREF_EXP - real, pointer, dimension(:,:) :: SGH_EXP - real, pointer, dimension(:,:,:) :: PLE_EXP, T_EXP, Q_EXP, U_EXP, V_EXP - - real, pointer, dimension(:,:) :: CLDSTD - real, pointer, dimension(:,:) :: UBAR, VBAR - real, pointer, dimension(:,:) :: UBASE, VBASE - real, pointer, dimension(:,:) :: TAUGWX, TAUGWY - real, pointer, dimension(:,:) :: TAUOROX, TAUOROY - real, pointer, dimension(:,:) :: TAUBKGX, TAUBKGY - real, pointer, dimension(:,:,:) :: TAUOROXZ,TAUOROYZ,FEOROZ,FEPOROZ - real, pointer, dimension(:,:,:) :: TAUBKGXZ,TAUBKGYZ,FEBKGZ,FEPBKGZ - real, pointer, dimension(:,:) :: TAUOROXT,TAUOROYT,FEOROT,FEPOROT - real, pointer, dimension(:,:) :: TAUOROXS,TAUOROYS,FEOROS,FEPOROS - real, pointer, dimension(:,:) :: TAUBKGXT,TAUBKGYT,FEBKGT,FEPBKGT - real, pointer, dimension(:,:) :: TAUBKGXS,TAUBKGYS,FEBKGS,FEPBKGS - real, pointer, dimension(:,:) :: TAUMSTX, TAUMSTY - real, pointer, dimension(:,:) :: KEGWD, KEORO, KERAY, KEBKG, KERES - real, pointer, dimension(:,:) :: PEGWD, PEORO, PERAY, PEBKG, BKGERR - - real, pointer, dimension(:,:,:) :: DTDT, DUDT, DVDT, TTMGW - real, pointer, dimension(:,:,:) :: DTDT_ORO, DUDT_ORO, DVDT_ORO - real, pointer, dimension(:,:,:) :: DTDT_BKG, DUDT_BKG, DVDT_BKG - real, pointer, dimension(:,:,:) :: DTDT_RAY, DUDT_RAY, DVDT_RAY - real, pointer, dimension(:,:,:) :: DTGENBKG, DUGENBKG, DVGENBKG - - real, pointer, dimension(:,:,:) :: TMP3D - real, pointer, dimension(:,:) :: TMP2D - -! local variables - - real, dimension(IM,JM,LM ) :: DQCDT_LS - real, dimension(IM,JM,LM ) :: ZM, PMID, PDEL, RPDEL, PMLN - real, dimension(IM,JM ) :: a2, Hefold - real, dimension(IM,JM,LM ) :: DUDT_ORG, DVDT_ORG, DTDT_ORG - real, dimension(IM,JM,LM ) :: DUDT_GWD, DVDT_GWD, DTDT_GWD - real, dimension(IM,JM,LM ) :: DUDT_RAH, DVDT_RAH, DTDT_RAH - real, dimension(IM,JM,LM ) :: DUDT_TOT, DVDT_TOT, DTDT_TOT - real, dimension(IM,JM,LM+1) :: PILN, ZI - real, dimension( LM ) :: ZREF, KRAY - real, dimension(IM,JM ) :: GBXAR_TMP - real, dimension(IM,JM ) :: TAUXO_TMP, TAUYO_TMP - real, dimension(IM,JM ) :: TAUXB_TMP, TAUYB_TMP - real, dimension(IM,JM,LM+1) :: TAUXO_3D , TAUYO_3D , FEO_3D, FEPO_3D - real, dimension(IM,JM,LM+1) :: TAUXB_3D , TAUYB_3D , FEB_3D, FEPB_3D - real, dimension(IM,JM,LM ) :: DUBKGSRC , DVBKGSRC , DTBKGSRC - real, dimension(IM,JM) :: KEGWD_X, KEORO_X, KERAY_X, KEBKG_X, KERES_X - real, dimension(IM,JM) :: PEGWD_X, PEORO_X, PERAY_X, PEBKG_X, BKGERR_X - - real, dimension(IM,JM,LM ) :: DUDT_GWD_GEOS , DVDT_GWD_GEOS , DTDT_GWD_GEOS - real, dimension(IM,JM,LM ) :: DUDT_ORG_GEOS , DVDT_ORG_GEOS , DTDT_ORG_GEOS - real, dimension(IM,JM ) :: TAUXB_TMP_GEOS, TAUYB_TMP_GEOS - real, dimension(IM,JM ) :: TAUXO_TMP_GEOS, TAUYO_TMP_GEOS - - real, dimension(IM,JM,LM ) :: DUDT_GWD_NCAR , DVDT_GWD_NCAR , DTDT_GWD_NCAR - real, dimension(IM,JM,LM ) :: DUDT_ORG_NCAR , DVDT_ORG_NCAR , DTDT_ORG_NCAR - real, dimension(IM,JM ) :: TAUXB_TMP_NCAR, TAUYB_TMP_NCAR - real, dimension(IM,JM ) :: TAUXO_TMP_NCAR, TAUYO_TMP_NCAR - - integer :: J, K, L, nrdg, ikpbl - real(ESMF_KIND_R8) :: DT_R8 - real :: DT ! time interval in sec - real :: a1, wsp, var_temp - !real, allocatable :: THV(:,:,:) - real :: THV(IM,JM,LM) - - integer :: I,IRUN - type (ESMF_State) :: INTERNAL - -! Begin... -!---------- - - IAm = "Gwd_Driver" - -! Get time step -!------------------------------------------------- - - call ESMF_AlarmGet( ALARM, ringInterval=TINT, _RC) - call ESMF_TimeIntervalGet(TINT, S_R8=DT_R8, _RC) - - DT = DT_R8 - -! Pointers to inputs -!--------------------- - - call MAPL_GetPointer( IMPORT, PLE, 'PLE', _RC ) - call MAPL_GetPointer( IMPORT, T, 'T', _RC ) - call MAPL_GetPointer( IMPORT, Q, 'Q', _RC ) - call MAPL_GetPointer( IMPORT, U, 'U', _RC ) - call MAPL_GetPointer( IMPORT, V, 'V', _RC ) - call MAPL_GetPointer( IMPORT, PHIS, 'PHIS', _RC ) - call MAPL_GetPointer( IMPORT, SGH, 'SGH', _RC ) - call MAPL_GetPointer( IMPORT, PREF, 'PREF', _RC ) - call MAPL_GetPointer( IMPORT, AREA, 'AREA', _RC ) - call MAPL_GetPointer( IMPORT, VARFLT, 'VARFLT', _RC ) - call MAPL_GetPointer( IMPORT, HT_dc, 'DTDT_DC', _RC ) - call MAPL_GetPointer( IMPORT, DQLDT, 'DQLDT' , _RC ) - call MAPL_GetPointer( IMPORT, DQIDT, 'DQIDT' , _RC ) - call MAPL_GetPointer( IMPORT, CNV_FRC, 'CNV_FRC', _RC ) - -! Allocate/refer to the outputs -!------------------------------ - - call MAPL_GetPointer(EXPORT, PLE_EXP, 'PLE' , _RC) - call MAPL_GetPointer(EXPORT, T_EXP, 'T' , _RC) - call MAPL_GetPointer(EXPORT, Q_EXP, 'Q' , _RC) - call MAPL_GetPointer(EXPORT, U_EXP, 'U' , _RC) - call MAPL_GetPointer(EXPORT, V_EXP, 'V' , _RC) - call MAPL_GetPointer(EXPORT, SGH_EXP, 'SGH' , _RC) - call MAPL_GetPointer(EXPORT, PREF_EXP, 'PREF' , _RC) - call MAPL_GetPointer(EXPORT, TTMGW, 'TTMGW' , _RC) - call MAPL_GetPointer(EXPORT, DTDT_ORO, 'DTDT_ORO', _RC) - call MAPL_GetPointer(EXPORT, DUDT_ORO, 'DUDT_ORO', _RC) - call MAPL_GetPointer(EXPORT, DVDT_ORO, 'DVDT_ORO', _RC) - call MAPL_GetPointer(EXPORT, DTDT_BKG, 'DTDT_BKG', _RC) - call MAPL_GetPointer(EXPORT, DUDT_BKG, 'DUDT_BKG', _RC) - call MAPL_GetPointer(EXPORT, DVDT_BKG, 'DVDT_BKG', _RC) - call MAPL_GetPointer(EXPORT, DTDT_RAY, 'DTDT_RAY', _RC) - call MAPL_GetPointer(EXPORT, DUDT_RAY, 'DUDT_RAY', _RC) - call MAPL_GetPointer(EXPORT, DVDT_RAY, 'DVDT_RAY', _RC) - call MAPL_GetPointer(EXPORT, TAUGWX, 'TAUGWX' , _RC) - call MAPL_GetPointer(EXPORT, TAUGWY, 'TAUGWY' , _RC) - call MAPL_GetPointer(EXPORT, TAUOROX, 'TAUOROX' , _RC) - call MAPL_GetPointer(EXPORT, TAUOROY, 'TAUOROY' , _RC) - call MAPL_GetPointer(EXPORT, TAUBKGX, 'TAUBKGX' , _RC) - call MAPL_GetPointer(EXPORT, TAUBKGY, 'TAUBKGY' , _RC) - call MAPL_GetPointer(EXPORT, TAUMSTX, 'TAUMSTX' , _RC) - call MAPL_GetPointer(EXPORT, TAUMSTY, 'TAUMSTY' , _RC) - call MAPL_GetPointer(EXPORT, UBASE, 'UBASE' , _RC) - call MAPL_GetPointer(EXPORT, VBASE, 'VBASE' , _RC) - call MAPL_GetPointer(EXPORT, UBAR, 'UBAR' , _RC) - call MAPL_GetPointer(EXPORT, VBAR, 'VBAR' , _RC) - call MAPL_GetPointer(EXPORT, CLDSTD, 'CLDSTD' , _RC) - - call MAPL_GetPointer(EXPORT, DTDT, 'DTDT' , _RC) - call MAPL_GetPointer(EXPORT, DUDT, 'DUDT' , _RC) - call MAPL_GetPointer(EXPORT, DVDT, 'DVDT' , _RC) - - call MAPL_GetPointer(EXPORT, PEGWD, 'PEGWD' , _RC) - call MAPL_GetPointer(EXPORT, PEORO, 'PEORO' , _RC) - call MAPL_GetPointer(EXPORT, PERAY, 'PERAY' , _RC) - call MAPL_GetPointer(EXPORT, PEBKG, 'PEBKG' , _RC) - - call MAPL_GetPointer(EXPORT, KEGWD, 'KEGWD' , _RC) - call MAPL_GetPointer(EXPORT, KEORO, 'KEORO' , _RC) - call MAPL_GetPointer(EXPORT, KERAY, 'KERAY' , _RC) - call MAPL_GetPointer(EXPORT, KEBKG, 'KEBKG' , _RC) - call MAPL_GetPointer(EXPORT, KERES, 'KERES' , _RC) - call MAPL_GetPointer(EXPORT, BKGERR, 'BKGERR' , _RC) - - - CALL PREGEO(IM*JM, LM, & - PLE, LATS, PMID, PDEL, RPDEL, PILN, PMLN) - -! Compute ZM -!------------- - - call GEOPOTENTIAL( IM*JM, LM, & - PILN, PMLN, PLE, PMID, PDEL, RPDEL, & - T, Q, ZI, ZM ) - -! Do gravity wave drag calculations on a list of soundings -!--------------------------------------------------------- - - !call MAPL_TimerOn(MAPL,"-INTR") - - ! get pointers from INTERNAL:MXDIS - call MAPL_Get(MAPL, INTERNAL_ESMF_STATE=INTERNAL, _RC) - call MAPL_GetPointer( INTERNAL, MXDIS, 'MXDIS', _RC ) - call MAPL_GetPointer( INTERNAL, HWDTH, 'HWDTH', _RC ) - call MAPL_GetPointer( INTERNAL, CLNGT, 'CLNGT', _RC ) - call MAPL_GetPointer( INTERNAL, ANGLL, 'ANGLL', _RC ) - call MAPL_GetPointer( INTERNAL, ANIXY, 'ANIXY', _RC ) - call MAPL_GetPointer( INTERNAL, GBXAR, 'GBXAR', _RC ) - call MAPL_GetPointer( INTERNAL, KWVRDG, 'KWVRDG', _RC ) - call MAPL_GetPointer( INTERNAL, EFFRDG, 'EFFRDG', _RC ) +#include "GWD_DeclarePointer___.h" + real, pointer, dimension(:,:,:) :: TMP3D + real, pointer, dimension(:,:) :: TMP2D + + ! local variables + + real, dimension(IM,JM,LM ) :: DQCDT_LS + real, dimension(IM,JM,LM ) :: ZM, PMID, PDEL, RPDEL, PMLN + real, dimension(IM,JM ) :: a2, Hefold + real, dimension(IM,JM,LM ) :: DUDT_ORG, DVDT_ORG, DTDT_ORG + real, dimension(IM,JM,LM ) :: DUDT_GWD, DVDT_GWD, DTDT_GWD + real, dimension(IM,JM,LM ) :: DUDT_RAH, DVDT_RAH, DTDT_RAH + real, dimension(IM,JM,LM ) :: DUDT_TOT, DVDT_TOT, DTDT_TOT + real, dimension(IM,JM,LM+1) :: PILN, ZI + real, dimension( LM ) :: ZREF, KRAY + real, dimension(IM,JM ) :: GBXAR_TMP + real, dimension(IM,JM ) :: TAUXO_TMP, TAUYO_TMP + real, dimension(IM,JM ) :: TAUXB_TMP, TAUYB_TMP + real, dimension(IM,JM,LM+1) :: TAUXO_3D , TAUYO_3D , FEO_3D, FEPO_3D + real, dimension(IM,JM,LM+1) :: TAUXB_3D , TAUYB_3D , FEB_3D, FEPB_3D + real, dimension(IM,JM,LM ) :: DUBKGSRC , DVBKGSRC , DTBKGSRC + real, dimension(IM,JM) :: KEGWD_X, KEORO_X, KERAY_X, KEBKG_X, KERES_X + real, dimension(IM,JM) :: PEGWD_X, PEORO_X, PERAY_X, PEBKG_X, BKGERR_X + + real, dimension(IM,JM,LM ) :: DUDT_GWD_GEOS , DVDT_GWD_GEOS , DTDT_GWD_GEOS + real, dimension(IM,JM,LM ) :: DUDT_ORG_GEOS , DVDT_ORG_GEOS , DTDT_ORG_GEOS + real, dimension(IM,JM ) :: TAUXB_TMP_GEOS, TAUYB_TMP_GEOS + real, dimension(IM,JM ) :: TAUXO_TMP_GEOS, TAUYO_TMP_GEOS + + real, dimension(IM,JM,LM ) :: DUDT_GWD_NCAR , DVDT_GWD_NCAR , DTDT_GWD_NCAR + real, dimension(IM,JM,LM ) :: DUDT_ORG_NCAR , DVDT_ORG_NCAR , DTDT_ORG_NCAR + real, dimension(IM,JM ) :: TAUXB_TMP_NCAR, TAUYB_TMP_NCAR + real, dimension(IM,JM ) :: TAUXO_TMP_NCAR, TAUYO_TMP_NCAR + + integer :: J, K, L, nrdg, ikpbl + real(ESMF_KIND_R8) :: DT_R8 + real :: DT ! time interval in sec + real :: a1, wsp, var_temp + !real, allocatable :: THV(:,:,:) + real :: THV(IM,JM,LM) + + integer :: I,IRUN + type (ESMF_State) :: INTERNAL + + ! Begin... + !---------- + + IAm = "Gwd_Driver" + + ! Get time step + !------------------------------------------------- + + call ESMF_AlarmGet( ALARM, ringInterval=TINT, _RC) + call ESMF_TimeIntervalGet(TINT, S_R8=DT_R8, _RC) + + DT = DT_R8 + + ! Pointers to import, export and internal variables + call MAPL_Get(MAPL, INTERNAL_ESMF_STATE=INTERNAL, _RC) +#include "GWD_GetPointer___.h" + + CALL PREGEO(IM*JM, LM, & + PLE, LATS, PMID, PDEL, RPDEL, PILN, PMLN) + + ! Compute ZM + !------------- + + call GEOPOTENTIAL( IM*JM, LM, & + PILN, PMLN, PLE, PMID, PDEL, RPDEL, & + T, Q, ZI, ZM ) + + ! Do gravity wave drag calculations on a list of soundings + !--------------------------------------------------------- + + !call MAPL_TimerOn(MAPL,"-INTR") + GBXAR_TMP = GBXAR * (MAPL_RADIUS/1000.)**2 ! transform to km^2 WHERE (ANGLL < -180) - ANGLL = 0.0 + ANGLL = 0.0 END WHERE do nrdg = 1, self%NCAR_NRDG - KWVRDG(:,:,nrdg) = 0.001/(HWDTH(:,:,nrdg)+0.001) - EFFRDG(:,:,nrdg) = self%NCAR_EFFGWORO*(HWDTH(:,:,nrdg)*CLNGT(:,:,nrdg))/GBXAR_TMP + KWVRDG(:,:,nrdg) = 0.001/(HWDTH(:,:,nrdg)+0.001) + EFFRDG(:,:,nrdg) = self%NCAR_EFFGWORO*(HWDTH(:,:,nrdg)*CLNGT(:,:,nrdg))/GBXAR_TMP enddo -! if (FIRST_RUN) then -! FIRST_RUN = .false. -! call gw_newtonian_set(LM, PREF) -!!#ifdef DEBUG_GWD -! if (self%NCAR_NRDG > 0) then -! IF (MAPL_AM_I_ROOT()) write(*,*) 'GWD internal state: ' -! call Write_Profile(GBXAR_TMP, AREA, ESMFGRID, 'GBXAR') -! do nrdg = 1, self%NCAR_NRDG -! IF (MAPL_AM_I_ROOT()) write(*,*) 'NRDG: ', nrdg -! call Write_Profile(MXDIS(:,:,nrdg), AREA, ESMFGRID, 'MXDIS') -! call Write_Profile(ANGLL(:,:,nrdg), AREA, ESMFGRID, 'ANGLL') -! call Write_Profile(ANIXY(:,:,nrdg), AREA, ESMFGRID, 'ANIXY') -! call Write_Profile(CLNGT(:,:,nrdg), AREA, ESMFGRID, 'CLNGT') -! call Write_Profile(HWDTH(:,:,nrdg), AREA, ESMFGRID, 'HWDTH') -! call Write_Profile(KWVRDG(:,:,nrdg), AREA, ESMFGRID, 'KWVRDG') -! call Write_Profile(EFFRDG(:,:,nrdg), AREA, ESMFGRID, 'EFFRDG') -! enddo -! endif -!!#endif -! endif - - call MAPL_GetPointer(EXPORT, TMP2D, 'RDG1_MXDIS', _RC) - if(associated(TMP2D)) TMP2D = MXDIS(:,:,1) - call MAPL_GetPointer(EXPORT, TMP2D, 'RDG1_HWDTH', _RC) - if(associated(TMP2D)) TMP2D = HWDTH(:,:,1) - call MAPL_GetPointer(EXPORT, TMP2D, 'RDG1_CLNGT', _RC) - if(associated(TMP2D)) TMP2D = CLNGT(:,:,1) - call MAPL_GetPointer(EXPORT, TMP2D, 'RDG1_ANGLL', _RC) - if(associated(TMP2D)) TMP2D = ANGLL(:,:,1) - call MAPL_GetPointer(EXPORT, TMP2D, 'RDG1_ANIXY', _RC) - if(associated(TMP2D)) TMP2D = ANIXY(:,:,1) - call MAPL_GetPointer(EXPORT, TMP2D, 'RDG1_GBXAR', _RC) - if(associated(TMP2D)) TMP2D = GBXAR_TMP + ! if (FIRST_RUN) then + ! FIRST_RUN = .false. + ! call gw_newtonian_set(LM, PREF) + !!#ifdef DEBUG_GWD + ! if (self%NCAR_NRDG > 0) then + ! IF (MAPL_AM_I_ROOT()) write(*,*) 'GWD internal state: ' + ! call Write_Profile(GBXAR_TMP, AREA, ESMFGRID, 'GBXAR') + ! do nrdg = 1, self%NCAR_NRDG + ! IF (MAPL_AM_I_ROOT()) write(*,*) 'NRDG: ', nrdg + ! call Write_Profile(MXDIS(:,:,nrdg), AREA, ESMFGRID, 'MXDIS') + ! call Write_Profile(ANGLL(:,:,nrdg), AREA, ESMFGRID, 'ANGLL') + ! call Write_Profile(ANIXY(:,:,nrdg), AREA, ESMFGRID, 'ANIXY') + ! call Write_Profile(CLNGT(:,:,nrdg), AREA, ESMFGRID, 'CLNGT') + ! call Write_Profile(HWDTH(:,:,nrdg), AREA, ESMFGRID, 'HWDTH') + ! call Write_Profile(KWVRDG(:,:,nrdg), AREA, ESMFGRID, 'KWVRDG') + ! call Write_Profile(EFFRDG(:,:,nrdg), AREA, ESMFGRID, 'EFFRDG') + ! enddo + ! endif + !!#endif + ! endif + + ! pchakrab: Redundant code? Commenting out. + ! call MAPL_GetPointer(EXPORT, TMP2D, 'RDG1_MXDIS', _RC) + ! if(associated(TMP2D)) TMP2D = MXDIS(:,:,1) + ! call MAPL_GetPointer(EXPORT, TMP2D, 'RDG1_HWDTH', _RC) + ! if(associated(TMP2D)) TMP2D = HWDTH(:,:,1) + ! call MAPL_GetPointer(EXPORT, TMP2D, 'RDG1_CLNGT', _RC) + ! if(associated(TMP2D)) TMP2D = CLNGT(:,:,1) + ! call MAPL_GetPointer(EXPORT, TMP2D, 'RDG1_ANGLL', _RC) + ! if(associated(TMP2D)) TMP2D = ANGLL(:,:,1) + ! call MAPL_GetPointer(EXPORT, TMP2D, 'RDG1_ANIXY', _RC) + ! if(associated(TMP2D)) TMP2D = ANIXY(:,:,1) + ! call MAPL_GetPointer(EXPORT, TMP2D, 'RDG1_GBXAR', _RC) + ! if(associated(TMP2D)) TMP2D = GBXAR_TMP ! Use new NCAR code convective+oro (excludes extratropical bkg sources) DUDT_GWD_NCAR = 0.0 @@ -1351,19 +705,19 @@ subroutine Gwd_Driver(RC) TAUYO_TMP_GEOS = 0.0 !call MAPL_TimerOn(MAPL,"-INTR_GEOS") if ( (self%GEOS_EFFGWORO /= 0.0) .OR. (self%GEOS_EFFGWBKG /= 0.0) ) then - call gw_intr (IM*JM, LM, DT, & - self%GEOS_PGWV, & - PLE, T, U, V, SGH, PREF, & - PMID, PDEL, RPDEL, PILN, ZM, LATS, & - DUDT_GWD_GEOS, DVDT_GWD_GEOS, DTDT_GWD_GEOS, & - DUDT_ORG_GEOS, DVDT_ORG_GEOS, DTDT_ORG_GEOS, & - TAUXO_TMP_GEOS, TAUYO_TMP_GEOS, TAUXO_3D, TAUYO_3D, FEO_3D, & - TAUXB_TMP_GEOS, TAUYB_TMP_GEOS, TAUXB_3D, TAUYB_3D, FEB_3D, & - FEPO_3D, FEPB_3D, DUBKGSRC, DVBKGSRC, DTBKGSRC, & - self%GEOS_BGSTRESS, & - self%GEOS_EFFGWORO, & - self%GEOS_EFFGWBKG, & - _RC) + call gw_intr (IM*JM, LM, DT, & + self%GEOS_PGWV, & + PLE, T, U, V, SGH, PREF, & + PMID, PDEL, RPDEL, PILN, ZM, LATS, & + DUDT_GWD_GEOS, DVDT_GWD_GEOS, DTDT_GWD_GEOS, & + DUDT_ORG_GEOS, DVDT_ORG_GEOS, DTDT_ORG_GEOS, & + TAUXO_TMP_GEOS, TAUYO_TMP_GEOS, TAUXO_3D, TAUYO_3D, FEO_3D, & + TAUXB_TMP_GEOS, TAUYB_TMP_GEOS, TAUXB_3D, TAUYB_3D, FEB_3D, & + FEPO_3D, FEPB_3D, DUBKGSRC, DVBKGSRC, DTBKGSRC, & + self%GEOS_BGSTRESS, & + self%GEOS_EFFGWORO, & + self%GEOS_EFFGWBKG, & + _RC) endif !call MAPL_TimerOff(MAPL,"-INTR_GEOS") @@ -1380,252 +734,252 @@ subroutine Gwd_Driver(RC) DTDT_ORG=DTDT_ORG_GEOS+DTDT_ORG_NCAR TAUXO_TMP=TAUXO_TMP_GEOS+TAUXO_TMP_NCAR TAUYO_TMP=TAUYO_TMP_GEOS+TAUYO_TMP_NCAR - !call MAPL_TimerOff(MAPL,"-INTR") - - CALL POSTINTR(IM*JM, LM, DT, H0, HH, Z1, TAU1, & - PREF, & - PDEL, & - U, & - V, & - DUDT_GWD, & - DVDT_GWD, & - DTDT_GWD, & - DUDT_ORG, & - DVDT_ORG, & - DTDT_ORG, & - - DUDT_TOT, & - DVDT_TOT, & - DTDT_TOT, & - DUDT_RAH, & - DVDT_RAH, & - DTDT_RAH, & - PEGWD_X, & - PEORO_X, & - PERAY_X, & - PEBKG_X, & - KEGWD_X, & - KEORO_X, & - KERAY_X, & - KEBKG_X, & - KERES_X, & - BKGERR_X ) - -!! Tendency diagnostics -!!--------------------- - - if(associated(DUDT )) DUDT = DUDT_TOT - if(associated(DVDT )) DVDT = DVDT_TOT - if(associated(DTDT )) DTDT = DTDT_TOT*PDEL ! DTDT has to be pressure weighted for dynamics - - if(associated(DUDT_RAY)) DUDT_RAY = DUDT_RAH - if(associated(DVDT_RAY)) DVDT_RAY = DVDT_RAH - if(associated(DTDT_RAY)) DTDT_RAY = DTDT_RAH - -!! KE dIagnostics -!!---------------- - - if(associated(PEGWD )) PEGWD = PEGWD_X - if(associated(PEORO )) PEORO = PEORO_X - if(associated(PERAY )) PERAY = PERAY_X - if(associated(PEBKG )) PEBKG = PEBKG_X - if(associated(KEGWD )) KEGWD = KEGWD_X - if(associated(KEORO )) KEORO = KEORO_X - if(associated(KERAY )) KERAY = KERAY_X - if(associated(KEBKG )) KEBKG = KEBKG_X - if(associated(KERES )) KERES = KERES_X - if(associated(BKGERR )) BKGERR = BKGERR_X - -!! Tendency diagnostics -!!--------------------- - - if(associated(DUDT_ORO)) DUDT_ORO = DUDT_ORG - if(associated(DVDT_ORO)) DVDT_ORO = DVDT_ORG - if(associated(DTDT_ORO)) DTDT_ORO = DTDT_ORG - - if(associated(DUDT_BKG)) DUDT_BKG = DUDT_GWD - DUDT_ORG - if(associated(DVDT_BKG)) DVDT_BKG = DVDT_GWD - DVDT_ORG - if(associated(DTDT_BKG)) DTDT_BKG = DTDT_GWD - DTDT_ORG - -! Orographic stress -!------------------ - - if(associated(TAUGWX )) TAUGWX = TAUXO_TMP + TAUXB_TMP - if(associated(TAUGWY )) TAUGWY = TAUYO_TMP + TAUYB_TMP - if(associated(TAUOROX )) TAUOROX = TAUXO_TMP - if(associated(TAUOROY )) TAUOROY = TAUYO_TMP - if(associated(TAUBKGX )) TAUBKGX = TAUXB_TMP - if(associated(TAUBKGY )) TAUBKGY = TAUYB_TMP - -! Export unweighted T Tendency -!----------------------------- - if(associated(TTMGW )) TTMGW = DTDT_TOT - -! Fille additional exports -!------------------------- - if(associated( Q_EXP )) Q_EXP = Q - if(associated( U_EXP )) U_EXP = U + DUDT_TOT*DT - if(associated( V_EXP )) V_EXP = V + DVDT_TOT*DT - if(associated( T_EXP )) T_EXP = T + DTDT_TOT*DT - if(associated( PREF_EXP )) PREF_EXP = PREF - if(associated( SGH_EXP )) SGH_EXP = SGH - if(associated( PLE_EXP )) PLE_EXP = PLE - -! All done -!----------- - RETURN_(ESMF_SUCCESS) - end subroutine GWD_DRIVER - - end subroutine RUN + !call MAPL_TimerOff(MAPL,"-INTR") + + CALL POSTINTR(IM*JM, LM, DT, H0, HH, Z1, TAU1, & + PREF, & + PDEL, & + U, & + V, & + DUDT_GWD, & + DVDT_GWD, & + DTDT_GWD, & + DUDT_ORG, & + DVDT_ORG, & + DTDT_ORG, & + + DUDT_TOT, & + DVDT_TOT, & + DTDT_TOT, & + DUDT_RAH, & + DVDT_RAH, & + DTDT_RAH, & + PEGWD_X, & + PEORO_X, & + PERAY_X, & + PEBKG_X, & + KEGWD_X, & + KEORO_X, & + KERAY_X, & + KEBKG_X, & + KERES_X, & + BKGERR_X ) + + !! Tendency diagnostics + !!--------------------- + + if(associated(DUDT )) DUDT = DUDT_TOT + if(associated(DVDT )) DVDT = DVDT_TOT + if(associated(DTDT )) DTDT = DTDT_TOT*PDEL ! DTDT has to be pressure weighted for dynamics + + if(associated(DUDT_RAY)) DUDT_RAY = DUDT_RAH + if(associated(DVDT_RAY)) DVDT_RAY = DVDT_RAH + if(associated(DTDT_RAY)) DTDT_RAY = DTDT_RAH + + !! KE dIagnostics + !!---------------- + + if(associated(PEGWD )) PEGWD = PEGWD_X + if(associated(PEORO )) PEORO = PEORO_X + if(associated(PERAY )) PERAY = PERAY_X + if(associated(PEBKG )) PEBKG = PEBKG_X + if(associated(KEGWD )) KEGWD = KEGWD_X + if(associated(KEORO )) KEORO = KEORO_X + if(associated(KERAY )) KERAY = KERAY_X + if(associated(KEBKG )) KEBKG = KEBKG_X + if(associated(KERES )) KERES = KERES_X + if(associated(BKGERR )) BKGERR = BKGERR_X + + !! Tendency diagnostics + !!--------------------- + + if(associated(DUDT_ORO)) DUDT_ORO = DUDT_ORG + if(associated(DVDT_ORO)) DVDT_ORO = DVDT_ORG + if(associated(DTDT_ORO)) DTDT_ORO = DTDT_ORG + + if(associated(DUDT_BKG)) DUDT_BKG = DUDT_GWD - DUDT_ORG + if(associated(DVDT_BKG)) DVDT_BKG = DVDT_GWD - DVDT_ORG + if(associated(DTDT_BKG)) DTDT_BKG = DTDT_GWD - DTDT_ORG + + ! Orographic stress + !------------------ + + if(associated(TAUGWX )) TAUGWX = TAUXO_TMP + TAUXB_TMP + if(associated(TAUGWY )) TAUGWY = TAUYO_TMP + TAUYB_TMP + if(associated(TAUOROX )) TAUOROX = TAUXO_TMP + if(associated(TAUOROY )) TAUOROY = TAUYO_TMP + if(associated(TAUBKGX )) TAUBKGX = TAUXB_TMP + if(associated(TAUBKGY )) TAUBKGY = TAUYB_TMP + + ! Export unweighted T Tendency + !----------------------------- + if(associated(TTMGW )) TTMGW = DTDT_TOT + + ! Fille additional exports + !------------------------- + if(associated( Q_EXP )) Q_EXP = Q + if(associated( U_EXP )) U_EXP = U + DUDT_TOT*DT + if(associated( V_EXP )) V_EXP = V + DVDT_TOT*DT + if(associated( T_EXP )) T_EXP = T + DTDT_TOT*DT + if(associated( PREF_EXP )) PREF_EXP = PREF + if(associated( SGH_EXP )) SGH_EXP = SGH + if(associated( PLE_EXP )) PLE_EXP = PLE + + ! All done + !----------- + RETURN_(ESMF_SUCCESS) + end subroutine GWD_DRIVER + + end subroutine RUN !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine geopotential(pcols , pver , & - piln , pmln , pint , pmid , pdel , rpdel , & - t , q , zi , zm ) + subroutine geopotential(pcols , pver , & + piln , pmln , pint , pmid , pdel , rpdel , & + t , q , zi , zm ) -!----------------------------------------------------------------------- -! -! Purpose: -! Compute the geopotential height (above the surface) at the midpoints and -! interfaces using the input temperatures and pressures. -! Author: B.Boville, Feb 2001 from earlier code by Boville and S.J. Lin -! -!----------------------------------------------------------------------- + !----------------------------------------------------------------------- + ! + ! Purpose: + ! Compute the geopotential height (above the surface) at the midpoints and + ! interfaces using the input temperatures and pressures. + ! Author: B.Boville, Feb 2001 from earlier code by Boville and S.J. Lin + ! + !----------------------------------------------------------------------- - implicit none + implicit none -!------------------------------Arguments-------------------------------- -! -! Input arguments -! - integer, intent(in) :: pcols ! Number of longitudes - integer, intent(in) :: pver ! Number of vertical layers + !------------------------------Arguments-------------------------------- + ! + ! Input arguments + ! + integer, intent(in) :: pcols ! Number of longitudes + integer, intent(in) :: pver ! Number of vertical layers - real, intent(in) :: piln (pcols,pver+1) ! Log interface pressures - real, intent(in) :: pmln (pcols,pver) ! Log midpoint pressures - real, intent(in) :: pint (pcols,pver+1) ! Interface pressures - real, intent(in) :: pmid (pcols,pver) ! Midpoint pressures - real, intent(in) :: pdel (pcols,pver) ! layer thickness - real, intent(in) :: rpdel(pcols,pver) ! inverse of layer thickness - real, intent(in) :: t (pcols,pver) ! temperature - real, intent(in) :: q (pcols,pver) ! specific humidity + real, intent(in) :: piln (pcols,pver+1) ! Log interface pressures + real, intent(in) :: pmln (pcols,pver) ! Log midpoint pressures + real, intent(in) :: pint (pcols,pver+1) ! Interface pressures + real, intent(in) :: pmid (pcols,pver) ! Midpoint pressures + real, intent(in) :: pdel (pcols,pver) ! layer thickness + real, intent(in) :: rpdel(pcols,pver) ! inverse of layer thickness + real, intent(in) :: t (pcols,pver) ! temperature + real, intent(in) :: q (pcols,pver) ! specific humidity -! Output arguments + ! Output arguments - real, intent(out) :: zi(pcols,pver+1) ! Height above surface at interfaces - real, intent(out) :: zm(pcols,pver) ! Geopotential height at mid level -! -!---------------------------Local variables----------------------------- -! - logical :: fvdyn ! finite volume dynamics - integer :: i,k ! Lon, level indices - real :: hkk ! diagonal element of hydrostatic matrix - real :: hkl ! off-diagonal element - real :: tv ! virtual temperature - real :: tvfac ! Tv/T + real, intent(out) :: zi(pcols,pver+1) ! Height above surface at interfaces + real, intent(out) :: zm(pcols,pver) ! Geopotential height at mid level + ! + !---------------------------Local variables----------------------------- + ! + logical :: fvdyn ! finite volume dynamics + integer :: i,k ! Lon, level indices + real :: hkk ! diagonal element of hydrostatic matrix + real :: hkl ! off-diagonal element + real :: tv ! virtual temperature + real :: tvfac ! Tv/T - real, parameter :: ROG = MAPL_RGAS/MAPL_GRAV -! -!----------------------------------------------------------------------- -! + real, parameter :: ROG = MAPL_RGAS/MAPL_GRAV + ! + !----------------------------------------------------------------------- + ! -! Set dynamics flag + ! Set dynamics flag - fvdyn = .true. + fvdyn = .true. -! The surface height is zero by definition. + ! The surface height is zero by definition. - I_LOOP: do i = 1, pcols + I_LOOP: do i = 1, pcols - zi(i,pver+1) = 0.0 + zi(i,pver+1) = 0.0 -! Compute zi, zm from bottom up. -! Note, zi(i,k) is the interface above zm(i,k) + ! Compute zi, zm from bottom up. + ! Note, zi(i,k) is the interface above zm(i,k) - do k = pver, 1, -1 + do k = pver, 1, -1 -! First set hydrostatic elements consistent with dynamics + ! First set hydrostatic elements consistent with dynamics - if (fvdyn) then - hkl = piln(i,k+1) - piln(i,k) - hkk = piln(i,k+1) - pmln(i,k) - else - hkl = pdel(i,k) / pmid(i,k) - hkk = 0.5 * hkl - end if + if (fvdyn) then + hkl = piln(i,k+1) - piln(i,k) + hkk = piln(i,k+1) - pmln(i,k) + else + hkl = pdel(i,k) / pmid(i,k) + hkk = 0.5 * hkl + end if -! Now compute tv, zm, zi + ! Now compute tv, zm, zi - tvfac = 1. + MAPL_VIREPS * q(i,k) - tv = t(i,k) * tvfac + tvfac = 1. + MAPL_VIREPS * q(i,k) + tv = t(i,k) * tvfac - zm(i,k) = zi(i,k+1) + ROG * tv * hkk - zi(i,k) = zi(i,k+1) + ROG * tv * hkl - end do - end do I_LOOP + zm(i,k) = zi(i,k+1) + ROG * tv * hkk + zi(i,k) = zi(i,k+1) + ROG * tv * hkl + end do + end do I_LOOP - return - end subroutine geopotential + return + end subroutine geopotential -!----------------------------------------------------------------------- + !----------------------------------------------------------------------- - subroutine pregeo(pcols,pver,& - ple,lats,pmid,pdel,rpdel,piln,pmln) + subroutine pregeo(pcols,pver,& + ple,lats,pmid,pdel,rpdel,piln,pmln) - implicit none + implicit none -!------------------------------Arguments-------------------------------- -! -! Input arguments -! + !------------------------------Arguments-------------------------------- + ! + ! Input arguments + ! - integer, intent(in) :: pcols ! Number of longitudes - integer, intent(in) :: pver ! Number of vertical layers + integer, intent(in) :: pcols ! Number of longitudes + integer, intent(in) :: pver ! Number of vertical layers - real, intent(in) :: ple (pcols,pver+1) ! Interface pressures - real, intent(in) :: lats(pcols) ! latitude in radian + real, intent(in) :: ple (pcols,pver+1) ! Interface pressures + real, intent(in) :: lats(pcols) ! latitude in radian -! Output arguments + ! Output arguments - real, intent(out) :: pmid (pcols,pver) ! Midpoint pressures - real, intent(out) :: pdel (pcols,pver) ! layer thickness - real, intent(out) :: rpdel (pcols,pver) ! inverse of layer thickness - real, intent(out) :: piln (pcols,pver+1) ! Log interface pressures - real, intent(out) :: pmln (pcols,pver) ! Log midpoint pressures + real, intent(out) :: pmid (pcols,pver) ! Midpoint pressures + real, intent(out) :: pdel (pcols,pver) ! layer thickness + real, intent(out) :: rpdel (pcols,pver) ! inverse of layer thickness + real, intent(out) :: piln (pcols,pver+1) ! Log interface pressures + real, intent(out) :: pmln (pcols,pver) ! Log midpoint pressures -! -!---------------------------Local variables----------------------------- -! - integer :: i,k + ! + !---------------------------Local variables----------------------------- + ! + integer :: i,k - real :: hvsd ! Efficiency factor + real :: hvsd ! Efficiency factor - real, parameter :: PI_GWD = 4.0*atan(1.0) ! This is *not* MAPL_PI + real, parameter :: PI_GWD = 4.0*atan(1.0) ! This is *not* MAPL_PI -! -!----------------------------------------------------------------------- -! + ! + !----------------------------------------------------------------------- + ! -! Form pressure factors -!---------------------- + ! Form pressure factors + !---------------------- - I_LOOP: DO I = 1, PCOLS + I_LOOP: DO I = 1, PCOLS - DO K = 1, PVER - PMID(I,K) = 0.5*( PLE(I,K ) + PLE(I,K+1) ) - PDEL(I,K) = PLE(I,K+1) - PLE(I,K ) - RPDEL(I,K) = 1.0 / PDEL(I,K) - PILN(I,K) = log( PLE(I,K) ) - PMLN(I,K) = log( PMID(I,K) ) ! - END DO - PILN(I,PVER+1) = log( PLE(I,PVER+1) ) - END DO I_LOOP + DO K = 1, PVER + PMID(I,K) = 0.5*( PLE(I,K ) + PLE(I,K+1) ) + PDEL(I,K) = PLE(I,K+1) - PLE(I,K ) + RPDEL(I,K) = 1.0 / PDEL(I,K) + PILN(I,K) = log( PLE(I,K) ) + PMLN(I,K) = log( PMID(I,K) ) ! + END DO + PILN(I,PVER+1) = log( PLE(I,PVER+1) ) + END DO I_LOOP - end subroutine pregeo + end subroutine pregeo - subroutine postintr(pcols,pver,dt, h0, hh, z1, tau1, & + subroutine postintr(pcols,pver,dt, h0, hh, z1, tau1, & pref, & pdel, & u, & @@ -1636,8 +990,8 @@ subroutine postintr(pcols,pver,dt, h0, hh, z1, tau1, & dudt_org, & dvdt_org, & dtdt_org, & - - ! Outputs + + ! Outputs dudt_tot, & dvdt_tot, & dtdt_tot, & @@ -1655,170 +1009,170 @@ subroutine postintr(pcols,pver,dt, h0, hh, z1, tau1, & keres, & bkgerr ) - implicit none - -!------------------------------Arguments-------------------------------- -! -! Input arguments -! - - integer, intent(in) :: PCOLS ! Number of longitudes - integer, intent(in) :: PVER ! Number of vertical layers - real, intent(in) :: DT ! Time step - real, intent(in) :: H0, HH, Z1, TAU1 ! Rayleigh friction parameters - - real, intent(in) :: PREF(PVER+1) - real, intent(in) :: PDEL(PCOLS,PVER) - real, intent(in) :: U(PCOLS,PVER) - real, intent(in) :: V(PCOLS,PVER) - - real, intent(in) :: DUDT_GWD(PCOLS,PVER) - real, intent(in) :: DVDT_GWD(PCOLS,PVER) - real, intent(in) :: DTDT_GWD(PCOLS,PVER) - real, intent(in) :: DUDT_ORG(PCOLS,PVER) - real, intent(in) :: DVDT_ORG(PCOLS,PVER) - real, intent(in) :: DTDT_ORG(PCOLS,PVER) - - real, intent(out) :: DUDT_TOT(PCOLS,PVER) - real, intent(out) :: DVDT_TOT(PCOLS,PVER) - real, intent(out) :: DTDT_TOT(PCOLS,PVER) - real, intent(out) :: DUDT_RAH(PCOLS,PVER) - real, intent(out) :: DVDT_RAH(PCOLS,PVER) - real, intent(out) :: DTDT_RAH(PCOLS,PVER) - real, intent(out) :: PEGWD(PCOLS) - real, intent(out) :: PEORO(PCOLS) - real, intent(out) :: PERAY(PCOLS) - real, intent(out) :: PEBKG(PCOLS) - real, intent(out) :: KEGWD(PCOLS) - real, intent(out) :: KEORO(PCOLS) - real, intent(out) :: KERAY(PCOLS) - real, intent(out) :: KEBKG(PCOLS) - real, intent(out) :: KERES(PCOLS) - real, intent(out) :: BKGERR(PCOLS) - -! -!---------------------------Local variables----------------------------- -! - integer :: i,k - real :: zref, kray -! -!----------------------------------------------------------------------- -! - - I_LOOP: DO I = 1, PCOLS - - PEGWD(I) = 0.0 - PEORO(I) = 0.0 - PERAY(I) = 0.0 - PEBKG(I) = 0.0 - KEGWD(I) = 0.0 - KEORO(I) = 0.0 - KERAY(I) = 0.0 - KEBKG(I) = 0.0 - KERES(I) = 0.0 - BKGERR(I) = 0.0 - - DO K = 1, PVER - -! Rayleigh friction -!------------------ - if (TAU1 > 0.0) then - ZREF = H0 * LOG(MAPL_P00/(0.5*(PREF(K)+PREF(K+1)))) - KRAY = (1.0/TAU1)*( 1.0 - TANH( (Z1-ZREF)/HH ) ) - KRAY = KRAY/(1+DT*KRAY) - DUDT_RAH(I,K) = -U(I,K)*KRAY - DVDT_RAH(I,K) = -V(I,K)*KRAY - DTDT_RAH(I,K) = - ((U(I,K) + (0.5*DT)*DUDT_RAH(I,K))*DUDT_RAH(I,K) + & - (V(I,K) + (0.5*DT)*DVDT_RAH(I,K))*DVDT_RAH(I,K) ) * (1.0/MAPL_CP) - else - DUDT_RAH(I,K) = 0.0 - DVDT_RAH(I,K) = 0.0 - DTDT_RAH(I,K) = 0.0 - endif - - DUDT_TOT(I,K) = DUDT_RAH(I,K) + DUDT_GWD(I,K) - DVDT_TOT(I,K) = DVDT_RAH(I,K) + DVDT_GWD(I,K) - DTDT_TOT(I,K) = DTDT_RAH(I,K) + DTDT_GWD(I,K) - -! KE dIagnostics -!---------------- - - PEGWD(I) = PEGWD(I) + DTDT_TOT(I,K) *PDEL(I,K)*(MAPL_CP/MAPL_GRAV) - PEORO(I) = PEORO(I) + DTDT_ORG(I,K) *PDEL(I,K)*(MAPL_CP/MAPL_GRAV) - PERAY(I) = PERAY(I) + DTDT_RAH(I,K) *PDEL(I,K)*(MAPL_CP/MAPL_GRAV) - PEBKG(I) = PEBKG(I) + (DTDT_GWD(I,K)-DTDT_ORG(I,K))*PDEL(I,K)*(MAPL_CP/MAPL_GRAV) - - KEGWD(I) = KEGWD(I) + ((U(I,K)+(0.5*DT)*DUDT_TOT(I,K))*DUDT_TOT(I,K) + & - (V(I,K)+(0.5*DT)*DVDT_TOT(I,K))*DVDT_TOT(I,K) ) * PDEL(I,K)*(1.0/MAPL_GRAV) - - KEORO(I) = KEORO(I) + ((U(I,K)+(0.5*DT)*DUDT_ORG(I,K))*DUDT_ORG(I,K) + & - (V(I,K)+(0.5*DT)*DVDT_ORG(I,K))*DVDT_ORG(I,K) ) * PDEL(I,K)*(1.0/MAPL_GRAV) - - KERAY(I) = KERAY(I) + ((U(I,K)+(0.5*DT)*DUDT_RAH(I,K))*DUDT_RAH(I,K) + & - (V(I,K)+(0.5*DT)*DVDT_RAH(I,K))*DVDT_RAH(I,K) ) * PDEL(I,K)*(1.0/MAPL_GRAV) - - KEBKG(I) = KEBKG(I) + ((U(I,K)+(0.5*DT)*(DUDT_GWD(I,K) - DUDT_ORG(I,K)))*(DUDT_GWD(I,K) - DUDT_ORG(I,K)) + & - (V(I,K)+(0.5*DT)*(DVDT_GWD(I,K) - DVDT_ORG(I,K)))*(DVDT_GWD(I,K) - DVDT_ORG(I,K)) ) * & - PDEL(I,K)*(1.0/MAPL_GRAV) - END DO - - BKGERR(I) = -( PEBKG(I) + KEBKG(I) ) - KERES(I) = PEGWD(I) + KEGWD(I) + BKGERR(I) - - END DO I_LOOP - - end subroutine postintr - - Subroutine Write_Profile(avar, area, grid, name) - type(ESMF_Grid), intent(IN) :: grid - real, intent(IN) :: avar(:,:) - real, intent(IN) :: area(:,:) - character(len=*), intent(IN) :: name - - real(kind=ESMF_KIND_R8), allocatable :: locArr(:,:) - real(kind=ESMF_KIND_R8), allocatable :: glbArr(:,:) - real, allocatable :: area_global(:,:) - real, allocatable :: avar_global(:,:) - real :: rng(3) - integer :: DIMS(3), STATUS, rc - - call MAPL_GridGet(GRID, localCellCountPerDim=DIMS, _RC) - allocate ( locArr(DIMS(1),DIMS(2)) ) - - call MAPL_GridGet(GRID, globalCellCountPerDim=DIMS, _RC) - allocate ( glbArr(DIMS(1),DIMS(2)) ) - allocate ( area_global(DIMS(1),DIMS(2)) ) - allocate ( avar_global(DIMS(1),DIMS(2)) ) + implicit none + + !------------------------------Arguments-------------------------------- + ! + ! Input arguments + ! + + integer, intent(in) :: PCOLS ! Number of longitudes + integer, intent(in) :: PVER ! Number of vertical layers + real, intent(in) :: DT ! Time step + real, intent(in) :: H0, HH, Z1, TAU1 ! Rayleigh friction parameters + + real, intent(in) :: PREF(PVER+1) + real, intent(in) :: PDEL(PCOLS,PVER) + real, intent(in) :: U(PCOLS,PVER) + real, intent(in) :: V(PCOLS,PVER) + + real, intent(in) :: DUDT_GWD(PCOLS,PVER) + real, intent(in) :: DVDT_GWD(PCOLS,PVER) + real, intent(in) :: DTDT_GWD(PCOLS,PVER) + real, intent(in) :: DUDT_ORG(PCOLS,PVER) + real, intent(in) :: DVDT_ORG(PCOLS,PVER) + real, intent(in) :: DTDT_ORG(PCOLS,PVER) + + real, intent(out) :: DUDT_TOT(PCOLS,PVER) + real, intent(out) :: DVDT_TOT(PCOLS,PVER) + real, intent(out) :: DTDT_TOT(PCOLS,PVER) + real, intent(out) :: DUDT_RAH(PCOLS,PVER) + real, intent(out) :: DVDT_RAH(PCOLS,PVER) + real, intent(out) :: DTDT_RAH(PCOLS,PVER) + real, intent(out) :: PEGWD(PCOLS) + real, intent(out) :: PEORO(PCOLS) + real, intent(out) :: PERAY(PCOLS) + real, intent(out) :: PEBKG(PCOLS) + real, intent(out) :: KEGWD(PCOLS) + real, intent(out) :: KEORO(PCOLS) + real, intent(out) :: KERAY(PCOLS) + real, intent(out) :: KEBKG(PCOLS) + real, intent(out) :: KERES(PCOLS) + real, intent(out) :: BKGERR(PCOLS) + + ! + !---------------------------Local variables----------------------------- + ! + integer :: i,k + real :: zref, kray + ! + !----------------------------------------------------------------------- + ! + + I_LOOP: DO I = 1, PCOLS + + PEGWD(I) = 0.0 + PEORO(I) = 0.0 + PERAY(I) = 0.0 + PEBKG(I) = 0.0 + KEGWD(I) = 0.0 + KEORO(I) = 0.0 + KERAY(I) = 0.0 + KEBKG(I) = 0.0 + KERES(I) = 0.0 + BKGERR(I) = 0.0 + + DO K = 1, PVER + + ! Rayleigh friction + !------------------ + if (TAU1 > 0.0) then + ZREF = H0 * LOG(MAPL_P00/(0.5*(PREF(K)+PREF(K+1)))) + KRAY = (1.0/TAU1)*( 1.0 - TANH( (Z1-ZREF)/HH ) ) + KRAY = KRAY/(1+DT*KRAY) + DUDT_RAH(I,K) = -U(I,K)*KRAY + DVDT_RAH(I,K) = -V(I,K)*KRAY + DTDT_RAH(I,K) = - ((U(I,K) + (0.5*DT)*DUDT_RAH(I,K))*DUDT_RAH(I,K) + & + (V(I,K) + (0.5*DT)*DVDT_RAH(I,K))*DVDT_RAH(I,K) ) * (1.0/MAPL_CP) + else + DUDT_RAH(I,K) = 0.0 + DVDT_RAH(I,K) = 0.0 + DTDT_RAH(I,K) = 0.0 + endif + + DUDT_TOT(I,K) = DUDT_RAH(I,K) + DUDT_GWD(I,K) + DVDT_TOT(I,K) = DVDT_RAH(I,K) + DVDT_GWD(I,K) + DTDT_TOT(I,K) = DTDT_RAH(I,K) + DTDT_GWD(I,K) + + ! KE dIagnostics + !---------------- + + PEGWD(I) = PEGWD(I) + DTDT_TOT(I,K) *PDEL(I,K)*(MAPL_CP/MAPL_GRAV) + PEORO(I) = PEORO(I) + DTDT_ORG(I,K) *PDEL(I,K)*(MAPL_CP/MAPL_GRAV) + PERAY(I) = PERAY(I) + DTDT_RAH(I,K) *PDEL(I,K)*(MAPL_CP/MAPL_GRAV) + PEBKG(I) = PEBKG(I) + (DTDT_GWD(I,K)-DTDT_ORG(I,K))*PDEL(I,K)*(MAPL_CP/MAPL_GRAV) + + KEGWD(I) = KEGWD(I) + ((U(I,K)+(0.5*DT)*DUDT_TOT(I,K))*DUDT_TOT(I,K) + & + (V(I,K)+(0.5*DT)*DVDT_TOT(I,K))*DVDT_TOT(I,K) ) * PDEL(I,K)*(1.0/MAPL_GRAV) + + KEORO(I) = KEORO(I) + ((U(I,K)+(0.5*DT)*DUDT_ORG(I,K))*DUDT_ORG(I,K) + & + (V(I,K)+(0.5*DT)*DVDT_ORG(I,K))*DVDT_ORG(I,K) ) * PDEL(I,K)*(1.0/MAPL_GRAV) + + KERAY(I) = KERAY(I) + ((U(I,K)+(0.5*DT)*DUDT_RAH(I,K))*DUDT_RAH(I,K) + & + (V(I,K)+(0.5*DT)*DVDT_RAH(I,K))*DVDT_RAH(I,K) ) * PDEL(I,K)*(1.0/MAPL_GRAV) + + KEBKG(I) = KEBKG(I) + ((U(I,K)+(0.5*DT)*(DUDT_GWD(I,K) - DUDT_ORG(I,K)))*(DUDT_GWD(I,K) - DUDT_ORG(I,K)) + & + (V(I,K)+(0.5*DT)*(DVDT_GWD(I,K) - DVDT_ORG(I,K)))*(DVDT_GWD(I,K) - DVDT_ORG(I,K)) ) * & + PDEL(I,K)*(1.0/MAPL_GRAV) + END DO + + BKGERR(I) = -( PEBKG(I) + KEBKG(I) ) + KERES(I) = PEGWD(I) + KEGWD(I) + BKGERR(I) + + END DO I_LOOP + + end subroutine postintr + + Subroutine Write_Profile(avar, area, grid, name) + type(ESMF_Grid), intent(IN) :: grid + real, intent(IN) :: avar(:,:) + real, intent(IN) :: area(:,:) + character(len=*), intent(IN) :: name + + real(kind=ESMF_KIND_R8), allocatable :: locArr(:,:) + real(kind=ESMF_KIND_R8), allocatable :: glbArr(:,:) + real, allocatable :: area_global(:,:) + real, allocatable :: avar_global(:,:) + real :: rng(3) + integer :: DIMS(3), STATUS, rc + + call MAPL_GridGet(GRID, localCellCountPerDim=DIMS, _RC) + allocate ( locArr(DIMS(1),DIMS(2)) ) + + call MAPL_GridGet(GRID, globalCellCountPerDim=DIMS, _RC) + allocate ( glbArr(DIMS(1),DIMS(2)) ) + allocate ( area_global(DIMS(1),DIMS(2)) ) + allocate ( avar_global(DIMS(1),DIMS(2)) ) #if 1 - locArr = avar - call ArrayGather(locArr, glbArr, grid) - avar_global = glbArr - - locArr = area - call ArrayGather(locArr, glbArr, grid) - area_global = glbArr - - IF (MAPL_AM_I_ROOT()) Then - rng(1) = MINVAL(MINVAL(avar_global,DIM=1),DIM=1) - rng(2) = MAXVAL(MAXVAL(avar_global,DIM=1),DIM=1) - rng(3) = SUM(SUM(avar_global*area_global,DIM=1),DIM=1) / & - SUM(SUM( area_global,DIM=1),DIM=1) - Write(*,'(A," ",3(f21.9,1x))'),trim(name),rng(:) - End IF + locArr = avar + call ArrayGather(locArr, glbArr, grid) + avar_global = glbArr + + locArr = area + call ArrayGather(locArr, glbArr, grid) + area_global = glbArr + + IF (MAPL_AM_I_ROOT()) Then + rng(1) = MINVAL(MINVAL(avar_global,DIM=1),DIM=1) + rng(2) = MAXVAL(MAXVAL(avar_global,DIM=1),DIM=1) + rng(3) = SUM(SUM(avar_global*area_global,DIM=1),DIM=1) / & + SUM(SUM( area_global,DIM=1),DIM=1) + Write(*,'(A," ",3(f21.9,1x))'),trim(name),rng(:) + End IF #else - rng(1) = MINVAL(MINVAL(avar,DIM=1),DIM=1) - rng(2) = MAXVAL(MAXVAL(avar,DIM=1),DIM=1) - rng(3) = SUM(SUM(avar*area,DIM=1),DIM=1) / & - SUM(SUM( area,DIM=1),DIM=1) - Write(*,'(A," ",3(f21.9,1x))'),trim(name),rng(:) + rng(1) = MINVAL(MINVAL(avar,DIM=1),DIM=1) + rng(2) = MAXVAL(MAXVAL(avar,DIM=1),DIM=1) + rng(3) = SUM(SUM(avar*area,DIM=1),DIM=1) / & + SUM(SUM( area,DIM=1),DIM=1) + Write(*,'(A," ",3(f21.9,1x))'),trim(name),rng(:) #endif - deallocate ( locArr ) - deallocate ( glbArr ) - deallocate ( area_global ) - deallocate ( avar_global ) + deallocate ( locArr ) + deallocate ( glbArr ) + deallocate ( area_global ) + deallocate ( avar_global ) - End Subroutine Write_Profile + End Subroutine Write_Profile end module GEOS_GwdGridCompMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GWD_StateSpecs.rc b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GWD_StateSpecs.rc new file mode 100644 index 000000000..e69a235a8 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GWD_StateSpecs.rc @@ -0,0 +1,96 @@ +schema_version: 2.0.0 +component: GWD + +category: INTERNAL +#-------------------------------------------------------------------------------------------------------------------- +# VARIABLE | DIMENSION | Additional Metadata +#-------------------------------------------------------------------------------------------------------------------- + NAME | UNITS | DIMS | VLOC | UNGRIDDED | LONG NAME +#-------------------------------------------------------------------------------------------------------------------- + SGH30 | m | xy | N | | standard deviation of 30s elevation from 3km cube + KWVRDG | km | xy | N | (/16/) | horizonal wwavenumber of mountain ridges + EFFRDG | km | xy | N | (/16/) | efficiency of mountain ridge scheme + GBXAR | NA | xy | N | | grid box area + HWDTH | km | xy | N | (/16/) | width of mountain ridges + CLNGT | km | xy | N | (/16/) | width of mountain ridges + MXDIS | NA | xy | N | (/16/) | NA + ANGLL | NA | xy | N | (/16/) | NA + ANIXY | NA | xy | N | (/16/) | NA + +category: IMPORT +#------------------------------------------------------------------------------------------------------- +# VARIABLE | DIMENSIONS | Additional Metadata +#------------------------------------------------------------------------------------------------------- + NAME | ALIAS | UNITS | DIMS | VLOC | RESTART | LONG NAME +#------------------------------------------------------------------------------------------------------- + PLE | | Pa | xyz | E | SKIP | air_pressure + T | | K | xyz | C | SKIP | air_temperature + Q | | kg kg-1 | xyz | C | SKIP | specific_humidity + U | | m s-1 | xyz | C | SKIP | eastward_wind + V | | m s-1 | xyz | C | SKIP | northward_wind + PHIS | | m+2 s-2 | xy | N | SKIP | surface geopotential height + SGH | | m | xy | N | SKIP | standard_deviation_of_topography + VARFLT | | m+2 | xy | N | SKIP | variance_of_the_filtered_topography + PREF | | Pa | z | E | SKIP | reference_air_pressure + AREA | | m^2 | xy | N | SKIP | grid_box_area +#-from-moist- + DTDT_DC | HT_dc | K s-1 | xyz | C | | T tendency due to deep convection + DQLDT | | kg kg-1 s-1 | xyz | C | | total_liq_water_tendency_due_to_moist + DQIDT | | kg kg-1 s-1 | xyz | C | | total_ice_water_tendency_due_to_moist + CNV_FRC | | 1 | xy | N | | convective_fraction + +category: EXPORT +#------------------------------------------------------------------------------------------------------- +# VARIABLE | DIMENSIONS | Additional Metadata +#------------------------------------------------------------------------------------------------------- + NAME | ALIAS | UNITS | DIMS | VLOC | LONG NAME +#------------------------------------------------------------------------------------------------------- + PLE | PLE_EXP | Pa | xyz | E | air_pressure + T | T_EXP | K | xyz | C | air_temperature + Q | Q_EXP | kg kg-1 | xyz | C | specific_humidity + U | U_EXP | m s-1 | xyz | C | eastward_wind + V | V_EXP | m s-1 | xyz | C | northward_wind + RDG1_MXDIS | | 1 | xy | N | ridge1_mxdis + RDG1_HWDTH | | 1 | xy | N | ridge1_hwdth + RDG1_CLNGT | | 1 | xy | N | ridge1_clngt + RDG1_ANGLL | | 1 | xy | N | ridge1_angll + RDG1_ANIXY | | 1 | xy | N | ridge1_anixy + RDG1_GBXAR | | km^2 | xy | N | ridge1_gridbox_area + SGH | SGH_EXP | m | xy | N | standard_deviation_of_topography + PREF | PREF_EXP | Pa | z | E | reference_air_pressure + DTDT | | Pa K s-1 | xyz | C | mass_weighted_air_temperature_tendency_due_to_GWD + TTMGW | | K s-1 | xyz | C | air_temperature_tendency_due_to_GWD + DUDT | | m s-2 | xyz | C | tendency_of_eastward_wind_due_to_GWD + DVDT | | m s-2 | xyz | C | tendency_of_northward_wind_due_to_GWD + DTDT_ORO | | K s-1 | xyz | C | air_temperature_tendency_due_to_orographic_GWD + DUDT_ORO | | m s-2 | xyz | C | tendency_of_eastward_wind_due_to_orographic_GWD + DVDT_ORO | | m s-2 | xyz | C | tendency_of_northward_wind_due_to_orographic_GWD + DTDT_BKG | | K s-1 | xyz | C | air_temperature_tendency_due_to_background_GWD + DUDT_BKG | | m s-2 | xyz | C | tendency_of_eastward_wind_due_to_background_GWD + DVDT_BKG | | m s-2 | xyz | C | tendency_of_northward_wind_due_to_background_GWD + DTDT_RAY | | K s-1 | xyz | C | air_temperature_tendency_due_to_Rayleigh_friction + DUDT_RAY | | m s-2 | xyz | C | tendency_of_eastward_wind_due_to_Rayleigh_friction + DVDT_RAY | | m s-2 | xyz | C | tendency_of_northward_wind_due_to_Rayleigh_friction + TAUGWX | | N m-2 | xy | N | surface_eastward_gravity_wave_stress + TAUGWY | | N m-2 | xy | N | surface_northward_gravity_wave_stress + TAUOROX | | N m-2 | xy | N | surface_eastward_orographic_gravity_wave_stress + TAUOROY | | N m-2 | xy | N | surface_northward_orographic_gravity_wave_stress + TAUBKGX | | N m-2 | xy | N | surface_eastward_background_gravity_wave_stress + TAUBKGY | | N m-2 | xy | N | surface_northward_background_gravity_wave_stress + TAUMSTX | | N m-2 | xy | N | surface_eastward_gravity_wave_stress_due_to_Moist_Processes + TAUMSTY | | N m-2 | xy | N | surface_northward_gravity_wave_stress_due_to_Moist_Processes + CLDSTD | | m | xy | N | gravity_wave_drag_standard_deviation_due_to_clouds + UBASE | | m s-1 | xy | N | eastward_component_of_base_level_wind + VBASE | | m s-1 | xy | N | northward_component_of_base_level_wind + UBAR | | m s-1 | xy | N | eastward_component_of_mean_level_wind + VBAR | | m s-1 | xy | N | northward_component_of_mean_level_wind + PEGWD | | W m-2 | xy | N | vertically_integrated_potential_energy_tendency_across_gwd + PEORO | | W m-2 | xy | N | vertically_integrated_potential_energy_tendency_due_to_orographic_gravity_waves + PEBKG | | W m-2 | xy | N | vertically_integrated_potential_energy_tendency_due_to_gravity_wave_background + PERAY | | W m-2 | xy | N | vertically_integrated_potential_energy_tendency_due_to_Rayleigh_friction + KEGWD | | W m-2 | xy | N | vertically_integrated_kinetic_energy_tendency_across_gwd + KEORO | | W m-2 | xy | N | vertically_integrated_kinetic_energy_dissipation_due_to_orographic_gravity_waves + KERAY | | W m-2 | xy | N | vertically_integrated_kinetic_energy_dissipation_due_to_Rayleigh_friction + KEBKG | | W m-2 | xy | N | vertically_integrated_kinetic_energy_dissipation_due_to_gravity_wave_background + KERES | | W m-2 | xy | N | vertically_integrated_kinetic_energy_residual_for_total_energy_conservation + BKGERR | | W m-2 | xy | N | vertically_integrated_kinetic_energy_residual_for_BKG_energy_conservation diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/CMakeLists.txt index ed7e01ec2..4374e909b 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/CMakeLists.txt +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/CMakeLists.txt @@ -22,20 +22,35 @@ if (CMAKE_Fortran_COMPILER_ID MATCHES Intel AND CMAKE_BUILD_TYPE MATCHES Aggress endif () if (CMAKE_Fortran_COMPILER_ID MATCHES GNU AND CMAKE_BUILD_TYPE MATCHES Release) - string (REPLACE "${FOPT3}" "${FOPT2}" CMAKE_Fortran_FLAGS_RELEASE ${CMAKE_Fortran_FLAGS_RELEASE}) + string (REPLACE "${FOPT3}" "${FOPT2}" CMAKE_Fortran_FLAGS_RELEASE ${CMAKE_Fortran_FLAGS_RELEASE}) + # There is some odd interaction between GCC 15 and the GF code. FPEs + # that do not occur with GCC 14 or earlier. For now, we compile GF + # codes with -O1 which seems to avoid the bad instruction. Tests show + # not much of a speed difference with GCC 14 + if (${CMAKE_Fortran_COMPILER_VERSION} VERSION_GREATER_EQUAL 15) + message (STATUS "[GCC15+] Setting GF Code to use -O1 for GCC 15") + set_source_files_properties(ConvPar_GF2020.F90 PROPERTIES COMPILE_OPTIONS ${FOPT1}) + set_source_files_properties(ConvPar_GF_GEOS5.F90 PROPERTIES COMPILE_OPTIONS ${FOPT1}) + endif() endif () # Note For unknown reasons, BACM_1M_Interface takes 20 minutes to compile at O3 # and 10 minutes at O2. But only 7 seconds with O1. So we compile at O1 if (CMAKE_Fortran_COMPILER_ID MATCHES Intel AND CMAKE_BUILD_TYPE MATCHES Release) set_source_files_properties(GEOS_BACM_1M_InterfaceMod.F90 PROPERTIES COMPILE_OPTIONS ${FOPT1}) - set_source_files_properties(GEOS_MGB2_2M_InterfaceMod.F90 PROPERTIES COMPILE_OPTIONS ${FOPT1}) + # set_source_files_properties(GEOS_MGB2_2M_InterfaceMod.F90 PROPERTIES COMPILE_OPTIONS ${FOPT1}) endif () esma_add_library (${this} SRCS ${srcs} DEPENDENCIES GEOS_Shared GMAO_mpeu MAPL Chem_Shared Chem_Base ESMF::ESMF) +# We need to add_dependencies for fms_r4 because CMake doesn't know we +# need it for include purposes. In R4R8, we only ever link against +# fms_r8, so it doesn't know to build the target fms_r4 +# NOTE NOTE NOTE: This should *not* be included in GEOSgcm v12 +# because FMS is pre-built library in that case. +add_dependencies (${this} fms_r4) get_target_property (extra_incs fms_r4 INCLUDE_DIRECTORIES) target_include_directories(${this} PRIVATE $ diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MGB2_2M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MGB2_2M_InterfaceMod.F90 index e5649a109..da0140a95 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MGB2_2M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MGB2_2M_InterfaceMod.F90 @@ -52,31 +52,30 @@ module GEOS_MGB2_2M_InterfaceMod ! Local resource variables integer :: imsize - real :: TURNRHCRIT + real :: TURNRHCRIT, TURNRHCRIT_UP real :: MINRHCRIT real :: CCW_EVAP_EFF real :: CCI_EVAP_EFF integer :: PDFSHAPE - real :: FAC_RL real :: MIN_RL real :: MAX_RL real :: FAC_RI + real :: FAC_RL real :: MIN_RI real :: MAX_RI logical :: LHYDROSTATIC - logical :: LPHYS_HYDROSTATIC + logical :: USE_AV_V + logical :: SECOND_HYSTPDF + - real :: DCS, QCVAR_, WBFFACTOR, NC_CST, NI_CST, NG_CST, MUI_CST, PMIN_CBL - real :: LCCIRRUS, UISCALE, SS_SCALE, REEVAP_MICRO, LIU_MU, TFRZ, & - NPRE_FRAC, QCVAR, ZPBLMAXLL, LTS_LOW, LTS_UP, MIN_EXP, & - BKGTAU, DCRIT_, USE_AV_V, AUTSC, TS_AUTO_ICE, CCN_PARAM, IN_PARAM, & - FDROP_DUST, FDROP_SOOT, USE_WSUB_CLIM, MIN_ALH, & - HMOIST_950, HSMOIST_500, SINST, MAX_EXP, MAX_CAPE, MIN_CAPE, & + real :: DCS, WBFFACTOR, NC_CST, NI_CST, NG_CST, & + LCCIRRUS, UISCALE, LIU_MU, NPRE_FRAC, QCVAR_CST, & + AUT_SCALE, TS_AUTO_ICE, CCN_PARAM, IN_PARAM, & + FDROP_DUST, FDROP_SOOT, WSUB_OPTION, & DUST_INFAC, ORG_INFAC, BC_INFAC, SS_INFAC, RRTMG_IRRAD, RRTMG_SORAD,& - SCWST, MTIME, SWCIRRUS, MINCDNC, TMAXCFCORR, & - Immersion_param, ACC_ENH, ACC_ENH_ICE, DT_MICRO, DT_AUX, UR_SCALE, & - CNV_NUMLIQ_SC, CNV_NUMICE_SC + MTIME,MINCDNC, Immersion_param, ACC_ENH, ACC_ENH_ICE, DT_MICRO, URSCALE, & + CNV_GSC, CNV_BSC, MUI_CST, USE_AREA, PRECIPRAD, DROPSZCNV, ICESZCNV_SC public :: MGB2_2M_Setup, MGB2_2M_Initialize, MGB2_2M_Run @@ -97,7 +96,7 @@ subroutine MGB2_2M_Setup (GC, CF, RC) VERIFY_(STATUS) Iam = trim(COMP_NAME) // Iam - call ESMF_ConfigGetAttribute( CF, MGVERSION, Label="MGVERSION:", default=1, __RC__) + call ESMF_ConfigGetAttribute( CF, MGVERSION, Label="MGVERSION:", default=3, __RC__) call ESMF_ConfigGetAttribute( CF, CONVPAR_OPTION, Label='CONVPAR_OPTION:', __RC__) ! Note: Default set in GEOS_GcmGridComp.F90 @@ -110,14 +109,29 @@ subroutine MGB2_2M_Setup (GC, CF, RC) FRIENDLIES%QLCN = "DYNAMICS:TURBULENCE" FRIENDLIES%QILS = "DYNAMICS:TURBULENCE" FRIENDLIES%QICN = "DYNAMICS:TURBULENCE" - FRIENDLIES%QRAIN = "DYNAMICS:TURBULENCE" - FRIENDLIES%QSNOW = "DYNAMICS:TURBULENCE" - FRIENDLIES%QGRAUPEL = "DYNAMICS:TURBULENCE" FRIENDLIES%NCPI = "DYNAMICS:TURBULENCE" FRIENDLIES%NCPL = "DYNAMICS:TURBULENCE" - FRIENDLIES%NRAIN = "DYNAMICS:TURBULENCE" - FRIENDLIES%NSNOW = "DYNAMICS:TURBULENCE" - FRIENDLIES%NGRAUPEL = "DYNAMICS:TURBULENCE" + + + if (MGVERSION .gt. 1) then + + FRIENDLIES%QRAIN = "DYNAMICS:TURBULENCE" + FRIENDLIES%QSNOW = "DYNAMICS:TURBULENCE" + FRIENDLIES%QGRAUPEL = "DYNAMICS:TURBULENCE" + FRIENDLIES%NRAIN = "DYNAMICS:TURBULENCE" + FRIENDLIES%NSNOW = "DYNAMICS:TURBULENCE" + FRIENDLIES%NGRAUPEL = "DYNAMICS:TURBULENCE" + + else + FRIENDLIES%QRAIN = trim(COMP_NAME) + FRIENDLIES%QSNOW = trim(COMP_NAME) + FRIENDLIES%QGRAUPEL = trim(COMP_NAME) + FRIENDLIES%NRAIN = trim(COMP_NAME) + FRIENDLIES%NSNOW = trim(COMP_NAME) + FRIENDLIES%NGRAUPEL = trim(COMP_NAME) + end if + + !BOS @@ -191,7 +205,6 @@ subroutine MGB2_2M_Setup (GC, CF, RC) LONG_NAME = 'mass_fraction_of_rain', & UNITS = 'kg kg-1', & FRIENDLYTO = trim(FRIENDLIES%QRAIN), & - default = 0.0, & DIMS = MAPL_DimsHorzVert, & VLOCATION = MAPL_VLocationCenter, RC=STATUS ) VERIFY_(STATUS) @@ -201,7 +214,6 @@ subroutine MGB2_2M_Setup (GC, CF, RC) LONG_NAME = 'mass_fraction_of_snow', & UNITS = 'kg kg-1', & FRIENDLYTO = trim(FRIENDLIES%QSNOW), & - default = 0.0, & DIMS = MAPL_DimsHorzVert, & VLOCATION = MAPL_VLocationCenter, RC=STATUS ) VERIFY_(STATUS) @@ -211,7 +223,6 @@ subroutine MGB2_2M_Setup (GC, CF, RC) LONG_NAME = 'mass_fraction_of_graupel', & UNITS = 'kg kg-1', & FRIENDLYTO = trim(FRIENDLIES%QGRAUPEL), & - default = 0.0, & DIMS = MAPL_DimsHorzVert, & VLOCATION = MAPL_VLocationCenter, RC=STATUS ) VERIFY_(STATUS) @@ -220,21 +231,21 @@ subroutine MGB2_2M_Setup (GC, CF, RC) SHORT_NAME ='NCPL', & LONG_NAME ='particle_number_for_liquid_cloud', & UNITS ='kg-1', & + default = 0., & FRIENDLYTO = trim(FRIENDLIES%NCPL), & DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - DEFAULT = 50.0e6 , __RC__ ) - + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) call MAPL_AddInternalSpec(GC, & SHORT_NAME ='NCPI', & LONG_NAME ='particle_number_for_ice_cloud', & UNITS ='kg-1', & + default = 0., & FRIENDLYTO = trim(FRIENDLIES%NCPI), & DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - DEFAULT = 1.0e3, __RC__ ) - + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) call MAPL_AddInternalSpec(GC, & SHORT_NAME ='NRAIN', & @@ -242,9 +253,8 @@ subroutine MGB2_2M_Setup (GC, CF, RC) UNITS ='kg-1', & FRIENDLYTO = trim(FRIENDLIES%NRAIN), & DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - DEFAULT = 0.0 , __RC__ ) - + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) call MAPL_AddInternalSpec(GC, & SHORT_NAME ='NSNOW', & @@ -252,18 +262,18 @@ subroutine MGB2_2M_Setup (GC, CF, RC) UNITS ='kg-1', & FRIENDLYTO = trim(FRIENDLIES%NSNOW), & DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - DEFAULT = 0.0, __RC__ ) - - + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & SHORT_NAME ='NGRAUPEL', & LONG_NAME ='particle_number_for_graupel', & UNITS ='kg-1', & FRIENDLYTO = trim(FRIENDLIES%NGRAUPEL), & DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - DEFAULT = 0.0, __RC__ ) + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) call MAPL_AddInternalSpec(GC, & SHORT_NAME = 'NACTL', & @@ -296,43 +306,21 @@ subroutine MGB2_2M_Initialize (MAPL, RC) type (MAPL_MetaComp), intent(inout) :: MAPL integer, optional :: RC ! return code - type (ESMF_Grid ) :: GRID + type (ESMF_State) :: INTERNAL - real, pointer, dimension(:,:,:) :: Q, QLLS, QLCN, QILS, QICN, QRAIN, QSNOW, QGRAUPEL - real, pointer, dimension(:,:,:) :: NCPL, NCPI, NRAIN, NSNOW, NGRAUPEL + real, pointer, dimension(:,:,:) :: Q, QLLS, QLCN, QILS, QICN, QRAIN, QSNOW, QGRAUPEL, CLLS, CLCN + real, pointer, dimension(:,:,:) :: NCPL, NCPI, NRAIN, NSNOW, NGRAUPEL, NACTI, NACTL - logical :: nccons, nicons, ngcons, do_graupel - real(ESMF_KIND_R8) Dcsr8, qcvarr8, micro_mg_berg_eff_factor_in, ncnstr8, ninstr8, ngnstr8, mui_cnstr8 + logical :: nccons=.false. + logical :: nicons=.false. + logical :: ngcons= .false. + logical :: do_graupel = .false. + real(ESMF_KIND_R8) Dcsr8, micro_mg_berg_eff_factor_in, ncnstr8, ninstr8, ngnstr8, mui_cnstr8 - - character(len=ESMF_MAXSTR) :: GRIDNAME - character(len=4) :: imchar - character(len=2) :: dateline - integer :: nn - real :: tmprhL, tmprhO - - IAm = "MGB2_2M_Initialize" - - call MAPL_Get ( MAPL, INTERNAL_ESMF_STATE=INTERNAL, __RC__ ) - - call MAPL_GetResource(MAPL, GRIDNAME, 'AGCM.GRIDNAME:', RC=STATUS) - VERIFY_(STATUS) - GRIDNAME = AdjustL(GRIDNAME) - nn = len_trim(GRIDNAME) - dateline = GRIDNAME(nn-1:nn) - imchar = GRIDNAME(3:index(GRIDNAME,'x')-1) - read(imchar,*) imsize - if(dateline.eq.'CF') imsize = imsize*4 - - - - call MAPL_GetResource( MAPL, LPHYS_HYDROSTATIC, Label="PHYS_HYDROSTATIC:", default=.TRUE., RC=STATUS) - VERIFY_(STATUS) - call MAPL_Get ( MAPL, INTERNAL_ESMF_STATE=INTERNAL, RC=STATUS ) VERIFY_(STATUS) @@ -344,30 +332,35 @@ subroutine MGB2_2M_Initialize (MAPL, RC) call MAPL_GetPointer(INTERNAL, QLCN, 'QLCN' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(INTERNAL, QILS, 'QILS' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(INTERNAL, QICN, 'QICN' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, CLCN, 'CLCN' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, CLLS, 'CLLS' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(INTERNAL, NCPL, 'NCPL' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(INTERNAL, NCPI, 'NCPI' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(INTERNAL, NRAIN, 'NRAIN' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(INTERNAL, NSNOW, 'NSNOW' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(INTERNAL, NGRAUPEL, 'NGRAUPEL' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, NACTL, 'NACTL' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, NACTI, 'NACTI' , RC=STATUS); VERIFY_(STATUS) call WRITE_PARALLEL ("INITIALIZED MGB2_2M microphysics in non-generic GC INIT") - call MAPL_GetResource( MAPL, PDFSHAPE , 'PDFSHAPE:' , DEFAULT= 2 , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, FAC_RI , 'FAC_RI:' , DEFAULT= 1.0 , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, PDFSHAPE , 'PDFSHAPE:' , DEFAULT= 1 , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, FAC_RI , 'FAC_RI:' , DEFAULT= 1.97 , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, FAC_RL , 'FAC_RL:' , DEFAULT= 2.28 , RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, MIN_RI , 'MIN_RI:' , DEFAULT= 5.e-6, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, MAX_RI , 'MAX_RI:' , DEFAULT=140.e-6, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, FAC_RL , 'FAC_RL:' , DEFAULT= 1.0 , RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, MIN_RL , 'MIN_RL:' , DEFAULT= 2.5e-6, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, MAX_RL , 'MAX_RL:' , DEFAULT=60.0e-6, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, CCW_EVAP_EFF, 'CCW_EVAP_EFF:', DEFAULT= 4.e-3, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, CCI_EVAP_EFF, 'CCI_EVAP_EFF:', DEFAULT= 4.e-3, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, CNV_FRACTION_MIN, 'CNV_FRACTION_MIN:', DEFAULT= 0.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, CCI_EVAP_EFF, 'CCI_EVAP_EFF:', DEFAULT= 4.e-3, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, MINRHCRIT, 'MINRHCRIT:', DEFAULT = 0.89, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, TURNRHCRIT, 'TURNRHCRIT:', DEFAULT = 726., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, TURNRHCRIT_UP, 'TURNRHCRIT_UP:', DEFAULT = 300., RC=STATUS); VERIFY_(STATUS) !pressure to turn the profile back at upper trop -1 dsiables it + call MAPL_GetResource( MAPL, CNV_FRACTION_MIN, 'CNV_FRACTION_MIN:', DEFAULT= 500.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, CNV_FRACTION_MAX, 'CNV_FRACTION_MAX:', DEFAULT= 1500.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, CNV_FRACTION_EXP, 'CNV_FRACTION_EXP:', DEFAULT= 0.5, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, CNV_FRACTION_EXP, 'CNV_FRACTION_EXP:', DEFAULT= 1.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, MINRHCRIT, 'MINRHCRIT:', DEFAULT = 0.9, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, TURNRHCRIT, 'TURNRHCRIT:', DEFAULT = 884., RC=STATUS); VERIFY_(STATUS) !2M==tuning and options====== @@ -376,9 +369,9 @@ subroutine MGB2_2M_Initialize (MAPL, RC) call MAPL_GetResource(MAPL, UISCALE, 'UISCALE:', DEFAULT= 1.0, __RC__) !Scaling factor for sed vel of ice call MAPL_GetResource(MAPL, LIU_MU, 'LIU_MU:', DEFAULT= 2.0, __RC__) !Liu autoconversion parameter call MAPL_GetResource(MAPL, NPRE_FRAC, 'NPRE_FRAC:', DEFAULT= -1.0, __RC__) !Fraction of preexisting ice affecting ice nucleationn - call MAPL_GetResource(MAPL, USE_AV_V, 'USE_AV_V:', DEFAULT= 1.0, __RC__) !Set to > 0 to use an average velocity for activation - call MAPL_GetResource(MAPL, AUTSC, 'AUT_SCALE:', DEFAULT= 1.0, __RC__) !scale factor for critical size for drizzle - call MAPL_GetResource(MAPL, TS_AUTO_ICE, 'TS_AUTO_ICE:', DEFAULT= 360., __RC__) !Ice autoconversion time scale + call MAPL_GetResource(MAPL, USE_AV_V, 'USE_AV_V:', DEFAULT= .TRUE., __RC__) !Set to > 0 to use an average velocity for activation + call MAPL_GetResource(MAPL, AUT_SCALE, 'AUT_SCALE:', DEFAULT= 1.7, __RC__) !scale factor for critical size for drizzle + call MAPL_GetResource(MAPL, TS_AUTO_ICE, 'TS_AUTO_ICE:', DEFAULT= -1., __RC__) !Ice autoconversion time scale call MAPL_GetResource(MAPL, CCN_PARAM, 'CCNPARAM:', DEFAULT= 2.0, __RC__) !CCN activation param call MAPL_GetResource(MAPL, IN_PARAM, 'INPARAM:', DEFAULT= 6.0, __RC__) !IN param call MAPL_GetResource(MAPL, Immersion_param,'ImmersionPARAM:', DEFAULT= 6.0, __RC__) !Immersion param @@ -386,43 +379,44 @@ subroutine MGB2_2M_Initialize (MAPL, RC) call MAPL_GetResource(MAPL, ACC_ENH_ICE, 'ACC_ENH_ICE:', DEFAULT= 1.0, __RC__) !accretion snow-ice scaling for MG2 call MAPL_GetResource(MAPL, FDROP_DUST, 'FDROP_DUST:', DEFAULT= 0.5, __RC__) !Fraction of dust within droplets for immersion freezing call MAPL_GetResource(MAPL, FDROP_SOOT, 'FDROP_SOOT:', DEFAULT= 0.05, __RC__) !Fraction of soot within droplets for immersion freezing - call MAPL_GetResource(MAPL, MINCDNC, 'MINCDNC:', DEFAULT= 25.0, __RC__) !min nucleated droplet conc. cm-3 + call MAPL_GetResource(MAPL, MINCDNC, 'MINCDNC:', DEFAULT= 52.0, __RC__) !min nucleated droplet conc. cm-3 call MAPL_GetResource(MAPL, MTIME, 'MTIME:', DEFAULT= -1.0, __RC__) !Mixing time scale for aerosol within the cloud. Default is time step - - - !===only applicable f not using Wnet nor WSUB_CLIM) - call MAPL_GetResource(MAPL, SWCIRRUS, 'SWCIRRUS:', DEFAULT= 3.0, __RC__) !Tunes vertical velocity in cirrus - call MAPL_GetResource(MAPL, MIN_ALH, 'MIN_ALH:', DEFAULT= 5.0, __RC__) !minimum PBL height - call MAPL_GetResource(MAPL, SCWST, 'SCWST:', DEFAULT= 3.0, __RC__) !scale factor for vertical velocity in sttratocumulus call MAPL_GetResource(MAPL, LCCIRRUS, 'LCCIRRUS:', DEFAULT= 500.0, __RC__) !Characteristic Length (m) of high freq gravity waves + call MAPL_GetResource(MAPL, QCVAR_CST, 'QCVAR_CST:', DEFAULT= -1., __RC__) !with of P(QL). Set to -1 to use Xie 2012 correlation. + call MAPL_GetResource(MAPL, PRECIPRAD, 'PRECIPRAD:', DEFAULT= 1., __RC__) !0 disables rad effect of precip + call MAPL_GetResource(MAPL, USE_AREA, 'USE_AREA:', DEFAULT= 1., __RC__) !set to zero for SCM + + call MAPL_GetResource(MAPL, DROPSZCNV, 'DROPSZCNV:', DEFAULT= 25.e-6 ,RC=STATUS) !drop vol radius in cnv + call MAPL_GetResource(MAPL, ICESZCNV_SC, 'ICESZCNV_SC:', DEFAULT= 1. ,RC=STATUS) !scaling ice eff radius in cnv + + !============ - call MAPL_GetResource(MAPL, DUST_INFAC, 'DUST_INFAC:', DEFAULT= 1.0, __RC__) !scalings for the INP concentrations + call MAPL_GetResource(MAPL, DUST_INFAC, 'DUST_INFAC:', DEFAULT= 1.0, __RC__) !scalings for the INP concentrations for dep mode call MAPL_GetResource(MAPL, BC_INFAC, 'BC_INFAC:', DEFAULT= 0.1, __RC__) call MAPL_GetResource(MAPL, ORG_INFAC, 'ORG_INFAC:', DEFAULT= 1.0, __RC__) - call MAPL_GetResource(MAPL, SS_INFAC, 'SS_INFAC:', DEFAULT= 1.0, __RC__) - + call MAPL_GetResource(MAPL, SS_INFAC, 'SS_INFAC:', DEFAULT= 1.0, __RC__) call MAPL_GetResource(MAPL, DT_MICRO, 'DT_MICRO:', DEFAULT= 300.0, __RC__) ! time step of the microphysics substepping (s) (MG2) (5 min) - call MAPL_GetResource(MAPL, UR_SCALE, 'URSCALE:', DEFAULT= 1.0, __RC__) !Scaling factor for sed vel of rain - call MAPL_GetResource(MAPL, USE_WSUB_CLIM, 'USE_WSUB_CLIM:', DEFAULT= 1.0, __RC__) !Use Wsub climatology - call MAPL_GetResource( MAPL, RRTMG_IRRAD , 'USE_RRTMG_IRRAD:',DEFAULT=1.0, __RC__) - call MAPL_GetResource( MAPL, RRTMG_SORAD , 'USE_RRTMG_SORAD:',DEFAULT=1.0, __RC__) - call MAPL_GetResource(MAPL, CNV_NUMLIQ_SC, 'CNV_NUMLIQ_SC:', DEFAULT= 0.5 ,RC=STATUS) !scaling for the particle size of conv detrainment - call MAPL_GetResource(MAPL, CNV_NUMICE_SC, 'CNV_NUMICE_SC:', DEFAULT= 2.5 ,RC=STATUS) !scaling for the particle size of conv detrainment - call MAPL_GetResource(MAPL, DCS, 'DCS:' , DEFAULT=250.0e-6, __RC__ ) !ice/snow separation diameter + call MAPL_GetResource(MAPL, URSCALE, 'URSCALE:', DEFAULT= 1.0, __RC__) !Scaling factor for sed vel of rain + call MAPL_GetResource(MAPL, RRTMG_IRRAD , 'USE_RRTMG_IRRAD:',DEFAULT=1.0, __RC__) + call MAPL_GetResource(MAPL, RRTMG_SORAD , 'USE_RRTMG_SORAD:',DEFAULT=1.0, __RC__) + !call MAPL_GetResource(MAPL, CNV_GSC, 'CNV_GSC:', DEFAULT= 1.0e-4 ,RC=STATUS) !linear scaling for NCPL of conv detrainment + !call MAPL_GetResource(MAPL, CNV_BSC, 'CNV_BSC:', DEFAULT= 0.1, RC=STATUS) !scaling for N=B*Nad for conv detrainment + call MAPL_GetResource(MAPL, DCS, 'DCS:' , DEFAULT=291.0e-6, __RC__ ) !ice/snow separation diameter Dcsr8 = DCS - call MAPL_GetResource(MAPL, QCVAR_, 'QCVAR:' , DEFAULT= 2.0 ,__RC__) !variance of the QL distribution (if assumed constant) - qcvarr8=QCVAR_ - call MAPL_GetResource(MAPL, WBFFACTOR, 'WBFFACTOR:', DEFAULT= 1.0 ,__RC__) !scaling for the Bergeron-Findeinsen process rate + call MAPL_GetResource(MAPL, WBFFACTOR, 'WBFFACTOR:', DEFAULT= 0.091 ,__RC__) !scaling for the Bergeron-Findeinsen process rate micro_mg_berg_eff_factor_in = WBFFACTOR call MAPL_GetResource(MAPL, NC_CST , 'NC_CST:' , DEFAULT= 0.0 ,__RC__) !constant nd (set if greather than zero) call MAPL_GetResource(MAPL, NI_CST , 'NI_CST:' , DEFAULT= 0.0 ,__RC__) !constant nd (set if greather than zero) call MAPL_GetResource(MAPL, NG_CST , 'NG_CST:' , DEFAULT= 0.0 ,__RC__) !constant ng (set if greather than zero) - call MAPL_GetResource(MAPL, MUI_CST, 'MUI_CST:', DEFAULT= -1.0 ,__RC__) !constant ng (set if greather than zero) - + call MAPL_GetResource(MAPL, MUI_CST, 'MUI_CST:', DEFAULT= -1. ,__RC__) !value of the dispersion exponent in ice size dist. + call MAPL_GetResource(MAPL, WSUB_OPTION, 'WSUB_OPTION:', DEFAULT= 1.0, __RC__) !0- param 1- Use Wsub climatology 2-Wnet + call MAPL_GetResource(MAPL, SECOND_HYSTPDF, 'SECOND_HYSTPDF:', DEFAULT= .TRUE. ,RC=STATUS) !drop vol radius in cnv + + mui_cnstr8 = MUI_CST ncnstr8 = NC_CST if (NC_CST .gt. 0.0) nccons =.true. @@ -438,7 +432,7 @@ subroutine MGB2_2M_Initialize (MAPL, RC) nccons, nicons, ncnstr8, ninstr8, ngcons, ngnstr8, mui_cnstr8) else call ini_micro(Dcsr8, micro_mg_berg_eff_factor_in, & - nccons, nicons, ncnstr8, ninstr8, qcvarr8) + nccons, nicons, ncnstr8, ninstr8, 2.0) end if call aer_cloud_init() @@ -466,10 +460,10 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) ! Internals real, pointer, dimension(:,:,:) :: Q, QLLS, QLCN, CLLS, CLCN, QILS, QICN, QRAIN, QSNOW, QGRAUPEL - real, pointer, dimension(:,:,:) :: NCPL, NCPI, NRAIN, NSNOW, NGRAUPEL + real, pointer, dimension(:,:,:) :: NCPL, NCPI, NRAIN, NSNOW, NGRAUPEL, NACTI, NACTL ! Imports real, pointer, dimension(:,:,:) :: ZLE, PLE, PK, T, U, V, W, KH, TKE - real, pointer, dimension(:,:) :: AREA, FRLAND, TS, DTSX, SH, EVAP, KPBLSC + real, pointer, dimension(:,:) :: AREA, FRLAND, TS, SH, EVAP, KPBL_SC real, pointer, dimension(:,:,:) :: SL2, SL3, QT2, QT3, W2, W3, SLQT, WQT, WQL, WSL real, pointer, dimension(:,:,:) :: WTHV2 real, pointer, dimension(:,:,:) :: OMEGA @@ -478,14 +472,10 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) real, pointer, dimension(:,:,:) :: ALH, RADLW, RADSW, WSUB_CLIM ! Local - real, allocatable, dimension(:,:,:) :: U0, V0 real, allocatable, dimension(:,:,:) :: PLEmb, ZLE0 real, allocatable, dimension(:,:,:) :: PLmb, ZL0, GZLO real, allocatable, dimension(:,:,:) :: DZET, DP, MASS, iMASS real, allocatable, dimension(:,:,:) :: DQST3, QST3 - real, allocatable, dimension(:,:,:) :: DQVDTmic, DQLDTmic, DQRDTmic, DQIDTmic, & - DQSDTmic, DQGDTmic, DQADTmic, & - DUDTmic, DVDTmic, DTDTmic real, allocatable, dimension(:,:,:) :: TMP3D real, allocatable, dimension(:,:) :: IKEX, IKEX2 real, allocatable, dimension(:,:) :: frland2D @@ -505,7 +495,7 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) real, pointer, dimension(:,:,:) :: PFL_LS, PFL_AN real, pointer, dimension(:,:,:) :: PFI_LS, PFI_AN real, pointer, dimension(:,:,:) :: PDF_A, PDFITERS - real, pointer, dimension(:,:,:) :: RHCRIT3D + real, pointer, dimension(:,:,:) :: RHCRIT real, pointer, dimension(:,:,:) :: PTR3D real, pointer, dimension(:,: ) :: PTR2D #ifdef PDFDIAG @@ -517,58 +507,51 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) !2m real, pointer, dimension(:,:,:) :: SC_ICE, CDNC_NUC, INC_NUC, PFRZ, & - CFICE, CFLIQ, DT_RASP, SMAXL, SMAXI, WSUB, CCN01, CCN04, CCN1, & + CFICE, CFLIQ, SMAX_LIQ, SMAX_ICE, WSUB, CCN01, CCN04, CCN1, & NHET_NUC, NLIM_NUC, SO4, ORG, BCARBON, DUST, SEASALT, NCPL_VOL, NCPI_VOL, & SAT_RAT, RHICE, RL_MASK, RI_MASK, & NHET_IMM, NHET_DEP, DUST_IMM, DUST_DEP, SIGW_GW, SIGW_CNV, SIGW_TURB, & SIGW_RC, BERG, BERGS, MELT, DNHET_CT, QCRES, QIRES, AUTICE, FRZPP_LS, & SNOWMELT_LS, DNCNUC, DNCSUBL, DNCHMSPLIT, DNCAUTICE, DNCACRIS, DNDCCN, & DNDACRLS, DNDACRLR, DNDEVAPC, DNDAUTLIQ, DNDCNV, DNICNV, & - CNV_UPDF, CNV_CVW, DNHET_IMM, CNV_MFD, CNV_DQCDT, KAPPA, RHCmicro, RHLIQ, & + DNHET_IMM, CNV_MFD, KAPPA, RHCmicro, RHLIQ, & CNV_NICE, CNV_NDROP, NWFA, CNV_FICE - - real, pointer, dimension(:,:) :: EIS, LTS, QCVAR_EXP, & + + real, pointer, dimension(:,:) :: EIS, LTS, QCVAR, & CCNCOLUMN, NDCOLUMN, NCCOLUMN - real, allocatable, dimension(:,:,:) :: dNI, dNL, QCNTOT, CFX, QTOT, & - QL_TOT, QI_TOT, ACIL_LS_X, ACIL_AN_X, ACLL_LS_X, ACLL_AN_X, DLPDF_X, DIPDF_X, DLFIX_X, DIFIX_X, & - AUT_X, SDM_X, FRZ_TT_X, FRZ_PP_X, DCNVL_X, DCNVI_X, AIRDEN, TH1, FQA, ALPH3D !check how much of these we are actually using + real, allocatable, dimension(:,:,:) :: CFX, & + ACIL_LS_X, ACIL_AN_X, ACLL_LS_X, ACLL_AN_X, DLPDF_X, DIPDF_X, DLFIX_X, DIFIX_X, & + AUT_X, SDM_X, FRZ_TT_X, FRZ_PP_X, AIRDEN, TH1 !check how much of these we are actually using - integer, allocatable, dimension(:, :) :: KMIN_TROP, KLCL - real, allocatable, dimension(:, :) :: NPRE_FRAC_2d, CLDREFFI_TOP_X, CLDREFFL_TOP_X, NCPL_TOP_X, NCPI_TOP_X, NCPL_CLDBASEX, ZWS, ZPBL + integer, allocatable, dimension(:, :) :: KLCL + real, allocatable, dimension(:, :) :: CLDREFFI_TOP_X, CLDREFFL_TOP_X, NCPL_TOP_X, NCPI_TOP_X, NCPL_CLDBASEX, uwind_gw ! Local variables - real :: ALPHA, RHCRIT + real :: ALPHA integer :: IM,JM,LM integer :: I, J, L, K - integer :: num_steps_micro, pcnst, n_modes, kbmin, kcldtop, kcldbot , & - NAUX, kcldtopcvn, nbincontactdust, index, K0, KCBLMIN, i_src_mode, i_dst_mode + integer :: kbmin, NAUX, kcldtopcvn, nbincontactdust real, parameter :: pmin_trop = 10.0 !mbar minimum pressure to do cloud microphysics - logical :: use_average_v - REAL, allocatable, dimension(:,:) :: SCICE_tmp, FQA_tmp, tm_gw, pm_gw, nm_gw, theta_tr, & - fcn, cfaux, pi_gw, rhoi_gw, ni_gw, ti_gw, h_gw, Wbreak - + real, parameter :: QNcnvfac = 2.5e-4 !~0.75/denW/pi + real (ESMF_KIND_R8), dimension(3) :: ccn_diag real(ESMF_KIND_R8), allocatable, dimension(:,:,:) :: rndstr8,naconr8 !Assume maximum 5 dust bins real(ESMF_KIND_R8), dimension(1) :: prectr8, precir8 - real (ESMF_KIND_R8) :: tauxr8, fsoot_drop, fdust_drop, rh1_r8, & - frachet_dust, frachet_bc, frachet_org, frachet_ss, & - disp_liu, ui_scale, dcrit, tfreez, qcvar8, & - ts_autice, dcsr8, qcvarr8, scale_ri, mtimesc, urscale + real (ESMF_KIND_R8) :: disp_liu, ui_scale, & + ts_autice, scale_ri, mtimesc, ur_scale real(ESMF_KIND_R8), allocatable, dimension(:,:) :: ttendr8, qtendr8, cwtendr8, & cldor8, rpdelr8, zmr8, omegr8, rhdfdar8, rhu00r8, ficer8 , & - ndropr8, nimmr8, wparc, smaxliq, atot, smaxicer8, nheticer8, incr8, swparc, & - nhetr8, nlimicer8, qilsr8, wparc_gw, wparc_ls, wparc_turb, wparc_cnv, lc_turb, rad_cooling, wparc_rc, & - uwind_gw, wparc_cgw, pfrz_inc_r8, pintr8, kkvhr8, rflxr8, sflxr8, lflxr8, iflxr8, gflxr8, & - so4x, seasaltx, dustx, & - orgx, bcx, ter8,qvr8, qcr8,qir8, ncr8,nir8, qrr8,qsr8, nrr8,nsr8, & + qilsr8, & + pintr8, kkvhr8, rflxr8, sflxr8, lflxr8, iflxr8, gflxr8, & + ter8,qvr8, qcr8,qir8, ncr8,nir8, qrr8,qsr8, nrr8,nsr8, & qgr8,ngr8, relvarr8,accre_enhanr8, plevr8, pdelr8, cldfr8,liqcldfr8, & icecldfr8,qsatfacr8, qcsinksum_rate1ordr8, naair8, npccninr8, & tlatr8, qvlatr8, qctendr8, qitendr8, nctendr8, nitendr8, qrtendr8, & @@ -595,22 +578,18 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) nsootr8, rnsootr8, & ! soot for contact IN npccnor8, npsacwsor8,npraor8,nsubcor8, nprc1or8, & ! Number tendencies for liquid npraior8, nnucctor8, nnucccor8, nnuccdor8, nsubior8, nprcior8, & - nsacwior8, mnuccror8,pracsor8, qiresor8, rate1ord_cw2pr, & !only MG1 - sc_icer8, nhet_immr8, dnhet_immr8, nhet_depr8, & ! activation - dust_immr8, dust_depr8,dpre8, npre8, accre_enhan_icer8 + nsacwior8, mnuccror8,pracsor8, qiresor8, rate1ord_cw2pr, accre_enhan_icer8 - real :: maxkhpbl, tausurf_gw, fracover, cfc_aux, aux1,aux2,aux3,hfs,hfl, Nct, Wct, ksa1, Xscale + real :: tausurf_gw, aux1, aux2,aux3, npre, dpre, nact, xscale real(ESMF_KIND_R8) :: autscx - real, parameter :: r_air = 3.47d-3 !m3 Pa kg-1K-1 integer, parameter :: ncolmicro = 1 - type (AerProps) :: AeroAux, AeroAux_b + type (AerProps) :: AeroAux call init_Aer(AeroAux) - call init_Aer(AeroAux_b) - + call ESMF_GridCompGet( GC, CONFIG=CF, RC=STATUS ) VERIFY_(STATUS) @@ -643,36 +622,9 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) allocate(rhdfdar8(1,LM), __STAT__) allocate(rhu00r8(1,LM), __STAT__) allocate(ficer8(1,LM), __STAT__) - allocate(ndropr8(1,LM), __STAT__) - allocate(nimmr8(1,LM), __STAT__) - allocate(wparc(1,LM), __STAT__) - allocate(smaxliq(1,LM), __STAT__) - allocate(atot(1,LM), __STAT__) - allocate(smaxicer8(1,LM), __STAT__) - allocate(nheticer8(1,LM), __STAT__) - allocate(incr8(1,LM), __STAT__) - allocate(swparc(1,LM), __STAT__) - allocate(nhetr8(1,LM), __STAT__) - allocate(nlimicer8(1,LM), __STAT__) allocate(qilsr8(1,LM), __STAT__) - allocate(wparc_gw(1,LM), __STAT__) - allocate(wparc_ls(1,LM), __STAT__) - allocate(wparc_turb(1,LM), __STAT__) - allocate(wparc_cnv(1,LM), __STAT__) - allocate(lc_turb(1,LM), __STAT__) - allocate(rad_cooling(1,LM), __STAT__) - allocate(wparc_rc(1,LM), __STAT__) allocate(uwind_gw(1,LM), __STAT__) - allocate(wparc_cgw(1,LM), __STAT__) - allocate(pfrz_inc_r8(1,LM), __STAT__) - allocate(SCICE_tmp(1,LM), __STAT__) - allocate(FQA_tmp(1,LM), __STAT__) - - allocate(so4x(1,LM), __STAT__) - allocate(seasaltx(1,LM), __STAT__) - allocate(dustx(1,LM), __STAT__) - allocate(orgx(1,LM), __STAT__) - allocate(bcx(1,LM), __STAT__) + allocate(ter8(1,LM), __STAT__) allocate(qvr8(1,LM), __STAT__) allocate(qcr8(1,LM), __STAT__) @@ -830,15 +782,7 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) allocate(pracsor8(1,LM), __STAT__) allocate(qiresor8(1,LM), __STAT__) allocate(rate1ord_cw2pr(1,LM), __STAT__) - allocate(sc_icer8(1,LM), __STAT__) - allocate(nhet_immr8(1,LM), __STAT__) - allocate(dnhet_immr8(1,LM), __STAT__) - allocate(nhet_depr8(1,LM), __STAT__) - allocate(dust_immr8(1,LM), __STAT__) - allocate(dust_depr8(1,LM), __STAT__) allocate(accre_enhan_icer8(1,LM), __STAT__) - allocate(dpre8(1,LM), __STAT__) - allocate(npre8(1,LM), __STAT__) allocate(pintr8(1,LM+1), __STAT__) allocate(kkvhr8(1,LM+1), __STAT__) allocate(rflxr8(1,LM+1), __STAT__) @@ -847,36 +791,14 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) allocate(iflxr8(1,LM+1), __STAT__) allocate(gflxr8(1,LM+1), __STAT__) allocate(rndstr8(1,LM,10), __STAT__) - allocate(naconr8(1,LM,10), __STAT__) - allocate(tm_gw(1,LM), __STAT__) - allocate(pm_gw(1,LM), __STAT__) - allocate(nm_gw(1,LM), __STAT__) - allocate(theta_tr(1,LM), __STAT__) - allocate(fcn(1,LM), __STAT__) - allocate(cfaux(1,LM), __STAT__) - allocate(pi_gw(1,0:LM), __STAT__) - allocate(rhoi_gw(1,0:LM), __STAT__) - allocate(ni_gw(1,0:LM), __STAT__) - allocate(ti_gw(1,0:LM), __STAT__) - allocate(h_gw(1,0:LM), __STAT__) + allocate(naconr8(1,LM,10), __STAT__) - allocate(KMIN_TROP(IM,JM), __STAT__) - allocate(NPRE_FRAC_2d(IM,JM), __STAT__) - allocate(ZWS(IM,JM), __STAT__) - allocate(ZPBL(IM,JM), __STAT__) - - allocate(FQA(IM,JM,LM ), __STAT__) - allocate(ALPH3D(IM,JM,LM ), __STAT__) allocate(GZLO(IM,JM,LM ), __STAT__) allocate(TH1(IM,JM,LM ), __STAT__) allocate(PK(IM,JM,LM ), __STAT__) - allocate(QCNTOT(IM,JM,LM), __STAT__) allocate(CFX(IM,JM,LM), __STAT__) allocate(AIRDEN(IM,JM,LM), __STAT__) - allocate(QTOT(IM,JM,LM ), __STAT__) - allocate(QL_TOT(IM,JM,LM ), __STAT__) - allocate(QI_TOT(IM,JM,LM ), __STAT__) allocate(ACIL_AN_X(IM,JM,LM ), __STAT__) allocate(ACIL_LS_X(IM,JM,LM ), __STAT__) allocate(ACLL_AN_X(IM,JM,LM ), __STAT__) @@ -889,8 +811,6 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) allocate(SDM_X(IM,JM,LM ), __STAT__) allocate(FRZ_TT_X(IM,JM,LM ), __STAT__) allocate(FRZ_PP_X(IM,JM,LM ), __STAT__) - allocate(DCNVL_X(IM,JM,LM ), __STAT__) - allocate(DCNVI_X(IM,JM,LM ), __STAT__) allocate(CLDREFFI_TOP_X(IM,JM ), __STAT__) allocate(CLDREFFL_TOP_X(IM,JM ), __STAT__) allocate(NCPL_TOP_X(IM,JM ), __STAT__) @@ -913,11 +833,13 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) call MAPL_GetPointer(INTERNAL, CLLS, 'CLLS' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(INTERNAL, QILS, 'QILS' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(INTERNAL, QICN, 'QICN' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, NCPL, 'NCPL' , __RC__) - call MAPL_GetPointer(INTERNAL, NCPI, 'NCPI' , __RC__) - call MAPL_GetPointer(INTERNAL, NRAIN, 'NRAIN' , __RC__) - call MAPL_GetPointer(INTERNAL, NSNOW, 'NSNOW' , __RC__) - call MAPL_GetPointer(INTERNAL, NGRAUPEL, 'NGRAUPEL' , __RC__) + call MAPL_GetPointer(INTERNAL, NCPL, 'NCPL' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, NCPI, 'NCPI' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, NRAIN, 'NRAIN' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, NSNOW, 'NSNOW' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, NGRAUPEL, 'NGRAUPEL' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, NACTL, 'NACTL' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, NACTI, 'NACTI' , RC=STATUS); VERIFY_(STATUS) ! Import State @@ -941,7 +863,7 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) call MAPL_GetPointer(IMPORT, QT3, 'QT3' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, SLQT, 'SLQT' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, TS, 'TS' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, KPBLSC, 'KPBL_SC' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, KPBL_SC, 'KPBL_SC' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, SH, 'SH' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, EVAP, 'EVAP' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, OMEGA, 'OMEGA' , RC=STATUS); VERIFY_(STATUS) @@ -957,13 +879,12 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) call MAPL_GetPointer(EXPORT, CFICE, 'CFICE' , ALLOC=.TRUE., __RC__) call MAPL_GetPointer(EXPORT, CFLIQ, 'CFLIQ' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, CNV_FICE, 'CNV_FICE' , ALLOC=.TRUE., __RC__) call MAPL_GetPointer(EXPORT, CCNCOLUMN, 'CCNCOLUMN' , ALLOC=.TRUE., __RC__) call MAPL_GetPointer(EXPORT, NDCOLUMN, 'NDCOLUMN' , ALLOC=.TRUE., __RC__) call MAPL_GetPointer(EXPORT, NCCOLUMN, 'NCCOLUMN' , ALLOC=.TRUE., __RC__) call MAPL_GetPointer(EXPORT, RHLIQ, 'RHLIQ' , ALLOC=.TRUE., __RC__) call MAPL_GetPointer(EXPORT, RHCmicro, 'RHCmicro' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, QCVAR_EXP, 'QCVAR_EXP' , ALLOC=.TRUE., __RC__) + call MAPL_GetPointer(EXPORT, QCVAR, 'QCVAR' , ALLOC=.TRUE., __RC__) call MAPL_GetPointer(EXPORT, SC_ICE, 'SC_ICE' , ALLOC=.TRUE., __RC__) call MAPL_GetPointer(EXPORT, CLDREFFR, 'RR' , ALLOC=.TRUE., __RC__) call MAPL_GetPointer(EXPORT, CLDREFFS, 'RS' , ALLOC=.TRUE., __RC__) @@ -973,8 +894,8 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) call MAPL_GetPointer(EXPORT, PFRZ, 'PFRZ' , ALLOC=.TRUE., __RC__) call MAPL_GetPointer(EXPORT, LTS, 'LTS' , ALLOC=.TRUE., __RC__) call MAPL_GetPointer(EXPORT, EIS, 'EIS' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, SMAXL, 'SMAX_LIQ' , ALLOC=.TRUE., __RC__) - call MAPL_GetPointer(EXPORT, SMAXI, 'SMAX_ICE' , ALLOC=.TRUE., __RC__) + call MAPL_GetPointer(EXPORT, SMAX_LIQ, 'SMAX_LIQ' , ALLOC=.TRUE., __RC__) + call MAPL_GetPointer(EXPORT, SMAX_ICE, 'SMAX_ICE' , ALLOC=.TRUE., __RC__) call MAPL_GetPointer(EXPORT, WSUB, 'WSUB' , ALLOC=.TRUE., __RC__) call MAPL_GetPointer(EXPORT, CCN01, 'CCN01' , ALLOC=.TRUE., __RC__) call MAPL_GetPointer(EXPORT, CCN04, 'CCN04' , ALLOC=.TRUE., __RC__) @@ -1025,8 +946,8 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) call MAPL_GetPointer(EXPORT, KAPPA, 'KAPPA' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) ! This export MUST have been filled in the GridComp - call MAPL_GetPointer(EXPORT, CNV_FRC, 'CNV_FRC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, SRF_TYPE, 'SRF_TYPE' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, CNV_FRC, 'CNV_FRC' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, SRF_TYPE, 'SRF_TYPE' , RC=STATUS); VERIFY_(STATUS) ! Allocatables @@ -1034,8 +955,6 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) ALLOCATE ( ZLE0 (IM,JM,0:LM) ) ALLOCATE ( PLEmb(IM,JM,0:LM) ) ! Layer variables - ALLOCATE ( U0 (IM,JM,LM ) ) - ALLOCATE ( V0 (IM,JM,LM ) ) ALLOCATE ( ZL0 (IM,JM,LM ) ) ALLOCATE ( PLmb (IM,JM,LM ) ) ALLOCATE ( DZET (IM,JM,LM ) ) @@ -1065,12 +984,40 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) DP = ( PLE(:,:,1:LM)-PLE(:,:,0:LM-1) ) MASS = DP/MAPL_GRAV iMASS = 1.0/MASS - U0 = U - V0 = V PK = (100.0*PLmb/MAPL_P00)**(MAPL_KAPPA) TH1 = T/PK AIRDEN = 100.*PLmb/T/MAPL_RGAS GZLO = MAPL_GRAV*ZL0 + + if (MGVERSION .lt. 2) then + QRAIN = 0. + QSNOW = 0. + QGRAUPEL = 0. + NRAIN = 0. + NSNOW = 0. + NGRAUPEL = 0. + end if + + + call fix_up_clouds_2M( & + Q, & + T, & + QLLS,& + QILS,& + CLLS, & + QLCN,& + QICN,& + CLCN, & + NCPL, & + NCPI, & + QRAIN, & + QSNOW, & + QGRAUPEL, & + NRAIN, & + NSNOW, & + NGRAUPEL, & + MASS, & + TMP2D) ! Lowe tropospheric stability and estimated inversion strength call MAPL_GetPointer(EXPORT, LTS, 'LTS' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) @@ -1078,8 +1025,7 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) KLCL = FIND_KLCL( T, Q, PLmb, IM, JM, LM ) call FIND_EIS(TH1, QST3, T, ZL0, PLEmb, KLCL, IM, JM, LM, LTS, EIS) - call find_l(KMIN_TROP, PLmb, pmin_trop, IM, JM, LM, 10, LM-2) - + !======================================================================================================================= !======================================================================================================================= !===================================Nucleation of cloud droplets and ice crystals ====================================== @@ -1093,279 +1039,215 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) call MAPL_TimerOn(MAPL,"---ACTIV") !Activation timer - - !================ Stratiform activation =========================================== - - if (NPRE_FRAC > 0.0) then - NPRE_FRAC_2d = NPRE_FRAC - else - ! include CNV_FRC dependence - DO J=1, JM - DO I=1, IM - NPRE_FRAC_2d(I,J) = CNV_FRC(I,J)*ABS(NPRE_FRAC) + (1-CNV_FRC(I,J))*0.05 - END DO - END DO - endif - - use_average_v = .false. - if (USE_AV_V .gt. 0.0) then - use_average_v = .true. - end if - fdust_drop = FDROP_DUST - fsoot_drop = FDROP_SOOT - frachet_org = ORG_INFAC - frachet_dust = DUST_INFAC - frachet_bc = BC_INFAC - frachet_ss = SS_INFAC + + SIGW_RC = -OMEGA/AIRDEN/MAPL_GRAV + (RADLW + RADSW)*MAPL_CP/MAPL_GRAV + + !!=============== find vertical velocity variance - - if (USE_WSUB_CLIM .gt. 0.) then - xscale = 8.7475*(real(imsize)**(-0.328)) ! scale for resolutions =! 50 km - end if - !Supersaturations to calculate CCN diagnostics - !ccn_diag(1)=0.001 - !ccn_diag(2)=0.004 - !ccn_diag(3)=0.01 + if (WSUB_OPTION .lt. 1.) then ! use parameterization from Barahona et al. GMD. 2014 (Appendix) + + do J=1,JM + do I=1,IM + + uwind_gw(1,1:LM) = min(0.5*SQRT( U(I,J,1:LM)**2+ V(I,J,1:LM)**2), 50.0) + tausurf_gw = min(0.5*SQRT(TAUOROX(I , J)**2+TAUOROY(I , J)**2), 10.0) !limit to a very high value + + call vertical_vel_variance(T(I,J,1:LM), TKE(I,J,1:LM), 100.0*PLmb(I,J,1:LM), PLE(I,J,0:LM), uwind_gw(1,1:LM), & + tausurf_gw, AIRDEN(I,J,1:LM), LM, LCCIRRUS, -SH (i,j), -EVAP(i,j), ZL0(I, J, NINT(KPBL_SC(I,J))), & + SIGW_GW (I, J, 1:LM), SIGW_TURB (I, J, 1:LM), SIGW_CNV (I, J, 1:LM), WSUB (I, J, 1:LM), & + SIGW_RC(I, J, 1:LM)) + + end do + end do + else !WSUB climatology + + WSUB = WSUB_CLIM + DO J=1, JM + DO I = 1, IM + xscale = log10(AREA(I, J)) + xscale = 0.089*xscale*xscale - 1.1812*xscale + 4.2627 ! scale for resolutions =! 50 km for WSUB_OPTION >= 1 + xscale = min(max(xscale, 0.1), 1.6) + WSUB(I, J, :) = WSUB_CLIM(I, J, :)*xscale + END DO + END DO + SIGW_TURB = WSUB + !call WRITE_PARALLEL ('Using Wclim***************') - do J=1,JM - do I=1,IM - - smaxliq = 0.0 - smaxicer8 = 0.0 - nheticer8 = 0.0 - sc_icer8 = 1.0 - naair8 = 0.0 - npccninr8 = 0.0 - nlimicer8 = 0.0 - nhet_immr8 = 0.0 - dnhet_immr8 = 0.0 - nhet_depr8 = 0.0 - dust_immr8 = 0.0 - dust_depr8 = 0.0 - so4x = 0.0 - dustx = 0.0 - bcx= 0.0 - orgx=0.0 - seasaltx=0.0 - wparc_ls = 0.0 - wparc_gw = 0.0 - wparc_cgw= 0.0 - wparc_turb = 0.0 - swparc=0.0 - pfrz_inc_r8 = 0.0 - omegr8(1,1:LM) = OMEGA(I,J,1:LM) - kbmin= min(NINT(KPBLSC(I, J)), LM-1)-2 - rad_cooling(1,1:LM) = RADLW(I,J,1:LM)+RADSW(I,J,1:LM) - wparc_ls(1,1:LM) =-OMEGA(I,J,1:LM)/AIRDEN(I,J,1:LM)/MAPL_GRAV + MAPL_CP*rad_cooling(1,1:LM)/MAPL_GRAV - - !!=============== find vertical velocity variance - - if (USE_WSUB_CLIM .le. 0.) then - - uwind_gw(1,1:LM) = min(0.5*SQRT( U0(I,J,1:LM)**2+ V0(I,J,1:LM)**2), 50.0) - tausurf_gw = min(0.5*SQRT(TAUOROX(I , J)**2+TAUOROY(I , J)**2), 10.0) !limit to a very high value - aux1=PLE(i,j,LM)/(287.04*(T(i,j,LM)*(1.+0.608*Q(i,j,LM)))) ! air_dens (kg m^-3) - hfs = -SH (i,j) ! W m^-2 - hfl = -EVAP(i,j) ! kg m^-2 s^-1 - aux2= (hfs/MAPL_CP + 0.608*T(i,j,LM)*hfl)/aux1 ! buoyancy flux (h+le) - aux3= ZLE(I, J, NINT(KPBLSC(I,J))) ! pbl height (m) - !-convective velocity scale W* (m/s) - ZWS(i,j) = max(0.,0.001-1.5*0.41*MAPL_GRAV*aux2*aux3/T(i,j,LM)) - ZWS(i,j) = 1.2*ZWS(i,j)**0.3333 ! m/s - pi_gw(1, 0:LM) = PLE(I,J,0:LM) - theta_tr(1,1:LM) = TH1(I,J,1:LM) - rhoi_gw = 0.0 - pi_gw(1, 0:LM) = 100.0*PLE(I,J,0:LM) - ni_gw = 0.0 - ti_gw = 0.0 - tm_gw =ter8 - pm_gw =plevr8 - h_gw = 0.0 - if (FRLAND(I, J) .lt. 0.1) then - lc_turb(1,1:LM) = max(ALH(I,J,1:LM), MIN_ALH) - else - lc_turb(1,1:LM) = max(ALH(I,J,1:LM), 50.0) - end if + end if - call gw_prof (1, LM, 1, tm_gw, pm_gw, pi_gw, & - rhoi_gw, ni_gw, ti_gw, nm_gw) !get Brunt_Vaisala Frequency and midpoint densities - - - h_gw(1,1:LM)= (2d0*MAPL_PI/LCCIRRUS)*AIRDEN(I, J,1:LM)*uwind_gw(1,1:LM)*nm_gw(1,1:LM) + ! ========================================================================================== + ! ========================Activate the aerosols ============================================ - where (h_gw .gt. 0.0) - h_gw=sqrt(2.0*tausurf_gw/h_gw) - end where - Wbreak = 0.133*(2d0*MAPL_PI/LCCIRRUS)*uwind_gw/nm_gw !Vertical velocity variance at saturation - - wparc_gw=(2d0*MAPL_PI/LCCIRRUS)*uwind_gw*h_gw*0.133 !account for gravity wave breaking - wparc_gw = min(wparc_gw, Wbreak) - wparc_gw=wparc_gw*wparc_gw + SC_ICE = 1.0 + + do J=1,JM + do I=1,IM + + kbmin= min(NINT(KPBL_SC(I, J)), LM-1)-2 + npre = NPRE_FRAC + dpre= 1.0e-9 + if (NPRE_FRAC < 0.0) npre = CNV_FRC(I,J)*ABS(NPRE_FRAC) + (1-CNV_FRC(I,J))*0.05 - wparc_turb(1,1:LM) =TKE(I, J, 1:LM) - do K = KMIN_TROP(I, J), LM-1 - if (FRLAND(I, J) .lt. 0.1) then - if (LTS(I, J) .gt. LTS_LOW) then - if (K .ge. kbmin-2) wparc_ls(1, K) = max(wparc_ls(1,K)+ zws(i, j), 0.00)*SCWST ! add convective velocity within the PBL - end if - end if - if (K .ge. kbmin-2) wparc_ls(1, K)=max(wparc_ls(1,K)+ zws(i, j), 0.00) - if (K .ge. kbmin-2) wparc_turb(1, K)=max(wparc_turb(1,K), 0.04) !minimum velocity within the PBL (not resolved by RAS) - - swparc(1, K)=sqrt(wparc_gw(1, K)+wparc_turb(1, K)+ wparc_cgw(1, K)) - end do - - else - swparc(1,1:LM) = WSUB_CLIM(I, j, 1:LM) - end if - - - ter8(1,1:LM) = T(I,J,1:LM) - plevr8(1,1:LM) = 100.0*PLmb(I,J,1:LM) - ndropr8(1,1:LM) = NCPL(I, J, 1:LM) - qir8(1,1:LM) = QILS(I, J,1:LM)+QICN(I, J,1:LM) - qcr8(1,1:LM) = QLLS(I, J,1:LM)+QLCN(I, J,1:LM) - npre8(1,1:LM) = NPRE_FRAC_2d(I,J)*NCPI(I,J,1:LM) - where ((npre8 .gt. 0.0) .and. (qir8 .gt. 0.0)) - dpre8 = ( qir8/(5400.0*npre8*MAPL_PI))**(0.33) !Assume exponential distribution - elsewhere - dpre8=1.0e-9 - end where - - ! ========================================================================================== - ! ========================Activate the aerosols ============================================ - - - - do K = KMIN_TROP(I, J), LM-1 !limit to troposphere and no activation at the surface - - AeroAux%nmods = 0 - AeroAux%num = 0.0 - do i_src_mode = 1, AeroProps(I,J,K)%nmods - if (AeroProps(I,J,K)%num(i_src_mode) > 0.1) then - AeroAux%nmods = AeroAux%nmods + 1 - i_dst_mode = AeroAux%nmods - - AeroAux%num(i_dst_mode) = AeroProps(I,J,K)%num(i_src_mode) - AeroAux%dpg(i_dst_mode) = AeroProps(I,J,K)%dpg(i_src_mode) - AeroAux%sig(i_dst_mode) = AeroProps(I,J,K)%sig(i_src_mode) - AeroAux%den(i_dst_mode) = AeroProps(I,J,K)%den(i_src_mode) - AeroAux%kap(i_dst_mode) = AeroProps(I,J,K)%kap(i_src_mode) - AeroAux%fdust(i_dst_mode) = AeroProps(I,J,K)%fdust(i_src_mode) - AeroAux%fsoot(i_dst_mode) = AeroProps(I,J,K)%fsoot(i_src_mode) - AeroAux%forg(i_dst_mode) = AeroProps(I,J,K)%forg(i_src_mode) - end if - end do - - !!Subroutine aerosol_activate contains the CCN activation and ice nucleation parameterizations. Lives in aer_cloud.F90. - - call aerosol_activate(ter8(1, k), plevr8(1, K), swparc(1, K), wparc_ls(1, K), AeroAux, & - npre8(1, k), dpre8(1, k), ccn_diag, ndropr8(1, k), qcr8(1, K), & - npccninr8(1, K), smaxliq(1, K), naair8(1, K), smaxicer8(1, K), nheticer8(1, K), & - nhet_immr8(1, K), dnhet_immr8(1, K), nhet_depr8(1, k), sc_icer8(1, k), & - dust_immr8(1, K), dust_depr8(1, k), nlimicer8(1, k), use_average_v, int(CCN_PARAM), int(IN_PARAM), & - so4x(1, k), seasaltx(1, k), dustx(1, k), orgx(1, K), bcx(1, k), & - fdust_drop, fsoot_drop, pfrz_inc_r8(1, K), rh1_r8, frachet_dust, frachet_bc, frachet_org, frachet_ss, int(Immersion_PARAM)) - - CCN01(I, J, K) = max(ccn_diag(1), 0.0) - CCN04(I, J, K) = max(ccn_diag(2), 0.0) - CCN1 (I, J, K) = max(ccn_diag(3), 0.0) - - if (K .ge. kbmin-6) npccninr8(1, K) = max(npccninr8(1, K), (1.0-CNV_FRC(I, J))*MINCDNC*1.e6) - - end do + do K = 1, LM-1 !limit to troposphere and no activation at the surface + + npre = npre*NCPI(I,J,K) + aux2 = QILS(I, J, K)+ QICN(I, J, K) + if ((npre .gt. 0.0) .and. (aux2 .gt. 0.)) dpre = ( aux2/(5400.0*npre*MAPL_PI))**(0.33) !Assume exponential distribution - SMAXL(I, J, 1:LM) = real(smaxliq(1,1:LM)*100.0) - SMAXI(I, J, 1:LM) = real(smaxicer8(1,1:LM)*100.0) - NHET_NUC(I, J, 1:LM) = real(nheticer8(1,1:LM)) - NLIM_NUC(I, J, 1:LM) = real(nlimicer8(1,1:LM)) - SC_ICE(I, J, 1:LM) = real(sc_icer8(1,1:LM)) - CDNC_NUC(I,J,1:LM) = real(npccninr8(1,1:LM)) - INC_NUC (I,J,1:LM) = real(naair8(1,1:LM) ) - NHET_IMM(I, J, 1:LM) = real(max(nhet_immr8(1,1:LM), 0.0)) - DNHET_IMM(I, J, 1:LM) = real(max(dnhet_immr8(1,1:LM), 0.0)) - NHET_DEP(I, J, 1:LM) = real(nhet_depr8(1,1:LM)) - DUST_IMM(I, J, 1:LM) = real(max(dust_immr8(1,1:LM), 0.0)) - DUST_DEP(I, J, 1:LM) = real(max(dust_depr8(1,1:LM), 0.0)) - WSUB (I, J, 1:LM) = real(wparc_ls(1,1:LM)+swparc(1,1:LM)*0.8) - SIGW_GW (I, J, 1:LM) = real( wparc_gw(1,1:LM)) - SIGW_CNV (I, J, 1:LM) = real(wparc_cgw(1,1:LM)) - SIGW_TURB (I, J, 1:LM) = real(wparc_turb(1,1:LM)) - SIGW_RC (I, J, 1:LM) = real(wparc_ls(1,1:LM)) - PFRZ (I, J, 1:LM) = real(pfrz_inc_r8(1,1:LM)) - - SO4(I, J, 1:LM)=real(so4x(1,1:LM)) - DUST(I, J, 1:LM)=real(dustx(1,1:LM)) - BCARBON(I, J, 1:LM)=real(bcx(1,1:LM)) - ORG(I, J, 1:LM)=real(orgx(1,1:LM)) - SEASALT(I, J, 1:LM)=real(seasaltx(1,1:LM)) - + !!Subroutine aerosol_activate contains the CCN activation and ice nucleation parameterizations. Lives in aer_cloud.F90. + + call aerosol_activate(T(I, J, K), 100.*PLmb(I, J, K), WSUB(I, J, K), SIGW_RC(I, J, K), AeroProps(I, J, K), & + npre, dpre, ccn_diag, & + nact, SMAX_LIQ(I, J, K), INC_NUC (I, J, K), SMAX_ICE(I, J, K) , NHET_NUC(I, J, K), & + NHET_IMM(I, J, K), DNHET_IMM(I, J, K) , NHET_DEP(I, J, K) , SC_ICE(I, J, K) , & + DUST_IMM(I, J, K), DUST_DEP(I, J, K), NLIM_NUC(I, J, K), USE_AV_V, int(CCN_PARAM), int(IN_PARAM), & + SO4(I, J, K), SEASALT(I, J, K), DUST(I, J, K), ORG(I, J, K), BCARBON(I, J, K), & + FDROP_DUST, FDROP_SOOT, DUST_INFAC, BC_INFAC, ORG_INFAC, SS_INFAC, int(Immersion_PARAM)) + + + CCN01(I, J, K) = max(ccn_diag(1), 0.0) + CCN04(I, J, K) = max(ccn_diag(2), 0.0) + CCN1 (I, J, K) = max(ccn_diag(3), 0.0) + + if (K .ge. kbmin-4) nact = max(nact, (1.0-CNV_FRC(I, J))*MINCDNC*1.e6) + + CDNC_NUC(I, J, K) = nact + + end do enddo enddo - - where (T .gt. 238.0) - SC_ICE = 1.0 - end where - where (SC_ICE < 1.0) - SC_ICE = 1.0 - end where - where (SC_ICE > 1.8) - SC_ICE = 1.8 - end where + WSUB = SIGW_RC + 0.8*WSUB !diagnostic - call MAPL_TimerOff(MAPL,"---ACTIV", __RC__) + where (T .gt. 238.0) + SC_ICE = 1.0 + end where + SC_ICE = MIN(MAX(SC_ICE, 1.0), 1.4) - !=============================================End cloud particle nucleation===================================== - !=============================================================================================================== + !SC_ICE = 1.0 ! test this - !====== Add convective detrainment of number concentration + call MAPL_TimerOff(MAPL,"---ACTIV", __RC__) - call MAPL_GetPointer(EXPORT, CNV_NICE, 'CNV_NICE', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, CNV_NDROP, 'CNV_NDROP', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - ! CNV_MFD includes Deep+Shallow mass flux - call MAPL_GetPointer(EXPORT, PTR3D, 'CNV_MFD', RC=STATUS); VERIFY_(STATUS) - + !=============================================End cloud particle nucleation===================================== + !=============================================================================================================== + + ! Export and/or scratch Variable + call MAPL_GetPointer(EXPORT, RAD_CF, 'FCLD', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, RAD_QV, 'QV' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, RAD_QL, 'QL' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, RAD_QI, 'QI' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, RAD_QR, 'QR' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, RAD_QS, 'QS' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, RAD_QG, 'QG' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, CLDREFFL, 'RL' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, CLDREFFI, 'RI' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + + + + !====== Add convective detrainment of number concentration + - DO I= 1, IM - DO J = 1, JM - kbmin = max(min(NINT(KPBLSC(I,J)), LM-1), NINT(0.7*LM)) - aux2= ZLE(I, J, kbmin ) !assume cldbase as PBLheight - aux3 = CDNC_NUC(I, J, kbmin) - Do K = 1, LM - call make_cnv_ice_drop_number(CNV_NDROP(I, J, K), CNV_NICE(I, J, K), \ - aux3, ZLE(I, J, K), aux2, T(I, J, K), QLCN(I, J, K), QICN(I, J, K), \ - CLCN(I, J, K), NHET_IMM(I, J, K), CNV_NUMLIQ_SC, CNV_NUMICE_SC) - end do - end do - end do - - DNDCNV = CNV_NDROP*PTR3D*iMASS - DNICNV = CNV_NICE*PTR3D*iMASS + DO J = 1, JM + Do K = 1, LM + + aux1 = ZL0(I, J, K)/1000. + aux2 = 3.2e-4*exp(0.0391*T(I, J, K)) !correction for dispersion. DErived from Heymsphield 2002 + aux3 = (0.3667*aux1*aux1 - 12.014*aux1 + 113.86)*1.e-6*ICESZCNV_SC !estimated effective radius from VanDiedenHover 2016 + + !CFX(I, J, K) = 2.21e3*aux3*aux3*aux3/aux2 + CFX(I, J, K) = aux3*aux3*aux3 + + + ! call make_cnv_ice_drop_number(CNV_NDROP(I, J, K), CNV_NICE(I, J, K), NHET_IMM(I, J, K), \ + ! aux3, ZL0(I, J, K), aux2, T(I, J, K), CNV_FICE(I, J, K), CNV_GSC, CNV_BSC) + + end do + end do + end do + + DNDCNV = 0. + DNICNV = 0. + + !deep convection + call MAPL_GetPointer(EXPORT, PTR3D, 'DQLDT_DC' , RC=STATUS); VERIFY_(STATUS) + if (associated(PTR3D)) DNDCNV = DNDCNV + AIRDEN*PTR3D*QNcnvfac/(DROPSZCNV*DROPSZCNV*DROPSZCNV) + + + call MAPL_GetPointer(EXPORT, PTR3D, 'DQIDT_DC' , RC=STATUS); VERIFY_(STATUS) + if (associated(PTR3D)) DNICNV = DNICNV + AIRDEN*PTR3D*QNcnvfac/CFX + + !shallow convection + call MAPL_GetPointer(EXPORT, PTR3D, 'DQLDT_SC' , RC=STATUS); VERIFY_(STATUS) + if (associated(PTR3D)) DNDCNV = DNDCNV + AIRDEN*PTR3D*QNcnvfac/(DROPSZCNV*DROPSZCNV*DROPSZCNV) + + call MAPL_GetPointer(EXPORT, PTR3D, 'DQIDT_SC' , RC=STATUS); VERIFY_(STATUS) + if (associated(PTR3D)) DNICNV = DNICNV + AIRDEN*PTR3D*QNcnvfac/CFX + !update Number concentrations - NCPL = NCPL + DNDCNV*DT_MOIST - NCPI = NCPI + DNICNV*DT_MOIST + NCPL = NCPL + DNDCNV*DT_MOIST + NCPI = NCPI + DNICNV*DT_MOIST + + !=====write out diagnostic CNV number concentrations + + ! CNV_MFD includes Deep+Shallow mass flux + call MAPL_GetPointer(EXPORT, CNV_MFD, 'CNV_MFD', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, CNV_NICE, 'CNV_NICE', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, CNV_NDROP, 'CNV_NDROP', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, CNV_FICE, 'CNV_FICE', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + + + CNV_NDROP = 0. + CNV_NICE = 0. + CNV_FICE = 0. + if (associated(CNV_MFD)) then + where (CNV_MFD .gt. 0.) + CNV_NDROP = DNDCNV*MASS/CNV_MFD + CNV_NICE = DNICNV*MASS/CNV_MFD + CNV_FICE = min(1.0, DNICNV/(DNICNV + DNDCNV + 1.e-12)) + end where + + + !CNV_FICE = ice_fraction( T, CNV_FRC, SRF_TYPE ) + + ! + + ! DO I= 1, IM + ! DO J = 1, JM + ! kbmin = max(min(NINT(KPBL_SC(I,J)), LM-1), NINT(0.8*LM)) + ! aux2= ZL0(I, J, kbmin ) !assume cldbase as PBLheight + ! aux3 = CDNC_NUC(I, J, kbmin) + !aux3 = NWFA(I, J, LM-1) + ! Do K = 1, LM + ! call make_cnv_ice_drop_number(CNV_NDROP(I, J, K), CNV_NICE(I, J, K), NHET_IMM(I, J, K), \ + ! aux3, ZL0(I, J, K), aux2, T(I, J, K), CNV_FICE(I, J, K), CNV_GSC, CNV_BSC) + + ! end do + ! end do + ! end do + + + !print *, 'DNDCNV', DNDCNV + !#print *, 'DNICNV', DNICNV + !#rint *, 'CNV_MFD', CNV_MFD + + + end if + + ! NACTL = 50.0e6 + ! NACTI = 1.e6 + !========================================================================================================== !===================================Cloud Macrophysics ==================================================== !========================================================================================================== - ! Export and/or scratch Variable - call MAPL_GetPointer(EXPORT, RAD_CF, 'FCLD', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, RAD_QV, 'QV' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, RAD_QL, 'QL' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, RAD_QI, 'QI' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, RAD_QR, 'QR' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, RAD_QS, 'QS' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, RAD_QG, 'QG' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, CLDREFFL, 'RL' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, CLDREFFI, 'RI' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + ! Exports required below call MAPL_GetPointer(EXPORT, EVAPC, 'EVAPC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, SUBLC, 'SUBLC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) @@ -1455,27 +1337,34 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) if (associated(PTR3D)) then QSNOW = QSNOW + PTR3D*DT_MOIST endif - - + !=========== evap/subl/pdf call MAPL_TimerOn(MAPL,"----hystpdf") - + call MAPL_GetPointer(EXPORT, RHCRIT, 'RHCRIT', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + + RHCRIT = 1.0 + - do L=1,LM + do I=1,IM do J=1,JM - do I=1,IM + do L=1,LM DLPDF_X(I, J, L)= QLLS(I, J, L) +QLCN(I, J, L) DIPDF_X(I, J, L)= QILS(I, J, L) +QICN(I, J, L) call pdf_alpha(PLmb(I, J, L),PLmb(I, J, LM), ALPHA, FRLAND(I, J), & - MINRHCRIT, TURNRHCRIT, EIS(I, J), 0) !0 uses old slingo formulation + MINRHCRIT, TURNRHCRIT, TURNRHCRIT_UP, EIS(I, J), 0) !0 uses old Slingo formulation - !include area scaling and limit RHcrit to > 70% - ALPHA = min( 0.30, ALPHA*SQRT(SQRT(max(AREA(I,J), 0.0)/1.e10)) ) - ALPH3D(I, J, L) = ALPHA + !include area scaling and limit RHcrit to > 60% + + IF (USE_AREA > 0.) then + ALPHA = min( 0.40, ALPHA*SQRT(SQRT(max(AREA(I,J), 0.0)/1.e10)) ) + end if + RHCRIT(I, J, L) = 1.0 - ALPHA + + call hystpdf( & DT_MOIST , & ALPHA , & @@ -1535,19 +1424,18 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) end do ! JM loop end do ! LM loop - call MAPL_GetPointer(EXPORT, RHCRIT3D, 'RHCRIT', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - if (associated(RHCRIT3D)) RHCRIT3D = 1.0-ALPH3D - + call MAPL_GetPointer(EXPORT, PTR3D, 'DIPDF' , ALLOC=.TRUE., __RC__) PTR3D= DIPDF_X call MAPL_GetPointer(EXPORT, PTR3D, 'DLPDF' , ALLOC=.TRUE., __RC__) PTR3D= DLPDF_X call MAPL_TimerOff(MAPL,"----hystpdf") - - do L=1,LM - do J=1,JM - do I=1,IM + + !IF (.FALSE.) then + do I=1,IM + do J=1,JM + do L=1,LM ! evaporation for CN/LS @@ -1555,7 +1443,7 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) call EVAP3 ( & DT_MOIST , & CCW_EVAP_EFF , & - RHCRIT3D(I, J, L) , & + RHCRIT(I, J, L) , & PLmb(I,J,L) , & T(I,J,L) , & Q(I,J,L) , & @@ -1572,7 +1460,7 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) call SUBL3 ( & DT_MOIST , & CCI_EVAP_EFF , & - RHCRIT3D(I, J, L) , & + RHCRIT(I, J, L) , & PLmb(I,J,L) , & T(I,J,L) , & Q(I,J,L) , & @@ -1583,29 +1471,14 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) NCPI(I,J,L) , & QST3(I,J,L) ) SUBLC(I,J,L) = ( Q(I,J,L) - SUBLC(I,J,L) ) / DT_MOIST - ! cleanup clouds - call FIX_UP_CLOUDS( Q(I,J,L), T(I,J,L), QLLS(I,J,L), QILS(I,J,L), CLLS(I,J,L), QLCN(I,J,L), QICN(I,J,L), CLCN(I,J,L) ) - RHX(I,J,L) = Q(I,J,L)/GEOS_QSAT( T(I,J,L), PLmb(I,J,L) ) end do ! IM loop end do ! JM loop end do ! LM loop + !end if - ! Clean up any negative specific humidity before the microphysics scheme - !----------------------------------------- - !make sure QI , NI stay within T limits - call meltfrz_inst2M ( & - IM,JM,LM , & - T , & - QLLS , & - QLCN , & - QILS , & - QICN , & - NCPL , & - NCPI ) - - call fix_up_clouds_2M( & + call fix_up_clouds_2M( & Q, & T, & QLLS,& @@ -1621,20 +1494,11 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) QGRAUPEL, & NRAIN, & NSNOW, & - NGRAUPEL) - - ! need to clean up small negative values. MG does can't handle them - call FILLQ2ZERO( Q, MASS, TMP2D) - call FILLQ2ZERO( QGRAUPEL, MASS, TMP2D) - call FILLQ2ZERO( QRAIN, MASS, TMP2D) - call FILLQ2ZERO( QSNOW, MASS, TMP2D) - call FILLQ2ZERO( QLLS, MASS, TMP2D) - call FILLQ2ZERO( QLCN, MASS, TMP2D) - call FILLQ2ZERO( QILS, MASS, TMP2D) - call FILLQ2ZERO( QICN, MASS, TMP2D) - - + NGRAUPEL, & + MASS, & + TMP2D) + ! Update macrophysics tendencies DUDT_macro=( U - DUDT_macro)/DT_MOIST DVDT_macro=( V - DVDT_macro)/DT_MOIST @@ -1654,7 +1518,6 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) !========================================================================================================= - !================================================================================================================== !===============================================Two-moment stratiform cloud microphysics ========================== !================================================================================================================== @@ -1682,33 +1545,30 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) DUDT_micro = U DVDT_micro = V DTDT_micro = T + + + CFLIQ=0.0 + CFICE=0.0 + INC_NUC = INC_NUC*CLLS !nucleation only happens in the supersaturated portion of the cell + !Zero-out 3D Precipitation Fluxes PFL_LS = 0.0 PFL_AN = 0.0 PFI_LS = 0.0 PFI_AN = 0.0 - - FQA = 0.0 - QCNTOT = QLCN+QICN - QL_TOT = QLCN+QLLS - QI_TOT = QICN+QILS - QTOT = QL_TOT+QI_TOT - - where (QTOT .gt. 0.0) - FQA= QCNTOT/QTOT - end where - - CFLIQ=0.0 - CFICE=0.0 - - RAD_CF = CLLS+CLCN - where (RAD_CF .gt. 1.0) - RAD_CF = 1.0 - end where - - WHERE (QTOT .gt. 0.0) - CFLIQ=RAD_CF*QL_TOT/QTOT - CFICE=RAD_CF*QI_TOT/QTOT - END WHERE + ! Cloud + RAD_CF = max(MIN(CLCN+CLLS,1.0), 0.) + ! Liquid + RAD_QL = QLCN+QLLS + ! Ice + RAD_QI = QICN+QILS + ! VAPOR + RAD_QV = Q + ! RAIN + RAD_QR = QRAIN + ! SNOW + RAD_QS = QSNOW + ! GRAUPEL + RAD_QG = QGRAUPEL rhdfdar8 = 1.e-8_r8 rhu00r8 = 0.95_r8 @@ -1729,7 +1589,6 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) TH1 = T/PK !initialize MG variables - nimmr8 = 0.0_r8 cldfr8 = 0.0_r8 prectr8 = 0.0_r8 precir8 = 0.0_r8 @@ -1786,93 +1645,84 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) nprc1or8 =0.0_r8 rndstr8 = 2.0e-7 naconr8 = 0. - lflxr8 = 0.0_r8 iflxr8 = 0.0_r8 rflxr8 = 0.0_r8 sflxr8 = 0.0_r8 gflxr8 = 0.0_r8 - frzcntr8 =0.0_r8 qrtendr8 = 0.0_r8 nrtendr8 = 0.0_r8 qstendr8 = 0.0_r8 nstendr8 = 0.0_r8 - qgtendr8 = 0.0_r8 ngtendr8 = 0.0_r8 !Tuning factors accre_enhanr8= ACC_ENH accre_enhan_icer8= ACC_ENH_ICE - QCVAR_EXP = 2.0 autscx = 1.0 - disp_liu = LIU_MU ui_scale = UISCALE - urscale = UR_SCALE - ts_autice = TS_AUTO_ICE - if (MTIME .le. 0.0) then - mtimesc = DT_MOIST - else - mtimesc=MTIME - end if - + ur_scale = URSCALE + ts_autice = DT_MOIST + mtimesc = DT_MOIST + if (TS_AUTO_ICE .gt. 0.) ts_autice= TS_AUTO_ICE + if (MTIME .gt. 0.0) mtimesc=MTIME + + IF (QCVAR_CST .gt. 0.) then + QCVAR = QCVAR_CST + else + IF (USE_AREA < 1) AREA = 1.e10 + call estimate_qcvar(QCVAR, IM, JM, LM, PLmb, T, GZLO, Q, QST3, AREA) + end if + + + + do I=1,IM do J=1,JM - do I=1,IM - - kbmin =1 - npccninr8 = 0.0 - naair8 = 0.0 + kbmin =1 rndstr8 = 2.0e-7 naconr8 = 0. - cldfr8(1,1:LM) = RAD_CF(I,J,1:LM) !Assume minimum overlap - liqcldfr8(1,1:LM) = CFLIQ(I,J,1:LM) - icecldfr8(1,1:LM) = CFICE(I,J,1:LM) - cldor8 = cldfr8 ter8(1,1:LM) = T(I,J,1:LM) qvr8(1,1:LM) = Q(I,J,1:LM) - - qcr8(1,1:LM) = QL_TOT(I,J,1:LM) - qir8(1,1:LM) = QI_TOT(I,J,1:LM) + qcr8(1,1:LM) = QLLS(I,J,1:LM) + QLCN(I,J,1:LM) + qir8(1,1:LM) = QILS(I,J,1:LM) + QICN(I,J,1:LM) ncr8(1,1:LM) = MAX( NCPL(I,J,1:LM), 0.0) nir8(1,1:LM) = MAX( NCPI(I,J,1:LM), 0.0) + + liqcldfr8 = cldfr8!*(qcr8/(qir8 + qcr8 + 1.e-12)) + icecldfr8 = cldfr8! max(cldfr8- liqcldfr8, 0.) + ! Nucleation tendencies naair8(1,1:LM) = max(( INC_NUC(I, J, 1:LM)*cldfr8(1,1:LM) - nir8(1,1:LM))/DT_MOIST, 0.0) npccninr8(1,1:LM) = max((CDNC_NUC(I, J, 1:LM)*cldfr8(1,1:LM) - ncr8(1,1:LM))/DT_MOIST, 0.0) - where ((naair8 .gt. 1.0e3)) ! add cloud fraction if nucleation is happening 2018 - icecldfr8 = max(0.05, icecldfr8) - end where + !where ((naair8 .gt. 1.0e3)) ! add cloud fraction if nucleation is happening 2018 + ! icecldfr8 = max(0.05, icecldfr8) + !end where where (cldfr8(1,:) .ge. 0.001) - nimmr8(1,1:LM) = MIN(DNHET_IMM(I, J, 1:LM), ncr8(1,1:LM)/cldfr8(1,1:LM)/DT_MOIST) !tendency + frzimmr8 (1,1:LM) = MIN(DNHET_IMM(I, J, 1:LM), ncr8(1,1:LM)/cldfr8(1,1:LM)/DT_MOIST) !tendency elsewhere - nimmr8(1,1:LM) = 0.0 + frzimmr8 (1,1:LM) = 0.0 end where - nhet_depr8(1,1:LM) = NHET_DEP(I, J, 1:LM)/DT_MOIST !becomes a tendency (could be done a bit better) nbincontactdust = 1 DO K=kbmin, LM - AeroAux = AeroProps(I, J, K) - ! Get dust properties for contact ice nucleation - call getINsubset(1, AeroAux, AeroAux_b) - naux = AeroAux_b%nmods - if (nbincontactdust .lt. naux) then - nbincontactdust = naux - end if - naconr8(1, K, 1:naux) = AeroAux_b%num(1:naux) - rndstr8( 1, K, 1:naux)=AeroAux_b%dpg(1:naux)/2.0 - + call getINsubset(1, AeroProps(I, J, K), AeroAux) + nbincontactdust = AeroAux%nmods + naconr8(1, K, 1:nbincontactdust) = AeroAux%num(1:nbincontactdust) + rndstr8( 1, K, 1:nbincontactdust)=AeroAux%dpg(1:nbincontactdust)/2.0 ! Get black carbon properties for contact ice nucleation - call getINsubset(2, AeroAux, AeroAux_b) - nsootr8 (1, K) = sum(AeroAux_b%num) ! - naux = AeroAux_b%nmods - rnsootr8 (1, K) = sum(AeroAux_b%dpg(1:naux))/naux + call getINsubset(2, AeroProps(I, J, K), AeroAux) + nsootr8 (1, K) = sum(AeroAux%num) ! + naux = AeroAux%nmods + rnsootr8 (1, K) = sum(AeroAux%dpg(1:naux))/naux END DO pdelr8(1,1:LM) = PLE(I,J,1:LM) - PLE(I,J,0:LM-1) @@ -1882,61 +1732,26 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) zmr8(1,1:LM) = ZL0(I,J,1:LM) kkvhr8(1,1:LM+1) = KH(I,J,0:LM) ficer8 = qir8 /( qcr8+qir8 + 1.e-10 ) - - - - if (AUTSC .gt. 0.0) then - autscx = AUTSC + + if (AUT_SCALE .gt. 0.0) then + autscx = AUT_SCALE else - autscx = min(max(0., (300.0 - T(I,J,LM))/ABS(AUTSC)), 1.0) + autscx = min(max(0., (300.0 - T(I,J,LM))/ABS(AUT_SCALE)), 1.0) autscx = 1.0 - 0.995*autscx end if - - - !!!!================Estimate qcvar following Xie and Zhang, JGR, 2015 - HMOIST_950 = 0.0 - HSMOIST_500 = 0.0 - IF (PLmb(I, J, LM) .le. 500.0) then - qcvarr8 = 2.0 - ELSEIF (PLmb(I, J, LM) .lt. 950.0) then - DO K=LM, 1, -1 - if (PLmb(I,J,K) .lt. 500.0) exit - HSMOIST_500 = MAPL_CP*T(I, J, K) + GZLO(I, J, K) + QST3(I, J, K)*MAPL_ALHL - END DO - HMOIST_950 = MAPL_CP*T(I, J, LM) + GZLO(I, J, LM) + Q(I, J, LM)*MAPL_ALHL - SINST = (HMOIST_950 - HSMOIST_500)/(PLmb(I,J,LM)*100.0- 50000.0) - ELSE - DO K=LM, 1, -1 - if (PLmb(I,J,K) .lt. 500.0) exit - HSMOIST_500 = MAPL_CP*T(I, J, K) + GZLO(I, J, K) + QST3(I, J, K)*MAPL_ALHL - END DO - DO K=LM, 1, -1 - if (PLmb(I,J,K) .lt. 950.0) exit - HMOIST_950 = MAPL_CP*T(I, J, K) + GZLO(I, J, K) + Q(I, J, K)*MAPL_ALHL - END DO - SINST = (HMOIST_950 - HSMOIST_500)/45000.0 - ENDIF - - xscale = (9000.0/real(imsize))**(-0.666) - qcvarr8 = 0.67 -0.38*SINST + 4.96*xscale - 8.32*SINST*xscale - qcvarr8 = min(max(qcvarr8, 0.5), 50.0) - if (associated(QCVAR_EXP)) QCVAR_EXP(I, J) = real(qcvarr8) - relvarr8 = qcvarr8 + relvarr8 = QCVAR(I, J) - ! for MG23 (initial values) - frzimmr8 = nimmr8 - frzcntr8 = nimmr8*0.0 - frzdepr8 = nhet_depr8 - qrr8(1,1:LM) = QRAIN(I, J,1:LM) - qsr8(1,1:LM) = QSNOW(I, J,1:LM) - qgr8(1,1:LM) = QGRAUPEL(I, J,1:LM) - nrr8(1,1:LM) = NRAIN(I, J,1:LM) - nsr8(1,1:LM) = NSNOW(I, J,1:LM) - ngr8(1,1:LM) = NGRAUPEL(I, J,1:LM) - qsatfacr8 = 1.0 - SCICE_tmp(1,1:LM) = SC_ICE(I, J, 1:LM) - FQA_tmp(1,1:LM) = FQA(I, J, 1:LM) + ! for MG23 (initial values) + frzcntr8 = frzimmr8 *0.0 + frzdepr8(1,1:LM) = NHET_DEP(I, J, 1:LM)/DT_MOIST + qrr8(1,1:LM) = QRAIN(I, J,1:LM) + qsr8(1,1:LM) = QSNOW(I, J,1:LM) + qgr8(1,1:LM) = QGRAUPEL(I, J,1:LM) + nrr8(1,1:LM) = NRAIN(I, J,1:LM) + nsr8(1,1:LM) = NSNOW(I, J,1:LM) + ngr8(1,1:LM) = NGRAUPEL(I, J,1:LM) + qsatfacr8 = 1.0 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -1945,7 +1760,7 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) if (MGVERSION .lt. 2) then - call set_qcvar (qcvarr8) + call set_qcvar (QCVAR(I, J)) call mmicro_pcond ( & ncolmicro, ncolmicro, dt_r8, DT_MICRO, ter8, ttendr8, & @@ -1976,7 +1791,7 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) praior8,qiresor8, & mnuccror8,pracsor8, & meltsdtr8,frzrdtr8, ncalr8, ncair8, mnuccdor8, nnucctor8, & - nsoutr8, nroutr8, nimmr8, disp_liu, & + nsoutr8, nroutr8, frzimmr8, disp_liu, & nsootr8, rnsootr8, ui_scale, autscx, mtimesc, & nnuccdor8, nnucccor8, nsacwior8, nsubior8, nprcior8, & npraior8, npccnor8, npsacwsor8, nsubcor8, npraor8, nprc1or8, nbincontactdust, & @@ -1984,9 +1799,8 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) else ! MG2/3 - call micro_mg_tend_interface ( DT_MICRO, INT(PDFSHAPE), ALPH3D(I, J, 1:LM), SCICE_tmp, FQA_tmp, & + call micro_mg_tend_interface ( DT_MICRO, & ncolmicro, LM, dt_r8, & - CNV_FRC(I,J), SRF_TYPE(I,J), & ter8, qvr8, & qcr8, qir8, & ncr8, nir8, & @@ -2055,36 +1869,36 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) nsootr8, rnsootr8, & ! soot for contact IN npccnor8, npsacwsor8,npraor8,nsubcor8, nprc1or8, & ! Number tendencies for liquid npraior8, nnucctor8, nnucccor8, nnuccdor8, nsubior8, nprcior8, nsacwior8, & ! Number tendencies for ice - ts_autice, ui_scale, autscx , disp_liu, nbincontactdust, urscale) + ts_autice, ui_scale, autscx , disp_liu, nbincontactdust, ur_scale) end if + IF (MGVERSION > 1) then - QRAIN(I,J,1:LM) = max(QRAIN(I,J,1:LM) + REAL(qrtendr8(1, 1:LM)*DT_R8), 0.0) ! grid average - QSNOW(I,J,1:LM) = max(QSNOW(I,J,1:LM) + REAL(qstendr8(1, 1:LM)*DT_R8), 0.0) ! grid average + RAD_QR(I,J,1:LM) = max(RAD_QR(I,J,1:LM) + REAL(qrtendr8(1, 1:LM)*DT_R8), 0.0) ! grid average + RAD_QS(I,J,1:LM) = max(RAD_QS(I,J,1:LM) + REAL(qstendr8(1, 1:LM)*DT_R8), 0.0) ! grid average NRAIN(I,J,1:LM) = max(NRAIN(I,J,1:LM) + REAL(nrtendr8(1, 1:LM)*DT_R8), 0.0) NSNOW(I,J,1:LM) = max(NSNOW(I,J,1:LM) + REAL(nstendr8(1, 1:LM)*DT_R8), 0.0) CLDREFFR(I,J,1:LM) = REAL(reff_rainr8(1,1:LM)) CLDREFFS(I,J,1:LM) = REAL(reff_snowr8(1,1:LM))/scale_ri CLDREFFG(I,J,1:LM) = REAL(reff_graur8(1,1:LM))/scale_ri - QGRAUPEL(I,J,1:LM) = max(QGRAUPEL(I,J,1:LM) + REAL(qgtendr8(1, 1:LM)*DT_R8), 0.0) ! grid average + RAD_QG(I,J,1:LM) = max(RAD_QG(I,J,1:LM) + REAL(qgtendr8(1, 1:LM)*DT_R8), 0.0) ! grid average NGRAUPEL(I,J,1:LM) = max(NGRAUPEL(I,J,1:LM) + REAL(ngtendr8(1, 1:LM)*DT_R8), 0.0) else - QRAIN(I,J,1:LM) = max(REAL(qrout2r8(1,1:LM)), 0.0) ! grid average - QSNOW(I,J,1:LM) = max(REAL(qsout2r8(1,1:LM)), 0.0) + RAD_QR(I,J,1:LM) = max(REAL(qrout2r8(1,1:LM)), 0.0) ! grid average + RAD_QS(I,J,1:LM) = max(REAL(qsout2r8(1,1:LM)), 0.0) NRAIN(I,J,1:LM) = max(REAL(nrout2r8(1,1:LM)), 0.0) NSNOW(I,J,1:LM) = max(REAL(nsout2r8(1,1:LM)), 0.0) CLDREFFR(I,J,1:LM) = REAL(drout2r8(1,1:LM))/2.0 CLDREFFS(I,J,1:LM) = REAL(dsout2r8(1,1:LM))/2.0/scale_ri - QGRAUPEL(I,J,1:LM) = 0.0 ! grid average + RAD_QG(I,J,1:LM) = 0.0 ! grid average NGRAUPEL(I,J,1:LM) = 0.0 ! grid average end if - - if (.TRUE.) then + PFL_LS(I, J, 1:LM) = rflxr8(1,2:LM+1) !+ lflxr8(1,1:LM) PFI_LS(I, J, 1:LM) = sflxr8(1,2:LM+1) + gflxr8(1,2:LM+1) !+ iflxr8(1,1:LM) @@ -2092,24 +1906,22 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) !Update state after microphysisc LS_PRCP(I,J) = max(1000.*REAL((prectr8(1)-precir8(1))), 0.0) LS_SNR(I,J) = max(1000.*REAL(precir8(1)), 0.0) - QL_TOT(I,J,1:LM) = max(QL_TOT(I,J,1:LM) + REAL(qctendr8(1,1:LM)) * DT_R8, 0.0) - QI_TOT(I,J,1:LM) = max(QI_TOT(I,J,1:LM) + REAL(qitendr8(1,1:LM)) * DT_R8, 0.0) - Q(I,J,1:LM) = MAX(Q(I,J,1:LM) + REAL(qvlatr8(1,1:LM)) * DT_R8, 0.0) + RAD_QL(I,J,1:LM) = max(RAD_QL(I,J,1:LM) + REAL(qctendr8(1,1:LM)) * DT_R8, 0.0) + RAD_QI(I,J,1:LM) = max(RAD_QI(I,J,1:LM) + REAL(qitendr8(1,1:LM)) * DT_R8, 0.0) + RAD_QV(I,J,1:LM) = MAX(RAD_QV(I,J,1:LM) + REAL(qvlatr8(1,1:LM)) * DT_R8, 0.0) T(I,J,1:LM) = T(I,J,1:LM) + REAL(tlatr8(1,1:LM)) * DT_R8 / (MAPL_CP) NCPL(I,J,1:LM) = MAX(NCPL(I,J,1:LM) + REAL(nctendr8(1,1:LM)) * DT_R8, 0.0) NCPI(I,J,1:LM) = MAX(NCPI(I,J,1:LM) + REAL(nitendr8(1,1:LM)) * DT_R8, 0.0) - - CLDREFFL(I,J,1:LM) = max(REAL(effcr8(1,1:LM))*1.0e-6, 1.0e-6) CLDREFFI(I,J,1:LM) = max(REAL(effir8(1,1:LM))*1.0e-6, 1.0e-6)/scale_ri !scale to match the Dge definition of Fu 1996 - end if IF (MGVERSION < 2) then !normalize precip flux if (PFL_LS(I, J, LM) .gt. 1.0e-7) PFL_LS(I, J, 1:LM) = PFL_LS(I, J, 1:LM)*LS_PRCP(I,J)/PFL_LS(I, J, LM) if (PFI_LS(I, J, LM) .gt. 1.0e-7) PFI_LS(I, J, 1:LM) = PFI_LS(I, J, 1:LM)*LS_SNR(I,J)/PFI_LS(I, J, LM) end if + ! diagnostics from the microphysics******************** @@ -2151,32 +1963,29 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) DNCSUBL (I,J,1:LM) = REAL(nsubior8(1,1:LM)) !ice number tendency from sublimation DNCAUTICE (I,J,1:LM) = REAL(nprcior8(1,1:LM)) !ice number tendency from autoconversion DNCHMSPLIT(I,J,1:LM) = REAL(nsacwior8(1,1:LM)) !ice number tendency from H-M process - - DNDCCN(I,J,1:LM) = REAL(npccnor8(1,1:LM)) !droplet number tendency from CCN activation - DNDACRLS(I,J,1:LM) = REAL(npsacwsor8(1,1:LM) )!droplet number tendency from accretion by snow - DNDACRLR(I,J,1:LM) = REAL(npraor8(1,1:LM)) !droplet number tendency from accretion by rain - DNDEVAPC(I,J,1:LM) = REAL(nsubcor8(1,1:LM)) !droplet number tendency from evaporation - DNDAUTLIQ(I,J,1:LM) = REAL(nprc1or8(1,1:LM)) !droplet number tendency from autoconversion - + + enddo !I enddo !J !============================================Finish 2-moment micro implementation=========================== !update water tracers -2022 QLCN=QL_TOT*FQA - QLLS=QL_TOT-QLCN - QICN=QI_TOT*FQA - QILS=QI_TOT-QICN - QTOT= QICN+QILS+QLCN+QLLS - + + + ! Redistribute CN/LS CF/QL/QI + call REDISTRIBUTE_CLOUDS(RAD_CF, RAD_QL, RAD_QI, CLCN, CLLS, QLCN, QLLS, QICN, QILS, RAD_QV, T) !============ Put cloud fraction back in contact with the PDF and create new condensate if neccesary (Barahona et al., GMD, 2014)============ - do K= 1, LM - do J=1,JM - do I=1,IM + RHCmicro = RHCRIT + Q = RAD_QV + do I=1,IM + do J=1,JM + do K= 1, LM + + call update_cld( & DT_MOIST , & - ALPH3D(I, J, K) , & + 1.- RHCRIT(I, J, K) , & PDFSHAPE , & CNV_FRC(I, J) , & SRF_TYPE(I, J) , & @@ -2193,75 +2002,144 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) NCPI(I, J, K) , & NCPL(I, J, K) , & RHCmicro(I, J, K)) - - end do - end do - end do - - ! Make sure ice and liquid stay within T limits - - call meltfrz_inst2M ( & - IM,JM,LM , & - T , & - QLLS , & - QLCN , & - QILS , & - QICN , & - NCPL , & - NCPI ) - - RAD_CF = CLLS+CLCN - where (RAD_CF .gt. 1.0) - RAD_CF = 1.0 - end where + ! second call to hystpdf + + if (SECOND_HYSTPDF) then + + call hystpdf( & + DT_MOIST , & + 1. - RHCRIT(I, J, K) , & + PDFSHAPE , & + CNV_FRC(I,J) , & + SRF_TYPE(I,J) , & + PLmb(I,J,K) , & + ZL0(I,J,K) , & + Q(I,J,K) , & + QLLS(I,J,K) , & + QLCN(I,J,K) , & + QILS(I,J,K) , & + QICN(I,J,K) , & + T(I,J,K) , & + CLLS(I,J,K) , & + CLCN(I,J,K) , & + NCPL(I,J,K) , & + NCPI(I,J,K) , & + WSL(I,J,K) , & + WQT(I,J,K) , & + SL2(I,J,K) , & + QT2(I,J,K) , & + SLQT(I,J,K) , & + W3(I,J,K) , & + W2(I,J,K) , & + QT3(I,J,K) , & + SL3(I,J,K) , & + PDF_A(I,J,K) , & + PDFITERS(I,J,K), & +#ifdef PDFDIAG + PDF_SIGW1(I,J,K), & + PDF_SIGW2(I,J,K), & + PDF_W1(I,J,K), & + PDF_W2(I,J,K), & + PDF_SIGTH1(I,J,K), & + PDF_SIGTH2(I,J,K), & + PDF_TH1(I,J,K), & + PDF_TH2(I,J,K), & + PDF_SIGQT1(I,J,K), & + PDF_SIGQT2(I,J,K), & + PDF_QT1(I,J,K), & + PDF_QT2(I,J,K), & + PDF_RQTTH(I,J,K), & + PDF_RWTH(I,J,K), & + PDF_RWQT(I,J,K), & +#endif + WTHV2(I,J,K) , & + WQL(I,J,K) , & + .false. , & + .true., & + SC_ICE(I, J, K)) + + end if + + end do ! IM loop + end do ! JM loop + end do ! LM loop + + + RAD_CF =max(min(CLLS+CLCN, 1.0), 0.) + + + + !=============================================End Stratiform cloud processes========================================== !====================================================================================================================== - !Calculate CFICE and CFLIQ - - CFLIQ=0.0 - CFICE=0.0 - QTOT= QICN+QILS+QLCN+QLLS - QL_TOT = QLCN+QLLS - QI_TOT = QICN+QILS - - WHERE (QTOT .gt. 1.0e-12) - CFLIQ=RAD_CF*QL_TOT/QTOT - CFICE=RAD_CF*QI_TOT/QTOT - END WHERE - - where (CFLIQ < 0.0) - CFLIQ = 0.0 - end where - where (CFLIQ > 1.0) - CFLIQ = 1.0 - end where - - where (CFICE < 0.0) - CFICE = 0.0 - end where - where (CFICE > 1.0) - CFICE = 1.0 - end where - + !====================================================================================================================== !===========================Clean stuff and send it to radiation ====================================================== !====================================================================================================================== - where (QI_TOT .le. 0.0) + ! + ! cleanup suspended precipitation condensates + call FIX_NEGATIVE_PRECIP(RAD_QR, RAD_QS, RAD_QG) + !Fill vapor/rain/snow/graupel state + QRAIN = RAD_QR + QSNOW = RAD_QS + QGRAUPEL = RAD_QG + ! Fill GEOS precip diagnostics + PRCP_RAIN = LS_PRCP + PRCP_SNOW = LS_SNR + ICE = 0.0 !PRCP_ICE + PRCP_GRAUPEL + FRZR = 0.0 + ! Redistribute precipitation fluxes for chemistry + TMP3D = QLCN/(QLCN + QLLS+1.E-14) + PFL_AN(:,:,1:LM) = PFL_LS(:,:,1:LM) * TMP3D + PFL_LS = PFL_LS - PFL_AN + TMP3D = QICN/(QICN + QILS + 1.E-14) + PFI_AN(:,:,1:LM) = PFI_LS(:,:,1:LM) * TMP3D + PFI_LS = PFI_LS - PFI_AN + + !clean negatives, make sure NCPI and NCPL stay within limits + call fix_up_clouds_2M( & + Q, & + T, & + QLLS,& + QILS,& + CLLS, & + QLCN,& + QICN,& + CLCN, & + NCPL, & + NCPI, & + QRAIN, & + QSNOW, & + QGRAUPEL, & + NRAIN, & + NSNOW, & + NGRAUPEL, & + MASS, & + TMP2D) + + where (RAD_QI .le. 0.0) CFICE =0.0 NCPI=0.0 + CLDREFFI = MAPL_UNDEF + elsewhere + CFICE = RAD_CF*(RAD_QI/(RAD_QL + RAD_QI + 1.e-12)) end where - where (QL_TOT .le. 0.0) + where (RAD_QL .le. 0.0) CFLIQ =0.0 NCPL =0.0 + CLDREFFL = MAPL_UNDEF + elsewhere + CFLIQ = RAD_CF*(RAD_QL/(RAD_QL + RAD_QI + 1.e-12)) end where + WHERE (RAD_CF > 1e-4) - RAD_QL = (QLLS+QLCN)/RAD_CF - RAD_QI = (QILS+QICN)/RAD_CF + RAD_QL = min((QLLS+QLCN)/RAD_CF, 1.0e-3) + RAD_QI = min((QILS+QICN)/RAD_CF, 1.0e-3) ! RAD_QR = QRAIN/RAD_CF RAD_QS = QSNOW/RAD_CF RAD_QG = QGRAUPEL/RAD_CF @@ -2275,51 +2153,27 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) !Everything in-cloud for radiation============== - where (RAD_QV < 0.0) - RAD_QV = 0.0 - endwhere - where (RAD_QL > 0.001) - RAD_QL = 0.001 - endwhere - where (RAD_QI > 0.001) - RAD_QI = 0.001 - endwhere - where (RAD_QR > 0.01) - RAD_QR = 0.01 - endwhere - where (RAD_QS > 0.01) - RAD_QS = 0.01 - endwhere - where (RAD_QG > 0.01) - RAD_QG = 0.01 - endwhere - where (QILS+QICN .le. 0.0) - CLDREFFI = 36.0e-6 - end where - where (QLLS+QLCN .le. 0.0) - CLDREFFL = 14.0e-6 - end where - - - ! Fill GEOS precip diagnostics - PRCP_RAIN = LS_PRCP - PRCP_SNOW = LS_SNR - ICE = PRCP_ICE + PRCP_GRAUPEL - FRZR = 0.0 - ! Redistribute precipitation fluxes for chemistry - TMP3D = QLCN/(QLCN + QLLS+1.E-14) - - PFL_AN(:,:,1:LM) = PFL_LS(:,:,1:LM) * TMP3D - PFL_LS = PFL_LS - PFL_AN - TMP3D = QICN/(QICN + QILS + 1.E-14) - PFI_AN(:,:,1:LM) = PFI_LS(:,:,1:LM) * TMP3D - PFI_LS = PFI_LS - PFI_AN - ! cleanup suspended precipitation condensates - call FIX_NEGATIVE_PRECIP(RAD_QR, RAD_QS, RAD_QG) + call FILLQ2ZERO(RAD_QV, MASS, TMP2D) + call FILLQ2ZERO(RAD_QL, MASS, TMP2D) + call FILLQ2ZERO(RAD_QI, MASS, TMP2D) + call FILLQ2ZERO(RAD_QR, MASS, TMP2D) + call FILLQ2ZERO(RAD_QS, MASS, TMP2D) + call FILLQ2ZERO(RAD_QG, MASS, TMP2D) + call FILLQ2ZERO(RAD_CF, MASS, TMP2D) + RAD_QL = MIN( RAD_QL , 0.001 ) ! Still a ridiculously large + RAD_QI = MIN( RAD_QI , 0.001 ) ! value. + RAD_QR = MIN( RAD_QR , 0.01 ) ! value. + RAD_QS = MIN( RAD_QS , 0.01 ) ! value. + RAD_QG = MIN( RAD_QG , 0.01 ) ! value. + ! !Set rain water for radiation to 0 if preciprad flag is off (set to 0) + if(PRECIPRAD .lt. 1.) then + RAD_QR = 0. + RAD_QS = 0. + RAD_QG = 0. + endif !================================================================================= - ! Units conversion for diagnostics - + ! Fill up diagnostics !to m-3 NCPL_VOL=NCPL*AIRDEN ! @@ -2357,25 +2211,20 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) END WHERE TH1 = T / PK - - ! !Set rain water for radiation to 0 if preciprad flag is off (set to 0) - !if(CLDPARAMS%PRECIPRAD .eq. 0.) then - ! RAD_QR = 0. - ! RAD_QS = 0. - ! RAD_QG = 0. - ! endif - - ! CLDREFFL = MAX(MIN_RL, CLDREFFL) !DONIF Limits according to MG2008-I - ! CLDREFFL = MIN(MAX_RL, CLDREFFL) - ! CLDREFFI = MAX(MIN_RI, CLDREFFI) - ! CLDREFFI = MIN(MAX_RI, CLDREFFI) !maximum number for the correlation and modis sim + CLDREFFL = MAX(MIN_RL, CLDREFFL) !DONIF Limits according to MG2008-I + CLDREFFL = MIN(MAX_RL, CLDREFFL) + CLDREFFI = MAX(MIN_RI, CLDREFFI) + CLDREFFI = MIN(MAX_RI, CLDREFFI) !maximum number for the correlation and modis sim - ! CLDREFFR = MAX(MIN_RL, CLDREFFR) - ! CLDREFFR = MIN(MAX_RL, CLDREFFR) - ! CLDREFFS = MAX(MIN_RI*2., CLDREFFS) - ! CLDREFFS = MIN(MAX_RI*2., CLDREFFS) !maximum number for the correlation and modis sim - ! CLDREFFG = MAX(MIN_RI*2., CLDREFFG) - ! CLDREFFG = MIN(MAX_RI*2., CLDREFFG) !maximum number for the correlation and modis sim + CLDREFFR = MAX(MIN_RL, CLDREFFR) + CLDREFFR = MIN(MAX_RL, CLDREFFR) + CLDREFFS = MAX(MIN_RI*2., CLDREFFS) + CLDREFFS = MIN(MAX_RI*2., CLDREFFS) !maximum number for the correlation and modis sim + CLDREFFG = MAX(MIN_RI*2., CLDREFFG) + CLDREFFG = MIN(MAX_RI*2., CLDREFFG) !maximum number for the correlation and modis sim + + CLDREFFL = CLDREFFL*FAC_RL !required to tune TOA rad + CLDREFFI = CLDREFFI*FAC_RI !required to tune TOA rad !=========================== @@ -2391,8 +2240,7 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) DO I=1, IM DO J= 1 , JM - cfaux(1,1:LM) = CFLIQ(I, J, 1:LM) - call find_cldtop(1, LM, cfaux, kbmin) + call find_cldtop(1, LM, CFLIQ(I, J, 1:LM), kbmin) if (kbmin .ge. LM-1) then CLDREFFL_TOP_X (I, J) = 8.0e-6 @@ -2403,13 +2251,13 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) NCPL_TOP_X (I, J) = NCPL_VOL(I, J, kbmin) end if - call find_cldbase(1, LM, cfaux, kbmin) + call find_cldbase(1, LM, CFLIQ(I, J, 1:LM), kbmin) if (kbmin .gt. 10) then - NCPL_CLDBASEX (I, J) = NCPL_VOL(I, J, kbmin)/max(cfaux(1, kbmin), 0.01) + NCPL_CLDBASEX (I, J) = NCPL_VOL(I, J, kbmin)/max(CFLIQ(I, J, kbmin), 0.01) end if - cfaux(1,1:LM) =CFICE(I, J, 1:LM) - call find_cldtop(1, LM, cfaux, kbmin) + + call find_cldtop(1, LM, CFICE(I, J, 1:LM), kbmin) if (kbmin .ge. LM-1) then CLDREFFI_TOP_X (I, J)=20.0E-6 @@ -2426,7 +2274,7 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) if (associated(PTR2D)) PTR2D = CLDREFFI_TOP_X call MAPL_GetPointer(EXPORT, PTR2D, 'CLDREFFL_TOP', RC=STATUS); VERIFY_(STATUS) - if (associated(PTR2D)) PTR2D = CLDREFFI_TOP_X + if (associated(PTR2D)) PTR2D = CLDREFFL_TOP_X call MAPL_GetPointer(EXPORT, PTR2D, 'NCPL_CLDBASE', RC=STATUS); VERIFY_(STATUS) if (associated(PTR2D)) PTR2D= NCPL_CLDBASEX @@ -2436,15 +2284,10 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) call MAPL_GetPointer(EXPORT, PTR2D, 'NCPI_TOP', RC=STATUS); VERIFY_(STATUS) if (associated(PTR2D)) PTR2D= NCPI_TOP_X - - - ! Clean up Relative Humidity where RH > 110% - !--------------------------------------------- - ! moved to Moist GridComp - if (associated(CCNCOLUMN)) CCNCOLUMN = SUM( CCN1*MASS/AIRDEN , 3) + if (associated(CCNCOLUMN)) CCNCOLUMN = SUM( CCN1*MASS/AIRDEN , 3) if (associated(NDCOLUMN )) NDCOLUMN = SUM(NCPL_VOL*MASS/AIRDEN , 3) if (associated(NCCOLUMN )) NCCOLUMN = SUM(NCPI_VOL*MASS/AIRDEN , 3) @@ -2456,8 +2299,8 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) if (associated(DQRDT_micro)) DQRDT_micro = ( QRAIN - DQRDT_micro) / DT_MOIST if (associated(DQSDT_micro)) DQSDT_micro = ( QSNOW - DQSDT_micro) / DT_MOIST if (associated(DQGDT_micro)) DQGDT_micro = ( QGRAUPEL - DQGDT_micro) / DT_MOIST - if (associated( DUDT_micro)) DUDT_micro = ( U0 - DUDT_micro) / DT_MOIST - if (associated( DVDT_micro)) DVDT_micro = ( V0 - DVDT_micro) / DT_MOIST + if (associated( DUDT_micro)) DUDT_micro = ( U - DUDT_micro) / DT_MOIST + if (associated( DVDT_micro)) DVDT_micro = ( V - DVDT_micro) / DT_MOIST if (associated( DTDT_micro)) DTDT_micro = ( T - DTDT_micro) / DT_MOIST @@ -2503,15 +2346,6 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) endif endif - call MAPL_GetPointer(EXPORT, PTR3D, 'QRTOT', RC=STATUS); VERIFY_(STATUS) - if (associated(PTR3D)) PTR3D = QRAIN - - call MAPL_GetPointer(EXPORT, PTR3D, 'QSTOT', RC=STATUS); VERIFY_(STATUS) - if (associated(PTR3D)) PTR3D = QSNOW - - call MAPL_GetPointer(EXPORT, PTR3D, 'QGTOT', RC=STATUS); VERIFY_(STATUS) - if (associated(PTR3D)) PTR3D = QGRAUPEL - call MAPL_TimerOff(MAPL,"--MGB2_2M",__RC__) end subroutine MGB2_2M_Run diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 index c43eb1e79..09171b586 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 @@ -4778,7 +4778,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - SHORT_NAME='QCVAR_EXP', & + SHORT_NAME='QCVAR', & LONG_NAME ='inverse relative variance of cloud water', & UNITS = '1', & DIMS = MAPL_DimsHorzOnly, & @@ -5222,7 +5222,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) real, allocatable, dimension(:,:) :: TMP2D ! Internals real, pointer, dimension(:,:,:) :: Q, QLLS, QLCN, CLLS, CLCN, QILS, QICN - real, pointer, dimension(:,:,:) :: NACTL, NACTI + real, pointer, dimension(:,:,:) :: NACTL, NACTI, NCPL, NCPI ! Imports real, pointer, dimension(:,:,:) :: ZLE, PLE, T, U, V, W real, pointer, dimension(:,:) :: FRLAND, FRLANDICE, FRACI, SNOMAS @@ -5295,6 +5295,8 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetPointer(INTERNAL, QICN, 'QICN' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(INTERNAL, NACTL, 'NACTL' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(INTERNAL, NACTI, 'NACTI' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, NCPL, 'NACTL' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL, NCPI, 'NACTI' , RC=STATUS); VERIFY_(STATUS) ! Import State call MAPL_GetPointer(IMPORT, PLE, 'PLE' , RC=STATUS); VERIFY_(STATUS) @@ -5319,12 +5321,17 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetPointer(IMPORT, FRACI, 'FRACI' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, SNOMAS, 'SNOMAS' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, SRF_TYPE, 'SRF_TYPE' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - SRF_TYPE = 0.0 ! Ocean - where (FRLAND > 0.1) - SRF_TYPE = 1.0 ! Land - end where - where ( (SNOMAS > 0.1) .OR. (FRLANDICE > 0.5) .OR. (FRACI > 0.5) ) - SRF_TYPE = 2.0 ! Ice/Snow + + where ( (FRLANDICE > 0.5) .OR. (FRACI > 0.5) ) + SRF_TYPE = 3.0 ! Ice + elsewhere ( SNOMAS > 0.1 .AND. SNOMAS /= MAPL_UNDEF ) + ! NOTE: SNOMAS has UNDEFs so we need to make sure we don't + ! allow that to infect this comparison + SRF_TYPE = 2.0 ! Snow + elsewhere (FRLAND > 0.1) + SRF_TYPE = 1.0 ! Land + elsewhere + SRF_TYPE = 0.0 ! Ocean end where ! Allocatables @@ -5559,7 +5566,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) end where endif - if (.FALSE.) then + if (adjustl(CLDMICR_OPTION)=="MGB2_2M") then QST3 = GEOS_QsatLQU (T, PLmb*100.0, DQ=DQST3) !clean up only with respect to liquid water else DQST3 = GEOS_DQSAT (T, PLmb, QSAT=QST3) ! this qsat function expects hPa... diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 index 9a0c3ac92..9ec85d331 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 @@ -37,7 +37,7 @@ module GEOSmoist_Process_Library real, parameter :: aT_ICE_ALL = 252.16 real, parameter :: aT_ICE_MAX = 268.16 real, parameter :: aICEFRPWR = 2.0 - ! Over snow/ice SRF_TYPE = 2 + ! Over snow SRF_TYPE = 2 and over ice SRF_TYPE = 3 real, parameter :: iT_ICE_ALL = 236.16 real, parameter :: iT_ICE_MAX = 261.16 real, parameter :: iICEFRPWR = 6.0 @@ -403,8 +403,8 @@ function ICE_FRACTION_SC (TEMP,CNV_FRACTION,SRF_TYPE) RESULT(ICEFRCT) ICEFRCT_C = MAX(ICEFRCT_C,0.00) ICEFRCT_C = ICEFRCT_C**aICEFRPWR ! Sigmoidal functions like figure 6b/6c of Hu et al 2010, doi:10.1029/2009JD012384 - if (SRF_TYPE == 2.0) then - ! Over snow/ice + if (SRF_TYPE >= 2.0) then + ! Over snow (SRF_TYPE == 2.0) and ice (SRF_TYPE == 3.0) if (ICE_RADII_PARAM == 1) then ! Jason formula ICEFRCT_M = 0.00 @@ -1112,18 +1112,21 @@ subroutine fix_up_clouds_2M( & QG, & NR, & NS, & - NG) + NG, & + MASS, & + TMP2D) real, intent(inout), dimension(:,:,:) :: TE,QV,QLC,CF,QLA,AF,QIC,QIA, QR, QS, QG real, intent(inout), dimension(:,:,:) :: NI, NL, NS, NR, NG + real, dimension(:,:,:), intent(in) :: MASS + real, dimension(:,:), intent( out) :: TMP2D + integer :: IM, JM, LM real, parameter :: qmin = 1.0e-12 real, parameter :: cfmin = 1.0e-4 real, parameter :: nmin = 100.0 - - ! Fix if Anvil cloud fraction too small where (AF < cfmin) QV = QV + QLA + QIA @@ -1184,9 +1187,22 @@ subroutine fix_up_clouds_2M( & QLC = 0. QIC = 0. end where - - - + + IM = SIZE( QV, 1 ) + JM = SIZE( QV, 2 ) + LM = SIZE( QV, 3 ) + + + !make sure QI , NI stay within T limits + call meltfrz_inst2M ( IM, JM, LM, & + TE , & + QLC , & + QLA , & + QIC , & + QIA , & + NL , & + NI ) + !make sure no negative number concentrations are passed !and that N goes to minimum defaults in the microphysics when mass is too small @@ -1205,6 +1221,18 @@ subroutine fix_up_clouds_2M( & where (QS .le. qmin) NS = 0. where (QG .le. qmin) NG = 0. + + ! need to clean up small negative values. MG does can't handle them + call FILLQ2ZERO( QV, MASS, TMP2D) + call FILLQ2ZERO( QG, MASS, TMP2D) + call FILLQ2ZERO( QR, MASS, TMP2D) + call FILLQ2ZERO( QS, MASS, TMP2D) + call FILLQ2ZERO( QLC, MASS, TMP2D) + call FILLQ2ZERO( QLA, MASS, TMP2D) + call FILLQ2ZERO( QIC, MASS, TMP2D) + call FILLQ2ZERO( QIA, MASS, TMP2D) + call FILLQ2ZERO( CF, MASS, TMP2D) + call FILLQ2ZERO( AF, MASS, TMP2D) end subroutine fix_up_clouds_2M @@ -1680,7 +1708,7 @@ subroutine partition_dblgss( fQi, & ! IN ! corrtest2 = max(-1.0,min(1.0,wqtntrgs/(sqrtw2*sqrtqt))) corrtest2 = max(-1.0,min(1.0,0.5*wqwsec/(sqrtw2*sqrtqt))) - + qw1_1 = - corrtest2 / w1_2 ! A.7 qw1_2 = - corrtest2 / w1_1 ! A.8 @@ -2276,17 +2304,17 @@ end subroutine hystpdf !==========Estimate RHcrit======================== !============================== - subroutine pdf_alpha(PP,P_LM, ALPHA, FRLAND, MINRHCRIT, TURNRHCRIT, EIS, RHC_OPTION) + subroutine pdf_alpha(PP,P_LM, ALPHA, FRLAND, MINRHCRIT, TURNRHCRIT, TURNRHCRIT_UPPER, EIS, RHC_OPTION) real, intent(in) :: PP, P_LM !mbar real, intent(out) :: ALPHA real, intent(in) :: FRLAND - real, intent(in) :: MINRHCRIT, TURNRHCRIT, EIS + real, intent(in) :: MINRHCRIT, TURNRHCRIT, EIS, TURNRHCRIT_UPPER integer, intent(in) :: RHC_OPTION !0-Slingo(1985), 1-QUAAS (2012) real :: dw_land = 0.20 !< base value for subgrid deviation / variability over land real :: dw_ocean = 0.10 !< base value for ocean real :: sloperhcrit =20. - real :: TURNRHCRIT_UPPER = 300. + !real :: TURNRHCRIT_UPPER = 300. real :: aux1, aux2, maxalpha IF (RHC_OPTION .lt. 1) then @@ -2304,9 +2332,13 @@ subroutine pdf_alpha(PP,P_LM, ALPHA, FRLAND, MINRHCRIT, TURNRHCRIT, EIS, RHC_OPT aux1 = 1.0/(1.0+exp(aux1)) !this function reproduces the old Sligo function. end if - !aux2= 1.0/(1.0+exp(aux2)) !this function would reverse the profile P< TURNRHCRIT_UPPER - aux2=1.0 - ALPHA = min(maxalpha*aux1*aux2, 0.3) + if (TURNRHCRIT_UPPER .gt. 0.0) then + aux2= 1.0/(1.0+exp(aux2)) !this function reverses the profile P< TURNRHCRIT_UPPER + else + aux2=1.0 + end if + + ALPHA = min(maxalpha*aux1*aux2, 0.4) ELSE ! based on Quass 2012 https://doi.org/10.1029/2012JD017495 @@ -3313,9 +3345,12 @@ subroutine update_cld( & QSLIQ = GEOS_QsatLQU( TE, PL*100.0 , DQ=DQx ) QSICE = GEOS_QsatICE( TE, PL*100.0 , DQ=DQX ) - if ((QC+QA) .gt. 1.0e-13) then - QSx=((QCl+QAl)*QSLIQ + QSICE*(QCi+QAi))/(QC+QA) - else + + IF (QCl + QAl .gt. 0.) then + QSx = QSLIQ + ELSEIF (QCi + QAi.gt. 0.) then + QSx = QSICE + ELSE DQSx = GEOS_DQSAT( TE, PL, QSAT=QSx ) end if @@ -3352,8 +3387,10 @@ subroutine update_cld( & if (QSx .gt. tiny(1.0)) then RHCmicro = SCICE - 0.5*DELQ/Qsx else - RHCmicro = 0.0 + RHCmicro = 1.0-ALPHA end if + + RHCmicro = max(min(RHCmicro, 0.99), 0.6) CFALL = max(CFo, 0.0) CFALL = min(CFo, 1.0) @@ -3367,8 +3404,7 @@ end subroutine update_cld - subroutine meltfrz_inst2M ( & - IM,JM,LM , & + subroutine meltfrz_inst2M ( IM, JM, LM, & TE , & QCL , & QAL , & @@ -3377,8 +3413,8 @@ subroutine meltfrz_inst2M ( & NL , & NI ) - integer, intent(in) :: IM,JM,LM real , intent(inout), dimension(:,:,:) :: TE,QCL,QCI, QAL, QAI, NI, NL + integer, intent(in) :: IM, JM, LM real , dimension(im,jm,lm) :: dQil, DQmax, QLTOT, QITOT, dNil, FQA real :: T_ICE_ALL = 240. @@ -3388,8 +3424,7 @@ subroutine meltfrz_inst2M ( & QLTOT=QCL + QAL FQA = 0.0 - - where (QITOT+QLTOT .gt. 0.0) + where (QITOT+QLTOT .gt. tiny(0.0)) FQA= (QAI+QAL)/(QITOT+QLTOT) end where @@ -3408,7 +3443,7 @@ subroutine meltfrz_inst2M ( & dNil = NL end where - where ((dQil .gt. DQmax) .and. (dQil .gt. 0.0)) + where ((dQil .gt. DQmax) .and. (dQil .gt. tiny(0.0))) dNil = NL*DQmax/dQil end where @@ -3432,7 +3467,7 @@ subroutine meltfrz_inst2M ( & where ((dQil .le. DQmax) .and. (dQil .gt. 0.0)) dNil = NI end where - where ((dQil .gt. DQmax) .and. (dQil .gt. 0.0)) + where ((dQil .gt. DQmax) .and. (dQil .gt. tiny(0.0))) dNil = NI*DQmax/dQil end where dQil = max( 0., dQil ) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/WSUB_ExtData.yaml b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/WSUB_ExtData.yaml index 90112086f..f7a53106c 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/WSUB_ExtData.yaml +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/WSUB_ExtData.yaml @@ -1,7 +1,7 @@ Collections: WSUB_SWclim_2005%m2.nc4: template: /discover/nobackup/dbarahon/DEV/SWclim/L72/SWclim_2005%m2.nc4 - valid_range: "2005-01-01/2005-12-31" + valid_range: "2005-01-01/2005-12-01" Samplings: WSUB_sample_0: diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_cloud.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_cloud.F90 index 5bd7fe7f4..c2e80ce69 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_cloud.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_cloud.F90 @@ -16,23 +16,37 @@ MODULE aer_cloud public :: aerosol_activate public :: AerConversion public :: AerProps + !public :: AerPropsNew public :: getINsubset public :: init_Aer public :: aer_cloud_init public :: vertical_vel_variance public :: gammp public :: make_cnv_ice_drop_number + public :: nsmx_par + public :: estimate_qcvar + + integer, parameter :: nsmx_par = 20 !maximum number of modes allowed + integer, parameter :: npgauss = 10 - integer, parameter :: & - nsmx_par = 20, npgauss=10 !maximum number of - !nsmx_par !maximum number of modes allowed - - - type :: AerProps - sequence - real, dimension(nsmx_par) :: num !Num conc m-3 - real, dimension(nsmx_par) :: dpg !dry Geometric size, m - real, dimension(nsmx_par) :: sig !logarithm (base e) of the dry geometric disp + !type :: AerPropsNew + !sequence + !real, dimension(:,:,:), pointer :: num !Num conc m-3 + !real, dimension(:,:,:), pointer :: dpg !dry Geometric size, m + !real, dimension(:,:,:), pointer :: sig !logarithm (base e) of the dry geometric disp + !real, dimension(:,:,:), pointer :: den !dry density , Kg m-3 + !real, dimension(:,:,:), pointer :: kap !Hygroscopicity parameter + !real, dimension(:,:,:), pointer :: fdust! mass fraction of dust + !real, dimension(:,:,:), pointer :: fsoot ! mass fraction of soot + !real, dimension(:,:,:), pointer :: forg ! mass fraction of organics + !integer :: nmods ! total number of modes (nmods240) !************************************************************ @@ -4042,82 +4003,237 @@ real function H_1_smooth(X, X_1, X_2, Hlo, Hhi) -subroutine make_cnv_ice_drop_number(Nd, Ni, Nad, z, zcb, T, qlcn, qicn, cf, nimm, rl_scale, ri_scale) +subroutine make_cnv_ice_drop_number(Nd, Ni, Nimm, Nad, z, zcb, T, cnvfice, g_scale, b_scale) ! estimate convective Nd and Ni profiles. !Written by Donifan Barahona - real, intent (in) :: Nad, z, zcb !Nadiabatic, Z, Zcb - real, intent (in) :: T, qlcn, qicn, cf, rl_scale, ri_scale, nimm + real, intent (in) :: T, Nimm, cnvfice + real, intent (in) :: g_scale, b_scale, Nad, z, zcb real, intent (out) :: Nd, Ni - real :: r3ad, Z12, alf, bet, gam_ad, LWCad - real :: rei3, mui, zkm + real :: r3ad, dZ12, alf, bet, gam_ad, LWCad + real :: rei3, mui, zkm, Tx real, parameter :: max_rel3 = 22.e-6**3. - real, parameter :: min_rel3 = 4.e-6**3. + real, parameter :: min_rel3 = 10.e-6**3. real, parameter :: max_rei3 = 300.e-6**3. - real, parameter :: min_rei3 = 5.e-6**3. - real, parameter :: ice_den = 900. - - - !========liquid droplet concentration - !Loosely based on Khain et al. JAS (2019) https://doi.org/10.1175/JAS-D-18-0046.1 - - alf=2.8915E-08*(T*T) - 2.1328E-05*T + 4.2523E-03 - bet=exp(3.49996E-04*T*T - 2.27938E-01*T + 4.20901E+01) - gam_ad = alf/bet - LWcad = max((z-zcb), 0.0)*gam_ad !adiabatic LWC + real, parameter :: min_rei3 = 20.e-6**3. + real, parameter :: ice_den = 600. + real, parameter :: wat_den = 1000. + real, parameter :: beta = 0.38 + real, parameter :: gamma = 1.0e-4 + - r3ad = max(min(3.63e-4*LWCad*rl_scale/Nad, max_rel3), min_rel3) !adiabatic droplet size^3 - Z12 = 4.8e-12*Nad/gam_ad ! - - if (z-zcb .lt. z12) then - Nd = Nad - else - Nd = min(Nad, 3.6e-4*qlcn/r3ad) - end if + + !make it simple + + Nd = b_scale*Nad*exp(-z/g_scale) + + if (.false.) then + ! print *, dqlcn + !========liquid droplet concentration + !Based on Khain et al. JAS (2019) https://doi.org/10.1175/JAS-D-18-0046.1 + Nd = 0. + Ni = 0. + Tx = max(273.15, T) + alf=2.8915E-08*(Tx*Tx) - 2.1328E-05*Tx + 4.2523E-03 + bet=exp(3.49996E-04*Tx*Tx - 2.27938E-01*Tx + 4.20901E+01) + gam_ad = alf/bet + LWcad = max((z-zcb), 0.0)*gam_ad !adiabatic LWC + + !r3ad = max(min(3.63e-4*LWCad*(rl_scale**3.)/Nad, max_rel3), min_rel3) !adiabatic droplet size^3 + + dZ12 = 4.8e-12*Nad/gam_ad ! + + if (z-zcb .lt. dz12) then + Nd = b_scale*Nad + else + Nd = max(b_scale*Nad*(1-g_scale*((z-zcb) - dz12)), 1.0e3) + end if + + end if - !=========ice crystal concentration + Ni = Nd*cnvfice + if (T .lt. 238.) Ni = Nd + Nd = Nd - Ni + !Ni = max(Ni, Nimm) + + + !=========ice crystal concentration -- different approach - zkm = z/1000. !to km - rei3 = 0.3667*zkm*zkm - 12.014*zkm + 113.86 !based on van Diedenhoven et al. 2016, GRL, Fig 2 - rei3 = min(max((1.e-6*rei3*ri_scale)**3., min_rei3), max_rei3) - mui = MUI_HEMP(T) - !assume gamma distribution - Ni = (mui+3.)*(mui+3.)/(mui+2.)/(mui+1.) - Ni = 2.15*Ni*qicn/ice_den/rei3/max(cf, 0.001) - Ni = max(Ni, nimm) + !if (dqicn .gt. 0.) then + ! zkm = min(z/1000., 18.) !to km + ! rei3 = 0.3667*zkm*zkm - 12.014*zkm + 113.86 !based on van Diedenhoven et al. 2016, GRL, Fig 2 + ! rei3 = min(max((1.e-6*rei3*ri_scale)**3., min_rei3), max_rei3) + ! mui = MUI_HEMP(T) + !assume gamma distribution + ! dNi = (mui+3.)*(mui+3.)/(mui+2.)/(mui+1.) + ! dNi = 4.18*dNi*dqicn/ice_den/rei3 + !end if end subroutine make_cnv_ice_drop_number + +!!!!================Estimate qcvar following Xie and Zhang, JGR, 2015 + +subroutine estimate_qcvar(QCVAR, IM, JM, LM, PLmb, T, GZLO, Q, QST3, AREA) + + real, dimension (:, :), intent(out) :: QCVAR + real , dimension (:, :, :), intent(in) :: PLmb, T, GZLO, Q, QST3 + real, dimension (:, :), intent(in) :: AREA + integer, intent(in) :: IM, JM, LM + integer :: I, J, K + real :: HMOIST_950, HSMOIST_500, SINST, QCV, xscale + + DO I = 1, IM + DO J = 1, JM + HMOIST_950 = 0.0 + HSMOIST_500 = 0.0 + + xscale = min(max(SQRT(AREA(I, J))/1.0e10, 1.0), 200.) + xscale = xscale**(-0.6666) + + IF (PLmb(I, J, LM) .le. 500.0) then + QCVAR = 2.0 + ELSEIF (PLmb(I, J, LM) .lt. 950.0) then + DO K=LM, 1, -1 + if (PLmb(I,J,K) .lt. 500.0) exit + HSMOIST_500 = MAPL_CP*T(I, J, K) + GZLO(I, J, K) + QST3(I, J, K)*MAPL_ALHL + END DO + HMOIST_950 = MAPL_CP*T(I, J, LM) + GZLO(I, J, LM) + Q(I, J, LM)*MAPL_ALHL + SINST = (HMOIST_950 - HSMOIST_500)/(PLmb(I,J,LM)*100.0- 50000.0) + ELSE + DO K=LM, 1, -1 + if (PLmb(I,J,K) .lt. 500.0) exit + HSMOIST_500 = MAPL_CP*T(I, J, K) + GZLO(I, J, K) + QST3(I, J, K)*MAPL_ALHL + END DO + DO K=LM, 1, -1 + if (PLmb(I,J,K) .lt. 950.0) exit + HMOIST_950 = MAPL_CP*T(I, J, K) + GZLO(I, J, K) + Q(I, J, K)*MAPL_ALHL + END DO + SINST = (HMOIST_950 - HSMOIST_500)/45000.0 + ENDIF + + QCV = 0.67 -0.38*SINST + 4.96*xscale - 8.32*SINST*xscale + QCVAR(I, J) = min(max(QCV, 0.5), 10.0) + end do + end do + +end subroutine estimate_qcvar + + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !DONIF Calculate the Brunt_Vaisala frequency !cccccccccccccccccccccDONIFccccccccccccccccccccccccccccccccccccccccccccccccc - !Returns the value of the dispersion parameter according to Heymsfield et al 2002, Table3. - !T is in K - ! Written by Donifan Barahona donifan.barahona@nasa.gov - !********************************** - FUNCTION MUI_HEMP(T) + !Returns the value of the dispersion parameter according to Heymsfield et al 2002, Table3. + !T is in K + ! Written by Donifan Barahona donifan.barahona@nasa.gov + !********************************** + FUNCTION MUI_HEMP(T) + real :: MUI_HEMP + REAL, intent(in) :: T + REAL :: TC, mui, lambdai + TC=T-273.15 - real :: MUI_HEMP - REAL, intent(in) :: T - REAL :: TC, mui, lambdai - TC=T-273.15 + TC=MIN(MAX(TC, -70.0), -15.0) - TC=MIN(MAX(TC, -70.0), -15.0) + if (TC .gt. -27.0) then + lambdai=6.8*exp(-0.096*TC) + else + lambdai=24.8*exp(-0.049*TC) + end if + + mui=(0.13*(lambdai**0.64))-2. + MUI_HEMP=max(mui, 1.5_r8) - if (TC .gt. -27.0) then - lambdai=6.8*exp(-0.096*TC) - else - lambdai=24.8*exp(-0.049*TC) - end if - mui=(0.13*(lambdai**0.64))-2. - MUI_HEMP=max(mui, 1.5_r8) + END FUNCTION MUI_HEMP + + !=============================================================================== + subroutine gw_prof (pcols, pver, ncol, t, pm, pi, rhoi, ni, ti, nm) + !----------------------------------------------------------------------- + ! Compute profiles of background state quantities for the multiple + ! gravity wave drag parameterization. + ! + ! The parameterization is assumed to operate only where water vapor + ! concentrations are negligible in determining the density. + !----------------------------------------------------------------------- + !------------------------------Arguments-------------------------------- + integer, intent(in) :: ncol ! number of atmospheric columns + integer, intent(in) :: pcols ! number of atmospheric columns + integer, intent(in) :: pver ! number of vertical layers + + !real, intent(in) :: u(pcols,pver) ! midpoint zonal wind + !real, intent(in) :: v(pcols,pver) ! midpoint meridional wind + real, intent(in) :: t(pcols,pver) ! midpoint temperatures + real, intent(in) :: pm(pcols,pver) ! midpoint pressures + real, intent(in) :: pi(pcols,0:pver) ! interface pressures + + real, intent(out) :: rhoi(pcols,0:pver) ! interface density + real, intent(out) :: ni(pcols,0:pver) ! interface Brunt-Vaisalla frequency + real, intent(out) :: ti(pcols,0:pver) ! interface temperature + real, intent(out) :: nm(pcols,pver) ! midpoint Brunt-Vaisalla frequency + + !---------------------------Local storage------------------------------- + integer :: ix,kx ! loop indexes + + real :: dtdp + real :: n2, cpair, r,g ! Brunt-Vaisalla frequency squared + real :: n2min = 1.e-8 + r=MAPL_RGAS + cpair=MAPL_CP + g=MAPL_GRAV + + !----------------------------------------------------------------------------- + ! Determine the interface densities and Brunt-Vaisala frequencies. + !----------------------------------------------------------------------------- + + ! The top interface values are calculated assuming an isothermal atmosphere + ! above the top level. + kx = 0 + do ix = 1, ncol + ti(ix,kx) = t(ix,kx+1) + rhoi(ix,kx) = pi(ix,kx) / (r*ti(ix,kx)) + ni(ix,kx) = sqrt (g*g / (cpair*ti(ix,kx))) + end do + + ! Interior points use centered differences + do kx = 1, pver-1 + do ix = 1, ncol + ti(ix,kx) = 0.5 * (t(ix,kx) + t(ix,kx+1)) + rhoi(ix,kx) = pi(ix,kx) / (r*ti(ix,kx)) + dtdp = (t(ix,kx+1)-t(ix,kx)) / (pm(ix,kx+1)-pm(ix,kx)) + n2 = g*g/ti(ix,kx) * (1./cpair - rhoi(ix,kx)*dtdp) + ni(ix,kx) = sqrt (max (n2min, n2)) + end do + end do + + ! Bottom interface uses bottom level temperature, density; next interface + ! B-V frequency. + kx = pver + do ix = 1, ncol + ti(ix,kx) = t(ix,kx) + rhoi(ix,kx) = pi(ix,kx) / (r*ti(ix,kx)) + ni(ix,kx) = ni(ix,kx-1) + end do + + !----------------------------------------------------------------------------- + ! Determine the midpoint Brunt-Vaisala frequencies. + !----------------------------------------------------------------------------- + do kx=1,pver + do ix=1,ncol + nm(ix,kx) = 0.5 * (ni(ix,kx-1) + ni(ix,kx)) + end do + end do - END FUNCTION MUI_HEMP + return + end subroutine gw_prof +!************************************************ ! END ICE PARAMETERIZATION DONIF ! diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/cldmacro.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/cldmacro.F90 deleted file mode 100644 index 20165adf6..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/cldmacro.F90 +++ /dev/null @@ -1,2054 +0,0 @@ -! $Id$ -! $Name$ - -module cldmacro - - - !This module handles large scale condesation and cloud fraction, convective precipitation, and makes - ! preliminary calculations for the two-moment cloud microphysics. - !======================================================================= - - use GEOS_UtilsMod, only:QSAT=>GEOS_Qsat, DQSAT=>GEOS_DQsat, & - QSATLQ=>GEOS_QsatLQU, QSATIC=>GEOS_QsatICE - - use MAPL_ConstantsMod, only: MAPL_TICE , MAPL_CP , & - MAPL_GRAV , MAPL_ALHS , & - MAPL_ALHL , MAPL_ALHF , & - MAPL_RGAS , MAPL_H2OMW, & - MAPL_AIRMW, MAPL_RVAP , & - MAPL_PI , MAPL_R8 , & - MAPL_R4 - - use MAPL_BaseMod, only: MAPL_UNDEF - - use GEOSmoist_Process_Library - - implicit none - - private - - public macro_cloud - public update_cld - public meltfrz_inst - public CLDPARAMS, CLDPARAM_TYPE - - type CLDPARAM_TYPE - real :: CNV_BETA - real :: RH00 - real :: C_ACC - real :: C_EV_R - real :: C_EV_S - real :: CCW_EVAP_EFF - real :: CCI_EVAP_EFF - real :: REVAP_OFF_P - real :: CNVENVFC - real :: T_ICE_ALL - real :: CNVICEPARAM - real :: CNVDDRFC - integer :: PDFSHAPE - real :: MINRHCRIT - real :: TURNRHCRIT - real :: TURNRHCRIT_UPPER - real :: SLOPERHCRIT - real :: DISP_FACTOR_ICE - real :: DISP_FACTOR_LIQ - real :: SCLM_DEEP, SCLM_SHALLOW - endtype CLDPARAM_TYPE - type (CLDPARAM_TYPE) :: CLDPARAMS - - real, parameter :: T_ICE_MAX = MAPL_TICE ! -7.0+MAPL_TICE - real, parameter :: RHO_W = 1.0e3 ! Density of liquid water in kg/m^3 - real, parameter :: MIN_CLD_FRAC = 1.0e-8 - - real, parameter :: ZVIR = MAPL_RVAP/MAPL_RGAS - 1. - real, parameter :: GORD = MAPL_GRAV/MAPL_RGAS - real, parameter :: GFAC = 1.e5/MAPL_GRAV - real, parameter :: R_AIR = 3.47e-3 !m3 Pa kg-1K-1 - - ! ICE_FRACTION constants - ! In anvil/convective clouds - real, parameter :: aT_ICE_ALL = 245.16 - real, parameter :: aT_ICE_MAX = 261.16 - real, parameter :: aICEFRPWR = 2.0 - ! Over snow/ice - real, parameter :: iT_ICE_ALL = 236.16 - real, parameter :: iT_ICE_MAX = 255.16 - real, parameter :: iICEFRPWR = 6.0 - ! Over Land - real, parameter :: lT_ICE_ALL = 239.16 - real, parameter :: lT_ICE_MAX = 261.16 - real, parameter :: lICEFRPWR = 2.0 - ! Over Oceans - real, parameter :: oT_ICE_ALL = 238.16 - real, parameter :: oT_ICE_MAX = 263.16 - real, parameter :: oICEFRPWR = 4.0 - - - ! There are two PI's in this routine: PI_0 and MAPL_PI - real, parameter :: PI_0 = 4.*atan(1.) - logical, parameter :: USE_AEROSOL_NN = .TRUE. -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -contains - - - subroutine macro_cloud( & -!!! first vars are (in) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - IRUN, LM , & - DT , & - PP_dev , & - PPE_dev , & - EXNP_dev , & - FRLAND_dev , & - CNVFRC_dev , & - SRFTYPE_dev , & - QLWDTR_dev , & - QRN_CU_dev , & - CNV_UPDFRC_dev , & - SC_QLWDTR_dev , & - SC_QIWDTR_dev , & - QRN_SC_dev , & - QSN_SC_dev , & - SC_UPDFRC_dev , & - U_dev , & - V_dev , & - TH_dev , & - Q_dev , & - QLW_LS_dev , & - QLW_AN_dev , & - QIW_LS_dev , & - QIW_AN_dev , & - ANVFRC_dev , & - CLDFRC_dev , & - PRECU_dev , & - CUARF_dev , & - SNRCU_dev , & - QST3_dev , & - DZET_dev , & - QDDF3_dev , & - RHX_dev , & - REV_AN_dev , & - RSU_AN_dev , & - ACLL_AN_dev,ACIL_AN_dev, & - PFL_AN_dev,PFI_AN_dev, & - PDFL_dev,PDFI_dev,FIXL_dev,FIXI_dev, & - DCNVL_dev, DCNVi_dev, & - ALPHT_dev, & - VFALLSN_AN_dev, & - VFALLRN_AN_dev, & - EVAPC_dev, & - SUBLC_dev, & - SCICE_dev, & - NCPL_dev, & - NCPI_dev, & - PFRZ_dev, & - DNDCNV_dev, & - DNCCNV_dev, & - RAS_DT_dev, & - QRAIN_CN, & - QSNOW_CN, & - KCBL) - - - integer, intent(in ) :: IRUN ! IM*JM - integer, intent(in ) :: LM ! LM - real, intent(in ) :: DT ! DT_MOIST - real, intent(in ), dimension(IRUN, LM) :: PP_dev ! PLO - real, intent(in ), dimension(IRUN,0:LM) :: PPE_dev ! CNV_PLE - real, intent(in ), dimension(IRUN, LM) :: EXNP_dev ! PK - real, intent(in ), dimension(IRUN ) :: FRLAND_dev ! FRLAND - real, intent(in ), dimension(IRUN ) :: CNVFRC_dev ! CNVFRC - real, intent(in ), dimension(IRUN ) :: SRFTYPE_dev - real, intent(in ), dimension(IRUN, LM) :: QLWDTR_dev ! CNV_DQLDT - real, intent(inout), dimension(IRUN, LM) :: QRN_CU_dev ! CNV_PRC3 IS THIS INTENT IN? - real, intent(inout), dimension(IRUN, LM) :: CNV_UPDFRC_dev ! CNV_UPDF - real, intent(in ), dimension(IRUN, LM) :: SC_QLWDTR_dev - real, intent(in ), dimension(IRUN, LM) :: SC_QIWDTR_dev - real, intent(inout), dimension(IRUN, LM) :: QRN_SC_dev - real, intent(inout), dimension(IRUN, LM) :: QSN_SC_dev - real, intent(inout), dimension(IRUN, LM) :: SC_UPDFRC_dev - real, intent(in ), dimension(IRUN, LM) :: U_dev ! U1 - real, intent(in ), dimension(IRUN, LM) :: V_dev ! V1 - real, intent(inout), dimension(IRUN, LM) :: TH_dev ! TH1 - real, intent(inout), dimension(IRUN, LM) :: Q_dev ! Q1 - real, intent(inout), dimension(IRUN, LM) :: QLW_LS_dev ! QLLS - real, intent(inout), dimension(IRUN, LM) :: QLW_AN_dev ! QLCN - real, intent(inout), dimension(IRUN, LM) :: QIW_LS_dev ! QILS - real, intent(inout), dimension(IRUN, LM) :: QIW_AN_dev ! QICN - real, intent(inout), dimension(IRUN, LM) :: ANVFRC_dev ! CLCN - real, intent(inout), dimension(IRUN, LM) :: CLDFRC_dev ! CLLS - real, intent( out), dimension(IRUN ) :: PRECU_dev ! CN_PRC2 - real, intent( out), dimension(IRUN ) :: CUARF_dev ! CN_ARFX - real, intent( out), dimension(IRUN ) :: SNRCU_dev ! CN_SNR - real, intent(in ), dimension(IRUN, LM) :: QST3_dev ! QST3 - real, intent(in ), dimension(IRUN, LM) :: DZET_dev ! DZET - real, intent(in ), dimension(IRUN, LM) :: QDDF3_dev ! QDDF3 - real, intent( out), dimension(IRUN, LM) :: RHX_dev ! RHX - real, intent( out), dimension(IRUN, LM) :: REV_AN_dev ! REV_CN - real, intent( out), dimension(IRUN, LM) :: RSU_AN_dev ! RSU_CN - real, intent( out), dimension(IRUN, LM) :: ACLL_AN_dev ! ACLL_CN - real, intent( out), dimension(IRUN, LM) :: ACIL_AN_dev ! ACIL_CN - real, intent( out), dimension(IRUN,0:LM) :: PFL_AN_dev ! PFL_CN - real, intent( out), dimension(IRUN,0:LM) :: PFI_AN_dev ! PFI_CN - real, intent( out), dimension(IRUN, LM) :: PDFL_dev ! DlPDF - real, intent( out), dimension(IRUN, LM) :: PDFI_dev ! DiPDF - real, intent( out), dimension(IRUN, LM) :: FIXL_dev ! DlFIX - real, intent( out), dimension(IRUN, LM) :: FIXI_dev ! DiFIX - real, intent( out), dimension(IRUN, LM) :: DCNVL_dev ! DCNVL - real, intent( out), dimension(IRUN, LM) :: DCNVi_dev ! DCNVi - real, intent( out), dimension(IRUN, LM) :: ALPHT_dev ! ALPHT - real, intent( out), dimension(IRUN, LM) :: VFALLSN_AN_dev ! VFALLSN_CN - real, intent( out), dimension(IRUN, LM) :: VFALLRN_AN_dev ! VFALLRN_CN - real, intent( out), dimension(IRUN, LM) :: EVAPC_dev ! VFALLSN_CN - real, intent( out), dimension(IRUN, LM) :: SUBLC_dev ! VFALLRN_CN - - !=====two_moment - real, intent(inout), dimension(IRUN, LM) :: SCICE_dev - real, intent(inout), dimension(IRUN, LM) :: NCPL_dev - real, intent(inout), dimension(IRUN, LM) :: NCPI_dev - real, intent(out), dimension(IRUN, LM) :: PFRZ_dev - real, intent(out), dimension(IRUN, LM) :: DNDCNV_dev - real, intent(out), dimension(IRUN, LM) :: DNCCNV_dev - real, intent(out), dimension(IRUN, LM) :: RAS_DT_dev - real, intent(out), dimension(IRUN, LM) :: QRAIN_CN - real, intent(out), dimension(IRUN, LM) :: QSNOW_CN - - - real, dimension(IRUN, LM) :: FRZ_PP_dev ! FRZ_PP - real :: TOT_UPDFRC - integer, intent(in ), dimension(IRUN ) :: KCBL ! RAS CLOUD BASE - - - ! GPU The GPUs need to know how big local arrays are during compile-time - ! as the GPUs cannot allocate memory themselves. This command resets - ! this a priori size to LM for the CPU. - - - integer :: I , K - - real :: MASS, iMASS - real :: TOTFRC - real :: QRN_CU_1D - real :: QSN_CU - real :: QRN_ALL, QSN_ALL - real :: QTMP1, QTMP2, QTMP3, QTOT - real :: TEMP - real :: RHCRIT - real :: AA3, BB3, ALPHA - real :: VFALL, VFALLRN, VFALLSN - real :: TOT_PREC_UPD - real :: AREA_UPD_PRC - real :: AREA_UPD_PRC_tolayer - real :: PRN_CU_above, PSN_CU_above - real :: EVAP_DD_CU_above, SUBL_DD_CU_above - - real :: NIX, TOTAL_WATER, QRN_XS, QSN_XS - - logical :: use_autoconv_timescale - - use_autoconv_timescale = .false. - QRN_XS = 0.0 - QSN_XS = 0.0 - - RUN_LOOP: DO I = 1, IRUN - - K_LOOP: DO K = 1, LM - - if (K == 1) then - TOT_PREC_UPD = 0. - AREA_UPD_PRC = 0. - end if - - if (K == LM ) then - !! ZERO DIAGNOSTIC OUTPUTS BEFORE SHOWERS !! - PRECU_dev(I) = 0. - SNRCU_dev(I) = 0. - CUARF_dev(I) = 0. - end if - - !Zero out/initialize precips, except QRN_CU which comes from RAS - QRN_CU_1D = 0. - QSN_CU = 0. - VFALL = 0. - - PFL_AN_dev(I,K) = 0. - PFI_AN_dev(I,K) = 0. - IF (K == 1) THEN - PFL_AN_dev(I,0) = 0. - PFI_AN_dev(I,0) = 0. - END IF - - ! Initialize other diagnostics - - RHX_dev(I,K) = MAPL_UNDEF - REV_AN_dev(I,K) = MAPL_UNDEF - RSU_AN_dev(I,K) = MAPL_UNDEF - ACLL_AN_dev(I,K) = MAPL_UNDEF - ACIL_AN_dev(I,K) = MAPL_UNDEF - PDFL_dev(I,K) = MAPL_UNDEF - PDFI_dev(I,K) = MAPL_UNDEF - FIXL_dev(I,K) = MAPL_UNDEF - FIXI_dev(I,K) = MAPL_UNDEF - DCNVL_dev(I,K) = MAPL_UNDEF - DCNVi_dev(I,K) = MAPL_UNDEF - ALPHT_dev(I,K) = MAPL_UNDEF - VFALLSN_AN_dev(I,K) = MAPL_UNDEF - VFALLRN_AN_dev(I,K) = MAPL_UNDEF - - EVAPC_dev(I,K) = 0.0 - SUBLC_dev(I,K) = 0.0 - - !====two-moment - - DNDCNV_dev(I, K) = MAPL_UNDEF - DNCCNV_dev(I, K) = MAPL_UNDEF - RAS_DT_dev(I, K) = MAPL_UNDEF - QRAIN_CN(I,K) = 0.0 - QSNOW_CN(I,K) = 0.0 - NIX= 0.0 - - ! Copy QRN_CU into a temp scalar - QRN_CU_1D = QRN_CU_dev(I,K) - - MASS = ( PPE_dev(I,K) - PPE_dev(I,K-1) )*100./MAPL_GRAV ! layer-mass (kg/m**2) - iMASS = 1.0 / MASS - TEMP = EXNP_dev(I,K) * TH_dev(I,K) - FRZ_PP_dev(I,K) = 0.00 - !PFRZ_dev(I, K) = 0.0 - -!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Condensate Source -!!!!!!!!!!!!!!!!!!!!!!!!!!! - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - - TOTAL_WATER = (QIW_AN_dev(I,K)+QLW_AN_dev(I,K) + QIW_LS_dev(I,K)+ QIW_LS_dev(I,K))*MASS +QLWDTR_dev(I,K)*DT+SC_QLWDTR_dev(I,K)*DT+SC_QIWDTR_dev(I,K)*DT - - DCNVi_dev(I,K) = QIW_AN_dev(I,K) - DCNVL_dev(I,K) = QLW_AN_dev(I,K) - DNDCNV_dev(I, K) = NCPL_dev(I, K) - DNCCNV_dev(I, K) = NCPI_dev(I, K) - - ! cnvsrc now handled in convection routines - - DCNVi_dev(I,K) = ( QIW_AN_dev(I,K) - DCNVi_dev(I,K) ) / DT - DCNVL_dev(I,K) = ( QLW_AN_dev(I,K) - DCNVL_dev(I,K) ) / DT - DNDCNV_dev(I, K) = (NCPL_dev(I, K)-DNDCNV_dev(I, K))/DT - DNCCNV_dev(I, K) = (NCPI_dev(I, K)-DNCCNV_dev(I, K))/DT - - - - -!!!!!!!!!!!!!!!!!!!!check consistency!!!!!!!!!!!!!!!!!!!!!!!!!!! - - FIXL_dev(I,K) = QLW_AN_dev(I,K) + QLW_LS_dev(I,K) - FIXI_dev(I,K) = QIW_AN_dev(I,K) + QIW_LS_dev(I,K) - - - CALL fix_up_clouds( & - Q_dev(I,K) , & - TEMP , & - QLW_LS_dev(I,K), & - QIW_LS_dev(I,K), & - CLDFRC_dev(I,K), & - QLW_AN_dev(I,K), & - QIW_AN_dev(I,K), & - ANVFRC_dev(I,K)) - - - FIXL_dev(I,K) = -( QLW_AN_dev(I,K) + QLW_LS_dev(I,K) - FIXL_dev(I,K) ) / DT - FIXI_dev(I,K) = -( QIW_AN_dev(I,K) + QIW_LS_dev(I,K) - FIXI_dev(I,K) ) / DT - - ! assume deep and shallow updraft fractions non-overlapping - TOT_UPDFRC = CNV_UPDFRC_dev(I,K) + SC_UPDFRC_dev(I,K) - TOT_UPDFRC = MAX( MIN( TOT_UPDFRC, 1.), 0.) - - call pdf_spread (& - PP_dev(I,K),ALPHA,& - ALPHT_dev(I,K), & - FRLAND_dev(I)) - - ! impose a minimum amount of variability - ALPHA = MAX( ALPHA , 1.0 - CLDPARAMS%RH00 ) - - RHCRIT = 1.0 - ALPHA - - - !=================================new condensate ==================================== -!!!!!!!!!Calculate probability of freezing to scale nucleated ice crystals !! - !================================ - - - call Pfreezing ( & - CLDPARAMS%PDFSHAPE , & - ALPHA , & - PP_dev(I,K) , & - TEMP , & - Q_dev(I,K) , & - QLW_LS_dev(I,K) , & - QLW_AN_dev(I,K) , & - QIW_LS_dev(I,K) , & - QIW_AN_dev(I,K) , & - SCICE_dev(I, K) , & - CLDFRC_dev(I,K) , & - ANVFRC_dev(I,K) , & - PFRZ_dev(I, K) ) - - - - !=============Collect convective precip============== - - - PDFL_dev(I,K) = QLW_LS_dev(I,K)+QLW_AN_dev(I,K) - PDFI_dev(I,K) = QIW_LS_dev(I,K)+QIW_AN_dev(I,K) - - call hystpdf_new( & - DT , & - ALPHA , & - CLDPARAMS%PDFSHAPE , & - CNVFRC_dev(I) , & - SRFTYPE_dev(I) , & - PP_dev(I,K) , & - Q_dev(I,K) , & - QLW_LS_dev(I,K), & - QLW_AN_dev(I,K), & - QIW_LS_dev(I,K), & - QIW_AN_dev(I,K), & - TEMP , & - CLDFRC_dev(I,K), & - ANVFRC_dev(I,K), & - NCPL_dev(I,K) , & - NCPI_dev(I,K) , & - SCICE_dev(I, K)) - - PDFL_dev(I,K) = ( QLW_LS_dev(I,K) + QLW_AN_dev(I,K) - PDFL_dev(I,K) ) / DT - PDFI_dev(I,K) = ( QIW_LS_dev(I,K) + QIW_AN_dev(I,K) - PDFI_dev(I,K) ) / DT - - - - QTMP1 = QLW_LS_dev(I,K) + QLW_AN_dev(I,K) - QTMP2 = QIW_LS_dev(I,K) + QIW_AN_dev(I,K) - - - EVAPC_dev(I,K) = QLW_LS_dev(I,K)+QLW_AN_dev(I,K) - SUBLC_dev(I,K) = QIW_LS_dev(I,K)+QIW_AN_dev(I,K) - - ! 'Anvil' partition from RAS/Parameterized not done in hystpdf - - call evap3( & - DT , & - CLDPARAMS%CCW_EVAP_EFF, & - RHCRIT , & - PP_dev(I,K) , & - TEMP , & - Q_dev(I,K) , & - QLW_AN_dev(I,K), & - QIW_AN_dev(I,K), & - ANVFRC_dev(I,K), & - NCPL_dev(I,K) , & - NCPI_dev(I,K) , & - QST3_dev(I,K) ) - - call subl3( & - DT , & - CLDPARAMS%CCI_EVAP_EFF, & - RHCRIT , & - PP_dev(I,K) , & - TEMP , & - Q_dev(I,K) , & - QLW_AN_dev(I,K), & - QIW_AN_dev(I,K), & - ANVFRC_dev(I,K), & - NCPL_dev(I,K) , & - NCPI_dev(I,K) , & - QST3_dev(I,K) ) - - EVAPC_dev(I,K) = ( EVAPC_dev(I,K) - (QLW_LS_dev(I,K)+QLW_AN_dev(I,K)) ) / DT - SUBLC_dev(I,K) = ( SUBLC_dev(I,K) - (QIW_LS_dev(I,K)+QIW_AN_dev(I,K)) ) / DT - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Add in convective rain -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - ! CU-FREEZE -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Also "freeze" out any conv. precip that needs - ! to be since this isn't done in RAS. This is - ! precip w/ large particles, so freezing is - ! strict. Check up on this!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - QTMP1 = 0. - QTMP2 = 0. - QTMP3 = 0. - QRN_ALL = 0. - QSN_ALL = 0. - - - if ( TEMP < MAPL_TICE ) then - QTMP2 = QRN_CU_1D - QSN_CU = QRN_CU_1D - QRN_CU_1D = 0. - TEMP = TEMP + QSN_CU*(MAPL_ALHS-MAPL_ALHL) / MAPL_CP - end if - - QRN_CU_1D = QRN_CU_1D + QRN_SC_dev(I,K) + QRN_XS!! add any excess precip to convective - QSN_CU = QSN_CU + QSN_SC_dev(I,K) + QSN_XS - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - !---------------------------------------------------------------------------------------------- - ! Column will now be swept from top-down for precip accumulation/accretion/re-evaporation - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - - AREA_UPD_PRC_tolayer = 0.0 - - - TOT_PREC_UPD = TOT_PREC_UPD + ( ( QRN_CU_1D + QSN_CU ) * MASS ) - AREA_UPD_PRC = AREA_UPD_PRC + ( TOT_UPDFRC* ( QRN_CU_1D + QSN_CU )* MASS ) - - if ( TOT_PREC_UPD > 0.0 ) AREA_UPD_PRC_tolayer = MAX( AREA_UPD_PRC/TOT_PREC_UPD, 1.E-6 ) - - AREA_UPD_PRC_tolayer = CLDPARAMS%CNV_BETA * AREA_UPD_PRC_tolayer - - IF (K == LM) THEN ! We've accumulated over the whole column - - if ( TOT_PREC_UPD > 0.0 ) AREA_UPD_PRC = MAX( AREA_UPD_PRC/TOT_PREC_UPD, 1.E-6 ) - - AREA_UPD_PRC = CLDPARAMS%CNV_BETA * AREA_UPD_PRC - - !! "couple" to diagnostic areal fraction output - !! Intensity factor in PRECIP3 is floored at - !! 1.0. So this is fair. - - CUARF_dev(I) = MIN( AREA_UPD_PRC, 1.0 ) - - END IF - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! GET SOME MICROPHYSICAL QUANTITIES - - CALL MICRO_AA_BB_3( TEMP,PP_dev(I,K),QST3_dev(I,K),AA3,BB3 ) - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - QTMP1 = QLW_LS_dev(I,K) + QLW_AN_dev(I,K) - QTMP2 = QIW_LS_dev(I,K) + QIW_AN_dev(I,K) - QTOT=QTMP1+QTMP2 - - ! QTMP1 = 0.0 - ! QTMP2 = 0.0 - - - - ! Convective - ! ---------- - !RHCRIT=1.0 - - call PRECIP3( & - K,LM , & - DT , & - FRLAND_dev(I) , & - RHCRIT , & - QRN_CU_1D , & - QSN_CU , & - QTMP1 , & - QTMP2 , & - TEMP , & - Q_dev(I,K) , & - mass , & - imass , & - PP_dev(I,K) , & - DZET_dev(I,K) , & - QDDF3_dev(I,K) , & - AA3 , & - BB3 , & - AREA_UPD_PRC_tolayer , & - PRECU_dev(I) , & - SNRCU_dev(I) , & - PRN_CU_above , & - PSN_CU_above , & - EVAP_DD_CU_above, & - SUBL_DD_CU_above, & - REV_AN_dev(I,K) , & - RSU_AN_dev(I,K) , & - ACLL_AN_dev(I,K), & - ACIL_AN_dev(I,K), & - PFL_AN_dev(I,K) , & - PFI_AN_dev(I,K) , & - VFALLRN , & - VFALLSN , & - FRZ_PP_dev(I,K) , & - CLDPARAMS%CNVENVFC, CLDPARAMS%CNVDDRFC, & - ANVFRC_dev(I,k), CLDFRC_dev(I,k), & - PP_dev(I,KCBL(I))) - - VFALLSN_AN_dev(I,K) = VFALLSN - VFALLRN_AN_dev(I,K) = VFALLRN - - if (.not.use_autoconv_timescale) then - if (VFALLSN.NE.0.) then - QSN_ALL = QSN_ALL + PFI_AN_dev(I,K)/VFALLSN - end if - if (VFALLRN.NE.0.) then - QRN_ALL = QRN_ALL + PFL_AN_dev(I,K)/VFALLRN - end if - end if - - if (.true.) then - - IF ( (QLW_LS_dev(I,K)+QLW_AN_dev(I,K)) > 1.e-20 ) THEN - QTMP3 = 1./(QLW_LS_dev(I,K)+QLW_AN_dev(I,K)) - ELSE - QTMP3 = 0.0 - END IF - QLW_LS_dev(I,K) = QLW_LS_dev(I,K) * QTMP1 * QTMP3 - QLW_AN_dev(I,K) = QLW_AN_dev(I,K) * QTMP1 * QTMP3 - NCPL_dev(I, K) = NCPL_dev(I, K)* QTMP1 * QTMP3 - - IF ( (QIW_LS_dev(I,K)+QIW_AN_dev(I,K)) > 1.0e-20 ) THEN - QTMP3 = 1./(QIW_LS_dev(I,K)+QIW_AN_dev(I,K)) - ELSE - QTMP3 = 0.0 - END IF - QIW_LS_dev(I,K) = QIW_LS_dev(I,K) * QTMP2 * QTMP3 - QIW_AN_dev(I,K) = QIW_AN_dev(I,K) * QTMP2 * QTMP3 - NCPI_dev(I, K) = NCPI_dev(I, K)* QTMP2 * QTMP3 - - ! reduce cloud farction as well - QTMP3 = QIW_LS_dev(I,K)+QIW_AN_dev(I,K) + QLW_LS_dev(I,K)+QLW_AN_dev(I,K) - - If (QTOT .gt. 0.0) then - CLDFRC_dev(I,k) = CLDFRC_dev(I,k)*QTMP3/QTOT - ANVFRC_dev(I,k) = ANVFRC_dev(I,k)*QTMP3/QTOT - end if - - end if - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - QRAIN_CN(I,K) = QRN_ALL / (100.*PP_dev(I,K) / (MAPL_RGAS*TEMP )) - QSNOW_CN(I,K) = QSN_ALL / (100.*PP_dev(I,K) / (MAPL_RGAS*TEMP )) - QRN_CU_dev(I,K) = QRN_CU_1D - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - TOTFRC = CLDFRC_dev(I,K) + ANVFRC_dev(I,K) - - IF ( TOTFRC > 1.00 ) THEN - CLDFRC_dev(I,k) = CLDFRC_dev(I,k)*(1.00 / TOTFRC ) - ANVFRC_dev(I,k) = ANVFRC_dev(I,k)*(1.00 / TOTFRC ) - END IF - - TOTFRC = CLDFRC_dev(I,K) + ANVFRC_dev(I,K) -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - - - TH_dev(I,K) = TEMP / EXNP_dev(I,K) - - end do K_LOOP - - - end do RUN_LOOP - - END SUBROUTINE MACRO_CLOUD - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!!!!!!!!!!!!! - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !! P R O C E S S S U B R O U T I N E S !! - !! * * * * * !! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !! !! - !! !! - !! !! - !! !! - !! !! - !! !! - !! !! - !! !! - !! !! - !! !! - !! !! - !! !! - !! !! - !! !! - !! !! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !! P R O C E S S S U B R O U T I N E S !! - !! * * * * * !! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !! !! - !! !! - !! !! - !! !! - !! !! - !! !! - !! !! - !! !! - !! !! - !! !! - !! !! - !! !! - !! !! - !! !! - !! !! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !! P R O C E S S S U B R O U T I N E S !! - !! * * * * * !! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - subroutine pdf_spread ( & - PP,ALPHA,& - ALPHT_DIAG, & - FRLAND, MINRHCRIT, USE_SLINGO, EIS) - - real, intent(in) :: PP - real, intent(out) :: ALPHA - real, intent(in) :: FRLAND, MINRHCRIT, TURNRHCRIT - real :: slope_up, aux1, aux2, maxalpha - - slope_up = 20.0 - maxalpha=1.0-MINRHCRIT - - ! alpha is the 1/2*width so RH_crit=1.0-alpha - - ! Use Slingo-Ritter (1985) formulation for critical relative humidity - ! array a1 holds the critical rh, ranges from 0.8 to 1 - !Reformulated by Donifan Barahona - - aux1 = min(max((pp- CLDPARAMS%TURNRHCRIT)/CLDPARAMS%SLOPERHCRIT, -20.0), 20.0) - aux2 = min(max((CLDPARAMS%TURNRHCRIT_UPPER - pp)/slope_up, -20.0), 20.0) - - - if (frland > 0.05) then - aux1=1.0 - !maxalpha=max(maxalpha-0.05, 0.001) - else - aux1 = 1.0/(1.0+exp(aux1)) !this function reproduces the old Sligo function. - ! aux2=min(max(2.0*(ltsx-min_lts), -20.0), 20.0) - !aux2=0.5/(1.0+exp(aux2)) - ! aux1=max(aux2, aux1) - - end if - - !aux2= 1.0/(1.0+exp(aux2)) !this function reverses the profile at low P - aux2=1.0 - - alpha = maxalpha*aux1*aux2 - - - - ALPHA = MIN( ALPHA , 0.4 ) ! restrict RHcrit to > 60% - ALPHT_DIAG = ALPHA - - end subroutine pdf_spread - - subroutine update_cld( & - DT , & - ALPHA , & - PDFFLAG , & - CNVFRC , & - SRFTYPE , & - PL , & - QV , & - QCl , & - QAl , & - QCi , & - QAi , & - TE , & - CF , & - AF , & - SCICE , & - NI , & - NL , & - RHcmicro , & - DO_HYSTPDF) - - real, intent(in) :: DT,ALPHA,PL,CNVFRC,SRFTYPE - integer, intent(in) :: pdfflag - real, intent(inout) :: TE,QV,QCl,QCi,CF,QAl,QAi,AF, NI, RHCmicro, NL, SCICE - - ! internal arrays - real :: CFO - real :: QT - - real :: QSx,DQsx - - real :: QCx, QC, QA - - real :: QX, QSLIQ, QSICE, CFALL, DQx, FQA, DELQ - - real :: SHOM, maxalpha - ! internal scalars - logical :: DO_HYSTPDF - - maxalpha=1.0-CLDPARAMS%MINRHCRIT - - QC = QCl + QCi - QA = QAl + QAi - QT = QC + QA + QV !Total water after microphysics - CFALL = AF+CF - FQA = 0.0 - if (QA+QC .gt. tiny(1.0)) FQA=QA/(QA+QC) - - SHOM=2.349-(TE/259.0) !hom threeshold Si according to Ren & McKenzie, 2005 - - !================================================ - ! First find the cloud fraction that would correspond to the current condensate - QSLIQ = QSATLQ( & - TE , & - PL*100.0 , DQ=DQx ) - - - QSICE = QSATIC( & - TE , & - PL*100.0 , DQ=DQx ) - - if ((QC+QA) .gt. 1.0e-13) then - QSx=((QCl+QAl)*QSLIQ + QSICE*(QCi+QAi))/(QC+QA) - else - DQSx = DQSAT( & - TE , & - PL , 35.0, QSAT=QSx ) !use ramp to -40 - end if - - - - if (TE .gt. CLDPARAMS%T_ICE_ALL) SCICE = 1.0 - QCx=QC+QA - QX=QT-QSx*SCICE - CFo=0. - - !====== recalculate QX if too low and SCICE= 1.0 ) QVx = QSx*1.e-4 - if ( AF > 0. ) QAx = QA/AF - - QT = QCx + QVx - - TEp = TEo - QSn = QSx - TEn = TEo - CFn = CFx - QVn = QVx - QCn = QCx - DQS = DQSx - - do n=1,nmax - - QVp = QVn - QCp = QCn - CFp = CFn - TEp = TEn - fQip= fQi - - if(pdfflag.lt.2) then - - sigmaqt1 = ALPHA*QSn - sigmaqt2 = ALPHA*QSn - - elseif(pdfflag.eq.2) then - ! for triangular, symmetric: sigmaqt1 = sigmaqt2 = alpha*qsn (alpha is half width) - ! for triangular, skewed r : sigmaqt1 < sigmaqt2 - ! try: skewed right below 500 mb -!!! if(pl.lt.500.) then - sigmaqt1 = ALPHA*QSn - sigmaqt2 = ALPHA*QSn -!!! else -!!! sigmaqt1 = 2*ALPHA*QSn*0.4 -!!! sigmaqt2 = 2*ALPHA*QSn*0.6 -!!! endif - elseif(pdfflag .eq. 4) then !lognormal (sigma is dimmensionless) - sigmaqt1 = max(ALPHA/sqrt(3.0), 0.001) - endif - - - qsnx= qsn*SC_ICE ! - if ((QCI .ge. 0.0) .and. (qsn .gt. qt)) qsnx=qsn !this way we do not evaporate preexisting ice but maintain supersat - - - call pdffrac(PDFFLAG,qt,sigmaqt1,sigmaqt2,qsnx,CFn) - call pdfcondensate(PDFFLAG,qt,sigmaqt1,sigmaqt2,qsnx,QCn) - - - DQCALL = QCn - QCp - CF = CFn * ( 1.-AF) - Nfac = 100.*PL*R_AIR/TEp !density times conversion factor - NLv = NL/Nfac - NIv = NI/Nfac - call Bergeron_iter ( & !Microphysically-based partitions the new condensate - DT , & - PL , & - TEp , & - QT , & - QCi , & - QAi , & - QCl , & - QAl , & - CF , & - AF , & - NLv , & - NIv , & - CNVFRC,SRFTYPE , & - DQCALL , & - fQi , & - .true.) - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! These lines represent adjustments - ! to anvil condensate due to the - ! assumption of a stationary TOTAL - ! water PDF subject to a varying - ! QSAT value during the iteration -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - if ( AF > 0. ) then - QAo = QAx ! + QSx - QS - else - QAo = 0. - end if -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - ALHX = (1.0-fQi)*MAPL_ALHL + fQi*MAPL_ALHS - - if(pdfflag.eq.1) then - QCn = QCp + ( QCn - QCp ) / ( 1. - (CFn * (ALPHA-1.) - (QCn/QSn))*DQS*ALHX/MAPL_CP) - elseif(pdfflag.eq.2) then - ! This next line needs correcting - need proper d(del qc)/dT derivative for triangular - ! for now, just use relaxation of 1/2. - if (n.ne.nmax) QCn = QCp + ( QCn - QCp ) *0.5 - endif - - QVn = QVp - (QCn - QCp) - TEn = TEp + (1.0-fQi)*(MAPL_ALHL/MAPL_CP)*( (QCn - QCp)*(1.-AF) + (QAo-QAx)*AF ) & - + fQi* (MAPL_ALHS/MAPL_CP)*( (QCn - QCp)*(1.-AF) + (QAo-QAx)*AF ) - - if (abs(Ten - Tep) .lt. 0.00001) exit - - DQS = DQSAT( TEn, PL, QSAT=QSn ) - - enddo ! qsat iteration - - CFo = CFn - CF = CFn - QCo = QCn - QVo = QVn - TEo = TEn - - ! Update prognostic variables. Deal with special case of AF=1 - ! Temporary variables QCo, QAo become updated grid means. - if ( AF < 1.0 ) then - CF = CFo * ( 1.-AF) - QCo = QCo * ( 1.-AF) - QAo = QAo * AF - else - - ! Special case AF=1, i.e., box filled with anvil. - ! - Note: no guarantee QV_box > QS_box - CF = 0. ! Remove any other cloud - QAo = QA + QC ! Add any LS condensate to anvil type - QCo = 0. ! Remove same from LS - QT = QAo + QV ! Total water - ! Now set anvil condensate to any excess of total water - ! over QSx (saturation value at top) - QAo = MAX( QT - QSx, 0. ) - end if - - ! Now take {\em New} condensate and partition into ice and liquid - ! taking care to keep both >=0 separately. New condensate can be - ! less than old, so $\Delta$ can be < 0. - - dQCl = 0.0 - dQCi = 0.0 - dQAl = 0.0 - dQAi = 0.0 - - !large scale - - QCx = QCo - QC - if (QCx .lt. 0.0) then !net evaporation. Water evaporates first - dQCl = max(QCx, -QCl) - dQCi = max(QCx - dQCl, -QCi) - else - dQCl = (1.0-fQi)*QCx - dQCi = fQi * QCx - end if - - !Anvil - QAx = QAo - QA - - if (QAx .lt. 0.0) then !net evaporation. Water evaporates first - dQAl = max(QAx, -QAl) - dQAi = max(QAx - dQAl, -QAi) - else - dQAl = (1.0-fQi)*QAx - dQAi = QAx*fQi - end if - - ! Clean-up cloud if fractions are too small - if ( AF < 1.e-5 ) then - dQAi = -QAi - dQAl = -QAl - end if - if ( CF < 1.e-5 ) then - dQCi = -QCi - dQCl = -QCl - end if - - QAi = QAi + dQAi - QAl = QAl + dQAl - QCi = QCi + dQCi - QCl = QCl + dQCl - QV = QV - ( dQAi+dQCi+dQAl+dQCl) - - TE = TE + (MAPL_ALHL*( dQAi+dQCi+dQAl+dQCl)+MAPL_ALHF*(dQAi+dQCi))/ MAPL_CP - - ! We need to take care of situations where QS moves past QA - ! during QSAT iteration. This should be only when QA/AF is small - ! to begin with. Effect is to make QAo negative. So, we - ! "evaporate" offending QA's - ! - ! We get rid of anvil fraction also, although strictly - ! speaking, PDF-wise, we should not do this. - if ( QAo <= 0. ) then - QV = QV + QAi + QAl - TE = TE - (MAPL_ALHS/MAPL_CP)*QAi - (MAPL_ALHL/MAPL_CP)*QAl - QAi = 0. - QAl = 0. - AF = 0. - end if - - end subroutine hystpdf_new - - subroutine PRECIP3( & - K,LM , & - DT , & - FRLAND , & - RHCR3 , & - QPl , & - QPi , & - QCl , & - QCi , & - TE , & - QV , & - mass , & - imass , & - PL , & - dZE , & - QDDF3 , & - AA , & - BB , & - AREA , & - RAIN , & - SNOW , & - PFl_above , & - PFi_above , & - EVAP_DD_above, & - SUBL_DD_above, & - REVAP_DIAG , & - RSUBL_DIAG , & - ACRLL_DIAG , & - ACRIL_DIAG , & - PFL_DIAG , & - PFI_DIAG , & - VFALLRN , & - VFALLSN , & - FRZ_DIAG , & - ENVFC,DDRFC, AF, CF, & - PCBL ) - - - integer, intent(in) :: K,LM - - real, intent(in ) :: DT - - real, intent(inout) :: QV,QPl,QPi,QCl,QCi,TE - - real, intent(in ) :: mass,imass - real, intent(in ) :: PL - real, intent(in ) :: AA,BB - real, intent(in ) :: RHCR3 - real, intent(in ) :: dZE - real, intent(in ) :: QDDF3 - real, intent( out) :: RAIN,SNOW - real, intent(in ) :: AREA - real, intent(in ) :: FRLAND - - real, intent(inout) :: PFl_above, PFi_above - real, intent(inout) :: EVAP_DD_above, SUBL_DD_above - - real, intent( out) :: REVAP_DIAG - real, intent( out) :: RSUBL_DIAG - real, intent( out) :: ACRLL_DIAG,ACRIL_DIAG - real, intent( out) :: PFL_DIAG, PFI_DIAG - real, intent(inout) :: FRZ_DIAG - real, intent( out) :: VFALLSN, VFALLRN - - real, intent(in ) :: ENVFC,DDRFC - - real, intent(in ) :: AF,CF, PCBL - - - real :: PFi,PFl,ENVFRAC - real :: TKo,QKo,QSTKo,DQSTKo,RH_BOX,T_ED,QPlKo,QPiKo - real :: Ifactor,RAINRAT0,SNOWRAT0 - real :: FALLRN,FALLSN,VEsn,VErn,NRAIN,NSNOW,Efactor - - real :: TinLAYERrn,DIAMrn,DROPRAD - real :: TinLAYERsn,DIAMsn,FLAKRAD - - real :: EVAP,SUBL,ACCR,MLTFRZ,EVAPx,SUBLx - real :: EVAP_DD,SUBL_DD,DDFRACT - real :: LANDSEAF, TC, MAXMLT, iDT - - real :: tmpARR, CFR, aux, RH_EVAP - - - real :: QSICE, DQSI, Told, QKCLR - - integer :: itr - - logical, parameter :: taneff = .true. - - - - real, parameter :: TRMV_L = 1.0 ! m/s - real, parameter :: TAU_FRZ = 5000.0 ! sec - real, parameter :: FRZ_TAU = 1.0/TAU_FRZ ! sec^-1 - real, parameter :: MELT_T = 5.0 ! degrees C - real, parameter :: LFBYCP = MAPL_ALHF/MAPL_CP - real, parameter :: CPBYLF = 1.0/LFBYCP - real, parameter :: B_SUB = 1.00 - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! fraction of precip falling through "environment" vs - ! through cloud - - - if(taneff) then - !reproduces the atan profile but is less messy - - aux = min(max((pl- PCBL)/10.0, -20.0), 20.0) - aux = 1.0/(1.0+exp(-aux)) - envfrac = ENVFC + (1.0-ENVFC)*aux !ENVFC is the minimum exposed area. Below cloud base envfrac becomes 1. - - - !if (pl .le. 600.) then - ! envfrac = 0.25 - !else - ! envfrac = 0.25 + (1.-0.25)/(19.) * & - ! ((atan( (2.*(pl-600.)/(900.-600.)-1.) * & - ! tan(20.*MAPL_PI/21.-0.5*MAPL_PI) ) + 0.5*MAPL_PI) * 21./MAPL_PI - 1.) - ! end if - - - envfrac = min(envfrac,1.) - - else - ENVFRAC = ENVFC - endif - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - CFR= AF+CF - if ( CFR < 0.99) then - tmpARR = 1./(1.-CFR) - else - tmpARR = 0.0 - end if -!!!!!!!!!!!!!!!!!!! - - IF ( AREA > 0. ) THEN - Ifactor = 1./ ( AREA ) - ELSE - Ifactor = 1.00 - END if - - Ifactor = MAX( Ifactor, 1.) ! - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! - ! Start at top of precip column: - ! - ! a) Accrete - ! b) Evaporate/Sublimate - ! c) Rain/Snow-out to next level down - ! d) return to (a) - ! - ! .................................................................... - ! - ! Accretion formulated according to Smith (1990, Q.J.R.M.S., 116, 435 - ! Eq. 2.29) - ! - ! Evaporation (ibid. Eq. 2.32) - ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - -iDT = 1.0/DT - -!!! INITIALIZE DIAGNOSTIC ARRAYS !!!!!!!!!!!!!!!!!!!!! - PFL_DIAG = 0. - PFI_DIAG = 0. - ACRIL_DIAG = 0. - ACRLL_DIAG = 0. - REVAP_DIAG = 0. - RSUBL_DIAG = 0. - RH_EVAP= RHCR3 - - !RH_EVAP= 1.0 - - DDFRACT = DDRFC - - IF (K == 1) THEN - PFl=QPl*MASS - PFi=QPi*MASS - - EVAP_DD = 0. - SUBL_DD = 0. - - VFALLRN = 0.0 - VFALLSN = 0.0 - ELSE - QPl = QPl + PFl_above * iMASS - PFl = 0.00 - - QPi = QPi + PFi_above * iMASS - PFi = 0.00 - - - IF(QCL > 0.0) THEN - IF(QPi > 0.0) THEN - ACCR = min(CLDPARAMS%C_ACC*(QPl*MASS)*QCl, QCl) - QPl = QPl + ACCR - QCl = QCl - ACCR - - ACRLL_DIAG = ACCR * iDT - END IF - - IF(QPi > 0.0) THEN - ACCR = min(CLDPARAMS%C_ACC*(QPi*MASS)*QCl, QCl) - QPi = QPi + ACCR - QCl = QCl - ACCR - TE = TE + LFBYCP*ACCR - - ACRIL_DIAG = ACCR * iDT - END IF - END IF - - - RAINRAT0 = Ifactor*QPl*MASS/DT - SNOWRAT0 = Ifactor*QPi*MASS/DT - - call MARSHPALMQ2(RAINRAT0,PL,DIAMrn,NRAIN,FALLrn,VErn) - call MARSHPALMQ2(SNOWRAT0,PL,DIAMsn,NSNOW,FALLsn,VEsn) - - IF ( FRLAND < 0.1 ) THEN - !! DIAMsn = MAX( DIAMsn, 1.0e-3 ) ! Over Ocean - END IF - - VFALLRN = FALLrn - VFALLSN = FALLsn - - TinLAYERrn = dZE / ( FALLrn+0.01 ) - TinLAYERsn = dZE / ( FALLsn+0.01 ) - - !***************************************** - ! Melting of Frozen precipitation - !***************************************** - - TC = TE - MAPL_TICE - - IF( QPi > 0.0 .AND. TC > 0.0) THEN - - MAXMLT = min(QPi, TC*CPBYLF) - - IF ( K < LM-3 .and. TC <= MELT_T) THEN - MLTFRZ = min(TinLAYERsn*QPi*TC*FRZ_TAU, MAXMLT) - else - MLTFRZ = MAXMLT - END IF - - TE = TE - LFBYCP*MLTFRZ - QPl = QPl + MLTFRZ - QPi = QPi - MLTFRZ - FRZ_DIAG = FRZ_DIAG - MLTFRZ * iDT - - END IF - - !***************************************** - ! Freezing of rain - !***************************************** - - IF ( QPl > 0.0 .AND. TC <= 0.0) THEN - - MLTFRZ = min(QPl,-TC*CPBYLF) - TE = TE + LFBYCP*MLTFRZ - QPi = QPi + MLTFRZ - QPl = QPl - MLTFRZ - FRZ_DIAG = FRZ_DIAG + MLTFRZ * iDT - - END IF - - - ! ****************************************** - ! In the exp below, evaporation time - ! scale is determined "microphysically" - ! from temp, press, and drop size. In this - ! context C_EV becomes a dimensionless - ! fudge-fraction. - ! Also remember that these microphysics - ! are still only for liquid. - ! ****************************************** - - QKo = QV - TKo = TE - QPlKo = QPl - QPiKo = QPi - - EVAP = 0.0 - SUBL = 0.0 - - ! if (TKo .gt. 240.0) then - do itr = 1,20 ! - - DQSTKo = DQSAT ( TKo , PL, QSAT=QSTko ) !use for rain - - QSTKo = MAX( QSTKo , 1.0e-7 ) - -!!!!! RAin falling !!!!!!!!!!!!!!!!!!!!!!! - if (tmpARR .gt. 0.0) then - QKCLR=(QKo -QSTKo*CFR)*tmpARR - RH_BOX =QKCLR/QSTKo - else - RH_BOX = QKo/QSTKo - end if - - IF ( RH_BOX < RH_EVAP ) THEN - Efactor = RHO_W * ( AA + BB ) / (RH_EVAP - RH_BOX ) - else - Efactor = 9.99e9 - end if - - - LANDSEAF = 1.00 - - - if ( ( RH_BOX < RH_EVAP ) .AND. ( DIAMrn > 0.00 ) .AND. & - ( PL > 100. ) .AND. ( PL < CLDPARAMS%REVAP_OFF_P ) ) then - DROPRAD=0.5*DIAMrn - T_ED = Efactor * DROPRAD**2 - T_ED = T_ED * ( 1.0 + DQSTKo*MAPL_ALHL/MAPL_CP ) - EVAP = QPl*(1.0 - EXP( -CLDPARAMS%C_EV_R * VErn * LANDSEAF *ENVFRAC* TinLAYERrn / T_ED ) ) - ELSE - EVAP = 0.0 - END if - -!!!!! Snow falling !!!!!!!!!!!!!!!!!!!!!!! - - !QSICE = QSATIC( min(TKo, T_ICE_MAX), PL*100.0 , DQ=DQSI ) ! use for snow - - DQSI = DQSAT( TKo , PL, 5.0, QSAT = QSICE ) !use for snow, small ramp to assure continuitiy at higher T - !DQSI = DQSAT( TKo , PL, QSAT = QSICE ) - QSICE = MAX( QSICE , 1.0e-7 ) - if (tmpARR .gt. 0.0) then - QKCLR =(QKo -QSICE*CFR)*tmpARR !Snow only sublimates when QV 0.00 ) .AND. & - ( PL > 100. ) .AND. ( PL < CLDPARAMS%REVAP_OFF_P ) ) then - FLAKRAD=0.5*DIAMsn - T_ED = Efactor * FLAKRAD**2 - T_ED = T_ED * ( 1.0 + DQSI*MAPL_ALHS/MAPL_CP ) - SUBL = QPi*(1.0 - EXP( -CLDPARAMS%C_EV_S * VEsn * LANDSEAF * ENVFRAC * TinLAYERsn / T_ED ) ) - ELSE - SUBL = 0.0 - END IF - - if (itr == 1) then - EVAPx = EVAP - SUBLx = SUBL - else - EVAP = (EVAP+EVAPx) /2.0 - SUBL = (SUBL+SUBLx) /2.0 - endif - - EVAP= EVAP*(1.-CFR)! Can only evaporate in the clear parto of the cell DONIF - SUBL = SUBL*(1.-CFR) - - Told = TKo - !QKo=QKo + EVAP + SUBL - TKo=TKo - EVAP * MAPL_ALHL / MAPL_CP - SUBL * MAPL_ALHS / MAPL_CP - - - if (abs(Told-Tko) .le. 0.01) exit - enddo - ! end if - - QPi = QPi - SUBL - QPl = QPl - EVAP - - !! Put some re-evap/re-subl precip in to a \quote{downdraft} to be applied later - EVAP_DD = EVAP_DD_above + DDFRACT*EVAP*MASS - EVAP = EVAP - DDFRACT*EVAP - SUBL_DD = SUBL_DD_above + DDFRACT*SUBL*MASS - SUBL = SUBL - DDFRACT*SUBL - ! ----- - - QV = QV + EVAP + SUBL - TE = TE - EVAP * MAPL_ALHL / MAPL_CP - SUBL * MAPL_ALHS / MAPL_CP - - REVAP_DIAG = EVAP / DT - RSUBL_DIAG = SUBL / DT - - PFl = QPl*MASS - PFi = QPi*MASS - - PFL_DIAG = PFl/DT - PFI_DIAG = PFi/DT - end if - - ! QDDF3 (<= QDDF3_dev) is calculated on the CPU in order to avoid - ! the reverse loop on GPUs and thus save local memory use. - EVAP = QDDF3*EVAP_DD/MASS - SUBL = QDDF3*SUBL_DD/MASS - QV = QV + EVAP + SUBL - TE = TE - EVAP * MAPL_ALHL / MAPL_CP - SUBL * MAPL_ALHS / MAPL_CP - REVAP_DIAG = REVAP_DIAG + EVAP / DT - RSUBL_DIAG = RSUBL_DIAG + SUBL / DT - - IF (K == LM) THEN - RAIN = PFl/DT - SNOW = PFi/DT - END IF - - QPi = 0. - QPl = 0. - - PFl_above = PFl - PFi_above = Pfi - - EVAP_DD_above = EVAP_DD - SUBL_DD_above = SUBL_DD - - end subroutine precip3 - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine MARSHPALMQ2(RAIN,PR,DIAM3,NTOTAL,W,VE) - - real, intent(in ) :: RAIN,PR ! in kg m**-2 s**-1, mbar - real, intent(out) :: DIAM3,NTOTAL,W,VE - - real :: RAIN_DAY,SLOPR,DIAM1 - - real, parameter :: N0 = 0.08 ! # cm**-3 - - INTEGER :: IQD - - real :: RX(8) , D3X(8) - - ! Marshall-Palmer sizes at different rain-rates: avg(D^3) - - RX = (/ 0. , 5. , 20. , 80. , 320. , 1280., 4*1280., 16*1280. /) ! rain per in mm/day - D3X= (/ 0.019, 0.032, 0.043, 0.057, 0.076, 0.102, 0.137 , 0.183 /) - - RAIN_DAY = RAIN * 3600. *24. - - IF ( RAIN_DAY <= 0.00 ) THEN - DIAM1 = 0.00 - DIAM3 = 0.00 - NTOTAL= 0.00 - W = 0.00 - END IF - - DO IQD = 1,7 - IF ( (RAIN_DAY <= RX(IQD+1)) .AND. (RAIN_DAY > RX(IQD) ) ) THEN - SLOPR =( D3X(IQD+1)-D3X(IQD) ) / ( RX(IQD+1)-RX(IQD) ) - DIAM3 = D3X(IQD) + (RAIN_DAY-RX(IQD))*SLOPR - END IF - END DO - - IF ( RAIN_DAY >= RX(8) ) THEN - DIAM3=D3X(8) - END IF - - NTOTAL = 0.019*DIAM3 - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - DIAM3 = 0.664 * DIAM3 !! DRYING/EVAP SHOULD PROBABLY GO AS !! - !! D_1.5 == <>^(2/3) NOT AS !! - !! D_3 == <>^(1/3) !! - !! RATIO D_1.5/D_3 =~ 0.66 (JTB 10/17/2002) !! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - W = (2483.8 * DIAM3 + 80.)*SQRT(1000./PR) - !VE = 1.0 + 28.0*DIAM3 - VE = MAX( 0.99*W/100. , 1.000 ) - - DIAM1 = 3.0*DIAM3 - ! Change back to MKS units - - DIAM1 = DIAM1/100. - DIAM3 = DIAM3/100. - W = W/100. - NTOTAL = NTOTAL*1.0e6 - - end subroutine MARSHPALMQ2 - !========================================================== - - subroutine MICRO_AA_BB_3(TEMP,PR,Q_SAT,AA,BB) - - real, intent(in ) :: TEMP,Q_SAT - real, intent(in ) :: PR - real, intent(out) :: AA,BB - - real :: E_SAT - - real, parameter :: EPSILON = MAPL_H2OMW/MAPL_AIRMW - real, parameter :: K_COND = 2.4e-2 ! J m**-1 s**-1 K**-1 - real, parameter :: DIFFU = 2.2e-5 ! m**2 s**-1 - - E_SAT = 100.* PR * Q_SAT /( (EPSILON) + (1.0-(EPSILON))*Q_SAT ) ! (100 converts from mbar to Pa) - - AA = ( GET_ALHX3(TEMP)**2 ) / ( K_COND*MAPL_RVAP*(TEMP**2) ) - ! AA = ( MAPL_ALHL**2 ) / ( K_COND*MAPL_RVAP*(TEMP**2) ) - - BB = MAPL_RVAP*TEMP / ( DIFFU*(1000./PR)*E_SAT ) - - end subroutine MICRO_AA_BB_3 - - function GET_ALHX3(T) RESULT(ALHX3) - - real, intent(in) :: T - real :: ALHX3 - - real :: T_X - - T_X = T_ICE_MAX - - if ( T < CLDPARAMS%T_ICE_ALL ) then - ALHX3=MAPL_ALHS - end if - - if ( T > T_X ) then - ALHX3=MAPL_ALHL - end if - - if ( (T <= T_X) .and. (T >= CLDPARAMS%T_ICE_ALL) ) then - ALHX3 = MAPL_ALHS + (MAPL_ALHL-MAPL_ALHS)*( T - CLDPARAMS%T_ICE_ALL ) /( T_X - CLDPARAMS%T_ICE_ALL ) - end if - - end function GET_ALHX3 - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !Partitions DQ into ice and liquid. Follows Barahona et al. GMD. 2014 -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine Bergeron_iter ( & - DTIME , & - PL , & - TE , & - QV , & - QILS , & - QICN , & - QLLS , & - QLCN , & - CF , & - AF , & - NL , & - NI , & - CNVFRC,SRFTYPE , & - DQALL , & - FQI , & - needs_preexisting ) - - real , intent(in ) :: DTIME, PL, TE !, RHCR - real , intent(inout ) :: DQALL - real , intent(in) :: QV, QLLS, QLCN, QICN, QILS - real , intent(in) :: CF, AF, NL, NI, CNVFRC,SRFTYPE - real, intent (out) :: FQI - logical, intent (in) :: needs_preexisting - - real :: DC, TEFF,DEP, & - DQSL, DQSI, QI, TC, & - DIFF, DENAIR, DENICE, AUX, & - QTOT, LHCORR, QL, DQI, DQL, & - QVINC, QSLIQ, CFALL, & - QSICE, fQI_0, FQA, NIX - - DIFF = 0.0 - DEP=0.0 - QI = QILS + QICN !neccesary because NI is for convective and large scale - QL = QLLS +QLCN - QTOT=QI+QL - FQA = 0.0 - if (QTOT .gt. 0.0) FQA = (QICN+QILS)/QTOT - NIX= (1.0-FQA)*NI - - DQALL=DQALL/DTIME !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - CFALL= min(CF+AF, 1.0) - TC=TE-273.0 - fQI_0 = fQI - - !Completelely glaciated cloud: - if (TE .ge. T_ICE_MAX) then !liquid cloud - FQI = 0.0 - - elseif(TE .le. CLDPARAMS%T_ICE_ALL) then !ice cloud - - FQI = 1.0 - - else !mixed phase cloud - - FQI = 0.0 - - if (QILS .le. 0.0) then - - if (needs_preexisting) then - ! new 0518 this line ensures that only preexisting ice can grow by deposition. - ! Only works if explicit ice nucleation is available (2 moment muphysics and up) - else - fQi = ice_fraction( TE, CNVFRC,SRFTYPE ) - end if - return - end if - - - QVINC= QV - QSLIQ = QSATLQ( & - TE , & - PL*100.0 , DQ=DQSL ) - - QSICE = QSATIC( & - TE , & - PL*100.0 , DQ=DQSI ) - - QVINC =MIN(QVINC, QSLIQ) !limit to below water saturation - - ! Calculate deposition onto preexisting ice - - DIFF=(0.211*1013.25/(PL+0.1))*(((TE+0.1)/273.0)**1.94)*1e-4 !From Seinfeld and Pandis 2006 - DENAIR=PL*100.0/MAPL_RGAS/TE - DENICE= 1000.0*(0.9167 - 1.75e-4*TC -5.0e-7*TC*TC) !From PK 97 - LHcorr = ( 1.0 + DQSI*MAPL_ALHS/MAPL_CP) !must be ice deposition - - if ((NIX .gt. 1.0) .and. (QILS .gt. 1.0e-10)) then - DC=max((QILS/(NIX*DENICE*MAPL_PI))**(0.333), 20.0e-6) !Assumme monodisperse size dsitribution - else - DC = 20.0e-6 - end if - - TEFF= NIX*DENAIR*2.0*MAPL_PI*DIFF*DC/LHcorr ! 1/Dep time scale - - DEP=0.0 - if ((TEFF .gt. 0.0) .and. (QILS .gt. 1.0e-14)) then - AUX =max(min(DTIME*TEFF, 20.0), 0.0) - DEP=(QVINC-QSICE)*(1.0-EXP(-AUX))/DTIME - end if - - DEP=MAX(DEP, -QILS/DTIME) !only existing ice can be sublimated - - !DEP=max(DEP, 0.0) - - DQI = 0.0 - DQL = 0.0 - FQI=0.0 - !QS_MIX=QSLIQ - !DQS_MIX = DQSL - !Partition DQALL accounting for Bergeron-Findensen process - - if (DQALL .ge. 0.0) then !net condensation. Note: do not allow bergeron with QLCN - - if (DEP .gt. 0.0) then - DQI = min(DEP, DQALL + QLLS/DTIME) - DQL = DQALL - DQI - else - DQL=DQALL ! could happen because the PDF allows condensation in subsaturated conditions - DQI = 0.0 - end if - end if - - if (DQALL .lt. 0.0) then !net evaporation. Water evaporates first regaardless of DEP - DQL = max(DQALL, -QLLS/DTIME) - DQI = max(DQALL - DQL, -QILS/DTIME) - end if - - if (DQALL .ne. 0.0) FQI=max(min(DQI/DQALL, 1.0), 0.0) - - end if !===== - - end subroutine Bergeron_iter - - - - !============================================================================= - ! Subroutine Pfreezing: calculates the probability of finding a supersaturated parcel in the grid cell - !SC_ICE is the effective freezing point for ice (Barahona & Nenes. 2009) - ! Modified 02/19/15. in situ nucleation only occurs in the non_convective part of the grid cell - - - subroutine Pfreezing ( & - PDFFLAG , & - ALPHA , & - PL , & - TE , & - QV , & - QCl , & - QAl , & - QCi , & - QAi , & - SC_ICE , & - CF , & - AF , & - PF ) - - - - integer, intent(IN) :: PDFFLAG - real , intent(in) :: PL,ALPHA, QV, SC_ICE, AF, TE, & - QCl, QCi, QAl, QAi, CF - real , intent(out) :: PF - - real :: qt, QCx, QSn, tmpARR, CFALL, QVx, CFio, QA, QC, DQSx - real :: sigmaqt1, sigmaqt2, qsnx - - - QA = QAl + QAi - QC=QCl+QCi - - CFALL = AF - - if ( CFALL >= 1.0 ) then - PF = 0.0 - return - end if - - QSn = QSATIC( & - TE , & - PL*100.0 , DQ=DQSx ) !only with respect to ice - QSn = MAX( QSn , 1.0e-9 ) - - tmpARR = 0.0 - if ( CFALL < 0.99 ) then - tmpARR = 1./(1.0-CFALL) - end if - - QCx = QC*tmpARR - QVx = ( QV - QSn*CFALL )*tmpARR - - qt = QCx + QVx - - CFio=0.0 - - if(pdfflag.lt.2) then - sigmaqt1 = max(ALPHA, 0.01)*QSn - sigmaqt2 = max(ALPHA, 0.01)*QSn - elseif(pdfflag.eq.2) then - ! for triangular, symmetric: sigmaqt1 = sigmaqt2 = alpha*qsn (alpha is half width) - ! for triangular, skewed r : sigmaqt1 < sigmaqt2 - sigmaqt1 = ALPHA*QSn - sigmaqt2 = ALPHA*QSn - elseif(pdfflag .eq. 4) then !lognormal (sigma is dimmensionless) - sigmaqt1 = max(ALPHA/sqrt(3.0), 0.001) - endif - - qsnx= Qsn*SC_ICE - - call pdffrac(pdfflag,qt,sigmaqt1,sigmaqt2,qsnx,CFio) - - PF = CFio*(1.0-CFALL) - - PF=min(max(PF, 0.0), 0.999) - - - end subroutine Pfreezing - - - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!Instantaneous freezing of condensate!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - - subroutine meltfrz_inst ( & - IM,JM,LM , & - TE , & - QCL , & - QAL , & - QCI , & - QAI , & - NL , & - NI ) - - integer, intent(in) :: IM,JM,LM - real , intent(inout), dimension(:,:,:) :: TE,QCL,QCI, QAL, QAI, NI, NL - - real , dimension(im,jm,lm) :: dQil, DQmax, QLTOT, QITOT, dNil, FQA - - QITOT= QCI+QAI - QLTOT=QCL + QAL - FQA = 0.0 - - - where (QITOT+QLTOT .gt. 0.0) - FQA= (QAI+QAL)/(QITOT+QLTOT) - end where - - - dQil = 0.0 - dNil =0.0 - DQmax = 0.0 - - ! freeze liquid instantaneosly below -40 C - where( TE <= CLDPARAMS%T_ICE_ALL ) - DQmax = (CLDPARAMS%T_ICE_ALL - TE)*MAPL_CP/(MAPL_ALHS-MAPL_ALHL) - dQil = min(QLTOT , DQmax) - end where - - where ((dQil .le. DQmax) .and. (dQil .gt. 0.0)) - dNil = NL - end where - - where ((dQil .gt. DQmax) .and. (dQil .gt. 0.0)) - dNil = NL*DQmax/dQil - end where - - dQil = max( 0., dQil ) - QITOT = max(QITOT + dQil, 0.0) - QLTOT= max(QLTOT - dQil, 0.0) - NL = NL - dNil - NI = NI + dNil - TE = TE + (MAPL_ALHS-MAPL_ALHL)*dQil/MAPL_CP - - dQil = 0.0 - dNil =0.0 - DQmax = 0.0 - - ! melt ice instantly above 0^C - where( TE > T_ICE_MAX ) - DQmax = (TE-T_ICE_MAX) *MAPL_CP/(MAPL_ALHS-MAPL_ALHL) - dQil = min(QITOT, DQmax) - endwhere - - where ((dQil .le. DQmax) .and. (dQil .gt. 0.0)) - dNil = NI - end where - where ((dQil .gt. DQmax) .and. (dQil .gt. 0.0)) - dNil = NI*DQmax/dQil - end where - dQil = max( 0., dQil ) - QLTOT = max(QLTOT+ dQil, 0.) - QITOT = max(QITOT - dQil, 0.) - NL = NL + dNil - NI = NI - dNil - - TE = TE - (MAPL_ALHS-MAPL_ALHL)*dQil/MAPL_CP - - QCI = QITOT*(1.0-FQA) - QAI = QITOT*FQA - QCL = QLTOT*(1.0-FQA) - QAL = QLTOT*FQA - - end subroutine meltfrz_inst - - - - - !C======================================================================= - !C - !C *** REAL FUNCTION erf (overwrites previous versions) - !C *** THIS SUBROUTINE CALCULATES THE ERROR FUNCTION USING A - !C *** POLYNOMIAL APPROXIMATION - !C - !C======================================================================= - !C - REAL FUNCTION erf_app(x) - REAL :: x - REAL*8:: AA(4), axx, y - DATA AA /0.278393d0,0.230389d0,0.000972d0,0.078108d0/ - - y = dabs(dble(x)) - axx = 1.d0 + y*(AA(1)+y*(AA(2)+y*(AA(3)+y*AA(4)))) - axx = axx*axx - axx = axx*axx - axx = 1.d0 - (1.d0/axx) - if(x.le.0.) then - erf_app = sngl(-axx) - else - erf_app = sngl(axx) - endif - RETURN - END FUNCTION erf_app - - -end module cldmacro diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/cldwat2m_micro.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/cldwat2m_micro.F90 index 20b94342d..c09bfa3fb 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/cldwat2m_micro.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/cldwat2m_micro.F90 @@ -206,7 +206,7 @@ subroutine ini_micro(micro_mg_dcs, micro_mg_berg_eff_factor_in, & #ifndef GEOS5 use cloud_fraction, only: cldfrc_getparams #endif - real(r8), intent(in) :: QCVAR_ + real, intent(in) :: QCVAR_ integer k @@ -221,8 +221,6 @@ subroutine ini_micro(micro_mg_dcs, micro_mg_berg_eff_factor_in, & logical :: history_microphysics ! output variables for microphysics diagnostics package - - real(r8), intent(in) :: micro_mg_berg_eff_factor_in ! berg efficiency factor logical, intent(in) :: nccons_in logical, intent(in) :: nicons_in @@ -432,7 +430,7 @@ end subroutine ini_micro subroutine set_qcvar (qcvar_) !!DONIF - real(r8), intent(in) :: qcvar_ + real, intent(in) :: qcvar_ qcvar = qcvar_ @@ -4944,9 +4942,11 @@ FUNCTION MUI_HEMP_L(lambda_) real(r8) :: MUI_HEMP_L REAL(r8), intent(in) :: lambda_ REAL(r8) :: TC, mui, lx - lx = lambda_*0.01 + + + lx = max(min(lambda_, lammaxi),lammini)*0.01 - mui=(0.008_r8*(lx**0.87_r8)) + mui=(0.008_r8*(lx**(0.87_r8))) MUI_HEMP_L=max(min(mui, 5.0_r8), 0.1_r8) @@ -4965,7 +4965,7 @@ FUNCTION gamma_incomp(muice, x) alfa=min(max(muice+1._r8, 1._r8), 20._r8) xog = log(alfa -0.3068_r8) - kg= 1.44818*(alfa**0.5357_r8) + kg= 1.44818*(alfa**(0.5357_r8)) auxx = max(min(kg*(log(x)-xog), 30._r8), -30._r8) gamma_incomp= 1._r8/(1._r8 +exp(-auxx)) gamma_incomp = max(gamma_incomp, 1.0e-20) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/micro_mg3_0.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/micro_mg3_0.F90 index b56105d29..ca5862459 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/micro_mg3_0.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/micro_mg3_0.F90 @@ -413,9 +413,8 @@ end subroutine micro_mg_init ! Written by Donifan Barahona -subroutine micro_mg_tend_interface ( DT_MICRO, SHAPE, ALPH_tmp, SCICE_tmp, FQA_tmp, & +subroutine micro_mg_tend_interface ( DT_MICRO, & ncol, LM, dt_moist, & - cnvfrc, srftype, & ter8, qvr8, & qcr8, qir8, & ncr8, nir8, & @@ -491,10 +490,7 @@ subroutine micro_mg_tend_interface ( DT_MICRO, SHAPE, ALPH_tmp, SCICE_tmp, FQA_t REAL, intent(in) :: DT_MICRO real(r8), intent(in) :: DT_MOIST - REAL, dimension(1,1:LM) :: SCICE_tmp, FQA_tmp, ALPH_tmp - INTEGER, intent(in) :: LM, shape, ncol - - real :: cnvfrc, srftype + INTEGER, intent(in) :: LM, ncol real(r8), dimension(1,1:LM) :: & ter8, qvr8, & qcr8, qir8, & @@ -909,9 +905,9 @@ subroutine accum_mg_tend(stage) precir8_accum = precir8_accum + precir8 -! effcr8_accum = effcr8_accum + effcr8 -! effc_fnr8_accum = effc_fnr8_accum +effc_fnr8 -! effir8_accum = effir8_accum + effir8 + !effcr8_accum = effcr8_accum + effcr8 + !effc_fnr8_accum = effc_fnr8_accum +effc_fnr8 + !effir8_accum = effir8_accum + effir8 !use the final size instad of the average effcr8_accum = effcr8 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOS_SurfaceGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOS_SurfaceGridComp.F90 index 191bd636e..0718f700a 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOS_SurfaceGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOS_SurfaceGridComp.F90 @@ -552,7 +552,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddImportSpec(GC, & SHORT_NAME = 'DRPARN', & - LONG_NAME = 'normalized_surface_downwelling_par_beam_flux', & + LONG_NAME = 'normalized_surface_downwelling_PAR_beam_flux', & UNITS = '1', & DIMS = MAPL_DimsHorzOnly, & VLOCATION = MAPL_VLocationNone, & @@ -561,7 +561,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddImportSpec(GC, & SHORT_NAME = 'DFPARN', & - LONG_NAME = 'normalized_surface_downwelling_par_diffuse_flux', & + LONG_NAME = 'normalized_surface_downwelling_PAR_diffuse_flux', & UNITS = '1', & DIMS = MAPL_DimsHorzOnly, & VLOCATION = MAPL_VLocationNone, & @@ -683,7 +683,7 @@ subroutine SetServices ( GC, RC ) ! !EXPORT STATE: call MAPL_AddExportSpec(GC, & - LONG_NAME = 'surface_albedo_for_visible_beam', & + LONG_NAME = 'surface_reflectivity_for_visible_beam', & UNITS = '1', & SHORT_NAME = 'ALBVR', & DIMS = MAPL_DimsHorzOnly, & @@ -692,7 +692,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'surface_albedo_for_visible_diffuse',& + LONG_NAME = 'surface_reflectivity_for_visible_diffuse',& UNITS = '1', & SHORT_NAME = 'ALBVF', & DIMS = MAPL_DimsHorzOnly, & @@ -701,7 +701,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'surface_albedo_for_nearinfrared_beam', & + LONG_NAME = 'surface_reflectivity_for_near_infrared_beam', & UNITS = '1', & SHORT_NAME = 'ALBNR', & DIMS = MAPL_DimsHorzOnly, & @@ -710,7 +710,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'surface_albedo_for_nearinfraed_diffuse', & + LONG_NAME = 'surface_reflectivity_for_near_infrared_diffuse', & UNITS = '1', & SHORT_NAME = 'ALBNF', & DIMS = MAPL_DimsHorzOnly, & @@ -766,7 +766,16 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'FRACI', & - LONG_NAME = 'ice_covered_fraction_of_tile', & + LONG_NAME = 'ice_covered_fraction_of_grid_cell', & + UNITS = '1', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'OFRACI', & + LONG_NAME = 'ice_covered_fraction_of_ocean_area',& UNITS = '1', & DIMS = MAPL_DimsHorzOnly, & VLOCATION = MAPL_VLocationNone, & @@ -938,7 +947,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'TSOIL1', & - LONG_NAME = 'soil_temperatures_layer_1' ,& + LONG_NAME = 'soil_temperature_layer_1' ,& UNITS = 'K', & DIMS = MAPL_DimsHorzOnly, & VLOCATION = MAPL_VLocationNone, & @@ -947,7 +956,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'TSOIL2', & - LONG_NAME = 'soil_temperatures_layer_2' ,& + LONG_NAME = 'soil_temperature_layer_2' ,& UNITS = 'K', & DIMS = MAPL_DimsHorzOnly, & VLOCATION = MAPL_VLocationNone, & @@ -956,7 +965,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'TSOIL3', & - LONG_NAME = 'soil_temperatures_layer_3' ,& + LONG_NAME = 'soil_temperature_layer_3' ,& UNITS = 'K', & DIMS = MAPL_DimsHorzOnly, & VLOCATION = MAPL_VLocationNone, & @@ -965,7 +974,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'TSOIL4', & - LONG_NAME = 'soil_temperatures_layer_4' ,& + LONG_NAME = 'soil_temperature_layer_4' ,& UNITS = 'K', & DIMS = MAPL_DimsHorzOnly, & VLOCATION = MAPL_VLocationNone, & @@ -974,7 +983,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'TSOIL5', & - LONG_NAME = 'soil_temperatures_layer_5' ,& + LONG_NAME = 'soil_temperature_layer_5' ,& UNITS = 'K', & DIMS = MAPL_DimsHorzOnly, & VLOCATION = MAPL_VLocationNone, & @@ -983,7 +992,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'TSOIL6', & - LONG_NAME = 'soil_temperatures_layer_6' ,& + LONG_NAME = 'soil_temperature_layer_6' ,& UNITS = 'K', & DIMS = MAPL_DimsHorzOnly, & VLOCATION = MAPL_VLocationNone, & @@ -992,7 +1001,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'fractional_area_of_land_snowcover',& + LONG_NAME = 'fractional_area_of_snow_on_land',& UNITS = '1' ,& SHORT_NAME = 'ASNOW' ,& DIMS = MAPL_DimsHorzOnly ,& @@ -1019,7 +1028,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'surface_temperature_of_snow',& + LONG_NAME = 'surface_temperature_of_snow_on_land',& UNITS = 'K' ,& SHORT_NAME = 'TPSNOW' ,& DIMS = MAPL_DimsHorzOnly ,& @@ -1046,7 +1055,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'surface_temperature_of_wilted_zone',& + LONG_NAME = 'surface_temperature_of_wilting_zone',& UNITS = 'K' ,& SHORT_NAME = 'TPWLT' ,& DIMS = MAPL_DimsHorzOnly ,& @@ -1100,7 +1109,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'surface_soil_wetness' ,& + LONG_NAME = 'soil_wetness_surface' ,& UNITS = '1' ,& SHORT_NAME = 'WET1' ,& DIMS = MAPL_DimsHorzOnly ,& @@ -1109,7 +1118,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'surface_soil_wetness_for_chem' ,& + LONG_NAME = 'soil_wetness_surface_for_chem' ,& UNITS = '1' ,& SHORT_NAME = 'WET1_FOR_CHEM' ,& DIMS = MAPL_DimsHorzOnly ,& @@ -1118,7 +1127,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'root_zone_soil_wetness' ,& + LONG_NAME = 'soil_wetness_rootzone' ,& UNITS = '1' ,& SHORT_NAME = 'WET2' ,& DIMS = MAPL_DimsHorzOnly ,& @@ -1127,7 +1136,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'ave_prof_soil_moisture' ,& + LONG_NAME = 'soil_wetness_profile' ,& UNITS = '1' ,& SHORT_NAME = 'WET3' ,& DIMS = MAPL_DimsHorzOnly ,& @@ -1136,7 +1145,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'water_surface_layer' ,& + LONG_NAME = 'soil_moisture_surface' ,& UNITS = 'm3 m-3' ,& SHORT_NAME = 'WCSF' ,& DIMS = MAPL_DimsHorzOnly ,& @@ -1145,7 +1154,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'water_root_zone' ,& + LONG_NAME = 'soil_moisture_rootzone' ,& UNITS = 'm3 m-3' ,& SHORT_NAME = 'WCRZ' ,& DIMS = MAPL_DimsHorzOnly ,& @@ -1154,7 +1163,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'water_profile' ,& + LONG_NAME = 'soil_moisture_profile' ,& UNITS = 'm3 m-3' ,& SHORT_NAME = 'WCPR' ,& DIMS = MAPL_DimsHorzOnly ,& @@ -1172,7 +1181,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'greenness_fraction' ,& + LONG_NAME = 'vegetation_greenness_fraction' ,& UNITS = '1' ,& SHORT_NAME = 'GRN' ,& DIMS = MAPL_DimsHorzOnly ,& @@ -1418,7 +1427,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'snow_depth_within_snow_covered_area_fraction' ,& + LONG_NAME = 'snow_depth_within_snow_covered_area_fraction_on_land' ,& UNITS = 'm' ,& SHORT_NAME = 'SNOWDP' ,& DIMS = MAPL_DimsHorzOnly ,& @@ -1546,6 +1555,24 @@ subroutine SetServices ( GC, RC ) RC=STATUS ) VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'ocean_icefall' ,& + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'ICEFOCN' ,& + DIMS = MAPL_DimsHorzOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'ocean_snow_and_icefall' ,& + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'SPTOTOCN' ,& + DIMS = MAPL_DimsHorzOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & LONG_NAME = 'ocean_rainfall' ,& UNITS = 'kg m-2 s-1' ,& @@ -1603,7 +1630,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'runoff_flux',& + LONG_NAME = 'runoff_total_flux' ,& UNITS = 'kg m-2 s-1' ,& SHORT_NAME = 'RUNOFF' ,& DIMS = MAPL_DimsHorzOnly ,& @@ -1693,7 +1720,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'baseflow_flux' ,& + LONG_NAME = 'baseflow_flux_land' ,& UNITS = 'kg m-2 s-1' ,& SHORT_NAME = 'BASEFLOW' ,& DIMS = MAPL_DimsHorzOnly ,& @@ -1712,7 +1739,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'EVLAND', & - LONG_NAME = 'Total_evapotranspiration_land', & + LONG_NAME = 'total_evapotranspiration_land', & UNITS = 'kg m-2 s-1', & DIMS = MAPL_DimsHorzOnly, & VLOCATION = MAPL_VLocationNone, & @@ -1739,7 +1766,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'DRPARLAND', & - LONG_NAME = 'surface_downwelling_par_beam_flux', & + LONG_NAME = 'surface_downwelling_PAR_beam_flux', & UNITS = 'W m-2', & DIMS = MAPL_DimsHorzOnly, & VLOCATION = MAPL_VLocationNone, & @@ -1748,7 +1775,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'DFPARLAND', & - LONG_NAME = 'surface_downwelling_par_diffuse_flux', & + LONG_NAME = 'surface_downwelling_PAR_diffuse_flux', & UNITS = 'W m-2', & DIMS = MAPL_DimsHorzOnly, & VLOCATION = MAPL_VLocationNone, & @@ -1793,7 +1820,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'SWNETSNOW', & - LONG_NAME = 'Net_shortwave_snow', & + LONG_NAME = 'Net_shortwave_flux_snow', & UNITS = 'W m-2', & DIMS = MAPL_DimsHorzOnly, & VLOCATION = MAPL_VLocationNone, & @@ -1820,7 +1847,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'GHSNOW', & - LONG_NAME = 'Ground_heating_snow', & + LONG_NAME = 'Ground_heating_flux_snow', & UNITS = 'W m-2', & DIMS = MAPL_DimsHorzOnly, & VLOCATION = MAPL_VLocationNone, & @@ -1847,7 +1874,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'SWLAND', & - LONG_NAME = 'Net_shortwave_land', & + LONG_NAME = 'Net_shortwave_flux_land', & UNITS = 'W m-2', & DIMS = MAPL_DimsHorzOnly, & VLOCATION = MAPL_VLocationNone, & @@ -1856,7 +1883,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'SWDOWNLAND', & - LONG_NAME = 'Incident_shortwave_land', & + LONG_NAME = 'Incident_shortwave_flux_land', & UNITS = 'W m-2', & DIMS = MAPL_DimsHorzOnly, & VLOCATION = MAPL_VLocationNone, & @@ -1865,7 +1892,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'LWLAND', & - LONG_NAME = 'Net_longwave_land', & + LONG_NAME = 'Net_longwave_flux_land', & UNITS = 'W m-2', & DIMS = MAPL_DimsHorzOnly, & VLOCATION = MAPL_VLocationNone, & @@ -1874,7 +1901,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'GHLAND', & - LONG_NAME = 'Ground_heating_land', & + LONG_NAME = 'Ground_heating_flux_land', & UNITS = 'W m-2', & DIMS = MAPL_DimsHorzOnly, & VLOCATION = MAPL_VLocationNone, & @@ -1883,7 +1910,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'GHTSKIN', & - LONG_NAME = 'Ground_heating_for_skin_temp',& + LONG_NAME = 'Ground_heating_flux_for_skin_temp',& UNITS = 'W m-2', & DIMS = MAPL_DimsHorzOnly, & VLOCATION = MAPL_VLocationNone, & @@ -1910,7 +1937,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'TWLAND', & - LONG_NAME = 'Avail_water_storage_land', & + LONG_NAME = 'total_water_storage_land', & UNITS = 'kg m-2', & DIMS = MAPL_DimsHorzOnly, & VLOCATION = MAPL_VLocationNone, & @@ -2395,7 +2422,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'interception_reservoir_capac', & + LONG_NAME = 'vegetation_interception_water_storage', & UNITS = 'kg m-2', & SHORT_NAME = 'CAPAC', & DIMS = MAPL_DimsHorzOnly, & @@ -3343,7 +3370,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddInternalSpec(GC, & SHORT_NAME = 'TS', & - LONG_NAME = 'surface_skin_temperature', & + LONG_NAME = 'surface_temperature', & UNITS = 'K', & FriendlyTO = trim(COMP_NAME), & DIMS = MAPL_DimsHorzOnly, & @@ -5384,6 +5411,7 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) real, pointer, dimension(:,:) :: LST => NULL() real, pointer, dimension(:,:) :: FRI => NULL() + real, pointer, dimension(:,:) :: OFRI => NULL() real, pointer, dimension(:,:) :: EMISS => NULL() real, pointer, dimension(:,:) :: ALBVR => NULL() real, pointer, dimension(:,:) :: ALBVF => NULL() @@ -5472,6 +5500,8 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) real, pointer, dimension(:,:) :: LWNDICE => NULL() real, pointer, dimension(:,:) :: SWNDICE => NULL() real, pointer, dimension(:,:) :: SNOWOCN => NULL() + real, pointer, dimension(:,:) :: ICEFOCN => NULL() + real, pointer, dimension(:,:) :: SPTOTOCN => NULL() real, pointer, dimension(:,:) :: RAINOCN => NULL() real, pointer, dimension(:,:) :: TSKINW => NULL() real, pointer, dimension(:,:) :: TSKINICE => NULL() @@ -5738,6 +5768,7 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) real, pointer, dimension(:) :: LSTTILE => NULL() real, pointer, dimension(:) :: FRTILE => NULL() + real, pointer, dimension(:) :: OFRTILE => NULL() real, pointer, dimension(:) :: EMISSTILE => NULL() real, pointer, dimension(:) :: ALBVRTILE => NULL() real, pointer, dimension(:) :: ALBVFTILE => NULL() @@ -5789,6 +5820,8 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) real, pointer, dimension(:) :: LWNDICETILE => NULL() real, pointer, dimension(:) :: SWNDICETILE => NULL() real, pointer, dimension(:) :: SNOWOCNTILE => NULL() + real, pointer, dimension(:) :: ICEFOCNTILE => NULL() + real, pointer, dimension(:) ::SPTOTOCNTILE => NULL() real, pointer, dimension(:) :: RAINOCNTILE => NULL() real, pointer, dimension(:) :: TSKINWTILE => NULL() real, pointer, dimension(:) :: TSKINICETILE => NULL() @@ -6041,6 +6074,7 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) real, allocatable :: PRECSUM(:,:) character(len=ESMF_MAXPATHLEN) :: SolCycFileName logical :: PersistSolar + logical :: allocateRunoff !============================================================================= @@ -6389,8 +6423,8 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetPointer(EXPORT, ICE , 'ICE' , alloc=.true., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, FRZR, 'FRZR', alloc=.true., RC=STATUS); VERIFY_(STATUS) -! These are the precips exported by moist -!---------------------------------------- +! These are the precips imported from moist +!------------------------------------------ call MAPL_GetPointer(IMPORT, PCU , 'PCU' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, PLS , 'PLS' , RC=STATUS); VERIFY_(STATUS) @@ -6425,7 +6459,7 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) ! call MAPL_CFIORead( PRECIP_FILE, CurrentTime, Bundle, RC=STATUS) ! VERIFY_(STATUS) - call MAPL_read_bundle( Bundle,PRECIP_FILE, CurrentTime, RC=status) + call MAPL_read_bundle( Bundle, PRECIP_FILE, CurrentTime, regrid_method=REGRID_METHOD_CONSERVE, RC=status) VERIFY_(STATUS) call ESMFL_BundleGetPointerToData(Bundle,'PRECTOT',PTTe, RC=STATUS) VERIFY_(STATUS) @@ -6451,8 +6485,12 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) allocate( PRECSUM(IM,JM), stat=STATUS ) VERIFY_(STATUS) - PRECSUM = RCU+RLS+SNO+ICE+FRZR - + ! PRECSUM = uncorrected total precip + ! PTTe = total precip from file + + PRECSUM = RCU+RLS+SNO+ICE ! do *not* add FRZR, which is liquid not solid and (probably) incl. in RCU+RLS + ! see comment re. FRZR in GEOS_CatchGridComp.F90 by reichle, 6/6/2025 + where (PTTe == MAPL_UNDEF) RCU = PCU RLS = PLS @@ -6696,6 +6734,8 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetPointer(EXPORT , LWNDICE , 'LWNDICE' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT , SWNDICE , 'SWNDICE' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT , SNOWOCN , 'SNOWOCN' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT , ICEFOCN , 'ICEFOCN' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT , SPTOTOCN , 'SPTOTOCN' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT , RAINOCN , 'RAINOCN' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT , TSKINW , 'TSKINW' , alloc=.true., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT , TSKINICE , 'TSKINICE' , RC=STATUS); VERIFY_(STATUS) @@ -6879,6 +6919,10 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetPointer(EXPORT , FRI , 'FRACI' , alloc=associated(LWI) , rC=STATUS) VERIFY_(STATUS) +! Not sure about why alloc of FRI depends on LWI, but copy the logic anyway + call MAPL_GetPointer(EXPORT , OFRI , 'OFRACI' , alloc=associated(LWI) , rC=STATUS) + VERIFY_(STATUS) + ! FRI = max(min(FRI,1.0),0.0) ! RiverRouting: force allocations of RUNOFF from continental components, @@ -7249,6 +7293,7 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) call MKTILE(ALBNF ,ALBNFTILE ,NT,RC=STATUS); VERIFY_(STATUS) call MKTILE(EMISS ,EMISSTILE ,NT,RC=STATUS); VERIFY_(STATUS) call MKTILE(FRI ,FRTILE ,NT,RC=STATUS); VERIFY_(STATUS) + call MKTILE(OFRI ,OFRTILE ,NT,RC=STATUS); VERIFY_(STATUS) call MKTILE(TSOIL1 ,TSOIL1TILE ,NT,RC=STATUS); VERIFY_(STATUS) call MKTILE(TSOIL2 ,TSOIL2TILE ,NT,RC=STATUS); VERIFY_(STATUS) call MKTILE(TSOIL3 ,TSOIL3TILE ,NT,RC=STATUS); VERIFY_(STATUS) @@ -7293,6 +7338,8 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) call MKTILE(LWNDICE ,LWNDICETILE ,NT,RC=STATUS); VERIFY_(STATUS) call MKTILE(SWNDICE ,SWNDICETILE ,NT,RC=STATUS); VERIFY_(STATUS) call MKTILE(SNOWOCN ,SNOWOCNTILE ,NT,RC=STATUS); VERIFY_(STATUS) + call MKTILE(ICEFOCN ,ICEFOCNTILE ,NT,RC=STATUS); VERIFY_(STATUS) + call MKTILE(SPTOTOCN ,SPTOTOCNTILE ,NT,RC=STATUS); VERIFY_(STATUS) call MKTILE(RAINOCN ,RAINOCNTILE ,NT,RC=STATUS); VERIFY_(STATUS) call MKTILE(TSKINW, TSKINWTILE ,NT,RC=STATUS); VERIFY_(STATUS) call MKTILE(TSKINICE, TSKINICETILE ,NT,RC=STATUS); VERIFY_(STATUS) @@ -7350,12 +7397,19 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) call MKTILE(LWNDSRF ,LWNDSRFTILE ,NT,RC=STATUS); VERIFY_(STATUS) call MKTILE(SWNDSRF ,SWNDSRFTILE ,NT,RC=STATUS); VERIFY_(STATUS) + allocateRunoff = .false. + if (associated(RUNOFF)) allocateRunoff = .true. + if (associated(SURF_INTERNAL_STATE%RoutingType) .or. DO_DATA_ATM4OCN) then ! routing file exists or we run DataAtm allocate(DISCHARGETILE(NT),stat=STATUS); VERIFY_(STATUS) DISCHARGETILE=MAPL_Undef + allocateRunoff = .true. + end if + if (allocateRunoff) then allocate(RUNOFFTILE(NT),stat=STATUS); VERIFY_(STATUS) - RUNOFFTILE=MAPL_Undef + RUNOFFTILE = 0.0 end if + call MKTILE(RUNSURF ,RUNSURFTILE ,NT,RC=STATUS); VERIFY_(STATUS) call MKTILE(BASEFLOW,BASEFLOWTILE,NT,RC=STATUS); VERIFY_(STATUS) call MKTILE(ACCUM ,ACCUMTILE ,NT,RC=STATUS); VERIFY_(STATUS) @@ -7492,13 +7546,12 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) end if - FRTILE = 0.0 + FRTILE = 0.0 + OFRTILE = MAPL_UNDEF ! Cycle through all continental children (skip ocean), ! collecting RUNOFFTILE exports. - if (associated(RUNOFFTILE)) RUNOFFTILE = 0.0 - do I = 1, NUM_CHILDREN if (I == OCEAN) cycle call DOTYPE(I,RC=STATUS) @@ -7624,7 +7677,7 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) VERIFY_(STATUS) if(PRECIP_FILE /= "null") then - TMPTILE = PCUTILE + PLSTILE + SNOFLTILE + ICEFLTILE + FRZRFLTILE + TMPTILE = PCUTILE + PLSTILE + SNOFLTILE + ICEFLTILE ! do *not* add FRZR, which is liquid not solid and (probably) incl. in PCUTILE+PCSTILE call MAPL_LocStreamTransform( LOCSTREAM, PRECTOT, TMPTILE, RC=STATUS) VERIFY_(STATUS) else @@ -7677,7 +7730,11 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) VERIFY_(STATUS) endif if(associated( FRI )) then - call MAPL_LocStreamTransform( LOCSTREAM, FRI , FRTILE, RC=STATUS) + call MAPL_LocStreamTransform( LOCSTREAM, FRI , FRTILE, RC=STATUS) + VERIFY_(STATUS) + endif + if(associated( OFRI )) then + call MAPL_LocStreamTransform( LOCSTREAM, OFRI , OFRTILE, RC=STATUS) VERIFY_(STATUS) endif if(associated(TSOIL1)) then @@ -8096,6 +8153,16 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) VERIFY_(STATUS) endif + if(associated( ICEFOCN)) then + call MAPL_LocStreamTransform( LOCSTREAM, ICEFOCN, ICEFOCNTILE, RC=STATUS) + VERIFY_(STATUS) + endif + + if(associated( SPTOTOCN)) then + call MAPL_LocStreamTransform( LOCSTREAM, SPTOTOCN, SPTOTOCNTILE, RC=STATUS) + VERIFY_(STATUS) + endif + if(associated( EVAPOU)) then call MAPL_LocStreamTransform( LOCSTREAM, EVAPOU, EVAPOUTILE, RC=STATUS) @@ -8864,6 +8931,8 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) if(associated(LWNDICETILE )) deallocate(LWNDICETILE ) if(associated(SWNDICETILE )) deallocate(SWNDICETILE ) if(associated(SNOWOCNTILE )) deallocate(SNOWOCNTILE ) + if(associated(ICEFOCNTILE )) deallocate(ICEFOCNTILE ) + if(associated(SPTOTOCNTILE )) deallocate(SPTOTOCNTILE ) if(associated(RAINOCNTILE )) deallocate(RAINOCNTILE ) if(associated(TSKINWTILE )) deallocate(TSKINWTILE ) if(associated(TSKINICETILE )) deallocate(TSKINICETILE ) @@ -9030,6 +9099,7 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) if(associated(ALBVRTILE )) deallocate(ALBVRTILE) if(associated(EMISSTILE )) deallocate(EMISSTILE) if(associated(FRTILE )) deallocate(FRTILE ) + if(associated(OFRTILE )) deallocate(OFRTILE ) if(associated(DUDP)) deallocate( DUDP ) if(associated(DUWT)) deallocate( DUWT ) @@ -9300,6 +9370,9 @@ subroutine DOTYPE(type,RC) VERIFY_(STATUS) call MAPL_GetPointer(GEX(type), dum, 'FRACI' , ALLOC=associated( FRTILE ), notFoundOK=.true., RC=STATUS) VERIFY_(STATUS) +! in case FRACI removed in future + call MAPL_GetPointer(GEX(type), dum, 'FRACI' , ALLOC=associated( OFRTILE ), notFoundOK=.true., RC=STATUS) + VERIFY_(STATUS) call MAPL_GetPointer(GEX(type), dum, 'RDU001' , ALLOC=associated(RDU001TILE ), notFoundOK=.true., RC=STATUS) VERIFY_(STATUS) call MAPL_GetPointer(GEX(type), dum, 'RDU002' , ALLOC=associated(RDU002TILE ), notFoundOK=.true., RC=STATUS) @@ -9448,6 +9521,10 @@ subroutine DOTYPE(type,RC) VERIFY_(STATUS) call MAPL_GetPointer(GEX(type), dum, 'SNOWOCN' , ALLOC=associated(SNOWOCNTILE ), notFoundOK=.true., RC=STATUS) VERIFY_(STATUS) + call MAPL_GetPointer(GEX(type), dum, 'ICEFOCN' , ALLOC=associated(ICEFOCNTILE ), notFoundOK=.true., RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(GEX(type), dum, 'SPTOTOCN', ALLOC=associated(SPTOTOCNTILE), notFoundOK=.true., RC=STATUS) + VERIFY_(STATUS) call MAPL_GetPointer(GEX(type), dum, 'TSKINW', ALLOC=associated(TSKINWTILE ), notFoundOK=.true., RC=STATUS) VERIFY_(STATUS) call MAPL_GetPointer(GEX(type), dum, 'TSKINICE', ALLOC=associated(TSKINICETILE ), notFoundOK=.true., RC=STATUS) @@ -9680,6 +9757,10 @@ subroutine DOTYPE(type,RC) call FILLOUT_TILE(GEX(type), 'FRACI', FRTILE, XFORM, RC=STATUS) VERIFY_(STATUS) end if + if(associated( OFRTILE)) then + call FILLOUT_TILE(GEX(type), 'FRACI', OFRTILE, XFORM, RC=STATUS) + VERIFY_(STATUS) + end if if(associated(TSOIL1TILE)) then call FILLOUT_TILE(GEX(type), 'TP1', TSOIL1TILE, XFORM, RC=STATUS) VERIFY_(STATUS) @@ -10174,6 +10255,14 @@ subroutine DOTYPE(type,RC) call FILLOUT_TILE(GEX(type), 'SNOWOCN', SNOWOCNTILE, XFORM, RC=STATUS) VERIFY_(STATUS) end if + if(associated(ICEFOCNTILE)) then + call FILLOUT_TILE(GEX(type), 'ICEFOCN', ICEFOCNTILE, XFORM, RC=STATUS) + VERIFY_(STATUS) + end if + if(associated(SPTOTOCNTILE)) then + call FILLOUT_TILE(GEX(type), 'SPTOTOCN', SPTOTOCNTILE,XFORM, RC=STATUS) + VERIFY_(STATUS) + end if if(associated(HLWUPTILE)) then call FILLOUT_TILE(GEX(type), 'HLWUP', HLWUPTILE, XFORM, RC=STATUS) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSlake_GridComp/GEOS_LakeGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSlake_GridComp/GEOS_LakeGridComp.F90 index 564beefe7..8af0fc45a 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSlake_GridComp/GEOS_LakeGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSlake_GridComp/GEOS_LakeGridComp.F90 @@ -137,7 +137,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'surface_albedo_for_visible_beam', & + LONG_NAME = 'surface_reflectivity_for_visible_beam', & UNITS = '1', & SHORT_NAME = 'ALBVR', & DIMS = MAPL_DimsTileOnly, & @@ -146,7 +146,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'surface_albedo_for_visible_diffuse',& + LONG_NAME = 'surface_reflectivity_for_visible_diffuse',& UNITS = '1', & SHORT_NAME = 'ALBVF', & DIMS = MAPL_DimsTileOnly, & @@ -155,7 +155,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'surface_albedo_for_near_infrared_beam', & + LONG_NAME = 'surface_reflectivity_for_near_infrared_beam', & UNITS = '1', & SHORT_NAME = 'ALBNR', & DIMS = MAPL_DimsTileOnly, & @@ -164,7 +164,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'surface_albedo_for_near_infrared_diffuse', & + LONG_NAME = 'surface_reflectivity_for_near_infrared_diffuse', & UNITS = '1', & SHORT_NAME = 'ALBNF', & DIMS = MAPL_DimsTileOnly, & @@ -192,7 +192,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'runoff_flux',& + LONG_NAME = 'runoff_total_flux' ,& UNITS = 'kg m-2 s-1' ,& SHORT_NAME = 'RUNOFF' ,& DIMS = MAPL_DimsTileOnly ,& diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOS_CatchCNGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOS_CatchCNGridComp.F90 index 96d970073..05b20561d 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOS_CatchCNGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOS_CatchCNGridComp.F90 @@ -245,7 +245,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddImportSpec(GC ,& - LONG_NAME = 'surface_downwelling_par_beam_flux',& + LONG_NAME = 'surface_downwelling_PAR_beam_flux',& UNITS = 'W m-2' ,& SHORT_NAME = 'DRPAR' ,& DIMS = MAPL_DimsTileOnly ,& @@ -254,7 +254,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddImportSpec(GC ,& - LONG_NAME = 'surface_downwelling_par_diffuse_flux',& + LONG_NAME = 'surface_downwelling_PAR_diffuse_flux',& UNITS = 'W m-2' ,& SHORT_NAME = 'DFPAR' ,& DIMS = MAPL_DimsTileOnly ,& @@ -346,7 +346,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddImportSpec(GC ,& - LONG_NAME = 'greeness_fraction' ,& + LONG_NAME = 'vegetation_greenness_fraction',& UNITS = '1' ,& SHORT_NAME = 'GRN' ,& DIMS = MAPL_DimsTileOnly ,& diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/GEOS_CatchCNCLM40GridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/GEOS_CatchCNCLM40GridComp.F90 index 775e2de57..cbebc22a3 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/GEOS_CatchCNCLM40GridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/GEOS_CatchCNCLM40GridComp.F90 @@ -344,7 +344,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddImportSpec(GC ,& - LONG_NAME = 'surface_downwelling_par_beam_flux',& + LONG_NAME = 'surface_downwelling_PAR_beam_flux',& UNITS = 'W m-2' ,& SHORT_NAME = 'DRPAR' ,& DIMS = MAPL_DimsTileOnly ,& @@ -353,7 +353,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddImportSpec(GC ,& - LONG_NAME = 'surface_downwelling_par_diffuse_flux',& + LONG_NAME = 'surface_downwelling_PAR_diffuse_flux',& UNITS = 'W m-2' ,& SHORT_NAME = 'DFPAR' ,& DIMS = MAPL_DimsTileOnly ,& @@ -445,7 +445,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddImportSpec(GC ,& - LONG_NAME = 'greeness_fraction' ,& + LONG_NAME = 'vegetation_greenness_fraction' ,& UNITS = '1' ,& SHORT_NAME = 'GRN' ,& DIMS = MAPL_DimsTileOnly ,& @@ -1161,7 +1161,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddInternalSpec(GC ,& - LONG_NAME = 'interception_reservoir_capac',& + LONG_NAME = 'vegetation_interception_water_storage',& UNITS = 'kg m-2' ,& SHORT_NAME = 'CAPAC' ,& FRIENDLYTO = trim(COMP_NAME) ,& @@ -1381,7 +1381,7 @@ subroutine SetServices ( GC, RC ) if (SNOW_ALBEDO_INFO == 1) then call MAPL_AddInternalSpec(GC ,& - LONG_NAME = 'effective_snow_albedo' ,& + LONG_NAME = 'effective_snow_reflectivity',& UNITS = '1' ,& SHORT_NAME = 'SNOWALB' ,& FRIENDLYTO = trim(COMP_NAME) ,& @@ -2172,7 +2172,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'runoff_flux' ,& + LONG_NAME = 'runoff_total_flux' ,& UNITS = 'kg m-2 s-1' ,& SHORT_NAME = 'RUNOFF' ,& DIMS = MAPL_DimsTileOnly ,& @@ -2208,7 +2208,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'snow_ice_evaporation_energy_flux',& + LONG_NAME = 'snow_ice_evaporation_energy_flux_on_land',& UNITS = 'W m-2' ,& SHORT_NAME = 'EVPICE' ,& DIMS = MAPL_DimsTileOnly ,& @@ -2227,7 +2227,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'totoal soil moisture' ,& + LONG_NAME = 'total_soil_moisture' ,& UNITS = 'kg m-2' ,& SHORT_NAME = 'WATSOI' ,& DIMS = MAPL_DimsTileOnly ,& @@ -2253,7 +2253,7 @@ subroutine SetServices ( GC, RC ) RC=STATUS ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'baseflow_flux' ,& + LONG_NAME = 'baseflow_flux_land' ,& UNITS = 'kg m-2 s-1' ,& SHORT_NAME = 'BASEFLOW' ,& DIMS = MAPL_DimsTileOnly ,& @@ -2389,7 +2389,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'ave_catchment_temp_incl_snw',& + LONG_NAME = 'surface_temperature_of_land_incl_snow',& UNITS = 'K' ,& SHORT_NAME = 'TPSURF' ,& DIMS = MAPL_DimsTileOnly ,& @@ -2398,7 +2398,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'temperature_top_snow_layer',& + LONG_NAME = 'surface_temperature_of_snow_on_land',& UNITS = 'K' ,& SHORT_NAME = 'TPSNOW' ,& DIMS = MAPL_DimsTileOnly ,& @@ -2407,7 +2407,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'temperature_unsaturated_zone',& + LONG_NAME = 'surface_temperature_of_unsaturated_zone',& UNITS = 'K' ,& SHORT_NAME = 'TPUNST' ,& DIMS = MAPL_DimsTileOnly ,& @@ -2416,7 +2416,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'temperature_saturated_zone',& + LONG_NAME = 'surface_temperature_of_saturated_zone',& UNITS = 'K' ,& SHORT_NAME = 'TPSAT' ,& DIMS = MAPL_DimsTileOnly ,& @@ -2425,7 +2425,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'temperature_wilted_zone' ,& + LONG_NAME = 'surface_temperature_of_wilting_zone' ,& UNITS = 'K' ,& SHORT_NAME = 'TPWLT' ,& DIMS = MAPL_DimsTileOnly ,& @@ -2434,7 +2434,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'fractional_area_of_land_snowcover',& + LONG_NAME = 'fractional_area_of_snow_on_land',& UNITS = '1' ,& SHORT_NAME = 'ASNOW' ,& DIMS = MAPL_DimsTileOnly ,& @@ -2497,7 +2497,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'snow_depth_within_snow_covered_area_fraction' ,& + LONG_NAME = 'snow_depth_within_snow_covered_area_fraction_on_land' ,& UNITS = 'm' ,& SHORT_NAME = 'SNOWDP' ,& DIMS = MAPL_DimsTileOnly ,& @@ -2506,7 +2506,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'surface_soil_wetness' ,& + LONG_NAME = 'soil_wetness_surface' ,& UNITS = '1' ,& SHORT_NAME = 'WET1' ,& DIMS = MAPL_DimsTileOnly ,& @@ -2515,7 +2515,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'root_zone_soil_wetness' ,& + LONG_NAME = 'soil_wetness_rootzone' ,& UNITS = '1' ,& SHORT_NAME = 'WET2' ,& DIMS = MAPL_DimsTileOnly ,& @@ -2524,7 +2524,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'ave_prof_soil__moisture' ,& + LONG_NAME = 'soil_wetness_profile' ,& UNITS = '1' ,& SHORT_NAME = 'WET3' ,& DIMS = MAPL_DimsTileOnly ,& @@ -2533,7 +2533,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'water_surface_layer' ,& + LONG_NAME = 'soil_moisture_surface' ,& UNITS = 'm3 m-3' ,& SHORT_NAME = 'WCSF' ,& DIMS = MAPL_DimsTileOnly ,& @@ -2542,7 +2542,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'water_root_zone' ,& + LONG_NAME = 'soil_moisture_rootzone' ,& UNITS = 'm3 m-3' ,& SHORT_NAME = 'WCRZ' ,& DIMS = MAPL_DimsTileOnly ,& @@ -2551,7 +2551,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'water_ave_prof' ,& + LONG_NAME = 'soil_moisture_profile' ,& UNITS = 'm3 m-3' ,& SHORT_NAME = 'WCPR' ,& DIMS = MAPL_DimsTileOnly ,& @@ -2560,7 +2560,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'soil_temperatures_layer_1' ,& + LONG_NAME = 'soil_temperature_layer_1' ,& UNITS = 'K' ,& ! units now K, rreichle & borescan, 6 Nov 2020 SHORT_NAME = 'TP1' ,& DIMS = MAPL_DimsTileOnly ,& @@ -2569,7 +2569,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'soil_temperatures_layer_2' ,& + LONG_NAME = 'soil_temperature_layer_2' ,& UNITS = 'K' ,& ! units now K, rreichle & borescan, 6 Nov 2020 SHORT_NAME = 'TP2' ,& DIMS = MAPL_DimsTileOnly ,& @@ -2578,7 +2578,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'soil_temperatures_layer_3' ,& + LONG_NAME = 'soil_temperature_layer_3' ,& UNITS = 'K' ,& ! units now K, rreichle & borescan, 6 Nov 2020 SHORT_NAME = 'TP3' ,& DIMS = MAPL_DimsTileOnly ,& @@ -2587,7 +2587,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'soil_temperatures_layer_4' ,& + LONG_NAME = 'soil_temperature_layer_4' ,& UNITS = 'K' ,& ! units now K, rreichle & borescan, 6 Nov 2020 SHORT_NAME = 'TP4' ,& DIMS = MAPL_DimsTileOnly ,& @@ -2596,7 +2596,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'soil_temperatures_layer_5' ,& + LONG_NAME = 'soil_temperature_layer_5' ,& UNITS = 'K' ,& ! units now K, rreichle & borescan, 6 Nov 2020 SHORT_NAME = 'TP5' ,& DIMS = MAPL_DimsTileOnly ,& @@ -2605,7 +2605,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'soil_temperatures_layer_6' ,& + LONG_NAME = 'soil_temperature_layer_6' ,& UNITS = 'K' ,& ! units now K, rreichle & borescan, 6 Nov 2020 SHORT_NAME = 'TP6' ,& DIMS = MAPL_DimsTileOnly ,& @@ -2623,7 +2623,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'surface_albedo_visible_beam',& + LONG_NAME = 'surface_reflectivity_visible_beam',& UNITS = '1' ,& SHORT_NAME = 'ALBVR' ,& DIMS = MAPL_DimsTileOnly ,& @@ -2632,7 +2632,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'surface_albedo_visible_diffuse',& + LONG_NAME = 'surface_reflectivity_visible_diffuse',& UNITS = '1' ,& SHORT_NAME = 'ALBVF' ,& DIMS = MAPL_DimsTileOnly ,& @@ -2641,7 +2641,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'surface_albedo_near_infrared_beam',& + LONG_NAME = 'surface_reflectivity_near_infrared_beam',& UNITS = '1' ,& SHORT_NAME = 'ALBNR' ,& DIMS = MAPL_DimsTileOnly ,& @@ -2650,7 +2650,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'surface_albedo_near_infrared_diffuse',& + LONG_NAME = 'surface_reflectivity_near_infrared_diffuse',& UNITS = '1' ,& SHORT_NAME = 'ALBNF' ,& DIMS = MAPL_DimsTileOnly ,& @@ -2932,7 +2932,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'EVLAND', & - LONG_NAME = 'Evaporation_land', & + LONG_NAME = 'total_evapotranspiration_land', & UNITS = 'kg m-2 s-1', & DIMS = MAPL_DimsTileOnly, & VLOCATION = MAPL_VLocationNone, & @@ -2959,7 +2959,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'DRPARLAND', & - LONG_NAME = 'surface_downwelling_par_beam_flux', & + LONG_NAME = 'surface_downwelling_PAR_beam_flux', & UNITS = 'W m-2', & DIMS = MAPL_DimsTileOnly, & VLOCATION = MAPL_VLocationNone, & @@ -2968,7 +2968,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'DFPARLAND', & - LONG_NAME = 'surface_downwelling_par_diffuse_flux', & + LONG_NAME = 'surface_downwelling_PAR_diffuse_flux', & UNITS = 'W m-2', & DIMS = MAPL_DimsTileOnly, & VLOCATION = MAPL_VLocationNone, & @@ -2987,7 +2987,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'SWNETSNOW', & - LONG_NAME = 'Net_shortwave_snow', & + LONG_NAME = 'Net_shortwave_flux_snow', & UNITS = 'W m-2', & DIMS = MAPL_DimsTileOnly, & VLOCATION = MAPL_VLocationNone, & @@ -3071,7 +3071,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'SWLAND', & - LONG_NAME = 'Net_shortwave_land', & + LONG_NAME = 'Net_shortwave_flux_land', & UNITS = 'W m-2', & DIMS = MAPL_DimsTileOnly, & VLOCATION = MAPL_VLocationNone, & @@ -3080,7 +3080,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'SWDOWNLAND', & - LONG_NAME = 'Incident_shortwave_land', & + LONG_NAME = 'Incident_shortwave_flux_land', & UNITS = 'W m-2', & DIMS = MAPL_DimsTileOnly, & VLOCATION = MAPL_VLocationNone, & @@ -3090,7 +3090,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'LWLAND', & - LONG_NAME = 'Net_longwave_land', & + LONG_NAME = 'Net_longwave_flux_land', & UNITS = 'W m-2', & DIMS = MAPL_DimsTileOnly, & VLOCATION = MAPL_VLocationNone, & @@ -3100,7 +3100,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'GHLAND', & - LONG_NAME = 'Ground_heating_land', & + LONG_NAME = 'Ground_heating_flux_land', & UNITS = 'W m-2', & DIMS = MAPL_DimsTileOnly, & VLOCATION = MAPL_VLocationNone, & @@ -3109,7 +3109,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'GHTSKIN', & - LONG_NAME = 'Ground_heating_skin_temp', & + LONG_NAME = 'Ground_heating_flux_for_skin_temp_land', & UNITS = 'W m-2', & DIMS = MAPL_DimsTileOnly, & VLOCATION = MAPL_VLocationNone, & @@ -3128,7 +3128,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'TWLAND', & - LONG_NAME = 'Avail_water_storage_land', & + LONG_NAME = 'total_water_storage_land', & UNITS = 'kg m-2', & DIMS = MAPL_DimsTileOnly, & VLOCATION = MAPL_VLocationNone, & @@ -3174,7 +3174,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'SPLAND', & - LONG_NAME = 'rate_of_spurious_land_energy_source',& + LONG_NAME = 'rate_of_spurious_energy_source_land',& UNITS = 'W m-2', & DIMS = MAPL_DimsTileOnly, & VLOCATION = MAPL_VLocationNone, & @@ -3183,7 +3183,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'SPWATR', & - LONG_NAME = 'rate_of_spurious_land_water_source',& + LONG_NAME = 'rate_of_spurious_water_source_land',& UNITS = 'kg m-2 s-1', & DIMS = MAPL_DimsTileOnly, & VLOCATION = MAPL_VLocationNone, & @@ -3192,7 +3192,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'SPSNOW', & - LONG_NAME = 'rate_of_spurious_snow_energy',& + LONG_NAME = 'rate_of_spurious_snow_energy_source_land',& UNITS = 'W m-2', & DIMS = MAPL_DimsTileOnly, & VLOCATION = MAPL_VLocationNone, & @@ -3916,7 +3916,7 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) VERIFY_(STATUS) Iam=trim(COMP_NAME)//"::RUN1" - ! Get component's offline mode from its pvt internal state + ! Get component's offline mode from its private internal state call ESMF_UserCompGetInternalState(gc, 'CatchcnInternal', wrap, status) VERIFY_(status) catchcn_internal => wrap%ptr @@ -4481,7 +4481,6 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) type(ESMF_Alarm) :: ALARM integer :: IM,JM - integer :: incl_Louis_extra_derivs real :: SCALE4Z0 @@ -4506,8 +4505,6 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_Get(MAPL, RUNALARM=ALARM, RC=STATUS) VERIFY_(STATUS) - call MAPL_GetResource ( MAPL, incl_Louis_extra_derivs, Label="INCL_LOUIS_EXTRA_DERIVS:", DEFAULT=1, RC=STATUS) - VERIFY_(STATUS) call MAPL_GetResource ( MAPL, SCALE4Z0, Label="SCALE4Z0:", DEFAULT=0.5, RC=STATUS) VERIFY_(STATUS) @@ -5986,11 +5983,13 @@ subroutine Driver ( RC ) !--------------- GOSWIM IMPORTS FROM GOCART --------------- ! Initialization - RCONSTIT(:,:,:) = 0.0 - TOTDEPOS(:,:) = 0.0 - RMELT(:,:) = 0.0 + if (N_constit>0) then + RCONSTIT(:,:,:) = 0.0 + TOTDEPOS(:,:) = 0.0 + RMELT(:,:) = 0.0 + end if !------------------------------------------------------------------ - + ! Zero the light-absorbing aerosol (LAA) deposition rates from GOCART: select case (catchcn_internal%AEROSOL_DEPOSITION) @@ -6027,6 +6026,8 @@ subroutine Driver ( RC ) OCSD(:,:)=0. end select + + if (catchcn_internal%N_CONST_LAND4SNWALB /= 0) then ! Convert the dimentions for LAAs from GEOS_SurfGridComp.F90 to GEOS_LandIceGridComp.F90 ! Note: Explanations of each variable @@ -6066,8 +6067,6 @@ subroutine Driver ( RC ) ! --------------- GOSWIM PROGRNOSTICS --------------------------- - if (catchcn_internal%N_CONST_LAND4SNWALB /= 0) then - ! Conversion of the masses of the snow impurities ! Note: Explanations of each variable ! Number of snow layer is 15: N = 1-15 @@ -6153,7 +6152,7 @@ subroutine Driver ( RC ) ALWN(:,N) = -3.0*BLWN(:,N)*TC(:,N) BLWN(:,N) = 4.0*BLWN(:,N) end do - if(catchcn_internal%CHOOSEMOSFC==0 .and. incl_Louis_extra_derivs ==1) then + if(catchcn_internal%CHOOSEMOSFC==0 .and. catchcn_internal%MOSFC_EXTRA_DERIVS_OFFL_LAND==1) then do N=1,NUM_SUBTILES DEVSBT(:,N)=CQ(:,N)+max(0.0,-DCQ(:,N)*MAPL_VIREPS*TC(:,N)*(QC(:,N)-QA)) DEDTC(:,N) =max(0.0,-DCQ(:,N)*(1.+MAPL_VIREPS*QC(:,N))*(QC(:,N)-QA)) @@ -6192,8 +6191,20 @@ subroutine Driver ( RC ) ! get total solid precip ! -------------------------------------------------------------------------- - SLDTOT = SNO+ICE+FRZR + SLDTOT = SNO+ICE ! do *not* add FRZR (freezing rain) to solid precip, see comment below + ! FRZR (freezing rain) is rain that falls as super-cooled liquid water, which freezes upon + ! impact on a sufficiently cold surface. As such, FRZR is *not* solid precipitation + ! and should be considered rainfall. + ! + ! As of Jun 2025, FRZR is identical to 0 and can be ignored. Looking ahead, make sure to + ! account correctly for FRZR in the input precipitation variables. Once it's filled + ! with non-zero values, FRZR will (probably) be included in PLS+PCU. It is (probably) + ! better to replace PCU & PLS with RAIN and FRZR, where RAIN (probably) does *not* + ! include FRZR and PCU+PLS=RAIN+FRZR (TO BE CONFIRMED!). + ! + ! - reichle, 6/6/2025 + ! -------------------------------------------------------------------------- ! protect the forcing from unsavory values, as per practice in offline ! driver @@ -7519,15 +7530,18 @@ subroutine Driver ( RC ) if(associated(FICE2 )) FICE2 = max( min( FICESOUT(2,:),1.0 ), 0.0 ) if(associated(FICE3 )) FICE3 = max( min( FICESOUT(3,:),1.0 ), 0.0 ) - if(associated(RMELTDU001)) RMELTDU001 = RMELT(:,1) - if(associated(RMELTDU002)) RMELTDU002 = RMELT(:,2) - if(associated(RMELTDU003)) RMELTDU003 = RMELT(:,3) - if(associated(RMELTDU004)) RMELTDU004 = RMELT(:,4) - if(associated(RMELTDU005)) RMELTDU005 = RMELT(:,5) - if(associated(RMELTBC001)) RMELTBC001 = RMELT(:,6) - if(associated(RMELTBC002)) RMELTBC002 = RMELT(:,7) - if(associated(RMELTOC001)) RMELTOC001 = RMELT(:,8) - if(associated(RMELTOC002)) RMELTOC002 = RMELT(:,9) + if (N_constit>0) then + if(associated(RMELTDU001)) RMELTDU001 = RMELT(:,1) + if(associated(RMELTDU002)) RMELTDU002 = RMELT(:,2) + if(associated(RMELTDU003)) RMELTDU003 = RMELT(:,3) + if(associated(RMELTDU004)) RMELTDU004 = RMELT(:,4) + if(associated(RMELTDU005)) RMELTDU005 = RMELT(:,5) + if(associated(RMELTBC001)) RMELTBC001 = RMELT(:,6) + if(associated(RMELTBC002)) RMELTBC002 = RMELT(:,7) + if(associated(RMELTOC001)) RMELTOC001 = RMELT(:,8) + if(associated(RMELTOC002)) RMELTOC002 = RMELT(:,9) + end if + if(associated(PEATCLSM_FSWCHANGE)) then where (POROS >= PEATCLSM_POROS_THRESHOLD) PEATCLSM_FSWCHANGE = FSW_CHANGE diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/GEOS_CatchCNCLM45GridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/GEOS_CatchCNCLM45GridComp.F90 index 961acc07c..1d87167a4 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/GEOS_CatchCNCLM45GridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/GEOS_CatchCNCLM45GridComp.F90 @@ -4445,7 +4445,6 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) type(MAPL_MetaComp),pointer :: MAPL type(ESMF_Alarm) :: ALARM integer :: IM,JM - integer :: incl_Louis_extra_derivs real :: SCALE4Z0 @@ -4470,8 +4469,6 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_Get(MAPL, RUNALARM=ALARM, RC=STATUS) VERIFY_(STATUS) - call MAPL_GetResource ( MAPL, incl_Louis_extra_derivs, Label="INCL_LOUIS_EXTRA_DERIVS:", DEFAULT=1, RC=STATUS) - VERIFY_(STATUS) call MAPL_GetResource ( MAPL, SCALE4Z0, Label="SCALE4Z0:", DEFAULT=0.5, RC=STATUS) VERIFY_(STATUS) @@ -6015,9 +6012,11 @@ subroutine Driver ( RC ) !--------------- GOSWIM IMPORTS FROM GOCART --------------- ! Initialization - RCONSTIT(:,:,:) = 0.0 - TOTDEPOS(:,:) = 0.0 - RMELT(:,:) = 0.0 + if (N_constit>0) then + RCONSTIT(:,:,:) = 0.0 + TOTDEPOS(:,:) = 0.0 + RMELT(:,:) = 0.0 + end if !------------------------------------------------------------------ ! Zero the light-absorbing aerosol (LAA) deposition rates from GOCART: @@ -6057,6 +6056,8 @@ subroutine Driver ( RC ) end select + if (catchcn_internal%N_CONST_LAND4SNWALB /= 0) then + ! Convert the dimentions for LAAs from GEOS_SurfGridComp.F90 to GEOS_LandIceGridComp.F90 ! Note: Explanations of each variable ! TOTDEPOS(:,1): Combined dust deposition from size bin 1 (dry, conv-scav, ls-scav, sed) @@ -6095,8 +6096,6 @@ subroutine Driver ( RC ) ! --------------- GOSWIM PROGRNOSTICS --------------------------- - if (catchcn_internal%N_CONST_LAND4SNWALB /= 0) then - ! Conversion of the masses of the snow impurities ! Note: Explanations of each variable ! Number of snow layer is 15: N = 1-15 @@ -6183,7 +6182,7 @@ subroutine Driver ( RC ) ALWN(:,N) = -3.0*BLWN(:,N)*TC(:,N) BLWN(:,N) = 4.0*BLWN(:,N) end do - if(catchcn_internal%CHOOSEMOSFC==0 .and. incl_Louis_extra_derivs ==1) then + if(catchcn_internal%CHOOSEMOSFC==0 .and. catchcn_internal%MOSFC_EXTRA_DERIVS_OFFL_LAND==1) then do N=1,NUM_SUBTILES DEVSBT(:,N)=CQ(:,N)+max(0.0,-DCQ(:,N)*MAPL_VIREPS*TC(:,N)*(QC(:,N)-QA)) DEDTC(:,N) =max(0.0,-DCQ(:,N)*(1.+MAPL_VIREPS*QC(:,N))*(QC(:,N)-QA)) @@ -6223,8 +6222,20 @@ subroutine Driver ( RC ) ! get total solid precip ! -------------------------------------------------------------------------- - SLDTOT = SNO+ICE+FRZR + SLDTOT = SNO+ICE ! do *not* add FRZR (freezing rain) to solid precip, see comment below + ! FRZR (freezing rain) is rain that falls as super-cooled liquid water, which freezes upon + ! impact on a sufficiently cold surface. As such, FRZR is *not* solid precipitation + ! and should be considered rainfall. + ! + ! As of Jun 2025, FRZR is identical to 0 and can be ignored. Looking ahead, make sure to + ! account correctly for FRZR in the input precipitation variables. Once it's filled + ! with non-zero values, FRZR will (probably) be included in PLS+PCU. It is (probably) + ! better to replace PCU & PLS with RAIN and FRZR, where RAIN (probably) does *not* + ! include FRZR and PCU+PLS=RAIN+FRZR (TO BE CONFIRMED!). + ! + ! - reichle, 6/6/2025 + ! -------------------------------------------------------------------------- ! protect the forcing from unsavory values, as per practice in offline ! driver @@ -7800,15 +7811,18 @@ subroutine Driver ( RC ) if(associated(FICE2 )) FICE2 = max( min( FICESOUT(2,:),1.0 ), 0.0 ) if(associated(FICE3 )) FICE3 = max( min( FICESOUT(3,:),1.0 ), 0.0 ) - if(associated(RMELTDU001)) RMELTDU001 = RMELT(:,1) - if(associated(RMELTDU002)) RMELTDU002 = RMELT(:,2) - if(associated(RMELTDU003)) RMELTDU003 = RMELT(:,3) - if(associated(RMELTDU004)) RMELTDU004 = RMELT(:,4) - if(associated(RMELTDU005)) RMELTDU005 = RMELT(:,5) - if(associated(RMELTBC001)) RMELTBC001 = RMELT(:,6) - if(associated(RMELTBC002)) RMELTBC002 = RMELT(:,7) - if(associated(RMELTOC001)) RMELTOC001 = RMELT(:,8) - if(associated(RMELTOC002)) RMELTOC002 = RMELT(:,9) + if (N_constit>0) then + if(associated(RMELTDU001)) RMELTDU001 = RMELT(:,1) + if(associated(RMELTDU002)) RMELTDU002 = RMELT(:,2) + if(associated(RMELTDU003)) RMELTDU003 = RMELT(:,3) + if(associated(RMELTDU004)) RMELTDU004 = RMELT(:,4) + if(associated(RMELTDU005)) RMELTDU005 = RMELT(:,5) + if(associated(RMELTBC001)) RMELTBC001 = RMELT(:,6) + if(associated(RMELTBC002)) RMELTBC002 = RMELT(:,7) + if(associated(RMELTOC001)) RMELTOC001 = RMELT(:,8) + if(associated(RMELTOC002)) RMELTOC002 = RMELT(:,9) + end if + if(associated(PEATCLSM_FSWCHANGE )) then where (POROS >= PEATCLSM_POROS_THRESHOLD) PEATCLSM_FSWCHANGE = FSW_CHANGE diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/Shared/catchmentCN.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/Shared/catchmentCN.F90 index b4ab70e5c..c1ddfded7 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/Shared/catchmentCN.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/Shared/catchmentCN.F90 @@ -137,7 +137,7 @@ MODULE CATCHMENT_CN_MODEL SUBROUTINE CATCHCN ( & NCH, LONS, LATS, DTSTEP, UFW4RO, FWETC, FWETL, cat_id, & ! LONS, LATS are in [radians] !!! ITYP1,ITYP2,FVEG1,FVEG2, & - DZSF, TRAINC,TRAINL, TSNOW, TICE, TFRZR, UM, & + DZSF, TRAINC,TRAINL, TSNOW, TICE, TFRZR, UM, & ! TFRZR=0 as of Jun 2025; needs attention if ever TFRZR/=0 ETURB1, DEDQA1, DEDTC1, HSTURB1,DHSDQA1, DHSDTC1, & ETURB2, DEDQA2, DEDTC2, HSTURB2,DHSDQA2, DHSDTC2, & ETURB4, DEDQA4, DEDTC4, HSTURB4,DHSDQA4, DHSDTC4, & @@ -802,8 +802,8 @@ SUBROUTINE CATCHCN ( & END IF AREA(2)= AR2(N) AREA(3)= AR4(N) - pr = trainc(n)+trainl(n)+tsnow(n)+tice(n)+tfrzr(n) - snowf = tsnow(n)+tice(n)+tfrzr(n) + pr = trainc(n)+trainl(n)+tsnow(n)+tice(n) ! see comment re. FRZR in GEOS_CatchGridComp.F90 by reichle, 6/6/2025: + snowf = tsnow(n)+tice(n) ! freezing rain is liquid not solid, (probably) included in trainl+trainc dedea = dedqas(n)*epsilon/psur(n) dhsdea = dhsdqas(n)*epsilon/psur(n) ea = qm(n)*psur(n)/epsilon @@ -1283,7 +1283,7 @@ SUBROUTINE CATCHCN ( & !FSW_CHANGE IS THE CHANGE IN THE FREE-STANDING WATER, RELEVANT FOR PEATLAND ONLY FSW_CHANGE(N) = 0. IF(POROS(N) >= PEATCLSM_POROS_THRESHOLD) THEN - pr = trainc(n)+trainl(n)+tsnow(n)+tice(n)+tfrzr(n) + pr = trainc(n)+trainl(n)+tsnow(n)+tice(n) ! see comment re. FRZR in GEOS_CatchGridComp.F90 by reichle, 6/6/2025 FSW_CHANGE(N) = PR - EVAP(N) - RUNOFF(N) - WCHANGE(N) ENDIF diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/utils/dbg_cnlsm_offline.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/utils/dbg_cnlsm_offline.F90 index 75e7b2954..107c31ecc 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/utils/dbg_cnlsm_offline.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/utils/dbg_cnlsm_offline.F90 @@ -474,7 +474,7 @@ PROGRAM dbg_cnlsm_offline DWLAND = WCHANGE PRLAND = c_input%PCU+c_input%PLS+c_input%SNO & - + c_input%ICE + + c_input%FRZR + + c_input%ICE EVLAND = EVAPOUT-EVACC BFLOW = BFLOW SPWATR = EVACC @@ -570,7 +570,7 @@ PROGRAM dbg_cnlsm_offline DWLAND(:) = WCHANGE(tid:tid) PRLAND(:) = c_input(tid:tid)%PCU + c_input(tid:tid)%PLS + c_input(tid:tid)%SNO & - + c_input(tid:tid)%ICE + + c_input(tid:tid)%FRZR + + c_input(tid:tid)%ICE EVLAND(:) = EVAPOUT(tid:tid)-EVACC(tid:tid) SPWATR(:) = EVACC(tid:tid) SUBLIM(:) = EVPICE(tid:tid)*(1./MAPL_ALHS)*FR(tid,4) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/GEOS_CatchGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/GEOS_CatchGridComp.F90 index 99fd7f8d3..17da8116a 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/GEOS_CatchGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/GEOS_CatchGridComp.F90 @@ -1,6 +1,7 @@ #include "MAPL_Generic.h" #define DEALLOC_(A) if(associated(A))then;A=0;if(MAPL_ShmInitialized)then; call MAPL_DeAllocNodeArray(A,rc=STATUS);else; deallocate(A,stat=STATUS);endif;_VERIFY(STATUS);NULLIFY(A);endif + !============================================================================= module GEOS_CatchGridCompMod @@ -61,62 +62,62 @@ module GEOS_CatchGridCompMod !#-- use catch_wrap_stateMod -implicit none -private - -! !PUBLIC MEMBER FUNCTIONS: - -public SetServices - -! -!EOP - -integer,parameter :: FSAT=1 ! Saturated subtile -integer,parameter :: FTRN=2 ! Transition subtile -integer,parameter :: FWLT=3 ! Wilting subtile -integer,parameter :: FSNW=4 ! Snowcover subtile - -integer,parameter :: NUM_SUBTILES=4 - -! Vegetation type as follows: -! 1: BROADLEAF EVERGREEN TREES -! 2: BROADLEAF DECIDUOUS TREES -! 3: NEEDLELEAF TREES -! 4: GROUND COVER -! 5: BROADLEAF SHRUBS -! 6: DWARF TREES (TUNDRA) -!=================================================== -!ALT: we currently use only 6 types (see above) -! in the legacy code we used to have 8 -! (or 10 with the sea and land ice) with -! these additional entries -! 7: BARE SOIL -! 8: DESERT - -integer,parameter :: NTYPS = MAPL_NUMVEGTYPES - -! Veg-dep. vector SAI factor for scaling of rough length (now exp(-.5) ) -real, parameter :: SAI4ZVG(NTYPS) = (/ 0.60653, 0.60653, 0.60653, 1.0, 1.0, 1.0 /) -real, parameter :: HPBL = 1000. -!real, parameter :: MIN_VEG_HEIGHT = 0.01 -real, parameter :: Z0_BY_ZVEG = 0.13 -real, parameter :: D0_BY_ZVEG = 0.66 - -! Emissivity values from Wilber et al (1999, NATA-TP-1999-209362) -! Fu-Liou bands have been combined to Chou bands (though these are broadband only) -! IGBP veg types have been mapped to Sib-Mosaic types -! Details in ~suarez/Emiss on cerebus - -real, parameter :: EMSVEG(NTYPS) = (/ 0.99560, 0.99000, 0.99560, 0.99320, & - 0.99280, 0.99180 /) -real, parameter :: EMSBARESOIL = 0.94120 -real, parameter :: EMSSNO = 0.99999 - -! moved SURFLAY from catchment.F90 to enable run-time changes for off-line system -! - reichle, 29 Oct 2010 - -! real, parameter :: SURFLAY = 20. ! moved to GetResource in RUN2 LLT:12Jul2013 -! SURFLAY moved to internal state + implicit none + private + + ! !PUBLIC MEMBER FUNCTIONS: + + public SetServices + + ! + !EOP + + integer,parameter :: FSAT=1 ! Saturated subtile + integer,parameter :: FTRN=2 ! Transition subtile + integer,parameter :: FWLT=3 ! Wilting subtile + integer,parameter :: FSNW=4 ! Snowcover subtile + + integer,parameter :: NUM_SUBTILES=4 + + ! Vegetation type as follows: + ! 1: BROADLEAF EVERGREEN TREES + ! 2: BROADLEAF DECIDUOUS TREES + ! 3: NEEDLELEAF TREES + ! 4: GROUND COVER + ! 5: BROADLEAF SHRUBS + ! 6: DWARF TREES (TUNDRA) + !=================================================== + !ALT: we currently use only 6 types (see above) + ! in the legacy code we used to have 8 + ! (or 10 with the sea and land ice) with + ! these additional entries + ! 7: BARE SOIL + ! 8: DESERT + + integer,parameter :: NTYPS = MAPL_NUMVEGTYPES + + ! Veg-dep. vector SAI factor for scaling of rough length (now exp(-.5) ) + real, parameter :: SAI4ZVG(NTYPS) = (/ 0.60653, 0.60653, 0.60653, 1.0, 1.0, 1.0 /) + real, parameter :: HPBL = 1000. + !real, parameter :: MIN_VEG_HEIGHT = 0.01 + real, parameter :: Z0_BY_ZVEG = 0.13 + real, parameter :: D0_BY_ZVEG = 0.66 + + ! Emissivity values from Wilber et al (1999, NATA-TP-1999-209362) + ! Fu-Liou bands have been combined to Chou bands (though these are broadband only) + ! IGBP veg types have been mapped to Sib-Mosaic types + ! Details in ~suarez/Emiss on cerebus + + real, parameter :: EMSVEG(NTYPS) = (/ 0.99560, 0.99000, 0.99560, 0.99320, & + 0.99280, 0.99180 /) + real, parameter :: EMSBARESOIL = 0.94120 + real, parameter :: EMSSNO = 0.99999 + + ! moved SURFLAY from catchment.F90 to enable run-time changes for off-line system + ! - reichle, 29 Oct 2010 + + ! real, parameter :: SURFLAY = 20. ! moved to GetResource in RUN2 LLT:12Jul2013 + ! SURFLAY moved to internal state contains @@ -321,7 +322,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddImportSpec(GC ,& - LONG_NAME = 'surface_downwelling_par_beam_flux',& + LONG_NAME = 'surface_downwelling_PAR_beam_flux',& UNITS = 'W m-2' ,& SHORT_NAME = 'DRPAR' ,& DIMS = MAPL_DimsTileOnly ,& @@ -330,7 +331,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddImportSpec(GC ,& - LONG_NAME = 'surface_downwelling_par_diffuse_flux',& + LONG_NAME = 'surface_downwelling_PAR_diffuse_flux',& UNITS = 'W m-2' ,& SHORT_NAME = 'DFPAR' ,& DIMS = MAPL_DimsTileOnly ,& @@ -411,7 +412,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddImportSpec(GC ,& - LONG_NAME = 'greeness_fraction' ,& + LONG_NAME = 'vegetation_greenness_fraction',& UNITS = '1' ,& SHORT_NAME = 'GRN' ,& DIMS = MAPL_DimsTileOnly ,& @@ -1112,7 +1113,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddInternalSpec(GC ,& - LONG_NAME = 'interception_reservoir_capac',& + LONG_NAME = 'vegetation_interception_water_storage',& UNITS = 'kg m-2' ,& SHORT_NAME = 'CAPAC' ,& FRIENDLYTO = trim(COMP_NAME) ,& @@ -1332,7 +1333,7 @@ subroutine SetServices ( GC, RC ) if (CATCH_INTERNAL_STATE%SNOW_ALBEDO_INFO == 1) then call MAPL_AddInternalSpec(GC ,& - LONG_NAME = 'effective_snow_albedo' ,& + LONG_NAME = 'effective_snow_reflectivity' ,& UNITS = '1' ,& SHORT_NAME = 'SNOWALB' ,& FRIENDLYTO = trim(COMP_NAME) ,& @@ -1366,7 +1367,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddInternalSpec(GC ,& - LONG_NAME = 'surface_moisture_exchange_coffiecient',& + LONG_NAME = 'surface_moisture_exchange_coefficient',& UNITS = 'kg m-2 s-1' ,& SHORT_NAME = 'CQ' ,& DIMS = MAPL_DimsTileTile ,& @@ -1397,29 +1398,62 @@ subroutine SetServices ( GC, RC ) RESTART = RESTART ,& RC=STATUS ) VERIFY_(STATUS) + + if (CATCH_INTERNAL_STATE%MOSFC_EXTRA_DERIVS_OFFL_LAND == 1) then + + ! for *analytical* extra derivatives in louissurface + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'delCH_delTVA', & + LONG_NAME = 'partial_derivative_of_CH_wrt_virtual_Tair', & + UNITS = '1', & + DIMS = MAPL_DimsTileTile, & + NUM_SUBTILES = NUM_SUBTILES ,& + VLOCATION = MAPL_VLocationNone, & + RESTART = MAPL_RestartSkip ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'delCQ_delTVA', & + LONG_NAME = 'partial_derivative_of_CQ_wrt_virtual_Tair', & + UNITS = '1', & + DIMS = MAPL_DimsTileTile, & + NUM_SUBTILES = NUM_SUBTILES ,& + VLOCATION = MAPL_VLocationNone, & + RESTART = MAPL_RestartSkip ,& + RC=STATUS ) + VERIFY_(STATUS) - call MAPL_AddInternalSpec(GC, & - SHORT_NAME = 'DCH', & - LONG_NAME = 'ch difference, optional in louissurface', & - UNITS = '1', & - DIMS = MAPL_DimsTileTile, & - NUM_SUBTILES = NUM_SUBTILES ,& - VLOCATION = MAPL_VLocationNone, & - RESTART = MAPL_RestartSkip ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec(GC, & - SHORT_NAME = 'DCQ', & - LONG_NAME = 'cq difference, optional in louissurface', & - UNITS = '1', & - DIMS = MAPL_DimsTileTile, & - NUM_SUBTILES = NUM_SUBTILES ,& - VLOCATION = MAPL_VLocationNone, & - RESTART = MAPL_RestartSkip ,& - RC=STATUS ) - VERIFY_(STATUS) + elseif (CATCH_INTERNAL_STATE%MOSFC_EXTRA_DERIVS_OFFL_LAND >= 2) then + + ! for *numerical* extra derivatives in helfsurface and louissurface + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'partial_derivative_of_CH_wrt_canopy_temperature', & + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'delCH_delTC' ,& + DIMS = MAPL_DimsTileTile ,& + NUM_SUBTILES = NUM_SUBTILES ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartSkip ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'partial_derivative_of_CQ_wrt_canopy_specific_humidity', & + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'delCQ_delQC' ,& + DIMS = MAPL_DimsTileTile ,& + NUM_SUBTILES = NUM_SUBTILES ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartSkip ,& + RC=STATUS ) + VERIFY_(STATUS) + end if + + !---------- GOSWIM snow impurity related variables ---------- if (CATCH_INTERNAL_STATE%N_CONST_LAND4SNWALB /= 0) then @@ -1564,7 +1598,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'runoff_flux' ,& + LONG_NAME = 'runoff_total_flux' ,& UNITS = 'kg m-2 s-1' ,& SHORT_NAME = 'RUNOFF' ,& DIMS = MAPL_DimsTileOnly ,& @@ -1619,7 +1653,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'totoal soil moisture' ,& + LONG_NAME = 'total_soil_moisture' ,& UNITS = 'kg m-2' ,& SHORT_NAME = 'WATSOI' ,& DIMS = MAPL_DimsTileOnly ,& @@ -1645,7 +1679,7 @@ subroutine SetServices ( GC, RC ) RC=STATUS ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'baseflow_flux' ,& + LONG_NAME = 'baseflow_flux_land' ,& UNITS = 'kg m-2 s-1' ,& SHORT_NAME = 'BASEFLOW' ,& DIMS = MAPL_DimsTileOnly ,& @@ -1780,7 +1814,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'ave_catchment_temp_incl_snw',& + LONG_NAME = 'surface_temperature_of_land_incl_snow',& UNITS = 'K' ,& SHORT_NAME = 'TPSURF' ,& DIMS = MAPL_DimsTileOnly ,& @@ -1789,7 +1823,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'temperature_top_snow_layer',& + LONG_NAME = 'surface_temperature_of_snow_on_land',& UNITS = 'K' ,& SHORT_NAME = 'TPSNOW' ,& DIMS = MAPL_DimsTileOnly ,& @@ -1798,7 +1832,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'temperature_unsaturated_zone',& + LONG_NAME = 'surface_temperature_of_unsaturated_zone',& UNITS = 'K' ,& SHORT_NAME = 'TPUNST' ,& DIMS = MAPL_DimsTileOnly ,& @@ -1807,7 +1841,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'temperature_saturated_zone',& + LONG_NAME = 'surface_temperature_of_saturated_zone',& UNITS = 'K' ,& SHORT_NAME = 'TPSAT' ,& DIMS = MAPL_DimsTileOnly ,& @@ -1816,7 +1850,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'temperature_wilted_zone' ,& + LONG_NAME = 'surface_temperature_of_wilting_zone' ,& UNITS = 'K' ,& SHORT_NAME = 'TPWLT' ,& DIMS = MAPL_DimsTileOnly ,& @@ -1825,7 +1859,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'fractional_area_of_land_snowcover',& + LONG_NAME = 'fractional_area_of_snow_on_land',& UNITS = '1' ,& SHORT_NAME = 'ASNOW' ,& DIMS = MAPL_DimsTileOnly ,& @@ -1888,7 +1922,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'snow_depth_within_snow_covered_area_fraction' ,& + LONG_NAME = 'snow_depth_within_snow_covered_area_fraction_on_land' ,& UNITS = 'm' ,& SHORT_NAME = 'SNOWDP' ,& DIMS = MAPL_DimsTileOnly ,& @@ -1897,7 +1931,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'surface_soil_wetness' ,& + LONG_NAME = 'soil_wetness_surface' ,& UNITS = '1' ,& SHORT_NAME = 'WET1' ,& DIMS = MAPL_DimsTileOnly ,& @@ -1906,7 +1940,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'root_zone_soil_wetness' ,& + LONG_NAME = 'soil_wetness_rootzone' ,& UNITS = '1' ,& SHORT_NAME = 'WET2' ,& DIMS = MAPL_DimsTileOnly ,& @@ -1915,7 +1949,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'ave_prof_soil__moisture' ,& + LONG_NAME = 'soil_wetness_profile' ,& UNITS = '1' ,& SHORT_NAME = 'WET3' ,& DIMS = MAPL_DimsTileOnly ,& @@ -1924,7 +1958,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'water_surface_layer' ,& + LONG_NAME = 'soil_moisture_surface' ,& UNITS = 'm3 m-3' ,& SHORT_NAME = 'WCSF' ,& DIMS = MAPL_DimsTileOnly ,& @@ -1933,7 +1967,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'water_root_zone' ,& + LONG_NAME = 'soil_moisture_rootzone' ,& UNITS = 'm3 m-3' ,& SHORT_NAME = 'WCRZ' ,& DIMS = MAPL_DimsTileOnly ,& @@ -1942,8 +1976,8 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'water_ave_prof' ,& - UNITS = 'm3 m-3' ,& + LONG_NAME = 'soil_moisture_profile' ,& + UNITS = 'm3 m-3' ,& SHORT_NAME = 'WCPR' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& @@ -1951,7 +1985,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'soil_temperatures_layer_1' ,& + LONG_NAME = 'soil_temperature_layer_1' ,& UNITS = 'K' ,& ! units now K, rreichle & borescan, 6 Nov 2020 SHORT_NAME = 'TP1' ,& DIMS = MAPL_DimsTileOnly ,& @@ -1960,7 +1994,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'soil_temperatures_layer_2' ,& + LONG_NAME = 'soil_temperature_layer_2' ,& UNITS = 'K' ,& ! units now K, rreichle & borescan, 6 Nov 2020 SHORT_NAME = 'TP2' ,& DIMS = MAPL_DimsTileOnly ,& @@ -1969,7 +2003,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'soil_temperatures_layer_3' ,& + LONG_NAME = 'soil_temperature_layer_3' ,& UNITS = 'K' ,& ! units now K, rreichle & borescan, 6 Nov 2020 SHORT_NAME = 'TP3' ,& DIMS = MAPL_DimsTileOnly ,& @@ -1978,7 +2012,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'soil_temperatures_layer_4' ,& + LONG_NAME = 'soil_temperature_layer_4' ,& UNITS = 'K' ,& ! units now K, rreichle & borescan, 6 Nov 2020 SHORT_NAME = 'TP4' ,& DIMS = MAPL_DimsTileOnly ,& @@ -1987,7 +2021,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'soil_temperatures_layer_5' ,& + LONG_NAME = 'soil_temperature_layer_5' ,& UNITS = 'K' ,& ! units now K, rreichle & borescan, 6 Nov 2020 SHORT_NAME = 'TP5' ,& DIMS = MAPL_DimsTileOnly ,& @@ -1996,7 +2030,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'soil_temperatures_layer_6' ,& + LONG_NAME = 'soil_temperature_layer_6' ,& UNITS = 'K' ,& ! units now K, rreichle & borescan, 6 Nov 2020 SHORT_NAME = 'TP6' ,& DIMS = MAPL_DimsTileOnly ,& @@ -2014,7 +2048,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'surface_albedo_visible_beam',& + LONG_NAME = 'surface_reflectivity_visible_beam',& UNITS = '1' ,& SHORT_NAME = 'ALBVR' ,& DIMS = MAPL_DimsTileOnly ,& @@ -2023,7 +2057,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'surface_albedo_visible_diffuse',& + LONG_NAME = 'surface_reflectivity_visible_diffuse',& UNITS = '1' ,& SHORT_NAME = 'ALBVF' ,& DIMS = MAPL_DimsTileOnly ,& @@ -2032,7 +2066,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'surface_albedo_near_infrared_beam',& + LONG_NAME = 'surface_reflectivity_near_infrared_beam',& UNITS = '1' ,& SHORT_NAME = 'ALBNR' ,& DIMS = MAPL_DimsTileOnly ,& @@ -2041,7 +2075,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'surface_albedo_near_infrared_diffuse',& + LONG_NAME = 'surface_reflectivity_near_infrared_diffuse',& UNITS = '1' ,& SHORT_NAME = 'ALBNF' ,& DIMS = MAPL_DimsTileOnly ,& @@ -2323,7 +2357,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'EVLAND', & - LONG_NAME = 'Total_evapotranspiration_land', & + LONG_NAME = 'total_evapotranspiration_land', & UNITS = 'kg m-2 s-1', & DIMS = MAPL_DimsTileOnly, & VLOCATION = MAPL_VLocationNone, & @@ -2350,7 +2384,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'DRPARLAND', & - LONG_NAME = 'surface_downwelling_par_beam_flux', & + LONG_NAME = 'surface_downwelling_PAR_beam_flux', & UNITS = 'W m-2', & DIMS = MAPL_DimsTileOnly, & VLOCATION = MAPL_VLocationNone, & @@ -2359,7 +2393,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'DFPARLAND', & - LONG_NAME = 'surface_downwelling_par_diffuse_flux', & + LONG_NAME = 'surface_downwelling_PAR_diffuse_flux', & UNITS = 'W m-2', & DIMS = MAPL_DimsTileOnly, & VLOCATION = MAPL_VLocationNone, & @@ -2378,7 +2412,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'SWNETSNOW', & - LONG_NAME = 'Net_shortwave_snow', & + LONG_NAME = 'Net_shortwave_flux_snow', & UNITS = 'W m-2', & DIMS = MAPL_DimsTileOnly, & VLOCATION = MAPL_VLocationNone, & @@ -2462,7 +2496,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'SWLAND', & - LONG_NAME = 'Net_shortwave_land', & + LONG_NAME = 'Net_shortwave_flux_land', & UNITS = 'W m-2', & DIMS = MAPL_DimsTileOnly, & VLOCATION = MAPL_VLocationNone, & @@ -2471,7 +2505,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'SWDOWNLAND', & - LONG_NAME = 'Incident_shortwave_land', & + LONG_NAME = 'Incident_shortwave_flux_land', & UNITS = 'W m-2', & DIMS = MAPL_DimsTileOnly, & VLOCATION = MAPL_VLocationNone, & @@ -2481,7 +2515,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'LWLAND', & - LONG_NAME = 'Net_longwave_land', & + LONG_NAME = 'Net_longwave_flux_land', & UNITS = 'W m-2', & DIMS = MAPL_DimsTileOnly, & VLOCATION = MAPL_VLocationNone, & @@ -2491,7 +2525,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'GHLAND', & - LONG_NAME = 'Ground_heating_land', & + LONG_NAME = 'Ground_heating_flux_land', & UNITS = 'W m-2', & DIMS = MAPL_DimsTileOnly, & VLOCATION = MAPL_VLocationNone, & @@ -2500,7 +2534,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'GHTSKIN', & - LONG_NAME = 'Ground_heating_skin_temp', & + LONG_NAME = 'Ground_heating_flux_for_skin_temp_land', & UNITS = 'W m-2', & DIMS = MAPL_DimsTileOnly, & VLOCATION = MAPL_VLocationNone, & @@ -2519,7 +2553,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'TWLAND', & - LONG_NAME = 'Avail_water_storage_land', & + LONG_NAME = 'total_water_storage_land', & UNITS = 'kg m-2', & DIMS = MAPL_DimsTileOnly, & VLOCATION = MAPL_VLocationNone, & @@ -2920,8 +2954,7 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_TimerOn(MAPL,"INITIALIZE") - - ! retrieve interal state + ! retrieve internal state call ESMF_UserCompGetInternalState ( GC, 'CatchInternal',wrap,status ) VERIFY_(STATUS) @@ -3076,7 +3109,7 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) type(ESMF_Clock), intent(inout) :: CLOCK !The clock integer,optional, intent(out ) :: RC !Error code: -! !DESCRIPTION: Does the cds computation and roughness length +! !DESCRIPTION: Compute roughness length and exchange coefficients ("cds"), incl. derivatives !EOP ! ErrLog Variables @@ -3122,8 +3155,16 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) real, dimension(:,:), pointer :: CQ real, dimension(:,:), pointer :: FR real, dimension(:,:), pointer :: WW - real, dimension(:,:), pointer :: DCH - real, dimension(:,:), pointer :: DCQ + + ! for analytical extra derivatives (louissurface) + + real, dimension(:,:), pointer :: delCH_delTVA + real, dimension(:,:), pointer :: delCQ_delTVA + + ! for numerical extra derivatives (louissurface, helfsurface) + + real, dimension(:,:), pointer :: delCH_delTC + real, dimension(:,:), pointer :: delCQ_delQC ! ----------------------------------------------------- ! EXPORT Pointers @@ -3206,9 +3247,25 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) real :: SCALE4ZVG real :: SCALE4Z0_u real :: MIN_VEG_HEIGHT + + ! ------------------------------------- + ! + ! for numerical extra derivatives (louissurface, helfsurface) + + real, parameter :: MOSFC_pert_fac = 0.001 ! size of multiplicative pert for numerical derivatives + + ! Louis needs 2d arrays; Helfand would work with 1d arrays but use 2d arrays to avoid "if" statements + + real, dimension(:,:), allocatable :: DeltaTC, CHpert + real, dimension(:,:), allocatable :: DeltaQC, CQpert + + real, dimension(:,:), allocatable :: DummyZ0T, DummyCM + + ! ------------------------------------- type(CATCH_WRAP) :: wrap type (T_CATCH_STATE), pointer :: CATCH_INTERNAL_STATE + !============================================================================= ! Begin... @@ -3253,7 +3310,7 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) INTERNAL_ESMF_STATE=INTERNAL , & RC=STATUS ) VERIFY_(STATUS) - + call MAPL_GetResource ( MAPL, CHOOSEZ0, Label="CHOOSEZ0:", DEFAULT=3, RC=STATUS) VERIFY_(STATUS) call ESMF_VMGetCurrent(VM, rc=STATUS) @@ -3306,11 +3363,24 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) VERIFY_(STATUS) call MAPL_GetPointer(INTERNAL,WW , 'WW' , RC=STATUS) VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL,DCH , 'DCH' , RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL,DCQ , 'DCQ' , RC=STATUS) - VERIFY_(STATUS) + + if (CATCH_INTERNAL_STATE%MOSFC_EXTRA_DERIVS_OFFL_LAND == 1) then + + call MAPL_GetPointer(INTERNAL,delCH_delTVA , 'delCH_delTVA' , RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,delCQ_delTVA , 'delCQ_delTVA' , RC=STATUS) + VERIFY_(STATUS) + + elseif (CATCH_INTERNAL_STATE%MOSFC_EXTRA_DERIVS_OFFL_LAND >= 2) then + + call MAPL_GetPointer(INTERNAL,delCQ_delQC , 'delCQ_delQC' , RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,delCH_delTC , 'delCH_delTC' , RC=STATUS) + VERIFY_(STATUS) + end if + + ! Pointers to outputs !-------------------- @@ -3444,6 +3514,21 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) allocate(IWATER(NT),STAT=STATUS) VERIFY_(STATUS) + if (CATCH_INTERNAL_STATE%MOSFC_EXTRA_DERIVS_OFFL_LAND>=2) then + + ! allocate variables for numerical extra derivatives (louissurface, helfsurface) + + allocate(DeltaTC( NT,NUM_SUBTILES),STAT=STATUS); VERIFY_(STATUS) + allocate(DeltaQC( NT,NUM_SUBTILES),STAT=STATUS); VERIFY_(STATUS) + + allocate(CHpert( NT,NUM_SUBTILES),STAT=STATUS); VERIFY_(STATUS) + allocate(CQpert( NT,NUM_SUBTILES),STAT=STATUS); VERIFY_(STATUS) + + allocate(DummyZ0T(NT,NUM_SUBTILES),STAT=STATUS); VERIFY_(STATUS) + allocate(DummyCM( NT,NUM_SUBTILES),STAT=STATUS); VERIFY_(STATUS) + + end if + ! Vegetation types used to index into tables !-------------------------------------------- @@ -3535,55 +3620,193 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) if(associated(Z0 )) Z0 = Z0T(:,N) if(associated(D0 )) D0 = D0T -! Compute the three surface exchange coefficients -!------------------------------------------------- +! Compute surface exchange coefficients +!--------------------------------------- + + call MAPL_TimerOn(MAPL,"-SURF") ! timer for computation of MOSFC exchange coeffs and derivs (Louis or Helfand) + + if (CATCH_INTERNAL_STATE%CHOOSEMOSFC.eq.0) then - call MAPL_TimerOn(MAPL,"-SURF") - if(CATCH_INTERNAL_STATE%CHOOSEMOSFC.eq.0) then - WW(:,N) = 0. - CM(:,N) = 0. + ! Louis surface turbulence + + WW(:,N) = 0. + CM(:,N) = 0. + + if (CATCH_INTERNAL_STATE%MOSFC_EXTRA_DERIVS_OFFL_LAND==1) then + + ! analytical extra derivatives (default for Louis) + + call louissurface(3,N,UU,WW,PS,TA,TC,QA,QC,PCU,LAI,Z0T,DZE,CM,CN,RIB,ZT,ZQ,CH,CQ,UUU,UCN,RE,delCH_delTVA,delCQ_delTVA) + + else + + ! none .or. numerical extra derivatives + + if (CATCH_INTERNAL_STATE%MOSFC_EXTRA_DERIVS_OFFL_LAND>=2) then + + ! Prep calculation of numerical extra derivatives. Start with calling louissurface with perturbed inputs and + ! save only the perturbed exchange coeffs. The final call with nominal inputs produces the unperturbed + ! exchange coeffs and other outputs (CN, RIB, ZT, ZQ, etc). + ! Must use properly initialized dummmies for Z0T and CM because these are intent(inout). + + ! perturb TC: send in (TC+DeltaTC), get back CHpert + + DeltaTC = MOSFC_pert_fac*TC + + DummyZ0T = Z0T + DummyCM = CM + + call louissurface( 3,N,UU,WW,PS,TA,TC+DeltaTC,QA,QC ,PCU,LAI,DummyZ0T,DZE,DummyCM,CN,RIB,ZT,ZQ,CHpert,CQ ,UUU,UCN,RE) + + if (CATCH_INTERNAL_STATE%MOSFC_EXTRA_DERIVS_OFFL_LAND==2) then + + ! perturb QC: send in (QC+DeltaQC), get back CQpert + + DeltaQC = MOSFC_pert_fac*QC + + DummyZ0T = Z0T + DummyCM = CM + + call louissurface(3,N,UU,WW,PS,TA,TC ,QA,QC+DeltaQC,PCU,LAI,DummyZ0T,DZE,DummyCM,CN,RIB,ZT,ZQ,CH ,CQpert,UUU,UCN,RE) + + end if + + end if + + ! Call with nominal inputs [after calls with perturbed inputs to obtain correct outputs (CN, RIB, ZT, ZQ, etc.)] + + call louissurface(3,N,UU,WW,PS,TA,TC,QA,QC,PCU,LAI,Z0T,DZE,CM,CN,RIB,ZT,ZQ,CH,CQ,UUU,UCN,RE) + + end if ! MOSFC_EXTRA_DERIVS_OFFL_LAND + + elseif (CATCH_INTERNAL_STATE%CHOOSEMOSFC.eq.1)then - call louissurface(3,N,UU,WW,PS,TA,TC,QA,QC,PCU,LAI,Z0T,DZE,CM,CN,RIB,ZT,ZQ,CH,CQ,UUU,UCN,RE,DCH,DCQ) + ! Helfand surface turbulence - elseif (CATCH_INTERNAL_STATE%CHOOSEMOSFC.eq.1)then - - niter = 6 ! number of internal iterations in the helfand MO surface layer routine - IWATER = 3 - - PSMB = PS * 0.01 ! convert to MB -! Approximate pressure at top of surface layer: hydrostatic, eqn of state using avg temp and press - PSL = PSMB * (1. - (DZE*MAPL_GRAV)/(MAPL_RGAS*(TA+TC(:,N)) ) ) / & - (1. + (DZE*MAPL_GRAV)/(MAPL_RGAS*(TA+TC(:,N)) ) ) - - CALL helfsurface( UWINDLMTILE,VWINDLMTILE,TA,TC(:,N),QA,QC(:,N),PSL,PSMB,Z0T(:,N),lai, & - IWATER,DZE,niter,nt,RHOH,VKH,VKM,USTAR,XX,YY,CU,CT,RIB,ZETA,WS, & - t2m,q2m,u2m,v2m,t10m,q10m,u10m,v10m,u50m,v50m,CHOOSEZ0) - - CM(:,N) = VKM - CH(:,N) = VKH - CQ(:,N) = VKH - - CN = (MAPL_KARMAN/ALOG(DZE/Z0T(:,N) + 1.0)) * (MAPL_KARMAN/ALOG(DZE/Z0T(:,N) + 1.0)) - ZT = Z0T(:,N) - ZQ = Z0T(:,N) - RE = 0. - UUU = UU - UCN = 0. - + niter = 6 ! number of internal iterations in the Helfand MO surface layer routine + IWATER = 3 + + PSMB = PS * 0.01 ! convert to MB + + ! Approximate pressure at top of surface layer: hydrostatic, eqn of state using avg temp and press + PSL = PSMB * (1. - (DZE*MAPL_GRAV)/(MAPL_RGAS*(TA+TC(:,N)) ) ) / & + (1. + (DZE*MAPL_GRAV)/(MAPL_RGAS*(TA+TC(:,N)) ) ) + + if (CATCH_INTERNAL_STATE%MOSFC_EXTRA_DERIVS_OFFL_LAND==2) then + + ! Prep calculation of numerical extra derivatives. Start with calling louissurface with perturbed inputs and + ! save only the perturbed exchange coeffs. The final call with nominal inputs produces the unperturbed + ! exchange coeffs and other outputs (CN, RIB, ZT, ZQ, etc). + ! Must use properly initialized dummmies for Z0T and CM because these are intent(inout). + + ! perturb TC: send in (TC+DeltaTC), get back CHpert + + DeltaTC( :,N) = MOSFC_pert_fac*TC(:,N) + + DummyZ0T(:,N) = Z0T(:,N) + + CALL helfsurface(UWINDLMTILE,VWINDLMTILE,TA,TC(:,N)+DeltaTC(:,N),QA,QC(:,N) ,PSL,PSMB,DummyZ0T(:,N),lai, & + IWATER,DZE,niter,nt,RHOH,VKH,VKM,USTAR,XX,YY,CU,CT,RIB,ZETA,WS, & + t2m,q2m,u2m,v2m,t10m,q10m,u10m,v10m,u50m,v50m,CHOOSEZ0) + + CHpert( :,N) = VKH + + ! perturb QC: send in (QC+DeltaQC), get back CQpert + + DeltaQC( :,N) = MOSFC_pert_fac*QC(:,N) + + DummyZ0T(:,N) = Z0T(:,N) + + CALL helfsurface(UWINDLMTILE,VWINDLMTILE,TA,TC(:,N) ,QA,QC(:,N)+DeltaQC(:,N),PSL,PSMB,DummyZ0T(:,N),lai, & + IWATER,DZE,niter,nt,RHOH,VKH,VKM,USTAR,XX,YY,CU,CT,RIB,ZETA,WS, & + t2m,q2m,u2m,v2m,t10m,q10m,u10m,v10m,u50m,v50m,CHOOSEZ0) + + CQpert( :,N) = VKH + + end if ! MOSFC_EXTRA_DERIVS_OFFL_LAND==2 + + ! Call with nominal inputs [after calls with perturbed inputs to obtain correct outputs (Z0T, [*]2m, [*]10m, etc.)] + + CALL helfsurface(UWINDLMTILE,VWINDLMTILE,TA,TC(:,N),QA,QC(:,N),PSL,PSMB,Z0T(:,N),lai, & + IWATER,DZE,niter,nt,RHOH,VKH,VKM,USTAR,XX,YY,CU,CT,RIB,ZETA,WS, & + t2m,q2m,u2m,v2m,t10m,q10m,u10m,v10m,u50m,v50m,CHOOSEZ0) + + CM(:,N) = VKM + CH(:,N) = VKH + CQ(:,N) = VKH + + CN = (MAPL_KARMAN/ALOG(DZE/Z0T(:,N) + 1.0)) * (MAPL_KARMAN/ALOG(DZE/Z0T(:,N) + 1.0)) + ZT = Z0T(:,N) + ZQ = Z0T(:,N) + RE = 0. + UUU = UU + UCN = 0. + ! Aggregate to tiles for MO only diagnostics !-------------------------------------------- - if(associated(MOU50M))MOU50M = MOU50M + U50M(:)*FR(:,N) - if(associated(MOV50M))MOV50M = MOV50M + V50M(:)*FR(:,N) - if(associated(MOT10M))MOT10M = MOT10M + T10M(:)*FR(:,N) - if(associated(MOQ10M))MOQ10M = MOQ10M + Q10M(:)*FR(:,N) - if(associated(MOU10M))MOU10M = MOU10M + U10M(:)*FR(:,N) - if(associated(MOV10M))MOV10M = MOV10M + V10M(:)*FR(:,N) - if(associated(MOT2M))MOT2M = MOT2M + T2M(:)*FR(:,N) - if(associated(MOQ2M))MOQ2M = MOQ2M + Q2M(:)*FR(:,N) - if(associated(MOU2M))MOU2M = MOU2M + U2M(:)*FR(:,N) - if(associated(MOV2M))MOV2M = MOV2M + V2M(:)*FR(:,N) + if(associated(MOU50M))MOU50M = MOU50M + U50M(:)*FR(:,N) + if(associated(MOV50M))MOV50M = MOV50M + V50M(:)*FR(:,N) + if(associated(MOT10M))MOT10M = MOT10M + T10M(:)*FR(:,N) + if(associated(MOQ10M))MOQ10M = MOQ10M + Q10M(:)*FR(:,N) + if(associated(MOU10M))MOU10M = MOU10M + U10M(:)*FR(:,N) + if(associated(MOV10M))MOV10M = MOV10M + V10M(:)*FR(:,N) + if(associated(MOT2M ))MOT2M = MOT2M + T2M( :)*FR(:,N) + if(associated(MOQ2M ))MOQ2M = MOQ2M + Q2M( :)*FR(:,N) + if(associated(MOU2M ))MOU2M = MOU2M + U2M( :)*FR(:,N) + if(associated(MOV2M ))MOV2M = MOV2M + V2M( :)*FR(:,N) + + endif ! CHOOSEMOSFC + + if (CATCH_INTERNAL_STATE%MOSFC_EXTRA_DERIVS_OFFL_LAND==2) then + + ! finalize numerical derivatives + + delCH_delTC(:,N) = (CHpert(:,N) - CH(:,N)) / DeltaTC(:,N) + delCQ_delQC(:,N) = (CQpert(:,N) - CQ(:,N)) / DeltaQC(:,N) + + elseif (CATCH_INTERNAL_STATE%MOSFC_EXTRA_DERIVS_OFFL_LAND==3) then + + ! finalize numerical derivatives (valid for Louis only!) + + ! For Louis, the exchange coeffs depend only on the *virtual* temperature (not true for Helfand). + ! + ! This lets us compute the derivatives of the exchange coefficients w.r.t. both TC and QC from + ! just one additional call to louissurface() with perturbed TC. + ! + ! In the following, "del" indicates a derivative and "Delta" indicates a difference term. + ! + ! We have: + ! + ! (1) CH = CQ + ! + ! (2) TVC = TC*(1 + eps*QC) (virtual temperature; eps = MAPL_VIREPS) + ! + ! (2a) ==> delTVC_delQC = eps*TC + ! + ! (2b) ==> DeltaTVC = (TVCpert - TVC) = TCpert*(1 + eps*QC) - TC*(1 + eps*QC) = DeltaTC*(1 + eps*QC) + ! + ! (3) delCH_delTC = (CHpert - CH)/DeltaTC + ! + ! (4) delCH_delTVC = (CHpert - CH)/DeltaTVC = (CHpert - CH)/(DeltaTC*(1 + eps*QC)) + ! + ! Using (1)-(4), we have: + ! + ! delCQ_delQC = delCH_delQC using (1) + ! + ! = delCH_delTVC * delTVC_delQC using chain rule + ! + ! = (CHpert - CH)/(DeltaTC*(1 + eps*QC)) * delTVC_delQC using (4) + ! + ! = (CHpert - CH)/DeltaTC * 1/(1+eps*QC) * eps*TC using (2a) + ! + ! = delCH_delTC * 1/(1+eps*QC) * eps*TC using (3) + + delCH_delTC(:,N) = (CHpert(:,N) - CH(:,N)) / DeltaTC(:,N) + delCQ_delQC(:,N) = delCH_delTC(:,N) * MAPL_VIREPS*TC(:,N)/(1.+MAPL_VIREPS*QC(:,N)) + endif + call MAPL_TimerOff(MAPL,"-SURF") ! Aggregate to tile @@ -3653,9 +3876,17 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) deallocate(IWATER) deallocate(PSMB) deallocate(PSL) + if (CATCH_INTERNAL_STATE%MOSFC_EXTRA_DERIVS_OFFL_LAND>=2) then + deallocate(DeltaTC ) + deallocate(DeltaQC ) + deallocate(CHpert ) + deallocate(CQpert ) + deallocate(dummyZ0T) + deallocate(dummyCM ) + end if -! All done -! ------------------------------------------------------------------------------ + ! All done + ! ------------------------------------------------------------------------------ call MAPL_TimerOff ( MAPL, "RUN1" ) call MAPL_TimerOff ( MAPL, "TOTAL" ) @@ -3692,17 +3923,17 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) ! Local derived type aliases ! ------------------------------------------------------------------------------ - type(MAPL_MetaComp),pointer :: MAPL - type(ESMF_Alarm) :: ALARM + type(MAPL_MetaComp),pointer :: MAPL + type(ESMF_Alarm) :: ALARM - integer :: IM,JM - integer :: incl_Louis_extra_derivs - real :: SCALE4ZVG - real :: SCALE4Z0_u - real :: MIN_VEG_HEIGHT - type(ESMF_VM) :: VM - type (T_CATCH_STATE), pointer :: CATCH_INTERNAL_STATE - type (CATCH_WRAP) :: wrap + integer :: IM,JM + + real :: SCALE4ZVG + real :: SCALE4Z0_u + real :: MIN_VEG_HEIGHT + type(ESMF_VM) :: VM + type (T_CATCH_STATE), pointer :: CATCH_INTERNAL_STATE + type (CATCH_WRAP) :: wrap ! ------------------------------------------------------------------------------ ! Begin: Get the target components name and @@ -3730,9 +3961,6 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_Get(MAPL, RUNALARM=ALARM, RC=STATUS) VERIFY_(STATUS) - call MAPL_GetResource ( MAPL, incl_Louis_extra_derivs, Label="INCL_LOUIS_EXTRA_DERIVS:", DEFAULT=1, RC=STATUS) - VERIFY_(STATUS) - call ESMF_VMGetCurrent(VM, rc=STATUS) select case (CATCH_INTERNAL_STATE%Z0_FORMULATION) @@ -3918,8 +4146,10 @@ subroutine Driver ( RC ) real, dimension(:,:), pointer :: cm real, dimension(:,:), pointer :: cq real, dimension(:,:), pointer :: fr - real, dimension(:,:), pointer :: dcq - real, dimension(:,:), pointer :: dch + real, dimension(:,:), pointer :: delCQ_delTVA + real, dimension(:,:), pointer :: delCH_delTVA + real, dimension(:,:), pointer :: delCH_delTC + real, dimension(:,:), pointer :: delCQ_delQC real, dimension(:,:), pointer :: RDU001 real, dimension(:,:), pointer :: RDU002 real, dimension(:,:), pointer :: RDU003 @@ -4106,7 +4336,7 @@ subroutine Driver ( RC ) real,pointer,dimension(:,:) :: evsbt real,pointer,dimension(:,:) :: devsbt real,pointer,dimension(:,:) :: DEDTC - real,pointer,dimension(:,:) :: DHSDQA + real,pointer,dimension(:,:) :: DHSDQC real,pointer,dimension(:,:) :: CFT real,pointer,dimension(:,:) :: RA real,pointer,dimension(:,:) :: CFQ @@ -4472,8 +4702,19 @@ subroutine Driver ( RC ) call MAPL_GetPointer(INTERNAL,CM ,'CM' ,RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(INTERNAL,CQ ,'CQ' ,RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(INTERNAL,FR ,'FR' ,RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL,DCQ ,'DCQ' ,RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL,DCH ,'DCH' ,RC=STATUS); VERIFY_(STATUS) + + if (CATCH_INTERNAL_STATE%MOSFC_EXTRA_DERIVS_OFFL_LAND == 1) then + + call MAPL_GetPointer(INTERNAL,delCQ_delTVA ,'delCQ_delTVA' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,delCH_delTVA ,'delCH_delTVA' ,RC=STATUS); VERIFY_(STATUS) + + elseif (CATCH_INTERNAL_STATE%MOSFC_EXTRA_DERIVS_OFFL_LAND >= 2) then + + call MAPL_GetPointer(INTERNAL,delCH_delTC ,'delCH_delTC' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,delCQ_delQC ,'delCQ_delQC' ,RC=STATUS); VERIFY_(STATUS) + + end if + if (CATCH_INTERNAL_STATE%N_CONST_LAND4SNWALB /= 0) then call MAPL_GetPointer(INTERNAL,RDU001 ,'RDU001' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(INTERNAL,RDU002 ,'RDU002' , RC=STATUS); VERIFY_(STATUS) @@ -4683,7 +4924,7 @@ subroutine Driver ( RC ) allocate(EVSBT (NTILES,NUM_SUBTILES)) allocate(DEVSBT (NTILES,NUM_SUBTILES)) allocate(DEDTC (NTILES,NUM_SUBTILES)) - allocate(DHSDQA (NTILES,NUM_SUBTILES)) + allocate(DHSDQC (NTILES,NUM_SUBTILES)) allocate(CFT (NTILES,NUM_SUBTILES)) allocate(CFQ (NTILES,NUM_SUBTILES)) allocate(TCO (NTILES,NUM_SUBTILES)) @@ -4904,9 +5145,11 @@ subroutine Driver ( RC ) !--------------- GOSWIM IMPORTS FROM GOCART --------------- ! Initialization - RCONSTIT(:,:,:) = 0.0 - TOTDEPOS(:,:) = 0.0 - RMELT(:,:) = 0.0 + if (N_constit>0) then + RCONSTIT(:,:,:) = 0.0 + TOTDEPOS(:,:) = 0.0 + RMELT(:,:) = 0.0 + end if !------------------------------------------------------------------ ! Zero the light-absorbing aerosol (LAA) deposition rates from GOCART: @@ -4946,6 +5189,8 @@ subroutine Driver ( RC ) end select + if (CATCH_INTERNAL_STATE%N_CONST_LAND4SNWALB /= 0) then + ! Convert the dimentions for LAAs from GEOS_SurfGridComp.F90 to GEOS_LandIceGridComp.F90 ! Note: Explanations of each variable ! TOTDEPOS(:,1): Combined dust deposition from size bin 1 (dry, conv-scav, ls-scav, sed) @@ -5005,7 +5250,6 @@ subroutine Driver ( RC ) ! RCONSTIT(NTILES,N,14): Sea salt mass from size bin 4 in layer N ! RCONSTIT(NTILES,N,15): Sea salt mass from size bin 5 in layer N - if (CATCH_INTERNAL_STATE%N_CONST_LAND4SNWALB /= 0) then RCONSTIT(:,:,1) = RDU001(:,:) RCONSTIT(:,:,2) = RDU002(:,:) RCONSTIT(:,:,3) = RDU003(:,:) @@ -5103,44 +5347,140 @@ subroutine Driver ( RC ) RDC = max(VGRDA(VEG)*min(1., LAI/VGRDB(VEG)),0.001) RHO = PS/(MAPL_RGAS*(TA*(1+MAPL_VIREPS*QA))) - DEDTC=0.0 - DHSDQA=0.0 - if(CATCH_INTERNAL_STATE%CATCH_OFFLINE /=0) then + !-------------------------------------------------------------------------------------------------------- + ! + ! MOSFC variable names and description: + ! + !-------------------------------------------------------------------------------------------------------- + ! GEOS_CatchGridComp.F90 | catchment.F90 | dimension | Description + !-------------------------------------------------------------------------------------------------------- + ! TA | TM | NT | surface (lowest model level) air temperature + ! QA | QM | NT | surface (lowest model level) air spec humidity + !-------------------------------------------------------------------------------------------------------- + ! TC | TC | NT-by-NSBT | canopy (air) temperature + ! QC | QA (!) | NT-by-NSBT | canopy (air) specific humidity + ! CH | - | NT-by-NSBT | exchange coeff for heat + ! CQ | - | NT-by-NSBT | exchange coeff for humidity + ! EVSBT | ETURB | NT-by-NSBT | evaporation + ! DEVSBT | DEDQA | NT-by-NSBT | deriv of evap w.r.t. canopy spec humidity + ! DEDTC | DEDTC | NT-by-NSBT | deriv of evap w.r.t. canopy temperature + ! SHSBT | HSTURB | NT-by-NSBT | sensible heat flux (SH) + ! DHSDQC (formerly DHSDQA) | DHSDQA | NT-by-NSBT | deriv of SH w.r.t. canopy spec humidity + ! DSHSBT | DHSDTC | NT-by-NSBT | deriv of SH w.r.t. canopy temperature + !-------------------------------------------------------------------------------------------------------- + ! *SBT = sub-tile (?) + ! NT = number of tiles + ! NSBT = number of subtiles (per tile) + ! + ! For land, CH = CQ in Helfand and Louis. + ! + ! + ! MOSFC equations: + ! + ! EVSBT = CQ * (QC - QA) + ! SHSBT = Cp * CH * (TC - TA) [ Cp = MAPL_CP ] + ! + ! Derivatives obtained via product rule. See equations below. + ! + ! For analytical derivatives, additionally use the following identities: + ! + ! virtual TC: TVC = TC*(1 + eps)*QC [ eps = MAPL_VIREPS ] + ! virtual TA: TVA = TA*(1 + eps)*QA + ! + ! delTVC_delQC = TC*eps + ! delTVC_delTC = (1 + eps) + ! + ! delCQ_delQC = delCQ_delTVC * delTVC_delQC + ! delCH_delTC = delCH_delTVC * delTVC_delTC + ! + ! CQ=CQ(Ri) where Ri is proportional to deltaTVA=TVA-TVC --> produces a minus sign + ! + ! delCQ_delTVC = -1*delCQ_delTVA + ! delCH_delTVC = -1*delCH_delTVA + ! + !-------------------------------------------------------------------------------------------------- + ! reichle, 9/9/2024 + !-------------------------------------------------------------------------------------------------- + + ! initialize derivatives that may not be filled later + + DEDTC =0.0 + DHSDQC=0.0 + + if (CATCH_INTERNAL_STATE%CATCH_OFFLINE /=0) then + + ! Catchment in offline (land-only) mode + do N=1,NUM_SUBTILES - CFT (:,N) = 1.0 - CFQ (:,N) = 1.0 - SHSBT (:,N) = MAPL_CP*CH(:,N)*(TC(:,N)-TA) - EVSBT (:,N) = CQ(:,N)*(QC(:,N)-QA) - DSHSBT(:,N) = MAPL_CP*CH(:,N) - DEVSBT(:,N) = CQ(:,N) - BLWN(:,N) = EMIS*MAPL_STFBOL*TC(:,N)*TC(:,N)*TC(:,N) - ALWN(:,N) = -3.0*BLWN(:,N)*TC(:,N) - BLWN(:,N) = 4.0*BLWN(:,N) + + CFT (:,N) = 1.0 + CFQ (:,N) = 1.0 + + SHSBT(:,N) = MAPL_CP*CH(:,N)*(TC(:,N)-TA) + EVSBT(:,N) = CQ(:,N)*(QC(:,N)-QA) + + BLWN( :,N) = EMIS*MAPL_STFBOL*TC(:,N)*TC(:,N)*TC(:,N) + ALWN( :,N) = -3.0*BLWN(:,N)*TC(:,N) + BLWN( :,N) = 4.0*BLWN(:,N) + end do - if(CATCH_INTERNAL_STATE%CHOOSEMOSFC==0 .and. incl_Louis_extra_derivs ==1) then + + select case (CATCH_INTERNAL_STATE%MOSFC_EXTRA_DERIVS_OFFL_LAND) + + case (0) ! ignore derivatives of exchange coeffs w.r.t. canopy temp and specific humidity + + do N=1,NUM_SUBTILES + DEVSBT(:,N) = CQ(:,N) + DSHSBT(:,N) = MAPL_CP* CH(:,N) + end do + + case (1) ! Louis only: analytical derivatives of exchange coeffs w.r.t. canopy temp and specific humidity + + _ASSERT( CATCH_INTERNAL_STATE%CHOOSEMOSFC==0, 'must use Louis scheme for MOSFC analytical derivatives' ) + + do N=1,NUM_SUBTILES + DEVSBT(:,N) = CQ(:,N) + max( 0.0, -delCQ_delTVA(:,N)* MAPL_VIREPS*TC(:,N) *(QC(:,N)-QA) ) + DEDTC( :,N) = max( 0.0, -delCQ_delTVA(:,N)*(1.+MAPL_VIREPS*QC(:,N))*(QC(:,N)-QA) ) + DSHSBT(:,N) = MAPL_CP*( CH(:,N) + max( 0.0, -delCH_delTVA(:,N)*(1.+MAPL_VIREPS*QC(:,N))*(TC(:,N)-TA) ) ) + DHSDQC(:,N) = max( 0.0, -MAPL_CP*delCH_delTVA(:,N)* MAPL_VIREPS*TC(:,N) *(TC(:,N)-TA) ) + end do + + case (2,3) ! numerical derivatives of exchange coeffs w.r.t. canopy temp and specific humidity + do N=1,NUM_SUBTILES - DEVSBT(:,N)=CQ(:,N)+max(0.0,-DCQ(:,N)*MAPL_VIREPS*TC(:,N)*(QC(:,N)-QA)) - DEDTC(:,N) =max(0.0,-DCQ(:,N)*(1.+MAPL_VIREPS*QC(:,N))*(QC(:,N)-QA)) - DSHSBT(:,N)=MAPL_CP*(CH(:,N)+max(0.0,-DCH(:,N)*(1.+MAPL_VIREPS*QC(:,N))*(TC(:,N)-TA))) - DHSDQA(:,N)=max(0.0,-MAPL_CP*DCH(:,N)*MAPL_VIREPS*TC(:,N)*(TC(:,N)-TA)) - enddo - endif - ! BLWX = EMIS*MAPL_STFBOL*TA*TA*TA - ! ALWX = -3.0*BLWX*TA - ! BLWX = 4.0*BLWX + DEVSBT(:,N) = CQ(:,N) + max( 0.0, delCQ_delQC( :,N)* (QC(:,N)-QA) ) + DEDTC( :,N) = max( 0.0, delCH_delTC( :,N)* (QC(:,N)-QA) ) + DSHSBT(:,N) = MAPL_CP*( CH(:,N) + max( 0.0, delCH_delTC( :,N)* (TC(:,N)-TA) ) ) + DHSDQC(:,N) = max( 0.0, MAPL_CP*delCQ_delQC( :,N)* (TC(:,N)-TA) ) + end do + + case default + + _ASSERT(.false., 'unknown MOSFC_EXTRA_DERIVS_OFFL_LAND') + + end select + else + + ! GCM: Catchment coupled to atmosphere + do N=1,NUM_SUBTILES + CFT (:,N) = (CH(:,N)/CTATM) CFQ (:,N) = (CQ(:,N)/CQATM) + SHSBT (:,N) = (SH + DSH *(TC(:,N)-THATM))*CFT(:,N) EVSBT (:,N) = (EVAP+ DEVAP*(QC(:,N)-QHATM))*CFQ(:,N) - DSHSBT(:,N) = DSH *CFT(:,N) - DEVSBT(:,N) = DEVAP*CFQ(:,N) - ALWN(:,N)=ALW - BLWN(:,N)=BLW + DSHSBT(:,N) = DSH * CFT(:,N) + DEVSBT(:,N) = DEVAP* CFQ(:,N) + + ALWN (:,N) = ALW + BLWN (:,N) = BLW + end do - end if + + end if ! Catchment offline ! Compute DQS; make sure QC is between QA and QSAT; compute RA. ! @@ -5149,7 +5489,19 @@ subroutine Driver ( RC ) ! Some 40 lines below, duplicate code was present within #ifdef LAND_UPD block ! (later changed to "if (LAND_FIX)") and was removed in Jan 2022. ! - reichle, 14 Jan 2022. - + ! + ! reichle, 9/9/2024: + ! + ! WHY IS QC RESET *AFTER* IT WAS USED TO CALCULATE THE EXCHANGE COEFFS (AND DERIVS) ABOVE??? + ! + ! For reference, the following comment was copied from from LDASsa m3-16, specifically, from + ! reichle-LDASsa_m3-16_6/src/Components/GEOSlana_GridComp/process_cat.F90 (Lines 330-333): + ! + ! ! compute surface exchange coefficients etc BEFORE possibly resetting + ! ! profile of Qair-QAx-Qsat(surf) -- for consistency with two-stage + ! ! run-method in GEOS_CatchGridComp.F90 + ! ! reichle+qliu, 9 Oct 2008 + do N=1,NUM_SUBTILES DQS(:,N) = GEOS_DQSAT ( TC(:,N), PS, QSAT=QSAT(:,N), PASCALS=.true., RAMP=0.0 ) QC (:,N) = min(max(QA(:),QSAT(:,N)),QC(:,N)) @@ -5159,15 +5511,27 @@ subroutine Driver ( RC ) QC(:,FSNW) = QSAT(:,FSNW) -! -------------------------------------------------------------------------- + ! -------------------------------------------------------------------------- ! get total solid precip ! -------------------------------------------------------------------------- - SLDTOT = SNO+ICE+FRZR + SLDTOT = SNO+ICE ! do *not* add FRZR (freezing rain) to solid precip, see comment below + + ! FRZR (freezing rain) is rain that falls as super-cooled liquid water, which freezes upon + ! impact on a sufficiently cold surface. As such, FRZR is *not* solid precipitation + ! and should be considered rainfall. + ! + ! As of Jun 2025, FRZR is identical to 0 and can be ignored. Looking ahead, make sure to + ! account correctly for FRZR in the input precipitation variables. Once it's filled + ! with non-zero values, FRZR will (probably) be included in PLS+PCU. It is (probably) + ! better to replace PCU & PLS with RAIN and FRZR, where RAIN (probably) does *not* + ! include FRZR and PCU+PLS=RAIN+FRZR (TO BE CONFIRMED!). + ! + ! - reichle, 6/6/2025 -! protect the forcing from unsavory values, as per practice in offline -! driver -! -------------------------------------------------------------------------- + ! protect the forcing from unsavory values, as per practice in offline + ! driver + ! -------------------------------------------------------------------------- _ASSERT(count(PLS<0.)==0,'needs informative message') _ASSERT(count(PCU<0.)==0,'needs informative message') @@ -5215,25 +5579,25 @@ subroutine Driver ( RC ) call MAPL_VarWrite(unit, tilegrid, DEVSBT(:,FSAT), mask=mask, rc=status); VERIFY_(STATUS) call MAPL_VarWrite(unit, tilegrid, DEDTC (:,FSAT), mask=mask, rc=status); VERIFY_(STATUS) call MAPL_VarWrite(unit, tilegrid, SHSBT (:,FSAT), mask=mask, rc=status); VERIFY_(STATUS) - call MAPL_VarWrite(unit, tilegrid, DHSDQA(:,FSAT), mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, DHSDQC(:,FSAT), mask=mask, rc=status); VERIFY_(STATUS) call MAPL_VarWrite(unit, tilegrid, DSHSBT(:,FSAT), mask=mask, rc=status); VERIFY_(STATUS) call MAPL_VarWrite(unit, tilegrid, EVSBT (:,FTRN), mask=mask, rc=status); VERIFY_(STATUS) call MAPL_VarWrite(unit, tilegrid, DEVSBT(:,FTRN), mask=mask, rc=status); VERIFY_(STATUS) call MAPL_VarWrite(unit, tilegrid, DEDTC (:,FTRN), mask=mask, rc=status); VERIFY_(STATUS) call MAPL_VarWrite(unit, tilegrid, SHSBT (:,FTRN), mask=mask, rc=status); VERIFY_(STATUS) - call MAPL_VarWrite(unit, tilegrid, DHSDQA(:,FTRN), mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, DHSDQC(:,FTRN), mask=mask, rc=status); VERIFY_(STATUS) call MAPL_VarWrite(unit, tilegrid, DSHSBT(:,FTRN), mask=mask, rc=status); VERIFY_(STATUS) call MAPL_VarWrite(unit, tilegrid, EVSBT (:,FWLT), mask=mask, rc=status); VERIFY_(STATUS) call MAPL_VarWrite(unit, tilegrid, DEVSBT(:,FWLT), mask=mask, rc=status); VERIFY_(STATUS) call MAPL_VarWrite(unit, tilegrid, DEDTC (:,FWLT), mask=mask, rc=status); VERIFY_(STATUS) call MAPL_VarWrite(unit, tilegrid, SHSBT (:,FWLT), mask=mask, rc=status); VERIFY_(STATUS) - call MAPL_VarWrite(unit, tilegrid, DHSDQA(:,FWLT), mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, DHSDQC(:,FWLT), mask=mask, rc=status); VERIFY_(STATUS) call MAPL_VarWrite(unit, tilegrid, DSHSBT(:,FWLT), mask=mask, rc=status); VERIFY_(STATUS) call MAPL_VarWrite(unit, tilegrid, EVSBT (:,FSNW), mask=mask, rc=status); VERIFY_(STATUS) call MAPL_VarWrite(unit, tilegrid, DEVSBT(:,FSNW), mask=mask, rc=status); VERIFY_(STATUS) call MAPL_VarWrite(unit, tilegrid, DEDTC (:,FSNW), mask=mask, rc=status); VERIFY_(STATUS) call MAPL_VarWrite(unit, tilegrid, SHSBT (:,FSNW), mask=mask, rc=status); VERIFY_(STATUS) - call MAPL_VarWrite(unit, tilegrid, DHSDQA(:,FSNW), mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, DHSDQC(:,FSNW), mask=mask, rc=status); VERIFY_(STATUS) call MAPL_VarWrite(unit, tilegrid, DSHSBT(:,FSNW), mask=mask, rc=status); VERIFY_(STATUS) call MAPL_VarWrite(unit, tilegrid, TA, mask=mask, rc=status); VERIFY_(STATUS) @@ -5624,13 +5988,13 @@ subroutine Driver ( RC ) UUU ,& EVSBT(:,FSAT), DEVSBT(:,FSAT), DEDTC(:,FSAT) ,& - SHSBT(:,FSAT), DHSDQA(:,FSAT), DSHSBT(:,FSAT),& + SHSBT(:,FSAT), DHSDQC(:,FSAT), DSHSBT(:,FSAT),& EVSBT(:,FTRN), DEVSBT(:,FTRN), DEDTC(:,FTRN) ,& - SHSBT(:,FTRN), DHSDQA(:,FTRN), DSHSBT(:,FTRN),& + SHSBT(:,FTRN), DHSDQC(:,FTRN), DSHSBT(:,FTRN),& EVSBT(:,FWLT), DEVSBT(:,FWLT), DEDTC(:,FWLT) ,& - SHSBT(:,FWLT), DHSDQA(:,FWLT), DSHSBT(:,FWLT),& + SHSBT(:,FWLT), DHSDQC(:,FWLT), DSHSBT(:,FWLT),& EVSBT(:,FSNW), DEVSBT(:,FSNW), DEDTC(:,FSNW) ,& - SHSBT(:,FSNW), DHSDQA(:,FSNW), DSHSBT(:,FSNW),& + SHSBT(:,FSNW), DHSDQC(:,FSNW), DSHSBT(:,FSNW),& TA , QA ,& @@ -5933,15 +6297,18 @@ subroutine Driver ( RC ) if(associated(FICE2 )) FICE2 = max( min( FICESOUT(2,:),1.0 ), 0.0 ) if(associated(FICE3 )) FICE3 = max( min( FICESOUT(3,:),1.0 ), 0.0 ) - if(associated(RMELTDU001)) RMELTDU001 = RMELT(:,1) - if(associated(RMELTDU002)) RMELTDU002 = RMELT(:,2) - if(associated(RMELTDU003)) RMELTDU003 = RMELT(:,3) - if(associated(RMELTDU004)) RMELTDU004 = RMELT(:,4) - if(associated(RMELTDU005)) RMELTDU005 = RMELT(:,5) - if(associated(RMELTBC001)) RMELTBC001 = RMELT(:,6) - if(associated(RMELTBC002)) RMELTBC002 = RMELT(:,7) - if(associated(RMELTOC001)) RMELTOC001 = RMELT(:,8) - if(associated(RMELTOC002)) RMELTOC002 = RMELT(:,9) + + if (N_constit>0) then + if(associated(RMELTDU001)) RMELTDU001 = RMELT(:,1) + if(associated(RMELTDU002)) RMELTDU002 = RMELT(:,2) + if(associated(RMELTDU003)) RMELTDU003 = RMELT(:,3) + if(associated(RMELTDU004)) RMELTDU004 = RMELT(:,4) + if(associated(RMELTDU005)) RMELTDU005 = RMELT(:,5) + if(associated(RMELTBC001)) RMELTBC001 = RMELT(:,6) + if(associated(RMELTBC002)) RMELTBC002 = RMELT(:,7) + if(associated(RMELTOC001)) RMELTOC001 = RMELT(:,8) + if(associated(RMELTOC002)) RMELTOC002 = RMELT(:,9) + end if if(associated(DZGT1 )) DZGT1 = DZGT(1) ! [m] if(associated(DZGT2 )) DZGT2 = DZGT(2) ! [m] @@ -6109,7 +6476,7 @@ subroutine Driver ( RC ) deallocate(EVSBT ) deallocate(DEVSBT ) deallocate(DEDTC ) - deallocate(DHSDQA ) + deallocate(DHSDQC ) deallocate(CFT ) deallocate(CFQ ) deallocate(TCO ) @@ -6175,13 +6542,16 @@ subroutine RUN0(gc, import, export, clock, rc) real, pointer :: ps(:)=>null() !! INTERNAL pointers - !! -asnow-emis-ww-fr- + !! -asnow-emis-ww-fr-D[xx] real, pointer :: asnow(:)=>null() real, pointer :: emis(:)=>null() real, pointer :: ww(:,:)=>null() real, pointer :: fr(:,:)=>null() - real, pointer :: DCQ(:,:)=>null() - real, pointer :: DCH(:,:)=>null() + real, pointer :: delCQ_delTVA(:,:)=>null() + real, pointer :: delCH_delTVA(:,:)=>null() + real, pointer :: delCH_delTC(:,:)=>null() + real, pointer :: delCQ_delQC(:,:)=>null() + !! -prognostic-variables- real, pointer :: tc(:,:)=>null() real, pointer :: qc(:,:)=>null() @@ -6261,10 +6631,23 @@ subroutine RUN0(gc, import, export, clock, rc) VERIFY_(status) call MAPL_GetPointer(INTERNAL, ww, 'WW', rc=status) VERIFY_(status) - call MAPL_GetPointer(INTERNAL, DCQ, 'DCQ', rc=status) - VERIFY_(status) - call MAPL_GetPointer(INTERNAL, DCH, 'DCH', rc=status) - VERIFY_(status) + + if (CATCH_INTERNAL_STATE%MOSFC_EXTRA_DERIVS_OFFL_LAND == 1) then + + call MAPL_GetPointer(INTERNAL, delCQ_delTVA, 'delCQ_delTVA', rc=status) + VERIFY_(status) + call MAPL_GetPointer(INTERNAL, delCH_delTVA, 'delCH_delTVA', rc=status) + VERIFY_(status) + + elseif (CATCH_INTERNAL_STATE%MOSFC_EXTRA_DERIVS_OFFL_LAND >= 2) then + + call MAPL_GetPointer(INTERNAL, delCH_delTC, 'delCH_delTC', rc=status) + VERIFY_(status) + call MAPL_GetPointer(INTERNAL, delCQ_delQC, 'delCQ_delQC', rc=status) + VERIFY_(status) + + end if + call MAPL_GetPointer(INTERNAL, tc, 'TC', rc=status) VERIFY_(status) call MAPL_GetPointer(INTERNAL, qc, 'QC', rc=status) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/catchment.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/catchment.F90 index 71485655a..1e3fc38ec 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/catchment.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/catchment.F90 @@ -130,7 +130,8 @@ MODULE CATCHMENT_MODEL SUBROUTINE CATCHMENT ( & NCH, LONS, LATS, DTSTEP, UFW4RO, FWETC, FWETL, & ! LONS, LATS are in [radians] !!! - cat_id,ITYP,DZSF,TRAINC,TRAINL, TSNOW, TICE, TFRZR, UM, & ! cat_id is set to no-data in GEOS_CatchGridcomp; DZSF in [mm] !!! + cat_id,ITYP,DZSF, & ! cat_id is set to no-data in GEOS_CatchGridcomp; DZSF in [mm] !!! + TRAINC,TRAINL, TSNOW, TICE, TFRZR, UM, & ! TFRZR=0 as of Jun 2025; needs attention if ever TFRZR/=0 ETURB1, DEDQA1, DEDTC1, HSTURB1,DHSDQA1, DHSDTC1, & ETURB2, DEDQA2, DEDTC2, HSTURB2,DHSDQA2, DHSDTC2, & ETURB4, DEDQA4, DEDTC4, HSTURB4,DHSDQA4, DHSDTC4, & @@ -845,8 +846,8 @@ SUBROUTINE CATCHMENT ( & END IF AREA(2)= AR2(N) AREA(3)= AR4(N) - pr = trainc(n)+trainl(n)+tsnow(n)+tice(n)+tfrzr(n) - snowf = tsnow(n)+tice(n)+tfrzr(n) + pr = trainc(n)+trainl(n)+tsnow(n)+tice(n) ! see comment re. FRZR in GEOS_CatchGridComp.F90 by reichle, 6/6/2025: + snowf = tsnow(n)+tice(n) ! freezing rain is liquid not solid, (probably) included in trainl+trainc dedea = dedqas(n)*epsilon/psur(n) dhsdea = dhsdqas(n)*epsilon/psur(n) ea = qm(n)*psur(n)/epsilon @@ -1302,7 +1303,7 @@ SUBROUTINE CATCHMENT ( & !FSW_CHANGE IS THE CHANGE IN THE FREE-STANDING WATER, RELEVANT FOR PEATLAND ONLY FSW_CHANGE(N) = 0. IF(POROS(N) >= PEATCLSM_POROS_THRESHOLD) THEN - pr = trainc(n)+trainl(n)+tsnow(n)+tice(n)+tfrzr(n) + pr = trainc(n)+trainl(n)+tsnow(n)+tice(n) ! see comment re. FRZR in GEOS_CatchGridComp.F90 by reichle, 6/6/2025 FSW_CHANGE(N) = PR - EVAP(N) - RUNOFF(N) - WCHANGE(N) ENDIF diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 index ad2be4db2..4a28c0da2 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 @@ -178,7 +178,7 @@ subroutine SetServices ( GC, RC ) ! ----------------------------------------------------------- call MAPL_AddImportSpec(GC, & - LONG_NAME = 'runoff_flux' ,& + LONG_NAME = 'runoff_total_flux' ,& UNITS = 'kg m-2 s-1' ,& SHORT_NAME = 'RUNOFF' ,& DIMS = MAPL_DimsTileOnly ,& diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSvegdyn_GridComp/GEOS_VegdynGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSvegdyn_GridComp/GEOS_VegdynGridComp.F90 index 83e575269..063d9ab13 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSvegdyn_GridComp/GEOS_VegdynGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSvegdyn_GridComp/GEOS_VegdynGridComp.F90 @@ -217,7 +217,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC ,& SHORT_NAME = 'GRN' ,& - LONG_NAME = 'greeness_fraction' ,& + LONG_NAME = 'vegetation_greenness_fraction' ,& UNITS = '1' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/Shared/catch_wrap_state.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/Shared/catch_wrap_state.F90 index cb9af81e0..4c50fedcd 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/Shared/catch_wrap_state.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/Shared/catch_wrap_state.F90 @@ -12,7 +12,9 @@ module catch_wrap_stateMod type T_CATCH_STATE type (ESMF_FieldBundle) :: Bundle + ! logical :: LDAS_CORRECTOR + ! ! CATCH_OFFLINE: ! 0: DEFAULT for GCM, (WW,CH,CM,CQ,FR) are required in Catchment restart file ! 1: DEFAULT for GEOSldas, (WW,CH,CM,CQ,FR) are optional @@ -21,10 +23,11 @@ module catch_wrap_stateMod ! see also GEOSldas repo: src/Applications/LDAS_App/GEOSldas_LDAS.rc integer :: CATCH_OFFLINE ! - ! resource parameters from GEOS_SurfaceGridComp.rc integer :: CATCH_SPINUP + ! + ! some (but not all) resource parameters from GEOS_SurfaceGridComp.rc: integer :: USE_ASCATZ0, Z0_FORMULATION, AEROSOL_DEPOSITION, N_CONST_LAND4SNWALB - integer :: CHOOSEMOSFC, SNOW_ALBEDO_INFO + integer :: CHOOSEMOSFC, MOSFC_EXTRA_DERIVS_OFFL_LAND, SNOW_ALBEDO_INFO real :: SURFLAY real :: FWETC, FWETL logical :: USE_FWET_FOR_RUNOFF @@ -36,6 +39,7 @@ module catch_wrap_stateMod end type CATCH_WRAP type, extends(T_CATCH_STATE) :: T_CATCHCN_STATE + ! resource parameters from GEOS_SurfaceGridComp.rc: integer :: ATM_CO2, PRESCRIBE_DVG real :: CO2 integer :: CO2_YEAR_IN @@ -50,21 +54,79 @@ module catch_wrap_stateMod subroutine surface_params_to_wrap_state(statePtr, scf, rc) - ! *********************************************** ! - ! see GEOS_SurfaceGridComp.rc for documentation ! - ! *********************************************** ! + ! obtain resource variables from "SURFRC" file; they are ultimately stored in CATCH_INTERNAL_STATE or CATCHCN_INTERNAL_STATE - class(T_CATCH_STATE), pointer, intent(inout) :: statePtr - type(ESMF_Config), intent(inout) :: SCF - integer, optional, intent(out) :: rc + class(T_CATCH_STATE), pointer, intent(inout) :: statePtr + type(ESMF_Config), intent(inout) :: SCF + integer, optional, intent( out) :: rc + real :: FWETC_default, FWETL_default - integer:: status + integer:: status, ii - call MAPL_GetResource( SCF, statePtr%SURFLAY, label='SURFLAY:', DEFAULT=50., __RC__ ) - call MAPL_GetResource( SCF, statePtr%USE_ASCATZ0, label='USE_ASCATZ0:', DEFAULT=0, __RC__ ) - call MAPL_GetResource( SCF, statePtr%CHOOSEMOSFC, label='CHOOSEMOSFC:', DEFAULT=1, __RC__ ) - call MAPL_GetResource( SCF, statePtr%USE_FWET_FOR_RUNOFF, label='USE_FWET_FOR_RUNOFF:', DEFAULT=.FALSE., __RC__ ) - call MAPL_GetResource( SCF, statePtr%Z0_FORMULATION, label='Z0_FORMULATION:', DEFAULT=4, __RC__ ) + ! ************************************************* ! + ! For documentation, see GEOS_SurfaceGridComp.rc. ! + ! ************************************************* ! + + call MAPL_GetResource( SCF, statePtr%SURFLAY, label='SURFLAY:', DEFAULT=50., __RC__ ) + call MAPL_GetResource( SCF, statePtr%USE_ASCATZ0, label='USE_ASCATZ0:', DEFAULT=0, __RC__ ) + call MAPL_GetResource( SCF, statePtr%CHOOSEMOSFC, label='CHOOSEMOSFC:', DEFAULT=1, __RC__ ) + + ! MOSFC_EXTRA_DERIVS_OFFL_LAND: Resource parameter for *offline* (LDAS) mode. + ! + ! Over *land*, use derivatives of exchange coeffs w.r.t. temp. & humidity. + ! + ! 0 : None, default for Helfand. + ! 1 : Analytical derivs, default for Louis, *not* available for Helfand. + ! 2 : Numerical derivs. + ! 3 : Numerical derivs, via virtual temp., *not* available for Helfand, same as 2 but faster than 2. + ! + ! Runtimes: Helfand takes ~10 times longer than Louis. In offline mode, Helfand consumes + ! about as much CPU as Catchment. Option 2 triples the runtime of the MOSFC scheme. + ! Option 3 doubles the runtime of the Louis scheme. + + if (statePtr%CATCH_OFFLINE==0) then + + statePtr%MOSFC_EXTRA_DERIVS_OFFL_LAND = 0 ! must be 0 for GCM + + else + + ! offline (LDAS) mode; default for MOSFC_EXTRA_DERIVS_OFFL_LAND depends on CHOOSEMOSFC (Louis or Helfand) + + if (statePtr%CHOOSEMOSFC==0) then + + ! Louis + call MAPL_GetResource( SCF, statePtr%MOSFC_EXTRA_DERIVS_OFFL_LAND, label='MOSFC_EXTRA_DERIVS_OFFL_LAND:', DEFAULT=1, __RC__ ) + ! make sure parameter value is allowed + ii = statePtr%MOSFC_EXTRA_DERIVS_OFFL_LAND ; _ASSERT(ii>=0 .and. ii<=3, 'unknown MOSFC_EXTRA_DERIVS_OFFL_LAND for Louis ') + + elseif (statePtr%CHOOSEMOSFC==1) then + + ! Helfand + call MAPL_GetResource( SCF, statePtr%MOSFC_EXTRA_DERIVS_OFFL_LAND, label='MOSFC_EXTRA_DERIVS_OFFL_LAND:', DEFAULT=0, __RC__ ) + ! make sure parameter value is allowed (analytical derivs not implemented for Helfand) + ii = statePtr%MOSFC_EXTRA_DERIVS_OFFL_LAND ; _ASSERT(ii==0 .or. ii==2, 'unknown MOSFC_EXTRA_DERIVS_OFFL_LAND for Helfand') + + else + + _ASSERT(.FALSE.,'unknown CHOOSEMOSFC') + + end if + + end if + + ! for CatchCN, must have MOSFC_EXTRA_DERIVS_OFFL_LAND<=1 (numerical derivatives not yet implemented for CatchCN) + + select type (statePtr) + type is (T_CATCHCN_STATE) ! CATCHCN + + _ASSERT( statePtr%MOSFC_EXTRA_DERIVS_OFFL_LAND<=1, 'selected choice for MOSFC_EXTRA_DERIVS_OFFL_LAND not yet implemented for CatchCN') + + end select + + ! ------------------------- + + call MAPL_GetResource( SCF, statePtr%USE_FWET_FOR_RUNOFF, label='USE_FWET_FOR_RUNOFF:', DEFAULT=.FALSE., __RC__ ) + call MAPL_GetResource( SCF, statePtr%Z0_FORMULATION, label='Z0_FORMULATION:', DEFAULT=4, __RC__ ) if (.NOT. statePtr%USE_FWET_FOR_RUNOFF) then FWETC_default = 0.02 @@ -73,22 +135,23 @@ subroutine surface_params_to_wrap_state(statePtr, scf, rc) FWETC_default = 0.005 ! NOT ready for science! FWETL_default = 0.025 ! NOT ready for science! endif - call MAPL_GetResource( SCF, statePtr%FWETC, label='FWETC:', DEFAULT=FWETC_default, __RC__ ) - call MAPL_GetResource( SCF, statePtr%FWETL, label='FWETL:', DEFAULT=FWETL_default, __RC__ ) - call MAPL_GetResource( SCF, statePtr%SNOW_ALBEDO_INFO, label='SNOW_ALBEDO_INFO:', DEFAULT=0, __RC__ ) - call MAPL_GetResource( SCF, statePtr%N_CONST_LAND4SNWALB, label='N_CONST_LAND4SNWALB:', DEFAULT=0, __RC__ ) - call MAPL_GetResource( SCF, statePtr%AEROSOL_DEPOSITION, label='AEROSOL_DEPOSITION:', DEFAULT=0, __RC__ ) - call MAPL_GetResource( SCF, statePtr%RUN_IRRIG, label='RUN_IRRIG:', DEFAULT=0, __RC__ ) - call MAPL_GetResource( SCF, statePtr%IRRIG_METHOD, label='IRRIG_METHOD:', DEFAULT=0, __RC__ ) + + call MAPL_GetResource( SCF, statePtr%FWETC, label='FWETC:', DEFAULT=FWETC_default, __RC__ ) + call MAPL_GetResource( SCF, statePtr%FWETL, label='FWETL:', DEFAULT=FWETL_default, __RC__ ) + call MAPL_GetResource( SCF, statePtr%SNOW_ALBEDO_INFO, label='SNOW_ALBEDO_INFO:', DEFAULT=0, __RC__ ) + call MAPL_GetResource( SCF, statePtr%N_CONST_LAND4SNWALB, label='N_CONST_LAND4SNWALB:', DEFAULT=0, __RC__ ) + call MAPL_GetResource( SCF, statePtr%AEROSOL_DEPOSITION, label='AEROSOL_DEPOSITION:', DEFAULT=0, __RC__ ) + call MAPL_GetResource( SCF, statePtr%RUN_IRRIG, label='RUN_IRRIG:', DEFAULT=0, __RC__ ) + call MAPL_GetResource( SCF, statePtr%IRRIG_METHOD, label='IRRIG_METHOD:', DEFAULT=0, __RC__ ) select type (statePtr) type is (T_CATCHCN_STATE) ! CATCHCN - call MAPL_GetResource( SCF, statePtr%DTCN, label='DTCN:', DEFAULT=5400., __RC__ ) - call MAPL_GetResource( SCF, statePtr%ATM_CO2, label='ATM_CO2:', DEFAULT=2, __RC__ ) - call MAPL_GetResource( SCF, statePtr%PRESCRIBE_DVG, label='PRESCRIBE_DVG:', DEFAULT=0, __RC__ ) - call MAPL_GetResource( SCF, statePtr%CO2, label='CO2:', DEFAULT=350.e-6, __RC__ ) - call MAPL_GetResource( SCF, statePtr%CO2_YEAR_IN, label='CO2_YEAR:', DEFAULT=-9999, __RC__ ) + call MAPL_GetResource( SCF, statePtr%DTCN, label='DTCN:', DEFAULT=5400., __RC__ ) + call MAPL_GetResource( SCF, statePtr%ATM_CO2, label='ATM_CO2:', DEFAULT=2, __RC__ ) + call MAPL_GetResource( SCF, statePtr%PRESCRIBE_DVG, label='PRESCRIBE_DVG:', DEFAULT=0, __RC__ ) + call MAPL_GetResource( SCF, statePtr%CO2, label='CO2:', DEFAULT=350.e-6, __RC__ ) + call MAPL_GetResource( SCF, statePtr%CO2_YEAR_IN, label='CO2_YEAR:', DEFAULT=-9999, __RC__ ) end select diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSlandice_GridComp/GEOS_LandIceGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSlandice_GridComp/GEOS_LandIceGridComp.F90 index 96841911a..c22870a00 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSlandice_GridComp/GEOS_LandIceGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSlandice_GridComp/GEOS_LandIceGridComp.F90 @@ -198,7 +198,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'surface_albedo_for_visible_beam', & + LONG_NAME = 'surface_reflectivity_for_visible_beam', & UNITS = '1', & SHORT_NAME = 'ALBVR', & DIMS = MAPL_DimsTileOnly, & @@ -207,7 +207,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'surface_albedo_for_visible_diffuse',& + LONG_NAME = 'surface_reflectivity_for_visible_diffuse',& UNITS = '1', & SHORT_NAME = 'ALBVF', & DIMS = MAPL_DimsTileOnly, & @@ -216,7 +216,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'surface_albedo_for_near_infrared_beam', & + LONG_NAME = 'surface_reflectivity_for_near_infrared_beam', & UNITS = '1', & SHORT_NAME = 'ALBNR', & DIMS = MAPL_DimsTileOnly, & @@ -225,7 +225,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'surface_albedo_for_near_infrared_diffuse', & + LONG_NAME = 'surface_reflectivity_for_near_infrared_diffuse', & UNITS = '1', & SHORT_NAME = 'ALBNF', & DIMS = MAPL_DimsTileOnly, & @@ -235,7 +235,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'TST', & - LONG_NAME = 'surface_skin_temperature', & + LONG_NAME = 'surface_temperature', & UNITS = 'K', & DIMS = MAPL_DimsTileOnly, & VLOCATION = MAPL_VLocationNone, & @@ -397,7 +397,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'fractional_area_of_glaciated_surface_snowcover',& + LONG_NAME = 'fractional_snow_covered_area_of_glaciated_surface',& UNITS = '1' ,& SHORT_NAME = 'ASNOW_GL' ,& DIMS = MAPL_DimsTileOnly ,& @@ -485,7 +485,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'top_snow_layer_mass_change_due_to_sub_con', & + LONG_NAME = 'top_snow_layer_mass_change_due_to_sublimation_and_condensation', & UNITS = 'kg m-2 s-1' ,& SHORT_NAME = 'WESNSC' ,& DIMS = MAPL_DimsTileOnly ,& @@ -569,7 +569,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'contribution_to_smb_from_refreezed_rain_over_bare_ice', & + LONG_NAME = 'contribution_to_surface_mass_balance_from_rain_frozen_onto_bare_ice', & UNITS = 'kg m-2 s-1' ,& SHORT_NAME = 'RAINRFZ' ,& DIMS = MAPL_DimsTileOnly ,& @@ -578,7 +578,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'snowmelt_flux' ,& + LONG_NAME = 'snow_melt_flux' ,& UNITS = 'kg m-2 s-1' ,& SHORT_NAME = 'SMELT' ,& DIMS = MAPL_DimsTileOnly ,& @@ -587,7 +587,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'icemelt_flux' ,& + LONG_NAME = 'ice_melt_flux' ,& UNITS = 'kg m-2 s-1' ,& SHORT_NAME = 'IMELT' ,& DIMS = MAPL_DimsTileOnly ,& @@ -596,7 +596,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'snow_broadband_albedo', & + LONG_NAME = 'snow_broadband_reflectivity', & UNITS = '1' ,& SHORT_NAME = 'SNOWALB' ,& DIMS = MAPL_DimsTileOnly ,& @@ -605,7 +605,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'aggregated_snow_ice_broadband_albedo', & + LONG_NAME = 'aggregated_snow_ice_broadband_reflectivity', & UNITS = '1' ,& SHORT_NAME = 'SNICEALB' ,& DIMS = MAPL_DimsTileOnly ,& @@ -623,7 +623,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'melt_water_content', & + LONG_NAME = 'snowpack_meltwater_content', & UNITS = 'kg m-2' ,& SHORT_NAME = 'MELTWTRCONT' ,& DIMS = MAPL_DimsTileOnly ,& @@ -641,7 +641,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'runoff_flux' ,& + LONG_NAME = 'runoff_total_flux' ,& UNITS = 'kg m-2 s-1' ,& SHORT_NAME = 'RUNOFF' ,& DIMS = MAPL_DimsTileOnly ,& @@ -848,7 +848,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'Ground_heating_for_tskin' ,& + LONG_NAME = 'glacier_ice_heating_flux' ,& UNITS = 'W m-2' ,& SHORT_NAME = 'GHTSKIN' ,& DIMS = MAPL_DimsTileOnly ,& @@ -2154,6 +2154,7 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) !integer, pointer :: TILETYPES(:) type(MAPL_SunOrbit) :: ORBIT + integer :: LANDICE_OFFLINE !============================================================================= ! Begin... @@ -2198,6 +2199,9 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) VERIFY_(STATUS) call ESMF_AlarmRingerOff(ALARM, RC=STATUS) VERIFY_(STATUS) + ! borrow CATCHMENT_OFFLINE + call MAPL_GetResource ( MAPL, LANDICE_OFFLINE, Label="CATCHMENT_OFFLINE:", DEFAULT=0, RC=STATUS) + VERIFY_(STATUS) call LANDICECORE(RC=STATUS ) VERIFY_(STATUS) end if @@ -2333,6 +2337,7 @@ subroutine LANDICECORE(RC) real, pointer, dimension(:) :: DRUVR real, pointer, dimension(:) :: DFUVR real, pointer, dimension(:) :: TA + real, pointer, dimension(:) :: QA real, pointer, dimension(:) :: UU real, pointer, dimension(:,:) :: DUDP real, pointer, dimension(:,:) :: DUSV @@ -2367,6 +2372,8 @@ subroutine LANDICECORE(RC) real, allocatable :: SWN(:) real, allocatable :: DIF(:) real, allocatable :: ULW(:) + real, allocatable :: ALWN(:) + real, allocatable :: BLWN(:) real :: DT real :: LANDICECAP @@ -2484,6 +2491,7 @@ subroutine LANDICECORE(RC) call MAPL_GetPointer(IMPORT,DRUVR , 'DRUVR' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT,DFUVR , 'DFUVR' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT,TA , 'TA' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT,QA , 'QA' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT,UU , 'UU' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT,DUDP , 'DUDP' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT,DUSV , 'DUSV' , RC=STATUS); VERIFY_(STATUS) @@ -2762,10 +2770,12 @@ subroutine LANDICECORE(RC) if(associated(TICE0 )) TICE0 = 0.0 if(associated(ACCUM )) ACCUM = 0.0 if(associated(MELTWTR )) MELTWTR = 0.0 - - TOTDEPOS = 0.0 - RCONSTIT = 0.0 - RMELT = 0.0 + + if (N_constit>0) then + TOTDEPOS = 0.0 + RCONSTIT = 0.0 + RMELT = 0.0 + end if ! Zero the light-absorbing aerosol (LAA) deposition rates from GOCART: @@ -2804,6 +2814,9 @@ subroutine LANDICECORE(RC) end select + + if (N_CONST_LANDICE4SNWALB /=0) then + ! Convert the dimentions for LAAs from GEOS_SurfGridComp.F90 to GEOS_LandIceGridComp.F90 ! Note: Explanations of each variable ! TOTDEPOS(:,1): Combined dust deposition from size bin 1 (dry, conv-scav, ls-scav, sed) @@ -2862,7 +2875,6 @@ subroutine LANDICECORE(RC) ! RCONSTIT(NT,N,14): Sea salt mass from size bin 4 in layer N ! RCONSTIT(NT,N,15): Sea salt mass from size bin 5 in layer N - if (N_CONST_LANDICE4SNWALB /=0) then RCONSTIT(:,:,1) = IRDU001(:,:) RCONSTIT(:,:,2) = IRDU002(:,:) RCONSTIT(:,:,3) = IRDU003(:,:) @@ -2942,155 +2954,169 @@ subroutine LANDICECORE(RC) !! The next sequence is to make sure that the albedo here and in solar are in sync !! ! Need to know when Solar was called last, so first get the solar alarm - call ESMF_ClockGetAlarm ( CLOCK, alarmname="SOLAR_Alarm", ALARM=SOLALARM, RC=STATUS ) - VERIFY_(STATUS) + call ESMF_ClockGetAlarm ( CLOCK, alarmname="SOLAR_Alarm", ALARM=SOLALARM, RC=STATUS ) + VERIFY_(STATUS) ! Get the interval of the solar alarm - first get it in seconds - call ESMF_ConfigGetAttribute ( CF, DT_SOLAR, Label="SOLAR_DT:", DEFAULT=DT, RC=STATUS ) - VERIFY_(STATUS) + call ESMF_ConfigGetAttribute ( CF, DT_SOLAR, Label="SOLAR_DT:", DEFAULT=DT, RC=STATUS ) + VERIFY_(STATUS) ! Now make an ESMF interval from the increment in seconds - CALL ESMF_TimeIntervalSet ( TINT, S=NINT(DT_SOLAR), RC=STATUS ) - VERIFY_(STATUS) + CALL ESMF_TimeIntervalSet ( TINT, S=NINT(DT_SOLAR), RC=STATUS ) + VERIFY_(STATUS) ! Now print out the solar alarm interval - if (MAPL_AM_I_Root(VM).and.debugzth) CALL ESMF_TimeIntervalPrint ( TINT, OPTIONS="string", RC=STATUS ) + if (MAPL_AM_I_Root(VM).and.debugzth) CALL ESMF_TimeIntervalPrint ( TINT, OPTIONS="string", RC=STATUS ) ! Now find out if it is ringing now: if so, set "BEFORE" to last time it rang before now - solalarmison = ESMF_AlarmIsRinging(SOLALARM,RC=STATUS) - VERIFY_(STATUS) - if (MAPL_AM_I_Root(VM).and.debugzth)print *,' logical for solar alarm ',solalarmison + solalarmison = ESMF_AlarmIsRinging(SOLALARM,RC=STATUS) + VERIFY_(STATUS) + if (MAPL_AM_I_Root(VM).and.debugzth)print *,' logical for solar alarm ',solalarmison ! if so, set "BEFORE" to last time it rang before now - if(solalarmison) then - if (MAPL_AM_I_Root(VM).and.debugzth)print *,' In catch, solar alarm is ringing ' - NOW = CURRENT_TIME - BEFORE = NOW - TINT + if(solalarmison) then + if (MAPL_AM_I_Root(VM).and.debugzth)print *,' In catch, solar alarm is ringing ' + NOW = CURRENT_TIME + BEFORE = NOW - TINT ! Now print out the last time solar alarm rang - if (MAPL_AM_I_Root(VM).and.debugzth)CALL ESMF_TimePrint ( BEFORE, OPTIONS="string", RC=STATUS ) + if (MAPL_AM_I_Root(VM).and.debugzth)CALL ESMF_TimePrint ( BEFORE, OPTIONS="string", RC=STATUS ) ! If alarm is not ringing now, find out when it rang last - else - if (MAPL_AM_I_Root(VM).and.debugzth)print *,' In catch, solar alarm is not ringing ' - call ESMF_AlarmGet ( SOLALARM, prevRingTime=BEFORE, RC=STATUS ) - VERIFY_(STATUS) + else + if (MAPL_AM_I_Root(VM).and.debugzth)print *,' In catch, solar alarm is not ringing ' + call ESMF_AlarmGet ( SOLALARM, prevRingTime=BEFORE, RC=STATUS ) + VERIFY_(STATUS) ! PrevRingTime can lie: if alarm never went off yet it gives next alarm time, not prev. - if(BEFORE > CURRENT_TIME) then + if(BEFORE > CURRENT_TIME) then BEFORE = BEFORE-TINT if (MAPL_AM_I_Root(VM).and.debugzth)print *,' In catch, solar alarm not ringing, prev time lied ' if (MAPL_AM_I_Root(VM).and.debugzth)CALL ESMF_TimePrint ( BEFORE, OPTIONS="string", RC=STATUS ) - else + else if (MAPL_AM_I_Root(VM).and.debugzth)print *,' In catch, solar alarm not ringing, prev time okay ' if (MAPL_AM_I_Root(VM).and.debugzth)CALL ESMF_TimePrint ( BEFORE, OPTIONS="string", RC=STATUS ) - endif + endif ! Now print out the last time solar alarm rang - endif + endif ! Get the zenith angle at the center of the time between the last solar call and the next one - call MAPL_SunGetInsolation(LONS, LATS, & + call MAPL_SunGetInsolation(LONS, LATS, & ORBIT, ZTH, SLR, & INTV = TINT, & currTime=BEFORE+DELT, & RC=STATUS ) - VERIFY_(STATUS) - - ZTH = max(0.0,ZTH) + VERIFY_(STATUS) + ZTH = max(0.0,ZTH) + do N=1,NUM_SUBTILES - - CFT = (CH(:,N)/CTATM) - CFQ = (CQ(:,N)/CQATM) - SHF = CFT*(SH + DSH*(TS(:,N)-THATM)) - LHF = CFQ*(EVAP + DEV*(QS(:,N)-QHATM))*MAPL_ALHS - SHD = CFT*DSH - LHD = CFQ*DEV*MAPL_ALHS*GEOS_DQSAT(TS(:,N), PS, PASCALS=.TRUE., RAMP=0.0) - SWN = ((DRUVR+DRPAR+DRNIR) + (DFUVR+DFPAR+DFNIR))*(1.0-LANDICEALB) - DIF = 0.0 - ULW = ALW + BLW*TS(:,N) - - LANDICECAP= (MAPL_RHOWTR*MAPL_CAPICE*LANDICEDEPTH) - - EVAPI = LHF / MAPL_ALHS - DEVAPDT = LHD / MAPL_ALHS - RADDN = LWDNSRF + SWN - - PERC = 0.0 - MELTI = 0.0 - - - if(N==SNOW) then - - ITYPE = 9 - LAI = 0.0 - GRN = 0.0 - MODISFAC = 1.0 - - !*** have to do a transpose of these internals since their dimensions in SNOW_ALBEDO - !*** are reversed - WESNN = transpose(WESN) - HTSNN = transpose(HTSN) - SNDZN = transpose(SNDZ) - !*** call new/shared routine to compute albedo - - call SNOW_ALBEDO(NT, NUM_SNOW_LAYERS, N_CONST_LANDICE4SNWALB, ITYPE, LAI, ZTH, & - RHOFRESH, VISMAX, NIRMAX, SLOPE, & !0.96, 0.68, 1.0, & ! - WESNN, HTSNN, SNDZN, & ! snow stuff - LNDVR, LNDNR, LNDVF, LNDNF, & ! instantaneous snow-free albedos on tiles - SNOVR, SNONR, SNOVF, SNONF, & ! instantaneous snow albedos on tiles - RCONSTIT, UU, TS(:,SNOW), DRPAR, DFPAR & ! When only N_constit > 0 (oprional) - ) - - VSUVR = DRPAR + DRUVR - VSUVF = DFPAR + DFUVR - SWNETSNOW = (1.-SNOVR)*VSUVR + (1.-SNOVF)*VSUVF + (1.-SNONR)*DRNIR + (1.-SNONF)*DFNIR - RADDN = LWDNSRF + SWNETSNOW - SWN = SWNETSNOW - if(associated(SNOWALB)) then - where(FR(:,N) > 0.0) - SNOWALB = SNOVR*AWTVDR + SNOVF*AWTVDF + SNONR*AWTIDR + SNONF*AWTIDF - elsewhere - SNOWALB = MAPL_UNDEF - endwhere - where(ZTH < 1.e-6) - SNOWALB = MAPL_UNDEF - endwhere + if (LANDICE_OFFLINE == 0 ) then + CFT = (CH(:,N)/CTATM) + CFQ = (CQ(:,N)/CQATM) + SHF = CFT*(SH + DSH*(TS(:,N)-THATM)) + LHF = CFQ*(EVAP + DEV*(QS(:,N)-QHATM))*MAPL_ALHS + SHD = CFT*DSH + LHD = CFQ*DEV*MAPL_ALHS*GEOS_DQSAT(TS(:,N), PS, PASCALS=.TRUE., RAMP=0.0) + ALWN = ALW + BLWN = BLW + else + CFT = 1.0 + CFQ = 1.0 + SHF = MAPL_CP*CH(:,N)*(TS(:,N)-TA) + LHF = CQ(:,N)*(QS(:,N)-QA) * MAPL_ALHS + SHD = MAPL_CP*CH(:,N) + LHD = CQ(:,N)*MAPL_ALHS*GEOS_DQSAT(TS(:,N), PS, PASCALS=.TRUE., RAMP=0.0) + BLWN = LANDICEEMISS*MAPL_STFBOL*TS(:,N)*TS(:,N)*TS(:,N) + ALWN = -3.0*BLWN*TS(:,N) + BLWN = 4.0*BLWN endif - endif - if(N==ICE) then - do k=1,NT - if(FR(k,N) > MINFRACSNO) then - call SOLVEICELAYER(NUM_ICE_LAYERS, DT, TICE(k,N,:), DZMAXI, 0, & - MELTI(k), DTSS=DTS(k), RUNOFF=PERC(k), & - lhturb=LHF(k),hlwtc=ULW(k),hsturb=SHF(k),raddn=RADDN(k), & - dlhdtc=LHD(k),dhsdtc=SHD(k),dhlwtc=BLW(k),rain=RAIN(k), & - rainrf=RAINRF(k), & - lhflux=LHFO(k),shflux=SHFO(k),hlwout=HLWO(k),evapout=EVAPO(k), & - ghflxice=ghflxice(k)) - else - TICE(k,N,:) = TICE(k,SNOW,:) + SWN = ((DRUVR+DRPAR+DRNIR) + (DFUVR+DFPAR+DFNIR))*(1.0-LANDICEALB) + DIF = 0.0 + ULW = ALWN + BLWN*TS(:,N) + + LANDICECAP= (MAPL_RHOWTR*MAPL_CAPICE*LANDICEDEPTH) + + EVAPI = LHF / MAPL_ALHS + DEVAPDT = LHD / MAPL_ALHS + RADDN = LWDNSRF + SWN + + PERC = 0.0 + MELTI = 0.0 + + + if(N==SNOW) then + + ITYPE = 9 + LAI = 0.0 + GRN = 0.0 + MODISFAC = 1.0 + + !*** have to do a transpose of these internals since their dimensions in SNOW_ALBEDO + !*** are reversed + WESNN = transpose(WESN) + HTSNN = transpose(HTSN) + SNDZN = transpose(SNDZ) + !*** call new/shared routine to compute albedo + + call SNOW_ALBEDO(NT, NUM_SNOW_LAYERS, N_CONST_LANDICE4SNWALB, ITYPE, LAI, ZTH, & + RHOFRESH, VISMAX, NIRMAX, SLOPE, & !0.96, 0.68, 1.0, & ! + WESNN, HTSNN, SNDZN, & ! snow stuff + LNDVR, LNDNR, LNDVF, LNDNF, & ! instantaneous snow-free albedos on tiles + SNOVR, SNONR, SNOVF, SNONF, & ! instantaneous snow albedos on tiles + RCONSTIT, UU, TS(:,SNOW), DRPAR, DFPAR & ! When only N_constit > 0 (oprional) + ) + + VSUVR = DRPAR + DRUVR + VSUVF = DFPAR + DFUVR + SWNETSNOW = (1.-SNOVR)*VSUVR + (1.-SNOVF)*VSUVF + (1.-SNONR)*DRNIR + (1.-SNONF)*DFNIR + RADDN = LWDNSRF + SWNETSNOW + SWN = SWNETSNOW + if(associated(SNOWALB)) then + where(FR(:,N) > 0.0) + SNOWALB = SNOVR*AWTVDR + SNOVF*AWTVDF + SNONR*AWTIDR + SNONF*AWTIDF + elsewhere + SNOWALB = MAPL_UNDEF + endwhere + where(ZTH < 1.e-6) + SNOWALB = MAPL_UNDEF + endwhere endif - enddo - TS(:,N) = TICE(:,N,1) - if(associated(RUNOFF)) RUNOFF = RUNOFF + FR(:,N) * PERC - endif + endif - if(N==SNOW) then - LANDICELT = TICE(:,N,1) - MAPL_TICE - do k=1,NT + if(N==ICE) then + do k=1,NT + if(FR(k,N) > MINFRACSNO) then + call SOLVEICELAYER(NUM_ICE_LAYERS, DT, TICE(k,N,:), DZMAXI, 0, & + MELTI(k), DTSS=DTS(k), RUNOFF=PERC(k), & + lhturb=LHF(k),hlwtc=ULW(k),hsturb=SHF(k),raddn=RADDN(k), & + dlhdtc=LHD(k),dhsdtc=SHD(k),dhlwtc=BLWN(k),rain=RAIN(k), & + rainrf=RAINRF(k), & + lhflux=LHFO(k),shflux=SHFO(k),hlwout=HLWO(k),evapout=EVAPO(k), & + ghflxice=ghflxice(k)) + else + TICE(k,N,:) = TICE(k,SNOW,:) + endif + enddo + TS(:,N) = TICE(:,N,1) + if(associated(RUNOFF)) RUNOFF = RUNOFF + FR(:,N) * PERC + endif + + if(N==SNOW) then + LANDICELT = TICE(:,N,1) - MAPL_TICE + do k=1,NT #if 0 - LATSD=LATS(K)*rad_to_deg - LONSD=LONS(K)*rad_to_deg - !if(abs(LATSD-0.700003698112E+02) < 1.e-3 .and. & - ! abs(LONSD-(-0.539905136947E+02)) < 1.e-3 ) then - !if(abs(LATSD-0.605467530483E+02) < 1.e-3 .and. & - ! abs(LONSD-(-0.433431029954E+02)) < 1.e-3 ) then - if(abs(LATSD-0.807870232172E+02) < 1.e-3 .and. & - abs(LONSD-(-0.154247429558E+02)) < 1.e-3 ) then - print*, 'PE = ', mype, ' tile = ',k - endif + LATSD=LATS(K)*rad_to_deg + LONSD=LONS(K)*rad_to_deg + !if(abs(LATSD-0.700003698112E+02) < 1.e-3 .and. & + ! abs(LONSD-(-0.539905136947E+02)) < 1.e-3 ) then + !if(abs(LATSD-0.605467530483E+02) < 1.e-3 .and. & + ! abs(LONSD-(-0.433431029954E+02)) < 1.e-3 ) then + if(abs(LATSD-0.807870232172E+02) < 1.e-3 .and. & + abs(LONSD-(-0.154247429558E+02)) < 1.e-3 ) then + print*, 'PE = ', mype, ' tile = ',k + endif #endif - TKSNO = condice + TKSNO = condice call SNOWRT( LONS(k), LATS(k), & ! in [radians] !!! 1,NUM_SNOW_LAYERS,MAPL_LANDICE, & ! in MAXSNDZ, RHOFRESH, DZMAX, & ! in LANDICELT(k),ZONEAREA,TKGND,PRECIP(k),SNO(k),TA(k),DT, & ! in - EVAPI(k),DEVAPDT(k),SHF(k),SHD(k),ULW(k),BLW(k), & ! in + EVAPI(k),DEVAPDT(k),SHF(k),SHD(k),ULW(k),BLWN(k), & ! in RADDN(k),ZC1,TOTDEPOS(k,:), & ! in WESN(k,:),HTSN(k,:),SNDZ(k,:), RCONSTIT(k,:,:), & ! inout HLWO(k), FROZFRAC(k,:),TPSN(k,:), RMELT(k,:), & ! out @@ -3099,108 +3125,109 @@ subroutine LANDICECORE(RC) SNDZSC(k), WESNPREC(k), SNDZPREC(k),SNDZ1PERC(k), & ! out WESNPERC(k,:), WESNDENS(k,:), WESNREPAR(k,:), MLT(k), & ! out EXCS(k,:), DRHO0(k,:), WESNBOT(k), TKSNO, DTS(k) ) ! out - - - ! Snow impurities update - if (N_CONST_LANDICE4SNWALB /= 0) then - if(associated(IRDU001)) IRDU001(k,:) = RCONSTIT(k,:,1) - if(associated(IRDU002)) IRDU002(k,:) = RCONSTIT(k,:,2) - if(associated(IRDU003)) IRDU003(k,:) = RCONSTIT(k,:,3) - if(associated(IRDU004)) IRDU004(k,:) = RCONSTIT(k,:,4) - if(associated(IRDU005)) IRDU005(k,:) = RCONSTIT(k,:,5) - if(associated(IRBC001)) IRBC001(k,:) = RCONSTIT(k,:,6) - if(associated(IRBC002)) IRBC002(k,:) = RCONSTIT(k,:,7) - if(associated(IROC001)) IROC001(k,:) = RCONSTIT(k,:,8) - if(associated(IROC002)) IROC002(k,:) = RCONSTIT(k,:,9) + + ! Snow impurities update + if (N_CONST_LANDICE4SNWALB /= 0) then + if(associated(IRDU001)) IRDU001(k,:) = RCONSTIT(k,:,1) + if(associated(IRDU002)) IRDU002(k,:) = RCONSTIT(k,:,2) + if(associated(IRDU003)) IRDU003(k,:) = RCONSTIT(k,:,3) + if(associated(IRDU004)) IRDU004(k,:) = RCONSTIT(k,:,4) + if(associated(IRDU005)) IRDU005(k,:) = RCONSTIT(k,:,5) + if(associated(IRBC001)) IRBC001(k,:) = RCONSTIT(k,:,6) + if(associated(IRBC002)) IRBC002(k,:) = RCONSTIT(k,:,7) + if(associated(IROC001)) IROC001(k,:) = RCONSTIT(k,:,8) + if(associated(IROC002)) IROC002(k,:) = RCONSTIT(k,:,9) + end if + if (N_constit>0) then + if(associated(RMELTDU001)) RMELTDU001(k) = RMELT(k,1) + if(associated(RMELTDU002)) RMELTDU002(k) = RMELT(k,2) + if(associated(RMELTDU003)) RMELTDU003(k) = RMELT(k,3) + if(associated(RMELTDU004)) RMELTDU004(k) = RMELT(k,4) + if(associated(RMELTDU005)) RMELTDU005(k) = RMELT(k,5) + if(associated(RMELTBC001)) RMELTBC001(k) = RMELT(k,6) + if(associated(RMELTBC002)) RMELTBC002(k) = RMELT(k,7) + if(associated(RMELTOC001)) RMELTOC001(k) = RMELT(k,8) + if(associated(RMELTOC002)) RMELTOC002(k) = RMELT(k,9) end if - if(associated(RMELTDU001)) RMELTDU001(k) = RMELT(k,1) - if(associated(RMELTDU002)) RMELTDU002(k) = RMELT(k,2) - if(associated(RMELTDU003)) RMELTDU003(k) = RMELT(k,3) - if(associated(RMELTDU004)) RMELTDU004(k) = RMELT(k,4) - if(associated(RMELTDU005)) RMELTDU005(k) = RMELT(k,5) - if(associated(RMELTBC001)) RMELTBC001(k) = RMELT(k,6) - if(associated(RMELTBC002)) RMELTBC002(k) = RMELT(k,7) - if(associated(RMELTOC001)) RMELTOC001(k) = RMELT(k,8) - if(associated(RMELTOC002)) RMELTOC002(k) = RMELT(k,9) - - if(associated(LWC ))then - ZDEP = sum(SNDZ(k,:)) - if(sum(WESN(k,:)) > MINSWE) then - if(ZDEP <= LWCTOP) then - LWC(k) = sum(WESN(k,:)*(1.-FROZFRAC(k,:)))/sum(WESN(k,:)) - else - KL = 0 - ZKL = 0.0 - do l=1,NUM_SNOW_LAYERS - ZKL = ZKL + SNDZ(k,l) - if(ZKL > LWCTOP) then - KL = l - exit - endif - enddo - ALPHA = 1.0 - (ZKL-LWCTOP)/SNDZ(k,KL) - LWC(k) = (sum(WESN(k,1:KL-1)*(1.-FROZFRAC(k,1:KL-1)))+ & - ALPHA*WESN(k,KL)*(1.-FROZFRAC(k,KL))) / & - (sum(WESN(k,1:KL-1))+ALPHA*WESN(k,KL)) - endif - else - LWC(k) = 0.0 - endif - endif - if(FR(K,N) < MINFRACSNO) then - TICE(k,N,:) = TICE(k,ICE,:) - else - call SOLVEICELAYER(NUM_ICE_LAYERS, DT, TICE(k,N,:), DZMAXI, 1, & - MELTI(k), & - condsno=TKSNO(NUM_SNOW_LAYERS), & - !tsn=TPSN(k,NUM_SNOW_LAYERS), & - fhgnd=FHGND(k), & - sndz=SNDZ(k,NUM_SNOW_LAYERS) & - ) - if(associated(RUNOFF)) RUNOFF(K) = RUNOFF(K) + FR(K,N) * MELTI(K) - endif - enddo - WESNSC = EVAPO - !PERC = PERC + MELTI - if(associated(RUNOFF)) RUNOFF = RUNOFF + PERC - TS(:,N) = TPSN(:,1)+MAPL_TICE - if(associated(MELTWTRCONT )) MELTWTRCONT = sum(WESN*(1.-FROZFRAC),dim=2) - endif - DQS = GEOS_QSAT(TS(:,N), PS, PASCALS=.TRUE.,RAMP=0.0) - QS(:,N) - QS(:,N) = QS(:,N) + DQS + if(associated(LWC ))then + ZDEP = sum(SNDZ(k,:)) + if(sum(WESN(k,:)) > MINSWE) then + if(ZDEP <= LWCTOP) then + LWC(k) = sum(WESN(k,:)*(1.-FROZFRAC(k,:)))/sum(WESN(k,:)) + else + KL = 0 + ZKL = 0.0 + do l=1,NUM_SNOW_LAYERS + ZKL = ZKL + SNDZ(k,l) + if(ZKL > LWCTOP) then + KL = l + exit + endif + enddo + ALPHA = 1.0 - (ZKL-LWCTOP)/SNDZ(k,KL) + LWC(k) = (sum(WESN(k,1:KL-1)*(1.-FROZFRAC(k,1:KL-1)))+ & + ALPHA*WESN(k,KL)*(1.-FROZFRAC(k,KL))) / & + (sum(WESN(k,1:KL-1))+ALPHA*WESN(k,KL)) + endif + else + LWC(k) = 0.0 + endif + endif + if(FR(K,N) < MINFRACSNO) then + TICE(k,N,:) = TICE(k,ICE,:) + else + call SOLVEICELAYER(NUM_ICE_LAYERS, DT, TICE(k,N,:), DZMAXI, 1, & + MELTI(k), & + condsno=TKSNO(NUM_SNOW_LAYERS), & + !tsn=TPSN(k,NUM_SNOW_LAYERS), & + fhgnd=FHGND(k), & + sndz=SNDZ(k,NUM_SNOW_LAYERS) & + ) + if(associated(RUNOFF)) RUNOFF(K) = RUNOFF(K) + FR(K,N) * MELTI(K) + endif + enddo + WESNSC = EVAPO + !PERC = PERC + MELTI + if(associated(RUNOFF)) RUNOFF = RUNOFF + PERC + TS(:,N) = TPSN(:,1)+MAPL_TICE + if(associated(MELTWTRCONT )) MELTWTRCONT = sum(WESN*(1.-FROZFRAC),dim=2) + endif + + DQS = GEOS_QSAT(TS(:,N), PS, PASCALS=.TRUE.,RAMP=0.0) - QS(:,N) + QS(:,N) = QS(:,N) + DQS - LHF = LHFO - SHF = SHFO - ULW = HLWO + LHF = LHFO + SHF = SHFO + ULW = HLWO - if(associated(EVAPOUT)) EVAPOUT = EVAPOUT + FR(:,N)*EVAPO - if(associated(SUBLIM )) SUBLIM = SUBLIM + FR(:,N)*EVAPO - if(associated(SHOUT )) SHOUT = SHOUT + FR(:,N)*SHF - if(associated(HLATN )) HLATN = HLATN + FR(:,N)*LHF + if(associated(EVAPOUT)) EVAPOUT = EVAPOUT + FR(:,N)*EVAPO + if(associated(SUBLIM )) SUBLIM = SUBLIM + FR(:,N)*EVAPO + if(associated(SHOUT )) SHOUT = SHOUT + FR(:,N)*SHF + if(associated(HLATN )) HLATN = HLATN + FR(:,N)*LHF - if(associated(DELTS )) DELTS = DELTS + DTS*CFT*FR(:,N) - if(associated(DELQS )) DELQS = DELQS + DQS*CFQ*FR(:,N) - if(associated(EVPICE)) EVPICE = EVPICE + FR(:,N)*LHF + if(associated(DELTS )) DELTS = DELTS + DTS*CFT*FR(:,N) + if(associated(DELQS )) DELQS = DELQS + DQS*CFQ*FR(:,N) + if(associated(EVPICE)) EVPICE = EVPICE + FR(:,N)*LHF - !if(associated(RUNOFF)) RUNOFF = RUNOFF + FR(:,N) * PERC - if(associated(IMELT )) IMELT = IMELT + FR(:,N) * MELTI + !if(associated(RUNOFF)) RUNOFF = RUNOFF + FR(:,N) * PERC + if(associated(IMELT )) IMELT = IMELT + FR(:,N) * MELTI - if(associated(SWNDSRF )) SWNDSRF = SWNDSRF + SWN * FR(:,N) - if(associated(LWNDSRF )) LWNDSRF = LWNDSRF + (LWDNSRF - ULW) * FR(:,N) - if(associated(HLWUP )) HLWUP = HLWUP + ULW * FR(:,N) - if(associated(DNICFLX )) DNICFLX = DNICFLX + DIF * FR(:,N) - if(associated(GHSNOW )) GHSNOW = ghflxsno - if(associated(ACCUM )) ACCUM = ACCUM - FR(:,N) * EVAPO - if(associated(MELTWTR )) MELTWTR = MELTWTR + FR(:,N) * MELTI + if(associated(SWNDSRF )) SWNDSRF = SWNDSRF + SWN * FR(:,N) + if(associated(LWNDSRF )) LWNDSRF = LWNDSRF + (LWDNSRF - ULW) * FR(:,N) + if(associated(HLWUP )) HLWUP = HLWUP + ULW * FR(:,N) + if(associated(DNICFLX )) DNICFLX = DNICFLX + DIF * FR(:,N) + if(associated(GHSNOW )) GHSNOW = ghflxsno + if(associated(ACCUM )) ACCUM = ACCUM - FR(:,N) * EVAPO + if(associated(MELTWTR )) MELTWTR = MELTWTR + FR(:,N) * MELTI - if(associated(TICE0 )) then - do k=1,NT - TICE0(k,:) = TICE0(k,:) + TICE(k,N,:) * FR(k,N) - enddo - endif + if(associated(TICE0 )) then + do k=1,NT + TICE0(k,:) = TICE0(k,:) + TICE(k,N,:) * FR(k,N) + enddo + endif - enddo + enddo ! NUM_SUBTILES FR(:,ICE) = max(1.0-FR(:,SNOW), 0.0) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSsaltwater_GridComp/BufferPacking.h b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSsaltwater_GridComp/BufferPacking.h index 77ee20a03..ecfd54d3e 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSsaltwater_GridComp/BufferPacking.h +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSsaltwater_GridComp/BufferPacking.h @@ -7,7 +7,7 @@ ! import packing and redistribution - numUsedImp = 34 ! should match the number of imports used in this subroutine + 2 (for LATS and LONS) + numUsedImp = 36 ! should match the number of imports used in this subroutine + 2 (for LATS and LONS) ! Allocate the buffer that will hold all balanced variables. The ! dimension of its 1D representation must ne NUMMAX---the larger of the @@ -102,6 +102,18 @@ PTR1(1:NUMMAX) => BUFIMP(L1:LN) SNO => PTR1(1:NT) L1 = LN + 1 + call MAPL_GetPointer(IMPORT,PTR1,'ICE', _RC) + call CICEReorder(BUFIMP(L1),PTR1,TILE_WITH_ICE,NUMMAX,HorzDims,1,PACKIT) + LN = L1 + NUMMAX - 1 + PTR1(1:NUMMAX) => BUFIMP(L1:LN) + ICEF => PTR1(1:NT) + L1 = LN + 1 + call MAPL_GetPointer(IMPORT,PTR1,'FRZR', _RC) + call CICEReorder(BUFIMP(L1),PTR1,TILE_WITH_ICE,NUMMAX,HorzDims,1,PACKIT) + LN = L1 + NUMMAX - 1 + PTR1(1:NUMMAX) => BUFIMP(L1:LN) + FRZR => PTR1(1:NT) + L1 = LN + 1 call MAPL_GetPointer(IMPORT,PTR1,'PLS', _RC) call CICEReorder(BUFIMP(L1),PTR1,TILE_WITH_ICE,NUMMAX,HorzDims,1,PACKIT) LN = L1 + NUMMAX - 1 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSsaltwater_GridComp/GEOS_CICE4ColumnPhysGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSsaltwater_GridComp/GEOS_CICE4ColumnPhysGridComp.F90 index bc5a7c044..40ea74019 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSsaltwater_GridComp/GEOS_CICE4ColumnPhysGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSsaltwater_GridComp/GEOS_CICE4ColumnPhysGridComp.F90 @@ -181,7 +181,7 @@ subroutine SetServices ( GC, RC ) _RC ) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'surface_albedo_for_visible_beam', & + LONG_NAME = 'surface_reflectivity_for_visible_beam', & UNITS = '1', & SHORT_NAME = 'ALBVR', & DIMS = MAPL_DimsTileOnly, & @@ -189,7 +189,7 @@ subroutine SetServices ( GC, RC ) _RC ) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'surface_albedo_for_visible_diffuse',& + LONG_NAME = 'surface_reflectivity_for_visible_diffuse',& UNITS = '1', & SHORT_NAME = 'ALBVF', & DIMS = MAPL_DimsTileOnly, & @@ -197,7 +197,7 @@ subroutine SetServices ( GC, RC ) _RC ) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'surface_albedo_for_near_infrared_beam', & + LONG_NAME = 'surface_reflectivity_for_near_infrared_beam', & UNITS = '1', & SHORT_NAME = 'ALBNR', & DIMS = MAPL_DimsTileOnly, & @@ -205,7 +205,7 @@ subroutine SetServices ( GC, RC ) _RC ) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'surface_albedo_for_near_infrared_diffuse', & + LONG_NAME = 'surface_reflectivity_for_near_infrared_diffuse', & UNITS = '1', & SHORT_NAME = 'ALBNF', & DIMS = MAPL_DimsTileOnly, & @@ -861,6 +861,23 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationNone, & _RC ) + call MAPL_AddImportSpec(GC, & + LONG_NAME = 'icefall', & + UNITS = 'kg m-2 s-1', & + SHORT_NAME = 'ICE', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + _RC ) + + call MAPL_AddImportSpec(GC, & + LONG_NAME = 'freezing_rain_fall', & + UNITS = 'kg m-2 s-1', & + SHORT_NAME = 'FRZR', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + _RC ) + + ! Surface air quantities call MAPL_AddImportSpec(GC, & @@ -1266,7 +1283,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'SIALB' ,& - LONG_NAME = 'broad_band_sea_ice_albedo' ,& + LONG_NAME = 'broad_band_sea_ice_reflectivity' ,& UNITS = '1' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& @@ -1388,7 +1405,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'ialb_CMIP5' ,& - LONG_NAME = 'bare_sea_ice_albedo' ,& + LONG_NAME = 'bare_sea_ice_reflectivity' ,& UNITS = '1' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& @@ -1527,7 +1544,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'ALBIN' ,& - LONG_NAME = 'ice_surface_albedo_over_ice_categories' ,& + LONG_NAME = 'ice_surface_reflectivity_over_ice_categories' ,& UNITS = '1' ,& DIMS = MAPL_DimsTileOnly ,& UNGRIDDED_DIMS = (/NUM_ICE_CATEGORIES/) ,& @@ -1536,7 +1553,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'ALBSN' ,& - LONG_NAME = 'snow_surface_albedo_over_ice_categories' ,& + LONG_NAME = 'snow_surface_reflectivity_over_ice_categories' ,& UNITS = '1' ,& DIMS = MAPL_DimsTileOnly ,& UNGRIDDED_DIMS = (/NUM_ICE_CATEGORIES/) ,& @@ -2880,6 +2897,8 @@ subroutine CICECORE(NT_ORIGINAL,RC) real, pointer, dimension(:) :: DEV => null() real, pointer, dimension(:) :: DSH => null() real, pointer, dimension(:) :: SNO => null() + real, pointer, dimension(:) :: ICEF => null() + real, pointer, dimension(:) :: FRZR => null() real, pointer, dimension(:) :: PLS => null() real, pointer, dimension(:) :: PCU => null() real, pointer, dimension(:) :: PS => null() @@ -3472,7 +3491,7 @@ subroutine CICECORE(NT_ORIGINAL,RC) if(associated(USTARI)) USTARI = sqrt(sqrt(TAUXBOT**2+TAUYBOT**2)/MAPL_RHO_SEAWATER) if(associated(PR_C5)) then - PR_C5 = FRCICE * (PLS + PCU) + PR_C5 = FRCICE * (PLS + PCU) ! as of Jun/2025, FRZR is included in PCU+PLS; see github issue #1111 where(FRCICE == 0.0) PR_C5 = 0.0 endwhere @@ -3541,7 +3560,7 @@ subroutine CICECORE(NT_ORIGINAL,RC) FSWTHRU,FCOND,FCONDBOT,EVP,FRESHN,FSALTN,FHOCNN, & MELTT,MELTS,MELTB,CONGEL,SNOICE,VOLICE,VOLSNO,SHF,LHF, & VOLPOND,APONDN,HPONDN,TAUAGE,TRACERS,ALW,BLW, & - FSWSFC,FSWINT,FSWABS,LWDNSRF,EVD,SHD,SNO,SBLX,_RC) + FSWSFC,FSWINT,FSWABS,LWDNSRF,EVD,SHD,SNO,ICEF,FRZR,SBLX,_RC) ! Some aggregation of fluxes to the Ocean has to be done now, before using in step2 @@ -4367,7 +4386,7 @@ subroutine CICE_THERMO1 (N,NSUB,NT,ICE,LATS,LONS,LATSO,LONSO,DT,TF,FR,TS, FSWTHRU,FCOND,FCONDBOT,EVP,FRESHN,FSALTN,FHOCNN, & MELTT,MELTS,MELTB,CONGEL,SNOICE,VOLICE,VOLSNO,SHF,LHF, & VOLPOND,APONDN,HPONDN,TAUAGE,TRACERS,ALW,BLW, & - FSWSFC,FSWINT,FSWABS,LWDNSRF,EVD,SHD,SNO,SBLX,RC) + FSWSFC,FSWINT,FSWABS,LWDNSRF,EVD,SHD,SNO,ICEF,FRZR,SBLX,RC) ! not passing TFfresh,saltwatercap,nt_tsfc,nt_iage,nt_volpn ! !ARGUMENTS: @@ -4399,6 +4418,8 @@ subroutine CICE_THERMO1 (N,NSUB,NT,ICE,LATS,LONS,LATSO,LONSO,DT,TF,FR,TS, real, intent(IN) :: EVD (:) ! related to evap real, intent(IN) :: SHD (:) ! related to sensible heat real, intent(IN) :: SNO (:) ! ? + real, intent(IN) :: ICEF (:) ! ? + real, intent(IN) :: FRZR (:) ! ? real, intent(INOUT) :: FSWSFC (:,:) ! ? real, intent(INOUT) :: EVP (:) ! evaporation @@ -4525,7 +4546,7 @@ subroutine CICE_THERMO1 (N,NSUB,NT,ICE,LATS,LONS,LATSO,LONSO,DT,TF,FR,TS, TRACERSDB = TRACERS(:,NSUB) LWDNSRFDB = LWDNSRF(K) - SNODB = SNO(K) + SNODB = SNO(K) + ICEF(K) TBOTDB = TBOT(K) FBOTDB = FBOT(K) FSWABSDB = FSWABS(K) @@ -4639,7 +4660,7 @@ subroutine CICE_THERMO1 (N,NSUB,NT,ICE,LATS,LONS,LATSO,LONSO,DT,TF,FR,TS, VOLSNODB = VOLSNO(K,NSUB) APONDNDB = APONDN(K,NSUB) HPONDNDB = HPONDN(K,NSUB) - FRAINDB = PCU(K) + PLS(K) + FRAINDB = PCU(K) + PLS(K) ! as of Jun/2025, FRZR is included in PCU+PLS; see github issue #1111 call compute_ponds(1, 1, & 1, 1, 1, 1, & MELTTDB, MELTSDB, FRAINDB, & diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSsaltwater_GridComp/GEOS_OpenWaterGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSsaltwater_GridComp/GEOS_OpenWaterGridComp.F90 index 436045ac7..0f4ba9e7d 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSsaltwater_GridComp/GEOS_OpenWaterGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSsaltwater_GridComp/GEOS_OpenWaterGridComp.F90 @@ -192,7 +192,7 @@ subroutine SetServices ( GC, RC ) _RC) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'surface_albedo_for_visible_beam', & + LONG_NAME = 'surface_reflectivity_for_visible_beam', & UNITS = '1', & SHORT_NAME = 'ALBVR', & DIMS = MAPL_DimsTileOnly, & @@ -200,7 +200,7 @@ subroutine SetServices ( GC, RC ) _RC) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'surface_albedo_for_visible_diffuse',& + LONG_NAME = 'surface_reflectivity_for_visible_diffuse',& UNITS = '1', & SHORT_NAME = 'ALBVF', & DIMS = MAPL_DimsTileOnly, & @@ -208,7 +208,7 @@ subroutine SetServices ( GC, RC ) _RC) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'surface_albedo_for_near_infrared_beam', & + LONG_NAME = 'surface_reflectivity_for_near_infrared_beam', & UNITS = '1', & SHORT_NAME = 'ALBNR', & DIMS = MAPL_DimsTileOnly, & @@ -216,7 +216,7 @@ subroutine SetServices ( GC, RC ) _RC) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'surface_albedo_for_near_infrared_diffuse', & + LONG_NAME = 'surface_reflectivity_for_near_infrared_diffuse', & UNITS = '1', & SHORT_NAME = 'ALBNF', & DIMS = MAPL_DimsTileOnly, & @@ -239,6 +239,22 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationNone ,& _RC ) + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'ocean_icefall' ,& + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'ICEFOCN' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + _RC ) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'ocean_snow_and_ice_fall' ,& + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'SPTOTOCN' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + _RC ) + call MAPL_AddExportSpec(GC, & LONG_NAME = 'ocean_rainfall' ,& UNITS = 'kg m-2 s-1' ,& @@ -1072,6 +1088,25 @@ subroutine SetServices ( GC, RC ) DIMS = MAPL_DimsTileOnly, & VLOCATION = MAPL_VLocationNone, & _RC) + call MAPL_AddImportSpec(GC ,& + LONG_NAME = 'icefall' ,& + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'ICE' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC ,& + LONG_NAME = 'freezing_rain_fall' ,& + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'FRZR' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + + VERIFY_(STATUS) ! Surface air quantities @@ -2007,6 +2042,8 @@ subroutine OPENWATERCORE(NT,RC) real, pointer, dimension(: ) :: EVAPOUT => null() real, pointer, dimension(: ) :: SUBLIM => null() real, pointer, dimension(: ) :: SNOWOCN => null() + real, pointer, dimension(: ) :: ICEFOCN => null() + real, pointer, dimension(: ) :: SPTOTOCN => null() real, pointer, dimension(: ) :: RAINOCN => null() real, pointer, dimension(: ) :: SHWTR => null() real, pointer, dimension(: ) :: SHOUT => null() @@ -2093,6 +2130,8 @@ subroutine OPENWATERCORE(NT,RC) real, pointer, dimension(:) :: DEV => null() real, pointer, dimension(:) :: DSH => null() real, pointer, dimension(:) :: SNO => null() + real, pointer, dimension(:) :: ICE => null() + real, pointer, dimension(:) :: FRZR => null() real, pointer, dimension(:) :: PLS => null() real, pointer, dimension(:) :: PCU => null() real, pointer, dimension(:) :: PS => null() @@ -2220,6 +2259,8 @@ subroutine OPENWATERCORE(NT,RC) call MAPL_GetPointer(IMPORT,DEV , 'DEVAP' , _RC) call MAPL_GetPointer(IMPORT,DSH , 'DSH' , _RC) call MAPL_GetPointer(IMPORT,SNO , 'SNO' , _RC) + call MAPL_GetPointer(IMPORT,ICE , 'ICE' , _RC) + call MAPL_GetPointer(IMPORT,FRZR , 'FRZR' , _RC) call MAPL_GetPointer(IMPORT,PLS , 'PLS' , _RC) call MAPL_GetPointer(IMPORT,PCU , 'PCU' , _RC) call MAPL_GetPointer(IMPORT,PS , 'PS' , _RC) @@ -2280,6 +2321,8 @@ subroutine OPENWATERCORE(NT,RC) call MAPL_GetPointer(EXPORT,PENPAF , 'PENPAF' , _RC) call MAPL_GetPointer(EXPORT,EVAPOUT, 'EVAPOUT' , _RC) call MAPL_GetPointer(EXPORT,SNOWOCN, 'SNOWOCN' , _RC) + call MAPL_GetPointer(EXPORT,ICEFOCN, 'ICEFOCN' , _RC) + call MAPL_GetPointer(EXPORT,SPTOTOCN,'SPTOTOCN', _RC) call MAPL_GetPointer(EXPORT,RAINOCN, 'RAINOCN' , _RC) call MAPL_GetPointer(EXPORT,SHOUT , 'SHOUT' , _RC) call MAPL_GetPointer(EXPORT,SHWTR , 'SHWTR' , _RC) @@ -2531,7 +2574,7 @@ subroutine OPENWATERCORE(NT,RC) call AOIL_v0 (NT, DO_SKIN_LAYER, DO_DATASEA, n_iter_cool, fr_ice_thresh, trim(DO_GRAD_DECAY_warmLayer), & DT, MUSKIN, epsilon_d, MaxWaterDepth, MinWaterDepth, MaxSalinity, MinSalinity, & - STOKES_SPEED, CM(:,WATER), CFT, CFQ, SH, EVAP, DSH, DEV, THATM, QHATM, PS, SNO, PCU+PLS, & + STOKES_SPEED, CM(:,WATER), CFT, CFQ, SH, EVAP, DSH, DEV, THATM, QHATM, PS, SNO+ICE, PCU+PLS, & UUA, VVA, UW, VW, FRWATER, SWN, SWN_surf, PEN, PEN_ocean, LWDNSRF, ALW, BLW, & HH(:,WATER), TS(:,WATER), SS(:,WATER), QS(:,WATER), TS_FOUNDi, & DWARM_, TBAR_, USTARW_, DCOOL_, TDROP_, SWCOOL_, QCOOL_, BCOOL_, LCOOL_, & @@ -2588,15 +2631,17 @@ subroutine OPENWATERCORE(NT,RC) if(associated(AOSHFLX)) AOSHFLX = SHF *FRWATER if(associated(AOQFLUX)) AOQFLUX = EVP *FRWATER if(associated(AOLWFLX)) AOLWFLX = (LWDNSRF-ALW-BLW*TS(:,WATER))*FRWATER - if(associated(AORAIN )) AORAIN = PCU + PLS - if(associated(AOSNOW )) AOSNOW = SNO *FRWATER + if(associated(AORAIN )) AORAIN = PCU + PLS ! + FRZR as of Jun/2025, FRZR is included in PCU+PLS; see github issue #1111 + if(associated(AOSNOW )) AOSNOW = (SNO+ICE) *FRWATER if(associated(AODRNIR)) AODRNIR = (1.-ALBNRO)*DRNIR*FRWATER if(associated(AODFNIR)) AODFNIR = (1.-ALBNFO)*DFNIR*FRWATER if(associated(FSURF )) FSURF = SWN+LWDNSRF-(ALW+BLW*TS(:,WATER))-SHF-LHF if(associated(PENOCNe)) PENOCNe = PEN_ocean * FRWATER if(associated(SNOWOCN)) SNOWOCN = SNO*FR(:,WATER) - if(associated(RAINOCN)) RAINOCN = PCU + PLS + if(associated(ICEFOCN)) ICEFOCN = ICE*FR(:,WATER) + if(associated(SPTOTOCN))SPTOTOCN = (SNO+ICE)*FR(:,WATER) + if(associated(RAINOCN)) RAINOCN = PCU + PLS ! + FRZR as of Jun/2025, FRZR is included in PCU+PLS; see github issue #1111 if(associated(HLWUP )) HLWUP = ALW*FR(:,WATER) if(associated(LWNDSRF)) LWNDSRF = (LWDNSRF - ALW)*FR(:,WATER) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSsaltwater_GridComp/GEOS_SaltWaterGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSsaltwater_GridComp/GEOS_SaltWaterGridComp.F90 index fa66715ec..568310800 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSsaltwater_GridComp/GEOS_SaltWaterGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSsaltwater_GridComp/GEOS_SaltWaterGridComp.F90 @@ -183,7 +183,7 @@ subroutine SetServices ( GC, RC ) _RC) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'surface_albedo_for_visible_beam', & + LONG_NAME = 'surface_reflectivity_for_visible_beam', & UNITS = '1', & SHORT_NAME = 'ALBVR', & DIMS = MAPL_DimsTileOnly, & @@ -191,7 +191,7 @@ subroutine SetServices ( GC, RC ) _RC) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'surface_albedo_for_visible_diffuse',& + LONG_NAME = 'surface_reflectivity_for_visible_diffuse',& UNITS = '1', & SHORT_NAME = 'ALBVF', & DIMS = MAPL_DimsTileOnly, & @@ -199,7 +199,7 @@ subroutine SetServices ( GC, RC ) _RC) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'surface_albedo_for_near_infrared_beam', & + LONG_NAME = 'surface_reflectivity_for_near_infrared_beam', & UNITS = '1', & SHORT_NAME = 'ALBNR', & DIMS = MAPL_DimsTileOnly, & @@ -207,7 +207,7 @@ subroutine SetServices ( GC, RC ) _RC) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'surface_albedo_for_near_infrared_diffuse', & + LONG_NAME = 'surface_reflectivity_for_near_infrared_diffuse', & UNITS = '1', & SHORT_NAME = 'ALBNF', & DIMS = MAPL_DimsTileOnly, & @@ -697,6 +697,8 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC, SHORT_NAME = 'LWNDWTR' , CHILD_ID = WATER, _RC) call MAPL_AddExportSpec(GC, SHORT_NAME = 'SHWTR' , CHILD_ID = WATER, _RC) call MAPL_AddExportSpec(GC, SHORT_NAME = 'SNOWOCN' , CHILD_ID = WATER, _RC) + call MAPL_AddExportSpec(GC, SHORT_NAME = 'ICEFOCN' , CHILD_ID = WATER, _RC) + call MAPL_AddExportSpec(GC, SHORT_NAME = 'SPTOTOCN' , CHILD_ID = WATER, _RC) call MAPL_AddExportSpec(GC, SHORT_NAME = 'RAINOCN' , CHILD_ID = WATER, _RC) ! Atmosphere-Ocean Interface Layer (AOIL) specific variables diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSsaltwater_GridComp/GEOS_SeaiceInterfaceGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSsaltwater_GridComp/GEOS_SeaiceInterfaceGridComp.F90 index 33ca3bc35..53aeb87b7 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSsaltwater_GridComp/GEOS_SeaiceInterfaceGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSsaltwater_GridComp/GEOS_SeaiceInterfaceGridComp.F90 @@ -164,7 +164,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'surface_albedo_for_visible_beam', & + LONG_NAME = 'surface_reflectivity_for_visible_beam', & UNITS = '1', & SHORT_NAME = 'ALBVR', & DIMS = MAPL_DimsTileOnly, & @@ -173,7 +173,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'surface_albedo_for_visible_diffuse',& + LONG_NAME = 'surface_reflectivity_for_visible_diffuse',& UNITS = '1', & SHORT_NAME = 'ALBVF', & DIMS = MAPL_DimsTileOnly, & @@ -182,7 +182,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'surface_albedo_for_near_infrared_beam', & + LONG_NAME = 'surface_reflectivity_for_near_infrared_beam', & UNITS = '1', & SHORT_NAME = 'ALBNR', & DIMS = MAPL_DimsTileOnly, & @@ -191,7 +191,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'surface_albedo_for_near_infrared_diffuse', & + LONG_NAME = 'surface_reflectivity_for_near_infrared_diffuse', & UNITS = '1', & SHORT_NAME = 'ALBNF', & DIMS = MAPL_DimsTileOnly, & @@ -943,6 +943,27 @@ subroutine SetServices ( GC, RC ) RC=STATUS ) VERIFY_(STATUS) + call MAPL_AddImportSpec(GC ,& + LONG_NAME = 'icefall' ,& + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'ICE' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC ,& + LONG_NAME = 'freezing_rain_fall' ,& + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'FRZR' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + + VERIFY_(STATUS) + + ! Surface air quantities call MAPL_AddImportSpec(GC, & @@ -1283,7 +1304,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'ALBIN' ,& - LONG_NAME = 'ice_surface_albedo_over_ice_categories' ,& + LONG_NAME = 'ice_surface_reflectivity_over_ice_categories' ,& UNITS = '1' ,& DIMS = MAPL_DimsTileOnly ,& UNGRIDDED_DIMS = (/NUM_ICE_CATEGORIES/) ,& @@ -1293,7 +1314,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'ALBSN' ,& - LONG_NAME = 'snow_surface_albedo_over_ice_categories' ,& + LONG_NAME = 'snow_surface_reflectivity_over_ice_categories' ,& UNITS = '1' ,& DIMS = MAPL_DimsTileOnly ,& UNGRIDDED_DIMS = (/NUM_ICE_CATEGORIES/) ,& @@ -2257,6 +2278,8 @@ subroutine CICECORE(NT,RC) real, pointer, dimension(:) :: DEV => null() real, pointer, dimension(:) :: DSH => null() real, pointer, dimension(:) :: SNO => null() + real, pointer, dimension(:) :: ICEF => null() + real, pointer, dimension(:) :: FRZR => null() real, pointer, dimension(:) :: PLS => null() real, pointer, dimension(:) :: PCU => null() real, pointer, dimension(:) :: PS => null() @@ -2338,6 +2361,7 @@ subroutine CICECORE(NT,RC) real, allocatable :: EVAPN (:,:) ! real, allocatable :: LHFN (:,:) ! real, allocatable :: RAIN (:) ! + real, allocatable :: SNOW (:) ! @@ -2382,6 +2406,8 @@ subroutine CICECORE(NT,RC) call MAPL_GetPointer(IMPORT,DEV , 'DEVAP' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT,DSH , 'DSH' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT,SNO , 'SNO' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT,ICEF , 'ICE' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT,FRZR , 'FRZR' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT,PLS , 'PLS' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT,PCU , 'PCU' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT,PS , 'PS' , RC=STATUS); VERIFY_(STATUS) @@ -2481,12 +2507,15 @@ subroutine CICECORE(NT,RC) allocate( TS_OLD(size(TS,1), size(TS,2)), __STAT__) allocate( RAIN(size(TS,1)), __STAT__) + allocate( SNOW(size(TS,1)), __STAT__) ! Aggregate imports if required !----------------------------------- - RAIN = PLS + PCU + RAIN = PLS + PCU ! + FRZR as of Jun/2025, FRZR is included in PCU+PLS; see github issue #1111 + + SNOW = SNO + ICEF ! Initialize PAR and UVR beam fluxes !----------------------------------- @@ -2670,7 +2699,7 @@ subroutine CICECORE(NT,RC) call RegridA2O_2d( EVAPN, SURFST, 'EVAP', XFORM_A2O, locstreamO, __RC__) call RegridA2O_1d( RAIN, SURFST, 'RAIN', XFORM_A2O, locstreamO, __RC__) - call RegridA2O_1d( SNO, SURFST, 'SNOW', XFORM_A2O, locstreamO, __RC__) + call RegridA2O_1d( SNOW, SURFST, 'SNOW', XFORM_A2O, locstreamO, __RC__) call RegridA2O_1d( ZTH, SURFST, 'COSZ', XFORM_A2O, locstreamO, __RC__) call RegridA2O_1d( DRPAR, SURFST, 'DRPAR', XFORM_A2O, locstreamO, __RC__) call RegridA2O_1d( DFPAR, SURFST, 'DFPAR', XFORM_A2O, locstreamO, __RC__) @@ -2821,6 +2850,7 @@ subroutine CICECORE(NT,RC) deallocate( EVAPN, __STAT__) deallocate( LHFN, __STAT__) deallocate( RAIN, __STAT__) + deallocate( SNOW, __STAT__) !deallocate(ALBIN) !deallocate(ALBSN) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSsaltwater_GridComp/GEOS_SimpleSeaiceGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSsaltwater_GridComp/GEOS_SimpleSeaiceGridComp.F90 index a86e02fa4..e3897efc1 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSsaltwater_GridComp/GEOS_SimpleSeaiceGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSsaltwater_GridComp/GEOS_SimpleSeaiceGridComp.F90 @@ -135,33 +135,33 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationNone, & _RC) - call MAPL_AddExportSpec(GC, & + call MAPL_AddExportSpec(GC, & SHORT_NAME = 'ALBVR', & - LONG_NAME = 'surface_albedo_for_visible_beam', & + LONG_NAME = 'surface_reflectivity_for_visible_beam', & UNITS = '1', & DIMS = MAPL_DimsTileOnly, & VLOCATION = MAPL_VLocationNone, & _RC) - call MAPL_AddExportSpec(GC, & + call MAPL_AddExportSpec(GC, & SHORT_NAME = 'ALBVF', & - LONG_NAME = 'surface_albedo_for_visible_diffuse',& + LONG_NAME = 'surface_reflectivity_for_visible_diffuse', & UNITS = '1', & DIMS = MAPL_DimsTileOnly, & VLOCATION = MAPL_VLocationNone, & _RC) - call MAPL_AddExportSpec(GC, & + call MAPL_AddExportSpec(GC, & SHORT_NAME = 'ALBNR', & - LONG_NAME = 'surface_albedo_for_near_infrared_beam', & + LONG_NAME = 'surface_reflectivity_for_near_infrared_beam', & UNITS = '1', & DIMS = MAPL_DimsTileOnly, & VLOCATION = MAPL_VLocationNone, & _RC) - call MAPL_AddExportSpec(GC, & + call MAPL_AddExportSpec(GC, & SHORT_NAME = 'ALBNF', & - LONG_NAME = 'surface_albedo_for_near_infrared_diffuse', & + LONG_NAME = 'surface_reflectivity_for_near_infrared_diffuse', & UNITS = '1', & DIMS = MAPL_DimsTileOnly, & VLOCATION = MAPL_VLocationNone, & @@ -825,6 +825,24 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationNone, & _RC) + call MAPL_AddImportSpec(GC ,& + LONG_NAME = 'icefall' ,& + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'ICE' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + _RC) + + + call MAPL_AddImportSpec(GC ,& + LONG_NAME = 'freezing_rain_fall' ,& + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'FRZR' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + _RC) + + ! Surface air quantities call MAPL_AddImportSpec(GC, & @@ -1772,6 +1790,8 @@ subroutine SEAICECORE(NT,RC) real, pointer, dimension(:) :: DEV => null() real, pointer, dimension(:) :: DSH => null() real, pointer, dimension(:) :: SNO => null() + real, pointer, dimension(:) :: ICEF => null() + real, pointer, dimension(:) :: FRZR => null() real, pointer, dimension(:) :: PLS => null() real, pointer, dimension(:) :: PCU => null() real, pointer, dimension(:) :: PS => null() @@ -1876,6 +1896,8 @@ subroutine SEAICECORE(NT,RC) call MAPL_GetPointer(IMPORT,DEV , 'DEVAP' , _RC) call MAPL_GetPointer(IMPORT,DSH , 'DSH' , _RC) call MAPL_GetPointer(IMPORT,SNO , 'SNO' , _RC) + call MAPL_GetPointer(IMPORT,ICEF , 'ICE' , _RC) + call MAPL_GetPointer(IMPORT,FRZR , 'FRZR' , _RC) call MAPL_GetPointer(IMPORT,PLS , 'PLS' , _RC) call MAPL_GetPointer(IMPORT,PCU , 'PCU' , _RC) call MAPL_GetPointer(IMPORT,PS , 'PS' , _RC) @@ -2150,7 +2172,7 @@ subroutine SEAICECORE(NT,RC) QS(:,N) = QS(:,N) + DQS if (.not. seaIceT_extData) then - HH(:,N) = HH(:,N) + DT*(SNO - EVP) + HH(:,N) = HH(:,N) + DT*(SNO + ICEF - EVP) HH(:,N) = max(min(HH(:,N), MAXICEDEPTH), MINICEDEPTH) endif @@ -2162,7 +2184,7 @@ subroutine SEAICECORE(NT,RC) if(associated(DELQS )) DELQS = DELQS + DQS*CFQ*FR(:,N) if (seaIceT_extData) then - if(associated(HSNO )) HSNO = (DT*(SNO - EVP))/water_RHO('fresh_water') + if(associated(HSNO )) HSNO = (DT*(SNO + ICEF - EVP))/water_RHO('fresh_water') if(associated(SEAICETHICKNESSe )) SEAICETHICKNESSe = SEAICETHICKNESSi endif diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSsaltwater_GridComp/GetPtr.h b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSsaltwater_GridComp/GetPtr.h index 999c8b442..1dc7b3a83 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSsaltwater_GridComp/GetPtr.h +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSsaltwater_GridComp/GetPtr.h @@ -17,6 +17,8 @@ call MAPL_GetPointer(IMPORT,DEV , 'DEVAP' , _RC) call MAPL_GetPointer(IMPORT,DSH , 'DSH' , _RC) call MAPL_GetPointer(IMPORT,SNO , 'SNO' , _RC) + call MAPL_GetPointer(IMPORT,ICEF , 'ICE' , _RC) + call MAPL_GetPointer(IMPORT,FRZR , 'FRZR' , _RC) call MAPL_GetPointer(IMPORT,PLS , 'PLS' , _RC) call MAPL_GetPointer(IMPORT,PCU , 'PCU' , _RC) call MAPL_GetPointer(IMPORT,PS , 'PS' , _RC) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/GEOS_SurfaceGridComp.rc b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/GEOS_SurfaceGridComp.rc index 144c74178..1ba28b70b 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/GEOS_SurfaceGridComp.rc +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/GEOS_SurfaceGridComp.rc @@ -2,15 +2,11 @@ # # # Resource file for surface parameters, *jointly* used by the GCM and GEOSldas. # # # -# Different default values for the GCM and GEOSldas are supported as follows: # -# # -# - Lines that are NOT commented out can be used to specify GCM defaults as # -# needed, because they are ignored by GEOSldas. # -# # -# - The string "GEOSldas=>" identifies the GEOSldas default. # -# # -# This works because this resource file is processed by the GEOSldas # -# script "ldas_setup". # +# Different default values for the GCM and GEOSldas are supported because # +# because this resource file is processed by setup scripts (gcm_setup, # +# fvsetup, ldas_setup). # +# The setup scripts uncomment the appropriate default values by removing the # +# the appropriate '# GEOS[xxxx]=>' strings. # # # # NOTE: For the GCM, there must NOT be white space between the resource # # parameter name and the colon. # @@ -29,13 +25,20 @@ # # #################################################################################### -# ---- Surface layer turbulence scheme +# ---- Monin-Obukhov (MO) surface layer turbulence scheme # # 0 : Louis (MERRA, Fortuna-DAS, SMAP NRv4/4.1/5/7.2/8.1/9.1/10.0) -# 1 : Helfand Monin-Obukhov (Fortuna-AR5, Ganymed, Heracles, Icarus-3_2, MERRA-2) +# 1 : Helfand (Fortuna-AR5, Ganymed, Heracles, Icarus-3_2, MERRA-2) +# +# Note: For *offline* simulations, optional use of extra MO derivatives is supported +# through rc parameter MOSFC_EXTRA_DERIVS_LAND (see catch_wrap_state.F90). # -# GEOSagcm=>CHOOSEMOSFC: 1 -# GEOSldas=>CHOOSEMOSFC: 0 +# GEOSagcm=>CHOOSEMOSFC: 1 +# GEOSagcm=>MOSFC_EXTRA_DERIVS_OFFL_LAND: 0 +# +# GEOSldas=>CHOOSEMOSFC: 0 +# GEOSldas=>MOSFC_EXTRA_DERIVS_OFFL_LAND: 1 + # ---- Thickness of surface layer for soil moisture [mm] # @@ -120,7 +123,7 @@ # - backfilled with global land average snow albedo where unavailable # - must use compatible bcs version that includes MODIS-based snow albedo (e.g., v06, v08, v09, ...) # - NOTE: bcs v06, v08, and v09 used approximate averaging of MODIS-based snow albedo to tile space; -# bcs v11 and v12 employ more accurate, raster-based averaging. +# bcs v11, v12 and v13 employ more accurate, raster-based averaging. # # GEOSagcm=>SNOW_ALBEDO_INFO: 0 # GEOSldas=>SNOW_ALBEDO_INFO: 0 @@ -129,13 +132,15 @@ # GOSWIM aerosol deposition on surface snow # #--------------------------------------------------------# +# *** NOTE: GOSWIM is DISABLED via hardcoded N_constit=0 in StieglitzSnow.F90 *** + # ---- Aerosol deposition on snow (available only with MERRA-2 forcings) # # 0 : GOCART aerosol are NOT used (default) -# 1 : Use all GOCART aerosol data -# 2 : Use GOCART aerosols *except* dust -# 3 : Use GOCART aerosols *except* black carbon -# 4 : Use GOCART aerosols *except* organic carbon +# DISABLED: 1 : Use all GOCART aerosol data +# DISABLED: 2 : Use GOCART aerosols *except* dust +# DISABLED: 3 : Use GOCART aerosols *except* black carbon +# DISABLED: 4 : Use GOCART aerosols *except* organic carbon # # GEOSagcm=>AEROSOL_DEPOSITION: 0 # GEOSldas=>AEROSOL_DEPOSITION: 0 @@ -145,7 +150,7 @@ # NOTE: There are separate parameters for LAND and LANDICE # # 0 : Default, GOSWIM snow albedo scheme is turned OFF for land/landice -# 9 : GOSWIM snow albedo scheme is turned ON for land/landice +# DISABLED: 9 : GOSWIM snow albedo scheme is turned ON for land/landice # # GEOSagcm=>N_CONST_LAND4SNWALB: 0 # GEOSldas=>N_CONST_LAND4SNWALB: 0 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/StieglitzSnow.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/StieglitzSnow.F90 index 99f1c8ea4..c0aa05caf 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/StieglitzSnow.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/StieglitzSnow.F90 @@ -95,7 +95,24 @@ module StieglitzSnow integer, parameter, public :: NUM_SUDP = 1, NUM_SUSV = 1, NUM_SUWT = 1, NUM_SUSD = 1 integer, parameter, public :: NUM_SSDP = 5, NUM_SSSV = 5, NUM_SSWT = 5, NUM_SSSD = 5 - integer, public, parameter :: N_constit = 9 ! Number of constituents in snow + ! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! + ! Turn off GOSWIM by setting N_constit=0 + ! + integer, parameter, public :: N_constit = 0 ! number of constituents *used* below + integer, parameter, private :: N_constit_GOSWIM = 9 ! number of constituents in GOSWIM + ! + ! Previously, N_constit=9 was hardwired even though GOSWIM was never used. + ! The GCM's rc parameter AEROSOL_DEPOSITION was set to 0, which forced + ! the constituent mass and the deposition rates to remain zero, but the many + ! do loops through the 9 constituents were still executed, thus multiplying and adding lots + ! zeros many times. + ! + ! If needed, recover original behavior by setting N_constit=N_constit_GOSWIM=9 + ! + ! - reichle, 31 Jan 2025 + ! + ! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ! (for riv, rin,aicev, aicen, and denice, instead use Teppei-defined ! values below) @@ -128,7 +145,7 @@ module StieglitzSnow ! constants for snow constituents (dust, carbon, etc.) ! MAC, visible (VIS) - real, private, parameter, dimension(N_constit) :: ABVIS = (/ & + real, private, parameter, dimension(N_constit_GOSWIM) :: ABVIS = (/ & 0.148, & ! Dust1 0.106, & ! Dust2 0.076, & ! Dust3 @@ -140,7 +157,7 @@ module StieglitzSnow 0.114 /) ! Organic carbon hydrophic ! MAC, near-infrared (NIR) - real, private, parameter, dimension(N_constit) :: ABNIR = (/ & + real, private, parameter, dimension(N_constit_GOSWIM) :: ABNIR = (/ & 0.095, & ! Dust1 0.080, & ! Dust2 0.062, & ! Dust3 @@ -158,7 +175,7 @@ module StieglitzSnow ! Tuning parameters so as to satisfy NCAR/CLM based scavenging efficiencies; ! See more in Yasunari et al. (SOLA, 2014) - real, private, parameter, dimension(N_constit) :: SCAV = (/ & + real, private, parameter, dimension(N_constit_GOSWIM) :: SCAV = (/ & 0.065442, & ! Dust 1 0.077829, & ! Dust 2 0.306841, & ! Dust 3 @@ -172,7 +189,7 @@ module StieglitzSnow ! Representative particle size in diameter ! based on effective radius GOCART/GEOS-5 (dust 1-5 bins, BC, and OC) [um] - real, private, parameter, dimension(N_constit) :: PSIZE = (/ & + real, private, parameter, dimension(N_constit_GOSWIM) :: PSIZE = (/ & 1.272, & ! Dust 1 2.649, & ! Dust 2 4.602, & ! Dust 3 @@ -240,7 +257,7 @@ subroutine StieglitzSnow_snowrt(tile_lon, tile_lat, & ! wesn : Layer water contents per unit area of catchment [kg/m^2] ! htsnn : Layer heat contents relative to liquid water at 0 C [J/m^2] ! sndz : Layer depths [m] - ! rconstit : Mass of constituents in snow layer [kg] (i.e., [kg m-2]) + ! rconstit : Mass of constituents in snow layer [kg] (i.e., [kg m-2]) ! rmelt : Flushed mass amount of constituents from the bottom snow layer [kg m-2 s-1 (kg/m^2/s)] !********* ! OUTPUTS: @@ -403,7 +420,8 @@ subroutine StieglitzSnow_snowrt(tile_lon, tile_lat, & dtss = 0. excswe = 0. - rmelt = 0.0 + if (N_constit>0) rmelt = 0.0 + mltwtr = 0.0 drho0 = 0.0 tksno = 0.0 @@ -424,7 +442,7 @@ subroutine StieglitzSnow_snowrt(tile_lon, tile_lat, & do k=1,N_constit rmelt(k)=sum(rconstit(:,k))/dts enddo - rconstit(:,:) = 0. + if (N_constit>0) rconstit(:,:) = 0. if(snowf > 0.) then ! only initialize with non-liquid part of precip ! liquid precip (rainf) is part of outflow from snow base (see "pre" above) @@ -742,9 +760,9 @@ subroutine StieglitzSnow_snowrt(tile_lon, tile_lat, & !**** Updated by Koster, August 27, 2002. pre = 0. - rmelt(:) = 0. + if (N_constit>0) rmelt(:) = 0. flow = 0. - flow_r(:) = 0. + if (N_constit>0) flow_r(:) = 0. wesnperc = wesn @@ -762,8 +780,11 @@ subroutine StieglitzSnow_snowrt(tile_lon, tile_lat, & pre = max((1.-fices(i))*wesn(i), 0.) flow = 0. - flow_r(:) = 0. - rconc(:) = 0. + + if (N_constit>0) then + flow_r(:) = 0. + rconc(:) = 0. + end if if(snowd > wemin) then @@ -1294,7 +1315,7 @@ subroutine StieglitzSnow_relayer(N_snow, N_constit, tileType, targetthick, & if (present(rc_calc_tpsn)) rc_calc_tpsn = rc_tmp - if (conserve_ice10_tzero) then + if (conserve_ice10_tzero_tmp) then !**** Check that (ice10,tzero) conditions are conserved through !**** relayering process (or at least that (fices,tpsn) conditions don't diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/.gitignore b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/.gitignore new file mode 100644 index 000000000..e833754b5 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/.gitignore @@ -0,0 +1,3 @@ +/@ncar_topo/ +/ncar_topo/ +/ncar_topo@/ diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/CMakeLists.txt index 005bc3bd9..895b59f9d 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/CMakeLists.txt +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/CMakeLists.txt @@ -2,7 +2,6 @@ esma_set_this() set (srcs LDAS_DateTimeMod.F90 -EASE_conv.F90 mod_process_hres_data.F90 rasterize.F90 read_riveroutlet.F90 @@ -38,6 +37,8 @@ else () target_compile_definitions(${this} PRIVATE STDC) endif () +esma_add_subdirectories (@ncar_topo utils_topo) + ecbuild_add_executable (TARGET CombineRasters.x SOURCES CombineRasters.F90 LIBS MAPL ${this}) ecbuild_add_executable (TARGET mkCatchParam.x SOURCES mkCatchParam.F90 LIBS MAPL ${this} OpenMP::OpenMP_Fortran) ecbuild_add_executable (TARGET mkCubeFVRaster.x SOURCES mkCubeFVRaster.F90 LIBS MAPL ${this}) @@ -48,11 +49,14 @@ ecbuild_add_executable (TARGET mkMOMAquaRaster.x SOURCES mkMOMAquaRaster.F90 LIB ecbuild_add_executable (TARGET FillMomGrid.x SOURCES FillMomGrid.F90 LIBS MAPL ${this}) ecbuild_add_executable (TARGET mk_runofftbl.x SOURCES mk_runofftbl.F90 LIBS MAPL ${this}) ecbuild_add_executable (TARGET mkEASETilesParam.x SOURCES mkEASETilesParam.F90 LIBS MAPL ${this}) +ecbuild_add_executable (TARGET TileFile_ASCII_to_nc4.x SOURCES TileFile_ASCII_to_nc4.F90 LIBS MAPL ${this}) install(PROGRAMS clsm_plots.pro create_README.csh DESTINATION bin) file(GLOB MAKE_BCS_PYTHON CONFIGURE_DEPENDS "./make_bcs*.py") list(FILTER MAKE_BCS_PYTHON EXCLUDE REGEX "make_bcs_shared.py") -install(PROGRAMS ${MAKE_BCS_PYTHON} DESTINATION bin) +install(PROGRAMS ${MAKE_BCS_PYTHON} DESTINATION bin) +install(PROGRAMS TileFile_ASCII_to_nc4.py DESTINATION bin) +install(PROGRAMS ExtractBCsFromOrig.py DESTINATION bin) set(file ./make_bcs_shared.py) configure_file(${file} ${file} @ONLY) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/CombineRasters.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/CombineRasters.F90 index b81da0868..001bce06c 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/CombineRasters.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/CombineRasters.F90 @@ -3,7 +3,7 @@ program mkOverlaySimple - use LogRectRasterizeMod + use LogRectRasterizeMod, ONLY: WriteRaster, WriteTiling, SortTiling use MAPL_SortMod use MAPL_HashMod use MAPL_ExceptionHandling @@ -28,7 +28,7 @@ program mkOverlaySimple integer, parameter :: TILUNIT1 = 22 integer, parameter :: TILUNIT2 = 23 - real(kind=8), parameter :: PI = MAPL_PI_R8 + real(REAL64), parameter :: PI = MAPL_PI_R8 integer :: command_argument_count integer :: nxt, argl, fill @@ -43,12 +43,12 @@ program mkOverlaySimple integer, allocatable :: RST2(: ) integer, allocatable :: iTable(:,:) - real(kind=8) , allocatable :: Table1(:,:) - real(kind=8) , allocatable :: Table2(:,:) - real(kind=8) , allocatable :: rTable(:,:) - real(kind=8) , allocatable :: cc(:), ss(:) - real(kind=8) :: dx, dy, area, xc, yc, d2r, vv(4) - real(kind=8) :: lats, lons, da + real(REAL64) , allocatable :: Table1(:,:) + real(REAL64) , allocatable :: Table2(:,:) + real(REAL64) , allocatable :: rTable(:,:) + real(REAL64) , allocatable :: cc(:), ss(:) + real(REAL64) :: dx, dy, area, xc, yc, d2r, vv(4) + real(REAL64) :: lats, lons, da logical :: DoZip logical :: Verb diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/CubedSphere_GridMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/CubedSphere_GridMod.F90 index d3331da0e..642ad4770 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/CubedSphere_GridMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/CubedSphere_GridMod.F90 @@ -2,7 +2,7 @@ module CubedSphere_GridMod use MAPL_ConstantsMod -#define r8 kind=8 +#define r8 REAL64 implicit none diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/EASE_conv.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/EASE_conv.F90 deleted file mode 100644 index 2060d77d5..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/EASE_conv.F90 +++ /dev/null @@ -1,786 +0,0 @@ - -module EASE_conv - - ! ===================================================================================== - ! - ! EASE_conv.F90 - FORTRAN routines for conversion of Equal-Area Scalable Earth (EASE) - ! grid coordinates (lat/lon <--> row/col indices) - ! - ! Implemented for global cylindrical ('Mxx') EASE grids only. - ! - ! Works for EASE[v1] and EASEv2 grids. - ! - ! ------------------------------------------------------------------------------------- - ! - ! CHANGELOG (easeV1_conv.F90): - ! ============================ - ! - ! easeV1_conv.F90 - FORTRAN routines for conversion of azimuthal - ! equal area and equal area cylindrical grid coordinates - ! - ! 30-Jan-1992 H.Maybee - ! 20-Mar-1992 Ken Knowles 303-492-0644 knowles@kryos.colorado.edu - ! 16-Dec-1993 MJ Brodzik 303-492-8263 brodzik@jokull.colorado.edu - ! Copied from nsmconv.f, changed resolutions from - ! 40-20-10 km to 25-12.5 km - ! 21-Dec-1993 MJ Brodzik 303-492-8263 brodzik@jokull.colorado.edu - ! Fixed sign of Southern latitudes in ease_inverse. - ! 12-Sep-1994 David Hoogstrate 303-492-4116 hoogstra@jokull.colorado.edu - ! Changed grid cell size. Changed "c","f" to "l","h" - ! 25-Oct-1994 David Hoogstrate 303-492-4116 hoogstra@jokull.colorado.edu - ! Changed row size from 587 to 586 for Mercator projection - ! 11-May-2011 reichle: Changed "smap" to "easeV1". - ! Added SSM/I and AMSR-E "M25" grid. - ! So far ONLY for cylindrical grids. - ! Converted from *.f to *.F90 module - ! - ! $Log$ - ! Revision 1.1 2011-05-11 21:58:46 rreichle - ! Adding utilities to map between EASE grids and lat/lon coordinates. - ! - ! Revision 1.3 1994/11/01 23:40:43 brodzik - ! Replaced all references to 'ease' with 'smap' - ! Replaced all references to 'smap' with 'easeV1' -- reichle - ! - ! - ! CHANGELOG (easeV2_conv.F90): - ! ============================ - ! - ! easeV2_conv.F90 - FORTRAN routines for converting grid coordinates - ! (latitude/longitude <--> row/column indices) - ! of the Equal Area Scalable Earth, version 2 (EASEv2) grid - ! - ! ***** ONLY cylindrical ('M') projection implemented ***** - ! - ! Ported from Steven Chan's matlab code (smapease2inverse.m, - ! smapease2forward.m), which has been ported from NSIDC's IDL code - ! (wgs84_convert.pro, wgs84_inverse.pro) available from - ! ftp://sidads.colorado.edu/pub/tools/easegrid/geolocation_tools/ - ! - ! Official references: - ! doi:10.3390/ijgi1010032 - ! doi:10.3390/ijgi3031154 -- correction of M25 "map_scale_m" parameters! - ! - ! 04-Apr-2013 - reichle - ! 11-Sep-2018 - reichle, mgirotto -- added 'M25' grid parameters - ! - ! - ! CHANGELOG (EASE_conv.F90): - ! ========================== - ! - ! 2022-09-13, wjiang+reichle: - ! merged easeV1_conv.F90 and easeV2_conv.F90 into EASE_conv.F90 - ! - using different values for PI in easeV1 and easeV2 calcs as in old easeV[x]_conv.F90 modules; - ! in contrast, LDAS_EASE_conv.F90 in GEOSldas used only a single value for PI. - ! - bug fix in easeV2_get_params() for EASEv2/M25 (to compute s0, divide by 2.0 not by integer 2) - ! - ! - ! ========================================================================== - - implicit none - - private - - public :: ease_convert - public :: ease_inverse - public :: ease_extent - - ! ======================================================================= - ! - ! EASEv1 global constants - - ! ***NEVER*** change these constants to GEOS MAPL constants!!!! - - ! radius of the earth (km), authalic sphere based on International datum - - real*8, parameter :: easeV1_RE_km = 6371.228 - - ! scale factor for standard paralles at +/-30.00 degrees - - real*8, parameter :: easeV1_COS_PHI1 = .866025403 - - real*8, parameter :: easeV1_PI = 3.141592653589793 - - ! ======================================================================= - ! - ! EASEv2 global constants - - ! ***NEVER*** change these constants to GEOS MAPL constants!!!! - - ! radius of the earth (m) and map eccentricity - - real*8, parameter :: map_equatorial_radius_m = 6378137.0 - - real*8, parameter :: map_eccentricity = 0.081819190843 - - real*8, parameter :: easeV2_PI = 3.14159265358979323846 - - real*8, parameter :: e2 = map_eccentricity * map_eccentricity - real*8, parameter :: e4 = e2 * e2 - real*8, parameter :: e6 = e2 * e4 - - real*8, parameter :: epsilon = 1.e-6 - - real*8, parameter :: map_reference_longitude = 0.0 ! 'M', 'N', 'S' - - ! constants for 'N' and 'S' (azimuthal) projections - - real*8, parameter :: N_map_reference_latitude = 90.0 - real*8, parameter :: S_map_reference_latitude = -90.0 - - ! constants for 'M' (cylindrical) projection - - real*8, parameter :: M_map_reference_latitude = 0.0 - real*8, parameter :: M_map_second_reference_latitude = 30.0 - - real*8, parameter :: M_sin_phi1 = sin(M_map_second_reference_latitude*easeV2_PI/180.) - real*8, parameter :: M_cos_phi1 = cos(M_map_second_reference_latitude*easeV2_PI/180.) - - real*8, parameter :: M_kz = M_cos_phi1/sqrt(1.0-e2*M_sin_phi1*M_sin_phi1) - - -contains - - ! ******************************************************************* - ! - ! GENERIC routines (public interface) - ! - ! ******************************************************************* - ! - ! EASELabel = *EASEv[x]_[p][yy]* (e.g., EASEv2_M09) - ! - ! version: x = { 1, 2 } - ! projection: p = { M } ! only cylindrical ("M") implemented - ! resolution: yy = { 01, 03, 09, 25, 36 } ! 12.5 km not yet implemented - ! - ! Coordinate arguments for ease_convert() and ease_inverse(): - ! - ! | map coords | 0-based index | # grid cells | - ! | | (real numbers!) | | - ! ---------------------------------------------------------- - ! | latitude | s | rows | - ! | longitude | r | cols | - ! - ! Indices are 0-based and run west to east (r) and north to south (s). - ! - ! -------------------------------------------------------------------- - - subroutine ease_convert (EASELabel, lat, lon, r, s) ! note odd/reversed order of (lat,lon) and (r,s) - - character*(*), intent(in) :: EASELabel - real, intent(in) :: lat, lon - real, intent(out) :: r, s ! r = lon index, s = lat index - - character(3) :: grid - - if ( index(EASELabel,'M36') /=0 ) then - grid='M36' - else if (index(EASELabel,'M25') /=0 ) then - grid='M25' - else if (index(EASELabel,'M09') /=0 ) then - grid='M09' - else if (index(EASELabel,'M03') /=0 ) then - grid='M03' - else if (index(EASELabel,'M01') /=0 ) then - grid='M01' - else - print*,"ease_convert(): unknown grid projection and resolution: "//trim(EASELabel)//" STOPPING." - stop - endif - - if( index(EASELabel,'EASEv2') /=0) then - call easeV2_convert(grid,lat,lon,r,s) - else if(index(EASELabel,'EASEv1') /=0) then - call easeV1_convert(grid,lat,lon,r,s) - else - print*,"ease_convert(): unknown grid version: "//trim(EASELabel)//" STOPPING." - stop - endif - - end subroutine ease_convert - - ! ******************************************************************* - - subroutine ease_inverse (EASELabel, r, s, lat, lon) ! note odd/reversed order of (r,s) and (lat,lon) - - ! Note: Get lat/lon of grid cell borders by using fractional indices. - ! E.g., s=-0.5 yields northern grid cell boundary of northernmost grid cells. - - character*(*), intent(in) :: EASELabel - real, intent(in) :: r, s ! r = lon index, s = lat index - real, intent(out) :: lat, lon - - character(3) :: grid - - if ( index(EASELabel,'M36') /=0 ) then - grid='M36' - else if (index(EASELabel,'M25') /=0 ) then - grid='M25' - else if (index(EASELabel,'M09') /=0 ) then - grid='M09' - else if (index(EASELabel,'M03') /=0 ) then - grid='M03' - else if (index(EASELabel,'M01') /=0 ) then - grid='M01' - else - print*,"ease_inverse(): unknown grid projection and resolution: "//trim(EASELabel)//" STOPPING." - stop - endif - - if( index(EASELabel,'EASEv2') /=0) then - call easeV2_inverse(grid,r,s,lat,lon) - else if(index(EASELabel,'EASEv1') /=0) then - call easeV1_inverse(grid,r,s,lat,lon) - else - print*,"ease_inverse(): unknown grid version: "//trim(EASELabel)//" STOPPING." - stop - endif - - end subroutine ease_inverse - - ! ******************************************************************* - - subroutine ease_extent (EASELabel, cols, rows, cell_area, ll_lon, ll_lat, ur_lon, ur_lat) - - ! get commonly used EASE grid parameters - - character*(*), intent(in) :: EASELabel - integer, intent(out) :: cols, rows ! number of grid cells in lon and lat direction, resp. - real, optional, intent(out) :: cell_area ! [m^2] - real, optional, intent(out) :: ll_lon ! lon of grid cell boundary in lower left corner - real, optional, intent(out) :: ll_lat ! lat of grid cell boundary in lower left corner - real, optional, intent(out) :: ur_lon ! lon of grid cell boundary in upper right corner - real, optional, intent(out) :: ur_lat ! lat of grid cell boundary in upper right corner - - ! --------------------------------------------------------------------- - - real*8 :: map_scale_m, CELL_km, r0, s0, Rg - real :: tmplon - character(3) :: grid - - if ( index(EASELabel,'M36') /=0 ) then - grid='M36' - else if (index(EASELabel,'M25') /=0 ) then - grid='M25' - else if (index(EASELabel,'M09') /=0 ) then - grid='M09' - else if (index(EASELabel,'M03') /=0 ) then - grid='M03' - else if (index(EASELabel,'M01') /=0 ) then - grid='M01' - else - print*,"ease_extent(): unknown grid projection and resolution: "//trim(EASELabel)//" STOPPING." - stop - endif - - if( index(EASELabel,'EASEv2') /=0) then - - call easeV2_get_params(grid, map_scale_m, cols, rows, r0, s0) - - if(present(cell_area)) cell_area = map_scale_m**2 - - else if(index(EASELabel,'EASEv1') /=0) then - - call easeV1_get_params(grid, CELL_km, cols, rows, r0, s0, Rg) - - if(present(cell_area)) cell_area = CELL_km**2 * 1000. * 1000. - - else - - print*,"ease_extent(): unknown grid version: "//trim(EASELabel)//" STOPPING." - stop - - endif - - ! get lat/lon of corner grid cells - ! - ! recall that EASE grid indexing is zero-based - - if (present(ll_lat)) call ease_inverse(EASElabel, 0., rows-0.5, ll_lat, tmplon) - if (present(ur_lat)) call ease_inverse(EASElabel, 0., -0.5, ur_lat, tmplon) - - if (present(ll_lon)) ll_lon = -180. - if (present(ur_lon)) ur_lon = 180. - - end subroutine ease_extent - - ! ******************************************************************* - ! - ! EASEv1 routines (private) - ! - ! ******************************************************************* - - subroutine easeV1_convert (grid, lat, lon, r, s) - - ! convert geographic coordinates (spherical earth) to - ! azimuthal equal area or equal area cylindrical grid coordinates - ! - ! status = easeV1_convert (grid, lat, lon, r, s) - ! - ! input : grid - projection name '[M][xx]' - ! where xx = approximate resolution [km] - ! ie xx = "01", "03", "09", "36" (SMAP) - ! or xx = "12", "25" (SSM/I, AMSR-E) - ! lat, lon = geo. coords. (decimal degrees) - ! - ! output: r, s - column, row coordinates - ! - ! result: status = 0 indicates normal successful completion - ! -1 indicates error status (point not on grid) - ! - ! -------------------------------------------------------------------------- - - character*(*), intent(in) :: grid - real, intent(in) :: lat, lon - real, intent(out) :: r, s - - ! local variables - - integer :: cols, rows - real*8 :: Rg, phi, lam, rho, CELL_km, r0, s0 - - real*8, parameter :: PI = easeV1_PI - - ! --------------------------------------------------------------------- - - call easeV1_get_params( grid, CELL_km, cols, rows, r0, s0, Rg ) - - phi = lat*PI/180. ! convert from degree to radians - lam = lon*PI/180. ! convert from degree to radians - - if (grid(1:1).eq.'N') then - rho = 2 * Rg * sin(PI/4. - phi/2.) - r = r0 + rho * sin(lam) - s = s0 + rho * cos(lam) - - else if (grid(1:1).eq.'S') then - rho = 2 * Rg * cos(PI/4. - phi/2.) - r = r0 + rho * sin(lam) - s = s0 - rho * cos(lam) - - else if (grid(1:1).eq.'M') then - r = r0 + Rg * lam * easeV1_COS_PHI1 - s = s0 - Rg * sin(phi) / easeV1_COS_PHI1 - - endif - - end subroutine easeV1_convert - - ! ******************************************************************* - - subroutine easeV1_inverse (grid, r, s, lat, lon) - - ! convert azimuthal equal area or equal area cylindrical - ! grid coordinates to geographic coordinates (spherical earth) - ! - ! status = easeV1_inverse (grid, r, s, lat, lon) - ! - ! input : grid - projection name '[M][xx]' - ! where xx = approximate resolution [km] - ! ie xx = "01", "03", "09", "36" (SMAP) - ! or xx = "12", "25" (SSM/I, AMSR-E) - ! r, s - column, row coordinates - ! - ! output: lat, lon = geo. coords. (decimal degrees) - ! - ! result: status = 0 indicates normal successful completion - ! -1 indicates error status (point not on grid) - ! - ! -------------------------------------------------------------------------- - - character*(*), intent(in) :: grid - real, intent(in) :: r, s - real, intent(out) :: lat, lon - - ! local variables - - integer :: cols, rows - real*8 :: Rg, phi, lam, rho, CELL_km, r0, s0 - real*8 :: gamma, beta, epsilon, x, y, c - real*8 :: sinphi1, cosphi1 - - real*8, parameter :: PI = easeV1_PI - - ! --------------------------------------------------------------------- - - call easeV1_get_params( grid, CELL_km, cols, rows, r0, s0, Rg ) - - x = r - r0 - y = -(s - s0) - - if ((grid(1:1).eq.'N').or.(grid(1:1).eq.'S')) then - rho = sqrt(x*x + y*y) - if (rho.eq.0.0) then - if (grid(1:1).eq.'N') lat = 90.0 - if (grid(1:1).eq.'S') lat = -90.0 - lon = 0.0 - else - if (grid(1:1).eq.'N') then - sinphi1 = sin(PI/2.) - cosphi1 = cos(PI/2.) - if (y.eq.0.) then - if (r.le.r0) lam = -PI/2. - if (r.gt.r0) lam = PI/2. - else - lam = atan2(x,-y) - endif - else if (grid(1:1).eq.'S') then - sinphi1 = sin(-PI/2.) - cosphi1 = cos(-PI/2.) - if (y.eq.0.) then - if (r.le.r0) lam = -PI/2. - if (r.gt.r0) lam = PI/2. - else - lam = atan2(x,y) - endif - endif - gamma = rho/(2 * Rg) - if (abs(gamma) .gt. 1.) return - c = 2 * asin(gamma) - beta = cos(c) * sinphi1 + y * sin(c) * (cosphi1/rho) - if (abs(beta).gt.1.) return - phi = asin(beta) - lat = phi*180./PI ! convert from radians to degree - lon = lam*180./PI ! convert from radians to degree - endif - - else if (grid(1:1).eq.'M') then - - ! allow .5 cell tolerance in arcsin function - ! so that grid coordinates which are less than .5 cells - ! above 90.00N or below 90.00S are given a lat of 90.00 - - epsilon = 1 + 0.5/Rg - beta = y*easeV1_COS_PHI1/Rg - if (abs(beta).gt.epsilon) return - if (beta.le.-1.) then - phi = -PI/2. - else if (beta.ge.1.) then - phi = PI/2. - else - phi = asin(beta) - endif - lam = x/easeV1_COS_PHI1/Rg - lat = phi*180./PI ! convert from radians to degree - lon = lam*180./PI ! convert from radians to degree - endif - - end subroutine easeV1_inverse - - ! ******************************************************************* - - subroutine easeV1_get_params( grid, CELL_km, cols, rows, r0, s0, Rg ) - - implicit none - - character*(*), intent(in) :: grid - real*8, intent(out) :: CELL_km, r0, s0, Rg - integer, intent(out) :: cols, rows - - ! -------------------------------------------------------- - ! - ! r0,s0 are defined such that cells at all scales have - ! coincident center points - ! - !c r0 = (cols-1)/2. * scale - !c s0 = (rows-1)/2. * scale - ! - ! -------------------------------------------------------- - - if ((grid(1:1).eq.'N').or.(grid(1:1).eq.'S')) then - - print *,'easeV1_get_params(): polar projections not implemented yet' - stop - - else if (grid(1:1).eq.'M') then - - if (grid .eq. 'M36') then ! SMAP 36 km grid - CELL_km = 36.00040279063 ! nominal cell size in kilometers - cols = 963 - rows = 408 - r0 = 481.0 - s0 = 203.5 - - else if (grid .eq. 'M25') then ! SSM/I, AMSR-E 25 km grid - CELL_km = 25.067525 ! nominal cell size in kilometers - cols = 1383 - rows = 586 - r0 = 691.0 - s0 = 292.5 - - else if (grid .eq. 'M09') then ! SMAP 9 km grid - CELL_km = 9.00010069766 ! nominal cell size in kilometers - cols = 3852 - rows = 1632 - r0 = 1925.5 - s0 = 815.5 - - else if (grid .eq. 'M03') then ! SMAP 3 km grid - CELL_km = 3.00003356589 ! nominal cell size in kilometers - cols = 11556 - rows = 4896 - r0 = 5777.5 - s0 = 2447.5 - - else if (grid .eq. 'M01') then ! SMAP 1 km grid - CELL_km = 1.00001118863 ! nominal cell size in kilometers - cols = 34668 - rows = 14688 - r0 = 17333.5 - s0 = 7343.5 - - else - - print *,'easeV1_get_params(): unknown resolution: ',grid - stop - - endif - - else - - print *, 'easeV1_get_params(): unknown projection: ', grid - stop - - endif - - Rg = easeV1_RE_km/CELL_km - - end subroutine easeV1_get_params - - - ! ******************************************************************* - ! - ! EASEv2 routines (private) - ! - ! ******************************************************************* - - subroutine easeV2_convert (grid, lat, lon, col_ind, row_ind) - - ! convert geographic coordinates (spherical earth) to - ! azimuthal equal area or equal area cylindrical grid coordinates - ! - ! *** NOTE order of calling arguments: "lat-lon-lon-lat" *** - ! - ! useage: call easeV2_convert (grid, lat, lon, r, s) - ! - ! input : grid - projection name '[M][xx]' - ! where xx = approximate resolution [km] - ! ie xx = "01", "03", "09", "36" (SMAP) - ! lat, lon = geo. coords. (decimal degrees) - ! - ! output: col_ind, row_ind - column, row coordinates - ! - ! -------------------------------------------------------------------------- - - character*(*), intent(in) :: grid - real, intent(in) :: lat, lon - real, intent(out) :: col_ind, row_ind - - ! local variables - - integer :: cols, rows - real*8 :: dlon, phi, lam, map_scale_m, r0, s0, ms, x, y, sin_phi, q - - real*8, parameter :: PI = easeV2_PI - - ! --------------------------------------------------------------------- - - call easeV2_get_params( grid, map_scale_m, cols, rows, r0, s0 ) - - dlon = lon - - if (abs(map_reference_longitude)>epsilon) then - - dlon = lon - map_reference_longitude - - end if - - if (dlon .lt. -180.0) dlon = dlon + 360.0 - if (dlon .gt. 180.0) dlon = dlon - 360.0 - - phi = lat*PI/180. ! convert from degree to radians - lam = dlon*PI/180. ! convert from degree to radians - - sin_phi = sin(phi) - - ms = map_eccentricity*sin_phi - - q = (1. - e2)* & - ( & - (sin_phi /(1. - e2*sin_phi*sin_phi)) & - - & - .5/map_eccentricity*log((1.-ms)/(1.+ms)) & - ) - - ! note: "qp" only needed for 'N' and 'S' projections - - if (grid(1:1).eq.'M') then - - x = map_equatorial_radius_m*M_kz*lam - - y = (map_equatorial_radius_m*q)/(2.*M_kz) - - else - - print *,'EASEv2_convert(): Polar projections not implemented yet' - stop - - endif - - row_ind = s0 - (y/map_scale_m) - col_ind = r0 + (x/map_scale_m) - - end subroutine easeV2_convert - - ! ******************************************************************* - - subroutine easeV2_inverse (grid, r, s, lat, lon) - - ! convert azimuthal equal area or equal area cylindrical - ! grid coordinates to geographic coordinates (spherical earth) - ! - ! *** NOTE order of calling arguments: "lon-lat-lat-lon" *** - ! - ! useage: call easeV1_inverse (grid, r, s, lat, lon) - ! - ! input : grid - projection name '[M][xx]' - ! where xx = approximate resolution [km] - ! ie xx = "01", "03", "09", "36" (SMAP) - ! r, s - column, row coordinates - ! - ! output: lat, lon = geo. coords. (decimal degrees) - ! - ! -------------------------------------------------------------------------- - - character*(*), intent(in) :: grid - real, intent(in) :: r, s - real, intent(out) :: lat, lon - - ! local variables - - integer :: cols, rows - real*8 :: phi, lam, map_scale_m, r0, s0, beta, x, y, qp - - real*8, parameter :: PI = easeV2_PI - - ! --------------------------------------------------------------------- - - call easeV2_get_params( grid, map_scale_m, cols, rows, r0, s0 ) - - x = (r - r0)*map_scale_m - y = -(s - s0)*map_scale_m - - qp = (1. - e2)* & - ( & - (1./(1.-e2)) & - - & - .5/map_eccentricity*log((1.-map_eccentricity)/(1.+map_eccentricity)) & - ) - - if (grid(1:1).eq.'M') then - - beta = asin(2.*y*M_kz/(map_equatorial_radius_m*qp)) - - lam = x/(map_equatorial_radius_m*M_kz) - - else - - print *,'EASEv2_inverse(): Polar projections not implemented yet' - stop - - endif - - phi = beta & - + ( ( e2/3. + 31./180.*e4 + 517./ 5040.*e6 )*sin(2.*beta) ) & - + ( ( 23./360.*e4 + 251./ 3780.*e6 )*sin(4.*beta) ) & - + ( ( 761./45360.*e6 )*sin(6.*beta) ) - - lat = phi*180./PI ! convert from radians to degree - lon = lam*180./PI + map_reference_longitude ! convert from radians to degree - - if (lon .lt. -180.0) lon = lon + 360.0 - if (lon .gt. 180.0) lon = lon - 360.0 - - end subroutine easeV2_inverse - - ! ******************************************************************* - - subroutine easeV2_get_params( grid, map_scale_m, cols, rows, r0, s0 ) - - implicit none - - character*(*), intent(in) :: grid - real*8, intent(out) :: map_scale_m, r0, s0 - integer, intent(out) :: cols, rows - - - if (grid(1:1).eq.'M') then - - if (grid .eq. 'M36') then ! SMAP 36 km grid - - map_scale_m = 36032.220840584 ! nominal cell size in meters - cols = 964 - rows = 406 - r0 = (cols-1)/2.0 - s0 = (rows-1)/2.0 - - - else if (grid .eq. 'M25') then ! 25 km grid - - map_scale_m = 25025.2600000 ! nominal cell size in meters (see doi:10.3390/ijgi3031154) - cols = 1388 - rows = 584 - r0 = (cols-1)/2.0 - s0 = (rows-1)/2.0 - - else if (grid .eq. 'M09') then ! SMAP 9 km grid - - map_scale_m = 9008.055210146 ! nominal cell size in meters - cols = 3856 - rows = 1624 - r0 = (cols-1)/2.0 - s0 = (rows-1)/2.0 - - else if (grid .eq. 'M03') then ! SMAP 3 km grid - - map_scale_m = 3002.6850700487 ! nominal cell size in meters - cols = 11568 - rows = 4872 - r0 = (cols-1)/2.0 - s0 = (rows-1)/2.0 - - else if (grid .eq. 'M01') then ! SMAP 1 km grid - - map_scale_m = 1000.89502334956 ! nominal cell size in meters - cols = 34704 - rows = 14616 - r0 = (cols-1)/2.0 - s0 = (rows-1)/2.0 - - else - - print *,'easeV2_get_params(): unknown resolution: ',grid - stop - - endif - - else if ((grid(1:1).eq.'N').or.(grid(1:1).eq.'S')) then - - print *,'easeV2_get_params(): Polar projections not implemented yet' - stop - - else - - print *, 'easeV2_get_params(): unknown projection: ', grid - stop - - endif - - end subroutine easeV2_get_params - - ! ******************************************************************* - -end module EASE_conv - -! =============================== EOF ================================= - diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/ExtractBCsFromOrig.py b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/ExtractBCsFromOrig.py new file mode 100755 index 000000000..3ce4c3c92 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/ExtractBCsFromOrig.py @@ -0,0 +1,163 @@ +#!/usr/bin/env python3 + +from netCDF4 import Dataset +from scipy.io import FortranFile +import numpy as np +import sys +import os +import glob + +def get_i_j_pf(til_file): + """ + This is just for cubed-sphere text tile. + """ + ii = [] + jj = [] + pfaf = [] + with open(til_file, 'r') as f: + for line in f: + data = line.split() + if data[0] == '100' : + ii.append(int(data[4])) + jj.append(int(data[5])) + pfaf.append(int(data[8])) + return ii, jj, pfaf + +def create_reduced_nc4(input_file, output_file, indices): + """ + Create a new nc4 file with with indices of for the input file. + + Parameters: + input_file (str): Path to the input nc4 file + output_file (str): Path to the output nc4 file + indices(int array): + """ + + # Open the input file in read mode + try: + src = Dataset(input_file, 'r') + print(f"Successfully opened input file: {input_file}") + except Exception as e: + print(f"Error opening input file: {e}") + return + + # Create the output file in write mode + try: + dst = Dataset(output_file, 'w', format='NETCDF4') + print(f"Creating output file: {output_file}") + except Exception as e: + print(f"Error creating output file: {e}") + src.close() + return + + # Copy global attributes + dst.setncatts(src.__dict__) + + # Copy dimensions with reduced size for unlimited/time dimensions + for name, dimension in src.dimensions.items(): + if name == 'tile': + dst.createDimension(name, len(indices)) + else: + dst.createDimension(name, len(dimension)) + # Copy variables with reduced data + for name, variable in src.variables.items(): + # Create variable with same attributes but possibly reduced dimensions + dims = variable.dimensions + new_dims = [] + for dim in dims: + new_dims.append(dim) + # Create the variable in the output file + dst_var = dst.createVariable( + name, + variable.datatype, + new_dims, + ) + + # Copy variable attributes + dst[name].setncatts(variable.__dict__) + + # Get the data and reduce it + if len(dims) == 2 : + dst_var[:,:] = variable[:,indices] + if len(dims) == 1 : + dst_var[:] = variable[indices] + + + # Close both files + src.close() + dst.close() + print(f"Successfully created reduced file: {output_file}") + +def create_reduced_bin(input_file, output_file, indices): + """ + Create a new ibinary file with with indices of for the input file. + + Parameters: + input_file (str): Path to the input binary file + output_file (str): Path to the output binaryfile + indices(int array): + """ + nland = len(indices) + fout = FortranFile(output_file, 'w') + with FortranFile(input_file, 'r') as f: + while True : + try: + a = f.read_reals(dtype=np.float32) + b = f.read_reals(dtype=np.float32) + a[12] = np.float32(nland) + fout.write_record(a) + b = b[indices] + fout.write_record(b) + except : + break + fout.close() + print(f"Successfully created reduced file: {output_file}") + +# Example usage +if __name__ == "__main__": + # Replace these with your actual file paths + # input_nc4 = "/discover/nobackup/projects/gmao/bcs_shared/fvInput/ExtData/esm/tiles/v13/land/CF1440x6C/clsm/catchcn_params.nc4" + # output_nc4 = "output_file_reduced.nc" + bcs_dir = sys.argv[1] + bcs_ver = sys.argv[2] + air_res = sys.argv[3] + ocn_res = sys.argv[4] + agname = air_res + '_' + air_res + orig_tile = bcs_dir + '/' + bcs_ver + '/geometry/' + agname + '/' + agname +'-Pfafstetter.til' + if not os.path.exists(orig_tile) : + print( "The original tile file must exist " + orig_tile) + exit() + + mom_tile = 'til/' + air_res + '_' + ocn_res + '-Pfafstetter.til' + if not os.path.exists(mom_tile) : + print( "The MOM tile file must exist " + mom_tile) + exit() + + ii1, jj1, pf1 = get_i_j_pf(orig_tile) + ii2, jj2, pf2 = get_i_j_pf(mom_tile) + i1 = 0 + indices =[] + for i2 in range(len(ii2)): + match = ii1[i1] == ii2[i2] and jj1[i1] == jj2[i2] and pf1[i1] == pf2[i2] + while not match : + i1 = i1 +1 + match = ii1[i1] == ii2[i2] and jj1[i1] == jj2[i2] and pf1[i1] == pf2[i2] + indices.append(i1) + i1 = i1 + 1 + + catch_params_file = bcs_dir + '/' + bcs_ver + '/land/' + air_res + '/clsm/catch_params.nc4' + catchcn_params_file = bcs_dir + '/' + bcs_ver + '/land/' + air_res + '/clsm/catchcn_params.nc4' + mom_catch_params_file = 'clsm/catch_params.nc4' + mom_catchcn_params_file = 'clsm/catchcn_params.nc4' + + create_reduced_nc4(catch_params_file, mom_catch_params_file, indices) + create_reduced_nc4(catchcn_params_file, mom_catchcn_params_file, indices) + + files = glob.glob(bcs_dir + '/' + bcs_ver + '/land/' + air_res + '/*.da*') + for file in files: + fname = os.path.basename(file) + if 'vegdyn' in fname: + create_reduced_nc4( file,'clsm/vegdyn.data', indices) + else: + shortname = 'clsm/' + fname.split('_')[0] + '.dat' + create_reduced_bin(file, shortname, indices) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/FillMomGrid.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/FillMomGrid.F90 index 36dbc1921..3f282fdbd 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/FillMomGrid.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/FillMomGrid.F90 @@ -4,10 +4,11 @@ program FillMomGrid - use LogRectRasterizeMod + use LogRectRasterizeMod, ONLY: WriteRaster, WriteTiling use MAPL_SortMod use MAPL_HashMod use MAPL_ConstantsMod + use, intrinsic :: iso_fortran_env, only: REAL64 ! Modifies Pfafstetter.rst such that for every pixel within a MOM ocean diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/TileFile_ASCII_to_nc4.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/TileFile_ASCII_to_nc4.F90 new file mode 100644 index 000000000..2e04f5afd --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/TileFile_ASCII_to_nc4.F90 @@ -0,0 +1,304 @@ +! +! Utility program that converts ASCII-formatted *.til file and catchment.def file into a single nc4 file +! +! Usage TileFile_ASCII-to-nc4.x tile_file catchmentdef_file +! +! wjiang, rreichle, 29 Nov 2024 + +program TileFile_ASCII_to_nc4 + use, intrinsic :: iso_fortran_env, only: REAL64 + use MAPL, only: MAPL_WriteTilingNC4, MAPL_ease_extent + use LogRectRasterizeMod, only: MAPL_UNDEF_R8 + + implicit none + + character(512) :: arg + integer :: i, unit, unit2 + + character(:), allocatable :: tile_file + character(:), allocatable :: catchmentdef_file + real(REAL64), allocatable :: rTable(:,:) + integer, allocatable :: iTable(:,:) + character(128) :: gName1, gName2 + character(len=512) :: tmpline + + character(:), allocatable :: array(:) + character(len=:), allocatable :: filenameNC4 + + real :: cell_area + + integer :: n_tile, n_grid, n_lon1, n_lat1, n_cat, tmp_in1, tmp_in2 + integer :: n_lon2, n_lat2, nx, ny, num, ll, maxcat + logical :: file_exists + + ! ---------------------------------------------------------------------- + ! + ! process command-line arguments + + CALL get_command_argument(1, arg) + tile_file = trim(arg) + CALL get_command_argument(2, arg) + catchmentdef_file = trim(arg) + + ! ---------------------------------------------------------------------- + ! + ! open and read *.til ASCII file + + open (newunit=unit, file=trim(tile_file), form='formatted', action='read') + + read (unit,"(A)") tmpline ! header line 1: N_tile [maxcat] nx ny (see below) + read (unit,*) N_grid ! header line 2: N_grid [=1 for EASE, =2 otherwise] + read (unit,*) gName1 ! header line 3: name of atm grid + read (unit,*) n_lon1 ! header line 4: N_lon of atm grid + read (unit,*) n_lat1 ! header line 5: N_lat of atm grid + + ! special treatment needed for header line 1 because maxcat is not included in legacy bcs + + call split(tmpline, array, " ") + read(array(1), *) n_tile + num = size(array) + ll = 0 + if (num == 4) then + ll = 1 + read(array(2), *) maxcat ! number of Pfafstetter catchments + else + maxcat = -1 ! maxcat not available in legacy bcs + endif + + read(array(2+ll), *) nx ! N_lon of raster grid + read(array(3+ll), *) ny ! N_lat of raster grid + + if (N_grid == 1) then + + ! EASE grid tile space + + ! in some legacy bcs, dummy ocean grid info is included in header (despite N_grid=1); + ! read next line and decide if it is dummy header or info for first tile + + read (unit,"(A)") tmpline + if (index(tmpline,'OCEAN')/=0) then + read (unit,*) + read (unit,*) + read (unit,"(A)") tmpline + endif + + else + + ! lat/lon or cube-sphere tile space + + read (unit,*) gName2 + read (unit,*) n_lon2 + read (unit,*) n_lat2 + read (unit,"(A)") tmpline ! read info for first tile (to accommodate legacy EASE grid issues above) + + endif + + allocate(iTable(N_tile,0:7)) + allocate(rTable(N_tile,10)) + + rTable = MAPL_UNDEF_r8 + + ! read ASCII tile file (NOTE: Info for first tile is already in tmpline!) + + if ( index(gName1, 'EASE') /=0 ) then ! EASE grid tile space + + read (tmpline,*) iTable(1,0), iTable(1,4), rTable(1,1), rTable(1,2), & + iTable(1,2), iTable(1,3), rTable(1,4) + + do i = 2, N_tile + read (unit,*) iTable(i,0), iTable(i,4), rTable(i,1), rTable(i,2), & + iTable(i,2), iTable(i,3), rTable(i,4) + enddo + + ! rTable(:,4) is tile area fraction within grid cell (fr), convert to area; + ! get fr back in WriteTilingNC4 + + call MAPL_ease_extent(gName1, tmp_in1, tmp_in2, cell_area=cell_area) ! get EASE grid cell area + + rTable(:,3) = rTable(:,4)*cell_area + rTable(:,4) = cell_area + + else ! lat/lon or cube-sphere tile space + + read (tmpline,*) iTable(1,0), rTable(1,3), rTable(1,1), rTable(1,2), & + iTable(1,2), iTable(1,3), rTable(1,4), iTable(1,6), & + iTable(1,4), iTable(1,5), rTable(1,5), iTable(1,7) + + do i = 2, N_tile + read (unit,*) iTable(i,0), rTable(i,3), rTable(i,1), rTable(i,2), & + iTable(i,2), iTable(i,3), rTable(i,4), iTable(i,6), & + iTable(i,4), iTable(i,5), rTable(i,5), iTable(i,7) + enddo + + ! re-define rTable(:,4) and rTable(:,5). + ! fr will be re-created in WriteTilingNC4 + + where (rTable(:,4) /=0.0) + rTable(:,4) = rTable(:,3)/rTable(:,4) + endwhere + + where (rTable(:,5) /=0.0) + rTable(:,5) = rTable(:,3)/rTable(:,5) + endwhere + + endif + + close(unit) + + ! ---------------------------------------------------------------------- + ! + ! open and read catchment.def ASCII file + + inquire( file= trim(catchmentdef_file), exist=file_exists) + + if (file_exists) then + + open (newunit=unit, file=trim(catchmentdef_file), form='formatted', action='read') + + read(unit, *) n_cat ! number of *land* tiles + + do i = 1, n_cat + read(unit, *) & + tmp_in1, & + tmp_in2, & + rTable(i, 6), & + rTable(i, 7), & + rTable(i, 8), & + rTable(i, 9), & + rTable(i,10) + enddo + + close(unit) + + endif + + ! assemble name of nc4 file + + ll = index(tile_file, '.til') + filenameNC4 = tile_file(1:ll)//'nc4' + + ! write nc4 file + + if (N_grid == 1) then + call MAPL_WriteTilingNC4(filenameNc4, [gName1 ], [n_lon1 ], [n_lat1 ], nx, ny, iTable, rTable, N_PfafCat=maxcat) + else + call MAPL_WriteTilingNC4(filenameNc4, [gName1, gName2], [n_lon1, n_lon2], [n_lat1, n_lat2], nx, ny, iTable, rTable, N_PfafCat=maxcat) + endif + +contains + + subroutine split(input_line,array,delimiters,order,nulls) + + character(len=*),intent(in) :: input_line + character(len=*),optional,intent(in) :: delimiters + character(len=*),optional,intent(in) :: order + character(len=*),optional,intent(in) :: nulls + character(len=:),allocatable,intent(out) :: array(:) + + integer :: n + integer,allocatable :: ibegin(:) + integer,allocatable :: iterm(:) + character(len=:),allocatable :: dlim + character(len=:),allocatable :: ordr + character(len=:),allocatable :: nlls + integer :: ii,iiii + integer :: icount + integer :: ilen + integer :: i10,i20,i30 + integer :: icol + integer :: idlim + integer :: ifound + integer :: inotnull + integer :: ireturn + integer :: imax + + ! decide on value for optional DELIMITERS parameter + if (present(delimiters)) then ! optional delimiter list was present + if(delimiters/='')then ! if DELIMITERS was specified and not null use it + dlim=delimiters + else ! DELIMITERS was specified on call as empty string + dlim=' '//char(9)//char(10)//char(11)//char(12)//char(13)//char(0) ! use default delimiter when not specified + endif + else ! no delimiter value was specified + dlim=' '//char(9)//char(10)//char(11)//char(12)//char(13)//char(0) ! use default delimiter when not specified + endif + idlim=len(dlim) ! dlim a lot of blanks on some machines if dlim is a big string + + if(present(order))then; ordr=adjustl(order); else; ordr='sequential'; endif ! decide on value for optional ORDER parameter + + if(present(nulls))then; nlls=adjustl(nulls); else; nlls='ignore' ; endif ! optional parameter + + n=len(input_line)+1 ! max number of strings INPUT_LINE could split into if all delimiter + allocate(ibegin(n)) ! allocate enough space to hold starting location of tokens if string all tokens + allocate(iterm(n)) ! allocate enough space to hold ending location of tokens if string all tokens + ibegin(:)=1 + iterm(:)=1 + + ilen=len(input_line) ! ILEN is the column position of the last non-blank character + icount=0 ! how many tokens found + inotnull=0 ! how many tokens found not composed of delimiters + imax=0 ! length of longest token found + + select case (ilen) + + case (0) ! command was totally blank + + case default ! there is at least one non-delimiter in INPUT_LINE if get here + icol=1 ! initialize pointer into input line + INFINITE: do i30=1,ilen,1 ! store into each array element + ibegin(i30)=icol ! assume start new token on the character + if(index(dlim(1:idlim),input_line(icol:icol))==0)then ! if current character is not a delimiter + iterm(i30)=ilen ! initially assume no more tokens + do i10=1,idlim ! search for next delimiter + ifound=index(input_line(ibegin(i30):ilen),dlim(i10:i10)) + IF(ifound>0)then + iterm(i30)=min(iterm(i30),ifound+ibegin(i30)-2) + endif + enddo + icol=iterm(i30)+2 ! next place to look as found end of this token + inotnull=inotnull+1 ! increment count of number of tokens not composed of delimiters + else ! character is a delimiter for a null string + iterm(i30)=icol-1 ! record assumed end of string. Will be less than beginning + icol=icol+1 ! advance pointer into input string + endif + imax=max(imax,iterm(i30)-ibegin(i30)+1) + icount=i30 ! increment count of number of tokens found + if(icol>ilen)then ! no text left + exit INFINITE + endif + enddo INFINITE + + end select + + select case (trim(adjustl(nlls))) + case ('ignore','','ignoreend') + ireturn=inotnull + case default + ireturn=icount + end select + allocate(character(len=imax) :: array(ireturn)) ! allocate the array to return + !allocate(array(ireturn)) ! allocate the array to turn + + select case (trim(adjustl(ordr))) ! decide which order to store tokens + case ('reverse','right') ; ii=ireturn ; iiii=-1 ! last to first + case default ; ii=1 ; iiii=1 ! first to last + end select + + do i20=1,icount ! fill the array with the tokens that were found + if(iterm(i20) clsm/soil read ([UNIT],'(i10,i8,i4,i4,3f8.4,f12.8,f7.4,f10.4,3f7.3,4f7.3,2f10.4, f8.4)') & - tile_index, pfaf_code, soil_class_top, soil_class_com, BEE, & + tile_index, pfaf_index, soil_class_top, soil_class_com, BEE, & PSIS, POROS, COND, WPWET, DP2BR, gravel, OrgCarbon_top, & OrgCarbon_rz, sand_top, clay_top, sand_rz, clay_rz, WPWET_top, POROS_top, PMAP end do where for each tile: (1) tile_index [-] number - (2) pfaf_code [-] ${pfaf_des} + (2) pfaf_index [-] ${pfaf_des} (3) soil_class_top [-] soil class for the surface layer (0-30cm) (4) soil_class_com [-] soil class for the root-zone (0-100cm) (5) BEE [-] b-parameter of the tension curve @@ -946,14 +953,14 @@ _EOS1_ else cat << _EOS2_ > clsm/soil read ([UNIT],'(i10,i8,i4,i4,3f8.4,f12.8,f7.4,f10.3)') & - tile_index, pfaf_code, soil_class_top, & + tile_index, pfaf_index, soil_class_top, & soil_class_com,BEE, PSIS, POROS, COND, & WPWET, soildepth end do where for each tile: (1) tile_index [-] number - (2) pfaf_code [-] ${pfaf_des} + (2) pfaf_index [-] ${pfaf_des} (3) soil_class_top [-] soil class for the surface layer (0-30cm) (4) soil_class_com [-] soil class for the root-zone (0-100cm) (5) BEE [-] b-parameter of the tension curve @@ -1016,14 +1023,14 @@ cat << _EOV1_ > clsm/veg1 3.2.1 Mosaic vegetation types and fractions file name: mosaic_veg_typs_fracs do n = 1, ${NTILES} - read ([UNIT],(i10,i8,2(2x,i3),2(2x,f6.2),2x,f6.3,2x,f10.7)) tile_index, pfaf_code, & + read ([UNIT],(i10,i8,2(2x,i3),2(2x,f6.2),2x,f6.3,2x,f10.7)) tile_index, pfaf_index, & primary_veg_type, secondary_veg_type, primary_veg_frac, & secondary_veg_frac, canopy_height, ASCATZ0 end do where for each tile: (1) tile_index [-] number - (2) pfaf_code [-] ${pfaf_des} + (2) pfaf_index [-] ${pfaf_des} (3) primary_veg_type [-] primary vegetation type [Figure 5 : "plots/mosaic_prim.jpg"] (4) secondary_veg_type [-] secondary vegetation type @@ -1052,7 +1059,7 @@ cat << _EOV2_ > clsm/veg2 file names: CLM_veg_typs_fracs do n = 1, ${NTILES} read ([UNIT],'(2I10,4I3,4f7.2,2I3,2f7.2)') & - tile_index, pfaf_code, & + tile_index, pfaf_index, & CLM-C_pt1, CLM-C_pt2, CLM-C_st1, CLM-C_st2, & CLM-C_pf1, CLM-C_pf2, CLM-C_sf1, CLM-C_sf2, & CLM_pt, CLM_st, CLM_pf, CLM_sf @@ -1060,7 +1067,7 @@ cat << _EOV2_ > clsm/veg2 where for each tile: (1) tile_index [-] number - (2) pfaf_code [-] ${pfaf_des} + (2) pfaf_index [-] ${pfaf_des} (3) CLM-C_pt1 [-] Catchment-CN primary type 1 [Figure 7a : top panel of "plots/CLM-Carbon_PRIM_veg_typs.jpg"] (4) CLM-C_pt2 [-] Catchment-CN primary type 2 (moisture stressed only) @@ -1362,7 +1369,7 @@ cat << _EOF0_ > clsm/README1 file name : tau_param.dat do n = 1, ${NTILES} read ([UNIT],'(i10,i8,4f10.7)') & - tile_index, pfaf_code, atau2, btau2, atau5, btau5 + tile_index, pfaf_index, atau2, btau2, atau5, btau5 end do where: (1) atau2 atau2: Equation (17) for a 2cm surface layer [-] @@ -1374,7 +1381,7 @@ cat << _EOF0_ > clsm/README1 root zone and water table file name : ts.dat do n = 1, ${NTILES} - read ([UNIT],'(i10,i8,f5.2,4(2x,e13.7))') tile_index, pfaf_code,gnu, & + read ([UNIT],'(i10,i8,f5.2,4(2x,e13.7))') tile_index, pfaf_index, gnu, & tsa1, tsa2, tsb1, tsb2 end do @@ -1387,7 +1394,7 @@ cat << _EOF0_ > clsm/README1 6.2.3 Baseflow parameters file name : bf.dat do n = 1, ${NTILES} - read ([UNIT],'(i10,i8,f5.2,3(2x,e13.7))') tile_index, pfaf_code, gnu, bf1, bf2, bf3 + read ([UNIT],'(i10,i8,f5.2,3(2x,e13.7))') tile_index, pfaf_index, gnu, bf1, bf2, bf3 end do where: @@ -1399,7 +1406,7 @@ cat << _EOF0_ > clsm/README1 6.2.4 Area fractioning parameters file name : ar.new do n = 1, ${NTILES} - read ([UNIT],'(i10,i8,f5.2,11(2x,e14.7))') tile_index, pfaf_code, gnu, & + read ([UNIT],'(i10,i8,f5.2,11(2x,e14.7))') tile_index, pfaf_index, gnu, & ars1, ars2, ars3, ara1, ara2, ara3, ara4, arw1, arw2, arw3, arw4 end do @@ -1492,7 +1499,7 @@ cat << _EOF1_ > clsm/README2 water pixel is assumed to be the location of the downstream confluence. 7.2 Data files - 7.2.1 Pafafstetter catchment connectivity, channel information + 7.2.1 Pfafstetter catchment connectivity, channel information file path : /discover/nobackup/projects/gmao/bcs_shared/make_bcs_inputs/ [NCCS/Discover] file name : land/topo/v1/SRTM-TopoData/Pfafcatch-routing.dat read ([UNIT],*) NPfafs @@ -1503,8 +1510,8 @@ cat << _EOF1_ > clsm/README2 UP_lon, UP_lat, mouth_lon, mouth_lat end do - pfaf_index [-] catchment index (1-$NPfafs) after sorting Pfafstetter codes in ascending order - pfaf_code [-] Pfafstetter code of the hydrologic catchment + pfaf_index [-] Pfafstetter (hydrological) catchment index (1-$NPfafs) after sorting Pfafstetter codes in ascending order + pfaf_code [-] Pfafstetter (routing) code of the hydrologic catchment min_lon [degree] Western edge of the catchment max_lon [degree] Eastern edge of the catchment min_lat [degree] Southern edge of the catchment diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/make_bcs_cube.py b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/make_bcs_cube.py index 50287a2a3..e603f411c 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/make_bcs_cube.py +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/make_bcs_cube.py @@ -8,81 +8,60 @@ cube_template = """ -if ( {STEP1} == True ) then - ln -s {MAKE_BCS_INPUT_DIR}/ocean/MOM5/360x200 data/MOM5/360x200 - ln -s {MAKE_BCS_INPUT_DIR}/ocean/MOM5/720x410 data/MOM5/720x410 - ln -s {MAKE_BCS_INPUT_DIR}/ocean/MOM5/1440x1080 data/MOM5/1440x1080 - ln -s {MAKE_BCS_INPUT_DIR}/ocean/MOM6/72x36 data/MOM6/72x36 - ln -s {MAKE_BCS_INPUT_DIR}/ocean/MOM6/540x458 data/MOM6/540x458 - ln -s {MAKE_BCS_INPUT_DIR}/ocean/MOM6/1440x1080 data/MOM6/1440x1080 +ln -s {MAKE_BCS_INPUT_DIR}/ocean/MOM5/360x200 data/MOM5/360x200 +ln -s {MAKE_BCS_INPUT_DIR}/ocean/MOM5/720x410 data/MOM5/720x410 +ln -s {MAKE_BCS_INPUT_DIR}/ocean/MOM5/1440x1080 data/MOM5/1440x1080 +ln -s {MAKE_BCS_INPUT_DIR}/ocean/MOM6/72x36 data/MOM6/72x36 +ln -s {MAKE_BCS_INPUT_DIR}/ocean/MOM6/540x458 data/MOM6/540x458 +ln -s {MAKE_BCS_INPUT_DIR}/ocean/MOM6/1440x1080 data/MOM6/1440x1080 - if( -e CF{NC}x6C{SGNAME}_{DATENAME}{IMO}x{POLENAME}{JMO}.stdout ) /bin/rm -f CF{NC}x6C{SGNAME}_{DATENAME}{IMO}x{POLENAME}{JMO}.stdout +if( -e CF{NC}x6C{SGNAME}_{DATENAME}{IMO}x{POLENAME}{JMO}.stdout ) /bin/rm -f CF{NC}x6C{SGNAME}_{DATENAME}{IMO}x{POLENAME}{JMO}.stdout -endif - -if ( {STEP1} == True ) then - bin/mkCubeFVRaster.x -x {NX} -y {NY} {SGPARAM} {STRETCH} {NC} >/dev/null - bin/mkLandRaster.x -x {NX} -y {NY} -v -t {NT} -endif +bin/mkCubeFVRaster.x -x {NX} -y {NY} {SGPARAM} {STRETCH} {NC} >/dev/null +bin/mkLandRaster.x -x {NX} -y {NY} -v -t {NT} if( {LATLON_OCEAN} == True ) then - - if ( {STEP1} == True ) then - bin/mkLatLonRaster.x -x {NX} -y {NY} -b DE -p PE -t 0 {IMO} {JMO} >/dev/null - bin/CombineRasters.x -f 0 -t {NT} DE{IMO}xPE{JMO} Pfafstetter >/dev/null - bin/CombineRasters.x -t {NT} CF{NC}x6C{SGNAME} DE{IMO}xPE{JMO}-Pfafstetter - setenv OMP_NUM_THREADS 1 - if ( {SKIPLAND} != True ) bin/mkCatchParam.x -x {NX} -y {NY} -g CF{NC}x6C{SGNAME}_DE{IMO}xPE{JMO}-Pfafstetter -v {lbcsv} - endif - - if ( {STEP2} == True ) then - setenv OMP_NUM_THREADS {NCPUS} - if ( {SKIPLAND} != True ) bin/mkCatchParam.x -x {NX} -y {NY} -g CF{NC}x6C{SGNAME}_DE{IMO}xPE{JMO}-Pfafstetter -v {lbcsv} - chmod 755 bin/create_README.csh - bin/create_README.csh - endif + bin/mkLatLonRaster.x -x {NX} -y {NY} -b DE -p PE -t 0 {IMO} {JMO} >/dev/null + bin/CombineRasters.x -f 0 -t {NT} DE{IMO}xPE{JMO} Pfafstetter >/dev/null + bin/CombineRasters.x -t {NT} CF{NC}x6C{SGNAME} DE{IMO}xPE{JMO}-Pfafstetter + setenv OMP_NUM_THREADS {NCPUS} + if ( {SKIPLAND} != True ) bin/mkCatchParam.x -x {NX} -y {NY} -g CF{NC}x6C{SGNAME}_DE{IMO}xPE{JMO}-Pfafstetter -v {lbcsv} + setenv OMP_NUM_THREADS 1 + chmod 755 bin/create_README.csh + bin/create_README.csh endif if( {TRIPOL_OCEAN} == True ) then - if ( {STEP1} == True ) then - bin/mkMOMAquaRaster.x -x {NX} -y {NY} -w {OCEAN_VERSION} data/{MOM_VERSION}/{imo}x{jmo}/MAPL_Tripolar.nc > /dev/null - /bin/cp til/Pfafstetter.til til/Pfafstetter-ORIG.til - /bin/cp rst/Pfafstetter.rst rst/Pfafstetter-ORIG.rst - bin/FillMomGrid.x -f 0 -g Pfafstetter-M {OCEAN_VERSION}{DATENAME}{IMO}x{POLENAME}{JMO} Pfafstetter data/{MOM_VERSION}/{imo}x{jmo}/MAPL_Tripolar.nc - /bin/mv til/Pfafstetter-M.til til/Pfafstetter.til - /bin/mv rst/Pfafstetter-M.rst rst/Pfafstetter.rst - bin/CombineRasters.x -f 0 -t {NT} {OCEAN_VERSION}{DATENAME}{IMO}x{POLENAME}{JMO} Pfafstetter >/dev/null - bin/CombineRasters.x -t {NT} CF{NC}x6C{SGNAME} {OCEAN_VERSION}{DATENAME}{IMO}x{POLENAME}{JMO}-Pfafstetter - bin/mk_runofftbl.x -g CF{NC}x6C{SGNAME}_{OCEAN_VERSION}{DATENAME}{IMO}x{POLENAME}{JMO}-Pfafstetter -v {lbcsv} - setenv OMP_NUM_THREADS 1 - if ({SKIPLAND} != True) bin/mkCatchParam.x -x {NX} -y {NY} -g CF{NC}x6C{SGNAME}_{OCEAN_VERSION}{DATENAME}{IMO}x{POLENAME}{JMO}-Pfafstetter -v {lbcsv} - endif - - if ( {STEP2} == True ) then - setenv OMP_NUM_THREADS {NCPUS} - if ({SKIPLAND} != True) bin/mkCatchParam.x -x {NX} -y {NY} -g CF{NC}x6C{SGNAME}_{OCEAN_VERSION}{DATENAME}{IMO}x{POLENAME}{JMO}-Pfafstetter -v {lbcsv} - chmod 755 bin/create_README.csh - bin/create_README.csh - endif + bin/mkMOMAquaRaster.x -x {NX} -y {NY} -w {OCEAN_VERSION} data/{MOM_VERSION}/{imo}x{jmo}/MAPL_Tripolar.nc > /dev/null + /bin/cp til/Pfafstetter.til til/Pfafstetter-ORIG.til + /bin/cp rst/Pfafstetter.rst rst/Pfafstetter-ORIG.rst + bin/FillMomGrid.x -f 0 -g Pfafstetter-M {OCEAN_VERSION}{DATENAME}{IMO}x{POLENAME}{JMO} Pfafstetter data/{MOM_VERSION}/{imo}x{jmo}/MAPL_Tripolar.nc + /bin/mv til/Pfafstetter-M.til til/Pfafstetter.til + /bin/mv rst/Pfafstetter-M.rst rst/Pfafstetter.rst + bin/CombineRasters.x -f 0 -t {NT} {OCEAN_VERSION}{DATENAME}{IMO}x{POLENAME}{JMO} Pfafstetter >/dev/null + bin/CombineRasters.x -t {NT} CF{NC}x6C{SGNAME} {OCEAN_VERSION}{DATENAME}{IMO}x{POLENAME}{JMO}-Pfafstetter + bin/mk_runofftbl.x -g CF{NC}x6C{SGNAME}_{OCEAN_VERSION}{DATENAME}{IMO}x{POLENAME}{JMO}-Pfafstetter -v {lbcsv} + + if ({SKIPLAND} != True) then + bin/mkCatchParam.x -x {NX} -y {NY} -g CF{NC}x6C{SGNAME}_{OCEAN_VERSION}{DATENAME}{IMO}x{POLENAME}{JMO}-Pfafstetter -v {lbcsv} -p no + bin/ExtractBCsFromOrig.py {BCS_DIR} {lbcsv} CF{NC}x6C{SGNAME} {OCEAN_VERSION}{DATENAME}{IMO}x{POLENAME}{JMO} + endif + + chmod 755 bin/create_README.csh + bin/create_README.csh endif if( {CUBED_SPHERE_OCEAN} == True ) then - if ( {STEP1} == True ) then - if ( {IS_STRETCHED} == True ) then - bin/mkCubeFVRaster.x -x {NX} -y {NY} {STRETCH} {NC} >/dev/null - endif - bin/CombineRasters.x -f 0 -t {NT} CF{NC}x6C Pfafstetter >/dev/null - bin/CombineRasters.x -t {NT} {SGPARAM} CF{NC}x6C CF{NC}x6C-Pfafstetter - setenv OMP_NUM_THREADS 1 - if ({SKIPLAND} != True) bin/mkCatchParam.x -x {NX} -y {NY} -g CF{NC}x6C{SGNAME}_CF{NC}x6C-Pfafstetter -v {lbcsv} - endif - - if ( {STEP2} == True ) then - setenv OMP_NUM_THREADS {NCPUS} - if ({SKIPLAND} != True) bin/mkCatchParam.x -x {NX} -y {NY} -g CF{NC}x6C{SGNAME}_CF{NC}x6C-Pfafstetter -v {lbcsv} - chmod 755 bin/create_README.csh - bin/create_README.csh - endif + if ( {IS_STRETCHED} == True ) then + bin/mkCubeFVRaster.x -x {NX} -y {NY} {STRETCH} {NC} >/dev/null + endif + bin/CombineRasters.x -f 0 -t {NT} CF{NC}x6C Pfafstetter >/dev/null + bin/CombineRasters.x -t {NT} {SGPARAM} CF{NC}x6C CF{NC}x6C-Pfafstetter + setenv OMP_NUM_THREADS {NCPUS} + if ({SKIPLAND} != True) bin/mkCatchParam.x -x {NX} -y {NY} -g CF{NC}x6C{SGNAME}_CF{NC}x6C-Pfafstetter -v {lbcsv} + setenv OMP_NUM_THREADS 1 + chmod 755 bin/create_README.csh + bin/create_README.csh endif """ @@ -158,26 +137,17 @@ def make_bcs_cube(config): if not os.path.exists(log_dir): os.makedirs(log_dir) - STEP1 = True - STEP2 = True - GRIDNAME2 = GRIDNAME script_template = get_script_head() + cube_template + get_script_mv(config['grid_type']) - if resolution in ['c1080' ,'c1536', 'c2160', 'c2880', 'c3072','c5760'] : - STEP1 = True - STEP2 = False - script_template = get_script_head() + cube_template script_string = script_template.format(\ account = account, \ EXPDIR = config['expdir'], \ TMP_DIR = tmp_dir, \ GRIDNAME = GRIDNAME, \ - GRIDNAME2 = GRIDNAME2, \ - STEP1 = STEP1, \ - STEP2 = STEP2, \ SCRATCH_DIR = scratch_dir, \ bin_dir = bin_dir, \ MAKE_BCS_INPUT_DIR = config['inputdir'], \ + BCS_DIR = config['bcs_dir'], \ DATENAME = DATENAME, \ POLENAME = POLENAME, \ OCEAN_VERSION = OCEAN_VERSION, \ @@ -212,56 +182,6 @@ def make_bcs_cube(config): cube_job.write(script_string) cube_job.close() - if resolution in ['c1080' ,'c1536', 'c2160', 'c2880', 'c3072','c5760'] : - STEP1 = False - STEP2 = True - GRIDNAME2 = GRIDNAME+'-2' - script_template = get_script_head() + cube_template + get_script_mv(config['grid_type']) - script_string = script_template.format(\ - account = account, \ - EXPDIR = config['expdir'], \ - TMP_DIR = tmp_dir, \ - GRIDNAME = GRIDNAME, \ - GRIDNAME2 = GRIDNAME2, \ - STEP1 = STEP1, \ - STEP2 = STEP2, \ - SCRATCH_DIR = scratch_dir, \ - bin_dir = bin_dir, \ - MAKE_BCS_INPUT_DIR = config['inputdir'], \ - DATENAME = DATENAME, \ - POLENAME = POLENAME, \ - OCEAN_VERSION = OCEAN_VERSION, \ - SKIPLAND = SKIPLAND, \ - MOM_VERSION = config['MOM_VERSION'], \ - LATLON_OCEAN= config['LATLON_OCEAN'], \ - TRIPOL_OCEAN= config['TRIPOL_OCEAN'], \ - CUBED_SPHERE_OCEAN = config['CUBED_SPHERE_OCEAN'], \ - nc = nc, \ - nc6 = nc6, \ - imo = config['imo'], \ - jmo = config['jmo'], \ - IRRIGTHRES = 2, \ - IMO = IMO, \ - JMO = JMO, \ - NC = NC, \ - MASKFILE = config['MASKFILE'], \ - lbcsv = config['lbcsv'], \ - NX = config['NX'], \ - NY = config['NY'], \ - NT = config['NT'], \ - RC = RC,\ - SG = SG,\ - STRETCH = STRETCH, \ - SGNAME = SGNAME, \ - SGPARAM = SGPARAM, \ - IS_STRETCHED = IS_STRETCHED, \ - RS = '-Pfafstetter',\ - NCPUS = config['NCPUS']) - - cube_job = open(bcjob+'-2','wt') - cube_job.write(script_string) - cube_job.close() - interactive = os.getenv('SLURM_JOB_ID', default = None) if ( interactive ) : if resolution in ['c1080' ,'c1536', 'c2160', 'c2880', 'c3072','c5760'] : @@ -280,10 +200,6 @@ def make_bcs_cube(config): out = subprocess.check_output(['sbatch', bcjob]) jobid = str(int(out.split()[3])) print( "Submitted batch job " + jobid) - if resolution in ['c1080' ,'c1536', 'c2160', 'c2880', 'c3072','c5760'] : - print("sbatch " + bcjob+'-2' + " depending on " + bcjob + "\n") - subprocess.call(['sbatch', '--dependency=afterok:'+jobid, bcjob+'-2']) - print() print( "cd " + bin_dir) os.chdir(bin_dir) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/make_bcs_ease.py b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/make_bcs_ease.py index 2f164e5f6..590b65b8b 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/make_bcs_ease.py +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/make_bcs_ease.py @@ -8,12 +8,10 @@ ease_template = """ -setenv OMP_NUM_THREADS 1 bin/mkEASETilesParam.x -ease_label {GRIDNAME} -setenv OMP_NUM_THREADS 1 -bin/mkCatchParam.x -g {GRIDNAME} -v {lbcsv} -x {NX} -y {NY} setenv OMP_NUM_THREADS {NCPUS} bin/mkCatchParam.x -g {GRIDNAME} -v {lbcsv} -x {NX} -y {NY} +setenv OMP_NUM_THREADS 1 chmod 755 bin/create_README.csh bin/create_README.csh diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/make_bcs_latlon.py b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/make_bcs_latlon.py index d552f7ae4..7050a1f9f 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/make_bcs_latlon.py +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/make_bcs_latlon.py @@ -42,10 +42,9 @@ bin/CombineRasters.x -f 0 -t {NT} {DATENAME}{IMO}x{POLENAME}{JMO} Pfafstetter >/dev/null bin/CombineRasters.x -t {NT} DC{IM}xPC{JM} {DATENAME}{IMO}x{POLENAME}{JMO}-Pfafstetter bin/mk_runofftbl.x -g DC{IM}xPC{JM}_{DATENAME}{IMO}x{POLENAME}{JMO}-Pfafstetter -v {lbcsv} - setenv OMP_NUM_THREADS 1 - if ( {SKIPLAND} != True ) bin/mkCatchParam.x -x {NX} -y {NY} -g DE{IMO}xPE{JMO}_DE{IMO}xPE{JMO}-Pfafstetter -v {lbcsv} setenv OMP_NUM_THREADS {NCPUS} if ( {SKIPLAND} != True ) bin/mkCatchParam.x -x {NX} -y {NY} -g DE{IMO}xPE{JMO}_DE{IMO}xPE{JMO}-Pfafstetter -v {lbcsv} + setenv OMP_NUM_THREADS 1 chmod 755 bin/create_README.csh bin/create_README.csh endif diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/make_bcs_questionary.py b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/make_bcs_questionary.py index d18c159d2..386d834c4 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/make_bcs_questionary.py +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/make_bcs_questionary.py @@ -43,6 +43,8 @@ def get_configs_from_answers(answers): else: make_bcs_input_dir = '/nobackup/gmao_SIteam/ModelData/make_bcs_inputs/' + bcs_dir ='/discover/nobackup/projects/gmao/bcs_shared/fvInput/ExtData/esm/tiles/' + user = get_user() expdir = answers["out_path"] now = datetime.now() @@ -73,7 +75,7 @@ def get_configs_from_answers(answers): if lbcsv in ['F25', 'GM4', 'ICA']: maskfile = 'global.cat_id.catch.GreatLakesCaspian_Updated.DL' if (maskfile == ''): - print(" \!\!\!\! Invalid Ocean Resolution, stopping ") + print(" !!! Invalid Ocean Resolution, stopping !!!") exit() if 'EASEv1' == grid_type or 'EASEv2' == grid_type: @@ -148,7 +150,8 @@ def get_configs_from_answers(answers): config ['expdir'] = expdir config ['outdir'] = outdir config ['inputdir'] = make_bcs_input_dir - config ['NCPUS'] = 20 + config ['bcs_dir'] = bcs_dir + config ['NCPUS'] = 16 for x in answers.get('Stretched_CS',[]): config ['SG'] = answers['SG'] @@ -195,6 +198,7 @@ def ask_questions(default_grid="Cubed-Sphere"): "v10 : NL3 + PEATMAP + MODIS snow alb v2", \ "v11 : NL3 + JPL veg height + PEATMAP + MODIS snow alb v2", \ "v12 : NL3 + JPL veg height + PEATMAP + MODIS snow alb v2 + Argentina peatland fix", \ + "v13 : NL3 + JPL veg height + PEATMAP + MODIS snow alb v2 + Argentina peatland fix + mean land elevation fix", \ "ICA : Icarus (archived*: /discover/nobackup/projects/gmao/bcs_shared/legacy_bcs/Icarus/)", \ "GM4 : Ganymed-4_0 (archived*: /discover/nobackup/projects/gmao/bcs_shared/legacy_bcs/Ganymed-4_0/)", \ "F25 : Fortuna-2_5 (archived*: n/a)"], diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/make_bcs_shared.py b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/make_bcs_shared.py index 95c047446..b5e651deb 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/make_bcs_shared.py +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/make_bcs_shared.py @@ -5,27 +5,24 @@ import os import glob -BUILT_ON_SLES15 = "@BUILT_ON_SLES15@" def get_script_head() : head = """#!/bin/csh -x -#SBATCH --output={EXPDIR}/{TMP_DIR}/logs/{GRIDNAME}/{GRIDNAME2}.log -#SBATCH --error={EXPDIR}/{TMP_DIR}/logs/{GRIDNAME}/{GRIDNAME2}.err +#SBATCH --output={EXPDIR}/{TMP_DIR}/logs/{GRIDNAME}/{GRIDNAME}.log +#SBATCH --error={EXPDIR}/{TMP_DIR}/logs/{GRIDNAME}/{GRIDNAME}.err #SBATCH --account={account} #SBATCH --time=12:00:00 #SBATCH --nodes=1 -#SBATCH --job-name={GRIDNAME2}.j +#SBATCH --job-name={GRIDNAME}.j """ - constraint = "#SBATCH --constraint=sky|cas" - if BUILT_ON_SLES15 : - constraint = "#SBATCH --constraint=mil" + constraint = '#SBATCH --constraint="[mil|cas]"' head = head + constraint + """ -echo "-----------------------------" -echo "make_bcs starts date/time" -echo `date` -echo "-----------------------------" +echo "-----------------------------" +echo "make_bcs starts date/time" +echo `date` +echo "-----------------------------" cd {SCRATCH_DIR} @@ -34,6 +31,7 @@ def get_script_head() : endif source bin/g5_modules +module load nco setenv MASKFILE {MASKFILE} setenv MAKE_BCS_INPUT_DIR {MAKE_BCS_INPUT_DIR} limit stacksize unlimited @@ -52,33 +50,23 @@ def get_change_til_file(grid_type): script = """ cd geometry/{GRIDNAME}/ -/bin/rm -f sedfile if( {TRIPOL_OCEAN} == True ) then -cat > sedfile << EOF -s/CF{NC}x6C/PE{nc}x{nc6}-CF/g -s/{OCEAN_VERSION}{DATENAME}{IMO}x{POLENAME}{JMO}-Pfafstetter/PE{imo}x{jmo}-{OCEAN_VERSION}/g -EOF -sed -f sedfile {GRIDNAME}{RS}.til > tile.file -/bin/mv -f tile.file {GRIDNAME}{RS}.til -/bin/rm -f sedfile + sed -i 's/{OCEAN_VERSION}{DATENAME}{IMO}x{POLENAME}{JMO}-Pfafstetter/PE{imo}x{jmo}-{OCEAN_VERSION}/g' {GRIDNAME}{RS}.til + sed -i 's/CF{NC}x6C/PE{nc}x{nc6}-CF/g' {GRIDNAME}{RS}.til + ncatted -a Grid_Name,global,o,c,'PE{nc}x{nc6}-CF' {GRIDNAME}{RS}.nc4 + ncatted -a Grid_ocn_Name,global,o,c,'PE{imo}x{jmo}-{OCEAN_VERSION}' {GRIDNAME}{RS}.nc4 endif if( {CUBED_SPHERE_OCEAN} == True ) then -cat > sedfile << EOF -s/{DATENAME}{IMO}x{POLENAME}{JMO}-Pfafstetter/OC{nc}x{nc6}-CF/g -s/CF{NC}x6C{SGNAME}/PE{nc}x{nc6}-CF/g -EOF -sed -f sedfile {GRIDNAME}{RS}.til > tile.file -/bin/mv -f tile.file {GRIDNAME}{RS}.til -/bin/rm -f sedfile + sed -i 's/{DATENAME}{IMO}x{POLENAME}{JMO}-Pfafstetter/OC{nc}x{nc6}-CF/g' {GRIDNAME}{RS}.til + sed -i 's/CF{NC}x6C{SGNAME}/PE{nc}x{nc6}-CF/g' {GRIDNAME}{RS}.til + ncatted -a Grid_Name,global,o,c,'PE{nc}x{nc6}-CF' {GRIDNAME}{RS}.nc4 + ncatted -a Grid_ocn_Name,global,o,c,'OC{nc}x{nc6}-CF' {GRIDNAME}{RS}.nc4 endif if( {LATLON_OCEAN} == True ) then -cat > sedfile << EOF -s/CF{NC}x6C{SGNAME}/PE{nc}x{nc6}-CF/g -s/{DATENAME}{IMO}x{POLENAME}{JMO}-Pfafstetter/PE{imo}x{jmo}-{DATENAME}/g -EOF -sed -f sedfile {GRIDNAME}{RS}.til > tile.file -/bin/mv -f tile.file {GRIDNAME}{RS}.til -/bin/rm -f sedfile + sed -i 's/{DATENAME}{IMO}x{POLENAME}{JMO}-Pfafstetter/PE{imo}x{jmo}-{DATENAME}/g' {GRIDNAME}{RS}.til + sed -i 's/CF{NC}x6C{SGNAME}/PE{nc}x{nc6}-CF/g' {GRIDNAME}{RS}.til + ncatted -a Grid_Name,global,o,c,'PE{nc}x{nc6}-CF' {GRIDNAME}{RS}.nc4 + ncatted -a Grid_ocn_Name,global,o,c,'PE{imo}x{jmo}-{DATENAME}' {GRIDNAME}{RS}.nc4 endif cd ../../ @@ -87,14 +75,10 @@ def get_change_til_file(grid_type): script = """ cd geometry/{GRIDNAME}/ -/bin/rm -f sedfile -cat > sedfile << EOF -s/DC{IM}xPC{JM}/PC{im}x{jm}-DC/g -s/{DATENAME}{IMO}x{POLENAME}{JMO}-Pfafstetter/PE{imo}x{jmo}-{DATENAME}/g -EOF -sed -f sedfile {GRIDNAME}{RS}.til > tile.file -/bin/mv -f tile.file {GRIDNAME}{RS}.til -/bin/rm -f sedfile +sed -i 's/{DATENAME}{IMO}x{POLENAME}{JMO}-Pfafstetter/PE{imo}x{jmo}-{DATENAME}/g' {GRIDNAME}{RS}.til +sed -i 's/DC{IM}xPC{JM}/PC{im}x{jm}-DC/g' {GRIDNAME}{RS}.til +ncatted -a Grid_Name,global,o,c,'PC{im}x{jm}-DC' {GRIDNAME}{RS}.nc4 +ncatted -a Grid_ocn_Name,global,o,c,'PE{imo}x{jmo}-{DATENAME}' {GRIDNAME}{RS}.nc4 cd ../../ """ @@ -107,6 +91,7 @@ def get_script_mv(grid_type): mkdir -p geometry/{GRIDNAME} /bin/mv {GRIDNAME}.j geometry/{GRIDNAME}/. /bin/cp til/{GRIDNAME}{RS}.til geometry/{GRIDNAME}/. +/bin/cp til/{GRIDNAME}{RS}.nc4 geometry/{GRIDNAME}/. if( {TRIPOL_OCEAN} == True ) /bin/cp til/{GRIDNAME}{RS}.TRN geometry/{GRIDNAME}/. /bin/mv rst til geometry/{GRIDNAME}/. @@ -127,33 +112,32 @@ def get_script_mv(grid_type): ln -s vegdyn_{RC}.dat vegdyn_{RC}.nc4 cd ../../ -/bin/mv clsm/ar.new \\ - clsm/bf.dat \\ - clsm/ts.dat \\ - clsm/catchment.def \\ - clsm/cti_stats.dat \\ - clsm/tau_param.dat \\ - clsm/soil_param.dat \\ - clsm/mosaic_veg_typs_fracs \\ - clsm/soil_param.first \\ - clsm/bad_sat_param.tiles \\ - clsm/README \\ - clsm/lai.* \\ - clsm/AlbMap* \\ - clsm/g5fmt \\ - clsm/vegetation.hst2 \\ - clsm/pfaf_fractions.dat \\ - clsm/plots \\ - clsm/CLM_veg_typs_fracs \\ - clsm/Grid2Catch_TransferData.nc \\ - clsm/CLM_NDep_SoilAlb_T2m \\ - clsm/CLM4.5_abm_peatf_gdp_hdm_fc \\ - clsm/catch_params.nc4 \\ - clsm/catchcn_params.nc4 \\ - clsm/country_and_state_code.data \\ - land/{GRIDNAME}/clsm/ - -""" +/bin/mv clsm/ar.new land/{GRIDNAME}/clsm/ +/bin/mv clsm/bf.dat land/{GRIDNAME}/clsm/ +/bin/mv clsm/ts.dat land/{GRIDNAME}/clsm/ +/bin/mv clsm/catchment.def land/{GRIDNAME}/clsm/ +/bin/mv clsm/cti_stats.dat land/{GRIDNAME}/clsm/ +/bin/mv clsm/tau_param.dat land/{GRIDNAME}/clsm/ +/bin/mv clsm/soil_param.dat land/{GRIDNAME}/clsm/ +/bin/mv clsm/mosaic_veg_typs_fracs land/{GRIDNAME}/clsm/ +/bin/mv clsm/soil_param.first land/{GRIDNAME}/clsm/ +/bin/mv clsm/bad_sat_param.tiles land/{GRIDNAME}/clsm/ +/bin/mv clsm/README land/{GRIDNAME}/clsm/ +/bin/mv clsm/lai.* land/{GRIDNAME}/clsm/ +/bin/mv clsm/AlbMap* land/{GRIDNAME}/clsm/ +/bin/mv clsm/g5fmt land/{GRIDNAME}/clsm/ +/bin/mv clsm/vegetation.hst2 land/{GRIDNAME}/clsm/ +/bin/mv clsm/pfaf_fractions.dat land/{GRIDNAME}/clsm/ +/bin/mv clsm/plots land/{GRIDNAME}/clsm/ +/bin/mv clsm/CLM_veg_typs_fracs land/{GRIDNAME}/clsm/ +/bin/mv clsm/Grid2Catch_TransferData.nc land/{GRIDNAME}/clsm/ +/bin/mv clsm/CLM_NDep_SoilAlb_T2m land/{GRIDNAME}/clsm/ +/bin/mv clsm/CLM4.5_abm_peatf_gdp_hdm_fc land/{GRIDNAME}/clsm/ +/bin/mv clsm/catch_params.nc4 land/{GRIDNAME}/clsm/ +/bin/mv clsm/catchcn_params.nc4 land/{GRIDNAME}/clsm/ +/bin/mv clsm/country_and_state_code.data land/{GRIDNAME}/clsm/ + +""" mv_template = mv_template + get_change_til_file(grid_type) mv_template = mv_template + """ @@ -163,10 +147,10 @@ def get_script_mv(grid_type): mkdir -p ../../geometry ../../land/shared ../../logs -echo "-----------------------------" -echo "make_bcs ends date/time" -echo `date` -echo "-----------------------------" +echo "-----------------------------" +echo "make_bcs ends date/time" +echo `date` +echo "-----------------------------" /bin/mv ../logs/{GRIDNAME} ../../logs/. @@ -179,7 +163,7 @@ def get_script_mv(grid_type): /bin/rm -r {TMP_DIR} -# if necessary, copy resolution-independent CO2 file from MAKE_BCS_INPUT_DIR to bcs dir +# if necessary, copy resolution-independent CO2 file from MAKE_BCS_INPUT_DIR to bcs dir if(-f land/shared/CO2_MonthlyMean_DiurnalCycle.nc4) then echo "CO2_MonthlyMean_DiurnalCycle.nc4 already present in bcs dir." diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkCatchParam.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkCatchParam.F90 index 1ad5ee773..fcafbf333 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkCatchParam.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkCatchParam.F90 @@ -1,3 +1,6 @@ +#define I_AM_MAIN +#include "MAPL_ErrLog.h" + PROGRAM mkCatchParam ! !INTERFACE: @@ -18,9 +21,11 @@ PROGRAM mkCatchParam ! ! Sarith Mahanama - March 23, 2012 ! Email: sarith.p.mahanama@nasa.gov - use EASE_conv + use MAPL, only: MAPL_ease_extent, MAPL_ReadTilingNC4 use rmTinyCatchParaMod use process_hres_data + use MAPL_ExceptionHandling + ! use module_irrig_params, ONLY : create_irrig_params implicit none @@ -35,6 +40,7 @@ PROGRAM mkCatchParam integer :: NC = i_raster, NR = j_raster character*5 :: LBCSV = 'UNDEF' character*128 :: Gridname = '' + character*128 :: withbcs = '' character*128 :: ARG, MaskFile character*256 :: CMD character*1 :: opt @@ -45,7 +51,7 @@ PROGRAM mkCatchParam integer :: I, J, command_argument_count, nxt real*8 :: dx, dy, lon0 logical :: regrid - character(len=400), dimension (6) :: Usage + character(len=128), dimension (7) :: Usage character*128 :: Grid2 character*2 :: poles character*128 :: fnameRst = '' ! a.k.a. "gfile[r]" in mod_process_hres_data.F90 @@ -58,10 +64,16 @@ PROGRAM mkCatchParam type (regrid_map) :: maparc30, mapgeoland2,maparc60 character*200 :: tmpstring, tmpstring1, tmpstring2 character*200 :: fname_tmp, fname_tmp2, fname_tmp3, fname_tmp4 - integer :: N_tile + integer :: n_land logical :: process_snow_albedo = .false. character(len=10) :: nc_string, nr_string - integer :: nc_ease, nr_ease + integer :: nc_ease, nr_ease, unit, clock_rate, clock1, clock2 + real :: seconds + integer, allocatable :: iTable(:,:), tile_pfs(:), tile_j_dum(:) + integer, pointer :: tile_id(:,:) + real, allocatable :: tile_lat(:), tile_lon(:), min_lon(:), max_lon(:), min_lat(:), max_lat(:) + real :: minlon, minlat, maxlon, maxlat, elev + integer :: tindex1, pfaf1, n, status ! --------- VARIABLES FOR *OPENMP* PARALLEL ENVIRONMENT ------------ ! @@ -107,11 +119,13 @@ PROGRAM mkCatchParam USAGE(3) =" -y: Size of latitude dimension of input raster. DEFAULT: 4320 " USAGE(4) =" -g: Gridname (name of the .til or .rst file *without* file extension) " USAGE(5) =" -b: Position of the dateline in the first grid box (DC or DE). DEFAULT: DC " - USAGE(6) =" -v LBCSV : Land bcs version (F25, GM4, ICA, NL3, NL4, NL5, v06, v07, v08 v09 ) " + USAGE(6) =" -v: Land bcs version (F25, GM4, ICA, NL3, NL4, NL5, v06, v07, v08 v09 ) " + USAGE(7) =" -p: if no, it creates catchment_def and nc4 tile files then exits " ! Process Arguments !------------------ + CALL system_clock(count_rate=clock_rate) CALL get_command (cmd) inquire(file='clsm/mkCatchParam.log', exist=file_exists) if(file_exists) then @@ -121,7 +135,7 @@ PROGRAM mkCatchParam write (log_file,'(a)')trim(cmd) write (log_file,'(a)')' ' endif - + withbcs = 'yes' I = command_argument_count() if(I < 1 .or. I > 10) then write (log_file,'(a)') "Wrong Number of arguments: ", i @@ -156,6 +170,8 @@ PROGRAM mkCatchParam call init_bcs_config (trim(LBCSV)) ! get bcs details from version string case ('b') DL = trim(arg) + case ('p') + withbcs = trim(arg) case default do j = 1,size(usage) print "(sp,a100)", Usage(j) @@ -177,7 +193,7 @@ PROGRAM mkCatchParam if (index(Gridname,'EASEv') /=0) then ! here Gridname has alias EASELabel - call ease_extent(Gridname, nc_ease, nr_ease ) + call MAPL_ease_extent(Gridname, nc_ease, nr_ease, _RC) write(nc_string, '(i0)') nc_ease write(nr_string, '(i0)') nr_ease Gridname = trim(Gridname)//'_'//trim(nc_string)//'x'//trim(nr_string) @@ -197,7 +213,7 @@ PROGRAM mkCatchParam if (trim(SNOWALB)=='MODC061' .or. trim(SNOWALB) =='MODC061v2') process_snow_albedo=.true. - if(n_threads == 1) then +! if(n_threads == 1) then write (log_file,'(a)')trim(LAIBCS) write (log_file,'(a)')trim(MODALB) @@ -230,33 +246,84 @@ PROGRAM mkCatchParam ! ! ****************************************************************************** + allocate(tile_id(nc, nr)) + fname_tmp = trim(fnameRst)//'.rst' + open (newunit=unit,file=fname_tmp,status='old',action='read',form='unformatted',convert='little_endian', IOSTAT=status) + if (status /=0) then + write (log_file,'(a)')' '//trim(fname_tmp) // 'cannot be opened, exit ' + call exit(1) + endif + do j = 1, nr + read(unit)tile_id(:,j) + end do + close(unit) ! Creating catchment.def ! ---------------------- - tmpstring = 'Step 01: Supplemental catchment definitions' + tmpstring = 'Step 01: Supplemental tile attributes and nc4-formatted tile file' fname_tmp = 'clsm/catchment.def' write (log_file,'(a,a,a,a)') trim(tmpstring), ' (', trim(fname_tmp), ')' if(.not.ease_grid) then inquire(file=trim(fname_tmp), exist=file_exists) if (.not.file_exists) then - write (log_file,'(a)')' Creating file...' - call catchment_def (nc,nr,regrid,dl,fnameTil,fnameRst) - write (log_file,'(a)')' Done.' + write (log_file,'(a)')' Creating catchment def and nc4 tile file...' + call system_clock(clock1) + call supplemental_tile_attributes(nc,nr,regrid,dl,fnameTil, tile_id) + call system_clock(clock2) + seconds = (clock2-clock1)/real(clock_rate) + write (log_file, *) ' Done. Spent ', seconds, " seconds" else write (log_file,'(a)')' Using existing file.' endif else write (log_file,'(a)')'Skipping step for EASE grid. ' + write (log_file,'(a)')'catchment.def file and tile file should already be created by mkEASETilesParam.x ' endif write (log_file,'(a)')' ' - open (10, file = 'clsm/catchment.def', form = 'formatted', status = 'old', & - action = 'read') - read (10, *) N_tile - close (10, status = 'keep') + if (trim(withbcs) == 'no') then + write (log_file,'(a)')'Skipping MOM BCs. BCs will be extracted from the corresponding BCs. ' + close (log_file,status='keep') + call exit(0) + endif + + call MAPL_ReadTilingNC4( trim(fnameTil)//".nc4", iTable = iTable) + + N_land = count(iTable(:,0) == 100) ! n_land = number of land tiles + allocate(tile_j_dum, source = iTable(1:n_land,7)) ! possible used in cti_stats.dat + deallocate (iTable) + + ! reading from catchment to preserve zero-diff + open (newunit=unit,file='clsm/catchment.def',status='old',action='read',form='formatted', IOSTAT=status) + if (status /=0) then + write (log_file,'(a)')' clsm/cathment.def cannot be opened, exit ' + call exit(1) + endif + read(unit,*) N + if (n /= n_land) then + write (log_file,'(a)')'n_land not consistent between tile file and catchment.def file, exit ' + write (log_file,*) n_land, n + call exit(1) + endif + + allocate(min_lon(n_land), max_lon(n_land), min_lat(n_land), max_lat(n_land)) + allocate(tile_lat(n_land), tile_lon(n_land)) + allocate(tile_pfs(n_land)) + + do n = 1, N_land + read (unit,*) tindex1,pfaf1,minlon,maxlon,minlat,maxlat, elev + min_lon(n) = minlon + max_lon(n) = maxlon + min_lat(n) = minlat + max_lat(n) = maxlat + tile_lon(n)= (minlon + maxlon)/2.0 + tile_lat(n)= (minlat + maxlat)/2.0 + tile_pfs(n)= pfaf1 + end do + close (unit,status='keep') inquire(file='clsm/catch_params.nc4', exist=file_exists) - if (.not.file_exists) CALL open_landparam_nc4_files(N_tile,process_snow_albedo) + if (.not.file_exists) CALL open_landparam_nc4_files(N_land,process_snow_albedo) ! Creating cti_stats.dat ! ---------------------- @@ -266,9 +333,12 @@ PROGRAM mkCatchParam write (log_file,'(a,a,a,a)') trim(tmpstring), ' (', trim(fname_tmp), ')' inquire(file=trim(fname_tmp), exist=file_exists) if (.not.file_exists) then - write (log_file,'(a)')' Creating file...' - call cti_stat_file (ease_grid,fnameTil, MaskFile) - write (log_file,'(a)')' Done.' + write (log_file,'(a)')' Creating file...' + call system_clock(clock1) + call cti_stat_file (MaskFile, n_land, tile_pfs, tile_j_dum) + call system_clock(clock2) + seconds = (clock2-clock1)/real(clock_rate) + write (log_file, *) ' Done. Spent ', seconds, " seconds" else write (log_file,'(a)')' Using existing file.' endif @@ -285,8 +355,11 @@ PROGRAM mkCatchParam inquire(file=trim(fname_tmp), exist=file_exists) if (.not.file_exists) then write (log_file,'(a)')' Creating file...' - call ESA2MOSAIC (nc,nr,fnameRst) - write (log_file,'(a)')' Done.' + call system_clock(clock1) + call ESA2MOSAIC (nc,nr, n_land, tile_pfs, tile_id) + call system_clock(clock2) + seconds = (clock2-clock1)/real(clock_rate) + write (log_file, *) ' Done. Spent ', seconds, " seconds" else write (log_file,'(a)')' Using existing file.' endif @@ -298,8 +371,11 @@ PROGRAM mkCatchParam inquire(file=trim(fname_tmp), exist=file_exists) if (.not.file_exists) then write (log_file,'(a)')' Creating file...' - call ESA2CLM (nc,nr,fnameRst) - write (log_file,'(a)')' Done.' + call system_clock(clock1) + call ESA2CLM (nc,nr, n_land, tile_lat, tile_pfs, tile_id) + call system_clock(clock2) + seconds = (clock2-clock1)/real(clock_rate) + write (log_file, *) ' Done. Spent ', seconds, " seconds" else write (log_file,'(a)')' Using existing file.' endif @@ -313,8 +389,11 @@ PROGRAM mkCatchParam inquire(file=trim(fname_tmp), exist=file_exists) if (.not.file_exists) then write (log_file,'(a)')' Creating file...' - call compute_mosaic_veg_types (nc,nr,ease_grid,regrid,fnameTil,fnameRst) - write (log_file,'(a)')' Done.' + call system_clock(clock1) + call compute_mosaic_veg_types (nc, nr, regrid, n_land, tile_pfs, tile_id) + call system_clock(clock2) + seconds = (clock2-clock1)/real(clock_rate) + write (log_file, *) ' Done. Spent ', seconds, " seconds" else write (log_file,'(a)')' Using existing file.' endif @@ -354,13 +433,23 @@ PROGRAM mkCatchParam if (.not.file_exists) then write (log_file,'(a)')' Creating file...' !allocate (mapgeoland2 (1:40320,1:20160)) - call create_mapping (nc,nr,40320,20160,mapgeoland2, fnameRst) - lai_name = 'GEOLAND2_10-DayClim/geoland2_' + call system_clock(clock1) + call create_mapping (nc,nr,40320,20160,mapgeoland2, n_land, tile_id ) + call system_clock(clock2) + seconds = (clock2-clock1)/real(clock_rate) + write (log_file, *) ' Done create mapping mapgeoland2. Spent ', seconds, " seconds" + lai_name = 'GEOLAND2_10-DayClim/geoland2_' + + write (log_file,'(a)')' Creating '//lai_name + call system_clock(clock1) if(trim(LAIBCS) == 'GEOLAND2') then - call hres_lai_no_gswp (40320,20160,mapgeoland2, lai_name) + call hres_lai_no_gswp (40320,20160,mapgeoland2, lai_name, n_land, tile_lon, tile_lat) else - call hres_lai_no_gswp (40320,20160,mapgeoland2, lai_name, merge=1) + call hres_lai_no_gswp (40320,20160,mapgeoland2, lai_name, n_land, tile_lon, tile_lat, merge=1) endif + call system_clock(clock2) + seconds = (clock2-clock1)/real(clock_rate) + write (log_file, *) ' Done. Spent ', seconds, " seconds" ! if(allocated(mapgeoland2)) deallocate (mapgeoland2) deallocate (mapgeoland2%map) deallocate (mapgeoland2%ij_index) @@ -372,7 +461,11 @@ PROGRAM mkCatchParam if ((LAIBCS == 'MODGEO').or.(LAIBCS == 'MODIS').or.(MODALB == 'MODIS2')) then ! allocate (maparc30 (1:43200,1:21600)) - call create_mapping (nc,nr,43200,21600,maparc30, fnameRst) + call system_clock(clock1) + call create_mapping (nc,nr,43200,21600,maparc30, n_land, tile_id) + call system_clock(clock2) + seconds = (clock2-clock1)/real(clock_rate) + write (log_file, *) ' Done create mapping maparc30. Spent ', seconds, " seconds" endif fname_tmp = 'clsm/green.dat' @@ -380,16 +473,20 @@ PROGRAM mkCatchParam inquire(file=trim(fname_tmp), exist=file_exists) if (.not.file_exists) then write (log_file,'(a)')' Creating file... (resolution will be added to file name later)' + + call system_clock(clock1) if (trim(LAIBCS) == 'GSWP2') then - call process_gswp2_veg (nc,nr,regrid,'grnFrac',fnameRst) + call process_gswp2_veg (nc,nr,regrid,'grnFrac',n_land, tile_id) else if (size(maparc30%ij_index,1) /= 43200) then ! allocate (maparc30 (1:43200,1:21600)) - call create_mapping (nc,nr,43200,21600,maparc30, fnameRst) + call create_mapping (nc,nr,43200,21600,maparc30, n_land, tile_id) endif - call hres_gswp2 (43200,21600, maparc30, 'green') + call hres_gswp2 (43200,21600, maparc30, 'green', n_land, tile_lon, tile_lat) endif - write (log_file,'(a)')' Done.' + call system_clock(clock2) + seconds = (clock2-clock1)/real(clock_rate) + write (log_file, *) ' Done. Spent ', seconds, " seconds" else write (log_file,'(a)')' Using existing file.' endif @@ -401,44 +498,46 @@ PROGRAM mkCatchParam write (log_file,'(a)')' Creating file... (resolution will be added to file name later)' redo_modis = .true. - if (trim(LAIBCS) == 'GSWP2') call process_gswp2_veg (nc,nr,regrid,'LAI',fnameRst) + call system_clock(clock1) + if (trim(LAIBCS) == 'GSWP2') call process_gswp2_veg (nc,nr,regrid,'LAI', n_land, tile_id) if (trim(LAIBCS) == 'GSWPH') then if (size(maparc30%ij_index,1) /= 43200) then ! allocate (maparc30 (1:43200,1:21600)) - call create_mapping (nc,nr,43200,21600,maparc30, fnameRst) + call create_mapping (nc,nr,43200,21600,maparc30, n_land, tile_id) endif inquire(file='clsm/lai.MODIS_8-DayClim', exist=file_exists) - if (.not.file_exists) call hres_gswp2 (43200,21600, maparc30, 'lai') + if (.not.file_exists) call hres_gswp2 (43200,21600, maparc30, 'lai', n_land, tile_lon, tile_lat) endif if (trim(LAIBCS) == 'MODIS') then lai_name = 'MODIS_8-DayClim/MODIS_' - call hres_lai_no_gswp (43200,21600,maparc30,lai_name) + call hres_lai_no_gswp (43200,21600,maparc30,lai_name, n_land, tile_lon, tile_lon) endif if (trim(LAIBCS) == 'MODGEO') then lai_name = 'MODIS_8-DayClim/MODIS_' inquire(file='clsm/lai.MODIS_8-DayClim', exist=file_exists) - if (.not.file_exists)call hres_lai_no_gswp (43200,21600,maparc30,lai_name, merge=1) - call merge_lai_data (MaskFile) + if (.not.file_exists)call hres_lai_no_gswp (43200,21600,maparc30,lai_name, n_land, tile_lon, tile_lat, merge=1) + call merge_lai_data (MaskFile, n_land, tile_pfs) endif if (trim(LAIBCS) == 'MODISV6') then lai_name = 'MCD15A2H.006/MODIS_' - call grid2tile_modis6 (86400,43200,nc,nr,fnameRst,lai_name) + call grid2tile_modis6 (86400,43200,nc,nr,n_land, tile_lon, tile_lat, tile_id, lai_name) endif if (trim(LAIBCS) == 'GLASSA') then lai_name = 'GLASS-LAI/AVHRR.v4/GLASS01B02.V04.AYYYY' - call grid2tile_glass (nc,nr,fnameRst,lai_name) + call grid2tile_glass (nc,nr, tile_id,lai_name, n_land, tile_lon, tile_lat) endif if (trim(LAIBCS) == 'GLASSM') then lai_name = 'GLASS-LAI/MODIS.v4/GLASS01B01.V04.AYYYY' - call grid2tile_glass (nc,nr,fnameRst,lai_name) + call grid2tile_glass (nc,nr,tile_id,lai_name, n_land, tile_lon, tile_lat) endif - - write (log_file,'(a)')' Done.' + call system_clock(clock2) + seconds = (clock2-clock1)/real(clock_rate) + write (log_file, *) ' Done. Spent ', seconds, " seconds" else write (log_file,'(a)')' Using existing file.' endif @@ -448,8 +547,11 @@ PROGRAM mkCatchParam inquire(file=trim(fname_tmp), exist=file_exists) if (.not.file_exists) then write (log_file,'(a)')' Creating file... (resolution will be added to file name later)' - call gimms_clim_ndvi (nc,nr,fnameRst) - write (log_file,'(a)')' Done.' + call system_clock(clock1) + call gimms_clim_ndvi (nc,nr, n_land, tile_id) + call system_clock(clock2) + seconds = (clock2-clock1)/real(clock_rate) + write (log_file, *) ' Done. Spent ', seconds, " seconds" else write (log_file,'(a)')' Using existing file.' endif @@ -474,16 +576,19 @@ PROGRAM mkCatchParam inquire(file=trim(fname_tmp), exist=file_exists) if (.not.file_exists) then write (log_file,'(a)')' Creating file...' + call system_clock(clock1) if(F25Tag) then - call create_mapping (nc,nr,21600,10800,maparc60, fnameRst) - call modis_alb_on_tiles_high (21600,10800,maparc60,MODALB) + call create_mapping (nc,nr,21600,10800,maparc60, n_land, tile_id) + call modis_alb_on_tiles_high (21600,10800,maparc60,MODALB, n_land) deallocate (maparc60%map) deallocate (maparc60%ij_index) else ! This option is for legacy sets like Fortuna 2.1 - call modis_alb_on_tiles (nc,nr,ease_grid,regrid,fnameTil,fnameRst) + call modis_alb_on_tiles (nc,nr,regrid, n_land, tile_id) endif - write (log_file,'(a)')' Done.' + call system_clock(clock2) + seconds = (clock2-clock1)/real(clock_rate) + write (log_file, *) ' Done. Spent ', seconds, " seconds" else write (log_file,'(a)')' Using existing file.' endif @@ -496,9 +601,12 @@ PROGRAM mkCatchParam inquire(file=trim(fname_tmp ), exist=file_exists ) inquire(file=trim(fname_tmp2), exist=file_exists2) if ((.not.file_exists).or.(.not.file_exists2)) then + call system_clock(clock1) write (log_file,'(a)')' Creating files...' - call modis_alb_on_tiles_high (43200,21600,maparc30,MODALB) - write (log_file,'(a)')' Done.' + call modis_alb_on_tiles_high (43200,21600,maparc30,MODALB, n_land) + call system_clock(clock2) + seconds = (clock2-clock1)/real(clock_rate) + write (log_file, *) ' Done. Spent ', seconds, " seconds" else write (log_file,'(a)')' Using existing file.' endif @@ -521,7 +629,8 @@ PROGRAM mkCatchParam if ((redo_modis).or.(.not.file_exists).or.(.not.file_exists2)) then ! if(.not.F25Tag) then write (log_file,'(a)')' Creating files... (resolution will be added to file name later)' - call modis_scale_para_high (ease_grid,MODALB,fnameTil) + call system_clock(clock1) + call modis_scale_para_high (MODALB, n_land) ! else ! This option is for legacy sets like Fortuna 2.1 ! inquire(file='clsm/modis_scale_factor.albvf.clim', exist=file_exists) @@ -530,7 +639,9 @@ PROGRAM mkCatchParam ! call REFORMAT_VEGFILES ! endif ! endif - write (log_file,'(a)')' Done.' + call system_clock(clock2) + seconds = (clock2-clock1)/real(clock_rate) + write (log_file, *) ' Done. Spent ', seconds, " seconds" else write (log_file,'(a)')' Using existing files.' endif @@ -540,15 +651,18 @@ PROGRAM mkCatchParam ! write(tmpstring2,'(2(a2,x,i5,x))')'-x',nc,'-y',nr ! tmpstring = 'bin/mkCatchParam_openmp '//trim(tmpstring2)//' '//trim(tmpstring1) - else +! else ! this block is for n_threads>1 !============================== if(trim(SOILBCS)=='NGDC') then write (log_file,'(a)')'Creating (intermediate) NGDC soil types file...' - call create_soil_types_files (nc,nr,ease_grid,fnameTil,fnameRst) - write (log_file,'(a)')' Done.' + call system_clock(clock1) + call create_soil_types_files (nc,nr, n_land, tile_pfs, tile_id) + call system_clock(clock2) + seconds = (clock2-clock1)/real(clock_rate) + write (log_file, *) ' Done. Spent ', seconds, " seconds" write (log_file,'(a)')' ' endif @@ -562,12 +676,15 @@ PROGRAM mkCatchParam inquire(file=trim(fname_tmp), exist=file_exists) if (.not.file_exists) then write (log_file,'(a)')' Creating file...' + call system_clock(clock1) if(trim(SOILBCS)=='NGDC') then - if( F25Tag) call soil_para_high (nc,nr,regrid,fnameRst,F25Tag=F25Tag) - if(.not.F25Tag) call soil_para_high (nc,nr,regrid,fnameRst) + if( F25Tag) call soil_para_high (nc,nr,regrid, n_land, tile_id,F25Tag=F25Tag) + if(.not.F25Tag) call soil_para_high (nc,nr,regrid, n_land, tile_id) endif - if(SOILBCS(1:4)=='HWSD') call soil_para_hwsd (nc,nr,fnameRst) - write (log_file,'(a)')' Done.' + if(SOILBCS(1:4)=='HWSD') call soil_para_hwsd (nc,nr, n_land, tile_pfs, tile_id) + call system_clock(clock2) + seconds = (clock2-clock1)/real(clock_rate) + write (log_file, *) ' Done. Spent ', seconds, " seconds" else write (log_file,'(a,a)')' Using existing file.' endif @@ -586,9 +703,12 @@ PROGRAM mkCatchParam inquire(file=trim(fname_tmp4), exist=file_exists4) if ((.not.file_exists).or.(.not.file_exists2).or.(.not.file_exists3).or.(.not.file_exists4)) then write (log_file,'(a)')' Creating files...' - if(trim(SOILBCS)=='NGDC') call create_model_para( MaskFile) - if(SOILBCS(1:4) =='HWSD') call create_model_para_woesten(MaskFile) - write (log_file,'(a)')' Done.' + call system_clock(clock1) + if(trim(SOILBCS)=='NGDC') call create_model_para( MaskFile, n_land, tile_lon, tile_lat, tile_pfs) + if(SOILBCS(1:4) =='HWSD') call create_model_para_woesten(MaskFile, n_land, tile_lon, tile_lat, tile_pfs) + call system_clock(clock2) + seconds = (clock2-clock1)/real(clock_rate) + write (log_file, *) ' Done. Spent ', seconds, " seconds" else write (log_file,'(a,a)')' Using existing files.' endif @@ -609,8 +729,11 @@ PROGRAM mkCatchParam inquire(file='clsm/CLM_veg_typs_fracs', exist=file_exists) if (file_exists) then write (log_file,'(a)')' Creating file...' - call grid2tile_ndep_t2m_alb (nc,nr,fnameRst) - write (log_file,'(a)')' Done.' + call system_clock(clock1) + call grid2tile_ndep_t2m_alb (nc,nr, n_land,tile_id) + call system_clock(clock2) + seconds = (clock2-clock1)/real(clock_rate) + write (log_file, *) 'Done. Spent ', seconds, " seconds" else write (log_file,'(a)')'Skipping step for lack of matching veg types file.' endif @@ -622,8 +745,11 @@ PROGRAM mkCatchParam inquire(file=trim(fname_tmp), exist=file_exists) if (.not.file_exists) then write (log_file,'(a)')' Creating file...' - call CLM45_fixed_parameters (nc,nr,fnameRst) - write (log_file,'(a)')' Done.' + call system_clock(clock1) + call CLM45_fixed_parameters (nc,nr, n_land, tile_id) + call system_clock(clock2) + seconds = (clock2-clock1)/real(clock_rate) + write (log_file, *) 'Done. Spent ', seconds, " seconds" else write (log_file,'(a)')' Using existing file.' endif @@ -635,8 +761,11 @@ PROGRAM mkCatchParam inquire(file=trim(fname_tmp), exist=file_exists) if (.not.file_exists) then write (log_file,'(a)')' Creating file... (resolution will be added to file name later)' - call CLM45_clim_parameters (nc,nr,fnameRst) - write (log_file,'(a)')' Done.' + call system_clock(clock1) + call CLM45_clim_parameters (nc,nr,n_land,tile_id) + call system_clock(clock2) + seconds = (clock2-clock1)/real(clock_rate) + write (log_file, *) 'Done. Spent ', seconds, " seconds" else write (log_file,'(a)')' Using existing file.' endif @@ -648,8 +777,11 @@ PROGRAM mkCatchParam inquire(file=trim(fname_tmp), exist=file_exists) if (.not.file_exists) then write (log_file,'(a)')' Creating file...' - call map_country_codes (nc,nr) - write (log_file,'(a)')' Done.' + call system_clock(clock1) + call map_country_codes (nc,nr,n_land, tile_lon, tile_lat) + call system_clock(clock2) + seconds = (clock2-clock1)/real(clock_rate) + write (log_file, *) 'Done. Spent ', seconds, " seconds" else write (log_file,'(a)')' Using existing file.' endif @@ -659,18 +791,21 @@ PROGRAM mkCatchParam tmpstring = 'Step 14: Static snow albedo from MODIS' write (log_file,'(a)') trim(tmpstring) write (log_file,'(a)')' Creating file...' + call system_clock(clock1) if (trim(SNOWALB)=='MODC061') then - call MODIS_snow_alb ( ) + call MODIS_snow_alb (n_land, min_lon, max_lon, min_lat, max_lat) elseif (trim(SNOWALB)=='MODC061v2') then if (size(maparc30%ij_index,1) /= 43200) then - call create_mapping (nc,nr,43200,21600,maparc30,fnameRst) + call create_mapping (nc,nr,43200,21600,maparc30, n_land, tile_id) end if - call MODIS_snow_alb_v2(43200,21600,maparc30) + call MODIS_snow_alb_v2(43200,21600,maparc30, n_land) else write (log_file,'(a)')'Unknown SNOWALB... stopping!' stop endif - write (log_file,'(a)')' Done.' + call system_clock(clock2) + seconds = (clock2-clock1)/real(clock_rate) + write (log_file, *) 'Done. Spent ', seconds, " seconds" write (log_file,'(a)')' ' endif @@ -684,7 +819,7 @@ PROGRAM mkCatchParam write (log_file,'(a)')' ' ! call execute_command_line ('chmod 755 bin/create_README.csh ; bin/create_README.csh') - endif +! endif close (log_file,status='keep') diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkCubeFVRaster.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkCubeFVRaster.F90 index 5b1c4d12a..ad6f663dc 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkCubeFVRaster.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkCubeFVRaster.F90 @@ -16,7 +16,7 @@ program mkCubeFVRaster ! !USES: ! use CubedSphere_GridMod - use LogRectRasterizeMod + use LogRectRasterizeMod, ONLY: LRRasterize use MAPL_ExceptionHandling !EOP diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkEASETilesParam.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkEASETilesParam.F90 index d64bf0967..5856811b8 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkEASETilesParam.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkEASETilesParam.F90 @@ -29,21 +29,23 @@ PROGRAM mkEASETilesParam ! - removed repetition of identical operations ! - added comments ! - white-space changes for improved readability - - use EASE_conv, only : EASE_extent, EASE_convert, EASE_inverse - use rmTinyCatchParaMod, only : i_raster, j_raster, SRTM_maxcat - use rmTinyCatchParaMod, only : RegridRasterReal - use process_hres_data, only : histogram + use, intrinsic :: iso_fortran_env, only: REAL64 + use rmTinyCatchParaMod, only : i_raster, j_raster + use rmTinyCatchParaMod, only : RegridRasterReal + use rmTinyCatchParaMod, only : Target_mean_land_elev + use process_hres_data, only : histogram + use LogRectRasterizeMod, only : SRTM_maxcat, MAPL_UNDEF_R8 ! rasterize.F90 use MAPL_SortMod - use MAPL_ConstantsMod + use MAPL_ConstantsMod, only : MAPL_PI_r8, MAPL_RADIUS use MAPL_ExceptionHandling + use MAPL, only : MAPL_ease_extent, MAPL_ease_convert, MAPL_ease_inverse, MAPL_WriteTilingNC4 use netcdf implicit none - integer, parameter :: nc_esa = 129600 ! number of cols in 10-arcsec ESA mask file - integer, parameter :: nr_esa = 64800 ! number of rows in 10-arcsec ESA mask file - + integer, parameter :: nc_esa = 129600 ! number of cols in 10-arcsec ESA mask file + integer, parameter :: nr_esa = 64800 ! number of rows in 10-arcsec ESA mask file + ! define tile types used for processing here (values may be from ESA mask?) integer, parameter :: OceanType = 0 @@ -51,8 +53,6 @@ PROGRAM mkEASETilesParam integer, parameter :: LakeType = 10 ! lake type used for processing here; in GEOS, lake tiles are type= 19 integer, parameter :: IceType = 11 ! landice type used for processing here; in GEOS, landice tiles are type= 20 - real*8, parameter :: Target_mean_land_elev = 614.649D0 - ! ------------------------------------------------------------ integer :: i, j, ig, jg, nn, kkE, kkR, mm @@ -70,7 +70,7 @@ PROGRAM mkEASETilesParam integer :: dx_esa, dy_esa, NBINS, NPLUS integer*8, allocatable, dimension(:) :: SRTM_catid - real(kind=8),allocatable, dimension(:) :: SRTM_catid_r8 + real(REAL64),allocatable, dimension(:) :: SRTM_catid_r8 integer, allocatable, dimension(:,:), target :: tileid_index, catid_index @@ -82,7 +82,9 @@ PROGRAM mkEASETilesParam integer*1, allocatable, dimension(:,:) :: veg real*4, allocatable, dimension(:,:) :: q0, raster REAL, allocatable, dimension(:) :: tile_elev - + integer, allocatable, dimension(:,:) :: iTable + real(REAL64),allocatable, dimension(:,:) :: rTable + !INTEGER*8 :: PFAF_CODE integer :: l, l_index, i_index, w_index, typ, pfaf_index @@ -155,7 +157,7 @@ PROGRAM mkEASETilesParam EASElabel = trim(EASELabel_) - call ease_extent( EASELabel, nc_ease, nr_ease ) + call MAPL_ease_extent( EASELabel, nc_ease, nr_ease, _RC) write(nc_string, '(i0)') nc_ease write(nr_string, '(i0)') nr_ease @@ -370,7 +372,7 @@ PROGRAM mkEASETilesParam ! get 1-based ind_col and ind_row indices of EASE grid cell that contains raster grid cell (i,j) - call EASE_convert(EASELabel, clat, clon, r_ease, s_ease) + call MAPL_EASE_convert(EASELabel, clat, clon, r_ease, s_ease, _RC) ind_col = nint(r_ease) + 1 ind_row = nint(s_ease) + 1 ! can be negative or greater than nr_ease (lat near N/S pole) @@ -540,7 +542,7 @@ PROGRAM mkEASETilesParam ! do j =nr ,1 ,-1 ! ! clat = -90. + float(j-1)*dy + dy/2. -! call EASE_convert(EASELabel, clat, clon, r_ease, s_ease) +! call MAPL_EASE_convert(EASELabel, clat, clon, r_ease, s_ease) ! ! ind_col = nint(r_ease) + 1 ! ind_row = nint(s_ease) + 1 @@ -612,7 +614,7 @@ PROGRAM mkEASETilesParam allocate(my_land (1:n_landlakelandice)) allocate(all_id (1:n_landlakelandice)) - allocate(tile_elev (1:n_land)) + allocate(tile_elev (1:n_landlakelandice)) ! =========================================================================== ! @@ -654,7 +656,7 @@ PROGRAM mkEASETilesParam ! get 1-based ind_col and ind_row indices of EASE grid cell that contains raster grid cell (i,j) - call EASE_convert(EASELabel, clat, clon, r_ease, s_ease) + call MAPL_EASE_convert(EASELabel, clat, clon, r_ease, s_ease, _RC) ind_col = nint(r_ease) + 1 ind_row = nint(s_ease) + 1 ! NOTE: can be zero or negative or greater than nr_ease (lat near N/S pole) @@ -708,13 +710,6 @@ PROGRAM mkEASETilesParam tileid_index(i,j) = land_id(kkE) - ! sum up area and (area-weighted) elevation (only over raster grid cells of type land!) - - tile_elev( tileid_index(i,j)) = tile_elev( tileid_index(i,j)) + q0(i,j) * pix_area ! q0 = elevation - - ! tile_area_land should be obsolete because identical to tile_area(1:n_land) - !tile_area_land(tileid_index(i,j)) = tile_area_land(tileid_index(i,j)) + pix_area - case default print *,'ERROR: unknown tile type value in veg(i,j): ', veg(i,j), ' STOPPING.' @@ -726,6 +721,12 @@ PROGRAM mkEASETilesParam tile_area(tileid_index(i,j)) = tile_area(tileid_index(i,j)) + pix_area + ! sum up (area-weighted) elevation + + tile_elev(tileid_index(i,j)) = tile_elev(tileid_index(i,j)) + q0(i,j) * pix_area ! q0 = elevation on 30-arcsec raster + + ! record 1-dim indices w.r.t. EASE grid cell and raster grid cell + my_land(tileid_index(i,j)) = kkE ! for this tile, store 1-dim index for EASE grid cells all_id( tileid_index(i,j)) = kkR ! for this tile, store 1-dim index for raster grid cells - last in prevails! @@ -770,7 +771,7 @@ PROGRAM mkEASETilesParam deallocate(water_id) deallocate(ice_id ) - tile_elev = tile_elev/tile_area(1:n_land) ! finalize tile elevation + tile_elev = tile_elev/tile_area(1:n_landlakelandice) ! finalize tile elevation ! --------------------------------------------------------------------------------- @@ -793,7 +794,7 @@ PROGRAM mkEASETilesParam print *, 'Global mean land elevation before adjustment [m]: ', mean_land_elev - tile_elev = tile_elev*(Target_mean_land_elev/mean_land_elev) + tile_elev(1:n_land) = tile_elev(1:n_land)*(Target_mean_land_elev/mean_land_elev) ! print adjusted elevation to log file mean_land_elev=0. @@ -845,6 +846,9 @@ PROGRAM mkEASETilesParam ! write (10,*) -9999 dx_ease = 180./real(nc_ease) + + allocate(iTable(n_landlakelandice,0:4)) ! 0-based index inherited from elsewhere in make_bcs + allocate(rTable(n_landlakelandice,10), source = MAPL_UNDEF_R8) do nn=1,n_landlakelandice @@ -875,6 +879,26 @@ PROGRAM mkEASETilesParam i = kkR - nc*(j-1) ! (1-based) pfaf_index = catid_index(i,j) + + ! get min/max lat/lon of EASE grid cell + ! BUG: This is *not* the desired min/max lat/lon of the land tile!!! + + call MAPL_ease_inverse( EASELabel, real(ig-1), real(jg-1), clat, clon, _RC) + + mnx = clon - dx_ease + mxx = clon + dx_ease + + jgv = real(jg-1) + 0.5 + + call MAPL_ease_inverse( EASELabel, real(ig-1), jgv, clat, clon, _RC) + + mny = clat + + jgv = real(jg-1) - 0.5 + + call MAPL_ease_inverse( EASELabel, real(ig-1), jgv, clat, clon, _RC) + + mxy = clat if ((nn>n_land) .and. (nn<=n_landlake)) typ = 19 ! Lake tile @@ -884,30 +908,10 @@ PROGRAM mkEASETilesParam typ = 100 ! Land tile - ! get min/max lat/lon of EASE grid cell - ! BUG: This is *not* the desired min/max lat/lon of the land tile!!! - - call EASE_inverse( EASELabel, real(ig-1), real(jg-1), clat, clon ) - - mnx = clon - dx_ease - mxx = clon + dx_ease - - jgv = real(jg-1) + 0.5 - - call EASE_inverse( EASELabel, real(ig-1), jgv, clat, clon ) - - mny = clat - - jgv = real(jg-1) - 0.5 - - call EASE_inverse( EASELabel, real(ig-1), jgv, clat, clon ) - - mxy = clat - - ! write tile properties into catchment.def file + ! write tile properties into (ASCII-formatted) catchment.def file write (11,'(i10,i8,5(2x,f9.4), i4)') nn, pfaf_index, mnx, mxx, mny, mxy, tile_elev(nn) - + endif ! get area fraction of tile within EASE grid cell @@ -916,11 +920,29 @@ PROGRAM mkEASETilesParam ! contributing raster grid cells, which is *not* the same for all EASE grid cells; ! that is, cannot use exact (globally constant) area of EASE grid cell. - call EASE_inverse( EASELabel, real(ig-1), real(jg-1), clat, clon ) + call MAPL_ease_inverse( EASELabel, real(ig-1), real(jg-1), clat, clon, _RC) fr_gcm = tile_area(nn) / ease_grid_area((jg-1)*nc_ease+ig) - ! write tile properties into *.til file + ! add info into array used for writing nc4-formatted tile file + + rTable(nn, 1) = clon + rTable(nn, 2) = clat + rTable(nn, 3) = tile_area(nn) + rTable(nn, 4) = ease_grid_area((jg-1)*nc_ease+ig) + rTable(nn, 5) = SRTM_catid_r8(pfaf_index) + rTable(nn, 6) = mnx + rTable(nn, 7) = mxx + rTable(nn, 8) = mny + rTable(nn, 9) = mxy + rTable(nn,10) = tile_elev(nn) + + iTable(nn, 0) = typ ! 0-based index inherited from elsewhere in make_bcs + iTable(nn, 2) = ig -1 + iTable(nn, 3) = jg -1 + iTable(nn, 4) = pfaf_index + + ! write tile properties into ASCII-formatted tile file (*.til) if (index(MaskFile,'GEOS5_10arcsec_mask') /= 0) then @@ -942,28 +964,33 @@ PROGRAM mkEASETilesParam stop ! ! write(10,'(i10,i9,2f10.4,2i5,f19.12,i10,e13.4,i8)') & -! typ,pfaf,clon,clat,ig-1,jg-1,fr_gcm ,cindex + ! typ,pfaf,clon,clat,ig-1,jg-1,fr_gcm ,cindex endif end do close(10,status='keep') - close(11,status='keep') + close(11,status='keep') + + ! write nc4-formatted tile file (including supplemental tile attributes ["catchment.def"]) + + call MAPL_WriteTilingNC4('til/'//trim(gfile)//'.nc4', [EASELabel],[nc_ease],[nr_ease], & + nc, nr, iTable, rTable) deallocate( tileid_index, catid_index,veg ) deallocate( tile_area, ease_grid_area, tile_elev, my_land, all_id ) ! Commented out "empty" if-block. -rreichle, 15 Jun 2023 -! -! if (index(MaskFile,'GEOS5_10arcsec_mask') /= 0) then -! -! print *,'Creating SMAP-Catch_TransferData.nc files.' -! -! !--------------------------------------------------- -! -! deallocate (SRTM_CatchArea, SRTM_catid, SRTM_catid_r8) -! -! endif + ! + ! if (index(MaskFile,'GEOS5_10arcsec_mask') /= 0) then + ! + ! print *,'Creating SMAP-Catch_TransferData.nc files.' + ! + ! !--------------------------------------------------- + ! + ! deallocate (SRTM_CatchArea, SRTM_catid, SRTM_catid_r8) + ! + ! endif ! create Grid2Catch transfer file ! ------------------------------- @@ -1004,7 +1031,7 @@ PROGRAM mkEASETilesParam !!! do i = 1, nc_ease+1 !!! x = real(i-1) -0.5 !!! y = real(nr_ease - j)+0.5 -!!! call EASE_inverse(MGRID, x, y, yout, xout) +!!! call MAPL_ease_inverse(MGRID, x, y, yout, xout) !!! ys (i,j) = dble(yout) !!! xs (i,j) = dble(xout) !!! end do diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkLandRaster.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkLandRaster.F90 index 1ecb9a0c3..6f0bb09ee 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkLandRaster.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkLandRaster.F90 @@ -4,12 +4,13 @@ Program MakeLandRaster use MAPL_ExceptionHandling - use LogRectRasterizeMod + use LogRectRasterizeMod, ONLY: WriteRaster, WriteTiling, SortTiling, SRTM_maxcat use MAPL_HashMod use process_hres_data use MAPL_SortMod - use rmTinyCatchParaMod, ONLY: SRTM_maxcat, RegridRaster - use MAPL_Constants, only: PI=>MAPL_PI_R8 + use rmTinyCatchParaMod, ONLY: RegridRaster + use MAPL_Constants, ONLY: PI=>MAPL_PI_R8 + use, intrinsic :: iso_fortran_env, only: REAL64 ! Program to create a surface raster file that has ! the ocean divided with a regular lat-lon DE grid. Its inputs @@ -52,12 +53,12 @@ Program MakeLandRaster integer :: type, maxtiles, nx, ny integer :: count0,count1,count_rate - real(kind=8) :: dx, dy, d2r ! Grid spacing of raster grid - real(kind=8) :: xmin, ymin, xmax, ymax, xs, ys, da + real(REAL64) :: dx, dy, d2r ! Grid spacing of raster grid + real(REAL64) :: xmin, ymin, xmax, ymax, xs, ys, da - real(kind=8), allocatable :: cc(:), ss(:) + real(REAL64), allocatable :: cc(:), ss(:) - real(kind=8) , allocatable :: rTable( :,:) + real(REAL64) , allocatable :: rTable( :,:) integer, pointer :: Raster( :,:) integer, allocatable, target :: Raster0(:,:) @@ -70,7 +71,7 @@ Program MakeLandRaster logical :: Verb logical :: regrid=.false., reynolds_sst=.false. - real(kind=8) :: VV(4) + real(REAL64) :: VV(4) ! ESA/SRTM ocean/land/ice/lake mask parameters ! -------------------------------------------- diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkLatLonRaster.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkLatLonRaster.F90 index 05c220ebd..2dbc78a52 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkLatLonRaster.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkLatLonRaster.F90 @@ -44,7 +44,7 @@ program mkLatLonRaster ! The rasterization fails if there are not an integer number of pixels ! in each box. - use LogRectRasterizeMod + use LogRectRasterizeMod, ONLY: LRRasterize use MAPL_ExceptionHandling implicit none diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkMITAquaRaster.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkMITAquaRaster.F90 index 6fc5ffdfd..7edff67ed 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkMITAquaRaster.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkMITAquaRaster.F90 @@ -3,21 +3,20 @@ program MAIN - use LogRectRasterizeMod + use LogRectRasterizeMod, ONLY: LRRasterize use MAPL_ExceptionHandling - + use, intrinsic :: iso_fortran_env, only: REAL64 implicit none integer, parameter :: IUNIT = 11, OUNIT = 12 integer :: iargc - integer, parameter :: RKIND = 8 INTEGER :: NC INTEGER :: NX, NY integer :: STATARRAY(12) - integer(kind=8) :: filesize - integer(kind=8) :: Length + integer(REAL64) :: filesize + integer(REAL64) :: Length integer :: K integer :: i, j integer :: KF, L, NF @@ -27,9 +26,9 @@ program MAIN integer :: J1,JN integer :: N integer :: nxt - REAL(kind=RKIND), POINTER :: XG(:,:), YG(:,:) - real(kind=RKIND), pointer :: XT(:,: ), YT(:,: ) - real(kind=RKIND), allocatable :: XV(:,:,:), YV(:,:,:) + REAL(kind=REAL64), POINTER :: XG(:,:), YG(:,:) + real(kind=REAL64), pointer :: XT(:,: ), YT(:,: ) + real(kind=REAL64), allocatable :: XV(:,:,:), YV(:,:,:) character(len=128) :: GridDir character(len=128) :: & @@ -52,7 +51,7 @@ program MAIN integer :: Ncol = 8640, NRow = 4320 type Ptr2 - real(kind=RKIND), pointer :: V(:,:) + real(kind=REAL64), pointer :: V(:,:) end type Ptr2 type(Ptr2) :: X(4), Y(4) @@ -99,7 +98,7 @@ program MAIN integer :: BLNKSZ integer, dimension(MAXBLNKSZ) :: blankList - real(kind=RKIND) :: areamin, xc, yc + real(kind=REAL64) :: areamin, xc, yc character(len=128) :: Iam = "mkMITAquaRaster" NAMELIST /W2_EXCH2_PARM01/ sNx, SNy, blankList @@ -162,7 +161,7 @@ program MAIN if (filesize <= 0) filesize = 2389893248 ! print *,'file size=',filesize - LENGTH = filesize/rkind + LENGTH = filesize/REAL64 do k=16,20 if(mod(length,k)==0) exit @@ -173,13 +172,13 @@ program MAIN call exit(1) end if - nc = nint(sqrt(length/real(k,kind=rkind))) + nc = nint(sqrt(length/real(k,kind=REAL64))) ! nc = 4321 nx = nc-1 ny = nc-1 - LENGTH = nx*ny*rkind + LENGTH = nx*ny*REAL64 ! Open Facet 1 to check sizes CS or LLC) open (IUNIT,file=trim(GridDir)//'/tile001.mitgrid', status='old') @@ -192,7 +191,7 @@ program MAIN if (filesize <= 0) filesize = 7168573568 ! print *,'file size=',filesize - LENGTH = filesize/(rkind * k) + LENGTH = filesize/(REAL64 * k) if (LENGTH == NC*NC) then ! cubed-sphere isLLC = .false. @@ -295,8 +294,8 @@ program MAIN xg=0.0 yg=0.0 - LENGTH = size(XG)*rkind -! print *,'DEBUG:length=',length, rkind + LENGTH = size(XG)*REAL64 +! print *,'DEBUG:length=',length, REAL64 ! Read vertcies for each face !---------------------------- diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkMOMAquaRaster.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkMOMAquaRaster.F90 index c22ddc57e..f347221ea 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkMOMAquaRaster.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkMOMAquaRaster.F90 @@ -2,8 +2,9 @@ #include "MAPL_ErrLog.h" program MOMraster - use LogRectRasterizeMod + use LogRectRasterizeMod, ONLY: LRRasterize use MAPL_ExceptionHandling + use, intrinsic :: iso_fortran_env, only: REAL64 implicit none ! this program builds a rasterized grid whose cells are 2.5 by 2.5 minutes @@ -13,9 +14,9 @@ program MOMraster ! via namelist hence can be changed at runtime integer :: im, jm ! dimensions of MOM grid - real(kind=8), pointer :: xvert(:,:,:) ! Lons of MOM's vertices - real(kind=8), pointer :: yvert(:,:,:) ! Lats of MOM's vertices - real(kind=8) :: xmin, xmax + real(REAL64), pointer :: xvert(:,:,:) ! Lons of MOM's vertices + real(REAL64), pointer :: yvert(:,:,:) ! Lats of MOM's vertices + real(REAL64) :: xmin, xmax integer :: i, j, nxt,k integer :: status, command_argument_count character*(128) :: GridFile @@ -35,7 +36,7 @@ program MOMraster integer :: Nc = 8640 integer :: NR = 4320 - real(kind=8) :: tol + real(REAL64) :: tol INCLUDE "netcdf.inc" ! Process Arguments @@ -147,13 +148,13 @@ end subroutine FieldSize subroutine ReadGridFile(FILE,XVERT,YVERT) character*(*), intent(IN ) :: FILE - real(kind=8), pointer :: XVERT(:,:,:) - real(kind=8), pointer :: YVERT(:,:,:) + real(REAL64), pointer :: XVERT(:,:,:) + real(REAL64), pointer :: YVERT(:,:,:) integer :: STATUS, NCID, VARID integer :: SIZ_XVERT_X, SIZ_XVERT_Y integer :: SIZ_YVERT_X, SIZ_YVERT_Y - real(kind=8), pointer :: VERTX(:,:),VERTY(:,:) + real(REAL64), pointer :: VERTX(:,:),VERTY(:,:) Status=NF_OPEN(FILE,NF_NOWRITE,NCID) _ASSERT(STATUS==NF_NOERR,'needs informative message') diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mk_runofftbl.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mk_runofftbl.F90 index 88ed9210c..b07c9fb4b 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mk_runofftbl.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mk_runofftbl.F90 @@ -29,6 +29,7 @@ program mk_runofftbl use mapl_sortmod use rmTinyCatchParaMod, only : init_bcs_config, OUTLETV use netcdf + use, intrinsic :: iso_fortran_env, only: REAL64 implicit none include 'netcdf.inc' @@ -168,8 +169,8 @@ program mk_runofftbl if(lnd<0) in(l) = 1. end do - print *, "area of sphere = ", sum(real(area,kind=8)) - print *, "area of land = ", sum(real(area*in,kind=8)) + print *, "area of sphere = ", sum(real(area,REAL64)) + print *, "area of land = ", sum(real(area*in,REAL64)) close(10) @@ -330,7 +331,7 @@ program mk_runofftbl do j=1,NumTrans Out(DstTile(j)) = Out(DstTile(j)) + In(SrcTile(J))*SrcFraction(J) enddo - print *, "area of land = ", sum(real(area*out,kind=8)) + print *, "area of land = ", sum(real(area*out,REAL64)) print *, "Completed successfully" diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mod_process_hres_data.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mod_process_hres_data.F90 index 5d0ebce60..6300fdebd 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mod_process_hres_data.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mod_process_hres_data.F90 @@ -20,15 +20,16 @@ MODULE process_hres_data - + use MAPL_SortMod use MAPL_ConstantsMod use MAPL_Base, ONLY: MAPL_UNDEF use LDAS_DateTimeMod - + use rmTinyCatchParaMod use lsm_routines, ONLY: sibalb + use LogRectRasterizeMod, ONLY: SRTM_maxcat #if defined USE_EXTERNAL_FINDLOC use findloc_mod, only: findloc @@ -36,17 +37,17 @@ MODULE process_hres_data implicit none - include 'netcdf.inc' - + include 'netcdf.inc' + private - - public :: soil_para_hwsd,hres_lai,hres_gswp2, merge_lai_data, grid2tile_modis6 + + public :: soil_para_hwsd,hres_gswp2, merge_lai_data, grid2tile_modis6 public :: MODIS_snow_alb, MODIS_snow_alb_v2 public :: modis_alb_on_tiles_high,modis_scale_para_high,hres_lai_no_gswp public :: histogram, create_mapping, esa2mosaic , esa2clm public :: grid2tile_ndep_t2m_alb, map_country_codes, get_country_codes public :: CLM45_fixed_parameters, CLM45_clim_parameters, gimms_clim_ndvi, grid2tile_glass, open_landparam_nc4_files - + integer, parameter :: nc_esa = 129600 ! # columns in 10-arcsec GEOS5_10arcsec_mask* file integer, parameter :: nr_esa = 64800 ! # rows in 10-arcsec GEOS5_10arcsec_mask* file @@ -55,47 +56,49 @@ MODULE process_hres_data integer, parameter :: N_GADM = 256 + 1 integer, parameter :: N_STATES = 50 - + real, parameter :: SOILDEPTH_MIN_HWSD = 1334. ! minimum soil depth for HWSD soil parameters - + character*512 :: MAKE_BCS_INPUT_DIR ! structure for remapping high-resolution data to tile space integer, parameter :: N_tiles_per_cell = 9 - + type :: do_regrid integer :: NT ! number of tiles or raster grid cells [??] integer, dimension(N_tiles_per_cell) :: TID ! tile ID [??] integer, dimension(N_tiles_per_cell) :: count ! [??] end type do_regrid - + type, public :: regrid_map integer :: nc_data = 1 integer :: nr_data = 1 integer, dimension(:,:), allocatable :: ij_index type(do_regrid), dimension(:), pointer :: map end type regrid_map - + contains - + ! --------------------------------------------------------------------- ! - - SUBROUTINE ESA2CLM (nc, nr, fnameRst) + + SUBROUTINE ESA2CLM (nc, nr, n_land, tile_lat, tile_pfs, Rst_id) implicit none - integer , intent (in) :: nc, nr - character (*) :: fnameRst - + integer, intent (in) :: nc, nr, n_land + real, intent (in) :: tile_lat(:) + integer, intent (in) :: tile_pfs(:) + integer, intent (in) :: Rst_id(:,:) + integer , parameter :: N_lon_clm = 1152, N_lat_clm = 768, lsmpft = 17 integer*2, allocatable, target, dimension (:,:) :: esa_veg integer*2, pointer , dimension (:,:) :: subset integer , allocatable, dimension (:) :: tile_id, i_esa2clm, j_esa2clm - integer :: i,j, k,n, status, ncid, varid, maxcat, dx,dy, esa_type, tid, cid, ii, jj + integer :: i,j, k,n, status, ncid, varid, dx,dy, esa_type, tid, cid, ii, jj real :: dx_clm, dy_clm, x_min_clm (N_lon_clm), y_min_clm (N_lat_clm), clm_fracs(lsmpft) - real :: minlon,maxlon,minlat,maxlat,tile_lat, scale, ftot + real :: scale, ftot integer :: cpt1, cpt2, cst1, cst2 ! CLM-carbon types real :: cpf1, cpf2, csf1, csf2 ! CLM-carbon fractions DOUBLE PRECISION, allocatable, dimension (:) :: lon_esa, lat_esa @@ -140,26 +143,26 @@ SUBROUTINE ESA2CLM (nc, nr, fnameRst) ! CLM description (17) CatchmentCNCLM description (19) ! -------------------- ------------------------------ - ! 'BARE' 1 bare (does not have bare soil) - ! 'NLEt' 2 needleleaf evergreen temperate tree 1 - ! 'NLEB' 3 needleleaf evergreen boreal tree 2 - ! 'NLDB' 4 needleleaf deciduous boreal tree 3 - ! 'BLET' 5 broadleaf evergreen tropical tree 4 - ! 'BLEt' 6 broadleaf evergreen temperate tree 5 - ! 'BLDT' 7 broadleaf deciduous tropical tree 6 - ! 'BLDt' 8 broadleaf deciduous temperate tree 7 - ! 'BLDB' 9 broadleaf deciduous boreal tree 8 - ! 'BLEtS' 10 broadleaf evergreen temperate shrub 9 - ! 'BLDtS' 11 broadleaf deciduous temperate shrub 10 broadleaf deciduous temperate shrub [moisture + deciduous] - ! 'BLDtSm' broadleaf deciduous temperate shrub 11 broadleaf deciduous temperate shrub [moisture stress only] - ! 'BLDBS' 12 broadleaf deciduous boreal shrub 12 - ! 'AC3G' 13 arctic c3 grass 13 - ! 'CC3G' 14 cool c3 grass 14 cool c3 grass [moisture + deciduous] + ! 'BARE' 1 bare (does not have bare soil) + ! 'NLEt' 2 needleleaf evergreen temperate tree 1 + ! 'NLEB' 3 needleleaf evergreen boreal tree 2 + ! 'NLDB' 4 needleleaf deciduous boreal tree 3 + ! 'BLET' 5 broadleaf evergreen tropical tree 4 + ! 'BLEt' 6 broadleaf evergreen temperate tree 5 + ! 'BLDT' 7 broadleaf deciduous tropical tree 6 + ! 'BLDt' 8 broadleaf deciduous temperate tree 7 + ! 'BLDB' 9 broadleaf deciduous boreal tree 8 + ! 'BLEtS' 10 broadleaf evergreen temperate shrub 9 + ! 'BLDtS' 11 broadleaf deciduous temperate shrub 10 broadleaf deciduous temperate shrub [moisture + deciduous] + ! 'BLDtSm' broadleaf deciduous temperate shrub 11 broadleaf deciduous temperate shrub [moisture stress only] + ! 'BLDBS' 12 broadleaf deciduous boreal shrub 12 + ! 'AC3G' 13 arctic c3 grass 13 + ! 'CC3G' 14 cool c3 grass 14 cool c3 grass [moisture + deciduous] ! 'CC3Gm' cool c3 grass 15 cool c3 grass [moisture stress only] - ! 'WC4G' 15 warm c4 grass 16 - ! 'WC4Gm' warm c4 grass 17 - ! 'CROP' 16 crop 18 crop [moisture + deciduous] - ! 'CROPm' crop 19 crop [moisture stress only] + ! 'WC4G' 15 warm c4 grass 16 + ! 'WC4Gm' warm c4 grass 17 + ! 'CROP' 16 crop 18 crop [moisture + deciduous] + ! 'CROPm' crop 19 crop [moisture stress only] ! 17 water dx_clm = 360./N_lon_clm @@ -190,16 +193,16 @@ SUBROUTINE ESA2CLM (nc, nr, fnameRst) ! if (maxval (clm_fracs) == 100.) then ! clm_veg(i,j,:) = maxloc (clm_fracs) ! else - ! clm_veg(i,j,0) = maxloc (clm_fracs) + ! clm_veg(i,j,0) = maxloc (clm_fracs) ! clm_fracs (clm_veg(i,j,0)) = 0. - ! clm_veg(i,j,1) = maxloc (clm_fracs) + ! clm_veg(i,j,1) = maxloc (clm_fracs) ! endif ! else ! clm_veg(i,j,:) = 17 ! endif ! end do ! end do - + ! Reading ESA vegetation types !----------------------------- @@ -215,8 +218,8 @@ SUBROUTINE ESA2CLM (nc, nr, fnameRst) stop endif - status = NF_GET_VARA_DOUBLE (ncid,1,(/1/),(/nr_esa/),lat_esa) - status = NF_GET_VARA_DOUBLE (ncid,2,(/1/),(/nc_esa/),lon_esa) + status = NF_GET_VARA_DOUBLE (ncid,1,(/1/),(/nr_esa/),lat_esa) + status = NF_GET_VARA_DOUBLE (ncid,2,(/1/),(/nc_esa/),lon_esa) do j = 1,nr_esa status = NF_GET_VARA_INT2 (ncid,3,(/1,j/),(/nc_esa,1/),esa_veg(:,j)) @@ -244,44 +247,31 @@ SUBROUTINE ESA2CLM (nc, nr, fnameRst) where ((real(lat_esa) >= y_min_clm(j)).and.(real(lat_esa) < (y_min_clm(j) + dy_clm))) j_esa2clm= j end do - ! - ! Reading number of tiles - ! ----------------------- - - open (10, file = 'clsm/catchment.def', form = 'formatted', status = 'old', & - action = 'read') - - read (10, *) maxcat - close (10, status = 'keep') - ! ! Loop through tile_id raster ! ___________________________ allocate (tile_id (1:nc )) - allocate (clm_veg (1:maxcat,1:lsmpft)) + allocate (clm_veg (1:n_land,1:lsmpft)) clm_veg = 0. dx = nc_esa / nc dy = nr_esa / nr - open (10,file=trim(fnameRst)//'.rst',status='old',action='read', & - form='unformatted',convert='little_endian') - do j=1,nr - + ! read a row - - read(10)tile_id(:) - + + tile_id(:) = Rst_id(:, j) + do i = 1,nc ii = i_esa2clm ((i-1)*dx + dx/2) jj = j_esa2clm ((j-1)*dy + dy/2) - if((tile_id (i) >= 1).and.(tile_id(i) <= maxcat)) then + if((tile_id (i) >= 1).and.(tile_id(i) <= n_land)) then if (associated (subset)) NULLIFY (subset) subset => esa_veg((i-1)*dx +1 :i*dx, (j-1)*dy +1:j*dy) @@ -297,31 +287,31 @@ SUBROUTINE ESA2CLM (nc, nr, fnameRst) unq_mask(n) = .not.(loc_int(n) == loc_int(n-1)) end do NBINS = count(unq_mask) - + allocate(loc_val (1:NBINS)) allocate(density (1:NBINS)) loc_val = 1.*pack(loc_int,mask =unq_mask) call histogram (size(subset,1)*size(subset,2), NBINS, density, loc_val, real(subset)) - + do k = 1, nbins - + if (density (k) > 0) then - + esa_type = int (loc_val(k)) - + ! if (esa_type == 10) clm_veg (tile_id(i), 17) = 1.* density(k) ! lakes inland water - + if (esa_type == 11) clm_veg (tile_id(i), 16) = clm_veg (tile_id(i), 16) + 1.* density(k) ! ESA type 11: Post-flooding or irrigated croplands if (esa_type == 14) clm_veg (tile_id(i), 16) = clm_veg (tile_id(i), 16) + 1.* density(k) ! ESA type 14: Rainfed croplands if (esa_type == 20) clm_veg (tile_id(i), 16) = clm_veg (tile_id(i), 16) + 1.* density(k) ! ESA type 20: Mosaic Cropland (50-70%) / Vegetation (grassland, shrubland, forest) (20-50%) - if (esa_type == 190) clm_veg (tile_id(i), 16) = clm_veg (tile_id(i), 16) + 1.* density(k) ! ESA type 190: Artificial surfaces and associated areas (urban areas >50%) - - ! if (esa_type == 200) clm_veg (tile_id(i), 11) = clm_veg (tile_id(i), 11) + 1.* density(k) ! ESA type 200: Bare areas + if (esa_type == 190) clm_veg (tile_id(i), 16) = clm_veg (tile_id(i), 16) + 1.* density(k) ! ESA type 190: Artificial surfaces and associated areas (urban areas >50%) + + ! if (esa_type == 200) clm_veg (tile_id(i), 11) = clm_veg (tile_id(i), 11) + 1.* density(k) ! ESA type 200: Bare areas ! if (esa_type == 210) clm_veg (tile_id(i), 17) = clm_veg (tile_id(i), 17) + 1.* density(k) ! ocean ! if (esa_type == 220) clm_veg (tile_id(i), 17) = clm_veg (tile_id(i), 17) + 1.* density(k) ! ice ! gkw: bare soil excluded! only considering vegetated land ! ----------------------------------------------------------------------------------------------------------------------------------------- - + if (esa_type == 30) then ! ESA type 30: Mosaic Vegetation (grassland, shrubland, forest) (50-70%) / Cropland (20-50%) clm_veg (tile_id(i), 16) = clm_veg (tile_id(i), 16) + 0.5* density(k) @@ -333,12 +323,12 @@ SUBROUTINE ESA2CLM (nc, nr, fnameRst) clm_veg (tile_id(i), 16) = clm_veg (tile_id(i), 16) + 1.0* density(k) endif endif - + ! ----------------------------------------------------------------------------------------------------------------------------------------- - + if (esa_type == 40) then - ! ESA type 40: Closed to open (>15%) broadleaved evergreen and/or semi-deciduous forest (>5m) - + ! ESA type 40: Closed to open (>15%) broadleaved evergreen and/or semi-deciduous forest (>5m) + if(sum(PCTPFT(ii,jj,5:6)) > 0.) then do n = 5, 6 clm_veg (tile_id(i), n) = clm_veg (tile_id(i), n) + 1.*density(k)*(PCTPFT(ii,jj,n))/sum(PCTPFT(ii,jj,5:6)) @@ -351,13 +341,13 @@ SUBROUTINE ESA2CLM (nc, nr, fnameRst) endif endif endif - + ! ----------------------------------------------------------------------------------------------------------------------------------------- - + if ((esa_type == 50) .or. (esa_type == 60)) then - ! ESA type 50: Closed (>40%) broadleaved deciduous forest (>5m) - ! ESA type 60: Open (15-40%) broadleaved deciduous forest (>5m) - + ! ESA type 50: Closed (>40%) broadleaved deciduous forest (>5m) + ! ESA type 60: Open (15-40%) broadleaved deciduous forest (>5m) + if(sum(PCTPFT(ii,jj,7:9)) > 0.) then do n = 7, 9 clm_veg (tile_id(i), n) = clm_veg (tile_id(i), n) + density(k)*(PCTPFT(ii,jj,n))/sum(PCTPFT(ii,jj,7:9)) @@ -371,30 +361,30 @@ SUBROUTINE ESA2CLM (nc, nr, fnameRst) end if end if endif - + ! ----------------------------------------------------------------------------------------------------------------------------------------- - + if (esa_type == 70) then - ! ESA type 70: Closed (>40%) needleleaved evergreen forest (>5m) - + ! ESA type 70: Closed (>40%) needleleaved evergreen forest (>5m) + if(sum(PCTPFT(ii,jj,2:3)) > 0.) then do n = 2, 3 - clm_veg (tile_id(i), n) = clm_veg (tile_id(i), n) + density(k)*(PCTPFT(ii,jj,n))/sum(PCTPFT(ii,jj,2:3)) + clm_veg (tile_id(i), n) = clm_veg (tile_id(i), n) + density(k)*(PCTPFT(ii,jj,n))/sum(PCTPFT(ii,jj,2:3)) enddo else if(abs(y_min_clm(jj) + 0.5*dy_clm) < 60.) then clm_veg (tile_id(i), 2) = clm_veg (tile_id(i), 2) + 1.0* density(k) - else - clm_veg (tile_id(i), 3) = clm_veg (tile_id(i), 3) + 1.0* density(k) + else + clm_veg (tile_id(i), 3) = clm_veg (tile_id(i), 3) + 1.0* density(k) end if end if endif - + ! ----------------------------------------------------------------------------------------------------------------------------------------- - + if (esa_type == 90) then - !ESA type 90: Open (15-40%) needleleaved deciduous or evergreen forest (>5m) - + !ESA type 90: Open (15-40%) needleleaved deciduous or evergreen forest (>5m) + if(sum(PCTPFT(ii,jj,2:4)) > 0.) then do n = 2, 4 clm_veg (tile_id(i), n) = clm_veg (tile_id(i), n) + 1.*density(k)*(PCTPFT(ii,jj,n))/sum(PCTPFT(ii,jj,2:4)) @@ -402,40 +392,40 @@ SUBROUTINE ESA2CLM (nc, nr, fnameRst) else if(abs(y_min_clm(jj) + 0.5*dy_clm) < 60.) then clm_veg (tile_id(i), 2) = clm_veg (tile_id(i), 2) + 1.0* density(k) - else - clm_veg (tile_id(i), 3) = clm_veg (tile_id(i), 3) + 1.0* density(k) + else + clm_veg (tile_id(i), 3) = clm_veg (tile_id(i), 3) + 1.0* density(k) end if end if endif - + ! ----------------------------------------------------------------------------------------------------------------------------------------- - + if (esa_type == 100) then - ! ESA type 100: Closed to open (>15%) mixed broadleaved and needleleaved forest (>5m) - + ! ESA type 100: Closed to open (>15%) mixed broadleaved and needleleaved forest (>5m) + if((sum(PCTPFT(ii,jj,2:4)) + sum(PCTPFT(ii,jj,7:9))) > 0.) then do n = 2, 9 - if((n /= 5) .and. (n /= 6)) clm_veg (tile_id(i), n) = clm_veg (tile_id(i), n) + density(k)*(PCTPFT(ii,jj,n))/(sum(PCTPFT(ii,jj,2:4)) + sum(PCTPFT(ii,jj,7:9))) + if((n /= 5) .and. (n /= 6)) clm_veg (tile_id(i), n) = clm_veg (tile_id(i), n) + density(k)*(PCTPFT(ii,jj,n))/(sum(PCTPFT(ii,jj,2:4)) + sum(PCTPFT(ii,jj,7:9))) enddo else if(abs(y_min_clm(jj) + 0.5*dy_clm) < 23.5) then clm_veg (tile_id(i), 7) = clm_veg (tile_id(i), 7) + 0.5* density(k) - clm_veg (tile_id(i), 2) = clm_veg (tile_id(i), 2) + 0.5* density(k) + clm_veg (tile_id(i), 2) = clm_veg (tile_id(i), 2) + 0.5* density(k) elseif (abs(y_min_clm(jj) + 0.5*dy_clm) < 60.) then clm_veg (tile_id(i), 8) = clm_veg (tile_id(i), 8) + 0.5* density(k) clm_veg (tile_id(i), 2) = clm_veg (tile_id(i), 2) + 0.5* density(k) else clm_veg (tile_id(i), 9) = clm_veg (tile_id(i), 9) + 0.5* density(k) - clm_veg (tile_id(i), 3) = clm_veg (tile_id(i), 3) + 0.5* density(k) + clm_veg (tile_id(i), 3) = clm_veg (tile_id(i), 3) + 0.5* density(k) end if end if endif - + ! ----------------------------------------------------------------------------------------------------------------------------------------- - + if (esa_type == 110) then - ! ESA type 110: Mosaic Forest/Shrubland (50-70%) / Grassland (20-50%) - + ! ESA type 110: Mosaic Forest/Shrubland (50-70%) / Grassland (20-50%) + if(sum(PCTPFT(ii,jj,7:12)) > 0.) then do n = 7, 12 clm_veg (tile_id(i), n) = clm_veg (tile_id(i), n) + 0.6*density(k)*(PCTPFT(ii,jj,n))/sum(PCTPFT(ii,jj,7:12)) @@ -443,16 +433,16 @@ SUBROUTINE ESA2CLM (nc, nr, fnameRst) else if(abs(y_min_clm(jj) + 0.5*dy_clm) < 23.5) then clm_veg (tile_id(i), 7) = clm_veg (tile_id(i), 7) + 0.3* density(k) - clm_veg (tile_id(i), 11) = clm_veg (tile_id(i), 11) + 0.3* density(k) + clm_veg (tile_id(i), 11) = clm_veg (tile_id(i), 11) + 0.3* density(k) else if (abs(y_min_clm(jj) + 0.5*dy_clm) < 60.) then clm_veg (tile_id(i), 8) = clm_veg (tile_id(i), 8) + 0.3* density(k) clm_veg (tile_id(i), 11) = clm_veg (tile_id(i), 11) + 0.3* density(k) else clm_veg (tile_id(i), 9) = clm_veg (tile_id(i), 9) + 0.3* density(k) - clm_veg (tile_id(i), 12) = clm_veg (tile_id(i), 12) + 0.3* density(k) + clm_veg (tile_id(i), 12) = clm_veg (tile_id(i), 12) + 0.3* density(k) end if end if - + if(sum(PCTPFT(ii,jj,13:15)) > 0.) then do n =13, 15 clm_veg (tile_id(i), n) = clm_veg (tile_id(i), n) + 0.4*density(k)*(PCTPFT(ii,jj,n))/sum(PCTPFT(ii,jj,13:15)) @@ -467,12 +457,12 @@ SUBROUTINE ESA2CLM (nc, nr, fnameRst) end if end if endif - + ! ----------------------------------------------------------------------------------------------------------------------------------------- if (esa_type == 120) then - ! ESA type 120: Mosaic Grassland (50-70%) / Forest/Shrubland (20-50%) - + ! ESA type 120: Mosaic Grassland (50-70%) / Forest/Shrubland (20-50%) + if(sum(PCTPFT(ii,jj,7:12)) > 0.) then do n = 7, 12 clm_veg (tile_id(i), n) = clm_veg (tile_id(i), n) + 0.4*density(k)*(PCTPFT(ii,jj,n))/sum(PCTPFT(ii,jj,7:12)) @@ -480,16 +470,16 @@ SUBROUTINE ESA2CLM (nc, nr, fnameRst) else if(abs(y_min_clm(jj) + 0.5*dy_clm) < 23.5) then clm_veg (tile_id(i), 7) = clm_veg (tile_id(i), 7) + 0.2* density(k) - clm_veg (tile_id(i), 11) = clm_veg (tile_id(i), 11) + 0.2* density(k) + clm_veg (tile_id(i), 11) = clm_veg (tile_id(i), 11) + 0.2* density(k) else if (abs(y_min_clm(jj) + 0.5*dy_clm) < 60.) then clm_veg (tile_id(i), 8) = clm_veg (tile_id(i), 8) + 0.2* density(k) clm_veg (tile_id(i), 11) = clm_veg (tile_id(i), 11) + 0.2* density(k) else clm_veg (tile_id(i), 9) = clm_veg (tile_id(i), 9) + 0.2* density(k) - clm_veg (tile_id(i), 12) = clm_veg (tile_id(i), 12) + 0.2* density(k) + clm_veg (tile_id(i), 12) = clm_veg (tile_id(i), 12) + 0.2* density(k) end if end if - + if(sum(PCTPFT(ii,jj,13:15)) > 0.) then do n =13, 15 clm_veg (tile_id(i), n) = clm_veg (tile_id(i), n) + 0.6*density(k)*(PCTPFT(ii,jj,n))/sum(PCTPFT(ii,jj,13:15)) @@ -504,12 +494,12 @@ SUBROUTINE ESA2CLM (nc, nr, fnameRst) end if end if endif - + ! ----------------------------------------------------------------------------------------------------------------------------------------- - + if (esa_type == 130) then - ! Closed to open (>15%) shrubland (<5m) - + ! Closed to open (>15%) shrubland (<5m) + if(sum(PCTPFT(ii,jj,10:12)) > 0.) then do n = 10,12 clm_veg (tile_id(i), n) = clm_veg (tile_id(i), n) + 1.*density(k)*(PCTPFT(ii,jj,n))/sum(PCTPFT(ii,jj,10:12)) @@ -517,17 +507,17 @@ SUBROUTINE ESA2CLM (nc, nr, fnameRst) else if(abs(y_min_clm(jj) + 0.5*dy_clm) < 60.) then clm_veg (tile_id(i), 11) = clm_veg (tile_id(i), 11) + 1.0* density(k) - else - clm_veg (tile_id(i), 12) = clm_veg (tile_id(i), 12) + 1.0* density(k) + else + clm_veg (tile_id(i), 12) = clm_veg (tile_id(i), 12) + 1.0* density(k) end if end if endif - + ! ----------------------------------------------------------------------------------------------------------------------------------------- - + if (esa_type == 140) then - ! ESA type 140: Closed to open (>15%) grassland - + ! ESA type 140: Closed to open (>15%) grassland + if(sum(PCTPFT(ii,jj,13:15)) > 0.) then do n = 13,15 clm_veg (tile_id(i), n) = clm_veg (tile_id(i), n) + 1.*density(k)*(PCTPFT(ii,jj,n))/sum(PCTPFT(ii,jj,13:15)) @@ -535,19 +525,19 @@ SUBROUTINE ESA2CLM (nc, nr, fnameRst) else if(abs(y_min_clm(jj) + 0.5*dy_clm) < 30.) then clm_veg (tile_id(i), 15) = clm_veg (tile_id(i), 15) + 1.0* density(k) - else if (abs(y_min_clm(jj) + 0.5*dy_clm) < 55.) then - clm_veg (tile_id(i), 14) = clm_veg (tile_id(i), 14) + 1.0* density(k) - else - clm_veg (tile_id(i), 13) = clm_veg (tile_id(i), 13) + 1.0* density(k) + else if (abs(y_min_clm(jj) + 0.5*dy_clm) < 55.) then + clm_veg (tile_id(i), 14) = clm_veg (tile_id(i), 14) + 1.0* density(k) + else + clm_veg (tile_id(i), 13) = clm_veg (tile_id(i), 13) + 1.0* density(k) end if end if end if - + ! ----------------------------------------------------------------------------------------------------------------------------------------- - + if (esa_type == 150) then - ! ESA type 150: Sparse (<15%) vegetation (woody vegetation, shrubs, grassland) - + ! ESA type 150: Sparse (<15%) vegetation (woody vegetation, shrubs, grassland) + if(sum(PCTPFT(ii,jj,10:15)) > 0.) then do n = 10, 15 clm_veg (tile_id(i), n) = clm_veg (tile_id(i), n) + 1.0*density(k)*(PCTPFT(ii,jj,n))/sum(PCTPFT(ii,jj,10:15)) @@ -555,22 +545,22 @@ SUBROUTINE ESA2CLM (nc, nr, fnameRst) else if(abs(y_min_clm(jj) + 0.5*dy_clm) < 30.) then clm_veg (tile_id(i), 14) = clm_veg (tile_id(i), 14) + 0.5* density(k) - clm_veg (tile_id(i), 11) = clm_veg (tile_id(i), 11) + 0.5* density(k) + clm_veg (tile_id(i), 11) = clm_veg (tile_id(i), 11) + 0.5* density(k) else if (abs(y_min_clm(jj) + 0.5*dy_clm) < 55.) then clm_veg (tile_id(i), 14) = clm_veg (tile_id(i), 14) + 0.5* density(k) clm_veg (tile_id(i), 11) = clm_veg (tile_id(i), 11) + 0.5* density(k) else clm_veg (tile_id(i), 13) = clm_veg (tile_id(i), 13) + 0.5* density(k) - clm_veg (tile_id(i), 12) = clm_veg (tile_id(i), 12) + 0.5* density(k) + clm_veg (tile_id(i), 12) = clm_veg (tile_id(i), 12) + 0.5* density(k) end if end if endif - + ! ----------------------------------------------------------------------------------------------------------------------------------------- - + if((esa_type == 160) .or. (esa_type == 170)) then - ! ESA type 160: Closed (>40%) broadleaved forest regularly flooded - Fresh water ! ESA type 170: Closed (>40%) broadleaved semi-deciduous and/or evergreen forest regularly flooded - + ! ESA type 160: Closed (>40%) broadleaved forest regularly flooded - Fresh water ! ESA type 170: Closed (>40%) broadleaved semi-deciduous and/or evergreen forest regularly flooded + if(sum(PCTPFT(ii,jj,5:9)) > 0.) then do n = 5,9 clm_veg (tile_id(i), n) = clm_veg (tile_id(i), n) + 1.*density(k)*(PCTPFT(ii,jj,n))/sum(PCTPFT(ii,jj,5:9)) @@ -579,29 +569,29 @@ SUBROUTINE ESA2CLM (nc, nr, fnameRst) if(abs(y_min_clm(jj) + 0.5*dy_clm) < 23.5) then clm_veg (tile_id(i), 5) = clm_veg (tile_id(i), 5) + 1.0* density(k) else if (abs(y_min_clm(jj) + 0.5*dy_clm) < 60.) then - clm_veg (tile_id(i), 8) = clm_veg (tile_id(i), 8) + 1.0* density(k) - else - clm_veg (tile_id(i), 9) = clm_veg (tile_id(i), 9) + 1.0* density(k) + clm_veg (tile_id(i), 8) = clm_veg (tile_id(i), 8) + 1.0* density(k) + else + clm_veg (tile_id(i), 9) = clm_veg (tile_id(i), 9) + 1.0* density(k) end if end if endif - + ! ----------------------------------------------------------------------------------------------------------------------------------------- - + if (esa_type == 180) then - ! ESA type 180: Closed to open (>15%) vegetation (grassland, shrubland, woody vegetation) on regularly flooded or waterlogged soil - Fresh, brackish or saline water - + ! ESA type 180: Closed to open (>15%) vegetation (grassland, shrubland, woody vegetation) on regularly flooded or waterlogged soil - Fresh, brackish or saline water + if(sum(PCTPFT(ii,jj,10:15)) > 0.) then do n = 10,15 - clm_veg (tile_id(i), n) = clm_veg (tile_id(i), n) + 1.*density(k)*(PCTPFT(ii,jj,n))/sum(PCTPFT(ii,jj,10:15)) + clm_veg (tile_id(i), n) = clm_veg (tile_id(i), n) + 1.*density(k)*(PCTPFT(ii,jj,n))/sum(PCTPFT(ii,jj,10:15)) enddo else if(abs(y_min_clm(jj) + 0.5*dy_clm) < 30.) then clm_veg (tile_id(i), 15) = clm_veg (tile_id(i), 15) + 1.0* density(k) else if (abs(y_min_clm(jj) + 0.5*dy_clm) < 55.) then - clm_veg (tile_id(i), 14) = clm_veg (tile_id(i), 14) + 1.0* density(k) - else - clm_veg (tile_id(i), 13) = clm_veg (tile_id(i), 13) + 1.0* density(k) + clm_veg (tile_id(i), 14) = clm_veg (tile_id(i), 14) + 1.0* density(k) + else + clm_veg (tile_id(i), 13) = clm_veg (tile_id(i), 13) + 1.0* density(k) end if end if endif @@ -612,10 +602,9 @@ SUBROUTINE ESA2CLM (nc, nr, fnameRst) end if enddo end do - - + + deallocate (tile_id, PCTPFT,esa_veg,lon_esa,lat_esa,i_esa2clm,j_esa2clm) - close (10,status='keep') ! ! Now create CLM-carbon_veg_fracs file @@ -623,30 +612,24 @@ SUBROUTINE ESA2CLM (nc, nr, fnameRst) open (10,file='clsm/CLM_veg_typs_fracs', & form='formatted',status='unknown') - open (11, file = 'clsm/catchment.def', form = 'formatted', status = 'old', & - action = 'read') - - read (11, *) maxcat inquire(file='clsm/catchcn_params.nc4', exist=file_exists) if(file_exists) then status = NF_OPEN ('clsm/catchcn_params.nc4', NF_WRITE, ncid) ; VERIFY_(STATUS) - allocate (NITYP (1:MAXCAT, 1:4)) - allocate (NFVEG (1:MAXCAT, 1:4)) + allocate (NITYP (1:n_land, 1:4)) + allocate (NFVEG (1:n_land, 1:4)) endif - do k = 1, maxcat + do k = 1, n_land - read (11,'(i10,i8,5(2x,f9.4))') tid,cid,minlon,maxlon,minlat,maxlat - tile_lat = (minlat + maxlat)/2. - scale = (ABS (tile_lat) - 32.)/10. + scale = (ABS (tile_lat(k)) - 32.)/10. scale = min (max(scale,0.),1.) esa_clm_veg = 0 esa_clm_frac= 0. clm_fracs = clm_veg (k,:) - + if (sum (clm_fracs) == 0.) then ! gkw: no vegetated land found; set to BLDtS esa_clm_veg (1) = 11 ! broadleaf deciduous shrub esa_clm_frac(1) = 100. @@ -667,12 +650,12 @@ SUBROUTINE ESA2CLM (nc, nr, fnameRst) esa_clm_frac(2) = 100. - esa_clm_frac(1) end if -! Now splitting CLM types for CNCLM model -! -------------------------------------------- - -! CLM types 2- 10,12,13 are not being split. -! ............................................. - + ! Now splitting CLM types for CNCLM model + ! -------------------------------------------- + + ! CLM types 2- 10,12,13 are not being split. + ! ............................................. + if ((esa_clm_veg (1) >= 2).and.(esa_clm_veg (1) <= 10)) then CPT1 = esa_clm_veg (1) - 1 CPT2 = esa_clm_veg (1) - 1 @@ -687,7 +670,7 @@ SUBROUTINE ESA2CLM (nc, nr, fnameRst) CSF2 = 0. endif -! ............................................. + ! ............................................. if ((esa_clm_veg (1) >= 12).and.(esa_clm_veg (1) <= 13)) then CPT1 = esa_clm_veg (1) @@ -703,8 +686,8 @@ SUBROUTINE ESA2CLM (nc, nr, fnameRst) CSF2 = 0. endif -! Now splitting -! ............. + ! Now splitting + ! ............. if (esa_clm_veg (1) == 11) then CPT1 = 10 @@ -720,7 +703,7 @@ SUBROUTINE ESA2CLM (nc, nr, fnameRst) CSF2 = esa_clm_frac(2) * (1. - scale) endif -! ............. + ! ............. if (esa_clm_veg (1) == 14) then CPT1 = 14 @@ -736,7 +719,7 @@ SUBROUTINE ESA2CLM (nc, nr, fnameRst) CSF2 = esa_clm_frac(2) * (1. - scale) endif -! ............. + ! ............. if (esa_clm_veg (1) == 15) then CPT1 = 16 @@ -751,7 +734,7 @@ SUBROUTINE ESA2CLM (nc, nr, fnameRst) CSF1 = esa_clm_frac(2) * scale CSF2 = esa_clm_frac(2) * (1. - scale) endif -! ............. + ! ............. if (esa_clm_veg (1) == 16) then CPT1 = 18 @@ -777,9 +760,9 @@ SUBROUTINE ESA2CLM (nc, nr, fnameRst) csf1 = 100. * csf1 / ftot csf2 = 100. * csf2 / ftot endif - + write (10,'(2I10,4I3,4f7.2,2I3,2f7.2)') & - tid,cid,cpt1, cpt2, cst1, cst2, cpf1, cpf2, csf1, csf2, & + k, tile_pfs(k), cpt1, cpt2, cst1, cst2, cpf1, cpf2, csf1, csf2, & esa_clm_veg (1), esa_clm_veg (2), esa_clm_frac(1), esa_clm_frac(2) if (allocated (NITYP)) NITYP (k, :) = (/REAL(cpt1), REAL(cpt2), REAL(cst1), REAL(cst2)/) @@ -789,37 +772,37 @@ SUBROUTINE ESA2CLM (nc, nr, fnameRst) if(file_exists) then - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ITY' ) ,(/1,1/),(/maxcat,1/), NITYP (:, 1)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ITY' ) ,(/1,2/),(/maxcat,1/), NITYP (:, 2)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ITY' ) ,(/1,3/),(/maxcat,1/), NITYP (:, 3)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ITY' ) ,(/1,4/),(/maxcat,1/), NITYP (:, 4)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'FVG' ) ,(/1,1/),(/maxcat,1/), NFVEG (:, 1)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'FVG' ) ,(/1,2/),(/maxcat,1/), NFVEG (:, 2)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'FVG' ) ,(/1,3/),(/maxcat,1/), NFVEG (:, 3)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'FVG' ) ,(/1,4/),(/maxcat,1/), NFVEG (:, 4)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ITY' ) ,(/1,1/),(/n_land,1/), NITYP (:, 1)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ITY' ) ,(/1,2/),(/n_land,1/), NITYP (:, 2)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ITY' ) ,(/1,3/),(/n_land,1/), NITYP (:, 3)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ITY' ) ,(/1,4/),(/n_land,1/), NITYP (:, 4)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'FVG' ) ,(/1,1/),(/n_land,1/), NFVEG (:, 1)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'FVG' ) ,(/1,2/),(/n_land,1/), NFVEG (:, 2)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'FVG' ) ,(/1,3/),(/n_land,1/), NFVEG (:, 3)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'FVG' ) ,(/1,4/),(/n_land,1/), NFVEG (:, 4)) ; VERIFY_(STATUS) DEALLOCATE (NITYP, NFVEG) STATUS = NF_CLOSE (NCID) ; VERIFY_(STATUS) - + endif - + close (10, status = 'keep') - close (11, status = 'keep') END SUBROUTINE ESA2CLM -! -! --------------------------------------------------------------------- -! - SUBROUTINE ESA2MOSAIC (nc, nr, fnameRst) - + ! + ! --------------------------------------------------------------------- + ! + SUBROUTINE ESA2MOSAIC (nc, nr, n_land, tile_pfs, rst_id) + implicit none - integer , intent (in) :: nc, nr - character (*) :: fnameRst + integer, intent(in) :: nc, nr, n_land + integer, intent(in) :: tile_pfs(:) + integer, intent(in) :: rst_id(:,:) !integer , parameter :: nc_esa = 129600, nr_esa = 64800 integer*2, allocatable, target, dimension (:,:) :: esa_veg integer*2, pointer , dimension (:,:) :: subset integer , allocatable, dimension (:) :: tile_id, ityp - integer :: i,j, k, status, ncid, maxcat, dx,dy, esa_type, tid, cid + integer :: i,j, k, status, ncid, dx,dy, esa_type integer :: mos1, mos2 real :: mfrac, sfrac, tfrac, tem (6) integer, allocatable, dimension (:) :: density, loc_int @@ -855,62 +838,48 @@ SUBROUTINE ESA2MOSAIC (nc, nr, fnameRst) end do status = NF_CLOSE(ncid) -! -! Reading number of tiles -! ----------------------- - - open (10, file = 'clsm/catchment.def', form = 'formatted', status = 'old', & - action = 'read') - - read (10, *) maxcat - - close (10, status = 'keep') - -! -! Loop through tile_id raster -! ___________________________ + ! + ! Loop through tile_id raster + ! ___________________________ allocate (tile_id (1:nc)) - allocate(veg(1:maxcat,1:6)) + allocate(veg(1:n_land,1:6)) veg = 0. dx = nc_esa / nc dy = nr_esa / nr - open (10,file=trim(fnameRst)//'.rst',status='old',action='read', & - form='unformatted',convert='little_endian') - do j=1,nr ! read a row - read(10)tile_id(:) + tile_id(:) = rst_id(:,j) do i = 1,nc - if((tile_id (i) >= 1).and.(tile_id(i) <= maxcat)) then + if((tile_id (i) >= 1).and.(tile_id(i) <= n_land)) then if (associated (subset)) NULLIFY (subset) subset => esa_veg((i-1)*dx +1 :i*dx, (j-1)*dy +1:j*dy) - + NPLUS = count(subset >= 1 .and. subset <= 230) - + if(NPLUS > 0) then allocate (loc_int (1:NPLUS)) allocate (unq_mask(1:NPLUS)) loc_int = pack(subset,mask = (subset >= 1 .and. subset <= 230)) call MAPL_Sort (loc_int) unq_mask = .true. - + do k = 2,NPLUS unq_mask(k) = .not.(loc_int(k) == loc_int(k-1)) end do NBINS = count(unq_mask) - + allocate(loc_val (1:NBINS)) allocate(density (1:NBINS)) loc_val = 1.*pack(loc_int,mask =unq_mask) call histogram (size(subset,1)*size(subset,2), NBINS, density, loc_val, real(subset)) - + do k = 1, nbins if (density (k) > 0) then @@ -936,7 +905,7 @@ SUBROUTINE ESA2MOSAIC (nc, nr, fnameRst) if (esa_type == 120) veg (tile_id(i), 4) = veg (tile_id(i), 4) + 0.6* density (k) if (esa_type == 130) veg (tile_id(i), 5) = veg (tile_id(i), 5) + 1.* density (k) if (esa_type == 140) veg (tile_id(i), 4) = veg (tile_id(i), 4) + 1.* density (k) - + if((j > NINT(real(nr)*(40./180.))).and.(j < NINT(real(nr)*(140./180.)))) then if (esa_type == 150) veg (tile_id(i),5) = veg (tile_id(i),5) + 0.5* density (k) if (esa_type == 150) veg (tile_id(i),4) = veg (tile_id(i),4) + 0.5* density (k) @@ -944,13 +913,13 @@ SUBROUTINE ESA2MOSAIC (nc, nr, fnameRst) if (esa_type == 150) veg (tile_id(i),6) = veg (tile_id(i),6) + 0.5* density (k) if (esa_type == 150) veg (tile_id(i),4) = veg (tile_id(i),4) + 0.5* density (k) end if - + if((j > NINT(real(nr)*(70./180.))).and.(j < NINT(real(nr)*(110./180.)))) then if (esa_type == 160) veg (tile_id(i), 1) = veg (tile_id(i), 1) + 1.* density (k) else if (esa_type == 160) veg (tile_id(i), 2) = veg (tile_id(i), 2) + 1.* density (k) end if - + if (esa_type == 170) veg (tile_id(i), 1) = veg (tile_id(i), 1) + 1.* density (k) if (esa_type == 180) veg (tile_id(i), 4) = veg (tile_id(i), 4) + 1.* density (k) if (esa_type == 190) veg (tile_id(i), 4) = veg (tile_id(i), 4) + 1.* density (k) @@ -968,33 +937,26 @@ SUBROUTINE ESA2MOSAIC (nc, nr, fnameRst) end do deallocate (tile_id) - close (10,status='keep') -! Canopy height and ASCAT roughness length + ! Canopy height and ASCAT roughness length - call ascat_r0 (nc,nr,fnameRst, z0) + call ascat_r0 (nc,nr, n_land, Rst_id, z0) if(jpl_height) then - call jpl_canoph (nc,nr,fnameRst, z2) + call jpl_canoph (nc,nr, n_land, Rst_id, z2) else - allocate (z2(1:maxcat)) + allocate (z2(1:n_land)) endif -! -! Now create mosaic_veg_fracs file -! -------------------------------- + ! + ! Now create mosaic_veg_fracs file + ! -------------------------------- - allocate (ityp (1:maxcat)) + allocate (ityp (1:n_land)) open (10,file='clsm/mosaic_veg_typs_fracs', & form='formatted',status='unknown') - open (11, file = 'clsm/catchment.def', form = 'formatted', status = 'old', & - action = 'read') - - read (11, *) maxcat - - do k = 1, maxcat - - read (11,'(i10,i8,5(2x,f9.4))') tid,cid + + do k = 1, n_land tem = 0. tem(1:6)=veg (k,1:6) @@ -1016,7 +978,7 @@ SUBROUTINE ESA2MOSAIC (nc, nr, fnameRst) sfrac = tem(i) mos2 = i endif - endif + endif end do mfrac = max (mfrac,0.) @@ -1036,29 +998,28 @@ SUBROUTINE ESA2MOSAIC (nc, nr, fnameRst) if(.not.jpl_height) z2(k) = VGZ2(mos1) ityp (k) = mos1 write (10,'(i10,i8,2(2x,i3),2(2x,f6.2),2x,f6.3,2x,f10.7)') & - tid,cid,mos1,mos2,100.*mfrac,100.*sfrac, z2(k), z0 (k) - + k, tile_pfs(k) ,mos1,mos2,100.*mfrac,100.*sfrac, z2(k), z0 (k) + endif end do close (10,status='keep') - close (11,status='keep') inquire(file='clsm/catch_params.nc4', exist=file_exists) if(file_exists) then status = NF_OPEN ('clsm/catch_params.nc4', NF_WRITE, ncid ) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'OLD_ITY' ) ,(/1/),(/maxcat/), real(ityp)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'OLD_ITY' ) ,(/1/),(/n_land/), real(ityp)) ; VERIFY_(STATUS) STATUS = NF_CLOSE (NCID) ; VERIFY_(STATUS) endif - + inquire(file='clsm/vegdyn.data', exist=file_exists) if(file_exists) then status = NF_OPEN ('clsm/vegdyn.data', NF_WRITE, ncid ) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ITY' ) ,(/1/),(/maxcat/), real(ityp)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'Z2CH' ) ,(/1/),(/maxcat/), z2 ) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ASCATZ0') ,(/1/),(/maxcat/), Z0 ) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ITY' ) ,(/1/),(/n_land/), real(ityp)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'Z2CH' ) ,(/1/),(/n_land/), z2 ) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ASCATZ0') ,(/1/),(/n_land/), Z0 ) ; VERIFY_(STATUS) STATUS = NF_CLOSE (NCID) ; VERIFY_(STATUS) else open (20,file='clsm/vegdyn.data',status='unknown',action='write',form='unformatted', & @@ -1067,19 +1028,19 @@ SUBROUTINE ESA2MOSAIC (nc, nr, fnameRst) write (20) z2 (:) write (20) z0 (:) close (20) - endif - - deallocate (veg, z0, z2, ityp) - + endif + + deallocate (veg, z0, z2, ityp) + END SUBROUTINE ESA2MOSAIC -! -!---------------------------------------------------------------------- -! + ! + !---------------------------------------------------------------------- + ! SUBROUTINE HISTOGRAM (NLENS, NBINS, density, loc_val, x, BIN) - + ! intent: in in out inout in in - + ! assemble histogram of x ! ! if optional input argument "bin" is not present, return only density @@ -1087,25 +1048,25 @@ SUBROUTINE HISTOGRAM (NLENS, NBINS, density, loc_val, x, BIN) ! NOTE: When the underlying data are integer (as, e.g., when histogram() is used ! in subroutine create_mapping()), the use of this subroutine and how it is ! implemented is highly questionable. - + implicit none - + integer, intent(in) :: NBINS ! # bins integer, intent(in) :: NLENS ! # data - + real, dimension(NLENS), intent(in) :: x ! data integer, dimension(NBINS), intent(out) :: density ! hist value real, dimension(NBINS), intent(inout) :: loc_val ! lower boundary of bin real, intent(in), optional :: bin ! bin size ("delta_x") - + ! -------------------------------------------------------------- - + real :: xdum(NLENS), xl, xu, min_value integer :: n - + if (present(bin)) min_value = real(floor(minval(x))) - + DO N=1,NBINS if(present(bin)) then xl = (N - 1)*BIN + min_value @@ -1119,303 +1080,287 @@ SUBROUTINE HISTOGRAM (NLENS, NBINS, density, loc_val, x, BIN) endif density(n) = int(sum(XDUM)) END DO - + END SUBROUTINE HISTOGRAM -! -!---------------------------------------------------------------------- -! + ! + !---------------------------------------------------------------------- + ! - SUBROUTINE create_mapping( nc, nr, nc_data, nr_data, rmap, fnameRst ) - - ! assemble "rmap" structure that can be used for remapping 2-dim gridded - ! science data (nc_data-by-nr_data) to *land* tiles, which are defined - ! on a 2-dim raster grid (nc-by-nr) - - implicit none - - integer, intent(in) :: nc, nr ! dims of raster array (with tile IDs) - integer, intent(in) :: nc_data, nr_data ! dims of science data array - type(regrid_map), intent(inout) :: rmap ! structure for remapping - character(*), intent(in) :: fnameRst ! name of raster (*.rst) file - - ! ----------------------- - - integer :: i, j, n, i1, i2, j1, j2, ncatch, nbins, status, NPLUS, pix_count - - REAL, allocatable, DIMENSION(:) :: loc_val - INTEGER, ALLOCATABLE, DIMENSION(:) :: density, loc_int - logical, allocatable, dimension(:) :: unq_mask - integer, allocatable, dimension(:,:), target :: tile_id - integer, dimension(:,:), pointer :: subset, iraster - - real :: dx_data, dy_data, dx_rst, dy_rst - - ! ------------------------------------------------------------------- - ! - ! Read raster (*.rst) file - - open( 10, file=trim(fnameRst)//'.rst', status='old', action='read', & - form='unformatted', convert='little_endian') - - allocate(tile_id(1:nc,1:nr)) - - do j=1,nr - read(10) tile_id(:,j) - end do - - close( 10,status='keep') - - ! Read number of land ("catchment") tiles (ncatch) - - open( 10, file='clsm/catchment.def', status='old', action='read', & - form='formatted') - read( 10, *) ncatch - close(10, status = 'keep') - - ! grid spacing - - dx_data = 360./real(nc_data) ! science data - dy_data = 180./real(nr_data) - - dx_rst = 360./real(nc) ! raster (*.rst) - dy_rst = 180./real(nr) - - if( (nc_data >= nc) .and. (nr_data >= nr) ) then - - ! science data to be remapped has resolution same as or finer than that of raster grid with tile_id - - ! Step 1: - ! Apply primitive regridding of tile_id(1:nc,1:nr) to iraster(1:nc_data,1:nr_data) - ! - ! NOTE: When the mask file is GEOS5_10arcsec_mask*.nc, then tile_id raster grid is nc=nx=43200 by nr=ny=21600. - ! In mkCatchParam.F90, nc_data=43200 and nr_data=21600 except for GEOLAND and old (16-day) MODIS1 data. - ! - ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - ! [??] --> In most cases, RegridRaster should have no impact and could probably be skipped. - ! Edits in RegridRaster() will do just that but may not be 0-diff. - ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - ! - allocate(iraster(nc_data,nr_data),stat=STATUS); VERIFY_(STATUS) - call RegridRaster(tile_id,iraster) - - ! now iraster contains tile_id on nc_data-by-nr_data science data grid - - ! [??] WHY REMAP RASTER TO DATA?? SHOULDN'T DATA BE REMAPPED TO RASTER?? - ! THEN WE WOULDN'T NEED A CUSTOM rmap STRUCTURE FOR EACH SCIENCE DATASET - - ! count number of science data grid cells that contribute to *land* tiles (excl. lake, landice, ocean) - - NPLUS = count(iraster>=1 .and. iraster<=ncatch) - - allocate( rmap%ij_index(1:nc_data, 1:nr_data), source = 0 ) ! allocate and initialize to 0 - allocate( rmap%map( 1:NPLUS )) - - rmap%map%NT = 1 ! science data & raster resolutions are such that there is at most 1 unique tile ID per science data grid cell - - pix_count = 0 ! 1-dim indexing of 1:NPLUS *science* *data* grid cells that contribute to land tiles - ! [??] WHY IS THIS CALLED pix_count?? - - do j=1,nr_data - do i=1,nc_data - - if( (iraster(i,j)>=1) .and. (iraster(i,j)<=ncatch) ) then - - ! science data grid cell (i,j) contributes to a land tile - - pix_count = pix_count + 1 - rmap%ij_index(i,j) = pix_count ! 1-dim index for [land subset of] 2-dim array (science data grid) - - rmap%map(pix_count)%TID (1) = iraster (i,j) ! 1-dim array with tile_id values - rmap%map(pix_count)%count(1) = 1 ! [??] MAYBE DO rmap%map%count=1 OUTSIDE OF THIS LOOP?? - - - endif - end do - end do - deallocate (iraster) ; VERIFY_(STATUS) - - ! verify final value of pix_count after i,j loop - if (pix_count/=NPLUS) then - print *, 'ERROR 1 in create_mapping(); stopping.' - stop - end if - - else - - ! science data to be remapped has coarser resolution than that of raster grid with tile_id - - ! count number of *original* raster grid cells that contribute to *land* tiles (excl. lake, landice, ocean) - - NPLUS = count(tile_id>=1 .and. tile_id<=ncatch) - - allocate (rmap%ij_index(1:nc_data, 1:nr_data), source = 0) - allocate (rmap%map( 1:NPLUS )) - - rmap%map%NT = 0 - - pix_count = 1 ! 1-dim indexing of 1:NPLUS *science* *data* grid cells that contribute to land tiles - ! [??] WHY IS THIS CALLED pix_count?? - - ! loop through *science* data grid - - do j=1,nr_data - - ! block (i1:i2,j1:j2) of orig raster grid falls within science data grid cell (i,j) - ! - ! NOTE: --> when ratio dy_data/dy_rst is not integer, all orig raster grid cells that - ! fall partly within science data grid cell are included - - j1 = floor ( ( -90. + (j-1)*dy_data +90. )/dy_rst ) + 1 ! WARNING: mixed mode arithmetic!!! [??] WHY NOT REPLACE dy_data/dy_rst WITH SOMETHING LIKE nr_data/nr[+1] ??? - j2 = ceiling( ( -90. + (j )*dy_data +90. )/dy_rst ) ! WARNING: mixed mode arithmetic!!! - - do i=1,nc_data - - i1 = floor ( ( -180. + (i-1)*dx_data +180.)/dx_rst) + 1 ! WARNING: mixed mode arithmetic!!! [??] WHY NOT REPLACE dx_data/dx_rst WITH SOMETHING LIKE nc_data/nc[+1] ??? - i2 = ceiling( ( -180. + (i )*dx_data +180.)/dx_rst) ! WARNING: mixed mode arithmetic!!! - - ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - ! a more sensible order of operations might be as follows: - ! - ! ! check if there is *land* in this science data grid cell - ! - ! subset => tile_id(i1:i2,j1:j2) - ! - ! ! WITHIN SUBSET, count number of *original* raster grid cells that contribute - ! ! to *land* tiles (excl. lake, landice, ocean) - ! - ! NPLUS = count(subset>=1 .and. subset<=ncatch) ! [??] OVERWRITES NPLUS FROM ABOVE !?!?!?!?! - ! - ! if (NPLUS>0) then - ! - ! ! there is *land* in this science data grid cell - ! - ! rmap%ij_index(i,j) = pix_count ! 1-dim index for [land subset of] 2-dim array (science data grid) - ! pix_count = pix_count + 1 ! [??] SWITCH ORDER WITH PREVIOUS LINE AND INIT pix_count TO ZERO ABOVE - ! - ! if (j2>j1 .or. i2>i1) then - ! - ! etc... [MAKE SURE TO REMOVE rmap%ij_index(i,j)=.. AND pix_count+=1 FROM CODE BELOW] - ! - ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - - - if (j2>j1 .or. i2>i1) then - - subset => tile_id(i1:i2,j1:j2) - - ! WITHIN SUBSET, count number of *original* raster grid cells that contribute - ! to *land* tiles (excl. lake, landice, ocean) - - NPLUS = count(subset>=1 .and. subset<=ncatch) ! [??] OVERWRITES NPLUS FROM ABOVE !?!?!?!?! - - if (NPLUS>0) then - - ! determine unique *land* tile IDs within science data grid cell (i,j) - - ! Step (i): determine NBINS = unique *land* tile ID values within subset - - allocate(loc_int (1:NPLUS)) ! [??] WHY NOT ALLOCATE TO A MAX SIZE OUTSIDE OF THE LOOP?? NPLUS<=ceiling(dx_data/dx_rst)*ceiling(dy_data/dy_rst) - allocate(unq_mask(1:NPLUS)) ! [??] WHY NOT ALLOCATE TO A MAX SIZE OUTSIDE OF THE LOOP?? - - loc_int = pack(subset, mask=(subset>=1 .and. subset<=ncatch)) - call MAPL_Sort(loc_int) - unq_mask = .true. - do n=2,NPLUS - unq_mask(n) = .not.(loc_int(n) == loc_int(n-1)) - end do - NBINS = count(unq_mask) - - ! Step (ii): assemble histogram of unique *land* tile ID values - - allocate(loc_val(1:NBINS)) ! [??] WHY NOT ALLOCATE TO A MAX SIZE OUTSIDE OF THE LOOP?? NBINS<=N_tile_per_gridcell - allocate(density(1:NBINS)) ! [??] WHY NOT ALLOCATE TO A MAX SIZE OUTSIDE OF THE LOOP?? - - loc_val = 1.*pack(loc_int,mask=unq_mask) ! [??] WHY REAL WHEN HANDLING INTEGERS??? - - call histogram( size(subset,1)*size(subset,2), NBINS, density, loc_val, real(subset) ) - - ! now "density(n)" contains the number of orig raster grid cells within the science - ! data grid cell (i,j) that contribute to the tile with the tile ID in "loc_val(n)" - - DO N=1,NBINS - - if (density(n)>0) then - - ! build up NT = # unique tile IDs within science grid cell (i,j) [a.k.a. (pix_count)] - - rmap%map(pix_count)%NT = rmap%map(pix_count)%NT + 1 - - ! verify NT <= max allowed value (=N_tiles_per_cell) - - if(rmap%map(pix_count)%NT > N_tiles_per_cell) then ! [??] WHY NOT CHECK NBINS<=N_tiles_per_gridcell OUTSIDE OF THIS LOOP???? - print *, 'N_tiles_per_cell exceeded :', rmap%map(pix_count)%NT - print *, i, j, i1, i2, j1, j2 - print *, 'NT =', rmap%map(pix_count)%NT - print *, 'TID =', rmap%map(pix_count)%TID - print *, 'count=', rmap%map(pix_count)%count - stop - endif - - ! for NT-th unique tile ID within science data grid cell (i,j), record tile ID and count - - rmap%map(pix_count)%TID (rmap%map(pix_count)%NT) = NINT(loc_val(n)) ! convert tile ID back to int!?!?!? - rmap%map(pix_count)%count(rmap%map(pix_count)%NT) = density(n) - - endif ! if (density(n)>0) - - END DO ! N=1,NBINS - - rmap%ij_index(i,j) = pix_count ! 1-dim index for [land subset of] 2-dim array (science data grid) - pix_count = pix_count + 1 - - deallocate (loc_val, density) ! [??] WHY NOT ALLOCATE TO A MAX SIZE OUTSIDE OF THE LOOP?? - deallocate (loc_int, unq_mask) ! [??] WHY NOT ALLOCATE TO A MAX SIZE OUTSIDE OF THE LOOP?? - - endif ! if (NPLUS>0) - - NULLIFY (subset) - - else - - if ( (tile_id (i1,j1)>=1) .and. (tile_id(i1,j1)<=ncatch) ) then - - ! only one unique *land* tile ID in science data grid cell (i,j) - - rmap%map(pix_count)%NT = 1 - rmap%map(pix_count)%TID(1) = tile_id(i1,j1) - rmap%map(pix_count)%COUNT(1) = 1 - rmap%ij_index(i,j) = pix_count - pix_count = pix_count + 1 - - endif - - endif - - end do ! i=1,nc_data - end do ! j=1,nr_data - - end if ! relative resolution of (nc,nr) and (nc_data,nr_data) - - END SUBROUTINE create_mapping + SUBROUTINE create_mapping( nc, nr, nc_data, nr_data, rmap, n_land, tile_id ) + + ! assemble "rmap" structure that can be used for remapping 2-dim gridded + ! science data (nc_data-by-nr_data) to *land* tiles, which are defined + ! on a 2-dim raster grid (nc-by-nr) -! -!---------------------------------------------------------------------- -! - SUBROUTINE merge_lai_data (MaskFile) implicit none - type (date_time_type) :: bf_geol2_time,af_geol2_time,date_time_new,bf_lai_time, & - af_lai_time + + integer, intent(in) :: nc, nr ! dims of raster array (with tile IDs) + integer, intent(in) :: nc_data, nr_data ! dims of science data array + type(regrid_map), intent(inout) :: rmap ! structure for remapping + integer, intent(in) :: n_land ! number of land tiles + integer, target, intent(in) :: tile_id(:,:) + + ! ----------------------- + + integer :: i, j, n, i1, i2, j1, j2, nbins, status, NPLUS, pix_count + + REAL, allocatable, DIMENSION(:) :: loc_val + INTEGER, ALLOCATABLE, DIMENSION(:) :: density, loc_int + logical, allocatable, dimension(:) :: unq_mask + integer, dimension(:,:), pointer :: subset, iraster + + real :: dx_data, dy_data, dx_rst, dy_rst + + ! ------------------------------------------------------------------- + ! + + ! grid spacing + + dx_data = 360./real(nc_data) ! science data + dy_data = 180./real(nr_data) + + dx_rst = 360./real(nc) ! raster (*.rst) + dy_rst = 180./real(nr) + + if( (nc_data >= nc) .and. (nr_data >= nr) ) then + + ! science data to be remapped has resolution same as or finer than that of raster grid with tile_id + + ! Step 1: + ! Apply primitive regridding of tile_id(1:nc,1:nr) to iraster(1:nc_data,1:nr_data) + ! + ! NOTE: When the mask file is GEOS5_10arcsec_mask*.nc, then tile_id raster grid is nc=nx=43200 by nr=ny=21600. + ! In mkCatchParam.F90, nc_data=43200 and nr_data=21600 except for GEOLAND and old (16-day) MODIS1 data. + ! + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! [??] --> In most cases, RegridRaster should have no impact and could probably be skipped. + ! Edits in RegridRaster() will do just that but may not be 0-diff. + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! + allocate(iraster(nc_data,nr_data),stat=STATUS); VERIFY_(STATUS) + call RegridRaster(tile_id,iraster) + + ! now iraster contains tile_id on nc_data-by-nr_data science data grid + + ! [??] WHY REMAP RASTER TO DATA?? SHOULDN'T DATA BE REMAPPED TO RASTER?? + ! THEN WE WOULDN'T NEED A CUSTOM rmap STRUCTURE FOR EACH SCIENCE DATASET + + ! count number of science data grid cells that contribute to *land* tiles (excl. lake, landice, ocean) + + NPLUS = count(iraster>=1 .and. iraster<=n_land) + + allocate( rmap%ij_index(1:nc_data, 1:nr_data), source = 0 ) ! allocate and initialize to 0 + allocate( rmap%map( 1:NPLUS )) + + rmap%map%NT = 1 ! science data & raster resolutions are such that there is at most 1 unique tile ID per science data grid cell + + pix_count = 0 ! 1-dim indexing of 1:NPLUS *science* *data* grid cells that contribute to land tiles + ! [??] WHY IS THIS CALLED pix_count?? + + do j=1,nr_data + do i=1,nc_data + + if( (iraster(i,j)>=1) .and. (iraster(i,j)<=n_land) ) then + + ! science data grid cell (i,j) contributes to a land tile + + pix_count = pix_count + 1 + rmap%ij_index(i,j) = pix_count ! 1-dim index for [land subset of] 2-dim array (science data grid) + + rmap%map(pix_count)%TID (1) = iraster (i,j) ! 1-dim array with tile_id values + rmap%map(pix_count)%count(1) = 1 ! [??] MAYBE DO rmap%map%count=1 OUTSIDE OF THIS LOOP?? + + + endif + end do + end do + deallocate (iraster) ; VERIFY_(STATUS) + + ! verify final value of pix_count after i,j loop + if (pix_count/=NPLUS) then + print *, 'ERROR 1 in create_mapping(); stopping.' + stop + end if + + else + + ! science data to be remapped has coarser resolution than that of raster grid with tile_id + + ! count number of *original* raster grid cells that contribute to *land* tiles (excl. lake, landice, ocean) + + NPLUS = count(tile_id>=1 .and. tile_id<=n_land) + + allocate (rmap%ij_index(1:nc_data, 1:nr_data), source = 0) + allocate (rmap%map( 1:NPLUS )) + + rmap%map%NT = 0 + + pix_count = 1 ! 1-dim indexing of 1:NPLUS *science* *data* grid cells that contribute to land tiles + ! [??] WHY IS THIS CALLED pix_count?? + + ! loop through *science* data grid + + do j=1,nr_data + + ! block (i1:i2,j1:j2) of orig raster grid falls within science data grid cell (i,j) + ! + ! NOTE: --> when ratio dy_data/dy_rst is not integer, all orig raster grid cells that + ! fall partly within science data grid cell are included + + j1 = floor ( ( -90. + (j-1)*dy_data +90. )/dy_rst ) + 1 ! WARNING: mixed mode arithmetic!!! [??] WHY NOT REPLACE dy_data/dy_rst WITH SOMETHING LIKE nr_data/nr[+1] ??? + j2 = ceiling( ( -90. + (j )*dy_data +90. )/dy_rst ) ! WARNING: mixed mode arithmetic!!! + + do i=1,nc_data + + i1 = floor ( ( -180. + (i-1)*dx_data +180.)/dx_rst) + 1 ! WARNING: mixed mode arithmetic!!! [??] WHY NOT REPLACE dx_data/dx_rst WITH SOMETHING LIKE nc_data/nc[+1] ??? + i2 = ceiling( ( -180. + (i )*dx_data +180.)/dx_rst) ! WARNING: mixed mode arithmetic!!! + + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! a more sensible order of operations might be as follows: + ! + ! ! check if there is *land* in this science data grid cell + ! + ! subset => tile_id(i1:i2,j1:j2) + ! + ! ! WITHIN SUBSET, count number of *original* raster grid cells that contribute + ! ! to *land* tiles (excl. lake, landice, ocean) + ! + ! NPLUS = count(subset>=1 .and. subset<=n_land) ! [??] OVERWRITES NPLUS FROM ABOVE !?!?!?!?! + ! + ! if (NPLUS>0) then + ! + ! ! there is *land* in this science data grid cell + ! + ! rmap%ij_index(i,j) = pix_count ! 1-dim index for [land subset of] 2-dim array (science data grid) + ! pix_count = pix_count + 1 ! [??] SWITCH ORDER WITH PREVIOUS LINE AND INIT pix_count TO ZERO ABOVE + ! + ! if (j2>j1 .or. i2>i1) then + ! + ! etc... [MAKE SURE TO REMOVE rmap%ij_index(i,j)=.. AND pix_count+=1 FROM CODE BELOW] + ! + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + + if (j2>j1 .or. i2>i1) then + + subset => tile_id(i1:i2,j1:j2) + + ! WITHIN SUBSET, count number of *original* raster grid cells that contribute + ! to *land* tiles (excl. lake, landice, ocean) + + NPLUS = count(subset>=1 .and. subset<=n_land) ! [??] OVERWRITES NPLUS FROM ABOVE !?!?!?!?! + + if (NPLUS>0) then + + ! determine unique *land* tile IDs within science data grid cell (i,j) + + ! Step (i): determine NBINS = unique *land* tile ID values within subset + + allocate(loc_int (1:NPLUS)) ! [??] WHY NOT ALLOCATE TO A MAX SIZE OUTSIDE OF THE LOOP?? NPLUS<=ceiling(dx_data/dx_rst)*ceiling(dy_data/dy_rst) + allocate(unq_mask(1:NPLUS)) ! [??] WHY NOT ALLOCATE TO A MAX SIZE OUTSIDE OF THE LOOP?? + + loc_int = pack(subset, mask=(subset>=1 .and. subset<=n_land)) + call MAPL_Sort(loc_int) + unq_mask = .true. + do n=2,NPLUS + unq_mask(n) = .not.(loc_int(n) == loc_int(n-1)) + end do + NBINS = count(unq_mask) + + ! Step (ii): assemble histogram of unique *land* tile ID values + + allocate(loc_val(1:NBINS)) ! [??] WHY NOT ALLOCATE TO A MAX SIZE OUTSIDE OF THE LOOP?? NBINS<=N_tile_per_gridcell + allocate(density(1:NBINS)) ! [??] WHY NOT ALLOCATE TO A MAX SIZE OUTSIDE OF THE LOOP?? + + loc_val = 1.*pack(loc_int,mask=unq_mask) ! [??] WHY REAL WHEN HANDLING INTEGERS??? + + call histogram( size(subset,1)*size(subset,2), NBINS, density, loc_val, real(subset) ) + + ! now "density(n)" contains the number of orig raster grid cells within the science + ! data grid cell (i,j) that contribute to the tile with the tile ID in "loc_val(n)" + + DO N=1,NBINS + + if (density(n)>0) then + + ! build up NT = # unique tile IDs within science grid cell (i,j) [a.k.a. (pix_count)] + + rmap%map(pix_count)%NT = rmap%map(pix_count)%NT + 1 + + ! verify NT <= max allowed value (=N_tiles_per_cell) + + if(rmap%map(pix_count)%NT > N_tiles_per_cell) then ! [??] WHY NOT CHECK NBINS<=N_tiles_per_gridcell OUTSIDE OF THIS LOOP???? + print *, 'N_tiles_per_cell exceeded :', rmap%map(pix_count)%NT + print *, i, j, i1, i2, j1, j2 + print *, 'NT =', rmap%map(pix_count)%NT + print *, 'TID =', rmap%map(pix_count)%TID + print *, 'count=', rmap%map(pix_count)%count + stop + endif + + ! for NT-th unique tile ID within science data grid cell (i,j), record tile ID and count + + rmap%map(pix_count)%TID (rmap%map(pix_count)%NT) = NINT(loc_val(n)) ! convert tile ID back to int!?!?!? + rmap%map(pix_count)%count(rmap%map(pix_count)%NT) = density(n) + + endif ! if (density(n)>0) + + END DO ! N=1,NBINS + + rmap%ij_index(i,j) = pix_count ! 1-dim index for [land subset of] 2-dim array (science data grid) + pix_count = pix_count + 1 + + deallocate (loc_val, density) ! [??] WHY NOT ALLOCATE TO A MAX SIZE OUTSIDE OF THE LOOP?? + deallocate (loc_int, unq_mask) ! [??] WHY NOT ALLOCATE TO A MAX SIZE OUTSIDE OF THE LOOP?? + + endif ! if (NPLUS>0) + + NULLIFY (subset) + + else + + if ( (tile_id (i1,j1)>=1) .and. (tile_id(i1,j1)<=n_land) ) then + + ! only one unique *land* tile ID in science data grid cell (i,j) + + rmap%map(pix_count)%NT = 1 + rmap%map(pix_count)%TID(1) = tile_id(i1,j1) + rmap%map(pix_count)%COUNT(1) = 1 + rmap%ij_index(i,j) = pix_count + pix_count = pix_count + 1 + + endif + + endif + + end do ! i=1,nc_data + end do ! j=1,nr_data + + end if ! relative resolution of (nc,nr) and (nc_data,nr_data) + + END SUBROUTINE create_mapping + + ! + !---------------------------------------------------------------------- + ! + SUBROUTINE merge_lai_data (MaskFile, ntiles, pfaf) + implicit none character (*) :: MaskFile - integer :: n,k,ntiles,t,ierr - integer, allocatable, dimension (:) :: pfaf + integer, intent(in) :: ntiles + integer, intent(in) :: pfaf(:) + + type (date_time_type) :: bf_geol2_time,af_geol2_time,date_time_new,bf_lai_time, & + af_lai_time + integer :: n,k, t,ierr + ! South AMerica/ Africa/ Australia are from GEOLAND2 integer :: i1,i2,i3,i4,i5,i6 - integer, parameter :: i1_hydr = 1011000, i2_hydr = 1999900 ! South America - integer, parameter :: i3_hydr = 3021000, i4_hydr = 3990000 ! Africa - integer, parameter :: i5_hydr = 5000142, i6_hydr = 5999900 ! Australia - integer, parameter :: i1_srtm = 229075 , i2_srtm = 267083 ! South America - integer, parameter :: i3_srtm = 75369 , i4_srtm = 140751 ! Africa + integer, parameter :: i1_hydr = 1011000, i2_hydr = 1999900 ! South America + integer, parameter :: i3_hydr = 3021000, i4_hydr = 3990000 ! Africa + integer, parameter :: i5_hydr = 5000142, i6_hydr = 5999900 ! Australia + integer, parameter :: i1_srtm = 229075 , i2_srtm = 267083 ! South America + integer, parameter :: i3_srtm = 75369 , i4_srtm = 140751 ! Africa integer, parameter :: i5_srtm = 267084 , i6_srtm = SRTM_maxcat ! Australia REAL, ALLOCATABLE, dimension (:) :: geol2_lai_bf,geol2_lai_af,geol2_lai, lai @@ -1438,133 +1383,120 @@ SUBROUTINE merge_lai_data (MaskFile) i6 = i6_hydr endif - open (10, file ='clsm/catchment.def',form='formatted',status='old',action='read') - read (10,*) ntiles - - allocate (pfaf(1:ntiles)) allocate (geol2_lai_bf(1:ntiles)) allocate (geol2_lai_af(1:ntiles)) allocate (geol2_lai (1:ntiles)) allocate (lai (1:ntiles)) - - do n =1,ntiles - read (10,*) k,pfaf(n) - end do - close (10,status='keep') - -! - open (41,file='clsm/lai.GEOLAND2_10-DayClim', & + ! + open (41,file='clsm/lai.GEOLAND2_10-DayClim', & form='unformatted',status='old',convert='little_endian',action='read') - open (42,file='clsm/lai.MODIS_8-DayClim', & + open (42,file='clsm/lai.MODIS_8-DayClim', & form='unformatted',status='old',convert='little_endian',action='read') - open (43,file='clsm/lai.dat', & + open (43,file='clsm/lai.dat', & form='unformatted',status='unknown',convert='little_endian',action='write') - read(41) gyr,gmn,gdy,dum,dum,dum,gyr1,gmn1,gdy1 - read(41) geol2_lai_bf - call Get_MidTime(gyr,gmn,gdy,gyr1,gmn1,gdy1,bf_geol2_time) - - read(41) gyr,gmn,gdy,dum,dum,dum,gyr1,gmn1,gdy1 - read(41) geol2_lai_af - call Get_MidTime(gyr,gmn,gdy,gyr1,gmn1,gdy1,af_geol2_time) - - do t = 1, 48 - - read(42) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 - read(42) lai - write(43) yr,mn,dy,0.,0.,0.,yr1,mn1,dy1,0.,0.,0.,float(ntiles),1. - call Get_MidTime(yr,mn,dy,yr1,mn1,dy1,date_time_new) - -! date_time_new%year = nint(yr) + 2001 -! date_time_new%month = nint(mn) -! date_time_new%day = nint(dy) -! date_time_new%hour = 0 -! date_time_new%min = 0 -! date_time_new%sec = 0 -! call get_dofyr_pentad(date_time_new) - if (datetime_le_refdatetime(date_time_new,af_geol2_time)) then - + read(41) gyr,gmn,gdy,dum,dum,dum,gyr1,gmn1,gdy1 + read(41) geol2_lai_bf + call Get_MidTime(gyr,gmn,gdy,gyr1,gmn1,gdy1,bf_geol2_time) + + read(41) gyr,gmn,gdy,dum,dum,dum,gyr1,gmn1,gdy1 + read(41) geol2_lai_af + call Get_MidTime(gyr,gmn,gdy,gyr1,gmn1,gdy1,af_geol2_time) + + do t = 1, 48 + + read(42) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 + read(42) lai + write(43) yr,mn,dy,0.,0.,0.,yr1,mn1,dy1,0.,0.,0.,float(ntiles),1. + call Get_MidTime(yr,mn,dy,yr1,mn1,dy1,date_time_new) + + ! date_time_new%year = nint(yr) + 2001 + ! date_time_new%month = nint(mn) + ! date_time_new%day = nint(dy) + ! date_time_new%hour = 0 + ! date_time_new%min = 0 + ! date_time_new%sec = 0 + ! call get_dofyr_pentad(date_time_new) + if ( .not. datetime_le_refdatetime(date_time_new,af_geol2_time)) then + read(41,IOSTAT=ierr) gyr,gmn,gdy,dum,dum,dum,gyr1,gmn1,gdy1 + if(ierr == 0) then + geol2_lai_bf = geol2_lai_af + read(41) geol2_lai_af + bf_geol2_time = af_geol2_time + call Get_MidTime(gyr,gmn,gdy,gyr1,gmn1,gdy1,af_geol2_time) else - read(41,IOSTAT=ierr) gyr,gmn,gdy,dum,dum,dum,gyr1,gmn1,gdy1 - if(ierr == 0) then - geol2_lai_bf = geol2_lai_af - read(41) geol2_lai_af - bf_geol2_time = af_geol2_time - call Get_MidTime(gyr,gmn,gdy,gyr1,gmn1,gdy1,af_geol2_time) - else - print *,'END OF GEOL2 LAI FILE' - stop - endif - endif - - if(t==1) then - date_time_new%year = date_time_new%year + 1 - geol2_lai_af = geol2_lai_bf - af_geol2_time = bf_geol2_time - af_geol2_time%year = af_geol2_time%year + 1 - - do k = 1,34 - read(41) gyr,gmn,gdy,dum,dum,dum,gyr1,gmn1,gdy1 - read(41) geol2_lai_bf - call Get_MidTime(gyr,gmn,gdy,gyr1,gmn1,gdy1,bf_geol2_time) - end do + print *,'END OF GEOL2 LAI FILE' + stop endif + endif -! print *,t -! print *,'DATE_TIME_NEW :',date_time_new -! print *,'bf_geol2_time :',bf_geol2_time -! print *,'af_geol2_time :',af_geol2_time + if(t==1) then + date_time_new%year = date_time_new%year + 1 + geol2_lai_af = geol2_lai_bf + af_geol2_time = bf_geol2_time + af_geol2_time%year = af_geol2_time%year + 1 - call Time_Interp_Fac (date_time_new, bf_geol2_time, af_geol2_time, slice1, slice2) - geol2_lai = (slice1*geol2_lai_bf + slice2*geol2_lai_af) - - if(t == 1) then - rewind(41) + do k = 1,34 read(41) gyr,gmn,gdy,dum,dum,dum,gyr1,gmn1,gdy1 read(41) geol2_lai_bf - call Get_MidTime(gyr,gmn,gdy,gyr1,gmn1,gdy1,bf_geol2_time) - - read(41) gyr,gmn,gdy,dum,dum,dum,gyr1,gmn1,gdy1 - read(41) geol2_lai_af - call Get_MidTime(gyr,gmn,gdy,gyr1,gmn1,gdy1,af_geol2_time) - endif + call Get_MidTime(gyr,gmn,gdy,gyr1,gmn1,gdy1,bf_geol2_time) + end do + endif -! replace South America with GEOLAND2 + ! print *,t + ! print *,'DATE_TIME_NEW :',date_time_new + ! print *,'bf_geol2_time :',bf_geol2_time + ! print *,'af_geol2_time :',af_geol2_time - DO n =1,ntiles - if((pfaf(n) >= i1).and.(pfaf(n) <= i2)) lai(n) = geol2_lai(n) - if((pfaf(n) >= i3).and.(pfaf(n) <= i4)) lai(n) = geol2_lai(n) - if((pfaf(n) >= i5).and.(pfaf(n) <= i6)) lai(n) = geol2_lai(n) - end do - write (43) lai(:) + call Time_Interp_Fac (date_time_new, bf_geol2_time, af_geol2_time, slice1, slice2) + geol2_lai = (slice1*geol2_lai_bf + slice2*geol2_lai_af) + + if(t == 1) then + rewind(41) + read(41) gyr,gmn,gdy,dum,dum,dum,gyr1,gmn1,gdy1 + read(41) geol2_lai_bf + call Get_MidTime(gyr,gmn,gdy,gyr1,gmn1,gdy1,bf_geol2_time) + + read(41) gyr,gmn,gdy,dum,dum,dum,gyr1,gmn1,gdy1 + read(41) geol2_lai_af + call Get_MidTime(gyr,gmn,gdy,gyr1,gmn1,gdy1,af_geol2_time) + endif + + ! replace South America with GEOLAND2 + + DO n =1,ntiles + if((pfaf(n) >= i1).and.(pfaf(n) <= i2)) lai(n) = geol2_lai(n) + if((pfaf(n) >= i3).and.(pfaf(n) <= i4)) lai(n) = geol2_lai(n) + if((pfaf(n) >= i5).and.(pfaf(n) <= i6)) lai(n) = geol2_lai(n) end do + write (43) lai(:) + end do - close (41,status = 'keep') - close (42,status = 'keep') - close (43,status = 'keep') + close (41,status = 'keep') + close (42,status = 'keep') + close (43,status = 'keep') - deallocate (pfaf,geol2_lai_bf, geol2_lai_af,geol2_lai,lai) + deallocate (geol2_lai_bf, geol2_lai_af,geol2_lai,lai) END SUBROUTINE merge_lai_data -! -!---------------------------------------------------------------------- -! - SUBROUTINE modis_scale_para_high (ease_grid,MA,fnameTil) - + ! + !---------------------------------------------------------------------- + ! + SUBROUTINE modis_scale_para_high (MA, n_land) implicit none + character(*), intent(in) :: MA + integer, intent(in) :: n_land + type (date_time_type) :: gf_green_time,af_green_time,end_time, & - bf_lai_time,af_lai_time,date_time_new,bf_modis_time, & - af_modis_time - logical :: ease_grid - character*6 :: MA + bf_lai_time,af_lai_time,date_time_new,bf_modis_time, & + af_modis_time CHARACTER*20 :: version,resoln,continent integer :: nc_gcm,nr_gcm,nc_ocean,nr_ocean REAL :: tsteps,zth, slr,tarea - INTEGER :: typ,j_dum,ierr,indr1,ip2 + INTEGER :: typ,j_dum,ierr,indr1 character*100 :: path,fname,fout,metpath - character (*) :: fnameTil - integer :: n,maxcat,ip + integer :: n,ip integer :: yy,j,month integer, allocatable, dimension (:) :: vegcls real, allocatable, dimension (:) :: & @@ -1579,60 +1511,32 @@ SUBROUTINE modis_scale_para_high (ease_grid,MA,fnameTil) real :: yr,mn,dy,yr1,mn1,dy1,dum, slice1,slice2 logical :: save_sib = .false. - fname='clsm/catchment.def' - open (10,file=fname,status='old',action='read',form='formatted') - read (10,*)maxcat - allocate (albvf (1:maxcat)) - allocate (albnf (1:maxcat)) - allocate (calbvf (1:maxcat)) - allocate (calbnf (1:maxcat)) - allocate (modisvf (1:maxcat)) - allocate (modisnf (1:maxcat)) - allocate (lai (1:maxcat)) - allocate (green (1:maxcat)) - allocate (lai_before (1:maxcat)) - allocate (grn_before (1:maxcat)) - allocate (lai_after (1:maxcat)) - allocate (grn_after (1:maxcat)) - allocate (vegcls (1:maxcat)) - allocate (zero_array (1:maxcat)) - allocate (one_array (1:maxcat)) - allocate (albvr (1:maxcat)) - allocate (albnr (1:maxcat)) - close (10,status='keep') - - fname=trim(fnameTil)//'.til' - open (10,file=fname,status='old',action='read',form='formatted') + allocate (albvf (1:n_land)) + allocate (albnf (1:n_land)) + allocate (calbvf (1:n_land)) + allocate (calbnf (1:n_land)) + allocate (modisvf (1:n_land)) + allocate (modisnf (1:n_land)) + allocate (lai (1:n_land)) + allocate (green (1:n_land)) + allocate (lai_before (1:n_land)) + allocate (grn_before (1:n_land)) + allocate (lai_after (1:n_land)) + allocate (grn_after (1:n_land)) + allocate (vegcls (1:n_land)) + allocate (zero_array (1:n_land)) + allocate (one_array (1:n_land)) + allocate (albvr (1:n_land)) + allocate (albnr (1:n_land)) + fname='clsm/mosaic_veg_typs_fracs' open (20,file=fname,status='old',action='read',form='formatted') - read (10,*)ip - read (10,*)j_dum - - do n = 1, j_dum - read (10,'(a)')version - read (10,*)nc_gcm - read (10,*)nr_gcm - end do - - do n = 1,ip - if (ease_grid) then - read(10,*,IOSTAT=ierr) typ !,pfs,lont,latt,ig,jg,fr_gcm - else - !read(10,'(I10,3E20.12,9(2I10,E20.12,I10))',IOSTAT=ierr) & - ! typ,tarea,lont,latt,ig,jg,fr_gcm,indx_dum,pfs,j_dum,fr_cat,j_dum - read(10,*,IOSTAT=ierr) typ - endif - if (typ == 100) then - ip2 = n - !read (20,'(i10,i8,2(2x,i3),2(2x,f6.4))') & - ! indr1,indr1,vegcls(ip2),indr1,fr_gcm,fr_gcm - read (20,*,IOSTAT=ierr) indr1,indr1,vegcls(ip2) - endif - if(ierr /= 0)write (*,*)'Problem reading', n, ease_grid + do n = 1, n_land + read (20,*,IOSTAT=ierr) indr1,indr1,vegcls(n) + if(ierr /= 0)write (*,*)'Problem reading', n end do - close (10,status='keep') close (20,status='keep') albvf =0. @@ -1646,7 +1550,7 @@ SUBROUTINE modis_scale_para_high (ease_grid,MA,fnameTil) albvr = 0. albnr = 0. -! MODIS Albedo files + ! MODIS Albedo files if(MA == 'MODIS1') then open (10,file='clsm/AlbMap.WS.16-day.tile.0.3_0.7.dat',& form='unformatted',convert='little_endian', & @@ -1670,23 +1574,23 @@ SUBROUTINE modis_scale_para_high (ease_grid,MA,fnameTil) read (10) modisvf (:) read (11) modisnf (:) -! SiB Albedo Parameterization files + ! SiB Albedo Parameterization files if (save_sib) then open (20,file='clsm/sib_visdf.dat',convert='little_endian', & - action='write',status='unknown',form='unformatted') + action='write',status='unknown',form='unformatted') open (21,file='clsm/sib_nirdf.dat',convert='little_endian', & - action='write',status='unknown',form='unformatted') - write(20) yr,mn,dy,0.,0.,0.,yr1,mn1,dy1,0.,0.,0.,float(maxcat),1. - write(21) yr,mn,dy,0.,0.,0.,yr1,mn1,dy1,0.,0.,0.,float(maxcat),1. + action='write',status='unknown',form='unformatted') + write(20) yr,mn,dy,0.,0.,0.,yr1,mn1,dy1,0.,0.,0.,float(n_land),1. + write(21) yr,mn,dy,0.,0.,0.,yr1,mn1,dy1,0.,0.,0.,float(n_land),1. endif -! MODIS scale parameter files + ! MODIS scale parameter files open (30,file='clsm/visdf.dat',convert='little_endian', & - action='write',status='unknown',form='unformatted') + action='write',status='unknown',form='unformatted') open (31,file='clsm/nirdf.dat',convert='little_endian', & - action='write',status='unknown',form='unformatted') - write(30) yr,mn,dy,0.,0.,0.,yr1,mn1,dy1,0.,0.,0.,float(maxcat),1. - write(31) yr,mn,dy,0.,0.,0.,yr1,mn1,dy1,0.,0.,0.,float(maxcat),1. + action='write',status='unknown',form='unformatted') + write(30) yr,mn,dy,0.,0.,0.,yr1,mn1,dy1,0.,0.,0.,float(n_land),1. + write(31) yr,mn,dy,0.,0.,0.,yr1,mn1,dy1,0.,0.,0.,float(n_land),1. call Get_MidTime(yr,mn,dy,yr1,mn1,dy1,date_time_new) bf_modis_time = date_time_new @@ -1712,19 +1616,19 @@ SUBROUTINE modis_scale_para_high (ease_grid,MA,fnameTil) read(40) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 read(40) lai_before call Get_MidTime(yr,mn,dy,yr1,mn1,dy1,bf_lai_time) - + read(40) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 read(40) lai_after call Get_MidTime(yr,mn,dy,yr1,mn1,dy1,af_lai_time) - - if(date_time_new%dofyr < bf_lai_time%dofyr) then + + if(date_time_new%dofyr < bf_lai_time%dofyr) then do while ((date_time_new%dofyr > af_lai_time%dofyr)) lai_before = lai_after bf_lai_time = af_lai_time read(40) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 read(40) lai_after call Get_MidTime(yr,mn,dy,yr1,mn1,dy1,af_lai_time) - end do + end do endif fname='clsm/green.dat' @@ -1733,7 +1637,7 @@ SUBROUTINE modis_scale_para_high (ease_grid,MA,fnameTil) read(41) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 read(41) grn_before call Get_MidTime(yr,mn,dy,yr1,mn1,dy1,gf_green_time) - + read(41) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 read(41) grn_after call Get_MidTime(yr,mn,dy,yr1,mn1,dy1,af_green_time) @@ -1745,187 +1649,179 @@ SUBROUTINE modis_scale_para_high (ease_grid,MA,fnameTil) tsteps =0. do while (datetime_le_refdatetime(date_time_new,end_time)) - -! write (*,'(a48,i4.4,i2.2,i2.2)') ' Computing MODIS scale parameters for month: ', & - - - if (datetime_le_refdatetime(date_time_new,af_lai_time)) then - else + ! write (*,'(a48,i4.4,i2.2,i2.2)') ' Computing MODIS scale parameters for month: ', & + - read(40,IOSTAT=ierr) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 - if(ierr == 0) then - lai_before = lai_after - read(40) lai_after - bf_lai_time = af_lai_time - call Get_MidTime(yr,mn,dy,yr1,mn1,dy1,af_lai_time) - else - rewind(40) - read(40) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 - read(40) lai_before - call Get_MidTime(yr,mn,dy,yr1,mn1,dy1,bf_lai_time) - read(40) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 - read(40) lai_after - call Get_MidTime(yr,mn,dy,yr1,mn1,dy1,af_lai_time) - - if(date_time_new%dofyr < bf_lai_time%dofyr) then - do while ((date_time_new%dofyr > af_lai_time%dofyr)) - lai_before = lai_after - bf_lai_time = af_lai_time - read(40) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 - read(40) lai_after - call Get_MidTime(yr,mn,dy,yr1,mn1,dy1,af_lai_time) - end do - endif - endif - endif - call Time_Interp_Fac (date_time_new, bf_lai_time, af_lai_time, slice1, slice2) - lai = (slice1*lai_before + slice2*lai_after) - - if (datetime_le_refdatetime(date_time_new,af_green_time)) then - - else - - read(41,IOSTAT=ierr) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 - if(ierr == 0) then - grn_before = grn_after - gf_green_time = af_green_time - read(41) grn_after - call Get_MidTime(yr,mn,dy,yr1,mn1,dy1,af_green_time) - endif - endif -! else -! rewind(41) -! read(41) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 -! read(41) grn_before -! gf_green_time%month = NINT(mn) -! gf_green_time%day = NINT(dy) -! call get_dofyr_pentad(gf_green_time) -! af_green_time%month = NINT(mn1) -! af_green_time%day = NINT(dy1) -! call get_dofyr_pentad(af_green_time) -! if(date_time_new%dofyr < gf_green_time%dofyr) then -! do while ((date_time_new%dofyr > af_green_time%dofyr)) -! read(41) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 -! read(41) grn_before -! gf_green_time%year = date_time_new%year -! gf_green_time%month = NINT(mn) -! gf_green_time%day = NINT(dy) -! call get_dofyr_pentad(gf_green_time) -! af_green_time%year = date_time_new%year -! if ((yr1-yr) == 1.)af_green_time%year = af_green_time%year+1 -! af_green_time%month = NINT(mn1) -! af_green_time%day = NINT(dy1) -! call get_dofyr_pentad(af_green_time) -! end do -! read(41) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 -! read(41) grn_after -! endif -! endif -! endif - - call Time_Interp_Fac (date_time_new, gf_green_time, af_green_time, slice1, slice2) - green = (slice1*grn_before + slice2*grn_after) - - call sibalb ( & - MAXCAT,vegcls,lai,green, zero_array, & - one_array,one_array,one_array,one_array, & - ALBVR, ALBNR, albvf, albnf) - - calbvf = calbvf + albvf - calbnf = calbnf + albnf - tsteps = tsteps + 1. - call augment_date_time( 86400, date_time_new ) - - if (datetime_le_refdatetime(date_time_new,af_modis_time)) then - + if ( .not. datetime_le_refdatetime(date_time_new,af_lai_time)) then + read(40,IOSTAT=ierr) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 + if(ierr == 0) then + lai_before = lai_after + read(40) lai_after + bf_lai_time = af_lai_time + call Get_MidTime(yr,mn,dy,yr1,mn1,dy1,af_lai_time) else + rewind(40) + read(40) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 + read(40) lai_before + call Get_MidTime(yr,mn,dy,yr1,mn1,dy1,bf_lai_time) + read(40) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 + read(40) lai_after + call Get_MidTime(yr,mn,dy,yr1,mn1,dy1,af_lai_time) + + if(date_time_new%dofyr < bf_lai_time%dofyr) then + do while ((date_time_new%dofyr > af_lai_time%dofyr)) + lai_before = lai_after + bf_lai_time = af_lai_time + read(40) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 + read(40) lai_after + call Get_MidTime(yr,mn,dy,yr1,mn1,dy1,af_lai_time) + end do + endif + endif + endif + call Time_Interp_Fac (date_time_new, bf_lai_time, af_lai_time, slice1, slice2) + lai = (slice1*lai_before + slice2*lai_after) + + if ( .not. datetime_le_refdatetime(date_time_new,af_green_time)) then + read(41,IOSTAT=ierr) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 + if(ierr == 0) then + grn_before = grn_after + gf_green_time = af_green_time + read(41) grn_after + call Get_MidTime(yr,mn,dy,yr1,mn1,dy1,af_green_time) + endif + endif + ! else + ! rewind(41) + ! read(41) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 + ! read(41) grn_before + ! gf_green_time%month = NINT(mn) + ! gf_green_time%day = NINT(dy) + ! call get_dofyr_pentad(gf_green_time) + ! af_green_time%month = NINT(mn1) + ! af_green_time%day = NINT(dy1) + ! call get_dofyr_pentad(af_green_time) + ! if(date_time_new%dofyr < gf_green_time%dofyr) then + ! do while ((date_time_new%dofyr > af_green_time%dofyr)) + ! read(41) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 + ! read(41) grn_before + ! gf_green_time%year = date_time_new%year + ! gf_green_time%month = NINT(mn) + ! gf_green_time%day = NINT(dy) + ! call get_dofyr_pentad(gf_green_time) + ! af_green_time%year = date_time_new%year + ! if ((yr1-yr) == 1.)af_green_time%year = af_green_time%year+1 + ! af_green_time%month = NINT(mn1) + ! af_green_time%day = NINT(dy1) + ! call get_dofyr_pentad(af_green_time) + ! end do + ! read(41) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 + ! read(41) grn_after + ! endif + ! endif + ! endif + + call Time_Interp_Fac (date_time_new, gf_green_time, af_green_time, slice1, slice2) + green = (slice1*grn_before + slice2*grn_after) + + call sibalb ( & + n_land,vegcls,lai,green, zero_array, & + one_array,one_array,one_array,one_array, & + ALBVR, ALBNR, albvf, albnf) + + calbvf = calbvf + albvf + calbnf = calbnf + albnf + tsteps = tsteps + 1. + call augment_date_time( 86400, date_time_new ) + + if ( .not. datetime_le_refdatetime(date_time_new,af_modis_time)) then + bf_modis_time = af_modis_time + calbvf = calbvf/tsteps + calbnf = calbnf/tsteps + + modisvf = modisvf/(calbvf + 1.e-20) + modisnf = modisnf/(calbnf + 1.e-20) + + do n =1, n_land + ! if(modisvf(n).le.0)print *,'Negative MODISVF scale param at cell',n, modisvf(n) + ! if(modisnf(n).le.0)print *,'Negative MODISNF scale param at cell',n, modisnf(n) + ! if(modisvf(n).gt.100)print *,'Too large MODISVF scale param at cell',n, modisvf(n) + ! if(modisnf(n).gt.100)print *,'Too large MODISNF scale param at cell',n, modisnf(n) + if(modisvf(n).le.0.) modisvf(n) = 1. + if(modisnf(n).le.0.) modisnf(n) = 1. + if(modisvf(n).gt.100)modisvf(n)= 1. + if(modisnf(n).gt.100)modisnf(n)= 1. + enddo + + if (save_sib) then + write (20) calbvf (:) + write (21) calbnf (:) + endif + + write (30) modisvf (:) + write (31) modisnf (:) + + read(10,IOSTAT=ierr) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 + + if(ierr == 0) then + read(11) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 + read (10) modisvf (:) + read (11) modisnf (:) + write(30) yr,mn,dy,0.,0.,0.,yr1,mn1,dy1,0.,0.,0.,float(n_land),1. + write(31) yr,mn,dy,0.,0.,0.,yr1,mn1,dy1,0.,0.,0.,float(n_land),1. + + if (save_sib) then + write(20) yr,mn,dy,0.,0.,0.,yr1,mn1,dy1,0.,0.,0.,float(n_land),1. + write(21) yr,mn,dy,0.,0.,0.,yr1,mn1,dy1,0.,0.,0.,float(n_land),1. + endif + bf_modis_time = af_modis_time - calbvf = calbvf/tsteps - calbnf = calbnf/tsteps - - modisvf = modisvf/(calbvf + 1.e-20) - modisnf = modisnf/(calbnf + 1.e-20) - - do n =1, maxcat -! if(modisvf(n).le.0)print *,'Negative MODISVF scale param at cell',n, modisvf(n) -! if(modisnf(n).le.0)print *,'Negative MODISNF scale param at cell',n, modisnf(n) -! if(modisvf(n).gt.100)print *,'Too large MODISVF scale param at cell',n, modisvf(n) -! if(modisnf(n).gt.100)print *,'Too large MODISNF scale param at cell',n, modisnf(n) - if(modisvf(n).le.0.) modisvf(n) = 1. - if(modisnf(n).le.0.) modisnf(n) = 1. - if(modisvf(n).gt.100)modisvf(n)= 1. - if(modisnf(n).gt.100)modisnf(n)= 1. - enddo - - if (save_sib) then - write (20) calbvf (:) - write (21) calbnf (:) - endif - - write (30) modisvf (:) - write (31) modisnf (:) - - read(10,IOSTAT=ierr) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 - - if(ierr == 0) then - - read(11) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 - read (10) modisvf (:) - read (11) modisnf (:) - write(30) yr,mn,dy,0.,0.,0.,yr1,mn1,dy1,0.,0.,0.,float(maxcat),1. - write(31) yr,mn,dy,0.,0.,0.,yr1,mn1,dy1,0.,0.,0.,float(maxcat),1. - - if (save_sib) then - write(20) yr,mn,dy,0.,0.,0.,yr1,mn1,dy1,0.,0.,0.,float(maxcat),1. - write(21) yr,mn,dy,0.,0.,0.,yr1,mn1,dy1,0.,0.,0.,float(maxcat),1. - endif - - bf_modis_time = af_modis_time - call Get_MidTime(yr,mn,dy,yr1,mn1,dy1,af_modis_time) - calbvf =0. - calbnf =0. - albvf =0. - albnf =0. - tsteps =0. - endif - endif - end do - - deallocate (modisvf,modisnf,albvf,albnf) - deallocate (green,lai) - deallocate (vegcls) - deallocate (calbvf,calbnf) - deallocate (lai_before,grn_before, lai_after,grn_after) - deallocate (zero_array, one_array, albvr, albnr) - - close (10, status='keep') - close (11, status='keep') - close (30, status='keep') - close (31, status='keep') - if (save_sib) then - close (20, status='keep') - close (21, status='keep') - endif - -END SUBROUTINE modis_scale_para_high + call Get_MidTime(yr,mn,dy,yr1,mn1,dy1,af_modis_time) + calbvf =0. + calbnf =0. + albvf =0. + albnf =0. + tsteps =0. + endif + endif + end do ! while (datetime_le_refdatetime(date_time_new,end_time)) + + deallocate (modisvf,modisnf,albvf,albnf) + deallocate (green,lai) + deallocate (vegcls) + deallocate (calbvf,calbnf) + deallocate (lai_before,grn_before, lai_after,grn_after) + deallocate (zero_array, one_array, albvr, albnr) + + close (10, status='keep') + close (11, status='keep') + close (30, status='keep') + close (31, status='keep') + if (save_sib) then + close (20, status='keep') + close (21, status='keep') + endif + + END SUBROUTINE modis_scale_para_high + + ! + ! --------------------------------------------------------------------------------------- + ! + SUBROUTINE modis_alb_on_tiles_high( nc_data, nr_data, rmap, MA, n_tiles) -! -! --------------------------------------------------------------------------------------- -! - SUBROUTINE modis_alb_on_tiles_high( nc_data, nr_data, rmap, MA ) - ! process high-res MODIS albedo and create 8-day or 16-day climatological data in tile space - + implicit none integer, intent(in) :: nc_data, nr_data ! expected dimensions of global science data array type (regrid_map), intent(in) :: rmap ! structure for mapping from science data grid to tile space character*6, intent(in) :: MA ! MODIS albedo version string - + integer, intent(in) :: n_tiles + ! ------------------------------------------ - integer :: kk, nn, ii, jj, ncid, i_highd, j_highd, pix_count, N_tiles + integer :: kk, nn, ii, jj, ncid, i_highd, j_highd, pix_count integer :: status, iLL, jLL, iG, jG, ix, jx, nc_10, nr_10, n_tslices, tt integer :: time_slice, time_slice_next, yr, mn, dd, yr1, mn1, dd1 character*512 :: fname @@ -1938,20 +1834,14 @@ SUBROUTINE modis_alb_on_tiles_high( nc_data, nr_data, rmap, MA ) character(64) :: Iam = 'modis_alb_on_tiles_high' REAL :: sf - + ! ----------------------------------------------------------------------- ! - ! read number of catchment-tiles (N_tiles) from "catchment.def" file - - fname='clsm/catchment.def' - open( 10, file=fname, status='old', action='read', form='formatted') - read( 10, * ) N_tiles - close(10, status='keep') - + ! get some common dimensions and attributes from one of the 36-by-18 MODIS files - + call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) - + if (MA=='MODIS1') then fname =trim(MAKE_BCS_INPUT_DIR)//'/land/albedo/snowfree/MODIS/v1/MODISalb.c004.v2.WS_H11V13.nc' elseif (MA=='MODIS2') then @@ -1962,88 +1852,88 @@ SUBROUTINE modis_alb_on_tiles_high( nc_data, nr_data, rmap, MA ) end if status = NF_OPEN( trim(fname), NF_NOWRITE, ncid ); VERIFY_(STATUS) - + status = NF_GET_att_INT( ncid, NF_GLOBAL, 'N_lon_global', i_highd ); VERIFY_(STATUS) status = NF_GET_att_INT( ncid, NF_GLOBAL, 'N_lat_global', j_highd ); VERIFY_(STATUS) - + status = NF_INQ_DIM (ncid,1,string, nc_10); VERIFY_(STATUS) ! nc_10 = # grid cells in long dir status = NF_INQ_DIM (ncid,2,string, nr_10); VERIFY_(STATUS) ! nr_10 = # grid cells in lat dir status = NF_INQ_DIM (ncid,3,string, n_tslices); VERIFY_(STATUS) ! # time slices - + allocate(MMDD (0:n_tslices+1)) allocate(MMDD_next(0:n_tslices+1)) - + ! read variable #3 = MMDD = start month/day of time-averaging interval per MAPL_ReadForcing() convention - + status = NF_GET_VARA_text( ncid, 3, (/1,1/), (/4,n_tslices/), MMDD(1:n_tslices) ); VERIFY_(STATUS) status = NF_CLOSE(ncid); VERIFY_(STATUS) - + ! verify input nc_data and nr_data against global dimensions in nc4 file - + if(nc_data/=i_highd .or. nr_data/=j_highd) then print *, 'ERROR ', trim(Iam), '(): Inconsistent mapping and dimensions; stopping' stop end if - + ! "wrap around" for mmdd - + mmdd(0) = mmdd(n_tslices) mmdd(n_tslices+1) = mmdd(1) - + ! assemble mmdd_next - + mmdd_next( 0:n_tslices-1) = mmdd(1:n_tslices) mmdd_next(n_tslices:n_tslices+1) = mmdd(1:2) - + ! allocate arrays for gridded albedo data from one of the 36-by-18 MODIS files - + allocate(net_data1(1:nc_10,1:nr_10)) allocate(net_data2(1:nc_10,1:nr_10)) - + ! open *output* files - + if(MA == 'MODIS1') then open(31,file='clsm/AlbMap.WS.16-day.tile.0.3_0.7.dat', & form='unformatted',status='unknown',convert='little_endian') open(32,file='clsm/AlbMap.WS.16-day.tile.0.7_5.0.dat', & form='unformatted',status='unknown',convert='little_endian') endif - + if(MA == 'MODIS2') then open(31,file='clsm/AlbMap.WS.8-day.tile.0.3_0.7.dat', & form='unformatted',status='unknown',convert='little_endian') open(32,file='clsm/AlbMap.WS.8-day.tile.0.7_5.0.dat', & form='unformatted',status='unknown',convert='little_endian') endif - + ! allocate data vectors in tile space - + allocate(vec_AlbVis( N_tiles)) allocate(count_AlbVis(N_tiles)) allocate(vec_AlbNir( N_tiles)) allocate(count_AlbNir(N_tiles)) - + do tt=0,n_tslices+1 ! get time stamp for MAPL_Readforcing convention - + ! yr, mn, dd = year/month/day at end of averaging interval in current time slice ! yr1, mn1, dd1 = year/month/day at start of averaging interval in current time slice - + ! initialize time_slice = tt yr = 1 yr1 = 1 - + ! deal with wrap-around for tt=0, tt=n_tslices, and tt=n_tslices+1 - + if (tt == 0) then time_slice = n_tslices yr = 0 endif - + if (tt >= n_tslices) then yr1 = 2 if (tt==n_tslices+1) then @@ -2051,26 +1941,26 @@ SUBROUTINE modis_alb_on_tiles_high( nc_data, nr_data, rmap, MA ) yr = 2 endif endif - + ! convert mmdd string to integers for month (mn) and day (dd) - + read(mmdd( tt),'(i2.2,i2.2)') mn, dd read(mmdd_next(tt),'(i2.2,i2.2)') mn1, dd1 - + ! initialize data vectors in tile space - + vec_AlbVis = 0. count_AlbVis = 0. vec_AlbNir = 0. count_AlbNir = 0. - + ! loop through 36-by-18 MODIS files - - do jx = 1,18 + + do jx = 1,18 do ix = 1,36 ! open MODIS file (ix,jx) - + write (vv,'(i2.2)')jx write (hh,'(i2.2)')ix @@ -2080,39 +1970,39 @@ SUBROUTINE modis_alb_on_tiles_high( nc_data, nr_data, rmap, MA ) status = NF_OPEN(trim(fname),NF_NOWRITE, ncid) if(status == 0) then - + ! read attributes (global i,j indices of first grid cell in chunk of data in this MODIS file) - + status = NF_GET_att_INT( ncid, NF_GLOBAL, 'i_ind_offset_LL', iLL ); VERIFY_(STATUS) status = NF_GET_att_INT( ncid, NF_GLOBAL, 'j_ind_offset_LL', jLL ); VERIFY_(STATUS) - + ! assume scale factor (sf) is same for Vis and NIR albedo - + status = NF_GET_att_REAL( ncid, 4, 'ScaleFactor', sf ); VERIFY_(STATUS) - + ! read chunk of MODIS data in file ! ! variable #4 = net_data1 = Alb_0.3_0.7 = visible (Vis) albedo ! variable #5 = net_data2 = Alb_0.7_5.0 = near-infrared (NIR) albedo - + status = NF_GET_VARA_INT( ncid, 4, (/1,1,time_slice/), (/nc_10,nr_10,1/), net_data1 ); VERIFY_(STATUS) status = NF_GET_VARA_INT( ncid, 5, (/1,1,time_slice/), (/nc_10,nr_10,1/), net_data2 ); VERIFY_(STATUS) - + ! loop through grid cells of this file's albedo science data and add into tile-space data vectors; ! keep count of how many (original) raster grid cells contribute (note that this integer count ! does not allow for fractional coverage of raster grid cells by the science data value and ! therefore is approximate) - + do jj=1,nr_10 do ii=1,nc_10 - + iG = ii+iLL-1 ! i-index relative to *global* 30-arcsec grid jG = jj+jLL-1 ! j-index relative to *global* 30-arcsec grid - + pix_count = rmap%ij_index(iG,jG) - + if (pix_count ==0) cycle - + if(net_data1(ii,jj) > 0) then if(rmap%map(pix_count)%nt > 0) then do kk = 1, rmap%map(pix_count)%nt @@ -2135,2542 +2025,2430 @@ SUBROUTINE modis_alb_on_tiles_high( nc_data, nr_data, rmap, MA ) endif enddo enddo - + status = NF_CLOSE(ncid) endif end do end do - + ! finalize remapping - + DO nn =1,N_tiles if(count_AlbVis(nn)/=0.) vec_AlbVis(nn)=vec_AlbVis(nn)/count_AlbVis(nn) if(count_AlbNir(nn)/=0.) vec_AlbNir(nn)=vec_AlbNir(nn)/count_AlbNir(nn) END DO - + ! write to file (MAPL_ReadForcing convention) - + write(31) float((/yr,mn,dd,0,0,0,yr1,mn1,dd1,0,0,0,N_tiles,1/)) write(31) vec_AlbVis(:) write(32) float((/yr,mn,dd,0,0,0,yr1,mn1,dd1,0,0,0,N_tiles,1/)) write(32) vec_AlbNir(:) - + end do ! do tt=0,n_tslices+1 - + close(31,status='keep') close(32,status='keep') - + deallocate( net_data1, net_data2 ) deallocate( count_AlbVis, count_AlbNir ) deallocate( vec_AlbVis, vec_AlbNir ) - + END SUBROUTINE modis_alb_on_tiles_high + + ! --------------------------------------------------------------------------------------- -! --------------------------------------------------------------------------------------- -! - SUBROUTINE hres_lai (nx,ny,fnameRst,lai_name,merge) +! SUBROUTINE hres_lai (nx,ny, maxcat,fnameRst,lai_name,merge) +! ! +! ! Processing GEOLAND2/MODIS LAI and creating 10-day climatological data +! ! +! implicit none +! integer, intent (in) :: nx, ny, maxcat +! character(*) :: fnameRst,lai_name +! integer, intent(in), optional :: merge +! integer :: n,i,j,k,ncid,i_highd,j_highd,nx_adj,ny_adj,ierr +! integer :: status,iLL,jLL,ix,jx,vid,nc_10,nr_10,n_tslices,d_undef,t, & +! time_slice,time_slice_next,yr,mn,dd,yr1,mn1,dd1,i1,i2 +! real :: dum, gyr,gmn,gdy,gyr1,gmn1,gdy1, slice1,slice2 +! character*100 :: fout +! character*200 :: fname +! character*10 :: string +! character*2 :: VV,HH +! integer, allocatable, dimension (:,:) :: & +! net_data1 +! integer (kind=2) , allocatable, target, dimension (:,:) :: LAI_HIGH +! integer (kind=2), pointer, dimension (:,:) :: Raster +! REAL, ALLOCATABLE, dimension (:) :: vec_lai, count_lai +! REAL, ALLOCATABLE, dimension (:) :: gswp2_lai_bf,gswp2_lai_af,gswp2_lai +! integer, allocatable, target, dimension (:,:) :: tile_id +! integer, pointer :: iRaster(:,:) +! character(len=4), dimension (:), allocatable :: MMDD, MMDD_next +! logical :: regrid +! REAL :: sf +! logical :: first_entry = .true. +! type (date_time_type) :: bf_gswp2_time,af_gswp2_time,date_time_new,bf_lai_time, & +! af_lai_time +! ! +! if (first_entry) then +! nullify(iraster) ; first_entry = .false. +! end if ! -! Processing GEOLAND2/MODIS LAI and creating 10-day climatological data +! call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) +! fname =trim(MAKE_BCS_INPUT_DIR)//'/land/veg/lai_grn/v2/'//trim(lai_name)//'lai_clim.H11V13.nc' +! status = NF_OPEN(trim(fname),NF_NOWRITE, ncid); VERIFY_(STATUS) +! status = NF_GET_att_INT(ncid,NF_GLOBAL,'i_ind_offset_LL',iLL); VERIFY_(STATUS) +! status = NF_GET_att_INT(ncid,NF_GLOBAL,'j_ind_offset_LL',jLL); VERIFY_(STATUS) +! status = NF_GET_att_INT(ncid,NF_GLOBAL,'N_lon_global',i_highd); VERIFY_(STATUS) +! status = NF_GET_att_INT(ncid,NF_GLOBAL,'N_lat_global',j_highd); VERIFY_(STATUS) +! status = NF_INQ_DIM (ncid,1,string, nc_10); VERIFY_(STATUS) +! status = NF_INQ_DIM (ncid,2,string, nr_10); VERIFY_(STATUS) +! status = NF_INQ_DIM (ncid,3,string, n_tslices); VERIFY_(STATUS) +! allocate (MMDD (0: n_tslices + 1)) +! allocate (MMDD_next (0: n_tslices + 1)) ! - implicit none - integer, intent (in) :: nx, ny - character(*) :: fnameRst,lai_name - integer, intent(in), optional :: merge - integer :: n,maxcat,i,j,k,ncid,i_highd,j_highd,nx_adj,ny_adj,ierr - integer :: status,iLL,jLL,ix,jx,vid,nc_10,nr_10,n_tslices,d_undef,t, & - time_slice,time_slice_next,yr,mn,dd,yr1,mn1,dd1,i1,i2 - real :: dum, gyr,gmn,gdy,gyr1,gmn1,gdy1, slice1,slice2 - character*100 :: fout - character*200 :: fname - character*10 :: string - character*2 :: VV,HH - integer, allocatable, dimension (:,:) :: & - net_data1 - integer (kind=2) , allocatable, target, dimension (:,:) :: LAI_HIGH - integer (kind=2), pointer, dimension (:,:) :: Raster - REAL, ALLOCATABLE, dimension (:) :: vec_lai, count_lai - REAL, ALLOCATABLE, dimension (:) :: gswp2_lai_bf,gswp2_lai_af,gswp2_lai - integer, allocatable, target, dimension (:,:) :: tile_id - integer, pointer :: iRaster(:,:) - character(len=4), dimension (:), allocatable :: MMDD, MMDD_next - logical :: regrid - REAL :: sf - logical :: first_entry = .true. - type (date_time_type) :: bf_gswp2_time,af_gswp2_time,date_time_new,bf_lai_time, & - af_lai_time +! status = NF_GET_VARA_text(ncid, 3,(/1,1/),(/4,n_tslices/),MMDD(1:n_tslices)); VERIFY_(STATUS) +! status = NF_CLOSE(ncid); VERIFY_(STATUS) ! -! Reading number of cathment-tiles from catchment.def file -!--------------------------------------------------------- - if (first_entry) then - nullify(iraster) ; first_entry = .false. - end if - - fname='clsm/catchment.def' - open (10,file=fname,status='old',action='read',form='formatted') - read(10,*) maxcat - close (10,status='keep') - - call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) - fname =trim(MAKE_BCS_INPUT_DIR)//'/land/veg/lai_grn/v2/'//trim(lai_name)//'lai_clim.H11V13.nc' - status = NF_OPEN(trim(fname),NF_NOWRITE, ncid); VERIFY_(STATUS) - status = NF_GET_att_INT(ncid,NF_GLOBAL,'i_ind_offset_LL',iLL); VERIFY_(STATUS) - status = NF_GET_att_INT(ncid,NF_GLOBAL,'j_ind_offset_LL',jLL); VERIFY_(STATUS) - status = NF_GET_att_INT(ncid,NF_GLOBAL,'N_lon_global',i_highd); VERIFY_(STATUS) - status = NF_GET_att_INT(ncid,NF_GLOBAL,'N_lat_global',j_highd); VERIFY_(STATUS) - status = NF_INQ_DIM (ncid,1,string, nc_10); VERIFY_(STATUS) - status = NF_INQ_DIM (ncid,2,string, nr_10); VERIFY_(STATUS) - status = NF_INQ_DIM (ncid,3,string, n_tslices); VERIFY_(STATUS) - allocate (MMDD (0: n_tslices + 1)) - allocate (MMDD_next (0: n_tslices + 1)) - - status = NF_GET_VARA_text(ncid, 3,(/1,1/),(/4,n_tslices/),MMDD(1:n_tslices)); VERIFY_(STATUS) - status = NF_CLOSE(ncid); VERIFY_(STATUS) - - mmdd(0) = mmdd(n_tslices) - mmdd(n_tslices + 1)= mmdd(1) - - mmdd_next(0:n_tslices - 1) = mmdd(1:n_tslices) - mmdd_next(n_tslices: n_tslices + 1) = mmdd (1:2) - - - allocate(tile_id(1:nx,1:ny)) - allocate(net_data1 (1:nc_10,1:nr_10)) - - fname=trim(fnameRst)//'.rst' - ! - ! Reading tile-id raster file - ! - open (10,file=fname,status='old',action='read', & - form='unformatted',convert='little_endian') - - do j=1,ny - read(10)tile_id(:,j) - end do - - close (10,status='keep') - - ! - ! writing GEOLAND2 LAI data - ! - - if(present(merge)) then - open (31,file='clsm/lai.'//lai_name(1:index(lai_name,'/')-1), & - form='unformatted',status='unknown',convert='little_endian') - else - open (31,file='clsm/lai.dat', & - form='unformatted',status='unknown',convert='little_endian') - endif - - allocate(vec_lai(maxcat)) - allocate(lai_high(1:i_highd,1:j_highd)) - allocate(count_lai(1:maxcat)) - allocate(gswp2_lai_bf (1:maxcat)) - allocate(gswp2_lai_af (1:maxcat)) - allocate(gswp2_lai (1:maxcat)) - - ! - ! reading GSWP2 LAI data - ! - - open (41,file='clsm/lai.gswp2', & - form='unformatted',status='old',convert='little_endian',action='read') - read(41) gyr,gmn,gdy,dum,dum,dum,gyr1,gmn1,gdy1 - read(41) gswp2_lai_bf - call Get_MidTime(gyr,gmn,gdy,gyr1,gmn1,gdy1,bf_gswp2_time) - - read(41) gyr,gmn,gdy,dum,dum,dum,gyr1,gmn1,gdy1 - read(41) gswp2_lai_af - call Get_MidTime(gyr,gmn,gdy,gyr1,gmn1,gdy1,af_gswp2_time) - - do t =0,n_tslices+1 - - time_slice = t - yr = 1 - yr1= 1 - if(t == 0) then - time_slice = n_tslices - yr = 1 - 1 - endif - - if(t >= n_tslices) then - yr1 = 1 + 1 - if(t ==n_tslices + 1) then - time_slice = 1 - yr = 1 + 1 - endif - endif - - read(mmdd(t),'(i2.2,i2.2)') mn,dd - read(mmdd_next(t),'(i2.2,i2.2)') mn1,dd1 - - lai_high = -9999 - - do jx = 1,18 - do ix = 1,36 - write (vv,'(i2.2)')jx - write (hh,'(i2.2)')ix - fname = trim(MAKE_BCS_INPUT_DIR)//'/land/veg/lai_grn/v2/'//trim(lai_name)//'lai_clim.H'//hh//'V'//vv//'.nc' - status = NF_OPEN(trim(fname),NF_NOWRITE, ncid) - if(status == 0) then - status = NF_GET_att_INT (ncid,NF_GLOBAL,'i_ind_offset_LL',iLL); VERIFY_(STATUS) - status = NF_GET_att_INT (ncid,NF_GLOBAL,'j_ind_offset_LL',jLL); VERIFY_(STATUS) - status = NF_GET_att_INT (ncid,4,'UNDEF',d_undef); VERIFY_(STATUS) - status = NF_GET_att_REAL (ncid,4,'ScaleFactor',sf); VERIFY_(STATUS) - status = NF_GET_VARA_INT (ncid, 4,(/1,1,time_slice/),(/nc_10,nr_10,1/),net_data1); VERIFY_(STATUS) - - do j = jLL,jLL + nr_10 -1 - do i = iLL, iLL + nc_10 -1 - if(net_data1(i-iLL +1 ,j - jLL +1) /= d_undef) & - lai_high(i,j) = net_data1(i-iLL +1 ,j - jLL +1) - enddo - enddo - status = NF_CLOSE(ncid) - endif - end do - end do - - ! Regridding - - nx_adj = nx - ny_adj = ny - - regrid = nx/=i_highd .or. ny/=j_highd - - if(regrid) then - if(nx > i_highd) then - allocate(raster(nx,ny),stat=STATUS); VERIFY_(STATUS) - call RegridRaster2(lai_high,raster) - iRaster => tile_id - if(ny < j_highd) then - print *,'nx > i_highd and ny < j_highd' - stop - endif - else - if(.not. associated(iraster)) then - allocate(iraster(i_highd,j_highd),stat=STATUS); VERIFY_(STATUS) - endif - -! if( associated(iraster)) deallocate(iraster) -! allocate(iraster(i_highd,j_highd),stat=STATUS); VERIFY_(STATUS) - call RegridRaster(tile_id,iraster) - raster => lai_high - nx_adj = i_highd - ny_adj = j_highd - - if(ny > j_highd) then - print *,'nx < i_highd and ny > j_highd' - stop - endif - endif - else - raster => lai_high - iRaster => tile_id - end if - - ! Interpolation or aggregation on to catchment-tiles - - vec_lai =0. - count_lai = 0. - - do j=1,ny_adj - do i=1,nx_adj - if((iRaster(i,j).gt.0).and.(iRaster(i,j).le.maxcat)) then - if ((raster(i,j).ge.0)) then - vec_lai(iRaster(i,j)) = & - vec_lai(iRaster(i,j)) + sf*raster(i,j) - count_lai(iRaster(i,j)) = & - count_lai(iRaster(i,j)) + 1. - endif - endif - end do - end do - - write(31) float((/yr,mn,dd,0,0,0,yr1,mn1,dd1,0,0,0,maxcat,1/)) - call Get_MidTime(real(yr),real(mn),real(dd),real(yr1),real(mn1),real(dd1),date_time_new) -! date_time_new%year = yr + 2001 -! date_time_new%month = mn -! date_time_new%day = dd -! date_time_new%hour = 0 -! date_time_new%min = 0 -! date_time_new%sec = 0 -! call get_dofyr_pentad(date_time_new) - - if (datetime_le_refdatetime(date_time_new,af_gswp2_time)) then - - else - read(41,IOSTAT=ierr) gyr,gmn,gdy,dum,dum,dum,gyr1,gmn1,gdy1 - if(ierr == 0) then - gswp2_lai_bf = gswp2_lai_af - read(41) gswp2_lai_af - bf_gswp2_time = af_gswp2_time - call Get_MidTime(gyr,gmn,gdy,gyr1,gmn1,gdy1,af_gswp2_time) - else - print *,'END OF GSWP2 LAI FILE' - stop - endif - endif - - call Time_Interp_Fac (date_time_new, bf_gswp2_time, af_gswp2_time, slice1, slice2) - gswp2_lai = (slice1*gswp2_lai_bf + slice2*gswp2_lai_af) - -! print *, 'Merging GEOLAND2-AVHRR' -! print *, bf_gswp2_time -! print *, date_time_new -! print *, af_gswp2_time -! print *, slice1, slice2 -! print *, maxval(gswp2_lai), minval(gswp2_lai) - - DO n =1,maxcat - if(count_lai(n)/=0.) vec_lai(n)= vec_lai(n)/count_lai(n) - if(vec_lai(n)==0.) vec_lai(n) = gswp2_lai(n) - END DO - - write(31) vec_lai(:) - end do - close(31,status='keep') - close(41,status='keep') - - deallocate (net_data1) - deallocate (LAI_HIGH) - deallocate (count_lai) - deallocate (vec_lai, iRaster) - deallocate (gswp2_lai_bf,gswp2_lai_af,gswp2_lai, tile_id) - - END SUBROUTINE hres_lai +! mmdd(0) = mmdd(n_tslices) +! mmdd(n_tslices + 1)= mmdd(1) ! -! --------------------------------------------------------------------------------------- -! - SUBROUTINE grid2tile_modis6 (nc_data,nr_data,ncol,nrow,fnameRst,lai_name) +! mmdd_next(0:n_tslices - 1) = mmdd(1:n_tslices) +! mmdd_next(n_tslices: n_tslices + 1) = mmdd (1:2) ! -! Processing GEOLAND2/MODIS LAI and creating 10-day climatological data ! - implicit none - integer, intent (in) :: nc_data,nr_data, ncol,nrow - real, parameter :: dxy = 1. - integer :: QSize - character(*) :: fnameRst,lai_name - integer :: n,maxcat,i,j,k,ncid,i_highd,j_highd,nx_adj,ny_adj,ierr,nx,ny - integer :: status,iLL,jLL,ix,jx,vid,nc_10,nr_10,n_tslices,d_undef,t, & - time_slice,time_slice_next,yr,mn,dd,yr1,mn1,dd1,i1,i2,tindex1,pfaf1 - character*100 :: fout - character*200 :: fname - character*10 :: string - character*2 :: VV,HH - integer, allocatable, target, dimension (:,:) :: net_data1 - integer, pointer, dimension (:,:) :: QSub - real, pointer, dimension (:,:) :: subset - REAL, ALLOCATABLE, dimension (:) :: vec_lai, count_lai,tile_lon, tile_lat & - , x, y !, distance - real, allocatable, target, dimension (:,:) :: lai_grid - INTEGER ::imn,imx,jmn,jmx,mval,d1,d2,l - character(len=4), dimension (:), allocatable :: MMDD, MMDD_next - logical :: regrid - REAL :: sf, dum,dist_save,tile_distance,minlat,maxlat,minlon,maxlon - logical :: first_entry = .true. - type (date_time_type) :: date_time_new,bf_lai_time, & - af_lai_time - integer, dimension (:,:), allocatable, target :: tile_id - integer :: tileid_tile - real :: dxm, dym -! Reading rst file -!----------------- - open (10,file=trim(fnameRst)//'.rst',status='old',action='read', & - form='unformatted',convert='little_endian') - allocate (tile_id (1:ncol,1:nrow)) - - do j=1,nrow - read(10)tile_id(:,j) - end do - close (10,status='keep') - - dxm = real(nc_data) /real(ncol) - dym = real(nr_data) /real(nrow) - - if ((mod( nc_data, ncol) /= 0).OR. (mod( nc_data, ncol) /= 0)) then - print *, 'For now, 86400 should be evenly divisible by NC Talk to Sarith' - stop - endif +! allocate(tile_id(1:nx,1:ny)) +! allocate(net_data1 (1:nc_10,1:nr_10)) ! -! Reading number of cathment-tiles from catchment.def file -!_________________________________________________________ +! fname=trim(fnameRst)//'.rst' +! ! +! ! Reading tile-id raster file +! ! +! open (10,file=fname,status='old',action='read', & +! form='unformatted',convert='little_endian') ! - fname='clsm/catchment.def' - open (10,file=fname,status='old',action='read',form='formatted') - read(10,*) maxcat - allocate (tile_lon(1:maxcat)) - allocate (tile_lat(1:maxcat)) - - do n = 1, maxcat - read (10,*) tindex1,pfaf1,minlon,maxlon,minlat,maxlat - tile_lon(n) = (minlon + maxlon)/2. - tile_lat(n) = (minlat + maxlat)/2. - end do - close (10,status='keep') - - call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) - fname =trim(MAKE_BCS_INPUT_DIR)//'/land/veg/lai_grn/v3/'//trim(lai_name)//'lai_clim.H11V13.nc' - status = NF_OPEN(trim(fname),NF_NOWRITE, ncid); VERIFY_(STATUS) - status = NF_GET_att_INT(ncid,NF_GLOBAL,'i_ind_offset_LL',iLL); VERIFY_(STATUS) - status = NF_GET_att_INT(ncid,NF_GLOBAL,'j_ind_offset_LL',jLL); VERIFY_(STATUS) - status = NF_GET_att_INT(ncid,NF_GLOBAL,'N_lon_global',i_highd); VERIFY_(STATUS) - status = NF_GET_att_INT(ncid,NF_GLOBAL,'N_lat_global',j_highd); VERIFY_(STATUS) - status = NF_INQ_DIM (ncid,1,string, nc_10); VERIFY_(STATUS) - status = NF_INQ_DIM (ncid,2,string, nr_10); VERIFY_(STATUS) - status = NF_INQ_DIM (ncid,3,string, n_tslices); VERIFY_(STATUS) - allocate (MMDD (0: n_tslices + 1)) - allocate (MMDD_next (0: n_tslices + 1)) - - status = NF_GET_VARA_text(ncid, 3,(/1,1/),(/4,n_tslices/),MMDD(1:n_tslices)); VERIFY_(STATUS) - status = NF_CLOSE(ncid); VERIFY_(STATUS) - - if(nc_data/=i_highd .or. nr_data/=j_highd) then - print *,'Inconsistent mapping and dimensions in hres_lai_no_gswp -so stopping ...' - stop - end if - - mmdd(0) = mmdd(n_tslices) - mmdd(n_tslices + 1)= mmdd(1) - - mmdd_next(0:n_tslices - 1) = mmdd(1:n_tslices) - mmdd_next(n_tslices: n_tslices + 1) = mmdd (1:2) - - - allocate(net_data1 (1:nc_10,1:nr_10)) - - ! writing MODIS6 - ! - open (31,file='clsm/lai.dat', & - form='unformatted',status='unknown',convert='little_endian') - - allocate (vec_lai (maxcat)) - allocate (count_lai (1:maxcat)) - -! allocate (vec_fill (maxcat)) -! allocate (distance (maxcat)) -! allocate (vec_lai_save(maxcat)) -! vec_fill = 0 - - nx = nint (360./dxy) - ny = nint (180./dxy) - allocate (x(1:nx)) - allocate (y(1:ny)) - - FORALL (i = 1:nx) x(i) = -180. + dxy/2. + (i-1)*dxy - FORALL (i = 1:ny) y(i) = -90. + dxy/2. + (i-1)*dxy - - allocate (lai_grid (1 : nx, 1 : ny)) - - QSize = nint(dxy*nc_data/360.) -! allocate (QSub (1:QSize,1:QSize)) - - do t =0,n_tslices+1 - - time_slice = t - yr = 1 - yr1= 1 - if(t == 0) then - time_slice = n_tslices - yr = 1 - 1 - endif - - if(t >= n_tslices) then - yr1 = 1 + 1 - if(t ==n_tslices + 1) then - time_slice = 1 - yr = 1 + 1 - endif - endif - - read(mmdd(t),'(i2.2,i2.2)') mn,dd - read(mmdd_next(t),'(i2.2,i2.2)') mn1,dd1 - - ! Reading Interpolation or aggregation on to catchment-tiles - - vec_lai = -9999. - count_lai = 0. - lai_grid = -9999 - - do jx = 1,18 - do ix = 1,36 - write (vv,'(i2.2)')jx - write (hh,'(i2.2)')ix - fname = trim(MAKE_BCS_INPUT_DIR)//'/land/veg/lai_grn/v3/'//trim(lai_name)//'lai_clim.H'//hh//'V'//vv//'.nc' - status = NF_OPEN(trim(fname),NF_NOWRITE, ncid) - if(status == 0) then - status = NF_GET_att_INT (ncid,NF_GLOBAL,'i_ind_offset_LL',iLL); VERIFY_(STATUS) - status = NF_GET_att_INT (ncid,NF_GLOBAL,'j_ind_offset_LL',jLL); VERIFY_(STATUS) - status = NF_GET_att_INT (ncid,4,'UNDEF',d_undef); VERIFY_(STATUS) - status = NF_GET_att_REAL (ncid,4,'ScaleFactor',sf); VERIFY_(STATUS) - status = NF_GET_VARA_INT (ncid, 4,(/1,1,time_slice/),(/nc_10,nr_10,1/),net_data1); VERIFY_(STATUS) - - do j = jLL,jLL + nr_10 -1 - do i = iLL, iLL + nc_10 -1 - if(net_data1(i-iLL +1 ,j - jLL +1) /= d_undef) then - tileid_tile = tile_id (ceiling(i/dxm), ceiling (j/dym)) - if((tileid_tile >= 1).and.(tileid_tile <= maxcat)) then - if(vec_lai(tileid_tile) == -9999.) vec_lai(tileid_tile) = 0. - vec_lai(tileid_tile) = vec_lai(tileid_tile) + & - sf*net_data1(i-iLL +1 ,j - jLL +1) - count_lai(tileid_tile) = & - count_lai(tileid_tile) + 1. - endif - endif - enddo - enddo - -! After experimenting with few finer methods, in order to reduce the time taken by the gap filling procedure, -! creating a 0.25-degree gridded data set from finer LAI data and use it for filling the gaps seems the most practical/manageble method. -!--------------------------------------------------------------------------------------------------------------------------------------- - do j = ceiling(1.*jLL/QSize),ceiling(1.*jLL/QSize) -1 + nr_10/QSize - do i = ceiling(1.*iLL/QSize),ceiling(1.*iLL/QSize) -1 + nc_10/QSize - QSub => net_data1((i-1)*QSize+2-iLL :i*QSize-iLL+1, (j-1)*QSize+2-jLL :j*QSize-jLL+1) - if(maxval (QSub) > 0) lai_grid(i,j) = sf*sum(QSub, QSub>0)/(max(1,count(QSub>0))) - enddo - enddo - status = NF_CLOSE(ncid) - endif - end do - end do - - NULLIFY (QSub) - - write(31) float((/yr,mn,dd,0,0,0,yr1,mn1,dd1,0,0,0,maxcat,1/)) - - where (count_lai > 0.) vec_lai = vec_lai/count_lai - -! Filling gaps -!------------- - DO n =1,maxcat - if(count_lai(n)==0.) then - - DO i = 1,nx - 1 - if ((tile_lon(n) >= x(i)).and.(tile_lon(n) < x(i+1))) ix = i - end do - DO i = 1,ny -1 - if ((tile_lat(n) >= y(i)).and.(tile_lat(n) < y(i+1))) jx = i - end do - - l = 1 - do - imx=ix + l - imn=ix - l - jmn=jx - l - jmx=jx + l - imn=MAX(imn,1) - jmn=MAX(jmn,1) - imx=MIN(imx,nx) - jmx=MIN(jmx,ny) - d1=imx-imn+1 - d2=jmx-jmn+1 - subset => lai_grid(imn: imx,jmn:jmx) - - if(maxval(subset) > 0.) then - vec_lai (n) = sum(subset, subset>0.)/(max(1,count(subset>0.))) - exit - endif - l = l + 1 - NULLIFY (subset) - end do - endif - END DO - write(31) vec_lai(:) - end do - close(31,status='keep') - - deallocate (net_data1, tile_id) - deallocate (count_lai) - deallocate (vec_lai) - deallocate (tile_lat,tile_lon) - - END SUBROUTINE grid2tile_modis6 - +! do j=1,ny +! read(10)tile_id(:,j) +! end do ! -! --------------------------------------------------------------------------------------- -! - SUBROUTINE hres_lai_no_gswp (nc_data,nr_data,rmap,lai_name, merge) +! close (10,status='keep') ! -! Processing GEOLAND2/MODIS LAI and creating 10-day climatological data +! ! +! ! writing GEOLAND2 LAI data +! ! ! - implicit none - integer, intent (in) :: nc_data,nr_data - real, parameter :: dxy = 1. - integer :: QSize - type (regrid_map), intent (in) :: rmap - character(*) :: lai_name - integer, intent(in), optional :: merge - integer :: n,maxcat,i,j,k,ncid,i_highd,j_highd,nx_adj,ny_adj,ierr,nx,ny - integer :: status,iLL,jLL,ix,jx,vid,nc_10,nr_10,n_tslices,d_undef,t, & - time_slice,time_slice_next,yr,mn,dd,yr1,mn1,dd1,i1,i2,tindex1,pfaf1 - character*100 :: fout - character*200 :: fname - character*10 :: string - character*2 :: VV,HH - integer, allocatable, target, dimension (:,:) :: net_data1 - integer, pointer, dimension (:,:) :: QSub - real, pointer, dimension (:,:) :: subset - REAL, ALLOCATABLE, dimension (:) :: vec_lai, count_lai,tile_lon, tile_lat & - , x, y !, distance - real, allocatable, target, dimension (:,:) :: lai_grid - INTEGER ::imn,imx,jmn,jmx,mval,d1,d2,l,pix_count - character(len=4), dimension (:), allocatable :: MMDD, MMDD_next - logical :: regrid - REAL :: sf, dum,dist_save,tile_distance,minlat,maxlat,minlon,maxlon - logical :: first_entry = .true. - type (date_time_type) :: date_time_new,bf_lai_time, & - af_lai_time - -! Reading rst file -!----------------- -! open (10,file=trim(fnameRst)//'.rst',status='old',action='read', & -! form='unformatted',convert='little_endian') -! allocate (tile_id (1:nx,1:ny)) -! -! do j=1,ny -! read(10)tile_id(:,j) -! end do -! close (10,status='keep') +! if(present(merge)) then +! open (31,file='clsm/lai.'//lai_name(1:index(lai_name,'/')-1), & +! form='unformatted',status='unknown',convert='little_endian') +! else +! open (31,file='clsm/lai.dat', & +! form='unformatted',status='unknown',convert='little_endian') +! endif ! +! allocate(vec_lai(maxcat)) +! allocate(lai_high(1:i_highd,1:j_highd)) +! allocate(count_lai(1:maxcat)) +! allocate(gswp2_lai_bf (1:maxcat)) +! allocate(gswp2_lai_af (1:maxcat)) +! allocate(gswp2_lai (1:maxcat)) ! -! Reading number of cathment-tiles from catchment.def file -!_________________________________________________________ +! ! +! ! reading GSWP2 LAI data +! ! ! - fname='clsm/catchment.def' - open (10,file=fname,status='old',action='read',form='formatted') - read(10,*) maxcat - allocate (tile_lon(1:maxcat)) - allocate (tile_lat(1:maxcat)) - - do n = 1, maxcat - read (10,*) tindex1,pfaf1,minlon,maxlon,minlat,maxlat - tile_lon(n) = (minlon + maxlon)/2. - tile_lat(n) = (minlat + maxlat)/2. - end do - close (10,status='keep') - - call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) - fname =trim(MAKE_BCS_INPUT_DIR)//'/land/veg/lai_grn/v2/'//trim(lai_name)//'lai_clim.H11V13.nc' - status = NF_OPEN(trim(fname),NF_NOWRITE, ncid); VERIFY_(STATUS) - status = NF_GET_att_INT(ncid,NF_GLOBAL,'i_ind_offset_LL',iLL); VERIFY_(STATUS) - status = NF_GET_att_INT(ncid,NF_GLOBAL,'j_ind_offset_LL',jLL); VERIFY_(STATUS) - status = NF_GET_att_INT(ncid,NF_GLOBAL,'N_lon_global',i_highd); VERIFY_(STATUS) - status = NF_GET_att_INT(ncid,NF_GLOBAL,'N_lat_global',j_highd); VERIFY_(STATUS) - status = NF_INQ_DIM (ncid,1,string, nc_10); VERIFY_(STATUS) - status = NF_INQ_DIM (ncid,2,string, nr_10); VERIFY_(STATUS) - status = NF_INQ_DIM (ncid,3,string, n_tslices); VERIFY_(STATUS) - allocate (MMDD (0: n_tslices + 1)) - allocate (MMDD_next (0: n_tslices + 1)) - - status = NF_GET_VARA_text(ncid, 3,(/1,1/),(/4,n_tslices/),MMDD(1:n_tslices)); VERIFY_(STATUS) - status = NF_CLOSE(ncid); VERIFY_(STATUS) - - if(nc_data/=i_highd .or. nr_data/=j_highd) then - print *,'Inconsistent mapping and dimensions in hres_lai_no_gswp -so stopping ...' - stop - end if - - mmdd(0) = mmdd(n_tslices) - mmdd(n_tslices + 1)= mmdd(1) - - mmdd_next(0:n_tslices - 1) = mmdd(1:n_tslices) - mmdd_next(n_tslices: n_tslices + 1) = mmdd (1:2) - - - allocate(net_data1 (1:nc_10,1:nr_10)) - - ! - ! writing MODIS/GEOLAND2 LAI data - ! - - if(present(merge)) then - open (31,file='clsm/lai.'//lai_name(1:index(lai_name,'/')-1), & - form='unformatted',status='unknown',convert='little_endian') - else - open (31,file='clsm/lai.dat', & - form='unformatted',status='unknown',convert='little_endian') - endif - - allocate (vec_lai (maxcat)) - allocate (count_lai (1:maxcat)) - -! allocate (vec_fill (maxcat)) -! allocate (distance (maxcat)) -! allocate (vec_lai_save(maxcat)) -! vec_fill = 0 - - nx = nint (360./dxy) - ny = nint (180./dxy) - allocate (x(1:nx)) - allocate (y(1:ny)) - - FORALL (i = 1:nx) x(i) = -180. + dxy/2. + (i-1)*dxy - FORALL (i = 1:ny) y(i) = -90. + dxy/2. + (i-1)*dxy - - allocate (lai_grid (1 : nx, 1 : ny)) - - QSize = nint(dxy*nc_data/360.) -! allocate (QSub (1:QSize,1:QSize)) - - do t =0,n_tslices+1 - - time_slice = t - yr = 1 - yr1= 1 - if(t == 0) then - time_slice = n_tslices - yr = 1 - 1 - endif - - if(t >= n_tslices) then - yr1 = 1 + 1 - if(t ==n_tslices + 1) then - time_slice = 1 - yr = 1 + 1 - endif - endif - - read(mmdd(t),'(i2.2,i2.2)') mn,dd - read(mmdd_next(t),'(i2.2,i2.2)') mn1,dd1 - - ! Reading Interpolation or aggregation on to catchment-tiles - - vec_lai = -9999. - count_lai = 0. - lai_grid = -9999 - - do jx = 1,18 - do ix = 1,36 - write (vv,'(i2.2)')jx - write (hh,'(i2.2)')ix - fname = trim(MAKE_BCS_INPUT_DIR)//'/land/veg/lai_grn/v2/'//trim(lai_name)//'lai_clim.H'//hh//'V'//vv//'.nc' - status = NF_OPEN(trim(fname),NF_NOWRITE, ncid) - if(status == 0) then - status = NF_GET_att_INT (ncid,NF_GLOBAL,'i_ind_offset_LL',iLL); VERIFY_(STATUS) - status = NF_GET_att_INT (ncid,NF_GLOBAL,'j_ind_offset_LL',jLL); VERIFY_(STATUS) - status = NF_GET_att_INT (ncid,4,'UNDEF',d_undef); VERIFY_(STATUS) - status = NF_GET_att_REAL (ncid,4,'ScaleFactor',sf); VERIFY_(STATUS) - status = NF_GET_VARA_INT (ncid, 4,(/1,1,time_slice/),(/nc_10,nr_10,1/),net_data1); VERIFY_(STATUS) - - do j = jLL,jLL + nr_10 -1 - do i = iLL, iLL + nc_10 -1 - if(net_data1(i-iLL +1 ,j - jLL +1) /= d_undef) then - pix_count = rmap%ij_index(i,j) - if (pix_count ==0) cycle - if(rmap%map(pix_count)%nt > 0) then - do n = 1, rmap%map(pix_count)%nt - if(vec_lai(rmap%map(pix_count)%tid(n)) == -9999.) vec_lai(rmap%map(pix_count)%tid(n)) = 0. - vec_lai(rmap%map(pix_count)%tid(n)) = vec_lai(rmap%map(pix_count)%tid(n)) + & - sf*net_data1(i-iLL +1 ,j - jLL +1)*rmap%map(pix_count)%count(n) - count_lai(rmap%map(pix_count)%tid(n)) = & - count_lai(rmap%map(pix_count)%tid(n)) + 1.*rmap%map(pix_count)%count(n) - end do - endif - endif - enddo - enddo - -! After experimenting with few finer methods, in order to reduce the time taken by the gap filling procedure, -! creating a 0.25-degree gridded data set from finer LAI data and use it for filling the gaps seems the most practical/manageble method. -!--------------------------------------------------------------------------------------------------------------------------------------- - do j = ceiling(1.*jLL/QSize),ceiling(1.*jLL/QSize) -1 + nr_10/QSize - do i = ceiling(1.*iLL/QSize),ceiling(1.*iLL/QSize) -1 + nc_10/QSize - QSub => net_data1((i-1)*QSize+2-iLL :i*QSize-iLL+1, (j-1)*QSize+2-jLL :j*QSize-jLL+1) - if(maxval (QSub) > 0) lai_grid(i,j) = sf*sum(QSub, QSub>0)/(max(1,count(QSub>0))) - enddo - enddo - status = NF_CLOSE(ncid) - endif - end do - end do - - NULLIFY (QSub) - - write(31) float((/yr,mn,dd,0,0,0,yr1,mn1,dd1,0,0,0,maxcat,1/)) - - where (count_lai > 0.) vec_lai = vec_lai/count_lai - -! Filling gaps -!------------- - DO n =1,maxcat - if(count_lai(n)==0.) then - - DO i = 1,nx - 1 - if ((tile_lon(n) >= x(i)).and.(tile_lon(n) < x(i+1))) ix = i - end do - DO i = 1,ny -1 - if ((tile_lat(n) >= y(i)).and.(tile_lat(n) < y(i+1))) jx = i - end do - - l = 1 - do - imx=ix + l - imn=ix - l - jmn=jx - l - jmx=jx + l - imn=MAX(imn,1) - jmn=MAX(jmn,1) - imx=MIN(imx,nx) - jmx=MIN(jmx,ny) - d1=imx-imn+1 - d2=jmx-jmn+1 - subset => lai_grid(imn: imx,jmn:jmx) - - if(maxval(subset) > 0.) then - vec_lai (n) = sum(subset, subset>0.)/(max(1,count(subset>0.))) - exit - endif - l = l + 1 - NULLIFY (subset) - end do - -! Another Method in which search for a neighboring value while looping through nc_data*nr_data +! open (41,file='clsm/lai.gswp2', & +! form='unformatted',status='old',convert='little_endian',action='read') +! read(41) gyr,gmn,gdy,dum,dum,dum,gyr1,gmn1,gdy1 +! read(41) gswp2_lai_bf +! call Get_MidTime(gyr,gmn,gdy,gyr1,gmn1,gdy1,bf_gswp2_time) +! +! read(41) gyr,gmn,gdy,dum,dum,dum,gyr1,gmn1,gdy1 +! read(41) gswp2_lai_af +! call Get_MidTime(gyr,gmn,gdy,gyr1,gmn1,gdy1,af_gswp2_time) +! +! do t=0,n_tslices+1 +! +! time_slice = t +! yr = 1 +! yr1= 1 +! if(t == 0) then +! time_slice = n_tslices +! yr = 1 - 1 +! endif +! +! if(t >= n_tslices) then +! yr1 = 1 + 1 +! if(t ==n_tslices + 1) then +! time_slice = 1 +! yr = 1 + 1 +! endif +! endif +! +! read(mmdd(t),'(i2.2,i2.2)') mn,dd +! read(mmdd_next(t),'(i2.2,i2.2)') mn1,dd1 +! +! lai_high = -9999 +! +! do jx = 1,18 +! do ix = 1,36 +! write (vv,'(i2.2)')jx +! write (hh,'(i2.2)')ix +! fname = trim(MAKE_BCS_INPUT_DIR)//'/land/veg/lai_grn/v2/'//trim(lai_name)//'lai_clim.H'//hh//'V'//vv//'.nc' +! status = NF_OPEN(trim(fname),NF_NOWRITE, ncid) +! if(status == 0) then +! status = NF_GET_att_INT (ncid,NF_GLOBAL,'i_ind_offset_LL',iLL); VERIFY_(STATUS) +! status = NF_GET_att_INT (ncid,NF_GLOBAL,'j_ind_offset_LL',jLL); VERIFY_(STATUS) +! status = NF_GET_att_INT (ncid,4,'UNDEF',d_undef); VERIFY_(STATUS) +! status = NF_GET_att_REAL (ncid,4,'ScaleFactor',sf); VERIFY_(STATUS) +! status = NF_GET_VARA_INT (ncid, 4,(/1,1,time_slice/),(/nc_10,nr_10,1/),net_data1); VERIFY_(STATUS) +! +! do j = jLL,jLL + nr_10 -1 +! do i = iLL, iLL + nc_10 -1 +! if(net_data1(i-iLL +1 ,j - jLL +1) /= d_undef) & +! lai_high(i,j) = net_data1(i-iLL +1 ,j - jLL +1) +! enddo +! enddo +! status = NF_CLOSE(ncid) +! endif +! end do +! end do ! -! -! DO i = 1,nc_data - 1 -! if ((tile_lon(n) >= x(i)).and.(tile_lon(n) < x(i+1))) ix = i -! end do -! DO i = 1,nr_data -1 -! if ((tile_lat(n) >= y(i)).and.(tile_lat(n) < y(i+1))) jx = i -! end do -! -! l = 1 -! do -! imx=ix + l -! imn=ix - l -! jmn=jx - l -! jmx=jx + l -! imn=MAX(imn,1) -! jmn=MAX(jmn,1) -! imx=MIN(imx,nc_data) -! jmx=MIN(jmx,nr_data) -! d1=imx-imn+1 -! d2=jmx-jmn+1 -! ALLOCATE(subset(1:d1,1:d2)) -! subset = -9999 -! -! do j = 1,d2 -! do i = 1,d1 -! if (rmap(imn + i -1,jmn + j -1)%nt > 0) subset(i,j)=rmap(imn + i -1,jmn + j -1)%tid(1) -! end do -! end do -! -! mval = maxval(subset) -! deallocate (subset) +! ! Regridding ! -! if((mval > 0).and.(vec_lai_save(mval) > 0.)) then -! vec_lai (n) = vec_lai_save (mval) -! print *, count_lai(n),mval, vec_lai_save (mval) -! exit -! endif -! l = l + 1 -! end do -! -! The OLDEST METHOD - in which process tile space -! if((vec_fill(n) > 0).and.(vec_lai_save(vec_fill(n)) > 0.)) then -! vec_lai (n) = vec_lai_save (vec_fill(n)) -! else +! nx_adj = nx +! ny_adj = ny ! -! distance = 1000000. -! where ((abs(tile_lat - tile_lat(n)) < 20.).and. & -! (abs(tile_lon - tile_lon(n)) < 10.)) & -! distance = & -! (tile_lon - tile_lon(n)) * (tile_lon - tile_lon(n)) + & -! (tile_lat - tile_lat(n)) * (tile_lat - tile_lat(n)) -! distance (n) = 1000000. -! k = minloc(distance,dim=1) +! regrid = nx/=i_highd .or. ny/=j_highd ! -!! do i = 1,maxcat -!! if((i /= n).and.(abs(tile_lat(i) - tile_lat(n)) < 20.).and. & -!! (abs(tile_lon(i) - tile_lon(n)) < 10.)) then -!! if(vec_lai_save(i).gt.0.) then -!! tile_distance = (tile_lon(i) - tile_lon(n)) * (tile_lon(i) - tile_lon(n)) + & -!! (tile_lat(i) - tile_lat(n)) * (tile_lat(i) - tile_lat(n)) -!! if(tile_distance < dist_save) then -!! k = i -!! dist_save = tile_distance -!! endif -!! endif -!! endif -!! enddo +! if(regrid) then +! if(nx > i_highd) then +! allocate(raster(nx,ny),stat=STATUS); VERIFY_(STATUS) +! call RegridRaster2(lai_high,raster) +! iRaster => tile_id +! if(ny < j_highd) then +! print *,'nx > i_highd and ny < j_highd' +! stop +! endif +! else +! if(.not. associated(iraster)) then +! allocate(iraster(i_highd,j_highd),stat=STATUS); VERIFY_(STATUS) +! endif ! -! vec_lai (n) = vec_lai_save (k) -! vec_fill(n) = k +! ! if( associated(iraster)) deallocate(iraster) +! ! allocate(iraster(i_highd,j_highd),stat=STATUS); VERIFY_(STATUS) +! call RegridRaster(tile_id,iraster) +! raster => lai_high +! nx_adj = i_highd +! ny_adj = j_highd +! +! if(ny > j_highd) then +! print *,'nx < i_highd and ny > j_highd' +! stop +! endif +! endif +! else +! raster => lai_high +! iRaster => tile_id +! end if +! +! ! Interpolation or aggregation on to catchment-tiles +! +! vec_lai =0. +! count_lai = 0. +! +! do j=1,ny_adj +! do i=1,nx_adj +! if((iRaster(i,j).gt.0).and.(iRaster(i,j).le.maxcat)) then +! if ((raster(i,j).ge.0)) then +! vec_lai(iRaster(i,j)) = & +! vec_lai(iRaster(i,j)) + sf*raster(i,j) +! count_lai(iRaster(i,j)) = & +! count_lai(iRaster(i,j)) + 1. ! endif - endif - END DO - write(31) vec_lai(:) - end do - close(31,status='keep') - - deallocate (net_data1) - deallocate (count_lai) - deallocate (vec_lai) - deallocate (tile_lat,tile_lon) - - END SUBROUTINE hres_lai_no_gswp +! endif +! end do +! end do ! -! --------------------------------------------------------------------------------------- -! - SUBROUTINE hres_gswp2 (nc_data,nr_data,rmap,lai_name,merge) +! write(31) float((/yr,mn,dd,0,0,0,yr1,mn1,dd1,0,0,0,maxcat,1/)) +! call Get_MidTime(real(yr),real(mn),real(dd),real(yr1),real(mn1),real(dd1),date_time_new) +! ! date_time_new%year = yr + 2001 +! ! date_time_new%month = mn +! ! date_time_new%day = dd +! ! date_time_new%hour = 0 +! ! date_time_new%min = 0 +! ! date_time_new%sec = 0 +! ! call get_dofyr_pentad(date_time_new) ! -! Processing GSWP2 30sec LAI and grnFrac climatological data +! if ( .not. datetime_le_refdatetime(date_time_new,af_gswp2_time)) then +! read(41,IOSTAT=ierr) gyr,gmn,gdy,dum,dum,dum,gyr1,gmn1,gdy1 +! if(ierr == 0) then +! gswp2_lai_bf = gswp2_lai_af +! read(41) gswp2_lai_af +! bf_gswp2_time = af_gswp2_time +! call Get_MidTime(gyr,gmn,gdy,gyr1,gmn1,gdy1,af_gswp2_time) +! else +! print *,'END OF GSWP2 LAI FILE' +! stop +! endif +! endif ! - implicit none - integer, intent (in) :: nc_data, nr_data - character(*) :: lai_name - integer :: n,maxcat,i,j,k,ncid,i_highd,j_highd,nx_adj,ny_adj,ierr - integer :: status,iLL,jLL,ix,jx,vid,nc_10,nr_10,n_tslices,d_undef,t, & - time_slice,time_slice_next,yr,mn,dd,yr1,mn1,dd1,i1,i2 - type (regrid_map), intent (in) :: rmap - real :: dum, gyr,gmn,gdy,gyr1,gmn1,gdy1, slice1,slice2 - character*100 :: fout - character*200 :: fname - character*10 :: string - character*2 :: VV,HH - integer, allocatable, target, dimension (:,:) :: & - net_data1 - REAL, ALLOCATABLE, dimension (:) :: vec_lai, count_lai - character(len=4), dimension (:), allocatable :: MMDD, MMDD_next - logical :: regrid - REAL :: sf,minlat,maxlat,minlon,maxlon - logical :: first_entry = .true. - type (date_time_type) :: date_time_new,bf_lai_time, & - af_lai_time - integer, intent(in), optional :: merge - real, parameter :: dxy = 1. - integer :: nx, ny, QSize, pix_count - REAL, ALLOCATABLE, dimension (:) :: x,y,tile_lon, tile_lat - real, allocatable, target, dimension (:,:) :: data_grid - integer, pointer, dimension (:,:) :: QSub - INTEGER ::imn,imx,jmn,jmx,mval,d1,d2,l,tindex1,pfaf1 - real, pointer, dimension (:,:) :: subset - - if(trim(lai_name) == 'lai' ) vid = 4 - if(trim(lai_name) == 'green') vid = 5 - - - ! For Gap filling - ! --------------- - - nx = nint (360./dxy) - ny = nint (180./dxy) - allocate (x(1:nx)) - allocate (y(1:ny)) - - FORALL (i = 1:nx) x(i) = -180. + dxy/2. + (i-1)*dxy - FORALL (i = 1:ny) y(i) = -90. + dxy/2. + (i-1)*dxy - - allocate (data_grid (1 : nx, 1 : ny)) - - QSize = nint(dxy*nc_data/360.) - -! Reading number of cathment-tiles from catchment.def file -! -------------------------------------------------------- - - fname='clsm/catchment.def' - open (10,file=fname,status='old',action='read',form='formatted') - read(10,*) maxcat - allocate (tile_lon(1:maxcat)) - allocate (tile_lat(1:maxcat)) - - do n = 1, maxcat - read (10,*) tindex1,pfaf1,minlon,maxlon,minlat,maxlat - tile_lon(n) = (minlon + maxlon)/2. - tile_lat(n) = (minlat + maxlat)/2. - end do - - close (10,status='keep') - - call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) - fname =trim(MAKE_BCS_INPUT_DIR)//'/land/veg/lai_grn/v1/GSWP2_VegParam_H11V13.nc' - status = NF_OPEN(trim(fname),NF_NOWRITE, ncid); VERIFY_(STATUS) - status = NF_GET_att_INT(ncid,NF_GLOBAL,'i_ind_offset_LL',iLL); VERIFY_(STATUS) - status = NF_GET_att_INT(ncid,NF_GLOBAL,'j_ind_offset_LL',jLL); VERIFY_(STATUS) - status = NF_GET_att_INT(ncid,NF_GLOBAL,'N_lon_global',i_highd); VERIFY_(STATUS) - status = NF_GET_att_INT(ncid,NF_GLOBAL,'N_lat_global',j_highd); VERIFY_(STATUS) - status = NF_INQ_DIM (ncid,1,string, nc_10); VERIFY_(STATUS) - status = NF_INQ_DIM (ncid,2,string, nr_10); VERIFY_(STATUS) - status = NF_INQ_DIM (ncid,3,string, n_tslices); VERIFY_(STATUS) - allocate (MMDD (0: n_tslices + 1)) - allocate (MMDD_next (0: n_tslices + 1)) - - status = NF_GET_VARA_text(ncid, 3,(/1,1/),(/4,n_tslices/),MMDD(1:n_tslices)); VERIFY_(STATUS) - status = NF_CLOSE(ncid); VERIFY_(STATUS) - - mmdd(0) = mmdd(n_tslices) - mmdd(n_tslices + 1)= mmdd(1) - - mmdd_next(0:n_tslices - 1) = mmdd(1:n_tslices) - mmdd_next(n_tslices: n_tslices + 1) = mmdd (1:2) - - allocate(net_data1 (1:nc_10,1:nr_10)) - - ! writing GSWP2 data - ! ------------------ - - if(present(merge)) then - open (31,file='clsm/lai.gswp2', & - form='unformatted',status='unknown',convert='little_endian') - else - open (31,file='clsm/'//trim(lai_name)//'.dat', & - form='unformatted',status='unknown',convert='little_endian') - endif - - allocate(vec_lai (1:maxcat)) - allocate(count_lai (1:maxcat)) - - do t =0,n_tslices+1 - - time_slice = t - yr = 1 - yr1= 1 - if(t == 0) then - time_slice = n_tslices - yr = 1 - 1 - endif - - if(t >= n_tslices) then - yr1 = 1 + 1 - if(t ==n_tslices + 1) then - time_slice = 1 - yr = 1 + 1 - endif - endif - - read(mmdd(t),'(i2.2,i2.2)') mn,dd - read(mmdd_next(t),'(i2.2,i2.2)') mn1,dd1 - - vec_lai = -9999. - count_lai = 0. - data_grid = -9999 - - do jx = 1,18 - do ix = 1,36 - write (vv,'(i2.2)')jx - write (hh,'(i2.2)')ix - fname = trim(MAKE_BCS_INPUT_DIR)//'/land/veg/lai_grn/v1/GSWP2_VegParam_H'//hh//'V'//vv//'.nc' - status = NF_OPEN(trim(fname),NF_NOWRITE, ncid) - if(status == 0) then - status = NF_GET_att_INT (ncid,NF_GLOBAL,'i_ind_offset_LL',iLL); VERIFY_(STATUS) - status = NF_GET_att_INT (ncid,NF_GLOBAL,'j_ind_offset_LL',jLL); VERIFY_(STATUS) - status = NF_GET_att_INT (ncid,vid,'UNDEF',d_undef); VERIFY_(STATUS) - status = NF_GET_att_REAL (ncid,vid,'ScaleFactor',sf); VERIFY_(STATUS) - status = NF_GET_VARA_INT (ncid, vid,(/1,1,time_slice/),(/nc_10,nr_10,1/),net_data1); VERIFY_(STATUS) - - do j = jLL,jLL + nr_10 -1 - do i = iLL, iLL + nc_10 -1 - if(net_data1(i-iLL +1 ,j - jLL +1) /= d_undef) then - pix_count = rmap%ij_index(i,j) - if (pix_count == 0) cycle - if(rmap%map(pix_count)%nt > 0) then - do n = 1, rmap%map(pix_count)%nt - if(vec_lai(rmap%map(pix_count)%tid(n)) == -9999.) vec_lai(rmap%map(pix_count)%tid(n)) = 0. - vec_lai(rmap%map(pix_count)%tid(n)) = vec_lai(rmap%map(pix_count)%tid(n)) + & - sf*net_data1(i-iLL +1 ,j - jLL +1)*rmap%map(pix_count)%count(n) - count_lai(rmap%map(pix_count)%tid(n)) = & - count_lai(rmap%map(pix_count)%tid(n)) + 1.*rmap%map(pix_count)%count(n) - end do - endif - endif - enddo - enddo - - ! After experimenting with few finer methods, in order to reduce the time taken by the gap filling procedure, - ! creating a 1.-degree gridded data set from finer LAI data and use it for filling the gaps seems the most practical/manageble method. - !--------------------------------------------------------------------------------------------------------------------------------------- - - do j = ceiling(1.*jLL/QSize),ceiling(1.*jLL/QSize) -1 + nr_10/QSize - do i = ceiling(1.*iLL/QSize),ceiling(1.*iLL/QSize) -1 + nc_10/QSize - QSub => net_data1((i-1)*QSize+2-iLL :i*QSize-iLL+1, (j-1)*QSize+2-jLL :j*QSize-jLL+1) - if(maxval (QSub) > 0) data_grid(i,j) = sf*sum(QSub, QSub>0)/(max(1,count(QSub>0))) - enddo - enddo - - status = NF_CLOSE(ncid) - endif - end do - end do - - write(31) float((/yr,mn,dd,0,0,0,yr1,mn1,dd1,0,0,0,maxcat,1/)) - where (count_lai > 0.) vec_lai = vec_lai/count_lai - - ! Filling gaps - !------------- - DO n =1,maxcat - if(count_lai(n)==0.) then - - DO i = 1,nx - 1 - if ((tile_lon(n) >= x(i)).and.(tile_lon(n) < x(i+1))) ix = i - end do - DO i = 1,ny -1 - if ((tile_lat(n) >= y(i)).and.(tile_lat(n) < y(i+1))) jx = i - end do - - l = 1 - do - imx=ix + l - imn=ix - l - jmn=jx - l - jmx=jx + l - imn=MAX(imn,1) - jmn=MAX(jmn,1) - imx=MIN(imx,nx) - jmx=MIN(jmx,ny) - d1=imx-imn+1 - d2=jmx-jmn+1 - subset => data_grid(imn: imx,jmn:jmx) - - if(maxval(subset) > 0.) then - vec_lai (n) = sum(subset, subset>0.)/(max(1,count(subset>0.))) - exit - endif - l = l + 1 - NULLIFY (subset) - end do - endif - end do - write(31) vec_lai(:) - end do - - close(31,status='keep') - - deallocate (net_data1) - deallocate (count_lai) - deallocate (vec_lai) - - END SUBROUTINE hres_gswp2 - - !---------------------------------------------------------------------- - - SUBROUTINE MODIS_snow_alb_v2( nc_data, nr_data, rmap ) - - ! Map static, MODIS climatology-based snow albedo from preprocessed 30-arcsec grid - ! to *land* tiles and write into clsm/catch_params.nc4. +! call Time_Interp_Fac (date_time_new, bf_gswp2_time, af_gswp2_time, slice1, slice2) +! gswp2_lai = (slice1*gswp2_lai_bf + slice2*gswp2_lai_af) +! +! ! print *, 'Merging GEOLAND2-AVHRR' +! ! print *, bf_gswp2_time +! ! print *, date_time_new +! ! print *, af_gswp2_time +! ! print *, slice1, slice2 +! ! print *, maxval(gswp2_lai), minval(gswp2_lai) +! +! DO n =1,maxcat +! if(count_lai(n)/=0.) vec_lai(n)= vec_lai(n)/count_lai(n) +! if(vec_lai(n)==0.) vec_lai(n) = gswp2_lai(n) +! END DO +! +! write(31) vec_lai(:) +! +! end do ! t=0,n_tslices+1 +! +! close(31,status='keep') +! close(41,status='keep') +! +! deallocate (net_data1) +! deallocate (LAI_HIGH) +! deallocate (count_lai) +! deallocate (vec_lai, iRaster) +! deallocate (gswp2_lai_bf,gswp2_lai_af,gswp2_lai, tile_id) +! +! END SUBROUTINE hres_lai + ! + ! --------------------------------------------------------------------------------------- + ! + SUBROUTINE grid2tile_modis6 (nc_data,nr_data,ncol,nrow, n_land, tile_lon, tile_lat, tile_id,lai_name) ! - ! Assumes that input snow albedo is backfilled (i.e., does not contain no-data values). + ! Processing GEOLAND2/MODIS LAI and creating 10-day climatological data ! - ! Snow albedo assigned to each tile is averaged over 30-arcsec MODIS grid cells associated - ! with the tile per the 30-arcsec raster file associated with the tile space. - ! Unlike in subroutine MODIS_snow_alb_v2, the tile-average snow albedo computed here - ! does not include snow albedo values from neighboring land tiles or water/landice tiles. + implicit none + integer, intent(in) :: nc_data,nr_data, ncol,nrow, n_land + real, intent(in) :: tile_lon(:), tile_lat(:) + integer, target, intent(in) :: tile_id(:,:) + character(*), intent(in) :: lai_name + + real, parameter :: dxy = 1. + integer :: QSize + integer :: n,i,j,k,ncid,i_highd,j_highd,nx_adj,ny_adj,ierr,nx,ny + integer :: status,iLL,jLL,ix,jx,vid,nc_10,nr_10,n_tslices,d_undef,t, & + time_slice,time_slice_next,yr,mn,dd,yr1,mn1,dd1,i1,i2,tindex1,pfaf1 + character*100 :: fout + character*200 :: fname + character*10 :: string + character*2 :: VV,HH + integer, allocatable, target, dimension (:,:) :: net_data1 + integer, pointer, dimension (:,:) :: QSub + real, pointer, dimension (:,:) :: subset + REAL, ALLOCATABLE, dimension (:) :: vec_lai, count_lai, x, y !, distance + real, allocatable, target, dimension (:,:) :: lai_grid + INTEGER ::imn,imx,jmn,jmx,mval,d1,d2,l + character(len=4), dimension (:), allocatable :: MMDD, MMDD_next + logical :: regrid + REAL :: sf, dum,dist_save,tile_distance,minlat,maxlat,minlon,maxlon + logical :: first_entry = .true. + type (date_time_type) :: date_time_new,bf_lai_time, & + af_lai_time + integer :: tileid_tile + real :: dxm, dym + + dxm = real(nc_data) /real(ncol) + dym = real(nr_data) /real(nrow) + + if ((mod( nc_data, ncol) /= 0).OR. (mod( nc_data, ncol) /= 0)) then + print *, 'For now, 86400 should be evenly divisible by NC Talk to Sarith' + stop + endif ! - ! rmap is the precomputed mapping from a 30-arcsec raster file to the tile space. - ! The raster file used to compute rmap must be on the same 30-arcsec grid as the - ! MODIS input data. + !_________________________________________________________ ! - ! Biljana Orescanin June 2023, SSAI@NASA - - implicit none - - integer(kind=4), parameter :: nc_10=1200 ! # columns in 10deg-by-10deg MODIS input file - integer(kind=4), parameter :: nr_10=1200 ! # rows in 10deg-by-10deg MODIS input file - - type (regrid_map), intent (in) :: rmap - integer, intent (in) :: nc_data,nr_data - - integer :: nn, N_tile, ii, jj, ncid, iG, jG - integer :: status, iLL, jLL, ix, jx - integer :: pix_count - - character*200 :: fname - character*2 :: VV, HH - logical :: file_exists - - character*128 :: Iam = "MODIS_snow_alb_v2" - - real, allocatable, dimension (:) :: snw_alb, count_snow_alb - real, allocatable, target, dimension (:,:) :: stch_snw_alb - - ! ---------------------------------------------------------------------------- + call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) + fname =trim(MAKE_BCS_INPUT_DIR)//'/land/veg/lai_grn/v3/'//trim(lai_name)//'lai_clim.H11V13.nc' + status = NF_OPEN(trim(fname),NF_NOWRITE, ncid); VERIFY_(STATUS) + status = NF_GET_att_INT(ncid,NF_GLOBAL,'i_ind_offset_LL',iLL); VERIFY_(STATUS) + status = NF_GET_att_INT(ncid,NF_GLOBAL,'j_ind_offset_LL',jLL); VERIFY_(STATUS) + status = NF_GET_att_INT(ncid,NF_GLOBAL,'N_lon_global',i_highd); VERIFY_(STATUS) + status = NF_GET_att_INT(ncid,NF_GLOBAL,'N_lat_global',j_highd); VERIFY_(STATUS) + status = NF_INQ_DIM (ncid,1,string, nc_10); VERIFY_(STATUS) + status = NF_INQ_DIM (ncid,2,string, nr_10); VERIFY_(STATUS) + status = NF_INQ_DIM (ncid,3,string, n_tslices); VERIFY_(STATUS) + allocate (MMDD (0: n_tslices + 1)) + allocate (MMDD_next (0: n_tslices + 1)) + + status = NF_GET_VARA_text(ncid, 3,(/1,1/),(/4,n_tslices/),MMDD(1:n_tslices)); VERIFY_(STATUS) + status = NF_CLOSE(ncid); VERIFY_(STATUS) + + if(nc_data/=i_highd .or. nr_data/=j_highd) then + print *,'Inconsistent mapping and dimensions in hres_lai_no_gswp -so stopping ...' + stop + end if + + mmdd(0) = mmdd(n_tslices) + mmdd(n_tslices + 1)= mmdd(1) + + mmdd_next(0:n_tslices - 1) = mmdd(1:n_tslices) + mmdd_next(n_tslices: n_tslices + 1) = mmdd (1:2) + + + allocate(net_data1 (1:nc_10,1:nr_10)) + + ! writing MODIS6 + ! + open (31,file='clsm/lai.dat', & + form='unformatted',status='unknown',convert='little_endian') + + allocate (vec_lai (n_land)) + allocate (count_lai (1:n_land)) + + ! allocate (vec_fill (n_land)) + ! allocate (distance (n_land)) + ! allocate (vec_lai_save(n_land)) + ! vec_fill = 0 + + nx = nint (360./dxy) + ny = nint (180./dxy) + allocate (x(1:nx)) + allocate (y(1:ny)) + + FORALL (i = 1:nx) x(i) = -180. + dxy/2. + (i-1)*dxy + FORALL (i = 1:ny) y(i) = -90. + dxy/2. + (i-1)*dxy + + allocate (lai_grid (1 : nx, 1 : ny)) + + QSize = nint(dxy*nc_data/360.) + ! allocate (QSub (1:QSize,1:QSize)) + + do t=0,n_tslices+1 + + time_slice = t + yr = 1 + yr1= 1 + if(t == 0) then + time_slice = n_tslices + yr = 1 - 1 + endif + + if(t >= n_tslices) then + yr1 = 1 + 1 + if(t ==n_tslices + 1) then + time_slice = 1 + yr = 1 + 1 + endif + endif + + read(mmdd(t),'(i2.2,i2.2)') mn,dd + read(mmdd_next(t),'(i2.2,i2.2)') mn1,dd1 + + ! Reading Interpolation or aggregation on to catchment-tiles + + vec_lai = -9999. + count_lai = 0. + lai_grid = -9999 + + do jx = 1,18 + do ix = 1,36 + write (vv,'(i2.2)')jx + write (hh,'(i2.2)')ix + fname = trim(MAKE_BCS_INPUT_DIR)//'/land/veg/lai_grn/v3/'//trim(lai_name)//'lai_clim.H'//hh//'V'//vv//'.nc' + status = NF_OPEN(trim(fname),NF_NOWRITE, ncid) + if(status == 0) then + status = NF_GET_att_INT (ncid,NF_GLOBAL,'i_ind_offset_LL',iLL); VERIFY_(STATUS) + status = NF_GET_att_INT (ncid,NF_GLOBAL,'j_ind_offset_LL',jLL); VERIFY_(STATUS) + status = NF_GET_att_INT (ncid,4,'UNDEF',d_undef); VERIFY_(STATUS) + status = NF_GET_att_REAL (ncid,4,'ScaleFactor',sf); VERIFY_(STATUS) + status = NF_GET_VARA_INT (ncid, 4,(/1,1,time_slice/),(/nc_10,nr_10,1/),net_data1); VERIFY_(STATUS) + + do j = jLL,jLL + nr_10 -1 + do i = iLL, iLL + nc_10 -1 + if(net_data1(i-iLL +1 ,j - jLL +1) /= d_undef) then + tileid_tile = tile_id (ceiling(i/dxm), ceiling (j/dym)) + if((tileid_tile >= 1).and.(tileid_tile <= n_land)) then + if(vec_lai(tileid_tile) == -9999.) vec_lai(tileid_tile) = 0. + vec_lai(tileid_tile) = vec_lai(tileid_tile) + & + sf*net_data1(i-iLL +1 ,j - jLL +1) + count_lai(tileid_tile) = & + count_lai(tileid_tile) + 1. + endif + endif + enddo + enddo + + ! After experimenting with few finer methods, in order to reduce the time taken by the gap filling procedure, + ! creating a 0.25-degree gridded data set from finer LAI data and use it for filling the gaps seems the most practical/manageble method. + !--------------------------------------------------------------------------------------------------------------------------------------- + do j = ceiling(1.*jLL/QSize),ceiling(1.*jLL/QSize) -1 + nr_10/QSize + do i = ceiling(1.*iLL/QSize),ceiling(1.*iLL/QSize) -1 + nc_10/QSize + QSub => net_data1((i-1)*QSize+2-iLL :i*QSize-iLL+1, (j-1)*QSize+2-jLL :j*QSize-jLL+1) + if(maxval (QSub) > 0) lai_grid(i,j) = sf*sum(QSub, QSub>0)/(max(1,count(QSub>0))) + enddo + enddo + status = NF_CLOSE(ncid) + endif + end do + end do + + NULLIFY (QSub) + + write(31) float((/yr,mn,dd,0,0,0,yr1,mn1,dd1,0,0,0,n_land,1/)) + + where (count_lai > 0.) vec_lai = vec_lai/count_lai + + ! Filling gaps + !------------- + DO n =1,n_land + if(count_lai(n)==0.) then + + DO i = 1,nx - 1 + if ((tile_lon(n) >= x(i)).and.(tile_lon(n) < x(i+1))) ix = i + end do + DO i = 1,ny -1 + if ((tile_lat(n) >= y(i)).and.(tile_lat(n) < y(i+1))) jx = i + end do + + l = 1 + do + imx=ix + l + imn=ix - l + jmn=jx - l + jmx=jx + l + imn=MAX(imn,1) + jmn=MAX(jmn,1) + imx=MIN(imx,nx) + jmx=MIN(jmx,ny) + d1=imx-imn+1 + d2=jmx-jmn+1 + subset => lai_grid(imn: imx,jmn:jmx) + + if(maxval(subset) > 0.) then + vec_lai (n) = sum(subset, subset>0.)/(max(1,count(subset>0.))) + exit + endif + l = l + 1 + NULLIFY (subset) + end do + endif + END DO + write(31) vec_lai(:) + + end do ! t=0,n_tslices+1 + + close(31,status='keep') + + deallocate (net_data1) + deallocate (count_lai) + deallocate (vec_lai) + deallocate (lai_grid) + + END SUBROUTINE grid2tile_modis6 + + ! + ! --------------------------------------------------------------------------------------- + ! + SUBROUTINE hres_lai_no_gswp (nc_data,nr_data,rmap,lai_name, n_land, tile_lon, tile_lat, merge) + ! + ! Processing GEOLAND2/MODIS LAI and creating 10-day climatological data + ! + implicit none + integer, intent(in) :: nc_data,nr_data + type (regrid_map), intent(in) :: rmap + character(*), intent(in) :: lai_name + integer, intent(in) :: n_land + real, intent(in) :: tile_lon(:), tile_lat(:) + integer, intent(in), optional :: merge + + real, parameter :: dxy = 1. + integer :: QSize + integer :: n,i,j,k,ncid,i_highd,j_highd,nx_adj,ny_adj,ierr,nx,ny + integer :: status,iLL,jLL,ix,jx,vid,nc_10,nr_10,n_tslices,d_undef,t, & + time_slice,time_slice_next,yr,mn,dd,yr1,mn1,dd1,i1,i2,tindex1,pfaf1 + character*100 :: fout + character*200 :: fname + character*10 :: string + character*2 :: VV,HH + integer, allocatable, target, dimension (:,:) :: net_data1 + integer, pointer, dimension (:,:) :: QSub + real, pointer, dimension (:,:) :: subset + REAL, ALLOCATABLE, dimension (:) :: vec_lai, count_lai, x, y !, distance + real, allocatable, target, dimension (:,:) :: lai_grid + INTEGER ::imn,imx,jmn,jmx,mval,d1,d2,l,pix_count + character(len=4), dimension (:), allocatable :: MMDD, MMDD_next + logical :: regrid + REAL :: sf, dum,dist_save,tile_distance,minlat,maxlat,minlon,maxlon + logical :: first_entry = .true. + type (date_time_type) :: date_time_new,bf_lai_time, & + af_lai_time + + !_________________________________________________________ + ! + call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) + fname =trim(MAKE_BCS_INPUT_DIR)//'/land/veg/lai_grn/v2/'//trim(lai_name)//'lai_clim.H11V13.nc' + status = NF_OPEN(trim(fname),NF_NOWRITE, ncid); VERIFY_(STATUS) + status = NF_GET_att_INT(ncid,NF_GLOBAL,'i_ind_offset_LL',iLL); VERIFY_(STATUS) + status = NF_GET_att_INT(ncid,NF_GLOBAL,'j_ind_offset_LL',jLL); VERIFY_(STATUS) + status = NF_GET_att_INT(ncid,NF_GLOBAL,'N_lon_global',i_highd); VERIFY_(STATUS) + status = NF_GET_att_INT(ncid,NF_GLOBAL,'N_lat_global',j_highd); VERIFY_(STATUS) + status = NF_INQ_DIM (ncid,1,string, nc_10); VERIFY_(STATUS) + status = NF_INQ_DIM (ncid,2,string, nr_10); VERIFY_(STATUS) + status = NF_INQ_DIM (ncid,3,string, n_tslices); VERIFY_(STATUS) + allocate (MMDD (0: n_tslices + 1)) + allocate (MMDD_next (0: n_tslices + 1)) + + status = NF_GET_VARA_text(ncid, 3,(/1,1/),(/4,n_tslices/),MMDD(1:n_tslices)); VERIFY_(STATUS) + status = NF_CLOSE(ncid); VERIFY_(STATUS) + + if(nc_data/=i_highd .or. nr_data/=j_highd) then + print *,'Inconsistent mapping and dimensions in hres_lai_no_gswp -so stopping ...' + stop + end if + + mmdd(0) = mmdd(n_tslices) + mmdd(n_tslices + 1)= mmdd(1) + + mmdd_next(0:n_tslices - 1) = mmdd(1:n_tslices) + mmdd_next(n_tslices: n_tslices + 1) = mmdd (1:2) + + + allocate(net_data1 (1:nc_10,1:nr_10)) + + ! + ! writing MODIS/GEOLAND2 LAI data + ! + + if(present(merge)) then + open (31,file='clsm/lai.'//lai_name(1:index(lai_name,'/')-1), & + form='unformatted',status='unknown',convert='little_endian') + else + open (31,file='clsm/lai.dat', & + form='unformatted',status='unknown',convert='little_endian') + endif + + allocate (vec_lai (n_land)) + allocate (count_lai (1:n_land)) + + ! allocate (vec_fill (n_land)) + ! allocate (distance (n_land)) + ! allocate (vec_lai_save(n_land)) + ! vec_fill = 0 + + nx = nint (360./dxy) + ny = nint (180./dxy) + allocate (x(1:nx)) + allocate (y(1:ny)) + + FORALL (i = 1:nx) x(i) = -180. + dxy/2. + (i-1)*dxy + FORALL (i = 1:ny) y(i) = -90. + dxy/2. + (i-1)*dxy + + allocate (lai_grid (1 : nx, 1 : ny)) + + QSize = nint(dxy*nc_data/360.) + ! allocate (QSub (1:QSize,1:QSize)) + + do t =0,n_tslices+1 + + time_slice = t + yr = 1 + yr1= 1 + if(t == 0) then + time_slice = n_tslices + yr = 1 - 1 + endif + + if(t >= n_tslices) then + yr1 = 1 + 1 + if(t ==n_tslices + 1) then + time_slice = 1 + yr = 1 + 1 + endif + endif + + read(mmdd(t),'(i2.2,i2.2)') mn,dd + read(mmdd_next(t),'(i2.2,i2.2)') mn1,dd1 + + ! Reading Interpolation or aggregation on to catchment-tiles + + vec_lai = -9999. + count_lai = 0. + lai_grid = -9999 + + do jx = 1,18 + do ix = 1,36 + write (vv,'(i2.2)')jx + write (hh,'(i2.2)')ix + fname = trim(MAKE_BCS_INPUT_DIR)//'/land/veg/lai_grn/v2/'//trim(lai_name)//'lai_clim.H'//hh//'V'//vv//'.nc' + status = NF_OPEN(trim(fname),NF_NOWRITE, ncid) + if(status == 0) then + status = NF_GET_att_INT (ncid,NF_GLOBAL,'i_ind_offset_LL',iLL); VERIFY_(STATUS) + status = NF_GET_att_INT (ncid,NF_GLOBAL,'j_ind_offset_LL',jLL); VERIFY_(STATUS) + status = NF_GET_att_INT (ncid,4,'UNDEF',d_undef); VERIFY_(STATUS) + status = NF_GET_att_REAL (ncid,4,'ScaleFactor',sf); VERIFY_(STATUS) + status = NF_GET_VARA_INT (ncid, 4,(/1,1,time_slice/),(/nc_10,nr_10,1/),net_data1); VERIFY_(STATUS) + + do j = jLL,jLL + nr_10 -1 + do i = iLL, iLL + nc_10 -1 + if(net_data1(i-iLL +1 ,j - jLL +1) /= d_undef) then + pix_count = rmap%ij_index(i,j) + if (pix_count ==0) cycle + if(rmap%map(pix_count)%nt > 0) then + do n = 1, rmap%map(pix_count)%nt + if(vec_lai(rmap%map(pix_count)%tid(n)) == -9999.) vec_lai(rmap%map(pix_count)%tid(n)) = 0. + vec_lai(rmap%map(pix_count)%tid(n)) = vec_lai(rmap%map(pix_count)%tid(n)) + & + sf*net_data1(i-iLL +1 ,j - jLL +1)*rmap%map(pix_count)%count(n) + count_lai(rmap%map(pix_count)%tid(n)) = & + count_lai(rmap%map(pix_count)%tid(n)) + 1.*rmap%map(pix_count)%count(n) + end do + endif + endif + enddo + enddo + + ! After experimenting with few finer methods, in order to reduce the time taken by the gap filling procedure, + ! creating a 0.25-degree gridded data set from finer LAI data and use it for filling the gaps seems the most practical/manageble method. + !--------------------------------------------------------------------------------------------------------------------------------------- + do j = ceiling(1.*jLL/QSize),ceiling(1.*jLL/QSize) -1 + nr_10/QSize + do i = ceiling(1.*iLL/QSize),ceiling(1.*iLL/QSize) -1 + nc_10/QSize + QSub => net_data1((i-1)*QSize+2-iLL :i*QSize-iLL+1, (j-1)*QSize+2-jLL :j*QSize-jLL+1) + if(maxval (QSub) > 0) lai_grid(i,j) = sf*sum(QSub, QSub>0)/(max(1,count(QSub>0))) + enddo + enddo + status = NF_CLOSE(ncid) + endif + end do + end do + + NULLIFY (QSub) + + write(31) float((/yr,mn,dd,0,0,0,yr1,mn1,dd1,0,0,0,n_land,1/)) + + where (count_lai > 0.) vec_lai = vec_lai/count_lai + + ! Filling gaps + !------------- + DO n =1,n_land + if(count_lai(n)==0.) then + + DO i = 1,nx - 1 + if ((tile_lon(n) >= x(i)).and.(tile_lon(n) < x(i+1))) ix = i + end do + DO i = 1,ny -1 + if ((tile_lat(n) >= y(i)).and.(tile_lat(n) < y(i+1))) jx = i + end do + + l = 1 + do + imx=ix + l + imn=ix - l + jmn=jx - l + jmx=jx + l + imn=MAX(imn,1) + jmn=MAX(jmn,1) + imx=MIN(imx,nx) + jmx=MIN(jmx,ny) + d1=imx-imn+1 + d2=jmx-jmn+1 + subset => lai_grid(imn: imx,jmn:jmx) + + if(maxval(subset) > 0.) then + vec_lai (n) = sum(subset, subset>0.)/(max(1,count(subset>0.))) + exit + endif + l = l + 1 + NULLIFY (subset) + end do + + ! Another Method in which search for a neighboring value while looping through nc_data*nr_data + ! + ! + ! DO i = 1,nc_data - 1 + ! if ((tile_lon(n) >= x(i)).and.(tile_lon(n) < x(i+1))) ix = i + ! end do + ! DO i = 1,nr_data -1 + ! if ((tile_lat(n) >= y(i)).and.(tile_lat(n) < y(i+1))) jx = i + ! end do + ! + ! l = 1 + ! do + ! imx=ix + l + ! imn=ix - l + ! jmn=jx - l + ! jmx=jx + l + ! imn=MAX(imn,1) + ! jmn=MAX(jmn,1) + ! imx=MIN(imx,nc_data) + ! jmx=MIN(jmx,nr_data) + ! d1=imx-imn+1 + ! d2=jmx-jmn+1 + ! ALLOCATE(subset(1:d1,1:d2)) + ! subset = -9999 + ! + ! do j = 1,d2 + ! do i = 1,d1 + ! if (rmap(imn + i -1,jmn + j -1)%nt > 0) subset(i,j)=rmap(imn + i -1,jmn + j -1)%tid(1) + ! end do + ! end do + ! + ! mval = maxval(subset) + ! deallocate (subset) + ! + ! if((mval > 0).and.(vec_lai_save(mval) > 0.)) then + ! vec_lai (n) = vec_lai_save (mval) + ! print *, count_lai(n),mval, vec_lai_save (mval) + ! exit + ! endif + ! l = l + 1 + ! end do + ! + ! The OLDEST METHOD - in which process tile space + ! if((vec_fill(n) > 0).and.(vec_lai_save(vec_fill(n)) > 0.)) then + ! vec_lai (n) = vec_lai_save (vec_fill(n)) + ! else + ! + ! distance = 1000000. + ! where ((abs(tile_lat - tile_lat(n)) < 20.).and. & + ! (abs(tile_lon - tile_lon(n)) < 10.)) & + ! distance = & + ! (tile_lon - tile_lon(n)) * (tile_lon - tile_lon(n)) + & + ! (tile_lat - tile_lat(n)) * (tile_lat - tile_lat(n)) + ! distance (n) = 1000000. + ! k = minloc(distance,dim=1) + ! + !! do i = 1,n_land + !! if((i /= n).and.(abs(tile_lat(i) - tile_lat(n)) < 20.).and. & + !! (abs(tile_lon(i) - tile_lon(n)) < 10.)) then + !! if(vec_lai_save(i).gt.0.) then + !! tile_distance = (tile_lon(i) - tile_lon(n)) * (tile_lon(i) - tile_lon(n)) + & + !! (tile_lat(i) - tile_lat(n)) * (tile_lat(i) - tile_lat(n)) + !! if(tile_distance < dist_save) then + !! k = i + !! dist_save = tile_distance + !! endif + !! endif + !! endif + !! enddo + ! + ! vec_lai (n) = vec_lai_save (k) + ! vec_fill(n) = k + ! endif + endif + END DO + write(31) vec_lai(:) + end do + close(31,status='keep') + + deallocate (net_data1) + deallocate (count_lai) + deallocate (vec_lai) + deallocate (lai_grid) + + END SUBROUTINE hres_lai_no_gswp + ! + ! --------------------------------------------------------------------------------------- + ! + SUBROUTINE hres_gswp2 (nc_data,nr_data,rmap,lai_name, n_land, tile_lon, tile_lat, merge) + ! + ! Processing GSWP2 30sec LAI and grnFrac climatological data + ! + implicit none + integer, intent (in) :: nc_data, nr_data + type (regrid_map), intent (in) :: rmap + character(*), intent (in) :: lai_name + integer, intent (in) :: n_land + real, intent (in) :: tile_lon(:), tile_lat(:) + integer, optional, intent (in) :: merge + + integer :: n,i,j,k,ncid,i_highd,j_highd,nx_adj,ny_adj,ierr + integer :: status,iLL,jLL,ix,jx,vid,nc_10,nr_10,n_tslices,d_undef,t, & + time_slice,time_slice_next,yr,mn,dd,yr1,mn1,dd1,i1,i2 + real :: dum, gyr,gmn,gdy,gyr1,gmn1,gdy1, slice1,slice2 + character*100 :: fout + character*200 :: fname + character*10 :: string + character*2 :: VV,HH + integer, allocatable, target, dimension (:,:) :: & + net_data1 + REAL, ALLOCATABLE, dimension (:) :: vec_lai, count_lai + character(len=4), dimension (:), allocatable :: MMDD, MMDD_next + logical :: regrid + REAL :: sf,minlat,maxlat,minlon,maxlon + logical :: first_entry = .true. + type (date_time_type) :: date_time_new,bf_lai_time, & + af_lai_time + real, parameter :: dxy = 1. + integer :: nx, ny, QSize, pix_count + REAL, ALLOCATABLE, dimension (:) :: x,y + real, allocatable, target, dimension (:,:) :: data_grid + integer, pointer, dimension (:,:) :: QSub + INTEGER ::imn,imx,jmn,jmx,mval,d1,d2,l,tindex1,pfaf1 + real, pointer, dimension (:,:) :: subset + + if(trim(lai_name) == 'lai' ) vid = 4 + if(trim(lai_name) == 'green') vid = 5 + + + ! For Gap filling + ! --------------- + + nx = nint (360./dxy) + ny = nint (180./dxy) + allocate (x(1:nx)) + allocate (y(1:ny)) + + FORALL (i = 1:nx) x(i) = -180. + dxy/2. + (i-1)*dxy + FORALL (i = 1:ny) y(i) = -90. + dxy/2. + (i-1)*dxy + + allocate (data_grid (1 : nx, 1 : ny)) + + QSize = nint(dxy*nc_data/360.) + + + call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) + fname =trim(MAKE_BCS_INPUT_DIR)//'/land/veg/lai_grn/v1/GSWP2_VegParam_H11V13.nc' + status = NF_OPEN(trim(fname),NF_NOWRITE, ncid); VERIFY_(STATUS) + status = NF_GET_att_INT(ncid,NF_GLOBAL,'i_ind_offset_LL',iLL); VERIFY_(STATUS) + status = NF_GET_att_INT(ncid,NF_GLOBAL,'j_ind_offset_LL',jLL); VERIFY_(STATUS) + status = NF_GET_att_INT(ncid,NF_GLOBAL,'N_lon_global',i_highd); VERIFY_(STATUS) + status = NF_GET_att_INT(ncid,NF_GLOBAL,'N_lat_global',j_highd); VERIFY_(STATUS) + status = NF_INQ_DIM (ncid,1,string, nc_10); VERIFY_(STATUS) + status = NF_INQ_DIM (ncid,2,string, nr_10); VERIFY_(STATUS) + status = NF_INQ_DIM (ncid,3,string, n_tslices); VERIFY_(STATUS) + allocate (MMDD (0: n_tslices + 1)) + allocate (MMDD_next (0: n_tslices + 1)) + + status = NF_GET_VARA_text(ncid, 3,(/1,1/),(/4,n_tslices/),MMDD(1:n_tslices)); VERIFY_(STATUS) + status = NF_CLOSE(ncid); VERIFY_(STATUS) + + mmdd(0) = mmdd(n_tslices) + mmdd(n_tslices + 1)= mmdd(1) + + mmdd_next(0:n_tslices - 1) = mmdd(1:n_tslices) + mmdd_next(n_tslices: n_tslices + 1) = mmdd (1:2) + + allocate(net_data1 (1:nc_10,1:nr_10)) + + ! writing GSWP2 data + ! ------------------ + + if(present(merge)) then + open (31,file='clsm/lai.gswp2', & + form='unformatted',status='unknown',convert='little_endian') + else + open (31,file='clsm/'//trim(lai_name)//'.dat', & + form='unformatted',status='unknown',convert='little_endian') + endif + + allocate(vec_lai (1:n_land)) + allocate(count_lai (1:n_land)) + + do t =0,n_tslices+1 + + time_slice = t + yr = 1 + yr1= 1 + if(t == 0) then + time_slice = n_tslices + yr = 1 - 1 + endif + + if(t >= n_tslices) then + yr1 = 1 + 1 + if(t ==n_tslices + 1) then + time_slice = 1 + yr = 1 + 1 + endif + endif + + read(mmdd(t),'(i2.2,i2.2)') mn,dd + read(mmdd_next(t),'(i2.2,i2.2)') mn1,dd1 + + vec_lai = -9999. + count_lai = 0. + data_grid = -9999 + + do jx = 1,18 + do ix = 1,36 + write (vv,'(i2.2)')jx + write (hh,'(i2.2)')ix + fname = trim(MAKE_BCS_INPUT_DIR)//'/land/veg/lai_grn/v1/GSWP2_VegParam_H'//hh//'V'//vv//'.nc' + status = NF_OPEN(trim(fname),NF_NOWRITE, ncid) + if(status == 0) then + status = NF_GET_att_INT (ncid,NF_GLOBAL,'i_ind_offset_LL',iLL); VERIFY_(STATUS) + status = NF_GET_att_INT (ncid,NF_GLOBAL,'j_ind_offset_LL',jLL); VERIFY_(STATUS) + status = NF_GET_att_INT (ncid,vid,'UNDEF',d_undef); VERIFY_(STATUS) + status = NF_GET_att_REAL (ncid,vid,'ScaleFactor',sf); VERIFY_(STATUS) + status = NF_GET_VARA_INT (ncid, vid,(/1,1,time_slice/),(/nc_10,nr_10,1/),net_data1); VERIFY_(STATUS) + + do j = jLL,jLL + nr_10 -1 + do i = iLL, iLL + nc_10 -1 + if(net_data1(i-iLL +1 ,j - jLL +1) /= d_undef) then + pix_count = rmap%ij_index(i,j) + if (pix_count == 0) cycle + if(rmap%map(pix_count)%nt > 0) then + do n = 1, rmap%map(pix_count)%nt + if(vec_lai(rmap%map(pix_count)%tid(n)) == -9999.) vec_lai(rmap%map(pix_count)%tid(n)) = 0. + vec_lai(rmap%map(pix_count)%tid(n)) = vec_lai(rmap%map(pix_count)%tid(n)) + & + sf*net_data1(i-iLL +1 ,j - jLL +1)*rmap%map(pix_count)%count(n) + count_lai(rmap%map(pix_count)%tid(n)) = & + count_lai(rmap%map(pix_count)%tid(n)) + 1.*rmap%map(pix_count)%count(n) + end do + endif + endif + enddo + enddo + + ! After experimenting with few finer methods, in order to reduce the time taken by the gap filling procedure, + ! creating a 1.-degree gridded data set from finer LAI data and use it for filling the gaps seems the most practical/manageble method. + !--------------------------------------------------------------------------------------------------------------------------------------- + + do j = ceiling(1.*jLL/QSize),ceiling(1.*jLL/QSize) -1 + nr_10/QSize + do i = ceiling(1.*iLL/QSize),ceiling(1.*iLL/QSize) -1 + nc_10/QSize + QSub => net_data1((i-1)*QSize+2-iLL :i*QSize-iLL+1, (j-1)*QSize+2-jLL :j*QSize-jLL+1) + if(maxval (QSub) > 0) data_grid(i,j) = sf*sum(QSub, QSub>0)/(max(1,count(QSub>0))) + enddo + enddo + + status = NF_CLOSE(ncid) + endif + end do + end do + + write(31) float((/yr,mn,dd,0,0,0,yr1,mn1,dd1,0,0,0,n_land,1/)) + where (count_lai > 0.) vec_lai = vec_lai/count_lai + + ! Filling gaps + !------------- + DO n =1,n_land + if(count_lai(n)==0.) then + + DO i = 1,nx - 1 + if ((tile_lon(n) >= x(i)).and.(tile_lon(n) < x(i+1))) ix = i + end do + DO i = 1,ny -1 + if ((tile_lat(n) >= y(i)).and.(tile_lat(n) < y(i+1))) jx = i + end do + + l = 1 + do + imx=ix + l + imn=ix - l + jmn=jx - l + jmx=jx + l + imn=MAX(imn,1) + jmn=MAX(jmn,1) + imx=MIN(imx,nx) + jmx=MIN(jmx,ny) + d1=imx-imn+1 + d2=jmx-jmn+1 + subset => data_grid(imn: imx,jmn:jmx) + + if(maxval(subset) > 0.) then + vec_lai (n) = sum(subset, subset>0.)/(max(1,count(subset>0.))) + exit + endif + l = l + 1 + NULLIFY (subset) + end do + endif + end do + write(31) vec_lai(:) + end do + + close(31,status='keep') + + deallocate (net_data1) + deallocate (count_lai) + deallocate (vec_lai) + deallocate (data_grid) + + END SUBROUTINE hres_gswp2 + + !---------------------------------------------------------------------- + + SUBROUTINE MODIS_snow_alb_v2( nc_data, nr_data, rmap, n_tile ) + + ! Map static, MODIS climatology-based snow albedo from preprocessed 30-arcsec grid + ! to *land* tiles and write into clsm/catch_params.nc4. + ! + ! Assumes that input snow albedo is backfilled (i.e., does not contain no-data values). + ! + ! Snow albedo assigned to each tile is averaged over 30-arcsec MODIS grid cells associated + ! with the tile per the 30-arcsec raster file associated with the tile space. + ! Unlike in subroutine MODIS_snow_alb_v2, the tile-average snow albedo computed here + ! does not include snow albedo values from neighboring land tiles or water/landice tiles. + ! + ! rmap is the precomputed mapping from a 30-arcsec raster file to the tile space. + ! The raster file used to compute rmap must be on the same 30-arcsec grid as the + ! MODIS input data. + ! + ! Biljana Orescanin June 2023, SSAI@NASA + + implicit none + + integer(kind=4), parameter :: nc_10=1200 ! # columns in 10deg-by-10deg MODIS input file + integer(kind=4), parameter :: nr_10=1200 ! # rows in 10deg-by-10deg MODIS input file + + integer, intent (in) :: nc_data,nr_data + type (regrid_map), intent (in) :: rmap + integer, intent (in) :: n_tile + + integer :: nn, ii, jj, ncid, iG, jG + integer :: status, iLL, jLL, ix, jx + integer :: pix_count + + character*200 :: fname + character*2 :: VV, HH + logical :: file_exists + + character*128 :: Iam = "MODIS_snow_alb_v2" + + real, allocatable, dimension (:) :: snw_alb, count_snow_alb + real, allocatable, target, dimension (:,:) :: stch_snw_alb + + ! ---------------------------------------------------------------------------- call get_environment_variable( "MAKE_BCS_INPUT_DIR", MAKE_BCS_INPUT_DIR ) - ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - ! - ! TO DO + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! + ! TO DO + ! + ! ASSERT THAT rmap IS CONSISTENT WITH 30-arcsec GRID OF MODIS INPUTS + ! + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + allocate(stch_snw_alb (1:nc_10,1:nr_10)) ! 10deg-by-10deg snow albedo data + allocate(snw_alb (1:N_tile)) ! snow albedo in tile space + allocate(count_snow_alb (1:N_tile)) ! count of MODIS grid cells contributing to tile-average snow albedo + + snw_alb = -9999. ! set all to missing + count_snow_alb = 0. ! initialize counter (SHOULD THIS BE KIND REAL???) + + ! loop through the 36x18 10deg-by-10deg MODIS files + + do jx = 1,18 + do ix = 1,36 + + ! assemble file name and open file + + write (hh,'(i2.2)') ix + write (vv,'(i2.2)') jx + + fname = trim(MAKE_BCS_INPUT_DIR) // '/land/albedo/snow/MODIS/v2/snow_alb_FillVal_MOD10A1.061_30arcsec_H'//hh//'V'//vv//'.nc' + + status = NF_OPEN (trim(fname),NF_NOWRITE, ncid) ! open file to read + + if(status == 0) then ! if file exists, read snow albedo + + status = NF_GET_VARA_REAL( ncid, NC_VarID(NCID,'Snow_Albedo'), (/1,1/), (/nc_10,nr_10/), stch_snw_alb); VERIFY_(STATUS) + + ! verify that input snow albedo has been back-filled *everywhere*, incl. water and landice + ! (i.e., stch_snw_alb must not contain no-data or unphysical values) + + if ( any(stch_snw_alb<0.) .or. any(stch_snw_alb>1.) ) then + + print *, 'ERROR: subroutine ', trim(Iam), '() : detected no-data or unphysical values in MODIS file ', trim(fname) + print *, 'STOPPING.' + stop + + end if + + ! calculate Lower Left (LL) indices for the chunk of the global 30-arcsec grid that is stored in file (ix,jx) + ! + ! NOTE: In similar subroutines for processing other data, iLL and jLL are stored in the nc4 file. + + iLL=(ix-1)*nc_10+1 + jLL=(jx-1)*nr_10+1 + + ! loop through 30-arcsec grid cells in current 10deg-by-10deg chunk + + do jj=1,nr_10 + do ii=1,nc_10 + + iG = ii+iLL-1 ! i-index relative to *global* 30-arcsec grid + jG = jj+jLL-1 ! j-index relative to *global* 30-arcsec grid + + pix_count = rmap%ij_index(iG,jG) ! pix_count == ID/index of tile to which current 30-arcsec grid cell belongs [???] + + if (pix_count == 0) cycle ! if this MODIS grid cell has no corresponding remapped value, skip it + + if (rmap%map(pix_count)%nt > 0) then ! if the # of tiles corresponding to this gridbox is gt 0, proceed with calculations + + do nn = 1,rmap%map(pix_count)%nt ! loop through all corresponding tiles [???] + + ! if first pass, set albedo to zero + ! [????] CAN THIS BE SKIPPED IF snw_alb IS INITIALIZED TO ZERO ABOVE? + ! BECAUSE MODIS DATA ARE BACKFILLED, THERE SHOULD NOT BE NO-DATA-VALUES FOR ANY TILE + if (snw_alb(rmap%map(pix_count)%tid(nn)) == -9999.) snw_alb(rmap%map(pix_count)%tid(nn)) = 0. + + ! accumulate values and counts + snw_alb(rmap%map(pix_count)%tid(nn)) = & + snw_alb(rmap%map(pix_count)%tid(nn)) + stch_snw_alb(ii,jj)*rmap%map(pix_count)%count(nn) + + ! [???] rmap%map(pix_count)%count(nn) IS INTEGER; MAKE count_snow_alb INTEGER AFTER FIRST ASSERTING 0-DIFF FOR CURRENT CLEANUP + count_snow_alb(rmap%map(pix_count)%tid(nn)) = & + count_snow_alb(rmap%map(pix_count)%tid(nn)) + 1.*rmap%map(pix_count)%count(nn) + + end do + + endif ! if not missing + enddo ! ii-loop + enddo ! jj-loop + + ! Close the file, freeing all resources. + status=NF_CLOSE(ncid); VERIFY_(STATUS) + + endif + end do ! jx-loop through 10deg-by-10deg files + end do ! ix-loop through 10deg-by-10deg files + + ! finalize calculation of mean values + ! [???] NOTE: count_snw_alb SHOULD BE INTEGER --> CONVERT TO REAL + + ! because MODIS data are backfilled, should have count_snow_alb>0 + + if ( any(count_snow_alb<=0.) ) then + + print *, 'ERROR: subroutine ', trim(Iam), '() : something wrong with count_snow_alb(:)' + print *, 'STOPPING.' + stop + + end if + + snw_alb = snw_alb/count_snow_alb ! finalize calculation of tile-average snow albedo + + ! write snow albedo into clsm/catch_params.nc4 + + inquire(file='clsm/catch_params.nc4', exist=file_exists) + + if(file_exists) then + status = NF_OPEN ('clsm/catch_params.nc4', NF_WRITE, ncid ) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'SNOWALB'),(/1/),(/N_tile/),real(snw_alb)) ; VERIFY_(STATUS) + STATUS = NF_CLOSE (NCID) ; VERIFY_(STATUS) + endif + + deallocate(stch_snw_alb) + deallocate(count_snow_alb) + deallocate(snw_alb) + + END SUBROUTINE MODIS_snow_alb_v2 + + !---------------------------------------------------------------------- + + SUBROUTINE MODIS_snow_alb(n_tile, min_lon, max_lon, min_lat, max_lat) + + ! Map static, MODIS climatology-based snow albedo from preprocessed 30-arcsec grid + ! to land tiles and write into clsm/catch_params.nc4. + ! + ! Assumes that input snow albedo is backfilled (i.e., does not contain no-data values). + ! + ! Snow albedo assigned to each tile is average over 30-arcsec MODIS grid cells located + ! within the rectangle defined by the min/max lat/lon of tile; this can include MODIS grid + ! cells located in neighboring land tiles and/or water/landice tiles. + ! See subroutine MODIS_snow_alb_v2() for a refined algorithm. + ! + ! Biljana Orescanin July 2022, SSAI@NASA + + implicit none + integer, intent(in) :: n_tile + real, intent(in) :: min_lon(:),max_lon(:),min_lat(:),max_lat(:) + + real, allocatable :: snw_alb(:) + + character*200 :: fname + character*2 :: vv,hh + integer :: n,ncid,status + integer(kind=4),parameter :: xdim = 1200, ydim = 1200 + real,dimension(xdim,ydim) :: stch_snw_alb_tmp + real,dimension(36,18,xdim,ydim) :: stch_snw_alb + real :: sno_alb_cnt,sno_alb_sum + integer :: vvtil_min,hhtil_min,vvtil_max,hhtil_max,hhtil,vvtil + integer(kind=4) :: imin,imax,jmin,jmax,varid1 + logical :: file_exists + + ! the stitched MODIS albedo file + allocate (snw_alb(1:N_tile)) + + ! Start by setting all snow albedo values to missing + snw_alb(:)=MAPL_UNDEF + + call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) + + ! ----------- Get the information on snow albedo ----- + ! ----------- The information on snow albedo is stored in 10x10deg 30-arcsec resolution files. + ! ----------- Read in this information, then loop over the tiles to find a corresponding snow albedo. + + ! Read in all 10x10deg snow albedo files into a single [36,18,1200,1200] array + do hhtil=1,36 ! loop over input files - horizontal direction + do vvtil=1,18 ! loop over input files - vertical direction + + write(vv,'(i2.2)') vvtil + write(hh,'(i2.2)') hhtil + + ! MODIS-based climatology albedo raster files, backfilled with global land + ! average snow albedo (=0.56; average excludes Antarctica and Greenland ice + ! sheets and is weighted by the grid-cell area). + + fname =trim(MAKE_BCS_INPUT_DIR)//'/land/albedo/snow/MODIS/v2/snow_alb_FillVal_MOD10A1.061_30arcsec_H'//hh//'V'//vv//'.nc' + + ! Open the file. (NF90_NOWRITE ensures read-only access to the file) + status=NF_OPEN(trim(fname),NF_NOWRITE, ncid) ; VERIFY_(STATUS) + ! Based on vars name, get the varids. + status=NF_INQ_VARID(ncid,'Snow_Albedo',VarID1) ; VERIFY_(STATUS) + ! Read the data. + status=NF_GET_VARA_REAL(ncid,VarID1,(/1,1/),(/xdim,ydim/),stch_snw_alb_tmp) ; VERIFY_(STATUS) + ! Close the file, freeing all resources. + status=NF_CLOSE(ncid); VERIFY_(STATUS) + + ! Store snow albedo values into a single 4D aray + stch_snw_alb(hhtil,vvtil,:,:)=stch_snw_alb_tmp + + enddo + enddo + + if (minval(stch_snw_alb) .le. 0.0 .or. maxval(stch_snw_alb) .gt. 1.0) then + print*, 'There is a problem with snow albedo raster file. Non-physical values present. STOP!' + stop + endif + + ! loop over tiles + print*, 'Starting tile loop for snow albedo.' + + do n = 1, N_tile ! loop over tiles + + ! Set sums and counts to zero + sno_alb_sum=0. + sno_alb_cnt=0. + + ! Use tile's min/max lat/lon info to identify the 10x10deg input file(s) + ! indexes + vvtil_min=floor((min_lat(n)+ 90.0)/10.)+1 + hhtil_min=floor((min_lon(n)+180.0)/10.)+1 + + ! if tile crosses the edge of the snow albedo 10x10deg box, expand the + ! search area into the neighbouring 10x10deg box + hhtil_max=hhtil_min + vvtil_max=vvtil_min + if (floor(min_lon(n)/10) .ne. floor(max_lon(n)/10)) hhtil_max=hhtil_min+1 + if (floor(min_lat(n)/10) .ne. floor(max_lat(n)/10)) vvtil_max=vvtil_min+1 + + ! Safety check; keep within the range + vvtil_min=max(vvtil_min,1) + vvtil_max=min(vvtil_max,18) + hhtil_min=max(hhtil_min,1) + hhtil_max=min(hhtil_max,36) + + do hhtil=hhtil_min,hhtil_max ! loop through input files - horizontal direction + do vvtil=vvtil_min,vvtil_max ! loop through input files - vertical direction + + ! Find indices ranges corresponding to the current tile area. + imin=floor((min_lon(n)+180.0 - (hhtil-1)*10.0) * (xdim/10.0)) +1 + imax=floor((max_lon(n)+180.0 - (hhtil-1)*10.0) * (xdim/10.0)) +1 + jmin=floor((min_lat(n)+ 90.0 - (vvtil-1)*10.0) * (ydim/10.0)) +1 + jmax=floor((max_lat(n)+ 90.0 - (vvtil-1)*10.0) * (ydim/10.0)) +1 + + ! if no matching grids, go to the next vv/hh box + if (imin .gt. xdim .or. jmin .gt. ydim .or. imax .lt. 1 .or. jmax .lt. 1) cycle + + ! Keep within the range, to include only the portion of the tile within this vv/hh box + imin=max(imin,1) + imax=min(imax,xdim) + jmin=max(jmin,1) + jmax=min(jmax,ydim) + + ! Generate sums and counts using current tile corresponding indices + sno_alb_sum = sno_alb_sum + sum(stch_snw_alb(hhtil,vvtil,imin:imax,jmin:jmax)) + sno_alb_cnt = sno_alb_cnt + (imax-imin+1)*(jmax-jmin+1) + + end do ! vvtil + end do ! hhtil + + ! If matching grids found, calculate snow albedo for the current tile; + ! ensure that resulting value is within physical range [0,1]. + if (sno_alb_cnt .ne. 0) snw_alb(n)=min(1.0,max(0.0,sno_alb_sum/sno_alb_cnt)) + + end do ! n-loop over tiles + + ! write snow albedo into clsm/catch_params.nc4 + inquire(file='clsm/catch_params.nc4', exist=file_exists) + + if(file_exists) then + status = NF_OPEN ('clsm/catch_params.nc4', NF_WRITE, ncid ) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'SNOWALB'),(/1/),(/N_tile/),real(snw_alb)) ; VERIFY_(STATUS) + STATUS = NF_CLOSE (NCID) ; VERIFY_(STATUS) + endif + + print*, 'Ended tile loop for snow albedo. ' + + END SUBROUTINE MODIS_snow_alb + + !-------------------------------------------------------------------------------------- + + SUBROUTINE soil_para_hwsd (nx,ny, n_land, tile_pfs, tile_id) + + ! Processing NGDC-HWSD-STATSGO merged soil properties with Woesten Soil + ! Parameters and produces tau_param.dat and soil_param.dat files + + implicit none + integer, intent(in) :: nx, ny, n_land + integer, intent(in) :: tile_pfs(:) + integer, target, intent(in) :: tile_id(:,:) + + + real, dimension (:), allocatable :: & + a_sand,a_clay,a_silt,a_oc,a_bee,a_psis, & + a_poros,a_wp,a_aksat,atau,btau,a_wpsurf,a_porosurf, & + atau_2cm,btau_2cm + integer, dimension (100,3) :: table_map + integer, dimension (3) :: nsoil_pcarbon + type (mineral_perc) :: min_percs + + integer :: n,i,j,k,ktop,ncid,i_highd,j_highd,nx_adj,ny_adj + integer :: status,iLL,jLL,ix,jx,vid,nc_10,nr_10,d_undef, & + i1,i2,icount + character*100 :: fout + character*200 :: fname + character*10 :: string + character*2 :: VV,HH, tmpversion + + logical, allocatable, dimension(:,:) :: land_pixels + integer, allocatable, dimension (:,:) :: & + net_data1,net_data2,net_data3,net_data4,net_data5,net_data6 ,net_data7 + integer (kind=2) , allocatable, target, dimension (:,:) :: SOIL_HIGH, & + sand_top,clay_top,oc_top,sand_sub,clay_sub,oc_sub, grav_grid + integer (kind=2), pointer, dimension (:,:) :: Raster, & + Raster1,Raster2,Raster3,Raster4,Raster5,Raster6 + integer (kind=4), allocatable, dimension (:) :: tileid_vec,arrayA,arrayB + integer (kind=2), allocatable, dimension (:) :: & + data_vec1, data_vec2,data_vec3, data_vec4,data_vec5, data_vec6 + REAL, ALLOCATABLE, dimension (:) :: soildepth, grav_vec,soc_vec,poc_vec + ! ncells_top,ncells_top_pro,ncells_sub_pro ! ncells_* not used + integer(kind=2) , allocatable, dimension (:) :: ss_clay, & + ss_sand,ss_clay_all,ss_sand_all,ss_oc_all + REAL, ALLOCATABLE :: count_soil(:) + integer, pointer :: iRaster(:,:) + integer :: tindex, pfafindex,fac,o_cl,o_clp,fac_surf !,vtype + real,dimension(4) :: cFamily + real ,dimension(5) :: cF_lim + logical :: first_entry = .true. + logical :: regrid,write_debug + INTEGER, allocatable, dimension (:) :: soil_class_top,soil_class_com + REAL :: sf,factor,wp_wetness,fac_count,this_cond + logical :: CatchParamsNC_file_exists + REAL, ALLOCATABLE, DIMENSION (:,:) :: parms4file + + ! PEATCLSM: + REAL, PARAMETER :: PEATMAP_THRESHOLD_1 = 0.5 ! for converting PEATMAP area fraction into peat/non-peat (on raster grid) + REAL, PARAMETER :: PEATMAP_THRESHOLD_2 = 0.5 ! for aggregation from raster grid cells to tiles + + REAL, DIMENSION (:), POINTER :: PMAP + REAL, ALLOCATABLE, DIMENSION (:,:) :: PMAPR + + + ! --------- VARIABLES FOR *OPENMP* PARALLEL ENVIRONMENT ------------ + ! + ! NOTE: "!$" is for conditional compilation + ! + logical :: running_omp = .false. + ! + !$ integer :: omp_get_thread_num, omp_get_num_threads + ! + integer :: n_threads=1, li, ui, t_count + ! + integer, dimension(:), allocatable :: low_ind, upp_ind + ! + ! ------------------------------------------------------------------ + + ! ----------- OpenMP PARALLEL ENVIRONMENT ---------------------------- + ! + ! FIND OUT WHETHER -omp FLAG HAS BEEN SET DURING COMPILATION + ! + !$ running_omp = .true. ! conditional compilation + ! + ! ECHO BASIC OMP VARIABLES + ! + !$OMP PARALLEL DEFAULT(NONE) SHARED(running_omp,n_threads) + ! + !$OMP SINGLE + ! + !$ n_threads = omp_get_num_threads() + ! + !$ write (*,*) 'running_omp = ', running_omp + !$ write (*,*) + !$ write (*,*) 'parallel OpenMP with ', n_threads, 'threads' + !$ write (*,*) + !$OMP ENDSINGLE + ! + !$OMP CRITICAL + !$ write (*,*) 'thread ', omp_get_thread_num(), ' alive' + !$OMP ENDCRITICAL + ! + !$OMP BARRIER + ! + !$OMP ENDPARALLEL + + if (first_entry) then + nullify(iraster) ; first_entry = .false. + endif + + ! define orgC content thresholds for orgC classes 1-4 (low, medium, high, peat) + + cF_lim(1) = 0. + cF_lim(2) = 0.4 ! 0.365 ! 0.3 + cF_lim(3) = 0.64 ! 0.585 ! 4.0 + cF_lim(4) = 15./1.72 ! 15./1.72=8.72 ! 9.885 ! 8.5 + cF_lim(5) = 100.0 + + ! define number of mineral classes in each orgC class + + nsoil_pcarbon(1) = 84 ! 84 + nsoil_pcarbon(2) = nsoil_pcarbon(1) + 84 ! 84 + nsoil_pcarbon(3) = nsoil_pcarbon(2) + 84 ! 57 + + + ! read soil depth data from GSWP2_soildepth_H[xx]V[yy].nc + ! + ! get info common to all H[xx]V[yy] rectangles: + + call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) + fname =trim(MAKE_BCS_INPUT_DIR)//'/land/soil/SOIL-DATA/soil_depth/v2/GSWP2_soildepth_H11V13.nc' + status = NF_OPEN(trim(fname),NF_NOWRITE, ncid); VERIFY_(STATUS) + !status = NF_GET_att_INT(ncid,NF_GLOBAL,'i_ind_offset_LL',iLL); VERIFY_(STATUS) ! cannot be needed here + !status = NF_GET_att_INT(ncid,NF_GLOBAL,'j_ind_offset_LL',jLL); VERIFY_(STATUS) ! cannot be needed here + status = NF_GET_att_INT(ncid,NF_GLOBAL,'N_lon_global',i_highd); VERIFY_(STATUS) + status = NF_GET_att_INT(ncid,NF_GLOBAL,'N_lat_global',j_highd); VERIFY_(STATUS) + status = NF_INQ_DIM (ncid,1,string, nc_10); VERIFY_(STATUS) + status = NF_INQ_DIM (ncid,2,string, nr_10); VERIFY_(STATUS) + status = NF_CLOSE(ncid); VERIFY_(STATUS) + + ! GSWP2_soildepth_H[xx]V[yy].nc as of 29 Apr 2022: + ! + ! Associated 43200-by-21600 global grid (1/120=0.083333 deg lat/lon): + ! + ! N_lon_global = i_highd = 43200 + ! N_lat_global = j_highd = 21600 + ! + ! i_ind_offset_LL = iLL = 42001 + ! j_ind_offset_LL = jLL = 19201 + ! + ! Each file contains data for one rectangle of size 1200-by-1200, which is + ! assumed to be the same for each H[xx]V[yy] rectangle + ! + ! N_lon = nc_10 = 1200 + ! N_lat = nr_10 = 1200 + + allocate(soil_high(1:i_highd,1:j_highd)) + allocate(net_data1 (1:nc_10,1:nr_10)) + + soil_high = -9999 + do jx = 1,18 + do ix = 1,36 + write (vv,'(i2.2)')jx + write (hh,'(i2.2)')ix + fname = trim(MAKE_BCS_INPUT_DIR)//'/land/soil/SOIL-DATA/soil_depth/v2/GSWP2_soildepth_H'//hh//'V'//vv//'.nc' + status = NF_OPEN(trim(fname),NF_NOWRITE, ncid) + if(status == 0) then + status = NF_GET_att_INT (ncid,NF_GLOBAL,'i_ind_offset_LL',iLL); VERIFY_(STATUS) + status = NF_GET_att_INT (ncid,NF_GLOBAL,'j_ind_offset_LL',jLL); VERIFY_(STATUS) + status = NF_GET_att_INT (ncid,4,'UNDEF',d_undef); VERIFY_(STATUS) + status = NF_GET_att_REAL (ncid,4,'ScaleFactor',sf); VERIFY_(STATUS) + status = NF_GET_VARA_INT (ncid, 4,(/1,1/),(/nc_10,nr_10/),net_data1); VERIFY_(STATUS) + + do j = jLL,jLL + nr_10 -1 + do i = iLL, iLL + nc_10 -1 + if(net_data1(i-iLL +1 ,j - jLL +1) /= d_undef) & + soil_high(i,j) = net_data1(i-iLL +1 ,j - jLL +1) + enddo + enddo + status = NF_CLOSE(ncid) + endif + end do + end do + + deallocate (net_data1) + + ! Regridding + + ! *EASE* grid bcs use mask file GEOS5_10arcsec_mask.nc or GEOS5_10arcsec_mask_freshwater-lakes.nc, + ! and the make_bcs script assigns NX=43200, NY=21600, which are passed into the present subroutine + ! via command-line arguments of mkCatchParam.x. That is, should have regrid=.false. for *EASE* + ! grid tile space. + + nx_adj = nx + ny_adj = ny + + regrid = nx/=i_highd .or. ny/=j_highd + + if(regrid) then + if(nx > i_highd) then + allocate(raster(nx,ny),stat=STATUS); VERIFY_(STATUS) + call RegridRaster2(soil_high,raster) + iRaster => tile_id + if(ny < j_highd) then + print *,'nx > i_highd and ny < j_highd' + stop + endif + else + if( .not.associated(iraster) ) then + allocate(iraster(i_highd,j_highd),stat=STATUS); VERIFY_(STATUS) + endif + call RegridRaster(tile_id,iraster) + raster => soil_high + nx_adj = i_highd + ny_adj = j_highd + + if(ny > j_highd) then + print *,'nx < i_highd and ny > j_highd' + stop + endif + endif + else + raster => soil_high + iRaster => tile_id + end if + + ! Interpolate/aggregate soil depth from raster grid to catchment-tiles + + allocate(soildepth(1:n_land)) + allocate(count_soil(1:n_land)) + + soildepth = 0. ! 1-d tile space + count_soil = 0. ! 1-d tile space + + do j=1,ny_adj + do i=1,nx_adj + if((iRaster(i,j).gt.0).and.(iRaster(i,j).le.n_land)) then + if ((raster(i,j).gt.0)) then + soildepth(iRaster(i,j)) = & + soildepth(iRaster(i,j)) + sf*raster(i,j) ! integer "raster" --> real "soildepth" + count_soil(iRaster(i,j)) = & + count_soil(iRaster(i,j)) + 1. + endif + endif + end do + end do + + DO n =1,n_land + if(count_soil(n)/=0.) soildepth(n)=soildepth(n)/count_soil(n) + soildepth(n) = max(soildepth(n),SOILDEPTH_MIN_HWSD) + ! soildepth(n) = soildepth(n) + 2000. + ! soildepth(n) = min(soildepth(n),8000.) + END DO + + deallocate (SOIL_HIGH) + !deallocate (count_soil) ! do not deallocate, needed again shortly + NULLIFY(Raster) + + ! --------------------------------------------------------------------------------- ! - ! ASSERT THAT rmap IS CONSISTENT WITH 30-arcsec GRID OF MODIS INPUTS + ! Read NGDC-HWSD-STATSGO merged soil texture from SoilProperties_H[xx]V[yy].nc' ! - ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! get info common to all H[xx]V[yy] rectangles (could in theory differ from that + ! of soildepth data read above but is the same as of 29 Apr 2022). - ! Read number of catchment-tiles (N_tile) from catchment.def file + if (trim(SOILBCS)=='HWSD_b') then + tmpversion = 'v3' + else if (trim(SOILBCS)=='HWSD') then + tmpversion = 'v2' + else + print *, 'Unknown SOILBCS: ', SOILBCS + stop + end if - fname='clsm/catchment.def' - open (10,file=fname,status='old',action='read',form='formatted') - read (10,*) N_tile ! # of tiles - close(10,status='keep') - - allocate(stch_snw_alb (1:nc_10,1:nr_10)) ! 10deg-by-10deg snow albedo data - allocate(snw_alb (1:N_tile)) ! snow albedo in tile space - allocate(count_snow_alb (1:N_tile)) ! count of MODIS grid cells contributing to tile-average snow albedo - - snw_alb = -9999. ! set all to missing - count_snow_alb = 0. ! initialize counter (SHOULD THIS BE KIND REAL???) - - ! loop through the 36x18 10deg-by-10deg MODIS files - - do jx = 1,18 + fname =trim(MAKE_BCS_INPUT_DIR)//'/land/soil/SOIL-DATA/soil_properties/' // tmpversion // '/SoilProperties_H11V13.nc' + status = NF_OPEN(trim(fname),NF_NOWRITE, ncid); VERIFY_(STATUS) + !status = NF_GET_att_INT(ncid,NF_GLOBAL,'i_ind_offset_LL',iLL); VERIFY_(STATUS) ! cannot be needed here + !status = NF_GET_att_INT(ncid,NF_GLOBAL,'j_ind_offset_LL',jLL); VERIFY_(STATUS) ! cannot be needed here + status = NF_GET_att_INT(ncid,NF_GLOBAL,'N_lon_global',i_highd); VERIFY_(STATUS) + status = NF_GET_att_INT(ncid,NF_GLOBAL,'N_lat_global',j_highd); VERIFY_(STATUS) + status = NF_INQ_DIM (ncid,1,string, nc_10); VERIFY_(STATUS) + status = NF_INQ_DIM (ncid,2,string, nr_10); VERIFY_(STATUS) + status = NF_CLOSE(ncid) + + ! SoilProperties_H[xx]V[yy].nc as of 29 Apr 2022: + ! + ! Associated 43200-by-21600 global grid (1/120=0.083333 deg lat/lon): + ! + ! N_lon_global = i_highd = 43200 + ! N_lat_global = j_highd = 21600 + ! + ! i_ind_offset_LL = iLL = 42001 + ! j_ind_offset_LL = jLL = 19201 + ! + ! Each file contains soil texture data for one rectangle of size 1200-by-1200, which is + ! assumed to be the same for each H[xx]V[yy] rectangle + ! + ! N_lon = nc_10 = 1200 + ! N_lat = nr_10 = 1200 + + !regrid = nx/=i_highd .or. ny/=j_highd ! not needed here, done below + + allocate(net_data1 (1:nc_10,1:nr_10)) + allocate(net_data2 (1:nc_10,1:nr_10)) + allocate(net_data3 (1:nc_10,1:nr_10)) + allocate(net_data4 (1:nc_10,1:nr_10)) + allocate(net_data5 (1:nc_10,1:nr_10)) + allocate(net_data6 (1:nc_10,1:nr_10)) + allocate(net_data7 (1:nc_10,1:nr_10)) + + allocate(sand_top (1:i_highd,1:j_highd)) + allocate(clay_top (1:i_highd,1:j_highd)) + allocate(oc_top (1:i_highd,1:j_highd)) + allocate(sand_sub (1:i_highd,1:j_highd)) + allocate(clay_sub (1:i_highd,1:j_highd)) + allocate(oc_sub (1:i_highd,1:j_highd)) + allocate(grav_grid(1:i_highd,1:j_highd)) + + sand_top = -9999 ! integer*2 + clay_top = -9999 ! integer*2 + oc_top = -9999 ! integer*2 + sand_sub = -9999 ! integer*2 + clay_sub = -9999 ! integer*2 + oc_sub = -9999 ! integer*2 + grav_grid= -9999 ! integer*2 + + do jx = 1,18 do ix = 1,36 - - ! assemble file name and open file - - write (hh,'(i2.2)') ix - write (vv,'(i2.2)') jx - - fname = trim(MAKE_BCS_INPUT_DIR) // '/land/albedo/snow/MODIS/v2/snow_alb_FillVal_MOD10A1.061_30arcsec_H'//hh//'V'//vv//'.nc' - - status = NF_OPEN (trim(fname),NF_NOWRITE, ncid) ! open file to read - - if(status == 0) then ! if file exists, read snow albedo - - status = NF_GET_VARA_REAL( ncid, NC_VarID(NCID,'Snow_Albedo'), (/1,1/), (/nc_10,nr_10/), stch_snw_alb); VERIFY_(STATUS) - - ! verify that input snow albedo has been back-filled *everywhere*, incl. water and landice - ! (i.e., stch_snw_alb must not contain no-data or unphysical values) - - if ( any(stch_snw_alb<0.) .or. any(stch_snw_alb>1.) ) then - - print *, 'ERROR: subroutine ', trim(Iam), '() : detected no-data or unphysical values in MODIS file ', trim(fname) - print *, 'STOPPING.' - stop - - end if - - ! calculate Lower Left (LL) indices for the chunk of the global 30-arcsec grid that is stored in file (ix,jx) - ! - ! NOTE: In similar subroutines for processing other data, iLL and jLL are stored in the nc4 file. - - iLL=(ix-1)*nc_10+1 - jLL=(jx-1)*nr_10+1 - - ! loop through 30-arcsec grid cells in current 10deg-by-10deg chunk - - do jj=1,nr_10 - do ii=1,nc_10 - - iG = ii+iLL-1 ! i-index relative to *global* 30-arcsec grid - jG = jj+jLL-1 ! j-index relative to *global* 30-arcsec grid - - pix_count = rmap%ij_index(iG,jG) ! pix_count == ID/index of tile to which current 30-arcsec grid cell belongs [???] - - if (pix_count == 0) cycle ! if this MODIS grid cell has no corresponding remapped value, skip it - - if (rmap%map(pix_count)%nt > 0) then ! if the # of tiles corresponding to this gridbox is gt 0, proceed with calculations - - do nn = 1,rmap%map(pix_count)%nt ! loop through all corresponding tiles [???] - - ! if first pass, set albedo to zero - ! [????] CAN THIS BE SKIPPED IF snw_alb IS INITIALIZED TO ZERO ABOVE? - ! BECAUSE MODIS DATA ARE BACKFILLED, THERE SHOULD NOT BE NO-DATA-VALUES FOR ANY TILE - if (snw_alb(rmap%map(pix_count)%tid(nn)) == -9999.) snw_alb(rmap%map(pix_count)%tid(nn)) = 0. - - ! accumulate values and counts - snw_alb(rmap%map(pix_count)%tid(nn)) = & - snw_alb(rmap%map(pix_count)%tid(nn)) + stch_snw_alb(ii,jj)*rmap%map(pix_count)%count(nn) - - ! [???] rmap%map(pix_count)%count(nn) IS INTEGER; MAKE count_snow_alb INTEGER AFTER FIRST ASSERTING 0-DIFF FOR CURRENT CLEANUP - count_snow_alb(rmap%map(pix_count)%tid(nn)) = & - count_snow_alb(rmap%map(pix_count)%tid(nn)) + 1.*rmap%map(pix_count)%count(nn) - - end do + write (vv,'(i2.2)')jx + write (hh,'(i2.2)')ix + fname = trim(MAKE_BCS_INPUT_DIR)//'/land/soil/SOIL-DATA/soil_properties/' // tmpversion // '/SoilProperties_H'//hh//'V'//vv//'.nc' + status = NF_OPEN(trim(fname),NF_NOWRITE, ncid) + if(status == 0) then + status = NF_GET_att_INT (ncid, NF_GLOBAL,'i_ind_offset_LL',iLL); VERIFY_(STATUS) + status = NF_GET_att_INT (ncid, NF_GLOBAL,'j_ind_offset_LL',jLL); VERIFY_(STATUS) + ! assume UNDEF and ScaleFactor (sf) are the same for *all* variables read below + ! (ok for SoilProperties_H[xx]V[yy].nc as of 29 Apr 2022). + status = NF_GET_att_INT (ncid, 4,'UNDEF',d_undef); VERIFY_(STATUS) + status = NF_GET_att_REAL (ncid, 4,'ScaleFactor',sf); VERIFY_(STATUS) + status = NF_GET_VARA_INT (ncid, 4,(/1,1/),(/nc_10,nr_10/),net_data1); VERIFY_(STATUS) + status = NF_GET_VARA_INT (ncid, 5,(/1,1/),(/nc_10,nr_10/),net_data2); VERIFY_(STATUS) + status = NF_GET_VARA_INT (ncid, 6,(/1,1/),(/nc_10,nr_10/),net_data3); VERIFY_(STATUS) + status = NF_GET_VARA_INT (ncid, 7,(/1,1/),(/nc_10,nr_10/),net_data4); VERIFY_(STATUS) + status = NF_GET_VARA_INT (ncid, 8,(/1,1/),(/nc_10,nr_10/),net_data5); VERIFY_(STATUS) + status = NF_GET_VARA_INT (ncid, 9,(/1,1/),(/nc_10,nr_10/),net_data6); VERIFY_(STATUS) + status = NF_GET_VARA_INT (ncid,10,(/1,1/),(/nc_10,nr_10/),net_data7); VERIFY_(STATUS) + do j = jLL,jLL + nr_10 -1 + do i = iLL, iLL + nc_10 -1 + if(net_data1(i-iLL +1 ,j - jLL +1) /= d_undef) & + clay_top(i,j) = net_data1(i-iLL +1 ,j - jLL +1) + if(net_data2(i-iLL +1 ,j - jLL +1) /= d_undef) & + sand_top(i,j) = net_data2(i-iLL +1 ,j - jLL +1) + if(net_data3(i-iLL +1 ,j - jLL +1) /= d_undef) & + oc_top (i,j) = net_data3(i-iLL +1 ,j - jLL +1) + if(net_data4(i-iLL +1 ,j - jLL +1) /= d_undef) & + clay_sub(i,j) = net_data4(i-iLL +1 ,j - jLL +1) + if(net_data5(i-iLL +1 ,j - jLL +1) /= d_undef) & + sand_sub(i,j) = net_data5(i-iLL +1 ,j - jLL +1) + if(net_data6(i-iLL +1 ,j - jLL +1) /= d_undef) & + oc_sub (i,j) = net_data6(i-iLL +1 ,j - jLL +1) + if(net_data7(i-iLL +1 ,j - jLL +1) /= d_undef) & + grav_grid(i,j) = net_data7(i-iLL +1 ,j - jLL +1) + enddo + enddo + status = NF_CLOSE(ncid) + endif + end do + end do - endif ! if not missing - enddo ! ii-loop - enddo ! jj-loop - - ! Close the file, freeing all resources. - status=NF_CLOSE(ncid); VERIFY_(STATUS) - + deallocate (net_data1) + deallocate (net_data2) + deallocate (net_data3) + deallocate (net_data4) + deallocate (net_data5) + deallocate (net_data6) + deallocate (net_data7) + + ! ---------------------------------------------------------------------------- + + if(use_PEATMAP) then + print *, 'PEATMAP_THRESHOLD_1 : ', PEATMAP_THRESHOLD_1 + allocate(pmapr (1:i_highd,1:j_highd)) + status = NF_OPEN (trim(MAKE_BCS_INPUT_DIR)//'/land/soil/SOIL-DATA/PEATMAP_mask.nc4', NF_NOWRITE, ncid) + status = NF_GET_VARA_REAL (ncid,NC_VarID(NCID,'PEATMAP'), (/1,1/),(/i_highd, j_highd/), pmapr) ; VERIFY_(STATUS) + + ! move HWSD sub-surface peat to peat-rich mineral Group 3 because merged surface peat defines sub-surface peat + + where (oc_sub*sf >= cF_lim(4)) + oc_sub = NINT(8./sf) + endwhere + + ! Hybridize: add OC 1km PEATMAP pixels to HWSD oc_top + + where (pmapr >= PEATMAP_THRESHOLD_1) + oc_top = NINT(33.0/sf) + endwhere + + deallocate (pmapr) + status = NF_CLOSE(ncid) + endif + + ! ---------------------------------------------------------------------------- + + ! Regridding + + ! *EASE* grid bcs use mask file GEOS5_10arcsec_mask.nc or GEOS5_10arcsec_mask_freshwater-lakes.nc, + ! and the make_bcs script assigns NX=43200, NY=21600, which are passed into the present subroutine + ! via command-line arguments of mkCatchParam.x. That is, should have regrid=.false. for *EASE* + ! grid tile space. + + nx_adj = nx + ny_adj = ny + + regrid = nx/=i_highd .or. ny/=j_highd + + if(regrid) then + if(nx > i_highd) then + allocate(raster1(nx,ny),stat=STATUS); VERIFY_(STATUS) + call RegridRaster2(clay_top,raster1) + + allocate(raster2(nx,ny),stat=STATUS); VERIFY_(STATUS) + call RegridRaster2(sand_top,raster2) + + allocate(raster3(nx,ny),stat=STATUS); VERIFY_(STATUS) + call RegridRaster2(oc_top, raster3) + + allocate(raster4(nx,ny),stat=STATUS); VERIFY_(STATUS) + call RegridRaster2(clay_sub,raster4) + + allocate(raster5(nx,ny),stat=STATUS); VERIFY_(STATUS) + call RegridRaster2(sand_sub,raster5) + + allocate(raster6(nx,ny),stat=STATUS); VERIFY_(STATUS) + call RegridRaster2(oc_sub, raster6) + + allocate(raster (nx,ny),stat=STATUS); VERIFY_(STATUS) + call RegridRaster2(grav_grid,raster) + + iRaster => tile_id + + if(ny < j_highd) then + print *,'nx > i_highd and ny < j_highd' + stop endif - end do ! jx-loop through 10deg-by-10deg files - end do ! ix-loop through 10deg-by-10deg files - - ! finalize calculation of mean values - ! [???] NOTE: count_snw_alb SHOULD BE INTEGER --> CONVERT TO REAL - - ! because MODIS data are backfilled, should have count_snow_alb>0 - - if ( any(count_snow_alb<=0.) ) then - - print *, 'ERROR: subroutine ', trim(Iam), '() : something wrong with count_snow_alb(:)' - print *, 'STOPPING.' - stop - + else + nx_adj = i_highd + ny_adj = j_highd + if( .not.associated(iraster) ) then + allocate(iRaster(i_highd,j_highd),stat=STATUS); VERIFY_(STATUS) + endif + call RegridRaster(tile_id,iRaster) + + raster1 => clay_top + raster2 => sand_top + raster3 => oc_top + raster4 => clay_sub + raster5 => sand_sub + raster6 => oc_sub + raster => grav_grid + + if(ny > j_highd) then + print *,'nx < i_highd and ny > j_highd' + stop + endif + endif + else + iRaster => tile_id + raster1 => clay_top + raster2 => sand_top + raster3 => oc_top + raster4 => clay_sub + raster5 => sand_sub + raster6 => oc_sub + raster => grav_grid end if - - snw_alb = snw_alb/count_snow_alb ! finalize calculation of tile-average snow albedo - - ! write snow albedo into clsm/catch_params.nc4 - inquire(file='clsm/catch_params.nc4', exist=file_exists) - - if(file_exists) then - status = NF_OPEN ('clsm/catch_params.nc4', NF_WRITE, ncid ) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'SNOWALB'),(/1/),(/N_tile/),real(snw_alb)) ; VERIFY_(STATUS) - STATUS = NF_CLOSE (NCID) ; VERIFY_(STATUS) + ! ---------------------------------------------------------------------------- + + ! compute peat fraction on tile for CLM45+ (for fires?) + + allocate(pmap (1:n_land)) + !allocate(count_soil(1:n_land)) ! already allocated above + + pmap = 0. ! 1-d tile space; peat fraction in tile based on oc_top + count_soil = 0. ! 1-d tile space + + do j=1,ny_adj + do i=1,nx_adj + if((iRaster(i,j).gt.0).and.(iRaster(i,j).le.n_land)) then + count_soil(iRaster(i,j)) = count_soil(iRaster(i,j)) + 1. + if (raster3(i,j)*sf >= cF_lim(4)) then + pmap (iRaster(i,j)) = pmap(iRaster(i,j)) + 1 + endif + endif + end do + end do + + where (count_soil > 0) pmap = pmap /count_soil + + !deallocate (count_soil) ! do not deallocate, needed again shortly + + ! ---------------------------------------------------------------------------- + + ! get number of "land" pixels (i1) on raster grid + + allocate(land_pixels(1:size(iRaster,1),1:size(iRaster,2))) + land_pixels = (iRaster >=1).and.(iRaster<=n_land) + i1 = count(land_pixels) + deallocate (land_pixels) + + ! allocate 1-d arrays for all "land" pixels on raster grid + + allocate (tileid_vec(1:i1)) + allocate (data_vec1 (1:i1)) + allocate (data_vec2 (1:i1)) + allocate (data_vec3 (1:i1)) + allocate (data_vec4 (1:i1)) + allocate (data_vec5 (1:i1)) + allocate (data_vec6 (1:i1)) + + ! allocate 1-d arrays for all "land" tiles + + allocate (grav_vec (1:n_land)) + allocate (soc_vec (1:n_land)) + allocate (poc_vec (1:n_land)) + !allocate (ncells_top (1:n_land)) ! ncells_* not used + !allocate (ncells_top_pro (1:n_land)) ! ncells_* not used + !allocate (ncells_sub_pro (1:n_land)) ! ncells_* not used + !allocate(count_soil(1:n_land)) + + count_soil = 0. + grav_vec = 0. + soc_vec = 0. ! soil orgC (top layer 0-30) + poc_vec = 0. ! soil orgC (profile layer 0-100) + + !ncells_top = 0. ! ncells_* not used + !ncells_top_pro = 0. ! ncells_* not used + !ncells_sub_pro = 0. ! ncells_* not used + + n =1 + do j=1,ny_adj + do i=1,nx_adj + if((iRaster(i,j).ge.1).and.(iRaster(i,j).le.n_land)) then + + ! map from 2-d raster array to 1-d raster vec + + tileid_vec (n) = iRaster(i,j) ! iRaster => tile_id int*4 + data_vec1 (n) = Raster1(i,j) ! raster1 => clay_top int*2 + data_vec2 (n) = Raster2(i,j) ! raster2 => sand_top int*2 + data_vec3 (n) = Raster3(i,j) ! raster3 => oc_top int*2 + data_vec4 (n) = Raster4(i,j) ! raster4 => clay_sub int*2 + data_vec5 (n) = Raster5(i,j) ! raster5 => sand_sub int*2 + data_vec6 (n) = Raster6(i,j) ! raster6 => oc_sub int*2 + + ! BUG??? It is unclear why here grav_vec is filled in the order of "tile_id" + ! while data_vec[x] is filled in the order of the long/lat grid. + ! Not sure if grav_vec is processed correctly below! + ! -reichle, 29 Apr 2022 + + if ((raster(i,j).gt.0)) then + grav_vec(iRaster(i,j)) = & + grav_vec(iRaster(i,j)) + sf*raster(i,j) ! raster => grav_grid int*2 + count_soil(iRaster(i,j)) = & + count_soil(iRaster(i,j)) + 1. + endif + n = n + 1 + endif + end do + end do + + DO n =1,n_land + if(count_soil(n)/=0.) grav_vec(n)=grav_vec(n)/count_soil(n) + END DO + + deallocate (count_soil) + NULLIFY(Raster,Raster1,Raster2,Raster3,Raster4,Raster5,Raster6) + deallocate (clay_top,sand_top,oc_top,clay_sub,sand_sub,oc_sub,grav_grid) + + ! sort 1-d land pixels vectors according to tile_id + + allocate (arrayA (1:i1)) ! 1-d land pixels on raster grid + allocate (arrayB (1:i1)) ! 1-d land pixels on raster grid + + arrayA = tileid_vec + arrayB = data_vec1 + call MAPL_Sort (arrayA, arrayB) + data_vec1 = arrayB + + arrayA = tileid_vec + arrayB = data_vec2 + call MAPL_Sort (arrayA, arrayB) + data_vec2 = arrayB + + arrayA = tileid_vec + arrayB = data_vec3 + call MAPL_Sort (arrayA, arrayB) + data_vec3 = arrayB + + arrayA = tileid_vec + arrayB = data_vec4 + call MAPL_Sort (arrayA, arrayB) + data_vec4 = arrayB + + arrayA = tileid_vec + arrayB = data_vec5 + call MAPL_Sort (arrayA, arrayB) + data_vec5 = arrayB + + arrayA = tileid_vec + arrayB = data_vec6 + call MAPL_Sort (arrayA, arrayB) + data_vec6 = arrayB + + tileid_vec= arrayA + + deallocate (arrayA, arrayB) + + ! -------------------------------------------------------------------- + ! + ! Read Woesten soil parameters and CLSM tau parameters for soil classes (1:253) + + allocate(a_sand (1:n_SoilClasses)) + allocate(a_clay (1:n_SoilClasses)) + allocate(a_silt (1:n_SoilClasses)) + allocate(a_oc (1:n_SoilClasses)) + allocate(a_bee (1:n_SoilClasses)) + allocate(a_psis (1:n_SoilClasses)) + allocate(a_poros (1:n_SoilClasses)) + allocate(a_wp (1:n_SoilClasses)) + allocate(a_aksat (1:n_SoilClasses)) + allocate(atau (1:n_SoilClasses)) + allocate(btau (1:n_SoilClasses)) + allocate(atau_2cm(1:n_SoilClasses)) + allocate(btau_2cm(1:n_SoilClasses)) + allocate(a_wpsurf(1:n_SoilClasses)) + allocate(a_porosurf(1:n_SoilClasses)) + + ! SoilClasses-SoilHyd-TauParam.dat and SoilClasses-SoilHyd-TauParam.peatmap differ + ! only in the parameters for the peat class #253. The file *.peatmap contains + ! the PEATCLSM parameters from Table 2 of Bechtold et al. 2019 (doi:10.1029/2018MS001574). + ! + ! Note: K_s = COND*exp(-zks*gnu) ==> with zks=2 and gnu=1, K_s = 0.135335*COND + ! + ! K_s COND [m/s] + ! NLv4 7.86e-7 5.81e-6 + ! NLv5 3.79e-6 2.80e-5 <== note *typo* in Table 2 of Bechtold et al. 2019, which erroneously lists K_s=2.8e-5 + + if(use_PEATMAP) then + fname = trim(MAKE_BCS_INPUT_DIR)//'/land/soil/SOIL-DATA/SoilClasses-SoilHyd-TauParam.peatmap' + else + fname = trim(MAKE_BCS_INPUT_DIR)//'/land/soil/SOIL-DATA/SoilClasses-SoilHyd-TauParam.dat' endif - - deallocate(stch_snw_alb) - deallocate(count_snow_alb) - deallocate(snw_alb) - - END SUBROUTINE MODIS_snow_alb_v2 - - !---------------------------------------------------------------------- - - SUBROUTINE MODIS_snow_alb( ) - ! Map static, MODIS climatology-based snow albedo from preprocessed 30-arcsec grid - ! to land tiles and write into clsm/catch_params.nc4. + table_map = 0 ! 100-by-3 look-up table + + open (11, file=trim(fname), form='formatted',status='old', & + action = 'read') + read (11,'(a)')fout ! read header line + + do n =1,n_SoilClasses + + read (11,'(4f7.3,4f8.4,e13.5,2f12.7,2f8.4,4f12.7)')a_sand(n),a_clay(n),a_silt(n),a_oc(n),a_bee(n),a_psis(n), & + a_poros(n),a_wp(n),a_aksat(n),atau(n),btau(n),a_wpsurf(n),a_porosurf(n),atau_2cm(n),btau_2cm(n) + + ! assemble scalar structure that holds mineral percentages of soil class n + + min_percs%clay_perc = a_clay(n) + min_percs%silt_perc = a_silt(n) + min_percs%sand_perc = a_sand(n) + + ! "soil_class" is an integer function (see rmTinyCatchParam.F90) that assigns + ! an integer (mineral) soil class [1-100] for a given mineral percentage triplet + + ! "table_map" is a 2-d array (100-by-3) that maps between overall soil class (1:252) and + ! (mineral_class 1:84, orgC_class). "table_map" has no entry for the peat class #253. + + if( n <= nsoil_pcarbon(1)) table_map(soil_class (min_percs),1) = n + if((n > nsoil_pcarbon(1)).and.(n <= nsoil_pcarbon(2))) table_map(soil_class (min_percs),2) = n + if((n > nsoil_pcarbon(2)).and.(n <= nsoil_pcarbon(3))) table_map(soil_class (min_percs),3) = n + + end do ! n=1,n_SoilClasses + + close (11,status='keep') + + ! ------------------------------------------------------------ ! - ! Assumes that input snow albedo is backfilled (i.e., does not contain no-data values). + ! When Woesten soil parameters are not available for a particular soil class, + ! as defined by "tiny" triangles in HWSD soil triangle, Woesten soil + ! parameters from the nearest available "tiny" triangle will be substituted. + ! For "tiny" triangles, see Fig 1b of De Lannoy et al. 2014 (doi:10.1002/2014MS000330). + + do n =1,10 + do k=1,n*2 -1 + + min_percs%clay_perc = 100. -((n-1)*10 + 5) + min_percs%sand_perc = 100. - min_percs%clay_perc -2.-(k-1)*5. + min_percs%silt_perc = 100. - min_percs%clay_perc - min_percs%sand_perc + + i = soil_class (min_percs) + + if(table_map (i,1)== 0) then + j = center_pix (a_clay(1:nsoil_pcarbon(1)),a_sand(1:nsoil_pcarbon(1)), & + min_percs%clay_perc,min_percs%sand_perc,min_percs%silt_perc,.true.) + + min_percs%clay_perc = a_clay(j) + min_percs%silt_perc = a_silt(j) + min_percs%sand_perc = a_sand(j) + table_map (i,1)= table_map (soil_class (min_percs),1) + endif + + min_percs%clay_perc = 100. -((n-1)*10 + 5) + min_percs%sand_perc = 100. - min_percs%clay_perc -2.-(k-1)*5. + min_percs%silt_perc = 100. - min_percs%clay_perc - min_percs%sand_perc + + if(table_map (i,2)== 0) then + j = center_pix(a_clay(nsoil_pcarbon(1)+1 : nsoil_pcarbon(2)), & + a_sand(nsoil_pcarbon(1)+1 : nsoil_pcarbon(2)), & + min_percs%clay_perc,min_percs%sand_perc,min_percs%silt_perc,.true.) + min_percs%clay_perc = a_clay(j + nsoil_pcarbon(1)) + min_percs%silt_perc = a_silt(j + nsoil_pcarbon(1)) + min_percs%sand_perc = a_sand(j + nsoil_pcarbon(1)) + table_map (i,2)= table_map (soil_class (min_percs),2) + endif + + min_percs%clay_perc = 100. -((n-1)*10 + 5) + min_percs%sand_perc = 100. - min_percs%clay_perc -2.-(k-1)*5. + min_percs%silt_perc = 100. - min_percs%clay_perc - min_percs%sand_perc + + if(table_map (i,3)== 0) then + j = center_pix (a_clay(nsoil_pcarbon(2)+1 : nsoil_pcarbon(3)), & + a_sand(nsoil_pcarbon(2)+1 : nsoil_pcarbon(3)), & + min_percs%clay_perc,min_percs%sand_perc,min_percs%silt_perc,.true.) + min_percs%clay_perc = a_clay(j + nsoil_pcarbon(2)) + min_percs%silt_perc = a_silt(j + nsoil_pcarbon(2)) + min_percs%sand_perc = a_sand(j + nsoil_pcarbon(2)) + table_map (i,3)= table_map (soil_class (min_percs),3) + endif + end do + end do ! - ! Snow albedo assigned to each tile is average over 30-arcsec MODIS grid cells located - ! within the rectangle defined by the min/max lat/lon of tile; this can include MODIS grid - ! cells located in neighboring land tiles and/or water/landice tiles. - ! See subroutine MODIS_snow_alb_v2() for a refined algorithm. + ! Now deriving soil types based on NGDC-HWSD-STATSGO merged soil property maps ! - ! Biljana Orescanin July 2022, SSAI@NASA + allocate (soil_class_top (1:n_land)) + allocate (soil_class_com (1:n_land)) + soil_class_top =-9999 + soil_class_com =-9999 - implicit none + allocate(low_ind(n_threads)) + allocate(upp_ind(n_threads)) + low_ind(1) = 1 + upp_ind(n_threads) = n_land - character*200 :: fname - character*2 :: vv,hh - integer :: n,N_tile,ncid,status - real,allocatable,dimension(:) :: min_lon,max_lon,min_lat,max_lat,snw_alb - integer(kind=4),parameter :: xdim = 1200, ydim = 1200 - real,dimension(xdim,ydim) :: stch_snw_alb_tmp - real,dimension(36,18,xdim,ydim) :: stch_snw_alb - real :: minlon,maxlon,minlat,maxlat - real :: sno_alb_cnt,sno_alb_sum - integer :: vvtil_min,hhtil_min,vvtil_max,hhtil_max,hhtil,vvtil - integer :: tindex1,pfaf1 - integer(kind=4) :: imin,imax,jmin,jmax,varid1 - logical :: file_exists + if (running_omp) then + do i=1,n_threads-1 + upp_ind(i) = low_ind(i) + (n_land/n_threads) - 1 + low_ind(i+1) = upp_ind(i) + 1 + end do + end if + + !$OMP PARALLELDO DEFAULT(NONE) & + !$OMP SHARED( n_threads, low_ind, upp_ind, tileid_vec, & + !$OMP sf,data_vec1,data_vec2,data_vec3, & + !$OMP data_vec4,data_vec5,data_vec6,cF_lim, & + !$OMP table_map,soil_class_top,soil_class_com, & + !$OMP soc_vec,poc_vec,use_PEATMAP) & + !ncells_* not used !$OMP soc_vec,poc_vec,ncells_top,ncells_top_pro,& + !ncells_* not used !$OMP ncells_sub_pro,use_PEATMAP) & + !$OMP PRIVATE(n,i,j,k,icount,t_count,i1,i2,ss_clay, & + !$OMP ss_sand,ss_clay_all,ss_sand_all, & + !$OMP ss_oc_all,cFamily,factor,o_cl,o_clp,ktop, & + !$OMP min_percs, fac_count, write_debug) + + ! loop through tiles (split into two loops for OpenMP) + + DO t_count = 1,n_threads + DO n = low_ind(t_count),upp_ind(t_count) + + write_debug = .false. + + ! if (n==171010) write_debug = .true. + + ! initialize "icount" when starting loop through n at low_ind(t_count) + ! recall: tileid_vec is a 1-d vector that covers all land pixels on the raster grid that + ! contains the (sorted) tile IDs, with matching parameter vectors data_vec[x] + + if(n==low_ind(t_count)) then + icount = 1 + ! Not sure what the following loops do. Why not check backwards from low_ind(t_count)?? + do k=1,low_ind(t_count) - 1 + do while (tileid_vec(icount)== k) + icount = icount + 1 + end do + end do + endif - ! Read number of catchment-tiles (N_tile) from catchment.def file - fname='clsm/catchment.def' - open (10,file=fname,status='old',action='read',form='formatted') - read(10,*) N_tile + ! ------------------------------------------------------------------ + ! + ! determine the land raster grid cells i1:i2 that make up tile n - ! Read min/max lat/lons to use when locating snow albedo grids in - ! the stitched MODIS albedo file - allocate (min_lon(1:N_tile)) - allocate (min_lat(1:N_tile)) - allocate (max_lon(1:N_tile)) - allocate (max_lat(1:N_tile)) - allocate (snw_alb(1:N_tile)) + ! NOTE change in meaning of "i1": + ! + ! before: i1 = total no. of land pixels on the raster grid + ! now: i1 = starting index of land raster grid cells (within 1-d vector) that make up tile n (?) - ! Start by setting all snow albedo values to missing - snw_alb(:)=MAPL_UNDEF + i1 = icount - do n = 1, N_tile - read (10,*) tindex1,pfaf1,minlon,maxlon,minlat,maxlat - min_lon(n) = minlon - max_lon(n) = maxlon - min_lat(n) = minlat - max_lat(n) = maxlat - end do + loop: do while (tileid_vec(icount)== n) + if(icount <= size(tileid_vec,1)) icount = icount + 1 + if(icount > size(tileid_vec,1)) exit loop + end do loop - close (10,status='keep') - - call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) + i2 = icount -1 + i = i2 - i1 + 1 ! number of land raster grid cells that make up tile n (?) - ! ----------- Get the information on snow albedo ----- - ! ----------- The information on snow albedo is stored in 10x10deg 30-arcsec resolution files. - ! ----------- Read in this information, then loop over the tiles to find a corresponding snow albedo. - ! Read in all 10x10deg snow albedo files into a single [36,18,1200,1200] array - do hhtil=1,36 ! loop over input files - horizontal direction - do vvtil=1,18 ! loop over input files - vertical direction + ! ------------------------------------------------------------------- + ! + ! prep data - write(vv,'(i2.2)') vvtil - write(hh,'(i2.2)') hhtil + allocate(ss_clay (1:2*i)) ! for top layer (0-30) -- why allocate 1:2*i and not 1:i?? + allocate(ss_sand (1:2*i)) ! for top layer (0-30) -- why allocate 1:2*i and not 1:i?? - ! MODIS-based climatology albedo raster files, backfilled with global land - ! average snow albedo (=0.56; average excludes Antarctica and Greenland ice - ! sheets and is weighted by the grid-cell area). + allocate(ss_clay_all(1:2*i)) ! for top (0-30) and sub (30-100) layers + allocate(ss_sand_all(1:2*i)) ! for top (0-30) and sub (30-100) layers + allocate(ss_oc_all (1:2*i)) ! for top (0-30) and sub (30-100) layers - fname =trim(MAKE_BCS_INPUT_DIR)//'/land/albedo/snow/MODIS/v2/snow_alb_FillVal_MOD10A1.061_30arcsec_H'//hh//'V'//vv//'.nc' + ss_clay = 0 ! int*2 -- why only clay and sand for top layer and not orgC ?? + ss_sand = 0 ! int*2 - ! Open the file. (NF90_NOWRITE ensures read-only access to the file) - status=NF_OPEN(trim(fname),NF_NOWRITE, ncid) ; VERIFY_(STATUS) - ! Based on vars name, get the varids. - status=NF_INQ_VARID(ncid,'Snow_Albedo',VarID1) ; VERIFY_(STATUS) - ! Read the data. - status=NF_GET_VARA_REAL(ncid,VarID1,(/1,1/),(/xdim,ydim/),stch_snw_alb_tmp) ; VERIFY_(STATUS) - ! Close the file, freeing all resources. - status=NF_CLOSE(ncid); VERIFY_(STATUS) + ss_clay_all= 0 ! int*2 + ss_sand_all= 0 ! int*2 + ss_oc_all = 0 ! int*2 - ! Store snow albedo values into a single 4D aray - stch_snw_alb(hhtil,vvtil,:,:)=stch_snw_alb_tmp + ss_clay_all (1:i) = data_vec1(i1:i2) ! put top layer info into first i elements (1:i) + ss_sand_all (1:i) = data_vec2(i1:i2) + ss_oc_all (1:i) = data_vec3(i1:i2) - enddo - enddo + ss_clay_all (1+i:2*i) = data_vec4(i1:i2) ! put sub layer info into next i elements (i+1:2*i) + ss_sand_all (1+i:2*i) = data_vec5(i1:i2) + ss_oc_all (1+i:2*i) = data_vec6(i1:i2) ! <-- oc_sub - if (minval(stch_snw_alb) .le. 0.0 .or. maxval(stch_snw_alb) .gt. 1.0) then - print*, 'There is a problem with snow albedo raster file. Non-physical values present. STOP!' - stop - endif - ! loop over tiles - print*, 'Starting tile loop for snow albedo.' + ! ----------------------------------------------------------------------- + ! + ! determine aggregate/dominant orgC *top* layer soil class ("o_cl") of tile n - do n = 1, N_tile ! loop over tiles + cFamily = 0. + !! factor = 1. - ! Set sums and counts to zero - sno_alb_sum=0. - sno_alb_cnt=0. - - ! Use tile's min/max lat/lon info to identify the 10x10deg input file(s) - ! indexes - vvtil_min=floor((min_lat(n)+ 90.0)/10.)+1 - hhtil_min=floor((min_lon(n)+180.0)/10.)+1 - - ! if tile crosses the edge of the snow albedo 10x10deg box, expand the - ! search area into the neighbouring 10x10deg box - hhtil_max=hhtil_min - vvtil_max=vvtil_min - if (floor(min_lon(n)/10) .ne. floor(max_lon(n)/10)) hhtil_max=hhtil_min+1 - if (floor(min_lat(n)/10) .ne. floor(max_lat(n)/10)) vvtil_max=vvtil_min+1 - - ! Safety check; keep within the range - vvtil_min=max(vvtil_min,1) - vvtil_max=min(vvtil_max,18) - hhtil_min=max(hhtil_min,1) - hhtil_max=min(hhtil_max,36) - - do hhtil=hhtil_min,hhtil_max ! loop through input files - horizontal direction - do vvtil=vvtil_min,vvtil_max ! loop through input files - vertical direction - - ! Find indices ranges corresponding to the current tile area. - imin=floor((min_lon(n)+180.0 - (hhtil-1)*10.0) * (xdim/10.0)) +1 - imax=floor((max_lon(n)+180.0 - (hhtil-1)*10.0) * (xdim/10.0)) +1 - jmin=floor((min_lat(n)+ 90.0 - (vvtil-1)*10.0) * (ydim/10.0)) +1 - jmax=floor((max_lat(n)+ 90.0 - (vvtil-1)*10.0) * (ydim/10.0)) +1 - - ! if no matching grids, go to the next vv/hh box - if (imin .gt. xdim .or. jmin .gt. ydim .or. imax .lt. 1 .or. jmax .lt. 1) cycle - - ! Keep within the range, to include only the portion of the tile within this vv/hh box - imin=max(imin,1) - imax=min(imax,xdim) - jmin=max(jmin,1) - jmax=min(jmax,ydim) - - ! Generate sums and counts using current tile corresponding indices - sno_alb_sum = sno_alb_sum + sum(stch_snw_alb(hhtil,vvtil,imin:imax,jmin:jmax)) - sno_alb_cnt = sno_alb_cnt + (imax-imin+1)*(jmax-jmin+1) - - end do ! vvtil - end do ! hhtil - - ! If matching grids found, calculate snow albedo for the current tile; - ! ensure that resulting value is within physical range [0,1]. - if (sno_alb_cnt .ne. 0) snw_alb(n)=min(1.0,max(0.0,sno_alb_sum/sno_alb_cnt)) + do j=1,i + if(j <= i) factor = 1. + if((ss_oc_all(j)*sf >= cF_lim(1)).and. (ss_oc_all(j)*sf < cF_lim(2))) cFamily(1) = cFamily(1) + factor + if((ss_oc_all(j)*sf >= cF_lim(2)).and. (ss_oc_all(j)*sf < cF_lim(3))) cFamily(2) = cFamily(2) + factor + if((ss_oc_all(j)*sf >= cF_lim(3)).and. (ss_oc_all(j)*sf < cF_lim(4))) cFamily(3) = cFamily(3) + factor + if((ss_oc_all(j)*sf >= cF_lim(4) )) cFamily(4) = cFamily(4) + factor + end do - end do ! n-loop over tiles + if (sum(cFamily) == 0.) o_cl = 1 ! default is o_cl=1 (if somehow no grid cell has top-layer orgC >=0.) - ! write snow albedo into clsm/catch_params.nc4 - inquire(file='clsm/catch_params.nc4', exist=file_exists) + !! if (.not. use_PEATMAP) then - if(file_exists) then - status = NF_OPEN ('clsm/catch_params.nc4', NF_WRITE, ncid ) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'SNOWALB'),(/1/),(/N_tile/),real(snw_alb)) ; VERIFY_(STATUS) - STATUS = NF_CLOSE (NCID) ; VERIFY_(STATUS) - endif + ! assign dominant *top* layer org soil class (even if only a minority of the contributing + ! raster grid cells is peat) - print*, 'Ended tile loop for snow albedo. ' + if (sum(cFamily) > 0.) o_cl = maxloc(cFamily, dim = 1) - END SUBROUTINE MODIS_snow_alb + !! else - !-------------------------------------------------------------------------------------- + if (use_PEATMAP) then - SUBROUTINE soil_para_hwsd (nx,ny,fnameRst) - -! Processing NGDC-HWSD-STATSGO merged soil properties with Woesten Soil -! Parameters and produces tau_param.dat and soil_param.dat files - - implicit none - integer, intent (in) :: nx, ny - character(*) :: fnameRst - real, dimension (:), allocatable :: & - a_sand,a_clay,a_silt,a_oc,a_bee,a_psis, & - a_poros,a_wp,a_aksat,atau,btau,a_wpsurf,a_porosurf, & - atau_2cm,btau_2cm - integer, dimension (100,3) :: table_map - integer, dimension (3) :: nsoil_pcarbon - type (mineral_perc) :: min_percs - - integer :: n,maxcat,i,j,k,ktop,ncid,i_highd,j_highd,nx_adj,ny_adj - integer :: status,iLL,jLL,ix,jx,vid,nc_10,nr_10,d_undef, & - i1,i2,icount - character*100 :: fout - character*200 :: fname - character*10 :: string - character*2 :: VV,HH, tmpversion - - logical, allocatable, dimension(:,:) :: land_pixels - integer, allocatable, dimension (:,:) :: & - net_data1,net_data2,net_data3,net_data4,net_data5,net_data6 ,net_data7 - integer (kind=2) , allocatable, target, dimension (:,:) :: SOIL_HIGH, & - sand_top,clay_top,oc_top,sand_sub,clay_sub,oc_sub, grav_grid - integer (kind=2), pointer, dimension (:,:) :: Raster, & - Raster1,Raster2,Raster3,Raster4,Raster5,Raster6 - integer (kind=4), allocatable, dimension (:) :: tileid_vec,arrayA,arrayB - integer (kind=2), allocatable, dimension (:) :: & - data_vec1, data_vec2,data_vec3, data_vec4,data_vec5, data_vec6 - REAL, ALLOCATABLE, dimension (:) :: soildepth, grav_vec,soc_vec,poc_vec -! ncells_top,ncells_top_pro,ncells_sub_pro ! ncells_* not used - integer(kind=2) , allocatable, dimension (:) :: ss_clay, & - ss_sand,ss_clay_all,ss_sand_all,ss_oc_all - REAL, ALLOCATABLE :: count_soil(:) - integer, allocatable, target, dimension (:,:) :: tile_id - integer, pointer :: iRaster(:,:) - integer :: tindex, pfafindex,fac,o_cl,o_clp,fac_surf !,vtype - real,dimension(4) :: cFamily - real ,dimension(5) :: cF_lim - logical :: first_entry = .true. - logical :: regrid,write_debug - INTEGER, allocatable, dimension (:) :: soil_class_top,soil_class_com - REAL :: sf,factor,wp_wetness,fac_count,this_cond - logical :: CatchParamsNC_file_exists - REAL, ALLOCATABLE, DIMENSION (:,:) :: parms4file - - ! PEATCLSM: - REAL, PARAMETER :: PEATMAP_THRESHOLD_1 = 0.5 ! for converting PEATMAP area fraction into peat/non-peat (on raster grid) - REAL, PARAMETER :: PEATMAP_THRESHOLD_2 = 0.5 ! for aggregation from raster grid cells to tiles - - REAL, DIMENSION (:), POINTER :: PMAP - REAL, ALLOCATABLE, DIMENSION (:,:) :: PMAPR - - -! --------- VARIABLES FOR *OPENMP* PARALLEL ENVIRONMENT ------------ -! -! NOTE: "!$" is for conditional compilation -! -logical :: running_omp = .false. -! -!$ integer :: omp_get_thread_num, omp_get_num_threads -! -integer :: n_threads=1, li, ui, t_count -! -integer, dimension(:), allocatable :: low_ind, upp_ind -! -! ------------------------------------------------------------------ - - ! ----------- OpenMP PARALLEL ENVIRONMENT ---------------------------- - ! - ! FIND OUT WHETHER -omp FLAG HAS BEEN SET DURING COMPILATION - ! - !$ running_omp = .true. ! conditional compilation - ! - ! ECHO BASIC OMP VARIABLES - ! - !$OMP PARALLEL DEFAULT(NONE) SHARED(running_omp,n_threads) - ! - !$OMP SINGLE - ! - !$ n_threads = omp_get_num_threads() - ! - !$ write (*,*) 'running_omp = ', running_omp - !$ write (*,*) - !$ write (*,*) 'parallel OpenMP with ', n_threads, 'threads' - !$ write (*,*) - !$OMP ENDSINGLE - ! - !$OMP CRITICAL - !$ write (*,*) 'thread ', omp_get_thread_num(), ' alive' - !$OMP ENDCRITICAL - ! - !$OMP BARRIER - ! - !$OMP ENDPARALLEL - - if (first_entry) then - nullify(iraster) ; first_entry = .false. - endif - - ! define orgC content thresholds for orgC classes 1-4 (low, medium, high, peat) - - cF_lim(1) = 0. - cF_lim(2) = 0.4 ! 0.365 ! 0.3 - cF_lim(3) = 0.64 ! 0.585 ! 4.0 - cF_lim(4) = 15./1.72 ! 15./1.72=8.72 ! 9.885 ! 8.5 - cF_lim(5) = 100.0 - - ! define number of mineral classes in each orgC class - - nsoil_pcarbon(1) = 84 ! 84 - nsoil_pcarbon(2) = nsoil_pcarbon(1) + 84 ! 84 - nsoil_pcarbon(3) = nsoil_pcarbon(2) + 84 ! 57 - - ! Read number of catchment-tiles (maxcat) from catchment.def file - - fname='clsm/catchment.def' - - open (10,file=fname,status='old',action='read',form='formatted') - read(10,*) maxcat - - close (10,status='keep') - - ! Read tile-id raster file - - allocate(tile_id(1:nx,1:ny)) - - fname=trim(fnameRst)//'.rst' - - open (10,file=fname,status='old',action='read', & - form='unformatted',convert='little_endian') - - do j=1,ny - read(10)tile_id(:,j) - end do - - close (10,status='keep') - - ! read soil depth data from GSWP2_soildepth_H[xx]V[yy].nc - ! - ! get info common to all H[xx]V[yy] rectangles: - - call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) - fname =trim(MAKE_BCS_INPUT_DIR)//'/land/soil/SOIL-DATA/soil_depth/v2/GSWP2_soildepth_H11V13.nc' - status = NF_OPEN(trim(fname),NF_NOWRITE, ncid); VERIFY_(STATUS) - !status = NF_GET_att_INT(ncid,NF_GLOBAL,'i_ind_offset_LL',iLL); VERIFY_(STATUS) ! cannot be needed here - !status = NF_GET_att_INT(ncid,NF_GLOBAL,'j_ind_offset_LL',jLL); VERIFY_(STATUS) ! cannot be needed here - status = NF_GET_att_INT(ncid,NF_GLOBAL,'N_lon_global',i_highd); VERIFY_(STATUS) - status = NF_GET_att_INT(ncid,NF_GLOBAL,'N_lat_global',j_highd); VERIFY_(STATUS) - status = NF_INQ_DIM (ncid,1,string, nc_10); VERIFY_(STATUS) - status = NF_INQ_DIM (ncid,2,string, nr_10); VERIFY_(STATUS) - status = NF_CLOSE(ncid); VERIFY_(STATUS) - - ! GSWP2_soildepth_H[xx]V[yy].nc as of 29 Apr 2022: - ! - ! Associated 43200-by-21600 global grid (1/120=0.083333 deg lat/lon): - ! - ! N_lon_global = i_highd = 43200 - ! N_lat_global = j_highd = 21600 - ! - ! i_ind_offset_LL = iLL = 42001 - ! j_ind_offset_LL = jLL = 19201 - ! - ! Each file contains data for one rectangle of size 1200-by-1200, which is - ! assumed to be the same for each H[xx]V[yy] rectangle - ! - ! N_lon = nc_10 = 1200 - ! N_lat = nr_10 = 1200 - - allocate(soil_high(1:i_highd,1:j_highd)) - allocate(net_data1 (1:nc_10,1:nr_10)) - - soil_high = -9999 - do jx = 1,18 - do ix = 1,36 - write (vv,'(i2.2)')jx - write (hh,'(i2.2)')ix - fname = trim(MAKE_BCS_INPUT_DIR)//'/land/soil/SOIL-DATA/soil_depth/v2/GSWP2_soildepth_H'//hh//'V'//vv//'.nc' - status = NF_OPEN(trim(fname),NF_NOWRITE, ncid) - if(status == 0) then - status = NF_GET_att_INT (ncid,NF_GLOBAL,'i_ind_offset_LL',iLL); VERIFY_(STATUS) - status = NF_GET_att_INT (ncid,NF_GLOBAL,'j_ind_offset_LL',jLL); VERIFY_(STATUS) - status = NF_GET_att_INT (ncid,4,'UNDEF',d_undef); VERIFY_(STATUS) - status = NF_GET_att_REAL (ncid,4,'ScaleFactor',sf); VERIFY_(STATUS) - status = NF_GET_VARA_INT (ncid, 4,(/1,1/),(/nc_10,nr_10/),net_data1); VERIFY_(STATUS) + ! PEATMAP: tile has *top* layer peat class only if more than 50% of the contributing + ! raster grid cells are peat (may loose some peat tiles w.r.t. non-PEATMAP bcs version) - do j = jLL,jLL + nr_10 -1 - do i = iLL, iLL + nc_10 -1 - if(net_data1(i-iLL +1 ,j - jLL +1) /= d_undef) & - soil_high(i,j) = net_data1(i-iLL +1 ,j - jLL +1) - enddo - enddo - status = NF_CLOSE(ncid) - endif - end do - end do - - deallocate (net_data1) - - ! Regridding - - ! *EASE* grid bcs use mask file GEOS5_10arcsec_mask.nc or GEOS5_10arcsec_mask_freshwater-lakes.nc, - ! and the make_bcs script assigns NX=43200, NY=21600, which are passed into the present subroutine - ! via command-line arguments of mkCatchParam.x. That is, should have regrid=.false. for *EASE* - ! grid tile space. - - nx_adj = nx - ny_adj = ny - - regrid = nx/=i_highd .or. ny/=j_highd - - if(regrid) then - if(nx > i_highd) then - allocate(raster(nx,ny),stat=STATUS); VERIFY_(STATUS) - call RegridRaster2(soil_high,raster) - iRaster => tile_id - if(ny < j_highd) then - print *,'nx > i_highd and ny < j_highd' - stop - endif - else - if( .not.associated(iraster) ) then - allocate(iraster(i_highd,j_highd),stat=STATUS); VERIFY_(STATUS) - endif - call RegridRaster(tile_id,iraster) - raster => soil_high - nx_adj = i_highd - ny_adj = j_highd - - if(ny > j_highd) then - print *,'nx < i_highd and ny > j_highd' - stop - endif - endif - else - raster => soil_high - iRaster => tile_id - end if - - ! Interpolate/aggregate soil depth from raster grid to catchment-tiles - - allocate(soildepth(1:maxcat)) - allocate(count_soil(1:maxcat)) - - soildepth = 0. ! 1-d tile space - count_soil = 0. ! 1-d tile space - - do j=1,ny_adj - do i=1,nx_adj - if((iRaster(i,j).gt.0).and.(iRaster(i,j).le.maxcat)) then - if ((raster(i,j).gt.0)) then - soildepth(iRaster(i,j)) = & - soildepth(iRaster(i,j)) + sf*raster(i,j) ! integer "raster" --> real "soildepth" - count_soil(iRaster(i,j)) = & - count_soil(iRaster(i,j)) + 1. - endif - endif - end do - end do - - DO n =1,maxcat - if(count_soil(n)/=0.) soildepth(n)=soildepth(n)/count_soil(n) - soildepth(n) = max(soildepth(n),SOILDEPTH_MIN_HWSD) -! soildepth(n) = soildepth(n) + 2000. -! soildepth(n) = min(soildepth(n),8000.) - END DO + if (cFamily(4)/real(i) > PEATMAP_THRESHOLD_2) then + o_cl = 4 + else + if (sum(cFamily(1:3)) > 0.) o_cl = maxloc(cFamily(1:3), dim = 1) ! o_cl = 1, 2, or 3 + endif - deallocate (SOIL_HIGH) - !deallocate (count_soil) ! do not deallocate, needed again shortly - NULLIFY(Raster) - - ! --------------------------------------------------------------------------------- - ! - ! Read NGDC-HWSD-STATSGO merged soil texture from SoilProperties_H[xx]V[yy].nc' - ! - ! get info common to all H[xx]V[yy] rectangles (could in theory differ from that - ! of soildepth data read above but is the same as of 29 Apr 2022). - - if (trim(SOILBCS)=='HWSD_b') then - tmpversion = 'v3' - else if (trim(SOILBCS)=='HWSD') then - tmpversion = 'v2' - else - print *, 'Unknown SOILBCS: ', SOILBCS - stop - end if - - fname =trim(MAKE_BCS_INPUT_DIR)//'/land/soil/SOIL-DATA/soil_properties/' // tmpversion // '/SoilProperties_H11V13.nc' - status = NF_OPEN(trim(fname),NF_NOWRITE, ncid); VERIFY_(STATUS) - !status = NF_GET_att_INT(ncid,NF_GLOBAL,'i_ind_offset_LL',iLL); VERIFY_(STATUS) ! cannot be needed here - !status = NF_GET_att_INT(ncid,NF_GLOBAL,'j_ind_offset_LL',jLL); VERIFY_(STATUS) ! cannot be needed here - status = NF_GET_att_INT(ncid,NF_GLOBAL,'N_lon_global',i_highd); VERIFY_(STATUS) - status = NF_GET_att_INT(ncid,NF_GLOBAL,'N_lat_global',j_highd); VERIFY_(STATUS) - status = NF_INQ_DIM (ncid,1,string, nc_10); VERIFY_(STATUS) - status = NF_INQ_DIM (ncid,2,string, nr_10); VERIFY_(STATUS) - status = NF_CLOSE(ncid) - - ! SoilProperties_H[xx]V[yy].nc as of 29 Apr 2022: - ! - ! Associated 43200-by-21600 global grid (1/120=0.083333 deg lat/lon): - ! - ! N_lon_global = i_highd = 43200 - ! N_lat_global = j_highd = 21600 - ! - ! i_ind_offset_LL = iLL = 42001 - ! j_ind_offset_LL = jLL = 19201 - ! - ! Each file contains soil texture data for one rectangle of size 1200-by-1200, which is - ! assumed to be the same for each H[xx]V[yy] rectangle - ! - ! N_lon = nc_10 = 1200 - ! N_lat = nr_10 = 1200 - - !regrid = nx/=i_highd .or. ny/=j_highd ! not needed here, done below - - allocate(net_data1 (1:nc_10,1:nr_10)) - allocate(net_data2 (1:nc_10,1:nr_10)) - allocate(net_data3 (1:nc_10,1:nr_10)) - allocate(net_data4 (1:nc_10,1:nr_10)) - allocate(net_data5 (1:nc_10,1:nr_10)) - allocate(net_data6 (1:nc_10,1:nr_10)) - allocate(net_data7 (1:nc_10,1:nr_10)) - - allocate(sand_top (1:i_highd,1:j_highd)) - allocate(clay_top (1:i_highd,1:j_highd)) - allocate(oc_top (1:i_highd,1:j_highd)) - allocate(sand_sub (1:i_highd,1:j_highd)) - allocate(clay_sub (1:i_highd,1:j_highd)) - allocate(oc_sub (1:i_highd,1:j_highd)) - allocate(grav_grid(1:i_highd,1:j_highd)) - - sand_top = -9999 ! integer*2 - clay_top = -9999 ! integer*2 - oc_top = -9999 ! integer*2 - sand_sub = -9999 ! integer*2 - clay_sub = -9999 ! integer*2 - oc_sub = -9999 ! integer*2 - grav_grid= -9999 ! integer*2 - - do jx = 1,18 - do ix = 1,36 - write (vv,'(i2.2)')jx - write (hh,'(i2.2)')ix - fname = trim(MAKE_BCS_INPUT_DIR)//'/land/soil/SOIL-DATA/soil_properties/' // tmpversion // '/SoilProperties_H'//hh//'V'//vv//'.nc' - status = NF_OPEN(trim(fname),NF_NOWRITE, ncid) - if(status == 0) then - status = NF_GET_att_INT (ncid, NF_GLOBAL,'i_ind_offset_LL',iLL); VERIFY_(STATUS) - status = NF_GET_att_INT (ncid, NF_GLOBAL,'j_ind_offset_LL',jLL); VERIFY_(STATUS) - ! assume UNDEF and ScaleFactor (sf) are the same for *all* variables read below - ! (ok for SoilProperties_H[xx]V[yy].nc as of 29 Apr 2022). - status = NF_GET_att_INT (ncid, 4,'UNDEF',d_undef); VERIFY_(STATUS) - status = NF_GET_att_REAL (ncid, 4,'ScaleFactor',sf); VERIFY_(STATUS) - status = NF_GET_VARA_INT (ncid, 4,(/1,1/),(/nc_10,nr_10/),net_data1); VERIFY_(STATUS) - status = NF_GET_VARA_INT (ncid, 5,(/1,1/),(/nc_10,nr_10/),net_data2); VERIFY_(STATUS) - status = NF_GET_VARA_INT (ncid, 6,(/1,1/),(/nc_10,nr_10/),net_data3); VERIFY_(STATUS) - status = NF_GET_VARA_INT (ncid, 7,(/1,1/),(/nc_10,nr_10/),net_data4); VERIFY_(STATUS) - status = NF_GET_VARA_INT (ncid, 8,(/1,1/),(/nc_10,nr_10/),net_data5); VERIFY_(STATUS) - status = NF_GET_VARA_INT (ncid, 9,(/1,1/),(/nc_10,nr_10/),net_data6); VERIFY_(STATUS) - status = NF_GET_VARA_INT (ncid,10,(/1,1/),(/nc_10,nr_10/),net_data7); VERIFY_(STATUS) - do j = jLL,jLL + nr_10 -1 - do i = iLL, iLL + nc_10 -1 - if(net_data1(i-iLL +1 ,j - jLL +1) /= d_undef) & - clay_top(i,j) = net_data1(i-iLL +1 ,j - jLL +1) - if(net_data2(i-iLL +1 ,j - jLL +1) /= d_undef) & - sand_top(i,j) = net_data2(i-iLL +1 ,j - jLL +1) - if(net_data3(i-iLL +1 ,j - jLL +1) /= d_undef) & - oc_top (i,j) = net_data3(i-iLL +1 ,j - jLL +1) - if(net_data4(i-iLL +1 ,j - jLL +1) /= d_undef) & - clay_sub(i,j) = net_data4(i-iLL +1 ,j - jLL +1) - if(net_data5(i-iLL +1 ,j - jLL +1) /= d_undef) & - sand_sub(i,j) = net_data5(i-iLL +1 ,j - jLL +1) - if(net_data6(i-iLL +1 ,j - jLL +1) /= d_undef) & - oc_sub (i,j) = net_data6(i-iLL +1 ,j - jLL +1) - if(net_data7(i-iLL +1 ,j - jLL +1) /= d_undef) & - grav_grid(i,j) = net_data7(i-iLL +1 ,j - jLL +1) - enddo - enddo - status = NF_CLOSE(ncid) - endif - end do - end do + endif - deallocate (net_data1) - deallocate (net_data2) - deallocate (net_data3) - deallocate (net_data4) - deallocate (net_data5) - deallocate (net_data6) - deallocate (net_data7) - - ! ---------------------------------------------------------------------------- - if(use_PEATMAP) then - print *, 'PEATMAP_THRESHOLD_1 : ', PEATMAP_THRESHOLD_1 - allocate(pmapr (1:i_highd,1:j_highd)) - status = NF_OPEN (trim(MAKE_BCS_INPUT_DIR)//'/land/soil/SOIL-DATA/PEATMAP_mask.nc4', NF_NOWRITE, ncid) - status = NF_GET_VARA_REAL (ncid,NC_VarID(NCID,'PEATMAP'), (/1,1/),(/i_highd, j_highd/), pmapr) ; VERIFY_(STATUS) + ! determine aggregate/dominant orgC *profile* (0-100) soil class ("o_clp") of tile n, + ! weight factor=1. for top (0-30) layer and weight factor=2.33 for sub (30-100) layer - ! move HWSD sub-surface peat to peat-rich mineral Group 3 because merged surface peat defines sub-surface peat + cFamily = 0. - where (oc_sub*sf >= cF_lim(4)) - oc_sub = NINT(8./sf) - endwhere + do j=1,2*i + if(j <= i) factor = 1. + if(j > i) factor = 2.33 + if((ss_oc_all(j)*sf >= cF_lim(1)).and. (ss_oc_all(j)*sf < cF_lim(2))) cFamily(1) = cFamily(1) + factor + if((ss_oc_all(j)*sf >= cF_lim(2)).and. (ss_oc_all(j)*sf < cF_lim(3))) cFamily(2) = cFamily(2) + factor + if((ss_oc_all(j)*sf >= cF_lim(3)).and. (ss_oc_all(j)*sf < cF_lim(4))) cFamily(3) = cFamily(3) + factor + if((ss_oc_all(j)*sf >= cF_lim(4) )) cFamily(4) = cFamily(4) + factor + end do - ! Hybridize: add OC 1km PEATMAP pixels to HWSD oc_top + ! NOTE: For PEATMAP, oc_sub was cut back to 8./sf above: + ! "! move HWSD sub-surface peat to peat-rich mineral Group 3 because merged surface peat defines sub-surface peat" + ! "where (oc_sub*sf >= cF_lim(4)) " + ! " oc_sub = NINT(8./sf) " + ! "endwhere " + ! For PEATMAP, the sub-layer weight of 2.33 should only count towards cFamily(1:3), and in most cases the + ! maxloc statement below should therefore result in o_clp = 1, 2, or 3 only. However, if the top-layer orgC + ! is peat for most contributing raster grid cells and the sub-layer orgC values are relatively evenly spread + ! over orgC classes 1, 2, and 3, then maxloc(cFamily) can result in o_clp=4. + + if (sum(cFamily) == 0.) o_clp = 1 + if (sum(cFamily) > 0.) o_clp = maxloc(cFamily, dim = 1) + + ! ---------------------------------------------------------------------------------------- + ! + ! Determine *top* layer mineral/organic soil class of tile n + + if(o_cl == 4) then + + ! Top-layer soil class of tile n is peat. + ! Compute average top-layer orgC (only across raster grid cells whose top layer is peat). + + soil_class_top(n) = n_SoilClasses + ktop = 0 + do j=1,i + ! avg only across contributing raster grid cells that are peat + if(ss_oc_all(j)*sf >= cF_lim(4)) then + soc_vec (n) = soc_vec(n) + ss_oc_all(j)*sf + ktop = ktop + 1 + endif + end do + if(ktop.ne.0) soc_vec (n) = soc_vec(n)/ktop + !ncells_top(n) = 100.*float(ktop)/float(i) ! ncells_* not used - where (pmapr >= PEATMAP_THRESHOLD_1) - oc_top = NINT(33.0/sf) - endwhere + else - deallocate (pmapr) - status = NF_CLOSE(ncid) - endif - - ! ---------------------------------------------------------------------------- - - ! Regridding - - ! *EASE* grid bcs use mask file GEOS5_10arcsec_mask.nc or GEOS5_10arcsec_mask_freshwater-lakes.nc, - ! and the make_bcs script assigns NX=43200, NY=21600, which are passed into the present subroutine - ! via command-line arguments of mkCatchParam.x. That is, should have regrid=.false. for *EASE* - ! grid tile space. - - nx_adj = nx - ny_adj = ny - - regrid = nx/=i_highd .or. ny/=j_highd - - if(regrid) then - if(nx > i_highd) then - allocate(raster1(nx,ny),stat=STATUS); VERIFY_(STATUS) - call RegridRaster2(clay_top,raster1) - - allocate(raster2(nx,ny),stat=STATUS); VERIFY_(STATUS) - call RegridRaster2(sand_top,raster2) - - allocate(raster3(nx,ny),stat=STATUS); VERIFY_(STATUS) - call RegridRaster2(oc_top, raster3) - - allocate(raster4(nx,ny),stat=STATUS); VERIFY_(STATUS) - call RegridRaster2(clay_sub,raster4) - - allocate(raster5(nx,ny),stat=STATUS); VERIFY_(STATUS) - call RegridRaster2(sand_sub,raster5) - - allocate(raster6(nx,ny),stat=STATUS); VERIFY_(STATUS) - call RegridRaster2(oc_sub, raster6) - - allocate(raster (nx,ny),stat=STATUS); VERIFY_(STATUS) - call RegridRaster2(grav_grid,raster) - - iRaster => tile_id - - if(ny < j_highd) then - print *,'nx > i_highd and ny < j_highd' - stop - endif - else - nx_adj = i_highd - ny_adj = j_highd - if( .not.associated(iraster) ) then - allocate(iRaster(i_highd,j_highd),stat=STATUS); VERIFY_(STATUS) - endif - call RegridRaster(tile_id,iRaster) - - raster1 => clay_top - raster2 => sand_top - raster3 => oc_top - raster4 => clay_sub - raster5 => sand_sub - raster6 => oc_sub - raster => grav_grid - - if(ny > j_highd) then - print *,'nx < i_highd and ny > j_highd' - stop - endif - endif - else - iRaster => tile_id - raster1 => clay_top - raster2 => sand_top - raster3 => oc_top - raster4 => clay_sub - raster5 => sand_sub - raster6 => oc_sub - raster => grav_grid - end if - - ! ---------------------------------------------------------------------------- - - ! compute peat fraction on tile for CLM45+ (for fires?) - - allocate(pmap (1:maxcat)) - !allocate(count_soil(1:maxcat)) ! already allocated above - - pmap = 0. ! 1-d tile space; peat fraction in tile based on oc_top - count_soil = 0. ! 1-d tile space - - do j=1,ny_adj - do i=1,nx_adj - if((iRaster(i,j).gt.0).and.(iRaster(i,j).le.maxcat)) then - count_soil(iRaster(i,j)) = count_soil(iRaster(i,j)) + 1. - if (raster3(i,j)*sf >= cF_lim(4)) then - pmap (iRaster(i,j)) = pmap(iRaster(i,j)) + 1 - endif - endif - end do - end do - - where (count_soil > 0) pmap = pmap /count_soil - - !deallocate (count_soil) ! do not deallocate, needed again shortly - - ! ---------------------------------------------------------------------------- - - ! get number of "land" pixels (i1) on raster grid - - allocate(land_pixels(1:size(iRaster,1),1:size(iRaster,2))) - land_pixels = (iRaster >=1).and.(iRaster<=maxcat) - i1 = count(land_pixels) - deallocate (land_pixels) - - ! allocate 1-d arrays for all "land" pixels on raster grid - - allocate (tileid_vec(1:i1)) - allocate (data_vec1 (1:i1)) - allocate (data_vec2 (1:i1)) - allocate (data_vec3 (1:i1)) - allocate (data_vec4 (1:i1)) - allocate (data_vec5 (1:i1)) - allocate (data_vec6 (1:i1)) - - ! allocate 1-d arrays for all "land" tiles - - allocate (grav_vec (1:maxcat)) - allocate (soc_vec (1:maxcat)) - allocate (poc_vec (1:maxcat)) - !allocate (ncells_top (1:maxcat)) ! ncells_* not used - !allocate (ncells_top_pro (1:maxcat)) ! ncells_* not used - !allocate (ncells_sub_pro (1:maxcat)) ! ncells_* not used - !allocate(count_soil(1:maxcat)) - - count_soil = 0. - grav_vec = 0. - soc_vec = 0. ! soil orgC (top layer 0-30) - poc_vec = 0. ! soil orgC (profile layer 0-100) - - !ncells_top = 0. ! ncells_* not used - !ncells_top_pro = 0. ! ncells_* not used - !ncells_sub_pro = 0. ! ncells_* not used - - n =1 - do j=1,ny_adj - do i=1,nx_adj - if((iRaster(i,j).ge.1).and.(iRaster(i,j).le.maxcat)) then - - ! map from 2-d raster array to 1-d raster vec - - tileid_vec (n) = iRaster(i,j) ! iRaster => tile_id int*4 - data_vec1 (n) = Raster1(i,j) ! raster1 => clay_top int*2 - data_vec2 (n) = Raster2(i,j) ! raster2 => sand_top int*2 - data_vec3 (n) = Raster3(i,j) ! raster3 => oc_top int*2 - data_vec4 (n) = Raster4(i,j) ! raster4 => clay_sub int*2 - data_vec5 (n) = Raster5(i,j) ! raster5 => sand_sub int*2 - data_vec6 (n) = Raster6(i,j) ! raster6 => oc_sub int*2 - - ! BUG??? It is unclear why here grav_vec is filled in the order of "tile_id" - ! while data_vec[x] is filled in the order of the long/lat grid. - ! Not sure if grav_vec is processed correctly below! - ! -reichle, 29 Apr 2022 - - if ((raster(i,j).gt.0)) then - grav_vec(iRaster(i,j)) = & - grav_vec(iRaster(i,j)) + sf*raster(i,j) ! raster => grav_grid int*2 - count_soil(iRaster(i,j)) = & - count_soil(iRaster(i,j)) + 1. - endif - n = n + 1 - endif - end do - end do - - DO n =1,maxcat - if(count_soil(n)/=0.) grav_vec(n)=grav_vec(n)/count_soil(n) - END DO - - deallocate (count_soil) - NULLIFY(Raster,Raster1,Raster2,Raster3,Raster4,Raster5,Raster6) - deallocate (clay_top,sand_top,oc_top,clay_sub,sand_sub,oc_sub,grav_grid) - deallocate (tile_id) - - ! sort 1-d land pixels vectors according to tile_id - - allocate (arrayA (1:i1)) ! 1-d land pixels on raster grid - allocate (arrayB (1:i1)) ! 1-d land pixels on raster grid - - arrayA = tileid_vec - arrayB = data_vec1 - call MAPL_Sort (arrayA, arrayB) - data_vec1 = arrayB - - arrayA = tileid_vec - arrayB = data_vec2 - call MAPL_Sort (arrayA, arrayB) - data_vec2 = arrayB - - arrayA = tileid_vec - arrayB = data_vec3 - call MAPL_Sort (arrayA, arrayB) - data_vec3 = arrayB - - arrayA = tileid_vec - arrayB = data_vec4 - call MAPL_Sort (arrayA, arrayB) - data_vec4 = arrayB - - arrayA = tileid_vec - arrayB = data_vec5 - call MAPL_Sort (arrayA, arrayB) - data_vec5 = arrayB - - arrayA = tileid_vec - arrayB = data_vec6 - call MAPL_Sort (arrayA, arrayB) - data_vec6 = arrayB - - tileid_vec= arrayA - - deallocate (arrayA, arrayB) - - ! -------------------------------------------------------------------- - ! - ! Read Woesten soil parameters and CLSM tau parameters for soil classes (1:253) - - allocate(a_sand (1:n_SoilClasses)) - allocate(a_clay (1:n_SoilClasses)) - allocate(a_silt (1:n_SoilClasses)) - allocate(a_oc (1:n_SoilClasses)) - allocate(a_bee (1:n_SoilClasses)) - allocate(a_psis (1:n_SoilClasses)) - allocate(a_poros (1:n_SoilClasses)) - allocate(a_wp (1:n_SoilClasses)) - allocate(a_aksat (1:n_SoilClasses)) - allocate(atau (1:n_SoilClasses)) - allocate(btau (1:n_SoilClasses)) - allocate(atau_2cm(1:n_SoilClasses)) - allocate(btau_2cm(1:n_SoilClasses)) - allocate(a_wpsurf(1:n_SoilClasses)) - allocate(a_porosurf(1:n_SoilClasses)) - - ! SoilClasses-SoilHyd-TauParam.dat and SoilClasses-SoilHyd-TauParam.peatmap differ - ! only in the parameters for the peat class #253. The file *.peatmap contains - ! the PEATCLSM parameters from Table 2 of Bechtold et al. 2019 (doi:10.1029/2018MS001574). - ! - ! Note: K_s = COND*exp(-zks*gnu) ==> with zks=2 and gnu=1, K_s = 0.135335*COND - ! - ! K_s COND [m/s] - ! NLv4 7.86e-7 5.81e-6 - ! NLv5 3.79e-6 2.80e-5 <== note *typo* in Table 2 of Bechtold et al. 2019, which erroneously lists K_s=2.8e-5 - - if(use_PEATMAP) then - fname = trim(MAKE_BCS_INPUT_DIR)//'/land/soil/SOIL-DATA/SoilClasses-SoilHyd-TauParam.peatmap' - else - fname = trim(MAKE_BCS_INPUT_DIR)//'/land/soil/SOIL-DATA/SoilClasses-SoilHyd-TauParam.dat' - endif + ! Top-layer soil class of tile n is mineral. + ! Compute average top-layer orgC (only across raster grid cells within same orgC class) + ! and collect all clay/sand pairs of raster grid cells within same orgC class. + + !k = 1 !cleanup k counter + !ktop = 1 !cleanup k counter + ktop = 0 !cleanup k counter - table_map = 0 ! 100-by-3 look-up table + do j=1,i ! loop only through top-layer elements of ss_*_all - open (11, file=trim(fname), form='formatted',status='old', & - action = 'read') - read (11,'(a)')fout ! read header line + ! avg only across contributing raster grid cells with orgC class as that assigned to tile n + if((ss_oc_all(j)*sf >= cF_lim(o_cl)).and.(ss_oc_all(j)*sf < cF_lim(o_cl + 1))) then + + if((ss_clay_all(j)*sf >= 0.).and.(ss_sand_all(j)*sf >= 0.)) then ! avoiding no-data-values - do n =1,n_SoilClasses + ktop = ktop + 1 !cleanup k counter + ss_clay (ktop) = ss_clay_all(j) + ss_sand (ktop) = ss_sand_all(j) - read (11,'(4f7.3,4f8.4,e13.5,2f12.7,2f8.4,4f12.7)')a_sand(n),a_clay(n),a_silt(n),a_oc(n),a_bee(n),a_psis(n), & - a_poros(n),a_wp(n),a_aksat(n),atau(n),btau(n),a_wpsurf(n),a_porosurf(n),atau_2cm(n),btau_2cm(n) + ! adjust clay and sand content if outside joint physical bounds + if((ss_clay (ktop) + ss_sand (ktop)) > 9999) then ! note: 9999 = 99.99% (scale factor = 0.01) + if(ss_clay (ktop) >= ss_sand (ktop)) then + ss_sand (ktop) = 10000 - ss_clay (ktop) + else + ss_clay (ktop) = 10000 - ss_sand (ktop) + endif + endif + soc_vec (n) = soc_vec(n) + ss_oc_all(j)*sf ! sum up top-layer orgC + !k = k + 1 !cleanup k counter + !ktop = ktop + 1 !cleanup k counter + endif + endif + end do - ! assemble scalar structure that holds mineral percentages of soil class n + !k = k - 1 !cleanup k counter + !ktop = ktop -1 !cleanup k counter - min_percs%clay_perc = a_clay(n) - min_percs%silt_perc = a_silt(n) - min_percs%sand_perc = a_sand(n) - - ! "soil_class" is an integer function (see rmTinyCatchParam.F90) that assigns - ! an integer (mineral) soil class [1-100] for a given mineral percentage triplet - - ! "table_map" is a 2-d array (100-by-3) that maps between overall soil class (1:252) and - ! (mineral_class 1:84, orgC_class). "table_map" has no entry for the peat class #253. - - if( n <= nsoil_pcarbon(1)) table_map(soil_class (min_percs),1) = n - if((n > nsoil_pcarbon(1)).and.(n <= nsoil_pcarbon(2))) table_map(soil_class (min_percs),2) = n - if((n > nsoil_pcarbon(2)).and.(n <= nsoil_pcarbon(3))) table_map(soil_class (min_percs),3) = n - - end do ! n=1,n_SoilClasses - - close (11,status='keep') - - ! ------------------------------------------------------------ - ! - ! When Woesten soil parameters are not available for a particular soil class, - ! as defined by "tiny" triangles in HWSD soil triangle, Woesten soil - ! parameters from the nearest available "tiny" triangle will be substituted. - ! For "tiny" triangles, see Fig 1b of De Lannoy et al. 2014 (doi:10.1002/2014MS000330). - - do n =1,10 - do k=1,n*2 -1 - - min_percs%clay_perc = 100. -((n-1)*10 + 5) - min_percs%sand_perc = 100. - min_percs%clay_perc -2.-(k-1)*5. - min_percs%silt_perc = 100. - min_percs%clay_perc - min_percs%sand_perc - - i = soil_class (min_percs) - - if(table_map (i,1)== 0) then - j = center_pix (a_clay(1:nsoil_pcarbon(1)),a_sand(1:nsoil_pcarbon(1)), & - min_percs%clay_perc,min_percs%sand_perc,min_percs%silt_perc,.true.) - - min_percs%clay_perc = a_clay(j) - min_percs%silt_perc = a_silt(j) - min_percs%sand_perc = a_sand(j) - table_map (i,1)= table_map (soil_class (min_percs),1) - endif - - min_percs%clay_perc = 100. -((n-1)*10 + 5) - min_percs%sand_perc = 100. - min_percs%clay_perc -2.-(k-1)*5. - min_percs%silt_perc = 100. - min_percs%clay_perc - min_percs%sand_perc - - if(table_map (i,2)== 0) then - j = center_pix(a_clay(nsoil_pcarbon(1)+1 : nsoil_pcarbon(2)), & - a_sand(nsoil_pcarbon(1)+1 : nsoil_pcarbon(2)), & - min_percs%clay_perc,min_percs%sand_perc,min_percs%silt_perc,.true.) - min_percs%clay_perc = a_clay(j + nsoil_pcarbon(1)) - min_percs%silt_perc = a_silt(j + nsoil_pcarbon(1)) - min_percs%sand_perc = a_sand(j + nsoil_pcarbon(1)) - table_map (i,2)= table_map (soil_class (min_percs),2) - endif - - min_percs%clay_perc = 100. -((n-1)*10 + 5) - min_percs%sand_perc = 100. - min_percs%clay_perc -2.-(k-1)*5. - min_percs%silt_perc = 100. - min_percs%clay_perc - min_percs%sand_perc - - if(table_map (i,3)== 0) then - j = center_pix (a_clay(nsoil_pcarbon(2)+1 : nsoil_pcarbon(3)), & - a_sand(nsoil_pcarbon(2)+1 : nsoil_pcarbon(3)), & - min_percs%clay_perc,min_percs%sand_perc,min_percs%silt_perc,.true.) - min_percs%clay_perc = a_clay(j + nsoil_pcarbon(2)) - min_percs%silt_perc = a_silt(j + nsoil_pcarbon(2)) - min_percs%sand_perc = a_sand(j + nsoil_pcarbon(2)) - table_map (i,3)= table_map (soil_class (min_percs),3) - endif - end do - end do -! -! Now deriving soil types based on NGDC-HWSD-STATSGO merged soil property maps -! - allocate (soil_class_top (1:maxcat)) - allocate (soil_class_com (1:maxcat)) - soil_class_top =-9999 - soil_class_com =-9999 - - allocate(low_ind(n_threads)) - allocate(upp_ind(n_threads)) - low_ind(1) = 1 - upp_ind(n_threads) = maxcat - - if (running_omp) then - do i=1,n_threads-1 - upp_ind(i) = low_ind(i) + (maxcat/n_threads) - 1 - low_ind(i+1) = upp_ind(i) + 1 - end do - end if - -!$OMP PARALLELDO DEFAULT(NONE) & -!$OMP SHARED( n_threads, low_ind, upp_ind, tileid_vec, & -!$OMP sf,data_vec1,data_vec2,data_vec3, & -!$OMP data_vec4,data_vec5,data_vec6,cF_lim, & -!$OMP table_map,soil_class_top,soil_class_com, & -!$OMP soc_vec,poc_vec,use_PEATMAP) & -!ncells_* not used !$OMP soc_vec,poc_vec,ncells_top,ncells_top_pro,& -!ncells_* not used !$OMP ncells_sub_pro,use_PEATMAP) & -!$OMP PRIVATE(n,i,j,k,icount,t_count,i1,i2,ss_clay, & -!$OMP ss_sand,ss_clay_all,ss_sand_all, & -!$OMP ss_oc_all,cFamily,factor,o_cl,o_clp,ktop, & -!$OMP min_percs, fac_count, write_debug) + if(ktop.ne.0) soc_vec (n) = soc_vec(n)/ktop ! normalize top-layer orgC - ! loop through tiles (split into two loops for OpenMP) + !ncells_top(n) = 100.*float(ktop)/float(i) ! ncells_* not used - DO t_count = 1,n_threads - DO n = low_ind(t_count),upp_ind(t_count) + ! debugging output + if (write_debug) write(80+n,*)ktop,o_cl + if(ktop > 0 .and. write_debug) then + write (80+n,*)ss_clay(1:ktop) + write (80+n,*)ss_sand(1:ktop) + endif - write_debug = .false. + ! Determine the raster grid cell j that has (top-layer) clay/sand content closest + ! to the average (top-layer) clay/sand across all raster grid cells within the + ! dominant orgC class. -! if (n==171010) write_debug = .true. + j = center_pix_int0(sf, ktop,ktop, ss_clay(1:ktop),ss_sand(1:ktop)) - ! initialize "icount" when starting loop through n at low_ind(t_count) - ! recall: tileid_vec is a 1-d vector that covers all land pixels on the raster grid that - ! contains the (sorted) tile IDs, with matching parameter vectors data_vec[x] + ! Assign soil class of raster grid cell j to tile n - if(n==low_ind(t_count)) then - icount = 1 - ! Not sure what the following loops do. Why not check backwards from low_ind(t_count)?? - do k=1,low_ind(t_count) - 1 - do while (tileid_vec(icount)== k) - icount = icount + 1 - end do - end do - endif - - ! ------------------------------------------------------------------ - ! - ! determine the land raster grid cells i1:i2 that make up tile n - - ! NOTE change in meaning of "i1": - ! - ! before: i1 = total no. of land pixels on the raster grid - ! now: i1 = starting index of land raster grid cells (within 1-d vector) that make up tile n (?) - - i1 = icount - - loop: do while (tileid_vec(icount)== n) - if(icount <= size(tileid_vec,1)) icount = icount + 1 - if(icount > size(tileid_vec,1)) exit loop - end do loop - - i2 = icount -1 - i = i2 - i1 + 1 ! number of land raster grid cells that make up tile n (?) - - - ! ------------------------------------------------------------------- - ! - ! prep data - - allocate(ss_clay (1:2*i)) ! for top layer (0-30) -- why allocate 1:2*i and not 1:i?? - allocate(ss_sand (1:2*i)) ! for top layer (0-30) -- why allocate 1:2*i and not 1:i?? - - allocate(ss_clay_all(1:2*i)) ! for top (0-30) and sub (30-100) layers - allocate(ss_sand_all(1:2*i)) ! for top (0-30) and sub (30-100) layers - allocate(ss_oc_all (1:2*i)) ! for top (0-30) and sub (30-100) layers - - ss_clay = 0 ! int*2 -- why only clay and sand for top layer and not orgC ?? - ss_sand = 0 ! int*2 - - ss_clay_all= 0 ! int*2 - ss_sand_all= 0 ! int*2 - ss_oc_all = 0 ! int*2 - - ss_clay_all (1:i) = data_vec1(i1:i2) ! put top layer info into first i elements (1:i) - ss_sand_all (1:i) = data_vec2(i1:i2) - ss_oc_all (1:i) = data_vec3(i1:i2) - - ss_clay_all (1+i:2*i) = data_vec4(i1:i2) ! put sub layer info into next i elements (i+1:2*i) - ss_sand_all (1+i:2*i) = data_vec5(i1:i2) - ss_oc_all (1+i:2*i) = data_vec6(i1:i2) ! <-- oc_sub - - - ! ----------------------------------------------------------------------- - ! - ! determine aggregate/dominant orgC *top* layer soil class ("o_cl") of tile n - - cFamily = 0. -!! factor = 1. - - do j=1,i - if(j <= i) factor = 1. - if((ss_oc_all(j)*sf >= cF_lim(1)).and. (ss_oc_all(j)*sf < cF_lim(2))) cFamily(1) = cFamily(1) + factor - if((ss_oc_all(j)*sf >= cF_lim(2)).and. (ss_oc_all(j)*sf < cF_lim(3))) cFamily(2) = cFamily(2) + factor - if((ss_oc_all(j)*sf >= cF_lim(3)).and. (ss_oc_all(j)*sf < cF_lim(4))) cFamily(3) = cFamily(3) + factor - if((ss_oc_all(j)*sf >= cF_lim(4) )) cFamily(4) = cFamily(4) + factor - end do - - if (sum(cFamily) == 0.) o_cl = 1 ! default is o_cl=1 (if somehow no grid cell has top-layer orgC >=0.) - -!! if (.not. use_PEATMAP) then - - ! assign dominant *top* layer org soil class (even if only a minority of the contributing - ! raster grid cells is peat) - - if (sum(cFamily) > 0.) o_cl = maxloc(cFamily, dim = 1) - -!! else - - if (use_PEATMAP) then - - ! PEATMAP: tile has *top* layer peat class only if more than 50% of the contributing - ! raster grid cells are peat (may loose some peat tiles w.r.t. non-PEATMAP bcs version) - - if (cFamily(4)/real(i) > PEATMAP_THRESHOLD_2) then - o_cl = 4 - else - if (sum(cFamily(1:3)) > 0.) o_cl = maxloc(cFamily(1:3), dim = 1) ! o_cl = 1, 2, or 3 - endif - - endif - - - ! determine aggregate/dominant orgC *profile* (0-100) soil class ("o_clp") of tile n, - ! weight factor=1. for top (0-30) layer and weight factor=2.33 for sub (30-100) layer - - cFamily = 0. - - do j=1,2*i - if(j <= i) factor = 1. - if(j > i) factor = 2.33 - if((ss_oc_all(j)*sf >= cF_lim(1)).and. (ss_oc_all(j)*sf < cF_lim(2))) cFamily(1) = cFamily(1) + factor - if((ss_oc_all(j)*sf >= cF_lim(2)).and. (ss_oc_all(j)*sf < cF_lim(3))) cFamily(2) = cFamily(2) + factor - if((ss_oc_all(j)*sf >= cF_lim(3)).and. (ss_oc_all(j)*sf < cF_lim(4))) cFamily(3) = cFamily(3) + factor - if((ss_oc_all(j)*sf >= cF_lim(4) )) cFamily(4) = cFamily(4) + factor - end do - - ! NOTE: For PEATMAP, oc_sub was cut back to 8./sf above: - ! "! move HWSD sub-surface peat to peat-rich mineral Group 3 because merged surface peat defines sub-surface peat" - ! "where (oc_sub*sf >= cF_lim(4)) " - ! " oc_sub = NINT(8./sf) " - ! "endwhere " - ! For PEATMAP, the sub-layer weight of 2.33 should only count towards cFamily(1:3), and in most cases the - ! maxloc statement below should therefore result in o_clp = 1, 2, or 3 only. However, if the top-layer orgC - ! is peat for most contributing raster grid cells and the sub-layer orgC values are relatively evenly spread - ! over orgC classes 1, 2, and 3, then maxloc(cFamily) can result in o_clp=4. - - if (sum(cFamily) == 0.) o_clp = 1 - if (sum(cFamily) > 0.) o_clp = maxloc(cFamily, dim = 1) - - ! ---------------------------------------------------------------------------------------- - ! - ! Determine *top* layer mineral/organic soil class of tile n - - if(o_cl == 4) then - - ! Top-layer soil class of tile n is peat. - ! Compute average top-layer orgC (only across raster grid cells whose top layer is peat). - - soil_class_top(n) = n_SoilClasses - ktop = 0 - do j=1,i - ! avg only across contributing raster grid cells that are peat - if(ss_oc_all(j)*sf >= cF_lim(4)) then - soc_vec (n) = soc_vec(n) + ss_oc_all(j)*sf - ktop = ktop + 1 + if(j >=1) then + min_percs%clay_perc = ss_clay(j)*sf + min_percs%sand_perc = ss_sand(j)*sf + min_percs%silt_perc = 100. - ss_clay(j)*sf - ss_sand(j)*sf + soil_class_top (n) = table_map(soil_class (min_percs),o_cl) endif - end do - if(ktop.ne.0) soc_vec (n) = soc_vec(n)/ktop - !ncells_top(n) = 100.*float(ktop)/float(i) ! ncells_* not used - else - - ! Top-layer soil class of tile n is mineral. - ! Compute average top-layer orgC (only across raster grid cells within same orgC class) - ! and collect all clay/sand pairs of raster grid cells within same orgC class. + ! debugging output + if (write_debug) write(80+n,*)j - !k = 1 !cleanup k counter - !ktop = 1 !cleanup k counter - ktop = 0 !cleanup k counter + endif ! o_cl==4 - do j=1,i ! loop only through top-layer elements of ss_*_all + ! debugging output + if (write_debug) write(80+n,*)soil_class_top (n) - ! avg only across contributing raster grid cells with orgC class as that assigned to tile n - if((ss_oc_all(j)*sf >= cF_lim(o_cl)).and.(ss_oc_all(j)*sf < cF_lim(o_cl + 1))) then + ! ------------------------------------------------------------------------------- + ! + ! determine aggregate sand/clay/orgC for *profile* layer of tile n - if((ss_clay_all(j)*sf >= 0.).and.(ss_sand_all(j)*sf >= 0.)) then ! avoiding no-data-values + if(o_clp == 4) then - ktop = ktop + 1 !cleanup k counter - ss_clay (ktop) = ss_clay_all(j) - ss_sand (ktop) = ss_sand_all(j) - - ! adjust clay and sand content if outside joint physical bounds - if((ss_clay (ktop) + ss_sand (ktop)) > 9999) then ! note: 9999 = 99.99% (scale factor = 0.01) - if(ss_clay (ktop) >= ss_sand (ktop)) then - ss_sand (ktop) = 10000 - ss_clay (ktop) - else - ss_clay (ktop) = 10000 - ss_sand (ktop) - endif - endif - soc_vec (n) = soc_vec(n) + ss_oc_all(j)*sf ! sum up top-layer orgC - !k = k + 1 !cleanup k counter - !ktop = ktop + 1 !cleanup k counter - endif - endif - end do - - !k = k - 1 !cleanup k counter - !ktop = ktop -1 !cleanup k counter - - if(ktop.ne.0) soc_vec (n) = soc_vec(n)/ktop ! normalize top-layer orgC - - !ncells_top(n) = 100.*float(ktop)/float(i) ! ncells_* not used - - ! debugging output - if (write_debug) write(80+n,*)ktop,o_cl - if(ktop > 0) then - if (write_debug) write (80+n,*)ss_clay(1:ktop) - if (write_debug) write (80+n,*)ss_sand(1:ktop) - endif - - ! Determine the raster grid cell j that has (top-layer) clay/sand content closest - ! to the average (top-layer) clay/sand across all raster grid cells within the - ! dominant orgC class. - - j = center_pix_int0(sf, ktop,ktop, ss_clay(1:ktop),ss_sand(1:ktop)) - - ! Assign soil class of raster grid cell j to tile n - - if(j >=1) then - min_percs%clay_perc = ss_clay(j)*sf - min_percs%sand_perc = ss_sand(j)*sf - min_percs%silt_perc = 100. - ss_clay(j)*sf - ss_sand(j)*sf - soil_class_top (n) = table_map(soil_class (min_percs),o_cl) - endif - - ! debugging output - if (write_debug) write(80+n,*)j - - endif - - ! debugging output - if (write_debug) write(80+n,*)soil_class_top (n) - - ! ------------------------------------------------------------------------------- - ! - ! determine aggregate sand/clay/orgC for *profile* layer of tile n - - if(o_clp == 4) then - - ! Profile-layer soil class of tile n is peat. - ! Compute average profile-layer orgC (only across raster grid cells and layers that are peat) - - soil_class_com(n) = n_SoilClasses - fac_count = 0. - k =0 - ktop =0 - do j=1,2*i - if(ss_oc_all(j)*sf >= cF_lim(4)) then - if(j <= i) factor = 1. ! top layer contribution 1 <= j <=i - if(j > i) factor = 2.33 ! sub layer contribution i+1 <= j <=2*i - if(j > i) k = k + 1 ! sub layer counter - if(j <= i) ktop = ktop + 1 ! top layer counter - poc_vec (n) = poc_vec(n) + ss_oc_all(j)*sf*factor ! weighted sum of orgC - fac_count = fac_count + factor ! sum of weights - endif - end do - if(fac_count.ne.0) poc_vec (n) = poc_vec (n)/fac_count ! normalize - !ncells_sub_pro(n) = 100.*float(k)/float(i) ! ncells_* not used - !ncells_top_pro(n) = 100.*float(ktop)/float(i) ! ncells_* not used - else - - ! Profile-layer soil class of tile n is mineral. - ! Compute average profile-layer orgC (only across raster grid cells within same orgC class) - ! and collect all clay/sand pairs of raster grid cells within same orgC class. - - !k = 1 !cleanup k counter - !ktop = 1 !cleanup k counter - k = 0 !cleanup k counter - ktop = 0 !cleanup k counter - - ss_clay=0 - ss_sand=0 - fac_count = 0. - - do j=1,2*i ! loop through both top (1<=j<=i) layer and sub (i+1<=j<=2*i) layer elements - + ! Profile-layer soil class of tile n is peat. + ! Compute average profile-layer orgC (only across raster grid cells and layers that are peat) + + soil_class_com(n) = n_SoilClasses + fac_count = 0. + k =0 + ktop =0 + do j=1,2*i + if(ss_oc_all(j)*sf >= cF_lim(4)) then + if(j <= i) factor = 1. ! top layer contribution 1 <= j <=i + if(j > i) factor = 2.33 ! sub layer contribution i+1 <= j <=2*i + if(j > i) k = k + 1 ! sub layer counter + if(j <= i) ktop = ktop + 1 ! top layer counter + poc_vec (n) = poc_vec(n) + ss_oc_all(j)*sf*factor ! weighted sum of orgC + fac_count = fac_count + factor ! sum of weights + endif + end do + if(fac_count.ne.0) poc_vec (n) = poc_vec (n)/fac_count ! normalize + !ncells_sub_pro(n) = 100.*float(k)/float(i) ! ncells_* not used + !ncells_top_pro(n) = 100.*float(ktop)/float(i) ! ncells_* not used + else + + ! Profile-layer soil class of tile n is mineral. + ! Compute average profile-layer orgC (only across raster grid cells within same orgC class) + ! and collect all clay/sand pairs of raster grid cells within same orgC class. + + !k = 1 !cleanup k counter + !ktop = 1 !cleanup k counter + k = 0 !cleanup k counter + ktop = 0 !cleanup k counter + + ss_clay=0 + ss_sand=0 + fac_count = 0. + + do j=1,2*i ! loop through both top (1<=j<=i) layer and sub (i+1<=j<=2*i) layer elements ! avg only across contributing raster grid cells and layers with orgC class as that assigned to tile n - if((ss_oc_all(j)*sf >= cF_lim(o_clp)).and.(ss_oc_all(j)*sf < cF_lim(o_clp + 1))) then + if((ss_oc_all(j)*sf >= cF_lim(o_clp)).and.(ss_oc_all(j)*sf < cF_lim(o_clp + 1))) then if((ss_clay_all(j)*sf >= 0.).and.(ss_sand_all(j)*sf >= 0.)) then ! avoiding no-data-values - if(j <= i) factor = 1. ! top layer contribution - if(j > i) factor = 2.33 ! sub layer contribution + if(j <= i) factor = 1. ! top layer contribution + if(j > i) factor = 2.33 ! sub layer contribution - poc_vec (n) = poc_vec(n) + ss_oc_all(j)*sf*factor ! weighted sum of orgC - fac_count = fac_count + factor + poc_vec (n) = poc_vec(n) + ss_oc_all(j)*sf*factor ! weighted sum of orgC + fac_count = fac_count + factor k = k + 1 ! counter for top and sub contributions !cleanup k counter - + if (j<=i) ktop = ktop + 1 ! counter for top contributions only !cleanup k counter -!obsolete20220502 The code within the if-then and if-else statements below was nearly identical, -!obsolete20220502 except for the omission of the ktop counter from the else block. -!obsolete20220502 -!obsolete20220502 if(j <= i) then + !obsolete20220502 The code within the if-then and if-else statements below was nearly identical, + !obsolete20220502 except for the omission of the ktop counter from the else block. + !obsolete20220502 + !obsolete20220502 if(j <= i) then ss_clay (k) = ss_clay_all(j) ss_sand (k) = ss_sand_all(j) @@ -4686,463 +4464,456 @@ SUBROUTINE soil_para_hwsd (nx,ny,fnameRst) !k = k + 1 !cleanup k counter !ktop = ktop + 1 !cleanup k counter -!obsolete20220502 else -!obsolete20220502 ss_clay (k) = ss_clay_all(j) -!obsolete20220502 ss_sand (k) = ss_sand_all(j) -!obsolete20220502 if((ss_clay (k) + ss_sand (k)) > 9999) then -!obsolete20220502 if(ss_clay (k) >= ss_sand (k)) then -!obsolete20220502 ss_sand (k) = 10000 - ss_clay (k) -!obsolete20220502 else -!obsolete20220502 ss_clay (k) = 10000 - ss_sand (k) -!obsolete20220502 endif -!obsolete20220502 endif -!obsolete20220502 !k = k + 1 !cleanup k counter -!obsolete20220502 endif + !obsolete20220502 else + !obsolete20220502 ss_clay (k) = ss_clay_all(j) + !obsolete20220502 ss_sand (k) = ss_sand_all(j) + !obsolete20220502 if((ss_clay (k) + ss_sand (k)) > 9999) then + !obsolete20220502 if(ss_clay (k) >= ss_sand (k)) then + !obsolete20220502 ss_sand (k) = 10000 - ss_clay (k) + !obsolete20220502 else + !obsolete20220502 ss_clay (k) = 10000 - ss_sand (k) + !obsolete20220502 endif + !obsolete20220502 endif + !obsolete20220502 !k = k + 1 !cleanup k counter + !obsolete20220502 endif endif - endif - end do - - !k = k - 1 !cleanup k counter - !ktop = ktop -1 !cleanup k counter - - if(fac_count.ne.0) poc_vec (n) = poc_vec(n)/fac_count ! normalize profile-layer orgC - - !ncells_top_pro(n) = 100.*float(ktop)/float(i) ! ncells_* not used - !ncells_sub_pro(n) = 100.*float(k-ktop)/float(i) ! ncells_* not used - - ! debugging output - if (write_debug) write (80+n,*)ktop,k,o_cl - if (write_debug) write (80+n,*)ss_clay(1:k) - if (write_debug) write (80+n,*)ss_sand(1:k) - - ! Determine the raster grid cell and layer j that has clay/sand content closest - ! to the average (profile) clay/sand across all raster grid cells within the - ! dominant orgC class. - - j = center_pix_int0 (sf, ktop,k, ss_clay(1:k),ss_sand(1:k)) - - ! Assign soil class of raster grid cell and layer j to tile n - - if(j >=1) then - min_percs%clay_perc = ss_clay(j)*sf - min_percs%sand_perc = ss_sand(j)*sf - min_percs%silt_perc = 100. - ss_clay(j)*sf - ss_sand(j)*sf - soil_class_com (n) = table_map(soil_class (min_percs),o_clp) - endif - - ! debugging output - if (write_debug) write(80+n,*) j - if (write_debug) write(80+n,*) soil_class_com (n) - if (write_debug) close(80+n) - - endif - - deallocate (ss_clay,ss_sand,ss_clay_all,ss_sand_all,ss_oc_all) - - END DO - END DO ! loop through tiles -!$OMP ENDPARALLELDO - -! call process_peatmap (nx, ny, fnameRst, pmap) - - ! ----------------------------------------------------------------------------- - ! - ! apply final touches and write output files: - ! - soil_param.first - ! - tau_param.dat - ! - catch_params.nc4 [soil hydraulic and srfexc-rzexc time scale parameters ONLY; - ! parameters from ar.new, bf.dat, and ts.dat parameters will be - ! added to catch_params.nc4 by subroutine create_model_para_woesten()] - - inquire(file='clsm/catch_params.nc4', exist=CatchParamsNC_file_exists) - - if(CatchParamsNC_file_exists) then - status = NF_OPEN ('clsm/catch_params.nc4', NF_WRITE, ncid) ; VERIFY_(STATUS) - allocate (parms4file (1:maxcat, 1:10)) - endif + endif + end do + + !k = k - 1 !cleanup k counter + !ktop = ktop -1 !cleanup k counter + + if(fac_count.ne.0) poc_vec (n) = poc_vec(n)/fac_count ! normalize profile-layer orgC + + !ncells_top_pro(n) = 100.*float(ktop)/float(i) ! ncells_* not used + !ncells_sub_pro(n) = 100.*float(k-ktop)/float(i) ! ncells_* not used + + ! debugging output + if (write_debug) write (80+n,*)ktop,k,o_cl + if (write_debug) write (80+n,*)ss_clay(1:k) + if (write_debug) write (80+n,*)ss_sand(1:k) + + ! Determine the raster grid cell and layer j that has clay/sand content closest + ! to the average (profile) clay/sand across all raster grid cells within the + ! dominant orgC class. + + j = center_pix_int0 (sf, ktop,k, ss_clay(1:k),ss_sand(1:k)) + + ! Assign soil class of raster grid cell and layer j to tile n + + if(j >=1) then + min_percs%clay_perc = ss_clay(j)*sf + min_percs%sand_perc = ss_sand(j)*sf + min_percs%silt_perc = 100. - ss_clay(j)*sf - ss_sand(j)*sf + soil_class_com (n) = table_map(soil_class (min_percs),o_clp) + endif + + ! debugging output + if (write_debug) write(80+n,*) j + if (write_debug) write(80+n,*) soil_class_com (n) + if (write_debug) close(80+n) + + endif ! o_clp==4 + + deallocate (ss_clay,ss_sand,ss_clay_all,ss_sand_all,ss_oc_all) + END DO + END DO ! loop through tiles + !$OMP ENDPARALLELDO + + ! call process_peatmap (nx, ny, fnameRst, pmap) + + ! ----------------------------------------------------------------------------- + ! + ! apply final touches and write output files: + ! - soil_param.first + ! - tau_param.dat + ! - catch_params.nc4 [soil hydraulic and srfexc-rzexc time scale parameters ONLY; + ! parameters from ar.new, bf.dat, and ts.dat parameters will be + ! added to catch_params.nc4 by subroutine create_model_para_woesten()] + + inquire(file='clsm/catch_params.nc4', exist=CatchParamsNC_file_exists) + + if(CatchParamsNC_file_exists) then + status = NF_OPEN ('clsm/catch_params.nc4', NF_WRITE, ncid) ; VERIFY_(STATUS) + allocate (parms4file (1:n_land, 1:10)) + endif + + fname ='clsm/soil_param.first' + open (11,file=trim(fname),form='formatted',status='unknown',action = 'write') + + fname ='clsm/tau_param.dat' + open (12,file=trim(fname),form='formatted',status='unknown',action = 'write') + + + !obsolete20220502 fname ='clsm/mosaic_veg_typs_fracs' + !obsolete20220502 open (13,file=trim(fname),form='formatted',status='old',action = 'read') + + do n = 1, n_land + + !obsolete20220502 read (13,*) tindex,pfafindex,vtype - fname ='clsm/soil_param.first' - open (11,file=trim(fname),form='formatted',status='unknown',action = 'write') + ! fill gaps from neighbor for rare missing values caused by inconsistent masks + + if ((soil_class_top (n) == -9999).or.(soil_class_com (n) == -9999)) then + + ! if com-layer has data, the issue is only with top-layer + + if(soil_class_com (n) >= 1) soil_class_top (n) = soil_class_com (n) + + ! if there is nothing, look for the neighbor + ! + ! ^ + ! | + ! | The comment above seems wrong; could have soil_class_top(n)>=1, unless + ! earlier soil_class_com was set equal to soil_class_top whenever + ! soil_class_top was available and soil_class_com was not. + + if (soil_class_com (n) == -9999) then + + ! Look for neighbor j (regardless of soil_class_top) and set both + ! soil_class_com(n) and soil_class_top(n) equal to the neighbor's + ! soil_class_com(j). + + do k = 1, n_land + j = 0 + i1 = n - k + i2 = n + k + if(i1 >= 1) then + if (soil_class_com (i1) >=1) j = i1 ! tentatively use "lower" neighbor unless out of range + endif + + if(1 <= i2 .and. i2 <=n_land) then + if (soil_class_com (i2) >=1) j = i2 ! "upper" neighbor prevails unless out of range + endif + + if (j > 0) then + soil_class_com (n) = soil_class_com (j) + !soil_class_top (n) = soil_class_com (n) + soil_class_top (n) = soil_class_com (j) ! should be faster/safer than usin gsoil_class_com(n) + grav_vec(n) = grav_vec(j) + soc_vec(n) = soc_vec (j) + poc_vec(n) = poc_vec (j) + endif + + if (soil_class_com (n) >=1) exit + end do + endif + + endif + + fac_surf = soil_class_top(n) + fac = soil_class_com(n) + + if(use_PEATMAP) then + ! the maximum peat soil depth is set to the value Michel used to derive parameters (5000.) + if (fac_surf == 253) soildepth(n) = 5000. ! max(soildepth(n),5000.) + ! reset subsurface to peat if surface soil type is peat + if (fac_surf == 253) fac = 253 + endif + + wp_wetness = a_wp(fac) /a_poros(fac) + + this_cond = a_aksat(fac)/exp(-1.0*zks*gnu) + + + tindex = n + pfafindex = tile_pfs(n) + + ! write soil_param.first + + write (11,'(i10,i8,i4,i4,3f8.4,f12.8,f7.4,f10.4,3f7.3,4f7.3,2f10.4, f8.4)')tindex,pfafindex, & + fac_surf, fac, a_bee(fac),a_psis(fac),a_poros(fac),& + this_cond,wp_wetness,soildepth(n), & + grav_vec(n),soc_vec(n),poc_vec(n), & + a_sand(fac_surf),a_clay(fac_surf),a_sand(fac),a_clay(fac), & + a_wpsurf(fac_surf)/a_porosurf(fac_surf),a_porosurf(fac_surf), pmap(n) + + ! write tau_param.dat + write (12,'(i10,i8,4f10.7)')tindex,pfafindex, & + atau_2cm(fac_surf),btau_2cm(fac_surf),atau(fac_surf),btau(fac_surf) + + ! write catch_params.nc [soil hydraulic and srfexc-rzexc time scale parameters] + + if (allocated (parms4file)) then + + parms4file (n, 1) = a_bee(fac) + parms4file (n, 2) = this_cond ! a_aksat(fac)/exp(-1.0*zks*gnu) + parms4file (n, 3) = a_poros(fac) + parms4file (n, 4) = a_psis(fac) + parms4file (n, 5) = wp_wetness + parms4file (n, 6) = soildepth(n) + parms4file (n, 7) = atau_2cm(fac_surf) + parms4file (n, 8) = btau_2cm(fac_surf) + parms4file (n, 9) = atau(fac_surf) + parms4file (n,10) = btau(fac_surf) + + endif + end do - fname ='clsm/tau_param.dat' - open (12,file=trim(fname),form='formatted',status='unknown',action = 'write') + ! add "header" line to the bottom of soil_param.first + + write (11,'(a)')' ' + write (11,'(a)')'FMT=i10,i8,i4,i4,3f8.4,f12.8,f7.4,f10.4,3f7.3,4f7.3,2f10.4,f8.4' + write (11,'(a)')'TileIndex PfafID SoilClassTop SoilClassProfile BEE PSIS POROS Ks_at_SURF WPWET SoilDepth %Grav %OCTop %OCProf %Sand_top %Clay_top %Sand_prof %Clay_prof WPWET_SURF POROS_SURF PMAP' + + close (10, status = 'keep') + close (11, status = 'keep') + close (12, status = 'keep') + + !obsolete20220502 close (13, status = 'keep') + + deallocate (data_vec1, data_vec2,data_vec3, data_vec4,data_vec5, data_vec6) + deallocate (tileid_vec) + deallocate (a_sand,a_clay,a_silt,a_oc,a_bee,a_psis, & + a_poros,a_wp,a_aksat,atau,btau,a_wpsurf,a_porosurf, & + atau_2cm,btau_2cm) + deallocate (soildepth, grav_vec,soc_vec,poc_vec,soil_class_top,soil_class_com) + !ncells_top,ncells_top_pro,ncells_sub_pro,soil_class_top,soil_class_com) ! ncells_* not used + + ! write catch_params.nc4 [soil hydraulic and srfexc-rzexc time scale parameters] + + if(CatchParamsNC_file_exists) then + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'BEE' ) ,(/1/),(/n_land/), parms4file (:, 1)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'COND' ) ,(/1/),(/n_land/), parms4file (:, 2)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'POROS') ,(/1/),(/n_land/), parms4file (:, 3)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'PSIS' ) ,(/1/),(/n_land/), parms4file (:, 4)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'WPWET') ,(/1/),(/n_land/), parms4file (:, 5)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'DP2BR') ,(/1/),(/n_land/), parms4file (:, 6)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ATAU2') ,(/1/),(/n_land/), parms4file (:, 7)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'BTAU2') ,(/1/),(/n_land/), parms4file (:, 8)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ATAU5') ,(/1/),(/n_land/), parms4file (:, 9)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'BTAU5') ,(/1/),(/n_land/), parms4file (:,10)) ; VERIFY_(STATUS) + STATUS = NF_CLOSE (NCID) ; VERIFY_(STATUS) + DEALLOCATE (parms4file) + endif - ! open catchment.def for reading tile index and Pfafstetter index - - fname='clsm/catchment.def' - open (10,file=fname,status='old',action='read',form='formatted') - read(10,*) maxcat ! re-read header line - -!obsolete20220502 fname ='clsm/mosaic_veg_typs_fracs' -!obsolete20220502 open (13,file=trim(fname),form='formatted',status='old',action = 'read') - - do n = 1, maxcat - -!obsolete20220502 read (13,*) tindex,pfafindex,vtype - - ! fill gaps from neighbor for rare missing values caused by inconsistent masks - - if ((soil_class_top (n) == -9999).or.(soil_class_com (n) == -9999)) then - - ! if com-layer has data, the issue is only with top-layer - - if(soil_class_com (n) >= 1) soil_class_top (n) = soil_class_com (n) - - ! if there is nothing, look for the neighbor - ! - ! ^ - ! | - ! | The comment above seems wrong; could have soil_class_top(n)>=1, unless - ! earlier soil_class_com was set equal to soil_class_top whenever - ! soil_class_top was available and soil_class_com was not. - - if (soil_class_com (n) == -9999) then - - ! Look for neighbor j (regardless of soil_class_top) and set both - ! soil_class_com(n) and soil_class_top(n) equal to the neighbor's - ! soil_class_com(j). - - do k = 1, maxcat - j = 0 - i1 = n - k - i2 = n + k - if(i1 >= 1) then - if (soil_class_com (i1) >=1) j = i1 ! tentatively use "lower" neighbor unless out of range - endif - - if(1 <= i2 .and. i2 <=maxcat) then - if (soil_class_com (i2) >=1) j = i2 ! "upper" neighbor prevails unless out of range - endif - - if (j > 0) then - soil_class_com (n) = soil_class_com (j) - !soil_class_top (n) = soil_class_com (n) - soil_class_top (n) = soil_class_com (j) ! should be faster/safer than usin gsoil_class_com(n) - grav_vec(n) = grav_vec(j) - soc_vec(n) = soc_vec (j) - poc_vec(n) = poc_vec (j) - endif - - if (soil_class_com (n) >=1) exit - end do - endif - - endif - - fac_surf = soil_class_top(n) - fac = soil_class_com(n) - - if(use_PEATMAP) then - ! the maximum peat soil depth is set to the value Michel used to derive parameters (5000.) - if (fac_surf == 253) soildepth(n) = 5000. ! max(soildepth(n),5000.) - ! reset subsurface to peat if surface soil type is peat - if (fac_surf == 253) fac = 253 - endif - - wp_wetness = a_wp(fac) /a_poros(fac) - - this_cond = a_aksat(fac)/exp(-1.0*zks*gnu) - - ! read tile index and Pfafstetter index from catchment.def - - read (10,*) tindex,pfafindex - - ! write soil_param.first - - write (11,'(i10,i8,i4,i4,3f8.4,f12.8,f7.4,f10.4,3f7.3,4f7.3,2f10.4, f8.4)')tindex,pfafindex, & - fac_surf, fac, a_bee(fac),a_psis(fac),a_poros(fac),& - this_cond,wp_wetness,soildepth(n), & - grav_vec(n),soc_vec(n),poc_vec(n), & - a_sand(fac_surf),a_clay(fac_surf),a_sand(fac),a_clay(fac), & - a_wpsurf(fac_surf)/a_porosurf(fac_surf),a_porosurf(fac_surf), pmap(n) - - ! write tau_param.dat - - write (12,'(i10,i8,4f10.7)')tindex,pfafindex, & - atau_2cm(fac_surf),btau_2cm(fac_surf),atau(fac_surf),btau(fac_surf) - - ! write catch_params.nc [soil hydraulic and srfexc-rzexc time scale parameters] - - if (allocated (parms4file)) then - - parms4file (n, 1) = a_bee(fac) - parms4file (n, 2) = this_cond ! a_aksat(fac)/exp(-1.0*zks*gnu) - parms4file (n, 3) = a_poros(fac) - parms4file (n, 4) = a_psis(fac) - parms4file (n, 5) = wp_wetness - parms4file (n, 6) = soildepth(n) - parms4file (n, 7) = atau_2cm(fac_surf) - parms4file (n, 8) = btau_2cm(fac_surf) - parms4file (n, 9) = atau(fac_surf) - parms4file (n,10) = btau(fac_surf) + END SUBROUTINE soil_para_hwsd - endif - end do - - ! add "header" line to the bottom of soil_param.first - - write (11,'(a)')' ' - write (11,'(a)')'FMT=i10,i8,i4,i4,3f8.4,f12.8,f7.4,f10.4,3f7.3,4f7.3,2f10.4,f8.4' - write (11,'(a)')'TileIndex PfafID SoilClassTop SoilClassProfile BEE PSIS POROS Ks_at_SURF WPWET SoilDepth %Grav %OCTop %OCProf %Sand_top %Clay_top %Sand_prof %Clay_prof WPWET_SURF POROS_SURF PMAP' - - close (10, status = 'keep') - close (11, status = 'keep') - close (12, status = 'keep') - -!obsolete20220502 close (13, status = 'keep') - - deallocate (data_vec1, data_vec2,data_vec3, data_vec4,data_vec5, data_vec6) - deallocate (tileid_vec) - deallocate (a_sand,a_clay,a_silt,a_oc,a_bee,a_psis, & - a_poros,a_wp,a_aksat,atau,btau,a_wpsurf,a_porosurf, & - atau_2cm,btau_2cm) - deallocate (soildepth, grav_vec,soc_vec,poc_vec,soil_class_top,soil_class_com) - !ncells_top,ncells_top_pro,ncells_sub_pro,soil_class_top,soil_class_com) ! ncells_* not used - - ! write catch_params.nc4 [soil hydraulic and srfexc-rzexc time scale parameters] - - if(CatchParamsNC_file_exists) then - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'BEE' ) ,(/1/),(/maxcat/), parms4file (:, 1)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'COND' ) ,(/1/),(/maxcat/), parms4file (:, 2)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'POROS') ,(/1/),(/maxcat/), parms4file (:, 3)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'PSIS' ) ,(/1/),(/maxcat/), parms4file (:, 4)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'WPWET') ,(/1/),(/maxcat/), parms4file (:, 5)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'DP2BR') ,(/1/),(/maxcat/), parms4file (:, 6)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ATAU2') ,(/1/),(/maxcat/), parms4file (:, 7)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'BTAU2') ,(/1/),(/maxcat/), parms4file (:, 8)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ATAU5') ,(/1/),(/maxcat/), parms4file (:, 9)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'BTAU5') ,(/1/),(/maxcat/), parms4file (:,10)) ; VERIFY_(STATUS) - STATUS = NF_CLOSE (NCID) ; VERIFY_(STATUS) - DEALLOCATE (parms4file) - endif + ! -------------------------------------------------------------------------------------------------------- + + !obsolete20220502 INTEGER FUNCTION center_pix_int (sf,ktop, ktot, x,y,x0,y0,z0,ext_point) + !obsolete20220502 + !obsolete20220502 implicit none + !obsolete20220502 + !obsolete20220502 integer (kind =2), dimension (:), intent (in) :: x,y + !obsolete20220502 integer, intent (in) :: ktop,ktot + !obsolete20220502 real, intent (in) :: sf + !obsolete20220502 real :: xi,xj,yi,yj,xx0,yy0,zz0 + !obsolete20220502 real, allocatable, dimension (:,:) :: length_m + !obsolete20220502 real, allocatable, dimension (:) :: length + !obsolete20220502 real, intent (inout) :: x0,y0,z0 + !obsolete20220502 integer :: i,j,npix + !obsolete20220502 logical, intent(in) :: ext_point + !obsolete20220502 real :: zi, zj + !obsolete20220502 + !obsolete20220502 allocate (length_m (1:ktot,1:ktot)) + !obsolete20220502 allocate (length (1:ktot)) + !obsolete20220502 length_m =0. + !obsolete20220502 length =0. + !obsolete20220502 + !obsolete20220502 center_pix_int = -9999 + !obsolete20220502 if(ktot /= 0) then + !obsolete20220502 do i = 1,ktot + !obsolete20220502 xi = sf*x(i) + !obsolete20220502 yi = sf*y(i) + !obsolete20220502 zi = 100. - xi - yi + !obsolete20220502 if (.not. ext_point) then + !obsolete20220502 x0 = xi + !obsolete20220502 y0 = yi + !obsolete20220502 z0 = zi + !obsolete20220502 endif + !obsolete20220502 + !obsolete20220502 do j = 1,ktot + !obsolete20220502 xj = sf*x(j) + !obsolete20220502 yj = sf*y(j) + !obsolete20220502 zj = 100. - xj - yj + !obsolete20220502 xx0= xj - x0 + !obsolete20220502 yy0= yj - y0 + !obsolete20220502 zz0= zj - z0 + !obsolete20220502 + !obsolete20220502 if(ktot > ktop) then + !obsolete20220502 if(j <= ktop) then + !obsolete20220502 length_m (i,j) = (xx0*xx0 + yy0*yy0 + zz0*zz0)**0.5 + !obsolete20220502 else + !obsolete20220502 length_m (i,j) = 2.33*((xx0*xx0 + yy0*yy0 + zz0*zz0)**0.5) + !obsolete20220502 endif + !obsolete20220502 else + !obsolete20220502 length_m (i,j) = (xx0*xx0 + yy0*yy0 + zz0*zz0)**0.5 + !obsolete20220502 endif + !obsolete20220502 end do + !obsolete20220502 length (i) = sum(length_m (i,:)) + !obsolete20220502 end do + !obsolete20220502 + !obsolete20220502 center_pix_int = minloc(length,dim=1) + !obsolete20220502 endif + !obsolete20220502 + !obsolete20220502 END FUNCTION center_pix_int + !obsolete20220502 + !obsolete20220502 ! + !obsolete20220502 + + ! ==================================================================== + ! + + INTEGER FUNCTION center_pix_int0 (sf,ktop, ktot, x,y) - END SUBROUTINE soil_para_hwsd - - ! -------------------------------------------------------------------------------------------------------- - -!obsolete20220502 INTEGER FUNCTION center_pix_int (sf,ktop, ktot, x,y,x0,y0,z0,ext_point) -!obsolete20220502 -!obsolete20220502 implicit none -!obsolete20220502 -!obsolete20220502 integer (kind =2), dimension (:), intent (in) :: x,y -!obsolete20220502 integer, intent (in) :: ktop,ktot -!obsolete20220502 real, intent (in) :: sf -!obsolete20220502 real :: xi,xj,yi,yj,xx0,yy0,zz0 -!obsolete20220502 real, allocatable, dimension (:,:) :: length_m -!obsolete20220502 real, allocatable, dimension (:) :: length -!obsolete20220502 real, intent (inout) :: x0,y0,z0 -!obsolete20220502 integer :: i,j,npix -!obsolete20220502 logical, intent(in) :: ext_point -!obsolete20220502 real :: zi, zj -!obsolete20220502 -!obsolete20220502 allocate (length_m (1:ktot,1:ktot)) -!obsolete20220502 allocate (length (1:ktot)) -!obsolete20220502 length_m =0. -!obsolete20220502 length =0. -!obsolete20220502 -!obsolete20220502 center_pix_int = -9999 -!obsolete20220502 if(ktot /= 0) then -!obsolete20220502 do i = 1,ktot -!obsolete20220502 xi = sf*x(i) -!obsolete20220502 yi = sf*y(i) -!obsolete20220502 zi = 100. - xi - yi -!obsolete20220502 if (.not. ext_point) then -!obsolete20220502 x0 = xi -!obsolete20220502 y0 = yi -!obsolete20220502 z0 = zi -!obsolete20220502 endif -!obsolete20220502 -!obsolete20220502 do j = 1,ktot -!obsolete20220502 xj = sf*x(j) -!obsolete20220502 yj = sf*y(j) -!obsolete20220502 zj = 100. - xj - yj -!obsolete20220502 xx0= xj - x0 -!obsolete20220502 yy0= yj - y0 -!obsolete20220502 zz0= zj - z0 -!obsolete20220502 -!obsolete20220502 if(ktot > ktop) then -!obsolete20220502 if(j <= ktop) then -!obsolete20220502 length_m (i,j) = (xx0*xx0 + yy0*yy0 + zz0*zz0)**0.5 -!obsolete20220502 else -!obsolete20220502 length_m (i,j) = 2.33*((xx0*xx0 + yy0*yy0 + zz0*zz0)**0.5) -!obsolete20220502 endif -!obsolete20220502 else -!obsolete20220502 length_m (i,j) = (xx0*xx0 + yy0*yy0 + zz0*zz0)**0.5 -!obsolete20220502 endif -!obsolete20220502 end do -!obsolete20220502 length (i) = sum(length_m (i,:)) -!obsolete20220502 end do -!obsolete20220502 -!obsolete20220502 center_pix_int = minloc(length,dim=1) -!obsolete20220502 endif -!obsolete20220502 -!obsolete20220502 END FUNCTION center_pix_int -!obsolete20220502 -!obsolete20220502 ! -!obsolete20220502 - - ! ==================================================================== + implicit none + + ! In a nutshell, given a list of clay/sand pairs, this function determines + ! the element (pair) in this list that is closest to the average clay/sand + ! across all pairs. ! - - INTEGER FUNCTION center_pix_int0 (sf,ktop, ktot, x,y) - - implicit none + ! The input list of clay/sand can consist of only top (0-30) layer clay/sand + ! pairs, or of pairs of clay/sand pairs for the top (0-30) and sub (30-70) + ! layers. In the latter case, a weighted average is computed. + ! + ! This is to ensure that ultimately the clay/sand values assigned to a tile + ! represent an actual soil class. + ! + ! sf = 0.01 (integer to real scale factor) + ! ktop = # of pixels in top layer + ! ktot = total # of pixels, top + subsurface combined + ! x (clay), y (sand) + integer (kind =2), dimension (:), intent (in) :: x,y + integer, intent (in) :: ktop,ktot + real, intent (in) :: sf + + real :: xi,xj,yi,yj + real :: length + + integer :: i,j,npix + real :: zi, zj, mindist,xc,yc,zc + + length = 0. + + center_pix_int0 = -9999 + + ! compute average clay/sand + + if(ktot /= 0) then + ! There should be some data pixels + if(ktot > ktop) then + ! Have both layers + if(ktop > 0) then + ! There are data in top layer + xc = sf*0.3*sum(real(x(1:ktop)))/real(ktop) + sf*0.7*sum(real(x(ktop+1 : ktot)))/real(ktot - ktop) + yc = sf*0.3*sum(real(y(1:ktop)))/real(ktop) + sf*0.7*sum(real(y(ktop+1 : ktot)))/real(ktot - ktop) + else + ! There are no data in top layer + xc = sf*sum(real(x(1:ktot)))/real(ktot) + yc = sf*sum(real(y(1:ktot)))/real(ktot) + endif + else + ! working on Top layer alone + xc = sf*sum(real(x(1:ktot)))/real(ktot) + yc = sf*sum(real(y(1:ktot)))/real(ktot) + endif + zc = 100. - xc - yc ! silt [percent] + endif - ! In a nutshell, given a list of clay/sand pairs, this function determines - ! the element (pair) in this list that is closest to the average clay/sand - ! across all pairs. - ! - ! The input list of clay/sand can consist of only top (0-30) layer clay/sand - ! pairs, or of pairs of clay/sand pairs for the top (0-30) and sub (30-70) - ! layers. In the latter case, a weighted average is computed. - ! - ! This is to ensure that ultimately the clay/sand values assigned to a tile - ! represent an actual soil class. - ! - ! sf = 0.01 (integer to real scale factor) - ! ktop = # of pixels in top layer - ! ktot = total # of pixels, top + subsurface combined - ! x (clay), y (sand) - integer (kind =2), dimension (:), intent (in) :: x,y - integer, intent (in) :: ktop,ktot - real, intent (in) :: sf - - real :: xi,xj,yi,yj - real :: length - - integer :: i,j,npix - real :: zi, zj, mindist,xc,yc,zc - - length = 0. - - center_pix_int0 = -9999 - - ! compute average clay/sand - - if(ktot /= 0) then - ! There should be some data pixels - if(ktot > ktop) then - ! Have both layers - if(ktop > 0) then - ! There are data in top layer - xc = sf*0.3*sum(real(x(1:ktop)))/real(ktop) + sf*0.7*sum(real(x(ktop+1 : ktot)))/real(ktot - ktop) - yc = sf*0.3*sum(real(y(1:ktop)))/real(ktop) + sf*0.7*sum(real(y(ktop+1 : ktot)))/real(ktot - ktop) - else - ! There are no data in top layer - xc = sf*sum(real(x(1:ktot)))/real(ktot) - yc = sf*sum(real(y(1:ktot)))/real(ktot) - endif - else - ! working on Top layer alone - xc = sf*sum(real(x(1:ktot)))/real(ktot) - yc = sf*sum(real(y(1:ktot)))/real(ktot) - endif - zc = 100. - xc - yc ! silt [percent] - endif - - mindist=100000.*100000. - - do i = 1,ktot - xi = sf*x(i) - yi = sf*y(i) - zi = 100. - xi - yi - length = (xi-xc)**2+(yi-yc)**2+(zi-zc)**2 - if(mindist>length)then - mindist=length - center_pix_int0=i - end if - end do - !print *,ktop,ktot,center_pix_int0 - - END FUNCTION center_pix_int0 - - ! -------------------------------------------------------------------------------------- - -! this subroutine seems obsolete, commented out for now - reichle, 9 Feb 2022 - -! SUBROUTINE process_peatmap (nc, nr, fnameRst, pmap) -! -! implicit none -! integer , parameter :: N_lon_pm = 43200, N_lat_pm = 21600 -! integer, intent (in) :: nc, nr -! real, pointer, dimension (:), intent (inout) :: pmap -! character(*), intent (in) :: fnameRst -! integer :: i,j, status, varid, ncid -! integer :: NTILES -! REAL, ALLOCATABLE, dimension (:) :: count_pix -! REAL, ALLOCATABLE, dimension (:,:) :: data_grid, pm_grid -! INTEGER, ALLOCATABLE, dimension (:,:) :: tile_id -! character*100 :: fout -! -! character*300 :: MAKE_BCS_INPUT_DIR -! call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) -! -! ! Reading number of tiles -! ! ----------------------- -! -! open (20, file = 'clsm/catchment.def', form = 'formatted', status = 'old', action = 'read') -! -! read (20, *) NTILES -! -! close (20, status = 'keep') -! -! ! READ PEATMAP source data files and regrid -! ! ----------------------------------------- -! -! status = NF_OPEN (''//trim(MAKE_BCS_INPUT_DIR)//'/land/soil/SOIL-DATA/PEATMAP_mask.nc4', NF_NOWRITE, ncid) -! -! allocate (pm_grid (1 : NC , 1 : NR)) -! allocate (data_grid (1 : N_lon_pm, 1 : N_lat_pm)) -! -! status = NF_INQ_VARID (ncid,'PEATMAP',VarID) ; VERIFY_(STATUS) -! status = NF_GET_VARA_REAL (ncid,VarID, (/1,1/),(/N_lon_pm, N_lat_pm/), data_grid) ; VERIFY_(STATUS) -! -! call RegridRasterReal(data_grid, pm_grid) -! -! status = NF_CLOSE(ncid) -! -! ! Grid to tile -! ! ------------ -! -! ! Reading tile-id raster file -! -! allocate(tile_id(1:nc,1:nr)) -! -! open (10,file=trim(fnameRst)//'.rst',status='old',action='read', & -! form='unformatted',convert='little_endian') -! -! do j=1,nr -! read(10)tile_id(:,j) -! end do -! -! close (10,status='keep') -! -! allocate (pmap (1:NTILES)) -! allocate (count_pix (1:NTILES)) -! -! pmap = 0. -! count_pix = 0. -! -! do j = 1,nr -! do i = 1, nc -! if((tile_id(i,j).gt.0).and.(tile_id(i,j).le.NTILES)) then -! if(pm_grid(i,j) > 0.) pmap (tile_id(i,j)) = pmap (tile_id(i,j)) + pm_grid(i,j) -! count_pix (tile_id(i,j)) = count_pix (tile_id(i,j)) + 1. -! endif -! end do -! end do -! -! where (count_pix > 0.) pmap = pmap/count_pix -! -! deallocate (count_pix) -! deallocate (pm_grid) -! deallocate (tile_id) -! -! END SUBROUTINE process_peatmap - -! ==================================================================== - - SUBROUTINE grid2tile_ndep_t2m_alb (irst,jrst,fnameRst) + mindist=100000.*100000. + + do i = 1,ktot + xi = sf*x(i) + yi = sf*y(i) + zi = 100. - xi - yi + length = (xi-xc)**2+(yi-yc)**2+(zi-zc)**2 + if(mindist>length)then + mindist=length + center_pix_int0=i + end if + end do + !print *,ktop,ktot,center_pix_int0 + + END FUNCTION center_pix_int0 + + ! -------------------------------------------------------------------------------------- + + ! this subroutine seems obsolete, commented out for now - reichle, 9 Feb 2022 + + ! SUBROUTINE process_peatmap (nc, nr, fnameRst, pmap) + ! + ! implicit none + ! integer , parameter :: N_lon_pm = 43200, N_lat_pm = 21600 + ! integer, intent (in) :: nc, nr + ! real, pointer, dimension (:), intent (inout) :: pmap + ! character(*), intent (in) :: fnameRst + ! integer :: i,j, status, varid, ncid + ! integer :: NTILES + ! REAL, ALLOCATABLE, dimension (:) :: count_pix + ! REAL, ALLOCATABLE, dimension (:,:) :: data_grid, pm_grid + ! INTEGER, ALLOCATABLE, dimension (:,:) :: tile_id + ! character*100 :: fout + ! + ! character*300 :: MAKE_BCS_INPUT_DIR + ! call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) + ! + ! ! Reading number of tiles + ! ! ----------------------- + ! + ! open (20, file = 'clsm/catchment.def', form = 'formatted', status = 'old', action = 'read') + ! + ! read (20, *) NTILES + ! + ! close (20, status = 'keep') + ! + ! ! READ PEATMAP source data files and regrid + ! ! ----------------------------------------- + ! + ! status = NF_OPEN (''//trim(MAKE_BCS_INPUT_DIR)//'/land/soil/SOIL-DATA/PEATMAP_mask.nc4', NF_NOWRITE, ncid) + ! + ! allocate (pm_grid (1 : NC , 1 : NR)) + ! allocate (data_grid (1 : N_lon_pm, 1 : N_lat_pm)) + ! + ! status = NF_INQ_VARID (ncid,'PEATMAP',VarID) ; VERIFY_(STATUS) + ! status = NF_GET_VARA_REAL (ncid,VarID, (/1,1/),(/N_lon_pm, N_lat_pm/), data_grid) ; VERIFY_(STATUS) + ! + ! call RegridRasterReal(data_grid, pm_grid) + ! + ! status = NF_CLOSE(ncid) + ! + ! ! Grid to tile + ! ! ------------ + ! + ! ! Reading tile-id raster file + ! + ! allocate(tile_id(1:nc,1:nr)) + ! + ! open (10,file=trim(fnameRst)//'.rst',status='old',action='read', & + ! form='unformatted',convert='little_endian') + ! + ! do j=1,nr + ! read(10)tile_id(:,j) + ! end do + ! + ! close (10,status='keep') + ! + ! allocate (pmap (1:NTILES)) + ! allocate (count_pix (1:NTILES)) + ! + ! pmap = 0. + ! count_pix = 0. + ! + ! do j = 1,nr + ! do i = 1, nc + ! if((tile_id(i,j).gt.0).and.(tile_id(i,j).le.NTILES)) then + ! if(pm_grid(i,j) > 0.) pmap (tile_id(i,j)) = pmap (tile_id(i,j)) + pm_grid(i,j) + ! count_pix (tile_id(i,j)) = count_pix (tile_id(i,j)) + 1. + ! endif + ! end do + ! end do + ! + ! where (count_pix > 0.) pmap = pmap/count_pix + ! + ! deallocate (count_pix) + ! deallocate (pm_grid) + ! deallocate (tile_id) + ! + ! END SUBROUTINE process_peatmap + + ! ==================================================================== + + SUBROUTINE grid2tile_ndep_t2m_alb (irst,jrst,nland, tile_id) implicit none @@ -5167,12 +4938,12 @@ SUBROUTINE grid2tile_ndep_t2m_alb (irst,jrst,fnameRst) ! 18 crop [moisture + deciduous] ! 19 crop [moisture stress only] - integer ,intent (in) :: irst, jrst - character (*), intent (in) :: fnameRst + integer, intent(in) :: irst, jrst, nland + integer, intent(in) :: tile_id(:,:) ! tile raster file integer, parameter :: nveg = 4 ! number of veg types integer, parameter :: npft = 19 ! number of PFT - + integer, parameter :: iclm = 1152 ! lon dimension CLM NDEP data integer, parameter :: jclm = 768 ! lat dimension CLM NDEP data @@ -5185,12 +4956,11 @@ SUBROUTINE grid2tile_ndep_t2m_alb (irst,jrst,fnameRst) integer, parameter :: ialb = 7200 ! lon dimension MODIS soil background albedo data integer, parameter :: jalb = 3600 ! lat dimension MODIS soil background albedo data -! integer, parameter :: irst = 43200 ! lon dimension of tile raster file -! integer, parameter :: jrst = 21600 ! lat dimension of tile raster file + ! integer, parameter :: irst = 43200 ! lon dimension of tile raster file + ! integer, parameter :: jrst = 21600 ! lat dimension of tile raster file logical, parameter :: dir_access_files = .false. - integer, dimension (:,:), allocatable :: tile_id ! tile raster file real, allocatable :: ndep_tile(:), t2mp_tile(:), t2mm_tile(:), alb_tile(:,:,:) real, allocatable :: data_grid (:,:), vector(:) @@ -5199,32 +4969,16 @@ SUBROUTINE grid2tile_ndep_t2m_alb (irst,jrst,fnameRst) character :: ctype*1, cband*1 real :: rdum, ftot, xg, yg, fill, alonw, alats, alone, alatn, rlonw, rlats, rlone, rlatn, xx, yy - integer :: i, j, n, im, jm, lwi, idum, ntiles, nland, nv, ix, jx, itype, iband, isum, ntl, np, jalbx, ialbx, ncid, status + integer :: i, j, n, im, jm, lwi, idum, ntiles, nv, ix, jx, itype, iband, isum, ntl, np, jalbx, ialbx, ncid, status logical :: file_exists - ! read nland from catchment.def - ! ----------------------------- - - open (8, file = 'clsm/catchment.def', form = 'formatted', status = 'old', & - action = 'read') - - read (8,*) nland - - close(8, status = 'keep') - ! Read tile-id raster file; used for mapping gridded fields to tile space ! ----------------------------------------------------------------------- - allocate (tile_id(1:irst,1:jrst)) allocate(vector(nland)) allocate(icount(nland)) - - open(8,file=trim(fnameRst)//'.rst' ,status='old',action='read',form='unformatted') - do j=1,jrst - read(8) tile_id(:,j) - end do - close (8) + !===================================================================================================== ! The below correction was moved to esa2clm - SM @@ -5292,7 +5046,7 @@ SUBROUTINE grid2tile_ndep_t2m_alb (irst,jrst,fnameRst) ! endif ! ! if(abs(sum(fveg(n,:))-1.) > 1.e-6) stop 'fracs/=1' - + ! if (dir_access_files) write(9,rec=n) ityp(n,:),fveg(n,:) ! !80 format('pft:',i8,2f10.4,4i3,4f7.4) @@ -5301,202 +5055,202 @@ SUBROUTINE grid2tile_ndep_t2m_alb (irst,jrst,fnameRst) ! ! close(8) ! if (dir_access_files) close(9) - - !===================================================================================================== - - ! nitrogen deposition - ! ------------------- - - allocate(data_grid(iclm,jclm)) - allocate(ndep_tile(nland)) - - call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) - open(8,file=trim(MAKE_BCS_INPUT_DIR)//'/land/soil/nitrogen_deposition/v1/ndep_clm_simyr2000_0.23x0.31_c091106.gdat', & - form='unformatted',status='old') - read(8) data_grid - close(8) - - ! regridding to raster grid irst x jrst - ! ------------------------------------- - - xx = iclm/real(irst) - yy = (jclm-1)/real(jrst) ! gkw: subtract 1, since 1 & jclm are centered at pole (dlat=180/(jclm-1)) - - vector = 0. - icount = 0 - - do j = 1,jrst - jx = (j-1)*yy + 1 + 0.5 ! add half because CLM data is centered at south pole - if(jx<1 .or. jx>jclm) stop 'jclm' - do i = 1,irst - - if(tile_id(i,j)>0 .and. tile_id(i,j)<=nland) then - ix = (i-1)*xx + 1 + 0.5 ! add half because CLM data is centered on dateline - ix = ix + iclm/2 - if(ix > iclm) ix = ix - iclm ! shift 180 degrees; data starts at 0 lon - if(ix<1 .or. ix>iclm) stop 'iclm' - - if(data_grid(ix,jx) >= 0.) then - - ! aggregation on to catchment-tiles - ! --------------------------------- - - vector(tile_id(i,j)) = vector(tile_id(i,j)) + data_grid(ix,jx) - icount(tile_id(i,j)) = icount(tile_id(i,j)) + 1 - - endif - endif - end do - end do - - where (icount > 0) ndep_tile = (vector/icount)* (1.e9 / (86400. * 365.)) ! g/m2/yr --> ng/m2/s (for offline; GEOS5 will use g/m2/s) - - if (dir_access_files) then - ! write tile-space data - ! --------------------- - open(9,file='clsm/ndep.dat',form='unformatted',convert='big_endian', & - status='unknown',access='direct',recl=1) - do n = 1,nland - write(9,rec=n) ndep_tile(n) - end do - close(9) - endif - deallocate(data_grid) - - !===================================================================================================== - - - ! annual mean 2m air temperature climatology: Sheffield Princeton 1948-2012 - ! ------------------------------------------------------------------------- - allocate(data_grid(iprn,jprn)) - allocate(t2mp_tile(nland)) - - open(8,file=trim(MAKE_BCS_INPUT_DIR)//'/land/soil/annual_mean_T2m/v1/princeton_annual_mean_T2m_1948-2012.gdat', & - form='unformatted',status='old') - read(8) data_grid - close(8) - - ! regridding to raster grid irst x jrst - ! ------------------------------------- - xx = iprn/real(irst) - yy = jprn/real(jrst) - - vector = 0. - icount = 0 - - do j = 1,jrst - jx = (j-1)*yy + 1 - if(jx<1 .or. jx>jprn) stop 'jprn' - do i = 1,irst - - if(tile_id(i,j)>0 .and. tile_id(i,j)<=nland) then - ix = (i-1)*xx + 1 - ix = ix + iprn/2 ! shift 180 degrees; data starts at 0 lon - if(ix > iprn) ix = ix - iprn - if(ix<1 .or. ix>iprn) stop 'iprn' - if(data_grid(ix,jx) >= 0.) then - - ! aggregation on to catchment-tiles - ! --------------------------------- - - vector(tile_id(i,j)) = vector(tile_id(i,j)) + data_grid(ix,jx) - icount(tile_id(i,j)) = icount(tile_id(i,j)) + 1 - - endif - endif - end do - end do - - where (icount > 0) t2mp_tile = vector/icount - - if (dir_access_files) then - ! write tile-space data - ! --------------------- - open(9,file='clsm/cli_t2m_princeton.dat',form='unformatted',convert='big_endian', & - status='unknown',access='direct',recl=1) - do n = 1,nland - write(9,rec=n) t2mp_tile(n) - end do - close(9) - endif - - deallocate(data_grid) - - !===================================================================================================== - - - ! annual mean 2m air temperature climatology: MERRA-2 1980-2014 - ! ------------------------------------------------------------- - allocate(data_grid(imra,jmra)) - allocate(t2mm_tile(nland)) - - open(8,file=trim(MAKE_BCS_INPUT_DIR)//'/land/soil/annual_mean_T2m/v1/MERRA2_annual_mean_T2m_1980-2014.gdat', & - form='unformatted',status='old') - read(8) data_grid - close(8) - - ! regridding to raster grid irst x jrst - ! ------------------------------------- - xx = imra/real(irst) - yy = (jmra-1)/real(jrst) - - vector = 0. - icount = 0 - - do j = 1,jrst - jx = (j-1)*yy + 1 + 0.5 - if(jx<1 .or. jx>jmra) stop 'jmra' - do i = 1,irst - - if(tile_id(i,j)>0 .and. tile_id(i,j)<=nland) then - ix = (i-1)*xx + 1 + 0.5 - if(ix > imra) ix = ix - imra - if(ix<1 .or. ix>imra) stop 'imra' - if(data_grid (ix,jx) >= 0.) then - - ! aggregation on to catchment-tiles - ! --------------------------------- - - vector(tile_id(i,j)) = vector(tile_id(i,j)) + data_grid(ix,jx) - icount(tile_id(i,j)) = icount(tile_id(i,j)) + 1 - - endif - endif - end do - end do - - where (icount > 0) t2mm_tile = vector/icount - - if (dir_access_files) then - ! write tile-space data - ! --------------------- - open(9,file='clsm/cli_t2m_merra2.dat',form='unformatted',convert='big_endian', & - status='unknown',access='direct',recl=1) - do n = 1,nland - write(9,rec=n) t2mm_tile(n) - end do - close(9) - endif - - deallocate(data_grid) - + + !===================================================================================================== + + ! nitrogen deposition + ! ------------------- + + allocate(data_grid(iclm,jclm)) + allocate(ndep_tile(nland)) + + call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) + open(8,file=trim(MAKE_BCS_INPUT_DIR)//'/land/soil/nitrogen_deposition/v1/ndep_clm_simyr2000_0.23x0.31_c091106.gdat', & + form='unformatted',status='old') + read(8) data_grid + close(8) + + ! regridding to raster grid irst x jrst + ! ------------------------------------- + + xx = iclm/real(irst) + yy = (jclm-1)/real(jrst) ! gkw: subtract 1, since 1 & jclm are centered at pole (dlat=180/(jclm-1)) + + vector = 0. + icount = 0 + + do j = 1,jrst + jx = (j-1)*yy + 1 + 0.5 ! add half because CLM data is centered at south pole + if(jx<1 .or. jx>jclm) stop 'jclm' + do i = 1,irst + + if(tile_id(i,j)>0 .and. tile_id(i,j)<=nland) then + ix = (i-1)*xx + 1 + 0.5 ! add half because CLM data is centered on dateline + ix = ix + iclm/2 + if(ix > iclm) ix = ix - iclm ! shift 180 degrees; data starts at 0 lon + if(ix<1 .or. ix>iclm) stop 'iclm' + + if(data_grid(ix,jx) >= 0.) then + + ! aggregation on to catchment-tiles + ! --------------------------------- + + vector(tile_id(i,j)) = vector(tile_id(i,j)) + data_grid(ix,jx) + icount(tile_id(i,j)) = icount(tile_id(i,j)) + 1 + + endif + endif + end do + end do + + where (icount > 0) ndep_tile = (vector/icount)* (1.e9 / (86400. * 365.)) ! g/m2/yr --> ng/m2/s (for offline; GEOS5 will use g/m2/s) + + if (dir_access_files) then + ! write tile-space data + ! --------------------- + open(9,file='clsm/ndep.dat',form='unformatted',convert='big_endian', & + status='unknown',access='direct',recl=1) + do n = 1,nland + write(9,rec=n) ndep_tile(n) + end do + close(9) + endif + deallocate(data_grid) + + !===================================================================================================== + + + ! annual mean 2m air temperature climatology: Sheffield Princeton 1948-2012 + ! ------------------------------------------------------------------------- + allocate(data_grid(iprn,jprn)) + allocate(t2mp_tile(nland)) + + open(8,file=trim(MAKE_BCS_INPUT_DIR)//'/land/soil/annual_mean_T2m/v1/princeton_annual_mean_T2m_1948-2012.gdat', & + form='unformatted',status='old') + read(8) data_grid + close(8) + + ! regridding to raster grid irst x jrst + ! ------------------------------------- + xx = iprn/real(irst) + yy = jprn/real(jrst) + + vector = 0. + icount = 0 + + do j = 1,jrst + jx = (j-1)*yy + 1 + if(jx<1 .or. jx>jprn) stop 'jprn' + do i = 1,irst + + if(tile_id(i,j)>0 .and. tile_id(i,j)<=nland) then + ix = (i-1)*xx + 1 + ix = ix + iprn/2 ! shift 180 degrees; data starts at 0 lon + if(ix > iprn) ix = ix - iprn + if(ix<1 .or. ix>iprn) stop 'iprn' + if(data_grid(ix,jx) >= 0.) then + + ! aggregation on to catchment-tiles + ! --------------------------------- + + vector(tile_id(i,j)) = vector(tile_id(i,j)) + data_grid(ix,jx) + icount(tile_id(i,j)) = icount(tile_id(i,j)) + 1 + + endif + endif + end do + end do + + where (icount > 0) t2mp_tile = vector/icount + + if (dir_access_files) then + ! write tile-space data + ! --------------------- + open(9,file='clsm/cli_t2m_princeton.dat',form='unformatted',convert='big_endian', & + status='unknown',access='direct',recl=1) + do n = 1,nland + write(9,rec=n) t2mp_tile(n) + end do + close(9) + endif + + deallocate(data_grid) + + !===================================================================================================== + + + ! annual mean 2m air temperature climatology: MERRA-2 1980-2014 + ! ------------------------------------------------------------- + allocate(data_grid(imra,jmra)) + allocate(t2mm_tile(nland)) + + open(8,file=trim(MAKE_BCS_INPUT_DIR)//'/land/soil/annual_mean_T2m/v1/MERRA2_annual_mean_T2m_1980-2014.gdat', & + form='unformatted',status='old') + read(8) data_grid + close(8) + + ! regridding to raster grid irst x jrst + ! ------------------------------------- + xx = imra/real(irst) + yy = (jmra-1)/real(jrst) + + vector = 0. + icount = 0 + + do j = 1,jrst + jx = (j-1)*yy + 1 + 0.5 + if(jx<1 .or. jx>jmra) stop 'jmra' + do i = 1,irst + + if(tile_id(i,j)>0 .and. tile_id(i,j)<=nland) then + ix = (i-1)*xx + 1 + 0.5 + if(ix > imra) ix = ix - imra + if(ix<1 .or. ix>imra) stop 'imra' + if(data_grid (ix,jx) >= 0.) then + + ! aggregation on to catchment-tiles + ! --------------------------------- + + vector(tile_id(i,j)) = vector(tile_id(i,j)) + data_grid(ix,jx) + icount(tile_id(i,j)) = icount(tile_id(i,j)) + 1 + + endif + endif + end do + end do + + where (icount > 0) t2mm_tile = vector/icount + + if (dir_access_files) then + ! write tile-space data + ! --------------------- + open(9,file='clsm/cli_t2m_merra2.dat',form='unformatted',convert='big_endian', & + status='unknown',access='direct',recl=1) + do n = 1,nland + write(9,rec=n) t2mm_tile(n) + end do + close(9) + endif + + deallocate(data_grid) + !===================================================================================================== - - + + ! read soil background albedo if tile falls in MODIS grid cell, use that value gkw: may want to interpolate or aggregate ! ---------------------------------------------------------------------------- allocate(data_grid(ialb,jalb)) allocate(alb_tile(nland,2,2)) - + do itype = 1,2 do iband = 1,2 - + if(itype == 1) then ctype = 'b' ! "b" (direct, black sky) else ctype = 'w' ! "w" (diffuse, white sky) endif - + if(iband == 1) then cband = '1' ! "1" (visible) fill = 0.10 ! fill value to use when albedo not defined over land @@ -5504,21 +5258,21 @@ SUBROUTINE grid2tile_ndep_t2m_alb (irst,jrst,fnameRst) cband = '2' ! "2" (near IR) fill = 0.07 endif - + open(8,file=trim(MAKE_BCS_INPUT_DIR)//'/land/soil/SOIL-DATA/soil_albedo/v1/modis_'//ctype//'sa_soil_bb'//cband//'_cmg', & form='unformatted',status='old',access='direct',recl=ialb*jalb) read(8,rec=1) (data_grid(:,j), j = jalb,1,-1) ! data is from north to south where(data_grid <= 0.) data_grid = fill close(8) - + ! regridding to raster grid irst x jrst ! ------------------------------------- xx = ialb/real(irst) yy = jalb/real(jrst) - + vector = 0. icount = 0 - + do j = 1,jrst jx = (j-1)*yy + 1 if(jx<1 .or. jx>jalb) stop 'jalb' @@ -5531,7 +5285,7 @@ SUBROUTINE grid2tile_ndep_t2m_alb (irst,jrst,fnameRst) ! aggregation on to catchment-tiles ! --------------------------------- - + vector(tile_id(i,j)) = vector(tile_id(i,j)) + data_grid(ix,jx) icount(tile_id(i,j)) = icount(tile_id(i,j)) + 1 @@ -5539,10 +5293,10 @@ SUBROUTINE grid2tile_ndep_t2m_alb (irst,jrst,fnameRst) endif end do end do - + where (icount > 0) vector = vector/icount alb_tile(:,itype,iband) = vector (:) - + if (dir_access_files) then ! write tile-space data ! --------------------- @@ -5560,7 +5314,7 @@ SUBROUTINE grid2tile_ndep_t2m_alb (irst,jrst,fnameRst) open (10, file = 'clsm/CLM_NDep_SoilAlb_T2m', form = 'formatted', status ='unknown', & action = 'write') - + do n = 1,nland write (10, '(f10.4,4f7.4,2f8.3)') ndep_tile(n), & alb_tile(n,1,1),alb_tile(n,2,1), & @@ -5587,364 +5341,343 @@ SUBROUTINE grid2tile_ndep_t2m_alb (irst,jrst,fnameRst) end SUBROUTINE grid2tile_ndep_t2m_alb -! -! -------------------------------------------------------------------------------------- -! + ! + ! -------------------------------------------------------------------------------------- + ! + + ! SUBROUTINE CREATE_ROUT_PARA_FILE (NC, NR, fnameRst, MGRID, deltaXY) + ! + ! IMPLICIT NONE + ! + ! INTEGER, INTENT (IN) :: NC, NR + ! character*5, INTENT (IN), OPTIONAL :: MGRID + ! REAL, INTENT (IN), OPTIONAL :: deltaXY + ! character(*),INTENT (IN) :: fnameRst + ! real, allocatable, dimension (:) :: pfaf_area + ! integer,allocatable, dimension (:) :: pfaf_index + ! INTEGER :: NBINS, NPLUS, PFAF,N,L, I1,I2,J1,J2,I,J,K,IL1,IL2,JL1,JL2,NC_RAT + ! REAL :: mnx,mxx,mny,mxy, lats, dxy30 + ! INTEGER, PARAMETER :: NC_SRTM = 21600, NR_SRTM = 10800 + ! REAL :: dx =360._8/NC_ESA,dy = 180._8/NR_ESA, d2r = PI/180._8 + ! integer :: max_pfaf_smap = 40 + ! INTEGER, TARGET, ALLOCATABLE, DIMENSION (:,:) :: raster, tileid_index,& + ! SUBSET_MSK + ! INTEGER, POINTER, DIMENSION (:,:) :: SUBSET_RST + ! REAL, ALLOCATABLE, DIMENSION (:,:) :: SUBSET_AREA + ! REAL, ALLOCATABLE, DIMENSION (:) :: loc_val, loc_area + ! INTEGER, ALLOCATABLE, DIMENSION (:) :: density, loc_int + ! logical, ALLOCATABLE, DIMENSION (:) :: unq_mask + ! + ! INCLUDE 'netcdf.inc' + ! + ! INTEGER :: CellID, MaxID, d2(2), STATUS, VID, NCID, NCID_MSK, NCAT + ! integer, dimension(8) :: date_time_values + ! character (22) :: time_stamp + ! + ! + ! ! Reading raster file + ! + ! allocate(raster (1:nc,1:nr)) + ! + ! open (10, file ='rst/'//trim(fnameRst)//'.rst',form='unformatted',status='old', & + ! action='read') + ! + ! do j=1,nr + ! read(10)(raster (i,j),i=1,nc) + ! end do + ! + ! close (10,status='keep') + ! + ! ! Creating SMAP-Catch_TransferData.nc that contains SMAP cells to Pfafstetter transfer infor + ! + ! open (10,file='clsm/catchment.def',form='formatted',status='old', action = 'read') + ! + ! read (10,*) NCAT + ! + ! if (PRESENT (MGRID)) then + ! if (trim(MGRID) == 'M25') max_pfaf_smap = 30 + ! if (trim(MGRID) == 'M09') max_pfaf_smap = 12 + ! if (trim(MGRID) == 'M03') max_pfaf_smap = 5 + ! endif + ! + ! if (PRESENT (deltaXY)) then + ! if (deltaXY < 0.125) max_pfaf_smap = 15 + ! if (deltaXY >= 0.125) max_pfaf_smap = 15 + ! if (deltaXY >= 0.25 ) max_pfaf_smap = 40 + ! if (deltaXY >= 0.5 ) max_pfaf_smap = 100 + ! if (deltaXY >= 1.0 ) max_pfaf_smap = 250 + ! endif + ! + ! status = NF_CREATE ('clsm/Grid2Catch_TransferData.nc', NF_NETCDF4, NCID) + ! status = NF_DEF_DIM(NCID, 'N_GRID_CELLS' , ncat,CellID) + ! status = NF_DEF_DIM(NCID, 'MAX_CAT_PER_CELL', max_pfaf_smap ,MaxID ) + ! + ! d2(1) = MaxID + ! d2(2) = CellID + ! + ! status = NF_DEF_VAR(NCID, 'NCats_in_GRID', NF_INT , 1 ,CellID, vid) + ! status = NF_PUT_ATT_TEXT(NCID, vid, 'long_name',& + ! LEN_TRIM('No. of watersheds contributed to the Grid cell'), & + ! trim('No. of watersheds contributed to the Grid cell')) + ! status = NF_DEF_VAR(NCID, 'Pfaf_Index' , NF_INT , 2 ,d2 , vid) + ! status = NF_PUT_ATT_TEXT(NCID, vid, 'long_name',& + ! LEN_TRIM('Pfaf indices of those contributing watersheds'), & + ! trim('Pfaf indices of those contributing watersheds')) + ! status = NF_DEF_VAR(NCID, 'Pfaf_Area ' , NF_FLOAT, 2 ,d2 , vid) + ! status = NF_PUT_ATT_TEXT(NCID, vid, 'long_name', & + ! LEN_TRIM('Area of watershed fraction'),& + ! trim('Area of watershed fraction')) + ! status = NF_PUT_ATT_TEXT(NCID, vid, 'units',& + ! LEN_TRIM('km2'), trim('km2')) + ! ! status = NF_DEF_VAR(NCID, 'Pfaf_Frac ' , NF_FLOAT, 2 ,d2 , vid) + ! ! status = NF_PUT_ATT_TEXT(NCID, vid, 'long_name', & + ! ! LEN_TRIM('Fraction of Pfaf catchment contributed to the SMAP cell'),& + ! ! trim('Fraction of Pfaf catchment contributed to the SMAP cell')) + ! ! + ! ! Global attributes + ! ! + ! call date_and_time(VALUES=date_time_values) + ! + ! write (time_stamp,'(i4.4,a1,i2.2,a1,i2.2,1x,a2,1x,i2.2,a1,i2.2,a1,i2.2)') & + ! date_time_values(1),'-',date_time_values(2),'-',date_time_values(3),'at', & + ! date_time_values(5),':',date_time_values(6),':',date_time_values(7) + ! + ! status = NF_PUT_ATT_TEXT(NCID, NF_GLOBAL, 'CreatedBy', LEN_TRIM('Sarith Mahanama @ GMAO/GSFC/NASA'), & + ! trim('Sarith Mahanama @ GMAO/GSFC/NASA')) + ! status = NF_PUT_ATT_TEXT(NCID, NF_GLOBAL, 'Contact', LEN_TRIM('sarith.p.mahanama@nasa.gov'), & + ! trim('sarith.p.mahanama@nasa.gov')) + ! status = NF_PUT_ATT_TEXT(NCID, NF_GLOBAL, 'Date' , LEN_TRIM(time_stamp),trim(time_stamp)) + ! status = NF_ENDDEF(NCID) + ! + ! ! Now computing SMAP-cells to Pfafcatchment fractional areas + ! + ! call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) + ! status = NF_OPEN (trim(MAKE_BCS_INPUT_DIR)//'/shared/mask/GEOS5_10arcsec_mask.nc', NF_NOWRITE, ncid_msk) + ! nbins = 1 + ! + ! allocate (pfaf_area (1:max_pfaf_smap)) + ! allocate (pfaf_index(1:max_pfaf_smap)) + ! + ! dxy30 = 360._8/nc + ! NC_RAT = nc_esa/nc + ! + ! DO N = 1, NCAT + ! + ! pfaf_index = 0 + ! pfaf_area = 0. + ! + ! READ (10,'(i10,i8,5(2x,f9.4), i4)')l,pfaf,mnx,mxx,mny,mxy + ! + ! IL1 = FLOOR ((180. + mnx)/DXY30 + 1.) + ! IL2 = CEILING((180. + mxx)/DXY30 + 1.) + ! JL1 = FLOOR (( 90. + mny)/DXY30 + 1.) + ! JL2 = CEILING(( 90. + mxy)/DXY30 + 1.) + ! + ! IF(IL2 > NC) IL2 = NC + ! IF(JL2 > NR) JL2 = NR + ! + ! I1 = NC_RAT * IL1 - (NC_RAT -1) + ! I2 = NC_RAT * IL2 + ! J1 = NC_RAT * JL1 - (NC_RAT -1) + ! J2 = NC_RAT * JL2 + ! + ! ALLOCATE (SUBSET_MSK (1 : I2 - I1 +1 , 1 : J2 - J1 + 1)) + ! ALLOCATE (SUBSET_AREA(1 : I2 - I1 +1 , 1 : J2 - J1 + 1)) + ! ALLOCATE (TILEID_INDEX(1 : I2 - I1 +1 , 1 : J2 - J1 + 1)) + ! + ! DO J = J1, J2 + ! lats = -90._8 + (j - 0.5_8)*dy + ! SUBSET_AREA(:,J-J1 + 1) = (sin(d2r*(lats+0.5*dy)) -sin(d2r*(lats-0.5*dy)))*(dx*d2r) + ! END DO + ! + ! status = NF_GET_VARA_INT (ncid_msk,4,(/I1,J1/),(/I2 - I1 +1,J2 - J1 + 1/),SUBSET_MSK) + ! + ! if (associated (subset_rst )) NULLIFY (subset_rst) + ! SUBSET_RST => RASTER (IL1 : IL2, JL1 : JL2) + ! + ! call RegridRaster(SUBSET_RST, tileid_index) + ! + ! NPLUS = count((tileid_index ==N).AND.(SUBSET_MSK >= 1 .and. subset_MSK <= SRTM_maxcat)) + ! allocate (loc_int (1:NPLUS)) + ! allocate (loc_area(1:NPLUS)) + ! allocate (unq_mask(1:NPLUS)) + ! + ! loc_int = pack(SUBSET_MSK ,mask = ((tileid_index ==N).AND.(SUBSET_MSK >= 1 .and. subset_MSK <= SRTM_maxcat))) + ! loc_area= pack(SUBSET_AREA ,mask = ((tileid_index ==N).AND.(SUBSET_MSK >= 1 .and. subset_MSK <= SRTM_maxcat))) + ! + ! call MAPL_Sort (loc_int, loc_area) + ! + ! unq_mask = .true. + ! do K = 2,NPLUS + ! unq_mask(K) = .not.(loc_int(K) == loc_int(K-1)) ! count number of unique numbers in loc_int for binning + ! end do + ! NBINS = count(unq_mask) + ! + ! if (NBINS > max_pfaf_smap) then + ! print *, 'NBINS exceeded max_pfaf_smap', NBINS, max_pfaf_smap + ! STOP + ! endif + ! + ! if (NBINS > 1) then + ! L = 1 + ! pfaf_index(L) = loc_int (1) + ! pfaf_area (L) = loc_area(1) + ! DO K = 2,NPLUS + ! IF(.not.(loc_int(K) == loc_int(K-1))) L = L + 1 + ! pfaf_index(L) = loc_int (K) + ! pfaf_area (L) = pfaf_area (L) + loc_area(K) * MAPL_RADIUS * MAPL_RADIUS/1000./1000. + ! END DO + ! else + ! IF(NBINS == 1) THEN + ! pfaf_index(1) = loc_int (1) + ! pfaf_area (1) = sum (loc_area(1:NPLUS)) + ! pfaf_area (1) = pfaf_area(1) * MAPL_RADIUS * MAPL_RADIUS/1000./1000. + ! ELSE + ! PRINT *,'NO Catchments so skipping' + ! NBINS = 1 + ! pfaf_index(1) = -1 + ! pfaf_area (1)= -9999. + ! ENDIF + ! endif + ! + ! status = NF_PUT_VARA_INT (NCID, 1,(/N/),(/1/),nbins) + ! status = NF_PUT_VARA_INT (NCID, 2,(/1,N/),(/nbins,1/),pfaf_index(1:nbins)) + ! status = NF_PUT_VARA_REAL(NCID, 3,(/1,N/),(/nbins,1/),pfaf_area (1:nbins)) + ! + ! DEALLOCATE (SUBSET_MSK,SUBSET_AREA, loc_int,loc_area,unq_mask,tileid_index) + ! END DO + ! + ! DEALLOCATE (RASTER) + ! status = NF_CLOSE (ncid) + ! status = NF_CLOSE (ncid_msk) + ! close (10, status = 'keep') + ! + ! END SUBROUTINE CREATE_ROUT_PARA_FILE + + ! ------------------------------------------------------------------------------------------------------------------------------- + + SUBROUTINE CLM45_fixed_parameters (nc,nr, ntiles, tile_id) -! SUBROUTINE CREATE_ROUT_PARA_FILE (NC, NR, fnameRst, MGRID, deltaXY) -! -! IMPLICIT NONE -! -! INTEGER, INTENT (IN) :: NC, NR -! character*5, INTENT (IN), OPTIONAL :: MGRID -! REAL, INTENT (IN), OPTIONAL :: deltaXY -! character(*),INTENT (IN) :: fnameRst -! real, allocatable, dimension (:) :: pfaf_area -! integer,allocatable, dimension (:) :: pfaf_index -! INTEGER :: NBINS, NPLUS, PFAF,N,L, I1,I2,J1,J2,I,J,K,IL1,IL2,JL1,JL2,NC_RAT -! REAL :: mnx,mxx,mny,mxy, lats, dxy30 -! INTEGER, PARAMETER :: NC_SRTM = 21600, NR_SRTM = 10800 -! REAL :: dx =360._8/NC_ESA,dy = 180._8/NR_ESA, d2r = PI/180._8 -! integer :: max_pfaf_smap = 40 -! INTEGER, TARGET, ALLOCATABLE, DIMENSION (:,:) :: raster, tileid_index,& -! SUBSET_MSK -! INTEGER, POINTER, DIMENSION (:,:) :: SUBSET_RST -! REAL, ALLOCATABLE, DIMENSION (:,:) :: SUBSET_AREA -! REAL, ALLOCATABLE, DIMENSION (:) :: loc_val, loc_area -! INTEGER, ALLOCATABLE, DIMENSION (:) :: density, loc_int -! logical, ALLOCATABLE, DIMENSION (:) :: unq_mask -! -! INCLUDE 'netcdf.inc' -! -! INTEGER :: CellID, MaxID, d2(2), STATUS, VID, NCID, NCID_MSK, NCAT -! integer, dimension(8) :: date_time_values -! character (22) :: time_stamp -! -! -! ! Reading raster file -! -! allocate(raster (1:nc,1:nr)) -! -! open (10, file ='rst/'//trim(fnameRst)//'.rst',form='unformatted',status='old', & -! action='read') -! -! do j=1,nr -! read(10)(raster (i,j),i=1,nc) -! end do -! -! close (10,status='keep') -! -! ! Creating SMAP-Catch_TransferData.nc that contains SMAP cells to Pfafstetter transfer infor -! -! open (10,file='clsm/catchment.def',form='formatted',status='old', action = 'read') -! -! read (10,*) NCAT -! -! if (PRESENT (MGRID)) then -! if (trim(MGRID) == 'M25') max_pfaf_smap = 30 -! if (trim(MGRID) == 'M09') max_pfaf_smap = 12 -! if (trim(MGRID) == 'M03') max_pfaf_smap = 5 -! endif -! -! if (PRESENT (deltaXY)) then -! if (deltaXY < 0.125) max_pfaf_smap = 15 -! if (deltaXY >= 0.125) max_pfaf_smap = 15 -! if (deltaXY >= 0.25 ) max_pfaf_smap = 40 -! if (deltaXY >= 0.5 ) max_pfaf_smap = 100 -! if (deltaXY >= 1.0 ) max_pfaf_smap = 250 -! endif -! -! status = NF_CREATE ('clsm/Grid2Catch_TransferData.nc', NF_NETCDF4, NCID) -! status = NF_DEF_DIM(NCID, 'N_GRID_CELLS' , ncat,CellID) -! status = NF_DEF_DIM(NCID, 'MAX_CAT_PER_CELL', max_pfaf_smap ,MaxID ) -! -! d2(1) = MaxID -! d2(2) = CellID -! -! status = NF_DEF_VAR(NCID, 'NCats_in_GRID', NF_INT , 1 ,CellID, vid) -! status = NF_PUT_ATT_TEXT(NCID, vid, 'long_name',& -! LEN_TRIM('No. of watersheds contributed to the Grid cell'), & -! trim('No. of watersheds contributed to the Grid cell')) -! status = NF_DEF_VAR(NCID, 'Pfaf_Index' , NF_INT , 2 ,d2 , vid) -! status = NF_PUT_ATT_TEXT(NCID, vid, 'long_name',& -! LEN_TRIM('Pfaf indices of those contributing watersheds'), & -! trim('Pfaf indices of those contributing watersheds')) -! status = NF_DEF_VAR(NCID, 'Pfaf_Area ' , NF_FLOAT, 2 ,d2 , vid) -! status = NF_PUT_ATT_TEXT(NCID, vid, 'long_name', & -! LEN_TRIM('Area of watershed fraction'),& -! trim('Area of watershed fraction')) -! status = NF_PUT_ATT_TEXT(NCID, vid, 'units',& -! LEN_TRIM('km2'), trim('km2')) -! ! status = NF_DEF_VAR(NCID, 'Pfaf_Frac ' , NF_FLOAT, 2 ,d2 , vid) -! ! status = NF_PUT_ATT_TEXT(NCID, vid, 'long_name', & -! ! LEN_TRIM('Fraction of Pfaf catchment contributed to the SMAP cell'),& -! ! trim('Fraction of Pfaf catchment contributed to the SMAP cell')) -! ! -! ! Global attributes -! ! -! call date_and_time(VALUES=date_time_values) -! -! write (time_stamp,'(i4.4,a1,i2.2,a1,i2.2,1x,a2,1x,i2.2,a1,i2.2,a1,i2.2)') & -! date_time_values(1),'-',date_time_values(2),'-',date_time_values(3),'at', & -! date_time_values(5),':',date_time_values(6),':',date_time_values(7) -! -! status = NF_PUT_ATT_TEXT(NCID, NF_GLOBAL, 'CreatedBy', LEN_TRIM('Sarith Mahanama @ GMAO/GSFC/NASA'), & -! trim('Sarith Mahanama @ GMAO/GSFC/NASA')) -! status = NF_PUT_ATT_TEXT(NCID, NF_GLOBAL, 'Contact', LEN_TRIM('sarith.p.mahanama@nasa.gov'), & -! trim('sarith.p.mahanama@nasa.gov')) -! status = NF_PUT_ATT_TEXT(NCID, NF_GLOBAL, 'Date' , LEN_TRIM(time_stamp),trim(time_stamp)) -! status = NF_ENDDEF(NCID) -! -! ! Now computing SMAP-cells to Pfafcatchment fractional areas -! -! call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) -! status = NF_OPEN (trim(MAKE_BCS_INPUT_DIR)//'/shared/mask/GEOS5_10arcsec_mask.nc', NF_NOWRITE, ncid_msk) -! nbins = 1 -! -! allocate (pfaf_area (1:max_pfaf_smap)) -! allocate (pfaf_index(1:max_pfaf_smap)) -! -! dxy30 = 360._8/nc -! NC_RAT = nc_esa/nc -! -! DO N = 1, NCAT -! -! pfaf_index = 0 -! pfaf_area = 0. -! -! READ (10,'(i10,i8,5(2x,f9.4), i4)')l,pfaf,mnx,mxx,mny,mxy -! -! IL1 = FLOOR ((180. + mnx)/DXY30 + 1.) -! IL2 = CEILING((180. + mxx)/DXY30 + 1.) -! JL1 = FLOOR (( 90. + mny)/DXY30 + 1.) -! JL2 = CEILING(( 90. + mxy)/DXY30 + 1.) -! -! IF(IL2 > NC) IL2 = NC -! IF(JL2 > NR) JL2 = NR -! -! I1 = NC_RAT * IL1 - (NC_RAT -1) -! I2 = NC_RAT * IL2 -! J1 = NC_RAT * JL1 - (NC_RAT -1) -! J2 = NC_RAT * JL2 -! -! ALLOCATE (SUBSET_MSK (1 : I2 - I1 +1 , 1 : J2 - J1 + 1)) -! ALLOCATE (SUBSET_AREA(1 : I2 - I1 +1 , 1 : J2 - J1 + 1)) -! ALLOCATE (TILEID_INDEX(1 : I2 - I1 +1 , 1 : J2 - J1 + 1)) -! -! DO J = J1, J2 -! lats = -90._8 + (j - 0.5_8)*dy -! SUBSET_AREA(:,J-J1 + 1) = (sin(d2r*(lats+0.5*dy)) -sin(d2r*(lats-0.5*dy)))*(dx*d2r) -! END DO -! -! status = NF_GET_VARA_INT (ncid_msk,4,(/I1,J1/),(/I2 - I1 +1,J2 - J1 + 1/),SUBSET_MSK) -! -! if (associated (subset_rst )) NULLIFY (subset_rst) -! SUBSET_RST => RASTER (IL1 : IL2, JL1 : JL2) -! -! call RegridRaster(SUBSET_RST, tileid_index) -! -! NPLUS = count((tileid_index ==N).AND.(SUBSET_MSK >= 1 .and. subset_MSK <= SRTM_maxcat)) -! allocate (loc_int (1:NPLUS)) -! allocate (loc_area(1:NPLUS)) -! allocate (unq_mask(1:NPLUS)) -! -! loc_int = pack(SUBSET_MSK ,mask = ((tileid_index ==N).AND.(SUBSET_MSK >= 1 .and. subset_MSK <= SRTM_maxcat))) -! loc_area= pack(SUBSET_AREA ,mask = ((tileid_index ==N).AND.(SUBSET_MSK >= 1 .and. subset_MSK <= SRTM_maxcat))) -! -! call MAPL_Sort (loc_int, loc_area) -! -! unq_mask = .true. -! do K = 2,NPLUS -! unq_mask(K) = .not.(loc_int(K) == loc_int(K-1)) ! count number of unique numbers in loc_int for binning -! end do -! NBINS = count(unq_mask) -! -! if (NBINS > max_pfaf_smap) then -! print *, 'NBINS exceeded max_pfaf_smap', NBINS, max_pfaf_smap -! STOP -! endif -! -! if (NBINS > 1) then -! L = 1 -! pfaf_index(L) = loc_int (1) -! pfaf_area (L) = loc_area(1) -! DO K = 2,NPLUS -! IF(.not.(loc_int(K) == loc_int(K-1))) L = L + 1 -! pfaf_index(L) = loc_int (K) -! pfaf_area (L) = pfaf_area (L) + loc_area(K) * MAPL_RADIUS * MAPL_RADIUS/1000./1000. -! END DO -! else -! IF(NBINS == 1) THEN -! pfaf_index(1) = loc_int (1) -! pfaf_area (1) = sum (loc_area(1:NPLUS)) -! pfaf_area (1) = pfaf_area(1) * MAPL_RADIUS * MAPL_RADIUS/1000./1000. -! ELSE -! PRINT *,'NO Catchments so skipping' -! NBINS = 1 -! pfaf_index(1) = -1 -! pfaf_area (1)= -9999. -! ENDIF -! endif -! -! status = NF_PUT_VARA_INT (NCID, 1,(/N/),(/1/),nbins) -! status = NF_PUT_VARA_INT (NCID, 2,(/1,N/),(/nbins,1/),pfaf_index(1:nbins)) -! status = NF_PUT_VARA_REAL(NCID, 3,(/1,N/),(/nbins,1/),pfaf_area (1:nbins)) -! -! DEALLOCATE (SUBSET_MSK,SUBSET_AREA, loc_int,loc_area,unq_mask,tileid_index) -! END DO -! -! DEALLOCATE (RASTER) -! status = NF_CLOSE (ncid) -! status = NF_CLOSE (ncid_msk) -! close (10, status = 'keep') -! -! END SUBROUTINE CREATE_ROUT_PARA_FILE - -! ------------------------------------------------------------------------------------------------------------------------------- - - SUBROUTINE CLM45_fixed_parameters (nc,nr,fnameRst) + implicit none + + ! producing CLM4.5 fixed parameters : + + + ! 1) Population density /discover/nobackup/fzeng/clm4-to-clm4.5/data/firedata4.5/clmforc.Li_2012_hdm_0.5x0.5_AVHRR_simyr1850-2010_c130401.nc + ! Use 2010 + ! 2) /gpfsm/dnb31/fzeng/clm4-to-clm4.5/data/rawdata4.5 + ! mksrf_abm_0.5x0.5_AVHRR_simyr2000.c130201.nc + ! mksrf_gdp_0.5x0.5_AVHRR_simyr2000.c130228.nc + ! mksrf_peatf_0.5x0.5_AVHRR_simyr2000.c130228.nc + ! one value per tile + ! 3) field capacity one value per tile + + integer, intent(in) :: nc, nr, ntiles + integer, intent(in) :: tile_id(:,:) + + integer , parameter :: N_lon_clm = 720, N_lat_clm = 360 + real, parameter :: dxy_clm = 0.5 + integer :: i,j, status, varid, ncid_hdm, ncid_abm, ncid_gdp, ncid_peatf + integer :: tid, cid, ABM_INT, sc_top, sc_com + REAL, ALLOCATABLE, dimension (:) :: hdm, abm, gdp, peatf + REAL, ALLOCATABLE, dimension (:,:) :: hdm_grid, gdp_grid, peatf_grid, data_grid, count_pix + INTEGER, ALLOCATABLE, dimension (:,:) :: abm_grid, int_grid + REAL :: hdm_r, gdp_r, peatf_r + character*100 :: fout + real :: & + a_sand,a_clay,a_silt,a_oc,a_bee,a_psis, & + a_poros,a_wp,a_aksat,atau,btau,a_wpsurf,a_porosurf, & + atau_2cm,btau_2cm, field_cap (n_SoilClasses) + + + ! READ CLM4.5 source data files and regrid + ! ---------------------------------------- + + call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) + status = NF_OPEN (trim(MAKE_BCS_INPUT_DIR)//'/land/veg/misc/CLM45/clmforc.Li_2012_hdm_0.5x0.5_AVHRR_simyr1850-2010_c130401.nc', NF_NOWRITE, ncid_hdm ) + status = NF_OPEN (trim(MAKE_BCS_INPUT_DIR)//'/land/veg/misc/CLM45/mksrf_abm_0.5x0.5_AVHRR_simyr2000.c130201.nc' , NF_NOWRITE, ncid_abm ) + status = NF_OPEN (trim(MAKE_BCS_INPUT_DIR)//'/land/veg/misc/CLM45/mksrf_gdp_0.5x0.5_AVHRR_simyr2000.c130228.nc' , NF_NOWRITE, ncid_gdp ) + status = NF_OPEN (trim(MAKE_BCS_INPUT_DIR)//'/land/veg/misc/CLM45/mksrf_peatf_0.5x0.5_AVHRR_simyr2000.c130228.nc' , NF_NOWRITE, ncid_peatf) + + allocate (hdm_grid (1:NC,1:NR)) + allocate (abm_grid (1:NC,1:NR)) + allocate (gdp_grid (1:NC,1:NR)) + allocate (peatf_grid (1:NC,1:NR)) + allocate (data_grid (1 : N_lon_clm, 1 : N_lat_clm)) + allocate (int_grid (1 : N_lon_clm, 1 : N_lat_clm)) + + status = NF_INQ_VARID (ncid_hdm,'hdm',VarID) ; VERIFY_(STATUS) + status = NF_GET_VARA_REAL (ncid_hdm,VarID,(/1,1,161/),(/N_lon_clm, N_lat_clm, 1/),data_grid(:,:)) ; VERIFY_(STATUS) + call RegridRasterReal(data_grid, hdm_grid) + + status = NF_INQ_VARID (ncid_abm,'abm',VarID) ; VERIFY_(STATUS) + status = NF_GET_VARA_INT (ncid_abm,VarID, (/1,1/),(/N_lon_clm, N_lat_clm/), int_grid) ; VERIFY_(STATUS) + call RegridRaster (int_grid, abm_grid) + + status = NF_INQ_VARID (ncid_gdp,'gdp',VarID) ; VERIFY_(STATUS) + status = NF_GET_VARA_REAL (ncid_gdp,VarID, (/1,1/),(/N_lon_clm, N_lat_clm/), data_grid) ; VERIFY_(STATUS) + call RegridRasterReal(data_grid, gdp_grid) + + status = NF_INQ_VARID (ncid_peatf,'peatf',VarID) ; VERIFY_(STATUS) + status = NF_GET_VARA_REAL (ncid_peatf,VarID, (/1,1/),(/N_lon_clm, N_lat_clm/), data_grid) ; VERIFY_(STATUS) + call RegridRasterReal(data_grid, peatf_grid) + + status = NF_CLOSE(ncid_hdm ) + status = NF_CLOSE(ncid_abm ) + status = NF_CLOSE(ncid_gdp ) + status = NF_CLOSE(ncid_peatf) + + ! Grid to tile + ! ------------ + + allocate (hdm (1:NTILES)) + allocate (abm (1:NTILES)) + allocate (gdp (1:NTILES)) + allocate (peatf (1:NTILES)) + allocate (count_pix (1:NTILES, 1:4)) + + hdm = 0. + abm = 0. + gdp = 0. + peatf = 0. + count_pix = 0. + + do j = 1,nr + do i = 1, nc + if((tile_id(i,j).gt.0).and.(tile_id(i,j).le.NTILES)) then + + ! peatf 0. < 1. + if((peatf_grid(i,j) >= 0.).and.(peatf_grid(i,j) <= 1.)) then + peatf (tile_id(i,j)) = peatf (tile_id(i,j)) + peatf_grid(i,j) + count_pix (tile_id(i,j), 1) = count_pix (tile_id(i,j), 1) + 1. + endif + + ! gdp 0. < 300. + if((gdp_grid(i,j) >= 0.).and.(gdp_grid(i,j) <= 300.)) then + gdp (tile_id(i,j)) = gdp (tile_id(i,j)) + gdp_grid(i,j) + count_pix (tile_id(i,j), 2) = count_pix (tile_id(i,j), 2) + 1. + endif + + ! abm 1 < 12 + if((abm_grid(i,j) >= 1).and.(abm_grid(i,j) <= 12)) then + abm (tile_id(i,j)) = abm (tile_id(i,j)) + abm_grid(i,j) + count_pix (tile_id(i,j), 3) = count_pix (tile_id(i,j), 3) + 1. + endif + + ! hdm 0. < 20000. + if((hdm_grid(i,j) >= 0.).and.(hdm_grid(i,j) <= 20000.)) then + hdm (tile_id(i,j)) = hdm (tile_id(i,j)) + hdm_grid(i,j) + count_pix (tile_id(i,j), 4) = count_pix (tile_id(i,j), 4) + 1. + endif + endif + end do + end do - implicit none - - ! producing CLM4.5 fixed parameters : - - - ! 1) Population density /discover/nobackup/fzeng/clm4-to-clm4.5/data/firedata4.5/clmforc.Li_2012_hdm_0.5x0.5_AVHRR_simyr1850-2010_c130401.nc - ! Use 2010 - ! 2) /gpfsm/dnb31/fzeng/clm4-to-clm4.5/data/rawdata4.5 - ! mksrf_abm_0.5x0.5_AVHRR_simyr2000.c130201.nc - ! mksrf_gdp_0.5x0.5_AVHRR_simyr2000.c130228.nc - ! mksrf_peatf_0.5x0.5_AVHRR_simyr2000.c130228.nc - ! one value per tile - ! 3) field capacity one value per tile - - integer, intent (in) :: nc, nr - character(*), intent (in) :: fnameRst - integer , parameter :: N_lon_clm = 720, N_lat_clm = 360 - real, parameter :: dxy_clm = 0.5 - integer :: i,j, status, varid, ncid_hdm, ncid_abm, ncid_gdp, ncid_peatf - integer :: NTILES, tid, cid, ABM_INT, sc_top, sc_com - REAL, ALLOCATABLE, dimension (:) :: hdm, abm, gdp, peatf - REAL, ALLOCATABLE, dimension (:,:) :: hdm_grid, gdp_grid, peatf_grid, data_grid, count_pix - INTEGER, ALLOCATABLE, dimension (:,:) :: tile_id, abm_grid, int_grid - REAL :: hdm_r, gdp_r, peatf_r - character*100 :: fout - real :: & - a_sand,a_clay,a_silt,a_oc,a_bee,a_psis, & - a_poros,a_wp,a_aksat,atau,btau,a_wpsurf,a_porosurf, & - atau_2cm,btau_2cm, field_cap (n_SoilClasses) - - - ! Reading number of tiles - ! ----------------------- - - open (20, file = 'clsm/catchment.def', form = 'formatted', status = 'old', action = 'read') - - read (20, *) NTILES - - close (20, status = 'keep') - - ! READ CLM4.5 source data files and regrid - ! ---------------------------------------- - - call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) - status = NF_OPEN (trim(MAKE_BCS_INPUT_DIR)//'/land/veg/misc/CLM45/clmforc.Li_2012_hdm_0.5x0.5_AVHRR_simyr1850-2010_c130401.nc', NF_NOWRITE, ncid_hdm ) - status = NF_OPEN (trim(MAKE_BCS_INPUT_DIR)//'/land/veg/misc/CLM45/mksrf_abm_0.5x0.5_AVHRR_simyr2000.c130201.nc' , NF_NOWRITE, ncid_abm ) - status = NF_OPEN (trim(MAKE_BCS_INPUT_DIR)//'/land/veg/misc/CLM45/mksrf_gdp_0.5x0.5_AVHRR_simyr2000.c130228.nc' , NF_NOWRITE, ncid_gdp ) - status = NF_OPEN (trim(MAKE_BCS_INPUT_DIR)//'/land/veg/misc/CLM45/mksrf_peatf_0.5x0.5_AVHRR_simyr2000.c130228.nc' , NF_NOWRITE, ncid_peatf) - - allocate (hdm_grid (1:NC,1:NR)) - allocate (abm_grid (1:NC,1:NR)) - allocate (gdp_grid (1:NC,1:NR)) - allocate (peatf_grid (1:NC,1:NR)) - allocate (data_grid (1 : N_lon_clm, 1 : N_lat_clm)) - allocate (int_grid (1 : N_lon_clm, 1 : N_lat_clm)) - - status = NF_INQ_VARID (ncid_hdm,'hdm',VarID) ; VERIFY_(STATUS) - status = NF_GET_VARA_REAL (ncid_hdm,VarID,(/1,1,161/),(/N_lon_clm, N_lat_clm, 1/),data_grid(:,:)) ; VERIFY_(STATUS) - call RegridRasterReal(data_grid, hdm_grid) - - status = NF_INQ_VARID (ncid_abm,'abm',VarID) ; VERIFY_(STATUS) - status = NF_GET_VARA_INT (ncid_abm,VarID, (/1,1/),(/N_lon_clm, N_lat_clm/), int_grid) ; VERIFY_(STATUS) - call RegridRaster (int_grid, abm_grid) - - status = NF_INQ_VARID (ncid_gdp,'gdp',VarID) ; VERIFY_(STATUS) - status = NF_GET_VARA_REAL (ncid_gdp,VarID, (/1,1/),(/N_lon_clm, N_lat_clm/), data_grid) ; VERIFY_(STATUS) - call RegridRasterReal(data_grid, gdp_grid) - - status = NF_INQ_VARID (ncid_peatf,'peatf',VarID) ; VERIFY_(STATUS) - status = NF_GET_VARA_REAL (ncid_peatf,VarID, (/1,1/),(/N_lon_clm, N_lat_clm/), data_grid) ; VERIFY_(STATUS) - call RegridRasterReal(data_grid, peatf_grid) - - status = NF_CLOSE(ncid_hdm ) - status = NF_CLOSE(ncid_abm ) - status = NF_CLOSE(ncid_gdp ) - status = NF_CLOSE(ncid_peatf) - - ! Grid to tile - ! ------------ - - ! Reading tile-id raster file - - allocate(tile_id(1:nc,1:nr)) - - open (10,file=trim(fnameRst)//'.rst',status='old',action='read', & - form='unformatted',convert='little_endian') - - do j=1,nr - read(10)tile_id(:,j) - end do - - close (10,status='keep') - - allocate (hdm (1:NTILES)) - allocate (abm (1:NTILES)) - allocate (gdp (1:NTILES)) - allocate (peatf (1:NTILES)) - allocate (count_pix (1:NTILES, 1:4)) - - hdm = 0. - abm = 0. - gdp = 0. - peatf = 0. - count_pix = 0. - - do j = 1,nr - do i = 1, nc - if((tile_id(i,j).gt.0).and.(tile_id(i,j).le.NTILES)) then - - ! peatf 0. < 1. - if((peatf_grid(i,j) >= 0.).and.(peatf_grid(i,j) <= 1.)) then - peatf (tile_id(i,j)) = peatf (tile_id(i,j)) + peatf_grid(i,j) - count_pix (tile_id(i,j), 1) = count_pix (tile_id(i,j), 1) + 1. - endif - - ! gdp 0. < 300. - if((gdp_grid(i,j) >= 0.).and.(gdp_grid(i,j) <= 300.)) then - gdp (tile_id(i,j)) = gdp (tile_id(i,j)) + gdp_grid(i,j) - count_pix (tile_id(i,j), 2) = count_pix (tile_id(i,j), 2) + 1. - endif - - ! abm 1 < 12 - if((abm_grid(i,j) >= 1).and.(abm_grid(i,j) <= 12)) then - abm (tile_id(i,j)) = abm (tile_id(i,j)) + abm_grid(i,j) - count_pix (tile_id(i,j), 3) = count_pix (tile_id(i,j), 3) + 1. - endif - - ! hdm 0. < 20000. - if((hdm_grid(i,j) >= 0.).and.(hdm_grid(i,j) <= 20000.)) then - hdm (tile_id(i,j)) = hdm (tile_id(i,j)) + hdm_grid(i,j) - count_pix (tile_id(i,j), 4) = count_pix (tile_id(i,j), 4) + 1. - endif - endif - end do - end do - ! Field Capacity ! -------------- open (11, file=trim(MAKE_BCS_INPUT_DIR)//'/land/soil/SOIL-DATA/SoilClasses-SoilHyd-TauParam.dat', form='formatted',status='old', & - action = 'read') + action = 'read') read (11,'(a)')fout do i =1,n_SoilClasses read (11,'(4f7.3,4f8.4,e13.5,2f12.7,2f8.4,4f12.7)')a_sand,a_clay,a_silt,a_oc,a_bee,a_psis, & @@ -5970,1312 +5703,1234 @@ SUBROUTINE CLM45_fixed_parameters (nc,nr,fnameRst) if(count_pix(i,2) > 0.) gdp_r = gdp (i) / count_pix(i,2) if(count_pix(i,3) > 0.) abm_int = NINT(abm (i) / count_pix(i,3)) if(count_pix(i,4) > 0.) hdm_r = hdm (i) / count_pix(i,4) - + write (10,'(2I10, i3, f8.4, f8.2, f10.2, f8.4)' ) tid, cid, abm_int, peatf_r, gdp_r, hdm_r, field_cap(sc_com) end do deallocate (hdm, abm, gdp, peatf) deallocate (hdm_grid, gdp_grid, peatf_grid, data_grid, count_pix) - deallocate (tile_id, abm_grid) + deallocate (abm_grid) close (10, status = 'keep') close (20, status = 'keep') END SUBROUTINE CLM45_fixed_parameters - ! ---------------------------------------------------------------------------------------------------------------------------- + ! ---------------------------------------------------------------------------------------------------------------------------- - SUBROUTINE CLM45_clim_parameters (nc,nr,fnameRst) + SUBROUTINE CLM45_clim_parameters (nc,nr, ntiles, tile_id) - implicit none - ! Producing : lightening frequency HRMC_COM_FR /gpfsm/dnb31/fzeng/clm4-to-clm4.5/data/firedata4.5/LISOTD_HRMC_V2.3.2014.hdf - ! 12 values per tile - integer, intent (in) :: nc, nr - character(*), intent (in) :: fnameRst - integer , parameter :: N_lon_clm = 720, N_lat_clm = 360 - integer :: NTILES, status, varid, ncid - real, dimension (:,:), allocatable :: hrmc_grid, data_grid - REAL, ALLOCATABLE, dimension (:) :: hrmc, count_pix - INTEGER, ALLOCATABLE, dimension (:,:) :: tile_id - integer :: yr,mn,yr1,mn1, k,t,i,j - - - ! Reading number of tiles - ! ----------------------- - - open (20, file = 'clsm/catchment.def', form = 'formatted', status = 'old', action = 'read') - - read (20, *) NTILES - - close (20, status = 'keep') - - ! Grid to tile - ! ------------ - - ! Reading tile-id raster file - - allocate(tile_id(1:nc,1:nr)) - - open (10,file=trim(fnameRst)//'.rst',status='old',action='read', & - form='unformatted',convert='little_endian') - - do j=1,nr - read(10)tile_id(:,j) - end do - - close (10,status='keep') - - ! READ CLM4.5 source data files and regrid - ! ---------------------------------------- - - call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) - status = NF_OPEN (trim(MAKE_BCS_INPUT_DIR)//'/land/veg/misc/CLM45/LISOTD_HRMC_V2.3.2014.nc4', NF_NOWRITE, ncid) - status = NF_INQ_VARID (ncid,'HRMC_COM_FR',VarID) ; VERIFY_(STATUS) - - allocate (hrmc_grid (1:NC,1:NR)) - allocate (data_grid (1 : N_lon_clm, 1 : N_lat_clm)) - allocate (hrmc (1:NTILES)) - allocate (count_pix (1:NTILES)) - - ! writing tile-spaced output - ! -------------------------- - - open (31,file='clsm/lnfm.dat',status='unknown',action='write',form='unformatted', & - convert='little_endian') - - do K=0,13 - yr = (k+11)/12 - mn = mod(k+11,12)+1 - yr1= (k+12)/12 - mn1= mod(k+12,12)+1 - write(31) float((/yr,mn,1,0,0,0,yr1,mn1,1,0,0,0,NTILES,1/)) - hrmc = 0. - count_pix = 0. - t = k - if (t == 0 ) t = 12 - if (t == 13) t = 1 - status = NF_GET_VARA_REAL (ncid,VarID, (/1,1,t/),(/N_lon_clm, N_lat_clm,1/), data_grid) ; VERIFY_(STATUS) - call RegridRasterReal(data_grid, hrmc_grid) - - do j = 1,nr - do i = 1, nc - if((tile_id(i,j).gt.0).and.(tile_id(i,j).le.NTILES)) then - if((hrmc_grid(i,j) >= 0.).and.(hrmc_grid(i,j) <= 1.)) then - hrmc (tile_id(i,j)) = hrmc (tile_id(i,j)) + hrmc_grid(i,j) - count_pix (tile_id(i,j)) = count_pix (tile_id(i,j)) + 1. - endif - endif - end do - end do - - where (count_pix > 0.) hrmc = hrmc /count_pix - write(31) hrmc - end do - - close(31,status='keep') - - END SUBROUTINE CLM45_clim_parameters - -! ---------------------------------------------------------------------------------------------------------------------------- - - SUBROUTINE grid2tile_glass (ncol,nrow,fnameRst,lai_name) -! -! Processing GLASS LAI (AVHRR or MODIS) and creating 8-day climatological data -! - implicit none - integer , parameter :: N_lon_glass = 7200, N_lat_glass = 3600 - integer, intent (in) :: ncol, nrow - real, parameter :: dxy = 1. - integer :: QSize - character(*) :: fnameRst,lai_name - integer :: n,maxcat,i,j,k,ncid,i_highd,j_highd,nx_adj,ny_adj,ierr,nx,ny - integer :: status,iLL,jLL,ix,jx,vid,nc_10,nr_10,n_tslices,d_undef,t, & - time_slice,time_slice_next,yr,mn,dd,yr1,mn1,dd1,i1,i2,tindex1,pfaf1 - character*100 :: fout - character*200 :: fname - character*10 :: string - character*2 :: VV,HH - integer, allocatable, target, dimension (:,:) :: net_data1 - real, pointer, dimension (:,:) :: QSub - real, pointer, dimension (:,:) :: subset - REAL, ALLOCATABLE, dimension (:):: vec_lai, count_lai,tile_lon, tile_lat & - , x, y !, distance - real, allocatable, target, dimension (:,:) :: lai_grid, data_grid, data_grid2 - INTEGER ::imn,imx,jmn,jmx,mval,d1,d2,l, VarID - character(len=4), dimension (:), allocatable :: MMDD, MMDD_next - logical :: regrid - REAL :: sf, dum,dist_save,tile_distance,minlat,maxlat,minlon,maxlon - logical :: first_entry = .true. - type (date_time_type) :: date_time_new,bf_lai_time, & - af_lai_time, date_time_this - integer, dimension (:,:), allocatable, target :: tile_id - integer :: tileid_tile - character*3 :: ddd - -! Reading rst file -!----------------- - open (10,file=trim(fnameRst)//'.rst',status='old',action='read', & - form='unformatted',convert='little_endian') - allocate (tile_id (1:ncol,1:nrow)) - - do j=1,nrow - read(10)tile_id(:,j) - end do - close (10,status='keep') + implicit none + ! Producing : lightening frequency HRMC_COM_FR /gpfsm/dnb31/fzeng/clm4-to-clm4.5/data/firedata4.5/LISOTD_HRMC_V2.3.2014.hdf + ! 12 values per tile + integer, intent (in) :: nc, nr, ntiles + INTEGER, intent (in) :: tile_id(:,:) -! -! Reading number of cathment-tiles from catchment.def file -!_________________________________________________________ -! - fname='clsm/catchment.def' - open (10,file=fname,status='old',action='read',form='formatted') - read(10,*) maxcat - allocate (tile_lon(1:maxcat)) - allocate (tile_lat(1:maxcat)) - - do n = 1, maxcat - read (10,*) tindex1,pfaf1,minlon,maxlon,minlat,maxlat - tile_lon(n) = (minlon + maxlon)/2. - tile_lat(n) = (minlat + maxlat)/2. - end do - close (10,status='keep') - - call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) - fname =trim(MAKE_BCS_INPUT_DIR)//'/land/veg/lai_grn/v2/MODIS_8-DayClim/MODIS_lai_clim.H11V13.nc' - status = NF_OPEN(trim(fname),NF_NOWRITE, ncid); VERIFY_(STATUS) - status = NF_INQ_DIM (ncid,3,string, n_tslices); VERIFY_(STATUS) - allocate (MMDD (0: n_tslices + 1)) - allocate (MMDD_next (0: n_tslices + 1)) - - status = NF_GET_VARA_text(ncid, 3,(/1,1/),(/4,n_tslices/),MMDD(1:n_tslices)); VERIFY_(STATUS) - status = NF_CLOSE(ncid); VERIFY_(STATUS) - - mmdd(0) = mmdd(n_tslices) - mmdd(n_tslices + 1)= mmdd(1) - - mmdd_next(0:n_tslices - 1) = mmdd(1:n_tslices) - mmdd_next(n_tslices: n_tslices + 1) = mmdd (1:2) - - ! writing GLASS LAI - ! - open (31,file='clsm/lai.dat', & - form='unformatted',status='unknown',convert='little_endian') - - allocate (vec_lai (maxcat)) - allocate (count_lai (1:maxcat)) - - nx = nint (360./dxy) - ny = nint (180./dxy) - allocate (x(1:nx)) - allocate (y(1:ny)) - - FORALL (i = 1:nx) x(i) = -180. + dxy/2. + (i-1)*dxy - FORALL (i = 1:ny) y(i) = -90. + dxy/2. + (i-1)*dxy - - allocate (lai_grid (1 : nx, 1 : ny)) - - QSize = nint(dxy*N_lon_glass/360.) - allocate (QSub (1:QSize,1:QSize)) - allocate (net_data1 (1 : N_lon_glass, 1 : N_lat_glass)) - allocate (data_grid (1:NCOL,1:NROW)) - allocate (data_grid2 (1 : N_lon_glass, 1 : N_lat_glass)) - - do t =0,n_tslices+1 - - time_slice = t - yr = 1 - yr1= 1 - if(t == 0) then - time_slice = n_tslices - yr = 1 - 1 - endif - - if(t >= n_tslices) then - yr1 = 1 + 1 - if(t ==n_tslices + 1) then - time_slice = 1 - yr = 1 + 1 - endif - endif - - read(mmdd(t),'(i2.2,i2.2)') mn,dd - read(mmdd_next(t),'(i2.2,i2.2)') mn1,dd1 - - date_time_this%year = 2001 - date_time_this%month = mn - date_time_this%day = dd - date_time_this%hour = 0 - date_time_this%min = 0 - date_time_this%sec = 0 - call get_dofyr_pentad(date_time_this) - - write (ddd,'(i3.3)') date_time_this%dofyr - - ! Reading Interpolation or aggregation on to catchment-tiles - - vec_lai = -9999. - count_lai = 0. - lai_grid = -9999 - - status = NF_OPEN (trim(MAKE_BCS_INPUT_DIR)//'/land/veg/lai_grn/v4/'//trim(lai_name)//ddd//'.nc4', NF_NOWRITE, ncid) ; VERIFY_(STATUS) - status = NF_INQ_VARID (ncid,'LAI',VarID) ; VERIFY_(STATUS) - status = NF_GET_VARA_INT(ncid,VarID, (/1,1/),(/N_lon_glass, N_lat_glass/), net_data1) ; VERIFY_(STATUS) - - call RegridRasterReal(0.01*real(net_data1), data_grid) - data_grid2 = 0.01*real(net_data1) - - status = NF_CLOSE(ncid) - - do j = 1,nrow - do i = 1, ncol - if((tile_id(i,j).gt.0).and.(tile_id(i,j).le.MAXCAT)) then - if((data_grid(i,j) >= 0.).and.(data_grid(i,j) <= 10.)) then - if(vec_lai(tile_id(i,j)) == -9999.) vec_lai(tile_id(i,j)) = 0. - vec_lai (tile_id(i,j)) = vec_lai (tile_id(i,j)) + data_grid(i,j) - count_lai (tile_id(i,j)) = count_lai (tile_id(i,j)) + 1. - endif - endif - end do - end do - - write(31) float((/yr,mn,dd,0,0,0,yr1,mn1,dd1,0,0,0,maxcat,1/)) - - where (count_lai > 0.) vec_lai = vec_lai/count_lai - - ! After experimenting with few finer methods, in order to reduce the time taken by the gap filling procedure, - ! creating a 0.25-degree gridded data set from finer LAI data and use it for filling the gaps seems the most practical/manageble method. - !--------------------------------------------------------------------------------------------------------------------------------------- - - iLL = 1 - jLL = 1 - do j = 1, N_lat_glass/QSize - do i = 1, N_lon_glass/QSize - QSub => data_grid2((i-1)*QSize+2-iLL :i*QSize-iLL+1, (j-1)*QSize+2-jLL :j*QSize-jLL+1) - if(minval (QSub) <= 10.) lai_grid(i,j) = sum(QSub, QSub<=10.)/(max(1,count(QSub<=10.))) - enddo - enddo - - NULLIFY (QSub) - -! Filling gaps -!------------- - DO n =1,maxcat - if(count_lai(n)==0.) then - - DO i = 1,nx - 1 - if ((tile_lon(n) >= x(i)).and.(tile_lon(n) < x(i+1))) ix = i - end do - DO i = 1,ny -1 - if ((tile_lat(n) >= y(i)).and.(tile_lat(n) < y(i+1))) jx = i - end do - - l = 1 - do - imx=ix + l - imn=ix - l - jmn=jx - l - jmx=jx + l - imn=MAX(imn,1) - jmn=MAX(jmn,1) - imx=MIN(imx,nx) - jmx=MIN(jmx,ny) - d1=imx-imn+1 - d2=jmx-jmn+1 - subset => lai_grid(imn: imx,jmn:jmx) - - if(maxval(subset) > 0.) then - vec_lai (n) = sum(subset, subset>0.)/(max(1,count(subset>0.))) - exit - endif - l = l + 1 - NULLIFY (subset) - end do + integer , parameter :: N_lon_clm = 720, N_lat_clm = 360 + integer :: status, varid, ncid + real, dimension (:,:), allocatable :: hrmc_grid, data_grid + REAL, ALLOCATABLE, dimension (:) :: hrmc, count_pix + integer :: yr,mn,yr1,mn1, k,t,i,j + + + ! Grid to tile + ! ------------ + + + ! READ CLM4.5 source data files and regrid + ! ---------------------------------------- + + call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) + status = NF_OPEN (trim(MAKE_BCS_INPUT_DIR)//'/land/veg/misc/CLM45/LISOTD_HRMC_V2.3.2014.nc4', NF_NOWRITE, ncid) + status = NF_INQ_VARID (ncid,'HRMC_COM_FR',VarID) ; VERIFY_(STATUS) + + allocate (hrmc_grid (1:NC,1:NR)) + allocate (data_grid (1 : N_lon_clm, 1 : N_lat_clm)) + allocate (hrmc (1:NTILES)) + allocate (count_pix (1:NTILES)) + + ! writing tile-spaced output + ! -------------------------- + + open (31,file='clsm/lnfm.dat',status='unknown',action='write',form='unformatted', & + convert='little_endian') + + do K=0,13 + yr = (k+11)/12 + mn = mod(k+11,12)+1 + yr1= (k+12)/12 + mn1= mod(k+12,12)+1 + write(31) float((/yr,mn,1,0,0,0,yr1,mn1,1,0,0,0,NTILES,1/)) + hrmc = 0. + count_pix = 0. + t = k + if (t == 0 ) t = 12 + if (t == 13) t = 1 + status = NF_GET_VARA_REAL (ncid,VarID, (/1,1,t/),(/N_lon_clm, N_lat_clm,1/), data_grid) ; VERIFY_(STATUS) + call RegridRasterReal(data_grid, hrmc_grid) + + do j = 1,nr + do i = 1, nc + if((tile_id(i,j).gt.0).and.(tile_id(i,j).le.NTILES)) then + if((hrmc_grid(i,j) >= 0.).and.(hrmc_grid(i,j) <= 1.)) then + hrmc (tile_id(i,j)) = hrmc (tile_id(i,j)) + hrmc_grid(i,j) + count_pix (tile_id(i,j)) = count_pix (tile_id(i,j)) + 1. + endif endif - END DO - write(31) vec_lai(:) + end do end do - close(31,status='keep') - - deallocate (net_data1, tile_id) - deallocate (count_lai) - deallocate (vec_lai) - deallocate (tile_lat,tile_lon) - END SUBROUTINE grid2tile_glass + where (count_pix > 0.) hrmc = hrmc /count_pix + write(31) hrmc + end do - ! ---------------------------------------------------------------------------------------------------------------------------- + close(31,status='keep') - SUBROUTINE gimms_clim_ndvi (nc,nr,fnameRst) - - implicit none - ! Producing : GIMMS NDVI 15-day climatology from 5 arcmin data - ! 24 values per tile - integer, intent (in) :: nc, nr - character(*), intent (in) :: fnameRst - integer , parameter :: N_lon_gimms = 4320, N_lat_gimms = 2160 - integer :: NTILES, status, varid, ncid1, ncid2,ncid - real, dimension (:,:), allocatable :: ndvi_grid, data_grid - integer, dimension (:,:), allocatable ::data_grid2 - REAL, ALLOCATABLE, dimension (:) :: ndvi, count_pix - INTEGER, ALLOCATABLE, dimension (:,:) :: tile_id - integer :: yr,mn,yr1,mn1, k,t,i,j,l - integer, parameter :: scale_fac = 10000 - real, parameter :: val_min = -0.3, val_max = 1. - - - ! Reading number of tiles - ! ----------------------- - - open (20, file = 'clsm/catchment.def', form = 'formatted', status = 'old', action = 'read') - - read (20, *) NTILES - - close (20, status = 'keep') - - ! Grid to tile - ! ------------ - - ! Reading tile-id raster file - - allocate(tile_id(1:nc,1:nr)) - - open (10,file=trim(fnameRst)//'.rst',status='old',action='read', & - form='unformatted',convert='little_endian') - - do j=1,nr - read(10)tile_id(:,j) - end do - - close (10,status='keep') - - ! READ GIMMS NDVI source data files and regrid - ! ---------------------------------------- - - call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) - status = NF_OPEN (trim(MAKE_BCS_INPUT_DIR)//'/land/veg/ndvi/v1/ndvi3g_geo_v1_YYYY_0106.nc4', NF_NOWRITE, ncid1) ; VERIFY_(STATUS) - status = NF_OPEN (trim(MAKE_BCS_INPUT_DIR)//'/land/veg/ndvi/v1/ndvi3g_geo_v1_YYYY_0712.nc4', NF_NOWRITE, ncid2) ; VERIFY_(STATUS) - status = NF_INQ_VARID (ncid2,'ndvi',VarID) ; VERIFY_(STATUS) - - allocate (ndvi_grid (1:NC,1:NR)) - allocate (data_grid (1 : N_lon_gimms, 1 : N_lat_gimms)) - allocate (data_grid2(1 : N_lon_gimms, 1 : N_lat_gimms)) - allocate (ndvi (1:NTILES)) - allocate (count_pix (1:NTILES)) - - ! writing tile-spaced output - ! -------------------------- - - open (31,file='clsm/ndvi.dat',status='unknown',action='write',form='unformatted', & - convert='little_endian') - - do K=0,13 - yr = (k+11)/12 - mn = mod(k+11,12)+1 - yr1= (k+12)/12 - mn1= mod(k+12,12)+1 - - ndvi = 0. - count_pix = 0. - t = k - if (k == 0 ) then - t = 12 - ncid = ncid2 - write(31) float((/yr,mn,16,0,0,0,yr1,mn1,1,0,0,0,NTILES,1/)) - - status = NF_GET_VARA_INT (ncid,VarID, (/1,1,t/),(/N_lon_gimms, N_lat_gimms,1/), data_grid2) ; VERIFY_(STATUS) - - do j = 1, N_lat_gimms - data_grid (:,j) = data_grid2 (:,N_lat_gimms - (j-1)) / real(scale_fac) - end do - - call RegridRasterReal(data_grid, ndvi_grid) - - do j = 1,nr - do i = 1, nc - if((tile_id(i,j).gt.0).and.(tile_id(i,j).le.NTILES)) then - if((ndvi_grid(i,j) >= val_min).and.(ndvi_grid(i,j) <= val_max)) then - ndvi (tile_id(i,j)) = ndvi (tile_id(i,j)) + ndvi_grid(i,j) - count_pix (tile_id(i,j)) = count_pix (tile_id(i,j)) + 1. - endif - endif - end do - end do - - where (count_pix > 0.) ndvi = ndvi /count_pix - write(31) ndvi - - elseif (k == 13) then - - t = 1 - ncid = ncid1 - write(31) float((/yr,mn,1,0,0,0,yr,mn,16,0,0,0,NTILES,1/)) - - status = NF_GET_VARA_INT (ncid,VarID, (/1,1,t/),(/N_lon_gimms, N_lat_gimms,1/), data_grid2) ; VERIFY_(STATUS) - - do j = 1, N_lat_gimms - data_grid (:,j) = data_grid2 (:,N_lat_gimms - (j-1)) / real(scale_fac) - end do - - call RegridRasterReal(data_grid, ndvi_grid) - - do j = 1,nr - do i = 1, nc - if((tile_id(i,j).gt.0).and.(tile_id(i,j).le.NTILES)) then - if((ndvi_grid(i,j) >= val_min).and.(ndvi_grid(i,j) <= val_max)) then - ndvi (tile_id(i,j)) = ndvi (tile_id(i,j)) + ndvi_grid(i,j) - count_pix (tile_id(i,j)) = count_pix (tile_id(i,j)) + 1. - endif - endif - end do - end do - - where (count_pix > 0.) ndvi = ndvi /count_pix - write(31) ndvi - - else - - do l = 1, 0 , -1 - t = k*2 - l - if (k <= 6) ncid = ncid1 - if (k >= 7) ncid = ncid2 - if (k >= 7) t = t - 12 - if(l == 1) write(31) float((/yr,mn,1,0,0,0,yr,mn,16,0,0,0,NTILES,1/)) - if(l == 0) write(31) float((/yr,mn,16,0,0,0,yr1,mn1,1,0,0,0,NTILES,1/)) - - ndvi = 0. - count_pix = 0. - - status = NF_GET_VARA_INT (ncid,VarID, (/1,1,t/),(/N_lon_gimms, N_lat_gimms,1/), data_grid2) ; VERIFY_(STATUS) - - do j = 1, N_lat_gimms - data_grid (:,j) = data_grid2 (:,N_lat_gimms - (j-1)) / real(scale_fac) - end do - - call RegridRasterReal(data_grid, ndvi_grid) - - do j = 1,nr - do i = 1, nc - if((tile_id(i,j).gt.0).and.(tile_id(i,j).le.NTILES)) then - if((ndvi_grid(i,j) >= val_min).and.(ndvi_grid(i,j) <= val_max)) then - ndvi (tile_id(i,j)) = ndvi (tile_id(i,j)) + ndvi_grid(i,j) - count_pix (tile_id(i,j)) = count_pix (tile_id(i,j)) + 1. - endif - endif - end do - end do - - where (count_pix > 0.) ndvi = ndvi /count_pix - write(31) ndvi - - end do - endif - end do - - close(31,status='keep') - - END SUBROUTINE gimms_clim_ndvi - - ! -------------------------------------------------------------------------- - - SUBROUTINE open_landparam_nc4_files(N_tile,process_snow_albedo) + END SUBROUTINE CLM45_clim_parameters - implicit none - integer :: NCCatOUTID, NCCatCNOUTID, NCVegOUTID - integer :: STATUS, CellID1, CellID2, CellID3, SubID - integer, intent (in) :: N_tile - logical, intent (in) :: process_snow_albedo - integer, dimension(8) :: date_time_values - character (22) :: time_stamp - character (100) :: MYNAME - - status = NF_CREATE ('clsm/catch_params.nc4' , NF_NETCDF4, NCCatOUTID ) ; VERIFY_(STATUS) - status = NF_CREATE ('clsm/catchcn_params.nc4', NF_NETCDF4, NCCatCNOUTID) ; VERIFY_(STATUS) - status = NF_CREATE ('clsm/vegdyn.data' , NF_NETCDF4, NCVegOUTID ) ; VERIFY_(STATUS) - - status = NF_DEF_DIM(NCCatOUTID , 'tile' , N_tile, CellID1) - status = NF_DEF_DIM(NCCatCNOUTID, 'tile' , N_tile, CellID2) - status = NF_DEF_DIM(NCVegOUTID , 'tile' , N_tile, CellID3) - status = NF_DEF_DIM(NCCatCNOUTID, 'unknown_dim2' , 4, SubID) - - call DEF_VAR ( NCCatOUTID, CellID1,'OLD_ITY' ,'vegetation_type.' , '1' ) - call DEF_VAR ( NCCatOUTID, CellID1,'ARA1' ,'shape_param_1' ,'m+2 kg-1' ) - call DEF_VAR ( NCCatOUTID, CellID1,'ARA2' ,'shape_param_2' ,'1' ) - call DEF_VAR ( NCCatOUTID, CellID1,'ARA3' ,'shape_param_3' ,'m+2 kg-1' ) - call DEF_VAR ( NCCatOUTID, CellID1,'ARA4' ,'shape_param_4' ,'1' ) - call DEF_VAR ( NCCatOUTID, CellID1,'ARS1' ,'wetness_param_1' ,'m+2 kg-1' ) - call DEF_VAR ( NCCatOUTID, CellID1,'ARS2' ,'wetness_param_2' ,'m+2 kg-1' ) - call DEF_VAR ( NCCatOUTID, CellID1,'ARS3' ,'wetness_param_3' ,'m+4 kg-2' ) - call DEF_VAR ( NCCatOUTID, CellID1,'ARW1' ,'min_theta_param_1' ,'m+2 kg-1' ) - call DEF_VAR ( NCCatOUTID, CellID1,'ARW2' ,'min_theta_param_2' ,'m+2 kg-1' ) - call DEF_VAR ( NCCatOUTID, CellID1,'ARW3' ,'min_theta_param_3' ,'m+4 kg-2' ) - call DEF_VAR ( NCCatOUTID, CellID1,'ARW4' ,'min_theta_param_4' ,'1' ) - call DEF_VAR ( NCCatOUTID, CellID1,'ATAU2' ,'2cm_water_transfer_param_5' ,'1' ) - call DEF_VAR ( NCCatOUTID, CellID1,'ATAU5' ,'5cm_water_transfer_param_5' ,'1' ) - call DEF_VAR ( NCCatOUTID, CellID1,'BEE' ,'clapp_hornberger_b' ,'1' ) - call DEF_VAR ( NCCatOUTID, CellID1,'BF1' ,'topo_baseflow_param_1' ,'kg m-4' ) - call DEF_VAR ( NCCatOUTID, CellID1,'BF2' ,'topo_baseflow_param_2' ,'m' ) - call DEF_VAR ( NCCatOUTID, CellID1,'BF3' ,'topo_baseflow_param_3' ,'log(m)' ) - call DEF_VAR ( NCCatOUTID, CellID1,'BTAU2' ,'2cm_water_transfer_param_6' ,'1' ) - call DEF_VAR ( NCCatOUTID, CellID1,'BTAU5' ,'5cm_water_transfer_param_6' ,'1' ) - call DEF_VAR ( NCCatOUTID, CellID1,'COND' ,'sfc_sat_hydraulic_conduct' ,'m s-1' ) - call DEF_VAR ( NCCatOUTID, CellID1,'GNU' ,'vertical_transmissivity' ,'m-1' ) - call DEF_VAR ( NCCatOUTID, CellID1,'POROS' ,'soil_porosity' ,'1' ) - call DEF_VAR ( NCCatOUTID, CellID1,'PSIS' ,'saturated_matric_potential' ,'m' ) - call DEF_VAR ( NCCatOUTID, CellID1,'TSA1' ,'water_transfer_param_1' ,'1' ) - call DEF_VAR ( NCCatOUTID, CellID1,'TSA2' ,'water_transfer_param_2' ,'1' ) - call DEF_VAR ( NCCatOUTID, CellID1,'TSB1' ,'water_transfer_param_3' ,'1' ) - call DEF_VAR ( NCCatOUTID, CellID1,'TSB2' ,'water_transfer_param_4' ,'1' ) - call DEF_VAR ( NCCatOUTID, CellID1,'WPWET' ,'wetness_at_wilting_point' ,'1' ) - call DEF_VAR ( NCCatOUTID, CellID1,'DP2BR' ,'depth_to_bedrock' ,'mm' ) - if (process_snow_albedo) & - call DEF_VAR ( NCCatOUTID, CellID1,'SNOWALB' ,'snow_albedo' ,'1' ) - - call DEF_VAR ( NCVegOUTID, CellID3,'ITY' ,'vegetation_type' ,'1' ) - call DEF_VAR ( NCVegOUTID, CellID3,'Z2CH' ,'vegetation_height' ,'m' ) - call DEF_VAR ( NCVegOUTID, CellID3,'ASCATZ0' ,'ASCAT_roughness_length' ,'m' ) - - call DEF_VAR ( NCCatCNOUTID, CellID2,'BGALBNF' ,'MODIS soil albedo nir dif' ,'1' ) - call DEF_VAR ( NCCatCNOUTID, CellID2,'BGALBNR' ,'MODIS soil albedo nir dir' ,'1' ) - call DEF_VAR ( NCCatCNOUTID, CellID2,'BGALBVF' ,'MODIS soil albedo vis dif' ,'1' ) - call DEF_VAR ( NCCatCNOUTID, CellID2,'BGALBVR' ,'MODIS soil albedo vis dir' ,'1' ) - call DEF_VAR ( NCCatCNOUTID, CellID2,'T2_M' ,'Clim 2m temperature (MERRA2)' ,'K' ) - call DEF_VAR ( NCCatCNOUTID, CellID2,'T2_S' ,'Clim 2m temperature (Sheffield)' ,'K' ) - call DEF_VAR ( NCCatCNOUTID, CellID2,'NDEP' ,'CLM_nitrogen_deposition' ,'g m-2 s-1') - call DEF_VAR ( NCCatCNOUTID, CellID2,'FVG' ,'vegetation_fraction' ,'1' ,SubID = SubID) - call DEF_VAR ( NCCatCNOUTID, CellID2,'ITY' ,'vegetation_type' ,'1' ,SubID = SubID) - - call date_and_time(VALUES=date_time_values) - - write (time_stamp,'(i4.4,a1,i2.2,a1,i2.2,1x,a2,1x,i2.2,a1,i2.2,a1,i2.2)') & - date_time_values(1),'-',date_time_values(2),'-',date_time_values(3),'at', & - date_time_values(5),':',date_time_values(6),':',date_time_values(7) -! call execute_command_line('setenv MYNAME `finger $USER | cut -d: -f3 | head -1`') -! call sleep (5) - call get_environment_variable ("USER" ,MYNAME ) - status = NF_PUT_ATT_TEXT(NCCatOUTID , NF_GLOBAL, 'CreatedBy', LEN_TRIM(MYNAME), trim(MYNAME) ) - status = NF_PUT_ATT_TEXT(NCCatOUTID , NF_GLOBAL, 'Date' , LEN_TRIM(time_stamp),trim(time_stamp)) - status = NF_PUT_ATT_TEXT(NCVegOUTID , NF_GLOBAL, 'CreatedBy', LEN_TRIM(MYNAME), trim(MYNAME) ) - status = NF_PUT_ATT_TEXT(NCVegOUTID , NF_GLOBAL, 'Date' , LEN_TRIM(time_stamp),trim(time_stamp)) - status = NF_PUT_ATT_TEXT(NCCatCNOUTID, NF_GLOBAL, 'CreatedBy', LEN_TRIM(MYNAME), trim(MYNAME) ) - status = NF_PUT_ATT_TEXT(NCCatCNOUTID, NF_GLOBAL, 'Date' , LEN_TRIM(time_stamp),trim(time_stamp)) - - status = NF_ENDDEF(NCCatOUTID ) - status = NF_ENDDEF(NCVegOUTID ) - status = NF_ENDDEF(NCCatCNOUTID) - - status = NF_CLOSE (NCCatOUTID ) - status = NF_CLOSE (NCVegOUTID ) - status = NF_CLOSE (NCCatCNOUTID) - - contains + ! ---------------------------------------------------------------------------------------------------------------------------- + + SUBROUTINE grid2tile_glass (ncol,nrow, tile_id,lai_name, n_land, tile_lon, tile_lat) + ! + ! Processing GLASS LAI (AVHRR or MODIS) and creating 8-day climatological data + ! + implicit none + integer, intent(in) :: ncol, nrow + integer, target, intent(in) :: tile_id(:,:) + character(*), intent(in) :: lai_name + integer, intent(in) :: n_land + real, intent(in) :: tile_lon(:), tile_lat(:) + + integer , parameter :: N_lon_glass = 7200, N_lat_glass = 3600 + real, parameter :: dxy = 1. + integer :: QSize + integer :: n,i,j,k,ncid,i_highd,j_highd,nx_adj,ny_adj,ierr,nx,ny + integer :: status,iLL,jLL,ix,jx,vid,nc_10,nr_10,n_tslices,d_undef,t, & + time_slice,time_slice_next,yr,mn,dd,yr1,mn1,dd1,i1,i2,tindex1,pfaf1 + character*100 :: fout + character*200 :: fname + character*10 :: string + character*2 :: VV,HH + integer, allocatable, target, dimension (:,:) :: net_data1 + real, pointer, dimension (:,:) :: QSub + real, pointer, dimension (:,:) :: subset + REAL, ALLOCATABLE, dimension (:):: vec_lai, count_lai, x, y !, distance + real, allocatable, target, dimension (:,:) :: lai_grid, data_grid, data_grid2 + INTEGER ::imn,imx,jmn,jmx,mval,d1,d2,l, VarID + character(len=4), dimension (:), allocatable :: MMDD, MMDD_next + logical :: regrid + REAL :: sf, dum,dist_save,tile_distance,minlat,maxlat,minlon,maxlon + logical :: first_entry = .true. + type (date_time_type) :: date_time_new,bf_lai_time, & + af_lai_time, date_time_this + integer :: tileid_tile + character*3 :: ddd + + call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) + fname =trim(MAKE_BCS_INPUT_DIR)//'/land/veg/lai_grn/v2/MODIS_8-DayClim/MODIS_lai_clim.H11V13.nc' + status = NF_OPEN(trim(fname),NF_NOWRITE, ncid); VERIFY_(STATUS) + status = NF_INQ_DIM (ncid,3,string, n_tslices); VERIFY_(STATUS) + allocate (MMDD (0: n_tslices + 1)) + allocate (MMDD_next (0: n_tslices + 1)) + + status = NF_GET_VARA_text(ncid, 3,(/1,1/),(/4,n_tslices/),MMDD(1:n_tslices)); VERIFY_(STATUS) + status = NF_CLOSE(ncid); VERIFY_(STATUS) + + mmdd(0) = mmdd(n_tslices) + mmdd(n_tslices + 1)= mmdd(1) + + mmdd_next(0:n_tslices - 1) = mmdd(1:n_tslices) + mmdd_next(n_tslices: n_tslices + 1) = mmdd (1:2) + + ! writing GLASS LAI + ! + open (31,file='clsm/lai.dat', & + form='unformatted',status='unknown',convert='little_endian') + + allocate (vec_lai (n_land)) + allocate (count_lai (1:n_land)) + + nx = nint (360./dxy) + ny = nint (180./dxy) + allocate (x(1:nx)) + allocate (y(1:ny)) + + FORALL (i = 1:nx) x(i) = -180. + dxy/2. + (i-1)*dxy + FORALL (i = 1:ny) y(i) = -90. + dxy/2. + (i-1)*dxy + + allocate (lai_grid (1 : nx, 1 : ny)) + + QSize = nint(dxy*N_lon_glass/360.) + allocate (QSub (1:QSize,1:QSize)) + allocate (net_data1 (1 : N_lon_glass, 1 : N_lat_glass)) + allocate (data_grid (1:NCOL,1:NROW)) + allocate (data_grid2 (1 : N_lon_glass, 1 : N_lat_glass)) + + do t =0,n_tslices+1 + + time_slice = t + yr = 1 + yr1= 1 + if(t == 0) then + time_slice = n_tslices + yr = 1 - 1 + endif + + if(t >= n_tslices) then + yr1 = 1 + 1 + if(t ==n_tslices + 1) then + time_slice = 1 + yr = 1 + 1 + endif + endif + + read(mmdd(t),'(i2.2,i2.2)') mn,dd + read(mmdd_next(t),'(i2.2,i2.2)') mn1,dd1 + + date_time_this%year = 2001 + date_time_this%month = mn + date_time_this%day = dd + date_time_this%hour = 0 + date_time_this%min = 0 + date_time_this%sec = 0 + call get_dofyr_pentad(date_time_this) + + write (ddd,'(i3.3)') date_time_this%dofyr + + ! Reading Interpolation or aggregation on to catchment-tiles + + vec_lai = -9999. + count_lai = 0. + lai_grid = -9999 + + status = NF_OPEN (trim(MAKE_BCS_INPUT_DIR)//'/land/veg/lai_grn/v4/'//trim(lai_name)//ddd//'.nc4', NF_NOWRITE, ncid) ; VERIFY_(STATUS) + status = NF_INQ_VARID (ncid,'LAI',VarID) ; VERIFY_(STATUS) + status = NF_GET_VARA_INT(ncid,VarID, (/1,1/),(/N_lon_glass, N_lat_glass/), net_data1) ; VERIFY_(STATUS) + + call RegridRasterReal(0.01*real(net_data1), data_grid) + data_grid2 = 0.01*real(net_data1) + + status = NF_CLOSE(ncid) + + do j = 1,nrow + do i = 1, ncol + if((tile_id(i,j).gt.0).and.(tile_id(i,j).le.n_land)) then + if((data_grid(i,j) >= 0.).and.(data_grid(i,j) <= 10.)) then + if(vec_lai(tile_id(i,j)) == -9999.) vec_lai(tile_id(i,j)) = 0. + vec_lai (tile_id(i,j)) = vec_lai (tile_id(i,j)) + data_grid(i,j) + count_lai (tile_id(i,j)) = count_lai (tile_id(i,j)) + 1. + endif + endif + end do + end do + + write(31) float((/yr,mn,dd,0,0,0,yr1,mn1,dd1,0,0,0,n_land,1/)) + + where (count_lai > 0.) vec_lai = vec_lai/count_lai + + ! After experimenting with few finer methods, in order to reduce the time taken by the gap filling procedure, + ! creating a 0.25-degree gridded data set from finer LAI data and use it for filling the gaps seems the most practical/manageble method. + !--------------------------------------------------------------------------------------------------------------------------------------- + + iLL = 1 + jLL = 1 + do j = 1, N_lat_glass/QSize + do i = 1, N_lon_glass/QSize + QSub => data_grid2((i-1)*QSize+2-iLL :i*QSize-iLL+1, (j-1)*QSize+2-jLL :j*QSize-jLL+1) + if(minval (QSub) <= 10.) lai_grid(i,j) = sum(QSub, QSub<=10.)/(max(1,count(QSub<=10.))) + enddo + enddo + + NULLIFY (QSub) + + ! Filling gaps + !------------- + DO n =1,n_land + if(count_lai(n)==0.) then + + DO i = 1,nx - 1 + if ((tile_lon(n) >= x(i)).and.(tile_lon(n) < x(i+1))) ix = i + end do + DO i = 1,ny -1 + if ((tile_lat(n) >= y(i)).and.(tile_lat(n) < y(i+1))) jx = i + end do + + l = 1 + do + imx=ix + l + imn=ix - l + jmn=jx - l + jmx=jx + l + imn=MAX(imn,1) + jmn=MAX(jmn,1) + imx=MIN(imx,nx) + jmx=MIN(jmx,ny) + d1=imx-imn+1 + d2=jmx-jmn+1 + subset => lai_grid(imn: imx,jmn:jmx) + + if(maxval(subset) > 0.) then + vec_lai (n) = sum(subset, subset>0.)/(max(1,count(subset>0.))) + exit + endif + l = l + 1 + NULLIFY (subset) + end do + endif + END DO + write(31) vec_lai(:) + end do + close(31,status='keep') + + deallocate (net_data1) + deallocate (count_lai) + deallocate (vec_lai) + deallocate (data_grid) + deallocate (data_grid2) + + END SUBROUTINE grid2tile_glass + + ! ---------------------------------------------------------------------------------------------------------------------------- - SUBROUTINE DEF_VAR (NCFID, CellID, VarName, long_name, units, SubID) - - implicit none - integer, intent (in) :: NCFID, CellID - character (*), intent (in) :: VarName, long_name, units - integer, intent (in), optional :: SubID - integer :: STATUS, VID + SUBROUTINE gimms_clim_ndvi (nc,nr, ntiles, tile_id) + + implicit none + ! Producing : GIMMS NDVI 15-day climatology from 5 arcmin data + ! 24 values per tile + integer, intent (in) :: nc, nr, ntiles + INTEGER, intent(in) :: tile_id(:,:) + + integer , parameter :: N_lon_gimms = 4320, N_lat_gimms = 2160 + integer :: status, varid, ncid1, ncid2,ncid + real, dimension (:,:), allocatable :: ndvi_grid, data_grid + integer, dimension (:,:), allocatable ::data_grid2 + REAL, ALLOCATABLE, dimension (:) :: ndvi, count_pix + integer :: yr,mn,yr1,mn1, k,t,i,j,l + integer, parameter :: scale_fac = 10000 + real, parameter :: val_min = -0.3, val_max = 1. + + + ! Grid to tile + ! ------------ + + ! READ GIMMS NDVI source data files and regrid + ! ---------------------------------------- + + call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) + status = NF_OPEN (trim(MAKE_BCS_INPUT_DIR)//'/land/veg/ndvi/v1/ndvi3g_geo_v1_YYYY_0106.nc4', NF_NOWRITE, ncid1) ; VERIFY_(STATUS) + status = NF_OPEN (trim(MAKE_BCS_INPUT_DIR)//'/land/veg/ndvi/v1/ndvi3g_geo_v1_YYYY_0712.nc4', NF_NOWRITE, ncid2) ; VERIFY_(STATUS) + status = NF_INQ_VARID (ncid2,'ndvi',VarID) ; VERIFY_(STATUS) + + allocate (ndvi_grid (1:NC,1:NR)) + allocate (data_grid (1 : N_lon_gimms, 1 : N_lat_gimms)) + allocate (data_grid2(1 : N_lon_gimms, 1 : N_lat_gimms)) + allocate (ndvi (1:NTILES)) + allocate (count_pix (1:NTILES)) + + ! writing tile-spaced output + ! -------------------------- + + open (31,file='clsm/ndvi.dat',status='unknown',action='write',form='unformatted', & + convert='little_endian') + + do K=0,13 + yr = (k+11)/12 + mn = mod(k+11,12)+1 + yr1= (k+12)/12 + mn1= mod(k+12,12)+1 + + ndvi = 0. + count_pix = 0. + t = k + if (k == 0 ) then + t = 12 + ncid = ncid2 + write(31) float((/yr,mn,16,0,0,0,yr1,mn1,1,0,0,0,NTILES,1/)) + + status = NF_GET_VARA_INT (ncid,VarID, (/1,1,t/),(/N_lon_gimms, N_lat_gimms,1/), data_grid2) ; VERIFY_(STATUS) + + do j = 1, N_lat_gimms + data_grid (:,j) = data_grid2 (:,N_lat_gimms - (j-1)) / real(scale_fac) + end do + + call RegridRasterReal(data_grid, ndvi_grid) + + do j = 1,nr + do i = 1, nc + if((tile_id(i,j).gt.0).and.(tile_id(i,j).le.NTILES)) then + if((ndvi_grid(i,j) >= val_min).and.(ndvi_grid(i,j) <= val_max)) then + ndvi (tile_id(i,j)) = ndvi (tile_id(i,j)) + ndvi_grid(i,j) + count_pix (tile_id(i,j)) = count_pix (tile_id(i,j)) + 1. + endif + endif + end do + end do + + where (count_pix > 0.) ndvi = ndvi /count_pix + write(31) ndvi + + elseif (k == 13) then + + t = 1 + ncid = ncid1 + write(31) float((/yr,mn,1,0,0,0,yr,mn,16,0,0,0,NTILES,1/)) + + status = NF_GET_VARA_INT (ncid,VarID, (/1,1,t/),(/N_lon_gimms, N_lat_gimms,1/), data_grid2) ; VERIFY_(STATUS) + + do j = 1, N_lat_gimms + data_grid (:,j) = data_grid2 (:,N_lat_gimms - (j-1)) / real(scale_fac) + end do + + call RegridRasterReal(data_grid, ndvi_grid) - if(present (SubID)) then - status = NF_DEF_VAR(NCFID, trim(VarName) , NF_FLOAT, 2 ,(/CellID, SubID/), vid) ; VERIFY_(STATUS) - else - status = NF_DEF_VAR(NCFID, trim(VarName) , NF_FLOAT, 1 ,(/CellID/), vid) ; VERIFY_(STATUS) - endif + do j = 1,nr + do i = 1, nc + if((tile_id(i,j).gt.0).and.(tile_id(i,j).le.NTILES)) then + if((ndvi_grid(i,j) >= val_min).and.(ndvi_grid(i,j) <= val_max)) then + ndvi (tile_id(i,j)) = ndvi (tile_id(i,j)) + ndvi_grid(i,j) + count_pix (tile_id(i,j)) = count_pix (tile_id(i,j)) + 1. + endif + endif + end do + end do + + where (count_pix > 0.) ndvi = ndvi /count_pix + write(31) ndvi + + else + + do l = 1, 0 , -1 + t = k*2 - l + if (k <= 6) ncid = ncid1 + if (k >= 7) ncid = ncid2 + if (k >= 7) t = t - 12 + if(l == 1) write(31) float((/yr,mn,1,0,0,0,yr,mn,16,0,0,0,NTILES,1/)) + if(l == 0) write(31) float((/yr,mn,16,0,0,0,yr1,mn1,1,0,0,0,NTILES,1/)) + + ndvi = 0. + count_pix = 0. + + status = NF_GET_VARA_INT (ncid,VarID, (/1,1,t/),(/N_lon_gimms, N_lat_gimms,1/), data_grid2) ; VERIFY_(STATUS) + + do j = 1, N_lat_gimms + data_grid (:,j) = data_grid2 (:,N_lat_gimms - (j-1)) / real(scale_fac) + end do + + call RegridRasterReal(data_grid, ndvi_grid) + + do j = 1,nr + do i = 1, nc + if((tile_id(i,j).gt.0).and.(tile_id(i,j).le.NTILES)) then + if((ndvi_grid(i,j) >= val_min).and.(ndvi_grid(i,j) <= val_max)) then + ndvi (tile_id(i,j)) = ndvi (tile_id(i,j)) + ndvi_grid(i,j) + count_pix (tile_id(i,j)) = count_pix (tile_id(i,j)) + 1. + endif + endif + end do + end do - status = NF_PUT_ATT_TEXT(NCFID, vid, 'long_name', LEN_TRIM(long_name), trim(long_name)) ; VERIFY_(STATUS) - status = NF_PUT_ATT_TEXT(NCFID, vid, 'units' , LEN_TRIM(units) , trim(units)) ; VERIFY_(STATUS) + where (count_pix > 0.) ndvi = ndvi /count_pix + write(31) ndvi + end do + endif + end do - END SUBROUTINE DEF_VAR + close(31,status='keep') - END SUBROUTINE open_landparam_nc4_files + END SUBROUTINE gimms_clim_ndvi - ! ---------------------------------------------------------------------------------------------- + ! -------------------------------------------------------------------------- + SUBROUTINE open_landparam_nc4_files(N_tile,process_snow_albedo) - SUBROUTINE map_country_codes (NC, NR) + implicit none + integer :: NCCatOUTID, NCCatCNOUTID, NCVegOUTID + integer :: STATUS, CellID1, CellID2, CellID3, SubID + integer, intent (in) :: N_tile + logical, intent (in) :: process_snow_albedo + integer, dimension(8) :: date_time_values + character (22) :: time_stamp + character (100) :: MYNAME + + status = NF_CREATE ('clsm/catch_params.nc4' , NF_NETCDF4, NCCatOUTID ) ; VERIFY_(STATUS) + status = NF_CREATE ('clsm/catchcn_params.nc4', NF_NETCDF4, NCCatCNOUTID) ; VERIFY_(STATUS) + status = NF_CREATE ('clsm/vegdyn.data' , NF_NETCDF4, NCVegOUTID ) ; VERIFY_(STATUS) + + status = NF_DEF_DIM(NCCatOUTID , 'tile' , N_tile, CellID1) + status = NF_DEF_DIM(NCCatCNOUTID, 'tile' , N_tile, CellID2) + status = NF_DEF_DIM(NCVegOUTID , 'tile' , N_tile, CellID3) + status = NF_DEF_DIM(NCCatCNOUTID, 'unknown_dim2' , 4, SubID) + + call DEF_VAR ( NCCatOUTID, CellID1,'OLD_ITY' ,'vegetation_type.' , '1' ) + call DEF_VAR ( NCCatOUTID, CellID1,'ARA1' ,'shape_param_1' ,'m+2 kg-1' ) + call DEF_VAR ( NCCatOUTID, CellID1,'ARA2' ,'shape_param_2' ,'1' ) + call DEF_VAR ( NCCatOUTID, CellID1,'ARA3' ,'shape_param_3' ,'m+2 kg-1' ) + call DEF_VAR ( NCCatOUTID, CellID1,'ARA4' ,'shape_param_4' ,'1' ) + call DEF_VAR ( NCCatOUTID, CellID1,'ARS1' ,'wetness_param_1' ,'m+2 kg-1' ) + call DEF_VAR ( NCCatOUTID, CellID1,'ARS2' ,'wetness_param_2' ,'m+2 kg-1' ) + call DEF_VAR ( NCCatOUTID, CellID1,'ARS3' ,'wetness_param_3' ,'m+4 kg-2' ) + call DEF_VAR ( NCCatOUTID, CellID1,'ARW1' ,'min_theta_param_1' ,'m+2 kg-1' ) + call DEF_VAR ( NCCatOUTID, CellID1,'ARW2' ,'min_theta_param_2' ,'m+2 kg-1' ) + call DEF_VAR ( NCCatOUTID, CellID1,'ARW3' ,'min_theta_param_3' ,'m+4 kg-2' ) + call DEF_VAR ( NCCatOUTID, CellID1,'ARW4' ,'min_theta_param_4' ,'1' ) + call DEF_VAR ( NCCatOUTID, CellID1,'ATAU2' ,'2cm_water_transfer_param_5' ,'1' ) + call DEF_VAR ( NCCatOUTID, CellID1,'ATAU5' ,'5cm_water_transfer_param_5' ,'1' ) + call DEF_VAR ( NCCatOUTID, CellID1,'BEE' ,'clapp_hornberger_b' ,'1' ) + call DEF_VAR ( NCCatOUTID, CellID1,'BF1' ,'topo_baseflow_param_1' ,'kg m-4' ) + call DEF_VAR ( NCCatOUTID, CellID1,'BF2' ,'topo_baseflow_param_2' ,'m' ) + call DEF_VAR ( NCCatOUTID, CellID1,'BF3' ,'topo_baseflow_param_3' ,'log(m)' ) + call DEF_VAR ( NCCatOUTID, CellID1,'BTAU2' ,'2cm_water_transfer_param_6' ,'1' ) + call DEF_VAR ( NCCatOUTID, CellID1,'BTAU5' ,'5cm_water_transfer_param_6' ,'1' ) + call DEF_VAR ( NCCatOUTID, CellID1,'COND' ,'sfc_sat_hydraulic_conduct' ,'m s-1' ) + call DEF_VAR ( NCCatOUTID, CellID1,'GNU' ,'vertical_transmissivity' ,'m-1' ) + call DEF_VAR ( NCCatOUTID, CellID1,'POROS' ,'soil_porosity' ,'1' ) + call DEF_VAR ( NCCatOUTID, CellID1,'PSIS' ,'saturated_matric_potential' ,'m' ) + call DEF_VAR ( NCCatOUTID, CellID1,'TSA1' ,'water_transfer_param_1' ,'1' ) + call DEF_VAR ( NCCatOUTID, CellID1,'TSA2' ,'water_transfer_param_2' ,'1' ) + call DEF_VAR ( NCCatOUTID, CellID1,'TSB1' ,'water_transfer_param_3' ,'1' ) + call DEF_VAR ( NCCatOUTID, CellID1,'TSB2' ,'water_transfer_param_4' ,'1' ) + call DEF_VAR ( NCCatOUTID, CellID1,'WPWET' ,'wetness_at_wilting_point' ,'1' ) + call DEF_VAR ( NCCatOUTID, CellID1,'DP2BR' ,'depth_to_bedrock' ,'mm' ) + if (process_snow_albedo) & + call DEF_VAR ( NCCatOUTID, CellID1,'SNOWALB' ,'snow_albedo' ,'1' ) + + call DEF_VAR ( NCVegOUTID, CellID3,'ITY' ,'vegetation_type' ,'1' ) + call DEF_VAR ( NCVegOUTID, CellID3,'Z2CH' ,'vegetation_height' ,'m' ) + call DEF_VAR ( NCVegOUTID, CellID3,'ASCATZ0' ,'ASCAT_roughness_length' ,'m' ) + + call DEF_VAR ( NCCatCNOUTID, CellID2,'BGALBNF' ,'MODIS soil albedo nir dif' ,'1' ) + call DEF_VAR ( NCCatCNOUTID, CellID2,'BGALBNR' ,'MODIS soil albedo nir dir' ,'1' ) + call DEF_VAR ( NCCatCNOUTID, CellID2,'BGALBVF' ,'MODIS soil albedo vis dif' ,'1' ) + call DEF_VAR ( NCCatCNOUTID, CellID2,'BGALBVR' ,'MODIS soil albedo vis dir' ,'1' ) + call DEF_VAR ( NCCatCNOUTID, CellID2,'T2_M' ,'Clim 2m temperature (MERRA2)' ,'K' ) + call DEF_VAR ( NCCatCNOUTID, CellID2,'T2_S' ,'Clim 2m temperature (Sheffield)' ,'K' ) + call DEF_VAR ( NCCatCNOUTID, CellID2,'NDEP' ,'CLM_nitrogen_deposition' ,'g m-2 s-1') + call DEF_VAR ( NCCatCNOUTID, CellID2,'FVG' ,'vegetation_fraction' ,'1' ,SubID = SubID) + call DEF_VAR ( NCCatCNOUTID, CellID2,'ITY' ,'vegetation_type' ,'1' ,SubID = SubID) + + call date_and_time(VALUES=date_time_values) + + write (time_stamp,'(i4.4,a1,i2.2,a1,i2.2,1x,a2,1x,i2.2,a1,i2.2,a1,i2.2)') & + date_time_values(1),'-',date_time_values(2),'-',date_time_values(3),'at', & + date_time_values(5),':',date_time_values(6),':',date_time_values(7) + ! call execute_command_line('setenv MYNAME `finger $USER | cut -d: -f3 | head -1`') + ! call sleep (5) + call get_environment_variable ("USER" ,MYNAME ) + status = NF_PUT_ATT_TEXT(NCCatOUTID , NF_GLOBAL, 'CreatedBy', LEN_TRIM(MYNAME), trim(MYNAME) ) + status = NF_PUT_ATT_TEXT(NCCatOUTID , NF_GLOBAL, 'Date' , LEN_TRIM(time_stamp),trim(time_stamp)) + status = NF_PUT_ATT_TEXT(NCVegOUTID , NF_GLOBAL, 'CreatedBy', LEN_TRIM(MYNAME), trim(MYNAME) ) + status = NF_PUT_ATT_TEXT(NCVegOUTID , NF_GLOBAL, 'Date' , LEN_TRIM(time_stamp),trim(time_stamp)) + status = NF_PUT_ATT_TEXT(NCCatCNOUTID, NF_GLOBAL, 'CreatedBy', LEN_TRIM(MYNAME), trim(MYNAME) ) + status = NF_PUT_ATT_TEXT(NCCatCNOUTID, NF_GLOBAL, 'Date' , LEN_TRIM(time_stamp),trim(time_stamp)) + + status = NF_ENDDEF(NCCatOUTID ) + status = NF_ENDDEF(NCVegOUTID ) + status = NF_ENDDEF(NCCatCNOUTID) + + status = NF_CLOSE (NCCatOUTID ) + status = NF_CLOSE (NCVegOUTID ) + status = NF_CLOSE (NCCatCNOUTID) + + contains + + SUBROUTINE DEF_VAR (NCFID, CellID, VarName, long_name, units, SubID) implicit none - integer , intent (in) :: nc, nr - - integer, parameter :: GC = 43200 - integer, parameter :: GR = 21600 - INTEGER, dimension (:), pointer :: index_RANGE - character*20, dimension (:), pointer :: ST_NAME - character*48, dimension (:), pointer :: CNT_NAME - - integer :: CNT_CODE, ST_CODE - integer :: i(GC),j(GR), k,n, status, ncid, varid, maxcat, I0(1), j0(1) - INTEGER, TARGET, ALLOCATABLE, dimension (:,:):: ST_grid, cnt_grid - real :: lat_mn, lat_mx, lon_mn, lon_mx - real (kind =8) :: XG(GC),YG(GR), y0, x0, dxy - - call get_country_codes (index_RANGE = index_RANGE, ST_NAME = ST_NAME, & - CNT_NAME = CNT_NAME) - - - ! Reading number of tiles - ! ----------------------- - - open (20, file = 'clsm/catchment.def', form = 'formatted', status = 'old', & - action = 'read') - - read (20, *) maxcat - - - ! READ country code source data files and regrid - ! ----------------------------------------- - - call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) - status = NF_OPEN (trim(MAKE_BCS_INPUT_DIR)//'/land/misc/country_codes/v1/GADM_Country_and_USStates_codes_1km.nc4', NF_NOWRITE, ncid) - - allocate (cnt_grid (1 : GC, 1 : GR)) - allocate (st_grid (1 : GC, 1 : GR)) - - status = NF_INQ_VARID (ncid,'UNIT_CODE',VarID) ; VERIFY_(STATUS) - status = NF_GET_VARA_INT (ncid,VarID, (/1,1,1/),(/GC, GR,1/), cnt_grid) ; VERIFY_(STATUS) - status = NF_GET_VARA_INT (ncid,VarID, (/1,1,2/),(/GC, GR,1/), st_grid) ; VERIFY_(STATUS) - where (st_grid == 0) st_grid = 999 - status = NF_CLOSE(ncid) - - open (10,file='clsm/country_and_state_code.data', & + integer, intent (in) :: NCFID, CellID + character (*), intent (in) :: VarName, long_name, units + integer, intent (in), optional :: SubID + integer :: STATUS, VID + + if(present (SubID)) then + status = NF_DEF_VAR(NCFID, trim(VarName) , NF_FLOAT, 2 ,(/CellID, SubID/), vid) ; VERIFY_(STATUS) + else + status = NF_DEF_VAR(NCFID, trim(VarName) , NF_FLOAT, 1 ,(/CellID/), vid) ; VERIFY_(STATUS) + endif + + status = NF_PUT_ATT_TEXT(NCFID, vid, 'long_name', LEN_TRIM(long_name), trim(long_name)) ; VERIFY_(STATUS) + status = NF_PUT_ATT_TEXT(NCFID, vid, 'units' , LEN_TRIM(units) , trim(units)) ; VERIFY_(STATUS) + + + END SUBROUTINE DEF_VAR + + END SUBROUTINE open_landparam_nc4_files + + ! ---------------------------------------------------------------------------------------------- + + + SUBROUTINE map_country_codes (NC, NR, n_land, tile_lon, tile_lat) + + implicit none + integer , intent(in) :: nc, nr, n_land + real, intent(in) :: tile_lon(:), tile_lat(:) + + integer, parameter :: GC = 43200 + integer, parameter :: GR = 21600 + INTEGER, dimension (:), pointer :: index_RANGE + character*20, dimension (:), pointer :: ST_NAME + character*48, dimension (:), pointer :: CNT_NAME + + integer :: CNT_CODE, ST_CODE + integer :: i(GC),j(GR), k,n, status, ncid, varid, I0(1), j0(1) + INTEGER, TARGET, ALLOCATABLE, dimension (:,:):: ST_grid, cnt_grid + real :: lat_mn, lat_mx, lon_mn, lon_mx + real (REAL64) :: XG(GC),YG(GR), y0, x0, dxy + + call get_country_codes (index_RANGE = index_RANGE, ST_NAME = ST_NAME, & + CNT_NAME = CNT_NAME) + + + + ! READ country code source data files and regrid + ! ----------------------------------------- + + call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) + status = NF_OPEN (trim(MAKE_BCS_INPUT_DIR)//'/land/misc/country_codes/v1/GADM_Country_and_USStates_codes_1km.nc4', NF_NOWRITE, ncid) + + allocate (cnt_grid (1 : GC, 1 : GR)) + allocate (st_grid (1 : GC, 1 : GR)) + + status = NF_INQ_VARID (ncid,'UNIT_CODE',VarID) ; VERIFY_(STATUS) + status = NF_GET_VARA_INT (ncid,VarID, (/1,1,1/),(/GC, GR,1/), cnt_grid) ; VERIFY_(STATUS) + status = NF_GET_VARA_INT (ncid,VarID, (/1,1,2/),(/GC, GR,1/), st_grid) ; VERIFY_(STATUS) + where (st_grid == 0) st_grid = 999 + status = NF_CLOSE(ncid) + + open (10,file='clsm/country_and_state_code.data', & form='formatted',status='unknown') - dxy = 360./GC - do k = 1, GC - xg(k) = (k-1)*dxy -180. + dxy/2. - end do - do k = 1, GR - yg(k) = (k-1)*dxy -90. + dxy/2. - end do - - DO n = 1, MAXCAT - read (20,*) i0,j0, lon_mn, lon_mx, lat_mn, lat_mx - x0 = (lon_mn + lon_mx)/2. - y0 = (lat_mn + lat_mx)/2. - I = 0 - J = 0 - WHERE ((xg >= x0).and.(xg < x0 + dxy)) I = 1 - WHERE ((yg >= y0).and.(yg < y0 + dxy)) J = 1 - - I0 =FINDLOC(I,1) - J0 =FINDLOC(J,1) - - cnt_code = cnt_grid(I0(1), J0(1)) - st_code = st_grid (I0(1), J0(1)) - - if(cnt_code > 300) then - CNT_CODE = 257 - endif - - if(st_code <= 50) then - write (10, '(i10, 2I4, 1x, a48, a20)') n, cnt_code, st_code, CNT_NAME(FINDLOC(INDEX_RANGE, CNT_CODE)), ST_NAME (ST_CODE) - else - write (10, '(i10, 2I4, 1x, a48, a20)') n, cnt_code, st_code, CNT_NAME(FINDLOC(INDEX_RANGE, CNT_CODE)), 'OUTSIDE USA' - endif - - END DO - - close (10, status = 'keep') - close (20, status = 'keep') - END SUBROUTINE map_country_codes - - ! ------------------------------------------------------------------------------------------- - - SUBROUTINE get_country_codes (index_RANGE, ST_NAME, CNT_NAME, ST_NAME_ABR, CNT_NAME_ABR) - - implicit none - - INTEGER, dimension (N_GADM ), TARGET :: index_RANGE_DATA - character*20, dimension (N_STATES), TARGET :: ST_NAME_DATA - character*48, dimension (N_GADM ), TARGET :: CNT_NAME_DATA - INTEGER, dimension (:), pointer, intent (inout), optional :: index_RANGE - character*20, dimension (:), pointer, intent (inout), optional :: ST_NAME - character*48, dimension (:), pointer, intent (inout), optional :: CNT_NAME - character*2, dimension (:), pointer, intent (inout), optional :: ST_NAME_ABR - character*3, dimension (:), pointer, intent (inout), optional :: CNT_NAME_ABR - - DATA ST_NAME_DATA / & - 'AK 1 Alaska ' ,& - 'AL 2 Alabama ' ,& - 'AZ 3 Arizona ' ,& - 'AR 4 Arkansas ' ,& - 'CA 5 California ' ,& - 'CO 6 Colorado ' ,& - 'CT 7 Connecticut ' ,& - 'DE 8 Delaware ' ,& - 'FL 9 Florida ' ,& - 'GA 10 Georgia ' ,& - 'HI 11 Hawaii ' ,& - 'IA 12 Iowa ' ,& - 'ID 13 Idaho ' ,& - 'IL 14 Illinois ' ,& - 'IN 15 Indiana ' ,& - 'KS 16 Kansas ' ,& - 'KY 17 Kentucky ' ,& - 'LA 18 Louisiana ' ,& - 'MA 19 Massachusetts ' ,& - 'MD 20 Maryland ' ,& - 'ME 21 Maine ' ,& - 'MI 22 Michigan ' ,& - 'MN 23 Minnesota ' ,& - 'MO 24 Missouri ' ,& - 'MS 25 Mississippi ' ,& - 'MT 26 Montana ' ,& - 'NC 27 NorthCarolina ' ,& - 'ND 28 NorthDakota ' ,& - 'NE 29 Nebraska ' ,& - 'NH 30 NewHampshire ' ,& - 'NJ 31 NewJersey ' ,& - 'NM 32 NewMexico ' ,& - 'NV 33 Nevada ' ,& - 'NY 34 NewYork ' ,& - 'OH 35 Ohio ' ,& - 'OK 36 Oklahoma ' ,& - 'OR 37 Oregon ' ,& - 'PA 38 Pennsylvania ' ,& - 'RI 39 RhodeIsland ' ,& - 'SC 40 SouthCarolina ' ,& - 'SD 41 SouthDakota ' ,& - 'TN 42 Tennessee ' ,& - 'TX 43 Texas ' ,& - 'UT 44 Utah ' ,& - 'VA 45 Virginia ' ,& - 'VT 46 Vermont ' ,& - 'WA 47 Washington ' ,& - 'WI 48 Wisconsin ' ,& - 'WV 49 WestVirginia ' ,& - 'WY 50 Wyoming ' / - - DATA CNT_NAME_DATA / & - 'ABW 14 Aruba ' ,& - 'AFG 1 Afghanistan ' ,& - 'AGO 8 Angola ' ,& - 'AIA 9 Anguilla ' ,& - 'ALA 3 Aland ' ,& - 'ALB 4 Albania ' ,& - 'AND 7 Andorra ' ,& - 'ARE 241 United Arab Emirates ' ,& - 'ARG 12 Argentina ' ,& - 'ARM 13 Armenia ' ,& - 'ASM 6 American Samoa ' ,& - 'ATA 10 Antarctica ' ,& - 'ATF 82 French Southern Territories ' ,& - 'ATG 11 Antigua and Barbuda ' ,& - 'AUS 15 Australia ' ,& - 'AUT 16 Austria ' ,& - 'AZE 17 Azerbaijan ' ,& - 'BDI 39 Burundi ' ,& - 'BEL 23 Belgium ' ,& - 'BEN 25 Benin ' ,& - 'BES 29 Bonaire, Sint Eustatius and Saba ' ,& - 'BFA 38 Burkina Faso ' ,& - 'BGD 20 Bangladesh ' ,& - 'BGR 37 Bulgaria ' ,& - 'BHR 19 Bahrain ' ,& - 'BHS 18 Bahamas ' ,& - 'BIH 30 Bosnia and Herzegovina ' ,& - 'BLM 190 Saint-Barthelemy ' ,& - 'BLR 22 Belarus ' ,& - 'BLZ 24 Belize ' ,& - 'BMU 26 Bermuda ' ,& - 'BOL 28 Bolivia ' ,& - 'BRA 33 Brazil ' ,& - 'BRB 21 Barbados ' ,& - 'BRN 36 Brunei ' ,& - 'BTN 27 Bhutan ' ,& - 'BVT 32 Bouvet Island ' ,& - 'BWA 31 Botswana ' ,& - 'CAF 46 Central African Republic ' ,& - 'CAN 42 Canada ' ,& - 'CCK 52 Cocos Islands ' ,& - 'CHE 223 Switzerland ' ,& - 'CHL 48 Chile ' ,& - 'CHN 49 China ' ,& - 'CIV 57 Cote dIvoire ' ,& - 'CMR 41 Cameroon ' ,& - 'COD 0 Democratic Republic of the Congo ' ,& - 'COG 185 Republic of Congo ' ,& - 'COK 55 Cook Islands ' ,& - 'COL 53 Colombia ' ,& - 'COM 54 Comoros ' ,& - 'CPV 43 Cape Verde ' ,& - 'CRI 56 Costa Rica ' ,& - 'CUB 59 Cuba ' ,& - 'CUW 60 Curacao ' ,& - 'CXR 50 Christmas Island ' ,& - 'CYM 45 Cayman Islands ' ,& - 'CYP 61 Cyprus ' ,& - 'CZE 62 Czech Republic ' ,& - 'DEU 86 Germany ' ,& - 'DJI 65 Djibouti ' ,& - 'DMA 66 Dominica ' ,& - 'DNK 64 Denmark ' ,& - 'DOM 67 Dominican Republic ' ,& - 'DZA 5 Algeria ' ,& - 'ECU 68 Ecuador ' ,& - 'EGY 69 Egypt ' ,& - 'ERI 72 Eritrea ' ,& - 'ESH 253 Western Sahara ' ,& - 'ESP 215 Spain ' ,& - 'EST 73 Estonia ' ,& - 'ETH 74 Ethiopia ' ,& - 'FIN 78 Finland ' ,& - 'FJI 77 Fiji ' ,& - 'FLK 75 Falkland Islands ' ,& - 'FRA 79 France ' ,& - 'FRO 76 Faroe Islands ' ,& - 'FSM 146 Micronesia ' ,& - 'GAB 83 Gabon ' ,& - 'GBR 242 United Kingdom ' ,& - 'GEO 85 Georgia ' ,& - 'GGY 95 Guernsey ' ,& - 'GHA 87 Ghana ' ,& - 'GIB 88 Gibraltar ' ,& - 'GIN 96 Guinea ' ,& - 'GLP 92 Guadeloupe ' ,& - 'GMB 84 Gambia ' ,& - 'GNB 97 Guinea-Bissau ' ,& - 'GNQ 71 Equatorial Guinea ' ,& - 'GRC 89 Greece ' ,& - 'GRD 91 Grenada ' ,& - 'GRL 90 Greenland ' ,& - 'GTM 94 Guatemala ' ,& - 'GUF 80 French Guiana ' ,& - 'GUM 93 Guam ' ,& - 'GUY 98 Guyana ' ,& - 'HKG 102 Hong Kong ' ,& - 'HMD 100 Heard Island and McDonald Islands ' ,& - 'HND 101 Honduras ' ,& - 'HRV 58 Croatia ' ,& - 'HTI 99 Haiti ' ,& - 'HUN 103 Hungary ' ,& - 'IDN 106 Indonesia ' ,& - 'IMN 110 Isle of Man ' ,& - 'IND 105 India ' ,& - 'IOT 34 British Indian Ocean Territory ' ,& - 'IRL 109 Ireland ' ,& - 'IRN 107 Iran ' ,& - 'IRQ 108 Iraq ' ,& - 'ISL 104 Iceland ' ,& - 'ISR 111 Israel ' ,& - 'ITA 112 Italy ' ,& - 'JAM 113 Jamaica ' ,& - 'JEY 115 Jersey ' ,& - 'JOR 116 Jordan ' ,& - 'JPN 114 Japan ' ,& - 'KAZ 117 Kazakhstan ' ,& - 'KEN 118 Kenya ' ,& - 'KGZ 122 Kyrgyzstan ' ,& - 'KHM 40 Cambodia ' ,& - 'KIR 119 Kiribati ' ,& - 'KNA 193 Saint Kitts and Nevis ' ,& - 'KOR 213 South Korea ' ,& - 'KWT 121 Kuwait ' ,& - 'LAO 123 Laos ' ,& - 'LBN 125 Lebanon ' ,& - 'LBR 127 Liberia ' ,& - 'LBY 128 Libya ' ,& - 'LCA 194 Saint Lucia ' ,& - 'LIE 129 Liechtenstein ' ,& - 'LKA 217 Sri Lanka ' ,& - 'LSO 126 Lesotho ' ,& - 'LTU 130 Lithuania ' ,& - 'LUX 131 Luxembourg ' ,& - 'LVA 124 Latvia ' ,& - 'MAC 132 Macao ' ,& - 'MAF 191 Saint-Martin ' ,& - 'MAR 152 Morocco ' ,& - 'MCO 148 Monaco ' ,& - 'MDA 147 Moldova ' ,& - 'MDG 134 Madagascar ' ,& - 'MDV 137 Maldives ' ,& - 'MEX 145 Mexico ' ,& - 'MHL 140 Marshall Islands ' ,& - 'MKD 133 Macedonia ' ,& - 'MLI 138 Mali ' ,& - 'MLT 139 Malta ' ,& - 'MMR 154 Myanmar ' ,& - 'MNE 150 Montenegro ' ,& - 'MNG 149 Mongolia ' ,& - 'MNP 168 Northern Mariana Islands ' ,& - 'MOZ 153 Mozambique ' ,& - 'MRT 142 Mauritania ' ,& - 'MSR 151 Montserrat ' ,& - 'MTQ 141 Martinique ' ,& - 'MUS 143 Mauritius ' ,& - 'MWI 135 Malawi ' ,& - 'MYS 136 Malaysia ' ,& - 'MYT 144 Mayotte ' ,& - 'NAM 155 Namibia ' ,& - 'NCL 159 New Caledonia ' ,& - 'NER 162 Niger ' ,& - 'NFK 165 Norfolk Island ' ,& - 'NGA 163 Nigeria ' ,& - 'NIC 161 Nicaragua ' ,& - 'NIU 164 Niue ' ,& - 'NLD 158 Netherlands ' ,& - 'NOR 169 Norway ' ,& - 'NPL 157 Nepal ' ,& - 'NRU 156 Nauru ' ,& - 'NZL 160 New Zealand ' ,& - 'OMN 170 Oman ' ,& - 'PAK 171 Pakistan ' ,& - 'PAN 174 Panama ' ,& - 'PCN 180 Pitcairn Islands ' ,& - 'PER 178 Peru ' ,& - 'PHL 179 Philippines ' ,& - 'PLW 172 Palau ' ,& - 'PNG 175 Papua New Guinea ' ,& - 'POL 181 Poland ' ,& - 'PRI 183 Puerto Rico ' ,& - 'PRK 166 North Korea ' ,& - 'PRT 182 Portugal ' ,& - 'PRY 177 Paraguay ' ,& - 'PSE 173 Palestina ' ,& - 'PYF 81 French Polynesia ' ,& - 'QAT 184 Qatar ' ,& - 'REU 186 Reunion ' ,& - 'ROU 187 Romania ' ,& - 'RUS 188 Russia ' ,& - 'RWA 189 Rwanda ' ,& - 'SAU 200 Saudi Arabia ' ,& - 'SDN 218 Sudan ' ,& - 'SEN 201 Senegal ' ,& - 'SGP 205 Singapore ' ,& - 'SGS 212 South Georgia and the South Sandwich Is ' ,& - 'SHN 192 Saint Helena ' ,& - 'SJM 220 Svalbard and Jan Mayen ' ,& - 'SLB 209 Solomon Islands ' ,& - 'SLE 204 Sierra Leone ' ,& - 'SLV 70 El Salvador ' ,& - 'SMR 198 San Marino ' ,& - 'SOM 210 Somalia ' ,& - 'SPM 195 Saint Pierre and Miquelon ' ,& - 'SRB 202 Serbia ' ,& - 'SSD 214 South Sudan ' ,& - 'STP 199 Sao Tome and Principe ' ,& - 'SUR 219 Suriname ' ,& - 'SVK 207 Slovakia ' ,& - 'SVN 208 Slovenia ' ,& - 'SWE 222 Sweden ' ,& - 'SWZ 221 Swaziland ' ,& - 'SXM 206 Sint Maarten ' ,& - 'SYC 203 Seychelles ' ,& - 'SYR 224 Syria ' ,& - 'TCA 237 Turks and Caicos Islands ' ,& - 'TCD 47 Chad ' ,& - 'TGO 230 Togo ' ,& - 'THA 228 Thailand ' ,& - 'TJK 226 Tajikistan ' ,& - 'TKL 231 Tokelau ' ,& - 'TKM 236 Turkmenistan ' ,& - 'TLS 229 Timor-Leste ' ,& - 'TON 232 Tonga ' ,& - 'TTO 233 Trinidad and Tobago ' ,& - 'TUN 234 Tunisia ' ,& - 'TUR 235 Turkey ' ,& - 'TUV 238 Tuvalu ' ,& - 'TWN 225 Taiwan ' ,& - 'TZA 227 Tanzania ' ,& - 'UGA 239 Uganda ' ,& - 'UKR 240 Ukraine ' ,& - 'UMI 244 United States Minor Outlying Islands ' ,& - 'URY 245 Uruguay ' ,& - 'USA 243 United States ' ,& - 'UZB 246 Uzbekistan ' ,& - 'VAT 248 Vatican City ' ,& - 'VCT 196 Saint Vincent and the Grenadines ' ,& - 'VEN 249 Venezuela ' ,& - 'VGB 35 British Virgin Islands ' ,& - 'VIR 251 Virgin Islands, U.S. ' ,& - 'VNM 250 Vietnam ' ,& - 'VUT 247 Vanuatu ' ,& - 'WLF 252 Wallis and Futuna ' ,& - 'WSM 197 Samoa ' ,& - 'XAD 2 Akrotiri and Dhekelia ' ,& - 'XCA 44 Caspian Sea ' ,& - 'XCL 51 Clipperton Island ' ,& - 'XKO 120 Kosovo ' ,& - 'XNC 167 Northern Cyprus ' ,& - 'XPI 176 Paracel Islands ' ,& - 'XSP 216 Spratly Islands ' ,& - 'YEM 254 Yemen ' ,& - 'ZAF 211 South Africa ' ,& - 'ZMB 255 Zambia ' ,& - 'ZWE 256 Zimbabwe ' ,& - 'UNK 257 Unknown '/ - - DATA INDEX_RANGE_DATA / & - 14 ,& - 1 ,& - 8 ,& - 9 ,& - 3 ,& - 4 ,& - 7 ,& - 241 ,& - 12 ,& - 13 ,& - 6 ,& - 10 ,& - 82 ,& - 11 ,& - 15 ,& - 16 ,& - 17 ,& - 39 ,& - 23 ,& - 25 ,& - 29 ,& - 38 ,& - 20 ,& - 37 ,& - 19 ,& - 18 ,& - 30 ,& - 190 ,& - 22 ,& - 24 ,& - 26 ,& - 28 ,& - 33 ,& - 21 ,& - 36 ,& - 27 ,& - 32 ,& - 31 ,& - 46 ,& - 42 ,& - 52 ,& - 223 ,& - 48 ,& - 49 ,& - 57 ,& - 41 ,& - 0 ,& - 185 ,& - 55 ,& - 53 ,& - 54 ,& - 43 ,& - 56 ,& - 59 ,& - 60 ,& - 50 ,& - 45 ,& - 61 ,& - 62 ,& - 86 ,& - 65 ,& - 66 ,& - 64 ,& - 67 ,& - 5 ,& - 68 ,& - 69 ,& - 72 ,& - 253 ,& - 215 ,& - 73 ,& - 74 ,& - 78 ,& - 77 ,& - 75 ,& - 79 ,& - 76 ,& - 146 ,& - 83 ,& - 242 ,& - 85 ,& - 95 ,& - 87 ,& - 88 ,& - 96 ,& - 92 ,& - 84 ,& - 97 ,& - 71 ,& - 89 ,& - 91 ,& - 90 ,& - 94 ,& - 80 ,& - 93 ,& - 98 ,& - 102 ,& - 100 ,& - 101 ,& - 58 ,& - 99 ,& - 103 ,& - 106 ,& - 110 ,& - 105 ,& - 34 ,& - 109 ,& - 107 ,& - 108 ,& - 104 ,& - 111 ,& - 112 ,& - 113 ,& - 115 ,& - 116 ,& - 114 ,& - 117 ,& - 118 ,& - 122 ,& - 40 ,& - 119 ,& - 193 ,& - 213 ,& - 121 ,& - 123 ,& - 125 ,& - 127 ,& - 128 ,& - 194 ,& - 129 ,& - 217 ,& - 126 ,& - 130 ,& - 131 ,& - 124 ,& - 132 ,& - 191 ,& - 152 ,& - 148 ,& - 147 ,& - 134 ,& - 137 ,& - 145 ,& - 140 ,& - 133 ,& - 138 ,& - 139 ,& - 154 ,& - 150 ,& - 149 ,& - 168 ,& - 153 ,& - 142 ,& - 151 ,& - 141 ,& - 143 ,& - 135 ,& - 136 ,& - 144 ,& - 155 ,& - 159 ,& - 162 ,& - 165 ,& - 163 ,& - 161 ,& - 164 ,& - 158 ,& - 169 ,& - 157 ,& - 156 ,& - 160 ,& - 170 ,& - 171 ,& - 174 ,& - 180 ,& - 178 ,& - 179 ,& - 172 ,& - 175 ,& - 181 ,& - 183 ,& - 166 ,& - 182 ,& - 177 ,& - 173 ,& - 81 ,& - 184 ,& - 186 ,& - 187 ,& - 188 ,& - 189 ,& - 200 ,& - 218 ,& - 201 ,& - 205 ,& - 212 ,& - 192 ,& - 220 ,& - 209 ,& - 204 ,& - 70 ,& - 198 ,& - 210 ,& - 195 ,& - 202 ,& - 214 ,& - 199 ,& - 219 ,& - 207 ,& - 208 ,& - 222 ,& - 221 ,& - 206 ,& - 203 ,& - 224 ,& - 237 ,& - 47 ,& - 230 ,& - 228 ,& - 226 ,& - 231 ,& - 236 ,& - 229 ,& - 232 ,& - 233 ,& - 234 ,& - 235 ,& - 238 ,& - 225 ,& - 227 ,& - 239 ,& - 240 ,& - 244 ,& - 245 ,& - 243 ,& - 246 ,& - 248 ,& - 196 ,& - 249 ,& - 35 ,& - 251 ,& - 250 ,& - 247 ,& - 252 ,& - 197 ,& - 2 ,& - 44 ,& - 51 ,& - 120 ,& - 167 ,& - 176 ,& - 216 ,& - 254 ,& - 211 ,& - 255 ,& - 256 ,& - 257 / - - if(present(index_RANGE )) index_RANGE => index_RANGE_DATA - if(present(ST_NAME )) ST_NAME => ST_NAME_DATA - if(present(CNT_NAME )) CNT_NAME => CNT_NAME_DATA - if(present(ST_NAME_ABR )) ST_NAME_ABR => ST_NAME_DATA (:)(1:2) - if(present(CNT_NAME_ABR)) CNT_NAME_ABR=> CNT_NAME_DATA(:)(1:3) - - END SUBROUTINE get_country_codes - - END MODULE process_hres_data + dxy = 360./GC + do k = 1, GC + xg(k) = (k-1)*dxy -180. + dxy/2. + end do + do k = 1, GR + yg(k) = (k-1)*dxy -90. + dxy/2. + end do + + DO n = 1, n_land + x0 = tile_lon(n) + y0 = tile_lat(n) + I = 0 + J = 0 + WHERE ((xg >= x0).and.(xg < x0 + dxy)) I = 1 + WHERE ((yg >= y0).and.(yg < y0 + dxy)) J = 1 + + I0 =FINDLOC(I,1) + J0 =FINDLOC(J,1) + + cnt_code = cnt_grid(I0(1), J0(1)) + st_code = st_grid (I0(1), J0(1)) + + if(cnt_code > 300) then + CNT_CODE = 257 + endif + + if(st_code <= 50) then + write (10, '(i10, 2I4, 1x, a48, a20)') n, cnt_code, st_code, CNT_NAME(FINDLOC(INDEX_RANGE, CNT_CODE)), ST_NAME (ST_CODE) + else + write (10, '(i10, 2I4, 1x, a48, a20)') n, cnt_code, st_code, CNT_NAME(FINDLOC(INDEX_RANGE, CNT_CODE)), 'OUTSIDE USA' + endif + + END DO + close (10, status = 'keep') + END SUBROUTINE map_country_codes + + ! ------------------------------------------------------------------------------------------- + + SUBROUTINE get_country_codes (index_RANGE, ST_NAME, CNT_NAME, ST_NAME_ABR, CNT_NAME_ABR) + + implicit none + + INTEGER, dimension (N_GADM ), TARGET :: index_RANGE_DATA + character*20, dimension (N_STATES), TARGET :: ST_NAME_DATA + character*48, dimension (N_GADM ), TARGET :: CNT_NAME_DATA + INTEGER, dimension (:), pointer, intent (inout), optional :: index_RANGE + character*20, dimension (:), pointer, intent (inout), optional :: ST_NAME + character*48, dimension (:), pointer, intent (inout), optional :: CNT_NAME + character*2, dimension (:), pointer, intent (inout), optional :: ST_NAME_ABR + character*3, dimension (:), pointer, intent (inout), optional :: CNT_NAME_ABR + + DATA ST_NAME_DATA / & + 'AK 1 Alaska ' ,& + 'AL 2 Alabama ' ,& + 'AZ 3 Arizona ' ,& + 'AR 4 Arkansas ' ,& + 'CA 5 California ' ,& + 'CO 6 Colorado ' ,& + 'CT 7 Connecticut ' ,& + 'DE 8 Delaware ' ,& + 'FL 9 Florida ' ,& + 'GA 10 Georgia ' ,& + 'HI 11 Hawaii ' ,& + 'IA 12 Iowa ' ,& + 'ID 13 Idaho ' ,& + 'IL 14 Illinois ' ,& + 'IN 15 Indiana ' ,& + 'KS 16 Kansas ' ,& + 'KY 17 Kentucky ' ,& + 'LA 18 Louisiana ' ,& + 'MA 19 Massachusetts ' ,& + 'MD 20 Maryland ' ,& + 'ME 21 Maine ' ,& + 'MI 22 Michigan ' ,& + 'MN 23 Minnesota ' ,& + 'MO 24 Missouri ' ,& + 'MS 25 Mississippi ' ,& + 'MT 26 Montana ' ,& + 'NC 27 NorthCarolina ' ,& + 'ND 28 NorthDakota ' ,& + 'NE 29 Nebraska ' ,& + 'NH 30 NewHampshire ' ,& + 'NJ 31 NewJersey ' ,& + 'NM 32 NewMexico ' ,& + 'NV 33 Nevada ' ,& + 'NY 34 NewYork ' ,& + 'OH 35 Ohio ' ,& + 'OK 36 Oklahoma ' ,& + 'OR 37 Oregon ' ,& + 'PA 38 Pennsylvania ' ,& + 'RI 39 RhodeIsland ' ,& + 'SC 40 SouthCarolina ' ,& + 'SD 41 SouthDakota ' ,& + 'TN 42 Tennessee ' ,& + 'TX 43 Texas ' ,& + 'UT 44 Utah ' ,& + 'VA 45 Virginia ' ,& + 'VT 46 Vermont ' ,& + 'WA 47 Washington ' ,& + 'WI 48 Wisconsin ' ,& + 'WV 49 WestVirginia ' ,& + 'WY 50 Wyoming ' / + + DATA CNT_NAME_DATA / & + 'ABW 14 Aruba ' ,& + 'AFG 1 Afghanistan ' ,& + 'AGO 8 Angola ' ,& + 'AIA 9 Anguilla ' ,& + 'ALA 3 Aland ' ,& + 'ALB 4 Albania ' ,& + 'AND 7 Andorra ' ,& + 'ARE 241 United Arab Emirates ' ,& + 'ARG 12 Argentina ' ,& + 'ARM 13 Armenia ' ,& + 'ASM 6 American Samoa ' ,& + 'ATA 10 Antarctica ' ,& + 'ATF 82 French Southern Territories ' ,& + 'ATG 11 Antigua and Barbuda ' ,& + 'AUS 15 Australia ' ,& + 'AUT 16 Austria ' ,& + 'AZE 17 Azerbaijan ' ,& + 'BDI 39 Burundi ' ,& + 'BEL 23 Belgium ' ,& + 'BEN 25 Benin ' ,& + 'BES 29 Bonaire, Sint Eustatius and Saba ' ,& + 'BFA 38 Burkina Faso ' ,& + 'BGD 20 Bangladesh ' ,& + 'BGR 37 Bulgaria ' ,& + 'BHR 19 Bahrain ' ,& + 'BHS 18 Bahamas ' ,& + 'BIH 30 Bosnia and Herzegovina ' ,& + 'BLM 190 Saint-Barthelemy ' ,& + 'BLR 22 Belarus ' ,& + 'BLZ 24 Belize ' ,& + 'BMU 26 Bermuda ' ,& + 'BOL 28 Bolivia ' ,& + 'BRA 33 Brazil ' ,& + 'BRB 21 Barbados ' ,& + 'BRN 36 Brunei ' ,& + 'BTN 27 Bhutan ' ,& + 'BVT 32 Bouvet Island ' ,& + 'BWA 31 Botswana ' ,& + 'CAF 46 Central African Republic ' ,& + 'CAN 42 Canada ' ,& + 'CCK 52 Cocos Islands ' ,& + 'CHE 223 Switzerland ' ,& + 'CHL 48 Chile ' ,& + 'CHN 49 China ' ,& + 'CIV 57 Cote dIvoire ' ,& + 'CMR 41 Cameroon ' ,& + 'COD 0 Democratic Republic of the Congo ' ,& + 'COG 185 Republic of Congo ' ,& + 'COK 55 Cook Islands ' ,& + 'COL 53 Colombia ' ,& + 'COM 54 Comoros ' ,& + 'CPV 43 Cape Verde ' ,& + 'CRI 56 Costa Rica ' ,& + 'CUB 59 Cuba ' ,& + 'CUW 60 Curacao ' ,& + 'CXR 50 Christmas Island ' ,& + 'CYM 45 Cayman Islands ' ,& + 'CYP 61 Cyprus ' ,& + 'CZE 62 Czech Republic ' ,& + 'DEU 86 Germany ' ,& + 'DJI 65 Djibouti ' ,& + 'DMA 66 Dominica ' ,& + 'DNK 64 Denmark ' ,& + 'DOM 67 Dominican Republic ' ,& + 'DZA 5 Algeria ' ,& + 'ECU 68 Ecuador ' ,& + 'EGY 69 Egypt ' ,& + 'ERI 72 Eritrea ' ,& + 'ESH 253 Western Sahara ' ,& + 'ESP 215 Spain ' ,& + 'EST 73 Estonia ' ,& + 'ETH 74 Ethiopia ' ,& + 'FIN 78 Finland ' ,& + 'FJI 77 Fiji ' ,& + 'FLK 75 Falkland Islands ' ,& + 'FRA 79 France ' ,& + 'FRO 76 Faroe Islands ' ,& + 'FSM 146 Micronesia ' ,& + 'GAB 83 Gabon ' ,& + 'GBR 242 United Kingdom ' ,& + 'GEO 85 Georgia ' ,& + 'GGY 95 Guernsey ' ,& + 'GHA 87 Ghana ' ,& + 'GIB 88 Gibraltar ' ,& + 'GIN 96 Guinea ' ,& + 'GLP 92 Guadeloupe ' ,& + 'GMB 84 Gambia ' ,& + 'GNB 97 Guinea-Bissau ' ,& + 'GNQ 71 Equatorial Guinea ' ,& + 'GRC 89 Greece ' ,& + 'GRD 91 Grenada ' ,& + 'GRL 90 Greenland ' ,& + 'GTM 94 Guatemala ' ,& + 'GUF 80 French Guiana ' ,& + 'GUM 93 Guam ' ,& + 'GUY 98 Guyana ' ,& + 'HKG 102 Hong Kong ' ,& + 'HMD 100 Heard Island and McDonald Islands ' ,& + 'HND 101 Honduras ' ,& + 'HRV 58 Croatia ' ,& + 'HTI 99 Haiti ' ,& + 'HUN 103 Hungary ' ,& + 'IDN 106 Indonesia ' ,& + 'IMN 110 Isle of Man ' ,& + 'IND 105 India ' ,& + 'IOT 34 British Indian Ocean Territory ' ,& + 'IRL 109 Ireland ' ,& + 'IRN 107 Iran ' ,& + 'IRQ 108 Iraq ' ,& + 'ISL 104 Iceland ' ,& + 'ISR 111 Israel ' ,& + 'ITA 112 Italy ' ,& + 'JAM 113 Jamaica ' ,& + 'JEY 115 Jersey ' ,& + 'JOR 116 Jordan ' ,& + 'JPN 114 Japan ' ,& + 'KAZ 117 Kazakhstan ' ,& + 'KEN 118 Kenya ' ,& + 'KGZ 122 Kyrgyzstan ' ,& + 'KHM 40 Cambodia ' ,& + 'KIR 119 Kiribati ' ,& + 'KNA 193 Saint Kitts and Nevis ' ,& + 'KOR 213 South Korea ' ,& + 'KWT 121 Kuwait ' ,& + 'LAO 123 Laos ' ,& + 'LBN 125 Lebanon ' ,& + 'LBR 127 Liberia ' ,& + 'LBY 128 Libya ' ,& + 'LCA 194 Saint Lucia ' ,& + 'LIE 129 Liechtenstein ' ,& + 'LKA 217 Sri Lanka ' ,& + 'LSO 126 Lesotho ' ,& + 'LTU 130 Lithuania ' ,& + 'LUX 131 Luxembourg ' ,& + 'LVA 124 Latvia ' ,& + 'MAC 132 Macao ' ,& + 'MAF 191 Saint-Martin ' ,& + 'MAR 152 Morocco ' ,& + 'MCO 148 Monaco ' ,& + 'MDA 147 Moldova ' ,& + 'MDG 134 Madagascar ' ,& + 'MDV 137 Maldives ' ,& + 'MEX 145 Mexico ' ,& + 'MHL 140 Marshall Islands ' ,& + 'MKD 133 Macedonia ' ,& + 'MLI 138 Mali ' ,& + 'MLT 139 Malta ' ,& + 'MMR 154 Myanmar ' ,& + 'MNE 150 Montenegro ' ,& + 'MNG 149 Mongolia ' ,& + 'MNP 168 Northern Mariana Islands ' ,& + 'MOZ 153 Mozambique ' ,& + 'MRT 142 Mauritania ' ,& + 'MSR 151 Montserrat ' ,& + 'MTQ 141 Martinique ' ,& + 'MUS 143 Mauritius ' ,& + 'MWI 135 Malawi ' ,& + 'MYS 136 Malaysia ' ,& + 'MYT 144 Mayotte ' ,& + 'NAM 155 Namibia ' ,& + 'NCL 159 New Caledonia ' ,& + 'NER 162 Niger ' ,& + 'NFK 165 Norfolk Island ' ,& + 'NGA 163 Nigeria ' ,& + 'NIC 161 Nicaragua ' ,& + 'NIU 164 Niue ' ,& + 'NLD 158 Netherlands ' ,& + 'NOR 169 Norway ' ,& + 'NPL 157 Nepal ' ,& + 'NRU 156 Nauru ' ,& + 'NZL 160 New Zealand ' ,& + 'OMN 170 Oman ' ,& + 'PAK 171 Pakistan ' ,& + 'PAN 174 Panama ' ,& + 'PCN 180 Pitcairn Islands ' ,& + 'PER 178 Peru ' ,& + 'PHL 179 Philippines ' ,& + 'PLW 172 Palau ' ,& + 'PNG 175 Papua New Guinea ' ,& + 'POL 181 Poland ' ,& + 'PRI 183 Puerto Rico ' ,& + 'PRK 166 North Korea ' ,& + 'PRT 182 Portugal ' ,& + 'PRY 177 Paraguay ' ,& + 'PSE 173 Palestina ' ,& + 'PYF 81 French Polynesia ' ,& + 'QAT 184 Qatar ' ,& + 'REU 186 Reunion ' ,& + 'ROU 187 Romania ' ,& + 'RUS 188 Russia ' ,& + 'RWA 189 Rwanda ' ,& + 'SAU 200 Saudi Arabia ' ,& + 'SDN 218 Sudan ' ,& + 'SEN 201 Senegal ' ,& + 'SGP 205 Singapore ' ,& + 'SGS 212 South Georgia and the South Sandwich Is ' ,& + 'SHN 192 Saint Helena ' ,& + 'SJM 220 Svalbard and Jan Mayen ' ,& + 'SLB 209 Solomon Islands ' ,& + 'SLE 204 Sierra Leone ' ,& + 'SLV 70 El Salvador ' ,& + 'SMR 198 San Marino ' ,& + 'SOM 210 Somalia ' ,& + 'SPM 195 Saint Pierre and Miquelon ' ,& + 'SRB 202 Serbia ' ,& + 'SSD 214 South Sudan ' ,& + 'STP 199 Sao Tome and Principe ' ,& + 'SUR 219 Suriname ' ,& + 'SVK 207 Slovakia ' ,& + 'SVN 208 Slovenia ' ,& + 'SWE 222 Sweden ' ,& + 'SWZ 221 Swaziland ' ,& + 'SXM 206 Sint Maarten ' ,& + 'SYC 203 Seychelles ' ,& + 'SYR 224 Syria ' ,& + 'TCA 237 Turks and Caicos Islands ' ,& + 'TCD 47 Chad ' ,& + 'TGO 230 Togo ' ,& + 'THA 228 Thailand ' ,& + 'TJK 226 Tajikistan ' ,& + 'TKL 231 Tokelau ' ,& + 'TKM 236 Turkmenistan ' ,& + 'TLS 229 Timor-Leste ' ,& + 'TON 232 Tonga ' ,& + 'TTO 233 Trinidad and Tobago ' ,& + 'TUN 234 Tunisia ' ,& + 'TUR 235 Turkey ' ,& + 'TUV 238 Tuvalu ' ,& + 'TWN 225 Taiwan ' ,& + 'TZA 227 Tanzania ' ,& + 'UGA 239 Uganda ' ,& + 'UKR 240 Ukraine ' ,& + 'UMI 244 United States Minor Outlying Islands ' ,& + 'URY 245 Uruguay ' ,& + 'USA 243 United States ' ,& + 'UZB 246 Uzbekistan ' ,& + 'VAT 248 Vatican City ' ,& + 'VCT 196 Saint Vincent and the Grenadines ' ,& + 'VEN 249 Venezuela ' ,& + 'VGB 35 British Virgin Islands ' ,& + 'VIR 251 Virgin Islands, U.S. ' ,& + 'VNM 250 Vietnam ' ,& + 'VUT 247 Vanuatu ' ,& + 'WLF 252 Wallis and Futuna ' ,& + 'WSM 197 Samoa ' ,& + 'XAD 2 Akrotiri and Dhekelia ' ,& + 'XCA 44 Caspian Sea ' ,& + 'XCL 51 Clipperton Island ' ,& + 'XKO 120 Kosovo ' ,& + 'XNC 167 Northern Cyprus ' ,& + 'XPI 176 Paracel Islands ' ,& + 'XSP 216 Spratly Islands ' ,& + 'YEM 254 Yemen ' ,& + 'ZAF 211 South Africa ' ,& + 'ZMB 255 Zambia ' ,& + 'ZWE 256 Zimbabwe ' ,& + 'UNK 257 Unknown '/ + + DATA INDEX_RANGE_DATA / & + 14 ,& + 1 ,& + 8 ,& + 9 ,& + 3 ,& + 4 ,& + 7 ,& + 241 ,& + 12 ,& + 13 ,& + 6 ,& + 10 ,& + 82 ,& + 11 ,& + 15 ,& + 16 ,& + 17 ,& + 39 ,& + 23 ,& + 25 ,& + 29 ,& + 38 ,& + 20 ,& + 37 ,& + 19 ,& + 18 ,& + 30 ,& + 190 ,& + 22 ,& + 24 ,& + 26 ,& + 28 ,& + 33 ,& + 21 ,& + 36 ,& + 27 ,& + 32 ,& + 31 ,& + 46 ,& + 42 ,& + 52 ,& + 223 ,& + 48 ,& + 49 ,& + 57 ,& + 41 ,& + 0 ,& + 185 ,& + 55 ,& + 53 ,& + 54 ,& + 43 ,& + 56 ,& + 59 ,& + 60 ,& + 50 ,& + 45 ,& + 61 ,& + 62 ,& + 86 ,& + 65 ,& + 66 ,& + 64 ,& + 67 ,& + 5 ,& + 68 ,& + 69 ,& + 72 ,& + 253 ,& + 215 ,& + 73 ,& + 74 ,& + 78 ,& + 77 ,& + 75 ,& + 79 ,& + 76 ,& + 146 ,& + 83 ,& + 242 ,& + 85 ,& + 95 ,& + 87 ,& + 88 ,& + 96 ,& + 92 ,& + 84 ,& + 97 ,& + 71 ,& + 89 ,& + 91 ,& + 90 ,& + 94 ,& + 80 ,& + 93 ,& + 98 ,& + 102 ,& + 100 ,& + 101 ,& + 58 ,& + 99 ,& + 103 ,& + 106 ,& + 110 ,& + 105 ,& + 34 ,& + 109 ,& + 107 ,& + 108 ,& + 104 ,& + 111 ,& + 112 ,& + 113 ,& + 115 ,& + 116 ,& + 114 ,& + 117 ,& + 118 ,& + 122 ,& + 40 ,& + 119 ,& + 193 ,& + 213 ,& + 121 ,& + 123 ,& + 125 ,& + 127 ,& + 128 ,& + 194 ,& + 129 ,& + 217 ,& + 126 ,& + 130 ,& + 131 ,& + 124 ,& + 132 ,& + 191 ,& + 152 ,& + 148 ,& + 147 ,& + 134 ,& + 137 ,& + 145 ,& + 140 ,& + 133 ,& + 138 ,& + 139 ,& + 154 ,& + 150 ,& + 149 ,& + 168 ,& + 153 ,& + 142 ,& + 151 ,& + 141 ,& + 143 ,& + 135 ,& + 136 ,& + 144 ,& + 155 ,& + 159 ,& + 162 ,& + 165 ,& + 163 ,& + 161 ,& + 164 ,& + 158 ,& + 169 ,& + 157 ,& + 156 ,& + 160 ,& + 170 ,& + 171 ,& + 174 ,& + 180 ,& + 178 ,& + 179 ,& + 172 ,& + 175 ,& + 181 ,& + 183 ,& + 166 ,& + 182 ,& + 177 ,& + 173 ,& + 81 ,& + 184 ,& + 186 ,& + 187 ,& + 188 ,& + 189 ,& + 200 ,& + 218 ,& + 201 ,& + 205 ,& + 212 ,& + 192 ,& + 220 ,& + 209 ,& + 204 ,& + 70 ,& + 198 ,& + 210 ,& + 195 ,& + 202 ,& + 214 ,& + 199 ,& + 219 ,& + 207 ,& + 208 ,& + 222 ,& + 221 ,& + 206 ,& + 203 ,& + 224 ,& + 237 ,& + 47 ,& + 230 ,& + 228 ,& + 226 ,& + 231 ,& + 236 ,& + 229 ,& + 232 ,& + 233 ,& + 234 ,& + 235 ,& + 238 ,& + 225 ,& + 227 ,& + 239 ,& + 240 ,& + 244 ,& + 245 ,& + 243 ,& + 246 ,& + 248 ,& + 196 ,& + 249 ,& + 35 ,& + 251 ,& + 250 ,& + 247 ,& + 252 ,& + 197 ,& + 2 ,& + 44 ,& + 51 ,& + 120 ,& + 167 ,& + 176 ,& + 216 ,& + 254 ,& + 211 ,& + 255 ,& + 256 ,& + 257 / + + if(present(index_RANGE )) index_RANGE => index_RANGE_DATA + if(present(ST_NAME )) ST_NAME => ST_NAME_DATA + if(present(CNT_NAME )) CNT_NAME => CNT_NAME_DATA + if(present(ST_NAME_ABR )) ST_NAME_ABR => ST_NAME_DATA (:)(1:2) + if(present(CNT_NAME_ABR)) CNT_NAME_ABR=> CNT_NAME_DATA(:)(1:3) + + END SUBROUTINE get_country_codes + +END MODULE process_hres_data ! ---------------------------------------------------------------------------------------------- diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/rasterize.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/rasterize.F90 index c742a1f24..5de460b47 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/rasterize.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/rasterize.F90 @@ -3,9 +3,10 @@ module LogRectRasterizeMod use MAPL_SORTMOD - use rmTinyCatchParaMod, ONLY: SRTM_maxcat use MAPL_ExceptionHandling - use MAPL_Constants, only: PI=>MAPL_PI_R8 + use MAPL_Constants, only: PI=>MAPL_PI_R8 + use MAPL + use, intrinsic :: iso_fortran_env, only: INT32, REAL64 implicit none private @@ -20,24 +21,32 @@ module LogRectRasterizeMod !EOP public LRRasterize - public ReadRaster +! public ReadRaster public WriteRaster public Writetiling + public WritetilingNC4 + public ReadTilingNC4 public Sorttiling - public Opentiling - public Closetiling - public WriteLine + public MAPL_UNDEF_R8 + ! SRTM_maxcat = number of Pfafstetter catchments defined in raster file produced by Kristine Version in 2013 + ! (based on DEMs from 3.0-arcsec HydroSHEDS/SRTM south of 60N, + ! 7.5-arcsec GMTED2010 north of 60N, and + ! CGIAR/SRTM where HydroSHEDS/SRTM is undefined [typically islands]) - integer, parameter :: PUSHLEFT = 10000 - real(kind=8) , parameter :: Zero = 0.0 + INTEGER, PARAMETER, public:: SRTM_maxcat = 291284 - integer, parameter :: NX = 8640 - integer, parameter :: NY = 4320 + ! ------------------------------------------------------------------------------------------------------------- + integer, parameter :: PUSHLEFT = 10000 + real(REAL64), parameter :: Zero = 0.0d0 + + integer, parameter :: NX = 8640 + integer, parameter :: NY = 4320 + real(REAL64), parameter :: MAPL_UNDEF_R8 = 1.0D15 + + real(REAL64) :: garea_ + integer :: ctg_ - real(kind=8) :: garea_ - integer :: ctg_ - interface LRRasterize module procedure LRRasterize2File module procedure LRRasterize2File0 @@ -77,42 +86,38 @@ subroutine WriteRaster(File, Raster, Zip) return end subroutine WriteRaster - - - - -subroutine ReadRaster(File, Raster, Zip) - character*(*), intent(IN) :: File - integer, intent(IN) :: Raster(:,:) - logical, optional :: Zip - - logical :: DoZip, Opened - integer :: nx, ny - - nx = size(Raster,1) - ny = size(Raster,2) - - if(present(Zip)) then - DoZip = Zip - else - DoZip = .false. - endif - - if(DoZip) then - print *, "Reading zipped raster files not supported" - call exit(1) - else - call READRST(RASTER(1,1),nx,ny,trim(FILE)//CHAR(0)) - end if - - return -end subroutine ReadRaster +! subroutine ReadRaster(File, Raster, Zip) +! character*(*), intent(IN) :: File +! integer, intent(IN) :: Raster(:,:) +! logical, optional :: Zip +! +! logical :: DoZip, Opened +! integer :: nx, ny +! +! nx = size(Raster,1) +! ny = size(Raster,2) +! +! if(present(Zip)) then +! DoZip = Zip +! else +! DoZip = .false. +! endif +! +! if(DoZip) then +! print *, "Reading zipped raster files not supported" +! call exit(1) +! else +! call READRST(RASTER(1,1),nx,ny,trim(FILE)//CHAR(0)) +! end if +! +! return +! end subroutine ReadRaster subroutine SortTiling(Raster,rTable,iTable) integer, intent(INOUT) :: Raster(:,:), iTable(0:,:) - real(kind=8), intent(INOUT) :: rTable(:,:) + real(REAL64), intent(INOUT) :: rTable(:,:) integer, dimension(size(iTable,2)) :: old, new integer*8, dimension(size(iTable,2)) :: key, key0 @@ -162,12 +167,34 @@ subroutine SortTiling(Raster,rTable,iTable) return end subroutine SortTiling +! -------------------------------------------------------------------------------------------- + subroutine WriteTilingIR(File, GridName, im, jm, ipx, nx, ny, iTable, rTable, Zip, Verb, rc) + + ! Write ASCII tile file + ! + ! We have ascii tile files that support either 1 or 2 grids. The most typcal case for GEOS is a tile file with + ! 2 grids (although to generate the final file, we generate a lot of intermediate tile files with a single grid). + ! For the 2-grid tile file, the pfaf index number should be in column 9 (basically that file has 3 groups, + ! each of which has 4 columns: the "global" info part (type, area, lat, lon), and then for each grid we have + ! (index1 (i.e. "i"), index2 (i.e. "j"), weight, dummy). Here "dummy" is a variable, used internally for + ! bookkeeping purposes, but it is totally ignored by GEOS, MAPL, etc. So, for the typical case, ATM and OCN + ! grids, columns 1-4 represent the global variables, then the next 4 columns refer to the ATM grid (but this + ! is to a large extend an artifact of the ordering of the "combine" calls that generate the final tile file). + ! Then for type=0 (i.e., "ocean") the last 4 columns are the i, j, weight, dummy of the ocean grid. + ! But for type=100 (i.e., land) the convention is the first index, i.e. column 9, is the pfaf index + ! (that is, the index of the Pfafstetter hydrological catchment). + ! I do not think we use the content of column 10 anywhere in the model. + ! So my bottom line is the pfaf index should be in column 9. If it appears in column 8, it won't do any harm + ! to the atmosphere, but we cannot use it properly to do river routing inside the land model. + ! (From https://github.com/GEOS-ESM/GEOSgcm_GridComp/pull/1028#issuecomment-2599275578, lightly edited.) + + character*(*), intent(IN) :: File character*(*), intent(IN) :: GridName(:) integer, intent(IN) :: nx,ny integer, intent(IN) :: iTable(0:,:) - real(kind=8), intent(IN) :: rTable(:,:) + real(REAL64), intent(IN) :: rTable(:,:) integer, intent(IN) :: IM(:), JM(:), ipx(:) logical, optional, intent(IN) :: Zip logical, optional, intent(IN) :: Verb @@ -177,10 +204,12 @@ subroutine WriteTilingIR(File, GridName, im, jm, ipx, nx, ny, iTable, rTable, Zi ! ! iTable(0) :: Surface type ! iTable(1) :: tile count -! iTable(2) :: I_1 I of first grid +! iTable(2) :: I_1 I of 1st grid ! iTable(3) :: J_1 -! iTable(4) :: I_2 I of 2nd grid +! iTable(4) :: I_2 I of 2nd grid *OR* for land tiles: index of Pfafstetter catchment (see comment above) ! iTable(5) :: J_2 +! iTable(6) :: kk_1 (dummy variable for internal bookkeeping) +! iTable(7) :: kk_2 (dummy variable for internal bookkeeping) ! ! rTable(1) :: sum of lons ! rTable(2) :: sum of lats @@ -188,22 +217,23 @@ subroutine WriteTilingIR(File, GridName, im, jm, ipx, nx, ny, iTable, rTable, Zi ! rTable(4) :: of first grid box area ! rTable(5) :: of 2nd grid box area - logical :: DoZip, Opened - integer :: j, unit, ng, ip, l, i, k, ix + logical :: DoZip, Opened + integer :: j, unit, ng, ip, l, i, k, ix character*1000 :: Line - integer :: ii(size(GridName)), jj(size(GridName)), kk(size(GridName)) - real(kind=8) :: fr(size(GridName)) - real(kind=8) :: xc, yc, area - real(kind=8) :: garea, ctg(size(Gridname)) - real(kind=8) :: sphere, error - integer :: status + integer :: ii(size(GridName)), jj(size(GridName)), kk(size(GridName)) + real(REAL64) :: fr(size(GridName)) + real(REAL64) :: xc, yc, area + real(REAL64) :: garea, ctg(size(Gridname)) + real(REAL64) :: sphere, error + integer :: status, tmp_in1, tmp_in2, ncat + logical :: file_exists ip = size(iTable,2) ng = size(GridName) _ASSERT(IP==size(rTable,2),'needs informative message') - _ASSERT(NG==size(IM),'needs informative message') - _ASSERT(NG==size(JM),'needs informative message') + _ASSERT(NG==size(IM), 'needs informative message') + _ASSERT(NG==size(JM), 'needs informative message') if(present(Zip)) then DoZip = Zip @@ -249,8 +279,8 @@ subroutine WriteTilingIR(File, GridName, im, jm, ipx, nx, ny, iTable, rTable, Zi ! Write tile info, one line per tile. #define LINE_FORMAT '(I10,3E20.12,9(2I10,E20.12,I10))' -#define LINE_VARIABLES iTable(0,k),area,xc,yc, (ii(l),jj(l),fr(l),kk(l),l=1,ng) - +#define LINE_VARIABLES iTable(0,k),area,xc,yc, (ii(l),jj(l),fr(l),kk(l),l=1,ng) ! for *land* tiles, ii(2) = index of Pfafstetter catchment + garea = 0.0 ctg = 0.0 @@ -264,10 +294,11 @@ subroutine WriteTilingIR(File, GridName, im, jm, ipx, nx, ny, iTable, rTable, Zi do l=0,ng-1 ii(l+1) = iTable(2 +L*2,K) jj(l+1) = iTable(3 +L*2,K) + ! kk = "dummy" variable, used internally for bookkeeping purposes, ignored by GEOS, MAPL, etc if(ng==1) then - kk(l+1) = K + kk(l+1) = K else - kk(l+1) = iTable(6 +L,K) + kk(l+1) = iTable(6 +L,K) end if if(rTable(4+L,K)/=0.0) then fr (l+1) = area / rTable(4+L,K) @@ -286,7 +317,7 @@ subroutine WriteTilingIR(File, GridName, im, jm, ipx, nx, ny, iTable, rTable, Zi end do if(present(Verb)) then - sphere = 4.*pi + sphere = 4.*PI error = (sphere-garea)/garea if(Verb) then print '(A,3e20.13)','Stats for the globe:',garea, sphere, error @@ -305,11 +336,470 @@ subroutine WriteTilingIR(File, GridName, im, jm, ipx, nx, ny, iTable, rTable, Zi close(UNIT) end if - return end subroutine WriteTilingIR +! ----------------------------------------------------------------------------------------- + +subroutine WriteTilingNC4(File, GridName, im, jm, nx, ny, iTable, rTable, N_PfafCat, rc) + + character(*), intent(IN) :: File + character(*), intent(IN) :: GridName(:) + integer, intent(IN) :: IM(:), JM(:) + integer, intent(IN) :: nx, ny + integer, intent(IN) :: iTable(:,0:) + real(REAL64), intent(IN) :: rTable(:,:) + integer, optional, intent(in) :: N_PfafCat + integer, optional, intent(out):: rc + + integer :: k, ll, ng, ip, status, n_pfafcat_ + + character(len=:), allocatable :: attr + type (Variable) :: v + type (NetCDF4_FileFormatter) :: formatter + character(len=4) :: ocn_str + type (FileMetadata) :: metadata + integer, allocatable :: II(:), JJ(:), KK(:), pfaf(:) + real(REAL64), allocatable :: fr(:) + logical :: EASE + integer, parameter :: deflate_level = 1 + + ng = size(GridName) + ip = size(iTable,1) + + EASE = .false. + if (index(GridName(1), 'EASE') /=0) EASE = .true. + + ! number of Pfafstetter catchments defined in underlying raster file + + n_pfafcat_ = SRTM_maxcat + + if (present(N_PfafCat)) n_pfafcat_ = N_PfafCat + + call metadata%add_dimension('tile', ip) + + ! ------------------------------------------------------------------- + ! + ! create nc4 variables and write metadata + + do ll = 1, ng + if (ll == 1) then + ocn_str = '' + else + ocn_str = '_ocn' + endif + + attr = 'Grid'//trim(ocn_str)//'_Name' + call metadata%add_attribute( attr, trim(GridName(ll))) + attr = 'IM'//trim(ocn_str) + call metadata%add_attribute( attr, IM(ll)) + attr = 'JM'//trim(ocn_str) + call metadata%add_attribute( attr, JM(ll)) + enddo + + attr = 'raster_nx' + call metadata%add_attribute( attr, nx) + attr = 'raster_ny' + call metadata%add_attribute( attr, ny) + attr = 'N_PfafCat' + call metadata%add_attribute( attr, n_pfafcat_) + attr = 'N_Grids' + call metadata%add_attribute( attr, ng) + + v = Variable(type=PFIO_INT32, dimensions='tile') + call v%add_attribute('units', '1') + call v%add_attribute('long_name', 'tile_type') + call v%set_deflation(DEFLATE_LEVEL) + call metadata%add_variable('typ', v) + + v = Variable(type=PFIO_REAL64, dimensions='tile') + call v%add_attribute('units', 'radian2') + call v%add_attribute('long_name', 'tile_area') + call v%add_attribute("missing_value", MAPL_UNDEF_R8) + call v%add_attribute("_FillValue", MAPL_UNDEF_R8) + call v%set_deflation(DEFLATE_LEVEL) + call metadata%add_variable('area', v) + + v = Variable(type=PFIO_REAL64, dimensions='tile') + call v%add_attribute('units', 'degree') + call v%add_attribute('long_name', 'tile_center_of_mass_longitude') + call v%add_attribute("missing_value", MAPL_UNDEF_R8) + call v%add_attribute("_FillValue", MAPL_UNDEF_R8) + call v%set_deflation(DEFLATE_LEVEL) + call metadata%add_variable('com_lon', v) + + v = Variable(type=PFIO_REAL64, dimensions='tile') + call v%add_attribute('units', 'degree') + call v%add_attribute('long_name', 'tile_center_of_mass_latitude') + call v%add_attribute("missing_value", MAPL_UNDEF_R8) + call v%add_attribute("_FillValue", MAPL_UNDEF_R8) + call v%set_deflation(DEFLATE_LEVEL) + call metadata%add_variable('com_lat', v) + + do ll = 1, ng + if (ll == 1) then + ocn_str = '' + else + ocn_str = '_ocn' + endif + + v = Variable(type=PFIO_INT32, dimensions='tile') + call v%add_attribute('units', '1') + call v%add_attribute('long_name', 'GRID'//trim(ocn_str)//'_i_index_of_tile_in_global_grid') + call v%add_attribute("missing_value", MAPL_UNDEFINED_INTEGER) + call v%set_deflation(DEFLATE_LEVEL) + call metadata%add_variable('i_indg'//trim(ocn_str), v) + + v = Variable(type=PFIO_INT32, dimensions='tile') + call v%add_attribute('units', '1') + call v%add_attribute('long_name', 'GRID'//trim(ocn_str)//'_j_index_of_tile_in_global_grid') + call v%set_deflation(DEFLATE_LEVEL) + call v%add_attribute("missing_value", MAPL_UNDEFINED_INTEGER) + call metadata%add_variable('j_indg'//trim(ocn_str), v) + + v = Variable(type=PFIO_REAL64, dimensions='tile') + call v%add_attribute('units', '1') + call v%add_attribute('long_name', 'GRID'//trim(ocn_str)//'_area_fraction_of_tile_in_grid_cell') + call v%add_attribute("missing_value", MAPL_UNDEF_R8) + call v%add_attribute("_FillValue", MAPL_UNDEF_R8) + call v%set_deflation(DEFLATE_LEVEL) + call metadata%add_variable('frac_cell'//trim(ocn_str), v) + + v = Variable(type=PFIO_INT32, dimensions='tile') + call v%add_attribute('units', '1') + call v%add_attribute('long_name', 'internal_dummy_index_of_tile') + call v%add_attribute("missing_value", MAPL_UNDEFINED_INTEGER) + call v%set_deflation(DEFLATE_LEVEL) + call metadata%add_variable('dummy_index'//trim(ocn_str), v) + enddo + + v = Variable(type=PFIO_INT32, dimensions='tile') + call v%add_attribute('units', '1') + call v%add_attribute('long_name', 'Pfafstetter_index_of_tile') + call v%add_attribute("missing_value", MAPL_UNDEFINED_INTEGER) + call v%set_deflation(DEFLATE_LEVEL) + call metadata%add_variable('pfaf_index', v) + + v = Variable(type=PFIO_REAL64, dimensions='tile') + call v%add_attribute('units', 'degree') + call v%add_attribute('long_name', 'tile_minimum_longitude') + call v%add_attribute("missing_value", MAPL_UNDEF_R8) + call v%set_deflation(DEFLATE_LEVEL) + call metadata%add_variable('min_lon', v) + + v = Variable(type=PFIO_REAL64, dimensions='tile') + call v%add_attribute('units', 'degree') + call v%add_attribute('long_name', 'tile_maximum_longitude') + call v%add_attribute("missing_value", MAPL_UNDEF_R8) + call v%set_deflation(DEFLATE_LEVEL) + call metadata%add_variable('max_lon', v) + + v = Variable(type=PFIO_REAL64, dimensions='tile') + call v%add_attribute('units', 'degree') + call v%add_attribute('long_name', 'tile_minimum_latitude') + call v%add_attribute("missing_value", MAPL_UNDEF_R8) + call v%set_deflation(DEFLATE_LEVEL) + call metadata%add_variable('min_lat', v) + + v = Variable(type=PFIO_REAL64, dimensions='tile') + call v%add_attribute('units', 'degree') + call v%add_attribute('long_name', 'tile_maximum_latitude') + call v%add_attribute("missing_value", MAPL_UNDEF_R8) + call v%set_deflation(DEFLATE_LEVEL) + call metadata%add_variable('max_lat', v) + + v = Variable(type=PFIO_REAL64, dimensions='tile') + call v%add_attribute('units', 'm') + call v%add_attribute('long_name', 'tile_mean_elevation') + call v%add_attribute("missing_value", MAPL_UNDEF_R8) + call v%set_deflation(DEFLATE_LEVEL) + call metadata%add_variable('elev', v) + + ! ------------------------------------------------------------------- + ! + ! write data into nc4 file + + call formatter%create(File, mode=PFIO_NOCLOBBER, rc=status) + call formatter%write(metadata, rc=status) + call formatter%put_var('typ', iTable(:,0), rc=status) + call formatter%put_var('area', rTable(:,3), rc=status) + call formatter%put_var('com_lon', rTable(:,1), rc=status) + call formatter%put_var('com_lat', rTable(:,2), rc=status) + + allocate(fr(ip), pfaf(ip)) + fr = MAPL_UNDEF_R8 + + do ll = 1, ng + if (ng == 1) then + if (EASE) then + KK = iTable(:,4) + pfaf = KK + else + KK =[(k, k=1,ip)] + endif + else + KK = iTable(:,5+ll) + endif + + II = iTable(:,ll*2 ) + JJ = iTable(:,ll*2 + 1) + + where( rTable(:,3+ll) /=0.0) + fr = rTable(:,3)/rTable(:,3+ll) + endwhere + + if (ll == 1) then + ocn_str='' + else + ocn_str='_ocn' + endif + + if (ll == 2) then + pfaf = MAPL_UNDEFINED_INTEGER + where (iTable(:,0) == 100) + pfaf = II + endwhere + where (iTable(:,0) == 19) + pfaf = 190000000 + endwhere + where (iTable(:,0) == 20) + pfaf = 200000000 + endwhere + + where (iTable(:,0) /=0 ) + II = MAPL_UNDEFINED_INTEGER + JJ = MAPL_UNDEFINED_INTEGER + fr = MAPL_UNDEF_R8 + endwhere + endif + + call formatter%put_var('i_indg' //trim(ocn_str), II, rc=status) + call formatter%put_var('j_indg' //trim(ocn_str), JJ, rc=status) + call formatter%put_var('frac_cell' //trim(ocn_str), fr, rc=status) + call formatter%put_var('dummy_index'//trim(ocn_str), KK, rc=status) + + if (EASE .or. ll == 2) call formatter%put_var('pfaf_index', pfaf, rc=status) + + enddo + + call formatter%put_var('min_lon', rTable(:, 6), rc=status) + call formatter%put_var('max_lon', rTable(:, 7), rc=status) + call formatter%put_var('min_lat', rTable(:, 8), rc=status) + call formatter%put_var('max_lat', rTable(:, 9), rc=status) + call formatter%put_var('elev', rTable(:,10), rc=status) + + call formatter%close(rc=status) + + if (present(rc)) rc = status + +end subroutine WriteTilingNC4 + +! ------------------------------------------------------------------------------------- + +subroutine ReadTilingNC4(File, GridName, im, jm, nx, ny, n_Grids, iTable, rTable, N_PfafCat, AVR,rc) + + character(*), intent(IN) :: File + character(*), optional, intent(out) :: GridName(:) + integer, optional, intent(out) :: IM(:), JM(:) + integer, optional, intent(out) :: nx, ny, n_Grids + integer, optional, allocatable, intent(out) :: iTable(:,:) + real(REAL64), optional, allocatable, intent(out) :: rTable(:,:) + integer, optional, intent(out) :: N_PfafCat + real, optional, allocatable, intent(out) :: AVR(:,:) ! used by GEOSgcm + integer, optional, intent(out) :: rc + + type (Attribute), pointer :: ref + character(len=:), allocatable :: attr + type (NetCDF4_FileFormatter) :: formatter + type (FileMetadata) :: meta + character(len=4) :: ocn_str + integer :: ng, ntile, status, ll + class(*), pointer :: attr_val(:) + class(*), pointer :: char_val + integer, allocatable :: tmp_int(:) + real(REAL64), allocatable :: fr(:) + + integer, parameter :: NumGlobalVars =4 + integer, parameter :: NumLocalVars =4 + integer :: NumCol + integer, allocatable :: iTable_(:,:) + real(REAL64), allocatable :: rTable_(:,:) + + call formatter%open(File, pFIO_READ, rc=status) + meta = formatter%read(rc=status) + + ntile = meta%get_dimension('tile') + + ref => meta%get_attribute('N_Grids') + attr_val => ref%get_values() + select type (attr_val) + type is (integer(INT32)) + ng = attr_val(1) + endselect + if (present(n_Grids)) then + n_Grids = ng + endif + + if (present(nx)) then + ref => meta%get_attribute('raster_nx') + attr_val => ref%get_values() + select type(attr_val) + type is (integer(INT32)) + nx = attr_val(1) + endselect + endif + if (present(ny)) then + ref => meta%get_attribute('raster_ny') + attr_val => ref%get_values() + select type (attr_val) + type is (integer(INT32)) + ny = attr_val(1) + endselect + endif + + if (present(N_PfafCat)) then + ref => meta%get_attribute('N_PfafCat') + attr_val => ref%get_values() + select type (attr_val) + type is (integer(INT32)) + N_PfafCat = attr_val(1) + endselect + endif + + do ll = 1, ng + if (ll == 1) then + ocn_str = '' + else + ocn_str = '_ocn' + endif + + if (present(GridName)) then + attr = 'Grid'//trim(ocn_str)//'_Name' + ref =>meta%get_attribute(attr) + char_val => ref%get_value() + select type(char_val) + type is(character(*)) + GridName(ll) = char_val + class default + print('unsupported subclass (not string) of attribute named '//attr) + end select + endif + if (present(IM)) then + attr = 'IM'//trim(ocn_str) + ref =>meta%get_attribute(attr) + attr_val => ref%get_values() + select type(attr_val) + type is( integer(INT32)) + IM(ll) = attr_val(1) + end select + endif + if (present(JM)) then + attr = 'JM'//trim(ocn_str) + ref =>meta%get_attribute(attr) + attr_val => ref%get_values() + select type(attr_val) + type is(integer(INT32)) + JM(ll) = attr_val(1) + end select + endif + enddo + + if (present(iTable) .or. present(AVR) ) then + allocate(iTable_(ntile,0:7)) + allocate(tmp_int(ntile)) + call formatter%get_var('typ', iTable_(:,0)) + do ll = 1, ng + if (ll == 1) then + ocn_str = '' + else + ocn_str = '_ocn' + endif + + call formatter%get_var('i_indg' //trim(ocn_str), tmp_int, rc=status) + iTable_(:,ll*2) = tmp_int + call formatter%get_var('j_indg' //trim(ocn_str), tmp_int, rc=status) + iTable_(:,ll*2+1) = tmp_int + call formatter%get_var('dummy_index'//trim(ocn_str), tmp_int, rc=status) + if ( ng == 1) then + iTable_(:,4) = tmp_int + ! set this 7th column to 1. This is to reproduce a potential bug + ! when it is ease grid and mask file is not GEOS5_10arcsec_mask + iTable_(:,7) = 1 + else + iTable_(:,5+ll) = tmp_int + endif + enddo + call formatter%get_var('pfaf_index', tmp_int, rc=status) + if (ng == 2) then + where (iTable_(:,0) == 100) + iTable_(:,4) = tmp_int + endwhere + endif + endif + + if (present(rTable) .or. present(AVR) ) then + allocate(rTable_(ntile,10)) + call formatter%get_var('com_lon', rTable_(:,1), rc=status) + call formatter%get_var('com_lat', rTable_(:,2), rc=status) + call formatter%get_var('area', rTable_(:,3), rc=status) + do ll = 1, ng + if (ll == 1) then + ocn_str = '' + else + ocn_str = '_ocn' + endif + call formatter%get_var('frac_cell' //trim(ocn_str), rTable_(:,3+ll), rc=status) + enddo + call formatter%get_var('min_lon', rTable_(:, 6), rc=status) + call formatter%get_var('max_lon', rTable_(:, 7), rc=status) + call formatter%get_var('min_lat', rTable_(:, 8), rc=status) + call formatter%get_var('max_lat', rTable_(:, 9), rc=status) + call formatter%get_var('elev', rTable_(:,10), rc=status) + endif + + if (present(AVR)) then + ! In GEOSgcm, it already assumes ng = 2, so NumCol = 10 + NumCol = NumGlobalVars+NumLocalVars*ng + allocate(AVR(ntile, NumCol)) + AVR(:, 1) = iTable_(:,0) + ! for EASE grid, the second collum is replaced by the area + AVR(:, 2) = rTable_(:,3) + AVR(:, 3) = rTable_(:,1) + AVR(:, 4) = rTable_(:,2) + + AVR(:, 5) = iTable_(:,2) + AVR(:, 6) = iTable_(:,3) + AVR(:, 7) = rTable_(:,4) + if (ng == 1) then + AVR(:,8) = iTable_(:,4) + else + AVR(:, 8) = iTable_(:,6) + + AVR(:, 9) = iTable_(:,4) + AVR(:, 10) = iTable_(:,5) + AVR(:, 11) = rTable_(:,5) + AVR(:, 12) = iTable_(:,7) + endif + endif + + if (present(iTable)) then + call move_alloc(iTable_, iTable) + endif + + if (present(rTable)) then + call move_alloc(rTable_, rTable) + do ll = 1, ng + where ( rTable(:,3+ll) /=0.0 ) rTable(:,3+ll) = rTable(:,3)/rTable(:,3+ll) + enddo + endif + + if (present(rc)) rc= status + +end subroutine ReadTilingNC4 + +! ---------------------------------------------------------------------------------- subroutine OpenTiling(Unit, File, GridName, im, jm, ip, nx, ny, Zip, Verb) + integer, intent(OUT) :: Unit character*(*), intent(IN) :: File character*(*), intent(IN) :: GridName @@ -380,16 +870,16 @@ subroutine OpenTiling(Unit, File, GridName, im, jm, ip, nx, ny, Zip, Verb) end if return -end subroutine OpenTiling - +end subroutine OpenTiling +! -------------------------------------------------------------------------- subroutine WriteLine(File, Unit, iTable, rTable, k, Zip, Verb) character*(*), intent(IN) :: File integer, intent(IN) :: Unit, k integer, intent(IN) :: iTable(0:) - real(kind=8), intent(IN) :: rTable(:) + real(REAL64), intent(IN) :: rTable(:) logical, optional, intent(IN) :: Zip logical, optional, intent(IN) :: Verb @@ -411,8 +901,8 @@ subroutine WriteLine(File, Unit, iTable, rTable, k, Zip, Verb) logical :: DoZip character*1000 :: Line integer :: ii, jj - real(kind=8) :: fr - real(kind=8) :: xc, yc, area + real(REAL64) :: fr + real(REAL64) :: xc, yc, area if(present(Zip)) then DoZip = Zip @@ -478,7 +968,7 @@ subroutine CloseTiling(FIle, Unit, ip, Zip, Verb) ! rTable(5) :: of 2nd grid box area logical :: DoZip - real(kind=8) :: sphere, error + real(REAL64) :: sphere, error character*1000 :: Line Line="" @@ -490,7 +980,7 @@ subroutine CloseTiling(FIle, Unit, ip, Zip, Verb) endif if(present(Verb)) then - sphere = 4.*pi + sphere = 4.*PI error = (sphere-garea_)/garea_ if(Verb) then print '(A,3e20.13)','Stats for the globe:',garea_, sphere, error @@ -511,9 +1001,6 @@ subroutine CloseTiling(FIle, Unit, ip, Zip, Verb) end subroutine CloseTiling - - - end module LogRectRasterizeMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/rasterize.H b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/rasterize.H index f2cf014ab..523b264f6 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/rasterize.H +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/rasterize.H @@ -54,22 +54,22 @@ character*(*), intent(INOUT) :: GridName ! Raster file name #ifdef MESH - real(kind=8), intent(INOUT) :: xv(:,:) ! X coordinates of vertices - real(kind=8), intent(INOUT) :: yv(:,:) ! Y coordinates of vertices + real(REAL64), intent(INOUT) :: xv(:,:) ! X coordinates of vertices + real(REAL64), intent(INOUT) :: yv(:,:) ! Y coordinates of vertices #else - real(kind=8), intent(INOUT) :: xv(:,:,:) ! X coordinates of vertices - real(kind=8), intent(INOUT) :: yv(:,:,:) ! Y coordinates of vertices + real(REAL64), intent(INOUT) :: xv(:,:,:) ! X coordinates of vertices + real(REAL64), intent(INOUT) :: yv(:,:,:) ! Y coordinates of vertices #endif integer, optional, intent(IN) :: nc,nr ! Raster field sizes - real(kind=8), optional, intent(IN) :: xmn ! LL x of LL raster cell (-180) - real(kind=8), optional, intent(IN) :: ymn ! LL y of LL raster cell ( -90) - real(kind=8), optional, intent(IN) :: xmx ! UR x of UR raster cell ( 180) - real(kind=8), optional, intent(IN) :: ymx ! UR y of UR raster cell ( 90) + real(REAL64), optional, intent(IN) :: xmn ! LL x of LL raster cell (-180) + real(REAL64), optional, intent(IN) :: ymn ! LL y of LL raster cell ( -90) + real(REAL64), optional, intent(IN) :: xmx ! UR x of UR raster cell ( 180) + real(REAL64), optional, intent(IN) :: ymx ! UR y of UR raster cell ( 90) logical, optional, intent(IN) :: verb ! Verbose logical, optional, intent(IN) :: here ! write here integer, optional, intent(IN) :: SurfaceType integer, optional, intent(IN) :: jseg - real(kind=8), optional :: tol + real(REAL64), optional :: tol integer, optional, intent(out) :: rc character*(128) :: TileFile @@ -191,42 +191,42 @@ integer, intent(INOUT) :: Raster(:,:) ! Raster field to be filled #ifdef MESH - real(kind=8), intent(INOUT) :: xv(:,: ) ! X coordinates of vertices - real(kind=8), intent(INOUT) :: yv(:,: ) ! Y coordinates of vertices + real(REAL64), intent(INOUT) :: xv(:,: ) ! X coordinates of vertices + real(REAL64), intent(INOUT) :: yv(:,: ) ! Y coordinates of vertices #else - real(kind=8), intent(INOUT) :: xv(:,:,:) ! X coordinates of vertices - real(kind=8), intent(INOUT) :: yv(:,:,:) ! Y coordinates of vertices + real(REAL64), intent(INOUT) :: xv(:,:,:) ! X coordinates of vertices + real(REAL64), intent(INOUT) :: yv(:,:,:) ! Y coordinates of vertices #endif character*(*), intent(IN ) :: TileFile - real(kind=8), optional, intent(IN) :: xmn ! LL x of LL raster cell (-180) - real(kind=8), optional, intent(IN) :: ymn ! LL y of LL raster cell ( -90) - real(kind=8), optional, intent(IN) :: xmx ! UR x of UR raster cell ( 180) - real(kind=8), optional, intent(IN) :: ymx ! UR y of UR raster cell ( 90) + real(REAL64), optional, intent(IN) :: xmn ! LL x of LL raster cell (-180) + real(REAL64), optional, intent(IN) :: ymn ! LL y of LL raster cell ( -90) + real(REAL64), optional, intent(IN) :: xmx ! UR x of UR raster cell ( 180) + real(REAL64), optional, intent(IN) :: ymx ! UR y of UR raster cell ( 90) logical, optional, intent(IN) :: verb ! Verbose integer, optional, intent(IN) :: SurfaceType integer, optional, intent(IN) :: jseg - real(kind=8), optional :: tol + real(REAL64), optional :: tol integer, optional, intent(out) :: rc ! X abd Y bounds of each polygon - real(kind=8) :: xmin, xmax - real(kind=8) :: ymin, ymax - real(kind=8) :: minx, miny - real(kind=8) :: maxx, maxy + real(REAL64) :: xmin, xmax + real(REAL64) :: ymin, ymax + real(REAL64) :: minx, miny + real(REAL64) :: maxx, maxy ! x and y coordinates of the Raster grid - real(kind=8), dimension(size(Raster,1)) :: xs, xcs, xss - real(kind=8), dimension(size(Raster,2)) :: ys, ycs, yss, da + real(REAL64), dimension(size(Raster,1)) :: xs, xcs, xss + real(REAL64), dimension(size(Raster,2)) :: ys, ycs, yss, da integer :: IM, JM, NV ! Shape of input grid - real(kind=8) :: dx, dy, dxi, dyi ! Grid spacing of raster grid + real(REAL64) :: dx, dy, dxi, dyi ! Grid spacing of raster grid integer :: xsize, ysize ! Dimensions of Raster grid integer :: i, j, jn, n, ib, jb, fill, uType, js, k - real(kind=8) :: range, d2r, r2d, ddx, grid_ymin, grid_ymax, xc, yc, Area, xx + real(REAL64) :: range, d2r, r2d, ddx, grid_ymin, grid_ymax, xc, yc, Area, xx logical :: DoZip, uVerb integer :: idx, ct integer :: count0,count1,count_rate @@ -235,18 +235,18 @@ character*(128) :: GridName, TilFile integer, allocatable :: iTable(:,:) - real(kind=8), allocatable :: rTable(:,:) + real(REAL64), allocatable :: rTable(:,:) integer :: useg, unit, fq integer, dimension(POLYSIZE) & :: nxt - real(kind=8), dimension(POLYSIZE) & + real(REAL64), dimension(POLYSIZE) & :: xvc, yvc, xvs, yvs, xrd, yrd, x3, y3, z3, & dx3, dy3, dz3, x31, x32, y31, y32, z31, z32, & dx4, dy4, x4, y4, xu, yu - real(kind=8) :: tol_ + real(REAL64) :: tol_ ! Process optionals @@ -558,14 +558,14 @@ subroutine FillPoly(sh) - real(kind=8), intent(IN) :: sh + real(REAL64), intent(IN) :: sh logical :: IsIn integer :: i1, i2, jj1 integer :: ii, jj, n1, n2, jx integer, save :: j1, j2 integer :: HALO=10 - real(kind=8) :: x0, y0 + real(REAL64) :: x0, y0 if (abs(miny+90._8) < 1.e-10_8) then diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/rmTinyCatchParaMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/rmTinyCatchParaMod.F90 index d7867004d..307934f61 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/rmTinyCatchParaMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/rmTinyCatchParaMod.F90 @@ -9,43 +9,56 @@ module rmTinyCatchParaMod use LDAS_DateTimeMod use MAPL_ConstantsMod - use MAPL_Base, ONLY: MAPL_UNDEF - use lsm_routines, ONLY: sibalb - + use MAPL_Base, ONLY: MAPL_UNDEF + use MAPL, only: MAPL_WriteTilingNC4 + use lsm_routines, ONLY: sibalb + use LogRectRasterizeMod, ONLY: SRTM_maxcat, MAPL_UNDEF_R8 + use, intrinsic :: iso_fortran_env, only: REAL64 implicit none + logical, parameter :: error_file=.true. integer, parameter :: n_SoilClasses = 253 - real, parameter :: zks = 2.0 + real, parameter :: zks = 2.0 integer, parameter :: i_raster = 8640, j_raster=4320 integer, parameter :: ncat_gswp2 = 15238 - REAL, PARAMETER :: undef = 1.e+20 - integer, parameter :: arr_len = 1734915,ip1 =0 - real, parameter :: dx_gswp2 =1.,dy_gswp2=1. + REAL, PARAMETER :: undef = 1.e+20 + integer, parameter :: arr_len = 1734915 + integer, parameter :: ip1 =0 ! index offset for land tiles within all vector of all tiles (ip1=0 => land tiles are first) + real, parameter :: dx_gswp2 =1.,dy_gswp2=1. integer, parameter :: MAX_NOF_GRID = ncat_gswp2 integer, PARAMETER :: nbdep=150, NAR=1000,nwt=81,nrz=41 - real, parameter :: slice=0.1, lim =5.,grzdep =1.1 - logical, parameter :: bug =.false. - include 'netcdf.inc' + real, parameter :: slice=0.1, lim =5.,grzdep =1.1 + logical, parameter :: bug =.false. + + include 'netcdf.inc' + logical :: preserve_soiltype = .false. + + ! Bugfix for Target_mean_land_elev: + ! Previously, the hardcoded value 614.649 m was used as the target mean land elevation. + ! This was incorrect because it did not account for the proper cosine-lat-weighted mean over land. + ! The correct value, 656.83 m, is derived from NCAR GMTED TOPO 30arcsec dataset. + ! This ensures that land elevation adjustment is based on the correct reference mean land elevation. + real*8, parameter :: Target_mean_land_elev = 656.83D0 ! cosine-lat-weighted mean land elev from NCAR GMTED TOPO 30arcsec + private - - public remove_tiny_tiles,modis_alb_on_tiles - public catchment_def,soil_para_high - public create_soil_types_files,compute_mosaic_veg_types + + public Target_mean_land_elev + public modis_alb_on_tiles + public supplemental_tile_attributes, soil_para_high + public create_soil_types_files, compute_mosaic_veg_types public cti_stat_file, create_model_para_woesten - public create_model_para, modis_lai,regridraster,regridrasterreal - public i_raster, j_raster,regridraster1,regridraster2,n_SoilClasses,zks - public mineral_perc, process_gswp2_veg,center_pix, soil_class - public tgen, sat_param,REFORMAT_VEGFILES,base_param,ts_param - public :: Get_MidTime, Time_Interp_Fac, compute_stats - public :: ascat_r0, jpl_canoph, NC_VarID, init_bcs_config - - INTEGER, PARAMETER, public:: SRTM_maxcat = 291284 - + public create_model_para, regridraster, regridrasterreal + public i_raster, j_raster, regridraster1, regridraster2, n_SoilClasses, zks + public mineral_perc, process_gswp2_veg, center_pix, soil_class + public REFORMAT_VEGFILES + public Get_MidTime, Time_Interp_Fac + public ascat_r0, jpl_canoph, NC_VarID, init_bcs_config + ! The following variables define the details of the BCS version (data sources). ! Initialize to dummy values here and set to desired values in init_bcs_config(). - + logical, public, save :: use_PEATMAP = .false. logical, public, save :: jpl_height = .false. character*8, public, save :: LAIBCS = 'UNDEF' @@ -54,9 +67,9 @@ module rmTinyCatchParaMod character*10, public, save :: SNOWALB = 'UNDEF' character*5, public, save :: OUTLETV = 'UNDEF' REAL, public, save :: GNU = MAPL_UNDEF - + character*512 :: MAKE_BCS_INPUT_DIR - + type :: mineral_perc real :: clay_perc real :: silt_perc @@ -64,9 +77,9 @@ module rmTinyCatchParaMod end type mineral_perc contains - - SUBROUTINE init_bcs_config (LBCSV) - + + SUBROUTINE init_bcs_config(LBCSV) + ! determine BCs details from land BCs version string (LBCSV) ! ! LAIBCS: Leaf-Area-Index data set. DEFAULT : MODGEO @@ -99,12 +112,10 @@ SUBROUTINE init_bcs_config (LBCSV) ! v2 : Outlet locations file produced by run_routing_raster.py using routing information encoded ! in SRTM-based Pfafstetter catchments and Greenland outlets info provided by Lauren Andrews. - implicit none - character(*), intent (in) :: LBCSV ! land BCs version select case (trim(LBCSV)) - + case ("F25") LAIBCS = 'GSWP2' SOILBCS = 'NGDC' @@ -114,7 +125,7 @@ SUBROUTINE init_bcs_config (LBCSV) GNU = 2.17 use_PEATMAP = .false. jpl_height = .false. - + case ("GM4", "ICA") LAIBCS = 'GSWP2' SOILBCS = 'NGDC' @@ -135,7 +146,7 @@ SUBROUTINE init_bcs_config (LBCSV) use_PEATMAP = .false. jpl_height = .false. - case ("NL4") + case ("NL4") LAIBCS = 'MODGEO' SOILBCS = 'HWSD' MODALB = 'MODIS2' @@ -145,7 +156,7 @@ SUBROUTINE init_bcs_config (LBCSV) use_PEATMAP = .false. jpl_height = .true. - case ("NL5") + case ("NL5") LAIBCS = 'MODGEO' SOILBCS = 'HWSD' MODALB = 'MODIS2' @@ -155,7 +166,7 @@ SUBROUTINE init_bcs_config (LBCSV) use_PEATMAP = .true. jpl_height = .true. - case ("v06") + case ("v06") LAIBCS = 'MODGEO' SOILBCS = 'HWSD' MODALB = 'MODIS2' @@ -165,7 +176,7 @@ SUBROUTINE init_bcs_config (LBCSV) use_PEATMAP = .true. jpl_height = .true. - case ("v07") + case ("v07") LAIBCS = 'MODGEO' SOILBCS = 'HWSD' MODALB = 'MODIS2' @@ -174,8 +185,8 @@ SUBROUTINE init_bcs_config (LBCSV) GNU = 1.0 use_PEATMAP = .true. jpl_height = .false. - - case ("v08") + + case ("v08") LAIBCS = 'MODGEO' SOILBCS = 'HWSD' MODALB = 'MODIS2' @@ -185,7 +196,7 @@ SUBROUTINE init_bcs_config (LBCSV) use_PEATMAP = .false. jpl_height = .false. - case ("v09") + case ("v09") LAIBCS = 'MODGEO' SOILBCS = 'HWSD' MODALB = 'MODIS2' @@ -195,7 +206,7 @@ SUBROUTINE init_bcs_config (LBCSV) use_PEATMAP = .true. jpl_height = .false. - case ("v10") + case ("v10") LAIBCS = 'MODGEO' SOILBCS = 'HWSD' MODALB = 'MODIS2' @@ -205,7 +216,7 @@ SUBROUTINE init_bcs_config (LBCSV) use_PEATMAP = .true. jpl_height = .false. - case ("v11") + case ("v11") LAIBCS = 'MODGEO' SOILBCS = 'HWSD' MODALB = 'MODIS2' @@ -215,7 +226,13 @@ SUBROUTINE init_bcs_config (LBCSV) use_PEATMAP = .true. jpl_height = .true. - case ("v12") + case ("v12","v13") + + ! "v12" and "v13" are identical except for: + ! - topography used for the atm (processed outside of make_bcs) + ! - bug fix for land elevation in catchment.def file + ! - generation of nc4-formatted tile file + LAIBCS = 'MODGEO' SOILBCS = 'HWSD_b' MODALB = 'MODIS2' @@ -226,33 +243,35 @@ SUBROUTINE init_bcs_config (LBCSV) jpl_height = .true. case default - + print *,'init_bcs_config(): unknown land boundary conditions version (LBCSV)' stop - + end select - + END SUBROUTINE init_bcs_config -! _____________________________________________________________________________________________ -! - - SUBROUTINE Get_MidTime ( & - yr1,mn1,dy1,yr2,mn2,dy2, & - MIDT) - implicit none - real, intent (in) :: yr1,mn1,dy1,yr2,mn2,dy2 - type(date_time_type), intent(out ) :: MIDT - type(date_time_type) :: TIME1, TIME2 - integer :: TIMEDIF - + ! -------------------------------------------------------------------------------------------- + + SUBROUTINE Get_MidTime ( & + yr1,mn1,dy1,yr2,mn2,dy2, & + MIDT) + + real, intent(in) :: yr1,mn1,dy1,yr2,mn2,dy2 + type(date_time_type), intent(out) :: MIDT + + ! ------------ + + type(date_time_type) :: TIME1, TIME2 + integer :: TIMEDIF + TIME1%year = NINT(yr1) + 2001 TIME1%month = NINT(mn1) TIME1%day = NINT(dy1) TIME1%hour = 0 TIME1%min = 0 TIME1%sec = 0 - + call get_dofyr_pentad(TIME1) MIDT = TIME1 @@ -263,144 +282,136 @@ SUBROUTINE Get_MidTime ( & TIME2%min = 59 TIME2%sec = 59 call get_dofyr_pentad(TIME2) - + TIMEDIF = datetime2_minus_datetime1(TIME1,TIME2) TIMEDIF = TIMEDIF/2 - + call augment_date_time(TIMEDIF, MIDT) -! print *,'MIDTIME' -! print *,'TIME1:', time1 -! print *,'MIDT :', midt -! print *,'TIME2:', time2 - + + ! print *,'MIDTIME' + ! print *,'TIME1:', time1 + ! print *,'MIDT :', midt + ! print *,'TIME2:', time2 + END SUBROUTINE Get_MidTime + + ! --------------------------------------------------------------------------------------------- + + SUBROUTINE Time_Interp_Fac (TIME0, TIME1, TIME2, FAC1, FAC2) -! -! --------------------------------------------------------------------------------------------- -! - -SUBROUTINE Time_Interp_Fac (TIME0, TIME1, TIME2, FAC1, FAC2) - -implicit none -! PURPOSE: -! ======== -! -! Compute interpolation factors, fac, to be used -! in the calculation of the instantaneous boundary -! conditions, ie: -! -! q(i,j) = fac1*q1(i,j) + (1.-fac1)*q2(i,j) -! -! where: -! q(i,j) => Boundary Data valid at time0 -! q1(i,j) => Boundary Data centered at time1 -! q2(i,j) => Boundary Data centered at time2 - -! INPUT: -! ====== -! time0 : Time of current timestep -! time1 : Time of boundary data 1 -! time2 : Time of boundary data 2 - -! OUTPUT: -! ======= -! fac1 : Interpolation factor for Boundary Data 1 -! - + ! PURPOSE: + ! ======== + ! + ! Compute interpolation factors, fac, to be used + ! in the calculation of the instantaneous boundary + ! conditions, ie: + ! + ! q(i,j) = fac1*q1(i,j) + (1.-fac1)*q2(i,j) + ! + ! where: + ! q(i,j) => Boundary Data valid at time0 + ! q1(i,j) => Boundary Data centered at time1 + ! q2(i,j) => Boundary Data centered at time2 + + ! INPUT: + ! ====== + ! time0 : Time of current timestep + ! time1 : Time of boundary data 1 + ! time2 : Time of boundary data 2 + + ! OUTPUT: + ! ======= + ! fac1 : Interpolation factor for Boundary Data 1 + ! + type(date_time_type), intent(in ) :: TIME0, TIME1, TIME2 - real, intent(out) :: FAC1 - real, intent(out) :: FAC2 + real, intent(out) :: FAC1 + real, intent(out) :: FAC2 real :: TimeDif1 real :: TimeDif -! print *,'Interpolation' -! print *,'TIME1:', time1 -! print *,'TIME0:', time0 -! print *,'TIME2:', time2 + ! print *,'Interpolation' + ! print *,'TIME1:', time1 + ! print *,'TIME0:', time0 + ! print *,'TIME2:', time2 + TimeDif1 = real(datetime2_minus_datetime1(TIME0,TIME2)) TimeDif = real(datetime2_minus_datetime1(TIME1,TIME2)) - + FAC1 = TimeDif1/TimeDif - + FAC2 = 1.-FAC1 + + ! print *,fac1,fac2 + + END SUBROUTINE Time_Interp_Fac + + ! --------------------------------------------------------------------- + + SUBROUTINE process_gswp2_veg (nc,nr,regrid,vname, n_land, tile_id,merge) + + integer, intent(in) :: nc, nr + logical, intent(in) :: regrid + integer, intent(in) :: n_land + integer, intent(in) :: tile_id(:,:) + character(*), intent(in) :: vname -! print *,fac1,fac2 - -END SUBROUTINE Time_Interp_Fac - - -! --------------------------------------------------------------------- -! --------------------------------------------------------------------- -SUBROUTINE process_gswp2_veg (nc,nr,regrid,vname,fnameRst,merge) - -implicit none - integer, intent(in) :: nc,nr - real, dimension (:), allocatable :: catforc,vecforc,catcount - integer, allocatable, target, dimension (:,:) :: gswp2_mask - integer, allocatable, dimension (:,:) :: tile_id - integer, parameter :: MAX_NOF_GRID = 15238 - REAL, ALLOCATABLE :: mon_climate(:,:) - integer :: ierr, ncid,iret, maxcat - integer :: i1,k1,n,iv,year,smon,imon,mon,i,j,status - REAL, PARAMETER :: undef = 1.e+20,UNDEF_GSWP2=-9999. - integer :: k,ncatch - integer :: yr,mn,yr1,mn1 - logical :: regrid - integer, pointer :: Raster(:,:) - character(*) :: vname,fnameRst - character*100 :: fname + integer, intent(in), optional :: merge + + ! ------------------------------------------------------------- - integer, intent(in), optional :: merge + integer, parameter :: MAX_NOF_GRID = 15238 + REAL, PARAMETER :: undef = 1.e+20 + REAL, PARAMETER :: UNDEF_GSWP2 = -9999. + + real, allocatable, dimension(:) :: catforc,vecforc,catcount + integer, allocatable, target, dimension(:,:) :: gswp2_mask + REAL, ALLOCATABLE :: mon_climate(:,:) + integer :: ierr, ncid,iret + integer :: i1,k1,n,iv,year,smon,imon,mon,i,j,status + integer :: k,ncatch + integer :: yr,mn,yr1,mn1 + integer, pointer :: Raster(:,:) + character*512 :: fname + + ! ----------------------------------------------------------------- - open (10,file=trim(fnameRst)//'.rst',status='old',action='read', & - form='unformatted',convert='little_endian') - + allocate (gswp2_mask (1:i_raster,1:j_raster)) - allocate (tile_id (1:nc,1:nr)) - - do j=1,nr - read(10)tile_id(:,j) - end do - close (10,status='keep') - + call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) open (10,file=trim(MAKE_BCS_INPUT_DIR)//'/shared/mask/mapping_2.5_grid_to_gswp2_tile_index.rst',& - form='unformatted',status='old',action='read',convert='little_endian') - + form='unformatted',status='old',action='read',convert='little_endian') + do j =1,j_raster - read (10) gswp2_mask(:,j) + read (10) gswp2_mask(:,j) end do close (10,status='keep') - + if(regrid) then allocate(raster(nc,nr),stat=STATUS); VERIFY_(STATUS) else raster => gswp2_mask end if - + if(regrid) then call RegridRaster(gswp2_mask,raster) - endif - - fname='clsm/catchment.def' - open (10,file=fname,status='old',action='read',form='formatted') - read (10,*)maxcat - close (10,status='keep') - + endif + allocate(vecforc(1:MAX_NOF_GRID)) - allocate(catforc(maxcat)) - allocate(catcount(maxcat)) - allocate(mon_climate(1:maxcat,1:12)) + allocate(catforc(n_land)) + allocate(catcount(n_land)) + allocate(mon_climate(1:n_land,1:12)) mon_climate(:,:)=0. catforc=0. - + mon_climate(:,:)=0. - + iret = NF_OPEN(trim(MAKE_BCS_INPUT_DIR)//'/land/veg/lai_grn/'//trim(vname)//'_uk.nc',NF_NOWRITE, ncid) - + ASSERT_(iret==NF_NOERR) - + if (present (merge)) then open (31,file='clsm/lai.dat.gswp2', & form='unformatted',status='unknown',convert='little_endian') @@ -412,1087 +423,399 @@ SUBROUTINE process_gswp2_veg (nc,nr,regrid,vname,fnameRst,merge) endif do year=82,98 - + smon=(year-82)*12 imon=0 do mon=smon+1,smon+12 imon=imon+1 iret = NF_GET_VARA_REAL(ncid, 6,(/1,mon/),(/MAX_NOF_GRID,1/),vecforc) - ASSERT_(iret==NF_NOERR) - catforc =1.e-20 - catcount=0 + ASSERT_(iret==NF_NOERR) + catforc =1.e-20 + catcount=0 DO j =1,nr - DO I = 1,nc - if((tile_id(i,j).gt.0).and.(tile_id(i,j).le.maxcat)) then - if ((Raster(i,j).ge.1).and.(Raster(i,j).le.MAX_NOF_GRID)) then - catforc(tile_id(i,j)) = catforc(tile_id(i,j)) + & - vecforc(Raster(i,j)) - catcount(tile_id(i,j)) = catcount(tile_id(i,j)) + 1. - endif - endif - END DO + DO I = 1,nc + if((tile_id(i,j).gt.0).and.(tile_id(i,j).le.n_land)) then + if ((Raster(i,j).ge.1).and.(Raster(i,j).le.MAX_NOF_GRID)) then + catforc(tile_id(i,j)) = catforc(tile_id(i,j)) + & + vecforc(Raster(i,j)) + catcount(tile_id(i,j)) = catcount(tile_id(i,j)) + 1. + endif + endif + END DO END DO - do i = 1, maxcat - if(catcount(i).gt.0.) catforc(i) = catforc (i) /catcount(i) - end do + do i = 1, n_land + if(catcount(i).gt.0.) catforc(i) = catforc (i) /catcount(i) + end do mon_climate(:,imon)=mon_climate(:,imon)+catforc(:)/17. - - END DO + + END DO END DO ! Year iret = NF_CLOSE(ncid) ASSERT_(iret==NF_NOERR) - fname='clsm/catchment.def' - - open (10,file=fname,status='old',action='read',form='formatted') - read (10,*) ncatch - close(10,status='keep') - + ncatch = n_land + do K=0,13 - yr = (k+11)/12 - mn = mod(k+11,12)+1 - yr1= (k+12)/12 - mn1= mod(k+12,12)+1 - write(31) float((/yr,mn,1,0,0,0,yr1,mn1,1,0,0,0,ncatch,1/)) - write(31) mon_climate(:,mod(k+11,12)+1) - end do + yr = (k+11)/12 + mn = mod(k+11,12)+1 + yr1= (k+12)/12 + mn1= mod(k+12,12)+1 + write(31) float((/yr,mn,1,0,0,0,yr1,mn1,1,0,0,0,ncatch,1/)) + write(31) mon_climate(:,mod(k+11,12)+1) + end do close(31,status='keep') - + deallocate(catforc) deallocate(mon_climate) deallocate(vecforc) deallocate(catcount) deallocate(gswp2_mask) - deallocate(tile_id) - if(regrid) then - deallocate(raster) - endif - -END SUBROUTINE process_gswp2_veg - - -! --------------------------------------------------------------------- -!---------------------------------------------------------------------- - -SUBROUTINE modis_lai (nx,ny,regrid,gfile) - -implicit none -type (date_time_type) :: before_time,after_time,end_time -character*300 :: fout,fname -character(*) :: gfile -integer :: i, n, k,j,ncatch -integer :: yr,mn,dy,yr1,mn1,dy1 -real, dimension (:,:), target, allocatable :: lai_grid -real, dimension (:), allocatable :: lai,count -character*5 :: mmdd -integer, allocatable, dimension (:,:) :: tile_id -integer :: i_sib,j_sib -integer :: nx,ny,status -logical :: regrid -real, pointer :: Raster(:,:) - -allocate(tile_id(1:nx,1:ny)) -i_sib = i_raster -j_sib = j_raster - -fname=trim(gfile)//'.rst' -open (10,file=fname,status='old',action='read', & - form='unformatted',convert='little_endian') - - do j=1,ny - read(10)tile_id(:,j) - end do - - close (10,status='keep') - -before_time%year =2001 -before_time%month =1 -before_time%day =1 -before_time%hour =0 -before_time%min =0 -before_time%sec =0 -before_time%pentad =1 -before_time%dofyr =1 - -end_time%year =2001 -end_time%month =12 -end_time%day =31 -end_time%hour =23 -end_time%min =59 -end_time%sec =59 -end_time%pentad =73 -end_time%dofyr =365 - -after_time = before_time - -do j =1,8 - call augment_date_time (86400, after_time) -end do - -fname='clsm/catchment.def' - -open (10,file=fname,status='old',action='read',form='formatted') -read (10,*) ncatch -close(10,status='keep') - -allocate (lai_grid (1:i_sib,1:j_sib)) -allocate (lai (1:ncatch)) -allocate (count (1:ncatch)) - -call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) -fname = trim(MAKE_BCS_INPUT_DIR)//'/MODIS_8-DayClim/' & -//'MOD15A2.YYYY.12.27.global_2.5min.data' - -!write (*,'(a120)')trim(fname) -!write (*,'(2(f2.0,2f3.0,3f2.0),f9.0,f2.0)') float((/0,12,27,0,0,0,1,1,1,0,0,0,ncatch,1/)) -open (20,file=trim(fname),form='unformatted',convert='little_endian', & - action='read',status='old') - -do j =1,j_raster - read (20) lai_grid (:,j) -end do -close(20,status='keep') -lai = 0. -count = 0. - -if(regrid) then - allocate(raster(nx,ny),stat=STATUS); VERIFY_(STATUS) -else - raster => lai_grid -end if - -if(regrid) then - call RegridRasterReal(lai_grid,raster) -endif - - -do j=1,ny - do i=1,nx - if((tile_id(i,j).gt.0).and.(tile_id(i,j).le.ncatch)) then - if((raster (i,j).ge.0.).and.(raster (i,j).le.10.)) then - lai (tile_id(i,j)) = & - lai(tile_id(i,j)) + raster(i,j) - count(tile_id(i,j)) = & - count(tile_id(i,j)) + 1. - endif - endif - end do -end do - -DO n =1,ncatch - if(count(n)/=0.) lai(n)=lai(n)/count(n) -END DO - -fout = 'clsm/lai.dat' -open (30,file=trim(fout),form='unformatted',convert='little_endian', & - action='write',status='unknown') - -write(30) float((/0,12,27,0,0,0,1,1,1,0,0,0,ncatch,1/)) -write (30) lai - -do while (datetime_le_refdatetime(before_time,end_time)) - - yr = before_time%year -2000 !(k+11)/12 - mn = before_time%month !mod(k+11,12)+1 - dy = before_time%day - yr1= after_time%year -2000 !(k+12)/12 - mn1= after_time%month !mod(k+12,12)+1 - dy1= after_time%day - write (mmdd,'(i2.2,a1,i2.2)'),mn,'.',dy - - fname =trim(MAKE_BCS_INPUT_DIR)//'/MODIS_8-DayClim/' & - //'MOD15A2.YYYY.'//mmdd//'.global_2.5min.data' - - open (20,file=trim(fname),form='unformatted',convert='little_endian', & - action='read',status='old') - do j =1,j_raster - read (20) lai_grid (:,j) - end do - close (20,status='keep') - - if(regrid) then - call RegridRasterReal(lai_grid,raster) - else - raster => lai_grid - endif - - lai = 0. - count = 0. - - do j=1,ny - do i=1,nx - if((tile_id(i,j).gt.0).and.(tile_id(i,j).le.ncatch)) then - if((raster (i,j).ge.0.).and.(raster (i,j).le.10.)) then - lai (tile_id(i,j)) = & - lai(tile_id(i,j)) + raster(i,j) - count(tile_id(i,j)) = & - count(tile_id(i,j)) + 1. - endif - endif - end do - end do - -DO n =1,ncatch - if(count(n)/=0.) lai(n)=lai(n)/count(n) -END DO - if(mmdd.eq.'12.27') dy1 = 1 -! write(*,'(2(f2.0,2f3.0,3f2.0),f9.0,f2.0)') float((/yr,mn,dy,0,0,0,yr1,mn1,dy1,0,0,0,ncatch,1/)) - write(30) float((/yr,mn,dy,0,0,0,yr1,mn1,dy1,0,0,0,ncatch,1/)) - write (30) lai - - do j =1,8 - call augment_date_time (86400, before_time) - call augment_date_time (86400, after_time ) - end do -end do - -fname = trim(MAKE_BCS_INPUT_DIR)//'/MODIS_8-DayClim/' & -//'MOD15A2.YYYY.01.01.global_2.5min.data' - -!write (*,'(a120)')trim(fname) -open (20,file=trim(fname),form='unformatted',convert='little_endian', & - action='read',status='old') - -do j =1,j_raster - read (20) lai_grid (:,j) -end do -close(20,status='keep') - -if(regrid) then - call RegridRasterReal(lai_grid,raster) - else - raster => lai_grid -endif - -lai = 0. -count = 0. - -do j=1,ny - do i=1,ny - if((tile_id(i,j).gt.0).and.(tile_id(i,j).le.ncatch)) then - if((raster (i,j).ge.0.).and.(raster (i,j).le.10.)) then - lai (tile_id(i,j)) = & - lai(tile_id(i,j)) + raster(i,j) - count(tile_id(i,j)) = & - count(tile_id(i,j)) + 1. - endif - endif - end do -end do - -DO n =1,ncatch - if(count(n)/=0.) lai(n)=lai(n)/count(n) -END DO - -! write(*,'(2(f2.0,2f3.0,3f2.0),f9.0,f2.0)') float((/2,1,1,0,0,0,2,1,9,0,0,0,ncatch,1/)) -write(30) float((/2,1,1,0,0,0,2,1,9,0,0,0,ncatch,1/)) -write(30) lai - if(regrid) then deallocate(raster) endif -close(30,status='keep') - -END SUBROUTINE modis_lai - -!---------------------------------------------------------------------- - - SUBROUTINE soil_para_high (nx,ny,regrid,gfile,F25Tag) - - implicit none - real, dimension(12) :: lbee,lpsis,lporo,lcond,lwpwet, & - atau2,btau2,atau5,btau5 - REAL, ALLOCATABLE :: soildepth (:) - INTEGER :: soil_class_top,soil_class_com,soil_gswp,swit - REAL :: BEE, PSIS, POROS,COND,WPWET - integer :: n,maxcat,count,k1,i1,i,j - character*100 :: path,fname,fout,metpath - character(*) :: gfile - character*10 :: dline - CHARACTER*20 :: version,resoln,continent - integer :: iret,ncid,ncid1 - real, allocatable, target, dimension (:,:) :: SOIL_HIGH - integer, allocatable, dimension (:,:) :: tile_id - REAL, ALLOCATABLE :: count_soil(:) - integer :: tindex, pfafindex,i_sib,j_sib - integer :: nx,ny,status - real, allocatable, dimension(:) :: soildepth_gswp2 - integer, allocatable, dimension (:) :: land_gswp2 - logical :: regrid - real, pointer :: Raster(:,:) - logical, intent (in), optional :: F25Tag - logical :: file_exists - real, allocatable, dimension (:,:) :: parms4file - - -! --------- VARIABLES FOR *OPENMP* PARALLEL ENVIRONMENT ------------ -! -! NOTE: "!$" is for conditional compilation -! -logical :: running_omp = .false. -! -!$ integer :: omp_get_thread_num, omp_get_num_threads -! -integer :: n_threads=1 -! -! ------------------------------------------------------------------ + + END SUBROUTINE process_gswp2_veg - ! ----------- OpenMP PARALLEL ENVIRONMENT ---------------------------- - ! - ! FIND OUT WHETHER -omp FLAG HAS BEEN SET DURING COMPILATION - ! - !$ running_omp = .true. ! conditional compilation + !---------------------------------------------------------------------- ! - ! ECHO BASIC OMP VARIABLES + ! SUBROUTINE modis_lai (nx,ny,regrid,gfile) ! - !$OMP PARALLEL DEFAULT(NONE) SHARED(running_omp,n_threads) + ! apparently not used; removed by reichle, 24 Dec 2024 ! - !$OMP SINGLE - ! - !$ n_threads = omp_get_num_threads() - ! - !$ write (*,*) 'running_omp = ', running_omp - !$ write (*,*) - !$ write (*,*) 'parallel OpenMP with ', n_threads, 'threads' - !$ write (*,*) - !$OMP ENDSINGLE - ! - !$OMP CRITICAL - !$ write (*,*) 'thread ', omp_get_thread_num(), ' alive' - !$OMP ENDCRITICAL - ! - !$OMP BARRIER - ! - !$OMP ENDPARALLEL - ! ----------- OpenMP PARALLEL ENVIRONMENT ---------------------------- - - data lbee /3.30, 3.80, 4.34, 5.25, 3.63, 5.96, 7.32, & - 8.41, 8.34, 9.70, 10.78, 12.93/ - data lpsis /-0.05, -0.07, -0.16, -0.65, -0.84, -0.24, & - -0.12, -0.63, -0.28, -0.12, -0.58, -0.27/ - data lporo /0.373, 0.386, 0.419, 0.476, 0.471, 0.437, & - 0.412, 0.478, 0.447, 0.415, 0.478, 0.450/ - data lcond /2.45e-05, 1.75e-05, 8.35e-06, 2.36e-06, & - 1.1e-06, 4.66e-06, 6.31e-06, 1.44e-06, & - 2.72e-06, 4.25e-06, 1.02e-06, 1.33e-06/ - data lwpwet /0.033,0.051,0.086,0.169,0.045,0.148,0.156, & - 0.249,0.211,0.199,0.286,0.276/ - - data atau2/0.0030065,0.0276075,0.0200614,0.0165152, & - 0.0165152,0.0168748,0.0308809,0.0329365, & - 0.0437085,0.0466403,0.0956670,0.1257360/ - - data btau2/0.0307900,0.0196558,0.0299702,0.0443406, & - 0.0443406,0.0359961,0.0234851,0.0370919, & - 0.0312746,0.0249973,0.0222786,0.0193874/ - - data atau5/0.0067424,0.0766189,0.0540989,0.0439714, & - 0.0439714,0.0457011,0.0589881,0.0885157, & - 0.1175960,0.0692305,0.1348880,0.1535540/ - - data btau5/0.0569718,0.0492634,0.0678898,0.0786387, & - 0.0786387,0.0737872,0.0713841,0.0742609, & - 0.0693533,0.0745496,0.0732726,0.0718882/ - - i_sib = i_raster - j_sib = j_raster - - fname='clsm/catchment.def' - - open (10,file=fname,status='old',action='read',form='formatted') - read(10,*) maxcat - close (10,status='keep') - - allocate(soildepth(maxcat)) - allocate(soil_high(1:i_raster,1:j_raster)) - allocate(count_soil(1:maxcat)) - allocate(tile_id(1:nx,1:ny)) - - inquire(file='clsm/catch_params.nc4', exist=file_exists) - - if(file_exists) then - status = NF_OPEN ('clsm/catch_params.nc4', NF_WRITE, ncid) ; VERIFY_(STATUS) - allocate (parms4file (1:maxcat, 1:10)) - endif - - soil_high =-9999. - fname=trim(gfile)//'.rst' - - open (10,file=fname,status='old',action='read', & - form='unformatted',convert='little_endian') - - do j=1,ny - read(10)tile_id(:,j) - end do - - close (10,status='keep') - - call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) - - if (present(F25Tag)) then - - iret = NF_OPEN(trim(MAKE_BCS_INPUT_DIR)//'/land/soil/SOIL-DATA/soil_depth/v1/SoilDepth.nc',NF_NOWRITE, ncid1) - ASSERT_(iret==NF_NOERR) - allocate (soildepth_gswp2(1: ncat_gswp2)) - allocate (land_gswp2 (1: ncat_gswp2)) - iret = NF_GET_VARA_INT (ncid1, 3,(/1/),(/ncat_gswp2/),land_gswp2) - ASSERT_(iret==NF_NOERR) - iret = NF_GET_VARA_REAL(ncid1, 4,(/1/),(/ncat_gswp2/),soildepth_gswp2) - ASSERT_(iret==NF_NOERR) - iret = NF_CLOSE(ncid1) - ASSERT_(iret==NF_NOERR) - - k1 = i_raster/360 - - do n = 1,ncat_gswp2 - - j = (land_gswp2(n)-1)/360 + 1 - i = land_gswp2(n) - (j - 1)*360 - j = 181 - j - soil_high((i-1)*k1+1:i*k1,(j-1)*k1+1:j*k1) = soildepth_gswp2(n) - - end do - deallocate (soildepth_gswp2,land_gswp2) - else - - open (10,file=trim(MAKE_BCS_INPUT_DIR)//'/land/soil/SOIL-DATA/soil_depth/v1/soil_depth_2.5.rst',& - form='unformatted',status='old',action='read',convert='little_endian') - - do j =1,j_raster - read (10) soil_high(:,j) - end do - close (10,status='keep') - - endif - - if(regrid) then - allocate(raster(nx,ny),stat=STATUS); VERIFY_(STATUS) - else - raster => soil_high - end if - - if(regrid) then - call RegridRasterReal(soil_high,raster) - endif - - soildepth =0. - count_soil = 0. + !---------------------------------------------------------------------- + + SUBROUTINE soil_para_high (nx,ny,regrid, n_land, tile_id, F25Tag) + + integer, intent(in) :: nx, ny + logical, intent(in) :: regrid + integer, intent(in) :: n_land + integer, intent(in) :: tile_id(:,:) + logical, intent (in), optional :: F25Tag - do j=1,ny - do i=1,nx - if((tile_id(i,j).gt.0).and.(tile_id(i,j).le.maxcat)) then - if(raster(i,j).eq.-9999.) then -! write (*,*)'soil_high UNDEF',i,j,tile_id(i,j),raster(i,j) - ! stop - endif - if (raster(i,j).gt.0.) then - - soildepth(tile_id(i,j)) = & - soildepth(tile_id(i,j)) + raster(i,j) - count_soil(tile_id(i,j)) = & - count_soil(tile_id(i,j)) + 1. - endif - endif - end do - end do + ! ----------------------------------------------------------- + + real, dimension(12) :: lbee,lpsis,lporo,lcond,lwpwet, & + atau2,btau2,atau5,btau5 + REAL, ALLOCATABLE :: soildepth (:) + INTEGER :: soil_class_top,soil_class_com,soil_gswp,swit + REAL :: BEE, PSIS, POROS,COND,WPWET + integer :: n,count,k1,i1,i,j + character*512 :: path,fname,fout,metpath + + CHARACTER*512 :: version,resoln,continent + integer :: iret,ncid,ncid1 + real, allocatable, target, dimension (:,:) :: SOIL_HIGH + REAL, ALLOCATABLE :: count_soil(:) + integer :: tindex, pfafindex,i_sib,j_sib + integer :: status + real, allocatable, dimension(:) :: soildepth_gswp2 + integer, allocatable, dimension (:) :: land_gswp2 - DO n =1,maxcat - if(count_soil(n)/=0.) soildepth(n)=soildepth(n)/count_soil(n) - if (present(F25Tag)) then - soildepth(n) = max(soildepth(n),1.) - else - soildepth(n) = max(soildepth(n),1.334) - endif - END DO + real, pointer :: Raster(:,:) - soildepth = soildepth*1000. - -! Openning files - - fname='clsm/soil_text.top' - open (10,file=fname,status='old',action='read',form='formatted') - fname='clsm/soil_text.com' - open (11,file=fname,status='old',action='read',form='formatted') - fout='clsm/soil_param.first' - open (21,file=fout,status='unknown',action='write',form='formatted') - fout='clsm/tau_param.dat' - open (22,file=fout,status='unknown',action='write',form='formatted') - - swit =0 - DO n=1 , maxcat - read (10,*) tindex,pfafindex, soil_class_top - write (22,'(i10,i8,4f10.7)')tindex,pfafindex,atau2(soil_class_top), & - btau2(soil_class_top),atau5(soil_class_top),btau5(soil_class_top) - read (11,*) tindex,pfafindex, soil_class_com - - !if (soil_class_com.eq.4) then - ! soil_gswp = 5 - !elseif (soil_class_com.eq.5) then - ! soil_gswp = 6 - !elseif (soil_class_com.eq.6) then - ! soil_gswp = 4 - !elseif (soil_class_com.eq.8) then - ! soil_gswp = 9 - !elseif (soil_class_com.eq.9) then - ! soil_gswp = 8 - !else - ! soil_gswp = soil_class_com - !endif - - soil_gswp = soil_class_com - - cond=lcond(soil_gswp)/exp(-1.*zks*gnu) - wpwet=lwpwet(soil_gswp)/lporo(soil_gswp) - write (21,'(i10,i8,i4,i4,3f8.4,f12.8,f7.4,f10.3)')tindex,pfafindex, & - soil_class_top,soil_class_com,lBEE(soil_gswp), lPSIS(soil_gswp), & - lPORO(soil_gswp),COND,WPWET,soildepth(n) - - if (allocated (parms4file)) then - - parms4file (n, 1) = lBEE(soil_gswp) - parms4file (n, 2) = COND - parms4file (n, 3) = lPORO(soil_gswp) - parms4file (n, 4) = lPSIS(soil_gswp) - parms4file (n, 5) = WPWET - parms4file (n, 6) = soildepth(n) - parms4file (n, 7) = atau2(soil_class_top) - parms4file (n, 8) = btau2(soil_class_top) - parms4file (n, 9) = atau5(soil_class_top) - parms4file (n,10) = btau5(soil_class_top) - - endif - - END DO - close (10,status='delete') - close (11,status='delete') - close (21,status='keep') - close (22,status='keep') - - if(file_exists) then - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'BEE' ) ,(/1/),(/maxcat/), parms4file (:, 1)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'COND' ) ,(/1/),(/maxcat/), parms4file (:, 2)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'POROS') ,(/1/),(/maxcat/), parms4file (:, 3)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'PSIS' ) ,(/1/),(/maxcat/), parms4file (:, 4)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'WPWET') ,(/1/),(/maxcat/), parms4file (:, 5)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'DP2BR') ,(/1/),(/maxcat/), parms4file (:, 6)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ATAU2') ,(/1/),(/maxcat/), parms4file (:, 7)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'BTAU2') ,(/1/),(/maxcat/), parms4file (:, 8)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ATAU5') ,(/1/),(/maxcat/), parms4file (:, 9)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'BTAU5') ,(/1/),(/maxcat/), parms4file (:,10)) ; VERIFY_(STATUS) - STATUS = NF_CLOSE (NCID) ; VERIFY_(STATUS) - DEALLOCATE (parms4file) - endif - - deallocate (soildepth, soil_high) - if(regrid) then - deallocate(raster) - endif - END SUBROUTINE soil_para_high -! -! ==================================================================== -! - SUBROUTINE remove_tiny_tiles ( & - dateline,poles,gout) - - IMPLICIT NONE - INTEGER :: ip,ip2,nc_gcm,nr_gcm,nc_ocean,nr_ocean,pick_val,k,nc,nr - INTEGER :: typ,pfs,ig,jg,indx,indx_old,j_dum,ierr,n,count,count_remain,i_dum - REAL :: lat,lon,mx_frac,da,tarea - REAL(KIND=8) :: fr_gcm,fr_ocean,fr_cat,lats,dx,dy,d2r - INTEGER :: im,jm,i,j,jk,ik,jx - INTEGER :: l,imn,imx,jmn,jmx - CHARACTER*30 :: version - CHARACTER*128 :: fname,gname,gout,gpath - character*300 :: string1, string2 - integer(kind=4), allocatable, dimension(:,:) :: grid - integer(kind=4), allocatable, dimension(:,:) :: grida - REAL (kind=8), PARAMETER :: threshold=0.01,RADIUS=MAPL_RADIUS,pi= MAPL_PI - real(kind=8), allocatable, dimension(:) :: tile_frac,total_area,pfaf,tile_area(:),lon_c(:),lat_c(:),int_c(:) - character*2 :: dateline,poles - integer, allocatable, dimension(:) :: rev_indx - real, allocatable, dimension(:,:):: tile_frac_2d - integer(kind=4),allocatable :: GRIDX(:,:) + logical :: file_exists + real, allocatable, dimension (:,:) :: parms4file + + + ! --------- VARIABLES FOR *OPENMP* PARALLEL ENVIRONMENT ------------ ! - nc=i_raster - nr=j_raster - dx = 360._8/nc - dy = 180._8/nr - d2r = PI/180._8 - - print *,'Revised tile space..:','clsm/'//trim(gout)//'-Pfaf.notiny' + ! NOTE: "!$" is for conditional compilation + ! + logical :: running_omp = .false. + ! + !$ integer :: omp_get_thread_num, omp_get_num_threads + ! + integer :: n_threads=1 + ! + ! ------------------------------------------------------------------ - gname='til/'//trim(gout)//'-Pfafstetter' - fname= trim(gname)//'.til' - - print *,'Any tile whose geographic area is <',threshold - print *,'of the AGCM grid box will be dissolved and' - print *,'the largest geographic neighbor will annex it!' - print *,'----------------------------------------------' - - open (10,file=trim(fname),status='old',action='read',form='formatted') - read (10,*)ip - read (10,*)j_dum - read (10,'(a)')version - read (10,*)nc_gcm - read (10,*)nr_gcm - read (10,'(a)')version - read (10,*)nc_ocean - read (10,*)nr_ocean - - count=0 - - do n = 1,ip - - read(10,'(I10,3E20.12,9(2I10,E20.12,I10))',IOSTAT=ierr) & - typ,tarea,lon,lat,ig,jg,fr_gcm,indx_old,pfs,j_dum,fr_cat,j_dum - - if (typ == 100) ip2 = n - if ((typ == 100).and.(fr_gcm < threshold)) count =count +1 - if(ierr /= 0)write (*,*)'Problem reading',fname + ! ----------- OpenMP PARALLEL ENVIRONMENT ---------------------------- + ! + ! FIND OUT WHETHER -omp FLAG HAS BEEN SET DURING COMPILATION + ! + !$ running_omp = .true. ! conditional compilation + ! + ! ECHO BASIC OMP VARIABLES + ! + !$OMP PARALLEL DEFAULT(NONE) SHARED(running_omp,n_threads) + ! + !$OMP SINGLE + ! + !$ n_threads = omp_get_num_threads() + ! + !$ write (*,*) 'running_omp = ', running_omp + !$ write (*,*) + !$ write (*,*) 'parallel OpenMP with ', n_threads, 'threads' + !$ write (*,*) + !$OMP ENDSINGLE + ! + !$OMP CRITICAL + !$ write (*,*) 'thread ', omp_get_thread_num(), ' alive' + !$OMP ENDCRITICAL + ! + !$OMP BARRIER + ! + !$OMP ENDPARALLEL + ! ----------- OpenMP PARALLEL ENVIRONMENT ---------------------------- + + data lbee /3.30, 3.80, 4.34, 5.25, 3.63, 5.96, 7.32, & + 8.41, 8.34, 9.70, 10.78, 12.93/ + data lpsis /-0.05, -0.07, -0.16, -0.65, -0.84, -0.24, & + -0.12, -0.63, -0.28, -0.12, -0.58, -0.27/ + data lporo /0.373, 0.386, 0.419, 0.476, 0.471, 0.437, & + 0.412, 0.478, 0.447, 0.415, 0.478, 0.450/ + data lcond /2.45e-05, 1.75e-05, 8.35e-06, 2.36e-06, & + 1.1e-06, 4.66e-06, 6.31e-06, 1.44e-06, & + 2.72e-06, 4.25e-06, 1.02e-06, 1.33e-06/ + data lwpwet /0.033,0.051,0.086,0.169,0.045,0.148,0.156, & + 0.249,0.211,0.199,0.286,0.276/ + + data atau2/0.0030065,0.0276075,0.0200614,0.0165152, & + 0.0165152,0.0168748,0.0308809,0.0329365, & + 0.0437085,0.0466403,0.0956670,0.1257360/ + + data btau2/0.0307900,0.0196558,0.0299702,0.0443406, & + 0.0443406,0.0359961,0.0234851,0.0370919, & + 0.0312746,0.0249973,0.0222786,0.0193874/ + + data atau5/0.0067424,0.0766189,0.0540989,0.0439714, & + 0.0439714,0.0457011,0.0589881,0.0885157, & + 0.1175960,0.0692305,0.1348880,0.1535540/ + + data btau5/0.0569718,0.0492634,0.0678898,0.0786387, & + 0.0786387,0.0737872,0.0713841,0.0742609, & + 0.0693533,0.0745496,0.0732726,0.0718882/ - end do + i_sib = i_raster + j_sib = j_raster + + allocate(soildepth(n_land)) + allocate(soil_high(1:i_raster,1:j_raster)) + allocate(count_soil(1:n_land)) + + inquire(file='clsm/catch_params.nc4', exist=file_exists) - write (*,*)'# of small catchments to be removed ', count - if (count < ip2/100) then - - print *,'Too few tiny tiles, thus exiting .............' - print *,'CLSM parameters will be generated for ........' - print *,trim(gname) - string1 ='til/'//trim(gout)//'-Pfafstetter.til'//' '//& - 'clsm/'//trim(gout)//'-Pfaf.notiny.til' - call execute_command_line ('cp '//trim(string1)) - string1 ='rst/'//trim(gout)//'-Pfafstetter.rst'//' '//& - 'clsm/'//trim(gout)//'-Pfaf.notiny.rst' - call execute_command_line ('cp '//trim(string1)) - print *,'and, copied those those files to clsm/.' - - stop + if(file_exists) then + status = NF_OPEN ('clsm/catch_params.nc4', NF_WRITE, ncid) ; VERIFY_(STATUS) + allocate (parms4file (1:n_land, 1:10)) endif - - ! - IM = nc/nc_gcm ! i-Pixels in GCM box - JM = nr/(nr_gcm-1) ! j-Pixels in interior GCM box. Pole boxes have half as many. - if (index(poles,'PE')/=0) JM = nr/(nr_gcm) ! pole edge case - allocate(GRID (nc,jm)) ! Enough space for all pixels in non-pole GCM latitude - allocate(GRIDA (nc,jm)) ! Enough space for all pixels in non-pole GCM latitude - allocate(tile_frac(ip)) - grid=0 - grida=0 - - fname='rst/'//trim(gout)//'-Pfafstetter.rst' - open (10,file=trim(fname),status='old',action='read',form='unformatted',convert='little_endian') - fname='clsm/'//trim(gout)//'-catchs_nosmall_rst' - open (11,file=trim(fname),status='unknown',action='write',form='unformatted',convert='little_endian') - - do j=1,nr_gcm ! loop over GCM latitudes - if(j==1.or.j==nr_gcm) then - jx=jm/2 ! pole latitudes are half as large - if (index(poles,'PE')/=0) jx=jm - else - jx=jm - endif + + soil_high =-9999. + + call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) + + if (present(F25Tag)) then - allocate(tile_frac_2d(im,jx)) - do jk=1,jx ! Read raster data for one row of atmos grid points - if (index(dateline,'DE')/=0) then - read (10) grid(:,jk) - else - read (10) grid(im/2+1:,jk),grid(1:im/2,jk) - endif - if(maxval(grid(:,jk)).gt.ip) print *,'MAX EXCEED',maxval(grid(:,jk)),ip,jk - enddo - - grida=grid + iret = NF_OPEN(trim(MAKE_BCS_INPUT_DIR)//'/land/soil/SOIL-DATA/soil_depth/v1/SoilDepth.nc',NF_NOWRITE, ncid1) + ASSERT_(iret==NF_NOERR) + allocate (soildepth_gswp2(1: ncat_gswp2)) + allocate (land_gswp2 (1: ncat_gswp2)) + iret = NF_GET_VARA_INT (ncid1, 3,(/1/),(/ncat_gswp2/),land_gswp2) + ASSERT_(iret==NF_NOERR) + iret = NF_GET_VARA_REAL(ncid1, 4,(/1/),(/ncat_gswp2/),soildepth_gswp2) + ASSERT_(iret==NF_NOERR) + iret = NF_CLOSE(ncid1) + ASSERT_(iret==NF_NOERR) + + k1 = i_raster/360 - do i=1,nc_gcm ! loop over GCM longitudes - tile_frac = 0 - tile_frac_2d = 0 + do n = 1,ncat_gswp2 - allocate(gridx(im,jx)) - gridx(1:im,1:jx)= grid(1+(I-1)*IM:I*IM,1:JX) - ! - ! We don't touch ocean, ice and lakes pixels - do jk=1,jx - do ik = 1,im - if(gridx(ik,jk) > ip2)gridx(ik,jk)=0 - end do - end do - - ! We don't have to process 100% ocean, lake or ice pixels - if (sum(gridx) /= 0) then - ! - do jk=1,jx - ! do ik=1+(I-1)*IM,I*IM - do ik = 1,im - if(gridx(ik,jk) /= 0) then - tile_frac(gridx(ik,jk)) = tile_frac(gridx(ik,jk)) + & - 1./FLOAT(im*jx) - endif - end do - end do - ! - do n= 1,ip2 - if (tile_frac(n) > threshold) then - do jk=1,jx - do ik = 1,im - if(gridx(ik,jk) == n)then - tile_frac_2d(ik,jk) = tile_frac(n) - endif - end do - end do - end if - end do - ! - if(sum(tile_frac_2d)>0.)then - do n= 1,ip2 - if ((tile_frac(n) > 0.).and.(tile_frac(n) mx_frac) then - mx_frac = tile_frac_2d(k,jmn) - pick_val = gridx(k,jmn) - endif - end do - ! - do k=imn,imx - if(tile_frac_2d(k,jmx) > mx_frac) then - mx_frac = tile_frac_2d(k,jmx) - pick_val = gridx(k,jmx) - endif - end do - ! - do k=jmn,jmx - if(tile_frac_2d(imn,k) > mx_frac) then - mx_frac = tile_frac_2d(imn,k) - pick_val = gridx(imn,k) - endif - end do - ! - do k=jmn,jmx - if(tile_frac_2d(imx,k) > mx_frac) then - mx_frac = tile_frac_2d(imx,k) - pick_val = gridx(imx,k) - endif - end do - ! - if(pick_val >0) grida ((I-1)*IM+ik ,jk) = & - pick_val - if(pick_val >0) exit - l =l+1 - end do - endif - end do - end do - endif - end do - endif - endif ! We don't have to process 100% ocean, lake or ice pixels + j = (land_gswp2(n)-1)/360 + 1 + i = land_gswp2(n) - (j - 1)*360 + j = 181 - j + soil_high((i-1)*k1+1:i*k1,(j-1)*k1+1:j*k1) = soildepth_gswp2(n) - deallocate(gridx) - end do ! loop over GCM longitudes - deallocate(tile_frac_2d) - - ! print *,maxval(grid),minval(grid) - ! print *,maxval(grida(:,1:jx)),minval(grida(:,1:jx)),jx - - do jk=1,jx ! Read raster data for one row of atmos grid points - write (11) grida(:,jk) - enddo - end do ! loop over GCM latitudes - ! - close (10,status='keep') - close (11,status='keep') - - open (11,file=trim(fname),status='unknown',action='read',form='unformatted',convert='little_endian') - tile_frac=0. - - do j=1,nr_gcm ! loop over GCM latitudes - grid=0 + end do + deallocate (soildepth_gswp2,land_gswp2) + else - if(j==1.or.j==nr_gcm) then - jx=jm/2 ! pole latitudes are half as large - if (index(poles,'PE')/=0) jx=jm - else - jx=jm - endif + open (10,file=trim(MAKE_BCS_INPUT_DIR)//'/land/soil/SOIL-DATA/soil_depth/v1/soil_depth_2.5.rst',& + form='unformatted',status='old',action='read',convert='little_endian') - do jk=1,jx ! Read raster data for one row of atmos grid points - read (11) grid(:,jk) - enddo - - do i=1,nc_gcm ! loop over GCM longitudes - do jk=1,jx - do ik=1+(I-1)*IM,I*IM - - tile_frac(grid(ik,jk)) = tile_frac(grid(ik,jk)) + 1./FLOAT(im*jx) - - end do - enddo + do j =1,j_raster + read (10) soil_high(:,j) end do - enddo - ! - close (11,status='keep') - ! - count=0 - count_remain=0 - allocate(rev_indx(ip)) - rev_indx=0 - do n=1,ip - if(tile_frac(n) > 0.) then - count = count + 1 - rev_indx(n) = count - if((n > ip1).and.(n <= ip2))then - if ( tile_frac(n) < threshold) count_remain =count_remain + 1 - endif - end if - end do - ! - write(*,*)'# of small catchments after merging',count_remain - write(*,*)'# of tiles in the before removing tiny tiles :',ip - write(*,*)'# of tiles in the after removing tiny tiles :',count - open (11,file=trim(fname),status='unknown',action='read',form='unformatted',convert='little_endian') - fname='clsm/'//trim(gout)//'-Pfaf.notiny.rst' - open (12,file=trim(fname),status='unknown',action='write',form='unformatted',convert='little_endian') + close (10,status='keep') + + endif - deallocate (grid,grida) - allocate(GRID (nc,1)) ! Enough space for all pixels in non-pole GCM latitude - allocate(GRIDA (nc,1)) ! Enough space for all pixels in non-pole GCM latitude + if(regrid) then + allocate(raster(nx,ny),stat=STATUS); VERIFY_(STATUS) + else + raster => soil_high + end if - grid=0 - grida=0 + if(regrid) then + call RegridRasterReal(soil_high,raster) + endif - allocate(total_area(ip)) - allocate(tile_area(ip)) - allocate(lon_c(ip)) - allocate(lat_c(ip)) - allocate(int_c(ip)) - - lon_c=0. - lat_c=0. - int_c=0. - tile_area=0. - total_area=0. - da = radius*radius*pi*pi/24./24./180./180./1000000. - - do jk =1,nr - lats = -90._8 + (jk - 0.5_8)*dy - read (11) grid(:,1) - do ik = 1,nc - grida(ik,1)=rev_indx(grid(ik,1)) - total_area(rev_indx(grid(ik,1)))=total_area(rev_indx(grid(ik,1))) +1. - tile_area(rev_indx(grid(ik,1)))=tile_area(rev_indx(grid(ik,1))) + & - (sin(d2r*(lats+0.5*dy)) - & - sin(d2r*(lats-0.5*dy)) )*(dx*d2r) - -! da*cos((-90.+float(jk)/24. -1./48.)*pi/180.) - - lat_c(rev_indx(grid(ik,1)))=lat_c(rev_indx(grid(ik,1))) +& - (-90.+float(jk)/24. -1./48.) - - if (index(dateline,'DE')/=0) then - lon_c(rev_indx(grid(ik,1)))=lon_c(rev_indx(grid(ik,1))) + & - (-180.+float(ik)/24. -1./48.) - else - if(ik.le.im/2)then - - lon_c(rev_indx(grid(ik,1)))=lon_c(rev_indx(grid(ik,1))) +& - (-360.-180.+float(nc-im/2+ik)/24. -1./48.) - else - lon_c(rev_indx(grid(ik,1)))=lon_c(rev_indx(grid(ik,1))) + & - (-180.+float(ik-im/2)/24. -1./48.) + soildepth =0. + count_soil = 0. + + do j=1,ny + do i=1,nx + if((tile_id(i,j).gt.0).and.(tile_id(i,j).le.n_land)) then + if(raster(i,j).eq.-9999.) then + ! write (*,*)'soil_high UNDEF',i,j,tile_id(i,j),raster(i,j) + ! stop + endif + if (raster(i,j).gt.0.) then + + soildepth(tile_id(i,j)) = & + soildepth(tile_id(i,j)) + raster(i,j) + count_soil(tile_id(i,j)) = & + count_soil(tile_id(i,j)) + 1. endif endif - int_c(rev_indx(grid(ik,1)))=int_c(rev_indx(grid(ik,1))) + 1. end do - if (index(dateline,'DE')/=0) then - write (12) grida(:,1) - else - write (12) grida(im/2+1:,1),grida(1:im/2,1) - endif end do - close (11,status='delete') - close (12,status='keep') - do n=1,ip - if(rev_indx(n)>0)then - lat_c(rev_indx(n))=lat_c(rev_indx(n))/int_c(rev_indx(n)) - lon_c(rev_indx(n))=lon_c(rev_indx(n))/int_c(rev_indx(n)) - if(lon_c(rev_indx(n)).lt.-180.)lon_c(rev_indx(n))=lon_c(rev_indx(n))+360. - endif - enddo - ! - gname='til/'//trim(gout)//'-Pfafstetter' - fname= trim(gname)//'.til' - ! - open (10,file=trim(fname),status='old',action='read',form='formatted') - read (10,*)ip - read (10,*)j_dum - read (10,'(a)')version - read (10,*)nc_gcm - read (10,*)nr_gcm - read (10,'(a)')version - read (10,*)nc_ocean - read (10,*)nr_ocean - - allocate(pfaf(36716)) - pfaf=0. - - do n = 1,ip - - read(10,'(I10,3E20.12,9(2I10,E20.12,I10))',IOSTAT=ierr) & - typ,tarea,lon,lat,ig,jg,fr_gcm,j_dum,pfs,indx_old,fr_cat,j_dum - - if(n <= ip2) then - if (rev_indx(n)>0)pfaf(indx_old)=pfaf(indx_old) +& - total_area(rev_indx(n)) + DO n =1,n_land + if(count_soil(n)/=0.) soildepth(n)=soildepth(n)/count_soil(n) + if (present(F25Tag)) then + soildepth(n) = max(soildepth(n),1.) + else + soildepth(n) = max(soildepth(n),1.334) endif - end do - close (10,status='keep') - fname= trim(gname)//'.til' - ! - open (10,file=trim(fname),status='old',action='read',form='formatted') - fname='clsm/'//trim(gout)//'-Pfaf.notiny.til' - open (20,file=trim(fname),status='unknown',action='write',form='formatted') - read (10,*)ip - write (20,*)COUNT, 8640,4320 - read (10,*)j_dum - write (20,*)j_dum - read (10,'(a)')version - write(20,'(a)')version - read (10,*)nc_gcm - write (20,*)nc_gcm - read (10,*)nr_gcm - write (20,*)nr_gcm - read (10,'(a)')version - write (20,'(a)')version - read (10,*)nc_ocean - write (20,*)nc_ocean - read (10,*)nr_ocean - write (20,*)nr_ocean + END DO - do n = 1,ip + soildepth = soildepth*1000. + + ! Openning files + + fname='clsm/soil_text.top' + open (10,file=fname,status='old',action='read',form='formatted') + fname='clsm/soil_text.com' + open (11,file=fname,status='old',action='read',form='formatted') + fout='clsm/soil_param.first' + open (21,file=fout,status='unknown',action='write',form='formatted') + fout='clsm/tau_param.dat' + open (22,file=fout,status='unknown',action='write',form='formatted') + + swit =0 + DO n=1 , n_land + read (10,*) tindex,pfafindex, soil_class_top + write (22,'(i10,i8,4f10.7)')tindex,pfafindex,atau2(soil_class_top), & + btau2(soil_class_top),atau5(soil_class_top),btau5(soil_class_top) + read (11,*) tindex,pfafindex, soil_class_com - read(10,'(I10,3E20.12,9(2I10,E20.12,I10))',IOSTAT=ierr) & - typ,tarea,lon,lat,ig,jg,fr_gcm,indx_old,pfs,i_dum,fr_cat,j_dum - - if(n <= ip2)then - if (rev_indx(n)>0) then - - write(20,'(I10,3E20.12,9(2I10,E20.12,I10))',IOSTAT=ierr) & - typ,tile_area(rev_indx(n)),lon_c(rev_indx(n)),lat_c(rev_indx(n)),ig,jg, & - tile_frac(n),indx_old,pfs,i_dum,total_area(rev_indx(n))/pfaf(i_dum),rev_indx(n) - - endif - else - if (rev_indx(n)>0)write(20,'(I10,3E20.12,9(2I10,E20.12,I10))',IOSTAT=ierr) & - typ,tile_area(rev_indx(n)),lon_c(rev_indx(n)),lat_c(rev_indx(n)),ig,jg, & - tile_frac(n),indx_old,pfs,i_dum,fr_cat,rev_indx(n) - + !if (soil_class_com.eq.4) then + ! soil_gswp = 5 + !elseif (soil_class_com.eq.5) then + ! soil_gswp = 6 + !elseif (soil_class_com.eq.6) then + ! soil_gswp = 4 + !elseif (soil_class_com.eq.8) then + ! soil_gswp = 9 + !elseif (soil_class_com.eq.9) then + ! soil_gswp = 8 + !else + ! soil_gswp = soil_class_com + !endif + + soil_gswp = soil_class_com + + cond=lcond(soil_gswp)/exp(-1.*zks*gnu) + wpwet=lwpwet(soil_gswp)/lporo(soil_gswp) + write (21,'(i10,i8,i4,i4,3f8.4,f12.8,f7.4,f10.3)')tindex,pfafindex, & + soil_class_top,soil_class_com,lBEE(soil_gswp), lPSIS(soil_gswp), & + lPORO(soil_gswp),COND,WPWET,soildepth(n) + + if (allocated (parms4file)) then + + parms4file (n, 1) = lBEE(soil_gswp) + parms4file (n, 2) = COND + parms4file (n, 3) = lPORO(soil_gswp) + parms4file (n, 4) = lPSIS(soil_gswp) + parms4file (n, 5) = WPWET + parms4file (n, 6) = soildepth(n) + parms4file (n, 7) = atau2(soil_class_top) + parms4file (n, 8) = btau2(soil_class_top) + parms4file (n, 9) = atau5(soil_class_top) + parms4file (n,10) = btau5(soil_class_top) + endif - end do - - write(*,*)'Surface Area of the Earth',sum(tile_area) - write(*,*)'Land area of the Earth',sum(tile_area(rev_indx(ip1+1):rev_indx(ip2))) - close (10,status='keep') - close (20,status='keep') + + END DO + close (10,status='delete') + close (11,status='delete') + close (21,status='keep') + close (22,status='keep') - END SUBROUTINE remove_tiny_tiles - - -! --------------------------------------------------------------------- -! --------------------------------------------------------------------- -! --------------------------------------------------------------------- + if(file_exists) then + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'BEE' ) ,(/1/),(/n_land/), parms4file (:, 1)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'COND' ) ,(/1/),(/n_land/), parms4file (:, 2)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'POROS') ,(/1/),(/n_land/), parms4file (:, 3)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'PSIS' ) ,(/1/),(/n_land/), parms4file (:, 4)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'WPWET') ,(/1/),(/n_land/), parms4file (:, 5)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'DP2BR') ,(/1/),(/n_land/), parms4file (:, 6)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ATAU2') ,(/1/),(/n_land/), parms4file (:, 7)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'BTAU2') ,(/1/),(/n_land/), parms4file (:, 8)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ATAU5') ,(/1/),(/n_land/), parms4file (:, 9)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'BTAU5') ,(/1/),(/n_land/), parms4file (:,10)) ; VERIFY_(STATUS) + STATUS = NF_CLOSE (NCID) ; VERIFY_(STATUS) + DEALLOCATE (parms4file) + endif + + deallocate (soildepth, soil_high) + if(regrid) then + deallocate(raster) + endif + END SUBROUTINE soil_para_high - SUBROUTINE modis_alb_on_tiles (nx,ny,ease_grid,regrid,gfilet,gfiler) + ! ==================================================================== + ! + ! SUBROUTINE remove_tiny_tiles ( & + ! dateline,poles,gout) + ! + ! ***** subroutine not used as of Dec 2024; removed by rreichle, 20 Dec 2024 ***** + ! + ! END SUBROUTINE remove_tiny_tiles + ! + ! --------------------------------------------------------------------- + ! --------------------------------------------------------------------- + ! --------------------------------------------------------------------- + + SUBROUTINE modis_alb_on_tiles (nx,ny,regrid, n_land, tile_id) - implicit none - CHARACTER*20 :: version,resoln,continent - character*100 :: path,fname,fout,metpath - character (*) :: gfilet,gfiler - character*10 :: dline - integer :: n,ip,maxcat,count,k1,i1,i + integer, intent(in) :: nx, ny + logical, intent(in) :: regrid + integer, intent(in) :: n_land + integer, intent(in) :: tile_id(:,:) + + ! ----------------------------------------------- + + CHARACTER*512 :: version,resoln,continent + character*512 :: path,fname,fout,metpath + integer :: n,count,k1,i1,i integer :: nc_gcm,nr_gcm,nc_ocean,nr_ocean REAL :: lat,lon,fr_gcm,fr_cat,tarea - INTEGER :: typ,pfs,ig,jg,j_dum,ierr,indx_dum,indr1,indr2,indr3 ,ip2 + INTEGER :: typ,pfs,ig,jg,j_dum,ierr,indx_dum,indr1,indr2,indr3,ip2 INTEGER :: laiid,year,mon,smon,imon,iret - integer,allocatable :: tile_id(:,:) integer :: ialbt,ialbs,yy,j,month character*2 :: bw character*5 :: cyy - character*300 :: albtype, albspec + character*512 :: albtype, albspec real, allocatable, target, dimension (:,:) :: alb_in real, allocatable, dimension (:) :: alb_count,alb_out - character*300 :: ifile,ofile - integer :: nx,ny,status - logical :: regrid, ease_grid + character*512 :: ifile,ofile + integer :: status real,pointer :: raster (:,:) - fname=trim(gfilet)//'.til' - - open (10,file=fname,status='old',action='read',form='formatted') - read (10,*)ip - read (10,*)j_dum - - do n = 1, j_dum - read (10,'(a)')version - read (10,*)nc_gcm - read (10,*)nr_gcm - end do - - do n = 1,ip - if (ease_grid) then - read(10,*,IOSTAT=ierr) typ,pfs,lon,lat,ig,jg,fr_gcm - else - read(10,'(I10,3E20.12,9(2I10,E20.12,I10))',IOSTAT=ierr) & - typ,tarea,lon,lat,ig,jg,fr_gcm,j_dum,pfs,j_dum,fr_cat,j_dum - endif - if (typ == 100) ip2 = n - if(ierr /= 0)write (*,*)'Problem reading' - end do - - close (10,status='keep') - - maxcat = ip2 - - fname=trim(gfiler)//'.rst' - - open (10,file=fname,status='old',action='read', & - form='unformatted',convert='little_endian') - allocate(tile_id(1:nx,1:ny)) - - do j=1,ny - read(10)tile_id(:,j) - end do - - close (10,status='keep') + ip2 = ip1 + n_land allocate(alb_in(1:i_raster,1:j_raster)) - allocate(alb_out(1:maxcat)) - allocate(alb_count(1:maxcat)) + allocate(alb_out(1:n_land)) + allocate(alb_count(1:n_land)) if(regrid) then - allocate(raster(nx,ny),stat=STATUS); VERIFY_(STATUS) - else - raster => alb_in + allocate(raster(nx,ny),stat=STATUS); VERIFY_(STATUS) + else + raster => alb_in end if - + call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) do ialbt = 2,2 do ialbs = 1,2 @@ -1510,531 +833,133 @@ SUBROUTINE modis_alb_on_tiles (nx,ny,ease_grid,regrid,gfilet,gfiler) ofile='clsm/AlbMap.'//bw//'.2x5.'//trim(cyy)//'.monthly-tile.' & //albspec(1:index(albspec,'/')-1)//'.dat' - open (20,file=trim(ifile),form='unformatted',& + open (20,file=trim(ifile),form='unformatted',& convert='big_endian', & action='read',status='old') - open (30,file=trim(ofile),form='unformatted', & - convert='big_endian', & - action='write',status='unknown') - - do month =1,12 - read (20) alb_in - if(regrid) then - call RegridRasterReal(alb_in,raster) - else - raster = alb_in - endif - - alb_out = 0. - alb_count = 0. - do j=1,ny - do i=1,nx - if((tile_id(i,j).gt.ip1).and.(tile_id(i,j).le.ip2)) then - if(raster(i,j).eq.undef) then -! write (*,*)'raster UNDEF',i,j,month,albtype,albspec -! stop - endif - if ((raster(i,j).gt.0.).and.(raster(i,j).ne.undef)) then - alb_out(tile_id(i,j)-ip1) = & - alb_out(tile_id(i,j)-ip1) + raster(i,j) - alb_count(tile_id(i,j)-ip1) = & - alb_count(tile_id(i,j)-ip1) + 1. - endif - endif - end do - end do - - do n = 1,maxcat - if (alb_count(n).gt.0)then - alb_out(n) = alb_out(n)/alb_count(n) - else -! print *,'No albedo for the tile :',n - alb_out(n) = alb_out(n-1) - endif - end do - write (30) alb_out - end do - close (20,status='keep') - close (30,status='keep') - - end do - end do - end do - - deallocate (tile_id,alb_in,alb_out,alb_count) + open (30,file=trim(ofile),form='unformatted', & + convert='big_endian', & + action='write',status='unknown') + + do month =1,12 + read (20) alb_in + if(regrid) then + call RegridRasterReal(alb_in,raster) + else + raster = alb_in + endif + + alb_out = 0. + alb_count = 0. + do j=1,ny + do i=1,nx + if((tile_id(i,j).gt.ip1).and.(tile_id(i,j).le.ip2)) then + if(raster(i,j).eq.undef) then + ! write (*,*)'raster UNDEF',i,j,month,albtype,albspec + ! stop + endif + if ((raster(i,j).gt.0.).and.(raster(i,j).ne.undef)) then + alb_out(tile_id(i,j)-ip1) = & + alb_out(tile_id(i,j)-ip1) + raster(i,j) + alb_count(tile_id(i,j)-ip1) = & + alb_count(tile_id(i,j)-ip1) + 1. + endif + endif + end do + end do + + do n = 1,n_land + if (alb_count(n).gt.0)then + alb_out(n) = alb_out(n)/alb_count(n) + else + ! print *,'No albedo for the tile :',n + alb_out(n) = alb_out(n-1) + endif + end do + write (30) alb_out + end do + close (20,status='keep') + close (30,status='keep') + + end do + end do + end do + + deallocate (alb_in,alb_out,alb_count) if(regrid) then deallocate(raster) - endif + endif END SUBROUTINE modis_alb_on_tiles + + !---------------------------------------------------------------------- + ! + ! The following subroutines were already commented out as of 24 Dec 2024. + ! Removed by rreichle, 24 Dec 2024. + ! + ! SUBROUTINE modis_scale_para (ease_grid,gfile) + ! + ! SUBROUTINE make_75 (nx,ny,regrid,path,gfile) + ! + ! subroutine pick_cat(sam,clr) + ! + !---------------------------------------------------------------------- + + SUBROUTINE supplemental_tile_attributes(nx,ny,regrid,dateline,fnameTil, Rst_id) + + ! 1) get supplemental tile attributes not provided in MAPL-generated (ASCII) tile file, + ! incl. min/max lat/lon of each tile and tile elevation + ! 2) write nc4-formatted til file (incl. supplemental tile attributes) + + integer, intent(in) :: nx, ny + + logical, intent(in) :: regrid -!---------------------------------------------------------------------- - -! SUBROUTINE modis_scale_para (ease_grid,gfile) -! -! implicit none -! type (date_time_type) :: gf_green_time,af_green_time,end_time, & -! bf_lai_time,af_lai_time,date_time_new -! logical :: ease_grid -! CHARACTER*20 :: version,resoln,continent -! integer :: nc_gcm,nr_gcm,nc_ocean,nr_ocean -! REAL :: latt,lont,fr_gcm,fr_cat,tsteps,zth, slr,tarea -! INTEGER :: typ,pfs,ig,jg,j_dum,ierr,indx_dum,indr1,indr2,indr3 ,ip2 -! character*100 :: path,fname,fout,metpath -! character (*) :: gfile -! integer :: n,maxcat,ip -! integer :: ialbt,ialbs,yy,j,month,unit1,unit2,unit3 -! character*2 :: bw -! character*5 :: cyy -! character*300 :: albtype, albspec -! character*30, dimension (2,2) :: sibname -! character*30, dimension (2,2) :: geosname -! integer, allocatable, dimension (:) :: vegcls -! real, allocatable, dimension (:) :: & -! modisalb,scale_fac,albvf,albnf, lat,lon, & -! green,lai,lai_before,lai_after,grn_before,grn_after -! real, allocatable, dimension (:) :: & -! calbvf,calbnf, zero_array, one_array, albvr,albnr -! character*300 :: ifile1,ifile2,ofile -! integer, dimension(12), parameter :: days_in_month_nonleap = & -! (/ 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 /) -! integer :: day, hour, min ,secs_in_day,k -! real :: yr,mn,dy,yr1,mn1,dy1,dum, slice1,slice2 -! -! ! --------- VARIABLES FOR *OPENMP* PARALLEL ENVIRONMENT ------------ -! ! -! ! NOTE: "!$" is for conditional compilation -! ! -! logical :: running_omp = .false. -! ! -! !$ integer :: omp_get_thread_num, omp_get_num_threads -! ! -! integer :: n_threads=1 -! ! -! ! ------------------------------------------------------------------ -! -! ! ----------- OpenMP PARALLEL ENVIRONMENT ---------------------------- -! ! -! ! FIND OUT WHETHER -omp FLAG HAS BEEN SET DURING COMPILATION -! ! -! !$ running_omp = .true. ! conditional compilation -! ! -! ! ECHO BASIC OMP VARIABLES -! ! -! !$OMP PARALLEL DEFAULT(NONE) SHARED(running_omp,n_threads) -! ! -! !$OMP SINGLE -! ! -! !$ n_threads = omp_get_num_threads() -! ! -! !$ write (*,*) 'running_omp = ', running_omp -! !$ write (*,*) -! !$ write (*,*) 'parallel OpenMP with ', n_threads, 'threads' -! !$ write (*,*) -! !$OMP ENDSINGLE -! ! -! !$OMP CRITICAL -! !$ write (*,*) 'thread ', omp_get_thread_num(), ' alive' -! !$OMP ENDCRITICAL -! ! -! !$OMP BARRIER -! ! -! !$OMP ENDPARALLEL -! ! ----------- OpenMP PARALLEL ENVIRONMENT ---------------------------- -! -! data sibname /'albvr','albnr', & -! 'albvf','albnf'/ -! data geosname /'visdr','nirdr', & -! 'visdf','nirdf'/ -! -! fname='clsm/catchment.def' -! open (10,file=fname,status='old',action='read',form='formatted') -! read (10,*)maxcat -! allocate (albvf (1:maxcat)) -! allocate (albnf (1:maxcat)) -! allocate (calbvf (1:maxcat)) -! allocate (calbnf (1:maxcat)) -! allocate (modisalb (1:maxcat)) -! allocate (lai (1:maxcat)) -! allocate (green (1:maxcat)) -! allocate (lai_before (1:maxcat)) -! allocate (grn_before (1:maxcat)) -! allocate (lai_after (1:maxcat)) -! allocate (grn_after (1:maxcat)) -! allocate (vegcls (1:maxcat)) -! allocate (zero_array (1:maxcat)) -! allocate (one_array (1:maxcat)) -! allocate (albvr (1:maxcat)) -! allocate (albnr (1:maxcat)) -! close (10,status='keep') -! -! date_time_new%year =2002 -! date_time_new%month =1 -! date_time_new%day =1 -! date_time_new%hour =0 -! date_time_new%min =0 -! date_time_new%sec =0 -! date_time_new%pentad =1 -! date_time_new%dofyr =1 -! -! gf_green_time = date_time_new -! af_green_time = date_time_new -! end_time = date_time_new -! bf_lai_time = date_time_new -! af_lai_time = date_time_new -! -! fname=trim(gfile)//'.til' -! -! open (10,file=fname,status='old',action='read',form='formatted') -! fname='clsm/mosaic_veg_typs_fracs' -! open (20,file=fname,status='old',action='read',form='formatted') -! -! read (10,*)ip -! read (10,*)j_dum -! -! do n = 1, j_dum -! read (10,'(a)')version -! read (10,*)nc_gcm -! read (10,*)nr_gcm -! end do -! -! do n = 1,ip -! if (ease_grid) then -! read(10,*,IOSTAT=ierr) typ,pfs,lon,lat,ig,jg,fr_gcm -! else -! read(10,'(I10,3E20.12,9(2I10,E20.12,I10))',IOSTAT=ierr) & -! typ,tarea,lont,latt,ig,jg,fr_gcm,indx_dum,pfs,j_dum,fr_cat,j_dum -! endif -! if (typ == 100) then -! ip2 = n -! read (20,'(i10,i8,2(2x,i3),2(2x,f6.4))') & -! indr1,indr1,vegcls(ip2),indr1,fr_gcm,fr_gcm -! endif -! if(ierr /= 0)write (*,*)'Problem reading' -! end do -! close (10,status='keep') -! close (20,status='keep') -! -! cyy='00-04' -! albvf =0. -! albnf =0. -! calbvf =0. -! calbnf =0. -! modisalb =0. -! zero_array = 0. -! one_array = 1. -! albvr = 0. -! albnr = 0. -! -! unit1 =10 -! unit2 =20 -! unit3 =30 -! -! do ialbt = 2,2 -! do ialbs = 1,2 -! -! if(ialbt.eq.1)albtype='BlackSky/' -! if(ialbt.eq.2)albtype='WhiteSky/' -! if(ialbt.eq.1)bw='BS' -! if(ialbt.eq.2)bw='WS' -! if(ialbs.eq.1)albspec='0.3_0.7/' -! if(ialbs.eq.2)albspec='0.7_5.0/' -! ifile1='clsm/AlbMap.'//bw//'.2x5.'//trim(cyy)//'.monthly-tile.' & -! //albspec(1:index(albspec,'/')-1)//'.dat' -! ! write (*,*) 'MODIS file: ', unit1,trim(ifile1) -! ! write (*,*) '-----------------------------' -! -! ifile2='clsm/sibalb1.'//trim(sibname(ialbs,ialbt))//'.climatology' -! ! write (*,*) 'SiB file: ', unit2, trim(ifile2) -! -! ofile='clsm/modis_scale_factor.'//trim(sibname(ialbs,ialbt))//'.clim' -! -! ! write (*,*) 'Scale factor: ', unit3, trim(ofile) -! -! open (unit1,file=trim(ifile1),form='unformatted',convert='big_endian', & -! action='read',status='old') -! open (unit2,file=trim(ifile2),form='unformatted',convert='big_endian', & -! action='write',status='unknown') -! open (unit3,file=trim(ofile),form='unformatted',convert='big_endian', & -! action='write',status='unknown') -! -! unit1 = unit1 + 1 -! unit2 = unit2 + 1 -! unit3 = unit3 + 1 -! end do -! end do -! -! fname='clsm/lai.dat' -! open (40,file=fname,status='old',action='read',form='unformatted', & -! convert='little_endian') -! read(40) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 -! read(40) lai_before -! call Get_MidTime(yr,mn,dy,yr1,mn1,dy1,bf_lai_time) -! -! read(40) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 -! read(40) lai_after -! call Get_MidTime(yr,mn,dy,yr1,mn1,dy1,af_lai_time) -! -! fname='clsm/green.dat' -! open (41,file=fname,status='old',action='read',form='unformatted', & -! convert='little_endian') -! read(41) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 -! read(41) grn_before -! call Get_MidTime(yr,mn,dy,yr1,mn1,dy1,gf_green_time) -! -! read(41) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 -! read(41) grn_after -! call Get_MidTime(yr,mn,dy,yr1,mn1,dy1,af_green_time) -! -! do month=1,12 -! -! write (*,'(a48,i3)') ' Computing MODIS scale parameters for month: ',month -! -! calbvf =0. -! calbnf =0. -! albvf =0. -! albnf =0. -! tsteps =0. -! -! do day = 1,days_in_month_nonleap(month) -! -! if (datetime_le_refdatetime(date_time_new,af_lai_time)) then -! -! else -! lai_before = lai_after -! bf_lai_time = af_lai_time -! read(40) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 -! read(40) lai_after -! call Get_MidTime(yr,mn,dy,yr1,mn1,dy1,af_lai_time) -! endif -! call Time_Interp_Fac (date_time_new, bf_lai_time, af_lai_time, slice1, slice2) -! lai = (slice1*lai_before + slice2*lai_after) -! ! print *,'LAI' -! ! print *,bf_lai_time -! ! print *,af_lai_time -! ! print *,slice1,slice2 -! ! print *,minval(lai),maxval(lai) -! -! if (datetime_le_refdatetime(date_time_new,af_green_time)) then -! -! else -! grn_before = grn_after -! gf_green_time = af_green_time -! read(41) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 -! read(41) grn_after -! call Get_MidTime(yr,mn,dy,yr1,mn1,dy1,af_green_time) -! -! endif -! call Time_Interp_Fac (date_time_new, gf_green_time, af_green_time, slice1, slice2) -! green = (slice1*grn_before + slice2*grn_after) -! ! print *,'GREEN' -! ! print *,gf_green_time -! ! print *,af_green_time -! ! print *,slice1,slice2 -! ! print *,minval(green),maxval(green) -! -! call augment_date_time(86400,date_time_new) -! -! tsteps = tsteps + 1. -! -! call sibalb ( & -! MAXCAT,vegcls,lai,green, zero_array, & -! one_array,one_array,one_array,one_array, & -! ALBVR, ALBNR, albvf, albnf) -! -! calbvf = calbvf + albvf -! calbnf = calbnf + albnf -! -! end do -! -! calbvf = calbvf/tsteps -! calbnf = calbnf/tsteps -! -! unit1 =10 -! unit2 =20 -! unit3 =30 -! -! do ialbt = 2,2 -! do ialbs = 1,2 -! -! read (unit1) (modisalb(n),n=1,maxcat) -! if(unit2==20)write (unit2) (calbvf(n),n=1,maxcat) -! if(unit2==21)write (unit2) (calbnf(n),n=1,maxcat) -! -! if(unit2==20) modisalb = modisalb/(calbvf + 1.e-20) -! if(unit2==21) modisalb = modisalb/(calbnf + 1.e-20) -! -! do n =1, maxcat -! if(modisalb(n).le.0)then -! print *,'Negative MODIS scale param at cell',n, modisalb(n) -! print *,'Set to 1' -! modisalb(n)=1 -! endif -! -! if(modisalb(n).gt.100)then -! print *,'Too large MODIS scale param',n, modisalb(n) -! print *,'Set to 1' -! modisalb(n)=1 -! endif -! -! enddo -! -! write (unit3) (modisalb(n),n=1,maxcat) -! -! unit1 = unit1 + 1 -! unit2 = unit2 + 1 -! unit3 = unit3 + 1 -! end do -! end do -! -! end do -! -! deallocate (modisalb,albvf,albnf) -! deallocate (green,lai) -! deallocate (vegcls) -! deallocate (calbvf,calbnf) -! deallocate (zero_array, one_array, albvr, albnr) -! -! unit1 =10 -! unit2 =20 -! unit3 =30 -! -! do ialbt = 2,2 -! do ialbs = 1,2 -! -! close (unit1, status='keep') -! close (unit2, status='keep') -! close (unit3, status='keep') -! -! unit1 = unit1 + 1 -! unit2 = unit2 + 1 -! unit3 = unit3 + 1 -! end do -! end do -! -! close (40, status='keep') -! close (41, status='keep') -! -! END SUBROUTINE modis_scale_para -! -! !---------------------------------------------------------------------- -! -! SUBROUTINE make_75 (nx,ny,regrid,path,gfile) -! implicit none -! integer nc,nr,i,j,i1,i2,j1,j2,cls,ip, ii, jj,xc,xr -! integer, allocatable :: catid(:,:),catold(:,:),cat75(:,:) -! integer sam(3,3) -! character*100 filename,path -! character (*) :: gfile -! integer :: nx,ny -! logical :: regrid -! -! nc = i_raster -! nr = j_raster -! -! filename=trim(path)//'global.cat_id.catch.DL' -! open (9,file=filename,form='formatted',status='old') -! -! filename=trim(gfile)//'.rst' -! -! open (10,file=filename,convert='little_endian', & -! form='unformatted',status='old',action='read') -! -! allocate(catid(nc,nr)) -! allocate(catold(nc,nr)) -! catid=0 -! catold=0 -! -! do j=1,nr -! read (9,*)(catold(i,j),i=1,nc) -! read (10)(catid(i,j),i=1,nc) -! do i=1,nc -! if((catold(i,j).eq.0).or.(catold(i,j).gt.5999900))catid(i,j)=0 -! end do -! end do -! -! close(9,status='keep') -! close(10,status='keep') -! -! deallocate(catold) -! allocate(cat75(nc/3,nr/3)) -! -! cat75=0 -! -! filename=trim(gfile)//'.7.5.rst' -! -! open (11,file=filename,convert='little_endian',form='unformatted',status='unknown') -! -! do j=1,1440 -! j2=J*3 -! j1=j2-2 -! do i=1,2880 -! i2=i*3 -! i1=i2-2 -! sam(1:3,1:3)=catid(i1:i2,j1:j2) -! call pick_cat(sam,cat75(i,j)) -! ! write(*,*)cat75(i,j) -! ! pause -! end do -! write (11)(cat75(i,j),i=1,2880) -! end do -! deallocate(catid) -! deallocate(cat75) -! -! end SUBROUTINE make_75 -! -! !---------------------------------------------------------------------- -! -! subroutine pick_cat(sam,clr) -! implicit none -! -! integer sam(9),num_val(9),i,j,cls(1),clr(1) -! num_val(1:9)=0 -! clr=0 -! do i=1,9 -! do j=1,9 -! if(sam(i).eq.sam(j))num_val(i)=num_val(i)+1 -! end do -! end do -! clr=sam(maxloc(num_val)) -! -! end subroutine pick_cat -! -! -!---------------------------------------------------------------------- - - SUBROUTINE catchment_def (nx,ny,regrid,dateline,gfilet,gfiler) - - implicit none + character(*), intent(in) :: dateline + + character(*), intent(in) :: fnameTil ! file name (w/o extension) of tile file + integer, intent(in) :: Rst_id(:,:) + + ! --------------------------------------------------------- INTEGER, allocatable, dimension(:) :: CATID - integer :: n,ip,maxcat,count,k1,i1,i,j,i_sib,j_sib - INTEGER, allocatable, dimension (:) :: id,I_INDEX,J_INDEX - integer :: nc_gcm,nr_gcm,nc_ocean,nr_ocean - REAL :: lat,lon,fr_gcm,fr_cat,tarea - INTEGER :: typ,pfs,ig,jg,j_dum,ierr,indx_dum,indr1,indr2,indr3 ,ip2 - REAL (kind=8), PARAMETER :: RADIUS=MAPL_RADIUS,pi= MAPL_PI - character*100 :: path,fname,fout,metpath - character*200 :: gtopo30 - character (*) :: gfilet,gfiler - character*10 :: dline - CHARACTER*20 :: version,resoln,continent - REAL, ALLOCATABLE :: limits(:,:) - REAL :: mnx,mxx,mny,mxy,dx,dy,d2r,lats,sum1,sum2,dx_gcm,dy_gcm - REAL, dimension (:), allocatable :: tile_ele, tile_area,tile_area_land - integer :: nx,ny,status - logical :: regrid - real, pointer :: Raster(:,:) + integer :: n, ip, n_land, i, j, i_sib, j_sib, status + INTEGER, allocatable, dimension(:) :: id, I_INDEX, J_INDEX + integer :: nc_gcm, nr_gcm, nc_ocean, nr_ocean + REAL :: lat, lon, fr_gcm, fr_cat, tarea + INTEGER :: typ, pfs, ig, jg, j_dum, i_dum, ierr, indx_dum, ip2, n_grid + + REAL (REAL64), PARAMETER :: RADIUS=MAPL_RADIUS, pi= MAPL_PI + + character*512 :: fname + character*512 :: gtopo30 + CHARACTER*512 :: version + + REAL, allocatable :: limits(:,:) + + REAL :: mnx,mxx,mny,mxy,dx,dy,d2r,lats,sum1,dx_gcm,area_rst + + REAL, allocatable, dimension(:) :: tile_ele, tile_area,tile_area_rst + integer :: IM(2), JM(2) + + real, pointer :: Raster(:,:) + real :: mean_land_elev - character*2 :: dateline - real*4, allocatable , target :: q0 (:,:) + real*4, allocatable, target :: q0 (:,:) + real(REAL64), allocatable :: rTable(:,:) + integer, allocatable :: iTable(:,:) + character(len=128) :: gName(2) + logical, allocatable :: IsOcean(:) + ! ----------------------------------------------------- + ! + ! get elevation (q0) from "gtopo30" raster file ("srtm30_withKMS_2.5x2.5min.data") + call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) gtopo30 = trim(MAKE_BCS_INPUT_DIR)//'/land/topo/v1/srtm30_withKMS_2.5x2.5min.data' allocate (q0(1:i_raster,1:j_raster)) i_sib = nx j_sib = ny - + dx = 360._8/i_sib dy = 180._8/j_sib d2r = PI/180._8 @@ -2042,119 +967,143 @@ SUBROUTINE catchment_def (nx,ny,regrid,dateline,gfilet,gfiler) open (10,file=trim(gtopo30),form='unformatted',status='old') read (10) q0 close (10,status='keep') - + if(regrid) then allocate(raster(nx,ny),stat=STATUS); VERIFY_(STATUS) else raster => q0 end if - + if(regrid) then call RegridRasterReal(q0,raster) endif + ! ----------------------------------------------------------- + ! + ! read ASCII-formatted tile file (*.til) + ! + ! ip = number of tiles in global domain (all types, incl. land, landice, lake, & ocean) + ! ip1 = index offset for land tiles in *.til files (ip1=0 implies that land tiles first in *.til file) + ! ip2 = ip1 + n_land = end index of land tiles (where n_land is number of land tiles in global *.til file) + allocate (catid(1:i_sib)) catid=0 - fname=trim(gfilet)//'.til' + fname=trim(fnameTil)//'.til' open (10,file=fname,status='old',action='read',form='formatted') read (10,*)ip - allocate(id(ip)) - allocate(i_index(ip)) - allocate(j_index(ip)) - allocate(tile_area(ip)) - id=0 - read (10,*)j_dum - do n = 1, j_dum + allocate(id( ip)) + allocate(i_index( ip)) + allocate(j_index( ip)) + allocate(tile_area(ip)) + + id=0 + read (10,*) n_grid + IM = 0 + JM = 0 + gName = ['',''] + do n = 1, n_grid read (10,'(a)')version read (10,*)nc_gcm read (10,*)nr_gcm + gName(n) = trim(adjustl(version)) + IM(n) = nc_gcm + JM(n) = nr_gcm end do ! dx_gcm = 360./float(nc_gcm) -! dy_gcm = 180./float(nr_gcm) - + + allocate(iTable(ip,0:7)) + allocate(rTable(ip,10)) + rTable = MAPL_UNDEF_r8 + + allocate(IsOcean(ip)) + IsOcean = .false. + do n = 1,ip - - read(10,'(I10,3E20.12,9(2I10,E20.12,I10))',IOSTAT=ierr) & - typ,tarea,lon,lat,ig,jg,fr_gcm,indx_dum,pfs,j_dum,fr_cat,j_dum - tile_area(n) = tarea - id(n)=pfs - i_index(n) = ig - j_index(n) = jg + + read(10,'(I10,3E20.12,9(2I10,E20.12,I10))',IOSTAT=ierr) & + typ,tarea,lon,lat,ig,jg,fr_gcm,indx_dum,pfs,i_dum,fr_cat,j_dum + + if(ierr /= 0) write (*,*)'Problem reading ' // trim(fname) + + tile_area(n) = tarea + id(n) = pfs + i_index(n) = ig + j_index(n) = jg if (typ == 100) ip2 = n - if(ierr /= 0)write (*,*)'Problem reading' + if (typ == 0 ) IsOcean(n) = .true. + + iTable(n,0) = typ + rTable(n,3) = tarea + rTable(n,1) = lon + rTable(n,2) = lat + iTable(n,2) = ig + iTable(n,3) = jg + rTable(n,4) = fr_gcm + iTable(n,6) = indx_dum + iTable(n,4) = pfs + iTable(n,5) = i_dum + rTable(n,5) = fr_cat + iTable(n,7) = j_dum end do close (10,status='keep') + + n_land=ip2-ip1 ! = number of land tiles + + ! --------------------------------------------------------------- + ! + ! compute supplemental tile info: mean elevation and min/max lat/lon of each tile + + allocate(tile_ele( 1:ip)) + allocate(tile_area_rst(1:ip)) - maxcat=ip2-ip1 - -! Tile elevation - allocate(tile_ele(1:maxcat)) - allocate(tile_area_land(1:maxcat)) - tile_ele = 0. - tile_area_land = 0. - - fname=trim(gfiler)//'.rst' - open (10,file=fname,status='old',action='read',form='unformatted',convert='little_endian') + tile_ele = 0. + tile_area_rst = 0. ! total area of raster grid cells contributing to each tile - do j=1,j_sib + allocate(limits( 1:ip,1:4)) - lats = -90._8 + (j - 0.5_8)*dy - read (10)(catid(i),i=1,i_sib) + limits(:,1) = 360. + limits(:,2) = -360. + limits(:,3) = 90. + limits(:,4) = -90. - do i=1,i_sib - if((catid(i) > ip1).and.(catid(i) <= ip2))then - tile_ele(catid(i)-ip1) = tile_ele(catid(i)-ip1) + raster(i,j)* & - (sin(d2r*(lats+0.5*dy)) -sin(d2r*(lats-0.5*dy)))*(dx*d2r) - tile_area_land(catid(i)-ip1) = tile_area_land(catid(i)-ip1) + & - (sin(d2r*(lats+0.5*dy)) -sin(d2r*(lats-0.5*dy)))*(dx*d2r) - endif - enddo - enddo - tile_ele = tile_ele/tile_area_land - close (10, status='keep') + ! read raster file with tile IDs - ! adjustment Global Mean Topography to 614.649 (615.662 GTOPO 30) m - ! -------------------------------------------- - sum1=0. - sum2=0. - do j=1,maxcat - sum1 = sum1 + tile_ele(j)*tile_area(j) - enddo - if(sum1/sum(tile_area(1:maxcat)).ne. 614.649D0 ) then -! print *,sum1/sum(tile_area(1:maxcat)) - tile_ele =tile_ele*(614.649D0 / (sum1/sum(tile_area(1:maxcat)))) - sum1=0. - sum2=0. - do j=1,maxcat - sum1 = sum1 + tile_ele(j)*tile_area(j) - enddo -! print *,sum1/sum(tile_area(1:maxcat)) - endif - + do j=1,j_sib + + ! latitude and area of raster grid cells associated with lat index j + + lats = -90._8 + (j - 0.5_8)*dy + + ! preserve zero-diff + !area_rst = (sin(d2r*(lats+0.5*dy)) -sin(d2r*(lats-0.5*dy)))*(dx*d2r) -! catchment def file -! ------------------ - allocate(limits(1:maxcat,1:4)) - limits(:,1)=360. - limits(:,2)=-360. - limits(:,3)=90. - limits(:,4)=-90. + ! read tile IDs for lat index j + catid(:) = rst_id(:,j) - fname=trim(gfiler)//'.rst' - open (10,file=fname,status='old',action='read',form='unformatted',convert='little_endian') - - do j=1,j_sib + ! compute average elevation weighted by area of contributing raster grid cells + + do i=1,i_sib + if (.not. IsOcean(catid(i)-ip1)) then + + tile_ele( catid(i)-ip1) = tile_ele( catid(i)-ip1) + raster(i,j)* & + (sin(d2r*(lats+0.5*dy)) -sin(d2r*(lats-0.5*dy)))*(dx*d2r) + + tile_area_rst(catid(i)-ip1) = tile_area_rst(catid(i)-ip1) + & + (sin(d2r*(lats+0.5*dy)) -sin(d2r*(lats-0.5*dy)))*(dx*d2r) + + endif + enddo + mny=-90. + float(j-1)*180./float(j_sib) mxy=-90. + float(j) *180./float(j_sib) - read (10)(catid(i),i=1,i_sib) + if (index(dateline,'DE')/=0) then - do i=1,i_sib - if((catid(i) > ip1).and.(catid(i) <= ip2))then + if( .not. IsOcean(catid(i)- ip1))then mnx =-180. + float(i-1)*360./float(i_sib) mxx =-180. + float(i) *360./float(i_sib) if(mnx .lt.limits(catid(i)-ip1,1))limits(catid(i)-ip1,1)=mnx @@ -2164,63 +1113,124 @@ SUBROUTINE catchment_def (nx,ny,regrid,dateline,gfilet,gfiler) endif end do else - do i=1,i_sib- i_sib/nc_gcm/2 - if((catid(i) > ip1).and.(catid(i) <= ip2))then - mnx =-180. + float(i-1)*360./float(i_sib) - mxx =-180. + float(i) *360./float(i_sib) - if(mnx .lt.limits(catid(i)-ip1,1))limits(catid(i)-ip1,1)=mnx - if(mxx .gt.limits(catid(i)-ip1,2))limits(catid(i)-ip1,2)=mxx - if(mny .lt.limits(catid(i)-ip1,3))limits(catid(i)-ip1,3)=mny - if(mxy .gt.limits(catid(i)-ip1,4))limits(catid(i)-ip1,4)=mxy - endif - end do - do i=i_sib- i_sib/nc_gcm/2 +1,i_sib - if((catid(i) > ip1).and.(catid(i) <= ip2))then - mnx =-360. -180. + float(i-1)*360./float(i_sib) - mxx =-360. -180. + float(i) *360./float(i_sib) - if(mnx < -180. ) mnx = mnx + 360. - if(mxx <= -180.) mxx = mxx + 360. - if(mnx .lt.limits(catid(i)-ip1,1))limits(catid(i)-ip1,1)=mnx - if(mxx .gt.limits(catid(i)-ip1,2))limits(catid(i)-ip1,2)=mxx - if(mny .lt.limits(catid(i)-ip1,3))limits(catid(i)-ip1,3)=mny - if(mxy .gt.limits(catid(i)-ip1,4))limits(catid(i)-ip1,4)=mxy - endif - end do - - endif - - end do - close(10,status='keep') - - open (10,file='clsm//catchment.def', & - form='formatted',status='unknown') - write (10,*)maxcat - - do j=1,maxcat - if(limits(j,1).lt.-180.) limits(j,1)= limits(j,1)+360. - if(limits(j,2).le.-180.) limits(j,2)= limits(j,2)+360. - ! if(trim(dateline)=='DC')then - ! limits(j,1) = max(limits(j,1),(i_index(j)-1)*dx_gcm -180. - dx_gcm/2.) - ! limits(j,2) = min(limits(j,2),(i_index(j)-1)*dx_gcm -180. + dx_gcm/2.) - ! endif - write (10,'(i10,i8,5(2x,f9.4))')j+ip1,id(j+ip1),limits(j,1), & - limits(j,2),limits(j,3),limits(j,4),tile_ele(j) - end do - + do i=1,i_sib- i_sib/nc_gcm/2 + if( .not. IsOcean(catid(i) - ip1)) then + mnx =-180. + float(i-1)*360./float(i_sib) + mxx =-180. + float(i) *360./float(i_sib) + if(mnx .lt.limits(catid(i)-ip1,1))limits(catid(i)-ip1,1)=mnx + if(mxx .gt.limits(catid(i)-ip1,2))limits(catid(i)-ip1,2)=mxx + if(mny .lt.limits(catid(i)-ip1,3))limits(catid(i)-ip1,3)=mny + if(mxy .gt.limits(catid(i)-ip1,4))limits(catid(i)-ip1,4)=mxy + endif + end do + do i=i_sib- i_sib/nc_gcm/2 +1,i_sib + if( .not. IsOcean(catid(i) - ip1)) then + mnx =-360. -180. + float(i-1)*360./float(i_sib) + mxx =-360. -180. + float(i) *360./float(i_sib) + if(mnx < -180.) mnx = mnx + 360. + if(mxx <= -180.) mxx = mxx + 360. + if(mnx .lt.limits(catid(i)-ip1,1))limits(catid(i)-ip1,1)=mnx + if(mxx .gt.limits(catid(i)-ip1,2))limits(catid(i)-ip1,2)=mxx + if(mny .lt.limits(catid(i)-ip1,3))limits(catid(i)-ip1,3)=mny + if(mxy .gt.limits(catid(i)-ip1,4))limits(catid(i)-ip1,4)=mxy + endif + end do + endif + enddo + + ! finalize min/max lat/lon + + where (limits(:,1).lt.-180.) limits(:,1) = limits(:,1) + 360.0 + where (limits(:,2).le.-180.) limits(:,2) = limits(:,2) + 360.0 + + ! finalize elevation + + where ( .not. IsOcean) tile_ele = tile_ele/tile_area_rst + + ! adjust global mean (land) topography to 614.649 (615.662 GTOPO 30) m + + sum1=0. + + do j=1,n_land + sum1 = sum1 + tile_ele(j)*tile_area(j) + enddo + + mean_land_elev = sum1/sum(tile_area(1:n_land)) + + if ( mean_land_elev .ne. Target_mean_land_elev ) then + + print *, 'Global mean land elevation before adjustment [m]: ', mean_land_elev + + tile_ele(1:n_land) = tile_ele(1:n_land)*(Target_mean_land_elev / mean_land_elev) + + ! verify adjustment + + sum1=0. + + do j=1,n_land + sum1 = sum1 + tile_ele(j)*tile_area(j) + enddo + + print *, 'Global mean land elevation after scaling to SRTM [m]: ', sum1/sum(tile_area(1:n_land)) + + endif + + ! -------------------------------------------------------------------------- + ! + ! write (ASCII) catchment.def file (land tiles only!) + + open (10,file='clsm//catchment.def', & + form='formatted',status='unknown') + write (10,*) n_land + + do j=1,n_land + ! if(trim(dateline)=='DC')then + ! limits(j,1) = max(limits(j,1),(i_index(j)-1)*dx_gcm -180. - dx_gcm/2.) + ! limits(j,2) = min(limits(j,2),(i_index(j)-1)*dx_gcm -180. + dx_gcm/2.) + ! endif + write (10,'(i10,i8,5(2x,f9.4))')j+ip1,id(j+ip1),limits(j,1), & + limits(j,2),limits(j,3),limits(j,4),tile_ele(j) + end do + close(10,status='keep') + + ! -------------------------------------------------------------------------- + ! + ! write nc4-formatted tile file (all tile types) + + rTable(1:ip,6:9) = limits + rTable(1:ip, 10) = tile_ele(1:ip) + ! re-define rTable(:,4) and rTable(:,5). + ! fr will be re-created in WriteTilingNC4 + where (rTable(:,4) /=0.0) + rTable(:,4) = rTable(:,3)/rTable(:,4) + endwhere + where (rTable(:,5) /=0.0) + rTable(:,5) = rTable(:,3)/rTable(:,5) + endwhere + + fname=trim(fnameTil)//'.nc4' + call MAPL_WriteTilingNC4(fname, gName(1:n_grid), im(1:n_grid), jm(1:n_grid), nx, ny, iTable, rTable, N_PfafCat=SRTM_maxcat, rc=status) + + deallocate (rTable, iTable) deallocate (limits) deallocate (catid) deallocate (q0) if(regrid) then deallocate(raster) - endif - END SUBROUTINE catchment_def + endif + + END SUBROUTINE supplemental_tile_attributes -!---------------------------------------------------------------------- + !---------------------------------------------------------------------- - SUBROUTINE create_soil_types_files (nx,ny,ease_grid,gfilet,gfiler) - - implicit none + SUBROUTINE create_soil_types_files( nx, ny, n_land, tile_pfs, catid ) + + integer, intent(in) :: nx, ny + integer, intent(in) :: n_land + integer, intent(in) :: tile_pfs(:) + INTEGER, target,intent(in) :: CATID(:,:) + ! This program reads global 5'x5' soil texture classification, ! then find the dominant Soil Classes for the GCM ! http://www.ngdc.noaa.gov/seg/eco/cdroms/reynolds/reynolds/reynolds.htm @@ -2249,7 +1259,6 @@ SUBROUTINE create_soil_types_files (nx,ny,ease_grid,gfilet,gfiler) PARAMETER(col=4320,row=2160) INTEGER, allocatable :: SIB_LAY(:,:) - INTEGER, allocatable, target :: CATID(:,:) INTEGER, allocatable :: SOIL1(:,:) INTEGER, allocatable :: SOIL2(:,:) INTEGER tem1 (13),tem2(13),tem3(13) @@ -2257,281 +1266,251 @@ SUBROUTINE create_soil_types_files (nx,ny,ease_grid,gfilet,gfiler) INTEGER IDVAL,STEX INTEGER (kind=1), allocatable :: gtext(:,:) INTEGER irrecs, c1,c2,r1,r2 - CHARACTER*200 ifile,ifile2,ofile1,ofile2,fname - CHARACTER (*) :: gfiler,gfilet - character*10 :: dline - CHARACTER*20 :: version,resoln + CHARACTER*512 ifile,ifile2,ofile1,ofile2,fname + CHARACTER*512 :: version,resoln INTEGER, allocatable, dimension (:) :: id !indx,id,indx_old integer :: nc_gcm,nr_gcm,nc_ocean,nr_ocean REAL :: lat,lon,fr_gcm,fr_cat,tarea INTEGER :: typ,pfs,ig,jg,j_dum,ierr,indx_dum,indr1,indr2,indr3 ,ip2 - integer :: nx,ny,status - logical :: ease_grid - -! --------- VARIABLES FOR *OPENMP* PARALLEL ENVIRONMENT ------------ -! -! NOTE: "!$" is for conditional compilation -! -logical :: running_omp = .false. -! -!$ integer :: omp_get_thread_num, omp_get_num_threads -! -integer :: n_threads=1 - -! ----------- OpenMP PARALLEL ENVIRONMENT ---------------------------- -! -! FIND OUT WHETHER -omp FLAG HAS BEEN SET DURING COMPILATION -! -!$ running_omp = .true. ! conditional compilation -! -! ECHO BASIC OMP VARIABLES -! -!$OMP PARALLEL DEFAULT(NONE) SHARED(running_omp,n_threads) -! -!$OMP SINGLE -! -!$ n_threads = omp_get_num_threads() -! -!$ write (*,*) 'running_omp = ', running_omp -!$ write (*,*) -!$ write (*,*) 'parallel OpenMP with ', n_threads, 'threads' -!$ write (*,*) -!$OMP ENDSINGLE -! -!$OMP CRITICAL -!$ write (*,*) 'thread ', omp_get_thread_num(), ' alive' -!$OMP ENDCRITICAL -! -!$OMP BARRIER -! -!$OMP ENDPARALLEL -! ----------- OpenMP PARALLEL ENVIRONMENT ---------------------------- + integer :: status + ! --------- VARIABLES FOR *OPENMP* PARALLEL ENVIRONMENT ------------ + ! + ! NOTE: "!$" is for conditional compilation + ! + logical :: running_omp = .false. + ! + !$ integer :: omp_get_thread_num, omp_get_num_threads + ! + integer :: n_threads=1 + + ! ----------- OpenMP PARALLEL ENVIRONMENT ---------------------------- + ! + ! FIND OUT WHETHER -omp FLAG HAS BEEN SET DURING COMPILATION + ! + !$ running_omp = .true. ! conditional compilation + ! + ! ECHO BASIC OMP VARIABLES + ! + !$OMP PARALLEL DEFAULT(NONE) SHARED(running_omp,n_threads) + ! + !$OMP SINGLE + ! + !$ n_threads = omp_get_num_threads() + ! + !$ write (*,*) 'running_omp = ', running_omp + !$ write (*,*) + !$ write (*,*) 'parallel OpenMP with ', n_threads, 'threads' + !$ write (*,*) + !$OMP ENDSINGLE + ! + !$OMP CRITICAL + !$ write (*,*) 'thread ', omp_get_thread_num(), ' alive' + !$OMP ENDCRITICAL + ! + !$OMP BARRIER + ! + !$OMP ENDPARALLEL + ! ----------- OpenMP PARALLEL ENVIRONMENT ---------------------------- + colsib = nx rowsib = ny ! ! Compute the number of input records per row. irrecs = nint (col / 4.0) ! - allocate(catid(1:nx,1:ny)) - catid =0 - + call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) - + ifile=trim(MAKE_BCS_INPUT_DIR)//'/land/soil/SOIL-DATA/soil_properties/v1/'//'dtex_tp1.bin' ifile2=trim(MAKE_BCS_INPUT_DIR)//'/land/soil/SOIL-DATA/soil_properties/v1/'//'dtex_sb1.bin' ofile1='clsm/soil_text.top' ofile2='clsm/soil_text.com' - fname=trim(gfilet)//'.til' + ip = size(tile_pfs,1) + allocate(id(1:ip), source = tile_pfs) - open (10,file=fname,status='old',action='read',form='formatted') - read (10,*)ip - read (10,*)j_dum + ip2 = ip1 + n_land + + ! write(*,*)'Finished reading CAT_IDs' - do n = 1, j_dum - read (10,'(a)')version - read (10,*)nc_gcm - read (10,*)nr_gcm + ! Top layer soil classification 0-30cm + ! + open (unit=11, file=ifile, form='unformatted', status='old', & + convert = 'big_endian') + + ! + allocate(gtext(1:col,1:row)) + allocate(SIB_LAY(1:nx,1:ny)) + gtext(:,:)=0 + SIB_LAY(:,:)=0 + k=0 + do j=row,1,-1 + ! do i=1,irrecs + ! k=k+1 + ! c1 = (4*i)-3 + ! c2 = (4*i) + ! read (unit=11, rec=k) (gtext(ii,j), ii=c1,c2) + read (unit=11) (gtext(i,j), i=1,col) + ! end do end do - - allocate(id(ip)) - id=0 - - do n = 1,ip - if (ease_grid) then - read(10,*,IOSTAT=ierr) typ,pfs,lon,lat,ig,jg,fr_gcm - else - read(10,'(I10,3E20.12,9(2I10,E20.12,I10))',IOSTAT=ierr) & - typ,tarea,lon,lat,ig,jg,fr_gcm,indx_dum,pfs,j_dum,fr_cat,j_dum - endif - id(n)=pfs - if (typ == 100) ip2 = n - - if(ierr /= 0)write (*,*)'Problem reading' - end do - - close (10,status='keep') -! - fname=trim(gfiler)//'.rst' - - open (1,file=fname,form='unformatted',status='old', convert='little_endian') - - do j=1,ny - read (1)(catid(i,j),i=1,nx) - end do - - close(1,status='keep') - ! write(*,*)'Finished reading CAT_IDs' - - ! Top layer soil classification 0-30cm - ! - open (unit=11, file=ifile, form='unformatted', status='old', & - convert = 'big_endian') - - ! - allocate(gtext(1:col,1:row)) - allocate(SIB_LAY(1:nx,1:ny)) - gtext(:,:)=0 - SIB_LAY(:,:)=0 - k=0 - do j=row,1,-1 -! do i=1,irrecs -! k=k+1 -! c1 = (4*i)-3 -! c2 = (4*i) -! read (unit=11, rec=k) (gtext(ii,j), ii=c1,c2) - read (unit=11) (gtext(i,j), i=1,col) -! end do - end do - - close (11,status='keep') -! - do j=1,rowsib - jsol=CEILING(j/(ny/real(row))) - do i=1,colsib - isol=CEILING(i/(nx/real(col))) - SIB_LAY(i,j)=gtext(isol,jsol) - end do - end do - - deallocate(gtext) - ! - ! Top layer on 2x2.5 - allocate(soil1(ip2,1:13)) - soil1(:,:)=0 - do j=1,rowsib - do i=1,colsib - if((catid(i,j) > ip1).and.(catid(i,j) <= ip2))then - IDVAL=catid(i,j) - STEX=SIB_LAY(i,j) - SOIL1(IDVAL,STEX+1)=SOIL1(IDVAL,STEX+1)+1 - end if - end do - end do - ! - ! write(*,*)'Finished reading top layer' - deallocate(sib_lay) - ! - ! Bottom layer soil classification 30-100cm - ! -! open (unit=11, file=ifile2, form='unformatted', status='old',access='direct',recl=1, & -! convert = 'big_endian') - open (unit=11, file=ifile2, form='unformatted', status='old', & - convert = 'big_endian') - - ! - allocate(gtext(1:col,1:row)) - allocate(SIB_LAY(1:colsib,1:rowsib)) - gtext(:,:)=0 - SIB_LAY(:,:)=0 - k=0 - do j=row,1,-1 -! do i=1,irrecs -! k=k+1 -! c1 = (4*i)-3 -! c2 = (4*i) -! read (unit=11, rec=k) (gtext(ii,j), ii=c1,c2) - read (unit=11) (gtext(i,j), i=1,col) -! end do - end do - ! - close (11,status='keep') - - do j=1,rowsib - jsol=CEILING(j/(ny/real(row))) - do i=1,colsib - isol=CEILING(i/(nx/real(col))) - SIB_LAY(i,j)=gtext(isol,jsol) - end do - end do - deallocate(gtext) - ! write(*,*)'Finished reading bottom layer' - ! - ! Bottom layer on 2x2.5 - allocate(soil2(ip2,1:13)) - soil2(:,:)=0 - do j=1,rowsib - do i=1,colsib - if((catid(i,j) > ip1).and.(catid(i,j) <= ip2))then - IDVAL=catid(i,j) - - STEX=SIB_LAY(i,j) - SOIL2(IDVAL,STEX+1)=SOIL2(IDVAL,STEX+1)+1 - endif - end do - end do - deallocate(sib_lay) - ! -! write(*,*)'Finished counting pixels for each catchment' - k=0 - allocate(top(ip2,2)) - allocate(com(ip2,2)) - top=0 - com=0 - do j=1,ip2 - tem1(1:13)=SOIL1(j,1:13) - tem2(1:13)=SOIL2(j,1:13) - - tem3(:)=3*tem1(:)+7*tem2(:) - if((sum(tem3).gt.0).and.(sum(tem1).eq.0))then - tem1(:)=tem3(:) - write(*,*)'Filled from the bottom layer',j - end if - if(sum(tem1).gt.0)then -! k=k+1 -! ! -! clr1=maxloc(tem1) -! clr2=maxloc(tem3) -! top(k,1)=j -! top(k,2)=clr1(1)-1 -! com(k,1)=j -! com(k,2)=clr2(1)-1 - k=k+1 - ! - clr1=maxloc(tem1) - clr2=maxloc(tem3) - top(j,1)=j - top(j,2)=clr1(1)-1 - com(j,1)=j - com(j,2)=clr2(1)-1 + + close (11,status='keep') + ! + do j=1,rowsib + jsol=CEILING(j/(ny/real(row))) + do i=1,colsib + isol=CEILING(i/(nx/real(col))) + SIB_LAY(i,j)=gtext(isol,jsol) + end do + end do + + deallocate(gtext) + ! + ! Top layer on 2x2.5 + allocate(soil1(n_land,1:13)) + soil1(:,:)=0 + do j=1,rowsib + do i=1,colsib + if((catid(i,j) > ip1).and.(catid(i,j) <= ip2))then + IDVAL=catid(i,j) + STEX=SIB_LAY(i,j) + SOIL1(IDVAL,STEX+1)=SOIL1(IDVAL,STEX+1)+1 end if end do + end do + ! + ! write(*,*)'Finished reading top layer' + deallocate(sib_lay) + ! + ! Bottom layer soil classification 30-100cm + ! + ! open (unit=11, file=ifile2, form='unformatted', status='old',access='direct',recl=1, & + ! convert = 'big_endian') + open (unit=11, file=ifile2, form='unformatted', status='old', & + convert = 'big_endian') + + ! + allocate(gtext(1:col,1:row)) + allocate(SIB_LAY(1:colsib,1:rowsib)) + gtext(:,:)=0 + SIB_LAY(:,:)=0 + k=0 + do j=row,1,-1 + ! do i=1,irrecs + ! k=k+1 + ! c1 = (4*i)-3 + ! c2 = (4*i) + ! read (unit=11, rec=k) (gtext(ii,j), ii=c1,c2) + read (unit=11) (gtext(i,j), i=1,col) + ! end do + end do + ! + close (11,status='keep') + + do j=1,rowsib + jsol=CEILING(j/(ny/real(row))) + do i=1,colsib + isol=CEILING(i/(nx/real(col))) + SIB_LAY(i,j)=gtext(isol,jsol) + end do + end do + deallocate(gtext) + ! write(*,*)'Finished reading bottom layer' + ! + ! Bottom layer on 2x2.5 + allocate(soil2(n_land,1:13)) + soil2(:,:)=0 + do j=1,rowsib + do i=1,colsib + if((catid(i,j) > ip1).and.(catid(i,j) <= ip2))then + IDVAL=catid(i,j) + + STEX=SIB_LAY(i,j) + SOIL2(IDVAL,STEX+1)=SOIL2(IDVAL,STEX+1)+1 + endif + end do + end do + deallocate(sib_lay) + ! + ! write(*,*)'Finished counting pixels for each catchment' + k=0 + allocate(top(n_land,2)) + allocate(com(n_land,2)) + top=0 + com=0 + do j=1,n_land + tem1(1:13)=SOIL1(j,1:13) + tem2(1:13)=SOIL2(j,1:13) + + tem3(:)=3*tem1(:)+7*tem2(:) + if((sum(tem3).gt.0).and.(sum(tem1).eq.0))then + tem1(:)=tem3(:) + write(*,*)'Filled from the bottom layer',j + end if + if(sum(tem1).gt.0)then + ! k=k+1 + ! ! + ! clr1=maxloc(tem1) + ! clr2=maxloc(tem3) + ! top(k,1)=j + ! top(k,2)=clr1(1)-1 + ! com(k,1)=j + ! com(k,2)=clr2(1)-1 + k=k+1 + ! + clr1=maxloc(tem1) + clr2=maxloc(tem3) + top(j,1)=j + top(j,2)=clr1(1)-1 + com(j,1)=j + com(j,2)=clr2(1)-1 + end if + end do + ! + open (unit=11, file=ofile1, form='formatted', status='unknown') + open (unit=12, file=ofile2, form='formatted', status='unknown') + + ! + if(top(1,2).eq.0)top(1,2)= 3 + if(com(1,2).eq.0)com(1,2)= 9 + + do j=1,n_land + + if(top(j,2).eq.0)top(j,2)=top(j-1,2) + if(com(j,2).eq.0)com(j,2)=com(j-1,2) + + ! if(com(j,1).gt.0)then + ! if(j.gt.1)then + ! if(top(j,2).eq.0)top(j,2)=top(j-1,2) + ! if(com(j,2).eq.0)com(j,2)=com(j-1,2) + ! end if ! - open (unit=11, file=ofile1, form='formatted', status='unknown') - open (unit=12, file=ofile2, form='formatted', status='unknown') - - ! - if(top(1,2).eq.0)top(1,2)= 3 - if(com(1,2).eq.0)com(1,2)= 9 - - do j=1,ip2 - - if(top(j,2).eq.0)top(j,2)=top(j-1,2) - if(com(j,2).eq.0)com(j,2)=com(j-1,2) - - ! if(com(j,1).gt.0)then - ! if(j.gt.1)then - ! if(top(j,2).eq.0)top(j,2)=top(j-1,2) - ! if(com(j,2).eq.0)com(j,2)=com(j-1,2) - ! end if - ! - write(11,*)j,id(j),top(j,2) - write(12,*)j,id(j),com(j,2) - - end do - close(11) - close(12) - deallocate (CATID,soil1,soil2,top,com,id) - + write(11,*)j,id(j),top(j,2) + write(12,*)j,id(j),com(j,2) + + end do + close(11) + close(12) + deallocate (soil1,soil2,top,com,id) + END SUBROUTINE create_soil_types_files - -!---------------------------------------------------------------------- - - SUBROUTINE compute_mosaic_veg_types (nx,ny,ease_grid,regrid,gfilet,gfiler) - - implicit none + + !---------------------------------------------------------------------- + + SUBROUTINE compute_mosaic_veg_types( nx, ny, regrid, n_land, tile_pfs, Rst_id) + + integer, intent(in) :: nx, ny + + logical, intent(in) :: regrid + + integer, intent(in) :: n_land + integer, intent(in) :: tile_pfs(:) + integer, intent(in) :: Rst_id(:,:) + + ! ----------------------------- + integer*1, allocatable , dimension (:,:) :: sib_veg2 integer, allocatable , target , dimension (:,:) :: sib_veg integer, allocatable :: mos_veg(:,:) @@ -2541,55 +1520,31 @@ SUBROUTINE compute_mosaic_veg_types (nx,ny,ease_grid,regrid,gfilet,gfiler) REAL, allocatable :: veg(:,:),bare_frac(:),zdep2_g(:,:) REAL :: fmax0,dummy,tem(6),mfrac,sfrac,bfrac - integer :: n,ip,maxcat,count,k1,i1,i + integer :: n,ip,count,k1,i1,i INTEGER, allocatable, dimension (:) :: id ! indx,id,indx_old integer :: nc_gcm,nr_gcm,nc_ocean,nr_ocean REAL :: lat,lon,fr_gcm,fr_cat,tarea - INTEGER :: typ,pfs,ig,jg,i_dum,j_dum,ierr,indx_dum,indr1,indr2,indr3 ,ip2 - character*100 :: fname,fout - character (*) :: gfiler,gfilet - character*10 :: dline - CHARACTER*20 :: version,resoln,continent + INTEGER :: ig,jg,i_dum,j_dum,ierr,indx_dum,indr1,indr2,indr3,ip2 + character*512 :: fname,fout + CHARACTER*512 :: version,resoln,continent character*2 :: chyear integer :: mon,smon,imon,year - integer :: nx,ny,status - logical :: regrid,ease_grid + integer :: status integer, pointer :: Raster(:,:) real, pointer, dimension (:) :: z2, z0 real, dimension (6) :: VGZ2 = (/35.0, 20.0, 17.0, 0.6, 0.5, 0.6/) ! Dorman and Sellers (1989) logical :: file_exists integer :: ncid - fname=trim(gfilet)//'.til' - open (10,file=fname,status='old',action='read',form='formatted') - read (10,*)ip - allocate(id(1:ip)) - - read (10,*)j_dum - - do n = 1, j_dum - read (10,'(a)')version - read (10,*)nc_gcm - read (10,*)nr_gcm - end do - - do n = 1,ip - if (ease_grid) then - read(10,*,IOSTAT=ierr) typ,pfs,lon,lat,ig,jg,fr_gcm - else - read(10,'(I10,3E20.12,9(2I10,E20.12,I10))',IOSTAT=ierr) & - typ,tarea,lon,lat,ig,jg,fr_gcm,indx_dum,pfs,i_dum,fr_cat,j_dum - endif - id(n)=pfs - if (typ == 100) ip2 = n - if(ierr /= 0)write (*,*)'Problem reading' - end do - close (10,status='keep') - maxcat=ip2 + ip = size(tile_pfs,1) + + ip2 = ip1 + n_land + + allocate(id(1:ip), source = tile_pfs) allocate(sib_veg2(1:i_raster,1:j_raster)) allocate(sib_veg (1:i_raster,1:j_raster)) - + call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) open (10,file=trim(MAKE_BCS_INPUT_DIR)//'/land/veg/pft/v1/sib22.5_v2.0.dat',form='unformatted', & status='old',action='read',convert='big_endian') @@ -2602,17 +1557,13 @@ SUBROUTINE compute_mosaic_veg_types (nx,ny,ease_grid,regrid,gfilet,gfiler) else raster => sib_veg end if - + if(regrid) then call RegridRaster(sib_veg,raster) - endif - - fname=trim(gfiler)//'.rst' - - open (10,file=fname,status='old',action='read',form='unformatted',convert='little_endian') + endif - allocate(veg(1:maxcat,1:6)) - allocate(zdep2_g(1:maxcat,1:1)) + allocate(veg(1:n_land,1:6)) + allocate(zdep2_g(1:n_land,1:1)) veg=0. zdep2_g=0. @@ -2621,14 +1572,14 @@ SUBROUTINE compute_mosaic_veg_types (nx,ny,ease_grid,regrid,gfilet,gfiler) do j=1,ny - read (10)(catid(i),i=1,nx) + catid(:) = Rst_id(:,j) do i=1,nx if((catid(i) > ip1).and.(catid(i) <= ip2))then zdep2_g(catid(i)-ip1,1)=zdep2_g(catid(i)-ip1,1)+1. if(raster(i,j).eq.0) then -! write (*,*)'Warning : SiB2 =0, an ocean pixel found !' + ! write (*,*)'Warning : SiB2 =0, an ocean pixel found !' elseif (raster(i,j).eq.1) then veg(catid(i)-ip1,1)=veg(catid(i)-ip1,1) + 1. elseif (raster(i,j).eq.2) then @@ -2645,12 +1596,12 @@ SUBROUTINE compute_mosaic_veg_types (nx,ny,ease_grid,regrid,gfilet,gfiler) elseif (raster(i,j).eq.7) then veg(catid(i)-ip1,5)=veg(catid(i)-ip1,5) + 1. elseif (raster(i,j).eq.8) then -! if (j >= NINT(float(ny)*(140./180.))) then -! veg(catid(i)-ip1,6)=veg(catid(i)-ip1,6) + 1. -! else -! veg(catid(i)-ip1,5)=veg(catid(i)-ip1,5) + 1. -! endif - if ((j > NINT(float(ny)*(40./180.))).and.(j < NINT(float(ny)*(140./180.)))) then + ! if (j >= NINT(float(ny)*(140./180.))) then + ! veg(catid(i)-ip1,6)=veg(catid(i)-ip1,6) + 1. + ! else + ! veg(catid(i)-ip1,5)=veg(catid(i)-ip1,5) + 1. + ! endif + if ((j > NINT(float(ny)*(40./180.))).and.(j < NINT(float(ny)*(140./180.)))) then veg(catid(i)-ip1,5)=veg(catid(i)-ip1,5) + 1. else veg(catid(i)-ip1,6)=veg(catid(i)-ip1,6) + 1. @@ -2658,29 +1609,27 @@ SUBROUTINE compute_mosaic_veg_types (nx,ny,ease_grid,regrid,gfilet,gfiler) elseif (raster(i,j).eq.9) then veg(catid(i)-ip1,4)=veg(catid(i)-ip1,4) + 1. elseif (raster(i,j).eq.10) then -! write (*,*)'Warning : SiB2 =10, a water pixel found !' + ! write (*,*)'Warning : SiB2 =10, a water pixel found !' elseif (raster(i,j).eq.11) then -! write (*,*)'Warning : SiB2 =11, an ice pixel found !' + ! write (*,*)'Warning : SiB2 =11, an ice pixel found !' elseif (raster(i,j).eq.100) then -! write (*,*)'Warning : SiB2 =100, NODATA pixel found !' + ! write (*,*)'Warning : SiB2 =100, NODATA pixel found !' endif endif enddo enddo - close(10,status='keep') - - allocate(mos_veg(1:maxcat,1:2)) - allocate(veg_frac(1:maxcat,1:3)) + allocate(mos_veg(1:n_land,1:2)) + allocate(veg_frac(1:n_land,1:3)) mos_veg=0 veg_frac=0. k=0 - do j=1,maxcat + do j=1,n_land tem(1:6)=veg(j,1:6) - + if(sum(tem).le.0.)write(*,*) 'Warning no veg types',j -! if(sum(tem).le.0.) stop + ! if(sum(tem).le.0.) stop if(sum(tem).gt.0)then k=k+1 @@ -2737,78 +1686,81 @@ SUBROUTINE compute_mosaic_veg_types (nx,ny,ease_grid,regrid,gfilet,gfiler) veg_frac(k,2)=0. write(*,*)k,tem write(*,*)mos_veg(j,1),mos_veg(j,2),veg_frac(j,1),veg_frac(j,2),veg_frac(j,3) - endif + endif end do deallocate(veg) - - ! Canopy height and ASCAT roughness length - - call ascat_r0 (nx,ny,gfiler, z0) - + + ! Canopy height and ASCAT roughness length + + call ascat_r0 (nx,ny, n_land, Rst_id, z0) + if(jpl_height) then - call jpl_canoph (nx,ny,gfiler, z2) + call jpl_canoph (nx,ny, n_land, Rst_id, z2) else - allocate (z2(1:maxcat)) - endif + allocate (z2(1:n_land)) + endif open (10,file='clsm/mosaic_veg_typs_fracs', & form='formatted',status='unknown') - do j=1,maxcat + do j=1,n_land if (mos_veg(j,1) == 0) then - if(.not.jpl_height) z2(j) = VGZ2(mos_veg(j,1)) - mos_veg(j,1) = mos_veg(j-1,1) - mos_veg(j,2) = mos_veg(j-1,2) - write (10,'(i10,i8,2(2x,i3),2(2x,f6.2),2x,f6.3,2x,f10.7)') & - j+ip1,id(j+ip1),mos_veg(j-1,1),mos_veg(j-1,2),veg_frac(j,1),veg_frac(j,2),z2(j), z0 (j) + if(.not.jpl_height) z2(j) = VGZ2(mos_veg(j,1)) + mos_veg(j,1) = mos_veg(j-1,1) + mos_veg(j,2) = mos_veg(j-1,2) + write (10,'(i10,i8,2(2x,i3),2(2x,f6.2),2x,f6.3,2x,f10.7)') & + j+ip1,id(j+ip1),mos_veg(j-1,1),mos_veg(j-1,2),veg_frac(j,1),veg_frac(j,2),z2(j), z0 (j) else - if(.not.jpl_height) z2(j) = VGZ2(mos_veg(j,1)) - write (10,'(i10,i8,2(2x,i3),2(2x,f6.2),2x,f6.3,2x,f10.7)') & - j+ip1,id(j+ip1),mos_veg(j,1),mos_veg(j,2),veg_frac(j,1),veg_frac(j,2),z2(j), z0 (j) + if(.not.jpl_height) z2(j) = VGZ2(mos_veg(j,1)) + write (10,'(i10,i8,2(2x,i3),2(2x,f6.2),2x,f6.3,2x,f10.7)') & + j+ip1,id(j+ip1),mos_veg(j,1),mos_veg(j,2),veg_frac(j,1),veg_frac(j,2),z2(j), z0 (j) endif end do close(10,status='keep') - + inquire(file='clsm/catch_params.nc4', exist=file_exists) - + if(file_exists) then status = NF_OPEN ('clsm/catch_params.nc4', NF_WRITE, ncid ) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'OLD_ITY'),(/1/),(/maxcat/),real(mos_veg(:,1))) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'OLD_ITY'),(/1/),(/n_land/),real(mos_veg(:,1))) ; VERIFY_(STATUS) STATUS = NF_CLOSE (NCID) ; VERIFY_(STATUS) endif - + inquire(file='clsm/vegdyn.data', exist=file_exists) - + if(file_exists) then status = NF_OPEN ('clsm/vegdyn.data', NF_WRITE, ncid ) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ITY' ),(/1/),(/maxcat/),real(mos_veg(:,1))) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'Z2CH' ),(/1/),(/maxcat/),z2 ) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ASCATZ0'),(/1/),(/maxcat/),Z0 ) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ITY' ),(/1/),(/n_land/),real(mos_veg(:,1))) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'Z2CH' ),(/1/),(/n_land/),z2 ) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ASCATZ0'),(/1/),(/n_land/),Z0 ) ; VERIFY_(STATUS) STATUS = NF_CLOSE (NCID) ; VERIFY_(STATUS) else open (20,file='clsm/vegdyn.data',status='unknown',action='write',form='unformatted', & convert='little_endian') - + write (20) real(mos_veg(:,1)) write (20) z2 (:) write (20) z0 (:) close (20) endif - + deallocate (sib_veg2,sib_veg,mos_veg,veg_frac,zdep2_g,id, z0, z2) if(regrid) then deallocate(raster) - endif - + endif + END SUBROUTINE compute_mosaic_veg_types -!---------------------------------------------------------------------- + !---------------------------------------------------------------------- + + SUBROUTINE cti_stat_file ( MaskFile, n_land, tile_pfs, til_j_dum) + character(*), intent(in) :: MaskFile + integer, intent(in) :: n_land, tile_pfs(:), til_j_dum(:) - SUBROUTINE cti_stat_file (ease_grid,gfile, MaskFile) + ! ---------------------------------------------- - IMPLICIT NONE INTEGER, PARAMETER :: nbcat=36716,nofvar=6 - INTEGER :: n,i,ip, itext(SRTM_maxcat,2),ix, jx,ip2, maxcat - INTEGER :: typ,pfs,ig,jg,j_dum,ierr,indx_dum,indr1,indr2,indr3 + INTEGER :: n,i,ip, itext(SRTM_maxcat,2),ix, jx,ip2 + INTEGER :: pfs, ig,jg,j_dum,ierr,indx_dum,indr1,indr2,indr3 INTEGER*8 :: idum8 INTEGER :: ncat,i_dum INTEGER, dimension(:), allocatable :: colin2cat @@ -2820,46 +1772,18 @@ SUBROUTINE cti_stat_file (ease_grid,gfile, MaskFile) REAL :: fr REAL, allocatable, dimension (:,:) :: var REAL, allocatable, dimension (:) :: dummy - logical :: ease_grid - CHARACTER*20 :: version - character*100 :: fname - character(*) :: gfile - character(*) :: MaskFile + CHARACTER*512 :: version + character*512 :: fname - fname=trim(gfile)//'.til' - open (10,file=fname,status='old',action='read',form='formatted') - read (10,*)ip + ip = size(tile_pfs,1) allocate(indx_old(ip)) allocate(id(ip)) - indx_old=0 - id=0 - - read (10,*)j_dum - do n = 1, j_dum - read (10,'(a)')version - read (10,*)nc_gcm - read (10,*)nr_gcm - end do - - do n = 1,ip - if (ease_grid) then - read(10,*,IOSTAT=ierr) typ,pfs !,lon,lat,ig,jg,fr_gcm,i_dum - else - read(10,'(I10,3E20.12,9(2I10,E20.12,I10))',IOSTAT=ierr) & - typ,tarea,lon,lat,ig,jg,fr_gcm,indx_dum,pfs,i_dum,fr_cat,j_dum - endif - - id(n)=pfs - indx_old(n) = j_dum - if (index(MaskFile,'GEOS5_10arcsec_mask') /= 0) indx_old(n) = pfs - if (typ == 100) ip2 = n - if (ierr /= 0) write (*,*)'Problem reading',fname - if (ierr /= 0) stop - end do - - close (10,status='keep') - + ip2 = ip1 + n_land + id = tile_pfs + indx_old = til_j_dum + if (index(MaskFile,'GEOS5_10arcsec_mask') /= 0) indx_old = tile_pfs + allocate(colin2cat(1:6000000)) colin2cat=0 call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) @@ -2873,11 +1797,11 @@ SUBROUTINE cti_stat_file (ease_grid,gfile, MaskFile) read (10,*) ncat do n=1,ncat - if (index(MaskFile,'GEOS5_10arcsec_mask') /= 0) then - read (10,*)indx_dum,idum8 - else - read (10,*)j_dum,indx_dum - endif + if (index(MaskFile,'GEOS5_10arcsec_mask') /= 0) then + read (10,*)indx_dum,idum8 + else + read (10,*)j_dum,indx_dum + endif colin2cat(indx_dum)=n end do close (10,status='keep') @@ -2892,7 +1816,7 @@ SUBROUTINE cti_stat_file (ease_grid,gfile, MaskFile) fname='clsm/cti_stats.dat' open (20,file=fname,form='formatted', status='unknown') - write (20,*)ip2 + write (20,*) n_land read (10,*)ncat allocate(var(1:ncat,1:nofvar)) @@ -2919,475 +1843,604 @@ SUBROUTINE cti_stat_file (ease_grid,gfile, MaskFile) end do close (10,status='keep') -! - do i=1,ip - - if((i > ip1).and.(i <= ip2))then - if(((id(i).ge.5000142).and.(id(i).le.5025829)))then - write(20,'(i10,i8,5(1x,f8.4),i5,e18.3)')i,id(i),var(indx_old(i),1)*11.1/9.1,var(indx_old(i),2), & - var(indx_old(i),3),var(indx_old(i),4),var(indx_old(i),5),itext(indx_old(i),2), & - var(indx_old(i),6) - else + ! + do i=ip1+1,ip2 + if(((id(i).ge.5000142).and.(id(i).le.5025829)))then + write(20,'(i10,i8,5(1x,f8.4),i5,e18.3)')i,id(i),var(indx_old(i),1)*11.1/9.1,var(indx_old(i),2), & + var(indx_old(i),3),var(indx_old(i),4),var(indx_old(i),5),itext(indx_old(i),2), & + var(indx_old(i),6) + else - write(20,'(i10,i8,5(1x,f8.4),i5,e18.3)')i,id(i),var(indx_old(i),1),var(indx_old(i),2), & - var(indx_old(i),3),var(indx_old(i),4),var(indx_old(i),5),itext(indx_old(i),2), & - var(indx_old(i),6) - endif + write(20,'(i10,i8,5(1x,f8.4),i5,e18.3)')i,id(i),var(indx_old(i),1),var(indx_old(i),2), & + var(indx_old(i),3),var(indx_old(i),4),var(indx_old(i),5),itext(indx_old(i),2), & + var(indx_old(i),6) endif - end do close (20,status='keep') deallocate (colin2cat,var,id,indx_old) END SUBROUTINE cti_stat_file - -!--------------------------------------------------------------------- - - SUBROUTINE create_model_para (MaskFile) - - implicit none - integer i,n,k, tindex1,pfaf1,nbcatch - integer soil_gswp - real meanlu,stdev,minlu,maxlu,coesk,rzdep - real minlat,maxlat,minlon,maxlon - real,allocatable, dimension (:) :: & - BEE, PSIS,POROS,COND,WPWET,soildepth, tile_lon, tile_lat - REAL, allocatable, dimension(:) :: TOPMEAN, TOPVAR, TOPSKEW - REAL ST(NAR), AC(NAR),COESKEW - REAL, allocatable, dimension (:) :: & - ARS1,ARS2,ARS3, ARA1,ARA2,ARA3,ARA4, & - ARW1,ARW2,ARW3,ARW4,bf1, bf2, bf3, & - tsa1, tsa2,tsb1, tsb2, & - taberr1,taberr2,normerr1,normerr2, & - taberr3,taberr4,normerr3,normerr4 - integer, dimension(12) :: tile_pick - integer, allocatable, dimension (:) :: soil_class_top,soil_class_com,tindex2,pfaf2 - real watdep(nwt,nrz),wan(nwt,nrz),rzexcn(nwt,nrz),frc(nwt,nrz) - real, allocatable, dimension (:,:,:,:) :: & - gwatdep,gwan,grzexcn,gfrc - real :: wtdep,wanom,rzaact,fracl,profdep,dist_save,tile_distance - character*200 :: pathout,fname,fout,losfile - character*10 :: dline - CHARACTER*20 :: version,resoln,continent - character*6 rdep,ext - integer :: iwt,irz,group - character(*) :: MaskFile - logical :: picked - - integer :: ncid, status - logical :: file_exists - real, allocatable, dimension (:,:) :: parms4file + + !--------------------------------------------------------------------- -! --------- VARIABLES FOR *OPENMP* PARALLEL ENVIRONMENT ------------ -! -! NOTE: "!$" is for conditional compilation -! -logical :: running_omp = .false. -! -!$ integer :: omp_get_thread_num, omp_get_num_threads -! -integer :: n_threads=1, li, ui -! -integer, dimension(:), allocatable :: low_ind, upp_ind -! -! ------------------------------------------------------------------ + SUBROUTINE create_model_para (MaskFile, nbcatch, tile_lon, tile_lat, tile_pfs) - ! ----------- OpenMP PARALLEL ENVIRONMENT ---------------------------- - ! - ! FIND OUT WHETHER -omp FLAG HAS BEEN SET DURING COMPILATION - ! - !$ running_omp = .true. ! conditional compilation - ! - ! ECHO BASIC OMP VARIABLES - ! - !$OMP PARALLEL DEFAULT(NONE) SHARED(running_omp,n_threads) - ! - !$OMP SINGLE - ! - !$ n_threads = omp_get_num_threads() - ! - !$ write (*,*) 'running_omp = ', running_omp - !$ write (*,*) - !$ write (*,*) 'parallel OpenMP with ', n_threads, 'threads' - !$ write (*,*) - !$OMP ENDSINGLE - ! - !$OMP CRITICAL - !$ write (*,*) 'thread ', omp_get_thread_num(), ' alive' - !$OMP ENDCRITICAL - ! - !$OMP BARRIER - ! - !$OMP ENDPARALLEL - ! ----------- OpenMP PARALLEL ENVIRONMENT ---------------------------- - -!c------------------------------------------------------------------------- - - call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) - losfile =trim(MAKE_BCS_INPUT_DIR)//'/land/soil/soil_water_loss/v1/loss_perday' -!c opening files - - - allocate (gwatdep(1:nwt,1:nrz,1:12,1:2)) - allocate (gwan (1:nwt,1:nrz,1:12,1:2)) - allocate (grzexcn(1:nwt,1:nrz,1:12,1:2)) - allocate (gfrc (1:nwt,1:nrz,1:12,1:2)) - - do n =1,12 - if(n.lt.10)write(ext,'(i1.1)')n - if(n.ge.10)write(ext,'(i2.2)')n - do i =1,2 - if (i==1) rdep='.rz75.' - if (i==2) rdep='.rz1.' - open (120,file=trim(losfile)//trim(rdep)//trim(ext), & - form='formatted',status='old') - - do iwt=1,nwt - do irz=1,nrz - read(120,2000) wtdep,wanom,rzaact,fracl - 2000 format(1x,4e16.8) - gwatdep(iwt,irz,n,i)=wtdep - gwan(iwt,irz,n,i)=wanom - grzexcn(iwt,irz,n,i)=rzaact - gfrc(iwt,irz,n,i)=amin1(fracl,1.) - enddo + character(*), intent(in) :: MaskFile + integer, intent(in) :: nbcatch + real, intent(in) :: tile_lon(:), tile_lat(:) + integer, intent(in) :: tile_pfs(:) + + ! -------------------------------------------- + + integer i,n,k, tindex1,pfaf1 + integer soil_gswp + real meanlu,stdev,minlu,maxlu,coesk,rzdep + real minlat,maxlat,minlon,maxlon + real,allocatable, dimension (:) :: & + BEE, PSIS,POROS,COND,WPWET,soildepth + REAL, allocatable, dimension(:) :: TOPMEAN, TOPVAR, TOPSKEW + REAL ST(NAR), AC(NAR),COESKEW + REAL, allocatable, dimension (:) :: & + ARS1,ARS2,ARS3, ARA1,ARA2,ARA3,ARA4, & + ARW1,ARW2,ARW3,ARW4,bf1, bf2, bf3, & + tsa1, tsa2,tsb1, tsb2, & + taberr1,taberr2,normerr1,normerr2, & + taberr3,taberr4,normerr3,normerr4 + integer, dimension(12) :: tile_pick + integer, allocatable, dimension (:) :: soil_class_top,soil_class_com,tindex2,pfaf2 + real watdep(nwt,nrz),wan(nwt,nrz),rzexcn(nwt,nrz),frc(nwt,nrz) + real, allocatable, dimension (:,:,:,:) :: & + gwatdep,gwan,grzexcn,gfrc + real :: wtdep,wanom,rzaact,fracl,profdep,dist_save,tile_distance + character*512 :: pathout,fname,fout,losfile + CHARACTER*512 :: version,resoln,continent + character*6 :: rdep,ext + integer :: iwt,irz,group + logical :: picked + + integer :: ncid, status + logical :: file_exists + real, allocatable, dimension (:,:) :: parms4file + + ! --------- VARIABLES FOR *OPENMP* PARALLEL ENVIRONMENT ------------ + ! + ! NOTE: "!$" is for conditional compilation + ! + logical :: running_omp = .false. + ! + !$ integer :: omp_get_thread_num, omp_get_num_threads + ! + integer :: n_threads=1, li, ui + ! + integer, dimension(:), allocatable :: low_ind, upp_ind + ! + ! ------------------------------------------------------------------ + + ! ----------- OpenMP PARALLEL ENVIRONMENT ---------------------------- + ! + ! FIND OUT WHETHER -omp FLAG HAS BEEN SET DURING COMPILATION + ! + !$ running_omp = .true. ! conditional compilation + ! + ! ECHO BASIC OMP VARIABLES + ! + !$OMP PARALLEL DEFAULT(NONE) SHARED(running_omp,n_threads) + ! + !$OMP SINGLE + ! + !$ n_threads = omp_get_num_threads() + ! + !$ write (*,*) 'running_omp = ', running_omp + !$ write (*,*) + !$ write (*,*) 'parallel OpenMP with ', n_threads, 'threads' + !$ write (*,*) + !$OMP ENDSINGLE + ! + !$OMP CRITICAL + !$ write (*,*) 'thread ', omp_get_thread_num(), ' alive' + !$OMP ENDCRITICAL + ! + !$OMP BARRIER + ! + !$OMP ENDPARALLEL + ! ----------- OpenMP PARALLEL ENVIRONMENT ---------------------------- + + !c------------------------------------------------------------------------- + + call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) + losfile =trim(MAKE_BCS_INPUT_DIR)//'/land/soil/soil_water_loss/v1/loss_perday' + !c opening files + + + allocate (gwatdep(1:nwt,1:nrz,1:12,1:2)) + allocate (gwan (1:nwt,1:nrz,1:12,1:2)) + allocate (grzexcn(1:nwt,1:nrz,1:12,1:2)) + allocate (gfrc (1:nwt,1:nrz,1:12,1:2)) + + do n =1,12 + if(n.lt.10)write(ext,'(i1.1)')n + if(n.ge.10)write(ext,'(i2.2)')n + do i =1,2 + if (i==1) rdep='.rz75.' + if (i==2) rdep='.rz1.' + open (120,file=trim(losfile)//trim(rdep)//trim(ext), & + form='formatted',status='old') + + do iwt=1,nwt + do irz=1,nrz + read(120,2000) wtdep,wanom,rzaact,fracl +2000 format(1x,4e16.8) + gwatdep(iwt,irz,n,i)=wtdep + gwan(iwt,irz,n,i)=wanom + grzexcn(iwt,irz,n,i)=rzaact + gfrc(iwt,irz,n,i)=amin1(fracl,1.) + enddo enddo close (120,status='keep') - end do - end do - fname='clsm/soil_param.first' - open (10,file=fname,action='read', & - form='formatted',status='old') - - fname='clsm/cti_stats.dat' - open (11,file=fname,action='read', & - form='formatted',status='old') - - fname='clsm/catchment.def' - open (12,file=fname,action='read', & - form='formatted',status='old') - - fout='clsm/ar.new' - open (20,file=fout,action='write', & - form='formatted',status='unknown') - - fout='clsm//bf.dat' - open (30,file=fout,action='write', & - form='formatted',status='unknown') - - fout='clsm//ts.dat' - open (40,file=fout,action='write', & - form='formatted',status='unknown') - - if (error_file) then - fout='clsm/ar_rmse.dat' - open (21,file=fout,action='write', & - form='formatted',status='unknown') - - fout='clsm/bf_rmse.dat' - open (31,file=fout,action='write', & - form='formatted',status='unknown') - - fout='clsm/bad_sat_param.tiles' - open (41,file=fout,action='write', & - form='formatted',status='unknown') - endif - fout='clsm/soil_param.dat' - open (42,file=fout,action='write', & - form='formatted',status='unknown') - read (11,*)nbcatch - read (12,*)nbcatch - - allocate (tile_lon(1:nbcatch)) - allocate (tile_lat(1:nbcatch)) - allocate (TOPMEAN (1:nbcatch)) - allocate (TOPVAR (1:nbcatch)) - allocate (TOPSKEW (1:nbcatch)) - allocate (ARS1 (1:nbcatch)) - allocate (ARS2 (1:nbcatch)) - allocate (ARS3 (1:nbcatch)) - allocate (ARA1 (1:nbcatch)) - allocate (ARA2 (1:nbcatch)) - allocate (ARA3 (1:nbcatch)) - allocate (ARA4 (1:nbcatch)) - allocate (ARW1 (1:nbcatch)) - allocate (ARW2 (1:nbcatch)) - allocate (ARW3 (1:nbcatch)) - allocate (ARW4 (1:nbcatch)) - allocate (BF1 (1:nbcatch)) - allocate (BF2 (1:nbcatch)) - allocate (BF3 (1:nbcatch)) - allocate (TSA1 (1:nbcatch)) - allocate (TSA2 (1:nbcatch)) - allocate (TSB1 (1:nbcatch)) - allocate (TSB2 (1:nbcatch)) - allocate (TABERR1 (1:nbcatch)) - allocate (TABERR2 (1:nbcatch)) - allocate (TABERR3 (1:nbcatch)) - allocate (TABERR4 (1:nbcatch)) - allocate (NORMERR1 (1:nbcatch)) - allocate (NORMERR2 (1:nbcatch)) - allocate (NORMERR3 (1:nbcatch)) - allocate (NORMERR4 (1:nbcatch)) - allocate (BEE (1:nbcatch)) - allocate (PSIS (1:nbcatch)) - allocate (POROS (1:nbcatch)) - allocate (COND (1:nbcatch)) - allocate (WPWET (1:nbcatch)) - allocate (soildepth (1:nbcatch)) - allocate (soil_class_top (1:nbcatch)) - allocate (soil_class_com (1:nbcatch)) - allocate (tindex2 (1:nbcatch)) - allocate (pfaf2 (1:nbcatch)) - - do n=1,nbcatch - - read(11,'(i10,i8,5(1x,f8.4))') tindex1,pfaf1,meanlu,stdev,minlu,maxlu,coesk - read(10,*) tindex2(n),pfaf2(n),soil_class_top(n),soil_class_com(n), & - BEE(n),PSIS(n),POROS(n),COND(n),WPWET(n),soildepth(n) - - if(tindex1.ne.tindex2(n))then - write(*,*)'Warnning 1: tindex mismatched' - stop - endif - - read (12,*) tindex1,pfaf1,minlon,maxlon,minlat,maxlat - tile_lon(n) = (minlon + maxlon)/2. - tile_lat(n) = (minlat + maxlat)/2. - - if(pfaf1.ne.pfaf2(n)) then - write(*,*)'Warnning 1: pfafstetter mismatched' - stop - endif - - if (index(MaskFile,'GEOS5_10arcsec_mask') /= 0) then - TOPMEAN(n) = meanlu - else - TOPMEAN(n) = 0.961*meanlu-1.957 - endif - - TOPVAR(n) = stdev*stdev - TOPSKEW(n) = coesk*stdev*stdev*stdev - - if (TOPVAR(n) .eq. 0. .or. coesk .eq. 0. .or. topskew(n) .eq. 0.) then - write(*,*) 'Problem: undefined values:' - write(*,*) TOPMEAN(n),TOPVAR(n),coesk,minlu,maxlu - stop - endif - END DO - - inquire(file='clsm/catch_params.nc4', exist=file_exists) - - if(file_exists) then - status = NF_OPEN ('clsm/catch_params.nc4', NF_WRITE, ncid) ; VERIFY_(STATUS) - allocate (parms4file (1:nbcatch, 1:25)) - status = NF_GET_VARA_REAL(NCID,NC_VarID(NCID,'BEE' ),(/1/),(/nbcatch/),BEE (:)) ; VERIFY_(STATUS) - status = NF_GET_VARA_REAL(NCID,NC_VarID(NCID,'COND' ),(/1/),(/nbcatch/),COND (:)) ; VERIFY_(STATUS) - status = NF_GET_VARA_REAL(NCID,NC_VarID(NCID,'POROS'),(/1/),(/nbcatch/),POROS(:)) ; VERIFY_(STATUS) - status = NF_GET_VARA_REAL(NCID,NC_VarID(NCID,'PSIS' ),(/1/),(/nbcatch/),PSIS (:)) ; VERIFY_(STATUS) - status = NF_GET_VARA_REAL(NCID,NC_VarID(NCID,'WPWET'),(/1/),(/nbcatch/),WPWET(:)) ; VERIFY_(STATUS) - status = NF_GET_VARA_REAL(NCID,NC_VarID(NCID,'DP2BR'),(/1/),(/nbcatch/),soildepth (:)) ; VERIFY_(STATUS) - parms4file (:,12) = BEE (:) - parms4file (:,16) = COND (:) - parms4file (:,18) = POROS (:) - parms4file (:,19) = PSIS (:) - parms4file (:,24) = WPWET (:) - parms4file (:,25) = soildepth(:) - endif - - rewind(10) - - allocate(low_ind(n_threads)) - allocate(upp_ind(n_threads)) - low_ind(1) = 1 - upp_ind(n_threads) = nbcatch - - if (running_omp) then - do i=1,n_threads-1 - - upp_ind(i) = low_ind(i) + (nbcatch/n_threads) - 1 - low_ind(i+1) = upp_ind(i) + 1 - - end do - end if - - -!$OMP PARALLELDO DEFAULT(NONE) & -!$OMP SHARED( BEE, PSIS,POROS,COND,WPWET,soildepth, & -!$OMP TOPMEAN, TOPVAR, TOPSKEW, & -!$OMP ARS1,ARS2,ARS3, ARA1,ARA2,ARA3,ARA4, & -!$OMP ARW1,ARW2,ARW3,ARW4,bf1, bf2, bf3, & -!$OMP tsa1, tsa2,tsb1, tsb2, & -!$OMP taberr1,taberr2,normerr1,normerr2, & -!$OMP taberr3,taberr4,normerr3,normerr4, & -!$OMP gwatdep,gwan,grzexcn,gfrc,soil_class_com, & -!$OMP n_threads, low_ind, upp_ind ) & -!$OMP PRIVATE(k,li,ui,n,i,watdep,wan,rzexcn,frc,ST,AC, & -!$OMP COESKEW,profdep) - - do k=1,n_threads - - li = low_ind(k) - ui = upp_ind(k) - - do n=li,ui -! if ((n == 877).or.(n == 880).or.(n == 881)) then -! print *,n -! endif -! print *,n -! pause -! c Gamma distribution - CALL TGEN ( & - TOPMEAN(n),TOPVAR(n),TOPSKEW(n), & - ST,AC,COESKEW) - -!c write(*,*) 'tgen4 ok' - -!c Areal fractioning parameters -! print *,'tileid:' ,n - CALL SAT_PARAM( & - BEE(n),PSIS(n),POROS(n),COND(n), & - WPWET(n), ST, AC, COESKEW,n, & - soildepth(n), & - ars1(n),ars2(n),ars3(n), & - ara1(n),ara2(n),ara3(n),ara4(n), & - arw1(n),arw2(n),arw3(n),arw4(n), & - taberr1(n),taberr2(n),taberr3(n),taberr4(n), & - normerr1(n),normerr2(n),normerr3(n),normerr4(n)) - - - CALL BASE_PARAM( & - BEE(n),PSIS(n),POROS(n),COND(n), & - ST, AC, & - bf1(n),bf2(n),bf3(n), & - taberr1(n),taberr2(n),normerr1(n),normerr2(n) & - ) - - profdep=soildepth(n)/1000. - profdep=amax1(1.,profdep) - if (grzdep .gt. .75*profdep) then - i=1 - else - i=2 - end if + end do + end do + fname='clsm/soil_param.first' + open (10,file=fname,action='read', & + form='formatted',status='old') + + fname='clsm/cti_stats.dat' + open (11,file=fname,action='read', & + form='formatted',status='old') + + fout='clsm/ar.new' + open (20,file=fout,action='write', & + form='formatted',status='unknown') + + fout='clsm//bf.dat' + open (30,file=fout,action='write', & + form='formatted',status='unknown') + + fout='clsm//ts.dat' + open (40,file=fout,action='write', & + form='formatted',status='unknown') + + if (error_file) then + fout='clsm/ar_rmse.dat' + open (21,file=fout,action='write', & + form='formatted',status='unknown') + + fout='clsm/bf_rmse.dat' + open (31,file=fout,action='write', & + form='formatted',status='unknown') + + fout='clsm/bad_sat_param.tiles' + open (41,file=fout,action='write', & + form='formatted',status='unknown') + endif + fout='clsm/soil_param.dat' + open (42,file=fout,action='write', & + form='formatted',status='unknown') + read (11,*) n ! read off nbcatch + + allocate (TOPMEAN (1:nbcatch)) + allocate (TOPVAR (1:nbcatch)) + allocate (TOPSKEW (1:nbcatch)) + allocate (ARS1 (1:nbcatch)) + allocate (ARS2 (1:nbcatch)) + allocate (ARS3 (1:nbcatch)) + allocate (ARA1 (1:nbcatch)) + allocate (ARA2 (1:nbcatch)) + allocate (ARA3 (1:nbcatch)) + allocate (ARA4 (1:nbcatch)) + allocate (ARW1 (1:nbcatch)) + allocate (ARW2 (1:nbcatch)) + allocate (ARW3 (1:nbcatch)) + allocate (ARW4 (1:nbcatch)) + allocate (BF1 (1:nbcatch)) + allocate (BF2 (1:nbcatch)) + allocate (BF3 (1:nbcatch)) + allocate (TSA1 (1:nbcatch)) + allocate (TSA2 (1:nbcatch)) + allocate (TSB1 (1:nbcatch)) + allocate (TSB2 (1:nbcatch)) + allocate (TABERR1 (1:nbcatch)) + allocate (TABERR2 (1:nbcatch)) + allocate (TABERR3 (1:nbcatch)) + allocate (TABERR4 (1:nbcatch)) + allocate (NORMERR1 (1:nbcatch)) + allocate (NORMERR2 (1:nbcatch)) + allocate (NORMERR3 (1:nbcatch)) + allocate (NORMERR4 (1:nbcatch)) + allocate (BEE (1:nbcatch)) + allocate (PSIS (1:nbcatch)) + allocate (POROS (1:nbcatch)) + allocate (COND (1:nbcatch)) + allocate (WPWET (1:nbcatch)) + allocate (soildepth (1:nbcatch)) + allocate (soil_class_top (1:nbcatch)) + allocate (soil_class_com (1:nbcatch)) + allocate (tindex2 (1:nbcatch)) + allocate (pfaf2 (1:nbcatch)) + + do n=1,nbcatch + + read(11,'(i10,i8,5(1x,f8.4))') tindex1,pfaf1,meanlu,stdev,minlu,maxlu,coesk + read(10,*) tindex2(n),pfaf2(n),soil_class_top(n),soil_class_com(n), & + BEE(n),PSIS(n),POROS(n),COND(n),WPWET(n),soildepth(n) + + if(tindex1.ne.tindex2(n))then + write(*,*)'Warnning 1: tindex mismatched' + stop + endif + + if(tile_pfs(n).ne.pfaf2(n)) then + write(*,*)'Warnning 1: pfafstetter mismatched' + stop + endif + + if (index(MaskFile,'GEOS5_10arcsec_mask') /= 0) then + TOPMEAN(n) = meanlu + else + TOPMEAN(n) = 0.961*meanlu-1.957 + endif + + TOPVAR(n) = stdev*stdev + TOPSKEW(n) = coesk*stdev*stdev*stdev + + if (TOPVAR(n) .eq. 0. .or. coesk .eq. 0. .or. topskew(n) .eq. 0.) then + write(*,*) 'Problem: undefined values:' + write(*,*) TOPMEAN(n),TOPVAR(n),coesk,minlu,maxlu + stop + endif + END DO + + inquire(file='clsm/catch_params.nc4', exist=file_exists) + + if(file_exists) then + status = NF_OPEN ('clsm/catch_params.nc4', NF_WRITE, ncid) ; VERIFY_(STATUS) + allocate (parms4file (1:nbcatch, 1:25)) + status = NF_GET_VARA_REAL(NCID,NC_VarID(NCID,'BEE' ),(/1/),(/nbcatch/),BEE (:)) ; VERIFY_(STATUS) + status = NF_GET_VARA_REAL(NCID,NC_VarID(NCID,'COND' ),(/1/),(/nbcatch/),COND (:)) ; VERIFY_(STATUS) + status = NF_GET_VARA_REAL(NCID,NC_VarID(NCID,'POROS'),(/1/),(/nbcatch/),POROS(:)) ; VERIFY_(STATUS) + status = NF_GET_VARA_REAL(NCID,NC_VarID(NCID,'PSIS' ),(/1/),(/nbcatch/),PSIS (:)) ; VERIFY_(STATUS) + status = NF_GET_VARA_REAL(NCID,NC_VarID(NCID,'WPWET'),(/1/),(/nbcatch/),WPWET(:)) ; VERIFY_(STATUS) + status = NF_GET_VARA_REAL(NCID,NC_VarID(NCID,'DP2BR'),(/1/),(/nbcatch/),soildepth (:)) ; VERIFY_(STATUS) + parms4file (:,12) = BEE (:) + parms4file (:,16) = COND (:) + parms4file (:,18) = POROS (:) + parms4file (:,19) = PSIS (:) + parms4file (:,24) = WPWET (:) + parms4file (:,25) = soildepth(:) + endif + + rewind(10) + + allocate(low_ind(n_threads)) + allocate(upp_ind(n_threads)) + low_ind(1) = 1 + upp_ind(n_threads) = nbcatch + + if (running_omp) then + do i=1,n_threads-1 + + upp_ind(i) = low_ind(i) + (nbcatch/n_threads) - 1 + low_ind(i+1) = upp_ind(i) + 1 + + end do + end if + + + !$OMP PARALLELDO DEFAULT(NONE) & + !$OMP SHARED( BEE, PSIS,POROS,COND,WPWET,soildepth, & + !$OMP TOPMEAN, TOPVAR, TOPSKEW, & + !$OMP ARS1,ARS2,ARS3, ARA1,ARA2,ARA3,ARA4, & + !$OMP ARW1,ARW2,ARW3,ARW4,bf1, bf2, bf3, & + !$OMP tsa1, tsa2,tsb1, tsb2, & + !$OMP taberr1,taberr2,normerr1,normerr2, & + !$OMP taberr3,taberr4,normerr3,normerr4, & + !$OMP gwatdep,gwan,grzexcn,gfrc,soil_class_com, & + !$OMP n_threads, low_ind, upp_ind ) & + !$OMP PRIVATE(k,li,ui,n,i,watdep,wan,rzexcn,frc,ST,AC, & + !$OMP COESKEW,profdep) + + do k=1,n_threads + + li = low_ind(k) + ui = upp_ind(k) + + do n=li,ui + ! if ((n == 877).or.(n == 880).or.(n == 881)) then + ! print *,n + ! endif + ! print *,n + ! pause + ! c Gamma distribution + CALL TGEN ( & + TOPMEAN(n),TOPVAR(n),TOPSKEW(n), & + ST,AC,COESKEW) + + !c write(*,*) 'tgen4 ok' + + !c Areal fractioning parameters + ! print *,'tileid:' ,n + CALL SAT_PARAM( & + BEE(n),PSIS(n),POROS(n),COND(n), & + WPWET(n), ST, AC, COESKEW,n, & + soildepth(n), & + ars1(n),ars2(n),ars3(n), & + ara1(n),ara2(n),ara3(n),ara4(n), & + arw1(n),arw2(n),arw3(n),arw4(n), & + taberr1(n),taberr2(n),taberr3(n),taberr4(n), & + normerr1(n),normerr2(n),normerr3(n),normerr4(n)) + + + CALL BASE_PARAM( & + BEE(n),PSIS(n),POROS(n),COND(n), & + ST, AC, & + bf1(n),bf2(n),bf3(n), & + taberr1(n),taberr2(n),normerr1(n),normerr2(n) & + ) + + profdep=soildepth(n)/1000. + profdep=amax1(1.,profdep) + if (grzdep .gt. .75*profdep) then + i=1 + else + i=2 + end if watdep (:,:) = gwatdep (:,:,soil_class_com(n),i) wan (:,:) = gwan (:,:,soil_class_com(n),i) rzexcn (:,:) = grzexcn (:,:,soil_class_com(n),i) frc (:,:) = gfrc (:,:,soil_class_com(n),i) - CALL TS_PARAM( & - BEE(n),PSIS(n),POROS(n), & - ST, AC, & - watdep,wan,rzexcn,frc, & - tsa1(n),tsa2(n),tsb1(n),tsb2(n) & - ) - - END DO - END DO - !$OMP ENDPARALLELDO - tile_pick = 0 - - DO n=1,nbcatch - if((arw1(n).ne.9999.).and.(ars1(n).ne.9999.))then - if(tile_pick(soil_class_com(n)) == 0) tile_pick(soil_class_com(n)) = n - endif - end do - - DO n=1,nbcatch - !c Third subroutine for the parameters related to the transfers - !c to the water table - ! - ! Writing the parameters, in the same order as in catchment.def - ! if((ars1(n).lt.0.).and.(ars2(n).le.0.3).and.(ars3(n).le.0.04).and.(arw1(n).ne.9999.))then - if((arw1(n).ne.9999.).and.(ars1(n).ne.9999.))then - write(20,'(i10,i8,f5.2,11(2x,e14.7))') & - tindex2(n),pfaf2(n),gnu, & - ars1(n),ars2(n),ars3(n), & - ara1(n),ara2(n),ara3(n),ara4(n), & - arw1(n),arw2(n),arw3(n),arw4(n) - write(30,'(i10,i8,f5.2,3(2x,e13.7))')tindex2(n),pfaf2(n),gnu,bf1(n),bf2(n),bf3(n) - write(40,'(i10,i8,f5.2,4(2x,e13.7))')tindex2(n),pfaf2(n),gnu, & - tsa1(n),tsa2(n),tsb1(n),tsb2(n) - - write(42,'(i10,i8,i4,i4,3f8.4,f12.8,f7.4,f10.3)') tindex2(n),pfaf2(n),soil_class_top(n),soil_class_com(n), & - BEE(n), PSIS(n),POROS(n),COND(n),WPWET(n),soildepth(n) - - if (allocated (parms4file)) then - parms4file (n, 1) = ara1(n) - parms4file (n, 2) = ara2(n) - parms4file (n, 3) = ara3(n) - parms4file (n, 4) = ara4(n) - parms4file (n, 5) = ars1(n) - parms4file (n, 6) = ars2(n) - parms4file (n, 7) = ars3(n) - parms4file (n, 8) = arw1(n) - parms4file (n, 9) = arw2(n) - parms4file (n,10) = arw3(n) - parms4file (n,11) = arw4(n) - parms4file (n,13) = bf1(n) - parms4file (n,14) = bf2(n) - parms4file (n,15) = bf3(n) - parms4file (n,17) = gnu - parms4file (n,20) = tsa1(n) - parms4file (n,21) = tsa2(n) - parms4file (n,22) = tsb1(n) - parms4file (n,23) = tsb2(n) - endif - else - - if(preserve_soiltype) then - picked=.false. - ! Group3 - ! category 1 : Sand - ! category 2 : Loamy Sand - ! category 3 : Sandy Loam - ! category 8 : Silty Clay Loam - ! Group2 - ! category 4 : Silt Loam - ! category 5 : Silt - ! category 6 : Loam - ! category 7 : Sandy Clay Loam - ! Group1 - ! category 9 : Clay Loam - ! category 10 : Sandy Clay - ! category 11 : Silty Clay - ! category 12 : Clay - - if ((soil_class_com(n)>=9).and.(soil_class_com(n)<=12)) then - group=1 - else if ((soil_class_com(n)>=4).and.(soil_class_com(n)<=7)) then - group=2 - else - group=3 + CALL TS_PARAM( & + BEE(n),PSIS(n),POROS(n), & + ST, AC, & + watdep,wan,rzexcn,frc, & + tsa1(n),tsa2(n),tsb1(n),tsb2(n) & + ) + + END DO + END DO + !$OMP ENDPARALLELDO + tile_pick = 0 + + DO n=1,nbcatch + if((arw1(n).ne.9999.).and.(ars1(n).ne.9999.))then + if(tile_pick(soil_class_com(n)) == 0) tile_pick(soil_class_com(n)) = n + endif + end do + + DO n=1,nbcatch + !c Third subroutine for the parameters related to the transfers + !c to the water table + ! + ! Writing the parameters, in the same order as in catchment.def + ! if((ars1(n).lt.0.).and.(ars2(n).le.0.3).and.(ars3(n).le.0.04).and.(arw1(n).ne.9999.))then + if((arw1(n).ne.9999.).and.(ars1(n).ne.9999.))then + write(20,'(i10,i8,f5.2,11(2x,e14.7))') & + tindex2(n),pfaf2(n),gnu, & + ars1(n),ars2(n),ars3(n), & + ara1(n),ara2(n),ara3(n),ara4(n), & + arw1(n),arw2(n),arw3(n),arw4(n) + write(30,'(i10,i8,f5.2,3(2x,e13.7))')tindex2(n),pfaf2(n),gnu,bf1(n),bf2(n),bf3(n) + write(40,'(i10,i8,f5.2,4(2x,e13.7))')tindex2(n),pfaf2(n),gnu, & + tsa1(n),tsa2(n),tsb1(n),tsb2(n) + + write(42,'(i10,i8,i4,i4,3f8.4,f12.8,f7.4,f10.3)') tindex2(n),pfaf2(n),soil_class_top(n),soil_class_com(n), & + BEE(n), PSIS(n),POROS(n),COND(n),WPWET(n),soildepth(n) + + if (allocated (parms4file)) then + parms4file (n, 1) = ara1(n) + parms4file (n, 2) = ara2(n) + parms4file (n, 3) = ara3(n) + parms4file (n, 4) = ara4(n) + parms4file (n, 5) = ars1(n) + parms4file (n, 6) = ars2(n) + parms4file (n, 7) = ars3(n) + parms4file (n, 8) = arw1(n) + parms4file (n, 9) = arw2(n) + parms4file (n,10) = arw3(n) + parms4file (n,11) = arw4(n) + parms4file (n,13) = bf1(n) + parms4file (n,14) = bf2(n) + parms4file (n,15) = bf3(n) + parms4file (n,17) = gnu + parms4file (n,20) = tsa1(n) + parms4file (n,21) = tsa2(n) + parms4file (n,22) = tsb1(n) + parms4file (n,23) = tsb2(n) endif - - if(tile_pick(soil_class_com(n)) > 0) then - k = tile_pick(soil_class_com(n)) - picked=.true. - if (error_file) then - write (41,*)n,k + else + + if(preserve_soiltype) then + picked=.false. + ! Group3 + ! category 1 : Sand + ! category 2 : Loamy Sand + ! category 3 : Sandy Loam + ! category 8 : Silty Clay Loam + ! Group2 + ! category 4 : Silt Loam + ! category 5 : Silt + ! category 6 : Loam + ! category 7 : Sandy Clay Loam + ! Group1 + ! category 9 : Clay Loam + ! category 10 : Sandy Clay + ! category 11 : Silty Clay + ! category 12 : Clay + + if ((soil_class_com(n)>=9).and.(soil_class_com(n)<=12)) then + group=1 + else if ((soil_class_com(n)>=4).and.(soil_class_com(n)<=7)) then + group=2 + else + group=3 + endif + + if(tile_pick(soil_class_com(n)) > 0) then + k = tile_pick(soil_class_com(n)) + picked=.true. + if (error_file) then + write (41,*)n,k + endif + write(20,'(i10,i8,f5.2,11(2x,e14.7))') & + tindex2(n),pfaf2(n),gnu, & + ars1(k),ars2(k),ars3(k), & + ara1(k),ara2(k),ara3(k),ara4(k), & + arw1(k),arw2(k),arw3(k),arw4(k) + ars1(n)=ars1(k) + ars2(n)=ars2(k) + ars3(n)=ars3(k) + ara1(n)=ara1(k) + ara2(n)=ara2(k) + ara3(n)=ara3(k) + ara4(n)=ara4(k) + arw1(n)=arw1(k) + arw2(n)=arw2(k) + arw3(n)=arw3(k) + arw4(n)=arw4(k) + + write(30,'(i10,i8,f5.2,3(2x,e13.7))')tindex2(n),pfaf2(n),gnu,bf1(k),bf2(k),bf3(k) + write(40,'(i10,i8,f5.2,4(2x,e13.7))')tindex2(n),pfaf2(n),gnu, & + tsa1(k),tsa2(k),tsb1(k),tsb2(k) + write(42,'(i10,i8,i4,i4,3f8.4,f12.8,f7.4,f10.3)') tindex2(n),pfaf2(n),soil_class_top(k),soil_class_com(k), & + BEE(k), PSIS(k),POROS(k),COND(k),WPWET(k),soildepth(k) + if (allocated (parms4file)) then + parms4file (n, 1) = ara1(k) + parms4file (n, 2) = ara2(k) + parms4file (n, 3) = ara3(k) + parms4file (n, 4) = ara4(k) + parms4file (n, 5) = ars1(k) + parms4file (n, 6) = ars2(k) + parms4file (n, 7) = ars3(k) + parms4file (n, 8) = arw1(k) + parms4file (n, 9) = arw2(k) + parms4file (n,10) = arw3(k) + parms4file (n,11) = arw4(k) + parms4file (n,12) = BEE(k) + parms4file (n,13) = bf1(k) + parms4file (n,14) = bf2(k) + parms4file (n,15) = bf3(k) + parms4file (n,16) = COND(k) + parms4file (n,17) = gnu + parms4file (n,18) = POROS(k) + parms4file (n,19) = PSIS(k) + parms4file (n,20) = tsa1(k) + parms4file (n,21) = tsa2(k) + parms4file (n,22) = tsb1(k) + parms4file (n,23) = tsb2(k) + parms4file (n,24) = wpwet (k) + parms4file (n,25) = soildepth(k) + endif + else + + do k =n-1,1,-1 + + if (group == 1) then + if ((soil_class_com(k)>=9).and.(soil_class_com(k)<=12))picked=.true. + endif + + if (group == 2) then + if ((soil_class_com(k)>=4).and.(soil_class_com(k)<=7)) picked=.true. + endif + + if (group == 3) then + if (((soil_class_com(k)>=1).and.(soil_class_com(k)<=3)).or. & + (soil_class_com(k)==8)) picked=.true. + endif + + if (picked) then + if (error_file) then + write (41,*)n,k + endif + + write(20,'(i10,i8,f5.2,11(2x,e14.7))') & + tindex2(n),pfaf2(n),gnu, & + ars1(k),ars2(k),ars3(k), & + ara1(k),ara2(k),ara3(k),ara4(k), & + arw1(k),arw2(k),arw3(k),arw4(k) + write(30,'(i10,i8,f5.2,3(2x,e13.7))')tindex2(n),pfaf2(n),gnu,bf1(k),bf2(k),bf3(k) + write(40,'(i10,i8,f5.2,4(2x,e13.7))')tindex2(n),pfaf2(n),gnu, & + tsa1(k),tsa2(k),tsb1(k),tsb2(k) + write(42,'(i10,i8,i4,i4,3f8.4,f12.8,f7.4,f10.3)') tindex2(n),pfaf2(n),soil_class_top(k),soil_class_com(k), & + BEE(k), PSIS(k),POROS(k),COND(k),WPWET(k),soildepth(k) + ars1(n)=ars1(k) + ars2(n)=ars2(k) + ars3(n)=ars3(k) + ara1(n)=ara1(k) + ara2(n)=ara2(k) + ara3(n)=ara3(k) + ara4(n)=ara4(k) + arw1(n)=arw1(k) + arw2(n)=arw2(k) + arw3(n)=arw3(k) + arw4(n)=arw4(k) + + if (allocated (parms4file)) then + parms4file (n, 1) = ara1(k) + parms4file (n, 2) = ara2(k) + parms4file (n, 3) = ara3(k) + parms4file (n, 4) = ara4(k) + parms4file (n, 5) = ars1(k) + parms4file (n, 6) = ars2(k) + parms4file (n, 7) = ars3(k) + parms4file (n, 8) = arw1(k) + parms4file (n, 9) = arw2(k) + parms4file (n,10) = arw3(k) + parms4file (n,11) = arw4(k) + parms4file (n,12) = BEE(k) + parms4file (n,13) = bf1(k) + parms4file (n,14) = bf2(k) + parms4file (n,15) = bf3(k) + parms4file (n,16) = COND(k) + parms4file (n,17) = gnu + parms4file (n,18) = POROS(k) + parms4file (n,19) = PSIS(k) + parms4file (n,20) = tsa1(k) + parms4file (n,21) = tsa2(k) + parms4file (n,22) = tsb1(k) + parms4file (n,23) = tsb2(k) + parms4file (n,24) = wpwet (k) + parms4file (n,25) = soildepth(k) + endif + exit + endif + + if((k==1) .and. (.not. picked)) then + print *,'Warning ar.new is bad at n=',n + stop + endif + end do endif + + + ! write(30,'(i8,i8,f5.2,3(2x,e13.7))')tindex2(n),pfaf2(n),gnu,bf1(n),bf2(n),bf3(n) + ! write(40,'(i8,i8,f5.2,4(2x,e13.7))')tindex2(n),pfaf2(n),gnu, & + ! tsa1(n),tsa2(n),tsb1(n),tsb2(n) + else + + dist_save = 1000000. + k = 0 + do i = 1,nbcatch + if(i /= n) then + if((ars1(i).ne.9999.).and.(arw1(i).ne.9999.)) then + + tile_distance = (tile_lon(i) - tile_lon(n)) * (tile_lon(i) - tile_lon(n)) + & + (tile_lat(i) - tile_lat(n)) * (tile_lat(i) - tile_lat(n)) + if(tile_distance < dist_save) then + k = i + dist_save = tile_distance + endif + endif + endif + enddo + write (41,*)n,k write(20,'(i10,i8,f5.2,11(2x,e14.7))') & tindex2(n),pfaf2(n),gnu, & ars1(k),ars2(k),ars3(k), & ara1(k),ara2(k),ara3(k),ara4(k), & arw1(k),arw2(k),arw3(k),arw4(k) - ars1(n)=ars1(k) - ars2(n)=ars2(k) - ars3(n)=ars3(k) - ara1(n)=ara1(k) - ara2(n)=ara2(k) - ara3(n)=ara3(k) - ara4(n)=ara4(k) - arw1(n)=arw1(k) - arw2(n)=arw2(k) - arw3(n)=arw3(k) - arw4(n)=arw4(k) - write(30,'(i10,i8,f5.2,3(2x,e13.7))')tindex2(n),pfaf2(n),gnu,bf1(k),bf2(k),bf3(k) write(40,'(i10,i8,f5.2,4(2x,e13.7))')tindex2(n),pfaf2(n),gnu, & - tsa1(k),tsa2(k),tsb1(k),tsb2(k) + tsa1(k),tsa2(k),tsb1(k),tsb2(k) write(42,'(i10,i8,i4,i4,3f8.4,f12.8,f7.4,f10.3)') tindex2(n),pfaf2(n),soil_class_top(k),soil_class_com(k), & BEE(k), PSIS(k),POROS(k),COND(k),WPWET(k),soildepth(k) if (allocated (parms4file)) then @@ -3417,4335 +2470,3842 @@ SUBROUTINE create_model_para (MaskFile) parms4file (n,24) = wpwet (k) parms4file (n,25) = soildepth(k) endif - else - - do k =n-1,1,-1 - - if (group == 1) then - if ((soil_class_com(k)>=9).and.(soil_class_com(k)<=12))picked=.true. - endif - - if (group == 2) then - if ((soil_class_com(k)>=4).and.(soil_class_com(k)<=7)) picked=.true. - endif - - if (group == 3) then - if (((soil_class_com(k)>=1).and.(soil_class_com(k)<=3)).or. & - (soil_class_com(k)==8)) picked=.true. - endif - - if (picked) then - if (error_file) then - write (41,*)n,k - endif - - write(20,'(i10,i8,f5.2,11(2x,e14.7))') & - tindex2(n),pfaf2(n),gnu, & - ars1(k),ars2(k),ars3(k), & - ara1(k),ara2(k),ara3(k),ara4(k), & - arw1(k),arw2(k),arw3(k),arw4(k) - write(30,'(i10,i8,f5.2,3(2x,e13.7))')tindex2(n),pfaf2(n),gnu,bf1(k),bf2(k),bf3(k) - write(40,'(i10,i8,f5.2,4(2x,e13.7))')tindex2(n),pfaf2(n),gnu, & - tsa1(k),tsa2(k),tsb1(k),tsb2(k) - write(42,'(i10,i8,i4,i4,3f8.4,f12.8,f7.4,f10.3)') tindex2(n),pfaf2(n),soil_class_top(k),soil_class_com(k), & - BEE(k), PSIS(k),POROS(k),COND(k),WPWET(k),soildepth(k) - ars1(n)=ars1(k) - ars2(n)=ars2(k) - ars3(n)=ars3(k) - ara1(n)=ara1(k) - ara2(n)=ara2(k) - ara3(n)=ara3(k) - ara4(n)=ara4(k) - arw1(n)=arw1(k) - arw2(n)=arw2(k) - arw3(n)=arw3(k) - arw4(n)=arw4(k) - - if (allocated (parms4file)) then - parms4file (n, 1) = ara1(k) - parms4file (n, 2) = ara2(k) - parms4file (n, 3) = ara3(k) - parms4file (n, 4) = ara4(k) - parms4file (n, 5) = ars1(k) - parms4file (n, 6) = ars2(k) - parms4file (n, 7) = ars3(k) - parms4file (n, 8) = arw1(k) - parms4file (n, 9) = arw2(k) - parms4file (n,10) = arw3(k) - parms4file (n,11) = arw4(k) - parms4file (n,12) = BEE(k) - parms4file (n,13) = bf1(k) - parms4file (n,14) = bf2(k) - parms4file (n,15) = bf3(k) - parms4file (n,16) = COND(k) - parms4file (n,17) = gnu - parms4file (n,18) = POROS(k) - parms4file (n,19) = PSIS(k) - parms4file (n,20) = tsa1(k) - parms4file (n,21) = tsa2(k) - parms4file (n,22) = tsb1(k) - parms4file (n,23) = tsb2(k) - parms4file (n,24) = wpwet (k) - parms4file (n,25) = soildepth(k) - endif - exit - endif - - if((k==1) .and. (.not. picked)) then - print *,'Warning ar.new is bad at n=',n - stop - endif - end do endif - - -! write(30,'(i8,i8,f5.2,3(2x,e13.7))')tindex2(n),pfaf2(n),gnu,bf1(n),bf2(n),bf3(n) -! write(40,'(i8,i8,f5.2,4(2x,e13.7))')tindex2(n),pfaf2(n),gnu, & -! tsa1(n),tsa2(n),tsb1(n),tsb2(n) - else + endif - dist_save = 1000000. - k = 0 - do i = 1,nbcatch - if(i /= n) then - if((ars1(i).ne.9999.).and.(arw1(i).ne.9999.)) then - - tile_distance = (tile_lon(i) - tile_lon(n)) * (tile_lon(i) - tile_lon(n)) + & - (tile_lat(i) - tile_lat(n)) * (tile_lat(i) - tile_lat(n)) - if(tile_distance < dist_save) then - k = i - dist_save = tile_distance - endif - endif - endif - enddo - write (41,*)n,k - write(20,'(i10,i8,f5.2,11(2x,e14.7))') & - tindex2(n),pfaf2(n),gnu, & - ars1(k),ars2(k),ars3(k), & - ara1(k),ara2(k),ara3(k),ara4(k), & - arw1(k),arw2(k),arw3(k),arw4(k) - write(30,'(i10,i8,f5.2,3(2x,e13.7))')tindex2(n),pfaf2(n),gnu,bf1(k),bf2(k),bf3(k) - write(40,'(i10,i8,f5.2,4(2x,e13.7))')tindex2(n),pfaf2(n),gnu, & - tsa1(k),tsa2(k),tsb1(k),tsb2(k) - write(42,'(i10,i8,i4,i4,3f8.4,f12.8,f7.4,f10.3)') tindex2(n),pfaf2(n),soil_class_top(k),soil_class_com(k), & - BEE(k), PSIS(k),POROS(k),COND(k),WPWET(k),soildepth(k) - if (allocated (parms4file)) then - parms4file (n, 1) = ara1(k) - parms4file (n, 2) = ara2(k) - parms4file (n, 3) = ara3(k) - parms4file (n, 4) = ara4(k) - parms4file (n, 5) = ars1(k) - parms4file (n, 6) = ars2(k) - parms4file (n, 7) = ars3(k) - parms4file (n, 8) = arw1(k) - parms4file (n, 9) = arw2(k) - parms4file (n,10) = arw3(k) - parms4file (n,11) = arw4(k) - parms4file (n,12) = BEE(k) - parms4file (n,13) = bf1(k) - parms4file (n,14) = bf2(k) - parms4file (n,15) = bf3(k) - parms4file (n,16) = COND(k) - parms4file (n,17) = gnu - parms4file (n,18) = POROS(k) - parms4file (n,19) = PSIS(k) - parms4file (n,20) = tsa1(k) - parms4file (n,21) = tsa2(k) - parms4file (n,22) = tsb1(k) - parms4file (n,23) = tsb2(k) - parms4file (n,24) = wpwet (k) - parms4file (n,25) = soildepth(k) - endif - endif - endif - - if (error_file) then - write(21,*)tindex2(n),pfaf2(n),taberr1(n),taberr2(n),taberr3(n),taberr4(n), & - normerr1(n),normerr2(n),normerr3(n),normerr4(n) - write(31,*)tindex2(n),pfaf2(n),taberr1(n),taberr2(n),normerr1(n),normerr2(n) - endif - - END DO - -! Write(*,*) 'END COMPUTING MODEL PARA' - - close(10,status='keep') - close(20,status='keep') - close(30,status='keep') - close(40,status='keep') - close(11,status='keep') - close(12,status='keep') - close(42,status='keep') - if (error_file) then - close(21,status='delete') - close(31,status='delete') - close(41,status='keep') - endif - - if(file_exists) then - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARA1' ) ,(/1/),(/nbcatch/), parms4file (:, 1)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARA2' ) ,(/1/),(/nbcatch/), parms4file (:, 2)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARA3' ) ,(/1/),(/nbcatch/), parms4file (:, 3)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARA4' ) ,(/1/),(/nbcatch/), parms4file (:, 4)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARS1' ) ,(/1/),(/nbcatch/), parms4file (:, 5)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARS2' ) ,(/1/),(/nbcatch/), parms4file (:, 6)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARS3' ) ,(/1/),(/nbcatch/), parms4file (:, 7)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARW1' ) ,(/1/),(/nbcatch/), parms4file (:, 8)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARW2' ) ,(/1/),(/nbcatch/), parms4file (:, 9)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARW3' ) ,(/1/),(/nbcatch/), parms4file (:,10)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARW4' ) ,(/1/),(/nbcatch/), parms4file (:,11)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'BEE' ) ,(/1/),(/nbcatch/), parms4file (:,12)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'BF1' ) ,(/1/),(/nbcatch/), parms4file (:,13)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'BF2' ) ,(/1/),(/nbcatch/), parms4file (:,14)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'BF3' ) ,(/1/),(/nbcatch/), parms4file (:,15)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'COND' ) ,(/1/),(/nbcatch/), parms4file (:,16)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'GNU' ) ,(/1/),(/nbcatch/), parms4file (:,17)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'POROS') ,(/1/),(/nbcatch/), parms4file (:,18)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'PSIS' ) ,(/1/),(/nbcatch/), parms4file (:,19)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'TSA1' ) ,(/1/),(/nbcatch/), parms4file (:,20)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'TSA2' ) ,(/1/),(/nbcatch/), parms4file (:,21)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'TSB1' ) ,(/1/),(/nbcatch/), parms4file (:,22)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'TSB2' ) ,(/1/),(/nbcatch/), parms4file (:,23)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'WPWET') ,(/1/),(/nbcatch/), parms4file (:,24)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'DP2BR') ,(/1/),(/nbcatch/), parms4file (:,25)) ; VERIFY_(STATUS) - STATUS = NF_CLOSE (NCID) ; VERIFY_(STATUS) - DEALLOCATE (parms4file) - endif + if (error_file) then + write(21,*)tindex2(n),pfaf2(n),taberr1(n),taberr2(n),taberr3(n),taberr4(n), & + normerr1(n),normerr2(n),normerr3(n),normerr4(n) + write(31,*)tindex2(n),pfaf2(n),taberr1(n),taberr2(n),normerr1(n),normerr2(n) + endif + + END DO + + ! Write(*,*) 'END COMPUTING MODEL PARA' + + close(10,status='keep') + close(20,status='keep') + close(30,status='keep') + close(40,status='keep') + close(11,status='keep') + close(12,status='keep') + close(42,status='keep') + if (error_file) then + close(21,status='delete') + close(31,status='delete') + close(41,status='keep') + endif + + if(file_exists) then + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARA1' ) ,(/1/),(/nbcatch/), parms4file (:, 1)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARA2' ) ,(/1/),(/nbcatch/), parms4file (:, 2)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARA3' ) ,(/1/),(/nbcatch/), parms4file (:, 3)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARA4' ) ,(/1/),(/nbcatch/), parms4file (:, 4)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARS1' ) ,(/1/),(/nbcatch/), parms4file (:, 5)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARS2' ) ,(/1/),(/nbcatch/), parms4file (:, 6)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARS3' ) ,(/1/),(/nbcatch/), parms4file (:, 7)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARW1' ) ,(/1/),(/nbcatch/), parms4file (:, 8)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARW2' ) ,(/1/),(/nbcatch/), parms4file (:, 9)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARW3' ) ,(/1/),(/nbcatch/), parms4file (:,10)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARW4' ) ,(/1/),(/nbcatch/), parms4file (:,11)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'BEE' ) ,(/1/),(/nbcatch/), parms4file (:,12)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'BF1' ) ,(/1/),(/nbcatch/), parms4file (:,13)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'BF2' ) ,(/1/),(/nbcatch/), parms4file (:,14)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'BF3' ) ,(/1/),(/nbcatch/), parms4file (:,15)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'COND' ) ,(/1/),(/nbcatch/), parms4file (:,16)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'GNU' ) ,(/1/),(/nbcatch/), parms4file (:,17)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'POROS') ,(/1/),(/nbcatch/), parms4file (:,18)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'PSIS' ) ,(/1/),(/nbcatch/), parms4file (:,19)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'TSA1' ) ,(/1/),(/nbcatch/), parms4file (:,20)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'TSA2' ) ,(/1/),(/nbcatch/), parms4file (:,21)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'TSB1' ) ,(/1/),(/nbcatch/), parms4file (:,22)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'TSB2' ) ,(/1/),(/nbcatch/), parms4file (:,23)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'WPWET') ,(/1/),(/nbcatch/), parms4file (:,24)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'DP2BR') ,(/1/),(/nbcatch/), parms4file (:,25)) ; VERIFY_(STATUS) + STATUS = NF_CLOSE (NCID) ; VERIFY_(STATUS) + DEALLOCATE (parms4file) + endif END SUBROUTINE create_model_para -!-------------------------------------------------------------------- - - SUBROUTINE create_model_para_woesten (Maskfile) - - implicit none - real, allocatable, dimension (:) :: a_sand,a_clay,a_silt,a_oc, & - atile_sand,atile_clay, tile_lon, tile_lat, grav_vec, soc_vec,& - poc_vec,a_sand_surf,a_clay_surf,wpwet_surf,poros_surf, pmap - -!obsolete20220428 real, allocatable, dimension (:,:) :: good_clay, good_sand -!obsolete20220428 integer, allocatable, dimension (:,:) :: tile_add, tile_pick -!obsolete20220428 type (mineral_perc) :: min_percs -!obsolete20220428 integer :: CF1, CF2, CF3, CF4 - - integer i,j,n,k, tindex1,pfaf1,nbcatch - integer soil_gswp - real meanlu,stdev,minlu,maxlu,coesk,rzdep - real minlat,maxlat,minlon,maxlon - real,allocatable, dimension (:) :: & - BEE, PSIS,POROS,COND,WPWET,soildepth - REAL, allocatable, dimension(:) :: TOPMEAN, TOPVAR, TOPSKEW - REAL ST(NAR), AC(NAR),COESKEW - REAL, allocatable, dimension (:) :: & - ARS1,ARS2,ARS3, ARA1,ARA2,ARA3,ARA4, & - ARW1,ARW2,ARW3,ARW4,bf1, bf2, bf3, & - tsa1, tsa2,tsb1, tsb2, & - taberr1,taberr2,normerr1,normerr2, & - taberr3,taberr4,normerr3,normerr4 - - integer, allocatable, dimension (:) :: soil_class_com,tindex2,pfaf2, & - soil_class_top - real watdep(nwt,nrz),wan(nwt,nrz),rzexcn(nwt,nrz),frc(nwt,nrz) - real, allocatable, dimension (:,:,:) :: & - gwatdep,gwan,grzexcn,gfrc - real :: wtdep,wanom,rzaact,fracl,profdep,dist_save, & - ncells_top, ncells_top_pro,ncells_sub_pro,tile_distance - character*200 :: pathout,fname,fout,losfile - character*10 :: dline - CHARACTER*20 :: version,resoln,continent - character*6 rdep,ext - character (*) :: MaskFile - integer :: iwt,irz,group - logical :: picked - logical :: file_exists - REAL, ALLOCATABLE, DIMENSION (:,:) :: parms4file - integer :: ncid, status - -! --------- VARIABLES FOR *OPENMP* PARALLEL ENVIRONMENT ------------ -! -! NOTE: "!$" is for conditional compilation -! -logical :: running_omp = .false. -! -!$ integer :: omp_get_thread_num, omp_get_num_threads -! -integer :: n_threads=1, li, ui -! -integer, dimension(:), allocatable :: low_ind, upp_ind -! -! ------------------------------------------------------------------ - - ! ----------- OpenMP PARALLEL ENVIRONMENT ---------------------------- - ! - ! FIND OUT WHETHER -omp FLAG HAS BEEN SET DURING COMPILATION - ! - !$ running_omp = .true. ! conditional compilation - ! - ! ECHO BASIC OMP VARIABLES - ! - !$OMP PARALLEL DEFAULT(NONE) SHARED(running_omp,n_threads) - ! - !$OMP SINGLE - ! - !$ n_threads = omp_get_num_threads() - ! - !$ write (*,*) 'running_omp = ', running_omp - !$ write (*,*) - !$ write (*,*) 'parallel OpenMP with ', n_threads, 'threads' - !$ write (*,*) - !$OMP ENDSINGLE - ! - !$OMP CRITICAL - !$ write (*,*) 'thread ', omp_get_thread_num(), ' alive' - !$OMP ENDCRITICAL - ! - !$OMP BARRIER - ! - !$OMP ENDPARALLEL - -!c------------------------------------------------------------------------- - - ! SoilClasses-SoilHyd-TauParam.dat and SoilClasses-SoilHyd-TauParam.peatmap differ - ! only in the parameters for the peat class #253. The file *.peatmap contains - ! the PEATCLSM parameters from Table 2 of Bechtold et al. 2019 (doi:10.1029/2018MS001574). - ! - ! Note: K_s = COND*exp(-zks*gnu) ==> with zks=2 and gnu=1, K_s = 0.135335*COND - ! - ! K_s COND [m/s] - ! NLv4 7.86e-7 5.81e-6 - ! NLv5 3.79e-6 2.80e-5 <== note *typo* in Table 2 of Bechtold et al. 2019, which erroneously lists K_s=2.8e-5 - - call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) - - if(use_PEATMAP) then - fname = trim(MAKE_BCS_INPUT_DIR)//'/land/soil/SOIL-DATA/SoilClasses-SoilHyd-TauParam.peatmap' - else - fname = trim(MAKE_BCS_INPUT_DIR)//'land/soil/SOIL-DATA/SoilClasses-SoilHyd-TauParam.dat' - endif - open (11, file=trim(fname), form='formatted',status='old', & - action = 'read') - read (11,'(a)')fout ! read header line - - losfile =trim(MAKE_BCS_INPUT_DIR)//'/land/soil/soil_water_loss/v2/loss_pd_top/loss_perday_rz1m_' - - allocate (a_sand (1:n_SoilClasses)) - allocate (a_silt (1:n_SoilClasses)) - allocate (a_clay (1:n_SoilClasses)) - allocate (a_oc (1:n_SoilClasses)) - allocate (gwatdep(1:nwt,1:nrz,1:n_SoilClasses)) - allocate (gwan (1:nwt,1:nrz,1:n_SoilClasses)) - allocate (grzexcn(1:nwt,1:nrz,1:n_SoilClasses)) - allocate (gfrc (1:nwt,1:nrz,1:n_SoilClasses)) - - do n =1,n_SoilClasses - - ! read sand/clay/orgC for class n defined in SoilClasses-SoilHyd-TauParam.* - - read (11,'(4f7.3)')a_sand(n),a_clay(n),a_silt(n),a_oc(n) - write (fout,'(i2.2,i2.2,i4.4)')nint(a_sand(n)),nint(a_clay(n)),nint(100*a_oc(n)) - - ! open and read loss parameter file for class n (defined through sand/clay/orgC) - - if(n == n_SoilClasses .and. use_PEATMAP) then - open (120,file=trim(losfile)//trim(fout)//'.peat', & - form='formatted',status='old') - else - open (120,file=trim(losfile)//trim(fout), & - form='formatted',status='old') - endif - - do iwt=1,nwt - do irz=1,nrz - read(120,2000) wtdep,wanom,rzaact,fracl - 2000 format(1x,4e16.8) - gwatdep(iwt,irz,n)= wtdep - gwan(iwt,irz,n) = wanom - grzexcn(iwt,irz,n)= rzaact - gfrc(iwt,irz,n) = amin1(fracl,1.) - enddo - enddo - close (120,status='keep') - end do - close (11,status='keep') - deallocate (a_sand,a_silt,a_clay,a_oc) - - ! open files for *reading* - - fname='clsm/soil_param.first' - open (10,file=fname,action='read', & - form='formatted',status='old') - - fname='clsm/cti_stats.dat' - open (11,file=fname,action='read', & - form='formatted',status='old') - - fname='clsm/catchment.def' - open (12,file=fname,action='read', & - form='formatted',status='old') - - ! open files for *writing* - - fout='clsm/ar.new' - open (20,file=fout,action='write', & - form='formatted',status='unknown') - - fout='clsm//bf.dat' - open (30,file=fout,action='write', & - form='formatted',status='unknown') - - fout='clsm//ts.dat' - open (40,file=fout,action='write', & - form='formatted',status='unknown') - - if (error_file) then - fout='clsm/ar_rmse.dat' - open (21,file=fout,action='write', & - form='formatted',status='unknown') - - fout='clsm/bf_rmse.dat' - open (31,file=fout,action='write', & - form='formatted',status='unknown') - - fout='clsm/bad_sat_param.tiles' - open (41,file=fout,action='write', & - form='formatted',status='unknown') - - endif - - fout='clsm/soil_param.dat' - open (42,file=fout,action='write', & - form='formatted',status='unknown') - - read (11,*)nbcatch ! read header line (number of tiles) -- cti_stats.dat - read (12,*)nbcatch ! read header line (number of tiles) -- catchment.def - - allocate (tile_lon(1:nbcatch)) - allocate (tile_lat(1:nbcatch)) - allocate (TOPMEAN (1:nbcatch)) - allocate (TOPVAR (1:nbcatch)) - allocate (TOPSKEW (1:nbcatch)) - allocate (ARS1 (1:nbcatch)) - allocate (ARS2 (1:nbcatch)) - allocate (ARS3 (1:nbcatch)) - allocate (ARA1 (1:nbcatch)) - allocate (ARA2 (1:nbcatch)) - allocate (ARA3 (1:nbcatch)) - allocate (ARA4 (1:nbcatch)) - allocate (ARW1 (1:nbcatch)) - allocate (ARW2 (1:nbcatch)) - allocate (ARW3 (1:nbcatch)) - allocate (ARW4 (1:nbcatch)) - allocate (BF1 (1:nbcatch)) - allocate (BF2 (1:nbcatch)) - allocate (BF3 (1:nbcatch)) - allocate (TSA1 (1:nbcatch)) - allocate (TSA2 (1:nbcatch)) - allocate (TSB1 (1:nbcatch)) - allocate (TSB2 (1:nbcatch)) - allocate (TABERR1 (1:nbcatch)) - allocate (TABERR2 (1:nbcatch)) - allocate (TABERR3 (1:nbcatch)) - allocate (TABERR4 (1:nbcatch)) - allocate (NORMERR1 (1:nbcatch)) - allocate (NORMERR2 (1:nbcatch)) - allocate (NORMERR3 (1:nbcatch)) - allocate (NORMERR4 (1:nbcatch)) - allocate (BEE (1:nbcatch)) - allocate (PSIS (1:nbcatch)) - allocate (POROS (1:nbcatch)) - allocate (COND (1:nbcatch)) - allocate (WPWET (1:nbcatch)) - allocate (soildepth (1:nbcatch)) - allocate (soil_class_top (1:nbcatch)) - allocate (soil_class_com (1:nbcatch)) - allocate (tindex2 (1:nbcatch)) - allocate (pfaf2 (1:nbcatch)) - allocate (atile_clay (1:nbcatch)) - allocate (atile_sand (1:nbcatch)) - allocate (grav_vec (1:nbcatch)) - allocate (soc_vec (1:nbcatch)) - allocate (poc_vec (1:nbcatch)) - allocate (a_sand_surf (1:nbcatch)) - allocate (a_clay_surf (1:nbcatch)) - allocate (wpwet_surf (1:nbcatch)) - allocate (poros_surf (1:nbcatch)) - allocate (pmap (1:nbcatch)) - -!obsolete20220428 allocate (good_clay (1:100,4)) -!obsolete20220428 allocate (good_sand (1:100,4)) -!obsolete20220428 allocate (tile_add (1:100,4)) -!obsolete20220428 allocate (tile_pick (1:100,4)) -!obsolete20220428 tile_add = 0 -!obsolete20220428 tile_pick= 0 -!obsolete20220428 good_clay =0. -!obsolete20220428 good_sand =0. - - do n=1,nbcatch + !-------------------------------------------------------------------- + + SUBROUTINE create_model_para_woesten (Maskfile, nbcatch, tile_lon, tile_lat, tile_pfs) + + character(*), intent(in) :: MaskFile + integer, intent(in) :: nbcatch + real, intent(in) :: tile_lon(:), tile_lat(:) + integer, intent(in) :: tile_pfs(:) + ! ----------------------------------------------- + + real, allocatable, dimension (:) :: a_sand,a_clay,a_silt,a_oc, & + atile_sand,atile_clay, grav_vec, soc_vec,& + poc_vec,a_sand_surf,a_clay_surf,wpwet_surf,poros_surf, pmap + + integer i,j,n,k, tindex1,pfaf1 + integer soil_gswp + real meanlu,stdev,minlu,maxlu,coesk,rzdep + real minlat,maxlat,minlon,maxlon + real,allocatable, dimension (:) :: & + BEE, PSIS,POROS,COND,WPWET,soildepth + REAL, allocatable, dimension(:) :: TOPMEAN, TOPVAR, TOPSKEW + REAL ST(NAR), AC(NAR),COESKEW + REAL, allocatable, dimension (:) :: & + ARS1,ARS2,ARS3, ARA1,ARA2,ARA3,ARA4, & + ARW1,ARW2,ARW3,ARW4,bf1, bf2, bf3, & + tsa1, tsa2,tsb1, tsb2, & + taberr1,taberr2,normerr1,normerr2, & + taberr3,taberr4,normerr3,normerr4 + + integer, allocatable, dimension (:) :: soil_class_com,tindex2,pfaf2, & + soil_class_top + real watdep(nwt,nrz),wan(nwt,nrz),rzexcn(nwt,nrz),frc(nwt,nrz) + real, allocatable, dimension (:,:,:) :: & + gwatdep,gwan,grzexcn,gfrc + real :: wtdep,wanom,rzaact,fracl,profdep,dist_save, & + ncells_top, ncells_top_pro,ncells_sub_pro,tile_distance + character*512 :: pathout,fname,fout,losfile + CHARACTER*512 :: version,resoln,continent + character*6 ::rdep,ext + integer :: iwt,irz,group + logical :: picked + logical :: file_exists + REAL, ALLOCATABLE, DIMENSION (:,:) :: parms4file + integer :: ncid, status + + ! --------- VARIABLES FOR *OPENMP* PARALLEL ENVIRONMENT ------------ + ! + ! NOTE: "!$" is for conditional compilation + ! + logical :: running_omp = .false. + ! + !$ integer :: omp_get_thread_num, omp_get_num_threads + ! + integer :: n_threads=1, li, ui + ! + integer, dimension(:), allocatable :: low_ind, upp_ind + ! + ! ------------------------------------------------------------------ + + ! ----------- OpenMP PARALLEL ENVIRONMENT ---------------------------- + ! + ! FIND OUT WHETHER -omp FLAG HAS BEEN SET DURING COMPILATION + ! + !$ running_omp = .true. ! conditional compilation + ! + ! ECHO BASIC OMP VARIABLES + ! + !$OMP PARALLEL DEFAULT(NONE) SHARED(running_omp,n_threads) + ! + !$OMP SINGLE + ! + !$ n_threads = omp_get_num_threads() + ! + !$ write (*,*) 'running_omp = ', running_omp + !$ write (*,*) + !$ write (*,*) 'parallel OpenMP with ', n_threads, 'threads' + !$ write (*,*) + !$OMP ENDSINGLE + ! + !$OMP CRITICAL + !$ write (*,*) 'thread ', omp_get_thread_num(), ' alive' + !$OMP ENDCRITICAL + ! + !$OMP BARRIER + ! + !$OMP ENDPARALLEL + + !c------------------------------------------------------------------------- + + ! SoilClasses-SoilHyd-TauParam.dat and SoilClasses-SoilHyd-TauParam.peatmap differ + ! only in the parameters for the peat class #253. The file *.peatmap contains + ! the PEATCLSM parameters from Table 2 of Bechtold et al. 2019 (doi:10.1029/2018MS001574). + ! + ! Note: K_s = COND*exp(-zks*gnu) ==> with zks=2 and gnu=1, K_s = 0.135335*COND + ! + ! K_s COND [m/s] + ! NLv4 7.86e-7 5.81e-6 + ! NLv5 3.79e-6 2.80e-5 <== note *typo* in Table 2 of Bechtold et al. 2019, which erroneously lists K_s=2.8e-5 + + call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) + + if(use_PEATMAP) then + fname = trim(MAKE_BCS_INPUT_DIR)//'/land/soil/SOIL-DATA/SoilClasses-SoilHyd-TauParam.peatmap' + else + fname = trim(MAKE_BCS_INPUT_DIR)//'land/soil/SOIL-DATA/SoilClasses-SoilHyd-TauParam.dat' + endif + open (11, file=trim(fname), form='formatted',status='old', & + action = 'read') + read (11,'(a)')fout ! read header line + + losfile =trim(MAKE_BCS_INPUT_DIR)//'/land/soil/soil_water_loss/v2/loss_pd_top/loss_perday_rz1m_' + + allocate (a_sand (1:n_SoilClasses)) + allocate (a_silt (1:n_SoilClasses)) + allocate (a_clay (1:n_SoilClasses)) + allocate (a_oc (1:n_SoilClasses)) + allocate (gwatdep(1:nwt,1:nrz,1:n_SoilClasses)) + allocate (gwan (1:nwt,1:nrz,1:n_SoilClasses)) + allocate (grzexcn(1:nwt,1:nrz,1:n_SoilClasses)) + allocate (gfrc (1:nwt,1:nrz,1:n_SoilClasses)) + + do n =1,n_SoilClasses + + ! read sand/clay/orgC for class n defined in SoilClasses-SoilHyd-TauParam.* + + read (11,'(4f7.3)')a_sand(n),a_clay(n),a_silt(n),a_oc(n) + write (fout,'(i2.2,i2.2,i4.4)')nint(a_sand(n)),nint(a_clay(n)),nint(100*a_oc(n)) + + ! open and read loss parameter file for class n (defined through sand/clay/orgC) + + if(n == n_SoilClasses .and. use_PEATMAP) then + open (120,file=trim(losfile)//trim(fout)//'.peat', & + form='formatted',status='old') + else + open (120,file=trim(losfile)//trim(fout), & + form='formatted',status='old') + endif + + do iwt=1,nwt + do irz=1,nrz + read(120,2000) wtdep,wanom,rzaact,fracl +2000 format(1x,4e16.8) + gwatdep(iwt,irz,n)= wtdep + gwan(iwt,irz,n) = wanom + grzexcn(iwt,irz,n)= rzaact + gfrc(iwt,irz,n) = amin1(fracl,1.) + enddo + enddo + close (120,status='keep') + end do + close (11,status='keep') + deallocate (a_sand,a_silt,a_clay,a_oc) + + ! open files for *reading* + + fname='clsm/soil_param.first' + open (10,file=fname,action='read', & + form='formatted',status='old') + + fname='clsm/cti_stats.dat' + open (11,file=fname,action='read', & + form='formatted',status='old') + + ! open files for *writing* + + fout='clsm/ar.new' + open (20,file=fout,action='write', & + form='formatted',status='unknown') + + fout='clsm//bf.dat' + open (30,file=fout,action='write', & + form='formatted',status='unknown') + + fout='clsm//ts.dat' + open (40,file=fout,action='write', & + form='formatted',status='unknown') + + if (error_file) then + fout='clsm/ar_rmse.dat' + open (21,file=fout,action='write', & + form='formatted',status='unknown') + + fout='clsm/bf_rmse.dat' + open (31,file=fout,action='write', & + form='formatted',status='unknown') + + fout='clsm/bad_sat_param.tiles' + open (41,file=fout,action='write', & + form='formatted',status='unknown') + + endif + + fout='clsm/soil_param.dat' + open (42,file=fout,action='write', & + form='formatted',status='unknown') + + read (11,*) n ! read off header line (number of tiles) -- cti_stats.dat + + allocate (TOPMEAN (1:nbcatch)) + allocate (TOPVAR (1:nbcatch)) + allocate (TOPSKEW (1:nbcatch)) + allocate (ARS1 (1:nbcatch)) + allocate (ARS2 (1:nbcatch)) + allocate (ARS3 (1:nbcatch)) + allocate (ARA1 (1:nbcatch)) + allocate (ARA2 (1:nbcatch)) + allocate (ARA3 (1:nbcatch)) + allocate (ARA4 (1:nbcatch)) + allocate (ARW1 (1:nbcatch)) + allocate (ARW2 (1:nbcatch)) + allocate (ARW3 (1:nbcatch)) + allocate (ARW4 (1:nbcatch)) + allocate (BF1 (1:nbcatch)) + allocate (BF2 (1:nbcatch)) + allocate (BF3 (1:nbcatch)) + allocate (TSA1 (1:nbcatch)) + allocate (TSA2 (1:nbcatch)) + allocate (TSB1 (1:nbcatch)) + allocate (TSB2 (1:nbcatch)) + allocate (TABERR1 (1:nbcatch)) + allocate (TABERR2 (1:nbcatch)) + allocate (TABERR3 (1:nbcatch)) + allocate (TABERR4 (1:nbcatch)) + allocate (NORMERR1 (1:nbcatch)) + allocate (NORMERR2 (1:nbcatch)) + allocate (NORMERR3 (1:nbcatch)) + allocate (NORMERR4 (1:nbcatch)) + allocate (BEE (1:nbcatch)) + allocate (PSIS (1:nbcatch)) + allocate (POROS (1:nbcatch)) + allocate (COND (1:nbcatch)) + allocate (WPWET (1:nbcatch)) + allocate (soildepth (1:nbcatch)) + allocate (soil_class_top (1:nbcatch)) + allocate (soil_class_com (1:nbcatch)) + allocate (tindex2 (1:nbcatch)) + allocate (pfaf2 (1:nbcatch)) + allocate (atile_clay (1:nbcatch)) + allocate (atile_sand (1:nbcatch)) + allocate (grav_vec (1:nbcatch)) + allocate (soc_vec (1:nbcatch)) + allocate (poc_vec (1:nbcatch)) + allocate (a_sand_surf (1:nbcatch)) + allocate (a_clay_surf (1:nbcatch)) + allocate (wpwet_surf (1:nbcatch)) + allocate (poros_surf (1:nbcatch)) + allocate (pmap (1:nbcatch)) + + do n=1,nbcatch + + ! read cti_stats.dat + + read(11,'(i10,i8,5(1x,f8.4))') tindex1,pfaf1,meanlu,stdev & + ,minlu,maxlu,coesk + + ! read soil_param.first + ! + ! WARNING: Immediately after the present do loop, BEE, COND, POROS, PSIS, WPWET, and + ! soildepth will be read again (and thus overwritten) with the values from + ! the catch_params.nc4 file. It is unclear if the values in soil_param.first + ! and catch_params.nc4 differ. See comments below. + + read(10,'(i10,i8,i4,i4,3f8.4,f12.8,f7.4,f10.4,3f7.3,4f7.3,2f10.4)') & + tindex2(n),pfaf2(n),soil_class_top(n),soil_class_com(n), & + BEE(n), PSIS(n),POROS(n),COND(n),WPWET(n),soildepth(n), & + grav_vec(n),soc_vec(n),poc_vec(n), & + a_sand_surf(n),a_clay_surf(n),atile_sand(n),atile_clay(n) + if(tindex1.ne.tindex2(n))then + write(*,*)'Warnning 1: tindex mismatched' + stop + endif + + if(tile_pfs(n).ne.pfaf2(n)) then + write(*,*)'Warnning 1: pfafstetter mismatched' + stop + endif + if((use_PEATMAP).and.(soil_class_top(n) == 253)) then + meanlu = 9.3 + stdev = 0.12 + minlu = 8.5 + maxlu = 11.5 + coesk = 0.25 + endif + + if (index(MaskFile,'GEOS5_10arcsec_mask') /= 0) then + TOPMEAN(n) = meanlu + else + TOPMEAN(n) = 0.961*meanlu-1.957 + endif + + TOPVAR(n) = stdev*stdev + TOPSKEW(n) = coesk*stdev*stdev*stdev + + if ( TOPVAR(n) .eq. 0. .or. coesk .eq. 0. & + .or. topskew(n) .eq. 0.) then + write(*,*) 'Problem: undefined values:' + write(*,*) TOPMEAN(n),TOPVAR(n),coesk, & + minlu,maxlu + stop + endif + END DO ! n=1,nbcatch + + inquire(file='clsm/catch_params.nc4', exist=file_exists) + + if(file_exists) then + + ! Read BEE, COND, POROS, PSIS, WPWET, and soildepth from nc4 file. + ! It is unclear if parameters in nc4 file differ from those in soil_param.first, which were read + ! in the do loop just above. + ! Probably, the parameters differ by roundoff because soil_param.first is an ASCII file and + ! catch_params.nc4 is a netcdf file. Consequently, the parameters from the nc4 file are used + ! in the calculation of the ar.new, bf.dat, and ts.dat parameters, which comes next. + ! To maintain consistency between the parameters in soil_param.first and soil_param.dat where + ! no changes are needed, soil_param.first needs to be read again below (so as to overwrite + ! the values from the nc4 file). + ! Why the parameters from the nc4 file are read here in the first place remains a mystery. + ! Removing this read, however, will (almost certainly) result in non-zero-diff changes + ! for existing bcs datasets. + ! - reichle, 28 April 2022 + + status = NF_OPEN ('clsm/catch_params.nc4', NF_WRITE, ncid) ; VERIFY_(STATUS) + allocate (parms4file (1:nbcatch, 1:25)) + status = NF_GET_VARA_REAL(NCID,NC_VarID(NCID,'BEE' ) ,(/1/),(/nbcatch/), BEE (:)) ; VERIFY_(STATUS) + status = NF_GET_VARA_REAL(NCID,NC_VarID(NCID,'COND' ) ,(/1/),(/nbcatch/), COND (:)) ; VERIFY_(STATUS) + status = NF_GET_VARA_REAL(NCID,NC_VarID(NCID,'POROS') ,(/1/),(/nbcatch/), POROS(:)) ; VERIFY_(STATUS) + status = NF_GET_VARA_REAL(NCID,NC_VarID(NCID,'PSIS' ) ,(/1/),(/nbcatch/), PSIS (:)) ; VERIFY_(STATUS) + status = NF_GET_VARA_REAL(NCID,NC_VarID(NCID,'WPWET') ,(/1/),(/nbcatch/), WPWET(:)) ; VERIFY_(STATUS) + status = NF_GET_VARA_REAL(NCID,NC_VarID(NCID,'DP2BR') ,(/1/),(/nbcatch/), soildepth (:)) ; VERIFY_(STATUS) + parms4file (:,12) = BEE (:) + parms4file (:,16) = COND (:) + parms4file (:,18) = POROS (:) + parms4file (:,19) = PSIS (:) + parms4file (:,24) = wpwet (:) + parms4file (:,25) = soildepth(:) + endif + + rewind(10) ! soil_param.first (so soil_param.first can be read again below...) + + allocate(low_ind(n_threads)) + allocate(upp_ind(n_threads)) + low_ind(1) = 1 + upp_ind(n_threads) = nbcatch + + if (running_omp) then + do i=1,n_threads-1 + + upp_ind(i) = low_ind(i) + (nbcatch/n_threads) - 1 + low_ind(i+1) = upp_ind(i) + 1 + + end do + end if + + + !$OMP PARALLELDO DEFAULT(NONE) & + !$OMP SHARED( BEE, PSIS,POROS,COND,WPWET,soildepth, & + !$OMP TOPMEAN, TOPVAR, TOPSKEW, & + !$OMP ARS1,ARS2,ARS3, ARA1,ARA2,ARA3,ARA4, & + !$OMP ARW1,ARW2,ARW3,ARW4,bf1, bf2, bf3, & + !$OMP tsa1, tsa2,tsb1, tsb2, & + !$OMP taberr1,taberr2,normerr1,normerr2, & + !$OMP taberr3,taberr4,normerr3,normerr4, & + !$OMP gwatdep,gwan,grzexcn,gfrc,soil_class_com, & + !$OMP n_threads, low_ind, upp_ind, use_PEATMAP ) & + !$OMP PRIVATE(k,li,ui,n,i,watdep,wan,rzexcn,frc,ST,AC, & + !$OMP COESKEW,profdep) + + do k=1,n_threads + + li = low_ind(k) + ui = upp_ind(k) + + do n=li,ui + + CALL TGEN ( & + TOPMEAN(n),TOPVAR(n),TOPSKEW(n), & + ST,AC,COESKEW) + + ! compute areal fractioning parameters (ar.new) + + CALL SAT_PARAM( & + BEE(n),PSIS(n),POROS(n),COND(n), & + WPWET(n), ST, AC, COESKEW,n, & + soildepth(n), & + ars1(n),ars2(n),ars3(n), & + ara1(n),ara2(n),ara3(n),ara4(n), & + arw1(n),arw2(n),arw3(n),arw4(n), & + taberr1(n),taberr2(n),taberr3(n),taberr4(n), & + normerr1(n),normerr2(n),normerr3(n),normerr4(n)) + + ! compute base flow parameters (bf.dat) + + CALL BASE_PARAM( & + BEE(n),PSIS(n),POROS(n),COND(n), & + ST, AC, & + bf1(n),bf2(n),bf3(n), & + taberr1(n),taberr2(n),normerr1(n),normerr2(n) & + ) + + + watdep (:,:) = gwatdep (:,:,soil_class_com(n)) + wan (:,:) = gwan (:,:,soil_class_com(n)) + rzexcn (:,:) = grzexcn (:,:,soil_class_com(n)) + frc (:,:) = gfrc (:,:,soil_class_com(n)) + + ! compute time scale parameters (rzexc-catdef) (ts.dat) + + CALL TS_PARAM( & + BEE(n),PSIS(n),POROS(n), & + ST, AC, & + watdep,wan,rzexcn,frc, & + tsa1(n),tsa2(n),tsb1(n),tsb2(n) & + ) + + if(soil_class_com(n) == 253 .and. use_PEATMAP) then + + ! Michel Bechtold paper - PEATCLSM_fitting_CLSM_params.R produced these data values. + + ars1(n) = -7.9514018e-03 + ars2(n) = 6.2297356e-02 + ars3(n) = 1.9187240e-03 + ara1(n) = 8.9551220e+00 + ara2(n) = 9.8149664e+02 + ara3(n) = 8.9551220e+00 + ara4(n) = 9.8149664e+02 + arw1(n) = 9.9466055e-03 + arw2(n) = 1.0881960e-02 + arw3(n) = 1.5309287e-05 + arw4(n) = 1.0000000e-04 + + bf1(n) = 4.6088086e+02 + bf2(n) = 1.4237401e-01 + bf3(n) = 6.9803000e+00 + + tsa1(n) = -2.417581e+00 + tsa2(n) = -4.784762e+00 + tsb1(n) = -3.700285e-03 + tsb2(n) = -2.392484e-03 + + endif + END DO + END DO + !$OMP ENDPARALLELDO + + + ! ---------------------------------------------------------------------------------------- + ! + ! write ar.new, bf.dat, ts.dat, and soil_param.dat + + DO n=1,nbcatch + + ! Read soil_param.first again...; this is (almost certainly) needed to maintain consistency + ! between soil_param.first and soil_param.dat, see comments above. + + read(10,'(i10,i8,i4,i4,3f8.4,f12.8,f7.4,f10.4,3f7.3,4f7.3,2f10.4, f8.4)') & + tindex2(n),pfaf2(n),soil_class_top(n),soil_class_com(n), & + BEE(n), PSIS(n),POROS(n),COND(n),WPWET(n),soildepth(n), & + grav_vec(n),soc_vec(n),poc_vec(n), & + a_sand_surf(n),a_clay_surf(n),atile_sand(n),atile_clay(n) , & + wpwet_surf(n),poros_surf(n), pmap(n) + + ! This revised if block replaces the complex, nested if block commented out above + + if ( (ars1(n)==9999.) .or. (arw1(n)==9999.) ) then + + ! some parameter values are no-data --> find nearest tile k with good parameters + + dist_save = 1000000. + k = 0 + do i = 1,nbcatch + if(i /= n) then + if((ars1(i).ne.9999.).and.(arw1(i).ne.9999.)) then + + tile_distance = (tile_lon(i) - tile_lon(n)) * (tile_lon(i) - tile_lon(n)) + & + (tile_lat(i) - tile_lat(n)) * (tile_lat(i) - tile_lat(n)) + if(tile_distance < dist_save) then + k = i + dist_save = tile_distance + endif + endif + endif + enddo + ! record in file clsm/bad_sat_param.tiles + write (41,*)n,k ! n="bad" tile, k=tile from which parameters are taken + + ! Overwrite parms4file when filling in parameters from neighboring tile k. + ! For "good" tiles, keep parms4file as read earlier from catch_params.nc4, + ! which is why this must be done within the "then" block of the "if" statement. + ! This is necessary for backward 0-diff compatibility of catch_params.nc4. + + parms4file (n,12) = BEE(k) + parms4file (n,16) = COND(k) + parms4file (n,18) = POROS(k) + parms4file (n,19) = PSIS(k) + parms4file (n,24) = wpwet(k) + parms4file (n,25) = soildepth(k) + + else + + ! nominal case, all parameters are good + + k = n + + end if + + ! for current tile n, write parameters of tile k into ar.new (20), bf.dat (30), ts.dat (40), + ! and soil_param.dat (42) + + write(20,'(i10,i8,f5.2,11(2x,e14.7))') & + tindex2(n),pfaf2(n),gnu, & + ars1(k),ars2(k),ars3(k), & + ara1(k),ara2(k),ara3(k),ara4(k), & + arw1(k),arw2(k),arw3(k),arw4(k) + + write(30,'(i10,i8,f5.2,3(2x,e13.7))')tindex2(n),pfaf2(n),gnu,bf1(k),bf2(k),bf3(k) + + write(40,'(i10,i8,f5.2,4(2x,e13.7))')tindex2(n),pfaf2(n),gnu, & + tsa1(k),tsa2(k),tsb1(k),tsb2(k) + + write(42,'(i10,i8,i4,i4,3f8.4,f12.8,f7.4,f10.4,3f7.3,4f7.3,2f10.4, f8.4)') & + tindex2(n),pfaf2(n),soil_class_top(k),soil_class_com(k), & + BEE(k), PSIS(k),POROS(k),COND(k),WPWET(k),soildepth(k), & + grav_vec(k),soc_vec(k),poc_vec(k), & + a_sand_surf(k),a_clay_surf(k),atile_sand(k),atile_clay(k) , & + wpwet_surf(k),poros_surf(k), pmap(k) + + ! record ar.new, bf.dat, and ts.dat parameters for later writing into catch_params.nc4 + + if (allocated (parms4file)) then + parms4file (n, 1) = ara1(k) + parms4file (n, 2) = ara2(k) + parms4file (n, 3) = ara3(k) + parms4file (n, 4) = ara4(k) + parms4file (n, 5) = ars1(k) + parms4file (n, 6) = ars2(k) + parms4file (n, 7) = ars3(k) + parms4file (n, 8) = arw1(k) + parms4file (n, 9) = arw2(k) + parms4file (n,10) = arw3(k) + parms4file (n,11) = arw4(k) + parms4file (n,13) = bf1(k) + parms4file (n,14) = bf2(k) + parms4file (n,15) = bf3(k) + parms4file (n,17) = gnu + parms4file (n,20) = tsa1(k) + parms4file (n,21) = tsa2(k) + parms4file (n,22) = tsb1(k) + parms4file (n,23) = tsb2(k) + endif + + if (error_file) then + write(21,*)tindex2(n),pfaf2(n),taberr1(n),taberr2(n),taberr3(n),taberr4(n), & + normerr1(n),normerr2(n),normerr3(n),normerr4(n) + write(31,*)tindex2(n),pfaf2(n),taberr1(n),taberr2(n),normerr1(n),normerr2(n) + endif + + END DO ! n=1,nbcatch + + ! Write(*,*) 'END COMPUTING MODEL PARA' + + close(10,status='keep') + close(11,status='keep') + close(20,status='keep') + close(30,status='keep') + close(40,status='keep') + close(42,status='keep') + + + if (error_file) then + close(21,status='delete') + close(31,status='delete') + close(41,status='keep') + endif + + if(file_exists) then + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARA1' ) ,(/1/),(/nbcatch/), parms4file (:, 1)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARA2' ) ,(/1/),(/nbcatch/), parms4file (:, 2)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARA3' ) ,(/1/),(/nbcatch/), parms4file (:, 3)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARA4' ) ,(/1/),(/nbcatch/), parms4file (:, 4)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARS1' ) ,(/1/),(/nbcatch/), parms4file (:, 5)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARS2' ) ,(/1/),(/nbcatch/), parms4file (:, 6)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARS3' ) ,(/1/),(/nbcatch/), parms4file (:, 7)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARW1' ) ,(/1/),(/nbcatch/), parms4file (:, 8)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARW2' ) ,(/1/),(/nbcatch/), parms4file (:, 9)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARW3' ) ,(/1/),(/nbcatch/), parms4file (:,10)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARW4' ) ,(/1/),(/nbcatch/), parms4file (:,11)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'BEE' ) ,(/1/),(/nbcatch/), parms4file (:,12)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'BF1' ) ,(/1/),(/nbcatch/), parms4file (:,13)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'BF2' ) ,(/1/),(/nbcatch/), parms4file (:,14)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'BF3' ) ,(/1/),(/nbcatch/), parms4file (:,15)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'COND' ) ,(/1/),(/nbcatch/), parms4file (:,16)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'GNU' ) ,(/1/),(/nbcatch/), parms4file (:,17)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'POROS') ,(/1/),(/nbcatch/), parms4file (:,18)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'PSIS' ) ,(/1/),(/nbcatch/), parms4file (:,19)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'TSA1' ) ,(/1/),(/nbcatch/), parms4file (:,20)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'TSA2' ) ,(/1/),(/nbcatch/), parms4file (:,21)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'TSB1' ) ,(/1/),(/nbcatch/), parms4file (:,22)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'TSB2' ) ,(/1/),(/nbcatch/), parms4file (:,23)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'WPWET') ,(/1/),(/nbcatch/), parms4file (:,24)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'DP2BR') ,(/1/),(/nbcatch/), parms4file (:,25)) ; VERIFY_(STATUS) + STATUS = NF_CLOSE (NCID) ; VERIFY_(STATUS) + DEALLOCATE (parms4file) + endif + + END SUBROUTINE create_model_para_woesten + + + !--------------------------------------------------------------------- + + SUBROUTINE TS_PARAM( & + BEE,PSIS,POROS, & + VALX, PX, & + watdep,wan,rzexcn,frc, & + tsa1,tsa2,tsb1,tsb2 & + ) + + !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + !c c + !c Given pre-computed 1-D relationships between a "local" root zone excess c + !c and a "local" catchment deficit, the timescale of the bulk vertical c + !c transfer between the two bulk prognostic variables is computed using c + !c the distribution of the local deficit established from the distribution c + !c of the topographic index, then an approximated function of catdef and c + !c rzex is derived. c + !c c + !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + + INTEGER NAR0 + REAL, intent (in) :: BEE, PSIS, POROS + REAL, intent (in) :: VALX(NAR), PX(NAR) + real, intent (inout) :: watdep(nwt,nrz),wan(nwt,nrz), & + rzexcn(nwt,nrz),frc(nwt,nrz) + real, intent (out) :: tsa1, tsa2 ,tsb1, tsb2 + + integer :: tex,iwt,irz,n,idep,k, index1,i0 + REAL VALX0(NAR), PX0(NAR),sumta,sumta2,timean,zbar, rzw + REAL :: term1, term2, sumdef, suma, frcsat,rzexc, rzact + real zdep(nar),def(nar),wrz(nar),wbin(500),rze(nar) + real catd(2,2),tsc(2,2), satfrc,sumfrac,sumz,frac + real, parameter :: frcmax = .041 + real wtdep,wanom,rzaact,fracl,profdep,rzdep + + ! logical bug + + !c---------------------------------------------------------------- + !c Is loss.dat compatible with rzdep = 0.49 ??? + + rzdep = grzdep + + !c Convert fractions to "per-hour" values + do iwt=1,nwt + do irz=1,nrz + frc(iwt,irz)=1.-((1.-frc(iwt,irz))**(1./24.)) + enddo + enddo + + nar0=0 + do n=1,nar + if (px(n) .ne. 0.) then + nar0=nar0+1 + valx0(nar0)=valx(n) + px0(nar0)=px(n) + endif + enddo + + sumta=0. + sumta2=0. + suma=0. + do n=1,nar0 + sumta=sumta+px0(n)*valx0(n) + sumta2=sumta2+px0(n)*valx0(n)*valx0(n) + suma=suma+px0(n) + enddo + + timean=sumta/suma + + !c**** Loop over two water table depths + do idep=1,2 + if(idep.eq.1) zbar=1.5 ! zbar in meters + if(idep.eq.2) zbar=2.0 + + !c**** Compute array of water table depths: + do k=1,nar0 + term1=(1/gnu)*(valx0(k)-timean) + zdep(k)=zbar-term1 + if(zdep(k) .lt. 0.) zdep(k)=0. + enddo + !c write(*,*)" End water table depth" + !c**** Compute array of moisture deficits: + do k=1,nar0 + term1=(psis-zdep(k))/psis + term1=term1**(1.-1./bee) + term2=-psis*(bee/(bee-1.))*(term1-1.) + def(k)=poros*(zdep(k)-term2) + enddo + + !c**** Add deficits to produce catdef: + sumdef=0. + do k=1,nar0 + sumdef=sumdef+def(k)*px0(k)*1000. + enddo + !c write(*,*)" End catchment deficit" + !c**** Compute array of root zone moisture (degree of wetness in root zone): + do k=1,nar0 + + if(zdep(k).eq.0.) then + wrz(k)=1. + elseif(zdep(k)-rzdep.lt.0.) then + term1=((psis-zdep(k))/psis)**(1.-1./bee) + wrz(k)=(-psis/zdep(k))*(bee/(bee-1.)) & + *(term1-1.) + frcsat=1.-zdep(k)/rzdep + wrz(k)=(1.-frcsat)*wrz(k)+frcsat*1. + else + term1=((psis-zdep(k))/psis)**(1.-1./bee) + term2=((psis-zdep(k)+rzdep)/psis) & + **(1.-1./bee) + wrz(k)=(-psis/rzdep)*(bee/(bee-1.)) & + *(term1-term2) + endif + enddo + + !c Loop over two root zone excess values: + do irz=1,2 + if(irz.eq.1) rzexc=-0.1*poros + if(irz.eq.2) rzexc=0.1*poros + + !c Determine actual root zone excess + rzact=0. + do k=1,nar0 + rze(k)=rzexc + rzw=wrz(k)*poros + if(rzw+rze(k) .gt. poros) rze(k)=poros-rzw + if(rzw+rze(k) .lt. 0.) rze(k)=rzw + rzact=rzact+rze(k)*px0(k) + enddo + !c write(*,*)" End root zone excess" + !c Compute the average timescale + + satfrc=0. + do k=1,nar0 + if(zdep(k).lt.0.) satfrc=satfrc+px0(k) + enddo + + sumfrac=0. + sumz=0. + do k=1,nar0 + sumz=sumz+zdep(k)*px0(k) + if(zdep(k) .lt. 1.) frac=frcmax + if(zdep(k) .ge. 1.) then + index1=1+int(((zdep(k)*100.)-99)/5.) + if(index1.gt.nwt) index1 = nwt + frac=amin1(frc(index1,1),frcmax) + do i0=2,nrz + if(rze(k) .ge. rzexcn(index1,i0)) & + frac=amin1(frc(index1,i0),frcmax) + enddo + endif + sumfrac=sumfrac+frac*px0(k) + enddo + !c write(*,*)" End average time scale" + catd(idep,irz)=sumdef + tsc(idep,irz)=sumfrac + + enddo + enddo + + tsb1=(alog(tsc(2,2))-alog(tsc(1,2)))/(catd(2,2)-catd(1,2)) + tsb2=(alog(tsc(2,1))-alog(tsc(1,1)))/(catd(2,1)-catd(1,1)) + tsa1=alog(tsc(2,2))-tsb1*catd(2,2) + tsa2=alog(tsc(2,1))-tsb2*catd(2,1) + + END SUBROUTINE TS_PARAM + + !********************************************************************* + + SUBROUTINE BASE_PARAM( & + BEE,PSIS,POROS,COND, & + VALX, PX, & + bf1,bf2,bf3, & + taberr1,taberr2,normerr1,normerr2 & + ) + + !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + !c c + !c New way to get baseflow: we parametrize the relationship between c + !c catdef and zbar (two parameters bf1 and bf2). c + !c Then, in the LSM/catchment.f/base.f, we use the original relation c + !c from TOPMODEL to infer baseflow from catdef and the mean of the c + !c topographic index (topmean=bf3, a third parameter). c + !c c + !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + + INTEGER IDMAX,i1,i2,i,icount + + REAL, intent (in) :: BEE, PSIS,POROS,COND,VALX(NAR),PX(NAR) + real zbar(nbdep),catdef(nbdep),bflow(nbdep) + real, intent (out) :: bf1,bf2,bf3,taberr1,taberr2,normerr1,normerr2 + integer :: n,idep + real suma,sumta,timean + + real catfit(nbdep),bfit(nbdep),dfit(nbdep),catmean,bfmean + real catref(nbdep),bref(nbdep) + real err1, err2 + ! logical, intent (in) :: bug + + sumta=0. + suma=0. + do n=1,nar + sumta=sumta+px(n)*valx(n) + suma=suma+px(n) + enddo + timean=sumta/suma + bf3 = timean + + !c**** Loop over water table depths + + do idep=1,nbdep + + !c write(*,*) 'idep=',idep + + CALL BASIDEP( & + IDEP, & + BEE,PSIS,POROS,COND, & + VALX,PX,TIMEAN,SUMA, & + ZBAR,CATDEF,BFLOW) + + enddo + + + i1=10 ! zbar= 0 m + i2=35 ! zbar= 2.5 m + + bf2=zbar(i2)*SQRT(catdef(i1)) & + /(SQRT(catdef(i2))-SQRT(catdef(i1))) + bf1=catdef(i1)/(bf2*bf2) + + if (bf1 .le. 0) write(*,*) 'bf1 le 0 for i=',i + if (bf2 .le. 0) write(*,*) 'bf2 le 0 for i=',i + + !c Errors: Root mean square errors: only for points where catdef GT 0.5mm + + do idep=1,nbdep + catref(idep)=0. + bref(idep)=0. + enddo + catmean=0. + bfmean=0. + icount=0 + do idep=1,nbdep + if (catdef(idep) .gt. lim) then + icount=icount+1 + catref(icount)=catdef(idep) + bref(icount)=bflow(idep) + catfit(icount)=bf1*(zbar(idep)+bf2) & + *(zbar(idep)+bf2) + dfit(icount)=SQRT(catdef(idep)/bf1)-bf2 + bfit(icount)=cond*exp(-timean-gnu*dfit(icount)) & + /gnu + catmean=catmean+catdef(idep) + bfmean=bfmean+bflow(idep) + endif + enddo + catmean=catmean/icount + bfmean=bfmean/icount + if (icount.gt.1) then + call RMSE(catref,catfit,icount,err1) + call RMSE(bref,bfit,icount,err2) + + taberr1=err1 + taberr2=err2 + normerr1=err1/catmean + normerr2=err2/bfmean + endif + !c--------------------------------------------------------------------- + + END SUBROUTINE BASE_PARAM + + ! ************************************************************************ + + SUBROUTINE BASIDEP( & + IDEP, & + BEE,PSIS,POROS,COND, & + VALX,PX,TIMEAN,SUMA, & + ZBAR,CATDEF,BFLOW) + + !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + !c c + !c This program returns the eight parameters for the areal fractioning c + !c c + !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + + INTEGER, intent (in) :: idep + integer nref, nind,nmax,indmin,locmax,shift,ord,locmin,ordref,width,k + REAL, intent (in) :: BEE, PSIS, POROS, COND,VALX(NAR), PX(NAR), & + suma,timean + real :: dx,sumdef,dz + real, intent (out) :: catdef(nbdep),bflow(nbdep),zbar(idep) + real term1,term2,sum + real zdep(nar),locdef(nar) + ! logical bug + + !c------------------------------------------------------------------------- + !c integral(f(x)dx)=1. for a pdf + !c here px=f(x)dx + + dx=valx(1)-valx(2) + + if (bug) write(*,*) 'IDEP=',IDEP,' dx=',dx, 'gnu=',gnu + + !c the loops over idmax and nbdep are initiated in sta_params4.f + + zbar(idep)=float(idep-10)*slice ! zdep in meters + + !c**** Compute array of water table depths: + do k=1,nar + term1=(1/gnu)*(valx(k)-timean) + zdep(k)=AMAX1(0.,zbar(idep)-term1) + enddo + + !c variable change must be reflected in dx + dz=dx/gnu + + if (bug) write(*,*) 'basidep: ok1' + + !c**** Compute array of moisture deficits: + do k=1,nar + term1=(psis-zdep(k))/psis + term1=term1**(1.-1./bee) + term2=-psis*(bee/(bee-1.))*(term1-1.) + locdef(k)=zdep(k)-term2 + enddo + + !c**** Add deficits to produce catdef: + sumdef=0. + do k=1,nar + sumdef=sumdef+locdef(k)*px(k) + enddo + catdef(idep)=poros*1000.*sumdef/suma + + if (bug) write(*,*) 'basidep: ok2' + + bflow(idep)=cond*exp(-timean-gnu*zbar(idep))/gnu + + if (bug) write(*,*) 'basidep: ok3' + + END SUBROUTINE BASIDEP + + !***************************************************************************** + + SUBROUTINE SAT_PARAM( & + BEE,PSIS,POROS,COND, & + WPWET,VALX, PX, COESKEW,PFC, & + soildepth, & + ARS1,ARS2,ARS3, & + ARA1,ARA2,ARA3,ARA4, & + ARW1,ARW2,ARW3,ARW4, & + taberr1,taberr2,taberr3,taberr4, & + normerr1,normerr2,normerr3,normerr4, & + DBG_UNIT) + + !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + !c c + !c This program returns the eleven parameters for the areal fractioning c + !c c + !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + + INTEGER, intent (in) :: pfc + REAL, intent (in) :: BEE,PSIS,POROS,COND,WPWET, & + VALX(NAR), PX(NAR) + REAL, intent (in) :: soildepth, COESKEW + REAL, intent (inout) :: ARS1,ARS2,ARS3, & + ARA1,ARA2,ARA3,ARA4, & + ARW1,ARW2,ARW3,ARW4, & + taberr1,taberr2,taberr3,taberr4, & + normerr1,normerr2,normerr3,normerr4 + INTEGER idep,n,k,i,icount,iref + integer nar0 + integer nref, nind,nmax,indmin,locmax,shift,ord,locmin + integer loc1,loc2,loc3,loc0,flag + REAL VALX0(NAR), PX0(NAR) + integer :: adjust,loc2save,inc,dec + real sumta,suma,timean,upval,loval,profdep + real rjunk,rjunk2 + integer, intent (in), optional :: DBG_UNIT + real catdef(nbdep),wmin(nbdep),ar1(nbdep),aa(nbdep),aabis(nbdep) + real ar2(nbdep),ar3(nbdep),swsrf2(nbdep),swsrf3(nbdep),rzeq(nbdep) + real zbar0,catdef0,wmin0,RZDEP,wminsave(nbdep) + + real x1,x2,x3,x4,w1,w1_0,w2,w3,w4,ref1 + real y0,f1,f2,f3,g1,g2,g3,df,dg,dx,bf,bg,delta,z1,z2 + + real nar1(nbdep),nar2(nbdep),nmean2(nbdep),neq(nbdep) + real shape, nwm, area1,cdi,nar3(nbdep),nmean3 + real err1,err2,err3,err4,sum + real tabact(nbdep),tabfit(nbdep) + + integer :: mp,isvd,j,first_loop + ! REAL*8, allocatable :: A(:,:),AP(:,:) + ! REAL*8, allocatable :: B(:) + REAL*8, allocatable, target :: A(:,:) + REAL*8, allocatable, target :: B(:) + REAL*8, pointer :: AP(:,:) + REAL*8, pointer :: BP(:) + REAL*8 V(3,3),W(3),ANS(3),sdmax,sdmin,wbrac + + real :: cdcr1,cdcr2,term1,term2,zmet + logical :: smooth,ars_svd_loop + logical, parameter :: bug=.false. + logical, parameter :: SingValDecomp = .true. + integer, parameter :: nl=4, nr=4, m=4, NP=50 + real :: savgol_coeff(NP) + integer :: savgol_ind(NP) + integer :: nbdepl,istart + + ref1 = 100. + ! print *,'PFC', pfc + if (bug) write(*,*) 'starting sat_param' + + if(SingValDecomp) then + savgol_ind(1)=0 + j=3 + do i=2, nl+1 + savgol_ind(i)=i-j + j=j+2 + end do + + j=2 + do i=nl+2, nl+nr+1 + savgol_ind(i)=i-j + j=j+2 + end do + call savgol(savgol_coeff,nl+nr+1,nl,nr,0,m) + endif + + profdep = soildepth + rzdep =grzdep + profdep=profdep/1000. + profdep=amax1(1.,profdep) + if (rzdep .gt. .75*profdep) then + rzdep=0.75*profdep + end if + + zmet=profdep + term1=-1.+((psis-zmet)/psis)** & + ((bee-1.)/bee) + term2=psis*bee/(bee-1) + cdcr1=1000.*poros*(zmet-(-term2*term1)) + cdcr2=(1-wpwet)*poros*1000.*zmet + !c mean of the topographic index distribution + + nar0=0 + do n=1,nar + if (px(n) .ne. 0.) then + nar0=nar0+1 + valx0(nar0)=valx(n) + px0(nar0)=px(n) + endif + enddo + + sumta=0. + suma=0. + do n=1,nar0 + sumta=sumta+px0(n)*valx0(n) + suma=suma+px0(n) + enddo + timean=sumta/suma + + if (bug) write(*,*) 'ok 0: sumta,suma,nar0=',sumta,suma,nar0 + + !c**** Loop over water table depths + + do idep=1,nbdep + + CALL FUNCIDEP( & + NAR0,IDEP, & + BEE,PSIS,POROS,COND,RZDEP,WPWET, & + VALX0,PX0,COESKEW,TIMEAN,SUMA, & + CATDEF,AR1,WMIN,AA,AABIS, & + AR2,AR3,SWSRF2,SWSRF3,RZEQ) + enddo + + nbdepl = 100 + if(catdef(50) > cdcr1 + 20.) nbdepl = 50 + if(soildepth > 6500.) nbdepl = nbdep + + if (bug) write(*,*) 'funcidep loop ok' + + !c**** for wmin's adjustment, we need an estimate of its limit toward INF + adjust =0 + ZBAR0=10. + CALL FUNCZBAR( & + NAR0,ZBAR0, & + BEE,PSIS,POROS,COND,RZDEP,WPWET, & + VALX0,PX0,COESKEW,TIMEAN,SUMA, & + CATDEF0,WMIN0) + + if (bug) write(*,*) 'funczbar ok' + + if (wmin0 == 0.9999900) then + do idep=1,nbdep-1 + if(catdef(idep).le.cdcr1+10.) then + if((wmin(idep) - wmin(idep +1)) > -0.01) then + wmin0=wmin(idep) + endif + endif + enddo + wmin0 = 0.1*(nint(wmin0*100000.)/10000) -0.02 + endif + + if(present(dbg_unit)) then + write (dbg_unit,*) nbdep,nbdepl,wmin0,cdcr1,cdcr2 + write (dbg_unit,*) catdef + write (dbg_unit,*) ar1 + write (dbg_unit,*) wmin + endif + + !c**** AR1 adjustment: 3 points + limit in INF = 0. + + if (bug) write(*,*) 'STARTING AR1' + + ! Singular value decomposition + loc1=1 + loc3=nbdepl + loc2=loc3 + + do idep = 1,loc2 + if(ar1(idep) < 1.e-10) then + loc3 = idep - 1 + exit + endif + end do + + first_loop = 0 + ars_svd_loop = .TRUE. + DO while (ars_svd_loop) + + first_loop = first_loop + 1 + mp = loc3-loc1+1 + + allocate(A(mp,3)) + allocate(AP(mp,3)) + allocate(B(mp)) + + a=0. + ap=0. + b=0. + v=0. + w=0. + ans=0. + + do isvd=loc1,loc3 + A(isvd-loc1+1,1)=catdef(isvd) + A(isvd-loc1+1,2)=-catdef(isvd)*ar1(isvd) + A(isvd-loc1+1,3)=-ar1(isvd)*((catdef(isvd))**2.) + B(isvd-loc1+1)=ar1(isvd)-1. + end do + + ap = a + call svdcmp(ap,mp,3,w,v) + sdmax=0. + do j=1,3 + if(w(j).gt.sdmax)sdmax=w(j) + end do + sdmin=sdmax*1.0e-6 + do j=1,3 + if(w(j).lt.sdmin)w(j)=0. + end do + + call svbksb(ap,w,v,mp,3,b,ans) + + ars1 = real(ans(1)) + ars2 = real(ans(2)) + ars3 = real(ans(3)) + + flag=0 + call curve1(ars1,ars2,ars3,cdcr2,flag) + deallocate (A, AP, B) + + IF(FLAG == 1) THEN + LOC3 = NBDEP + LOC1 =1 + IF(first_loop > 1) ars_svd_loop=.FALSE. + ELSE + ars_svd_loop=.FALSE. + ENDIF + END DO + + IF (FLAG.EQ.1) then + + flag=0 + loc1=1 + do idep=1,nbdepl + if (catdef(idep) .le. 20.) loc1=idep + enddo + + loc3=1 + do idep=1,nbdepl -1 + if ((ar1(idep) >= 0.0001).and.(catdef(idep) <= cdcr1)) loc3=idep + 1 + enddo + + if (loc3.le.loc1+1) then + loc1=MIN(loc3-4,loc1-4) + loc1=MAX(1,loc1) + endif + + !c below is what was used for no regression, but it's not equivalent to the + !c IDL program + loc2=AINT(loc1-1+(loc3-loc1)*3./5.)+1 + + w1=ar1(loc1) + w2=ar1(loc2) + w3=ar1(loc3) + + if(w3.eq.0.)then +95 loc3=loc3-1 + if(loc3.eq.loc2)loc2=loc2-1 + w3=ar1(loc3) + w2=ar1(loc2) + if(w3.eq.0.)goto 95 + endif + w4=0. + + if((loc1.ge.loc2).or.(loc2.ge.loc3))then + loc1=10 + loc2=14 + loc3=18 + endif + +115 x1=catdef(loc1) + x2=catdef(loc2) + x3=catdef(loc3) + w1=ar1(loc1) + w2=ar1(loc2) + w3=ar1(loc3) + + if (bug) then + write(*,*) 'loc1,loc2,loc3=',loc1,loc2,loc3 + write(*,*) 'x1,x2,x3=',x1,x2,x3 + write(*,*) 'w1,w2,w3=',w1,w2,w3 + endif + + y0=w4 + f1=(1.-w1)/(w1-y0)/x1 + f2=(1.-w2)/(w2-y0)/x2 + f3=(1.-w3)/(w3-y0)/x3 + g1=(1.-y0)/(w1-y0) + g2=(1.-y0)/(w2-y0) + g3=(1.-y0)/(w3-y0) + df=f2-f1 + dg=g2-g1 + dx=x2-x1 + bf=f1-x1*df/dx + bg=g1-x1*dg/dx + + ars1 = -(f3-bf-x3*df/dx)/(g3-bg-x3*dg/dx + 1.e-10) + ars2 = bf+ars1*bg + ars3 = (df+ars1*dg)/dx + + delta=ars2*ars2-4*ars3 + upval=1.+200.*ars1 + loval=1.+200.*ars2+40000.*ars3 + z1=0. + z2=0. + + if (delta .ge. 0.) then !if 8 + z1=(-ars2-SQRT(delta))/2./ars3 + z2=(-ars2+SQRT(delta))/2./ars3 + endif + + if ((z1 .gt. 0. .and. z1 .lt. cdcr1) .or. & + (z2 .gt. 0. .and. z1 .lt. cdcr1) .or. & + ((upval/loval).lt.-.01)) then !if 7 + z1=0. + z2=0. + if (loc1 .eq. 10) then + loc1=1 +1 else + loc1=1 + do idep=1,nbdepl + if (catdef(idep) .gt. 60.) then + loc1=idep + if(loc1.ge.loc3-1)then + ! write(*,*)'Loc1 exceeded loc3 in 2nd attempt' + loc1=loc3-5 + endif + goto 46 + endif + enddo + endif +46 loc2=loc1+AINT(float(loc3-loc1)*3./5.)+1 + if(loc2.ge.loc3)loc2=loc3-1 + loc2save=loc2 + INC=1 + DEC=0 + +47 w1=ar1(loc1) + w2=ar1(loc2) + x1=catdef(loc1) + x2=catdef(loc2) + + if (bug) then + write(*,*) 'z1,z2=',z1,z2,' -> ar1, 2nd try' + write(*,*) 'loc1,loc2,loc3=',loc1,loc2,loc3 + write(*,*) 'x1,x2,x3=',x1,x2,x3 + write(*,*) 'w1,w2,w3=',w1,w2,w3 + endif + + f1=(1.-w1)/(w1-y0)/(x1 + 1.e-20) + f2=(1.-w2)/(w2-y0)/(x2 + 1.e-20) + g1=(1.-y0)/(w1-y0 + 1.e-20 ) + g2=(1.-y0)/(w2-y0 + 1.e-20) + df=f2-f1 + dg=g2-g1 + dx=x2-x1 + bf=f1-x1*df/dx + bg=g1-x1*dg/dx + + ars1 = -(f3-bf-x3*df/dx)/(g3-bg-x3*dg/dx + 1.e-10) + ars2 = bf+ars1*bg + ars3 = (df+ars1*dg)/dx + delta=ars2*ars2-4*ars3 + upval=1.+200.*ars1 + loval=1.+200.*ars2+40000.*ars3 + + if (delta .ge. 0.) then !if 6 + z1=(-ars2-SQRT(delta))/2./ars3 + z2=(-ars2+SQRT(delta))/2./ars3 + end if + + if ((z1 .gt. 0. .and. z1 .lt. cdcr1) .or. & + (z2 .gt. 0. .and. z1 .lt. cdcr1) .or. & + ((upval/loval).lt.-.01)) then !if 5 + !c Sarith --- + z1=0. + z2=0. + IF(INC.EQ.1)loc2=loc2+1 + IF(DEC.EQ.1)LOC2=LOC2-1 + if(inc.eq.1)then !if 4 + if(loc2.ge.loc3)then !if 3 + ! WRITE(*,*)'INCREASING LOC2 FAILED' + INC=0 + DEC=1 + loc2=loc2save + else + adjust=ADJUST+1 + goto 47 + end if !if 3 + endif !if 4 + + if(dec.eq.1)then !if 2 + if(loc2.eq.loc1)then !if 1 + ! WRITE(*,*)'Decreasing too failed' + INC=1 + DEC=0 + ars1=9999. !ars1old + ars2=9999. !ars2old + ars3=9999. !ars3old + ! write(*,*) 'AR1: PROBLEM for pfc=',pfc + else + adjust=ADJUST+1 + !c write(*,*)'ADJUSTING AR1 CYCLE =',ADJUST + goto 47 + end if !if 1 + endif !if 2 + endif !if 5 + !c endif !if 6 + endif !if 7 + + !c endif !if 8 + flag=0 + call curve1(ars1,ars2,ars3,cdcr2,flag) + + IF (FLAG.EQ.1)then + ! WRITE(*,*)'Curve problem in the catchment pfc=',pfc + ars1=9999. + ars2=9999. + ars3=9999. + ! write(*,*) 'Pick values from icatch-1' + flag=0 + end if + endif + + adjust=0 + + if (bug) write(*,*) 'ar1 adjustment ok' + + !c**** WMIN adjustment: 3 points + limit in INF = wmin0 + + if (bug) write(*,*) 'STARTING WMIN' + + w4=wmin0 + y0=w4 + + ! write(*,*) 'wmin=',(wmin(idep),idep=1,50) + + loc1=1 + do idep=1,nbdepl + if (catdef(idep) <= 10.) loc1=idep + enddo + + loc3=1 + do idep=1,nbdepl - 2 + if ((wmin(idep) >= wmin0).and.(catdef(idep) <= cdcr1)) loc3=idep + 2 + enddo + + loc2=loc1 + 2 + do idep=1,nbdepl -1 + if ((wmin(idep) >= wmin0).and.(catdef(idep) <= cdcr1/2.))loc2=idep + 1 + enddo + + !c For global catch + INC=1 + DEC=0 + + if(loc3.eq.loc2)loc2=loc2-2 + if(loc2 <= loc1) loc1= loc1-2 +44 loc2save=loc2 + if(loc1 < 1) then + loc1 =1 + loc2 =2 + loc3 =3 + endif + + w1=wmin(loc1) + w2=wmin(loc2) + w3=wmin(loc3) + x1=catdef(loc1) + x2=catdef(loc2) + x3=catdef(loc3) + + if (bug) then + write(*,*) 'loc1,loc2,loc3=',loc1,loc2,loc3 + write(*,*) 'x1,x2,x3=',x1,x2,x3 + write(*,*) 'w1,w2,w3,w4=',w1,w2,w3,w4 + endif + + f1=(1.-w1)/(w1-y0)/x1 + f2=(1.-w2)/(w2-y0)/x2 + f3=(1.-w3)/(w3-y0)/x3 + g1=(1.-y0)/(w1-y0) + g2=(1.-y0)/(w2-y0) + g3=(1.-y0)/(w3-y0) + df=f2-f1 + dg=g2-g1 + dx=x2-x1 + bf=f1-x1*df/dx + bg=g1-x1*dg/dx + + arw1 = -(f3-bf-x3*df/dx)/(g3-bg-x3*dg/dx + 1.e-10) + arw2 = bf+arw1*bg + arw3 = (df+arw1*dg)/dx + arw4 = y0 + + !c wmin=arw4+(1.-arw4)*(1.+arw1*catdef(idep)) + !c /(1.+arw2*catdef(idep)+arw3*catdef(idep)*catdef(idep)) + !c we want to check the roots of the denominator + + delta=arw2*arw2-4*arw3 + + if (delta .ge. 0.) then !if 8 + + z1=(-arw2-SQRT(delta))/2./arw3 + z2=(-arw2+SQRT(delta))/2./arw3 + + if ((z1 .gt. 0. .and. z1 .lt. cdcr1) .or. & + (z2 .gt. 0. .and. z1 .lt. cdcr1)) then !if 7 + + w1_0=w1 + w1=(1.+w1_0)/2. + x1=x1/4. + + ! if (gnu .eq. 3.26/1.5) then + ! w1=(1.+w1_0)/3. ! already difficult + ! w3=wmin(nint(cdcr1)) ! with gnu=3.26 + ! x3=catdef(nint(cdcr1)) + ! f3=(1.-w3)/(w3-y0)/x3 + ! g3=(1.-y0)/(w3-y0) + ! endif + + f1=(1.-w1)/(w1-y0)/x1 + g1=(1.-y0)/(w1-y0) + df=f2-f1 + dg=g2-g1 + dx=x2-x1 + bf=f1-x1*df/dx + bg=g1-x1*dg/dx + + if (bug) then + write(*,*) 'z1,z2=',z1,z2,' -> wmin, 2nd try' + write(*,*) 'loc1,loc2,loc3=',loc1,loc2,loc3 + write(*,*) 'x1,x2,x3=',x1,x2,x3 + write(*,*) 'w1,w2,w3=',w1,w2,w3 + write(*,*) 'wmin0=',wmin0 + endif + + arw1 = -(f3-bf-x3*df/dx)/(g3-bg-x3*dg/dx + 1.e-10) + arw2 = bf+arw1*bg + arw3 = (df+arw1*dg)/dx + arw4 = y0 + + delta=arw2*arw2-4*arw3 + + if (delta .ge. 0.) then !if 6 + z1=(-arw2-SQRT(delta))/2./arw3 + z2=(-arw2+SQRT(delta))/2./arw3 + + if ((z1 .gt. 0. .and. z1 .lt. cdcr1) .or. & + (z2 .gt. 0. .and. z1 .lt. cdcr1)) then !if 5 + !c Sarith --- + IF(INC.EQ.1)loc2=loc2+1 + IF(DEC.EQ.1)LOC2=LOC2-1 + if(inc.eq.1)then !if 4 + if(loc2.eq.loc3)then !if 3 + ! WRITE(*,*)'INCREASING LOC2 FAILED: WMIN' + INC=0 + DEC=1 + loc2=loc2save + else + adjust=ADJUST+1 + !c write(*,*)'ADJUSTING AR1 CYCLE =',ADJUST + goto 44 + end if !if 3 + endif !if 4 + if(dec.eq.1)then !if 2 + if(loc2.eq.loc1)then !if 1 + ! WRITE(*,*)'Decreasing too failed: WMIN' + INC=1 + DEC=0 + + arw1=9999. + arw2=9999. + arw3=9999. + arw4=9999. + + else + adjust=ADJUST+1 + !c write(*,*)'ADJUSTING AR1 CYCLE =',ADJUST + goto 44 + end if !if 1 + endif !if 2 + endif !if 5 + endif !if 6 + + endif !if 7 + endif !if 8 + adjust=0 + ! endif ! pfc=12821 + flag=0 + + call curve2(arw1,arw2,arw3,arw4,cdcr1,WPWET,flag) + + IF (FLAG.EQ.1) THEN + arw1=9999. !arw1old + arw2=9999. !arw2old + arw3=9999. !arw3old + arw4=9999. !arw4old + flag=0 + endif + + if(arw1==9999.) then + ! Singular Value Decomposition + + w4=wmin0 + y0=w4 + + loc1=1 + loc3=nbdepl + + mp = loc3-loc1+1 + + if(mp.lt.3)then + + write(*,*)'WMIN Note: not sufficient points MP = ',mp + print *,w4,cdcr1,catdef(loc3),wmin(loc3) + arw1 = 9999. + arw2 = 9999. + arw3 = 9999. + arw4 = 9999. + else + + mp = 1 + istart =1 + w4 = wmin(istart) + + if(w4 <=0) then + do idep=2,nbdepl + if(wmin(idep) > 0.) istart = idep + if(wmin(idep) > 0.) exit + enddo + endif + + w4 = wmin(istart) + + do idep=istart+1,nbdepl + ! if(wmin(idep).lt.w4) then + if((wmin(idep) - w4).lt.0.0005) then + w4 = wmin(idep) + mp = mp +1 + endif + enddo + loc3 = mp + allocate(A(mp,3)) + allocate(AP(mp,3)) + allocate(B(mp)) + allocate(BP(mp)) + smooth = .false. + do idep=istart,nbdepl-1 + if(catdef(idep).le.cdcr1+10.) then + if((wmin(idep) - wmin(idep +1)) < -0.01) smooth = .true. + endif + enddo + if(smooth) then + wminsave = wmin + ! Apply filter to input data + do i=istart, nbdepl-nr + wmin(i)=0. + do j=1, nl+nr+1 + if (i+savgol_ind(j).gt.0) then !skip left points that do not exist + wmin(i)=wmin(i)+savgol_coeff(j)*wminsave(i+savgol_ind(j)) + endif + end do + enddo + wmin (istart:istart+4) = wminsave (istart:istart+4) + + endif + + j = 1 + w4 = wmin(istart) + do isvd=1,size(wmin) + if (j <= mp) then + if(isvd == 1) then + wbrac=(wmin(isvd + istart -1)-y0)/(1.-y0 + 1.e-20) + A(j,1)=catdef(isvd + istart -1) + A(j,2)=-catdef(isvd + istart -1)*wbrac + A(j,3)=-wbrac*((catdef(isvd + istart -1))**2.) + B(j)=wbrac-1. + j = j + 1 + else + if((wmin(isvd + istart -1).lt.w4).and.(wmin(isvd + istart -1).gt.y0)) then + wbrac=(wmin(isvd + istart -1)-y0)/(1.-y0 + 1.e-20) + A(j,1)=catdef(isvd + istart -1) + A(j,2)=-catdef(isvd + istart -1)*wbrac + A(j,3)=-wbrac*((catdef(isvd + istart -1))**2.) + B(j)=wbrac-1. + w4 = wmin(isvd + istart -1) + j = j + 1 + endif + endif + endif + end do + + j = j -1 + mp = j + ap => a (1:j,:) + bp => b (1:j) + ap(j,1) = catdef(nbdep) + ap(j,2) = 0. + ap(j,3) = 0. + bp (j) = -1. + + call svdcmp(ap,mp,3,w,v) + + sdmax=0. + do j=1,3 + if(w(j).gt.sdmax)sdmax=w(j) + end do + + sdmin=sdmax*1.0e-6 + do j=1,3 + if(w(j).lt.sdmin)w(j)=0. + end do + + call svbksb(ap,w,v,mp,3,bp,ans) + + arw1 = real(ans(1)) + arw2 = real(ans(2)) + arw3 = real(ans(3)) + arw4 = y0 + + !c wmin=arw4+(1.-arw4)*(1.+arw1*catdef(idep)) + !c /(1.+arw2*catdef(idep)+arw3*catdef(idep)*catdef(idep)) + !c we want to check the roots of the denominator + + adjust=0 + flag=0 + + call curve2(arw1,arw2,arw3,arw4,cdcr1,WPWET,flag) + + IF (FLAG.EQ.1) THEN + ! WRITE(*,*)'Curve2 problem in the catchment:pfc=',pfc + + arw1 = 9999. + arw2 = 9999. + arw3 = 9999. + arw4 = 9999. + + flag=0 + end if + deallocate (A, B ) + NULLIFY (AP, BP) + end if + endif + + if(present(dbg_unit)) then + write (dbg_unit,*) ars1,ars2,ars3 + write (dbg_unit,*) arw1,arw2,arw3,arw4 + endif + + if (bug) write(*,*) 'wmin adjustment ok' + + !c**** SHAPE PARAMETER ADJUSTMENT: with a straight if coeskew > 0.25 + !c with 2 segments if not + + if (bug) write(*,*) 'STARTING SHAPE' + + x3=catdef(nbdepl) + w3=aa(nbdepl) + x1=0. + + if (coeskew .lt. 0.25) then + w1=0.1 + loc2=20 + do idep=1,nbdepl + if (catdef(idep) .gt. ref1) then + loc2=idep + goto 45 + endif + enddo +45 x2=catdef(loc2) + w2=aabis(loc2) + ara1 = (w1-w2)/(x1-x2) + ara2 = w1-ara1*x1 + ara3 = (w2-w3)/(x2-x3) + ara4 = w2-ara3*x2 + else + w1=1. + x2=x1 + w2=w1 + ara3 = (w2-w3)/(x2-x3) + ara4 = w2-ara3*x2 + ara1 = ara3 + ara2 = ara4 + endif + + if (bug) write(*,*) 'x1,w1,x2,w2,x3,w3',x1,w1,x2,w2,x3,w3 + + !**** RMSE checking: on ar1, ar2, swsrf2 and rzeq + + do idep=1,nbdepl + if(catdef(idep) <= cdcr1) then + nar1(idep)=AMIN1(1.,AMAX1(0.,(1.+ars1*catdef(idep)) & + /(1.+ars2*catdef(idep) & + +ars3*catdef(idep)*catdef(idep)))) + + nwm=AMIN1(1.,AMAX1(0.,arw4+(1.-arw4)* & + (1.+arw1*catdef(idep)) & + /(1.+arw2*catdef(idep) & + +arw3*catdef(idep)*catdef(idep)))) + + !c we have to first determine if there is one or two segments + if (ara1 .ne. ara3) then + cdi=(ara4-ara2)/(ara1-ara3) + else + cdi=0. + endif + + if (catdef(idep) .ge. cdi) then + shape=ara3*catdef(idep)+ara4 + else + shape=ara1*catdef(idep)+ara2 + endif + shape =AMIN1(40.,shape) + area1=exp(-shape*(1.-nwm))*(shape*(1.-nwm)+1.) + + !c the threshold for truncation problems is higher than the "usual" + !c E-8 to E-10, because it plays together with the uncertainties coming + !c from the approximation of the parameters nwm, nar1 and shape. + if (area1 .ge. 1.-1.E-8) then + nar1(idep)=1. + nar2(idep)=0. + nar3(idep)=0. + nmean2(idep)=0. + nmean3=0. + neq(idep)=1. + else + + if (nwm .gt. wpwet) then + nar2(idep)=1.-nar1(idep) + else + nar2(idep)=AMAX1(0.,((shape*(wpwet-nwm)+1.) & + *exp(-shape*(wpwet-nwm)) & + - (shape*(1.-nwm)+1.)*exp(-shape*(1.-nwm))) & + * (1.-nar1(idep))/(1.-area1)) + endif + + nar3(idep)=1.-nar1(idep)-nar2(idep) + + if (nar3(idep) .lt. 1.E-8) then ! for nwm le wpwet + + nmean2(idep)=AMAX1(0.,AMIN1(1.,(nwm + 2./shape + & + shape*exp(-shape*(1.-nwm))* & + (nwm+nwm/shape-1.-2./shape-2./(shape*shape))) & + /(1.-area1))) + nmean3=0. + + else + + !c WARNING: I think the two values below are false. + !c But it is never used in this context, because nwm > wpwet !! + nmean2(idep)=AMAX1(0.,AMIN1(1.,-shape*(exp(-shape*& + (wpwet-nwm))* (nwm*wpwet & + +nwm/shape-wpwet*wpwet & + -2.*wpwet/shape-2./(shape*shape)) & + - exp(-shape*(1.-nwm))* & + (nwm+nwm/shape-1.-2./shape-2./(shape*shape)))& + * (1.-nar1(idep))/(1.-area1) / (nar2(idep)+1.e-20))) + + nmean3=AMAX1(0.,AMIN1(1.,(nwm+2./shape + & + shape*exp(-shape*(wpwet-nwm))* & + (nwm*wpwet+nwm/shape-wpwet & + *wpwet-2.*wpwet/shape & + -2./(shape*shape))) * (1.-nar1(idep)) & + /(1.-area1)/(nar3(idep) + 1.e-20))) + endif + + neq(idep)=nar1(idep)+nar2(idep)*nmean2(idep) & + +nar3(idep)*nmean3 + + if (area1 .ge. 1.-1.E-5) then + nmean2(idep)=1. + nmean3=0. + neq(idep)=1. + endif + + endif + endif + enddo + + if (bug) write(*,*) 'shape adjustment ok' + !c + !c RMSE + + !c ERR1 + icount=0 + iref=0 + sum=0. + do i=1,nbdepl + if(catdef(i) <= cdcr1) then + tabact(i)=0. + tabfit(i)=0. + endif + enddo + + do i=1,nbdepl + if(catdef(i) <= cdcr1) then + if (catdef(i) .gt. lim) then + icount=icount+1 + sum=sum+ar1(i) + tabfit(icount)=nar1(i) + tabact(icount)=ar1(i) + endif + endif + enddo + + if(icount.gt.1) then + sum=sum/icount + call RMSE(tabact,tabfit,icount,err1) + taberr1=err1 + normerr1=err1/sum + endif + !c ERR2 + icount=0 + iref=0 + sum=0. + do i=1,nbdepl + if(catdef(i) <= cdcr1) then + tabact(i)=0. + tabfit(i)=0. + endif + enddo + + do i=1,nbdepl + if(catdef(i) <= cdcr1) then + if (catdef(i) .gt. lim) then + icount=icount+1 + sum=sum+ar2(i) + tabfit(icount)=nar2(i) + tabact(icount)=ar2(i) + endif + endif + enddo + + if(icount.gt.1) then + sum=sum/icount + call RMSE(tabact,tabfit,icount,err2) + taberr2=err2 + normerr2=err2/sum + endif + + !c ERR3 + icount=0 + iref=0 + sum=0. + do i=1,nbdep + if(catdef(i) <= cdcr1) then + tabact(i)=0. + tabfit(i)=0. + endif + enddo + + do i=1,nbdepl + if(catdef(i) <= cdcr1) then + if (catdef(i) .gt. lim) then + icount=icount+1 + sum=sum+swsrf2(i) + tabfit(icount)=nmean2(i) + tabact(icount)=swsrf2(i) + endif + endif + enddo + + if(icount.gt.1) then + sum=sum/icount + call RMSE(tabact,tabfit,icount,err3) + taberr3=err3 + normerr3=err3/sum + endif + !c ERR4 + icount=0 + iref=0 + sum=0. + do i=1,nbdepl + tabact(i)=0. + tabfit(i)=0. + enddo + + do i=1,nbdepl + if(catdef(i) <= cdcr1) then + if (catdef(i) .gt. lim) then + icount=icount+1 + sum=sum+rzeq(i) + tabfit(icount)=neq(i) + tabact(icount)=rzeq(i) + endif + endif + enddo + + if(icount.gt.1) then + sum=sum/icount + call RMSE(tabact,tabfit,icount,err4) + taberr4=err4 + normerr4=err4/sum + endif + END SUBROUTINE SAT_PARAM + ! + + ! ****************************************************************** + + !c + SUBROUTINE CURVE1(ars1,ars2,ars3,cdcr2,flag) + REAL ars1,ars2,ars3,y,x,yp,cdcr2 + INTEGER i,flag + !c + yp=1. + if (abs(ars1+ars2+ars3).le.1.e25) then + do i=0,CEILING(cdcr2) + x=float(i) + if(x > cdcr2) x = cdcr2 + y=(1.+ars1*x)/(1.+ars2*x+ars3*x*x + 1.e-20) + if((y.gt.0.0).and.(((yp -y) .lt. -1.e-4).or.(y.gt.1.)))then + flag=1 + goto 99 + endif + yp=y + end do +99 continue + else + flag=1 + endif + + end SUBROUTINE CURVE1 + + + ! ****************************************************************** + + SUBROUTINE CURVE2(arw1,arw2,arw3,arw4,cdcr1,WPWET,flag) + REAL arw1,arw2,arw3,arw4,y,x,yp,cdcr1, wpwet + INTEGER i,flag + !c + yp=1. + if (abs(arw1+arw2+arw3+arw4).le.1.e25) then + do i=0,CEILING(cdcr1) + x=float(i) + if(x > cdcr1) x = cdcr1 + y=arw4+(1.-arw4)*(1.+arw1*x)/(1.+arw2*x+arw3*x*x + 1.e-20) + if ((y .lt. wpwet).or.((yp -y) .lt. -1.e-4).or.(y.gt.1.)) then + flag=1 + goto 99 + endif + yp=y + end do +99 continue + else + flag=1 + endif + end SUBROUTINE CURVE2 + + ! ****************************************************************** + + subroutine tgen ( & + TOPMEAN,TOPVAR,TOPSKEW, & + STO,ACO,COESKEW) + + !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + ! c + ! The difference between tgen4 and tgen3 is that tgen4 deals with arrays c + ! of topmean, topvar and topskew and 2-dim arrays of st and ac. c + ! c + ! This routine determine the theoretical gamma distribution for the c + ! soil-topographic indexes (Sivapalan et al., 1987), knowing the three c + ! first moments, the min and the max of the observed topographic indexes c + ! in a given catchment. c + ! c + ! Routine from Dave Wolock. c + ! Modified by Agnes (11-06-98): we don't use min and max anymore, and c + ! this strongly improves the behavior for negative skewnesses. It also c + ! improves in general the matching of the moments. c + ! c + ! We also add a correction on the skewness to have gamma distributions c + ! that start and end from the x-axis. It is based on the fact that if c + ! TOPETA=1, the gamma is an exponential distribution, and if TOPETA<1, c + ! then the gamma distribution increases towards the infinite when x c + ! decreases towards 0. c + ! To eliminate some numerical pb due to teh discretization of the gamma c + ! distribution, we choose skewness=MAX(MIN(1.9, skewness),-1.6) c + ! c + ! WE MAY NEED TO COMPUTE IN DOUBLE RESOLUTION !!!! BECAUSE OF THE SMALL c + ! BIN WIDTH + ! c + !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + + real, parameter :: VALMAX=50. + REAL, intent (in) :: TOPMEAN,TOPVAR,TOPSKEW + REAL, intent (out) :: COESKEW + REAL, dimension (NAR), intent (out) :: STO,ACO + + INTEGER I + REAL ST(NAR),AC(NAR) + REAL TOPETA,TOPLAM,TOPSCAL,GAMLN,SCALE,ACLN + real cumac, cum2,cum3 + + !------------------------------------------------------------------------- + + ! topmean is the mean of the ln(a/tanB) distribution + ! topvar is the variance (2nd moment centered around the mean) of the ... + ! topskew is the skew (3rd moment centerd around the mean) of the ... + ! compute the coefficient of skew or skewness (coeskew) + + COESKEW=TOPSKEW/TOPVAR**1.5 + if (coeskew .ge. 0.) then + COESKEW=AMAX1(0.005, AMIN1(1.9, COESKEW)) + else + COESKEW=AMAX1(-1.6, AMIN1(-0.005, COESKEW)) + endif + + ! compute the gamma parameters, eta (topeta) and lambda (toplam), and topscal + ! which is the translation parameter + + TOPETA=4./COESKEW**2 + TOPLAM=SQRT(TOPETA)/SQRT(TOPVAR) + TOPSCAL=TOPMEAN-TOPETA/TOPLAM + + ! evaluate the gamma function + + CALL GAMMLN (TOPETA,GAMLN) + + CUMAC=0.0 + + ! compute the frequency distribution of ln(a/tanB) + ! st(i) are the values of ln(a/tanB) + ! ac(i) are the relative frequency values (they should sum to 1) + + DO I=1,NAR + + ST(I)=(FLOAT(I)-0.95)*(VALMAX-TOPSCAL)/FLOAT(NAR)+TOPSCAL + SCALE=ST(I)-TOPSCAL + + ! below is the logarithmic form of the gamma distribution; this is required + ! because the numerical estimate of the logarithm of the gamma function + ! is more stable than the one of the gamma function. + + ACLN=TOPETA*ALOG(TOPLAM)+(TOPETA-1.)*ALOG(SCALE) & + -TOPLAM*SCALE-GAMLN + + IF(ACLN.LT.-10.) THEN + AC(I)=0. + ELSE + AC(I)=EXP(ACLN) + ENDIF + + CUMAC=CUMAC+AC(I) + + ENDDO + + ! we want the relative frequencies to sum 1. + + IF (CUMAC.eq.0.) THEN + ! write(*,*) 'distrib sum=',CUMAC + stop + endif + CUM2=0. + DO I=1,NAR + AC(I) = AC(I) / CUMAC + CUM2=CUM2+AC(I) + ENDDO + + ! if the real distribution of the topographic indices is negativeley skewed, + ! we symetrize the gamma distribution (depending on coeskew**2 and always + ! positively skewed), centering on topmean, which preserves topmean and + ! topvar, and re-establishes a negative skewness. + + IF (COESKEW.LT.0.) then + + do i=1,nar + STO(I)=2.*TOPMEAN-ST(I) + ACO(I)=AC(I) + + enddo + ELSE + ! if (n .eq. idmax) then + ! write(*,*) 'last catchment' + ! endif + do i=1,nar + STO(I)=ST(-I+NAR+1) + ACO(I)=AC(-I+NAR+1) + enddo + ENDIF + + ! sum=0. + ! do i=1,nar + ! sum=sum+sto(i)*aco(i) + ! end do + + ! sum=0. + ! do i=1,nar + ! sum=sum+aco(i) + ! end do + + + END subroutine tgen + + ! ******************************************************************** + + SUBROUTINE GAMMLN (XX,GAMLN) + + DOUBLE PRECISION :: COF(6),STP,HALF,ONE,FPF,X,TMP,SER + REAL, intent(in) :: XX + REAL, intent(out) :: GAMLN + integer :: j + + DATA COF /76.18009173D0,-86.50532033D0,24.01409822D0, & + -1.231739516D0,.120858003D-2,-.536382D-5/ + STP = 2.50662827465D0 + HALF= 0.5D0 + ONE = 1.0D0 + FPF = 5.5D0 + + X=XX-ONE + TMP=X+FPF + TMP=(X+HALF)*LOG(TMP)-TMP + SER=ONE + + DO J=1,6 + X=X+ONE + SER=SER+COF(J)/X + END DO + + GAMLN=TMP+LOG(STP*SER) + + END SUBROUTINE GAMMLN + + ! ******************************************************************** + + SUBROUTINE FUNCIDEP( & + NAR0,IDEP, &!I + BEE,PSIS,POROS,COND,RZDEP,WPWET, &!I + VALX,PX,COESKEW,TIMEAN,SUMA, &!I + CATDEF,AR1,WMIN,AA,AABIS, &!O + AR2,AR3,SWSRF2,SWSRF3,RZEQ) + + !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + !c c + !c This program returns the eight parameters for the areal fractioning c + !c c + !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + + integer, intent (in) :: NAR0,idep + REAL, intent (in) :: BEE, PSIS, POROS, COND, RZDEP, WPWET, COESKEW + REAL, intent (inout) :: VALX(NAR), PX(NAR),TIMEAN,SUMA + ! logical, intent(in) :: bug + real, dimension (nbdep), intent (inout) :: CATDEF,AR1,WMIN,AA, & + AABIS,AR2,AR3,SWSRF2,SWSRF3,RZEQ + INTEGER :: width, nref, nind,nmax,indmin,locmax,shift,ord,locmin,ordref + integer :: indimax10,indmin0,k,n,n1,n2 + real dx,zbar + + real test,term1,term2,sum + real zdep(nar),locdef(nar),wrz(nar),frcunsat + real valtest(nbdep,nar),ptest(nbdep,nar),denstest(nbdep,nar) + real dtest(nbdep,nar),cump + real x1,x2,y1,y2,wa,wb + real densaux(nar),densaux2(nar),densmax,aux10 + real :: dz, sumdef + !c------------------------------------------------------------------------- + + !c integral(f(x)dx)=1. for a pdf + !c here px=f(x)dx + dx=valx(1)-valx(2) + + if (bug) write(*,*) 'IDEP=',IDEP,' dx=',dx + + !c the loops over idmax and nbdep are initiated in sta_params4.f + + zbar=float(idep-10)*slice ! zdep in meters + + !c**** Compute array of water table depths: + do k=1,nar0 + term1=(1/gnu)*(valx(k)-timean) + zdep(k)=AMAX1(0.,zbar-term1) + enddo + + !c variable change must be reflected in dx + dz=dx/gnu + + if (bug) write(*,*) 'funcidep: ok1' + + !c**** Compute array of moisture deficits: + do k=1,nar0 + term1=(psis-zdep(k))/psis + term1=term1**(1.-1./bee) + term2=-psis*(bee/(bee-1.))*(term1-1.) + locdef(k)=zdep(k)-term2 + enddo + + !c**** Add deficits to produce catdef: + sumdef=0. + do k=1,nar0 + sumdef=sumdef+locdef(k)*px(k) + enddo + catdef(idep)=poros*1000.*sumdef/suma + + if (bug) write(*,*) 'funcidep: ok2' + + !c**** Compute array of root zone moisture (degree of wetness in root zone): + do k=1,nar0 + term1=((psis-zdep(k))/psis) & + **(1.-1./bee) + if(zdep(k).le.0.) then + wrz(k)=1. + elseif(zdep(k)-rzdep.lt.0.) then + term2=(-psis/zdep(k))*(bee/(bee-1.)) & + *(term1-1.) + frcunsat=zdep(k)/rzdep + wrz(k)=frcunsat*term2+(1.-frcunsat)*1. + else + term2=((psis-zdep(k)+rzdep) & + /psis)**(1.-1./bee) + wrz(k)=(-psis/rzdep)*(bee/ & + (bee-1.))*(term1-term2) + endif + + enddo + + if (bug) write(*,*) 'funcidep: ok3' + + !c**** compute the densities and dx + !c**** we use a usefull property that is due to the construction of the + !c**** gamma distribution in tgen3.f : this distribution is continuous, + !c**** with decreasing values on ln(a/tanb) when n goes from 1 to nar0 + + !c first we gather in the same bin all the bins with values ge 1 + nref=1 + nind=1 + ptest(idep,1)=0. + do k=1,nar0 + if (wrz(k) .eq. 1.) then + nref=nref+1 + ptest(idep,1) = ptest(idep,1) + px(k) + endif + enddo + if (nref .gt. 1) then + nind=2 + valtest(idep,1)=1. + endif + nmax=nar0-nref+nind + if (bug) write(*,*) 'nmax,nind,nar0,nref=',nmax,nind,nar0,nref + + !c definition of the probabilities ptest + if (nmax .eq. 1) then ! all the bins have values ge 1 + dtest(idep,1) = 0.0001 + ptest(idep,1) = 1. + else ! distribution in ar2/ar3 + do n=0,nmax-nind + valtest(idep,nind+n)=wrz(nref+n) + ptest(idep,nind+n)=px(nref+n) + enddo + + !c we have to define dtest, the size of each bin + if (nmax .eq. 2) then + dtest(idep,2) = valtest(idep,1)-valtest(idep,2) + dtest(idep,1) = dtest(idep,2)/2. + else ! nmax .gt. 2 + do n=2,nmax-1 + dtest(idep,n)=(valtest(idep,n-1)-valtest(idep,n+1))/2. + enddo + dtest(idep,1) = dtest(idep,2)/2. + dtest(idep,nmax) = dtest(idep,nmax-1) + endif + endif + + if (bug) write(*,*) 'funcidep: ok4' + + !c we can now define the probability density: denstest=ptest/dtest + !c where ptest is the probability and dtest the size of the bin + do n=1,nmax + if (ptest(idep,n) .eq. 0.) then + denstest(idep,n)=0. + else + denstest(idep,n)=ptest(idep,n)/dtest(idep,n) + endif + enddo + + if (bug) write(*,*) 'funcidep: ok5' + + !c NOW we can estimate the parameters for the approximated distrib + !c from the actual distrib + + !c 1. AR1=saturated area and AR2 and AR3 + averages of the RZ wetness + !c in the different fractions + + ar1(idep)=0. + ar2(idep)=0. + ar3(idep)=0. + swsrf3(idep)=0. + swsrf2(idep)=0. + rzeq(idep)=0. + + if(valtest(idep,1).eq.1.) ar1(idep)=dtest(idep,1)*denstest(idep,1) + + if (nmax .gt. 1) then + do n=nind,nmax + if (valtest(idep,n) .lt. wpwet) then + ar3(idep)=ar3(idep)+denstest(idep,n)*dtest(idep,n) + swsrf3(idep)=swsrf3(idep)+valtest(idep,n)* & + denstest(idep,n)*dtest(idep,n) + else + ar2(idep)=ar2(idep)+denstest(idep,n)*dtest(idep,n) + swsrf2(idep)=swsrf2(idep)+valtest(idep,n)* & + denstest(idep,n)*dtest(idep,n) + endif + enddo + endif + + test=ar1(idep)+ar2(idep)+ar3(idep) + if (test .gt. 1.+1.e-5 .or. test .lt. 1.-1.e-5) then + ! write(*,*) 'PROBLEM at depth ',zbar + ! write(*,*) ' ar1+ar2+ar3=',test + ! write(*,*) ' ar1=',ar1(idep),' ar2=',ar2(idep),' ar3=', & + ! ar3(idep) + endif + + ar1(idep)=ar1(idep)/test + ar2(idep)=ar2(idep)/test + ar3(idep)=ar3(idep)/test + if (ar2(idep) .ne. 0.) swsrf2(idep)=swsrf2(idep)/ar2(idep) + if (ar3(idep) .ne. 0.) swsrf3(idep)=swsrf3(idep)/ar3(idep) + + rzeq(idep)=ar1(idep)+ar2(idep)*swsrf2(idep)+ar3(idep)*swsrf3(idep) + + if (bug) write(*,*) 'funcidep: ok6' + + !c 2. Maximum density -> shape parameter + !c -> wmin + + locmax=3 + shift=15 + ordref=1 + do n=1,nmax + densaux2(n)=denstest(idep,n) + enddo + + if (nmax .ge. shift*2) then + + !c we start with sliding mean to facilitate the search for the maximum + + ord=MIN(ordref,nmax/shift) + + call smtot(densaux2,nmax,ord,densaux) + ! print *,nmax,ord,shift,densaux(shift-14),shift-14,size(densaux) + do n=nmax,shift,-1 + if (densaux(n) .gt. densaux(n-1) .and. & + densaux(n) .gt. densaux(n-2) .and. & + densaux(n) .gt. densaux(n-3) .and. & + densaux(n) .gt. densaux(n-4) .and. & + densaux(n) .gt. densaux(n-5) .and. & + densaux(n) .gt. densaux(n-6) .and. & + densaux(n) .gt. densaux(n-7) .and. & + densaux(n) .gt. densaux(n-8) .and. & + densaux(n) .gt. densaux(n-9) .and. & + densaux(n) .gt. densaux(n-10) .and. & + densaux(n) .gt. densaux(n-11) .and. & + densaux(n) .gt. densaux(n-12) .and. & + densaux(n) .gt. densaux(n-13) .and. & + densaux(n) .gt. densaux(n-14))then ! .and. & + ! densaux(n) .gt. densaux(n-15)) then + locmax=n + goto 30 + endif + enddo + + else + + aux10=-9999. + indimax10=3 + do n=1,nmax + if (densaux2(n) .gt. aux10) then + aux10=densaux2(n) + indimax10=n + endif + enddo + locmax=MAX(3,indimax10) + ! add protection here in case nmax <3 . why 3 ? + if (locmax > nmax) locmax = nmax + endif ! if (nmax .ge. shift+1) +30 densmax=denstest(idep,locmax) + aa(idep)=exp(1.)*densmax + + if (bug) write(*,*) 'funcidep: ok7' + + !c WMIN=lowest value where the density is strictly gt densmax/100. + + indmin=1 + indmin0=0 + do n=1,nmax + if (denstest(idep,n) .gt. 0.) indmin0=n + if (denstest(idep,n) .gt. densmax/100. .and. & + valtest(idep,n) .lt. valtest(idep,locmax)) indmin=n + enddo + if (indmin .eq.0) indmin=indmin0 + + if (indmin .le. 2) then + wmin(idep) = 0.99999 + else + x1=valtest(idep,indmin) + wmin(idep)=x1 + endif + + if (bug) write(*,*) 'funcidep: ok8; first wmin=',wmin(idep) + + !c for negative or low coeskew the previous wmin doesn't give good results... + !c wmin is higher !!! + + if (coeskew .lt. 1. ) then + + if (locmax .gt. 3 .and. indmin .ge. locmax+4) then + n2=MAX(locmax+1,(indmin-locmax)/2+locmax) + x2=valtest(idep,n2) + y2=denstest(idep,n2) + n1=locmax + x1=valtest(idep,n1) + y1=denstest(idep,n1) + wa=(y2-y1)/(x2-x1) + wb=y1-wa*x1 + wmin(idep)=AMAX1(wmin(idep),-wb/wa) + endif + + !c wmin is even higher in some cases !!! + if (coeskew .lt. 0.2 ) wmin(idep)=wmin(idep)+0.01 + + endif + + if (bug) write(*,*) 'funcidep: ok9; 2nd wmin=',wmin(idep) + + if (valtest(idep,locmax) .le. wmin(idep)) then ! doesn't make sense + wmin(idep)=valtest(idep,locmax)-dx + endif + aabis(idep)=1./(valtest(idep,locmax)-wmin(idep)+1.e-20) + + if (bug) write(*,*) 'funcidep: ok10' + + END SUBROUTINE FUNCIDEP + + ! ******************************************************************** + + SUBROUTINE FUNCZBAR( & + NAR0,ZBAR, & + BEE,PSIS,POROS,COND,RZDEP,WPWET, & + VALX,PX,COESKEW,TIMEAN,SUMA, & + CATDEF,WMIN) + + !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + !c c + !c This program returns the eight parameters for the areal fractioning c + !c c + !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + + INTEGER , intent (in) :: NAR0 + integer nref,nind,nmax,indmin,locmax,shift,ord,locmin,ordref + integer indimax10,indmin0 + REAL, intent (in) :: BEE, PSIS, POROS, COND, RZDEP, WPWET, COESKEW + REAL, intent (inout) :: VALX(NAR), PX(NAR),TIMEAN,SUMA,zbar + real, intent (inout) :: catdef,wmin + + REAL dx,dz,sumdef + real term1,term2 + real zdep(nar),locdef(nar),wrz(nar),frcunsat + real valtest(nar),ptest(nar),denstest(nar),dtest(nar) + real x1,x2,y1,y2,wa,wb + integer n1,n2,k,n + real densaux(nar),densaux2(nar),densmax,aux10 + + !c------------------------------------------------------------------------- + !c integral(f(x)dx)=1. for a pdf + !c here px=f(x)dx + dx=valx(1)-valx(2) + + !c**** Compute array of water table depths: + do k=1,nar0 + term1=(1/gnu)*(valx(k)-timean) + zdep(k)=AMAX1(0.,zbar-term1) + enddo + + !c variable change must be reflected in dx + dz=dx/gnu + + !c**** Compute array of moisture deficits: + do k=1,nar0 + term1=(psis-zdep(k))/psis + term1=term1**(1.-1./bee) + term2=-psis*(bee/(bee-1.))*(term1-1.) + locdef(k)=zdep(k)-term2 + enddo + + !c**** Add deficits to produce catdef: + sumdef=0. + do k=1,nar0 + sumdef=sumdef+locdef(k)*px(k) + enddo + catdef=poros*1000.*sumdef/suma + + !c**** Compute array of root zone moisture (degree of wetness in root zone): + do k=1,nar0 + term1=((psis-zdep(k))/psis) & + **(1.-1./bee) + if(zdep(k).le.0.) then + wrz(k)=1. + elseif(zdep(k)-rzdep.lt.0.) then + term2=(-psis/zdep(k))*(bee/(bee-1.)) & + *(term1-1.) + frcunsat=zdep(k)/rzdep + wrz(k)=frcunsat*term2+(1.-frcunsat)*1. + else + term2=((psis-zdep(k)+rzdep) & + /psis)**(1.-1./bee) + wrz(k)=(-psis/rzdep)*(bee/ & + (bee-1.))*(term1-term2) + endif + enddo + + !c**** compute the densities and dx + !c**** we use a usefull property that is due to the construction of the + !c**** gamma distribution in tgen3.f : this distribution is continuous, + !c**** with decreasing values on ln(a/tanb) when n goes from 1 to nar0 + !c first we gather in the same bin all the bins with values ge 1 + nref=1 + nind=1 + ptest(1)=0. + do k=1,nar0 + if (wrz(k) .eq. 1.) then + nref=nref+1 + ptest(1) = ptest(1) + px(k) + endif + enddo + if (nref .gt. 1) then + nind=2 + valtest(1)=1. + endif + nmax=nar0-nref+nind + + !c definition of the probabilities ptest + if (nmax .eq. 1) then ! all the bins have values ge 1 + dtest(1) = 0.0001 + ptest(1) = 1. + else ! distribution in ar2/ar3 + do n=0,nmax-nind + valtest(nind+n)=wrz(nref+n) + ptest(nind+n)=px(nref+n) + enddo + + !c we have to define dtest, the size of each bin + if (nmax .eq. 2) then + dtest(2) = valtest(1)-valtest(2) + dtest(1) = dtest(2)/2. + else ! nmax .gt. 2 + do n=2,nmax-1 + dtest(n)=(valtest(n-1)-valtest(n+1))/2. + enddo + dtest(1) = dtest(2)/2. + dtest(nmax) = dtest(nmax-1) + endif + endif + + !c we can now define the probability density: denstest=ptest/dtest + !c where ptest is the probability and dtest the size of the bin + do n=1,nmax + if (ptest(n) .eq. 0.) then + denstest(n)=0. + else + denstest(n)=ptest(n)/dtest(n) + endif + enddo + + !c NOW we can estimate the parameters for the approximated distrib + !c from the actual distrib + + !c 2. Maximum density -> shape parameter + !c -> wmin + + locmax=3 + shift=15 + ordref=1 + do n=1,nmax + densaux2(n)=denstest(n) + enddo + + if (nmax .ge. shift*2) then + + !c we start with sliding mean to facilitate the search for the maximum + + ord=MIN(ordref,nmax/shift) + call smtot(densaux2,nmax,ord,densaux) + + do n=nmax,shift,-1 + if (densaux(n) .gt. densaux(n-1) .and. & + densaux(n) .gt. densaux(n-2) .and. & + densaux(n) .gt. densaux(n-3) .and. & + densaux(n) .gt. densaux(n-4) .and. & + densaux(n) .gt. densaux(n-5) .and. & + densaux(n) .gt. densaux(n-6) .and. & + densaux(n) .gt. densaux(n-7) .and. & + densaux(n) .gt. densaux(n-8) .and. & + densaux(n) .gt. densaux(n-9) .and. & + densaux(n) .gt. densaux(n-10) .and. & + densaux(n) .gt. densaux(n-11) .and. & + densaux(n) .gt. densaux(n-12) .and. & + densaux(n) .gt. densaux(n-13) .and. & + densaux(n) .gt. densaux(n-14)) then ! .and. & + !densaux(n) .gt. densaux(n-15)) then + locmax=n + goto 30 + endif + enddo + + else + + aux10=-9999. + indimax10=3 + do n=1,nmax + if (densaux2(n) .gt. aux10) then + aux10=densaux2(n) + indimax10=n + endif + enddo + locmax=MAX(3,indimax10) + ! in case nmax < 3. why hard coded 3? + if(locmax > nmax) locmax = nmax + endif ! if (nmax .ge. shift+1) + +30 densmax=denstest(locmax) + + !c WMIN=lowest value where the density is strictly gt densmax/100. + + indmin=1 + indmin0=0 + do n=1,nmax + if (denstest(n) .gt. 0.) indmin0=n + if (denstest(n) .gt. densmax/100. .and. & + valtest(n) .lt. valtest(locmax)) indmin=n + enddo + if (indmin .eq. 0) indmin=indmin0 + + if (indmin .le. 2) then + wmin = 0.99999 + else + x1=valtest(indmin) + wmin=x1 + endif + + !c for negative or low coeskew the previous wmin doesn't give good results... + !c wmin is higher !!! + + if (coeskew .lt. 1. ) then + + if (locmax .gt. 3 .and. indmin .ge. locmax+4) then + + n2=MAX(locmax+1,(indmin-locmax)/2+locmax) + x2=valtest(n2) + y2=denstest(n2) + n1=locmax + x1=valtest(n1) + y1=denstest(n1) + wa=(y2-y1)/(x2-x1) + wb=y1-wa*x1 + wmin=AMAX1(wmin,-wb/wa) + endif + + !c wmin is even higher in some cases !!! + if (coeskew .lt. 0.2 ) wmin=wmin+0.01 + + endif + + END SUBROUTINE FUNCZBAR + + ! ****************************************************************** + + SUBROUTINE RMSE(XX,YY,LEN,ERROR) + + !c--------------------------------------------------------------------------- + !c Computes the root-mean square error ERROR between two one-dimensional + !c random variables XX and YY of same length LEN + !c--------------------------------------------------------------------------- + + INTEGER, intent (in) :: LEN + REAL, intent (in) :: XX(LEN),YY(LEN) + REAL, intent (out) :: ERROR + INTEGER :: I + + !c--------------------------------------------------------------------------- + error=0. + do i=1,len + if(abs(xx(i)-yy(i)) >=1.e-10) then + error=error+(xx(i)-yy(i))*(xx(i)-yy(i)) + endif + enddo + error=SQRT(error/float(len)) + + END SUBROUTINE RMSE + + ! ****************************************************************** + + SUBROUTINE SMTOT(XX,LEN,ORD,YY) + + !c--------------------------------------------------------------------------- + !c Runs a sliding average of order ORD through the one-dimensional array XX + !c of length LEN and returns the smoothed YY + !!c--------------------------------------------------------------------------- + + INTEGER, intent(in) :: LEN + + INTEGER :: ORD,WIDTH,i,ini,n,fin ! replaced var name "end" w/ "fin" to fix auto-indent, reichle, 24 Dec 2024 + + REAL, intent(in) :: XX(NAR) + REAL, intent(out) :: YY(NAR) + + !c--------------------------------------------------------------------------- + do i=1,nar + yy(i)=0. + enddo + + width=ord*2+1 + if (width .gt. len/2) then + write(*,*) 'the order for the sliding average is too large !!!' + write(*,*) 'regard with the length of the array to be smoothed' + stop + endif + + do i=1,len + ini=MAX(1,i-ord) + fin=MIN(len,i+ord) + yy(i)=0. + do n=ini,fin + yy(i)=yy(i)+xx(n) + enddo + yy(i)=yy(i)/(fin-ini+1) + enddo + + END SUBROUTINE SMTOT + + ! ----------------------------------------------------------------------------------- + + subroutine RegridRaster(Rin,Rout) + + ! primitive regridding of integer values from 2-dim array Rin to 2-dim array Rout + ! + ! If Rout is higher-resolution than Rin, result should be fine: + ! An Rout grid cell is assigned the value of the Rin grid cell that + ! contains the center of the Rout grid cell (oversampling). + ! If Rin is higher-resolution than Rout, result is questionable: + ! An Rout grid cell is assigned the value of the Rin grid cell that is + ! near the *corner* of the Rout grid cell. See notes below. + + integer, intent(IN) :: Rin( :,:) + integer, intent(OUT) :: Rout(:,:) + + REAL(REAL64) :: xx, yy + integer :: i, j, ii, jj + integer :: Nx_in, Ny_in, Nx_out, Ny_out + + Nx_in = size(Rin ,1) + Ny_in = size(Rin ,2) + + Nx_out = size(Rout,1) + Ny_out = size(Rout,2) + + !if ( (Nx_in==Nx_out) .and. (Ny_in==Ny_out) ) then + if (.false.) then + + ! avoid loop through output grid cells + + Rout = Rin ! [??] MAY NOT BE 0-DIFF B/C OF MIXED-MODE ARITHMETIC IN LOOP!?!?!? + + else + + ! NOTE: float() yields real*4 but xx was declared real*8 + + xx = Nx_in/float(Nx_out) ! WARNING: mixed mode arithmentic!!! + yy = Ny_in/float(Ny_out) ! WARNING: mixed mode arithmentic!!! + + do j=1,Ny_out + + ! NOTE: When Rin is finer resolution than Rout, the below use of + ! ii = (i-1)*xx + 1 (1a) + ! jj = (j-1)*yy + 1 (1b) + ! implies that Rout(i,j) is assigned the Rin(ii,jj) value near a corner of + ! the (ii,jj) output grid cell, which effectively results in a shift of the + ! data by 1/2 of the width of the output grid cell. This shift could + ! presumably minimized by using + ! ii = NINT( (i-1)*xx + xx/2 ) (2a) + ! jj = NINT( (j-1)*yy + yy/2 ) (2b) + ! + ! HOWEVER, equations (2a) and (2b) are preferable when Rout is finer resolution + ! than Rin, in which case Rout should just be oversampling of Rin. + + jj = (j-1)*yy + 1 ! WARNING: mixed mode arithmetic!!! Note implied "floor()" operator. + do i=1,Nx_out + ii = (i-1)*xx + 1 ! WARNING: mixed mode arithmetic!!! Note implied "floor()" operator. + Rout(i,j) = Rin(ii,jj) + end do + end do + + end if + + end subroutine RegridRaster + + ! ----------------------------------------------------------------------------------- + + subroutine RegridRaster1(Rin,Rout) + + ! same as RegridRaster() but for gridded integer*1 values + + integer*1, intent(IN) :: Rin( :,:) + integer*1, intent(OUT) :: Rout(:,:) + + REAL(REAL64) :: xx, yy + integer :: i, j, ii, jj + integer :: Nx_in, Ny_in, Nx_out, Ny_out + + Nx_in = size(Rin ,1) + Ny_in = size(Rin ,2) + + Nx_out = size(Rout,1) + Ny_out = size(Rout,2) + + !if ( (Nx_in==Nx_out) .and. (Ny_in==Ny_out) ) then + if (.false.) then + + Rout = Rin - ! read cti_stats.dat + else - read(11,'(i10,i8,5(1x,f8.4))') tindex1,pfaf1,meanlu,stdev & - ,minlu,maxlu,coesk - - ! read soil_param.first - ! - ! WARNING: Immediately after the present do loop, BEE, COND, POROS, PSIS, WPWET, and - ! soildepth will be read again (and thus overwritten) with the values from - ! the catch_params.nc4 file. It is unclear if the values in soil_param.first - ! and catch_params.nc4 differ. See comments below. - - read(10,'(i10,i8,i4,i4,3f8.4,f12.8,f7.4,f10.4,3f7.3,4f7.3,2f10.4)') & - tindex2(n),pfaf2(n),soil_class_top(n),soil_class_com(n), & - BEE(n), PSIS(n),POROS(n),COND(n),WPWET(n),soildepth(n), & - grav_vec(n),soc_vec(n),poc_vec(n), & - a_sand_surf(n),a_clay_surf(n),atile_sand(n),atile_clay(n) - if(tindex1.ne.tindex2(n))then - write(*,*)'Warnning 1: tindex mismatched' - stop - endif - - ! read catchment.def - - read (12,*) tindex1,pfaf1,minlon,maxlon,minlat,maxlat - tile_lon(n) = (minlon + maxlon)/2. - tile_lat(n) = (minlat + maxlat)/2. - - if(pfaf1.ne.pfaf2(n)) then - write(*,*)'Warnning 1: pfafstetter mismatched' - stop - endif - if((use_PEATMAP).and.(soil_class_top(n) == 253)) then - meanlu = 9.3 - stdev = 0.12 - minlu = 8.5 - maxlu = 11.5 - coesk = 0.25 - endif - - if (index(MaskFile,'GEOS5_10arcsec_mask') /= 0) then - TOPMEAN(n) = meanlu - else - TOPMEAN(n) = 0.961*meanlu-1.957 - endif - - TOPVAR(n) = stdev*stdev - TOPSKEW(n) = coesk*stdev*stdev*stdev - - if ( TOPVAR(n) .eq. 0. .or. coesk .eq. 0. & - .or. topskew(n) .eq. 0.) then - write(*,*) 'Problem: undefined values:' - write(*,*) TOPMEAN(n),TOPVAR(n),coesk, & - minlu,maxlu - stop - endif - END DO ! n=1,nbcatch - - inquire(file='clsm/catch_params.nc4', exist=file_exists) - - if(file_exists) then - - ! Read BEE, COND, POROS, PSIS, WPWET, and soildepth from nc4 file. - ! It is unclear if parameters in nc4 file differ from those in soil_param.first, which were read - ! in the do loop just above. - ! Probably, the parameters differ by roundoff because soil_param.first is an ASCII file and - ! catch_params.nc4 is a netcdf file. Consequently, the parameters from the nc4 file are used - ! in the calculation of the ar.new, bf.dat, and ts.dat parameters, which comes next. - ! To maintain consistency between the parameters in soil_param.first and soil_param.dat where - ! no changes are needed, soil_param.first needs to be read again below (so as to overwrite - ! the values from the nc4 file). - ! Why the parameters from the nc4 file are read here in the first place remains a mystery. - ! Removing this read, however, will (almost certainly) result in non-zero-diff changes - ! for existing bcs datasets. - ! - reichle, 28 April 2022 - - status = NF_OPEN ('clsm/catch_params.nc4', NF_WRITE, ncid) ; VERIFY_(STATUS) - allocate (parms4file (1:nbcatch, 1:25)) - status = NF_GET_VARA_REAL(NCID,NC_VarID(NCID,'BEE' ) ,(/1/),(/nbcatch/), BEE (:)) ; VERIFY_(STATUS) - status = NF_GET_VARA_REAL(NCID,NC_VarID(NCID,'COND' ) ,(/1/),(/nbcatch/), COND (:)) ; VERIFY_(STATUS) - status = NF_GET_VARA_REAL(NCID,NC_VarID(NCID,'POROS') ,(/1/),(/nbcatch/), POROS(:)) ; VERIFY_(STATUS) - status = NF_GET_VARA_REAL(NCID,NC_VarID(NCID,'PSIS' ) ,(/1/),(/nbcatch/), PSIS (:)) ; VERIFY_(STATUS) - status = NF_GET_VARA_REAL(NCID,NC_VarID(NCID,'WPWET') ,(/1/),(/nbcatch/), WPWET(:)) ; VERIFY_(STATUS) - status = NF_GET_VARA_REAL(NCID,NC_VarID(NCID,'DP2BR') ,(/1/),(/nbcatch/), soildepth (:)) ; VERIFY_(STATUS) - parms4file (:,12) = BEE (:) - parms4file (:,16) = COND (:) - parms4file (:,18) = POROS (:) - parms4file (:,19) = PSIS (:) - parms4file (:,24) = wpwet (:) - parms4file (:,25) = soildepth(:) - endif - - rewind(10) ! soil_param.first (so soil_param.first can be read again below...) - - allocate(low_ind(n_threads)) - allocate(upp_ind(n_threads)) - low_ind(1) = 1 - upp_ind(n_threads) = nbcatch - - if (running_omp) then - do i=1,n_threads-1 - - upp_ind(i) = low_ind(i) + (nbcatch/n_threads) - 1 - low_ind(i+1) = upp_ind(i) + 1 - - end do - end if + xx = Nx_in/float(Nx_out) + yy = Ny_in/float(Ny_out) + do j=1,Ny_out + jj = (j-1)*yy + 1 + do i=1,Nx_out + ii = (i-1)*xx + 1 + Rout(i,j) = Rin(ii,jj) + end do + end do -!$OMP PARALLELDO DEFAULT(NONE) & -!$OMP SHARED( BEE, PSIS,POROS,COND,WPWET,soildepth, & -!$OMP TOPMEAN, TOPVAR, TOPSKEW, & -!$OMP ARS1,ARS2,ARS3, ARA1,ARA2,ARA3,ARA4, & -!$OMP ARW1,ARW2,ARW3,ARW4,bf1, bf2, bf3, & -!$OMP tsa1, tsa2,tsb1, tsb2, & -!$OMP taberr1,taberr2,normerr1,normerr2, & -!$OMP taberr3,taberr4,normerr3,normerr4, & -!$OMP gwatdep,gwan,grzexcn,gfrc,soil_class_com, & -!$OMP n_threads, low_ind, upp_ind, use_PEATMAP ) & -!$OMP PRIVATE(k,li,ui,n,i,watdep,wan,rzexcn,frc,ST,AC, & -!$OMP COESKEW,profdep) + end if - do k=1,n_threads + end subroutine RegridRaster1 - li = low_ind(k) - ui = upp_ind(k) + ! ----------------------------------------------------------------------------------- - do n=li,ui + subroutine RegridRaster2(Rin,Rout) - CALL TGEN ( & - TOPMEAN(n),TOPVAR(n),TOPSKEW(n), & - ST,AC,COESKEW) - - ! compute areal fractioning parameters (ar.new) - - CALL SAT_PARAM( & - BEE(n),PSIS(n),POROS(n),COND(n), & - WPWET(n), ST, AC, COESKEW,n, & - soildepth(n), & - ars1(n),ars2(n),ars3(n), & - ara1(n),ara2(n),ara3(n),ara4(n), & - arw1(n),arw2(n),arw3(n),arw4(n), & - taberr1(n),taberr2(n),taberr3(n),taberr4(n), & - normerr1(n),normerr2(n),normerr3(n),normerr4(n)) - - ! compute base flow parameters (bf.dat) - - CALL BASE_PARAM( & - BEE(n),PSIS(n),POROS(n),COND(n), & - ST, AC, & - bf1(n),bf2(n),bf3(n), & - taberr1(n),taberr2(n),normerr1(n),normerr2(n) & - ) - - - watdep (:,:) = gwatdep (:,:,soil_class_com(n)) - wan (:,:) = gwan (:,:,soil_class_com(n)) - rzexcn (:,:) = grzexcn (:,:,soil_class_com(n)) - frc (:,:) = gfrc (:,:,soil_class_com(n)) - - ! compute time scale parameters (rzexc-catdef) (ts.dat) - - CALL TS_PARAM( & - BEE(n),PSIS(n),POROS(n), & - ST, AC, & - watdep,wan,rzexcn,frc, & - tsa1(n),tsa2(n),tsb1(n),tsb2(n) & - ) - - if(soil_class_com(n) == 253 .and. use_PEATMAP) then - - ! Michel Bechtold paper - PEATCLSM_fitting_CLSM_params.R produced these data values. - - ars1(n) = -7.9514018e-03 - ars2(n) = 6.2297356e-02 - ars3(n) = 1.9187240e-03 - ara1(n) = 8.9551220e+00 - ara2(n) = 9.8149664e+02 - ara3(n) = 8.9551220e+00 - ara4(n) = 9.8149664e+02 - arw1(n) = 9.9466055e-03 - arw2(n) = 1.0881960e-02 - arw3(n) = 1.5309287e-05 - arw4(n) = 1.0000000e-04 - - bf1(n) = 4.6088086e+02 - bf2(n) = 1.4237401e-01 - bf3(n) = 6.9803000e+00 - - tsa1(n) = -2.417581e+00 - tsa2(n) = -4.784762e+00 - tsb1(n) = -3.700285e-03 - tsb2(n) = -2.392484e-03 - - endif - END DO - END DO - !$OMP ENDPARALLELDO - -! This code block is obsolete because it was only needed if preserve_soiltype==.true, but -! preserve_soiltype was hardwired to .false. above. -! -reichle, 28 April 2022 -! -!obsolete20220428 CF1 =0 -!obsolete20220428 CF2 =0 -!obsolete20220428 CF3 =0 -!obsolete20220428 CF4 =0 -!obsolete20220428 -!obsolete20220428 DO n=1,nbcatch -!obsolete20220428 -!obsolete20220428 if((ars1(n).ne.9999.).and.(arw1(n).ne.9999.))then -!obsolete20220428 -!obsolete20220428 ! determine organic carbon class ("group") from soil class -!obsolete20220428 -!obsolete20220428 if ((soil_class_com(n)>=1).and.(soil_class_com(n)<=84)) then -!obsolete20220428 group=1 -!obsolete20220428 else if ((soil_class_com(n) > 84).and.(soil_class_com(n)<=168)) then -!obsolete20220428 group=2 -!obsolete20220428 else if ((soil_class_com(n) >168).and.(soil_class_com(n)< N_SoilClasses)) then -!obsolete20220428 group=3 -!obsolete20220428 else -!obsolete20220428 group=4 ! peat -!obsolete20220428 endif -!obsolete20220428 -!obsolete20220428 ! assemble scalar structure that holds mineral percentages of tile n -!obsolete20220428 -!obsolete20220428 min_percs%clay_perc = atile_clay(n) -!obsolete20220428 min_percs%sand_perc = atile_sand(n) -!obsolete20220428 min_percs%silt_perc = 100. - min_percs%clay_perc - min_percs%sand_perc -!obsolete20220428 -!obsolete20220428 ! "soil_class" is an integer function (defined below) that assigns -!obsolete20220428 ! an integer soil class [1-100] for a given mineral percentage triplet -!obsolete20220428 -!obsolete20220428 ! "tile_pick" contains the number (ID) n of a sample tile for each -!obsolete20220428 ! soil class -!obsolete20220428 -!obsolete20220428 if(tile_pick(soil_class (min_percs),group) == 0) then -!obsolete20220428 -!obsolete20220428 ! assign tile n as the sample tile for its soil class in "tile_pick" -!obsolete20220428 -!obsolete20220428 tile_pick(soil_class (min_percs),group) = n -!obsolete20220428 -!obsolete20220428 ! Assign sand/clay from tile n to "good_clay" and "good_sand" for its class???? -!obsolete20220428 ! Why is "good_sand" dimension (100,4) when CF[x] seems to count the -!obsolete20220428 ! number of tiles within each organic carbon subclass ("group")?? -!obsolete20220428 -!obsolete20220428 select case (group) -!obsolete20220428 -!obsolete20220428 case (1) -!obsolete20220428 -!obsolete20220428 CF1 = CF1 + 1 -!obsolete20220428 good_clay (CF1,group) = atile_clay(n) -!obsolete20220428 good_sand (CF1,group) = atile_sand(n) -!obsolete20220428 tile_add (CF1,group) = n -!obsolete20220428 -!obsolete20220428 case (2) -!obsolete20220428 CF2 = CF2 + 1 -!obsolete20220428 good_clay (CF2,group) = atile_clay(n) -!obsolete20220428 good_sand (CF2,group) = atile_sand(n) -!obsolete20220428 tile_add (CF2,group) = n -!obsolete20220428 -!obsolete20220428 case (3) -!obsolete20220428 CF3 = CF3 + 1 -!obsolete20220428 good_clay (CF3,group) = atile_clay(n) -!obsolete20220428 good_sand (CF3,group) = atile_sand(n) -!obsolete20220428 tile_add (CF3,group) = n -!obsolete20220428 -!obsolete20220428 case (4) -!obsolete20220428 CF4 = CF4 + 1 -!obsolete20220428 good_clay (CF4,group) = atile_clay(n) -!obsolete20220428 good_sand (CF4,group) = atile_sand(n) -!obsolete20220428 tile_add (CF4,group) = n -!obsolete20220428 -!obsolete20220428 end select -!obsolete20220428 endif -!obsolete20220428 -!obsolete20220428 endif ! (ars1(n).ne.9999.).and.(arw1(n).ne.9999.) -!obsolete20220428 -!obsolete20220428 END DO ! n=1,nbcatch - - ! ---------------------------------------------------------------------------------------- - ! - ! write ar.new, bf.dat, ts.dat, and soil_param.dat - - DO n=1,nbcatch - - ! Read soil_param.first again...; this is (almost certainly) needed to maintain consistency - ! between soil_param.first and soil_param.dat, see comments above. - - read(10,'(i10,i8,i4,i4,3f8.4,f12.8,f7.4,f10.4,3f7.3,4f7.3,2f10.4, f8.4)') & - tindex2(n),pfaf2(n),soil_class_top(n),soil_class_com(n), & - BEE(n), PSIS(n),POROS(n),COND(n),WPWET(n),soildepth(n), & - grav_vec(n),soc_vec(n),poc_vec(n), & - a_sand_surf(n),a_clay_surf(n),atile_sand(n),atile_clay(n) , & - wpwet_surf(n),poros_surf(n), pmap(n) + ! same as RegridRaster() but for gridded integer*2 values + integer(kind=2), intent(IN) :: Rin( :,:) + integer(kind=2), intent(OUT) :: Rout(:,:) -! This code block was obsolete because only one set of write statements is needed/desired. -! Repeating near-verbatim copies of write statements was bad coding practice. -! - reichle, 28 April 2022 -! -!obsolete20220428 if((ars1(n).ne.9999.).and.(arw1(n).ne.9999.))then -!obsolete20220428 -!obsolete20220428 ! nominal case, all parameter values are good -!obsolete20220428 -!obsolete20220428 ! write ar.new -!obsolete20220428 -!obsolete20220428 write(20,'(i10,i8,f5.2,11(2x,e14.7))') & -!obsolete20220428 tindex2(n),pfaf2(n),gnu, & -!obsolete20220428 ars1(n),ars2(n),ars3(n), & -!obsolete20220428 ara1(n),ara2(n),ara3(n),ara4(n), & -!obsolete20220428 arw1(n),arw2(n),arw3(n),arw4(n) -!obsolete20220428 -!obsolete20220428 ! write bf.dat -!obsolete20220428 -!obsolete20220428 write(30,'(i10,i8,f5.2,3(2x,e13.7))')tindex2(n),pfaf2(n),gnu,bf1(n),bf2(n),bf3(n) -!obsolete20220428 -!obsolete20220428 ! write ts.dat -!obsolete20220428 -!obsolete20220428 write(40,'(i10,i8,f5.2,4(2x,e13.7))')tindex2(n),pfaf2(n),gnu, & -!obsolete20220428 tsa1(n),tsa2(n),tsb1(n),tsb2(n) -!obsolete20220428 -!obsolete20220428 ! write soil_param.dat -!obsolete20220428 -!obsolete20220428 write(42,'(i10,i8,i4,i4,3f8.4,f12.8,f7.4,f10.4,3f7.3,4f7.3,2f10.4, f8.4)') & -!obsolete20220428 tindex2(n),pfaf2(n),soil_class_top(n),soil_class_com(n), & -!obsolete20220428 BEE(n), PSIS(n),POROS(n),COND(n),WPWET(n),soildepth(n), & -!obsolete20220428 grav_vec(n),soc_vec(n),poc_vec(n), & -!obsolete20220428 a_sand_surf(n),a_clay_surf(n),atile_sand(n),atile_clay(n), & -!obsolete20220428 wpwet_surf(n),poros_surf(n), pmap(n) -!obsolete20220428 -!obsolete20220428 if (allocated (parms4file)) then -!obsolete20220428 parms4file (n, 1) = ara1(n) -!obsolete20220428 parms4file (n, 2) = ara2(n) -!obsolete20220428 parms4file (n, 3) = ara3(n) -!obsolete20220428 parms4file (n, 4) = ara4(n) -!obsolete20220428 parms4file (n, 5) = ars1(n) -!obsolete20220428 parms4file (n, 6) = ars2(n) -!obsolete20220428 parms4file (n, 7) = ars3(n) -!obsolete20220428 parms4file (n, 8) = arw1(n) -!obsolete20220428 parms4file (n, 9) = arw2(n) -!obsolete20220428 parms4file (n,10) = arw3(n) -!obsolete20220428 parms4file (n,11) = arw4(n) -!obsolete20220428 parms4file (n,13) = bf1(n) -!obsolete20220428 parms4file (n,14) = bf2(n) -!obsolete20220428 parms4file (n,15) = bf3(n) -!obsolete20220428 parms4file (n,17) = gnu -!obsolete20220428 parms4file (n,20) = tsa1(n) -!obsolete20220428 parms4file (n,21) = tsa2(n) -!obsolete20220428 parms4file (n,22) = tsb1(n) -!obsolete20220428 parms4file (n,23) = tsb2(n) -!obsolete20220428 endif - - -! This code block is obsolete because it was only needed if preserve_soiltype==.true, but -! preserve_soiltype was hardwired to .false. above. -! -reichle, 28 April 2022 -! -!obsolete20220428 else ! (ars1(n).ne.9999.) .or. (arw1(n)==9999.) -!obsolete20220428 -!obsolete20220428 ! exception, some parameter values are no-data -!obsolete20220428 -!obsolete20220428 if(preserve_soiltype) then -!obsolete20220428 -!obsolete20220428 ! look for a tile with a similar soil class -!obsolete20220428 -!obsolete20220428 ! NOTE: preserve_soiltype=.false. hardwired as of 28 Apr 2022 -!obsolete20220428 -!obsolete20220428 if ((soil_class_com(n)>=1).and.(soil_class_com(n)<=84)) then -!obsolete20220428 group=1 -!obsolete20220428 else if ((soil_class_com(n)> 84).and.(soil_class_com(n)<=168)) then -!obsolete20220428 group=2 -!obsolete20220428 else if ((soil_class_com(n)> 168).and.(soil_class_com(n)< N_SoilClasses)) then -!obsolete20220428 group=3 -!obsolete20220428 else -!obsolete20220428 group=4 -!obsolete20220428 endif -!obsolete20220428 -!obsolete20220428 min_percs%clay_perc = atile_clay(n) -!obsolete20220428 min_percs%sand_perc = atile_sand(n) -!obsolete20220428 min_percs%silt_perc = 100. - min_percs%clay_perc - min_percs%sand_perc -!obsolete20220428 -!obsolete20220428 if(tile_pick(soil_class (min_percs),group) > 0) then -!obsolete20220428 -!obsolete20220428 k = tile_pick(soil_class (min_percs),group) -!obsolete20220428 -!obsolete20220428 else -!obsolete20220428 -!obsolete20220428 select case (group) -!obsolete20220428 -!obsolete20220428 case (1) -!obsolete20220428 j = center_pix (good_clay(1:CF1,group),good_sand(1:CF1,group), & -!obsolete20220428 min_percs%clay_perc,min_percs%sand_perc,min_percs%silt_perc,.true.) -!obsolete20220428 k = tile_add (j,group) -!obsolete20220428 case (2) -!obsolete20220428 j = center_pix (good_clay(1:CF2,group),good_sand(1:CF2,group), & -!obsolete20220428 min_percs%clay_perc,min_percs%sand_perc,min_percs%silt_perc,.true.) -!obsolete20220428 k = tile_add (j,group) -!obsolete20220428 case (3) -!obsolete20220428 j = center_pix (good_clay(1:CF3,group),good_sand(1:CF3,group), & -!obsolete20220428 min_percs%clay_perc,min_percs%sand_perc,min_percs%silt_perc,.true.) -!obsolete20220428 k = tile_add (j,group) -!obsolete20220428 case (4) -!obsolete20220428 j = center_pix (good_clay(1:CF4,group),good_sand(1:CF4,group), & -!obsolete20220428 min_percs%clay_perc,min_percs%sand_perc,min_percs%silt_perc,.true.) -!obsolete20220428 k = tile_add (j,group) -!obsolete20220428 end select -!obsolete20220428 print *,'NO Similar SoilClass :',soil_class (min_percs),group,n,k -!obsolete20220428 -!obsolete20220428 endif -!obsolete20220428 -!obsolete20220428 if (error_file) then -!obsolete20220428 ! record in file clsm/bad_sat_param.tiles -!obsolete20220428 write (41,*)n,k ! n="bad" tile, k=tile from which parameters are taken -!obsolete20220428 -!obsolete20220428 ! write (41,*)tindex2(n),pfaf2(n),soil_class_top(n),soil_class_com(n), & -!obsolete20220428 ! BEE(n), PSIS(n),POROS(n),COND(n),WPWET(n),soildepth(n) -!obsolete20220428 ! write (41,*)tindex2(k),pfaf2(k),soil_class_top,soil_class_com(k), & -!obsolete20220428 ! BEE(k), PSIS(k),POROS(k),COND(k),WPWET(k),soildepth(k) -!obsolete20220428 endif -!obsolete20220428 -!obsolete20220428 -!obsolete20220428 ! write ar.new, bf.dat, ts.dat, and soil_param.dat -!obsolete20220428 -!obsolete20220428 write(20,'(i10,i8,f5.2,11(2x,e14.7))') & -!obsolete20220428 tindex2(n),pfaf2(n),gnu, & -!obsolete20220428 ars1(k),ars2(k),ars3(k), & -!obsolete20220428 ara1(k),ara2(k),ara3(k),ara4(k), & -!obsolete20220428 arw1(k),arw2(k),arw3(k),arw4(k) -!obsolete20220428 write(30,'(i10,i8,f5.2,3(2x,e13.7))')tindex2(n),pfaf2(n),gnu,bf1(k),bf2(k),bf3(k) -!obsolete20220428 write(40,'(i10,i8,f5.2,4(2x,e13.7))')tindex2(n),pfaf2(n),gnu, & -!obsolete20220428 tsa1(k),tsa2(k),tsb1(k),tsb2(k) -!obsolete20220428 -!obsolete20220428 write(42,'(i10,i8,i4,i4,3f8.4,f12.8,f7.4,f10.4,3f7.3,4f7.3,2f10.4, f8.4)') & -!obsolete20220428 tindex2(n),pfaf2(n),soil_class_top(k),soil_class_com(k), & -!obsolete20220428 BEE(k), PSIS(k),POROS(k),COND(k),WPWET(k),soildepth(k), & -!obsolete20220428 grav_vec(k),soc_vec(k),poc_vec(k), & -!obsolete20220428 a_sand_surf(k),a_clay_surf(k),atile_sand(k),atile_clay(k) , & -!obsolete20220428 wpwet_surf(k),poros_surf(k), pmap (k) -!obsolete20220428 -!obsolete20220428 if (allocated (parms4file)) then -!obsolete20220428 parms4file (n, 1) = ara1(k) -!obsolete20220428 parms4file (n, 2) = ara2(k) -!obsolete20220428 parms4file (n, 3) = ara3(k) -!obsolete20220428 parms4file (n, 4) = ara4(k) -!obsolete20220428 parms4file (n, 5) = ars1(k) -!obsolete20220428 parms4file (n, 6) = ars2(k) -!obsolete20220428 parms4file (n, 7) = ars3(k) -!obsolete20220428 parms4file (n, 8) = arw1(k) -!obsolete20220428 parms4file (n, 9) = arw2(k) -!obsolete20220428 parms4file (n,10) = arw3(k) -!obsolete20220428 parms4file (n,11) = arw4(k) -!obsolete20220428 parms4file (n,12) = BEE(k) -!obsolete20220428 parms4file (n,13) = bf1(k) -!obsolete20220428 parms4file (n,14) = bf2(k) -!obsolete20220428 parms4file (n,15) = bf3(k) -!obsolete20220428 parms4file (n,16) = COND(k) -!obsolete20220428 parms4file (n,17) = gnu -!obsolete20220428 parms4file (n,18) = POROS(k) -!obsolete20220428 parms4file (n,19) = PSIS(k) -!obsolete20220428 parms4file (n,20) = tsa1(k) -!obsolete20220428 parms4file (n,21) = tsa2(k) -!obsolete20220428 parms4file (n,22) = tsb1(k) -!obsolete20220428 parms4file (n,23) = tsb2(k) -!obsolete20220428 parms4file (n,24) = wpwet (k) -!obsolete20220428 parms4file (n,25) = soildepth(k) -!obsolete20220428 endif -!obsolete20220428 -!obsolete20220428 else ! .not. preserve_soiltype - - - ! This revised if block replaces the complex, nested if block commented out above - - if ( (ars1(n)==9999.) .or. (arw1(n)==9999.) ) then - - ! some parameter values are no-data --> find nearest tile k with good parameters - - dist_save = 1000000. - k = 0 - do i = 1,nbcatch - if(i /= n) then - if((ars1(i).ne.9999.).and.(arw1(i).ne.9999.)) then - - tile_distance = (tile_lon(i) - tile_lon(n)) * (tile_lon(i) - tile_lon(n)) + & - (tile_lat(i) - tile_lat(n)) * (tile_lat(i) - tile_lat(n)) - if(tile_distance < dist_save) then - k = i - dist_save = tile_distance - endif - endif - endif - enddo - ! record in file clsm/bad_sat_param.tiles - write (41,*)n,k ! n="bad" tile, k=tile from which parameters are taken - - ! Overwrite parms4file when filling in parameters from neighboring tile k. - ! For "good" tiles, keep parms4file as read earlier from catch_params.nc4, - ! which is why this must be done within the "then" block of the "if" statement. - ! This is necessary for backward 0-diff compatibility of catch_params.nc4. - - parms4file (n,12) = BEE(k) - parms4file (n,16) = COND(k) - parms4file (n,18) = POROS(k) - parms4file (n,19) = PSIS(k) - parms4file (n,24) = wpwet(k) - parms4file (n,25) = soildepth(k) - - else - - ! nominal case, all parameters are good - - k = n - - end if - - ! for current tile n, write parameters of tile k into ar.new (20), bf.dat (30), ts.dat (40), - ! and soil_param.dat (42) - - write(20,'(i10,i8,f5.2,11(2x,e14.7))') & - tindex2(n),pfaf2(n),gnu, & - ars1(k),ars2(k),ars3(k), & - ara1(k),ara2(k),ara3(k),ara4(k), & - arw1(k),arw2(k),arw3(k),arw4(k) - - write(30,'(i10,i8,f5.2,3(2x,e13.7))')tindex2(n),pfaf2(n),gnu,bf1(k),bf2(k),bf3(k) - - write(40,'(i10,i8,f5.2,4(2x,e13.7))')tindex2(n),pfaf2(n),gnu, & - tsa1(k),tsa2(k),tsb1(k),tsb2(k) - - write(42,'(i10,i8,i4,i4,3f8.4,f12.8,f7.4,f10.4,3f7.3,4f7.3,2f10.4, f8.4)') & - tindex2(n),pfaf2(n),soil_class_top(k),soil_class_com(k), & - BEE(k), PSIS(k),POROS(k),COND(k),WPWET(k),soildepth(k), & - grav_vec(k),soc_vec(k),poc_vec(k), & - a_sand_surf(k),a_clay_surf(k),atile_sand(k),atile_clay(k) , & - wpwet_surf(k),poros_surf(k), pmap(k) - - ! record ar.new, bf.dat, and ts.dat parameters for later writing into catch_params.nc4 - - if (allocated (parms4file)) then - parms4file (n, 1) = ara1(k) - parms4file (n, 2) = ara2(k) - parms4file (n, 3) = ara3(k) - parms4file (n, 4) = ara4(k) - parms4file (n, 5) = ars1(k) - parms4file (n, 6) = ars2(k) - parms4file (n, 7) = ars3(k) - parms4file (n, 8) = arw1(k) - parms4file (n, 9) = arw2(k) - parms4file (n,10) = arw3(k) - parms4file (n,11) = arw4(k) - parms4file (n,13) = bf1(k) - parms4file (n,14) = bf2(k) - parms4file (n,15) = bf3(k) - parms4file (n,17) = gnu - parms4file (n,20) = tsa1(k) - parms4file (n,21) = tsa2(k) - parms4file (n,22) = tsb1(k) - parms4file (n,23) = tsb2(k) - endif - -!obsolete20220428 endif ! if (preserve_soiltype) then -!obsolete20220428 -!obsolete20220428 endif ! if((ars1(n).ne.9999.).and.(arw1(n).ne.9999.))then - - if (error_file) then - write(21,*)tindex2(n),pfaf2(n),taberr1(n),taberr2(n),taberr3(n),taberr4(n), & - normerr1(n),normerr2(n),normerr3(n),normerr4(n) - write(31,*)tindex2(n),pfaf2(n),taberr1(n),taberr2(n),normerr1(n),normerr2(n) - endif - - END DO ! n=1,nbcatch - -! Write(*,*) 'END COMPUTING MODEL PARA' - - close(10,status='keep') - close(11,status='keep') - close(12,status='keep') - close(20,status='keep') - close(30,status='keep') - close(40,status='keep') - close(42,status='keep') - - - if (error_file) then - close(21,status='delete') - close(31,status='delete') - close(41,status='keep') - endif - - if(file_exists) then - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARA1' ) ,(/1/),(/nbcatch/), parms4file (:, 1)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARA2' ) ,(/1/),(/nbcatch/), parms4file (:, 2)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARA3' ) ,(/1/),(/nbcatch/), parms4file (:, 3)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARA4' ) ,(/1/),(/nbcatch/), parms4file (:, 4)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARS1' ) ,(/1/),(/nbcatch/), parms4file (:, 5)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARS2' ) ,(/1/),(/nbcatch/), parms4file (:, 6)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARS3' ) ,(/1/),(/nbcatch/), parms4file (:, 7)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARW1' ) ,(/1/),(/nbcatch/), parms4file (:, 8)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARW2' ) ,(/1/),(/nbcatch/), parms4file (:, 9)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARW3' ) ,(/1/),(/nbcatch/), parms4file (:,10)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARW4' ) ,(/1/),(/nbcatch/), parms4file (:,11)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'BEE' ) ,(/1/),(/nbcatch/), parms4file (:,12)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'BF1' ) ,(/1/),(/nbcatch/), parms4file (:,13)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'BF2' ) ,(/1/),(/nbcatch/), parms4file (:,14)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'BF3' ) ,(/1/),(/nbcatch/), parms4file (:,15)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'COND' ) ,(/1/),(/nbcatch/), parms4file (:,16)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'GNU' ) ,(/1/),(/nbcatch/), parms4file (:,17)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'POROS') ,(/1/),(/nbcatch/), parms4file (:,18)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'PSIS' ) ,(/1/),(/nbcatch/), parms4file (:,19)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'TSA1' ) ,(/1/),(/nbcatch/), parms4file (:,20)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'TSA2' ) ,(/1/),(/nbcatch/), parms4file (:,21)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'TSB1' ) ,(/1/),(/nbcatch/), parms4file (:,22)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'TSB2' ) ,(/1/),(/nbcatch/), parms4file (:,23)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'WPWET') ,(/1/),(/nbcatch/), parms4file (:,24)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'DP2BR') ,(/1/),(/nbcatch/), parms4file (:,25)) ; VERIFY_(STATUS) - STATUS = NF_CLOSE (NCID) ; VERIFY_(STATUS) - DEALLOCATE (parms4file) - endif + REAL(REAL64) :: xx, yy + integer :: i, j, ii, jj + integer :: Nx_in, Ny_in, Nx_out, Ny_out - END SUBROUTINE create_model_para_woesten + Nx_in = size(Rin ,1) + Ny_in = size(Rin ,2) + Nx_out = size(Rout,1) + Ny_out = size(Rout,2) -!--------------------------------------------------------------------- - - SUBROUTINE TS_PARAM( & - BEE,PSIS,POROS, & - VALX, PX, & - watdep,wan,rzexcn,frc, & - tsa1,tsa2,tsb1,tsb2 & - ) - -!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -!c c -!c Given pre-computed 1-D relationships between a "local" root zone excess c -!c and a "local" catchment deficit, the timescale of the bulk vertical c -!c transfer between the two bulk prognostic variables is computed using c -!c the distribution of the local deficit established from the distribution c -!c of the topographic index, then an approximated function of catdef and c -!c rzex is derived. c -!c c -!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - - INTEGER NAR0 - REAL, intent (in) :: BEE, PSIS, POROS - REAL, intent (in) :: VALX(NAR), PX(NAR) - real, intent (inout) :: watdep(nwt,nrz),wan(nwt,nrz), & - rzexcn(nwt,nrz),frc(nwt,nrz) - real, intent (out) :: tsa1, tsa2 ,tsb1, tsb2 - - integer :: tex,iwt,irz,n,idep,k, index1,i0 - REAL VALX0(NAR), PX0(NAR),sumta,sumta2,timean,zbar, rzw - REAL :: term1, term2, sumdef, suma, frcsat,rzexc, rzact - real zdep(nar),def(nar),wrz(nar),wbin(500),rze(nar) - real catd(2,2),tsc(2,2), satfrc,sumfrac,sumz,frac - real, parameter :: frcmax = .041 - real wtdep,wanom,rzaact,fracl,profdep,rzdep - -! logical bug - -!c---------------------------------------------------------------- -!c Is loss.dat compatible with rzdep = 0.49 ??? - - rzdep = grzdep - -!c Convert fractions to "per-hour" values - do iwt=1,nwt - do irz=1,nrz - frc(iwt,irz)=1.-((1.-frc(iwt,irz))**(1./24.)) - enddo - enddo - - nar0=0 - do n=1,nar - if (px(n) .ne. 0.) then - nar0=nar0+1 - valx0(nar0)=valx(n) - px0(nar0)=px(n) - endif - enddo - - sumta=0. - sumta2=0. - suma=0. - do n=1,nar0 - sumta=sumta+px0(n)*valx0(n) - sumta2=sumta2+px0(n)*valx0(n)*valx0(n) - suma=suma+px0(n) - enddo - - timean=sumta/suma - -!c**** Loop over two water table depths - do idep=1,2 - if(idep.eq.1) zbar=1.5 ! zbar in meters - if(idep.eq.2) zbar=2.0 - -!c**** Compute array of water table depths: - do k=1,nar0 - term1=(1/gnu)*(valx0(k)-timean) - zdep(k)=zbar-term1 - if(zdep(k) .lt. 0.) zdep(k)=0. - enddo -!c write(*,*)" End water table depth" -!c**** Compute array of moisture deficits: - do k=1,nar0 - term1=(psis-zdep(k))/psis - term1=term1**(1.-1./bee) - term2=-psis*(bee/(bee-1.))*(term1-1.) - def(k)=poros*(zdep(k)-term2) - enddo - -!c**** Add deficits to produce catdef: - sumdef=0. - do k=1,nar0 - sumdef=sumdef+def(k)*px0(k)*1000. - enddo -!c write(*,*)" End catchment deficit" -!c**** Compute array of root zone moisture (degree of wetness in root zone): - do k=1,nar0 - - if(zdep(k).eq.0.) then - wrz(k)=1. - elseif(zdep(k)-rzdep.lt.0.) then - term1=((psis-zdep(k))/psis)**(1.-1./bee) - wrz(k)=(-psis/zdep(k))*(bee/(bee-1.)) & - *(term1-1.) - frcsat=1.-zdep(k)/rzdep - wrz(k)=(1.-frcsat)*wrz(k)+frcsat*1. - else - term1=((psis-zdep(k))/psis)**(1.-1./bee) - term2=((psis-zdep(k)+rzdep)/psis) & - **(1.-1./bee) - wrz(k)=(-psis/rzdep)*(bee/(bee-1.)) & - *(term1-term2) - endif - enddo - -!c Loop over two root zone excess values: - do irz=1,2 - if(irz.eq.1) rzexc=-0.1*poros - if(irz.eq.2) rzexc=0.1*poros - -!c Determine actual root zone excess - rzact=0. - do k=1,nar0 - rze(k)=rzexc - rzw=wrz(k)*poros - if(rzw+rze(k) .gt. poros) rze(k)=poros-rzw - if(rzw+rze(k) .lt. 0.) rze(k)=rzw - rzact=rzact+rze(k)*px0(k) - enddo -!c write(*,*)" End root zone excess" -!c Compute the average timescale - - satfrc=0. - do k=1,nar0 - if(zdep(k).lt.0.) satfrc=satfrc+px0(k) - enddo - - sumfrac=0. - sumz=0. - do k=1,nar0 - sumz=sumz+zdep(k)*px0(k) - if(zdep(k) .lt. 1.) frac=frcmax - if(zdep(k) .ge. 1.) then - index1=1+int(((zdep(k)*100.)-99)/5.) - if(index1.gt.nwt) index1 = nwt - frac=amin1(frc(index1,1),frcmax) - do i0=2,nrz - if(rze(k) .ge. rzexcn(index1,i0)) & - frac=amin1(frc(index1,i0),frcmax) - enddo - endif - sumfrac=sumfrac+frac*px0(k) - enddo -!c write(*,*)" End average time scale" - catd(idep,irz)=sumdef - tsc(idep,irz)=sumfrac - - enddo - enddo - - tsb1=(alog(tsc(2,2))-alog(tsc(1,2)))/(catd(2,2)-catd(1,2)) - tsb2=(alog(tsc(2,1))-alog(tsc(1,1)))/(catd(2,1)-catd(1,1)) - tsa1=alog(tsc(2,2))-tsb1*catd(2,2) - tsa2=alog(tsc(2,1))-tsb2*catd(2,1) - - END SUBROUTINE TS_PARAM - -!********************************************************************* - - SUBROUTINE BASE_PARAM( & - BEE,PSIS,POROS,COND, & - VALX, PX, & - bf1,bf2,bf3, & - taberr1,taberr2,normerr1,normerr2 & - ) - -!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -!c c -!c New way to get baseflow: we parametrize the relationship between c -!c catdef and zbar (two parameters bf1 and bf2). c -!c Then, in the LSM/catchment.f/base.f, we use the original relation c -!c from TOPMODEL to infer baseflow from catdef and the mean of the c -!c topographic index (topmean=bf3, a third parameter). c -!c c -!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - - INTEGER IDMAX,i1,i2,i,icount - - REAL, intent (in) :: BEE, PSIS,POROS,COND,VALX(NAR),PX(NAR) - real zbar(nbdep),catdef(nbdep),bflow(nbdep) - real, intent (out) :: bf1,bf2,bf3,taberr1,taberr2,normerr1,normerr2 - integer :: n,idep - real suma,sumta,timean - - real catfit(nbdep),bfit(nbdep),dfit(nbdep),catmean,bfmean - real catref(nbdep),bref(nbdep) - real err1, err2 -! logical, intent (in) :: bug - - sumta=0. - suma=0. - do n=1,nar - sumta=sumta+px(n)*valx(n) - suma=suma+px(n) - enddo - timean=sumta/suma - bf3 = timean - -!c**** Loop over water table depths - - do idep=1,nbdep - -!c write(*,*) 'idep=',idep - - CALL BASIDEP( & - IDEP, & - BEE,PSIS,POROS,COND, & - VALX,PX,TIMEAN,SUMA, & - ZBAR,CATDEF,BFLOW) - - enddo - - - i1=10 ! zbar= 0 m - i2=35 ! zbar= 2.5 m - - bf2=zbar(i2)*SQRT(catdef(i1)) & - /(SQRT(catdef(i2))-SQRT(catdef(i1))) - bf1=catdef(i1)/(bf2*bf2) - - if (bf1 .le. 0) write(*,*) 'bf1 le 0 for i=',i - if (bf2 .le. 0) write(*,*) 'bf2 le 0 for i=',i - -!c Errors: Root mean square errors: only for points where catdef GT 0.5mm - - do idep=1,nbdep - catref(idep)=0. - bref(idep)=0. - enddo - catmean=0. - bfmean=0. - icount=0 - do idep=1,nbdep - if (catdef(idep) .gt. lim) then - icount=icount+1 - catref(icount)=catdef(idep) - bref(icount)=bflow(idep) - catfit(icount)=bf1*(zbar(idep)+bf2) & - *(zbar(idep)+bf2) - dfit(icount)=SQRT(catdef(idep)/bf1)-bf2 - bfit(icount)=cond*exp(-timean-gnu*dfit(icount)) & - /gnu - catmean=catmean+catdef(idep) - bfmean=bfmean+bflow(idep) - endif - enddo - catmean=catmean/icount - bfmean=bfmean/icount - if (icount.gt.1) then - call RMSE(catref,catfit,icount,err1) - call RMSE(bref,bfit,icount,err2) - - taberr1=err1 - taberr2=err2 - normerr1=err1/catmean - normerr2=err2/bfmean - endif -!c--------------------------------------------------------------------- - - END SUBROUTINE BASE_PARAM - -! ************************************************************************ - - SUBROUTINE BASIDEP( & - IDEP, & - BEE,PSIS,POROS,COND, & - VALX,PX,TIMEAN,SUMA, & - ZBAR,CATDEF,BFLOW) - -!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -!c c -!c This program returns the eight parameters for the areal fractioning c -!c c -!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - - implicit none - INTEGER, intent (in) :: idep - integer nref, nind,nmax,indmin,locmax,shift,ord,locmin,ordref,width,k - REAL, intent (in) :: BEE, PSIS, POROS, COND,VALX(NAR), PX(NAR), & - suma,timean - real :: dx,sumdef,dz - real, intent (out) :: catdef(nbdep),bflow(nbdep),zbar(idep) - real term1,term2,sum - real zdep(nar),locdef(nar) -! logical bug - -!c------------------------------------------------------------------------- -!c integral(f(x)dx)=1. for a pdf -!c here px=f(x)dx - - dx=valx(1)-valx(2) - - if (bug) write(*,*) 'IDEP=',IDEP,' dx=',dx, 'gnu=',gnu - -!c the loops over idmax and nbdep are initiated in sta_params4.f - - zbar(idep)=float(idep-10)*slice ! zdep in meters - -!c**** Compute array of water table depths: - do k=1,nar - term1=(1/gnu)*(valx(k)-timean) - zdep(k)=AMAX1(0.,zbar(idep)-term1) - enddo - -!c variable change must be reflected in dx - dz=dx/gnu - - if (bug) write(*,*) 'basidep: ok1' - -!c**** Compute array of moisture deficits: - do k=1,nar - term1=(psis-zdep(k))/psis - term1=term1**(1.-1./bee) - term2=-psis*(bee/(bee-1.))*(term1-1.) - locdef(k)=zdep(k)-term2 - enddo - -!c**** Add deficits to produce catdef: - sumdef=0. - do k=1,nar - sumdef=sumdef+locdef(k)*px(k) - enddo - catdef(idep)=poros*1000.*sumdef/suma - - if (bug) write(*,*) 'basidep: ok2' - - bflow(idep)=cond*exp(-timean-gnu*zbar(idep))/gnu - - if (bug) write(*,*) 'basidep: ok3' - - END SUBROUTINE BASIDEP - -!***************************************************************************** - - SUBROUTINE SAT_PARAM( & - BEE,PSIS,POROS,COND, & - WPWET,VALX, PX, COESKEW,PFC, & - soildepth, & - ARS1,ARS2,ARS3, & - ARA1,ARA2,ARA3,ARA4, & - ARW1,ARW2,ARW3,ARW4, & - taberr1,taberr2,taberr3,taberr4, & - normerr1,normerr2,normerr3,normerr4, & - DBG_UNIT) - -!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -!c c -!c This program returns the eleven parameters for the areal fractioning c -!c c -!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - - IMPLICIT NONE - - INTEGER, intent (in) :: pfc - REAL, intent (in) :: BEE,PSIS,POROS,COND,WPWET, & - VALX(NAR), PX(NAR) - REAL, intent (in) :: soildepth, COESKEW - REAL, intent (inout) :: ARS1,ARS2,ARS3, & - ARA1,ARA2,ARA3,ARA4, & - ARW1,ARW2,ARW3,ARW4, & - taberr1,taberr2,taberr3,taberr4, & - normerr1,normerr2,normerr3,normerr4 - INTEGER idep,n,k,i,icount,iref - integer nar0 - integer nref, nind,nmax,indmin,locmax,shift,ord,locmin - integer loc1,loc2,loc3,loc0,flag - REAL VALX0(NAR), PX0(NAR) - integer :: adjust,loc2save,inc,dec - real sumta,suma,timean,upval,loval,profdep - real rjunk,rjunk2 - integer, intent (in), optional :: DBG_UNIT - real catdef(nbdep),wmin(nbdep),ar1(nbdep),aa(nbdep),aabis(nbdep) - real ar2(nbdep),ar3(nbdep),swsrf2(nbdep),swsrf3(nbdep),rzeq(nbdep) - real zbar0,catdef0,wmin0,RZDEP,wminsave(nbdep) - - real x1,x2,x3,x4,w1,w1_0,w2,w3,w4,ref1 - real y0,f1,f2,f3,g1,g2,g3,df,dg,dx,bf,bg,delta,z1,z2 - - real nar1(nbdep),nar2(nbdep),nmean2(nbdep),neq(nbdep) - real shape, nwm, area1,cdi,nar3(nbdep),nmean3 - real err1,err2,err3,err4,sum - real tabact(nbdep),tabfit(nbdep) - - integer :: mp,isvd,j,first_loop -! REAL*8, allocatable :: A(:,:),AP(:,:) -! REAL*8, allocatable :: B(:) - REAL*8, allocatable, target :: A(:,:) - REAL*8, allocatable, target :: B(:) - REAL*8, pointer :: AP(:,:) - REAL*8, pointer :: BP(:) - REAL*8 V(3,3),W(3),ANS(3),sdmax,sdmin,wbrac - - real :: cdcr1,cdcr2,term1,term2,zmet - logical :: smooth,ars_svd_loop - logical, parameter :: bug=.false. - logical, parameter :: SingValDecomp = .true. - integer, parameter :: nl=4, nr=4, m=4, NP=50 - real :: savgol_coeff(NP) - integer :: savgol_ind(NP) - integer :: nbdepl,istart - - ref1 = 100. -! print *,'PFC', pfc - if (bug) write(*,*) 'starting sat_param' - - if(SingValDecomp) then - savgol_ind(1)=0 - j=3 - do i=2, nl+1 - savgol_ind(i)=i-j - j=j+2 - end do - - j=2 - do i=nl+2, nl+nr+1 - savgol_ind(i)=i-j - j=j+2 - end do - call savgol(savgol_coeff,nl+nr+1,nl,nr,0,m) - endif - - profdep = soildepth - rzdep =grzdep - profdep=profdep/1000. - profdep=amax1(1.,profdep) - if (rzdep .gt. .75*profdep) then - rzdep=0.75*profdep - end if - - zmet=profdep - term1=-1.+((psis-zmet)/psis)** & - ((bee-1.)/bee) - term2=psis*bee/(bee-1) - cdcr1=1000.*poros*(zmet-(-term2*term1)) - cdcr2=(1-wpwet)*poros*1000.*zmet -!c mean of the topographic index distribution - - nar0=0 - do n=1,nar - if (px(n) .ne. 0.) then - nar0=nar0+1 - valx0(nar0)=valx(n) - px0(nar0)=px(n) - endif - enddo - - sumta=0. - suma=0. - do n=1,nar0 - sumta=sumta+px0(n)*valx0(n) - suma=suma+px0(n) - enddo - timean=sumta/suma - - if (bug) write(*,*) 'ok 0: sumta,suma,nar0=',sumta,suma,nar0 - -!c**** Loop over water table depths - - do idep=1,nbdep - - CALL FUNCIDEP( & - NAR0,IDEP, & - BEE,PSIS,POROS,COND,RZDEP,WPWET, & - VALX0,PX0,COESKEW,TIMEAN,SUMA, & - CATDEF,AR1,WMIN,AA,AABIS, & - AR2,AR3,SWSRF2,SWSRF3,RZEQ) - enddo - - nbdepl = 100 - if(catdef(50) > cdcr1 + 20.) nbdepl = 50 - if(soildepth > 6500.) nbdepl = nbdep - - if (bug) write(*,*) 'funcidep loop ok' - -!c**** for wmin's adjustment, we need an estimate of its limit toward INF - adjust =0 - ZBAR0=10. - CALL FUNCZBAR( & - NAR0,ZBAR0, & - BEE,PSIS,POROS,COND,RZDEP,WPWET, & - VALX0,PX0,COESKEW,TIMEAN,SUMA, & - CATDEF0,WMIN0) - - if (bug) write(*,*) 'funczbar ok' - - if (wmin0 == 0.9999900) then - do idep=1,nbdep-1 - if(catdef(idep).le.cdcr1+10.) then - if((wmin(idep) - wmin(idep +1)) > -0.01) then - wmin0=wmin(idep) - endif - endif - enddo - wmin0 = 0.1*(nint(wmin0*100000.)/10000) -0.02 - endif - - if(present(dbg_unit)) then - write (dbg_unit,*) nbdep,nbdepl,wmin0,cdcr1,cdcr2 - write (dbg_unit,*) catdef - write (dbg_unit,*) ar1 - write (dbg_unit,*) wmin - endif + !if ( (Nx_in==Nx_out) .and. (Ny_in==Ny_out) ) then + if (.false.) then -!c**** AR1 adjustment: 3 points + limit in INF = 0. + Rout = Rin - if (bug) write(*,*) 'STARTING AR1' + else - ! Singular value decomposition - loc1=1 - loc3=nbdepl - loc2=loc3 + xx = Nx_in/float(Nx_out) + yy = Ny_in/float(Ny_out) - do idep = 1,loc2 - if(ar1(idep) < 1.e-10) then - loc3 = idep - 1 - exit - endif - end do - - first_loop = 0 - ars_svd_loop = .TRUE. - DO while (ars_svd_loop) - - first_loop = first_loop + 1 - mp = loc3-loc1+1 - - allocate(A(mp,3)) - allocate(AP(mp,3)) - allocate(B(mp)) - - a=0. - ap=0. - b=0. - v=0. - w=0. - ans=0. - - do isvd=loc1,loc3 - A(isvd-loc1+1,1)=catdef(isvd) - A(isvd-loc1+1,2)=-catdef(isvd)*ar1(isvd) - A(isvd-loc1+1,3)=-ar1(isvd)*((catdef(isvd))**2.) - B(isvd-loc1+1)=ar1(isvd)-1. - end do - - ap = a - call svdcmp(ap,mp,3,w,v) - sdmax=0. - do j=1,3 - if(w(j).gt.sdmax)sdmax=w(j) - end do - sdmin=sdmax*1.0e-6 - do j=1,3 - if(w(j).lt.sdmin)w(j)=0. - end do - - call svbksb(ap,w,v,mp,3,b,ans) - - ars1 = real(ans(1)) - ars2 = real(ans(2)) - ars3 = real(ans(3)) - - flag=0 - call curve1(ars1,ars2,ars3,cdcr2,flag) - deallocate (A, AP, B) - - IF(FLAG == 1) THEN - LOC3 = NBDEP - LOC1 =1 - IF(first_loop > 1) ars_svd_loop=.FALSE. - ELSE - ars_svd_loop=.FALSE. - ENDIF - END DO - - IF (FLAG.EQ.1) then - - flag=0 - loc1=1 - do idep=1,nbdepl - if (catdef(idep) .le. 20.) loc1=idep - enddo - - loc3=1 - do idep=1,nbdepl -1 - if ((ar1(idep) >= 0.0001).and.(catdef(idep) <= cdcr1)) loc3=idep + 1 - enddo - - if (loc3.le.loc1+1) then - loc1=MIN(loc3-4,loc1-4) - loc1=MAX(1,loc1) - endif - -!c below is what was used for no regression, but it's not equivalent to the -!c IDL program - loc2=AINT(loc1-1+(loc3-loc1)*3./5.)+1 - - w1=ar1(loc1) - w2=ar1(loc2) - w3=ar1(loc3) - - if(w3.eq.0.)then - 95 loc3=loc3-1 - if(loc3.eq.loc2)loc2=loc2-1 - w3=ar1(loc3) - w2=ar1(loc2) - if(w3.eq.0.)goto 95 - endif - w4=0. - - if((loc1.ge.loc2).or.(loc2.ge.loc3))then - loc1=10 - loc2=14 - loc3=18 - endif - - 115 x1=catdef(loc1) - x2=catdef(loc2) - x3=catdef(loc3) - w1=ar1(loc1) - w2=ar1(loc2) - w3=ar1(loc3) - - if (bug) then - write(*,*) 'loc1,loc2,loc3=',loc1,loc2,loc3 - write(*,*) 'x1,x2,x3=',x1,x2,x3 - write(*,*) 'w1,w2,w3=',w1,w2,w3 - endif - - y0=w4 - f1=(1.-w1)/(w1-y0)/x1 - f2=(1.-w2)/(w2-y0)/x2 - f3=(1.-w3)/(w3-y0)/x3 - g1=(1.-y0)/(w1-y0) - g2=(1.-y0)/(w2-y0) - g3=(1.-y0)/(w3-y0) - df=f2-f1 - dg=g2-g1 - dx=x2-x1 - bf=f1-x1*df/dx - bg=g1-x1*dg/dx - - ars1 = -(f3-bf-x3*df/dx)/(g3-bg-x3*dg/dx + 1.e-10) - ars2 = bf+ars1*bg - ars3 = (df+ars1*dg)/dx - - delta=ars2*ars2-4*ars3 - upval=1.+200.*ars1 - loval=1.+200.*ars2+40000.*ars3 - z1=0. - z2=0. - - if (delta .ge. 0.) then !if 8 - z1=(-ars2-SQRT(delta))/2./ars3 - z2=(-ars2+SQRT(delta))/2./ars3 - endif - - if ((z1 .gt. 0. .and. z1 .lt. cdcr1) .or. & - (z2 .gt. 0. .and. z1 .lt. cdcr1) .or. & - ((upval/loval).lt.-.01)) then !if 7 - z1=0. - z2=0. - if (loc1 .eq. 10) then - loc1=1 -1 else - loc1=1 - do idep=1,nbdepl - if (catdef(idep) .gt. 60.) then - loc1=idep - if(loc1.ge.loc3-1)then - ! write(*,*)'Loc1 exceeded loc3 in 2nd attempt' - loc1=loc3-5 - endif - goto 46 - endif - enddo - endif -46 loc2=loc1+AINT(float(loc3-loc1)*3./5.)+1 - if(loc2.ge.loc3)loc2=loc3-1 - loc2save=loc2 - INC=1 - DEC=0 - -47 w1=ar1(loc1) - w2=ar1(loc2) - x1=catdef(loc1) - x2=catdef(loc2) - - if (bug) then - write(*,*) 'z1,z2=',z1,z2,' -> ar1, 2nd try' - write(*,*) 'loc1,loc2,loc3=',loc1,loc2,loc3 - write(*,*) 'x1,x2,x3=',x1,x2,x3 - write(*,*) 'w1,w2,w3=',w1,w2,w3 - endif - - f1=(1.-w1)/(w1-y0)/(x1 + 1.e-20) - f2=(1.-w2)/(w2-y0)/(x2 + 1.e-20) - g1=(1.-y0)/(w1-y0 + 1.e-20 ) - g2=(1.-y0)/(w2-y0 + 1.e-20) - df=f2-f1 - dg=g2-g1 - dx=x2-x1 - bf=f1-x1*df/dx - bg=g1-x1*dg/dx - - ars1 = -(f3-bf-x3*df/dx)/(g3-bg-x3*dg/dx + 1.e-10) - ars2 = bf+ars1*bg - ars3 = (df+ars1*dg)/dx - delta=ars2*ars2-4*ars3 - upval=1.+200.*ars1 - loval=1.+200.*ars2+40000.*ars3 - - if (delta .ge. 0.) then !if 6 - z1=(-ars2-SQRT(delta))/2./ars3 - z2=(-ars2+SQRT(delta))/2./ars3 - end if - - if ((z1 .gt. 0. .and. z1 .lt. cdcr1) .or. & - (z2 .gt. 0. .and. z1 .lt. cdcr1) .or. & - ((upval/loval).lt.-.01)) then !if 5 - !c Sarith --- - z1=0. - z2=0. - IF(INC.EQ.1)loc2=loc2+1 - IF(DEC.EQ.1)LOC2=LOC2-1 - if(inc.eq.1)then !if 4 - if(loc2.ge.loc3)then !if 3 - ! WRITE(*,*)'INCREASING LOC2 FAILED' - INC=0 - DEC=1 - loc2=loc2save - else - adjust=ADJUST+1 - goto 47 - end if !if 3 - endif !if 4 - - if(dec.eq.1)then !if 2 - if(loc2.eq.loc1)then !if 1 - ! WRITE(*,*)'Decreasing too failed' - INC=1 - DEC=0 - ars1=9999. !ars1old - ars2=9999. !ars2old - ars3=9999. !ars3old - ! write(*,*) 'AR1: PROBLEM for pfc=',pfc - else - adjust=ADJUST+1 - !c write(*,*)'ADJUSTING AR1 CYCLE =',ADJUST - goto 47 - end if !if 1 - endif !if 2 - endif !if 5 - !c endif !if 6 - endif !if 7 - - !c endif !if 8 - flag=0 - call curve1(ars1,ars2,ars3,cdcr2,flag) - - IF (FLAG.EQ.1)then - ! WRITE(*,*)'Curve problem in the catchment pfc=',pfc - ars1=9999. - ars2=9999. - ars3=9999. - ! write(*,*) 'Pick values from icatch-1' - flag=0 - end if - endif - - adjust=0 - - if (bug) write(*,*) 'ar1 adjustment ok' - -!c**** WMIN adjustment: 3 points + limit in INF = wmin0 - - if (bug) write(*,*) 'STARTING WMIN' - - w4=wmin0 - y0=w4 - -! write(*,*) 'wmin=',(wmin(idep),idep=1,50) - - loc1=1 - do idep=1,nbdepl - if (catdef(idep) <= 10.) loc1=idep - enddo - - loc3=1 - do idep=1,nbdepl - 2 - if ((wmin(idep) >= wmin0).and.(catdef(idep) <= cdcr1)) loc3=idep + 2 - enddo - - loc2=loc1 + 2 - do idep=1,nbdepl -1 - if ((wmin(idep) >= wmin0).and.(catdef(idep) <= cdcr1/2.))loc2=idep + 1 - enddo - -!c For global catch - INC=1 - DEC=0 - - if(loc3.eq.loc2)loc2=loc2-2 - if(loc2 <= loc1) loc1= loc1-2 - 44 loc2save=loc2 - if(loc1 < 1) then - loc1 =1 - loc2 =2 - loc3 =3 - endif - - w1=wmin(loc1) - w2=wmin(loc2) - w3=wmin(loc3) - x1=catdef(loc1) - x2=catdef(loc2) - x3=catdef(loc3) - - if (bug) then - write(*,*) 'loc1,loc2,loc3=',loc1,loc2,loc3 - write(*,*) 'x1,x2,x3=',x1,x2,x3 - write(*,*) 'w1,w2,w3,w4=',w1,w2,w3,w4 - endif - - f1=(1.-w1)/(w1-y0)/x1 - f2=(1.-w2)/(w2-y0)/x2 - f3=(1.-w3)/(w3-y0)/x3 - g1=(1.-y0)/(w1-y0) - g2=(1.-y0)/(w2-y0) - g3=(1.-y0)/(w3-y0) - df=f2-f1 - dg=g2-g1 - dx=x2-x1 - bf=f1-x1*df/dx - bg=g1-x1*dg/dx - - arw1 = -(f3-bf-x3*df/dx)/(g3-bg-x3*dg/dx + 1.e-10) - arw2 = bf+arw1*bg - arw3 = (df+arw1*dg)/dx - arw4 = y0 - -!c wmin=arw4+(1.-arw4)*(1.+arw1*catdef(idep)) -!c /(1.+arw2*catdef(idep)+arw3*catdef(idep)*catdef(idep)) -!c we want to check the roots of the denominator - - delta=arw2*arw2-4*arw3 - - if (delta .ge. 0.) then !if 8 - - z1=(-arw2-SQRT(delta))/2./arw3 - z2=(-arw2+SQRT(delta))/2./arw3 - - if ((z1 .gt. 0. .and. z1 .lt. cdcr1) .or. & - (z2 .gt. 0. .and. z1 .lt. cdcr1)) then !if 7 - - w1_0=w1 - w1=(1.+w1_0)/2. - x1=x1/4. - -! if (gnu .eq. 3.26/1.5) then -! w1=(1.+w1_0)/3. ! already difficult -! w3=wmin(nint(cdcr1)) ! with gnu=3.26 -! x3=catdef(nint(cdcr1)) -! f3=(1.-w3)/(w3-y0)/x3 -! g3=(1.-y0)/(w3-y0) -! endif - - f1=(1.-w1)/(w1-y0)/x1 - g1=(1.-y0)/(w1-y0) - df=f2-f1 - dg=g2-g1 - dx=x2-x1 - bf=f1-x1*df/dx - bg=g1-x1*dg/dx - - if (bug) then - write(*,*) 'z1,z2=',z1,z2,' -> wmin, 2nd try' - write(*,*) 'loc1,loc2,loc3=',loc1,loc2,loc3 - write(*,*) 'x1,x2,x3=',x1,x2,x3 - write(*,*) 'w1,w2,w3=',w1,w2,w3 - write(*,*) 'wmin0=',wmin0 - endif - - arw1 = -(f3-bf-x3*df/dx)/(g3-bg-x3*dg/dx + 1.e-10) - arw2 = bf+arw1*bg - arw3 = (df+arw1*dg)/dx - arw4 = y0 - - delta=arw2*arw2-4*arw3 - - if (delta .ge. 0.) then !if 6 - z1=(-arw2-SQRT(delta))/2./arw3 - z2=(-arw2+SQRT(delta))/2./arw3 - - if ((z1 .gt. 0. .and. z1 .lt. cdcr1) .or. & - (z2 .gt. 0. .and. z1 .lt. cdcr1)) then !if 5 -!c Sarith --- - IF(INC.EQ.1)loc2=loc2+1 - IF(DEC.EQ.1)LOC2=LOC2-1 - if(inc.eq.1)then !if 4 - if(loc2.eq.loc3)then !if 3 -! WRITE(*,*)'INCREASING LOC2 FAILED: WMIN' - INC=0 - DEC=1 - loc2=loc2save - else - adjust=ADJUST+1 -!c write(*,*)'ADJUSTING AR1 CYCLE =',ADJUST - goto 44 - end if !if 3 - endif !if 4 - if(dec.eq.1)then !if 2 - if(loc2.eq.loc1)then !if 1 -! WRITE(*,*)'Decreasing too failed: WMIN' - INC=1 - DEC=0 - - arw1=9999. - arw2=9999. - arw3=9999. - arw4=9999. - - else - adjust=ADJUST+1 -!c write(*,*)'ADJUSTING AR1 CYCLE =',ADJUST - goto 44 - end if !if 1 - endif !if 2 - endif !if 5 - endif !if 6 - - endif !if 7 - endif !if 8 - adjust=0 -! endif ! pfc=12821 - flag=0 - - call curve2(arw1,arw2,arw3,arw4,cdcr1,WPWET,flag) - - IF (FLAG.EQ.1) THEN - arw1=9999. !arw1old - arw2=9999. !arw2old - arw3=9999. !arw3old - arw4=9999. !arw4old - flag=0 - endif + do j=1,Ny_out + jj = (j-1)*yy + 1 + do i=1,Nx_out + ii = (i-1)*xx + 1 + Rout(i,j) = Rin(ii,jj) + end do + end do - if(arw1==9999.) then -! Singular Value Decomposition + end if - w4=wmin0 - y0=w4 + end subroutine RegridRaster2 - loc1=1 - loc3=nbdepl + ! ----------------------------------------------------------------------------------- - mp = loc3-loc1+1 + subroutine RegridRasterReal(Rin,Rout) - if(mp.lt.3)then + ! same as RegridRaster() but for gridded real values - write(*,*)'WMIN Note: not sufficient points MP = ',mp - print *,w4,cdcr1,catdef(loc3),wmin(loc3) - arw1 = 9999. - arw2 = 9999. - arw3 = 9999. - arw4 = 9999. - else - - mp = 1 - istart =1 - w4 = wmin(istart) + real, intent(IN) :: Rin( :,:) + real, intent(OUT) :: Rout(:,:) - if(w4 <=0) then - do idep=2,nbdepl - if(wmin(idep) > 0.) istart = idep - if(wmin(idep) > 0.) exit - enddo - endif + REAL(REAL64) :: xx, yy + integer :: i, j, ii, jj + integer :: Nx_in, Ny_in, Nx_out, Ny_out - w4 = wmin(istart) + Nx_in = size(Rin ,1) + Ny_in = size(Rin ,2) - do idep=istart+1,nbdepl -! if(wmin(idep).lt.w4) then - if((wmin(idep) - w4).lt.0.0005) then - w4 = wmin(idep) - mp = mp +1 - endif - enddo - loc3 = mp - allocate(A(mp,3)) - allocate(AP(mp,3)) - allocate(B(mp)) - allocate(BP(mp)) - smooth = .false. - do idep=istart,nbdepl-1 - if(catdef(idep).le.cdcr1+10.) then - if((wmin(idep) - wmin(idep +1)) < -0.01) smooth = .true. - endif - enddo - if(smooth) then - wminsave = wmin - ! Apply filter to input data - do i=istart, nbdepl-nr - wmin(i)=0. - do j=1, nl+nr+1 - if (i+savgol_ind(j).gt.0) then !skip left points that do not exist - wmin(i)=wmin(i)+savgol_coeff(j)*wminsave(i+savgol_ind(j)) - endif - end do - enddo - wmin (istart:istart+4) = wminsave (istart:istart+4) - - endif - - j = 1 - w4 = wmin(istart) - do isvd=1,size(wmin) - if (j <= mp) then - if(isvd == 1) then - wbrac=(wmin(isvd + istart -1)-y0)/(1.-y0 + 1.e-20) - A(j,1)=catdef(isvd + istart -1) - A(j,2)=-catdef(isvd + istart -1)*wbrac - A(j,3)=-wbrac*((catdef(isvd + istart -1))**2.) - B(j)=wbrac-1. - j = j + 1 - else - if((wmin(isvd + istart -1).lt.w4).and.(wmin(isvd + istart -1).gt.y0)) then - wbrac=(wmin(isvd + istart -1)-y0)/(1.-y0 + 1.e-20) - A(j,1)=catdef(isvd + istart -1) - A(j,2)=-catdef(isvd + istart -1)*wbrac - A(j,3)=-wbrac*((catdef(isvd + istart -1))**2.) - B(j)=wbrac-1. - w4 = wmin(isvd + istart -1) - j = j + 1 - endif - endif - endif - end do - - j = j -1 - mp = j - ap => a (1:j,:) - bp => b (1:j) - ap(j,1) = catdef(nbdep) - ap(j,2) = 0. - ap(j,3) = 0. - bp (j) = -1. - - call svdcmp(ap,mp,3,w,v) - - sdmax=0. - do j=1,3 - if(w(j).gt.sdmax)sdmax=w(j) - end do - - sdmin=sdmax*1.0e-6 - do j=1,3 - if(w(j).lt.sdmin)w(j)=0. - end do - - call svbksb(ap,w,v,mp,3,bp,ans) - - arw1 = real(ans(1)) - arw2 = real(ans(2)) - arw3 = real(ans(3)) - arw4 = y0 - -!c wmin=arw4+(1.-arw4)*(1.+arw1*catdef(idep)) -!c /(1.+arw2*catdef(idep)+arw3*catdef(idep)*catdef(idep)) -!c we want to check the roots of the denominator - - adjust=0 - flag=0 - - call curve2(arw1,arw2,arw3,arw4,cdcr1,WPWET,flag) - - IF (FLAG.EQ.1) THEN - ! WRITE(*,*)'Curve2 problem in the catchment:pfc=',pfc - - arw1 = 9999. - arw2 = 9999. - arw3 = 9999. - arw4 = 9999. - - flag=0 - end if - deallocate (A, B ) - NULLIFY (AP, BP) - end if - endif - - if(present(dbg_unit)) then - write (dbg_unit,*) ars1,ars2,ars3 - write (dbg_unit,*) arw1,arw2,arw3,arw4 - endif - - if (bug) write(*,*) 'wmin adjustment ok' - -!c**** SHAPE PARAMETER ADJUSTMENT: with a straight if coeskew > 0.25 -!c with 2 segments if not - - if (bug) write(*,*) 'STARTING SHAPE' - - x3=catdef(nbdepl) - w3=aa(nbdepl) - x1=0. - - if (coeskew .lt. 0.25) then - w1=0.1 - loc2=20 - do idep=1,nbdepl - if (catdef(idep) .gt. ref1) then - loc2=idep - goto 45 - endif - enddo - 45 x2=catdef(loc2) - w2=aabis(loc2) - ara1 = (w1-w2)/(x1-x2) - ara2 = w1-ara1*x1 - ara3 = (w2-w3)/(x2-x3) - ara4 = w2-ara3*x2 - else - w1=1. - x2=x1 - w2=w1 - ara3 = (w2-w3)/(x2-x3) - ara4 = w2-ara3*x2 - ara1 = ara3 - ara2 = ara4 - endif - - if (bug) write(*,*) 'x1,w1,x2,w2,x3,w3',x1,w1,x2,w2,x3,w3 - -!**** RMSE checking: on ar1, ar2, swsrf2 and rzeq - - do idep=1,nbdepl - if(catdef(idep) <= cdcr1) then - nar1(idep)=AMIN1(1.,AMAX1(0.,(1.+ars1*catdef(idep)) & - /(1.+ars2*catdef(idep) & - +ars3*catdef(idep)*catdef(idep)))) - - nwm=AMIN1(1.,AMAX1(0.,arw4+(1.-arw4)* & - (1.+arw1*catdef(idep)) & - /(1.+arw2*catdef(idep) & - +arw3*catdef(idep)*catdef(idep)))) - -!c we have to first determine if there is one or two segments - if (ara1 .ne. ara3) then - cdi=(ara4-ara2)/(ara1-ara3) - else - cdi=0. - endif - - if (catdef(idep) .ge. cdi) then - shape=ara3*catdef(idep)+ara4 - else - shape=ara1*catdef(idep)+ara2 - endif - shape =AMIN1(40.,shape) - area1=exp(-shape*(1.-nwm))*(shape*(1.-nwm)+1.) - -!c the threshold for truncation problems is higher than the "usual" -!c E-8 to E-10, because it plays together with the uncertainties coming -!c from the approximation of the parameters nwm, nar1 and shape. - if (area1 .ge. 1.-1.E-8) then - nar1(idep)=1. - nar2(idep)=0. - nar3(idep)=0. - nmean2(idep)=0. - nmean3=0. - neq(idep)=1. - else - - if (nwm .gt. wpwet) then - nar2(idep)=1.-nar1(idep) - else - nar2(idep)=AMAX1(0.,((shape*(wpwet-nwm)+1.) & - *exp(-shape*(wpwet-nwm)) & - - (shape*(1.-nwm)+1.)*exp(-shape*(1.-nwm))) & - * (1.-nar1(idep))/(1.-area1)) - endif - - nar3(idep)=1.-nar1(idep)-nar2(idep) - - if (nar3(idep) .lt. 1.E-8) then ! for nwm le wpwet - - nmean2(idep)=AMAX1(0.,AMIN1(1.,(nwm + 2./shape + & - shape*exp(-shape*(1.-nwm))* & - (nwm+nwm/shape-1.-2./shape-2./(shape*shape))) & - /(1.-area1))) - nmean3=0. + Nx_out = size(Rout,1) + Ny_out = size(Rout,2) - else + !if ( (Nx_in==Nx_out) .and. (Ny_in==Ny_out) ) then + if (.false.) then -!c WARNING: I think the two values below are false. -!c But it is never used in this context, because nwm > wpwet !! - nmean2(idep)=AMAX1(0.,AMIN1(1.,-shape*(exp(-shape*& - (wpwet-nwm))* (nwm*wpwet & - +nwm/shape-wpwet*wpwet & - -2.*wpwet/shape-2./(shape*shape)) & - - exp(-shape*(1.-nwm))* & - (nwm+nwm/shape-1.-2./shape-2./(shape*shape)))& - * (1.-nar1(idep))/(1.-area1) / (nar2(idep)+1.e-20))) - - nmean3=AMAX1(0.,AMIN1(1.,(nwm+2./shape + & - shape*exp(-shape*(wpwet-nwm))* & - (nwm*wpwet+nwm/shape-wpwet & - *wpwet-2.*wpwet/shape & - -2./(shape*shape))) * (1.-nar1(idep)) & - /(1.-area1)/(nar3(idep) + 1.e-20))) - endif - - neq(idep)=nar1(idep)+nar2(idep)*nmean2(idep) & - +nar3(idep)*nmean3 - - if (area1 .ge. 1.-1.E-5) then - nmean2(idep)=1. - nmean3=0. - neq(idep)=1. - endif + Rout = Rin - endif - endif - enddo + else - if (bug) write(*,*) 'shape adjustment ok' -!c -!c RMSE - -!c ERR1 - icount=0 - iref=0 - sum=0. - do i=1,nbdepl - if(catdef(i) <= cdcr1) then - tabact(i)=0. - tabfit(i)=0. - endif - enddo + xx = Nx_in/float(Nx_out) + yy = Ny_in/float(Ny_out) - do i=1,nbdepl - if(catdef(i) <= cdcr1) then - if (catdef(i) .gt. lim) then - icount=icount+1 - sum=sum+ar1(i) - tabfit(icount)=nar1(i) - tabact(icount)=ar1(i) - endif - endif - enddo + do j=1,Ny_out + jj = (j-1)*yy + 1 + do i=1,Nx_out + ii = (i-1)*xx + 1 + Rout(i,j) = Rin(ii,jj) + end do + end do - if(icount.gt.1) then - sum=sum/icount - call RMSE(tabact,tabfit,icount,err1) - taberr1=err1 - normerr1=err1/sum - endif -!c ERR2 - icount=0 - iref=0 - sum=0. - do i=1,nbdepl - if(catdef(i) <= cdcr1) then - tabact(i)=0. - tabfit(i)=0. - endif - enddo + end if - do i=1,nbdepl - if(catdef(i) <= cdcr1) then - if (catdef(i) .gt. lim) then - icount=icount+1 - sum=sum+ar2(i) - tabfit(icount)=nar2(i) - tabact(icount)=ar2(i) - endif - endif - enddo + end subroutine RegridRasterReal - if(icount.gt.1) then - sum=sum/icount - call RMSE(tabact,tabfit,icount,err2) - taberr2=err2 - normerr2=err2/sum - endif - -!c ERR3 - icount=0 - iref=0 - sum=0. - do i=1,nbdep - if(catdef(i) <= cdcr1) then - tabact(i)=0. - tabfit(i)=0. - endif - enddo + !--------------------------------------------------------------------- + + SUBROUTINE svbksb(u,w,v,m,n,b,x) + + INTEGER m,mp,n,np,NMAX + REAL*8 b(m),u(m,n),v(n,n),w(n),x(n) + PARAMETER (NMAX=500) !Maximum anticipated value of n + !------------------------------------------------------------------------------------------- + ! Solves A · X = B for a vector X, where A is specified by the arrays u, w, v as returned by + ! svdcmp. m and n are the dimensions of a, and will be equal for square matrices. b(1:m) is + ! the input right-hand side. x(1:n) is the output solution vector. No input quantities are + ! destroyed, so the routine may be called sequentially with different b’s. + !------------------------------------------------------------------------------------------- + + INTEGER i,j,jj + REAL*8 s,tmp(NMAX) + do j=1,n !Calculate UTB. + s=0. + if(w(j).ne.0.)then !Nonzero result only if wj is nonzero. + do i=1,m + s=s+u(i,j)*b(i) + end do + s=s/(w(j) + 1.d-20) !This is the divide by wj . + endif + tmp(j)=s + end do + do j=1,n !Matrix multiply by V to get answer. + s=0. + do jj=1,n + s=s+v(j,jj)*tmp(jj) + end do + x(j)=s + end do + return + END SUBROUTINE svbksb + + !--------------------------------------------------------------------- + + SUBROUTINE svdcmp(a,m,n,w,v) + + INTEGER m,n,NMAX + REAL*8, intent (inout) :: a(m,n) + REAL*8, intent (out) :: v(n,n),w(n) + PARAMETER (NMAX=500) !Maximum anticipated value of n. + !-------------------------------------------------------------------------------------- + ! Given a matrix A(1:m,1:n), this routine computes its singular value decomposition, + ! A = U · W · Vt. The matrix U replaces A on output. The diagonal matrix of singular + ! values W is output as a vector W(1:n). The matrix V (not the transpose Vt) is output + ! as V(1:n,1:n). + !-------------------------------------------------------------------------------------- + + INTEGER i,its,j,jj,k,l,nm + REAL*8 anorm,c,f,g,h,s,scale,x,y,z,rv1(NMAX) + real*8, parameter :: EPS=epsilon(1.0d0) + g=0.d0 !Householder reduction to bidiagonal form. + scale=0.d0 + anorm=0.d0 + c =0.d0 + f =0.d0 + g =0.d0 + h =0.d0 + s =0.d0 + x =0.d0 + y =0.d0 + z =0.d0 + rv1=0.d0 + w = 0.d0 + v = 0.d0 + do i=1,n + l=i+1 + rv1(i)=scale*g + g=0.d0 + s=0.d0 + scale=0.d0 + if(i.le.m)then + do k=i,m + scale=scale+abs(a(k,i)) + end do + if(scale.ne.0.d0)then + do k=i,m + a(k,i)=a(k,i)/scale + s=s+a(k,i)*a(k,i) + end do + f=a(i,i) + g=-dsign(dsqrt(s),f) + h=f*g-s + a(i,i)=f-g + do j=l,n + s=0.d0 + do k=i,m + s=s+a(k,i)*a(k,j) + end do + f=s/h + do k=i,m + a(k,j)=a(k,j)+f*a(k,i) + end do + end do + do k=i,m + a(k,i)=scale*a(k,i) + end do + endif + endif + w(i)=scale *g + g=0.d0 + s=0.d0 + scale=0.d0 + if((i.le.m).and.(i.ne.n))then + do k=l,n + scale=scale+abs(a(i,k)) + end do + if(scale.ne.0.d0)then + do k=l,n + a(i,k)=a(i,k)/scale + s=s+a(i,k)*a(i,k) + end do + f=a(i,l) + g=-sign(sqrt(s),f) + h=f*g-s + a(i,l)=f-g + do k=l,n + rv1(k)=a(i,k)/h + end do + do j=l,m + s=0.d0 + do k=l,n + s=s+a(j,k)*a(i,k) + end do + do k=l,n + a(j,k)=a(j,k)+s*rv1(k) + end do + end do + do k=l,n + a(i,k)=scale*a(i,k) + end do + endif + endif + anorm=max(anorm,(abs(w(i))+abs(rv1(i)))) + end do !do i=1,n + + do i=n,1,-1 !Accumulation of right-hand transformations. + if(i.lt.n)then + if(g.ne.0.d0)then + do j=l,n !Double division to avoid possible underflow. + v(j,i)=(a(i,j)/a(i,l))/g + end do + do j=l,n + s=0.d0 + do k=l,n + s=s+a(i,k)*v(k,j) + end do + do k=l,n + v(k,j)=v(k,j)+s*v(k,i) + end do + end do + endif + do j=l,n + v(i,j)=0.d0 + v(j,i)=0.d0 + end do + endif + v(i,i)=1.d0 + g=rv1(i) + l=i + end do + + do i=min(m,n),1,-1 !Accumulation of left-hand transformations. + l=i+1 + g=w(i) + do j=l,n + a(i,j)=0.d0 + end do + if(g.ne.0.d0)then + g=1.d0/g + do j=l,n + s=0.d0 + do k=l,m + s=s+a(k,i)*a(k,j) + end do + f=(s/a(i,i))*g + do k=i,m + a(k,j)=a(k,j)+f*a(k,i) + end do + end do + do j=i,m + a(j,i)=a(j,i)*g + end do + else + do j= i,m + a(j,i)=0.d0 + end do + endif + a(i,i)=a(i,i)+1.d0 + end do - do i=1,nbdepl - if(catdef(i) <= cdcr1) then - if (catdef(i) .gt. lim) then - icount=icount+1 - sum=sum+swsrf2(i) - tabfit(icount)=nmean2(i) - tabact(icount)=swsrf2(i) + do k=n,1,-1 !Diagonalization of the bidiagonal form: Loop over + !singular values, and over allowed iterations. + do its=1,30 + do l=k,1,-1 !Test for splitting. + nm=l-1 !Note that rv1(1) is always zero. + if( abs(rv1(l)) <= EPS*anorm ) goto 2 + if( abs(w(nm) ) <= EPS*anorm ) goto 1 + end do +1 c=0.d0 !Cancellation of rv1(l), if l > 1. + s=1.d0 + do i=l,k + f=s*rv1(i) + rv1(i)=c*rv1(i) + if( abs(f) <= EPS*anorm ) goto 2 + g=w(i) + h=pythag(f,g) + w(i)=h + h=1.d0/h + c= (g*h) + s=-(f*h) + do j=1,m + y=a(j,nm) + z=a(j,i) + a(j,nm)=(y*c)+(z*s) + a(j,i)=-(y*s)+(z*c) + end do + end do +2 z=w(k) + if(l.eq.k)then !Convergence. + if(z.lt.0.d0)then !Singular value is made nonnegative. + w(k)=-z + do j=1,n + v(j,k)=-v(j,k) + end do endif + goto 3 + endif + if(its.eq.30) print *, 'no convergence in svdcmp' + ! if(its.ge.4) print *, 'its = ',its + x=w(l) !Shift from bottom 2-by-2 minor. + nm=k-1 + y=w(nm) + g=rv1(nm) + h=rv1(k) + f=((y-z)*(y+z)+(g-h)*(g+h))/(2.0*h*y) + g=pythag(f,1.d0) + f=((x-z)*(x+z)+h*((y/(f+sign(g,f)))-h))/x + c=1.d0 !Next QR transformation: + s=1.d0 + do j=l,nm + i=j+1 + g=rv1(i) + y=w(i) + h=s*g + g=c*g + z=pythag(f,h) + rv1(j)=z + c=f/z + s=h/z + f= (x*c)+(g*s) + g=-(x*s)+(g*c) + h=y*s + y=y*c + do jj=1,n + x=v(jj,j) + z=v(jj,i) + v(jj,j)= (x*c)+(z*s) + v(jj,i)=-(x*s)+(z*c) + end do + z=pythag(f,h) + w(j)=z !Rotation can be arbitrary if z = 0. + if(z.ne.0.d0)then + z=1.d0/z + c=f*z + s=h*z endif - enddo + f= (c*g)+(s*y) + x=-(s*g)+(c*y) + do jj=1,m + y=a(jj,j) + z=a(jj,i) + a(jj,j)= (y*c)+(z*s) + a(jj,i)=-(y*s)+(z*c) + end do + end do !j=l;nm + rv1(l)=0.d0 + rv1(k)=f + w(k)=x + end do !its=1,30 +3 continue + end do !k=n,1,-1 + return + END SUBROUTINE svdcmp + ! + ! ________________________________________________________________________________ + ! + REAL*8 FUNCTION pythag(a,b) + REAL*8 a,b + !Computes sqrt(a**2 + b**2) without destructive underflow or overflow. + REAL*8 absa,absb + absa=abs(a) + absb=abs(b) + if(absa.gt.absb)then + pythag=absa*sqrt(1.+(absb/absa)**2) + else + if(absb.eq.0.)then + pythag=0. + else + pythag=absb*sqrt(1.+(absa/absb)**2) + endif + endif + return + END FUNCTION pythag + ! + ! ________________________________________________________________________________ + ! + + SUBROUTINE savgol(c,np,nl,nr,ld,m) + + INTEGER ld,m,nl,np,nr,MMAX + real c(np) + PARAMETER (MMAX=6) + !-------------------------------------------------------------------------------------------- + !USES lubksb,ludcmp given below. + !Returns in c(1:np), in wrap-around order (see reference) consistent with the argument respns + !in routine convlv, a set of Savitzky-Golay filter coefficients. nl is the number of leftward + !(past) data points used, while nr is the number of rightward (future) data points, making + !the total number of data points used nl +nr+1. ld is the order of the derivative desired + !(e.g., ld = 0 for smoothed function). m is the order of the smoothing polynomial, also + !equal to the highest conserved moment; usual values are m = 2 or m = 4. + !-------------------------------------------------------------------------------------------- + INTEGER d,icode,imj,ipj,j,k,kk,mm,indx(MMAX+1) + real fac,sum,a(MMAX+1,MMAX+1),b(MMAX+1) + if(np.lt.nl+nr+1.or.nl.lt.0.or.nr.lt.0.or.ld.gt.m.or.m.gt.MMAX & + .or.nl+nr.lt.m) pause ' Bad args in savgol.' + do ipj=0,2*m !Set up the normal equations of the desired leastsquares fit. + sum=0. + if(ipj.eq.0) sum=1. + do k=1,nr + sum=sum+dfloat(k)**ipj + end do + do k=1,nl + sum=sum+dfloat(-k)**ipj + end do + mm=min(ipj,2*m-ipj) + do imj=-mm,mm,2 + a(1+(ipj+imj)/2,1+(ipj-imj)/2)=sum + end do + end do - if(icount.gt.1) then - sum=sum/icount - call RMSE(tabact,tabfit,icount,err3) - taberr3=err3 - normerr3=err3/sum - endif -!c ERR4 - icount=0 - iref=0 - sum=0. - do i=1,nbdepl - tabact(i)=0. - tabfit(i)=0. - enddo + call ludcmp(a,m+1,MMAX+1,indx,d,icode) !Solve them: LU decomposition. - do i=1,nbdepl - if(catdef(i) <= cdcr1) then - if (catdef(i) .gt. lim) then - icount=icount+1 - sum=sum+rzeq(i) - tabfit(icount)=neq(i) - tabact(icount)=rzeq(i) - endif - endif - enddo + do j=1,m+1 + b(j)=0. + end do + b(ld+1)=1. !Right-hand side vector is unit vector, depending on which derivative we want. - if(icount.gt.1) then - sum=sum/icount - call RMSE(tabact,tabfit,icount,err4) - taberr4=err4 - normerr4=err4/sum - endif - END SUBROUTINE SAT_PARAM -! + call lubksb(a,m+1,MMAX+1,indx,b) !Backsubstitute, giving one row of the inverse matrix. -! ****************************************************************** - -!c - SUBROUTINE CURVE1(ars1,ars2,ars3,cdcr2,flag) - REAL ars1,ars2,ars3,y,x,yp,cdcr2 - INTEGER i,flag -!c - yp=1. - if (abs(ars1+ars2+ars3).le.1.e25) then - do i=0,CEILING(cdcr2) - x=float(i) - if(x > cdcr2) x = cdcr2 - y=(1.+ars1*x)/(1.+ars2*x+ars3*x*x + 1.e-20) - if((y.gt.0.0).and.(((yp -y) .lt. -1.e-4).or.(y.gt.1.)))then - flag=1 - goto 99 - endif - yp=y - end do - 99 continue - else - flag=1 - endif - - end SUBROUTINE CURVE1 - - -! ****************************************************************** - - SUBROUTINE CURVE2(arw1,arw2,arw3,arw4,cdcr1,WPWET,flag) - REAL arw1,arw2,arw3,arw4,y,x,yp,cdcr1, wpwet - INTEGER i,flag -!c - yp=1. - if (abs(arw1+arw2+arw3+arw4).le.1.e25) then - do i=0,CEILING(cdcr1) - x=float(i) - if(x > cdcr1) x = cdcr1 - y=arw4+(1.-arw4)*(1.+arw1*x)/(1.+arw2*x+arw3*x*x + 1.e-20) - if ((y .lt. wpwet).or.((yp -y) .lt. -1.e-4).or.(y.gt.1.)) then - flag=1 - goto 99 - endif - yp=y - end do -99 continue - else - flag=1 - endif - end SUBROUTINE CURVE2 - -! ****************************************************************** - - subroutine tgen ( & - TOPMEAN,TOPVAR,TOPSKEW, & - STO,ACO,COESKEW) - -!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -! c -! The difference between tgen4 and tgen3 is that tgen4 deals with arrays c -! of topmean, topvar and topskew and 2-dim arrays of st and ac. c -! c -! This routine determine the theoretical gamma distribution for the c -! soil-topographic indexes (Sivapalan et al., 1987), knowing the three c -! first moments, the min and the max of the observed topographic indexes c -! in a given catchment. c -! c -! Routine from Dave Wolock. c -! Modified by Agnes (11-06-98): we don't use min and max anymore, and c -! this strongly improves the behavior for negative skewnesses. It also c -! improves in general the matching of the moments. c -! c -! We also add a correction on the skewness to have gamma distributions c -! that start and end from the x-axis. It is based on the fact that if c -! TOPETA=1, the gamma is an exponential distribution, and if TOPETA<1, c -! then the gamma distribution increases towards the infinite when x c -! decreases towards 0. c -! To eliminate some numerical pb due to teh discretization of the gamma c -! distribution, we choose skewness=MAX(MIN(1.9, skewness),-1.6) c -! c -! WE MAY NEED TO COMPUTE IN DOUBLE RESOLUTION !!!! BECAUSE OF THE SMALL c -! BIN WIDTH -! c -!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - - IMPLICIT NONE - - real, parameter :: VALMAX=50. - REAL, intent (in) :: TOPMEAN,TOPVAR,TOPSKEW - REAL, intent (out) :: COESKEW - REAL, dimension (NAR), intent (out) :: STO,ACO - - INTEGER I - REAL ST(NAR),AC(NAR) - REAL TOPETA,TOPLAM,TOPSCAL,GAMLN,SCALE,ACLN - real cumac, cum2,cum3 - -!------------------------------------------------------------------------- - -! topmean is the mean of the ln(a/tanB) distribution -! topvar is the variance (2nd moment centerd around the mean) of the ... -! topskew is the skew (3rd moment centerd around the mean) of the ... -! compute the coefficient of skew or skewness (coeskew) - - COESKEW=TOPSKEW/TOPVAR**1.5 - if (coeskew .ge. 0.) then - COESKEW=AMAX1(0.005, AMIN1(1.9, COESKEW)) - else - COESKEW=AMAX1(-1.6, AMIN1(-0.005, COESKEW)) - endif - -! compute the gamma parameters, eta (topeta) and lambda (toplam), and topscal -! which is the translation parameter - - TOPETA=4./COESKEW**2 - TOPLAM=SQRT(TOPETA)/SQRT(TOPVAR) - TOPSCAL=TOPMEAN-TOPETA/TOPLAM - -! evaluate the gamma function - - CALL GAMMLN (TOPETA,GAMLN) - - CUMAC=0.0 - -! compute the frequency distribution of ln(a/tanB) -! st(i) are the values of ln(a/tanB) -! ac(i) are the relative frequency values (they should sum to 1) - - DO I=1,NAR - - ST(I)=(FLOAT(I)-0.95)*(VALMAX-TOPSCAL)/FLOAT(NAR)+TOPSCAL - SCALE=ST(I)-TOPSCAL - -! below is the logarithmic form of the gamma distribution; this is required -! because the numerical estimate of the logarithm of the gamma function -! is more stable than the one of the gamma function. - - ACLN=TOPETA*ALOG(TOPLAM)+(TOPETA-1.)*ALOG(SCALE) & - -TOPLAM*SCALE-GAMLN - - IF(ACLN.LT.-10.) THEN - AC(I)=0. - ELSE - AC(I)=EXP(ACLN) - ENDIF - - CUMAC=CUMAC+AC(I) - - ENDDO - -! we want the relative frequencies to sum 1. - - IF (CUMAC.eq.0.) THEN -! write(*,*) 'distrib sum=',CUMAC - stop - endif - CUM2=0. - DO I=1,NAR - AC(I) = AC(I) / CUMAC - CUM2=CUM2+AC(I) - ENDDO - -! if the real distribution of the topographic indices is negativeley skewed, -! we symetrize the gamma distribution (depending on coeskew**2 and always -! positively skewed), centering on topmean, which preserves topmean and -! topvar, and re-establishes a negative skewness. - - IF (COESKEW.LT.0.) then - - do i=1,nar - STO(I)=2.*TOPMEAN-ST(I) - ACO(I)=AC(I) - - enddo - ELSE -! if (n .eq. idmax) then -! write(*,*) 'last catchment' -! endif - do i=1,nar - STO(I)=ST(-I+NAR+1) - ACO(I)=AC(-I+NAR+1) - enddo - ENDIF - -! sum=0. -! do i=1,nar -! sum=sum+sto(i)*aco(i) -! end do - -! sum=0. -! do i=1,nar -! sum=sum+aco(i) -! end do - - - END subroutine tgen - - ! ******************************************************************** + do kk=1,np !Zero the output array (it may be bigger than the number + c(kk)=0. !of coefficients). + end do + do k=-nl,nr !Each Savitzky-Golay coefficient is the dot product + sum=b(1) !of powers of an integer with the inverse matrix row. + fac=1. + do mm=1,m + fac=fac*k + sum=sum+b(mm+1)*fac + end do + kk=mod(np-k,np)+1 !Store in wrap-around order. + c(kk)=sum + end do + return + END SUBROUTINE savgol + + !*************************************************************** + !* Given an N x N matrix A, this routine replaces it by the LU * + !* decomposition of a rowwise permutation of itself. A and N * + !* are input. INDX is an output vector which records the row * + !* permutation effected by the partial pivoting; D is output * + !* as -1 or 1, depending on whether the number of row inter- * + !* changes was even or odd, respectively. This routine is used * + !* in combination with LUBKSB to solve linear equations or to * + !* invert a matrix. Return code is 1, if matrix is singular. * + !*************************************************************** + Subroutine LUDCMP(A,N,NP,INDX,D,CODE) + INTEGER, PARAMETER :: NMAX=100 + REAL, PARAMETER :: TINY=1E-12 + real AMAX,DUM, SUM, A(NP,NP),VV(NMAX) + INTEGER CODE, D, INDX(N),NP,N,I,J,K,IMAX + + D=1; CODE=0 + + DO I=1,N + AMAX=0. + DO J=1,N + IF (ABS(A(I,J)).GT.AMAX) AMAX=ABS(A(I,J)) + END DO ! j loop + IF(AMAX.LT.TINY) THEN + CODE = 1 + RETURN + END IF + VV(I) = 1. / AMAX + END DO ! i loop + + DO J=1,N + DO I=1,J-1 + SUM = A(I,J) + DO K=1,I-1 + SUM = SUM - A(I,K)*A(K,J) + END DO ! k loop + A(I,J) = SUM + END DO ! i loop + AMAX = 0. + DO I=J,N + SUM = A(I,J) + DO K=1,J-1 + SUM = SUM - A(I,K)*A(K,J) + END DO ! k loop + A(I,J) = SUM + DUM = VV(I)*ABS(SUM) + IF(DUM.GE.AMAX) THEN + IMAX = I + AMAX = DUM + END IF + END DO ! i loop + + IF(J.NE.IMAX) THEN + DO K=1,N + DUM = A(IMAX,K) + A(IMAX,K) = A(J,K) + A(J,K) = DUM + END DO ! k loop + D = -D + VV(IMAX) = VV(J) + END IF + + INDX(J) = IMAX + IF(ABS(A(J,J)) < TINY) A(J,J) = TINY + + IF(J.NE.N) THEN + DUM = 1. / A(J,J) + DO I=J+1,N + A(I,J) = A(I,J)*DUM + END DO ! i loop + END IF + END DO ! j loop + + RETURN + END Subroutine LUDCMP + + + !****************************************************************** + !* Solves the set of N linear equations A . X = B. Here A is * + !* input, not as the matrix A but rather as its LU decomposition, * + !* determined by the routine LUDCMP. INDX is input as the permuta-* + !* tion vector returned by LUDCMP. B is input as the right-hand * + !* side vector B, and returns with the solution vector X. A, N and* + !* INDX are not modified by this routine and can be used for suc- * + !* cessive calls with different right-hand sides. This routine is * + !* also efficient for plain matrix inversion. * + !****************************************************************** + Subroutine LUBKSB(A,N,NP,INDX,B) + INTEGER :: II,I,J,LL,N,NP + real SUM, A(NP,NP),B(N) + INTEGER INDX(N) + + II = 0 + + DO I=1,N + LL = INDX(I) + SUM = B(LL) + B(LL) = B(I) + IF(II.NE.0) THEN + DO J=II,I-1 + SUM = SUM - A(I,J)*B(J) + END DO ! j loop + ELSE IF(SUM.NE.0.) THEN + II = I + END IF + B(I) = SUM + END DO ! i loop + + DO I=N,1,-1 + SUM = B(I) + IF(I < N) THEN + DO J=I+1,N + SUM = SUM - A(I,J)*B(J) + END DO ! j loop + END IF + B(I) = SUM / A(I,I) + END DO ! i loop + + RETURN + END Subroutine LUBKSB + + ! + ! ==================================================================== + ! + + INTEGER FUNCTION center_pix (x,y,x0,y0,z0,ext_point) - SUBROUTINE GAMMLN (XX,GAMLN) - - implicit none - DOUBLE PRECISION :: COF(6),STP,HALF,ONE,FPF,X,TMP,SER - REAL, intent(in) :: XX - REAL, intent(out) :: GAMLN - integer :: j + real, dimension (:), intent(in ) :: x,y - DATA COF /76.18009173D0,-86.50532033D0,24.01409822D0, & - -1.231739516D0,.120858003D-2,-.536382D-5/ - STP = 2.50662827465D0 - HALF= 0.5D0 - ONE = 1.0D0 - FPF = 5.5D0 - - X=XX-ONE - TMP=X+FPF - TMP=(X+HALF)*LOG(TMP)-TMP - SER=ONE + real, intent(inout) :: x0,y0,z0 + logical, intent(in ) :: ext_point - DO J=1,6 - X=X+ONE - SER=SER+COF(J)/X - END DO + ! ------------------------------------------------------ - GAMLN=TMP+LOG(STP*SER) - - END SUBROUTINE GAMMLN - - ! ******************************************************************** + real, allocatable, dimension (:,:) :: length_m + real, allocatable, dimension (:) :: length + + integer :: i,j,npix,ii + + real :: zi, zj + + npix = size (x) + allocate (length_m (1:npix,1:npix)) + allocate (length (1:npix)) + length_m =0. + length =0. + + do i = 1,npix + zi = 100. - x(i) - y(i) + if (.not. ext_point) then + x0 = x(i) + y0 = y(i) + z0 = zi + endif - SUBROUTINE FUNCIDEP( & - NAR0,IDEP, &!I - BEE,PSIS,POROS,COND,RZDEP,WPWET, &!I - VALX,PX,COESKEW,TIMEAN,SUMA, &!I - CATDEF,AR1,WMIN,AA,AABIS, &!O - AR2,AR3,SWSRF2,SWSRF3,RZEQ) - -!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -!c c -!c This program returns the eight parameters for the areal fractioning c -!c c -!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - - implicit none - integer, intent (in) :: NAR0,idep - REAL, intent (in) :: BEE, PSIS, POROS, COND, RZDEP, WPWET, COESKEW - REAL, intent (inout) :: VALX(NAR), PX(NAR),TIMEAN,SUMA -! logical, intent(in) :: bug - real, dimension (nbdep), intent (inout) :: CATDEF,AR1,WMIN,AA, & - AABIS,AR2,AR3,SWSRF2,SWSRF3,RZEQ - INTEGER :: width, nref, nind,nmax,indmin,locmax,shift,ord,locmin,ordref - integer :: indimax10,indmin0,k,n,n1,n2 - real dx,zbar - - real test,term1,term2,sum - real zdep(nar),locdef(nar),wrz(nar),frcunsat - real valtest(nbdep,nar),ptest(nbdep,nar),denstest(nbdep,nar) - real dtest(nbdep,nar),cump - real x1,x2,y1,y2,wa,wb - real densaux(nar),densaux2(nar),densmax,aux10 - real :: dz, sumdef -!c------------------------------------------------------------------------- - -!c integral(f(x)dx)=1. for a pdf -!c here px=f(x)dx - dx=valx(1)-valx(2) - - if (bug) write(*,*) 'IDEP=',IDEP,' dx=',dx - -!c the loops over idmax and nbdep are initiated in sta_params4.f - - zbar=float(idep-10)*slice ! zdep in meters - -!c**** Compute array of water table depths: - do k=1,nar0 - term1=(1/gnu)*(valx(k)-timean) - zdep(k)=AMAX1(0.,zbar-term1) - enddo - -!c variable change must be reflected in dx - dz=dx/gnu - - if (bug) write(*,*) 'funcidep: ok1' - -!c**** Compute array of moisture deficits: - do k=1,nar0 - term1=(psis-zdep(k))/psis - term1=term1**(1.-1./bee) - term2=-psis*(bee/(bee-1.))*(term1-1.) - locdef(k)=zdep(k)-term2 - enddo - -!c**** Add deficits to produce catdef: - sumdef=0. - do k=1,nar0 - sumdef=sumdef+locdef(k)*px(k) - enddo - catdef(idep)=poros*1000.*sumdef/suma - - if (bug) write(*,*) 'funcidep: ok2' - -!c**** Compute array of root zone moisture (degree of wetness in root zone): - do k=1,nar0 - term1=((psis-zdep(k))/psis) & - **(1.-1./bee) - if(zdep(k).le.0.) then - wrz(k)=1. - elseif(zdep(k)-rzdep.lt.0.) then - term2=(-psis/zdep(k))*(bee/(bee-1.)) & - *(term1-1.) - frcunsat=zdep(k)/rzdep - wrz(k)=frcunsat*term2+(1.-frcunsat)*1. - else - term2=((psis-zdep(k)+rzdep) & - /psis)**(1.-1./bee) - wrz(k)=(-psis/rzdep)*(bee/ & - (bee-1.))*(term1-term2) - endif - - enddo - - if (bug) write(*,*) 'funcidep: ok3' - -!c**** compute the densities and dx -!c**** we use a usefull property that is due to the construction of the -!c**** gamma distribution in tgen3.f : this distribution is continuous, -!c**** with decreasing values on ln(a/tanb) when n goes from 1 to nar0 - -!c first we gather in the same bin all the bins with values ge 1 - nref=1 - nind=1 - ptest(idep,1)=0. - do k=1,nar0 - if (wrz(k) .eq. 1.) then - nref=nref+1 - ptest(idep,1) = ptest(idep,1) + px(k) - endif - enddo - if (nref .gt. 1) then - nind=2 - valtest(idep,1)=1. - endif - nmax=nar0-nref+nind - if (bug) write(*,*) 'nmax,nind,nar0,nref=',nmax,nind,nar0,nref - -!c definition of the probabilities ptest - if (nmax .eq. 1) then ! all the bins have values ge 1 - dtest(idep,1) = 0.0001 - ptest(idep,1) = 1. - else ! distribution in ar2/ar3 - do n=0,nmax-nind - valtest(idep,nind+n)=wrz(nref+n) - ptest(idep,nind+n)=px(nref+n) - enddo - -!c we have to define dtest, the size of each bin - if (nmax .eq. 2) then - dtest(idep,2) = valtest(idep,1)-valtest(idep,2) - dtest(idep,1) = dtest(idep,2)/2. - else ! nmax .gt. 2 - do n=2,nmax-1 - dtest(idep,n)=(valtest(idep,n-1)-valtest(idep,n+1))/2. - enddo - dtest(idep,1) = dtest(idep,2)/2. - dtest(idep,nmax) = dtest(idep,nmax-1) - endif - endif - - if (bug) write(*,*) 'funcidep: ok4' - -!c we can now define the probability density: denstest=ptest/dtest -!c where ptest is the probability and dtest the size of the bin - do n=1,nmax - if (ptest(idep,n) .eq. 0.) then - denstest(idep,n)=0. - else - denstest(idep,n)=ptest(idep,n)/dtest(idep,n) - endif - enddo - - if (bug) write(*,*) 'funcidep: ok5' - -!c NOW we can estimate the parameters for the approximated distrib -!c from the actual distrib - -!c 1. AR1=saturated area and AR2 and AR3 + averages of the RZ wetness -!c in the different fractions - - ar1(idep)=0. - ar2(idep)=0. - ar3(idep)=0. - swsrf3(idep)=0. - swsrf2(idep)=0. - rzeq(idep)=0. - - if(valtest(idep,1).eq.1.) ar1(idep)=dtest(idep,1)*denstest(idep,1) - - if (nmax .gt. 1) then - do n=nind,nmax - if (valtest(idep,n) .lt. wpwet) then - ar3(idep)=ar3(idep)+denstest(idep,n)*dtest(idep,n) - swsrf3(idep)=swsrf3(idep)+valtest(idep,n)* & - denstest(idep,n)*dtest(idep,n) - else - ar2(idep)=ar2(idep)+denstest(idep,n)*dtest(idep,n) - swsrf2(idep)=swsrf2(idep)+valtest(idep,n)* & - denstest(idep,n)*dtest(idep,n) - endif - enddo - endif - - test=ar1(idep)+ar2(idep)+ar3(idep) - if (test .gt. 1.+1.e-5 .or. test .lt. 1.-1.e-5) then -! write(*,*) 'PROBLEM at depth ',zbar -! write(*,*) ' ar1+ar2+ar3=',test -! write(*,*) ' ar1=',ar1(idep),' ar2=',ar2(idep),' ar3=', & -! ar3(idep) - endif - - ar1(idep)=ar1(idep)/test - ar2(idep)=ar2(idep)/test - ar3(idep)=ar3(idep)/test - if (ar2(idep) .ne. 0.) swsrf2(idep)=swsrf2(idep)/ar2(idep) - if (ar3(idep) .ne. 0.) swsrf3(idep)=swsrf3(idep)/ar3(idep) - - rzeq(idep)=ar1(idep)+ar2(idep)*swsrf2(idep)+ar3(idep)*swsrf3(idep) - - if (bug) write(*,*) 'funcidep: ok6' - -!c 2. Maximum density -> shape parameter -!c -> wmin - - locmax=3 - shift=15 - ordref=1 - do n=1,nmax - densaux2(n)=denstest(idep,n) - enddo - - if (nmax .ge. shift*2) then - -!c we start with sliding mean to facilitate the search for the maximum - - ord=MIN(ordref,nmax/shift) - - call smtot(densaux2,nmax,ord,densaux) -! print *,nmax,ord,shift,densaux(shift-14),shift-14,size(densaux) - do n=nmax,shift,-1 - if (densaux(n) .gt. densaux(n-1) .and. & - densaux(n) .gt. densaux(n-2) .and. & - densaux(n) .gt. densaux(n-3) .and. & - densaux(n) .gt. densaux(n-4) .and. & - densaux(n) .gt. densaux(n-5) .and. & - densaux(n) .gt. densaux(n-6) .and. & - densaux(n) .gt. densaux(n-7) .and. & - densaux(n) .gt. densaux(n-8) .and. & - densaux(n) .gt. densaux(n-9) .and. & - densaux(n) .gt. densaux(n-10) .and. & - densaux(n) .gt. densaux(n-11) .and. & - densaux(n) .gt. densaux(n-12) .and. & - densaux(n) .gt. densaux(n-13) .and. & - densaux(n) .gt. densaux(n-14))then ! .and. & -! densaux(n) .gt. densaux(n-15)) then - locmax=n - goto 30 - endif - enddo - - else - - aux10=-9999. - indimax10=3 - do n=1,nmax - if (densaux2(n) .gt. aux10) then - aux10=densaux2(n) - indimax10=n - endif - enddo - locmax=MAX(3,indimax10) - ! add protection here in case nmax <3 . why 3 ? - if (locmax > nmax) locmax = nmax - endif ! if (nmax .ge. shift+1) - 30 densmax=denstest(idep,locmax) - aa(idep)=exp(1.)*densmax - - if (bug) write(*,*) 'funcidep: ok7' - -!c WMIN=lowest value where the density is strictly gt densmax/100. - - indmin=1 - indmin0=0 - do n=1,nmax - if (denstest(idep,n) .gt. 0.) indmin0=n - if (denstest(idep,n) .gt. densmax/100. .and. & - valtest(idep,n) .lt. valtest(idep,locmax)) indmin=n - enddo - if (indmin .eq.0) indmin=indmin0 - - if (indmin .le. 2) then - wmin(idep) = 0.99999 - else - x1=valtest(idep,indmin) - wmin(idep)=x1 - endif - - if (bug) write(*,*) 'funcidep: ok8; first wmin=',wmin(idep) - -!c for negative or low coeskew the previous wmin doesn't give good results... -!c wmin is higher !!! - - if (coeskew .lt. 1. ) then - - if (locmax .gt. 3 .and. indmin .ge. locmax+4) then - n2=MAX(locmax+1,(indmin-locmax)/2+locmax) - x2=valtest(idep,n2) - y2=denstest(idep,n2) - n1=locmax - x1=valtest(idep,n1) - y1=denstest(idep,n1) - wa=(y2-y1)/(x2-x1) - wb=y1-wa*x1 - wmin(idep)=AMAX1(wmin(idep),-wb/wa) - endif - -!c wmin is even higher in some cases !!! - if (coeskew .lt. 0.2 ) wmin(idep)=wmin(idep)+0.01 - - endif - - if (bug) write(*,*) 'funcidep: ok9; 2nd wmin=',wmin(idep) - - if (valtest(idep,locmax) .le. wmin(idep)) then ! doesn't make sense - wmin(idep)=valtest(idep,locmax)-dx - endif - aabis(idep)=1./(valtest(idep,locmax)-wmin(idep)+1.e-20) + do j = i,npix + zj = 100. - x(j) - y(j) + ! length_m (i,j) = abs (x(j) - x0) + & + ! abs (y(j) - y0) + abs (zj - z0) + ! + length_m (i,j) = ((x(j) - x0)*(x(j) - x0) & + + (y(j) - y0)*(y(j) - y0) & + + (zj - z0)*(zj - z0))**0.5 + length_m (j,i) = length_m (i,j) + end do + length (i) = sum(length_m (i,:)) + end do - if (bug) write(*,*) 'funcidep: ok10' + center_pix = minloc(length,dim=1) - END SUBROUTINE FUNCIDEP - - ! ******************************************************************** + END FUNCTION center_pix - SUBROUTINE FUNCZBAR( & - NAR0,ZBAR, & - BEE,PSIS,POROS,COND,RZDEP,WPWET, & - VALX,PX,COESKEW,TIMEAN,SUMA, & - CATDEF,WMIN) - -!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -!c c -!c This program returns the eight parameters for the areal fractioning c -!c c -!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - - implicit none - INTEGER , intent (in) :: NAR0 - integer nref,nind,nmax,indmin,locmax,shift,ord,locmin,ordref - integer indimax10,indmin0 - REAL, intent (in) :: BEE, PSIS, POROS, COND, RZDEP, WPWET, COESKEW - REAL, intent (inout) :: VALX(NAR), PX(NAR),TIMEAN,SUMA,zbar - real, intent (inout) :: catdef,wmin - - REAL dx,dz,sumdef - real term1,term2 - real zdep(nar),locdef(nar),wrz(nar),frcunsat - real valtest(nar),ptest(nar),denstest(nar),dtest(nar) - real x1,x2,y1,y2,wa,wb - integer n1,n2,k,n - real densaux(nar),densaux2(nar),densmax,aux10 - -!c------------------------------------------------------------------------- -!c integral(f(x)dx)=1. for a pdf -!c here px=f(x)dx - dx=valx(1)-valx(2) - -!c**** Compute array of water table depths: - do k=1,nar0 - term1=(1/gnu)*(valx(k)-timean) - zdep(k)=AMAX1(0.,zbar-term1) - enddo - -!c variable change must be reflected in dx - dz=dx/gnu - -!c**** Compute array of moisture deficits: - do k=1,nar0 - term1=(psis-zdep(k))/psis - term1=term1**(1.-1./bee) - term2=-psis*(bee/(bee-1.))*(term1-1.) - locdef(k)=zdep(k)-term2 - enddo - -!c**** Add deficits to produce catdef: - sumdef=0. - do k=1,nar0 - sumdef=sumdef+locdef(k)*px(k) - enddo - catdef=poros*1000.*sumdef/suma - -!c**** Compute array of root zone moisture (degree of wetness in root zone): - do k=1,nar0 - term1=((psis-zdep(k))/psis) & - **(1.-1./bee) - if(zdep(k).le.0.) then - wrz(k)=1. - elseif(zdep(k)-rzdep.lt.0.) then - term2=(-psis/zdep(k))*(bee/(bee-1.)) & - *(term1-1.) - frcunsat=zdep(k)/rzdep - wrz(k)=frcunsat*term2+(1.-frcunsat)*1. - else - term2=((psis-zdep(k)+rzdep) & - /psis)**(1.-1./bee) - wrz(k)=(-psis/rzdep)*(bee/ & - (bee-1.))*(term1-term2) - endif - enddo - -!c**** compute the densities and dx -!c**** we use a usefull property that is due to the construction of the -!c**** gamma distribution in tgen3.f : this distribution is continuous, -!c**** with decreasing values on ln(a/tanb) when n goes from 1 to nar0 -!c first we gather in the same bin all the bins with values ge 1 - nref=1 - nind=1 - ptest(1)=0. - do k=1,nar0 - if (wrz(k) .eq. 1.) then - nref=nref+1 - ptest(1) = ptest(1) + px(k) - endif - enddo - if (nref .gt. 1) then - nind=2 - valtest(1)=1. - endif - nmax=nar0-nref+nind - -!c definition of the probabilities ptest - if (nmax .eq. 1) then ! all the bins have values ge 1 - dtest(1) = 0.0001 - ptest(1) = 1. - else ! distribution in ar2/ar3 - do n=0,nmax-nind - valtest(nind+n)=wrz(nref+n) - ptest(nind+n)=px(nref+n) - enddo - -!c we have to define dtest, the size of each bin - if (nmax .eq. 2) then - dtest(2) = valtest(1)-valtest(2) - dtest(1) = dtest(2)/2. - else ! nmax .gt. 2 - do n=2,nmax-1 - dtest(n)=(valtest(n-1)-valtest(n+1))/2. - enddo - dtest(1) = dtest(2)/2. - dtest(nmax) = dtest(nmax-1) - endif - endif - -!c we can now define the probability density: denstest=ptest/dtest -!c where ptest is the probability and dtest the size of the bin - do n=1,nmax - if (ptest(n) .eq. 0.) then - denstest(n)=0. - else - denstest(n)=ptest(n)/dtest(n) - endif - enddo - -!c NOW we can estimate the parameters for the approximated distrib -!c from the actual distrib - -!c 2. Maximum density -> shape parameter -!c -> wmin - - locmax=3 - shift=15 - ordref=1 - do n=1,nmax - densaux2(n)=denstest(n) - enddo - - if (nmax .ge. shift*2) then - -!c we start with sliding mean to facilitate the search for the maximum - - ord=MIN(ordref,nmax/shift) - call smtot(densaux2,nmax,ord,densaux) - - do n=nmax,shift,-1 - if (densaux(n) .gt. densaux(n-1) .and. & - densaux(n) .gt. densaux(n-2) .and. & - densaux(n) .gt. densaux(n-3) .and. & - densaux(n) .gt. densaux(n-4) .and. & - densaux(n) .gt. densaux(n-5) .and. & - densaux(n) .gt. densaux(n-6) .and. & - densaux(n) .gt. densaux(n-7) .and. & - densaux(n) .gt. densaux(n-8) .and. & - densaux(n) .gt. densaux(n-9) .and. & - densaux(n) .gt. densaux(n-10) .and. & - densaux(n) .gt. densaux(n-11) .and. & - densaux(n) .gt. densaux(n-12) .and. & - densaux(n) .gt. densaux(n-13) .and. & - densaux(n) .gt. densaux(n-14)) then ! .and. & - !densaux(n) .gt. densaux(n-15)) then - locmax=n - goto 30 - endif - enddo - - else - - aux10=-9999. - indimax10=3 - do n=1,nmax - if (densaux2(n) .gt. aux10) then - aux10=densaux2(n) - indimax10=n - endif - enddo - locmax=MAX(3,indimax10) - ! in case nmax < 3. why hard coded 3? - if(locmax > nmax) locmax = nmax - endif ! if (nmax .ge. shift+1) - - 30 densmax=denstest(locmax) - -!c WMIN=lowest value where the density is strictly gt densmax/100. - - indmin=1 - indmin0=0 - do n=1,nmax - if (denstest(n) .gt. 0.) indmin0=n - if (denstest(n) .gt. densmax/100. .and. & - valtest(n) .lt. valtest(locmax)) indmin=n - enddo - if (indmin .eq. 0) indmin=indmin0 - - if (indmin .le. 2) then - wmin = 0.99999 - else - x1=valtest(indmin) - wmin=x1 - endif - -!c for negative or low coeskew the previous wmin doesn't give good results... -!c wmin is higher !!! - - if (coeskew .lt. 1. ) then - - if (locmax .gt. 3 .and. indmin .ge. locmax+4) then - - n2=MAX(locmax+1,(indmin-locmax)/2+locmax) - x2=valtest(n2) - y2=denstest(n2) - n1=locmax - x1=valtest(n1) - y1=denstest(n1) - wa=(y2-y1)/(x2-x1) - wb=y1-wa*x1 - wmin=AMAX1(wmin,-wb/wa) - endif - -!c wmin is even higher in some cases !!! - if (coeskew .lt. 0.2 ) wmin=wmin+0.01 - - endif - - END SUBROUTINE FUNCZBAR - -! ****************************************************************** - - SUBROUTINE RMSE(XX,YY,LEN,ERROR) - -!c--------------------------------------------------------------------------- -!c Computes the root-mean square error ERROR between two one-dimensional -!c random variables XX and YY of same length LEN -!c--------------------------------------------------------------------------- - - IMPLICIT NONE - - INTEGER, intent (in) :: LEN - REAL, intent (in) :: XX(LEN),YY(LEN) - REAL, intent (out) :: ERROR - INTEGER :: I - -!c--------------------------------------------------------------------------- - error=0. - do i=1,len - if(abs(xx(i)-yy(i)) >=1.e-10) then - error=error+(xx(i)-yy(i))*(xx(i)-yy(i)) - endif - enddo - error=SQRT(error/float(len)) - - END SUBROUTINE RMSE - -! ****************************************************************** - SUBROUTINE SMTOT(XX,LEN,ORD,YY) - -!c--------------------------------------------------------------------------- -!c Runs a sliding average of order ORD through the one-dimensional array XX -!c of length LEN and returns the smoothed YY -!!c--------------------------------------------------------------------------- - - IMPLICIT NONE - - INTEGER, intent (in) :: LEN - INTEGER :: ORD,WIDTH,i,ini,n,end - REAL, intent (in) :: XX(NAR) - REAL, intent (out) :: YY(NAR) - -!c--------------------------------------------------------------------------- - do i=1,nar - yy(i)=0. - enddo - - width=ord*2+1 - if (width .gt. len/2) then - write(*,*) 'the order for the sliding average is too large !!!' - write(*,*) 'regard with the length of the array to be smoothed' - stop - endif - - do i=1,len - ini=MAX(1,i-ord) - end=MIN(len,i+ord) - yy(i)=0. - do n=ini,end - yy(i)=yy(i)+xx(n) - enddo - yy(i)=yy(i)/(end-ini+1) - enddo - - END SUBROUTINE SMTOT - -! ----------------------------------------------------------------------------------- - -subroutine RegridRaster(Rin,Rout) - - ! primitive regridding of integer values from 2-dim array Rin to 2-dim array Rout ! - ! If Rout is higher-resolution than Rin, result should be fine: - ! An Rout grid cell is assigned the value of the Rin grid cell that - ! contains the center of the Rout grid cell (oversampling). - ! If Rin is higher-resolution than Rout, result is questionable: - ! An Rout grid cell is assigned the value of the Rin grid cell that is - ! near the *corner* of the Rout grid cell. See notes below. - - integer, intent(IN) :: Rin( :,:) - integer, intent(OUT) :: Rout(:,:) - - REAL(KIND=8) :: xx, yy - integer :: i, j, ii, jj - integer :: Nx_in, Ny_in, Nx_out, Ny_out - - Nx_in = size(Rin ,1) - Ny_in = size(Rin ,2) + !---------------------------------------------------------- + ! - Nx_out = size(Rout,1) - Ny_out = size(Rout,2) - - !if ( (Nx_in==Nx_out) .and. (Ny_in==Ny_out) ) then - if (.false.) then - - ! avoid loop through output grid cells - - Rout = Rin ! [??] MAY NOT BE 0-DIFF B/C OF MIXED-MODE ARITHMETIC IN LOOP!?!?!? - - else - - ! NOTE: float() yields real*4 but xx was declared real*8 - - xx = Nx_in/float(Nx_out) ! WARNING: mixed mode arithmentic!!! - yy = Ny_in/float(Ny_out) ! WARNING: mixed mode arithmentic!!! - - do j=1,Ny_out - - ! NOTE: When Rin is finer resolution than Rout, the below use of - ! ii = (i-1)*xx + 1 (1a) - ! jj = (j-1)*yy + 1 (1b) - ! implies that Rout(i,j) is assigned the Rin(ii,jj) value near a corner of - ! the (ii,jj) output grid cell, which effectively results in a shift of the - ! data by 1/2 of the width of the output grid cell. This shift could - ! presumably minimized by using - ! ii = NINT( (i-1)*xx + xx/2 ) (2a) - ! jj = NINT( (j-1)*yy + yy/2 ) (2b) - ! - ! HOWEVER, equations (2a) and (2b) are preferable when Rout is finer resolution - ! than Rin, in which case Rout should just be oversampling of Rin. - - jj = (j-1)*yy + 1 ! WARNING: mixed mode arithmetic!!! Note implied "floor()" operator. - do i=1,Nx_out - ii = (i-1)*xx + 1 ! WARNING: mixed mode arithmetic!!! Note implied "floor()" operator. - Rout(i,j) = Rin(ii,jj) - end do - end do - - end if - -end subroutine RegridRaster + INTEGER FUNCTION soil_class (min_perc) -! ----------------------------------------------------------------------------------- + ! Function returns a unique soil class [1-100], -subroutine RegridRaster1(Rin,Rout) + type(mineral_perc), intent (in) :: min_perc - ! same as RegridRaster() but for gridded integer*1 values + ! ------------------------------------------------ + + integer :: clay_row, sand_row, silt_row - integer*1, intent(IN) :: Rin( :,:) - integer*1, intent(OUT) :: Rout(:,:) + clay_row = ceiling((100.- min_perc%clay_perc)/10.) + if(clay_row == 0 ) clay_row = 1 + if(clay_row == 11) clay_row = 10 - REAL(KIND=8) :: xx, yy - integer :: i, j, ii, jj - integer :: Nx_in, Ny_in, Nx_out, Ny_out - - Nx_in = size(Rin ,1) - Ny_in = size(Rin ,2) + sand_row = ceiling((min_perc%sand_perc)/10.) + if(sand_row == 0 ) sand_row = 1 + if(sand_row == 11) sand_row = 10 - Nx_out = size(Rout,1) - Ny_out = size(Rout,2) - - !if ( (Nx_in==Nx_out) .and. (Ny_in==Ny_out) ) then - if (.false.) then - - Rout = Rin - - else - - xx = Nx_in/float(Nx_out) - yy = Ny_in/float(Ny_out) - - do j=1,Ny_out - jj = (j-1)*yy + 1 - do i=1,Nx_out - ii = (i-1)*xx + 1 - Rout(i,j) = Rin(ii,jj) - end do - end do - - end if - -end subroutine RegridRaster1 - -! ----------------------------------------------------------------------------------- - -subroutine RegridRaster2(Rin,Rout) - - ! same as RegridRaster() but for gridded integer*2 values - - integer(kind=2), intent(IN) :: Rin( :,:) - integer(kind=2), intent(OUT) :: Rout(:,:) - - REAL(KIND=8) :: xx, yy - integer :: i, j, ii, jj - integer :: Nx_in, Ny_in, Nx_out, Ny_out - - Nx_in = size(Rin ,1) - Ny_in = size(Rin ,2) + silt_row = ceiling((min_perc%silt_perc)/10.) + if(silt_row == 0 ) silt_row = 1 + if(silt_row == 11) silt_row = 10 - Nx_out = size(Rout,1) - Ny_out = size(Rout,2) - - !if ( (Nx_in==Nx_out) .and. (Ny_in==Ny_out) ) then - if (.false.) then - - Rout = Rin - - else - - xx = Nx_in/float(Nx_out) - yy = Ny_in/float(Ny_out) - - do j=1,Ny_out - jj = (j-1)*yy + 1 - do i=1,Nx_out - ii = (i-1)*xx + 1 - Rout(i,j) = Rin(ii,jj) - end do - end do - - end if - -end subroutine RegridRaster2 - -! ----------------------------------------------------------------------------------- - -subroutine RegridRasterReal(Rin,Rout) - - ! same as RegridRaster() but for gridded real values - - real, intent(IN) :: Rin( :,:) - real, intent(OUT) :: Rout(:,:) - - REAL(KIND=8) :: xx, yy - integer :: i, j, ii, jj - integer :: Nx_in, Ny_in, Nx_out, Ny_out - - Nx_in = size(Rin ,1) - Ny_in = size(Rin ,2) + if(clay_row == 1) soil_class=1 - Nx_out = size(Rout,1) - Ny_out = size(Rout,2) - - !if ( (Nx_in==Nx_out) .and. (Ny_in==Ny_out) ) then - if (.false.) then - - Rout = Rin - - else - - xx = Nx_in/float(Nx_out) - yy = Ny_in/float(Ny_out) - - do j=1,Ny_out - jj = (j-1)*yy + 1 - do i=1,Nx_out - ii = (i-1)*xx + 1 - Rout(i,j) = Rin(ii,jj) - end do - end do - - end if - -end subroutine RegridRasterReal - -!--------------------------------------------------------------------- - - SUBROUTINE svbksb(u,w,v,m,n,b,x) - implicit none - INTEGER m,mp,n,np,NMAX - REAL*8 b(m),u(m,n),v(n,n),w(n),x(n) - PARAMETER (NMAX=500) !Maximum anticipated value of n - !------------------------------------------------------------------------------------------- - ! Solves A · X = B for a vector X, where A is specified by the arrays u, w, v as returned by - ! svdcmp. m and n are the dimensions of a, and will be equal for square matrices. b(1:m) is - ! the input right-hand side. x(1:n) is the output solution vector. No input quantities are - ! destroyed, so the routine may be called sequentially with different b’s. - !------------------------------------------------------------------------------------------- - - INTEGER i,j,jj - REAL*8 s,tmp(NMAX) - do j=1,n !Calculate UTB. - s=0. - if(w(j).ne.0.)then !Nonzero result only if wj is nonzero. - do i=1,m - s=s+u(i,j)*b(i) - end do - s=s/(w(j) + 1.d-20) !This is the divide by wj . - endif - tmp(j)=s - end do - do j=1,n !Matrix multiply by V to get answer. - s=0. - do jj=1,n - s=s+v(j,jj)*tmp(jj) - end do - x(j)=s - end do - return - END SUBROUTINE svbksb - -!--------------------------------------------------------------------- - - SUBROUTINE svdcmp(a,m,n,w,v) - implicit none - INTEGER m,n,NMAX - REAL*8, intent (inout) :: a(m,n) - REAL*8, intent (out) :: v(n,n),w(n) - PARAMETER (NMAX=500) !Maximum anticipated value of n. - !-------------------------------------------------------------------------------------- - ! Given a matrix A(1:m,1:n), this routine computes its singular value decomposition, - ! A = U · W · Vt. The matrix U replaces A on output. The diagonal matrix of singular - ! values W is output as a vector W(1:n). The matrix V (not the transpose Vt) is output - ! as V(1:n,1:n). - !-------------------------------------------------------------------------------------- - - INTEGER i,its,j,jj,k,l,nm - REAL*8 anorm,c,f,g,h,s,scale,x,y,z,rv1(NMAX) - real*8, parameter :: EPS=epsilon(1.0d0) - g=0.d0 !Householder reduction to bidiagonal form. - scale=0.d0 - anorm=0.d0 - c =0.d0 - f =0.d0 - g =0.d0 - h =0.d0 - s =0.d0 - x =0.d0 - y =0.d0 - z =0.d0 - rv1=0.d0 - w = 0.d0 - v = 0.d0 - do i=1,n - l=i+1 - rv1(i)=scale*g - g=0.d0 - s=0.d0 - scale=0.d0 - if(i.le.m)then - do k=i,m - scale=scale+abs(a(k,i)) - end do - if(scale.ne.0.d0)then - do k=i,m - a(k,i)=a(k,i)/scale - s=s+a(k,i)*a(k,i) - end do - f=a(i,i) - g=-dsign(dsqrt(s),f) - h=f*g-s - a(i,i)=f-g - do j=l,n - s=0.d0 - do k=i,m - s=s+a(k,i)*a(k,j) - end do - f=s/h - do k=i,m - a(k,j)=a(k,j)+f*a(k,i) - end do - end do - do k=i,m - a(k,i)=scale*a(k,i) - end do - endif - endif - w(i)=scale *g - g=0.d0 - s=0.d0 - scale=0.d0 - if((i.le.m).and.(i.ne.n))then - do k=l,n - scale=scale+abs(a(i,k)) - end do - if(scale.ne.0.d0)then - do k=l,n - a(i,k)=a(i,k)/scale - s=s+a(i,k)*a(i,k) - end do - f=a(i,l) - g=-sign(sqrt(s),f) - h=f*g-s - a(i,l)=f-g - do k=l,n - rv1(k)=a(i,k)/h - end do - do j=l,m - s=0.d0 - do k=l,n - s=s+a(j,k)*a(i,k) - end do - do k=l,n - a(j,k)=a(j,k)+s*rv1(k) - end do - end do - do k=l,n - a(i,k)=scale*a(i,k) - end do - endif - endif - anorm=max(anorm,(abs(w(i))+abs(rv1(i)))) - end do !do i=1,n - - do i=n,1,-1 !Accumulation of right-hand transformations. - if(i.lt.n)then - if(g.ne.0.d0)then - do j=l,n !Double division to avoid possible underflow. - v(j,i)=(a(i,j)/a(i,l))/g - end do - do j=l,n - s=0.d0 - do k=l,n - s=s+a(i,k)*v(k,j) - end do - do k=l,n - v(k,j)=v(k,j)+s*v(k,i) - end do - end do - endif - do j=l,n - v(i,j)=0.d0 - v(j,i)=0.d0 - end do - endif - v(i,i)=1.d0 - g=rv1(i) - l=i - end do - - do i=min(m,n),1,-1 !Accumulation of left-hand transformations. - l=i+1 - g=w(i) - do j=l,n - a(i,j)=0.d0 - end do - if(g.ne.0.d0)then - g=1.d0/g - do j=l,n - s=0.d0 - do k=l,m - s=s+a(k,i)*a(k,j) - end do - f=(s/a(i,i))*g - do k=i,m - a(k,j)=a(k,j)+f*a(k,i) - end do - end do - do j=i,m - a(j,i)=a(j,i)*g - end do - else - do j= i,m - a(j,i)=0.d0 - end do - endif - a(i,i)=a(i,i)+1.d0 - end do - - do k=n,1,-1 !Diagonalization of the bidiagonal form: Loop over - !singular values, and over allowed iterations. - do its=1,30 - do l=k,1,-1 !Test for splitting. - nm=l-1 !Note that rv1(1) is always zero. - if( abs(rv1(l)) <= EPS*anorm ) goto 2 - if( abs(w(nm) ) <= EPS*anorm ) goto 1 - end do -1 c=0.d0 !Cancellation of rv1(l), if l > 1. - s=1.d0 - do i=l,k - f=s*rv1(i) - rv1(i)=c*rv1(i) - if( abs(f) <= EPS*anorm ) goto 2 - g=w(i) - h=pythag(f,g) - w(i)=h - h=1.d0/h - c= (g*h) - s=-(f*h) - do j=1,m - y=a(j,nm) - z=a(j,i) - a(j,nm)=(y*c)+(z*s) - a(j,i)=-(y*s)+(z*c) - end do - end do -2 z=w(k) - if(l.eq.k)then !Convergence. - if(z.lt.0.d0)then !Singular value is made nonnegative. - w(k)=-z - do j=1,n - v(j,k)=-v(j,k) - end do - endif - goto 3 - endif - if(its.eq.30) print *, 'no convergence in svdcmp' - ! if(its.ge.4) print *, 'its = ',its - x=w(l) !Shift from bottom 2-by-2 minor. - nm=k-1 - y=w(nm) - g=rv1(nm) - h=rv1(k) - f=((y-z)*(y+z)+(g-h)*(g+h))/(2.0*h*y) - g=pythag(f,1.d0) - f=((x-z)*(x+z)+h*((y/(f+sign(g,f)))-h))/x - c=1.d0 !Next QR transformation: - s=1.d0 - do j=l,nm - i=j+1 - g=rv1(i) - y=w(i) - h=s*g - g=c*g - z=pythag(f,h) - rv1(j)=z - c=f/z - s=h/z - f= (x*c)+(g*s) - g=-(x*s)+(g*c) - h=y*s - y=y*c - do jj=1,n - x=v(jj,j) - z=v(jj,i) - v(jj,j)= (x*c)+(z*s) - v(jj,i)=-(x*s)+(z*c) - end do - z=pythag(f,h) - w(j)=z !Rotation can be arbitrary if z = 0. - if(z.ne.0.d0)then - z=1.d0/z - c=f*z - s=h*z - endif - f= (c*g)+(s*y) - x=-(s*g)+(c*y) - do jj=1,m - y=a(jj,j) - z=a(jj,i) - a(jj,j)= (y*c)+(z*s) - a(jj,i)=-(y*s)+(z*c) - end do - end do !j=l;nm - rv1(l)=0.d0 - rv1(k)=f - w(k)=x - end do !its=1,30 -3 continue - end do !k=n,1,-1 - return - END SUBROUTINE svdcmp -! -! ________________________________________________________________________________ -! - REAL*8 FUNCTION pythag(a,b) - REAL*8 a,b - !Computes sqrt(a**2 + b**2) without destructive underflow or overflow. - REAL*8 absa,absb - absa=abs(a) - absb=abs(b) - if(absa.gt.absb)then - pythag=absa*sqrt(1.+(absb/absa)**2) - else - if(absb.eq.0.)then - pythag=0. - else - pythag=absb*sqrt(1.+(absa/absb)**2) - endif - endif - return - END FUNCTION pythag -! -! ________________________________________________________________________________ -! - - SUBROUTINE savgol(c,np,nl,nr,ld,m) - implicit none - INTEGER ld,m,nl,np,nr,MMAX - real c(np) - PARAMETER (MMAX=6) -!-------------------------------------------------------------------------------------------- -!USES lubksb,ludcmp given below. -!Returns in c(1:np), in wrap-around order (see reference) consistent with the argument respns -!in routine convlv, a set of Savitzky-Golay filter coefficients. nl is the number of leftward -!(past) data points used, while nr is the number of rightward (future) data points, making -!the total number of data points used nl +nr+1. ld is the order of the derivative desired -!(e.g., ld = 0 for smoothed function). m is the order of the smoothing polynomial, also -!equal to the highest conserved moment; usual values are m = 2 or m = 4. -!-------------------------------------------------------------------------------------------- -INTEGER d,icode,imj,ipj,j,k,kk,mm,indx(MMAX+1) -real fac,sum,a(MMAX+1,MMAX+1),b(MMAX+1) -if(np.lt.nl+nr+1.or.nl.lt.0.or.nr.lt.0.or.ld.gt.m.or.m.gt.MMAX & - .or.nl+nr.lt.m) pause ' Bad args in savgol.' - do ipj=0,2*m !Set up the normal equations of the desired leastsquares fit. - sum=0. - if(ipj.eq.0) sum=1. - do k=1,nr - sum=sum+dfloat(k)**ipj - end do - do k=1,nl - sum=sum+dfloat(-k)**ipj - end do - mm=min(ipj,2*m-ipj) - do imj=-mm,mm,2 - a(1+(ipj+imj)/2,1+(ipj-imj)/2)=sum - end do - end do - - call ludcmp(a,m+1,MMAX+1,indx,d,icode) !Solve them: LU decomposition. - - do j=1,m+1 - b(j)=0. - end do - b(ld+1)=1. !Right-hand side vector is unit vector, depending on which derivative we want. - - call lubksb(a,m+1,MMAX+1,indx,b) !Backsubstitute, giving one row of the inverse matrix. - - do kk=1,np !Zero the output array (it may be bigger than the number - c(kk)=0. !of coefficients). - end do - do k=-nl,nr !Each Savitzky-Golay coefficient is the dot product - sum=b(1) !of powers of an integer with the inverse matrix row. - fac=1. - do mm=1,m - fac=fac*k - sum=sum+b(mm+1)*fac - end do - kk=mod(np-k,np)+1 !Store in wrap-around order. - c(kk)=sum - end do - return -END SUBROUTINE savgol - -!*************************************************************** -!* Given an N x N matrix A, this routine replaces it by the LU * -!* decomposition of a rowwise permutation of itself. A and N * -!* are input. INDX is an output vector which records the row * -!* permutation effected by the partial pivoting; D is output * -!* as -1 or 1, depending on whether the number of row inter- * -!* changes was even or odd, respectively. This routine is used * -!* in combination with LUBKSB to solve linear equations or to * -!* invert a matrix. Return code is 1, if matrix is singular. * -!*************************************************************** - Subroutine LUDCMP(A,N,NP,INDX,D,CODE) -INTEGER, PARAMETER :: NMAX=100 -REAL, PARAMETER :: TINY=1E-12 - real AMAX,DUM, SUM, A(NP,NP),VV(NMAX) - INTEGER CODE, D, INDX(N),NP,N,I,J,K,IMAX - - D=1; CODE=0 - - DO I=1,N - AMAX=0. - DO J=1,N - IF (ABS(A(I,J)).GT.AMAX) AMAX=ABS(A(I,J)) - END DO ! j loop - IF(AMAX.LT.TINY) THEN - CODE = 1 - RETURN - END IF - VV(I) = 1. / AMAX - END DO ! i loop - - DO J=1,N - DO I=1,J-1 - SUM = A(I,J) - DO K=1,I-1 - SUM = SUM - A(I,K)*A(K,J) - END DO ! k loop - A(I,J) = SUM - END DO ! i loop - AMAX = 0. - DO I=J,N - SUM = A(I,J) - DO K=1,J-1 - SUM = SUM - A(I,K)*A(K,J) - END DO ! k loop - A(I,J) = SUM - DUM = VV(I)*ABS(SUM) - IF(DUM.GE.AMAX) THEN - IMAX = I - AMAX = DUM - END IF - END DO ! i loop - - IF(J.NE.IMAX) THEN - DO K=1,N - DUM = A(IMAX,K) - A(IMAX,K) = A(J,K) - A(J,K) = DUM - END DO ! k loop - D = -D - VV(IMAX) = VV(J) - END IF - - INDX(J) = IMAX - IF(ABS(A(J,J)) < TINY) A(J,J) = TINY - - IF(J.NE.N) THEN - DUM = 1. / A(J,J) - DO I=J+1,N - A(I,J) = A(I,J)*DUM - END DO ! i loop - END IF - END DO ! j loop - - RETURN - END Subroutine LUDCMP - - -!****************************************************************** -!* Solves the set of N linear equations A . X = B. Here A is * -!* input, not as the matrix A but rather as its LU decomposition, * -!* determined by the routine LUDCMP. INDX is input as the permuta-* -!* tion vector returned by LUDCMP. B is input as the right-hand * -!* side vector B, and returns with the solution vector X. A, N and* -!* INDX are not modified by this routine and can be used for suc- * -!* cessive calls with different right-hand sides. This routine is * -!* also efficient for plain matrix inversion. * -!****************************************************************** - Subroutine LUBKSB(A,N,NP,INDX,B) - INTEGER :: II,I,J,LL,N,NP - real SUM, A(NP,NP),B(N) - INTEGER INDX(N) - - II = 0 - - DO I=1,N - LL = INDX(I) - SUM = B(LL) - B(LL) = B(I) - IF(II.NE.0) THEN - DO J=II,I-1 - SUM = SUM - A(I,J)*B(J) - END DO ! j loop - ELSE IF(SUM.NE.0.) THEN - II = I - END IF - B(I) = SUM - END DO ! i loop - - DO I=N,1,-1 - SUM = B(I) - IF(I < N) THEN - DO J=I+1,N - SUM = SUM - A(I,J)*B(J) - END DO ! j loop - END IF - B(I) = SUM / A(I,I) - END DO ! i loop - - RETURN - END Subroutine LUBKSB + if(clay_row > 1) soil_class= & + (clay_row - 1)*(clay_row - 1) + (clay_row - sand_row) + silt_row -! -! ==================================================================== -! + end FUNCTION soil_class -INTEGER FUNCTION center_pix (x,y,x0,y0,z0,ext_point) - -implicit none - -real, dimension (:), intent (in) :: x,y -real, allocatable, dimension (:,:) :: length_m -real, allocatable, dimension (:) :: length -real, intent (inout) :: x0,y0,z0 -integer :: i,j,npix,ii -logical, intent(in) :: ext_point -real :: zi, zj - -npix = size (x) -allocate (length_m (1:npix,1:npix)) -allocate (length (1:npix)) -length_m =0. -length =0. - -do i = 1,npix - zi = 100. - x(i) - y(i) - if (.not. ext_point) then - x0 = x(i) - y0 = y(i) - z0 = zi - endif - - do j = i,npix - zj = 100. - x(j) - y(j) -! length_m (i,j) = abs (x(j) - x0) + & -! abs (y(j) - y0) + abs (zj - z0) -! - length_m (i,j) = ((x(j) - x0)*(x(j) - x0) & - + (y(j) - y0)*(y(j) - y0) & - + (zj - z0)*(zj - z0))**0.5 - length_m (j,i) = length_m (i,j) - end do - length (i) = sum(length_m (i,:)) -end do + ! ----------------------------------------------------------------------------------- -center_pix = minloc(length,dim=1) + SUBROUTINE REFORMAT_VEGFILES -END FUNCTION center_pix + character*512 :: tmp_string + integer :: n_tiles + real, dimension (:), allocatable :: var_array + character*512 :: header + real :: a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13,a14 + integer :: month -! -!---------------------------------------------------------- -! + tmp_string = 'mkdir -p '//'clsm/g5fmt' + call execute_command_line(tmp_string) + tmp_string = '/bin/mv '//'clsm/lai.dat ' //'clsm/g5fmt/.' + call execute_command_line(tmp_string) + tmp_string = '/bin/mv '//'clsm/green.dat ' //'clsm/g5fmt/.' + call execute_command_line(tmp_string) -INTEGER FUNCTION soil_class (min_perc) + open (10,file='clsm/g5fmt/lai.dat' , form = 'unformatted', & + convert='little_endian',status='old',action='read' ) + open (11,file='clsm/g5fmt/green.dat', form = 'unformatted', & + convert='little_endian',status='old',action='read' ) -! Function returns a unique soil class [1-100], + open (20,file='clsm/lai.dat', form = 'unformatted', & + convert='big_endian',status='unknown',action='write' ) + open (21,file='clsm/green.dat', form = 'unformatted', & + convert='big_endian',status='unknown',action='write' ) -IMPLICIT NONE -type(mineral_perc), intent (in) :: min_perc -!real, intent (in) :: clay_perc,silt_perc,sand_perc -integer :: clay_row, sand_row, silt_row + open (30,file='clsm/catchment.def', form = 'formatted',status='old',action='read' ) + read (30,*) n_tiles + close(30,status='keep') -clay_row = ceiling((100.- min_perc%clay_perc)/10.) -if(clay_row == 0 ) clay_row = 1 -if(clay_row == 11) clay_row = 10 + allocate (var_array (1:n_tiles)) -sand_row = ceiling((min_perc%sand_perc)/10.) -if(sand_row == 0 ) sand_row = 1 -if(sand_row == 11) sand_row = 10 + read (10) header + read (10) var_array + read (11) header + read (11) var_array -silt_row = ceiling((min_perc%silt_perc)/10.) -if(silt_row == 0 ) silt_row = 1 -if(silt_row == 11) silt_row = 10 + do month =1,12 -if(clay_row == 1) soil_class=1 + read (10) a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13,a14 + read (10) var_array + print '(12f3.0,f4.00,f2.0,a6,2f6.2)',a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13,a14,'LAI ',minval(var_array),maxval(var_array) + write (20)var_array(:) + read (11) a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13,a14 + read (11) var_array + print '(12f3.0,f4.00,f2.0,a6,2f6.2)',a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13,a14,'GREEN ',minval(var_array),maxval(var_array) + write (21)var_array(:) + end do -if(clay_row > 1) soil_class= & - (clay_row - 1)*(clay_row - 1) + (clay_row - sand_row) + silt_row + END SUBROUTINE REFORMAT_VEGFILES -end FUNCTION soil_class + ! + ! -------------------------------------------------------- + ! + ! SUBROUTINE compute_stats (ndata,cti_val,mu,sig,sk) + ! + ! Subroutine not used as of 24 Dec 2024; removed by reichle, 24 Dec 2024 + ! + ! ----------------------------------------------------------------------------------- + + SUBROUTINE ascat_r0 (nc,nr, ntiles,tile_id, z0) -! ----------------------------------------------------------------------------------- -! ----------------------------------------------------------------------------------- -! ----------------------------------------------------------------------------------- + ! 1) ASCAT roughness + ! /discover/nobackup/adarmeno/projects/k14/arlems-roughness.x3600_y1800_t1.nc4 -SUBROUTINE REFORMAT_VEGFILES - implicit none - character*400 :: tmp_string - integer :: n_tiles - real, dimension (:), allocatable :: var_array - character*40 :: header - real :: a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13,a14 - integer :: month - - tmp_string = 'mkdir -p '//'clsm/g5fmt' - call execute_command_line(tmp_string) - tmp_string = '/bin/mv '//'clsm/lai.dat ' //'clsm/g5fmt/.' - call execute_command_line(tmp_string) - tmp_string = '/bin/mv '//'clsm/green.dat ' //'clsm/g5fmt/.' - call execute_command_line(tmp_string) - - open (10,file='clsm/g5fmt/lai.dat' , form = 'unformatted', & - convert='little_endian',status='old',action='read' ) - open (11,file='clsm/g5fmt/green.dat', form = 'unformatted', & - convert='little_endian',status='old',action='read' ) - - open (20,file='clsm/lai.dat', form = 'unformatted', & - convert='big_endian',status='unknown',action='write' ) - open (21,file='clsm/green.dat', form = 'unformatted', & - convert='big_endian',status='unknown',action='write' ) - - open (30,file='clsm/catchment.def', form = 'formatted',status='old',action='read' ) - read (30,*) n_tiles - close(30,status='keep') - - allocate (var_array (1:n_tiles)) - - read (10) header - read (10) var_array - read (11) header - read (11) var_array - - do month =1,12 - - read (10) a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13,a14 - read (10) var_array - print '(12f3.0,f4.00,f2.0,a6,2f6.2)',a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13,a14,'LAI ',minval(var_array),maxval(var_array) - write (20)var_array(:) - read (11) a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13,a14 - read (11) var_array - print '(12f3.0,f4.00,f2.0,a6,2f6.2)',a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13,a14,'GREEN ',minval(var_array),maxval(var_array) - write (21)var_array(:) - end do - -END SUBROUTINE REFORMAT_VEGFILES + integer, intent(in) :: nc, nr + integer, intent(in) :: ntiles + INTEGER, intent(in) :: tile_id(:,:) -! -! -------------------------------------------------------- -! + real, pointer, dimension (:), intent(inout) :: z0 -SUBROUTINE compute_stats (ndata,cti_val,mu,sig,sk) - -implicit none -integer, intent(in) :: ndata -real, intent(inout), dimension(ndata) :: cti_val -real, intent(out) :: mu,sig,sk -integer :: i,j -real :: del - - mu = sum(cti_val(1:ndata))/float(ndata) - sig = 0. - sk = 0. - del = 0. - - do i = 1,ndata - del = CTI_VAL(i) - mu - sig = sig + del**2 - sk = sk + (del*del*del) - end do - - sig = sig/float(ndata-1) - sig = sqrt(sig) - sk = sk/(sig**3 + 1.e-10)/float(ndata) - -END SUBROUTINE compute_stats + integer , parameter :: N_lon_ascat = 3600, N_lat_ascat = 1800 + integer :: i,j, status, varid, ncid + REAL, ALLOCATABLE, dimension (:) :: count_pix + REAL, ALLOCATABLE, dimension (:,:) :: z0_grid, data_grid + character*512 :: fout -! ----------------------------------------------------------------------------------- - - SUBROUTINE ascat_r0 (nc,nr,gfiler, z0) - - implicit none - - ! 1) ASCAT roughness - ! /discover/nobackup/adarmeno/projects/k14/arlems-roughness.x3600_y1800_t1.nc4 - - integer, intent (in) :: nc, nr - real, pointer, dimension (:), intent (inout) :: z0 - character(*), intent (in) :: gfiler - integer , parameter :: N_lon_ascat = 3600, N_lat_ascat = 1800 - integer :: i,j, status, varid, ncid - integer :: NTILES - REAL, ALLOCATABLE, dimension (:) :: count_pix - REAL, ALLOCATABLE, dimension (:,:) :: z0_grid, data_grid - INTEGER, ALLOCATABLE, dimension (:,:) :: tile_id - character*100 :: fout - - ! Reading number of tiles - ! ----------------------- - - open (20, file = 'clsm/catchment.def', form = 'formatted', status = 'old', action = 'read') - - read (20, *) NTILES - - close (20, status = 'keep') + ! READ ASCAT source data and regrid + ! --------------------------------- + + call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) + status = NF_OPEN (trim(MAKE_BCS_INPUT_DIR)//'/land/misc/roughness_length/v1/arlems-roughness.x3600_y1800_t1.nc4', NF_NOWRITE, ncid) - ! READ ASCAT source data and regrid - ! --------------------------------- + allocate (z0_grid (1 : NC , 1 : NR)) + allocate (data_grid (1 : N_lon_ascat, 1 : N_lat_ascat)) - call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) - status = NF_OPEN (trim(MAKE_BCS_INPUT_DIR)//'/land/misc/roughness_length/v1/arlems-roughness.x3600_y1800_t1.nc4', NF_NOWRITE, ncid) - - allocate (z0_grid (1 : NC , 1 : NR)) - allocate (data_grid (1 : N_lon_ascat, 1 : N_lat_ascat)) + status = NF_INQ_VARID (ncid,'roughness',VarID) ; VERIFY_(STATUS) + status = NF_GET_VARA_REAL (ncid,VarID, (/1,1,1/),(/N_lon_ascat, N_lat_ascat,1/), data_grid) ; VERIFY_(STATUS) - status = NF_INQ_VARID (ncid,'roughness',VarID) ; VERIFY_(STATUS) - status = NF_GET_VARA_REAL (ncid,VarID, (/1,1,1/),(/N_lon_ascat, N_lat_ascat,1/), data_grid) ; VERIFY_(STATUS) + call RegridRasterReal(data_grid, z0_grid) - call RegridRasterReal(data_grid, z0_grid) + status = NF_CLOSE(ncid) - status = NF_CLOSE(ncid) + ! Grid to tile + ! ------------ - ! Grid to tile - ! ------------ - - ! Reading tile-id raster file + ! Reading tile-id raster file - allocate(tile_id(1:nc,1:nr)) - - open (10,file=trim(gfiler)//'.rst',status='old',action='read', & - form='unformatted',convert='little_endian') - - do j=1,nr - read(10)tile_id(:,j) - end do + allocate (z0 (1:NTILES)) + allocate (count_pix (1:NTILES)) + + z0 = 0. + count_pix = 0. + + do j = 1,nr + do i = 1, nc + if((tile_id(i,j).gt.0).and.(tile_id(i,j).le.NTILES)) then + + ! z0 0. < 0.1 + if((z0_grid(i,j) >= 2.0e-6).and.(z0_grid(i,j) <= 0.1)) then + z0 (tile_id(i,j)) = z0 (tile_id(i,j)) + z0_grid(i,j) + count_pix (tile_id(i,j)) = count_pix (tile_id(i,j)) + 1. + endif + + endif + end do + end do + + where (count_pix > 0.) z0 = z0/count_pix + where (z0 == 0.) z0 = 2.0e-6 + + deallocate (count_pix) + deallocate (z0_grid) - close (10,status='keep') - - allocate (z0 (1:NTILES)) - allocate (count_pix (1:NTILES)) - - z0 = 0. - count_pix = 0. - - do j = 1,nr - do i = 1, nc - if((tile_id(i,j).gt.0).and.(tile_id(i,j).le.NTILES)) then - - ! z0 0. < 0.1 - if((z0_grid(i,j) >= 2.0e-6).and.(z0_grid(i,j) <= 0.1)) then - z0 (tile_id(i,j)) = z0 (tile_id(i,j)) + z0_grid(i,j) - count_pix (tile_id(i,j)) = count_pix (tile_id(i,j)) + 1. - endif - - endif - end do - end do - - where (count_pix > 0.) z0 = z0/count_pix - where (z0 == 0.) z0 = 2.0e-6 - - deallocate (count_pix) - deallocate (z0_grid) - deallocate (tile_id) - END SUBROUTINE ascat_r0 - ! ---------------------------------------------------------------------------------------------------------------------------- + ! ---------------------------------------------------------------------------------------------------------------------------- + + SUBROUTINE jpl_canoph (nc,nr, ntiles, tile_id, z2) - SUBROUTINE jpl_canoph (nc,nr,gfiler, z2) + ! 1) JPL Canopy Height + ! /discover/nobackup/projects/gmao/bcs_shared/make_bcs_inputs/land/veg/veg_height/v1/Simard_Pinto_3DGlobalVeg_JGR.nc4 - implicit none + integer, intent(in) :: nc, nr, ntiles + integer, intent(in) :: tile_id(:,:) + real, pointer, dimension(:), intent(inout) :: z2 - ! 1) JPL Canopy Height - ! /discover/nobackup/projects/gmao/bcs_shared/make_bcs_inputs/land/veg/veg_height/v1/Simard_Pinto_3DGlobalVeg_JGR.nc4 - - integer, intent (in) :: nc, nr - real, pointer, dimension (:), intent (inout) :: z2 - character(*), intent (in) :: gfiler - integer , parameter :: N_lon_jpl = 43200, N_lat_jpl = 21600 - integer :: i,j, status, varid, ncid - integer :: NTILES - REAL, ALLOCATABLE, dimension (:) :: count_pix - INTEGER, ALLOCATABLE, dimension (:,:) :: data_grid, z2_grid - INTEGER, ALLOCATABLE, dimension (:,:) :: tile_id - character*100 :: fout + ! ---------------------------------------------------------- - ! Reading number of tiles - ! ----------------------- - - open (20, file = 'clsm/catchment.def', form = 'formatted', status = 'old', action = 'read') - - read (20, *) NTILES - - close (20, status = 'keep') + integer , parameter :: N_lon_jpl = 43200, N_lat_jpl = 21600 - ! READ JPL source data files and regrid - ! ------------------------------------- + ! ---------------------------------------------------------- - call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) - status = NF_OPEN (trim(MAKE_BCS_INPUT_DIR)//'/land/veg/veg_height/v1/Simard_Pinto_3DGlobalVeg_JGR.nc4', NF_NOWRITE, ncid) - - allocate (z2_grid (1 : NC , 1 : NR)) - allocate (data_grid (1 : N_lon_jpl, 1 : N_lat_jpl)) + integer :: i,j, status, varid, ncid + REAL, ALLOCATABLE, dimension (:) :: count_pix + INTEGER, ALLOCATABLE, dimension (:,:) :: data_grid, z2_grid + character*512 :: fout - status = NF_INQ_VARID (ncid,'CanopyHeight',VarID) ; VERIFY_(STATUS) - status = NF_GET_VARA_INT (ncid,VarID, (/1,1/),(/N_lon_jpl, N_lat_jpl/), data_grid) ; VERIFY_(STATUS) - - call RegridRaster(data_grid, z2_grid) + ! READ JPL source data files and regrid + ! ------------------------------------- - status = NF_CLOSE(ncid) + call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) + status = NF_OPEN (trim(MAKE_BCS_INPUT_DIR)//'/land/veg/veg_height/v1/Simard_Pinto_3DGlobalVeg_JGR.nc4', NF_NOWRITE, ncid) - ! Grid to tile - ! ------------ - - ! Reading tile-id raster file + allocate (z2_grid (1 : NC , 1 : NR)) + allocate (data_grid (1 : N_lon_jpl, 1 : N_lat_jpl)) - allocate(tile_id(1:nc,1:nr)) - - open (10,file=trim(gfiler)//'.rst',status='old',action='read', & - form='unformatted',convert='little_endian') - - do j=1,nr - read(10)tile_id(:,j) - end do + status = NF_INQ_VARID (ncid,'CanopyHeight',VarID) ; VERIFY_(STATUS) + status = NF_GET_VARA_INT (ncid,VarID, (/1,1/),(/N_lon_jpl, N_lat_jpl/), data_grid) ; VERIFY_(STATUS) - close (10,status='keep') - - allocate (z2 (1:NTILES)) - allocate (count_pix (1:NTILES)) - - z2 = 0. - count_pix = 0. + call RegridRaster(data_grid, z2_grid) - do j = 1,nr - do i = 1, nc - if((tile_id(i,j).gt.0).and.(tile_id(i,j).le.NTILES)) then + status = NF_CLOSE(ncid) - if(z2_grid(i,j) >= 0.) then - z2 (tile_id(i,j)) = z2 (tile_id(i,j)) + real (z2_grid(i,j)) - count_pix (tile_id(i,j)) = count_pix (tile_id(i,j)) + 1. - endif + ! Grid to tile + ! ------------ - endif - end do - end do - - where (count_pix > 0.) z2 = z2/count_pix - where (z2 < 0.01) z2 = 0.01 ! to ensure Z2 >= MIN_VEG_HEIGHT + ! Reading tile-id raster file - deallocate (count_pix) - deallocate (z2_grid) - deallocate (tile_id) - - END SUBROUTINE jpl_canoph - ! ---------------------------------------------------------------------- + allocate (z2 (1:NTILES)) + allocate (count_pix (1:NTILES)) - integer function NC_VarID (NCFID, VNAME) - - integer, intent (in) :: NCFID - character(*), intent (in) :: VNAME - integer :: status + z2 = 0. + count_pix = 0. - STATUS = NF_INQ_VARID (NCFID, trim(VNAME) ,NC_VarID) - IF (STATUS .NE. NF_NOERR) & - CALL HANDLE_ERR(STATUS, trim(VNAME)) - - end function NC_VarID + do j = 1,nr + do i = 1, nc + if((tile_id(i,j).gt.0).and.(tile_id(i,j).le.NTILES)) then - ! ----------------------------------------------------------------------- + if(z2_grid(i,j) >= 0.) then + z2 (tile_id(i,j)) = z2 (tile_id(i,j)) + real (z2_grid(i,j)) + count_pix (tile_id(i,j)) = count_pix (tile_id(i,j)) + 1. + endif + + endif + end do + end do + + where (count_pix > 0.) z2 = z2/count_pix + where (z2 < 0.01) z2 = 0.01 ! to ensure Z2 >= MIN_VEG_HEIGHT - SUBROUTINE HANDLE_ERR(STATUS, Line) + deallocate (count_pix) + deallocate (z2_grid) - INTEGER, INTENT (IN) :: STATUS - CHARACTER(*), INTENT (IN) :: Line + END SUBROUTINE jpl_canoph - IF (STATUS .NE. NF_NOERR) THEN - PRINT *, trim(Line),': ',NF_STRERROR(STATUS) - STOP 'Stopped' - ENDIF + ! ---------------------------------------------------------------------- + + integer function NC_VarID (NCFID, VNAME) - END SUBROUTINE HANDLE_ERR + integer, intent (in) :: NCFID + character(*), intent (in) :: VNAME + integer :: status + + STATUS = NF_INQ_VARID (NCFID, trim(VNAME) ,NC_VarID) + IF (STATUS .NE. NF_NOERR) & + CALL HANDLE_ERR(STATUS, trim(VNAME)) + + end function NC_VarID + + ! ----------------------------------------------------------------------- + + SUBROUTINE HANDLE_ERR(STATUS, Line) + + INTEGER, INTENT (IN) :: STATUS + CHARACTER(*), INTENT (IN) :: Line + + IF (STATUS .NE. NF_NOERR) THEN + PRINT *, trim(Line),': ',NF_STRERROR(STATUS) + STOP 'Stopped' + ENDIF + + END SUBROUTINE HANDLE_ERR + + ! ----------------------------------------------------------------------------------- -! ----------------------------------------------------------------------------------- - END module rmTinyCatchParaMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/utils_topo/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/utils_topo/CMakeLists.txt new file mode 100644 index 000000000..d7fe66616 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/utils_topo/CMakeLists.txt @@ -0,0 +1,31 @@ +#-------------------- +# Copy include files that are used by other libraries. +# We could leave these in the source directory, and just broaden the search path +# in the other libaries, but this make it explicit which aspects are externally +# used. + +ecbuild_add_executable (TARGET generate_scrip_cube_topo.x SOURCES generate_scrip_cube.F90 geompack.F90) +target_link_libraries (generate_scrip_cube_topo.x PRIVATE MPI::MPI_Fortran esmf) +# CMake has an OpenMP issue with NAG Fortran: https://gitlab.kitware.com/cmake/cmake/-/issues/21280 +if (NOT CMAKE_Fortran_COMPILER_ID MATCHES "NAG") + target_link_libraries(generate_scrip_cube_topo.x PRIVATE OpenMP::OpenMP_Fortran) +endif () + +ecbuild_add_executable (TARGET convert_bin_to_netcdf_topo.x SOURCES convert_bin_to_netcdf.F90) +target_link_libraries (convert_bin_to_netcdf_topo.x PRIVATE MPI::MPI_Fortran NetCDF::NetCDF_Fortran) +# CMake has an OpenMP issue with NAG Fortran: https://gitlab.kitware.com/cmake/cmake/-/issues/21280 +if (NOT CMAKE_Fortran_COMPILER_ID MATCHES "NAG") + target_link_libraries(convert_bin_to_netcdf_topo.x PRIVATE OpenMP::OpenMP_Fortran) +endif () + +ecbuild_add_executable (TARGET convert_to_gmao_output_topo.x SOURCES convert_to_gmao_output.F90) +target_link_libraries (convert_to_gmao_output_topo.x PRIVATE MPI::MPI_Fortran NetCDF::NetCDF_Fortran) +# CMake has an OpenMP issue with NAG Fortran: https://gitlab.kitware.com/cmake/cmake/-/issues/21280 +if (NOT CMAKE_Fortran_COMPILER_ID MATCHES "NAG") + target_link_libraries(convert_to_gmao_output_topo.x PRIVATE OpenMP::OpenMP_Fortran) +endif () + +install(PROGRAMS scrip_to_cube_topo.py DESTINATION bin) +install(PROGRAMS scrip_to_restart_topo.py DESTINATION bin) +install(PROGRAMS generate_topo.sh DESTINATION bin) +install(PROGRAMS make_topo.py DESTINATION bin) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/utils_topo/convert_bin_to_netcdf.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/utils_topo/convert_bin_to_netcdf.F90 new file mode 100644 index 000000000..86244ad16 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/utils_topo/convert_bin_to_netcdf.F90 @@ -0,0 +1,128 @@ +program create_example +use netcdf +use, intrinsic :: iso_fortran_env, only: REAL64 +implicit none + + +character(len=512) :: fin,fout,str,fncar +integer :: im_world,jm_world +integer :: varid, lonid, latid +integer :: i, j, nc,xid,yid +integer :: zid,gwdid,trbid +integer :: ncid,rc +integer :: dimids(2) +integer :: status + +integer :: nargs + +logical :: doNcar,doGEOS + +integer :: ntiles +real, allocatable :: z1d(:) +real(REAL64), allocatable :: xdim(:),ydim(:) +real, allocatable :: a(:,:) +logical :: isCube + +nargs = command_argument_count() + +doNCAR=.false. +doGEOS=.false. +isCube = .true. +do i=1,nargs + call get_command_argument(i,str) + select case(trim(str)) + case ('-i','--input') + call get_command_argument(i+1,fin) + case ('-o','--output') + call get_command_argument(i+1,fout) + doGEOS=.true. + case ('--im') + call get_command_argument(i+1,str) + read(str,'(I10)')im_world + case ('--jm') + call get_command_argument(i+1,str) + read(str,'(I10)')jm_world + isCube = .false. + case ('--ncar') + call get_command_argument(i+1,fncar) + doNCAR=.true. + end select +enddo + +if (isCube) jm_world = im_world*6 + +allocate(a(im_world,jm_world)) +open(file=fin,unit=21,form='unformatted') +read(21)a +close(21) + +if (doGEOS) then + + call check( nf90_create(fout, NF90_NETCDF4,ncid),"error") + call check( nf90_def_dim(ncid,"Xdim",im_world,lonid),"error") + call check( nf90_def_var(ncid,"Xdim",NF90_DOUBLE,(/lonid/),xid),"error") + call check( nf90_put_att(ncid,xid,"units","degrees_east"),"error") + call check( nf90_def_dim(ncid,"Ydim",jm_world,latid),"error") + call check( nf90_def_var(ncid,"Ydim",NF90_DOUBLE,(/latid/),yid),"error") + call check( nf90_put_att(ncid,yid,"units","degrees_north"),"error") + call check( nf90_def_var(ncid,"z",NF90_FLOAT,(/lonid,latid/),varid),"error") + call check( nf90_put_att(ncid,varid,"units","m"),"error") + call check( nf90_put_att(ncid,varid,"long_name","height above sea level"),"error") + + call check( nf90_enddef(ncid),"error") + + allocate(xdim(im_world),ydim(jm_world)) + do i=1,im_world + xdim(i)=i + enddo + do j=1,jm_world + ydim(j)=j + enddo + + call check(nf90_put_var(ncid,xid,xdim),"error") + call check(nf90_put_var(ncid,yid,ydim),"error") + call check(nf90_put_var(ncid,varid,a),"error") + call check(nf90_close(ncid),"error") + +end if + +if (doNCAR) then + + ntiles=im_world*jm_world + allocate(z1d(ntiles)) + call check( nf90_create(fncar, NF90_NETCDF4,ncid),"error") + call check( nf90_def_dim(ncid,"ncol",ntiles,xid),"error") + call check( nf90_def_var(ncid,"PHIS",NF90_DOUBLE,(/xid/),varid),"error") + call check( nf90_put_att(ncid,varid,"long_name","height"),"error") + call check( nf90_put_att(ncid,varid,"units","m"),"error") + call check( nf90_enddef(ncid),"error") + + nc=0 + do j=1,jm_world + do i=1,im_world + nc=nc+1 + z1d(nc)=a(i,j) + enddo + enddo + + call check(nf90_put_var(ncid,varid,z1d),"error") + +end if + +contains + +subroutine check(status,loc) + + integer, intent ( in) :: status + character(len=*), intent ( in) :: loc + + if(status /= NF90_noerr) then + write (*,*) "Error at ", loc + write (*,*) nf90_strerror(status) + stop "Stopped" + end if + +end subroutine check + +end program create_example + diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/utils_topo/convert_to_gmao_output.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/utils_topo/convert_to_gmao_output.F90 new file mode 100644 index 000000000..9df4a7292 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/utils_topo/convert_to_gmao_output.F90 @@ -0,0 +1,261 @@ +program create_example +use netcdf +implicit none + + +character(len=512) :: fin,str,fonc4,fobin,fsnc4,fsbin +integer :: im_world,jm_world +integer :: varid, lonid, latid +integer :: i, j, nc +integer :: zid,gwdid,trbid +integer :: ncid,rc +integer :: dimids(2) +integer :: status +character(len=:), allocatable :: Istr, Jstr +real :: g +real, allocatable :: z1d(:),turb1d(:),gwd1d(:) + +real, allocatable :: a(:,:) +real :: asum + +logical :: isLL +integer :: nargs + +nargs = command_argument_count() + +isLL = .false. +do i=1,nargs + call get_command_argument(i,str) + select case(trim(str)) + case ('-i','--input') + call get_command_argument(i+1,fin) + case ('--im') + call get_command_argument(i+1,str) + read(str,'(I10)')im_world + jm_world=im_world*6 + case ('--jm') + call get_command_argument(i+1,str) + read(str,'(I10)')jm_world + isLL=.true. + end select +enddo + +g = 9.80616 + +allocate(z1d(im_world*jm_world),turb1d(im_world*jm_world),gwd1d(im_world*jm_world)) +allocate(a(im_world,jm_world)) + +call check(nf90_open(fin,NF90_NOWRITE,ncid),"open") +call check(nf90_inq_varid(ncid,'PHIS',varid),"find phis") +call check(nf90_get_var(ncid,varid,z1d),"read phis") +call check(nf90_inq_varid(ncid,'SGH',varid),"find sgh") +call check(nf90_get_var(ncid,varid,gwd1d),"read sgh") +call check(nf90_inq_varid(ncid,'SGH30',varid),"find sgh30") +call check(nf90_get_var(ncid,varid,turb1d),"read sgh30") +call check(nf90_close(ncid),"close") + +Istr = i_to_string(im_world) +Jstr = i_to_string(jm_world) +fsnc4 = Istr//'x'//Jstr//'.nc4' +fsbin = Istr//'x'//Jstr//'.data' +!if (isLL) then +! if (im_world < 288) then +! write(fsnc4,"(i3.3,'x',i2.2,'.nc4')")im_world,jm_world +! write(fsbin,"(i3.3,'x',i2.2,'.data')")im_world,jm_world +! else if (im_world < 1152) then +! write(fsnc4,"(i3.3,'x',i3.3,'.nc4')")im_world,jm_world +! write(fsbin,"(i3.3,'x',i3.3,'.data')")im_world,jm_world +! else +! write(fsnc4,"(i4.4,'x',i3.3,'.nc4')")im_world,jm_world +! write(fsbin,"(i4.4,'x',i3.3,'.data')")im_world,jm_world +! end if +!else +! if (im_world < 168) then +! write(fsnc4,"(i2.2,'x',i3.3,'.nc4')")im_world,jm_world +! write(fsbin,"(i2.2,'x',i3.3,'.data')")im_world,jm_world +! else if (im_world >= 168 .and. im_world < 1000) then +! write(fsnc4,"(i3.3,'x',i4.4,'.nc4')")im_world,jm_world +! write(fsbin,"(i3.3,'x',i4.4,'.data')")im_world,jm_world +! else if (im_world >= 1000 .and. im_world < 1666) then +! write(fsnc4,"(i4.4,'x',i4.4,'.nc4')")im_world,jm_world +! write(fsbin,"(i4.4,'x',i4.4,'.data')")im_world,jm_world +! else if (im_world >= 1666) then +! write(fsnc4,"(i4.4,'x',i5.5,'.nc4')")im_world,jm_world +! write(fsbin,"(i4.4,'x',i5.5,'.data')")im_world,jm_world +! endif +!end if + +! --- DYN (mean elevation in meters) ----------------------------------------- +fonc4 = "gmted_DYN_ave_"//trim(fsnc4) +fobin = "gmted_DYN_ave_"//trim(fsbin) + +call check(nf90_create(fonc4, IOR(NF90_CLOBBER, NF90_NETCDF4), ncid), "create dyn") +open(file=fobin, unit=21, form='unformatted') + +call check(nf90_def_dim(ncid, "lon", im_world, lonid), "defdim lon dyn") +call check(nf90_def_dim(ncid, "lat", jm_world, latid), "defdim lat dyn") +call check(nf90_def_var(ncid, "z", NF90_FLOAT, (/lonid, latid/), varid), "defvar z") + +call check(nf90_put_att(ncid, varid, "long_name", "mean elevation"), "att z long_name") +call check(nf90_put_att(ncid, varid, "units", "m"), "att z units") +! optional nicety: + call check(nf90_put_att(ncid, varid, "standard_name","surface_altitude"), "att z stdname") + +call check(nf90_enddef(ncid), "enddef dyn") + +nc = 0 +do j = 1, jm_world + do i = 1, im_world + nc = nc + 1 + ! NCAR writes PHIS (m^2 s^-2); convert to meters. Guard sentinels if present. + if (z1d(nc) < 0.9e36) then + a(i,j) = z1d(nc) / g + else + a(i,j) = 0.0 ! or 1.0e36 if you decide to add _FillValue + end if + end do +end do + +if (isLL) then + asum = 0.0 + do i = 1, im_world + asum = asum + a(i,1) + end do + a(:,1) = asum / float(im_world) + + asum = 0.0 + do i = 1, im_world + asum = asum + a(i,jm_world) + end do + a(:,jm_world) = asum / float(im_world) +end if + +call check(nf90_put_var(ncid, varid, a), "putvar z") +call check(nf90_close(ncid), "close dyn") +write(21) a +close(21) + +! --- GWD (write variance m^2) ---------------------------------------------- +fonc4 = "gmted_GWD_var_"//trim(fsnc4) +fobin = "gmted_GWD_var_"//trim(fsbin) + +call check(nf90_create(fonc4, IOR(NF90_CLOBBER, NF90_NETCDF4), ncid), "create gwd") +open(file=fobin, unit=21, form='unformatted') + +call check(nf90_def_dim(ncid, "lon", im_world, lonid), "defdim lon gwd") +call check(nf90_def_dim(ncid, "lat", jm_world, latid), "defdim lat gwd") +call check(nf90_def_var(ncid, "gwd", NF90_FLOAT, (/lonid, latid/), varid), "defvar gwd") + +call check(nf90_put_att(ncid, varid, "long_name", "variance of subgrid orography for GWD"), "att gwd long_name") +call check(nf90_put_att(ncid, varid, "units", "m2"), "att gwd units") + +call check(nf90_enddef(ncid), "enddef gwd") + +nc = 0 +do j = 1, jm_world + do i = 1, im_world + nc = nc + 1 + ! Square std dev (m) from PE file to variance (m^2) here. + ! Guard against sentinels/negatives so we don't square 1e36. + if (gwd1d(nc) >= 0.0 .and. gwd1d(nc) < 0.9e36) then + a(i,j) = gwd1d(nc) * gwd1d(nc) + else + a(i,j) = 1.0e36 + end if + end do +end do + +if (isLL) then + asum = 0.0 + do i = 1, im_world + asum = asum + a(i,1) + end do + a(:,1) = asum / float(im_world) + + asum = 0.0 + do i = 1, im_world + asum = asum + a(i,jm_world) + end do + a(:,jm_world) = asum / float(im_world) +end if + +call check(nf90_put_var(ncid, varid, a), "putvar gwd") +call check(nf90_close(ncid), "close gwd") +write(21) a +close(21) + +! --- TURB (write variance m^2) ---------------------------------------------- +fonc4 = "gmted_TRB_var_"//trim(fsnc4) +fobin = "gmted_TRB_var_"//trim(fsbin) + +call check(nf90_create(fonc4, IOR(NF90_CLOBBER, NF90_NETCDF4), ncid), "create trb") +open(file=fobin, unit=21, form='unformatted') + +call check(nf90_def_dim(ncid, "lon", im_world, lonid), "defdim lon trb") +call check(nf90_def_dim(ncid, "lat", jm_world, latid), "defdim lat trb") +call check(nf90_def_var(ncid, "trb", NF90_FLOAT, (/lonid, latid/), varid), "defvar trb") + +call check(nf90_put_att(ncid, varid, "long_name", "variance of subgrid orography for TRB"), "att trb long_name") +call check(nf90_put_att(ncid, varid, "units", "m2"), "att trb units") + +call check(nf90_enddef(ncid), "enddef trb") + +nc = 0 +do j = 1, jm_world + do i = 1, im_world + nc = nc + 1 + ! Square std dev (m) from PE file to variance (m^2) here. + ! Guard against sentinels/negatives so we don't square 1e36. + if (turb1d(nc) >= 0.0 .and. turb1d(nc) < 0.9e36) then + a(i,j) = turb1d(nc) * turb1d(nc) + else + a(i,j) = 1.0e36 + end if + end do +end do + +if (isLL) then + asum = 0.0 + do i = 1, im_world + asum = asum + a(i,1) + end do + a(:,1) = asum / float(im_world) + + asum = 0.0 + do i = 1, im_world + asum = asum + a(i,jm_world) + end do + a(:,jm_world) = asum / float(im_world) +end if + +call check(nf90_put_var(ncid, varid, a), "putvar trb") +call check(nf90_close(ncid), "close trb") +write(21) a +close(21) +! --------------------------------------------------------------------------- + +contains + + subroutine check(status,loc) + + integer, intent ( in) :: status + character(len=*), intent ( in) :: loc + + if(status /= NF90_noerr) then + write (*,*) "Error at ", loc + write (*,*) nf90_strerror(status) + stop "Stopped" + end if + + end subroutine check + + function i_to_string(count) result(str) + character(len=:), allocatable :: str + integer, intent(in) :: count + character(len=9) :: buffer + write(buffer,'(i0)') count + str = trim(buffer) + end function i_to_string + +end program create_example + diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/utils_topo/generate_scrip_cube.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/utils_topo/generate_scrip_cube.F90 new file mode 100644 index 000000000..881bc0a9e --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/utils_topo/generate_scrip_cube.F90 @@ -0,0 +1,1837 @@ +!#define _VERIFY(A) if(A/=0) write(*,*)__LINE__;call MPI_ABort(MPI_COMM_WORLD,error_code,status) +#define _VERIFY(A) if(A/=0) call local_abort(A,__LINE__) + + program ESMF_GenerateCSGridDescription + +! ESMF Framework module + use ESMF + use mpi + use netcdf + use, intrinsic :: iso_fortran_env, only: REAL64,REAL32 + + implicit none + +! The code creating and filling these variables is not included in the +! example documentation because those interfaces are not specific to +! Regrid. + type(ESMF_Grid) :: dstgrid + type(ESMF_Grid) :: tempgrid + type(ESMF_Grid) :: unigrid + type(ESMF_CubedSphereTransform_Args) :: transformArgument + +!EOC + + real(REAL64), parameter :: PI = 3.14159265358979323846 + integer :: npets, localPet + integer :: i, j, k + integer :: rc + type(ESMF_VM) :: vm + integer :: IM_World, JM_World, scrip_size + integer, parameter :: grid_type = 0 + integer, parameter :: KM_WORLD=1 + integer, parameter :: NX=1 + integer, parameter :: NY=6 + integer, parameter :: ntiles=6 + integer, parameter :: ndims=2 + integer :: N + integer :: info + integer :: start(2), cnt(2), hull_num, hull(4) + integer :: UNIT + real(ESMF_KIND_R8), allocatable :: SCRIP_CenterLat(:), SCRIP_CenterLon(:) + real(ESMF_KIND_R8), allocatable :: SCRIP_CornerLat(:,:), SCRIP_CornerLon(:,:) + real(ESMF_KIND_R8), allocatable :: SCRIP_Area(:) + real(ESMF_KIND_R8), allocatable :: SCRIP_rrfac(:) + real(ESMF_KIND_R8) :: node_xy(2,4), node_xy_tmp(2,4), lon_e, lon_w + integer :: gridsize, griddim, rankdim, mask + integer :: cornerlon, cornerlat, centerlon, centerlat,cellarea, cellrrfac + integer, allocatable :: IMS(:,:), JMS(:,:), sendData(:), GlobalCounts(:), recvCounts(:), recvOffsets(:) + integer, allocatable :: grid_imask(:) + character(len=ESMF_MAXSTR) :: gridname, FMT, title + integer :: myTile + integer :: tmp, mpiC + integer :: rrfac_max + logical :: do_schmidt + logical, allocatable :: fallback_mask(:) + integer :: varid_mask_fallback + integer, allocatable :: mask_fallback(:) + real(ESMF_KIND_R8) :: p1(2),p2(2),p3(2),p4(2) + real(ESMF_KIND_R8) :: local_max_length, local_min_length + real(ESMF_KIND_R4) :: target_lon, target_lat, stretch_factor + type(ESMF_HConfig) :: CF + integer :: status + character(len=ESMF_MAXPATHLEN) :: output_scrip, output_geos + integer :: failed_cells + real(ESMF_KIND_R8), allocatable :: local_max_length_all(:), local_min_length_all(:) + integer, allocatable :: localDEList(:) + integer :: cell, num_cells + integer :: localDECount + integer :: mpi_err + integer :: de + integer :: global_chosen_pet, chosen_pet, chosen_de + integer :: chosen_de_stretch, chosen_i_stretch, chosen_j_stretch, chosen_pet_stretch + real(ESMF_KIND_R8), pointer :: tmp_center_lons(:,:) => null() + real(ESMF_KIND_R8), pointer :: tmp_center_lats(:,:) => null() + real(ESMF_KIND_R8), pointer :: tmp_corner_lons(:,:) => null() + real(ESMF_KIND_R8), pointer :: tmp_corner_lats(:,:) => null() + real(ESMF_KIND_R8), pointer :: uni_corner_lons(:,:) => null() + real(ESMF_KIND_R8), pointer :: uni_corner_lats(:,:) => null() + real(ESMF_KIND_R8) :: tiny_dlon, tiny_dlat + real(ESMF_KIND_R8) :: clon, clat, area_signed + real(ESMF_KIND_R8) :: global_max_length, global_min_length, min_allowed_length + real(ESMF_KIND_R8) :: midpoint_lon, midpoint_lat + real(ESMF_KIND_R8) :: dist, min_dist_local, min_dist_global, lon_diff, lat_diff + real(ESMF_KIND_R8) :: chosen_center_lon, chosen_center_lat + real(ESMF_KIND_R8) :: global_chosen_lon, global_chosen_lat + real(ESMF_KIND_R8), parameter :: min_length_threshold = 1.0d-12 + integer , parameter :: grid_corners = 4 + integer :: num_rrfac_max + integer :: j_offset, jc_offset + integer :: num_local_cells, n_start + integer :: best_idx + integer :: num_cells_global + integer :: n_end + integer :: num_rrfac_max_local + integer :: global_idx_max_rrfac + integer :: valid_count_local + integer :: cornerdimID + integer :: clamp_count_local, clamp_count_global + integer :: fallback_count_local, fallback_count_global + integer :: owner_pet + integer :: start_file, cnt_file, mem_start, mem_end + integer :: j_offset_chosen + real(ESMF_KIND_R8) :: local_max_rrfac, global_max_rrfac + real(ESMF_KIND_R8) :: global_lon_max_rrfac, global_lat_max_rrfac + real(ESMF_KIND_R8) :: eps + logical :: found_degenerate + logical :: bad_corner + real(ESMF_KIND_R8) :: epsilon + integer :: l + real(ESMF_KIND_R8) :: global_max_area, global_min_area,ratio + real(ESMF_KIND_R8), allocatable :: my_corner_lat(:,:), my_corner_lon(:,:) + real(ESMF_KIND_R8), allocatable :: A_uniform(:) + real(ESMF_KIND_R8) :: max_rrfac_allowed + real(ESMF_KIND_R8) :: midpoint_lon_deg, midpoint_lat_deg + real(ESMF_KIND_R8) :: max_area_local, min_area_local + real(ESMF_KIND_R8) :: local_min_rrfac, global_min_rrfac_print, global_max_rrfac_print + real(ESMF_KIND_R8) :: owner_lon, owner_lat + real(ESMF_KIND_R8) :: u1(2), u2(2), u3(2), u4(2) + real(ESMF_KIND_R8) :: swap_p(2) + real(ESMF_KIND_R8) :: deg2rad, lonc, latc, half_power_radius_deg, theta0 + real(ESMF_KIND_R8) :: desired_peak, dlon, lat1, lat2, dlam, cc, dtheta, w + real(ESMF_KIND_R8) :: best_dist + real(ESMF_KIND_R8) :: pair_local(2), pair_global(2) + real(ESMF_KIND_R8) :: tmp_len + real(ESMF_KIND_R8) :: dummy_max, dummy_min + real(ESMF_KIND_R8) :: max_len_local, min_len_local + + + call ESMF_Initialize(logKindFlag=ESMF_LOGKIND_NONE,rc=status) + _VERIFY(status) + call ESMF_CalendarSetDefault(ESMF_CALKIND_GREGORIAN,rc=status) + _VERIFY(status) + + call ESMF_VMGetGlobal(vm, rc=status) + _VERIFY(status) + +! Get number of PETs we are running with +! -------------------------------------- + call ESMF_VMGet(vm, localPet=localPet, petCount=npets, mpiCommunicator=mpiC, rc=status) + _VERIFY(status) + if (npets /= 6) call local_abort(1,__LINE__) + + cf = ESMF_HConfigCreate(filename='GenScrip.yaml',rc=status) + _VERIFY(STATUS) + + im_world = ESMF_HConfigAsI4(cf,keyString='CUBE_DIM',rc=status) + _VERIFY(STATUS) + JM_WORLD = 6 * IM_WORLD + gridname = "cube_grid" + + output_scrip = ESMF_HConfigAsString(cf,keyString='output_scrip',rc=status) + _VERIFY(STATUS) + output_geos = ESMF_HConfigAsString(cf,keyString='output_geos',rc=status) + _VERIFY(STATUS) + + do_schmidt=.false. + if (ESMF_HConfigIsDefined(cf,keyString='DO_SCHMIDT')) then + do_schmidt = ESMF_HConfigAsLogical(cf,keystring='DO_SCHMIDT',rc=status) + _VERIFY(status) + end if + if (do_schmidt) then + target_lon = ESMF_HConfigAsR4(cf,keyString='TARGET_LON',rc=status) + _VERIFY(status) + target_lat = ESMF_HConfigAsR4(cf,keyString='TARGET_LAT',rc=status) + _VERIFY(status) + stretch_factor = ESMF_HConfigAsR4(cf,keyString='STRETCH_FACTOR',rc=status) + _VERIFY(status) + if (target_lon < 0.0) target_lon = target_lon + 360.0 + end if + + allocate(ims(1,6),jms(1,6)) + do i=1,ntiles + ims(1,i)=im_world + jms(1,i)=im_world + enddo + + !======================== GRID CREATION & SETUP ======================== + + ! Build grid(s) based on do_schmidt + if (.not. do_schmidt) then + !------------------------------ REGULAR GRID (legacy) ------------------------------ + dstgrid = ESMF_GridCreateCubedSphere(im_world, countsPerDEDim1PTile=ims, & + countsPerDEDim2PTile=jms, name='bobo', & + staggerLocList=[ESMF_STAGGERLOC_CENTER, ESMF_STAGGERLOC_CORNER], & + coordSys=ESMF_COORDSYS_SPH_RAD, rc=status); _VERIFY(status) + + call ESMF_GridGet(dstgrid, localDECount=localDECount, rc=status); _VERIFY(status) + + else + !------------------------------ STRETCHED GRID (Schmidt) --------------------------- + + ! 1) Pick the midpoint (closest cell center to requested target) on an + ! unstretched grid in degrees, so the search is simple. + tempgrid = ESMF_GridCreateCubedSphere(im_world, countsPerDEDim1PTile=ims, & + countsPerDEDim2PTile=jms, name='temp', & + staggerLocList=[ESMF_STAGGERLOC_CENTER], & + coordSys=ESMF_COORDSYS_SPH_DEG, rc=status); _VERIFY(status) + + call ESMF_GridGet(tempgrid, localDECount=localDECount, rc=status); _VERIFY(status) + + allocate(localDEList(localDECount)) + do de = 0, localDECount - 1 + localDEList(de+1) = de + enddo + + min_dist_local = huge(1.0d0) + do de = 1, localDECount + call ESMF_GridGetCoord(tempgrid, coordDim=1, localDE=localDEList(de), & + staggerloc=ESMF_STAGGERLOC_CENTER, farrayPtr=tmp_center_lons, rc=status); _VERIFY(status) + call ESMF_GridGetCoord(tempgrid, coordDim=2, localDE=localDEList(de), & + staggerloc=ESMF_STAGGERLOC_CENTER, farrayPtr=tmp_center_lats, rc=status); _VERIFY(status) + + do j = 1, size(tmp_center_lats,2) + do i = 1, size(tmp_center_lons,1) + lon_diff = modulo(tmp_center_lons(i,j) - target_lon + 180.0d0, 360.0d0) - 180.0d0 + lat_diff = tmp_center_lats(i,j) - target_lat + dist = sqrt(lon_diff**2 + lat_diff**2) + + if (dist < min_dist_local) then + min_dist_local = dist + chosen_center_lon = tmp_center_lons(i,j) + chosen_center_lat = tmp_center_lats(i,j) + chosen_pet = localPet + chosen_de = localDEList(de) + endif + enddo + enddo + enddo + + ! 2) Find global min distance and broadcast the midpoint in degrees + call MPI_Allreduce(min_dist_local, min_dist_global, 1, MPI_DOUBLE_PRECISION, MPI_MIN, mpiC, mpi_err) + + if (abs(min_dist_local - min_dist_global) < 1.0d-10) then + global_chosen_pet = localPet + else + global_chosen_pet = -1 + endif + call MPI_Allreduce(MPI_IN_PLACE, global_chosen_pet, 1, MPI_INTEGER, MPI_MAX, mpiC, mpi_err) + + global_chosen_lon = chosen_center_lon + global_chosen_lat = chosen_center_lat + call MPI_Bcast(global_chosen_lon, 1, MPI_DOUBLE_PRECISION, global_chosen_pet, mpiC, mpi_err) + call MPI_Bcast(global_chosen_lat, 1, MPI_DOUBLE_PRECISION, global_chosen_pet, mpiC, mpi_err) + + midpoint_lon = global_chosen_lon + midpoint_lat = global_chosen_lat + + ! 3) Create the actual stretched grid at the chosen midpoint (radians) + transformArgument%stretch_factor = stretch_factor + transformArgument%target_lon = midpoint_lon * pi/180.0d0 + transformArgument%target_lat = midpoint_lat * pi/180.0d0 + + dstgrid = ESMF_GridCreateCubedSphere(im_world, countsPerDEDim1PTile=ims, & + countsPerDEDim2PTile=jms, name='bobo', & + staggerLocList=[ESMF_STAGGERLOC_CENTER, ESMF_STAGGERLOC_CORNER], & + transformArgs=transformArgument, & + coordSys=ESMF_COORDSYS_SPH_RAD, rc=status); _VERIFY(status) + + call ESMF_GridGet(dstgrid, localDECount=localDECount, rc=status); _VERIFY(status) + + ! 4) uniform “reference” corners used for diagnostics/comparisons + unigrid = ESMF_GridCreateCubedSphere(im_world, countsPerDEDim1PTile=ims, & + countsPerDEDim2PTile=jms, name='uniform', & + staggerLocList=[ESMF_STAGGERLOC_CORNER], & + coordSys=ESMF_COORDSYS_SPH_RAD, rc=status); _VERIFY(status) + + call ESMF_GridGetCoord(unigrid, coordDim=1, localDE=0, & + staggerloc=ESMF_STAGGERLOC_CORNER, farrayPtr=uni_corner_lons, rc=status); _VERIFY(status) + call ESMF_GridGetCoord(unigrid, coordDim=2, localDE=0, & + staggerloc=ESMF_STAGGERLOC_CORNER, farrayPtr=uni_corner_lats, rc=status); _VERIFY(status) + + ! 5) Find the exact (PET,DE,i,j) of the midpoint on the *stretched* grid + min_dist_local = huge(1.0d0) + do de = 0, localDECount - 1 + call ESMF_GridGetCoord(dstgrid, coordDim=1, localDE=de, & + staggerloc=ESMF_STAGGERLOC_CENTER, farrayPtr=tmp_center_lons, rc=status); _VERIFY(status) + call ESMF_GridGetCoord(dstgrid, coordDim=2, localDE=de, & + staggerloc=ESMF_STAGGERLOC_CENTER, farrayPtr=tmp_center_lats, rc=status); _VERIFY(status) + + do j = 1, size(tmp_center_lats,2) + do i = 1, size(tmp_center_lons,1) + lon_diff = modulo(tmp_center_lons(i,j)*180.d0/pi - midpoint_lon + 180.0d0, 360.0d0) - 180.0d0 + lat_diff = tmp_center_lats(i,j)*180.d0/pi - midpoint_lat + dist = sqrt(lon_diff**2 + lat_diff**2) + if (dist < min_dist_local) then + min_dist_local = dist + chosen_de_stretch = de + chosen_i_stretch = i + chosen_j_stretch = j + endif + enddo + enddo + enddo + + call MPI_Allreduce(min_dist_local, min_dist_global, 1, MPI_DOUBLE_PRECISION, MPI_MIN, mpiC, mpi_err) + if (abs(min_dist_local - min_dist_global) < 1.0d-10) then + chosen_pet_stretch = localPet + else + chosen_pet_stretch = -1 + endif + call MPI_Allreduce(MPI_IN_PLACE, chosen_pet_stretch, 1, MPI_INTEGER, MPI_MAX, mpiC, mpi_err) + + call MPI_Bcast(chosen_pet_stretch, 1, MPI_INTEGER, chosen_pet_stretch, mpiC, mpi_err) + call MPI_Bcast(chosen_de_stretch, 1, MPI_INTEGER, chosen_pet_stretch, mpiC, mpi_err) + call MPI_Bcast(chosen_i_stretch, 1, MPI_INTEGER, chosen_pet_stretch, mpiC, mpi_err) + call MPI_Bcast(chosen_j_stretch, 1, MPI_INTEGER, chosen_pet_stretch, mpiC, mpi_err) + + midpoint_lon_deg = -999.d0 + midpoint_lat_deg = -999.d0 + if (localPet == chosen_pet_stretch) then + call ESMF_GridGetCoord(dstgrid, coordDim=1, localDE=chosen_de_stretch, & + staggerloc=ESMF_STAGGERLOC_CENTER, farrayPtr=tmp_center_lons, rc=status); _VERIFY(status) + call ESMF_GridGetCoord(dstgrid, coordDim=2, localDE=chosen_de_stretch, & + staggerloc=ESMF_STAGGERLOC_CENTER, farrayPtr=tmp_center_lats, rc=status); _VERIFY(status) + midpoint_lon_deg = modulo(tmp_center_lons(chosen_i_stretch,chosen_j_stretch)*180.d0/pi, 360.d0) + midpoint_lat_deg = tmp_center_lats(chosen_i_stretch,chosen_j_stretch)*180.d0/pi + endif + call MPI_Bcast(midpoint_lon_deg, 1, MPI_DOUBLE_PRECISION, chosen_pet_stretch, mpiC, mpi_err) + call MPI_Bcast(midpoint_lat_deg, 1, MPI_DOUBLE_PRECISION, chosen_pet_stretch, mpiC, mpi_err) + + end if + !-------------------------- end split regular / stretched -------------------------- + + ! 6) Pointers to THIS PET’s face on dstgrid (used by both paths later) + call ESMF_GridGetCoord(dstgrid, coordDim=1, localDE=0, & + staggerloc=ESMF_STAGGERLOC_CENTER, farrayPtr=tmp_center_lons, rc=status); _VERIFY(status) + call ESMF_GridGetCoord(dstgrid, coordDim=2, localDE=0, & + staggerloc=ESMF_STAGGERLOC_CENTER, farrayPtr=tmp_center_lats, rc=status); _VERIFY(status) + + call ESMF_GridGetCoord(dstgrid, coordDim=1, localDE=0, & + staggerloc=ESMF_STAGGERLOC_CORNER, farrayPtr=tmp_corner_lons, rc=status); _VERIFY(status) + call ESMF_GridGetCoord(dstgrid, coordDim=2, localDE=0, & + staggerloc=ESMF_STAGGERLOC_CORNER, farrayPtr=tmp_corner_lats, rc=status); _VERIFY(status) + + ! 7) Indexing helpers (REGULAR keeps legacy local indexing; STRETCH uses global) + jm_world = im_world * npets + num_local_cells = im_world * im_world + num_cells_global = im_world * jm_world + + if (.not. do_schmidt) then + n_start = 1 + n_end = num_local_cells + else + n_start = localPet * num_local_cells + 1 + n_end = n_start + num_local_cells - 1 + endif + + !====================== END GRID CREATION & SETUP ====================== + ! --- Optional: quick sanity print from locals (in degrees) --- + if (localPet == 0) then + write(*,*) "[LOCAL FACE] center(1,1) lon/lat (deg):", & + modulo(tmp_center_lons(1,1)*180.d0/pi,360.d0), tmp_center_lats(1,1)*180.d0/pi + write(*,*) "[LOCAL FACE] corner(1,1) lon/lat (deg):", & + modulo(tmp_corner_lons(1,1)*180.d0/pi,360.d0), tmp_corner_lats(1,1)*180.d0/pi + end if + + ! wrap local tile corners to [0,2π) – applies to both modes + do j = 1, size(tmp_corner_lons,2) + do i = 1, size(tmp_corner_lons,1) + if (tmp_corner_lons(i,j) >= 2.d0*pi) tmp_corner_lons(i,j) = tmp_corner_lons(i,j) - 2.d0*pi + if (tmp_corner_lons(i,j) < 0.d0) tmp_corner_lons(i,j) = tmp_corner_lons(i,j) + 2.d0*pi + end do + end do + write(*,*) "[POST PERIODICITY] PET:", localPet, & + " corner_lons(1,1):", tmp_corner_lons(1,1)*180.d0/pi, & + " corner_lats(1,1):", tmp_corner_lats(1,1)*180.d0/pi + + ! Extra midpoint diagnostics ONLY for stretched mode + if (do_schmidt) then + j_offset_chosen = chosen_pet_stretch * im_world + midpoint_lon_deg = -999.d0 + midpoint_lat_deg = -999.d0 + if (localPet == chosen_pet_stretch) then + midpoint_lon_deg = modulo(tmp_center_lons(chosen_i_stretch, chosen_j_stretch)*180.d0/pi, 360.d0) + midpoint_lat_deg = tmp_center_lats(chosen_i_stretch, chosen_j_stretch)*180.d0/pi + endif + call MPI_Bcast(midpoint_lon_deg, 1, MPI_DOUBLE_PRECISION, chosen_pet_stretch, MPI_COMM_WORLD, mpi_err) + call MPI_Bcast(midpoint_lat_deg, 1, MPI_DOUBLE_PRECISION, chosen_pet_stretch, MPI_COMM_WORLD, mpi_err) + if (localPet == chosen_pet_stretch) write(*,*) "[MIDPOINT CONFIRMED] PET:", localPet + end if + + ! ---- Allocate SCRIP arrays (size depends on mode) ---- + if (.not. do_schmidt) then + tmp = im_world * im_world ! local face (legacy behavior) + else + tmp = num_cells_global ! global (stretched workflow) + endif + + allocate(SCRIP_CenterLon(tmp),stat=status); _VERIFY(status) + allocate(SCRIP_CenterLat(tmp),stat=status); _VERIFY(status) + allocate(SCRIP_CornerLat(4,tmp),stat=status); _VERIFY(status) + allocate(SCRIP_CornerLon(4,tmp),stat=status); _VERIFY(status) + allocate(SCRIP_Area(tmp),stat=status); _VERIFY(status) + allocate(SCRIP_rrfac(tmp),stat=status); _VERIFY(status) + SCRIP_rrfac = 0.0d0 + allocate(fallback_mask(tmp),stat=status); _VERIFY(status) + + if (do_schmidt) then + allocate(A_uniform(tmp), stat=status); _VERIFY(status) + end if + + num_cells = tmp + allocate(local_max_length_all(num_cells)) + allocate(local_min_length_all(num_cells)) + local_max_length_all(:) = 0.0d0 + local_min_length_all(:) = 1.0d15 + fallback_mask = .false. + failed_cells = 0 + + mytile = localPet + 1 + j_offset = (mytile-1)*im_world + jc_offset= (mytile-1)*im_world + + write(*,'("[CHECK PET SLICE] PET:",I2," j_offset:",I8," jc_offset:",I8)') localPet,j_offset,jc_offset + + if (localPet == 0) then + write(*,*) "PET 0 local corner (1,1) lon/lat:", & + tmp_corner_lons(1,1)*180.d0/pi, tmp_corner_lats(1,1)*180.d0/pi + end if + if (localPet == npets-1) then + write(*,*) "PET last local corner (end,end) lon/lat:", & + tmp_corner_lons(im_world+1,im_world+1)*180.d0/pi, & + tmp_corner_lats(im_world+1,im_world+1)*180.d0/pi + end if + + num_local_cells = im_world*im_world + + ! *** CRITICAL: indexing differs by mode *** + if (.not. do_schmidt) then + n_start = 1 + n_end = num_local_cells + else + n_start = num_local_cells * localPet + 1 + n_end = n_start + num_local_cells - 1 + endif + n = n_start + + write(*,*) "[PRE MAIN LOOP] PET:", localPet, " j_offset:", j_offset, " jc_offset:", jc_offset, & + " corner_lons(1,1):", tmp_corner_lons(1,1)*180.d0/pi, & + " corner_lats(1,1):", tmp_corner_lats(1,1)*180.d0/pi + + do j = 1, im_world + do i = 1, im_world + ! centers (local tile → degrees) + SCRIP_CenterLon(n) = modulo(tmp_center_lons(i,j)*(180.d0/pi), 360.d0) + SCRIP_CenterLat(n) = tmp_center_lats(i,j)*(180.d0/pi) + + ! corners (local tile → radians here, you wrap before area or convert when writing) + node_xy(1,:) = [ tmp_corner_lons(i ,j ), tmp_corner_lons(i+1,j ), & + tmp_corner_lons(i+1,j+1), tmp_corner_lons(i ,j+1) ] + node_xy(2,:) = [ tmp_corner_lats(i ,j ), tmp_corner_lats(i+1,j ), & + tmp_corner_lats(i+1,j+1), tmp_corner_lats(i ,j+1) ] + + node_xy_tmp = node_xy + + ! Correct for longitude periodicity + lon_w = minval(node_xy(1,:)) + lon_e = maxval(node_xy(1,:)) + if (abs(lon_e - lon_w) > 1.5_8*pi) then + if (tmp_center_lons(i,j) < pi) then + where (node_xy(1,:) > pi) node_xy_tmp(1,:) = node_xy(1,:) - 2._8*pi + else + where (node_xy(1,:) < pi) node_xy_tmp(1,:) = node_xy(1,:) + 2._8*pi + endif + endif + + node_xy = node_xy_tmp + + ! === Uniform-grid reference area: STRETCH ONLY === + if (do_schmidt) then + u1 = [uni_corner_lons(i ,j ), uni_corner_lats(i ,j )] + u2 = [uni_corner_lons(i+1,j ), uni_corner_lats(i+1,j )] + u3 = [uni_corner_lons(i+1,j+1), uni_corner_lats(i+1,j+1)] + u4 = [uni_corner_lons(i ,j+1), uni_corner_lats(i ,j+1)] + A_uniform(n) = get_area_spherical_polygon(u1,u2,u3,u4) + end if + + if (n == n_start) then + write(*,*) "[FIRST CELL CORNERS] PET:", localPet, " n:", n, & + " corners_lon(deg):", node_xy(1,:)*180/pi, & + " corners_lat(deg):", node_xy(2,:)*180/pi + endif + + !------------------------------------------------------------------------------------ + ! STRETCHED-ONLY geometry repair (WHY & ORDER) + ! + ! WHY: + ! Schmidt stretching can distort panel quads near the target and panel edges: + ! - corners can wrap across 0/360, + ! - quads can become non-convex or nearly collinear, + ! - numerical noise can yield NaNs/Inf or negative/tiny areas, + ! - corner ordering can be inconsistent. + ! SCRIP expects a simple quad with CCW ordering and positive area. + ! + ! WHAT & ORDER (progressively stronger interventions): + ! 1) Degeneracy check: if any pair of corners nearly coincides, build a tiny + ! CCW square around the cell center (fallback) and flag fallback_mask. + ! 2) Clamp corners: wrap lon to [0,2π), clamp lon away from exact 0/2π, clamp + ! lat to [-π/2, π/2] to avoid out-of-range/NaN geometry. + ! 3) Convex hull: reorder the (possibly scrambled) corners into a proper quad. + ! If hull fails, jitter a tiny ε box around the center and retry. + ! If it still fails, build the explicit tiny CCW square fallback. + ! 4) Finite check: if any corner is NaN/Inf, rebuild the tiny CCW square fallback. + ! 5) Consistent ordering: call safe_reorder_hull → (p1,p2,p3,p4). + ! 6) Area guard: compute signed spherical area; if NaN/Inf/|area| tiny/huge, + ! rebuild tiny CCW square and recompute; mark fallback_mask. + ! 7) CCW enforcement: if signed area < 0, swap p2↔p4 to make it CCW so area>0. + ! 8) Write corners/area: store in SCRIP arrays (degrees; lon wrapped to 0..360). + ! + ! NOTE: + ! - All of the above is under do_schmidt=.true.; the regular grid path preserves + ! legacy behavior, with only CCW enforcement to guarantee positive area. + ! - fallback_mask marks cells where we had to invent a tiny polygon; later logic + ! (e.g., rrfac) can treat these conservatively. + !------------------------------------------------------------------------------------ + if (do_schmidt) then + ! 1) Detect truly degenerate quads and do tiny‐polygon fallback + found_degenerate = .false. + epsilon = 5.0d-6 ! ≈ 1″; stops “everything looks degenerate” + do k = 1,4 + do l = k+1,4 + if (abs(node_xy_tmp(1,k)-node_xy_tmp(1,l)) < epsilon .and. & + abs(node_xy_tmp(2,k)-node_xy_tmp(2,l)) < epsilon) then + found_degenerate = .true. + end if + end do + end do + + if (found_degenerate) then + ! build a tiny fallback polygon around the center + tiny_dlon = 1.0d-2 * pi/180._8 + tiny_dlat = 1.0d-2 * pi/180._8 + clon = tmp_center_lons(i,j) ! radians + clat = tmp_center_lats(i,j) ! radians + p1 = [clon - tiny_dlon, clat - tiny_dlat] + p2 = [clon + tiny_dlon, clat - tiny_dlat] + p3 = [clon + tiny_dlon, clat + tiny_dlat] + p4 = [clon - tiny_dlon, clat + tiny_dlat] + + ! wrap each longitude of the tiny fallback polygon + p1(1) = modulo(p1(1), 2.0d0*pi) + p2(1) = modulo(p2(1), 2.0d0*pi) + p3(1) = modulo(p3(1), 2.0d0*pi) + p4(1) = modulo(p4(1), 2.0d0*pi) + + ! compute area + area_signed = get_signed_area_spherical_polygon(p1,p2,p3,p4) + if (area_signed <= 0.d0 .or. abs(area_signed) < 1.0d-12) then + area_signed = 1.0d-12 + end if + SCRIP_Area(n) = abs(area_signed) + + ! write fallback into SCRIP arrays + SCRIP_CornerLon(:,n) = modulo([p1(1),p2(1),p3(1),p4(1)]*(180._8/pi),360.0_8) + SCRIP_CornerLat(:,n) = [p1(2),p2(2),p3(2),p4(2)]*(180._8/pi) + fallback_mask(n) = .true. + failed_cells = failed_cells + 1 + + n = n + 1 + cycle + end if + + ! 2) Clamp and correct the “real” node_xy_tmp before hull + do k = 1,4 + node_xy_tmp(1,k) = modulo(node_xy_tmp(1,k), 2.0d0*pi) + + ! longitude clamp + if (node_xy_tmp(1,k) < 1.0d-8) node_xy_tmp(1,k) = 1.0d-8 + if (node_xy_tmp(1,k) > 2.0d0*pi - 1.0d-8) node_xy_tmp(1,k) = 2.0d0*pi - 1.0d-8 + + ! latitude clamp + if (node_xy_tmp(2,k) < -pi/2.0d0) node_xy_tmp(2,k) = -pi/2.0d0 + if (node_xy_tmp(2,k) > pi/2.0d0) node_xy_tmp(2,k) = pi/2.0d0 + end do + + ! 3) Attempt the real hull + call points_hull_2d(4, node_xy_tmp, hull_num, hull) + + ! If hull fails, try jitter fallback near cell center + if (hull_num /= 4) then + eps = 1.0d-5*pi/180.0d0 + node_xy_tmp(:,1) = [tmp_center_lons(i,j)-eps, tmp_center_lats(i,j)-eps] + node_xy_tmp(:,2) = [tmp_center_lons(i,j)+eps, tmp_center_lats(i,j)-eps] + node_xy_tmp(:,3) = [tmp_center_lons(i,j)+eps, tmp_center_lats(i,j)+eps] + node_xy_tmp(:,4) = [tmp_center_lons(i,j)-eps, tmp_center_lats(i,j)+eps] + call points_hull_2d(4, node_xy_tmp, hull_num, hull) + end if + + ! If still fails, fallback to explicit tiny cell at real center + if (hull_num /= 4) then + tiny_dlon = 1.0d-2 * pi/180.0d0 + tiny_dlat = 1.0d-2 * pi/180.0d0 + clon = tmp_center_lons(i,j) + clat = tmp_center_lats(i,j) + node_xy_tmp(:,1) = [modulo(clon-tiny_dlon,2*pi), clat-tiny_dlat] + node_xy_tmp(:,2) = [modulo(clon+tiny_dlon,2*pi), clat-tiny_dlat] + node_xy_tmp(:,3) = [modulo(clon+tiny_dlon,2*pi), clat+tiny_dlat] + node_xy_tmp(:,4) = [modulo(clon-tiny_dlon,2*pi), clat+tiny_dlat] + hull_num = 4 + hull = [1,2,3,4] + end if + + ! Ensure corners are finite; if not, rebuild tiny polygon + bad_corner = .false. + do k=1,4 + if (node_xy_tmp(1,k) /= node_xy_tmp(1,k) .or. abs(node_xy_tmp(1,k)) > 1.0d10) bad_corner = .true. + if (node_xy_tmp(2,k) /= node_xy_tmp(2,k) .or. abs(node_xy_tmp(2,k)) > 1.0d10) bad_corner = .true. + end do + if (bad_corner) then + clon = tmp_center_lons(i,j) + clat = tmp_center_lats(i,j) + tiny_dlon = 1.0d-4 * pi/180._8 + tiny_dlat = 1.0d-4 * pi/180._8 + node_xy_tmp(:,1) = [modulo(clon-tiny_dlon,2*pi), clat-tiny_dlat] + node_xy_tmp(:,2) = [modulo(clon+tiny_dlon,2*pi), clat-tiny_dlat] + node_xy_tmp(:,3) = [modulo(clon+tiny_dlon,2*pi), clat+tiny_dlat] + node_xy_tmp(:,4) = [modulo(clon-tiny_dlon,2*pi), clat+tiny_dlat] + hull_num = 4 + hull = [1,2,3,4] + fallback_mask(n) = .true. + endif + + ! 4) Reorder hull consistently -> p1,p2,p3,p4 + call safe_reorder_hull(node_xy_tmp, hull, p1, p2, p3, p4, n, i, j) + + area_signed = get_signed_area_spherical_polygon(p1, p2, p3, p4) + + ! If NaN/inf/tiny/huge area, rebuild a tiny CCW square and recompute + if (area_signed /= area_signed .or. abs(area_signed) < 1.0d-12 .or. abs(area_signed) > 1.0d10) then + clon = tmp_center_lons(i,j) + clat = tmp_center_lats(i,j) + tiny_dlon = 1.0d-4 * pi/180._8 + tiny_dlat = 1.0d-4 * pi/180._8 + p1 = [modulo(clon-tiny_dlon,2*pi), clat-tiny_dlat] + p2 = [modulo(clon+tiny_dlon,2*pi), clat-tiny_dlat] + p3 = [modulo(clon+tiny_dlon,2*pi), clat+tiny_dlat] + p4 = [modulo(clon-tiny_dlon,2*pi), clat+tiny_dlat] + area_signed = get_signed_area_spherical_polygon(p1, p2, p3, p4) + fallback_mask(n) = .true. + end if + + ! Enforce CCW orientation for SCRIP (positive signed area) + if (area_signed < 0.0d0) then + swap_p = p2; p2 = p4; p4 = swap_p + area_signed = -area_signed + endif + + ! Write CCW corners and POSITIVE area + SCRIP_CornerLon(:,n) = modulo([p1(1),p2(1),p3(1),p4(1)]*(180._8/pi), 360.0_8) + SCRIP_CornerLat(:,n) = [p1(2),p2(2),p3(2),p4(2)]*(180._8/pi) + SCRIP_Area(n) = area_signed + + else + ! ----- Regular grid path: enforce CLOCKWISE corners ----- + ! node_xy is (lon,lat) in radians with canonical perimeter order: + ! 1:(i,j), 2:(i+1,j), 3:(i+1,j+1), 4:(i,j+1) + + p1 = node_xy(:,1) + p2 = node_xy(:,2) + p3 = node_xy(:,3) + p4 = node_xy(:,4) + + area_signed = get_signed_area_spherical_polygon(p1, p2, p3, p4) ! >0 CCW, <0 CW + + if (area_signed > 0.d0) then + swap_p = p2; p2 = p4; p4 = swap_p ! make CW + end if + + SCRIP_CornerLon(:,n) = modulo([p1(1),p2(1),p3(1),p4(1)]*(180._8/pi), 360.0_8) + SCRIP_CornerLat(:,n) = [p1(2),p2(2),p3(2),p4(2)]*(180._8/pi) + + SCRIP_Area(n) = sph_tri_area_rad(p1,p2,p3) + sph_tri_area_rad(p1,p3,p4) ! steradians + if (SCRIP_Area(n) <= 0.d0) SCRIP_Area(n) = 1.d-12 + end if + !============================================================== + ! Per-cell metrics & rrfac inputs + ! - Regular: rrfac(n) holds the per-cell length (legacy); we + ! convert to final rrfac after the loop. + ! - Stretched: rrfac is computed later (Gaussian profile); + ! here we only collect a robust per-cell length. + !============================================================== + if (.not. do_schmidt) then + !----- ORIGINAL REGULAR GRID LOGIC (legacy) ----- + dummy_max = 0.0d0 + dummy_min = huge(1.0d0) + call get_grid_length(p1, p2, p3, tmp_len, dummy_max, dummy_min) + + ! Legacy behavior: store per-cell length in SCRIP_rrfac(n) + SCRIP_rrfac(n) = tmp_len + + ! Also track the same per-cell length into our arrays so the + ! post-loop reduction works uniformly for both modes + local_max_length_all(n) = tmp_len + local_min_length_all(n) = tmp_len + + else + !----- STRETCHED GRID PATH ----- + ! Keep the area guard + if (SCRIP_Area(n) /= SCRIP_Area(n) .or. SCRIP_Area(n) <= 0.0d0) then + write(*,*) '[CRITICAL FIX] Non-positive or NaN area at cell:', n, ' original area:', SCRIP_Area(n) + SCRIP_Area(n) = 1.0d-12 + fallback_mask(n) = .true. + endif + + ! Use the same geometric length metric as regular grids + dummy_max = 0.0d0 + dummy_min = huge(1.0d0) + call get_grid_length(p1, p2, p3, tmp_len, dummy_max, dummy_min) + + ! Store per-cell length for later global reductions + local_max_length_all(n) = tmp_len + local_min_length_all(n) = tmp_len + endif + + ! Minimal diagnostics (both modes) + if (local_min_length_all(n) <= 1.0d-12) then + write(*,*) "CRITICAL DEBUG cell:", n, i, j + write(*,*) "local_min_length very small or zero:", local_min_length_all(n) + write(*,*) "Polygon lengths (km):", & + great_circle_dist(p1,p2,6371.d0), & + great_circle_dist(p2,p3,6371.d0), & + great_circle_dist(p3,p4,6371.d0), & + great_circle_dist(p4,p1,6371.d0) + write(*,*) "Polygon coords (deg):", & + "p1", p1*180/pi, "p2", p2*180/pi, & + "p3", p3*180/pi, "p4", p4*180/pi + endif + + n = n + 1 + end do ! closes i loop + end do ! closes j loop + + write(*,*) 'Finished per-cell geometry/length pass' + call MPI_Barrier(mpiC, mpi_err) + + !---------------- Global min/max of per-cell length ---------------- + local_max_length = maxval(local_max_length_all) + local_min_length = minval(local_min_length_all) + + call MPI_Allreduce(local_max_length, global_max_length, 1, MPI_DOUBLE_PRECISION, MPI_MAX, mpiC, mpi_err) + call MPI_Allreduce(local_min_length, global_min_length, 1, MPI_DOUBLE_PRECISION, MPI_MIN, mpiC, mpi_err) + + if (global_min_length <= 0.0d0 .or. global_min_length /= global_min_length) then + global_min_length = max(1.0d-12, global_max_length * 1.0d-4) + end if + min_allowed_length = max(1.0d-12, global_max_length * 1.0d-3) + + + if (do_schmidt) then + !--- Guard areas and compute global area bounds (diagnostics only) + do cell = n_start, n_end + if (SCRIP_Area(cell) < 1.0d-12 .or. SCRIP_Area(cell) /= SCRIP_Area(cell)) then + SCRIP_Area(cell) = 1.0d-12 + fallback_mask(cell) = .true. + end if + end do + + valid_count_local = count(.not. fallback_mask(n_start:n_end)) + if (valid_count_local > 0) then + max_area_local = maxval(SCRIP_Area(n_start:n_end), mask=.not. fallback_mask(n_start:n_end)) + min_area_local = minval(SCRIP_Area(n_start:n_end), mask=.not. fallback_mask(n_start:n_end)) + else + max_area_local = 0.0d0 + min_area_local = huge(1.0d0) + end if + call MPI_Allreduce(max_area_local, global_max_area, 1, MPI_DOUBLE_PRECISION, MPI_MAX, mpiC, mpi_err) + call MPI_Allreduce(min_area_local, global_min_area, 1, MPI_DOUBLE_PRECISION, MPI_MIN, mpiC, mpi_err) + if (global_max_area <= 0.0d0 .or. global_max_area /= global_max_area) global_max_area = 1.0d-12 + if (global_min_area <= 0.0d0 .or. global_min_area /= global_min_area) global_min_area = 1.0d-12 + + !--- Build the Gaussian radial rrfac about (target_lon, target_lat) + max_rrfac_allowed = 100.0d0 + clamp_count_local = 0 + fallback_count_local = count(fallback_mask(n_start:n_end)) + + deg2rad = acos(-1.0d0)/180.0d0 + lonc = target_lon; if (lonc < 0.d0) lonc = lonc + 360.d0 + latc = target_lat + + ! Use global length contrast computed earlier to set the peak + valid_count_local = count(.not. fallback_mask(n_start:n_end)) + if (valid_count_local > 0) then + max_len_local = maxval(local_max_length_all(n_start:n_end), mask=.not. fallback_mask(n_start:n_end)) + min_len_local = minval(local_min_length_all(n_start:n_end), mask=.not. fallback_mask(n_start:n_end)) + else + max_len_local = 0.0d0 + min_len_local = huge(1.0d0) + end if + call MPI_Allreduce(max_len_local, global_max_length, 1, MPI_DOUBLE_PRECISION, MPI_MAX, mpiC, mpi_err) + call MPI_Allreduce(min_len_local, global_min_length, 1, MPI_DOUBLE_PRECISION, MPI_MIN, mpiC, mpi_err) + if (global_max_length <= 0.d0 .or. global_max_length /= global_max_length) global_max_length = 1.0d0 + if (global_min_length <= 0.d0 .or. global_min_length /= global_min_length) global_min_length = global_max_length + + !============================================================== + ! Width knob: choose a *continental* footprint. + ! For sf=2.5 this gives half-power ~25° (covers most of CONUS). + ! If you want even broader, bump 40 -> 45 or 50. + ! (FWHM radius = half_power_radius_deg by our definition.) + ! Width knob, narrower if stretch_factor is larger + ! USING LENGTH: Peak magnitude from *edge-length* ratio (matches legacy behavior), capped + ! --- Radial “bullseye” centered on (target_lon, target_lat) --- + ! Continental footprint: ~25° half-power for sf≈2.5; scales gently with stretch + !============================================================== + half_power_radius_deg = 40.0d0 / sqrt(max(1.0d0, dble(stretch_factor))) + theta0 = (half_power_radius_deg*deg2rad) / sqrt(log(2.d0)) + + ! Peak magnitude from *edge-length* ratio (legacy-aligned), capped + ratio = global_max_length / max(global_min_length, 1.0d-12) + if (ratio < 1.d0) ratio = 1.d0 + desired_peak = min(max_rrfac_allowed, ratio) + if (localPet == 0) then + write(*,*) 'RRFAC length ratio:', ratio, ' desired_peak:', desired_peak, & + ' half_power_radius_deg:', half_power_radius_deg + end if + + do cell = n_start, n_end + if (fallback_mask(cell)) then + SCRIP_rrfac(cell) = 1.d0 + else + dlon = modulo(SCRIP_CenterLon(cell) - lonc + 180.d0, 360.d0) - 180.d0 + lat1 = SCRIP_CenterLat(cell) * deg2rad + lat2 = latc * deg2rad + dlam = dlon * deg2rad + cc = sin(lat1)*sin(lat2) + cos(lat1)*cos(lat2)*cos(dlam) + cc = max(-1.d0, min(1.d0, cc)) + dtheta = acos(cc) + + ! Gaussian radial profile: 1 far away, ~desired_peak at center + w = exp( - (dtheta/theta0)**2 ) + SCRIP_rrfac(cell) = 1.d0 + (desired_peak - 1.d0) * w + + if (SCRIP_rrfac(cell) > max_rrfac_allowed) then + SCRIP_rrfac(cell) = max_rrfac_allowed + clamp_count_local = clamp_count_local + 1 + end if + end if + end do + + ! --- Peak/diagnostics block (global max, apex, counts) --- + if (any(.not. fallback_mask(n_start:n_end))) then + local_max_rrfac = maxval(SCRIP_rrfac(n_start:n_end), mask=.not. fallback_mask(n_start:n_end)) + else + local_max_rrfac = -huge(1.0d0) + end if + call MPI_Allreduce(local_max_rrfac, global_max_rrfac, 1, MPI_DOUBLE_PRECISION, MPI_MAX, mpiC, mpi_err) + + ! Choose unique apex: the near-max cell closest to (lonc,latc) + best_dist = huge(1.0d0); best_idx = -1 + lat2 = latc * deg2rad + do cell = n_start, n_end + if (.not. fallback_mask(cell)) then + if (SCRIP_rrfac(cell) >= (1.0d0 - 1.0d-6)*global_max_rrfac) then + dlon = modulo(SCRIP_CenterLon(cell) - lonc + 180.d0, 360.d0) - 180.d0 + lat1 = SCRIP_CenterLat(cell) * deg2rad + dlam = dlon * deg2rad + cc = sin(lat1)*sin(lat2) + cos(lat1)*cos(lat2)*cos(dlam) + cc = max(-1.d0, min(1.d0, cc)) + dtheta = acos(cc) + if (dtheta < best_dist) then + best_dist = dtheta + best_idx = cell + end if + end if + end if + end do + + pair_local(1) = best_dist + pair_local(2) = real(max(0,best_idx), 8) + call MPI_Allreduce(pair_local, pair_global, 1, MPI_2DOUBLE_PRECISION, MPI_MINLOC, mpiC, mpi_err) + global_idx_max_rrfac = int(pair_global(2)) + + ! Nudge chosen cell to be strictly largest, then recompute the peak + if (global_idx_max_rrfac >= n_start .and. global_idx_max_rrfac <= n_end) then + SCRIP_rrfac(global_idx_max_rrfac) = max(SCRIP_rrfac(global_idx_max_rrfac), global_max_rrfac*(1.0d0+1.0d-12)) + end if + if (any(.not. fallback_mask(n_start:n_end))) then + local_max_rrfac = maxval(SCRIP_rrfac(n_start:n_end), mask=.not. fallback_mask(n_start:n_end)) + else + local_max_rrfac = -huge(1.0d0) + end if + call MPI_Allreduce(local_max_rrfac, global_max_rrfac, 1, MPI_DOUBLE_PRECISION, MPI_MAX, mpiC, mpi_err) + + ! rrfac_max for downstream + rrfac_max = int(ceiling(min(max_rrfac_allowed, global_max_rrfac))) + write(*,*) 'Computed rrfac_max:', rrfac_max + + ! Location of the max (owner PET + broadcast of lon/lat) + if (global_idx_max_rrfac < 1 .or. global_idx_max_rrfac > size(SCRIP_CenterLon)) then + owner_pet = 0; owner_lon = -999.d0; owner_lat = -999.d0 + else + owner_pet = (global_idx_max_rrfac - 1) / (im_world*im_world) + owner_lon = -999.d0; owner_lat = -999.d0 + if (localPet == owner_pet) then + owner_lon = SCRIP_CenterLon(global_idx_max_rrfac) + owner_lat = SCRIP_CenterLat(global_idx_max_rrfac) + end if + end if + call MPI_Bcast(owner_lon, 1, MPI_DOUBLE_PRECISION, owner_pet, mpiC, mpi_err) + call MPI_Bcast(owner_lat, 1, MPI_DOUBLE_PRECISION, owner_pet, mpiC, mpi_err) + global_lon_max_rrfac = owner_lon + global_lat_max_rrfac = owner_lat + + ! Diagnostics (min/max/clamp/fallback counts) + if (any(.not. fallback_mask(n_start:n_end))) then + local_min_rrfac = minval(SCRIP_rrfac(n_start:n_end), mask=.not. fallback_mask(n_start:n_end)) + local_max_rrfac = maxval(SCRIP_rrfac(n_start:n_end), mask=.not. fallback_mask(n_start:n_end)) + else + local_min_rrfac = huge(1.0d0) + local_max_rrfac = -huge(1.0d0) + end if + call MPI_Allreduce(local_min_rrfac, global_min_rrfac_print, 1, MPI_DOUBLE_PRECISION, MPI_MIN, mpiC, mpi_err) + call MPI_Allreduce(local_max_rrfac, global_max_rrfac_print, 1, MPI_DOUBLE_PRECISION, MPI_MAX, mpiC, mpi_err) + call MPI_Allreduce(clamp_count_local, clamp_count_global, 1, MPI_INTEGER, MPI_SUM, mpiC, mpi_err) + call MPI_Allreduce(fallback_count_local, fallback_count_global, 1, MPI_INTEGER, MPI_SUM, mpiC, mpi_err) + + if (localPet == 0) then + write(*,*) "Final RRFAC diagnostics:" + write(*,*) " Min rrfac:", global_min_rrfac_print + write(*,*) " Max rrfac:", global_max_rrfac_print + write(*,*) " rrfac_max:", rrfac_max + write(*,*) " [GLOBAL] clamped cells:", clamp_count_global, " geometry fallbacks:", fallback_count_global + write(*,*) " MPI GLOBAL MAX RRFAC RESULTS:" + write(*,*) " global_max_rrfac:", global_max_rrfac + write(*,*) " global_idx_max_rrfac:", global_idx_max_rrfac + write(*,*) " owner PET:", owner_pet + write(*,*) " global_lon_max_rrfac:", global_lon_max_rrfac + write(*,*) " global_lat_max_rrfac:", global_lat_max_rrfac + end if + + num_rrfac_max_local = count( (.not. fallback_mask(n_start:n_end)) .and. & + (SCRIP_rrfac(n_start:n_end) >= (1.0d0 - 1.0d-5) * global_max_rrfac) ) + call MPI_Reduce(num_rrfac_max_local, num_rrfac_max, 1, MPI_INTEGER, MPI_SUM, 0, mpiC, mpi_err) + if (localPet == 0) then + write(*,*) ">>> Number of cells near max rrfac (0.001%):", num_rrfac_max + write(*,*) ">>> Intended center: Lon =", target_lon, "Lat =", target_lat + write(*,*) ">>> Actual max rrfac at Lon =", global_lon_max_rrfac, "Lat =", global_lat_max_rrfac + end if + + else + !---------------- Regular (non-stretch) final rrfac ---------------- + ! Legacy rule: rrfac = global_max_length / per_cell_length + SCRIP_rrfac(n_start:n_end) = global_max_length / max(SCRIP_rrfac(n_start:n_end), 1.0d-12) + end if + !======================== END FINAL RRFAC ========================= + + 100 format(a,4f20.15) + 101 format(a,f20.15) + 102 format(2f20.15) + 103 format(a) + deallocate( IMS ) + deallocate( JMS ) + + scrip_size = IM_World*JM_World + call MPI_Info_create(info, status); _VERIFY(status) + call MPI_Info_set(info, "cb_buffer_size", "1048576", status); _VERIFY(status) + + if (len_trim(output_scrip) == 0) then + write(*,*) 'ERROR: output_scrip is blank!' + call ESMF_Finalize(rc=status) + stop 1 + endif + + status = nf90_create(trim(output_scrip), IOR(NF90_MPIIO,IOR(NF90_CLOBBER,NF90_NETCDF4)), unit, comm=mpiC, info=info) + _VERIFY(status) + + FMT = '(A,' // 'A,' //'A)' + write(title,trim(FMT)) 'GMAO ',trim(gridname),' Grid' + status = nf90_put_att(UNIT, NF90_GLOBAL, 'title',trim(title)); _VERIFY(status) + status = nf90_put_att(UNIT, NF90_GLOBAL, 'GridDescriptionFormat','SCRIP'); _VERIFY(status) + if (do_schmidt) then + status = nf90_put_att(UNIT, NF90_GLOBAL, 'rrfac_max', rrfac_max); _VERIFY(status) + endif + + status = NF90_DEF_DIM(UNIT, 'grid_size' , scrip_size, gridsize); _VERIFY(status) + status = NF90_DEF_DIM(UNIT, 'grid_corners', grid_corners, cornerdimID); _VERIFY(status) + status = NF90_DEF_DIM(UNIT, 'grid_rank' , 1, rankdim); _VERIFY(status) + + ! grid_dims (unstructured marker) + status = nf90_def_var(UNIT, "grid_dims", NF90_INT, [rankdim], griddim); _VERIFY(status) + + ! grid_imask + status = nf90_def_var(UNIT, "grid_imask", NF90_INT, [gridsize], mask); _VERIFY(status) + status = nf90_put_att(UNIT, mask, "units", "unitless"); _VERIFY(status) + + ! stretched/geometry fallback mask (1D) + status = nf90_def_var(UNIT, "grid_fallback_mask", NF90_INT, [gridsize], varid_mask_fallback); _VERIFY(status) + status = nf90_put_att(UNIT, varid_mask_fallback, "description", "1 = fallback area used, 0 = valid"); _VERIFY(status) + status = nf90_put_att(UNIT, varid_mask_fallback, "units", "unitless"); _VERIFY(status) + + ! centers + status = nf90_def_var(UNIT, "grid_center_lon", NF90_DOUBLE, [gridsize], centerlon); _VERIFY(status) + status = nf90_put_att(UNIT, centerlon, "units", "degrees"); _VERIFY(status) + status = nf90_def_var(UNIT, "grid_center_lat", NF90_DOUBLE, [gridsize], centerlat); _VERIFY(status) + status = nf90_put_att(UNIT, centerlat, "units", "degrees"); _VERIFY(status) + + ! corners + status = nf90_def_var(UNIT, "grid_corner_lon", NF90_DOUBLE, [cornerdimID,gridsize], cornerlon); _VERIFY(status) + status = nf90_put_att(UNIT, cornerlon, "units", "degrees"); _VERIFY(status) + status = nf90_def_var(UNIT, "grid_corner_lat", NF90_DOUBLE, [cornerdimID,gridsize], cornerlat); _VERIFY(status) + status = nf90_put_att(UNIT, cornerlat, "units", "degrees"); _VERIFY(status) + + ! area + status = nf90_def_var(UNIT, "grid_area", NF90_DOUBLE, [gridsize], cellarea); _VERIFY(status) + status = nf90_put_att(UNIT, cellarea, "units", "radians^2"); _VERIFY(status) + + ! rrfac only for stretched + if (do_schmidt) then + status = nf90_def_var(UNIT, "rrfac", NF90_DOUBLE, [gridsize], cellrrfac); _VERIFY(status) + status = nf90_put_att(UNIT, cellrrfac, "units", "unitless"); _VERIFY(status) + endif + + status = nf90_enddef(UNIT); _VERIFY(status) + + ! grid_dims value + rc = NF90_PUT_VAR(UNIT, griddim, (/ scrip_size /)) + + allocate (sendData(1), GlobalCounts(npets), recvCounts(npets), recvOffsets(npets), stat=status); _VERIFY(status) + sendData = tmp + recvCounts = 1 + recvOffsets = 0 + do i=2, npets + recvOffsets(i) = recvOffsets(i-1) + recvCounts(i-1) + end do + call ESMF_VMGatherV(vm, sendData=sendData, sendCount=1, recvData=GlobalCounts, recvCounts=recvCounts, recvOffsets=recvOffsets, rootPet=0, rc=status); _VERIFY(status) + call ESMF_VMBroadcast(vm, bcstData=GlobalCounts, count=npets, rootPet=0, rc=status); _VERIFY(status) + + ! ------------------- File vs memory spans ------------------- + ! FILE: global slice for this PET (must differ by PET) + if (do_schmidt) then + start_file = n_start ! already global index in stretched mode + else + start_file = localPet * num_local_cells + 1 + end if + cnt_file = num_local_cells + + ! MEMORY: regular uses local-sized arrays; stretched uses global-sized + if (do_schmidt) then + mem_start = n_start + else + mem_start = 1 + end if + mem_end = mem_start + cnt_file - 1 + ! ----------------------------------------------------------- + + ! 1D writes: centers / area / (rrfac only if stretched) / imask + start(1) = start_file + cnt(1) = cnt_file + + status = NF90_PUT_VAR(UNIT, centerlon, SCRIP_CenterLon(mem_start:mem_end), start, cnt); _VERIFY(status) + status = NF90_PUT_VAR(UNIT, centerlat, SCRIP_CenterLat(mem_start:mem_end), start, cnt); _VERIFY(status) + status = NF90_PUT_VAR(UNIT, cellarea , SCRIP_Area (mem_start:mem_end), start, cnt); _VERIFY(status) + + if (do_schmidt) then + status = NF90_PUT_VAR(UNIT, cellrrfac, SCRIP_rrfac(mem_start:mem_end), start, cnt); _VERIFY(status) + end if + + allocate(grid_imask(cnt_file), stat=status); _VERIFY(status) + grid_imask = 1 + status = NF90_PUT_VAR(UNIT, mask, grid_imask, start, cnt); _VERIFY(status) + deallocate(grid_imask) + + ! Fallback mask (1D) + allocate(mask_fallback(cnt_file), stat=status); _VERIFY(status) + mask_fallback = 0 + where (fallback_mask(mem_start:mem_end)) mask_fallback = 1 + start(1) = start_file + cnt(1) = cnt_file + status = NF90_PUT_VAR(UNIT, varid_mask_fallback, mask_fallback, start, cnt); _VERIFY(status) + deallocate(mask_fallback) + + ! 2D corners: (corner=1..4, cells = this PET's global slice) + start(1) = 1 + start(2) = start_file + cnt(1) = grid_corners + cnt(2) = cnt_file + + allocate(my_corner_lat(grid_corners, cnt_file), stat=status); _VERIFY(status) + allocate(my_corner_lon(grid_corners, cnt_file), stat=status); _VERIFY(status) + + my_corner_lat = SCRIP_CornerLat(:, mem_start:mem_end) + my_corner_lon = SCRIP_CornerLon(:, mem_start:mem_end) + + status = NF90_PUT_VAR(UNIT, cornerlat, my_corner_lat, start, cnt); _VERIFY(status) + status = NF90_PUT_VAR(UNIT, cornerlon, my_corner_lon, start, cnt); _VERIFY(status) + + deallocate(my_corner_lat, my_corner_lon) + + if (localPet == 0) write(*,*) 'WRITE slices file:[', start_file, start_file+cnt_file-1, '] mem:[', mem_start, mem_end, ']' + + call MPI_Barrier(mpiC, mpi_err); _VERIFY(mpi_err) + status = NF90_CLOSE(UNIT); _VERIFY(status) + call MPI_Barrier(mpiC, mpi_err); _VERIFY(mpi_err) + call ESMF_VMBarrier(vm, rc=status); _VERIFY(status) + call ESMF_Finalize ( rc=status); _VERIFY(status) + + if (allocated(SCRIP_CenterLat)) deallocate(SCRIP_CenterLat) + if (allocated(SCRIP_CenterLon)) deallocate(SCRIP_CenterLon) + if (allocated(SCRIP_CornerLat)) deallocate(SCRIP_CornerLat) + if (allocated(SCRIP_CornerLon)) deallocate(SCRIP_CornerLon) + if (allocated(SCRIP_Area)) deallocate(SCRIP_Area) + if (allocated(SCRIP_rrfac)) deallocate(SCRIP_rrfac) + if (allocated(sendData)) deallocate(sendData) + if (allocated(GlobalCounts)) deallocate(GlobalCounts) + deallocate(recvCounts) + deallocate(recvOffsets) + deallocate(fallback_mask) + + contains + +subroutine angle_rad_2d ( p1, p2, p3, res ) +!*****************************************************************************80 +! +!! ANGLE_RAD_2D returns the angle swept out between two rays in 2D. +! +! Discussion: +! +! Except for the zero angle case, it should be true that +! +! ANGLE_RAD_2D ( P1, P2, P3 ) + ANGLE_RAD_2D ( P3, P2, P1 ) = 2 * PI +! +! P1 +! / +! / +! / +! / +! P2--------->P3 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 15 January 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( REAL64 ) P1(2), P2(2), P3(2), define the rays +! P1 - P2 and P3 - P2 which define the angle. +! +! Output, real ( REAL64 ) ANGLE_RAD_2D, the angle swept out by the rays, +! in radians. 0 <= ANGLE_RAD_2D < 2 * PI. If either ray has zero +! length, then ANGLE_RAD_2D is set to 0. + implicit none + + integer, parameter :: dim_num = 2 + + real (REAL64), parameter :: pi = 3.141592653589793D+00 + real (REAL64) p(dim_num) + real (REAL64) p1(dim_num) + real (REAL64) p2(dim_num) + real (REAL64) p3(dim_num) + real (REAL64) res + + p(1) = ( p3(1) - p2(1) ) * ( p1(1) - p2(1) ) & + + ( p3(2) - p2(2) ) * ( p1(2) - p2(2) ) + + + p(2) = ( p3(1) - p2(1) ) * ( p1(2) - p2(2) ) & + - ( p3(2) - p2(2) ) * ( p1(1) - p2(1) ) + + if ( p(1) == 0.0D+00 .and. p(2) == 0.0D+00 ) then + res = 0.0D+00 + return + end if + + res = atan2 ( p(2), p(1) ) + + if ( res < 0.0D+00 ) then + res = res + 2.0D+00 * pi + end if + + return +end + + +subroutine points_hull_2d ( node_num, node_xy, hull_num, hull ) + +!*****************************************************************************80 +! +!! POINTS_HULL_2D computes the convex hull of 2D points. +! +! Discussion: +! +! The work involved is N*log(H), where N is the number of points, and H is +! the number of points that are on the hull. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 12 June 2006 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer NODE_NUM, the number of nodes. +! +! Input, real ( REAL64 ) NODE_XY(2,NODE_NUM), the coordinates of the nodes. +! +! Output, integer HULL_NUM, the number of nodes that lie on +! the convex hull. +! +! Output, integer HULL(NODE_NUM). Entries 1 through HULL_NUM +! contain the indices of the nodes that form the convex hull, in order. +! Jun,2025 Robustness enhancements added for numerical stability and polar cases. +! + implicit none + + integer, intent(in) :: node_num + real(REAL64) angle + real(REAL64) angle_max + real(REAL64) di + real(REAL64) dr + real(REAL64) eps, lon_min, lon_max + integer, intent(out) :: hull_num + integer, intent(out) :: hull(node_num) + integer :: i, q, r, first + real(REAL64) node_xy(2,node_num) + real(REAL64) p_xy(2) + real(REAL64) q_xy(2) + real(REAL64) r_xy(2) + logical :: polar_cell + integer :: node_num_unique + real(REAL64), allocatable :: unique_xy(:,:) + real(REAL64), parameter :: pi = 3.141592653589793d0 + + if ( node_num < 1 ) then + hull_num = 0 + return + elseif ( node_num <= 2 ) then + hull_num = node_num + hull(1:node_num) = (/ (i, i=1,node_num) /) + return + endif + + ! Step 1: Remove duplicate points (numerical degeneracy fix) + + eps = 1.0d-12 + allocate(unique_xy(2, node_num)) + + call remove_duplicate_points(node_xy, node_num, eps, unique_xy, node_num_unique) + + ! Update the original array: + node_xy(:,1:node_num_unique) = unique_xy(:,1:node_num_unique) + + deallocate(unique_xy) + + ! Step 2: Handle longitude periodicity + + do i = 1, node_num_unique + node_xy(1,i) = modulo(node_xy(1,i), 2.0d0*pi) + enddo + + lon_min = minval(node_xy(1,1:node_num_unique)) + lon_max = maxval(node_xy(1,1:node_num_unique)) + + if (lon_max - lon_min > pi) then + do i = 1, node_num_unique + if (node_xy(1,i) < lon_min + pi) then + node_xy(1,i) = node_xy(1,i) + 2.0d0*pi + endif + enddo + endif + + ! Step 3: Detect and handle polar cells + + polar_cell = all(abs(node_xy(2,1:node_num_unique))*180.d0/pi >= 89.0d0) + if (polar_cell) then + call handle_polar_cell(node_num_unique, node_xy(:,1:node_num_unique), hull_num, hull) + return + endif + + ! Step 4: Original convex hull algorithm begins (unchanged original logic) + +! Find the leftmost point and call it "Q". +! In case of ties, take the bottom-most. +! + q = 1 + do i = 2, node_num_unique + if ( node_xy(1,i) < node_xy(1,q) .or. & + ( node_xy(1,i) == node_xy(1,q) .and. node_xy(2,i) < node_xy(2,q) ) ) then + q = i + end if + end do + + q_xy(1:2) = node_xy(1:2,q) + +! +! Remember the starting point, so we know when to stop! +! + first = q + hull_num = 1 + hull(1) = q +! +! For the first point, make a dummy previous point, 1 unit south, +! and call it "P". +! + p_xy(1) = q_xy(1) + p_xy(2) = q_xy(2) - 1.0D+00 +! +! Now, having old point P, and current point Q, find the new point R +! so the angle PQR is maximal. +! +! Watch out for the possibility that the two nodes are identical. +! + do + + r = 0 + angle_max = 0.0D+00 + + do i = 1, node_num_unique + + if ( i /= q .and. & + ( node_xy(1,i) /= q_xy(1) .or. node_xy(2,i) /= q_xy(2) ) ) then + + call angle_rad_2d(p_xy, q_xy, node_xy(1:2,i),angle) + + if ( r == 0 .or. angle_max < angle ) then + + r = i + r_xy(1:2) = node_xy(1:2,r) + angle_max = angle +! +! In case of ties, choose the nearer point. +! + else if ( r /= 0 .and. angle == angle_max ) then + + di = ( node_xy(1,i) - q_xy(1) )**2 + ( node_xy(2,i) - q_xy(2) )**2 + dr = ( r_xy(1) - q_xy(1) )**2 + ( r_xy(2) - q_xy(2) )**2 + + if ( di < dr ) then + r = i + r_xy(1:2) = node_xy(1:2,r) + angle_max = angle + end if + + end if + + end if + + end do +! +! We are done when we have returned to the first point on the convex hull. +! + if ( r == first ) then + exit + end if + + hull_num = hull_num + 1 + if ( node_num_unique < hull_num ) then + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) 'POINTS_HULL_2D - Fatal error!' + write ( *, '(a)' ) ' The algorithm has failed.' + stop + end if +! +! Add point R to convex hull. +! + hull(hull_num) = r +! +! Set P := Q, Q := R, and prepare to search for next point R. +! + q = r + + p_xy(1:2) = q_xy(1:2) + q_xy(1:2) = r_xy(1:2) + + end do + + return +end subroutine + +subroutine create_gmao_file(grid,im_world,filename,rc) + type(ESMF_Grid), intent(in) :: grid + integer, intent(in) :: im_world + character(len=*), intent(in) :: filename + integer, intent(out), optional :: rc + + integer :: status + real(ESMF_KIND_R8), pointer :: coords(:,:) + + integer :: ncid,info,lat_id,lon_id,clat_id,clon_id,nf_id,x_id,y_id,rank + integer :: xp1_id,yp1_id + real(ESMF_KIND_R8), allocatable :: temp_var(:,:) + + + call MPI_Info_create(info, status) + _VERIFY(status) + call MPI_Info_set(info, "cb_buffer_size", "1048576", status) + _VERIFY(status) + + status = nf90_create(filename,NF90_NETCDF4,ncid,comm=MPI_COMM_WORLD,info=info) + _VERIFY(status) + + status = nf90_def_dim(ncid,"nf",6,nf_id) + _VERIFY(status) + status = nf90_def_dim(ncid,"Xdim",im_world,x_id) + _VERIFY(status) + status = nf90_def_dim(ncid,"Ydim",im_world,y_id) + _VERIFY(status) + status = nf90_def_dim(ncid,"XCdim",im_world+1,xp1_id) + _VERIFY(status) + status = nf90_def_dim(ncid,"YCdim",im_world+1,yp1_id) + _VERIFY(status) + + status = nf90_def_var(ncid,"lons",NF90_DOUBLE,[x_id,y_id,nf_id],lon_id) + _VERIFY(status) + status = nf90_def_var(ncid,"lats",NF90_DOUBLE,[x_id,y_id,nf_id],lat_id) + _VERIFY(status) + status = nf90_def_var(ncid,"corner_lons",NF90_DOUBLE,[xp1_id,yp1_id,nf_id],clon_id) + _VERIFY(status) + status = nf90_def_var(ncid,"corner_lats",NF90_DOUBLE,[xp1_id,yp1_id,nf_id],clat_id) + _VERIFY(status) + + call MPI_COMM_RANK(MPI_COMM_WORLD,rank,status) + ! centers + call ESMF_GridGetCoord(grid, coordDim=1, localDE=0, & + staggerloc=ESMF_STAGGERLOC_CENTER, & + farrayPtr=coords, rc=status) + _VERIFY(status) + allocate(temp_var(im_world,im_world)) + temp_var = coords*180.d0/pi + status = NF90_put_var(ncid,lon_id,temp_var,start=[1,1,rank+1],count=[im_world,im_world,1]) + _VERIFY(status) + call ESMF_GridGetCoord(grid, coordDim=2, localDE=0, & + staggerloc=ESMF_STAGGERLOC_CENTER, & + farrayPtr=coords, rc=status) + _VERIFY(status) + temp_var = coords*180.d0/pi + status = NF90_put_var(ncid,lat_id,temp_var,start=[1,1,rank+1],count=[im_world,im_world,1]) + _VERIFY(status) + deallocate(temp_var) + ! corners + call ESMF_GridGetCoord(grid, coordDim=1, localDE=0, & + staggerloc=ESMF_STAGGERLOC_CORNER, & + farrayPtr=coords, rc=status) + _VERIFY(status) + allocate(temp_var(im_world+1,im_world+1)) + temp_var = coords*180.d0/pi + status = NF90_put_var(ncid,clon_id,temp_var,start=[1,1,rank+1],count=[im_world+1,im_world+1,1]) + _VERIFY(status) + call ESMF_GridGetCoord(grid, coordDim=2, localDE=0, & + staggerloc=ESMF_STAGGERLOC_CORNER, & + farrayPtr=coords, rc=status) + _VERIFY(status) + temp_var = coords*180.d0/pi + status = NF90_put_var(ncid,clat_id,temp_var,start=[1,1,rank+1],count=[im_world+1,im_world+1,1]) + _VERIFY(status) + deallocate(temp_var) + if (present(rc)) rc=0 + + end subroutine + + pure function central_angle(v1, v2) result(ang) + real(ESMF_KIND_R8), intent(in) :: v1(3), v2(3) + real(ESMF_KIND_R8) :: cp(3), dotp, ang + cp = [ v1(2)*v2(3)-v1(3)*v2(2), v1(3)*v2(1)-v1(1)*v2(3), v1(1)*v2(2)-v1(2)*v2(1) ] + dotp = v1(1)*v2(1) + v1(2)*v2(2) + v1(3)*v2(3) + ang = atan2( sqrt(cp(1)**2 + cp(2)**2 + cp(3)**2), dotp ) + end function central_angle + + real(ESMF_KIND_R8) pure function sph_tri_area_rad(pA, pB, pC) result(area) + implicit none + real(ESMF_KIND_R8), intent(in) :: pA(2), pB(2), pC(2) + real(ESMF_KIND_R8) :: a, b, c, s, t + real(ESMF_KIND_R8) :: A3(3), B3(3), C3(3) + + A3 = [cos(pA(2))*cos(pA(1)), cos(pA(2))*sin(pA(1)), sin(pA(2))] + B3 = [cos(pB(2))*cos(pB(1)), cos(pB(2))*sin(pB(1)), sin(pB(2))] + C3 = [cos(pC(2))*cos(pC(1)), cos(pC(2))*sin(pC(1)), sin(pC(2))] + + a = central_angle(B3, C3) + b = central_angle(C3, A3) + c = central_angle(A3, B3) + + s = 0.5d0*(a+b+c) + t = tan(0.5d0*s)*tan(0.5d0*(s-a))*tan(0.5d0*(s-b))*tan(0.5d0*(s-c)) + + if (t <= 0.d0) then + area = 0.d0 + else + area = 4.d0*atan( sqrt(t) ) + end if + end function sph_tri_area_rad + + function get_area_spherical_polygon(p1,p2,p3,p4) result(area) + ! p1..p4 are (lon,lat) in radians, ordered around the cell + real(ESMF_KIND_R8), intent(in) :: p1(2), p2(2), p3(2), p4(2) + real(ESMF_KIND_R8) :: area + area = sph_tri_area_rad(p1,p2,p3) + sph_tri_area_rad(p1,p3,p4) ! steradians + end function get_area_spherical_polygon + + subroutine get_grid_length(p1,p2,p3, local,max_length, min_length) + real(real64), intent(in) :: p1(2),p2(2),p3(2) + real(REAL64), intent(out) :: local + real(REAL64), intent(inout) :: max_length + real(REAL64), intent(inout) :: min_length + real(REAL64) :: dx, dy + + dx = great_circle_dist(p1,p2) + dy = great_circle_dist(p2,p3) + local = 0.5d0*(dx+dy) + max_length = max(local, max_length) + min_length = min(local, min_length) + end subroutine + + function convert_to_cart(v) result(xyz) + real(real64), intent(in) :: v(2) + real(real64) :: xyz(3) + + xyz(1)=cos(v(2))*cos(v(1)) + xyz(2)=cos(v(2))*sin(v(1)) + xyz(3)=sin(v(2)) + + end function convert_to_cart + +function spherical_angles(p1,p2,p3) result(spherical_angle) + real(real64) :: spherical_angle + real(real64), intent(in) :: p1(3),p2(3),p3(3) + + real (real64):: e1(3), e2(3), e3(3) + real (real64):: px, py, pz + real (real64):: qx, qy, qz + real (real64):: angle, ddd, threshold + integer n + real(REAL64), parameter :: PI = 3.14159265358979323846 + + do n=1,3 + e1(n) = p1(n) + e2(n) = p2(n) + e3(n) = p3(n) + enddo + + !------------------------------------------------------------------- + ! Page 41, Silverman's book on Vector Algebra; spherical trigonmetry + !------------------------------------------------------------------- + ! Vector P: + px = e1(2)*e2(3) - e1(3)*e2(2) + py = e1(3)*e2(1) - e1(1)*e2(3) + pz = e1(1)*e2(2) - e1(2)*e2(1) + ! Vector Q: + qx = e1(2)*e3(3) - e1(3)*e3(2) + qy = e1(3)*e3(1) - e1(1)*e3(3) + qz = e1(1)*e3(2) - e1(2)*e3(1) + + ddd = (px*px + py*py + pz*pz)*(qx*qx + qy*qy + qz*qz) + + threshold = 1.d-24 + if (ddd <= threshold) then + angle = 0.d0 + else + ddd = (px*qx + py*qy + pz*qz) / sqrt(ddd) + ddd = min(1.d0, max(-1.d0, ddd)) + angle = acos(ddd) + endif + + spherical_angle = angle +end function + +subroutine local_abort(rc,line_number) + integer, intent(in) :: rc + integer, intent(in) :: line_number + integer :: status + write(*,*) 'Aborting at line', line_number, 'rc=', rc + call MPI_Abort(MPI_COMM_WORLD, rc, status) +end subroutine local_abort + + +real(REAL64) function great_circle_dist( q1, q2, radius ) + real(REAL64), intent(IN) :: q1(2), q2(2) + real(REAL64), intent(IN), optional :: radius + + real (REAL64):: p1(2), p2(2) + real (REAL64):: beta + real(REAL64) :: dlon, dlat + real(REAL64), parameter :: pi = 3.141592653589793d0 + integer n + + do n=1,2 + p1(n) = q1(n) + p2(n) = q2(n) + enddo + + dlon = modulo( (p1(1)-p2(1)) + pi, 2.0d0*pi ) - pi + dlat = p1(2) - p2(2) + beta = sin(0.5d0*dlat)**2 + cos(p1(2))*cos(p2(2))*sin(0.5d0*dlon)**2 + beta = max(0.d0, min(1.d0, beta)) + beta = 2.d0*atan2( sqrt(beta), sqrt(max(0.d0, 1.d0 - beta)) ) + + if ( present(radius) ) then + great_circle_dist = radius * beta + else + great_circle_dist = beta ! Returns the angle + endif + +end function great_circle_dist + +subroutine remove_duplicate_points(points, num_points, eps, unique_points, num_unique) + implicit none + integer, intent(in) :: num_points + real(REAL64), intent(in) :: points(2,num_points), eps + real(REAL64), intent(out) :: unique_points(2,num_points) + integer, intent(out) :: num_unique + integer :: i, j + logical :: duplicate + + num_unique = 0 + do i = 1, num_points + duplicate = .false. + do j = 1, num_unique + if (sum(abs(points(:,i) - unique_points(:,j))) < eps) then + duplicate = .true. + exit + endif + enddo + if (.not. duplicate) then + num_unique = num_unique + 1 + unique_points(:,num_unique) = points(:,i) + endif + enddo +end subroutine + +subroutine safe_reorder_hull(node_xy_tmp, hull, p1, p2, p3, p4, n, i, j) + implicit none + real(8), intent(in) :: node_xy_tmp(2,4) + integer, intent(in) :: hull(4) + real(8), intent(out) :: p1(2), p2(2), p3(2), p4(2) + integer, intent(in) :: n, i, j + integer :: idx + real(8) :: tmp_nodes(2,4) + + do idx = 1,4 + if (hull(idx) < 1 .or. hull(idx) > 4) then + write(*,*) "CRITICAL INDEX ERROR at idx=", idx, & + " hull(idx)=", hull(idx), " cell (n,i,j)=", n,i,j + stop "Exiting due to invalid hull index" + endif + tmp_nodes(:,idx) = node_xy_tmp(:,hull(idx)) + enddo + + call reorder_hull_quad(tmp_nodes, p1, p2, p3, p4) + +end subroutine safe_reorder_hull + +subroutine handle_polar_cell(node_num, points, hull_num, hull) + implicit none + integer, intent(in) :: node_num + real(REAL64), intent(in) :: points(2,node_num) + integer, intent(out) :: hull_num, hull(node_num) + real(REAL64) :: angles(node_num), centroid(2) + integer :: i, idx(node_num) + + centroid = [sum(points(1,:)), sum(points(2,:))] / node_num + + do i = 1, node_num + angles(i) = atan2(points(2,i)-centroid(2), points(1,i)-centroid(1)) + idx(i) = i + enddo + + call sort_by_angles(node_num, angles, idx) + + hull_num = node_num + hull(1:node_num) = idx(1:node_num) +end subroutine + +subroutine sort_by_angles(n, angles, idx) + implicit none + integer, intent(in) :: n + real(REAL64), intent(inout) :: angles(n) + integer, intent(inout) :: idx(n) + integer :: i, j, tmp_idx + real(REAL64) :: tmp_angle + do i = 1, n-1 + do j = i+1, n + if (angles(j) < angles(i)) then + tmp_angle = angles(i); angles(i) = angles(j); angles(j) = tmp_angle + tmp_idx = idx(i); idx(i) = idx(j); idx(j) = tmp_idx + endif + enddo + enddo +end subroutine + +subroutine reorder_hull_quad(node_xy, p1, p2, p3, p4) + implicit none + real(8), intent(in) :: node_xy(2,4) + real(8), intent(out) :: p1(2), p2(2), p3(2), p4(2) + real(8) :: centroid(2), angles(4) + integer :: i, order(4), temp_order + real(8) :: temp_angle, temp_x(4), temp_y(4) + logical :: swapped + real(8) :: xyz1(3), xyz2(3), xyz3(3), xyz4(3), normal(3), xyz_centroid(3), orientation, tmp_p(2) + logical, parameter :: verbose = .false. + + ! Compute centroid + centroid = [sum(node_xy(1,:))/4.0_8, sum(node_xy(2,:))/4.0_8] + + ! Compute angles from centroid to each corner + do i = 1,4 + angles(i) = atan2(node_xy(2,i)-centroid(2), node_xy(1,i)-centroid(1)) + enddo + ! Immediately at start of routine: + if (verbose) then + write(*,*) "INSIDE reorder_hull_quad (INPUT):" + do i = 1,4 + write(*,*) " Corner ", i, ": Lon,Lat(deg):", node_xy(1,i)*180.0d0/pi, node_xy(2,i)*180.0d0/pi + end do + end if + + ! Initialize corner order + order = [1, 2, 3, 4] + + ! Robust bubble sort angles (ascending order) + do + swapped = .false. + do i = 1, 3 + if (angles(i) > angles(i+1)) then + ! Swap angles + temp_angle = angles(i) + angles(i) = angles(i+1) + angles(i+1) = temp_angle + + ! Swap order indices + temp_order = order(i) + order(i) = order(i+1) + order(i+1) = temp_order + + swapped = .true. + endif + enddo + if (.not. swapped) exit ! Sorted correctly + enddo + + ! Print explicitly sorted angles and corresponding corners + temp_x = node_xy(1,:) + temp_y = node_xy(2,:) + + ! Assign sorted corners explicitly + p1 = [temp_x(order(1)), temp_y(order(1))] + p2 = [temp_x(order(2)), temp_y(order(2))] + p3 = [temp_x(order(3)), temp_y(order(3))] + p4 = [temp_x(order(4)), temp_y(order(4))] + + xyz1 = lonlat_to_xyz(p1(1), p1(2)) + xyz2 = lonlat_to_xyz(p2(1), p2(2)) + xyz3 = lonlat_to_xyz(p3(1), p3(2)) + xyz4 = lonlat_to_xyz(p4(1), p4(2)) + + normal = cross(xyz1, xyz2) + cross(xyz2, xyz3) + cross(xyz3, xyz4) + cross(xyz4, xyz1) + xyz_centroid = (xyz1 + xyz2 + xyz3 + xyz4) / 4.0_8 + orientation = dot_product(normal, xyz_centroid) + + if (orientation > 0.0_8) then + tmp_p = p2 + p2 = p4 + p4 = tmp_p + endif + ! Just before exiting: + if (verbose) then + write(*,*) "INSIDE reorder_hull_quad (OUTPUT):" + write(*,*) " p1(deg):", p1*180.0d0/pi + write(*,*) " p2(deg):", p2*180.0d0/pi + write(*,*) " p3(deg):", p3*180.0d0/pi + write(*,*) " p4(deg):", p4*180.0d0/pi + end if + +end subroutine reorder_hull_quad + +! Calculate signed spherical polygon area using Girard's formula: +function get_signed_area_spherical_polygon(p1, p2, p3, p4) result(area_signed) + implicit none + real(8), intent(in) :: p1(2), p2(2), p3(2), p4(2) + real(8) :: area_signed + real(8) :: angles(4), excess + real(8), dimension(3) :: xyz1, xyz2, xyz3, xyz4 + + xyz1 = lonlat_to_xyz(p1(1), p1(2)) + xyz2 = lonlat_to_xyz(p2(1), p2(2)) + xyz3 = lonlat_to_xyz(p3(1), p3(2)) + xyz4 = lonlat_to_xyz(p4(1), p4(2)) + + angles(1) = vertex_angle(xyz4, xyz1, xyz2) + angles(2) = vertex_angle(xyz1, xyz2, xyz3) + angles(3) = vertex_angle(xyz2, xyz3, xyz4) + angles(4) = vertex_angle(xyz3, xyz4, xyz1) + + excess = sum(angles) - 2.0_8*pi + area_signed = excess ! negative for CW, positive for CCW +end function + +! Helper function to calculate vertex angle: +function vertex_angle(xyzA, xyzB, xyzC) result(angle) + implicit none + real(8), intent(in) :: xyzA(3), xyzB(3), xyzC(3) + real(8) :: angle + real(8), dimension(3) :: AB, CB, cross_prod + real(8) :: norm_cross, dot_prod + + AB = xyzA - xyzB + CB = xyzC - xyzB + + cross_prod = cross(AB, CB) + norm_cross = sqrt(dot_product(cross_prod, cross_prod)) + dot_prod = dot_product(AB, CB) + + angle = atan2(norm_cross, dot_prod) +end function + +! Convert spherical coordinates (lon,lat) to Cartesian coordinates +function lonlat_to_xyz(lon, lat) result(xyz) + real(kind=8), intent(in) :: lon, lat + real(kind=8) :: xyz(3) + + xyz(1) = cos(lat) * cos(lon) + xyz(2) = cos(lat) * sin(lon) + xyz(3) = sin(lat) +end function + +function cross(a, b) result(c) + real(kind=8), intent(in) :: a(3), b(3) + real(kind=8) :: c(3) + + c(1) = a(2)*b(3) - a(3)*b(2) + c(2) = a(3)*b(1) - a(1)*b(3) + c(3) = a(1)*b(2) - a(2)*b(1) +end function cross + + + end program ESMF_GenerateCSGridDescription diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/utils_topo/generate_topo.sh b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/utils_topo/generate_topo.sh new file mode 100755 index 000000000..5a52807ee --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/utils_topo/generate_topo.sh @@ -0,0 +1,90 @@ +#!/bin/bash +#SBATCH --time=24:00:00 +#SBATCH --nodes=1 --ntasks-per-node=126 +#SBATCH --job-name=topo_intel +#SBATCH --constraint=mil +#SBATCH --qos=benchmark +#SBATCH --partition=preops +#SBATCH --account=g0620 +#SBATCH --mail-type=ALL +#SBATCH --no-requeue + +# put path to path to bin here +export TOPODIR= +source ${TOPODIR}/g5_modules.sh + +echo "STARTING" +# generate intermediate cube +raw_latlon_data="/discover/nobackup/bmauer/gmted_topo/gmted_fix_superior/gmted_fixed_anartica_superior_caspian.nc4" +intermediate_cube="c3000.gmted_fixedanarticasuperior.nc" +source_topo="gmted_intel" + +cat << _EOF_ > bin_to_cube.nl +&binparams + raw_latlon_data_file='$raw_latlon_data' + output_file='$intermediate_cube' + ncube=3000 +/ +_EOF_ + +if [[ ! -e landm_coslat.nc ]]; then + ln -s $TOPODIR/landm_coslat.nc landm_coslat.nc +fi + +${TOPODIR}/bin_to_cube.x + +res=("12" "24" "48" "90" "180" "360" "720" "1120" "1440" "2880") +cutoff=25 +smoothmap[12]="773.91" +smoothmap[24]="386.52" +smoothmap[48]="193.07" +smoothmap[90]="102.91" +smoothmap[180]="51.44" +smoothmap[360]="25.71" +smoothmap[720]="12.86" +smoothmap[1120]="8.26" +smoothmap[1440]="6.43" +smoothmap[2880]="3.21" + +for n in "${res[@]}"; +do + + let jm=$n*6 + echo $n + echo ${smoothmap[$n]} + + export output_dir=output_${n} + if [[ ! -e $output_dir ]]; then + mkdir $output_dir + fi + + config_file=GenScrip.rc + let jm=$n*6 + echo $n + echo $jm + scripfile=PE${n}x${jm}-CF.nc4 + echo $scripfile + echo $config_file + cat << _EOF_ > ${config_file} +CUBE_DIM: $n +output_scrip: ${scripfile} +output_geos: c${n}_coords.nc4 +_EOF_ + mpirun -np 6 ${TOPODIR}/generate_scrip_cube_topo.x + rm GenScrip.rc + output_grid=PE${im}x${jm}-CF + if (( $res < $cutoff )); then + ${TOPODIR}/cube_to_target.x --grid_descriptor_file="PE${n}x${jm}-CF.nc4" --intermediate_cs_name=${intermediate_cube} --output_grid="PE${n}x${jm}-CF.nc4" --output_data_directory=${output_dir} --smoothing_scale=${smoothmap[$n]} --name_email_of_creator='gmao' --fine_radius=0 --output_grid=${output_grid} --source_data_identifier=${source_topo} --jmax_segments=100000 + else + ${TOPODIR}/cube_to_target.x --grid_descriptor_file="PE${n}x${jm}-CF.nc4" --intermediate_cs_name=${intermediate_cube} --output_grid="PE${n}x${jm}-CF.nc4" --output_data_directory=${output_dir} --smoothing_scale=${smoothmap[$n]} --name_email_of_creator='gmao' --fine_radius=0 --output_grid=${output_grid} --source_data_identifier=${source_topo} + fi + rm $scripfile + + #convert to gmao + cd ${output_dir} + arr=(*.nc) + echo ${arr[0]} + ${TOPODIR}/scrip_to_restart_topo.py -i ${arr[0]} -o gwd_internal_rst + ${TOPODIR}/convert_to_gmao_output_topo.x -i ${arr[0]} --im $n --jm$n + cd .. +done diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/utils_topo/geompack.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/utils_topo/geompack.F90 new file mode 100644 index 000000000..7166617a8 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/utils_topo/geompack.F90 @@ -0,0 +1,4089 @@ +subroutine alpha_measure ( n, z, triangle_order, triangle_num, triangle_node, & + alpha_min, alpha_ave, alpha_area ) + +!*****************************************************************************80 +! +!! ALPHA_MEASURE determines the triangulated pointset quality measure ALPHA. +! +! Discusion: +! +! The ALPHA measure evaluates the uniformity of the shapes of the triangles +! defined by a triangulated pointset. +! +! We compute the minimum angle among all the triangles in the triangulated +! dataset and divide by the maximum possible value (which, in degrees, +! is 60). The best possible value is 1, and the worst 0. A good +! triangulation should have an ALPHA score close to 1. +! +! The code has been modified to 'allow' 6-node triangulations. +! However, no effort is made to actually process the midside nodes. +! Only information from the vertices is used. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 21 June 2009 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the number of points. +! +! Input, real ( kind = 8 ) Z(2,N), the points. +! +! Input, integer ( kind = 4 ) TRIANGLE_ORDER, the order of the triangles. +! +! Input, integer ( kind = 4 ) TRIANGLE_NUM, the number of triangles. +! +! Input, integer ( kind = 4 ) TRIANGLE_NODE(TRIANGLE_ORDER,TRIANGLE_NUM), +! the triangulation. +! +! Output, real ( kind = 8 ) ALPHA_MIN, the minimum value of ALPHA over all +! triangles. +! +! Output, real ( kind = 8 ) ALPHA_AVE, the value of ALPHA averaged over +! all triangles. +! +! Output, real ( kind = 8 ) ALPHA_AREA, the value of ALPHA averaged over +! all triangles and weighted by area. +! + implicit none + + integer ( kind = 4 ) n + integer ( kind = 4 ) triangle_num + integer ( kind = 4 ) triangle_order + + real ( kind = 8 ) a_angle + integer ( kind = 4 ) a_index + real ( kind = 8 ) a_x + real ( kind = 8 ) a_y + real ( kind = 8 ) ab_len + real ( kind = 8 ) alpha + real ( kind = 8 ) alpha_area + real ( kind = 8 ) alpha_ave + real ( kind = 8 ) alpha_min + real ( kind = 8 ) arc_cosine + real ( kind = 8 ) area + real ( kind = 8 ) area_total + real ( kind = 8 ) b_angle + integer ( kind = 4 ) b_index + real ( kind = 8 ) b_x + real ( kind = 8 ) b_y + real ( kind = 8 ) bc_len + real ( kind = 8 ) c_angle + integer ( kind = 4 ) c_index + real ( kind = 8 ) c_x + real ( kind = 8 ) c_y + real ( kind = 8 ) ca_len + real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 + integer ( kind = 4 ) triangle + integer ( kind = 4 ) triangle_node(triangle_order,triangle_num) + real ( kind = 8 ) z(2,n) + + alpha_min = huge ( alpha ) + alpha_ave = 0.0D+00 + alpha_area = 0.0D+00 + area_total = 0.0D+00 + + do triangle = 1, triangle_num + + a_index = triangle_node(1,triangle) + b_index = triangle_node(2,triangle) + c_index = triangle_node(3,triangle) + + a_x = z(1,a_index) + a_y = z(2,a_index) + b_x = z(1,b_index) + b_y = z(2,b_index) + c_x = z(1,c_index) + c_y = z(2,c_index) + + area = 0.5D+00 * abs ( a_x * ( b_y - c_y ) & + + b_x * ( c_y - a_y ) & + + c_x * ( a_y - b_y ) ) + + ab_len = sqrt ( ( a_x - b_x )**2 + ( a_y - b_y )**2 ) + bc_len = sqrt ( ( b_x - c_x )**2 + ( b_y - c_y )**2 ) + ca_len = sqrt ( ( c_x - a_x )**2 + ( c_y - a_y )**2 ) +! +! Take care of a ridiculous special case. +! + if ( ab_len == 0.0D+00 .and. & + bc_len == 0.0D+00 .and. & + ca_len == 0.0D+00 ) then + + a_angle = 2.0D+00 * pi / 3.0D+00 + b_angle = 2.0D+00 * pi / 3.0D+00 + c_angle = 2.0D+00 * pi / 3.0D+00 + + else + + if ( ca_len == 0.0D+00 .or. ab_len == 0.0D+00 ) then + a_angle = pi + else + a_angle = arc_cosine ( ( ca_len**2 + ab_len**2 - bc_len**2 ) & + / ( 2.0D+00 * ca_len * ab_len ) ) + end if + + if ( ab_len == 0.0D+00 .or. bc_len == 0.0D+00 ) then + b_angle = pi + else + b_angle = arc_cosine ( ( ab_len**2 + bc_len**2 - ca_len**2 ) & + / ( 2.0D+00 * ab_len * bc_len ) ) + end if + + if ( bc_len == 0.0D+00 .or. ca_len == 0.0D+00 ) then + c_angle = pi + else + c_angle = arc_cosine ( ( bc_len**2 + ca_len**2 - ab_len**2 ) & + / ( 2.0D+00 * bc_len * ca_len ) ) + end if + + end if + + alpha_min = min ( alpha_min, a_angle ) + alpha_min = min ( alpha_min, b_angle ) + alpha_min = min ( alpha_min, c_angle ) + + alpha_ave = alpha_ave + alpha_min + + alpha_area = alpha_area + area * alpha_min + + area_total = area_total + area + + end do + + alpha_ave = alpha_ave / real ( triangle_num, kind = 8 ) + alpha_area = alpha_area / area_total +! +! Normalize angles from [0,pi/3] degrees into qualities in [0,1]. +! + alpha_min = alpha_min * 3.0D+00 / pi + alpha_ave = alpha_ave * 3.0D+00 / pi + alpha_area = alpha_area * 3.0D+00 / pi + + return +end +function angle_rad_2d ( p1, p2, p3 ) + +!*****************************************************************************80 +! +!! ANGLE_RAD_2D returns the angle swept out between two rays in 2D. +! +! Discussion: +! +! Except for the zero angle case, it should be true that +! +! ANGLE_RAD_2D ( P1, P2, P3 ) + ANGLE_RAD_2D ( P3, P2, P1 ) = 2 * PI +! +! P1 +! / +! / +! / +! / +! P2--------->P3 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 15 January 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) P1(2), P2(2), P3(2), define the rays +! P1 - P2 and P3 - P2 which define the angle. +! +! Output, real ( kind = 8 ) ANGLE_RAD_2D, the angle swept out by the rays, +! in radians. 0 <= ANGLE_RAD_2D < 2 * PI. If either ray has zero +! length, then ANGLE_RAD_2D is set to 0. +! + implicit none + + integer ( kind = 4 ), parameter :: dim_num = 2 + + real ( kind = 8 ) angle_rad_2d + real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 + real ( kind = 8 ) p(dim_num) + real ( kind = 8 ) p1(dim_num) + real ( kind = 8 ) p2(dim_num) + real ( kind = 8 ) p3(dim_num) + + p(1) = ( p3(1) - p2(1) ) * ( p1(1) - p2(1) ) & + + ( p3(2) - p2(2) ) * ( p1(2) - p2(2) ) + + + p(2) = ( p3(1) - p2(1) ) * ( p1(2) - p2(2) ) & + - ( p3(2) - p2(2) ) * ( p1(1) - p2(1) ) + + if ( p(1) == 0.0D+00 .and. p(2) == 0.0D+00 ) then + angle_rad_2d = 0.0D+00 + return + end if + + angle_rad_2d = atan2 ( p(2), p(1) ) + + if ( angle_rad_2d < 0.0D+00 ) then + angle_rad_2d = angle_rad_2d + 2.0D+00 * pi + end if + + return +end +function arc_cosine ( c ) + +!*****************************************************************************80 +! +!! ARC_COSINE computes the arc cosine function, with argument truncation. +! +! Discussion: +! +! If you call your system ACOS routine with an input argument that is +! even slightly outside the range [-1.0, 1.0 ], you may get an unpleasant +! surprise (I did). +! +! This routine simply truncates arguments outside the range. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 02 December 2000 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) C, the argument. +! +! Output, real ( kind = 8 ) ARC_COSINE, an angle whose cosine is C. +! + implicit none + + real ( kind = 8 ) arc_cosine + real ( kind = 8 ) c + real ( kind = 8 ) c2 + + c2 = c + c2 = max ( c2, -1.0D+00 ) + c2 = min ( c2, +1.0D+00 ) + + arc_cosine = acos ( c2 ) + + return +end +function diaedg ( x0, y0, x1, y1, x2, y2, x3, y3 ) + +!*****************************************************************************80 +! +!! DIAEDG chooses a diagonal edge. +! +! Discussion: +! +! The routine determines whether 0--2 or 1--3 is the diagonal edge +! that should be chosen, based on the circumcircle criterion, where +! (X0,Y0), (X1,Y1), (X2,Y2), (X3,Y3) are the vertices of a simple +! quadrilateral in counterclockwise order. +! +! Modified: +! +! 19 February 2001 +! +! Author: +! +! Original FORTRAN77 version by Barry Joe. +! FORTRAN90 version by John Burkardt. +! +! Reference: +! +! Barry Joe, +! GEOMPACK - a software package for the generation of meshes +! using geometric algorithms, +! Advances in Engineering Software, +! Volume 13, pages 325-331, 1991. +! +! Parameters: +! +! Input, real ( kind = 8 ) X0, Y0, X1, Y1, X2, Y2, X3, Y3, the +! coordinates of the vertices of a quadrilateral, given in +! counter clockwise order. +! +! Output, integer ( kind = 4 ) DIAEDG, chooses a diagonal: +! +1, if diagonal edge 02 is chosen; +! -1, if diagonal edge 13 is chosen; +! 0, if the four vertices are cocircular. +! + implicit none + + real ( kind = 8 ) ca + real ( kind = 8 ) cb + integer ( kind = 4 ) diaedg + real ( kind = 8 ) dx10 + real ( kind = 8 ) dx12 + real ( kind = 8 ) dx30 + real ( kind = 8 ) dx32 + real ( kind = 8 ) dy10 + real ( kind = 8 ) dy12 + real ( kind = 8 ) dy30 + real ( kind = 8 ) dy32 + real ( kind = 8 ) s + real ( kind = 8 ) tol + real ( kind = 8 ) tola + real ( kind = 8 ) tolb + real ( kind = 8 ) x0 + real ( kind = 8 ) x1 + real ( kind = 8 ) x2 + real ( kind = 8 ) x3 + real ( kind = 8 ) y0 + real ( kind = 8 ) y1 + real ( kind = 8 ) y2 + real ( kind = 8 ) y3 + + tol = 100.0D+00 * epsilon ( tol ) + + dx10 = x1 - x0 + dy10 = y1 - y0 + dx12 = x1 - x2 + dy12 = y1 - y2 + dx30 = x3 - x0 + dy30 = y3 - y0 + dx32 = x3 - x2 + dy32 = y3 - y2 + + tola = tol * max ( abs ( dx10 ), abs ( dy10 ), abs ( dx30 ), abs ( dy30 ) ) + tolb = tol * max ( abs ( dx12 ), abs ( dy12 ), abs ( dx32 ), abs ( dy32 ) ) + + ca = dx10 * dx30 + dy10 * dy30 + cb = dx12 * dx32 + dy12 * dy32 + + if ( tola < ca .and. tolb < cb ) then + + diaedg = -1 + + else if ( ca < -tola .and. cb < -tolb ) then + + diaedg = 1 + + else + + tola = max ( tola, tolb ) + s = ( dx10 * dy30 - dx30 * dy10 ) * cb + ( dx32 * dy12 - dx12 * dy32 ) * ca + + if ( tola < s ) then + diaedg = -1 + else if ( s < -tola ) then + diaedg = 1 + else + diaedg = 0 + end if + + end if + + return +end +subroutine dtris2 ( node_num, node_xy, triangle_num, triangle_node, & + triangle_neighbor ) + +!*****************************************************************************80 +! +!! DTRIS2 constructs a Delaunay triangulation of 2D vertices. +! +! Discussion: +! +! The routine constructs the Delaunay triangulation of a set of 2D vertices +! using an incremental approach and diagonal edge swaps. Vertices are +! first sorted in lexicographically increasing (X,Y) order, and +! then are inserted one at a time from outside the convex hull. +! +! Modified: +! +! 25 August 2001 +! +! Author: +! +! Original FORTRAN77 version by Barry Joe. +! FORTRAN90 version by John Burkardt. +! +! Reference: +! +! Barry Joe, +! GEOMPACK - a software package for the generation of meshes +! using geometric algorithms, +! Advances in Engineering Software, +! Volume 13, pages 325-331, 1991. +! +! Parameters: +! +! Input, integer ( kind = 4 ) NODE_NUM, the number of vertices. +! +! Input/output, real ( kind = 8 ) NODE_XY(2,NODE_NUM), the coordinates +! of the vertices. On output, the vertices have been sorted into +! dictionary order. +! +! Output, integer ( kind = 4 ) TRIANGLE_NUM, the number of triangles in +! the triangulation; TRIANGLE_NUM is equal to 2*NODE_NUM - NB - 2, where +! NB is the number of boundary vertices. +! +! Output, integer ( kind = 4 ) TRIANGLE_NODE(3,TRIANGLE_NUM), the nodes +! that make up each triangle. The elements are indices of P. The vertices +! of the triangles are in counter clockwise order. +! +! Output, integer ( kind = 4 ) TRIANGLE_NEIGHBOR(3,TRIANGLE_NUM), +! the triangle neighbor list. Positive elements are indices of TIL; +! negative elements are used for links of a counter clockwise linked list +! of boundary edges; LINK = -(3*I + J-1) where I, J = triangle, edge index; +! TRIANGLE_NEIGHBOR(J,I) refers to the neighbor along edge from vertex J +! to J+1 (mod 3). +! + implicit none + + integer ( kind = 4 ) node_num + + real ( kind = 8 ) cmax + integer ( kind = 4 ) e + integer ( kind = 4 ) i + integer ( kind = 4 ) ierr + integer ( kind = 4 ) indx(node_num) + integer ( kind = 4 ) j + integer ( kind = 4 ) k + integer ( kind = 4 ) l + integer ( kind = 4 ) ledg + integer ( kind = 4 ) lr + integer ( kind = 4 ) lrline + integer ( kind = 4 ) ltri + integer ( kind = 4 ) m + integer ( kind = 4 ) m1 + integer ( kind = 4 ) m2 + integer ( kind = 4 ) n + real ( kind = 8 ) node_xy(2,node_num) + integer ( kind = 4 ) redg + integer ( kind = 4 ) rtri + integer ( kind = 4 ) stack(node_num) + integer ( kind = 4 ) t + real ( kind = 8 ) tol + integer ( kind = 4 ) top + integer ( kind = 4 ) triangle_neighbor(3,node_num*2) + integer ( kind = 4 ) triangle_num + integer ( kind = 4 ) triangle_node(3,node_num*2) + + tol = 100.0D+00 * epsilon ( tol ) + + ierr = 0 +! +! Sort the vertices by increasing (x,y). +! + call r82vec_sort_heap_index_a ( node_num, node_xy, indx ) + + call r82vec_permute ( node_num, node_xy, indx ) +! +! Make sure that the data points are "reasonably" distinct. +! + m1 = 1 + + do i = 2, node_num + + m = m1 + m1 = i + + k = 0 + + do j = 1, 2 + + cmax = max ( abs ( node_xy(j,m) ), abs ( node_xy(j,m1) ) ) + + if ( tol * ( cmax + 1.0D+00 ) & + < abs ( node_xy(j,m) - node_xy(j,m1) ) ) then + k = j + exit + end if + + end do + + if ( k == 0 ) then + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) 'DTRIS2 - Fatal error!' + write ( *, '(a,i8)' ) ' Fails for point number I = ', i + write ( *, '(a,i8)' ) ' M = ', m + write ( *, '(a,i8)' ) ' M1 = ', m1 + write ( *, '(a,2g14.6)' ) ' X,Y(M) = ', node_xy(1:2,m) + write ( *, '(a,2g14.6)' ) ' X,Y(M1) = ', node_xy(1:2,m1) + ierr = 224 + return + end if + + end do +! +! Starting from points M1 and M2, search for a third point M that +! makes a "healthy" triangle (M1,M2,M) +! + m1 = 1 + m2 = 2 + j = 3 + + do + + if ( node_num < j ) then + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) 'DTRIS2 - Fatal error!' + ierr = 225 + return + end if + + m = j + + lr = lrline ( node_xy(1,m), node_xy(2,m), node_xy(1,m1), & + node_xy(2,m1), node_xy(1,m2), node_xy(2,m2), 0.0D+00 ) + + if ( lr /= 0 ) then + exit + end if + + j = j + 1 + + end do +! +! Set up the triangle information for (M1,M2,M), and for any other +! triangles you created because points were collinear with M1, M2. +! + triangle_num = j - 2 + + if ( lr == -1 ) then + + triangle_node(1,1) = m1 + triangle_node(2,1) = m2 + triangle_node(3,1) = m + triangle_neighbor(3,1) = -3 + + do i = 2, triangle_num + + m1 = m2 + m2 = i+1 + triangle_node(1,i) = m1 + triangle_node(2,i) = m2 + triangle_node(3,i) = m + triangle_neighbor(1,i-1) = -3 * i + triangle_neighbor(2,i-1) = i + triangle_neighbor(3,i) = i - 1 + + end do + + triangle_neighbor(1,triangle_num) = -3 * triangle_num - 1 + triangle_neighbor(2,triangle_num) = -5 + ledg = 2 + ltri = triangle_num + + else + + triangle_node(1,1) = m2 + triangle_node(2,1) = m1 + triangle_node(3,1) = m + triangle_neighbor(1,1) = -4 + + do i = 2, triangle_num + m1 = m2 + m2 = i+1 + triangle_node(1,i) = m2 + triangle_node(2,i) = m1 + triangle_node(3,i) = m + triangle_neighbor(3,i-1) = i + triangle_neighbor(1,i) = -3 * i - 3 + triangle_neighbor(2,i) = i - 1 + end do + + triangle_neighbor(3,triangle_num) = -3 * triangle_num + triangle_neighbor(2,1) = -3 * triangle_num - 2 + ledg = 2 + ltri = 1 + + end if +! +! Insert the vertices one at a time from outside the convex hull, +! determine visible boundary edges, and apply diagonal edge swaps until +! Delaunay triangulation of vertices (so far) is obtained. +! + top = 0 + + do i = j+1, node_num + + m = i + m1 = triangle_node(ledg,ltri) + + if ( ledg <= 2 ) then + m2 = triangle_node(ledg+1,ltri) + else + m2 = triangle_node(1,ltri) + end if + + lr = lrline ( node_xy(1,m), node_xy(2,m), node_xy(1,m1), & + node_xy(2,m1), node_xy(1,m2), node_xy(2,m2), 0.0D+00 ) + + if ( 0 < lr ) then + rtri = ltri + redg = ledg + ltri = 0 + else + l = -triangle_neighbor(ledg,ltri) + rtri = l / 3 + redg = mod(l,3) + 1 + end if + + call vbedg ( node_xy(1,m), node_xy(2,m), node_num, node_xy, triangle_num, & + triangle_node, triangle_neighbor, ltri, ledg, rtri, redg ) + + n = triangle_num + 1 + l = -triangle_neighbor(ledg,ltri) + + do + + t = l / 3 + e = mod ( l, 3 ) + 1 + l = -triangle_neighbor(e,t) + m2 = triangle_node(e,t) + + if ( e <= 2 ) then + m1 = triangle_node(e+1,t) + else + m1 = triangle_node(1,t) + end if + + triangle_num = triangle_num + 1 + triangle_neighbor(e,t) = triangle_num + triangle_node(1,triangle_num) = m1 + triangle_node(2,triangle_num) = m2 + triangle_node(3,triangle_num) = m + triangle_neighbor(1,triangle_num) = t + triangle_neighbor(2,triangle_num) = triangle_num - 1 + triangle_neighbor(3,triangle_num) = triangle_num + 1 + top = top + 1 + + if ( node_num < top ) then + ierr = 8 + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) 'DTRIS2 - Fatal error!' + write ( *, '(a)' ) ' Stack overflow.' + return + end if + + stack(top) = triangle_num + + if ( t == rtri .and. e == redg ) then + exit + end if + + end do + + triangle_neighbor(ledg,ltri) = -3 * n - 1 + triangle_neighbor(2,n) = -3 * triangle_num - 2 + triangle_neighbor(3,triangle_num) = -l + ltri = n + ledg = 2 + + call swapec ( m, top, ltri, ledg, node_num, node_xy, triangle_num, & + triangle_node, triangle_neighbor, stack, ierr ) + + if ( ierr /= 0 ) then + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) 'DTRIS2 - Fatal error!' + write ( *, '(a)' ) ' Error return from SWAPEC.' + return + end if + + end do +! +! Now account for the sorting that we did. +! + do i = 1, 3 + do j = 1, triangle_num + triangle_node(i,j) = indx ( triangle_node(i,j) ) + end do + end do + + call perm_inv ( node_num, indx ) + + call r82vec_permute ( node_num, node_xy, indx ) + + return +end +subroutine get_unit ( iunit ) + +!*****************************************************************************80 +! +!! GET_UNIT returns a free FORTRAN unit number. +! +! Discussion: +! +! A "free" FORTRAN unit number is avalue between 1 and 99 which +! is not currently associated with an I/O device. A free FORTRAN unit +! number is needed in order to open a file with the OPEN command. +! +! If IUNIT = 0, then no free FORTRAN unit could be found, although +! all 99 units were checked (except for units 5, 6 and 9, which +! are commonly reserved for console I/O). +! +! Otherwise, IUNIT is a value between 1 and 99, representing a +! free FORTRAN unit. Note that GET_UNIT assumes that units 5 and 6 +! are special, and will never return those values. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 18 September 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Output, integer ( kind = 4 ) IUNIT, the free unit number. +! + implicit none + + integer ( kind = 4 ) i + integer ( kind = 4 ) ios + integer ( kind = 4 ) iunit + logical lopen + + iunit = 0 + + do i = 1, 99 + + if ( i /= 5 .and. i /= 6 .and. i /= 9 ) then + + inquire ( unit = i, opened = lopen, iostat = ios ) + + if ( ios == 0 ) then + if ( .not. lopen ) then + iunit = i + return + end if + end if + + end if + + end do + + return +end +function i4_modp ( i, j ) + +!*****************************************************************************80 +! +!! I4_MODP returns the nonnegative remainder of integer ( kind = 4 ) division. +! +! Discussion: +! +! The MOD function computes a result with the same sign as the +! quantity being divided. Thus, suppose you had an angle A, +! and you wanted to ensure that it was between 0 and 360. +! Then mod(A,360) would do, if A was positive, but if A +! was negative, your result would be between -360 and 0. +! +! On the other hand, I4_MODP(A,360) is between 0 and 360, always. +! +! If +! NREM = I4_MODP ( I, J ) +! NMULT = ( I - NREM ) / J +! then +! I = J * NMULT + NREM +! where NREM is always nonnegative. +! +! Example: +! +! I J MOD I4_MODP Factorization +! +! 107 50 7 7 107 = 2 * 50 + 7 +! 107 -50 7 7 107 = -2 * -50 + 7 +! -107 50 -7 43 -107 = -3 * 50 + 43 +! -107 -50 -7 43 -107 = 3 * -50 + 43 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 02 March 1999 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) I, the number to be divided. +! +! Input, integer ( kind = 4 ) J, the number that divides I. +! +! Output, integer ( kind = 4 ) I4_MODP, the nonnegative remainder +! when I is divided by J. +! + implicit none + + integer ( kind = 4 ) i + integer ( kind = 4 ) i4_modp + integer ( kind = 4 ) j + + if ( j == 0 ) then + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) 'I4_MODP - Fatal error!' + write ( *, '(a,i8)' ) ' I4_MODP ( I, J ) called with J = ', j + stop + end if + + i4_modp = mod ( i, j ) + + if ( i4_modp < 0 ) then + i4_modp = i4_modp + abs ( j ) + end if + + return +end +subroutine i4_swap ( i, j ) + +!*****************************************************************************80 +! +!! I4_SWAP swaps two I4's. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 30 November 1998 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input/output, integer ( kind = 4 ) I, J. On output, the values of I and +! J have been interchanged. +! + implicit none + + integer ( kind = 4 ) i + integer ( kind = 4 ) j + integer ( kind = 4 ) k + + k = i + i = j + j = k + + return +end +function i4_wrap ( ival, ilo, ihi ) + +!*****************************************************************************80 +! +!! I4_WRAP forces an I4 to lie between given limits by wrapping. +! +! Example: +! +! ILO = 4, IHI = 8 +! +! I I4_WRAP +! +! -2 8 +! -1 4 +! 0 5 +! 1 6 +! 2 7 +! 3 8 +! 4 4 +! 5 5 +! 6 6 +! 7 7 +! 8 8 +! 9 4 +! 10 5 +! 11 6 +! 12 7 +! 13 8 +! 14 4 +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 19 August 2003 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) IVAL, a value. +! +! Input, integer ( kind = 4 ) ILO, IHI, the desired bounds for the value. +! +! Output, integer ( kind = 4 ) I4_WRAP, a "wrapped" version of the value. +! + implicit none + + integer ( kind = 4 ) i4_modp + integer ( kind = 4 ) i4_wrap + integer ( kind = 4 ) ihi + integer ( kind = 4 ) ilo + integer ( kind = 4 ) ival + integer ( kind = 4 ) jhi + integer ( kind = 4 ) jlo + integer ( kind = 4 ) wide + + jlo = min ( ilo, ihi ) + jhi = max ( ilo, ihi ) + + wide = jhi - jlo + 1 + + if ( wide == 1 ) then + i4_wrap = jlo + else + i4_wrap = jlo + i4_modp ( ival - jlo, wide ) + end if + + return +end +subroutine i4mat_transpose_print ( m, n, a, title ) + +!*****************************************************************************80 +! +!! I4MAT_TRANSPOSE_PRINT prints an I4MAT, transposed. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 09 February 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) M, N, the number of rows and columns. +! +! Input, integer ( kind = 4 ) A(M,N), an M by N matrix to be printed. +! +! Input, character ( len = * ) TITLE, an optional title. +! + implicit none + + integer ( kind = 4 ) m + integer ( kind = 4 ) n + + integer ( kind = 4 ) a(m,n) + character ( len = * ) title + + call i4mat_transpose_print_some ( m, n, a, 1, 1, m, n, title ) + + return +end +subroutine i4mat_transpose_print_some ( m, n, a, ilo, jlo, ihi, jhi, title ) + +!*****************************************************************************80 +! +!! I4MAT_TRANSPOSE_PRINT_SOME prints some of the transpose of an I4MAT. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 09 February 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) M, N, the number of rows and columns. +! +! Input, integer ( kind = 4 ) A(M,N), an M by N matrix to be printed. +! +! Input, integer ( kind = 4 ) ILO, JLO, the first row and column to print. +! +! Input, integer ( kind = 4 ) IHI, JHI, the last row and column to print. +! +! Input, character ( len = * ) TITLE, an optional title. +! + implicit none + + integer ( kind = 4 ), parameter :: incx = 10 + integer ( kind = 4 ) m + integer ( kind = 4 ) n + + integer ( kind = 4 ) a(m,n) + character ( len = 7 ) ctemp(incx) + integer ( kind = 4 ) i + integer ( kind = 4 ) i2 + integer ( kind = 4 ) i2hi + integer ( kind = 4 ) i2lo + integer ( kind = 4 ) ihi + integer ( kind = 4 ) ilo + integer ( kind = 4 ) inc + integer ( kind = 4 ) j + integer ( kind = 4 ) j2hi + integer ( kind = 4 ) j2lo + integer ( kind = 4 ) jhi + integer ( kind = 4 ) jlo + character ( len = * ) title + + if ( 0 < len_trim ( title ) ) then + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) trim ( title ) + end if + + do i2lo = max ( ilo, 1 ), min ( ihi, m ), incx + + i2hi = i2lo + incx - 1 + i2hi = min ( i2hi, m ) + i2hi = min ( i2hi, ihi ) + + inc = i2hi + 1 - i2lo + + write ( *, '(a)' ) ' ' + + do i = i2lo, i2hi + i2 = i + 1 - i2lo + write ( ctemp(i2), '(i7)') i + end do + + write ( *, '('' Row '',10a7)' ) ctemp(1:inc) + write ( *, '(a)' ) ' Col' + write ( *, '(a)' ) ' ' + + j2lo = max ( jlo, 1 ) + j2hi = min ( jhi, n ) + + do j = j2lo, j2hi + + do i2 = 1, inc + + i = i2lo - 1 + i2 + + write ( ctemp(i2), '(i7)' ) a(i,j) + + end do + + write ( *, '(i5,1x,10a7)' ) j, ( ctemp(i), i = 1, inc ) + + end do + + end do + + return +end +subroutine i4vec_heap_d ( n, a ) + +!*****************************************************************************80 +! +!! I4VEC_HEAP_D reorders an I4VEC into an descending heap. +! +! Discussion: +! +! A descending heap is an array A with the property that, for every index J, +! A(J) >= A(2*J) and A(J) >= A(2*J+1), (as long as the indices +! 2*J and 2*J+1 are legal). +! +! A(1) +! / \ +! A(2) A(3) +! / \ / \ +! A(4) A(5) A(6) A(7) +! / \ / \ +! A(8) A(9) A(10) A(11) +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 15 April 1999 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! A Nijenhuis and H Wilf, +! Combinatorial Algorithms, +! Academic Press, 1978, second edition, +! ISBN 0-12-519260-6. +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the size of the input array. +! +! Input/output, integer ( kind = 4 ) A(N). +! On input, an unsorted array. +! On output, the array has been reordered into a heap. +! + implicit none + + integer ( kind = 4 ) n + + integer ( kind = 4 ) a(n) + integer ( kind = 4 ) i + integer ( kind = 4 ) ifree + integer ( kind = 4 ) key + integer ( kind = 4 ) m +! +! Only nodes N/2 down to 1 can be "parent" nodes. +! + do i = n/2, 1, -1 +! +! Copy the value out of the parent node. +! Position IFREE is now "open". +! + key = a(i) + ifree = i + + do +! +! Positions 2*IFREE and 2*IFREE + 1 are the descendants of position +! IFREE. (One or both may not exist because they exceed N.) +! + m = 2 * ifree +! +! Does the first position exist? +! + if ( n < m ) then + exit + end if +! +! Does the second position exist? +! + if ( m + 1 <= n ) then +! +! If both positions exist, take the larger of the two values, +! and update M if necessary. +! + if ( a(m) < a(m+1) ) then + m = m + 1 + end if + + end if +! +! If the large descendant is larger than KEY, move it up, +! and update IFREE, the location of the free position, and +! consider the descendants of THIS position. +! + if ( a(m) <= key ) then + exit + end if + + a(ifree) = a(m) + ifree = m + + end do +! +! Once there is no more shifting to do, KEY moves into the free spot IFREE. +! + a(ifree) = key + + end do + + return +end +subroutine i4vec_sort_heap_a ( n, a ) + +!*****************************************************************************80 +! +!! I4VEC_SORT_HEAP_A ascending sorts an I4VEC using heap sort. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 15 April 1999 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! A Nijenhuis and H Wilf, +! Combinatorial Algorithms, +! Academic Press, 1978, second edition, +! ISBN 0-12-519260-6. +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the number of entries in the array. +! +! Input/output, integer ( kind = 4 ) A(N). +! On input, the array to be sorted; +! On output, the array has been sorted. +! + implicit none + + integer ( kind = 4 ) n + + integer ( kind = 4 ) a(n) + integer ( kind = 4 ) n1 + + if ( n <= 1 ) then + return + end if +! +! 1: Put A into descending heap form. +! + call i4vec_heap_d ( n, a ) +! +! 2: Sort A. +! +! The largest object in the heap is in A(1). +! Move it to position A(N). +! + call i4_swap ( a(1), a(n) ) +! +! Consider the diminished heap of size N1. +! + do n1 = n-1, 2, -1 +! +! Restore the heap structure of A(1) through A(N1). +! + call i4vec_heap_d ( n1, a ) +! +! Take the largest object from A(1) and move it to A(N1). +! + call i4_swap ( a(1), a(n1) ) + + end do + + return +end +subroutine i4vec_sorted_unique ( n, a, nuniq ) + +!*****************************************************************************80 +! +!! I4VEC_SORTED_UNIQUE finds the unique elements in a sorted I4VEC. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 09 July 2000 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the number of elements in A. +! +! Input/output, integer ( kind = 4 ) A(N). On input, the sorted +! integer ( kind = 4 ) array. On output, the unique elements in A. +! +! Output, integer ( kind = 4 ) NUNIQ, the number of unique elements in A. +! + implicit none + + integer ( kind = 4 ) n + + integer ( kind = 4 ) a(n) + integer ( kind = 4 ) itest + integer ( kind = 4 ) nuniq + + nuniq = 0 + + if ( n <= 0 ) then + return + end if + + nuniq = 1 + + do itest = 2, n + + if ( a(itest) /= a(nuniq) ) then + nuniq = nuniq + 1 + a(nuniq) = a(itest) + end if + + end do + + return +end +function lrline ( xu, yu, xv1, yv1, xv2, yv2, dv ) + +!*****************************************************************************80 +! +!! LRLINE determines if a point is left of, right or, or on a directed line. +! +! Discussion: +! +! The directed line is parallel to, and at a signed distance DV from +! a directed base line from (XV1,YV1) to (XV2,YV2). +! +! Modified: +! +! 14 July 2001 +! +! Author: +! +! Original FORTRAN77 version by Barry Joe. +! FORTRAN90 version by John Burkardt. +! +! Reference: +! +! Barry Joe, +! GEOMPACK - a software package for the generation of meshes +! using geometric algorithms, +! Advances in Engineering Software, +! Volume 13, pages 325-331, 1991. +! +! Parameters: +! +! Input, real ( kind = 8 ) XU, YU, the coordinates of the point whose +! position relative to the directed line is to be determined. +! +! Input, real ( kind = 8 ) XV1, YV1, XV2, YV2, the coordinates of two points +! that determine the directed base line. +! +! Input, real ( kind = 8 ) DV, the signed distance of the directed line +! from the directed base line through the points (XV1,YV1) and (XV2,YV2). +! DV is positive for a line to the left of the base line. +! +! Output, integer ( kind = 4 ) LRLINE, the result: +! +1, the point is to the right of the directed line; +! 0, the point is on the directed line; +! -1, the point is to the left of the directed line. +! + implicit none + + real ( kind = 8 ) dv + real ( kind = 8 ) dx + real ( kind = 8 ) dxu + real ( kind = 8 ) dy + real ( kind = 8 ) dyu + integer ( kind = 4 ) lrline + real ( kind = 8 ) t + real ( kind = 8 ) tol + real ( kind = 8 ) tolabs + real ( kind = 8 ) xu + real ( kind = 8 ) xv1 + real ( kind = 8 ) xv2 + real ( kind = 8 ) yu + real ( kind = 8 ) yv1 + real ( kind = 8 ) yv2 + + tol = 100.0D+00 * epsilon ( tol ) + + dx = xv2 - xv1 + dy = yv2 - yv1 + dxu = xu - xv1 + dyu = yu - yv1 + + tolabs = tol * max ( abs ( dx ), abs ( dy ), abs ( dxu ), & + abs ( dyu ), abs ( dv ) ) + + t = dy * dxu - dx * dyu + dv * sqrt ( dx * dx + dy * dy ) + + if ( tolabs < t ) then + lrline = 1 + else if ( -tolabs <= t ) then + lrline = 0 + else + lrline = -1 + end if + + return +end +subroutine perm_check ( n, p, ierror ) + +!*****************************************************************************80 +! +!! PERM_CHECK checks that a vector represents a permutation. +! +! Discussion: +! +! The routine verifies that each of the values from 1 +! to N occurs among the N entries of the permutation. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 01 February 2001 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the number of entries. +! +! Input, integer ( kind = 4 ) P(N), the array to check. +! +! Output, integer ( kind = 4 ) IERROR, error flag. +! 0, the array represents a permutation. +! nonzero, the array does not represent a permutation. The smallest +! missing value is equal to IERROR. +! + implicit none + + integer ( kind = 4 ) n + + integer ( kind = 4 ) ierror + integer ( kind = 4 ) ifind + integer ( kind = 4 ) iseek + integer ( kind = 4 ) p(n) + + ierror = 0 + + do iseek = 1, n + + ierror = iseek + + do ifind = 1, n + if ( p(ifind) == iseek ) then + ierror = 0 + exit + end if + end do + + if ( ierror /= 0 ) then + return + end if + + end do + + return +end +subroutine perm_inv ( n, p ) + +!*****************************************************************************80 +! +!! PERM_INV inverts a permutation "in place". +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 25 July 2000 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the number of objects being permuted. +! +! Input/output, integer ( kind = 4 ) P(N), the permutation, in standard +! index form. On output, P describes the inverse permutation +! + implicit none + + integer ( kind = 4 ) n + + integer ( kind = 4 ) i + integer ( kind = 4 ) i0 + integer ( kind = 4 ) i1 + integer ( kind = 4 ) i2 + integer ( kind = 4 ) ierror + integer ( kind = 4 ) is + integer ( kind = 4 ) p(n) + + if ( n <= 0 ) then + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) 'PERM_INV - Fatal error!' + write ( *, '(a,i8)' ) ' Input value of N = ', n + stop + end if + + call perm_check ( n, p, ierror ) + + if ( ierror /= 0 ) then + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) 'PERM_INV - Fatal error!' + write ( *, '(a)' ) ' The input array does not represent' + write ( *, '(a)' ) ' a proper permutation. In particular, the' + write ( *, '(a,i8)' ) ' array is missing the value ', ierror + stop + end if + + is = 1 + + do i = 1, n + + i1 = p(i) + + do while ( i < i1 ) + i2 = p(i1) + p(i1) = -i2 + i1 = i2 + end do + + is = -sign ( 1, p(i) ) + p(i) = sign ( p(i), is ) + + end do + + do i = 1, n + + i1 = -p(i) + + if ( 0 <= i1 ) then + + i0 = i + + do + + i2 = p(i1) + p(i1) = i0 + + if ( i2 < 0 ) then + exit + end if + + i0 = i1 + i1 = i2 + + end do + + end if + + end do + + return +end +subroutine points_delaunay_naive_2d ( node_num, node_xy, maxtri, & + triangle_num, triangle_node ) + +!*****************************************************************************80 +! +!! POINTS_DELAUNAY_NAIVE_2D is a naive Delaunay triangulation scheme. +! +! Discussion: +! +! This routine is only suitable as a demonstration code for small +! problems. Its running time is of order NODE_NUM**4. Much faster +! algorithms are available. +! +! Given a set of nodes in the plane, a triangulation is set of +! triples of distinct nodes, forming triangles, so that every +! point within the convex hull of the set of nodes is either +! one of the nodes, or lies on an edge of one or more triangles, +! or lies within exactly one triangle. +! +! A Delaunay triangulation is a triangulation with additional +! properties. +! +! NODE_NUM must be at least 3. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 08 November 2000 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Joseph O'Rourke, +! Computational Geometry, +! Cambridge University Press, +! Second Edition, 1998, page 187. +! +! Parameters: +! +! Input, integer ( kind = 4 ) NODE_NUM, the number of nodes. +! +! Input, real ( kind = 8 ) NODE_XY(2,NODE_NUM), the coordinates of the nodes. +! +! Input, integer ( kind = 4 ) MAXTRI, the maximum number of triangles. +! +! Output, integer ( kind = 4 ) TRIANGLE_NUM, the number of triangles in +! the triangulation. +! +! Output, integer ( kind = 4 ) TRIANGLE_NODE(3,MAXTRI), the indices of the +! triangle nodes. +! + implicit none + + integer ( kind = 4 ), parameter :: dim_num = 2 + integer ( kind = 4 ) maxtri + integer ( kind = 4 ) node_num + + logical flag + integer ( kind = 4 ) i + integer ( kind = 4 ) j + integer ( kind = 4 ) k + integer ( kind = 4 ) m + real ( kind = 8 ) node_xy(dim_num,node_num) + integer ( kind = 4 ) triangle_node(3,maxtri) + integer ( kind = 4 ) triangle_num + real ( kind = 8 ) xn + real ( kind = 8 ) yn + real ( kind = 8 ) z(node_num) + real ( kind = 8 ) zn + + triangle_num = 0 + + if ( node_num < 3 ) then + return + end if +! +! Compute Z = X*X + Y*Y. +! + z(1:node_num) = node_xy(1,1:node_num)**2 + node_xy(2,1:node_num)**2 +! +! For each triple (I,J,K): +! + do i = 1, node_num - 2 + do j = i+1, node_num + do k = i+1, node_num + + if ( j /= k ) then + + xn = ( node_xy(2,j) - node_xy(2,i) ) * ( z(k) - z(i) ) & + - ( node_xy(2,k) - node_xy(2,i) ) * ( z(j) - z(i) ) + + yn = ( node_xy(1,k) - node_xy(1,i) ) * ( z(j) - z(i) ) & + - ( node_xy(1,j) - node_xy(1,i) ) * ( z(k) - z(i) ) + + zn = ( node_xy(1,j) - node_xy(1,i) ) & + * ( node_xy(2,k) - node_xy(2,i) ) & + - ( node_xy(1,k) - node_xy(1,i) ) & + * ( node_xy(2,j) - node_xy(2,i) ) + + flag = ( zn < 0.0D+00 ) + + if ( flag ) then + do m = 1, node_num + flag = flag .and. & + ( ( node_xy(1,m) - node_xy(1,i) ) * xn & + + ( node_xy(2,m) - node_xy(2,i) ) * yn & + + ( z(m) - z(i) ) * zn <= 0.0D+00 ) + end do + end if + + if ( flag ) then + if ( triangle_num < maxtri ) then + triangle_num = triangle_num + 1 + triangle_node(1:3,triangle_num) = (/ i, j, k /) + end if + end if + + end if + + end do + end do + end do + + return +end +subroutine points_hull_2d ( node_num, node_xy, hull_num, hull ) + +!*****************************************************************************80 +! +!! POINTS_HULL_2D computes the convex hull of 2D points. +! +! Discussion: +! +! The work involved is N*log(H), where N is the number of points, and H is +! the number of points that are on the hull. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 12 June 2006 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) NODE_NUM, the number of nodes. +! +! Input, real ( kind = 8 ) NODE_XY(2,NODE_NUM), the coordinates of the nodes. +! +! Output, integer ( kind = 4 ) HULL_NUM, the number of nodes that lie on +! the convex hull. +! +! Output, integer ( kind = 4 ) HULL(NODE_NUM). Entries 1 through HULL_NUM +! contain the indices of the nodes that form the convex hull, in order. +! + implicit none + + integer ( kind = 4 ) node_num + + real ( kind = 8 ) angle + real ( kind = 8 ) angle_max + real ( kind = 8 ) angle_rad_2d + real ( kind = 8 ) di + real ( kind = 8 ) dr + integer ( kind = 4 ) first + integer ( kind = 4 ) hull(node_num) + integer ( kind = 4 ) hull_num + integer ( kind = 4 ) i + real ( kind = 8 ) node_xy(2,node_num) + real ( kind = 8 ) p_xy(2) + integer ( kind = 4 ) q + real ( kind = 8 ) q_xy(2) + integer ( kind = 4 ) r + real ( kind = 8 ) r_xy(2) + + if ( node_num < 1 ) then + hull_num = 0 + return + end if +! +! If NODE_NUM = 1, the hull is the point. +! + if ( node_num == 1 ) then + hull_num = 1 + hull(1) = 1 + return + end if +! +! If NODE_NUM = 2, then the convex hull is either the two distinct points, +! or possibly a single (repeated) point. +! + if ( node_num == 2 ) then + + if ( node_xy(1,1) /= node_xy(1,2) .or. node_xy(2,1) /= node_xy(2,2) ) then + hull_num = 2 + hull(1) = 1 + hull(2) = 2 + else + hull_num = 1 + hull(1) = 1 + end if + + return + + end if +! +! Find the leftmost point and call it "Q". +! In case of ties, take the bottom-most. +! + q = 1 + do i = 2, node_num + if ( node_xy(1,i) < node_xy(1,q) .or. & + ( node_xy(1,i) == node_xy(1,q) .and. node_xy(2,i) < node_xy(2,q) ) ) then + q = i + end if + end do + + q_xy(1:2) = node_xy(1:2,q) +! +! Remember the starting point, so we know when to stop! +! + first = q + hull_num = 1 + hull(1) = q +! +! For the first point, make a dummy previous point, 1 unit south, +! and call it "P". +! + p_xy(1) = q_xy(1) + p_xy(2) = q_xy(2) - 1.0D+00 +! +! Now, having old point P, and current point Q, find the new point R +! so the angle PQR is maximal. +! +! Watch out for the possibility that the two nodes are identical. +! + do + + r = 0 + angle_max = 0.0D+00 + + do i = 1, node_num + + if ( i /= q .and. & + ( node_xy(1,i) /= q_xy(1) .or. node_xy(2,i) /= q_xy(2) ) ) then + + angle = angle_rad_2d ( p_xy, q_xy, node_xy(1:2,i) ) + + if ( r == 0 .or. angle_max < angle ) then + + r = i + r_xy(1:2) = node_xy(1:2,r) + angle_max = angle +! +! In case of ties, choose the nearer point. +! + else if ( r /= 0 .and. angle == angle_max ) then + + di = ( node_xy(1,i) - q_xy(1) )**2 + ( node_xy(2,i) - q_xy(2) )**2 + dr = ( r_xy(1) - q_xy(1) )**2 + ( r_xy(2) - q_xy(2) )**2 + + if ( di < dr ) then + r = i + r_xy(1:2) = node_xy(1:2,r) + angle_max = angle + end if + + end if + + end if + + end do +! +! We are done when we have returned to the first point on the convex hull. +! + if ( r == first ) then + exit + end if + + hull_num = hull_num + 1 + + if ( node_num < hull_num ) then + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) 'POINTS_HULL_2D - Fatal error!' + write ( *, '(a)' ) ' The algorithm has failed.' + stop + end if +! +! Add point R to convex hull. +! + hull(hull_num) = r +! +! Set P := Q, Q := R, and prepare to search for next point R. +! + q = r + + p_xy(1:2) = q_xy(1:2) + q_xy(1:2) = r_xy(1:2) + + end do + + return +end +subroutine quad_convex_random ( seed, xy ) + +!*****************************************************************************80 +! +!! QUAD_CONVEX_RANDOM returns a random convex quadrilateral. +! +! Description: +! +! The quadrilateral is constrained in that the vertices must all lie +! with the unit square. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 26 June 2009 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input/output, integer ( kind = 4 ) SEED, a seed for the random number +! generator. +! +! Output, real ( kind = 8 ) XY(2,NODE_NUM), the coordinates of the +! nodes of the quadrilateral, given in counterclockwise order. +! + implicit none + + integer ( kind = 4 ), parameter :: node_num = 4 + + integer ( kind = 4 ) hull(node_num) + integer ( kind = 4 ) hull_num + integer ( kind = 4 ) j + integer ( kind = 4 ) seed + real ( kind = 8 ) xy(2,node_num) + real ( kind = 8 ) xy_random(2,node_num) + + do +! +! Generate 4 random points. +! + call r8mat_uniform_01 ( 2, node_num, seed, xy_random ) +! +! Determine the convex hull. +! + call points_hull_2d ( node_num, xy_random, hull_num, hull ) +! +! If HULL_NUM < NODE_NUM, then our convex hull is a triangle. +! Try again. +! + if ( hull_num == node_num ) then + exit + end if + + end do +! +! Make an ordered copy of the random points. +! + do j = 1, node_num + xy(1:2,j) = xy_random(1:2,hull(j)) + end do + + return +end +subroutine r82vec_part_quick_a ( n, a, l, r ) + +!*****************************************************************************80 +! +!! R82VEC_PART_QUICK_A reorders an R82VEC as part of a quick sort. +! +! Discussion: +! +! The routine reorders the entries of A. Using A(1:2,1) as a +! key, all entries of A that are less than or equal to the key will +! precede the key, which precedes all entries that are greater than the key. +! +! Example: +! +! Input: +! +! N = 8 +! +! A = ( (2,4), (8,8), (6,2), (0,2), (10,6), (10,0), (0,6), (4,8) ) +! +! Output: +! +! L = 2, R = 4 +! +! A = ( (0,2), (0,6), (2,4), (8,8), (6,2), (10,6), (10,0), (4,8) ) +! ----------- ---------------------------------- +! LEFT KEY RIGHT +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 08 December 2004 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the number of entries of A. +! +! Input/output, real ( kind = 8 ) A(2,N). On input, the array to be checked. +! On output, A has been reordered as described above. +! +! Output, integer ( kind = 4 ) L, R, the indices of A that define +! the three segments. +! Let KEY = the input value of A(1:2,1). Then +! I <= L A(1:2,I) < KEY; +! L < I < R A(1:2,I) = KEY; +! R <= I KEY < A(1:2,I). +! + implicit none + + integer ( kind = 4 ) n + integer ( kind = 4 ), parameter :: dim_num = 2 + + real ( kind = 8 ) a(dim_num,n) + integer ( kind = 4 ) i + real ( kind = 8 ) key(dim_num) + integer ( kind = 4 ) l + integer ( kind = 4 ) m + integer ( kind = 4 ) r + logical r8vec_eq + logical r8vec_gt + logical r8vec_lt + + if ( n < 1 ) then + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) 'R82VEC_PART_QUICK_A - Fatal error!' + write ( *, '(a)' ) ' N < 1.' + stop + else if ( n == 1 ) then + l = 0 + r = 2 + return + end if + + key(1:dim_num) = a(1:dim_num,1) + m = 1 +! +! The elements of unknown size have indices between L+1 and R-1. +! + l = 1 + r = n + 1 + + do i = 2, n + + if ( r8vec_gt ( dim_num, a(1:dim_num,l+1), key(1:dim_num) ) ) then + r = r - 1 + call r8vec_swap ( dim_num, a(1:dim_num,r), a(1:dim_num,l+1) ) + else if ( r8vec_eq ( dim_num, a(1:dim_num,l+1), key(1:dim_num) ) ) then + m = m + 1 + call r8vec_swap ( dim_num, a(1:dim_num,m), a(1:dim_num,l+1) ) + l = l + 1 + else if ( r8vec_lt ( dim_num, a(1:dim_num,l+1), key(1:dim_num) ) ) then + l = l + 1 + end if + + end do +! +! Now shift small elements to the left, and KEY elements to center. +! + do i = 1, l - m + a(1:dim_num,i) = a(1:dim_num,i+m) + end do + + l = l - m + + do i = 1, dim_num + a(i,l+1:l+m) = key(i) + end do + + return +end +subroutine r82vec_permute ( n, a, p ) + +!*****************************************************************************80 +! +!! R82VEC_PERMUTE permutes an R82VEC in place. +! +! Discussion: +! +! This routine permutes an array of real "objects", but the same +! logic can be used to permute an array of objects of any arithmetic +! type, or an array of objects of any complexity. The only temporary +! storage required is enough to store a single object. The number +! of data movements made is N + the number of cycles of order 2 or more, +! which is never more than N + N/2. +! +! Example: +! +! Input: +! +! N = 5 +! P = ( 2, 4, 5, 1, 3 ) +! A = ( 1.0, 2.0, 3.0, 4.0, 5.0 ) +! (11.0, 22.0, 33.0, 44.0, 55.0 ) +! +! Output: +! +! A = ( 2.0, 4.0, 5.0, 1.0, 3.0 ) +! ( 22.0, 44.0, 55.0, 11.0, 33.0 ). +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 08 December 2004 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the number of objects. +! +! Input/output, real ( kind = 8 ) A(2,N), the array to be permuted. +! +! Input, integer ( kind = 4 ) P(N), the permutation. P(I) = J means +! that the I-th element of the output array should be the J-th +! element of the input array. P must be a legal permutation +! of the integer ( kind = 4 )s from 1 to N, otherwise the algorithm will +! fail catastrophically. +! + implicit none + + integer ( kind = 4 ) n + + real ( kind = 8 ) a(2,n) + real ( kind = 8 ) a_temp(2) + integer ( kind = 4 ) ierror + integer ( kind = 4 ) iget + integer ( kind = 4 ) iput + integer ( kind = 4 ) istart + integer ( kind = 4 ) p(n) + + call perm_check ( n, p, ierror ) + + if ( ierror /= 0 ) then + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) 'R82VEC_PERMUTE - Fatal error!' + write ( *, '(a)' ) ' The input array does not represent' + write ( *, '(a)' ) ' a proper permutation. In particular, the' + write ( *, '(a,i8)' ) ' array is missing the value ', ierror + stop + end if +! +! Search for the next element of the permutation that has not been used. +! + do istart = 1, n + + if ( p(istart) < 0 ) then + + cycle + + else if ( p(istart) == istart ) then + + p(istart) = -p(istart) + cycle + + else + + a_temp(1:2) = a(1:2,istart) + iget = istart +! +! Copy the new value into the vacated entry. +! + do + + iput = iget + iget = p(iget) + + p(iput) = -p(iput) + + if ( iget < 1 .or. n < iget ) then + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) 'R82VEC_PERMUTE - Fatal error!' + stop + end if + + if ( iget == istart ) then + a(1:2,iput) = a_temp(1:2) + exit + end if + + a(1:2,iput) = a(1:2,iget) + + end do + + end if + + end do +! +! Restore the signs of the entries. +! + p(1:n) = -p(1:n) + + return +end +subroutine r82vec_sort_heap_index_a ( n, a, indx ) + +!*****************************************************************************80 +! +!! R82VEC_SORT_HEAP_INDEX_A does an indexed heap ascending sort of an R82VEC. +! +! Discussion: +! +! The sorting is not actually carried out. Rather an index array is +! created which defines the sorting. This array may be used to sort +! or index the array, or to sort or index related arrays keyed on the +! original array. +! +! Once the index array is computed, the sorting can be carried out +! "implicitly: +! +! A(1:2,INDX(I)), I = 1 to N is sorted, +! +! or explicitly, by the call +! +! call R82VEC_PERMUTE ( N, A, INDX ) +! +! after which A(1:2,I), I = 1 to N is sorted. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 08 December 2004 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the number of entries in the array. +! +! Input, real ( kind = 8 ) A(2,N), an array to be index-sorted. +! +! Output, integer ( kind = 4 ) INDX(N), the sort index. The +! I-th element of the sorted array is A(1:2,INDX(I)). +! + implicit none + + integer ( kind = 4 ) n + + real ( kind = 8 ) a(2,n) + real ( kind = 8 ) aval(2) + integer ( kind = 4 ) i + integer ( kind = 4 ) indx(n) + integer ( kind = 4 ) indxt + integer ( kind = 4 ) ir + integer ( kind = 4 ) j + integer ( kind = 4 ) l + + if ( n < 1 ) then + return + end if + + do i = 1, n + indx(i) = i + end do + + if ( n == 1 ) then + return + end if + + l = n / 2 + 1 + ir = n + + do + + if ( 1 < l ) then + + l = l - 1 + indxt = indx(l) + aval(1:2) = a(1:2,indxt) + + else + + indxt = indx(ir) + aval(1:2) = a(1:2,indxt) + indx(ir) = indx(1) + ir = ir - 1 + + if ( ir == 1 ) then + indx(1) = indxt + exit + end if + + end if + + i = l + j = l + l + + do while ( j <= ir ) + + if ( j < ir ) then + if ( a(1,indx(j)) < a(1,indx(j+1)) .or. & + ( a(1,indx(j)) == a(1,indx(j+1)) .and. & + a(2,indx(j)) < a(2,indx(j+1)) ) ) then + j = j + 1 + end if + end if + + if ( aval(1) < a(1,indx(j)) .or. & + ( aval(1) == a(1,indx(j)) .and. & + aval(2) < a(2,indx(j)) ) ) then + indx(i) = indx(j) + i = j + j = j + j + else + j = ir + 1 + end if + + end do + + indx(i) = indxt + + end do + + return +end +subroutine r82vec_sort_quick_a ( n, a ) + +!*****************************************************************************80 +! +!! R82VEC_SORT_QUICK_A ascending sorts an R82VEC using quick sort. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 08 December 2004 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the number of entries in the array. +! +! Input/output, real ( kind = 8 ) A(2,N). +! On input, the array to be sorted. +! On output, the array has been sorted. +! + implicit none + + integer ( kind = 4 ), parameter :: level_max = 25 + integer ( kind = 4 ) n + integer ( kind = 4 ), parameter :: dim_num = 2 + + real ( kind = 8 ) a(dim_num,n) + integer ( kind = 4 ) base + integer ( kind = 4 ) l_segment + integer ( kind = 4 ) level + integer ( kind = 4 ) n_segment + integer ( kind = 4 ) rsave(level_max) + integer ( kind = 4 ) r_segment + + if ( n < 1 ) then + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) 'R82VEC_SORT_QUICK_A - Fatal error!' + write ( *, '(a)' ) ' N < 1.' + stop + else if ( n == 1 ) then + return + end if + + level = 1 + rsave(level) = n + 1 + base = 1 + n_segment = n + + do +! +! Partition the segment. +! + call r82vec_part_quick_a ( n_segment, a(1,base), l_segment, r_segment ) +! +! If the left segment has more than one element, we need to partition it. +! + if ( 1 < l_segment ) then + + if ( level_max < level ) then + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) 'R82VEC_SORT_QUICK_A - Fatal error!' + write ( *, '(a,i8)' ) ' Exceeding recursion maximum of ', level_max + stop + end if + + level = level + 1 + n_segment = l_segment + rsave(level) = r_segment + base - 1 +! +! The left segment and the middle segment are sorted. +! Must the right segment be partitioned? +! + else if ( r_segment < n_segment ) then + + n_segment = n_segment + 1 - r_segment + base = base + r_segment - 1 +! +! Otherwise, we back up a level if there is an earlier one. +! + else + + do + + if ( level <= 1 ) then + return + end if + + base = rsave(level) + n_segment = rsave(level-1) - rsave(level) + level = level - 1 + + if ( 0 < n_segment ) then + exit + end if + + end do + + end if + + end do + + return +end +subroutine r8mat_transpose_print ( m, n, a, title ) + +!*****************************************************************************80 +! +!! R8MAT_TRANSPOSE_PRINT prints an R8MAT, transposed. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 14 June 2004 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) M, N, the number of rows and columns. +! +! Input, real ( kind = 8 ) A(M,N), an M by N matrix to be printed. +! +! Input, character ( len = * ) TITLE, an optional title. +! + implicit none + + integer ( kind = 4 ) m + integer ( kind = 4 ) n + + real ( kind = 8 ) a(m,n) + character ( len = * ) title + + call r8mat_transpose_print_some ( m, n, a, 1, 1, m, n, title ) + + return +end +subroutine r8mat_transpose_print_some ( m, n, a, ilo, jlo, ihi, jhi, title ) + +!*****************************************************************************80 +! +!! R8MAT_TRANSPOSE_PRINT_SOME prints some of an R8MAT, transposed. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 14 June 2004 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) M, N, the number of rows and columns. +! +! Input, real ( kind = 8 ) A(M,N), an M by N matrix to be printed. +! +! Input, integer ( kind = 4 ) ILO, JLO, the first row and column to print. +! +! Input, integer ( kind = 4 ) IHI, JHI, the last row and column to print. +! +! Input, character ( len = * ) TITLE, an optional title. +! + implicit none + + integer ( kind = 4 ), parameter :: incx = 5 + integer ( kind = 4 ) m + integer ( kind = 4 ) n + + real ( kind = 8 ) a(m,n) + character ( len = 14 ) ctemp(incx) + integer ( kind = 4 ) i + integer ( kind = 4 ) i2 + integer ( kind = 4 ) i2hi + integer ( kind = 4 ) i2lo + integer ( kind = 4 ) ihi + integer ( kind = 4 ) ilo + integer ( kind = 4 ) inc + integer ( kind = 4 ) j + integer ( kind = 4 ) j2hi + integer ( kind = 4 ) j2lo + integer ( kind = 4 ) jhi + integer ( kind = 4 ) jlo + character ( len = * ) title + + if ( 0 < len_trim ( title ) ) then + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) trim ( title ) + end if + + do i2lo = max ( ilo, 1 ), min ( ihi, m ), incx + + i2hi = i2lo + incx - 1 + i2hi = min ( i2hi, m ) + i2hi = min ( i2hi, ihi ) + + inc = i2hi + 1 - i2lo + + write ( *, '(a)' ) ' ' + + do i = i2lo, i2hi + i2 = i + 1 - i2lo + write ( ctemp(i2), '(i7,7x)') i + end do + + write ( *, '('' Row '',5a14)' ) ctemp(1:inc) + write ( *, '(a)' ) ' Col' + write ( *, '(a)' ) ' ' + + j2lo = max ( jlo, 1 ) + j2hi = min ( jhi, n ) + + do j = j2lo, j2hi + + do i2 = 1, inc + i = i2lo - 1 + i2 + write ( ctemp(i2), '(g14.6)' ) a(i,j) + end do + + write ( *, '(i5,1x,5a14)' ) j, ( ctemp(i), i = 1, inc ) + + end do + + end do + + write ( *, '(a)' ) ' ' + + return +end +subroutine r8mat_uniform_01 ( m, n, seed, r ) + +!*****************************************************************************80 +! +!! R8MAT_UNIFORM_01 returns a unit pseudorandom R8MAT. +! +! Discussion: +! +! An R8MAT is an array of R8's. +! +! For now, the input quantity SEED is an integer variable. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 31 May 2007 +! +! Author: +! +! John Burkardt +! +! Reference: +! +! Paul Bratley, Bennett Fox, Linus Schrage, +! A Guide to Simulation, +! Second Edition, +! Springer, 1987, +! ISBN: 0387964673, +! LC: QA76.9.C65.B73. +! +! Bennett Fox, +! Algorithm 647: +! Implementation and Relative Efficiency of Quasirandom +! Sequence Generators, +! ACM Transactions on Mathematical Software, +! Volume 12, Number 4, December 1986, pages 362-376. +! +! Pierre L'Ecuyer, +! Random Number Generation, +! in Handbook of Simulation, +! edited by Jerry Banks, +! Wiley, 1998, +! ISBN: 0471134031, +! LC: T57.62.H37. +! +! Peter Lewis, Allen Goodman, James Miller, +! A Pseudo-Random Number Generator for the System/360, +! IBM Systems Journal, +! Volume 8, Number 2, 1969, pages 136-143. +! +! Parameters: +! +! Input, integer ( kind = 4 ) M, N, the number of rows and columns +! in the array. +! +! Input/output, integer ( kind = 4 ) SEED, the "seed" value, which +! should NOT be 0. On output, SEED has been updated. +! +! Output, real ( kind = 8 ) R(M,N), the array of pseudorandom values. +! + implicit none + + integer ( kind = 4 ) m + integer ( kind = 4 ) n + + integer ( kind = 4 ) i + integer ( kind = 4 ), parameter :: i4_huge = 2147483647 + integer ( kind = 4 ) j + integer ( kind = 4 ) k + integer ( kind = 4 ) seed + real ( kind = 8 ) r(m,n) + + if ( seed == 0 ) then + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) 'R8MAT_UNIFORM_01 - Fatal error!' + write ( *, '(a)' ) ' Input value of SEED = 0.' + stop + end if + + do j = 1, n + + do i = 1, m + + k = seed / 127773 + + seed = 16807 * ( seed - k * 127773 ) - k * 2836 + + if ( seed < 0 ) then + seed = seed + i4_huge + end if + + r(i,j) = real ( seed, kind = 8 ) * 4.656612875D-10 + + end do + end do + + return +end +function r8vec_eq ( n, a1, a2 ) + +!*****************************************************************************80 +! +!! R8VEC_EQ is true if two R8VEC's are equal. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 05 December 2004 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the number of entries in the vectors. +! +! Input, real ( kind = 8 ) A1(N), A2(N), two vectors to compare. +! +! Output, logical R8VEC_EQ, is TRUE if every pair of elements A1(I) +! and A2(I) are equal, and FALSE otherwise. +! + implicit none + + integer ( kind = 4 ) n + + real ( kind = 8 ) a1(n) + real ( kind = 8 ) a2(n) + logical r8vec_eq + + r8vec_eq = ( all ( a1(1:n) == a2(1:n) ) ) + + return +end +function r8vec_gt ( n, a1, a2 ) + +!*****************************************************************************80 +! +!! R8VEC_GT == ( A1 > A2 ) for R8VEC's. +! +! Discussion: +! +! The comparison is lexicographic. +! +! A1 > A2 <=> A1(1) > A2(1) or +! ( A1(1) == A2(1) and A1(2) > A2(2) ) or +! ... +! ( A1(1:N-1) == A2(1:N-1) and A1(N) > A2(N) +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 05 December 2004 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the dimension of the vectors. +! +! Input, real ( kind = 8 ) A1(N), A2(N), the vectors to be compared. +! +! Output, logical R8VEC_GT, is TRUE if and only if A1 > A2. +! + implicit none + + integer ( kind = 4 ) n + + real ( kind = 8 ) a1(n) + real ( kind = 8 ) a2(n) + integer ( kind = 4 ) i + logical r8vec_gt + + r8vec_gt = .false. + + do i = 1, n + + if ( a2(i) < a1(i) ) then + r8vec_gt = .true. + exit + else if ( a1(i) < a2(i) ) then + r8vec_gt = .false. + exit + end if + + end do + + return +end +function r8vec_lt ( n, a1, a2 ) + +!*****************************************************************************80 +! +!! R8VEC_LT == ( A1 < A2 ) for R8VEC's. +! +! Discussion: +! +! The comparison is lexicographic. +! +! A1 < A2 <=> A1(1) < A2(1) or +! ( A1(1) == A2(1) and A1(2) < A2(2) ) or +! ... +! ( A1(1:N-1) == A2(1:N-1) and A1(N) < A2(N) +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 05 December 2004 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the dimension of the vectors. +! +! Input, real ( kind = 8 ) A1(N), A2(N), the vectors to be compared. +! +! Output, logical R8VEC_LT, is TRUE if and only if A1 < A2. +! + implicit none + + integer ( kind = 4 ) n + + real ( kind = 8 ) a1(n) + real ( kind = 8 ) a2(n) + integer ( kind = 4 ) i + logical r8vec_lt + + r8vec_lt = .false. + + do i = 1, n + + if ( a1(i) < a2(i) ) then + r8vec_lt = .true. + exit + else if ( a2(i) < a1(i) ) then + r8vec_lt = .false. + exit + end if + + end do + + return +end +subroutine r8vec_print ( n, a, title ) + +!*****************************************************************************80 +! +!! R8VEC_PRINT prints an R8VEC. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 22 August 2000 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the number of components of the vector. +! +! Input, real ( kind = 8 ) A(N), the vector to be printed. +! +! Input, character ( len = * ) TITLE, an optional title. +! + implicit none + + integer ( kind = 4 ) n + + real ( kind = 8 ) a(n) + integer ( kind = 4 ) i + character ( len = * ) title + + if ( 0 < len_trim ( title ) ) then + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) trim ( title ) + end if + + write ( *, '(a)' ) ' ' + do i = 1, n + write ( *, '(2x,i8,g16.8)' ) i, a(i) + end do + + return +end +subroutine r8vec_swap ( n, a1, a2 ) + +!*****************************************************************************80 +! +!! R8VEC_SWAP swaps the entries of two R8VEC's. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 04 December 2004 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the number of entries in the arrays. +! +! Input/output, real ( kind = 8 ) A1(N), A2(N), the vectors to swap. +! + implicit none + + integer ( kind = 4 ) n + + real ( kind = 8 ) a1(n) + real ( kind = 8 ) a2(n) + real ( kind = 8 ) a3(n) + + a3(1:n) = a1(1:n) + a1(1:n) = a2(1:n) + a2(1:n) = a3(1:n) + + return +end +subroutine swapec ( i, top, btri, bedg, node_num, node_xy, triangle_num, & + triangle_node, triangle_neighbor, stack, ierr ) + +!*****************************************************************************80 +! +!! SWAPEC swaps diagonal edges until all triangles are Delaunay. +! +! Discussion: +! +! The routine swaps diagonal edges in a 2D triangulation, based on +! the empty circumcircle criterion, until all triangles are Delaunay, +! given that I is the index of the new vertex added to the triangulation. +! +! Modified: +! +! 14 July 2001 +! +! Author: +! +! Original FORTRAN77 version by Barry Joe. +! FORTRAN90 version by John Burkardt. +! +! Reference: +! +! Barry Joe, +! GEOMPACK - a software package for the generation of meshes +! using geometric algorithms, +! Advances in Engineering Software, +! Volume 13, pages 325-331, 1991. +! +! Parameters: +! +! Input, integer ( kind = 4 ) I, the index of the new vertex. +! +! Input/output, integer ( kind = 4 ) TOP, the index of the top of the stack. +! On output, TOP is zero. +! +! Input/output, integer ( kind = 4 ) BTRI, BEDG; on input, if positive, are the +! triangle and edge indices of a boundary edge whose updated indices +! must be recorded. On output, these may be updated because of swaps. +! +! Input, integer ( kind = 4 ) NODE_NUM, the number of points. +! +! Input, real ( kind = 8 ) NODE_XY(2,NODE_NUM), the coordinates of +! the points. +! +! Input, integer ( kind = 4 ) TRIANGLE_NUM, the number of triangles. +! +! Input/output, integer ( kind = 4 ) TRIANGLE_NODE(3,TRIANGLE_NUM), the triangle +! incidence list. May be updated on output because of swaps. +! +! Input/output, integer ( kind = 4 ) TRIANGLE_NEIGHBOR(3,TRIANGLE_NUM), +! the triangle neighbor list; negative values are used for links of the +! counter-clockwise linked list of boundary edges; May be updated on output +! because of swaps. +! LINK = -(3*I + J-1) where I, J = triangle, edge index. +! +! Workspace, integer ( kind = 4 ) STACK(MAXST); on input, entries 1 through TOP +! contain the indices of initial triangles (involving vertex I) +! put in stack; the edges opposite I should be in interior; entries +! TOP+1 through MAXST are used as a stack. +! +! Output, integer ( kind = 4 ) IERR is set to 8 for abnormal return. +! + implicit none + + integer ( kind = 4 ) node_num + integer ( kind = 4 ) triangle_num + + integer ( kind = 4 ) a + integer ( kind = 4 ) b + integer ( kind = 4 ) bedg + integer ( kind = 4 ) btri + integer ( kind = 4 ) c + integer ( kind = 4 ) diaedg + integer ( kind = 4 ) e + integer ( kind = 4 ) ee + integer ( kind = 4 ) em1 + integer ( kind = 4 ) ep1 + integer ( kind = 4 ) f + integer ( kind = 4 ) fm1 + integer ( kind = 4 ) fp1 + integer ( kind = 4 ) i + integer ( kind = 4 ) ierr + integer ( kind = 4 ) i4_wrap + integer ( kind = 4 ) l + real ( kind = 8 ) node_xy(2,node_num) + integer ( kind = 4 ) r + integer ( kind = 4 ) s + integer ( kind = 4 ) stack(node_num) + integer ( kind = 4 ) swap + integer ( kind = 4 ) t + integer ( kind = 4 ) top + integer ( kind = 4 ) triangle_neighbor(3,triangle_num) + integer ( kind = 4 ) triangle_node(3,triangle_num) + integer ( kind = 4 ) tt + integer ( kind = 4 ) u + real ( kind = 8 ) x + real ( kind = 8 ) y +! +! Determine whether triangles in stack are Delaunay, and swap +! diagonal edge of convex quadrilateral if not. +! + x = node_xy(1,i) + y = node_xy(2,i) + + do + + if ( top <= 0 ) then + exit + end if + + t = stack(top) + top = top - 1 + + if ( triangle_node(1,t) == i ) then + e = 2 + b = triangle_node(3,t) + else if ( triangle_node(2,t) == i ) then + e = 3 + b = triangle_node(1,t) + else + e = 1 + b = triangle_node(2,t) + end if + + a = triangle_node(e,t) + u = triangle_neighbor(e,t) + + if ( triangle_neighbor(1,u) == t ) then + f = 1 + c = triangle_node(3,u) + else if ( triangle_neighbor(2,u) == t ) then + f = 2 + c = triangle_node(1,u) + else + f = 3 + c = triangle_node(2,u) + end if + + swap = diaedg ( x, y, node_xy(1,a), node_xy(2,a), node_xy(1,c), & + node_xy(2,c), node_xy(1,b), node_xy(2,b) ) + + if ( swap == 1 ) then + + em1 = i4_wrap ( e - 1, 1, 3 ) + ep1 = i4_wrap ( e + 1, 1, 3 ) + fm1 = i4_wrap ( f - 1, 1, 3 ) + fp1 = i4_wrap ( f + 1, 1, 3 ) + + triangle_node(ep1,t) = c + triangle_node(fp1,u) = i + r = triangle_neighbor(ep1,t) + s = triangle_neighbor(fp1,u) + triangle_neighbor(ep1,t) = u + triangle_neighbor(fp1,u) = t + triangle_neighbor(e,t) = s + triangle_neighbor(f,u) = r + + if ( 0 < triangle_neighbor(fm1,u) ) then + top = top + 1 + stack(top) = u + end if + + if ( 0 < s ) then + + if ( triangle_neighbor(1,s) == u ) then + triangle_neighbor(1,s) = t + else if ( triangle_neighbor(2,s) == u ) then + triangle_neighbor(2,s) = t + else + triangle_neighbor(3,s) = t + end if + + top = top + 1 + + if ( node_num < top ) then + ierr = 8 + return + end if + + stack(top) = t + + else + + if ( u == btri .and. fp1 == bedg ) then + btri = t + bedg = e + end if + + l = - ( 3 * t + e - 1 ) + tt = t + ee = em1 + + do while ( 0 < triangle_neighbor(ee,tt) ) + + tt = triangle_neighbor(ee,tt) + + if ( triangle_node(1,tt) == a ) then + ee = 3 + else if ( triangle_node(2,tt) == a ) then + ee = 1 + else + ee = 2 + end if + + end do + + triangle_neighbor(ee,tt) = l + + end if + + if ( 0 < r ) then + + if ( triangle_neighbor(1,r) == t ) then + triangle_neighbor(1,r) = u + else if ( triangle_neighbor(2,r) == t ) then + triangle_neighbor(2,r) = u + else + triangle_neighbor(3,r) = u + end if + + else + + if ( t == btri .and. ep1 == bedg ) then + btri = u + bedg = f + end if + + l = - ( 3 * u + f - 1 ) + tt = u + ee = fm1 + + do while ( 0 < triangle_neighbor(ee,tt) ) + + tt = triangle_neighbor(ee,tt) + + if ( triangle_node(1,tt) == b ) then + ee = 3 + else if ( triangle_node(2,tt) == b ) then + ee = 1 + else + ee = 2 + end if + + end do + + triangle_neighbor(ee,tt) = l + + end if + + end if + + end do + + return +end +subroutine timestamp ( ) + +!*****************************************************************************80 +! +!! TIMESTAMP prints the current YMDHMS date as a time stamp. +! +! Example: +! +! May 31 2001 9:45:54.872 AM +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 15 March 2003 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! None +! + implicit none + + character ( len = 40 ) string + + call timestring ( string ) + + write ( *, '(a)' ) trim ( string ) + + return +end +subroutine timestring ( string ) + +!*****************************************************************************80 +! +!! TIMESTRING writes the current YMDHMS date into a string. +! +! Example: +! +! STRING = 'May 31 2001 9:45:54.872 AM' +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 15 March 2003 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Output, character ( len = * ) STRING, contains the date information. +! A character length of 40 should always be sufficient. +! + implicit none + + character ( len = 8 ) ampm + integer ( kind = 4 ) d + character ( len = 8 ) date + integer ( kind = 4 ) h + integer ( kind = 4 ) m + integer ( kind = 4 ) mm + character ( len = 9 ), parameter, dimension(12) :: month = (/ & + 'January ', 'February ', 'March ', 'April ', & + 'May ', 'June ', 'July ', 'August ', & + 'September', 'October ', 'November ', 'December ' /) + integer ( kind = 4 ) n + integer ( kind = 4 ) s + character ( len = * ) string + character ( len = 10 ) time + integer ( kind = 4 ) values(8) + integer ( kind = 4 ) y + character ( len = 5 ) zone + + call date_and_time ( date, time, zone, values ) + + y = values(1) + m = values(2) + d = values(3) + h = values(5) + n = values(6) + s = values(7) + mm = values(8) + + if ( h < 12 ) then + ampm = 'AM' + else if ( h == 12 ) then + if ( n == 0 .and. s == 0 ) then + ampm = 'Noon' + else + ampm = 'PM' + end if + else + h = h - 12 + if ( h < 12 ) then + ampm = 'PM' + else if ( h == 12 ) then + if ( n == 0 .and. s == 0 ) then + ampm = 'Midnight' + else + ampm = 'AM' + end if + end if + end if + + write ( string, '(a,1x,i2,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) & + trim ( month(m) ), d, y, h, ':', n, ':', s, '.', mm, trim ( ampm ) + + return +end +subroutine triangle_circumcenter_2d ( t, center ) + +!*****************************************************************************80 +! +!! TRIANGLE_CIRCUMCENTER_2D computes the circumcenter of a triangle in 2D. +! +! Discussion: +! +! The circumcenter of a triangle is the center of the circumcircle, the +! circle that passes through the three vertices of the triangle. +! +! The circumcircle contains the triangle, but it is not necessarily the +! smallest triangle to do so. +! +! If all angles of the triangle are no greater than 90 degrees, then +! the center of the circumscribed circle will lie inside the triangle. +! Otherwise, the center will lie outside the circle. +! +! The circumcenter is the intersection of the perpendicular bisectors +! of the sides of the triangle. +! +! In geometry, the circumcenter of a triangle is often symbolized by "O". +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 09 February 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) T(2,3), the triangle vertices. +! +! Output, real ( kind = 8 ) CENTER(2), the circumcenter of the triangle. +! + implicit none + + integer ( kind = 4 ), parameter :: dim_num = 2 + + real ( kind = 8 ) asq + real ( kind = 8 ) bot + real ( kind = 8 ) center(dim_num) + real ( kind = 8 ) csq + real ( kind = 8 ) t(dim_num,3) + real ( kind = 8 ) top(dim_num) + + asq = ( t(1,2) - t(1,1) )**2 + ( t(2,2) - t(2,1) )**2 + csq = ( t(1,3) - t(1,1) )**2 + ( t(2,3) - t(2,1) )**2 + + top(1) = ( t(2,2) - t(2,1) ) * csq - ( t(2,3) - t(2,1) ) * asq + top(2) = ( t(1,2) - t(1,1) ) * csq - ( t(1,3) - t(1,1) ) * asq + + bot = ( t(2,2) - t(2,1) ) * ( t(1,3) - t(1,1) ) & + - ( t(2,3) - t(2,1) ) * ( t(1,2) - t(1,1) ) + + center(1:2) = t(1:2,1) + 0.5D+00 * top(1:2) / bot + + return +end +subroutine triangulation_order3_plot ( file_name, node_num, node_xy, & + triangle_num, triangle_node, node_show, triangle_show ) + +!*****************************************************************************80 +! +!! TRIANGULATION_ORDER3_PLOT plots a 3-node triangulation of a set of nodes. +! +! Discussion: +! +! The triangulation is most usually a Delaunay triangulation, +! but this is not necessary. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 16 March 2005 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, character ( len = * ) FILE_NAME, the name of the output file. +! +! Input, integer ( kind = 4 ) NODE_NUM, the number of nodes. +! +! Input, real ( kind = 8 ) NODE_XY(2,NODE_NUM), the coordinates of the nodes. +! +! Input, integer ( kind = 4 ) TRIANGLE_NUM, the number of triangles. +! +! Input, integer ( kind = 4 ) TRIANGLE_NODE(3,TRIANGLE_NUM), lists, for each +! triangle, the indices of the nodes that form the vertices of the triangle. +! +! Input, integer ( kind = 4 ) NODE_SHOW, +! 0, do not show nodes; +! 1, show nodes; +! 2, show nodes and label them. +! +! Input, integer ( kind = 4 ) TRIANGLE_SHOW, +! 0, do not show triangles; +! 1, show triangles; +! 2, show triangles and label them. +! +! Local parameters: +! +! Local, integer ( kind = 4 ) CIRCLE_SIZE, controls the size of the circles +! depicting the nodes. Currently set to 5. 3 is pretty small, and 1 is +! barely visible. +! + implicit none + + integer ( kind = 4 ) node_num + integer ( kind = 4 ) triangle_num + + real ( kind = 8 ) ave_x + real ( kind = 8 ) ave_y + character ( len = 40 ) date_time + integer ( kind = 4 ), parameter :: circle_size = 5 + integer ( kind = 4 ) delta + integer ( kind = 4 ) e + character ( len = * ) file_name + integer ( kind = 4 ) file_unit + integer ( kind = 4 ) i + integer ( kind = 4 ) i4_wrap + integer ( kind = 4 ) ios + integer ( kind = 4 ) node + integer ( kind = 4 ) node_show + real ( kind = 8 ) node_xy(2,node_num) + character ( len = 40 ) string + integer ( kind = 4 ) triangle + integer ( kind = 4 ) triangle_node(3,triangle_num) + integer ( kind = 4 ) triangle_show + real ( kind = 8 ) x_max + real ( kind = 8 ) x_min + integer ( kind = 4 ) x_ps + integer ( kind = 4 ) :: x_ps_max = 576 + integer ( kind = 4 ) :: x_ps_max_clip = 594 + integer ( kind = 4 ) :: x_ps_min = 36 + integer ( kind = 4 ) :: x_ps_min_clip = 18 + real ( kind = 8 ) x_scale + real ( kind = 8 ) y_max + real ( kind = 8 ) y_min + integer ( kind = 4 ) y_ps + integer ( kind = 4 ) :: y_ps_max = 666 + integer ( kind = 4 ) :: y_ps_max_clip = 684 + integer ( kind = 4 ) :: y_ps_min = 126 + integer ( kind = 4 ) :: y_ps_min_clip = 108 + real ( kind = 8 ) y_scale + + call timestring ( date_time ) +! +! We need to do some figuring here, so that we can determine +! the range of the data, and hence the height and width +! of the piece of paper. +! + x_max = maxval ( node_xy(1,1:node_num) ) + x_min = minval ( node_xy(1,1:node_num) ) + x_scale = x_max - x_min + + x_max = x_max + 0.05D+00 * x_scale + x_min = x_min - 0.05D+00 * x_scale + x_scale = x_max - x_min + + y_max = maxval ( node_xy(2,1:node_num) ) + y_min = minval ( node_xy(2,1:node_num) ) + y_scale = y_max - y_min + + y_max = y_max + 0.05D+00 * y_scale + y_min = y_min - 0.05D+00 * y_scale + y_scale = y_max - y_min + + if ( x_scale < y_scale ) then + + delta = nint ( real ( x_ps_max - x_ps_min, kind = 8 ) & + * ( y_scale - x_scale ) / ( 2.0D+00 * y_scale ) ) + + x_ps_max = x_ps_max - delta + x_ps_min = x_ps_min + delta + + x_ps_max_clip = x_ps_max_clip - delta + x_ps_min_clip = x_ps_min_clip + delta + + x_scale = y_scale + + else if ( y_scale < x_scale ) then + + delta = nint ( real ( y_ps_max - y_ps_min, kind = 8 ) & + * ( x_scale - y_scale ) / ( 2.0D+00 * x_scale ) ) + + y_ps_max = y_ps_max - delta + y_ps_min = y_ps_min + delta + + y_ps_max_clip = y_ps_max_clip - delta + y_ps_min_clip = y_ps_min_clip + delta + + y_scale = x_scale + + end if + + call get_unit ( file_unit ) + + open ( unit = file_unit, file = file_name, status = 'replace', & + iostat = ios ) + + if ( ios /= 0 ) then + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) 'TRIANGULATION_ORDER3_PLOT - Fatal error!' + write ( *, '(a)' ) ' Can not open output file "', trim ( file_name ), '".' + return + end if + + write ( file_unit, '(a)' ) '%!PS-Adobe-3.0 EPSF-3.0' + write ( file_unit, '(a)' ) '%%Creator: triangulation_order3_plot.f90' + write ( file_unit, '(a)' ) '%%Title: ' // trim ( file_name ) + write ( file_unit, '(a)' ) '%%CreationDate: ' // trim ( date_time ) + write ( file_unit, '(a)' ) '%%Pages: 1' + write ( file_unit, '(a,i3,2x,i3,2x,i3,2x,i3)' ) '%%BoundingBox: ', & + x_ps_min, y_ps_min, x_ps_max, y_ps_max + write ( file_unit, '(a)' ) '%%Document-Fonts: Times-Roman' + write ( file_unit, '(a)' ) '%%LanguageLevel: 1' + write ( file_unit, '(a)' ) '%%EndComments' + write ( file_unit, '(a)' ) '%%BeginProlog' + write ( file_unit, '(a)' ) '/inch {72 mul} def' + write ( file_unit, '(a)' ) '%%EndProlog' + write ( file_unit, '(a)' ) '%%Page: 1 1' + write ( file_unit, '(a)' ) 'save' + write ( file_unit, '(a)' ) '%' + write ( file_unit, '(a)' ) '% Set the RGB line color to very light gray.' + write ( file_unit, '(a)' ) '%' + write ( file_unit, '(a)' ) '0.900 0.900 0.900 setrgbcolor' + write ( file_unit, '(a)' ) '%' + write ( file_unit, '(a)' ) '% Draw a gray border around the page.' + write ( file_unit, '(a)' ) '%' + write ( file_unit, '(a)' ) 'newpath' + write ( file_unit, '(a,i3,2x,i3,2x,a)' ) ' ', x_ps_min, y_ps_min, ' moveto' + write ( file_unit, '(a,i3,2x,i3,2x,a)' ) ' ', x_ps_max, y_ps_min, ' lineto' + write ( file_unit, '(a,i3,2x,i3,2x,a)' ) ' ', x_ps_max, y_ps_max, ' lineto' + write ( file_unit, '(a,i3,2x,i3,2x,a)' ) ' ', x_ps_min, y_ps_max, ' lineto' + write ( file_unit, '(a,i3,2x,i3,2x,a)' ) ' ', x_ps_min, y_ps_min, ' lineto' + write ( file_unit, '(a)' ) 'stroke' + write ( file_unit, '(a)' ) '%' + write ( file_unit, '(a)' ) '% Set the RGB color to black.' + write ( file_unit, '(a)' ) '%' + write ( file_unit, '(a)' ) '0.000 0.000 0.000 setrgbcolor' + write ( file_unit, '(a)' ) '%' + write ( file_unit, '(a)' ) '% Set the font and its size.' + write ( file_unit, '(a)' ) '%' + write ( file_unit, '(a)' ) '/Times-Roman findfont' + write ( file_unit, '(a)' ) '0.50 inch scalefont' + write ( file_unit, '(a)' ) 'setfont' + write ( file_unit, '(a)' ) '%' + write ( file_unit, '(a)' ) '% Print a title.' + write ( file_unit, '(a)' ) '%' + write ( file_unit, '(a)' ) '% 210 702 moveto' + write ( file_unit, '(a)' ) '% (Triangulation) show' + write ( file_unit, '(a)' ) '%' + write ( file_unit, '(a)' ) '% Define a clipping polygon.' + write ( file_unit, '(a)' ) '%' + write ( file_unit, '(a)' ) 'newpath' + write ( file_unit, '(a,i3,2x,i3,2x,a)' ) ' ', & + x_ps_min_clip, y_ps_min_clip, ' moveto' + write ( file_unit, '(a,i3,2x,i3,2x,a)' ) ' ', & + x_ps_max_clip, y_ps_min_clip, ' lineto' + write ( file_unit, '(a,i3,2x,i3,2x,a)' ) ' ', & + x_ps_max_clip, y_ps_max_clip, ' lineto' + write ( file_unit, '(a,i3,2x,i3,2x,a)' ) ' ', & + x_ps_min_clip, y_ps_max_clip, ' lineto' + write ( file_unit, '(a,i3,2x,i3,2x,a)' ) ' ', & + x_ps_min_clip, y_ps_min_clip, ' lineto' + write ( file_unit, '(a)' ) 'clip newpath' +! +! Draw the nodes. +! + if ( 1 <= node_show ) then + write ( file_unit, '(a)' ) '%' + write ( file_unit, '(a)' ) '% Draw filled dots at the nodes.' + write ( file_unit, '(a)' ) '%' + write ( file_unit, '(a)' ) '% Set the RGB color to blue.' + write ( file_unit, '(a)' ) '%' + write ( file_unit, '(a)' ) '0.000 0.150 0.750 setrgbcolor' + write ( file_unit, '(a)' ) '%' + + do node = 1, node_num + + x_ps = int ( & + ( ( x_max - node_xy(1,node) ) * real ( x_ps_min, kind = 8 ) & + + ( node_xy(1,node) - x_min ) * real ( x_ps_max, kind = 8 ) ) & + / ( x_max - x_min ) ) + + y_ps = int ( & + ( ( y_max - node_xy(2,node) ) * real ( y_ps_min, kind = 8 ) & + + ( node_xy(2,node) - y_min ) * real ( y_ps_max, kind = 8 ) ) & + / ( y_max - y_min ) ) + + write ( file_unit, '(a,i4,2x,i4,2x,i4,2x,a)' ) 'newpath ', x_ps, y_ps, & + circle_size, '0 360 arc closepath fill' + + end do + + end if +! +! Label the nodes. +! + if ( 2 <= node_show ) then + + write ( file_unit, '(a)' ) '%' + write ( file_unit, '(a)' ) '% Label the nodes:' + write ( file_unit, '(a)' ) '%' + write ( file_unit, '(a)' ) '% Set the RGB color to darker blue.' + write ( file_unit, '(a)' ) '%' + write ( file_unit, '(a)' ) '0.000 0.250 0.850 setrgbcolor' + write ( file_unit, '(a)' ) '/Times-Roman findfont' + write ( file_unit, '(a)' ) '0.20 inch scalefont' + write ( file_unit, '(a)' ) 'setfont' + write ( file_unit, '(a)' ) '%' + + do node = 1, node_num + + x_ps = int ( & + ( ( x_max - node_xy(1,node) ) * real ( x_ps_min, kind = 8 ) & + + ( + node_xy(1,node) - x_min ) * real ( x_ps_max, kind = 8 ) ) & + / ( x_max - x_min ) ) + + y_ps = int ( & + ( ( y_max - node_xy(2,node) ) * real ( y_ps_min, kind = 8 ) & + + ( node_xy(2,node) - y_min ) * real ( y_ps_max, kind = 8 ) ) & + / ( y_max - y_min ) ) + + write ( string, '(i4)' ) node + string = adjustl ( string ) + + write ( file_unit, '(i4,2x,i4,a)' ) x_ps, y_ps+5, & + ' moveto (' // trim ( string ) // ') show' + + end do + + end if +! +! Draw the triangles. +! + if ( 1 <= triangle_show ) then + write ( file_unit, '(a)' ) '%' + write ( file_unit, '(a)' ) '% Set the RGB color to red.' + write ( file_unit, '(a)' ) '%' + write ( file_unit, '(a)' ) '0.900 0.200 0.100 setrgbcolor' + write ( file_unit, '(a)' ) '%' + write ( file_unit, '(a)' ) '% Draw the triangles.' + write ( file_unit, '(a)' ) '%' + + do triangle = 1, triangle_num + + write ( file_unit, '(a)' ) 'newpath' + + do i = 1, 4 + + e = i4_wrap ( i, 1, 3 ) + + node = triangle_node(e,triangle) + + x_ps = int ( & + ( ( x_max - node_xy(1,node) ) * real ( x_ps_min, kind = 8 ) & + + ( node_xy(1,node) - x_min ) * real ( x_ps_max, kind = 8 ) ) & + / ( x_max - x_min ) ) + + y_ps = int ( & + ( ( y_max - node_xy(2,node) ) * real ( y_ps_min, kind = 8 ) & + + ( node_xy(2,node) - y_min ) * real ( y_ps_max, kind = 8 ) ) & + / ( y_max - y_min ) ) + + if ( i == 1 ) then + write ( file_unit, '(i3,2x,i3,2x,a)' ) x_ps, y_ps, ' moveto' + else + write ( file_unit, '(i3,2x,i3,2x,a)' ) x_ps, y_ps, ' lineto' + end if + + end do + + write ( file_unit, '(a)' ) 'stroke' + + end do + + end if +! +! Label the triangles. +! + if ( 2 <= triangle_show ) then + + write ( file_unit, '(a)' ) '%' + write ( file_unit, '(a)' ) '% Label the triangles:' + write ( file_unit, '(a)' ) '%' + write ( file_unit, '(a)' ) '% Set the RGB color to darker red.' + write ( file_unit, '(a)' ) '%' + write ( file_unit, '(a)' ) '0.950 0.250 0.150 setrgbcolor' + write ( file_unit, '(a)' ) '/Times-Roman findfont' + write ( file_unit, '(a)' ) '0.20 inch scalefont' + write ( file_unit, '(a)' ) 'setfont' + write ( file_unit, '(a)' ) '%' + + do triangle = 1, triangle_num + + ave_x = 0.0D+00 + ave_y = 0.0D+00 + + do i = 1, 3 + + node = triangle_node(i,triangle) + + ave_x = ave_x + node_xy(1,node) + ave_y = ave_y + node_xy(2,node) + + end do + + ave_x = ave_x / 3.0D+00 + ave_y = ave_y / 3.0D+00 + + x_ps = int ( & + ( ( x_max - ave_x ) * real ( x_ps_min, kind = 8 ) & + + ( + ave_x - x_min ) * real ( x_ps_max, kind = 8 ) ) & + / ( x_max - x_min ) ) + + y_ps = int ( & + ( ( y_max - ave_y ) * real ( y_ps_min, kind = 8 ) & + + ( ave_y - y_min ) * real ( y_ps_max, kind = 8 ) ) & + / ( y_max - y_min ) ) + + write ( string, '(i4)' ) triangle + string = adjustl ( string ) + + write ( file_unit, '(i4,2x,i4,a)' ) x_ps, y_ps, ' moveto (' & + // trim ( string ) // ') show' + + end do + + end if + + write ( file_unit, '(a)' ) '%' + write ( file_unit, '(a)' ) 'restore showpage' + write ( file_unit, '(a)' ) '%' + write ( file_unit, '(a)' ) '% End of page.' + write ( file_unit, '(a)' ) '%' + write ( file_unit, '(a)' ) '%%Trailer' + write ( file_unit, '(a)' ) '%%EOF' + close ( unit = file_unit ) + + return +end +subroutine triangulation_order3_print ( node_num, triangle_num, node_xy, & + triangle_node, triangle_neighbor ) + +!*****************************************************************************80 +! +!! TRIANGULATION_ORDER3_PRINT prints information about a Delaunay triangulation. +! +! Discussion: +! +! Triangulations created by DTRIS2 include extra information encoded +! in the negative values of TRIANGLE_NEIGHBOR. +! +! Because some of the nodes counted in NODE_NUM may not actually be +! used in the triangulation, I needed to compute the true number +! of vertices. I added this calculation on 13 October 2001. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 26 November 2002 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, integer ( kind = 4 ) NODE_NUM, the number of nodes. +! +! Input, integer ( kind = 4 ) TRIANGLE_NUM, the number of triangles. +! +! Input, real ( kind = 8 ) NODE_XY(2,NODE_NUM), the coordinates of the nodes. +! +! Input, integer ( kind = 4 ) TRIANGLE_NODE(3,TRIANGLE_NUM), the nodes that +! make up the triangles. +! +! Input, integer ( kind = 4 ) TRIANGLE_NEIGHBOR(3,TRIANGLE_NUM), the +! triangle neighbors on each side. If there is no triangle neighbor on a +! particular side, the value of TRIANGLE_NEIGHBOR should be negative. If +! the triangulation data was created by DTRIS2, then there is more +! information encoded in the negative values. +! + implicit none + + integer ( kind = 4 ), parameter :: dim_num = 2 + integer ( kind = 4 ) node_num + integer ( kind = 4 ) triangle_num + + integer ( kind = 4 ) boundary_num + integer ( kind = 4 ) i + integer ( kind = 4 ) i4_wrap + integer ( kind = 4 ) j + integer ( kind = 4 ) k + integer ( kind = 4 ) n1 + integer ( kind = 4 ) n2 + real ( kind = 8 ) node_xy(dim_num,node_num) + integer ( kind = 4 ) s + logical skip + integer ( kind = 4 ) t + integer ( kind = 4 ) triangle_node(3,triangle_num) + integer ( kind = 4 ) triangle_neighbor(3,triangle_num) + integer ( kind = 4 ), allocatable, dimension ( : ) :: vertex_list + integer ( kind = 4 ) vertex_num + + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) 'TRIANGULATION_ORDER3_PRINT' + write ( *, '(a)' ) ' Information defining an order3 triangulation.' + write ( *, '(a)' ) ' ' + write ( *, '(a,i8)' ) ' The number of nodes is ', node_num + + call r8mat_transpose_print ( dim_num, node_num, node_xy, ' Node coordinates' ) + + write ( *, '(a)' ) ' ' + write ( *, '(a,i8)' ) ' The number of triangles is ', triangle_num + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) ' Sets of three nodes are used as vertices of' + write ( *, '(a)' ) ' the triangles. For each triangle, the nodes' + write ( *, '(a)' ) ' are listed in counterclockwise order.' + + call i4mat_transpose_print ( 3, triangle_num, triangle_node, & + ' Triangle nodes:' ) + + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) ' On each side of a given triangle, there is either' + write ( *, '(a)' ) ' another triangle, or a piece of the convex hull.' + write ( *, '(a)' ) ' For each triangle, we list the indices of the three' + write ( *, '(a)' ) ' neighbors, or (if negative) the codes of the' + write ( *, '(a)' ) ' segments of the convex hull.' + + call i4mat_transpose_print ( 3, triangle_num, triangle_neighbor, & + ' Triangle neighbors' ) +! +! Determine the number of vertices. +! + allocate ( vertex_list(1:3*triangle_num) ) + + vertex_list(1:3*triangle_num) = reshape ( triangle_node(1:3,1:triangle_num), & + (/ 3*triangle_num /) ) + + call i4vec_sort_heap_a ( 3*triangle_num, vertex_list ) + + call i4vec_sorted_unique ( 3*triangle_num, vertex_list, vertex_num ) + + deallocate ( vertex_list ) +! +! Determine the number of boundary points. +! + boundary_num = 2 * vertex_num - triangle_num - 2 + + write ( *, '(a)' ) ' ' + write ( *, '(a,i8)' ) ' The number of boundary points is ', boundary_num + + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) ' The segments that make up the convex hull can be' + write ( *, '(a)' ) ' determined from the negative entries of the triangle' + write ( *, '(a)' ) ' neighbor list.' + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) ' # Tri Side N1 N2' + write ( *, '(a)' ) ' ' + + skip = .false. + + k = 0 + + do i = 1, triangle_num + + do j = 1, 3 + + if ( triangle_neighbor(j,i) < 0 ) then + s = - triangle_neighbor(j,i) + t = s / 3 + + if ( t < 1 .or. triangle_num < t ) then + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) ' Sorry, this data does not use the DTRIS2' + write ( *, '(a)' ) ' convention for convex hull segments.' + skip = .true. + exit + end if + + s = mod ( s, 3 ) + 1 + k = k + 1 + n1 = triangle_node(s,t) + n2 = triangle_node(i4_wrap(s+1,1,3),t) + write ( *, '(2x,i4,2x,i4,2x,i4,2x,i4,2x,i4)' ) k, t, s, n1, n2 + end if + + end do + + if ( skip ) then + exit + end if + + end do + + return +end +subroutine vbedg ( x, y, node_num, node_xy, triangle_num, triangle_node, & + triangle_neighbor, ltri, ledg, rtri, redg ) + +!*****************************************************************************80 +! +!! VBEDG determines which boundary edges are visible to a point. +! +! Discussion: +! +! The point (X,Y) is assumed to be outside the convex hull of the +! region covered by the 2D triangulation. +! +! Modified: +! +! 25 August 2001 +! +! Author: +! +! Original FORTRAN77 version by Barry Joe. +! FORTRAN90 version by John Burkardt. +! +! Reference: +! +! Barry Joe, +! GEOMPACK - a software package for the generation of meshes +! using geometric algorithms, +! Advances in Engineering Software, +! Volume 13, pages 325-331, 1991. +! +! Parameters: +! +! Input, real ( kind = 8 ) X, Y, the coordinates of a point outside the +! convex hull of the current triangulation. +! +! Input, integer ( kind = 4 ) NODE_NUM, the number of points. +! +! Input, real ( kind = 8 ) NODE_XY(2,NODE_NUM), the coordinates of the +! vertices. +! +! Input, integer ( kind = 4 ) TRIANGLE_NUM, the number of triangles. +! +! Input, integer ( kind = 4 ) TRIANGLE_NODE(3,TRIANGLE_NUM), the +! triangle incidence list. +! +! Input, integer ( kind = 4 ) TRIANGLE_NEIGHBOR(3,TRIANGLE_NUM), the +! triangle neighbor list; negative values are used for links of a +! counterclockwise linked list of boundary edges; +! LINK = -(3*I + J-1) where I, J = triangle, edge index. +! +! Input/output, integer ( kind = 4 ) LTRI, LEDG. If LTRI /= 0 then these +! values are assumed to be already computed and are not changed, else they +! are updated. On output, LTRI is the index of boundary triangle to the +! left of the leftmost boundary triangle visible from (X,Y), and LEDG is +! the boundary edge of triangle LTRI to the left of the leftmost boundary +! edge visible from (X,Y). 1 <= LEDG <= 3. +! +! Input/output, integer ( kind = 4 ) RTRI. On input, the index of the +! boundary triangle to begin the search at. On output, the index of the +! rightmost boundary triangle visible from (X,Y). +! +! Input/output, integer ( kind = 4 ) REDG, the edge of triangle RTRI that +! is visible from (X,Y). 1 <= REDG <= 3. +! + implicit none + + integer ( kind = 4 ), parameter :: dim_num = 2 + integer ( kind = 4 ) node_num + integer ( kind = 4 ) triangle_num + + integer ( kind = 4 ) a + integer ( kind = 4 ) b + integer ( kind = 4 ) e + integer ( kind = 4 ) i4_wrap + integer ( kind = 4 ) l + logical ldone + integer ( kind = 4 ) ledg + integer ( kind = 4 ) lr + integer ( kind = 4 ) lrline + integer ( kind = 4 ) ltri + real ( kind = 8 ) node_xy(2,node_num) + integer ( kind = 4 ) redg + integer ( kind = 4 ) rtri + integer ( kind = 4 ) t + integer ( kind = 4 ) triangle_neighbor(3,triangle_num) + integer ( kind = 4 ) triangle_node(3,triangle_num) + real ( kind = 8 ) x + real ( kind = 8 ) y +! +! Find the rightmost visible boundary edge using links, then possibly +! leftmost visible boundary edge using triangle neighbor information. +! + if ( ltri == 0 ) then + ldone = .false. + ltri = rtri + ledg = redg + else + ldone = .true. + end if + + do + + l = -triangle_neighbor(redg,rtri) + t = l / 3 + e = mod ( l, 3 ) + 1 + a = triangle_node(e,t) + + if ( e <= 2 ) then + b = triangle_node(e+1,t) + else + b = triangle_node(1,t) + end if + + lr = lrline ( x, y, node_xy(1,a), node_xy(2,a), node_xy(1,b), & + node_xy(2,b), 0.0D+00 ) + + if ( lr <= 0 ) then + exit + end if + + rtri = t + redg = e + + end do + + if ( ldone ) then + return + end if + + t = ltri + e = ledg + + do + + b = triangle_node(e,t) + e = i4_wrap ( e-1, 1, 3 ) + + do while ( 0 < triangle_neighbor(e,t) ) + + t = triangle_neighbor(e,t) + + if ( triangle_node(1,t) == b ) then + e = 3 + else if ( triangle_node(2,t) == b ) then + e = 1 + else + e = 2 + end if + + end do + + a = triangle_node(e,t) + + lr = lrline ( x, y, node_xy(1,a), node_xy(2,a), node_xy(1,b), & + node_xy(2,b), 0.0D+00 ) + + if ( lr <= 0 ) then + exit + end if + + end do + + ltri = t + ledg = e + + return +end diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/utils_topo/make_topo.py b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/utils_topo/make_topo.py new file mode 100755 index 000000000..ef9f29dd5 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/utils_topo/make_topo.py @@ -0,0 +1,386 @@ +#!/usr/bin/env python3 +# +# run as ./make_topo.py +# +# NOTE run time setups: +# c180, c360, c720, c1080, c1440, c2880, c1536, c1120, c2160 all need 1 node : 1h +# c5760, c540, c270 and c48 require 2 nodes : 4h +# c90 1 node : 3h +# c24 2 nodes : 8h +# c12 2 nodes : 19h - has to be run with qos=long +# +import os +import subprocess +import shlex +import questionary +import pathlib + +#Bigger smoothing_scale ⇒ stronger smoothing ⇒ smaller GWD (less roughness). +smoothmap ={ +# # uniform + 'C12' : 512.0, + 'C24' : 305.0, + 'C48' : 166.0, + 'C90' : 96.2, + 'C180' : 51.21, + 'C360' : 28.95, + 'C720' : 19.5, + 'C1120': 8.26, + 'C1440': 12.0, + 'C2880': 3.285, + 'C5760': 3.0, +# # stretched (SG001/SG002) + 'C270' : 100.0, + 'C540' : 53.3, + 'C1080': 17.0, + 'C1536': 26.8, + 'C2160': 2.98 + } +## Tuning parameter for GWD amplitude for stretched grids this affects step in laplacian iterations. +alpha ={ 'C270' : 2.9, + 'C540' : 2.73, + 'C1080': 7.0, + 'C1536': 12.1, + 'C2160': 14.25, + # regular grids do not use alpha!!! + } + +def get_script_topo(answers) : + head = """#!/bin/csh -x + +#SBATCH --output=topo.log +#SBATCH --error=topo.err +#SBATCH --account={account} +#SBATCH --time=1:00:00 +#SBATCH --nodes=1 +#SBATCH --job-name=topo_{res_tag}.j +""" + + constraint = '#SBATCH --constraint="[mil]"' + + if len(answers['resolutions']) == 1: + res_tag = answers['resolutions'][0].lower() + else: + res_tag = "_".join(r.lower() for r in answers['resolutions']) + + topo_template = head + constraint + """ + +echo "-----------------------------" +echo "make_topo starts date/time" +echo `date` +echo "-----------------------------" + +if( ! -d bin ) then + /bin/ln -s {bin_dir} +endif + +source bin/g5_modules +module load nco +module load cdo + +if ( ! -e landm_coslat.nc ) then + /bin/ln -s bin/landm_coslat.nc landm_coslat.nc +endif + +set source_topo = gmted_intel +set smooths = {SMOOTHMAP} +set resolutions = {RESOLUTIONS} +set SG001 = ( 270 540 1080 2160 ) +set SG002 = ( 1536 ) + +# Generate a single high-resolution intermediate cube (3000) for ALL resolutions +if ( ! -e c3000.gmted_fixedanarticasuperior.nc ) then +cat << _EOF_ > bin_to_cube.nl +&binparams + raw_latlon_data_file='{raw_latlon_data}' + output_file='c3000.gmted_fixedanarticasuperior.nc' + ncube=3000 +/ +_EOF_ + bin/bin_to_cube.x +else + echo "Reusing existing c3000.gmted_fixedanarticasuperior.nc" +endif + +# Use the same intermediate for all resolutions +set intermediate_cube = c3000.gmted_fixedanarticasuperior.nc +if ( ! -e $intermediate_cube ) then + echo "ERROR: Missing $intermediate_cube after generation"; exit 2 +endif + +@ count = 1 +foreach im ($resolutions) + @ jm = ($im * 6) + set output_dir = output_${{im}} + + if ( ! -e $output_dir ) then + mkdir $output_dir + endif + set alpha = "" + set ALPHALINE = "" + + set DO_SCHMIDT = '' + set TARGET_LON = '' + set TARGET_LAT = '' + set STRETCH_FACTOR = '' + set grid_type = '' + + foreach sg1 ($SG001) + if ($im == $sg1) then + set DO_SCHMIDT = 'DO_SCHMIDT: true' + set TARGET_LON = 'TARGET_LON: -98.35 ' + set TARGET_LAT = 'TARGET_LAT: 39.5 ' + set STRETCH_FACTOR = 'STRETCH_FACTOR: 2.5 ' + set grid_type = sg001 + endif + end + + foreach sg2 ($SG002) + if ($im == $sg2) then + set DO_SCHMIDT = 'DO_SCHMIDT: true' + set TARGET_LON = 'TARGET_LON: -98.35' + set TARGET_LAT = 'TARGET_LAT: 39.5' + set STRETCH_FACTOR = 'STRETCH_FACTOR: 3.0' + set grid_type = sg002 + endif + end + + set config_file = GenScrip.yaml + set output_grid = PE${{im}}x${{jm}}-CF + set scriptfile = ${{output_grid}}.nc4 + set smoothing_scale = ${{smooths[$count]}} + + if ( $im == 5760 ) then + set extra_cli = "-l 13" # run the Laplacian for 13 cycles + else + set extra_cli = "" + endif + + # fill alpha only for stretched cases (injected switch from Python) + {alpha_switch} + + # after your alpha_switch and smoothing_scale logic + if ( "$alpha" == "" ) then + set ALPHALINE = '' + else + set ALPHALINE = "ALPHA: $alpha" + endif + +cat << _EOF_ > ${{config_file}} +CUBE_DIM: $im +output_scrip: ${{scriptfile}} +output_geos: c${{im}}_coords.nc4 +${{DO_SCHMIDT}} +${{TARGET_LON}} +${{TARGET_LAT}} +${{STRETCH_FACTOR}} +${{ALPHALINE}} +_EOF_ + + cat ${{config_file}} + mpirun -np 6 bin/generate_scrip_cube_topo.x + + # --- Add error-checking here --- + if ( $status != 0 ) then + echo "ERROR: generate_scrip_cube_topo.x failed (exit $status)" + exit 1 + endif + if ( ! -e ${{scriptfile}} ) then + echo "ERROR: descriptor ${{scriptfile}} not created" + exit 1 + endif + + echo "IM=$im -> using intermediate: $intermediate_cube" + + #-------------------------------------------------------- + # Build jmax/rrfac flags + #-------------------------------------------------------- + + # --- rrfac_max = ceil( max(rrfac) ) ------------------ + set rr = `cdo -s infon $scriptfile | \ + awk '/rrfac/ {{v=$(NF-2); printf("%d",(v>int(v)?int(v)+1:int(v)));}}'` + if ( "$rr" != "" ) then + set rrfac = "--rrfac_max=$rr" + else + set rrfac = "--rrfac_max=1" + endif + + bin/cube_to_target.x \ + --grid_descriptor_file=$scriptfile \ + --intermediate_cs_name=$intermediate_cube \ + --output_data_directory=$output_dir \ + --smoothing_scale=$smoothing_scale \ + --name_email_of_creator=gmao \ + --fine_radius=0 \ + --output_grid=$output_grid \ + --source_data_identifier=$source_topo \ + $rrfac $extra_cli + + # Safety check after cube_to_target.x + if ( $status != 0 ) then + echo "ERROR: cube_to_target.x failed (exit $status). Check stdout above." + exit 1 + endif + + ls $output_dir/*.nc >& /dev/null + if ( $status != 0 ) then + echo "ERROR: cube_to_target.x returned 0, but wrote no *.nc files." + exit 1 + endif + + + #rm $scriptfile + rm ${{config_file}} + + # convert to gmao + cd $output_dir + + # choose exactly the PE* file (ignore any topo_smooth*.nc written by -z) + set pe = `ls -1t PE${{im}}x${{jm}}*.nc | head -1` + if ( "$pe" == "" ) then + echo "ERROR: no PE file found for IM=$im JM=$jm" + exit 1 + endif + + if ( "$grid_type" != "" ) then + ../bin/scrip_to_restart_topo.py -i $pe -o gwd_internal_rst -g $grid_type + else + ../bin/scrip_to_restart_topo.py -i $pe -o gwd_internal_rst + endif + + ../bin/convert_to_gmao_output_topo.x -i $pe --im $im + cd .. + @ count = $count + 1 +end +""" + account = get_account() + SMOOTHMAP = '( ' + RESOLUTIONS = '( ' + for res in answers['resolutions']: + SMOOTHMAP += str(smoothmap[res]) + ' ' + RESOLUTIONS += str(res)[1:] + ' ' + SMOOTHMAP = SMOOTHMAP + ' )' + RESOLUTIONS = RESOLUTIONS + ' )' + + # Explicit csh switch-case for alpha per resolution + alpha_switch = "switch ($im)\n" + for res in answers['resolutions']: + numeric_res = res[1:] # Remove leading "C" + if res in alpha: + alpha_switch += f" case {numeric_res}:\n" + alpha_switch += f" set alpha = {alpha[res]}\n" + alpha_switch += " breaksw\n" + alpha_switch += " default:\n" + alpha_switch += " set alpha = ''\n" + alpha_switch += "endsw\n" + + + script_string = topo_template.format(\ + account = account, \ + bin_dir = answers['bin_dir'], \ + raw_latlon_data = answers['path_latlon']+ "/gmted_fixed_anartica_superior_caspian.nc4", \ + SMOOTHMAP = SMOOTHMAP, \ + alpha_switch = alpha_switch, \ + RESOLUTIONS = RESOLUTIONS, \ + res_tag = res_tag ) + out_dir = answers['out_dir'] + pathlib.Path(out_dir).mkdir(parents=True, exist_ok=True) + if len(answers['resolutions']) == 1: + res_tag = answers['resolutions'][0].lower() + else: + res_tag = "_".join(r.lower() for r in answers['resolutions']) + + topojob = f"{out_dir}/topo_{res_tag}.j" + + topo_job = open(topojob,'wt') + topo_job.write(script_string) + topo_job.close() + subprocess.call(['chmod', '755', topojob]) + + print(f"\nJob script {os.path.basename(topojob)} has been generated in {out_dir}\n") + + +def get_user(): + cmd = 'whoami' + p = subprocess.Popen(shlex.split(cmd), stdout=subprocess.PIPE) + (user, err) = p.communicate() + p_status = p.wait() + user = user.decode().split() + return user[0] + +def get_account(): + cmd = 'id -gn' + p = subprocess.Popen(shlex.split(cmd), stdout=subprocess.PIPE) + (accounts, err) = p.communicate() + p_status = p.wait() + accounts = accounts.decode().split() + return accounts[0] + +def ask_questions(): + + # See remap_utils.py for definitions of "choices", "message" strings, and "validate" lists + # that are used multiple times. + user_name = get_user() + + questions = [ + { + "type": "path", + "name": "bin_dir", + "message": "Enter the root path of the bin:\n", + "default": "./" + }, + + { + "type": "path", + "name": "out_dir", + "message": "Enter the path of the output directory:\n", + "default": "/discover/nobackup/"+user_name+"/BCS_TOPO/" + }, + + { + "type": "path", + "name": "path_latlon", + "message": "Enter the path contains gmted_fixed_anartica_superior_caspian.nc4 :\n", + "default": "/discover/nobackup/projects/gmao/bcs_shared/preprocessing_bcs_inputs/land/topo/v1/" + }, + + + { + "type": "checkbox", + "name": "resolutions", + "message": "Select resolutions: \n", + "choices": ["C12","C24", "C48", "C90", "C180", "C360", "C720", "C1120", "C1440", "C2880", "C5760", "SG001","SG002"] + }, + + { + "type": "checkbox", + "name": "SG001", + "message": "Select resolution of SG001 grid: \n", + "choices": ['C270', 'C540', 'C1080', 'C2160'], + "when": lambda x : 'SG001' in x.get('resolutions'), + }, + { + "type": "checkbox", + "name": "SG002", + "message": "Select resolution of SG002 grid: \n", + "choices": ['C1536'], + "when": lambda x : 'SG002' in x.get('resolutions'), + }, + + ] + answers = questionary.prompt(questions) + answers['bin_dir'] = os.path.abspath(answers['bin_dir']) + if 'SG001' in answers: + answers['resolutions'].remove('SG001') + answers['resolutions'] = answers['resolutions'] + answers['SG001'] + if 'SG002' in answers: + answers['resolutions'].remove('SG002') + answers['resolutions'] = answers['resolutions'] + answers['SG002'] + print(answers['resolutions']) + return answers + + +if __name__ == '__main__' : + + answers = ask_questions() + get_script_topo(answers) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/utils_topo/scrip_to_cube_topo.py b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/utils_topo/scrip_to_cube_topo.py new file mode 100755 index 000000000..9608a1456 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/utils_topo/scrip_to_cube_topo.py @@ -0,0 +1,131 @@ +#!/usr/bin/env python3 + +#------------- +# Load modules +#------------- +from netCDF4 import Dataset +import numpy +import argparse + +def parse_args(): + p = argparse.ArgumentParser(description='convert old style cube to new style cube input') + p.add_argument('-i','--input',type=str,help='input file',default=None) + p.add_argument('-e','--example',type=str,help='example file',default=None) + p.add_argument('-o','--output',type=str,help='output file',default=None) + p.add_argument('-v','--vars',type=str,help='output only these',default=None,nargs='+') + return vars(p.parse_args()) + +#------------------ +# Opening the file +#------------------ +comm_args = parse_args() +Input_file = comm_args['input'] +Output_file = comm_args['output'] +Example_file = comm_args['example'] +only_vars = comm_args['vars'] + +ncFid = Dataset(Input_file, mode='r') +ncFidEx = Dataset(Example_file, mode='r') +ncFidOut = Dataset(Output_file, mode='w', format='NETCDF4') + +#--------------------- +# Extracting variables +#--------------------- + +ntiles = len(ncFid.dimensions['ncol']) +haveRdg = False +for dim in ncFid.dimensions: + if dim == 'nrdg': + haveRdg = True + rdgSize = len(ncFid.dimensions['nrdg']) + + +cRes = len(ncFidEx.dimensions['Xdim']) + +Xdim = ncFidOut.createDimension('Xdim',cRes) +Ydim = ncFidOut.createDimension('Ydim',cRes) +nf = ncFidOut.createDimension('nf',6) +ncontact = ncFidOut.createDimension('contact',4) + +if haveRdg: + rdgOut = ncFidOut.createDimension('nrdg',rdgSize) + +vXdim = ncFidOut.createVariable('Xdim','f8',('Xdim')) +vYdim = ncFidOut.createVariable('Ydim','f8',('Ydim')) +setattr(ncFidOut.variables['Xdim'],'units','degrees_east') +setattr(ncFidOut.variables['Ydim'],'units','degrees_north') +setattr(ncFidOut.variables['Xdim'],'long_name','Fake Longitude for GrADS Compatibility') +setattr(ncFidOut.variables['Ydim'],'long_name','Fake Latitude for GrADS Compatibility') +vXdim[:]=range(1,cRes+1) +vYdim[:]=range(1,cRes+1) +vnf = ncFidOut.createVariable('nf','i4',('nf')) +vnf[:]=range(1,7) +setattr(ncFidOut.variables['nf'],'long_name','cubed-sphere face') +setattr(ncFidOut.variables['nf'],'axis','e') +setattr(ncFidOut.variables['nf'],'grads_dim','e') + +vchar = ncFidOut.createVariable('cubed_sphere','S1') +setattr(ncFidOut.variables['cubed_sphere'],'grid_mapping_name','gnomonic cubed-sphere') +setattr(ncFidOut.variables['cubed_sphere'],'file_format_version','2.90') +setattr(ncFidOut.variables['cubed_sphere'],'additional_vars','contacts,orientation,anchor') + +temp1d = numpy.zeros([6,cRes,cRes]) +if haveRdg: + temp2d = numpy.zeros([rdgSize,6,cRes,cRes]) + +if only_vars == None: + only_vars = ncFid.variables + +for var in only_vars: + temp = ncFid.variables[var][:] + dim_size =len(temp.shape) + + if dim_size == 2: + tout = ncFidOut.createVariable(var,'f8',('nrdg','nf','Ydim','Xdim'),fill_value=1.0e15) + for att in ncFid.variables[var].ncattrs(): + if att != "_FillValue": + setattr(ncFidOut.variables[var],att,getattr(ncFid.variables[var],att)) + setattr(ncFidOut.variables[var],'grid_mapping','cubed_sphere') + setattr(ncFidOut.variables[var],'coordinates','lons lats') + temp2d = numpy.reshape(temp,[rdgSize,6,cRes,cRes]) + tout[:,::,:] = temp2d[:,:,:,:] + + elif dim_size == 1: + tout = ncFidOut.createVariable(var,'f8',('nf','Ydim','Xdim'),fill_value=1.0e15) + for att in ncFid.variables[var].ncattrs(): + if att != "_FillValue": + setattr(ncFidOut.variables[var],att,getattr(ncFid.variables[var],att)) + setattr(ncFidOut.variables[var],'grid_mapping','cubed_sphere') + setattr(ncFidOut.variables[var],'coordinates','lons lats') + temp1d = numpy.reshape(temp,[6,cRes,cRes]) + tout[:,:,:] = temp1d[:,:,:] + +XCdim = ncFidOut.createDimension('XCdim',cRes+1) +YCdim = ncFidOut.createDimension('YCdim',cRes+1) +center_lons = ncFidOut.createVariable('lons','f8',('nf','Ydim','Xdim')) +setattr(ncFidOut.variables['lons'],'long_name','longitude') +setattr(ncFidOut.variables['lons'],'units','degrees_east') +center_lats = ncFidOut.createVariable('lats','f8',('nf','Ydim','Xdim')) +setattr(ncFidOut.variables['lats'],'long_name','latitude') +setattr(ncFidOut.variables['lats'],'units','degrees_north') + +center_lons[:,:,:] = ncFidEx.variables['lons'][:,:,:] +center_lats[:,:,:] = ncFidEx.variables['lats'][:,:,:] + + +corner_lons = ncFidOut.createVariable('corner_lons','f8',('nf','YCdim','XCdim')) +setattr(ncFidOut.variables['corner_lons'],'long_name','longitude') +setattr(ncFidOut.variables['corner_lons'],'units','degrees_east') +corner_lats = ncFidOut.createVariable('corner_lats','f8',('nf','YCdim','XCdim')) +setattr(ncFidOut.variables['corner_lats'],'long_name','latitude') +setattr(ncFidOut.variables['corner_lats'],'units','degrees_north') + +corner_lons[:,:,:] = ncFidEx.variables['corner_lons'][:,:,:] +corner_lats[:,:,:] = ncFidEx.variables['corner_lats'][:,:,:] +#----------------- +# Closing the file +#----------------- +ncFidEx.close() +ncFidOut.close() +ncFid.close() + diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/utils_topo/scrip_to_restart_topo.py b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/utils_topo/scrip_to_restart_topo.py new file mode 100755 index 000000000..351a62039 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/utils_topo/scrip_to_restart_topo.py @@ -0,0 +1,99 @@ +#!/usr/bin/env python3 + +#------------- +# Load modules +#------------- +from netCDF4 import Dataset +import numpy +import argparse +import math + +def parse_args(): + p = argparse.ArgumentParser(description='convert old style cube to new style cube input') + p.add_argument('-i','--input',type=str,help='input file',default=None) + p.add_argument('-o','--output',type=str,help='output file',default=None) + p.add_argument('-g','--grid',type=str,help='grid identifier (e.g., sg001, sg002)',default=None) + return vars(p.parse_args()) + +#------------------ +# Opening the file +#------------------ +comm_args = parse_args() +Input_file = comm_args['input'] +Output_file = comm_args['output'] + +ncFid = Dataset(Input_file, mode='r') +ncFidOut = Dataset(Output_file, mode='w', format='NETCDF4') + +grid_type = comm_args['grid'] + +if grid_type == 'sg001': + ncFidOut.STRETCH_FACTOR = 2.5 + ncFidOut.TARGET_LAT = 39.5 + ncFidOut.TARGET_LON = -98.35 +elif grid_type == 'sg002': + ncFidOut.STRETCH_FACTOR = 3.0 + ncFidOut.TARGET_LAT = 39.5 + ncFidOut.TARGET_LON = -98.35 + +#--------------------- +# Extracting variables +#--------------------- + +ntiles = len(ncFid.dimensions['ncol']) +haveRdg = False +for dim in ncFid.dimensions: + if dim == 'nrdg': + haveRdg = True + rdgSize = len(ncFid.dimensions['nrdg']) + + +cRes = ntiles/6 +cRes = int(math.sqrt(cRes)) + +Xdim = ncFidOut.createDimension('lon',cRes) +Ydim = ncFidOut.createDimension('lat',cRes*6) + +if haveRdg: + rdgOut = ncFidOut.createDimension('unknown_dim1',rdgSize) + +vXdim = ncFidOut.createVariable('lon','f8',('lon')) +vYdim = ncFidOut.createVariable('lat','f8',('lat')) +setattr(ncFidOut.variables['lon'],'units','degrees_east') +setattr(ncFidOut.variables['lat'],'units','degrees_north') +setattr(ncFidOut.variables['lon'],'long_name','Longitude') +setattr(ncFidOut.variables['lat'],'long_name','Latitude') +vXdim[:]=range(1,cRes+1) +vYdim[:]=range(1,(6*cRes)+1) + +temp1d = numpy.zeros([6*cRes,cRes]) +if haveRdg: + temp2d = numpy.zeros([rdgSize,6*cRes,cRes]) + +exclude = ['lon','lat'] +for var in ncFid.variables: + if var not in exclude: + temp = ncFid.variables[var][:] + dim_size =len(temp.shape) + + if dim_size == 2: + tout = ncFidOut.createVariable(var,'f8',('unknown_dim1','lat','lon'),fill_value=1.0e15) + for att in ncFid.variables[var].ncattrs(): + if att != "_FillValue": + setattr(ncFidOut.variables[var],att,getattr(ncFid.variables[var],att)) + temp2d = numpy.reshape(temp,[rdgSize,cRes*6,cRes]) + tout[:,:,:] = temp2d[:,:,:] + + elif dim_size == 1: + tout = ncFidOut.createVariable(var,'f8',('lat','lon'),fill_value=1.0e15) + for att in ncFid.variables[var].ncattrs(): + if att != "_FillValue": + setattr(ncFidOut.variables[var],att,getattr(ncFid.variables[var],att)) + temp1d = numpy.reshape(temp,[cRes*6,cRes]) + tout[:,:] = temp1d[:,:] +#----------------- +# Closing the file +#---------------- +ncFidOut.close() +ncFid.close() + diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentRst.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentRst.F90 index 3af5915f7..e0cf3f7bf 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentRst.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentRst.F90 @@ -577,7 +577,7 @@ subroutine add_bcs_to_rst(this, surflay, DataDir, rc) call MAPL_VarRead ( CatchFmt ,'SNOWALB', this%snowalb, __RC__) if ( .not. this%meta%has_variable('SNOWALB')) then var = Variable(type=pFIO_REAL32, dimensions='tile') - call var%add_attribute('long_name', 'snow_albedo') + call var%add_attribute('long_name', 'snow_reflectivity') call var%add_attribute('units', '1') call this%meta%add_variable('SNOWALB', var) endif @@ -807,10 +807,10 @@ subroutine re_tile(this, InTileFile, OutBcsDir, OutTileFile, surflay, rc) if (root_proc) then allocate (long (out_ntiles)) allocate (latg (out_ntiles)) - call ReadTileFile_RealLatLon ( OutTileFile, n, long, latg) + call ReadTileFile_RealLatLon ( OutTileFile, n, xlon=long, xlat=latg) _ASSERT( n == out_ntiles, "Out tile number should match") this%latg = latg - call ReadTileFile_RealLatLon ( InTileFile, n, lonc, latc) + call ReadTileFile_RealLatLon ( InTileFile, n, xlon=lonc, xlat=latc) _ASSERT( n == in_ntiles, "In tile number should match") endif diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/SaltImpConverter.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/SaltImpConverter.F90 index 6a6df0672..39976ff86 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/SaltImpConverter.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/SaltImpConverter.F90 @@ -6,7 +6,7 @@ program SaltImpConverter use MAPL_ConstantsMod,only: MAPL_PI, MAPL_radius use netcdf use MAPL - use mk_restarts_getidsMod, only: ReadTileFile_IntLatLon + use mk_restarts_getidsMod, only: ReadTileFile_RealLatLon use gFTL_StringVector implicit none @@ -18,8 +18,6 @@ program SaltImpConverter character*256 :: arg integer :: i, rc, jc, iostat, iargc, n, mask,j,k,otiles,nsubtiles,l,itiles,nwords - integer, pointer :: Lono(:), Lato(:), Id(:), Pf(:) - integer, pointer :: Loni(:), Lati(:) real, allocatable :: varIn(:),varOut(:) real, allocatable :: TW(:),SW(:) real*8, allocatable :: varInR8(:),varOutR8(:) @@ -113,13 +111,7 @@ program SaltImpConverter ! Read Output Tile File .til file ! to get the index into the pfafsttater table - call ReadTileFile_IntLatLon(InTileFile ,Pf,Id,loni,lati,zoom, 0) - deallocate(Pf,Id) - - nullify(Pf) - nullify(Id) - - itiles = size(loni) ! Input Tile Size + call ReadTileFile_RealLatLon(InTileFile , itiles, mask = 0) allocate( varIn(itiles) ) allocate( varOut(itiles) ) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/SaltIntSplitter.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/SaltIntSplitter.F90 index 16eab40d7..5ea5824ed 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/SaltIntSplitter.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/SaltIntSplitter.F90 @@ -5,7 +5,7 @@ program SaltIntSplitter use MAPL_ConstantsMod,only: MAPL_PI, MAPL_radius use netcdf use MAPL - use mk_restarts_getidsMod, only: ReadTileFile_IntLatLon + use mk_restarts_getidsMod, only: ReadTileFile_RealLatLon use gFTL_StringVector use gFTL_StringIntegerMap @@ -17,8 +17,6 @@ program SaltIntSplitter character*256 :: arg integer :: i, rc, jc, iostat, iargc, n, mask,j,k,otiles,nsubtiles,l,itiles,nwords - integer, pointer :: Lono(:), Lato(:), Id(:), Pf(:) - integer, pointer :: Loni(:), Lati(:) real, allocatable :: varIn(:),varOut(:) real*8, allocatable :: varInR8(:),varOutR8(:) real, allocatable :: var2(:,:) @@ -66,16 +64,8 @@ program SaltIntSplitter call getarg(1,InTileFile) call getarg(2,InRestart) -! Read Output Tile File .til file -! to get the index into the pfafsttater table - call ReadTileFile_IntLatLon(InTileFile ,Pf,Id,loni,lati,zoom,0) - deallocate(Pf,Id) - - nullify(Pf) - nullify(Id) - - itiles = size(loni) ! Input Tile Size + call ReadTileFile_RealLatLon(InTileFile, itiles, mask=0) allocate( varIn(itiles), source = 0. ) allocate( varOut(itiles), source = 0. ) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/getids.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/getids.F90 index 9212dc919..814ed551d 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/getids.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/getids.F90 @@ -18,7 +18,7 @@ module mk_restarts_getidsMod contains - subroutine ReadTileFile_IntLatLon(Tf,Pf,Id,lon,lat,zoom,mask) + subroutine ReadTileFile_IntLatLon(Tf, ntiles, zoom, lon_int, lat_int, mask) ! Read *.til tile definition file, return integer lat/lon for fast but inaccurate processing. ! Can handle "old" format of *.til files, but that is probably obsolete as of March 2020 and @@ -27,77 +27,32 @@ subroutine ReadTileFile_IntLatLon(Tf,Pf,Id,lon,lat,zoom,mask) ! that is read into "Pf" depends on whether the file is for EASE or cube-sphere grid tiles! ! - reichle, 4 Mar 2020 - character*(*), intent(IN) :: Tf - integer, pointer :: Pf(:), Id(:), lon(:), lat(:) - integer, intent(in) :: zoom + character*(*), intent(IN) :: Tf + integer, intent(out) :: ntiles + integer, intent(in) :: zoom + integer, pointer, optional :: lon_int(:), lat_int(:) integer, optional, intent(IN) :: mask - - integer, allocatable :: Pf1(:), Id1(:), ln1(:), lt1(:) - integer :: k, i, nt, pfs, ids,n,msk, umask + + real, pointer :: xlon(:), xlat(:) + real :: dum(4),dum1,lnn,ltt integer :: de, ce, st - logical :: old - de=180*zoom - ce=360*zoom - st=2*zoom - if(present(mask)) then - umask = mask + + if (present(lon_int) .and. present(lat_int)) then + de=180*zoom + ce=360*zoom + call ReadTileFile_RealLatLon(Tf, ntiles, xlon=xlon, xlat=xlat, mask=mask) + allocate(lon_int(ntiles), lat_int(ntiles)) + lon_int = nint(xlon*zoom) + lat_int = max(min(nint(xlat*zoom),90*zoom),-90*zoom) + where(lon_int<-de) lon_int = lon_int + ce + where(lon_int> de) lon_int = lon_int - ce + deallocate(xlon, xlat) else - umask = 100 + call ReadTileFile_RealLatLon(Tf, ntiles, mask=mask) endif - - print *, "Reading tilefile ",trim(Tf) - - open(unit=20,file=trim(Tf),form='formatted') - - read(20,*,iostat=n) Nt,i,k - old=n<0 - close(20) - - open(unit=20,file=trim(Tf),form='formatted') - - read(20,*) Nt - - do i=1,7 - read(20,*) - enddo - - allocate(Pf1(Nt),Id1(Nt),ln1(Nt),lt1(Nt)) - - n=0 - do i=1,Nt - if(old) then - read(20,*,end=200) msk, Pfs, lnn, ltt - ids = 0 - else - read(20,*,end=200) msk, dum1, lnn, ltt, dum, Pfs, Ids - end if - if(msk/=umask) cycle - n = n+1 - pf1(n) = pfs - Id1(n) = ids - ln1(n) = nint(lnn*zoom) - Lt1(n)=max(min(nint(ltt*zoom),90*zoom),-90*zoom) - if(ln1(n)<-de) ln1(n) = ln1(n) + ce - if(ln1(n)> de) ln1(n) = ln1(n) - ce - enddo - - 200 continue - - close(20) - - Nt=n - print *, "Found ",nt," land tiles." - - allocate(Pf(Nt),Id(Nt),lon(Nt),lat(Nt)) - Pf = Pf1(:Nt) - Id = Id1(:Nt) - lon = ln1(:Nt) - lat = lt1(:Nt) - deallocate(Pf1,Id1,ln1,lt1) - - return + end subroutine ReadTileFile_IntLatLon subroutine GetStencil(ii,jj,st) @@ -535,69 +490,99 @@ real function haversine(deglat1,deglon1,deglat2,deglon2) ! ***************************************************************************** - subroutine ReadTileFile_RealLatLon (InCNTileFile, ntiles, xlon, xlat,mask) + subroutine ReadTileFile_RealLatLon (InCNTileFile, ntiles, xlon, xlat, mask) ! read *.til tile definition file, return *real* lat/lon for slow but accurate processing implicit none character(*), intent (in) :: InCNTileFile - integer , intent (inout) :: ntiles - real, pointer, dimension (:) :: xlon, xlat + integer , intent (out) :: ntiles + real, pointer, optional, dimension (:) :: xlon, xlat integer, optional, intent(IN) :: mask integer :: n,icnt,ityp, nt, umask, i, header real :: xval,yval, pf - real, allocatable :: ln1(:), lt1(:) - - if(present(mask)) then - umask = mask - else - umask = 100 - endif - - open(11,file=InCNTileFile, & - form='formatted',action='read',status='old') + real, allocatable :: ln1(:), lt1(:) + real, pointer :: AVR(:,:) + integer :: filetype, k + integer, allocatable :: indices(:), indices_tmp(:) + logical :: isNC4 + + if(present(mask)) then + umask = mask + else + umask = 100 + endif + + call MAPL_NCIOGetFileType(InCNTileFile, filetype) + isNC4 = (filetype == MAPL_FILETYPE_NC4) + + if (isNC4) then + call MAPL_ReadTilingNC4(InCNTileFile, AVR=AVR) + allocate(indices_tmp(size(AVR,1))) + k = 0 + do i = 1, size(AVR,1) + if( int(AVR(i,1)) == umask) then + k = k+1 + indices_tmp(k) = i + endif + enddo + indices = indices_tmp(1:k) + Ntiles = k + if ( present(xlon) .and. present(xlat)) then + if(.not.associated (xlon)) allocate(xlon(Ntiles)) + if(.not.associated (xlat)) allocate(xlat(Ntiles)) + xlon = AVR(indices, 3) + xlat = AVR(indices, 4) + endif + deallocate(AVR) + else - ! first read number of lines in the til file header - ! ------------------------------------------------- - header = 5 - read (11,*, iostat=n) Nt - do i = 1, header -1 - read (11,*) - end do - read (11,*,IOSTAT=n)ityp,pf,xval, yval - if(n /= 0) header = 8 + open(11,file=InCNTileFile, form='formatted',action='read',status='old') - rewind (11) + ! first read number of lines in the til file header + ! ------------------------------------------------- + header = 5 + read (11,*, iostat=n) Nt + do i = 1, header -1 + read (11,*) + end do + read (11,*,IOSTAT=n)ityp,pf,xval, yval + if(n /= 0) header = 8 - ! read the tile file - !------------------- - read (11,*, iostat=n) Nt + rewind (11) + + ! read the tile file + !------------------- + read (11,*, iostat=n) Nt - allocate(ln1(Nt),lt1(Nt)) + allocate(ln1(Nt),lt1(Nt)) - do n = 1,header-1 ! skip header - read(11,*) - end do + do n = 1,header-1 ! skip header + read(11,*) + end do - icnt = 0 - - do i=1,Nt - read(11,*) ityp,pf,xval,yval - if(ityp == umask) then - icnt = icnt + 1 - ln1(icnt) = xval - Lt1(icnt) = yval - endif - end do - - close(11) - - Ntiles = icnt - if(.not.associated (xlon)) allocate(xlon(Ntiles)) - if(.not.associated (xlat)) allocate(xlat(Ntiles)) - xlon = ln1(:Ntiles) - xlat = lt1(:Ntiles) - + icnt = 0 + + do i=1,Nt + read(11,*) ityp,pf,xval,yval + if(ityp == umask) then + icnt = icnt + 1 + ln1(icnt) = xval + Lt1(icnt) = yval + endif + end do + + close(11) + + Ntiles = icnt + if ( present(xlon) .and. present(xlat)) then + if(.not.associated (xlon)) allocate(xlon(Ntiles)) + if(.not.associated (xlat)) allocate(xlat(Ntiles)) + xlon = ln1(:Ntiles) + xlat = lt1(:Ntiles) + endif + endif !isNC4 + end subroutine ReadTileFile_RealLatLon end module mk_restarts_getidsMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_CICERestart.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_CICERestart.F90 index a6deac791..71e1294cc 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_CICERestart.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_CICERestart.F90 @@ -15,8 +15,8 @@ program mk_CiceRestart character*128 :: InRestart character*128 :: arg - integer :: i, iargc, n,j,ntiles,k - integer, pointer :: Lono(:), Lato(:), Id(:), Pf(:) + integer :: i, iargc, n,j, otiles,k, itiles + integer, pointer :: Lono(:), Lato(:), Id(:) integer, pointer :: Loni(:), Lati(:) real*4, allocatable :: var4(:) real*8, allocatable :: var8(:) @@ -40,16 +40,8 @@ program mk_CiceRestart ! Read Output Tile File .til file ! to get the index into the pfafsttater table - call ReadTileFile_IntLatLon(OutTileFile,Pf,Id,lono,lato,zoom,0) - deallocate(Pf,Id) - - call ReadTileFile_IntLatLon(InTileFile ,Pf,Id,loni,lati,zoom,0) - deallocate(Pf,Id) - - nullify(Pf) - nullify(Id) - - ntiles = size(lono) + call ReadTileFile_IntLatLon(OutTileFile, otiles, zoom, lon_int=lono, lat_int=lato, mask = 0) + call ReadTileFile_IntLatLon(InTileFile, itiles, zoom, lon_int=loni, lat_int=lati, mask = 0) i = index(InRestart,'/',back=.true.) @@ -59,7 +51,7 @@ program mk_CiceRestart open(unit=50,FILE=InRestart,form='unformatted',& status='old',convert='little_endian') - allocate(var4(size(loni)),var8(size(loni))) + allocate(var4(itiles),var8(itiles)) do n=1,124 read (50) @@ -69,23 +61,23 @@ program mk_CiceRestart rewind 50 - allocate(Id (ntiles)) + allocate(Id (otiles)) call GetIds(loni,lati,lono,lato,zoom,Id) do n=1,18 read (50) var4(:) - write(40)(var4(id(i)),i=1,ntiles) + write(40)(var4(id(i)),i=1,otiles) end do do n=19,74 read (50) var8(:) - write(40)(var8(id(i)),i=1,ntiles) + write(40)(var8(id(i)),i=1,otiles) end do do n=75,125 read (50) var4(:) - write(40)(var4(id(i)),i=1,ntiles) + write(40)(var4(id(i)),i=1,otiles) end do deallocate(var4,var8) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_CatchCNRestarts.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_CatchCNRestarts.F90 index abf5e507e..e4ab880c8 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_CatchCNRestarts.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_CatchCNRestarts.F90 @@ -326,8 +326,8 @@ program mk_CatchCNRestarts MPI_PROC0 : if (root_proc) then ! Read Output/Input .til files - call ReadTileFile_RealLatLon(OutTileFile, ntiles, lono, lato) - call ReadTileFile_RealLatLon(InTileFile,ntiles_in,loni,lati) + call ReadTileFile_RealLatLon(OutTileFile, ntiles, xlon=lono, xlat=lato) + call ReadTileFile_RealLatLon(InTileFile,ntiles_in,xlon=loni, xlat=lati) allocate(Id (ntiles)) ! ------------------------------------------------ @@ -1154,7 +1154,7 @@ SUBROUTINE regrid_carbon_vars ( & allocate (latg (ntiles)) allocate (DAYX (NTILES)) - call ReadTileFile_RealLatLon (OutTileFile, i, long, latg) + call ReadTileFile_RealLatLon (OutTileFile, i, xlon=long, xlat=latg) !----------------------- ! COMPUTE DAYX @@ -1201,7 +1201,7 @@ SUBROUTINE regrid_carbon_vars ( & ! Read exact lonc, latc from offline .til File ! --------------------------------------------- - call ReadTileFile_RealLatLon(InCNTilFile,i,lonc,latc) + call ReadTileFile_RealLatLon(InCNTilFile,i,xlon=lonc,xlat=latc) endif @@ -1921,13 +1921,13 @@ SUBROUTINE regrid_hyd_vars (NTILES, OutFMT) allocate (latg (ntiles)) allocate (ld_reorder(ntiles_cn)) - call ReadTileFile_RealLatLon (OutTileFile, i, long, latg) + call ReadTileFile_RealLatLon (OutTileFile, i, xlon=long, xlat=latg) ! --------------------------------------------- ! Read exact lonc, latc from offline .til File ! --------------------------------------------- - call ReadTileFile_RealLatLon(trim(InCNTilFile), i,lonc,latc) + call ReadTileFile_RealLatLon(trim(InCNTilFile), i,xlon=lonc,xlat=latc) STATUS = NF_OPEN (trim(InCNRestart),NF_NOWRITE,NCFID) STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TILE_ID' ), (/1/), (/NTILES_CN/),tmp_var) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_CatchRestarts.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_CatchRestarts.F90 index 4e6b2d94f..26884ad03 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_CatchRestarts.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_CatchRestarts.F90 @@ -75,8 +75,8 @@ program mk_CatchRestarts if (root_proc) then ! Read Output/Input .til files - call ReadTileFile_RealLatLon(OutTileFile, ntiles, lono, lato) - call ReadTileFile_RealLatLon(InTileFile,ntiles_in,loni,lati) + call ReadTileFile_RealLatLon(OutTileFile, ntiles, xlon=lono, xlat=lato) + call ReadTileFile_RealLatLon(InTileFile,ntiles_in,xlon=loni, xlat=lati) allocate(Id (ntiles)) ! allocate(mask (ntiles_in)) ! allocate(tid_in (ntiles_in)) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_GEOSldasRestarts.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_GEOSldasRestarts.F90 index dd2b5c266..5e3da8d3a 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_GEOSldasRestarts.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_GEOSldasRestarts.F90 @@ -445,7 +445,7 @@ SUBROUTINE regrid_from_xgrid (SURFLAY, BCSDIR, YYYYMMDDHH, EXPNAME, EXPDIR, MOD allocate (lon_rst (1:ntiles_rst)) allocate (lat_rst (1:ntiles_rst)) - call ReadTileFile_RealLatLon ('InData/OutTileFile', i, long, latg); VERIFY_(i-ntiles) + call ReadTileFile_RealLatLon ('InData/OutTileFile', i, xlon=long, xlat=latg); VERIFY_(i-ntiles) read (10) LDAS2BCS read (10) tile_id @@ -1187,17 +1187,17 @@ SUBROUTINE regrid_hyd_vars (NTILES, model) allocate (latg (ntiles)) allocate (ld_reorder(ntiles_smap)) - call ReadTileFile_RealLatLon ('InData/OutTileFile', i, long, latg); VERIFY_(i-ntiles) + call ReadTileFile_RealLatLon ('InData/OutTileFile', i, xlon=long, xlat=latg); VERIFY_(i-ntiles) ! --------------------------------------------- ! Read exact lonc, latc from offline .til File ! --------------------------------------------- if(index(MODEL,'catchcn') /=0) then - call ReadTileFile_RealLatLon(trim(InCNTilFile ),i,lonc,latc) + call ReadTileFile_RealLatLon(trim(InCNTilFile ),i,xlon=lonc,xlat=latc) VERIFY_(i-ntiles_smap) endif if(trim(MODEL) == 'catch' ) then - call ReadTileFile_RealLatLon(trim(InCatTilFile),i,lonc,latc) + call ReadTileFile_RealLatLon(trim(InCatTilFile),i,xlon=lonc,xlat=latc) VERIFY_(i-ntiles_smap) endif if(index(MODEL,'catchcn') /=0) then @@ -1852,7 +1852,7 @@ SUBROUTINE regrid_carbon_vars (NTILES, model) allocate (latg (ntiles)) allocate (DAYX (NTILES)) - call ReadTileFile_RealLatLon (OutTileFile, i, long, latg); VERIFY_(i-ntiles) + call ReadTileFile_RealLatLon (OutTileFile, i, xlon=long, xlat=latg); VERIFY_(i-ntiles) ! Compute DAYX ! ------------ @@ -1865,7 +1865,7 @@ SUBROUTINE regrid_carbon_vars (NTILES, model) ! Read exact lonc, latc from offline .til File ! --------------------------------------------- - call ReadTileFile_RealLatLon(trim(InCNTilFile),i,lonc,latc); VERIFY_(i-ntiles_cn) + call ReadTileFile_RealLatLon(trim(InCNTilFile),i,xlon=lonc,xlat=latc); VERIFY_(i-ntiles_cn) endif diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_LakeLandiceSaltRestarts.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_LakeLandiceSaltRestarts.F90 index b499074d3..478b6f3f9 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_LakeLandiceSaltRestarts.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_LakeLandiceSaltRestarts.F90 @@ -18,7 +18,7 @@ program mk_LakeLandiceSaltRestarts character*256 :: arg integer :: i, rc, jc, iostat, iargc, n, mask,j,k,otiles,nsubtiles,l,itiles,nwords - integer, pointer :: Lono(:), Lato(:), Id(:), Pf(:) + integer, pointer :: Lono(:), Lato(:), Id(:) integer, pointer :: Loni(:), Lati(:) real, allocatable :: varIn(:),varOut(:) real*8, allocatable :: varIn8(:),varOut8(:) @@ -67,17 +67,9 @@ program mk_LakeLandiceSaltRestarts ! Read Output Tile File .til file ! to get the index into the pfafsttater table - call ReadTileFile_IntLatLon(OutTileFile,Pf,Id,lono,lato,zoom,mask) - deallocate(Pf,Id) + call ReadTileFile_IntLatLon(OutTileFile, otiles, zoom, lon_int=lono, lat_int=lato, mask=mask) + call ReadTileFile_IntLatLon(InTileFile, itiles, zoom, lon_int=loni, lat_int=lati, mask=mask) - call ReadTileFile_IntLatLon(InTileFile ,Pf,Id,loni,lati,zoom,mask) - deallocate(Pf,Id) - - nullify(Pf) - nullify(Id) - - itiles = size(loni) ! Input Tile Size - otiles = size(lono) ! Output Tile Size allocate(Id (otiles)) call GetIds(loni,lati,lono,lato,zoom,Id) diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/CMakeLists.txt b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/CMakeLists.txt index 968ceaf51..c59826405 100644 --- a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/CMakeLists.txt +++ b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/CMakeLists.txt @@ -20,6 +20,8 @@ if (EXISTS ${CMAKE_CURRENT_SOURCE_DIR}/GEOS_SuperdynGridComp.F90) SUBCOMPONENTS ${alldirs} DEPENDENCIES MAPL GEOS_Shared ESMF::ESMF) + target_compile_definitions (${this} PRIVATE $<$:HAS_GIGATRAJ>) + else () esma_add_subdirectories (${alldirs}) diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOS_SuperdynGridComp.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOS_SuperdynGridComp.F90 index 670b5fa9c..9d10e6eaf 100644 --- a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOS_SuperdynGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOS_SuperdynGridComp.F90 @@ -274,6 +274,15 @@ subroutine SetServices ( GC, RC ) RC=STATUS ) VERIFY_(STATUS) +#ifdef HAS_GIGATRAJ + call MAPL_AddExportSpec ( GC , & + SHORT_NAME = 'ZL', & + CHILD_ID = DYN, & + RC=STATUS ) + VERIFY_(STATUS) +#endif + + call MAPL_AddExportSpec ( GC , & SHORT_NAME = 'PREF', & CHILD_ID = DYN, & diff --git a/GEOSdataatm_GridComp/CMakeLists.txt b/GEOSdataatm_GridComp/CMakeLists.txt index 47e14da1e..407031c05 100644 --- a/GEOSdataatm_GridComp/CMakeLists.txt +++ b/GEOSdataatm_GridComp/CMakeLists.txt @@ -10,3 +10,7 @@ esma_add_library (${this} target_compile_definitions (${this} PRIVATE USE_CICE USE_R8) +install( + FILES JRA55-DO_DataAtm_Forcings_ExtData.yaml CORE_NYF_Data_AtmForcings_ExtData.yaml + DESTINATION etc + ) diff --git a/GEOSdataatm_GridComp/CORE_NYF_Data_AtmForcings_ExtData.yaml b/GEOSdataatm_GridComp/CORE_NYF_Data_AtmForcings_ExtData.yaml new file mode 100755 index 000000000..afacc2f2d --- /dev/null +++ b/GEOSdataatm_GridComp/CORE_NYF_Data_AtmForcings_ExtData.yaml @@ -0,0 +1,27 @@ +Collections: + slp: {template: /discover/nobackup/mmehari/DATA/MODEL/dataAtm_forcing/CORE/NYF_v2.0/slp.clim.nc} + t_10: {template: /discover/nobackup/mmehari/DATA/MODEL/dataAtm_forcing/CORE/NYF_v2.0/t_10_mod.clim.nc} + q_10: {template: /discover/nobackup/mmehari/DATA/MODEL/dataAtm_forcing/CORE/NYF_v2.0/q_10_mod.clim.nc} + u_10: {template: /discover/nobackup/mmehari/DATA/MODEL/dataAtm_forcing/CORE/NYF_v2.0/u_10_mod.clim.nc} + v_10: {template: /discover/nobackup/mmehari/DATA/MODEL/dataAtm_forcing/CORE/NYF_v2.0/v_10_mod.clim.nc} + ncar_runoff: {template: /discover/nobackup/mmehari/DATA/MODEL/dataAtm_forcing/CORE/NYF_v2.0/ncar_runoff.clim.nc} + ncar_precip: {template: /discover/nobackup/mmehari/DATA/MODEL/dataAtm_forcing/CORE/NYF_v2.0/ncar_precip.clim.nc} + ncar_rad: {template: /discover/nobackup/mmehari/DATA/MODEL/dataAtm_forcing/CORE/NYF_v2.0/ncar_rad.clim.nc} + +Samplings: + clim_sample: + extrapolation: clim + +Exports: + PS: {collection: slp, sample: clim_sample, variable: SLP} + TA: {collection: t_10, sample: clim_sample, variable: T_10_MOD} + QA: {collection: q_10, sample: clim_sample, variable: Q_10_MOD} + UA: {collection: u_10, sample: clim_sample, variable: U_10_MOD} + VA: {collection: v_10, sample: clim_sample, variable: V_10_MOD} + RUNOFF: {collection: ncar_runoff, sample: clim_sample, variable: RUNOFF} + PCU: {collection: ncar_precip, sample: clim_sample, variable: RAIN} + PLS: {collection: ncar_precip, sample: clim_sample, variable: RAIN} + SNO: {collection: ncar_precip, sample: clim_sample, variable: SNOW} + LWDN: {collection: ncar_rad, sample: clim_sample, variable: LWDN_MOD} + SWGDWN: {collection: ncar_rad, sample: clim_sample, variable: SWDN_MOD} + diff --git a/GEOSdataatm_GridComp/GEOS_DataAtmGridComp.F90 b/GEOSdataatm_GridComp/GEOS_DataAtmGridComp.F90 index ee3f327b6..95964a7e4 100644 --- a/GEOSdataatm_GridComp/GEOS_DataAtmGridComp.F90 +++ b/GEOSdataatm_GridComp/GEOS_DataAtmGridComp.F90 @@ -202,6 +202,7 @@ subroutine SetServices ( GC, RC ) LONG_NAME = 'surface_temperature', & UNITS = 'K', & DIMS = MAPL_DimsHorzOnly, & + DEFAULT = -1000.0, & VLOCATION = MAPL_VLocationNone, __RC__) call MAPL_AddInternalSpec(GC, & @@ -270,7 +271,12 @@ subroutine SetServices ( GC, RC ) ! This call is needed only when we use ReadForcing. ! If we switch to use ExtData, next line has be commented out - call MAPL_TerminateImport ( GC, ALL=.true., __RC__ ) + if (DO_CICE_THERMO == 2) then + call MAPL_TerminateImport ( GC, SHORT_NAMES=['SURFSTATE'], & + CHILD_IDS=[SURF], __RC__ ) + else + call MAPL_TerminateImport ( GC, ALL=.true., __RC__ ) + endif call MAPL_GenericSetServices ( GC, __RC__) @@ -419,6 +425,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) real, dimension(:,:), pointer :: ALW, BLW, SPEED, DISCHARGE, rPCU, rPLS, sSNO real, dimension(:,:), pointer :: CT, CQ, CM, SH, EVAP, TAUX, TAUY, Tskin, lwdnsrf real, dimension(:,:), pointer :: DRPARN, DFPARN, DRNIRN, DFNIRN, DRUVRN, DFUVRN + real, dimension(:,:), pointer :: DSH, DEVAP real, dimension(:,:), pointer :: EMISSRF real, allocatable, dimension(:,:) :: ZTH @@ -474,7 +481,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) ! real LATSO, LONSO real, parameter :: HW_hack = 2. - logical :: firsttime = .true. + logical :: firsttime = .false. real :: TAU_TS real :: DT @@ -590,7 +597,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) SPEED = SQRT(Uair**2 + Vair**2) IM = size(Uair, 1) - JM = size(Uair, 1) + JM = size(Uair, 2) allocate(Uskin(IM,JM), Vskin(IM,JM), Qskin(IM,JM), swrad(IM,JM), __STAT__) call MAPL_GetPointer(SurfImport, DZ, 'DZ', __RC__) @@ -609,11 +616,13 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) call SetVarToZero('DEWL', __RC__) call SetVarToZero('FRSL', __RC__) + call MAPL_GetPointer(SurfImport, DSH, 'DSH', __RC__) + call MAPL_GetPointer(SurfImport, DEVAP, 'DEVAP', __RC__) ! these should be set to 0 (for now) - call SetVarToZero('DSH', __RC__) + !call SetVarToZero('DSH', __RC__) call SetVarToZero('DFU', __RC__) call SetVarToZero('DFV', __RC__) - call SetVarToZero('DEVAP', __RC__) + !call SetVarToZero('DEVAP', __RC__) call SetVarToZero('DDEWL', __RC__) call SetVarToZero('DFRSL', __RC__) @@ -653,7 +662,10 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) !------------------------------------------------------ call ESMF_ClockGet(CLOCK, TIMESTEP=DELT, __RC__) - DELT = DELT * NINT((86400./DT)) ! emulate daily Solar + ! the line below only works for daily forcing e..g. CORE I + ! for JRA55-DO or any dataset at higher frequency, this line makes SW much + ! higher than what data prescribed + !DELT = DELT * NINT((86400./DT)) ! emulate daily Solar call MAPL_SunGetInsolation(LONS, LATS, & ORBIT, ZTH, SLR, & @@ -711,6 +723,10 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetPointer(SurfImport, ALW, 'ALW', __RC__) call MAPL_GetPointer(SurfImport, BLW, 'BLW', __RC__) + if(any(Tskin<0.0)) then !only when DATAATM restart is bootstrapped + firsttime = .true. + end if + if (firsttime) then firsttime = .false. Tskin = TA @@ -768,6 +784,10 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) TAUX = CM * (Uskin - Uair) TAUY = CM * (Vskin - Vair) + ! these derivatives are important for sea ice + DSH = CT !* MAPL_CP (MAPL_CP got multiplied in Surf) + DEVAP = CQ + 101 format (A, e20.12, 3I3.2) !!! if (mapl_am_i_root()) PRINT*, __FILE__, __LINE__ @@ -1070,7 +1090,7 @@ subroutine Finalize ( gc, import, export, clock, rc ) call MAPL_TimerOn(MAPL,"TOTAL" ) call MAPL_TimerOn(MAPL,"FINALIZE") - if (DO_CICE_THERMO /= 0) call dealloc_column_physics( MAPL_AM_I_Root(), Iam ) + if (DO_CICE_THERMO == 1) call dealloc_column_physics( MAPL_AM_I_Root(), Iam ) call MAPL_TimerOff(MAPL,"FINALIZE") call MAPL_TimerOff(MAPL,"TOTAL" ) diff --git a/GEOSdataatm_GridComp/JRA55-DO_DataAtm_Forcings_ExtData.yaml b/GEOSdataatm_GridComp/JRA55-DO_DataAtm_Forcings_ExtData.yaml new file mode 100755 index 000000000..5da6f8658 --- /dev/null +++ b/GEOSdataatm_GridComp/JRA55-DO_DataAtm_Forcings_ExtData.yaml @@ -0,0 +1,106 @@ +Collections: + psl_1_5_0: + template: ExtData/JRA55-DO/v1-5-0/psl/psl_input4MIPs_atmosphericState_OMIP_MRI-JRA55-do-1-5-0_gr_%y401010000-%y412312100.nc + valid_range: "1958-01-01T00:00:00/2020-01-01T00:00:00" + psl_1_5_0_1: + template: ExtData/JRA55-DO/v1-5-0-1/psl/psl_input4MIPs_atmosphericState_OMIP_MRI-JRA55-do-1-5-0-1_gr_%y401010000-%y412312100.nc + valid_range: "2020-01-01T00:00:00/2024-02-02T00:00:00" + tas_1_5_0: + template: ExtData/JRA55-DO/v1-5-0/tas/tas_input4MIPs_atmosphericState_OMIP_MRI-JRA55-do-1-5-0_gr_%y401010000-%y412312100.nc + valid_range: "1958-01-01T00:00:00/2020-01-01T00:00:00" + tas_1_5_0_1: + template: ExtData/JRA55-DO/v1-5-0-1/tas/tas_input4MIPs_atmosphericState_OMIP_MRI-JRA55-do-1-5-0-1_gr_%y401010000-%y412312100.nc + valid_range: "2020-01-01T00:00:00/2024-02-02T00:00:00" + huss_1_5_0: + template: ExtData/JRA55-DO/v1-5-0/huss/huss_input4MIPs_atmosphericState_OMIP_MRI-JRA55-do-1-5-0_gr_%y401010000-%y412312100.nc + valid_range: "1958-01-01T00:00:00/2020-01-01T00:00:00" + huss_1_5_0_1: + template: ExtData/JRA55-DO/v1-5-0-1/huss/huss_input4MIPs_atmosphericState_OMIP_MRI-JRA55-do-1-5-0-1_gr_%y401010000-%y412312100.nc + valid_range: "2020-01-01T00:00:00/2024-02-02T00:00:00" + uas_1_5_0: + template: ExtData/JRA55-DO/v1-5-0/uas/uas_input4MIPs_atmosphericState_OMIP_MRI-JRA55-do-1-5-0_gr_%y401010000-%y412312100.nc + valid_range: "1958-01-01T00:00:00/2020-01-01T00:00:00" + uas_1_5_0_1: + template: ExtData/JRA55-DO/v1-5-0-1/uas/uas_input4MIPs_atmosphericState_OMIP_MRI-JRA55-do-1-5-0-1_gr_%y401010000-%y412312100.nc + valid_range: "2020-01-01T00:00:00/2024-02-02T00:00:00" + vas_1_5_0: + template: ExtData/JRA55-DO/v1-5-0/vas/vas_input4MIPs_atmosphericState_OMIP_MRI-JRA55-do-1-5-0_gr_%y401010000-%y412312100.nc + valid_range: "1958-01-01T00:00:00/2020-01-01T00:00:00" + vas_1_5_0_1: + template: ExtData/JRA55-DO/v1-5-0-1/vas/vas_input4MIPs_atmosphericState_OMIP_MRI-JRA55-do-1-5-0-1_gr_%y401010000-%y412312100.nc + valid_range: "2020-01-01T00:00:00/2024-02-02T00:00:00" + uvas_1_5_0: + template: ExtData/JRA55-DO/v1-5-0/uvas/uvas_input4MIPs_atmosphericState_OMIP_MRI-JRA55-do-1-5-0_gr_%y401010000-%y412312100.nc + valid_range: "1958-01-01T00:00:00/2020-01-01T00:00:00" + uvas_1_5_0_1: + template: ExtData/JRA55-DO/v1-5-0-1/uvas/uvas_input4MIPs_atmosphericState_OMIP_MRI-JRA55-do-1-5-0-1_gr_%y401010000-%y412312100.nc + valid_range: "2020-01-01T00:00:00/2024-02-02T00:00:00" + friver_1_5_0: + template: ExtData/JRA55-DO/v1-5-0/friver/friver_input4MIPs_atmosphericState_OMIP_MRI-JRA55-do-1-5-0_gr_%y40101-%y41231.nc + valid_range: "1958-01-01T00:00:00/2020-01-01T00:00:00" + friver_1_5_0_1: + template: ExtData/JRA55-DO/v1-5-0-1/friver/friver_input4MIPs_atmosphericState_OMIP_MRI-JRA55-do-1-5-0-1_gr_%y40101-%y41231.nc + valid_range: "2020-01-01T00:00:00/2024-02-02T00:00:00" + prra_1_5_0: + template: ExtData/JRA55-DO/v1-5-0/prra/prra_input4MIPs_atmosphericState_OMIP_MRI-JRA55-do-1-5-0_gr_%y401010130-%y412312230.nc + valid_range: "1958-01-01T00:00:00/2020-01-01T00:00:00" + prra_1_5_0_1: + template: ExtData/JRA55-DO/v1-5-0-1/prra/prra_input4MIPs_atmosphericState_OMIP_MRI-JRA55-do-1-5-0-1_gr_%y401010130-%y412312230.nc + valid_range: "2020-01-01T00:00:00/2024-02-02T00:00:00" + prsn_1_5_0: + template: ExtData/JRA55-DO/v1-5-0/prsn/prsn_input4MIPs_atmosphericState_OMIP_MRI-JRA55-do-1-5-0_gr_%y401010130-%y412312230.nc + valid_range: "1958-01-01T00:00:00/2020-01-01T00:00:00" + prsn_1_5_0_1: + template: ExtData/JRA55-DO/v1-5-0-1/prsn/prsn_input4MIPs_atmosphericState_OMIP_MRI-JRA55-do-1-5-0-1_gr_%y401010130-%y412312230.nc + valid_range: "2020-01-01T00:00:00/2024-02-02T00:00:00" + rlds_1_5_0: + template: ExtData/JRA55-DO/v1-5-0/rlds/rlds_input4MIPs_atmosphericState_OMIP_MRI-JRA55-do-1-5-0_gr_%y401010130-%y412312230.nc + valid_range: "1958-01-01T00:00:00/2020-01-01T00:00:00" + rlds_1_5_0_1: + template: ExtData/JRA55-DO/v1-5-0-1/rlds/rlds_input4MIPs_atmosphericState_OMIP_MRI-JRA55-do-1-5-0-1_gr_%y401010130-%y412312230.nc + valid_range: "2020-01-01T00:00:00/2024-02-02T00:00:00" + rsds_1_5_0: + template: ExtData/JRA55-DO/v1-5-0/rsds/rsds_input4MIPs_atmosphericState_OMIP_MRI-JRA55-do-1-5-0_gr_%y401010130-%y412312230.nc + valid_range: "1958-01-01T00:00:00/2020-01-01T00:00:00" + rsds_1_5_0_1: + template: ExtData/JRA55-DO/v1-5-0-1/rsds/rsds_input4MIPs_atmosphericState_OMIP_MRI-JRA55-do-1-5-0-1_gr_%y401010130-%y412312230.nc + valid_range: "2020-01-01T00:00:00/2024-02-02T00:00:00" + +Samplings: + interannual_sample: + flux_conserve_sample: + time_interpolation: false + update_offset: "PT1H30M" + river_conserve_sample: + time_interpolation: false + update_offset: "PT12H" + +Exports: + PS: + - {starting: "1958-01-01T00:00:00", collection: psl_1_5_0, sample: interannual_sample, variable: psl} + - {starting: "2020-01-01T00:00:00", collection: psl_1_5_0_1, sample: interannual_sample, variable: psl} + TA: + - {starting: "1958-01-01T00:00:00", collection: tas_1_5_0, sample: interannual_sample, variable: tas} + - {starting: "2020-01-01T00:00:00", collection: tas_1_5_0_1, sample: interannual_sample, variable: tas} + QA: + - {starting: "1958-01-01T00:00:00", collection: huss_1_5_0, sample: interannual_sample, variable: huss} + - {starting: "2020-01-01T00:00:00", collection: huss_1_5_0_1, sample: interannual_sample, variable: huss} + UA;VA: + - {starting: "1958-01-01T00:00:00", collection: uvas_1_5_0, sample: interannual_sample, variable: uas;vas} + - {starting: "2020-01-01T00:00:00", collection: uvas_1_5_0_1, sample: interannual_sample, variable: uas;vas} + RUNOFF: + - {starting: "1958-01-01T00:00:00", collection: friver_1_5_0, regrid: CONSERVE, sample: river_conserve_sample, variable: friver} + - {starting: "2020-01-01T00:00:00", collection: friver_1_5_0_1, regrid: CONSERVE, sample: river_conserve_sample, variable: friver} + PCU: + - {starting: "1958-01-01T00:00:00", collection: prra_1_5_0, regrid: CONSERVE, sample: flux_conserve_sample, variable: prra} + - {starting: "2020-01-01T00:00:00", collection: prra_1_5_0_1, regrid: CONSERVE, sample: flux_conserve_sample, variable: prra} + PLS: {collection: /dev/null} + SNO: + - {starting: "1958-01-01T00:00:00", collection: prsn_1_5_0, regrid: CONSERVE, sample: flux_conserve_sample, variable: prsn} + - {starting: "2020-01-01T00:00:00", collection: prsn_1_5_0_1, regrid: CONSERVE, sample: flux_conserve_sample, variable: prsn} + LWDN: + - {starting: "1958-01-01T00:00:00", collection: rlds_1_5_0, regrid: CONSERVE, sample: flux_conserve_sample, variable: rlds} + - {starting: "2020-01-01T00:00:00", collection: rlds_1_5_0_1, regrid: CONSERVE, sample: flux_conserve_sample, variable: rlds} + SWGDWN: + - {starting: "1958-01-01T00:00:00", collection: rsds_1_5_0, regrid: CONSERVE, sample: flux_conserve_sample, variable: rsds} + - {starting: "2020-01-01T00:00:00", collection: rsds_1_5_0_1, regrid: CONSERVE, sample: flux_conserve_sample, variable: rsds} diff --git a/GEOSgigatraj_GridComp/.gitignore b/GEOSgigatraj_GridComp/.gitignore new file mode 100644 index 000000000..7bf7f4af4 --- /dev/null +++ b/GEOSgigatraj_GridComp/.gitignore @@ -0,0 +1,3 @@ +@GigaTraj/ +GigaTraj/ +GigaTraj@/ diff --git a/GEOSgigatraj_GridComp/CMakeLists.txt b/GEOSgigatraj_GridComp/CMakeLists.txt new file mode 100644 index 000000000..3b4d5db38 --- /dev/null +++ b/GEOSgigatraj_GridComp/CMakeLists.txt @@ -0,0 +1,9 @@ +esma_set_this() + +set (dependencies MAPL ESMF::ESMF geos_giga metsources filters gigatraj) + +esma_add_library (${this} + SRCS GEOS_Giga_InterOp.F90 Gigatraj_Utils.F90 GEOS_GigatrajGridComp.F90 + DEPENDENCIES ${dependencies}) + +esma_add_subdirectories(GigaTraj) diff --git a/GEOSgigatraj_GridComp/GEOS_Giga_InterOp.F90 b/GEOSgigatraj_GridComp/GEOS_Giga_InterOp.F90 new file mode 100644 index 000000000..0c914dc53 --- /dev/null +++ b/GEOSgigatraj_GridComp/GEOS_Giga_InterOp.F90 @@ -0,0 +1,190 @@ +! This module define the interface bewteen GEOS and gigatraj +! The functions are defined in gigatraj + +module GEOS_Giga_InterOpMod + use, intrinsic :: iso_c_binding, only : c_double, c_int, c_ptr, c_null_char, c_associated + use, intrinsic :: iso_c_binding, only : c_loc, c_null_ptr + use mpi + implicit none + private + + public :: initMetGEOSDistributedLatLonData + public :: initMetGEOSDistributedCubedData + public :: updateFields + public :: RK4_advance + public :: setData + public :: getData + public :: getData2d + + public :: test_Field3D + public :: test_dataflow + public :: test_metData + + interface + + function initMetGEOSDistributedCubedData(comm, ijToRank, Ig, lev, i1, i2, j1, j2, nzs, lons_ptr, lats_ptr, eta_ptr, ctime_ptr) result (metdata_ptr) bind(C, name="initGigaGridDistributedCubedData") + import :: c_int, c_ptr + implicit none + integer(c_int), intent(in), value :: comm, Ig, lev, i1,i2,j1,j2, nzs + type(c_ptr), intent(in), value :: ijToRank, lons_ptr, lats_ptr, eta_ptr, ctime_ptr + type(c_ptr) :: metdata_ptr + end function + + function initMetGEOSDistributedLatLonData(comm, ijToRank, Ig, Jg,lev, nlon_local, nlat_local, nzs, lons_ptr, lats_ptr, eta_ptr, ctime_ptr) result (metdata_ptr) bind(C, name="initGigaGridDistributedLatLonData") + import :: c_int, c_ptr + implicit none + integer(c_int), intent(in), value :: comm, Ig, Jg, lev, nlon_local, nlat_local, nzs + type(c_ptr), intent(in), value :: ijToRank, lons_ptr, lats_ptr, eta_ptr, ctime_ptr + type(c_ptr) :: metdata_ptr + end function + + subroutine updateFields( metSrc_ptr, ctime_ptr, u_ptr, v_ptr, w_ptr, p_ptr) bind(C, name="updateFields") + import :: c_ptr + implicit none + type(c_ptr), intent(in), value :: metSrc_ptr, ctime_ptr, u_ptr, v_ptr, w_ptr, p_ptr + end subroutine + + subroutine RK4_advance(metsrc_ptr, ctime_ptr, dt, n, lons_ptr, lats_ptr, levs_ptr) bind( C, name='RK4_advance') + import :: c_ptr, c_int, c_double + type(c_ptr), intent(in), value :: metsrc_ptr + real(c_double), intent(in), value :: dt + integer(c_int), intent(in), value :: n + type(c_ptr), intent(in), value :: ctime_ptr, lons_ptr, lats_ptr, levs_ptr + end subroutine + + subroutine test_Field3d(obj_ptr) bind(C, name="test_Field3D") + import :: c_ptr + implicit none + type(c_ptr), intent(in), value :: obj_ptr + end subroutine + + subroutine test_metData(obj_ptr, time, n, lons_ptr, lats_ptr, levs_ptr, u_ptr, v_ptr, w_ptr) bind(C, name="test_metData") + import :: c_ptr,c_int, c_double + type(c_ptr), intent(in), value :: obj_ptr + real(c_double), intent(in), value :: time + integer(c_int), intent(in), value :: n + type(c_ptr), intent(in), value :: lons_ptr, lats_ptr, levs_ptr, u_ptr, v_ptr, w_ptr + end subroutine + + subroutine setData ( metSrc_ptr, ctime, quantity_ptr, data_ptr) bind(C, name="setData") + import :: c_ptr + type(c_ptr), intent(in), value :: metSrc_ptr, ctime, quantity_ptr, data_ptr + end subroutine setData + + subroutine getData ( metSrc_ptr, ctime, quantity_ptr, n, lons_ptr, lats_ptr, levs_ptr, values_ptr) bind(C, name="getData") + import :: c_ptr, c_int + integer(c_int), intent(in), value :: n + type(c_ptr), intent(in), value :: metSrc_ptr, ctime, quantity_ptr, lons_ptr, lats_ptr, levs_ptr, values_ptr + end subroutine getData + + subroutine getData2d ( metSrc_ptr, ctime, quantity_ptr, n, lons_ptr, lats_ptr, values_ptr) bind(C, name="getData2d") + import :: c_ptr, c_int + integer(c_int), intent(in), value :: n + type(c_ptr), intent(in), value :: metSrc_ptr, ctime, quantity_ptr, lons_ptr, lats_ptr, values_ptr + end subroutine getData2d + end interface + +contains + + subroutine test_dataflow(num_parcels, lons, lats, zs, CellToRank, DIMS, comm) + integer :: num_parcels, comm, DIMS(3) + real, dimension(:), intent(in) :: lons, lats,zs + integer, dimension(:,:), intent(in) :: CellToRank + + integer :: i, npes, ierror, rank, my_rank + real :: dlon, dlat + real, allocatable :: lons_positive(:) + + real, allocatable :: lons_send(:), lats_send(:), zs_send(:) + real, allocatable :: lons_recv(:), lats_recv(:), zs_recv(:) + real, allocatable :: U_recv(:), U_send(:) + real, allocatable :: U(:), V(:), W(:), pos(:) + + integer, allocatable :: counts_send(:),counts_recv(:), II(:), JJ(:), ranks(:) + integer, allocatable :: disp_send(:), disp_recv(:), tmp_position(:) + + dlon = 360.0 / DIMS(1) + dlat = 180.0 / DIMS(2) + + lons_positive = lons + where (lons_positive < 0) lons_positive=lons_positive + 360.0 + II = min( max(ceiling (lons_positive/dlon),1), DIMS(1)) + JJ = min( max(ceiling ((lats + 90.0)/dlat),1), DIMS(2)) + + call MPI_Comm_size(comm, npes, ierror) + call MPI_Comm_rank(comm, my_rank, ierror) + + allocate(ranks(num_parcels)) + allocate(counts_send(npes)) + allocate(counts_recv(npes)) + allocate(disp_send(npes)) + allocate(disp_recv(npes)) + + do i = 1, num_parcels + ranks(i) = CellToRank(II(i), JJ(i)) + enddo + +!-- ------------------- +!step 4) Pack the location data and send them to where the metData sit +!-- ------------------- + + do rank = 0, npes-1 + counts_send(rank+1) = count(ranks == rank) + enddo + + call MPI_AllToALL(counts_send, 1, MPI_INTEGER, counts_recv, 1, MPI_INTEGER, comm, ierror) + + disp_send = 0 + do rank = 1, npes-1 + disp_send(rank+1) = disp_send(rank)+ counts_send(rank) + enddo + disp_recv = 0 + do rank = 1, npes-1 + disp_recv(rank+1) = disp_recv(rank)+ counts_recv(rank) + enddo + + + ! re-arranged lats lons, and ids + tmp_position = disp_send + allocate(lons_send(num_parcels)) + allocate(lons_recv(sum(counts_recv))) + allocate(lats_send(num_parcels)) + allocate(lats_recv(sum(counts_recv))) + allocate(zs_send(num_parcels)) + allocate(zs_recv(sum(counts_recv))) + + allocate(pos(num_parcels)) + do i = 1, num_parcels + rank = ranks(i) + pos(i) = tmp_position(rank+1) +1 + lons_send(pos(i)) = lons(i) + lats_send(pos(i)) = lats(i) + zs_send(pos(i)) = zs(i) + tmp_position(rank+1) = tmp_position(rank+1) + 1 + enddo + + call MPI_AllToALLv(lons_send, counts_send, disp_send, MPI_REAL, lons_recv, counts_recv, disp_recv, MPI_REAL, comm, ierror) + call MPI_AllToALLv(lats_send, counts_send, disp_send, MPI_REAL, lats_recv, counts_recv, disp_recv, MPI_REAL, comm, ierror) + call MPI_AllToALLv(zs_send, counts_send, disp_send, MPI_REAL, zs_recv, counts_recv, disp_recv, MPI_REAL, comm, ierror) +!-- ------------------- +!step 5) Interpolate the data ( horiontally and vertically) and send back where they are from +!-- ------------------- + allocate(U_recv(sum(counts_recv)), source = my_rank*1.0) + allocate(U_send(num_parcels), source = -1.0) + ! + ! Horizontal and vertical interpolator here + ! + call MPI_AllToALLv(U_recv, counts_recv, disp_recv, MPI_REAL, U_send, counts_send, disp_send, MPI_REAL, comm, ierror) + +!--------------------- +!step 6) Rearrange data ( not necessary if ids was rearranged ins step 4) +!--------------------- + + allocate(U(num_parcels)) + allocate(V(num_parcels)) + allocate(W(num_parcels)) + U(:) = U_send(pos(:)) + + end subroutine + +end module GEOS_Giga_InterOpMod diff --git a/GEOSgigatraj_GridComp/GEOS_GigatrajGridComp.F90 b/GEOSgigatraj_GridComp/GEOS_GigatrajGridComp.F90 new file mode 100644 index 000000000..ba2f62b1d --- /dev/null +++ b/GEOSgigatraj_GridComp/GEOS_GigatrajGridComp.F90 @@ -0,0 +1,1477 @@ +#include "MAPL_Generic.h" + +module GEOS_GigatrajGridCompMod + use, intrinsic :: iso_c_binding, only : c_int, c_ptr, c_null_ptr, c_associated, c_null_char + use, intrinsic :: iso_c_binding, only : c_loc + use ESMF + use MAPL + use MAPL_VerticalDataMod + use mpi + use GEOS_Giga_interOpMod + use Gigatraj_UtilsMod + implicit none + + public :: SetServices + +contains + + subroutine SetServices ( GC, RC ) + type(ESMF_GridComp), intent(INOUT) :: GC ! gridded component + integer, optional :: RC ! return code + + character(len=ESMF_MAXSTR) :: IAm + integer :: STATUS + character(len=ESMF_MAXSTR) :: COMP_NAME + + type (GigaTrajInternal), pointer :: GigaTrajInternalPtr + type (GigatrajInternalWrap) :: wrap + + call ESMF_GridCompGet( GC, NAME=COMP_NAME, _RC ) + Iam = trim(COMP_NAME) // 'SetServices' + + ! Register services for this component + ! ------------------------------------ + + call MAPL_GridCompSetEntryPoint ( GC, ESMF_METHOD_INITIALIZE, Initialize, _RC ) + call MAPL_GridCompSetEntryPoint ( GC, ESMF_METHOD_RUN, GetInitVars , _RC ) + call MAPL_GridCompSetEntryPoint ( GC, ESMF_METHOD_RUN, Run , _RC ) + + + ! Internal state + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'U', & + LONG_NAME = 'eastward_wind', & + UNITS = 'm s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, _RC) + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'V', & + LONG_NAME = 'northward_wind', & + UNITS = 'm s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, _RC) + + call MAPL_AddInternalSpec ( gc, & + SHORT_NAME = 'OMEGA', & + LONG_NAME = 'vertical_pressure_velocity', & + UNITS = 'Pa s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, _RC) + + call MAPL_AddInternalSpec ( gc, & + SHORT_NAME = 'PL', & + LONG_NAME = 'mid_level_pressure', & + UNITS = 'Pa', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, _RC) + + call MAPL_AddInternalSpec ( gc, & + SHORT_NAME = 'ZL', & + LONG_NAME = 'mid_layer_heights', & + UNITS = 'm', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, _RC) + + call MAPL_AddInternalSpec ( gc, & + SHORT_NAME = 'W', & + LONG_NAME = 'vertical_velocity', & + UNITS = 'm s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, _RC) + + call MAPL_AddInternalSpec ( gc, & + SHORT_NAME = 'TH', & + LONG_NAME = 'potential_temperature', & + UNITS = 'K', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, _RC) + + call MAPL_AddInternalSpec ( gc, & + SHORT_NAME = 'DTDTDYN', & + LONG_NAME = 'tendency_of_air_temperature_due_to_dynamics', & + UNITS = 'K s-1', & + DIMS = MAPL_DimsHorzVert, & + VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + allocate(GigaTrajInternalPtr) + wrap%ptr => GigaTrajInternalPtr + call ESMF_UserCompSetInternalState(GC, 'GigaTrajInternal', wrap, _RC) + + call MAPL_GenericSetServices(GC, _RC ) + + call MAPL_TimerAdd(GC, name="INITIALIZE" ,_RC) + call MAPL_TimerAdd(GC, name="RUN" ,_RC) + + RETURN_(ESMF_SUCCESS) + end subroutine SetServices + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) + type(ESMF_GridComp), intent(inout) :: GC ! Gridded component + type(ESMF_State), intent(inout) :: IMPORT ! Import state + type(ESMF_State), intent(inout) :: EXPORT ! Export state + type(ESMF_Clock), intent(inout) :: CLOCK ! The clock + integer, optional, intent( out) :: RC ! Error code + + character(len=ESMF_MAXSTR) :: IAm + integer :: STATUS + character(len=ESMF_MAXSTR) :: COMP_NAME + + ! Local derived type aliases + type (MAPL_MetaComp), pointer :: MPL + type (ESMF_VM) :: vm + integer :: I1, I2, J1, J2, comm, npes, my_rank, rank, ierror, NX, NY, NPZ + type(ESMF_Grid) :: CubedGrid + integer, allocatable :: I1s(:), J1s(:), I2s(:),J2s(:) + integer :: DIMS(3) + type (GigaTrajInternal), pointer :: GigaTrajInternalPtr + type (GigatrajInternalWrap) :: wrap + type (ESMF_TIME) :: CurrentTime + type(ESMF_Alarm) :: GigaTrajOutAlarm, GigaTrajRebalanceAlarm, GigaTrajIntegrateAlarm + type(ESMF_TimeInterval) :: parcelsOut_DT, Rebalance_DT, Integrate_DT + type(ESMF_TimeInterval) :: ModelTimeStep + integer :: HH, MM, SS + integer :: integrate_time, r_time, o_time + character(len=ESMF_MAXSTR) :: parcels_file + character(len=ESMF_MAXSTR) :: grid_name, vCoord + character(len=ESMF_MAXSTR) :: regrid_to_latlon + character(len=ESMF_MAXSTR), allocatable :: cName(:), bName(:), fName(:), aName(:) + type(ESMF_Grid) :: grid_ + + call ESMF_GridCompGet ( GC, name=COMP_NAME, _RC ) + Iam = trim(COMP_NAME) // "Initialize" + + call MAPL_GetObjectFromGC ( GC, MPL, _RC) + + call MAPL_TimerOn(MPL,"TOTAL") + call MAPL_TimerOn(MPL,"INITIALIZE") + + call ESMF_ClockGet(clock, currTime=CurrentTime, _RC) + call ESMF_ClockGet(clock, timeStep=ModelTimeStep, _RC) + + call ESMF_TimeIntervalGet(ModelTimeStep, h = hh, m = mm, s = ss, _RC) + + call MAPL_GetResource(MPL, integrate_time, "GIGATRAJ_INTEGRATE_DT:", default = hh*10000+mm*100+ss, _RC) + hh = integrate_time/10000 + mm = mod(integrate_time, 10000)/100 + ss = mod(integrate_time, 100) + call ESMF_TimeIntervalSet(Integrate_DT, h = hh, m = mm, s = ss, _RC) + + call MAPL_GetResource(MPL, r_time, "GIGATRAJ_REBALANCE_DT:", default = integrate_time, _RC) + hh = r_time/10000 + mm = mod(r_time, 10000)/100 + ss = mod(r_time, 100) + call ESMF_TimeIntervalSet(Rebalance_DT, h = hh, m = mm, s = ss, _RC) + + call MAPL_GetResource(MPL, o_time, "GIGATRAJ_OUTPUT_DT:", default = integrate_time, _RC) + hh = o_time/10000 + mm = mod(o_time, 10000)/100 + ss = mod(o_time, 100) + call ESMF_TimeIntervalSet(parcelsOut_DT, h = hh, m = mm, s = ss, _RC) + + GigaTrajOutAlarm = ESMF_AlarmCreate( & + clock, & + name='GigatrajOut', & + ringTime= CurrentTime + parcelsOut_DT-ModelTimeStep, & + ringInterval=parcelsOut_DT, & + ringTimeStepCount=1, & + sticky=.false., _RC) + + GigaTrajRebalanceAlarm = ESMF_AlarmCreate( & + clock, & + name='GigatrajRebalance', & + ringTime= CurrentTime + Rebalance_DT-ModelTimeStep, & + ringInterval=Rebalance_DT, & + ringTimeStepCount=1, & + sticky=.false., _RC) + + GigaTrajIntegrateAlarm = ESMF_AlarmCreate( & + clock, & + name='GigatrajIntegrate', & + ringTime= CurrentTime + integrate_DT-ModelTimeStep, & + ringInterval=integrate_DT, & + ringTimeStepCount=1, & + sticky=.false., _RC) + + call MAPL_GenericInitialize ( GC, IMPORT, EXPORT, CLOCK, _RC) + + call ESMF_VMGetCurrent(vm, _RC) + call ESMF_VMGet(vm, mpiCommunicator=comm, _RC) + call MPI_Comm_size(comm, npes, ierror); _VERIFY(ierror) + call MPI_Comm_rank(comm, my_rank, ierror); _VERIFY(ierror) + + call ESMF_UserCompGetInternalState(GC, 'GigaTrajInternal', wrap, status); _VERIFY(STATUS) + GigaTrajInternalPtr => wrap%ptr + GigaTrajInternalPtr%npes = npes + + call ESMF_GridCompGet(GC, grid=CubedGrid, _RC) + call MAPL_GridGet(CubedGrid, globalCellCountPerDim=DIMS, _RC) + + call MAPL_GetResource(MPL, vCoord, "GIGATRAJ_VERTICAL_COORD:", default='DYN%%PL|P', rc=status) + call parseCompsAndFieldsName(vCoord, cName, bName, fName, aName) + GigaTrajInternalPtr%vCoord = trim(fName(1)) + GigaTrajInternalPtr%vAlias = trim(aName(1)) + select case(GigaTrajInternalPtr%vCoord) + case ('PL') + GigaTrajInternalPtr%vTendency = 'OMEGA' + case('TH') + GigaTrajInternalPtr%vTendency = 'DTDTDYN' + case('ZL') + GigaTrajInternalPtr%vTendency = 'W' + case default + _ASSERT(.false., "vertical coordinate is needed") + end select + + npz = Dims(3) + GigaTrajInternalPtr%npz = npz + GigaTrajInternalPtr%Integrate_DT = Integrate_DT + + call MAPL_GetResource(MPL, NX, "NX:", _RC) + call MAPL_GetResource(MPL, grid_name, "AGCM_GRIDNAME:", _RC) + + ! the level is differtent from the original grid + GigaTrajInternalPtr%CubedGrid = grid_manager%make_grid(& + CubedSphereGridFactory(grid_name=trim(grid_name),im_world = DIMS(1), lm=npz, nx=NX, ny=NX, rc=status)); _VERIFY(status) + + call MAPL_GetResource(MPL, regrid_to_latlon, "GIGATRAJ_REGRID_TO_LATLON:", default='YES', _RC) + + GigaTrajInternalPtr%regrid_to_latlon = .true. + if (trim(regrid_to_latlon) == "NO") GigaTrajInternalPtr%regrid_to_latlon = .false. + + if ( GigaTrajInternalPtr%regrid_to_latlon ) then + + call MAPL_MakeDecomposition(NX,NY,_RC) + + GigaTrajInternalPtr%LatLonGrid = grid_manager%make_grid( & + LatLonGridFactory(im_world=DIMS(1)*4, jm_world=DIMS(1)*2+1, lm=npz, & + nx=NX, ny=NY, pole='PC', dateline= 'DC', rc=status) ); _VERIFY(status) + + GigaTrajInternalPtr%cube2latlon => new_regridder_manager%make_regridder(GigaTrajInternalPtr%CubedGrid, GigaTrajInternalPtr%LatLonGrid, REGRID_METHOD_CONSERVE, _RC) + + grid_ = GigaTrajInternalPtr%LatLonGrid + call MAPL_GridGet(grid_, globalCellCountPerDim=DIMS, _RC) + else + grid_ = CubedGrid + endif + + call MAPL_Grid_interior(grid_, i1,i2,j1,j2) + + allocate(I1s(npes),J1s(npes)) + allocate(I2s(npes),J2s(npes)) + + call MPI_Allgather(i1, 1, MPI_INTEGER, I1s, 1, MPI_INTEGER, comm, ierror); _VERIFY(ierror) + call MPI_Allgather(i2, 1, MPI_INTEGER, I2s, 1, MPI_INTEGER, comm, ierror); _VERIFY(ierror) + call MPI_Allgather(j1, 1, MPI_INTEGER, J1s, 1, MPI_INTEGER, comm, ierror); _VERIFY(ierror) + call MPI_Allgather(j2, 1, MPI_INTEGER, J2s, 1, MPI_INTEGER, comm, ierror); _VERIFY(ierror) + + allocate(GigaTrajInternalPtr%CellToRank(DIMS(1),DIMS(2))) + + do rank = 0, npes -1 + I1 = I1s(rank+1) + I2 = I2s(rank+1) + J1 = J1s(rank+1) + J2 = J2s(rank+1) + GigaTrajInternalPtr%CellToRank(I1:I2,J1:J2) = rank + enddo + + call read_parcels(GC, GigaTrajInternalPtr, _RC) + + call MAPL_TimerOff(MPL,"INITIALIZE") + call MAPL_TimerOff(MPL,"TOTAL") + RETURN_(ESMF_SUCCESS) + end subroutine Initialize + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine GetInitVars ( GC, IMPORT, EXPORT, CLOCK, RC ) + type(ESMF_GridComp), intent(inout) :: GC + type(ESMF_State), intent(inout) :: IMPORT + type(ESMF_State), intent(inout) :: EXPORT + type(ESMF_Clock), intent(inout) :: CLOCK + integer, optional, intent( out) :: RC + + integer :: i, status, k + character(len=ESMF_MAXSTR) :: IAm + type (ESMF_State) :: INTERNAL, leaf_export + type (GigaTrajInternal), pointer :: GigaTrajInternalPtr + type (GigatrajInternalWrap) :: wrap + character(len=ESMF_MAXSTR) :: GigaRstFile + character(len=ESMF_MAXSTR) :: other_fields + type(ESMF_Field) :: tmp_field + type (ESMF_FieldBundle) :: bdle + type (ESMF_TIME) :: CurrentTime + character(len=20), target :: ctime + type (MAPL_MetaComp), pointer :: MPL + logical, save :: init = .false. + real, dimension(:,:,:) , pointer :: ptr3d + type(Netcdf4_fileformatter) :: formatter + type(FileMetadata) :: meta + character(len=ESMF_MAXSTR) :: parcels_file + character(len=:), allocatable :: fieldname, tmp_name + character(len=20) :: diffusions(4) + character (len=ESMF_MAXSTR), allocatable :: itemNameList(:) + character (len=ESMF_MAXSTR) :: LONG_NAME, UNITS + character (len=ESMF_MAXSTR), allocatable :: fieldnames(:) + character (len=ESMF_MAXSTR), allocatable :: bundlenames(:) + character (len=ESMF_MAXSTR), allocatable :: compnames(:) + character (len=ESMF_MAXSTR), allocatable :: aliasnames(:) + integer :: nitems + logical :: file_exists + + Iam = "getInitVars" + + if (init) then + RETURN_(ESMF_SUCCESS) + endif + + call MAPL_GetObjectFromGC ( GC, MPL, _RC) + + call ESMF_ClockGet(clock, currTime=CurrentTime, _RC) + call ESMF_TimeGet(CurrentTime, timeStringISOFrac=ctime) + ctime(20:20) = c_null_char + + call MAPL_Get(MPL, INTERNAL_ESMF_STATE=INTERNAL, _RC) + + call ESMF_UserCompGetInternalState(GC, 'GigaTrajInternal', wrap, _RC) + GigaTrajInternalPtr => wrap%ptr + + call MAPL_GetResource(MPL, GigaRstFile, 'GIGATRAJ_INTERNAL_RESTART_FILE:', default="NONE", RC=STATUS ) + + if (trim(GigaRstFile) == 'NONE') then + ! without restart file, get value from import + call init_metsrc_field0(GC, IMPORT, ctime, _RC) + else + INQUIRE(FILE= GigaRstFile, EXIST=file_exists) + _ASSERT( file_exists, " GIGATRAJ_INTERNAL_RESTART_FILE does not exist") + call init_metsrc_field0(GC, INTERNAL, ctime, _RC) + endif + + call MAPL_GetResource(MPL, other_fields, "GIGATRAJ_EXTRA_FIELDS:", default='NONE', _RC) + + if (other_fields /= 'NONE') then + call MAPL_GetResource(MPL, parcels_file, "GIGATRAJ_PARCELS_FILE:", default='parcels.nc4', _RC) + if (MAPL_AM_I_ROOT()) then + call formatter%open(trim(parcels_file), pFIO_WRITE, _RC) + meta = formatter%read(_RC) + endif + + call parseCompsAndFieldsName(other_fields, compnames, bundlenames, fieldnames, aliasnames) + GigaTrajInternalPtr%ExtraCompNames = compnames + GigaTrajInternalPtr%ExtraBundleNames = bundlenames + GigaTrajInternalPtr%ExtraFieldNames = fieldnames + GigaTrajInternalPtr%ExtraAliasNames = aliasnames + + do i = 1, size(FieldNames) + call MAPL_ExportStateGet([import], trim(compnames(i)), leaf_export, _RC) + if ( trim(bundlenames(i)) == 'NONE') then + call ESMF_StateGet(leaf_export, trim(FieldNames(i)), tmp_field, _RC) + else + call ESMF_StateGet(leaf_export, trim(bundlenames(i)), bdle, _RC) + call ESMFL_BundleGetPointerToData(bdle , trim(FieldNames(i)) , ptr3d, _RC) + if ( .not. associated(ptr3d)) then + _ASSERT(.false., trim(FieldNames(i)) // " in bundle "//trim(bundlenames(i)) // " is not allocated, gigatraj cannot output this field") + endif + call ESMF_FieldBundleGet(bdle, trim(FieldNames(i)), field=tmp_field, _RC) + endif + call MAPL_AllocateCoupling(tmp_field, _RC) + call ESMF_AttributeGet(tmp_field, NAME='LONG_NAME', VALUE=LONG_NAME, _RC) + call ESMF_AttributeGet(tmp_field, NAME='UNITS', VALUE=UNITS, _RC) + + call create_new_vars( meta, formatter, trim(long_name), trim(aliasnames(i)), trim(units)) + + enddo + if (MAPL_AM_I_Root()) then + call formatter%close() + endif + endif + + init = .true. + + RETURN_(ESMF_SUCCESS) + + end subroutine GetInitVars + + subroutine Init_metsrc_field0 (GC, state, ctime, RC ) + type(ESMF_GridComp), intent(inout) :: GC ! Gridded component + type(ESMF_State), intent(inout) :: state + character(*), target, intent(in) :: ctime + integer, optional, intent(out) :: RC ! Error code + + character(len=ESMF_MAXSTR) :: IAm + integer :: STATUS + + type(GigaTrajInternal), pointer :: GigaTrajInternalPtr + type (GigatrajInternalWrap) :: wrap + real, dimension(:,:,:), pointer :: U, V, W, P, PL0, PLE, TH + real, dimension(:,:,:), allocatable :: U_latlon, V_latlon, W_latlon, P_latlon + real, dimension(:,:,:), allocatable, target :: haloU, haloV, haloW, haloP + integer :: counts(3), dims(3), d1,d2,km,lm, i1,i2,j1,j2,i + real, allocatable, target :: lats_center(:), lons_center(:), levs_center(:) + real, allocatable, target :: cube_lats_center(:, :), cube_lons_center(:,:) + integer :: comm + real :: delt, High, low + type(ESMF_VM) :: vm + type(ESMF_Grid) :: grid_ + + Iam = "init_metsrc_field0" + + call ESMF_VMGetCurrent(vm, _RC) + call ESMF_VMGet(vm, mpiCommunicator=comm, _RC) + call ESMF_UserCompGetInternalState(GC, 'GigaTrajInternal', wrap, _RC) + GigaTrajInternalPtr => wrap%ptr + + call MAPL_GetPointer(state, U, "U", _RC) + call MAPL_GetPointer(state, V, "V", _RC) + call MAPL_GetPointer(state, W, trim(GigaTrajInternalPtr%vTendency), _RC) + call MAPL_GetPointer(state, P, trim(GigaTrajInternalPtr%vCoord), _RC) + + if (GigaTrajInternalPtr%regrid_to_latlon) then + grid_ = GigaTrajInternalPtr%LatLonGrid + else + grid_ = GigaTrajInternalPtr%CubedGrid + endif + + call MAPL_GridGet( grid_, localCellCountPerDim=counts, globalCellCountPerDim=dims, _RC) + + select case ( trim(GigaTrajInternalPtr%vCoord)) + case ("PL") + High = 100000. + Low = 2. + case ("TH") + High = 5000. + Low = 200. + case ("ZL") + High = 78000. + Low = 1. + end select + + delt = (log(High)-log(low))/dims(3) + levs_center=[(exp(log(High)-(i-1)*delt), i=1, dims(3))] + + if (GigaTrajInternalPtr%regrid_to_latlon) then + call get_latlon_centers(gc, lons_center, lats_center, _RC) + GigaTrajInternalPtr%metSrc = initMetGEOSDistributedLatLonData(comm, c_loc(GigaTrajInternalPtr%CellToRank), DIMS(1), DIMS(2), & + dims(3), counts(1)+2, counts(2)+2, dims(3), & + c_loc(lons_center), c_loc(lats_center), c_loc(levs_center), c_loc(ctime)) + deallocate(lons_center, lats_center) + else + call MAPL_Grid_interior(grid_, i1, i2, j1, j2) + call get_cube_centers(gc, cube_lons_center, cube_lats_center, _RC) + GigaTrajInternalPtr%metSrc = initMetGEOSDistributedCubedData(comm, c_loc(GigaTrajInternalPtr%CellToRank), DIMS(1), & + dims(3), i1, i2, j1, j2, dims(3), & + c_loc(cube_lons_center), c_loc(cube_lats_center), c_loc(levs_center), c_loc(ctime)) + + deallocate(cube_lons_center, cube_lats_center) + + endif + deallocate(levs_center) + + lm = dims(3) + d1 = counts(1) + d2 = counts(2) + + allocate(haloU(d1+2, d2+2,lm), source = 0.0) + allocate(haloV(d1+2, d2+2,lm), source = 0.0) + allocate(haloW(d1+2, d2+2,lm), source = 0.0) + allocate(haloP(d1+2, d2+2,lm), source = 0.0) + + if ( GigaTrajInternalPtr%regrid_to_latlon) then + allocate(U_latlon(d1,d2,lm)) + allocate(V_latlon(d1,d2,lm)) + allocate(W_latlon(d1,d2,lm)) + allocate(P_latlon(d1,d2,lm)) + call GigaTrajInternalPtr%cube2latlon%regrid(U, V, U_latlon, V_latlon, _RC) + call GigaTrajInternalPtr%cube2latlon%regrid(W, W_latlon, _RC) + call GigaTrajInternalPtr%cube2latlon%regrid(P, P_latlon, _RC) + + call esmf_halo(GigaTrajInternalPtr%LatLonGrid, U_Latlon, haloU, _RC) + call esmf_halo(GigaTrajInternalPtr%LatLonGrid, V_Latlon, haloV, _RC) + call esmf_halo(GigaTrajInternalPtr%LatLonGrid, W_Latlon, haloW, _RC) + call esmf_halo(GigaTrajInternalPtr%LatLonGrid, P_Latlon, haloP, _RC) + deallocate(U_latlon, V_latlon, W_latlon, P_latlon) + else + call esmf_halo(GigaTrajInternalPtr%CubedGrid, U, haloU, _RC) + call esmf_halo(GigaTrajInternalPtr%CubedGrid, V, haloV, _RC) + call esmf_halo(GigaTrajInternalPtr%CubedGrid, W, haloW, _RC) + call esmf_halo(GigaTrajInternalPtr%CubedGrid, P, haloP, _RC) + endif + + call updateFields( GigaTrajInternalPtr%metSrc, c_loc(ctime), c_loc(haloU), c_loc(haloV), c_loc(haloW), c_loc(haloP)) + + if(associated(PL0)) deallocate(PL0) + deallocate(haloU, haloV, haloW, haloP) + RETURN_(ESMF_SUCCESS) + + end subroutine init_metsrc_field0 + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) + type(ESMF_GridComp), intent(inout) :: GC ! Gridded component + type(ESMF_State), intent(inout) :: IMPORT ! Import state + type(ESMF_State), intent(inout) :: EXPORT ! Export state + type(ESMF_Clock), intent(inout) :: CLOCK ! The clock + integer, optional, intent( out) :: RC ! Error code + + character(len=ESMF_MAXSTR) :: IAm + integer :: STATUS + integer :: CSTAT, ESTAT, YY, DD + character(512) :: CMSG + character(256) :: command_line + character(19) :: begdate, enddate + character(64) :: format_string + type(ESMF_TimeInterval) :: ModelTimeStep + type(ESMF_Time) :: CurrentTime, preTime + type(ESMF_Grid) :: grid_ + + type (GigaTrajInternal), pointer :: GigaTrajInternalPtr + type (GigatrajInternalWrap) :: wrap + + integer :: lm, d1, d2, k, itemCount + integer ::counts(3), DIMS(3), comm, ierror + type (ESMF_VM) :: vm + + real, dimension(:,:,:), pointer :: U_cube, V_cube, W_cube, P_cube, PLE_Cube, with_halo + real, dimension(:,:,:), pointer :: internal_field, model_field + real, dimension(:,:,:), pointer :: tmp_ptr + + real, dimension(:,:,:), allocatable :: U_latlon, V_latlon, W_latlon, P_latlon + real, dimension(:,:,:), allocatable :: U_inter, V_inter, W_inter, P_inter + real, dimension(:,:,:), allocatable, target :: haloU, haloV, haloW, haloP + + real(ESMF_KIND_R8) :: DT + + character(len=20), target :: ctime, ctime0 + type(ESMF_State) :: INTERNAL + type(MAPL_MetaComp),pointer :: MPL + type(ESMF_Alarm) :: GigaTrajIntegrateAlarm + type(MAPL_VarSpec ), pointer:: internal_specs(:) + character(len=ESMF_MAXSTR) :: SHORT_NAME + character(len=ESMF_MAXSTR), allocatable :: item_names(:) + +!--------------- +! Update internal +!--------------- + call ESMF_UserCompGetInternalState(GC, 'GigaTrajInternal', wrap, _RC) + GigaTrajInternalPtr => wrap%ptr + call MAPL_GetObjectFromGC ( GC, MPL, _RC) + call MAPL_Get (MPL, INTERNAL_ESMF_STATE=INTERNAL, _RC) + + call ESMF_StateGet(INTERNAL, itemCount=itemCount, _RC) + allocate(item_names(itemCount)) + call ESMF_StateGet(INTERNAL, itemNameList=item_names, _RC) + + do k=1, ItemCount + call MAPL_GetPointer(Import, model_field, trim(item_names(k)), _RC) + call MAPL_GetPointer(INTERNAL, internal_field, trim(item_names(k)), _RC) + internal_field(:,:,:) = model_field(:,:,:) + enddo + deallocate(item_names) + + call ESMF_ClockGetAlarm(clock, 'GigatrajIntegrate', GigaTrajIntegrateAlarm, _RC) + + if ( .not. ESMF_AlarmIsRinging(GigaTrajIntegrateAlarm)) then + RETURN_(ESMF_SUCCESS) + endif + + call ESMF_VMGetCurrent(vm, _RC) + call ESMF_VMGet(vm, mpiCommunicator=comm, _RC) + + + call ESMF_ClockGet(clock, currTime=CurrentTime, _RC) + call ESMF_ClockGet(clock, timeStep=ModelTimeStep, _RC) + + ! W.J note: this run is after agcm's run. The clock is not yet ticked + ! So the values we are using are at (CurrentTime + ModelTimeStep) + + CurrentTime = CurrentTime + ModelTimeStep + call ESMF_TimeGet(CurrentTime, timeStringISOFrac=ctime) + ctime(20:20) = c_null_char + + preTime = CurrentTime - GigaTrajInternalPtr%Integrate_DT + call ESMF_TimeGet(preTime, timeStringISOFrac=ctime0) + ctime0(20:20) = c_null_char + + call ESMF_TimeIntervalGet(GigaTrajInternalPtr%Integrate_DT, d_r8=DT, _RC) + +!--------------- +! Step 1) Regrid the metData field from cubed to lat-lon +!--------------- + call MAPL_GetPointer(Import, U_cube, "U", _RC) + call MAPL_GetPointer(Import, V_cube, "V", _RC) + call MAPL_GetPointer(Import, W_cube, GigaTrajInternalPtr%vTendency, _RC) + call MAPL_GetPointer(Import, P_cube, GigaTrajInternalPtr%vCoord, _RC) + + lm = size(u_cube,3) + d1 = size(u_cube,1) + d2 = size(u_cube,2) + + if (GigaTrajInternalPtr%regrid_to_latlon) then + grid_ = GigaTrajInternalPtr%LatLonGrid + call MAPL_GridGet(grid_, localCellCountPerDim=counts, & + globalCellCountPerDim=DIMS, _RC) + + allocate(U_latlon(counts(1), counts(2),lm), source = 0.0) + allocate(V_latlon(counts(1), counts(2),lm), source = 0.0) + allocate(W_latlon(counts(1), counts(2),lm), source = 0.0) + allocate(P_latlon(counts(1), counts(2),lm), source = 0.0) + else + grid_ = GigaTrajInternalPtr%CubedGrid + call MAPL_GridGet(grid_, localCellCountPerDim=counts, & + globalCellCountPerDim=DIMS, _RC) + endif + + allocate(haloU(counts(1)+2, counts(2)+2,lm), source = 0.0) + allocate(haloV(counts(1)+2, counts(2)+2,lm), source = 0.0) + allocate(haloW(counts(1)+2, counts(2)+2,lm), source = 0.0) + allocate(haloP(counts(1)+2, counts(2)+2,lm), source = 0.0) + +!--------------- +! Step 2) Get halo +!--------------- + if (GigaTrajInternalPtr%regrid_to_latlon) then + + call GigaTrajInternalPtr%cube2latlon%regrid(U_cube,V_cube, U_latlon, V_latlon, _RC) + call GigaTrajInternalPtr%cube2latlon%regrid(W_cube, W_latlon, _RC) + call GigaTrajInternalPtr%cube2latlon%regrid(P_cube, P_latlon, _RC) + + call esmf_halo(grid_, U_Latlon, haloU, _RC) + call esmf_halo(grid_, V_Latlon, haloV, _RC) + call esmf_halo(grid_, W_Latlon, haloW, _RC) + call esmf_halo(grid_, P_Latlon, haloP, _RC) + + deallocate( U_Latlon, V_latlon, W_latlon, P_latlon) + else + call esmf_halo(grid_, U_cube, haloU, _RC) + call esmf_halo(grid_, V_cube, haloV, _RC) + call esmf_halo(grid_, W_cube, haloW, _RC) + call esmf_halo(grid_, P_cube, haloP, _RC) + endif + +!--------------- +! Step 3) Update +!--------------- + + call updateFields( GigaTrajInternalPtr%metSrc, c_loc(ctime), c_loc(haloU), c_loc(haloV), c_loc(haloW), c_loc(haloP)) + +!--------------- +! Step 4) Time advance +!--------------- + call RK4_advance( GigaTrajInternalPtr%metSrc, c_loc(ctime0), DT, GigaTrajInternalPtr%parcels%num_parcels, & + c_loc(GigaTrajInternalPtr%parcels%lons), & + c_loc(GigaTrajInternalPtr%parcels%lats), & + c_loc(GigaTrajInternalPtr%parcels%zs)) + + deallocate(haloU, haloV, haloW, haloP) + +!--------------- +! Step 5) rebalance parcels among processors ( configurable with alarm) +!--------------- + call rebalance_parcels(clock, GigaTrajInternalPtr%parcels, GigaTrajInternalPtr%CellToRank, comm, grid_, _RC) + +!--------------- +! Step 6) write out parcel positions and related fields ( configurable with alarm) +!--------------- + + call write_parcels(GC, import, clock, currentTime, _RC) + RETURN_(ESMF_SUCCESS) + + end subroutine Run + + subroutine esmf_halo(grid, Field,haloField, rc) + type(ESMF_Grid), intent(in) :: grid + real, dimension(:,:,:), intent(in) :: Field + real, dimension(:,:,:), intent(inout) :: haloField + integer, optional, intent( out) :: RC + + character(len=ESMF_MAXSTR) :: IAm + integer :: counts(3), k, count3 + integer :: status + type(ESMF_Field) :: halo_field + type(ESMF_RouteHandle) :: rh + real, dimension(:,:), pointer :: with_halo + + Iam = "Gigatraj ESMF Halo" + call MAPL_GridGet(grid, localCellCountPerDim=counts, _RC) + + count3 = size(field,3) ! may be nbins + + halo_field = ESMF_FieldCreate(grid, ESMF_TYPEKIND_R4, name='halo_field', & + totalLWidth=[1,1],totalUWidth=[1,1]) + call ESMF_FieldGet(halo_field, farrayPtr=with_halo, _RC) + with_halo = 0.0 + call ESMF_FieldHaloStore(halo_field, rh, _RC) + ! + ! W.Y note, the pointer with_halo's lbound is 0 + ! + do k = 1, count3 + with_halo(1:counts(1), 1:counts(2)) = Field(:,:,k) + call ESMF_FieldHalo(halo_field, rh, _RC) + haloField(:,:,k) = with_halo + enddo + + call ESMF_FieldDestroy(halo_field) + call ESMF_FieldHaloRelease(rh, _RC) + + RETURN_(ESMF_SUCCESS) + end subroutine esmf_halo + + ! move the parcels to the PE where they belong to + subroutine rebalance_parcels(clock, parcels, CellToRank, comm, grid, rc) + type(ESMF_Clock), intent(inout) :: CLOCK ! The clock + type(horde), intent(inout) :: parcels + integer, dimension(:,:), intent(in) :: CellToRank + integer :: comm + type(ESMF_Grid), intent(inout) :: grid + integer, optional, intent(out) :: rc + + integer :: status + integer :: DIMS(3) + character(len=:), allocatable :: Iam + integer :: num_parcels0, num_parcels + real, dimension(:), allocatable :: lons0, lats0, zs0 + integer, dimension(:), allocatable :: IDs0 + + integer :: i, npes, ierror, rank, my_rank, pos + real :: dlon, dlat + + real, allocatable :: lons_send(:), lats_send(:), zs_send(:) + integer, allocatable :: ids_send(:) + type(ESMF_Alarm) :: GigaTrajRebalanceAlarm + integer, allocatable :: counts_send(:),counts_recv(:), II(:), JJ(:), ranks(:) + integer, allocatable :: disp_send(:), disp_recv(:), tmp_position(:) + + Iam = "rebalance_parcels" + + call ESMF_ClockGetAlarm(clock, 'GigatrajRebalance', GigaTrajRebalanceAlarm, _RC) + + if ( .not. ESMF_AlarmIsRinging(GigaTrajRebalanceAlarm)) then + RETURN_(ESMF_SUCCESS) + endif + + call move_alloc( parcels%lons, lons0) + call move_alloc( parcels%lats, lats0) + call move_alloc( parcels%zs, zs0) + call move_alloc( parcels%IDs, IDs0) + num_parcels0 = parcels%num_parcels + + where (lons0 < -180.0) lons0 =lons0 + 360.0 + where (lons0 > 180.0) lons0 =lons0 - 360.0 + + allocate(II(num_parcels0), JJ(num_parcels0)) + call MAPL_GridGet(Grid, globalCellCountPerDim=DIMS) + if (DIMS(2) == 6*DIMS(1)) then + call MAPL_GetGlobalHorzIJIndex(num_parcels0, II, JJ, lons0/180.0*MAPL_PI, lats0/180.0*MAPL_PI, Grid=Grid, rc=status) + else + + dlon = 360.0 / DIMS(1) + dlat = 180.0 / (DIMS(2)-1) + ! DC + II = min( max(ceiling ((lons0+dlon/2.+180.0)/dlon),1), DIMS(1)) + JJ = min( max(ceiling ((lats0+dlat/2.+ 90.0)/dlat),1), DIMS(2)) + + endif + + call MPI_Comm_size(comm, npes, ierror) + call MPI_Comm_rank(comm, my_rank, ierror) + + allocate(ranks (num_parcels0)) + allocate(lons_send(num_parcels0)) + allocate(lats_send(num_parcels0)) + allocate(zs_send (num_parcels0)) + allocate(IDs_send (num_parcels0)) + + allocate(counts_send(npes)) + allocate(counts_recv(npes)) + allocate(disp_send(npes)) + allocate(disp_recv(npes)) + + do i = 1, num_parcels0 + ranks(i) = CellToRank(II(i), JJ(i)) + enddo + + do rank = 0, npes-1 + counts_send(rank+1) = count(ranks == rank) + enddo + + call MPI_AllToALL(counts_send, 1, MPI_INTEGER, counts_recv, 1, MPI_INTEGER, comm, ierror) + + disp_send = 0 + do rank = 1, npes-1 + disp_send(rank+1) = disp_send(rank)+ counts_send(rank) + enddo + disp_recv = 0 + do rank = 1, npes-1 + disp_recv(rank+1) = disp_recv(rank)+ counts_recv(rank) + enddo + + ! re-arranged lats lons, and ids + tmp_position = disp_send + parcels%num_parcels = sum(counts_recv) + num_parcels = parcels%num_parcels + allocate(parcels%lons(num_parcels )) + allocate(parcels%lats(num_parcels )) + allocate(parcels%zs (num_parcels )) + allocate(parcels%IDs (num_parcels )) + + do i = 1, num_parcels0 + rank = ranks(i) + pos = tmp_position(rank+1) +1 + lons_send(pos) = lons0(i) + lats_send(pos) = lats0(i) + zs_send(pos) = zs0(i) + IDs_send(pos) = IDs0(i) + tmp_position(rank+1) = tmp_position(rank+1) + 1 + enddo + + call MPI_AllToALLv(lons_send, counts_send, disp_send, MPI_REAL, parcels%lons, counts_recv, disp_recv, MPI_REAL, comm, ierror) + call MPI_AllToALLv(lats_send, counts_send, disp_send, MPI_REAL, parcels%lats, counts_recv, disp_recv, MPI_REAL, comm, ierror) + call MPI_AllToALLv(zs_send, counts_send, disp_send, MPI_REAL, parcels%zs, counts_recv, disp_recv, MPI_REAL, comm, ierror) + call MPI_AllToALLv(ids_send, counts_send, disp_send, MPI_INTEGER, parcels%IDs, counts_recv, disp_recv, MPI_INTEGER, comm, ierror) + + RETURN_(ESMF_SUCCESS) + end subroutine rebalance_parcels + + ! Scatter parcels from root after reading parcels file + subroutine scatter_parcels(num_parcels0, lons0, lats0, zs0, IDs0, CellToRank, Grid, comm, lons, lats, zs, IDs, num_parcels) + integer :: num_parcels0 + real, dimension(:), intent(inout) :: lons0 + real, dimension(:), intent(in) :: lats0, zs0 + integer, dimension(:), intent(in) :: IDs0 + integer, dimension(:,:), intent(in) :: CellToRank + type(ESMF_GRID), intent(inout) :: Grid + integer, intent(in) :: comm + real, dimension(:), allocatable, intent(out) :: lons, lats, zs + integer, dimension(:), allocatable, intent(out) :: IDs + integer, intent(out) :: num_parcels + + integer :: DIMS(3) + integer :: i, npes, ierror, rank, my_rank, counts_recv, pos, status + real :: dlon, dlat + + real, allocatable :: lons_send(:), lats_send(:), zs_send(:) + integer, allocatable :: ids_send(:) + + integer, allocatable :: counts_send(:), II(:), JJ(:), ranks(:) + integer, allocatable :: disp_send(:), tmp_position(:) + + call MPI_Comm_size(comm, npes, ierror) + call MPI_Comm_rank(comm, my_rank, ierror) + + call MAPL_GridGet(Grid, globalCellCountPerDim=DIMS) + + allocate(II(num_parcels0), JJ(num_parcels0)) + + allocate(counts_send(npes), source = 0) + allocate(disp_send(npes), source = 0) + where (lons0 < -180.0) lons0 =lons0 + 360.0 + where (lons0 > 180.0 ) lons0 =lons0 - 360.0 + + if (my_rank == 0) then + if (DIMS(2) == 6*DIMS(1)) then + call MAPL_GetGlobalHorzIJIndex(num_parcels0, II, JJ, lons0/180.0*MAPL_PI, lats0/180.0*MAPL_PI, Grid=Grid, rc=status) + else + dlon = 360.0 / DIMS(1) + dlat = 180.0 / (DIMS(2)-1) !PC + + II = min( max(ceiling ((lons0+dlon/2.0 + 180.0)/dlon),1), DIMS(1)) + JJ = min( max(ceiling ((lats0+dlat/2.0 + 90.0 )/dlat),1), DIMS(2)) + endif + + allocate(ranks(num_parcels0)) + do i = 1, num_parcels0 + ranks(i) = CellToRank(II(i), JJ(i)) + enddo + + do rank = 0, npes-1 + counts_send(rank+1) = count(ranks == rank) + enddo + + do rank = 1, npes-1 + disp_send(rank+1) = disp_send(rank)+ counts_send(rank) + enddo + endif + + call MPI_Scatter(counts_send, 1, MPI_INTEGER, counts_recv, 1, MPI_INTEGER, 0, comm, ierror) + + ! re-arranged lats lons, and ids + tmp_position = disp_send + num_parcels = counts_recv + + allocate(lons_send(num_parcels0)) + allocate(lons (num_parcels )) + allocate(lats_send(num_parcels0)) + allocate(lats (num_parcels )) + allocate(zs_send (num_parcels0)) + allocate(zs (num_parcels )) + allocate(IDs_send (num_parcels0)) + allocate(IDs (num_parcels )) + + if (my_rank == 0) then + do i = 1, num_parcels0 + rank = ranks(i) + pos = tmp_position(rank+1) +1 + lons_send(pos) = lons0(i) + lats_send(pos) = lats0(i) + zs_send(pos) = zs0(i) + IDs_send(pos) = IDs0(i) + tmp_position(rank+1) = tmp_position(rank+1) + 1 + enddo + endif + + call MPI_ScatterV(lons_send, counts_send, disp_send, MPI_REAL, lons, counts_recv, MPI_REAL, 0, comm, ierror) + call MPI_ScatterV(lats_send, counts_send, disp_send, MPI_REAL, lats, counts_recv, MPI_REAL, 0, comm, ierror) + call MPI_ScatterV(zs_send, counts_send, disp_send, MPI_REAL, zs, counts_recv, MPI_REAL, 0, comm, ierror) + call MPI_ScatterV(ids_send, counts_send, disp_send, MPI_INTEGER, IDs, counts_recv, MPI_INTEGER,0, comm, ierror) + + end subroutine scatter_parcels + + ! gather parcels to root for writing + subroutine gather_parcels(num_parcels0, lons0, lats0, zs0, IDs0, comm, lons, lats, zs, IDs, num_parcels) + integer, intent(out) :: num_parcels0 + real, dimension(:), allocatable, intent(out) :: lons0, lats0,zs0 + integer, dimension(:), allocatable, intent(out) :: IDs0 + integer, intent(in) :: comm + real, dimension(:), intent(in) :: lons, lats, zs + integer, dimension(:), intent(in) :: IDs + integer, intent(in) :: num_parcels + + integer :: i, npes, ierror, my_rank + integer, allocatable :: nums_all(:), displ(:) + + call MPI_Comm_size(comm, npes, ierror) + call MPI_Comm_rank(comm, my_rank, ierror) + + allocate(nums_all(npes), source = 0) + call MPI_Gather(num_parcels, 1, MPI_INTEGER, nums_all, 1, MPI_INTEGER, 0, comm, ierror) + + num_parcels0 = sum(nums_all) + + allocate(lons0(num_parcels0)) + allocate(lats0(num_parcels0)) + allocate( zs0(num_parcels0)) + allocate( IDS0(num_parcels0)) + allocate( displ(npes), source =0) + do i =2, npes + displ(i) = displ(i-1)+nums_all(i-1) + enddo + + call MPI_GatherV(lons, num_parcels, MPI_REAL, lons0, nums_all, displ, MPI_REAL, 0, comm,ierror) + call MPI_GatherV(lats, num_parcels, MPI_REAL, lats0, nums_all, displ, MPI_REAL, 0, comm,ierror) + call MPI_GatherV(zs, num_parcels, MPI_REAL, zs0, nums_all, displ, MPI_REAL, 0, comm,ierror) + call MPI_GatherV(IDS, num_parcels, MPI_INTEGER, IDs0,nums_all, displ, MPI_INTEGER, 0, comm,ierror) + + end subroutine gather_parcels + + subroutine gather_onefield(num_parcels0, field0, comm, field, num_parcels) + integer, intent(out) :: num_parcels0 + real, dimension(:), allocatable, intent(out) :: field0 + integer, intent(in) :: comm + real, dimension(:), intent(in) :: field + integer, intent(in) :: num_parcels + + integer :: i, npes, ierror, my_rank + integer, allocatable :: nums_all(:), displ(:) + + call MPI_Comm_size(comm, npes, ierror) + call MPI_Comm_rank(comm, my_rank, ierror) + + allocate(nums_all(npes), source = 0) + call MPI_Gather(num_parcels, 1, MPI_INTEGER, nums_all, 1, MPI_INTEGER, 0, comm, ierror) + + num_parcels0 = sum(nums_all) + + allocate(field0(num_parcels0)) + allocate( displ(npes), source =0) + do i =2, npes + displ(i) = displ(i-1)+nums_all(i-1) + enddo + + call MPI_GatherV(field, num_parcels, MPI_REAL, field0, nums_all, displ, MPI_REAL, 0, comm,ierror) + + end subroutine gather_onefield + + subroutine write_parcels(GC, state, CLOCK, currentTime, rc) + type(ESMF_GridComp), intent(inout) :: GC ! Gridded component + type(ESMF_State), intent(inout) :: state ! Import state + type(ESMF_Clock), intent(inout) :: CLOCK ! The clock + type(ESMF_TIME), intent(in) :: currentTime + integer, optional, intent(out) :: rc + + character(len=:), allocatable :: Iam + type (ESMF_VM) :: vm + type(Netcdf4_fileformatter) :: formatter + integer :: comm, my_rank, total_num, i, k,status, last_time, ierror, count3 + real, allocatable :: lats0(:), lons0(:), zs0(:), values(:), values0(:) + real,target, allocatable :: values_2d(:,:) + real,pointer :: field(:,:,:) + integer, allocatable :: ids0(:), ids0_in(:) + type(ESMF_Alarm) :: GigaTrajOutAlarm + type(FileMetadata) :: meta + real(ESMF_KIND_R8) :: tint_d + type(ESMF_TimeInterval) :: tint + type(MAPL_MetaComp),pointer :: MPL + character(len=ESMF_MAXSTR) :: parcels_file, other_fields + character(len=ESMF_MAXSTR), allocatable :: varnames(:) + character(len=:), allocatable:: var_name, var_, comp_name, var_alias, bdlename + + type (GigaTrajInternal), pointer :: GigaTrajInternalPtr + type (GigatrajInternalWrap) :: wrap + character(len=20), target :: ctime + character(len=:), allocatable :: vAlias + + Iam = "write_parcels" + call ESMF_ClockGetAlarm(clock, 'GigatrajOut', GigaTrajOutAlarm, _RC) + + if ( .not. ESMF_AlarmIsRinging(GigaTrajOutAlarm)) then + RETURN_(ESMF_SUCCESS) + endif + + call MAPL_GetObjectFromGC ( GC, MPL, _RC) + call ESMF_UserCompGetInternalState(GC, 'GigaTrajInternal', wrap, _RC) + GigaTrajInternalPtr => wrap%ptr + + call MAPL_GetResource(MPL, parcels_file, "GIGATRAJ_PARCELS_FILE:", default='parcels.nc4', _RC) + + call ESMF_VMGetCurrent(vm, _RC) + call ESMF_VMGet(vm, mpiCommunicator=comm, _RC) + call gather_parcels(total_num, lons0, lats0, zs0, IDs0, & + comm, & + GigaTrajInternalPtr%parcels%lons, & + GigaTrajInternalPtr%parcels%lats, & + GigaTrajInternalPtr%parcels%zs, & + GigaTrajInternalPtr%parcels%IDS, & + GigaTrajInternalPtr%parcels%num_parcels ) + + call MPI_Comm_rank(comm, my_rank, ierror); _VERIFY(ierror) + if (my_rank ==0) then + if (GigaTrajInternalPtr%vCoord == 'PL') then + zs0 = zs0 / 100.0 ! hard coded, conert Pa back to hPa + endif + ! reorder + ids0 = ids0 + 1 ! element start 0, make it to 1 for ordering + ids0(ids0) = [(k, k=1,size(ids0))] + + ! test if ordering is right + ! ids0_in = ids0 + ! ids0_in = ids0_in(ids0) + ! do k = 1, size(ids0) + ! if (k /= ids0_in(k)) then + ! RETURN_(-1) + ! endif + ! enddo + + lats0 = lats0(ids0(:)) ! id is zero-bases, plus 1 Fortran + lons0 = lons0(ids0(:)) + where (lons0 > 180.0) lons0 = lons0 - 360. + where (lons0 < -180.0) lons0 = lons0 + 360. + zs0 = zs0(ids0(:)) + call formatter%open(trim(parcels_file), pFIO_WRITE, _RC) + meta = formatter%read(_RC) + last_time = meta%get_dimension('time', _RC) + tint = CurrentTime - GigaTrajInternalPtr%startTime + call ESMF_TimeIntervalGet(tint,d_r8=tint_d,rc=status) + + call formatter%put_var('lat', lats0, start=[1, last_time+1], _RC) + call formatter%put_var('lon', lons0, start=[1, last_time+1], _RC) + call formatter%put_var(GigaTrajInternalPtr%vAlias, zs0, start=[1, last_time+1], _RC) + call formatter%put_var('time', [tint_d], start=[last_time+1], _RC) + endif + + ! extra fields + if (allocated(GigaTrajInternalPtr%ExtraFieldNames)) then + call ESMF_TimeGet(CurrentTime, timeStringISOFrac=ctime) + ctime(20:20) = c_null_char + do k = 1, size(GigaTrajInternalPtr%ExtraFieldNames) + comp_name = trim(GigaTrajInternalPtr%ExtraCompNames(k)) + var_name = trim(GigaTrajInternalPtr%ExtraFieldNames(k)) + bdlename = trim(GigaTrajInternalPtr%ExtraBundleNames(k)) + var_alias = trim(GigaTrajInternalPtr%ExtraAliasNames(k)) + + if ( index(var_name, 'bcDP') /= 0 .or. & + index(var_name, 'ocDP') /= 0 .or. & + index(var_name, 'bcWT') /= 0 .or. & + index(var_name, 'ocWT') /= 0 .or. & + index(var_name, 'bcSD') /= 0 .or. & + index(var_name, 'ocSD') /= 0 .or. & + index(var_name, 'bcSV') /= 0 .or. & + index(var_name, 'ocSV') /= 0 ) then + + call MAPL_GetPointer(state, field, var_name, _RC) + count3 = size(field,3) + allocate(values_2d(GigaTrajInternalPtr%parcels%num_parcels, count3)) + call get_metsrc_data2d (GC, state, ctime, var_name, values_2d, RC ) + do i = 1, count3 + call gather_onefield(total_num, values0, comm, values_2d(:,i), GigaTrajInternalPtr%parcels%num_parcels) + + if (my_rank == 0) then + values0 = values0(ids0(:)) + var_ = var_alias //'00'//i_to_string(i) + if ( meta%has_variable(var_)) then + call formatter%put_var( var_, values0, start=[1, last_time+1], _RC) + else + print*, "Please provide "//var_ // " in the file "//trim(parcels_file) + endif + endif + enddo + deallocate(values_2d) + else if ( index(var_name, 'TRI') /= 0) then + allocate(values(GigaTrajInternalPtr%parcels%num_parcels)) + allocate(varnames(4)) + varnames(1) = "CA.bc::CA.bcphilicIT" + varnames(2) = "CA.bc::CA.bcphobicIT" + varnames(3) = "CA.oc::CA.ocphilicIT" + varnames(4) = "CA.oc::CA.ocphobicIT" + do i = 1, 4 + var_ = varnames(i)(8:) + call get_metsrc_data (GC, state, ctime, comp_name, bdlename, varnames(i), values, _RC) + call gather_onefield(total_num, values0, comm, values, GigaTrajInternalPtr%parcels%num_parcels) + + if (my_rank == 0) then + values0 = values0(ids0(:)) + if ( meta%has_variable(var_)) then + call formatter%put_var( var_, values0, start=[1, last_time+1], _RC) + else + print*, "Please provide "//var_ // " in the file "//trim(parcels_file) + endif + endif + enddo + deallocate(values, varnames) + else + allocate(values(GigaTrajInternalPtr%parcels%num_parcels)) + call get_metsrc_data (GC, state, ctime, comp_name, bdlename, var_name, values, _RC ) + call gather_onefield(total_num, values0, comm, values, GigaTrajInternalPtr%parcels%num_parcels) + if (my_rank == 0) then + values0 = values0(ids0(:)) + if ( meta%has_variable(var_alias)) then + if(var_alias == 'P') values0 = values0/100.0 ! hard coded to hPa + call formatter%put_var( var_alias, values0, start=[1, last_time+1], _RC) + else + print*, "Please provide "//var_alias // " in the file "//trim(parcels_file) + endif + endif + deallocate(values) + endif + enddo + endif + + if (my_rank ==0) then + call formatter%close(_RC) + endif + RETURN_(ESMF_SUCCESS) + contains + + end subroutine write_parcels + + subroutine read_parcels(GC,internal, rc) + type(ESMF_GridComp), intent(inout) :: GC + type(GigaTrajInternal), intent(inout) :: internal + integer, optional, intent(out) :: rc + + type(Netcdf4_fileformatter) :: formatter + type(FileMetadata) :: meta + integer :: comm, my_rank, total_num, ierror, last_time + real, allocatable :: lats0(:), lons0(:), zs0(:) + !real(kind=ESMF_KIND_R8), allocatable :: ids0_r(:) + integer, allocatable :: ids0(:) + integer :: status, k + character(len=ESMF_MAXSTR) :: parcels_file + character(len=ESMF_MAXSTR) :: regrid_to_latlon + type(MAPL_MetaComp),pointer :: MPL + type (ESMF_VM) :: vm + type (ESMF_GRID) :: grid_ + class(Variable), pointer :: t + type(Attribute), pointer :: attr + class(*), pointer :: units + character(len=ESMF_MAXSTR) :: Iam ="read_parcels" + + call ESMF_VMGetCurrent(vm, _RC) + call ESMF_VMGet(vm, mpiCommunicator=comm, _RC) + + call MPI_Comm_rank(comm, my_rank, ierror); _VERIFY(ierror) + call MAPL_GetObjectFromGC ( GC, MPL, _RC) + call MAPL_GetResource(MPL, parcels_file, "GIGATRAJ_PARCELS_FILE:", default='parcels.nc4', _RC) + total_num = 0 + if (my_rank ==0) then + call formatter%open(parcels_file, pFIO_READ, _RC) + meta = formatter%read(_RC) + total_num = meta%get_dimension('id', _RC) + last_time = meta%get_dimension('time', _RC) + t => meta%get_variable('time', _RC) + attr => t%get_attribute('long_name') + units => attr%get_value() + select type(units) + type is (character(*)) + internal%startTime = parse_time_string(units, _RC) + class default + _FAIL('unsupported subclass for units') + end select + endif + + allocate(lats0(total_num), lons0(total_num), zs0(total_num),ids0(total_num)) + + if (my_rank ==0) then + call formatter%get_var('lat', lats0, start = [1,last_time], _RC) + call formatter%get_var('lon', lons0, start = [1,last_time], _RC) + call formatter%get_var(internal%vAlias,zs0, start = [1,last_time], _RC) + if (internal%vCoord == 'PL') zs0 = zs0*100.0 ! hard coded from hPa to Pa + call formatter%close(_RC) + ids0 = [(k, k=0,total_num-1)] + endif + call MAPL_GetResource(MPL, regrid_to_latlon, "GIGATRAJ_REGRID_TO_LATLON:", default= 'YES' , _RC) + if (trim (regrid_to_latlon) == 'YES') then + grid_ = internal%LatLonGrid + else + grid_ = internal%CubedGrid + endif + call scatter_parcels(total_num, lons0, lats0, zs0, IDs0, internal%CellToRank, grid_, comm, & + Internal%parcels%lons, & + Internal%parcels%lats, & + Internal%parcels%zs, & + Internal%parcels%IDS, & + Internal%parcels%num_parcels) + + RETURN_(ESMF_SUCCESS) + contains + ! a copy from MAPL_TimeMod + function parse_time_string(timeUnits,rc) result(time) + character(len=*), intent(inout) :: timeUnits + integer, optional, intent(out) :: rc + + type(ESMF_Time) :: time + integer :: status + + integer year ! 4-digit year + integer month ! month + integer day ! day + integer hour ! hour + integer min ! minute + integer sec ! second + + integer ypos(2), mpos(2), dpos(2), hpos(2), spos(2) + integer strlen + integer firstdash, lastdash + integer firstcolon, lastcolon + integer lastspace + strlen = LEN_TRIM (TimeUnits) + + firstdash = index(TimeUnits, '-') + lastdash = index(TimeUnits, '-', BACK=.TRUE.) + if (firstdash .LE. 0 .OR. lastdash .LE. 0) then + _FAIL('time string is not a valid format') + endif + ypos(2) = firstdash - 1 + mpos(1) = firstdash + 1 + ypos(1) = ypos(2) - 3 + + mpos(2) = lastdash - 1 + dpos(1) = lastdash + 1 + dpos(2) = dpos(1) + 1 + + read ( TimeUnits(ypos(1):ypos(2)), * ) year + read ( TimeUnits(mpos(1):mpos(2)), * ) month + read ( TimeUnits(dpos(1):dpos(2)), * ) day + + firstcolon = index(TimeUnits, ':') + if (firstcolon .LE. 0) then + + ! If no colons, check for hour. + + ! Logic below assumes a null character or something else is after the hour + ! if we do not find a null character add one so that it correctly parses time + if (TimeUnits(strlen:strlen) /= char(0)) then + TimeUnits = trim(TimeUnits)//char(0) + strlen=len_trim(TimeUnits) + endif + lastspace = index(TRIM(TimeUnits), ' ', BACK=.TRUE.) + if ((strlen-lastspace).eq.2 .or. (strlen-lastspace).eq.3) then + hpos(1) = lastspace+1 + hpos(2) = strlen-1 + read (TimeUnits(hpos(1):hpos(2)), * ) hour + min = 0 + sec = 0 + else + hour = 0 + min = 0 + sec = 0 + endif + else + hpos(1) = firstcolon - 2 + hpos(2) = firstcolon - 1 + lastcolon = index(TimeUnits, ':', BACK=.TRUE.) + if ( lastcolon .EQ. firstcolon ) then + mpos(1) = firstcolon + 1 + mpos(2) = firstcolon + 2 + read (TimeUnits(hpos(1):hpos(2)), * ) hour + read (TimeUnits(mpos(1):mpos(2)), * ) min + sec = 0 + else + mpos(1) = firstcolon + 1 + mpos(2) = lastcolon - 1 + spos(1) = lastcolon + 1 + spos(2) = lastcolon + 2 + read (TimeUnits(hpos(1):hpos(2)), * ) hour + read (TimeUnits(mpos(1):mpos(2)), * ) min + read (TimeUnits(spos(1):spos(2)), * ) sec + endif + endif + + call ESMF_TimeSet(time,yy=year,mm=month,dd=day,h=hour,m=min,s=sec,rc=status) + _VERIFY(status) + RETURN_(ESMF_SUCCESS) + end function parse_time_string + end subroutine read_parcels + + subroutine get_metsrc_data (GC, state, ctime, compname, bundlename, fieldname, values, RC ) + type(ESMF_GridComp), intent(inout) :: GC ! Gridded component + type(ESMF_State), intent(inout) :: state + character(*), target, intent(in) :: ctime + character(*), intent(in) :: compname + character(*), intent(in) :: bundlename + character(*), intent(in) :: fieldname + real, target, intent(inout) :: values(:) + integer, optional, intent(out) :: RC ! Error code + + character(len=ESMF_MAXSTR) :: IAm + integer :: STATUS + + type(GigaTrajInternal), pointer :: GigaTrajInternalPtr + type (GigatrajInternalWrap) :: wrap + type (ESMF_FieldBundle) :: bdle + type (ESMF_GRID) :: grid_ + type(ESMF_State) :: leaf_export + real, dimension(:,:,:), pointer :: ptr3d + real, dimension(:,:,:), allocatable :: field_latlon + + real, dimension(:,:,:), allocatable, target :: haloField + integer :: counts(3), dims(3), d1, d2, lm, count3 + character(len=:), target, allocatable :: field_ + + Iam = "get_metsrc_data" + + !if (index(fieldname,'philicIT') /=0 .or. index(fieldname,'phobicIT') /=0) then + ! call ESMF_StateGet(state, 'PHYSICS_Exports/TURBULENCE_Exports/TRI', TRI, _RC) + ! call ESMF_FieldBundleGet(TRI, fieldname, field=field, _RC) + ! call ESMF_FieldGet(field,farrayPtr=ptr3d, _RC) + !else + ! call MAPL_GetPointer(state, ptr3d, fieldname, _RC) + !endif + + call MAPL_ExportStateGet([state], trim(compname), leaf_export, _RC) + if (trim(bundlename) /= 'NONE') then + call ESMF_StateGet(leaf_export, trim(bundlename), bdle, _RC) + call ESMFL_BundleGetPointerToData(bdle, fieldname, ptr3d, _RC) + else + call MAPL_GetPointer(leaf_export, ptr3d, fieldname, _RC) + endif + + call ESMF_UserCompGetInternalState(GC, 'GigaTrajInternal', wrap, _RC) + GigaTrajInternalPtr => wrap%ptr + + lm = size(ptr3d,3) + d1 = size(ptr3d,1) + d2 = size(ptr3d,2) + + if (GigaTrajInternalPtr%regrid_to_latlon) then + grid_ = GigaTrajInternalPtr%LatLonGrid + call MAPL_GridGet(grid_, localCellCountPerDim=counts,globalCellCountPerDim=DIMS, _RC) + allocate(field_latlon(counts(1),counts(2), lm)) + else + grid_ = GigaTrajInternalPtr%CubedGrid + call MAPL_GridGet(grid_, localCellCountPerDim=counts,globalCellCountPerDim=DIMS, _RC) + endif + + allocate(haloField(counts(1)+2, counts(2)+2, lm), source = 0.0) + + if (GigaTrajInternalPtr%regrid_to_latlon) then + call GigaTrajInternalPtr%cube2latlon%regrid(ptr3d, Field_latlon, _RC) + call esmf_halo(grid_, Field_latlon, haloField, _RC) + deallocate(Field_latlon) + else + call esmf_halo(grid_, ptr3d, haloField, _RC) + endif + + field_ = trim(fieldname)//c_null_char + call setData( GigaTrajInternalPtr%metSrc, c_loc(ctime), c_loc(field_), c_loc(haloField)) + call getData(GigaTrajInternalPtr%metSrc, c_loc(ctime), c_loc(field_), & + GigaTrajInternalPtr%parcels%num_parcels, & + c_loc(GigaTrajInternalPtr%parcels%lons), & + c_loc(GigaTrajInternalPtr%parcels%lats), & + c_loc(GigaTrajInternalPtr%parcels%zs), & + c_loc(values)) + + deallocate(haloField) + RETURN_(ESMF_SUCCESS) + + end subroutine get_metsrc_data + + subroutine get_metsrc_data2d (GC, state, ctime, fieldname, values, RC ) + type(ESMF_GridComp), intent(inout) :: GC ! Gridded component + type(ESMF_State), intent(inout) :: state + character(*), target, intent(in) :: ctime + character(*), intent(in) :: fieldname + real, target, intent(inout) :: values(:,:) + integer, optional, intent(out) :: RC ! Error code + + character(len=ESMF_MAXSTR) :: IAm + integer :: STATUS + + type(GigaTrajInternal), pointer :: GigaTrajInternalPtr + type (GigatrajInternalWrap) :: wrap + type (ESMF_GRID) :: grid_ + real, dimension(:,:,:), pointer :: field + real, dimension(:,:,:), allocatable :: field_latlon + real, dimension(:,:,:), allocatable, target :: haloField + integer :: counts(3), i, count3 + character(len=:), target, allocatable :: field_ + + Iam = "get_metsrc_data" + + call MAPL_GetPointer(state, field, fieldname, _RC) + count3 = size(field,3) + + call ESMF_UserCompGetInternalState(GC, 'GigaTrajInternal', wrap, _RC) + GigaTrajInternalPtr => wrap%ptr + if (GigaTrajInternalPtr%regrid_to_latlon) then + grid_ = GigaTrajInternalPtr%LatLonGrid + else + grid_ = GigaTrajInternalPtr%CubedGrid + endif + + call MAPL_GridGet(grid_, localCellCountPerDim=counts, _RC) + + allocate(field_latlon(counts(1),counts(2),count3)) + allocate(haloField(counts(1)+2, counts(2)+2,count3), source = 0.0) + + if (GigaTrajInternalPtr%regrid_to_latlon) then + call GigaTrajInternalPtr%cube2latlon%regrid(field, Field_latlon, _RC) + call esmf_halo(grid_, Field_latlon, haloField, _RC) + else + call esmf_halo(grid_, field, haloField, _RC) + endif + + field_ = trim(fieldname)//'_2D'//c_null_char + + do i = 1,count3 + + call setData( GigaTrajInternalPtr%metSrc, c_loc(ctime), c_loc(field_), c_loc(haloField(1,1,i))) + call getData2d(GigaTrajInternalPtr%metSrc, c_loc(ctime), c_loc(field_), & + GigaTrajInternalPtr%parcels%num_parcels, & + c_loc(GigaTrajInternalPtr%parcels%lons), & + c_loc(GigaTrajInternalPtr%parcels%lats), & + c_loc(values(1,i))) + + enddo + deallocate(field_latlon, haloField, field_) + RETURN_(ESMF_SUCCESS) + + end subroutine get_metsrc_data2d + +end module GEOS_GigatrajGridCompMod diff --git a/GEOSgigatraj_GridComp/Gigatraj_Utils.F90 b/GEOSgigatraj_GridComp/Gigatraj_Utils.F90 new file mode 100644 index 000000000..bb77ed1a3 --- /dev/null +++ b/GEOSgigatraj_GridComp/Gigatraj_Utils.F90 @@ -0,0 +1,291 @@ +#include "MAPL_Generic.h" + +module Gigatraj_UtilsMod + use, intrinsic :: iso_c_binding, only : c_int, c_ptr, c_null_ptr, c_associated, c_null_char + use, intrinsic :: iso_c_binding, only : c_loc + + use ESMF + use MAPL + use mpi + implicit none + public :: parseCompsAndFieldsName + public :: create_new_vars + public :: get_levels + public :: get_latlon_centers + public :: get_cube_centers + public :: horde + public :: GigaTrajInternal + public :: GigatrajInternalWrap + + type horde + integer :: num_parcels + integer, allocatable :: IDS(:) + real, allocatable :: lats(:), lons(:), zs(:) + end type + + type GigaTrajInternal + integer :: npes + integer :: npz ! number of pressure levels + type (ESMF_Grid) :: LatLonGrid + type (ESMF_Grid) :: CubedGrid + class (AbstractRegridder), pointer :: cube2latlon => null() + integer, allocatable :: CellToRank(:,:) + type(horde) :: parcels + type(c_ptr) :: metSrc + type(ESMF_Time) :: startTime + type(ESMF_TimeInterval) :: Integrate_DT + character(len=ESMF_MAXSTR), allocatable :: ExtraFieldNames(:) + character(len=ESMF_MAXSTR), allocatable :: ExtraCompNames(:) + character(len=ESMF_MAXSTR), allocatable :: ExtrabundleNames(:) + character(len=ESMF_MAXSTR), allocatable :: ExtraAliasNames(:) + + character(len=:), allocatable :: vCoord + character(len=:), allocatable :: vAlias + character(len=:), allocatable :: vTendency + + logical :: regrid_to_latlon + end type + + type GigatrajInternalWrap + type (GigaTrajInternal), pointer :: PTR + end type + +contains + + subroutine parseCompsAndFieldsName(fields_line, CompNames, BundleNames, FieldNames, AliasNames) + character(*), intent(in) :: fields_line + character(len=ESMF_MAXSTR), allocatable, intent(out) :: CompNames(:) + character(len=ESMF_MAXSTR), allocatable, intent(out) :: BundleNames(:) + character(len=ESMF_MAXSTR), allocatable, intent(out) :: FieldNames(:) + character(len=ESMF_MAXSTR), allocatable, intent(out) :: AliasNames(:) + integer :: num_field, i, j, k, l, endl, num_ + character(len=:), allocatable :: tmp, tmp_bnf, tmp_f, tmp_alias + num_field = 1 + k = 1 + do + i = index(fields_line(k:),';') + if (i == 0) exit + if (trim(fields_line(i+1:)) =='') exit ! take care of the last unnecessay ";" + k = k+i + num_field = num_field+1 + enddo + + allocate(Fieldnames(num_field)) + allocate(Compnames(num_field)) + allocate(BundleNames(num_field)) + allocate(AliasNames(num_field)) + + k = 1 + num_ = 1 + + do + i = index(fields_line(k:),';') + if (i == 0) then + endl = len(fields_line) + else + endl = (k-1)+i-1 + endif + tmp = fields_line(k:endl) + + j = index(tmp, '%%') + if (j /= 0) then ! there is bundle + Compnames(num_) = trim(adjustl(tmp(1:j-1))) + tmp_bnf = trim(adjustl(tmp(j+2:))) + l = index(tmp_bnf, '%') + if (l /=0) then + BundleNames(num_) = tmp_bnf(1:l-1) + tmp_f = tmp_bnf(l+1:) + else + print*, "%field is a must" + endif + else + BundleNames(num_) = 'NONE' + j = index(tmp, '%') + Compnames(num_) = trim(adjustl(tmp(1:j-1))) + tmp_f = tmp(j+1:) + endif + + ! Aliasing....., Hard coded here + l = index(tmp_f, '|') + if (l /=0) then + FieldNames(num_) = tmp_f(1:l-1) + tmp_alias = tmp_f(l+1:) + else + FieldNames(num_) = tmp_f + tmp_alias = tmp_f + endif + + AliasNames(num_) = tmp_alias + + num_ = num_ + 1 + k = endl + 2 + if (num_ > num_field) exit + enddo + end subroutine parseCompsAndFieldsName + + subroutine create_new_vars(meta, formatter, long_name, short_name, units) + type(FileMetadata), intent(inout) :: meta + type(Netcdf4_fileformatter), intent(inout) :: formatter + character(*), intent(in) :: long_name + character(*), intent(in) :: short_name + character(*), intent(in) :: units + type(Variable) :: var + character(len=:), allocatable :: var_name + if (MAPL_AM_I_Root()) then + if( meta%has_variable(short_name)) return + var_name = short_name + var = variable(type=pFIO_REAL32, dimensions='id,time') + call var%add_attribute('long_name', long_name) + call var%add_attribute('units', units) + call var%add_attribute('positive', "up") + call var%add_attribute('_FillValue', -999.99) + call var%add_attribute('missing_value', -999.99) + call meta%add_variable(var_name, var) + call formatter%add_variable(meta, short_name) + endif + end subroutine create_new_vars + + subroutine get_levels(P, func, levels, rc) + real, dimension(:,:,:), intent(in) :: P + character(*), intent(in) :: func + real, dimension(:), intent(out) :: levels + integer, optional, intent(out) :: rc + logical :: positive + type (ESMF_VM) :: vm + integer :: comm, lm, status, i, ll + real :: local_min_val, local_max_val, lev01, levLm, delt + real, allocatable :: temp(:,:) + character(:), allocatable :: Iam + + Iam = "get_levels" + + lm = size(P,3) + + call ESMF_VMgetCurrent(vm) + call ESMF_VMGet(vm, mpiCommunicator = comm, rc = status) + positive = P(1,1,1) < P(1,1,2) + if (positive) then + local_min_val = maxval(P(:,:,1)) + call MPI_Allreduce(lev01, local_min_val,1, MPI_FLOAT, MPI_MIN, comm, status) + temp = P(:,:,lm) + where(temp >= MAPL_UNDEF) temp = -MAPL_UNDEF + local_max_val = maxval(temp) + call MPI_Allreduce(levLm, local_max_val,1, MPI_FLOAT, MPI_MAX, comm, status) + else + local_min_val = minval(P(:,:,lm)) + call MPI_Allreduce(levLm, local_min_val,1, MPI_FLOAT, MPI_MIN, comm, status) + temp = P(:,:,1) + where(temp >= MAPL_UNDEF) temp = -MAPL_UNDEF + local_max_val = maxval(temp) + call MPI_Allreduce(lev01, local_max_val,1, MPI_FLOAT, MPI_MAX, comm, status) + endif + + ll = size(levels) + + if (trim(func) == 'log') then + delt = (log(levLm)-log(lev01))/(lm-1) + levels =[ (exp(log(lev01)+i*delt), i=0, ll-1)] + else + delt = (levLm-lev01)/(lm-1) + levels =[ (lev01 + i*delt, i=0, ll-1)] + endif + + end subroutine get_levels + + subroutine get_cube_centers(GC, lon_center, lat_center, rc) + type(ESMF_GridComp), intent(inout) :: GC ! Gridded component + real, allocatable, intent(out) :: lat_center(:,:), lon_center(:,:) + integer, optional, intent( out) :: RC + integer :: i1, i2, j1, j2, imc, jmc, status + real(ESMF_KIND_R8), pointer :: centerX(:,:) + real(ESMF_KIND_R8), pointer :: centerY(:,:) + real(ESMF_KIND_R8), pointer :: ptr(:,:) + type(ESMF_Field) :: field + type(ESMF_RouteHandle) :: rh + type (GigaTrajInternal), pointer :: GigaTrajInternalPtr + type (GigatrajInternalWrap) :: wrap + type(ESMF_Grid) :: grid_ + character(:), allocatable :: Iam + Iam="get_cube_centers,cube with halo" + + call ESMF_UserCompGetInternalState(GC, 'GigaTrajInternal', wrap, status); _VERIFY(STATUS) + GigaTrajInternalPtr => wrap%ptr + grid_ = GigaTrajInternalPtr%CubedGrid + call MAPL_Grid_interior(Grid_, i1,i2,j1,j2) + imc = i2-i1 + 1 + jmc = j2-j1 + 1 + + allocate(lon_center(imc+2, jmc+2)) + allocate(lat_center(imc+2, jmc+2)) + + field = ESMF_FieldCreate(Grid_, ESMF_TYPEKIND_R8, name='halo', staggerLoc=ESMF_STAGGERLOC_CENTER,totalLWidth=[1,1],totalUWidth=[1,1],_RC) + call ESMF_FieldGet(field,farrayPtr=ptr,_RC) + ptr = 0.0d0 + call ESMF_FieldHaloStore(field,rh,_RC) + + call ESMF_GridGetCoord(grid_ , coordDim=1, localDE=0, & + staggerloc=ESMF_STAGGERLOC_CENTER, & + farrayPtr=centerX, _RC) + + ptr(1:imc,1:jmc)=centerX + call ESMF_FieldHalo(field,rh, _RC) + lon_center = ptr + + call ESMF_GridGetCoord(grid_ , coordDim=2, localDE=0, & + staggerloc=ESMF_STAGGERLOC_CENTER, & + farrayPtr=centerY, _RC) + ptr = 0.0d0 + ptr(1:imc,1:jmc)=centerY + call ESMF_FieldHalo(field,rh, _RC) + lat_center = ptr + + lon_center = lon_center/MAPL_PI*180.0 + lat_center = lat_center/MAPL_PI*180.0 + where (lon_center < -180.) lon_center = lon_center + 360. + where (lon_center > 180.) lon_center = lon_center - 360. + call ESMF_FieldDestroy(field,_RC) + call ESMF_FieldHaloRelease(rh,_RC) + _RETURN(_SUCCESS) + end subroutine get_cube_centers + + subroutine get_latlon_centers(GC, lon_center, lat_center, rc) + type(ESMF_GridComp), intent(inout) :: GC ! Gridded component + real, allocatable, intent(out) :: lat_center(:), lon_center(:) + integer, optional, intent( out) :: RC + integer :: i1, i2, j1, j2, imc, jmc, i, j, status, DIMS(3) + real :: dlon, dlat + type (GigaTrajInternal), pointer :: GigaTrajInternalPtr + type (GigatrajInternalWrap) :: wrap + type(ESMF_Grid) :: grid_ + character(len=:), allocatable :: Iam + Iam="get_latlon_centers, latlon with halo" + + + call ESMF_UserCompGetInternalState(GC, 'GigaTrajInternal', wrap, status); _VERIFY(STATUS) + GigaTrajInternalPtr => wrap%ptr + grid_ = GigaTrajInternalPtr%LatLonGrid + call MAPL_GridGet(Grid_, globalCellCountPerDim=DIMS, _RC) + call MAPL_Grid_interior(Grid_, i1,i2,j1,j2) + imc = i2-i1 + 1 + jmc = j2-j1 + 1 + + allocate(lon_center(imc+2)) + allocate(lat_center(jmc+2)) + + dlon = 360.0/dims(1) + ! DE + !lons_center = [(dlon*(i-1)+dlon/2., i= i1-1, i2+1)] + ! DC + lon_center = [(dlon*(i-1) - 180.0 , i= i1-1, i2+1)] + !PE + !dlat = 180.0/dims(2) + !lats_center = [(-dlat/2. + dlat*j-90.0, j= j1-1, j2+1)] + !PC + dlat = 180.0/(dims(2)-1) ! PC + lat_center = [(-90.0 + (j-1)*dlat, j= j1-1, j2+1)] + where(lat_center <-90.) lat_center = -90. + where(lat_center >90. ) lat_center = 90. + _RETURN(_SUCCESS) + end subroutine get_latlon_centers + +end module diff --git a/GEOSmkiau_GridComp/CMakeLists.txt b/GEOSmkiau_GridComp/CMakeLists.txt index 213c2776d..283c5981a 100644 --- a/GEOSmkiau_GridComp/CMakeLists.txt +++ b/GEOSmkiau_GridComp/CMakeLists.txt @@ -1,5 +1,7 @@ esma_set_this() +option(BUILD_PYMKIAU_INTERFACE "Build pyMKIAU interface" OFF) + set (srcs IAU_GridCompMod.F90 GEOS_mkiauGridComp.F90 @@ -8,6 +10,90 @@ set (srcs DynVec_GridComp.F90 ) -set(dependencies MAPL_cfio_r4 NCEP_sp_r4i4 GEOS_Shared GMAO_mpeu MAPL FVdycoreCubed_GridComp ESMF::ESMF NetCDF::NetCDF_Fortran) -esma_add_library (${this} SRCS ${srcs} DEPENDENCIES ${dependencies}) +if (BUILD_PYMKIAU_INTERFACE) + list (APPEND srcs + pyMKIAU/interface/interface.f90 + pyMKIAU/interface/interface.c) + + message(STATUS "Building pyMKIAU interface") + + add_definitions(-DPYMKIAU_INTEGRATION) + + # The Python library creation requires mpiexec/mpirun to run on a + # compute node. Probably a weird SLURM thing? + find_package(Python3 COMPONENTS Interpreter REQUIRED) + + # Set up some variables in case names change + set(PYMKIAU_INTERFACE_LIBRARY ${CMAKE_CURRENT_BINARY_DIR}/libpyMKIAU_interface_py.so) + set(PYMKIAU_INTERFACE_HEADER_FILE ${CMAKE_CURRENT_BINARY_DIR}/pyMKIAU_interface_py.h) + set(PYMKIAU_INTERFACE_FLAG_HEADER_FILE ${CMAKE_CURRENT_SOURCE_DIR}/pyMKIAU/interface/interface.h) + set(PYMKIAU_INTERFACE_SRCS ${CMAKE_CURRENT_SOURCE_DIR}/pyMKIAU/interface/interface.py) + + # This command creates the shared object library from Python + add_custom_command( + OUTPUT ${PYMKIAU_INTERFACE_LIBRARY} + # Note below is essentially: + # mpirun -np 1 python file + # but we use the CMake options as much as we can for flexibility + COMMAND ${CMAKE_COMMAND} -E copy_if_different ${PYMKIAU_INTERFACE_FLAG_HEADER_FILE} ${CMAKE_CURRENT_BINARY_DIR} + COMMAND ${MPIEXEC_EXECUTABLE} ${MPIEXEC_NUMPROC_FLAG} 1 ${Python3_EXECUTABLE} ${PYMKIAU_INTERFACE_SRCS} + BYPRODUCTS ${PYMKIAU_INTERFACE_HEADER_FILE} + WORKING_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR} + MAIN_DEPENDENCY ${PYMKIAU_INTERFACE_SRCS} + COMMENT "Building pyMKIAU interface library with Python" + VERBATIM + ) + + # This creates a target we can use for dependencies and post build + add_custom_target(generate_pyMKIAU_interface_library DEPENDS ${PYMKIAU_INTERFACE_LIBRARY}) + # Because of the weird hacking of INTERFACE libraries below, we cannot + # use the "usual" CMake calls to install() the .so. I think it's because + # INTERFACE libraries don't actually produce any artifacts as far as + # CMake is concerned. So we add a POST_BUILD custom command to "install" + # the library into install/lib + add_custom_command(TARGET generate_pyMKIAU_interface_library + POST_BUILD + # We first need to make a lib dir if it doesn't exist. If not, then + # the next command can copy the script into a *file* called lib because + # of a race condition (if install/lib/ isn't mkdir'd first) + COMMAND ${CMAKE_COMMAND} -E make_directory ${CMAKE_INSTALL_PREFIX}/lib + # Now we copy the file (if different...though not sure if this is useful) + COMMAND ${CMAKE_COMMAND} -E copy_if_different "${PYMKIAU_INTERFACE_LIBRARY}" ${CMAKE_INSTALL_PREFIX}/lib + ) + + # We use INTERFACE libraries to create a sort of "fake" target library we can use + # to make libFVdycoreCubed_GridComp.a depend on. It seems to work! + add_library(pyMKIAU_interface_py INTERFACE) + + # The target_include_directories bits were essentially stolen from the esma_add_library + # code... + target_include_directories(pyMKIAU_interface_py INTERFACE + $ + $ # stubs + # modules and copied *.h, *.inc + $ + $ + ) + target_link_libraries(pyMKIAU_interface_py INTERFACE ${PYMKIAU_INTERFACE_LIBRARY}) + + # This makes sure the library is built first + add_dependencies(pyMKIAU_interface_py generate_pyMKIAU_interface_library) + + # This bit is to resolve an issue and Google told me to do this. I'm not + # sure that the LIBRARY DESTINATION bit actually does anything since + # this is using INTERFACE + install(TARGETS pyMKIAU_interface_py + EXPORT ${PROJECT_NAME}-targets + LIBRARY DESTINATION ${CMAKE_INSTALL_PREFIX}/lib + ) + +endif () + +if (BUILD_PYMKIAU_INTERFACE) + set(dependencies pyMKIAU_interface_py MAPL_cfio_r4 NCEP_sp_r4i4 GEOS_Shared GMAO_mpeu MAPL FVdycoreCubed_GridComp ESMF::ESMF NetCDF::NetCDF_Fortran) +else () + set(dependencies MAPL_cfio_r4 NCEP_sp_r4i4 GEOS_Shared GMAO_mpeu MAPL FVdycoreCubed_GridComp ESMF::ESMF NetCDF::NetCDF_Fortran) +endif () + +esma_add_library (${this} SRCS ${srcs} DEPENDENCIES ${dependencies}) diff --git a/GEOSmkiau_GridComp/GEOS_mkiauGridComp.F90 b/GEOSmkiau_GridComp/GEOS_mkiauGridComp.F90 index 08c36a967..92daadce6 100644 --- a/GEOSmkiau_GridComp/GEOS_mkiauGridComp.F90 +++ b/GEOSmkiau_GridComp/GEOS_mkiauGridComp.F90 @@ -18,7 +18,12 @@ module GEOS_mkiauGridCompMod use ESMF_CFIOFileMod use GEOS_UtilsMod ! use GEOS_RemapMod, only: myremap => remap + use MAPL_CubedSphereGridFactoryMod use m_set_eta, only: set_eta +#ifdef PYMKIAU_INTEGRATION + use pyMKIAU_interface_mod + use ieee_exceptions, only: ieee_get_halting_mode, ieee_set_halting_mode, ieee_all +#endif implicit none private @@ -91,8 +96,15 @@ subroutine SetServices ( GC, RC ) type (ESMF_Config) :: CF logical :: BLEND_AT_PBL - -!============================================================================= +#ifdef PYMKIAU_INTEGRATION + ! IEEE trapping see below + logical :: halting_mode(5) + ! BOGUS DATA TO SHOW USAGE + type(a_pod_struct_type) :: options + real, allocatable, dimension(:,:,:) :: in_buffer + real, allocatable, dimension(:,:,:) :: out_buffer +#endif + !============================================================================= ! Begin... @@ -459,6 +471,25 @@ subroutine SetServices ( GC, RC ) call MAPL_GenericSetServices ( gc, RC=STATUS) VERIFY_(STATUS) +#ifdef PYMKIAU_INTEGRATION + ! Spin the interface - we have to deactivate the ieee error + ! to be able to load numpy, scipy and other numpy packages + ! that generate NaN as an init mechanism for numerical solving + call ieee_get_halting_mode(ieee_all, halting_mode) + call ieee_set_halting_mode(ieee_all, .false.) + call pyMKIAU_interface_f_setservice() + call ieee_set_halting_mode(ieee_all, halting_mode) + + ! BOGUS CODE TO SHOW USAGE + options%npx = 10 + options%npy = 11 + options%npz = 12 + allocate (in_buffer(10,11,12), source = 42.42 ) + allocate (out_buffer(10,11,12), source = 0.0 ) + call pyMKIAU_interface_f_run(options, in_buffer, out_buffer) + write(*,*) "[pyMKIAU] From fortran OUT[5,5,5] is ", out_buffer(5,5,5) +#endif + RETURN_(ESMF_SUCCESS) end subroutine SetServices @@ -641,6 +672,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) integer :: nymdm1,nhmsm1 integer :: nymdm2,nhmsm2 integer :: NX,NY,IMG,JMG + integer :: NX_CUBE,NY_CUBE integer :: method integer :: DIMS(ESMF_MAXGRIDDIM) integer :: JCAP,LMP1 @@ -665,6 +697,9 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) real :: REPLAY_O3_FACTOR real :: REPLAY_TS_FACTOR + type (CubedSphereGridFactory) :: cs_factory + type (LatlonGridFactory) :: ll_factory + class (AbstractRegridder), pointer :: ANA2BKG => null() class (AbstractRegridder), pointer :: BKG2ANA => null() integer :: NPHIS, NPHIS_MAX @@ -1047,30 +1082,36 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) VERIFY_(STATUS) end if + call CFIO_Open ( REPLAY_FILEP0, 1, fid, STATUS ) + VERIFY_(STATUS) + call CFIO_DimInquire ( fid, IMana_World, JMana_world, LMana, nt, nvars, natts, rc=STATUS ) + VERIFY_(STATUS) + call CFIO_Close ( fid, STATUS ) + VERIFY_(STATUS) + call WRITE_PARALLEL("Creating GRIDana...") write(imstr,*) IMana_World write(jmstr,*) JMana_World gridAnaName='PC'//trim(adjustl(imstr))//'x'//trim(adjustl(jmstr))//'-DC' ! Get grid_dimensions from file. - call CFIO_Open(REPLAY_FILEP0, 1, fid, rc=status) - VERIFY_(status) - call CFIO_DimInquire (fid, IMana_World, JMana_World, LMana, nt, nvars, natts, rc=status) - VERIFY_(status) - call CFIO_Close(fid, rc=status) - VERIFY_(status) + if ( JMana_world == 6*IMana_World ) then - block - use MAPL_LatLonGridFactoryMod - GRIDrep = grid_manager%make_grid( & - LatLonGridFactory(im_world=IMana_World, jm_world=JMana_World, lm=LMana, & - nx=NX, ny=NY, pole='PC', dateline= 'DC', rc=status) ) - VERIFY_(STATUS) - GRIDana = grid_manager%make_grid( & - LatLonGridFactory(im_world=IMana_World, jm_world=JMana_World, lm=LMbkg, & - nx=NX, ny=NY, pole='PC', dateline= 'DC', rc=status) ) - VERIFY_(STATUS) - end block + call MAPL_MakeDecomposition(NX_CUBE,NY_CUBE,reduceFactor=6,__RC__) + cs_factory = CubedSphereGridFactory(im_world=IMana_World,lm=LMana,nx=nx_cube,ny=ny_cube,__RC__) + GRIDana = grid_manager%make_grid(cs_factory,__RC__) + GRIDrep = grid_manager%make_grid(cs_factory,__RC__) + + else + + block + class(AbstractGridFactory), allocatable :: factory + allocate(factory, source = grid_manager%make_factory(trim(REPLAY_FILEP0),force_file_coordinates = .false.)) + GRIDrep = grid_manager%make_grid(factory) + GRIDana = grid_manager%make_grid(factory) + end block + + endif mkiau_internal_state%im = IMana_World mkiau_internal_state%jm = JMana_World @@ -1193,7 +1234,7 @@ subroutine handleINC_ VERIFY_(STATUS) call ESMF_FieldBundleSet(RBUNDLEP0, grid=GRIDana, rc=status) VERIFY_(STATUS) - call MAPL_CFIORead ( REPLAY_FILEP0, REPLAY_TIMEP0, RBUNDLEP0, RC=status) + call MAPL_read_bundle( RBUNDLEP0, REPLAY_FILEP0, REPLAY_TIMEP0, RC=status) VERIFY_(STATUS) call ESMF_FieldBundleGet ( RBUNDLEP0, fieldCount=NQ, RC=STATUS ) VERIFY_(STATUS) @@ -1483,13 +1524,13 @@ subroutine handleANA_ if ( trim(GRIDINC)=="ANA" ) call ESMF_FieldBundleSet(RBUNDLEP0, grid=GRIDrep, rc=status) if ( trim(GRIDINC)=="BKG" ) call ESMF_FieldBundleSet(RBUNDLEP0, grid=GRIDbkg, rc=status) VERIFY_(STATUS) - call MAPL_CFIORead ( REPLAY_FILEP0, REPLAY_TIMEP0, RBUNDLEP0 , RC=status) + call MAPL_read_bundle( RBUNDLEP0, REPLAY_FILEP0, REPLAY_TIMEP0, RC=status) VERIFY_(STATUS) FILEP0 = REPLAY_FILEP0 FILE_TIMEP0 = REPLAY_TIMEP0 NEED_BUNDLEP0 = .FALSE. else if( (FILE_TIMEP0 .ne. REPLAY_TIMEP0) .or. (FILEP0 .ne. REPLAY_FILEP0) ) then - call MAPL_CFIORead ( REPLAY_FILEP0, REPLAY_TIMEP0, RBUNDLEP0 , RC=status) + call MAPL_read_bundle( RBUNDLEP0, REPLAY_FILEP0, REPLAY_TIMEP0, RC=status) VERIFY_(STATUS) FILEP0 = REPLAY_FILEP0 FILE_TIMEP0 = REPLAY_TIMEP0 @@ -1502,13 +1543,13 @@ subroutine handleANA_ if ( trim(GRIDINC)=="ANA" ) call ESMF_FieldBundleSet(RBUNDLEM1, grid=GRIDrep, rc=status) if ( trim(GRIDINC)=="BKG" ) call ESMF_FieldBundleSet(RBUNDLEM1, grid=GRIDbkg, rc=status) VERIFY_(STATUS) - call MAPL_CFIORead ( REPLAY_FILEM1, REPLAY_TIMEM1, RBUNDLEM1 , RC=status) + call MAPL_read_bundle( RBUNDLEM1, REPLAY_FILEM1, REPLAY_TIMEM1, RC=status) VERIFY_(STATUS) FILEM1 = REPLAY_FILEM1 FILE_TIMEM1 = REPLAY_TIMEM1 NEED_BUNDLEM1 = .FALSE. else if ( (FILE_TIMEM1 .ne. REPLAY_TIMEM1) .or. (FILEM1 .ne. REPLAY_FILEM1) ) then - call MAPL_CFIORead ( REPLAY_FILEM1, REPLAY_TIMEM1, RBUNDLEM1 , RC=status) + call MAPL_read_bundle( RBUNDLEM1, REPLAY_FILEM1, REPLAY_TIMEM1, RC=status) VERIFY_(STATUS) FILEM1 = REPLAY_FILEM1 FILE_TIMEM1 = REPLAY_TIMEM1 @@ -1521,13 +1562,13 @@ subroutine handleANA_ if ( trim(GRIDINC)=="ANA" ) call ESMF_FieldBundleSet(RBUNDLEP1, grid=GRIDrep, rc=status) if ( trim(GRIDINC)=="BKG" ) call ESMF_FieldBundleSet(RBUNDLEP1, grid=GRIDbkg, rc=status) VERIFY_(STATUS) - call MAPL_CFIORead ( REPLAY_FILEP1, REPLAY_TIMEP1, RBUNDLEP1 , RC=status) + call MAPL_read_bundle( RBUNDLEP1, REPLAY_FILEP1, REPLAY_TIMEP1, RC=status) VERIFY_(STATUS) FILEP1 = REPLAY_FILEP1 FILE_TIMEP1 = REPLAY_TIMEP1 NEED_BUNDLEP1 = .FALSE. else if ( FILE_TIMEP1 .ne. REPLAY_TIMEP1 .or. (FILEP1 .ne. REPLAY_FILEP1) ) then - call MAPL_CFIORead ( REPLAY_FILEP1, REPLAY_TIMEP1, RBUNDLEP1 , RC=status) + call MAPL_read_bundle( RBUNDLEP1, REPLAY_FILEP1, REPLAY_TIMEP1, RC=status) VERIFY_(STATUS) FILEP1 = REPLAY_FILEP1 FILE_TIMEP1 = REPLAY_TIMEP1 @@ -1539,13 +1580,13 @@ subroutine handleANA_ if ( trim(GRIDINC)=="ANA" ) call ESMF_FieldBundleSet(RBUNDLEM2, grid=GRIDrep, rc=status) if ( trim(GRIDINC)=="BKG" ) call ESMF_FieldBundleSet(RBUNDLEM2, grid=GRIDbkg, rc=status) VERIFY_(STATUS) - call MAPL_CFIORead ( REPLAY_FILEM2, REPLAY_TIMEM2, RBUNDLEM2 , RC=status) + call MAPL_read_bundle( RBUNDLEM2, REPLAY_FILEM2, REPLAY_TIMEM2, RC=status) VERIFY_(STATUS) FILEM2 = REPLAY_FILEM2 FILE_TIMEM2 = REPLAY_TIMEM2 NEED_BUNDLEM2 = .FALSE. else if ( FILE_TIMEM2 .ne. REPLAY_TIMEM2 .or. (FILEM2 .ne. REPLAY_FILEM2) ) then - call MAPL_CFIORead ( REPLAY_FILEM2, REPLAY_TIMEM2, RBUNDLEM2 , RC=status) + call MAPL_read_bundle( RBUNDLEM2, REPLAY_FILEM2, REPLAY_TIMEM2, RC=status) VERIFY_(STATUS) FILEM2 = REPLAY_FILEM2 FILE_TIMEM2 = REPLAY_TIMEM2 @@ -1561,6 +1602,7 @@ subroutine handleANA_ VERIFY_(STATUS) call ESMF_FieldBundleGet ( RBUNDLEP0, fieldNameList=RNAMES, rc=STATUS ) VERIFY_(STATUS) + call RedanduncyCheck(RNAMES) if( first ) then if(MAPL_AM_I_ROOT() ) then print * @@ -2833,11 +2875,13 @@ function match (replay_name,replay_alias,replay_var) if( trim(name) == 'U' ) then if( trim(var) == 'U' ) match = .true. + if( trim(var) == 'UA' ) match = .true. if( trim(var) == 'UGRD' ) match = .true. endif if( trim(name) == 'V' ) then if( trim(var) == 'V' ) match = .true. + if( trim(var) == 'VA' ) match = .true. if( trim(var) == 'VGRD' ) match = .true. endif @@ -2877,6 +2921,7 @@ function match (replay_name,replay_alias,replay_var) if( trim(name) == 'O3' ) then if( trim(var) == 'O3' ) match = .true. + if( trim(var) == 'O3PPMV' ) match = .true. if( trim(var) == 'OZONE' ) match = .true. endif @@ -3380,4 +3425,33 @@ subroutine myremap ( ple_in,ple_out, & return end subroutine myremap + subroutine RedanduncyCheck(rnames) + + character(len=*), intent(inout) :: rnames(:) + ! completely wired + ! at the moment, the files generated for/by JEDI + ! largely ignore GEOS naming convensions, this + ! here a paliative to a solution/clean-up to come + ! in the future (Todling). + + ! when both t and tv are in file, bypass t + if (any(rnames=='t') .and. any(rnames=='tv')) then + where(rnames=='t') + rnames = 't-bypass' + endwhere + endif + ! when both u and ua are in file, bypass u + if (any(rnames=='u') .and. any(rnames=='ua')) then + where(rnames=='u') + rnames = 'u-bypass' + endwhere + endif + ! when both v and va are in file, bypass v + if (any(rnames=='v') .and. any(rnames=='va')) then + where(rnames=='v') + rnames = 'v-bypass' + endwhere + endif + end subroutine RedanduncyCheck + end module GEOS_mkiauGridCompMod diff --git a/GEOSmkiau_GridComp/pyMKIAU/.gitignore b/GEOSmkiau_GridComp/pyMKIAU/.gitignore new file mode 100644 index 000000000..9ae227288 --- /dev/null +++ b/GEOSmkiau_GridComp/pyMKIAU/.gitignore @@ -0,0 +1,12 @@ +__pycache__/ +*.py[cod] +*$py.class +.pytest_cache +*.egg-info/ +test_data/ +.gt_cache_* +.translate-*/ +.vscode +test_data/ +sandbox/ +*.mod diff --git a/GEOSmkiau_GridComp/pyMKIAU/README.md b/GEOSmkiau_GridComp/pyMKIAU/README.md new file mode 100644 index 000000000..61f039520 --- /dev/null +++ b/GEOSmkiau_GridComp/pyMKIAU/README.md @@ -0,0 +1,40 @@ +# Fortran - Python bridge prototype + +Nomenclatura: we call the brige "fpy" and "c", "f" and "py" denotes functions in their respective language. + +Building: you have to pass `-DBUILD_PYMKIAU_INTERFACE=ON` to your `cmake` command to turn on the interface build and execution. + +## Pipeline + +Here's a quick rundown of how a buffer travels through the interface and back. + +- From Fortran in `GEOS_MKIAUGridComp:488` we call `pyMKIAU_interface_f_run` with the buffer passed as argument +- This pings the interface, located at `pyMKIAU/interface/interface.f90`. This interface uses the `iso_c_binding` to marshall the parameters downward (careful about the user type, look at the code) +- Fortran then call into C at `pyMKIAU/interface/interface.c`. Those functions now expect that a few `extern` hooks have been made available on the python side, they are define in `pyMKIAU/interface/interface.h` +- At runtime, the hooks are found and code carries to the python thanks to cffi. The .so that exposes the hooks is in `pyMKIAU/interface/interface.py`. Within this code, we: expose extern functions via `ffi.extern`, build a shared library to link for runtime and pass the code down to the `pyMKIAU` python package which lives at `pyMKIAU/pyMKIAU` +- In the package, the `serservices` or `run` function is called. + +## Fortran <--> C: iso_c_binding + +We leverage Fortan `iso_c_binding` extension to do conform Fortran and C calling structure. Which comes with a bunch of easy type casting and some pretty steep potholes. +The two big ones are: + +- strings need to be send/received as a buffer plus a length, +- pointers/buffers are _not_ able to be pushed into a user type. + +## C <->Python: CFFI based glue + +The interface is based on CFFI which is reponsible for the heavy lifting of + +- spinning a python interpreter +- passing memory between C and Python without a copy + +## Running python + +The last trick is to make sure your package is callable by the `interface.py`. Basically your code has to be accessible by the interpreter, be via virtual env, conda env or PYTHONPATH. +The easy way to know is that you need to be able to get into your environment and run in a python terminal: + +```python +from pyMKIAU.core import pyMKIAU_init +pyMKIAU_init() +``` diff --git a/GEOSmkiau_GridComp/pyMKIAU/interface/interface.c b/GEOSmkiau_GridComp/pyMKIAU/interface/interface.c new file mode 100644 index 000000000..28ebad972 --- /dev/null +++ b/GEOSmkiau_GridComp/pyMKIAU/interface/interface.c @@ -0,0 +1,31 @@ +#include +#include +#include "interface.h" + +extern int pyMKIAU_interface_c_setservice() +{ + // Check magic number + int return_code = pyMKIAU_interface_py_setservices(); + + if (return_code < 0) + { + exit(return_code); + } +} + +extern int pyMKIAU_interface_c_run(a_pod_struct_t *options, const float *in_buffer, float *out_buffer) +{ + // Check magic number + if (options->mn_123456789 != 123456789) + { + printf("Magic number failed, pyMKIAU interface is broken on the C side\n"); + exit(-1); + } + + int return_code = pyMKIAU_interface_py_run(options, in_buffer, out_buffer); + + if (return_code < 0) + { + exit(return_code); + } +} diff --git a/GEOSmkiau_GridComp/pyMKIAU/interface/interface.f90 b/GEOSmkiau_GridComp/pyMKIAU/interface/interface.f90 new file mode 100644 index 000000000..c94b4a06b --- /dev/null +++ b/GEOSmkiau_GridComp/pyMKIAU/interface/interface.f90 @@ -0,0 +1,43 @@ +module pyMKIAU_interface_mod + + use iso_c_binding, only: c_int, c_float, c_double, c_bool, c_ptr + + implicit none + + private + public :: pyMKIAU_interface_f_setservice, pyMKIAU_interface_f_run + public :: a_pod_struct_type + + !----------------------------------------------------------------------- + ! See `interface.h` for explanation of the POD-strict struct + !----------------------------------------------------------------------- + type, bind(c) :: a_pod_struct_type + integer(kind=c_int) :: npx + integer(kind=c_int) :: npy + integer(kind=c_int) :: npz + ! Magic number + integer(kind=c_int) :: make_flags_C_interop = 123456789 + end type + + + interface + + subroutine pyMKIAU_interface_f_setservice() bind(c, name='pyMKIAU_interface_c_setservice') + end subroutine pyMKIAU_interface_f_setservice + + subroutine pyMKIAU_interface_f_run(options, in_buffer, out_buffer) bind(c, name='pyMKIAU_interface_c_run') + + import c_float, a_pod_struct_type + + implicit none + ! This is an interface to a C function, the intent ARE NOT enforced + ! by the compiler. Consider them developer hints + type(a_pod_struct_type), intent(in) :: options + real(kind=c_float), dimension(*), intent(in) :: in_buffer + real(kind=c_float), dimension(*), intent(out) :: out_buffer + + end subroutine pyMKIAU_interface_f_run + + end interface + +end module pyMKIAU_interface_mod diff --git a/GEOSmkiau_GridComp/pyMKIAU/interface/interface.h b/GEOSmkiau_GridComp/pyMKIAU/interface/interface.h new file mode 100644 index 000000000..ce8dfb179 --- /dev/null +++ b/GEOSmkiau_GridComp/pyMKIAU/interface/interface.h @@ -0,0 +1,40 @@ +#pragma once + +/*** + * C Header for the interface to python. + * Define here any POD-strict structures and external functions + * that will get exported by cffi from python (see interface.py) + ***/ + +#include +#include + +// POD-strict structure to pack options and flags efficiently +// Struct CANNOT hold pointers. The iso_c_binding does not allow for foolproof +// pointer memory packing. +// We use the low-embedded trick of the magic number to attempt to catch +// any type mismatch betweeen Fortran and C. This is not a foolproof method +// but it bring a modicum of check at the cost of a single integer. +typedef struct +{ + int npx; + int npy; + int npz; + // Magic number needs to be last item + int mn_123456789; +} a_pod_struct_t; + +// For complex type that can be exported with different +// types (like the MPI communication object), you can rely on C `union` +typedef union +{ + int comm_int; + void *comm_ptr; +} MPI_Comm_t; + +// Python hook functions: defined as external so that the .so can link out ot them +// Though we define `in_buffer` as a `const float*` it is _not_ enforced +// by the interface. Treat as a developer hint only. + +extern int pyMKIAU_interface_py_run(a_pod_struct_t *options, const float *in_buffer, float *out_buffer); +extern int pyMKIAU_interface_py_setservices(); diff --git a/GEOSmkiau_GridComp/pyMKIAU/interface/interface.py b/GEOSmkiau_GridComp/pyMKIAU/interface/interface.py new file mode 100644 index 000000000..c0bfc1c03 --- /dev/null +++ b/GEOSmkiau_GridComp/pyMKIAU/interface/interface.py @@ -0,0 +1,46 @@ +import cffi # type: ignore + +TMPFILEBASE = "pyMKIAU_interface_py" + +ffi = cffi.FFI() + +source = """ +from {} import ffi +from datetime import datetime +from pyMKIAU.core import pyMKIAU_init, pyMKIAU_run #< User code starts here +import traceback + +@ffi.def_extern() +def pyMKIAU_interface_py_setservices() -> int: + + try: + # Calling out off the bridge into the python + pyMKIAU_init() + except Exception as err: + print("Error in Python:") + print(traceback.format_exc()) + return -1 + return 0 + +@ffi.def_extern() +def pyMKIAU_interface_py_run(options, in_buffer, out_buffer) -> int: + + try: + # Calling out off the bridge into the python + pyMKIAU_run(options, in_buffer, out_buffer) + except Exception as err: + print("Error in Python:") + print(traceback.format_exc()) + return -1 + return 0 +""".format(TMPFILEBASE) + +with open("interface.h") as f: + data = "".join([line for line in f if not line.startswith("#")]) + data = data.replace("CFFI_DLLEXPORT", "") + ffi.embedding_api(data) + +ffi.set_source(TMPFILEBASE, '#include "interface.h"') + +ffi.embedding_init_code(source) +ffi.compile(target="lib" + TMPFILEBASE + ".so", verbose=True) diff --git a/GEOSmkiau_GridComp/pyMKIAU/pyMKIAU/__init__.py b/GEOSmkiau_GridComp/pyMKIAU/pyMKIAU/__init__.py new file mode 100644 index 000000000..e69de29bb diff --git a/GEOSmkiau_GridComp/pyMKIAU/pyMKIAU/core.py b/GEOSmkiau_GridComp/pyMKIAU/pyMKIAU/core.py new file mode 100644 index 000000000..c3f9684d4 --- /dev/null +++ b/GEOSmkiau_GridComp/pyMKIAU/pyMKIAU/core.py @@ -0,0 +1,74 @@ +from _cffi_backend import _CDataBase as CFFIObj # type: ignore +import dataclasses +from pyMKIAU.f_py_conversion import FortranPythonConversion +from pyMKIAU.cuda_profiler import TimedCUDAProfiler +import numpy as np +from typing import Dict, List + + +@dataclasses.dataclass +class FPYOptions: + npx: int = 0 + npy: int = 0 + npz: int = 0 + mn_123456789: int = 0 + + +def options_fortran_to_python( + f_options: CFFIObj, +) -> FPYOptions: + if f_options.mn_123456789 != 123456789: # type:ignore + raise RuntimeError( + "Magic number failed, pyMoist interface is broken on the python side" + ) + + py_flags = FPYOptions() + keys = list(filter(lambda k: not k.startswith("__"), dir(type(py_flags)))) + for k in keys: + if hasattr(f_options, k): + setattr(py_flags, k, getattr(f_options, k)) + return py_flags + + +F_PY_MEMORY_CONV = None + + +def pyMKIAU_init(): + print("[pyMKIAU] Init called") + + +def pyMKIAU_run( + f_options: CFFIObj, + f_in_buffer: CFFIObj, + f_out_buffer: CFFIObj, +): + print("[pyMKIAU] Run called") + options = options_fortran_to_python(f_options) + print(f"[pyMKIAU] Options: {options}") + + # Dev Note: this should be doen better in it's own class + # and the `np` should be driven by the user code requirements + # for GPU or CPU memory + global F_PY_MEMORY_CONV + if F_PY_MEMORY_CONV is None: + F_PY_MEMORY_CONV = FortranPythonConversion( + options.npx, + options.npy, + options.npz, + np, + ) + + # Move memory into a manipulable numpy array + in_buffer = F_PY_MEMORY_CONV.fortran_to_python(f_in_buffer) + out_buffer = F_PY_MEMORY_CONV.fortran_to_python(f_out_buffer) + + # Here goes math and dragons + timings: Dict[str, List[float]] = {} + with TimedCUDAProfiler("pyMKIAU bogus math", timings): + out_buffer[:, :, :] = in_buffer[:, :, :] * 2 + + print(f"[pyMKIAU] At 5,5,5 in python OUT is: {out_buffer[5,5,5]}") + print(f"[pyMKIAU] Timers: {timings}") + + # Go back to fortran + F_PY_MEMORY_CONV.python_to_fortran(out_buffer, f_out_buffer) diff --git a/GEOSmkiau_GridComp/pyMKIAU/pyMKIAU/cuda_profiler.py b/GEOSmkiau_GridComp/pyMKIAU/pyMKIAU/cuda_profiler.py new file mode 100644 index 000000000..5a6e41a71 --- /dev/null +++ b/GEOSmkiau_GridComp/pyMKIAU/pyMKIAU/cuda_profiler.py @@ -0,0 +1,76 @@ +import time +from typing import Dict, List + + +# Conditional cupy import for non-GPU machines +try: + import cupy as cp +except ModuleNotFoundError: + cp = None + +# Run a deviceSynchronize() to check +# that the GPU is present and ready to run +if cp is not None: + try: + cp.cuda.runtime.deviceSynchronize() + GPU_AVAILABLE = True + except cp.cuda.runtime.CUDARuntimeError: + GPU_AVAILABLE = False +else: + GPU_AVAILABLE = False + + +class CUDAProfiler: + """Leverages NVTX & NSYS to profile CUDA kernels.""" + + def __init__(self, label: str) -> None: + self.label = label + + def __enter__(self): + if GPU_AVAILABLE: + cp.cuda.runtime.deviceSynchronize() + cp.cuda.nvtx.RangePush(self.label) + + def __exit__(self, _type, _val, _traceback): + if GPU_AVAILABLE: + cp.cuda.runtime.deviceSynchronize() + cp.cuda.nvtx.RangePop() + + @classmethod + def sync_device(cls): + if GPU_AVAILABLE: + cp.cuda.runtime.deviceSynchronize() + + @classmethod + def start_cuda_profiler(cls): + if GPU_AVAILABLE: + cp.cuda.profiler.start() + + @classmethod + def stop_cuda_profiler(cls): + if GPU_AVAILABLE: + cp.cuda.profiler.stop() + + @classmethod + def mark_cuda_profiler(cls, message: str): + if GPU_AVAILABLE: + cp.cuda.nvtx.Mark(message) + + +class TimedCUDAProfiler(CUDAProfiler): + def __init__(self, label: str, timings: Dict[str, List[float]]) -> None: + super().__init__(label) + self._start_time = 0 + self._timings = timings + + def __enter__(self): + super().__enter__() + self._start_time = time.perf_counter() + + def __exit__(self, _type, _val, _traceback): + super().__exit__(_type, _val, _traceback) + t = time.perf_counter() - self._start_time + if self.label not in self._timings: + self._timings[self.label] = [t] + else: + self._timings[self.label].append(t) diff --git a/GEOSmkiau_GridComp/pyMKIAU/pyMKIAU/f_py_conversion.py b/GEOSmkiau_GridComp/pyMKIAU/pyMKIAU/f_py_conversion.py new file mode 100644 index 000000000..47a17e731 --- /dev/null +++ b/GEOSmkiau_GridComp/pyMKIAU/pyMKIAU/f_py_conversion.py @@ -0,0 +1,219 @@ +from math import prod +from types import ModuleType +from typing import List, Optional, Tuple, TypeAlias + +import cffi +import numpy as np + +# Conditional cupy import for non-GPU machines +try: + import cupy as cp +except ModuleNotFoundError: + cp = None + + +# Dev note: we would like to use cp.ndarray for Device and +# Union of np and cp ndarray for Python but we can't +# because cp might not be importable! +DeviceArray: TypeAlias = np.ndarray +PythonArray: TypeAlias = np.ndarray + +# Default floating point cast +BaseFloat = np.float32 + + +class NullStream: + def __init__(self): + pass + + def synchronize(self): + pass + + def __enter__(self): + pass + + def __exit__(self, exc_type, exc_value, traceback): + pass + + +class FortranPythonConversion: + """ + Convert Fortran arrays to NumPy and vice-versa + """ + + def __init__( + self, + npx: int, + npy: int, + npz: int, + numpy_module: ModuleType, + ): + # Python numpy-like module is given by the caller leaving + # optional control of upload/download in the case + # of GPU/CPU system + self._target_np = numpy_module + + # Device parameters + # Pace targets gpu: we want the Pace layout to be on device + self._python_targets_gpu = self._target_np == cp + if self._python_targets_gpu: + self._stream_A = cp.cuda.Stream(non_blocking=True) + self._stream_B = cp.cuda.Stream(non_blocking=True) + else: + self._stream_A = NullStream() + self._stream_B = NullStream() + self._current_stream = self._stream_A + + # Layout & indexing + self._npx, self._npy, self._npz = npx, npy, npz + + # cffi init + self._ffi = cffi.FFI() + self._TYPEMAP = { + "float": np.float32, + "double": np.float64, + "int": np.int32, + } + + def device_sync(self): + """Synchronize the working CUDA streams""" + self._stream_A.synchronize() + self._stream_B.synchronize() + + def _fortran_to_numpy( + self, + fptr: "cffi.FFI.CData", + dim: Optional[List[int]] = None, + ) -> np.ndarray: + """ + Input: Fortran data pointed to by fptr and of shape dim = (i, j, k) + Output: C-ordered double precision NumPy data of shape (i, j, k) + """ + if not dim: + dim = [self._npx, self._npy, self._npz] + ftype = self._ffi.getctype(self._ffi.typeof(fptr).item) + assert ftype in self._TYPEMAP + return np.frombuffer( + self._ffi.buffer(fptr, prod(dim) * self._ffi.sizeof(ftype)), + self._TYPEMAP[ftype], + ) + + def _upload_and_transform( + self, + host_array: np.ndarray, + dim: Optional[List[int]] = None, + swap_axes: Optional[Tuple[int, int]] = None, + ) -> DeviceArray: + """Upload to device & transform to Pace compatible layout""" + with self._current_stream: + device_array = cp.asarray(host_array) + final_array = self._transform_from_fortran_layout( + device_array, + dim, + swap_axes, + ) + self._current_stream = ( + self._stream_A + if self._current_stream == self._stream_B + else self._stream_B + ) + return final_array + + def _transform_from_fortran_layout( + self, + array: PythonArray, + dim: Optional[List[int]] = None, + swap_axes: Optional[Tuple[int, int]] = None, + ) -> PythonArray: + """Transform from Fortran layout into a Pace compatible layout""" + if not dim: + dim = [self._npx, self._npy, self._npz] + trf_array = array.reshape(tuple(reversed(dim))).transpose().astype(BaseFloat) + if swap_axes: + trf_array = self._target_np.swapaxes( + trf_array, + swap_axes[0], + swap_axes[1], + ) + return trf_array + + def fortran_to_python( + self, + fptr: "cffi.FFI.CData", + dim: Optional[List[int]] = None, + swap_axes: Optional[Tuple[int, int]] = None, + ) -> PythonArray: + """Move fortran memory into python space""" + np_array = self._fortran_to_numpy(fptr, dim) + if self._python_targets_gpu: + return self._upload_and_transform(np_array, dim, swap_axes) + else: + return self._transform_from_fortran_layout( + np_array, + dim, + swap_axes, + ) + + def _transform_and_download( + self, + device_array: DeviceArray, + dtype: type, + swap_axes: Optional[Tuple[int, int]] = None, + ) -> np.ndarray: + with self._current_stream: + if swap_axes: + device_array = cp.swapaxes( + device_array, + swap_axes[0], + swap_axes[1], + ) + host_array = cp.asnumpy( + device_array.astype(dtype).flatten(order="F"), + ) + self._current_stream = ( + self._stream_A + if self._current_stream == self._stream_B + else self._stream_B + ) + return host_array + + def _transform_from_python_layout( + self, + array: PythonArray, + dtype: type, + swap_axes: Optional[Tuple[int, int]] = None, + ) -> np.ndarray: + """Copy back a numpy array in python layout to Fortran""" + + if self._python_targets_gpu: + numpy_array = self._transform_and_download(array, dtype, swap_axes) + else: + numpy_array = array.astype(dtype).flatten(order="F") + if swap_axes: + numpy_array = np.swapaxes( + numpy_array, + swap_axes[0], + swap_axes[1], + ) + return numpy_array + + def python_to_fortran( + self, + array: PythonArray, + fptr: "cffi.FFI.CData", + ptr_offset: int = 0, + swap_axes: Optional[Tuple[int, int]] = None, + ) -> np.ndarray: + """ + Input: Fortran data pointed to by fptr and of shape dim = (i, j, k) + Output: C-ordered double precision NumPy data of shape (i, j, k) + """ + ftype = self._ffi.getctype(self._ffi.typeof(fptr).item) + assert ftype in self._TYPEMAP + dtype = self._TYPEMAP[ftype] + numpy_array = self._transform_from_python_layout( + array, + dtype, + swap_axes, + ) + self._ffi.memmove(fptr + ptr_offset, numpy_array, 4 * numpy_array.size) diff --git a/GEOSmkiau_GridComp/pyMKIAU/setup.py b/GEOSmkiau_GridComp/pyMKIAU/setup.py new file mode 100644 index 000000000..851e0b1b6 --- /dev/null +++ b/GEOSmkiau_GridComp/pyMKIAU/setup.py @@ -0,0 +1,33 @@ +#!/usr/bin/env python +# -*- coding: utf-8 -*- + +"""pyMKIAU - python sub-component of GEOS MKIAU.""" + +from setuptools import find_namespace_packages, setup + + +with open("README.md", encoding="utf-8") as readme_file: + readme = readme_file.read() + +setup( + author="NASA", + python_requires=">=3.11", + classifiers=[ + "Development Status :: 2 - Pre-Alpha", + "Intended Audience :: Developers", + "License :: OSI Approved :: Apache 2 License", + "Natural Language :: English", + "Programming Language :: Python :: 3.11", + ], + description=("pyMKIAU - python sub-component of GEOS MKIAU."), + install_requires=[], + extras_require={}, + long_description=readme, + include_package_data=True, + name="pyMKIAU", + packages=find_namespace_packages(include=["pyMKIAU", "pyMKIAU.*"]), + setup_requires=[], + url="https://github.com/GEOS-ESM/GEOSgcm_GridComp", + version="0.0.0", + zip_safe=False, +) diff --git a/GEOSogcm_GridComp/GEOS_OgcmGridComp.F90 b/GEOSogcm_GridComp/GEOS_OgcmGridComp.F90 index 8adf181fc..38832aed0 100644 --- a/GEOSogcm_GridComp/GEOS_OgcmGridComp.F90 +++ b/GEOSogcm_GridComp/GEOS_OgcmGridComp.F90 @@ -805,12 +805,14 @@ subroutine SetServices ( GC, RC ) SRC_ID = SEAICE, & RC=STATUS ) VERIFY_(STATUS) - call MAPL_AddConnectivity ( GC, & - SHORT_NAME = (/'UWC','VWC'/), & - SRC_ID = OCEAN, & - DST_ID = SEAICE, & - _RC) - endif + if (trim(OCEAN_NAME) /= "MIT") then ! + call MAPL_AddConnectivity ( GC, & + SHORT_NAME = (/'UWC','VWC'/), & + SRC_ID = OCEAN, & + DST_ID = SEAICE, & + _RC) + endif + end if end if if (DO_CICE_THERMO > 1) then diff --git a/GEOSogcm_GridComp/GEOSseaice_GridComp/CICE_GEOSPlug/CICE_GEOSPlug.F90 b/GEOSogcm_GridComp/GEOSseaice_GridComp/CICE_GEOSPlug/CICE_GEOSPlug.F90 index 46e2af25b..18f714055 100644 --- a/GEOSogcm_GridComp/GEOSseaice_GridComp/CICE_GEOSPlug/CICE_GEOSPlug.F90 +++ b/GEOSogcm_GridComp/GEOSseaice_GridComp/CICE_GEOSPlug/CICE_GEOSPlug.F90 @@ -94,7 +94,7 @@ subroutine SetServices ( GC, RC ) call MAPL_GridCompSetEntryPoint ( GC, ESMF_METHOD_RUN, Run, _RC) call MAPL_GridCompSetEntryPoint ( GC, ESMF_METHOD_FINALIZE, Finalize, _RC) call MAPL_GridCompSetEntryPoint ( GC, ESMF_METHOD_WRITERESTART, Record, _RC) - call MAPL_GridCompSetEntryPoint ( GC, ESMF_METHOD_READRESTART, Refresh, _RC) + call MAPL_GridCompSetEntryPoint ( GC, MAPL_METHOD_REFRESH, Refresh, _RC) ! Set the state variable specs. ! ----------------------------- @@ -933,6 +933,8 @@ subroutine Record ( GC, IMPORT, EXPORT, CLOCK, RC ) type(MAPL_MetaComp), pointer :: MAPL ! ErrLog Variables + character(len=ESMF_MAXSTR) :: IAm + integer :: STATUS character(len=ESMF_MAXSTR) :: COMP_NAME @@ -940,7 +942,7 @@ subroutine Record ( GC, IMPORT, EXPORT, CLOCK, RC ) character(len=14) :: timeStamp logical :: doRecord - __Iam__('Record') + Iam = "Record" ! Get the target components name and set-up traceback handle. ! ----------------------------------------------------------- @@ -1003,18 +1005,18 @@ subroutine Refresh ( GC, IMPORT, EXPORT, CLOCK, RC ) integer, optional, intent( OUT) :: RC ! Error code !EOP - type(MAPL_MetaComp), pointer :: MAPL ! ErrLog Variables - + character(len=ESMF_MAXSTR) :: IAm + integer :: STATUS character(len=ESMF_MAXSTR) :: COMP_NAME ! Locals character(len=14) :: timeStamp logical :: doRecord - __Iam__('Restore') + IAm = "Restore" ! Get the target components name and set-up traceback handle. ! ----------------------------------------------------------- diff --git a/GEOSogcm_GridComp/GEOSseaice_GridComp/CICE_GEOSPlug/cice6_app/1440x1080/ice_in b/GEOSogcm_GridComp/GEOSseaice_GridComp/CICE_GEOSPlug/cice6_app/1440x1080/ice_in index 6d5284c6d..fbd804c01 100644 --- a/GEOSogcm_GridComp/GEOSseaice_GridComp/CICE_GEOSPlug/cice6_app/1440x1080/ice_in +++ b/GEOSogcm_GridComp/GEOSseaice_GridComp/CICE_GEOSPlug/cice6_app/1440x1080/ice_in @@ -62,9 +62,9 @@ grid_format = 'nc' grid_type = 'tripole' grid_subtype = 'geosmom' - grid_ice = 'B' + grid_ice = 'C' grid_atm = 'A' - grid_ocn = 'B' + grid_ocn = 'C' grid_file = 'cice6_grid.nc' kmt_file = 'cice6_kmt.nc' bathymetry_file = 'cice6_global.bathy.nc' @@ -101,7 +101,7 @@ restart_lvl = .true. tr_pond_topo = .false. restart_pond_topo = .false. - tr_pond_lvl = .false. + tr_pond_lvl = .true. restart_pond_lvl = .false. tr_snow = .false. restart_snow = .false. @@ -115,7 +115,7 @@ &thermo_nml kitd = 1 - ktherm = 1 + ktherm = 2 conduct = 'bubbly' ksno = 0.3d0 a_rapid_mode = 0.5e-3 @@ -174,7 +174,7 @@ / &shortwave_nml - shortwave = 'ccsm3' + shortwave = 'dEdd' albedo_type = 'ccsm3' albicev = 0.78 albicei = 0.36 @@ -183,13 +183,13 @@ ahmax = 0.3 R_ice = 0. R_pnd = 0. - R_snw = 1.5 + R_snw = 0. dT_mlt = 1.5 rsnw_mlt = 1500. - kalg = 0.6 - sw_redist = .true. - sw_frac = 0.9d0 - sw_dtemp = 0.02d0 + kalg = 0.0 + sw_redist = .true. + sw_frac = 0.9d0 + sw_dtemp = 0.02d0 / &ponds_nml diff --git a/GEOSogcm_GridComp/GEOSseaice_GridComp/CICE_GEOSPlug/cice6_app/540x458/ice_in b/GEOSogcm_GridComp/GEOSseaice_GridComp/CICE_GEOSPlug/cice6_app/540x458/ice_in index ae56ccdc0..56164fe63 100644 --- a/GEOSogcm_GridComp/GEOSseaice_GridComp/CICE_GEOSPlug/cice6_app/540x458/ice_in +++ b/GEOSogcm_GridComp/GEOSseaice_GridComp/CICE_GEOSPlug/cice6_app/540x458/ice_in @@ -62,9 +62,9 @@ grid_format = 'nc' grid_type = 'tripole' grid_subtype = 'geosmom' - grid_ice = 'B' + grid_ice = 'C' grid_atm = 'A' - grid_ocn = 'B' + grid_ocn = 'C' grid_file = 'cice6_grid.nc' kmt_file = 'cice6_kmt.nc' bathymetry_file = 'cice6_global.bathy.nc' @@ -470,7 +470,7 @@ f_snowfrac = 'x' f_snow = 'x' f_snow_ai = 'm' - f_rain = 'x' + f_rain = 'm' f_rain_ai = 'm' f_sst = 'm' f_sss = 'm' @@ -492,7 +492,7 @@ f_alidf_ai = 'x' f_albice = 'md' f_albsno = 'md' - f_albpnd = 'x' + f_albpnd = 'md' f_coszen = 'x' f_flat = 'md' f_flat_ai = 'md' diff --git a/GEOSogcm_GridComp/GEOSseaice_GridComp/CICE_GEOSPlug/cice6_app/72x36/ice_in b/GEOSogcm_GridComp/GEOSseaice_GridComp/CICE_GEOSPlug/cice6_app/72x36/ice_in index f23ada4de..01c600044 100644 --- a/GEOSogcm_GridComp/GEOSseaice_GridComp/CICE_GEOSPlug/cice6_app/72x36/ice_in +++ b/GEOSogcm_GridComp/GEOSseaice_GridComp/CICE_GEOSPlug/cice6_app/72x36/ice_in @@ -115,7 +115,7 @@ &thermo_nml kitd = 1 - ktherm = 1 + ktherm = 2 conduct = 'bubbly' ksno = 0.3d0 a_rapid_mode = 0.5e-3 @@ -293,8 +293,6 @@ restart_hbrine = .false. tr_zaero = .false. modal_aero = .false. - optics_file = 'unknown' - optics_file_fieldname = 'modalBCabsorptionParameter5band' skl_bgc = .false. z_tracers = .false. dEdd_algae = .false. diff --git a/GEOSwgcm_GridComp/GEOS_WgcmGridComp.F90 b/GEOSwgcm_GridComp/GEOS_WgcmGridComp.F90 index 69316e660..c8adea992 100644 --- a/GEOSwgcm_GridComp/GEOS_WgcmGridComp.F90 +++ b/GEOSwgcm_GridComp/GEOS_WgcmGridComp.F90 @@ -370,6 +370,10 @@ subroutine SetServices(GC, RC) SHORT_NAME = 'SWH', & CHILD_ID = WM, __RC__) + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'WCM', & + CHILD_ID = WM, __RC__) + call MAPL_AddExportSpec(GC, & SHORT_NAME = 'DCP', & CHILD_ID = WM, __RC__) diff --git a/GEOSwgcm_GridComp/GEOSwavewatch_GridComp/GEOS_WaveWatchGridComp.F90 b/GEOSwgcm_GridComp/GEOSwavewatch_GridComp/GEOS_WaveWatchGridComp.F90 index c7fc934f9..e6e569f58 100644 --- a/GEOSwgcm_GridComp/GEOSwavewatch_GridComp/GEOS_WaveWatchGridComp.F90 +++ b/GEOSwgcm_GridComp/GEOSwavewatch_GridComp/GEOS_WaveWatchGridComp.F90 @@ -239,7 +239,21 @@ subroutine SetServices(GC, RC) SHORT_NAME = 'EDF', & CHILD_ID = WW3GC, __RC__) - + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'WCC', & + CHILD_ID = WW3GC, __RC__) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'WCF', & + CHILD_ID = WW3GC, __RC__) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'WCH', & + CHILD_ID = WW3GC, __RC__) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'WCM', & + CHILD_ID = WW3GC, __RC__) ! Set the Profiling timers diff --git a/GEOSwgcm_GridComp/GEOSwavewatch_GridComp/ww3_multi_esmf/CMakeLists.txt b/GEOSwgcm_GridComp/GEOSwavewatch_GridComp/ww3_multi_esmf/CMakeLists.txt index 0d6073c2a..416e6e57a 100644 --- a/GEOSwgcm_GridComp/GEOSwavewatch_GridComp/ww3_multi_esmf/CMakeLists.txt +++ b/GEOSwgcm_GridComp/GEOSwavewatch_GridComp/ww3_multi_esmf/CMakeLists.txt @@ -1,62 +1,61 @@ esma_set_this () - -list( APPEND WW3ESMF_FTN - constants.ftn - w3adatmd.ftn - w3arrymd.ftn - w3cspcmd.ftn - w3dispmd.ftn - w3fldsmd.ftn - w3flx1md.ftn - w3gdatmd.ftn - w3gsrumd.ftn - w3idatmd.ftn - w3initmd.ftn - w3iobcmd.ftn - w3iogomd.ftn - w3iogrmd.ftn - w3iopomd.ftn - w3iorsmd.ftn - w3iosfmd.ftn - w3iotrmd.ftn - w3nmlmultimd.ftn - w3odatmd.ftn - w3parall.ftn - w3partmd.ftn - w3pro3md.ftn - w3profsmd.ftn - w3sbt1md.ftn - w3sdb1md.ftn - w3servmd.ftn - w3snl1md.ftn - w3sln1md.ftn - w3fld1md.ftn - w3fld2md.ftn - w3src4md.ftn - w3srcemd.ftn - w3timemd.ftn - w3triamd.ftn - w3updtmd.ftn - w3uqckmd.ftn - w3wavemd.ftn - w3wdasmd.ftn - w3wdatmd.ftn - wmmaplmd.ftn - wmfinlmd.ftn - wmgridmd.ftn - wminiomd.ftn - wminitmd.ftn - wmiopomd.ftn - wmmdatmd.ftn - wmscrpmd.ftn - wmunitmd.ftn - wmupdtmd.ftn - wmwavemd.ftn +list( APPEND WW3ESMF_SRCS + constants.F90 + w3adatmd.F90 + w3arrymd.F90 + w3cspcmd.F90 + w3dispmd.F90 + w3fldsmd.F90 + w3gdatmd.F90 + w3flx1md.F90 + w3gsrumd.F90 + w3idatmd.F90 + w3initmd.F90 + w3iobcmd.F90 + w3iogomd.F90 + w3iogrmd.F90 + w3iopomd.F90 + w3iorsmd.F90 + w3iosfmd.F90 + w3iotrmd.F90 + w3nmlmultimd.F90 + w3odatmd.F90 + w3parall.F90 + w3partmd.F90 + w3pro3md.F90 + w3profsmd.F90 + w3sbt1md.F90 + w3sdb1md.F90 + w3servmd.F90 + w3snl1md.F90 + w3sln1md.F90 + w3fld1md.F90 + w3fld2md.F90 + w3src4md.F90 + w3srcemd.F90 + w3timemd.F90 + w3triamd.F90 + w3updtmd.F90 + w3uqckmd.F90 + w3wavemd.F90 + w3wdasmd.F90 + w3wdatmd.F90 + wmmaplmd.F90 + wmfinlmd.F90 + wmgridmd.F90 + wminiomd.F90 + wminitmd.F90 + wmiopomd.F90 + wmmdatmd.F90 + wmscrpmd.F90 + wmunitmd.F90 + wmupdtmd.F90 + wmwavemd.F90 SCRIP/scrip_constants.f SCRIP/scrip_errormod.f90 SCRIP/scrip_grids.f - SCRIP/scrip_interface.ftn + SCRIP/scrip_interface.F90 SCRIP/scrip_iounitsmod.f90 SCRIP/scrip_kindsmod.f90 SCRIP/scrip_netcdfmod.f90 @@ -70,40 +69,65 @@ list( APPEND WW3ESMF_FTN esma_mepo_style(ww3 WW3_rel_path REL_PATH ..) set (WW3_path ${CMAKE_CURRENT_SOURCE_DIR}/${WW3_rel_path}) -get_filename_component(aux_dir ${WW3_path}/model/aux ABSOLUTE) -get_filename_component(ftn_dir ${WW3_path}/model/ftn ABSOLUTE) - -message(DEBUG "WW3 aux_dir ${aux_dir}") -message(DEBUG "WW3 ftn_dir ${ftn_dir}") - -add_executable(w3adc "${aux_dir}/w3adc.f") - -set (WW3ESMF_F90) -foreach(src_file ${WW3ESMF_FTN}) - STRING(REGEX REPLACE ".ftn" ".F90" gen_src_file ${src_file}) - STRING(REGEX REPLACE "/" "_" gen_log_file ${gen_src_file}) - # Testing shows that we only want BYPRODUCTS here if our CMAKE_GENERATOR is Unix Makefiles - # If we use Ninja, we don't want BYPRODUCTS - if (CMAKE_GENERATOR STREQUAL "Unix Makefiles") - set(BYPRODUCTS ${gen_src_file}) - else() - set(BYPRODUCTS "") - endif() - add_custom_command( - OUTPUT ${gen_src_file} - BYPRODUCTS ${BYPRODUCTS} - DEPENDS w3adc ${ftn_dir}/${src_file} - COMMAND ${CMAKE_CURRENT_SOURCE_DIR}/run_w3adc.sh ${ftn_dir} ${src_file} > ${gen_log_file}.w3adc.log 2>&1 - COMMENT "Running w3adc ${src_file}") - list(APPEND WW3ESMF_F90 ${gen_src_file}) +set (SRCS) +foreach(src_file ${WW3ESMF_SRCS}) + list(APPEND SRCS ${WW3_path}/model/src/${src_file}) +# message(STATUS "WW3::file ${src_file}") +# message(STATUS "WW3::file ${WW3_path}/model/src/${src_file}") +# message(STATUS "") endforeach() - esma_add_library (${this} - SRCS ${WW3ESMF_F90} + SRCS ${SRCS} DEPENDENCIES MAPL ESMF::ESMF NetCDF::NetCDF_Fortran ) -target_include_directories (${this} PRIVATE - $ + +set (switch_strings "NOGRB DIST MPI SCRIP PR3 UQ FLX0 LN1 FLD2 ST4 STAB0 NL1 BT1 DB1 MLIM TR0 BS0 XX0 WNX0 WNT0 CRX0 CRT0 O0 O1 O2 O3 O4 O5 O6 O7 IC0 IS0 REF0" ) + +set_property (SOURCE ${WW3_path}/model/src/w3initmd.F90 + APPEND + PROPERTY COMPILE_DEFINITIONS + "__WW3_SWITCHES__=\'${switch_strings}\'" ) + + +list (APPEND defs + W3_NOGRB + W3_DIST + W3_MPI + W3_SCRIP + W3_PR3 + W3_UQ + W3_FLX0 + W3_LN1 + W3_FLD2 + W3_ST4 + W3_STAB0 + W3_NL1 + W3_BT1 + W3_DB1 + W3_MLIM + W3_TR0 + W3_BS0 + W3_XX0 + W3_WNX0 + W3_WNT0 + W3_CRX0 + W3_CRT0 + W3_O0 + W3_O1 + W3_O2 + W3_O3 + W3_O4 + W3_O5 + W3_O6 + W3_O7 + W3_IC0 + W3_IS0 + W3_REF0 +) + +target_compile_definitions(${this} PRIVATE ${defs}) + + diff --git a/GEOSwgcm_GridComp/GEOSwavewatch_GridComp/ww3_multi_esmf/run_w3adc.sh b/GEOSwgcm_GridComp/GEOSwavewatch_GridComp/ww3_multi_esmf/run_w3adc.sh deleted file mode 100755 index bef344bf4..000000000 --- a/GEOSwgcm_GridComp/GEOSwavewatch_GridComp/ww3_multi_esmf/run_w3adc.sh +++ /dev/null @@ -1,29 +0,0 @@ -#!/bin/bash -set -eux - -if [ $# -ne 2 ]; then - echo "Error in run_w3adc.sh" - exit 1 -fi - -ftn_dir=$1 -filename=$2 - -switches=$(cat ${ftn_dir}/../esmf/switch | tr '\n' ' ') - -extension="${filename##*.}" -basename="${filename%.*}" -inputname="${filename//\//_}.input" - -mkdir -p $( dirname ${filename} ) - -if [[ $extension == "ftn" ]]; then - echo "0 0" > ${inputname} - echo "'${ftn_dir}/${filename}' '${basename}.F90'" >> ${inputname} - echo "'${switches}'" >> ${inputname} - ./w3adc < ${inputname} -else - cp ${ftn_dir}/${filename} ${filename} -fi - -echo "Done running w3adc for ${filename}"