diff --git a/.github/workflows/TestCaseLists b/.github/workflows/TestCaseLists new file mode 100644 index 00000000..86b50e1a --- /dev/null +++ b/.github/workflows/TestCaseLists @@ -0,0 +1,88 @@ +GRID_PFT_URBANON_CAMBELL_CAMAON_BGCON_CROPON GRID LULC_IGBP_PFT URBANON Campbell CaMaON BGCON CROPON +GRID_PFT_URBANON_CAMBELL_CAMAOFF_BGCON_CROPON GRID LULC_IGBP_PFT URBANON Campbell CaMaOFF BGCON CROPON +GRID_PFT_URBANON_vanGen_CAMAON_BGCON_CROPON GRID LULC_IGBP_PFT URBANON vanGenu CaMaON BGCON CROPON +GRID_PFT_URBANON_vanGen_CAMAOFF_BGCON_CROPON GRID LULC_IGBP_PFT URBANON vanGenu CaMaOFF BGCON CROPON +GRID_PFT_URBANOFF_CAMBELL_CAMAON_BGCON_CROPON GRID LULC_IGBP_PFT URBANOFF Campbell CaMaON BGCON CROPON +GRID_PFT_URBANOFF_CAMBELL_CAMAOFF_BGCON_CROPON GRID LULC_IGBP_PFT URBANOFF Campbell CaMaOFF BGCON CROPON +GRID_PFT_URBANOFF_vanGen_CAMAON_BGCON_CROPON GRID LULC_IGBP_PFT URBANOFF vanGenu CaMaON BGCON CROPON +GRID_PFT_URBANOFF_vanGen_CAMAOFF_BGCON_CROPON GRID LULC_IGBP_PFT URBANOFF vanGenu CaMaOFF BGCON CROPON +GRID_PFT_URBANON_CAMBELL_CAMAON_BGCON_CROPOFF GRID LULC_IGBP_PFT URBANON Campbell CaMaON BGCON CROPOFF +GRID_PFT_URBANON_CAMBELL_CAMAOFF_BGCON_CROPOFF GRID LULC_IGBP_PFT URBANON Campbell CaMaOFF BGCON CROPOFF +GRID_PFT_URBANON_vanGen_CAMAON_BGCON_CROPOFF GRID LULC_IGBP_PFT URBANON vanGenu CaMaON BGCON CROPOFF +GRID_PFT_URBANON_vanGen_CAMAOFF_BGCON_CROPOFF GRID LULC_IGBP_PFT URBANON vanGenu CaMaOFF BGCON CROPOFF +GRID_PFT_URBANOFF_CAMBELL_CAMAON_BGCON_CROPOFF GRID LULC_IGBP_PFT URBANOFF Campbell CaMaON BGCON CROPOFF +GRID_PFT_URBANOFF_CAMBELL_CAMAOFF_BGCON_CROPOFF GRID LULC_IGBP_PFT URBANOFF Campbell CaMaOFF BGCON CROPOFF +GRID_PFT_URBANOFF_vanGen_CAMAON_BGCON_CROPOFF GRID LULC_IGBP_PFT URBANOFF vanGenu CaMaON BGCON CROPOFF +GRID_PFT_URBANOFF_vanGen_CAMAOFF_BGCON_CROPOFF GRID LULC_IGBP_PFT URBANOFF vanGenu CaMaOFF BGCON CROPOFF +GRID_PFT_URBANON_CAMBELL_CAMAON_BGCOFF_CROPOFF GRID LULC_IGBP_PFT URBANON Campbell CaMaON BGCOFF CROPOFF +GRID_PFT_URBANON_CAMBELL_CAMAOFF_BGCOFF_CROPOFF GRID LULC_IGBP_PFT URBANON Campbell CaMaOFF BGCOFF CROPOFF +GRID_PFT_URBANON_vanGen_CAMAON_BGCOFF_CROPOFF GRID LULC_IGBP_PFT URBANON vanGenu CaMaON BGCOFF CROPOFF +GRID_PFT_URBANON_vanGen_CAMAOFF_BGCOFF_CROPOFF GRID LULC_IGBP_PFT URBANON vanGenu CaMaOFF BGCOFF CROPOFF +GRID_PFT_URBANOFF_CAMBELL_CAMAON_BGCOFF_CROPOFF GRID LULC_IGBP_PFT URBANOFF Campbell CaMaON BGCOFF CROPOFF +GRID_PFT_URBANOFF_CAMBELL_CAMAOFF_BGCOFF_CROPOFF GRID LULC_IGBP_PFT URBANOFF Campbell CaMaOFF BGCOFF CROPOFF +GRID_PFT_URBANOFF_vanGen_CAMAON_BGCOFF_CROPOFF GRID LULC_IGBP_PFT URBANOFF vanGenu CaMaON BGCOFF CROPOFF +GRID_PFT_URBANOFF_vanGen_CAMAOFF_BGCOFF_CROPOFF GRID LULC_IGBP_PFT URBANOFF vanGenu CaMaOFF BGCOFF CROPOFF +GRID_PC_URBANON_CAMBELL_CAMAON_BGCON_CROPON GRID LULC_IGBP_PC URBANON Campbell CaMaON BGCON CROPON +GRID_PC_URBANON_CAMBELL_CAMAOFF_BGCON_CROPON GRID LULC_IGBP_PC URBANON Campbell CaMaOFF BGCON CROPON +GRID_PC_URBANON_vanGen_CAMAON_BGCON_CROPON GRID LULC_IGBP_PC URBANON vanGenu CaMaON BGCON CROPON +GRID_PC_URBANON_vanGen_CAMAOFF_BGCON_CROPON GRID LULC_IGBP_PC URBANON vanGenu CaMaOFF BGCON CROPON +GRID_PC_URBANOFF_CAMBELL_CAMAON_BGCON_CROPON GRID LULC_IGBP_PC URBANOFF Campbell CaMaON BGCON CROPON +GRID_PC_URBANOFF_CAMBELL_CAMAOFF_BGCON_CROPON GRID LULC_IGBP_PC URBANOFF Campbell CaMaOFF BGCON CROPON +GRID_PC_URBANOFF_vanGen_CAMAON_BGCON_CROPON GRID LULC_IGBP_PC URBANOFF vanGenu CaMaON BGCON CROPON +GRID_PC_URBANOFF_vanGen_CAMAOFF_BGCON_CROPON GRID LULC_IGBP_PC URBANOFF vanGenu CaMaOFF BGCON CROPON +GRID_PC_URBANON_CAMBELL_CAMAON_BGCOFF_CROPON GRID LULC_IGBP_PC URBANON Campbell CaMaON BGCOFF CROPON +GRID_PC_URBANON_CAMBELL_CAMAOFF_BGCOFF_CROPON GRID LULC_IGBP_PC URBANON Campbell CaMaOFF BGCOFF CROPON +GRID_PC_URBANON_vanGen_CAMAON_BGCOFF_CROPON GRID LULC_IGBP_PC URBANON vanGenu CaMaON BGCOFF CROPON +GRID_PC_URBANON_vanGen_CAMAOFF_BGCOFF_CROPON GRID LULC_IGBP_PC URBANON vanGenu CaMaOFF BGCOFF CROPON +GRID_PC_URBANOFF_CAMBELL_CAMAON_BGCOFF_CROPON GRID LULC_IGBP_PC URBANOFF Campbell CaMaON BGCOFF CROPON +GRID_PC_URBANOFF_CAMBELL_CAMAOFF_BGCOFF_CROPON GRID LULC_IGBP_PC URBANOFF Campbell CaMaOFF BGCOFF CROPON +GRID_PC_URBANOFF_vanGen_CAMAON_BGCOFF_CROPON GRID LULC_IGBP_PC URBANOFF vanGenu CaMaON BGCOFF CROPON +GRID_PC_URBANOFF_vanGen_CAMAOFF_BGCOFF_CROPON GRID LULC_IGBP_PC URBANOFF vanGenu CaMaOFF BGCOFF CROPON +GRID_PC_URBANON_CAMBELL_CAMAON_BGCON_CROPOFF GRID LULC_IGBP_PC URBANON Campbell CaMaON BGCON CROPOFF +GRID_PC_URBANON_CAMBELL_CAMAOFF_BGCON_CROPOFF GRID LULC_IGBP_PC URBANON Campbell CaMaOFF BGCON CROPOFF +GRID_PC_URBANON_vanGen_CAMAON_BGCON_CROPOFF GRID LULC_IGBP_PC URBANON vanGenu CaMaON BGCON CROPOFF +GRID_PC_URBANON_vanGen_CAMAOFF_BGCON_CROPOFF GRID LULC_IGBP_PC URBANON vanGenu CaMaOFF BGCON CROPOFF +GRID_PC_URBANOFF_CAMBELL_CAMAON_BGCON_CROPOFF GRID LULC_IGBP_PC URBANOFF Campbell CaMaON BGCON CROPOFF +GRID_PC_URBANOFF_CAMBELL_CAMAOFF_BGCON_CROPOFF GRID LULC_IGBP_PC URBANOFF Campbell CaMaOFF BGCON CROPOFF +GRID_PC_URBANOFF_vanGen_CAMAON_BGCON_CROPOFF GRID LULC_IGBP_PC URBANOFF vanGenu CaMaON BGCON CROPOFF +GRID_PC_URBANOFF_vanGen_CAMAOFF_BGCON_CROPOFF GRID LULC_IGBP_PC URBANOFF vanGenu CaMaOFF BGCON CROPOFF +GRID_PC_URBANON_CAMBELL_CAMAON_BGCOFF_CROPOFF GRID LULC_IGBP_PC URBANON Campbell CaMaON BGCOFF CROPOFF +GRID_PC_URBANON_CAMBELL_CAMAOFF_BGCOFF_CROPOFF GRID LULC_IGBP_PC URBANON Campbell CaMaOFF BGCOFF CROPOFF +GRID_PC_URBANON_vanGen_CAMAON_BGCOFF_CROPOFF GRID LULC_IGBP_PC URBANON vanGenu CaMaON BGCOFF CROPOFF +GRID_PC_URBANON_vanGen_CAMAOFF_BGCOFF_CROPOFF GRID LULC_IGBP_PC URBANON vanGenu CaMaOFF BGCOFF CROPOFF +GRID_PC_URBANOFF_CAMBELL_CAMAON_BGCOFF_CROPOFF GRID LULC_IGBP_PC URBANOFF Campbell CaMaON BGCOFF CROPOFF +GRID_PC_URBANOFF_CAMBELL_CAMAOFF_BGCOFF_CROPOFF GRID LULC_IGBP_PC URBANOFF Campbell CaMaOFF BGCOFF CROPOFF +GRID_PC_URBANOFF_vanGen_CAMAON_BGCOFF_CROPOFF GRID LULC_IGBP_PC URBANOFF vanGenu CaMaON BGCOFF CROPOFF +GRID_PC_URBANOFF_vanGen_CAMAOFF_BGCOFF_CROPOFF GRID LULC_IGBP_PC URBANOFF vanGenu CaMaOFF BGCOFF CROPOFF +GRID_IGBP_URBANON_CAMBELL_CAMAON_BGCON_CROPOFF GRID LULC_IGBP URBANON Campbell CaMaON BGCON CROPOFF +GRID_IGBP_URBANON_CAMBELL_CAMAOFF_BGCON_CROPOFF GRID LULC_IGBP URBANON Campbell CaMaOFF BGCON CROPOFF +GRID_IGBP_URBANON_vanGen_CAMAON_BGCON_CROPOFF GRID LULC_IGBP URBANON vanGenu CaMaON BGCON CROPOFF +GRID_IGBP_URBANON_vanGen_CAMAOFF_BGCON_CROPOFF GRID LULC_IGBP URBANON vanGenu CaMaOFF BGCON CROPOFF +GRID_IGBP_URBANOFF_CAMBELL_CAMAON_BGCON_CROPOFF GRID LULC_IGBP URBANOFF Campbell CaMaON BGCON CROPOFF +GRID_IGBP_URBANOFF_CAMBELL_CAMAOFF_BGCON_CROPOFF GRID LULC_IGBP URBANOFF Campbell CaMaOFF BGCON CROPOFF +GRID_IGBP_URBANOFF_vanGen_CAMAON_BGCON_CROPOFF GRID LULC_IGBP URBANOFF vanGenu CaMaON BGCON CROPOFF +GRID_IGBP_URBANOFF_vanGen_CAMAOFF_BGCON_CROPOFF GRID LULC_IGBP URBANOFF vanGenu CaMaOFF BGCON CROPOFF +GRID_IGBP_URBANON_CAMBELL_CAMAON_BGCOFF_CROPOFF GRID LULC_IGBP URBANON Campbell CaMaON BGCOFF CROPOFF +GRID_IGBP_URBANON_CAMBELL_CAMAOFF_BGCOFF_CROPOFF GRID LULC_IGBP URBANON Campbell CaMaOFF BGCOFF CROPOFF +GRID_IGBP_URBANON_vanGen_CAMAON_BGCOFF_CROPOFF GRID LULC_IGBP URBANON vanGenu CaMaON BGCOFF CROPOFF +GRID_IGBP_URBANON_vanGen_CAMAOFF_BGCOFF_CROPOFF GRID LULC_IGBP URBANON vanGenu CaMaOFF BGCOFF CROPOFF +GRID_IGBP_URBANOFF_CAMBELL_CAMAON_BGCOFF_CROPOFF GRID LULC_IGBP URBANOFF Campbell CaMaON BGCOFF CROPOFF +GRID_IGBP_URBANOFF_CAMBELL_CAMAOFF_BGCOFF_CROPOFF GRID LULC_IGBP URBANOFF Campbell CaMaOFF BGCOFF CROPOFF +GRID_IGBP_URBANOFF_vanGen_CAMAON_BGCOFF_CROPOFF GRID LULC_IGBP URBANOFF vanGenu CaMaON BGCOFF CROPOFF +GRID_IGBP_URBANOFF_vanGen_CAMAOFF_BGCOFF_CROPOFF GRID LULC_IGBP URBANOFF vanGenu CaMaOFF BGCOFF CROPOFF +GRID_USGS_URBANON_CAMBELL_CAMAON_BGCON_CROPOFF GRID LULC_USGS URBANON Campbell CaMaON BGCON CROPOFF +GRID_USGS_URBANON_CAMBELL_CAMAOFF_BGCON_CROPOFF GRID LULC_USGS URBANON Campbell CaMaOFF BGCON CROPOFF +GRID_USGS_URBANON_vanGen_CAMAON_BGCON_CROPOFF GRID LULC_USGS URBANON vanGenu CaMaON BGCON CROPOFF +GRID_USGS_URBANON_vanGen_CAMAOFF_BGCON_CROPOFF GRID LULC_USGS URBANON vanGenu CaMaOFF BGCON CROPOFF +GRID_USGS_URBANOFF_CAMBELL_CAMAON_BGCON_CROPOFF GRID LULC_USGS URBANOFF Campbell CaMaON BGCON CROPOFF +GRID_USGS_URBANOFF_CAMBELL_CAMAOFF_BGCON_CROPOFF GRID LULC_USGS URBANOFF Campbell CaMaOFF BGCON CROPOFF +GRID_USGS_URBANOFF_vanGen_CAMAON_BGCON_CROPOFF GRID LULC_USGS URBANOFF vanGenu CaMaON BGCON CROPOFF +GRID_USGS_URBANOFF_vanGen_CAMAOFF_BGCON_CROPOFF GRID LULC_USGS URBANOFF vanGenu CaMaOFF BGCON CROPOFF +GRID_USGS_URBANON_CAMBELL_CAMAON_BGCOFF_CROPOFF GRID LULC_USGS URBANON Campbell CaMaON BGCOFF CROPOFF +GRID_USGS_URBANON_CAMBELL_CAMAOFF_BGCOFF_CROPOFF GRID LULC_USGS URBANON Campbell CaMaOFF BGCOFF CROPOFF +GRID_USGS_URBANON_vanGen_CAMAON_BGCOFF_CROPOFF GRID LULC_USGS URBANON vanGenu CaMaON BGCOFF CROPOFF +GRID_USGS_URBANON_vanGen_CAMAOFF_BGCOFF_CROPOFF GRID LULC_USGS URBANON vanGenu CaMaOFF BGCOFF CROPOFF +GRID_USGS_URBANOFF_CAMBELL_CAMAON_BGCOFF_CROPOFF GRID LULC_USGS URBANOFF Campbell CaMaON BGCOFF CROPOFF +GRID_USGS_URBANOFF_CAMBELL_CAMAOFF_BGCOFF_CROPOFF GRID LULC_USGS URBANOFF Campbell CaMaOFF BGCOFF CROPOFF +GRID_USGS_URBANOFF_vanGen_CAMAON_BGCOFF_CROPOFF GRID LULC_USGS URBANOFF vanGenu CaMaON BGCOFF CROPOFF +GRID_USGS_URBANOFF_vanGen_CAMAOFF_BGCOFF_CROPOFF GRID LULC_USGS URBANOFF vanGenu CaMaOFF BGCOFF CROPOFF diff --git a/.github/workflows/build_CoLM_gnu.yml b/.github/workflows/build_CoLM_gnu.yml new file mode 100644 index 00000000..7048d4fb --- /dev/null +++ b/.github/workflows/build_CoLM_gnu.yml @@ -0,0 +1,87 @@ +name: Build_CoLM202X_gnu +on: + pull_request: + branches: + - master + paths-ignore: + - 'postprocess/**' + - 'preprocess/**' + - 'run/**' + - 'README.md' + - '.gitignore' + - '**/**.sh' + push: + branches: + - master + + workflow_dispatch: + +jobs: + Build-CoLM-gnu: + runs-on: ${{ matrix.os }} + strategy: + fail-fast: false + matrix: + os: [ubuntu-latest, ubuntu-20.04] + mpi: ['mpich', 'openmpi', 'intelmpi'] + toolchain: + - {compiler: gcc, version: 13} + - {compiler: gcc, version: 12} + - {compiler: gcc, version: 11} + - {compiler: gcc, version: 10} + - {compiler: gcc, version: 9} + # include: + # - os: ubuntu-latest + # toolchain: {compiler: gcc, version: 12} + exclude: + - os: ubuntu-20.04 + toolchain: {compiler: gcc, version: 12} + - os: ubuntu-latest + toolchain: {compiler: gcc, version: 9} + + steps: + - uses: actions/checkout@v4 + - uses: mpi4py/setup-mpi@v1 + with: + mpi: ${{ matrix.mpi }} + - uses: fortran-lang/setup-fortran@v1 + id: setup-fortran + with: + compiler: ${{ matrix.toolchain.compiler }} + version: ${{ matrix.toolchain.version }} + - name: Install netcdf-fortran library + shell: bash -l {0} + run: sudo apt update && sudo apt install -y netcdf-bin libnetcdf-dev libnetcdff-dev + - name: Test mpi + #run: mpif90 -v + run: which mpif90 + #- name: Test netcdf + # run: nc-config --all + - name: Build CoLM202X + # run: make clean && make all + run: | + cd ${{ github.workspace }} + TestList=./.github/workflows/TestCaseLists + for CaseName in `awk '{print $1}' $TestList` + do + echo "+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++" + echo "Create test cases" + echo $CaseName + echo "+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++" + + echo defineh `cat $TestList |grep $CaseName |awk '{print $2,$3,$4,$5,$6,$7,$8}'` + ./.github/workflows/create_defineh.bash `cat $TestList |grep $CaseName |awk '{print $2,$3,$4,$5,$6,$7,$8}'` + + echo "Create test case $CaseName Complete!" + cat ./include/define.h + + echo "...................................................................." + echo "Start Compilation $CaseName" + echo "...................................................................." + + make clean && make all + done + + echo "----------------------------------------------------------------------" + echo "All test cases are compiled successfully! " + echo "----------------------------------------------------------------------" diff --git a/.github/workflows/create_defineh.bash b/.github/workflows/create_defineh.bash new file mode 100755 index 00000000..ad2a017d --- /dev/null +++ b/.github/workflows/create_defineh.bash @@ -0,0 +1,200 @@ +#!/bin/bash +#./create_defineh.bash GRID LULC_IGBP_PFT URBANON CaMaON BGCON +echo $1 $2 $3 $4 $5 $6 $7 + +if [ $1 = "GRID" ];then + GRIDBASE="#define GRIDBASED" + CATCHMENT="#undef CATCHMENT" + UNSTRUCTU="#undef UNSTRUCTURED" + SINGLEPOI="#undef SinglePoint" +else + if [ $1 = "CATCHMENT" ];then + GRIDBASE="#undef GRIDBASED" + CATCHMENT="#define CATCHMENT" + UNSTRUCTU="#undef UNSTRUCTURED" + SINGLEPOI="#undef SinglePoint" + else + if [ $1 = "UNSTRUCTURED" ];then + GRIDBASE="#undef GRIDBASED" + CATCHMENT="#undef CATCHMENT" + UNSTRUCTU="#define UNSTRUCTURED" + SINGLEPOI="#undef SinglePoint" + else + if [ $1 = "SinglePoint" ];then + GRIDBASE="#undef GRIDBASED" + CATCHMENT="#undef CATCHMENT" + UNSTRUCTU="#undef UNSTRUCTURED" + SINGLEPOI="#define SinglePoint" + else + echo "Error in argument 1, try (GRID, CATCHMENT, UNSTRUCTURED, SinglePoint)" + exit + fi + fi + fi +fi +#echo $GRIDBASE +#echo $CATCHMENT +#echo $UNSTRUCTU +#echo $SINGLEPOI +if [ $2 = "LULC_USGS" ];then + LULC_USGS="#define LULC_USGS" + LULC_IGBP="#undef LULC_IGBP" + LULC_IGBP_PFT="#undef LULC_IGBP_PFT" + LULC_IGBP_PC="#undef LULC_IGBP_PC" +else + if [ $2 = "LULC_IGBP" ];then + LULC_USGS="#undef LULC_USGS" + LULC_IGBP="#define LULC_IGBP" + LULC_IGBP_PFT="#undef LULC_IGBP_PFT" + LULC_IGBP_PC="#undef LULC_IGBP_PC" + else + if [ $2 = "LULC_IGBP_PFT" ];then + LULC_USGS="#undef LULC_USGS" + LULC_IGBP="#undef LULC_IGBP" + LULC_IGBP_PFT="#define LULC_IGBP_PFT" + LULC_IGBP_PC="#undef LULC_IGBP_PC" + else + if [ $2 = "LULC_IGBP_PC" ];then + LULC_USGS="#undef LULC_USGS" + LULC_IGBP="#undef LULC_IGBP" + LULC_IGBP_PFT="#undef LULC_IGBP_PFT" + LULC_IGBP_PC="#define LULC_IGBP_PC" + else + echo "Error in argument 2, try (LULC_USGS, LULC_IGBP, LULC_IGBP_PFT, LULC_IGBP_PC)" + exit + fi + fi + fi +fi + +#echo $LULC_USGS +#echo $LULC_IGBP +#echo $LULC_IGBP_PFT +#echo $LULC_IGBP_PC + +if [ $3 = "URBANON" ];then + URBAN="#define URBAN_MODEL" +else + if [ $3 = "URBANOFF" ];then + URBAN="#undef URBAN_MODEL" + else + echo "Error in argument 3, try (URBANON, URBANOFF)" + exit + fi +fi +#echo $URBAN + +if [ $4 = "Campbell" ];then + CAMPBELL="#define Campbell_SOIL_MODEL" + VENGENU="#undef vanGenuchten_Mualem_SOIL_MODEL" +else + if [ $4 = "vanGenu" ];then + CAMPBELL="#undef Campbell_SOIL_MODEL" + VENGENU="#define vanGenuchten_Mualem_SOIL_MODEL" + else + echo "Error in argument 4, try (Campbell, vanGenu)" + exit + fi +fi + +#echo $CAMPBELL +#echo $VENGENU + +if [ $5 = "CaMaON" ];then + CaMa="#define CaMa_Flood" +else + if [ $5 = "CaMaOFF" ];then + CaMa="#undef CaMa_Flood" + else + echo "Error in argument 5, try (CaMaON, CaMaOFF)" + exit + fi +fi +#echo $CaMa + +if [ $6 = "BGCON" ];then + BGC="#define BGC" +else + if [ $6 = "BGCOFF" ];then + BGC="#undef BGC" + else + echo "Error in argument 6, try (BGCON, BGCOFF)" + exit + fi +fi +#echo $BGC + +if [ $7 = "CROPON" ];then + CROP="#define CROP" +else + if [ $7 = "CROPOFF" ];then + CROP="#undef CROP" + else + echo "Error in argument 7, try (CROPON, CROPOFF)" + fi +fi + +cat>include/define.h<=0 .and. KSTEP==NSTEPS )THEN !! end of run - IREST=1 -ENDIF +!IF ( IFRQ_RST>=0 .and. KSTEP==NSTEPS )THEN !! end of run +! IREST=1 +!ENDIF -IF ( IFRQ_RST>=1 .and. IFRQ_RST<=24 )THEN - IF ( MOD(JHOUR,IFRQ_RST)==0 .and. JMIN==0 )THEN !! at selected hour - IREST=1 - ENDIF -ENDIF +!IF ( IFRQ_RST>=1 .and. IFRQ_RST<=24 )THEN +! IF ( MOD(JHOUR,IFRQ_RST)==0 .and. JMIN==0 )THEN !! at selected hour +! IREST=1 +! ENDIF +!ENDIF -IF ( IFRQ_RST==30 )THEN - IF ( JDD==1 .and. JHOUR==0 .and. JMIN==0 )THEN !! at start of month - IREST=1 - ENDIF -ENDIF +!IF ( IFRQ_RST==30 )THEN +! IF ( JDD==1 .and. JHOUR==0 .and. JMIN==0 )THEN !! at start of month +! IREST=1 +! ENDIF +!ENDIF -IF( IREST==1 )THEN - WRITE(LOGNAM,*) "" - WRITE(LOGNAM,*) "!---------------------!" - WRITE(LOGNAM,*) 'CMF::RESTART_WRITE: write time: ' , JYYYYMMDD, JHHMM +!IF( IREST==1 )THEN +WRITE(LOGNAM,*) "" +WRITE(LOGNAM,*) "!---------------------!" +WRITE(LOGNAM,*) 'CMF::RESTART_WRITE: write time: ' , JYYYYMMDD, JHHMM - IF( LRESTCDF )THEN - CALL WRTE_REST_CDF !! netCDF restart write - ELSE - CALL WRTE_REST_BIN - ENDIF -END IF +IF( LRESTCDF )THEN + CALL WRTE_REST_CDF !! netCDF restart write +ELSE + CALL WRTE_REST_BIN +ENDIF +!END IF CONTAINS !========================================================== diff --git a/Makefile b/Makefile index 1c5c8d8b..2e9663a9 100644 --- a/Makefile +++ b/Makefile @@ -3,8 +3,10 @@ include include/Makeoptions HEADER = include/define.h -INCLUDE_DIR = -Iinclude -I.bld -I${NETCDF_INC} -VPATH = include : share : mksrfdata : mkinidata : main : main/HYDRO : main/BGC : main/URBAN : main/LULCC : CaMa/src : postprocess : .bld +INCLUDE_DIR = -Iinclude -I.bld/ -I${NETCDF_INC} +VPATH = include : share : mksrfdata : mkinidata \ + : main : main/HYDRO : main/BGC : main/URBAN : main/LULCC : main/DA \ + : CaMa/src : postprocess : .bld # ********** Targets ALL ********** .PHONY: all @@ -23,10 +25,10 @@ mkdir_build : OBJS_SHARED = \ MOD_Precision.o \ - MOD_Vars_Global.o \ - MOD_Const_Physical.o \ MOD_SPMD_Task.o \ MOD_Namelist.o \ + MOD_Vars_Global.o \ + MOD_Const_Physical.o \ MOD_Const_LC.o \ MOD_Utils.o \ MOD_TimeManager.o \ @@ -46,17 +48,18 @@ OBJS_SHARED = \ MOD_Mapping_Grid2Pset.o \ MOD_Mapping_Pset2Grid.o \ MOD_AggregationRequestData.o \ - MOD_PixelsetShadow.o \ + MOD_PixelsetShared.o \ MOD_LandElm.o \ MOD_LandHRU.o \ MOD_LandPatch.o \ MOD_LandUrban.o \ + MOD_LandCrop.o \ MOD_LandPFT.o \ - MOD_LandPC.o \ MOD_SrfdataDiag.o \ MOD_SrfdataRestart.o \ MOD_ElmVector.o \ - MOD_HRUVector.o + MOD_HRUVector.o \ + MOD_Urban_Const_LCZ.o ${OBJS_SHARED} : %.o : %.F90 ${HEADER} ${FF} -c ${FOPTS} $(INCLUDE_DIR) -o .bld/$@ $< ${MOD_CMD}.bld @@ -102,7 +105,6 @@ OBJS_BASIC = \ MOD_BGC_Vars_PFTimeVariables.o \ MOD_BGC_Vars_TimeInvariants.o \ MOD_BGC_Vars_TimeVariables.o \ - MOD_Urban_Const_LCZ.o \ MOD_Urban_Vars_1DFluxes.o \ MOD_Urban_Vars_TimeVariables.o \ MOD_Urban_Vars_TimeInvariants.o\ @@ -110,7 +112,6 @@ OBJS_BASIC = \ MOD_Vars_TimeInvariants.o \ MOD_Vars_TimeVariables.o \ MOD_Vars_1DPFTFluxes.o \ - MOD_Vars_1DPCFluxes.o \ MOD_Vars_1DFluxes.o \ MOD_Vars_1DForcing.o \ MOD_Hydro_SoilFunction.o \ @@ -140,8 +141,12 @@ OBJS_BASIC = \ MOD_SoilParametersReadin.o \ MOD_HtopReadin.o \ MOD_UrbanReadin.o \ + MOD_BGC_CNSummary.o \ MOD_IniTimeVariable.o \ MOD_UrbanIniTimeVariable.o \ + MOD_ElementNeighbour.o \ + MOD_Catch_HillslopeNetwork.o \ + MOD_Catch_RiverLakeNetwork.o \ MOD_Initialize.o @@ -210,14 +215,11 @@ OBJS_CAMA_T = $(addprefix .bld/,${OBJECTS_CAMA}) endif OBJS_MAIN = \ - MOD_Hydro_HillslopeNetwork.o \ - MOD_Hydro_RiverLakeNetwork.o \ - MOD_Hydro_BasinNeighbour.o \ - MOD_Hydro_HillslopeFlow.o \ - MOD_Hydro_SubsurfaceFlow.o \ - MOD_Hydro_RiverLakeFlow.o \ + MOD_Catch_HillslopeFlow.o \ + MOD_Catch_SubsurfaceFlow.o \ + MOD_Catch_RiverLakeFlow.o \ MOD_Hydro_Hist.o \ - MOD_Hydro_LateralFlow.o \ + MOD_Catch_LateralFlow.o \ MOD_BGC_CNCStateUpdate1.o \ MOD_BGC_CNCStateUpdate2.o \ MOD_BGC_CNCStateUpdate3.o \ @@ -240,7 +242,6 @@ OBJS_MAIN = \ MOD_BGC_Veg_CNPhenology.o \ MOD_BGC_Veg_NutrientCompetition.o \ MOD_BGC_Veg_CNVegStructUpdate.o \ - MOD_BGC_CNSummary.o \ MOD_BGC_CNAnnualUpdate.o \ MOD_BGC_CNZeroFluxes.o \ MOD_BGC_CNBalanceCheck.o \ @@ -248,16 +249,20 @@ OBJS_MAIN = \ MOD_BGC_Veg_CNNDynamics.o \ MOD_BGC_Veg_CNFireBase.o \ MOD_BGC_Veg_CNFireLi2016.o \ + MOD_Irrigation.o \ MOD_BGC_driver.o \ MOD_Vars_2DForcing.o \ MOD_UserSpecifiedForcing.o \ MOD_ForcingDownscaling.o \ MOD_Forcing.o \ + MOD_DA_GRACE.o \ + MOD_DataAssimilation.o \ MOD_AssimStomataConductance.o \ MOD_PlantHydraulic.o \ MOD_FrictionVelocity.o \ MOD_TurbulenceLEddy.o \ MOD_Ozone.o \ + MOD_CanopyLayerProfile.o \ MOD_LeafTemperature.o \ MOD_LeafTemperaturePC.o \ MOD_SoilThermalParameters.o \ @@ -273,10 +278,12 @@ OBJS_MAIN = \ MOD_NetSolar.o \ MOD_WetBulb.o \ MOD_RainSnowTemp.o \ + MOD_SoilSurfaceResistance.o \ MOD_NewSnow.o \ MOD_Thermal.o \ MOD_Vars_1DAccFluxes.o \ MOD_CaMa_Vars.o \ + MOD_HistWriteBack.o \ MOD_HistGridded.o \ MOD_HistVector.o \ MOD_HistSingle.o \ @@ -300,6 +307,8 @@ OBJS_MAIN = \ MOD_Lulcc_Vars_TimeInvariants.o \ MOD_Lulcc_Vars_TimeVariables.o \ MOD_Lulcc_Initialize.o \ + MOD_Lulcc_TransferTrace.o \ + MOD_Lulcc_MassEnergyConserve.o \ MOD_Lulcc_Driver.o \ CoLMDRIVER.o \ CoLMMAIN.o \ diff --git a/README.md b/README.md index 9325b264..24febace 100644 --- a/README.md +++ b/README.md @@ -1,2 +1,4 @@ -# CoLM202X -The Common Land Model Version 202X +# The Common Land Model Version 202X (CoLM202X) + +[![Build_CoLM202X_gnu](https://github.com/CoLM-SYSU/CoLM202X/actions/workflows/build_CoLM_gnu.yml/badge.svg)](https://github.com/CoLM-SYSU/CoLM202X/actions/workflows/build_CoLM_gnu.yml) + diff --git a/include/Makeoptions.gnu b/include/Makeoptions.gnu index a505758e..6e99b60b 100644 --- a/include/Makeoptions.gnu +++ b/include/Makeoptions.gnu @@ -2,18 +2,28 @@ # mpif90 - gfortran # - FF = /usr/bin/mpif90 -fopenmp + FF = mpif90 -fopenmp NETCDF_LIB = /usr/lib/x86_64-linux-gnu NETCDF_INC = /usr/include MOD_CMD = -J - - FOPTS = -fdefault-real-8 -ffree-form -C -g -u -xcheck=stkovf \ + +# determine the gfortran version + GCC_VERSION := "`gcc -dumpversion`" + IS_GCC_ABOVE_10 := $(shell expr "$(GCC_VERSION)" ">=" "10") + ifeq "$(IS_GCC_ABOVE_10)" "1" + FOPTS = -fdefault-real-8 -ffree-form -C -g -u -xcheck=stkovf \ + -ffpe-trap=invalid,zero,overflow -fbounds-check \ + -mcmodel=medium -fbacktrace -fdump-core -cpp \ + -ffree-line-length-0 -fallow-argument-mismatch + else + FOPTS = -fdefault-real-8 -ffree-form -C -g -u -xcheck=stkovf \ -ffpe-trap=invalid,zero,overflow -fbounds-check \ -mcmodel=medium -fbacktrace -fdump-core -cpp \ - -ffree-line-length-0 - + -ffree-line-length-0 + endif + INCLUDE_DIR = -I../include -I../share -I../mksrfdata -I../mkinidata -I../main -I$(NETCDF_INC) LDFLAGS = -L$(NETCDF_LIB) -lnetcdff -lnetcdf -llapack -lblas diff --git a/include/Makeoptions.intel b/include/Makeoptions.intel index 53f16773..40e65634 100755 --- a/include/Makeoptions.intel +++ b/include/Makeoptions.intel @@ -2,10 +2,12 @@ # mpif90 - ifort # - FF = /opt/mpich-3.4.2-intel/bin/mpif90 + FF = mpif90 -f90=ifort - NETCDF_LIB = /opt/netcdf/lib - NETCDF_INC = /opt/netcdf/include + NETCDF_LIB = /usr/lib/x86_64-linux-gnu + NETCDF_INC = /usr/include + + MATH_LIB = /share/home/dq013/software//miniconda3/lib/ #MKL LIB_PATH MOD_CMD = -module @@ -34,4 +36,3 @@ FCMP = ifort -qopenmp FC = ifort LFLAGS = FFLAGS = -O3 -warn all -fpp -free -assume byterecl -heap-arrays -nogen-interface -lpthread -static-intel - diff --git a/include/define.h b/include/define.h index e75b15f8..c4c483e4 100755 --- a/include/define.h +++ b/include/define.h @@ -5,26 +5,25 @@ #undef UNSTRUCTURED #undef SinglePoint -! 2. Land TYPE classification : +! 2. Land subgrid type classification: ! Select one of the following options. #undef LULC_USGS -#define LULC_IGBP -#undef LULC_IGBP_PFT +#undef LULC_IGBP +#define LULC_IGBP_PFT #undef LULC_IGBP_PC -! 2.1 Urban model setting (put it temporarily here): +! 2.1 3D Urban model (put it temporarily here): #undef URBAN_MODEL -#undef URBAN_LCZ ! 3. If defined, debug information is output. #define CoLMDEBUG ! 3.1 If defined, range of variables is checked. #define RangeCheck ! 3.1 If defined, surface data in vector is mapped to gridded data for checking. -#define SrfdataDiag +#undef SrfdataDiag ! 4. If defined, MPI parallelization is enabled. -#define USEMPI +#define USEMPI ! Conflict: not used when defined SingPoint. #if (defined SinglePoint) #undef USEMPI @@ -32,73 +31,36 @@ ! 5. Hydrological process options. ! 5.1 Two soil hydraulic models can be used. -#define Campbell_SOIL_MODEL -#undef vanGenuchten_Mualem_SOIL_MODEL +#undef Campbell_SOIL_MODEL +#define vanGenuchten_Mualem_SOIL_MODEL ! 5.2 If defined, lateral flow is modeled. -#define LATERAL_FLOW +#define CatchLateralFlow ! Conflicts : #ifndef CATCHMENT -#undef LATERAL_FLOW +#undef CatchLateralFlow #endif -! 6. Soil reflectance can be predefined values or load from files. -! Soil reflectance is now a namelist DEF_SOIL_REFL_SCHEME -! The below will be removed later -!#undef SOIL_REFL_GUESSED -!#define SOIL_REFL_READ - -! 7. If defined, CaMa-Flood model will be used. +! 6. If defined, CaMa-Flood model will be used. #undef CaMa_Flood -! 8. If defined, BGC model is used. +! 7. If defined, BGC model is used. #define BGC + ! Conflicts : only used when LULC_IGBP_PFT is defined. #ifndef LULC_IGBP_PFT #undef BGC #endif -! 8.1 If defined, CROP model is used +! 7.1 If defined, CROP model is used #define CROP ! Conflicts : only used when BGC is defined #ifndef BGC #undef CROP #endif -! 8.2 If defined, Semi-Analytic-Spin-Up (SASU) is used -!#undef SASU -! Conflicts : only used when BGC is defined -!#ifndef BGC -!#undef SASU -!#endif -!SASU switch has been moved to namelist: DEF_USE_SASU -! 8.3 If defined, Fertlization on crop is used -!@#define FERT -! Conflicts : only used when CROP is defined -!#ifndef CROP -!#undef FERT -!#endif -!FERT has been moved to namelist: DEF_USE_FERT -! 8.4 If defined, Nitrification-Denitrification is used -!#define NITRIF -! Conflicts : only used when BGC is defined -!#ifndef BGC -!#undef NITRIF -!#endif -!NITRIF switch has been moved to namelist: DEF_USE_NITRIF -!! 9 If defined, Fire is on -!#undef Fire -! Conflicts : only used when BGC is defined -!#ifndef BGC -!#undef Fire -!#endif -!FIRE switch has been moved to namelist: DEF_USE_FIRE - -! 10 If defined, SNICAR is on -! NOTE: SNICAR is now a namelist DEF_USE_SNICAR -! This macro will be removed later -!#undef SNICAR +! 8. If defined, open Land use and land cover change mode. +#undef LULCC -! 11. If defined, diagnostics in wue model will be output -!#undef WUEdiag +! 9. If defined, data assimilation is used. +#undef DataAssimilation -! 12. If defined, open Land use and land cover change mode. -#undef LULCC +#define VectorInOneFile diff --git a/main/BGC/MOD_BGC_CNBalanceCheck.F90 b/main/BGC/MOD_BGC_CNBalanceCheck.F90 index 30ad01fd..2f4b4b84 100644 --- a/main/BGC/MOD_BGC_CNBalanceCheck.F90 +++ b/main/BGC/MOD_BGC_CNBalanceCheck.F90 @@ -140,7 +140,11 @@ subroutine CBalanceCheck(i,ps,pe,deltim,dlat,dlon) write(*,*)'wood_harvestc = ',wood_harvestc(i)*deltim write(*,*)'grainc_to_cropprodc = ',grainc_to_cropprodc(i)*deltim, grainc_to_food_p(ps)*deltim write(*,*)'-1*som_c_leached = ',som_c_leached(i)*deltim - call abort +#ifdef USEMPI + CALL mpi_abort (p_comm_glb, p_err) +#else + CALL abort +#endif end if end subroutine CBalanceCheck @@ -210,7 +214,11 @@ subroutine NBalanceCheck(i,deltim,dlat,dlon) sminn_leached(i)*deltim,denit(i)*deltim,fire_nloss(i)*deltim,& (wood_harvestn(i)+grainn_to_cropprodn(i))*deltim, - som_n_leached(i) end if - call abort +#ifdef USEMPI + CALL mpi_abort (p_comm_glb, p_err) +#else + CALL abort +#endif end if end subroutine NBalanceCheck diff --git a/main/BGC/MOD_BGC_CNSummary.F90 b/main/BGC/MOD_BGC_CNSummary.F90 index e5556080..ff27f1a4 100644 --- a/main/BGC/MOD_BGC_CNSummary.F90 +++ b/main/BGC/MOD_BGC_CNSummary.F90 @@ -18,6 +18,7 @@ module MOD_BGC_CNSummary use MOD_Precision use MOD_Namelist, only : DEF_USE_NITRIF use MOD_Vars_PFTimeInvariants, only: pftclass + use MOD_Vars_PFTimeVariables, only :irrig_method_p use MOD_BGC_Vars_TimeVariables, only: & totlitc, totsomc, totcwdc, decomp_cpools, decomp_cpools_vr, ctrunc_soil,ctrunc_veg, ctrunc_vr, & totlitn, totsomn, totcwdn, decomp_npools, decomp_npools_vr, ntrunc_soil,ntrunc_veg, ntrunc_vr, & @@ -94,6 +95,9 @@ module MOD_BGC_CNSummary m_livecrootc_to_fire_p, m_livecrootc_storage_to_fire_p, m_livecrootc_xfer_to_fire_p, & m_deadcrootc_to_fire_p, m_deadcrootc_storage_to_fire_p, m_deadcrootc_xfer_to_fire_p, & m_gresp_storage_to_fire_p, m_gresp_xfer_to_fire_p + use MOD_Vars_TimeVariables, only: & + irrig_method_corn , irrig_method_swheat, irrig_method_wwheat, irrig_method_soybean , & + irrig_method_cotton, irrig_method_rice1 , irrig_method_rice2 , irrig_method_sugarcane use MOD_Vars_TimeInvariants, only : patchclass use MOD_Vars_Global, only : spval use MOD_SPMD_Task @@ -114,7 +118,7 @@ module MOD_BGC_CNSummary contains - subroutine CNDriverSummarizeStates(i,ps,pe,nl_soil,dz_soi,ndecomp_pools) + subroutine CNDriverSummarizeStates(i,ps,pe,nl_soil,dz_soi,ndecomp_pools,init) ! !DESCRIPTION: ! summarizes CN state varaibles for veg and soil. @@ -131,11 +135,12 @@ subroutine CNDriverSummarizeStates(i,ps,pe,nl_soil,dz_soi,ndecomp_pools) integer, intent(in) :: nl_soil ! number of total soil real(r8),intent(in) :: dz_soi(1:nl_soil) ! thicknesses of each soil layer (m) integer, intent(in) :: ndecomp_pools ! number of total soil & litter pools + logical, intent(in) :: init call soilbiogeochem_carbonstate_summary(i,nl_soil,dz_soi,ndecomp_pools) call soilbiogeochem_nitrogenstate_summary(i,nl_soil,dz_soi,ndecomp_pools) - call cnveg_carbonstate_summary(i,ps,pe) + call cnveg_carbonstate_summary(i,ps,pe,init) call cnveg_nitrogenstate_summary(i,ps,pe) end subroutine CNDriverSummarizeStates @@ -271,7 +276,7 @@ subroutine soilbiogeochem_nitrogenstate_summary(i,nl_soil,dz_soi,ndecomp_pools) end subroutine soilbiogeochem_nitrogenstate_summary - subroutine cnveg_carbonstate_summary(i,ps,pe) + subroutine cnveg_carbonstate_summary(i,ps,pe,init) ! !DESCRIPTION ! summarizes vegetation C state varaibles. @@ -285,6 +290,7 @@ subroutine cnveg_carbonstate_summary(i,ps,pe) integer, intent(in) :: i ! patch index integer, intent(in) :: ps ! start pft index integer, intent(in) :: pe ! end pft index + logical, intent(in) :: init integer m @@ -343,69 +349,79 @@ subroutine cnveg_carbonstate_summary(i,ps,pe) #ifdef CROP if( pftclass(m) .eq. 17 .or. pftclass(m) .eq. 18 .or. pftclass(m) .eq. 63 .or. pftclass(m) .eq. 64)then - fertnitro_corn(i) = fertnitro_p(m) + fertnitro_corn (i) = fertnitro_p (m) + irrig_method_corn (i) = irrig_method_p(m) else if(pftclass(m) .eq. 19 .or. pftclass(m) .eq. 20)then - fertnitro_swheat(i) = fertnitro_p(m) + fertnitro_swheat (i) = fertnitro_p (m) + irrig_method_swheat(i) = irrig_method_p (m) else if(pftclass(m) .eq. 21 .or. pftclass(m) .eq. 22)then - fertnitro_wwheat(i) = fertnitro_p(m) + fertnitro_wwheat (i) = fertnitro_p (m) + irrig_method_wwheat (i) = irrig_method_p(m) else if(pftclass(m) .eq. 23 .or. pftclass(m) .eq. 24 .or. pftclass(m) .eq. 77 .or. pftclass(m) .eq. 78)then - fertnitro_soybean(i) = fertnitro_p(m) + fertnitro_soybean (i) = fertnitro_p (m) + irrig_method_soybean (i) = irrig_method_p(m) else if(pftclass(m) .eq. 41 .or. pftclass(m) .eq. 42)then - fertnitro_cotton(i) = fertnitro_p(m) + fertnitro_cotton (i) = fertnitro_p (m) + irrig_method_cotton (i) = irrig_method_p(m) else if(pftclass(m) .eq. 61 .or. pftclass(m) .eq. 62)then - fertnitro_rice1(i) = fertnitro_p(m) - fertnitro_rice2(i) = fertnitro_p(m) + fertnitro_rice1 (i) = fertnitro_p (m) + fertnitro_rice2 (i) = fertnitro_p (m) + irrig_method_rice1 (i) = irrig_method_p(m) + irrig_method_rice2 (i) = irrig_method_p(m) else if(pftclass(m) .eq. 67 .or. pftclass(m) .eq. 68)then - fertnitro_sugarcane(i) = fertnitro_p(m) + fertnitro_sugarcane (i) = fertnitro_p (m) + irrig_method_sugarcane(i) = irrig_method_p(m) end if #endif end do - leafc_enftemp (i) = 0._r8 - leafc_enfboreal (i) = 0._r8 - leafc_dnfboreal (i) = 0._r8 - leafc_ebftrop (i) = 0._r8 - leafc_ebftemp (i) = 0._r8 - leafc_dbftrop (i) = 0._r8 - leafc_dbftemp (i) = 0._r8 - leafc_dbfboreal (i) = 0._r8 - leafc_ebstemp (i) = 0._r8 - leafc_dbstemp (i) = 0._r8 - leafc_dbsboreal (i) = 0._r8 - leafc_c3arcgrass (i) = 0._r8 - leafc_c3grass (i) = 0._r8 - leafc_c4grass (i) = 0._r8 - do m = ps, pe - if(pftclass (m) .eq. 1)then - leafc_enftemp (i) = leafc_p(m) - else if(pftclass (m) .eq. 2)then - leafc_enfboreal (i) = leafc_p(m) - else if(pftclass (m) .eq. 3)then - leafc_dnfboreal (i) = leafc_p(m) - else if(pftclass (m) .eq. 4)then - leafc_ebftrop (i) = leafc_p(m) - else if(pftclass (m) .eq. 5)then - leafc_ebftemp (i) = leafc_p(m) - else if(pftclass (m) .eq. 6)then - leafc_dbftrop (i) = leafc_p(m) - else if(pftclass (m) .eq. 7)then - leafc_dbftemp (i) = leafc_p(m) - else if(pftclass (m) .eq. 8)then - leafc_dbfboreal (i) = leafc_p(m) - else if(pftclass (m) .eq. 9)then - leafc_ebstemp (i) = leafc_p(m) - else if(pftclass (m) .eq. 10)then - leafc_dbstemp (i) = leafc_p(m) - else if(pftclass (m) .eq. 11)then - leafc_dbsboreal (i) = leafc_p(m) - else if(pftclass (m) .eq. 12)then - leafc_c3arcgrass(i)= leafc_p(m) - else if(pftclass (m) .eq. 13)then - leafc_c3grass (i) = leafc_p(m) - else if(pftclass (m) .eq. 14)then - leafc_c4grass (i) = leafc_p(m) - end if - end do + if(.not. init)then + leafc_enftemp (i) = 0._r8 + leafc_enfboreal (i) = 0._r8 + leafc_dnfboreal (i) = 0._r8 + leafc_ebftrop (i) = 0._r8 + leafc_ebftemp (i) = 0._r8 + leafc_dbftrop (i) = 0._r8 + leafc_dbftemp (i) = 0._r8 + leafc_dbfboreal (i) = 0._r8 + leafc_ebstemp (i) = 0._r8 + leafc_dbstemp (i) = 0._r8 + leafc_dbsboreal (i) = 0._r8 + leafc_c3arcgrass (i) = 0._r8 + leafc_c3grass (i) = 0._r8 + leafc_c4grass (i) = 0._r8 + do m = ps, pe + if(pftclass (m) .eq. 1)then + leafc_enftemp (i) = leafc_p(m) + else if(pftclass (m) .eq. 2)then + leafc_enfboreal (i) = leafc_p(m) + else if(pftclass (m) .eq. 3)then + leafc_dnfboreal (i) = leafc_p(m) + else if(pftclass (m) .eq. 4)then + leafc_ebftrop (i) = leafc_p(m) + else if(pftclass (m) .eq. 5)then + leafc_ebftemp (i) = leafc_p(m) + else if(pftclass (m) .eq. 6)then + leafc_dbftrop (i) = leafc_p(m) + else if(pftclass (m) .eq. 7)then + leafc_dbftemp (i) = leafc_p(m) + else if(pftclass (m) .eq. 8)then + leafc_dbfboreal (i) = leafc_p(m) + else if(pftclass (m) .eq. 9)then + leafc_ebstemp (i) = leafc_p(m) + else if(pftclass (m) .eq. 10)then + leafc_dbstemp (i) = leafc_p(m) + else if(pftclass (m) .eq. 11)then + leafc_dbsboreal (i) = leafc_p(m) + else if(pftclass (m) .eq. 12)then + leafc_c3arcgrass(i)= leafc_p(m) + else if(pftclass (m) .eq. 13)then + leafc_c3grass (i) = leafc_p(m) + else if(pftclass (m) .eq. 14)then + leafc_c4grass (i) = leafc_p(m) + end if + end do + end if totvegc(i) = sum(totvegc_p(ps:pe)*pftfrac(ps:pe)) ctrunc_veg(i) = sum(ctrunc_p(ps:pe) *pftfrac(ps:pe)) totcolc(i) = totvegc(i) + totcwdc(i) + totlitc(i) + totsomc(i) + ctrunc_veg(i) +ctrunc_soil(i) diff --git a/main/BGC/MOD_BGC_Soil_BiogeochemNitrifDenitrif.F90 b/main/BGC/MOD_BGC_Soil_BiogeochemNitrifDenitrif.F90 index 5105d9b4..f0ce7c86 100644 --- a/main/BGC/MOD_BGC_Soil_BiogeochemNitrifDenitrif.F90 +++ b/main/BGC/MOD_BGC_Soil_BiogeochemNitrifDenitrif.F90 @@ -96,7 +96,7 @@ subroutine SoilBiogeochemNitrifDenitrif(i,nl_soil,dz_soi) ! calculate anoxic fraction of soils ! use rijtema and kroess model after Riley et al., 2000 ! caclulated r_psi as a function of psi - r_min(j) = 2 * surface_tension_water / (rho_w * 9.80616_r8 * abs(smp(j,i))) + r_min(j) = 2 * surface_tension_water / (rho_w * 9.80616_r8 * abs(smp(j,i)*1.e-5)) r_max = 2 * surface_tension_water / (rho_w * 9.80616_r8 * 0.1_r8) r_psi(j) = sqrt(r_min(j) * r_max) ratio_diffusivity_water_gas(j) = (d_con_g21 + d_con_g22*t_soisno(j,i) ) * 1.e-4_r8 / & diff --git a/main/BGC/MOD_BGC_Vars_1DPFTFluxes.F90 b/main/BGC/MOD_BGC_Vars_1DPFTFluxes.F90 index 387153bb..b351a68e 100644 --- a/main/BGC/MOD_BGC_Vars_1DPFTFluxes.F90 +++ b/main/BGC/MOD_BGC_Vars_1DPFTFluxes.F90 @@ -1,6 +1,6 @@ #include -#ifdef LULC_IGBP_PFT +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) MODULE MOD_BGC_Vars_1DPFTFluxes #ifdef BGC @@ -318,7 +318,6 @@ MODULE MOD_BGC_Vars_1DPFTFluxes REAL(r8), allocatable :: grainc_to_cropprodc_p (:) ! pft level: harvested grain C (gC m-2 s-1) REAL(r8), allocatable :: grainn_to_cropprodn_p (:) ! pft level: harvested grain N (gN m-2 s-1) REAL(r8), allocatable :: hrv_xsmrpool_to_atm_p (:) ! pft level: maintenance respiration storage C to atmosphere due to harvest (gC m-2 s-1) - REAL(r8), allocatable :: fert_p (:) ! pft level: nitrogen fertilizer rate (gN m-2 s-1) REAL(r8), allocatable :: soyfixn_p (:) ! pft level: soybean fixed nitrogen rate (gN m-2 s-1) ! PUBLIC MEMBER FUNCTIONS: @@ -650,7 +649,6 @@ SUBROUTINE allocate_1D_BGCPFTFluxes allocate (grainc_to_cropprodc_p (numpft)) ; grainc_to_cropprodc_p (:) = spval allocate (grainn_to_cropprodn_p (numpft)) ; grainn_to_cropprodn_p (:) = spval allocate (hrv_xsmrpool_to_atm_p (numpft)) ; hrv_xsmrpool_to_atm_p (:) = spval - allocate (fert_p (numpft)) ; fert_p (:) = spval allocate (soyfixn_p (numpft)) ; soyfixn_p (:) = spval ENDIF @@ -973,7 +971,6 @@ SUBROUTINE deallocate_1D_BGCPFTFluxes deallocate (grainc_to_cropprodc_p ) deallocate (grainn_to_cropprodn_p ) deallocate (hrv_xsmrpool_to_atm_p ) - deallocate (fert_p ) deallocate (soyfixn_p ) ENDIF @@ -1300,7 +1297,6 @@ SUBROUTINE set_1D_BGCPFTFluxes(Values, Nan) grainc_to_cropprodc_p (:) = Values grainn_to_cropprodn_p (:) = Values hrv_xsmrpool_to_atm_p (:) = Values - fert_p (:) = Values soyfixn_p (:) = Values ENDIF diff --git a/main/BGC/MOD_BGC_Vars_PFTimeVariables.F90 b/main/BGC/MOD_BGC_Vars_PFTimeVariables.F90 index d9a6c66a..d9e112b0 100644 --- a/main/BGC/MOD_BGC_Vars_PFTimeVariables.F90 +++ b/main/BGC/MOD_BGC_Vars_PFTimeVariables.F90 @@ -1,6 +1,6 @@ #include -#if (defined LULC_IGBP_PFT) +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) MODULE MOD_BGC_Vars_PFTimeVariables @@ -160,6 +160,7 @@ MODULE MOD_BGC_Vars_PFTimeVariables REAL(r8),allocatable :: tref_min_inst_p (:) ! temporary daily min of average 2-m temperature (degree C) REAL(r8),allocatable :: tref_max_inst_p (:) ! temporary daily max of average 2-m temperature (degree C) REAL(r8),allocatable :: fertnitro_p (:) ! fertilizer nitrogen (gN m-2) + REAL(r8),allocatable :: fert_p (:) ! fertilizer nitrogen (gN m-2) including manure REAL(r8),allocatable :: latbaset_p (:) ! latitude vary base temperature for gddplant (degree C) REAL(r8),allocatable :: plantdate_p (:) ! planting date (input) #endif @@ -515,6 +516,7 @@ SUBROUTINE allocate_BGCPFTimeVariables () allocate (tref_min_inst_p (numpft)); tref_min_inst_p (:) = spval allocate (tref_max_inst_p (numpft)); tref_max_inst_p (:) = spval allocate (fertnitro_p (numpft)); fertnitro_p (:) = spval + allocate (fert_p (numpft)); fert_p (:) = spval allocate (latbaset_p (numpft)); latbaset_p (:) = spval allocate (plantdate_p (numpft)); plantdate_p (:) = spval #endif @@ -842,6 +844,7 @@ SUBROUTINE READ_BGCPFTimeVariables (file_restart) call ncio_read_vector (file_restart, 'tref_min_inst_p ', landpft, tref_min_inst_p ) call ncio_read_vector (file_restart, 'tref_max_inst_p ', landpft, tref_max_inst_p ) call ncio_read_vector (file_restart, 'fertnitro_p ', landpft, fertnitro_p ) + call ncio_read_vector (file_restart, 'fert_p ', landpft, fert_p ) call ncio_read_vector (file_restart, 'latbaset_p ', landpft, latbaset_p ) call ncio_read_vector (file_restart, 'plantdate_p ', landpft, plantdate_p ) #endif @@ -1384,6 +1387,8 @@ SUBROUTINE WRITE_BGCPFTimeVariables (file_restart) tref_max_inst_p , compress) call ncio_write_vector (file_restart, 'fertnitro_p ', 'pft', landpft, & fertnitro_p , compress) + call ncio_write_vector (file_restart, 'fert_p ', 'pft', landpft, & + fert_p , compress) call ncio_write_vector (file_restart, 'latbaset_p ', 'pft', landpft, & latbaset_p , compress) call ncio_write_vector (file_restart, 'plantdate_p ', 'pft', landpft, & @@ -1888,6 +1893,7 @@ SUBROUTINE deallocate_BGCPFTimeVariables () deallocate (tref_min_inst_p ) deallocate (tref_max_inst_p ) deallocate (fertnitro_p ) + deallocate (fert_p ) deallocate (latbaset_p ) deallocate (plantdate_p ) #endif @@ -2218,6 +2224,7 @@ SUBROUTINE check_BGCPFTimeVariables call check_vector_data ('tref_min_inst_p ', tref_min_inst_p ) call check_vector_data ('tref_max_inst_p ', tref_max_inst_p ) call check_vector_data ('fertnitro_p ', fertnitro_p ) + call check_vector_data ('fert_p ', fert_p ) call check_vector_data ('latbaset_p ', latbaset_p ) call check_vector_data ('plantdate_p ', plantdate_p ) #endif diff --git a/main/BGC/MOD_BGC_Vars_TimeInvariants.F90 b/main/BGC/MOD_BGC_Vars_TimeInvariants.F90 index fea390f6..c08aaea7 100644 --- a/main/BGC/MOD_BGC_Vars_TimeInvariants.F90 +++ b/main/BGC/MOD_BGC_Vars_TimeInvariants.F90 @@ -114,7 +114,7 @@ MODULE MOD_BGC_Vars_TimeInvariants REAL(r8) :: bt_min ! minimum water stress factor REAL(r8) :: bt_max ! maximum water stress factor REAL(r8) :: pot_hmn_ign_counts_alpha ! Potential human ignition counts (alpha in Li et. al. 2012) (1/person/month) - REAL(r8) :: g0 ! constant for fire spread estimates + REAL(r8) :: g0_fire ! constant for fire spread estimates REAL(r8) :: sf ! soluble fraction of mineral N (unitless) REAL(r8) :: sf_no3 ! soluble fraction of NO3 (unitless) @@ -289,7 +289,7 @@ SUBROUTINE READ_BGCTimeInvariants (file_restart) call ncio_read_bcast_serial (file_restart, 'bt_min ', bt_min ) call ncio_read_bcast_serial (file_restart, 'bt_max ', bt_max ) call ncio_read_bcast_serial (file_restart, 'pot_hmn_ign_counts_alpha', pot_hmn_ign_counts_alpha) - call ncio_read_bcast_serial (file_restart, 'g0', g0) + call ncio_read_bcast_serial (file_restart, 'g0_fire', g0_fire) call ncio_read_bcast_serial (file_restart, 'sf', sf) call ncio_read_bcast_serial (file_restart, 'sf_no3', sf_no3) @@ -342,9 +342,15 @@ SUBROUTINE WRITE_BGCTimeInvariants (file_restart) ! call ncio_write_vector (file_restart, 'peatf_lf ', 'patch', landpatch, peatf_lf , compress) call ncio_write_vector (file_restart, 'rice2pdt ', 'patch', landpatch, rice2pdt , compress) +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + if (p_is_master) then +#ifndef VectorInOneFile call ncio_create_file (file_restart) +#endif call ncio_define_dimension(file_restart, 'ndecomp_transitions',ndecomp_transitions) call ncio_define_dimension(file_restart, 'ndecomp_pools' ,ndecomp_pools) call ncio_define_dimension(file_restart, 'nlitter_fire' ,2 ) @@ -439,7 +445,7 @@ SUBROUTINE WRITE_BGCTimeInvariants (file_restart) call ncio_write_serial (file_restart, 'bt_min ', bt_min ) call ncio_write_serial (file_restart, 'bt_max ', bt_max ) call ncio_write_serial (file_restart, 'pot_hmn_ign_counts_alpha', pot_hmn_ign_counts_alpha) - call ncio_write_serial (file_restart, 'g0', g0) + call ncio_write_serial (file_restart, 'g0_fire', g0_fire) call ncio_write_serial (file_restart, 'sf', sf) call ncio_write_serial (file_restart, 'sf_no3', sf_no3) diff --git a/main/BGC/MOD_BGC_Veg_CNFireLi2016.F90 b/main/BGC/MOD_BGC_Veg_CNFireLi2016.F90 index 8e747347..200e88e9 100644 --- a/main/BGC/MOD_BGC_Veg_CNFireLi2016.F90 +++ b/main/BGC/MOD_BGC_Veg_CNFireLi2016.F90 @@ -28,7 +28,7 @@ module MOD_BGC_Veg_CNFireLi2016 use MOD_Vars_TimeInvariants, only: & i_cwd, occur_hi_gdp_tree, gdp_lf, abm_lf, peatf_lf, & lfuel, ufuel, cropfire_a1, borealat, troplat, non_boreal_peatfire_c, boreal_peatfire_c, rh_low, rh_hgh, & - bt_min, bt_max, pot_hmn_ign_counts_alpha, g0, psi0, porsl, bsw + bt_min, bt_max, pot_hmn_ign_counts_alpha, g0_fire, psi0, porsl, bsw #ifdef vanGenuchten_Mualem_SOIL_MODEL use MOD_Vars_TimeInvariants, only: theta_r, alpha_vgm, n_vgm, L_vgm, sc_vgm, fc_vgm #endif @@ -304,7 +304,7 @@ subroutine CNFireArea(i,ps,pe,dlat,nl_soil,idate,dz_soi) nfire(i) = ig/secsphr*fb*fire_m*lgdp(i) !fire counts/km2/sec Lb_lf = 1._r8+10._r8*(1._r8-EXP(-0.06_r8*sqrt(forc_us(i)*forc_us(i)+forc_vs(i)*forc_vs(i)))) spread_m = fire_m**0.5_r8 - farea_burned(i) = min(1._r8,(g0*spread_m*fsr(i)* & + farea_burned(i) = min(1._r8,(g0_fire*spread_m*fsr(i)* & fd(i)/1000._r8)**2*lgdp1(i)* & lpop(i)*nfire(i)*PI*Lb_lf+ & baf_crop(i)+baf_peatf(i)) ! fraction (0-1) per sec diff --git a/main/BGC/MOD_BGC_Veg_CNNDynamics.F90 b/main/BGC/MOD_BGC_Veg_CNNDynamics.F90 index 9c261957..9fdafb12 100644 --- a/main/BGC/MOD_BGC_Veg_CNNDynamics.F90 +++ b/main/BGC/MOD_BGC_Veg_CNNDynamics.F90 @@ -31,13 +31,12 @@ module MOD_BGC_Veg_CNNDynamics use MOD_Vars_TimeInvariants, only: porsl, psi0, bsw use MOD_Vars_TimeVariables, only: h2osoi - use MOD_BGC_Vars_1DPFTFluxes, only: fert_p ! intent(in) - use MOD_BGC_Vars_1DFluxes, only: fert_to_sminn, soyfixn_to_sminn, nfix_to_sminn use MOD_BGC_Vars_TimeVariables, only: sminn, fpg, lag_npp #ifdef CROP use MOD_BGC_Vars_PFTimeVariables, only: croplive_p, hui_p + use MOD_BGC_Vars_PFTimeVariables, only: fert_p #endif use MOD_BGC_Vars_1DPFTFluxes, only: plant_ndemand_p, soyfixn_p diff --git a/main/BGC/MOD_BGC_Veg_CNPhenology.F90 b/main/BGC/MOD_BGC_Veg_CNPhenology.F90 index 017717a5..0f187b4e 100644 --- a/main/BGC/MOD_BGC_Veg_CNPhenology.F90 +++ b/main/BGC/MOD_BGC_Veg_CNPhenology.F90 @@ -77,7 +77,7 @@ module MOD_BGC_Veg_CNPhenology croplive_p , gddplant_p , harvdate_p , gddmaturity_p , & hui_p , peaklai_p , & tref_min_p , tref_max_p , tref_min_inst_p , tref_max_inst_p, & - fertnitro_p , plantdate_p , &! input from files + fertnitro_p , plantdate_p , fert_p ,&! input from files #endif leaf_prof_p , froot_prof_p , & @@ -116,7 +116,7 @@ module MOD_BGC_Veg_CNPhenology grainc_to_food_p , grainn_to_food_p , & cpool_to_grainc_p , npool_to_grainn_p , & livestemc_to_litter_p , livestemn_to_litter_p , & - cpool_to_livestemc_p , fert_p + cpool_to_livestemc_p use MOD_Vars_PFTimeInvariants, only: pftclass, pftfrac diff --git a/main/BGC/MOD_BGC_Veg_CNVegStructUpdate.F90 b/main/BGC/MOD_BGC_Veg_CNVegStructUpdate.F90 index 4175a976..45c110c8 100644 --- a/main/BGC/MOD_BGC_Veg_CNVegStructUpdate.F90 +++ b/main/BGC/MOD_BGC_Veg_CNVegStructUpdate.F90 @@ -15,7 +15,7 @@ module MOD_BGC_Veg_CNVegStructUpdate ! use MOD_Precision - use MOD_Namelist, only: DEF_USE_LAIFEEDBACK + use MOD_Namelist, only: DEF_USE_LAIFEEDBACK, DEF_USE_Fire use MOD_Vars_Global, only: nc3crop, nc3irrig, nbrdlf_evr_shrub, nbrdlf_dcd_brl_shrub, & npcropmin, ntmp_corn, nirrig_tmp_corn, ntrp_corn, nirrig_trp_corn, & nsugarcane, nirrig_sugarcane, nmiscanthus, nirrig_miscanthus, & @@ -127,9 +127,11 @@ subroutine CNVegStructUpdate(i,ps,pe,deltim,npcropmin) end if ! "stubble" after harvest - if (harvdate_p(m) < 999 .and. tlai_p(m) == 0._r8) then - tsai_p(m) = 0.25_r8*(1._r8-farea_burned(i)*0.90_r8) !changed by F. Li and S. Levis - peaklai_p(m) = 0 + if(DEF_USE_Fire)then + if (harvdate_p(m) < 999 .and. tlai_p(m) == 0._r8) then + tsai_p(m) = 0.25_r8*(1._r8-farea_burned(i)*0.90_r8) !changed by F. Li and S. Levis + peaklai_p(m) = 0 + end if end if #endif end if diff --git a/main/BGC/MOD_BGC_driver.F90 b/main/BGC/MOD_BGC_driver.F90 index 1ea844a9..65275572 100644 --- a/main/BGC/MOD_BGC_driver.F90 +++ b/main/BGC/MOD_BGC_driver.F90 @@ -1,6 +1,5 @@ #include #ifdef BGC -#include SUBROUTINE bgc_driver & (i,idate,deltim,dlat,dlon) @@ -26,7 +25,7 @@ SUBROUTINE bgc_driver & use MOD_Precision - use MOD_Namelist, only : DEF_USE_SASU, DEF_USE_NITRIF, DEF_USE_CNSOYFIXN, DEF_USE_FIRE + use MOD_Namelist, only : DEF_USE_SASU, DEF_USE_NITRIF, DEF_USE_CNSOYFIXN, DEF_USE_FIRE, DEF_USE_IRRIGATION use MOD_Const_Physical, only : tfrz, denh2o, denice use MOD_Vars_PFTimeInvariants, only: pftfrac use MOD_LandPFT, only: patch_pft_s, patch_pft_e @@ -63,6 +62,7 @@ SUBROUTINE bgc_driver & use MOD_BGC_Veg_CNNDynamics, only: CNNFixation #ifdef CROP use MOD_BGC_Veg_CNNDynamics, only: CNNFert, CNSoyfix + use MOD_Irrigation, only: CalIrrigationNeeded #endif use MOD_TimeManager use MOD_Vars_Global, only: nl_soil, nl_soil_full, ndecomp_pools, ndecomp_pools_vr, ndecomp_transitions, npcropmin, & @@ -113,7 +113,11 @@ SUBROUTINE bgc_driver & call CNNFert(i, ps, pe) #endif call CNGResp(i, ps, pe, npcropmin) - +#ifdef CROP + if(DEF_USE_IRRIGATION)then + call CalIrrigationNeeded(i,ps,pe,idate,nl_soil,nbedrock,z_soi,dz_soi,deltim,dlon,npcropmin) + end if +#endif ! update vegetation pools from phenology, allocation and nitrogen uptake ! update soil N pools from decomposition and nitrogen competition call CStateUpdate1(i, ps, pe, deltim, nl_soil, ndecomp_transitions, npcropmin) @@ -128,7 +132,6 @@ SUBROUTINE bgc_driver & call CStateUpdate2(i, ps, pe, deltim, nl_soil) call NStateUpdate2(i, ps, pe, deltim, nl_soil, dz_soi) - if(DEF_USE_FIRE)then ! update vegetation and fire pools from fire call CNFireArea(i,ps,pe,dlat,nl_soil,idate,dz_soi) @@ -145,7 +148,7 @@ SUBROUTINE bgc_driver & call CNSASU(i,ps,pe,deltim,idate(1:3),nl_soil,ndecomp_transitions,ndecomp_pools,ndecomp_pools_vr)! only for spin up end if - call CNDriverSummarizeStates(i,ps,pe,nl_soil,dz_soi,ndecomp_pools) + call CNDriverSummarizeStates(i,ps,pe,nl_soil,dz_soi,ndecomp_pools, .false.) call CNDriverSummarizeFluxes(i,ps,pe,nl_soil,dz_soi,ndecomp_transitions,ndecomp_pools,deltim) if( .not. skip_balance_check(i) )then diff --git a/main/CoLM.F90 b/main/CoLM.F90 index fc00402d..0f01141b 100644 --- a/main/CoLM.F90 +++ b/main/CoLM.F90 @@ -44,12 +44,9 @@ PROGRAM CoLM USE MOD_LandUrban USE MOD_Urban_LAIReadin #endif -#ifdef LULC_IGBP_PFT +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) USE MOD_LandPFT #endif -#ifdef LULC_IGBP_PC - USE MOD_LandPC -#endif #if (defined UNSTRUCTURED || defined CATCHMENT) USE MOD_ElmVector #endif @@ -63,8 +60,8 @@ PROGRAM CoLM USE MOD_SingleSrfdata #endif -#if (defined LATERAL_FLOW) - USE MOD_Hydro_LateralFlow +#if (defined CatchLateralFlow) + USE MOD_Catch_LateralFlow #endif USE MOD_Ozone, only: init_ozone_data, update_ozone_data @@ -83,10 +80,22 @@ PROGRAM CoLM USE MOD_Lulcc_Driver #endif +#ifdef CoLMDEBUG + USE MOD_Hydro_SoilWater +#endif + ! SNICAR USE MOD_SnowSnicar, only: SnowAge_init, SnowOptics_init USE MOD_Aerosol, only: AerosolDepInit, AerosolDepReadin +#ifdef DataAssimilation + USE MOD_DataAssimilation +#endif + +#ifdef USEMPI + USE MOD_HistWriteBack +#endif + IMPLICIT NONE character(LEN=256) :: nlfile @@ -126,14 +135,24 @@ PROGRAM CoLM CALL spmd_init () #endif - IF (p_is_master) THEN - CALL system_clock (start_time) - ENDIF - CALL getarg (1, nlfile) CALL read_namelist (nlfile) +#ifdef USEMPI + IF (DEF_HIST_WriteBack) THEN + CALL spmd_assign_writeback () + ENDIF + + IF (p_is_writeback) THEN + CALL hist_writeback_daemon () + ELSE +#endif + + IF (p_is_master) THEN + CALL system_clock (start_time) + ENDIF + casename = DEF_CASE_NAME dir_landdata = DEF_dir_landdata dir_forcing = DEF_dir_forcing @@ -142,7 +161,11 @@ PROGRAM CoLM #ifdef SinglePoint fsrfdata = trim(dir_landdata) // '/srfdata.nc' +#ifndef URBAN_MODEL CALL read_surface_data_single (fsrfdata, mksrfdata=.false.) +#else + CALL read_urban_surface_data_single (fsrfdata, mksrfdata=.false., mkrun=.true.) +#endif #endif deltim = DEF_simulation_time%timestep @@ -194,16 +217,11 @@ PROGRAM CoLM CALL pixelset_load_from_file (dir_landdata, 'landpatch', landpatch, numpatch, lc_year) -#ifdef LULC_IGBP_PFT +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) CALL pixelset_load_from_file (dir_landdata, 'landpft' , landpft , numpft , lc_year) CALL map_patch_to_pft #endif -#ifdef LULC_IGBP_PC - CALL pixelset_load_from_file (dir_landdata, 'landpc' , landpc , numpc , lc_year) - CALL map_patch_to_pc -#endif - #ifdef URBAN_MODEL CALL pixelset_load_from_file (dir_landdata, 'landurban', landurban, numurban, lc_year) CALL map_patch_to_urban @@ -247,14 +265,14 @@ PROGRAM CoLM CALL SnowOptics_init( DEF_file_snowoptics ) ! SNICAR optical parameters CALL SnowAge_init( DEF_file_snowaging ) ! SNICAR aging parameters - !----------------------- + ! ---------------------------------------------------------------------- doalb = .true. dolai = .true. dosst = .false. ! Initialize meteorological forcing data module CALL allocate_1D_Forcing () - CALL forcing_init (dir_forcing, deltim, sdate, lc_year) + CALL forcing_init (dir_forcing, deltim, ststamp, lc_year, etstamp) CALL allocate_2D_Forcing (gforc) ! Initialize history data module @@ -280,7 +298,14 @@ PROGRAM CoLM CALL init_nitrif_data (sdate) ENDIF - CALL init_ndep_data (sdate(1)) + IF (DEF_NDEP_FREQUENCY==1)THEN ! Initial annual ndep data readin + CALL init_ndep_data_annually (sdate(1)) + ELSEIF(DEF_NDEP_FREQUENCY==2)THEN ! Initial monthly ndep data readin + CALL init_ndep_data_monthly (sdate(1),s_month) ! sf_add + ELSE + write(6,*) 'ERROR: DEF_NDEP_FREQUENCY should be only 1-2, Current is:',DEF_NDEP_FREQUENCY + CALL CoLM_stop () + ENDIF IF (DEF_USE_FIRE) THEN CALL init_fire_data (sdate(1)) @@ -288,8 +313,12 @@ PROGRAM CoLM ENDIF #endif -#if (defined LATERAL_FLOW) - CALL lateral_flow_init () +#if (defined CatchLateralFlow) + CALL lateral_flow_init (lc_year) +#endif + +#ifdef DataAssimilation + CALL init_DataAssimilation () #endif ! ====================================================================== @@ -320,7 +349,7 @@ PROGRAM CoLM ! Read in the meteorological forcing ! ---------------------------------------------------------------------- - CALL read_forcing (idate, dir_forcing) + CALL read_forcing (jdate, dir_forcing) IF(DEF_USE_OZONEDATA)THEN CALL update_Ozone_data(itstamp, deltim) @@ -352,8 +381,17 @@ PROGRAM CoLM ENDIF ENDIF - IF (jdate(1) /= year_p) THEN - CALL update_ndep_data (idate(1), iswrite = .true.) + IF (DEF_NDEP_FREQUENCY==1)THEN ! Read Annual Ndep data + IF (jdate(1) /= year_p) THEN + CALL update_ndep_data_annually (idate(1), iswrite = .true.) + ENDIF + ELSEIF(DEF_NDEP_FREQUENCY==2)THEN! Read Monthly Ndep data + IF (jdate(1) /= year_p .or. month /= month_p) THEN !sf_add + CALL update_ndep_data_monthly (jdate(1), month, iswrite = .true.) !sf_add + ENDIF + ELSE + write(6,*) 'ERROR: DEF_NDEP_FREQUENCY should be only 1-2, Current is:',DEF_NDEP_FREQUENCY + CALL CoLM_stop () ENDIF IF(DEF_USE_FIRE)THEN @@ -371,6 +409,40 @@ PROGRAM CoLM ENDIF +#if (defined CatchLateralFlow) + CALL lateral_flow (deltim) +#endif + +#if(defined CaMa_Flood) + call colm_CaMa_drv(idate(3)) ! run CaMa-Flood +#endif + +#ifdef DataAssimilation + CALL do_DataAssimilation (idate, deltim) +#endif + + ! Write out the model variables for restart run and the histroy file + ! ---------------------------------------------------------------------- + CALL hist_out (idate, deltim, itstamp, etstamp, ptstamp, dir_hist, casename) + + ! DO land USE and land cover change simulation + ! ---------------------------------------------------------------------- +#ifdef LULCC + IF ( isendofyear(idate, deltim) ) THEN + CALL deallocate_1D_Forcing + CALL deallocate_1D_Fluxes + + CALL LulccDriver (casename,dir_landdata,dir_restart,& + idate,greenwich) + + CALL allocate_1D_Forcing + CALL forcing_init (dir_forcing, deltim, itstamp, jdate(1)) + CALL deallocate_acc_fluxes + CALL hist_init (dir_hist) + CALL allocate_1D_Fluxes + ENDIF +#endif + ! Get leaf area index ! ---------------------------------------------------------------------- #if(defined DYN_PHENOLOGY) @@ -416,46 +488,24 @@ PROGRAM CoLM ENDIF #endif -#if (defined LATERAL_FLOW) - CALL lateral_flow (deltim) -#endif - -#if(defined CaMa_Flood) - call colm_CaMa_drv(idate(3)) ! run CaMa-Flood -#endif - - ! Write out the model variables for restart run and the histroy file - ! ---------------------------------------------------------------------- - CALL hist_out (idate, deltim, itstamp, etstamp, ptstamp, dir_hist, casename) - -#ifdef LULCC - ! DO land USE and land cover change simulation - IF ( isendofyear(idate, deltim) ) THEN - CALL deallocate_1D_Forcing - CALL deallocate_1D_Fluxes - - CALL LulccDriver (casename,dir_landdata,dir_restart,& - idate,greenwich) - - CALL allocate_1D_Forcing - CALL forcing_init (dir_forcing, deltim, idate, jdate(1)) - CALL deallocate_acc_fluxes - CALL hist_init (dir_hist, DEF_hist_lon_res, DEF_hist_lat_res) - CALL allocate_1D_Fluxes - ENDIF -#endif - IF (save_to_restart (idate, deltim, itstamp, ptstamp)) THEN #ifdef LULCC CALL WRITE_TimeVariables (jdate, jdate(1), casename, dir_restart) #else CALL WRITE_TimeVariables (jdate, lc_year, casename, dir_restart) +#endif +#if(defined CaMa_Flood) + IF (p_is_master) THEN + call colm_cama_write_restart (jdate, lc_year, casename, dir_restart) + ENDIF #endif ENDIF - #ifdef RangeCheck CALL check_TimeVariables () #endif +#ifdef CoLMDEBUG + CALL print_VSF_iteration_stat_info () +#endif #ifdef USEMPI CALL mpi_barrier (p_comm_glb, p_err) @@ -476,7 +526,9 @@ PROGRAM CoLM IF ((spinup_repeat > 1) .and. (ptstamp <= itstamp)) THEN spinup_repeat = spinup_repeat - 1 idate = sdate + jdate = sdate itstamp = ststamp + CALL adj2begin(jdate) CALL forcing_reset () ENDIF @@ -489,11 +541,12 @@ PROGRAM CoLM CALL deallocate_1D_Forcing () CALL deallocate_1D_Fluxes () -#if (defined LATERAL_FLOW) +#if (defined CatchLateralFlow) CALL lateral_flow_final () #endif - CALL hist_final () + CALL forcing_final () + CALL hist_final () #ifdef SinglePoint CALL single_srfdata_final () @@ -507,6 +560,10 @@ PROGRAM CoLM CALL colm_cama_exit ! finalize CaMa-Flood #endif +#ifdef DataAssimilation + CALL final_DataAssimilation () +#endif + IF (p_is_master) THEN write(*,'(/,A25)') 'CoLM Execution Completed.' ENDIF @@ -518,9 +575,14 @@ PROGRAM CoLM 103 format(/, 'Time elapsed : ', I3, ' seconds.') #ifdef USEMPI + ENDIF + + IF (DEF_HIST_WriteBack) THEN + CALL hist_writeback_exit () + ENDIF + CALL spmd_exit #endif END PROGRAM CoLM -! ---------------------------------------------------------------------- -! EOP +! ---------- EOP ------------ diff --git a/main/CoLMDRIVER.F90 b/main/CoLMDRIVER.F90 index 058475b6..5caf8689 100644 --- a/main/CoLMDRIVER.F90 +++ b/main/CoLMDRIVER.F90 @@ -40,125 +40,141 @@ SUBROUTINE CoLMDRIVER (idate,deltim,dolai,doalb,dosst,oro) real(r8), intent(inout) :: oro(numpatch) ! ocean(0)/seaice(2)/ flag - integer :: i, m, u + real(r8) :: deltim_phy + integer :: steps_in_one_deltim + integer :: i, m, u, k ! ====================================================================== #ifdef OPENMP !$OMP PARALLEL DO NUM_THREADS(OPENMP) & -!$OMP PRIVATE(i, m, u) & +!$OMP PRIVATE(i, m, u, k, steps_in_one_deltim, deltim_phy) & !$OMP SCHEDULE(STATIC, 1) #endif + DO i = 1, numpatch + ! Apply forcing mask IF (DEF_forcing%has_missing_value) THEN IF (.not. forcmask(i)) CYCLE ENDIF + ! Apply patch mask + IF (.not. patchmask(i)) CYCLE + m = patchclass(i) + steps_in_one_deltim = 1 + ! deltim need to be within 1800s for waterbody with snow in order to avoid large + ! temperature fluctuations due to rapid snow heat conductance + IF(m == WATERBODY .and. snowdp(i) > 0.0) steps_in_one_deltim = ceiling(deltim/1800.) + deltim_phy = deltim/steps_in_one_deltim + ! For non urban patch or slab urban IF (.not.DEF_URBAN_RUN .or. m.ne.URBAN) THEN - ! ***** Call CoLM main program ***** - ! - CALL CoLMMAIN (i,idate, coszen(i), deltim, & - patchlonr(i), patchlatr(i), patchclass(i), patchtype(i), & - doalb, dolai, dosst, oro(i), & + DO k = 1, steps_in_one_deltim + ! ***** Call CoLM main program ***** + ! + CALL CoLMMAIN (i,idate, coszen(i), deltim_phy, & + patchlonr(i), patchlatr(i), patchclass(i), patchtype(i), & + doalb, dolai, dosst, oro(i), & - ! SOIL INFORMATION AND LAKE DEPTH - soil_s_v_alb(i), soil_d_v_alb(i), soil_s_n_alb(i), soil_d_n_alb(i), & - vf_quartz(1:,i), vf_gravels(1:,i),vf_om(1:,i), vf_sand(1:,i), & - wf_gravels(1:,i),wf_sand(1:,i), porsl(1:,i), psi0(1:,i), & - bsw(1:,i), & + ! SOIL INFORMATION AND LAKE DEPTH + soil_s_v_alb(i), soil_d_v_alb(i), soil_s_n_alb(i), soil_d_n_alb(i), & + vf_quartz(1:,i), vf_gravels(1:,i),vf_om(1:,i), vf_sand(1:,i), & + wf_gravels(1:,i),wf_sand(1:,i), porsl(1:,i), psi0(1:,i), & + bsw(1:,i), & #ifdef vanGenuchten_Mualem_SOIL_MODEL - theta_r(1:,i), alpha_vgm(1:,i), n_vgm(1:,i), L_vgm(1:,i), & - sc_vgm (1:,i), fc_vgm (1:,i), & + theta_r(1:,i), alpha_vgm(1:,i), n_vgm(1:,i), L_vgm(1:,i), & + sc_vgm (1:,i), fc_vgm (1:,i), & #endif - hksati(1:,i), csol(1:,i), k_solids(1:,i), dksatu(1:,i), & - dksatf(1:,i), dkdry(1:,i), & - BA_alpha(1:,i), BA_beta(1:,i), & - rootfr(1:,m), lakedepth(i), dz_lake(1:,i), & + hksati(1:,i), csol(1:,i), k_solids(1:,i), dksatu(1:,i), & + dksatf(1:,i), dkdry(1:,i), & + BA_alpha(1:,i), BA_beta(1:,i), & + rootfr(1:,m), lakedepth(i), dz_lake(1:,i), & #if(defined CaMa_Flood) - ! flood variables [mm, m2/m2, mm/s, mm/s] - flddepth_cama(i),fldfrc_cama(i),fevpg_fld(i), finfg_fld(i), & + ! flood variables [mm, m2/m2, mm/s, mm/s] + flddepth_cama(i),fldfrc_cama(i),fevpg_fld(i), finfg_fld(i), & #endif - ! VEGETATION INFORMATION - htop(i), hbot(i), sqrtdi(m), & - effcon(m), vmax25(m), & - kmax_sun(m), kmax_sha(m), kmax_xyl(m), kmax_root(m), & - psi50_sun(m), psi50_sha(m), psi50_xyl(m), psi50_root(m), & - ck(m), & - slti(m), hlti(m), & - shti(m), hhti(m), trda(m), trdm(m), & - trop(m), gradm(m), binter(m), extkn(m), & - chil(m), rho(1:,1:,m), tau(1:,1:,m), & - - ! ATMOSPHERIC FORCING - forc_pco2m(i), forc_po2m(i), forc_us(i), forc_vs(i), & - forc_t(i), forc_q(i), forc_prc(i), forc_prl(i), & - forc_rain(i), forc_snow(i), forc_psrf(i), forc_pbot(i), & - forc_sols(i), forc_soll(i), forc_solsd(i), forc_solld(i), & - forc_frl(i), forc_hgt_u(i), forc_hgt_t(i), forc_hgt_q(i), & - forc_rhoair(i), & - ! CBL height forcing - forc_hpbl(i), & - ! Aerosol deposition - forc_aerdep(:,i), & - - ! LAND SURFACE VARIABLES REQUIRED FOR RESTART - z_sno(maxsnl+1:,i), dz_sno(maxsnl+1:,i), & - t_soisno(maxsnl+1:,i), wliq_soisno(maxsnl+1:,i), & - wice_soisno(maxsnl+1:,i), smp(1:,i), hk(1:,i), & - t_grnd(i), tleaf(i), ldew(i),ldew_rain(i),ldew_snow(i),& - sag(i), scv(i), snowdp(i), fveg(i), & - fsno(i), sigf(i), green(i), lai(i), & - sai(i), alb(1:,1:,i), ssun(1:,1:,i), ssha(1:,1:,i), & - thermk(i), extkb(i), extkd(i), & - vegwp(1:,i), gs0sun(i), gs0sha(i), & - ! Ozone Stress Variables - lai_old(i), o3uptakesun(i), o3uptakesha(i) ,forc_ozone(i), & - ! End ozone stress variables - zwt(i), wdsrf(i), wa(i), & - t_lake(1:,i), lake_icefrac(1:,i), savedtke1(i), & - - ! SNICAR snow model related - snw_rds(:,i), ssno(:,:,:,i), & - mss_bcpho(:,i), mss_bcphi(:,i), mss_ocpho(:,i), mss_ocphi(:,i), & - mss_dst1(:,i), mss_dst2(:,i), mss_dst3(:,i), mss_dst4(:,i), & - - ! additional diagnostic variables for output - laisun(i), laisha(i), rootr(1:,i), & - rstfacsun_out(i),rstfacsha_out(i),gssun_out(i), gssha_out(i), & - assimsun_out(i), etrsun_out(i), assimsha_out(i), etrsha_out(i), & - h2osoi(1:,i), wat(i), & - - ! FLUXES - taux(i), tauy(i), fsena(i), fevpa(i), & - lfevpa(i), fsenl(i), fevpl(i), etr(i), & - fseng(i), fevpg(i), olrg(i), fgrnd(i), & - trad(i), tref(i), qref(i), rsur(i), & - rnof(i), qintr(i), qinfl(i), qdrip(i), & - rst(i), assim(i), respc(i), sabvsun(i), & - sabvsha(i), sabg(i), sr(i), solvd(i), & - solvi(i), solnd(i), solni(i), srvd(i), & - srvi(i), srnd(i), srni(i), solvdln(i), & - solviln(i), solndln(i), solniln(i), srvdln(i), & - srviln(i), srndln(i), srniln(i), qcharge(i), & - xerr(i), zerr(i), & - - ! TUNABLE modle constants - zlnd, zsno, csoilc, dewmx, & - wtfact, capr, cnfac, ssi, & - wimp, pondmx, smpmax, smpmin, & - trsmx0, tcrit, & - - ! additional variables required by coupling with WRF model - emis(i), z0m(i), zol(i), rib(i), & - ustar(i), qstar(i), tstar(i), & - fm(i), fh(i), fq(i) ) + ! VEGETATION INFORMATION + htop(i), hbot(i), sqrtdi(m), & + effcon(m), vmax25(m), & + kmax_sun(m), kmax_sha(m), kmax_xyl(m), kmax_root(m), & + psi50_sun(m), psi50_sha(m), psi50_xyl(m), psi50_root(m), & + ck(m), & + slti(m), hlti(m), & + shti(m), hhti(m), trda(m), trdm(m), & + trop(m), g1(m), g0(m),gradm(m), binter(m), & + extkn(m), chil(m), rho(1:,1:,m), tau(1:,1:,m), & + + ! ATMOSPHERIC FORCING + forc_pco2m(i), forc_po2m(i), forc_us(i), forc_vs(i), & + forc_t(i), forc_q(i), forc_prc(i), forc_prl(i), & + forc_rain(i), forc_snow(i), forc_psrf(i), forc_pbot(i), & + forc_sols(i), forc_soll(i), forc_solsd(i), forc_solld(i), & + forc_frl(i), forc_hgt_u(i), forc_hgt_t(i), forc_hgt_q(i), & + forc_rhoair(i), & + ! CBL height forcing + forc_hpbl(i), & + ! Aerosol deposition + forc_aerdep(:,i), & + + ! LAND SURFACE VARIABLES REQUIRED FOR RESTART + z_sno(maxsnl+1:,i), dz_sno(maxsnl+1:,i), & + t_soisno(maxsnl+1:,i), wliq_soisno(maxsnl+1:,i), & + wice_soisno(maxsnl+1:,i), smp(1:,i), hk(1:,i), & + t_grnd(i), tleaf(i), ldew(i),ldew_rain(i),ldew_snow(i),& + sag(i), scv(i), snowdp(i), fveg(i), & + fsno(i), sigf(i), green(i), lai(i), & + sai(i), alb(1:,1:,i), ssun(1:,1:,i), ssha(1:,1:,i), & + ssoi(:,:,i), ssno(:,:,i), thermk(i), extkb(i), & + extkd(i), vegwp(1:,i), gs0sun(i), gs0sha(i), & + ! Ozone Stress Variables + lai_old(i), o3uptakesun(i), o3uptakesha(i) ,forc_ozone(i), & + ! End ozone stress variables + zwt(i), wdsrf(i), wa(i), wetwat(i), & + t_lake(1:,i), lake_icefrac(1:,i), savedtke1(i), & + + ! SNICAR snow model related + snw_rds(:,i), ssno_lyr(:,:,:,i), & + mss_bcpho(:,i), mss_bcphi(:,i), mss_ocpho(:,i), mss_ocphi(:,i), & + mss_dst1(:,i), mss_dst2(:,i), mss_dst3(:,i), mss_dst4(:,i), & + + ! additional diagnostic variables for output + laisun(i), laisha(i), rootr(1:,i),rootflux(1:,i),rss(i),& + rstfacsun_out(i),rstfacsha_out(i),gssun_out(i), gssha_out(i), & + assimsun_out(i), etrsun_out(i), assimsha_out(i), etrsha_out(i), & + h2osoi(1:,i), wat(i), & + + ! FLUXES + taux(i), tauy(i), fsena(i), fevpa(i), & + lfevpa(i), fsenl(i), fevpl(i), etr(i), & + fseng(i), fevpg(i), olrg(i), fgrnd(i), & + trad(i), tref(i), qref(i), rsur(i), & + rnof(i), qintr(i), qinfl(i), qdrip(i), & + rst(i), assim(i), respc(i), sabvsun(i), & + sabvsha(i), sabg(i), sr(i), solvd(i), & + solvi(i), solnd(i), solni(i), srvd(i), & + srvi(i), srnd(i), srni(i), solvdln(i), & + solviln(i), solndln(i), solniln(i), srvdln(i), & + srviln(i), srndln(i), srniln(i), qcharge(i), & + xerr(i), zerr(i), & + + ! TUNABLE modle constants + zlnd, zsno, csoilc, dewmx, & + wtfact, capr, cnfac, ssi, & + wimp, pondmx, smpmax, smpmin, & + trsmx0, tcrit, & + + ! additional variables required by coupling with WRF model + emis(i), z0m(i), zol(i), rib(i), & + ustar(i), qstar(i), tstar(i), & + fm(i), fh(i), fq(i) ) + + END DO ENDIF @@ -215,8 +231,8 @@ SUBROUTINE CoLMDRIVER (idate,deltim,dolai,doalb,dosst,oro) htop(i) ,hbot(i) ,sqrtdi(m) ,chil(m) ,& effcon(m) ,vmax25(m) ,slti(m) ,hlti(m) ,& shti(m) ,hhti(m) ,trda(m) ,trdm(m) ,& - trop(m) ,gradm(m) ,binter(m) ,extkn(m) ,& - rho(1:,1:,m) ,tau(1:,1:,m) ,rootfr(1:,m) ,& + trop(m) ,g1(m) ,g0(m),gradm(m) ,binter(m) ,& + extkn(m) ,rho(1:,1:,m) ,tau(1:,1:,m) ,rootfr(1:,m) ,& ! ATMOSPHERIC FORCING forc_pco2m(i) ,forc_po2m(i) ,forc_us(i) ,forc_vs(i) ,& @@ -242,7 +258,7 @@ SUBROUTINE CoLMDRIVER (idate,deltim,dolai,doalb,dosst,oro) wliq_soisno (maxsnl+1:,i) ,wice_soisno (maxsnl+1:,i) ,& t_soisno (maxsnl+1:,i) ,& smp (1:,i) ,hk (1:,i) ,& - t_wallsha (1:,u) ,t_wallsun (1:,u) ,& + t_wallsun (1:,u) ,t_wallsha (1:,u) ,& lai(i) ,sai(i) ,fveg(i) ,sigf(i) ,& green(i) ,tleaf(i) ,ldew(i) ,t_grnd(i) ,& @@ -263,7 +279,7 @@ SUBROUTINE CoLMDRIVER (idate,deltim,dolai,doalb,dosst,oro) t_lake(1:,i) ,lake_icefrac(1:,i), savedtke1(i) ,& ! SNICAR snow model related - snw_rds(:,i) ,ssno(:,:,:,i) ,& + snw_rds(:,i) ,ssno_lyr(:,:,:,i),& mss_bcpho(:,i) ,mss_bcphi(:,i) ,mss_ocpho(:,i) ,mss_ocphi(:,i) ,& mss_dst1(:,i) ,mss_dst2(:,i) ,mss_dst3(:,i) ,mss_dst4(:,i) ,& @@ -273,7 +289,7 @@ SUBROUTINE CoLMDRIVER (idate,deltim,dolai,doalb,dosst,oro) #endif ! additional diagnostic variables for output - laisun(i) ,laisha(i) ,& + laisun(i) ,laisha(i) ,rss(i) ,& rstfacsun_out(i),h2osoi(1:,i) ,wat(i) ,& ! FLUXES @@ -311,6 +327,5 @@ SUBROUTINE CoLMDRIVER (idate,deltim,dolai,doalb,dosst,oro) !$OMP END PARALLEL DO #endif - END SUBROUTINE CoLMDRIVER ! ---------- EOP ------------ diff --git a/main/CoLMMAIN.F90 b/main/CoLMMAIN.F90 index ab0c0211..54a2761d 100644 --- a/main/CoLMMAIN.F90 +++ b/main/CoLMMAIN.F90 @@ -34,8 +34,8 @@ SUBROUTINE CoLMMAIN ( & ck, & slti, hlti, & shti, hhti, trda, trdm, & - trop, gradm, binter, extkn, & - chil, rho, tau, & + trop, g1, g0, gradm, & + binter, extkn, chil, rho, tau,& ! atmospheric forcing forc_pco2m, forc_po2m, forc_us, forc_vs, & @@ -56,24 +56,24 @@ SUBROUTINE CoLMMAIN ( & sag, scv, snowdp, fveg, & fsno, sigf, green, lai, & sai, alb, ssun, ssha, & - thermk, extkb, extkd, & - vegwp, gs0sun, gs0sha, & + ssoi, ssno, thermk, extkb, & + extkd, vegwp, gs0sun, gs0sha, & !Ozone stress variables lai_old, o3uptakesun, o3uptakesha, forc_ozone, & !End ozone stress variables - zwt, wdsrf, wa, & + zwt, wdsrf, wa, wetwat, & t_lake, lake_icefrac, savedtke1, & ! SNICAR snow model related - snw_rds, ssno, & + snw_rds, ssno_lyr, & mss_bcpho, mss_bcphi, mss_ocpho, mss_ocphi, & mss_dst1, mss_dst2, mss_dst3, mss_dst4, & ! additional diagnostic variables for output - laisun, laisha, rootr, & + laisun, laisha, rootr,rootflux,rss, & rstfacsun_out,rstfacsha_out,gssun_out, gssha_out, & assimsun_out, etrsun_out, assimsha_out, etrsha_out, & - h2osoi, wat, & + h2osoi, wat, & ! FLUXES taux, tauy, fsena, fevpa, & @@ -136,17 +136,12 @@ SUBROUTINE CoLMMAIN ( & USE MOD_Precision USE MOD_Vars_Global - USE MOD_Const_Physical, only: tfrz, denh2o, denice - USE MOD_Vars_TimeVariables, only: tlai, tsai -#ifdef LULC_IGBP_PFT + USE MOD_Const_Physical, only: tfrz, denh2o, denice, cpliq, cpice + USE MOD_Vars_TimeVariables, only: tlai, tsai, irrig_rate +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) USE MOD_LandPFT, only : patch_pft_s, patch_pft_e USE MOD_Vars_PFTimeInvariants USE MOD_Vars_PFTimeVariables -#endif -#ifdef LULC_IGBP_PC - USE MOD_LandPC - USE MOD_Vars_PCTimeInvariants - USE MOD_Vars_PCTimeVariables #endif USE MOD_RainSnowTemp USE MOD_NetSolar @@ -162,15 +157,15 @@ SUBROUTINE CoLMMAIN ( & USE MOD_Albedo USE MOD_LAIEmpirical USE MOD_TimeManager - USE MOD_Vars_1DFluxes, only : rsub - USE MOD_Namelist, only: DEF_Interception_scheme, DEF_USE_VARIABLY_SATURATED_FLOW, & - DEF_USE_PLANTHYDRAULICS + USE MOD_Namelist, only: DEF_Interception_scheme, DEF_USE_VariablySaturatedFlow, & + DEF_USE_PLANTHYDRAULICS, DEF_USE_IRRIGATION USE MOD_LeafInterception #if(defined CaMa_Flood) ! get flood depth [mm], flood fraction[0-1], flood evaporation [mm/s], flood inflow [mm/s] USE MOD_CaMa_colmCaMa, only: get_fldevp USE YOS_CMF_INPUT, only: LWINFILT,LWEVAP #endif + USE MOD_SPMD_Task IMPLICIT NONE @@ -188,8 +183,8 @@ SUBROUTINE CoLMMAIN ( & patchlatr ! latitude in radians integer, intent(in) :: & - patchclass ,&! land cover type of USGS classification or others - patchtype ! land water type (0=soil, 1=urban and built-up, + patchclass ,&! land patch class of USGS classification or others + patchtype ! land patch type (0=soil, 1=urban and built-up, ! 2=wetland, 3=land ice, 4=land water bodies, 99 = ocean) ! Parameters ! ---------------------- @@ -217,8 +212,8 @@ SUBROUTINE CoLMMAIN ( & alpha_vgm(1:nl_soil), & ! the parameter corresponding approximately to the inverse of the air-entry value n_vgm (1:nl_soil), & ! a shape parameter L_vgm (1:nl_soil), & ! pore-connectivity parameter - sc_vgm (1:nl_soil), & - fc_vgm (1:nl_soil), & + sc_vgm (1:nl_soil), & ! saturation at the air entry value in the classical vanGenuchten model [-] + fc_vgm (1:nl_soil), & ! a scaling factor by using air entry value in the Mualem model [-] #endif hksati(nl_soil) ,&! hydraulic conductivity at saturation [mm h2o/s] csol(nl_soil) ,&! heat capacity of soil solids [J/(m3 K)] @@ -236,10 +231,10 @@ SUBROUTINE CoLMMAIN ( & sqrtdi ,&! inverse sqrt of leaf dimension [m**-0.5] effcon ,&! quantum efficiency of RuBP regeneration (mol CO2/mol quanta) vmax25 ,&! maximum carboxylation rate at 25 C at canopy top - kmax_sun ,& - kmax_sha ,& - kmax_xyl ,& - kmax_root ,& + kmax_sun ,&! Plant Hydraulics Paramters + kmax_sha ,&! Plant Hydraulics Paramters + kmax_xyl ,&! Plant Hydraulics Paramters + kmax_root ,&! Plant Hydraulics Paramters psi50_sun ,&! water potential at 50% loss of sunlit leaf tissue conductance (mmH2O) psi50_sha ,&! water potential at 50% loss of shaded leaf tissue conductance (mmH2O) psi50_xyl ,&! water potential at 50% loss of xylem tissue conductance (mmH2O) @@ -252,6 +247,8 @@ SUBROUTINE CoLMMAIN ( & trda ,&! temperature coefficient in gs-a model [s5] trdm ,&! temperature coefficient in gs-a model [s6] trop ,&! temperature coefficient in gs-a model + g1 ,&! conductance-photosynthesis slope parameter for medlyn model + g0 ,&! conductance-photosynthesis intercept for medlyn model gradm ,&! conductance-photosynthesis slope parameter binter ,&! conductance-photosynthesis intercep extkn ,&! coefficient of leaf nitrogen allocation @@ -344,6 +341,7 @@ SUBROUTINE CoLMMAIN ( & zwt ,&! the depth to water table [m] wdsrf ,&! depth of surface water [mm] wa ,&! water storage in aquifer [mm] + wetwat ,&! water storage in wetland [mm] snw_rds ( maxsnl+1:0 ) ,&! effective grain radius (col,lyr) [microns, m-6] mss_bcpho ( maxsnl+1:0 ) ,&! mass of hydrophobic BC in snow (col,lyr) [kg] @@ -354,7 +352,7 @@ SUBROUTINE CoLMMAIN ( & mss_dst2 ( maxsnl+1:0 ) ,&! mass of dust species 2 in snow (col,lyr) [kg] mss_dst3 ( maxsnl+1:0 ) ,&! mass of dust species 3 in snow (col,lyr) [kg] mss_dst4 ( maxsnl+1:0 ) ,&! mass of dust species 4 in snow (col,lyr) [kg] - ssno (2,2,maxsnl+1:1) ,&! snow layer absorption [-] + ssno_lyr (2,2,maxsnl+1:1),&! snow layer absorption [-] fveg ,&! fraction of vegetation cover fsno ,&! fractional snow cover @@ -367,6 +365,8 @@ SUBROUTINE CoLMMAIN ( & alb(2,2) ,&! averaged albedo [-] ssun(2,2) ,&! sunlit canopy absorption for solar radiation ssha(2,2) ,&! shaded canopy absorption for solar radiation + ssoi(2,2) ,&! ground soil absorption [-] + ssno(2,2) ,&! ground snow absorption [-] thermk ,&! canopy gap fraction for tir radiation extkb ,&! (k, g(mu)/mu) direct solar extinction coefficient extkd ! diffuse and scattered diffuse PAR extinction coefficient @@ -381,7 +381,9 @@ SUBROUTINE CoLMMAIN ( & gssun_out ,&! sunlit stomata conductance gssha_out ,&! shaded stomata conductance wat ,&! total water storage + rss ,&! soil surface resistance [s/m] rootr(nl_soil),&! water exchange between soil and root. Positive: soil->root [?] + rootflux(nl_soil),&! water exchange between soil and root in different layers. Posiitive: soil->root [?] h2osoi(nl_soil) ! volumetric soil water in layers [m3/m3] real(r8), intent(out) :: & @@ -464,12 +466,23 @@ SUBROUTINE CoLMMAIN ( & errorw ,&! water balnce errore (mm) fiold(maxsnl+1:nl_soil), &! fraction of ice relative to the total water w_old ,&! liquid water mass of the column at the previous time step (mm) +! 03/06/2020, yuan: added + sabg_soil , &! solar absorbed by soil fraction + sabg_snow , &! solar absorbed by snow fraction parsun ,&! PAR by sunlit leaves [W/m2] parsha ,&! PAR by shaded leaves [W/m2] qseva ,&! ground surface evaporation rate (mm h2o/s) qsdew ,&! ground surface dew formation (mm h2o /s) [+] qsubl ,&! sublimation rate from snow pack (mm h2o /s) [+] qfros ,&! surface dew added to snow pack (mm h2o /s) [+] + qseva_soil , &! ground soil surface evaporation rate (mm h2o/s) + qsdew_soil , &! ground soil surface dew formation (mm h2o /s) [+] + qsubl_soil , &! sublimation rate from soil ice pack (mm h2o /s) [+] + qfros_soil , &! surface dew added to soil ice pack (mm h2o /s) [+] + qseva_snow , &! ground snow surface evaporation rate (mm h2o/s) + qsdew_snow , &! ground snow surface dew formation (mm h2o /s) [+] + qsubl_snow , &! sublimation rate from snow pack (mm h2o /s) [+] + qfros_snow , &! surface dew added to snow pack (mm h2o /s) [+] scvold ,&! snow cover for previous time step [mm] sm ,&! rate of snowmelt [kg/(m2 s)] ssw ,&! water volumetric content of soil surface layer [m3/m3] @@ -501,16 +514,17 @@ SUBROUTINE CoLMMAIN ( & ! For SNICAR snow model !---------------------------------------------------------------------- - integer snl_bef !number of snow layers - real(r8) forc_aer ( 14 ) !aerosol deposition from atmosphere model (grd,aer) [kg m-1 s-1] - real(r8) snofrz (maxsnl+1:0) !snow freezing rate (col,lyr) [kg m-2 s-1] - real(r8) t_soisno_ (maxsnl+1:1) !soil + snow layer temperature [K] - real(r8) dz_soisno_(maxsnl+1:1) !layer thickness (m) - real(r8) sabg_lyr (maxsnl+1:1) !snow layer absorption [W/m-2] + integer snl_bef !number of snow layers + real(r8) forc_aer ( 14 ) !aerosol deposition from atmosphere model (grd,aer) [kg m-1 s-1] + real(r8) snofrz (maxsnl+1:0) !snow freezing rate (col,lyr) [kg m-2 s-1] + real(r8) t_soisno_ (maxsnl+1:1) !soil + snow layer temperature [K] + real(r8) dz_soisno_ (maxsnl+1:1) !layer thickness (m) + real(r8) sabg_snow_lyr(maxsnl+1:1) !snow layer absorption [W/m-2] !---------------------------------------------------------------------- - real(r8) :: a, aa + real(r8) :: a, aa, gwat + real(r8) :: wextra, t_rain, t_snow integer ps, pe, pc !====================================================================== @@ -552,8 +566,8 @@ SUBROUTINE CoLMMAIN ( & IF (DEF_Aerosol_Readin) THEN forc_aer(:) = forc_aerdep ! read from outside forcing file ELSE - forc_aer(:) = 4.2E-7 ! manual setting - !forc_aer(:) = 0. + forc_aer(:) = 0. ! manual setting + !forc_aer(:) = 4.2E-7 ! manual setting ENDIF @@ -564,8 +578,8 @@ SUBROUTINE CoLMMAIN ( & CALL netsolar (ipatch,idate,deltim,patchlonr,patchtype,& forc_sols,forc_soll,forc_solsd,forc_solld,& - alb,ssun,ssha,lai,sai,rho,tau,ssno,& - parsun,parsha,sabvsun,sabvsha,sabg,sabg_lyr,sr,& + alb,ssun,ssha,lai,sai,rho,tau,ssoi,ssno,ssno_lyr,& + parsun,parsha,sabvsun,sabvsha,sabg,sabg_soil,sabg_snow,fsno,sabg_snow_lyr,sr,& solvd,solvi,solnd,solni,srvd,srvi,srnd,srni,& solvdln,solviln,solndln,solniln,srvdln,srviln,srndln,srniln) @@ -604,8 +618,11 @@ SUBROUTINE CoLMMAIN ( & totwb = ldew + scv + sum(wice_soisno(1:)+wliq_soisno(1:)) + wa - IF (DEF_USE_VARIABLY_SATURATED_FLOW) THEN + IF (DEF_USE_VariablySaturatedFlow) THEN totwb = totwb + wdsrf + IF (patchtype == 2) THEN + totwb = totwb + wetwat + ENDIF ENDIF fiold(:) = 0.0 @@ -616,7 +633,7 @@ SUBROUTINE CoLMMAIN ( & !---------------------------------------------------------------------- ! [2] Canopy interception and precipitation onto ground surface !---------------------------------------------------------------------- - +qflx_irrig_sprinkler = 0._r8 IF (patchtype == 0) THEN #if(defined LULC_USGS || defined LULC_IGBP) @@ -626,19 +643,13 @@ SUBROUTINE CoLMMAIN ( & #endif -#ifdef LULC_IGBP_PFT +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) CALL LEAF_interception_pftwrap (ipatch,deltim,dewmx,forc_us,forc_vs,forc_t,& prc_rain,prc_snow,prl_rain,prl_snow,& ldew,ldew_rain,ldew_snow,z0m,forc_hgt_u,pg_rain,pg_snow,qintr,qintr_rain,qintr_snow) #endif -#ifdef LULC_IGBP_PC - CALL LEAF_interception_pcwrap (ipatch,deltim,dewmx,forc_us,forc_vs,forc_t,chil,& - prc_rain,prc_snow,prl_rain,prl_snow,& - ldew,ldew_rain,ldew_snow,forc_hgt_u,pg_rain,pg_snow,qintr,qintr_rain,qintr_snow) -#endif - ELSE CALL LEAF_interception_wrap (deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sai,forc_t, tleaf,& prc_rain,prc_snow,prl_rain,prl_snow,& @@ -655,13 +666,13 @@ SUBROUTINE CoLMMAIN ( & CALL newsnow (patchtype,maxsnl,deltim,t_grnd,pg_rain,pg_snow,bifall,& t_precip,zi_soisno(:0),z_soisno(:0),dz_soisno(:0),t_soisno(:0),& - wliq_soisno(:0),wice_soisno(:0),fiold(:0),snl,sag,scv,snowdp,fsno) + wliq_soisno(:0),wice_soisno(:0),fiold(:0),snl,sag,scv,snowdp,fsno,wetwat) - ! new snow layer - IF (snl .lt. snl_bef) THEN - sabg_lyr(snl+1:snl-snl_bef+1) = sabg_lyr(snl_bef+1:1) - sabg_lyr(snl-snl_bef+2:1) = 0. - ENDIF + ! new snow layer emerge, pull up the snow layer absorption + !IF (snl .lt. snl_bef) THEN + ! sabg_snow_lyr(snl+1:snl-snl_bef+1) = sabg_snow_lyr(snl_bef+1:1) + ! sabg_snow_lyr(snl-snl_bef+2:1) = 0. + !ENDIF !---------------------------------------------------------------------- ! [4] Energy and Water balance @@ -685,7 +696,7 @@ SUBROUTINE CoLMMAIN ( & BA_alpha ,BA_beta ,& lai ,laisun ,laisha ,& sai ,htop ,hbot ,sqrtdi ,& - rootfr ,rstfacsun_out ,rstfacsha_out ,& + rootfr ,rstfacsun_out ,rstfacsha_out ,rss ,& gssun_out ,gssha_out ,& assimsun_out ,etrsun_out ,assimsha_out ,etrsha_out ,& @@ -698,13 +709,13 @@ SUBROUTINE CoLMMAIN ( & lai_old ,o3uptakesun ,o3uptakesha ,forc_ozone ,& !End ozone stress variables slti ,hlti ,shti ,hhti ,& - trda ,trdm ,trop ,gradm ,& - binter ,extkn ,forc_hgt_u ,forc_hgt_t ,& - forc_hgt_q ,forc_us ,forc_vs ,forc_t ,& - forc_q ,forc_rhoair ,forc_psrf ,forc_pco2m ,& - forc_hpbl ,& + trda ,trdm ,trop ,g1 ,& + g0 ,gradm ,binter ,extkn ,& + forc_hgt_u ,forc_hgt_t ,forc_hgt_q ,forc_us ,& + forc_vs ,forc_t ,forc_q ,forc_rhoair ,& + forc_psrf ,forc_pco2m ,forc_hpbl ,& forc_po2m ,coszen ,parsun ,parsha ,& - sabvsun ,sabvsha ,sabg ,forc_frl ,& + sabvsun ,sabvsha ,sabg,sabg_soil,sabg_snow,forc_frl ,& extkb ,extkd ,thermk ,fsno ,& sigf ,dz_soisno(lb:) ,z_soisno(lb:) ,zi_soisno(lb-1:) ,& tleaf ,t_soisno(lb:) ,wice_soisno(lb:) ,wliq_soisno(lb:) ,& @@ -712,23 +723,30 @@ SUBROUTINE CoLMMAIN ( & taux ,tauy ,fsena ,fevpa ,& lfevpa ,fsenl ,fevpl ,etr ,& fseng ,fevpg ,olrg ,fgrnd ,& - rootr ,qseva ,qsdew ,qsubl ,& - qfros ,sm ,tref ,qref ,& + rootr ,rootflux ,& + qseva ,qsdew ,qsubl ,qfros ,& + qseva_soil ,qsdew_soil ,qsubl_soil ,qfros_soil ,& + qseva_snow ,qsdew_snow ,qsubl_snow ,qfros_snow ,& + sm ,tref ,qref ,& trad ,rst ,assim ,respc ,& + errore ,emis ,z0m ,zol ,& rib ,ustar ,qstar ,tstar ,& fm ,fh ,fq ,pg_rain ,& pg_snow ,t_precip ,qintr_rain ,qintr_snow ,& - snofrz(lbsn:0) ,sabg_lyr(lb:1) ) + snofrz(lbsn:0) ,sabg_snow_lyr(lb:1) ) - IF (.not. DEF_USE_VARIABLY_SATURATED_FLOW) THEN + IF (.not. DEF_USE_VariablySaturatedFlow) THEN - CALL WATER (ipatch ,patchtype ,lb ,nl_soil ,& + CALL WATER_2014 (ipatch,patchtype ,lb ,nl_soil ,& deltim ,z_soisno(lb:) ,dz_soisno(lb:) ,zi_soisno(lb-1:) ,& bsw ,porsl ,psi0 ,hksati ,& - rootr ,t_soisno(lb:) ,wliq_soisno(lb:) ,wice_soisno(lb:) ,smp,hk,& - pg_rain ,sm ,etr ,qseva ,& - qsdew ,qsubl ,qfros ,rsur ,& + rootr,rootflux ,t_soisno(lb:) ,wliq_soisno(lb:) ,wice_soisno(lb:) ,smp,hk,& + pg_rain ,sm ,etr ,& + qseva ,qsdew ,qsubl ,qfros ,& + qseva_soil ,qsdew_soil ,qsubl_soil ,qfros_soil ,& + qseva_snow ,qsdew_snow ,qsubl_snow ,qfros_snow ,& + fsno ,rsur ,& rnof ,qinfl ,wtfact ,pondmx ,& ssi ,wimp ,smpmin ,zwt ,& wa ,qcharge ,errw_rsub & @@ -755,13 +773,16 @@ SUBROUTINE CoLMMAIN ( & sc_vgm ,fc_vgm ,& #endif porsl ,psi0 ,hksati ,& - rootr ,t_soisno(lb:) ,wliq_soisno(lb:) ,wice_soisno(lb:) ,smp,hk,& + rootr,rootflux ,t_soisno(lb:) ,wliq_soisno(lb:) ,wice_soisno(lb:) ,smp,hk,& pg_rain ,sm ,etr ,qseva ,& - qsdew ,qsubl ,qfros ,rsur ,& + qsdew ,qsubl ,qfros ,& + qseva_soil ,qsdew_soil ,qsubl_soil ,qfros_soil ,& + qseva_snow ,qsdew_snow ,qsubl_snow ,qfros_snow ,& + fsno ,rsur ,& rnof ,qinfl ,wtfact ,ssi ,& pondmx, & wimp ,zwt ,wdsrf ,wa ,& - qcharge ,errw_rsub & + wetwat ,qcharge ,errw_rsub & #if(defined CaMa_Flood) !add variables for flood depth [mm], flood fraction [0-1] and re-infiltration [mm/s] calculation. ,flddepth,fldfrc,qinfl_fld & @@ -842,8 +863,11 @@ SUBROUTINE CoLMMAIN ( & ! ---------------------------------------- endwb=sum(wice_soisno(1:)+wliq_soisno(1:))+ldew+scv + wa - IF (DEF_USE_VARIABLY_SATURATED_FLOW) THEN + IF (DEF_USE_VariablySaturatedFlow) THEN endwb = endwb + wdsrf + IF (patchtype == 2) THEN + endwb = endwb + wetwat + ENDIF ENDIF #if(defined CaMa_Flood) IF (LWINFILT) THEN @@ -853,20 +877,31 @@ SUBROUTINE CoLMMAIN ( & ENDIF #endif -#ifndef LATERAL_FLOW +#ifndef CatchLateralFlow errorw=(endwb-totwb)-(forc_prc+forc_prl-fevpa-rnof-errw_rsub)*deltim #else ! for lateral flow, "rsur" is considered in HYDRO/MOD_Hydro_SurfaceFlow.F90 - errorw=(endwb-totwb)-(forc_prc+forc_prl-fevpa-rnof-rsur-errw_rsub)*deltim + errorw=(endwb-totwb)-(forc_prc+forc_prl-fevpa-errw_rsub)*deltim +#endif + +#ifdef CROP + if (DEF_USE_IRRIGATION) errorw = errorw - irrig_rate(ipatch)*deltim #endif - IF(patchtype==2) errorw=0. !wetland + + IF (.not. DEF_USE_VariablySaturatedFlow) THEN + IF (patchtype==2) errorw=0. !wetland + ENDIF xerr=errorw/deltim #if(defined CoLMDEBUG) IF (abs(errorw) > 1.e-3) THEN - write(6,*) 'Warning: water balance violation', ipatch,errorw,patchclass - STOP + IF (patchtype <= 1) THEN + write(6,*) 'Warning: water balance violation in CoLMMAIN (soil) ', errorw + ELSEIF (patchtype == 2) THEN + write(6,*) 'Warning: water balance violation in CoLMMAIN (wetland) ', errorw + ENDIF + CALL CoLM_stop () ENDIF IF(abs(errw_rsub*deltim)>1.e-3) THEN write(6,*) 'Subsurface runoff deficit due to PHS', errw_rsub*deltim @@ -897,6 +932,10 @@ SUBROUTINE CoLMMAIN ( & ENDDO totwb = scv + sum(wice_soisno(1:)+wliq_soisno(1:)) + IF (DEF_USE_VariablySaturatedFlow) THEN + totwb = wdsrf + totwb + ENDIF + fiold(:) = 0.0 IF (snl <0 ) THEN fiold(snl+1:0)=wice_soisno(snl+1:0)/(wliq_soisno(snl+1:0)+wice_soisno(snl+1:0)) @@ -905,6 +944,28 @@ SUBROUTINE CoLMMAIN ( & pg_rain = prc_rain + prl_rain pg_snow = prc_snow + prl_snow + t_rain = t_precip + IF (wliq_soisno(1) > dz_soisno(1)*denh2o) THEN + wextra = (wliq_soisno(1) - dz_soisno(1)*denh2o) / deltim + t_rain = (pg_rain*t_precip + wextra*t_soisno(1)) / (pg_rain + wextra) + pg_rain = pg_rain + wextra + wliq_soisno(1) = dz_soisno(1)*denh2o + totwb = totwb - wextra*deltim + ENDIF + + t_snow = t_precip + IF (wice_soisno(1) > dz_soisno(1)*denice) THEN + wextra = (wice_soisno(1) - dz_soisno(1)*denice) / deltim + t_snow = (pg_snow*t_precip + wextra*t_soisno(1)) / (pg_snow + wextra) + pg_snow = pg_snow + wextra + wice_soisno(1) = dz_soisno(1)*denice + totwb = totwb - wextra*deltim + ENDIF + + IF (pg_rain+pg_snow > 0) THEN + t_precip = (pg_rain*cpliq*t_rain + pg_snow*cpice*t_snow)/(pg_rain*cpliq+pg_snow*cpice) + ENDIF + !---------------------------------------------------------------- ! Initilize new snow nodes for snowfall / sleet !---------------------------------------------------------------- @@ -915,11 +976,11 @@ SUBROUTINE CoLMMAIN ( & t_precip,zi_soisno(:0),z_soisno(:0),dz_soisno(:0),t_soisno(:0),& wliq_soisno(:0),wice_soisno(:0),fiold(:0),snl,sag,scv,snowdp,fsno) - ! new snow layer - IF (snl .lt. snl_bef) THEN - sabg_lyr(snl+1:snl-snl_bef+1) = sabg_lyr(snl_bef+1:1) - sabg_lyr(snl-snl_bef+2:1) = 0. - ENDIF + ! new snow layer emerge, pull up the snow layer absorption + !IF (snl .lt. snl_bef) THEN + ! sabg_snow_lyr(snl+1:snl-snl_bef+1) = sabg_snow_lyr(snl_bef+1:1) + ! sabg_snow_lyr(snl-snl_bef+2:1) = 0. + !ENDIF !---------------------------------------------------------------- ! Energy and Water balance @@ -945,7 +1006,7 @@ SUBROUTINE CoLMMAIN ( & rib ,ustar ,qstar ,tstar ,& fm ,fh ,fq ,pg_rain ,& pg_snow ,t_precip , & - snofrz(lbsn:0), sabg_lyr(lb:1) ) + snofrz(lbsn:0), sabg_snow_lyr(lb:1) ) IF (DEF_USE_SNICAR) THEN @@ -954,7 +1015,7 @@ SUBROUTINE CoLMMAIN ( & wliq_soisno ,wice_soisno ,pg_rain ,pg_snow ,& sm ,scv ,snowdp ,imelt ,& fiold ,snl ,qseva ,qsdew ,& - qsubl ,qfros ,rsur ,rnof ,& + qsubl ,qfros ,gwat , & ssi ,wimp ,forc_us ,forc_vs ,& ! SNICAR forc_aer ,& @@ -966,10 +1027,32 @@ SUBROUTINE CoLMMAIN ( & wliq_soisno ,wice_soisno ,pg_rain ,pg_snow ,& sm ,scv ,snowdp ,imelt ,& fiold ,snl ,qseva ,qsdew ,& - qsubl ,qfros ,rsur ,rnof ,& + qsubl ,qfros ,gwat , & ssi ,wimp ,forc_us ,forc_vs ) ENDIF + IF (.not. DEF_USE_VariablySaturatedFlow) THEN + rsur = max(0.0,gwat) + rnof = rsur + ELSE + a = wdsrf + wliq_soisno(1) + gwat * deltim + IF (a > dz_soisno(1)*denh2o) THEN + wliq_soisno(1) = dz_soisno(1)*denh2o + wdsrf = a - wliq_soisno(1) + ELSE + wdsrf = 0. + wliq_soisno(1) = max(a, 1.e-8) + ENDIF +#ifndef CatchLateralFlow + IF (wdsrf > pondmx) THEN + rsur = (wdsrf - pondmx) / deltim + wdsrf = pondmx + ELSE + rsur = 0. + ENDIF + rnof = rsur +#endif + ENDIF lb = snl + 1 t_grnd = t_soisno(lb) @@ -979,9 +1062,31 @@ SUBROUTINE CoLMMAIN ( & ! ---------------------------------------- zerr=errore - endwb=scv+sum(wice_soisno(1:)+wliq_soisno(1:)) + endwb = scv + sum(wice_soisno(1:)+wliq_soisno(1:)) + IF (DEF_USE_VariablySaturatedFlow) THEN + endwb = wdsrf + endwb + ENDIF + +#ifndef CatchLateralFlow errorw=(endwb-totwb)-(pg_rain+pg_snow-fevpa-rnof)*deltim - xerr=errorw/deltim +#else + errorw=(endwb-totwb)-(pg_rain+pg_snow-fevpa)*deltim +#endif + +#if(defined CoLMDEBUG) + IF (DEF_USE_VariablySaturatedFlow) THEN + IF (abs(errorw) > 1.e-3) THEN + write(6,*) 'Warning: water balance violation in CoLMMAIN (land ice) ', errorw + CALL CoLM_stop () + ENDIF + ENDIF +#endif + + IF (DEF_USE_VariablySaturatedFlow) THEN + xerr=errorw/deltim + ELSE + xerr = 0. + ENDIF !====================================================================== @@ -989,6 +1094,11 @@ SUBROUTINE CoLMMAIN ( & !====================================================================== + totwb = scv + sum(wice_soisno(1:)+wliq_soisno(1:)) + wa + IF (DEF_USE_VariablySaturatedFlow) THEN + totwb = totwb + wdsrf + ENDIF + snl = 0 DO j = maxsnl+1, 0 IF (wliq_soisno(j)+wice_soisno(j) > 0.) THEN @@ -1053,7 +1163,7 @@ SUBROUTINE CoLMMAIN ( & lake_icefrac ,savedtke1 ,& ! SNICAR model variables - snofrz ,sabg_lyr ,& + snofrz ,sabg_snow_lyr,& ! END SNICAR model variables ! "out" laketem arguments @@ -1078,6 +1188,7 @@ SUBROUTINE CoLMMAIN ( & ! --------------------------- z_soisno ,dz_soisno ,zi_soisno ,t_soisno ,& wice_soisno ,wliq_soisno ,t_lake ,lake_icefrac ,& + gwat , & fseng ,fgrnd ,snl ,scv ,& snowdp ,sm ,forc_us ,forc_vs & @@ -1093,15 +1204,58 @@ SUBROUTINE CoLMMAIN ( & ! this unreasonable assumption should be updated in the future version a = (sum(wliq_soisno(1:))+sum(wice_soisno(1:))+scv-w_old-scvold)/deltim aa = qseva+qsubl-qsdew-qfros -#ifndef LATERAL_FLOW - rsur = max(0., pg_rain + pg_snow - aa - a) - rsub(ipatch) = 0. - rnof = rsur -#else - ! for lateral flow, "rsub" refers to water exchage between hillslope and river - rnof = rsur + rsub(ipatch) + + IF (.not. DEF_USE_VariablySaturatedFlow) THEN + rsur = max(0., pg_rain + pg_snow - aa - a) + rnof = rsur + ELSE + ! for lateral flow, only water change vertically is calculated here. + ! TODO : snow should be considered. + wdsrf = wdsrf + (pg_rain + pg_snow - aa - a) * deltim + + IF (wdsrf + wa < 0) THEN + wa = wa + wdsrf + wdsrf = 0 + else + wdsrf = wa + wdsrf + wa = 0 + ENDIF +#ifndef CatchLateralFlow + IF (wdsrf > pondmx) THEN + rsur = (wdsrf - pondmx) / deltim + wdsrf = pondmx + ELSE + rsur = 0. + ENDIF + rnof = rsur +#endif + ENDIF + + endwb = scv + sum(wice_soisno(1:)+wliq_soisno(1:)) + wa + IF (DEF_USE_VariablySaturatedFlow) THEN + endwb = endwb + wdsrf + ENDIF + + errorw = (endwb-totwb) - (forc_prc+forc_prl-fevpa) * deltim +#ifndef CatchLateralFlow + errorw = errorw + rnof * deltim +#endif + +#if(defined CoLMDEBUG) + IF (DEF_USE_VariablySaturatedFlow) THEN + IF (abs(errorw) > 1.e-3) THEN + write(*,*) 'Warning: water balance violation in CoLMMAIN (lake) ', errorw + CALL CoLM_stop () + ENDIF + ENDIF #endif + IF (DEF_USE_VariablySaturatedFlow) THEN + xerr = errorw / deltim + ELSE + xerr = 0. + ENDIF + ! Set zero to the empty node IF (snl > maxsnl) THEN wice_soisno(maxsnl+1:snl) = 0. @@ -1140,6 +1294,7 @@ SUBROUTINE CoLMMAIN ( & fgrnd = 0.0 rsur = 0.0 rnof = 0.0 + xerr = 0.0 !====================================================================== @@ -1214,25 +1369,20 @@ SUBROUTINE CoLMMAIN ( & sai = tsai(ipatch) * sigf #endif -#ifdef LULC_IGBP_PFT +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) ps = patch_pft_s(ipatch) pe = patch_pft_e(ipatch) CALL snowfraction_pftwrap (ipatch,zlnd,scv,snowdp,wt,sigf,fsno) - lai_p(ps:pe) = tlai_p(ps:pe) + if(DEF_USE_LAIFEEDBACK)then + lai = sum(lai_p(ps:pe)*pftfrac(ps:pe)) + else + lai_p(ps:pe) = tlai_p(ps:pe) + lai = tlai(ipatch) + endif sai_p(ps:pe) = tsai_p(ps:pe) * sigf_p(ps:pe) - lai = tlai(ipatch) sai = sum(sai_p(ps:pe)*pftfrac(ps:pe)) #endif -#ifdef LULC_IGBP_PC - pc = patch2pc(ipatch) - CALL snowfraction_pcwrap (ipatch,zlnd,scv,snowdp,wt,sigf,fsno) - lai_c(:,pc) = tlai_c(:,pc) - sai_c(:,pc) = tsai_c(:,pc) * sigf_c(:,pc) - lai = tlai(ipatch) - sai = sum(sai_c(:,pc)*pcfrac(:,pc)) -#endif - ELSE CALL snowfraction (tlai(ipatch),tsai(ipatch),z0m,zlnd,scv,snowdp,wt,sigf,fsno) lai = tlai(ipatch) @@ -1299,7 +1449,7 @@ SUBROUTINE CoLMMAIN ( & snl,wliq_soisno,wice_soisno,snw_rds,snofrz,& mss_bcpho,mss_bcphi,mss_ocpho,mss_ocphi,& mss_dst1,mss_dst2,mss_dst3,mss_dst4,& - alb,ssun,ssha,ssno,thermk,extkb,extkd) + alb,ssun,ssha,ssoi,ssno,ssno_lyr,thermk,extkb,extkd) ENDIF ELSE !OCEAN sag = 0.0 @@ -1335,7 +1485,6 @@ SUBROUTINE CoLMMAIN ( & respc = 0.0 zerr = 0. - xerr = 0. qinfl = 0. qdrip = forc_rain + forc_snow @@ -1350,11 +1499,10 @@ SUBROUTINE CoLMMAIN ( & assimsha_out = 0. etrsha_out = 0. rootr = 0. + rootflux = 0. zwt = 0. - IF (DEF_USE_VARIABLY_SATURATED_FLOW) THEN - wa = 0. - ELSE + IF (.not. DEF_USE_VariablySaturatedFlow) THEN wa = 4800. ENDIF @@ -1366,8 +1514,8 @@ SUBROUTINE CoLMMAIN ( & h2osoi = wliq_soisno(1:)/(dz_soisno(1:)*denh2o) + wice_soisno(1:)/(dz_soisno(1:)*denice) - IF (DEF_USE_VARIABLY_SATURATED_FLOW) THEN - wat = sum(wice_soisno(1:)+wliq_soisno(1:))+ldew+scv + IF (DEF_USE_VariablySaturatedFlow) THEN + wat = sum(wice_soisno(1:)+wliq_soisno(1:))+ldew+scv+wetwat ELSE wat = sum(wice_soisno(1:)+wliq_soisno(1:))+ldew+scv + wa ENDIF @@ -1376,6 +1524,5 @@ SUBROUTINE CoLMMAIN ( & z_sno (maxsnl+1:0) = z_soisno (maxsnl+1:0) dz_sno(maxsnl+1:0) = dz_soisno(maxsnl+1:0) -!---------------------------------------------------------------------- - END SUBROUTINE CoLMMAIN +! ---------- EOP ------------ diff --git a/main/DA/MOD_DA_GRACE.F90 b/main/DA/MOD_DA_GRACE.F90 new file mode 100644 index 00000000..dc1607b7 --- /dev/null +++ b/main/DA/MOD_DA_GRACE.F90 @@ -0,0 +1,437 @@ +#include + +#ifdef DataAssimilation +MODULE MOD_DA_GRACE + + USE MOD_DataType + USE MOD_Mapping_Grid2Pset + IMPLICIT NONE + + PUBLIC :: init_DA_GRACE + PUBLIC :: do_DA_GRACE + PUBLIC :: final_DA_GRACE + + REAL(r8), allocatable, PUBLIC :: fslp_k_mon (:,:) ! slope factor of runoff + REAL(r8), allocatable, PUBLIC :: fslp_k (:) ! slope factor of runoff + + PRIVATE + + CHARACTER(len=256) :: file_grace + TYPE(grid_type) :: grid_grace + + REAL(r8), allocatable :: longrace(:) + REAL(r8), allocatable :: latgrace(:) + + INTEGER :: nobstime + INTEGER, allocatable :: obsyear (:) + INTEGER, allocatable :: obsmonth (:) + + type (mapping_grid2pset_type) :: mg2p_grace + + REAL(r8), allocatable :: lwe_obs_this (:) + REAL(r8), allocatable :: err_obs_this (:) + + REAL(r8), allocatable :: lwe_obs_prev (:) + REAL(r8), allocatable :: err_obs_prev (:) + + REAL(r8), allocatable :: wat_prev_m (:) + REAL(r8), allocatable :: wat_this_m (:) + + REAL(r8), allocatable :: rnof_acc_prev_m (:) + REAL(r8), allocatable :: rnof_acc_this_m (:) + REAL(r8), allocatable :: zwt_acc_prev_m (:) + REAL(r8), allocatable :: zwt_acc_this_m (:) + + REAL(r8), allocatable :: rnof_prev_m0 (:) + REAL(r8), allocatable :: rnof_prev_m1 (:) + REAL(r8), allocatable :: rnof_this_m (:) + + logical, allocatable :: rnofmask (:) + + LOGICAL :: has_prev_grace_obs + INTEGER :: nac_grace_this, nac_grace_prev + + integer :: year_prev, month_prev + +CONTAINS + + ! ---------- + SUBROUTINE init_DA_GRACE () + + USE MOD_Spmd_Task + USE MOD_Namelist, only : DEF_DA_obsdir + USE MOD_Grid + USE MOD_NetCDFSerial + USE MOD_Mesh, only : numelm + USE MOD_LandElm, only : landelm + USE MOD_LandPatch +#ifdef CROP + USE MOD_LandCrop +#endif + USE MOD_Pixelset + USE MOD_Mapping_Grid2pset + USE MOD_Vars_TimeInvariants, only : patchtype + USE MOD_Forcing, only : forcmask + USE MOD_RangeCheck + IMPLICIT NONE + + ! Local Variables + + REAL(r8), allocatable :: time_real8(:) + INTEGER :: itime + + file_grace = trim(DEF_DA_obsdir) & + // '/GRACE_JPL/GRCTellus.JPL.200204_202207.GLO.RL06M.MSCNv02CRI.nc' + + CALL ncio_read_bcast_serial (file_grace, 'time', time_real8) + + nobstime = size(time_real8) + allocate (obsyear (nobstime)) + allocate (obsmonth(nobstime)) + + DO itime = 1, nobstime + CALL retrieve_yymm_from_days (time_real8(itime), obsyear(itime), obsmonth(itime)) + ENDDO + + IF (p_is_master) THEN + write(*,*) 'Assimilate GRACE data at' + DO itime = 1, nobstime + write(*,*) obsyear(itime), obsmonth(itime) + ENDDO + ENDIF + + CALL ncio_read_bcast_serial (file_grace, 'lon', longrace) + CALL ncio_read_bcast_serial (file_grace, 'lat', latgrace) + + CALL grid_grace%define_by_center (latgrace,longrace) + + call mg2p_grace%build (grid_grace, landelm) + + IF (p_is_worker) THEN + IF (numelm > 0) THEN + allocate (lwe_obs_this (numelm)) + allocate (err_obs_this (numelm)) + allocate (lwe_obs_prev (numelm)) + allocate (err_obs_prev (numelm)) + ENDIF + + IF (numpatch > 0) THEN + allocate (wat_prev_m (numpatch)) + allocate (wat_this_m (numpatch)) + allocate (rnof_acc_prev_m (numpatch)) + allocate (rnof_acc_this_m (numpatch)) + allocate (zwt_acc_prev_m (numpatch)) + allocate (zwt_acc_this_m (numpatch)) + allocate (rnof_prev_m0 (numpatch)) + allocate (rnof_prev_m1 (numpatch)) + allocate (rnof_this_m (numpatch)) + allocate (rnofmask (numpatch)) + + allocate (fslp_k_mon (12,numpatch)) + allocate (fslp_k (numpatch)) + ENDIF + ENDIF + + IF (p_is_worker) THEN +#ifdef CROP + CALL elm_patch%build (landelm, landpatch, use_frac = .true., sharedfrac = pctshrpch) +#else + CALL elm_patch%build (landelm, landpatch, use_frac = .true.) +#endif + ENDIF + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + rnofmask = patchtype == 0 + IF (DEF_forcing%has_missing_value) THEN + rnofmask = rnofmask .and. forcmask + ENDIF + ENDIF + ENDIF + + + has_prev_grace_obs = .false. + + nac_grace_this = 0 + nac_grace_prev = 0 + + IF (p_is_worker) THEN + wat_this_m (:) = 0. + rnof_acc_this_m(:) = 0. + rnof_this_m (:) = 0. + zwt_acc_this_m (:) = 0. + fslp_k_mon (:,:) = 1.0 + fslp_k (:) = 1.0 + ENDIF + + deallocate (time_real8) + + END SUBROUTINE init_DA_GRACE + + ! ---------- + SUBROUTINE do_DA_GRACE (idate, deltim) + + USE MOD_Spmd_task + USE MOD_TimeManager + USE MOD_NetCDFBlock + USE MOD_Mesh + USE MOD_LandElm + USE MOD_LandPatch + USE MOD_Vars_1DFluxes, only : rnof, rsur + USE MOD_Vars_TimeVariables, only : wat, wa, wdsrf, zwt + USE MOD_RangeCheck + IMPLICIT NONE + + INTEGER, INTENT(in) :: idate(3) + REAL(r8), INTENT(in) :: deltim + + ! Local Variables + LOGICAL :: is_obs_time + INTEGER :: month, mday, itime, ielm, istt, iend, nextmonth + + real(r8) :: sumpct + REAL(r8) :: w1, w0, r1, r0, var_o, var_m, dw_f, dw_o, dw_a, rr, zwt_ave + REAL(r8) :: fscal, fprev, fthis + + TYPE(block_data_real8_2d) :: f_grace_lwe ! unit: cm + TYPE(block_data_real8_2d) :: f_grace_err ! unit: cm + + character(len=256) :: sid, logfile + + CALL julian2monthday (idate(1), idate(2), month, mday) + + is_obs_time = any((obsyear == idate(1)) .and. (obsmonth == month)) + + IF (p_is_master) THEN + IF (is_obs_time) THEN + write(*,*) 'GRACE at this time.' + ENDIF + ENDIF + + IF (p_is_worker) THEN + + IF (has_prev_grace_obs) THEN + + nac_grace_prev = nac_grace_prev + 1 + + rnof_acc_prev_m = rnof_acc_prev_m + rnof * deltim + IF (is_obs_time) THEN + rnof_prev_m1 = rnof_prev_m1 + rnof_acc_prev_m + ENDIF + + zwt_acc_prev_m = zwt_acc_prev_m + zwt + ENDIF + + IF (is_obs_time) THEN + + nac_grace_this = nac_grace_this + 1 + + wat_this_m = wat_this_m + wat + wa + wdsrf + + rnof_acc_this_m = rnof_acc_this_m + rnof * deltim + rnof_this_m = rnof_this_m + rnof_acc_this_m + + zwt_acc_this_m = zwt_acc_this_m + zwt + ENDIF + + ENDIF + + IF (is_obs_time .and. (isendofmonth(idate, deltim))) then + + itime = findloc((obsyear == idate(1)) .and. (obsmonth == month), .true., dim=1) + + IF (p_is_io) THEN + CALL allocate_block_data (grid_grace, f_grace_lwe) + CALL allocate_block_data (grid_grace, f_grace_err) + CALL ncio_read_block_time (file_grace, 'lwe_thickness', grid_grace, itime, f_grace_lwe) + CALL ncio_read_block_time (file_grace, 'uncertainty' , grid_grace, itime, f_grace_err) + ENDIF + + CALL mg2p_grace%map_aweighted (f_grace_lwe, lwe_obs_this) + CALL mg2p_grace%map_aweighted (f_grace_err, err_obs_this) + + IF (p_is_worker) THEN + + lwe_obs_this = lwe_obs_this * 10.0 ! from cm to mm + err_obs_this = err_obs_this * 10.0 ! from cm to mm + + wat_this_m = wat_this_m / nac_grace_this + + zwt_acc_prev_m = zwt_acc_prev_m / nac_grace_prev + + IF (has_prev_grace_obs) then + rnof_prev_m1 = rnof_prev_m1 / nac_grace_this + endif + + IF (has_prev_grace_obs .and. & + (((idate(1) == year_prev) .and. (month_prev == month-1)) & + .or. ((idate(1) == year_prev+1) .and. (month_prev == 12) .and. (month == 1)))) & + THEN + + ! write(sid,'(I0)') p_iam_worker + ! logfile = 'log/grace_log_' // trim(sid) // '.txt' + ! open(12, file = trim(logfile), position = 'append') + + DO ielm = 1, numelm + istt = elm_patch%substt(ielm) + iend = elm_patch%subend(ielm) + + sumpct = sum(elm_patch%subfrc(istt:iend), mask = rnofmask(istt:iend)) + + IF (sumpct <= 0) THEN + CYCLE + ENDIF + + w1 = sum(wat_this_m (istt:iend) * elm_patch%subfrc(istt:iend), & + mask = rnofmask(istt:iend)) / sumpct + w0 = sum(wat_prev_m (istt:iend) * elm_patch%subfrc(istt:iend), & + mask = rnofmask(istt:iend)) / sumpct + r1 = sum(rnof_prev_m1(istt:iend) * elm_patch%subfrc(istt:iend), & + mask = rnofmask(istt:iend)) / sumpct + r0 = sum(rnof_prev_m0(istt:iend) * elm_patch%subfrc(istt:iend), & + mask = rnofmask(istt:iend)) / sumpct + + zwt_ave = sum(zwt_acc_prev_m(istt:iend) * elm_patch%subfrc(istt:iend), & + mask = rnofmask(istt:iend)) / sumpct + + + var_o = err_obs_this(ielm)**2 + err_obs_prev(ielm)**2 + + dw_f = w1 - w0 + dw_o = lwe_obs_this(ielm) - lwe_obs_prev(ielm) + var_m = (dw_f-dw_o)**2 - var_o + + IF (var_m > 0) THEN + + dw_a = (var_o * dw_f + var_m * dw_o) / (var_m+var_o) + + rr = r1 - r0 + + IF (rr > 0) THEN + + fscal = (1-(dw_a-dw_f)/rr) + + ! (2) method 2: one parameters adjusted + fprev = fslp_k_mon(month,istt) + fthis = fprev * fscal + fthis = min(max(fthis, fprev*0.5), fprev*2.0) + fslp_k_mon(month,istt:iend) = fthis + + fprev = fslp_k_mon(month_prev,istt) + fthis = fprev * fscal + fthis = min(max(fthis, fprev*0.5), fprev*2.0) + fslp_k_mon(month_prev,istt:iend) = fthis + + ! write(12,'(I4,I3,I8,8ES11.2)') idate(1), month, landelm%eindex(ielm), & + ! dw_o, sqrt(var_o), dw_f, sqrt(var_m), dw_a, & + ! rr, zwt_ave, fscal + + ENDIF + + ENDIF + + ENDDO + + ! close(12) + ENDIF + + lwe_obs_prev = lwe_obs_this + err_obs_prev = err_obs_this + + wat_prev_m = wat_this_m + wat_this_m = 0. + + rnof_acc_prev_m = rnof_acc_this_m + rnof_acc_this_m = 0. + + zwt_acc_prev_m = zwt_acc_this_m + zwt_acc_this_m = 0. + + rnof_prev_m0 = rnof_this_m / nac_grace_this + rnof_prev_m1 = 0. + rnof_this_m = 0. + + nac_grace_prev = nac_grace_this + nac_grace_this = 0 + + ENDIF + + has_prev_grace_obs = .true. + year_prev = idate(1) + month_prev = month + + ENDIF + + IF (isendofmonth(idate, deltim)) then + IF (p_is_worker .and. (numpatch > 0)) THEN + nextmonth = mod(month+1,12)+1 + fslp_k = fslp_k_mon(nextmonth,:) + ENDIF + ENDIF + + + END SUBROUTINE do_DA_GRACE + + ! --------- + SUBROUTINE final_DA_GRACE () + + IMPLICIT NONE + + IF (allocated(lwe_obs_this)) deallocate(lwe_obs_this) + IF (allocated(err_obs_this)) deallocate(err_obs_this) + IF (allocated(lwe_obs_prev)) deallocate(lwe_obs_prev) + IF (allocated(err_obs_prev)) deallocate(err_obs_prev) + IF (allocated(wat_prev_m )) deallocate(wat_prev_m ) + IF (allocated(wat_this_m )) deallocate(wat_this_m ) + IF (allocated(rnof_acc_prev_m)) deallocate(rnof_acc_prev_m) + IF (allocated(rnof_acc_this_m)) deallocate(rnof_acc_this_m) + IF (allocated(rnof_prev_m0 )) deallocate(rnof_prev_m0 ) + IF (allocated(rnof_prev_m1 )) deallocate(rnof_prev_m1 ) + IF (allocated(rnof_this_m )) deallocate(rnof_this_m ) + IF (allocated(rnofmask )) deallocate(rnofmask ) + + IF (allocated(fslp_k_mon)) deallocate(fslp_k_mon) + IF (allocated(fslp_k)) deallocate(fslp_k) + + IF (allocated(longrace)) deallocate(longrace) + IF (allocated(latgrace)) deallocate(latgrace) + + END SUBROUTINE final_DA_GRACE + + ! --------- + SUBROUTINE retrieve_yymm_from_days (days, yy, mm) + + IMPLICIT NONE + REAL(r8), intent(in) :: days + INTEGER, intent(out) :: yy, mm + + ! Local Variables + REAL(r8) :: resday + INTEGER :: mdays(12) + + yy = 2002 + mm = 1 + mdays = (/31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/) + + resday = days + DO WHILE (resday > mdays(mm)) + + resday = resday - mdays(mm) + + mm = mm + 1 + IF (mm > 12) THEN + yy = yy + 1 + mm = 1 + IF( (mod(yy,4)==0 .AND. mod(yy,100)/=0) .OR. mod(yy,400)==0 ) THEN + mdays(2) = 29 + ELSE + mdays(2) = 28 + ENDIF + ENDIF + + ENDDO + + END SUBROUTINE retrieve_yymm_from_days + +END MODULE MOD_DA_GRACE +#endif diff --git a/main/DA/MOD_DataAssimilation.F90 b/main/DA/MOD_DataAssimilation.F90 new file mode 100644 index 00000000..2d358784 --- /dev/null +++ b/main/DA/MOD_DataAssimilation.F90 @@ -0,0 +1,43 @@ +#include + +#ifdef DataAssimilation +MODULE MOD_DataAssimilation + + USE MOD_Precision + USE MOD_DA_GRACE + IMPLICIT NONE + +CONTAINS + + ! ---------- + SUBROUTINE init_DataAssimilation () + + IMPLICIT NONE + + CALL init_DA_GRACE () + + END SUBROUTINE init_DataAssimilation + + ! ---------- + SUBROUTINE do_DataAssimilation (idate, deltim) + + IMPLICIT NONE + + INTEGER, INTENT(in) :: idate(3) + REAL(r8), INTENT(in) :: deltim + + CALL do_DA_GRACE (idate, deltim) + + END SUBROUTINE do_DataAssimilation + + ! --------- + SUBROUTINE final_DataAssimilation () + + IMPLICIT NONE + + CALL final_DA_GRACE () + + END SUBROUTINE final_DataAssimilation + +END MODULE MOD_DataAssimilation +#endif diff --git a/main/HYDRO/MOD_Hydro_HillslopeFlow.F90 b/main/HYDRO/MOD_Catch_HillslopeFlow.F90 similarity index 75% rename from main/HYDRO/MOD_Hydro_HillslopeFlow.F90 rename to main/HYDRO/MOD_Catch_HillslopeFlow.F90 index ad9b2068..a40faa10 100644 --- a/main/HYDRO/MOD_Hydro_HillslopeFlow.F90 +++ b/main/HYDRO/MOD_Catch_HillslopeFlow.F90 @@ -1,7 +1,7 @@ #include -#ifdef LATERAL_FLOW -MODULE MOD_Hydro_HillslopeFlow +#ifdef CatchLateralFlow +MODULE MOD_Catch_HillslopeFlow !------------------------------------------------------------------------------------- ! DESCRIPTION: ! @@ -41,8 +41,8 @@ SUBROUTINE hillslope_flow (dt) USE MOD_Vars_1DFluxes USE MOD_Hydro_Vars_TimeVariables USE MOD_Hydro_Vars_1DFluxes - USE MOD_Hydro_HillslopeNetwork - USE MOD_Hydro_RiverLakeNetwork + USE MOD_Catch_HillslopeNetwork + USE MOD_Catch_RiverLakeNetwork USE MOD_Const_Physical, only : grav IMPLICIT NONE @@ -50,7 +50,7 @@ SUBROUTINE hillslope_flow (dt) REAL(r8), intent(in) :: dt ! Local Variables - INTEGER :: numbasin, nhru, istt, iend, ibasin, i, j + INTEGER :: numbasin, nhru, hs, he, ibasin, i, j, ps, pe TYPE(hillslope_network_info_type), pointer :: hillslope @@ -66,26 +66,29 @@ SUBROUTINE hillslope_flow (dt) REAL(r8) :: wdsrf_up, wdsrf_dn, vwave_up, vwave_dn REAL(r8) :: hflux_up, hflux_dn, mflux_up, mflux_dn - REAL(r8), allocatable :: rsurf_h (:) ! [m/s] + REAL(r8), allocatable :: xsurf_h (:) ! [m/s] REAL(r8) :: friction REAL(r8) :: dt_res, dt_this + logical, allocatable :: mask(:) + real(r8) :: srfbsn, dvol, nextl, nexta, nextv, ddep + IF (p_is_worker) THEN numbasin = numelm DO ibasin = 1, numbasin - istt = basin_hru%substt(ibasin) - iend = basin_hru%subend(ibasin) + hs = basin_hru%substt(ibasin) + he = basin_hru%subend(ibasin) IF (lake_id(ibasin) > 0) THEN - veloc_hru(istt:iend) = 0 - momen_hru(istt:iend) = 0 + veloc_hru(hs:he) = 0 + momen_hru(hs:he) = 0 CYCLE ! skip lakes ELSE - DO i = istt, iend + DO i = hs, he ! momentum is less or equal than the momentum at last time step. momen_hru(i) = min(wdsrf_hru_prev(i), wdsrf_hru(i)) * veloc_hru(i) ENDDO @@ -103,7 +106,7 @@ SUBROUTINE hillslope_flow (dt) allocate (sum_mflux_h (nhru)) allocate (sum_zgrad_h (nhru)) - allocate (rsurf_h (nhru)) + allocate (xsurf_h (nhru)) DO i = 1, nhru wdsrf_h(i) = wdsrf_hru(hillslope%ihru(i)) @@ -138,7 +141,7 @@ SUBROUTINE hillslope_flow (dt) ENDIF ! reconstruction of height of water near interface - hand_fc = min(hillslope%hand(i), hillslope%hand(j)) + hand_fc = max(hillslope%hand(i), hillslope%hand(j)) wdsrf_up = max(0., hillslope%hand(i)+wdsrf_h(i) - hand_fc) wdsrf_dn = max(0., hillslope%hand(j)+wdsrf_h(j) - hand_fc) @@ -179,7 +182,7 @@ SUBROUTINE hillslope_flow (dt) mflux_fc = hillslope%flen(i) * (vwave_dn*mflux_up - vwave_up*mflux_dn & + vwave_up*vwave_dn*(hflux_dn-hflux_up)) / (vwave_dn-vwave_up) ENDIF - + sum_hflux_h(i) = sum_hflux_h(i) + hflux_fc sum_hflux_h(j) = sum_hflux_h(j) - hflux_fc @@ -200,9 +203,9 @@ SUBROUTINE hillslope_flow (dt) ENDIF ! constraint 2: Avoid negative values of water - rsurf_h(i) = sum_hflux_h(i) / hillslope%area(i) - IF (rsurf_h(i) > 0) THEN - dt_this = min(dt_this, wdsrf_h(i) / rsurf_h(i)) + xsurf_h(i) = sum_hflux_h(i) / hillslope%area(i) + IF (xsurf_h(i) > 0) THEN + dt_this = min(dt_this, wdsrf_h(i) / xsurf_h(i)) ENDIF ! constraint 3: Avoid change of flow direction @@ -215,37 +218,84 @@ SUBROUTINE hillslope_flow (dt) DO i = 1, nhru - wdsrf_h(i) = max(0., wdsrf_h(i) - rsurf_h(i) * dt_this) + wdsrf_h(i) = max(0., wdsrf_h(i) - xsurf_h(i) * dt_this) IF (wdsrf_h(i) < PONDMIN) THEN momen_h(i) = 0 - veloc_h(i) = 0 ELSE friction = grav * nmanning_hslp**2 * abs(momen_h(i)) / wdsrf_h(i)**(7.0/3.0) momen_h(i) = (momen_h(i) - & (sum_mflux_h(i) - sum_zgrad_h(i)) / hillslope%area(i) * dt_this) & / (1 + friction * dt_this) - veloc_h(i) = momen_h(i) / wdsrf_h(i) IF (hillslope%inext(i) <= 0) THEN - veloc_h(i) = min(veloc_h(i), 0.) momen_h(i) = min(momen_h(i), 0.) ENDIF IF (all(hillslope%inext /= i)) THEN - veloc_h(i) = max(veloc_h(i), 0.) momen_h(i) = max(momen_h(i), 0.) ENDIF ENDIF + ENDDO + + IF (hillslope%indx(1) == 0) THEN + srfbsn = minval(hillslope%hand + wdsrf_h) + IF (srfbsn < wdsrf_h(1)) THEN + allocate (mask (hillslope%nhru)) + dvol = (wdsrf_h(1) - srfbsn) * hillslope%area(1) + momen_h(1) = srfbsn/wdsrf_h(1) * momen_h(1) + wdsrf_h(1) = srfbsn + DO WHILE (dvol > 0) + mask = hillslope%hand + wdsrf_h > srfbsn + nexta = sum(hillslope%area, mask = (.not. mask)) + IF (any(mask)) THEN + nextl = minval(hillslope%hand + wdsrf_h, mask = mask) + nextv = nexta*(nextl-srfbsn) + IF (dvol > nextv) THEN + ddep = nextl - srfbsn + dvol = dvol - nextv + ELSE + ddep = dvol/nexta + dvol = 0. + ENDIF + ELSE + ddep = dvol/nexta + dvol = 0. + ENDIF + + srfbsn = srfbsn + ddep + + WHERE (.not. mask) + wdsrf_h = wdsrf_h + ddep + END WHERE + ENDDO + deallocate(mask) + ENDIF + ENDIF + + DO i = 1, nhru + IF (wdsrf_h(i) < PONDMIN) THEN + veloc_h(i) = 0 + ELSE + veloc_h(i) = momen_h(i) / wdsrf_h(i) + ENDIF + wdsrf_hru_ta(hillslope%ihru(i)) = wdsrf_hru_ta(hillslope%ihru(i)) + wdsrf_h(i) * dt_this momen_hru_ta(hillslope%ihru(i)) = momen_hru_ta(hillslope%ihru(i)) + momen_h(i) * dt_this ENDDO + IF (hillslope%indx(1) == 0) THEN + ps = elm_patch%substt(ibasin) + pe = elm_patch%subend(ibasin) + ! m/s to mm/s + rsur(ps:pe) = rsur(ps:pe) - sum_hflux_h(1) * dt_this / sum(hillslope%area) * 1.0e3 + ENDIF + dt_res = dt_res - dt_this - - ENDDO + ENDDO + ! SAVE depth of surface water DO i = 1, nhru wdsrf_hru(hillslope%ihru(i)) = wdsrf_h(i) @@ -260,7 +310,7 @@ SUBROUTINE hillslope_flow (dt) deallocate (sum_mflux_h) deallocate (sum_zgrad_h) - deallocate (rsurf_h) + deallocate (xsurf_h) ENDDO @@ -270,5 +320,5 @@ SUBROUTINE hillslope_flow (dt) END SUBROUTINE hillslope_flow -END MODULE MOD_Hydro_HillslopeFlow +END MODULE MOD_Catch_HillslopeFlow #endif diff --git a/main/HYDRO/MOD_Hydro_HillslopeNetwork.F90 b/main/HYDRO/MOD_Catch_HillslopeNetwork.F90 similarity index 90% rename from main/HYDRO/MOD_Hydro_HillslopeNetwork.F90 rename to main/HYDRO/MOD_Catch_HillslopeNetwork.F90 index ec2e4ed1..cd15021c 100644 --- a/main/HYDRO/MOD_Hydro_HillslopeNetwork.F90 +++ b/main/HYDRO/MOD_Catch_HillslopeNetwork.F90 @@ -1,7 +1,7 @@ #include -#ifdef LATERAL_FLOW -MODULE MOD_Hydro_HillslopeNetwork +#ifdef CatchLateralFlow +MODULE MOD_Catch_HillslopeNetwork !-------------------------------------------------------------------------------- ! DESCRIPTION: ! @@ -19,7 +19,7 @@ MODULE MOD_Hydro_HillslopeNetwork INTEGER , pointer :: ihru (:) ! location of HRU in global vector "landhru" INTEGER , pointer :: indx (:) ! index of HRU REAL(r8), pointer :: area (:) ! area of HRU [m^2] - REAL(r8), pointer :: awat (:) ! water area only including (patchtype <= 2) [m^2] + REAL(r8), pointer :: agwt (:) ! water area only including (patchtype <= 2) [m^2] REAL(r8), pointer :: hand (:) ! height above nearest drainage [m] REAL(r8), pointer :: elva (:) ! elevation [m] REAL(r8), pointer :: plen (:) ! average drainage path length to downstream HRU [m] @@ -49,7 +49,7 @@ SUBROUTINE hillslope_network_init () ! Local Variables CHARACTER(len=256) :: hillslope_network_file - INTEGER :: numbasin, maxnumhru, ibasin, nhru, istt, iend, ihru, ipatch, ps, pe, i, j, ipxl + INTEGER :: numbasin, maxnumhru, ibasin, nhru, hs, he, ihru, ipatch, ps, pe, i, j, ipxl INTEGER :: iworker, mesg(2), nrecv, irecv, isrc, idest INTEGER , allocatable :: indxhru (:,:) @@ -70,6 +70,8 @@ SUBROUTINE hillslope_network_init () numbasin = numelm + hillslope_network => null() + hillslope_network_file = DEF_CatchmentMesh_data IF (p_is_master) THEN @@ -267,7 +269,7 @@ SUBROUTINE hillslope_network_init () allocate (hillslope_network(ibasin)%ihru (nhru)) allocate (hillslope_network(ibasin)%indx (nhru)) allocate (hillslope_network(ibasin)%area (nhru)) - allocate (hillslope_network(ibasin)%awat (nhru)) + allocate (hillslope_network(ibasin)%agwt (nhru)) allocate (hillslope_network(ibasin)%hand (nhru)) allocate (hillslope_network(ibasin)%elva (nhru)) allocate (hillslope_network(ibasin)%plen (nhru)) @@ -281,9 +283,9 @@ SUBROUTINE hillslope_network_init () hillslope_network(ibasin)%plen = plenhru(1:nhru,ibasin) * 1.0e3 ! km to m hillslope_network(ibasin)%flen = lfachru(1:nhru,ibasin) * 1.0e3 ! km to m - istt = basin_hru%substt(ibasin) - iend = basin_hru%subend(ibasin) - hillslope_network(ibasin)%ihru = (/ (i, i = istt, iend) /) + hs = basin_hru%substt(ibasin) + he = basin_hru%subend(ibasin) + hillslope_network(ibasin)%ihru = (/ (i, i = hs, he) /) DO i = 1, nhru IF (nexthru(i,ibasin) >= 0) THEN @@ -295,13 +297,13 @@ SUBROUTINE hillslope_network_init () ENDDO DO i = 1, nhru - hillslope_network(ibasin)%awat(i) = 0 - ps = hru_patch%substt(i+istt-1) - pe = hru_patch%subend(i+iend-1) + hillslope_network(ibasin)%agwt(i) = 0 + ps = hru_patch%substt(i+hs-1) + pe = hru_patch%subend(i+hs-1) DO ipatch = ps, pe IF (patchtype(ipatch) <= 2) THEN DO ipxl = landpatch%ipxstt(ipatch), landpatch%ipxend(ipatch) - hillslope_network(ibasin)%awat(i) = hillslope_network(ibasin)%awat(i) & + hillslope_network(ibasin)%agwt(i) = hillslope_network(ibasin)%agwt(i) & + 1.0e6 * areaquad ( & pixel%lat_s(mesh(ibasin)%ilat(ipxl)), pixel%lat_n(mesh(ibasin)%ilat(ipxl)), & pixel%lon_w(mesh(ibasin)%ilon(ipxl)), pixel%lon_e(mesh(ibasin)%ilon(ipxl)) ) @@ -310,6 +312,16 @@ SUBROUTINE hillslope_network_init () ENDDO ENDDO + ELSE + hillslope_network(ibasin)%ihru => null() + hillslope_network(ibasin)%indx => null() + hillslope_network(ibasin)%area => null() + hillslope_network(ibasin)%agwt => null() + hillslope_network(ibasin)%hand => null() + hillslope_network(ibasin)%elva => null() + hillslope_network(ibasin)%plen => null() + hillslope_network(ibasin)%flen => null() + hillslope_network(ibasin)%inext => null() ENDIF ENDDO @@ -344,7 +356,7 @@ SUBROUTINE hillslope_network_final () IF (associated(hillslope_network(ibasin)%ihru )) deallocate(hillslope_network(ibasin)%ihru ) IF (associated(hillslope_network(ibasin)%indx )) deallocate(hillslope_network(ibasin)%indx ) IF (associated(hillslope_network(ibasin)%area )) deallocate(hillslope_network(ibasin)%area ) - IF (associated(hillslope_network(ibasin)%awat )) deallocate(hillslope_network(ibasin)%awat ) + IF (associated(hillslope_network(ibasin)%agwt )) deallocate(hillslope_network(ibasin)%agwt ) IF (associated(hillslope_network(ibasin)%hand )) deallocate(hillslope_network(ibasin)%hand ) IF (associated(hillslope_network(ibasin)%elva )) deallocate(hillslope_network(ibasin)%elva ) IF (associated(hillslope_network(ibasin)%plen )) deallocate(hillslope_network(ibasin)%plen ) @@ -357,5 +369,5 @@ SUBROUTINE hillslope_network_final () END SUBROUTINE hillslope_network_final -END MODULE MOD_Hydro_HillslopeNetwork +END MODULE MOD_Catch_HillslopeNetwork #endif diff --git a/main/HYDRO/MOD_Catch_LateralFlow.F90 b/main/HYDRO/MOD_Catch_LateralFlow.F90 new file mode 100644 index 00000000..6c12bd66 --- /dev/null +++ b/main/HYDRO/MOD_Catch_LateralFlow.F90 @@ -0,0 +1,282 @@ +#include + +#ifdef CatchLateralFlow +MODULE MOD_Catch_LateralFlow + !------------------------------------------------------------------------------------- + ! DESCRIPTION: + ! + ! Lateral flow. + ! + ! Lateral flows in CoLM include + ! 1. Surface flow over hillslopes; + ! 2. Routing flow in rivers; + ! 3. Groundwater (subsurface) lateral flow. + ! + ! Water exchanges between + ! 1. surface flow and rivers; + ! 2. subsurface flow and rivers. + ! + ! Created by Shupeng Zhang, May 2023 + !------------------------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_Hydro_Vars_TimeVariables + USE MOD_ElementNeighbour + USE MOD_Catch_RiverLakeNetwork + USE MOD_Catch_HillslopeNetwork + USE MOD_Catch_HillslopeFlow + USE MOD_Catch_SubsurfaceFlow + USE MOD_Catch_RiverLakeFlow + USE MOD_Vars_TimeVariables + USE MOD_Vars_Global, only : dz_soi + USE MOD_Const_Physical, only : denice, denh2o + IMPLICIT NONE + + INTEGER, parameter :: nsubstep = 20 + real(r8) :: dt_average + +#ifdef CoLMDEBUG + real(r8) :: landarea + real(r8), allocatable :: patcharea (:) ! m^2 +#endif + +CONTAINS + + ! ---------- + SUBROUTINE lateral_flow_init (lc_year) + +#ifdef CoLMDEBUG + USE MOD_SPMD_Task + USE MOD_Mesh + USE MOD_Pixel + USE MOD_LandPatch + USE MOD_Utils +#endif + IMPLICIT NONE + + INTEGER, intent(in) :: lc_year ! which year of land cover data used + +#ifdef CoLMDEBUG + integer :: ip ,ie, ipxl +#endif + + CALL element_neighbour_init (lc_year) + + CALL hillslope_network_init () + CALL river_lake_network_init () + CALL basin_neighbour_init () + +#ifdef CoLMDEBUG + IF (p_is_worker) THEN + allocate (patcharea (numpatch)) + DO ip = 1, numpatch + patcharea(ip) = 0. + ie = landpatch%ielm(ip) + DO ipxl = landpatch%ipxstt(ip), landpatch%ipxend(ip) + patcharea(ip) = patcharea(ip) + 1.0e6 * areaquad ( & + pixel%lat_s(mesh(ie)%ilat(ipxl)), pixel%lat_n(mesh(ie)%ilat(ipxl)), & + pixel%lon_w(mesh(ie)%ilon(ipxl)), pixel%lon_e(mesh(ie)%ilon(ipxl)) ) + ENDDO + ENDDO + + landarea = 0. + IF (numpatch > 0) landarea = sum(patcharea) +#ifdef USEMPI + CALL mpi_allreduce (MPI_IN_PLACE, landarea, 1, MPI_REAL8, MPI_SUM, p_comm_worker, p_err) +#endif + ENDIF +#endif + + END SUBROUTINE lateral_flow_init + + ! ---------- + SUBROUTINE lateral_flow (deltime) + + USE MOD_Mesh, only : numelm + USE MOD_LandHRU, only : landhru, numhru, basin_hru + USE MOD_LandPatch, only : numpatch, elm_patch, hru_patch + + USE MOD_Vars_1DFluxes, only : rsur, rsub, rnof + USE MOD_Vars_TimeVariables, only : wdsrf + USE MOD_Vars_TimeInvariants, only : lakedepth + USE MOD_Hydro_Vars_1DFluxes + USE MOD_Hydro_Vars_TimeVariables + + USE MOD_RangeCheck + IMPLICIT NONE + + REAL(r8), intent(in) :: deltime + + ! Local Variables + INTEGER :: numbasin, ibasin, ihru, i, j, ps, pe, istep + real(r8), allocatable :: wdsrf_p (:) +#ifdef CoLMDEBUG + real(r8) :: dtolw, toldis +#endif + + IF (p_is_worker) THEN + + numbasin = numelm + + ! a) The smallest unit in surface lateral flow (including hillslope flow and river-lake flow) + ! is HRU and the main prognostic variable is "wdsrf_hru" (surface water depth). + ! b) "wdsrf_hru" is updated by aggregating water depths in patches. + ! c) Water surface in a basin ("wdsrf_bsn", defined as the lowest surface water in the basin) + ! is derived from "wdsrf_hru". + DO i = 1, numhru + ps = hru_patch%substt(i) + pe = hru_patch%subend(i) + wdsrf_hru(i) = sum(wdsrf(ps:pe) * hru_patch%subfrc(ps:pe)) + wdsrf_hru(i) = wdsrf_hru(i) / 1.0e3 ! mm to m + ENDDO + + wdsrf_hru_ta(:) = 0 + momen_hru_ta(:) = 0 + wdsrf_bsn_ta(:) = 0 + momen_riv_ta(:) = 0 + + IF (numpatch > 0) THEN + allocate (wdsrf_p (numpatch)) + wdsrf_p = wdsrf + ENDIF + + dt_average = 0. + + IF (numpatch > 0) rsur (:) = 0. + IF (numbasin > 0) discharge(:) = 0. + + DO istep = 1, nsubstep + + ! (1) Surface flow over hillslopes. + CALL hillslope_flow (deltime/nsubstep) + + ! (2) River and Lake flow. + CALL river_lake_flow (deltime/nsubstep) + + dt_average = dt_average + deltime/nsubstep/ntimestep_riverlake + + ENDDO + + IF (numpatch > 0) rsur = rsur / deltime + IF (numbasin > 0) discharge = discharge / deltime + + IF (numbasin > 0) THEN + wdsrf_bsn_ta(:) = wdsrf_bsn_ta(:) / deltime + momen_riv_ta(:) = momen_riv_ta(:) / deltime + + where (wdsrf_bsn_ta > 0) + veloc_riv_ta = momen_riv_ta / wdsrf_bsn_ta + ELSE where + veloc_riv_ta = 0 + END where + ENDIF + + IF (numhru > 0) THEN + wdsrf_hru_ta(:) = wdsrf_hru_ta(:) / deltime + momen_hru_ta(:) = momen_hru_ta(:) / deltime + + where (wdsrf_hru_ta > 0) + veloc_hru_ta = momen_hru_ta / wdsrf_hru_ta + ELSE where + veloc_hru_ta = 0. + END where + ENDIF + + ! update surface water depth on patches + DO i = 1, numhru + ps = hru_patch%substt(i) + pe = hru_patch%subend(i) + wdsrf(ps:pe) = wdsrf_hru(i) * 1.0e3 ! m to mm + ENDDO + + IF (numpatch > 0) THEN + xwsur(:) = (wdsrf_p(:) - wdsrf(:)) / deltime + ENDIF + + IF (allocated(wdsrf_p)) deallocate(wdsrf_p) + + ! (3) Subsurface lateral flow. + CALL subsurface_flow (deltime) + + IF (numpatch > 0) THEN + rnof(:) = rsur(:) + rsub(:) + ENDIF + + DO i = 1, numpatch + h2osoi(:,i) = wliq_soisno(1:,i)/(dz_soi(1:)*denh2o) + wice_soisno(1:,i)/(dz_soi(1:)*denice) + wat(i) = sum(wice_soisno(1:,i)+wliq_soisno(1:,i)) + ldew(i) + scv(i) + wetwat(i) + ENDDO + + ENDIF + +#ifdef RangeCheck + if (p_is_worker .and. (p_iam_worker == 0)) then + write(*,'(/,A)') 'Checking Lateral Flow Variables ...' + write(*,'(A,F12.5,A)') 'River Lake Flow average timestep: ', & + dt_average/nsubstep, ' seconds' + end if + + CALL check_vector_data ('Basin Water Depth [m] ', wdsrf_bsn) + CALL check_vector_data ('River Velocity [m/s]', veloc_riv) + CALL check_vector_data ('HRU Water Depth [m] ', wdsrf_hru) + CALL check_vector_data ('HRU Water Velocity [m/s]', veloc_hru) + CALL check_vector_data ('Subsurface bt basin [m/s]', xsubs_bsn) + CALL check_vector_data ('Subsurface bt HRU [m/s]', xsubs_hru) + CALL check_vector_data ('Subsurface bt patch [m/s]', xsubs_pch) + +#ifdef CoLMDEBUG + IF (p_is_worker) THEN + + dtolw = 0 + toldis = 0 + + IF (numpatch > 0) THEN + dtolw = sum(patcharea * xwsur) / 1.e3 * deltime + ENDIF + IF (numelm > 0) THEN + toldis = sum(discharge*deltime, mask = (riverdown == 0) .or. (riverdown == -3)) + dtolw = dtolw - toldis + ENDIF + +#ifdef USEMPI + CALL mpi_allreduce (MPI_IN_PLACE, dtolw, 1, MPI_REAL8, MPI_SUM, p_comm_worker, p_err) + CALL mpi_allreduce (MPI_IN_PLACE, toldis, 1, MPI_REAL8, MPI_SUM, p_comm_worker, p_err) +#endif + if (p_iam_worker == 0) then + write(*,'(A,F10.5,A,ES10.3,A,ES10.3,A)') 'Total surface water error: ', dtolw, & + '(m^3) in area ', landarea, '(m^2), discharge ', toldis, '(m^3)' + endif + + dtolw = 0 + IF (numpatch > 0) dtolw = sum(patcharea * xwsub) / 1.e3 * deltime +#ifdef USEMPI + CALL mpi_allreduce (MPI_IN_PLACE, dtolw, 1, MPI_REAL8, MPI_SUM, p_comm_worker, p_err) +#endif + if (p_iam_worker == 0) then + write(*,'(A,F10.5,A,ES10.3,A)') 'Total ground water error: ', dtolw, & + '(m^3) in area ', landarea, '(m^2)' + endif + ENDIF +#endif +#endif + + END SUBROUTINE lateral_flow + + ! ---------- + SUBROUTINE lateral_flow_final () + + IMPLICIT NONE + + CALL hillslope_network_final () + CALL river_lake_network_final () + CALL basin_neighbour_final () + +#ifdef CoLMDEBUG + IF (allocated(patcharea)) deallocate(patcharea) +#endif + + END SUBROUTINE lateral_flow_final + +END MODULE MOD_Catch_LateralFlow +#endif diff --git a/main/HYDRO/MOD_Hydro_RiverLakeFlow.F90 b/main/HYDRO/MOD_Catch_RiverLakeFlow.F90 similarity index 64% rename from main/HYDRO/MOD_Hydro_RiverLakeFlow.F90 rename to main/HYDRO/MOD_Catch_RiverLakeFlow.F90 index e57827c8..5e990d2e 100644 --- a/main/HYDRO/MOD_Hydro_RiverLakeFlow.F90 +++ b/main/HYDRO/MOD_Catch_RiverLakeFlow.F90 @@ -1,7 +1,7 @@ #include -#ifdef LATERAL_FLOW -MODULE MOD_Hydro_RiverLakeFlow +#ifdef CatchLateralFlow +MODULE MOD_Catch_RiverLakeFlow !------------------------------------------------------------------------------------- ! DESCRIPTION: ! @@ -23,9 +23,13 @@ MODULE MOD_Hydro_RiverLakeFlow USE MOD_Precision IMPLICIT NONE - REAL(r8), parameter :: RIVERMIN = 1.e-4 REAL(r8), parameter :: nmanning_riv = 0.03 + REAL(r8), parameter :: RIVERMIN = 1.e-5_r8 + REAL(r8), parameter :: VOLUMEMIN = 1.e-5_r8 + + integer :: ntimestep_riverlake + CONTAINS ! --------- @@ -37,8 +41,8 @@ SUBROUTINE river_lake_flow (dt) USE MOD_LandPatch USE MOD_Vars_TimeVariables USE MOD_Hydro_Vars_1DFluxes - USE MOD_Hydro_HillslopeNetwork - USE MOD_Hydro_RiverLakeNetwork + USE MOD_Catch_HillslopeNetwork + USE MOD_Catch_RiverLakeNetwork USE MOD_Const_Physical, only : grav IMPLICIT NONE @@ -46,11 +50,11 @@ SUBROUTINE river_lake_flow (dt) ! Local Variables INTEGER :: nbasin - INTEGER :: istt, iend, i, j + INTEGER :: hs, he, i, j REAL(r8), allocatable :: wdsrf_bsn_ds(:) - REAL(r8), allocatable :: veloc_riv_ds (:) - REAL(r8), allocatable :: momen_riv_ds (:) + REAL(r8), allocatable :: veloc_riv_ds(:) + REAL(r8), allocatable :: momen_riv_ds(:) REAL(r8), allocatable :: hflux_fc(:) REAL(r8), allocatable :: mflux_fc(:) @@ -67,34 +71,28 @@ SUBROUTINE river_lake_flow (dt) REAL(r8) :: dt_res, dt_this logical, allocatable :: mask(:) - + IF (p_is_worker) THEN nbasin = numelm - + ! update water depth in basin by aggregating water depths in patches DO i = 1, nbasin - istt = basin_hru%substt(i) - iend = basin_hru%subend(i) + hs = basin_hru%substt(i) + he = basin_hru%subend(i) IF (lake_id(i) <= 0) THEN ! river or lake catchment - ! Water surface in a basin is defined as the lowest surface water in the basin - wdsrf_bsn(i) = minval(hillslope_network(i)%hand + wdsrf_hru(istt:iend)) + wdsrf_bsn(i) = minval(hillslope_network(i)%hand + wdsrf_hru(hs:he)) - handmin(i) - totalvolume = sum((wdsrf_bsn(i) - hillslope_network(i)%hand) * hillslope_network(i)%area, & - mask = hillslope_network(i)%hand <= wdsrf_bsn(i)) - - IF (totalvolume < 1.0e-4) THEN - wdsrf_bsn(i) = 0 - ENDIF ELSEIF (lake_id(i) > 0) THEN ! lake - totalvolume = sum(wdsrf_hru(istt:iend) * lakes(i)%area0) + totalvolume = sum(wdsrf_hru(hs:he) * lakes(i)%area0) wdsrf_bsn(i) = lakes(i)%surface(totalvolume) ENDIF + IF (lake_id(i) == 0) THEN ! river momentum is less or equal than the momentum at last time step. IF (wdsrf_bsn_prev(i) < wdsrf_bsn(i)) THEN @@ -124,8 +122,11 @@ SUBROUTINE river_lake_flow (dt) allocate (sum_zgrad_riv (nbasin)) ENDIF + ntimestep_riverlake = 0 dt_res = dt DO WHILE (dt_res > 0) + + ntimestep_riverlake = ntimestep_riverlake + 1 DO i = 1, nbasin sum_hflux_riv(i) = 0. @@ -222,10 +223,60 @@ SUBROUTINE river_lake_flow (dt) zgrad_dn(i) = outletwth(i) * 0.5*grav * height_dn**2 - ELSE ! inland depression + ELSEIF (riverdown(i) == -3) THEN + ! downstream is not in model region. + ! assume: 1. downstream river bed is equal to this river bed. + ! 2. downstream water surface is equal to this river depth. + ! 3. downstream water velocity is equal to this velocity. + + veloc_riv(i) = max(veloc_riv(i), 0.) + + IF (wdsrf_bsn(i) > riverdpth(i)) THEN + + ! reconstruction of height of water near interface + height_up = wdsrf_bsn(i) + height_dn = riverdpth(i) + + veloct_fc = veloc_riv(i) + sqrt(grav * height_up) - sqrt(grav * height_dn) + height_fc = 1/grav * (0.5*(sqrt(grav*height_up) + sqrt(grav*height_dn))) ** 2 + + vwave_up = min(veloc_riv(i)-sqrt(grav*height_up), veloct_fc-sqrt(grav*height_fc)) + vwave_dn = max(veloc_riv(i)+sqrt(grav*height_dn), veloct_fc+sqrt(grav*height_fc)) + + hflux_up = veloc_riv(i) * height_up + hflux_dn = veloc_riv(i) * height_dn + mflux_up = veloc_riv(i)**2 * height_up + 0.5*grav * height_up**2 + mflux_dn = veloc_riv(i)**2 * height_dn + 0.5*grav * height_dn**2 + + IF (vwave_up >= 0.) THEN + hflux_fc(i) = outletwth(i) * hflux_up + mflux_fc(i) = outletwth(i) * mflux_up + ELSEIF (vwave_dn <= 0.) THEN + hflux_fc(i) = outletwth(i) * hflux_dn + mflux_fc(i) = outletwth(i) * mflux_dn + ELSE + hflux_fc(i) = outletwth(i) * (vwave_dn*hflux_up - vwave_up*hflux_dn & + + vwave_up*vwave_dn*(height_dn-height_up)) / (vwave_dn-vwave_up) + mflux_fc(i) = outletwth(i) * (vwave_dn*mflux_up - vwave_up*mflux_dn & + + vwave_up*vwave_dn*(hflux_dn-hflux_up)) / (vwave_dn-vwave_up) + ENDIF + + sum_zgrad_riv(i) = sum_zgrad_riv(i) + outletwth(i) * 0.5*grav * height_up**2 + + ELSE + hflux_fc(i) = 0 + mflux_fc(i) = 0 + ENDIF + + ELSEIF (riverdown(i) == -1) THEN ! inland depression hflux_fc(i) = 0 mflux_fc(i) = 0 - zgrad_dn(i) = 0 + ENDIF + + IF ((lake_id(i) < 0) .and. (hflux_fc(i) < 0)) THEN + hflux_fc(i) = & + max(hflux_fc(i), (height_up-height_dn) / dt_this * sum(hillslope_network(i)%area, & + mask = hillslope_network(i)%hand <= wdsrf_bsn(i) + handmin(i))) ENDIF sum_hflux_riv(i) = sum_hflux_riv(i) + hflux_fc(i) @@ -241,13 +292,14 @@ SUBROUTINE river_lake_flow (dt) ENDDO #ifdef USEMPI - hflux_fc = - hflux_fc - mflux_fc = - mflux_fc - zgrad_dn = - zgrad_dn + hflux_fc = - hflux_fc; mflux_fc = - mflux_fc; zgrad_dn = - zgrad_dn + CALL river_data_exchange (SEND_DATA_UP_TO_DOWN, accum = .true., & vec_send1 = hflux_fc, vec_recv1 = sum_hflux_riv, & vec_send2 = mflux_fc, vec_recv2 = sum_mflux_riv, & vec_send3 = zgrad_dn, vec_recv3 = sum_zgrad_riv) + + hflux_fc = - hflux_fc; mflux_fc = - mflux_fc; zgrad_dn = - zgrad_dn #endif DO i = 1, nbasin @@ -262,8 +314,9 @@ SUBROUTINE river_lake_flow (dt) IF (sum_hflux_riv(i) > 0) THEN IF (lake_id(i) <= 0) THEN ! for river or lake catchment - totalvolume = sum((wdsrf_bsn(i) - hillslope_network(i)%hand) * hillslope_network(i)%area, & - mask = hillslope_network(i)%hand <= wdsrf_bsn(i)) + totalvolume = sum((wdsrf_bsn(i) + handmin(i) - hillslope_network(i)%hand) & + * hillslope_network(i)%area, & + mask = wdsrf_bsn(i) + handmin(i) >= hillslope_network(i)%hand) ELSEIF (lake_id(i) > 0) THEN ! for lake totalvolume = lakes(i)%volume(wdsrf_bsn(i)) @@ -272,7 +325,7 @@ SUBROUTINE river_lake_flow (dt) dt_this = min(dt_this, totalvolume / sum_hflux_riv(i)) ENDIF - + ! constraint 3: Avoid change of flow direction (only for rivers) IF (lake_id(i) == 0) THEN IF ((abs(veloc_riv(i)) > 0.1) & @@ -291,63 +344,81 @@ SUBROUTINE river_lake_flow (dt) IF (lake_id(i) <= 0) THEN ! rivers or lake catchments - istt = basin_hru%substt(i) - iend = basin_hru%subend(i) + hs = basin_hru%substt(i) + he = basin_hru%subend(i) allocate (mask (hillslope_network(i)%nhru)) - dvol = sum_hflux_riv(i) * dt_this - IF (dvol > 0.) THEN - DO WHILE (dvol > 0.) - mask = hillslope_network(i)%hand < wdsrf_bsn(i) - nextl = maxval(hillslope_network(i)%hand, mask = mask) - nexta = sum (hillslope_network(i)%area, mask = mask) - nextv = nexta * (wdsrf_bsn(i)-nextl) - IF (nextv > dvol) THEN - ddep = dvol/nexta - dvol = 0. - ELSE - ddep = wdsrf_bsn(i) - nextl - dvol = dvol - nextv - ENDIF + totalvolume = sum((wdsrf_bsn(i) + handmin(i) - hillslope_network(i)%hand) & + * hillslope_network(i)%area, & + mask = wdsrf_bsn(i) + handmin(i) >= hillslope_network(i)%hand) + + totalvolume = totalvolume - sum_hflux_riv(i) * dt_this - wdsrf_bsn(i) = wdsrf_bsn(i) - ddep + IF (totalvolume < VOLUMEMIN) THEN + DO j = 1, hillslope_network(i)%nhru + IF (hillslope_network(i)%hand(j) <= wdsrf_bsn(i) + handmin(i)) THEN + wdsrf_hru(j+hs-1) = wdsrf_hru(j+hs-1) & + - (wdsrf_bsn(i) + handmin(i) - hillslope_network(i)%hand(j)) + ENDIF + ENDDO + wdsrf_bsn(i) = 0 + ELSE - DO j = 1, hillslope_network(i)%nhru - IF (mask(j)) THEN - wdsrf_hru(j+istt-1) = wdsrf_hru(j+istt-1) - ddep + dvol = sum_hflux_riv(i) * dt_this + IF (dvol > VOLUMEMIN) THEN + DO WHILE (dvol > VOLUMEMIN) + mask = hillslope_network(i)%hand < wdsrf_bsn(i) + handmin(i) + nextl = maxval(hillslope_network(i)%hand, mask = mask) + nexta = sum (hillslope_network(i)%area, mask = mask) + nextv = nexta * (wdsrf_bsn(i)+handmin(i)-nextl) + IF (nextv > dvol) THEN + ddep = dvol/nexta + dvol = 0. + ELSE + ddep = wdsrf_bsn(i)+handmin(i) - nextl + dvol = dvol - nextv ENDIF + + wdsrf_bsn(i) = wdsrf_bsn(i) - ddep + + DO j = 1, hillslope_network(i)%nhru + IF (mask(j)) THEN + wdsrf_hru(j+hs-1) = wdsrf_hru(j+hs-1) - ddep + ENDIF + ENDDO ENDDO - ENDDO - ELSEIF (dvol < 0.) THEN - DO WHILE (dvol < 0.) - mask = hillslope_network(i)%hand + wdsrf_hru(istt:iend) > wdsrf_bsn(i) - nexta = sum(hillslope_network(i)%area, mask = (.not. mask)) - IF (any(mask)) THEN - nextl = minval(hillslope_network(i)%hand + wdsrf_hru(istt:iend), mask = mask) - nextv = nexta*(nextl-wdsrf_bsn(i)) - IF ((-dvol) > nextv) THEN - ddep = nextl - wdsrf_bsn(i) - dvol = dvol + nextv + ELSEIF (dvol < -VOLUMEMIN) THEN + DO WHILE (dvol < -VOLUMEMIN) + mask = hillslope_network(i)%hand + wdsrf_hru(hs:he) > wdsrf_bsn(i) + handmin(i) + nexta = sum(hillslope_network(i)%area, mask = (.not. mask)) + IF (any(mask)) THEN + nextl = minval(hillslope_network(i)%hand + wdsrf_hru(hs:he), mask = mask) + nextv = nexta*(nextl-(wdsrf_bsn(i)+handmin(i))) + IF ((-dvol) > nextv) THEN + ddep = nextl - (wdsrf_bsn(i)+handmin(i)) + dvol = dvol + nextv + ELSE + ddep = (-dvol)/nexta + dvol = 0. + ENDIF ELSE ddep = (-dvol)/nexta dvol = 0. ENDIF - ELSE - ddep = (-dvol)/nexta - dvol = 0. - ENDIF - wdsrf_bsn(i) = wdsrf_bsn(i) + ddep + wdsrf_bsn(i) = wdsrf_bsn(i) + ddep - DO j = 1, hillslope_network(i)%nhru - IF (.not. mask(j)) THEN - wdsrf_hru(j+istt-1) = wdsrf_hru(j+istt-1) + ddep - ENDIF + DO j = 1, hillslope_network(i)%nhru + IF (.not. mask(j)) THEN + wdsrf_hru(j+hs-1) = wdsrf_hru(j+hs-1) + ddep + ENDIF + ENDDO ENDDO - ENDDO + ENDIF + ENDIF - deallocate(mask) + ELSE totalvolume = lakes(i)%volume(wdsrf_bsn(i)) totalvolume = totalvolume - sum_hflux_riv(i) * dt_this @@ -366,7 +437,7 @@ SUBROUTINE river_lake_flow (dt) ENDIF ! inland depression river - IF ((lake_id(i) == 0) .and. (riverdown(i) < 0)) THEN + IF ((lake_id(i) == 0) .and. (riverdown(i) == -1)) THEN momen_riv(i) = min(0., momen_riv(i)) veloc_riv(i) = min(0., veloc_riv(i)) ENDIF @@ -376,6 +447,7 @@ SUBROUTINE river_lake_flow (dt) IF (nbasin > 0) THEN wdsrf_bsn_ta(:) = wdsrf_bsn_ta(:) + wdsrf_bsn(:) * dt_this momen_riv_ta(:) = momen_riv_ta(:) + momen_riv(:) * dt_this + discharge (:) = discharge (:) + hflux_fc (:) * dt_this ENDIF dt_res = dt_res - dt_this @@ -384,16 +456,16 @@ SUBROUTINE river_lake_flow (dt) DO i = 1, nbasin IF (lake_id(i) > 0) THEN ! for lakes - istt = basin_hru%substt(i) - iend = basin_hru%subend(i) - DO j = istt, iend - wdsrf_hru(j) = max(wdsrf_bsn(i) - (lakes(i)%depth(1) - lakes(i)%depth0(j-istt+1)), 0.) + hs = basin_hru%substt(i) + he = basin_hru%subend(i) + DO j = hs, he + wdsrf_hru(j) = max(wdsrf_bsn(i) - (lakes(i)%depth(1) - lakes(i)%depth0(j-hs+1)), 0.) ENDDO ENDIF ENDDO - - wdsrf_bsn_prev(:) = wdsrf_bsn(:) + wdsrf_bsn_prev(:) = wdsrf_bsn(:) + IF (allocated(wdsrf_bsn_ds )) deallocate(wdsrf_bsn_ds ) IF (allocated(veloc_riv_ds )) deallocate(veloc_riv_ds ) IF (allocated(momen_riv_ds )) deallocate(momen_riv_ds ) @@ -407,6 +479,6 @@ SUBROUTINE river_lake_flow (dt) ENDIF END SUBROUTINE river_lake_flow - -END MODULE MOD_Hydro_RiverLakeFlow + +END MODULE MOD_Catch_RiverLakeFlow #endif diff --git a/main/HYDRO/MOD_Hydro_RiverLakeNetwork.F90 b/main/HYDRO/MOD_Catch_RiverLakeNetwork.F90 similarity index 79% rename from main/HYDRO/MOD_Hydro_RiverLakeNetwork.F90 rename to main/HYDRO/MOD_Catch_RiverLakeNetwork.F90 index f6d199d3..24d7cbf2 100644 --- a/main/HYDRO/MOD_Hydro_RiverLakeNetwork.F90 +++ b/main/HYDRO/MOD_Catch_RiverLakeNetwork.F90 @@ -1,7 +1,7 @@ #include -#ifdef LATERAL_FLOW -MODULE MOD_Hydro_RiverLakeNetwork +#ifdef CatchLateralFlow +MODULE MOD_Catch_RiverLakeNetwork !-------------------------------------------------------------------------------- ! DESCRIPTION: ! @@ -23,6 +23,7 @@ MODULE MOD_Hydro_RiverLakeNetwork REAL(r8), allocatable :: basinelv (:) REAL(r8), allocatable :: bedelv (:) + REAL(r8), allocatable :: handmin (:) REAL(r8), allocatable :: wtsrfelv (:) @@ -93,16 +94,19 @@ SUBROUTINE river_lake_network_init () USE MOD_Pixel USE MOD_LandElm USE MOD_LandPatch - USE MOD_Hydro_HillslopeNetwork + USE MOD_Catch_HillslopeNetwork + USE MOD_ElementNeighbour USE MOD_DataType USE MOD_Utils USE MOD_Vars_TimeInvariants, only : lakedepth IMPLICIT NONE + ! Local Variables - CHARACTER(len=256) :: river_file + CHARACTER(len=256) :: river_file, rivdpt_file + logical :: use_calc_rivdpt - INTEGER :: numbasin, ibasin, nbasin + INTEGER :: numbasin, ibasin, nbasin, inb INTEGER :: iworker, mesg(4), isrc, idest, iproc INTEGER :: irecv, ifrom, ito, iup, idn, idata INTEGER :: nrecv, ndata, nup, ndn @@ -121,7 +125,7 @@ SUBROUTINE river_lake_network_init () INTEGER, allocatable :: basin_sorted(:), order(:) ! for lakes - integer :: istt, iend, nsublake, i, ipatch, ipxl + integer :: ps, pe, nsublake, i, ipatch, ipxl #ifdef USEMPI CALL mpi_barrier (p_comm_glb, p_err) @@ -129,7 +133,8 @@ SUBROUTINE river_lake_network_init () numbasin = numelm - river_file = DEF_CatchmentMesh_data + use_calc_rivdpt = DEF_USE_EstimatedRiverDepth + river_file = DEF_CatchmentMesh_data IF (p_is_master) THEN @@ -137,10 +142,28 @@ SUBROUTINE river_lake_network_init () CALL ncio_read_serial (river_file, 'basin_downstream', riverdown) CALL ncio_read_serial (river_file, 'river_length' , riverlen ) CALL ncio_read_serial (river_file, 'river_elevation' , riverelv ) - CALL ncio_read_serial (river_file, 'river_depth ' , riverdpth) CALL ncio_read_serial (river_file, 'basin_elevation' , basinelv ) + + IF (.not. use_calc_rivdpt) THEN + CALL ncio_read_serial (river_file, 'river_depth' , riverdpth) + ENDIF riverlen = riverlen * 1.e3 ! km to m + + nbasin = size(riverdown) + allocate (to_lake (nbasin)) + to_lake = .false. + DO i = 1, nbasin + IF (riverdown(i) > 0) THEN + to_lake(i) = lake_id(riverdown(i)) > 0 + ENDIF + ENDDO + + ENDIF + + IF (use_calc_rivdpt) THEN + ! Estimate river depth by using runoff data. + CALL calc_riverdepth_from_runoff () ENDIF #ifdef USEMPI @@ -151,14 +174,6 @@ SUBROUTINE river_lake_network_init () allocate (addrbasin (2,nbasin)) addrbasin(:,:) = -1 - allocate (to_lake (nbasin)) - to_lake = .false. - DO i = 1, nbasin - IF (riverdown(i) > 0) THEN - to_lake(i) = lake_id(riverdown(i)) > 0 - ENDIF - ENDDO - DO iworker = 1, p_np_worker CALL mpi_recv (mesg(1:2), 2, MPI_INTEGER, & @@ -519,6 +534,7 @@ SUBROUTINE river_lake_network_init () allocate (riverarea (numbasin)) allocate (riverwth (numbasin)) allocate (bedelv (numbasin)) + allocate (handmin (numbasin)) allocate (wtsrfelv (numbasin)) allocate (riverlen_ds (numbasin)) allocate (wtsrfelv_ds (numbasin)) @@ -546,12 +562,12 @@ SUBROUTINE river_lake_network_init () wtsrfelv(ibasin) = basinelv(ibasin) - istt = elm_patch%substt(ibasin) - iend = elm_patch%subend(ibasin) + ps = elm_patch%substt(ibasin) + pe = elm_patch%subend(ibasin) - bedelv(ibasin) = basinelv(ibasin) - maxval(lakedepth(istt:iend)) + bedelv(ibasin) = basinelv(ibasin) - maxval(lakedepth(ps:pe)) - nsublake = iend - istt + 1 + nsublake = pe - ps + 1 lakes(ibasin)%nsub = nsublake allocate (lakes(ibasin)%area0 (nsublake)) @@ -560,7 +576,7 @@ SUBROUTINE river_lake_network_init () allocate (lakes(ibasin)%depth (nsublake)) DO i = 1, nsublake - ipatch = i + istt - 1 + ipatch = i + ps - 1 lakes(ibasin)%area(i) = 0 DO ipxl = landpatch%ipxstt(ipatch), landpatch%ipxend(ipatch) lakes(ibasin)%area(i) = lakes(ibasin)%area(i) & @@ -573,7 +589,7 @@ SUBROUTINE river_lake_network_init () ! area data in HRU order lakes(ibasin)%area0 = lakes(ibasin)%area - lakes(ibasin)%depth = lakedepth(istt:iend) + lakes(ibasin)%depth = lakedepth(ps:pe) ! depth data in HRU order lakes(ibasin)%depth0 = lakes(ibasin)%depth @@ -586,8 +602,8 @@ SUBROUTINE river_lake_network_init () lakes(ibasin)%area = lakes(ibasin)%area(order) ! adjust to be from deepest to shallowest - lakes(ibasin)%depth = lakes(ibasin)%depth(1:nsublake:-1) - lakes(ibasin)%area = lakes(ibasin)%area (1:nsublake:-1) + lakes(ibasin)%depth = lakes(ibasin)%depth(nsublake:1:-1) + lakes(ibasin)%area = lakes(ibasin)%area (nsublake:1:-1) allocate (lakes(ibasin)%dep_vol_curve (nsublake)) @@ -602,6 +618,10 @@ SUBROUTINE river_lake_network_init () deallocate (order) ENDIF + + IF (lake_id(ibasin) <= 0) THEN + handmin(ibasin) = minval(hillslope_network(ibasin)%hand) + ENDIF ENDDO ENDIF @@ -629,7 +649,42 @@ SUBROUTINE river_lake_network_init () DO ibasin = 1, numbasin IF (lake_id(ibasin) < 0) THEN - bedelv(ibasin) = wtsrfelv_ds(ibasin) + bedelv(ibasin) = wtsrfelv_ds(ibasin) + minval(hillslope_network(ibasin)%hand) + ENDIF + ENDDO + + DO ibasin = 1, numbasin + IF (lake_id(ibasin) == 0) THEN + IF ((to_lake(ibasin)) .or. (riverdown(ibasin) <= 0)) THEN + ! river to lake, ocean, inland depression or out of region + outletwth(ibasin) = riverwth(ibasin) + ELSE + ! river to river + outletwth(ibasin) = (riverwth(ibasin) + riverwth_ds(ibasin)) * 0.5 + ENDIF + ELSEIF (lake_id(ibasin) /= 0) THEN + IF ((.not. to_lake(ibasin)) .and. (riverdown(ibasin) /= 0)) THEN + IF (riverdown(ibasin) > 0) THEN + ! lake to river + outletwth(ibasin) = riverwth_ds(ibasin) + ELSEIF (riverdown(ibasin) == -1) THEN + ! lake is inland depression + outletwth(ibasin) = 0 + ENDIF + ELSEIF (to_lake(ibasin) .or. (riverdown(ibasin) == 0)) THEN + ! lake to lake .or. lake catchment to lake .or. lake to ocean + IF (riverdown(ibasin) > 0) THEN + inb = findloc(elementneighbour(ibasin)%glbindex, riverdown(ibasin), dim=1) + ELSE + inb = findloc(elementneighbour(ibasin)%glbindex, -9, dim=1) ! -9 is ocean + ENDIF + + IF (inb <= 0) THEN + outletwth(ibasin) = 0 + ELSE + outletwth(ibasin) = elementneighbour(ibasin)%lenbdr(inb) + ENDIF + ENDIF ENDIF ENDDO @@ -643,6 +698,187 @@ SUBROUTINE river_lake_network_init () END SUBROUTINE river_lake_network_init + ! ----- retrieve river depth from runoff ----- + SUBROUTINE calc_riverdepth_from_runoff () + + USE MOD_SPMD_Task + USE MOD_Namelist + USE MOD_DataType + USE MOD_NetCDFSerial + USE MOD_NetCDFBlock + USE MOD_Block + USE MOD_Mesh + USE MOD_Grid + USE MOD_Mapping_Grid2Pset + USE MOD_LandElm + USE MOD_ElmVector + USE MOD_ElementNeighbour + USE MOD_Hydro_IO + IMPLICIT NONE + + ! Local Variables + character(len=256) :: file_rnof, file_rivdpt + type(grid_type) :: grid_rnof + type(block_data_real8_2d) :: f_rnof + type(mapping_grid2pset_type) :: mg2p_rnof + + real(r8), allocatable :: bsnrnof(:) , bsndis(:) + integer, allocatable :: nups_riv(:), iups_riv(:), b_up2down(:) + + integer :: i, j, ithis, ib, jb, iblkme + integer :: iwork, mesg(2), isrc, ndata + real(r8), allocatable :: rcache(:) + + real(r8), parameter :: cH_rivdpt = 0.1 + real(r8), parameter :: pH_rivdpt = 0.5 + real(r8), parameter :: B0_rivdpt = 0.0 + real(r8), parameter :: Bmin_rivdpt = 1.0 + + + file_rnof = trim(DEF_dir_runtime) // '/runoff_clim.nc' + + CALL grid_rnof%define_from_file (file_rnof, 'lat', 'lon') + + call mg2p_rnof%build (grid_rnof, landelm) + + IF (p_is_io) THEN + CALL allocate_block_data (grid_rnof, f_rnof) + CALL ncio_read_block (file_rnof, 'ro', grid_rnof, f_rnof) + + DO iblkme = 1, gblock%nblkme + ib = gblock%xblkme(iblkme) + jb = gblock%yblkme(iblkme) + do j = 1, grid_rnof%ycnt(jb) + do i = 1, grid_rnof%xcnt(ib) + f_rnof%blk(ib,jb)%val(i,j) = max(f_rnof%blk(ib,jb)%val(i,j), 0.) + ENDDO + ENDDO + ENDDO + ENDIF + + IF (p_is_worker) THEN + IF (numelm > 0) allocate (bsnrnof (numelm)) + ENDIF + + call mg2p_rnof%map_aweighted (f_rnof, bsnrnof) + + IF (p_is_worker) THEN + IF (numelm > 0) THEN + bsnrnof = bsnrnof /24.0/3600.0 ! from m/day to m/s + DO i = 1, numelm + ! total runoff in basin, from m/s to m3/s + bsnrnof(i) = bsnrnof(i) * elementneighbour(i)%myarea + ENDDO + ENDIF + ENDIF + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) + + if (p_is_worker) then + mesg = (/p_iam_glb, numelm/) + call mpi_send (mesg, 2, MPI_INTEGER, p_root, mpi_tag_mesg, p_comm_glb, p_err) + IF (numelm > 0) THEN + call mpi_send (bsnrnof, numelm, MPI_REAL8, p_root, mpi_tag_data, p_comm_glb, p_err) + ENDIF + ENDIF + + IF (p_is_master) THEN + + allocate (bsnrnof (totalnumelm)) + + DO iwork = 0, p_np_worker-1 + call mpi_recv (mesg, 2, MPI_INTEGER, MPI_ANY_SOURCE, & + mpi_tag_mesg, p_comm_glb, p_stat, p_err) + + isrc = mesg(1) + ndata = mesg(2) + IF (ndata > 0) THEN + allocate(rcache (ndata)) + + call mpi_recv (rcache, ndata, MPI_REAL8, isrc, & + mpi_tag_data, p_comm_glb, p_stat, p_err) + + bsnrnof(elm_data_address(p_itis_worker(isrc))%val) = rcache + + deallocate (rcache) + ENDIF + ENDDO + ENDIF + + CALL mpi_barrier (p_comm_glb, p_err) +#else + bsnrnof(elm_data_address(0)%val) = bsnrnof +#endif + + + IF (p_is_master) THEN + + allocate (nups_riv (totalnumelm)) + allocate (iups_riv (totalnumelm)) + allocate (b_up2down(totalnumelm)) + + allocate (bsndis (totalnumelm)) + + nups_riv(:) = 0 + DO i = 1, totalnumelm + j = riverdown(i) + IF (j > 0) THEN + nups_riv(j) = nups_riv(j) + 1 + ENDIF + ENDDO + + iups_riv(:) = 0 + ithis = 0 + DO i = 1, totalnumelm + IF (iups_riv(i) == nups_riv(i)) THEN + ithis = ithis + 1 + b_up2down(ithis) = i + + j = riverdown(i) + IF (j > 0) THEN + iups_riv(j) = iups_riv(j) + 1 + DO WHILE (iups_riv(j) == nups_riv(j)) + IF (j < i) THEN + ithis = ithis + 1 + b_up2down(ithis) = j + ENDIF + j = riverdown(j) + IF (j > 0) THEN + iups_riv(j) = iups_riv(j) + 1 + ELSE + EXIT + ENDIF + ENDDO + ENDIF + ELSE + CYCLE + ENDIF + ENDDO + + bsndis(:) = 0. + DO i = 1, totalnumelm + j = b_up2down(i) + bsndis(j) = bsndis(j) + bsnrnof(j) + IF (riverdown(j) > 0) THEN + bsndis(riverdown(j)) = bsndis(riverdown(j)) + bsndis(j) + ENDIF + ENDDO + + DO i = 1, totalnumelm + riverdpth(i) = max(cH_rivdpt * (bsndis(i)**pH_rivdpt) + B0_rivdpt, Bmin_rivdpt) + ENDDO + + ENDIF + + IF (allocated (bsnrnof )) deallocate(bsnrnof ) + IF (allocated (bsndis )) deallocate(bsndis ) + IF (allocated (nups_riv )) deallocate(nups_riv ) + IF (allocated (iups_riv )) deallocate(iups_riv ) + IF (allocated (b_up2down)) deallocate(b_up2down) + + END SUBROUTINE calc_riverdepth_from_runoff + ! FUNCTION retrieve_lake_surface_from_volume (this, volume) result(surface) @@ -664,8 +900,12 @@ FUNCTION retrieve_lake_surface_from_volume (this, volume) result(surface) surface = volume / this%area(1) ELSE i = 1 - DO WHILE ((volume >= this%dep_vol_curve(i+1)) .and. (i < this%nsub)) - i = i + 1 + DO WHILE (i < this%nsub) + IF (volume >= this%dep_vol_curve(i+1)) THEN + i = i + 1 + ELSE + EXIT + ENDIF ENDDO surface = this%depth(1) - this%depth(i) + & (volume - this%dep_vol_curve(i)) / sum(this%area(1:i)) @@ -694,8 +934,12 @@ FUNCTION retrieve_lake_volume_from_surface (this, surface) result(volume) volume = this%area(1) * surface ELSE i = 1 - DO WHILE ((surface >= this%depth(1)-this%depth(i+1)) .and. (i < this%nsub)) - i = i + 1 + DO WHILE (i < this%nsub) + IF (surface >= this%depth(1)-this%depth(i+1)) THEN + i = i + 1 + ELSE + EXIT + ENDIF ENDDO volume = this%dep_vol_curve(i) & + (surface - (this%depth(1) - this%depth(i))) * sum(this%area(1:i)) @@ -955,6 +1199,8 @@ SUBROUTINE river_lake_network_final () IF (allocated(riverwth )) deallocate(riverwth ) IF (allocated(riverdpth)) deallocate(riverdpth) IF (allocated(basinelv )) deallocate(basinelv ) + IF (allocated(bedelv )) deallocate(bedelv ) + IF (allocated(handmin )) deallocate(handmin ) IF (allocated(wtsrfelv )) deallocate(wtsrfelv ) IF (allocated(riverdown)) deallocate(riverdown) IF (allocated(addrdown )) deallocate(addrdown ) @@ -995,5 +1241,5 @@ SUBROUTINE river_sendrecv_free_mem (this) END SUBROUTINE river_sendrecv_free_mem -END MODULE MOD_Hydro_RiverLakeNetwork +END MODULE MOD_Catch_RiverLakeNetwork #endif diff --git a/main/HYDRO/MOD_Hydro_SubsurfaceFlow.F90 b/main/HYDRO/MOD_Catch_SubsurfaceFlow.F90 similarity index 55% rename from main/HYDRO/MOD_Hydro_SubsurfaceFlow.F90 rename to main/HYDRO/MOD_Catch_SubsurfaceFlow.F90 index df1d8c64..876a34f3 100644 --- a/main/HYDRO/MOD_Hydro_SubsurfaceFlow.F90 +++ b/main/HYDRO/MOD_Catch_SubsurfaceFlow.F90 @@ -1,7 +1,7 @@ #include -#ifdef LATERAL_FLOW -MODULE MOD_Hydro_SubsurfaceFlow +#ifdef CatchLateralFlow +MODULE MOD_Catch_SubsurfaceFlow !------------------------------------------------------------------------------------- ! DESCRIPTION: ! @@ -16,13 +16,88 @@ MODULE MOD_Hydro_SubsurfaceFlow !------------------------------------------------------------------------------------- USE MOD_Precision + USE MOD_DataType IMPLICIT NONE REAL(r8), parameter :: e_ice = 6.0 ! soil ice impedance factor REAL(r8), parameter :: raniso = 1. ! anisotropy ratio, unitless + ! -- neighbour variables -- + TYPE(pointer_real8_1d), allocatable :: agwt_nb (:) ! ground water area (for patchtype <= 2) of neighbours [m^2] + TYPE(pointer_real8_1d), allocatable :: theta_a_nb (:) ! saturated volume content [-] + TYPE(pointer_real8_1d), allocatable :: zwt_nb (:) ! water table depth [m] + TYPE(pointer_real8_1d), allocatable :: Ks_nb (:) ! saturated hydraulic conductivity [m/s] + TYPE(pointer_real8_1d), allocatable :: wdsrf_nb (:) ! depth of surface water [m] + TYPE(pointer_logic_1d), allocatable :: islake_nb (:) ! whether a neighbour is water body + CONTAINS + ! ---------- + SUBROUTINE basin_neighbour_init () + + USE MOD_SPMD_Task + USE MOD_Mesh + USE MOD_ElementNeighbour + USE MOD_Catch_HillslopeNetwork, only : hillslope_network + USE MOD_Catch_RiverLakeNetwork, only : lake_id + IMPLICIT NONE + + INTEGER :: numbasin, ibasin, inb + + REAL(r8), allocatable :: agwt_b(:) + real(r8), allocatable :: islake(:) + TYPE(pointer_real8_1d), allocatable :: iswat_nb (:) + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + numbasin = numelm + + IF (p_is_worker) THEN + + CALL allocate_neighbour_data (agwt_nb ) + CALL allocate_neighbour_data (theta_a_nb) + CALL allocate_neighbour_data (zwt_nb ) + CALL allocate_neighbour_data (Ks_nb ) + CALL allocate_neighbour_data (wdsrf_nb ) + CALL allocate_neighbour_data (islake_nb ) + + CALL allocate_neighbour_data (iswat_nb ) + + IF (numbasin > 0) THEN + allocate (agwt_b(numbasin)) + allocate (islake(numbasin)) + DO ibasin = 1, numbasin + IF (lake_id(ibasin) <= 0) THEN + agwt_b(ibasin) = sum(hillslope_network(ibasin)%agwt) + islake(ibasin) = 0. + ELSE + agwt_b(ibasin) = 0. + islake(ibasin) = 1. + ENDIF + ENDDO + ENDIF + + CALL retrieve_neighbour_data (agwt_b, agwt_nb ) + CALL retrieve_neighbour_data (islake, iswat_nb) + + DO ibasin = 1, numbasin + DO inb = 1, elementneighbour(ibasin)%nnb + IF (elementneighbour(ibasin)%glbindex(inb) > 0) THEN ! skip ocean neighbour + islake_nb(ibasin)%val(inb) = (iswat_nb(ibasin)%val(inb) > 0) + ENDIF + ENDDO + ENDDO + + IF (allocated(agwt_b )) deallocate(agwt_b ) + IF (allocated(islake )) deallocate(islake ) + IF (allocated(iswat_nb)) deallocate(iswat_nb) + + ENDIF + + END SUBROUTINE basin_neighbour_init + ! --------- SUBROUTINE subsurface_flow (deltime) @@ -33,9 +108,9 @@ SUBROUTINE subsurface_flow (deltime) USE MOD_Vars_TimeVariables USE MOD_Vars_TimeInvariants USE MOD_Vars_1DFluxes - USE MOD_Hydro_HillslopeNetwork - USE MOD_Hydro_RiverLakeNetwork - USE MOD_Hydro_BasinNeighbour + USE MOD_Catch_HillslopeNetwork + USE MOD_Catch_RiverLakeNetwork + USE MOD_ElementNeighbour USE MOD_Const_Physical, only : denice, denh2o USE MOD_Vars_Global, only : pi, nl_soil, zi_soi USE MOD_Hydro_SoilWater, only : soilwater_aquifer_exchange @@ -52,9 +127,8 @@ SUBROUTINE subsurface_flow (deltime) REAL(r8), allocatable :: theta_a_h (:) REAL(r8), allocatable :: zwt_h (:) REAL(r8), allocatable :: Ks_h (:) ! [m/s] - REAL(r8), allocatable :: rsubs_h (:) ! [m/s] - REAL(r8), allocatable :: rsubs_fc (:) ! [m/s] - REAL(r8) :: rsubs_riv + REAL(r8), allocatable :: xsubs_h (:) ! [m/s] + REAL(r8), allocatable :: xsubs_fc (:) ! [m/s] logical :: j_is_river REAL(r8) :: theta_s_h, air_h, icefrac, imped, delp @@ -71,8 +145,8 @@ SUBROUTINE subsurface_flow (deltime) INTEGER :: jnb REAL(r8) :: zsubs_up, zwt_up, Ks_up, theta_a_up, area_up REAL(r8) :: zsubs_dn, zwt_dn, Ks_dn, theta_a_dn, area_dn - REAL(r8) :: lenbdr, rsubs_nb - logical :: iam_watb, nb_is_watb, has_river + REAL(r8) :: lenbdr, xsubs_nb + logical :: iam_lake, nb_is_lake, has_river ! for water exchange integer :: izwt @@ -98,62 +172,58 @@ SUBROUTINE subsurface_flow (deltime) numbasin = numelm - rsubs_bsn(:) = 0. ! subsurface lateral flow between basins - rsubs_hru(:) = 0. ! subsurface lateral flow between hydrological response units - rsubs_pch(:) = 0. ! subsurface lateral flow between patches inside one HRU + xsubs_bsn(:) = 0. ! subsurface lateral flow between basins + xsubs_hru(:) = 0. ! subsurface lateral flow between hydrological response units + xsubs_pch(:) = 0. ! subsurface lateral flow between patches inside one HRU - rsub(:) = 0. ! total recharge/discharge from subsurface lateral flow + xwsub(:) = 0. ! total recharge/discharge from subsurface lateral flow bdamp = 4.8 IF (numbasin > 0) THEN - allocate (theta_a_bsn (numbasin)) - allocate (zwt_bsn (numbasin)) - allocate (Ks_bsn (numbasin)) + allocate (theta_a_bsn (numbasin)); theta_a_bsn = 0. + allocate (zwt_bsn (numbasin)); zwt_bsn = 0. + allocate (Ks_bsn (numbasin)); Ks_bsn = 0. ENDIF DO ibasin = 1, numbasin hrus => hillslope_network(ibasin) - - theta_a_bsn (ibasin) = 0. - zwt_bsn (ibasin) = 0. - Ks_bsn (ibasin) = 0. nhru = hrus%nhru - IF (lake_id(ibasin) > 0) CYCLE ! lake - IF ((hrus%indx(1)==0) .and. (nhru==1)) CYCLE ! only river in a catchment + IF (lake_id(ibasin) > 0) CYCLE ! lake + IF (sum(hrus%agwt) <= 0) CYCLE ! no area of soil, urban or wetland - allocate (theta_a_h (nhru)) - allocate (zwt_h (nhru)) - allocate (Ks_h (nhru)) - - theta_a_h = 0. - zwt_h = 0. - Ks_h = 0. + allocate (theta_a_h (nhru)); theta_a_h = 0. + allocate (zwt_h (nhru)); zwt_h = 0. + allocate (Ks_h (nhru)); Ks_h = 0. DO i = 1, nhru IF (hrus%indx(i) == 0) CYCLE ! river - IF (hrus%awat(i) == 0) CYCLE ! only land ice or water body in this HRU + IF (hrus%agwt(i) == 0) CYCLE ! no area of soil, urban or wetland ps = hru_patch%substt(hrus%ihru(i)) pe = hru_patch%subend(hrus%ihru(i)) theta_s_h = 0 + sumwt = 0 DO ipatch = ps, pe IF (patchtype(ipatch) <= 2) THEN theta_s_h = theta_s_h + hru_patch%subfrc(ipatch) & * sum(porsl(1:nl_soil,ipatch) * dz_soi(1:nl_soil) & - wice_soisno(1:nl_soil,ipatch)/denice) / sum(dz_soi(1:nl_soil)) + sumwt = sumwt + hru_patch%subfrc(ipatch) ENDIF ENDDO + IF (sumwt > 0) theta_s_h = theta_s_h / sumwt IF (theta_s_h > 0.) THEN air_h = 0. zwt_h(i) = 0. + sumwt = 0. DO ipatch = ps, pe IF (patchtype(ipatch) <= 2) THEN air_h = air_h + hru_patch%subfrc(ipatch) & @@ -163,8 +233,12 @@ SUBROUTINE subsurface_flow (deltime) air_h = max(0., air_h) zwt_h(i) = zwt_h(i) + zwt(ipatch) * hru_patch%subfrc(ipatch) + + sumwt = sumwt + hru_patch%subfrc(ipatch) ENDIF ENDDO + IF (sumwt > 0) air_h = air_h / sumwt + IF (sumwt > 0) zwt_h(i) = zwt_h(i) / sumwt IF ((air_h <= 0.) .or. (zwt_h(i) <= 0.)) THEN theta_a_h(i) = theta_s_h @@ -178,6 +252,7 @@ SUBROUTINE subsurface_flow (deltime) ENDIF Ks_h(i) = 0. + sumwt = 0. DO ipatch = ps, pe IF (patchtype(ipatch) <= 2) THEN DO ilev = 1, nl_soil @@ -186,8 +261,10 @@ SUBROUTINE subsurface_flow (deltime) Ks_h(i) = Ks_h(i) + hru_patch%subfrc(ipatch) & * hksati(ilev,ipatch)/1.0e3 * imped * dz_soi(ilev)/zi_soi(nl_soil) ENDDO + sumwt = sumwt + hru_patch%subfrc(ipatch) ENDIF ENDDO + IF (sumwt > 0) Ks_h(i) = Ks_h(i) / sumwt ELSE ! Frozen soil. Ks_h(i) = 0. @@ -195,11 +272,11 @@ SUBROUTINE subsurface_flow (deltime) ENDDO - allocate (rsubs_h (nhru)) - allocate (rsubs_fc (nhru)) + allocate (xsubs_h (nhru)) + allocate (xsubs_fc (nhru)) - rsubs_h (:) = 0. - rsubs_fc(:) = 0. + xsubs_h (:) = 0. + xsubs_fc(:) = 0. DO i = 1, nhru @@ -250,52 +327,64 @@ SUBROUTINE subsurface_flow (deltime) ENDIF ENDIF - ca = hrus%flen(i) * Ks_fc / theta_a_h(i) / delp / hrus%awat(i) * deltime + ca = hrus%flen(i) * Ks_fc / theta_a_h(i) / delp / hrus%agwt(i) * deltime IF (.not. j_is_river) THEN - cb = hrus%flen(i) * Ks_fc / theta_a_h(j) / delp / hrus%awat(j) * deltime + cb = hrus%flen(i) * Ks_fc / theta_a_h(j) / delp / hrus%agwt(j) * deltime ELSE - cb = hrus%flen(i) * Ks_fc / delp / hrus%awat(j) * deltime + cb = hrus%flen(i) * Ks_fc / delp / hrus%area(j) * deltime ENDIF - rsubs_fc(i) = (zsubs_h_up - zsubs_h_dn) * hrus%flen(i) * Ks_fc / (1+ca+cb) / delp + xsubs_fc(i) = (zsubs_h_up - zsubs_h_dn) * hrus%flen(i) * Ks_fc / (1+ca+cb) / delp - rsubs_h(i) = rsubs_h(i) + rsubs_fc(i) / hrus%awat(i) - rsubs_h(j) = rsubs_h(j) - rsubs_fc(i) / hrus%awat(j) + xsubs_h(i) = xsubs_h(i) + xsubs_fc(i) / hrus%agwt(i) + + IF (j_is_river) THEN + xsubs_h(j) = xsubs_h(j) - xsubs_fc(i) / hrus%area(j) + ELSE + xsubs_h(j) = xsubs_h(j) - xsubs_fc(i) / hrus%agwt(j) + ENDIF ENDDO IF (hrus%indx(1) == 0) THEN - ! rsubs_h(1) is positive = out of soil column - IF (rsubs_h(1)*deltime > wdsrf_bsn(ibasin)*riverarea(ibasin)) THEN - alp = wdsrf_bsn(ibasin)*riverarea(ibasin) / (rsubs_h(1)*deltime) - rsubs_h(1) = rsubs_h(1) * alp + ! xsubs_h(1) is positive = out of soil column + IF (xsubs_h(1)*deltime > wdsrf_bsn(ibasin)) THEN + alp = wdsrf_bsn(ibasin) / (xsubs_h(1)*deltime) + xsubs_h(1) = xsubs_h(1) * alp DO i = 2, nhru - IF (hrus%inext(i) == 1) THEN - rsubs_h(i) = rsubs_h(i) - (1.0-alp)*rsubs_fc(i)/hrus%awat(i) + IF ((hrus%inext(i) == 1) .and. (hrus%agwt(i) > 0.)) THEN + xsubs_h(i) = xsubs_h(i) - (1.0-alp)*xsubs_fc(i)/hrus%agwt(i) ENDIF ENDDO ENDIF ENDIF ! Update total subsurface lateral flow (1): Between hydrological units + ! for soil, urban, wetland or river patches DO i = 1, nhru - rsubs_hru(hrus%ihru(i)) = rsubs_h(i) + xsubs_hru(hrus%ihru(i)) = xsubs_h(i) ps = hru_patch%substt(hrus%ihru(i)) pe = hru_patch%subend(hrus%ihru(i)) DO ipatch = ps, pe - IF (patchtype(ipatch) <= 2) THEN - rsub(ipatch) = rsub(ipatch) + rsubs_h(i) * 1.e3 ! (positive = out of soil column) + IF ((patchtype(ipatch) <= 2) .or. (hrus%indx(i) == 0)) THEN + xwsub(ipatch) = xwsub(ipatch) + xsubs_h(i) * 1.e3 ! (positive = out of soil column) ENDIF ENDDO + + IF (hrus%indx(1) == 0) THEN + DO ipatch = ps, pe + IF (patchtype(ipatch) <= 2) THEN + rsub(ipatch) = - xsubs_h(1) * riverarea(ibasin) / sum(hrus%agwt) * 1.0e3 ! m/s to mm/s + ENDIF + ENDDO + ENDIF ENDDO DO i = 1, nhru ! Inside hydrological units - IF (hrus%indx(i) /= 0) THEN - ps = hru_patch%substt(hrus%ihru(i)) - pe = hru_patch%subend(hrus%ihru(i)) + IF (hrus%agwt(i) > 0) THEN IF (zwt_h(i) > 1.5) THEN ! from Fan et al., JGR 112(D10125) @@ -304,33 +393,35 @@ SUBROUTINE subsurface_flow (deltime) Ks_in = raniso * Ks_h(i) * ((1.5-zwt_h(i)) + bdamp) ENDIF + ps = hru_patch%substt(hrus%ihru(i)) + pe = hru_patch%subend(hrus%ihru(i)) sumwt = sum(hru_patch%subfrc(ps:pe), mask = patchtype(ps:pe) <= 2) IF (sumwt > 0) THEN zwt_mean = sum(zwt(ps:pe)*hru_patch%subfrc(ps:pe), mask = patchtype(ps:pe) <= 2) / sumwt DO ipatch = ps, pe IF (patchtype(ipatch) <= 2) THEN - rsubs_pch(ipatch) = - Ks_in * (zwt(ipatch) - zwt_mean) *6.0*pi/hrus%awat(i) + xsubs_pch(ipatch) = - Ks_in * (zwt(ipatch) - zwt_mean) *6.0*pi/hrus%agwt(i) ! Update total subsurface lateral flow (2): Between patches - rsub(ipatch) = rsub(ipatch) + rsubs_pch(ipatch) * 1.e3 ! m/s to mm/s + xwsub(ipatch) = xwsub(ipatch) + xsubs_pch(ipatch) * 1.e3 ! m/s to mm/s ENDIF ENDDO ENDIF ENDIF ENDDO - sumarea = sum(hrus%awat) + sumarea = sum(hrus%agwt) IF (sumarea > 0) THEN - theta_a_bsn (ibasin) = sum(theta_a_h * hrus%awat) / sumarea - zwt_bsn (ibasin) = sum(zwt_h * hrus%awat) / sumarea - Ks_bsn (ibasin) = sum(Ks_h * hrus%awat) / sumarea + theta_a_bsn (ibasin) = sum(theta_a_h * hrus%agwt) / sumarea + zwt_bsn (ibasin) = sum(zwt_h * hrus%agwt) / sumarea + Ks_bsn (ibasin) = sum(Ks_h * hrus%agwt) / sumarea ENDIF deallocate (theta_a_h) deallocate (zwt_h ) deallocate (Ks_h ) - deallocate (rsubs_h ) - deallocate (rsubs_fc ) + deallocate (xsubs_h ) + deallocate (xsubs_fc ) ENDDO @@ -343,74 +434,66 @@ SUBROUTINE subsurface_flow (deltime) hrus => hillslope_network(ibasin) - iam_watb = .false. - IF (lake_id(ibasin) > 0) THEN - iam_watb = .true. - ELSEIF ((hrus%nhru == 1) .and. (hrus%indx(1) == 0)) THEN - iam_watb = .true. - ENDIF + iam_lake = (lake_id(ibasin) > 0) - DO jnb = 1, basinneighbour(ibasin)%nnb + DO jnb = 1, elementneighbour(ibasin)%nnb - IF (basinneighbour(ibasin)%bindex(jnb) == -9) CYCLE ! skip ocean neighbour + IF (elementneighbour(ibasin)%glbindex(jnb) == -9) CYCLE ! skip ocean neighbour - nb_is_watb = basinneighbour(ibasin)%iswatb(jnb) + nb_is_lake = islake_nb(ibasin)%val(jnb) - IF (iam_watb .and. nb_is_watb) then + IF (iam_lake .and. nb_is_lake) then CYCLE ENDIF - - IF (.not. iam_watb) Ks_up = Ks_bsn(ibasin) - IF (.not. nb_is_watb) Ks_dn = Ks_nb(ibasin)%val(jnb) - - IF ((Ks_up == 0.) .or. (Ks_dn == 0.)) THEN - cycle - ENDIF - - IF (.not. iam_watb) zwt_up = zwt_bsn(ibasin) - IF (.not. nb_is_watb) zwt_dn = zwt_nb(ibasin)%val(jnb) - - IF (.not. iam_watb) then + + IF (.not. iam_lake) then + Ks_up = Ks_bsn (ibasin) + zwt_up = zwt_bsn (ibasin) theta_a_up = theta_a_bsn(ibasin) + zsubs_up = elementneighbour(ibasin)%myelva - zwt_up + area_up = sum(hrus%agwt) ELSE theta_a_up = 1. - ENDIF + zsubs_up = elementneighbour(ibasin)%myelva + wdsrf_bsn(ibasin) + area_up = elementneighbour(ibasin)%myarea + ENDIF - IF (.not. nb_is_watb) THEN + IF (.not. nb_is_lake) THEN + Ks_dn = Ks_nb(ibasin)%val(jnb) + zwt_dn = zwt_nb(ibasin)%val(jnb) theta_a_dn = theta_a_nb(ibasin)%val(jnb) + zsubs_dn = elementneighbour(ibasin)%elva(jnb) - zwt_dn + area_dn = agwt_nb(ibasin)%val(jnb) ELSE theta_a_dn = 1. + zsubs_dn = elementneighbour(ibasin)%elva(jnb) + wdsrf_nb(ibasin)%val(jnb) + area_dn = elementneighbour(ibasin)%area(jnb) ENDIF - IF (iam_watb) then - zsubs_up = basinneighbour(ibasin)%myelva + wdsrf_bsn(ibasin) - IF ((zsubs_up > zsubs_dn) .and. (wdsrf_bsn(ibasin) == 0.)) THEN - CYCLE - ENDIF - delp = basinneighbour(ibasin)%area(jnb) / basinneighbour(ibasin)%lenbdr(jnb) * 0.5 - ELSE - zsubs_up = basinneighbour(ibasin)%myelva - zwt_up - delp = basinneighbour(ibasin)%dist(jnb) - ENDIF + IF ((.not. iam_lake) .and. (area_up <= 0)) CYCLE + IF ((.not. nb_is_lake) .and. (area_dn <= 0)) CYCLE + IF ((Ks_up == 0.) .or. (Ks_dn == 0.)) CYCLE - IF (nb_is_watb) THEN - zsubs_dn = basinneighbour(ibasin)%elva(jnb) + wdsrf_nb(ibasin)%val(jnb) - IF ((zsubs_up < zsubs_dn) .and. (wdsrf_nb(ibasin)%val(jnb) == 0.)) THEN - CYCLE - ENDIF - delp = basinneighbour(ibasin)%myarea / basinneighbour(ibasin)%lenbdr(jnb) * 0.5 - ELSE - zsubs_dn = basinneighbour(ibasin)%elva(jnb) - zwt_dn - delp = basinneighbour(ibasin)%dist(jnb) - ENDIF - - area_up = basinneighbour(ibasin)%myarea - area_dn = basinneighbour(ibasin)%area(jnb) + ! water body is dry. + IF (iam_lake .and. (zsubs_up > zsubs_dn) .and. (wdsrf_bsn(ibasin) == 0.)) THEN + CYCLE + ENDIF + IF (nb_is_lake .and. (zsubs_up < zsubs_dn) .and. (wdsrf_nb(ibasin)%val(jnb) == 0.)) THEN + CYCLE + ENDIF + + lenbdr = elementneighbour(ibasin)%lenbdr(jnb) - lenbdr = basinneighbour(ibasin)%lenbdr(jnb) + delp = elementneighbour(ibasin)%dist(jnb) + IF (iam_lake) then + delp = elementneighbour(ibasin)%area(jnb) / lenbdr * 0.5 + ENDIF + IF (nb_is_lake) THEN + delp = elementneighbour(ibasin)%myarea / lenbdr * 0.5 + ENDIF ! from Fan et al., JGR 112(D10125) - slope = abs(basinneighbour(ibasin)%slope(jnb)) + slope = abs(elementneighbour(ibasin)%slope(jnb)) IF (slope > 0.16) THEN bdamp = 4.8 ELSE @@ -418,7 +501,7 @@ SUBROUTINE subsurface_flow (deltime) ENDIF ! Upstream scheme for hydraulic conductivity - IF (nb_is_watb .or. ((.not. iam_watb) .and. (zsubs_up > zsubs_dn))) THEN + IF (nb_is_lake .or. ((.not. iam_lake) .and. (zsubs_up > zsubs_dn))) THEN IF (zwt_up > 1.5) THEN ! from Fan et al., JGR 112(D10125) Ks_fc = raniso * Ks_up * bdamp * exp(-(zwt_up-1.5)/bdamp) @@ -436,41 +519,26 @@ SUBROUTINE subsurface_flow (deltime) ca = lenbdr * Ks_fc / theta_a_up / delp / area_up * deltime cb = lenbdr * Ks_fc / theta_a_dn / delp / area_dn * deltime - rsubs_nb = (zsubs_up - zsubs_dn) * lenbdr * Ks_fc / (1+ca+cb) / delp + xsubs_nb = (zsubs_up - zsubs_dn) * lenbdr * Ks_fc / (1+ca+cb) / delp - IF (.not. iam_watb) THEN - IF (hrus%indx(1) == 0) THEN - rsubs_nb = rsubs_nb / sum(hrus%area(2:)) - ELSE - rsubs_nb = rsubs_nb / basinneighbour(ibasin)%myarea - ENDIF + IF (.not. iam_lake) THEN + xsubs_nb = xsubs_nb / sum(hrus%agwt) ELSE - rsubs_nb = rsubs_nb / basinneighbour(ibasin)%myarea + xsubs_nb = xsubs_nb / elementneighbour(ibasin)%myarea ENDIF - rsubs_bsn(ibasin) = rsubs_bsn(ibasin) + rsubs_nb + xsubs_bsn(ibasin) = xsubs_bsn(ibasin) + xsubs_nb ENDDO - IF (iam_watb) THEN - ps = elm_patch%substt(ibasin) - pe = elm_patch%subend(ibasin) - ! Update total subsurface lateral flow (3): Between basins - rsub(ps:pe) = rsub(ps:pe) + rsubs_bsn(ibasin) * 1.e3 ! m/s to mm/s - ELSE - IF (hrus%indx(1) == 0) THEN - i0 = 2 ! excluding river HRU - ELSE - i0 = 1 + ! Update total subsurface lateral flow (3): Between basins + ps = elm_patch%substt(ibasin) + pe = elm_patch%subend(ibasin) + DO ipatch = ps, pe + IF (iam_lake .or. (patchtype(ipatch) <= 2)) THEN + xwsub(ipatch) = xwsub(ipatch) + xsubs_bsn(ibasin) * 1.e3 ! m/s to mm/s ENDIF - - DO i = i0, hrus%nhru - ps = hru_patch%substt(hrus%ihru(i)) - pe = hru_patch%subend(hrus%ihru(i)) - ! Update total subsurface lateral flow (3): Between basins - rsub(ps:pe) = rsub(ps:pe) + rsubs_bsn(ibasin) * 1.e3 ! m/s to mm/s - ENDDO - ENDIF + ENDDO ENDDO @@ -489,14 +557,15 @@ SUBROUTINE subsurface_flow (deltime) DO ipatch = 1, numpatch - IF (patchtype(ipatch) <= 2) THEN #if(defined CoLMDEBUG) - ! For water balance check, the sum of water in soil column before the calcultion - w_sum_before = sum(wliq_soisno(1:nl_soil,ipatch)) + sum(wice_soisno(1:nl_soil,ipatch)) & - + wa(ipatch) + wdsrf(ipatch) + ! For water balance check, the sum of water in soil column before the calcultion + w_sum_before = sum(wliq_soisno(1:nl_soil,ipatch)) + sum(wice_soisno(1:nl_soil,ipatch)) & + + wa(ipatch) + wdsrf(ipatch) + wetwat(ipatch) #endif - exwater = rsub(ipatch) * deltime + IF (patchtype(ipatch) <= 1) THEN + + exwater = xwsub(ipatch) * deltime #ifdef Campbell_SOIL_MODEL vl_r(1:nl_soil) = 0._r8 @@ -521,14 +590,25 @@ SUBROUTINE subsurface_flow (deltime) vol_liq(ilev) = wliq_soisno(ilev,ipatch)/denh2o*1000. / sp_dz(ilev) vol_liq(ilev) = min(eff_porosity(ilev), max(0., vol_liq(ilev))) wresi(ilev) = wliq_soisno(ilev,ipatch) - sp_dz(ilev)*vol_liq(ilev)/1000. * denh2o + ELSE + vol_liq(ilev) = eff_porosity(ilev) + wresi(ilev) = 0. ENDIF ENDDO - + zwtmm = zwt(ipatch) * 1000. ! m -> mm - izwt = findloc(zwtmm >= sp_zi, .true., dim=1, back=.true.) + + ! check consistancy between water table location and liquid water content + DO ilev = 1, nl_soil + IF ((vol_liq(ilev) < eff_porosity(ilev)-1.e-8) .and. (zwtmm <= sp_zi(ilev-1))) THEN + zwtmm = sp_zi(ilev) + ENDIF + ENDDO + + izwt = findloc(zwtmm >= sp_zi, .true., dim=1, back=.true.) IF (izwt <= nl_soil) THEN - IF (is_permeable(izwt)) THEN + IF (is_permeable(izwt) .and. (zwtmm > sp_zi(izwt-1))) THEN vol_liq(izwt) = (wliq_soisno(izwt,ipatch)/denh2o*1000.0 & - eff_porosity(izwt)*(sp_zi(izwt)-zwtmm)) / (zwtmm - sp_zi(izwt-1)) @@ -544,10 +624,10 @@ SUBROUTINE subsurface_flow (deltime) ENDIF CALL soilwater_aquifer_exchange ( & - nl_soil, exwater, sp_zi, is_permeable, porsl(:,ipatch), vl_r, psi0(:,ipatch), & - hksati(:,ipatch), nprms, prms, porsl(nl_soil,ipatch), wdsrf(ipatch), & + nl_soil, exwater, sp_zi, is_permeable, eff_porosity, vl_r, psi0(:,ipatch), & + hksati(:,ipatch), nprms, prms, porsl(nl_soil,ipatch), wdsrf(ipatch), & vol_liq, zwtmm, wa(ipatch), izwt) - + ! update the mass of liquid water DO ilev = nl_soil, 1, -1 IF (is_permeable(ilev)) THEN @@ -568,36 +648,67 @@ SUBROUTINE subsurface_flow (deltime) zwt(ipatch) = zwtmm/1000.0 -#if(defined CoLMDEBUG) - ! For water balance check, the sum of water in soil column after the calcultion - w_sum_after = sum(wliq_soisno(1:nl_soil,ipatch)) + sum(wice_soisno(1:nl_soil,ipatch)) & - + wa(ipatch) + wdsrf(ipatch) - errblc = w_sum_after - w_sum_before + exwater - - if(abs(errblc) > 1.e-3)then - write(6,'(A,E20.5)') 'Warning (Subsurface Runoff): water balance violation', errblc - endif -#endif + ELSEIF (patchtype(ipatch) == 2) THEN ! wetland + + wetwat(ipatch) = wdsrf(ipatch) + wa(ipatch) + wetwat(ipatch) - xwsub(ipatch)*deltime + + IF (wetwat(ipatch) > wetwatmax) THEN + wdsrf (ipatch) = wetwat(ipatch) - wetwatmax + wetwat(ipatch) = wetwatmax + wa (ipatch) = 0. + ELSEIF (wetwat(ipatch) < 0) THEN + wa (ipatch) = wetwat(ipatch) + wdsrf (ipatch) = 0. + wetwat(ipatch) = 0. + ELSE + wdsrf(ipatch) = 0. + wa (ipatch) = 0. + ENDIF + ELSEIF (patchtype(ipatch) == 4) THEN ! land water bodies - IF (wa(ipatch) < 0) THEN - wa(ipatch) = wa(ipatch) - rsub(ipatch)*deltime - IF (wa(ipatch) > 0) THEN - wdsrf(ipatch) = wa(ipatch) - wa(ipatch) = 0 - ENDIF + + wdsrf(ipatch) = wa(ipatch) + wdsrf(ipatch) - xwsub(ipatch)*deltime + + IF (wdsrf(ipatch) < 0) THEN + wa (ipatch) = wdsrf(ipatch) + wdsrf(ipatch) = 0 ELSE - wdsrf(ipatch) = wdsrf(ipatch) - rsub(ipatch)*deltime - IF (wdsrf(ipatch) < 0) THEN - wa(ipatch) = wdsrf(ipatch) - wdsrf(ipatch) = 0 - ENDIF + wa(ipatch) = 0 ENDIF + ENDIF +#if(defined CoLMDEBUG) + ! For water balance check, the sum of water in soil column after the calcultion + w_sum_after = sum(wliq_soisno(1:nl_soil,ipatch)) + sum(wice_soisno(1:nl_soil,ipatch)) & + + wa(ipatch) + wdsrf(ipatch) + wetwat(ipatch) + errblc = w_sum_after - w_sum_before + xwsub(ipatch)*deltime + + if(abs(errblc) > 1.e-3)then + write(6,'(A,I0,4E20.5)') 'Warning (Subsurface Runoff): water balance violation ', & + ipatch, errblc, xwsub(ipatch), zwtmm + write(*,*) patchtype(ipatch) + CALL CoLM_stop () + endif +#endif ENDDO ENDIF END SUBROUTINE subsurface_flow -END MODULE MOD_Hydro_SubsurfaceFlow + ! ---------- + SUBROUTINE basin_neighbour_final () + + IMPLICIT NONE + + IF (allocated(theta_a_nb)) deallocate(theta_a_nb) + IF (allocated(zwt_nb )) deallocate(zwt_nb ) + IF (allocated(Ks_nb )) deallocate(Ks_nb ) + IF (allocated(wdsrf_nb )) deallocate(wdsrf_nb ) + IF (allocated(agwt_nb )) deallocate(agwt_nb ) + IF (allocated(islake_nb )) deallocate(islake_nb ) + + END SUBROUTINE basin_neighbour_final + +END MODULE MOD_Catch_SubsurfaceFlow #endif diff --git a/main/HYDRO/MOD_ElementNeighbour.F90 b/main/HYDRO/MOD_ElementNeighbour.F90 new file mode 100644 index 00000000..dbf83684 --- /dev/null +++ b/main/HYDRO/MOD_ElementNeighbour.F90 @@ -0,0 +1,715 @@ +#include + +MODULE MOD_ElementNeighbour + !--------------------------------------------------------------------------------! + ! DESCRIPTION: ! + ! ! + ! Element Neighbours : data and communication subroutines. ! + ! ! + ! Created by Shupeng Zhang, May 2023 ! + !--------------------------------------------------------------------------------! + + USE MOD_Precision + USE MOD_DataType + IMPLICIT NONE + + ! -- neighbour parameters -- + type element_neighbour_type + + integer :: nnb ! number of neighbours + real(r8) :: myarea ! area of this element [m^2] + real(r8) :: myelva ! elevation of this element [m] + + integer*8, allocatable :: glbindex (:) ! neighbour global index + + ! data address: (1,:) refers to process, (2,:) refers to location + integer , allocatable :: addr (:,:) + + real(r8), allocatable :: dist (:) ! distance between element centers [m] + real(r8), allocatable :: lenbdr (:) ! length of boundary line [m] + real(r8), allocatable :: area (:) ! area of neighbours [m^2] + real(r8), allocatable :: elva (:) ! elevation of neighbours [m] + real(r8), allocatable :: slope (:) ! slope (positive) [-] + + END type element_neighbour_type + + type(element_neighbour_type), allocatable :: elementneighbour (:) + + ! -- neighbour communication -- + TYPE neighbour_sendrecv_type + INTEGER :: ndata + INTEGER*8, allocatable :: glbindex (:) + INTEGER, allocatable :: ielement (:) + END TYPE neighbour_sendrecv_type + + TYPE(neighbour_sendrecv_type), allocatable :: recvaddr(:) + TYPE(neighbour_sendrecv_type), allocatable :: sendaddr(:) + + interface allocate_neighbour_data + MODULE procedure allocate_neighbour_data_real8 + MODULE procedure allocate_neighbour_data_logic + END interface allocate_neighbour_data + +CONTAINS + + ! ---------- + SUBROUTINE element_neighbour_init (lc_year) + + USE MOD_SPMD_Task + USE MOD_Namelist + USE MOD_NetCDFSerial + USE MOD_NetCDFVector + USE MOD_Mesh + USE MOD_Pixel + USE MOD_LandElm + USE MOD_LandPatch + USE MOD_Utils + IMPLICIT NONE + + INTEGER, intent(in) :: lc_year ! which year of land cover data used + + ! Local Variables + CHARACTER(len=256) :: neighbour_file + + INTEGER :: ielm + INTEGER :: iwork, mesg(2), isrc, idest + INTEGER :: nrecv, irecv + INTEGER :: iloc, iloc1, iloc2 + INTEGER :: nnb, nnbinq, inb, ndata + + INTEGER :: maxnnb + INTEGER , allocatable :: nnball (:) + INTEGER , allocatable :: idxnball (:,:) + REAL(r8), allocatable :: lenbdall (:,:) + + INTEGER , allocatable :: addrelement(:) + + INTEGER*8, allocatable :: eindex (:) + INTEGER, allocatable :: icache1 (:) + INTEGER, allocatable :: icache2 (:,:) + REAL(r8), allocatable :: rcache2 (:,:) + + INTEGER*8, allocatable :: elm_sorted (:) + INTEGER, allocatable :: order (:) + INTEGER*8, allocatable :: idxinq (:) + INTEGER, allocatable :: addrinq (:) + + LOGICAL, allocatable :: mask(:) + + REAL(r8), allocatable :: rlon_b(:), rlat_b(:) + TYPE(pointer_real8_1d), allocatable :: rlon_nb(:), rlat_nb(:) + + REAL(r8), allocatable :: area_b(:) + REAL(r8), allocatable :: elva_b(:) + + character(len=256) :: lndname, cyear + REAL(r8), allocatable :: topo_patches(:) + + TYPE(pointer_real8_1d), allocatable :: area_nb (:) ! m^2 + TYPE(pointer_real8_1d), allocatable :: elva_nb (:) ! m + + integer :: ipxl, istt, iend + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + neighbour_file = DEF_ElementNeighbour_file + + IF (p_is_master) THEN + CALL ncio_read_serial (neighbour_file, 'num_neighbour', nnball ) + CALL ncio_read_serial (neighbour_file, 'idx_neighbour', idxnball) + CALL ncio_read_serial (neighbour_file, 'len_border' , lenbdall) + + maxnnb = size(idxnball,1) + + lenbdall = lenbdall * 1.e3 ! km to m + ENDIF + +#ifdef USEMPI + + CALL mpi_bcast (maxnnb, 1, MPI_INTEGER, p_root, p_comm_glb, p_err) + + IF (p_is_master) THEN + + allocate (addrelement (size(nnball))) + addrelement(:) = -1 + + DO iwork = 0, p_np_worker-1 + + CALL mpi_recv (mesg(1:2), 2, MPI_INTEGER, & + MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err) + isrc = mesg(1) + nrecv = mesg(2) + + IF (nrecv > 0) THEN + + allocate (eindex (nrecv)) + allocate (icache1 (nrecv)) + allocate (icache2 (maxnnb,nrecv)) + allocate (rcache2 (maxnnb,nrecv)) + + CALL mpi_recv (eindex, nrecv, MPI_INTEGER8, & + isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) + + addrelement(eindex) = isrc + + idest = isrc + + icache1 = nnball(eindex) + CALL mpi_send (icache1, nrecv, MPI_INTEGER, & + idest, mpi_tag_data, p_comm_glb, p_err) + + DO irecv = 1, nrecv + icache2(:,irecv) = idxnball(:,eindex(irecv)) + ENDDO + CALL mpi_send (icache2, maxnnb*nrecv, MPI_INTEGER, & + idest, mpi_tag_data, p_comm_glb, p_err) + + DO irecv = 1, nrecv + rcache2(:,irecv) = lenbdall(:,eindex(irecv)) + ENDDO + CALL mpi_send (rcache2, maxnnb*nrecv, MPI_REAL8, & + idest, mpi_tag_data, p_comm_glb, p_err) + + deallocate (eindex ) + deallocate (icache1) + deallocate (icache2) + deallocate (rcache2) + + ENDIF + ENDDO + ENDIF +#endif + + IF (p_is_worker) THEN + + IF (numelm > 0) THEN + allocate (eindex (numelm)) + eindex = landelm%eindex + ENDIF + +#ifdef USEMPI + mesg(1:2) = (/p_iam_glb, numelm/) + CALL mpi_send (mesg(1:2), 2, MPI_INTEGER, p_root, mpi_tag_mesg, p_comm_glb, p_err) + + IF (numelm > 0) THEN + CALL mpi_send (eindex, numelm, MPI_INTEGER8, & + p_root, mpi_tag_data, p_comm_glb, p_err) + + allocate (nnball (numelm)) + CALL mpi_recv (nnball, numelm, MPI_INTEGER, & + p_root, mpi_tag_data, p_comm_glb, p_stat, p_err) + + allocate (idxnball (maxnnb,numelm)) + CALL mpi_recv (idxnball, maxnnb*numelm, MPI_INTEGER, & + p_root, mpi_tag_data, p_comm_glb, p_stat, p_err) + + allocate (lenbdall (maxnnb,numelm)) + CALL mpi_recv (lenbdall, maxnnb*numelm, MPI_REAL8, & + p_root, mpi_tag_data, p_comm_glb, p_stat, p_err) + ENDIF +#else + allocate (icache1 (numelm)) + allocate (icache2 (maxnnb,numelm)) + allocate (rcache2 (maxnnb,numelm)) + + icache1 = nnball + icache2 = idxnball + rcache2 = lenbdall + + DO ielm = 1, numelm + nnball (ielm) = icache1 (eindex(ielm)) + idxnball (:,ielm) = icache2 (:,eindex(ielm)) + lenbdall (:,ielm) = rcache2 (:,eindex(ielm)) + ENDDO + + deallocate (icache1, icache2, rcache2) +#endif + + IF (numelm > 0) THEN + + allocate (elementneighbour (numelm)) + + DO ielm = 1, numelm + nnb = nnball(ielm) + elementneighbour(ielm)%nnb = nnb + + IF (nnb > 0) THEN + allocate (elementneighbour(ielm)%glbindex (nnb)) + allocate (elementneighbour(ielm)%lenbdr (nnb)) + allocate (elementneighbour(ielm)%addr (2,nnb)) + + elementneighbour(ielm)%glbindex = idxnball(1:nnb,ielm) + elementneighbour(ielm)%lenbdr = lenbdall(1:nnb,ielm) + elementneighbour(ielm)%addr(1,:) = -9999 + ENDIF + ENDDO + ENDIF + + ENDIF + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + +#ifdef USEMPI + IF (p_is_master) THEN + DO iwork = 0, p_np_worker-1 + + CALL mpi_recv (mesg(1:2), 2, MPI_INTEGER, & + MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err) + isrc = mesg(1) + nrecv = mesg(2) + + IF (nrecv > 0) THEN + allocate (eindex (nrecv)) + allocate (icache1 (nrecv)) + + CALL mpi_recv (eindex, nrecv, MPI_INTEGER8, & + isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) + + icache1 = addrelement(eindex) + + idest = isrc + CALL mpi_send (icache1, nrecv, MPI_INTEGER, & + idest, mpi_tag_data, p_comm_glb, p_err) + + deallocate(eindex, icache1) + ENDIF + ENDDO + ENDIF +#endif + + IF (p_is_worker) THEN + + IF (numelm > 0) THEN + allocate (elm_sorted (numelm)) + allocate (order (numelm)) + + elm_sorted = eindex + order = (/(ielm, ielm = 1, numelm)/) + + CALL quicksort (numelm, elm_sorted, order) + +#ifdef USEMPI + allocate(idxinq (numelm*maxnnb)) +#endif + + nnbinq = 0 + DO ielm = 1, numelm + DO inb = 1, elementneighbour(ielm)%nnb + + IF (elementneighbour(ielm)%glbindex(inb) <= 0) CYCLE ! skip ocean neighbour + + iloc = find_in_sorted_list1 (elementneighbour(ielm)%glbindex(inb), numelm, elm_sorted) + IF (iloc > 0) THEN + elementneighbour(ielm)%addr(1,inb) = -1 + elementneighbour(ielm)%addr(2,inb) = order(iloc) +#ifdef USEMPI + ELSE + CALL insert_into_sorted_list1 (elementneighbour(ielm)%glbindex(inb), nnbinq, idxinq, iloc) +#endif + ENDIF + ENDDO + ENDDO + ELSE + nnbinq = 0 + ENDIF + +#ifdef USEMPI + mesg(1:2) = (/p_iam_glb, nnbinq/) + CALL mpi_send (mesg(1:2), 2, MPI_INTEGER, p_root, mpi_tag_mesg, p_comm_glb, p_err) + + IF (nnbinq > 0) THEN + + CALL mpi_send (idxinq(1:nnbinq), nnbinq, MPI_INTEGER8, & + p_root, mpi_tag_data, p_comm_glb, p_err) + + allocate (addrinq (nnbinq)) + CALL mpi_recv (addrinq, nnbinq, MPI_INTEGER, & + p_root, mpi_tag_data, p_comm_glb, p_stat, p_err) + + ENDIF + + IF (nnbinq > 0) allocate(mask (nnbinq)) + + allocate (recvaddr (0:p_np_worker-1)) + DO iwork = 0, p_np_worker-1 + IF (nnbinq > 0) THEN + mask = (addrinq == p_address_worker(iwork)) + ndata = count(mask) + ELSE + ndata = 0 + ENDIF + + recvaddr(iwork)%ndata = ndata + IF (ndata > 0) THEN + allocate (recvaddr(iwork)%glbindex (ndata)) + recvaddr(iwork)%glbindex = pack(idxinq(1:nnbinq), mask) + ENDIF + ENDDO + + IF (nnbinq > 0) deallocate(mask) + + DO ielm = 1, numelm + DO inb = 1, elementneighbour(ielm)%nnb + IF ((elementneighbour(ielm)%addr(1,inb) == -9999) & + .and. (elementneighbour(ielm)%glbindex(inb) > 0)) THEN ! skip ocean neighbour + + iloc = find_in_sorted_list1 (elementneighbour(ielm)%glbindex(inb), & + nnbinq, idxinq(1:nnbinq)) + + iwork = p_itis_worker(addrinq(iloc)) + iloc1 = find_in_sorted_list1 (elementneighbour(ielm)%glbindex(inb), & + recvaddr(iwork)%ndata, recvaddr(iwork)%glbindex) + + elementneighbour(ielm)%addr(1,inb) = iwork + elementneighbour(ielm)%addr(2,inb) = iloc1 + ENDIF + ENDDO + ENDDO + + allocate (sendaddr (0:p_np_worker-1)) + DO iwork = 0, p_np_worker-1 + sendaddr(iwork)%ndata = 0 + ENDDO + + DO ielm = 1, numelm + DO inb = 1, elementneighbour(ielm)%nnb + IF (elementneighbour(ielm)%addr(1,inb) >= 0) THEN + iwork = elementneighbour(ielm)%addr(1,inb) + sendaddr(iwork)%ndata = sendaddr(iwork)%ndata + 1 + ENDIF + ENDDO + ENDDO + + DO iwork = 0, p_np_worker-1 + IF (sendaddr(iwork)%ndata > 0) THEN + allocate (sendaddr(iwork)%glbindex (sendaddr(iwork)%ndata)) + sendaddr(iwork)%ndata = 0 + ENDIF + ENDDO + + DO ielm = 1, numelm + DO inb = 1, elementneighbour(ielm)%nnb + IF (elementneighbour(ielm)%addr(1,inb) >= 0) THEN + iwork = elementneighbour(ielm)%addr(1,inb) + CALL insert_into_sorted_list1 (eindex(ielm), & + sendaddr(iwork)%ndata, sendaddr(iwork)%glbindex, iloc) + ENDIF + ENDDO + ENDDO + + DO iwork = 0, p_np_worker-1 + IF (sendaddr(iwork)%ndata > 0) THEN + IF (sendaddr(iwork)%ndata < size(sendaddr(iwork)%glbindex)) THEN + allocate (icache1 (sendaddr(iwork)%ndata)) + icache1 = sendaddr(iwork)%glbindex(1:sendaddr(iwork)%ndata) + + deallocate (sendaddr(iwork)%glbindex) + allocate (sendaddr(iwork)%glbindex (sendaddr(iwork)%ndata)) + sendaddr(iwork)%glbindex = icache1 + + deallocate (icache1) + ENDIF + ENDIF + ENDDO + + DO iwork = 0, p_np_worker-1 + IF (sendaddr(iwork)%ndata > 0) THEN + allocate (sendaddr(iwork)%ielement (sendaddr(iwork)%ndata)) + + DO inb = 1, sendaddr(iwork)%ndata + iloc = find_in_sorted_list1 (sendaddr(iwork)%glbindex(inb), numelm, elm_sorted) + sendaddr(iwork)%ielement(inb) = order(iloc) + ENDDO + ENDIF + ENDDO +#endif + ENDIF + + IF (allocated(addrelement)) deallocate(addrelement) + IF (allocated(elm_sorted )) deallocate(elm_sorted ) + IF (allocated(nnball )) deallocate(nnball ) + IF (allocated(idxnball )) deallocate(idxnball ) + IF (allocated(lenbdall )) deallocate(lenbdall ) + IF (allocated(eindex )) deallocate(eindex ) + IF (allocated(icache1 )) deallocate(icache1 ) + IF (allocated(icache2 )) deallocate(icache2 ) + IF (allocated(rcache2 )) deallocate(rcache2 ) + IF (allocated(order )) deallocate(order ) + IF (allocated(idxinq )) deallocate(idxinq ) + IF (allocated(addrinq )) deallocate(addrinq ) + IF (allocated(mask )) deallocate(mask ) + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + write(cyear,'(i4.4)') lc_year + lndname = trim(DEF_dir_landdata) // '/topography/'//trim(cyear)//'/topography_patches.nc' + call ncio_read_vector (lndname, 'topography_patches', landpatch, topo_patches) + + IF (p_is_worker) THEN + + DO ielm = 1, numelm + nnb = elementneighbour(ielm)%nnb + IF (nnb > 0) THEN + allocate (elementneighbour(ielm)%dist (nnb)) + allocate (elementneighbour(ielm)%area (nnb)) + allocate (elementneighbour(ielm)%elva (nnb)) + allocate (elementneighbour(ielm)%slope (nnb)) + ENDIF + ENDDO + + IF (numelm > 0) THEN + allocate (rlon_b(numelm)) + allocate (rlat_b(numelm)) + CALL landelm%get_lonlat_radian (rlon_b, rlat_b) + ENDIF + + CALL allocate_neighbour_data (rlon_nb) + CALL allocate_neighbour_data (rlat_nb) + + CALL retrieve_neighbour_data (rlon_b, rlon_nb) + CALL retrieve_neighbour_data (rlat_b, rlat_nb) + + DO ielm = 1, numelm + DO inb = 1, elementneighbour(ielm)%nnb + IF (elementneighbour(ielm)%glbindex(inb) > 0) THEN ! skip ocean neighbour + elementneighbour(ielm)%dist(inb) = 1.0e3 * arclen ( & + rlat_b (ielm), rlon_b (ielm), & + rlat_nb(ielm)%val(inb), rlon_nb(ielm)%val(inb)) + ENDIF + ENDDO + ENDDO + + IF (numelm > 0) THEN + allocate (area_b(numelm)) + allocate (elva_b(numelm)) + DO ielm = 1, numelm + area_b(ielm) = 0 + DO ipxl = 1, mesh(ielm)%npxl + area_b(ielm) = area_b(ielm) + 1.0e6 * areaquad ( & + pixel%lat_s(mesh(ielm)%ilat(ipxl)), pixel%lat_n(mesh(ielm)%ilat(ipxl)), & + pixel%lon_w(mesh(ielm)%ilon(ipxl)), pixel%lon_e(mesh(ielm)%ilon(ipxl)) ) + ENDDO + + istt = elm_patch%substt(ielm) + iend = elm_patch%subend(ielm) + elva_b(ielm) = sum(topo_patches(istt:iend) * elm_patch%subfrc(istt:iend)) + + elementneighbour(ielm)%myarea = area_b(ielm) + elementneighbour(ielm)%myelva = elva_b(ielm) + ENDDO + ENDIF + + CALL allocate_neighbour_data (area_nb) + CALL retrieve_neighbour_data (area_b, area_nb) + + CALL allocate_neighbour_data (elva_nb) + CALL retrieve_neighbour_data (elva_b, elva_nb) + + DO ielm = 1, numelm + DO inb = 1, elementneighbour(ielm)%nnb + IF (elementneighbour(ielm)%glbindex(inb) > 0) THEN ! skip ocean neighbour + elementneighbour(ielm)%area (inb) = area_nb(ielm)%val(inb) + elementneighbour(ielm)%elva (inb) = elva_nb(ielm)%val(inb) + elementneighbour(ielm)%slope(inb) = & + abs(elva_nb(ielm)%val(inb) - elva_b(ielm)) / elementneighbour(ielm)%dist(inb) + ENDIF + ENDDO + ENDDO + + IF (allocated(rlon_b )) deallocate(rlon_b ) + IF (allocated(rlat_b )) deallocate(rlat_b ) + IF (allocated(elva_b )) deallocate(elva_b ) + IF (allocated(area_b )) deallocate(area_b ) + IF (allocated(rlon_nb)) deallocate(rlon_nb) + IF (allocated(rlat_nb)) deallocate(rlat_nb) + IF (allocated(area_nb)) deallocate(area_nb) + IF (allocated(elva_nb)) deallocate(elva_nb) + + ENDIF + + END SUBROUTINE element_neighbour_init + + ! ---------- + SUBROUTINE retrieve_neighbour_data (vec_in, nbdata) + + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_Mesh, only : numelm + IMPLICIT NONE + + REAL(r8), intent(inout) :: vec_in (:) + TYPE(pointer_real8_1d) :: nbdata (:) + + ! Local Variables + LOGICAL, allocatable :: smask(:), rmask(:) + INTEGER, allocatable :: req_send(:), req_recv(:) + TYPE(pointer_real8_1d), allocatable :: sbuff(:), rbuff(:) + INTEGER :: iwork, ielm, inb, iloc + + IF (p_is_worker) THEN + + DO ielm = 1, numelm + DO inb = 1, elementneighbour(ielm)%nnb + IF (elementneighbour(ielm)%addr(1,inb)== -1) THEN + iloc = elementneighbour(ielm)%addr(2,inb) + nbdata(ielm)%val(inb) = vec_in(iloc) + ENDIF + ENDDO + ENDDO + +#ifdef USEMPI + CALL mpi_barrier (p_comm_worker, p_err) + + allocate (smask (0:p_np_worker-1)) + allocate (req_send (0:p_np_worker-1)) + allocate (sbuff (0:p_np_worker-1)) + smask(:) = .false. + + DO iwork = 0, p_np_worker-1 + IF (sendaddr(iwork)%ndata > 0) THEN + smask(iwork) = .true. + + allocate (sbuff(iwork)%val (sendaddr(iwork)%ndata)) + sbuff(iwork)%val = vec_in(sendaddr(iwork)%ielement) + + CALL mpi_isend(sbuff(iwork)%val, sendaddr(iwork)%ndata, MPI_REAL8, & + p_address_worker(iwork), 101, p_comm_glb, req_send(iwork), p_err) + ENDIF + ENDDO + + allocate (rmask (0:p_np_worker-1)) + allocate (req_recv (0:p_np_worker-1)) + allocate (rbuff (0:p_np_worker-1)) + rmask(:) = .false. + + DO iwork = 0, p_np_worker-1 + IF (recvaddr(iwork)%ndata > 0) THEN + rmask(iwork) = .true. + + allocate (rbuff(iwork)%val (recvaddr(iwork)%ndata)) + + CALL mpi_irecv(rbuff(iwork)%val, recvaddr(iwork)%ndata, MPI_REAL8, & + p_address_worker(iwork), 101, p_comm_glb, req_recv(iwork), p_err) + ENDIF + ENDDO + + IF (any(rmask)) THEN + + CALL mpi_waitall(count(rmask), pack(req_recv,rmask), MPI_STATUSES_IGNORE, p_err) + + DO ielm = 1, numelm + DO inb = 1, elementneighbour(ielm)%nnb + IF (elementneighbour(ielm)%addr(1,inb) >= 0) THEN + iwork = elementneighbour(ielm)%addr(1,inb) + iloc = elementneighbour(ielm)%addr(2,inb) + nbdata(ielm)%val(inb) = rbuff(iwork)%val(iloc) + ENDIF + ENDDO + ENDDO + ENDIF + + IF (any(smask)) THEN + CALL mpi_waitall(count(smask), pack(req_send,smask), MPI_STATUSES_IGNORE, p_err) + ENDIF + + IF (allocated(smask)) deallocate(smask) + IF (allocated(rmask)) deallocate(rmask) + + IF (allocated(req_send)) deallocate(req_send) + IF (allocated(req_recv)) deallocate(req_recv) + + IF (allocated(sbuff)) deallocate(sbuff) + IF (allocated(rbuff)) deallocate(rbuff) + + CALL mpi_barrier (p_comm_worker, p_err) +#endif + + ENDIF + + END SUBROUTINE retrieve_neighbour_data + + ! --- + SUBROUTINE allocate_neighbour_data_real8 (nbdata) + + USE MOD_Mesh, only : numelm + IMPLICIT NONE + + TYPE(pointer_real8_1d), allocatable :: nbdata(:) + INTEGER :: ielm + + IF (numelm > 0) THEN + allocate (nbdata(numelm)) + DO ielm = 1, numelm + IF (elementneighbour(ielm)%nnb > 0) THEN + allocate (nbdata(ielm)%val (elementneighbour(ielm)%nnb)) + ENDIF + ENDDO + ENDIF + + END SUBROUTINE allocate_neighbour_data_real8 + + ! --- + SUBROUTINE allocate_neighbour_data_logic (nbdata) + + USE MOD_Mesh, only : numelm + IMPLICIT NONE + + TYPE(pointer_logic_1d), allocatable :: nbdata(:) + INTEGER :: ielm + + IF (numelm > 0) THEN + allocate (nbdata(numelm)) + DO ielm = 1, numelm + IF (elementneighbour(ielm)%nnb > 0) THEN + allocate (nbdata(ielm)%val (elementneighbour(ielm)%nnb)) + ENDIF + ENDDO + ENDIF + + END SUBROUTINE allocate_neighbour_data_logic + + ! ---------- + SUBROUTINE element_neighbour_final () + + IMPLICIT NONE + INTEGER :: i + + IF (allocated(elementneighbour)) THEN + DO i = 1, size(elementneighbour) + IF (allocated(elementneighbour(i)%glbindex)) deallocate(elementneighbour(i)%glbindex) + IF (allocated(elementneighbour(i)%addr )) deallocate(elementneighbour(i)%addr ) + IF (allocated(elementneighbour(i)%dist )) deallocate(elementneighbour(i)%dist ) + IF (allocated(elementneighbour(i)%lenbdr)) deallocate(elementneighbour(i)%lenbdr) + IF (allocated(elementneighbour(i)%area )) deallocate(elementneighbour(i)%area ) + IF (allocated(elementneighbour(i)%elva )) deallocate(elementneighbour(i)%elva ) + IF (allocated(elementneighbour(i)%slope )) deallocate(elementneighbour(i)%slope ) + ENDDO + deallocate(elementneighbour) + ENDIF + + IF (allocated(recvaddr)) THEN + DO i = lbound(recvaddr,1), ubound(recvaddr,1) + IF (allocated(recvaddr(i)%glbindex)) deallocate(recvaddr(i)%glbindex) + IF (allocated(recvaddr(i)%ielement)) deallocate(recvaddr(i)%ielement) + ENDDO + ENDIF + + IF (allocated(sendaddr)) THEN + DO i = lbound(sendaddr,1), ubound(sendaddr,1) + IF (allocated(sendaddr(i)%glbindex)) deallocate(sendaddr(i)%glbindex) + IF (allocated(sendaddr(i)%ielement)) deallocate(sendaddr(i)%ielement) + ENDDO + ENDIF + + IF (allocated(recvaddr)) deallocate(recvaddr) + IF (allocated(sendaddr)) deallocate(sendaddr) + + END SUBROUTINE element_neighbour_final + +END MODULE MOD_ElementNeighbour diff --git a/main/HYDRO/MOD_Hydro_BasinNeighbour.F90 b/main/HYDRO/MOD_Hydro_BasinNeighbour.F90 deleted file mode 100644 index a995fd8c..00000000 --- a/main/HYDRO/MOD_Hydro_BasinNeighbour.F90 +++ /dev/null @@ -1,750 +0,0 @@ -#include - -#ifdef LATERAL_FLOW -MODULE MOD_Hydro_BasinNeighbour - !--------------------------------------------------------------------------------! - ! DESCRIPTION: ! - ! ! - ! Basin Neighbours : data and communication subroutines. ! - ! ! - ! Created by Shupeng Zhang, May 2023 ! - !--------------------------------------------------------------------------------! - - USE MOD_Precision - USE MOD_DataType - IMPLICIT NONE - - ! -- neighbour parameters -- - type basin_neighbour_type - integer :: nnb ! number of neighbours - real(r8) :: myarea ! area of this basin [m^2] - real(r8) :: myelva ! elevation of this basin [m] - integer , allocatable :: bindex (:) ! neighbour global index - integer , allocatable :: addr (:,:) ! data address: (1,:) refers to process, (2,:) refers to location - real(r8), allocatable :: dist (:) ! distance between basin centers [m] - real(r8), allocatable :: lenbdr (:) ! length of boundary line [m] - real(r8), allocatable :: area (:) ! area of neighbours [m^2] - real(r8), allocatable :: elva (:) ! elevation of neighbours [m] - real(r8), allocatable :: slope (:) ! slope (positive) [-] - logical , allocatable :: iswatb (:) ! whether a neighbour is water body - END type basin_neighbour_type - - type(basin_neighbour_type), allocatable :: basinneighbour (:) - - ! -- neighbour variables -- - TYPE(pointer_real8_1d), allocatable :: theta_a_nb (:) ! saturated volume content [-] - TYPE(pointer_real8_1d), allocatable :: zwt_nb (:) ! water table depth [m] - TYPE(pointer_real8_1d), allocatable :: Ks_nb (:) ! saturated hydraulic conductivity [m/s] - TYPE(pointer_real8_1d), allocatable :: wdsrf_nb (:) ! depth of surface water [m] - - ! -- neighbour communication -- - TYPE neighbour_sendrecv_type - INTEGER :: ndata - INTEGER, allocatable :: bindex (:) - INTEGER, allocatable :: ibasin (:) - END TYPE neighbour_sendrecv_type - - TYPE(neighbour_sendrecv_type), allocatable :: recvaddr(:) - TYPE(neighbour_sendrecv_type), allocatable :: sendaddr(:) - -CONTAINS - - ! ---------- - SUBROUTINE basin_neighbour_init () - - USE MOD_SPMD_Task - USE MOD_Namelist - USE MOD_NetCDFSerial - USE MOD_Mesh - USE MOD_LandElm - USE MOD_Hydro_HillslopeNetwork - USE MOD_Hydro_RiverLakeNetwork - USE MOD_Utils - IMPLICIT NONE - - ! Local Variables - CHARACTER(len=256) :: neighbour_file - - INTEGER :: numbasin, ibasin - INTEGER :: iwork, mesg(2), isrc, idest - INTEGER :: nrecv, irecv - INTEGER :: iloc, iloc1, iloc2 - INTEGER :: nnb, nnbinq, inb, ndata - - INTEGER :: maxnnb - INTEGER , allocatable :: nnball (:) - INTEGER , allocatable :: idxnball (:,:) - REAL(r8), allocatable :: lenbdall (:,:) - - INTEGER , allocatable :: addrbasin(:) - - INTEGER , allocatable :: bindex (:) - INTEGER , allocatable :: icache1 (:) - INTEGER , allocatable :: icache2 (:,:) - REAL(r8), allocatable :: rcache2 (:,:) - - INTEGER, allocatable :: basin_sorted(:), order(:) - INTEGER, allocatable :: idxinq(:), addrinq(:) - - LOGICAL, allocatable :: mask(:) - - REAL(r8), allocatable :: rlon_b(:), rlat_b(:) - TYPE(pointer_real8_1d), allocatable :: rlon_nb(:), rlat_nb(:) - - REAL(r8), allocatable :: area_b(:) - REAL(r8), allocatable :: elva_b(:) - real(r8), allocatable :: iswatb(:) - - TYPE(pointer_real8_1d), allocatable :: area_nb (:) ! m^2 - TYPE(pointer_real8_1d), allocatable :: elva_nb (:) ! m - TYPE(pointer_real8_1d), allocatable :: iswat_nb (:) - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - - numbasin = numelm - - neighbour_file = DEF_CatchmentMesh_data - - IF (p_is_master) THEN - CALL ncio_read_serial (neighbour_file, 'basin_num_neighbour', nnball ) - CALL ncio_read_serial (neighbour_file, 'basin_idx_neighbour', idxnball) - CALL ncio_read_serial (neighbour_file, 'basin_len_border' , lenbdall) - - maxnnb = size(idxnball,1) - - lenbdall = lenbdall * 1.e3 ! km to m - ENDIF - -#ifdef USEMPI - - CALL mpi_bcast (maxnnb, 1, MPI_INTEGER, p_root, p_comm_glb, p_err) - - IF (p_is_master) THEN - - allocate (addrbasin (size(nnball))) - addrbasin(:) = -1 - - DO iwork = 0, p_np_worker-1 - - CALL mpi_recv (mesg(1:2), 2, MPI_INTEGER, & - MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err) - isrc = mesg(1) - nrecv = mesg(2) - - IF (nrecv > 0) THEN - - allocate (bindex (nrecv)) - allocate (icache1 (nrecv)) - allocate (icache2 (maxnnb,nrecv)) - allocate (rcache2 (maxnnb,nrecv)) - - CALL mpi_recv (bindex, nrecv, MPI_INTEGER, & - isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) - - addrbasin(bindex) = isrc - - idest = isrc - - icache1 = nnball(bindex) - CALL mpi_send (icache1, nrecv, MPI_INTEGER, & - idest, mpi_tag_data, p_comm_glb, p_err) - - DO irecv = 1, nrecv - icache2(:,irecv) = idxnball(:,bindex(irecv)) - ENDDO - CALL mpi_send (icache2, maxnnb*nrecv, MPI_INTEGER, & - idest, mpi_tag_data, p_comm_glb, p_err) - - DO irecv = 1, nrecv - rcache2(:,irecv) = lenbdall(:,bindex(irecv)) - ENDDO - CALL mpi_send (rcache2, maxnnb*nrecv, MPI_REAL8, & - idest, mpi_tag_data, p_comm_glb, p_err) - - deallocate (bindex ) - deallocate (icache1) - deallocate (icache2) - deallocate (rcache2) - - ENDIF - ENDDO - ENDIF -#endif - - IF (p_is_worker) THEN - - IF (numbasin > 0) THEN - allocate (bindex (numbasin)) - bindex = landelm%eindex - ENDIF - -#ifdef USEMPI - mesg(1:2) = (/p_iam_glb, numbasin/) - CALL mpi_send (mesg(1:2), 2, MPI_INTEGER, p_root, mpi_tag_mesg, p_comm_glb, p_err) - - IF (numbasin > 0) THEN - CALL mpi_send (bindex, numbasin, MPI_INTEGER, & - p_root, mpi_tag_data, p_comm_glb, p_err) - - allocate (nnball (numbasin)) - CALL mpi_recv (nnball, numbasin, MPI_INTEGER, & - p_root, mpi_tag_data, p_comm_glb, p_stat, p_err) - - allocate (idxnball (maxnnb,numbasin)) - CALL mpi_recv (idxnball, maxnnb*numbasin, MPI_INTEGER, & - p_root, mpi_tag_data, p_comm_glb, p_stat, p_err) - - allocate (lenbdall (maxnnb,numbasin)) - CALL mpi_recv (lenbdall, maxnnb*numbasin, MPI_REAL8, & - p_root, mpi_tag_data, p_comm_glb, p_stat, p_err) - ENDIF -#else - allocate (icache1 (numbasin)) - allocate (icache2 (maxnnb,numbasin)) - allocate (rcache2 (maxnnb,numbasin)) - - icache1 = nnball - icache2 = idxnball - rcache2 = lenbdall - - DO ibasin = 1, numbasin - nnball (ibasin) = icache1 (bindex(ibasin)) - idxnball (:,ibasin) = icache2 (:,bindex(ibasin)) - lenbdall (:,ibasin) = rcache2 (:,bindex(ibasin)) - ENDDO - - deallocate (icache1, icache2, rcache2) -#endif - - IF (numbasin > 0) THEN - - allocate (basinneighbour (numbasin)) - - DO ibasin = 1, numbasin - nnb = nnball(ibasin) - basinneighbour(ibasin)%nnb = nnb - - IF (nnb > 0) THEN - allocate (basinneighbour(ibasin)%bindex (nnb)) - allocate (basinneighbour(ibasin)%lenbdr (nnb)) - allocate (basinneighbour(ibasin)%addr (2,nnb)) - - basinneighbour(ibasin)%bindex = idxnball(1:nnb,ibasin) - basinneighbour(ibasin)%lenbdr = lenbdall(1:nnb,ibasin) - basinneighbour(ibasin)%addr(1,:) = -9999 - ENDIF - ENDDO - ENDIF - - ENDIF - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - -#ifdef USEMPI - IF (p_is_master) THEN - DO iwork = 0, p_np_worker-1 - - CALL mpi_recv (mesg(1:2), 2, MPI_INTEGER, & - MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err) - isrc = mesg(1) - nrecv = mesg(2) - - IF (nrecv > 0) THEN - allocate (bindex (nrecv)) - allocate (icache1 (nrecv)) - - CALL mpi_recv (bindex, nrecv, MPI_INTEGER, & - isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) - - icache1 = addrbasin(bindex) - - idest = isrc - CALL mpi_send (icache1, nrecv, MPI_INTEGER, & - idest, mpi_tag_data, p_comm_glb, p_err) - - deallocate(bindex, icache1) - ENDIF - ENDDO - ENDIF -#endif - - IF (p_is_worker) THEN - - IF (numbasin > 0) THEN - allocate (basin_sorted (numbasin)) - allocate (order (numbasin)) - - basin_sorted = bindex - order = (/(ibasin, ibasin = 1, numbasin)/) - - CALL quicksort (numbasin, basin_sorted, order) - -#ifdef USEMPI - allocate(idxinq (numbasin*maxnnb)) -#endif - - nnbinq = 0 - DO ibasin = 1, numbasin - DO inb = 1, basinneighbour(ibasin)%nnb - - IF (basinneighbour(ibasin)%bindex(inb) <= 0) CYCLE ! skip ocean neighbour - - iloc = find_in_sorted_list1 (basinneighbour(ibasin)%bindex(inb), numbasin, basin_sorted) - IF (iloc > 0) THEN - basinneighbour(ibasin)%addr(1,inb) = -1 - basinneighbour(ibasin)%addr(2,inb) = order(iloc) -#ifdef USEMPI - ELSE - CALL insert_into_sorted_list1 (basinneighbour(ibasin)%bindex(inb), nnbinq, idxinq, iloc) -#endif - ENDIF - ENDDO - ENDDO - ELSE - nnbinq = 0 - ENDIF - -#ifdef USEMPI - mesg(1:2) = (/p_iam_glb, nnbinq/) - CALL mpi_send (mesg(1:2), 2, MPI_INTEGER, p_root, mpi_tag_mesg, p_comm_glb, p_err) - - IF (nnbinq > 0) THEN - - CALL mpi_send (idxinq(1:nnbinq), nnbinq, MPI_INTEGER, & - p_root, mpi_tag_data, p_comm_glb, p_err) - - allocate (addrinq (nnbinq)) - CALL mpi_recv (addrinq, nnbinq, MPI_INTEGER, & - p_root, mpi_tag_data, p_comm_glb, p_stat, p_err) - - ENDIF - - IF (nnbinq > 0) allocate(mask (nnbinq)) - - allocate (recvaddr (0:p_np_worker-1)) - DO iwork = 0, p_np_worker-1 - IF (nnbinq > 0) THEN - mask = (addrinq == p_address_worker(iwork)) - ndata = count(mask) - ELSE - ndata = 0 - ENDIF - - recvaddr(iwork)%ndata = ndata - IF (ndata > 0) THEN - allocate (recvaddr(iwork)%bindex (ndata)) - recvaddr(iwork)%bindex = pack(idxinq(1:nnbinq), mask) - ENDIF - ENDDO - - IF (nnbinq > 0) deallocate(mask) - - DO ibasin = 1, numbasin - DO inb = 1, basinneighbour(ibasin)%nnb - IF ((basinneighbour(ibasin)%addr(1,inb) == -9999) & - .and. (basinneighbour(ibasin)%bindex(inb) > 0)) THEN ! skip ocean neighbour - - iloc = find_in_sorted_list1 (basinneighbour(ibasin)%bindex(inb), nnbinq, idxinq(1:nnbinq)) - - iwork = p_itis_worker(addrinq(iloc)) - iloc1 = find_in_sorted_list1 (basinneighbour(ibasin)%bindex(inb), & - recvaddr(iwork)%ndata, recvaddr(iwork)%bindex) - - basinneighbour(ibasin)%addr(1,inb) = iwork - basinneighbour(ibasin)%addr(2,inb) = iloc1 - ENDIF - ENDDO - ENDDO - - allocate (sendaddr (0:p_np_worker-1)) - DO iwork = 0, p_np_worker-1 - sendaddr(iwork)%ndata = 0 - ENDDO - - DO ibasin = 1, numbasin - DO inb = 1, basinneighbour(ibasin)%nnb - IF (basinneighbour(ibasin)%addr(1,inb) >= 0) THEN - iwork = basinneighbour(ibasin)%addr(1,inb) - sendaddr(iwork)%ndata = sendaddr(iwork)%ndata + 1 - ENDIF - ENDDO - ENDDO - - DO iwork = 0, p_np_worker-1 - IF (sendaddr(iwork)%ndata > 0) THEN - allocate (sendaddr(iwork)%bindex (sendaddr(iwork)%ndata)) - sendaddr(iwork)%ndata = 0 - ENDIF - ENDDO - - DO ibasin = 1, numbasin - DO inb = 1, basinneighbour(ibasin)%nnb - IF (basinneighbour(ibasin)%addr(1,inb) >= 0) THEN - iwork = basinneighbour(ibasin)%addr(1,inb) - CALL insert_into_sorted_list1 (bindex(ibasin), & - sendaddr(iwork)%ndata, sendaddr(iwork)%bindex, iloc) - ENDIF - ENDDO - ENDDO - - DO iwork = 0, p_np_worker-1 - IF (sendaddr(iwork)%ndata > 0) THEN - IF (sendaddr(iwork)%ndata < size(sendaddr(iwork)%bindex)) THEN - allocate (icache1 (sendaddr(iwork)%ndata)) - icache1 = sendaddr(iwork)%bindex(1:sendaddr(iwork)%ndata) - - deallocate (sendaddr(iwork)%bindex) - allocate (sendaddr(iwork)%bindex (sendaddr(iwork)%ndata)) - sendaddr(iwork)%bindex = icache1 - - deallocate (icache1) - ENDIF - ENDIF - ENDDO - - DO iwork = 0, p_np_worker-1 - IF (sendaddr(iwork)%ndata > 0) THEN - allocate (sendaddr(iwork)%ibasin (sendaddr(iwork)%ndata)) - - DO inb = 1, sendaddr(iwork)%ndata - iloc = find_in_sorted_list1 (sendaddr(iwork)%bindex(inb), numbasin, basin_sorted) - sendaddr(iwork)%ibasin(inb) = order(iloc) - ENDDO - ENDIF - ENDDO -#endif - ENDIF - - IF (allocated(nnball )) deallocate(nnball ) - IF (allocated(idxnball )) deallocate(idxnball ) - IF (allocated(lenbdall )) deallocate(lenbdall ) - IF (allocated(addrbasin)) deallocate(addrbasin) - IF (allocated(bindex )) deallocate(bindex ) - IF (allocated(icache1)) deallocate(icache1) - IF (allocated(icache2)) deallocate(icache2) - IF (allocated(rcache2)) deallocate(rcache2) - - IF (allocated(basin_sorted)) deallocate(basin_sorted) - IF (allocated(order )) deallocate(order ) - IF (allocated(idxinq )) deallocate(idxinq ) - IF (allocated(addrinq)) deallocate(addrinq) - IF (allocated(mask )) deallocate(mask ) - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - - IF (p_is_worker) THEN - - DO ibasin = 1, numbasin - nnb = basinneighbour(ibasin)%nnb - IF (nnb > 0) THEN - allocate (basinneighbour(ibasin)%dist (nnb)) - allocate (basinneighbour(ibasin)%area (nnb)) - allocate (basinneighbour(ibasin)%elva (nnb)) - allocate (basinneighbour(ibasin)%slope (nnb)) - allocate (basinneighbour(ibasin)%iswatb(nnb)) - ENDIF - ENDDO - - IF (numbasin > 0) THEN - allocate (rlon_b(numbasin)) - allocate (rlat_b(numbasin)) - CALL landelm%get_lonlat_radian (rlon_b, rlat_b) - ENDIF - - CALL allocate_neighbour_data (rlon_nb) - CALL allocate_neighbour_data (rlat_nb) - - CALL retrieve_neighbour_data (rlon_b, rlon_nb) - CALL retrieve_neighbour_data (rlat_b, rlat_nb) - - DO ibasin = 1, numbasin - DO inb = 1, basinneighbour(ibasin)%nnb - IF (basinneighbour(ibasin)%bindex(inb) > 0) THEN ! skip ocean neighbour - basinneighbour(ibasin)%dist(inb) = 1.0e3 * arclen ( & - rlat_b (ibasin), rlon_b (ibasin), & - rlat_nb(ibasin)%val(inb), rlon_nb(ibasin)%val(inb)) - ENDIF - ENDDO - ENDDO - - IF (numbasin > 0) THEN - allocate (area_b(numbasin)) - allocate (elva_b(numbasin)) - allocate (iswatb(numbasin)) - DO ibasin = 1, numbasin - IF (lake_id(ibasin) <= 0) THEN - area_b(ibasin) = sum(hillslope_network(ibasin)%area) - IF ((hillslope_network(ibasin)%nhru == 1) .and. (hillslope_network(ibasin)%indx(1) == 0)) THEN - iswatb(ibasin) = 1. - ELSE - iswatb(ibasin) = 0. - ENDIF - ELSE - area_b(ibasin) = sum(lakes(ibasin)%area0) - iswatb(ibasin) = 1. - ENDIF - - elva_b(ibasin) = basinelv(ibasin) - IF (lake_id(ibasin) > 0) THEN - elva_b(ibasin) = bedelv(ibasin) - ENDIF - - basinneighbour(ibasin)%myarea = area_b(ibasin) - basinneighbour(ibasin)%myelva = elva_b(ibasin) - ENDDO - ENDIF - - CALL allocate_neighbour_data (area_nb) - CALL retrieve_neighbour_data (area_b, area_nb) - - CALL allocate_neighbour_data (elva_nb) - CALL retrieve_neighbour_data (elva_b, elva_nb) - - CALL allocate_neighbour_data (iswat_nb) - CALL retrieve_neighbour_data (iswatb, iswat_nb) - - DO ibasin = 1, numbasin - DO inb = 1, basinneighbour(ibasin)%nnb - IF (basinneighbour(ibasin)%bindex(inb) > 0) THEN ! skip ocean neighbour - basinneighbour(ibasin)%area (inb) = area_nb(ibasin)%val(inb) - basinneighbour(ibasin)%elva (inb) = elva_nb(ibasin)%val(inb) - basinneighbour(ibasin)%slope(inb) = & - abs(elva_nb(ibasin)%val(inb) - elva_b(ibasin)) / basinneighbour(ibasin)%dist(inb) - - IF (iswat_nb(ibasin)%val(inb) > 0) THEN - basinneighbour(ibasin)%iswatb(inb) = .true. - ELSE - basinneighbour(ibasin)%iswatb(inb) = .false. - ENDIF - ENDIF - ENDDO - ENDDO - - CALL allocate_neighbour_data (theta_a_nb) - CALL allocate_neighbour_data (zwt_nb ) - CALL allocate_neighbour_data (Ks_nb ) - CALL allocate_neighbour_data (wdsrf_nb ) - - IF (allocated(rlon_b)) deallocate(rlon_b) - IF (allocated(rlat_b)) deallocate(rlat_b) - IF (allocated(elva_b)) deallocate(elva_b) - IF (allocated(area_b)) deallocate(area_b) - IF (allocated(iswatb)) deallocate(iswatb) - - IF (allocated(rlon_nb )) deallocate(rlon_nb ) - IF (allocated(rlat_nb )) deallocate(rlat_nb ) - IF (allocated(area_nb )) deallocate(area_nb ) - IF (allocated(elva_nb )) deallocate(elva_nb ) - IF (allocated(iswat_nb)) deallocate(iswat_nb) - - ENDIF - - If (p_is_worker) THEN - - DO ibasin = 1, numbasin - IF (lake_id(ibasin) == 0) THEN - IF ((to_lake(ibasin)) .or. (riverdown(ibasin) <= 0)) THEN - ! river to lake, ocean or inland depression - outletwth(ibasin) = riverwth(ibasin) - ELSE - ! river to river - outletwth(ibasin) = (riverwth(ibasin) + riverwth_ds(ibasin)) * 0.5 - ENDIF - ELSEIF (lake_id(ibasin) /= 0) THEN - IF ((.not. to_lake(ibasin)) .and. (riverdown(ibasin) /= 0)) THEN - IF (riverdown(ibasin) > 0) THEN - ! lake to river - outletwth(ibasin) = riverwth_ds(ibasin) - ELSEIF (riverdown(ibasin) == -1) THEN - ! lake is inland depression - outletwth(ibasin) = 0 - ENDIF - ELSEIF (to_lake(ibasin) .or. (riverdown(ibasin) == 0)) THEN - ! lake to lake .or. lake catchment to lake .or. lake to ocean - IF (riverdown(ibasin) > 0) THEN - inb = findloc(basinneighbour(ibasin)%bindex, riverdown(ibasin), dim=1) - ELSE - inb = findloc(basinneighbour(ibasin)%bindex, -9, dim=1) ! -9 is ocean - ENDIF - - IF (inb <= 0) THEN - outletwth(ibasin) = 0 - ELSE - outletwth(ibasin) = basinneighbour(ibasin)%lenbdr(inb) - ENDIF - ENDIF - ENDIF - ENDDO - ENDIF - - END SUBROUTINE basin_neighbour_init - - ! ---------- - SUBROUTINE retrieve_neighbour_data (vec_in, nbdata) - - USE MOD_Precision - USE MOD_SPMD_Task - USE MOD_Mesh, only : numelm - IMPLICIT NONE - - REAL(r8), intent(inout) :: vec_in (:) - TYPE(pointer_real8_1d) :: nbdata (:) - - ! Local Variables - LOGICAL, allocatable :: smask(:), rmask(:) - INTEGER, allocatable :: req_send(:), req_recv(:) - TYPE(pointer_real8_1d), allocatable :: sbuff(:), rbuff(:) - INTEGER :: numbasin, iwork, ibasin, inb, iloc - - IF (p_is_worker) THEN - - numbasin = numelm - - DO ibasin = 1, numbasin - DO inb = 1, basinneighbour(ibasin)%nnb - IF (basinneighbour(ibasin)%addr(1,inb)== -1) THEN - iloc = basinneighbour(ibasin)%addr(2,inb) - nbdata(ibasin)%val(inb) = vec_in(iloc) - ENDIF - ENDDO - ENDDO - -#ifdef USEMPI - CALL mpi_barrier (p_comm_worker, p_err) - - allocate (smask (0:p_np_worker-1)) - allocate (req_send (0:p_np_worker-1)) - allocate (sbuff (0:p_np_worker-1)) - smask(:) = .false. - - DO iwork = 0, p_np_worker-1 - IF (sendaddr(iwork)%ndata > 0) THEN - smask(iwork) = .true. - - allocate (sbuff(iwork)%val (sendaddr(iwork)%ndata)) - sbuff(iwork)%val = vec_in(sendaddr(iwork)%ibasin) - - CALL mpi_isend(sbuff(iwork)%val, sendaddr(iwork)%ndata, MPI_REAL8, & - p_address_worker(iwork), 101, p_comm_glb, req_send(iwork), p_err) - ENDIF - ENDDO - - allocate (rmask (0:p_np_worker-1)) - allocate (req_recv (0:p_np_worker-1)) - allocate (rbuff (0:p_np_worker-1)) - rmask(:) = .false. - - DO iwork = 0, p_np_worker-1 - IF (recvaddr(iwork)%ndata > 0) THEN - rmask(iwork) = .true. - - allocate (rbuff(iwork)%val (recvaddr(iwork)%ndata)) - - CALL mpi_irecv(rbuff(iwork)%val, recvaddr(iwork)%ndata, MPI_REAL8, & - p_address_worker(iwork), 101, p_comm_glb, req_recv(iwork), p_err) - ENDIF - ENDDO - - IF (any(rmask)) THEN - - CALL mpi_waitall(count(rmask), pack(req_recv,rmask), MPI_STATUSES_IGNORE, p_err) - - DO ibasin = 1, numbasin - DO inb = 1, basinneighbour(ibasin)%nnb - IF (basinneighbour(ibasin)%addr(1,inb) >= 0) THEN - iwork = basinneighbour(ibasin)%addr(1,inb) - iloc = basinneighbour(ibasin)%addr(2,inb) - nbdata(ibasin)%val(inb) = rbuff(iwork)%val(iloc) - ENDIF - ENDDO - ENDDO - ENDIF - - IF (any(smask)) THEN - CALL mpi_waitall(count(smask), pack(req_send,smask), MPI_STATUSES_IGNORE, p_err) - ENDIF - - IF (allocated(smask)) deallocate(smask) - IF (allocated(rmask)) deallocate(rmask) - - IF (allocated(req_send)) deallocate(req_send) - IF (allocated(req_recv)) deallocate(req_recv) - - IF (allocated(sbuff)) deallocate(sbuff) - IF (allocated(rbuff)) deallocate(rbuff) - - CALL mpi_barrier (p_comm_worker, p_err) -#endif - - ENDIF - - END SUBROUTINE retrieve_neighbour_data - - ! --- - SUBROUTINE allocate_neighbour_data (nbdata) - - USE MOD_Mesh, only : numelm - IMPLICIT NONE - - TYPE(pointer_real8_1d), allocatable :: nbdata(:) - INTEGER :: ibasin - - IF (numelm > 0) THEN - allocate (nbdata(numelm)) - DO ibasin = 1, numelm - IF (basinneighbour(ibasin)%nnb > 0) THEN - allocate (nbdata(ibasin)%val (basinneighbour(ibasin)%nnb)) - ENDIF - ENDDO - ENDIF - - END SUBROUTINE allocate_neighbour_data - - ! ---------- - SUBROUTINE basin_neighbour_final () - - IMPLICIT NONE - INTEGER :: i - - IF (allocated(basinneighbour)) THEN - DO i = 1, size(basinneighbour) - IF (allocated(basinneighbour(i)%bindex)) deallocate(basinneighbour(i)%bindex) - IF (allocated(basinneighbour(i)%addr )) deallocate(basinneighbour(i)%addr ) - IF (allocated(basinneighbour(i)%dist )) deallocate(basinneighbour(i)%dist ) - IF (allocated(basinneighbour(i)%lenbdr)) deallocate(basinneighbour(i)%lenbdr) - IF (allocated(basinneighbour(i)%area )) deallocate(basinneighbour(i)%area ) - IF (allocated(basinneighbour(i)%elva )) deallocate(basinneighbour(i)%elva ) - IF (allocated(basinneighbour(i)%slope )) deallocate(basinneighbour(i)%slope ) - IF (allocated(basinneighbour(i)%iswatb)) deallocate(basinneighbour(i)%iswatb) - ENDDO - deallocate(basinneighbour) - ENDIF - - IF (allocated(theta_a_nb)) deallocate(theta_a_nb) - IF (allocated(zwt_nb )) deallocate(zwt_nb ) - IF (allocated(Ks_nb )) deallocate(Ks_nb ) - IF (allocated(wdsrf_nb )) deallocate(wdsrf_nb ) - - DO i = lbound(recvaddr,1), ubound(recvaddr,1) - IF (allocated(recvaddr(i)%bindex)) deallocate(recvaddr(i)%bindex) - IF (allocated(recvaddr(i)%ibasin )) deallocate(recvaddr(i)%ibasin ) - ENDDO - - DO i = lbound(sendaddr,1), ubound(sendaddr,1) - IF (allocated(sendaddr(i)%bindex)) deallocate(sendaddr(i)%bindex) - IF (allocated(sendaddr(i)%ibasin )) deallocate(sendaddr(i)%ibasin ) - ENDDO - - IF (allocated(recvaddr)) deallocate(recvaddr) - IF (allocated(sendaddr)) deallocate(sendaddr) - - END SUBROUTINE basin_neighbour_final - -END MODULE MOD_Hydro_BasinNeighbour -#endif diff --git a/main/HYDRO/MOD_Hydro_Hist.F90 b/main/HYDRO/MOD_Hydro_Hist.F90 index 3c0d9634..237f2278 100644 --- a/main/HYDRO/MOD_Hydro_Hist.F90 +++ b/main/HYDRO/MOD_Hydro_Hist.F90 @@ -1,6 +1,6 @@ #include -#ifdef LATERAL_FLOW +#ifdef CatchLateralFlow module MOD_Hydro_Hist !-------------------------------------------------------------------------------- ! DESCRIPTION: @@ -27,11 +27,12 @@ module MOD_Hydro_Hist REAL(r8), allocatable :: a_wdsrf_hru (:) REAL(r8), allocatable :: a_veloc_hru (:) - REAL(r8), allocatable :: a_rsubs_bsn (:) - REAL(r8), allocatable :: a_rsubs_hru (:) + REAL(r8), allocatable :: a_xsubs_bsn (:) + REAL(r8), allocatable :: a_xsubs_hru (:) REAL(r8), allocatable :: a_height_riv (:) REAL(r8), allocatable :: a_veloct_riv (:) + REAL(r8), allocatable :: a_discharge (:) ! -- PUBLIC SUBROUTINEs -- public :: hist_basin_init @@ -53,13 +54,14 @@ SUBROUTINE hist_basin_init IF (numhru > 0) THEN allocate ( a_wdsrf_hru (numhru)) allocate ( a_veloc_hru (numhru)) - allocate ( a_rsubs_hru (numhru)) + allocate ( a_xsubs_hru (numhru)) ENDIF IF (numbasin > 0) THEN allocate ( a_height_riv (numbasin)) allocate ( a_veloct_riv (numbasin)) - allocate ( a_rsubs_bsn (numbasin)) + allocate ( a_discharge (numbasin)) + allocate ( a_xsubs_bsn (numbasin)) ENDIF ENDIF @@ -75,11 +77,12 @@ subroutine hist_basin_final () IF (allocated(a_wdsrf_hru )) deallocate(a_wdsrf_hru ) IF (allocated(a_veloc_hru )) deallocate(a_veloc_hru ) - IF (allocated(a_rsubs_bsn )) deallocate(a_rsubs_bsn ) - IF (allocated(a_rsubs_hru )) deallocate(a_rsubs_hru ) + IF (allocated(a_xsubs_bsn )) deallocate(a_xsubs_bsn ) + IF (allocated(a_xsubs_hru )) deallocate(a_xsubs_hru ) IF (allocated(a_height_riv)) deallocate(a_height_riv) IF (allocated(a_veloct_riv)) deallocate(a_veloct_riv) + IF (allocated(a_discharge )) deallocate(a_discharge ) end subroutine hist_basin_final @@ -136,53 +139,75 @@ SUBROUTINE hist_basin_out (file_hist, idate) numbasin = numelm - where(a_height_riv /= spval) - a_height_riv = a_height_riv / nac_basin - END where + IF (p_is_worker) THEN + where(a_height_riv /= spval) + a_height_riv = a_height_riv / nac_basin + END where + ENDIF CALL vector_write_basin (& file_hist_basin, a_height_riv, numbasin, totalnumelm, 'wdsrf_bsn', 'basin', elm_data_address, & DEF_hist_vars%riv_height, itime_in_file, 'River Height', 'm') - where(a_veloct_riv /= spval) - a_veloct_riv = a_veloct_riv / nac_basin - END where + IF (p_is_worker) THEN + where(a_veloct_riv /= spval) + a_veloct_riv = a_veloct_riv / nac_basin + END where + ENDIF CALL vector_write_basin (& file_hist_basin, a_veloct_riv, numbasin, totalnumelm, 'veloc_riv', 'basin', elm_data_address, & DEF_hist_vars%riv_veloct, itime_in_file, 'River Velocity', 'm/s') - where(a_wdsrf_hru /= spval) - a_wdsrf_hru = a_wdsrf_hru / nac_basin - END where + IF (p_is_worker) THEN + where(a_discharge /= spval) + a_discharge = a_discharge / nac_basin + END where + ENDIF + + CALL vector_write_basin (& + file_hist_basin, a_discharge, numbasin, totalnumelm, 'discharge', 'basin', elm_data_address, & + DEF_hist_vars%discharge, itime_in_file, 'River Discharge', 'm^3/s') + + IF (p_is_worker) THEN + where(a_wdsrf_hru /= spval) + a_wdsrf_hru = a_wdsrf_hru / nac_basin + END where + ENDIF CALL vector_write_basin (& file_hist_basin, a_wdsrf_hru, numhru, totalnumhru, 'wdsrf_hru', 'hydrounit', hru_data_address, & DEF_hist_vars%wdsrf_hru, itime_in_file, 'Depth of Surface Water in Hydro unit', 'm') - where(a_veloc_hru /= spval) - a_veloc_hru = a_veloc_hru / nac_basin - END where + IF (p_is_worker) THEN + where(a_veloc_hru /= spval) + a_veloc_hru = a_veloc_hru / nac_basin + END where + ENDIF CALL vector_write_basin (& file_hist_basin, a_veloc_hru, numhru, totalnumhru, 'veloc_hru', 'hydrounit', hru_data_address, & DEF_hist_vars%veloc_hru, itime_in_file, 'Surface Flow Velocity in Hydro unit', 'm/s') - where(a_rsubs_bsn /= spval) - a_rsubs_bsn = a_rsubs_bsn / nac_basin - END where + IF (p_is_worker) THEN + where(a_xsubs_bsn /= spval) + a_xsubs_bsn = a_xsubs_bsn / nac_basin + END where + ENDIF CALL vector_write_basin (& - file_hist_basin, a_rsubs_bsn, numbasin, totalnumelm, 'rsubs_bsn', 'basin', elm_data_address, & - DEF_hist_vars%rsubs_bsn, itime_in_file, 'Subsurface lateral flow between basins', 'm/s') + file_hist_basin, a_xsubs_bsn, numbasin, totalnumelm, 'xsubs_bsn', 'basin', elm_data_address, & + DEF_hist_vars%xsubs_bsn, itime_in_file, 'Subsurface lateral flow between basins', 'm/s') - where(a_rsubs_hru /= spval) - a_rsubs_hru = a_rsubs_hru / nac_basin - END where + IF (p_is_worker) THEN + where(a_xsubs_hru /= spval) + a_xsubs_hru = a_xsubs_hru / nac_basin + END where + ENDIF CALL vector_write_basin (& - file_hist_basin, a_rsubs_hru, numhru, totalnumhru, 'rsubs_hru', 'hydrounit', hru_data_address, & - DEF_hist_vars%rsubs_hru, itime_in_file, 'SubSurface lateral flow between HRUs', 'm/s') + file_hist_basin, a_xsubs_hru, numhru, totalnumhru, 'xsubs_hru', 'hydrounit', hru_data_address, & + DEF_hist_vars%xsubs_hru, itime_in_file, 'SubSurface lateral flow between HRUs', 'm/s') call FLUSH_acc_fluxes_basin () @@ -208,13 +233,14 @@ SUBROUTINE FLUSH_acc_fluxes_basin () IF (numbasin > 0) THEN a_height_riv(:) = spval a_veloct_riv(:) = spval - a_rsubs_bsn (:) = spval + a_discharge (:) = spval + a_xsubs_bsn (:) = spval ENDIF IF (numhru > 0) THEN a_wdsrf_hru(:) = spval a_veloc_hru(:) = spval - a_rsubs_hru(:) = spval + a_xsubs_hru(:) = spval ENDIF ENDIF @@ -237,13 +263,14 @@ SUBROUTINE accumulate_fluxes_basin IF (numbasin > 0) THEN CALL acc1d_basin (wdsrf_bsn_ta, a_height_riv) CALL acc1d_basin (veloc_riv_ta, a_veloct_riv) - CALL acc1d_basin (rsubs_bsn , a_rsubs_bsn ) + CALL acc1d_basin (discharge , a_discharge ) + CALL acc1d_basin (xsubs_bsn , a_xsubs_bsn ) ENDIF IF (numhru > 0) THEN CALL acc1d_basin (wdsrf_hru_ta, a_wdsrf_hru) CALL acc1d_basin (veloc_hru_ta, a_veloc_hru) - CALL acc1d_basin (rsubs_hru , a_rsubs_hru) + CALL acc1d_basin (xsubs_hru , a_xsubs_hru) ENDIF ENDIF diff --git a/main/HYDRO/MOD_Hydro_IO.F90 b/main/HYDRO/MOD_Hydro_IO.F90 index a8cac7cc..af1f83ae 100644 --- a/main/HYDRO/MOD_Hydro_IO.F90 +++ b/main/HYDRO/MOD_Hydro_IO.F90 @@ -1,6 +1,6 @@ #include -#ifdef LATERAL_FLOW +#ifdef CatchLateralFlow MODULE MOD_Hydro_IO !----------------------------------------------------------------------- ! DESCRIPTION: diff --git a/main/HYDRO/MOD_Hydro_LateralFlow.F90 b/main/HYDRO/MOD_Hydro_LateralFlow.F90 deleted file mode 100644 index 218679f9..00000000 --- a/main/HYDRO/MOD_Hydro_LateralFlow.F90 +++ /dev/null @@ -1,175 +0,0 @@ -#include - -#ifdef LATERAL_FLOW -MODULE MOD_Hydro_LateralFlow - !------------------------------------------------------------------------------------- - ! DESCRIPTION: - ! - ! Lateral flow. - ! - ! Lateral flows in CoLM include - ! 1. Surface flow over hillslopes; - ! 2. Routing flow in rivers; - ! 3. Groundwater (subsurface) lateral flow. - ! - ! Water exchanges between - ! 1. surface flow and rivers; - ! 2. subsurface flow and rivers. - ! - ! Created by Shupeng Zhang, May 2023 - !------------------------------------------------------------------------------------- - - USE MOD_Precision - USE MOD_SPMD_Task - USE MOD_Hydro_Vars_TimeVariables - USE MOD_Hydro_RiverLakeNetwork - USE MOD_Hydro_BasinNeighbour - USE MOD_Hydro_HillslopeNetwork - USE MOD_Hydro_HillslopeFlow - USE MOD_Hydro_SubsurfaceFlow - USE MOD_Hydro_RiverLakeFlow - IMPLICIT NONE - - INTEGER, parameter :: nsubstep = 20 - -CONTAINS - - ! ---------- - SUBROUTINE lateral_flow_init () - - IMPLICIT NONE - - CALL hillslope_network_init () - CALL river_lake_network_init () - CALL basin_neighbour_init () - - IF (p_is_worker) THEN - wdsrf_bsn_prev(:) = wdsrf_bsn(:) - wdsrf_hru_prev(:) = wdsrf_hru(:) - ENDIF - - END SUBROUTINE lateral_flow_init - - ! ---------- - SUBROUTINE lateral_flow (deltime) - - USE MOD_Mesh, only : numelm - USE MOD_LandHRU, only : landhru, numhru, basin_hru - USE MOD_LandPatch, only : numpatch, elm_patch, hru_patch - - USE MOD_Vars_1DFluxes, only : rsur - USE MOD_Vars_TimeVariables, only : wdsrf - USE MOD_Vars_TimeInvariants, only : lakedepth - USE MOD_Hydro_Vars_1DFluxes - USE MOD_Hydro_Vars_TimeVariables - - USE MOD_RangeCheck - IMPLICIT NONE - - REAL(r8), intent(in) :: deltime - - ! Local Variables - INTEGER :: nbasin, ibasin, ihru, i, j, istt, iend, istep - real(r8), allocatable :: wdsrf_p (:) - - IF (p_is_worker) THEN - - nbasin = numelm - - ! a) The smallest unit in surface lateral flow (including hillslope flow and river-lake flow) - ! is HRU and the main prognostic variable is "wdsrf_hru" (surface water depth). - ! b) "wdsrf_hru" is updated by aggregating water depths in patches. - ! c) Water surface in a basin ("wdsrf_bsn", defined as the lowest surface water in the basin) - ! is derived from "wdsrf_hru". - DO i = 1, numhru - istt = hru_patch%substt(i) - iend = hru_patch%subend(i) - wdsrf_hru(i) = sum(wdsrf(istt:iend) * hru_patch%subfrc(istt:iend)) - wdsrf_hru(i) = wdsrf_hru(i) / 1.0e3 ! mm to m - ENDDO - - wdsrf_hru_ta(:) = 0 - momen_hru_ta(:) = 0 - wdsrf_bsn_ta(:) = 0 - momen_riv_ta(:) = 0 - - IF (numpatch > 0) THEN - allocate (wdsrf_p (numpatch)) - wdsrf_p = wdsrf - ENDIF - - DO istep = 1, nsubstep - - ! (1) Surface flow over hillslopes. - CALL hillslope_flow (deltime/nsubstep) - - ! (2) River and Lake flow. - CALL river_lake_flow (deltime/nsubstep) - - ENDDO - - IF (nbasin > 0) THEN - wdsrf_bsn_ta(:) = wdsrf_bsn_ta(:) / deltime - momen_riv_ta(:) = momen_riv_ta(:) / deltime - - where (wdsrf_bsn_ta > 0) - veloc_riv_ta = momen_riv_ta / wdsrf_bsn_ta - ELSE where - veloc_riv_ta = 0 - END where - ENDIF - - IF (numhru > 0) THEN - wdsrf_hru_ta(:) = wdsrf_hru_ta(:) / deltime - momen_hru_ta(:) = momen_hru_ta(:) / deltime - - where (wdsrf_hru_ta > 0) - veloc_hru_ta = momen_hru_ta / wdsrf_hru_ta - ELSE where - veloc_hru_ta = 0. - END where - ENDIF - - ! update surface water depth on patches - DO i = 1, numhru - istt = hru_patch%substt(i) - iend = hru_patch%subend(i) - wdsrf(istt:iend) = wdsrf_hru(i) * 1.0e3 ! m to mm - ENDDO - - IF (numpatch > 0) THEN - rsur(:) = (wdsrf_p(:) - wdsrf(:)) / deltime - ENDIF - - IF (allocated(wdsrf_p)) deallocate(wdsrf_p) - - ! (3) Subsurface lateral flow. - CALL subsurface_flow (deltime) - - ENDIF - -#ifdef RangeCheck - if (p_is_worker .and. (p_iam_worker == 0)) then - write(*,'(/,A)') 'Checking Lateral Flow Variables ...' - end if - CALL check_vector_data ('Basin Water Depth ', wdsrf_bsn) - CALL check_vector_data ('River Velocity ', veloc_riv) - CALL check_vector_data ('HRU Water Depth ', wdsrf_hru) - CALL check_vector_data ('HRU Water Velocity', veloc_hru) -#endif - - END SUBROUTINE lateral_flow - - ! ---------- - SUBROUTINE lateral_flow_final () - - IMPLICIT NONE - - CALL hillslope_network_final () - CALL river_lake_network_final () - CALL basin_neighbour_final () - - END SUBROUTINE lateral_flow_final - -END MODULE MOD_Hydro_LateralFlow -#endif diff --git a/main/HYDRO/MOD_Hydro_SoilWater.F90 b/main/HYDRO/MOD_Hydro_SoilWater.F90 index 466b29d4..d1eb59ef 100644 --- a/main/HYDRO/MOD_Hydro_SoilWater.F90 +++ b/main/HYDRO/MOD_Hydro_SoilWater.F90 @@ -1,7 +1,5 @@ #include -#define SoilWaterDebug - module MOD_Hydro_SoilWater !------------------------------------------------------------------------- @@ -19,6 +17,7 @@ module MOD_Hydro_SoilWater use MOD_Precision use MOD_Hydro_SoilFunction + use MOD_Namelist, only: DEF_USE_PLANTHYDRAULICS implicit none @@ -42,12 +41,13 @@ module MOD_Hydro_SoilWater integer, parameter :: type_weighted_geometric_mean = 2 integer, parameter :: effective_hk_type = type_weighted_geometric_mean - integer, parameter :: max_iters_richards = 6 + integer, parameter :: max_iters_richards = 10 real(r8), parameter :: tol_richards = 1.e-7 -#ifdef SoilWaterDebug - INTEGER(8) :: count_iters_this(max_iters_richards) = 0 - INTEGER(8) :: count_iters_accm(max_iters_richards) = 0 +#ifdef CoLMDEBUG + INTEGER(8) :: count_implicit = 0 + INTEGER(8) :: count_explicit = 0 + INTEGER(8) :: count_wet2dry = 0 #endif ! private subroutines and functions @@ -160,8 +160,9 @@ subroutine soil_water_vertical_movement ( & nlev, dt, sp_zc, sp_zi, is_permeable, & porsl, vl_r, psi_s, hksat, nprm, prms, & porsl_wa, & - rain, etr, rootr, rsubst, qinfl, & - ss_dp, zwt, wa, ss_vliq, smp, hk ) + qgtop, etr, rootr, rootflux, rsubst, qinfl, & + ss_dp, zwt, wa, ss_vliq, smp, hk , & + tolerance ) !======================================================================= ! this is the main subroutine to execute the calculation of @@ -189,10 +190,13 @@ subroutine soil_water_vertical_movement ( & real(r8), intent(in) :: prms (nprm,1:nlev) ! parameters included in soil function real(r8), intent(in) :: porsl_wa ! soil porosity in aquifer (mm^3/mm^3) - - REAL(r8), intent(in) :: rain ! rain fall on ponding layer (mm/s) + + ! ground water including rain, snow melt and dew formation (mm/s) + REAL(r8), intent(in) :: qgtop + REAL(r8), intent(in) :: etr ! transpiration rate (mm/s) REAL(r8), intent(in) :: rootr(1:nlev) ! root fractions (percentage) + REAL(r8), intent(in) :: rootflux(1:nlev) ! root water uptake from different layers (mm/s) REAL(r8), intent(in) :: rsubst ! subsurface runoff (mm/s) REAL(r8), intent(out) :: qinfl ! infiltration into soil (mm/s) @@ -205,6 +209,8 @@ subroutine soil_water_vertical_movement ( & REAL(r8), intent(out) :: smp(1:nlev) ! soil matrix potential (mm) REAL(r8), intent(out) :: hk (1:nlev) ! hydraulic conductivity (mm/s) + real(r8), intent(in) :: tolerance + ! Local variables integer :: lb, ub, ilev, izwt REAL(r8) :: sumroot, deficit, wexchange @@ -221,7 +227,7 @@ subroutine soil_water_vertical_movement ( & integer :: lbc_typ_sub real(r8) :: lbc_val_sub -#ifdef SoilWaterDebug +#ifdef CoLMDEBUG REAL(r8) :: w_sum_before, w_sum_after, wblc #endif @@ -232,7 +238,7 @@ subroutine soil_water_vertical_movement ( & dp_m1 = ss_dp ! tolerances - tol_q = tol_richards / sqrt(real(nlev,r8)) * 0.5_r8 + tol_q = tolerance / real(nlev,r8) / dt /2.0 tol_z = tol_q * dt tol_v = tol_z / maxval(sp_dz) tol_p = 1.0e-14 @@ -240,7 +246,7 @@ subroutine soil_water_vertical_movement ( & ! water table location izwt = findloc(zwt >= sp_zi, .true., dim=1, back=.true.) -#ifdef SoilWaterDebug +#ifdef CoLMDEBUG ! total water mass w_sum_before = ss_dp DO ilev = 1, nlev @@ -259,16 +265,21 @@ subroutine soil_water_vertical_movement ( & #endif ! transpiration - sumroot = sum(rootr, mask = is_permeable .and. (rootr > 0.)) - etroot(:) = 0. - IF (sumroot > 0.) THEN - where (is_permeable) - etroot = etr * max(rootr, 0.) / sumroot - END where + if(.not. DEF_USE_PLANTHYDRAULICS)then + sumroot = sum(rootr, mask = is_permeable .and. (rootr > 0.)) + etroot(:) = 0. + IF (sumroot > 0.) THEN + where (is_permeable) + etroot = etr * max(rootr, 0.) / sumroot + END where + deficit = 0. + ELSE + deficit = etr*dt + ENDIF + else deficit = 0. - ELSE - deficit = etr*dt - ENDIF + etroot(:) = rootflux + end if do ilev = 1, izwt-1 IF (is_permeable(ilev)) THEN @@ -276,12 +287,17 @@ subroutine soil_water_vertical_movement ( & ss_vliq(ilev) = (ss_vliq(ilev) * sp_dz(ilev) & - etroot(ilev)*dt - deficit) / sp_dz(ilev) - IF (ss_vliq(ilev) < 0.) THEN - deficit = - ss_vliq(ilev) * sp_dz(ilev) - ss_vliq(ilev) = 0. + IF (ss_vliq(ilev) < 0) THEN + deficit = ( - ss_vliq(ilev)) * sp_dz(ilev) + ss_vliq(ilev) = 0 + ELSEIF (ss_vliq(ilev) > porsl(ilev)) THEN + deficit = - (ss_vliq(ilev) - porsl(ilev)) * sp_dz(ilev) + ss_vliq(ilev) = porsl(ilev) ELSE deficit = 0. ENDIF + ELSE + deficit = deficit + etroot(ilev)*dt ENDIF enddo @@ -331,7 +347,7 @@ subroutine soil_water_vertical_movement ( & if (lb == 1) then ubc_typ_sub = bc_rainfall - ubc_val_sub = rain + ubc_val_sub = qgtop else ubc_typ_sub = bc_fix_flux ubc_val_sub = 0 @@ -358,7 +374,7 @@ subroutine soil_water_vertical_movement ( & end do soilcolumn IF (.not. is_permeable(1)) THEN - ss_dp = max(ss_dp + rain * dt, 0._r8) + ss_dp = max(ss_dp + qgtop * dt, 0._r8) ENDIF IF (wa >= 0) THEN @@ -392,9 +408,9 @@ subroutine soil_water_vertical_movement ( & ENDIF ENDDO - qinfl = rain - (ss_dp - dp_m1)/dt + qinfl = qgtop - (ss_dp - dp_m1)/dt -#ifdef SoilWaterDebug +#ifdef CoLMDEBUG ! total water mass w_sum_after = ss_dp DO ilev = 1, nlev @@ -411,11 +427,11 @@ subroutine soil_water_vertical_movement ( & ENDDO w_sum_after = w_sum_after + wa - wblc = w_sum_after - (w_sum_before + (rain - etr - rsubst) * dt) + wblc = w_sum_after - (w_sum_before + (qgtop - etr - rsubst) * dt) - IF (abs(wblc) > 1.0e-3) THEN + IF (abs(wblc) > tolerance) THEN write(*,*) 'soil_water_vertical_movement balance error: ', wblc - write(*,*) w_sum_after, w_sum_before, rain, etr, rsubst + write(*,*) w_sum_after, w_sum_before, qgtop, etr, rsubst, is_permeable(1), ss_dp ENDIF #endif @@ -677,6 +693,8 @@ subroutine Richards_solver ( & integer :: ilev, iter real(r8) :: dlt + logical :: wet2dry + REAL(r8) :: wsum_m1, wsum, werr ss_wf(lb:ub) = 0 @@ -696,7 +714,7 @@ subroutine Richards_solver ( & wf_m1 = ss_wf vl_m1 = ss_vl wt_m1 = ss_wt - + wsum_m1 = sum(ss_vl * (sp_dz - ss_wt)) + sum(ss_wt * vl_s) IF (ubc_typ == bc_rainfall) THEN wsum_m1 = wsum_m1 + ss_dp @@ -707,6 +725,7 @@ subroutine Richards_solver ( & if (ubc_typ == bc_rainfall) then dp_m1 = max(ss_dp, 0._r8) + IF (dp_m1 < tol_z) dp_m1 = 0. infl_max = dp_m1/dt_this + ubc_val end if @@ -747,7 +766,7 @@ subroutine Richards_solver ( & ubc_typ, ubc_val, lbc_typ, lbc_val, & ss_wf, ss_vl, ss_wt, ss_dp, waquifer, & wf_m1, vl_m1, wt_m1, dp_m1, waquifer_m1, & - blc, is_solvable) + blc, is_solvable, tol_richards * dt_this) if (iter == 1) then q_0 = q_this @@ -755,16 +774,25 @@ subroutine Richards_solver ( & q_wt_0 = q_wt end if + wet2dry = .false. + if (ubc_typ == bc_rainfall) then + IF ((dp_m1 > 0.) .and. (q_0(lb-1) >= infl_max)) then + wet2dry = .true. + ENDIF + ENDIF + f2_norm(iter) = sqrt(sum(blc**2)) if ( (f2_norm(iter) < tol_richards * dt_this) & .or. (dt_this < dt_explicit) & .or. (iter >= max_iters_richards) & - .or. (.not. is_solvable) ) then + .or. (.not. is_solvable) & + .or. wet2dry) THEN if ((dt_this < dt_explicit) & .or. (iter >= max_iters_richards) & - .or. (.not. is_solvable) ) then + .or. (.not. is_solvable) & + .or. wet2dry) THEN dt_this = min(dt_this, dt_explicit) q_this = q_0 @@ -783,8 +811,15 @@ subroutine Richards_solver ( & dt_done = dt_done + dt_this -#ifdef SoilWaterDebug - count_iters_this(iter) = count_iters_this(iter) + 1 +#ifdef CoLMDEBUG + if (f2_norm(iter) < tol_richards * dt_this) THEN + count_implicit = count_implicit + 1 + else + count_explicit = count_explicit + 1 + IF (wet2dry) THEN + count_wet2dry = count_wet2dry + 1 + ENDIF + ENDIF #endif exit @@ -1001,12 +1036,6 @@ subroutine Richards_solver ( & werr = wsum - (wsum_m1 + ubc_val * dt_this - lbc_val * dt_this) -#ifdef SoilWaterDebug - IF (abs(werr) > 1.0e-3) then - write(*,*) 'Richards solver water balance violation: ', werr, ubc_val, lbc_val - ENDIF -#endif - end do ss_q = ss_q / dt @@ -1028,7 +1057,7 @@ subroutine water_balance ( & ubc_typ, ubc_val, lbc_typ, lbc_val, & wf, vl, wt, dp, waquifer, & wf_m1, vl_m1, wt_m1, dp_m1, waquifer_m1, & - blc, is_solvable) + blc, is_solvable, tol) integer, intent(in) :: lb, ub @@ -1059,6 +1088,7 @@ subroutine water_balance ( & real(r8), intent(out) :: blc(lb-1:ub+1) logical, intent(out), optional :: is_solvable + real(r8), intent(in ), optional :: tol ! Local variables integer :: ilev, jlev @@ -1109,7 +1139,11 @@ subroutine water_balance ( & end if if (present(is_solvable)) then - is_solvable = (ubc_typ == bc_rainfall) .or. (blc(lb-1) == 0) + IF (present(tol)) THEN + is_solvable = (ubc_typ == bc_rainfall) .or. (blc(lb-1) < tol) + ELSE + is_solvable = (ubc_typ == bc_rainfall) .or. (blc(lb-1) == 0) + ENDIF end if end subroutine water_balance @@ -1341,8 +1375,8 @@ subroutine use_explicit_form ( & dwat = (q(ilev-1) - q(ilev)) * dt wa_m1 = (wt_m1(ilev)+wf_m1(ilev)) * vl_s(ilev) & + (dz(ilev)-wt_m1(ilev)-wf_m1(ilev)) * vl_m1(ilev) - if (dwat <= - wa_m1/2) then - q(ilev) = q(ilev-1) + wa_m1/2/dt + if (dwat <= - wa_m1) then + q(ilev) = q(ilev-1) + wa_m1/dt end if end do @@ -1354,8 +1388,8 @@ subroutine use_explicit_form ( & dwat = (q(ilev-1) - q(ilev)) * dt wa_m1 = (wt_m1(ilev)+wf_m1(ilev)) * vl_s(ilev) & + (dz(ilev)-wt_m1(ilev)-wf_m1(ilev)) * vl_m1(ilev) - if (dwat <= - wa_m1/2) then - q(ilev-1) = q(ilev) - wa_m1/2/dt + if (dwat <= - wa_m1) then + q(ilev-1) = q(ilev) - wa_m1/dt end if ENDDO @@ -2478,7 +2512,9 @@ subroutine flux_sat_zone_all ( & if (qlower - qupper >= tol_q) then if ((psi_s(iface) < psi_s(iface+1)) & .or. & - ((psi_s(iface) == psi_s(iface+1)) .and. (is_sat(iface+1)))) then + ((psi_s(iface) == psi_s(iface+1)) .and. (is_sat(iface+1))) & + .or. & + (top_at_interface .and. (iface == i_stt))) then qq(iface) = qupper @@ -2501,7 +2537,9 @@ subroutine flux_sat_zone_all ( & elseif ((psi_s(iface) > psi_s(iface+1)) & .or. & - ((psi_s(iface) == psi_s(iface+1)) .and. (.not. is_sat(iface+1)))) then + ((psi_s(iface) == psi_s(iface+1)) .and. (.not. is_sat(iface+1))) & + .or. & + (btm_at_interface .and. (iface == i_end-1))) then qq(iface) = qlower @@ -2818,7 +2856,7 @@ subroutine flux_at_unsaturated_interface (& iter = iter + 1 end do -#if (defined SoilWaterDebug) +#if (defined CoLMDEBUG) if (iter == 50) then write(*,*) 'Warning : flux_at_unsaturated_interface: not converged.' end if @@ -2986,7 +3024,7 @@ subroutine flux_top_transitive_interface ( & iter = iter + 1 end do -#if (defined SoilWaterDebug) +#if (defined CoLMDEBUG) if (iter == 50) then write(*,*) 'Warning : flux_top_transitive_interface: not converged.' end if @@ -3157,7 +3195,7 @@ subroutine flux_btm_transitive_interface ( & iter = iter + 1 end do -#if (defined SoilWaterDebug) +#if (defined CoLMDEBUG) if (iter == 50) then write(*,*) 'Warning : flux_btm_transitive_interface: not converged.' end if @@ -3318,7 +3356,7 @@ subroutine flux_both_transitive_interface ( & iter = iter + 1 end do -#if (defined SoilWaterDebug) +#if (defined CoLMDEBUG) if (iter == 50) then write(*,*) 'Warning : flux_both_transitive_interface: not converged.' end if @@ -3388,7 +3426,7 @@ subroutine get_zwt_from_wa ( & iter = iter + 1 end do -#if (defined SoilWaterDebug) +#if (defined CoLMDEBUG) if (iter == 50) then write(*,*) 'Warning : get_zwt_from_wa: not converged.' end if @@ -3504,10 +3542,13 @@ subroutine secant_method_iteration ( & x_k2 = x_k1 x_k1 = x_i - x_i = (fval_k1 * x_k2 - fval_k2 * x_k1) / (fval_k1 - fval_k2) - - x_i = max(x_i, x_l * alp + x_r * (1.0_r8 - alp)) - x_i = min(x_i, x_l * (1.0_r8 - alp) + x_r * alp) + IF (fval_k1 == fval_k2) THEN + x_i = (x_l + x_r) * 0.5_r8 + ELSE + x_i = (fval_k1 * x_k2 - fval_k2 * x_k1) / (fval_k1 - fval_k2) + x_i = max(x_i, x_l * alp + x_r * (1.0_r8 - alp)) + x_i = min(x_i, x_l * (1.0_r8 - alp) + x_r * alp) + ENDIF end subroutine secant_method_iteration @@ -3533,32 +3574,62 @@ integer function find_unsat_lev_lower (is_sat, lb, ub, ilev) end function find_unsat_lev_lower ! ----- - SUBROUTINE print_iteration_stat_info () + SUBROUTINE print_VSF_iteration_stat_info () USE MOD_SPMD_Task IMPLICIT NONE + + INTEGER(8), SAVE :: count_implicit_accum = 0 + INTEGER(8), SAVE :: count_explicit_accum = 0 + INTEGER(8), SAVE :: count_wet2dry_accum = 0 + integer :: iwork - CHARACTER(len=20) :: fmtt - -#ifdef SoilWaterDebug +#ifdef CoLMDEBUG IF (p_is_worker) THEN #ifdef USEMPI - CALL mpi_allreduce (MPI_IN_PLACE, count_iters_this, size(count_iters_this), & - MPI_INTEGER8, MPI_SUM, p_comm_worker, p_err) + CALL mpi_allreduce (MPI_IN_PLACE, count_implicit, 1, MPI_INTEGER8, MPI_SUM, p_comm_worker, p_err) + CALL mpi_allreduce (MPI_IN_PLACE, count_explicit, 1, MPI_INTEGER8, MPI_SUM, p_comm_worker, p_err) + CALL mpi_allreduce (MPI_IN_PLACE, count_wet2dry , 1, MPI_INTEGER8, MPI_SUM, p_comm_worker, p_err) #endif IF (p_iam_worker == 0) THEN - write(*,*) - write(fmtt,'("(A,",I1,"I12)")') max_iters_richards - write(*,fmtt) 'VSF Iteration stat this step: ', count_iters_this(:) - - count_iters_accm = count_iters_accm + count_iters_this - write(*,fmtt) 'VSF Iteration stat all steps: ', count_iters_accm(:) + count_implicit_accum = count_implicit_accum + count_implicit + count_explicit_accum = count_explicit_accum + count_explicit + count_wet2dry_accum = count_wet2dry_accum + count_wet2dry + +#ifdef USEMPI + CALL mpi_send (count_implicit, 1, MPI_INTEGER, 0, mpi_tag_mesg, p_comm_glb, p_err) + CALL mpi_send (count_explicit, 1, MPI_INTEGER, 0, mpi_tag_mesg, p_comm_glb, p_err) + CALL mpi_send (count_wet2dry, 1, MPI_INTEGER, 0, mpi_tag_mesg, p_comm_glb, p_err) + CALL mpi_send (count_implicit_accum, 1, MPI_INTEGER, 0, mpi_tag_mesg, p_comm_glb, p_err) + CALL mpi_send (count_explicit_accum, 1, MPI_INTEGER, 0, mpi_tag_mesg, p_comm_glb, p_err) + CALL mpi_send (count_wet2dry_accum, 1, MPI_INTEGER, 0, mpi_tag_mesg, p_comm_glb, p_err) +#endif ENDIF - - count_iters_this = 0 ENDIF + + IF (p_is_master) THEN + +#ifdef USEMPI + iwork = p_address_worker(0) + CALL mpi_recv (count_implicit, 1, MPI_INTEGER, iwork, mpi_tag_mesg, p_comm_glb, p_stat, p_err) + CALL mpi_recv (count_explicit, 1, MPI_INTEGER, iwork, mpi_tag_mesg, p_comm_glb, p_stat, p_err) + CALL mpi_recv (count_wet2dry , 1, MPI_INTEGER, iwork, mpi_tag_mesg, p_comm_glb, p_stat, p_err) + CALL mpi_recv (count_implicit_accum, 1, MPI_INTEGER, iwork, mpi_tag_mesg, p_comm_glb, p_stat, p_err) + CALL mpi_recv (count_explicit_accum, 1, MPI_INTEGER, iwork, mpi_tag_mesg, p_comm_glb, p_stat, p_err) + CALL mpi_recv (count_wet2dry_accum , 1, MPI_INTEGER, iwork, mpi_tag_mesg, p_comm_glb, p_stat, p_err) #endif - END SUBROUTINE print_iteration_stat_info + write(*,"(/,A,I13,A,I13,A,I13,A)") 'VSF scheme this step: ', & + count_implicit, ' (implicit)', count_explicit, ' (explicit)', count_wet2dry, ' (wet2dry)' + write(*,"(A,I13,A,I13,A,I13,A)") 'VSF scheme all steps: ', & + count_implicit_accum, ' (implicit)', count_explicit_accum, ' (explicit)', & + count_wet2dry_accum, ' (wet2dry)' + ENDIF + + count_implicit = 0 + count_explicit = 0 + count_wet2dry = 0 +#endif + END SUBROUTINE print_VSF_iteration_stat_info end module MOD_Hydro_SoilWater diff --git a/main/HYDRO/MOD_Hydro_Vars_1DFluxes.F90 b/main/HYDRO/MOD_Hydro_Vars_1DFluxes.F90 index 609f5283..60b60a33 100644 --- a/main/HYDRO/MOD_Hydro_Vars_1DFluxes.F90 +++ b/main/HYDRO/MOD_Hydro_Vars_1DFluxes.F90 @@ -1,6 +1,6 @@ #include -#ifdef LATERAL_FLOW +#ifdef CatchLateralFlow MODULE MOD_Hydro_Vars_1DFluxes !------------------------------------------------------------------------------------- ! DESCRIPTION: @@ -14,9 +14,9 @@ MODULE MOD_Hydro_Vars_1DFluxes IMPLICIT NONE ! -- fluxes -- - REAL(r8), allocatable :: rsubs_bsn (:) ! subsurface lateral flow between basins [m/s] - REAL(r8), allocatable :: rsubs_hru (:) ! subsurface lateral flow between hydrological response units [m/s] - REAL(r8), allocatable :: rsubs_pch (:) ! subsurface lateral flow between patches inside one HRU [m/s] + REAL(r8), allocatable :: xsubs_bsn (:) ! subsurface lateral flow between basins [m/s] + REAL(r8), allocatable :: xsubs_hru (:) ! subsurface lateral flow between hydrological response units [m/s] + REAL(r8), allocatable :: xsubs_pch (:) ! subsurface lateral flow between patches inside one HRU [m/s] REAL(r8), allocatable :: wdsrf_bsn_ta (:) ! time step average of river height [m] REAL(r8), allocatable :: momen_riv_ta (:) ! time step average of river momentum [m^2/s] @@ -25,11 +25,15 @@ MODULE MOD_Hydro_Vars_1DFluxes REAL(r8), allocatable :: wdsrf_hru_ta (:) ! time step average of surface water depth [m] REAL(r8), allocatable :: momen_hru_ta (:) ! time step average of surface water momentum [m^2/s] REAL(r8), allocatable :: veloc_hru_ta (:) ! time step average of surface water veloctiy [m/s] + + REAL(r8), allocatable :: xwsur (:) ! surface water exchange [mm h2o/s] + REAL(r8), allocatable :: xwsub (:) ! subsurface water exchange [mm h2o/s] + + REAL(r8), allocatable :: discharge (:) ! river discharge [m^3/s] ! PUBLIC MEMBER FUNCTIONS: PUBLIC :: allocate_1D_HydroFluxes PUBLIC :: deallocate_1D_HydroFluxes - PUBLIC :: set_1D_HydroFluxes CONTAINS @@ -48,16 +52,19 @@ SUBROUTINE allocate_1D_HydroFluxes IF (p_is_worker) THEN IF (numpatch > 0) THEN - allocate (rsubs_pch (numpatch)) ; rsubs_pch (:) = spval + allocate (xsubs_pch (numpatch)) ; xsubs_pch (:) = spval + allocate (xwsur (numpatch)) ; xwsur (:) = spval + allocate (xwsub (numpatch)) ; xwsub (:) = spval ENDIF IF (numbasin > 0) THEN - allocate (rsubs_bsn (numbasin)) ; rsubs_bsn (:) = spval + allocate (xsubs_bsn (numbasin)) ; xsubs_bsn (:) = spval allocate (wdsrf_bsn_ta (numbasin)) ; wdsrf_bsn_ta (:) = spval allocate (momen_riv_ta (numbasin)) ; momen_riv_ta (:) = spval allocate (veloc_riv_ta (numbasin)) ; veloc_riv_ta (:) = spval + allocate (discharge (numbasin)) ; discharge (:) = spval ENDIF IF (numhru > 0) THEN - allocate (rsubs_hru (numhru)) ; rsubs_hru (:) = spval + allocate (xsubs_hru (numhru)) ; xsubs_hru (:) = spval allocate (wdsrf_hru_ta (numhru)) ; wdsrf_hru_ta (:) = spval allocate (momen_hru_ta (numhru)) ; momen_hru_ta (:) = spval allocate (veloc_hru_ta (numhru)) ; veloc_hru_ta (:) = spval @@ -70,9 +77,9 @@ SUBROUTINE deallocate_1D_HydroFluxes IMPLICIT NONE - IF (allocated(rsubs_pch)) deallocate(rsubs_pch) - IF (allocated(rsubs_hru)) deallocate(rsubs_hru) - IF (allocated(rsubs_bsn)) deallocate(rsubs_bsn) + IF (allocated(xsubs_pch)) deallocate(xsubs_pch) + IF (allocated(xsubs_hru)) deallocate(xsubs_hru) + IF (allocated(xsubs_bsn)) deallocate(xsubs_bsn) IF (allocated(wdsrf_bsn_ta)) deallocate(wdsrf_bsn_ta) IF (allocated(momen_riv_ta)) deallocate(momen_riv_ta) @@ -81,40 +88,13 @@ SUBROUTINE deallocate_1D_HydroFluxes IF (allocated(wdsrf_hru_ta)) deallocate(wdsrf_hru_ta) IF (allocated(momen_hru_ta)) deallocate(momen_hru_ta) IF (allocated(veloc_hru_ta)) deallocate(veloc_hru_ta) + + IF (allocated(xwsur)) deallocate(xwsur) + IF (allocated(xwsub)) deallocate(xwsub) - END SUBROUTINE deallocate_1D_HydroFluxes - - SUBROUTINE set_1D_HydroFluxes - - USE MOD_SPMD_Task - USE MOD_Mesh, only : numelm - USE MOD_LandHRU, only : numhru - USE MOD_LandPatch, only : numpatch - IMPLICIT NONE - - INTEGER :: numbasin - - numbasin = numelm - - IF (p_is_worker) THEN - IF (numpatch > 0) THEN - rsubs_pch (:) = 0._r8 - ENDIF - IF (numbasin > 0) THEN - rsubs_bsn (:) = 0._r8 - wdsrf_bsn_ta (:) = 0._r8 - momen_riv_ta (:) = 0._r8 - veloc_riv_ta (:) = 0._r8 - ENDIF - IF (numhru > 0) THEN - rsubs_hru (:) = 0._r8 - wdsrf_hru_ta (:) = 0._r8 - momen_hru_ta (:) = 0._r8 - veloc_hru_ta (:) = 0._r8 - ENDIF - ENDIF + IF (allocated(discharge)) deallocate(discharge) - END SUBROUTINE set_1D_HydroFluxes + END SUBROUTINE deallocate_1D_HydroFluxes END MODULE MOD_Hydro_Vars_1DFluxes #endif diff --git a/main/HYDRO/MOD_Hydro_Vars_TimeVariables.F90 b/main/HYDRO/MOD_Hydro_Vars_TimeVariables.F90 index 5e031bb3..5b5f5b7e 100644 --- a/main/HYDRO/MOD_Hydro_Vars_TimeVariables.F90 +++ b/main/HYDRO/MOD_Hydro_Vars_TimeVariables.F90 @@ -1,6 +1,6 @@ #include -#ifdef LATERAL_FLOW +#ifdef CatchLateralFlow MODULE MOD_Hydro_Vars_TimeVariables !------------------------------------------------------------------------------------- ! DESCRIPTION: @@ -78,9 +78,11 @@ SUBROUTINE READ_HydroTimeVariables (file_restart) CALL vector_read_basin (file_restart, wdsrf_bsn, numbasin, 'wdsrf_bsn', elm_data_address) CALL vector_read_basin (file_restart, veloc_riv, numbasin, 'veloc_riv', elm_data_address) + CALL vector_read_basin (file_restart, wdsrf_bsn_prev, numbasin, 'wdsrf_bsn_prev', elm_data_address) CALL vector_read_basin (file_restart, wdsrf_hru, numhru, 'wdsrf_hru', hru_data_address) CALL vector_read_basin (file_restart, veloc_hru, numhru, 'veloc_hru', hru_data_address) + CALL vector_read_basin (file_restart, wdsrf_hru_prev, numhru, 'wdsrf_hru_prev', hru_data_address) END SUBROUTINE READ_HydroTimeVariables @@ -128,6 +130,12 @@ SUBROUTINE WRITE_HydroTimeVariables (file_restart) CALL vector_write_basin (& file_restart, veloc_hru, numhru, totalnumhru, 'veloc_hru', 'hydrounit', hru_data_address) + + CALL vector_write_basin (& + file_restart, wdsrf_bsn_prev, numbasin, totalnumelm, 'wdsrf_bsn_prev', 'basin', elm_data_address) + + CALL vector_write_basin (& + file_restart, wdsrf_hru_prev, numhru, totalnumhru, 'wdsrf_hru_prev', 'hydrounit', hru_data_address) END SUBROUTINE WRITE_HydroTimeVariables diff --git a/main/LULCC/MOD_Lulcc_Driver.F90 b/main/LULCC/MOD_Lulcc_Driver.F90 index e174c2d7..81136202 100644 --- a/main/LULCC/MOD_Lulcc_Driver.F90 +++ b/main/LULCC/MOD_Lulcc_Driver.F90 @@ -1,7 +1,6 @@ #include #ifdef LULCC - MODULE MOD_Lulcc_Driver !----------------------------------------------------------------------- @@ -15,7 +14,7 @@ MODULE MOD_Lulcc_Driver !----------------------------------------------------------------------- - CONTAINS + CONTAINS !----------------------------------------------------------------------- @@ -24,12 +23,17 @@ MODULE MOD_Lulcc_Driver SUBROUTINE LulccDriver (casename,dir_landdata,dir_restart,& idate,greenwich) -!======================================================================= -! PURPOSE: +! ====================================================================== +! !PURPOSE: ! the main subroutine for Land use and land cover change simulation ! ! Created by Hua Yuan, 04/08/2022 -!======================================================================= +! +! !REVISONS: +! 07/2023, Wenzong Dong: porting to MPI version. +! 08/2023, Wanyi Lin: add interface for Mass&Energy conserved scheme. +! +! ====================================================================== USE MOD_Precision USE MOD_SPMD_Task @@ -37,15 +41,18 @@ SUBROUTINE LulccDriver (casename,dir_landdata,dir_restart,& USE MOD_Lulcc_Vars_TimeVariables USE MOD_Lulcc_Initialize USE MOD_Vars_TimeVariables + USE MOD_Lulcc_TransferTrace + USE MOD_Lulcc_MassEnergyConserve + USE MOD_Namelist IMPLICIT NONE - CHARACTER(LEN=256), intent(in) :: casename !casename name - CHARACTER(LEN=256), intent(in) :: dir_landdata !surface data directory - CHARACTER(LEN=256), intent(in) :: dir_restart !case restart data directory + character(LEN=256), intent(in) :: casename !casename name + character(LEN=256), intent(in) :: dir_landdata !surface data directory + character(LEN=256), intent(in) :: dir_restart !case restart data directory - LOGICAL, intent(in) :: greenwich !true: greenwich time, false: local time - INTEGER, intent(inout) :: idate(3) !year, julian day, seconds of the starting time + logical, intent(in) :: greenwich !true: greenwich time, false: local time + integer, intent(inout) :: idate(3) !year, julian day, seconds of the starting time ! allocate Lulcc memory CALL allocate_LulccTimeInvariants @@ -55,7 +62,10 @@ SUBROUTINE LulccDriver (casename,dir_landdata,dir_restart,& CALL SAVE_LulccTimeInvariants CALL SAVE_LulccTimeVariables + ! ============================================================= ! cold start for Lulcc + ! ============================================================= + IF (p_is_master) THEN print *, ">>> LULCC: initializing..." ENDIF @@ -63,27 +73,43 @@ SUBROUTINE LulccDriver (casename,dir_landdata,dir_restart,& CALL LulccInitialize (casename,dir_landdata,dir_restart,& idate,greenwich) + + ! ============================================================= ! simple method for variable recovery - IF (p_is_master) THEN - print *, ">>> LULCC: simple method for variable recovery..." + ! ============================================================= + + IF (DEF_LULCC_SCHEME == 1) THEN + IF (p_is_master) THEN + print *, ">>> LULCC: simple method for variable recovery..." + ENDIF + CALL REST_LulccTimeVariables ENDIF - CALL REST_LulccTimeVariables + + ! ============================================================= ! conserved method for variable revocery - !print *, ">>> LULCC: Mass&Energy conserve for variable recovery..." - !CALL READ_LulccTMatrix() - !CALL LulccEnergyConserve() - !CALL LulccWaterConserve() + ! ============================================================= + + IF (DEF_LULCC_SCHEME == 2) THEN + IF (p_is_master) THEN + print *, ">>> LULCC: Mass&Energy conserve for variable recovery..." + ENDIF + CALL allocate_LulccTransferTrace() + CALL REST_LulccTimeVariables + CALL MAKE_LulccTransferTrace(idate(1)) + CALL LulccMassEnergyConserve() + ENDIF + ! deallocate Lulcc memory CALL deallocate_LulccTimeInvariants() CALL deallocate_LulccTimeVariables() - - ! write out state variables - CALL WRITE_TimeVariables (idate, idate(1), casename, dir_restart) + IF (DEF_LULCC_SCHEME == 2) THEN + CALL deallocate_LulccTransferTrace() + ENDIF END SUBROUTINE LulccDriver END MODULE MOD_Lulcc_Driver - #endif +! ---------- EOP ------------ diff --git a/main/LULCC/MOD_Lulcc_EnergyConserve.F90 b/main/LULCC/MOD_Lulcc_EnergyConserve.F90 deleted file mode 100644 index 1ce3952a..00000000 --- a/main/LULCC/MOD_Lulcc_EnergyConserve.F90 +++ /dev/null @@ -1,25 +0,0 @@ -#include - - SUBROUTINE LulccEnergyConserve -! ------------------------------- -! Created by Hua Yuan, 04/2022 -! ------------------------------- - - USE MOD_Precision - USE MOD_Vars_Global - USE MOD_Vars_TimeInvariants - USE MOD_Vars_PFTimeInvariants - USE MOD_Vars_PCTimeInvariants - USE MOD_Urban_Vars_TimeInvariants - USE MOD_Lulcc_Vars_TimeInvariants - USE MOD_Vars_TimeVariables - USE MOD_Vars_PFTimeVariables - USE MOD_Vars_PCTimeVariables - USE MOD_Urban_Vars_TimeVariables - USE MOD_Lulcc_Vars_TimeVariables - - IMPLICIT NONE -!TODO: need coding below... - - END SUBROUTINE LulccEnergyConserve -! ---------- EOP ------------ diff --git a/main/LULCC/MOD_Lulcc_Initialize.F90 b/main/LULCC/MOD_Lulcc_Initialize.F90 index 4940f2b6..4bbcb978 100644 --- a/main/LULCC/MOD_Lulcc_Initialize.F90 +++ b/main/LULCC/MOD_Lulcc_Initialize.F90 @@ -21,6 +21,11 @@ SUBROUTINE LulccInitialize (casename,dir_landdata,dir_restart,& ! ! Initialization routine for Land-use-Land-cover-change (Lulcc) case ! +! Created by Hua Yuan, 04/08/2022 +! +! !REVISONS: +! 08/2023, Wenzong Dong: porting to MPI version and share the same code with +! MOD_Initialize:initialize ! ====================================================================== USE MOD_Precision @@ -29,15 +34,22 @@ SUBROUTINE LulccInitialize (casename,dir_landdata,dir_restart,& USE MOD_Mesh USE MOD_LandElm USE MOD_LandPatch +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + USE MOD_LandPFT +#endif + USE MOD_LandUrban USE MOD_Const_LC USE MOD_Const_PFT - use MOD_TimeManager + USE MOD_TimeManager USE MOD_Lulcc_Vars_TimeInvariants USE MOD_Lulcc_Vars_TimeVariables USE MOD_SrfdataRestart USE MOD_Vars_TimeInvariants USE MOD_Vars_TimeVariables USE MOD_Initialize +#ifdef SrfdataDiag + USE MOD_SrfdataDiag, only : gdiag, srfdata_diag_init +#endif IMPLICIT NONE @@ -50,7 +62,7 @@ SUBROUTINE LulccInitialize (casename,dir_landdata,dir_restart,& logical, intent(in) :: greenwich ! true: greenwich time, false: local time ! local vars - INTEGER :: year, jday + integer :: year, jday ! ---------------------------------------------------------------------- ! initial time of model run @@ -64,47 +76,44 @@ SUBROUTINE LulccInitialize (casename,dir_landdata,dir_restart,& CAll Init_LC_Const CAll Init_PFT_Const - ! deallocate pixelset and mesh data of previous + ! deallocate pixelset and mesh data of previous year CALL mesh_free_mem CALL landelm%forc_free_mem CALL landpatch%forc_free_mem -#ifdef LULC_IGBP_PFT +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) CALL landpft%forc_free_mem #endif -#ifdef LULC_IGBP_PC - CALL landpc%forc_free_mem -#endif #ifdef URBAN_MODEL CALL landurban%forc_free_mem #endif ! load pixelset and mesh data of next year - ! call pixel%load_from_file (dir_landdata) - ! call gblock%load_from_file (dir_landdata) - call mesh_load_from_file (dir_landdata, year) + ! CALL pixel%load_from_file (dir_landdata) + ! CALL gblock%load_from_file (dir_landdata) + CALL mesh_load_from_file (dir_landdata, year) CALL pixelset_load_from_file (dir_landdata, 'landelm' , landelm , numelm , year) + ! load CATCHMENT of next year #ifdef CATCHMENT CALL pixelset_load_from_file (dir_landdata, 'landhru' , landhru , numhru , year) #endif - call pixelset_load_from_file (dir_landdata, 'landpatch', landpatch, numpatch, year) + ! load landpatch data of next year + CALL pixelset_load_from_file (dir_landdata, 'landpatch', landpatch, numpatch, year) -#ifdef LULC_IGBP_PFT - call pixelset_load_from_file (dir_landdata, 'landpft' , landpft , numpft , year) + ! load pft data of PFT/PC of next year +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + CALL pixelset_load_from_file (dir_landdata, 'landpft' , landpft , numpft , year) CALL map_patch_to_pft #endif -#ifdef LULC_IGBP_PC - call pixelset_load_from_file (dir_landdata, 'landpc' , landpc , numpc , year) - CALL map_patch_to_pc -#endif - + ! load urban data of next year #ifdef URBAN_MODEL CALL pixelset_load_from_file (dir_landdata, 'landurban', landurban, numurban, year) CALL map_patch_to_urban #endif + ! initialize for data associated with land element #if (defined UNSTRUCTURED || defined CATCHMENT) CALL elm_vector_init () #ifdef CATCHMENT @@ -112,12 +121,29 @@ SUBROUTINE LulccInitialize (casename,dir_landdata,dir_restart,& #endif #endif + ! build element subfraction of next year which it's needed in the MOD_Lulcc_TransferTrace + IF (p_is_worker) THEN + CALL elm_patch%build (landelm, landpatch, use_frac = .true.) + ENDIF + + ! initialize for SrfdataDiag, it is needed in the MOD_Lulcc_TransferTrace for outputing transfer_matrix +#ifdef SrfdataDiag +#ifdef GRIDBASED + CALL init_gridbased_mesh_grid () + CALL gdiag%define_by_copy (gridmesh) +#else + CALL gdiag%define_by_ndims(3600,1800) +#endif + CALL srfdata_diag_init (dir_landdata) +#endif + ! -------------------------------------------------------------------- ! Deallocates memory for CoLM 1d [numpatch] variables ! -------------------------------------------------------------------- CALL deallocate_TimeInvariants CALL deallocate_TimeVariables + ! initialize all state variables of next year CALL initialize (casename,dir_landdata,dir_restart,& idate,year,greenwich,lulcc_call=.true.) @@ -125,3 +151,4 @@ END SUBROUTINE LulccInitialize END MODULE MOD_Lulcc_Initialize #endif +! ---------- EOP ------------ diff --git a/main/LULCC/MOD_Lulcc_MassEnergyConserve.F90 b/main/LULCC/MOD_Lulcc_MassEnergyConserve.F90 new file mode 100644 index 00000000..92e76d05 --- /dev/null +++ b/main/LULCC/MOD_Lulcc_MassEnergyConserve.F90 @@ -0,0 +1,934 @@ +#include + +#ifdef LULCC +MODULE MOD_Lulcc_MassEnergyConserve + +!----------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: LulccMassEnergyConserve + + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + + SUBROUTINE LulccMassEnergyConserve +! ====================================================================== +! +! Created by Wanyi Lin and Hua Yuan, 07/2023 +! +! !DESCRIPTION +! This is the main subroutine to execute the calculation of the restart +! variables for the begin of next year. +! There are mainly three ways to adjust restart variables: +! +! 1) variable related to mass: area weighted mean of the source patches, +! e.g., ldew, wliq_soisno. +! variable related to energy: keep energy conserve after the change +! of temperature, e.g., t_soisno. +! +! 2) recalculate according to physical process, e.g., dz_sno, scv, fsno. +! +! !REVISONS: +! +! 10/2023, Wanyi Lin: share the codes with REST_LulccTimeVariables(), and +! simply the codes in this subroutine. +! +! ====================================================================== + + + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_LandPatch + USE MOD_LandElm + USE MOD_Mesh + USE MOD_SPMD_Task + USE MOD_Vars_TimeInvariants + USE MOD_Vars_TimeVariables + USE MOD_Lulcc_Vars_TimeInvariants + USE MOD_Lulcc_Vars_TimeVariables + USE MOD_Lulcc_TransferTrace +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + USE MOD_LandPFT + USE MOD_Vars_PFTimeInvariants + USE MOD_Vars_PFTimeVariables +#endif +#ifdef URBAN_MODEL + USE MOD_LandUrban + USE MOD_Urban_Vars_TimeVariables + USE MOD_Urban_Vars_TimeInvariants +#endif + USE MOD_Const_Physical, only: cpice, cpliq, denh2o, denice + USE MOD_GroundTemperature + USE MOD_SnowFraction + USE MOD_Albedo + USE MOD_Namelist + + IMPLICIT NONE + + integer, allocatable, dimension(:) :: grid_patch_s , grid_patch_e + integer, allocatable, dimension(:) :: grid_patch_s_, grid_patch_e_ + integer, allocatable, dimension(:) :: locpxl + integer :: numpxl,ipxl + + integer, allocatable :: frnp_(:) !index of source patches + integer, allocatable :: gu_(:) !index of urban patches in last year's grid + real(r8),allocatable :: cvsoil_(:,:) !heat capacity [J/(m2 K)] + + integer :: k, ilc, num, inp_ + integer :: i, j, np, np_, selfnp_, l, ipft, ip, ip_, pc, pc_ + integer :: nsl !number of snow layer of the source patch with maximum area + integer :: nsl_max !maximum number of snow layer considering all source patches + integer :: u, u_, iu, selfu_, nurb, duclass + integer :: nlc = N_land_classification + integer :: ps, pe, ps_, pe_ !start and end index of patch pft + + real(r8), dimension(1:N_land_classification) :: lccpct_np + real(r8):: sum_lccpct_np, wgt(maxsnl+1:nl_soil) + real(r8):: zi_sno(maxsnl+1:0) !local variable for snow node and depth calculation + real(r8):: vf_water !volumetric fraction liquid water within soil + real(r8):: vf_ice !volumetric fraction ice len within soil + real(r8):: hcap !J/(m3 K) + real(r8):: c_water !Specific heat of water * density of liquid water + real(r8):: c_ice !Specific heat of ice * density of ice + real(r8):: denice_np(maxsnl+1:0), denh2o_np(maxsnl+1:0) + real(r8):: wbef,wpre !water before and water present for water calculation heck + ! real(r8):: fmelt !dimensionless metling factor + real(r8):: wt !fraction of vegetation covered with snow [-] + real(r8), parameter :: m = 1.0 !the value of m used in CLM4.5 is 1.0. + ! real(r8) :: deltim = 1800. !time step (senconds) TODO: be intent in + logical :: FROM_SOIL + + IF (p_is_worker) THEN + + ! allocate with numelm + allocate(grid_patch_s (numelm )) + allocate(grid_patch_e (numelm )) + allocate(grid_patch_s_(numelm_)) + allocate(grid_patch_e_(numelm_)) + + grid_patch_e (:) = -1 + grid_patch_s (:) = -1 + grid_patch_e_(:) = -1 + grid_patch_s_(:) = -1 + + ! loop for numelm of next year, patches at the beginning and end of + ! the element were recorded landpatch%eindex is arranged in order, + ! and the not land element is skipped so, if element is missing, the + ! recorder is -1. + DO i=1, numelm + ! how many patches in ith element in this worker + numpxl = count(landpatch%eindex==landelm%eindex(i)) + + IF (allocated(locpxl)) deallocate(locpxl) + allocate(locpxl(numpxl)) + + ! get all patches' index that eindex is equal the i element + locpxl = pack([(ipxl, ipxl=1, numpatch)], landpatch%eindex==landelm%eindex(i)) + ! the min index is the start of patch's index + grid_patch_s(i) = minval(locpxl) + ! the max index is the end of patch's index + grid_patch_e(i) = maxval(locpxl) + ENDDO + + ! same as above, loop for numelm of previous year + ! patches at the beginning and end of the element were recorded + DO i=1, numelm_ + numpxl = count(landpatch_%eindex==landelm_%eindex(i)) + + IF (allocated(locpxl)) deallocate(locpxl) + allocate(locpxl(numpxl)) + + locpxl = pack([(ipxl, ipxl=1, numpatch_)], landpatch_%eindex==landelm_%eindex(i)) + + grid_patch_s_(i) = minval(locpxl) + grid_patch_e_(i) = maxval(locpxl) + ENDDO + + DO i=1, numelm + DO j=1,numelm_ + IF (landelm%eindex(i) == landelm_%eindex(j)) THEN + np = grid_patch_s (i) + np_= grid_patch_s_(j) + + IF (np.le.0) CYCLE + + DO WHILE (np.le.grid_patch_e(i)) + +IF (patchtype(np) .ne. 3) THEN !not a glacier patch + +IF (DEF_USE_PFT .or. DEF_FAST_PC) THEN + lccpct_np(:) = 0 + lccpct_np(1) = sum(lccpct_patches(np,1:), mask=patchtypes(:)==0) + lccpct_np(URBAN ) = lccpct_patches(np,URBAN ) + lccpct_np(WETLAND) = lccpct_patches(np,WETLAND) + lccpct_np(WATERBODY) = lccpct_patches(np,WATERBODY) +ELSE + lccpct_np(:) = lccpct_patches(np,1:nlc) +ENDIF + + num = count(lccpct_np .gt. 0) + sum_lccpct_np = sum(lccpct_np) + allocate ( frnp_ ( num)) + allocate ( cvsoil_(maxsnl+1:nl_soil,num)) + + ! Source patch type which differs from np's type exists + IF ( (sum_lccpct_np - lccpct_np(patchclass(np))) .gt. 0 ) THEN + + ! Get the index of source patches, and stored as frnp_ + k = 0 + DO ilc = 1, nlc + + IF (lccpct_np(ilc) .gt. 0) THEN + k = k + 1 + inp_ = np_ + + DO WHILE (inp_ .le. grid_patch_e_(j)) + + ! Get the index of source patch that has the same LC, and stored as selfnp_ + IF (patchclass_(inp_) .eq. patchclass(np)) THEN + selfnp_ = inp_ + ENDIF + + IF (patchclass_(inp_) .eq. ilc) THEN + frnp_(k) = inp_ + EXIT + ENDIF + inp_ = inp_ + 1 + ENDDO + + ELSE + CYCLE + ENDIF + ENDDO + + ! Initialize + wliq_soisno (:,np) = 0 !liquid water in layers [kg/m2] + wice_soisno (:,np) = 0 !ice lens in layers [kg/m2] + t_soisno (:,np) = 0 !soil + snow layer temperature [K] + z_sno (:,np) = 0 !node depth [m] + dz_sno (:,np) = 0 !interface depth [m] + t_grnd (np) = 0 !ground surface temperature [K] + tleaf (np) = 0 !leaf temperature [K] + ldew (np) = 0 !depth of water on foliage [mm] + ldew_rain (np) = 0 !depth of rain on foliage [mm] + ldew_snow (np) = 0 !depth of snow on foliage [mm] + sag (np) = 0 !non dimensional snow age [-] + scv (np) = 0 !snow cover, water equivalent [mm] + snowdp (np) = 0 !snow depth [meter] + fsno (np) = 0 !fraction of snow cover on ground + sigf (np) = 0 !fraction of veg cover, excluding snow-covered veg [-] + zwt (np) = 0 !the depth to water table [m] + wa (np) = 0 !water storage in aquifer [mm] + wdsrf (np) = 0 !depth of surface water [mm] + smp (:,np) = 0 !soil matrix potential [mm] + hk (:,np) = 0 !hydraulic conductivity [mm h2o/s] + + IF(DEF_USE_PLANTHYDRAULICS)THEN + vegwp (:,np) = 0 !vegetation water potential [mm] + gs0sun (np) = 0 !working copy of sunlit stomata conductance + gs0sha (np) = 0 !working copy of shalit stomata conductance + ENDIF + + IF(DEF_USE_OZONESTRESS)THEN + lai_old (np) = 0 !lai in last time step + ENDIF + + snw_rds (:,np) = 0 !effective grain radius (col,lyr) [microns, m-6] + mss_bcpho (:,np) = 0 !mass of hydrophobic BC in snow (col,lyr) [kg] + mss_bcphi (:,np) = 0 !mass of hydrophillic BC in snow (col,lyr) [kg] + mss_ocpho (:,np) = 0 !mass of hydrophobic OC in snow (col,lyr) [kg] + mss_ocphi (:,np) = 0 !mass of hydrophillic OC in snow (col,lyr) [kg] + mss_dst1 (:,np) = 0 !mass of dust species 1 in snow (col,lyr) [kg] + mss_dst2 (:,np) = 0 !mass of dust species 2 in snow (col,lyr) [kg] + mss_dst3 (:,np) = 0 !mass of dust species 3 in snow (col,lyr) [kg] + mss_dst4 (:,np) = 0 !mass of dust species 4 in snow (col,lyr) [kg] + ssno_lyr(:,:,:,np) = 0 !snow layer absorption [-] + + trad (np) = 0 !radiative temperature of surface [K] + tref (np) = 0 !2 m height air temperature [kelvin] + qref (np) = 0 !2 m height air specific humidity + rst (np) = 0 !canopy stomatal resistance (s/m) + emis (np) = 0 !averaged bulk surface emissivity + z0m (np) = 0 !effective roughness [m] + zol (np) = 0 !dimensionless height (z/L) used in Monin-Obukhov theory + rib (np) = 0 !bulk Richardson number in surface layer + ustar (np) = 0 !u* in similarity theory [m/s] + qstar (np) = 0 !q* in similarity theory [kg/kg] + tstar (np) = 0 !t* in similarity theory [K] + fm (np) = 0 !integral of profile function for momentum + fh (np) = 0 !integral of profile function for heat + fq (np) = 0 !integral of profile function for moisture + + + ! ============================================================= + ! 1) Mass and Energy conserve adjustment (except for dz_sno). + ! ============================================================= + + ! Calculate the weight of temperature adjustment + c_water = cpliq * denh2o ! J/(m3 K) = 4188 [J/(kg K)]*1000(kg/m3) + c_ice = cpice * denice ! J/(m3 K) = 2117.27[J/(kg K)]*917 (kg/m3) + cvsoil_(:,:) = 0 + wgt(maxsnl+1:nl_soil) = 0 + + DO k = 1, num + + ! Soil ground and wetland heat capacity + DO l = 1, nl_soil + vf_water = wliq_soisno_(l,frnp_(k))/(dz_soi(l)*denh2o) + vf_ice = wice_soisno_(l,frnp_(k))/(dz_soi(l)*denice) + hcap = csol_(l,frnp_(k)) + vf_water*c_water + vf_ice*c_ice + cvsoil_(l,k) = hcap*dz_soi(l) + ENDDO + + ! no snow layer exist + IF( dz_sno_(0,frnp_(k))<1.e-6 .and. scv_(frnp_(k))>0.) THEN + cvsoil_(1,k) = cvsoil_(1,k) + cpice*scv_(frnp_(k)) + ENDIF + + ! Snow heat capacity + IF( z_sno_(0,frnp_(k)) < 0 ) THEN + cvsoil_(:0,k) = cpliq*wliq_soisno_(:0,frnp_(k)) + cpice*wice_soisno_(:0,frnp_(k)) + ENDIF + + wgt(maxsnl+1:nl_soil) = wgt(maxsnl+1:nl_soil) & + + cvsoil_(maxsnl+1:nl_soil,k) * lccpct_np(patchclass_(frnp_(k))) + ENDDO + + ! Get the maximum lccpct for snow layers assignment + inp_ = frnp_(1) + k = 2 + DO WHILE (k .le. num) + IF ( lccpct_np(patchclass_(frnp_(k))) .gt. lccpct_np(patchclass_(inp_)) ) THEN + inp_ = frnp_(k) + ENDIF + k = k + 1 + ENDDO + + ! check if snow layer exist in patch inp_ + nsl = count(z_sno_(:,inp_) .lt. 0) + nsl_max = count(wgt(:0) .gt. 0) + denh2o_np(maxsnl+1:0) = 0 + denice_np(maxsnl+1:0) = 0 + + IF (nsl > 0) THEN + ! move wgt above nsl to nsl + IF ( nsl_max > nsl) THEN + DO l = nsl+1, nsl_max + wgt(-nsl+1) = wgt(-nsl+1) + wgt(-l+1) + ENDDO + ENDIF + + DO k = 1, num + + t_soisno (-nsl+1:0,np) = t_soisno (-nsl+1:0,np) & + + t_soisno_(-nsl+1:0,frnp_(k))*cvsoil_(-nsl+1:0,k)*lccpct_np(patchclass_(frnp_(k)))/wgt(-nsl+1:0) + wliq_soisno (-nsl+1:0,np) = wliq_soisno (-nsl+1:0,np) & + + wliq_soisno_(-nsl+1:0,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + wice_soisno (-nsl+1:0,np) = wice_soisno (-nsl+1:0,np) & + + wice_soisno_(-nsl+1:0,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + + l = 1 + DO WHILE ( (l .le. nsl) .and. (dz_sno_(-l+1,frnp_(k)) .gt. 0) ) + denh2o_np (-l+1) = denh2o_np(-l+1) & + + wliq_soisno_(-l+1,frnp_(k))/dz_sno_(-l+1,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + denice_np (-l+1) = denice_np(-l+1) & + + wice_soisno_(-l+1,frnp_(k))/dz_sno_(-l+1,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + l = l + 1 + IF (l .gt. -maxsnl) EXIT + ENDDO + + ! if source patch has more snow layer than the main patch + IF (nsl .lt. -maxsnl) THEN + l = nsl+1 + DO WHILE ( (l .le. -maxsnl) .and. (dz_sno_(-l+1,frnp_(k)) .gt. 0) ) + + wliq_soisno(-nsl+1,np) = wliq_soisno (-nsl+1,np) & + + wliq_soisno_(-l+1,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + wice_soisno(-nsl+1,np) = wice_soisno (-nsl+1,np) & + + wice_soisno_(-l+1,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + + t_soisno (-nsl+1,np) = t_soisno (-nsl+1,np) & + + t_soisno_(-l+1,frnp_(k))*cvsoil_(-l+1,k)*lccpct_np(patchclass_(frnp_(k)))/wgt(-nsl+1) + + denh2o_np (-nsl+1) = denh2o_np(-nsl+1) & + + wliq_soisno_(-l+1,frnp_(k))/dz_sno_(-l+1,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + denice_np (-nsl+1) = denice_np(-nsl+1) & + + wice_soisno_(-l+1,frnp_(k))/dz_sno_(-l+1,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + l = l + 1 + IF (l .gt. -maxsnl) EXIT + ENDDO + ENDIF + ENDDO + + ! snow layer node and depth calculation according to new mass and density + zi_sno(0) = 0._r8 + DO l = 0, -nsl+1, -1 + + IF (denice_np(l)>0 .and. denh2o_np(l)>0) THEN + dz_sno (l,np) = wice_soisno(l,np)/denice_np(l) + wliq_soisno(l,np)/denh2o_np(l) + + ELSEIF (denice_np(l)==0 .and. denh2o_np(l)>0) THEN + dz_sno (l,np) = wliq_soisno(l,np)/denh2o_np(l) + ! print*, 'denice=0! np=',np,'igbp=',patchclass(np),'nsl=',nsl,'frnp_=',frnp_ + ! DO k = 1,num + ! print*,'frnp_=',frnp_(k),'wice=',wice_soisno(:0,frnp_(k)) + ! ENDDO + + ELSEIF (denh2o_np(l)==0 .and. denice_np(l)>0) THEN + dz_sno (l,np) = wice_soisno(l,np)/denice_np(l) + ! print*, 'denh2o=0! np=',np,'igbp=',patchclass(np),'nsl=',nsl,'frnp_=',frnp_ + ! DO k = 1,num + ! print*,'frnp_=',frnp_(k),'wliq=',wliq_soisno(:0,frnp_(k)) + ! ENDDO + + ELSE + print*, 'denh2o and denice == 0! np=',np,'igbp=',patchclass(np),'nsl=',nsl,'frnp_=',frnp_ + DO k = 1,num + print*,'frnp_=',frnp_(k),'wliq=',wliq_soisno(:0,frnp_(k)) + print*,'frnp_=',frnp_(k),'wice=',wice_soisno(:0,frnp_(k)) + ENDDO + CALL CoLM_stop() + ENDIF + + z_sno (l,np) = zi_sno(l) - 0.5_r8*dz_sno(l,np) + IF (l-1 .lt. maxsnl+1) EXIT + zi_sno (l-1) = zi_sno(l) - dz_sno(l,np) + + ENDDO + + ELSE + ! no snow layer exist in the main patch, add a layer + ! move wgt above soil to layer 0 + IF ( nsl_max > nsl) THEN + DO l = nsl+1, nsl_max + wgt(0) = wgt(0) + wgt(-l+1) + ENDDO + ENDIF + + l = 0 + DO WHILE (wgt(l) .gt. 0) + DO k = 1, num + + wliq_soisno(0,np) = wliq_soisno(0,np) & + + wliq_soisno_(l,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + wice_soisno(0,np) = wice_soisno(0,np) & + + wice_soisno_(l,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + t_soisno (0,np) = t_soisno (0,np) & + + t_soisno_(l,frnp_(k))*cvsoil_(l,k)*lccpct_np(patchclass_(frnp_(k)))/wgt(0) + + IF (dz_sno_(l,frnp_(k)) .gt. 0) THEN + denh2o_np(0) = denh2o_np(0) & + + wliq_soisno_(l,frnp_(k))/dz_sno_(l,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + denice_np(0) = denice_np(0) & + + wice_soisno_(l,frnp_(k))/dz_sno_(l,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + ENDIF + ENDDO + + l = l-1 + IF (l .lt. maxsnl+1) EXIT + ENDDO + + IF (wgt(0) .gt. 0) THEN + + ! snow layer node and depth calculation according to new mass and density + IF (denh2o_np(0)>0 .and. denh2o_np(0)>0) THEN + dz_sno (0,np) = wice_soisno(0,np)/denice_np(0) + wliq_soisno(0,np)/denh2o_np(0) + ELSEIF (denice_np(0)==0 .and. denh2o_np(0)>0) THEN + dz_sno (0,np) = wliq_soisno(0,np)/denh2o_np(0) + ! print*, 'denice=0! stop! np=',np,'igbp=',patchclass(np),'nsl=',nsl,'frnp_=',frnp_ + ! DO k = 1,num + ! print*,'frnp_=',frnp_(k),'wice=',wice_soisno(:0,frnp_(k)) + ! ENDDO + ELSEIF (denice_np(0)>0 .and. denh2o_np(0)==0) THEN + dz_sno (0,np) = wice_soisno(0,np)/denice_np(0) + ! print*, 'denh2o=0! stop! np=',np,'igbp=',patchclass(np),'nsl=',nsl,'frnp_=',frnp_ + ! DO k = 1,num + ! print*,'frnp_=',frnp_(k),'wliq=',wliq_soisno(:0,frnp_(k)) + ! ENDDO + ELSE + print*, 'denh2o and denice == 0! np=',np,'igbp=',patchclass(np),'nsl=',nsl,'frnp_=',frnp_ + DO k = 1,num + print*,'frnp_=',frnp_(k),'wliq=',wliq_soisno(:0,frnp_(k)) + print*,'frnp_=',frnp_(k),'wice=',wice_soisno(:0,frnp_(k)) + ENDDO + CALL CoLM_stop() + ENDIF + + zi_sno (0) = 0._r8 + z_sno (0,np) = zi_sno(0) - 0.5_r8*dz_sno(0,np) + ENDIF + + ENDIF + + + ! Variable adjustment + DO k = 1, num + + wliq_soisno (1:nl_soil,np) = wliq_soisno (1:nl_soil,np) & + + wliq_soisno_(1:nl_soil,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + wice_soisno (1:nl_soil,np) = wice_soisno (1:nl_soil,np) & + + wice_soisno_(1:nl_soil,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + t_soisno (1:nl_soil,np) = t_soisno (1:nl_soil,np) & + + t_soisno_(1:nl_soil,frnp_(k))*cvsoil_(1:nl_soil,k)*lccpct_np(patchclass_(frnp_(k)))/wgt(1:nl_soil) + + tleaf (np) = tleaf (np) + tleaf_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + ldew (np) = ldew (np) + ldew_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + ldew_rain (np) = ldew_rain (np) + ldew_rain_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + ldew_snow (np) = ldew_snow (np) + ldew_snow_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + sag (np) = sag (np) + sag_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + + ! TODO: use MOD_SnowFraction.F90 to calculate sigf later - DONE + ! sigf (np) = sigf (np) + sigf_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + wa (np) = wa (np) + wa_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + wdsrf (np) = wdsrf (np) + wdsrf_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + + snw_rds (:,np) = snw_rds (:,np) + snw_rds_ (:,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + mss_bcpho (:,np) = mss_bcpho (:,np) + mss_bcpho_ (:,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + mss_bcphi (:,np) = mss_bcphi (:,np) + mss_bcphi_ (:,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + mss_ocpho (:,np) = mss_ocpho (:,np) + mss_ocpho_ (:,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + mss_ocphi (:,np) = mss_ocphi (:,np) + mss_ocphi_ (:,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + mss_dst1 (:,np) = mss_dst1 (:,np) + mss_dst1_ (:,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + mss_dst2 (:,np) = mss_dst2 (:,np) + mss_dst2_ (:,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + mss_dst3 (:,np) = mss_dst3 (:,np) + mss_dst3_ (:,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + mss_dst4 (:,np) = mss_dst4 (:,np) + mss_dst4_ (:,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + ssno_lyr (:,:,:,np) = ssno_lyr (:,:,:,np) + ssno_lyr_ (:,:,:,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + + ! TODO:or use same type assignment + smp (:,np) = smp (:,np) + smp_ (:,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + hk (:,np) = hk (:,np) + hk_ (:,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + + IF(DEF_USE_PLANTHYDRAULICS)THEN + vegwp (:,np) = vegwp (:,np) + vegwp_ (:,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + gs0sun (np) = gs0sun (np) + gs0sun_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + gs0sha (np) = gs0sha (np) + gs0sha_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + ENDIF + + !TODO@Wanyi: check the related namelist, DEF_USE_OZONESTRESS or some other? + ! - checked. Line 1109 of MOD_Vars_TimeVariables.F90 + IF(DEF_USE_OZONESTRESS)THEN + lai_old (np) = lai_old (np) + lai_old_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + ENDIF + + trad (np) = trad (np) + trad_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + tref (np) = tref (np) + tref_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + qref (np) = qref (np) + qref_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + rst (np) = rst (np) + rst_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + emis (np) = emis (np) + emis_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + z0m (np) = z0m (np) + z0m_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + zol (np) = zol (np) + zol_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + rib (np) = rib (np) + rib_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + ustar (np) = ustar (np) + ustar_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + qstar (np) = qstar (np) + qstar_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + tstar (np) = tstar (np) + tstar_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + fm (np) = fm (np) + fm_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + fh (np) = fh (np) + fh_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + fq (np) = fq (np) + fq_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + ENDDO + + ! water balance check + wbef = 0 + wpre = 0 + DO k = 1, num + wbef = wbef + ldew_(frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + wbef = wbef + scv_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + wbef = wbef + wa_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + wbef = wbef + sum(wliq_soisno_(maxsnl+1:nl_soil,frnp_(k)))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + wbef = wbef + sum(wice_soisno_(maxsnl+1:nl_soil,frnp_(k)))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + ENDDO + + wpre = ldew(np) + scv(np) + wa(np) + sum(wliq_soisno(maxsnl+1:nl_soil,np)) + sum(wice_soisno(maxsnl+1:nl_soil,np)) + IF (wpre-wbef > 1.e-6) THEN + print*,'np=',np,'total err=',wpre-wbef + ENDIF + + wbef = 0 + wpre = 0 + DO k = 1, num + wbef = wbef + sum(wliq_soisno_(maxsnl+1:nl_soil,frnp_(k)))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + wbef = wbef + sum(wice_soisno_(maxsnl+1:nl_soil,frnp_(k)))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + ENDDO + + wpre = sum(wliq_soisno(maxsnl+1:nl_soil,np)) + sum(wice_soisno(maxsnl+1:nl_soil,np)) + IF (wpre-wbef > 1.e-6) THEN + print*,'np=',np,'wice+wliq err=',wpre-wbef + ENDIF + + + ! ============================================================= + ! 2) adjusted based on code of physical process. + ! ============================================================= + + DO l = maxsnl+1, 0 + IF ( z_sno(l,np) .lt. 0 ) THEN + scv(np) = scv(np) + wice_soisno(l,np) + wliq_soisno(l,np) + snowdp(np) = snowdp(np) + dz_sno(l,np) + ENDIF + ENDDO + + ! ! Use restart value from the same type of source patch or remain initialized + ! IF (lccpct_np(patchclass(np)) .gt. 0) THEN + ! tleaf (np) = tleaf_ (selfnp_) + ! lake_icefrac(:,np) = lake_icefrac_(:,selfnp_) + ! t_lake (:,np) = t_lake_ (:,selfnp_) + ! ENDIF + + ! Fraction of soil covered by snow + zlnd = 0.01 !Roughness length for soil [m] + ! fsno(np) = 0.0 + ! IF (snowdp(np) > 0.) THEN + ! fmelt = (scv(np)/snowdp(np)/100.) ** m + ! fsno(np) = tanh(snowdp(np)/(2.5 * zlnd * fmelt)) + ! ENDIF + + ! Sigf, fsno + CALL snowfraction (tlai(np),tsai(np),z0m(np),zlnd,scv(np),snowdp(np),wt,sigf(np),fsno(np)) + sai(np) = tsai(np) * sigf(np) + + ! ! In case lai+sai come into existence this year, set sigf to 1; Update: won't happen if CALL snowfraction + ! IF ( (lai(np) + sai(np)).gt.0 .and. sigf(np).eq.0 ) THEN + ! sigf(np) = 1 + ! ENDIF + + ! Set Groud temperature + IF ( sum( z_sno(:,np) ) .eq. 0 ) THEN + t_grnd(np) = t_soisno(1,np) + ELSE + DO k = maxsnl+1, 0 + IF ( z_sno(k,np) .lt. 0 ) THEN + t_grnd(np) = t_soisno(k,np) + EXIT + ENDIF + ENDDO + ENDIF + + ! Get the lowest zwt from source patches and assign to np suggested by Shupeng Zhang + zwt(np) = zwt_(frnp_(1)) + k = 2 + DO WHILE (k .le. num) + IF ( zwt_(frnp_(k)) .lt. zwt(np) ) zwt(np) = zwt_(frnp_(k)) + k = k + 1 + ENDDO + + ! ELSE + ! ! Patch area stay unchanged or decrease, use restart value or remain initialized + ! ! TODO: CALL REST - DONE + ! inp_ = np_ + ! DO WHILE (inp_ .le. grid_patch_e_(j)) + ! IF (patchclass_(inp_) .eq. patchclass(np)) THEN + ! selfnp_ = inp_ + ! frnp_(1) = inp_ + ! wliq_soisno (:,np) = wliq_soisno_ (:,inp_) + ! wice_soisno (:,np) = wice_soisno_ (:,inp_) + ! t_soisno (:,np) = t_soisno_ (:,inp_) + ! z_sno (:,np) = z_sno_ (:,inp_) + ! dz_sno (:,np) = dz_sno_ (:,inp_) + ! t_grnd (np) = t_grnd_ (inp_) + ! tleaf (np) = tleaf_ (inp_) + ! ldew (np) = ldew_ (inp_) + ! sag (np) = sag_ (inp_) + ! scv (np) = scv_ (inp_) + ! snowdp (np) = snowdp_ (inp_) + ! fsno (np) = fsno_ (inp_) + ! sigf (np) = sigf_ (inp_) + ! ! In case lai+sai come into existence this year, set sigf to 1 + ! IF ( (lai(np) + sai(np)).gt.0 .and. sigf(np).eq.0 ) THEN + ! sigf(np) = 1 + ! ENDIF + ! zwt (np) = zwt_ (inp_) + ! wa (np) = wa_ (inp_) + ! EXIT + ! ENDIF + ! + ! inp_ = inp_ + 1 + ! ENDDO + + ENDIF + +! ELSEIF (patchtype(np)==3) THEN !glacier patch +! ! Used restart value for GLACIERS patches if patchclass exists last year, or remain initialized +! ! TODO: CALL REST - DONE +! inp_ = np_ +! DO WHILE (inp_ .le. grid_patch_e_(j)) +! IF (patchclass_(inp_) .eq. patchclass(np)) THEN +! wliq_soisno (:,np) = wliq_soisno_ (:,inp_) +! wice_soisno (:,np) = wice_soisno_ (:,inp_) +! t_soisno (:,np) = t_soisno_ (:,inp_) +! z_sno (:,np) = z_sno_ (:,inp_) +! dz_sno (:,np) = dz_sno_ (:,inp_) +! t_grnd (np) = t_grnd_ (inp_) +! tleaf (np) = tleaf_ (inp_) +! ldew (np) = ldew_ (inp_) +! sag (np) = sag_ (inp_) +! scv (np) = scv_ (inp_) +! snowdp (np) = snowdp_ (inp_) +! fsno (np) = fsno_ (inp_) +! sigf (np) = sigf_ (inp_) +! zwt (np) = zwt_ (inp_) +! wa (np) = wa_ (inp_) +! EXIT +! ENDIF +! inp_ = inp_ + 1 +! ENDDO +ENDIF + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + + IF (patchtype(np)==0) THEN + ps = patch_pft_s(np) + pe = patch_pft_e(np) + ! ps_ = patch_pft_s_(selfnp_) + ! pe_ = patch_pft_e_(selfnp_) + ! if totally come from other types,ldew set to zero since ldew_p(:)=0 + ldew(np) = sum( ldew_p(ps:pe)*pftfrac(ps:pe) ) + + ! z0m_p was same-type assigned, then here we update sigf_p, sigf, fsno + CALL snowfraction_pftwrap (np,zlnd,scv(np),snowdp(np),wt,sigf(np),fsno(np)) + + sai_p(ps:pe) = tsai_p(ps:pe) * sigf_p(ps:pe) + sai(np) = sum(sai_p(ps:pe)*pftfrac(ps:pe)) + ENDIF + + ! ! TODO: CALL REST - DONE + ! IF (patchtype(np)==0 .and. lccpct_np(patchclass(np)) .gt. 0) THEN + ! ! Used restart value of the same pftclass for pft-specific variables + ! ! Note: For ip-specific variables, remain initialized value for new soil patch or pftclass + ! ip = ps + ! ip_= ps_ + ! + ! IF (ip.le.0 .or. ip_.le.0) THEN + ! print *, "Error in LuLccMassEnergyConserve LULC_IGBP_PFT|LULC_IGBP_PC!" + ! STOP + ! ENDIF + ! + ! DO WHILE (ip.le.pe .and. ip_.le.pe_) + ! ! if a PFT is missing, CYCLE + ! IF (pftclass(ip) > pftclass_(ip_)) THEN + ! ip_= ip_+ 1 + ! CYCLE + ! ENDIF + ! + ! ! if a PFT is added, CYCLE + ! IF (pftclass(ip) < pftclass_(ip_)) THEN + ! ip = ip + 1 + ! CYCLE + ! ENDIF + ! + ! ! for the same PFT, set PFT value + ! tleaf_p (ip) = tleaf_p_ (ip_) + ! ldew_p (ip) = ldew_p_ (ip_) + ! ! use MOD_SnowFraction.F90 later + ! sigf_p (ip) = sigf_p_ (ip_) + ! IF ( (lai_p(ip) + sai_p(ip)).gt.0 .and. sigf_p(ip).eq.0 ) THEN + ! sigf_p(ip) = 1 + ! ENDIF + ! + ! ip = ip + 1 + ! ip_= ip_+ 1 + ! ENDDO + ! ldew(np) = sum( ldew_p(ps:pe)*pftfrac(ps:pe) ) + ! ENDIF + +#endif + +#ifdef URBAN_MODEL + IF (patchclass(np)==URBAN) THEN + + ! If there isn't any urban patch in last year's grid,initialized value was remained. + ! Though the first source soil patch would be used for pervious ground related variables. + u = patch2urban (np) + nurb = count( patchclass_(grid_patch_s_(j):grid_patch_e_(j)) == URBAN ) + + ! Get the index of urban patches in last year's grid, and index of urban patch with the same urbclass + IF (nurb > 0) THEN + + allocate(gu_(nurb)) ! index of urban patches in last year's grid + selfu_ = -1 ! index of urban patch with the same urbclass in last year's grid + inp_ = np_ ! for loop to record the index of urban patch + iu = 0 + + DO WHILE (inp_ .le. grid_patch_e_(j)) + IF (patchclass_(inp_) == URBAN) THEN + iu = iu + 1 + gu_(iu) = patch2urban_(inp_) + IF (landurban%settyp(u) == urbclass_(gu_(iu))) THEN + selfu_ = gu_(iu) + ENDIF + ENDIF + inp_ = inp_ + 1 + ENDDO + ENDIF + + ! Index of the same urbclass or the nearest class would be used for new year's assignment + IF (selfu_ > 0) THEN + u_ = selfu_ + + ELSE IF (nurb > 0) THEN + duclass = abs ( landurban%settyp(u) - urbclass_(gu_(1)) ) + u_ = gu_(1) + iu = 2 + DO WHILE (iu .le. nurb) + IF (duclass .gt. abs( landurban%settyp(u) - urbclass_(gu_(iu)) )) THEN + u_ = gu_(iu) + duclass = abs( landurban%settyp(u) - urbclass_(u_) ) + ENDIF + iu = iu + 1 + ENDDO + ENDIF + + IF (u.le.0 .or. u_.le.0) THEN + print *, "Error in LuLccMassEnergyConserve URBAN_MODEL!" + STOP + ENDIF + + fwsun (u) = fwsun_ (u_) + dfwsun (u) = dfwsun_ (u_) + + sroof (:,:,u) = sroof_ (:,:,u_) + swsun (:,:,u) = swsun_ (:,:,u_) + swsha (:,:,u) = swsha_ (:,:,u_) + sgimp (:,:,u) = sgimp_ (:,:,u_) + sgper (:,:,u) = sgper_ (:,:,u_) + slake (:,:,u) = slake_ (:,:,u_) + + z_sno_roof (:,u) = z_sno_roof_ (:,u_) + z_sno_gimp (:,u) = z_sno_gimp_ (:,u_) + z_sno_gper (:,u) = z_sno_gper_ (:,u_) + z_sno_lake (:,u) = z_sno_lake_ (:,u_) + + dz_sno_roof (:,u) = dz_sno_roof_ (:,u_) + dz_sno_gimp (:,u) = dz_sno_gimp_ (:,u_) + dz_sno_gper (:,u) = dz_sno_gper_ (:,u_) + dz_sno_lake (:,u) = dz_sno_lake_ (:,u_) + + lwsun (u) = lwsun_ (u_) + lwsha (u) = lwsha_ (u_) + lgimp (u) = lgimp_ (u_) + lgper (u) = lgper_ (u_) + lveg (u) = lveg_ (u_) + + t_roofsno (:,u) = t_roofsno_ (:,u_) + t_wallsun (:,u) = t_wallsun_ (:,u_) + t_wallsha (:,u) = t_wallsha_ (:,u_) + t_gimpsno (:,u) = t_gimpsno_ (:,u_) + t_gpersno (:,u) = t_gpersno_ (:,u_) + t_lakesno (:,u) = t_lakesno_ (:,u_) + + troof_inner (u) = troof_inner_ (u_) + twsun_inner (u) = twsun_inner_ (u_) + twsha_inner (u) = twsha_inner_ (u_) + + wliq_roofsno (:,u) = wliq_roofsno_ (:,u_) + wice_roofsno (:,u) = wice_roofsno_ (:,u_) + wliq_gimpsno (:,u) = wliq_gimpsno_ (:,u_) + wice_gimpsno (:,u) = wice_gimpsno_ (:,u_) + wliq_gpersno (:,u) = wliq_gpersno_ (:,u_) + wice_gpersno (:,u) = wice_gpersno_ (:,u_) + wliq_lakesno (:,u) = wliq_lakesno_ (:,u_) + wice_lakesno (:,u) = wice_lakesno_ (:,u_) + + sag_roof (u) = sag_roof_ (u_) + sag_gimp (u) = sag_gimp_ (u_) + sag_gper (u) = sag_gper_ (u_) + sag_lake (u) = sag_lake_ (u_) + scv_roof (u) = scv_roof_ (u_) + scv_gimp (u) = scv_gimp_ (u_) + scv_gper (u) = scv_gper_ (u_) + scv_lake (u) = scv_lake_ (u_) + fsno_roof (u) = fsno_roof_ (u_) + fsno_gimp (u) = fsno_gimp_ (u_) + fsno_gper (u) = fsno_gper_ (u_) + fsno_lake (u) = fsno_lake_ (u_) + snowdp_roof (u) = snowdp_roof_ (u_) + snowdp_gimp (u) = snowdp_gimp_ (u_) + snowdp_gper (u) = snowdp_gper_ (u_) + snowdp_lake (u) = snowdp_lake_ (u_) + + Fhac (u) = Fhac_ (u_) + Fwst (u) = Fwst_ (u_) + Fach (u) = Fach_ (u_) + Fahe (u) = Fahe_ (u_) + Fhah (u) = Fhah_ (u_) + vehc (u) = vehc_ (u_) + meta (u) = meta_ (u_) + t_room (u) = t_room_ (u_) + t_roof (u) = t_roof_ (u_) + t_wall (u) = t_wall_ (u_) + tafu (u) = tafu_ (u_) + urb_green (u) = urb_green_ (u_) + + ! used soil patch value for variable on pervious ground + FROM_SOIL = .false. + IF (selfu_ < 0) THEN + DO k = 1, num + IF (patchtype_(frnp_(k)) == 0) THEN + FROM_SOIL = .true. + ENDIF + ENDDO + ENDIF + + ! Use the first source soil patch temporarily + IF (FROM_SOIL) THEN + z_sno_gper (:,u) = z_sno_ (:,frnp_(1)) + sag_gper (u) = sag_ (frnp_(1)) + scv_gper (u) = scv_ (frnp_(1)) + fsno_gper (u) = fsno_ (frnp_(1)) + snowdp_gper (u) = snowdp_ (frnp_(1)) + ENDIF + + !TODO: need to recalculate wliq_soisno, wice_soisno and scv value - DONE + wliq_soisno(: ,np) = 0. + wliq_soisno(:1,np) = wliq_roofsno(:1,u )*froof(u) + wliq_soisno(: ,np) = wliq_soisno (: ,np)+wliq_gpersno(: ,u)*(1-froof(u))*fgper(u) + wliq_soisno(:1,np) = wliq_soisno (:1,np)+wliq_gimpsno(:1,u)*(1-froof(u))*(1-fgper(u)) + + wice_soisno(: ,np) = 0. + wice_soisno(:1,np) = wice_roofsno(:1,u )*froof(u) + wice_soisno(: ,np) = wice_soisno (: ,np)+wice_gpersno(: ,u)*(1-froof(u))*fgper(u) + wice_soisno(:1,np) = wice_soisno (:1,np)+wice_gimpsno(:1,u)*(1-froof(u))*(1-fgper(u)) + + scv(np) = scv_roof(u)*froof(u) + scv_gper(u)*(1-froof(u))*fgper(u) + scv_gimp(u)*(1-froof(u))*(1-fgper(u)) + + ENDIF +#endif + + ! CALL albland (np, patchtype(np),deltim,& + ! soil_s_v_alb(np),soil_d_v_alb(np),soil_s_n_alb(np),soil_d_n_alb(np),& + ! chil(patchclass(np)),rho(1:,1:,patchclass(np)),tau(1:,1:,patchclass(np)),fveg(np),green(np),lai(np),sai(np),coszen(np),& + ! wt,fsno(np),scv(np),scvold(np),sag(np),ssw,pg_snow(np),forc_t(np),t_grnd(np),t_soisno_(maxsnl+1:,np),& + ! dz_soisno_(maxsnl+1:,np),snl,wliq_soisno(maxsnl+1:,np),wice_soisno(maxsnl+1:,np),snw_rds(maxsnl+1:0,np),snofrz,& + ! mss_bcpho(maxsnl+1:0,np),mss_bcphi(maxsnl+1:0,np),mss_ocpho(maxsnl+1:0,np),mss_ocphi(maxsnl+1:0,np),& + ! mss_dst1(maxsnl+1:0,np),mss_dst2(maxsnl+1:0,np),mss_dst3(maxsnl+1:0,np),mss_dst4(maxsnl+1:0,np),& + ! alb(1:,1:,np),ssun(1:,1:,np),ssha(1:,1:,np),ssno(:,:,:,np),thermk(np),extkb(np),extkd(np)) + + + IF (allocated(frnp_ )) deallocate(frnp_ ) + IF (allocated(gu_ )) deallocate(gu_ ) + IF (allocated(cvsoil_)) deallocate(cvsoil_) + np = np + 1 + ENDDO + ENDIF + ENDDO + ENDDO + ENDIF + + IF (p_is_worker) THEN + IF (allocated(grid_patch_s )) deallocate(grid_patch_s ) + IF (allocated(grid_patch_e )) deallocate(grid_patch_e ) + IF (allocated(grid_patch_s_)) deallocate(grid_patch_s_) + IF (allocated(grid_patch_e_)) deallocate(grid_patch_e_) + IF (allocated(locpxl )) deallocate(locpxl ) + ENDIF + + END SUBROUTINE LulccMassEnergyConserve + +END MODULE MOD_Lulcc_MassEnergyConserve +#endif +! ---------- EOP ------------ diff --git a/main/LULCC/MOD_Lulcc_TMatrix.F90 b/main/LULCC/MOD_Lulcc_TMatrix.F90 deleted file mode 100644 index c6ad6de8..00000000 --- a/main/LULCC/MOD_Lulcc_TMatrix.F90 +++ /dev/null @@ -1,66 +0,0 @@ -#include - -MODULE MOD_Lulcc_TMatrix -! ------------------------------- -! Created by Hua Yuan, 04/2022 -! ------------------------------- - - USE MOD_Precision - USE MOD_Vars_Global - IMPLICIT NONE - SAVE -! ----------------------------------------------------------------- - !TODO: need coding below... - -! PUBLIC MEMBER FUNCTIONS: - PUBLIC :: allocate_LulccTMatrix - PUBLIC :: deallocate_LulccTMatrix - PUBLIC :: READ_LulccTMatrix - -! PRIVATE MEMBER FUNCTIONS: - -!----------------------------------------------------------------------- - - CONTAINS - -!----------------------------------------------------------------------- - - SUBROUTINE allocate_LulccTMatrix - ! -------------------------------------------------------------------- - ! Allocates memory for Lulcc time invariant variables - ! -------------------------------------------------------------------- - - USE MOD_Precision - USE MOD_Vars_Global - - IMPLICIT NONE -!TODO: need coding below... - - END SUBROUTINE allocate_LulccTMatrix - - - SUBROUTINE READ_LulccTMatrix - - USE MOD_Precision - USE MOD_Vars_Global - USE MOD_Vars_TimeInvariants - USE MOD_Vars_PFTimeInvariants - USE MOD_Vars_PCTimeInvariants - USE MOD_Urban_Vars_TimeInvariants - IMPLICIT NONE -!TODO: need coding below... - - END SUBROUTINE READ_LulccTMatrix - - SUBROUTINE deallocate_LulccTMatrix -! -------------------------------------------------- -! Deallocates memory for Lulcc time invariant variables -! -------------------------------------------------- - -!TODO: need coding below... - - - END SUBROUTINE deallocate_LulccTMatrix - -END MODULE MOD_LulccTMatrix -! ---------- EOP ------------ diff --git a/main/LULCC/MOD_Lulcc_TransferTrace.F90 b/main/LULCC/MOD_Lulcc_TransferTrace.F90 new file mode 100644 index 00000000..482f6ee0 --- /dev/null +++ b/main/LULCC/MOD_Lulcc_TransferTrace.F90 @@ -0,0 +1,248 @@ +#include + +MODULE MOD_Lulcc_TransferTrace +! ======================================================================= +! Created by Wanyi Lin, Shupeng Zhang and Hua Yuan, 07/2023 +! +! !DESCRIPTION: +! The transfer matrix and patch tracing vector were created using the land +! cover type data of the adjacent two years. Based on next year's patch, +! the pixels within the patch and last years' land cover type of these +! pixels were obtained. Then the percent of source land cover type of each +! patch was derived. +! +! ======================================================================= + + USE MOD_Precision + USE MOD_Vars_Global + IMPLICIT NONE + SAVE +!------------------------------------------------------------------------ + + real(r8), allocatable, dimension(:,:) :: lccpct_patches(:,:) !Percent area of source patches in a patch + real(r8), allocatable, dimension(:,:) :: lccpct_matrix (:,:) !Percent area of source patches in a grid + + ! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: allocate_LulccTransferTrace + PUBLIC :: deallocate_LulccTransferTrace + PUBLIC :: MAKE_LulccTransferTrace + + ! PRIVATE MEMBER FUNCTIONS: + +!------------------------------------------------------------------------ + +CONTAINS + +!------------------------------------------------------------------------ + + + SUBROUTINE allocate_LulccTransferTrace + ! -------------------------------------------------------------------- + ! Allocates memory for Lulcc time invariant variables + ! -------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_LandPatch + USE MOD_SPMD_Task + + IMPLICIT NONE + + integer :: nlc = N_land_classification + + IF (p_is_worker) THEN + allocate (lccpct_patches (numpatch, 0:nlc)) + lccpct_patches (:,:) = 0 + allocate (lccpct_matrix (numpatch, 0:nlc)) + lccpct_matrix (:,:) = 0 + ENDIF + + END SUBROUTINE allocate_LulccTransferTrace + + + SUBROUTINE MAKE_LulccTransferTrace (lc_year) + + USE MOD_Precision + USE MOD_Namelist + USE MOD_SPMD_Task + USE MOD_Grid + USE MOD_LandPatch + USE MOD_NetCDFVector + USE MOD_NetCDFBlock + USE MOD_AggregationRequestData + USE MOD_Mesh + USE MOD_MeshFilter + USE MOD_LandElm + USE MOD_DataType + USE MOD_Block + USE MOD_Pixel + USE MOD_5x5DataReadin + USE MOD_RegionClip + USE MOD_Utils +#ifdef SrfdataDiag + USE MOD_SrfdataDiag +#endif +#ifdef RangeCheck + USE MOD_RangeCheck +#endif + + IMPLICIT NONE + + integer, intent(in) :: lc_year + + ! local variables: + ! --------------------------------------------------------------- + character(len=256) :: dir_5x5, suffix, lastyr, thisyr, dir_landdata, lndname + integer :: i,ipatch,ipxl,ipxstt,ipxend,numpxl,ilc + integer, allocatable, dimension(:) :: locpxl + type (block_data_int32_2d) :: lcdatafr !land cover data of last year + integer, allocatable, dimension(:) :: lcdatafr_one(:), lcfrbuff(:) + real(r8),allocatable, dimension(:) :: area_one(:) , areabuff(:) + real(r8) :: sum_areabuff, gridarea + integer, allocatable, dimension(:) :: grid_patch_s, grid_patch_e +! for surface data diag +#ifdef SrfdataDiag + integer :: ityp + integer, allocatable, dimension(:) :: typindex + + allocate( typindex(N_land_classification+1) ) +#endif + + write(thisyr,'(i4.4)') lc_year + write(lastyr,'(i4.4)') lc_year-1 + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + CALL gpatch%define_by_name ('colm_500m') + CALL pixel%assimilate_grid (gpatch) + CALL pixel%map_to_grid (gpatch) + + IF (p_is_io) THEN + CALL allocate_block_data (gpatch, lcdatafr) + dir_5x5 = trim(DEF_dir_rawdata) // '/plant_15s' + suffix = 'MOD'//trim(lastyr) + ! read the previous year land cover data + CALL read_5x5_data (dir_5x5, suffix, gpatch, 'LC', lcdatafr) + +#ifdef USEMPI + CALL aggregation_data_daemon (gpatch, data_i4_2d_in1 = lcdatafr) +#endif + ENDIF + + ! ----------------------------------------------------------------- + ! extract the land cover type of pixels of last year for each patch + ! ----------------------------------------------------------------- + IF (p_is_worker) THEN + + ! allocate with numelm + allocate(grid_patch_s (numelm )) + allocate(grid_patch_e (numelm )) + + grid_patch_e (:) = -1 + grid_patch_s (:) = -1 + + DO i=1, numelm + ! how many patches in ith element in this worker + numpxl = count(landpatch%eindex==landelm%eindex(i)) + + IF (allocated(locpxl)) deallocate(locpxl) + allocate(locpxl(numpxl)) + + ! get all patches' index that eindex is equal the i element + locpxl = pack([(ipxl, ipxl=1, numpatch)], landpatch%eindex==landelm%eindex(i)) + ! the min index is the start of patch's index + grid_patch_s(i) = minval(locpxl) + ! the max index is the end of patch's index + grid_patch_e(i) = maxval(locpxl) + ENDDO + + DO i=1, numelm + ipatch = grid_patch_s (i) + + IF (ipatch.le.0) CYCLE + gridarea = 0 + + DO WHILE (ipatch.le.grid_patch_e(i)) + + IF (ipatch.le.0) THEN + CYCLE + ENDIF + + ! using this year patch mapping to aggregate the previous year land cover data + CALL aggregation_request_data (landpatch, ipatch, gpatch, zip = .true., area = area_one, & + data_i4_2d_in1 = lcdatafr, data_i4_2d_out1 = lcdatafr_one) + + ipxstt = landpatch%ipxstt(ipatch) + ipxend = landpatch%ipxend(ipatch) + + IF (allocated(lcfrbuff)) deallocate(lcfrbuff) + allocate(lcfrbuff(ipxstt:ipxend)) + lcfrbuff(:) = lcdatafr_one(:) + + IF (allocated(areabuff)) deallocate(areabuff) + allocate(areabuff(ipxstt:ipxend)) + areabuff(:) = area_one(:) + + sum_areabuff = sum(areabuff) + DO ipxl = ipxstt, ipxend + ! Transfer trace - the key codes to count for the source land cover types of LULCC + lccpct_patches(ipatch, lcfrbuff(ipxl)) = lccpct_patches(ipatch, lcfrbuff(ipxl)) + areabuff(ipxl) / sum_areabuff + lccpct_matrix (ipatch, lcfrbuff(ipxl)) = lccpct_matrix (ipatch, lcfrbuff(ipxl)) + areabuff(ipxl) + ENDDO + gridarea = gridarea + sum_areabuff + ipatch = ipatch + 1 + ENDDO + + lccpct_matrix(grid_patch_s(i):grid_patch_e(i), :) = lccpct_matrix (grid_patch_s(i):grid_patch_e(i), :) / gridarea + + ENDDO + +#ifdef USEMPI + CALL aggregation_worker_done () +#endif + ENDIF + +#ifdef SrfdataDiag + dir_landdata = DEF_dir_landdata + typindex = (/(ityp, ityp = 0, N_land_classification)/) + lndname = trim(dir_landdata) // '/diag/transfer_matrix'// trim(lastyr)//'-'// trim(thisyr) // '.nc' + DO ilc = 0, N_land_classification + CALL srfdata_map_and_write (lccpct_matrix(:,ilc), landpatch%settyp, typindex, m_patch2diag, & + -1.0e36_r8, lndname, 'TRANSFER_MATRIX', compress = 0, write_mode = 'one', lastdimname = 'source_patch', lastdimvalue = ilc) + ENDDO + deallocate(typindex) +#endif + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + +#ifdef RangeCheck + CALL check_vector_data ('lccpct_patches', lccpct_patches) + CALL check_vector_data ('lccpct_matrix' , lccpct_matrix ) +#endif + + IF (p_is_worker) THEN + IF (allocated(area_one)) deallocate (area_one) + ENDIF + + END SUBROUTINE MAKE_LulccTransferTrace + + + SUBROUTINE deallocate_LulccTransferTrace + ! -------------------------------------------------- + ! Deallocates memory for Lulcc time invariant variables + ! -------------------------------------------------- + USE MOD_SPMD_Task + + IF (p_is_worker) THEN + IF (allocated(lccpct_patches)) deallocate (lccpct_patches) + IF (allocated(lccpct_matrix )) deallocate (lccpct_matrix ) + ENDIF + + END SUBROUTINE deallocate_LulccTransferTrace + +END MODULE MOD_Lulcc_TransferTrace +! ---------- EOP ------------ diff --git a/main/LULCC/MOD_Lulcc_Vars_TimeInvariants.F90 b/main/LULCC/MOD_Lulcc_Vars_TimeInvariants.F90 index 5b2f1124..6c418d72 100644 --- a/main/LULCC/MOD_Lulcc_Vars_TimeInvariants.F90 +++ b/main/LULCC/MOD_Lulcc_Vars_TimeInvariants.F90 @@ -1,9 +1,15 @@ #include -MODULE MOD_LuLcc_Vars_TimeInvariants -! ------------------------------- +MODULE MOD_Lulcc_Vars_TimeInvariants +! ====================================================================== ! Created by Hua Yuan, 04/2022 -! ------------------------------- +! +! !REVISIONS: +! +! 07/2023, Wenzong Dong: porting to MPI version +! 08/2023, Hua Yuan: unified PFT and PC process +! +! ====================================================================== USE MOD_Precision USE MOD_Vars_Global @@ -11,34 +17,32 @@ MODULE MOD_LuLcc_Vars_TimeInvariants IMPLICIT NONE SAVE -! ----------------------------------------------------------------- +!----------------------------------------------------------------------- ! for patch time invariant information - TYPE(pixelset_type) :: landpatch_ - TYPE(pixelset_type) :: landelm_ - INTEGER :: numpatch_ - INTEGER :: numelm_ - INTEGER :: numpft_ - INTEGER :: numpc_ - INTEGER :: numurban_ - INTEGER, allocatable :: patchclass_ (:) !index of land cover type - INTEGER, allocatable :: patchtype_ (:) !land water type - - ! for LULC_IGBP_PFT - INTEGER, allocatable :: pftclass_ (:) !PFT type - INTEGER, allocatable :: patch_pft_s_ (:) !start PFT index of a patch - INTEGER, allocatable :: patch_pft_e_ (:) !end PFT index of a patch - - ! for LULC_IGBP_PC - INTEGER, allocatable :: patch2pc_ (:) !projection from patch to PC + type(pixelset_type) :: landpatch_ + type(pixelset_type) :: landelm_ + integer :: numpatch_ + integer :: numelm_ + integer :: numpft_ + integer :: numpc_ + integer :: numurban_ + integer, allocatable :: patchclass_ (:) !index of land cover type + integer, allocatable :: patchtype_ (:) !land patch type + real(r8), allocatable:: csol_ (:,:) !heat capacity of soil solids [J/(m3 K)] + + ! for LULC_IGBP_PFT and LULC_IGBP_PC + integer, allocatable :: pftclass_ (:) !PFT type + integer, allocatable :: patch_pft_s_ (:) !start PFT index of a patch + integer, allocatable :: patch_pft_e_ (:) !end PFT index of a patch ! for Urban model - INTEGER, allocatable :: urbclass_ (:) !urban TYPE - INTEGER, allocatable :: patch2urban_ (:) !projection from patch to Urban + integer, allocatable :: urbclass_ (:) !urban type + integer, allocatable :: patch2urban_ (:) !projection from patch to Urban ! PUBLIC MEMBER FUNCTIONS: - PUBLIC :: allocate_LuLccTimeInvariants - PUBLIC :: deallocate_LuLccTimeInvariants - PUBLIC :: SAVE_LuLccTimeInvariants + PUBLIC :: allocate_LulccTimeInvariants + PUBLIC :: deallocate_LulccTimeInvariants + PUBLIC :: SAVE_LulccTimeInvariants ! PRIVATE MEMBER FUNCTIONS: @@ -48,22 +52,19 @@ MODULE MOD_LuLcc_Vars_TimeInvariants !----------------------------------------------------------------------- - SUBROUTINE allocate_LuLccTimeInvariants + SUBROUTINE allocate_LulccTimeInvariants ! -------------------------------------------------------------------- - ! Allocates memory for LuLcc time invariant variables + ! Allocates memory for Lulcc time invariant variables ! -------------------------------------------------------------------- - use MOD_SPMD_Task + USE MOD_SPMD_Task USE MOD_Precision USE MOD_Vars_Global USE MOD_LandPatch USE MOD_Mesh -#ifdef LULC_IGBP_PFT +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) USE MOD_LandPFT #endif -#ifdef LULC_IGBP_PC - USE MOD_LandPC -#endif #ifdef URBAN_MODEL USE MOD_LandUrban #endif @@ -87,8 +88,9 @@ SUBROUTINE allocate_LuLccTimeInvariants allocate (patchclass_ (numpatch)) allocate (patchtype_ (numpatch)) + allocate (csol_ (nl_soil,numpatch)) -#ifdef LULC_IGBP_PFT +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) IF (numpft > 0) THEN allocate (pftclass_ (numpft)) allocate (patch_pft_s_ (numpatch)) @@ -96,12 +98,6 @@ SUBROUTINE allocate_LuLccTimeInvariants ENDIF #endif -#ifdef LULC_IGBP_PC - IF (numpc > 0) THEN - allocate (patch2pc_ (numpatch)) - ENDIF -#endif - #ifdef URBAN_MODEL IF (numurban > 0) THEN allocate (urbclass_ (numurban)) @@ -110,26 +106,23 @@ SUBROUTINE allocate_LuLccTimeInvariants #endif ENDIF ENDIF - END SUBROUTINE allocate_LuLccTimeInvariants + END SUBROUTINE allocate_LulccTimeInvariants - SUBROUTINE SAVE_LuLccTimeInvariants + SUBROUTINE SAVE_LulccTimeInvariants USE MOD_Precision USE MOD_Vars_Global - use MOD_SPMD_Task + USE MOD_SPMD_Task USE MOD_Pixelset USE MOD_Vars_TimeInvariants USE MOD_Landpatch USE MOD_Landelm USE MOD_Mesh -#ifdef LULC_IGBP_PFT +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) USE MOD_Vars_PFTimeInvariants USE MOD_LandPFT #endif -#ifdef LULC_IGBP_PC - USE MOD_LandPC -#endif #ifdef URBAN_MODEL USE MOD_LandUrban #endif @@ -144,8 +137,9 @@ SUBROUTINE SAVE_LuLccTimeInvariants numelm_ = numelm patchclass_ (:) = patchclass (:) patchtype_ (:) = patchtype (:) + csol_ (:,:) = csol (:,:) -#ifdef LULC_IGBP_PFT +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) IF (numpft > 0) THEN numpft_ = numpft pftclass_ (:) = pftclass (:) @@ -154,13 +148,6 @@ SUBROUTINE SAVE_LuLccTimeInvariants ENDIF #endif -#ifdef LULC_IGBP_PC - IF (numpc > 0) THEN - numpc_ = numpc - patch2pc_ (:) = patch2pc (:) - ENDIF -#endif - #ifdef URBAN_MODEL IF (numurban > 0) THEN numurban_ = numurban @@ -170,14 +157,14 @@ SUBROUTINE SAVE_LuLccTimeInvariants #endif ENDIF ENDIF - END SUBROUTINE SAVE_LuLccTimeInvariants + END SUBROUTINE SAVE_LulccTimeInvariants - SUBROUTINE deallocate_LuLccTimeInvariants - use MOD_SPMD_Task + SUBROUTINE deallocate_LulccTimeInvariants + USE MOD_SPMD_Task USE MOD_PixelSet ! -------------------------------------------------- -! Deallocates memory for LuLcc time invariant variables +! Deallocates memory for Lulcc time invariant variables ! -------------------------------------------------- IF (p_is_worker) THEN IF (numpatch_ > 0) THEN @@ -185,8 +172,9 @@ SUBROUTINE deallocate_LuLccTimeInvariants CALL landelm_%forc_free_mem deallocate (patchclass_ ) deallocate (patchtype_ ) + deallocate (csol_ ) -#ifdef LULC_IGBP_PFT +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) IF (numpft_ > 0) THEN deallocate (pftclass_ ) deallocate (patch_pft_s_ ) @@ -194,12 +182,6 @@ SUBROUTINE deallocate_LuLccTimeInvariants ENDIF #endif -#ifdef LULC_IGBP_PC - IF (numpc_ > 0) THEN - deallocate (patch2pc_ ) - ENDIF -#endif - #ifdef URBAN_MODEL IF (numurban_ > 0) THEN deallocate (urbclass_ ) @@ -209,7 +191,7 @@ SUBROUTINE deallocate_LuLccTimeInvariants ENDIF ENDIF - END SUBROUTINE deallocate_LuLccTimeInvariants + END SUBROUTINE deallocate_LulccTimeInvariants -END MODULE MOD_LuLcc_Vars_TimeInvariants +END MODULE MOD_Lulcc_Vars_TimeInvariants ! ---------- EOP ------------ diff --git a/main/LULCC/MOD_Lulcc_Vars_TimeVariables.F90 b/main/LULCC/MOD_Lulcc_Vars_TimeVariables.F90 index b5edf121..1942c89a 100644 --- a/main/LULCC/MOD_Lulcc_Vars_TimeVariables.F90 +++ b/main/LULCC/MOD_Lulcc_Vars_TimeVariables.F90 @@ -1,153 +1,213 @@ #include -MODULE MOD_LuLcc_Vars_TimeVariables -! ------------------------------- +MODULE MOD_Lulcc_Vars_TimeVariables + +! ====================================================================== ! Created by Hua Yuan, 04/2022 -! ------------------------------- +! +! +! !REVISIONS: +! +! 07/2023, Wenzong Dong: porting to MPI version +! 08/2023, Hua Yuan: unified PFT and PC process +! 10/2023, Wanyi Lin: check with MOD_Vars_TimeVariables.F90, add variables, +! and remove unnecessary variables +! +! ====================================================================== USE MOD_Precision USE MOD_Vars_Global IMPLICIT NONE SAVE -! ----------------------------------------------------------------- +! ---------------------------------------------------------------------- ! Time-varying state variables which reaquired by restart run - REAL(r8), allocatable :: z_sno_ (:,:) !node depth [m] - REAL(r8), allocatable :: dz_sno_ (:,:) !interface depth [m] - REAL(r8), allocatable :: t_soisno_ (:,:) !soil temperature [K] - REAL(r8), allocatable :: wliq_soisno_ (:,:) !liquid water in layers [kg/m2] - REAL(r8), allocatable :: wice_soisno_ (:,:) !ice lens in layers [kg/m2] - REAL(r8), allocatable :: t_grnd_ (:) !ground surface temperature [K] - - REAL(r8), allocatable :: tleaf_ (:) !leaf temperature [K] - REAL(r8), allocatable :: ldew_ (:) !depth of water on foliage [mm] - REAL(r8), allocatable :: sag_ (:) !non dimensional snow age [-] - REAL(r8), allocatable :: scv_ (:) !snow cover, water equivalent [mm] - REAL(r8), allocatable :: snowdp_ (:) !snow depth [meter] - REAL(r8), allocatable :: fveg_ (:) !fraction of vegetation cover - REAL(r8), allocatable :: fsno_ (:) !fraction of snow cover on ground - REAL(r8), allocatable :: sigf_ (:) !fraction of veg cover, excluding snow-covered veg [-] - REAL(r8), allocatable :: green_ (:) !leaf greenness - REAL(r8), allocatable :: lai_ (:) !leaf area index - REAL(r8), allocatable :: sai_ (:) !stem area index - REAL(r8), allocatable :: coszen_ (:) !cosine of solar zenith angle - REAL(r8), allocatable :: alb_ (:,:,:) !averaged albedo [-] - REAL(r8), allocatable :: ssun_ (:,:,:) !sunlit canopy absorption for solar radiation (0-1) - REAL(r8), allocatable :: ssha_ (:,:,:) !shaded canopy absorption for solar radiation (0-1) - REAL(r8), allocatable :: thermk_ (:) !canopy gap fraction for tir radiation - REAL(r8), allocatable :: extkb_ (:) !(k, g(mu)/mu) direct solar extinction coefficient - REAL(r8), allocatable :: extkd_ (:) !diffuse and scattered diffuse PAR extinction coefficient - REAL(r8), allocatable :: zwt_ (:) !the depth to water table [m] - REAL(r8), allocatable :: wa_ (:) !water storage in aquifer [mm] - - REAL(r8), allocatable :: t_lake_ (:,:) !lake layer teperature [K] - REAL(r8), allocatable :: lake_icefrac_(:,:) !lake mass fraction of lake layer that is frozen - - ! for LULC_IGBP_PFT - REAL(r8), allocatable :: tleaf_p_ (:) !shaded leaf temperature [K] - REAL(r8), allocatable :: ldew_p_ (:) !depth of water on foliage [mm] - REAL(r8), allocatable :: sigf_p_ (:) !fraction of veg cover, excluding snow-covered veg [-] - REAL(r8), allocatable :: lai_p_ (:) !leaf area index - REAL(r8), allocatable :: sai_p_ (:) !stem area index - REAL(r8), allocatable :: ssun_p_ (:,:,:) !sunlit canopy absorption for solar radiation (0-1) - REAL(r8), allocatable :: ssha_p_ (:,:,:) !shaded canopy absorption for solar radiation (0-1) - REAL(r8), allocatable :: thermk_p_ (:) !canopy gap fraction for tir radiation - REAL(r8), allocatable :: extkb_p_ (:) !(k, g(mu)/mu) direct solar extinction coefficient - REAL(r8), allocatable :: extkd_p_ (:) !diffuse and scattered diffuse PAR extinction coefficient - - ! for LULC_IGBP_PC - REAL(r8), allocatable :: tleaf_c_ (:,:) !leaf temperature [K] - REAL(r8), allocatable :: ldew_c_ (:,:) !depth of water on foliage [mm] - REAL(r8), allocatable :: sigf_c_ (:,:) !fraction of veg cover, excluding snow-covered veg [-] - REAL(r8), allocatable :: lai_c_ (:,:) !leaf area index - REAL(r8), allocatable :: sai_c_ (:,:) !stem area index - REAL(r8), allocatable :: ssun_c_ (:,:,:,:) !sunlit canopy absorption for solar radiation (0-1) - REAL(r8), allocatable :: ssha_c_ (:,:,:,:) !shaded canopy absorption for solar radiation (0-1) - REAL(r8), allocatable :: thermk_c_ (:,:) !canopy gap fraction for tir radiation - REAL(r8), allocatable :: fshade_c_ (:,:) !canopy gap fraction for tir radiation - REAL(r8), allocatable :: extkb_c_ (:,:) !(k, g(mu)/mu) direct solar extinction coefficient - REAL(r8), allocatable :: extkd_c_ (:,:) !diffuse and scattered diffuse PAR extinction coefficient + !TODO: need to check with MOD_Vars_TimeVariables.F90 whether + ! there are any variables missing. - DONE + real(r8), allocatable :: z_sno_ (:,:) !node depth [m] + real(r8), allocatable :: dz_sno_ (:,:) !interface depth [m] + real(r8), allocatable :: t_soisno_ (:,:) !soil temperature [K] + real(r8), allocatable :: wliq_soisno_ (:,:) !liquid water in layers [kg/m2] + real(r8), allocatable :: wice_soisno_ (:,:) !ice lens in layers [kg/m2] + real(r8), allocatable :: smp_ (:,:) !soil matrix potential [mm] + real(r8), allocatable :: hk_ (:,:) !hydraulic conductivity [mm h2o/s] + real(r8), allocatable :: t_grnd_ (:) !ground surface temperature [K] + + real(r8), allocatable :: tleaf_ (:) !leaf temperature [K] + real(r8), allocatable :: ldew_ (:) !depth of water on foliage [mm] + real(r8), allocatable :: ldew_rain_ (:) !depth of rain on foliage [mm] + real(r8), allocatable :: ldew_snow_ (:) !depth of rain on foliage [mm] + real(r8), allocatable :: sag_ (:) !non dimensional snow age [-] + real(r8), allocatable :: scv_ (:) !snow cover, water equivalent [mm] + real(r8), allocatable :: snowdp_ (:) !snow depth [meter] + real(r8), allocatable :: fsno_ (:) !fraction of snow cover on ground + real(r8), allocatable :: sigf_ (:) !fraction of veg cover, excluding snow-covered veg [-] + real(r8), allocatable :: zwt_ (:) !the depth to water table [m] + real(r8), allocatable :: wa_ (:) !water storage in aquifer [mm] + real(r8), allocatable :: wdsrf_ (:) !depth of surface water [mm] + real(r8), allocatable :: rss_ (:) !soil surface resistance [s/m] + + real(r8), allocatable :: t_lake_ (:,:) !lake layer teperature [K] + real(r8), allocatable :: lake_icefrac_(:,:) !lake mass fraction of lake layer that is frozen + real(r8), allocatable :: savedtke1_ (:) !top level eddy conductivity (W/m K) + + !Plant Hydraulic variables + real(r8), allocatable :: vegwp_ (:,:) !vegetation water potential [mm] + real(r8), allocatable :: gs0sun_ (:) !working copy of sunlit stomata conductance + real(r8), allocatable :: gs0sha_ (:) !working copy of shalit stomata conductance + !END plant hydraulic variables + + !Ozone stress variables + real(r8), allocatable :: lai_old_ (:) !lai in last time step + real(r8), allocatable :: o3uptakesun_ (:) !Ozone does, sunlit leaf (mmol O3/m^2) + real(r8), allocatable :: o3uptakesha_ (:) !Ozone does, shaded leaf (mmol O3/m^2) + !End ozone stress variables + + real(r8), allocatable :: snw_rds_ (:,:) !effective grain radius (col,lyr) [microns, m-6] + real(r8), allocatable :: mss_bcpho_ (:,:) !mass of hydrophobic BC in snow (col,lyr) [kg] + real(r8), allocatable :: mss_bcphi_ (:,:) !mass of hydrophillic BC in snow (col,lyr) [kg] + real(r8), allocatable :: mss_ocpho_ (:,:) !mass of hydrophobic OC in snow (col,lyr) [kg] + real(r8), allocatable :: mss_ocphi_ (:,:) !mass of hydrophillic OC in snow (col,lyr) [kg] + real(r8), allocatable :: mss_dst1_ (:,:) !mass of dust species 1 in snow (col,lyr) [kg] + real(r8), allocatable :: mss_dst2_ (:,:) !mass of dust species 2 in snow (col,lyr) [kg] + real(r8), allocatable :: mss_dst3_ (:,:) !mass of dust species 3 in snow (col,lyr) [kg] + real(r8), allocatable :: mss_dst4_ (:,:) !mass of dust species 4 in snow (col,lyr) [kg] + real(r8), allocatable :: ssno_lyr_(:,:,:,:) !snow layer absorption [-] + + ! Additional variables required by reginal model (such as WRF ) RSM) + real(r8), allocatable :: trad_ (:) !radiative temperature of surface [K] + real(r8), allocatable :: tref_ (:) !2 m height air temperature [kelvin] + real(r8), allocatable :: qref_ (:) !2 m height air specific humidity + real(r8), allocatable :: rst_ (:) !canopy stomatal resistance (s/m) + real(r8), allocatable :: emis_ (:) !averaged bulk surface emissivity + real(r8), allocatable :: z0m_ (:) !effective roughness [m] + real(r8), allocatable :: displa_ (:) !zero displacement height [m] + real(r8), allocatable :: zol_ (:) !dimensionless height (z/L) used in Monin-Obukhov theory + real(r8), allocatable :: rib_ (:) !bulk Richardson number in surface layer + real(r8), allocatable :: ustar_ (:) !u* in similarity theory [m/s] + real(r8), allocatable :: qstar_ (:) !q* in similarity theory [kg/kg] + real(r8), allocatable :: tstar_ (:) !t* in similarity theory [K] + real(r8), allocatable :: fm_ (:) !integral of profile function for momentum + real(r8), allocatable :: fh_ (:) !integral of profile function for heat + real(r8), allocatable :: fq_ (:) !integral of profile function for moisture + + real(r8), allocatable :: sum_irrig_ (:) !total irrigation amount [kg/m2] + real(r8), allocatable :: sum_irrig_count_ (:) !total irrigation counts [-] + + ! for LULC_IGBP_PFT and LULC_IGBP_PC + real(r8), allocatable :: tleaf_p_ (:) !shaded leaf temperature [K] + real(r8), allocatable :: ldew_rain_p_ (:) !depth of rain on foliage [mm] + real(r8), allocatable :: ldew_snow_p_ (:) !depth of snow on foliage [mm] + real(r8), allocatable :: ldew_p_ (:) !depth of water on foliage [mm] + real(r8), allocatable :: sigf_p_ (:) !fraction of veg cover, excluding snow-covered veg [-] + + !TODO@yuan: to check the below for PC whether they are needed + real(r8), allocatable :: tref_p_ (:) !2 m height air temperature [kelvin] + real(r8), allocatable :: qref_p_ (:) !2 m height air specific humidity + real(r8), allocatable :: rst_p_ (:) !canopy stomatal resistance (s/m) + real(r8), allocatable :: z0m_p_ (:) !effective roughness [m] + + ! Plant Hydraulic variables + real(r8), allocatable :: vegwp_p_ (:,:) !vegetation water potential [mm] + real(r8), allocatable :: gs0sun_p_ (:) !working copy of sunlit stomata conductance + real(r8), allocatable :: gs0sha_p_ (:) !working copy of shalit stomata conductance + ! end plant hydraulic variables + + ! Ozone Stress Variables + real(r8), allocatable :: lai_old_p_ (:) !lai in last time step + real(r8), allocatable :: o3uptakesun_p_ (:) !Ozone does, sunlit leaf (mmol O3/m^2) + real(r8), allocatable :: o3uptakesha_p_ (:) !Ozone does, shaded leaf (mmol O3/m^2) + ! End Ozone Stress Variables ! for URBAN_MODEL - REAL(r8), allocatable :: fwsun_ (:) !sunlit fraction of walls [-] - REAL(r8), allocatable :: dfwsun_ (:) !change of sunlit fraction of walls [-] + real(r8), allocatable :: fwsun_ (:) !sunlit fraction of walls [-] + real(r8), allocatable :: dfwsun_ (:) !change of sunlit fraction of walls [-] ! shortwave absorption - REAL(r8), allocatable :: sroof_ (:,:,:) !roof aborption [-] - REAL(r8), allocatable :: swsun_ (:,:,:) !sunlit wall absorption [-] - REAL(r8), allocatable :: swsha_ (:,:,:) !shaded wall absorption [-] - REAL(r8), allocatable :: sgimp_ (:,:,:) !impervious absorptioin [-] - REAL(r8), allocatable :: sgper_ (:,:,:) !pervious absorptioin [-] - REAL(r8), allocatable :: slake_ (:,:,:) !urban lake absorptioin [-] + real(r8), allocatable :: sroof_ (:,:,:) !roof aborption [-] + real(r8), allocatable :: swsun_ (:,:,:) !sunlit wall absorption [-] + real(r8), allocatable :: swsha_ (:,:,:) !shaded wall absorption [-] + real(r8), allocatable :: sgimp_ (:,:,:) !impervious absorptioin [-] + real(r8), allocatable :: sgper_ (:,:,:) !pervious absorptioin [-] + real(r8), allocatable :: slake_ (:,:,:) !urban lake absorptioin [-] ! net longwave radiation for last time temperature change - REAL(r8), allocatable :: lwsun_ (:) !net longwave of sunlit wall [W/m2] - REAL(r8), allocatable :: lwsha_ (:) !net longwave of shaded wall [W/m2] - REAL(r8), allocatable :: lgimp_ (:) !net longwave of impervious [W/m2] - REAL(r8), allocatable :: lgper_ (:) !net longwave of pervious [W/m2] - REAL(r8), allocatable :: lveg_ (:) !net longwave of vegetation [W/m2] - - REAL(r8), allocatable :: z_sno_roof_ (:,:) !node depth of roof [m] - REAL(r8), allocatable :: z_sno_gimp_ (:,:) !node depth of impervious [m] - REAL(r8), allocatable :: z_sno_gper_ (:,:) !node depth pervious [m] - REAL(r8), allocatable :: z_sno_lake_ (:,:) !node depth lake [m] - - REAL(r8), allocatable :: dz_sno_roof_ (:,:) !interface depth of roof [m] - REAL(r8), allocatable :: dz_sno_gimp_ (:,:) !interface depth of impervious [m] - REAL(r8), allocatable :: dz_sno_gper_ (:,:) !interface depth pervious [m] - REAL(r8), allocatable :: dz_sno_lake_ (:,:) !interface depth lake [m] - - REAL(r8), allocatable :: troof_inner_ (:) !temperature of roof [K] - REAL(r8), allocatable :: twsun_inner_ (:) !temperature of sunlit wall [K] - REAL(r8), allocatable :: twsha_inner_ (:) !temperature of shaded wall [K] - - REAL(r8), allocatable :: t_roofsno_ (:,:) !temperature of roof [K] - REAL(r8), allocatable :: t_wallsun_ (:,:) !temperature of sunlit wall [K] - REAL(r8), allocatable :: t_wallsha_ (:,:) !temperature of shaded wall [K] - REAL(r8), allocatable :: t_gimpsno_ (:,:) !temperature of impervious [K] - REAL(r8), allocatable :: t_gpersno_ (:,:) !temperature of pervious [K] - REAL(r8), allocatable :: t_lakesno_ (:,:) !temperature of pervious [K] - - REAL(r8), allocatable :: wliq_roofsno_(:,:) !liquid water in layers [kg/m2] - REAL(r8), allocatable :: wliq_gimpsno_(:,:) !liquid water in layers [kg/m2] - REAL(r8), allocatable :: wliq_gpersno_(:,:) !liquid water in layers [kg/m2] - REAL(r8), allocatable :: wliq_lakesno_(:,:) !liquid water in layers [kg/m2] - REAL(r8), allocatable :: wice_roofsno_(:,:) !ice lens in layers [kg/m2] - REAL(r8), allocatable :: wice_gimpsno_(:,:) !ice lens in layers [kg/m2] - REAL(r8), allocatable :: wice_gpersno_(:,:) !ice lens in layers [kg/m2] - REAL(r8), allocatable :: wice_lakesno_(:,:) !ice lens in layers [kg/m2] - - REAL(r8), allocatable :: sag_roof_ (:) !roof snow age [-] - REAL(r8), allocatable :: sag_gimp_ (:) !impervious ground snow age [-] - REAL(r8), allocatable :: sag_gper_ (:) !pervious ground snow age [-] - REAL(r8), allocatable :: sag_lake_ (:) !urban lake snow age [-] - - REAL(r8), allocatable :: scv_roof_ (:) !roof snow cover [-] - REAL(r8), allocatable :: scv_gimp_ (:) !impervious ground snow cover [-] - REAL(r8), allocatable :: scv_gper_ (:) !pervious ground snow cover [-] - REAL(r8), allocatable :: scv_lake_ (:) !urban lake snow cover [-] - - REAL(r8), allocatable :: fsno_roof_ (:) !roof snow fraction [-] - REAL(r8), allocatable :: fsno_gimp_ (:) !impervious ground snow fraction [-] - REAL(r8), allocatable :: fsno_gper_ (:) !pervious ground snow fraction [-] - REAL(r8), allocatable :: fsno_lake_ (:) !urban lake snow fraction [-] - - REAL(r8), allocatable :: snowdp_roof_ (:) !roof snow depth [m] - REAL(r8), allocatable :: snowdp_gimp_ (:) !impervious ground snow depth [m] - REAL(r8), allocatable :: snowdp_gper_ (:) !pervious ground snow depth [m] - REAL(r8), allocatable :: snowdp_lake_ (:) !urban lake snow depth [m] - - REAL(r8), allocatable :: t_room_ (:) !temperature of inner building [K] - REAL(r8), allocatable :: tafu_ (:) !temperature of outer building [K] - REAL(r8), allocatable :: Fhac_ (:) !sensible flux from heat or cool AC [W/m2] - REAL(r8), allocatable :: Fwst_ (:) !waste heat flux from heat or cool AC [W/m2] - REAL(r8), allocatable :: Fach_ (:) !flux from inner and outter air exchange [W/m2] - + real(r8), allocatable :: lwsun_ (:) !net longwave of sunlit wall [W/m2] + real(r8), allocatable :: lwsha_ (:) !net longwave of shaded wall [W/m2] + real(r8), allocatable :: lgimp_ (:) !net longwave of impervious [W/m2] + real(r8), allocatable :: lgper_ (:) !net longwave of pervious [W/m2] + real(r8), allocatable :: lveg_ (:) !net longwave of vegetation [W/m2] + + real(r8), allocatable :: z_sno_roof_ (:,:) !node depth of roof [m] + real(r8), allocatable :: z_sno_gimp_ (:,:) !node depth of impervious [m] + real(r8), allocatable :: z_sno_gper_ (:,:) !node depth pervious [m] + real(r8), allocatable :: z_sno_lake_ (:,:) !node depth lake [m] + + real(r8), allocatable :: dz_sno_roof_ (:,:) !interface depth of roof [m] + real(r8), allocatable :: dz_sno_gimp_ (:,:) !interface depth of impervious [m] + real(r8), allocatable :: dz_sno_gper_ (:,:) !interface depth pervious [m] + real(r8), allocatable :: dz_sno_lake_ (:,:) !interface depth lake [m] + + real(r8), allocatable :: troof_inner_ (:) !temperature of roof [K] + real(r8), allocatable :: twsun_inner_ (:) !temperature of sunlit wall [K] + real(r8), allocatable :: twsha_inner_ (:) !temperature of shaded wall [K] + + real(r8), allocatable :: t_roofsno_ (:,:) !temperature of roof [K] + real(r8), allocatable :: t_wallsun_ (:,:) !temperature of sunlit wall [K] + real(r8), allocatable :: t_wallsha_ (:,:) !temperature of shaded wall [K] + real(r8), allocatable :: t_gimpsno_ (:,:) !temperature of impervious [K] + real(r8), allocatable :: t_gpersno_ (:,:) !temperature of pervious [K] + real(r8), allocatable :: t_lakesno_ (:,:) !temperature of pervious [K] + + real(r8), allocatable :: wliq_roofsno_(:,:) !liquid water in layers [kg/m2] + real(r8), allocatable :: wliq_gimpsno_(:,:) !liquid water in layers [kg/m2] + real(r8), allocatable :: wliq_gpersno_(:,:) !liquid water in layers [kg/m2] + real(r8), allocatable :: wliq_lakesno_(:,:) !liquid water in layers [kg/m2] + real(r8), allocatable :: wice_roofsno_(:,:) !ice lens in layers [kg/m2] + real(r8), allocatable :: wice_gimpsno_(:,:) !ice lens in layers [kg/m2] + real(r8), allocatable :: wice_gpersno_(:,:) !ice lens in layers [kg/m2] + real(r8), allocatable :: wice_lakesno_(:,:) !ice lens in layers [kg/m2] + + real(r8), allocatable :: sag_roof_ (:) !roof snow age [-] + real(r8), allocatable :: sag_gimp_ (:) !impervious ground snow age [-] + real(r8), allocatable :: sag_gper_ (:) !pervious ground snow age [-] + real(r8), allocatable :: sag_lake_ (:) !urban lake snow age [-] + + real(r8), allocatable :: scv_roof_ (:) !roof snow cover [-] + real(r8), allocatable :: scv_gimp_ (:) !impervious ground snow cover [-] + real(r8), allocatable :: scv_gper_ (:) !pervious ground snow cover [-] + real(r8), allocatable :: scv_lake_ (:) !urban lake snow cover [-] + + real(r8), allocatable :: fsno_roof_ (:) !roof snow fraction [-] + real(r8), allocatable :: fsno_gimp_ (:) !impervious ground snow fraction [-] + real(r8), allocatable :: fsno_gper_ (:) !pervious ground snow fraction [-] + real(r8), allocatable :: fsno_lake_ (:) !urban lake snow fraction [-] + + real(r8), allocatable :: snowdp_roof_ (:) !roof snow depth [m] + real(r8), allocatable :: snowdp_gimp_ (:) !impervious ground snow depth [m] + real(r8), allocatable :: snowdp_gper_ (:) !pervious ground snow depth [m] + real(r8), allocatable :: snowdp_lake_ (:) !urban lake snow depth [m] + + !TODO: condsider renaming the below variables + real(r8), allocatable :: Fhac_ (:) !sensible flux from heat or cool AC [W/m2] + real(r8), allocatable :: Fwst_ (:) !waste heat flux from heat or cool AC [W/m2] + real(r8), allocatable :: Fach_ (:) !flux from inner and outter air exchange [W/m2] + real(r8), allocatable :: Fahe_ (:) !flux from metabolism and vehicle [W/m2] + real(r8), allocatable :: Fhah_ (:) !sensible heat flux from heating [W/m2] + real(r8), allocatable :: vehc_ (:) !flux from vehicle [W/m2] + real(r8), allocatable :: meta_ (:) !flux from metabolism [W/m2] + + real(r8), allocatable :: t_room_ (:) !temperature of inner building [K] + real(r8), allocatable :: t_roof_ (:) !temperature of roof [K] + real(r8), allocatable :: t_wall_ (:) !temperature of wall [K] + real(r8), allocatable :: tafu_ (:) !temperature of outer building [K] + + real(r8), allocatable :: urb_green_ (:) !fractional of green leaf in urban patch [-] ! PUBLIC MEMBER FUNCTIONS: - PUBLIC :: allocate_LuLccTimeVariables - PUBLIC :: deallocate_LuLccTimeVariables - PUBLIC :: SAVE_LuLccTimeVariables - PUBLIC :: REST_LuLccTimeVariables + PUBLIC :: allocate_LulccTimeVariables + PUBLIC :: deallocate_LulccTimeVariables + PUBLIC :: SAVE_LulccTimeVariables + PUBLIC :: REST_LulccTimeVariables ! PRIVATE MEMBER FUNCTIONS: @@ -157,23 +217,19 @@ MODULE MOD_LuLcc_Vars_TimeVariables !----------------------------------------------------------------------- - SUBROUTINE allocate_LuLccTimeVariables + SUBROUTINE allocate_LulccTimeVariables ! -------------------------------------------------------------------- - ! Allocates memory for LuLcc time variant variables + ! Allocates memory for Lulcc time variant variables ! -------------------------------------------------------------------- - use MOD_SPMD_Task + USE MOD_SPMD_Task USE MOD_Precision USE MOD_Vars_Global USE MOD_LandPatch -#ifdef LULC_IGBP_PFT +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) USE MOD_Vars_PFTimeVariables USE MOD_LandPFT #endif -#ifdef LULC_IGBP_PC - USE MOD_Vars_PCTimeVariables - USE MOD_LandPC -#endif #ifdef URBAN_MODEL USE MOD_Urban_Vars_TimeVariables USE MOD_LandUrban @@ -188,60 +244,92 @@ SUBROUTINE allocate_LuLccTimeVariables allocate (t_soisno_ (maxsnl+1:nl_soil,numpatch)) allocate (wliq_soisno_ (maxsnl+1:nl_soil,numpatch)) allocate (wice_soisno_ (maxsnl+1:nl_soil,numpatch)) + allocate (smp_ (1:nl_soil,numpatch)) + allocate (hk_ (1:nl_soil,numpatch)) allocate (t_grnd_ (numpatch)) allocate (tleaf_ (numpatch)) allocate (ldew_ (numpatch)) + allocate (ldew_rain_ (numpatch)) + allocate (ldew_snow_ (numpatch)) allocate (sag_ (numpatch)) allocate (scv_ (numpatch)) allocate (snowdp_ (numpatch)) - allocate (fveg_ (numpatch)) allocate (fsno_ (numpatch)) allocate (sigf_ (numpatch)) - allocate (green_ (numpatch)) - allocate (lai_ (numpatch)) - allocate (sai_ (numpatch)) - allocate (coszen_ (numpatch)) - allocate (alb_ (2,2,numpatch)) - allocate (ssun_ (2,2,numpatch)) - allocate (ssha_ (2,2,numpatch)) - allocate (thermk_ (numpatch)) - allocate (extkb_ (numpatch)) - allocate (extkd_ (numpatch)) allocate (zwt_ (numpatch)) allocate (wa_ (numpatch)) + allocate (wdsrf_ (numpatch)) + allocate (rss_ (numpatch)) allocate (t_lake_ (nl_lake,numpatch)) allocate (lake_icefrac_ (nl_lake,numpatch)) + allocate (savedtke1_ (numpatch)) + + !Plant Hydraulic variables + allocate (vegwp_ (1:nvegwcs,numpatch)) + allocate (gs0sun_ (numpatch)) + allocate (gs0sha_ (numpatch)) + !END plant hydraulic variables + + !Ozone Stress variables + allocate (lai_old_ (numpatch)) + allocate (o3uptakesun_ (numpatch)) + allocate (o3uptakesha_ (numpatch)) + !End ozone stress variables + + allocate (snw_rds_ (maxsnl+1:0,numpatch)) + allocate (mss_bcpho_ (maxsnl+1:0,numpatch)) + allocate (mss_bcphi_ (maxsnl+1:0,numpatch)) + allocate (mss_ocpho_ (maxsnl+1:0,numpatch)) + allocate (mss_ocphi_ (maxsnl+1:0,numpatch)) + allocate (mss_dst1_ (maxsnl+1:0,numpatch)) + allocate (mss_dst2_ (maxsnl+1:0,numpatch)) + allocate (mss_dst3_ (maxsnl+1:0,numpatch)) + allocate (mss_dst4_ (maxsnl+1:0,numpatch)) + allocate (ssno_lyr_ (2,2,maxsnl+1:1,numpatch)) + + allocate (trad_ (numpatch)) + allocate (tref_ (numpatch)) + allocate (qref_ (numpatch)) + allocate (rst_ (numpatch)) + allocate (emis_ (numpatch)) + allocate (z0m_ (numpatch)) + allocate (zol_ (numpatch)) + allocate (rib_ (numpatch)) + allocate (ustar_ (numpatch)) + allocate (qstar_ (numpatch)) + allocate (tstar_ (numpatch)) + allocate (fm_ (numpatch)) + allocate (fh_ (numpatch)) + allocate (fq_ (numpatch)) + + allocate (sum_irrig_ (numpatch)) + allocate (sum_irrig_count_ (numpatch)) ENDIF -#ifdef LULC_IGBP_PFT +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) IF (numpft > 0) THEN allocate (tleaf_p_ (numpft)) allocate (ldew_p_ (numpft)) + allocate (ldew_rain_p_ (numpft)) + allocate (ldew_snow_p_ (numpft)) allocate (sigf_p_ (numpft)) - allocate (lai_p_ (numpft)) - allocate (sai_p_ (numpft)) - allocate (ssun_p_ (2,2,numpft)) - allocate (ssha_p_ (2,2,numpft)) - allocate (thermk_p_ (numpft)) - allocate (extkb_p_ (numpft)) - allocate (extkd_p_ (numpft)) - ENDIF -#endif - -#ifdef LULC_IGBP_PC - IF (numpc > 0) THEN - allocate (tleaf_c_ (0:N_PFT-1,numpc)) - allocate (ldew_c_ (0:N_PFT-1,numpc)) - allocate (sigf_c_ (0:N_PFT-1,numpc)) - allocate (lai_c_ (0:N_PFT-1,numpc)) - allocate (sai_c_ (0:N_PFT-1,numpc)) - allocate (ssun_c_ (2,2,0:N_PFT-1,numpc)) - allocate (ssha_c_ (2,2,0:N_PFT-1,numpc)) - allocate (thermk_c_ (0:N_PFT-1,numpc)) - allocate (fshade_c_ (0:N_PFT-1,numpc)) - allocate (extkb_c_ (0:N_PFT-1,numpc)) - allocate (extkd_c_ (0:N_PFT-1,numpc)) + allocate (tref_p_ (numpft)) + allocate (qref_p_ (numpft)) + allocate (rst_p_ (numpft)) + allocate (z0m_p_ (numpft)) + + ! Plant Hydraulic variables + allocate (vegwp_p_ (1:nvegwcs,numpft)) + allocate (gs0sun_p_ (numpft)) + allocate (gs0sha_p_ (numpft)) + ! end plant hydraulic variables + + ! Allocate Ozone Stress Variables + allocate (lai_old_p_ (numpft)) + allocate (o3uptakesun_p_ (numpft)) + allocate (o3uptakesha_p_ (numpft)) + ! End allocate Ozone Stress Variables ENDIF #endif @@ -310,29 +398,33 @@ SUBROUTINE allocate_LuLccTimeVariables allocate (snowdp_gper_ (numurban)) allocate (snowdp_lake_ (numurban)) - allocate (t_room_ (numurban)) - allocate (tafu_ (numurban)) allocate (Fhac_ (numurban)) allocate (Fwst_ (numurban)) allocate (Fach_ (numurban)) + allocate (Fahe_ (numurban)) + allocate (Fhah_ (numurban)) + allocate (vehc_ (numurban)) + allocate (meta_ (numurban)) + allocate (t_room_ (numurban)) + allocate (t_roof_ (numurban)) + allocate (t_wall_ (numurban)) + allocate (tafu_ (numurban)) + allocate (urb_green_ (numurban)) ENDIF #endif ENDIF - END SUBROUTINE allocate_LuLccTimeVariables + END SUBROUTINE allocate_LulccTimeVariables - SUBROUTINE SAVE_LuLccTimeVariables + SUBROUTINE SAVE_LulccTimeVariables USE MOD_Precision - use MOD_SPMD_Task + USE MOD_SPMD_Task USE MOD_Vars_Global USE MOD_Vars_TimeVariables -#ifdef LULC_IGBP_PFT +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) USE MOD_Vars_PFTimeVariables #endif -#ifdef LULC_IGBP_PC - USE MOD_Vars_PCTimeVariables -#endif #ifdef URBAN_MODEL USE MOD_Urban_Vars_TimeVariables #endif @@ -345,56 +437,95 @@ SUBROUTINE SAVE_LuLccTimeVariables t_soisno_ = t_soisno wliq_soisno_ = wliq_soisno wice_soisno_ = wice_soisno + smp_ = smp + hk_ = hk t_grnd_ = t_grnd tleaf_ = tleaf ldew_ = ldew + ldew_rain_ = ldew_rain + ldew_snow_ = ldew_snow sag_ = sag scv_ = scv snowdp_ = snowdp - fveg_ = fveg fsno_ = fsno sigf_ = sigf - green_ = green - lai_ = lai - sai_ = sai - coszen_ = coszen - alb_ = alb - ssun_ = ssun - ssha_ = ssha - thermk_ = thermk - extkb_ = extkb - extkd_ = extkd zwt_ = zwt wa_ = wa + wdsrf_ = wdsrf + rss_ = rss t_lake_ = t_lake lake_icefrac_ = lake_icefrac + savedtke1_ = savedtke1 -#ifdef LULC_IGBP_PFT +IF(DEF_USE_PLANTHYDRAULICS)THEN + vegwp_ = vegwp + gs0sun_ = gs0sun + gs0sha_ = gs0sha +ENDIF + +IF(DEF_USE_OZONESTRESS)THEN + lai_old_ = lai_old + o3uptakesun_ = o3uptakesun + o3uptakesha_ = o3uptakesha +ENDIF + snw_rds_ = snw_rds + mss_bcpho_ = mss_bcpho + mss_bcphi_ = mss_bcphi + mss_ocpho_ = mss_ocpho + mss_ocphi_ = mss_ocphi + mss_dst1_ = mss_dst1 + mss_dst2_ = mss_dst2 + mss_dst3_ = mss_dst3 + mss_dst4_ = mss_dst4 + ssno_lyr_ = ssno_lyr + + trad_ = trad + tref_ = tref + qref_ = qref + rst_ = rst + emis_ = emis + z0m_ = z0m + displa_ = displa + zol_ = zol + rib_ = rib + ustar_ = ustar + qstar_ = qstar + tstar_ = tstar + fm_ = fm + fh_ = fh + fq_ = fq + +IF (DEF_USE_IRRIGATION) THEN + sum_irrig_ = sum_irrig + sum_irrig_count_ = sum_irrig_count +ENDIF + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) tleaf_p_ = tleaf_p ldew_p_ = ldew_p + ldew_rain_p_ = ldew_rain_p + ldew_snow_p_ = ldew_snow_p sigf_p_ = sigf_p - lai_p_ = lai_p - sai_p_ = sai_p - ssun_p_ = ssun_p - ssha_p_ = ssha_p - thermk_p_ = thermk_p - extkb_p_ = extkb_p - extkd_p_ = extkd_p -#endif -#ifdef LULC_IGBP_PC - tleaf_c_ = tleaf_c - ldew_c_ = ldew_c - sigf_c_ = sigf_c - lai_c_ = lai_c - sai_c_ = sai_c - ssun_c_ = ssun_c - ssha_c_ = ssha_c - thermk_c_ = thermk_c - fshade_c_ = fshade_c - extkb_c_ = extkb_c - extkd_c_ = extkd_c + tref_p_ = tref_p + qref_p_ = qref_p + rst_p_ = rst_p + z0m_p_ = z0m_p +IF(DEF_USE_PLANTHYDRAULICS)THEN + ! Plant Hydraulic variables + vegwp_p_ = vegwp_p + gs0sun_p_ = gs0sun_p + gs0sha_p_ = gs0sha_p + ! end plant hydraulic variables +ENDIF +IF(DEF_USE_OZONESTRESS)THEN + ! Ozone Stress Variables + lai_old_p_ = lai_old_p + o3uptakesun_p_ = o3uptakesun_p + o3uptakesha_p_ = o3uptakesha_p + ! End allocate Ozone Stress Variables +ENDIF #endif #ifdef URBAN_MODEL @@ -461,20 +592,27 @@ SUBROUTINE SAVE_LuLccTimeVariables snowdp_gper_ = snowdp_gper snowdp_lake_ = snowdp_lake - t_room_ = t_room - tafu_ = tafu Fhac_ = Fhac Fwst_ = Fwst Fach_ = Fach + Fahe_ = Fahe + Fhah_ = Fhah + vehc_ = vehc + meta_ = meta + t_room_ = t_room + t_roof_ = t_roof + t_wall_ = t_wall + tafu_ = tafu + urb_green_ = urb_green #endif ENDIF - END SUBROUTINE SAVE_LuLccTimeVariables + END SUBROUTINE SAVE_LulccTimeVariables - SUBROUTINE REST_LuLccTimeVariables + SUBROUTINE REST_LulccTimeVariables - use MOD_SPMD_Task + USE MOD_SPMD_Task USE MOD_Precision USE MOD_Vars_Global USE MOD_LandPatch @@ -482,16 +620,12 @@ SUBROUTINE REST_LuLccTimeVariables USE MOD_Mesh USE MOD_Vars_TimeInvariants USE MOD_Vars_TimeVariables - USE MOD_LuLcc_Vars_TimeInvariants -#ifdef LULC_IGBP_PFT + USE MOD_Lulcc_Vars_TimeInvariants +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) USE MOD_Vars_PFTimeInvariants USE MOD_Vars_PFTimeVariables USE MOD_LandPFT #endif -#ifdef LULC_IGBP_PC - USE MOD_Vars_PCTimeVariables - USE MOD_LandPC -#endif #ifdef URBAN_MODEL USE MOD_Urban_Vars_TimeVariables USE MOD_LandUrban @@ -499,12 +633,12 @@ SUBROUTINE REST_LuLccTimeVariables IMPLICIT NONE - REAL(r8), allocatable, dimension(:) :: grid_patch_s , grid_patch_e - REAL(r8), allocatable, dimension(:) :: grid_patch_s_, grid_patch_e_ - INTEGER , allocatable, dimension(:) :: locpxl - INTEGER i, j, np, np_, ip, ip_, pc, pc_, u, u_ - INTEGER ps, ps_, pe, pe_ - INTEGER numpxl, ipxl + real(r8), allocatable, dimension(:) :: grid_patch_s , grid_patch_e + real(r8), allocatable, dimension(:) :: grid_patch_s_, grid_patch_e_ + integer , allocatable, dimension(:) :: locpxl + integer i, j, np, np_, ip, ip_, pc, pc_, u, u_ + integer ps, ps_, pe, pe_ + integer numpxl, ipxl IF (p_is_worker) THEN ! allocate with numelm @@ -578,46 +712,109 @@ SUBROUTINE REST_LuLccTimeVariables CYCLE ENDIF +#ifdef URBAN_MODEL + u = patch2urban (np ) + u_= patch2urban_(np_) + + ! vars assignment needs same urb class for urban patch + IF (patchclass(np) == URBAN) THEN + ! if a Urban type is missing, CYCLE + IF (landurban%settyp(u) > urbclass_(u_)) THEN + np_= np_+ 1 + CYCLE + ENDIF + + ! if a urban type is added, CYCLE + IF (landurban%settyp(u) < urbclass_(u_)) THEN + np = np + 1 + CYCLE + ENDIF + ENDIF +#endif ! otherwise, set patch value - ! only for the same patch TYPE + ! only for the same patch type z_sno (:,np) = z_sno_ (:,np_) dz_sno (:,np) = dz_sno_ (:,np_) t_soisno (:,np) = t_soisno_ (:,np_) wliq_soisno (:,np) = wliq_soisno_ (:,np_) wice_soisno (:,np) = wice_soisno_ (:,np_) + scv (np) = scv_ (np_) + smp (:,np) = smp_ (:,np_) + hk (:,np) = hk_ (:,np_) t_grnd (np) = t_grnd_ (np_) tleaf (np) = tleaf_ (np_) ldew (np) = ldew_ (np_) + ldew_rain (np) = ldew_rain_ (np_) + ldew_snow (np) = ldew_snow_ (np_) sag (np) = sag_ (np_) - scv (np) = scv_ (np_) snowdp (np) = snowdp_ (np_) - fveg (np) = fveg_ (np_) fsno (np) = fsno_ (np_) sigf (np) = sigf_ (np_) - green (np) = green_ (np_) - lai (np) = lai_ (np_) - sai (np) = sai_ (np_) - coszen (np) = coszen_ (np_) - alb (:,:,np) = alb_ (:,:,np_) - ssun (:,:,np) = ssun_ (:,:,np_) - ssha (:,:,np) = ssha_ (:,:,np_) - thermk (np) = thermk_ (np_) - extkb (np) = extkb_ (np_) - extkd (np) = extkd_ (np_) + ! In case lai+sai come into existence this year, set sigf to 1 + IF ( (sigf(np) .eq. 0) .and. ((lai(np) + sai(np)) .gt. 0) ) THEN + sigf(np) = 1 + ENDIF zwt (np) = zwt_ (np_) wa (np) = wa_ (np_) + wdsrf (np) = wdsrf_ (np_) + rss (np) = rss_ (np_) t_lake (:,np) = t_lake_ (:,np_) lake_icefrac(:,np) = lake_icefrac_(:,np_) + savedtke1 (np) = savedtke1_ (np_) +IF(DEF_USE_PLANTHYDRAULICS)THEN + !Plant Hydraulic variables + vegwp (:,np) = vegwp_ (:,np_) + gs0sun (np) = gs0sun_ (np_) + gs0sha (np) = gs0sha_ (np_) + !END plant hydraulic variables +ENDIF +IF(DEF_USE_OZONESTRESS)THEN + !Ozone Stress variables + lai_old (np) = lai_old_ (np_) + o3uptakesun (np) = o3uptakesun_ (np_) + o3uptakesha (np) = o3uptakesha_ (np_) + !End ozone stress variables +ENDIF + snw_rds (:,np) = snw_rds_ (:,np_) + mss_bcpho (:,np) = mss_bcpho_ (:,np_) + mss_bcphi (:,np) = mss_bcphi_ (:,np_) + mss_ocpho (:,np) = mss_ocpho_ (:,np_) + mss_ocphi (:,np) = mss_ocphi_ (:,np_) + mss_dst1 (:,np) = mss_dst1_ (:,np_) + mss_dst2 (:,np) = mss_dst2_ (:,np_) + mss_dst3 (:,np) = mss_dst3_ (:,np_) + mss_dst4 (:,np) = mss_dst4_ (:,np_) + ssno_lyr(2,2,:,np) = ssno_lyr_(2,2,:,np_) + + trad (np) = trad_ (np_) + tref (np) = tref_ (np_) + qref (np) = qref_ (np_) + rst (np) = rst_ (np_) + emis (np) = emis_ (np_) + z0m (np) = z0m_ (np_) + zol (np) = zol_ (np_) + rib (np) = rib_ (np_) + ustar (np) = ustar_ (np_) + qstar (np) = qstar_ (np_) + tstar (np) = tstar_ (np_) + fm (np) = fm_ (np_) + fh (np) = fh_ (np_) + fq (np) = fq_ (np_) + +IF(DEF_USE_IRRIGATION)THEN + sum_irrig (np) = sum_irrig_ (np_) + sum_irrig_count (np) = sum_irrig_count_ (np_) +ENDIF -#ifdef LULC_IGBP_PFT +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) IF (patchtype(np)==0 .and. patchtype_(np_)==0) THEN ip = patch_pft_s (np ) ip_= patch_pft_s_(np_) IF (ip.le.0 .or. ip_.le.0) THEN - print *, "Error in REST_LuLccTimeVariables LULC_IGBP_PFT!" - STOP + print *, "Error in REST_LulccTimeVariables LULC_IGBP_PFT|LULC_IGBP_PC!" + CALL CoLM_stop () ENDIF DO WHILE (ip.le.patch_pft_e(np) .and. ip_.le.patch_pft_e_(np_)) @@ -637,71 +834,63 @@ SUBROUTINE REST_LuLccTimeVariables ! for the same PFT, set PFT value tleaf_p (ip) = tleaf_p_ (ip_) ldew_p (ip) = ldew_p_ (ip_) + ldew_rain_p(ip) = ldew_rain_p_(ip_) + ldew_snow_p(ip) = ldew_snow_p_(ip_) sigf_p (ip) = sigf_p_ (ip_) - lai_p (ip) = lai_p_ (ip_) - sai_p (ip) = sai_p_ (ip_) - ssun_p (:,:,ip) = ssun_p_ (:,:,ip_) - ssha_p (:,:,ip) = ssha_p_ (:,:,ip_) - thermk_p (ip) = thermk_p_ (ip_) - extkb_p (ip) = extkb_p_ (ip_) - extkd_p (ip) = extkd_p_ (ip_) + tref_p (ip) = tref_p_ (ip_) + qref_p (ip) = qref_p_ (ip_) + rst_p (ip) = rst_p_ (ip_) + z0m_p (ip) = z0m_p_ (ip_) + +IF(DEF_USE_PLANTHYDRAULICS)THEN + ! Plant Hydraulic variables + vegwp_p (:,ip) = vegwp_p_ (:,ip_) + gs0sun_p (ip) = gs0sun_p_ (ip_) + gs0sha_p (ip) = gs0sha_p_ (ip_) + ! end plant hydraulic variables +ENDIF +IF(DEF_USE_OZONESTRESS)THEN + ! Ozone Stress Variables + lai_old_p (ip) = lai_old_p_ (ip_) + o3uptakesun_p (ip) = o3uptakesun_p_ (ip_) + o3uptakesha_p (ip) = o3uptakesha_p_ (ip_) + ! End allocate Ozone Stress Variables +ENDIF ip = ip + 1 ip_= ip_+ 1 ENDDO -ENDIF -#endif - -#ifdef LULC_IGBP_PC -IF (patchtype(np)==0 .and. patchtype_(np_)==0) THEN - - pc = patch2pc (np ) - pc_= patch2pc_(np_) - - IF (pc.le.0 .or. pc_.le.0) THEN - print *, "Error in REST_LuLccTimeVariables LULC_IGBP_PC!" - STOP - ENDIF - - ! for the same patch TYPE - tleaf_c (:,pc) = tleaf_c_ (:,pc_) - ldew_c (:,pc) = ldew_c_ (:,pc_) - sigf_c (:,pc) = sigf_c_ (:,pc_) - lai_c (:,pc) = lai_c_ (:,pc_) - sai_c (:,pc) = sai_c_ (:,pc_) - ssun_c (:,:,:,pc) = ssun_c_ (:,:,:,pc_) - ssha_c (:,:,:,pc) = ssha_c_ (:,:,:,pc_) - thermk_c (:,pc) = thermk_c_ (:,pc_) - fshade_c (:,pc) = fshade_c_ (:,pc_) - extkb_c (:,pc) = extkb_c_ (:,pc_) - extkd_c (:,pc) = extkd_c_ (:,pc_) + ps = patch_pft_s(np) + pe = patch_pft_e(np) + ldew(np) = sum( ldew_p(ps:pe)*pftfrac(ps:pe) ) ENDIF #endif #ifdef URBAN_MODEL IF (patchclass(np)==URBAN .and. patchclass_(np_)==URBAN) THEN - u = patch2urban (np ) - u_= patch2urban_(np_) + + ! u = patch2urban (np ) + ! u_= patch2urban_(np_) IF (u.le.0 .or. u_.le.0) THEN - print *, "Error in REST_LuLccTimeVariables URBAN_MODEL!" - STOP + print *, "Error in REST_LulccTimeVariables URBAN_MODEL!" + CALL CoLM_stop () ENDIF - ! if a Urban TYPE is missing, CYCLE - IF (landurban%settyp(u) > urbclass_(u_)) THEN - np_= np_+ 1 - CYCLE - ENDIF + ! ! if a Urban type is missing, CYCLE + ! IF (landurban%settyp(u) > urbclass_(u_)) THEN + ! np_= np_+ 1 + ! CYCLE + ! ENDIF - ! if a urban TYPE is added, CYCLE - IF (landurban%settyp(u) < urbclass_(u_)) THEN - np = np + 1 - CYCLE - ENDIF + ! ! if a urban type is added, CYCLE + ! IF (landurban%settyp(u) < urbclass_(u_)) THEN + ! np = np + 1 + ! CYCLE + ! ENDIF ! otherwise, set urban value - ! include added urban and the same urban TYPE + ! include added urban and the same urban type fwsun (u) = fwsun_ (u_) dfwsun (u) = dfwsun_ (u_) @@ -765,11 +954,30 @@ SUBROUTINE REST_LuLccTimeVariables snowdp_gper (u) = snowdp_gper_ (u_) snowdp_lake (u) = snowdp_lake_ (u_) - t_room (u) = t_room_ (u_) - tafu (u) = tafu_ (u_) Fhac (u) = Fhac_ (u_) Fwst (u) = Fwst_ (u_) Fach (u) = Fach_ (u_) + Fahe (u) = Fahe_ (u_) + Fhah (u) = Fhah_ (u_) + vehc (u) = vehc_ (u_) + meta (u) = meta_ (u_) + t_room (u) = t_room_ (u_) + t_roof (u) = t_roof_ (u_) + t_wall (u) = t_wall_ (u_) + tafu (u) = tafu_ (u_) + urb_green (u) = urb_green_ (u_) + + wliq_soisno(: ,np) = 0. + wliq_soisno(:1,np) = wliq_roofsno(:1,u )*froof(u) + wliq_soisno(: ,np) = wliq_soisno (: ,np)+wliq_gpersno(: ,u)*(1-froof(u))*fgper(u) + wliq_soisno(:1,np) = wliq_soisno (:1,np)+wliq_gimpsno(:1,u)*(1-froof(u))*(1-fgper(u)) + + wice_soisno(: ,np) = 0. + wice_soisno(:1,np) = wice_roofsno(:1,u )*froof(u) + wice_soisno(: ,np) = wice_soisno (: ,np)+wice_gpersno(: ,u)*(1-froof(u))*fgper(u) + wice_soisno(:1,np) = wice_soisno (:1,np)+wice_gimpsno(:1,u)*(1-froof(u))*(1-fgper(u)) + + scv(np) = scv_roof(u)*froof(u) + scv_gper(u)*(1-froof(u))*fgper(u) + scv_gimp(u)*(1-froof(u))*(1-fgper(u)) ENDIF #endif np = np + 1 @@ -787,15 +995,15 @@ SUBROUTINE REST_LuLccTimeVariables IF (allocated(grid_patch_e_)) deallocate(grid_patch_e_) IF (allocated(locpxl )) deallocate(locpxl ) ENDIF - END SUBROUTINE REST_LuLccTimeVariables + END SUBROUTINE REST_LulccTimeVariables - SUBROUTINE deallocate_LuLccTimeVariables - use MOD_SPMD_Task - USE MOD_LuLcc_Vars_TimeInvariants, only: numpatch_, numpft_, numpc_, numurban_ + SUBROUTINE deallocate_LulccTimeVariables + USE MOD_SPMD_Task + USE MOD_Lulcc_Vars_TimeInvariants, only: numpatch_, numpft_, numpc_, numurban_ ! -------------------------------------------------- -! Deallocates memory for LuLcc time variant variables +! Deallocates memory for Lulcc time variant variables ! -------------------------------------------------- IF (p_is_worker) THEN IF (numpatch_ > 0) THEN @@ -804,60 +1012,93 @@ SUBROUTINE deallocate_LuLccTimeVariables deallocate (t_soisno_ ) deallocate (wliq_soisno_ ) deallocate (wice_soisno_ ) + deallocate (smp_ ) + deallocate (hk_ ) deallocate (t_grnd_ ) deallocate (tleaf_ ) deallocate (ldew_ ) + deallocate (ldew_rain_ ) + deallocate (ldew_snow_ ) deallocate (sag_ ) deallocate (scv_ ) deallocate (snowdp_ ) - deallocate (fveg_ ) deallocate (fsno_ ) deallocate (sigf_ ) - deallocate (green_ ) - deallocate (lai_ ) - deallocate (sai_ ) - deallocate (coszen_ ) - deallocate (alb_ ) - deallocate (ssun_ ) - deallocate (ssha_ ) - deallocate (thermk_ ) - deallocate (extkb_ ) - deallocate (extkd_ ) deallocate (zwt_ ) deallocate (wa_ ) + deallocate (wdsrf_ ) + deallocate (rss_ ) deallocate (t_lake_ ) deallocate (lake_icefrac_ ) + deallocate (savedtke1_ ) + + !Plant Hydraulic variables + deallocate (vegwp_ ) + deallocate (gs0sun_ ) + deallocate (gs0sha_ ) + !END plant hydraulic variables + + !Ozone Stress variables + deallocate (lai_old_ ) + deallocate (o3uptakesun_ ) + deallocate (o3uptakesha_ ) + !End ozone stress variables + + deallocate (snw_rds_ ) + deallocate (mss_bcpho_ ) + deallocate (mss_bcphi_ ) + deallocate (mss_ocpho_ ) + deallocate (mss_ocphi_ ) + deallocate (mss_dst1_ ) + deallocate (mss_dst2_ ) + deallocate (mss_dst3_ ) + deallocate (mss_dst4_ ) + deallocate (ssno_lyr_ ) + + deallocate (trad_ ) + deallocate (tref_ ) + deallocate (qref_ ) + deallocate (rst_ ) + deallocate (emis_ ) + deallocate (z0m_ ) + deallocate (zol_ ) + deallocate (rib_ ) + deallocate (ustar_ ) + deallocate (qstar_ ) + deallocate (tstar_ ) + deallocate (fm_ ) + deallocate (fh_ ) + deallocate (fq_ ) + + deallocate (sum_irrig_ ) + deallocate (sum_irrig_count_) + ENDIF -#ifdef LULC_IGBP_PFT +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) IF (numpft_ > 0) THEN deallocate (tleaf_p_ ) deallocate (ldew_p_ ) + deallocate (ldew_rain_p_ ) + deallocate (ldew_snow_p_ ) deallocate (sigf_p_ ) - deallocate (lai_p_ ) - deallocate (sai_p_ ) - deallocate (ssun_p_ ) - deallocate (ssha_p_ ) - deallocate (thermk_p_ ) - deallocate (extkb_p_ ) - deallocate (extkd_p_ ) - ENDIF -#endif - -#ifdef LULC_IGBP_PC - IF (numpc_ > 0) THEN - deallocate (tleaf_c_ ) - deallocate (ldew_c_ ) - deallocate (sigf_c_ ) - deallocate (lai_c_ ) - deallocate (sai_c_ ) - deallocate (ssun_c_ ) - deallocate (ssha_c_ ) - deallocate (thermk_c_ ) - deallocate (fshade_c_ ) - deallocate (extkb_c_ ) - deallocate (extkd_c_ ) + deallocate (tref_p_ ) + deallocate (qref_p_ ) + deallocate (rst_p_ ) + deallocate (z0m_p_ ) + + ! Plant Hydraulic variables + deallocate (vegwp_p_ ) + deallocate (gs0sun_p_ ) + deallocate (gs0sha_p_ ) + ! end plant hydraulic variables + + ! Allocate Ozone Stress Variables + deallocate (lai_old_p_ ) + deallocate (o3uptakesun_p_) + deallocate (o3uptakesha_p_) + ! End allocate Ozone Stress Variables ENDIF #endif @@ -926,16 +1167,23 @@ SUBROUTINE deallocate_LuLccTimeVariables deallocate (snowdp_gper_ ) deallocate (snowdp_lake_ ) - deallocate (t_room_ ) - deallocate (tafu_ ) deallocate (Fhac_ ) deallocate (Fwst_ ) deallocate (Fach_ ) + deallocate (Fahe_ ) + deallocate (Fhah_ ) + deallocate (vehc_ ) + deallocate (meta_ ) + deallocate (t_room_ ) + deallocate (t_roof_ ) + deallocate (t_wall_ ) + deallocate (tafu_ ) + deallocate (urb_green_ ) ENDIF #endif ENDIF - END SUBROUTINE deallocate_LuLccTimeVariables + END SUBROUTINE deallocate_LulccTimeVariables -END MODULE MOD_LuLcc_Vars_TimeVariables +END MODULE MOD_Lulcc_Vars_TimeVariables ! ---------- EOP ------------ diff --git a/main/LULCC/MOD_Lulcc_WaterConserve.F90 b/main/LULCC/MOD_Lulcc_WaterConserve.F90 deleted file mode 100644 index 98c9ab75..00000000 --- a/main/LULCC/MOD_Lulcc_WaterConserve.F90 +++ /dev/null @@ -1,26 +0,0 @@ -#include - - SUBROUTINE LulccWaterConserve -! ------------------------------- -! Created by Hua Yuan, 04/2022 -! ------------------------------- - - USE precision - USE GlobalVars - USE MOD_Vars_TimeInvariants - USE MOD_Vars_PFTimeInvariants - USE MOD_Vars_PCTimeInvariants - USE MOD_Vars_UrbanTimeInvariants - USE MOD_Vars_LuLccTimeInvariants - USE MOD_Vars_TimeVariables - USE MOD_Vars_PFTimeVariables - USE MOD_Vars_PCTimeVariables - USE MOD_Urban_Vars_TimeVariables - USE MOD_LuLcc_Vars_TimeVariables - - IMPLICIT NONE - -!TODO: need coding below... - - END SUBROUTINE LulccWaterConserve -! ---------- EOP ------------ diff --git a/main/MOD_3DCanopyRadiation.F90 b/main/MOD_3DCanopyRadiation.F90 index 3d876d35..e4f552a9 100644 --- a/main/MOD_3DCanopyRadiation.F90 +++ b/main/MOD_3DCanopyRadiation.F90 @@ -16,7 +16,7 @@ MODULE MOD_3DCanopyRadiation !----------------------------------------------------------------------- - CONTAINS +CONTAINS !----------------------------------------------------------------------- @@ -24,7 +24,7 @@ MODULE MOD_3DCanopyRadiation #ifdef LULC_IGBP_PC !----------------------------------------------------------------------- - SUBROUTINE ThreeDCanopy_wrap (ipatch, czen, albg, albv, ssun, ssha) + SUBROUTINE ThreeDCanopy_wrap (ipatch, czen, albg, albv, tran, ssun, ssha) ! ! !DESCRIPTION: @@ -43,92 +43,118 @@ SUBROUTINE ThreeDCanopy_wrap (ipatch, czen, albg, albv, ssun, ssha) ! USE MOD_Precision - USE MOD_LandPC + USE MOD_LandPFT, only: patch_pft_s, patch_pft_e USE MOD_Vars_Global USE MOD_Const_PFT - USE MOD_Vars_PCTimeInvariants - USE MOD_Vars_PCTimeVariables + USE MOD_Vars_PFTimeInvariants + USE MOD_Vars_PFTimeVariables IMPLICIT NONE - INTEGER, intent(in) :: ipatch - REAL(r8), Intent(in) :: czen - REAL(r8), Intent(in) :: albg(2,2) - REAL(r8), Intent(out) :: albv(2,2) - REAL(r8), Intent(out) :: ssun(2,2) - REAL(r8), Intent(out) :: ssha(2,2) + integer, intent(in) :: ipatch + real(r8), intent(in) :: czen + real(r8), intent(in) :: albg(2,2) + real(r8), intent(out) :: albv(2,2) + real(r8), intent(out) :: tran(2,3) + real(r8), intent(out) :: ssun(2,2) + real(r8), intent(out) :: ssha(2,2) ! local variables - INTEGER :: lbp, ubp; -#ifndef CROP - REAL(r8), dimension(0:N_PFT-1, 2) :: albd, albi, fabd, fabi, fadd - REAL(r8), dimension(0:N_PFT-1, 2) :: ftdd, ftid, ftii - REAL(r8), dimension(0:N_PFT-1, 2) :: rho, tau - REAL(r8), dimension(0:N_PFT-1) :: csiz, chgt, lsai - REAL(r8), dimension(0:N_PFT-1) :: fsun_id, fsun_ii, psun - REAL(r8), dimension(0:N_PFT-1) :: phi1, phi2, gdir -#else - REAL(r8), dimension(0:N_PFT+N_CFT-1, 2) :: albd, albi, fabd, fabi, fadd - REAL(r8), dimension(0:N_PFT+N_CFT-1, 2) :: ftdd, ftid, ftii - REAL(r8), dimension(0:N_PFT+N_CFT-1, 2) :: rho, tau - REAL(r8), dimension(0:N_PFT+N_CFT-1) :: csiz, chgt, lsai - REAL(r8), dimension(0:N_PFT+N_CFT-1) :: fsun_id, fsun_ii, psun - REAL(r8), dimension(0:N_PFT+N_CFT-1) :: phi1, phi2, gdir -#endif - - INTEGER p, pc - - ! get PC patch index - pc = patch2pc(ipatch) + integer :: i, p, ps, pe; + + ! define allocatable variables + integer, allocatable :: canlay(:) + real(r8), allocatable :: albd(:,:), albi(:,:) + real(r8), allocatable :: fabd(:,:), fabi(:,:), fadd(:,:) + real(r8), allocatable :: ftdd(:,:), ftid(:,:), ftii(:,:) + real(r8), allocatable :: rho (:,:), tau (:,:) + real(r8), allocatable :: csiz(:), chgt(:), chil(:), lsai(:) + real(r8), allocatable :: fsun_id(:), fsun_ii(:), psun(:) + real(r8), allocatable :: phi1(:), phi2(:), gdir(:) + + ! get patch PFT index + ps = patch_pft_s(ipatch) + pe = patch_pft_e(ipatch) + + ! allocate memory for defined variables + allocate (albd (ps:pe, 2) ) + allocate (albi (ps:pe, 2) ) + allocate (fabd (ps:pe, 2) ) + allocate (fabi (ps:pe, 2) ) + allocate (fadd (ps:pe, 2) ) + allocate (ftdd (ps:pe, 2) ) + allocate (ftid (ps:pe, 2) ) + allocate (ftii (ps:pe, 2) ) + allocate (rho (ps:pe, 2) ) + allocate (tau (ps:pe, 2) ) + allocate (csiz (ps:pe) ) + allocate (chgt (ps:pe) ) + allocate (chil (ps:pe) ) + allocate (lsai (ps:pe) ) + allocate (canlay (ps:pe) ) + allocate (fsun_id(ps:pe) ) + allocate (fsun_ii(ps:pe) ) + allocate (psun (ps:pe) ) + allocate (phi1 (ps:pe) ) + allocate (phi2 (ps:pe) ) + allocate (gdir (ps:pe) ) ! initialization albd=1.; albi=1.; fabd=0.; fabi=0.; ftdd=1.; ftid=0.; ftii=1.; fadd=0.; - lbp = 0; ubp = N_PFT-1; - csiz(:) = (htop_c(:,pc) - hbot_c(:,pc)) / 2 - chgt(:) = (htop_c(:,pc) + hbot_c(:,pc)) / 2 - lsai(:) = lai_c(:,pc) + sai_c(:,pc) + csiz(:) = (htop_p(ps:pe) - hbot_p(ps:pe)) / 2 + chgt(:) = (htop_p(ps:pe) + hbot_p(ps:pe)) / 2 + lsai(:) = lai_p(ps:pe) + sai_p(ps:pe) ! calculate weighted plant optical properties ! loop for each PFT rho = 0. tau = 0. - DO p = 0, N_PFT-1 - IF (lsai(p) > 0.) THEN - rho(p,:) = rho_p(:,1,p)*lai_c(p,pc)/lsai(p) & - + rho_p(:,2,p)*sai_c(p,pc)/lsai(p) - tau(p,:) = tau_p(:,1,p)*lai_c(p,pc)/lsai(p) & - + tau_p(:,2,p)*sai_c(p,pc)/lsai(p) + DO i = ps, pe + + p = pftclass(i) + canlay(i) = canlay_p(p) + chil(i) = chil_p(p) + + IF (lsai(i) > 0.) THEN + rho(i,:) = rho_p(:,1,p)*lai_p(i)/lsai(i) & + + rho_p(:,2,p)*sai_p(i)/lsai(i) + tau(i,:) = tau_p(:,1,p)*lai_p(i)/lsai(i) & + + tau_p(:,2,p)*sai_p(i)/lsai(i) ENDIF ENDDO - CALL ThreeDCanopy(lbp, ubp, canlay(:), pcfrac(:,pc), csiz, chgt, chil_p(:), czen, & + ! CALL 3D canopy radiation transfer model + CALL ThreeDCanopy(ps, pe, canlay, pftfrac(ps:pe), csiz, chgt, chil, czen, & lsai, rho, tau, albg(:,1), albg(:,2), albd, albi, & fabd, fabi, ftdd, ftid, ftii, fadd, psun, & - thermk_c(:,pc), fshade_c(:,pc) ) + thermk_p(ps:pe), fshade_p(ps:pe) ) - ! calculate extkb_c, extkd_c + ! calculate extkb_p, extkd_p ! applied for 1D case - extkd_c(:,pc) = 0.719 !used for scaling-up coefficients from leaf to canopy + extkd_p(ps:pe) = 0.719 !used for scaling-up coefficients from leaf to canopy ! 11/07/2018: calculate gee FUNCTION consider LAD - phi1 = 0.5 - 0.633 * chil_p(:) - 0.33 * chil_p(:) * chil_p(:) - phi2 = 0.877 * ( 1. - 2. * phi1 ) + DO i = ps, pe + p = pftclass(i) + phi1(i) = 0.5 - 0.633 * chil_p(p) - 0.33 * chil_p(p) * chil_p(p) + phi2(i) = 0.877 * ( 1. - 2. * phi1(i) ) + ENDDO ! 11/07/2018: calculate gee FUNCTION consider LAD gdir = phi1 + phi2*czen - extkb_c(:,pc) = gdir/czen + extkb_p(ps:pe) = gdir/czen fsun_id(:) = 0. fsun_ii(:) = 0. - DO p = 1, N_PFT-1 + DO p = ps, pe IF (lsai(p) > 0.) THEN - fsun_id(p) = (1._r8 - exp(-2._r8*extkb_c(p,pc)*lsai(p))) / & - (1._r8 - exp(-extkb_c(p,pc)*lsai(p))) / 2.0_r8 * psun(p) + fsun_id(p) = (1._r8 - exp(-2._r8*extkb_p(p)*lsai(p))) / & + (1._r8 - exp(-extkb_p(p)*lsai(p))) / 2.0_r8 * psun(p) - fsun_ii(p) = (1._r8 - exp(-extkb_c(p,pc)*lsai(p)-0.5/0.5_r8*lsai(p))) / & - (extkb_c(p,pc)+0.5/0.5_r8) / & + fsun_ii(p) = (1._r8 - exp(-extkb_p(p)*lsai(p)-0.5/0.5_r8*lsai(p))) / & + (extkb_p(p)+0.5/0.5_r8) / & (1._r8 - exp(-0.5/0.5_r8*lsai(p))) * & (0.5/0.5_r8) * psun(p) ENDIF @@ -136,38 +162,67 @@ SUBROUTINE ThreeDCanopy_wrap (ipatch, czen, albg, albv, ssun, ssha) ! calculate albv, ssun, ssha ! NOTE: CoLM (1/2,): vis/nir; (,1/2): dir/dif - albv(1,1) = albd(1,1); albv(1,2) = albi(1,1) - albv(2,1) = albd(1,2); albv(2,2) = albi(1,2) + albv(1,1) = albd(ps,1); albv(1,2) = albi(ps,1) + albv(2,1) = albd(ps,2); albv(2,2) = albi(ps,2) ! ssun(band, dir/dif, pft), fabd/fadd(pft, band) - ssun_c(1,1,:,pc) = fadd(:,1) + (fabd(:,1)-fadd(:,1))*fsun_id - ssun_c(2,1,:,pc) = fadd(:,2) + (fabd(:,2)-fadd(:,2))*fsun_id - ssha_c(1,1,:,pc) = (fabd(:,1)-fadd(:,1)) * (1.-fsun_id) - ssha_c(2,1,:,pc) = (fabd(:,2)-fadd(:,2)) * (1.-fsun_id) - ssun_c(1,2,:,pc) = fabi(:,1) * fsun_ii - ssun_c(2,2,:,pc) = fabi(:,2) * fsun_ii - ssha_c(1,2,:,pc) = fabi(:,1) * (1.-fsun_ii) - ssha_c(2,2,:,pc) = fabi(:,2) * (1.-fsun_ii) - - ssun(1,1) = sum( ssun_c(1,1,:,pc) * pcfrac(:,pc) ) - ssun(2,1) = sum( ssun_c(2,1,:,pc) * pcfrac(:,pc) ) - ssun(1,2) = sum( ssun_c(1,2,:,pc) * pcfrac(:,pc) ) - ssun(2,2) = sum( ssun_c(2,2,:,pc) * pcfrac(:,pc) ) - - ssha(1,1) = sum( ssha_c(1,1,:,pc) * pcfrac(:,pc) ) - ssha(2,1) = sum( ssha_c(2,1,:,pc) * pcfrac(:,pc) ) - ssha(1,2) = sum( ssha_c(1,2,:,pc) * pcfrac(:,pc) ) - ssha(2,2) = sum( ssha_c(2,2,:,pc) * pcfrac(:,pc) ) - - END SUBROUTINE ThreeDCanopy_wrap + ssun_p(1,1,ps:pe) = fadd(:,1) + (fabd(:,1)-fadd(:,1))*fsun_id + ssun_p(2,1,ps:pe) = fadd(:,2) + (fabd(:,2)-fadd(:,2))*fsun_id + ssha_p(1,1,ps:pe) = (fabd(:,1)-fadd(:,1)) * (1.-fsun_id) + ssha_p(2,1,ps:pe) = (fabd(:,2)-fadd(:,2)) * (1.-fsun_id) + ssun_p(1,2,ps:pe) = fabi(:,1) * fsun_ii + ssun_p(2,2,ps:pe) = fabi(:,2) * fsun_ii + ssha_p(1,2,ps:pe) = fabi(:,1) * (1.-fsun_ii) + ssha_p(2,2,ps:pe) = fabi(:,2) * (1.-fsun_ii) + + ssun(1,1) = sum( ssun_p(1,1,ps:pe) * pftfrac(ps:pe) ) + ssun(2,1) = sum( ssun_p(2,1,ps:pe) * pftfrac(ps:pe) ) + ssun(1,2) = sum( ssun_p(1,2,ps:pe) * pftfrac(ps:pe) ) + ssun(2,2) = sum( ssun_p(2,2,ps:pe) * pftfrac(ps:pe) ) + + ssha(1,1) = sum( ssha_p(1,1,ps:pe) * pftfrac(ps:pe) ) + ssha(2,1) = sum( ssha_p(2,1,ps:pe) * pftfrac(ps:pe) ) + ssha(1,2) = sum( ssha_p(1,2,ps:pe) * pftfrac(ps:pe) ) + ssha(2,2) = sum( ssha_p(2,2,ps:pe) * pftfrac(ps:pe) ) + + tran(1,1) = ftid(ps,1) + tran(2,1) = ftid(ps,2) + tran(1,3) = ftdd(ps,1) + tran(2,3) = ftdd(ps,2) + tran(1,2) = ftii(ps,1) + tran(2,2) = ftii(ps,2) + + ! deallocate memory for defined variables + deallocate (albd ) + deallocate (albi ) + deallocate (fabd ) + deallocate (fabi ) + deallocate (fadd ) + deallocate (ftdd ) + deallocate (ftid ) + deallocate (ftii ) + deallocate (rho ) + deallocate (tau ) + deallocate (csiz ) + deallocate (chgt ) + deallocate (chil ) + deallocate (lsai ) + deallocate (canlay ) + deallocate (fsun_id ) + deallocate (fsun_ii ) + deallocate (psun ) + deallocate (phi1 ) + deallocate (phi2 ) + deallocate (gdir ) + + END SUBROUTINE ThreeDCanopy_wrap #endif - SUBROUTINE ThreeDCanopy(lbp, ubp, canlev, pwtcol, csiz, chgt, chil, coszen, & - lsai, rho, tau, albgrd, albgri, albd, albi, & - fabd, fabi, ftdd, ftid, ftii, fadd, psun, & - thermk, fshade) - + SUBROUTINE ThreeDCanopy(ps, pe, canlay, fcover, csiz, chgt, chil, coszen, & + lsai, rho, tau, albgrd, albgri, albd, albi, & + fabd, fabi, ftdd, ftid, ftii, fadd, psun, & + thermk, fshade) ! ! !DESCRIPTION: ! ThreeDCanopy based on Dickinson (2008) using three canopy layer @@ -177,6 +232,10 @@ SUBROUTINE ThreeDCanopy(lbp, ubp, canlev, pwtcol, csiz, chgt, chil, coszen, & ! ! Created by Hua Yuan, 08/2019 ! +! !HISTORY: +! Before 2013: Robert E. Dickinson proposed the inital idea. Dickinson and +! Muhammad J. Shake contributed to the code writing. +! ! !REFERENCE: ! Yuan, H., R. E. Dickinson, Y. Dai, M. J. Shaikh, L. Zhou, W. Shangguan, ! and D. Ji, 2014: A 3D canopy radiative transfer model for global climate @@ -187,148 +246,148 @@ SUBROUTINE ThreeDCanopy(lbp, ubp, canlev, pwtcol, csiz, chgt, chil, coszen, & ! !ARGUMENTS: IMPLICIT NONE - INTEGER, parameter :: numrad = 2 + integer, parameter :: numrad = 2 ! !ARGUMENTS: - INTEGER , intent(in) :: lbp, ubp !pft bounds - INTEGER , intent(in) :: canlev(lbp:ubp) !canopy level for current pft - REAL(r8), intent(in) :: pwtcol(lbp:ubp) !weight of pft wrt corresponding column - REAL(r8), intent(in) :: csiz (lbp:ubp) !crown size of vegetation - REAL(r8), intent(in) :: chgt (lbp:ubp) !central height of crown - REAL(r8), intent(in) :: chil (lbp:ubp) !leaf angle distribution parameter - REAL(r8), intent(in) :: lsai (lbp:ubp) !LAI+SAI - REAL(r8), intent(in) :: rho (lbp:ubp,numrad) !leaf/stem refl weighted by fraction LAI and SAI - REAL(r8), intent(in) :: tau (lbp:ubp,numrad) !leaf/stem tran weighted by fraction LAI and SAI - - REAL(r8), intent(in) :: coszen !cosine solar zenith angle for next time step - REAL(r8), intent(in) :: albgrd(numrad) !ground albedo (direct) (column-level) - REAL(r8), intent(in) :: albgri(numrad) !ground albedo (diffuse)(column-level) - - REAL(r8), intent(out) :: albd(lbp:ubp,numrad) !surface albedo (direct) - REAL(r8), intent(out) :: albi(lbp:ubp,numrad) !surface albedo (diffuse) - REAL(r8), intent(out) :: fabd(lbp:ubp,numrad) !flux absorbed by veg per unit direct flux - REAL(r8), intent(out) :: fabi(lbp:ubp,numrad) !flux absorbed by veg per unit diffuse flux - REAL(r8), intent(out) :: ftdd(lbp:ubp,numrad) !down direct flux below veg per unit dir flx - REAL(r8), intent(out) :: ftid(lbp:ubp,numrad) !down diffuse flux below veg per unit dir flx - REAL(r8), intent(out) :: ftii(lbp:ubp,numrad) !down diffuse flux below veg per unit dif flx - REAL(r8), intent(out) :: fadd(lbp:ubp,numrad) !absorbed flux in direct mode per unit direct flux - REAL(r8), intent(out) :: psun (lbp:ubp) !percent sunlit vegetation cover - REAL(r8), intent(out) :: thermk(lbp:ubp) !direct transmittance of diffuse radiation - REAL(r8), intent(out) :: fshade(lbp:ubp) !shadow in diffuse case of vegetation + integer , intent(in) :: ps, pe !pft index bounds + integer , intent(in) :: canlay(ps:pe) !canopy level for current pft + real(r8), intent(in) :: fcover(ps:pe) !fractional cover of pft within a patch + real(r8), intent(in) :: csiz (ps:pe) !crown size of vegetation + real(r8), intent(in) :: chgt (ps:pe) !central height of crown + real(r8), intent(in) :: chil (ps:pe) !leaf angle distribution parameter + real(r8), intent(in) :: lsai (ps:pe) !LAI+SAI + real(r8), intent(in) :: rho (ps:pe,numrad) !leaf/stem refl weighted by fraction LAI and SAI + real(r8), intent(in) :: tau (ps:pe,numrad) !leaf/stem tran weighted by fraction LAI and SAI + + real(r8), intent(in) :: coszen !cosine solar zenith angle for next time step + real(r8), intent(in) :: albgrd(numrad) !ground albedo (direct) (column-level) + real(r8), intent(in) :: albgri(numrad) !ground albedo (diffuse)(column-level) + + real(r8), intent(out) :: albd(ps:pe,numrad) !surface albedo (direct) + real(r8), intent(out) :: albi(ps:pe,numrad) !surface albedo (diffuse) + real(r8), intent(out) :: fabd(ps:pe,numrad) !flux absorbed by veg per unit direct flux + real(r8), intent(out) :: fabi(ps:pe,numrad) !flux absorbed by veg per unit diffuse flux + real(r8), intent(out) :: ftdd(ps:pe,numrad) !down direct flux below veg per unit dir flx + real(r8), intent(out) :: ftid(ps:pe,numrad) !down diffuse flux below veg per unit dir flx + real(r8), intent(out) :: ftii(ps:pe,numrad) !down diffuse flux below veg per unit dif flx + real(r8), intent(out) :: fadd(ps:pe,numrad) !absorbed flux in direct mode per unit direct flux + real(r8), intent(out) :: psun (ps:pe) !percent sunlit vegetation cover + real(r8), intent(out) :: thermk(ps:pe) !direct transmittance of diffuse radiation + real(r8), intent(out) :: fshade(ps:pe) !shadow in diffuse case of vegetation ! !OTHER LOCAL VARIABLES: - REAL(r8), parameter :: mpe = 1.0e-06_r8 !prevents overflow for division by zero - INTEGER , parameter :: nlay=3 !number of canopy layers - REAL(r8), parameter :: D0=0.0_r8 !double accuracy REAL number - REAL(r8), parameter :: D1=1.0_r8 !double accuracy REAL number - REAL(r8), parameter :: D2=2.0_r8 !double accuracy REAL number - REAL(r8), parameter :: D3=3.0_r8 !double accuracy REAL number - REAL(r8), parameter :: D4=4.0_r8 !double accuracy REAL number - REAL(r8), parameter :: D6=6.0_r8 !double accuracy REAL number - REAL(r8), parameter :: D7=7.0_r8 !double accuracy REAL number - REAL(r8), parameter :: D8=8.0_r8 !double accuracy REAL number - REAL(r8), parameter :: D9=9.0_r8 !double accuracy REAL number - REAL(r8), parameter :: D10=10.0_r8 !double accuracy REAL number - REAL(r8), parameter :: D16=16.0_r8 !double accuracy REAL number - REAL(r8), parameter :: DH=0.5_r8 !quad accuracy REAL number - REAL(r16),parameter :: DDH=0.5_r16 !quad accuracy REAL number - REAL(r16),parameter :: DD0=0.0_r16 !quad accuracy REAL number - REAL(r16),parameter :: DD1=1.0_r16 !quad accuracy REAL number - REAL(r8) ,parameter :: pi=3.14159265358979323846_r8 !pi - - INTEGER :: ib !band index 1:vis 2:nir - INTEGER :: ip,ic,ig,kband !array indices for pft,column,grid - INTEGER :: kfr !variable for layer radiation coming from - INTEGER :: klay !variable for layer absorbing radiation - INTEGER :: kto !variable for layer radiation is transmitted to - INTEGER :: lev !do loop variable - INTEGER :: nn !do loop variable - INTEGER :: nsoilveg !number of pfts in gridcell with veg and cosz > 0 - INTEGER :: nstep !time step index - INTEGER :: clev !canopy level for current pft - - REAL(r8) :: albd_col(numrad) !surface reflection (direct) for column - REAL(r8) :: albi_col(numrad) !surface reflection (diffuse) for column - REAL(r8) :: bot_lay(nlay) !avergae canopy bottom in layer - REAL(r8) :: hgt_lay(nlay) !average canopy height in layer - REAL(r8) :: omg_lay(nlay,numrad) !average omega for all three layer - REAL(r8) :: rho_lay(nlay,numrad) !average rho for all three layer - REAL(r8) :: siz_lay(nlay) !average canopy size in layer - REAL(r8) :: tau_lay(nlay,numrad) !average tau for all three layer - REAL(r8) :: lsai_lay(nlay) !average lsai for each layer - REAL(r8) :: cosz !0.001 <= coszen <= 1.000 - REAL(r8) :: cosd !0.001 <= coszen <= 1.000 - REAL(r8) :: delta !variable for increment layer in loop - REAL(r8) :: dif !diffuse radiation transmitted - REAL(r8) :: dir !direct radiation transmitted - REAL(r8) :: fabd_col(numrad) !flux absorbed by veg per unit diffuse flux - REAL(r8) :: fabd_lay(nlay,numrad)!layer absorption for direct beam - REAL(r8) :: fabi_col(numrad) !flux absorbed by veg per unit diffuse flux - REAL(r8) :: fabi_lay(nlay,numrad)!layer absorption for diffuse beam - REAL(r8) :: fabs_lay(0:4,numrad) !layer absorption for all five layers - REAL(r8) :: fabs_leq(0:4,numrad) !layer absorption for all five layers - REAL(r8) :: A(6,6) !three-layer radiation transfer eqation (EQ. 19, Yuan et al., 2014) - REAL(r8) :: B(6,2) !three-layer radiation transfer eqation (EQ. 19, Yuan et al., 2014) - REAL(r8) :: X(6,2) !three-layer radiation transfer eqation (EQ. 19, Yuan et al., 2014) - REAL(r8) :: fabsm !pft absorption for multiple reflections - REAL(r8) :: faid_lay(nlay) !layer diffused absorption for direct beam - REAL(r8) :: faid_p !pft absorption direct beam - REAL(r8) :: faii_lay(nlay) !layer diffused absorption for diffuse beam - REAL(r8) :: faii_p !pft absorption diffuse beam - REAL(r8) :: fc0(nlay) !canopy fraction for layers - REAL(r8) :: frid_lay(nlay) !layer reflection for direct beam - REAL(r8) :: frid_p !pft reflection direct beam - REAL(r8) :: frii_lay(nlay) !layer reflection for indirect beam - REAL(r8) :: ftdd_lay(nlay) !unscattered layer transmission for direct beam - REAL(r8) :: ftdi_lay(nlay) !unscattered layer transmission for indirect beam - REAL(r8) :: ftdd_lay_orig(nlay) !unscattered layer transmission for direct beam without lad/crown_shape calibration - REAL(r8) :: ftdi_lay_orig(nlay) !unscattered layer transmission for indirect beam without lad/crown_shape calibratioin - REAL(r8) :: ftid_lay(nlay) !diffused layer transmission for direct beam - REAL(r8) :: ftii_lay(nlay) !diffused layer transmission for diffuse beam - REAL(r8) :: ftran !pft transmittance - REAL(r8) :: gee=0.5_r8 !Ross factor geometric blocking - REAL(r8) :: gdir(lbp:ubp) !Ross G factor considering LAD for incident direct radiation - REAL(r8) :: gdif(lbp:ubp) !Ross G factor considering LAD for incident diffuse radiation - REAL(r8) :: gdir_lay(nlay) !Ross G factor considering LAD for incident direct radiation - REAL(r8) :: gdif_lay(nlay) !Ross G factor considering LAD for incident diffuse radiation - REAL(r8) :: fcad(lbp:ubp) !calibration factor for LAD for direct radiation - REAL(r8) :: fcai(lbp:ubp) !calibration factor for LAD for diffuse radiation - REAL(r8) :: fcad_lay(nlay) !calibration factor for LAD for direct radiation - REAL(r8) :: fcai_lay(nlay) !calibration factor for LAD for diffuse radiation - REAL(r8) :: pad !probabilty function for absorption after two scat - REAL(r8) :: pai !probabilty of asborption for diffuse incident beam - REAL(r8) :: pfc !contribution of current pft in layer - REAL(r8) :: probm !prob photon reflect diffusly from grnd reach canopy - REAL(r8) :: ref(0:nlay+1,0:nlay+1)!radiation reflected between five layers - REAL(r8) :: fadd_lay(nlay,numrad)!layer absorbed flux in direct mode per unit direct flux - REAL(r8) :: shad_oa(nlay,nlay) !shadow overlaps (direct beam) - REAL(r8) :: shadow_d(nlay) !layer shadow for direct beam - REAL(r8) :: shadow_i(nlay) !layer shadow for diffuse beam - REAL(r8) :: sum_fabd(3) !sum of absorption for all pfts in grid (direct) - REAL(r8) :: sum_fabi(3) !sum of absorption for all pfts in grid (diffuse) - REAL(r8) :: sum_fadd(nlay) !sum of absorbed flux in direct mode per unit direct flux - REAL(r8) :: taud_lay(nlay) !direct transmission for a layer - REAL(r8) :: taui_lay(nlay) !diffuse transmission for a layer - REAL(r8) :: trd(0:nlay+1,0:nlay+1)!direct radiation transmitted between five layers - REAL(r8) :: tri(0:4,0:4) !diffuse radiation transmitted between five layers - REAL(r8) :: tt(0:4,0:4) !unscattered direct radiation available at layer - REAL(r8) :: wl !fraction of LAI+SAI that is LAI - REAL(r8) :: ws !fraction of LAI+SAI that is SAI - REAL(r8) :: zenith !zenith angle - REAL(r8) :: ftdd_col !unscattered column transmission for direct beam - - REAL(r8) :: shadow_pd(lbp:ubp) !sky shadow area - REAL(r8) :: shadow_pi(lbp:ubp) !sky shadow area - REAL(r8) :: shadow_sky(lbp:ubp) !sky shadow area - REAL(r8) :: taud(lbp:ubp) !transmission to direct beam - REAL(r8) :: taui(lbp:ubp) !transmission to diffuse beam - REAL(r8) :: omega(lbp:ubp,numrad)!leaf/stem transmitance weighted by frac veg - REAL(r8) :: ftdi(lbp:ubp,numrad) !leaf/stem transmitance weighted by frac veg - REAL(r8) :: ftdd_orig(lbp:ubp,numrad)!leaf/stem transmitance weighted by frac veg - REAL(r8) :: ftdi_orig(lbp:ubp,numrad)!leaf/stem transmitance weighted by frac veg - LOGICAL :: soilveg(lbp:ubp) !true if pft over soil with veg and cosz > 0 - - REAL(r8) :: phi1(lbp:ubp), phi2(lbp:ubp) + real(r8), parameter :: mpe = 1.0e-06_r8 !prevents overflow for division by zero + integer , parameter :: nlay=3 !number of canopy layers + real(r8), parameter :: D0=0.0_r8 !double accuracy real number + real(r8), parameter :: D1=1.0_r8 !double accuracy real number + real(r8), parameter :: D2=2.0_r8 !double accuracy real number + real(r8), parameter :: D3=3.0_r8 !double accuracy real number + real(r8), parameter :: D4=4.0_r8 !double accuracy real number + real(r8), parameter :: D6=6.0_r8 !double accuracy real number + real(r8), parameter :: D7=7.0_r8 !double accuracy real number + real(r8), parameter :: D8=8.0_r8 !double accuracy real number + real(r8), parameter :: D9=9.0_r8 !double accuracy real number + real(r8), parameter :: D10=10.0_r8 !double accuracy real number + real(r8), parameter :: D16=16.0_r8 !double accuracy real number + real(r8), parameter :: DH=0.5_r8 !quad accuracy real number + real(r16),parameter :: DDH=0.5_r16 !quad accuracy real number + real(r16),parameter :: DD0=0.0_r16 !quad accuracy real number + real(r16),parameter :: DD1=1.0_r16 !quad accuracy real number + real(r8) ,parameter :: pi=3.14159265358979323846_r8 !pi + + integer :: ib !band index 1:vis 2:nir + integer :: ip,ic,ig,kband !array indices for pft,column,grid + integer :: kfr !variable for layer radiation coming from + integer :: klay !variable for layer absorbing radiation + integer :: kto !variable for layer radiation is transmitted to + integer :: lev !do loop variable + integer :: nn !do loop variable + integer :: nsoilveg !number of pfts in gridcell with veg and cosz > 0 + integer :: nstep !time step index + integer :: clev !canopy level for current pft + + real(r8) :: albd_col(numrad) !surface reflection (direct) for column + real(r8) :: albi_col(numrad) !surface reflection (diffuse) for column + real(r8) :: bot_lay(nlay) !avergae canopy bottom in layer + real(r8) :: hgt_lay(nlay) !average canopy height in layer + real(r8) :: omg_lay(nlay,numrad) !average omega for all three layer + real(r8) :: rho_lay(nlay,numrad) !average rho for all three layer + real(r8) :: siz_lay(nlay) !average canopy size in layer + real(r8) :: tau_lay(nlay,numrad) !average tau for all three layer + real(r8) :: lsai_lay(nlay) !average lsai for each layer + real(r8) :: cosz !0.001 <= coszen <= 1.000 + real(r8) :: cosd !0.001 <= coszen <= 1.000 + real(r8) :: delta !variable for increment layer in loop + real(r8) :: dif !diffuse radiation transmitted + real(r8) :: dir !direct radiation transmitted + real(r8) :: fabd_col(numrad) !flux absorbed by veg per unit diffuse flux + real(r8) :: fabd_lay(nlay,numrad) !layer absorption for direct beam + real(r8) :: fabi_col(numrad) !flux absorbed by veg per unit diffuse flux + real(r8) :: fabi_lay(nlay,numrad) !layer absorption for diffuse beam + real(r8) :: fabs_lay(0:4,numrad) !layer absorption for all five layers + real(r8) :: fabs_leq(0:4,numrad) !layer absorption for all five layers + real(r8) :: A(6,6) !three-layer radiation transfer eqation (EQ. 19, Yuan et al., 2014) + real(r8) :: B(6,2) !three-layer radiation transfer eqation (EQ. 19, Yuan et al., 2014) + real(r8) :: X(6,2) !three-layer radiation transfer eqation (EQ. 19, Yuan et al., 2014) + real(r8) :: fabsm !pft absorption for multiple reflections + real(r8) :: faid_lay(nlay) !layer diffused absorption for direct beam + real(r8) :: faid_p !pft absorption direct beam + real(r8) :: faii_lay(nlay) !layer diffused absorption for diffuse beam + real(r8) :: faii_p !pft absorption diffuse beam + real(r8) :: fc0(nlay) !canopy fraction for layers + real(r8) :: frid_lay(nlay) !layer reflection for direct beam + real(r8) :: frid_p !pft reflection direct beam + real(r8) :: frii_lay(nlay) !layer reflection for indirect beam + real(r8) :: ftdd_lay(nlay) !unscattered layer transmission for direct beam + real(r8) :: ftdi_lay(nlay) !unscattered layer transmission for indirect beam + real(r8) :: ftdd_lay_orig(nlay) !unscattered layer transmission for direct beam without lad/crown_shape calibration + real(r8) :: ftdi_lay_orig(nlay) !unscattered layer transmission for indirect beam without lad/crown_shape calibratioin + real(r8) :: ftid_lay(nlay) !diffused layer transmission for direct beam + real(r8) :: ftii_lay(nlay) !diffused layer transmission for diffuse beam + real(r8) :: ftran !pft transmittance + real(r8) :: gee=0.5_r8 !Ross factor geometric blocking + real(r8) :: gdir(ps:pe) !Ross G factor considering LAD for incident direct radiation + real(r8) :: gdif(ps:pe) !Ross G factor considering LAD for incident diffuse radiation + real(r8) :: gdir_lay(nlay) !Ross G factor considering LAD for incident direct radiation + real(r8) :: gdif_lay(nlay) !Ross G factor considering LAD for incident diffuse radiation + real(r8) :: fcad(ps:pe) !calibration factor for LAD for direct radiation + real(r8) :: fcai(ps:pe) !calibration factor for LAD for diffuse radiation + real(r8) :: fcad_lay(nlay) !calibration factor for LAD for direct radiation + real(r8) :: fcai_lay(nlay) !calibration factor for LAD for diffuse radiation + real(r8) :: pad !probabilty function for absorption after two scat + real(r8) :: pai !probabilty of asborption for diffuse incident beam + real(r8) :: pfc !contribution of current pft in layer + real(r8) :: probm !prob photon reflect diffusly from grnd reach canopy + real(r8) :: ref(0:nlay+1,0:nlay+1) !radiation reflected between five layers + real(r8) :: fadd_lay(nlay,numrad) !layer absorbed flux in direct mode per unit direct flux + real(r8) :: shad_oa(nlay,nlay) !shadow overlaps (direct beam) + real(r8) :: shadow_d(nlay) !layer shadow for direct beam + real(r8) :: shadow_i(nlay) !layer shadow for diffuse beam + real(r8) :: sum_fabd(3) !sum of absorption for all pfts in grid (direct) + real(r8) :: sum_fabi(3) !sum of absorption for all pfts in grid (diffuse) + real(r8) :: sum_fadd(nlay) !sum of absorbed flux in direct mode per unit direct flux + real(r8) :: taud_lay(nlay) !direct transmission for a layer + real(r8) :: taui_lay(nlay) !diffuse transmission for a layer + real(r8) :: trd(0:nlay+1,0:nlay+1) !direct radiation transmitted between five layers + real(r8) :: tri(0:4,0:4) !diffuse radiation transmitted between five layers + real(r8) :: tt(0:4,0:4) !unscattered direct radiation available at layer + real(r8) :: wl !fraction of LAI+SAI that is LAI + real(r8) :: ws !fraction of LAI+SAI that is SAI + real(r8) :: zenith !zenith angle + real(r8) :: ftdd_col !unscattered column transmission for direct beam + + real(r8) :: shadow_pd(ps:pe) !sky shadow area + real(r8) :: shadow_pi(ps:pe) !sky shadow area + real(r8) :: shadow_sky(ps:pe) !sky shadow area + real(r8) :: taud(ps:pe) !transmission to direct beam + real(r8) :: taui(ps:pe) !transmission to diffuse beam + real(r8) :: omega(ps:pe,numrad) !leaf/stem transmitance weighted by frac veg + real(r8) :: ftdi(ps:pe,numrad) !leaf/stem transmitance weighted by frac veg + real(r8) :: ftdd_orig(ps:pe,numrad) !leaf/stem transmitance weighted by frac veg + real(r8) :: ftdi_orig(ps:pe,numrad) !leaf/stem transmitance weighted by frac veg + logical :: soilveg(ps:pe) !true if pft over soil with veg and cosz > 0 + + real(r8) :: phi1(ps:pe), phi2(ps:pe) ! 11/07/2018: calculate gee FUNCTION consider LAD phi1 = 0.5 - 0.633 * chil - 0.33 * chil * chil @@ -354,32 +413,32 @@ SUBROUTINE ThreeDCanopy(lbp, ubp, canlev, pwtcol, csiz, chgt, chil, coszen, & gdir_lay = D0 gdif_lay = D0 - DO ip = lbp, ubp + DO ip = ps, pe shadow_sky(ip) = D1 ! check elai and pft weight are non-zero - IF ( lsai(ip)>1.e-6_r8 .and. pwtcol(ip)>D0 ) THEN + IF ( lsai(ip)>1.e-6_r8 .and. fcover(ip)>D0 ) THEN soilveg(ip) = .true. nsoilveg = nsoilveg + 1 - clev = canlev(ip) - fc0(clev) = fc0(clev) + pwtcol(ip) + clev = canlay(ip) + fc0(clev) = fc0(clev) + fcover(ip) - siz_lay (clev) = siz_lay (clev) + pwtcol(ip)*csiz(ip) - hgt_lay (clev) = hgt_lay (clev) + pwtcol(ip)*chgt(ip) - lsai_lay(clev) = lsai_lay(clev) + pwtcol(ip)*lsai(ip) - gdir_lay(clev) = gdir_lay(clev) + pwtcol(ip)*gdir(ip) - gdif_lay(clev) = gdif_lay(clev) + pwtcol(ip)*gdif(ip) + siz_lay (clev) = siz_lay (clev) + fcover(ip)*csiz(ip) + hgt_lay (clev) = hgt_lay (clev) + fcover(ip)*chgt(ip) + lsai_lay(clev) = lsai_lay(clev) + fcover(ip)*lsai(ip) + gdir_lay(clev) = gdir_lay(clev) + fcover(ip)*gdir(ip) + gdif_lay(clev) = gdif_lay(clev) + fcover(ip)*gdif(ip) ! set optical properties DO ib = 1, numrad omega(ip,ib) = rho(ip,ib) + tau(ip,ib) ! sum of tau,rho and omega for pfts in a layer - tau_lay(clev,ib) = tau_lay(clev,ib) + pwtcol(ip)*(tau(ip,ib)) - rho_lay(clev,ib) = rho_lay(clev,ib) + pwtcol(ip)*(rho(ip,ib)) - omg_lay(clev,ib) = omg_lay(clev,ib) + pwtcol(ip)*(omega(ip,ib)) + tau_lay(clev,ib) = tau_lay(clev,ib) + fcover(ip)*(tau(ip,ib)) + rho_lay(clev,ib) = rho_lay(clev,ib) + fcover(ip)*(rho(ip,ib)) + omg_lay(clev,ib) = omg_lay(clev,ib) + fcover(ip)*(omega(ip,ib)) ENDDO ! ENDDO ib=1, numrad ELSE @@ -411,8 +470,8 @@ SUBROUTINE ThreeDCanopy(lbp, ubp, canlev, pwtcol, csiz, chgt, chil, coszen, & ! layer shadows !============================================================= - shadow_d = D0 - shadow_i = D0 + shadow_d = D0 + shadow_i = D0 DO lev =1, 3 IF ( fc0(lev)>D0 .and. cosz>D0 ) THEN shadow_d(lev) = (D1 - exp(-D1*fc0(lev)/cosz))/& @@ -503,15 +562,15 @@ SUBROUTINE ThreeDCanopy(lbp, ubp, canlev, pwtcol, csiz, chgt, chil, coszen, & tt(4,2) = shadow_d(2)*(D1-shadow_d(3)+shad_oa(3,2)) tt(4,2) = min(1-tt(4,3), max(D0, tt(4,2))) tt(4,1) = shadow_d(1)*(D1-(shadow_d(2)-shad_oa(2,1)) & - - (shadow_d(3)-shad_oa(3,1)) & - + (shadow_d(2)-shad_oa(2,1))*(shadow_d(3)-shad_oa(3,2))) + - (shadow_d(3)-shad_oa(3,1)) & + + (shadow_d(2)-shad_oa(2,1))*(shadow_d(3)-shad_oa(3,2))) tt(4,1) = min(1-tt(4,3)-tt(4,2), max(D0, tt(4,1))) tt(4,0) = D1-(shadow_d(1)+shadow_d(2)+shadow_d(3) & - - (shadow_d(2)-shad_oa(2,1))*shadow_d(1) & - - (shadow_d(3)-shad_oa(3,2))*shadow_d(2) & - - (shadow_d(3)-shad_oa(3,1))*shadow_d(1) & - + (shadow_d(2)-shad_oa(2,1))*(shadow_d(3)-shad_oa(3,2))*shadow_d(1)) + - (shadow_d(2)-shad_oa(2,1))*shadow_d(1) & + - (shadow_d(3)-shad_oa(3,2))*shadow_d(2) & + - (shadow_d(3)-shad_oa(3,1))*shadow_d(1) & + + (shadow_d(2)-shad_oa(2,1))*(shadow_d(3)-shad_oa(3,2))*shadow_d(1)) tt(4,0) = min(1-tt(4,3)-tt(4,2)-tt(4,1), max(D0, tt(4,0))) IF (tt(4,0) < 0) THEN @@ -578,7 +637,7 @@ SUBROUTINE ThreeDCanopy(lbp, ubp, canlev, pwtcol, csiz, chgt, chil, coszen, & ! 10/12/2017 ftdi(:,ib) = D1 - DO ip = lbp, ubp + DO ip = ps, pe taud(ip)=D0 taui(ip)=D0 @@ -586,13 +645,13 @@ SUBROUTINE ThreeDCanopy(lbp, ubp, canlev, pwtcol, csiz, chgt, chil, coszen, & shadow_pi(ip)=D0 IF (soilveg(ip)) THEN - clev = canlev(ip) + clev = canlay(ip) !================================================ ! fractional contribution of current pft in layer !================================================ - pfc = min( pwtcol(ip)/fc0(clev), D1) + pfc = min( fcover(ip)/fc0(clev), D1) shadow_pd(ip)=pfc*shadow_d(clev) shadow_pi(ip)=pfc*shadow_i(clev) @@ -600,10 +659,10 @@ SUBROUTINE ThreeDCanopy(lbp, ubp, canlev, pwtcol, csiz, chgt, chil, coszen, & ! get taud,taui at pft level !===================================== - taud(ip)=D3/D4*gee*pwtcol(ip)*(lsai(ip))/& + taud(ip)=D3/D4*gee*fcover(ip)*(lsai(ip))/& (cosz*shadow_pd(ip)) - taui(ip)=D3/D4*gee*pwtcol(ip)*(lsai(ip))/& + taui(ip)=D3/D4*gee*fcover(ip)*(lsai(ip))/& (cosd*shadow_pi(ip)) !==================================== @@ -720,6 +779,8 @@ SUBROUTINE ThreeDCanopy(lbp, ubp, canlev, pwtcol, csiz, chgt, chil, coszen, & fabi_col(ib) = fabs_lay(1,2)+fabs_lay(2,2)+fabs_lay(3,2) albd_col(ib) = fabs_lay(4,1) albi_col(ib) = fabs_lay(4,2) + + ! balance check IF (abs(fabd_col(ib)+albd_col(ib)+fabs_lay(0,1)-1) > 1e-6) THEN print *, "Imbalance kband=1" print *, fabd_col(ib)+albd_col(ib)+fabs_lay(0,1)-1 @@ -737,8 +798,8 @@ SUBROUTINE ThreeDCanopy(lbp, ubp, canlev, pwtcol, csiz, chgt, chil, coszen, & sum_fabi=D0 sum_fadd=D0 - DO ip = lbp, ubp - clev = canlev(ip) + DO ip = ps, pe + clev = canlay(ip) IF (clev == D0) CYCLE IF ( shadow_d(clev)>D0 .and. soilveg(ip) ) THEN @@ -746,7 +807,7 @@ SUBROUTINE ThreeDCanopy(lbp, ubp, canlev, pwtcol, csiz, chgt, chil, coszen, & ! fractional contribution of current pft in layer !================================================= - pfc = min( pwtcol(ip)/fc0(clev), D1) + pfc = min( fcover(ip)/fc0(clev), D1) !========================================= ! shadow contribution from ground to sky @@ -760,7 +821,7 @@ SUBROUTINE ThreeDCanopy(lbp, ubp, canlev, pwtcol, csiz, chgt, chil, coszen, & !======================================================= CALL CanopyRad(taud(ip), taui(ip), ftdd_orig(ip,ib), ftdi_orig(ip,ib), & - cosz,cosd, shadow_pd(ip), shadow_pi(ip), pwtcol(ip),& + cosz,cosd, shadow_pd(ip), shadow_pi(ip), fcover(ip),& omega(ip,ib), lsai(ip), tau(ip,ib),& rho(ip,ib), ftid(ip,ib), ftii(ip,ib), albd(ip,ib),& albi(ip,ib), faid_p, faii_p) @@ -799,8 +860,8 @@ SUBROUTINE ThreeDCanopy(lbp, ubp, canlev, pwtcol, csiz, chgt, chil, coszen, & ENDIF ! ENDIF shadow & soilveg ENDDO ! ENDDO ip - DO ip = lbp, ubp - clev = canlev(ip) + DO ip = ps, pe + clev = canlay(ip) !=========================================================== ! adjust pft absorption for total column absorption per @@ -809,12 +870,12 @@ SUBROUTINE ThreeDCanopy(lbp, ubp, canlev, pwtcol, csiz, chgt, chil, coszen, & IF (soilveg(ip)) THEN fabd(ip,ib)=fabd(ip,ib)*fabd_lay(clev,ib)/& - sum_fabd(clev)/pwtcol(ip) + sum_fabd(clev)/fcover(ip) fabi(ip,ib)=fabi(ip,ib)*fabi_lay(clev,ib)/& - sum_fabi(clev)/pwtcol(ip) + sum_fabi(clev)/fcover(ip) fadd(ip,ib) = fadd(ip,ib)*fadd_lay(clev,ib)/& - sum_fadd(clev)/pwtcol(ip) + sum_fadd(clev)/fcover(ip) fadd(ip,ib) = min(fabd(ip,ib), fadd(ip,ib)) psun(ip) = tt(clev+1,clev)/shadow_d(clev) @@ -858,42 +919,42 @@ SUBROUTINE ThreeDCanopy(lbp, ubp, canlev, pwtcol, csiz, chgt, chil, coszen, & fshade(:) = shadow_pi(:) thermk(:) = ftdi(:,1) - END SUBROUTINE ThreeDCanopy + END SUBROUTINE ThreeDCanopy !===================== ! FUNCTION tee !===================== - REAL(selected_real_kind(12)) FUNCTION tee(tau) + real(selected_real_kind(12)) FUNCTION tee(tau) IMPLICIT NONE - REAL(r16),parameter :: DDH = 0.50_r16 !128-bit accuracy REAL - REAL(r16),parameter :: DD1 = 1.0_r16 !128-bit accuracy REAL - REAL(r16),parameter :: DD2 = 2.0_r16 !128-bit accuracy REAL - REAL(r16) :: tau ! transmittance + real(r16),parameter :: DDH = 0.50_r16 !128-bit accuracy real + real(r16),parameter :: DD1 = 1.0_r16 !128-bit accuracy real + real(r16),parameter :: DD2 = 2.0_r16 !128-bit accuracy real + real(r16) :: tau ! transmittance tee = DDH*(DD1/tau/tau-(DD1/tau/tau+DD2/tau)*exp(-DD2*tau)) - END FUNCTION tee + END FUNCTION tee !=========================================== ! FUNCTION overlapArea !=========================================== - REAL(selected_real_kind(12)) FUNCTION OverlapArea(radius, hgt, zenith) + real(selected_real_kind(12)) FUNCTION OverlapArea(radius, hgt, zenith) IMPLICIT NONE - REAL(r8),parameter :: rpi = 3.14159265358979323846_R8 !pi - REAL(r8),parameter :: D0 = 0.0_r8 !128-bit accuracy REAL - REAL(r8),parameter :: D1 = 1.0_r8 !128-bit accuracy REAL + real(r8),parameter :: rpi = 3.14159265358979323846_R8 !pi + real(r8),parameter :: D0 = 0.0_r8 !128-bit accuracy real + real(r8),parameter :: D1 = 1.0_r8 !128-bit accuracy real - REAL(r8) :: radius !radius of bus - REAL(r8) :: hgt !height of canopy - REAL(r8) :: zenith !zenith angle - REAL(r8) :: cost !cosine of angle - REAL(r8) :: theta !angle + real(r8) :: radius !radius of bus + real(r8) :: hgt !height of canopy + real(r8) :: zenith !zenith angle + real(r8) :: cost !cosine of angle + real(r8) :: theta !angle IF (radius == D0) THEN OverlapArea= D0 @@ -907,73 +968,73 @@ REAL(selected_real_kind(12)) FUNCTION OverlapArea(radius, hgt, zenith) theta = acos(cost) OverlapArea = (theta-cost*sin(theta))*(D1+D1/cos(zenith))/rpi RETURN - END FUNCTION OverlapArea + END FUNCTION OverlapArea !========================================================= ! FUNCTION to calculate scattering, absorption, reflection and ! transmittance for unit input radiation !========================================================= - SUBROUTINE CanopyRad(tau_d, tau_i, ftdd, ftdi, cosz,cosd, & + SUBROUTINE CanopyRad(tau_d, tau_i, ftdd, ftdi, cosz,cosd, & shadow_d, shadow_i, fc, omg, lsai, tau_p, rho_p, & ftid, ftii, frid, frii, faid, faii) IMPLICIT NONE ! input variables - REAL(r8)::cosz !0.001 <= coszen <= 1.000 - REAL(r8)::cosd !0.001 <= coszen <= 1.000 - REAL(r8)::faid !direct absorption - REAL(r8)::faii !diffuse absorption - REAL(r8)::fc !fraction of grid covered with canopy - REAL(r8)::frid !direct reflectance - REAL(r8)::frii !diffuse reflectance - REAL(r8)::frio !diffuse reflectance - REAL(r8)::ftdd !down direct flux below veg per unit dir flx - REAL(r8)::ftdi !down direct flux below veg per unit dif flux - REAL(r8)::ftid !direct transmittance - REAL(r8)::ftii !diffuse transmittance - REAL(r8)::omg !frac of intercepted rad that is scattered - REAL(r8)::rho_p !leaf/stem reflectance weighted by fract of LAI and SAI - REAL(r8)::shadow_d !canopy shadow for direct solar - REAL(r8)::shadow_i !canopy shadow for diffuse solar - REAL(r8)::tau_d !radial optical depth for direct beam - REAL(r8)::tau_i !radial optical depth for indirect beam - REAL(r8)::tau_p !leaf/stem transmission weighted by frac of LAI & SAI - REAL(r8)::lsai !elai+esai + real(r8)::cosz !0.001 <= coszen <= 1.000 + real(r8)::cosd !0.001 <= coszen <= 1.000 + real(r8)::faid !direct absorption + real(r8)::faii !diffuse absorption + real(r8)::fc !fraction of grid covered with canopy + real(r8)::frid !direct reflectance + real(r8)::frii !diffuse reflectance + real(r8)::frio !diffuse reflectance + real(r8)::ftdd !down direct flux below veg per unit dir flx + real(r8)::ftdi !down direct flux below veg per unit dif flux + real(r8)::ftid !direct transmittance + real(r8)::ftii !diffuse transmittance + real(r8)::omg !frac of intercepted rad that is scattered + real(r8)::rho_p !leaf/stem reflectance weighted by fract of LAI and SAI + real(r8)::shadow_d !canopy shadow for direct solar + real(r8)::shadow_i !canopy shadow for diffuse solar + real(r8)::tau_d !radial optical depth for direct beam + real(r8)::tau_i !radial optical depth for indirect beam + real(r8)::tau_p !leaf/stem transmission weighted by frac of LAI & SAI + real(r8)::lsai !elai+esai ! output variables - REAL(r8)::phi_dif_d !differnce of rad scattered forward-backward per direct beam - REAL(r8)::phi_dif_i !difference of rad scattered forward-backward per direct beam - REAL(r8)::phi_tot_d !total rad scattered in all direction per direct beam - REAL(r8)::phi_tot_i !total rad scattered in all direction per diffuse beam - REAL(r8)::phi_tot_o !total rad scattered in all direction per direct beam - REAL(r8)::phi_dif_o !total rad scattered in all direction per diffuse beam - REAL(r8)::pa2 !total rad scattered in all direction per direct beam + real(r8)::phi_dif_d !differnce of rad scattered forward-backward per direct beam + real(r8)::phi_dif_i !difference of rad scattered forward-backward per direct beam + real(r8)::phi_tot_d !total rad scattered in all direction per direct beam + real(r8)::phi_tot_i !total rad scattered in all direction per diffuse beam + real(r8)::phi_tot_o !total rad scattered in all direction per direct beam + real(r8)::phi_dif_o !total rad scattered in all direction per diffuse beam + real(r8)::pa2 !total rad scattered in all direction per direct beam ! local variables - LOGICAL::runmode = .true. - REAL(r8)::tau - REAL(r8)::muv !forward frac of 3D scat rad in all direction for diffuse - REAL(r8)::ac !forward frac of 3D scat rad in all direction for diffuse - REAL(r8)::ald !forward frac of 3D scat rad in all direction for diffuse - REAL(r8)::ali !forward frac of 3D scat rad in all direction for diffuse - - REAL(r8)::wb !EQ. (2.14), Dickinson 1983, omega*beta - REAL(r8)::alpha !EQ. (2.14), Dickinson 1983, alpha - REAL(r8)::nd !EQ. (4), Appendix 1, Yuan, dissertation - REAL(r8)::ni !EQ. (4), Appendix 1, Yuan, dissertation - REAL(r8)::gee=0.5_r8 !Ross factor geometric blocking - - REAL(r8),parameter::D0 = 0.0_r8 !64-bit REAL number - REAL(r8),parameter::D1 = 1.0_r8 !64-bit REAL number - REAL(r8),parameter::D2 = 2.0_r8 !64-bit REAL number - REAL(r8),parameter::D3 = 3.0_r8 !64-bit REAL number - REAL(r8),parameter::D4 = 4.0_r8 !64-bit REAL number - REAL(r8),parameter::D6 = 6.0_r8 !64-bit REAL number - REAL(r8),parameter::DH = 0.5_r8 !64-bit REAL number - REAL(r16),parameter::DD1 = 1.0_r16 !128-bit REAL number - - REAL(r8),parameter :: pi = 3.14159265358979323846_R8 !pi + logical::runmode = .true. + real(r8)::tau + real(r8)::muv !forward frac of 3D scat rad in all direction for diffuse + real(r8)::ac !forward frac of 3D scat rad in all direction for diffuse + real(r8)::ald !forward frac of 3D scat rad in all direction for diffuse + real(r8)::ali !forward frac of 3D scat rad in all direction for diffuse + + real(r8)::wb !EQ. (2.14), Dickinson 1983, omega*beta + real(r8)::alpha !EQ. (2.14), Dickinson 1983, alpha + real(r8)::nd !EQ. (4), Appendix 1, Yuan, dissertation + real(r8)::ni !EQ. (4), Appendix 1, Yuan, dissertation + real(r8)::gee=0.5_r8 !Ross factor geometric blocking + + real(r8),parameter::D0 = 0.0_r8 !64-bit real number + real(r8),parameter::D1 = 1.0_r8 !64-bit real number + real(r8),parameter::D2 = 2.0_r8 !64-bit real number + real(r8),parameter::D3 = 3.0_r8 !64-bit real number + real(r8),parameter::D4 = 4.0_r8 !64-bit real number + real(r8),parameter::D6 = 6.0_r8 !64-bit real number + real(r8),parameter::DH = 0.5_r8 !64-bit real number + real(r16),parameter::DD1 = 1.0_r16 !128-bit real number + + real(r8),parameter :: pi = 3.14159265358979323846_R8 !pi tau = D3/D4*gee*lsai @@ -1053,47 +1114,48 @@ SUBROUTINE CanopyRad(tau_d, tau_i, ftdd, ftdi, cosz,cosd, & faii = D0 ENDIF - END SUBROUTINE CanopyRad + END SUBROUTINE CanopyRad + - SUBROUTINE phi(runmode, tau, omg, tau_p, rho_p, phi_tot, phi_dif, pa2) + SUBROUTINE phi(runmode, tau, omg, tau_p, rho_p, phi_tot, phi_dif, pa2) IMPLICIT NONE ! input variables - LOGICAL::runmode - REAL(r8)::omg !frac of intercepted rad that is scattered - REAL(r8)::rho_p !leaf/stem reflectance weighted by fract of LAI and SAI - REAL(r8)::tau !radial optical depth for direct beam - REAL(r8)::tau_p !leaf/stem transmission weighted by frac of LAI & SAI + logical::runmode + real(r8)::omg !frac of intercepted rad that is scattered + real(r8)::rho_p !leaf/stem reflectance weighted by fract of LAI and SAI + real(r8)::tau !radial optical depth for direct beam + real(r8)::tau_p !leaf/stem transmission weighted by frac of LAI & SAI ! output variables - REAL(r8)::phi_dif !differnce of rad scattered forward-backward - REAL(r8)::phi_tot !total rad scattered in all direction - REAL(r8)::pa2 !total rad scattered in all direction + real(r8)::phi_dif !differnce of rad scattered forward-backward + real(r8)::phi_tot !total rad scattered in all direction + real(r8)::pa2 !total rad scattered in all direction ! local variables - REAL(r8)::pac !probablity of absorption after two scatterings - REAL(r8)::phi_1b !backward single scattered radiation - REAL(r8)::phi_1f !forward single scattered radiation - REAL(r8)::phi_2a !average second-order scattered radiation - REAL(r8)::phi_2b !backward second-order scattered radiation - REAL(r8)::phi_2f !forward second-order scattered radiation - REAL(r8)::phi_mb !backward multiple scattered radiation - REAL(r8)::phi_mf !forward multiple scattered radiation - REAL(r8)::phi_tb !backward frac of 3D scat rad in all direction - REAL(r8)::phi_tf !forward frac of 3D scat rad in all direction - REAL(r8)::aa,bb !temporary constants - - REAL(r8),parameter::D0 = 0.0_r8 !64-bit REAL number - REAL(r8),parameter::D1 = 1.0_r8 !64-bit REAL number - - REAL(r16),parameter::DD1 = 1.0_r16 !128-bit REAL number - REAL(r16),parameter::DD2 = 2.0_r16 !128-bit REAL number - REAL(r16),parameter::DD3 = 3.0_r16 !128-bit REAL number - REAL(r16),parameter::DD4 = 4.0_r16 !128-bit REAL number - REAL(r16),parameter::DD9 = 9.0_r16 !128-bit REAL number - REAL(r16),parameter::DD10= 10.0_r16 !128-bit REAL number - REAL(r16),parameter::DDH = 0.5_r16 !128-bit REAL number + real(r8)::pac !probablity of absorption after two scatterings + real(r8)::phi_1b !backward single scattered radiation + real(r8)::phi_1f !forward single scattered radiation + real(r8)::phi_2a !average second-order scattered radiation + real(r8)::phi_2b !backward second-order scattered radiation + real(r8)::phi_2f !forward second-order scattered radiation + real(r8)::phi_mb !backward multiple scattered radiation + real(r8)::phi_mf !forward multiple scattered radiation + real(r8)::phi_tb !backward frac of 3D scat rad in all direction + real(r8)::phi_tf !forward frac of 3D scat rad in all direction + real(r8)::aa,bb !temporary constants + + real(r8),parameter::D0 = 0.0_r8 !64-bit real number + real(r8),parameter::D1 = 1.0_r8 !64-bit real number + + real(r16),parameter::DD1 = 1.0_r16 !128-bit real number + real(r16),parameter::DD2 = 2.0_r16 !128-bit real number + real(r16),parameter::DD3 = 3.0_r16 !128-bit real number + real(r16),parameter::DD4 = 4.0_r16 !128-bit real number + real(r16),parameter::DD9 = 9.0_r16 !128-bit real number + real(r16),parameter::DD10= 10.0_r16 !128-bit real number + real(r16),parameter::DDH = 0.5_r16 !128-bit real number !---------------------------------------------------------------------- ! single scattering terms for sphere with overlap corrections to path @@ -1101,7 +1163,7 @@ SUBROUTINE phi(runmode, tau, omg, tau_p, rho_p, phi_tot, phi_dif, pa2) !---------------------------------------------------------------------- ! forward first order normalized scattering - phi_1f =(DD1/tau/tau - (DD1/tau/tau + DD2/tau + DD2)*exp(-DD2*tau)) + phi_1f = (DD1/tau/tau - (DD1/tau/tau + DD2/tau + DD2)*exp(-DD2*tau)) ! backward first order normalized scattering phi_1b = DDH*(DD1 - tee(DD2*tau)) @@ -1113,8 +1175,8 @@ SUBROUTINE phi(runmode, tau, omg, tau_p, rho_p, phi_tot, phi_dif, pa2) IF (.not. runmode) THEN ! forward double scattering - phi_2f = DDH*(DD4*phi_1f/DD3 + tee(DD2*tau) + tee(DD4*tau)/DD9 & - -DD10*tee(DD1*tau)/DD9) + phi_2f = DDH*(DD4*phi_1f/DD3 + tee(DD2*tau) + tee(DD4*tau)/DD9 - & + DD10*tee(DD1*tau)/DD9) ! backward double scattering phi_2b = DDH*(DD1/DD3 - tee(DD2*tau) + DD2*tee(DD3*tau)/DD3) @@ -1125,12 +1187,12 @@ SUBROUTINE phi(runmode, tau, omg, tau_p, rho_p, phi_tot, phi_dif, pa2) bb = 1.74_r8 phi_2b = aa*( DD1/(bb+DD1) -DD1/(bb-D1)*tee(DD2*tau) + & - DD2/(bb+DD1)/(bb-DD1)*tee((DD1+bb)*tau) ) + DD2/(bb+DD1)/(bb-DD1)*tee((DD1+bb)*tau) ) phi_2f = aa*( DD2*bb/(bb*bb-DD1)*phi_1f - & - (DD1/(bb+DD1)/(bb+DD1) + DD1/(bb-DD1)/(bb-DD1))*tee(DD1*tau) + & - DD1/(bb-DD1)/(bb-DD1)*tee(DD1*tau*bb) + & - DD1/(bb+DD1)/(bb+DD1)*tee(DD1*(bb+DD2)*tau) ) + (DD1/(bb+DD1)/(bb+DD1) + DD1/(bb-DD1)/(bb-DD1))*tee(DD1*tau) + & + DD1/(bb-DD1)/(bb-DD1)*tee(DD1*tau*bb) + & + DD1/(bb+DD1)/(bb+DD1)*tee(DD1*(bb+DD2)*tau) ) ENDIF ! second order avaerage scattering @@ -1142,8 +1204,8 @@ SUBROUTINE phi(runmode, tau, omg, tau_p, rho_p, phi_tot, phi_dif, pa2) ! probabilty of absorption for diffuse beam ! corrected probabilty of absorption for direct beam - pac = DD1-phi_2a /(DD1 - tee(DD1*tau) - (rho_p*phi_1b + & - tau_p*phi_1f)/(tau_p+rho_p)) + pac = DD1-phi_2a / & + (DD1 - tee(DD1*tau) - (rho_p*phi_1b + tau_p*phi_1f)/(tau_p+rho_p)) ! NOTE: for test only pac = max(min(pac,D1),D0) @@ -1166,20 +1228,20 @@ SUBROUTINE phi(runmode, tau, omg, tau_p, rho_p, phi_tot, phi_dif, pa2) phi_tot = phi_tf + phi_tb phi_dif = phi_tf - phi_tb - END SUBROUTINE phi + END SUBROUTINE phi - SUBROUTINE mGauss(A, B, X) + SUBROUTINE mGauss(A, B, X) IMPLICIT NONE - REAL(r8), intent(inout) :: A(6,6) - REAL(r8), intent(inout) :: B(6,2) - REAL(r8), intent(out) :: X(6,2) + real(r8), intent(inout) :: A(6,6) + real(r8), intent(inout) :: B(6,2) + real(r8), intent(out) :: X(6,2) - INTEGER :: i, j - INTEGER :: nstep(5) = (/0, 2, 1, 2, 1/) + integer :: i, j + integer :: nstep(5) = (/0, 2, 1, 2, 1/) - REAL(r8) :: f + real(r8) :: f ! Elimination DO i = 1, 5 @@ -1201,6 +1263,6 @@ SUBROUTINE mGauss(A, B, X) X(i,2) = (B(i,2) - sum(A(i,i+1:6)*X(i+1:6,2))) / A(i,i) ENDDO - END SUBROUTINE mGauss + END SUBROUTINE mGauss END MODULE MOD_3DCanopyRadiation diff --git a/main/MOD_Aerosol.F90 b/main/MOD_Aerosol.F90 index 9ff8bbe9..9e411b5e 100644 --- a/main/MOD_Aerosol.F90 +++ b/main/MOD_Aerosol.F90 @@ -419,8 +419,8 @@ SUBROUTINE AerosolDepReadin (idate) CALL mg2p_aerdep%map_aweighted (f_aerdep, forc_aerdep(14,:)) #ifdef RangeCheck - CALL check_block_data ('aerosol', f_aerdep) - CALL check_vector_data ('aerosol', forc_aerdep) + ! CALL check_block_data ('aerosol', f_aerdep) + CALL check_vector_data (' aerosol [kg/m/s]', forc_aerdep) #endif diff --git a/main/MOD_Albedo.F90 b/main/MOD_Albedo.F90 index a22b0692..dfcbbd62 100644 --- a/main/MOD_Albedo.F90 +++ b/main/MOD_Albedo.F90 @@ -9,14 +9,14 @@ MODULE MOD_Albedo ! PUBLIC MEMBER FUNCTIONS: PUBLIC :: albland - PUBLIC :: SnowAlbedo PUBLIC :: snowage + PUBLIC :: SnowAlbedo PUBLIC :: albocean ! PRIVATE MEMBER FUNCTIONS: PRIVATE :: twostream -#ifdef LULC_IGBP_PFT +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) PRIVATE :: twostream_mod PRIVATE :: twostream_wrap #endif @@ -37,7 +37,7 @@ SUBROUTINE albland (ipatch, patchtype, deltim,& snl,wliq_soisno,wice_soisno,snw_rds,snofrz,& mss_bcpho,mss_bcphi,mss_ocpho,mss_ocphi,& mss_dst1,mss_dst2,mss_dst3,mss_dst4,& - alb,ssun,ssha,ssno,thermk,extkb,extkd) + alb,ssun,ssha,ssoi,ssno,ssno_lyr,thermk,extkb,extkd) !======================================================================= ! Calculates fragmented albedos (direct and diffuse) in @@ -60,7 +60,7 @@ SUBROUTINE albland (ipatch, patchtype, deltim,& ! ! Original author : Yongjiu Dai, 09/15/1999; 08/30/2002, 03/2014 ! -! REVISIONS: +! !REVISIONS: ! Hua Yuan, 12/2019: added a wrap FUNCTION for PFT calculation, details see ! twostream_wrap() added a wrap FUNCTION for PC (3D) calculation, ! details see ThreeDCanopy_wrap() @@ -79,15 +79,11 @@ SUBROUTINE albland (ipatch, patchtype, deltim,& USE MOD_Vars_Global USE MOD_Const_Physical, only: tfrz USE MOD_Namelist, only: DEF_USE_SNICAR -#ifdef LULC_IGBP_PFT + USE MOD_Vars_TimeInvariants, only: patchclass +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) USE MOD_LandPFT, only: patch_pft_s, patch_pft_e USE MOD_Vars_PFTimeInvariants USE MOD_Vars_PFTimeVariables -#endif -#ifdef LULC_IGBP_PC - USE MOD_LandPC - USE MOD_Vars_PCTimeInvariants - USE MOD_Vars_PCTimeVariables #endif USE MOD_Aerosol, only: AerosolMasses USE MOD_SnowSnicar, only: SnowAge_grain @@ -99,47 +95,45 @@ SUBROUTINE albland (ipatch, patchtype, deltim,& !------------------------- Dummy Arguments ----------------------------- ! ground cover index - INTEGER, intent(in) :: & - ipatch, & ! patch index - patchtype ! land water type (0=soil, 1=urban or built-up, 2=wetland, - ! 3=land ice, 4=deep lake, 5=shallow lake) - INTEGER, intent(in) :: & - snl ! number of snow layers - - ! parameters - REAL(r8), intent(in) :: & + integer, intent(in) :: & + ipatch, &! patch index + patchtype ! land patch type (0=soil, 1=urban or built-up, 2=wetland, + ! 3=land ice, 4=deep lake) + integer, intent(in) :: & + snl ! number of snow layers + + real(r8), intent(in) :: & deltim, &! seconds in a time step [second] soil_s_v_alb, &! albedo of visible of the saturated soil soil_d_v_alb, &! albedo of visible of the dry soil soil_s_n_alb, &! albedo of near infrared of the saturated soil soil_d_n_alb, &! albedo of near infrared of the dry soil - chil, &! leaf angle distribution factor - rho(2,2), &! leaf reflectance (iw=iband, il=life and dead) - tau(2,2), &! leaf transmittance (iw=iband, il=life and dead) - fveg, &! fractional vegetation cover [-] - green, &! green leaf fraction - lai, &! leaf area index (LAI+SAI) [m2/m2] - sai, &! stem area index (LAI+SAI) [m2/m2] - - ! variables - coszen, &! cosine of solar zenith angle [-] - wt, &! fraction of vegetation covered by snow [-] - fsno, &! fraction of soil covered by snow [-] - ssw, &! water volumetric content of soil surface layer [m3/m3] - scv, &! snow cover, water equivalent [mm] - scvold, &! snow cover for previous time step [mm] - pg_snow, &! snowfall onto ground including canopy runoff [kg/(m2 s)] - forc_t, &! atmospheric temperature [K] - t_grnd ! ground surface temperature [K] - - REAL(r8), intent(in) :: & + chil, &! leaf angle distribution factor + rho(2,2), &! leaf reflectance (iw=iband, il=life and dead) + tau(2,2), &! leaf transmittance (iw=iband, il=life and dead) + fveg, &! fractional vegetation cover [-] + green, &! green leaf fraction + lai, &! leaf area index (LAI+SAI) [m2/m2] + sai, &! stem area index (LAI+SAI) [m2/m2] + + coszen, &! cosine of solar zenith angle [-] + wt, &! fraction of vegetation covered by snow [-] + fsno, &! fraction of soil covered by snow [-] + ssw, &! water volumetric content of soil surface layer [m3/m3] + scv, &! snow cover, water equivalent [mm] + scvold, &! snow cover for previous time step [mm] + pg_snow, &! snowfall onto ground including canopy runoff [kg/(m2 s)] + forc_t, &! atmospheric temperature [K] + t_grnd ! ground surface temperature [K] + + real(r8), intent(in) :: & wliq_soisno ( maxsnl+1:0 ), &! liquid water (kg/m2) wice_soisno ( maxsnl+1:0 ), &! ice lens (kg/m2) snofrz ( maxsnl+1:0 ), &! snow freezing rate (col,lyr) [kg m-2 s-1] t_soisno ( maxsnl+1:1 ), &! soil + snow layer temperature [K] dz_soisno ( maxsnl+1:1 ) ! layer thickness (m) - REAL(r8), intent(inout) :: & + real(r8), intent(inout) :: & snw_rds ( maxsnl+1:0 ), &! effective grain radius (col,lyr) [microns, m-6] mss_bcpho ( maxsnl+1:0 ), &! mass of hydrophobic BC in snow (col,lyr) [kg] mss_bcphi ( maxsnl+1:0 ), &! mass of hydrophillic BC in snow (col,lyr) [kg] @@ -150,138 +144,120 @@ SUBROUTINE albland (ipatch, patchtype, deltim,& mss_dst3 ( maxsnl+1:0 ), &! mass of dust species 3 in snow (col,lyr) [kg] mss_dst4 ( maxsnl+1:0 ) ! mass of dust species 4 in snow (col,lyr) [kg] - REAL(r8), intent(inout) :: sag ! non dimensional snow age [-] + real(r8), intent(inout) :: sag ! non dimensional snow age [-] - REAL(r8), intent(out) :: & - alb(2,2), &! averaged albedo [-] - ssun(2,2), &! sunlit canopy absorption for solar radiation - ssha(2,2), &! shaded canopy absorption for solar radiation, - ! normalized by the incident flux - thermk, &! canopy gap fraction for tir radiation - extkb, &! (k, g(mu)/mu) direct solar extinction coefficient - extkd ! diffuse and scattered diffuse PAR extinction coefficient + real(r8), intent(out) :: & + alb(2,2), &! averaged albedo [-] + ssun(2,2), &! sunlit canopy absorption for solar radiation + ssha(2,2), &! shaded canopy absorption for solar radiation, + ! normalized by the incident flux + thermk, &! canopy gap fraction for tir radiation + extkb, &! (k, g(mu)/mu) direct solar extinction coefficient + extkd ! diffuse and scattered diffuse PAR extinction coefficient - REAL(r8), intent(out) :: & - ssno(2,2,maxsnl+1:1) ! snow absorption [-] + real(r8), intent(out) :: & + ssoi(2,2), &! ground soil absorption [-] + ssno(2,2), &! ground snow absorption [-] + ssno_lyr(2,2,maxsnl+1:1) ! ground snow layer absorption, by SNICAR [-] !-------------------------- Local variables ---------------------------- - INTEGER &! - iw, &! wavelength (1=visible, 2=near-infrared) - id, &! 1=direct, 2=diffuse - k ! looping indx - - REAL(r8) &! - age, &! factor to reduce visible snow alb due to snow age [-] - albg0, &! temporary varaiable [-] - albsno(2,2),&! snow albedo [-] + + real(r8) :: &! + age, &! factor to reduce visible snow alb due to snow age [-] + albg0, &! temporary varaiable [-] + albsoi(2,2), &! soil albedo [-] + albsno(2,2), &! snow albedo [-] albsno_pur(2,2),&! snow albedo [-] albsno_bc (2,2),&! snow albedo [-] albsno_oc (2,2),&! snow albedo [-] albsno_dst(2,2),&! snow albedo [-] - albg(2,2), &! albedo, ground - albv(2,2), &! albedo, vegetation [-] - alb_s_inc, &! decrease in soil albedo due to wetness [-] - beta0, &! upscattering parameter for direct beam [-] - cff, &! snow alb correction factor for zenith angle > 60 [-] - conn, &! constant (=0.5) for visible snow alb calculation [-] - cons, &! constant (=0.2) for nir snow albedo calculation [-] - czen, &! cosine of solar zenith angle > 0 [-] - czf, &! solar zenith correction for new snow albedo [-] - dfalbl, &! snow albedo for diffuse nir radiation [-] - dfalbs, &! snow albedo for diffuse visible solar radiation [-] - dralbl, &! snow albedo for visible radiation [-] - dralbs, &! snow albedo for near infrared radiation [-] - fsol1, &! solar flux fraction for wavelength < 0.7 micron [-] - fsol2, &! solar flux fraction for wavelength > 0.7 micron [-] - lsai, &! leaf and stem area index (LAI+SAI) [m2/m2] - scat(2), &! single scattering albedo for vir/nir beam [-] - sl, &! factor that helps control alb zenith dependence [-] - snal0, &! alb for visible,incident on new snow (zen ang<60) [-] - snal1, &! alb for NIR, incident on new snow (zen angle<60) [-] - upscat, &! upward scattered fraction for direct beam [-] - tran(2,2) ! canopy transmittances for solar radiation - - INTEGER ps, pe, pc - LOGICAL do_capsnow ! true => do snow capping - logical use_snicar_frc ! true: if radiative forcing is being calculated, first estimate clean-snow albedo + albg(2,2), &! albedo, ground + albv(2,2), &! albedo, vegetation [-] + alb_s_inc, &! decrease in soil albedo due to wetness [-] + beta0, &! upscattering parameter for direct beam [-] + cff, &! snow alb correction factor for zenith angle > 60 [-] + conn, &! constant (=0.5) for visible snow alb calculation [-] + cons, &! constant (=0.2) for nir snow albedo calculation [-] + czen, &! cosine of solar zenith angle > 0 [-] + czf, &! solar zenith correction for new snow albedo [-] + dfalbl, &! snow albedo for diffuse nir radiation [-] + dfalbs, &! snow albedo for diffuse visible solar radiation [-] + dralbl, &! snow albedo for visible radiation [-] + dralbs, &! snow albedo for near infrared radiation [-] + lsai, &! leaf and stem area index (LAI+SAI) [m2/m2] + sl, &! factor that helps control alb zenith dependence [-] + snal0, &! alb for visible,incident on new snow (zen ang<60) [-] + snal1, &! alb for NIR, incident on new snow (zen angle<60) [-] + upscat, &! upward scattered fraction for direct beam [-] + tran(2,3) ! canopy transmittances for solar radiation + + integer ps, pe + logical do_capsnow ! true => DO snow capping + logical use_snicar_frc ! true: IF radiative forcing is being calculated, first estimate clean-snow albedo logical use_snicar_ad ! true: use SNICAR_AD_RT, false: use SNICAR_RT - REAL(r8) snwcp_ice ! excess precipitation due to snow capping [kg m-2 s-1] - REAL(r8) mss_cnc_bcphi ( maxsnl+1:0 ) !mass concentration of hydrophilic BC (col,lyr) [kg/kg] - REAL(r8) mss_cnc_bcpho ( maxsnl+1:0 ) !mass concentration of hydrophobic BC (col,lyr) [kg/kg] - REAL(r8) mss_cnc_ocphi ( maxsnl+1:0 ) !mass concentration of hydrophilic OC (col,lyr) [kg/kg] - REAL(r8) mss_cnc_ocpho ( maxsnl+1:0 ) !mass concentration of hydrophobic OC (col,lyr) [kg/kg] - REAL(r8) mss_cnc_dst1 ( maxsnl+1:0 ) !mass concentration of dust aerosol species 1 (col,lyr) [kg/kg] - REAL(r8) mss_cnc_dst2 ( maxsnl+1:0 ) !mass concentration of dust aerosol species 2 (col,lyr) [kg/kg] - REAL(r8) mss_cnc_dst3 ( maxsnl+1:0 ) !mass concentration of dust aerosol species 3 (col,lyr) [kg/kg] - REAL(r8) mss_cnc_dst4 ( maxsnl+1:0 ) !mass concentration of dust aerosol species 4 (col,lyr) [kg/kg] + real(r8) snwcp_ice !excess precipitation due to snow capping [kg m-2 s-1] + real(r8) mss_cnc_bcphi ( maxsnl+1:0 ) !mass concentration of hydrophilic BC (col,lyr) [kg/kg] + real(r8) mss_cnc_bcpho ( maxsnl+1:0 ) !mass concentration of hydrophobic BC (col,lyr) [kg/kg] + real(r8) mss_cnc_ocphi ( maxsnl+1:0 ) !mass concentration of hydrophilic OC (col,lyr) [kg/kg] + real(r8) mss_cnc_ocpho ( maxsnl+1:0 ) !mass concentration of hydrophobic OC (col,lyr) [kg/kg] + real(r8) mss_cnc_dst1 ( maxsnl+1:0 ) !mass concentration of dust aerosol species 1 (col,lyr) [kg/kg] + real(r8) mss_cnc_dst2 ( maxsnl+1:0 ) !mass concentration of dust aerosol species 2 (col,lyr) [kg/kg] + real(r8) mss_cnc_dst3 ( maxsnl+1:0 ) !mass concentration of dust aerosol species 3 (col,lyr) [kg/kg] + real(r8) mss_cnc_dst4 ( maxsnl+1:0 ) !mass concentration of dust aerosol species 4 (col,lyr) [kg/kg] ! ---------------------------------------------------------------------- ! 1. Initial set ! ---------------------------------------------------------------------- -! division of solar flux for wavelength less or greater than 0.7 micron - fsol1 = 0.5 ! shortwave - fsol2 = 0.5 ! longwave -! short and long wave albedo for new snow - snal0 = 0.85 ! shortwave - snal1 = 0.65 ! long wave - -! set initial leaf scattering reflectance. Note: "scat" may use different -! value for different vegetation latter - beta0 = 0.5 - scat(1) = 0.15 - scat(2) = 0.85 +! visible and near infrared band albedo for new snow + snal0 = 0.85 ! visible band + snal1 = 0.65 ! near infrared ! ---------------------------------------------------------------------- ! set default soil and vegetation albedos and solar absorption - alb (:,:) = 0. ! averaged - albg(:,:) = 0. ! ground - albv(:,:) = 0. ! vegetation - ssun(:,:) = 0. - ssha(:,:) = 0. + !TODO: need double check + alb (:,:) = 1. ! averaged + albg(:,:) = 1. ! ground + albv(:,:) = 1. ! vegetation + ssun(:,:) = 0. ! sunlit leaf absorption + ssha(:,:) = 0. ! shaded leaf absorption + tran(:,1) = 0. ! incident direct radiation duffuse transmittance + tran(:,2) = 1. ! incident diffuse radiation diffuse transmittance + tran(:,3) = 1. ! incident direct radiation direct transmittance + ! 07/06/2023, yuan: use the values of previous timestep. ! for nighttime longwave calculations. !thermk = 1.e-3 IF (lai+sai <= 1.e-6) THEN - thermk = 1.e-3 + thermk = 1. ENDIF extkb = 1. extkd = 0.718 albsno (:,:) = 0. !set initial snow albedo - albsno_pur(:,:) = 0. !set initial snow albedo - albsno_bc (:,:) = 0. !set initial snow albedo - albsno_oc (:,:) = 0. !set initial snow albedo - albsno_dst(:,:) = 0. !set initial snow albedo - ssno (:,:,:) = 0. !set initial snow absorption - ssno(:,:,snl+1) = 1. !set initial snow absorption + albsno_pur(:,:) = 0. !set initial pure snow albedo + albsno_bc (:,:) = 0. !set initial BC snow albedo + albsno_oc (:,:) = 0. !set initial OC snow albedo + albsno_dst(:,:) = 0. !set initial dust snow albedo + + ! soil and snow absorption + ssoi (:,:) = 0. !set initial soil absorption + ssno (:,:) = 0. !set initial snow absorption + ssno_lyr(:,:,:) = 0. !set initial snow layer absorption IF (patchtype == 0) THEN -#ifdef LULC_IGBP_PFT +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) ps = patch_pft_s(ipatch) pe = patch_pft_e(ipatch) ssun_p(:,:,ps:pe) = 0. ssha_p(:,:,ps:pe) = 0. ! 07/06/2023, yuan: use the values of previous timestep. !thermk_p(ps:pe) = 1.e-3 - WHERE (lai_p(ps:pe)+sai_p(ps:pe) <= 1.e-6) thermk_p(ps:pe) = 1.e-3 + WHERE (lai_p(ps:pe)+sai_p(ps:pe) <= 1.e-6) thermk_p(ps:pe) = 1. extkb_p(ps:pe) = 1. extkd_p(ps:pe) = 0.718 #endif - -#ifdef LULC_IGBP_PC - pc = patch2pc(ipatch) - ssun_c(:,:,:,pc) = 0. - ssha_c(:,:,:,pc) = 0. - ! 07/06/2023, yuan: use the values of previous timestep. - !thermk_c(:,pc) = 1.e-3 - WHERE (lai_c(:,pc)+sai_c(:,pc) <= 1.e-6) thermk_c(:,pc) = 1.e-3 - !fshade_c(:,pc) = pcfrac(:,pc) - !fshade_c(0,pc) = 0. - extkb_c(:,pc) = 1. - extkd_c(:,pc) = 0.718 -#endif ENDIF ! ---------------------------------------------------------------------- @@ -301,7 +277,7 @@ SUBROUTINE albland (ipatch, patchtype, deltim,& mss_dst1 ,mss_dst2 ,mss_dst3 ,mss_dst4 ,& mss_cnc_bcphi ,mss_cnc_bcpho ,mss_cnc_ocphi ,mss_cnc_ocpho ,& - mss_cnc_dst1 ,mss_cnc_dst2 ,mss_cnc_dst3 ,mss_cnc_dst4 ) + mss_cnc_dst1 ,mss_cnc_dst2 ,mss_cnc_dst3 ,mss_cnc_dst4 ) ! ---------------------------------------------------------------------- ! Snow aging routine based on Flanner and Zender (2006), Linking snowpack @@ -320,7 +296,7 @@ SUBROUTINE albland (ipatch, patchtype, deltim,& lsai=lai+sai IF(coszen<=0.) THEN - RETURN !only do albedo when coszen > 0 + RETURN !only DO albedo when coszen > 0 ENDIF czen=max(coszen,0.001) @@ -328,41 +304,45 @@ SUBROUTINE albland (ipatch, patchtype, deltim,& ! ---------------------------------------------------------------------- ! 2. get albedo over land ! ---------------------------------------------------------------------- -! 2.1 bare soil albedos, depends on moisture - IF(patchtype<=2)THEN ! wetland, permanent ice and water +! 2.1 soil albedos, depends on moisture + IF (patchtype <= 2) THEN !soil, urban and wetland alb_s_inc = max(0.11-0.40*ssw, 0.) albg(1,1) = min(soil_s_v_alb + alb_s_inc, soil_d_v_alb) albg(2,1) = min(soil_s_n_alb + alb_s_inc, soil_d_n_alb) - albg(:,2) = albg(:,1) !diffused albedos for bare soil + albg(:,2) = albg(:,1) !diffused albedos setting ! 2.2 albedos for permanent ice sheet. - ELSE IF(patchtype==3) THEN !permanent ice sheet + ELSE IF(patchtype == 3) THEN !permanent ice sheet albg(1,:) = 0.8 albg(2,:) = 0.55 -! 2.3 albedo for inland water (NOTE: wetland is removed) - ELSE IF(patchtype>=4) THEN +! 2.3 albedo for inland water + ELSE IF(patchtype >= 4) THEN albg0 = 0.05/(czen+0.15) albg(:,1) = albg0 - albg(:,2) = 0.1 !Subin (2012) + albg(:,2) = 0.1 !Subin (2012) - IF(t_grnd0.)THEN + IF (scv > 0.) THEN IF (.not. DEF_USE_SNICAR) THEN cons = 0.2 conn = 0.5 - sl = 2.0 !sl helps control albedo zenith dependence + sl = 2.0 !sl helps control albedo zenith dependence ! 05/02/2023, Dai: move from CoLMMAIN.F90 ! update the snow age @@ -370,7 +350,7 @@ SUBROUTINE albland (ipatch, patchtype, deltim,& CALL snowage (deltim,t_grnd,scv,scvold,sag) ! correction for snow age - age = 1.-1./(1.+sag) !correction for snow age + age = 1.-1./(1.+sag) dfalbs = snal0*(1.-cons*age) ! czf corrects albedo of new snow for solar zenith @@ -390,7 +370,7 @@ SUBROUTINE albland (ipatch, patchtype, deltim,& ELSE ! 01/09/2023, yuan: CALL SNICAR for snow albedo - use_snicar_frc = .false. ! true: if radiative forcing is being calculated, first estimate clean-snow albedo + use_snicar_frc = .false. ! true: IF radiative forcing is being calculated, first estimate clean-snow albedo use_snicar_ad = .true. ! use true: use SNICAR_AD_RT, false: use SNICAR_RT CALL SnowAlbedo( use_snicar_frc ,use_snicar_ad ,coszen ,& @@ -402,64 +382,84 @@ SUBROUTINE albland (ipatch, patchtype, deltim,& albsno(:,1) ,albsno(:,2) ,albsno_pur(:,1),albsno_pur(:,2),& albsno_bc(:,1) ,albsno_bc(:,2) ,albsno_oc(:,1) ,albsno_oc(:,2) ,& - albsno_dst(:,1),albsno_dst(:,2),ssno(1,1,:) ,ssno(2,1,:) ,& - ssno(1,2,:) ,ssno(2,2,:) ) + albsno_dst(:,1),albsno_dst(:,2),ssno_lyr(1,1,:),ssno_lyr(2,1,:),& + ssno_lyr(1,2,:),ssno_lyr(2,2,:)) ! IF no snow layer exist IF (snl == 0) THEN - ssno(:,:,1) = ssno(:,:,1) + ssno(:,:,0) - ssno(:,:,0) = 0. - END IF + ssno_lyr(:,:,1) = ssno_lyr(:,:,1) + ssno_lyr(:,:,0) + ssno_lyr(:,:,0) = 0. + ENDIF ENDIF ENDIF ! 3.1 correction due to snow cover albg(:,:) = (1.-fsno)*albg(:,:) + fsno*albsno(:,:) - alb(:,:) = albg(:,:) + alb (:,:) = albg(:,:) ! ---------------------------------------------------------------------- -! 4. canopy albedos : two stream approximation +! 4. canopy albedos: two stream approximation or 3D canopy radiation transfer ! ---------------------------------------------------------------------- IF (lai+sai > 1e-6) THEN - IF (patchtype == 0) THEN + IF (patchtype == 0) THEN !soil patches #if (defined LULC_USGS || defined LULC_IGBP) CALL twostream (chil,rho,tau,green,lai,sai,& czen,albg,albv,tran,thermk,extkb,extkd,ssun,ssha) - albv(:,:) = (1.-wt)*albv(:,:) + wt*albsno(:,:) - alb(:,:) = (1.-fveg)*albg(:,:) + fveg*albv(:,:) -#endif - -#ifdef LULC_IGBP_PFT - CALL twostream_wrap (ipatch, czen, albg, albv, tran, ssun, ssha) + ! 08/31/2023, yuan: to be consistent with PFT and PC + !albv(:,:) = (1.- wt)*albv(:,:) + wt*albsno(:,:) + !alb (:,:) = (1.-fveg)*albg(:,:) + fveg*albv(:,:) alb(:,:) = albv(:,:) #endif - -#ifdef LULC_IGBP_PC - CALL ThreeDCanopy_wrap (ipatch, czen, albg, albv, ssun, ssha) - alb(:,:) = albv(:,:) -#endif - ELSE !other patchtypes (/=0) - CALL twostream (chil,rho,tau,green,lai,sai,& czen,albg,albv,tran,thermk,extkb,extkd,ssun,ssha) - albv(:,:) = (1.-wt)*albv(:,:) + wt*albsno(:,:) - alb(:,:) = (1.-fveg)*albg(:,:) + fveg*albv(:,:) + ! 08/31/2023, yuan: to be consistent with PFT and PC + !albv(:,:) = (1.- wt)*albv(:,:) + wt*albsno(:,:) + !alb (:,:) = (1.-fveg)*albg(:,:) + fveg*albv(:,:) + alb(:,:) = albv(:,:) ENDIF + ENDIF + + + IF (patchtype == 0) THEN +#ifdef LULC_IGBP_PFT + CALL twostream_wrap (ipatch, czen, albg, albv, tran, ssun, ssha) + alb(:,:) = albv(:,:) +#endif +#ifdef LULC_IGBP_PC + !NOTE: if patchclass is CROPLAND, using twostream model + IF (patchclass(ipatch) == CROPLAND) THEN + CALL twostream_wrap (ipatch, czen, albg, albv, tran, ssun, ssha) + alb(:,:) = albv(:,:) + ELSE + CALL ThreeDCanopy_wrap (ipatch, czen, albg, albv, tran, ssun, ssha) + alb(:,:) = albv(:,:) + ENDIF +#endif ENDIF + ! treat soil/snow albedo in direct and diffuse respectively + ssoi(1,1) = tran(1,1)*(1.-albsoi(1,2)) + tran(1,3)*(1-albsoi(1,1)) + ssoi(2,1) = tran(2,1)*(1.-albsoi(2,2)) + tran(2,3)*(1-albsoi(2,1)) + ssoi(1,2) = tran(1,2)*(1.-albsoi(1,2)) + ssoi(2,2) = tran(2,2)*(1.-albsoi(2,2)) + + ssno(1,1) = tran(1,1)*(1.-albsno(1,2)) + tran(1,3)*(1-albsno(1,1)) + ssno(2,1) = tran(2,1)*(1.-albsno(2,2)) + tran(2,3)*(1-albsno(2,1)) + ssno(1,2) = tran(1,2)*(1.-albsno(1,2)) + ssno(2,2) = tran(2,2)*(1.-albsno(2,2)) + !----------------------------------------------------------------------- END SUBROUTINE albland - SUBROUTINE twostream ( chil, rho, tau, green, lai, sai, & coszen, albg, albv, tran, thermk, extkb, extkd, ssun, ssha ) @@ -476,7 +476,7 @@ SUBROUTINE twostream ( chil, rho, tau, green, lai, sai, & IMPLICIT NONE ! parameters - REAL(r8), intent(in) :: & + real(r8), intent(in) :: & ! static parameters associated with vegetation type chil, &! leaf angle distribution factor rho(2,2), &! leaf reflectance (iw=iband, il=life and dead) @@ -488,14 +488,14 @@ SUBROUTINE twostream ( chil, rho, tau, green, lai, sai, & sai ! stem area index ! environmental variables - REAL(r8), intent(in) :: & + real(r8), intent(in) :: & coszen, &! consine of solar zenith angle albg(2,2) ! albedos of ground ! output - REAL(r8), intent(out) :: & + real(r8), intent(out) :: & albv(2,2), &! albedo, vegetation [-] - tran(2,2), &! canopy transmittances for solar radiation + tran(2,3), &! canopy transmittances for solar radiation thermk, &! canopy gap fraction for tir radiation extkb, &! (k, g(mu)/mu) direct solar extinction coefficient extkd, &! diffuse and scattered diffuse PAR extinction coefficient @@ -504,62 +504,62 @@ SUBROUTINE twostream ( chil, rho, tau, green, lai, sai, & ! normalized by the incident flux !-------------------------- local ----------------------------------- - REAL(r8) :: & - lsai, &! lai+sai - sai_, &! sai=0 for USGS, no stem - phi1, &! (phi-1) - phi2, &! (phi-2) - scat, &! (omega) - proj, &! (g(mu)) - zmu, &! (int(mu/g(mu)) - zmu2, &! (zmu * zmu) - as, &! (a-s(mu)) - upscat, &! (omega-beta) - betao, &! (beta-0) - psi, &! (h) - - be, &! (b) - ce, &! (c) - de, &! (d) - fe, &! (f) - - power1, &! (h*lai) - power2, &! (k*lai) - power3, &! - - sigma, &! - s1, &! - s2, &! - p1, &! - p2, &! - p3, &! - p4, &! - f1, &! - f2, &! - h1, &! - h4, &! - m1, &! - m2, &! - m3, &! - n1, &! - n2, &! - n3, &! - - hh1, &! (h1/sigma) - hh2, &! (h2) - hh3, &! (h3) - hh4, &! (h4/sigma) - hh5, &! (h5) - hh6, &! (h6) - hh7, &! (h7) - hh8, &! (h8) - hh9, &! (h9) - hh10, &! (h10) - - eup(2,2), &! (integral of i_up*exp(-kx) ) - edown(2,2) ! (integral of i_down*exp(-kx) ) - - INTEGER iw ! + real(r8) :: & + lsai, &! lai+sai + sai_, &! sai=0 for USGS, no stem + phi1, &! (phi-1) + phi2, &! (phi-2) + scat, &! (omega) + proj, &! (g(mu)) + zmu, &! (int(mu/g(mu)) + zmu2, &! (zmu * zmu) + as, &! (a-s(mu)) + upscat, &! (omega-beta) + betao, &! (beta-0) + psi, &! (h) + + be, &! (b) + ce, &! (c) + de, &! (d) + fe, &! (f) + + power1, &! (h*lai) + power2, &! (k*lai) + power3, &! + + sigma, &! + s1, &! + s2, &! + p1, &! + p2, &! + p3, &! + p4, &! + f1, &! + f2, &! + h1, &! + h4, &! + m1, &! + m2, &! + m3, &! + n1, &! + n2, &! + n3, &! + + hh1, &! (h1/sigma) + hh2, &! (h2) + hh3, &! (h3) + hh4, &! (h4/sigma) + hh5, &! (h5) + hh6, &! (h6) + hh7, &! (h7) + hh8, &! (h8) + hh9, &! (h9) + hh10, &! (h10) + + eup(2,2), &! (integral of i_up*exp(-kx) ) + edown(2,2) ! (integral of i_down*exp(-kx) ) + + integer iw ! !----------------------------------------------------------------------- ! projected area of phytoelements in direction of mu and @@ -722,8 +722,8 @@ SUBROUTINE twostream ( chil, rho, tau, green, lai, sai, & ssun(iw,1) = (1.-scat) * ( 1.-s2 + 1. / zmu * (eup(iw,1) + edown(iw,1)) ) ssha(iw,1) = scat * (1.-s2) & - + ( albg(iw,2)*tran(iw,1) + albg(iw,1)*s2 - tran(iw,1) ) - albv(iw,1) & - - ( 1. - scat ) / zmu * ( eup(iw,1) + edown(iw,1) ) + + ( albg(iw,2)*tran(iw,1) + albg(iw,1)*s2 - tran(iw,1) ) - albv(iw,1) & + - ( 1. - scat ) / zmu * ( eup(iw,1) + edown(iw,1) ) !----------------------------------------------------------------------- ! calculation of diffuse albedos and canopy transmittances @@ -742,10 +742,10 @@ SUBROUTINE twostream ( chil, rho, tau, green, lai, sai, & hh7 = -m2 / (m1*n2 - m2*n1) hh8 = -m1 / (m2*n1 - m1*n2) - hh9 = hh7 * p1 / ce + hh9 = hh7 * p1 / ce hh10 = hh8 * p2 / ce - albv(iw,2) = hh7 + hh8 + albv(iw,2) = hh7 + hh8 tran(iw,2) = hh9 * s1 + hh10 / s1 IF (abs(sigma) .gt. 1.e-10) THEN @@ -764,9 +764,15 @@ SUBROUTINE twostream ( chil, rho, tau, green, lai, sai, & ENDDO ! WAVE_BAND_LOOP +! 03/06/2020, yuan: add direct transmittance (s2) to +! tran for incident direct case +! 03/14/2020, yuan: save direct T to 3rd position of tran + tran(:,3) = s2 + END SUBROUTINE twostream -#ifdef LULC_IGBP_PFT + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) SUBROUTINE twostream_mod ( chil, rho, tau, green, lai, sai, & coszen, albg, albv, tran, thermk, extkb, extkd, ssun, ssha ) @@ -790,8 +796,8 @@ SUBROUTINE twostream_mod ( chil, rho, tau, green, lai, sai, & IMPLICIT NONE ! parameters - REAL(r8), intent(in) :: & - ! static parameters associated with vegetation TYPE + real(r8), intent(in) :: & + ! static parameters associated with vegetation type chil, &! leaf angle distribution factor rho(2,2), &! leaf reflectance (iw=iband, il=life and dead) tau(2,2), &! leaf transmittance (iw=iband, il=life and dead) @@ -802,14 +808,14 @@ SUBROUTINE twostream_mod ( chil, rho, tau, green, lai, sai, & sai ! stem area index ! environmental variables - REAL(r8), intent(in) :: & + real(r8), intent(in) :: & coszen, &! consine of solar zenith angle albg(2,2) ! albedos of ground ! output - REAL(r8), intent(out) :: & + real(r8), intent(out) :: & albv(2,2), &! albedo, vegetation [-] - tran(2,2), &! canopy transmittances for solar radiation + tran(2,3), &! canopy transmittances for solar radiation thermk, &! canopy gap fraction for tir radiation extkb, &! (k, g(mu)/mu) direct solar extinction coefficient extkd, &! diffuse and scattered diffuse PAR extinction coefficient @@ -818,67 +824,67 @@ SUBROUTINE twostream_mod ( chil, rho, tau, green, lai, sai, & ! normalized by the incident flux !-------------------------- local ----------------------------------- - REAL(r8) :: & - lsai, &! lai+sai - phi1, &! (phi-1) - phi2, &! (phi-2) - scat, &! (omega) - proj, &! (g(mu)) - zmu, &! (int(mu/g(mu)) - zmu2, &! (zmu * zmu) - as, &! (a-s(mu)) - upscat, &! (omega-beta) - betao, &! (beta-0) - psi, &! (h) - - be, &! (b) - ce, &! (c) - de, &! (d) - fe, &! (f) - - power1, &! (h*lai) - power2, &! (k*lai) - power3, &! - - sigma, &! - s1, &! - s2, &! - p1, &! - p2, &! - p3, &! - p4, &! - f1, &! - f2, &! - h1, &! - h4, &! - m1, &! - m2, &! - m3, &! - n1, &! - n2, &! - n3, &! - - hh1, &! (h1/sigma) - hh2, &! (h2) - hh3, &! (h3) - hh4, &! (h4/sigma) - hh5, &! (h5) - hh6, &! (h6) - hh7, &! (h7) - hh8, &! (h8) - hh9, &! (h9) - hh10, &! (h10) - - eup, &! (integral of i_up*exp(-kx) ) - edw ! (integral of i_down*exp(-kx) ) - - INTEGER iw ! band loop index - INTEGER ic ! direct/diffuse loop index + real(r8) :: & + lsai, &! lai+sai + phi1, &! (phi-1) + phi2, &! (phi-2) + scat, &! (omega) + proj, &! (g(mu)) + zmu, &! (int(mu/g(mu)) + zmu2, &! (zmu * zmu) + as, &! (a-s(mu)) + upscat, &! (omega-beta) + betao, &! (beta-0) + psi, &! (h) + + be, &! (b) + ce, &! (c) + de, &! (d) + fe, &! (f) + + power1, &! (h*lai) + power2, &! (k*lai) + power3, &! + + sigma, &! + s1, &! + s2, &! + p1, &! + p2, &! + p3, &! + p4, &! + f1, &! + f2, &! + h1, &! + h4, &! + m1, &! + m2, &! + m3, &! + n1, &! + n2, &! + n3, &! + + hh1, &! (h1/sigma) + hh2, &! (h2) + hh3, &! (h3) + hh4, &! (h4/sigma) + hh5, &! (h5) + hh6, &! (h6) + hh7, &! (h7) + hh8, &! (h8) + hh9, &! (h9) + hh10, &! (h10) + + eup, &! (integral of i_up*exp(-kx) ) + edw ! (integral of i_down*exp(-kx) ) + + integer iw ! band loop index + integer ic ! direct/diffuse loop index ! variables for modified version - REAL(r8) :: cosz, theta, cosdif, albgblk - REAL(r8) :: tmptau, wrho, wtau - REAL(r8) :: s2d, extkbd, sall(2,2), q, ssun_rev + real(r8) :: cosz, theta, cosdif, albgblk + real(r8) :: tmptau, wrho, wtau + real(r8) :: s2d, extkbd, sall(2,2), q, ssun_rev !----------------------------------------------------------------------- ! projected area of phytoelements in direction of mu and @@ -916,14 +922,14 @@ SUBROUTINE twostream_mod ( chil, rho, tau, green, lai, sai, & DO ic = 1, 2 IF (ic == 2) THEN - cosz = max(0.001_r8, cosdif) + cosz = max(0.001_r8, cosdif) theta = acos(cosz) theta = theta/3.14159*180 theta = theta + chil*5._r8 - cosz = cos(theta/180*3.14159) + cosz = cos(theta/180*3.14159) ELSE - cosz = coszen + cosz = coszen ENDIF proj = phi1 + phi2 * cosz @@ -1104,6 +1110,7 @@ SUBROUTINE twostream_mod ( chil, rho, tau, green, lai, sai, & ! 03/14/2020, yuan: treat soil albedo in direct/diffuse cases IF (ic == 1) THEN tran(iw,ic) = (s2d*albg(iw,1)*albv(iw,2) + tran(iw,ic)) / (1.-q) + tran(:,3) = s2d sall(iw,ic) = sall(iw,ic) + & (tran(iw,ic)*albg(iw,2) + s2d*albg(iw,1)) * sall(iw,2) @@ -1136,7 +1143,8 @@ SUBROUTINE twostream_mod ( chil, rho, tau, green, lai, sai, & END SUBROUTINE twostream_mod #endif -#ifdef LULC_IGBP_PFT + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) SUBROUTINE twostream_wrap ( ipatch, coszen, albg, & albv, tran, ssun, ssha ) @@ -1156,30 +1164,30 @@ SUBROUTINE twostream_wrap ( ipatch, coszen, albg, & IMPLICIT NONE ! parameters - INTEGER, intent(in) :: & + integer, intent(in) :: & ipatch ! patch index ! environmental variables - REAL(r8), intent(in) :: & + real(r8), intent(in) :: & coszen, &! consine of solar zenith angle albg(2,2) ! albedos of ground ! output - REAL(r8), intent(out) :: & + real(r8), intent(out) :: & albv(2,2), &! albedo, vegetation [-] - tran(2,2), &! canopy transmittances for solar radiation + tran(2,3), &! canopy transmittances for solar radiation ssun(2,2), &! sunlit canopy absorption for solar radiation ssha(2,2) ! shaded canopy absorption for solar radiation, ! normalized by the incident flux - INTEGER :: i, p, ps, pe - REAL(r8), allocatable :: tran_p(:,:,:) - REAL(r8), allocatable :: albv_p (:,:,:) + integer :: i, p, ps, pe + real(r8), allocatable :: tran_p(:,:,:) + real(r8), allocatable :: albv_p(:,:,:) ps = patch_pft_s(ipatch) pe = patch_pft_e(ipatch) - allocate ( tran_p (2,2,ps:pe) ) + allocate ( tran_p (2,3,ps:pe) ) allocate ( albv_p (2,2,ps:pe) ) DO i = ps, pe @@ -1192,8 +1200,9 @@ SUBROUTINE twostream_wrap ( ipatch, coszen, albg, & albv_p(:,:,i) = albg(:,:) ssun_p(:,:,i) = 0. ssha_p(:,:,i) = 0. - tran_p(:,1,i) = 1. + tran_p(:,1,i) = 0. tran_p(:,2,i) = 1. + tran_p(:,3,i) = 1. ENDIF ENDDO @@ -1214,127 +1223,81 @@ SUBROUTINE twostream_wrap ( ipatch, coszen, albg, & tran(1,1) = sum( tran_p(1,1,ps:pe)*pftfrac(ps:pe) ) tran(1,2) = sum( tran_p(1,2,ps:pe)*pftfrac(ps:pe) ) + tran(1,3) = sum( tran_p(1,3,ps:pe)*pftfrac(ps:pe) ) tran(2,1) = sum( tran_p(2,1,ps:pe)*pftfrac(ps:pe) ) tran(2,2) = sum( tran_p(2,2,ps:pe)*pftfrac(ps:pe) ) + tran(2,3) = sum( tran_p(2,3,ps:pe)*pftfrac(ps:pe) ) - !NOTE: fordebug ONLY below + !NOTE: fordebug only below IF (ssun(1,1)<0 .or. ssun(1,2)<0 .or. ssun(2,1)<0 .or. ssun(2,2)<0) THEN - print *, ipatch + print *, 'Warning:negative albedo',ipatch print *, ssun ENDIF deallocate ( tran_p ) + deallocate ( albv_p ) END SUBROUTINE twostream_wrap #endif - SUBROUTINE albocean (oro, scv, coszrs, alb) -!----------------------------------------------------------------------- -! -! Compute surface albedos -! -! Computes surface albedos for direct/diffuse incident radiation for -! two spectral intervals: -! s = 0.2-0.7 micro-meters -! l = 0.7-5.0 micro-meters -! -! Albedos specified as follows: -! -! Ocean Uses solar zenith angle to compute albedo for direct -! radiation; diffuse radiation values constant; albedo -! independent of spectral interval and other physical -! factors such as ocean surface wind speed. -! -! Ocean with Surface albs specified; combined with overlying snow -! sea ice -! -! For more details , see Briegleb, Bruce P., 1992: Delta-Eddington -! Approximation for Solar Radiation in the NCAR Community Climate Model, -! Journal of Geophysical Research, Vol 97, D7, pp7603-7612). -! -! yongjiu dai and xin-zhong liang (08/01/2001) -!----------------------------------------------------------------------- + SUBROUTINE snowage ( deltim,tg,scv,scvold,sag ) + +!======================================================================= +! Original version: Robert Dickinson +! Update snow cover and snow age, based on BATS code +!======================================================================= USE MOD_Precision + USE MOD_Const_Physical, only : tfrz IMPLICIT NONE -!------------------------------Arguments-------------------------------- - - REAL(r8), intent(in) :: oro ! /ocean(0)/seaice(2) flag - REAL(r8), intent(in) :: scv ! snow water equivalent) [mm] - REAL(r8), intent(in) :: coszrs ! Cosine solar zenith angle - - REAL(r8), intent(out) :: alb(2,2) ! srf alb for direct (diffuse) rad 0.2-0.7 micro-ms - ! Srf alb for direct (diffuse) rad 0.7-5.0 micro-ms - -!---------------------------Local variables----------------------------- +!-------------------------- Dummy Argument ----------------------------- - REAL(r8) frsnow ! horizontal fraction of snow cover - REAL(r8) snwhgt ! physical snow height - REAL(r8) rghsnw ! roughness for horizontal snow cover fractn + real(r8), intent(in) :: deltim ! seconds in a time step [second] + real(r8), intent(in) :: tg ! temperature of soil at surface [K] + real(r8), intent(in) :: scv ! snow cover, water equivalent [mm] + real(r8), intent(in) :: scvold ! snow cover for previous time step [mm] + real(r8), intent(inout) :: sag ! non dimensional snow age [-] - REAL(r8) sasdir ! snow alb for direct rad 0.2-0.7 micro-ms - REAL(r8) saldir ! snow alb for direct rad 0.7-5.0 micro-ms - REAL(r8) sasdif ! snow alb for diffuse rad 0.2-0.7 micro-ms - REAL(r8) saldif ! snow alb for diffuse rad 0.7-5.0 micro-ms +!-------------------------- Local variables ---------------------------- - REAL(r8), parameter :: asices = 0.70 ! sea ice albedo for 0.2-0.7 micro-meters [-] - REAL(r8), parameter :: asicel = 0.50 ! sea ice albedo for 0.7-5.0 micro-meters [-] - REAL(r8), parameter :: asnows = 0.95 ! snow albedo for 0.2-0.7 micro-meters [-] - REAL(r8), parameter :: asnowl = 0.70 ! snow albedo for 0.7-5.0 micro-meters + real(r8) :: age1 ! snow aging factor due to crystal growth [-] + real(r8) :: age2 ! snow aging factor due to surface growth [-] + real(r8) :: age3 ! snow aging factor due to accum of other particles [-] + real(r8) :: arg ! temporary variable used in snow age calculation [-] + real(r8) :: arg2 ! temporary variable used in snow age calculation [-] + real(r8) :: dela ! temporary variable used in snow age calculation [-] + real(r8) :: dels ! temporary variable used in snow age calculation [-] + real(r8) :: sge ! temporary variable used in snow age calculation [-] !----------------------------------------------------------------------- -! initialize all ocean/sea ice surface albedos to zero - - alb(:,:) = 0. - IF(coszrs<=0.0) RETURN - - IF(nint(oro)==2)THEN - alb(1,1) = asices - alb(2,1) = asicel - alb(1,2) = alb(1,1) - alb(2,2) = alb(2,1) - sasdif = asnows - saldif = asnowl - - IF(scv>0.)THEN - IF (coszrs<0.5) THEN - ! zenith angle regime 1 ( coszrs < 0.5 ). - ! set direct snow albedos (limit to 0.98 max) - sasdir = min(0.98,sasdif+(1.-sasdif)*0.5*(3./(1.+4.*coszrs)-1.)) - saldir = min(0.98,saldif+(1.-saldif)*0.5*(3./(1.+4.*coszrs)-1.)) - ELSE - ! zenith angle regime 2 ( coszrs >= 0.5 ) - sasdir = asnows - saldir = asnowl - ENDIF - - ! compute both diffuse and direct total albedos - snwhgt = 20.*scv / 1000. - rghsnw = 0.25 - frsnow = snwhgt/(rghsnw+snwhgt) - alb(1,1) = alb(1,1)*(1.-frsnow) + sasdir*frsnow - alb(2,1) = alb(2,1)*(1.-frsnow) + saldir*frsnow - alb(1,2) = alb(1,2)*(1.-frsnow) + sasdif*frsnow - alb(2,2) = alb(2,2)*(1.-frsnow) + saldif*frsnow - ENDIF - ENDIF - -! ice-free ocean albedos function of solar zenith angle only, and -! independent of spectral interval: + IF(scv <= 0.) THEN + sag = 0. +! +! Over antarctica +! + ELSE IF (scv > 800.) THEN + sag = 0. +! +! Away from antarctica +! + ELSE + age3 = 0.3 + arg = 5.e3*(1./tfrz-1./tg) + arg2 = min(0.,10.*arg) + age2 = exp(arg2) + age1 = exp(arg) + dela = 1.e-6*deltim*(age1+age2+age3) + dels = 0.1*max(0.0,scv-scvold) + sge = (sag+dela)*(1.0-dels) + sag = max(0.0,sge) + ENDIF - IF(nint(oro)==0)THEN - alb(2,1) = .026/(coszrs**1.7+.065) & - + .15*(coszrs-0.1)*(coszrs-0.5)*(coszrs-1.) - alb(1,1) = alb(2,1) - alb(1,2) = 0.06 - alb(2,2) = 0.06 - ENDIF + END SUBROUTINE snowage - END SUBROUTINE albocean - subroutine SnowAlbedo( use_snicar_frc,use_snicar_ad ,coszen_col ,& + SUBROUTINE SnowAlbedo( use_snicar_frc,use_snicar_ad ,coszen_col ,& albsod ,albsoi ,snl ,frac_sno ,& h2osno ,h2osno_liq ,h2osno_ice ,snw_rds ,& @@ -1372,7 +1335,7 @@ subroutine SnowAlbedo( use_snicar_frc,use_snicar_ad ,coszen_col ,& !----------------------------------------------------------------------- ! !USES: USE MOD_Vars_Global, only: maxsnl - use MOD_SnowSnicar, only: SNICAR_RT, SNICAR_AD_RT + USE MOD_SnowSnicar, only: SNICAR_RT, SNICAR_AD_RT ! and the evolution of snow effective radius ! @@ -1387,47 +1350,47 @@ subroutine SnowAlbedo( use_snicar_frc,use_snicar_ad ,coszen_col ,& integer, parameter :: sno_nbr_aer = 8 ! number of aerosol species in snowpack logical, parameter :: DO_SNO_OC = .true. ! parameter to include organic carbon (OC) logical, parameter :: DO_SNO_AER = .true. ! parameter to include aerosols in snowpack radiative calculations - integer, parameter :: subgridflag = 1 ! = 0 use subgrid fluxes, = 1 not use subgrid fluxes + integer, parameter :: subgridflag = 1 ! = 0 USE subgrid fluxes, = 1 not USE subgrid fluxes ! ! !ARGUMENTS: ! - logical , INTENT(in) :: use_snicar_frc ! true: if radiative forcing is being calculated, first estimate clean-snow albedo - logical , INTENT(in) :: use_snicar_ad ! true: use SNICAR_AD_RT, false: use SNICAR_RT - - real(r8), INTENT(in) :: coszen_col ! cosine of solar zenith angle - real(r8), INTENT(in) :: albsod ( numrad ) ! direct-beam soil albedo (col,bnd) [frc] - real(r8), INTENT(in) :: albsoi ( numrad ) ! diffuse soil albedo (col,bnd) [frc] - - integer , INTENT(in) :: snl ! negative number of snow layers (col) [nbr] - real(r8), INTENT(in) :: frac_sno ! fraction of ground covered by snow (0 to 1) - real(r8), INTENT(in) :: h2osno ! snow water equivalent (mm H2O) - real(r8), INTENT(in) :: h2osno_liq ( maxsnl+1:0 ) ! liquid water content (col,lyr) [kg/m2] - real(r8), INTENT(in) :: h2osno_ice ( maxsnl+1:0 ) ! ice lens content (col,lyr) [kg/m2] - real(r8), INTENT(in) :: snw_rds ( maxsnl+1:0 ) ! snow grain radius (col,lyr) [microns] - - real(r8), INTENT(in) :: mss_cnc_bcphi ( maxsnl+1:0 ) ! mass concentration of hydrophilic BC (col,lyr) [kg/kg] - real(r8), INTENT(in) :: mss_cnc_bcpho ( maxsnl+1:0 ) ! mass concentration of hydrophobic BC (col,lyr) [kg/kg] - real(r8), INTENT(in) :: mss_cnc_ocphi ( maxsnl+1:0 ) ! mass concentration of hydrophilic OC (col,lyr) [kg/kg] - real(r8), INTENT(in) :: mss_cnc_ocpho ( maxsnl+1:0 ) ! mass concentration of hydrophobic OC (col,lyr) [kg/kg] - real(r8), INTENT(in) :: mss_cnc_dst1 ( maxsnl+1:0 ) ! mass concentration of dust aerosol species 1 (col,lyr) [kg/kg] - real(r8), INTENT(in) :: mss_cnc_dst2 ( maxsnl+1:0 ) ! mass concentration of dust aerosol species 2 (col,lyr) [kg/kg] - real(r8), INTENT(in) :: mss_cnc_dst3 ( maxsnl+1:0 ) ! mass concentration of dust aerosol species 3 (col,lyr) [kg/kg] - real(r8), INTENT(in) :: mss_cnc_dst4 ( maxsnl+1:0 ) ! mass concentration of dust aerosol species 4 (col,lyr) [kg/kg] - - real(r8), INTENT(out) :: albgrd ( numrad ) ! ground albedo (direct) - real(r8), INTENT(out) :: albgri ( numrad ) ! ground albedo (diffuse) - real(r8), INTENT(out) :: albgrd_pur ( numrad ) ! pure snow ground albedo (direct) - real(r8), INTENT(out) :: albgri_pur ( numrad ) ! pure snow ground albedo (diffuse) - real(r8), INTENT(out) :: albgrd_bc ( numrad ) ! ground albedo without BC (direct) - real(r8), INTENT(out) :: albgri_bc ( numrad ) ! ground albedo without BC (diffuse) - real(r8), INTENT(out) :: albgrd_oc ( numrad ) ! ground albedo without OC (direct) - real(r8), INTENT(out) :: albgri_oc ( numrad ) ! ground albedo without OC (diffuse) - real(r8), INTENT(out) :: albgrd_dst ( numrad ) ! ground albedo without dust (direct) - real(r8), INTENT(out) :: albgri_dst ( numrad ) ! ground albedo without dust (diffuse) - real(r8), INTENT(out) :: flx_absdv ( maxsnl+1:1 ) ! direct flux absorption factor (col,lyr): VIS [frc] - real(r8), INTENT(out) :: flx_absdn ( maxsnl+1:1 ) ! direct flux absorption factor (col,lyr): NIR [frc] - real(r8), INTENT(out) :: flx_absiv ( maxsnl+1:1 ) ! diffuse flux absorption factor (col,lyr): VIS [frc] - real(r8), INTENT(out) :: flx_absin ( maxsnl+1:1 ) ! diffuse flux absorption factor (col,lyr): NIR [frc] + logical , intent(in) :: use_snicar_frc ! true: IF radiative forcing is being calculated, first estimate clean-snow albedo + logical , intent(in) :: use_snicar_ad ! true: USE SNICAR_AD_RT, false: USE SNICAR_RT + + real(r8), intent(in) :: coszen_col ! cosine of solar zenith angle + real(r8), intent(in) :: albsod ( numrad ) ! direct-beam soil albedo (col,bnd) [frc] + real(r8), intent(in) :: albsoi ( numrad ) ! diffuse soil albedo (col,bnd) [frc] + + integer , intent(in) :: snl ! negative number of snow layers (col) [nbr] + real(r8), intent(in) :: frac_sno ! fraction of ground covered by snow (0 to 1) + real(r8), intent(in) :: h2osno ! snow water equivalent (mm H2O) + real(r8), intent(in) :: h2osno_liq ( maxsnl+1:0 ) ! liquid water content (col,lyr) [kg/m2] + real(r8), intent(in) :: h2osno_ice ( maxsnl+1:0 ) ! ice lens content (col,lyr) [kg/m2] + real(r8), intent(in) :: snw_rds ( maxsnl+1:0 ) ! snow grain radius (col,lyr) [microns] + + real(r8), intent(in) :: mss_cnc_bcphi ( maxsnl+1:0 ) ! mass concentration of hydrophilic BC (col,lyr) [kg/kg] + real(r8), intent(in) :: mss_cnc_bcpho ( maxsnl+1:0 ) ! mass concentration of hydrophobic BC (col,lyr) [kg/kg] + real(r8), intent(in) :: mss_cnc_ocphi ( maxsnl+1:0 ) ! mass concentration of hydrophilic OC (col,lyr) [kg/kg] + real(r8), intent(in) :: mss_cnc_ocpho ( maxsnl+1:0 ) ! mass concentration of hydrophobic OC (col,lyr) [kg/kg] + real(r8), intent(in) :: mss_cnc_dst1 ( maxsnl+1:0 ) ! mass concentration of dust aerosol species 1 (col,lyr) [kg/kg] + real(r8), intent(in) :: mss_cnc_dst2 ( maxsnl+1:0 ) ! mass concentration of dust aerosol species 2 (col,lyr) [kg/kg] + real(r8), intent(in) :: mss_cnc_dst3 ( maxsnl+1:0 ) ! mass concentration of dust aerosol species 3 (col,lyr) [kg/kg] + real(r8), intent(in) :: mss_cnc_dst4 ( maxsnl+1:0 ) ! mass concentration of dust aerosol species 4 (col,lyr) [kg/kg] + + real(r8), intent(out) :: albgrd ( numrad ) ! ground albedo (direct) + real(r8), intent(out) :: albgri ( numrad ) ! ground albedo (diffuse) + real(r8), intent(out) :: albgrd_pur ( numrad ) ! pure snow ground albedo (direct) + real(r8), intent(out) :: albgri_pur ( numrad ) ! pure snow ground albedo (diffuse) + real(r8), intent(out) :: albgrd_bc ( numrad ) ! ground albedo without BC (direct) + real(r8), intent(out) :: albgri_bc ( numrad ) ! ground albedo without BC (diffuse) + real(r8), intent(out) :: albgrd_oc ( numrad ) ! ground albedo without OC (direct) + real(r8), intent(out) :: albgri_oc ( numrad ) ! ground albedo without OC (diffuse) + real(r8), intent(out) :: albgrd_dst ( numrad ) ! ground albedo without dust (direct) + real(r8), intent(out) :: albgri_dst ( numrad ) ! ground albedo without dust (diffuse) + real(r8), intent(out) :: flx_absdv ( maxsnl+1:1 ) ! direct flux absorption factor (col,lyr): VIS [frc] + real(r8), intent(out) :: flx_absdn ( maxsnl+1:1 ) ! direct flux absorption factor (col,lyr): NIR [frc] + real(r8), intent(out) :: flx_absiv ( maxsnl+1:1 ) ! diffuse flux absorption factor (col,lyr): VIS [frc] + real(r8), intent(out) :: flx_absin ( maxsnl+1:1 ) ! diffuse flux absorption factor (col,lyr): NIR [frc] !----------------------------------------------------------------------- ! @@ -1436,7 +1399,7 @@ subroutine SnowAlbedo( use_snicar_frc,use_snicar_ad ,coszen_col ,& integer :: aer ! index for sno_nbr_aer integer :: ib ! band index integer :: ic ! 0=unit incoming direct; 1=unit incoming diffuse - integer :: flg_slr ! flag for SNICAR (=1 if direct, =2 if diffuse) + integer :: flg_slr ! flag for SNICAR (=1 IF direct, =2 IF diffuse) integer :: flg_snw_ice ! flag for SNICAR (=1 when called from ELM, =2 when called from sea-ice) real(r8) :: mss_cnc_aer_in_frc_pur (maxsnl+1:0,sno_nbr_aer) ! mass concentration of aerosol species for forcing calculation (zero) (col,lyr,aer) [kg kg-1] @@ -1466,9 +1429,9 @@ subroutine SnowAlbedo( use_snicar_frc,use_snicar_ad ,coszen_col ,& !----------------------------------------------------------------------- - ! Initialize output because solar radiation only done if coszen > 0 + ! Initialize output because solar radiation only done IF coszen > 0 - do ib = 1, numrad + DO ib = 1, numrad albgrd(ib) = 0._r8 albgri(ib) = 0._r8 albgrd_pur(ib) = 0._r8 @@ -1479,13 +1442,13 @@ subroutine SnowAlbedo( use_snicar_frc,use_snicar_ad ,coszen_col ,& albgri_oc(ib) = 0._r8 albgrd_dst(ib) = 0._r8 albgri_dst(ib) = 0._r8 - do i=maxsnl+1,1,1 + DO i=maxsnl+1,1,1 flx_absdv(i) = 0._r8 flx_absdn(i) = 0._r8 flx_absiv(i) = 0._r8 flx_absin(i) = 0._r8 - enddo - end do ! end of numrad loop + ENDDO + ENDDO ! END of numrad loop ! set variables to pass to SNICAR. @@ -1494,24 +1457,24 @@ subroutine SnowAlbedo( use_snicar_frc,use_snicar_ad ,coszen_col ,& snw_rds_in(:) = nint(snw_rds(:)) ! zero aerosol input arrays - do aer = 1, sno_nbr_aer - do i = maxsnl+1, 0 + DO aer = 1, sno_nbr_aer + DO i = maxsnl+1, 0 mss_cnc_aer_in_frc_pur(i,aer) = 0._r8 mss_cnc_aer_in_frc_bc(i,aer) = 0._r8 mss_cnc_aer_in_frc_oc(i,aer) = 0._r8 mss_cnc_aer_in_frc_dst(i,aer) = 0._r8 mss_cnc_aer_in_fdb(i,aer) = 0._r8 - end do - end do + ENDDO + ENDDO ! If radiative forcing is being calculated, first estimate clean-snow albedo - if (use_snicar_frc) then + IF (use_snicar_frc) THEN ! 1. PURE SNOW ALBEDO CALCULATIONS flg_slr = 1 ! direct-beam - if (use_snicar_ad) then - call SNICAR_AD_RT(flg_snw_ice, & + IF (use_snicar_ad) THEN + CALL SNICAR_AD_RT(flg_snw_ice, & flg_slr, & coszen_col, & snl, & @@ -1524,8 +1487,8 @@ subroutine SnowAlbedo( use_snicar_frc,use_snicar_ad ,coszen_col ,& albsfc(:), & albsnd_pur(:), & foo_snw(:, :) ) - else - call SNICAR_RT(flg_snw_ice, & + ELSE + CALL SNICAR_RT(flg_snw_ice, & flg_slr, & coszen_col, & snl, & @@ -1538,11 +1501,11 @@ subroutine SnowAlbedo( use_snicar_frc,use_snicar_ad ,coszen_col ,& albsfc(:), & albsnd_pur(:), & foo_snw(:, :) ) - endif ! end if use_snicar_ad + ENDIF ! END IF use_snicar_ad flg_slr = 2 ! diffuse - if (use_snicar_ad) then - call SNICAR_AD_RT(flg_snw_ice, & + IF (use_snicar_ad) THEN + CALL SNICAR_AD_RT(flg_snw_ice, & flg_slr, & coszen_col, & snl, & @@ -1555,8 +1518,8 @@ subroutine SnowAlbedo( use_snicar_frc,use_snicar_ad ,coszen_col ,& albsfc(:), & albsni_pur(:), & foo_snw(:, :) ) - else - call SNICAR_RT(flg_snw_ice, & + ELSE + CALL SNICAR_RT(flg_snw_ice, & flg_slr, & coszen_col, & snl, & @@ -1569,14 +1532,14 @@ subroutine SnowAlbedo( use_snicar_frc,use_snicar_ad ,coszen_col ,& albsfc(:), & albsni_pur(:), & foo_snw(:, :) ) - endif ! end if use_snicar_ad + ENDIF ! END IF use_snicar_ad ! 2. BC input array: ! set dust and (optionally) OC concentrations, so BC_FRC=[(BC+OC+dust)-(OC+dust)] - if (DO_SNO_OC) then + IF (DO_SNO_OC) THEN mss_cnc_aer_in_frc_bc(:,3) = mss_cnc_ocphi(:) mss_cnc_aer_in_frc_bc(:,4) = mss_cnc_ocpho(:) - endif + ENDIF mss_cnc_aer_in_frc_bc(:,5) = mss_cnc_dst1(:) mss_cnc_aer_in_frc_bc(:,6) = mss_cnc_dst2(:) mss_cnc_aer_in_frc_bc(:,7) = mss_cnc_dst3(:) @@ -1584,8 +1547,8 @@ subroutine SnowAlbedo( use_snicar_frc,use_snicar_ad ,coszen_col ,& ! BC FORCING CALCULATIONS flg_slr = 1 ! direct-beam - if (use_snicar_ad) then - call SNICAR_AD_RT(flg_snw_ice, & + IF (use_snicar_ad) THEN + CALL SNICAR_AD_RT(flg_snw_ice, & flg_slr, & coszen_col, & snl, & @@ -1598,8 +1561,8 @@ subroutine SnowAlbedo( use_snicar_frc,use_snicar_ad ,coszen_col ,& albsfc(:), & albsnd_bc(:), & foo_snw(:, :) ) - else - call SNICAR_RT (flg_snw_ice, & + ELSE + CALL SNICAR_RT (flg_snw_ice, & flg_slr, & coszen_col, & snl, & @@ -1612,11 +1575,11 @@ subroutine SnowAlbedo( use_snicar_frc,use_snicar_ad ,coszen_col ,& albsfc(:), & albsnd_bc(:), & foo_snw(:, :) ) - endif ! end if use_snicar_ad + ENDIF ! END IF use_snicar_ad flg_slr = 2 ! diffuse - if (use_snicar_ad) then - call SNICAR_AD_RT(flg_snw_ice, & + IF (use_snicar_ad) THEN + CALL SNICAR_AD_RT(flg_snw_ice, & flg_slr, & coszen_col, & snl, & @@ -1629,8 +1592,8 @@ subroutine SnowAlbedo( use_snicar_frc,use_snicar_ad ,coszen_col ,& albsfc(:), & albsni_bc(:), & foo_snw(:, :) ) - else - call SNICAR_RT (flg_snw_ice, & + ELSE + CALL SNICAR_RT (flg_snw_ice, & flg_slr, & coszen_col, & snl, & @@ -1643,11 +1606,11 @@ subroutine SnowAlbedo( use_snicar_frc,use_snicar_ad ,coszen_col ,& albsfc(:), & albsni_bc(:), & foo_snw(:, :) ) - endif ! end if use_snicar_ad + ENDIF ! END IF use_snicar_ad ! 3. OC input array: ! set BC and dust concentrations, so OC_FRC=[(BC+OC+dust)-(BC+dust)] - if (DO_SNO_OC) then + IF (DO_SNO_OC) THEN mss_cnc_aer_in_frc_oc(:,1) = mss_cnc_bcphi(:) mss_cnc_aer_in_frc_oc(:,2) = mss_cnc_bcpho(:) @@ -1658,8 +1621,8 @@ subroutine SnowAlbedo( use_snicar_frc,use_snicar_ad ,coszen_col ,& ! OC FORCING CALCULATIONS flg_slr = 1 ! direct-beam - if (use_snicar_ad) then - call SNICAR_AD_RT(flg_snw_ice, & + IF (use_snicar_ad) THEN + CALL SNICAR_AD_RT(flg_snw_ice, & flg_slr, & coszen_col, & snl, & @@ -1672,8 +1635,8 @@ subroutine SnowAlbedo( use_snicar_frc,use_snicar_ad ,coszen_col ,& albsfc(:), & albsnd_oc(:), & foo_snw(:, :) ) - else - call SNICAR_RT(flg_snw_ice, & + ELSE + CALL SNICAR_RT(flg_snw_ice, & flg_slr, & coszen_col, & snl, & @@ -1686,11 +1649,11 @@ subroutine SnowAlbedo( use_snicar_frc,use_snicar_ad ,coszen_col ,& albsfc(:), & albsnd_oc(:), & foo_snw(:, :) ) - endif ! end if use_snicar_ad + ENDIF ! END IF use_snicar_ad flg_slr = 2 ! diffuse - if (use_snicar_ad) then - call SNICAR_AD_RT(flg_snw_ice, & + IF (use_snicar_ad) THEN + CALL SNICAR_AD_RT(flg_snw_ice, & flg_slr, & coszen_col, & snl, & @@ -1703,8 +1666,8 @@ subroutine SnowAlbedo( use_snicar_frc,use_snicar_ad ,coszen_col ,& albsfc(:), & albsni_oc(:), & foo_snw(:, :) ) - else - call SNICAR_RT(flg_snw_ice, & + ELSE + CALL SNICAR_RT(flg_snw_ice, & flg_slr, & coszen_col, & snl, & @@ -1717,8 +1680,8 @@ subroutine SnowAlbedo( use_snicar_frc,use_snicar_ad ,coszen_col ,& albsfc(:), & albsni_oc(:), & foo_snw(:, :) ) - endif ! end if use_snicar_ad - endif ! end if (DO_SNO_OC) + ENDIF ! END IF use_snicar_ad + ENDIF ! END IF (DO_SNO_OC) ! 4. DUST FORCING CALCULATIONS ! DUST input array: @@ -1726,14 +1689,14 @@ subroutine SnowAlbedo( use_snicar_frc,use_snicar_ad ,coszen_col ,& mss_cnc_aer_in_frc_dst(:,1) = mss_cnc_bcphi(:) mss_cnc_aer_in_frc_dst(:,2) = mss_cnc_bcpho(:) - if (DO_SNO_OC) then + IF (DO_SNO_OC) THEN mss_cnc_aer_in_frc_dst(:,3) = mss_cnc_ocphi(:) mss_cnc_aer_in_frc_dst(:,4) = mss_cnc_ocpho(:) - endif + ENDIF flg_slr = 1 ! direct-beam - if (use_snicar_ad) then - call SNICAR_AD_RT(flg_snw_ice, & + IF (use_snicar_ad) THEN + CALL SNICAR_AD_RT(flg_snw_ice, & flg_slr, & coszen_col, & snl, & @@ -1746,8 +1709,8 @@ subroutine SnowAlbedo( use_snicar_frc,use_snicar_ad ,coszen_col ,& albsfc(:), & albsnd_dst(:), & foo_snw(:, :) ) - else - call SNICAR_RT(flg_snw_ice, & + ELSE + CALL SNICAR_RT(flg_snw_ice, & flg_slr, & coszen_col, & snl, & @@ -1760,11 +1723,11 @@ subroutine SnowAlbedo( use_snicar_frc,use_snicar_ad ,coszen_col ,& albsfc(:), & albsnd_dst(:), & foo_snw(:, :) ) - endif ! end if use_snicar_ad + ENDIF ! END IF use_snicar_ad flg_slr = 2 ! diffuse - if (use_snicar_ad) then - call SNICAR_AD_RT(flg_snw_ice, & + IF (use_snicar_ad) THEN + CALL SNICAR_AD_RT(flg_snw_ice, & flg_slr, & coszen_col, & snl, & @@ -1777,8 +1740,8 @@ subroutine SnowAlbedo( use_snicar_frc,use_snicar_ad ,coszen_col ,& albsfc(:), & albsni_dst(:), & foo_snw(:, :) ) - else - call SNICAR_RT(flg_snw_ice, & + ELSE + CALL SNICAR_RT(flg_snw_ice, & flg_slr, & coszen_col, & snl, & @@ -1791,9 +1754,9 @@ subroutine SnowAlbedo( use_snicar_frc,use_snicar_ad ,coszen_col ,& albsfc(:), & albsni_dst(:), & foo_snw(:, :) ) - endif ! end if use_snicar_ad + ENDIF ! END IF use_snicar_ad - end if !end if use_snicar_frc + ENDIF !END IF use_snicar_frc ! -------------------------------------------- @@ -1802,7 +1765,7 @@ subroutine SnowAlbedo( use_snicar_frc,use_snicar_ad ,coszen_col ,& ! Set aerosol input arrays ! feedback input arrays have been zeroed ! set soot and dust aerosol concentrations: - if (DO_SNO_AER) then + IF (DO_SNO_AER) THEN mss_cnc_aer_in_fdb(:,1) = mss_cnc_bcphi(:) mss_cnc_aer_in_fdb(:,2) = mss_cnc_bcpho(:) @@ -1810,20 +1773,20 @@ subroutine SnowAlbedo( use_snicar_frc,use_snicar_ad ,coszen_col ,& ! 1) Knowledge of their optical properties is primitive ! 2) When 'water-soluble' OPAC optical properties are applied to OC in snow, ! it has a negligible darkening effect. - if (DO_SNO_OC) then + IF (DO_SNO_OC) THEN mss_cnc_aer_in_fdb(:,3) = mss_cnc_ocphi(:) mss_cnc_aer_in_fdb(:,4) = mss_cnc_ocpho(:) - endif + ENDIF mss_cnc_aer_in_fdb(:,5) = mss_cnc_dst1(:) mss_cnc_aer_in_fdb(:,6) = mss_cnc_dst2(:) mss_cnc_aer_in_fdb(:,7) = mss_cnc_dst3(:) mss_cnc_aer_in_fdb(:,8) = mss_cnc_dst4(:) - endif + ENDIF flg_slr = 1 ! direct-beam - if (use_snicar_ad) then - call SNICAR_AD_RT(flg_snw_ice, & + IF (use_snicar_ad) THEN + CALL SNICAR_AD_RT(flg_snw_ice, & flg_slr, & coszen_col, & snl, & @@ -1836,8 +1799,8 @@ subroutine SnowAlbedo( use_snicar_frc,use_snicar_ad ,coszen_col ,& albsfc(:), & albsnd(:), & flx_absd_snw(:, :) ) - else - call SNICAR_RT (flg_snw_ice, & + ELSE + CALL SNICAR_RT (flg_snw_ice, & flg_slr, & coszen_col, & snl, & @@ -1850,11 +1813,11 @@ subroutine SnowAlbedo( use_snicar_frc,use_snicar_ad ,coszen_col ,& albsfc(:), & albsnd(:), & flx_absd_snw(:, :) ) - endif ! end if use_snicar_ad + ENDIF ! END IF use_snicar_ad flg_slr = 2 ! diffuse - if (use_snicar_ad) then - call SNICAR_AD_RT(flg_snw_ice, & + IF (use_snicar_ad) THEN + CALL SNICAR_AD_RT(flg_snw_ice, & flg_slr, & coszen_col, & snl, & @@ -1867,8 +1830,8 @@ subroutine SnowAlbedo( use_snicar_frc,use_snicar_ad ,coszen_col ,& albsfc(:), & albsni(:), & flx_absi_snw(:, :) ) - else - call SNICAR_RT (flg_snw_ice, & + ELSE + CALL SNICAR_RT (flg_snw_ice, & flg_slr, & coszen_col, & snl, & @@ -1881,123 +1844,187 @@ subroutine SnowAlbedo( use_snicar_frc,use_snicar_ad ,coszen_col ,& albsfc(:), & albsni(:), & flx_absi_snw(:, :) ) - endif ! end if use_snicar_ad + ENDIF ! END IF use_snicar_ad ! ground albedos and snow-fraction weighting of snow absorption factors - do ib = 1, nband - if (coszen_col > 0._r8) then + DO ib = 1, nband + IF (coszen_col > 0._r8) THEN ! ground albedo was originally computed in SoilAlbedo, but is now computed here ! because the order of SoilAlbedo and SNICAR_RT/SNICAR_AD_RT was switched for SNICAR/SNICAR_AD_RT. - albgrd(ib) = albsod(ib)*(1._r8-frac_sno) + albsnd(ib)*frac_sno - albgri(ib) = albsoi(ib)*(1._r8-frac_sno) + albsni(ib)*frac_sno + ! 09/01/2023, yuan: change to only snow albedo, the same below + !albgrd(ib) = albsod(ib)*(1._r8-frac_sno) + albsnd(ib)*frac_sno + !albgri(ib) = albsoi(ib)*(1._r8-frac_sno) + albsni(ib)*frac_sno + albgrd(ib) = albsnd(ib) + albgri(ib) = albsni(ib) ! albedos for radiative forcing calculations: - if (use_snicar_frc) then + IF (use_snicar_frc) THEN ! pure snow albedo for all-aerosol radiative forcing - albgrd_pur(ib) = albsod(ib)*(1.-frac_sno) + albsnd_pur(ib)*frac_sno - albgri_pur(ib) = albsoi(ib)*(1.-frac_sno) + albsni_pur(ib)*frac_sno + !albgrd_pur(ib) = albsod(ib)*(1.-frac_sno) + albsnd_pur(ib)*frac_sno + !albgri_pur(ib) = albsoi(ib)*(1.-frac_sno) + albsni_pur(ib)*frac_sno + albgrd_pur(ib) = albsnd_pur(ib) + albgri_pur(ib) = albsni_pur(ib) ! BC forcing albedo - albgrd_bc(ib) = albsod(ib)*(1.-frac_sno) + albsnd_bc(ib)*frac_sno - albgri_bc(ib) = albsoi(ib)*(1.-frac_sno) + albsni_bc(ib)*frac_sno + !albgrd_bc(ib) = albsod(ib)*(1.-frac_sno) + albsnd_bc(ib)*frac_sno + !albgri_bc(ib) = albsoi(ib)*(1.-frac_sno) + albsni_bc(ib)*frac_sno + albgrd_bc(ib) = albsnd_bc(ib) + albgri_bc(ib) = albsni_bc(ib) - if (DO_SNO_OC) then + IF (DO_SNO_OC) THEN ! OC forcing albedo - albgrd_oc(ib) = albsod(ib)*(1.-frac_sno) + albsnd_oc(ib)*frac_sno - albgri_oc(ib) = albsoi(ib)*(1.-frac_sno) + albsni_oc(ib)*frac_sno - endif + !albgrd_oc(ib) = albsod(ib)*(1.-frac_sno) + albsnd_oc(ib)*frac_sno + !albgri_oc(ib) = albsoi(ib)*(1.-frac_sno) + albsni_oc(ib)*frac_sno + albgrd_oc(ib) = albsnd_oc(ib) + albgri_oc(ib) = albsni_oc(ib) + ENDIF ! dust forcing albedo - albgrd_dst(ib) = albsod(ib)*(1.-frac_sno) + albsnd_dst(ib)*frac_sno - albgri_dst(ib) = albsoi(ib)*(1.-frac_sno) + albsni_dst(ib)*frac_sno - end if + !albgrd_dst(ib) = albsod(ib)*(1.-frac_sno) + albsnd_dst(ib)*frac_sno + !albgri_dst(ib) = albsoi(ib)*(1.-frac_sno) + albsni_dst(ib)*frac_sno + albgrd_dst(ib) = albsnd_dst(ib) + albgri_dst(ib) = albsni_dst(ib) + ENDIF ! also in this loop (but optionally in a different loop for vectorized code) ! weight snow layer radiative absorption factors based on snow fraction and soil albedo ! (NEEDED FOR ENERGY CONSERVATION) - do i = maxsnl+1,1,1 - if (subgridflag == 0 ) then - if (ib == 1) then + DO i = maxsnl+1,1,1 + IF (subgridflag == 0 ) THEN + IF (ib == 1) THEN flx_absdv(i) = flx_absd_snw(i,ib)*frac_sno + & ((1.-frac_sno)*(1-albsod(ib))*(flx_absd_snw(i,ib)/(1.-albsnd(ib)))) flx_absiv(i) = flx_absi_snw(i,ib)*frac_sno + & ((1.-frac_sno)*(1-albsoi(ib))*(flx_absi_snw(i,ib)/(1.-albsni(ib)))) - elseif (ib == 2) then + elseif (ib == 2) THEN flx_absdn(i) = flx_absd_snw(i,ib)*frac_sno + & ((1.-frac_sno)*(1-albsod(ib))*(flx_absd_snw(i,ib)/(1.-albsnd(ib)))) flx_absin(i) = flx_absi_snw(i,ib)*frac_sno + & ((1.-frac_sno)*(1-albsoi(ib))*(flx_absi_snw(i,ib)/(1.-albsni(ib)))) - endif - else - if (ib == 1) then + ENDIF + ELSE + IF (ib == 1) THEN flx_absdv(i) = flx_absd_snw(i,ib)*(1.-albsnd(ib)) flx_absiv(i) = flx_absi_snw(i,ib)*(1.-albsni(ib)) - elseif (ib == 2) then + elseif (ib == 2) THEN flx_absdn(i) = flx_absd_snw(i,ib)*(1.-albsnd(ib)) flx_absin(i) = flx_absi_snw(i,ib)*(1.-albsni(ib)) - endif - endif - enddo - endif - enddo + ENDIF + ENDIF + ENDDO + ENDIF + ENDDO - end subroutine SnowAlbedo + END SUBROUTINE SnowAlbedo - subroutine snowage ( deltim,tg,scv,scvold,sag ) -!======================================================================= -! Original version: Robert Dickinson -! Update snow cover and snow age, based on BATS code -!======================================================================= + SUBROUTINE albocean (oro, scv, coszrs, alb) - use MOD_Precision - use MOD_Const_Physical, only : tfrz - implicit none +!----------------------------------------------------------------------- +! +! Compute surface albedos +! +! Computes surface albedos for direct/diffuse incident radiation for +! two spectral intervals: +! s = 0.2-0.7 micro-meters +! l = 0.7-5.0 micro-meters +! +! Albedos specified as follows: +! +! Ocean Uses solar zenith angle to compute albedo for direct +! radiation; diffuse radiation values constant; albedo +! independent of spectral interval and other physical +! factors such as ocean surface wind speed. +! +! Ocean with Surface albs specified; combined with overlying snow +! sea ice +! +! For more details , see Briegleb, Bruce P., 1992: Delta-Eddington +! Approximation for Solar Radiation in the NCAR Community Climate Model, +! Journal of Geophysical Research, Vol 97, D7, pp7603-7612). +! +! yongjiu dai and xin-zhong liang (08/01/2001) +!----------------------------------------------------------------------- -!-------------------------- Dummy Argument ----------------------------- + USE MOD_Precision + IMPLICIT NONE - real(r8), INTENT(in) :: deltim ! seconds in a time step [second] - real(r8), INTENT(in) :: tg ! temperature of soil at surface [K] - real(r8), INTENT(in) :: scv ! snow cover, water equivalent [mm] - real(r8), INTENT(in) :: scvold ! snow cover for previous time step [mm] - real(r8), INTENT(inout) :: sag ! non dimensional snow age [-] +!------------------------------Arguments-------------------------------- -!-------------------------- Local variables ---------------------------- + real(r8), intent(in) :: oro ! /ocean(0)/seaice(2) flag + real(r8), intent(in) :: scv ! snow water equivalent) [mm] + real(r8), intent(in) :: coszrs ! Cosine solar zenith angle - real(r8) :: age1 ! snow aging factor due to crystal growth [-] - real(r8) :: age2 ! snow aging factor due to surface growth [-] - real(r8) :: age3 ! snow aging factor due to accum of other particles [-] - real(r8) :: arg ! temporary variable used in snow age calculation [-] - real(r8) :: arg2 ! temporary variable used in snow age calculation [-] - real(r8) :: dela ! temporary variable used in snow age calculation [-] - real(r8) :: dels ! temporary variable used in snow age calculation [-] - real(r8) :: sge ! temporary variable used in snow age calculation [-] + real(r8), intent(out) :: alb(2,2) ! srf alb for direct (diffuse) rad 0.2-0.7 micro-ms + ! Srf alb for direct (diffuse) rad 0.7-5.0 micro-ms + +!---------------------------Local variables----------------------------- + + real(r8) frsnow ! horizontal fraction of snow cover + real(r8) snwhgt ! physical snow height + real(r8) rghsnw ! roughness for horizontal snow cover fractn + + real(r8) sasdir ! snow alb for direct rad 0.2-0.7 micro-ms + real(r8) saldir ! snow alb for direct rad 0.7-5.0 micro-ms + real(r8) sasdif ! snow alb for diffuse rad 0.2-0.7 micro-ms + real(r8) saldif ! snow alb for diffuse rad 0.7-5.0 micro-ms + + real(r8), parameter :: asices = 0.70 ! sea ice albedo for 0.2-0.7 micro-meters [-] + real(r8), parameter :: asicel = 0.50 ! sea ice albedo for 0.7-5.0 micro-meters [-] + real(r8), parameter :: asnows = 0.95 ! snow albedo for 0.2-0.7 micro-meters [-] + real(r8), parameter :: asnowl = 0.70 ! snow albedo for 0.7-5.0 micro-meters !----------------------------------------------------------------------- - if(scv <= 0.) then - sag = 0. -! -! Over antarctica -! - else if (scv > 800.) then - sag = 0. -! -! Away from antarctica -! - else - age3 = 0.3 - arg = 5.e3*(1./tfrz-1./tg) - arg2 = min(0.,10.*arg) - age2 = exp(arg2) - age1 = exp(arg) - dela = 1.e-6*deltim*(age1+age2+age3) - dels = 0.1*max(0.0,scv-scvold) - sge = (sag+dela)*(1.0-dels) - sag = max(0.0,sge) - end if +! initialize all ocean/sea ice surface albedos to zero + + alb(:,:) = 0. + IF(coszrs<=0.0) RETURN + + IF(nint(oro)==2)THEN + alb(1,1) = asices + alb(2,1) = asicel + alb(1,2) = alb(1,1) + alb(2,2) = alb(2,1) + sasdif = asnows + saldif = asnowl + + IF(scv>0.)THEN + IF (coszrs<0.5) THEN + ! zenith angle regime 1 ( coszrs < 0.5 ). + ! set direct snow albedos (limit to 0.98 max) + sasdir = min(0.98,sasdif+(1.-sasdif)*0.5*(3./(1.+4.*coszrs)-1.)) + saldir = min(0.98,saldif+(1.-saldif)*0.5*(3./(1.+4.*coszrs)-1.)) + ELSE + ! zenith angle regime 2 ( coszrs >= 0.5 ) + sasdir = asnows + saldir = asnowl + ENDIF + + ! compute both diffuse and direct total albedos + snwhgt = 20.*scv / 1000. + rghsnw = 0.25 + frsnow = snwhgt/(rghsnw+snwhgt) + alb(1,1) = alb(1,1)*(1.-frsnow) + sasdir*frsnow + alb(2,1) = alb(2,1)*(1.-frsnow) + saldir*frsnow + alb(1,2) = alb(1,2)*(1.-frsnow) + sasdif*frsnow + alb(2,2) = alb(2,2)*(1.-frsnow) + saldif*frsnow + ENDIF + ENDIF + +! ice-free ocean albedos function of solar zenith angle only, and +! independent of spectral interval: + + IF(nint(oro)==0)THEN + alb(2,1) = .026/(coszrs**1.7+.065) & + + .15*(coszrs-0.1)*(coszrs-0.5)*(coszrs-1.) + alb(1,1) = alb(2,1) + alb(1,2) = 0.06 + alb(2,2) = 0.06 + ENDIF + + END SUBROUTINE albocean - end subroutine snowage END MODULE MOD_Albedo ! --------- EOP ---------- diff --git a/main/MOD_AssimStomataConductance.F90 b/main/MOD_AssimStomataConductance.F90 index e1f1657a..040c3fc4 100644 --- a/main/MOD_AssimStomataConductance.F90 +++ b/main/MOD_AssimStomataConductance.F90 @@ -4,14 +4,17 @@ MODULE MOD_AssimStomataConductance !----------------------------------------------------------------------- use MOD_Precision + use MOD_Namelist IMPLICIT NONE SAVE ! PUBLIC MEMBER FUNCTIONS: public :: stomata + public :: update_photosyn ! PRIVATE MEMBER FUNCTIONS: private :: sortin + private :: calc_photo_params !----------------------------------------------------------------------- @@ -23,7 +26,7 @@ MODULE MOD_AssimStomataConductance subroutine stomata (vmax25,effcon,slti,hlti,shti, & - hhti,trda,trdm,trop,gradm,binter,tm, & + hhti,trda,trdm,trop,g1,g0,gradm,binter,tm, & psrf,po2m,pco2m,pco2a,ea,ei,tlef,par & !Ozone stress variables ,o3coefv,o3coefg & @@ -76,15 +79,16 @@ subroutine stomata (vmax25,effcon,slti,hlti,shti, & real(r8),intent(in) :: & effcon, &! quantum efficiency of RuBP regeneration (mol CO2 / mol quanta) vmax25, &! maximum carboxylation rate at 25 C at canopy top - ! the range : 30.e-6 <-> 100.e-6 (mol co2 m-2 s-1) + trop, &! temperature coefficient in gs-a model (298.16) slti, &! slope of low temperature inhibition function (0.2) hlti, &! 1/2 point of low temperature inhibition function (288.16) shti, &! slope of high temperature inhibition function (0.3) hhti, &! 1/2 point of high temperature inhibition function (313.16) trda, &! temperature coefficient in gs-a model (1.3) trdm, &! temperature coefficient in gs-a model (328.16) - trop, &! temperature coefficient in gs-a model (298.16) + g1, &! conductance-photosynthesis slope parameter for medlyn model + g0, &! conductance-photosynthesis intercept for medlyn model gradm, &! conductance-photosynthesis slope parameter binter ! conductance-photosynthesis intercept @@ -121,27 +125,19 @@ subroutine stomata (vmax25,effcon,slti,hlti,shti, & integer, parameter :: iterationtotal = 6 ! total iteration number in pco2i calculation - real(r8) c3, &! c3 vegetation : 1; 0 for c4 + real(r8) & + c3, &! c3 vegetation : 1; 0 for c4 c4, &! c4 vegetation : 1; 0 for c3 - qt, &! (tleaf - 298.16) / 10 - kc, &! Michaelis-Menten constant for co2 - ko, &! Michaelis-Menten constant for o2 rrkk, &! kc (1+o2/ko) - templ, &! intermediate value - temph, &! intermediate value - vm, &! maximum catalytic activity of Rubison (mol co2 m-2 s-1) - jmax25, &! potential rate of whole-chain electron transport at 25 C - jmax, &! potential rate of whole-chain electron transport (mol electron m-2 s-1) epar, &! electron transport rate (mol electron m-2 s-1) - respcp, &! respiration fraction of vmax (mol co2 m-2 s-1) bintc, &! residual stomatal conductance for co2 (mol co2 m-2 s-1) + acp, &! temporary variable for stomata model (mol co2 m-2 s-1) + vpd, &! vapor pressure deficit (kpa) - rgas, &! universal gas contant (8.314 J mol-1 K-1) tprcor, &! coefficient for unit transfer gbh2o, &! one side leaf boundary layer conductance (mol m-2 s-1) - gah2o, &! aerodynamic conductance between cas and reference height (mol m-2 s-1) gsh2o, &! canopy conductance (mol m-2 s-1) atheta, &! wc, we coupling parameter @@ -176,96 +172,19 @@ subroutine stomata (vmax25,effcon,slti,hlti,shti, & integer ic -!======================================================================= - - c3 = 0. - if( effcon .gt. 0.07 ) c3 = 1. - c4 = 1. - c3 - -!----------------------------------------------------------------------- -! dependence on leaf temperature -! gammas - CO2 compensation point in the absence of day respiration -! ko - Michaelis-Menton constant for carboxylation by Rubisco -! kc - Michaelis-Menton constant for oxygenation by Rubisco -!----------------------------------------------------------------------- - - qt = 0.1*( tlef - trop ) - - kc = 30. * 2.1**qt - ko = 30000. * 1.2**qt - gammas = 0.5 * po2m / (2600. * 0.57**qt) * c3 ! = 0. for c4 plant ??? - - rrkk = kc * ( 1. + po2m/ko ) * c3 - -!---------------------------------------------------------------------- -! maximun capacity -! vm - maximum catalytic activity of Rubisco in the presence of -! saturating level of RuP2 and CO2 (mol m-2s-1) -! jmax - potential rate of whole-chain electron transport (mol m-2s-1) -! epar - electron transport rate for a given absorbed photon radiation -! respc - dark resipration (mol m-2s-1) -! omss - capacity of the leaf to export or utilize the products of photosynthesis. -! binter - coefficient from observation, 0.01 for c3 plant, 0.04 for c4 plant -!----------------------------------------------------------------------- - - vm = vmax25 * 2.1**qt ! (mol m-2 s-1) - templ = 1. + exp(slti*(hlti-tlef)) - temph = 1. + exp(shti*(tlef-hhti)) - vm = vm / temph * rstfac * c3 + vm / (templ*temph) * rstfac * c4 - vm = vm * cint(1) - - rgas = 8.314467591 ! universal gas constant (J mol-1 K-1) -!---> jmax25 = 2.39 * vmax25 - 14.2e-6 ! (mol m-2 s-1) -!---> jmax25 = 2.1 * vmax25 ! (mol m-2 s-1) -!/05/2014/ - jmax25 = 1.97 * vmax25 ! (mol m-2 s-1) - jmax = jmax25 * exp( 37.e3 * (tlef - trop) / (rgas*trop*tlef) ) * & - ( 1. + exp( (710.*trop-220.e3)/(rgas*trop) ) ) / & - ( 1. + exp( (710.*tlef-220.e3)/(rgas*tlef) ) ) - ! 37000 (J mol-1) - ! 220000 (J mol-1) - ! 710 (J K-1) - - jmax = jmax * rstfac - jmax = jmax * cint(2) - -!---> epar = min(4.6e-6 * par * effcon, 0.25*jmax) -! /05/2014/ - epar = min(4.6e-6 * par * effcon, jmax) - - respcp = 0.015 * c3 + 0.025 * c4 - respc = respcp * vmax25 * 2.0**qt / ( 1. + exp( trda*(tlef-trdm )) ) * rstfac -! respc = 0.7e-6 * 2.0**qt / ( 1. + exp( trda*(tlef-trdm )) ) * rstfac - respc = respc * cint(1) - - omss = ( vmax25/2. ) * (1.8**qt) / templ * rstfac * c3 & - + ( vmax25/5. ) * (1.8**qt) * rstfac * c4 - omss = omss * cint(1) + call calc_photo_params(tlef, po2m, par , psrf, rstfac, rb, effcon, vmax25, & + trop, slti, hlti, shti, hhti, trda, trdm, cint, & + vm, epar, respc, omss, gbh2o, gammas, rrkk, c3, c4) bintc = binter * max( 0.1, rstfac ) bintc = bintc * cint(3) -!----------------------------------------------------------------------- - tprcor = 44.6*273.16*psrf/1.013e5 - -! one side leaf boundary layer conductance for water vapor [=1/(2*rb)] -! ATTENTION: rb in CLM is for one side leaf, but for SiB2 rb for -! 2-side leaf, so the gbh2o shold be " 0.5/rb * tprcor/tlef " -! gbh2o = 0.5/rb * tprcor/tlef ! mol m-2 s-1 - gbh2o = 1./rb * tprcor/tlef ! mol m-2 s-1 - -! rb is for single leaf, but here the flux is for canopy, thus - ! Xingjie Lu: rb has already been converted to canopy scale, - ! thus, there is no need for gbh2o *cint(3) (sunlit/shaded LAI) -! gbh2o = gbh2o * cint(3) - -! aerodynamic condutance between canopy and reference height atmosphere - gah2o = 1.0/ra * tprcor/tm ! mol m-2 s-1 - !----------------------------------------------------------------------- ! first guess is midway between compensation point and maximum ! assimilation rate. ! pay attention on this iteration + tprcor = 44.6*273.16*psrf/1.013e5 + co2m = pco2m/psrf ! mol mol-1 co2a = pco2a/psrf @@ -351,27 +270,38 @@ subroutine stomata (vmax25,effcon,slti,hlti,shti, & ! !----------------------------------------------------------------------- -!--> co2a = co2m - 1.37/max(0.446,gah2o) * (assimn - 0.) ! mol mol-1 co2s = co2a - 1.37*assimn/gbh2o ! mol mol-1 co2st = min( co2s, co2a ) co2st = max( co2st,1.e-5 ) assmt = max( 1.e-12, assimn ) - hcdma = ei*co2st / ( gradm*assmt ) - - aquad = hcdma - bquad = gbh2o*hcdma - ei - bintc*hcdma - cquad = -gbh2o*( ea + hcdma*bintc ) - - sqrtin= max( 0., ( bquad**2 - 4.*aquad*cquad ) ) - gsh2o = ( -bquad + sqrt ( sqrtin ) ) / (2.*aquad) - - es = ( gsh2o-bintc ) * hcdma ! pa - es = min( es, ei ) - es = max( es, 1.e-2) - - gsh2o = es/hcdma + bintc ! mol m-2 s-1 + if(DEF_USE_MEDLYNST)then + vpd = amax1((ei - ea),50._r8) * 1.e-3 ! in kpa + acp = 1.6*assmt/co2st ! in mol m-2 s-1 + aquad = 1._r8 + bquad = -2*(g0*1.e-6 + acp) - (g1*acp)**2/(gbh2o*vpd) ! in mol m-2 s-1 + cquad = (g0*1.e-6)**2 + (2*g0*1.e-6+acp*(1-g1**2)/vpd)*acp ! in (mol m-2 s-1)**2 + + sqrtin= max( 0., ( bquad**2 - 4.*aquad*cquad ) ) + gsh2o = ( -bquad + sqrt ( sqrtin ) ) / (2.*aquad) + + else + hcdma = ei*co2st / ( gradm*assmt ) + + aquad = hcdma + bquad = gbh2o*hcdma - ei - bintc*hcdma + cquad = -gbh2o*( ea + hcdma*bintc ) + + sqrtin= max( 0., ( bquad**2 - 4.*aquad*cquad ) ) + gsh2o = ( -bquad + sqrt ( sqrtin ) ) / (2.*aquad) + + es = ( gsh2o-bintc ) * hcdma ! pa + es = min( es, ei ) + es = max( es, 1.e-2) + + gsh2o = es/hcdma + bintc ! mol m-2 s-1 + end if pco2in = ( co2s - 1.6 * assimn / gsh2o )*psrf ! pa eyy(ic) = pco2i - pco2in ! pa @@ -484,7 +414,317 @@ subroutine sortin( eyy, pco2y, range, gammas, ic, iterationtotal ) end subroutine sortin + subroutine calc_photo_params(tlef, po2m, par , psrf, rstfac, rb, effcon, vmax25, & + trop, slti, hlti, shti, hhti, trda, trdm, cint, & + vm, epar, respc, omss, gbh2o, gammas, rrkk, c3, c4) + + use MOD_Precision + IMPLICIT NONE + + real(r8),intent(in) :: & + tlef, &! leaf temperature (K) + po2m, &! O2 concentration in atmos. (pascals) + par, &! photosynthetic active radiation (W m-2) + rstfac, &! canopy resistance stress factors to soil moisture + rb, &! boundary resistance from canopy to cas (s m-1) + + effcon, &! quantum efficiency of RuBP regeneration (mol CO2 / mol quanta) + vmax25, &! maximum carboxylation rate at 25 C at canopy top + ! the range : 30.e-6 <-> 100.e-6 (mol co2 m-2 s-1) + trop, &! temperature coefficient in gs-a model (298.16) + slti, &! slope of low temperature inhibition function (0.2) + hlti, &! 1/2 point of low temperature inhibition function (288.16) + shti, &! slope of high temperature inhibition function (0.3) + hhti, &! 1/2 point of high temperature inhibition function (313.16) + trda, &! temperature coefficient in gs-a model (1.3) + trdm, &! temperature coefficient in gs-a model (328.16) + psrf ! surface atmospheric pressure (pa) + + real(r8),intent(in), dimension(3) :: & + cint ! scaling up from leaf to canopy + + real(r8),intent(out) :: & + vm, &! maximum catalytic activity of Rubison (mol co2 m-2 s-1) + epar, &! electron transport rate (mol electron m-2 s-1) + respc, &! canopy respiration (mol m-2 s-1) + omss, &! intermediate calcuation for oms + gbh2o, &! one side leaf boundary layer conductance (mol m-2 s-1) + gammas, &! CO2 compensation point + rrkk, &! kc (1+o2/ko) + c3, &! c3 vegetation : 1; 0 for c4 + c4 ! c4 vegetation : 1; 0 for c3 + + real(r8) :: & + qt, &! (tleaf - 298.16) / 10 + kc, &! Michaelis-Menten constant for co2 + ko, &! Michaelis-Menten constant for o2 + templ, &! intermediate value + temph, &! intermediate value + rgas, &! universal gas contant (8.314 J mol-1 K-1) + jmax25, &! potential rate of whole-chain electron transport at 25 C + jmax, &! potential rate of whole-chain electron transport (mol electron m-2 s-1) + respcp, &! respiration fraction of vmax (mol co2 m-2 s-1) + tprcor ! coefficient for unit transfer + +!======================================================================= + + c3 = 0. + if( effcon .gt. 0.07 ) c3 = 1. + c4 = 1. - c3 + +!----------------------------------------------------------------------- +! dependence on leaf temperature +! gammas - CO2 compensation point in the absence of day respiration +! ko - Michaelis-Menton constant for carboxylation by Rubisco +! kc - Michaelis-Menton constant for oxygenation by Rubisco +!----------------------------------------------------------------------- + + qt = 0.1*( tlef - trop ) + + kc = 30. * 2.1**qt + ko = 30000. * 1.2**qt + gammas = 0.5 * po2m / (2600. * 0.57**qt) * c3 ! = 0. for c4 plant ??? + + rrkk = kc * ( 1. + po2m/ko ) * c3 + +!---------------------------------------------------------------------- +! maximun capacity +! vm - maximum catalytic activity of Rubisco in the presence of +! saturating level of RuP2 and CO2 (mol m-2s-1) +! jmax - potential rate of whole-chain electron transport (mol m-2s-1) +! epar - electron transport rate for a given absorbed photon radiation +! respc - dark resipration (mol m-2s-1) +! omss - capacity of the leaf to export or utilize the products of photosynthesis. +! binter - coefficient from observation, 0.01 for c3 plant, 0.04 for c4 plant +!----------------------------------------------------------------------- + + vm = vmax25 * 2.1**qt ! (mol m-2 s-1) + templ = 1. + exp(slti*(hlti-tlef)) + temph = 1. + exp(shti*(tlef-hhti)) + vm = vm / temph * rstfac * c3 + vm / (templ*temph) * rstfac * c4 + vm = vm * cint(1) + + rgas = 8.314467591 ! universal gas constant (J mol-1 K-1) +!---> jmax25 = 2.39 * vmax25 - 14.2e-6 ! (mol m-2 s-1) +!---> jmax25 = 2.1 * vmax25 ! (mol m-2 s-1) +!/05/2014/ + jmax25 = 1.97 * vmax25 ! (mol m-2 s-1) + jmax = jmax25 * exp( 37.e3 * (tlef - trop) / (rgas*trop*tlef) ) * & + ( 1. + exp( (710.*trop-220.e3)/(rgas*trop) ) ) / & + ( 1. + exp( (710.*tlef-220.e3)/(rgas*tlef) ) ) + ! 37000 (J mol-1) + ! 220000 (J mol-1) + ! 710 (J K-1) + + jmax = jmax * rstfac + jmax = jmax * cint(2) + +!---> epar = min(4.6e-6 * par * effcon, 0.25*jmax) +! /05/2014/ + epar = min(4.6e-6 * par * effcon, jmax) + + respcp = 0.015 * c3 + 0.025 * c4 + respc = respcp * vmax25 * 2.0**qt / ( 1. + exp( trda*(tlef-trdm )) ) * rstfac +! respc = 0.7e-6 * 2.0**qt / ( 1. + exp( trda*(tlef-trdm )) ) * rstfac + respc = respc * cint(1) + + omss = ( vmax25/2. ) * (1.8**qt) / templ * rstfac * c3 & + + ( vmax25/5. ) * (1.8**qt) * rstfac * c4 + omss = omss * cint(1) + +!----------------------------------------------------------------------- + tprcor = 44.6*273.16*psrf/1.013e5 + +! one side leaf boundary layer conductance for water vapor [=1/(2*rb)] +! ATTENTION: rb in CLM is for one side leaf, but for SiB2 rb for +! 2-side leaf, so the gbh2o shold be " 0.5/rb * tprcor/tlef " +! gbh2o = 0.5/rb * tprcor/tlef ! mol m-2 s-1 + gbh2o = 1./rb * tprcor/tlef ! mol m-2 s-1 + +! rb is for single leaf, but here the flux is for canopy, thus + ! Xingjie Lu: rb has already been converted to canopy scale, + ! thus, there is no need for gbh2o *cint(3) (sunlit/shaded LAI) +! gbh2o = gbh2o * cint(3) + + end subroutine calc_photo_params + + subroutine update_photosyn(tlef, po2m, pco2m, pco2a, par, psrf, rstfac, rb, gsh2o, & + effcon, vmax25, gradm, trop, slti, hlti, shti, hhti, trda, trdm, cint, & + assim, respc) + + use MOD_Precision + IMPLICIT NONE + + real(r8),intent(in) :: & + tlef, &! leaf temperature (K) + po2m, &! O2 concentration in atmos. (pascals) + pco2m, &! CO2 concentration in atmos. (pascals) + pco2a, &! CO2 concentration in canopy air space (pa) + par, &! photosynthetic active radiation (W m-2) + psrf, &! surface atmospheric pressure (pa) + rstfac, &! canopy resistance stress factors to soil moisture + rb, &! boundary resistance from canopy to cas (s m-1) + gsh2o, &! canopy conductance (mol m-2 s-1) + + effcon, &! quantum efficiency of RuBP regeneration (mol CO2 / mol quanta) + vmax25, &! maximum carboxylation rate at 25 C at canopy top + ! the range : 30.e-6 <-> 100.e-6 (mol co2 m-2 s-1) + gradm, &! conductance-photosynthesis slope parameter + trop, &! temperature coefficient in gs-a model (298.16) + slti, &! slope of low temperature inhibition function (0.2) + hlti, &! 1/2 point of low temperature inhibition function (288.16) + shti, &! slope of high temperature inhibition function (0.3) + hhti, &! 1/2 point of high temperature inhibition function (313.16) + trda, &! temperature coefficient in gs-a model (1.3) + trdm ! temperature coefficient in gs-a model (328.16) + + real(r8),intent(in), dimension(3) :: & + cint ! scaling up from leaf to canopy + + real(r8),intent(out) :: & + assim, &! canopy assimilation rate (mol m-2 s-1) + respc ! canopy respiration (mol m-2 s-1) + + real(r8) :: & + vm, &! maximum catalytic activity of Rubison (mol co2 m-2 s-1) + epar, &! electron transport rate (mol electron m-2 s-1) + gbh2o, &! one side leaf boundary layer conductance (mol m-2 s-1) + gammas, &! CO2 compensation point + rrkk, &! kc (1+o2/ko) + c3, &! c3 vegetation : 1; 0 for c4 + c4 ! c4 vegetation : 1; 0 for c3 + + real(r8) :: & + atheta, &! wc, we coupling parameter + btheta, &! wc & we, ws coupling parameter + omss, &! intermediate calcuation for oms + omc, &! rubisco limited assimilation (omega-c: mol m-2 s-1) + ome, &! light limited assimilation (omega-e: mol m-2 s-1) + oms, &! sink limited assimilation (omega-s: mol m-2 s-1) + omp, &! intermediate calcuation for omc, ome + + co2a, &! co2 concentration at cas (mol mol-1) + co2s, &! co2 concentration at canopy surface (mol mol-1) + co2st, &! co2 concentration at canopy surface (mol mol-1) + co2i, &! internal co2 concentration (mol mol-1) + pco2in, &! internal co2 concentration at the new iteration (pa) + pco2i, &! internal co2 concentration (pa) + es, &! canopy surface h2o vapor pressure (pa) + + sqrtin, &! intermediate calculation for quadratic + assmt, &! net assimilation with a positive limitation (mol co2 m-2 s-1) + assimn ! net assimilation (mol co2 m-2 s-1) + + integer, parameter :: iterationtotal = 6 ! total iteration number in pco2i calculation + + real(r8) :: & + eyy(iterationtotal), &! differnce of pco2i at two iteration step + pco2y(iterationtotal), &! adjusted to total iteration number + range ! + + integer ic + + call calc_photo_params(tlef, po2m, par , psrf, rstfac, rb, effcon, vmax25, & + trop, slti, hlti, shti, hhti, trda, trdm, cint, & + vm, epar, respc, omss, gbh2o, gammas, rrkk, c3, c4) + + co2a = pco2a/psrf + + range = pco2m * ( 1. - 1.6/gradm ) - gammas + + do ic = 1, iterationtotal ! loop for total iteration number + pco2y(ic) = 0. + eyy(ic) = 0. + enddo + + ITERATION_LOOP_UPDATE: do ic = 1, iterationtotal + + call sortin(eyy, pco2y, range, gammas, ic, iterationtotal) + pco2i = pco2y(ic) + +!----------------------------------------------------------------------- +! NET ASSIMILATION +! the leaf assimilation (or gross photosynthesis) rate is described +! as the minimum of three limiting rates: +! omc: the efficiency of the photosynthetic enzyme system (Rubisco-limited); +! ome: the amount of PAR captured by leaf chlorophyll; +! oms: the capacity of the leaf to export or utilize the products of photosynthesis. +! to aviod the abrupt transitions, two quadratic equations are used: +! atheta*omp^2 - omp*(omc+ome) + omc*ome = 0 +! btheta*assim^2 - assim*(omp+oms) + omp*oms = 0 +!----------------------------------------------------------------------- + + atheta = 0.877 + btheta = 0.95 + + omc = vm * ( pco2i-gammas ) / ( pco2i + rrkk ) * c3 + vm * c4 + ome = epar * ( pco2i-gammas ) / ( pco2i+2.*gammas ) * c3 + epar * c4 + oms = omss * c3 + omss*pco2i * c4 + + sqrtin= max( 0., ( (ome+omc)**2 - 4.*atheta*ome*omc ) ) + omp = ( ( ome+omc ) - sqrt( sqrtin ) ) / ( 2.*atheta ) + sqrtin= max( 0., ( (omp+oms)**2 - 4.*btheta*omp*oms ) ) + assim = max( 0., ( ( oms+omp ) - sqrt( sqrtin ) ) / ( 2.*btheta )) + + assimn= ( assim - respc) ! mol m-2 s-1 + +!----------------------------------------------------------------------- +! STOMATAL CONDUCTANCE +! +! (1) pathway for co2 flux +! co2m +! o +! | +! | +! < | +! 1.37/gsh2o > | Ac-Rd-Rsoil +! < v +! | +! <--- Ac-Rd | +! o------/\/\/\/\/\------o------/\/\/\/\/\------o +! co2i 1.6/gsh2o co2s 1.37/gbh2o co2a +! | ^ +! | | Rsoil +! | | +! +! (2) pathway for water vapor flux +! +! em +! o +! | +! | +! < ^ +! 1/gsh2o > | Ea +! < | +! | +! ---> Ec ! +! o------/\/\/\/\/\------o------/\/\/\/\/\------o +! ei 1/gsh2o es 1/gbh2o ea +! | ^ +! | | Eg +! | | +! +! (3) the relationship between net assimilation and tomatal conductance : +! gsh2o = m * An * [es/ei] / [pco2s/p] + b +! es = [gsh2o *ei + gbh2o * ea] / [gsh2o + gbh2o] +! ===> +! a*gsh2o^2 + b*gsh2o + c = 0 +! +!----------------------------------------------------------------------- + + co2s = co2a - 1.37*assimn/gbh2o ! mol mol-1 + + pco2in = ( co2s - 1.6 * assimn / gsh2o )*psrf ! pa + + eyy(ic) = pco2i - pco2in ! pa + +!----------------------------------------------------------------------- + + if( abs(eyy(ic)) .lt. 0.1 ) exit + + enddo ITERATION_LOOP_UPDATE + end subroutine update_photosyn END MODULE MOD_AssimStomataConductance ! -------------- EOP --------------- diff --git a/main/MOD_CanopyLayerProfile.F90 b/main/MOD_CanopyLayerProfile.F90 new file mode 100644 index 00000000..13c54978 --- /dev/null +++ b/main/MOD_CanopyLayerProfile.F90 @@ -0,0 +1,729 @@ +#include + +MODULE MOD_CanopyLayerProfile + +!----------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER SUBROUTINE/FUNCTIONS: + + PUBLIC :: uprofile + PUBLIC :: kprofile + PUBLIC :: uintegral + PUBLIC :: uintegralz + PUBLIC :: ueffect + PUBLIC :: ueffectz + PUBLIC :: fuint + PUBLIC :: udiff + PUBLIC :: kintegral + PUBLIC :: frd + PUBLIC :: fkint + PUBLIC :: kdiff + + PUBLIC :: ufindroots + PUBLIC :: kfindroots + + PUBLIC :: cal_z0_displa + +!----------------------------------------------------------------------- + +CONTAINS + + real(r8) FUNCTION uprofile(utop, fc, bee, alpha, z0mg, htop, hbot, z) + + USE MOD_Precision + USE MOD_FrictionVelocity + IMPLICIT NONE + + real(r8), intent(in) :: utop + real(r8), intent(in) :: fc + real(r8), intent(in) :: bee + real(r8), intent(in) :: alpha + real(r8), intent(in) :: z0mg + real(r8), intent(in) :: htop + real(r8), intent(in) :: hbot + real(r8), intent(in) :: z + + real(r8) :: ulog,uexp + + ! when canopy LAI->0, z0->zs, fac->1, u->umoninobuk + ! canopy LAI->large, fac->0 or=0, u->log profile + ulog = utop*log(z/z0mg)/log(htop/z0mg) + uexp = utop*exp(-alpha*(1-(z-hbot)/(htop-hbot))) + + uprofile = bee*fc*min(uexp,ulog) + (1-bee*fc)*ulog + + RETURN + END FUNCTION uprofile + + + real(r8) FUNCTION kprofile(ktop, fc, bee, alpha, & + displah, htop, hbot, obu, ustar, z) + + USE MOD_Precision + USE MOD_FrictionVelocity + IMPLICIT NONE + + real(r8), parameter :: com1 = 0.4 + real(r8), parameter :: com2 = 0.08 + + real(r8), intent(in) :: ktop + real(r8), intent(in) :: fc + real(r8), intent(in) :: bee + real(r8), intent(in) :: alpha + real(r8), intent(in) :: displah + real(r8), intent(in) :: htop + real(r8), intent(in) :: hbot + real(r8), intent(in) :: obu + real(r8), intent(in) :: ustar + real(r8), intent(in) :: z + + real(r8) :: fac + real(r8) :: kcob, klin, kexp + + klin = ktop*z/htop + + fac = 1. / (1.+exp(-(displah-com1)/com2)) + kcob = 1. / (fac/klin + (1.-fac)/kmoninobuk(0.,obu,ustar,z)) + + kexp = ktop*exp(-alpha*(htop-z)/(htop-hbot)) + kprofile = 1./( bee*fc/min(kexp,kcob) + (1-bee*fc)/kcob ) + + RETURN + END FUNCTION kprofile + + + real(r8) FUNCTION uintegral(utop, fc, bee, alpha, z0mg, htop, hbot) + + USE MOD_Precision + IMPLICIT NONE + + real(r8), intent(in) :: utop + real(r8), intent(in) :: fc + real(r8), intent(in) :: bee + real(r8), intent(in) :: alpha + real(r8), intent(in) :: z0mg + real(r8), intent(in) :: htop + real(r8), intent(in) :: hbot + + integer :: i, n + real(r8) :: dz, z, u + + ! 09/26/2017: change fixed n -> fixed dz + dz = 0.001 !fordebug only + n = int( (htop-hbot) / dz ) + 1 + + uintegral = 0. + + DO i = 1, n + IF (i < n) THEN + z = htop - (i-0.5)*dz + ELSE + dz = htop - hbot - (n-1)*dz + z = hbot + 0.5*dz + ENDIF + + u = uprofile(utop, fc, bee, alpha, z0mg, htop, hbot, z) + + u = max(0._r8, u) + !uintegral = uintegral + sqrt(u)*dz / (htop-hbot) +! 03/04/2020, yuan: NOTE: the above is hard to solve + !NOTE: The integral cannot be solved analytically after + !the square root sign of u, and the integral can be approximated + !directly for u, In this way, there is no need to square + uintegral = uintegral + u*dz / (htop-hbot) + ENDDO + + !uintegral = uintegral * uintegral + + RETURN + END FUNCTION uintegral + + + real(r8) FUNCTION uintegralz(utop, fc, bee, alpha, z0mg, & + htop, hbot, ztop, zbot) + + USE MOD_Precision + IMPLICIT NONE + + real(r8), intent(in) :: utop + real(r8), intent(in) :: fc + real(r8), intent(in) :: bee + real(r8), intent(in) :: alpha + real(r8), intent(in) :: z0mg + real(r8), intent(in) :: htop + real(r8), intent(in) :: hbot + real(r8), intent(in) :: ztop + real(r8), intent(in) :: zbot + + integer :: i, n + real(r8) :: dz, z, u + + ! 09/26/2017: change fixed n -> fixed dz + dz = 0.001 !fordebug only + n = int( (ztop-zbot) / dz ) + 1 + + uintegralz = 0. + + DO i = 1, n + IF (i < n) THEN + z = ztop - (i-0.5)*dz + ELSE + dz = ztop - zbot - (n-1)*dz + z = zbot + 0.5*dz + ENDIF + + u = uprofile(utop, fc, bee, alpha, z0mg, htop, hbot, z) + + u = max(0._r8, u) + !uintegral = uintegral + sqrt(u)*dz / (htop-hbot) +! 03/04/2020, yuan: NOTE: the above is hard to solve + !NOTE: The integral cannot be solved analytically after + !the square root sign of u, and the integral can be approximated + !directly for u, In this way, there is no need to square + uintegralz = uintegralz + u*dz / (ztop-zbot) + ENDDO + + !uintegralz = uintegralz * uintegralz + + RETURN + END FUNCTION uintegralz + + + real(r8) FUNCTION ueffect(utop, htop, hbot, & + z0mg, alpha, bee, fc) + USE MOD_Precision + IMPLICIT NONE + + real(r8), intent(in) :: utop + real(r8), intent(in) :: htop + real(r8), intent(in) :: hbot + real(r8), intent(in) :: z0mg + real(r8), intent(in) :: alpha + real(r8), intent(in) :: bee + real(r8), intent(in) :: fc + + real(r8) :: roots(2), uint + integer :: rootn + + rootn = 0 + uint = 0. + + ! The dichotomy method to find the root satisfies a certain accuracy, + ! assuming that there are at most 2 roots + CALL ufindroots(htop,hbot,(htop+hbot)/2., & + utop, htop, hbot, z0mg, alpha, roots, rootn) + + IF (rootn == 0) THEN !no root + uint = uint + fuint(utop, htop, hbot, & + htop, hbot, z0mg, alpha, bee, fc) + ENDIF + + IF (rootn == 1) THEN + uint = uint + fuint(utop, htop, roots(1), & + htop, hbot, z0mg, alpha, bee, fc) + uint = uint + fuint(utop, roots(1), hbot, & + htop, hbot, z0mg, alpha, bee, fc) + ENDIF + + IF (rootn == 2) THEN + uint = uint + fuint(utop, htop, roots(1), & + htop, hbot, z0mg, alpha, bee, fc) + uint = uint + fuint(utop, roots(1), roots(2), & + htop, hbot, z0mg, alpha, bee, fc) + uint = uint + fuint(utop, roots(2), hbot, & + htop, hbot, z0mg, alpha, bee, fc) + ENDIF + + ueffect = uint / (htop-hbot) + + RETURN + END FUNCTION ueffect + + + ! Calculate the effective wind speed between ztop and zbot + real(r8) FUNCTION ueffectz(utop, htop, hbot, & + ztop, zbot, z0mg, alpha, bee, fc) + USE MOD_Precision + IMPLICIT NONE + + real(r8), intent(in) :: utop + real(r8), intent(in) :: htop + real(r8), intent(in) :: hbot + real(r8), intent(in) :: ztop + real(r8), intent(in) :: zbot + real(r8), intent(in) :: z0mg + real(r8), intent(in) :: alpha + real(r8), intent(in) :: bee + real(r8), intent(in) :: fc + + real(r8) :: roots(2), uint + integer :: rootn + + rootn = 0 + uint = 0. + + ! The dichotomy method to find the root satisfies a certain accuracy, + ! assuming that there are at most 2 roots + CALL ufindroots(ztop,zbot,(ztop+zbot)/2., & + utop, htop, hbot, z0mg, alpha, roots, rootn) + + IF (rootn == 0) THEN !no root + uint = uint + fuint(utop, ztop, zbot, & + htop, hbot, z0mg, alpha, bee, fc) + ENDIF + + IF (rootn == 1) THEN + uint = uint + fuint(utop, ztop, roots(1), & + htop, hbot, z0mg, alpha, bee, fc) + uint = uint + fuint(utop, roots(1), zbot, & + htop, hbot, z0mg, alpha, bee, fc) + ENDIF + + IF (rootn == 2) THEN + uint = uint + fuint(utop, ztop, roots(1), & + htop, hbot, z0mg, alpha, bee, fc) + uint = uint + fuint(utop, roots(1), roots(2), & + htop, hbot, z0mg, alpha, bee, fc) + uint = uint + fuint(utop, roots(2), zbot, & + htop, hbot, z0mg, alpha, bee, fc) + ENDIF + + ueffectz = uint / (ztop-zbot) + + RETURN + END FUNCTION ueffectz + + + real(r8) FUNCTION fuint(utop, ztop, zbot, & + htop, hbot, z0mg, alpha, bee, fc) + + USE MOD_Precision + IMPLICIT NONE + + real(r8), intent(in) :: utop, ztop, zbot + real(r8), intent(in) :: htop, hbot + real(r8), intent(in) :: z0mg, alpha + real(r8), intent(in) :: bee, fc + + ! local variables + real(r8) :: fuexpint, fulogint + + fulogint = utop/log(htop/z0mg) *& + (ztop*log(ztop/z0mg) - zbot*log(zbot/z0mg) + zbot - ztop) + + IF (udiff((ztop+zbot)/2.,utop,htop,hbot,z0mg,alpha) <= 0) THEN + ! uexp is smaller + fuexpint = utop*(htop-hbot)/alpha*( & + exp(-alpha*(htop-ztop)/(htop-hbot))-& + exp(-alpha*(htop-zbot)/(htop-hbot)) ) + + fuint = bee*fc*fuexpint + (1.-bee*fc)*fulogint + ELSE + ! ulog is smaller + fuint = fulogint + ENDIF + + RETURN + END FUNCTION fuint + + + RECURSIVE SUBROUTINE ufindroots(ztop,zbot,zmid, & + utop, htop, hbot, z0mg, alpha, roots, rootn) + + USE MOD_Precision + IMPLICIT NONE + + real(r8), intent(in) :: ztop, zbot, zmid + real(r8), intent(in) :: utop, htop, hbot + real(r8), intent(in) :: z0mg, alpha + + real(r8), intent(inout) :: roots(2) + integer, intent(inout) :: rootn + + ! local variables + real(r8) :: udiff_ub, udiff_lb + + udiff_ub = udiff(ztop,utop,htop,hbot,z0mg,alpha) + udiff_lb = udiff(zmid,utop,htop,hbot,z0mg,alpha) + + IF (udiff_ub*udiff_lb == 0) THEN + IF (udiff_lb == 0) THEN !root found + rootn = rootn + 1 + IF (rootn > 2) THEN + print *, "U root number > 2, abort!" + CALL abort + ENDIF + roots(rootn) = zmid + ENDIF + ELSE IF (udiff_ub*udiff_lb < 0) THEN + IF (ztop-zmid < 0.01) THEN + rootn = rootn + 1 !root found + IF (rootn > 2) THEN + print *, "U root number > 2, abort!" + CALL abort + ENDIF + roots(rootn) = (ztop+zmid)/2. + ELSE + CALL ufindroots(ztop,zmid,(ztop+zmid)/2., & + utop, htop, hbot, z0mg, alpha, roots, rootn) + ENDIF + ENDIF + + udiff_ub = udiff(zmid,utop,htop,hbot,z0mg,alpha) + udiff_lb = udiff(zbot,utop,htop,hbot,z0mg,alpha) + + IF (udiff_ub*udiff_lb == 0) THEN + IF (udiff_ub == 0) THEN !root found + rootn = rootn + 1 + IF (rootn > 2) THEN + print *, "U root number > 2, abort!" + CALL abort + ENDIF + roots(rootn) = zmid + ENDIF + ELSE IF (udiff_ub*udiff_lb < 0) THEN + IF (zmid-zbot < 0.01) THEN + rootn = rootn + 1 !root found + IF (rootn > 2) THEN + print *, "U root number > 2, abort!" + CALL abort + ENDIF + roots(rootn) = (zmid+zbot)/2. + ELSE + CALL ufindroots(zmid,zbot,(zmid+zbot)/2., & + utop, htop, hbot, z0mg, alpha, roots, rootn) + ENDIF + ENDIF + END SUBROUTINE ufindroots + + + real(r8) FUNCTION udiff(z, utop, htop, hbot, z0mg, alpha) + + USE MOD_Precision + IMPLICIT NONE + + real(r8), intent(in) :: z, utop, htop, hbot + real(r8), intent(in) :: z0mg, alpha + + real(r8) :: uexp, ulog + + ! yuan, 12/28/2020: + uexp = utop*exp(-alpha*(htop-z)/(htop-hbot)) + ulog = utop*log(z/z0mg)/log(htop/z0mg) + + udiff = uexp - ulog + + RETURN + END FUNCTION udiff + + + real(r8) FUNCTION kintegral(ktop, fc, bee, alpha, z0mg, & + displah, htop, hbot, obu, ustar, ztop, zbot) + USE MOD_Precision + IMPLICIT NONE + + real(r8), intent(in) :: ktop + real(r8), intent(in) :: fc + real(r8), intent(in) :: bee + real(r8), intent(in) :: alpha + real(r8), intent(in) :: z0mg + real(r8), intent(in) :: displah + real(r8), intent(in) :: htop + real(r8), intent(in) :: hbot + real(r8), intent(in) :: obu + real(r8), intent(in) :: ustar + real(r8), intent(in) :: ztop + real(r8), intent(in) :: zbot + + integer :: i, n + real(r8) :: dz, z, k + + kintegral = 0. + + IF (ztop <= zbot) THEN + RETURN + ENDIF + + ! 09/26/2017: change fixed n -> fixed dz + dz = 0.001 ! fordebug only + n = int( (ztop-zbot) / dz ) + 1 + + DO i = 1, n + IF (i < n) THEN + z = ztop - (i-0.5)*dz + ELSE + dz = ztop - zbot - (n-1)*dz + z = zbot + 0.5*dz + ENDIF + + k = kprofile(ktop, fc, bee, alpha, & + displah, htop, hbot, obu, ustar, z) + + kintegral = kintegral + 1./k * dz + + ENDDO + + RETURN + END FUNCTION kintegral + + + real(r8) FUNCTION frd(ktop, htop, hbot, & + ztop, zbot, displah, z0h, obu, ustar, & + z0mg, alpha, bee, fc) + + USE MOD_Precision + IMPLICIT NONE + + real(r8), intent(in) :: ktop, htop, hbot + real(r8), intent(in) :: ztop, zbot + real(r8), intent(in) :: displah, z0h, obu, ustar + real(r8), intent(in) :: z0mg, alpha, bee, fc + + ! local parameters + real(r8), parameter :: com1 = 0.4 + real(r8), parameter :: com2 = 0.08 + + real(r8) :: roots(2), fac, kint + integer :: rootn + + rootn = 0 + kint = 0. + + ! calculate fac + fac = 1. / (1.+exp(-(displah-com1)/com2)) + roots(:) = 0. + + CALL kfindroots(ztop,zbot,(ztop+zbot)/2., & + ktop, htop, hbot, obu, ustar, fac, alpha, roots, rootn) + + IF (rootn == 0) THEN !no root + kint = kint + fkint(ktop, ztop, zbot, htop, hbot, & + z0h, obu, ustar, fac, alpha, bee, fc) + ENDIF + + IF (rootn == 1) THEN + kint = kint + fkint(ktop, ztop, roots(1), htop, hbot, & + z0h, obu, ustar, fac, alpha, bee, fc) + kint = kint + fkint(ktop, roots(1), zbot, htop, hbot, & + z0h, obu, ustar, fac, alpha, bee, fc) + ENDIF + + IF (rootn == 2) THEN + kint = kint + fkint(ktop, ztop, roots(1), htop, hbot, & + z0h, obu, ustar, fac, alpha, bee, fc) + kint = kint + fkint(ktop, roots(1), roots(2), htop, hbot, & + z0h, obu, ustar, fac, alpha, bee, fc) + kint = kint + fkint(ktop, roots(2), zbot, htop, hbot, & + z0h, obu, ustar, fac, alpha, bee, fc) + ENDIF + + frd = kint + + RETURN + END FUNCTION frd + + + real(r8) FUNCTION fkint(ktop, ztop, zbot, htop, hbot, & + z0h, obu, ustar, fac, alpha, bee, fc) + + USE MOD_Precision + USE MOD_FrictionVelocity + IMPLICIT NONE + + real(r8), intent(in) :: ktop, ztop, zbot + real(r8), intent(in) :: htop, hbot + real(r8), intent(in) :: z0h, obu, ustar, fac, alpha + real(r8), intent(in) :: bee, fc + + ! local variables + real(r8) :: fkexpint, fkcobint + + !NOTE: + ! klin = ktop*z/htop + ! kcob = 1./(fac/klin + (1.-fac)/kmoninobuk(0.,obu,ustar,z)) + fkcobint = fac*htop/ktop*(log(ztop)-log(zbot)) +& + (1.-fac)*kintmoninobuk(0.,z0h,obu,ustar,ztop,zbot) + + IF (kdiff((ztop+zbot)/2.,ktop,htop,hbot,obu,ustar,fac,alpha) <= 0) THEN + ! kexp is smaller + IF (alpha > 0) THEN + fkexpint = -(htop-hbot)/alpha/ktop*( & + exp(alpha*(htop-ztop)/(htop-hbot))-& + exp(alpha*(htop-zbot)/(htop-hbot)) ) + ELSE + fkexpint = (ztop-zbot)/ktop + ENDIF + + fkint = bee*fc*fkexpint + (1.-bee*fc)*fkcobint + ELSE + ! kcob is smaller + fkint = fkcobint + ENDIF + + RETURN + END FUNCTION fkint + + + RECURSIVE SUBROUTINE kfindroots(ztop,zbot,zmid, & + ktop, htop, hbot, obu, ustar, fac, alpha, roots, rootn) + + USE MOD_Precision + IMPLICIT NONE + + real(r8), intent(in) :: ztop, zbot, zmid + real(r8), intent(in) :: ktop, htop, hbot + real(r8), intent(in) :: obu, ustar, fac, alpha + + real(r8), intent(inout) :: roots(2) + integer, intent(inout) :: rootn + + ! local variables + real(r8) :: kdiff_ub, kdiff_lb + + !print *, "*** CALL recursive SUBROUTINE kfindroots!!" + kdiff_ub = kdiff(ztop,ktop,htop,hbot,obu,ustar,fac,alpha) + kdiff_lb = kdiff(zmid,ktop,htop,hbot,obu,ustar,fac,alpha) + + IF (kdiff_ub*kdiff_lb == 0) THEN + IF (kdiff_lb == 0) THEN !root found + rootn = rootn + 1 + IF (rootn > 2) THEN + print *, "K root number > 2, abort!" + CALL abort + ENDIF + roots(rootn) = zmid + ENDIF + ELSE IF (kdiff_ub*kdiff_lb < 0) THEN + IF (ztop-zmid < 0.01) THEN + rootn = rootn + 1 !root found + IF (rootn > 2) THEN + print *, "K root number > 2, abort!" + CALL abort + ENDIF + roots(rootn) = (ztop+zmid)/2. + ELSE + CALL kfindroots(ztop,zmid,(ztop+zmid)/2., & + ktop, htop, hbot, obu, ustar, fac, alpha, roots, rootn) + ENDIF + ENDIF + + kdiff_ub = kdiff(zmid,ktop,htop,hbot,obu,ustar,fac,alpha) + kdiff_lb = kdiff(zbot,ktop,htop,hbot,obu,ustar,fac,alpha) + + IF (kdiff_ub*kdiff_lb == 0) THEN + IF (kdiff_ub == 0) THEN !root found + rootn = rootn + 1 + IF (rootn > 2) THEN + print *, "K root number > 2, abort!" + CALL abort + ENDIF + roots(rootn) = zmid + ENDIF + ELSE IF (kdiff_ub*kdiff_lb < 0) THEN + IF (zmid-zbot < 0.01) THEN + rootn = rootn + 1 !root found + IF (rootn > 2) THEN + print *, "K root number > 2, abort!" + CALL abort + ENDIF + roots(rootn) = (zmid+zbot)/2. + ELSE + CALL kfindroots(zmid,zbot,(zmid+zbot)/2., & + ktop, htop, hbot, obu, ustar, fac, alpha, roots, rootn) + ENDIF + ENDIF + END SUBROUTINE kfindroots + + + real(r8) FUNCTION kdiff(z, ktop, htop, hbot, & + obu, ustar, fac, alpha) + + USE MOD_Precision + USE MOD_FrictionVelocity + IMPLICIT NONE + + real(r8), intent(in) :: z, ktop, htop, hbot + real(r8), intent(in) :: obu, ustar, fac, alpha + + real(r8) :: kexp, klin, kcob + + kexp = ktop*exp(-alpha*(htop-z)/(htop-hbot)) + + klin = ktop*z/htop + kcob = 1./(fac/klin + (1.-fac)/kmoninobuk(0.,obu,ustar,z)) + + kdiff = kexp - kcob + + RETURN + END FUNCTION kdiff + + + SUBROUTINE cal_z0_displa (lai, h, fc, z0, displa) + + USE MOD_Const_Physical, only: vonkar + IMPLICIT NONE + + real(r8), intent(in) :: lai + real(r8), intent(in) :: h + real(r8), intent(in) :: fc + real(r8), intent(out) :: z0 + real(r8), intent(out) :: displa + + real(r8), parameter :: Cd = 0.2 !leaf drag coefficient + real(r8), parameter :: cd1 = 7.5 !a free parameter for d/h calculation, Raupach 1992, 1994 + real(r8), parameter :: psih = 0.193 !psih = ln(cw) - 1 + cw^-1, cw = 2, Raupach 1994 + + ! local variables + real(r8) :: fai, sqrtdragc, temp1, delta , lai0 + + ! when assume z0=0.01, displa=0 + ! to calculate lai0, delta displa + !---------------------------------------------------- + sqrtdragc = -vonkar/(log(0.01/h) - psih) + sqrtdragc = max(sqrtdragc, 0.0031**0.5) + IF (sqrtdragc .le. 0.3) THEN + fai = (sqrtdragc**2-0.003) / 0.3 + fai = min(fai, fc*(1-exp(-20.))) + ELSE + fai = 0.29 + print *, "z0m, displa error!" + ENDIF + + ! calculate delta displa when z0 = 0.01 + lai0 = -log(1.-fai/fc)/0.5 + temp1 = (2.*cd1*fai)**0.5 + delta = -h * ( fc*1.1*log(1. + (Cd*lai0*fc)**0.25) + & + (1.-fc)*(1.-(1.-exp(-temp1))/temp1) ) + + ! calculate z0m, displa + !---------------------------------------------------- + ! NOTE: potential bug below, only apply for spheric + ! crowns. For other cases, fc*(...) ==> a*fc*(...) + fai = fc*(1. - exp(-0.5*lai)) + sqrtdragc = min( (0.003+0.3*fai)**0.5, 0.3 ) + temp1 = (2.*cd1*fai)**0.5 + + IF (lai > lai0) THEN + displa = delta + h*( & + ( fc)*1.1*log(1. + (Cd*lai*fc)**0.25) + & + (1-fc)*(1.-(1.-exp(-temp1))/temp1) ) + ELSE + displa = h*( & + ( fc)*1.1*log(1. + (Cd*lai*fc)**0.25) + & + (1-fc)*(1.-(1.-exp(-temp1))/temp1) ) + ENDIF + + displa = max(displa, 0.) + z0 = (h-displa) * exp(-vonkar/sqrtdragc + psih) + + IF (z0 < 0.01) THEN + z0 = 0.01 + displa = 0. + ENDIF + + END SUBROUTINE cal_z0_displa + +END MODULE MOD_CanopyLayerProfile diff --git a/main/MOD_Const_LC.F90 b/main/MOD_Const_LC.F90 index 44b77cd8..9828033d 100644 --- a/main/MOD_Const_LC.F90 +++ b/main/MOD_Const_LC.F90 @@ -8,10 +8,10 @@ MODULE MOD_Const_LC ! ! Created by Hua Yuan, 08/2019 ! -! REVISIONS: +! !REVISIONS: ! Hua Yuan, 08/2019: initial version adapted from IniTimeConst.F90 of CoLM2014 ! Hua Yuan, 08/2019: added constants values for IGBP land cover types -! TODO... +! Xingjie Lu, 05/2023: added Plant Hydraulics Paramters ! ! !USES: USE MOD_Precision @@ -51,9 +51,9 @@ MODULE MOD_Const_LC !23 Bare Ground Tundra !24 Snow or Ice - ! land water types + ! land patch types ! 0: soil, 1: urban, 2: wetland, 3: ice, 4: lake - INTEGER , parameter, dimension(N_land_classification) :: patchtypes_usgs & + integer , parameter, dimension(N_land_classification) :: patchtypes_usgs & = (/1, 0, 0, 0, 0, 0, 0, 0,& 0, 0, 0, 0, 0, 0, 0, 4,& 2, 2, 0, 0, 0, 0, 0, 3/) @@ -62,172 +62,185 @@ MODULE MOD_Const_LC !NOTE: now read from input NetCDF file !NOTE: woody wetland 35m? ! shrub land 0.5m? grass like land 1m? all set to 0.5 - REAL(r8), parameter, dimension(N_land_classification) :: htop0_usgs & - !=(/ 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 0.5,& - ! 0.5, 1.0, 20.0, 17.0, 35.0, 17.0, 20.0, 1.0,& - ! 1.0, 35.0, 0.5, 1.0, 1.0, 1.0, 1.0, 1.0/) + real(r8), parameter, dimension(N_land_classification) :: htop0_usgs & + !=(/ 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 0.5,& + ! 0.5, 1.0, 20.0, 17.0, 35.0, 17.0, 20.0, 1.0,& + ! 1.0, 35.0, 0.5, 1.0, 1.0, 1.0, 1.0, 1.0/) =(/ 1.0, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5,& 0.5, 0.5, 20.0, 17.0, 35.0, 17.0, 20.0, 0.5,& 0.5, 17.0, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5/) ! Look-up table canopy bottom height - REAL(r8), parameter, dimension(N_land_classification) :: hbot0_usgs & -! 01/06/2020, yuan: adjust hbop: grass/shrub -> 0, tree->1 - !=(/0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.1,& - ! 0.1, 0.1, 11.5, 8.5, 1.0, 8.5, 10.0, 0.1,& - ! 0.1, 1.0, 0.1, 0.01, 0.01, 0.01, 0.01, 0.01/) + ! 01/06/2020, yuan: adjust hbop: grass/shrub -> 0, tree->1 + real(r8), parameter, dimension(N_land_classification) :: hbot0_usgs & + !=(/0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.1,& + ! 0.1, 0.1, 11.5, 8.5, 1.0, 8.5, 10.0, 0.1,& + ! 0.1, 1.0, 0.1, 0.01, 0.01, 0.01, 0.01, 0.01/) =(/ 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0,& 0.0, 0.0, 1.0, 1.0, 1.0, 1.0, 1.0, 0.0,& 0.0, 1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/) ! defulat vegetation fractional cover - REAL(r8), parameter, dimension(N_land_classification) :: fveg0_usgs & + real(r8), parameter, dimension(N_land_classification) :: fveg0_usgs & = 1.0 !(/.../) ! Look-up table stem area index !NOTE: now read from input NetCDF file - REAL(r8), parameter, dimension(N_land_classification) :: sai0_usgs & - !=(/0.2, 0.2, 0.3, 0.3, 0.5, 0.5, 1.0, 0.5,& - ! 1.0, 0.5, 2.0, 2.0, 2.0, 2.0, 2.0, 0.0,& - ! 2.0, 2.0, 0.0, 0.1, 0.1, 0.1, 0.0, 0.0/) + real(r8), parameter, dimension(N_land_classification) :: sai0_usgs & + !=(/0.2, 0.2, 0.3, 0.3, 0.5, 0.5, 1.0, 0.5,& + ! 1.0, 0.5, 2.0, 2.0, 2.0, 2.0, 2.0, 0.0,& + ! 2.0, 2.0, 0.0, 0.1, 0.1, 0.1, 0.0, 0.0/) =(/0.2, 0.2, 0.3, 0.3, 0.5, 0.5, 1.0, 0.5,& 1.0, 0.5, 2.0, 2.0, 2.0, 2.0, 2.0, 0.0,& 0.2, 2.0, 0.2, 0.2, 0.2, 0.2, 0.0, 0.0/) ! ratio to calculate roughness length z0m - REAL(r8), parameter, dimension(N_land_classification) :: z0mr_usgs = 0.1 + real(r8), parameter, dimension(N_land_classification) :: z0mr_usgs = 0.1 ! ratio to calculate displacement height d - REAL(r8), parameter, dimension(N_land_classification) :: displar_usgs = 0.667 + real(r8), parameter, dimension(N_land_classification) :: displar_usgs = 0.667 ! inverse sqrt of leaf dimension [m**-0.5, m=4 cm] - REAL(r8), parameter, dimension(N_land_classification) :: sqrtdi_usgs = 5.0 + real(r8), parameter, dimension(N_land_classification) :: sqrtdi_usgs = 5.0 ! leaf angle distribution parameter - REAL(r8), parameter, dimension(N_land_classification) :: chil_usgs & + real(r8), parameter, dimension(N_land_classification) :: chil_usgs & = (/-0.300, -0.300, -0.300, -0.300, -0.300, -0.300, -0.300, 0.010,& 0.010, -0.300, 0.250, 0.010, 0.100, 0.010, 0.125, -0.300,& -0.300, 0.100, 0.010, -0.300, -0.300, -0.300, -0.300, -0.300/) ! reflectance of green leaf in virsible band - REAL(r8), parameter, dimension(N_land_classification) :: rhol_vis_usgs & + real(r8), parameter, dimension(N_land_classification) :: rhol_vis_usgs & = (/0.105, 0.105, 0.105, 0.105, 0.105, 0.105, 0.105, 0.100,& 0.100, 0.105, 0.100, 0.070, 0.100, 0.070, 0.070, 0.105,& 0.105, 0.100, 0.100, 0.105, 0.105, 0.105, 0.105, 0.105/) ! reflectance of dead leaf in virsible band - REAL(r8), parameter, dimension(N_land_classification) :: rhos_vis_usgs & + real(r8), parameter, dimension(N_land_classification) :: rhos_vis_usgs & = (/0.360, 0.360, 0.360, 0.360, 0.360, 0.360, 0.360, 0.160,& 0.160, 0.360, 0.160, 0.160, 0.160, 0.160, 0.160, 0.360,& 0.360, 0.160, 0.160, 0.360, 0.360, 0.360, 0.360, 0.360/) ! reflectance of green leaf in near infrared band - REAL(r8), parameter, dimension(N_land_classification) :: rhol_nir_usgs & + real(r8), parameter, dimension(N_land_classification) :: rhol_nir_usgs & = (/0.580, 0.580, 0.580, 0.580, 0.580, 0.580, 0.580, 0.450,& 0.450, 0.580, 0.450, 0.350, 0.450, 0.350, 0.400, 0.580,& 0.580, 0.450, 0.450, 0.580, 0.580, 0.580, 0.580, 0.580/) ! reflectance of dead leaf in near infrared band - REAL(r8), parameter, dimension(N_land_classification) :: rhos_nir_usgs & + real(r8), parameter, dimension(N_land_classification) :: rhos_nir_usgs & = (/0.580, 0.580, 0.580, 0.580, 0.580, 0.580, 0.580, 0.390,& 0.390, 0.580, 0.390, 0.390, 0.390, 0.390, 0.390, 0.580,& 0.580, 0.390, 0.390, 0.580, 0.580, 0.580, 0.580, 0.580/) ! transmittance of green leaf in visible band - REAL(r8), parameter, dimension(N_land_classification) :: taul_vis_usgs & + real(r8), parameter, dimension(N_land_classification) :: taul_vis_usgs & = (/0.070, 0.070, 0.070, 0.070, 0.070, 0.070, 0.070, 0.070,& 0.070, 0.070, 0.050, 0.050, 0.050, 0.050, 0.050, 0.070,& 0.070, 0.050, 0.070, 0.070, 0.070, 0.070, 0.070, 0.070/) ! transmittance of dead leaf in visible band - REAL(r8), parameter, dimension(N_land_classification) :: taus_vis_usgs & + real(r8), parameter, dimension(N_land_classification) :: taus_vis_usgs & = (/0.220, 0.220, 0.220, 0.220, 0.220, 0.220, 0.220, 0.001,& 0.001, 0.220, 0.001, 0.001, 0.001, 0.001, 0.001, 0.220,& 0.220, 0.001, 0.001, 0.220, 0.220, 0.220, 0.220, 0.220/) ! transmittance of green leaf in near infrared band - REAL(r8), parameter, dimension(N_land_classification) :: taul_nir_usgs & + real(r8), parameter, dimension(N_land_classification) :: taul_nir_usgs & = (/0.250, 0.250, 0.250, 0.250, 0.250, 0.250, 0.250, 0.250,& 0.250, 0.250, 0.250, 0.100, 0.250, 0.100, 0.150, 0.250,& 0.250, 0.250, 0.250, 0.250, 0.250, 0.250, 0.250, 0.250/) ! transmittance of dead leaf in near infrared band - REAL(r8), parameter, dimension(N_land_classification) :: taus_nir_usgs & + real(r8), parameter, dimension(N_land_classification) :: taus_nir_usgs & = (/0.380, 0.380, 0.380, 0.380, 0.380, 0.380, 0.380, 0.001,& 0.001, 0.380, 0.001, 0.001, 0.001, 0.001, 0.001, 0.380,& 0.380, 0.001, 0.001, 0.380, 0.380, 0.380, 0.380, 0.380/) ! maximum carboxylation rate at 25 C at canopy top ! /06/03/2014/ based on Bonan et al., 2010 (Table 2) - REAL(r8), parameter, dimension(N_land_classification) :: vmax25_usgs & + real(r8), parameter, dimension(N_land_classification) :: vmax25_usgs & = (/100.0, 57.0, 57.0, 57.0, 52.0, 52.0, 52.0, 52.0,& 52.0, 52.0, 52.0, 57.0, 72.0, 54.0, 52.0, 57.0,& 52.0, 52.0, 52.0, 52.0, 52.0, 52.0, 52.0, 52.0/) ! quantum efficiency !TODO: no C4, 0.05 may have problem - REAL(r8), parameter, dimension(N_land_classification) :: effcon_usgs & + real(r8), parameter, dimension(N_land_classification) :: effcon_usgs & = (/0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08,& 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08,& 0.08, 0.08, 0.08, 0.05, 0.05, 0.05, 0.05, 0.05/) ! conductance-photosynthesis slope parameter !TODO: no C4, 4.0 may have problem - REAL(r8), parameter, dimension(N_land_classification) :: gradm_usgs & + real(r8), parameter, dimension(N_land_classification) :: g1_usgs & + = (/4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0,& + 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0,& + 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0/) + + ! conductance-photosynthesis intercept + real(r8), parameter, dimension(N_land_classification) :: g0_usgs & + = (/100, 100, 100, 100, 100, 100, 100, 100,& + 100, 100, 100, 100, 100, 100, 100, 100,& + 100, 100, 100, 100, 100, 100, 100, 100/) + + ! conductance-photosynthesis slope parameter + !TODO: no C4, 4.0 may have problem + real(r8), parameter, dimension(N_land_classification) :: gradm_usgs & = (/9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0,& 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0,& 9.0, 9.0, 9.0, 4.0, 4.0, 4.0, 4.0, 4.0/) ! conductance-photosynthesis intercept - REAL(r8), parameter, dimension(N_land_classification) :: binter_usgs & + real(r8), parameter, dimension(N_land_classification) :: binter_usgs & = (/0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01,& 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01,& 0.01, 0.01, 0.01, 0.04, 0.04, 0.04, 0.04, 0.04/) ! respiration fraction - REAL(r8), parameter, dimension(N_land_classification) :: respcp_usgs & + real(r8), parameter, dimension(N_land_classification) :: respcp_usgs & = (/0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015,& 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015,& 0.015, 0.015, 0.015, 0.025, 0.025, 0.025, 0.025, 0.025/) ! slope of high temperature inhibition FUNCTION (s1) - REAL(r8), parameter, dimension(N_land_classification) :: shti_usgs = 0.3 + real(r8), parameter, dimension(N_land_classification) :: shti_usgs = 0.3 ! slope of low temperature inhibition FUNCTION (s3) - REAL(r8), parameter, dimension(N_land_classification) :: slti_usgs = 0.2 + real(r8), parameter, dimension(N_land_classification) :: slti_usgs = 0.2 ! temperature coefficient in gs-a model (s5) - REAL(r8), parameter, dimension(N_land_classification) :: trda_usgs = 1.3 + real(r8), parameter, dimension(N_land_classification) :: trda_usgs = 1.3 ! temperature coefficient in gs-a model (s6) - REAL(r8), parameter, dimension(N_land_classification) :: trdm_usgs = 328.0 + real(r8), parameter, dimension(N_land_classification) :: trdm_usgs = 328.0 ! temperature coefficient in gs-a model (273.16+25) - REAL(r8), parameter, dimension(N_land_classification) :: trop_usgs = 298.0 + real(r8), parameter, dimension(N_land_classification) :: trop_usgs = 298.0 ! 1/2 point of high temperature inhibition FUNCTION (s2) - REAL(r8), parameter, dimension(N_land_classification) :: hhti_usgs & + real(r8), parameter, dimension(N_land_classification) :: hhti_usgs & =(/308.0, 308.0, 308.0, 308.0, 308.0, 308.0, 308.0, 313.0,& 313.0, 308.0, 311.0, 303.0, 313.0, 303.0, 307.0, 308.0,& 308.0, 313.0, 313.0, 313.0, 313.0, 313.0, 313.0, 308.0/) ! 1/2 point of low temperature inhibition FUNCTION (s4) - REAL(r8), parameter, dimension(N_land_classification) :: hlti_usgs & + real(r8), parameter, dimension(N_land_classification) :: hlti_usgs & =(/281.0, 281.0, 281.0, 281.0, 281.0, 281.0, 281.0, 283.0,& 283.0, 281.0, 283.0, 278.0, 288.0, 278.0, 281.0, 281.0,& 281.0, 288.0, 283.0, 288.0, 288.0, 288.0, 288.0, 281.0/) ! coefficient of leaf nitrogen allocation - REAL(r8), parameter, dimension(N_land_classification) :: extkn_usgs = 0.5 + real(r8), parameter, dimension(N_land_classification) :: extkn_usgs = 0.5 ! depth at 50% roots - REAL(r8), parameter, dimension(N_land_classification) :: d50_usgs & + real(r8), parameter, dimension(N_land_classification) :: d50_usgs & =(/23.0, 21.0, 23.0, 22.0, 15.7, 19.0, 9.3, 47.0,& 28.2, 21.7, 16.0, 16.0, 15.0, 15.0, 15.5, 1.0,& 9.3, 15.5, 27.0, 9.0, 9.0, 9.0, 9.0, 1.0/) ! coefficient of root profile - REAL(r8), parameter, dimension(N_land_classification) :: beta_usgs & + real(r8), parameter, dimension(N_land_classification) :: beta_usgs & =(/-1.757, -1.835, -1.757, -1.796, -1.577, -1.738, -1.359, -3.245,& -2.302, -1.654, -1.681, -1.681, -1.632, -1.632, -1.656, -1.000,& -1.359, -1.656, -2.051, -2.621, -2.621, -2.621, -2.621, -1.000/) @@ -235,75 +248,75 @@ MODULE MOD_Const_LC ! Table 2. Zeng, 2001 ! urban ==> cropland ! water/glacier ==> grass - REAL(r8), parameter, dimension(N_land_classification) :: roota_usgs & + real(r8), parameter, dimension(N_land_classification) :: roota_usgs & =(/ 5.558, 5.558, 5.558, 5.558, 8.149, 5.558, 10.740, 7.022,& - 8.881, 7.920, 5.990, 7.066, 7.344, 7.706, 4.453, 10.740,& + 8.881, 7.920, 5.990, 7.066, 7.344, 6.706, 4.453, 10.740,& 10.740, 4.453, 8.992, 8.992, 8.992, 8.992, 4.372, 10.740/) - REAL(r8), parameter, dimension(N_land_classification) :: rootb_usgs & + real(r8), parameter, dimension(N_land_classification) :: rootb_usgs & =(/ 2.614, 2.614, 2.614, 2.614, 2.611, 2.614, 2.608, 1.415,& 2.012, 1.964, 1.955, 1.953, 1.303, 2.175, 1.631, 2.608,& 2.608, 1.631, 8.992, 8.992, 8.992, 8.992, 0.978, 2.608/) ! Plant Hydraulics Paramters - REAL(r8), parameter, dimension(N_land_classification) :: kmax_sun0_usgs & - = (/0., 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008,& + real(r8), parameter, dimension(N_land_classification) :: kmax_sun0_usgs & + = (/ 0., 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008,& 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008,& - 2.e-008, 2.e-008, 2.e-008, 0., 2.e-008, 2.e-008,& - 0., 2.e-008, 2.e-008, 2.e-008, 0., 0./) + 2.e-008, 2.e-008, 2.e-008, 0., 2.e-008, 2.e-008,& + 0., 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008/) - REAL(r8), parameter, dimension(N_land_classification) :: kmax_sha0_usgs & - = (/0., 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008,& + real(r8), parameter, dimension(N_land_classification) :: kmax_sha0_usgs & + = (/ 0., 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008,& 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008,& - 2.e-008, 2.e-008, 2.e-008, 0., 2.e-008, 2.e-008,& - 0., 2.e-008, 2.e-008, 2.e-008, 0., 0./) + 2.e-008, 2.e-008, 2.e-008, 0., 2.e-008, 2.e-008,& + 0., 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008/) - REAL(r8), parameter, dimension(N_land_classification) :: kmax_xyl0_usgs & - = (/0., 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008,& + real(r8), parameter, dimension(N_land_classification) :: kmax_xyl0_usgs & + = (/ 0., 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008,& 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008,& - 2.e-008, 2.e-008, 2.e-008, 0., 2.e-008, 2.e-008,& - 0., 2.e-008, 2.e-008, 2.e-008, 0., 0./) + 2.e-008, 2.e-008, 2.e-008, 0., 2.e-008, 2.e-008,& + 0., 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008/) - REAL(r8), parameter, dimension(N_land_classification) :: kmax_root0_usgs & - = (/0., 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008,& + real(r8), parameter, dimension(N_land_classification) :: kmax_root0_usgs & + = (/ 0., 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008,& 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008,& - 2.e-008, 2.e-008, 2.e-008, 0., 2.e-008, 2.e-008,& - 0., 2.e-008, 2.e-008, 2.e-008, 0., 0./) + 2.e-008, 2.e-008, 2.e-008, 0., 2.e-008, 2.e-008,& + 0., 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008/) ! water potential at 50% loss of sunlit leaf tissue conductance (mmH2O) - REAL(r8), parameter, dimension(N_land_classification) :: psi50_sun0_usgs & + real(r8), parameter, dimension(N_land_classification) :: psi50_sun0_usgs & = (/-150000.0,-340000.0,-340000.0,-340000.0,-340000.0,-343636.4,& -340000.0,-393333.3,-366666.7,-340000.0,-270000.0,-380000.0,& -260000.0,-465000.0,-330000.0,-150000.0,-340000.0,-347272.7,& -150000.0,-340000.0,-342500.0,-341250.0,-150000.0,-150000.0/) *1 ! water potential at 50% loss of shaded leaf tissue conductance (mmH2O) - REAL(r8), parameter, dimension(N_land_classification) :: psi50_sha0_usgs & + real(r8), parameter, dimension(N_land_classification) :: psi50_sha0_usgs & = (/-150000.0,-340000.0,-340000.0,-340000.0,-340000.0,-343636.4,& -340000.0,-393333.3,-366666.7,-340000.0,-270000.0,-380000.0,& -260000.0,-465000.0,-330000.0,-150000.0,-340000.0,-347272.7,& -150000.0,-340000.0,-342500.0,-341250.0,-150000.0,-150000.0/) *1 ! water potential at 50% loss of xylem tissue conductance (mmH2O) - REAL(r8), parameter, dimension(N_land_classification) :: psi50_xyl0_usgs & + real(r8), parameter, dimension(N_land_classification) :: psi50_xyl0_usgs & = (/-200000.0,-340000.0,-340000.0,-340000.0,-340000.0,-343636.4,& -340000.0,-393333.3,-366666.7,-340000.0,-270000.0,-380000.0,& -260000.0,-465000.0,-330000.0,-200000.0,-340000.0,-347272.7,& -200000.0,-340000.0,-342500.0,-341250.0,-200000.0,-200000.0/) *1 ! water potential at 50% loss of root tissue conductance (mmH2O) - REAL(r8), parameter, dimension(N_land_classification) :: psi50_root0_usgs & + real(r8), parameter, dimension(N_land_classification) :: psi50_root0_usgs & = (/-200000.0,-340000.0,-340000.0,-340000.0,-340000.0,-343636.4,& -340000.0,-393333.3,-366666.7,-340000.0,-270000.0,-380000.0,& -260000.0,-465000.0,-330000.0,-200000.0,-340000.0,-347272.7,& -200000.0,-340000.0,-342500.0,-341250.0,-200000.0,-200000.0/)*1 ! shape-fitting parameter for vulnerability curve (-) - REAL(r8), parameter, dimension(N_land_classification) :: ck0_usgs & - = (/0., 3.95, 3.95, 3.95, 3.95, 3.95, & + real(r8), parameter, dimension(N_land_classification) :: ck0_usgs & + = (/ 0., 3.95, 3.95, 3.95, 3.95, 3.95, & 3.95, 3.95, 3.95, 3.95, 3.95, 3.95, & - 3.95, 3.95, 3.95, 0., 3.95, 3.95, & - 0., 3.95, 3.95, 3.95, 0., 0./) + 3.95, 3.95, 3.95, 0., 3.95, 3.95, & + 0., 3.95, 3.95, 3.95, 0., 0./) !end plant hydraulic parameters #else @@ -328,176 +341,188 @@ MODULE MOD_Const_LC !16 Barren !17 Water Bodies - ! land water types + ! land patch types ! 0: soil, 1: urban, 2: wetland, 3: ice, 4: lake - INTEGER , parameter, dimension(N_land_classification) :: patchtypes_igbp & + integer , parameter, dimension(N_land_classification) :: patchtypes_igbp & = (/0, 0, 0, 0, 0, 0, 0, 0,& 0, 0, 2, 0, 1, 0, 3, 0,& 4 /) ! Look-up table canopy top height !NOTE: now read from input NetCDF file - REAL(r8), parameter, dimension(N_land_classification) :: htop0_igbp & + real(r8), parameter, dimension(N_land_classification) :: htop0_igbp & =(/17.0, 35.0, 17.0, 20.0, 20.0, 0.5, 0.5, 1.0,& 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0,& 1.0 /) - !=(/17.0, 35.0, 17.0, 20.0, 20.0, 0.5, 0.5, 0.5,& - ! 0.5, 0.5, 0.5, 0.5, 1.0, 0.5, 0.5, 0.5,& - ! 0.5 /) + !=(/17.0, 35.0, 17.0, 20.0, 20.0, 0.5, 0.5, 0.5,& + ! 0.5, 0.5, 0.5, 0.5, 1.0, 0.5, 0.5, 0.5,& + ! 0.5 /) ! Look-up table canopy bottom height - REAL(r8), parameter, dimension(N_land_classification) :: hbot0_igbp & -! 01/06/2020, yuan: adjust hbop: grass/shrub -> 0, tree->1 + ! 01/06/2020, yuan: adjust hbop: grass/shrub -> 0, tree->1 + real(r8), parameter, dimension(N_land_classification) :: hbot0_igbp & =(/ 8.5, 1.0, 8.5, 11.5, 10.0, 0.1, 0.1, 0.1,& 0.1, 0.01, 0.01, 0.01, 0.3, 0.01, 0.01, 0.01,& 0.01 /) - !=(/ 1.0, 1.0, 1.0, 1.0, 1.0, 0.0, 0.0, 0.0,& - ! 0.1, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0,& - ! 0.0 /) + !=(/ 1.0, 1.0, 1.0, 1.0, 1.0, 0.0, 0.0, 0.0,& + ! 0.1, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0,& + ! 0.0 /) ! Look-up table vegetation fractional cover - REAL(r8), parameter, dimension(N_land_classification) :: fveg0_igbp & + real(r8), parameter, dimension(N_land_classification) :: fveg0_igbp & = 1.0 !(/.../) ! Look-up table stem area index !NOTE: now read from input NetCDF file - REAL(r8), parameter, dimension(N_land_classification) :: sai0_igbp & + real(r8), parameter, dimension(N_land_classification) :: sai0_igbp & =(/2.0, 2.0, 2.0, 2.0, 2.0, 0.5, 0.5, 0.5,& 0.5, 0.2, 0.2, 0.2, 0.2, 0.2, 0.0, 0.0,& 0.0 /) ! ratio to calculate roughness length z0m - REAL(r8), parameter, dimension(N_land_classification) :: z0mr_igbp = 0.1 + real(r8), parameter, dimension(N_land_classification) :: z0mr_igbp = 0.1 ! ratio to calculate displacement height d - REAL(r8), parameter, dimension(N_land_classification) :: displar_igbp = 0.667 + real(r8), parameter, dimension(N_land_classification) :: displar_igbp = 0.667 ! inverse&sqrt leaf specific dimension size 4 cm - REAL(r8), parameter, dimension(N_land_classification) :: sqrtdi_igbp = 5.0 + real(r8), parameter, dimension(N_land_classification) :: sqrtdi_igbp = 5.0 ! leaf angle distribution parameter - REAL(r8), parameter, dimension(N_land_classification) :: chil_igbp & + real(r8), parameter, dimension(N_land_classification) :: chil_igbp & = (/ 0.010, 0.100, 0.010, 0.250, 0.125, 0.010, 0.010, 0.010,& 0.010, -0.300, 0.100, -0.300, 0.010, -0.300, 0.010, 0.010,& 0.010 /) ! reflectance of green leaf in virsible band - REAL(r8), parameter, dimension(N_land_classification) :: rhol_vis_igbp & + real(r8), parameter, dimension(N_land_classification) :: rhol_vis_igbp & = (/0.070, 0.100, 0.070, 0.100, 0.070, 0.105, 0.105, 0.105,& 0.105, 0.105, 0.105, 0.105, 0.105, 0.105, 0.105, 0.105,& 0.105 /) ! reflectance of dead leaf in virsible band - REAL(r8), parameter, dimension(N_land_classification) :: rhos_vis_igbp & + real(r8), parameter, dimension(N_land_classification) :: rhos_vis_igbp & = (/0.160, 0.160, 0.160, 0.160, 0.160, 0.160, 0.160, 0.160,& 0.160, 0.360, 0.160, 0.360, 0.160, 0.360, 0.160, 0.160,& 0.160 /) ! reflectance of green leaf in near infrared band - REAL(r8), parameter, dimension(N_land_classification) :: rhol_nir_igbp & + real(r8), parameter, dimension(N_land_classification) :: rhol_nir_igbp & = (/0.350, 0.450, 0.350, 0.450, 0.400, 0.450, 0.450, 0.580,& 0.580, 0.580, 0.450, 0.580, 0.450, 0.580, 0.450, 0.450,& 0.580 /) ! reflectance of dead leaf in near infrared band - REAL(r8), parameter, dimension(N_land_classification) :: rhos_nir_igbp & + real(r8), parameter, dimension(N_land_classification) :: rhos_nir_igbp & = (/0.390, 0.390, 0.390, 0.390, 0.390, 0.390, 0.390, 0.390,& 0.390, 0.580, 0.390, 0.580, 0.390, 0.580, 0.390, 0.390,& 0.580 /) ! transmittance of green leaf in visible band - REAL(r8), parameter, dimension(N_land_classification) :: taul_vis_igbp & + real(r8), parameter, dimension(N_land_classification) :: taul_vis_igbp & = (/0.050, 0.050, 0.050, 0.050, 0.050, 0.050, 0.050, 0.050,& 0.050, 0.070, 0.050, 0.070, 0.050, 0.070, 0.050, 0.050,& 0.050 /) ! transmittance of dead leaf in visible band - REAL(r8), parameter, dimension(N_land_classification) :: taus_vis_igbp & + real(r8), parameter, dimension(N_land_classification) :: taus_vis_igbp & = (/0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001,& 0.001, 0.220, 0.001, 0.220, 0.001, 0.220, 0.001, 0.001,& 0.001 /) ! transmittance of green leaf in near infrared band - REAL(r8), parameter, dimension(N_land_classification) :: taul_nir_igbp & + real(r8), parameter, dimension(N_land_classification) :: taul_nir_igbp & = (/0.100, 0.250, 0.100, 0.250, 0.150, 0.250, 0.250, 0.250,& 0.250, 0.250, 0.250, 0.250, 0.250, 0.250, 0.250, 0.250,& 0.250 /) ! transmittance of dead leaf in near infrared band - REAL(r8), parameter, dimension(N_land_classification) :: taus_nir_igbp & + real(r8), parameter, dimension(N_land_classification) :: taus_nir_igbp & = (/0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001,& 0.001, 0.380, 0.001, 0.380, 0.001, 0.380, 0.001, 0.001,& 0.001 /) ! maximum carboxylation rate at 25 C at canopy top ! /06/03/2014/ based on Bonan et al., 2010 (Table 2) - REAL(r8), parameter, dimension(N_land_classification) :: vmax25_igbp & + real(r8), parameter, dimension(N_land_classification) :: vmax25_igbp & = (/ 54.0, 72.0, 57.0, 52.0, 52.0, 52.0, 52.0, 52.0,& 52.0, 52.0, 52.0, 57.0,100.0, 57.0, 52.0, 52.0,& 52.0 /) ! quantum efficiency !TODO: no C4 - REAL(r8), parameter, dimension(N_land_classification) :: effcon_igbp & + real(r8), parameter, dimension(N_land_classification) :: effcon_igbp & = (/0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08,& 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08,& 0.08 /) ! conductance-photosynthesis slope parameter - REAL(r8), parameter, dimension(N_land_classification) :: gradm_igbp & + real(r8), parameter, dimension(N_land_classification) :: g1_igbp & + = (/9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0,& + 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0,& + 9.0 /) + + ! conductance-photosynthesis intercept + real(r8), parameter, dimension(N_land_classification) :: g0_igbp & + = (/100, 100, 100, 100, 100, 100, 100, 100,& + 100, 100, 100, 100, 100, 100, 100, 100,& + 100 /) + + ! conductance-photosynthesis slope parameter + real(r8), parameter, dimension(N_land_classification) :: gradm_igbp & = (/9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0,& 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0,& 9.0 /) ! conductance-photosynthesis intercept - REAL(r8), parameter, dimension(N_land_classification) :: binter_igbp & + real(r8), parameter, dimension(N_land_classification) :: binter_igbp & = (/0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01,& 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01,& 0.01 /) ! respiration fraction - REAL(r8), parameter, dimension(N_land_classification) :: respcp_igbp & + real(r8), parameter, dimension(N_land_classification) :: respcp_igbp & = (/0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015,& 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015,& 0.015 /) ! slope of high temperature inhibition FUNCTION (s1) - REAL(r8), parameter, dimension(N_land_classification) :: shti_igbp = 0.3 + real(r8), parameter, dimension(N_land_classification) :: shti_igbp = 0.3 ! slope of low temperature inhibition FUNCTION (s3) - REAL(r8), parameter, dimension(N_land_classification) :: slti_igbp = 0.2 + real(r8), parameter, dimension(N_land_classification) :: slti_igbp = 0.2 ! temperature coefficient in gs-a model (s5) - REAL(r8), parameter, dimension(N_land_classification) :: trda_igbp = 1.3 + real(r8), parameter, dimension(N_land_classification) :: trda_igbp = 1.3 ! temperature coefficient in gs-a model (s6) - REAL(r8), parameter, dimension(N_land_classification) :: trdm_igbp = 328.0 + real(r8), parameter, dimension(N_land_classification) :: trdm_igbp = 328.0 ! temperature coefficient in gs-a model (273.16+25) - REAL(r8), parameter, dimension(N_land_classification) :: trop_igbp = 298.0 + real(r8), parameter, dimension(N_land_classification) :: trop_igbp = 298.0 ! 1/2 point of high temperature inhibition FUNCTION (s2) - REAL(r8), parameter, dimension(N_land_classification) :: hhti_igbp & + real(r8), parameter, dimension(N_land_classification) :: hhti_igbp & =(/303.0, 313.0, 303.0, 311.0, 307.0, 308.0, 313.0, 313.0,& 313.0, 308.0, 313.0, 308.0, 308.0, 308.0, 303.0, 313.0,& 308.0 /) ! 1/2 point of low temperature inhibition FUNCTION (s4) - REAL(r8), parameter, dimension(N_land_classification) :: hlti_igbp & + real(r8), parameter, dimension(N_land_classification) :: hlti_igbp & =(/278.0, 288.0, 278.0, 283.0, 281.0, 281.0, 288.0, 288.0,& 288.0, 281.0, 283.0, 281.0, 281.0, 281.0, 278.0, 288.0,& 281.0 /) ! coefficient of leaf nitrogen allocation - REAL(r8), parameter, dimension(N_land_classification) :: extkn_igbp = 0.5 + real(r8), parameter, dimension(N_land_classification) :: extkn_igbp = 0.5 ! depth at 50% roots - REAL(r8), parameter, dimension(N_land_classification) :: d50_igbp & + real(r8), parameter, dimension(N_land_classification) :: d50_igbp & =(/15.0, 15.0, 16.0, 16.0, 15.5, 19.0, 28.0, 18.5,& 28.0, 9.0, 9.0, 22.0, 23.0, 22.0, 1.0, 9.0,& 1.0 /) ! coefficient of root profile - REAL(r8), parameter, dimension(N_land_classification) :: beta_igbp & + real(r8), parameter, dimension(N_land_classification) :: beta_igbp & =(/-1.623, -1.623, -1.681, -1.681, -1.652, -1.336, -1.909, -1.582,& -1.798, -1.359, -1.359, -1.796, -1.757, -1.796, -1.000, -2.261,& -1.000 /) @@ -505,71 +530,71 @@ MODULE MOD_Const_LC ! Table 2. Zeng, 2001 ! water/glacier ==> grass ! urban ==> cropland - REAL(r8), parameter, dimension(N_land_classification) :: roota_igbp & + real(r8), parameter, dimension(N_land_classification) :: roota_igbp & =(/ 6.706, 7.344, 7.066, 5.990, 4.453, 6.326, 7.718, 7.604,& 8.235, 10.740, 10.740, 5.558, 5.558, 5.558, 10.740, 4.372,& 10.740 /) - REAL(r8), parameter, dimension(N_land_classification) :: rootb_igbp & + real(r8), parameter, dimension(N_land_classification) :: rootb_igbp & =(/ 2.175, 1.303, 1.953, 1.955, 1.631, 1.567, 1.262, 2.300,& 1.627, 2.608, 2.608, 2.614, 2.614, 2.614, 2.608, 0.978,& 2.608 /) ! Plant Hydraulics Paramters - REAL(r8), parameter, dimension(N_land_classification) :: kmax_sun0_igbp & + real(r8), parameter, dimension(N_land_classification) :: kmax_sun0_igbp & = (/2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008, & 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008, & - 0. , 2.e-008, 0. , 0. , 0. /) + 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008 /) - REAL(r8), parameter, dimension(N_land_classification) :: kmax_sha0_igbp & + real(r8), parameter, dimension(N_land_classification) :: kmax_sha0_igbp & = (/2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008, & 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008, & - 0. , 2.e-008, 0. , 0. , 0. /) + 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008 /) - REAL(r8), parameter, dimension(N_land_classification) :: kmax_xyl0_igbp & + real(r8), parameter, dimension(N_land_classification) :: kmax_xyl0_igbp & = (/2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008, & 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008, & - 0. , 2.e-008, 0. , 0. , 0. /) + 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008 /) - REAL(r8), parameter, dimension(N_land_classification) :: kmax_root0_igbp & + real(r8), parameter, dimension(N_land_classification) :: kmax_root0_igbp & = (/2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008, & 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008, & - 0. , 2.e-008, 0. , 0. , 0. /) + 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008 /) ! water potential at 50% loss of sunlit leaf tissue conductance (mmH2O) - REAL(r8), parameter, dimension(N_land_classification) :: psi50_sun0_igbp & + real(r8), parameter, dimension(N_land_classification) :: psi50_sun0_igbp & = (/-465000.0, -260000.0, -380000.0, -270000.0, -330000.0, -393333.3, & -393333.3, -340000.0, -340000.0, -340000.0, -343636.4, -340000.0, & -150000.0, -343636.4, -150000.0, -150000.0, -150000.0/) *1 ! water potential at 50% loss of shaded leaf tissue conductance (mmH2O) - REAL(r8), parameter, dimension(N_land_classification) :: psi50_sha0_igbp & + real(r8), parameter, dimension(N_land_classification) :: psi50_sha0_igbp & = (/-465000.0, -260000.0, -380000.0, -270000.0, -330000.0, -393333.3, & -393333.3, -340000.0, -340000.0, -340000.0, -343636.4, -340000.0, & -150000.0, -343636.4, -150000.0, -150000.0, -150000.0/) *1 ! water potential at 50% loss of xylem tissue conductance (mmH2O) - REAL(r8), parameter, dimension(N_land_classification) :: psi50_xyl0_igbp & + real(r8), parameter, dimension(N_land_classification) :: psi50_xyl0_igbp & = (/-465000.0, -260000.0, -380000.0, -270000.0, -330000.0, -393333.3, & -393333.3, -340000.0, -340000.0, -340000.0, -343636.4, -340000.0, & -200000.0, -343636.4, -200000.0, -200000.0, -200000.0/) *1 ! water potential at 50% loss of root tissue conductance (mmH2O) - REAL(r8), parameter, dimension(N_land_classification) :: psi50_root0_igbp & + real(r8), parameter, dimension(N_land_classification) :: psi50_root0_igbp & = (/-465000.0, -260000.0, -380000.0, -270000.0, -330000.0, -393333.3, & -393333.3, -340000.0, -340000.0, -340000.0, -343636.4, -340000.0, & -200000.0, -343636.4, -200000.0, -200000.0, -200000.0/) *1 ! shape-fitting parameter for vulnerability curve (-) - REAL(r8), parameter, dimension(N_land_classification) :: ck0_igbp & + real(r8), parameter, dimension(N_land_classification) :: ck0_igbp & = (/3.95, 3.95, 3.95, 3.95, 3.95, 3.95, & 3.95, 3.95, 3.95, 3.95, 3.95, 3.95, & - 0. , 3.95, 0. , 0. , 0. /) + 3.95, 3.95, 0., 0., 0. /) !end plant hydraulic parameters #endif - REAL(r8), dimension(N_land_classification) :: & - patchtypes, &! land water types + real(r8), dimension(N_land_classification) :: & + patchtypes, &! land patch types htop0, &! canopy top height hbot0, &! canopy bottom height fveg0, &! canopy vegetation fractional cover @@ -581,6 +606,8 @@ MODULE MOD_Const_LC vmax25, &! maximum carboxylation rate at 25 C at canopy top effcon, &! quantum efficiency + g1, &! conductance-photosynthesis slope parameter + g0, &! conductance-photosynthesis intercept gradm, &! conductance-photosynthesis slope parameter binter, &! conductance-photosynthesis intercept respcp, &! respiration fraction @@ -597,11 +624,11 @@ MODULE MOD_Const_LC beta ! coefficient of root profile ! Plant Hydraulic Parameters - REAL(r8), dimension(N_land_classification) :: & - kmax_sun, & - kmax_sha, & - kmax_xyl, & - kmax_root, & + real(r8), dimension(N_land_classification) :: & + kmax_sun, &! Plant Hydraulics Paramters (TODO@Xingjie Lu, please give more details and below) + kmax_sha, &! Plant Hydraulics Paramters + kmax_xyl, &! Plant Hydraulics Paramters + kmax_root, &! Plant Hydraulics Paramters psi50_sun, &! water potential at 50% loss of sunlit leaf tissue conductance (mmH2O) psi50_sha, &! water potential at 50% loss of shaded leaf tissue conductance (mmH2O) psi50_xyl, &! water potential at 50% loss of xylem tissue conductance (mmH2O) @@ -609,19 +636,19 @@ MODULE MOD_Const_LC ck ! shape-fitting parameter for vulnerability curve (-) ! end plant hydraulic parameters - REAL(r8), PRIVATE, dimension(N_land_classification) :: & + real(r8), PRIVATE, dimension(N_land_classification) :: & roota, &! root fraction para rootb ! root fraction para - REAL(r8) :: & + real(r8) :: & rho(2,2,N_land_classification),&! leaf reflectance tau(2,2,N_land_classification) ! leaf transmittance ! scheme 1: Schenk and Jackson, 2002, 2: Zeng 2001 - INTEGER, PRIVATE :: ROOTFR_SCHEME = 1 + integer, PRIVATE :: ROOTFR_SCHEME = 1 ! fraction of roots in each soil layer - REAL(r8), dimension(nl_soil,N_land_classification) :: rootfr + real(r8), dimension(nl_soil,N_land_classification) :: rootfr ! PUBLIC MEMBER FUNCTIONS: PUBLIC :: Init_LC_Const @@ -632,7 +659,7 @@ SUBROUTINE Init_LC_Const IMPLICIT NONE - INTEGER :: i, nsl + integer :: i, nsl #ifdef LULC_USGS patchtypes (:) = patchtypes_usgs (:) @@ -646,6 +673,8 @@ SUBROUTINE Init_LC_Const chil (:) = chil_usgs (:) vmax25 (:) = vmax25_usgs (:) * 1.e-6 effcon (:) = effcon_usgs (:) + g1 (:) = g1_usgs (:) + g0 (:) = g0_usgs (:) gradm (:) = gradm_usgs (:) binter (:) = binter_usgs (:) respcp (:) = respcp_usgs (:) @@ -659,17 +688,17 @@ SUBROUTINE Init_LC_Const extkn (:) = extkn_usgs (:) d50 (:) = d50_usgs (:) beta (:) = beta_usgs (:) - if(DEF_USE_PLANTHYDRAULICS)then - kmax_sun (:) = kmax_sun0_usgs (:) - kmax_sha (:) = kmax_sha0_usgs (:) - kmax_xyl (:) = kmax_xyl0_usgs (:) - kmax_root (:) = kmax_root0_usgs (:) - psi50_sun (:) = psi50_sun0_usgs (:) - psi50_sha (:) = psi50_sha0_usgs (:) - psi50_xyl (:) = psi50_xyl0_usgs (:) - psi50_root (:) = psi50_root0_usgs(:) - ck (:) = ck0_usgs (:) - end if +IF (DEF_USE_PLANTHYDRAULICS) THEN + kmax_sun (:) = kmax_sun0_usgs (:) + kmax_sha (:) = kmax_sha0_usgs (:) + kmax_xyl (:) = kmax_xyl0_usgs (:) + kmax_root (:) = kmax_root0_usgs (:) + psi50_sun (:) = psi50_sun0_usgs (:) + psi50_sha (:) = psi50_sha0_usgs (:) + psi50_xyl (:) = psi50_xyl0_usgs (:) + psi50_root (:) = psi50_root0_usgs(:) + ck (:) = ck0_usgs (:) +ENDIF roota (:) = roota_usgs (:) rootb (:) = rootb_usgs (:) rho (1,1,:) = rhol_vis_usgs (:) @@ -692,6 +721,8 @@ SUBROUTINE Init_LC_Const chil (:) = chil_igbp (:) vmax25 (:) = vmax25_igbp (:) * 1.e-6 effcon (:) = effcon_igbp (:) + g1 (:) = g1_igbp (:) + g0 (:) = g0_igbp (:) gradm (:) = gradm_igbp (:) binter (:) = binter_igbp (:) respcp (:) = respcp_igbp (:) @@ -705,17 +736,17 @@ SUBROUTINE Init_LC_Const extkn (:) = extkn_igbp (:) d50 (:) = d50_igbp (:) beta (:) = beta_igbp (:) - if(DEF_USE_PLANTHYDRAULICS)then - kmax_sun (:) = kmax_sun0_igbp (:) - kmax_sha (:) = kmax_sha0_igbp (:) - kmax_xyl (:) = kmax_xyl0_igbp (:) - kmax_root (:) = kmax_root0_igbp (:) - psi50_sun (:) = psi50_sun0_igbp (:) - psi50_sha (:) = psi50_sha0_igbp (:) - psi50_xyl (:) = psi50_xyl0_igbp (:) - psi50_root (:) = psi50_root0_igbp(:) - ck (:) = ck0_igbp (:) - end if +IF(DEF_USE_PLANTHYDRAULICS)THEN + kmax_sun (:) = kmax_sun0_igbp (:) + kmax_sha (:) = kmax_sha0_igbp (:) + kmax_xyl (:) = kmax_xyl0_igbp (:) + kmax_root (:) = kmax_root0_igbp (:) + psi50_sun (:) = psi50_sun0_igbp (:) + psi50_sha (:) = psi50_sha0_igbp (:) + psi50_xyl (:) = psi50_xyl0_igbp (:) + psi50_root (:) = psi50_root0_igbp(:) + ck (:) = ck0_igbp (:) +ENDIF roota (:) = roota_igbp (:) rootb (:) = rootb_igbp (:) rho (1,1,:) = rhol_vis_igbp (:) @@ -735,30 +766,30 @@ SUBROUTINE Init_LC_Const ! ---------------------------------------------------------- IF (ROOTFR_SCHEME == 1) THEN DO i = 1, N_land_classification - rootfr(1,i)=1./(1.+(z_soih(1)*100./d50(i))**beta(i)) - rootfr(nl_soil,i)=1.-1./(1.+(z_soih(nl_soil-1)*100./d50(i))**beta(i)) + rootfr(1,i)=1./(1.+(zi_soi(1)*100./d50(i))**beta(i)) + rootfr(nl_soil,i)=1.-1./(1.+(zi_soi(nl_soil-1)*100./d50(i))**beta(i)) DO nsl=2,nl_soil-1 - rootfr(nsl,i)=1./(1.+(z_soih(nsl)*100./d50(i))**beta(i)) & - -1./(1.+(z_soih(nsl-1)*100./d50(i))**beta(i)) + rootfr(nsl,i)=1./(1.+(zi_soi(nsl)*100./d50(i))**beta(i)) & + -1./(1.+(zi_soi(nsl-1)*100./d50(i))**beta(i)) ENDDO ENDDO ELSE DO i = 1, N_land_classification rootfr(1,i) = 1. - 0.5*( & - exp(-roota(i) * z_soih(1)) & - + exp(-rootb(i) * z_soih(1)) ) + exp(-roota(i) * zi_soi(1)) & + + exp(-rootb(i) * zi_soi(1)) ) rootfr(nl_soil,i) = 0.5*( & - exp(-roota(i) * z_soih(nl_soil)) & - + exp(-rootb(i) * z_soih(nl_soil)) ) + exp(-roota(i) * zi_soi(nl_soil)) & + + exp(-rootb(i) * zi_soi(nl_soil)) ) DO nsl = 2, nl_soil-1 rootfr(nsl,i) = 0.5*( & - exp(-roota(i) * z_soih(nsl-1)) & - + exp(-rootb(i) * z_soih(nsl-1)) & - - exp(-roota(i) * z_soih(nsl)) & - - exp(-rootb(i) * z_soih(nsl)) ) + exp(-roota(i) * zi_soi(nsl-1)) & + + exp(-rootb(i) * zi_soi(nsl-1)) & + - exp(-roota(i) * zi_soi(nsl)) & + - exp(-rootb(i) * zi_soi(nsl)) ) ENDDO ENDDO ENDIF diff --git a/main/MOD_Const_PFT.F90 b/main/MOD_Const_PFT.F90 index 4b66593f..2f6a35bd 100644 --- a/main/MOD_Const_PFT.F90 +++ b/main/MOD_Const_PFT.F90 @@ -16,6 +16,7 @@ MODULE MOD_Const_PFT USE MOD_Precision USE MOD_Vars_Global USE MOD_TimeManager, only: get_calday + USE MOD_Namelist, only: DEF_USE_IRRIGATION IMPLICIT NONE SAVE @@ -103,7 +104,7 @@ MODULE MOD_Const_PFT !78 irrigated_tropical_soybean ! canopy layer number - INTEGER , parameter :: canlay(0:N_PFT+N_CFT-1) & + INTEGER , parameter :: canlay_p(0:N_PFT+N_CFT-1) & = (/0, 2, 2, 2, 2, 2, 2, 2 & , 2, 1, 1, 1, 1, 1, 1, 1 & #ifdef CROP @@ -135,11 +136,11 @@ MODULE MOD_Const_PFT /) ! canopy bottom height + ! 01/06/2020, yuan: adjust htop: grass/shrub -> 0, tree->1 REAL(r8), parameter :: hbot0_p(0:N_PFT+N_CFT-1) & -! 01/06/2020, yuan: adjust htop: grass/shrub -> 0, tree->1 - !TODO: check the setting values - !=(/0.01, 8.5, 8.5, 7.0, 1.0, 1.0, 10.0, 11.5& - ! 11.5, 0.1, 0.1, 0.1, 0.01, 0.01, 0.01, 0.01/) + !TODO: check the setting values + !=(/0.01, 8.5, 8.5, 7.0, 1.0, 1.0, 10.0, 11.5& + ! 11.5, 0.1, 0.1, 0.1, 0.01, 0.01, 0.01, 0.01/) =(/0.00, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0& , 1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0& #ifdef CROP @@ -357,10 +358,10 @@ MODULE MOD_Const_PFT ! maximum carboxylation rate at 25 C at canopy top ! /06/03/2014/ based on Bonan et al., 2011 (Table 2) - !REAL(r8), parameter :: vmax25_p(0:N_PFT+N_CFT-1) & - ! = (/ 52.0, 61.0, 54.0, 57.0, 72.0, 72.0, 52.0, 52.0& - ! , 52.0, 72.0, 52.0, 52.0, 52.0, 52.0, 52.0, 57.0& - ! /07/27/2022/ based on Bonan et al., 2011 (Table 2, VmaxF(N)) + !REAL(r8), parameter :: vmax25_p(0:N_PFT+N_CFT-1) & + ! = (/ 52.0, 61.0, 54.0, 57.0, 72.0, 72.0, 52.0, 52.0& + ! , 52.0, 72.0, 52.0, 52.0, 52.0, 52.0, 52.0, 57.0& + ! /07/27/2022/ based on Bonan et al., 2011 (Table 2, VmaxF(N)) REAL(r8), parameter :: vmax25_p(0:N_PFT+N_CFT-1) & = (/ 52.0, 55.0, 42.0, 29.0, 41.0, 51.0, 36.0, 30.0& , 40.0, 36.0, 30.0, 19.0, 21.0, 26.0, 25.0, 57.0& @@ -372,7 +373,7 @@ MODULE MOD_Const_PFT , 57.0, 57.0, 57.0, 57.0, 57.0, 57.0, 57.0, 57.0& , 57.0, 57.0, 57.0, 57.0, 57.0, 57.0, 57.0, 57.0& , 57.0, 57.0, 57.0, 57.0, 57.0, 57.0, 57.0, 57.0& - , 57.0, 57.0, 57.0, 57.0, 57.0, 57.0, 57.0 & + , 57.0, 57.0, 57.0, 57.0, 57.0, 57.0, 57.0 & #endif /) * 1.e-6 @@ -388,7 +389,39 @@ MODULE MOD_Const_PFT , 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08& , 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08& , 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08& - , 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08 & + , 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08 & +#endif + /) + + ! conductance-photosynthesis slope parameter + REAL(r8), parameter :: g1_p(0:N_PFT+N_CFT-1) & + = (/4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0& + , 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0& +#ifdef CROP + , 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0& + , 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0& + , 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0& + , 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0& + , 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0& + , 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0& + , 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0& + , 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0 & +#endif + /) + + ! conductance-photosynthesis intercept + REAL(r8), parameter :: g0_p(0:N_PFT+N_CFT-1) & + = (/100, 100, 100, 100, 100, 100, 100, 100& + , 100, 100, 100, 100, 100, 100, 100, 100& +#ifdef CROP + , 100, 100, 100, 100, 100, 100, 100, 100& + , 100, 100, 100, 100, 100, 100, 100, 100& + , 100, 100, 100, 100, 100, 100, 100, 100& + , 100, 100, 100, 100, 100, 100, 100, 100& + , 100, 100, 100, 100, 100, 100, 100, 100& + , 100, 100, 100, 100, 100, 100, 100, 100& + , 100, 100, 100, 100, 100, 100, 100, 100& + , 100, 100, 100, 100, 100, 100, 100 & #endif /) @@ -404,7 +437,7 @@ MODULE MOD_Const_PFT , 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0& , 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0& , 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0& - , 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0 & + , 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0 & #endif /) @@ -420,7 +453,7 @@ MODULE MOD_Const_PFT , 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01& , 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01& , 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01& - , 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01 & + , 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01 & #endif /) @@ -436,7 +469,7 @@ MODULE MOD_Const_PFT , 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015& , 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015& , 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015& - , 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015 & + , 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015 & #endif /) @@ -467,7 +500,7 @@ MODULE MOD_Const_PFT ,308.0, 308.0, 308.0, 308.0, 308.0, 308.0, 308.0, 308.0& ,308.0, 308.0, 308.0, 308.0, 308.0, 308.0, 308.0, 308.0& ,308.0, 308.0, 308.0, 308.0, 308.0, 308.0, 308.0, 308.0& - ,308.0, 308.0, 308.0, 308.0, 308.0, 308.0, 308.0 & + ,308.0, 308.0, 308.0, 308.0, 308.0, 308.0, 308.0 & #endif /) @@ -483,7 +516,7 @@ MODULE MOD_Const_PFT ,281.0, 281.0, 281.0, 281.0, 281.0, 281.0, 281.0, 281.0& ,281.0, 281.0, 281.0, 281.0, 281.0, 281.0, 281.0, 281.0& ,281.0, 281.0, 281.0, 281.0, 281.0, 281.0, 281.0, 281.0& - ,281.0, 281.0, 281.0, 281.0, 281.0, 281.0, 281.0 & + ,281.0, 281.0, 281.0, 281.0, 281.0, 281.0, 281.0 & #endif /) @@ -511,7 +544,7 @@ MODULE MOD_Const_PFT ,22.0, 22.0, 22.0, 22.0, 22.0, 22.0, 22.0, 22.0& ,22.0, 22.0, 22.0, 22.0, 22.0, 22.0, 22.0, 22.0& ,22.0, 22.0, 22.0, 22.0, 22.0, 22.0, 22.0, 22.0& - ,22.0, 22.0, 22.0, 22.0, 22.0, 22.0, 22.0 & + ,22.0, 22.0, 22.0, 22.0, 22.0, 22.0, 22.0 & #endif /) @@ -527,7 +560,7 @@ MODULE MOD_Const_PFT , -1.796, -1.796, -1.796, -1.796, -1.796, -1.796, -1.796, -1.796& , -1.796, -1.796, -1.796, -1.796, -1.796, -1.796, -1.796, -1.796& , -1.796, -1.796, -1.796, -1.796, -1.796, -1.796, -1.796, -1.796& - , -1.796, -1.796, -1.796, -1.796, -1.796, -1.796, -1.796 & + , -1.796, -1.796, -1.796, -1.796, -1.796, -1.796, -1.796 & #endif /) @@ -538,7 +571,7 @@ MODULE MOD_Const_PFT , 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 & , 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 & , 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 & - , 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 & + , 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 & #endif /) @@ -554,7 +587,7 @@ MODULE MOD_Const_PFT , 6.0, 6.0, 6.0, 6.0, 6.0, 6.0, 6.0, 6.0& , 6.0, 6.0, 6.0, 6.0, 6.0, 6.0, 6.0, 6.0& , 6.0, 6.0, 6.0, 6.0, 6.0, 6.0, 6.0, 6.0& - , 6.0, 6.0, 6.0, 6.0, 6.0, 6.0, 6.0 & + , 6.0, 6.0, 6.0, 6.0, 6.0, 6.0, 6.0 & #endif /) @@ -569,7 +602,7 @@ MODULE MOD_Const_PFT , 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0& , 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0& , 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0& - , 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0 & + , 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0 & #endif /) @@ -1159,20 +1192,20 @@ MODULE MOD_Const_PFT , 0.035, 0.035, 0.035, 0.05, 0.05, 0.035, 0.035 & #endif /) -!--- crop variables +!--- crop variables --- REAL(r8),parameter, dimension(0:N_PFT+N_CFT-1) :: manunitro & ! Max fertilizer to be applied in total (kg N/m2) = (/ 0., 0., 0., 0., 0., 0., 0., 0. & , 0., 0., 0., 0., 0., 0., 0., 0. & #ifdef CROP - , 0., 0.0150, 0.0150, 0.0080, 0.0080, 0.0080, 0.0080, 0.0025 & - , 0.0025, 0.0080, 0.0080, 0.0080, 0.0080, 0.0080, 0.0080, 0.0080 & - , 0.0080, 0., 0., 0., 0., 0., 0., 0. & - , 0., 0.02, 0.02, 0., 0., 0., 0., 0. & + , 0., 0.0020, 0.0020, 0.0020, 0.0020, 0.0020, 0.0020, 0.0020 & + , 0.0020, 0.0020, 0.0020, 0.0020, 0.0020, 0.0020, 0.0020, 0.0020 & + , 0.0020, 0., 0., 0., 0., 0., 0., 0. & + , 0., 0.0020, 0.0020, 0., 0., 0., 0., 0. & , 0., 0., 0., 0., 0., 0., 0., 0. & - , 0., 0., 0., 0., 0., 0.02, 0.02, 0. & - , 0., 0., 0., 0.04, 0.04, 0., 0., 0. & - , 0., 0., 0., 0.03, 0.03, 0.05, 0.05 & + , 0., 0., 0., 0., 0., 0.0020, 0.0020, 0. & + , 0., 0., 0., 0.0020, 0.0020, 0., 0., 0. & + , 0., 0., 0., 0.0020, 0.0020, 0.0020, 0.0020 & #endif /) @@ -1429,61 +1462,61 @@ MODULE MOD_Const_PFT ! Plant Hydraulics Paramters REAL(r8), parameter :: kmax_sun_p(0:N_PFT+N_CFT-1) & - = (/ 0.,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008& - ,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008& + = (/ 0.,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& #ifdef CROP - ,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008& - ,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008& - ,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008& - ,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008& - ,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008& - ,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008& - ,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008& - ,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& #endif /) REAL(r8), parameter :: kmax_sha_p(0:N_PFT+N_CFT-1) & - = (/ 0.,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008& - ,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008& + = (/ 0.,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& #ifdef CROP - ,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008& - ,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008& - ,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008& - ,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008& - ,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008& - ,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008& - ,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008& - ,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& #endif /) REAL(r8), parameter :: kmax_xyl_p(0:N_PFT+N_CFT-1) & - = (/ 0.,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008& - ,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008& + = (/ 0.,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& #ifdef CROP - ,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008& - ,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008& - ,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008& - ,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008& - ,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008& - ,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008& - ,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008& - ,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& #endif /) REAL(r8), parameter :: kmax_root_p(0:N_PFT+N_CFT-1) & - = (/ 0.,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008& - ,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008& + = (/ 0.,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& #ifdef CROP - ,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008& - ,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008& - ,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008& - ,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008& - ,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008& - ,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008& - ,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008& - ,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008,2.e-008& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& #endif /) @@ -1568,6 +1601,23 @@ MODULE MOD_Const_PFT /) !end plant hydraulic parameters + ! irrigation parameter for irrigated crop + LOGICAL , parameter :: irrig_crop(0:N_PFT+N_CFT-1) & ! True => is tropical broadleaf evergreen tree + =(/.False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & +#ifdef CROP + , .True., .False., .True., .False., .True., .False., .True., .False. & + , .True., .False., .True., .False., .True., .False., .True., .False. & + , .True., .False., .True., .False., .True., .False., .True., .False. & + , .True., .False., .True., .False., .True., .False., .True., .False. & + , .True., .False., .True., .False., .True., .False., .True., .False. & + , .True., .False., .True., .False., .True., .False., .True., .False. & + , .True., .False., .True., .False., .True., .False., .True., .False. & + , .True., .False., .True., .False., .True., .False., .True. & +#endif + /) + + ! scheme 1: Zeng 2001, 2: Schenk and Jackson, 2002 INTEGER, PRIVATE :: ROOTFR_SCHEME = 1 @@ -1582,6 +1632,7 @@ MODULE MOD_Const_PFT INTEGER, PRIVATE :: i, nsl + ! PUBLIC MEMBER FUNCTIONS: PUBLIC :: Init_PFT_Const @@ -1606,12 +1657,12 @@ SUBROUTINE Init_PFT_Const #else DO i = 0, N_PFT-1 #endif - rootfr_p(1,i)=1./(1.+(z_soih(1)*100./d50_p(i))**beta_p(i)) - rootfr_p(nl_soil,i)=1.-1./(1.+(z_soih(nl_soil-1)*100./d50_p(i))**beta_p(i)) + rootfr_p(1,i)=1./(1.+(zi_soi(1)*100./d50_p(i))**beta_p(i)) + rootfr_p(nl_soil,i)=1.-1./(1.+(zi_soi(nl_soil-1)*100./d50_p(i))**beta_p(i)) DO nsl=2,nl_soil-1 - rootfr_p(nsl,i)=1./(1.+(z_soih(nsl)*100./d50_p(i))**beta_p(i)) & - -1./(1.+(z_soih(nsl-1)*100./d50_p(i))**beta_p(i)) + rootfr_p(nsl,i)=1./(1.+(zi_soi(nsl)*100./d50_p(i))**beta_p(i)) & + -1./(1.+(zi_soi(nsl-1)*100./d50_p(i))**beta_p(i)) ENDDO ENDDO ELSE @@ -1622,19 +1673,19 @@ SUBROUTINE Init_PFT_Const DO i = 0, N_PFT-1 #endif rootfr_p(1,i) = 1. - 0.5*( & - exp(-roota(i) * z_soih(1)) & - + exp(-rootb(i) * z_soih(1)) ) + exp(-roota(i) * zi_soi(1)) & + + exp(-rootb(i) * zi_soi(1)) ) rootfr_p(nl_soil,i) = 0.5*( & - exp(-roota(i) * z_soih(nl_soil)) & - + exp(-rootb(i) * z_soih(nl_soil)) ) + exp(-roota(i) * zi_soi(nl_soil)) & + + exp(-rootb(i) * zi_soi(nl_soil)) ) DO nsl = 2, nl_soil-1 rootfr_p(nsl,i) = 0.5*( & - exp(-roota(i) * z_soih(nsl-1)) & - + exp(-rootb(i) * z_soih(nsl-1)) & - - exp(-roota(i) * z_soih(nsl)) & - - exp(-rootb(i) * z_soih(nsl)) ) + exp(-roota(i) * zi_soi(nsl-1)) & + + exp(-rootb(i) * zi_soi(nsl-1)) & + - exp(-roota(i) * zi_soi(nsl)) & + - exp(-rootb(i) * zi_soi(nsl)) ) ENDDO ENDDO ENDIF @@ -1643,3 +1694,4 @@ SUBROUTINE Init_PFT_Const END SUBROUTINE Init_PFT_Const END MODULE MOD_Const_PFT +! ---------- EOP ------------ diff --git a/main/MOD_CropData.F90 b/main/MOD_CropData.F90 deleted file mode 100644 index 04ba2a70..00000000 --- a/main/MOD_CropData.F90 +++ /dev/null @@ -1,123 +0,0 @@ -#include - -#ifdef CROP -MODULE MOD_CropData - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! This module read in crop data. - ! - ! !ORIGINAL: - ! Lu Xingjie and Zhang Shupeng, 2023, prepare the original version of the crop data module. - - USE MOD_Grid - USE MOD_Mapping_Grid2Pset - use MOD_BGC_Vars_TimeVariables, only : pdrice2 - USE MOD_BGC_Vars_PFTimeVariables, only : plantdate_p, fertnitro_p - IMPLICIT NONE - - CHARACTER(len=256) :: file_crop - - TYPE(grid_type) :: grid_crop - type(mapping_grid2pset_type) :: mg2p_crop - -CONTAINS - - ! ---------- - SUBROUTINE init_crop_data () - - !---------------------- - ! DESCTIPTION: - ! open crop netcdf file from DEF_dir_runtime, read latitude and longitude info. - ! Initialize crop data read in. - - use MOD_TimeManager - USE MOD_Namelist - USE MOD_Grid - USE MOD_NetCDFSerial - USE MOD_LandPatch - IMPLICIT NONE - - ! Local Variables - REAL(r8), allocatable :: lat(:), lon(:) - - file_crop = trim(DEF_dir_runtime) // '/crop/fcrop_colm_hist_simyr1849-2006_1.9x2.5_c100428.nc' - - CALL ncio_read_bcast_serial (file_crop, 'lat', lat) - CALL ncio_read_bcast_serial (file_crop, 'lon', lon) - - CALL grid_crop%define_by_center (lat, lon) - - call mg2p_crop%build (grid_crop, landpatch) - - IF (allocated(lon)) deallocate(lon) - IF (allocated(lat)) deallocate(lat) - - CALL update_crop_data (YY, iswrite = .true.) - - END SUBROUTINE init_crop_data - - ! ---------- - SUBROUTINE update_crop_data (YY, iswrite) -! =========================================================== -! -! !DESCRIPTION: -! Read in the Nitrogen deposition data from CLM5. -! -! !REFERENCE: -! Galloway, J.N., et al. 2004. Nitrogen cycles: past, present, and future. Biogeochem. 70:153-226. -! -! !ORIGINAL: -! Created by Xingjie Lu and Shupeng Zhang, 2022 -! =========================================================== - - use MOD_SPMD_Task - USE MOD_Namelist, only : DEF_USE_PN - USE MOD_DataType - USE MOD_NetCDFBlock - use MOD_LandPatch - use MOD_Vars_TimeInvariants - USE MOD_RangeCheck - IMPLICIT NONE - - integer, intent(in) :: YY - logical, INTENT(in) :: iswrite - - ! Local Variables - TYPE(block_data_real8_2d) :: f_xy_crop - integer :: itime, npatch, m - - itime = max(min(YY,2006),1849) - 1848 - - IF (p_is_io) THEN - CALL allocate_block_data (grid_crop, f_xy_crop) - CALL ncio_read_block_time (file_crop, 'crop_year', grid_crop, itime, f_xy_crop) - ENDIF - - call mg2p_crop%map_aweighted (f_xy_crop, crop) - - if (p_is_worker .and. iswrite) then - if (numpatch > 0) then - do npatch = 1, numpatch - m = patchclass(npatch) - if(m == 0)then - crop_to_sminn(npatch) = 0. - else - if(DEF_USE_PN)then - crop_to_sminn(npatch) = crop(npatch) / 3600. / 365. / 24. * 5 - else - crop_to_sminn(npatch) = crop(npatch) / 3600. / 365. / 24. - end if - end if - end do - - ENDIF - ENDIF - -#ifdef RangeCheck - call check_vector_data ('crop', crop) -#endif - - END SUBROUTINE update_crop_data - -END MODULE MOD_CropData -#endif diff --git a/main/MOD_CropReadin.F90 b/main/MOD_CropReadin.F90 index f1ff8b29..8e4f831e 100644 --- a/main/MOD_CropReadin.F90 +++ b/main/MOD_CropReadin.F90 @@ -36,24 +36,32 @@ SUBROUTINE CROP_readin () USE MOD_LandPFT USE MOD_Vars_PFTimeVariables USE MOD_RangeCheck + USE MOD_Block IMPLICIT NONE CHARACTER(len=256) :: file_crop - TYPE(grid_type) :: grid_crop + TYPE(grid_type) :: grid_crop TYPE(block_data_real8_2d) :: f_xy_crop type(mapping_grid2pset_type) :: mg2patch_crop type(mapping_grid2pset_type) :: mg2pft_crop + CHARACTER(len=256) :: file_irrig + TYPE(grid_type) :: grid_irrig + TYPE(block_data_int32_2d) :: f_xy_irrig + type(mapping_grid2pset_type) :: mg2pft_irrig - real(r8),allocatable :: pdrice2_tmp (:) - real(r8),allocatable :: plantdate_tmp (:) - real(r8),allocatable :: fertnitro_tmp (:) + real(r8),allocatable :: pdrice2_tmp (:) + real(r8),allocatable :: plantdate_tmp (:) + real(r8),allocatable :: fertnitro_tmp (:) + integer ,allocatable :: irrig_method_tmp (:) ! Local variables REAL(r8), allocatable :: lat(:), lon(:) real(r8) :: missing_value integer :: cft, npatch, ipft CHARACTER(LEN=2) :: cx + integer :: iblkme, iblk, jblk + integer :: maxvalue, minvalue ! READ in crops file_crop = trim(DEF_dir_runtime) // '/crop/plantdt-colm-64cfts-rice2_fillcoast.nc' @@ -88,6 +96,7 @@ SUBROUTINE CROP_readin () IF (numpatch > 0) allocate(pdrice2_tmp (numpatch)) IF (numpft > 0) allocate(plantdate_tmp (numpft)) IF (numpft > 0) allocate(fertnitro_tmp (numpft)) + IF (numpft > 0) allocate(irrig_method_tmp (numpft)) ENDIF ! (1) Read in plant date for rice2. @@ -160,7 +169,7 @@ SUBROUTINE CROP_readin () IF(landpft%settyp(ipft) .eq. cft)THEN fertnitro_p(ipft) = fertnitro_tmp(ipft) if(fertnitro_p(ipft) <= 0._r8) then - fertnitro_p(ipft) = -99999999._r8 + fertnitro_p(ipft) = 0._r8 end if endif end do @@ -171,9 +180,56 @@ SUBROUTINE CROP_readin () CALL check_vector_data ('fert nitro value ', fertnitro_p) #endif - IF (allocated (pdrice2_tmp )) deallocate(pdrice2_tmp ) - IF (allocated (plantdate_tmp)) deallocate(plantdate_tmp) - IF (allocated (fertnitro_tmp)) deallocate(fertnitro_tmp) + ! (4) Read in irrigation method +! file_irrig = trim(DEF_dir_runtime) // '/crop/surfdata_irrigation_method.nc' + file_irrig = trim(DEF_dir_runtime) // '/crop/surfdata_irrigation_method_96x144.nc' + + CALL ncio_read_bcast_serial (file_irrig, 'lat', lat) + CALL ncio_read_bcast_serial (file_irrig, 'lon', lon) + + CALL grid_irrig%define_by_center (lat, lon) + + IF (p_is_io) THEN + CALL allocate_block_data (grid_irrig, f_xy_irrig) + ENDIF + + call mg2pft_irrig%build (grid_irrig, landpft) + + IF (allocated(lon)) deallocate(lon) + IF (allocated(lat)) deallocate(lat) + + IF (p_is_worker) THEN + irrig_method_p(:) = -99999999 + ENDIF + + DO cft = 1, N_CFT + IF (p_is_io) THEN + CALL ncio_read_block_time (file_irrig, 'irrigation_method', grid_irrig, cft, f_xy_irrig) + ENDIF + + call mg2pft_irrig%map_max_frenquency_2d (f_xy_irrig, irrig_method_tmp) + + if (p_is_worker) then + do ipft = 1, numpft + + IF(landpft%settyp(ipft) .eq. cft + 14)THEN + irrig_method_p(ipft) = irrig_method_tmp(ipft) + if(irrig_method_p(ipft) < 0) then + irrig_method_p(ipft) = -99999999 + end if + endif + end do + ENDIF + ENDDO + +#ifdef RangeCheck + CALL check_vector_data ('irrigation method ', irrig_method_p) +#endif + + IF (allocated (pdrice2_tmp )) deallocate(pdrice2_tmp ) + IF (allocated (plantdate_tmp)) deallocate(plantdate_tmp) + IF (allocated (fertnitro_tmp)) deallocate(fertnitro_tmp) + IF (allocated (irrig_method_tmp)) deallocate(irrig_method_tmp) END SUBROUTINE CROP_readin diff --git a/main/MOD_Forcing.F90 b/main/MOD_Forcing.F90 index d01c0f7d..e24809f5 100644 --- a/main/MOD_Forcing.F90 +++ b/main/MOD_Forcing.F90 @@ -42,17 +42,24 @@ module MOD_Forcing ! local variables integer :: deltim_int ! model time step length - real(r8) :: deltim_real ! model time step length + ! real(r8) :: deltim_real ! model time step length ! for SinglePoint TYPE(timestamp), allocatable :: forctime (:) - INTEGER, allocatable :: iforctime(:) + INTEGER, allocatable :: iforctime(:) + + logical :: forcing_read_ahead + real(r8), allocatable :: forc_disk(:,:) type(timestamp), allocatable :: tstamp_LB(:) ! time stamp of low boundary data type(timestamp), allocatable :: tstamp_UB(:) ! time stamp of up boundary data type(block_data_real8_2d) :: avgcos ! time-average of cos(zenith) type(block_data_real8_2d) :: metdata ! forcing data +#ifdef URBAN_MODEL + type(block_data_real8_2d) :: rainf + type(block_data_real8_2d) :: snowf +#endif type(block_data_real8_2d), allocatable :: forcn (:) ! forcing data type(block_data_real8_2d), allocatable :: forcn_LB (:) ! forcing data at lower bondary @@ -64,7 +71,7 @@ module MOD_Forcing contains !-------------------------------- - subroutine forcing_init (dir_forcing, deltatime, idate, lc_year) + subroutine forcing_init (dir_forcing, deltatime, ststamp, lc_year, etstamp) use MOD_SPMD_Task USE MOD_Namelist @@ -72,6 +79,9 @@ subroutine forcing_init (dir_forcing, deltatime, idate, lc_year) USE MOD_Mesh USE MOD_LandElm USE MOD_LandPatch +#ifdef CROP + USE MOD_LandCrop +#endif use MOD_Mapping_Grid2Pset use MOD_UserSpecifiedForcing USE MOD_NetCDFSerial @@ -82,13 +92,14 @@ subroutine forcing_init (dir_forcing, deltatime, idate, lc_year) implicit none character(len=*), intent(in) :: dir_forcing - real(r8), intent(in) :: deltatime ! model time step - integer, intent(in) :: idate(3) + real(r8), intent(in) :: deltatime ! model time step + type(timestamp), intent(in) :: ststamp INTEGER, intent(in) :: lc_year ! which year of land cover data used + type(timestamp), intent(in), optional :: etstamp ! Local variables + integer :: idate(3) CHARACTER(len=256) :: filename, lndname, cyear - type(timestamp) :: mtstamp integer :: ivar, year, month, day, time_i REAL(r8) :: missing_value INTEGER :: ielm, istt, iend @@ -100,7 +111,7 @@ subroutine forcing_init (dir_forcing, deltatime, idate, lc_year) ! get value of fmetdat and deltim deltim_int = int(deltatime) - deltim_real = deltatime + ! deltim_real = deltatime ! set initial values IF (allocated(tstamp_LB)) deallocate(tstamp_LB) @@ -110,6 +121,8 @@ subroutine forcing_init (dir_forcing, deltatime, idate, lc_year) tstamp_LB(:) = timestamp(-1, -1, -1) tstamp_UB(:) = timestamp(-1, -1, -1) + idate = (/ststamp%year, ststamp%day, ststamp%sec/) + call metread_latlon (dir_forcing, idate) if (p_is_io) then @@ -130,6 +143,10 @@ subroutine forcing_init (dir_forcing, deltatime, idate, lc_year) ! allocate memory for forcing data call allocate_block_data (gforc, metdata) ! forcing data call allocate_block_data (gforc, avgcos ) ! time-average of cos(zenith) +#if(defined URBAN_MODEL && defined SinglePoint) + call allocate_block_data (gforc, rainf) + call allocate_block_data (gforc, snowf) +#endif end if @@ -139,8 +156,7 @@ subroutine forcing_init (dir_forcing, deltatime, idate, lc_year) call mg2p_forc_elm%build (gforc, landelm) ENDIF ELSE - mtstamp = idate - call setstampLB(mtstamp, 1, year, month, day, time_i) + call setstampLB(ststamp, 1, year, month, day, time_i) filename = trim(dir_forcing)//trim(metfilename(year, month, day, 1)) tstamp_LB(1) = timestamp(-1, -1, -1) @@ -158,7 +174,7 @@ subroutine forcing_init (dir_forcing, deltatime, idate, lc_year) ENDIF IF (p_is_master) THEN - CALL ncio_get_attr (filename, vname(1), 'missing_value', missing_value) + CALL ncio_get_attr (filename, vname(1), trim(DEF_forcing%missing_value_name), missing_value) ENDIF #ifdef USEMPI CALL mpi_bcast (missing_value, 1, MPI_REAL8, p_root, p_comm_glb, p_err) @@ -179,7 +195,7 @@ subroutine forcing_init (dir_forcing, deltatime, idate, lc_year) IF (p_is_worker) THEN #if (defined CROP) - CALL elm_patch%build (landelm, landpatch, use_frac = .true., shadowfrac = pctcrop) + CALL elm_patch%build (landelm, landpatch, use_frac = .true., sharedfrac = pctshrpch) #else CALL elm_patch%build (landelm, landpatch, use_frac = .true.) #endif @@ -198,13 +214,61 @@ subroutine forcing_init (dir_forcing, deltatime, idate, lc_year) ENDIF - IF (trim(DEF_forcing%dataset) == 'POINT') THEN - CALL metread_time (dir_forcing) + forcing_read_ahead = .false. + IF (trim(DEF_forcing%dataset) == 'POINT') then + IF (USE_SITE_ForcingReadAhead .and. present(etstamp)) THEN + forcing_read_ahead = .true. + CALL metread_time (dir_forcing, ststamp, etstamp, deltatime) + ELSE + CALL metread_time (dir_forcing) + ENDIF allocate (iforctime(NVAR)) ENDIF + IF (trim(DEF_forcing%dataset) == 'POINT') then + + filename = trim(dir_forcing)//trim(fprefix(1)) + +#ifndef URBAN_MODEL + IF (ncio_var_exist(filename,'reference_height_v')) THEN + CALL ncio_read_serial (filename, 'reference_height_v', Height_V) + ENDIF + + IF (ncio_var_exist(filename,'reference_height_t')) THEN + CALL ncio_read_serial (filename, 'reference_height_t', Height_T) + ENDIF + + IF (ncio_var_exist(filename,'reference_height_q')) THEN + CALL ncio_read_serial (filename, 'reference_height_q', Height_Q) + ENDIF +#else + IF (ncio_var_exist(filename,'measurement_height_above_ground')) THEN + CALL ncio_read_serial (filename, 'measurement_height_above_ground', Height_V) + CALL ncio_read_serial (filename, 'measurement_height_above_ground', Height_T) + CALL ncio_read_serial (filename, 'measurement_height_above_ground', Height_Q) + ENDIF +#endif + + ENDIF + end subroutine forcing_init + ! ---- forcing finalize ---- + SUBROUTINE forcing_final () + + IMPLICIT NONE + + IF (allocated(forcmask )) deallocate(forcmask ) + IF (allocated(forcmask_elm)) deallocate(forcmask_elm) + IF (allocated(glacierss )) deallocate(glacierss ) + IF (allocated(forctime )) deallocate(forctime ) + IF (allocated(iforctime )) deallocate(iforctime ) + IF (allocated(forc_disk )) deallocate(forc_disk ) + IF (allocated(tstamp_LB )) deallocate(tstamp_LB ) + IF (allocated(tstamp_UB )) deallocate(tstamp_UB ) + + END SUBROUTINE forcing_final + ! ------------ SUBROUTINE forcing_reset () @@ -266,7 +330,7 @@ SUBROUTINE read_forcing (idate, dir_forcing) ! set model time stamp id(:) = idate(:) - call adj2end(id) + !call adj2end(id) mtstamp = id has_u = .true. @@ -282,7 +346,7 @@ SUBROUTINE read_forcing (idate, dir_forcing) ! to make sure the forcing data calculated is in the range of time ! interval [LB, UB] if ( (mtstamp < tstamp_LB(ivar)) .or. (tstamp_UB(ivar) < mtstamp) ) then - write(6, *) "the data required is out of range! stop!"; stop + write(6, *) "the data required is out of range! stop!"; CALL CoLM_stop() end if ! calcualte distance to lower/upper boundary @@ -363,7 +427,10 @@ SUBROUTINE read_forcing (idate, dir_forcing) call block_data_copy (forcn(6), forc_xy_us , sca = 1/sqrt(2.0_r8)) call block_data_copy (forcn(6), forc_xy_vs , sca = 1/sqrt(2.0_r8)) ELSE - write(6, *) "At least one of the wind components must be provided! stop!"; stop + if (.not.trim(DEF_forcing%dataset) == 'CPL7') then + write(6, *) "At least one of the wind components must be provided! stop!"; + CALL CoLM_stop() + ENDIF ENDIF call flush_block_data (forc_xy_hgt_u, real(HEIGHT_V,r8)) @@ -598,7 +665,9 @@ SUBROUTINE metreadLBUB (idate, dir_forcing) use MOD_UserSpecifiedForcing USE MOD_Namelist + USE MOD_Block use MOD_DataType + use MOD_Block use MOD_NetCDFBlock use MOD_RangeCheck implicit none @@ -608,6 +677,7 @@ SUBROUTINE metreadLBUB (idate, dir_forcing) ! Local variables integer :: ivar, year, month, day, time_i + INTEGER :: iblkme, ib, jb, i, j type(timestamp) :: mtstamp character(len=256) :: filename @@ -619,7 +689,7 @@ SUBROUTINE metreadLBUB (idate, dir_forcing) ! lower and upper boundary data already exist, cycle if ( .NOT.(tstamp_LB(ivar)=='NULL') .AND. .NOT.(tstamp_UB(ivar)=='NULL') .AND. & - tstamp_LB(ivar)<=mtstamp .AND. mtstamp<=tstamp_UB(ivar) ) then + tstamp_LB(ivar)<=mtstamp .AND. mtstamp 1) THEN - forctime(itime) = forctime(itime-1) - sec_long = sec_long + forctime_sec(itime) - forctime_sec(itime-1) + IF ((ststamp < forctime(1)) .or. (etstamp_f < etstamp)) THEN + write(*,*) 'Error: Forcing does not cover simulation period!' + write(*,*) 'Model start ', ststamp, ' -> Model end ', etstamp + write(*,*) 'Forc start ', forctime(1), ' -> Forc end ', etstamp_f + CALL CoLM_stop () + ELSE + its = 1 + DO WHILE (.not. (ststamp < forctime(its+1))) + its = its + 1 + IF (its >= ntime) EXIT + ENDDO + + ite = ntime + DO WHILE (etstamp < forctime(ite-1)) + ite = ite - 1 + IF (ite <= 1) EXIT + ENDDO + + ntime = ite-its+1 + + allocate (forctime_(ntime)) + DO it = 1, ntime + forctime_(it) = forctime(it+its-1) + ENDDO + + deallocate (forctime) + allocate (forctime (ntime)) + DO it = 1, ntime + forctime(it) = forctime_(it) + ENDDO + + deallocate(forctime_) ENDIF - DO WHILE (sec_long > 86400) - sec_long = sec_long - 86400 - IF( isleapyear(forctime(itime)%year) ) THEN - maxday = 366 - ELSE - maxday = 365 - ENDIF - forctime(itime)%day = forctime(itime)%day + 1 - IF(forctime(itime)%day > maxday) THEN - forctime(itime)%year = forctime(itime)%year + 1 - forctime(itime)%day = 1 + allocate (forc_disk (size(forctime),NVAR)) + + filename = trim(dir_forcing)//trim(metfilename(-1,-1,-1,-1)) + DO ivar = 1, NVAR + if (trim(vname(ivar)) /= 'NULL') THEN + CALL ncio_read_period_serial (filename, vname(ivar), its, ite, metcache) + forc_disk(:,ivar) = metcache(1,1,:) ENDIF ENDDO - forctime(itime)%sec = sec_long - ENDDO + IF (allocated(metcache)) deallocate(metcache) + ENDIF END SUBROUTINE metread_time @@ -833,7 +1005,7 @@ SUBROUTINE setstampLB(mtstamp, var_i, year, month, mday, time_i) IF ((mtstamp < forctime(1)) .or. (forctime(ntime) < mtstamp)) THEN write(*,*) 'Error: Forcing does not cover simulation period!' write(*,*) 'Need ', mtstamp, ', Forc start ', forctime(1), ', Forc END', forctime(ntime) - stop + CALL CoLM_stop () ELSE DO WHILE (.not. (mtstamp < forctime(time_i+1))) time_i = time_i + 1 @@ -841,7 +1013,6 @@ SUBROUTINE setstampLB(mtstamp, var_i, year, month, mday, time_i) iforctime(var_i) = time_i tstamp_LB(var_i) = forctime(iforctime(var_i)) ENDIF - write(*,*) mtstamp, forctime(time_i) RETURN ENDIF @@ -854,12 +1025,12 @@ SUBROUTINE setstampLB(mtstamp, var_i, year, month, mday, time_i) ! calculate the intitial second sec = 86400*(day-1) + sec - time_i = floor( (sec-offset(var_i)-0.01) *1. / dtime(var_i) ) + 1 + time_i = floor( (sec-offset(var_i)) *1. / dtime(var_i) ) + 1 sec = (time_i-1)*dtime(var_i) + offset(var_i) - 86400*(day-1) tstamp_LB(var_i)%sec = sec ! set time stamp (ststamp_LB) - if (sec <= 0) then + if (sec < 0) then tstamp_LB(var_i)%sec = 86400 + sec tstamp_LB(var_i)%day = day - 1 if (tstamp_LB(var_i)%day == 0) then @@ -920,12 +1091,12 @@ SUBROUTINE setstampLB(mtstamp, var_i, year, month, mday, time_i) ! calculate initial second value sec = 86400*(mday-1) + sec - time_i = floor( (sec-offset(var_i)-0.01) *1. / dtime(var_i) ) + 1 + time_i = floor( (sec-offset(var_i)) *1. / dtime(var_i) ) + 1 sec = (time_i-1)*dtime(var_i) + offset(var_i) - 86400*(mday-1) tstamp_LB(var_i)%sec = sec ! set time stamp (ststamp_LB) - if (sec <= 0) then + if (sec < 0) then tstamp_LB(var_i)%sec = 86400 + sec tstamp_LB(var_i)%day = day - 1 if (tstamp_LB(var_i)%day == 0) then @@ -983,12 +1154,12 @@ SUBROUTINE setstampLB(mtstamp, var_i, year, month, mday, time_i) call julian2monthday(year, day, month, mday) ! calculate initial second value - time_i = floor( (sec-offset(var_i)-0.01) *1. / dtime(var_i) ) + 1 + time_i = floor( (sec-offset(var_i)) *1. / dtime(var_i) ) + 1 sec = (time_i-1)*dtime(var_i) + offset(var_i) tstamp_LB(var_i)%sec = sec ! set time stamp (ststamp_LB) - if (sec <= 0) then + if (sec < 0) then tstamp_LB(var_i)%sec = 86400 + sec tstamp_LB(var_i)%day = day - 1 if (tstamp_LB(var_i)%day == 0) then @@ -1021,7 +1192,7 @@ SUBROUTINE setstampLB(mtstamp, var_i, year, month, mday, time_i) end if if (time_i <= 0) then - write(6, *) "got the wrong time record of forcing! stop!"; stop + write(6, *) "got the wrong time record of forcing! stop!"; CALL CoLM_stop() end if return @@ -1055,10 +1226,10 @@ SUBROUTINE setstampUB(var_i, year, month, mday, time_i) ELSE iforctime(var_i) = iforctime(var_i) + 1 tstamp_LB(var_i) = forctime(iforctime(var_i)) - tstamp_UB(var_i) = forctime(iforctime(var_i) + 1) + tstamp_UB(var_i) = forctime(iforctime(var_i)+1) ENDIF - time_i = iforctime(var_i) + time_i = iforctime(var_i)+1 year = tstamp_UB(var_i)%year RETURN ENDIF @@ -1181,7 +1352,7 @@ SUBROUTINE setstampUB(var_i, year, month, mday, time_i) end if if (time_i < 0) then - write(6, *) "got the wrong time record of forcing! stop!"; stop + write(6, *) "got the wrong time record of forcing! stop!"; CALL CoLM_stop() end if return @@ -1195,23 +1366,30 @@ END SUBROUTINE setstampUB ! REVISIONS: ! 04/2014, yuan: this method is adapted from CLM ! ------------------------------------------------------------ - SUBROUTINE calavgcos() + SUBROUTINE calavgcos(idate) use MOD_Block use MOD_DataType implicit none - integer :: iblkme, ib, jb, i, j, ilon, ilat + integer, intent(in) :: idate(3) + + integer :: ntime, iblkme, ib, jb, i, j, ilon, ilat real(r8) :: calday, cosz type(timestamp) :: tstamp - tstamp = tstamp_LB(7) + tstamp = idate !tstamp_LB(7) + ntime = 0 + do while (tstamp < tstamp_UB(7)) + ntime = ntime + 1 + tstamp = tstamp + deltim_int + ENDDO + + tstamp = idate !tstamp_LB(7) call flush_block_data (avgcos, 0._r8) do while (tstamp < tstamp_UB(7)) - tstamp = tstamp + deltim_int - DO iblkme = 1, gblock%nblkme ib = gblock%xblkme(iblkme) jb = gblock%yblkme(iblkme) @@ -1226,11 +1404,14 @@ SUBROUTINE calavgcos() cosz = orb_coszen(calday, gforc%rlon(ilon), gforc%rlat(ilat)) cosz = max(0.001, cosz) avgcos%blk(ib,jb)%val(i,j) = avgcos%blk(ib,jb)%val(i,j) & - + cosz*deltim_real /real(tstamp_UB(7)-tstamp_LB(7)) + + cosz / real(ntime,r8) ! * deltim_real /real(tstamp_UB(7)-tstamp_LB(7)) end do end do end do + + tstamp = tstamp + deltim_int + end do END SUBROUTINE calavgcos diff --git a/main/MOD_Glacier.F90 b/main/MOD_Glacier.F90 index 1e0fea72..335e97cf 100644 --- a/main/MOD_Glacier.F90 +++ b/main/MOD_Glacier.F90 @@ -53,7 +53,7 @@ subroutine GLACIER_TEMP (patchtype, lb ,nl_ice ,deltim ,& errore ,emis ,z0m ,zol ,& rib ,ustar ,qstar ,tstar ,& fm ,fh ,fq ,pg_rain ,& - pg_snow ,t_precip ,snofrz ,sabg_lyr ) + pg_snow ,t_precip ,snofrz ,sabg_snow_lyr) !======================================================================= ! this is the main subroutine to execute the calculation @@ -81,7 +81,7 @@ subroutine GLACIER_TEMP (patchtype, lb ,nl_ice ,deltim ,& !---------------------Argument------------------------------------------ integer, INTENT(in) :: & - patchtype,& ! land water type (0=soil, 1=urban and built-up, 2=wetland, 3=land ice, 4=land water bodies, 99 = ocean) + patchtype,& ! land patch type (0=soil, 1=urban and built-up, 2=wetland, 3=land ice, 4=land water bodies, 99 = ocean) lb, &! lower bound of array nl_ice ! upper bound of array @@ -119,7 +119,7 @@ subroutine GLACIER_TEMP (patchtype, lb ,nl_ice ,deltim ,& zi_icesno(lb-1:nl_ice) ! interface depth [m] REAL(r8), intent(in) :: & - sabg_lyr (lb:1) ! snow layer absorption [W/m-2] + sabg_snow_lyr (lb:1) ! snow layer absorption [W/m-2] ! State variables (2) real(r8), INTENT(inout) :: & @@ -249,7 +249,7 @@ subroutine GLACIER_TEMP (patchtype, lb ,nl_ice ,deltim ,& call groundtem_glacier (patchtype,lb,nl_ice,deltim,& capr,cnfac,dz_icesno,z_icesno,zi_icesno,& t_icesno,wice_icesno,wliq_icesno,scv,snowdp,& - forc_frl,sabg,sabg_lyr,fseng,fevpg,cgrnd,htvp,emg,& + forc_frl,sabg,sabg_snow_lyr,fseng,fevpg,cgrnd,htvp,emg,& imelt,snofrz,sm,xmf,fact,pg_rain,pg_snow,t_precip) !======================================================================= @@ -295,7 +295,8 @@ subroutine GLACIER_TEMP (patchtype, lb ,nl_ice ,deltim ,& ! ground heat flux fgrnd = sabg + emg*forc_frl & - emg*stefnc*t_icesno_bef(lb)**3*(t_icesno_bef(lb) + 4.*tinc) & - - (fseng+fevpg*htvp) + cpliq * pg_rain * (t_precip - t_icesno(lb)) & + - (fseng+fevpg*htvp) & + + cpliq * pg_rain * (t_precip - t_icesno(lb)) & + cpice * pg_snow * (t_precip - t_icesno(lb)) ! outgoing long-wave radiation from ground @@ -313,17 +314,18 @@ subroutine GLACIER_TEMP (patchtype, lb ,nl_ice ,deltim ,& ! [6] energy balance error !======================================================================= - errore = sabg + forc_frl - olrg - fsena - lfevpa - xmf + & - cpliq * pg_rain * (t_precip - t_icesno(lb)) & - + cpice * pg_snow * (t_precip - t_icesno(lb)) + errore = sabg + forc_frl - olrg - fsena - lfevpa - xmf & + + cpliq * pg_rain * (t_precip-t_icesno(lb)) & + + cpice * pg_snow * (t_precip-t_icesno(lb)) do j = lb, nl_ice errore = errore - (t_icesno(j)-t_icesno_bef(j))/fact(j) enddo #if (defined CoLMDEBUG) if(abs(errore)>.2)then - write(6,*) 'GLACIER_TEMP.F90 : energy balance violation' + write(6,*) 'GLACIER_TEMP.F90 : energy balance violation' write(6,100) errore,sabg,forc_frl,olrg,fsena,lfevpa,xmf,t_precip,t_icesno(lb) + STOP endif 100 format(10(f7.3)) #endif @@ -564,7 +566,7 @@ end subroutine groundfluxes_glacier subroutine groundtem_glacier (patchtype,lb,nl_ice,deltim,& capr,cnfac,dz_icesno,z_icesno,zi_icesno,& t_icesno,wice_icesno,wliq_icesno,scv,snowdp,& - forc_frl,sabg,sabg_lyr,fseng,fevpg,cgrnd,htvp,emg,& + forc_frl,sabg,sabg_snow_lyr,fseng,fevpg,cgrnd,htvp,emg,& imelt,snofrz,sm,xmf,fact,pg_rain,pg_snow,t_precip) !======================================================================= @@ -600,7 +602,7 @@ subroutine groundtem_glacier (patchtype,lb,nl_ice,deltim,& IMPLICIT NONE - integer, INTENT(in) :: patchtype ! land water type (0=soil, 1=urban and built-up, + integer, INTENT(in) :: patchtype ! land patch type (0=soil, 1=urban and built-up, ! 2=wetland, 3=land ice, 4=land water bodies, 99 = ocean) integer, INTENT(in) :: lb !lower bound of array integer, INTENT(in) :: nl_ice !upper bound of array @@ -623,9 +625,9 @@ subroutine groundtem_glacier (patchtype,lb,nl_ice,deltim,& real(r8), INTENT(in) :: pg_rain ! rainfall [kg/(m2 s)] real(r8), INTENT(in) :: pg_snow ! snowfall [kg/(m2 s)] - REAL(r8), intent(in) :: sabg_lyr (lb:1) !snow layer absorption [W/m-2] + REAL(r8), intent(in) :: sabg_snow_lyr (lb:1) !snow layer absorption [W/m-2] - real(r8), INTENT(inout) :: t_icesno (lb:nl_ice) !snow and ice temperature [K] + real(r8), INTENT(inout) :: t_icesno (lb:nl_ice) !snow and ice temperature [K] real(r8), INTENT(inout) :: wice_icesno(lb:nl_ice) !ice lens [kg/m2] real(r8), INTENT(inout) :: wliq_icesno(lb:nl_ice) !liqui water [kg/m2] real(r8), INTENT(inout) :: scv !snow cover, water equivalent [mm, kg/m2] @@ -734,7 +736,7 @@ subroutine groundtem_glacier (patchtype,lb,nl_ice,deltim,& ! net ground heat flux into the surface and its temperature derivative IF (DEF_USE_SNICAR) THEN - hs = sabg_lyr(lb) + emg*forc_frl - emg*stefnc*t_icesno(lb)**4 - (fseng+fevpg*htvp) +& + hs = sabg_snow_lyr(lb) + emg*forc_frl - emg*stefnc*t_icesno(lb)**4 - (fseng+fevpg*htvp) +& cpliq * pg_rain * (t_precip - t_icesno(lb)) + cpice * pg_snow * (t_precip - t_icesno(lb)) ELSE hs = sabg + emg*forc_frl - emg*stefnc*t_icesno(lb)**4 - (fseng+fevpg*htvp) +& @@ -773,7 +775,7 @@ subroutine groundtem_glacier (patchtype,lb,nl_ice,deltim,& at(j) = - (1.-cnfac)*fact(j)* tk(j-1)/dzm bt(j) = 1.+ (1.-cnfac)*fact(j)*(tk(j)/dzp + tk(j-1)/dzm) ct(j) = - (1.-cnfac)*fact(j)* tk(j)/dzp - rt(j) = t_icesno(j) + fact(j)*sabg_lyr(j) + cnfac*fact(j)*( fn(j) - fn(j-1) ) + rt(j) = t_icesno(j) + fact(j)*sabg_snow_lyr(j) + cnfac*fact(j)*( fn(j) - fn(j-1) ) end do endif @@ -820,9 +822,12 @@ subroutine groundtem_glacier (patchtype,lb,nl_ice,deltim,& wice_icesno_bef(lb:0) = wice_icesno(lb:0) call meltf_snicar (patchtype,lb,nl_ice,deltim, & - fact(lb:),brr(lb:),hs,dhsdT,sabg_lyr, & - t_icesno_bef(lb:),t_icesno(lb:),wliq_icesno(lb:),wice_icesno(lb:),imelt(lb:), & - scv,snowdp,sm,xmf,porsl,psi0,& + !NOTE: compatibility settings for spliting soil&snow temproal input, + ! cause glacier patch doesn't support split soil&snow + ! hs_soil=hs, hs_snow=hs, fsno=1. not go into effect. + fact(lb:),brr(lb:),hs,hs,hs,1.,sabg_snow_lyr(lb:),dhsdT, & + t_icesno_bef(lb:),t_icesno(lb:),wliq_icesno(lb:),wice_icesno(lb:),imelt(lb:), & + scv,snowdp,sm,xmf,porsl,psi0,& #ifdef Campbell_SOIL_MODEL bsw,& #endif @@ -841,7 +846,10 @@ subroutine groundtem_glacier (patchtype,lb,nl_ice,deltim,& ELSE call meltf (patchtype,lb,nl_ice,deltim, & - fact(lb:),brr(lb:),hs,dhsdT, & + !NOTE: compatibility settings for spliting soil&snow temproal input, + ! cause glacier patch doesn't support split soil&snow + ! hs_soil=hs, hs_snow=hs, fsno=1. not go into effect. + fact(lb:),brr(lb:),hs,hs,hs,1.,dhsdT, & t_icesno_bef(lb:),t_icesno(lb:),wliq_icesno(lb:),wice_icesno(lb:),imelt(lb:), & scv,snowdp,sm,xmf,porsl,psi0,& #ifdef Campbell_SOIL_MODEL @@ -865,7 +873,7 @@ subroutine GLACIER_WATER ( nl_ice,maxsnl,deltim,& wliq_icesno ,wice_icesno ,pg_rain ,pg_snow ,& sm ,scv ,snowdp ,imelt ,& fiold ,snl ,qseva ,qsdew ,& - qsubl ,qfros ,rsur ,rnof ,& + qsubl ,qfros ,gwat , & ssi ,wimp ,forc_us ,forc_vs ) !======================================================================= @@ -911,16 +919,12 @@ subroutine GLACIER_WATER ( nl_ice,maxsnl,deltim,& snowdp ! snow depth (m) real(r8), INTENT(out) :: & - rsur , &! surface runoff (mm h2o/s) - rnof ! total runoff (mm h2o/s) + gwat ! net water input from top (mm/s) ! !-----------------------Local Variables------------------------------ ! integer lb, j - real(r8) :: gwat ! net water input from top (mm/s) - real(r8) :: rsubst ! subsurface runoff (mm h2o/s) - !======================================================================= ! [1] update the liquid water within snow layer and the water onto the ice surface ! @@ -944,10 +948,6 @@ subroutine GLACIER_WATER ( nl_ice,maxsnl,deltim,& ! [2] surface runoff and infiltration !======================================================================= - rsur = max(0.0,gwat) - rsubst = 0. - rnof = rsur - if(snl<0)then ! Compaction rate for snow ! Natural compaction and metamorphosis. The compaction rate @@ -978,6 +978,10 @@ subroutine GLACIER_WATER ( nl_ice,maxsnl,deltim,& dz_icesno (maxsnl+1:snl) = 0. endif + if(lb >= 1)then + wliq_icesno(1) = max(1.e-8, wliq_icesno(1) + qsdew * deltim) + wice_icesno(1) = max(1.e-8, wice_icesno(1) + (qfros-qsubl) * deltim) + end if end subroutine GLACIER_WATER @@ -987,7 +991,7 @@ subroutine GLACIER_WATER_snicar ( nl_ice,maxsnl,deltim,& wliq_icesno ,wice_icesno ,pg_rain ,pg_snow ,& sm ,scv ,snowdp ,imelt ,& fiold ,snl ,qseva ,qsdew ,& - qsubl ,qfros ,rsur ,rnof ,& + qsubl ,qfros ,gwat , & ssi ,wimp ,forc_us ,forc_vs ,& ! SNICAR forc_aer ,& @@ -1033,8 +1037,7 @@ subroutine GLACIER_WATER_snicar ( nl_ice,maxsnl,deltim,& snowdp ! snow depth (m) real(r8), INTENT(out) :: & - rsur , &! surface runoff (mm h2o/s) - rnof ! total runoff (mm h2o/s) + gwat ! net water input from top (mm/s) real(r8), intent(in) :: forc_us real(r8), intent(in) :: forc_vs @@ -1058,9 +1061,6 @@ subroutine GLACIER_WATER_snicar ( nl_ice,maxsnl,deltim,& ! integer lb, j - real(r8) :: gwat ! net water input from top (mm/s) - real(r8) :: rsubst ! subsurface runoff (mm h2o/s) - !======================================================================= ! [1] update the liquid water within snow layer and the water onto the ice surface ! @@ -1087,10 +1087,6 @@ subroutine GLACIER_WATER_snicar ( nl_ice,maxsnl,deltim,& ! [2] surface runoff and infiltration !======================================================================= - rsur = max(0.0,gwat) - rsubst = 0. - rnof = rsur - if(snl<0)then ! Compaction rate for snow ! Natural compaction and metamorphosis. The compaction rate @@ -1125,6 +1121,10 @@ subroutine GLACIER_WATER_snicar ( nl_ice,maxsnl,deltim,& dz_icesno (maxsnl+1:snl) = 0. endif + if(lb >= 1)then + wliq_icesno(1) = max(1.e-8, wliq_icesno(1) + qsdew * deltim) + wice_icesno(1) = max(1.e-8, wice_icesno(1) + (qfros-qsubl) * deltim) + end if end subroutine GLACIER_WATER_snicar diff --git a/main/MOD_GroundFluxes.F90 b/main/MOD_GroundFluxes.F90 index 8b5de604..f6ad9e49 100644 --- a/main/MOD_GroundFluxes.F90 +++ b/main/MOD_GroundFluxes.F90 @@ -6,7 +6,7 @@ MODULE MOD_GroundFluxes SAVE ! PUBLIC MEMBER FUNCTIONS: - PUBLIC :: groundfluxes + PUBLIC :: GroundFluxes !----------------------------------------------------------------------- @@ -16,12 +16,13 @@ MODULE MOD_GroundFluxes !----------------------------------------------------------------------- - subroutine groundfluxes (zlnd, zsno, hu, ht, hq,& - hpbl, & - us, vs, tm, qm, rhoair, psrf,& - ur, thm, th, thv, t_grnd, qg, dqgdT, htvp,& - fsno, cgrnd, cgrndl, cgrnds,& - taux, tauy, fseng, fevpg, tref, qref,& + subroutine GroundFluxes (zlnd, zsno, hu, ht, hq, hpbl, & + us, vs, tm, qm, rhoair, psrf, & + ur, thm, th, thv, t_grnd, qg, rss, dqgdT, htvp, & + fsno, cgrnd, cgrndl, cgrnds, & + t_soil, t_snow, q_soil, q_snow, & + taux, tauy, fseng, fseng_soil, fseng_snow, & + fevpg, fevpg_soil, fevpg_snow, tref, qref, & z0m, z0hg, zol, rib, ustar, qstar, tstar, fm, fh, fq) !======================================================================= @@ -41,91 +42,100 @@ subroutine groundfluxes (zlnd, zsno, hu, ht, hq,& use MOD_Precision use MOD_Const_Physical, only: cpair,vonkar,grav use MOD_FrictionVelocity - USE mod_namelist, only: DEF_USE_CBL_HEIGHT + USE mod_namelist, only: DEF_USE_CBL_HEIGHT,DEF_RSS_SCHEME USE MOD_TurbulenceLEddy implicit none !----------------------- Dummy argument -------------------------------- real(r8), INTENT(in) :: & - zlnd, &! roughness length for soil [m] - zsno, &! roughness length for snow [m] + zlnd, &! roughness length for soil [m] + zsno, &! roughness length for snow [m] ! atmospherical variables and observational height - hu, &! observational height of wind [m] - ht, &! observational height of temperature [m] - hq, &! observational height of humidity [m] - hpbl, &! atmospheric boundary layer height [m] - us, &! wind component in eastward direction [m/s] - vs, &! wind component in northward direction [m/s] - tm, &! temperature at agcm reference height [kelvin] [not used] - qm, &! specific humidity at agcm reference height [kg/kg] - rhoair, &! density air [kg/m3] - psrf, &! atmosphere pressure at the surface [pa] [not used] - - fsno, &! fraction of ground covered by snow - - ur, &! wind speed at reference height [m/s] - thm, &! intermediate variable (tm+0.0098*ht) - th, &! potential temperature (kelvin) - thv, &! virtual potential temperature (kelvin) - - t_grnd, &! ground surface temperature [K] - qg, &! ground specific humidity [kg/kg] - dqgdT, &! d(qg)/dT - htvp ! latent heat of vapor of water (or sublimation) [j/kg] + hu, &! observational height of wind [m] + ht, &! observational height of temperature [m] + hq, &! observational height of humidity [m] + hpbl, &! atmospheric boundary layer height [m] + us, &! wind component in eastward direction [m/s] + vs, &! wind component in northward direction [m/s] + tm, &! temperature at agcm reference height [kelvin] [not used] + qm, &! specific humidity at agcm reference height [kg/kg] + rhoair, &! density air [kg/m3] + psrf, &! atmosphere pressure at the surface [pa] [not used] + + fsno, &! fraction of ground covered by snow + + ur, &! wind speed at reference height [m/s] + thm, &! intermediate variable (tm+0.0098*ht) + th, &! potential temperature (kelvin) + thv, &! virtual potential temperature (kelvin) + + t_grnd, &! ground surface temperature [K] + t_soil, &! ground soil temperature [K] + t_snow, &! ground snow temperature [K] + qg, &! ground specific humidity [kg/kg] + q_soil, &! ground soil specific humidity [kg/kg] + q_snow, &! ground snow specific humidity [kg/kg] + dqgdT, &! d(qg)/dT + rss, &! soil surface resistance for evaporation [s/m] + htvp ! latent heat of vapor of water (or sublimation) [j/kg] real(r8), INTENT(out) :: & - taux, &! wind stress: E-W [kg/m/s**2] - tauy, &! wind stress: N-S [kg/m/s**2] - fseng, &! sensible heat flux from ground [W/m2] - fevpg, &! evaporation heat flux from ground [mm/s] - cgrnd, &! deriv. of soil energy flux wrt to soil temp [w/m2/k] - cgrndl, &! deriv, of soil sensible heat flux wrt soil temp [w/m2/k] - cgrnds, &! deriv of soil latent heat flux wrt soil temp [w/m**2/k] - tref, &! 2 m height air temperature [kelvin] - qref, &! 2 m height air humidity - - z0m, &! effective roughness [m] - z0hg, &! roughness length over ground, sensible heat [m] - zol, &! dimensionless height (z/L) used in Monin-Obukhov theory - rib, &! bulk Richardson number in surface layer - ustar, &! friction velocity [m/s] - tstar, &! temperature scaling parameter - qstar, &! moisture scaling parameter - fm, &! integral of profile function for momentum - fh, &! integral of profile function for heat - fq ! integral of profile function for moisture + taux, &! wind stress: E-W [kg/m/s**2] + tauy, &! wind stress: N-S [kg/m/s**2] + fseng, &! sensible heat flux from ground [W/m2] + fseng_soil,&! sensible heat flux from ground soil [W/m2] + fseng_snow,&! sensible heat flux from ground snow [W/m2] + fevpg, &! evaporation heat flux from ground [mm/s] + fevpg_soil,&! evaporation heat flux from ground soil [mm/s] + fevpg_snow,&! evaporation heat flux from ground snow [mm/s] + cgrnd, &! deriv. of soil energy flux wrt to soil temp [w/m2/k] + cgrndl, &! deriv, of soil sensible heat flux wrt soil temp [w/m2/k] + cgrnds, &! deriv of soil latent heat flux wrt soil temp [w/m**2/k] + tref, &! 2 m height air temperature [kelvin] + qref, &! 2 m height air humidity + + z0m, &! effective roughness [m] + z0hg, &! roughness length over ground, sensible heat [m] + zol, &! dimensionless height (z/L) used in Monin-Obukhov theory + rib, &! bulk Richardson number in surface layer + ustar, &! friction velocity [m/s] + tstar, &! temperature scaling parameter + qstar, &! moisture scaling parameter + fm, &! integral of profile function for momentum + fh, &! integral of profile function for heat + fq ! integral of profile function for moisture !------------------------ LOCAL VARIABLES ------------------------------ - integer niters, &! maximum number of iterations for surface temperature - iter, &! iteration index - nmozsgn ! number of times moz changes sign + integer niters, &! maximum number of iterations for surface temperature + iter, &! iteration index + nmozsgn ! number of times moz changes sign real(r8) :: & - beta, &! coefficient of conective velocity [-] - displax, &! zero-displacement height [m] - dth, &! diff of virtual temp. between ref. height and surface - dqh, &! diff of humidity between ref. height and surface - dthv, &! diff of vir. poten. temp. between ref. height and surface - obu, &! monin-obukhov length (m) - obuold, &! monin-obukhov length from previous iteration - ram, &! aerodynamical resistance [s/m] - rah, &! thermal resistance [s/m] - raw, &! moisture resistance [s/m] - raih, &! temporary variable [kg/m2/s] - raiw, &! temporary variable [kg/m2/s] - fh2m, &! relation for temperature at 2m - fq2m, &! relation for specific humidity at 2m - fm10m, &! integral of profile function for momentum at 10m - thvstar, &! virtual potential temperature scaling parameter - um, &! wind speed including the stablity effect [m/s] - wc, &! convective velocity [m/s] - wc2, &! wc**2 - zeta, &! dimensionless height used in Monin-Obukhov theory - zii, &! convective boundary height [m] - zldis, &! reference height "minus" zero displacement heght [m] - z0mg, &! roughness length over ground, momentum [m] - z0qg ! roughness length over ground, latent heat [m] + beta, &! coefficient of conective velocity [-] + displax, &! zero-displacement height [m] + dth, &! diff of virtual temp. between ref. height and surface + dqh, &! diff of humidity between ref. height and surface + dthv, &! diff of vir. poten. temp. between ref. height and surface + obu, &! monin-obukhov length (m) + obuold, &! monin-obukhov length from previous iteration + ram, &! aerodynamical resistance [s/m] + rah, &! thermal resistance [s/m] + raw, &! moisture resistance [s/m] + raih, &! temporary variable [kg/m2/s] + raiw, &! temporary variable [kg/m2/s] + fh2m, &! relation for temperature at 2m + fq2m, &! relation for specific humidity at 2m + fm10m, &! integral of profile function for momentum at 10m + thvstar, &! virtual potential temperature scaling parameter + um, &! wind speed including the stablity effect [m/s] + wc, &! convective velocity [m/s] + wc2, &! wc**2 + zeta, &! dimensionless height used in Monin-Obukhov theory + zii, &! convective boundary height [m] + zldis, &! reference height "minus" zero displacement heght [m] + z0mg, &! roughness length over ground, momentum [m] + z0qg ! roughness length over ground, latent heat [m] !----------------------- Dummy argument -------------------------------- ! initial roughness length @@ -136,8 +146,8 @@ subroutine groundfluxes (zlnd, zsno, hu, ht, hq,& ! potential temperatur at the reference height beta = 1. ! - (in computing W_*) - zii = 1000. ! m (pbl height) - z0m = z0mg + zii = 1000. ! m (pbl height) + z0m = z0mg !----------------------------------------------------------------------- ! Compute sensible and latent fluxes and their derivatives with respect @@ -176,8 +186,8 @@ subroutine groundfluxes (zlnd, zsno, hu, ht, hq,& z0qg = z0hg ! 2023.04.06, weinan + !thvstar=tstar+0.61*th*qstar thvstar=tstar*(1.+0.61*qm)+0.61*th*qstar - ! thvstar=tstar+0.61*th*qstar zeta=zldis*vonkar*grav*thvstar/(ustar**2*thv) if(zeta >= 0.) then !stable zeta = min(2.,max(zeta,1.e-6)) @@ -198,7 +208,7 @@ subroutine groundfluxes (zlnd, zsno, hu, ht, hq,& endif if (obuold*obu < 0.) nmozsgn = nmozsgn+1 - if(nmozsgn >= 4) EXIT + if (nmozsgn >= 4) EXIT obuold = obu @@ -207,13 +217,23 @@ subroutine groundfluxes (zlnd, zsno, hu, ht, hq,& !---------------------------------------------------------------- ! Get derivative of fluxes with repect to ground temperature - ram = 1./(ustar*ustar/um) - rah = 1./(vonkar/fh*ustar) - raw = 1./(vonkar/fq*ustar) + ram = 1./(ustar*ustar/um) + rah = 1./(vonkar/fh*ustar) + raw = 1./(vonkar/fq*ustar) + + raih = rhoair*cpair/rah + + ! 08/23/2019, yuan: add soil surface resistance (rss) + IF (dqh > 0.) THEN + raiw = rhoair/raw !dew case. assume no soil resistance + ELSE + IF (DEF_RSS_SCHEME .eq. 4) THEN + raiw = rss*rhoair/raw + ELSE + raiw = rhoair/(raw+rss) + ENDIF + ENDIF - ! 08/23/2019, yuan: - raih = rhoair*cpair/rah - raiw = rhoair/raw cgrnds = raih cgrndl = raiw*dqgdT cgrnd = cgrnds + htvp*cgrndl @@ -223,15 +243,20 @@ subroutine groundfluxes (zlnd, zsno, hu, ht, hq,& ! surface fluxes of momentum, sensible and latent ! using ground temperatures from previous time step - taux = -rhoair*us/ram - tauy = -rhoair*vs/ram - fseng = -raih*dth - fevpg = -raiw*dqh + taux = -rhoair*us/ram + tauy = -rhoair*vs/ram + fseng = -raih*dth + fevpg = -raiw*dqh + + fseng_soil = -raih * (thm - t_soil) + fseng_snow = -raih * (thm - t_snow) + fevpg_soil = -raiw * ( qm - q_soil) + fevpg_snow = -raiw * ( qm - q_snow) ! 2 m height air temperature - tref = thm + vonkar/fh*dth * (fh2m/vonkar - fh/vonkar) - qref = qm + vonkar/fq*dqh * (fq2m/vonkar - fq/vonkar) + tref = thm + vonkar/fh*dth * (fh2m/vonkar - fh/vonkar) + qref = qm + vonkar/fq*dqh * (fq2m/vonkar - fq/vonkar) - end subroutine groundfluxes + end subroutine GroundFluxes END MODULE MOD_GroundFluxes diff --git a/main/MOD_GroundTemperature.F90 b/main/MOD_GroundTemperature.F90 index dd0cfd1a..0dd726fd 100644 --- a/main/MOD_GroundTemperature.F90 +++ b/main/MOD_GroundTemperature.F90 @@ -8,7 +8,7 @@ MODULE MOD_GroundTemperature SAVE ! PUBLIC MEMBER FUNCTIONS: - PUBLIC :: groundtem + PUBLIC :: GroundTemperature !----------------------------------------------------------------------- @@ -18,7 +18,7 @@ MODULE MOD_GroundTemperature !----------------------------------------------------------------------- - subroutine groundtem (itypwat,lb,nl_soil,deltim,& + SUBROUTINE GroundTemperature (patchtype,lb,nl_soil,deltim,& capr,cnfac,vf_quartz,vf_gravels,vf_om,vf_sand,wf_gravels,wf_sand,& porsl,psi0,& #ifdef Campbell_SOIL_MODEL @@ -31,8 +31,9 @@ subroutine groundtem (itypwat,lb,nl_soil,deltim,& csol,k_solids,dksatu,dksatf,dkdry,& BA_alpha,BA_beta,& sigf,dz_soisno,z_soisno,zi_soisno,& - t_soisno,wice_soisno,wliq_soisno,scv,snowdp,& - frl,dlrad,sabg,sabg_lyr,fseng,fevpg,cgrnd,htvp,emg,& + t_soisno,t_grnd,t_soil,t_snow,wice_soisno,wliq_soisno,scv,snowdp,fsno,& + frl,dlrad,sabg,sabg_soil,sabg_snow,sabg_snow_lyr,& + fseng,fseng_soil,fseng_snow,fevpg,fevpg_soil,fevpg_snow,cgrnd,htvp,emg,& imelt,snofrz,sm,xmf,fact,pg_rain,pg_snow,t_precip) !======================================================================= @@ -58,117 +59,130 @@ subroutine groundtem (itypwat,lb,nl_soil,deltim,& ! ! REVISIONS: ! Nan Wei, 07/2017: interaction btw prec and land surface -! Nan Wei, 01/2019: use the new version of soil thermal parameters to calculate soil temperature +! Nan Wei, 01/2019: USE the new version of soil thermal parameters to calculate soil temperature ! Hua Yuan, 01/2023: modified ground heat flux, temperature and meltf ! calculation for SNICAR model !======================================================================= - use MOD_Precision - use MOD_Const_Physical, only: stefnc,denh2o,denice,tfrz,cpice,cpliq,tkwat,tkice,tkair - USE MOD_Namelist, only: DEF_USE_SNICAR + USE MOD_Precision + USE MOD_Const_Physical, only: stefnc,denh2o,denice,tfrz,cpice,cpliq,tkwat,tkice,tkair + USE MOD_Namelist, only: DEF_USE_SNICAR, DEF_SPLIT_SOILSNOW USE MOD_PhaseChange USE MOD_SoilThermalParameters + USE MOD_SPMD_Task USE MOD_Utils - implicit none - - integer, INTENT(in) :: lb !lower bound of array - integer, INTENT(in) :: nl_soil !upper bound of array - integer, INTENT(in) :: itypwat !land water type (0=soil,1=urban or built-up,2=wetland, - !3=land ice, 4=deep lake, 5=shallow lake) - real(r8), INTENT(in) :: deltim !seconds in a time step [second] - real(r8), INTENT(in) :: capr !tuning factor to turn first layer T into surface T - real(r8), INTENT(in) :: cnfac !Crank Nicholson factor between 0 and 1 - - real(r8), INTENT(in) :: vf_quartz (1:nl_soil) ! volumetric fraction of quartz within mineral soil - real(r8), INTENT(in) :: vf_gravels(1:nl_soil) ! volumetric fraction of gravels - real(r8), INTENT(in) :: vf_om (1:nl_soil) ! volumetric fraction of organic matter - real(r8), INTENT(in) :: vf_sand (1:nl_soil) ! volumetric fraction of sand - real(r8), INTENT(in) :: wf_gravels(1:nl_soil) ! gravimetric fraction of gravels - real(r8), INTENT(in) :: wf_sand (1:nl_soil) ! gravimetric fraction of sand - - real(r8), INTENT(in) :: porsl(1:nl_soil) ! soil porosity [-] - real(r8), INTENT(in) :: psi0 (1:nl_soil) ! soil water suction, negative potential [mm] + IMPLICIT NONE + + integer, intent(in) :: lb !lower bound of array + integer, intent(in) :: nl_soil !upper bound of array + integer, intent(in) :: patchtype !land patch type (0=soil,1=urban or built-up,2=wetland, + !3=land ice, 4=deep lake, 5=shallow lake) + real(r8), intent(in) :: deltim !seconds in a time step [second] + real(r8), intent(in) :: capr !tuning factor to turn first layer T into surface T + real(r8), intent(in) :: cnfac !Crank Nicholson factor between 0 and 1 + + real(r8), intent(in) :: vf_quartz (1:nl_soil) !volumetric fraction of quartz within mineral soil + real(r8), intent(in) :: vf_gravels(1:nl_soil) !volumetric fraction of gravels + real(r8), intent(in) :: vf_om (1:nl_soil) !volumetric fraction of organic matter + real(r8), intent(in) :: vf_sand (1:nl_soil) !volumetric fraction of sand + real(r8), intent(in) :: wf_gravels(1:nl_soil) !gravimetric fraction of gravels + real(r8), intent(in) :: wf_sand (1:nl_soil) !gravimetric fraction of sand + + real(r8), intent(in) :: porsl(1:nl_soil) !soil porosity [-] + real(r8), intent(in) :: psi0 (1:nl_soil) !soil water suction, negative potential [mm] #ifdef Campbell_SOIL_MODEL - real(r8), INTENT(in) :: bsw(1:nl_soil) ! clapp and hornbereger "b" parameter [-] + real(r8), intent(in) :: bsw(1:nl_soil) !clapp and hornbereger "b" parameter [-] #endif #ifdef vanGenuchten_Mualem_SOIL_MODEL - real(r8), INTENT(in) :: theta_r (1:nl_soil), & - alpha_vgm(1:nl_soil), & - n_vgm (1:nl_soil), & - L_vgm (1:nl_soil), & - sc_vgm (1:nl_soil), & + real(r8), intent(in) :: theta_r (1:nl_soil), & ! + alpha_vgm(1:nl_soil), & ! + n_vgm (1:nl_soil), & ! + L_vgm (1:nl_soil), & ! + sc_vgm (1:nl_soil), & ! fc_vgm (1:nl_soil) #endif - real(r8), INTENT(in) :: csol(1:nl_soil) ! heat capacity of soil solids [J/(m3 K)] - real(r8), INTENT(in) :: k_solids(1:nl_soil) ! thermal conductivity of minerals soil [W/m-K] - real(r8), INTENT(in) :: dksatu(1:nl_soil) ! thermal conductivity of saturated unfrozen soil [W/m-K] - real(r8), INTENT(in) :: dksatf(1:nl_soil) ! thermal conductivity of saturated frozen soil [W/m-K] - real(r8), INTENT(in) :: dkdry(1:nl_soil) ! thermal conductivity of dry soil [W/m-K] - real(r8), INTENT(in) :: BA_alpha(1:nl_soil) ! alpha in Balland and Arp(2005) thermal conductivity scheme - real(r8), INTENT(in) :: BA_beta(1:nl_soil) ! beta in Balland and Arp(2005) thermal conductivity scheme - - real(r8), INTENT(in) :: sigf !fraction of veg cover, excluding snow-covered veg [-] - real(r8), INTENT(in) :: dz_soisno(lb:nl_soil) !layer thickiness [m] - real(r8), INTENT(in) :: z_soisno (lb:nl_soil) !node depth [m] - real(r8), INTENT(in) :: zi_soisno(lb-1:nl_soil) !interface depth [m] - - REAL(r8), intent(in) :: sabg_lyr(lb:1) !snow layer absorption [W/m-2] - - real(r8), INTENT(in) :: sabg !solar radiation absorbed by ground [W/m2] - real(r8), INTENT(in) :: frl !atmospheric infrared (longwave) radiation [W/m2] - real(r8), INTENT(in) :: dlrad !downward longwave radiation blow the canopy [W/m2] - real(r8), INTENT(in) :: fseng !sensible heat flux from ground [W/m2] - real(r8), INTENT(in) :: fevpg !evaporation heat flux from ground [mm/s] - real(r8), INTENT(in) :: cgrnd !deriv. of soil energy flux wrt to soil temp [w/m2/k] - real(r8), INTENT(in) :: htvp !latent heat of vapor of water (or sublimation) [j/kg] - real(r8), INTENT(in) :: emg !ground emissivity (0.97 for snow, - real(r8), INTENT(in) :: pg_rain ! rainfall onto ground including canopy runoff [kg/(m2 s)] - real(r8), INTENT(in) :: pg_snow ! snowfall onto ground including canopy runoff [kg/(m2 s)] - real(r8), INTENT(in) :: t_precip ! snowfall/rainfall temperature [kelvin] - - real(r8), INTENT(inout) :: t_soisno (lb:nl_soil) !soil temperature [K] - real(r8), INTENT(inout) :: wice_soisno(lb:nl_soil) !ice lens [kg/m2] - real(r8), INTENT(inout) :: wliq_soisno(lb:nl_soil) !liqui water [kg/m2] - real(r8), INTENT(inout) :: scv !snow cover, water equivalent [mm, kg/m2] - real(r8), INTENT(inout) :: snowdp !snow depth [m] - - real(r8), INTENT(out) :: sm !rate of snowmelt [kg/(m2 s)] - real(r8), INTENT(out) :: xmf !total latent heat of phase change of ground water - real(r8), INTENT(out) :: fact(lb:nl_soil) !used in computing tridiagonal matrix - integer, INTENT(out) :: imelt(lb:nl_soil)!flag for melting or freezing [-] - - REAL(r8), intent(out) :: snofrz(lb:0) !snow freezing rate (lyr) [kg m-2 s-1] + real(r8), intent(in) :: csol (1:nl_soil) !heat capacity of soil solids [J/(m3 K)] + real(r8), intent(in) :: k_solids (1:nl_soil) !thermal conductivity of minerals soil [W/m-K] + real(r8), intent(in) :: dksatu (1:nl_soil) !thermal conductivity of saturated unfrozen soil [W/m-K] + real(r8), intent(in) :: dksatf (1:nl_soil) !thermal conductivity of saturated frozen soil [W/m-K] + real(r8), intent(in) :: dkdry (1:nl_soil) !thermal conductivity of dry soil [W/m-K] + real(r8), intent(in) :: BA_alpha (1:nl_soil) !alpha in Balland and Arp(2005) thermal conductivity scheme + real(r8), intent(in) :: BA_beta (1:nl_soil) !beta in Balland and Arp(2005) thermal conductivity scheme + + real(r8), intent(in) :: sigf !fraction of veg cover, excluding snow-covered veg [-] + real(r8), intent(in) :: dz_soisno(lb:nl_soil) !layer thickiness [m] + real(r8), intent(in) :: z_soisno (lb:nl_soil) !node depth [m] + real(r8), intent(in) :: zi_soisno(lb-1:nl_soil) !interface depth [m] + + real(r8), intent(in) :: sabg_snow_lyr(lb:1) !snow layer absorption [W/m-2] + + real(r8), intent(in) :: t_grnd !ground surface temperature [K] + real(r8), intent(in) :: t_soil !ground soil temperature [K] + real(r8), intent(in) :: t_snow !ground snow temperature [K] + real(r8), intent(in) :: sabg !solar radiation absorbed by ground [W/m2] + real(r8), intent(in) :: sabg_soil !solar radiation absorbed by ground soil [W/m2] + real(r8), intent(in) :: sabg_snow !solar radiation absorbed by ground snow [W/m2] + real(r8), intent(in) :: frl !atmospheric infrared (longwave) radiation [W/m2] + real(r8), intent(in) :: dlrad !downward longwave radiation blow the canopy [W/m2] + real(r8), intent(in) :: fseng !sensible heat flux from ground [W/m2] + real(r8), intent(in) :: fseng_soil !sensible heat flux from ground soil [W/m2] + real(r8), intent(in) :: fseng_snow !sensible heat flux from ground snow [W/m2] + real(r8), intent(in) :: fevpg !evaporation heat flux from ground [mm/s] + real(r8), intent(in) :: fevpg_soil !evaporation heat flux from ground soil [mm/s] + real(r8), intent(in) :: fevpg_snow !evaporation heat flux from ground snow [mm/s] + real(r8), intent(in) :: cgrnd !deriv. of soil energy flux wrt to soil temp [w/m2/k] + real(r8), intent(in) :: htvp !latent heat of vapor of water (or sublimation) [j/kg] + real(r8), intent(in) :: emg !ground emissivity (0.97 for snow, + real(r8), intent(in) :: pg_rain !rainfall onto ground including canopy runoff [kg/(m2 s)] + real(r8), intent(in) :: pg_snow !snowfall onto ground including canopy runoff [kg/(m2 s)] + real(r8), intent(in) :: t_precip !snowfall/rainfall temperature [kelvin] + + real(r8), intent(inout) :: t_soisno (lb:nl_soil) !soil temperature [K] + real(r8), intent(inout) :: wice_soisno(lb:nl_soil) !ice lens [kg/m2] + real(r8), intent(inout) :: wliq_soisno(lb:nl_soil) !liqui water [kg/m2] + real(r8), intent(inout) :: scv !snow cover, water equivalent [mm, kg/m2] + real(r8), intent(inout) :: snowdp !snow depth [m] + real(r8), INTENT(in) :: fsno !snow fractional cover [-] + + real(r8), intent(out) :: sm !rate of snowmelt [kg/(m2 s)] + real(r8), intent(out) :: xmf !total latent heat of phase change of ground water + real(r8), intent(out) :: fact (lb:nl_soil) !used in computing tridiagonal matrix + integer, intent(out) :: imelt(lb:nl_soil) !flag for melting or freezing [-] + + real(r8), intent(out) :: snofrz(lb:0) !snow freezing rate (lyr) [kg m-2 s-1] !------------------------ local variables ------------------------------ - real(r8) cv(lb:nl_soil) ! heat capacity [J/(m2 K)] - real(r8) tk(lb:nl_soil) ! thermal conductivity [W/(m K)] - real(r8) hcap(1:nl_soil) ! J/(m3 K) - real(r8) thk(lb:nl_soil) ! W/(m K) + real(r8) cv (lb:nl_soil) !heat capacity [J/(m2 K)] + real(r8) tk (lb:nl_soil) !thermal conductivity [W/(m K)] + real(r8) hcap(1:nl_soil) !J/(m3 K) + real(r8) thk(lb:nl_soil) !W/(m K) - real(r8) at(lb:nl_soil) !"a" vector for tridiagonal matrix - real(r8) bt(lb:nl_soil) !"b" vector for tridiagonal matrix - real(r8) ct(lb:nl_soil) !"c" vector for tridiagonal matrix - real(r8) rt(lb:nl_soil) !"r" vector for tridiagonal solution + real(r8) at (lb:nl_soil) !"a" vector for tridiagonal matrix + real(r8) bt (lb:nl_soil) !"b" vector for tridiagonal matrix + real(r8) ct (lb:nl_soil) !"c" vector for tridiagonal matrix + real(r8) rt (lb:nl_soil) !"r" vector for tridiagonal solution - real(r8) fn (lb:nl_soil) !heat diffusion through the layer interface [W/m2] - real(r8) fn1 (lb:nl_soil) !heat diffusion through the layer interface [W/m2] - real(r8) dzm !used in computing tridiagonal matrix - real(r8) dzp !used in computing tridiagonal matrix + real(r8) fn (lb:nl_soil) !heat diffusion through the layer interface [W/m2] + real(r8) fn1(lb:nl_soil) !heat diffusion through the layer interface [W/m2] + real(r8) dzm !used in computing tridiagonal matrix + real(r8) dzp !used in computing tridiagonal matrix real(r8) t_soisno_bef(lb:nl_soil) !soil/snow temperature before update real(r8) wice_soisno_bef(lb:0) !ice lens [kg/m2] - real(r8) hs !net energy flux into the surface (w/m2) - real(r8) dhsdt !d(hs)/dT - real(r8) brr(lb:nl_soil) !temporay set - real(r8) vf_water(1:nl_soil) ! volumetric fraction liquid water within soil - real(r8) vf_ice(1:nl_soil) ! volumetric fraction ice len within soil - real(r8) rhosnow ! partitial density of water (ice + liquid) + real(r8) hs !net energy flux into the surface (w/m2) + real(r8) hs_soil !net energy flux into the surface soil (w/m2) + real(r8) hs_snow !net energy flux into the surface snow (w/m2) + real(r8) dhsdT !d(hs)/dT + real(r8) brr (lb:nl_soil) !temporay set + real(r8) vf_water(1:nl_soil) !volumetric fraction liquid water within soil + real(r8) vf_ice (1:nl_soil) !volumetric fraction ice len within soil + real(r8) rhosnow !partitial density of water (ice + liquid) integer i,j !======================================================================= ! soil ground and wetland heat capacity - do i = 1, nl_soil + DO i = 1, nl_soil vf_water(i) = wliq_soisno(i)/(dz_soisno(i)*denh2o) vf_ice(i) = wice_soisno(i)/(dz_soisno(i)*denice) CALL soil_hcap_cond(vf_gravels(i),vf_om(i),vf_sand(i),porsl(i),& @@ -177,17 +191,17 @@ subroutine groundtem (itypwat,lb,nl_soil,deltim,& BA_alpha(i),BA_beta(i),& t_soisno(i),vf_water(i),vf_ice(i),hcap(i),thk(i)) cv(i) = hcap(i)*dz_soisno(i) - enddo - if(lb==1 .AND. scv>0.) cv(1) = cv(1) + cpice*scv + ENDDO + IF(lb==1 .and. scv>0.) cv(1) = cv(1) + cpice*scv ! Snow heat capacity - if(lb <= 0)then + IF(lb <= 0)THEN cv(:0) = cpliq*wliq_soisno(:0) + cpice*wice_soisno(:0) - endif + ENDIF ! Snow thermal conductivity - if(lb <= 0)then - do i = lb, 0 + IF(lb <= 0)THEN + DO i = lb, 0 rhosnow = (wice_soisno(i)+wliq_soisno(i))/dz_soisno(i) ! presently option [1] is the default option @@ -205,11 +219,11 @@ subroutine groundtem (itypwat,lb,nl_soil,deltim,& ! [6] van Dusen (1992) presented in Sturm et al. (1997) ! thk(i) = 0.021 + 0.42e-3*rhosnow + 0.22e-6*rhosnow**2 - enddo - endif + ENDDO + ENDIF ! Thermal conductivity at the layer interface - do i = lb, nl_soil-1 + DO i = lb, nl_soil-1 ! the following consideration is try to avoid the snow conductivity ! to be dominant in the thermal conductivity of the interface. @@ -217,76 +231,141 @@ subroutine groundtem (itypwat,lb,nl_soil,deltim,& ! is larger than that of interface to top soil node, ! the snow thermal conductivity will be dominant, and the result is that ! lees heat tranfer between snow and soil - if((i==0) .AND. (z_soisno(i+1)-zi_soisno(i)100% cover - - emg*stefnc*t_soisno(lb)**4 & - - (fseng+fevpg*htvp) + cpliq * pg_rain * (t_precip - t_soisno(lb)) & - + cpice * pg_snow * (t_precip - t_soisno(lb)) + + ! 08/19/2021, yuan: NOTE! removed sigf, LAI->100% cover + IF (DEF_USE_SNICAR .and. lb < 1) THEN + hs = sabg_snow_lyr(lb) + sabg_soil + dlrad*emg & + - (fseng+fevpg*htvp) & + + cpliq*pg_rain*(t_precip-t_grnd) & + + cpice*pg_snow*(t_precip-t_grnd) ELSE hs = sabg + dlrad*emg & - ! 08/19/2021, yuan: NOTE! removed sigf, LAI->100% cover - - emg*stefnc*t_soisno(lb)**4 & - - (fseng+fevpg*htvp) + cpliq * pg_rain * (t_precip - t_soisno(lb)) & - + cpice * pg_snow * (t_precip - t_soisno(lb)) + - (fseng+fevpg*htvp) & + + cpliq*pg_rain*(t_precip-t_grnd) & + + cpice*pg_snow*(t_precip-t_grnd) + ENDIF + + IF (.not.DEF_SPLIT_SOILSNOW) THEN + hs = hs - emg*stefnc*t_grnd**4 + ELSE + ! 03/08/2020, yuan: separate soil and snow + hs = hs - fsno*emg*stefnc*t_snow**4 & + - (1.-fsno)*emg*stefnc*t_soil**4 + + ! 03/08/2020, yuan: calculate hs_soil, hs_snow for + ! soil/snow fractional cover separately. + hs_soil = dlrad*emg & + - emg*stefnc*t_soil**4 & + - (fseng_soil+fevpg_soil*htvp) & + + cpliq*pg_rain*(t_precip-t_soil) & + + cpice*pg_snow*(t_precip-t_soil) + + hs_soil = hs_soil*(1.-fsno) + sabg_soil + + hs_snow = dlrad*emg & + - emg*stefnc*t_snow**4 & + - (fseng_snow+fevpg_snow*htvp) & + + cpliq*pg_rain*(t_precip-t_snow) & + + cpice*pg_snow*(t_precip-t_snow) + + IF (DEF_USE_SNICAR .and. lb < 1) THEN + hs_snow = hs_snow*fsno + sabg_snow_lyr(lb) + ELSE + hs_snow = hs_snow*fsno + sabg_snow + ENDIF + + dhsdT = -cgrnd - 4.*emg*stefnc*t_grnd**3 - cpliq*pg_rain - cpice*pg_snow + + IF (sabg_soil+sabg_snow-sabg>1.e-6 .or. hs_soil+hs_snow-hs>1.e-6) THEN + print *, "MOD_GroundTemperature.F90: Error in spliting soil and snow surface!" + print *, "sabg:", sabg, "sabg_soil:", sabg_soil, "sabg_snow", sabg_snow + print *, "hs", hs, "hs_soil", hs_soil, "hs_snow:", hs_snow, "fsno:", fsno + print *, "hs_soil+hs_snow", hs_soil+hs_snow, "sabg_soil+sabg_snow:", sabg_soil+sabg_snow + print *, "lb:", lb, "sabg_snow_lyr:", sabg_snow_lyr + CALL CoLM_stop() + ENDIF ENDIF - dhsdT = - cgrnd - 4.*emg * stefnc * t_soisno(lb)**3 - cpliq * pg_rain - cpice * pg_snow + dhsdT = -cgrnd - 4.*emg*stefnc*t_grnd**3 - cpliq*pg_rain - cpice*pg_snow t_soisno_bef(lb:) = t_soisno(lb:) j = lb fact(j) = deltim / cv(j) & * dz_soisno(j) / (0.5*(z_soisno(j)-zi_soisno(j-1)+capr*(z_soisno(j+1)-zi_soisno(j-1)))) - do j = lb + 1, nl_soil + DO j = lb + 1, nl_soil fact(j) = deltim/cv(j) - enddo + ENDDO - do j = lb, nl_soil - 1 + DO j = lb, nl_soil - 1 fn(j) = tk(j)*(t_soisno(j+1)-t_soisno(j))/(z_soisno(j+1)-z_soisno(j)) - enddo + ENDDO fn(nl_soil) = 0. ! set up vector r and vectors a, b, c that define tridiagonal matrix j = lb dzp = z_soisno(j+1)-z_soisno(j) at(j) = 0. - bt(j) = 1+(1.-cnfac)*fact(j)*tk(j)/dzp-fact(j)*dhsdT ct(j) = -(1.-cnfac)*fact(j)*tk(j)/dzp - rt(j) = t_soisno(j) + fact(j)*( hs - dhsdT*t_soisno(j) + cnfac*fn(j) ) - -! January 12, 2023 - if (lb <= 0) then - do j = lb + 1, 1 - dzm = (z_soisno(j)-z_soisno(j-1)) - dzp = (z_soisno(j+1)-z_soisno(j)) - at(j) = - (1.-cnfac)*fact(j)* tk(j-1)/dzm - bt(j) = 1.+ (1.-cnfac)*fact(j)*(tk(j)/dzp + tk(j-1)/dzm) - ct(j) = - (1.-cnfac)*fact(j)* tk(j)/dzp - rt(j) = t_soisno(j) + fact(j)*sabg_lyr(j) + cnfac*fact(j)*( fn(j) - fn(j-1) ) - end do - endif - - do j = 2, nl_soil - 1 -! January 12, 2023 - dzm = (z_soisno(j)-z_soisno(j-1)) - dzp = (z_soisno(j+1)-z_soisno(j)) - at(j) = - (1.-cnfac)*fact(j)* tk(j-1)/dzm - bt(j) = 1.+ (1.-cnfac)*fact(j)*(tk(j)/dzp + tk(j-1)/dzm) - ct(j) = - (1.-cnfac)*fact(j)* tk(j)/dzp - rt(j) = t_soisno(j) + cnfac*fact(j)*( fn(j) - fn(j-1) ) - end do + + ! the first layer + IF (j<1 .and. DEF_SPLIT_SOILSNOW) THEN ! snow covered and split soil and snow + bt(j) = 1+(1.-cnfac)*fact(j)*tk(j)/dzp-fact(j)*fsno*dhsdT + rt(j) = t_soisno(j) +fact(j)*( hs_snow - fsno*dhsdT*t_soisno(j) + cnfac*fn(j) ) + ELSE ! not a snow layer or don't split soil and snow + bt(j) = 1+(1.-cnfac)*fact(j)*tk(j)/dzp-fact(j)*dhsdT + rt(j) = t_soisno(j) +fact(j)*( hs - dhsdT*t_soisno(j) + cnfac*fn(j) ) + ENDIF + + DO j = lb + 1, nl_soil - 1 + + dzm = (z_soisno(j)-z_soisno(j-1)) + dzp = (z_soisno(j+1)-z_soisno(j)) + + IF (j < 1) THEN ! snow layer + at(j) = - (1.-cnfac)*fact(j)* tk(j-1)/dzm + bt(j) = 1.+ (1.-cnfac)*fact(j)*(tk(j)/dzp + tk(j-1)/dzm) + ct(j) = - (1.-cnfac)*fact(j)* tk(j)/dzp + IF (DEF_USE_SNICAR) THEN + rt(j) = t_soisno(j) + fact(j)*sabg_snow_lyr(j) + cnfac*fact(j)*( fn(j) - fn(j-1) ) + ELSE + rt(j) = t_soisno(j) + cnfac*fact(j)*( fn(j) - fn(j-1) ) + ENDIF + ENDIF + + IF (j == 1) THEN ! the first soil layer + at(j) = - (1.-cnfac)*fact(j)* tk(j-1)/dzm + ct(j) = - (1.-cnfac)*fact(j)* tk(j)/dzp + IF (.not.DEF_SPLIT_SOILSNOW) THEN + bt(j) = 1.+ (1.-cnfac)*fact(j)*(tk(j)/dzp + tk(j-1)/dzm) + rt(j) = t_soisno(j) + cnfac*fact(j)*( fn(j) - fn(j-1) ) + ELSE + bt(j) = 1.+ (1.-cnfac)*fact(j)*(tk(j)/dzp + tk(j-1)/dzm) & + - (1.-fsno)*dhsdT*fact(j) + rt(j) = t_soisno(j) + cnfac*fact(j)*( fn(j) - fn(j-1) ) & + + fact(j)*( hs_soil - (1.-fsno)*dhsdT*t_soisno(j) ) + ENDIF + ENDIF + + IF (j > 1) THEN ! inner soil layer + at(j) = - (1.-cnfac)*fact(j)* tk(j-1)/dzm + bt(j) = 1.+ (1.-cnfac)*fact(j)*(tk(j)/dzp + tk(j-1)/dzm) + ct(j) = - (1.-cnfac)*fact(j)* tk(j)/dzp + rt(j) = t_soisno(j) + cnfac*fact(j)*( fn(j) - fn(j-1) ) + ENDIF + + ENDDO j = nl_soil dzm = (z_soisno(j)-z_soisno(j-1)) @@ -297,30 +376,30 @@ subroutine groundtem (itypwat,lb,nl_soil,deltim,& ! solve for t_soisno i = size(at) - call tridia (i ,at ,bt ,ct ,rt ,t_soisno) + CALL tridia (i ,at ,bt ,ct ,rt ,t_soisno) !======================================================================= ! melting or freezing !======================================================================= - do j = lb, nl_soil - 1 + DO j = lb, nl_soil - 1 fn1(j) = tk(j)*(t_soisno(j+1)-t_soisno(j))/(z_soisno(j+1)-z_soisno(j)) - enddo + ENDDO fn1(nl_soil) = 0. j = lb brr(j) = cnfac*fn(j) + (1.-cnfac)*fn1(j) - do j = lb + 1, nl_soil + DO j = lb + 1, nl_soil brr(j) = cnfac*(fn(j)-fn(j-1)) + (1.-cnfac)*(fn1(j)-fn1(j-1)) - enddo + ENDDO IF (DEF_USE_SNICAR) THEN wice_soisno_bef(lb:0) = wice_soisno(lb:0) - call meltf_snicar (itypwat,lb,nl_soil,deltim, & - fact(lb:),brr(lb:),hs,dhsdT,sabg_lyr, & + CALL meltf_snicar (patchtype,lb,nl_soil,deltim, & + fact(lb:),brr(lb:),hs,hs_soil,hs_snow,fsno,sabg_snow_lyr(lb:),dhsdT, & t_soisno_bef(lb:),t_soisno(lb:),wliq_soisno(lb:),wice_soisno(lb:),imelt(lb:), & scv,snowdp,sm,xmf,porsl,psi0,& #ifdef Campbell_SOIL_MODEL @@ -340,8 +419,8 @@ subroutine groundtem (itypwat,lb,nl_soil,deltim,& ENDDO ELSE - call meltf (itypwat,lb,nl_soil,deltim, & - fact(lb:),brr(lb:),hs,dhsdT, & + CALL meltf (patchtype,lb,nl_soil,deltim, & + fact(lb:),brr(lb:),hs,hs_soil,hs_snow,fsno,dhsdT, & t_soisno_bef(lb:),t_soisno(lb:),wliq_soisno(lb:),wice_soisno(lb:),imelt(lb:), & scv,snowdp,sm,xmf,porsl,psi0,& #ifdef Campbell_SOIL_MODEL @@ -356,6 +435,6 @@ subroutine groundtem (itypwat,lb,nl_soil,deltim,& !----------------------------------------------------------------------- - end subroutine groundtem + END SUBROUTINE GroundTemperature END MODULE MOD_GroundTemperature diff --git a/main/MOD_Hist.F90 b/main/MOD_Hist.F90 index a220c727..a5aebdd8 100644 --- a/main/MOD_Hist.F90 +++ b/main/MOD_Hist.F90 @@ -14,11 +14,11 @@ module MOD_Hist ! ! TODO...(need complement) !---------------------------------------------------------------------------- - + use MOD_Vars_1DAccFluxes - use MOD_Vars_Global, only : spval + USE MOD_Vars_Global, only : spval USE MOD_NetCDFSerial - + use MOD_HistGridded #if (defined UNSTRUCTURED || defined CATCHMENT) use MOD_HistVector @@ -26,7 +26,7 @@ module MOD_Hist #ifdef SinglePoint use MOD_HistSingle #endif -#ifdef LATERAL_FLOW +#ifdef CatchLateralFlow USE MOD_Hydro_Hist #endif @@ -34,7 +34,7 @@ module MOD_Hist public :: hist_out public :: hist_final - character(len=10) :: HistForm ! 'Gridded', 'Vector', 'Single' + character(len=10) :: HistForm ! 'Gridded', 'Vector', 'Single' !-------------------------------------------------------------------------- contains @@ -67,7 +67,7 @@ subroutine hist_init (dir_hist) #endif ENDIF -#ifdef LATERAL_FLOW +#ifdef CatchLateralFlow CALL hist_basin_init () #endif @@ -84,7 +84,7 @@ subroutine hist_final () CALL hist_single_final () #endif -#ifdef LATERAL_FLOW +#ifdef CatchLateralFlow CALL hist_basin_final () #endif @@ -103,22 +103,27 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & use MOD_TimeManager use MOD_SPMD_Task use MOD_Vars_1DAccFluxes + USE MOD_Vars_TimeVariables, only : wa, wat, wetwat, wdsrf use MOD_Block use MOD_DataType use MOD_LandPatch use MOD_Mapping_Pset2Grid - USE MOD_Vars_TimeInvariants, only : patchtype, patchclass + USE MOD_Vars_TimeInvariants, only: patchtype, patchclass, patchmask #ifdef URBAN_MODEL USE MOD_LandUrban #endif -#ifdef LULC_IGBP_PFT +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) USE MOD_Vars_PFTimeInvariants, only: pftclass - USE MOD_LandPFT, only : patch_pft_s + USE MOD_LandPFT, only: patch_pft_s #endif #if(defined CaMa_Flood) use MOD_CaMa_Vars !defination of CaMa variables #endif - USE MOD_Forcing, only : forcmask + USE MOD_Forcing, only: forcmask +#ifdef DataAssimilation + USE MOD_DA_GRACE, only : fslp_k_mon +#endif + IMPLICIT NONE integer, INTENT(in) :: idate(3) @@ -165,13 +170,13 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & case ('TIMESTEP') lwrite = .true. case ('HOURLY') - lwrite = isendofhour (idate, deltim) + lwrite = isendofhour (idate, deltim) .or. (.not. (itstamp < etstamp)) case ('DAILY') - lwrite = isendofday(idate, deltim) + lwrite = isendofday (idate, deltim) .or. (.not. (itstamp < etstamp)) case ('MONTHLY') - lwrite = isendofmonth(idate, deltim) + lwrite = isendofmonth(idate, deltim) .or. (.not. (itstamp < etstamp)) case ('YEARLY') - lwrite = isendofyear(idate, deltim) + lwrite = isendofyear (idate, deltim) .or. (.not. (itstamp < etstamp)) case default write(*,*) 'Warning : Please use one of TIMESTEP/HOURLY/DAILY/MONTHLY/YEARLY for history frequency.' end select @@ -211,9 +216,9 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & #if(defined CaMa_Flood) ! add variables to write cama-flood output. ! file name of cama-flood output - file_hist_cama = trim(dir_hist) // '/' // trim(site) //'_hist_cama_'//trim(cdate)//'.nc' + file_hist_cama = trim(dir_hist) // '/' // trim(site) //'_hist_cama_'//trim(cdate)//'.nc' ! write CaMa-Flood output - call hist_write_cama_time (file_hist_cama, 'time', idate, itime_in_file_cama) + call hist_write_cama_time (file_hist_cama, 'time', idate, itime_in_file_cama) #endif file_hist = trim(dir_hist) // '/' // trim(site) //'_hist_'//trim(cdate)//'.nc' @@ -246,14 +251,18 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF ! --------------------------------------------------- - ! Meteorological forcing + ! Meteorological forcing and patch mask filter applying. ! --------------------------------------------------- if (p_is_worker) then if (numpatch > 0) then + filter(:) = patchtype < 99 + IF (DEF_forcing%has_missing_value) THEN filter = filter .and. forcmask ENDIF + + filter = filter .and. patchmask end if end if @@ -261,6 +270,13 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF + IF (HistForm == 'Gridded') THEN + IF (itime_in_file == 1) then + call hist_write_var_real8_2d (file_hist, 'landarea', ghist, 1, sumarea, & + compress = 1, longname = 'land area', units = 'km2') + ENDIF + ENDIF + ! wind in eastward direction [m/s] call write_history_variable_2d ( DEF_hist_vars%xy_us, & a_us, file_hist, 'f_xy_us', itime_in_file, sumarea, filter, & @@ -328,10 +344,14 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ! ------------------------------------------------------------------------------------------ if (p_is_worker) then if (numpatch > 0) then + filter(:) = patchtype < 99 + IF (DEF_forcing%has_missing_value) THEN filter = filter .and. forcmask ENDIF + + filter = filter .and. patchmask end if end if @@ -432,17 +452,40 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ! surface runoff [mm/s] call write_history_variable_2d ( DEF_hist_vars%rsur, & a_rsur, file_hist, 'f_rsur', itime_in_file, sumarea, filter, & - 'surface runoff / surface water change by lateral flow)','mm/s') + 'surface runoff','mm/s') ! subsurface runoff [mm/s] call write_history_variable_2d ( DEF_hist_vars%rsub, & a_rsub, file_hist, 'f_rsub', itime_in_file, sumarea, filter, & - 'subsurface runoff / groundwater change by lateral flow','mm/s') + 'subsurface runoff','mm/s') ! total runoff [mm/s] call write_history_variable_2d ( DEF_hist_vars%rnof, & a_rnof, file_hist, 'f_rnof', itime_in_file, sumarea, filter, & - 'total runoff / total change of surface water and groundwater by lateral flow','mm/s') + 'total runoff','mm/s') + +#ifdef DataAssimilation + ! slope factors for runoff [-] + IF (p_is_worker) THEN + vecacc = fslp_k_mon(month,:) + WHERE(vecacc /= spval) vecacc = vecacc * nac + ENDIF + call write_history_variable_2d ( .true., & + vecacc, file_hist, 'f_slope_factor_k', itime_in_file, sumarea, filter, & + 'slope factor [k] for runoff', '-') +#endif + +#ifdef CatchLateralFlow + ! rate of surface water depth change [mm/s] + call write_history_variable_2d ( DEF_hist_vars%xwsur, & + a_xwsur, file_hist, 'f_xwsur', itime_in_file, sumarea, filter, & + 'rate of surface water depth change','mm/s') + + ! rate of ground water change [mm/s] + call write_history_variable_2d ( DEF_hist_vars%xwsub, & + a_xwsub, file_hist, 'f_xwsub', itime_in_file, sumarea, filter, & + 'rate of ground water change','mm/s') +#endif ! interception [mm/s] call write_history_variable_2d ( DEF_hist_vars%qintr, & @@ -464,6 +507,15 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & a_wat, file_hist, 'f_wat', itime_in_file, sumarea, filter, & 'total water storage','mm') + ! instantaneous total water storage [mm] + IF (p_is_worker) THEN + vecacc = wat + WHERE(vecacc /= spval) vecacc = vecacc * nac + ENDIF + call write_history_variable_2d ( DEF_hist_vars%wat_inst, & + vecacc, file_hist, 'f_wat_inst', itime_in_file, sumarea, filter, & + 'instantaneous total water storage','mm') + ! canopy assimilation rate [mol m-2 s-1] call write_history_variable_2d ( DEF_hist_vars%assim, & a_assim, file_hist, 'f_assim', itime_in_file, sumarea, filter, & @@ -569,6 +621,33 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & a_qref, file_hist, 'f_qref', itime_in_file, sumarea, filter, & '2 m height air specific humidity','kg/kg') + if (p_is_worker) then + if (numpatch > 0) then + + filter(:) = patchtype == 2 + + IF (DEF_forcing%has_missing_value) THEN + filter = filter .and. forcmask + ENDIF + + filter = filter .and. patchmask + end if + end if + + ! wetland water storage [mm] + call write_history_variable_2d ( DEF_hist_vars%wetwat, & + a_wetwat, file_hist, 'f_wetwat', itime_in_file, sumarea, filter, & + 'wetland water storage','mm') + + ! instantaneous wetland water storage [mm] + IF (p_is_worker) THEN + vecacc = wetwat + WHERE(vecacc /= spval) vecacc = vecacc * nac + ENDIF + call write_history_variable_2d ( DEF_hist_vars%wetwat_inst, & + vecacc, file_hist, 'f_wetwat_inst', itime_in_file, sumarea, filter, & + 'instantaneous wetland water storage','mm') + ! ------------------------------------------------------------------------------------------ ! Mapping the urban variables at patch [numurban] to grid ! ------------------------------------------------------------------------------------------ @@ -751,6 +830,11 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & a_gssha, file_hist, 'f_gssha', itime_in_file, sumarea, filter, & 'Ecosystem level canopy conductance on shaded canopy','mol m-2 s-1') + ! soil resistance [m/s] + call write_history_variable_2d ( DEF_hist_vars%rss, & + a_rss, file_hist, 'f_rss', itime_in_file, sumarea, filter, & + 'soil surface resistance','s/m') + #ifdef BGC ! leaf carbon display pool call write_history_variable_2d ( DEF_hist_vars%leafc, & @@ -1070,12 +1154,29 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & call write_history_variable_2d ( DEF_hist_vars%grainc_to_seed, & a_grainc_to_seed, file_hist, 'f_grainc_to_seed', itime_in_file, sumarea, filter, & 'grain to crop seed carbon','gC/m2/s') - ! grain to crop seed carbon call write_history_variable_2d ( DEF_hist_vars%fert_to_sminn, & a_fert_to_sminn, file_hist, 'f_fert_to_sminn', itime_in_file, sumarea, filter, & 'fertilization','gN/m2/s') + if(DEF_USE_IRRIGATION)then + ! irrigation rate mm/s in 4h is averaged to the given time resolution mm/s + call write_history_variable_2d ( DEF_hist_vars%irrig_rate, & + a_irrig_rate, file_hist, 'f_irrig_rate', itime_in_file, sumarea, filter, & + 'irrigation rate mm/s in 4h is averaged to the given time resolution mm/s','mm/s') + ! still need irrigation amounts + call write_history_variable_2d ( DEF_hist_vars%deficit_irrig, & + a_deficit_irrig, file_hist, 'f_deficit_irrig', itime_in_file, sumarea, filter, & + 'still need irrigation amounts','kg/m2') + ! total irrigation amounts at growing season + call write_history_variable_2d ( DEF_hist_vars%sum_irrig, & + a_sum_irrig, file_hist, 'f_sum_irrig', itime_in_file, sumarea, filter, & + 'total irrigation amounts at growing season','kg/m2') + ! total irrigation times at growing season + call write_history_variable_2d ( DEF_hist_vars%sum_irrig_count, & + a_sum_irrig_count, file_hist, 'f_sum_irrig_count', itime_in_file, sumarea, filter, & + 'total irrigation times at growing season','-') + end if #endif ! grain to crop seed carbon @@ -1791,6 +1892,202 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & a_fertnitro_sugarcane, file_hist, 'f_fertnitro_sugarcane', & itime_in_file, sumarea, filter,'nitrogen fertilizer for sugarcane','gN/m2/yr') + if(DEF_USE_IRRIGATION)THEN + if (p_is_worker) then + if (numpatch > 0) then + do i=1,numpatch + if(patchclass(i) == 12)then + if(pftclass(patch_pft_s(i)) .eq. 17)then + filter(i) = .true. + else + filter(i) = .false. + end if + else + filter(i) = .false. + end if + end do + end if + end if + + IF (HistForm == 'Gridded') THEN + call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + ENDIF + + call write_history_variable_2d ( DEF_hist_vars%irrig_method_corn, & + a_irrig_method_corn, file_hist, 'f_irrig_method_corn', & + itime_in_file, sumarea, filter,'irrigation method for corn','-') + + if (p_is_worker) then + if (numpatch > 0) then + do i=1,numpatch + if(patchclass(i) == 12)then + if(pftclass(patch_pft_s(i)) .eq. 19 .or. pftclass(patch_pft_s(i)) .eq. 20)then + filter(i) = .true. + else + filter(i) = .false. + end if + else + filter(i) = .false. + end if + end do + end if + end if + + IF (HistForm == 'Gridded') THEN + call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + ENDIF + + call write_history_variable_2d ( DEF_hist_vars%irrig_method_swheat, & + a_irrig_method_swheat, file_hist, 'f_irrig_method_swheat', & + itime_in_file, sumarea, filter,'irrigation method for spring wheat','-') + + if (p_is_worker) then + if (numpatch > 0) then + do i=1,numpatch + if(patchclass(i) == 12)then + if(pftclass(patch_pft_s(i)) .eq. 21 .or. pftclass(patch_pft_s(i)) .eq. 22)then + filter(i) = .true. + else + filter(i) = .false. + end if + else + filter(i) = .false. + end if + end do + end if + end if + + IF (HistForm == 'Gridded') THEN + call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + ENDIF + + call write_history_variable_2d ( DEF_hist_vars%irrig_method_wwheat, & + a_irrig_method_wwheat, file_hist, 'f_irrig_method_wwheat', & + itime_in_file, sumarea, filter,'irrigation method for winter wheat','-') + + if (p_is_worker) then + if (numpatch > 0) then + do i=1,numpatch + if(patchclass(i) == 12)then + if(pftclass(patch_pft_s(i)) .eq. 23 .or. pftclass(patch_pft_s(i)) .eq. 24 & + .or. pftclass(patch_pft_s(i)) .eq. 77 .or. pftclass(patch_pft_s(i)) .eq. 78)then + filter(i) = .true. + else + filter(i) = .false. + end if + else + filter(i) = .false. + end if + end do + end if + end if + + IF (HistForm == 'Gridded') THEN + call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + ENDIF + + call write_history_variable_2d ( DEF_hist_vars%irrig_method_soybean, & + a_irrig_method_soybean, file_hist, 'f_irrig_method_soybean', & + itime_in_file, sumarea, filter,'irrigation method for soybean','-') + + if (p_is_worker) then + if (numpatch > 0) then + do i=1,numpatch + if(patchclass(i) == 12)then + if(pftclass(patch_pft_s(i)) .eq. 41 .or. pftclass(patch_pft_s(i)) .eq. 42)then + filter(i) = .true. + else + filter(i) = .false. + end if + else + filter(i) = .false. + end if + end do + end if + end if + + IF (HistForm == 'Gridded') THEN + call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + ENDIF + + call write_history_variable_2d ( DEF_hist_vars%irrig_method_cotton, & + a_irrig_method_cotton, file_hist, 'f_irrig_method_cotton', & + itime_in_file, sumarea, filter,'irrigation method for cotton','-') + + if (p_is_worker) then + if (numpatch > 0) then + do i=1,numpatch + if(patchclass(i) == 12)then + if(pftclass(patch_pft_s(i)) .eq. 61 .or. pftclass(patch_pft_s(i)) .eq. 62)then + filter(i) = .true. + else + filter(i) = .false. + end if + else + filter(i) = .false. + end if + end do + end if + end if + + IF (HistForm == 'Gridded') THEN + call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + ENDIF + + call write_history_variable_2d ( DEF_hist_vars%irrig_method_rice1, & + a_irrig_method_rice1, file_hist, 'f_irrig_method_rice1', & + itime_in_file, sumarea, filter,'irrigation method for rice1','-') + + if (p_is_worker) then + if (numpatch > 0) then + do i=1,numpatch + if(patchclass(i) == 12)then + if(pftclass(patch_pft_s(i)) .eq. 61 .or. pftclass(patch_pft_s(i)) .eq. 62)then + filter(i) = .true. + else + filter(i) = .false. + end if + else + filter(i) = .false. + end if + end do + end if + end if + + IF (HistForm == 'Gridded') THEN + call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + ENDIF + + call write_history_variable_2d ( DEF_hist_vars%irrig_method_rice2, & + a_irrig_method_rice2, file_hist, 'f_irrig_method_rice2', & + itime_in_file, sumarea, filter,'irrigation method for rice2','-') + + if (p_is_worker) then + if (numpatch > 0) then + do i=1,numpatch + if(patchclass(i) == 12)then + if(pftclass(patch_pft_s(i)) .eq. 67 .or. pftclass(patch_pft_s(i)) .eq. 68)then + filter(i) = .true. + else + filter(i) = .false. + end if + else + filter(i) = .false. + end if + end do + end if + end if + + IF (HistForm == 'Gridded') THEN + call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + ENDIF + + call write_history_variable_2d ( DEF_hist_vars%irrig_method_sugarcane, & + a_irrig_method_sugarcane, file_hist, 'f_irrig_method_sugarcane', & + itime_in_file, sumarea, filter,'irrigation method for sugarcane','-') + + end if + if (p_is_worker) then if (numpatch > 0) then do i=1,numpatch @@ -1811,7 +2108,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF - ! grain to corn production carbon + ! planting date of rainfed temperate corn if (p_is_worker) then if (numpatch > 0) then vecacc (:) = a_plantdate (:) @@ -1819,7 +2116,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & end if call write_history_variable_2d ( DEF_hist_vars%plantdate_rainfed_temp_corn, & vecacc, file_hist, 'f_plantdate_rainfed_temp_corn', itime_in_file, sumarea, filter, & - 'Crop production (rainfed temperate corn)','gC/m2/s') + 'Crop planting date (rainfed temperate corn)','day') if (p_is_worker) then if (numpatch > 0) then @@ -1841,7 +2138,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF - ! grain to corn production carbon + ! planting date of irrigated temperate corn if (p_is_worker) then if (numpatch > 0) then vecacc (:) = a_plantdate (:) @@ -1849,7 +2146,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & end if call write_history_variable_2d ( DEF_hist_vars%plantdate_irrigated_temp_corn, & vecacc, file_hist, 'f_plantdate_irrigated_temp_corn', itime_in_file, sumarea, filter, & - 'Crop production (irrigated temperate corn)','gC/m2/s') + 'Crop planting date (irrigated temperate corn)','day') if (p_is_worker) then if (numpatch > 0) then @@ -1872,7 +2169,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF - ! grain to spring wheat production carbon + ! planting date of rainfed spring wheat if (p_is_worker) then if (numpatch > 0) then vecacc (:) = a_plantdate (:) @@ -1880,7 +2177,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & end if call write_history_variable_2d ( DEF_hist_vars%plantdate_rainfed_spwheat, & vecacc, file_hist, 'f_plantdate_rainfed_spwheat', itime_in_file, sumarea, filter, & - 'Crop production (rainfed spring wheat)','gC/m2/s') + 'Crop planting date (rainfed spring wheat)','day') if (p_is_worker) then if (numpatch > 0) then @@ -1903,7 +2200,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF - ! grain to spring wheat production carbon + ! planting date of irrigated spring wheat if (p_is_worker) then if (numpatch > 0) then vecacc (:) = a_plantdate (:) @@ -1911,7 +2208,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & end if call write_history_variable_2d ( DEF_hist_vars%plantdate_irrigated_spwheat, & vecacc, file_hist, 'f_plantdate_irrigated_spwheat', itime_in_file, sumarea, filter, & - 'Crop production (irrigated spring wheat)','gC/m2/s') + 'Crop planting date (irrigated spring wheat)','day') if (p_is_worker) then if (numpatch > 0) then @@ -1933,7 +2230,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF - ! grain to winter wheat production carbon + ! planting date of rainfed winter wheat if (p_is_worker) then if (numpatch > 0) then vecacc (:) = a_plantdate (:) @@ -1941,7 +2238,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & end if call write_history_variable_2d ( DEF_hist_vars%plantdate_rainfed_wtwheat, & vecacc, file_hist, 'f_plantdate_rainfed_wtwheat', itime_in_file, sumarea, filter, & - 'Crop production (rainfed winter wheat)','gC/m2/s') + 'Crop planting date (rainfed winter wheat)','day') if (p_is_worker) then if (numpatch > 0) then @@ -1963,7 +2260,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF - ! grain to winter wheat production carbon + ! planting date of irrigated winter wheat if (p_is_worker) then if (numpatch > 0) then vecacc (:) = a_plantdate (:) @@ -1971,7 +2268,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & end if call write_history_variable_2d ( DEF_hist_vars%plantdate_irrigated_wtwheat, & vecacc, file_hist, 'f_plantdate_irrigated_wtwheat', itime_in_file, sumarea, filter, & - 'Crop production (irrigated winter wheat)','gC/m2/s') + 'Crop planting date (irrigated winter wheat)','day') if (p_is_worker) then if (numpatch > 0) then @@ -1988,12 +2285,12 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & end do end if end if - + IF (HistForm == 'Gridded') THEN call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF - ! grain to soybean production carbon + ! planting date of rainfed temperate soybean if (p_is_worker) then if (numpatch > 0) then vecacc (:) = a_plantdate (:) @@ -2001,7 +2298,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & end if call write_history_variable_2d ( DEF_hist_vars%plantdate_rainfed_temp_soybean, & vecacc, file_hist, 'f_plantdate_rainfed_temp_soybean', itime_in_file, sumarea, filter, & - 'Crop production (rainfed temperate soybean)','gC/m2/s') + 'Crop planting date (rainfed temperate soybean)','day') if (p_is_worker) then if (numpatch > 0) then @@ -2018,12 +2315,12 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & end do end if end if - + IF (HistForm == 'Gridded') THEN call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF - ! grain to soybean production carbon + ! planting date of irrigated temperate soybean if (p_is_worker) then if (numpatch > 0) then vecacc (:) = a_plantdate (:) @@ -2031,7 +2328,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & end if call write_history_variable_2d ( DEF_hist_vars%plantdate_irrigated_temp_soybean, & vecacc, file_hist, 'f_plantdate_irrigated_temp_soybean', itime_in_file, sumarea, filter, & - 'Crop production (irrigated temperate soybean)','gC/m2/s') + 'Crop planting date (irrigated temperate soybean)','day') if (p_is_worker) then if (numpatch > 0) then @@ -2053,7 +2350,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF - ! grain to cotton production carbon + ! planting date of rainfed cotton if (p_is_worker) then if (numpatch > 0) then vecacc (:) = a_plantdate (:) @@ -2061,7 +2358,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & end if call write_history_variable_2d ( DEF_hist_vars%plantdate_rainfed_cotton, & vecacc, file_hist, 'f_plantdate_rainfed_cotton', itime_in_file, sumarea, filter, & - 'Crop production (rainfed cotton)','gC/m2/s') + 'Crop planting date (rainfed cotton)','day') if (p_is_worker) then if (numpatch > 0) then @@ -2083,7 +2380,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF - ! grain to cotton production carbon + ! planting date of irrigated cotton if (p_is_worker) then if (numpatch > 0) then vecacc (:) = a_plantdate (:) @@ -2091,7 +2388,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & end if call write_history_variable_2d ( DEF_hist_vars%plantdate_irrigated_cotton, & vecacc, file_hist, 'f_plantdate_irrigated_cotton', itime_in_file, sumarea, filter, & - 'Crop production (irrigated cotton)','gC/m2/s') + 'Crop planting date (irrigated cotton)','day') if (p_is_worker) then if (numpatch > 0) then @@ -2113,7 +2410,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF - ! grain to rice production carbon + ! planting date of rainfed rice if (p_is_worker) then if (numpatch > 0) then vecacc (:) = a_plantdate (:) @@ -2121,7 +2418,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & end if call write_history_variable_2d ( DEF_hist_vars%plantdate_rainfed_rice, & vecacc, file_hist, 'f_plantdate_rainfed_rice', itime_in_file, sumarea, filter, & - 'Crop production (rainfed rice)','gC/m2/s') + 'Crop planting date (rainfed rice)','day') if (p_is_worker) then if (numpatch > 0) then @@ -2143,7 +2440,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF - ! grain to rice production carbon + ! planting date of irrigated rice if (p_is_worker) then if (numpatch > 0) then vecacc (:) = a_plantdate (:) @@ -2151,7 +2448,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & end if call write_history_variable_2d ( DEF_hist_vars%plantdate_irrigated_rice, & vecacc, file_hist, 'f_plantdate_irrigated_rice', itime_in_file, sumarea, filter, & - 'Crop production (irrigated rice)','gC/m2/s') + 'Crop planting date (irrigated rice)','day') if (p_is_worker) then if (numpatch > 0) then @@ -2173,7 +2470,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF - ! grain to sugarcane production carbon + ! planting date of rainfed sugarcane if (p_is_worker) then if (numpatch > 0) then vecacc (:) = a_plantdate (:) @@ -2181,7 +2478,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & end if call write_history_variable_2d ( DEF_hist_vars%plantdate_rainfed_sugarcane, & vecacc, file_hist, 'f_plantdate_rainfed_sugarcane', itime_in_file, sumarea, filter, & - 'Crop production (rainfed sugarcane)','gC/m2/s') + 'Crop planting date (rainfed sugarcane)','day') if (p_is_worker) then if (numpatch > 0) then @@ -2203,7 +2500,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF - ! grain to sugarcane production carbon + ! planting date of irrigated sugarcane if (p_is_worker) then if (numpatch > 0) then vecacc (:) = a_plantdate (:) @@ -2211,7 +2508,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & end if call write_history_variable_2d ( DEF_hist_vars%plantdate_irrigated_sugarcane, & vecacc, file_hist, 'f_plantdate_irrigated_sugarcane', itime_in_file, sumarea, filter, & - 'Crop production (irrigated sugarcane)','gC/m2/s') + 'Crop planting date (irrigated sugarcane)','day') if (p_is_worker) then if (numpatch > 0) then @@ -2233,7 +2530,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF - ! grain to sugarcane production carbon + ! planting date of rainfed trop corn if (p_is_worker) then if (numpatch > 0) then vecacc (:) = a_plantdate (:) @@ -2241,7 +2538,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & end if call write_history_variable_2d ( DEF_hist_vars%plantdate_rainfed_trop_corn, & vecacc, file_hist, 'f_plantdate_rainfed_trop_corn', itime_in_file, sumarea, filter, & - 'Crop production (rainfed_trop_corn)','gC/m2/s') + 'Crop planting date (rainfed trop corn)','day') if (p_is_worker) then if (numpatch > 0) then @@ -2263,7 +2560,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF - ! grain to sugarcane production carbon + ! planting date of irrigated trop corn if (p_is_worker) then if (numpatch > 0) then vecacc (:) = a_plantdate (:) @@ -2271,7 +2568,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & end if call write_history_variable_2d ( DEF_hist_vars%plantdate_irrigated_trop_corn, & vecacc, file_hist, 'f_plantdate_irrigated_trop_corn', itime_in_file, sumarea, filter, & - 'Crop production (irrigated_trop_corn)','gC/m2/s') + 'Crop planting date (irrigated trop corn)','day') if (p_is_worker) then if (numpatch > 0) then @@ -2293,7 +2590,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF - ! grain to sugarcane production carbon + ! planting date of rainfed trop soybean if (p_is_worker) then if (numpatch > 0) then vecacc (:) = a_plantdate (:) @@ -2301,7 +2598,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & end if call write_history_variable_2d ( DEF_hist_vars%plantdate_rainfed_trop_soybean, & vecacc, file_hist, 'f_plantdate_rainfed_trop_soybean', itime_in_file, sumarea, filter, & - 'Crop production (rainfed trop soybean)','gC/m2/s') + 'Crop planting date (rainfed trop soybean)','day') if (p_is_worker) then if (numpatch > 0) then @@ -2323,7 +2620,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF - ! grain to sugarcane production carbon + ! planting date of irrigated trop soybean if (p_is_worker) then if (numpatch > 0) then vecacc (:) = a_plantdate (:) @@ -2331,7 +2628,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & end if call write_history_variable_2d ( DEF_hist_vars%plantdate_irrigated_trop_soybean, & vecacc, file_hist, 'f_plantdate_irrigated_trop_soybean', itime_in_file, sumarea, filter, & - 'Crop production (irrigated trop soybean)','gC/m2/s') + 'Crop planting date (irrigated trop soybean)','day') if (p_is_worker) then if (numpatch > 0) then @@ -2354,7 +2651,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF - ! grain to unmanaged crop production carbon + ! planting date of unmanaged crop production if (p_is_worker) then if (numpatch > 0) then vecacc (:) = a_plantdate (:) @@ -2362,7 +2659,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & end if call write_history_variable_2d ( DEF_hist_vars%plantdate_unmanagedcrop, & vecacc, file_hist, 'f_plantdate_unmanagedcrop', itime_in_file, sumarea, filter, & - 'Crop production (unmanaged crop production)','gC/m2/s') + 'Crop planting date (unmanaged crop production)','day') if (p_is_worker) then if (numpatch > 0) then @@ -2559,7 +2856,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & end do end if end if - + IF (HistForm == 'Gridded') THEN call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF @@ -2589,7 +2886,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & end do end if end if - + IF (HistForm == 'Gridded') THEN call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF @@ -2937,16 +3234,20 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & #endif ! -------------------------------------------------------------------- ! Temperature and water (excluding land water bodies and ocean patches) - ! [soil => 0; urban and built-up => 1; wetland => 2; land ice => 3; + ! [soil => 0; urban and built-up => 1; wetland => 2; land ice => 3; ! land water bodies => 4; ocean => 99] ! -------------------------------------------------------------------- if (p_is_worker) then if (numpatch > 0) then + filter(:) = patchtype <= 3 + IF (DEF_forcing%has_missing_value) THEN filter = filter .and. forcmask ENDIF + + filter = filter .and. patchmask end if end if @@ -2971,16 +3272,20 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ! -------------------------------------------------------------------- ! additial diagnostic variables for output (vegetated land only <=2) - ! [soil => 0; urban and built-up => 1; wetland => 2; land ice => 3; + ! [soil => 0; urban and built-up => 1; wetland => 2; land ice => 3; ! land water bodies => 4; ocean => 99] ! -------------------------------------------------------------------- if (p_is_worker) then if (numpatch > 0) then + filter(:) = patchtype <= 2 + IF (DEF_forcing%has_missing_value) THEN filter = filter .and. forcmask ENDIF + + filter = filter .and. patchmask end if end if @@ -3011,20 +3316,19 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & a_zwt, file_hist, 'f_zwt', itime_in_file, sumarea, filter, & 'the depth to water table','m') - ! water storage in aquifer [mm] - call write_history_variable_2d ( DEF_hist_vars%wa, & - a_wa, file_hist, 'f_wa', itime_in_file, sumarea, filter, & - 'water storage in aquifer','mm') - ! -------------------------------------------------------------------- - ! depth of surface water (excluding land ice and ocean patches) + ! depth of surface water (including land ice and ocean patches) ! -------------------------------------------------------------------- if (p_is_worker) then if (numpatch > 0) then - filter(:) = (patchtype <= 2) .or. (patchtype == 4) + + filter(:) = (patchtype <= 4) + IF (DEF_forcing%has_missing_value) THEN filter = filter .and. forcmask ENDIF + + filter = filter .and. patchmask end if end if @@ -3032,11 +3336,34 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF - ! depth of surface water [m] + ! water storage in aquifer [mm] + call write_history_variable_2d ( DEF_hist_vars%wa, & + a_wa, file_hist, 'f_wa', itime_in_file, sumarea, filter, & + 'water storage in aquifer','mm') + + ! instantaneous water storage in aquifer [mm] + IF (p_is_worker) THEN + vecacc = wa + WHERE(vecacc /= spval) vecacc = vecacc * nac + ENDIF + call write_history_variable_2d ( DEF_hist_vars%wa_inst, & + vecacc, file_hist, 'f_wa_inst', itime_in_file, sumarea, filter, & + 'instantaneous water storage in aquifer','mm') + + ! depth of surface water [mm] call write_history_variable_2d ( DEF_hist_vars%wdsrf, & a_wdsrf, file_hist, 'f_wdsrf', itime_in_file, sumarea, filter, & 'depth of surface water','mm') + ! instantaneous depth of surface water [mm] + IF (p_is_worker) THEN + vecacc = wdsrf + WHERE(vecacc /= spval) vecacc = vecacc * nac + ENDIF + call write_history_variable_2d ( DEF_hist_vars%wdsrf_inst, & + vecacc, file_hist, 'f_wdsrf_inst', itime_in_file, sumarea, filter, & + 'instantaneous depth of surface water','mm') + ! ----------------------------------------------- ! Land water bodies' ice fraction and temperature ! ----------------------------------------------- @@ -3069,10 +3396,14 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ! -------------------------------- if (p_is_worker) then if (numpatch > 0) then + filter(:) = patchtype < 99 + IF (DEF_forcing%has_missing_value) THEN filter = filter .and. forcmask ENDIF + + filter = filter .and. patchmask end if end if @@ -3248,7 +3579,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF #endif -#ifdef LATERAL_FLOW +#ifdef CatchLateralFlow CALL hist_basin_out (file_hist, idate) #endif @@ -3306,7 +3637,7 @@ subroutine write_history_variable_2d ( is_hist, & CALL single_write_2d ( & acc_vec, file_hist, varname, itime_in_file, longname, units) #endif - end select + end select end subroutine write_history_variable_2d @@ -3346,7 +3677,7 @@ subroutine write_history_variable_urb_2d ( is_hist, & CALL single_write_urb_2d ( & acc_vec, file_hist, varname, itime_in_file, longname, units) #endif - end select + end select end subroutine write_history_variable_urb_2d #endif @@ -3394,7 +3725,7 @@ subroutine write_history_variable_3d ( is_hist, & CALL single_write_3d (acc_vec, file_hist, varname, itime_in_file, & dim1name, ndim1, longname, units) #endif - end select + end select end subroutine write_history_variable_3d @@ -3438,7 +3769,7 @@ subroutine write_history_variable_4d ( is_hist, & CALL single_write_4d (acc_vec, file_hist, varname, itime_in_file, & dim1name, ndim1, dim2name, ndim2, longname, units) #endif - end select + end select end subroutine write_history_variable_4d @@ -3476,7 +3807,7 @@ subroutine write_history_variable_ln ( is_hist, & case ('Single') CALL single_write_ln (acc_vec, file_hist, varname, itime_in_file, longname, units) #endif - end select + end select end subroutine write_history_variable_ln @@ -3501,7 +3832,7 @@ subroutine hist_write_time (filename, dataname, time, itime) case ('Single') CALL hist_single_write_time (filename, dataname, time, itime) #endif - end select + end select end subroutine hist_write_time diff --git a/main/MOD_HistGridded.F90 b/main/MOD_HistGridded.F90 index ec73bff4..910ec1dc 100644 --- a/main/MOD_HistGridded.F90 +++ b/main/MOD_HistGridded.F90 @@ -20,6 +20,9 @@ module MOD_HistGridded use MOD_Mapping_Pset2Grid USE MOD_Namelist USE MOD_NetCDFSerial +#ifdef USEMPI + USE MOD_HistWriteBack +#endif type(grid_type), target :: ghist type(mapping_pset2grid_type) :: mp2g_hist @@ -41,6 +44,9 @@ subroutine hist_gridded_init (dir_hist) USE MOD_LandPatch #ifdef URBAN_MODEL USE MOD_LandUrban +#endif +#ifdef CROP + USE MOD_LandCrop #endif use MOD_Mapping_Pset2Grid use MOD_Vars_1DAccFluxes @@ -61,7 +67,7 @@ subroutine hist_gridded_init (dir_hist) #ifndef CROP call mp2g_hist%build (landpatch, ghist) #else - call mp2g_hist%build (landpatch, ghist, pctcrop) + call mp2g_hist%build (landpatch, ghist, pctshrpch) #endif #ifdef URBAN_MODEL @@ -141,13 +147,8 @@ subroutine flux_map_and_write_2d ( & end if compress = DEF_HIST_COMPRESS_LEVEL - call hist_write_var_real8_2d (file_hist, varname, ghist, itime_in_file, flux_xy_2d, compress) - - IF (p_is_master .and. (itime_in_file == 1) .and. (trim(DEF_HIST_mode) == 'one')) then - CALL ncio_put_attr (file_hist, varname, 'long_name', longname) - CALL ncio_put_attr (file_hist, varname, 'units', units) - CALL ncio_put_attr (file_hist, varname, 'missing_value', spval) - ENDIF + call hist_write_var_real8_2d (file_hist, varname, ghist, itime_in_file, & + flux_xy_2d, compress, longname, units) end subroutine flux_map_and_write_2d @@ -212,13 +213,8 @@ subroutine flux_map_and_write_urb_2d ( & end if compress = DEF_HIST_COMPRESS_LEVEL - call hist_write_var_real8_2d (file_hist, varname, ghist, itime_in_file, flux_xy_2d, compress) - - IF (p_is_master .and. (itime_in_file == 1) .and. (trim(DEF_HIST_mode) == 'one')) then - CALL ncio_put_attr (file_hist, varname, 'long_name', longname) - CALL ncio_put_attr (file_hist, varname, 'units', units) - CALL ncio_put_attr (file_hist, varname, 'missing_value', spval) - ENDIF + call hist_write_var_real8_2d (file_hist, varname, ghist, itime_in_file, flux_xy_2d, & + compress, longname, units) end subroutine flux_map_and_write_urb_2d @@ -292,13 +288,7 @@ subroutine flux_map_and_write_3d ( & compress = DEF_HIST_COMPRESS_LEVEL call hist_write_var_real8_3d (file_hist, varname, dim1name, ghist, & - itime_in_file, flux_xy_3d, compress) - - IF (p_is_master .and. (itime_in_file == 1) .and. (trim(DEF_HIST_mode) == 'one')) then - CALL ncio_put_attr (file_hist, varname, 'long_name', longname) - CALL ncio_put_attr (file_hist, varname, 'units', units) - CALL ncio_put_attr (file_hist, varname, 'missing_value', spval) - ENDIF + itime_in_file, flux_xy_3d, compress, longname, units) end subroutine flux_map_and_write_3d @@ -375,13 +365,7 @@ subroutine flux_map_and_write_4d ( & compress = DEF_HIST_COMPRESS_LEVEL call hist_write_var_real8_4d (file_hist, varname, dim1name, dim2name, & - ghist, itime_in_file, flux_xy_4d, compress) - - IF (p_is_master .and. (itime_in_file == 1) .and. (trim(DEF_HIST_mode) == 'one')) then - CALL ncio_put_attr (file_hist, varname, 'long_name', longname) - CALL ncio_put_attr (file_hist, varname, 'units', units) - CALL ncio_put_attr (file_hist, varname, 'missing_value', spval) - ENDIF + ghist, itime_in_file, flux_xy_4d, compress, longname, units) end subroutine flux_map_and_write_4d @@ -455,13 +439,7 @@ subroutine flux_map_and_write_ln ( & compress = DEF_HIST_COMPRESS_LEVEL call hist_write_var_real8_2d (file_hist, varname, ghist, itime_in_file, flux_xy_2d, & - compress) - - IF (p_is_master .and. (itime_in_file == 1) .and. (trim(DEF_HIST_mode) == 'one')) then - CALL ncio_put_attr (file_hist, varname, 'long_name', longname) - CALL ncio_put_attr (file_hist, varname, 'units', units) - CALL ncio_put_attr (file_hist, varname, 'missing_value', spval) - ENDIF + compress, longname, units) end subroutine flux_map_and_write_ln @@ -488,6 +466,11 @@ subroutine hist_gridded_write_time ( & if (trim(DEF_HIST_mode) == 'one') then if (p_is_master) then +#ifdef USEMPI + IF (DEF_HIST_WriteBack) THEN + CALL hist_writeback_latlon_time (filename, dataname, time, hist_concat) + ELSE +#endif inquire (file=filename, exist=fexists) if (.not. fexists) then call ncio_create_file (trim(filename)) @@ -510,9 +493,19 @@ subroutine hist_gridded_write_time ( & call ncio_write_serial (filename, 'lon_e', hist_concat%ginfo%lon_e, 'lon') #endif endif + call ncio_write_time (filename, dataname, time, itime, DEF_HIST_FREQ) +#ifdef USEMPI + ENDIF +#endif + ENDIF + +#ifdef USEMPI + IF (.not. DEF_HIST_WriteBack) THEN + CALL mpi_bcast (itime, 1, MPI_INTEGER, p_root, p_comm_glb, p_err) ENDIF +#endif elseif (trim(DEF_HIST_mode) == 'block') then @@ -538,13 +531,17 @@ subroutine hist_gridded_write_time ( & end do end if +#ifdef USEMPI + IF (.not. p_is_master) CALL mpi_bcast (itime, 1, MPI_INTEGER, p_root, p_comm_group, p_err) +#endif + endif end subroutine hist_gridded_write_time !---------------------------------------------------------------------------- subroutine hist_write_var_real8_2d ( & - filename, dataname, grid, itime, wdata, compress) + filename, dataname, grid, itime, wdata, compress, longname, units) use MOD_Namelist use MOD_Block @@ -562,6 +559,8 @@ subroutine hist_write_var_real8_2d ( & type (block_data_real8_2d), intent(in) :: wdata integer, intent(in) :: compress + character(len=*), intent(in) :: longname + character(len=*), intent(in) :: units ! Local variables integer :: iblkme, iblk, jblk, idata, ixseg, iyseg @@ -574,33 +573,43 @@ subroutine hist_write_var_real8_2d ( & if (p_is_master) then - allocate (vdata (hist_concat%ginfo%nlon, hist_concat%ginfo%nlat)) - vdata(:,:) = spval - #ifdef USEMPI - do idata = 1, hist_concat%ndatablk - call mpi_recv (rmesg, 3, MPI_INTEGER, MPI_ANY_SOURCE, & - hist_data_id, p_comm_glb, p_stat, p_err) + IF (.not. DEF_HIST_WriteBack) THEN + + allocate (vdata (hist_concat%ginfo%nlon, hist_concat%ginfo%nlat)) + vdata(:,:) = spval - isrc = rmesg(1) - ixseg = rmesg(2) - iyseg = rmesg(3) + do idata = 1, hist_concat%ndatablk + call mpi_recv (rmesg, 3, MPI_INTEGER, MPI_ANY_SOURCE, & + hist_data_id, p_comm_glb, p_stat, p_err) - xgdsp = hist_concat%xsegs(ixseg)%gdsp - ygdsp = hist_concat%ysegs(iyseg)%gdsp - xcnt = hist_concat%xsegs(ixseg)%cnt - ycnt = hist_concat%ysegs(iyseg)%cnt + isrc = rmesg(1) + ixseg = rmesg(2) + iyseg = rmesg(3) - allocate (rbuf(xcnt,ycnt)) + xgdsp = hist_concat%xsegs(ixseg)%gdsp + ygdsp = hist_concat%ysegs(iyseg)%gdsp + xcnt = hist_concat%xsegs(ixseg)%cnt + ycnt = hist_concat%ysegs(iyseg)%cnt - call mpi_recv (rbuf, xcnt*ycnt, MPI_DOUBLE, & - isrc, hist_data_id, p_comm_glb, p_stat, p_err) + allocate (rbuf(xcnt,ycnt)) - vdata (xgdsp+1:xgdsp+xcnt, ygdsp+1:ygdsp+ycnt) = rbuf - deallocate (rbuf) + call mpi_recv (rbuf, xcnt*ycnt, MPI_DOUBLE, & + isrc, hist_data_id, p_comm_glb, p_stat, p_err) - end do + vdata (xgdsp+1:xgdsp+xcnt, ygdsp+1:ygdsp+ycnt) = rbuf + deallocate (rbuf) + + end do + + ELSE + CALL hist_writeback_var_header (hist_data_id, filename, dataname, & + 2, 'lon', 'lat', 'time', '', '', compress, longname, units) + ENDIF #else + allocate (vdata (hist_concat%ginfo%nlon, hist_concat%ginfo%nlat)) + vdata(:,:) = spval + do iyseg = 1, hist_concat%nyseg do ixseg = 1, hist_concat%nxseg iblk = hist_concat%xsegs(ixseg)%blk @@ -620,10 +629,23 @@ subroutine hist_write_var_real8_2d ( & end do #endif - call ncio_write_serial_time (filename, dataname, itime, vdata, & - 'lon', 'lat', 'time', compress) +#ifdef USEMPI + IF (.not. DEF_HIST_WriteBack) THEN +#endif + call ncio_write_serial_time (filename, dataname, itime, vdata, & + 'lon', 'lat', 'time', compress) + + IF (itime == 1) then + CALL ncio_put_attr (filename, dataname, 'long_name', longname) + CALL ncio_put_attr (filename, dataname, 'units', units) + CALL ncio_put_attr (filename, dataname, 'missing_value', spval) + ENDIF + + deallocate (vdata) +#ifdef USEMPI + ENDIF +#endif - deallocate (vdata) ENDIF #ifdef USEMPI @@ -644,11 +666,15 @@ subroutine hist_write_var_real8_2d ( & allocate (sbuf (xcnt,ycnt)) sbuf = wdata%blk(iblk,jblk)%val(xbdsp+1:xbdsp+xcnt,ybdsp+1:ybdsp+ycnt) - smesg = (/p_iam_glb, ixseg, iyseg/) - call mpi_send (smesg, 3, MPI_INTEGER, & - p_root, hist_data_id, p_comm_glb, p_err) - call mpi_send (sbuf, xcnt*ycnt, MPI_DOUBLE, & - p_root, hist_data_id, p_comm_glb, p_err) + IF (.not. DEF_HIST_WriteBack) THEN + smesg = (/p_iam_glb, ixseg, iyseg/) + call mpi_send (smesg, 3, MPI_INTEGER, & + p_root, hist_data_id, p_comm_glb, p_err) + call mpi_send (sbuf, xcnt*ycnt, MPI_DOUBLE, & + p_root, hist_data_id, p_comm_glb, p_err) + ELSE + CALL hist_writeback_var (hist_data_id, ixseg, iyseg, wdata2d = sbuf) + ENDIF deallocate (sbuf) @@ -684,7 +710,7 @@ end subroutine hist_write_var_real8_2d !---------------------------------------------------------------------------- subroutine hist_write_var_real8_3d ( & - filename, dataname, dim1name, grid, itime, wdata, compress) + filename, dataname, dim1name, grid, itime, wdata, compress, longname, units) use MOD_Namelist use MOD_Block @@ -703,6 +729,8 @@ subroutine hist_write_var_real8_3d ( & type (block_data_real8_3d), intent(in) :: wdata integer, intent(in) :: compress + character(len=*), intent(in) :: longname + character(len=*), intent(in) :: units ! Local variables integer :: iblkme, iblk, jblk, idata, ixseg, iyseg @@ -716,35 +744,42 @@ subroutine hist_write_var_real8_3d ( & if (p_is_master) then #ifdef USEMPI - do idata = 1, hist_concat%ndatablk + IF (.not. DEF_HIST_WriteBack) THEN - call mpi_recv (rmesg, 4, MPI_INTEGER, MPI_ANY_SOURCE, & - hist_data_id, p_comm_glb, p_stat, p_err) + do idata = 1, hist_concat%ndatablk - isrc = rmesg(1) - ixseg = rmesg(2) - iyseg = rmesg(3) - ndim1 = rmesg(4) + call mpi_recv (rmesg, 4, MPI_INTEGER, MPI_ANY_SOURCE, & + hist_data_id, p_comm_glb, p_stat, p_err) - xgdsp = hist_concat%xsegs(ixseg)%gdsp - ygdsp = hist_concat%ysegs(iyseg)%gdsp - xcnt = hist_concat%xsegs(ixseg)%cnt - ycnt = hist_concat%ysegs(iyseg)%cnt + isrc = rmesg(1) + ixseg = rmesg(2) + iyseg = rmesg(3) + ndim1 = rmesg(4) - allocate (rbuf (ndim1,xcnt,ycnt)) + xgdsp = hist_concat%xsegs(ixseg)%gdsp + ygdsp = hist_concat%ysegs(iyseg)%gdsp + xcnt = hist_concat%xsegs(ixseg)%cnt + ycnt = hist_concat%ysegs(iyseg)%cnt - call mpi_recv (rbuf, ndim1 * xcnt * ycnt, MPI_DOUBLE, & - isrc, hist_data_id, p_comm_glb, p_stat, p_err) + allocate (rbuf (ndim1,xcnt,ycnt)) - IF (idata == 1) THEN - allocate (vdata (ndim1, hist_concat%ginfo%nlon, hist_concat%ginfo%nlat)) - vdata(:,:,:) = spval - ENDIF + call mpi_recv (rbuf, ndim1 * xcnt * ycnt, MPI_DOUBLE, & + isrc, hist_data_id, p_comm_glb, p_stat, p_err) - vdata (:,xgdsp+1:xgdsp+xcnt,ygdsp+1:ygdsp+ycnt) = rbuf + IF (idata == 1) THEN + allocate (vdata (ndim1, hist_concat%ginfo%nlon, hist_concat%ginfo%nlat)) + vdata(:,:,:) = spval + ENDIF - deallocate (rbuf) - end do + vdata (:,xgdsp+1:xgdsp+xcnt,ygdsp+1:ygdsp+ycnt) = rbuf + + deallocate (rbuf) + end do + + ELSE + CALL hist_writeback_var_header (hist_data_id, filename, dataname, & + 3, dim1name, 'lon', 'lat', 'time', '', compress, longname, units) + ENDIF #else ndim1 = wdata%ub1 - wdata%lb1 + 1 allocate (vdata (ndim1, hist_concat%ginfo%nlon, hist_concat%ginfo%nlat)) @@ -769,12 +804,25 @@ subroutine hist_write_var_real8_3d ( & ENDDO #endif - call ncio_define_dimension (filename, dim1name, ndim1) - call ncio_write_serial_time (filename, dataname, itime, & - vdata, dim1name, 'lon', 'lat', 'time', compress) +#ifdef USEMPI + IF (.not. DEF_HIST_WriteBack) THEN +#endif + call ncio_define_dimension (filename, dim1name, ndim1) + + call ncio_write_serial_time (filename, dataname, itime, & + vdata, dim1name, 'lon', 'lat', 'time', compress) - deallocate (vdata) + IF (itime == 1) then + CALL ncio_put_attr (filename, dataname, 'long_name', longname) + CALL ncio_put_attr (filename, dataname, 'units', units) + CALL ncio_put_attr (filename, dataname, 'missing_value', spval) + ENDIF + + deallocate (vdata) +#ifdef USEMPI + ENDIF +#endif ENDIF #ifdef USEMPI @@ -797,11 +845,15 @@ subroutine hist_write_var_real8_3d ( & allocate (sbuf (ndim1,xcnt,ycnt)) sbuf = wdata%blk(iblk,jblk)%val(:,xbdsp+1:xbdsp+xcnt,ybdsp+1:ybdsp+ycnt) - smesg = (/p_iam_glb, ixseg, iyseg, ndim1/) - call mpi_send (smesg, 4, MPI_INTEGER, & - p_root, hist_data_id, p_comm_glb, p_err) - call mpi_send (sbuf, ndim1*xcnt*ycnt, MPI_DOUBLE, & - p_root, hist_data_id, p_comm_glb, p_err) + IF (.not. DEF_HIST_WriteBack) THEN + smesg = (/p_iam_glb, ixseg, iyseg, ndim1/) + call mpi_send (smesg, 4, MPI_INTEGER, & + p_root, hist_data_id, p_comm_glb, p_err) + call mpi_send (sbuf, ndim1*xcnt*ycnt, MPI_DOUBLE, & + p_root, hist_data_id, p_comm_glb, p_err) + ELSE + CALL hist_writeback_var (hist_data_id, ixseg, iyseg, wdata3d = sbuf) + ENDIF deallocate (sbuf) end if @@ -838,7 +890,7 @@ end subroutine hist_write_var_real8_3d !---------------------------------------------------------------------------- subroutine hist_write_var_real8_4d ( & - filename, dataname, dim1name, dim2name, grid, itime, wdata, compress) + filename, dataname, dim1name, dim2name, grid, itime, wdata, compress, longname, units) use MOD_Namelist use MOD_Block @@ -857,6 +909,8 @@ subroutine hist_write_var_real8_4d ( & type (block_data_real8_4d), intent(in) :: wdata integer, intent(in) :: compress + character(len=*), intent(in) :: longname + character(len=*), intent(in) :: units ! Local variables integer :: iblkme, iblk, jblk, idata, ixseg, iyseg @@ -870,36 +924,43 @@ subroutine hist_write_var_real8_4d ( & if (p_is_master) then #ifdef USEMPI - do idata = 1, hist_concat%ndatablk + IF (.not. DEF_HIST_WriteBack) THEN - call mpi_recv (rmesg, 5, MPI_INTEGER, MPI_ANY_SOURCE, & - hist_data_id, p_comm_glb, p_stat, p_err) + do idata = 1, hist_concat%ndatablk - isrc = rmesg(1) - ixseg = rmesg(2) - iyseg = rmesg(3) - ndim1 = rmesg(4) - ndim2 = rmesg(4) + call mpi_recv (rmesg, 5, MPI_INTEGER, MPI_ANY_SOURCE, & + hist_data_id, p_comm_glb, p_stat, p_err) - xgdsp = hist_concat%xsegs(ixseg)%gdsp - ygdsp = hist_concat%ysegs(iyseg)%gdsp - xcnt = hist_concat%xsegs(ixseg)%cnt - ycnt = hist_concat%ysegs(iyseg)%cnt + isrc = rmesg(1) + ixseg = rmesg(2) + iyseg = rmesg(3) + ndim1 = rmesg(4) + ndim2 = rmesg(4) - allocate (rbuf (ndim1,ndim2,xcnt,ycnt)) + xgdsp = hist_concat%xsegs(ixseg)%gdsp + ygdsp = hist_concat%ysegs(iyseg)%gdsp + xcnt = hist_concat%xsegs(ixseg)%cnt + ycnt = hist_concat%ysegs(iyseg)%cnt - call mpi_recv (rbuf, ndim1*ndim2*xcnt*ycnt, MPI_DOUBLE, & - isrc, hist_data_id, p_comm_glb, p_stat, p_err) + allocate (rbuf (ndim1,ndim2,xcnt,ycnt)) - IF (idata == 1) THEN - allocate (vdata (ndim1,ndim2,hist_concat%ginfo%nlon,hist_concat%ginfo%nlat)) - vdata(:,:,:,:) = spval - ENDIF + call mpi_recv (rbuf, ndim1*ndim2*xcnt*ycnt, MPI_DOUBLE, & + isrc, hist_data_id, p_comm_glb, p_stat, p_err) - vdata (:,:,xgdsp+1:xgdsp+xcnt,ygdsp+1:ygdsp+ycnt) = rbuf + IF (idata == 1) THEN + allocate (vdata (ndim1,ndim2,hist_concat%ginfo%nlon,hist_concat%ginfo%nlat)) + vdata(:,:,:,:) = spval + ENDIF - deallocate (rbuf) - end do + vdata (:,:,xgdsp+1:xgdsp+xcnt,ygdsp+1:ygdsp+ycnt) = rbuf + + deallocate (rbuf) + end do + + ELSE + CALL hist_writeback_var_header (hist_data_id, filename, dataname, & + 4, dim1name, dim2name, 'lon', 'lat', 'time', compress, longname, units) + ENDIF #else ndim1 = wdata%ub1 - wdata%lb1 + 1 ndim2 = wdata%ub2 - wdata%lb2 + 1 @@ -926,13 +987,25 @@ subroutine hist_write_var_real8_4d ( & #endif - call ncio_define_dimension (filename, dim1name, ndim1) - call ncio_define_dimension (filename, dim2name, ndim2) - - call ncio_write_serial_time (filename, dataname, itime, vdata, dim1name, dim2name, & - 'lon', 'lat', 'time', compress) +#ifdef USEMPI + IF (.not. DEF_HIST_WriteBack) THEN +#endif + call ncio_define_dimension (filename, dim1name, ndim1) + call ncio_define_dimension (filename, dim2name, ndim2) + + call ncio_write_serial_time (filename, dataname, itime, vdata, & + dim1name, dim2name, 'lon', 'lat', 'time', compress) + + IF (itime == 1) then + CALL ncio_put_attr (filename, dataname, 'long_name', longname) + CALL ncio_put_attr (filename, dataname, 'units', units) + CALL ncio_put_attr (filename, dataname, 'missing_value', spval) + ENDIF - deallocate (vdata) + deallocate (vdata) +#ifdef USEMPI + ENDIF +#endif ENDIF #ifdef USEMPI @@ -956,11 +1029,15 @@ subroutine hist_write_var_real8_4d ( & allocate (sbuf (ndim1,ndim2,xcnt,ycnt)) sbuf = wdata%blk(iblk,jblk)%val(:,:,xbdsp+1:xbdsp+xcnt,ybdsp+1:ybdsp+ycnt) - smesg = (/p_iam_glb, ixseg, iyseg, ndim1, ndim2/) - call mpi_send (smesg, 5, MPI_INTEGER, & - p_root, hist_data_id, p_comm_glb, p_err) - call mpi_send (sbuf, ndim1*ndim2*xcnt*ycnt, MPI_DOUBLE, & - p_root, hist_data_id, p_comm_glb, p_err) + IF (.not. DEF_HIST_WriteBack) THEN + smesg = (/p_iam_glb, ixseg, iyseg, ndim1, ndim2/) + call mpi_send (smesg, 5, MPI_INTEGER, & + p_root, hist_data_id, p_comm_glb, p_err) + call mpi_send (sbuf, ndim1*ndim2*xcnt*ycnt, MPI_DOUBLE, & + p_root, hist_data_id, p_comm_glb, p_err) + ELSE + CALL hist_writeback_var (hist_data_id, ixseg, iyseg, wdata4d = sbuf) + ENDIF deallocate (sbuf) end if diff --git a/main/MOD_HistSingle.F90 b/main/MOD_HistSingle.F90 index 148c8982..c13e6887 100644 --- a/main/MOD_HistSingle.F90 +++ b/main/MOD_HistSingle.F90 @@ -15,6 +15,7 @@ module MOD_HistSingle USE MOD_Precision USE MOD_NetCDFSerial USE MOD_Namelist, only : USE_SITE_HistWriteBack + USE MOD_SPMD_Task logical :: memory_to_disk @@ -218,7 +219,7 @@ SUBROUTINE single_write_2d ( & IF (thisvar%varname /= varname) THEN write(*,*) 'Warning: history variable in memory is wrong: ' & // trim(thisvar%varname) // ' should be ' // trim(varname) - STOP + CALL CoLM_stop () ENDIF thisvar%v2d(:,itime_mem) = acc_vec(:) @@ -276,7 +277,7 @@ SUBROUTINE single_write_urb_2d ( & IF (thisvar%varname /= varname) THEN write(*,*) 'Warning: history variable in memory is wrong: ' & // trim(thisvar%varname) // ' should be ' // trim(varname) - STOP + CALL CoLM_stop () ENDIF thisvar%v2d(:,itime_mem) = acc_vec @@ -337,7 +338,7 @@ SUBROUTINE single_write_ln ( & IF (thisvar%varname /= varname) THEN write(*,*) 'Warning: history variable in memory is wrong: ' & // trim(thisvar%varname) // ' should be ' // trim(varname) - STOP + CALL CoLM_stop () ENDIF thisvar%v2d(:,itime_mem) = acc_vec @@ -396,7 +397,7 @@ SUBROUTINE single_write_3d ( & IF (thisvar%varname /= varname) THEN write(*,*) 'Warning: history variable in memory is wrong: ' & // trim(thisvar%varname) // ' should be ' // trim(varname) - STOP + CALL CoLM_stop () ENDIF thisvar%v3d(:,:,itime_mem) = acc_vec @@ -461,7 +462,7 @@ SUBROUTINE single_write_4d ( & IF (thisvar%varname /= varname) THEN write(*,*) 'Warning: history variable in memory is wrong: ' & // trim(thisvar%varname) // ' should be ' // trim(varname) - STOP + CALL CoLM_stop () ENDIF thisvar%v4d(:,:,:,itime_mem) = acc_vec diff --git a/main/MOD_HistVector.F90 b/main/MOD_HistVector.F90 index 99c7c255..4ae9983c 100644 --- a/main/MOD_HistVector.F90 +++ b/main/MOD_HistVector.F90 @@ -5,7 +5,7 @@ module MOD_HistVector !---------------------------------------------------------------------------- ! DESCRIPTION: - ! + ! ! Write out vectorized model results to history files. ! ! Created by Shupeng Zhang, May 2023 @@ -243,7 +243,7 @@ subroutine aggregate_to_vector_and_write_3d ( & use MOD_Vars_Global, only: spval implicit none - real(r8), intent(in) :: acc_vec_patch (:,:) + real(r8), intent(in) :: acc_vec_patch (lb1:,:) character(len=*), intent(in) :: file_hist character(len=*), intent(in) :: varname integer, intent(in) :: itime_in_file @@ -413,7 +413,7 @@ subroutine aggregate_to_vector_and_write_4d ( & use MOD_Vars_Global, only: spval implicit none - real(r8), intent(in) :: acc_vec_patch (:,:,:) + real(r8), intent(in) :: acc_vec_patch (lb1:,lb2:,:) character(len=*), intent(in) :: file_hist character(len=*), intent(in) :: varname integer, intent(in) :: itime_in_file @@ -633,7 +633,8 @@ subroutine aggregate_to_vector_and_write_ln ( & IF ((istt > 0) .and. (iend >= istt)) THEN allocate (mask(istt:iend)) allocate (frac(istt:iend)) - mask = (acc_vec_patch(istt:iend) /= spval) .and. filter(istt:iend) .and. (nac_ln > 0) + mask = (acc_vec_patch(istt:iend) /= spval) & + .and. filter(istt:iend) .and. (nac_ln(istt:iend) > 0) IF (any(mask)) THEN #ifdef CATCHMENT frac = hru_patch%subfrc(istt:iend) diff --git a/main/MOD_HistWriteBack.F90 b/main/MOD_HistWriteBack.F90 new file mode 100644 index 00000000..c0a79dfc --- /dev/null +++ b/main/MOD_HistWriteBack.F90 @@ -0,0 +1,851 @@ +#include + +#ifdef USEMPI +module MOD_HistWriteBack + !---------------------------------------------------------------------------- + ! DESCRIPTION: + ! + ! Write out data to history files by a dedicated process. + ! + ! Author: Shupeng Zhang, 11/2023 + !---------------------------------------------------------------------------- + + use MOD_Precision + USE MOD_SPMD_Task + USE MOD_NetCDFSerial + + ! type of send buffer + type :: HistSendBufferType + integer :: dataid + integer :: datatag + integer :: sendreqs (3) + integer :: sendint4 (5) + character(len=256) :: sendchar (9) + real(r8), allocatable :: senddata (:) + type(HistSendBufferType), pointer :: next + END type HistSendBufferType + + ! Sending Variables + type(HistSendBufferType), pointer :: HistSendBuffer + type(HistSendBufferType), pointer :: LastSendBuffer + + ! type of times + type :: timenodetype + character(len=256) :: filename + character(len=256) :: timename + integer :: time(3) + integer :: req (3) + type(timenodetype), pointer :: next + END type timenodetype + + ! time nodes + integer :: dataid_zero = 0 + integer :: req_zero + type(timenodetype), pointer :: timenodes, lasttime + + ! dimension information + logical :: SDimInited = .false. + ! 1: grid-based; 2: catchment based; 3: unstructered + integer :: SDimType + + ! 1: grid-based + integer :: nGridData, nxGridSeg, nyGridSeg + integer, allocatable :: xGridDsp(:), xGridCnt(:) + integer, allocatable :: yGridDsp(:), yGridCnt(:) + + integer :: nlat, nlon + real(r8), allocatable :: lat_c(:), lat_s(:), lat_n(:) + real(r8), allocatable :: lon_c(:), lon_w(:), lon_e(:) + + ! 2: catchment based; 3: unstructured + ! integer :: SDimLength + ! integer*8, allocatable :: vindex1(:) + ! integer, allocatable :: vindex2(:) + + ! Memory limits + integer*8, parameter :: MaxHistMemSize = 8589934592_8 ! 8*1024^3 + integer*8, parameter :: MaxHistMesgSize = 8388608_8 ! 8*1024^2 + + integer*8 :: TotalMemSize = 0 + + integer :: itime_in_file + + ! tags + integer, parameter :: tag_next = 100 + integer, parameter :: tag_time = 101 + integer, parameter :: tag_dims = 102 + +contains + + ! ----- + subroutine hist_writeback_daemon () + + USE MOD_Namelist, only : DEF_HIST_FREQ + use MOD_Vars_Global, only: spval + IMPLICIT NONE + + ! Local Variables + integer :: dataid, tag + integer :: time(3), ndims, ndim1, ndim2, dimlens(4), compress + integer :: i, idata, isrc, ixseg, iyseg, xdsp, ydsp, xcnt, ycnt + + integer :: recvint4 (5) + character(len=256) :: recvchar (9) + real(r8), allocatable :: datathis (:) + + character(len=256) :: filename, dataname, longname, units + character(len=256) :: dim1name, dim2name, dim3name, dim4name, dim5name + logical :: fexists + + real(r8), allocatable :: wdata1d(:), wdata2d(:,:), wdata3d(:,:,:), wdata4d(:,:,:,:) + + + DO WHILE (.true.) + + CALL mpi_recv (dataid, 1, MPI_INTEGER, & + MPI_ANY_SOURCE, tag_next, p_comm_glb_plus, p_stat, p_err) + + IF (dataid < 0) THEN + + EXIT + + ELSEIF (dataid == 0) THEN + + CALL mpi_recv (filename, 256, MPI_CHARACTER, & + MPI_ANY_SOURCE, tag_time, p_comm_glb_plus, p_stat, p_err) + + CALL mpi_recv (dataname, 256, MPI_CHARACTER, & + MPI_ANY_SOURCE, tag_time, p_comm_glb_plus, p_stat, p_err) + + CALL mpi_recv (time, 3, MPI_INTEGER, & + MPI_ANY_SOURCE, tag_time, p_comm_glb_plus, p_stat, p_err) + + IF (.not. SDimInited) THEN + + CALL mpi_recv (SDimType, 1, MPI_INTEGER, & + MPI_ANY_SOURCE, tag_dims, p_comm_glb_plus, p_stat, p_err) + + IF (SDimType == 1) THEN + + CALL mpi_recv (nGridData, 1, MPI_INTEGER, & + MPI_ANY_SOURCE, tag_dims, p_comm_glb_plus, p_stat, p_err) + CALL mpi_recv (nxGridSeg, 1, MPI_INTEGER, & + MPI_ANY_SOURCE, tag_dims, p_comm_glb_plus, p_stat, p_err) + CALL mpi_recv (nyGridSeg, 1, MPI_INTEGER, & + MPI_ANY_SOURCE, tag_dims, p_comm_glb_plus, p_stat, p_err) + + allocate (xGridDsp (nxGridSeg)) + allocate (xGridCnt (nxGridSeg)) + allocate (yGridDsp (nyGridSeg)) + allocate (yGridCnt (nyGridSeg)) + + CALL mpi_recv (xGridDsp, nxGridSeg, MPI_INTEGER, & + MPI_ANY_SOURCE, tag_dims, p_comm_glb_plus, p_stat, p_err) + CALL mpi_recv (xGridCnt, nxGridSeg, MPI_INTEGER, & + MPI_ANY_SOURCE, tag_dims, p_comm_glb_plus, p_stat, p_err) + CALL mpi_recv (yGridDsp, nyGridSeg, MPI_INTEGER, & + MPI_ANY_SOURCE, tag_dims, p_comm_glb_plus, p_stat, p_err) + CALL mpi_recv (yGridCnt, nyGridSeg, MPI_INTEGER, & + MPI_ANY_SOURCE, tag_dims, p_comm_glb_plus, p_stat, p_err) + + CALL mpi_recv (nlat, 1, MPI_INTEGER, & + MPI_ANY_SOURCE, tag_dims, p_comm_glb_plus, p_stat, p_err) + + allocate(lat_c(nlat)) + allocate(lat_s(nlat)) + allocate(lat_n(nlat)) + + CALL mpi_recv (lat_c, nlat, MPI_REAL8, & + MPI_ANY_SOURCE, tag_dims, p_comm_glb_plus, p_stat, p_err) + CALL mpi_recv (lat_s, nlat, MPI_REAL8, & + MPI_ANY_SOURCE, tag_dims, p_comm_glb_plus, p_stat, p_err) + CALL mpi_recv (lat_n, nlat, MPI_REAL8, & + MPI_ANY_SOURCE, tag_dims, p_comm_glb_plus, p_stat, p_err) + + CALL mpi_recv (nlon, 1, MPI_INTEGER, & + MPI_ANY_SOURCE, tag_dims, p_comm_glb_plus, p_stat, p_err) + + allocate(lon_c(nlon)) + allocate(lon_w(nlon)) + allocate(lon_e(nlon)) + + CALL mpi_recv (lon_c, nlon, MPI_REAL8, & + MPI_ANY_SOURCE, tag_dims, p_comm_glb_plus, p_stat, p_err) + CALL mpi_recv (lon_w, nlon, MPI_REAL8, & + MPI_ANY_SOURCE, tag_dims, p_comm_glb_plus, p_stat, p_err) + CALL mpi_recv (lon_e, nlon, MPI_REAL8, & + MPI_ANY_SOURCE, tag_dims, p_comm_glb_plus, p_stat, p_err) + + ! elseif (SDimType == 2) THEN + ! + ! CALL mpi_recv (SDimLength, 1, MPI_INTEGER, & + ! MPI_ANY_SOURCE, tag_dims, p_comm_glb_plus, p_stat, p_err) + + ! allocate (vindex1(SDimLength)) + ! allocate (vindex2(SDimLength)) + + ! CALL mpi_recv (vindex1, SDimLength, MPI_INTEGER8, & + ! MPI_ANY_SOURCE, tag_dims, p_comm_glb_plus, p_stat, p_err) + ! CALL mpi_recv (vindex2, SDimLength, MPI_INTEGER, & + ! MPI_ANY_SOURCE, tag_dims, p_comm_glb_plus, p_stat, p_err) + + ! elseif (SDimType == 3) THEN + + ! CALL mpi_recv (SDimLength, 1, MPI_INTEGER, & + ! MPI_ANY_SOURCE, tag_dims, p_comm_glb_plus, p_stat, p_err) + + ! allocate (vindex1(SDimLength)) + ! CALL mpi_recv (vindex1, SDimLength, MPI_INTEGER8, & + ! MPI_ANY_SOURCE, tag_dims, p_comm_glb_plus, p_stat, p_err) + + ENDIF + + SDimInited = .true. + + ENDIF + + inquire (file=filename, exist=fexists) + if (.not. fexists) then + + call ncio_create_file (trim(filename)) + + CALL ncio_define_dimension(filename, 'time', 0) + + IF (SDimType == 1) THEN + + call ncio_define_dimension(filename, 'lat', nlat) + call ncio_define_dimension(filename, 'lon', nlon) + + call ncio_write_serial (filename, 'lat', lat_c, 'lat') + call ncio_write_serial (filename, 'lon', lon_c, 'lon') + call ncio_write_serial (filename, 'lat_s', lat_s, 'lat') + call ncio_write_serial (filename, 'lat_n', lat_n, 'lat') + call ncio_write_serial (filename, 'lon_w', lon_w, 'lon') + call ncio_write_serial (filename, 'lon_e', lon_e, 'lon') + + CALL ncio_put_attr (filename, 'lat', 'long_name', 'latitude') + CALL ncio_put_attr (filename, 'lat', 'units', 'degrees_north') + CALL ncio_put_attr (filename, 'lon', 'long_name', 'longitude') + CALL ncio_put_attr (filename, 'lon', 'units', 'degrees_east') + + ! ELSEIF (SDimType == 2) THEN + ! + ! call ncio_define_dimension(filename, 'hydrounit', SDimLength) + + ! call ncio_write_serial (filename, 'typ_hru' , vindex1, 'hydrounit') + ! CALL ncio_put_attr (filename, 'typ_hru' , 'long_name', & + ! 'index of hydrological units inside basin') + + ! call ncio_write_serial (filename, 'bsn_hru', vindex2, 'hydrounit') + ! CALL ncio_put_attr (filename, 'bsn_hru', 'long_name', & + ! 'basin index of hydrological units in mesh') + + ! ELSEIF (SDimType == 3) THEN + ! + ! call ncio_define_dimension(filename, 'element', SDimLength) + ! call ncio_write_serial (filename, 'elmindex', vindex1, 'element') + ! CALL ncio_put_attr (filename, 'elmindex', 'long_name', & + ! 'element index in mesh') + + ENDIF + + ENDIF + + call ncio_write_time (filename, dataname, time, itime_in_file, DEF_HIST_FREQ) + + ELSE + + !-------------------------------- + ! reveive and write history data. + !-------------------------------- + + ! (1) data header + tag = dataid*10000 + CALL mpi_recv (recvint4(1:2), 2, MPI_INTEGER, & + MPI_ANY_SOURCE, tag, p_comm_glb_plus, p_stat, p_err) + + ndims = recvint4(1) + compress = recvint4(2) + + CALL mpi_recv (recvchar(1:9), 256*9, MPI_CHARACTER, & + MPI_ANY_SOURCE, tag, p_comm_glb_plus, p_stat, p_err) + + filename = recvchar(1) + dataname = recvchar(2) + dim1name = recvchar(3) + dim2name = recvchar(4) + dim3name = recvchar(5) + dim4name = recvchar(6) + dim5name = recvchar(7) + longname = recvchar(8) + units = recvchar(9) + + ! (2) data + tag = dataid*10000+1 + + IF (SDimType == 1) THEN + DO idata = 1, nGridData + + call mpi_recv (recvint4(1:5), 5, MPI_INTEGER, MPI_ANY_SOURCE, & + tag, p_comm_glb_plus, p_stat, p_err) + + isrc = recvint4(1) + ixseg = recvint4(2) + iyseg = recvint4(3) + ndim1 = recvint4(4) + ndim2 = recvint4(5) + + xdsp = xGridDsp(ixseg) + ydsp = yGridDsp(iyseg) + xcnt = xGridCnt(ixseg) + ycnt = yGridCnt(iyseg) + + select case (ndims) + case (2) + + dimlens = (/nlon, nlat, 0, 0/) + + IF (.not. allocated(wdata2d)) THEN + allocate (wdata2d (nlon,nlat)) + ENDIF + + allocate (datathis(xcnt*ycnt)) + call mpi_recv (datathis, xcnt*ycnt, MPI_REAL8, & + isrc, tag, p_comm_glb_plus, p_stat, p_err) + + wdata2d(xdsp+1:xdsp+xcnt, ydsp+1:ydsp+ycnt) = & + reshape(datathis,(/xcnt,ycnt/)) + + case (3) + + dimlens = (/ndim1, nlon, nlat, 0/) + + IF (.not. allocated(wdata3d)) THEN + allocate (wdata3d (ndim1,nlon,nlat)) + ENDIF + + allocate (datathis(ndim1*xcnt*ycnt)) + call mpi_recv (datathis, ndim1*xcnt*ycnt, MPI_REAL8, & + isrc, tag, p_comm_glb_plus, p_stat, p_err) + + wdata3d(:,xdsp+1:xdsp+xcnt, ydsp+1:ydsp+ycnt) = & + reshape(datathis,(/ndim1,xcnt,ycnt/)) + + case (4) + + dimlens = (/ndim1, ndim2, nlon, nlat/) + + IF (.not. allocated(wdata4d)) THEN + allocate (wdata4d (ndim1,ndim2,nlon,nlat)) + ENDIF + + allocate (datathis(ndim1*ndim2*xcnt*ycnt)) + call mpi_recv (datathis, ndim1*ndim2*xcnt*ycnt, MPI_REAL8, & + isrc, tag, p_comm_glb_plus, p_stat, p_err) + + wdata4d(:,:,xdsp+1:xdsp+xcnt, ydsp+1:ydsp+ycnt) = & + reshape(datathis,(/ndim1,ndim2,xcnt,ycnt/)) + + END select + + deallocate (datathis) + + ENDDO + ! ELSE + ! SDimType == 2, 3 + ENDIF + + IF (ndims >= 1) CALL ncio_define_dimension (filename, dim1name, dimlens(1)) + IF (ndims >= 2) CALL ncio_define_dimension (filename, dim2name, dimlens(2)) + IF (ndims >= 3) CALL ncio_define_dimension (filename, dim3name, dimlens(3)) + IF (ndims >= 4) CALL ncio_define_dimension (filename, dim4name, dimlens(4)) + + select case (ndims) + case (1) + + call ncio_write_serial_time (filename, dataname, itime_in_file, wdata1d, & + dim1name, dim2name, compress) + + deallocate(wdata1d) + case (2) + + call ncio_write_serial_time (filename, dataname, itime_in_file, wdata2d, & + dim1name, dim2name, dim3name, compress) + + deallocate(wdata2d) + case (3) + + call ncio_write_serial_time (filename, dataname, itime_in_file, wdata3d, & + dim1name, dim2name, dim3name, dim4name, compress) + + deallocate(wdata3d) + case (4) + + call ncio_write_serial_time (filename, dataname, itime_in_file, wdata4d, & + dim1name, dim2name, dim3name, dim4name, dim5name, compress) + + deallocate(wdata4d) + END select + + IF (itime_in_file == 1) THEN + CALL ncio_put_attr (filename, dataname, 'long_name', longname) + CALL ncio_put_attr (filename, dataname, 'units', units) + CALL ncio_put_attr (filename, dataname, 'missing_value', spval) + ENDIF + + write(*,'(3A,I0,2A)') 'HIST WriteBack: ', trim(basename(filename)), & + ' (time ', itime_in_file, '): ', trim(dataname) + + ENDIF + + ENDDO + + END subroutine hist_writeback_daemon + + ! ----- + SUBROUTINE hist_writeback_latlon_time (filename, timename, time, HistConcat) + + USE MOD_Namelist + USE MOD_Grid + IMPLICIT NONE + + character (len=*), intent(in) :: filename + character (len=*), intent(in) :: timename + integer, intent(in) :: time(3) + TYPE(grid_concat_type), intent(in) :: HistConcat + + ! Local Variables + integer :: i + + CALL hist_writeback_append_timenodes (filename, timename, time) + + CALL mpi_isend (dataid_zero, 1, MPI_INTEGER, & + 0, tag_next, p_comm_glb_plus, req_zero, p_err) + + CALL mpi_isend (lasttime%filename, 256, MPI_CHARACTER, & + 0, tag_time, p_comm_glb_plus, lasttime%req(1), p_err) + + CALL mpi_isend (lasttime%timename, 256, MPI_CHARACTER, & + 0, tag_time, p_comm_glb_plus, lasttime%req(2), p_err) + + CALL mpi_isend (lasttime%time, 3, MPI_INTEGER, & + 0, tag_time, p_comm_glb_plus, lasttime%req(3), p_err) + + + IF (.not. SDimInited) THEN + + SDimType = 1 + CALL mpi_send (SDimType, 1, MPI_INTEGER, 0, tag_dims, p_comm_glb_plus, p_err) + + nGridData = HistConcat%ndatablk + nxGridSeg = HistConcat%nxseg + nyGridSeg = HistConcat%nyseg + + allocate (xGridDsp (nxGridSeg)) + allocate (xGridCnt (nxGridSeg)) + allocate (yGridDsp (nyGridSeg)) + allocate (yGridCnt (nyGridSeg)) + + DO i = 1, nxGridSeg + xGridDsp(i) = HistConcat%xsegs(i)%gdsp + xGridCnt(i) = HistConcat%xsegs(i)%cnt + ENDDO + + DO i = 1, nyGridSeg + yGridDsp(i) = HistConcat%ysegs(i)%gdsp + yGridCnt(i) = HistConcat%ysegs(i)%cnt + ENDDO + + CALL mpi_send (nGridData, 1, MPI_INTEGER, 0, tag_dims, p_comm_glb_plus, p_err) + CALL mpi_send (nxGridSeg, 1, MPI_INTEGER, 0, tag_dims, p_comm_glb_plus, p_err) + CALL mpi_send (nyGridSeg, 1, MPI_INTEGER, 0, tag_dims, p_comm_glb_plus, p_err) + + CALL mpi_send (xGridDsp, nxGridSeg, MPI_INTEGER, 0, tag_dims, p_comm_glb_plus, p_err) + CALL mpi_send (xGridCnt, nxGridSeg, MPI_INTEGER, 0, tag_dims, p_comm_glb_plus, p_err) + CALL mpi_send (yGridDsp, nyGridSeg, MPI_INTEGER, 0, tag_dims, p_comm_glb_plus, p_err) + CALL mpi_send (yGridCnt, nyGridSeg, MPI_INTEGER, 0, tag_dims, p_comm_glb_plus, p_err) + + nlat = HistConcat%ginfo%nlat + nlon = HistConcat%ginfo%nlon + allocate(lat_c(nlat)); lat_c = HistConcat%ginfo%lat_c + allocate(lat_s(nlat)); lat_s = HistConcat%ginfo%lat_s + allocate(lat_n(nlat)); lat_n = HistConcat%ginfo%lat_n + allocate(lon_c(nlon)); lon_c = HistConcat%ginfo%lon_c + allocate(lon_w(nlon)); lon_w = HistConcat%ginfo%lon_w + allocate(lon_e(nlon)); lon_e = HistConcat%ginfo%lon_e + + CALL mpi_send (nlat, 1, MPI_INTEGER, 0, tag_dims, p_comm_glb_plus, p_err) + CALL mpi_send (lat_c, nlat, MPI_REAL8, 0, tag_dims, p_comm_glb_plus, p_err) + CALL mpi_send (lat_s, nlat, MPI_REAL8, 0, tag_dims, p_comm_glb_plus, p_err) + CALL mpi_send (lat_n, nlat, MPI_REAL8, 0, tag_dims, p_comm_glb_plus, p_err) + CALL mpi_send (nlon, 1, MPI_INTEGER, 0, tag_dims, p_comm_glb_plus, p_err) + CALL mpi_send (lon_c, nlon, MPI_REAL8, 0, tag_dims, p_comm_glb_plus, p_err) + CALL mpi_send (lon_w, nlon, MPI_REAL8, 0, tag_dims, p_comm_glb_plus, p_err) + CALL mpi_send (lon_e, nlon, MPI_REAL8, 0, tag_dims, p_comm_glb_plus, p_err) + + SDimInited = .true. + + ENDIF + + CALL hist_writeback_clean_timenodes () + + END SUBROUTINE hist_writeback_latlon_time + + ! ----- + ! SUBROUTINE hist_writeback_vector_time (filename, & + ! timename, time, index1, index2) + + ! USE MOD_Namelist + ! IMPLICIT NONE + ! + ! character (len=*), intent(in) :: filename + ! character (len=*), intent(in) :: timename + ! integer, intent(in) :: time(3) + + ! integer*8, intent(in) :: index1(:) + ! integer, intent(in), optional :: index2(:) + + + ! CALL hist_writeback_append_timenodes (filename, timename, time) + + ! CALL mpi_isend (dataid_zero, 1, MPI_INTEGER, & + ! 0, mpi_tag_mesg, p_comm_glb_plus, req_zero, p_err) + + ! CALL mpi_isend (lasttime%filename, 256, MPI_CHARACTER, & + ! 0, mpi_tag_mesg, p_comm_glb_plus, lasttime%req(1), p_err) + ! + ! CALL mpi_isend (lasttime%timename, 256, MPI_CHARACTER, & + ! 0, mpi_tag_mesg, p_comm_glb_plus, lasttime%req(2), p_err) + + ! CALL mpi_isend (lasttime%time, 3, MPI_INTEGER, & + ! 0, mpi_tag_mesg, p_comm_glb_plus, lasttime%req(3), p_err) + + + ! IF (.not. SDimInited) THEN + + ! IF (.not. present(index2)) THEN + ! SDimType = 2 + ! ELSE + ! SDimType = 3 + ! ENDIF + + ! SDimLength = size(index1) + + ! CALL mpi_send (SDimType, 1, MPI_INTEGER, 0, mpi_tag_mesg, p_comm_glb_plus, p_err) + ! CALL mpi_send (SDimLength, 1, MPI_INTEGER, 0, mpi_tag_mesg, p_comm_glb_plus, p_err) + + ! CALL mpi_send (index1, SDimLength, MPI_INTEGER8, 0, mpi_tag_data, p_comm_glb_plus, p_err) + ! IF (present(index2)) THEN + ! CALL mpi_send (index2, SDimLength, MPI_INTEGER, 0, mpi_tag_data, p_comm_glb_plus, p_err) + ! ENDIF + + ! SDimInited = .true. + + ! ENDIF + + ! CALL hist_writeback_clean_timenodes () + + ! END SUBROUTINE hist_writeback_vector_time + + ! ----- + SUBROUTINE hist_writeback_append_timenodes (filename, timename, time) + + IMPLICIT NONE + + character (len=*), intent(in) :: filename + character (len=*), intent(in) :: timename + integer, intent(in) :: time(3) + + IF (.not. associated(timenodes)) THEN + allocate (timenodes) + lasttime => timenodes + ELSE + allocate (lasttime%next) + lasttime => lasttime%next + ENDIF + + lasttime%filename = filename + lasttime%timename = timename + lasttime%time = time + lasttime%next => null() + + END SUBROUTINE hist_writeback_append_timenodes + + ! ----- + SUBROUTINE hist_writeback_clean_timenodes + + IMPLICIT NONE + + ! Local Variables + logical :: senddone + integer :: stat(MPI_STATUS_SIZE,3) + type(timenodetype), pointer :: tempnode + + + DO WHILE (associated(timenodes%next)) + + CALL MPI_TestAll (3, timenodes%req, senddone, stat, p_err) + + IF (senddone) THEN + tempnode => timenodes + timenodes => timenodes%next + deallocate(tempnode) + ELSE + EXIT + ENDIF + ENDDO + + END SUBROUTINE hist_writeback_clean_timenodes + + ! ----- + SUBROUTINE hist_writeback_var_header (dataid, filename, dataname, & + ndims, dim1name, dim2name, dim3name, dim4name, dim5name, & + compress, longname, units) + + IMPLICIT NONE + + integer, intent(in) :: dataid + character(len=*), intent(in) :: filename, dataname + integer, intent(in) :: ndims + character(len=*), intent(in) :: dim1name, dim2name, dim3name, dim4name, dim5name + integer, intent(in) :: compress + character(len=*), intent(in) :: longname, units + + ! Local Variables + logical :: senddone + integer :: sendstat(MPI_STATUS_SIZE,3) + type(HistSendBufferType), pointer :: TempSendBuffer + + ! append sending buffer + IF (.not. associated(HistSendBuffer)) THEN + allocate (HistSendBuffer) + LastSendBuffer => HistSendBuffer + ELSE + allocate (LastSendBuffer%next) + LastSendBuffer => LastSendBuffer%next + ENDIF + + LastSendBuffer%next => null() + + ! clean sending buffer and free memory + DO WHILE (associated(HistSendBuffer%next)) + + CALL MPI_Testall (3, HistSendBuffer%sendreqs, senddone, sendstat, p_err) + + IF (senddone) THEN + + TempSendBuffer => HistSendBuffer + HistSendBuffer => HistSendBuffer%next + + IF (allocated(TempSendBuffer%senddata)) THEN + deallocate (TempSendBuffer%senddata) + ENDIF + deallocate (TempSendBuffer) + ELSE + EXIT + ENDIF + ENDDO + + LastSendBuffer%dataid = dataid + LastSendBuffer%datatag = dataid*10000 + + LastSendBuffer%sendint4(1:2) = (/ndims, compress/) + + LastSendBuffer%sendchar(1) = filename + LastSendBuffer%sendchar(2) = dataname + LastSendBuffer%sendchar(3) = dim1name + LastSendBuffer%sendchar(4) = dim2name + LastSendBuffer%sendchar(5) = dim3name + LastSendBuffer%sendchar(6) = dim4name + LastSendBuffer%sendchar(7) = dim5name + LastSendBuffer%sendchar(8) = longname + LastSendBuffer%sendchar(9) = units + + CALL mpi_isend (LastSendBuffer%dataid, 1, MPI_INTEGER, & + 0, tag_next, p_comm_glb_plus, LastSendBuffer%sendreqs(1), p_err) + + CALL mpi_isend (LastSendBuffer%sendint4(1:2), 2, MPI_INTEGER, & + 0, LastSendBuffer%datatag, p_comm_glb_plus, LastSendBuffer%sendreqs(2), p_err) + + CALL mpi_isend (LastSendBuffer%sendchar, 256*9, MPI_CHARACTER, & + 0, LastSendBuffer%datatag, p_comm_glb_plus, LastSendBuffer%sendreqs(3), p_err) + + END SUBROUTINE hist_writeback_var_header + + ! ----- + SUBROUTINE hist_writeback_var ( dataid, ixseg, iyseg, & + wdata1d, wdata2d, wdata3d, wdata4d) + + IMPLICIT NONE + + integer, intent(in) :: dataid, ixseg, iyseg + + real(r8), intent(in), optional :: wdata1d(:) + real(r8), intent(in), optional :: wdata2d(:,:) + real(r8), intent(in), optional :: wdata3d(:,:,:) + real(r8), intent(in), optional :: wdata4d(:,:,:,:) + + ! Local Variables + integer :: totalsize, ndim1, ndim2 + type(HistSendBufferType), pointer :: TempSendBuffer + + ! append sending buffer + IF (.not. associated(HistSendBuffer)) THEN + allocate (HistSendBuffer) + LastSendBuffer => HistSendBuffer + TotalMemSize = 0 + ELSE + allocate (LastSendBuffer%next) + LastSendBuffer => LastSendBuffer%next + ENDIF + + LastSendBuffer%next => null() + + ! clean sending buffer and free memory + DO WHILE ((TotalMemSize > MaxHistMemSize) .and. associated(HistSendBuffer%next)) + + CALL MPI_Waitall (2, HistSendBuffer%sendreqs(1:2), p_stat, p_err) + + TotalMemSize = TotalMemSize - size(HistSendBuffer%senddata) + + TempSendBuffer => HistSendBuffer + HistSendBuffer => HistSendBuffer%next + deallocate(TempSendBuffer%senddata) + deallocate(TempSendBuffer) + + ENDDO + + LastSendBuffer%datatag = dataid*10000+1 + + ndim1 = 0 + ndim2 = 0 + + IF (present(wdata1d)) THEN + + totalsize = size(wdata1d) + allocate(LastSendBuffer%senddata(totalsize)) + LastSendBuffer%senddata = wdata1d + + ELSEIF (present(wdata2d)) THEN + + totalsize = size(wdata2d) + allocate(LastSendBuffer%senddata(totalsize)) + LastSendBuffer%senddata = reshape(wdata2d, (/totalsize/)) + + ELSEIF (present(wdata3d)) THEN + + ndim1 = size(wdata3d,1) + totalsize = size(wdata3d) + allocate(LastSendBuffer%senddata(totalsize)) + LastSendBuffer%senddata = reshape(wdata3d, (/totalsize/)) + + ELSEIF (present(wdata4d)) THEN + + ndim1 = size(wdata4d,1) + ndim2 = size(wdata4d,2) + totalsize = size(wdata4d) + allocate(LastSendBuffer%senddata(totalsize)) + LastSendBuffer%senddata = reshape(wdata4d, (/totalsize/)) + + ENDIF + + TotalMemSize = TotalMemSize + totalsize + + LastSendBuffer%sendint4(1:5) = (/p_iam_glb_plus, ixseg, iyseg, ndim1, ndim2/) + + CALL mpi_isend (LastSendBuffer%sendint4(1:5), 5, MPI_INTEGER, & + 0, LastSendBuffer%datatag, p_comm_glb_plus, LastSendBuffer%sendreqs(1), p_err) + + CALL mpi_isend (LastSendBuffer%senddata, totalsize, MPI_REAL8, & + 0, LastSendBuffer%datatag, p_comm_glb_plus, LastSendBuffer%sendreqs(2), p_err) + + END SUBROUTINE hist_writeback_var + + ! ----- + subroutine hist_writeback_exit () + + IMPLICIT NONE + + ! Local Variables + integer :: dataid, nreq + type(timenodetype), pointer :: tempnode + type(HistSendBufferType), pointer :: TempSendBuffer + + lasttime => null() + DO WHILE (associated(timenodes)) + + CALL MPI_WaitAll (3, timenodes%req, p_stat, p_err) + + tempnode => timenodes + timenodes => timenodes%next + deallocate(tempnode) + ENDDO + + LastSendBuffer => null() + DO WHILE (associated(HistSendBuffer)) + + IF (allocated(HistSendBuffer%senddata)) THEN + CALL MPI_Waitall (2, HistSendBuffer%sendreqs(1:2), p_stat, p_err) + deallocate(HistSendBuffer%senddata) + ELSE + CALL MPI_Waitall (3, HistSendBuffer%sendreqs(1:3), p_stat, p_err) + ENDIF + + TempSendBuffer => HistSendBuffer + HistSendBuffer => HistSendBuffer%next + deallocate (TempSendBuffer) + + ENDDO + + IF (allocated(xGridDsp)) deallocate(xGridDsp) + IF (allocated(yGridDsp)) deallocate(yGridDsp) + IF (allocated(xGridCnt)) deallocate(xGridCnt) + IF (allocated(yGridCnt)) deallocate(yGridCnt) + IF (allocated(lat_c )) deallocate(lat_c ) + IF (allocated(lat_s )) deallocate(lat_s ) + IF (allocated(lat_n )) deallocate(lat_n ) + IF (allocated(lon_c )) deallocate(lon_c ) + IF (allocated(lon_w )) deallocate(lon_w ) + IF (allocated(lon_e )) deallocate(lon_e ) + + ! IF (allocated(vindex1 )) deallocate(vindex1 ) + ! IF (allocated(vindex2 )) deallocate(vindex2 ) + + IF (.not. p_is_writeback) THEN + CALL mpi_barrier (p_comm_glb, p_err) + ENDIF + + IF (p_is_master) THEN + dataid = -1 + CALL mpi_send (dataid, 1, MPI_INTEGER, 0, tag_next, p_comm_glb_plus, p_err) + ENDIF + + CALL mpi_barrier (p_comm_glb_plus, p_err) + + END subroutine hist_writeback_exit + + ! ---- + character(len=256) FUNCTION basename (fullname) + + IMPLICIT NONE + character(len=*), intent(in) :: fullname + + ! Local variables + INTEGER :: i, n + + i = len_trim (fullname) + DO while (i > 0) + IF (fullname(i:i) == '/') exit + i = i - 1 + ENDDO + + IF (i > 0) THEN + basename = fullname(i+1:) + ELSE + basename = fullname + ENDIF + + END FUNCTION basename + +end module MOD_HistWriteBack +#endif diff --git a/main/MOD_Irrigation.F90 b/main/MOD_Irrigation.F90 new file mode 100644 index 00000000..969eff74 --- /dev/null +++ b/main/MOD_Irrigation.F90 @@ -0,0 +1,348 @@ +#include +#ifdef CROP +module MOD_Irrigation + +! DESCRIPTION: +! This module has all irrigation related subroutines for irrigated crop at either IGBP/USGS or PFT Land type classification and even in the C and N cycle. + use MOD_Precision + USE MOD_TimeManager + USE MOD_Namelist, only: DEF_simulation_time + ! ,DEF_IRRIGATION_METHOD + use MOD_Const_Physical, only: tfrz + use MOD_Const_PFT, only: irrig_crop + use MOD_Vars_Global, only: irrig_start_time, irrig_max_depth, irrig_threshold_fraction, irrig_min_cphase, irrig_max_cphase, irrig_time_per_day + use MOD_Qsadv, only: qsadv + use MOD_Vars_TimeInvariants, only: & +#ifdef vanGenuchten_Mualem_SOIL_MODEL + theta_r, alpha_vgm, n_vgm, L_vgm, fc_vgm, sc_vgm,& +#endif + porsl, psi0, bsw + use MOD_Vars_TimeVariables, only : tref, t_soisno, wliq_soisno, irrig_rate, deficit_irrig, sum_irrig, sum_irrig_count, n_irrig_steps_left, & + tairday, usday, vsday, pairday, rnetday, fgrndday, potential_evapotranspiration + use MOD_Vars_PFTimeInvariants, only: pftclass + use MOD_Vars_PFTimeVariables, only: irrig_method_p + use MOD_BGC_Vars_PFTimeVariables, only: cphase_p + use MOD_Vars_1DForcing, only: forc_t, forc_frl, forc_psrf, forc_us, forc_vs + use MOD_Vars_1DFluxes, only: sabg, sabvsun, sabvsha, olrg, fgrnd + use MOD_Hydro_SoilFunction, only: soil_vliq_from_psi + + implicit none + + public :: CalIrrigationNeeded + public :: CalIrrigationApplicationFluxes + + ! local variable + integer :: irrig_method_drip = 1 + integer :: irrig_method_sprinkler = 2 + integer :: irrig_method_flood = 3 + integer :: irrig_method_paddy = 4 + +contains + + subroutine CalIrrigationNeeded(i,ps,pe,idate,nl_soil,nbedrock,z_soi,dz_soi,deltim,dlon,npcropmin) + + ! DESCRIPTION: + ! This subroutine is used to calculate how much irrigation needed in each irrigated crop patch + integer , intent(in) :: i + integer , intent(in) :: ps, pe + integer , intent(in) :: idate(3) + integer , intent(in) :: nl_soil + integer , intent(in) :: nbedrock + real(r8), intent(in) :: z_soi(1:nl_soil) + real(r8), intent(in) :: dz_soi(1:nl_soil) + real(r8), intent(in) :: deltim + real(r8), intent(in) :: dlon + integer , intent(in) :: npcropmin + + ! local + integer :: m + integer :: irrig_nsteps_per_day + logical :: check_for_irrig + + ! ! calculate last day potential evapotranspiration + ! call CalPotentialEvapotranspiration(i,idate,dlon,deltim) + + ! calculate whether irrigation needed + call PointNeedsCheckForIrrig(i,ps,pe,idate,deltim,dlon,npcropmin,check_for_irrig) + + ! calculate irrigation needed + if (check_for_irrig) then + call CalIrrigationPotentialNeeded(i,ps,pe,nl_soil,nbedrock,z_soi,dz_soi) + ! call CalIrrigationLimitedNeeded(i,ps,pe) + end if + + ! calculate irrigation rate kg/m2->mm/s + if ((check_for_irrig) .and. (deficit_irrig(i) > 0)) then + irrig_nsteps_per_day = nint(irrig_time_per_day/deltim) + irrig_rate(i) = deficit_irrig(i)/deltim/irrig_nsteps_per_day + n_irrig_steps_left(i) = irrig_nsteps_per_day + sum_irrig(i) = sum_irrig(i) + deficit_irrig(i) + sum_irrig_count(i) = sum_irrig_count(i) + 1._r8 + end if + + ! ! zero irrigation at the end of growing season + ! do m = ps, pe + ! if (cphase_p(m) >= 4._r8) then + ! sum_irrig(i) = 0._r8 + ! sum_irrig_count(i) = 0._r8 + ! end if + ! end do + end subroutine CalIrrigationNeeded + + + subroutine CalIrrigationPotentialNeeded(i,ps,pe,nl_soil,nbedrock,z_soi,dz_soi) + + ! DESCRIPTION: + ! This subroutine is used to calculate how much irrigation needed in each irrigated crop patch without water supply restriction + integer , intent(in) :: i + integer , intent(in) :: ps, pe + integer , intent(in) :: nbedrock + integer , intent(in) :: nl_soil + real(r8), intent(in) :: z_soi(1:nl_soil) + real(r8), intent(in) :: dz_soi(1:nl_soil) + + ! local variables + integer :: j + integer :: m + logical :: reached_max_depth + real(r8) :: h2osoi_liq_tot + real(r8) :: h2osoi_liq_target_tot + real(r8) :: h2osoi_liq_wilting_point_tot + real(r8) :: h2osoi_liq_saturation_capacity_tot + real(r8) :: h2osoi_liq_wilting_point(1:nl_soil) + real(r8) :: h2osoi_liq_field_capacity(1:nl_soil) + real(r8) :: h2osoi_liq_saturation_capacity(1:nl_soil) + real(r8) :: h2osoi_liq_at_threshold + + real(r8) :: smpswc = -1.5e5 + real(r8) :: smpsfc = -3.3e3 + + ! initialize local variables + reached_max_depth = .false. + h2osoi_liq_tot = 0._r8 + h2osoi_liq_target_tot = 0._r8 + h2osoi_liq_wilting_point_tot = 0._r8 + h2osoi_liq_saturation_capacity_tot = 0._r8 + + ! ! single site initialization + ! do m = ps, pe + ! irrig_method_p(m) = DEF_IRRIGATION_METHOD + ! enddo + +! calculate wilting point and field capacity + do j = 1, nl_soil + if (t_soisno(j,i) > tfrz .and. porsl(j,i) >= 1.e-6) then +#ifdef Campbell_SOIL_MODEL + h2osoi_liq_wilting_point(j) = 1000.*dz_soi(j)*porsl(j,i)*((smpswc/psi0(j,i))**(-1/bsw(j,i))) + h2osoi_liq_field_capacity(j) = 1000.*dz_soi(j)*porsl(j,i)*((smpsfc/psi0(j,i))**(-1/bsw(j,i))) + h2osoi_liq_saturation_capacity(j) = 1000.*dz_soi(j)*porsl(j,i) +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + h2osoi_liq_wilting_point(j) = soil_vliq_from_psi(smpswc, porsl(j,i), theta_r(j,i), psi0(j,i), 5, & + (/alpha_vgm(j,i), n_vgm(j,i), L_vgm(j,i), sc_vgm(j,i), fc_vgm(j,i)/)) + h2osoi_liq_wilting_point(j) = 1000.*dz_soi(j)*h2osoi_liq_wilting_point(j) + h2osoi_liq_field_capacity(j) = soil_vliq_from_psi(smpsfc, porsl(j,i), theta_r(j,i), psi0(j,i), 5, & + (/alpha_vgm(j,i), n_vgm(j,i), L_vgm(j,i), sc_vgm(j,i), fc_vgm(j,i)/)) + h2osoi_liq_field_capacity(j) = 1000.*dz_soi(j)*h2osoi_liq_field_capacity(j) + h2osoi_liq_saturation_capacity(j) = 1000.*dz_soi(j)*porsl(j,i) +#endif + end if + end do + + ! calculate total irrigation needed in all soil layers + do m = ps, pe + do j = 1, nl_soil + if (.not. reached_max_depth) then + if (z_soi(j) > irrig_max_depth) then + reached_max_depth = .true. + else if (j > nbedrock) then + reached_max_depth = .true. + else if (t_soisno(j,i) <= tfrz) then + reached_max_depth = .true. + else + h2osoi_liq_tot = h2osoi_liq_tot + wliq_soisno(j,i) + h2osoi_liq_wilting_point_tot = h2osoi_liq_wilting_point_tot + h2osoi_liq_wilting_point(j) + if (irrig_method_p(m) == irrig_method_drip .or. irrig_method_p(m) == irrig_method_sprinkler) then + h2osoi_liq_target_tot = h2osoi_liq_target_tot + h2osoi_liq_field_capacity(j) + ! irrigation threshold at field capacity, but irrigation amount at saturation capacity + else if (irrig_method_p(m) == irrig_method_flood) then + h2osoi_liq_target_tot = h2osoi_liq_target_tot + h2osoi_liq_field_capacity(j) + h2osoi_liq_saturation_capacity_tot = h2osoi_liq_saturation_capacity_tot + h2osoi_liq_saturation_capacity(j) + else if (irrig_method_p(m) == irrig_method_paddy) then + h2osoi_liq_target_tot = h2osoi_liq_target_tot + h2osoi_liq_saturation_capacity(j) + else + h2osoi_liq_target_tot = h2osoi_liq_target_tot + h2osoi_liq_field_capacity(j) + end if + end if + end if + end do + end do + + ! calculate irrigation threshold + deficit_irrig(i) = 0._r8 + h2osoi_liq_at_threshold = h2osoi_liq_wilting_point_tot + irrig_threshold_fraction * (h2osoi_liq_target_tot - h2osoi_liq_wilting_point_tot) + + ! calculate total irrigation + do m = ps, pe + if (h2osoi_liq_tot < h2osoi_liq_at_threshold) then + if (irrig_method_p(m) == irrig_method_sprinkler) then + deficit_irrig(i) = h2osoi_liq_target_tot - h2osoi_liq_tot + ! deficit_irrig(i) = h2osoi_liq_target_tot - h2osoi_liq_tot + potential_evapotranspiration(i) + else if (irrig_method_p(m) == irrig_method_flood) then + deficit_irrig(i) = h2osoi_liq_saturation_capacity_tot - h2osoi_liq_tot + else + deficit_irrig(i) = h2osoi_liq_at_threshold - h2osoi_liq_tot + end if + else + deficit_irrig(i) = 0 + end if + end do + + end subroutine CalIrrigationPotentialNeeded + + subroutine CalIrrigationApplicationFluxes(i,ps,pe,deltim,qflx_irrig_drip,qflx_irrig_sprinkler,qflx_irrig_flood,qflx_irrig_paddy,irrig_flag) + ! DESCRIPTION: + ! This subroutine is used to calculate irrigation application fluxes for each irrigated crop patch + integer , intent(in) :: i + integer , intent(in) :: ps, pe + real(r8), intent(in) :: deltim + integer , intent(in) :: irrig_flag ! 1 if sprinker, 2 if others + real(r8), intent(out):: qflx_irrig_drip,qflx_irrig_sprinkler,qflx_irrig_flood,qflx_irrig_paddy + + integer :: m + + qflx_irrig_drip = 0._r8 + qflx_irrig_sprinkler = 0._r8 + qflx_irrig_flood = 0._r8 + qflx_irrig_paddy = 0._r8 + + ! ! single site initialization + ! do m = ps, pe + ! irrig_method_p(m) = DEF_IRRIGATION_METHOD + ! enddo + + ! add irrigation fluxes to precipitation or land surface + do m = ps, pe + if (n_irrig_steps_left(i) > 0) then + if ((irrig_flag == 1) .and. (irrig_method_p(m) == irrig_method_sprinkler)) then + qflx_irrig_sprinkler = irrig_rate(i) + n_irrig_steps_left(i) = n_irrig_steps_left(i) -1 + deficit_irrig(i) = deficit_irrig(i) - irrig_rate(i)*deltim + else if (irrig_flag == 2) then + if (irrig_method_p(m) == irrig_method_drip) then + qflx_irrig_drip = irrig_rate(i) + else if (irrig_method_p(m) == irrig_method_flood) then + qflx_irrig_flood = irrig_rate(i) + else if (irrig_method_p(m) == irrig_method_paddy) then + qflx_irrig_paddy = irrig_rate(i) + else if ((irrig_method_p(m) /= irrig_method_drip) .and. (irrig_method_p(m) /= irrig_method_sprinkler) & + .and. (irrig_method_p(m) /= irrig_method_flood) .and. (irrig_method_p(m) /= irrig_method_paddy)) then + qflx_irrig_drip = irrig_rate(i) + end if + n_irrig_steps_left(i) = n_irrig_steps_left(i) -1 + deficit_irrig(i) = deficit_irrig(i) - irrig_rate(i)*deltim + end if + if (deficit_irrig(i) < 0._r8) then + deficit_irrig(i) = 0._r8 + end if + else + irrig_rate(i) = 0._r8 + end if + end do + end subroutine CalIrrigationApplicationFluxes + + subroutine PointNeedsCheckForIrrig(i,ps,pe,idate,deltim,dlon,npcropmin,check_for_irrig) + ! DESCRIPTION: + ! This subroutine is used to calculate whether irrigation needed in each patch + integer , intent(in) :: i + integer , intent(in) :: ps, pe + integer , intent(in) :: idate(3) + real(r8), intent(in) :: deltim + real(r8), intent(in) :: dlon + integer , intent(in) :: npcropmin + logical , intent(out):: check_for_irrig + + ! local variable + integer :: m, ivt + real(r8):: ldate(3) + real(r8):: seconds_since_irrig_start_time + + do m = ps, pe + ivt = pftclass(m) + if ((ivt >= npcropmin) .and. (irrig_crop(ivt)) .and. & + (cphase_p(m) >= irrig_min_cphase) .and. (cphase_p(m)= 0._r8) .and. (seconds_since_irrig_start_time < deltim)) then + check_for_irrig = .true. + else + check_for_irrig = .false. + end if + else + check_for_irrig = .false. + end if + end do + + end subroutine PointNeedsCheckForIrrig + + ! subroutine CalPotentialEvapotranspiration(i,idate,dlon,deltim) + ! ! DESCRIPTION: + ! ! This subroutine is used to calculate daily potential evapotranspiration + ! integer , intent(in) :: i + ! integer , intent(in) :: idate(3) + ! real(r8), intent(in) :: dlon + ! real(r8), intent(in) :: deltim + + ! ! local variable + ! real(r8):: ldate(3) + ! real(r8):: seconds_since_irrig_start_time + ! real(r8) :: es,esdT,qs,qsdT ! saturation vapour pressure + ! real(r8) :: evsat ! vapour pressure + ! real(r8) :: ur ! wind speed + ! real(r8) :: delta ! slope of saturation vapour pressure curve + ! real(r8) :: gamma ! Psychrometric constant + + ! if (DEF_simulation_time%greenwich) then + ! call gmt2local(idate, dlon, ldate) + ! seconds_since_irrig_start_time = ldate(3) - irrig_start_time + deltim + ! else + ! seconds_since_irrig_start_time = idate(3) - irrig_start_time + deltim + ! end if + + ! if (((seconds_since_irrig_start_time-deltim) >= 0) .and. ((seconds_since_irrig_start_time-deltim) < deltim)) then + ! tairday(i) = (forc_t(i)-tfrz)*deltim/86400 + ! usday(i) = forc_us(i)*deltim/86400 + ! vsday(i) = forc_vs(i)*deltim/86400 + ! pairday(i) = forc_psrf(i)*deltim/86400/1000 + ! rnetday(i) = (sabg(i)+sabvsun(i)+sabvsha(i)-olrg(i)+forc_frl(i))*deltim/1000000 + ! fgrndday(i) = fgrnd(i)*deltim/1000000 + ! else + ! tairday(i) = tairday(i) + (forc_t(i)-tfrz)*deltim/86400 + ! usday(i) = usday(i) + forc_us(i)*deltim/86400 + ! vsday(i) = vsday(i) + forc_vs(i)*deltim/86400 + ! pairday(i) = pairday(i) + forc_psrf(i)*deltim/86400/1000 + ! rnetday(i) = rnetday(i) + (sabg(i)+sabvsun(i)+sabvsha(i)-olrg(i)+forc_frl(i))*deltim/1000000 + ! fgrndday(i) = fgrndday(i) + fgrnd(i)*deltim/1000000 + ! endif + + ! if ((seconds_since_irrig_start_time >= 0) .and. (seconds_since_irrig_start_time < deltim)) then + ! call qsadv(tairday(i),pairday(i),es,esdT,qs,qsdT) + ! if (tairday(i) > 0)then + ! evsat = 0.611*EXP(17.27*tairday(i)/(tairday(i)+237.3)) + ! else + ! evsat = 0.611*EXP(21.87*tairday(i)/(tairday(i)+265.5)) + ! endif + ! ur = max(0.1,sqrt(usday(i)*usday(i)+vsday(i)*vsday(i))) + ! delta = 4098*evsat/((tairday(i)+237.3)*(tairday(i)+237.3)) + ! gamma = 0.665*0.001*pairday(i) + ! potential_evapotranspiration(i) = (0.408*delta*(rnetday(i)-fgrndday(i))+gamma*(900/(tairday(i)+273))*ur* & + ! (evsat-es))/(delta+(gamma*(1+0.34*ur))) + ! end if + ! end subroutine CalPotentialEvapotranspiration + +end module MOD_Irrigation +#endif diff --git a/main/MOD_LAIReadin.F90 b/main/MOD_LAIReadin.F90 index 78a69965..99126240 100644 --- a/main/MOD_LAIReadin.F90 +++ b/main/MOD_LAIReadin.F90 @@ -36,15 +36,10 @@ SUBROUTINE LAI_readin (year, time, dir_landdata) USE MOD_Vars_Global USE MOD_Const_LC -#ifdef LULC_IGBP_PFT +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) USE MOD_LandPFT USE MOD_Vars_PFTimeVariables #endif -#ifdef LULC_IGBP_PC - USE MOD_LandPC - USE MOD_Vars_PCTimeVariables - USE MOD_Vars_PCTimeInvariants -#endif #ifdef SinglePoint USE MOD_SingleSrfdata #endif @@ -72,22 +67,26 @@ SUBROUTINE LAI_readin (year, time, dir_landdata) landdir = trim(dir_landdata) // '/LAI' #ifdef SinglePoint +#ifndef URBAN_MODEL iyear = findloc(SITE_LAI_year, year, dim=1) IF (.not. DEF_LAI_MONTHLY) THEN itime = (time-1)/8 + 1 ENDIF #endif +#endif #if (defined LULC_USGS || defined LULC_IGBP) -!TODO: need to consider single point for urban model +!TODO-done: need to consider single point for urban model #ifdef SinglePoint +#ifndef URBAN_MODEL IF (DEF_LAI_MONTHLY) THEN tlai(:) = SITE_LAI_monthly(time,iyear) tsai(:) = SITE_SAI_monthly(time,iyear) ELSE tlai(:) = SITE_LAI_8day(itime,iyear) ENDIF +#endif #else IF (DEF_LAI_MONTHLY) THEN write(cyear,'(i4.4)') year @@ -124,9 +123,9 @@ SUBROUTINE LAI_readin (year, time, dir_landdata) IF (fveg0(m) > 0) THEN tlai(npatch) = tlai(npatch)/fveg0(m) !leaf area index IF (DEF_LAI_MONTHLY) THEN - tsai(npatch) = tsai(npatch)/fveg0(m) !stem are index + tsai(npatch) = tsai(npatch)/fveg0(m) !stem are index ELSE - tsai(npatch) = sai0(m) !stem are index + tsai(npatch) = sai0(m) !stem are index ENDIF green(npatch) = 1. !fraction of green leaf ELSE @@ -142,10 +141,11 @@ SUBROUTINE LAI_readin (year, time, dir_landdata) #endif -#ifdef LULC_IGBP_PFT +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) #ifdef SinglePoint - !TODO: how to add time parameter in single point case + !TODO-done@wenzong: need to add for urban model CASE like IGBP/USGS above? +#ifndef URBAN_MODEL IF (.not. DEF_USE_LAIFEEDBACK)THEN IF (DEF_LAI_MONTHLY) THEN tlai_p(:) = pack(SITE_LAI_pfts_monthly(:,time,iyear), SITE_pctpfts > 0.) @@ -159,6 +159,7 @@ SUBROUTINE LAI_readin (year, time, dir_landdata) tsai(:) = sum (SITE_SAI_pfts_monthly(:,time,iyear) * SITE_pctpfts) ENDIF ENDIF +#endif #else write(cyear,'(i4.4)') year @@ -186,59 +187,10 @@ SUBROUTINE LAI_readin (year, time, dir_landdata) #ifdef URBAN_MODEL IF (m == URBAN) CYCLE #endif + !TODO@yuan: may need to revise patch LAI/SAI green(npatch) = 1. - fveg (npatch) = fveg0(m) - - end do - ENDIF - ENDIF - -#endif - -#ifdef LULC_IGBP_PC - -#ifdef SinglePoint - IF (DEF_LAI_MONTHLY) THEN - tlai(:) = sum(SITE_LAI_pfts_monthly(:,time,iyear) * SITE_pctpfts) - tsai(:) = sum(SITE_SAI_pfts_monthly(:,time,iyear) * SITE_pctpfts) - tlai_c(:,1) = SITE_LAI_pfts_monthly(:,time,iyear) - tsai_c(:,1) = SITE_SAI_pfts_monthly(:,time,iyear) - ENDIF -#else - - write(cyear,'(i4.4)') year - write(ctime,'(i2.2)') time - lndname = trim(landdir)//'/'//trim(cyear)//'/LAI_patches'//trim(ctime)//'.nc' - call ncio_read_vector (lndname, 'LAI_patches', landpatch, tlai ) + fveg (npatch) = fveg0(m) - lndname = trim(landdir)//'/'//trim(cyear)//'/SAI_patches'//trim(ctime)//'.nc' - call ncio_read_vector (lndname, 'SAI_patches', landpatch, tsai ) - - lndname = trim(landdir)//'/'//trim(cyear)//'/LAI_pcs'//trim(ctime)//'.nc' - call ncio_read_vector (lndname, 'LAI_pcs', N_PFT, landpc, tlai_c ) - - lndname = trim(landdir)//'/'//trim(cyear)//'/SAI_pcs'//trim(ctime)//'.nc' - call ncio_read_vector (lndname, 'SAI_pcs', N_PFT, landpc, tsai_c ) - -#endif - - if (p_is_worker) then - if (numpatch > 0) then - do npatch = 1, numpatch - m = patchclass(npatch) - -#ifdef URBAN_MODEL - IF (m == URBAN) CYCLE -#endif - IF (patchtypes(landpatch%settyp(npatch)) == 0) THEN - pc = patch2pc(npatch) - - tlai(npatch) = sum(tlai_c(:,pc)*pcfrac(:,pc)) - tsai(npatch) = sum(tsai_c(:,pc)*pcfrac(:,pc)) - ENDIF - - fveg (npatch) = fveg0(m) - green(npatch) = 1. end do ENDIF ENDIF diff --git a/main/MOD_Lake.F90 b/main/MOD_Lake.F90 index f6b6821e..4262e191 100644 --- a/main/MOD_Lake.F90 +++ b/main/MOD_Lake.F90 @@ -261,7 +261,7 @@ end subroutine newsnow_lake subroutine laketem (& ! "in" arguments ! ------------------- - itypwat , maxsnl , nl_soil , nl_lake ,& + patchtype , maxsnl , nl_soil , nl_lake ,& dlat , deltim , forc_hgt_u , forc_hgt_t,& forc_hgt_q , forc_us , forc_vs , forc_t ,& forc_q , forc_rhoair , forc_psrf , forc_sols ,& @@ -277,10 +277,10 @@ subroutine laketem (& ! ------------------- t_grnd , scv , snowdp , t_soisno ,& wliq_soisno , wice_soisno , imelt_soisno , t_lake ,& - lake_icefrac , savedtke1, & + lake_icefrac , savedtke1 , & ! SNICAR model variables - snofrz ,sabg_lyr ,& + snofrz ,sabg_snow_lyr, & ! END SNICAR model variables ! "out" arguments @@ -339,7 +339,7 @@ subroutine laketem (& ! [ts] n = old temperature (kelvin) ! [ts] n+1 = new temperature (kelvin) ! fin = heat flux into lake (w/m**2) -! = beta*sabg_lyr(1)+forc_frl-olrg-fsena-lfevpa-hm + phi(1) + ... + phi(nl_lake) +! = beta*sabg_snow_lyr(1)+forc_frl-olrg-fsena-lfevpa-hm + phi(1) + ... + phi(nl_lake) ! ! REVISIONS: ! Yongjiu Dai and Hua Yuan, 01/2023: added SNICAR for layer solar absorption, ground heat @@ -361,20 +361,20 @@ subroutine laketem (& IMPLICIT NONE ! ------------------------ input/output variables ----------------- - integer, INTENT(in) :: itypwat ! land water type (4=deep lake, 5=shallow lake) - integer, INTENT(in) :: maxsnl ! maximum number of snow layers - integer, INTENT(in) :: nl_soil ! number of soil layers - integer, INTENT(in) :: nl_lake ! number of lake layers - - real(r8), INTENT(in) :: dlat ! latitude (radians) - real(r8), INTENT(in) :: deltim ! seconds in a time step (s) - real(r8), INTENT(in) :: forc_hgt_u ! observational height of wind [m] - real(r8), INTENT(in) :: forc_hgt_t ! observational height of temperature [m] - real(r8), INTENT(in) :: forc_hgt_q ! observational height of humidity [m] - real(r8), INTENT(in) :: forc_us ! wind component in eastward direction [m/s] - real(r8), INTENT(in) :: forc_vs ! wind component in northward direction [m/s] - real(r8), INTENT(in) :: forc_t ! temperature at agcm reference height [kelvin] - real(r8), INTENT(in) :: forc_q ! specific humidity at agcm reference height [kg/kg] + integer, INTENT(in) :: patchtype ! land patch type (4=deep lake, 5=shallow lake) + integer, INTENT(in) :: maxsnl ! maximum number of snow layers + integer, INTENT(in) :: nl_soil ! number of soil layers + integer, INTENT(in) :: nl_lake ! number of lake layers + + real(r8), INTENT(in) :: dlat ! latitude (radians) + real(r8), INTENT(in) :: deltim ! seconds in a time step (s) + real(r8), INTENT(in) :: forc_hgt_u ! observational height of wind [m] + real(r8), INTENT(in) :: forc_hgt_t ! observational height of temperature [m] + real(r8), INTENT(in) :: forc_hgt_q ! observational height of humidity [m] + real(r8), INTENT(in) :: forc_us ! wind component in eastward direction [m/s] + real(r8), INTENT(in) :: forc_vs ! wind component in northward direction [m/s] + real(r8), INTENT(in) :: forc_t ! temperature at agcm reference height [kelvin] + real(r8), INTENT(in) :: forc_q ! specific humidity at agcm reference height [kg/kg] real(r8), INTENT(in) :: forc_rhoair ! density air [kg/m3] real(r8), INTENT(in) :: forc_psrf ! atmosphere pressure at the surface [pa] real(r8), INTENT(in) :: forc_sols ! atm vis direct beam solar rad onto srf [W/m2] @@ -388,8 +388,8 @@ subroutine laketem (& real(r8), INTENT(in) :: z_soisno(maxsnl+1:nl_soil) ! soil/snow node depth [m] real(r8), INTENT(in) :: zi_soisno(maxsnl:nl_soil) ! soil/snow depth of layer interface [m] - real(r8), INTENT(in) :: dz_lake(nl_lake) ! lake layer thickness (m) - real(r8), INTENT(in) :: lakedepth ! column lake depth (m) + real(r8), INTENT(in) :: dz_lake(nl_lake) ! lake layer thickness (m) + real(r8), INTENT(in) :: lakedepth ! column lake depth (m) real(r8), INTENT(in) :: vf_quartz (1:nl_soil) ! volumetric fraction of quartz within mineral soil real(r8), INTENT(in) :: vf_gravels(1:nl_soil) ! volumetric fraction of gravels @@ -397,20 +397,20 @@ subroutine laketem (& real(r8), INTENT(in) :: vf_sand (1:nl_soil) ! volumetric fraction of sand real(r8), INTENT(in) :: wf_gravels(1:nl_soil) ! gravimetric fraction of gravels real(r8), INTENT(in) :: wf_sand (1:nl_soil) ! gravimetric fraction of sand - real(r8), INTENT(in) :: porsl(1:nl_soil) ! soil porosity [-] + real(r8), INTENT(in) :: porsl(1:nl_soil) ! soil porosity [-] - real(r8), INTENT(in) :: csol(1:nl_soil) ! heat capacity of soil solids [J/(m3 K)] - real(r8), INTENT(in) :: k_solids(1:nl_soil) ! thermal conductivity of mineralssoil [W/m-K] - real(r8), INTENT(in) :: dksatu(1:nl_soil) ! thermal conductivity of saturated unfrozen soil [W/m-K] - real(r8), INTENT(in) :: dksatf(1:nl_soil) ! thermal conductivity of saturated frozen soil [W/m-K] - real(r8), INTENT(in) :: dkdry(1:nl_soil) ! thermal conductivity of dry soil [W/m-K] - real(r8), INTENT(in) :: BA_alpha(1:nl_soil) ! alpha in Balland and Arp(2005) thermal conductivity scheme - real(r8), INTENT(in) :: BA_beta(1:nl_soil) ! beta in Balland and Arp(2005) thermal conductivity scheme - real(r8), INTENT(in) :: hpbl ! atmospheric boundary layer height [m] + real(r8), INTENT(in) :: csol(1:nl_soil) ! heat capacity of soil solids [J/(m3 K)] + real(r8), INTENT(in) :: k_solids(1:nl_soil) ! thermal conductivity of mineralssoil [W/m-K] + real(r8), INTENT(in) :: dksatu(1:nl_soil) ! thermal conductivity of saturated unfrozen soil [W/m-K] + real(r8), INTENT(in) :: dksatf(1:nl_soil) ! thermal conductivity of saturated frozen soil [W/m-K] + real(r8), INTENT(in) :: dkdry(1:nl_soil) ! thermal conductivity of dry soil [W/m-K] + real(r8), INTENT(in) :: BA_alpha(1:nl_soil) ! alpha in Balland and Arp(2005) thermal conductivity scheme + real(r8), INTENT(in) :: BA_beta(1:nl_soil) ! beta in Balland and Arp(2005) thermal conductivity scheme + real(r8), INTENT(in) :: hpbl ! atmospheric boundary layer height [m] - real(r8), INTENT(inout) :: t_grnd ! surface temperature (kelvin) - real(r8), INTENT(inout) :: scv ! snow water equivalent [mm] - real(r8), INTENT(inout) :: snowdp ! snow depth [mm] + real(r8), INTENT(inout) :: t_grnd ! surface temperature (kelvin) + real(r8), INTENT(inout) :: scv ! snow water equivalent [mm] + real(r8), INTENT(inout) :: snowdp ! snow depth [mm] real(r8), INTENT(inout) :: t_soisno (maxsnl+1:nl_soil) ! soil/snow temperature [K] real(r8), INTENT(inout) :: wliq_soisno (maxsnl+1:nl_soil) ! soil/snow liquid water (kg/m2) @@ -422,8 +422,8 @@ subroutine laketem (& real(r8), INTENT(inout) :: savedtke1 ! top level eddy conductivity (W/m K) ! SNICAR model variables - REAL(r8), intent(out) :: snofrz (maxsnl+1:0) ! snow freezing rate (col,lyr) [kg m-2 s-1] - REAL(r8), intent(in) :: sabg_lyr (maxsnl+1:1) ! solar radiation absorbed by ground [W/m2] + REAL(r8), intent(out) :: snofrz (maxsnl+1:0) ! snow freezing rate (col,lyr) [kg m-2 s-1] + REAL(r8), intent(in) :: sabg_snow_lyr(maxsnl+1:1) ! solar radiation absorbed by ground [W/m2] ! END SNICAR model variables real(r8), INTENT(out) :: taux ! wind stress: E-W [kg/m/s**2] @@ -915,7 +915,7 @@ subroutine laketem (& ! January 12, 2023 by Yongjiu Dai IF (DEF_USE_SNICAR .and. .not. present(urban_call)) THEN - hs = sabg_lyr(lb) + forc_frl - olrg - fseng - htvp*fevpg + hs = sabg_snow_lyr(lb) + forc_frl - olrg - fseng - htvp*fevpg dhsdT = 0.0 ENDIF @@ -1067,8 +1067,8 @@ subroutine laketem (& ! This looks like it should be robust even for pathological cases, ! like lakes thinner than za(idlak). - phi(j) = (rsfin-rsfout) * sabg_lyr(1) * (1.-betaprime) - if (j == nl_lake) phi_soil = rsfout * sabg_lyr(1) * (1.-betaprime) + phi(j) = (rsfin-rsfout) * sabg_snow_lyr(1) * (1.-betaprime) + if (j == nl_lake) phi_soil = rsfout * sabg_snow_lyr(1) * (1.-betaprime) end do ENDIF @@ -1160,14 +1160,14 @@ subroutine laketem (& a(j) = - (1.-cnfac)*factx(j)* tkix(j-1)/dzm b(j) = 1.+ (1.-cnfac)*factx(j)*(tkix(j)/dzp + tkix(j-1)/dzm) c(j) = - (1.-cnfac)*factx(j)* tkix(j)/dzp - r(j) = tx_bef(j) + cnfac*factx(j)*(fnx(j) - fnx(j-1)) + factx(j)*sabg_lyr(j) + r(j) = tx_bef(j) + cnfac*factx(j)*(fnx(j) - fnx(j-1)) + factx(j)*sabg_snow_lyr(j) else ! snow covered top lake layer dzm = (zx(j)-zx(j-1)) dzp = (zx(j+1)-zx(j)) a(j) = - (1.-cnfac)*factx(j)* tkix(j-1)/dzm b(j) = 1.+ (1.-cnfac)*factx(j)*(tkix(j)/dzp + tkix(j-1)/dzm) c(j) = - (1.-cnfac)*factx(j)* tkix(j)/dzp - r(j) = tx_bef(j) + cnfac*factx(j)*(fnx(j) - fnx(j-1)) + factx(j)*(phix(j) + betaprime*sabg_lyr(j)) + r(j) = tx_bef(j) + cnfac*factx(j)*(fnx(j) - fnx(j-1)) + factx(j)*(phix(j) + betaprime*sabg_snow_lyr(j)) endif enddo else @@ -1542,6 +1542,7 @@ subroutine snowwater_lake ( & ! --------------------------- z_soisno , dz_soisno , zi_soisno , t_soisno ,& wice_soisno , wliq_soisno , t_lake , lake_icefrac ,& + qout_snowb , & fseng , fgrnd , snl , scv ,& snowdp , sm , forc_us , forc_vs ,& ! SNICAR model variables @@ -1607,6 +1608,7 @@ subroutine snowwater_lake ( & real(r8), INTENT(inout) :: wliq_soisno(maxsnl+1:nl_soil) ! liquid water (kg/m2) real(r8), INTENT(inout) :: t_lake (1:nl_lake) ! lake temperature (Kelvin) real(r8), INTENT(inout) :: lake_icefrac(1:nl_lake) ! mass fraction of lake layer that is frozen + real(r8), INTENT(inout) :: qout_snowb ! rate of water out of snow bottom (mm/s) real(r8), INTENT(inout) :: fseng ! total sensible heat flux (W/m**2) [+ to atm] real(r8), INTENT(inout) :: fgrnd ! heat flux into snow / lake (W/m**2) [+ = into soil] @@ -1641,7 +1643,6 @@ subroutine snowwater_lake ( & integer j ! indices integer lb ! lower bound of array - real(r8) qout_snowb ! rate of water out of snow bottom (mm/s) real(r8) xmf ! snow melt heat flux (W/m**2) real(r8) sumsnowice ! sum of snow ice if snow layers found above unfrozen lake [kg/m&2] diff --git a/main/MOD_LeafInterception.F90 b/main/MOD_LeafInterception.F90 index d4540c1e..471369ba 100644 --- a/main/MOD_LeafInterception.F90 +++ b/main/MOD_LeafInterception.F90 @@ -1,7 +1,9 @@ #include MODULE MOD_LeafInterception -!DESCRIPTION -!=========== +! ----------------------------------------------------------------- +! !DESCRIPTION: +! For calculating vegetation canopy preciptation interception. +! ! This MODULE is the coupler for the colm and CaMa-Flood model. !ANCILLARY FUNCTIONS AND SUBROUTINES @@ -13,20 +15,27 @@ MODULE MOD_LeafInterception !* :SUBROUTINE:"LEAF_interception_NOAHMP" : interception and drainage of precipitation schemes modified from Noah-MP !* :SUBROUTINE:"LEAF_interception_MATSIRO" : interception and drainage of precipitation schemes modified from MATSIRO 2021 version !* :SUBROUTINE:"LEAF_interception_VIC" : interception and drainage of precipitation schemes modified from VIC + !* :SUBROUTINE:"LEAF_interception_JULES" : interception and drainage of precipitation schemes modified from JULES !* :SUBROUTINE:"LEAF_interception_pftwrap" : wapper for pft land use classification !* :SUBROUTINE:"LEAF_interception_pcwrap" : wapper for pc land use classification -!REVISION HISTORY +!REVISION HISTORY: !---------------- - ! 2023.06 ? Yuan Hua and Shupeng Zhang @ SYSU + ! 2023.07 Hua Yuan: remove wrapper PC by using PFT leaf interception + ! 2023.06 Shupeng Zhang @ SYSU ! 2023.02.23 Zhongwang Wei @ SYSU ! 2021.12.12 Zhongwang Wei @ SYSU ! 2020.10.21 Zhongwang Wei @ SYSU - !---2014.04 Yongjiu Dai - !---2002.08.31 Yongjiu Dai + ! 2019.06 Hua Yuan: 1) add wrapper for PFT and PC, and 2) remove sigf by using lai+sai + ! 2014.04 Yongjiu Dai + ! 2002.08.31 Yongjiu Dai USE MOD_Precision USE MOD_Const_Physical, only: tfrz, denh2o, denice - USE MOD_Namelist, only : DEF_Interception_scheme + USE MOD_Namelist, only : DEF_Interception_scheme, DEF_USE_IRRIGATION +#ifdef CROP + USE MOD_Irrigation, only: CalIrrigationApplicationFluxes +#endif + IMPLICIT NONE REAL(r8), parameter :: CICE = 2.094E06 !specific heat capacity of ice (j/m3/k) @@ -73,6 +82,11 @@ MODULE MOD_LeafInterception REAL(r8) :: int_rain REAL(r8) :: int_snow + REAL(r8) :: qflx_irrig_drip + REAL(r8) :: qflx_irrig_sprinkler + REAL(r8) :: qflx_irrig_flood + REAL(r8) :: qflx_irrig_paddy + contains SUBROUTINE LEAF_interception_CoLM2014 (deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sai,tair,tleaf,& @@ -118,6 +132,7 @@ SUBROUTINE LEAF_interception_CoLM2014 (deltim,dewmx,forc_us,forc_vs,chil,sigf,la !---------------- !---2023.02.21 Zhongwang Wei @ SYSU : Snow and rain interception !---2021.12.08 Zhongwang Wei @ SYSU + !---2019.06 Hua Yuan: remove sigf and USE lai+sai for judgement. !---2014.04 Yongjiu Dai !---2002.08.31 Yongjiu Dai !======================================================================= @@ -156,12 +171,11 @@ SUBROUTINE LEAF_interception_CoLM2014 (deltim,dewmx,forc_us,forc_vs,chil,sigf,la vegt = lsai satcap = dewmx*vegt - p0 = (prc_rain + prc_snow + prl_rain + prl_snow)*deltim + p0 = (prc_rain + prc_snow + prl_rain + prl_snow + qflx_irrig_sprinkler)*deltim ppc = (prc_rain+prc_snow)*deltim - ppl = (prl_rain+prl_snow)*deltim + ppl = (prl_rain+prl_snow+qflx_irrig_sprinkler)*deltim w = ldew+p0 - ! 06/08/2019, yuan: why excessed rain calculated here IF (tleaf > tfrz) THEN xsc_rain = max(0., ldew-satcap) xsc_snow = 0. @@ -169,7 +183,6 @@ SUBROUTINE LEAF_interception_CoLM2014 (deltim,dewmx,forc_us,forc_vs,chil,sigf,la xsc_rain = 0. xsc_snow = max(0., ldew-satcap) ENDIF - ! 06/08/2019, yuan: ?? ldew = ldew - (xsc_rain + xsc_snow) ap = pcoefs(2,1) @@ -193,7 +206,7 @@ SUBROUTINE LEAF_interception_CoLM2014 (deltim,dewmx,forc_us,forc_vs,chil,sigf,la ! assume alpha_rain = alpha_snow alpha_rain = 0.25 fpi = alpha_rain * ( 1.-exp(-exrain*lsai) ) - tti_rain = (prc_rain+prl_rain)*deltim * ( 1.-fpi ) + tti_rain = (prc_rain+prl_rain+qflx_irrig_sprinkler)*deltim * ( 1.-fpi ) tti_snow = (prc_snow+prl_snow)*deltim * ( 1.-fpi ) xs = 1. @@ -208,7 +221,7 @@ SUBROUTINE LEAF_interception_CoLM2014 (deltim,dewmx,forc_us,forc_vs,chil,sigf,la ! assume no fall down of the intercepted snowfall in a time step ! drainage - tex_rain = (prc_rain+prl_rain)*deltim * fpi * (ap/bp*(1.-exp(-bp*xs))+cp*xs) & + tex_rain = (prc_rain+prl_rain+qflx_irrig_sprinkler)*deltim * fpi * (ap/bp*(1.-exp(-bp*xs))+cp*xs) & - (satcap-ldew) * xs tex_rain = max( tex_rain, 0. ) tex_snow = 0. @@ -240,7 +253,7 @@ SUBROUTINE LEAF_interception_CoLM2014 (deltim,dewmx,forc_us,forc_vs,chil,sigf,la pg_snow = (xsc_snow + thru_snow) / deltim qintr = pinf / deltim - qintr_rain = prc_rain + prl_rain - thru_rain / deltim + qintr_rain = prc_rain + prl_rain + qflx_irrig_sprinkler - thru_rain / deltim qintr_snow = prc_snow + prl_snow - thru_snow / deltim #if(defined CoLMDEBUG) @@ -257,14 +270,14 @@ SUBROUTINE LEAF_interception_CoLM2014 (deltim,dewmx,forc_us,forc_vs,chil,sigf,la !NOTE: this bug should exist in other interception schemes @Zhongwang. IF (ldew > 0.) THEN IF (tleaf > tfrz) THEN - pg_rain = prc_rain + prl_rain + ldew/deltim + pg_rain = prc_rain + prl_rain + qflx_irrig_sprinkler + ldew/deltim pg_snow = prc_snow + prl_snow ELSE - pg_rain = prc_rain + prl_rain + pg_rain = prc_rain + prl_rain + qflx_irrig_sprinkler pg_snow = prc_snow + prl_snow + ldew/deltim ENDIF ELSE - pg_rain = prc_rain + prl_rain + pg_rain = prc_rain + prl_rain + qflx_irrig_sprinkler pg_snow = prc_snow + prl_snow ENDIF @@ -339,9 +352,9 @@ SUBROUTINE LEAF_interception_CoLM202x (deltim,dewmx,forc_us,forc_vs,chil,sigf,la vegt = lsai satcap = dewmx*vegt - p0 = (prc_rain + prc_snow + prl_rain + prl_snow)*deltim + p0 = (prc_rain + prc_snow + prl_rain + prl_snow + qflx_irrig_sprinkler)*deltim ppc = (prc_rain+prc_snow)*deltim - ppl = (prl_rain+prl_snow)*deltim + ppl = (prl_rain+prl_snow+qflx_irrig_sprinkler)*deltim w = ldew+p0 @@ -352,7 +365,6 @@ SUBROUTINE LEAF_interception_CoLM202x (deltim,dewmx,forc_us,forc_vs,chil,sigf,la xsc_rain = 0. xsc_snow = max(0., ldew-satcap) ENDIF - ! 06/08/2019, yuan: ?? ldew = ldew - (xsc_rain + xsc_snow) ap = pcoefs(2,1) @@ -374,7 +386,7 @@ SUBROUTINE LEAF_interception_CoLM202x (deltim,dewmx,forc_us,forc_vs,chil,sigf,la ! set fraction of potential interception to max 0.25 (Lawrence et al. 2007) alpha_rain = 0.25 fpi = alpha_rain * ( 1.-exp(-exrain*lsai) ) - tti_rain = (prc_rain+prl_rain)*deltim * ( 1.-fpi ) + tti_rain = (prc_rain+prl_rain+qflx_irrig_sprinkler)*deltim * ( 1.-fpi ) tti_snow = (prc_snow+prl_snow)*deltim * ( 1.-fpi ) xs = 1. @@ -388,7 +400,7 @@ SUBROUTINE LEAF_interception_CoLM202x (deltim,dewmx,forc_us,forc_vs,chil,sigf,la ENDIF ! assume no fall down of the intercepted snowfall in a time step drainage - tex_rain = (prc_rain+prl_rain)*deltim * fpi * (ap/bp*(1.-exp(-bp*xs))+cp*xs) - (satcap-ldew) * xs + tex_rain = (prc_rain+prl_rain+qflx_irrig_sprinkler)*deltim * fpi * (ap/bp*(1.-exp(-bp*xs))+cp*xs) - (satcap-ldew) * xs ! tex_rain = (prc_rain+prl_rain)*deltim * fpi * (ap/bp*(1.-exp(-bp*xs))+cp*xs) & ! - (satcap-ldew) * xs @@ -422,7 +434,7 @@ SUBROUTINE LEAF_interception_CoLM202x (deltim,dewmx,forc_us,forc_vs,chil,sigf,la pg_snow = (xsc_snow + thru_snow) / deltim qintr = pinf / deltim - qintr_rain = prc_rain + prl_rain - thru_rain / deltim + qintr_rain = prc_rain + prl_rain + qflx_irrig_sprinkler - thru_rain / deltim qintr_snow = prc_snow + prl_snow - thru_snow / deltim @@ -436,14 +448,25 @@ SUBROUTINE LEAF_interception_CoLM202x (deltim,dewmx,forc_us,forc_vs,chil,sigf,la #endif ELSE - ldew = 0. - pg_rain = prc_rain + prl_rain - pg_snow = prc_snow + prl_snow - qintr = 0. + ! 07/15/2023, yuan: #bug found for ldew value reset. + IF (ldew > 0.) THEN + IF (tleaf > tfrz) THEN + pg_rain = prc_rain + prl_rain + qflx_irrig_sprinkler + ldew/deltim + pg_snow = prc_snow + prl_snow + ELSE + pg_rain = prc_rain + prl_rain + qflx_irrig_sprinkler + pg_snow = prc_snow + prl_snow + ldew/deltim + ENDIF + ELSE + pg_rain = prc_rain + prl_rain + qflx_irrig_sprinkler + pg_snow = prc_snow + prl_snow + ENDIF + + ldew = 0. + qintr = 0. qintr_rain = 0. qintr_snow = 0. ENDIF - END SUBROUTINE LEAF_interception_CoLM202x SUBROUTINE LEAF_interception_CLM4 (deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sai,tair,tleaf,& @@ -510,13 +533,12 @@ SUBROUTINE LEAF_interception_CLM4 (deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sa vegt = lsai satcap = dewmx*vegt - p0 = (prc_rain + prc_snow + prl_rain + prl_snow)*deltim + p0 = (prc_rain + prc_snow + prl_rain + prl_snow + qflx_irrig_sprinkler)*deltim ppc = (prc_rain+prc_snow)*deltim - ppl = (prl_rain+prl_snow)*deltim + ppl = (prl_rain+prl_snow+qflx_irrig_sprinkler)*deltim w = ldew+p0 - ! 06/08/2019, yuan: why excessed rain calculated here IF (tleaf > tfrz) THEN xsc_rain = max(0., ldew-satcap) xsc_snow = 0. @@ -524,50 +546,22 @@ SUBROUTINE LEAF_interception_CLM4 (deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sa xsc_rain = 0. xsc_snow = max(0., ldew-satcap) ENDIF - ! 06/08/2019, yuan: ?? - ldew = ldew - (xsc_rain + xsc_snow) - ap = pcoefs(2,1) - cp = pcoefs(2,2) + ldew = ldew - (xsc_rain + xsc_snow) IF (p0 > 1.e-8) THEN - ap = ppc/p0 * pcoefs(1,1) + ppl/p0 * pcoefs(2,1) - cp = ppc/p0 * pcoefs(1,2) + ppl/p0 * pcoefs(2,2) - - !---------------------------------------------------------------------- - ! proportional saturated area (xs) and leaf drainage(tex) - !----------------------------------------------------------------------- - - chiv = chil - IF ( abs(chiv) .le. 0.01 ) chiv = 0.01 - aa1 = 0.5 - 0.633 * chiv - 0.33 * chiv * chiv - bb1 = 0.877 * ( 1. - 2. * aa1 ) - exrain = aa1 + bb1 exrain =0.5 ! coefficient of interception ! set fraction of potential interception to max 0.25 (Lawrence et al. 2007) alpha_rain = 0.25 fpi = alpha_rain * ( 1.-exp(-exrain*lsai) ) - tti_rain = (prc_rain+prl_rain)*deltim * ( 1.-fpi ) + tti_rain = (prc_rain+prl_rain+qflx_irrig_sprinkler)*deltim * ( 1.-fpi ) tti_snow = (prc_snow+prl_snow)*deltim * ( 1.-fpi ) - xs = 1. - IF (p0*fpi>1.e-9) THEN - arg = (satcap-ldew)/(p0*fpi*ap) - cp/ap - IF (arg>1.e-9) THEN - xs = -1./bp * log( arg ) - xs = min( xs, 1. ) - xs = max( xs, 0. ) - ENDIF - ENDIF - ! assume no fall down of the intercepted snowfall in a time step ! drainage - - tex_rain = (prc_rain+prl_rain)*deltim * fpi * (ap/bp*(1.-exp(-bp*xs))+cp*xs) - (satcap-ldew) * xs - ! tex_rain = (prc_rain+prl_rain)*deltim * fpi * (ap/bp*(1.-exp(-bp*xs))+cp*xs) & - ! - (satcap-ldew) * xs - tex_rain = max( tex_rain, 0. ) + tex_rain = (prc_rain+prl_rain)*deltim * fpi + ldew - satcap + tex_rain = max(tex_rain, 0. ) tex_snow = 0. #if(defined CoLMDEBUG) @@ -596,7 +590,7 @@ SUBROUTINE LEAF_interception_CLM4 (deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sa pg_snow = (xsc_snow + thru_snow) / deltim qintr = pinf / deltim - qintr_rain = prc_rain + prl_rain - thru_rain / deltim + qintr_rain = prc_rain + prl_rain + qflx_irrig_sprinkler - thru_rain / deltim qintr_snow = prc_snow + prl_snow - thru_snow / deltim @@ -610,11 +604,22 @@ SUBROUTINE LEAF_interception_CLM4 (deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sa #endif ELSE + ! 07/15/2023, yuan: #bug found for ldew value reset. + IF (ldew > 0.) THEN + IF (tleaf > tfrz) THEN + pg_rain = prc_rain + prl_rain + qflx_irrig_sprinkler + ldew/deltim + pg_snow = prc_snow + prl_snow + ELSE + pg_rain = prc_rain + prl_rain + qflx_irrig_sprinkler + pg_snow = prc_snow + prl_snow + ldew/deltim + ENDIF + ELSE + pg_rain = prc_rain + prl_rain + qflx_irrig_sprinkler + pg_snow = prc_snow + prl_snow + ENDIF - ldew = 0. - pg_rain = prc_rain + prl_rain - pg_snow = prc_snow + prl_snow - qintr = 0. + ldew = 0. + qintr = 0. qintr_rain = 0. qintr_snow = 0. ENDIF @@ -691,38 +696,44 @@ SUBROUTINE LEAF_interception_CLM5 (deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sa IF (lai+sai > 1e-6) THEN lsai = lai + sai vegt = lsai - p0 = (prc_rain + prc_snow + prl_rain + prl_snow)*deltim + p0 = (prc_rain + prc_snow + prl_rain + prl_snow + qflx_irrig_sprinkler)*deltim ppc = (prc_rain+prc_snow)*deltim - ppl = (prl_rain+prl_snow)*deltim + ppl = (prl_rain+prl_snow+qflx_irrig_sprinkler)*deltim w = ldew+p0 satcap_rain = dewmx*vegt satcap_snow = satcap_rain*60.0 xsc_rain = max(0., ldew_rain-satcap_rain) xsc_snow = max(0., ldew_snow-satcap_snow) - !xsc_snow = min(ldew_snow, xsc_snow) - !ldew_rain = ldew_rain - xsc_rain - !ldew_snow = ldew_snow - xsc_snow - !ldew = ldew_rain+ldew_snow - !xsc_rain=0.0 + + ldew_rain = ldew_rain-xsc_rain + ldew_snow = ldew_snow-xsc_snow !unload due to wind and temperature - U10= sqrt(forc_us*forc_us+forc_vs*forc_vs)*log(10.0/z0m)/log(hu/z0m) - unl_snow_temp = ldew_snow*(tleaf-270.0)/(1.87*1.e5) - unl_snow_temp =max(unl_snow_temp,0.0) - unl_snow_wind = U10*ldew_snow/(1.56*1.e5) - unl_snow = min(unl_snow_temp+unl_snow_wind,ldew_snow) + !U10= sqrt(forc_us*forc_us+forc_vs*forc_vs)*log(10.0/z0m)/log(hu/z0m) + IF(ldew_snow > 1.e-8) THEN + U10 = sqrt(forc_us*forc_us+forc_vs*forc_vs) + unl_snow_temp = ldew_snow*(tleaf-270.0)/(1.87*1.e5) + unl_snow_temp = max(unl_snow_temp,0.0) + unl_snow_wind = U10*ldew_snow/(1.56*1.e5) + unl_snow_temp = max(unl_snow_wind,0.0) + unl_snow = unl_snow_temp+unl_snow_wind + unl_snow = min(unl_snow,ldew_snow) + + xsc_snow = xsc_snow+unl_snow + ldew_snow = ldew_snow - unl_snow + ENDIF - xsc_snow=min(xsc_snow+xsc_snow,ldew_snow) + ldew = ldew - (xsc_rain + xsc_snow) IF(p0 > 1.e-8) THEN alpha_rain = 1.0 alpha_snow = 1.0 fpi_rain = alpha_rain * tanh(lsai) fpi_snow = alpha_snow * ( 1.-exp(-0.5*lsai) ) - tti_rain = (prc_rain+prl_rain)*deltim * ( 1.-fpi_rain ) + tti_rain = (prc_rain+prl_rain+qflx_irrig_sprinkler)*deltim * ( 1.-fpi_rain ) tti_snow = (prc_snow+prl_snow)*deltim * ( 1.-fpi_snow ) - tex_rain = (prc_rain+prl_rain)*deltim * fpi_rain -satcap_rain !*(prc_rain+prl_rain)/p0 !(satcap-ldew) * xs + tex_rain = (prc_rain+prl_rain+qflx_irrig_sprinkler)*deltim * fpi_rain -satcap_rain !*(prc_rain+prl_rain)/p0 !(satcap-ldew) * xs tex_snow = (prc_snow+prl_snow)*deltim * fpi_snow -satcap_snow ! (ap/bp*(1.-exp(-bp*xs))+cp*xs) - (satcap-ldew) * xs tex_rain = max( tex_rain, 0. ) tex_snow = max( tex_snow, 0. ) @@ -747,16 +758,15 @@ SUBROUTINE LEAF_interception_CLM5 (deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sa thru_rain = tti_rain + tex_rain thru_snow = tti_snow + tex_snow pinf = p0 - (thru_rain + thru_snow) - ldew_rain = ldew_rain+ (prc_rain + prl_rain)*deltim - thru_rain -xsc_rain - ldew_snow = ldew_snow+ (prc_snow + prl_snow)*deltim - thru_snow-xsc_snow - ldew_snow = max(0.0,ldew_snow) - ldew_rain = max(0.0,ldew_rain) + ldew_rain = ldew_rain+ (prc_rain + prl_rain + qflx_irrig_sprinkler)*deltim - thru_rain + ldew_snow = ldew_snow+ (prc_snow + prl_snow)*deltim - thru_snow + ldew = ldew_rain+ldew_snow !+ pinf pg_rain = (xsc_rain + thru_rain) / deltim pg_snow = (xsc_snow + thru_snow) / deltim qintr = pinf / deltim - qintr_rain = prc_rain + prl_rain - thru_rain / deltim + qintr_rain = prc_rain + prl_rain + qflx_irrig_sprinkler - thru_rain / deltim qintr_snow = prc_snow + prl_snow - thru_snow / deltim #if(defined CoLMDEBUG) @@ -769,12 +779,23 @@ SUBROUTINE LEAF_interception_CLM5 (deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sa #endif ELSE - ldew = 0. - ldew_rain = 0. - ldew_snow = 0. - pg_rain = prc_rain + prl_rain - pg_snow = prc_snow + prl_snow - qintr = 0. + ! 07/15/2023, yuan: #bug found for ldew value reset. + !NOTE: this bug should exist in other interception schemes @Zhongwang. + IF (ldew > 0.) THEN + IF (tleaf > tfrz) THEN + pg_rain = prc_rain + prl_rain + qflx_irrig_sprinkler + ldew/deltim + pg_snow = prc_snow + prl_snow + ELSE + pg_rain = prc_rain + prl_rain + qflx_irrig_sprinkler + pg_snow = prc_snow + prl_snow + ldew/deltim + ENDIF + ELSE + pg_rain = prc_rain + prl_rain + qflx_irrig_sprinkler + pg_snow = prc_snow + prl_snow + ENDIF + + ldew = 0. + qintr = 0. qintr_rain = 0. qintr_snow = 0. ENDIF @@ -843,60 +864,76 @@ SUBROUTINE LEAF_interception_NOAHMP(deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,s REAL(r8), INTENT(out) :: qintr !interception [kg/(m2 s)] REAL(r8), INTENT(out) :: qintr_rain ! rainfall interception (mm h2o/s) REAL(r8), INTENT(out) :: qintr_snow ! snowfall interception (mm h2o/s) - + REAL(r8) :: BDFALL IF (lai+sai > 1e-6) THEN lsai = lai + sai vegt = lsai satcap_rain = dewmx*vegt - satcap_snow = satcap_rain*60.0 + BDFALL = 67.92+51.25*EXP(MIN(2.5,(tleaf-273.15))/2.59) + satcap_snow = 6.6*(0.27+46./BDFALL) * lsai + satcap_snow = max(0.0,satcap_snow) fvegc=max(0.05,1.0-exp(-0.52*lsai)) + p0 = (prc_rain + prc_snow + prl_rain + prl_snow+qflx_irrig_sprinkler)*deltim + ppc = (prc_rain+prc_snow)*deltim + ppl = (prl_rain+prl_snow+qflx_irrig_sprinkler)*deltim + + w = ldew+p0 + + xsc_rain = max(0., ldew_rain-satcap_rain) + xsc_snow = max(0., ldew_snow-satcap_snow) + + ldew_rain = ldew_rain-xsc_rain + ldew_snow = ldew_snow-xsc_snow + !snow unloading IF (ldew_snow>1.e-8) THEN FT = MAX(0.0,(tair - 270.15) / 1.87E5) FV = SQRT(forc_us*forc_us + forc_vs*forc_vs) / 1.56E5 ICEDRIP = MAX(0.,ldew_snow) * (FV+FT) !MB: removed /DT - ELSE - ICEDRIP = 0. + ICEDRIP = MIN(ICEDRIP,ldew_snow) + xsc_snow = xsc_snow+ICEDRIP + ldew_snow = ldew_snow - ICEDRIP ENDIF ! phase change and excess ! IF (tleaf > tfrz) THEN - ldew_smelt = MIN(ldew_snow,(tleaf-tfrz)*CICE*ldew_snow/DENICE/(HFUS)) - ldew_smelt = max(ldew_smelt,0.0) - ldew_snow = ldew_snow-ldew_smelt - ldew_rain = ldew_rain+ldew_smelt - xsc_rain = max(0., ldew_rain-satcap_rain) - xsc_snow = ICEDRIP+max(0., ldew_snow-satcap_snow) + IF (ldew_snow>1.e-8) THEN + ldew_smelt = MIN(ldew_snow,(tleaf-tfrz)*CICE*ldew_snow/DENICE/(HFUS)) + ldew_smelt = MAX(ldew_smelt,0.0) + ldew_snow = ldew_snow-ldew_smelt + ldew_rain = ldew_rain+ldew_smelt + xsc_rain = xsc_rain + MAX(0., ldew_rain-satcap_rain) + ldew_rain = ldew_rain - MAX(0., ldew_rain-satcap_rain) + ENDIF ! tleaf = fvegc*tfrz+ (1.0-fwet)*tleaf ELSE - ldew_frzc = MIN(ldew_rain,(tfrz-tleaf)*CWAT*ldew_rain/DENH2O/(HFUS)) - ldew_frzc = max(ldew_smelt,0.0) - ldew_snow = ldew_snow+ldew_frzc - ldew_rain = ldew_rain-ldew_frzc - xsc_rain = max(0., ldew_rain-satcap_rain) - xsc_snow = ICEDRIP+max(0., ldew_snow-satcap_snow) + IF (ldew_rain>1.e-8) THEN + ldew_frzc = MIN(ldew_rain,(tfrz-tleaf)*CWAT*ldew_rain/DENH2O/(HFUS)) + ldew_frzc = MAX(ldew_frzc,0.0) + ldew_snow = ldew_snow+ldew_frzc + ldew_rain = ldew_rain-ldew_frzc + xsc_snow = xsc_snow + MAX(0., ldew_snow-satcap_snow) + ldew_snow = ldew_snow - MAX(0., ldew_snow-satcap_snow) + ENDIF !tleaf = fvegc*tfrz+ (1.0-fwet)*tleaf ENDIF + ldew = ldew - (xsc_rain + xsc_snow) IF (p0 > 1.e-8) THEN - p0 = (prc_rain + prc_snow + prl_rain + prl_snow)*deltim - ppc = (prc_rain+prc_snow)*deltim - ppl = (prl_rain+prl_snow)*deltim - w = ldew+p0 - - tti_rain = (prc_rain+prl_rain)*deltim * ( 1.-fvegc ) + tti_rain = (prc_rain+prl_rain+qflx_irrig_sprinkler)*deltim * ( 1.-fvegc ) tti_snow = (prc_snow+prl_snow)*deltim * ( 1.-fvegc ) FP=p0/(10.*ppc+ppl) - int_rain=min(fvegc*FP,(satcap_rain-ldew_rain)/((prc_rain+prl_rain)*deltim)*(1.0-exp(-(prc_rain+prl_rain)*deltim/satcap_rain))) - int_snow=min(fvegc*FP,(satcap_snow-ldew_snow)/((prc_snow+prl_snow)*deltim)*(1.0-exp(-(prc_snow+prl_snow)*deltim/satcap_snow))) - int_rain=max(0.,int_rain) - int_snow=max(0.,int_snow) - tex_rain = (prc_rain+prl_rain)*deltim * ( 1. - int_rain ) - tex_snow = (prc_snow+prl_snow)*deltim * ( 1. - int_snow ) + int_rain=min(fvegc*FP*(prc_rain+prl_rain+qflx_irrig_sprinkler),(satcap_rain-ldew_rain)/deltim*(1.0-exp(-(prc_rain+prl_rain+qflx_irrig_sprinkler)*deltim/satcap_rain))) + int_snow=min(fvegc*FP*(prc_snow + prl_snow),(satcap_snow-ldew_snow)/deltim*(1.0-exp(-(prc_snow+prl_snow)*deltim/satcap_snow))) + int_rain=max(0.,int_rain)*deltim + int_snow=max(0.,int_snow)*deltim + + tex_rain = (prc_rain+prl_rain+qflx_irrig_sprinkler)*fvegc*deltim - int_rain + tex_snow = (prc_snow+prl_snow)*fvegc*deltim - int_snow #if(defined CoLMDEBUG) IF (tex_rain+tex_snow+tti_rain+tti_snow-p0 > 1.e-10) THEN write(6,*) 'tex_ + tti_ > p0 in interception code : ' @@ -926,7 +963,7 @@ SUBROUTINE LEAF_interception_NOAHMP(deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,s qintr = pinf / deltim - qintr_rain = prc_rain + prl_rain - thru_rain / deltim + qintr_rain = prc_rain + prl_rain + qflx_irrig_sprinkler - thru_rain / deltim qintr_snow = prc_snow + prl_snow - thru_snow / deltim @@ -940,12 +977,26 @@ SUBROUTINE LEAF_interception_NOAHMP(deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,s #endif ELSE - ldew = 0. - pg_rain = prc_rain + prl_rain - pg_snow = prc_snow + prl_snow - qintr = 0. + ! 07/15/2023, yuan: #bug found for ldew value reset. + !NOTE: this bug should exist in other interception schemes @Zhongwang. + IF (ldew > 0.) THEN + IF (tleaf > tfrz) THEN + pg_rain = prc_rain + prl_rain + qflx_irrig_sprinkler + ldew/deltim + pg_snow = prc_snow + prl_snow + ELSE + pg_rain = prc_rain + prl_rain + qflx_irrig_sprinkler + pg_snow = prc_snow + prl_snow + ldew/deltim + ENDIF + ELSE + pg_rain = prc_rain + prl_rain + qflx_irrig_sprinkler + pg_snow = prc_snow + prl_snow + ENDIF + + ldew = 0. + qintr = 0. qintr_rain = 0. qintr_snow = 0. + ENDIF END SUBROUTINE LEAF_interception_NOAHMP @@ -1003,8 +1054,8 @@ SUBROUTINE LEAF_interception_MATSIRO (deltim,dewmx,forc_us,forc_vs,chil,sigf,lai REAL(r8), INTENT(inout) :: ldew !depth of water on foliage [mm] REAL(r8), INTENT(inout) :: ldew_rain !depth of liquid on foliage [mm] REAL(r8), INTENT(inout) :: ldew_snow !depth of liquid on foliage [mm] - REAL(r8), INTENT(in) :: z0m !roughness length - REAL(r8), INTENT(in) :: hu !forcing height of U + REAL(r8), INTENT(in) :: z0m !roughness length + REAL(r8), INTENT(in) :: hu !forcing height of U REAL(r8), INTENT(out) :: pg_rain !rainfall onto ground including canopy runoff [kg/(m2 s)] @@ -1012,48 +1063,121 @@ SUBROUTINE LEAF_interception_MATSIRO (deltim,dewmx,forc_us,forc_vs,chil,sigf,lai REAL(r8), INTENT(out) :: qintr !interception [kg/(m2 s)] REAL(r8), INTENT(out) :: qintr_rain ! rainfall interception (mm h2o/s) REAL(r8), INTENT(out) :: qintr_snow ! snowfall interception (mm h2o/s) + !local + REAL(r8) :: fint, Ac, dewmx_MATSIRO,ldew_rain_s, ldew_snow_s,ldew_rain_n, ldew_snow_n + REAL(r8) :: tex_rain_n,tex_rain_s,tex_snow_n,tex_snow_s,tti_rain_n,tti_rain_s,tti_snow_n,tti_snow_s + + !the canopy water capacity per leaf area index is set to 0.2mm + dewmx_MATSIRO = 0.2 + !the fracrtion of the convective precipitation area is assumed to be uniform (0.1) + Ac = 0.1 IF (lai+sai > 1e-6) THEN lsai = lai + sai vegt = lsai - satcap_rain = 0.2*vegt - satcap_snow = 0.2*vegt + p0 = (prc_rain + prc_snow + prl_rain + prl_snow + qflx_irrig_sprinkler)*deltim + ppc = (prc_rain+prc_snow)*deltim + ppl = (prl_rain+prl_snow + qflx_irrig_sprinkler)*deltim - !fvegc=max(0.05,1.0-exp(-0.52*lsai)) + satcap_rain = dewmx_MATSIRO*vegt + satcap_snow = dewmx_MATSIRO*vegt + + w = ldew+p0 + xsc_rain = max(0., ldew_rain-satcap_rain) + xsc_snow = max(0., ldew_snow-satcap_snow) + + ldew_rain = ldew_rain-xsc_rain + ldew_snow = ldew_snow-xsc_snow ! phase change and excess ! IF (tleaf > tfrz) THEN - ldew_smelt = MIN(ldew_snow,(tleaf-tfrz)*CICE*ldew_snow/DENICE/(HFUS)) - ldew_smelt = max(ldew_smelt,0.0) - ldew_snow = ldew_snow-ldew_smelt - ldew_rain = ldew_rain+ldew_smelt - xsc_rain = max(0., ldew_rain-satcap_rain) - xsc_snow = max(0., ldew_snow-satcap_snow) + IF (ldew_snow>1.e-8) THEN + ldew_smelt = MIN(ldew_snow,(tleaf-tfrz)*CICE*ldew_snow/DENICE/(HFUS)) + ldew_smelt = MAX(ldew_smelt,0.0) + ldew_snow = ldew_snow-ldew_smelt + ldew_rain = ldew_rain+ldew_smelt + xsc_rain = xsc_rain + MAX(0., ldew_rain-satcap_rain) + ldew_rain = ldew_rain - MAX(0., ldew_rain-satcap_rain) + ENDIF + ! tleaf = fvegc*tfrz+ (1.0-fwet)*tleaf ELSE - ldew_frzc = MIN(ldew_rain,(tfrz-tleaf)*CWAT*ldew_rain/DENH2O/(HFUS)) - ldew_frzc = max(ldew_smelt,0.0) - ldew_snow = ldew_snow+ldew_frzc - ldew_rain = ldew_rain-ldew_frzc - xsc_rain = max(0., ldew_rain-satcap_rain) - xsc_snow = max(0., ldew_snow-satcap_snow) + IF (ldew_rain>1.e-8) THEN + ldew_frzc = MIN(ldew_rain,(tfrz-tleaf)*CWAT*ldew_rain/DENH2O/(HFUS)) + ldew_frzc = MAX(ldew_frzc,0.0) + ldew_snow = ldew_snow+ldew_frzc + ldew_rain = ldew_rain-ldew_frzc + xsc_snow = xsc_snow + MAX(0., ldew_snow-satcap_snow) + ldew_snow = ldew_snow - MAX(0., ldew_snow-satcap_snow) + ENDIF + !tleaf = fvegc*tfrz+ (1.0-fwet)*tleaf ENDIF + ldew = ldew - (xsc_rain + xsc_snow) IF (p0 > 1.e-8) THEN - p0 = (prc_rain + prc_snow + prl_rain + prl_snow)*deltim - ppc = (prc_rain+prc_snow)*deltim - ppl = (prl_rain+prl_snow)*deltim + ! interception efficiency + fpi_rain = min(1.0,lai+sai) + fpi_snow = min(1.0,lai+sai) + + !----------------------------------------------------------------------- + ! Storm area + !----------------------------------------------------------------------- + ldew_rain_s = ldew_rain + ((prl_rain+qflx_irrig_sprinkler) * fpi_rain + prc_rain * fpi_rain / Ac) * deltim + ldew_snow_s = ldew_snow + (prl_snow * fpi_snow + prc_snow * fpi_snow / Ac) * deltim + ! + tti_rain_s = (prl_rain+qflx_irrig_sprinkler + prc_rain/Ac) * (1.d0-fpi_rain) * deltim + tti_snow_s = (prl_snow + prc_snow/Ac) * (1.d0-fpi_snow) * deltim + + tex_rain_s = max(ldew_rain_s - satcap_rain, 0.d0) + (1.14d-11)*1000.*deltim*exp(min(ldew_rain_s,satcap_rain)/1000.* 3.7d3 ) !cwb_adrp1 = 1.14d-11 ! dripping coefficient, [m/sec] rutter et.al.(1975) + tex_rain_s = min(tex_rain_s, ldew_rain_s) + ldew_rain_s = ldew_rain_s - tex_rain_s + + ! + tex_snow_s = max(ldew_snow_s - satcap_snow, 0.d0) + (1.14d-11)*1000.*deltim*exp(min(ldew_snow_s,satcap_snow)/1000.0* 3.7d3 ) !cwb_adrp2 = 3.7d3 ! dripping coefficient, [/m] rutter et.al.(1975) + tex_snow_s = min(tex_snow_s, ldew_snow_s) + ldew_snow_s = ldew_snow_s - tex_snow_s + + + + !------------------------------------------------------------------------- + ! Non-storm area + !------------------------------------------------------------------------- + ldew_rain_n = ldew_rain + (prl_rain+qflx_irrig_sprinkler) * fpi_rain * deltim + ldew_snow_n = ldew_snow + prl_snow * fpi_snow * deltim + + ! + tti_rain_n = (prl_rain+qflx_irrig_sprinkler) * (1.d0-fpi_rain) * deltim + tti_snow_n = (prl_snow) * (1.d0-fpi_snow) * deltim + - w = ldew+p0 - fpi_rain = max(min(lsai, 1.0),0.0) - fpi_snow = max(min(lsai, 1.0),0.0) + tex_rain_n = max(ldew_rain_n - satcap_rain, 0.d0) + (1.14d-11)*1000.*deltim*exp(min(ldew_rain_n,satcap_rain)/1000.* 3.7d3) + tex_rain_n = min(tex_rain_n, ldew_rain_n) + ldew_rain_n = ldew_rain_n - tex_rain_n - tti_rain = fpi_rain * (prc_rain/0.1+prl_rain)*deltim + fpi_rain * (prl_rain)*deltim - tti_snow = fpi_snow * (prc_snow/0.1+prl_snow)*deltim + fpi_snow * (prl_rain)*deltim - tti_rain = min(tti_rain,(prc_rain+prl_rain)*deltim) - tti_snow = min(tti_snow,(prc_snow+prl_snow)*deltim) + ! + tex_snow_n = max(ldew_snow_n - satcap_snow, 0.d0) + (1.14d-11)*1000.*deltim*exp(min(ldew_snow_n,satcap_snow)/1000.* 3.7d3 ) + tex_snow_n = min(tex_snow_n, ldew_snow_n) + ldew_snow_n = ldew_snow_n - tex_snow_n + !------------------------------------------------------------------------- - tex_rain=max(ldew_rain+(prc_rain+prl_rain)*deltim-tti_rain-satcap_rain,0.0) + (1.14d-11)*exp(3.7d3*(min(ldew_rain+(prc_rain+prl_rain)*deltim-tti_rain,satcap_rain)/deltim))*deltim - tex_snow=max(ldew_snow+(prc_snow+prl_snow)*deltim-tti_snow-satcap_snow,0.0) + (1.14d-11)*exp(3.7d3*(min(ldew_snow+(prc_snow+prl_snow)*deltim-tti_snow,satcap_snow)/deltim))*deltim + + !------------------------------------------------------------------------- + ! Average + !------------------------------------------------------------------------- + ldew_rain = ldew_rain_n + (ldew_rain_s - ldew_rain_n) * Ac + ldew_snow = ldew_snow_n + (ldew_snow_s - ldew_snow_n) * Ac + ldew_rain = max(0.0,ldew_rain) + ldew_snow = max(0.0,ldew_snow) + + tti_rain = tti_rain_n*(1-Ac)+tti_rain_s*Ac + tti_snow = tti_snow_n+(tti_snow_s-tti_snow_n) * Ac + tti_rain = max(0.0,tti_rain) + tti_snow = max(0.0,tti_snow) + + tex_rain = tex_rain_n+(tex_rain_s-tex_rain_n)*Ac + tex_snow = tex_snow_n+(tex_snow_s-tex_snow_n)*Ac + tex_rain = max(0.0,tex_rain) + tex_snow = max(0.0,tex_snow) + !------------------------------------------------------------------------- #if(defined CoLMDEBUG) @@ -1080,14 +1204,14 @@ SUBROUTINE LEAF_interception_MATSIRO (deltim,dewmx,forc_us,forc_vs,chil,sigf,lai thru_snow = tti_snow + tex_snow pinf = p0 - (thru_rain + thru_snow) ldew = ldew + pinf - ldew_rain= ldew_rain+(prc_rain+prl_rain)*deltim- thru_rain + ldew_rain= ldew_rain+(prc_rain+prl_rain+qflx_irrig_sprinkler)*deltim- thru_rain ldew_snow= ldew_snow+(prc_snow+prl_snow)*deltim- thru_snow pg_rain = (xsc_rain + thru_rain) / deltim pg_snow = (xsc_snow + thru_snow) / deltim qintr = pinf / deltim - qintr_rain = prc_rain + prl_rain - thru_rain / deltim + qintr_rain = prc_rain + prl_rain + qflx_irrig_sprinkler - thru_rain / deltim qintr_snow = prc_snow + prl_snow - thru_snow / deltim #if(defined CoLMDEBUG) w = w - ldew - (pg_rain+pg_snow)*deltim @@ -1099,12 +1223,23 @@ SUBROUTINE LEAF_interception_MATSIRO (deltim,dewmx,forc_us,forc_vs,chil,sigf,lai #endif ELSE - ldew = 0. - ldew_rain = 0. - ldew_snow = 0. - pg_rain = prc_rain + prl_rain - pg_snow = prc_snow + prl_snow - qintr = 0. + ! 07/15/2023, yuan: #bug found for ldew value reset. + !NOTE: this bug should exist in other interception schemes @Zhongwang. + IF (ldew > 0.) THEN + IF (tleaf > tfrz) THEN + pg_rain = prc_rain + prl_rain + qflx_irrig_sprinkler + ldew/deltim + pg_snow = prc_snow + prl_snow + ELSE + pg_rain = prc_rain + prl_rain + qflx_irrig_sprinkler + pg_snow = prc_snow + prl_snow + ldew/deltim + ENDIF + ELSE + pg_rain = prc_rain + prl_rain + qflx_irrig_sprinkler + pg_snow = prc_snow + prl_snow + ENDIF + + ldew = 0. + qintr = 0. qintr_rain = 0. qintr_snow = 0. ENDIF @@ -1182,12 +1317,9 @@ SUBROUTINE LEAF_interception_VIC (deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sai IF (lai+sai > 1e-6) THEN lsai = lai + sai vegt = lsai - !satcap_rain = dewmx*vegt - !satcap_snow = satcap_rain*60.0 - fvegc=max(0.05,1.0-exp(-0.52*lsai)) !the maximum bearing capacity of the tree regardless of air temp (Imax1) Imax1=4.0*lsai*0.0005 *1000.0 ! in mm - + MaxInt=0.1*lsai if (tair>-272.15) THEN Lr=4.0 ELSE IF (tair<=-272.15 .and. tair>=-270.15) THEN @@ -1196,147 +1328,354 @@ SUBROUTINE LEAF_interception_VIC (deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sai Lr=1.0 endif - ldew_max_snow=0.0005 *Lr *lsai * 1000.0 ! in mm !!! - Snow=(prc_snow+prl_snow)*deltim - if (ldew_max_snow>0.0) THEN - DeltaSnowInt=(1.0-ldew_snow/ldew_max_snow)*Snow - if ((DeltaSnowInt+ldew_snow)>ldew_max_snow) THEN - DeltaSnowInt=ldew_max_snow-ldew_snow - endif - if (DeltaSnowInt<0.0) THEN - DeltaSnowInt=0.0 - endif - else - DeltaSnowInt=0.0 - endif + satcap_snow=0.0005 *Lr *lsai * 1000.0 ! in mm !!! + !/* Calculate amount of snow intercepted on branches and stored in intercepted snow. */ + satcap_rain= 0.035 * (ldew_snow) + MaxInt ! - !* Reduce the amount of intercepted snow if windy and cold. - !Ringyo Shikenjo Tokyo, #54, 1952. - !Bulletin of the Govt. Forest Exp. Station, - !Govt. Forest Exp. Station, Meguro, Tokyo, Japan. - !FORSTX 634.9072 R475r #54. - !Page 146, Figure 10. - - !Reduce the amount of intercepted snow if snowing, windy, and - !cold (< -3 to -5 C). - !Schmidt and Troendle 1992 western snow conference paper. */ - Wind= SQRT(forc_us*forc_us + forc_vs*forc_vs) - if (tleaf<-3.0 .and. DeltaSnowInt>0.0 .and. Wind> 1.0) THEN - BlownSnow=(0.2*Wind -0.2)*DeltaSnowInt - if (BlownSnow>=DeltaSnowInt) THEN - BlownSnow = DeltaSnowInt - endif - DeltaSnowInt=DeltaSnowInt-BlownSnow - endif + p0 = (prc_rain + prc_snow + prl_rain + prl_snow+ qflx_irrig_sprinkler)*deltim + ppc = (prc_rain+prc_snow)*deltim + ppl = (prl_rain+prl_snow+ qflx_irrig_sprinkler)*deltim + w = ldew+p0 - ! now update snowfall and total accumulated intercepted snow amounts */ - if ((DeltaSnowInt+ldew_snow)>Imax1) THEN - DeltaSnowInt = 0.0 - endif + xsc_rain = max(0., ldew_rain-satcap_rain) + xsc_snow = max(0., ldew_snow-satcap_snow) - !/* pixel depth */ - SnowThroughFall = (Snow - DeltaSnowInt) * fvegc + Snow * (1 - fvegc); + ldew_rain = ldew_rain-xsc_rain + ldew_snow = ldew_snow-xsc_snow + ! phase change and excess ! + IF (tleaf > tfrz) THEN + IF (ldew_snow>1.e-8) THEN + ldew_smelt = MIN(ldew_snow,(tleaf-tfrz)*CICE*ldew_snow/DENICE/(HFUS)) + ldew_smelt = MAX(ldew_smelt,0.0) + ldew_snow = ldew_snow-ldew_smelt + ldew_rain = ldew_rain+ldew_smelt + xsc_rain = xsc_rain + MAX(0., ldew_rain-satcap_rain) + ldew_rain = ldew_rain - MAX(0., ldew_rain-satcap_rain) + ENDIF + ! tleaf = fvegc*tfrz+ (1.0-fwet)*tleaf + ELSE + IF (ldew_rain>1.e-8) THEN + ldew_frzc = MIN(ldew_rain,(tfrz-tleaf)*CWAT*ldew_rain/DENH2O/(HFUS)) + ldew_frzc = MAX(ldew_frzc,0.0) + ldew_snow = ldew_snow+ldew_frzc + ldew_rain = ldew_rain-ldew_frzc + xsc_snow = xsc_snow + MAX(0., ldew_snow-satcap_snow) + ldew_snow = ldew_snow - MAX(0., ldew_snow-satcap_snow) + ENDIF + !tleaf = fvegc*tfrz+ (1.0-fwet)*tleaf + ENDIF + + ldew = ldew -(xsc_rain+xsc_snow) + + IF (p0 > 1.e-8) THEN + ! interception efficiency + fpi_rain = min(1.0,lai+sai) + fpi_snow = min(1.0,lai+sai) + + tti_rain = (prc_rain+prl_rain+ qflx_irrig_sprinkler)*deltim * ( 1. - fpi_rain ) + tti_snow = (prc_snow+prl_snow)*deltim * ( 1. - fpi_snow ) + + ldew_rain = ldew_rain + (prc_rain+prl_rain+ qflx_irrig_sprinkler)*deltim * fpi_rain + ldew_snow = ldew_snow + (prc_snow+prl_snow)*deltim * fpi_snow + + tex_rain = max(0.0,ldew_rain-satcap_rain) + tex_snow = max(0.0,ldew_snow-satcap_snow) + + ldew_rain = ldew_rain - tex_rain + ldew_snow = ldew_snow - tex_snow + + !unload of snow + !* Reduce the amount of intercepted snow if windy and cold. + !Ringyo Shikenjo Tokyo, #54, 1952. + !Bulletin of the Govt. Forest Exp. Station, + !Govt. Forest Exp. Station, Meguro, Tokyo, Japan. + !FORSTX 634.9072 R475r #54. + !Page 146, Figure 10. + + !Reduce the amount of intercepted snow if snowing, windy, and + !cold (< -3 to -5 C). + !Schmidt and Troendle 1992 western snow conference paper. */ + Wind= SQRT(forc_us*forc_us + forc_vs*forc_vs) + if (tleaf-273.15<-3.0 .and. Wind> 1.0) THEN + BlownSnow=(0.2*Wind -0.2)* ldew_snow + BlownSnow = min(ldew_snow,BlownSnow) + tex_snow = tex_snow + BlownSnow + ldew_snow = ldew_snow - BlownSnow + endif + !/* at this point we have calculated the amount of snowfall intercepted and + !/* the amount of rainfall intercepted. These values have been + !/* appropriately subtracted from SnowFall and RainFall to determine + !/* SnowThroughfall and RainThroughfall. However, we can end up with the + !/* condition that the total intercepted rain plus intercepted snow is + !/* greater than the maximum bearing capacity of the tree regardless of air + !/* temp (Imax1). The following routine will adjust ldew_rain and ldew_snow + !/* by triggering mass release due to overloading. Of course since ldew_rain + !/* and ldew_snow are mixed, we need to slough them of as fixed fractions */ + IF (ldew_rain + ldew_snow > Imax1) THEN + ! /*THEN trigger structural unloading*/ + Overload = (ldew_snow + ldew_rain) - Imax1 + IntRainFract = ldew_rain / (ldew_rain + ldew_snow) + IntSnowFract = 1.0 - IntRainFract + ldew_rain = ldew_rain - Overload * IntRainFract + ldew_snow = ldew_snow - Overload * IntSnowFract + tex_rain = tex_rain + Overload*IntRainFract + tex_snow = tex_snow + Overload*IntSnowFract + ENDIF + +#if(defined CoLMDEBUG) + IF (tex_rain+tex_snow+tti_rain+tti_snow-p0 > 1.e-10) THEN + write(6,*) 'tex_ + tti_ > p0 in interception code : ' + ENDIF +#endif - !/* Snow in canopy too thin for EB calculations; let it fall through */ - !param.SNOW_MIN_SWQ_EB_THRES = 0.0010; m*1000. - if (Snow == 0.0 .and. ldew_snow < 0.0010*1000.0) THEN - SnowThroughFall = ldew_snow+SnowThroughFall - DeltaSnowInt =DeltaSnowInt-ldew_snow; + ELSE + ! all intercepted by canopy leves for very small precipitation + tti_rain = 0. + tti_snow = 0. + tex_rain = 0. + tex_snow = 0. ENDIF - !/* physical depth */ - ldew_snow = ldew_snow+ DeltaSnowInt; - if (ldew_snow < 1.e-8) THEN - ldew_snow = 0.0; + + thru_rain = tti_rain + tex_rain + thru_snow = tti_snow + tex_snow + + ldew_rain= ldew_rain+(prc_rain+prl_rain+ qflx_irrig_sprinkler)*deltim- thru_rain + ldew_snow= ldew_snow+(prc_snow+prl_snow)*deltim- thru_snow + + pinf = p0 - (thru_rain + thru_snow) + ldew = ldew + pinf + + + pg_rain = (xsc_rain + thru_rain) / deltim + pg_snow = (xsc_snow + thru_snow) / deltim + qintr = pinf / deltim + + qintr_rain = prc_rain + prl_rain - thru_rain / deltim + qintr_snow = prc_snow + prl_snow - thru_snow / deltim +#if(defined CoLMDEBUG) + w = w - ldew - (pg_rain+pg_snow)*deltim + IF (abs(w) > 1.e-6) THEN + write(6,*) 'something wrong in interception code : ' + write(6,*) w, ldew, (pg_rain+pg_snow)*deltim !, satcap + CALL abort ENDIF +#endif - ! /* Calculate amount of rain intercepted on branches and stored in intercepted snow. */ - ! /* physical depth */ - MaxInt=exp(-4.0)*lsai !need check the unit!! maximum interception capacity!!1 - MaxWaterInt =0.035 * (ldew_snow) + MaxInt - - Rain=(prc_rain+prl_rain)*deltim - if (ldew_rain+Rain <=MaxWaterInt) THEN - !/* physical depth */ - ldew_rain=ldew_rain+Rain - ! /* pixel depth */ - RainThroughFall = Rain * (1 -fvegc) + ELSE + ! 07/15/2023, yuan: #bug found for ldew value reset. + !NOTE: this bug should exist in other interception schemes @Zhongwang. + IF (ldew > 0.) THEN + IF (tleaf > tfrz) THEN + pg_rain = prc_rain + prl_rain + qflx_irrig_sprinkler + ldew/deltim + pg_snow = prc_snow + prl_snow + ELSE + pg_rain = prc_rain + prl_rain + qflx_irrig_sprinkler + pg_snow = prc_snow + prl_snow + ldew/deltim + ENDIF ELSE - ! /* pixel depth */ - RainThroughFall = (ldew_rain +Rain - MaxWaterInt) * fvegc +(Rain * (1.0 - fvegc)); - !/* physical depth */ - ldew_rain = MaxWaterInt + pg_rain = prc_rain + prl_rain + qflx_irrig_sprinkler + pg_snow = prc_snow + prl_snow ENDIF - !// Liquid water in canopy too thin for EB calculations; let it fall through - if (Rain <= 1.e-8 .and.ldew_rain < 0.0010/1000.) THEN - RainThroughFall =RainThroughFall+ldew_rain; - ldew_rain = 0.0; - ENDIF + ldew = 0. + qintr = 0. + qintr_rain = 0. + qintr_snow = 0. + ENDIF + END SUBROUTINE LEAF_interception_VIC - !/* at this point we have calculated the amount of snowfall intercepted and - !/* the amount of rainfall intercepted. These values have been - !/* appropriately subtracted from SnowFall and RainFall to determine - !/* SnowThroughfall and RainThroughfall. However, we can end up with the - !/* condition that the total intercepted rain plus intercepted snow is - !/* greater than the maximum bearing capacity of the tree regardless of air - !/* temp (Imax1). The following routine will adjust ldew_rain and ldew_snow - !/* by triggering mass release due to overloading. Of course since ldew_rain - !/* and ldew_snow are mixed, we need to slough them of as fixed fractions */ - - IF (ldew_rain + ldew_snow > Imax1) THEN - ! /*THEN trigger structural unloading*/ - Overload = (ldew_snow + ldew_rain) - Imax1 - IntRainFract = ldew_rain / (ldew_rain + ldew_snow) - IntSnowFract = ldew_snow / (ldew_rain + ldew_snow) - ldew_rain = ldew_rain - Overload * IntRainFract - ldew_snow = ldew_snow - Overload * IntSnowFract - RainThroughFall = RainThroughFall + (Overload * IntRainFract) * fvegc - SnowThroughFall = SnowThroughFall + (Overload * IntSnowFract) * fvegc - ENDIF + SUBROUTINE LEAF_interception_JULES(deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sai,tair,tleaf, & + prc_rain,prc_snow,prl_rain,prl_snow,& + ldew,ldew_rain,ldew_snow,z0m,hu,pg_rain,pg_snow,qintr,qintr_rain,qintr_snow) + !DESCRIPTION + !=========== + ! Interception and drainage of precipitation + ! the treatment are modified from JULES + !Original Author: + !------------------- + !---JULES development and research community + + !References: + !------------------- + !---Best et al. (2011): The Joint UK Land Environment Simulator (JULES), model description – + ! Part 1: Energy and water fluxes. Geosci. Model Dev. 4:677–699. + !---Clark et al. (2011): The Joint UK Land Environment Simulator (JULES), model description – + ! Part 2: Carbon fluxes and vegetation dynamics. Geosci. Model Dev. 4:701–722. + !ANCILLARY FUNCTIONS AND SUBROUTINES + !------------------- + + !REVISION HISTORY + !---------------- + ! 2023.02.21 Zhongwang Wei @ SYSU + ! 2021.12.08 Zhongwang Wei @ SYSU + !======================================================================= + + IMPLICIT NONE + + REAL(r8), INTENT(in) :: deltim !seconds in a time step [second] + REAL(r8), INTENT(in) :: dewmx !maximum dew [mm] + REAL(r8), INTENT(in) :: forc_us !wind speed + REAL(r8), INTENT(in) :: forc_vs !wind speed + REAL(r8), INTENT(in) :: chil !leaf angle distribution factor + REAL(r8), INTENT(in) :: prc_rain !convective ranfall [mm/s] + REAL(r8), INTENT(in) :: prc_snow !convective snowfall [mm/s] + REAL(r8), INTENT(in) :: prl_rain !large-scale rainfall [mm/s] + REAL(r8), INTENT(in) :: prl_snow !large-scale snowfall [mm/s] + REAL(r8), INTENT(in) :: sigf !fraction of veg cover, excluding snow-covered veg [-] + REAL(r8), INTENT(in) :: lai !leaf area index [-] + REAL(r8), INTENT(in) :: sai !stem area index [-] + REAL(r8), INTENT(in) :: tair !air temperature [K] + REAL(r8), INTENT(inout) :: tleaf !sunlit canopy leaf temperature [K] + + REAL(r8), INTENT(inout) :: ldew !depth of water on foliage [mm] + REAL(r8), INTENT(inout) :: ldew_rain !depth of liquid on foliage [mm] + REAL(r8), INTENT(inout) :: ldew_snow !depth of liquid on foliage [mm] + REAL(r8), INTENT(in) :: z0m !roughness length + REAL(r8), INTENT(in) :: hu !forcing height of U + + REAL(r8), INTENT(out) :: pg_rain !rainfall onto ground including canopy runoff [kg/(m2 s)] + REAL(r8), INTENT(out) :: pg_snow !snowfall onto ground including canopy runoff [kg/(m2 s)] + REAL(r8), INTENT(out) :: qintr !interception [kg/(m2 s)] + REAL(r8), INTENT(out) :: qintr_rain ! rainfall interception (mm h2o/s) + REAL(r8), INTENT(out) :: qintr_snow ! snowfall interception (mm h2o/s) + REAL(r8) :: snowinterceptfact,unload_rate_cnst,unload_rate_u,Wind + IF (lai+sai > 1e-6) THEN + lsai = lai + sai + vegt = lsai + !--------------------------------------------------- + !TODO: these variable should be based on vegetation type + unload_rate_cnst= 0.001 !a constant term (kg m-2 s-1) that represents unloading processes like sublimation, wind erosion etc. + unload_rate_u = 0.001 !wind speed dependent term (s-1*1000) that causes additional unloading proportional to wind speed. + !--------------------------------------------------- + ! Constant in relationship between mass of intercepted snow and snowfall rate + snowinterceptfact = 0.6 + satcap_snow = 4.4 *lsai + satcap_rain = 0.1 *lsai + + ! Caution here: JULES is PFT based, fvegc is not exxisitng + fvegc = max(0.05,1.0-exp(-0.52*lsai)) + + p0 = (prc_rain + prc_snow + prl_rain + prl_snow+qflx_irrig_sprinkler)*deltim + ppc = (prc_rain + prc_snow)*deltim + ppl = (prl_rain + prl_snow + qflx_irrig_sprinkler)*deltim + + w = ldew+p0 + + xsc_rain = max(0., ldew_rain-satcap_rain) + xsc_snow = max(0., ldew_snow-satcap_snow) + + ldew_rain = ldew_rain-xsc_rain + ldew_snow = ldew_snow-xsc_snow + + !snow unloading + !something wrong with this part in JULES, need to be checked +! IF (ldew_snow>1.e-8) THEN +! Wind= SQRT(forc_us*forc_us + forc_vs*forc_vs) +! if (Wind > 1.0) THEN +! ICEDRIP = unload_rate_cnst + unload_rate_u * Wind +! ICEDRIP = MIN(ICEDRIP,ldew_snow) +! xsc_snow = xsc_snow+ICEDRIP +! ldew_snow = ldew_snow - ICEDRIP +! endif +! ENDIF - !here is diff from original VIC ! phase change and excess ! IF (tleaf > tfrz) THEN - ldew_smelt = MIN(ldew_snow,(tleaf-tfrz)*CICE*ldew_snow/DENICE/(HFUS)) - ldew_smelt = max(ldew_smelt,0.0) - ldew_snow = ldew_snow-ldew_smelt - ldew_rain = ldew_rain+ldew_smelt + IF (ldew_snow>1.e-8) THEN + ldew_smelt = MIN(ldew_snow,(tleaf-tfrz)*CICE*ldew_snow/DENICE/(HFUS)) + ldew_smelt = MAX(ldew_smelt,0.0) + ldew_snow = ldew_snow-ldew_smelt + ldew_rain = ldew_rain+ldew_smelt + xsc_rain = xsc_rain + MAX(0., ldew_rain-satcap_rain) + ldew_rain = ldew_rain - MAX(0., ldew_rain-satcap_rain) + ENDIF + ! tleaf = fvegc*tfrz+ (1.0-fwet)*tleaf ELSE - ldew_frzc = MIN(ldew_rain,(tfrz-tleaf)*CWAT*ldew_rain/DENH2O/(HFUS)) - ldew_frzc = max(ldew_smelt,0.0) - ldew_snow = ldew_snow+ldew_frzc - ldew_rain = ldew_rain-ldew_frzc + IF (ldew_rain>1.e-8) THEN + ldew_frzc = MIN(ldew_rain,(tfrz-tleaf)*CWAT*ldew_rain/DENH2O/(HFUS)) + ldew_frzc = MAX(ldew_frzc,0.0) + ldew_snow = ldew_snow+ldew_frzc + ldew_rain = ldew_rain-ldew_frzc + xsc_snow = xsc_snow + MAX(0., ldew_snow-satcap_snow) + ldew_snow = ldew_snow - MAX(0., ldew_snow-satcap_snow) + ENDIF + !tleaf = fvegc*tfrz+ (1.0-fwet)*tleaf ENDIF + ldew = ldew - (xsc_rain + xsc_snow) - !/* Update maximum water interception storage */ - MaxInt=exp(-4.0)*lsai !need check the unit!! maximum interception capacity!!1 - MaxWaterInt =0.035 * (ldew_snow) + MaxInt + IF (p0 > 1.e-8) THEN - drip=max(0.0,ldew_rain-MaxWaterInt) - ldew_rain=ldew_rain-drip + tti_rain = (prc_rain+prl_rain+qflx_irrig_sprinkler)*deltim * ( 1.-fvegc ) + tti_snow = (prc_snow+prl_snow)*deltim * ( 1.-fvegc ) + int_rain = min(fvegc*(prc_rain+prl_rain+qflx_irrig_sprinkler),snowinterceptfact*(satcap_rain-ldew_rain)/deltim*(1.0-exp(-(prc_rain+prl_rain+qflx_irrig_sprinkler)*deltim/satcap_rain))) + int_snow = min(fvegc*(prc_snow + prl_snow),snowinterceptfact*(satcap_snow-ldew_snow)/deltim*(1.0-exp(-(prc_snow+prl_snow)*deltim/satcap_snow))) + int_rain = max(0.,int_rain)*deltim + int_snow = max(0.,int_snow)*deltim - ldew=ldew_rain+ldew_snow + tex_rain = (prc_rain+prl_rain+qflx_irrig_sprinkler)*fvegc*deltim - int_rain + tex_snow = (prc_snow+prl_snow)*fvegc*deltim - int_snow +#if(defined CoLMDEBUG) + IF (tex_rain+tex_snow+tti_rain+tti_snow-p0 > 1.e-10) THEN + write(6,*) 'tex_ + tti_ > p0 in interception code : ' + ENDIF +#endif + ELSE + ! all intercepted by canopy leves for very small precipitation + tti_rain = 0. + tti_snow = 0. + tex_rain = 0. + tex_snow = 0. + ENDIF + !---------------------------------------------------------------------- + ! total throughfall (thru) and store augmentation + !---------------------------------------------------------------------- - pg_rain=drip+RainThroughFall - pg_snow=SnowThroughFall - qintr_snow=-0.0 - qintr_rain=-0.0 + thru_rain = tti_rain + tex_rain + thru_snow = tti_snow + tex_snow + pinf = p0 - (thru_rain + thru_snow) + ldew = ldew + pinf + + pg_rain = (xsc_rain + thru_rain) / deltim + pg_snow = (xsc_snow + thru_snow) / deltim + qintr = pinf / deltim + + qintr_rain = prc_rain + prl_rain + qflx_irrig_sprinkler - thru_rain / deltim + qintr_snow = prc_snow + prl_snow - thru_snow / deltim +#if(defined CoLMDEBUG) + w = w - ldew - (pg_rain+pg_snow)*deltim + IF (abs(w) > 1.e-6) THEN + write(6,*) 'something wrong in interception code : ' + write(6,*) w, ldew, (pg_rain+pg_snow)*deltim !, satcap + CALL abort + ENDIF +#endif ELSE - ldew = 0. - pg_rain = prc_rain + prl_rain - pg_snow = prc_snow + prl_snow - qintr = 0. + ! 07/15/2023, yuan: #bug found for ldew value reset. + !NOTE: this bug should exist in other interception schemes @Zhongwang. + IF (ldew > 0.) THEN + IF (tleaf > tfrz) THEN + pg_rain = prc_rain + prl_rain + qflx_irrig_sprinkler + ldew/deltim + pg_snow = prc_snow + prl_snow + ELSE + pg_rain = prc_rain + prl_rain + qflx_irrig_sprinkler + pg_snow = prc_snow + prl_snow + ldew/deltim + ENDIF + ELSE + pg_rain = prc_rain + prl_rain + qflx_irrig_sprinkler + pg_snow = prc_snow + prl_snow + ENDIF + + ldew = 0. + qintr = 0. qintr_rain = 0. qintr_snow = 0. - ENDIF - - END SUBROUTINE LEAF_interception_VIC - + ENDIF + END SUBROUTINE LEAF_interception_JULES SUBROUTINE LEAF_interception_wrap(deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sai,tair,tleaf, & prc_rain,prc_snow,prl_rain,prl_snow,& @@ -1361,101 +1700,99 @@ SUBROUTINE LEAF_interception_wrap(deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sai IMPLICIT NONE - REAL(r8), INTENT(in) :: deltim !seconds in a time step [second] - REAL(r8), INTENT(in) :: dewmx !maximum dew [mm] - REAL(r8), INTENT(in) :: forc_us !wind speed - REAL(r8), INTENT(in) :: forc_vs !wind speed - REAL(r8), INTENT(in) :: chil !leaf angle distribution factor - REAL(r8), INTENT(in) :: prc_rain !convective ranfall [mm/s] - REAL(r8), INTENT(in) :: prc_snow !convective snowfall [mm/s] - REAL(r8), INTENT(in) :: prl_rain !large-scale rainfall [mm/s] - REAL(r8), INTENT(in) :: prl_snow !large-scale snowfall [mm/s] - REAL(r8), INTENT(in) :: sigf !fraction of veg cover, excluding snow-covered veg [-] - REAL(r8), INTENT(in) :: lai !leaf area index [-] - REAL(r8), INTENT(in) :: sai !stem area index [-] - REAL(r8), INTENT(in) :: tair !air temperature [K] + REAL(r8), INTENT(in) :: deltim !seconds in a time step [second] + REAL(r8), INTENT(in) :: dewmx !maximum dew [mm] + REAL(r8), INTENT(in) :: forc_us !wind speed + REAL(r8), INTENT(in) :: forc_vs !wind speed + REAL(r8), INTENT(in) :: chil !leaf angle distribution factor + REAL(r8), INTENT(in) :: prc_rain !convective ranfall [mm/s] + REAL(r8), INTENT(in) :: prc_snow !convective snowfall [mm/s] + REAL(r8), INTENT(in) :: prl_rain !large-scale rainfall [mm/s] + REAL(r8), INTENT(in) :: prl_snow !large-scale snowfall [mm/s] + REAL(r8), INTENT(in) :: sigf !fraction of veg cover, excluding snow-covered veg [-] + REAL(r8), INTENT(in) :: lai !leaf area index [-] + REAL(r8), INTENT(in) :: sai !stem area index [-] + REAL(r8), INTENT(in) :: tair !air temperature [K] REAL(r8), INTENT(inout) :: tleaf !sunlit canopy leaf temperature [K] REAL(r8), INTENT(inout) :: ldew !depth of water on foliage [mm] REAL(r8), INTENT(inout) :: ldew_rain !depth of liquid on foliage [mm] REAL(r8), INTENT(inout) :: ldew_snow !depth of liquid on foliage [mm] - REAL(r8), INTENT(in) :: z0m !roughness length - REAL(r8), INTENT(in) :: hu !forcing height of U + REAL(r8), INTENT(in) :: z0m !roughness length + REAL(r8), INTENT(in) :: hu !forcing height of U - REAL(r8), INTENT(out) :: pg_rain !rainfall onto ground including canopy runoff [kg/(m2 s)] - REAL(r8), INTENT(out) :: pg_snow !snowfall onto ground including canopy runoff [kg/(m2 s)] - REAL(r8), INTENT(out) :: qintr !interception [kg/(m2 s)] - REAL(r8), INTENT(out) :: qintr_rain ! rainfall interception (mm h2o/s) - REAL(r8), INTENT(out) :: qintr_snow ! snowfall interception (mm h2o/s) + REAL(r8), INTENT(out) :: pg_rain !rainfall onto ground including canopy runoff [kg/(m2 s)] + REAL(r8), INTENT(out) :: pg_snow !snowfall onto ground including canopy runoff [kg/(m2 s)] + REAL(r8), INTENT(out) :: qintr !interception [kg/(m2 s)] + REAL(r8), INTENT(out) :: qintr_rain ! rainfall interception (mm h2o/s) + REAL(r8), INTENT(out) :: qintr_snow ! snowfall interception (mm h2o/s) - if (DEF_Interception_scheme==1) then + IF (DEF_Interception_scheme==1) then - CALL LEAF_interception_CoLM2014 ( deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sai,tair,tleaf, & + CALL LEAF_interception_CoLM2014 (deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sai,tair,tleaf, & prc_rain,prc_snow,prl_rain,prl_snow,& - ldew,ldew_rain,ldew_snow,z0m,hu,pg_rain,& - pg_snow,qintr,qintr_rain,qintr_snow) + ldew,ldew_rain,ldew_snow,z0m,hu,pg_rain,& + pg_snow,qintr,qintr_rain,qintr_snow) ELSEIF (DEF_Interception_scheme==2) then - CALL LEAF_interception_CLM4 ( deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sai,tair,tleaf, & - prc_rain,prc_snow,prl_rain,prl_snow,& - ldew,ldew_rain,ldew_snow,z0m,hu,pg_rain,& + CALL LEAF_interception_CLM4 (deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sai,tair,tleaf, & + prc_rain,prc_snow,prl_rain,prl_snow,& + ldew,ldew_rain,ldew_snow,z0m,hu,pg_rain,& pg_snow,qintr,qintr_rain,qintr_snow) ELSEIF (DEF_Interception_scheme==3) then - CALL LEAF_interception_CLM5( deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sai,tair,tleaf, & - prc_rain,prc_snow,prl_rain,prl_snow,& - ldew,ldew_rain,ldew_snow,z0m,hu,pg_rain,& - pg_snow,qintr,qintr_rain,qintr_snow) + CALL LEAF_interception_CLM5(deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sai,tair,tleaf, & + prc_rain,prc_snow,prl_rain,prl_snow,& + ldew,ldew_rain,ldew_snow,z0m,hu,pg_rain,& + pg_snow,qintr,qintr_rain,qintr_snow) ELSEIF (DEF_Interception_scheme==4) then - CALL LEAF_interception_NoahMP ( deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sai,tair,tleaf, & - prc_rain,prc_snow,prl_rain,prl_snow,& - ldew,ldew_rain,ldew_snow,z0m,hu,pg_rain,& - pg_snow,qintr,qintr_rain,qintr_snow) + CALL LEAF_interception_NoahMP (deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sai,tair,tleaf, & + prc_rain,prc_snow,prl_rain,prl_snow,& + ldew,ldew_rain,ldew_snow,z0m,hu,pg_rain,& + pg_snow,qintr,qintr_rain,qintr_snow) ELSEIF (DEF_Interception_scheme==5) then - CALL LEAF_interception_matsiro ( deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sai,tair,tleaf, & + CALL LEAF_interception_matsiro (deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sai,tair,tleaf, & prc_rain,prc_snow,prl_rain,prl_snow,& - ldew,ldew_rain,ldew_snow,z0m,hu,pg_rain,& - pg_snow,qintr,qintr_rain,qintr_snow) + ldew,ldew_rain,ldew_snow,z0m,hu,pg_rain,& + pg_snow,qintr,qintr_rain,qintr_snow) ELSEIF (DEF_Interception_scheme==6) then - CALL LEAF_interception_vic ( deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sai,tair,tleaf, & - prc_rain,prc_snow,prl_rain,prl_snow,& - ldew,ldew_rain,ldew_snow,z0m,hu,pg_rain,& + CALL LEAF_interception_vic (deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sai,tair,tleaf, & + prc_rain,prc_snow,prl_rain,prl_snow,& + ldew,ldew_rain,ldew_snow,z0m,hu,pg_rain,& pg_snow,qintr,qintr_rain,qintr_snow) ELSEIF (DEF_Interception_scheme==7) then + CALL LEAF_interception_JULES (deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sai,tair,tleaf, & + prc_rain,prc_snow,prl_rain,prl_snow,& + ldew,ldew_rain,ldew_snow,z0m,hu,pg_rain,& + pg_snow,qintr,qintr_rain,qintr_snow) - CALL LEAF_interception_colm202x ( deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sai,tair,tleaf, & - prc_rain,prc_snow,prl_rain,prl_snow,& - ldew,ldew_rain,ldew_snow,z0m,hu,pg_rain,& - pg_snow,qintr,qintr_rain,qintr_snow) + ELSEIF (DEF_Interception_scheme==8) then + CALL LEAF_interception_colm202x (deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sai,tair,tleaf, & + prc_rain,prc_snow,prl_rain,prl_snow,& + ldew,ldew_rain,ldew_snow,z0m,hu,pg_rain,& + pg_snow,qintr,qintr_rain,qintr_snow) endif END SUBROUTINE LEAF_interception_wrap -#ifdef LULC_IGBP_PFT +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) SUBROUTINE LEAF_interception_pftwrap (ipatch,deltim,dewmx,forc_us,forc_vs,forc_t,& prc_rain,prc_snow,prl_rain,prl_snow,& ldew,ldew_rain,ldew_snow,z0m,hu,pg_rain,pg_snow,qintr,qintr_rain,qintr_snow) - !DESCRIPTION - !=========== - !wrapper for calculation of canopy interception using PFT land cover classification - - !ANCILLARY FUNCTIONS AND SUBROUTINES - !------------------- - - !Original Author: - !------------------- - !---Shupeng Zhang - - !References: - - - !REVISION HISTORY - !---------------- - ! 2023.02.21 Zhongwang Wei @ SYSU : add different options of canopy interception for PFTs +! ----------------------------------------------------------------- +! !DESCRIPTION: +! wrapper for calculation of canopy interception for PFTs within a land cover type. +! +! Created by Hua Yuan, 06/2019 +! +! !REVISION HISTORY: +! 2023.02.21 Zhongwang Wei @ SYSU: add different options of canopy interception for PFTs +! +! ----------------------------------------------------------------- USE MOD_Precision USE MOD_LandPFT @@ -1466,29 +1803,32 @@ SUBROUTINE LEAF_interception_pftwrap (ipatch,deltim,dewmx,forc_us,forc_vs,forc_t USE MOD_Const_PFT IMPLICIT NONE - INTEGER, INTENT(in) :: ipatch !patch index - REAL(r8), INTENT(in) :: deltim !seconds in a time step [second] - REAL(r8), INTENT(in) :: dewmx !maximum dew [mm] - REAL(r8), INTENT(in) :: forc_us !wind speed - REAL(r8), INTENT(in) :: forc_vs !wind speed - REAL(r8), INTENT(in) :: forc_t !air temperature - REAL(r8), INTENT(in) :: z0m ! roughness length - REAL(r8), INTENT(in) :: hu ! forcing height of U - REAL(r8), INTENT(in) :: ldew_rain ! depth of water on foliage [mm] - REAL(r8), INTENT(in) :: ldew_snow ! depth of water on foliage [mm] - REAL(r8), INTENT(in) :: prc_rain !convective ranfall [mm/s] - REAL(r8), INTENT(in) :: prc_snow !convective snowfall [mm/s] - REAL(r8), INTENT(in) :: prl_rain !large-scale rainfall [mm/s] - REAL(r8), INTENT(in) :: prl_snow !large-scale snowfall [mm/s] - - REAL(r8), INTENT(inout) :: ldew !depth of water on foliage [mm] - REAL(r8), INTENT(out) :: pg_rain !rainfall onto ground including canopy runoff [kg/(m2 s)] - REAL(r8), INTENT(out) :: pg_snow !snowfall onto ground including canopy runoff [kg/(m2 s)] - REAL(r8), INTENT(out) :: qintr !interception [kg/(m2 s)] - REAL(r8), INTENT(out) :: qintr_rain ! rainfall interception (mm h2o/s) - REAL(r8), INTENT(out) :: qintr_snow ! snowfall interception (mm h2o/s) + INTEGER, INTENT(in) :: ipatch !patch index + REAL(r8), INTENT(in) :: deltim !seconds in a time step [second] + REAL(r8), INTENT(in) :: dewmx !maximum dew [mm] + REAL(r8), INTENT(in) :: forc_us !wind speed + REAL(r8), INTENT(in) :: forc_vs !wind speed + REAL(r8), INTENT(in) :: forc_t !air temperature + REAL(r8), INTENT(in) :: z0m !roughness length + REAL(r8), INTENT(in) :: hu !forcing height of U + REAL(r8), INTENT(in) :: ldew_rain !depth of water on foliage [mm] + REAL(r8), INTENT(in) :: ldew_snow !depth of water on foliage [mm] + REAL(r8), INTENT(in) :: prc_rain !convective ranfall [mm/s] + REAL(r8), INTENT(in) :: prc_snow !convective snowfall [mm/s] + REAL(r8), INTENT(in) :: prl_rain !large-scale rainfall [mm/s] + REAL(r8), INTENT(in) :: prl_snow !large-scale snowfall [mm/s] + + REAL(r8), INTENT(inout) :: ldew !depth of water on foliage [mm] + REAL(r8), INTENT(out) :: pg_rain !rainfall onto ground including canopy runoff [kg/(m2 s)] + REAL(r8), INTENT(out) :: pg_snow !snowfall onto ground including canopy runoff [kg/(m2 s)] + REAL(r8), INTENT(out) :: qintr !interception [kg/(m2 s)] + REAL(r8), INTENT(out) :: qintr_rain !rainfall interception (mm h2o/s) + REAL(r8), INTENT(out) :: qintr_snow !snowfall interception (mm h2o/s) INTEGER i, p, ps, pe +#ifdef CROP + INTEGER :: irrig_flag ! 1 if sprinker, 2 if others +#endif REAL(r8) pg_rain_tmp, pg_snow_tmp pg_rain_tmp = 0. @@ -1497,12 +1837,20 @@ SUBROUTINE LEAF_interception_pftwrap (ipatch,deltim,dewmx,forc_us,forc_vs,forc_t ps = patch_pft_s(ipatch) pe = patch_pft_e(ipatch) + if(.not. DEF_USE_IRRIGATION) qflx_irrig_sprinkler = 0._r8 + +#ifdef CROP + if(DEF_USE_IRRIGATION)then + call CalIrrigationApplicationFluxes(ipatch,ps,pe,deltim,qflx_irrig_drip,qflx_irrig_sprinkler,qflx_irrig_flood,qflx_irrig_paddy,irrig_flag=1) + end if +#endif + if (DEF_Interception_scheme==1) THEN DO i = ps, pe p = pftclass(i) CALL LEAF_interception_CoLM2014 (deltim,dewmx,forc_us,forc_vs,chil_p(p),sigf_p(i),lai_p(i),sai_p(i),forc_t,tleaf_p(i),& - prc_rain,prc_snow,prl_rain,prl_snow,& - ldew_p(i),ldew_p(i),ldew_p(i),z0m_p(i),hu,pg_rain,pg_snow,qintr_p(i),qintr_rain_p(i),qintr_snow_p(i)) + prc_rain,prc_snow,prl_rain,prl_snow,& + ldew_p(i),ldew_p(i),ldew_p(i),z0m_p(i),hu,pg_rain,pg_snow,qintr_p(i),qintr_rain_p(i),qintr_snow_p(i)) pg_rain_tmp = pg_rain_tmp + pg_rain*pftfrac(i) pg_snow_tmp = pg_snow_tmp + pg_snow*pftfrac(i) ENDDO @@ -1552,6 +1900,15 @@ SUBROUTINE LEAF_interception_pftwrap (ipatch,deltim,dewmx,forc_us,forc_vs,forc_t pg_snow_tmp = pg_snow_tmp + pg_snow*pftfrac(i) ENDDO ELSE IF (DEF_Interception_scheme==7) THEN + DO i = ps, pe + p = pftclass(i) + CALL LEAF_interception_JULES (deltim,dewmx,forc_us,forc_vs,chil_p(p),sigf_p(i),lai_p(i),sai_p(i),forc_t,tleaf_p(i),& + prc_rain,prc_snow,prl_rain,prl_snow,& + ldew_p(i),ldew_p(i),ldew_p(i),z0m_p(i),hu,pg_rain,pg_snow,qintr_p(i),qintr_rain_p(i),qintr_snow_p(i)) + pg_rain_tmp = pg_rain_tmp + pg_rain*pftfrac(i) + pg_snow_tmp = pg_snow_tmp + pg_snow*pftfrac(i) + ENDDO + ELSE IF (DEF_Interception_scheme==8) THEN DO i = ps, pe p = pftclass(i) CALL LEAF_interception_CoLM202x (deltim,dewmx,forc_us,forc_vs,chil_p(p),sigf_p(i),lai_p(i),sai_p(i),forc_t,tleaf_p(i),& @@ -1560,182 +1917,15 @@ SUBROUTINE LEAF_interception_pftwrap (ipatch,deltim,dewmx,forc_us,forc_vs,forc_t pg_rain_tmp = pg_rain_tmp + pg_rain*pftfrac(i) pg_snow_tmp = pg_snow_tmp + pg_snow*pftfrac(i) ENDDO - end if + ENDIF pg_rain = pg_rain_tmp pg_snow = pg_snow_tmp - ldew = sum( ldew_p(ps:pe) * pftfrac(ps:pe)) + ldew = sum(ldew_p(ps:pe) * pftfrac(ps:pe)) qintr = sum(qintr_p(ps:pe) * pftfrac(ps:pe)) qintr_rain = sum(qintr_rain_p(ps:pe) * pftfrac(ps:pe)) qintr_snow = sum(qintr_snow_p(ps:pe) * pftfrac(ps:pe)) END SUBROUTINE LEAF_interception_pftwrap #endif -#ifdef LULC_IGBP_PC - SUBROUTINE LEAF_interception_pcwrap (ipatch,deltim,dewmx,forc_us,forc_vs,forc_t,chil,& - prc_rain,prc_snow,prl_rain,prl_snow,& - ldew,ldew_rain, ldew_snow,hu,pg_rain,pg_snow,qintr,qintr_rain,qintr_snow) - - !DESCRIPTION - !=========== - !wrapper for calculation of canopy interception using PC land cover classification - - !ANCILLARY FUNCTIONS AND SUBROUTINES - !------------------- - - !Original Author: - !------------------- - !--- Hua Yuan - - !References: - !------------------- - - !REVISION HISTORY - !---------------- - !---2023.02.21 Zhongwang Wei @ SYSU : add different options of canopy interception for PFTs - - USE MOD_Precision - USE MOD_Vars_Global - USE MOD_Const_Physical, only: tfrz - USE MOD_Vars_PCTimeInvariants - USE MOD_Vars_PCTimeVariables - USE MOD_Vars_1DPCFluxes - USE MOD_LandPC - USE MOD_Const_PFT - - IMPLICIT NONE - - INTEGER, INTENT(in) :: ipatch !patch index - REAL(r8), INTENT(in) :: deltim !seconds in a time step [second] - REAL(r8), INTENT(in) :: dewmx !maximum dew [mm] - REAL(r8), INTENT(in) :: forc_us !wind speed - REAL(r8), INTENT(in) :: forc_vs !wind speed - REAL(r8), INTENT(in) :: forc_t !air temperature - REAL(r8), INTENT(in) :: chil - REAL(r8), INTENT(in) :: prc_rain !convective ranfall [mm/s] - REAL(r8), INTENT(in) :: prc_snow !convective snowfall [mm/s] - REAL(r8), INTENT(in) :: prl_rain !large-scale rainfall [mm/s] - REAL(r8), INTENT(in) :: prl_snow !large-scale snowfall [mm/s] - REAL(r8), INTENT(in) :: hu - - REAL(r8), INTENT(inout) :: ldew !depth of water on foliage [mm] - REAL(r8), INTENT(inout) :: ldew_rain !depth of water on foliage [mm] - REAL(r8), INTENT(inout) :: ldew_snow !depth of water on foliage [mm] - REAL(r8), INTENT(out) :: pg_rain !rainfall onto ground including canopy runoff [kg/(m2 s)] - REAL(r8), INTENT(out) :: pg_snow !snowfall onto ground including canopy runoff [kg/(m2 s)] - REAL(r8), INTENT(out) :: qintr !interception [kg/(m2 s)] - REAL(r8), INTENT(out) :: qintr_rain !rainfall interception (mm h2o/s) - REAL(r8), INTENT(out) :: qintr_snow !snowfall interception (mm h2o/s) - - INTEGER p, pc - REAL(r8) pg_rain_tmp, pg_snow_tmp - - pg_rain_tmp = 0. - pg_snow_tmp = 0. - - pc = patch2pc(ipatch) - - IF (DEF_Interception_scheme==1) THEN - DO p = 0, N_PFT-1 - CALL LEAF_interception_CoLM2014 (deltim,dewmx,forc_us,forc_vs,& - chil,sigf_c(p,pc),lai_c(p,pc),sai_c(p,pc),forc_t,tleaf_c(p,pc),& - prc_rain,prc_snow,prl_rain,prl_snow,& - ldew_c(p,pc),ldew_rain_c(p,pc),ldew_snow_c(p,pc),& - z0m_c(p,pc),hu,pg_rain,pg_snow,& - qintr_c(p,pc),qintr_rain_c(p,pc),qintr_snow_c(p,pc)) - pg_rain_tmp = pg_rain_tmp + pg_rain*pcfrac(p,pc) - pg_snow_tmp = pg_snow_tmp + pg_snow*pcfrac(p,pc) - ENDDO - ELSE IF (DEF_Interception_scheme==2) THEN - DO p = 0, N_PFT-1 - CALL LEAF_interception_CLM4 (deltim,dewmx,forc_us,forc_vs,& - chil,sigf_c(p,pc),lai_c(p,pc),sai_c(p,pc),forc_t,tleaf_c(p,pc),& - prc_rain,prc_snow,prl_rain,prl_snow,& - ldew_c(p,pc),ldew_rain_c(p,pc),ldew_snow_c(p,pc),& - z0m_c(p,pc),hu,pg_rain,pg_snow,& - qintr_c(p,pc),qintr_rain_c(p,pc),qintr_snow_c(p,pc)) - pg_rain_tmp = pg_rain_tmp + pg_rain*pcfrac(p,pc) - pg_snow_tmp = pg_snow_tmp + pg_snow*pcfrac(p,pc) - ENDDO - pg_rain_tmp = pg_rain_tmp + pg_rain*pcfrac(p,pc) - pg_snow_tmp = pg_snow_tmp + pg_snow*pcfrac(p,pc) - ELSE IF (DEF_Interception_scheme==3) THEN - DO p = 0, N_PFT-1 - CALL LEAF_interception_CLM5 (deltim,dewmx,forc_us,forc_vs,& - chil,sigf_c(p,pc),lai_c(p,pc),sai_c(p,pc),forc_t,tleaf_c(p,pc),& - prc_rain,prc_snow,prl_rain,prl_snow,& - ldew_c(p,pc),ldew_rain_c(p,pc),ldew_snow_c(p,pc),& - z0m_c(p,pc),hu,pg_rain,pg_snow,& - qintr_c(p,pc),qintr_rain_c(p,pc),qintr_snow_c(p,pc)) - pg_rain_tmp = pg_rain_tmp + pg_rain*pcfrac(p,pc) - pg_snow_tmp = pg_snow_tmp + pg_snow*pcfrac(p,pc) - ENDDO - pg_rain_tmp = pg_rain_tmp + pg_rain*pcfrac(p,pc) - pg_snow_tmp = pg_snow_tmp + pg_snow*pcfrac(p,pc) - ELSE IF (DEF_Interception_scheme==4) THEN - DO p = 0, N_PFT-1 - CALL LEAF_interception_NOAHMP (deltim,dewmx,forc_us,forc_vs,& - chil,sigf_c(p,pc),lai_c(p,pc),sai_c(p,pc),forc_t,tleaf_c(p,pc),& - prc_rain,prc_snow,prl_rain,prl_snow,& - ldew_c(p,pc),ldew_rain_c(p,pc),ldew_snow_c(p,pc),& - z0m_c(p,pc),hu,pg_rain,pg_snow,& - qintr_c(p,pc),qintr_rain_c(p,pc),qintr_snow_c(p,pc)) - pg_rain_tmp = pg_rain_tmp + pg_rain*pcfrac(p,pc) - pg_snow_tmp = pg_snow_tmp + pg_snow*pcfrac(p,pc) - ENDDO - pg_rain_tmp = pg_rain_tmp + pg_rain*pcfrac(p,pc) - pg_snow_tmp = pg_snow_tmp + pg_snow*pcfrac(p,pc) - ELSE IF (DEF_Interception_scheme==5) THEN - DO p = 0, N_PFT-1 - CALL LEAF_interception_MATSIRO (deltim,dewmx,forc_us,forc_vs,& - chil,sigf_c(p,pc),lai_c(p,pc),sai_c(p,pc),forc_t,tleaf_c(p,pc),& - prc_rain,prc_snow,prl_rain,prl_snow,& - ldew_c(p,pc),ldew_rain_c(p,pc),ldew_snow_c(p,pc),& - z0m_c(p,pc),hu,pg_rain,pg_snow,& - qintr_c(p,pc),qintr_rain_c(p,pc),qintr_snow_c(p,pc)) - pg_rain_tmp = pg_rain_tmp + pg_rain*pcfrac(p,pc) - pg_snow_tmp = pg_snow_tmp + pg_snow*pcfrac(p,pc) - ENDDO - pg_rain_tmp = pg_rain_tmp + pg_rain*pcfrac(p,pc) - pg_snow_tmp = pg_snow_tmp + pg_snow*pcfrac(p,pc) - ELSE IF (DEF_Interception_scheme==6) THEN - DO p = 0, N_PFT-1 - CALL LEAF_interception_VIC (deltim,dewmx,forc_us,forc_vs,& - chil,sigf_c(p,pc),lai_c(p,pc),sai_c(p,pc),forc_t,tleaf_c(p,pc),& - prc_rain,prc_snow,prl_rain,prl_snow,& - ldew_c(p,pc),ldew_rain_c(p,pc),ldew_snow_c(p,pc),& - z0m_c(p,pc),hu,pg_rain,pg_snow,& - qintr_c(p,pc),qintr_rain_c(p,pc),qintr_snow_c(p,pc)) - pg_rain_tmp = pg_rain_tmp + pg_rain*pcfrac(p,pc) - pg_snow_tmp = pg_snow_tmp + pg_snow*pcfrac(p,pc) - ENDDO - pg_rain_tmp = pg_rain_tmp + pg_rain*pcfrac(p,pc) - pg_snow_tmp = pg_snow_tmp + pg_snow*pcfrac(p,pc) - - ELSE IF (DEF_Interception_scheme==7) THEN - DO p = 0, N_PFT-1 - CALL LEAF_interception_CoLM202x (deltim,dewmx,forc_us,forc_vs,& - chil,sigf_c(p,pc),lai_c(p,pc),sai_c(p,pc),forc_t,tleaf_c(p,pc),& - prc_rain,prc_snow,prl_rain,prl_snow,& - ldew_c(p,pc),ldew_rain_c(p,pc),ldew_snow_c(p,pc),& - z0m_c(p,pc),hu,pg_rain,pg_snow,& - qintr_c(p,pc),qintr_rain_c(p,pc),qintr_snow_c(p,pc)) - pg_rain_tmp = pg_rain_tmp + pg_rain*pcfrac(p,pc) - pg_snow_tmp = pg_snow_tmp + pg_snow*pcfrac(p,pc) - ENDDO - pg_rain_tmp = pg_rain_tmp + pg_rain*pcfrac(p,pc) - pg_snow_tmp = pg_snow_tmp + pg_snow*pcfrac(p,pc) - END IF - - pg_rain = pg_rain_tmp - pg_snow = pg_snow_tmp - ldew = sum( ldew_c(:,pc) * pcfrac(:,pc)) - qintr = sum(qintr_c(:,pc) * pcfrac(:,pc)) - qintr_rain = sum(qintr_rain_c(:,pc) * pcfrac(:,pc)) - qintr_snow = sum(qintr_snow_c(:,pc) * pcfrac(:,pc)) - - END SUBROUTINE LEAF_interception_pcwrap -#endif - - END MODULE MOD_LeafInterception diff --git a/main/MOD_LeafTemperature.F90 b/main/MOD_LeafTemperature.F90 index c87bd1ac..19a4da5f 100644 --- a/main/MOD_LeafTemperature.F90 +++ b/main/MOD_LeafTemperature.F90 @@ -3,50 +3,55 @@ MODULE MOD_LeafTemperature !----------------------------------------------------------------------- -USE MOD_Precision -USE MOD_Namelist, ONLY: DEF_Interception_scheme, DEF_USE_PLANTHYDRAULICS, DEF_USE_OZONESTRESS -USE MOD_SPMD_Task + USE MOD_Precision + USE MOD_Namelist, only: DEF_Interception_scheme, DEF_USE_PLANTHYDRAULICS, & + DEF_USE_OZONESTRESS, DEF_RSS_SCHEME, DEF_SPLIT_SOILSNOW + USE MOD_SPMD_Task -IMPLICIT NONE + IMPLICIT NONE -SAVE + SAVE -! PUBLIC MEMBER FUNCTIONS: -PUBLIC :: LeafTemp + ! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: LeafTemperature -! PRIVATE MEMBER FUNCTIONS: -PRIVATE :: dewfraction -PRIVATE :: cal_z0_displa + ! PRIVATE MEMBER FUNCTIONS: + PRIVATE :: dewfraction +!----------------------------------------------------------------------- CONTAINS - SUBROUTINE LeafTemp(ipatch,ivt,deltim,csoilc,dewmx,htvp,lai ,& - sai ,htop ,hbot ,sqrtdi ,effcon ,vmax25 ,& - slti ,hlti ,shti ,hhti ,trda ,trdm ,& - trop ,gradm ,binter ,extkn ,extkb ,extkd ,& - hu ,ht ,hq ,us ,vs ,thm ,& - th ,thv ,qm ,psrf ,rhoair ,parsun ,& - parsha ,sabv ,frl ,fsun ,thermk ,& - rstfacsun , rstfacsha ,gssun ,gssha ,& - po2m ,pco2m ,z0h_g ,obug ,ustarg ,zlnd ,& - zsno ,fsno ,sigf ,etrc ,tg ,qg ,& - dqgdT ,emg ,tl ,ldew, ldew_rain,ldew_snow ,taux ,tauy ,& - fseng ,fevpg ,cgrnd ,cgrndl ,cgrnds ,tref ,& - qref ,rst ,assim ,respc ,fsenl ,fevpl ,& - etr ,dlrad ,ulrad ,z0m ,zol ,rib ,& - ustar ,qstar ,tstar ,fm ,fh ,fq ,& - rootfr ,& +!----------------------------------------------------------------------- + + SUBROUTINE LeafTemperature ( & + ipatch ,ivt ,deltim ,csoilc ,dewmx ,htvp ,& + lai ,sai ,htop ,hbot ,sqrtdi ,effcon ,& + vmax25 ,slti ,hlti ,shti ,hhti ,trda ,& + trdm ,trop ,g1 ,g0 ,gradm ,binter ,& + extkn ,extkb ,extkd ,hu ,ht ,hq ,& + us ,vs ,thm ,th ,thv ,qm ,& + psrf ,rhoair ,parsun ,parsha ,sabv ,frl ,& + fsun ,thermk ,rstfacsun ,rstfacsha ,gssun ,gssha ,& + po2m ,pco2m ,z0h_g ,obug ,ustarg ,zlnd ,& + zsno ,fsno ,sigf ,etrc ,tg ,qg,rss ,& + t_soil ,t_snow ,q_soil ,q_snow ,dqgdT ,emg ,& + tl ,ldew ,ldew_rain ,ldew_snow ,taux ,tauy ,& + fseng ,fseng_soil,fseng_snow,fevpg ,fevpg_soil,fevpg_snow,& + cgrnd ,cgrndl ,cgrnds ,tref ,qref ,rst ,& + assim ,respc ,fsenl ,fevpl ,etr ,dlrad ,& + ulrad ,z0m ,zol ,rib ,ustar ,qstar ,& + tstar ,fm ,fh ,fq ,rootfr ,& !Plant Hydraulic variables - kmax_sun,kmax_sha,kmax_xyl,kmax_root,psi50_sun,psi50_sha,& - psi50_xyl,psi50_root,ck ,vegwp ,gs0sun ,gs0sha ,& - assimsun,etrsun ,assimsha,etrsha ,& + kmax_sun ,kmax_sha ,kmax_xyl ,kmax_root ,psi50_sun ,psi50_sha ,& + psi50_xyl ,psi50_root,ck ,vegwp ,gs0sun ,gs0sha ,& + assimsun ,etrsun ,assimsha ,etrsha ,& !Ozone stress variables - o3coefv_sun ,o3coefv_sha ,o3coefg_sun ,o3coefg_sha, & - lai_old, o3uptakesun, o3uptakesha, forc_ozone,& + o3coefv_sun ,o3coefv_sha ,o3coefg_sun ,o3coefg_sha ,& + lai_old ,o3uptakesun ,o3uptakesha ,forc_ozone ,& !End ozone stress variables - hpbl, & - qintr_rain,qintr_snow,t_precip,hprl,smp ,hk ,& - hksati ,rootr ) + hpbl ,& + qintr_rain,qintr_snow,t_precip ,hprl ,smp ,hk ,& + hksati ,rootflux ) !======================================================================= ! !DESCRIPTION: @@ -71,11 +76,14 @@ SUBROUTINE LeafTemp(ipatch,ivt,deltim,csoilc,dewmx,htvp,lai ,& ! land surface modeling. Agricultural and Forest Meteorology, ! 269–270, 119–135. https://doi.org/10.1016/j.agrformet.2019.02.006 ! -! Hua Yuan, 10/2019: change leaf tempertature from two-leaf to one-leaf +! Hua Yuan, 10/2019: change only the leaf tempertature from two-leaf to one-leaf ! (due to large differences may exist btween sunlit/shaded ! leaf temperature. +! ! Xingjie Lu and Nan Wei, 01/2021: added plant hydraulic process interface +! ! Nan Wei, 01/2021: added interaction btw prec and canopy +! ! Shaofeng Liu, 05/2023: add option to call moninobuk_leddy, the LargeEddy ! surface turbulence scheme (LZD2022); ! make a proper update of um. @@ -85,29 +93,31 @@ SUBROUTINE LeafTemp(ipatch,ivt,deltim,csoilc,dewmx,htvp,lai ,& USE MOD_Vars_Global USE MOD_Const_Physical, only: vonkar, grav, hvap, cpair, stefnc, cpliq, cpice, tfrz USE MOD_FrictionVelocity + USE MOD_CanopyLayerProfile USE mod_namelist, only: DEF_USE_CBL_HEIGHT USE MOD_TurbulenceLEddy USE MOD_AssimStomataConductance USE MOD_Vars_TimeInvariants, only: patchclass USE MOD_Const_LC, only: z0mr, displar - USE MOD_PlantHydraulic, only : PlantHydraulicStress_twoleaf - use MOD_Ozone, only: CalcOzoneStress + USE MOD_PlantHydraulic, only :PlantHydraulicStress_twoleaf, getvegwp_twoleaf + USE MOD_Ozone, only: CalcOzoneStress USE MOD_Qsadv IMPLICIT NONE !-----------------------Arguments--------------------------------------- - INTEGER, intent(in) :: ipatch,ivt - REAL(r8), intent(in) :: & + integer, intent(in) :: ipatch,ivt + real(r8), intent(in) :: & deltim, &! seconds in a time step [second] csoilc, &! drag coefficient for soil under canopy [-] dewmx, &! maximum dew htvp ! latent heat of evaporation (/sublimation) [J/kg] ! vegetation parameters - REAL(r8), intent(in) :: & - sai, &! stem area index [-] + real(r8), intent(inout) :: & + sai ! stem area index [-] + real(r8), intent(in) :: & sqrtdi, &! inverse sqrt of leaf dimension [m**-0.5] htop, &! PFT crown top height [m] hbot, &! PFT crown bot height [m] @@ -122,26 +132,28 @@ SUBROUTINE LeafTemp(ipatch,ivt,deltim,csoilc,dewmx,htvp,lai ,& trda, &! temperature coefficient in gs-a model (s5) trdm, &! temperature coefficient in gs-a model (s6) trop, &! temperature coefficient in gs-a model (273+25) + g1, &! conductance-photosynthesis slope parameter for medlyn model + g0, &! conductance-photosynthesis intercept for medlyn model gradm, &! conductance-photosynthesis slope parameter binter, &! conductance-photosynthesis intercept extkn ! coefficient of leaf nitrogen allocation - REAL(r8), intent(in) :: & ! for plant hydraulic scheme - kmax_sun, & - kmax_sha, & - kmax_xyl, & - kmax_root, & + real(r8), intent(in) :: & ! for plant hydraulic scheme + kmax_sun, &! Plant Hydraulics Paramters + kmax_sha, &! Plant Hydraulics Paramters + kmax_xyl, &! Plant Hydraulics Paramters + kmax_root, &! Plant Hydraulics Paramters psi50_sun, &! water potential at 50% loss of sunlit leaf tissue conductance (mmH2O) psi50_sha, &! water potential at 50% loss of shaded leaf tissue conductance (mmH2O) psi50_xyl, &! water potential at 50% loss of xylem tissue conductance (mmH2O) psi50_root, &! water potential at 50% loss of root tissue conductance (mmH2O) ck ! shape-fitting parameter for vulnerability curve (-) - REAL(r8), intent(inout) :: & + real(r8), intent(inout) :: & vegwp(1:nvegwcs),&! vegetation water potential - gs0sun, &! - gs0sha ! + gs0sun, &! maximum stomata conductance of sunlit leaf + gs0sha ! maximum stomata conductance of shaded leaf ! input variables - REAL(r8), intent(in) :: & + real(r8), intent(in) :: & hu, &! observational height of wind [m] ht, &! observational height of temperature [m] hq, &! observational height of humidity [m] @@ -178,11 +190,16 @@ SUBROUTINE LeafTemp(ipatch,ivt,deltim,csoilc,dewmx,htvp,lai ,& sigf, &! fraction of veg cover, excluding snow-covered veg [-] etrc, &! maximum possible transpiration rate (mm/s) tg, &! ground surface temperature [K] + t_soil, &! ground surface soil temperature [K] + t_snow, &! ground surface snow temperature [K] qg, &! specific humidity at ground surface [kg/kg] + q_soil, &! specific humidity at ground soil surface [kg/kg] + q_snow, &! specific humidity at ground snow surface [kg/kg] dqgdT, &! temperature derivative of "qg" + rss, &! soil surface resistance [s/m] emg ! vegetation emissivity - REAL(r8), intent(in) :: & + real(r8), intent(in) :: & t_precip, &! snowfall/rainfall temperature [kelvin] qintr_rain, &! rainfall interception (mm h2o/s) qintr_snow, &! snowfall interception (mm h2o/s) @@ -190,14 +207,14 @@ SUBROUTINE LeafTemp(ipatch,ivt,deltim,csoilc,dewmx,htvp,lai ,& rootfr (1:nl_soil), &! root fraction hksati (1:nl_soil), &! hydraulic conductivity at saturation [mm h2o/s] hk (1:nl_soil) ! soil hydraulic conducatance - REAL(r8), intent(in) :: & - hpbl ! atmospheric boundary layer height [m] + real(r8), intent(in) :: & + hpbl ! atmospheric boundary layer height [m] - REAL(r8), intent(inout) :: & + real(r8), intent(inout) :: & tl, &! leaf temperature [K] ldew, &! depth of water on foliage [mm] - ldew_rain, &! depth of rain on foliage [mm] - ldew_snow, &! depth of snow on foliage [mm] + ldew_rain, &! depth of rain on foliage [mm] + ldew_snow, &! depth of snow on foliage [mm] !Ozone stress variables lai_old ,&! lai in last time step @@ -208,7 +225,11 @@ SUBROUTINE LeafTemp(ipatch,ivt,deltim,csoilc,dewmx,htvp,lai ,& taux, &! wind stress: E-W [kg/m/s**2] tauy, &! wind stress: N-S [kg/m/s**2] fseng, &! sensible heat flux from ground [W/m2] + fseng_soil, &! sensible heat flux from ground soil [W/m2] + fseng_snow, &! sensible heat flux from ground snow [W/m2] fevpg, &! evaporation heat flux from ground [mm/s] + fevpg_soil, &! evaporation heat flux from ground soil [mm/s] + fevpg_snow, &! evaporation heat flux from ground snow [mm/s] cgrnd, &! deriv. of soil energy flux wrt to soil temp [w/m2/k] cgrndl, &! deriv, of soil sensible heat flux wrt soil temp [w/m2/k] cgrnds, &! deriv of soil latent heat flux wrt soil temp [w/m**2/k] @@ -216,17 +237,17 @@ SUBROUTINE LeafTemp(ipatch,ivt,deltim,csoilc,dewmx,htvp,lai ,& qref, &! 2 m height air specific humidity rstfacsun, &! factor of soil water stress to transpiration on sunlit leaf rstfacsha, &! factor of soil water stress to transpiration on shaded leaf - gssun, & - gssha, & - rootr(1:nl_soil) ! fraction of root water uptake from different layers + gssun, &! stomata conductance of sunlit leaf + gssha, &! stomata conductance of shaded leaf + rootflux(1:nl_soil) ! root water uptake from different layers - REAL(r8), intent(inout) :: & + real(r8), intent(inout) :: & assimsun, &! sunlit leaf assimilation rate [umol co2 /m**2/ s] [+] - etrsun, & + etrsun, &! transpiration rate of sunlit leaf [mm/s] assimsha, &! shaded leaf assimilation rate [umol co2 /m**2/ s] [+] - etrsha + etrsha ! transpiration rate of shaded leaf [mm/s] - REAL(r8), intent(out) :: & + real(r8), intent(out) :: & rst, &! stomatal resistance assim, &! rate of assimilation respc, &! rate of respiration @@ -255,15 +276,15 @@ SUBROUTINE LeafTemp(ipatch,ivt,deltim,csoilc,dewmx,htvp,lai ,& !-----------------------Local Variables--------------------------------- ! assign iteration parameters - INTEGER, parameter :: itmax = 40 !maximum number of iteration - INTEGER, parameter :: itmin = 6 !minimum number of iteration - REAL(r8),parameter :: delmax = 3.0 !maximum change in leaf temperature [K] - REAL(r8),parameter :: dtmin = 0.01 !max limit for temperature convergence [K] - REAL(r8),parameter :: dlemin = 0.1 !max limit for energy flux convergence [w/m2] + integer, parameter :: itmax = 40 !maximum number of iteration + integer, parameter :: itmin = 6 !minimum number of iteration + real(r8),parameter :: delmax = 3.0 !maximum change in leaf temperature [K] + real(r8),parameter :: dtmin = 0.01 !max limit for temperature convergence [K] + real(r8),parameter :: dlemin = 0.1 !max limit for energy flux convergence [w/m2] - REAL(r8) dtl(0:itmax+1) !difference of tl between two iterative step + real(r8) dtl(0:itmax+1) !difference of tl between two iterative step - REAL(r8) :: & + real(r8) :: & displa, &! displacement height [m] zldis, &! reference height "minus" zero displacement heght [m] zii, &! convective boundary layer height [m] @@ -295,9 +316,8 @@ SUBROUTINE LeafTemp(ipatch,ivt,deltim,csoilc,dewmx,htvp,lai ,& fwet, &! fraction of foliage covered by water [-] cf, &! heat transfer coefficient from leaves [-] rb, &! leaf boundary layer resistance [s/m] - rbone, &! canopy bulk boundary layer resistance - rbsun, &! canopy bulk boundary layer resistance - rbsha, &! canopy bulk boundary layer resistance + rbsun, &! Sunlit leaf boundary layer resistance [s/m] + rbsha, &! Shaded leaf boundary layer resistance [s/m] rd, &! aerodynamical resistance between ground and canopy air ram, &! aerodynamical resistance [s/m] rah, &! thermal resistance [s/m] @@ -347,30 +367,30 @@ SUBROUTINE LeafTemp(ipatch,ivt,deltim,csoilc,dewmx,htvp,lai ,& gdh2o, &! conductance between canopy and ground tprcor ! tf*psur*100./1.013e5 - INTEGER it, nmozsgn + integer it, nmozsgn - REAL(r8) delta, fac - REAL(r8) evplwet, evplwet_dtl, etr_dtl, elwmax, elwdif,etr0 - REAL(r8) irab, dirab_dtl, fsenl_dtl, fevpl_dtl - REAL(r8) w, csoilcn, z0mg, cintsun(3), cintsha(3) - REAL(r8) fevpl_bef, fevpl_noadj, dtl_noadj, errt, erre + real(r8) delta, fac + real(r8) evplwet, evplwet_dtl, etr_dtl, elwmax, elwdif, etr0, sumrootr + real(r8) irab, dirab_dtl, fsenl_dtl, fevpl_dtl + real(r8) w, csoilcn, z0mg, cintsun(3), cintsha(3) + real(r8) fevpl_bef, fevpl_noadj, dtl_noadj, errt, erre - REAL(r8) lt, egvf + real(r8) lt, egvf - REAL(r8) :: sqrtdragc !sqrt(drag coefficient) - REAL(r8) :: fai !canopy frontal area index - REAL(r8) :: a_k71 !exponential extinction factor for u/k decline within canopy (Kondo 1971) - REAL(r8) :: fqt, fht, fmtop - REAL(r8) :: utop, ueff, ktop - REAL(r8) :: phih, z0qg, z0hg - REAL(r8) :: hsink, displasink - real(r8) gb_mol_sun,gb_mol_sha + real(r8) :: sqrtdragc !sqrt(drag coefficient) + real(r8) :: fai !canopy frontal area index + real(r8) :: a_k71 !exponential extinction factor for u/k decline within canopy (Kondo 1971) + real(r8) :: fqt, fht, fmtop + real(r8) :: utop, ueff, ktop + real(r8) :: phih, z0qg, z0hg + real(r8) :: hsink, displasink + real(r8) gb_mol real(r8),dimension(nl_soil) :: k_soil_root ! radial root and soil conductance real(r8),dimension(nl_soil) :: k_ax_root ! axial root conductance - INTEGER, parameter :: zd_opt = 3 - INTEGER, parameter :: rb_opt = 3 - INTEGER, parameter :: rd_opt = 3 + integer, parameter :: zd_opt = 3 ! z0 and d with vertical profile consideration + integer, parameter :: rb_opt = 3 ! rb with vertical profile consideration + integer, parameter :: rd_opt = 3 ! rd with vertical profile consideration !-----------------------End Variable List------------------------------- @@ -410,10 +430,9 @@ SUBROUTINE LeafTemp(ipatch,ivt,deltim,csoilc,dewmx,htvp,lai ,& !clai = 4.2 * 1000. * 0.2 clai = 0.0 - ! loop - CALL dewfraction (sigf,lai,sai,dewmx,ldew,ldew_rain,ldew_snow,fwet,fdry) - ! loop - CALL qsadv(tl,psrf,ei,deiDT,qsatl,qsatlDT) + CALL dewfraction (sigf,lai,sai,dewmx,ldew,ldew_rain,ldew_snow,fwet,fdry) + + CALL qsadv(tl,psrf,ei,deiDT,qsatl,qsatlDT) !----------------------------------------------------------------------- ! initial for fluxes profile @@ -421,7 +440,7 @@ SUBROUTINE LeafTemp(ipatch,ivt,deltim,csoilc,dewmx,htvp,lai ,& nmozsgn = 0 !number of times moz changes sign obuold = 0. !monin-obukhov length from previous iteration - zii = 1000. !m (pbl height) + zii = 1000. !m (pbl height) beta = 1. !- (in computing W_*) z0mg = (1.-fsno)*zlnd + fsno*zsno z0hg = z0mg @@ -441,7 +460,7 @@ SUBROUTINE LeafTemp(ipatch,ivt,deltim,csoilc,dewmx,htvp,lai ,& z0hv = z0mv z0qv = z0mv -! 10/17/2017, yuan: 3D z0m and displa +! 10/17/2017, yuan: z0m and displa with vertical profile solution IF (zd_opt == 3) THEN CALL cal_z0_displa(lai+sai, htop, 1., z0mv, displa) @@ -471,10 +490,10 @@ SUBROUTINE LeafTemp(ipatch,ivt,deltim,csoilc,dewmx,htvp,lai ,& ! rsoil = 5.22 * 1.e-6 rsoil = 0.22 * 1.e-6 - ur = max(0.1, sqrt(us*us+vs*vs)) !limit set to 0.1 + ur = max(0.1, sqrt(us*us+vs*vs)) !limit set to 0.1 dth = thm - taf - dqh = qm - qaf - dthv = dth*(1.+0.61*qm) + 0.61*th*dqh + dqh = qm - qaf + dthv = dth*(1.+0.61*qm) + 0.61*th*dqh zldis = hu - displa IF(zldis <= 0.0) THEN @@ -499,355 +518,409 @@ SUBROUTINE LeafTemp(ipatch,ivt,deltim,csoilc,dewmx,htvp,lai ,& ! Aerodynamical resistances !----------------------------------------------------------------------- ! Evaluate stability-dependent variables using moz from prior iteration - IF (rd_opt == 3) THEN - if (DEF_USE_CBL_HEIGHT) then - CALL moninobukm_leddy(hu,ht,hq,displa,z0mv,z0hv,z0qv,obu,um, & - displasink,z0mv, hpbl, ustar,fh2m,fq2m, & - htop,fmtop,fm,fh,fq,fht,fqt,phih) - else - CALL moninobukm(hu,ht,hq,displa,z0mv,z0hv,z0qv,obu,um, & - displasink,z0mv,ustar,fh2m,fq2m, & - htop,fmtop,fm,fh,fq,fht,fqt,phih) - endif - ! Aerodynamic resistance - ram = 1./(ustar*ustar/um) - rah = 1./(vonkar/(fh-fht)*ustar) - raw = 1./(vonkar/(fq-fqt)*ustar) - ELSE - if (DEF_USE_CBL_HEIGHT) then - CALL moninobuk_leddy(hu,ht,hq,displa,z0mv,z0hv,z0qv,obu,um, hpbl, & - ustar,fh2m,fq2m,fm10m,fm,fh,fq) - else - CALL moninobuk(hu,ht,hq,displa,z0mv,z0hv,z0qv,obu,um,& - ustar,fh2m,fq2m,fm10m,fm,fh,fq) - endif - ! Aerodynamic resistance - ram = 1./(ustar*ustar/um) - rah = 1./(vonkar/fh*ustar) - raw = 1./(vonkar/fq*ustar) - ENDIF - - z0hg = z0mg/exp(0.13 * (ustar*z0mg/1.5e-5)**0.45) - z0qg = z0hg + IF (rd_opt == 3) THEN + IF (DEF_USE_CBL_HEIGHT) THEN + CALL moninobukm_leddy(hu,ht,hq,displa,z0mv,z0hv,z0qv,obu,um, & + displasink,z0mv,hpbl,ustar,fh2m,fq2m, & + htop,fmtop,fm,fh,fq,fht,fqt,phih) + ELSE + CALL moninobukm(hu,ht,hq,displa,z0mv,z0hv,z0qv,obu,um, & + displasink,z0mv,ustar,fh2m,fq2m, & + htop,fmtop,fm,fh,fq,fht,fqt,phih) + ENDIF + ! Aerodynamic resistance + ram = 1./(ustar*ustar/um) + rah = 1./(vonkar/(fh-fht)*ustar) + raw = 1./(vonkar/(fq-fqt)*ustar) + ELSE + IF (DEF_USE_CBL_HEIGHT) THEN + CALL moninobuk_leddy(hu,ht,hq,displa,z0mv,z0hv,z0qv,obu,um,hpbl, & + ustar,fh2m,fq2m,fm10m,fm,fh,fq) + ELSE + CALL moninobuk(hu,ht,hq,displa,z0mv,z0hv,z0qv,obu,um,& + ustar,fh2m,fq2m,fm10m,fm,fh,fq) + ENDIF + ! Aerodynamic resistance + ram = 1./(ustar*ustar/um) + rah = 1./(vonkar/fh*ustar) + raw = 1./(vonkar/fq*ustar) + ENDIF + + z0hg = z0mg/exp(0.13 * (ustar*z0mg/1.5e-5)**0.45) + z0qg = z0hg ! Bulk boundary layer resistance of leaves - uaf = ustar - cf = 0.01*sqrtdi/sqrt(uaf) - rb = 1/(cf*uaf) + uaf = ustar + cf = 0.01*sqrtdi/sqrt(uaf) + rb = 1/(cf*uaf) -! 11/17/2017, yuan: 3D rb calculation +! 11/17/2017, yuan: 3D rb calculation (with vertical profile consideration) ! 03/13/2020, yuan: added analytical solution - IF (rb_opt == 3) THEN - utop = ustar/vonkar * fmtop - ueff = ueffect(utop, htop, z0mg, z0mg, a_k71, 1._r8, 1._r8) - cf = 0.01*sqrtdi*sqrt(ueff) - rb = 1./cf - ENDIF - - ! rd = 1./(csoilc*uaf) ! BATS legacy - ! w = exp(-0.5*(lai+sai)) ! Dickinson's modification : - ! csoilc = ( 1.-w + w*um/uaf)/rah ! "rah" here is the resistance over - ! rd = 1./(csoilc*uaf) ! bare ground fraction + IF (rb_opt == 3) THEN + utop = ustar/vonkar * fmtop + ueff = ueffect(utop, htop, z0mg, z0mg, a_k71, 1._r8, 1._r8) + cf = 0.01*sqrtdi*sqrt(ueff) + rb = 1./cf + ENDIF + +! rd = 1./(csoilc*uaf) ! BATS legacy +! w = exp(-0.5*(lai+sai)) ! Dickinson's modification : +! csoilc = ( 1.-w + w*um/uaf)/rah ! "rah" here is the resistance over +! rd = 1./(csoilc*uaf) ! bare ground fraction ! modified by Xubin Zeng's suggestion at 08-07-2002 - w = exp(-(lai+sai)) - csoilcn = (vonkar/(0.13*(z0mg*uaf/1.5e-5)**0.45))*w + csoilc*(1.-w) - rd = 1./(csoilcn*uaf) + w = exp(-(lai+sai)) + csoilcn = (vonkar/(0.13*(z0mg*uaf/1.5e-5)**0.45))*w + csoilc*(1.-w) + rd = 1./(csoilcn*uaf) -! 11/17/2017, yuan: 3D rd calculation +! 11/17/2017, yuan: 3D rd calculation with vertical profile solution ! 03/13/2020, yuan: added analytical solution - IF (rd_opt == 3) THEN - ktop = vonkar * (htop-displa) * ustar / phih - rd = frd(ktop, htop, z0qg, hsink, z0qg, displa/htop, & - z0qg, obug, ustar, z0mg, a_k71, 1._r8, 1._r8) - ENDIF + IF (rd_opt == 3) THEN + ktop = vonkar * (htop-displa) * ustar / phih + rd = frd(ktop, htop, z0qg, hsink, z0qg, displa/htop, & + z0qg, obug, ustar, z0mg, a_k71, 1._r8, 1._r8) + ENDIF !----------------------------------------------------------------------- ! stomatal resistances !----------------------------------------------------------------------- - IF(lai .gt. 0.001) THEN - - rbsun = rb / laisun - rbsha = rb / laisha - - eah = qaf * psrf / ( 0.622 + 0.378 * qaf ) !pa - - if(DEF_USE_PLANTHYDRAULICS) then - call PlantHydraulicStress_twoleaf (nl_soil ,nvegwcs ,z_soi ,& - dz_soi ,rootfr ,psrf ,qsatl ,qsatl ,& - qaf ,tl ,tl ,rbsun ,rbsha ,& - raw ,rd ,rstfacsun ,rstfacsha ,cintsun ,& - cintsha ,laisun ,laisha ,rhoair ,fwet ,& - sai ,kmax_sun ,kmax_sha ,kmax_xyl ,kmax_root ,& - psi50_sun ,psi50_sha ,psi50_xyl ,psi50_root ,htop ,& - ck ,smp ,hk ,hksati ,vegwp ,& - etrsun ,etrsha ,rootr ,sigf ,qg ,& - qm ,gs0sun ,gs0sha ,k_soil_root,k_ax_root ) - etr = etrsun + etrsha - end if - -! Sunlit leaves - CALL stomata (vmax25 ,effcon ,slti ,hlti ,& - shti ,hhti ,trda ,trdm ,trop ,& - gradm ,binter ,thm ,psrf ,po2m ,& - pco2m ,pco2a ,eah ,ei ,tl , parsun ,& -!Ozone stress variables - o3coefv_sun ,o3coefg_sun, & -!End ozone stress variables - rbsun ,raw ,rstfacsun ,cintsun ,& - assimsun ,respcsun ,rssun & - ) - -! Shaded leaves - CALL stomata (vmax25 ,effcon ,slti ,hlti ,& - shti ,hhti ,trda ,trdm ,trop ,& - gradm ,binter ,thm ,psrf ,po2m ,& - pco2m ,pco2a ,eah ,ei ,tl , parsha ,& -!Ozone stress variables - o3coefv_sha ,o3coefg_sha, & -!End ozone stress variables - rbsha ,raw ,rstfacsha ,cintsha ,& - assimsha ,respcsha ,rssha & - ) - - gssun = min( 1.e6, 1./(rssun*tl/tprcor) ) / cintsun(3) * 1.e6 - gssha = min( 1.e6, 1./(rssha*tl/tprcor) ) / cintsha(3) * 1.e6 - if(DEF_USE_PLANTHYDRAULICS) then - gs0sun = gssun/amax1(rstfacsun,1.e-2) - gs0sha = gssha/amax1(rstfacsha,1.e-2) - - gb_mol_sun = 1./rbsun * tprcor/tl / cintsun(3) * 1.e6 ! leaf to canopy - gb_mol_sha = 1./rbsha * tprcor/tl / cintsha(3) * 1.e6 ! leaf to canopy - end if - ELSE - rssun = 2.e4; assimsun = 0.; respcsun = 0. - rssha = 2.e4; assimsha = 0.; respcsha = 0. - gssun = 0._r8 - gssha = 0._r8 - - ! 07/2023, yuan: a bug for imbalanced water, rootr only change - ! in DEF_USE_PLANTHYDRAULICS case in this routine. - if(DEF_USE_PLANTHYDRAULICS) then - etr = 0. - etrsun = 0._r8 - etrsha = 0._r8 - rootr = 0. - ENDIF - ENDIF + IF(lai .gt. 0.001) THEN + + eah = qaf * psrf / ( 0.622 + 0.378 * qaf ) !pa + + ! If use PHS, calculate maximum stomata conductance (minimum stomata resistance) + ! by setting rstfac = 1. (no water stress). When use PHS, stomata only calculate + ! non-stress stomata conductance, assimilation rate and leaf respiration + IF (DEF_USE_PLANTHYDRAULICS) THEN + rstfacsun = 1. + rstfacsha = 1. + ENDIF + + ! leaf to canopy level + rbsun = rb / laisun + rbsha = rb / laisha + + ! Sunlit leaves + CALL stomata (vmax25 ,effcon ,slti ,hlti ,& + shti ,hhti ,trda ,trdm ,trop ,& + g1 ,g0 ,gradm ,binter ,thm ,& + psrf ,po2m ,pco2m ,pco2a ,eah ,& + ei ,tl ,parsun ,& + !Ozone stress variables + o3coefv_sun ,o3coefg_sun ,& + !End ozone stress variables + rbsun ,raw ,rstfacsun,cintsun ,& + assimsun ,respcsun ,rssun ) + + ! Shaded leaves + CALL stomata (vmax25 ,effcon ,slti ,hlti ,& + shti ,hhti ,trda ,trdm ,trop ,& + g1 ,g0 ,gradm ,binter ,thm ,& + psrf ,po2m ,pco2m ,pco2a ,eah ,& + ei ,tl ,parsha ,& + ! Ozone stress variables + o3coefv_sha ,o3coefg_sha ,& + ! End ozone stress variables + rbsha ,raw ,rstfacsha,cintsha ,& + assimsha ,respcsha ,rssha ) + + IF (DEF_USE_PLANTHYDRAULICS) THEN + + gs0sun = min( 1.e6, 1./(rssun*tl/tprcor) )/ laisun * 1.e6 + gs0sha = min( 1.e6, 1./(rssha*tl/tprcor) )/ laisha * 1.e6 + + sai = amax1(sai,0.1) + ! PHS update actual stomata conductance (resistance), assimilation rate + ! and leaf respiration. above stomatal resistances are for the canopy, + ! the stomatal rsistances and the "rb" in the following calculations are + ! the average for single leaf. thus, + CALL PlantHydraulicStress_twoleaf ( nl_soil ,nvegwcs ,& + z_soi ,dz_soi ,rootfr ,psrf ,qsatl ,& + qaf ,tl ,rb ,rss ,raw ,& + rd ,rstfacsun ,rstfacsha ,cintsun ,cintsha ,& + laisun ,laisha ,rhoair ,fwet ,sai ,& + kmax_sun ,kmax_sha ,kmax_xyl ,kmax_root ,psi50_sun ,& + psi50_sha ,psi50_xyl ,psi50_root ,htop ,ck ,& + smp ,hk ,hksati ,vegwp ,etrsun ,& + etrsha ,rootflux ,qg ,qm ,gs0sun ,& + gs0sha ,k_soil_root,k_ax_root ,gssun ,gssha ) + + etr = etrsun + etrsha + gssun = gssun * laisun + gssha = gssha * laisha + + call update_photosyn(tl, po2m, pco2m, pco2a, parsun, psrf, rstfacsun, rb, gssun, & + effcon, vmax25, gradm, trop, slti, hlti, shti, hhti, trda, trdm, cintsun, & + assimsun, respcsun) + + CALL update_photosyn(tl, po2m, pco2m, pco2a, parsha, psrf, rstfacsha, rb, gssha, & + effcon, vmax25, gradm, trop, slti, hlti, shti, hhti, trda, trdm, cintsha, & + assimsha, respcsha) + + rssun = tprcor/tl * 1.e6 / gssun + rssha = tprcor/tl * 1.e6 / gssha + ENDIF + + ELSE + rssun = 2.e20; assimsun = 0.; respcsun = 0. + rssha = 2.e20; assimsha = 0.; respcsha = 0. + gssun = 0._r8 + gssha = 0._r8 + + ! 07/2023, yuan: a bug for imbalanced water, rootflux only change + ! in DEF_USE_PLANTHYDRAULICS case in this routine. + IF (DEF_USE_PLANTHYDRAULICS) THEN + etr = 0. + etrsun = 0._r8 + etrsha = 0._r8 + rootflux = 0. + ENDIF + ENDIF ! above stomatal resistances are for the canopy, the stomatal rsistances ! and the "rb" in the following calculations are the average for single leaf. thus, - rssun = rssun * laisun - rssha = rssha * laisha + rssun = rssun * laisun + rssha = rssha * laisha !----------------------------------------------------------------------- ! dimensional and non-dimensional sensible and latent heat conductances ! for canopy and soil flux calculations. !----------------------------------------------------------------------- - delta = 0.0 - IF(qsatl-qaf .gt. 0.) delta = 1.0 - - cah = 1. / rah - cgh = 1. / rd - cfh = (lai + sai) / rb - - caw = 1. / raw - cgw = 1. / rd - cfw = (1.-delta*(1.-fwet))*(lai+sai)/rb + (1.-fwet)*delta* & - ( laisun/(rb+rssun) + laisha/(rb+rssha) ) - - wtshi = 1. / ( cah + cgh + cfh ) - wtsqi = 1. / ( caw + cgw + cfw ) - - wta0 = cah * wtshi - wtg0 = cgh * wtshi - wtl0 = cfh * wtshi - - wtaq0 = caw * wtsqi - wtgq0 = cgw * wtsqi - wtlq0 = cfw * wtsqi + delta = 0.0 + IF(qsatl-qaf .gt. 0.) delta = 1.0 + + cah = 1. / rah + cgh = 1. / rd + cfh = (lai + sai) / rb + + caw = 1. / raw + IF (qg < qaf) THEN + cgw = 1. / rd !dew case. no soil resistance + ELSE + IF (DEF_RSS_SCHEME .eq. 4) THEN + cgw = rss / rd + ELSE + cgw = 1. / (rd + rss) + ENDIF + ENDIF + cfw = (1.-delta*(1.-fwet))*(lai+sai)/rb + (1.-fwet)*delta* & + ( laisun/(rb+rssun) + laisha/(rb+rssha) ) + + wtshi = 1. / ( cah + cgh + cfh ) + wtsqi = 1. / ( caw + cgw + cfw ) + + wta0 = cah * wtshi + wtg0 = cgh * wtshi + wtl0 = cfh * wtshi + + wtaq0 = caw * wtsqi + wtgq0 = cgw * wtsqi + wtlq0 = cfw * wtsqi !----------------------------------------------------------------------- ! IR radiation, sensible and latent heat fluxes and their derivatives !----------------------------------------------------------------------- ! the partial derivatives of areodynamical resistance are ignored ! which cannot be determined analtically - fac = 1. - thermk + fac = 1. - thermk ! longwave absorption and their derivatives - ! 10/16/2017, yuan: added reflected longwave by the ground - irab = (frl - 2. * stefnc * tl**4 + emg*stefnc*tg**4 ) * fac & - + (1-emg)*thermk*fac*frl + (1-emg)*(1-thermk)*fac*stefnc*tl**4 - dirab_dtl = - 8. * stefnc * tl**3 * fac & - + 4.*(1-emg)*(1-thermk)*fac*stefnc*tl**3 + ! 10/16/2017, yuan: added reflected longwave by the ground + +IF (.not.DEF_SPLIT_SOILSNOW) THEN + irab = (frl - 2. * stefnc * tl**4 + emg*stefnc*tg**4 ) * fac & + + (1-emg)*thermk*fac*frl + (1-emg)*(1-thermk)*fac*stefnc*tl**4 +ELSE + irab = (frl - 2. * stefnc * tl**4 & + + (1.-fsno)*emg*stefnc*t_soil**4 & + + fsno*emg*stefnc*t_snow**4 ) * fac & + + (1-emg)*thermk*fac*frl + (1-emg)*(1-thermk)*fac*stefnc*tl**4 +ENDIF + dirab_dtl = - 8. * stefnc * tl**3 * fac & + + 4.*(1-emg)*(1-thermk)*fac*stefnc*tl**3 ! sensible heat fluxes and their derivatives - fsenl = rhoair * cpair * cfh * ( (wta0 + wtg0)*tl - wta0*thm - wtg0*tg ) - fsenl_dtl = rhoair * cpair * cfh * (wta0 + wtg0) + fsenl = rhoair * cpair * cfh * ( (wta0 + wtg0)*tl - wta0*thm - wtg0*tg ) + fsenl_dtl = rhoair * cpair * cfh * (wta0 + wtg0) ! latent heat fluxes and their derivatives - etr = rhoair * (1.-fwet) * delta & - * ( laisun/(rb+rssun) + laisha/(rb+rssha) ) & - * ( (wtaq0 + wtgq0)*qsatl - wtaq0*qm - wtgq0*qg ) - !NOTE, yuan: need some revision below. if undef PHS and WUEdiag, there may be problem. - etrsun = rhoair * (1.-fwet) * delta & - * ( laisun/(rb+rssun) ) * ( (wtaq0 + wtgq0)*qsatl - wtaq0*qm - wtgq0*qg ) - etrsha = rhoair * (1.-fwet) * delta & - * ( laisha/(rb+rssha) ) * ( (wtaq0 + wtgq0)*qsatl - wtaq0*qm - wtgq0*qg ) - - etr_dtl = rhoair * (1.-fwet) * delta & - * ( laisun/(rb+rssun) + laisha/(rb+rssha) ) & - * (wtaq0 + wtgq0)*qsatlDT - - if(.not. DEF_USE_PLANTHYDRAULICS)then - IF(etr.ge.etrc)THEN - etr = etrc - etr_dtl = 0. - ENDIF - end if - - evplwet = rhoair * (1.-delta*(1.-fwet)) * (lai+sai) / rb & - * ( (wtaq0 + wtgq0)*qsatl - wtaq0*qm - wtgq0*qg ) - evplwet_dtl = rhoair * (1.-delta*(1.-fwet)) * (lai+sai) / rb & - * (wtaq0 + wtgq0)*qsatlDT - IF(evplwet.ge.ldew/deltim)THEN - evplwet = ldew/deltim - evplwet_dtl = 0. - ENDIF - - fevpl = etr + evplwet - fevpl_dtl = etr_dtl + evplwet_dtl - - ! 07/09/2014, yuan: added for energy balance - erre = 0. - fevpl_noadj = fevpl - IF ( fevpl*fevpl_bef < 0. ) THEN - erre = -0.9*fevpl - fevpl = 0.1*fevpl - ENDIF + etr = rhoair * (1.-fwet) * delta & + * ( laisun/(rb+rssun) + laisha/(rb+rssha) ) & + * ( (wtaq0 + wtgq0)*qsatl - wtaq0*qm - wtgq0*qg ) + + etrsun = rhoair * (1.-fwet) * delta & + * ( laisun/(rb+rssun) ) * ( (wtaq0 + wtgq0)*qsatl - wtaq0*qm - wtgq0*qg ) + etrsha = rhoair * (1.-fwet) * delta & + * ( laisha/(rb+rssha) ) * ( (wtaq0 + wtgq0)*qsatl - wtaq0*qm - wtgq0*qg ) + + etr_dtl = rhoair * (1.-fwet) * delta & + * ( laisun/(rb+rssun) + laisha/(rb+rssha) ) & + * (wtaq0 + wtgq0)*qsatlDT + + IF (.not. DEF_USE_PLANTHYDRAULICS) THEN + IF(etr.ge.etrc)THEN + etr = etrc + etr_dtl = 0. + ENDIF + ELSE + IF(rstfacsun .lt. 1.e-2 .or. etrsun .le. 0.)etrsun = 0._r8 + IF(rstfacsha .lt. 1.e-2 .or. etrsha .le. 0.)etrsha = 0._r8 + etr = etrsun + etrsha + IF(abs(etr - sum(rootflux)) .gt. 1.e-7)THEN + write(6,*) 'Warning: water balance violation in vegetation PHS', & + ipatch,p_iam_glb, etr, sum(rootflux), abs(etr-sum(rootflux)) + CALL CoLM_stop() + ENDIF + ENDIF + + evplwet = rhoair * (1.-delta*(1.-fwet)) * (lai+sai) / rb & + * ( (wtaq0 + wtgq0)*qsatl - wtaq0*qm - wtgq0*qg ) + evplwet_dtl = rhoair * (1.-delta*(1.-fwet)) * (lai+sai) / rb & + * (wtaq0 + wtgq0)*qsatlDT + + IF(evplwet.ge.ldew/deltim)THEN + evplwet = ldew/deltim + evplwet_dtl = 0. + ENDIF + + fevpl = etr + evplwet + fevpl_dtl = etr_dtl + evplwet_dtl + + ! 07/09/2014, yuan: added for energy balance + erre = 0. + fevpl_noadj = fevpl + IF ( fevpl*fevpl_bef < 0. ) THEN + erre = -0.9*fevpl + fevpl = 0.1*fevpl + ENDIF !----------------------------------------------------------------------- ! difference of temperatures by quasi-newton-raphson method for the non-linear system equations !----------------------------------------------------------------------- - dtl(it) = (sabv + irab - fsenl - hvap*fevpl & - + cpliq*qintr_rain*(t_precip-tl) + cpice*qintr_snow*(t_precip-tl)) & - / ((lai+sai)*clai/deltim - dirab_dtl + fsenl_dtl + hvap*fevpl_dtl & - + cpliq*qintr_rain + cpice*qintr_snow) - dtl_noadj = dtl(it) + dtl(it) = (sabv + irab - fsenl - hvap*fevpl & + + cpliq*qintr_rain*(t_precip-tl) + cpice*qintr_snow*(t_precip-tl)) & + / ((lai+sai)*clai/deltim - dirab_dtl + fsenl_dtl + hvap*fevpl_dtl & + + cpliq*qintr_rain + cpice*qintr_snow) - ! check magnitude of change in leaf temperature limit to maximum allowed value + dtl_noadj = dtl(it) - ! 06/12/2014, yuan: .lt. -> .le. - IF(it .le. itmax) THEN + ! check magnitude of change in leaf temperature limit to maximum allowed value - ! put brakes on large temperature excursions - IF(abs(dtl(it)).gt.delmax)THEN - dtl(it) = delmax*dtl(it)/abs(dtl(it)) - ENDIF + ! 06/12/2014, yuan: .lt. -> .le. + IF(it .le. itmax) THEN + + ! put brakes on large temperature excursions + IF(abs(dtl(it)).gt.delmax)THEN + dtl(it) = delmax*dtl(it)/abs(dtl(it)) + ENDIF - ! 06/12/2014, yuan: .lt. -> .le. - ! NOTE: could be a bug IF dtl*dtl==0, changed from lt->le - IF((it.ge.2) .and. (dtl(it-1)*dtl(it).le.0.))THEN - dtl(it) = 0.5*(dtl(it-1) + dtl(it)) - ENDIF + ! 06/12/2014, yuan: .lt. -> .le. + ! NOTE: could be a bug IF dtl*dtl==0, changed from lt->le + IF((it.ge.2) .and. (dtl(it-1)*dtl(it).le.0.))THEN + dtl(it) = 0.5*(dtl(it-1) + dtl(it)) + ENDIF - ENDIF + ENDIF - tl = tlbef + dtl(it) + tl = tlbef + dtl(it) !----------------------------------------------------------------------- ! square roots differences of temperatures and fluxes for use as the condition of convergences !----------------------------------------------------------------------- - del = sqrt( dtl(it)*dtl(it) ) - dele = dtl(it) * dtl(it) * ( dirab_dtl**2 + fsenl_dtl**2 + hvap*fevpl_dtl**2 ) - dele = sqrt(dele) + del = sqrt( dtl(it)*dtl(it) ) + dele = dtl(it) * dtl(it) * ( dirab_dtl**2 + fsenl_dtl**2 + hvap*fevpl_dtl**2 ) + dele = sqrt(dele) !----------------------------------------------------------------------- ! saturated vapor pressures and canopy air temperature, canopy air humidity !----------------------------------------------------------------------- ! Recalculate leaf saturated vapor pressure (ei_)for updated leaf temperature ! and adjust specific humidity (qsatl_) proportionately - CALL qsadv(tl,psrf,ei,deiDT,qsatl,qsatlDT) + CALL qsadv(tl,psrf,ei,deiDT,qsatl,qsatlDT) ! update vegetation/ground surface temperature, canopy air temperature, ! canopy air humidity - taf = wta0*thm + wtg0*tg + wtl0*tl - - qaf = wtaq0*qm + wtgq0*qg + wtlq0*qsatl + taf = wta0*thm + wtg0*tg + wtl0*tl + qaf = wtaq0*qm + wtgq0*qg + wtlq0*qsatl ! update co2 partial pressure within canopy air - gah2o = 1.0/raw * tprcor/thm !mol m-2 s-1 - gdh2o = 1.0/rd * tprcor/thm !mol m-2 s-1 - pco2a = pco2m - 1.37*psrf/max(0.446,gah2o) * & - (assimsun + assimsha - respcsun -respcsha - rsoil) + gah2o = 1.0/raw * tprcor/thm !mol m-2 s-1 + IF (DEF_RSS_SCHEME .eq. 4) THEN + gdh2o = rss/rd * tprcor/thm !mol m-2 s-1 + ELSE + gdh2o = 1.0/(rd+rss) * tprcor/thm !mol m-2 s-1 + ENDIF + pco2a = pco2m - 1.37*psrf/max(0.446,gah2o) * & + (assimsun + assimsha - respcsun -respcsha - rsoil) !----------------------------------------------------------------------- ! Update monin-obukhov length and wind speed including the stability effect !----------------------------------------------------------------------- - dth = thm - taf - dqh = qm - qaf - - tstar = vonkar/(fh-fht)*dth - qstar = vonkar/(fq-fqt)*dqh - - thvstar = tstar*(1.+0.61*qm)+0.61*th*qstar - zeta = zldis*vonkar*grav*thvstar / (ustar**2*thv) - IF(zeta .ge. 0.)THEN !stable - zeta = min(2.,max(zeta,1.e-6)) - ELSE !unstable - zeta = max(-100.,min(zeta,-1.e-6)) - ENDIF - obu = zldis/zeta - - IF(zeta .ge. 0.)THEN - um = max(ur,.1) - ELSE - if (DEF_USE_CBL_HEIGHT) then !//TODO: Shaofeng, 2023.05.18 - zii = max(5.*hu,hpbl) - endif !//TODO: Shaofeng, 2023.05.18 - wc = (-grav*ustar*thvstar*zii/thv)**(1./3.) - wc2 = beta*beta*(wc*wc) - um = sqrt(ur*ur+wc2) - ENDIF - - IF(obuold*obu .lt. 0.) nmozsgn = nmozsgn+1 - IF(nmozsgn .ge. 4) obu = zldis/(-0.01) - obuold = obu + dth = thm - taf + dqh = qm - qaf + + tstar = vonkar/(fh-fht)*dth + qstar = vonkar/(fq-fqt)*dqh + + thvstar = tstar*(1.+0.61*qm)+0.61*th*qstar + zeta = zldis*vonkar*grav*thvstar / (ustar**2*thv) + IF(zeta .ge. 0.)THEN !stable + zeta = min(2.,max(zeta,1.e-6)) + ELSE !unstable + zeta = max(-100.,min(zeta,-1.e-6)) + ENDIF + obu = zldis/zeta + + IF(zeta .ge. 0.)THEN + um = max(ur,.1) + ELSE + IF (DEF_USE_CBL_HEIGHT) THEN !//TODO: Shaofeng, 2023.05.18 + zii = max(5.*hu,hpbl) + ENDIF !//TODO: Shaofeng, 2023.05.18 + wc = (-grav*ustar*thvstar*zii/thv)**(1./3.) + wc2 = beta*beta*(wc*wc) + um = sqrt(ur*ur+wc2) + ENDIF + + IF(obuold*obu .lt. 0.) nmozsgn = nmozsgn+1 + IF(nmozsgn .ge. 4) obu = zldis/(-0.01) + obuold = obu !----------------------------------------------------------------------- ! Test for convergence !----------------------------------------------------------------------- - it = it+1 + it = it+1 - IF(it .gt. itmin) THEN - fevpl_bef = fevpl - det = max(del,del2) - ! 10/03/2017, yuan: possible bugs here, solution: - ! define dee, change del => dee - dee = max(dele,dele2) - IF(det .lt. dtmin .and. dee .lt. dlemin) exit - ENDIF + IF(it .gt. itmin) THEN + fevpl_bef = fevpl + det = max(del,del2) + ! 10/03/2017, yuan: possible bugs here, solution: + ! define dee, change del => dee + dee = max(dele,dele2) + IF(det .lt. dtmin .and. dee .lt. dlemin) EXIT + ENDIF ENDDO IF(DEF_USE_OZONESTRESS)THEN - call CalcOzoneStress(o3coefv_sun,o3coefg_sun,forc_ozone,psrf,th,ram,& - rssun,rbsun,lai,lai_old,ivt,o3uptakesun,deltim) - call CalcOzoneStress(o3coefv_sha,o3coefg_sha,forc_ozone,psrf,th,ram,& - rssha,rbsha,lai,lai_old,ivt,o3uptakesha,deltim) + CALL CalcOzoneStress(o3coefv_sun,o3coefg_sun,forc_ozone,psrf,th,ram,& + rssun,rb,lai,lai_old,ivt,o3uptakesun,deltim) + CALL CalcOzoneStress(o3coefv_sha,o3coefg_sha,forc_ozone,psrf,th,ram,& + rssha,rb,lai,lai_old,ivt,o3uptakesha,deltim) lai_old = lai assimsun = assimsun * o3coefv_sun assimsha = assimsha * o3coefv_sha rssun = rssun / o3coefg_sun rssha = rssha / o3coefg_sha ENDIF + ! ====================================================================== ! END stability iteration ! ====================================================================== @@ -871,20 +944,33 @@ SUBROUTINE LeafTemp(ipatch,ivt,deltim,csoilc,dewmx,htvp,lai ,& ! canopy fluxes and total assimilation amd respiration fsenl = fsenl + fsenl_dtl*dtl(it-1) & - ! yuan: add the imbalanced energy below due to T adjustment to sensibel heat - + (dtl_noadj-dtl(it-1)) * ((lai+sai)*clai/deltim - dirab_dtl + fsenl_dtl + hvap*fevpl_dtl & - + cpliq * qintr_rain + cpice * qintr_snow) & - ! yuan: add the imbalanced energy below due to q adjustment to sensibel heat - + hvap*erre - etr0 = etr - etr = etr + etr_dtl*dtl(it-1) - if(DEF_USE_PLANTHYDRAULICS) then - if(abs(etr0) .ge. 1.e-15)then - rootr = rootr * etr / etr0 - else - rootr = rootr + dz_soi / sum(dz_soi) * etr_dtl* dtl(it-1) - end if - end if + ! yuan: add the imbalanced energy below due to T adjustment to sensibel heat + + (dtl_noadj-dtl(it-1)) * ((lai+sai)*clai/deltim - dirab_dtl + fsenl_dtl + hvap*fevpl_dtl & + + cpliq * qintr_rain + cpice * qintr_snow) & + ! yuan: add the imbalanced energy below due to q adjustment to sensibel heat + + hvap*erre + + etr0 = etr + etr = etr + etr_dtl*dtl(it-1) + + IF (DEF_USE_PLANTHYDRAULICS) THEN + !TODO@yuan: rootflux may not be consistent with etr, + ! water imbalance could happen. + IF (abs(etr0) .ge. 1.e-15) THEN + rootflux = rootflux * etr / etr0 + ELSE + rootflux = rootflux + dz_soi / sum(dz_soi) * etr_dtl* dtl(it-1) + ENDIF + +! !NOTE: temporal solution to make etr and rootflux consistent. +! !TODO: need double check +! sumrootr = sum(rootr(:), rootr(:)>0.) +! IF (abs(sumrootr) > 0.) THEN +! rootr(:) = max(rootr(:),0.) * (etr/sumrootr) +! ELSE +! rootr(:) = etr*rootfr(:) +! ENDIF + ENDIF evplwet = evplwet + evplwet_dtl*dtl(it-1) fevpl = fevpl_noadj @@ -905,7 +991,16 @@ SUBROUTINE LeafTemp(ipatch,ivt,deltim,csoilc,dewmx,htvp,lai ,& !----------------------------------------------------------------------- fseng = cpair*rhoair*cgh*(tg-taf) +! 03/07/2020, yuan: calculate fseng_soil/snow + !NOTE: taf = wta0*thm + wtg0*tg + wtl0*tl + fseng_soil = cpair*rhoair*cgh*((1.-wtg0)*t_soil - wta0*thm - wtl0*tl) + fseng_snow = cpair*rhoair*cgh*((1.-wtg0)*t_snow - wta0*thm - wtl0*tl) + +! 03/07/2020, yuan: calculate fevpg_soil/snow + !NOTE: qaf = wtaq0*qm + wtgq0*qg + wtlq0*qsatl fevpg = rhoair*cgw*(qg-qaf) + fevpg_soil = rhoair*cgw*((1.-wtgq0)*q_soil - wtaq0*qm - wtlq0*qsatl) + fevpg_snow = rhoair*cgw*((1.-wtgq0)*q_snow - wtaq0*qm - wtlq0*qsatl) !----------------------------------------------------------------------- ! downward (upward) longwave radiation below (above) the canopy and prec. sensible heat @@ -914,11 +1009,21 @@ SUBROUTINE LeafTemp(ipatch,ivt,deltim,csoilc,dewmx,htvp,lai ,& ! 10/16/2017, yuan: added reflected longwave by the ground dlrad = thermk * frl & + stefnc * fac * tlbef**3 * (tlbef + 4.*dtl(it-1)) + +IF (.not.DEF_SPLIT_SOILSNOW) THEN ulrad = stefnc * ( fac * tlbef**3 * (tlbef + 4.*dtl(it-1)) & + thermk*emg*tg**4 ) & + (1-emg)*thermk*thermk*frl & + (1-emg)*thermk*fac*stefnc*tlbef**4 & + 4.*(1-emg)*thermk*fac*stefnc*tlbef**3*dtl(it-1) +ELSE + ulrad = stefnc * ( fac * tlbef**3 * (tlbef + 4.*dtl(it-1)) & + + (1.-fsno)*thermk*emg*t_soil**4 & + + fsno*thermk*emg*t_snow**4 ) & + + (1-emg)*thermk*thermk*frl & + + (1-emg)*thermk*fac*stefnc*tlbef**4 & + + 4.*(1-emg)*thermk*fac*stefnc*tlbef**3*dtl(it-1) +ENDIF hprl = cpliq * qintr_rain*(t_precip-tl) + cpice * qintr_snow*(t_precip-tl) !----------------------------------------------------------------------- @@ -938,64 +1043,84 @@ SUBROUTINE LeafTemp(ipatch,ivt,deltim,csoilc,dewmx,htvp,lai ,& #if(defined CoLMDEBUG) IF(abs(err) .gt. .2) & - write(6,*) 'energy imbalance in leaftem.F90',it-1,err,sabv,irab,fsenl,hvap*fevpl,hprl + write(6,*) 'energy imbalance in LeafTemperature.F90',it-1,err,sabv,irab,fsenl,hvap*fevpl,hprl #endif !----------------------------------------------------------------------- ! Update dew accumulation (kg/m2) !----------------------------------------------------------------------- - if (DEF_Interception_scheme .eq. 1) then - ldew = max(0., ldew-evplwet*deltim) - - ELSEIF (DEF_Interception_scheme .eq. 2) then!CLM4.5 - ldew = max(0., ldew-evplwet*deltim) - - ELSEIF (DEF_Interception_scheme .eq. 3) then !CLM5 - if (ldew_rain.gt.evplwet*deltim) then - ldew_rain = ldew_rain-evplwet*deltim - ldew_snow = ldew_snow - ldew=ldew_rain+ldew_snow - else - ldew_rain = 0.0 - ldew_snow = max(0., ldew-evplwet*deltim) - ldew = ldew_snow - endif - - ELSEIF (DEF_Interception_scheme .eq. 4) then !Noah-MP - if (taf .gt. tfrz) then - ldew_rain = ldew_rain-evplwet*deltim !max(0., ldew-evplwet*deltim) - ldew_rain=max(ldew_rain,0.0) - else - ldew_snow = ldew_snow-evplwet*deltim - ldew_snow=max(ldew_snow,0.0) - endif - ldew=ldew_rain+ldew_snow - - ELSEIF (DEF_Interception_scheme .eq. 5) then !MATSIRO - if (taf .gt. tfrz) then - ldew_rain = ldew_rain-evplwet*deltim !max(0., ldew-evplwet*deltim) - ldew_rain=max(ldew_rain,0.0) - else - ldew_snow = ldew_snow-evplwet*deltim - ldew_snow=max(ldew_snow,0.0) - endif - ldew=ldew_rain+ldew_snow - - ELSEIF (DEF_Interception_scheme .eq. 6) then !VIC - if (taf .gt. tfrz) then - ldew_rain = ldew_rain-evplwet*deltim !max(0., ldew-evplwet*deltim) - ldew_rain=max(ldew_rain,0.0) - else - ldew_snow = ldew_snow-evplwet*deltim - ldew_snow=max(ldew_snow,0.0) - endif - ldew=ldew_rain+ldew_snow - - else - call abort - - endif + IF (DEF_Interception_scheme .eq. 1) THEN + ldew = max(0., ldew-evplwet*deltim) + + ELSEIF (DEF_Interception_scheme .eq. 2) THEN!CLM4.5 + ldew = max(0., ldew-evplwet*deltim) + + ELSEIF (DEF_Interception_scheme .eq. 3) THEN !CLM5 + IF (ldew_rain .gt. evplwet*deltim) THEN + ldew_rain = ldew_rain-evplwet*deltim + ldew_snow = ldew_snow + ldew=ldew_rain+ldew_snow + ELSE + ldew_rain = 0.0 + ldew_snow = max(0., ldew-evplwet*deltim) + ldew = ldew_snow + ENDIF + + ELSEIF (DEF_Interception_scheme .eq. 4) THEN !Noah-MP + IF (ldew_rain .gt. evplwet*deltim) THEN + ldew_rain = ldew_rain-evplwet*deltim + ldew_snow = ldew_snow + ldew=ldew_rain+ldew_snow + ELSE + ldew_rain = 0.0 + ldew_snow = max(0., ldew-evplwet*deltim) + ldew = ldew_snow + ENDIF + + ELSEIF (DEF_Interception_scheme .eq. 5) THEN !MATSIRO + IF (ldew_rain .gt. evplwet*deltim) THEN + ldew_rain = ldew_rain-evplwet*deltim + ldew_snow = ldew_snow + ldew=ldew_rain+ldew_snow + ELSE + ldew_rain = 0.0 + ldew_snow = max(0., ldew-evplwet*deltim) + ldew = ldew_snow + ENDIF + ELSEIF (DEF_Interception_scheme .eq. 6) THEN !VIC + IF (ldew_rain .gt. evplwet*deltim) THEN + ldew_rain = ldew_rain-evplwet*deltim + ldew_snow = ldew_snow + ldew=ldew_rain+ldew_snow + ELSE + ldew_rain = 0.0 + ldew_snow = max(0., ldew-evplwet*deltim) + ldew = ldew_snow + ENDIF + ELSEIF (DEF_Interception_scheme .eq. 7) THEN !JULES + IF (ldew_rain .gt. evplwet*deltim) THEN + ldew_rain = ldew_rain-evplwet*deltim + ldew_snow = ldew_snow + ldew=ldew_rain+ldew_snow + ELSE + ldew_rain = 0.0 + ldew_snow = max(0., ldew-evplwet*deltim) + ldew = ldew_snow + ENDIF + ELSEIF (DEF_Interception_scheme .eq. 8) THEN !JULES + IF (ldew_rain .gt. evplwet*deltim) THEN + ldew_rain = ldew_rain-evplwet*deltim + ldew_snow = ldew_snow + ldew=ldew_rain+ldew_snow + ELSE + ldew_rain = 0.0 + ldew_snow = max(0., ldew-evplwet*deltim) + ldew = ldew_snow + ENDIF + ELSE + CALL abort + ENDIF !----------------------------------------------------------------------- ! 2 m height air temperature @@ -1003,7 +1128,7 @@ SUBROUTINE LeafTemp(ipatch,ivt,deltim,csoilc,dewmx,htvp,lai ,& tref = thm + vonkar/(fh-fht)*dth * (fh2m/vonkar - fh/vonkar) qref = qm + vonkar/(fq-fqt)*dqh * (fq2m/vonkar - fq/vonkar) - END SUBROUTINE LeafTemp + END SUBROUTINE LeafTemperature !---------------------------------------------------------------------- SUBROUTINE dewfraction (sigf,lai,sai,dewmx,ldew,ldew_rain,ldew_snow,fwet,fdry) @@ -1031,688 +1156,45 @@ SUBROUTINE dewfraction (sigf,lai,sai,dewmx,ldew,ldew_rain,ldew_snow,fwet,fdry) !---1999.09.15 Yongjiu Dai !======================================================================= - USE MOD_Precision IMPLICIT NONE - REAL(r8), intent(in) :: sigf ! fraction of veg cover, excluding snow-covered veg [-] - REAL(r8), intent(in) :: lai ! leaf area index [-] - REAL(r8), intent(in) :: sai ! stem area index [-] - REAL(r8), intent(in) :: dewmx ! maximum allowed dew [0.1 mm] - REAL(r8), intent(in) :: ldew ! depth of water on foliage [kg/m2/s] - REAL(r8), intent(in) :: ldew_rain ! depth of rain on foliage [kg/m2/s] - REAL(r8), intent(in) :: ldew_snow ! depth of snow on foliage [kg/m2/s] - REAL(r8), intent(out) :: fwet ! fraction of foliage covered by water [-] - REAL(r8), intent(out) :: fdry ! fraction of foliage that is green and dry [-] - - REAL(r8) :: lsai ! lai + sai - REAL(r8) :: dewmxi ! inverse of maximum allowed dew [1/mm] - REAL(r8) :: vegt ! sigf*lsai, NOTE: remove sigf - REAL(r8) :: satcap_rain ! saturation capacity of foliage for rain [kg/m2] - REAL(r8) :: satcap_snow ! saturation capacity of foliage for snow [kg/m2] + real(r8), intent(in) :: sigf ! fraction of veg cover, excluding snow-covered veg [-] + real(r8), intent(in) :: lai ! leaf area index [-] + real(r8), intent(in) :: sai ! stem area index [-] + real(r8), intent(in) :: dewmx ! maximum allowed dew [0.1 mm] + real(r8), intent(in) :: ldew ! depth of water on foliage [kg/m2/s] + real(r8), intent(in) :: ldew_rain ! depth of rain on foliage [kg/m2/s] + real(r8), intent(in) :: ldew_snow ! depth of snow on foliage [kg/m2/s] + real(r8), intent(out) :: fwet ! fraction of foliage covered by water [-] + real(r8), intent(out) :: fdry ! fraction of foliage that is green and dry [-] + + real(r8) :: lsai ! lai + sai + real(r8) :: dewmxi ! inverse of maximum allowed dew [1/mm] + real(r8) :: vegt ! sigf*lsai, NOTE: remove sigf + real(r8) :: satcap_rain ! saturation capacity of foliage for rain [kg/m2] + real(r8) :: satcap_snow ! saturation capacity of foliage for snow [kg/m2] !----------------------------------------------------------------------- ! Fwet is the fraction of all vegetation surfaces which are wet ! including stem area which contribute to evaporation - if (DEF_Interception_scheme .eq. 1) then !CoLM2014 - lsai = lai + sai ! effective leaf area index - dewmxi = 1.0/dewmx - ! 06/2018, yuan: remove sigf, to compatible with PFT - vegt = lsai - fwet = 0 - IF(ldew > 0.) THEN - fwet = ((dewmxi/vegt)*ldew)**.666666666666 - ! Check for maximum limit of fwet - fwet = min(fwet,1.0) - ENDIF - ELSEIF (DEF_Interception_scheme .eq. 2) then !CLM4.5 - lsai = lai + sai - dewmxi = 1.0/dewmx - vegt = lsai - fwet = 0 - IF(ldew > 0.) THEN - fwet = ((dewmxi/vegt)*ldew)**.666666666666 - ! Check for maximum limit of fwet - fwet = min(fwet,1.0) - ENDIF - ELSEIF (DEF_Interception_scheme .eq. 3) then !CLM5 - print *, "NOAHMP canopy evaporation scheme to be implemented" - call abort - ELSEIF (DEF_Interception_scheme .eq. 4) then !Noah-MP - lsai = lai + sai - satcap_rain = dewmx*lsai - satcap_snow = satcap_rain*60.0 - IF(ldew_snow > 0. .and. ldew_snow>ldew_rain) THEN - fwet=(ldew_snow/satcap_snow)**.666666666666 - ELSEIF (ldew_rain > 0. .and. ldew_snow<=ldew_rain) then - fwet=(ldew_rain/satcap_rain)**.666666666666 - else - fwet=0.0 - endif + lsai = lai + sai ! effective leaf area index + dewmxi = 1.0/dewmx + ! 06/2018, yuan: remove sigf, to compatible with PFT + vegt = lsai + fwet = 0 + IF(ldew > 0.) THEN + fwet = ((dewmxi/vegt)*ldew)**.666666666666 ! Check for maximum limit of fwet fwet = min(fwet,1.0) - print *, "MATSIRO canopy evaporation scheme to be implemented" - call abort - ELSEIF (DEF_Interception_scheme .eq. 5) then !Matsiro - IF(ldew > 0.) THEN - satcap_rain=0.2*lsai - satcap_snow=0.2*lsai - fwet=(ldew/(satcap_rain))**.666666666666 - else - fwet=0.0 - endif - fwet = min(fwet,1.0) - print *, "VIC canopy evaporation scheme to be implemented" - call abort - ELSEIF (DEF_Interception_scheme .eq. 6) then !VIC - IF(ldew > 0.) THEN - fwet=(ldew/(lsai*0.2))**.666666666666 - else - fwet=0.0 - endif - ELSEIF (DEF_Interception_scheme .eq. 7) then - print *, "CoLM202X canopy evaporation scheme to be implemented" - call abort - else - call abort - endif - - -! fdry is the fraction of lai which is dry because only leaves can -! transpire. Adjusted for stem area which does not transpire - fdry = (1.-fwet)*lai/lsai + ENDIF - END SUBROUTINE dewfraction - -!---------------------------------------------------------------------- - - REAL(r8) FUNCTION uprofile(utop, fc, bee, alpha, z0mg, htop, hbot, z) - - USE MOD_Precision - USE MOD_FrictionVelocity - IMPLICIT NONE - - REAL(r8), intent(in) :: utop - REAL(r8), intent(in) :: fc - REAL(r8), intent(in) :: bee - REAL(r8), intent(in) :: alpha - REAL(r8), intent(in) :: z0mg - REAL(r8), intent(in) :: htop - REAL(r8), intent(in) :: hbot - REAL(r8), intent(in) :: z - - REAL(r8) :: ulog,uexp - - ! when canopy LAI->0, z0->zs, fac->1, u->umoninobuk - ! canopy LAI->large, fac->0 or=0, u->log profile - ulog = utop*log(z/z0mg)/log(htop/z0mg) - uexp = utop*exp(-alpha*(1-(z-hbot)/(htop-hbot))) - - uprofile = bee*fc*min(uexp,ulog) + (1-bee*fc)*ulog - - RETURN - END FUNCTION uprofile - - REAL(r8) FUNCTION kprofile(ktop, fc, bee, alpha, & - displah, htop, hbot, obu, ustar, z) - - USE MOD_Precision - USE MOD_FrictionVelocity - IMPLICIT NONE - - REAL(r8), parameter :: com1 = 0.4 - REAL(r8), parameter :: com2 = 0.08 - - REAL(r8), intent(in) :: ktop - REAL(r8), intent(in) :: fc - REAL(r8), intent(in) :: bee - REAL(r8), intent(in) :: alpha - REAL(r8), intent(in) :: displah - REAL(r8), intent(in) :: htop - REAL(r8), intent(in) :: hbot - REAL(r8), intent(in) :: obu - REAL(r8), intent(in) :: ustar - REAL(r8), intent(in) :: z - - REAL(r8) :: fac - REAL(r8) :: kcob, klin, kexp - - klin = ktop*z/htop - - fac = 1. / (1.+exp(-(displah-com1)/com2)) - kcob = 1. / (fac/klin + (1.-fac)/kmoninobuk(0.,obu,ustar,z)) - - kexp = ktop*exp(-alpha*(1-(z-hbot)/(htop-hbot))) - - kprofile = 1./( bee*fc/min(kexp,kcob) + (1-bee*fc)/kcob ) - - RETURN - END FUNCTION kprofile - - REAL(r8) FUNCTION uintegral(utop, fc, bee, alpha, z0mg, htop, hbot) - - USE MOD_Precision - IMPLICIT NONE - - REAL(r8), intent(in) :: utop - REAL(r8), intent(in) :: fc - REAL(r8), intent(in) :: bee - REAL(r8), intent(in) :: alpha - REAL(r8), intent(in) :: z0mg - REAL(r8), intent(in) :: htop - REAL(r8), intent(in) :: hbot - - INTEGER :: i, n - REAL(r8) :: dz, z, u - - ! 09/26/2017: change fixed n -> fixed dz - dz = 0.01 - n = int( (htop-hbot) / dz ) + 1 - - uintegral = 0. - - DO i = 1, n - IF (i < n) THEN - z = htop - (i-0.5)*dz - ELSE - dz = htop - hbot - (n-1)*dz - z = hbot + 0.5*dz - ENDIF - - u = uprofile(utop, fc, bee, alpha, z0mg, htop, hbot, z) - - u = max(0._r8, u) - !uintegral = uintegral + sqrt(u)*dz / (htop-hbot) -! 03/04/2020, yuan: NOTE: the above is hard to solve - !NOTE: The integral cannot be solved analytically after - !the square root sign of u, and the integral can be approximated - !directly for u, In this way, there is no need to square - uintegral = uintegral + u*dz / (htop-hbot) - ENDDO - - !uintegral = uintegral * uintegral - - RETURN - END FUNCTION uintegral - - - REAL(r8) FUNCTION ueffect(utop, htop, hbot, & - z0mg, alpha, bee, fc) - USE MOD_Precision - IMPLICIT NONE - - REAL(r8), intent(in) :: utop - REAL(r8), intent(in) :: htop - REAL(r8), intent(in) :: hbot - REAL(r8), intent(in) :: z0mg - REAL(r8), intent(in) :: alpha - REAL(r8), intent(in) :: bee - REAL(r8), intent(in) :: fc - - REAL(r8) :: roots(2), uint - INTEGER :: rootn - - rootn = 0 - uint = 0. - - CALL ufindroots(htop,hbot,(htop+hbot)/2., & - utop, htop, hbot, z0mg, alpha, roots, rootn) - - IF (rootn == 0) THEN !no root - uint = uint + fuint(utop, htop, hbot, & - htop, hbot, z0mg, alpha, bee, fc) - ENDIF - - IF (rootn == 1) THEN - uint = uint + fuint(utop, htop, roots(1), & - htop, hbot, z0mg, alpha, bee, fc) - uint = uint + fuint(utop, roots(1), hbot, & - htop, hbot, z0mg, alpha, bee, fc) - ENDIF - - IF (rootn == 2) THEN - uint = uint + fuint(utop, htop, roots(1), & - htop, hbot, z0mg, alpha, bee, fc) - uint = uint + fuint(utop, roots(1), roots(2), & - htop, hbot, z0mg, alpha, bee, fc) - uint = uint + fuint(utop, roots(2), hbot, & - htop, hbot, z0mg, alpha, bee, fc) - ENDIF - - ueffect = uint / (htop-hbot) - - RETURN - END FUNCTION ueffect - - - REAL(r8) FUNCTION fuint(utop, ztop, zbot, & - htop, hbot, z0mg, alpha, bee, fc) - - USE MOD_Precision - IMPLICIT NONE - - REAL(r8), intent(in) :: utop, ztop, zbot - REAL(r8), intent(in) :: htop, hbot - REAL(r8), intent(in) :: z0mg, alpha - REAL(r8), intent(in) :: bee, fc - - ! local variables - REAL(r8) :: fuexpint, fulogint - - fulogint = utop/log(htop/z0mg) *& - (ztop*log(ztop/z0mg) - zbot*log(zbot/z0mg) + zbot - ztop) - - IF (udif((ztop+zbot)/2.,utop,htop,hbot,z0mg,alpha) <= 0) THEN - ! uexp is smaller - fuexpint = utop*(htop-hbot)/alpha*( & - exp(-alpha*(htop-ztop)/(htop-hbot))-& - exp(-alpha*(htop-zbot)/(htop-hbot)) ) - - fuint = bee*fc*fuexpint + (1.-bee*fc)*fulogint - ELSE - ! ulog is smaller - fuint = fulogint - ENDIF - - RETURN - END FUNCTION fuint - - - RECURSIVE SUBROUTINE ufindroots(ztop,zbot,zmid, & - utop, htop, hbot, z0mg, alpha, roots, rootn) - - USE MOD_Precision - IMPLICIT NONE - - REAL(r8), intent(in) :: ztop, zbot, zmid - REAL(r8), intent(in) :: utop, htop, hbot - REAL(r8), intent(in) :: z0mg, alpha - - REAL(r8), intent(inout) :: roots(2) - INTEGER, intent(inout) :: rootn - - ! local variables - REAL(r8) :: udif_ub, udif_lb - - udif_ub = udif(ztop,utop,htop,hbot,z0mg,alpha) - udif_lb = udif(zmid,utop,htop,hbot,z0mg,alpha) - - IF (udif_ub*udif_lb == 0) THEN - IF (udif_lb == 0) THEN !root found - rootn = rootn + 1 - IF (rootn > 2) THEN - print *, "U root number > 2, abort!" - CALL abort - ENDIF - roots(rootn) = zmid - ENDIF - ELSE IF (udif_ub*udif_lb < 0) THEN - IF (ztop-zmid < 0.01) THEN - rootn = rootn + 1 !root found - IF (rootn > 2) THEN - print *, "U root number > 2, abort!" - CALL abort - ENDIF - roots(rootn) = (ztop+zmid)/2. - ELSE - CALL ufindroots(ztop,zmid,(ztop+zmid)/2., & - utop, htop, hbot, z0mg, alpha, roots, rootn) - ENDIF - ENDIF - - udif_ub = udif(zmid,utop,htop,hbot,z0mg,alpha) - udif_lb = udif(zbot,utop,htop,hbot,z0mg,alpha) - - IF (udif_ub*udif_lb == 0) THEN - IF (udif_ub == 0) THEN !root found - rootn = rootn + 1 - IF (rootn > 2) THEN - print *, "U root number > 2, abort!" - CALL abort - ENDIF - roots(rootn) = zmid - ENDIF - ELSE IF (udif_ub*udif_lb < 0) THEN - IF (zmid-zbot < 0.01) THEN - rootn = rootn + 1 !root found - IF (rootn > 2) THEN - print *, "U root number > 2, abort!" - CALL abort - ENDIF - roots(rootn) = (zmid+zbot)/2. - ELSE - CALL ufindroots(zmid,zbot,(zmid+zbot)/2., & - utop, htop, hbot, z0mg, alpha, roots, rootn) - ENDIF - ENDIF - - END SUBROUTINE ufindroots - - - REAL(r8) FUNCTION udif(z, utop, htop, hbot, z0mg, alpha) - - USE MOD_Precision - IMPLICIT NONE - - REAL(r8), intent(in) :: z, utop, htop, hbot - REAL(r8), intent(in) :: z0mg, alpha - - REAL(r8) :: uexp, ulog - - uexp = utop*exp(-alpha*(1-(z-hbot)/(htop-hbot))) - ulog = utop*log(z/z0mg)/log(htop/z0mg) - - udif = uexp - ulog - - RETURN - END FUNCTION udif - - - REAL(r8) FUNCTION kintegral(ktop, fc, bee, alpha, z0mg, & - displah, htop, hbot, obu, ustar, ztop, zbot) - USE MOD_Precision - IMPLICIT NONE - - REAL(r8), intent(in) :: ktop - REAL(r8), intent(in) :: fc - REAL(r8), intent(in) :: bee - REAL(r8), intent(in) :: alpha - REAL(r8), intent(in) :: z0mg - REAL(r8), intent(in) :: displah - REAL(r8), intent(in) :: htop - REAL(r8), intent(in) :: hbot - REAL(r8), intent(in) :: obu - REAL(r8), intent(in) :: ustar - REAL(r8), intent(in) :: ztop - REAL(r8), intent(in) :: zbot - - INTEGER :: i, n - REAL(r8) :: dz, z, k - - kintegral = 0. - - IF (ztop <= zbot) THEN - RETURN - ENDIF - - ! 09/26/2017: change fixed n -> fixed dz - dz = 0.01 - n = int( (ztop-zbot) / dz ) + 1 - - DO i = 1, n - IF (i < n) THEN - z = ztop - (i-0.5)*dz - ELSE - dz = ztop - zbot - (n-1)*dz - z = zbot + 0.5*dz - ENDIF - - k = kprofile(ktop, fc, bee, alpha, & - displah, htop, hbot, obu, ustar, z) - - kintegral = kintegral + 1./k * dz - - ENDDO - - RETURN - END FUNCTION kintegral - - REAL(r8) FUNCTION frd(ktop, htop, hbot, & - ztop, zbot, displah, z0h, obu, ustar, & - z0mg, alpha, bee, fc) - - USE MOD_Precision - IMPLICIT NONE - - REAL(r8), intent(in) :: ktop, htop, hbot - REAL(r8), intent(in) :: ztop, zbot - REAL(r8), intent(in) :: displah, z0h, obu, ustar - REAL(r8), intent(in) :: z0mg, alpha, bee, fc - - ! local parameters - REAL(r8), parameter :: com1 = 0.4 - REAL(r8), parameter :: com2 = 0.08 - - REAL(r8) :: roots(2), fac, kint - INTEGER :: rootn - - rootn = 0 - kint = 0. - - ! calculate fac - fac = 1. / (1.+exp(-(displah-com1)/com2)) - - CALL kfindroots(ztop,zbot,(ztop+zbot)/2., & - ktop, htop, hbot, obu, ustar, fac, alpha, roots, rootn) + ! fdry is the fraction of lai which is dry because only leaves can + ! transpire. Adjusted for stem area which does not transpire + fdry = (1.-fwet)*lai/lsai - IF (rootn == 0) THEN !no root - kint = kint + fkint(ktop, ztop, zbot, htop, hbot, & - z0h, obu, ustar, fac, alpha, bee, fc) - ENDIF - - IF (rootn == 1) THEN - kint = kint + fkint(ktop, ztop, roots(1), htop, hbot, & - z0h, obu, ustar, fac, alpha, bee, fc) - kint = kint + fkint(ktop, roots(1), zbot, htop, hbot, & - z0h, obu, ustar, fac, alpha, bee, fc) - ENDIF - - IF (rootn == 2) THEN - kint = kint + fkint(ktop, ztop, roots(1), htop, hbot, & - z0h, obu, ustar, fac, alpha, bee, fc) - kint = kint + fkint(ktop, roots(1), roots(2), htop, hbot, & - z0h, obu, ustar, fac, alpha, bee, fc) - kint = kint + fkint(ktop, roots(2), zbot, htop, hbot, & - z0h, obu, ustar, fac, alpha, bee, fc) - ENDIF - - frd = kint - - RETURN - END FUNCTION frd - - - REAL(r8) FUNCTION fkint(ktop, ztop, zbot, htop, hbot, & - z0h, obu, ustar, fac, alpha, bee, fc) - - USE MOD_Precision - USE MOD_FrictionVelocity - IMPLICIT NONE - - REAL(r8), intent(in) :: ktop, ztop, zbot - REAL(r8), intent(in) :: htop, hbot - REAL(r8), intent(in) :: z0h, obu, ustar, fac, alpha - REAL(r8), intent(in) :: bee, fc - - ! local variables - REAL(r8) :: fkexpint, fkcobint - - !NOTE: - ! klin = ktop*z/htop - ! kcob = 1./(fac/klin + (1.-fac)/kmoninobuk(0.,obu,ustar,z)) - fkcobint = fac*htop/ktop*(log(ztop)-log(zbot)) +& - (1.-fac)*kintmoninobuk(0.,z0h,obu,ustar,ztop,zbot) - - IF (kdif((ztop+zbot)/2.,ktop,htop,hbot,obu,ustar,fac,alpha) <= 0) THEN - ! kexp is smaller - IF (alpha > 0) THEN - fkexpint = -(htop-hbot)/alpha/ktop*( & - exp(alpha*(htop-ztop)/(htop-hbot))-& - exp(alpha*(htop-zbot)/(htop-hbot)) ) - ELSE - fkexpint = (ztop-zbot)/ktop - ENDIF - - fkint = bee*fc*fkexpint + (1.-bee*fc)*fkcobint - ELSE - ! kcob is smaller - fkint = fkcobint - ENDIF - - RETURN - END FUNCTION fkint - - - RECURSIVE SUBROUTINE kfindroots(ztop,zbot,zmid, & - ktop, htop, hbot, obu, ustar, fac, alpha, roots, rootn) - - USE MOD_Precision - IMPLICIT NONE - - REAL(r8), intent(in) :: ztop, zbot, zmid - REAL(r8), intent(in) :: ktop, htop, hbot - REAL(r8), intent(in) :: obu, ustar, fac, alpha - - REAL(r8), intent(inout) :: roots(2) - INTEGER, intent(inout) :: rootn - - ! local variables - REAL(r8) :: kdif_ub, kdif_lb - - !print *, "*** CALL recursive SUBROUTINE kfindroots!!" - kdif_ub = kdif(ztop,ktop,htop,hbot,obu,ustar,fac,alpha) - kdif_lb = kdif(zmid,ktop,htop,hbot,obu,ustar,fac,alpha) - - IF (kdif_ub*kdif_lb == 0) THEN - IF (kdif_lb == 0) THEN !root found - rootn = rootn + 1 - IF (rootn > 2) THEN - print *, "K root number > 2, abort!" - CALL abort - ENDIF - roots(rootn) = zmid - ENDIF - ELSE IF (kdif_ub*kdif_lb < 0) THEN - IF (ztop-zmid < 0.01) THEN - rootn = rootn + 1 !root found - IF (rootn > 2) THEN - print *, "K root number > 2, abort!" - CALL abort - ENDIF - roots(rootn) = (ztop+zmid)/2. - ELSE - CALL kfindroots(ztop,zmid,(ztop+zmid)/2., & - ktop, htop, hbot, obu, ustar, fac, alpha, roots, rootn) - ENDIF - ENDIF - - kdif_ub = kdif(zmid,ktop,htop,hbot,obu,ustar,fac,alpha) - kdif_lb = kdif(zbot,ktop,htop,hbot,obu,ustar,fac,alpha) - - IF (kdif_ub*kdif_lb == 0) THEN - IF (kdif_ub == 0) THEN !root found - rootn = rootn + 1 - IF (rootn > 2) THEN - print *, "K root number > 2, abort!" - CALL abort - ENDIF - roots(rootn) = zmid - ENDIF - ELSE IF (kdif_ub*kdif_lb < 0) THEN - IF (zmid-zbot < 0.01) THEN - rootn = rootn + 1 !root found - IF (rootn > 2) THEN - print *, "K root number > 2, abort!" - CALL abort - ENDIF - roots(rootn) = (zmid+zbot)/2. - ELSE - CALL kfindroots(zmid,zbot,(zmid+zbot)/2., & - ktop, htop, hbot, obu, ustar, fac, alpha, roots, rootn) - ENDIF - ENDIF - - END SUBROUTINE kfindroots - - - REAL(r8) FUNCTION kdif(z, ktop, htop, hbot, & - obu, ustar, fac, alpha) - - USE MOD_Precision - USE MOD_FrictionVelocity - IMPLICIT NONE - - REAL(r8), intent(in) :: z, ktop, htop, hbot - REAL(r8), intent(in) :: obu, ustar, fac, alpha - - REAL(r8) :: kexp, klin, kcob - - kexp = ktop*exp(-alpha*(1-(z-hbot)/(htop-hbot))) - - klin = ktop*z/htop - kcob = 1./(fac/klin + (1.-fac)/kmoninobuk(0.,obu,ustar,z)) - - kdif = kexp - kcob - - RETURN - END FUNCTION kdif - - - SUBROUTINE cal_z0_displa (lai, h, fc, z0, displa) - - USE MOD_Const_Physical, only: vonkar - IMPLICIT NONE - - REAL(r8), intent(in) :: lai - REAL(r8), intent(in) :: h - REAL(r8), intent(in) :: fc - REAL(r8), intent(out) :: z0 - REAL(r8), intent(out) :: displa - - REAL(r8), parameter :: Cd = 0.2 !leaf drag coefficient - REAL(r8), parameter :: cd1 = 7.5 !a free parameter for d/h calculation, Raupach 1992, 1994 - REAL(r8), parameter :: psih = 0.193 !psih = ln(cw) - 1 + cw^-1, cw = 2, Raupach 1994 - - ! local variables - REAL(r8) :: fai, sqrtdragc, temp1, delta , lai0 - - ! when assume z0=0.01, displa=0 - ! to calculate lai0, delta displa - !---------------------------------------------------- - sqrtdragc = -vonkar/(log(0.01/h) - psih) - sqrtdragc = max(sqrtdragc, 0.0031**0.5) - IF (sqrtdragc .le. 0.3) THEN - fai = (sqrtdragc**2-0.003) / 0.3 - fai = min(fai, fc*(1-exp(-20.))) - ELSE - fai = 0.29 - print *, "z0m, displa error!" - ENDIF - - ! calculate delta displa when z0 = 0.01 - lai0 = -log(1.-fai/fc)/0.5 - temp1 = (2.*cd1*fai)**0.5 - delta = -h * ( fc*1.1*log(1. + (Cd*lai0*fc)**0.25) + & - (1.-fc)*(1.-(1.-exp(-temp1))/temp1) ) - - ! calculate z0m, displa - !---------------------------------------------------- - ! NOTE: potential bug below, ONLY apply for spheric - ! crowns. For other cases, fc*(...) ==> a*fc*(...) - fai = fc*(1. - exp(-0.5*lai)) - sqrtdragc = min( (0.003+0.3*fai)**0.5, 0.3 ) - temp1 = (2.*cd1*fai)**0.5 - - IF (lai > lai0) THEN - displa = delta + h*( & - ( fc)*1.1*log(1. + (Cd*lai*fc)**0.25) + & - (1-fc)*(1.-(1.-exp(-temp1))/temp1) ) - ELSE - displa = h*( & - ( fc)*1.1*log(1. + (Cd*lai*fc)**0.25) + & - (1-fc)*(1.-(1.-exp(-temp1))/temp1) ) - ENDIF - - displa = max(displa, 0.) - z0 = (h-displa) * exp(-vonkar/sqrtdragc + psih) - - IF (z0 < 0.01) THEN - z0 = 0.01 - displa = 0. - ENDIF - - END SUBROUTINE cal_z0_displa + END SUBROUTINE dewfraction END MODULE MOD_LeafTemperature diff --git a/main/MOD_LeafTemperaturePC.F90 b/main/MOD_LeafTemperaturePC.F90 index 78a772da..7e20ffcc 100644 --- a/main/MOD_LeafTemperaturePC.F90 +++ b/main/MOD_LeafTemperaturePC.F90 @@ -3,52 +3,48 @@ MODULE MOD_LeafTemperaturePC !----------------------------------------------------------------------- - USE MOD_Precision - IMPLICIT NONE - SAVE + USE MOD_Precision + IMPLICIT NONE + SAVE ! PUBLIC MEMBER FUNCTIONS: - PUBLIC :: LeafTempPC + PUBLIC :: LeafTemperaturePC ! PRIVATE MEMBER FUNCTIONS: PRIVATE :: dewfraction - PRIVATE :: cal_z0_displa !----------------------------------------------------------------------- - CONTAINS +CONTAINS !----------------------------------------------------------------------- - SUBROUTINE LeafTempPC (ipatch,npft,deltim,csoilc,dewmx ,htvp ,& - fcover ,canlev ,htop ,hbot ,lai ,sai ,& - sqrtdi ,effcon ,vmax25 ,slti ,hlti ,shti ,& - hhti ,trda ,trdm ,trop ,gradm ,binter ,& - extkn ,extkb ,extkd ,hu ,ht ,hq ,& - us ,vs ,thm ,th ,thv ,qm ,& - psrf ,rhoair ,parsun ,parsha ,fsun ,sabv ,& - frl ,thermk ,fshade ,rstfacsun, rstfacsha,& - gssun ,gssha ,po2m ,pco2m ,& - z0h_g ,obug ,ustarg ,zlnd ,zsno ,fsno ,& - sigf ,etrc ,tg ,qg ,dqgdT ,emg ,& - z0mpc ,tl ,ldew ,ldew_rain ,ldew_snow,& - taux ,tauy ,fseng ,& - fevpg ,cgrnd ,cgrndl ,cgrnds ,tref ,qref ,& - rst ,assim ,respc ,fsenl ,fevpl ,etr ,& - dlrad ,ulrad ,z0m ,zol ,rib ,ustar ,& - qstar ,tstar ,fm ,fh ,fq ,& - rootfr ,& - kmax_sun,kmax_sha,kmax_xyl,kmax_root,psi50_sun,psi50_sha,& - psi50_xyl,psi50_root,ck ,vegwp ,gs0sun ,gs0sha ,& - assimsun,etrsun ,assimsha,etrsha ,& + SUBROUTINE LeafTemperaturePC ( & + ipatch ,ps ,pe ,deltim ,csoilc ,dewmx ,& + htvp ,pftclass ,fcover ,htop ,hbot ,lai ,& + sai ,extkb ,extkd ,hu ,ht ,hq ,& + us ,vs ,forc_t ,thm ,th ,thv ,& + qm ,psrf ,rhoair ,parsun ,parsha ,fsun ,& + sabv ,frl ,thermk ,fshade ,rstfacsun ,rstfacsha ,& + gssun ,gssha ,po2m ,pco2m ,z0h_g ,obug ,& + ustarg ,zlnd ,zsno ,fsno ,sigf ,etrc ,& + tg ,qg ,rss ,dqgdT ,emg ,t_soil ,& + t_snow ,q_soil ,q_snow ,z0mpc ,tl ,ldew ,& + ldew_rain ,ldew_snow ,taux ,tauy ,fseng ,fseng_soil,& + fseng_snow,fevpg ,fevpg_soil,fevpg_snow,cgrnd ,cgrndl ,& + cgrnds ,tref ,qref ,rst ,assim ,respc ,& + fsenl ,fevpl ,etr ,dlrad ,ulrad ,z0m ,& + zol ,rib ,ustar ,qstar ,tstar ,fm ,& + fh ,fq ,vegwp ,gs0sun ,gs0sha ,assimsun ,& + etrsun ,assimsha ,etrsha ,& !Ozone stress variables - o3coefv_sun ,o3coefv_sha ,o3coefg_sun ,o3coefg_sha, & - lai_old, o3uptakesun, o3uptakesha, forc_ozone,& + o3coefv_sun ,o3coefv_sha ,o3coefg_sun ,o3coefg_sha,& + lai_old ,o3uptakesun ,o3uptakesha ,forc_ozone ,& !End ozone stress variables hpbl, & - qintr_rain,qintr_snow,t_precip,hprl,smp ,hk ,& - hksati ,rootr ) + qintr_rain ,qintr_snow ,t_precip ,hprl ,& + smp ,hk ,hksati ,rootflux ) !======================================================================= ! @@ -62,8 +58,7 @@ SUBROUTINE LeafTempPC (ipatch,npft,deltim,csoilc,dewmx ,htvp ,& ! transfer between foliage and atmosphere and ground is linked by the equations: ! Ha = Hf + Hg and Ea = Ef + Eg ! -! Original author : Yongjiu Dai, August 15, 2001 -! Hua Yuan, September, 2017 +! Original author : Hua Yuan and Yongjiu Dai, September, 2017 ! ! REFERENCES: ! 1) Dai, Y., Yuan, H., Xin, Q., Wang, D., Shangguan, W., Zhang, S., et al. (2019). @@ -82,186 +77,175 @@ SUBROUTINE LeafTempPC (ipatch,npft,deltim,csoilc,dewmx ,htvp ,& USE MOD_Precision USE MOD_Vars_Global USE MOD_Const_Physical, only: vonkar, grav, hvap, cpair, stefnc, cpliq, cpice + USE MOD_Const_PFT USE MOD_FrictionVelocity - USE MOD_Namelist, only: DEF_USE_CBL_HEIGHT, DEF_USE_PLANTHYDRAULICS, DEF_USE_OZONESTRESS + USE MOD_CanopyLayerProfile + USE MOD_Namelist, only: DEF_USE_CBL_HEIGHT, DEF_USE_PLANTHYDRAULICS, DEF_USE_OZONESTRESS, & + DEF_RSS_SCHEME, DEF_Interception_scheme, DEF_SPLIT_SOILSNOW USE MOD_TurbulenceLEddy USE MOD_Qsadv USE MOD_AssimStomataConductance - USE MOD_PlantHydraulic, only : PlantHydraulicStress_twoleaf + USE MOD_PlantHydraulic, only: PlantHydraulicStress_twoleaf USE MOD_Ozone, only: CalcOzoneStress IMPLICIT NONE !-----------------------Arguments--------------------------------------- integer, intent(in) :: ipatch - integer , intent(in) :: & - npft, &! potential PFT number in a column - canlev(npft) ! potential canopy layer in a column + integer, intent(in) :: & + ps, &! start PFT index in a patch + pe ! end PFT index in a patch real(r8), intent(in) :: & - deltim, &! seconds in a time step [second] - csoilc, &! drag coefficient for soil under canopy [-] - dewmx, &! maximum dew - htvp ! latent heat of evaporation (/sublimation) [J/kg] + deltim, &! seconds in a time step [second] + csoilc, &! drag coefficient for soil under canopy [-] + dewmx, &! maximum dew + htvp ! latent heat of evaporation (/sublimation) [J/kg] ! vegetation parameters - real(r8), dimension(npft), intent(in) :: & - fcover, &! PFT fractiona coverage [-] - htop, &! PFT crown top height [m] - hbot, &! PFT crown bottom height [m] - lai, &! adjusted leaf area index for seasonal variation [-] - sai, &! stem area index [-] - sqrtdi, &! inverse sqrt of leaf dimension [m**-0.5] - - effcon, &! quantum efficiency of RuBP regeneration (mol CO2 / mol quanta) - vmax25, &! maximum carboxylation rate at 25 C at canopy top - ! the range : 30.e-6 <-> 100.e-6 (mol co2 m-2 s-1) - shti, &! slope of high temperature inhibition function (s1) - hhti, &! 1/2 point of high temperature inhibition function (s2) - slti, &! slope of low temperature inhibition function (s3) - hlti, &! 1/2 point of low temperature inhibition function (s4) - trda, &! temperature coefficient in gs-a model (s5) - trdm, &! temperature coefficient in gs-a model (s6) - trop, &! temperature coefficient in gs-a model (273+25) - gradm, &! conductance-photosynthesis slope parameter - binter, &! conductance-photosynthesis intercept - extkn ! coefficient of leaf nitrogen allocation - - real(r8), dimension(npft), intent(in), optional :: & - kmax_sun, & - kmax_sha, & - kmax_xyl, & - kmax_root, & - psi50_sun, &! water potential at 50% loss of sunlit leaf tissue conductance (mmH2O) - psi50_sha, &! water potential at 50% loss of shaded leaf tissue conductance (mmH2O) - psi50_xyl, &! water potential at 50% loss of xylem tissue conductance (mmH2O) - psi50_root, &! water potential at 50% loss of root tissue conductance (mmH2O) - ck ! shape-fitting parameter for vulnerability curve (-) + integer, dimension(ps:pe), intent(in) :: & + pftclass ! PFT class + + real(r8), dimension(ps:pe), intent(in) :: & + fcover, &! PFT fractiona coverage [-] + htop, &! PFT crown top height [m] + hbot, &! PFT crown bottom height [m] + lai, &! adjusted leaf area index for seasonal variation [-] + sai ! stem area index [-] real(r8), intent(inout) :: & - vegwp(1:nvegwcs,npft), &! vegetation water potential - gs0sun(npft), &! - gs0sha(npft) + vegwp(1:nvegwcs,ps:pe), &! vegetation water potential + gs0sun(ps:pe), &! maximum stomata conductance of sunlit leaf + gs0sha(ps:pe) ! maximum stomata conductance of shaded leaf ! input variables real(r8), intent(in) :: & - hu, &! observational height of wind [m] - ht, &! observational height of temperature [m] - hq, &! observational height of humidity [m] - us, &! wind component in eastward direction [m/s] - vs, &! wind component in northward direction [m/s] - thm, &! intermediate variable (tm+0.0098*ht) - th, &! potential temperature (kelvin) - thv, &! virtual potential temperature (kelvin) - qm, &! specific humidity at reference height [kg/kg] - psrf, &! pressure at reference height [pa] - rhoair, &! density air [kg/m**3] - - parsun(npft),&! par absorbed per unit sunlit lai [w/m**2] - parsha(npft),&! par absorbed per unit shaded lai [w/m**2] - fsun(npft), &! sunlit fraction of canopy - sabv(npft), &! solar radiation absorbed by vegetation [W/m2] - frl, &! atmospheric infrared (longwave) radiation [W/m2] - - extkb(npft), &! (k, g(mu)/mu) direct solar extinction coefficient - extkd(npft), &! diffuse and scattered diffuse PAR extinction coefficient - thermk(npft),&! canopy gap fraction for tir radiation - fshade(npft),&! shadow for each PFT - - po2m, &! atmospheric partial pressure o2 (pa) - pco2m, &! atmospheric partial pressure co2 (pa) - - z0h_g, &! bare soil roughness length, sensible heat [m] - obug, &! bare soil obu - ustarg, &! bare soil ustar - zlnd, &! roughness length for soil [m] - zsno, &! roughness length for snow [m] - fsno, &! fraction of snow cover on ground - - sigf(npft), &! fraction of veg cover, excluding snow-covered veg [-] - etrc(npft), &! maximum possible transpiration rate (mm/s) - tg, &! ground surface temperature [K] - qg, &! specific humidity at ground surface [kg/kg] - dqgdT, &! temperature derivative of "qg" - emg ! vegetation emissivity + hu, &! observational height of wind [m] + ht, &! observational height of temperature [m] + hq, &! observational height of humidity [m] + us, &! wind component in eastward direction [m/s] + vs, &! wind component in northward direction [m/s] + forc_t, &! temperature at agcm reference height [kelvin] + thm, &! intermediate variable (tm+0.0098*ht) + th, &! potential temperature (kelvin) + thv, &! virtual potential temperature (kelvin) + qm, &! specific humidity at reference height [kg/kg] + psrf, &! pressure at reference height [pa] + rhoair, &! density air [kg/m**3] + + parsun(ps:pe), &! par absorbed per unit sunlit lai [w/m**2] + parsha(ps:pe), &! par absorbed per unit shaded lai [w/m**2] + fsun (ps:pe), &! sunlit fraction of canopy + sabv (ps:pe), &! solar radiation absorbed by vegetation [W/m2] + frl, &! atmospheric infrared (longwave) radiation [W/m2] + + extkb (ps:pe), &! (k, g(mu)/mu) direct solar extinction coefficient + extkd (ps:pe), &! diffuse and scattered diffuse PAR extinction coefficient + thermk(ps:pe), &! canopy gap fraction for tir radiation + fshade(ps:pe), &! shadow for each PFT + + po2m, &! atmospheric partial pressure o2 (pa) + pco2m, &! atmospheric partial pressure co2 (pa) + + z0h_g, &! bare soil roughness length, sensible heat [m] + obug, &! bare soil obu + ustarg, &! bare soil ustar + zlnd, &! roughness length for soil [m] + zsno, &! roughness length for snow [m] + fsno, &! fraction of snow cover on ground + + sigf (ps:pe), &! fraction of veg cover, excluding snow-covered veg [-] + etrc (ps:pe), &! maximum possible transpiration rate (mm/s) + tg, &! ground surface temperature [K] + t_soil, &! ground surface soil temperature [K] + t_snow, &! ground surface snow temperature [K] + qg, &! specific humidity at ground surface [kg/kg] + q_soil, &! specific humidity at ground surface soil [kg/kg] + q_snow, &! specific humidity at ground surface snow [kg/kg] + dqgdT, &! temperature derivative of "qg" + rss, &! soil surface resistance [s/m] + emg ! vegetation emissivity real(r8), intent(in) :: & t_precip, &! snowfall/rainfall temperature [kelvin] - qintr_rain(npft), &! rainfall interception (mm h2o/s) - qintr_snow(npft), &! snowfall interception (mm h2o/s) + qintr_rain(ps:pe), &! rainfall interception (mm h2o/s) + qintr_snow(ps:pe), &! snowfall interception (mm h2o/s) smp (1:nl_soil), &! precipitation sensible heat from canopy - rootfr (1:nl_soil,npft), &! root fraction hksati (1:nl_soil), &! hydraulic conductivity at saturation [mm h2o/s] hk (1:nl_soil) ! soil hydraulic conducatance real(r8), intent(in) :: & - hpbl ! atmospheric boundary layer height [m] + hpbl ! atmospheric boundary layer height [m] - real(r8), dimension(npft), intent(inout) :: & - tl, &! leaf temperature [K] - ldew, &! depth of water on foliage [mm] - ldew_rain, &! depth of rain on foliage [mm] - ldew_snow, &! depth of snow on foliage [mm] + real(r8), dimension(ps:pe), intent(inout) :: & + tl, &! leaf temperature [K] + ldew, &! depth of water on foliage [mm] + ldew_rain, &! depth of rain on foliage [mm] + ldew_snow, &! depth of snow on foliage [mm] !Ozone stress variables - lai_old ,&! lai in last time step - o3uptakesun,&! Ozone does, sunlit leaf (mmol O3/m^2) - o3uptakesha,&! Ozone does, shaded leaf (mmol O3/m^2) - o3coefv_sun,&! Ozone stress factor for photosynthesis on sunlit leaf - o3coefv_sha,&! Ozone stress factor for photosynthesis on sunlit leaf - o3coefg_sun,&! Ozone stress factor for stomata on shaded leaf - o3coefg_sha,&! Ozone stress factor for stomata on shaded leaf + lai_old , &! lai in last time step + o3uptakesun, &! Ozone does, sunlit leaf (mmol O3/m^2) + o3uptakesha, &! Ozone does, shaded leaf (mmol O3/m^2) + o3coefv_sun, &! Ozone stress factor for photosynthesis on sunlit leaf + o3coefv_sha, &! Ozone stress factor for photosynthesis on sunlit leaf + o3coefg_sun, &! Ozone stress factor for stomata on shaded leaf + o3coefg_sha, &! Ozone stress factor for stomata on shaded leaf !End ozone stress variables - rstfacsun, &! factor of soil water stress to transpiration on sunlit leaf - rstfacsha, &! factor of soil water stress to transpiration on shaded leaf - gssun, & - gssha + rstfacsun, &! factor of soil water stress to transpiration on sunlit leaf + rstfacsha, &! factor of soil water stress to transpiration on shaded leaf + gssun, &! stomata conductance of sunlit leaf + gssha ! stomata conductance of shaded leaf - real(r8), dimension(npft), intent(inout) :: & - assimsun, &! sunlit leaf assimilation rate [umol co2 /m**2/ s] [+] - etrsun, & - assimsha, &! shaded leaf assimilation rate [umol co2 /m**2/ s] [+] - etrsha + real(r8), dimension(ps:pe), intent(inout) :: & + assimsun, &! sunlit leaf assimilation rate [umol co2 /m**2/ s] [+] + etrsun, &! transpiration rate of sunlit leaf [mm/s] + assimsha, &! shaded leaf assimilation rate [umol co2 /m**2/ s] [+] + etrsha ! transpiration rate of shaded leaf [mm/s] !Ozone stress variables real(r8), intent(inout) :: forc_ozone !End ozone stress variables real(r8), intent(inout) :: & - dlrad, &! downward longwave radiation blow the canopy [W/m2] - ulrad, &! upward longwave radiation above the canopy [W/m2] - taux, &! wind stress: E-W [kg/m/s**2] - tauy, &! wind stress: N-S [kg/m/s**2] - fseng, &! sensible heat flux from ground [W/m2] - fevpg, &! evaporation heat flux from ground [mm/s] - tref, &! 2 m height air temperature (kelvin) - qref, &! 2 m height air specific humidity - rootr(nl_soil,npft) ! fraction of root water uptake from different layers - - real(r8), dimension(npft), intent(out) :: & - z0mpc, &! z0m for individual PFT - rst, &! stomatal resistance - assim, &! rate of assimilation - respc, &! rate of respiration - fsenl, &! sensible heat from leaves [W/m2] - fevpl, &! evaporation+transpiration from leaves [mm/s] - etr, &! transpiration rate [mm/s] - hprl ! precipitation sensible heat from canopy + dlrad, &! downward longwave radiation blow the canopy [W/m2] + ulrad, &! upward longwave radiation above the canopy [W/m2] + taux, &! wind stress: E-W [kg/m/s**2] + tauy, &! wind stress: N-S [kg/m/s**2] + fseng, &! sensible heat flux from ground [W/m2] + fseng_soil, &! sensible heat flux from ground soil [W/m2] + fseng_snow, &! sensible heat flux from ground snow [W/m2] + fevpg, &! evaporation heat flux from ground [mm/s] + fevpg_soil, &! evaporation heat flux from ground soil [mm/s] + fevpg_snow, &! evaporation heat flux from ground snow [mm/s] + tref, &! 2 m height air temperature (kelvin) + qref, &! 2 m height air specific humidity + rootflux(nl_soil,ps:pe) ! root water uptake from different layers + + real(r8), dimension(ps:pe), intent(out) :: & + z0mpc, &! z0m for individual PFT + rst, &! stomatal resistance + assim, &! rate of assimilation + respc, &! rate of respiration + fsenl, &! sensible heat from leaves [W/m2] + fevpl, &! evaporation+transpiration from leaves [mm/s] + etr, &! transpiration rate [mm/s] + hprl ! precipitation sensible heat from canopy real(r8), intent(inout) :: & - z0m, &! effective roughness [m] - zol, &! dimensionless height (z/L) used in Monin-Obukhov theory - rib, &! bulk Richardson number in surface layer - ustar, &! friction velocity [m/s] - tstar, &! temperature scaling parameter - qstar, &! moisture scaling parameter - fm, &! integral of profile function for momentum - fh, &! integral of profile function for heat - fq ! integral of profile function for moisture + z0m, &! effective roughness [m] + zol, &! dimensionless height (z/L) used in Monin-Obukhov theory + rib, &! bulk Richardson number in surface layer + ustar, &! friction velocity [m/s] + tstar, &! temperature scaling parameter + qstar, &! moisture scaling parameter + fm, &! integral of profile function for momentum + fh, &! integral of profile function for heat + fq ! integral of profile function for moisture real(r8), intent(inout) :: & - cgrnd, &! deriv. of soil energy flux wrt to soil temp [w/m2/k] - cgrndl, &! deriv, of soil latent heat flux wrt soil temp [w/m2/k] - cgrnds ! deriv of soil sensible heat flux wrt soil temp [w/m**2/k] + cgrnd, &! deriv. of soil energy flux wrt to soil temp [w/m2/k] + cgrndl, &! deriv, of soil latent heat flux wrt soil temp [w/m2/k] + cgrnds ! deriv of soil sensible heat flux wrt soil temp [w/m**2/k] !-----------------------Local Variables--------------------------------- ! assign iteration parameters @@ -271,91 +255,128 @@ SUBROUTINE LeafTempPC (ipatch,npft,deltim,csoilc,dewmx ,htvp ,& real(r8),parameter :: dtmin = 0.01 !max limit for temperature convergence [K] real(r8),parameter :: dlemin = 0.1 !max limit for energy flux convergence [w/m2] - real(r8) dtl(0:itmax+1,npft) !difference of tl between two iterative step + real(r8) dtl(0:itmax+1,ps:pe) !difference of tl between two iterative step + + !TODO: read from mod_const_pft.F90 + real(r8), dimension(ps:pe) :: & + canlay, &! PFT canopy layer number + sqrtdi ! inverse sqrt of leaf dimension [m**-0.5] + + !TODO: read from mod_const_pft.F90 file + real(r8), dimension(ps:pe) :: & + effcon, &! quantum efficiency of RuBP regeneration (mol CO2 / mol quanta) + vmax25, &! maximum carboxylation rate at 25 C at canopy top + ! the range : 30.e-6 <-> 100.e-6 (mol co2 m-2 s-1) + shti, &! slope of high temperature inhibition function (s1) + hhti, &! 1/2 point of high temperature inhibition function (s2) + slti, &! slope of low temperature inhibition function (s3) + hlti, &! 1/2 point of low temperature inhibition function (s4) + trda, &! temperature coefficient in gs-a model (s5) + trdm, &! temperature coefficient in gs-a model (s6) + trop, &! temperature coefficient in gs-a model (273+25) + g1, &! conductance-photosynthesis slope parameter for medlyn model + g0, &! conductance-photosynthesis intercept for medlyn model + gradm, &! conductance-photosynthesis slope parameter + binter, &! conductance-photosynthesis intercept + extkn ! coefficient of leaf nitrogen allocation + + real(r8), dimension(ps:pe) :: & + kmax_sun, &! Plant Hydraulics Paramters + kmax_sha, &! Plant Hydraulics Paramters + kmax_xyl, &! Plant Hydraulics Paramters + kmax_root, &! Plant Hydraulics Paramters + psi50_sun, &! water potential at 50% loss of sunlit leaf tissue conductance (mmH2O) + psi50_sha, &! water potential at 50% loss of shaded leaf tissue conductance (mmH2O) + psi50_xyl, &! water potential at 50% loss of xylem tissue conductance (mmH2O) + psi50_root, &! water potential at 50% loss of root tissue conductance (mmH2O) + ck ! shape-fitting parameter for vulnerability curve (-) real(r8) :: & - zldis, &! reference height "minus" zero displacement heght [m] - zii, &! convective boundary layer height [m] - z0mv, &! roughness length, momentum [m] - z0hv, &! roughness length, sensible heat [m] - z0qv, &! roughness length, latent heat [m] - zeta, &! dimensionless height used in Monin-Obukhov theory - beta, &! coefficient of conective velocity [-] - wc, &! convective velocity [m/s] - wc2, &! wc**2 - dth, &! diff of virtual temp. between ref. height and surface - dthv, &! diff of vir. poten. temp. between ref. height and surface - dqh, &! diff of humidity between ref. height and surface - obu, &! monin-obukhov length (m) - um, &! wind speed including the stablity effect [m/s] - ur, &! wind speed at reference height [m/s] - uaf, &! velocity of air within foliage [m/s] - fh2m, &! relation for temperature at 2m - fq2m, &! relation for specific humidity at 2m - fm10m, &! integral of profile function for momentum at 10m - thvstar, &! virtual potential temperature scaling parameter - eah, &! canopy air vapor pressure (pa) - pco2g, &! co2 pressure (pa) at ground surface (pa) - pco2a, &! canopy air co2 pressure (pa) - - fdry(npft), &! fraction of foliage that is green and dry [-] - fwet(npft), &! fraction of foliage covered by water [-] - cf, &! heat transfer coefficient from leaves [-] - rb(npft), &! leaf boundary layer resistance [s/m] - rbone, &! canopy bulk boundary layer resistance - rbsun, &! bulk boundary layer resistance of sunlit fraction of canopy - rbsha, &! bulk boundary layer resistance of shaded fraction of canopy - ram, &! aerodynamical resistance [s/m] - rah, &! thermal resistance [s/m] - raw, &! moisture resistance [s/m] - clai, &! canopy heat capacity [Jm-2K-1] - cfh(npft), &! heat conductance for leaf [m/s] - cfw(npft), &! latent heat conductance for leaf [m/s] - wtl0(npft), &! normalized heat conductance for air and leaf [-] - wtlq0(npft),&! normalized latent heat cond. for air and leaf [-] - - ei(npft), &! vapor pressure on leaf surface [pa] - deidT(npft),&! derivative of "ei" on "tl" [pa/K] - qsatl(npft),&! leaf specific humidity [kg/kg] - qsatldT(npft),&! derivative of "qsatl" on "tlef" - - del(npft), &! absolute change in leaf temp in current iteration [K] - del2(npft), &! change in leaf temperature in previous iteration [K] - dele(npft), &! change in heat fluxes from leaf [W/m2] - dele2(npft),&! change in heat fluxes from leaf in previous iteration [W/m2] - det, &! maximum leaf temp. change in two consecutive iter [K] - dee, &! maximum leaf heat fluxes change in two consecutive iter [W/m2] - - obuold, &! monin-obukhov length from previous iteration - tlbef(npft),&! leaf temperature from previous iteration [K] - err, &! balance error - - fsha(npft), &! shaded fraction of canopy - laisun(npft), &! sunlit leaf area index, one-sided - laisha(npft), &! shaded leaf area index, one-sided - rssun(npft), &! sunlit leaf stomatal resistance [s/m] - rssha(npft), &! shaded leaf stomatal resistance [s/m] - respcsun(npft),&! sunlit leaf respiration rate [umol co2 /m**2/ s] [+] - respcsha(npft),&! shaded leaf respiration rate [umol co2 /m**2/ s] [+] - - rsoil, &! soil respiration - gah2o, &! conductance between canopy and atmosphere - gdh2o, &! conductance between canopy and ground - tprcor, &! tf*psur*100./1.013e5 - - fht, &! integral of profile function for heat at the top layer - fqt, &! integral of profile function for moisture at the top layer - phih ! phi(h), similarity function for sensible heat + rootfr(nl_soil,ps:pe) ! root fraction + real(r8) :: & + zldis, &! reference height "minus" zero displacement heght [m] + zii, &! convective boundary layer height [m] + z0mv, &! roughness length, momentum [m] + z0hv, &! roughness length, sensible heat [m] + z0qv, &! roughness length, latent heat [m] + zeta, &! dimensionless height used in Monin-Obukhov theory + beta, &! coefficient of conective velocity [-] + wc, &! convective velocity [m/s] + wc2, &! wc**2 + dth, &! diff of virtual temp. between ref. height and surface + dthv, &! diff of vir. poten. temp. between ref. height and surface + dqh, &! diff of humidity between ref. height and surface + obu, &! monin-obukhov length (m) + um, &! wind speed including the stablity effect [m/s] + ur, &! wind speed at reference height [m/s] + uaf, &! velocity of air within foliage [m/s] + fh2m, &! relation for temperature at 2m + fq2m, &! relation for specific humidity at 2m + fm10m, &! integral of profile function for momentum at 10m + thvstar, &! virtual potential temperature scaling parameter + eah, &! canopy air vapor pressure (pa) + pco2g, &! co2 pressure (pa) at ground surface (pa) + pco2a, &! canopy air co2 pressure (pa) + + cf, &! heat transfer coefficient from leaves [-] + rbsun, &! bulk boundary layer resistance of sunlit fraction of canopy + rbsha, &! bulk boundary layer resistance of shaded fraction of canopy + ram, &! aerodynamical resistance [s/m] + rah, &! thermal resistance [s/m] + raw, &! moisture resistance [s/m] + clai, &! canopy heat capacity [Jm-2K-1] + + det, &! maximum leaf temp. change in two consecutive iter [K] + dee, &! maximum leaf heat fluxes change in two consecutive iter [W/m2] + obuold, &! monin-obukhov length from previous iteration + err, &! balance error + + rsoil, &! soil respiration + gah2o, &! conductance between canopy and atmosphere + gdh2o, &! conductance between canopy and ground + tprcor, &! tf*psur*100./1.013e5 + + fht, &! integral of profile function for heat at the top layer + fqt, &! integral of profile function for moisture at the top layer + phih, &! phi(h), similarity function for sensible heat + + fdry (ps:pe), &! fraction of foliage that is green and dry [-] + fwet (ps:pe), &! fraction of foliage covered by water [-] + rb (ps:pe), &! leaf boundary layer resistance [s/m] + cfh (ps:pe), &! heat conductance for leaf [m/s] + cfw (ps:pe), &! latent heat conductance for leaf [m/s] + wtl0 (ps:pe), &! normalized heat conductance for air and leaf [-] + wtlq0 (ps:pe), &! normalized latent heat cond. for air and leaf [-] + + ei (ps:pe), &! vapor pressure on leaf surface [pa] + deidT (ps:pe), &! derivative of "ei" on "tl" [pa/K] + qsatl (ps:pe), &! leaf specific humidity [kg/kg] + qsatldT (ps:pe), &! derivative of "qsatl" on "tlef" + + del (ps:pe), &! absolute change in leaf temp in current iteration [K] + del2 (ps:pe), &! change in leaf temperature in previous iteration [K] + dele (ps:pe), &! change in heat fluxes from leaf [W/m2] + dele2 (ps:pe), &! change in heat fluxes from leaf in previous iteration [W/m2] + + tlbef (ps:pe), &! leaf temperature from previous iteration [K] + fsha (ps:pe), &! shaded fraction of canopy + laisun (ps:pe), &! sunlit leaf area index, one-sided + laisha (ps:pe), &! shaded leaf area index, one-sided + rssun (ps:pe), &! sunlit leaf stomatal resistance [s/m] + rssha (ps:pe), &! shaded leaf stomatal resistance [s/m] + respcsun (ps:pe), &! sunlit leaf respiration rate [umol co2 /m**2/ s] [+] + respcsha (ps:pe) ! shaded leaf respiration rate [umol co2 /m**2/ s] [+] integer it, nmozsgn - real(r8) delta(npft), fac(npft), etr0(npft) - real(r8) evplwet(npft), evplwet_dtl(npft), etr_dtl(npft), elwmax, elwdif - real(r8) irab(npft), dirab_dtl(npft), fsenl_dtl(npft), fevpl_dtl(npft) - real(r8) w, csoilcn, z0mg, z0hg, z0qg, cintsun(3, npft), cintsha(3, npft) - real(r8), dimension(npft) :: fevpl_bef, fevpl_noadj, dtl_noadj, erre - real(r8),dimension(npft) :: gb_mol_sun,gb_mol_sha + real(r8) w, csoilcn, z0mg, z0hg, z0qg, elwmax, elwdif, sumrootflux + real(r8) cintsun(3, ps:pe), cintsha(3, ps:pe) + real(r8),dimension(ps:pe) :: delta, fac, etr0 + real(r8),dimension(ps:pe) :: irab, dirab_dtl, fsenl_dtl, fevpl_dtl + real(r8),dimension(ps:pe) :: evplwet, evplwet_dtl, etr_dtl + real(r8),dimension(ps:pe) :: fevpl_bef, fevpl_noadj, dtl_noadj, erre + real(r8),dimension(ps:pe) :: gb_mol_sun,gb_mol_sha real(r8),dimension(nl_soil) :: k_soil_root ! radial root and soil conductance real(r8),dimension(nl_soil) :: k_ax_root ! axial root conductance @@ -385,7 +406,7 @@ SUBROUTINE LeafTempPC (ipatch,npft,deltim,csoilc,dewmx ,htvp ,& displa_lays, &! displacement height for the layer and below fcover_lays ! vegetation fractional cover for this layer and above - real(r8), dimension(npft) :: & + real(r8), dimension(ps:pe) :: & lsai ! lai + sai real(r8), dimension(nlay) :: & @@ -425,11 +446,12 @@ SUBROUTINE LeafTempPC (ipatch,npft,deltim,csoilc,dewmx ,htvp ,& real(r8) :: ktop, utop, fmtop, bee, tmpw1, tmpw2, fact, facq - integer i, clev + logical is_vegetated_patch + integer i, p, clev integer toplay, botlay, upplay, numlay integer d_opt, rb_opt, rd_opt - real(r8) :: displa + real(r8) :: displa, ttaf, tqaf ! variables for longwave transfer calculation ! ................................................................. @@ -444,12 +466,30 @@ SUBROUTINE LeafTempPC (ipatch,npft,deltim,csoilc,dewmx ,htvp ,& real(r8) :: Ld(0:4) !total downward longwave radiation for each layer real(r8) :: Lu(0:4) !total upward longwave radiation for each layer real(r8) :: Lg !emitted longwave radiation from ground - real(r8) :: Lv(npft) !absorbed longwave raidation for each pft - real(r8) :: dLv(npft) !LW change due to temperature change + real(r8) :: Lv(ps:pe) !absorbed longwave raidation for each pft + real(r8) :: dLv(ps:pe) !LW change due to temperature change real(r8) :: dLvpar(nlay) !temporal variable for calcualting dLv !-----------------------End Variable List------------------------------- +! only process with vegetated patches + + lsai(:) = lai(:) + sai(:) + is_vegetated_patch = .false. + + DO i = ps, pe + IF (fcover(i)>0 .and. lsai(i)>1.e-6) THEN + is_vegetated_patch = .true. + ELSE + tl(i) = forc_t + ENDIF + ENDDO + + IF (.not. is_vegetated_patch) THEN + print *, "NOTE: There is no vegetation in this Plant Community Patch, RETURN." + RETURN + ENDIF + ! initialization of errors and iteration parameters it = 1 !counter for leaf temperature iteration del(:) = 0.0 !change in leaf temperature from previous iteration @@ -467,6 +507,44 @@ SUBROUTINE LeafTempPC (ipatch,npft,deltim,csoilc,dewmx ,htvp ,& z0hg = z0mg z0qg = z0mg + !clai = 4.2 * 1000. * 0.2 + clai = 0.0 + +! initialization of PFT constants + DO i = ps, pe + p = pftclass(i) + + canlay (i) = canlay_p (p) + sqrtdi (i) = sqrtdi_p (p) + + effcon (i) = effcon_p (p) + vmax25 (i) = vmax25_p (p) + shti (i) = shti_p (p) + hhti (i) = hhti_p (p) + slti (i) = slti_p (p) + hlti (i) = hlti_p (p) + trda (i) = trda_p (p) + trdm (i) = trdm_p (p) + trop (i) = trop_p (p) + g1 (i) = g1_p (p) + g0 (i) = g0_p (p) + gradm (i) = gradm_p (p) + binter (i) = binter_p (p) + extkn (i) = extkn_p (p) + + kmax_sun (i) = kmax_sun_p (p) + kmax_sha (i) = kmax_sha_p (p) + kmax_xyl (i) = kmax_xyl_p (p) + kmax_root (i) = kmax_root_p (p) + psi50_sun (i) = psi50_sun_p (p) + psi50_sha (i) = psi50_sha_p (p) + psi50_xyl (i) = psi50_xyl_p (p) + psi50_root (i) = psi50_root_p (p) + ck (i) = ck_p (p) + + rootfr (:,i) = rootfr_p (:,p) + ENDDO + !----------------------------------------------------------------------- ! scaling-up coefficients from leaf to canopy !----------------------------------------------------------------------- @@ -493,11 +571,7 @@ SUBROUTINE LeafTempPC (ipatch,npft,deltim,csoilc,dewmx ,htvp ,& ! initial saturated vapor pressure and humidity and their derivation !----------------------------------------------------------------------- - !clai = 4.2 * 1000. * 0.2 - clai = 0.0 - lsai(:) = lai(:) + sai(:) - - DO i = 1, npft + DO i = ps, pe IF (fcover(i)>0 .and. lsai(i)>1.e-6) THEN CALL dewfraction (sigf(i),lai(i),sai(i),dewmx,ldew(i),ldew_rain(i),ldew_snow(i),fwet(i),fdry(i)) CALL qsadv(tl(i),psrf,ei(i),deiDT(i),qsatl(i),qsatlDT(i)) @@ -522,9 +596,9 @@ SUBROUTINE LeafTempPC (ipatch,npft,deltim,csoilc,dewmx ,htvp ,& lsai_lay(:) = 0 fcover_lay(:) = 0 - DO i = 1, npft + DO i = ps, pe IF (fcover(i)>0 .and. lsai(i)>1.e-6) THEN - clev = canlev(i) + clev = canlay(i) htop_lay(clev) = htop_lay(clev) + htop(i) * fcover(i) hbot_lay(clev) = hbot_lay(clev) + hbot(i) * fcover(i) lsai_lay(clev) = lsai_lay(clev) + lsai(i) * fcover(i) @@ -558,7 +632,7 @@ SUBROUTINE LeafTempPC (ipatch,npft,deltim,csoilc,dewmx ,htvp ,& !----------------------------------------------------------------------- ! calculate z0m and displa for PFTs !----------------------------------------------------------------------- - DO i = 1, npft + DO i = ps, pe IF (lsai(i) > 1.e-6) THEN CALL cal_z0_displa(lsai(i), htop(i), 1., z0mpc(i), displa) ELSE @@ -577,21 +651,18 @@ SUBROUTINE LeafTempPC (ipatch,npft,deltim,csoilc,dewmx ,htvp ,& DO i = 1, nlay IF (fcover_lay(i)>0 .and. lsai_lay(i)>0) THEN - CALL cal_z0_displa(lsai_lay(i), htop_lay(i), 1., z0m_lay(i), displa_lay(i)) - CALL cal_z0_displa(lsai_lay(i), htop_lay(i), fcover_lay(i), z0m_lays(i), displa_lays(i)) - ENDIF ENDDO ! ground - z0m_lays(0) = z0mg + z0m_lays (0) = z0mg displa_lays(0) = 0. ! 10/05/2017: robust check WHERE (z0m_lays(:) < z0mg) z0m_lays(:) = z0mg - WHERE (z0m_lay(:) < z0mg) z0m_lay(:) = z0mg + WHERE (z0m_lay (:) < z0mg) z0m_lay (:) = z0mg ! maximum assumption z0m_lays(1) = maxval(z0m_lays(0:1)) @@ -611,7 +682,7 @@ SUBROUTINE LeafTempPC (ipatch,npft,deltim,csoilc,dewmx ,htvp ,& ! calculate layer a_lay !----------------------------------------------------------------------- ! initialization - a_lay(:) = 0. + a_lay (:) = 0. a_lay_i63(:) = 0. a_lay_k71(:) = 0. a_lay_g77(:) = 0. @@ -624,12 +695,12 @@ SUBROUTINE LeafTempPC (ipatch,npft,deltim,csoilc,dewmx ,htvp ,& lm = vonkar*(htop_lay(i) - displa_lay(i)) ! Raupach, 1992 - fai = 1. - exp(-0.5*lsai_lay(i)) + fai = 1. - exp(-0.5*lsai_lay(i)) sqrtdragc = min( (0.003+0.3*fai)**0.5, 0.3 ) ! Inoue, 1963 a_lay_i63(i) = htop_lay(i) * & - (Cd*lsai_lay(i)/(2.*htop_lay(i)*lm**2))**(1./3.) + (Cd*lsai_lay(i)/(2.*htop_lay(i)*lm**2))**(1./3.) ! Kondo, 1971 a_lay_k71(i) = htop_lay(i)/(htop_lay(i)-displa_lay(i))/ & @@ -682,9 +753,9 @@ SUBROUTINE LeafTempPC (ipatch,npft,deltim,csoilc,dewmx ,htvp ,& thermk_lay(:) = 0. fshade_lay(:) = 0. - DO i = 1, npft - IF (fshade(i) > 0) THEN - clev = canlev(i) + DO i = ps, pe + IF (fshade(i)>0 .and. canlay(i)>0) THEN + clev = canlay(i) thermk_lay(clev) = thermk_lay(clev) + fshade(i) * thermk(i) fshade_lay(clev) = fshade_lay(clev) + fshade(i) ENDIF @@ -789,10 +860,10 @@ SUBROUTINE LeafTempPC (ipatch,npft,deltim,csoilc,dewmx ,htvp ,& ! initialization and input values for Monin-Obukhov ! have been set before z0mv = z0m_lays(3); z0hv = z0m_lays(3); z0qv = z0m_lays(3) - ur = max(0.1, sqrt(us*us+vs*vs)) !limit set to 0.1 - dth = thm - taf(toplay) - dqh = qm - qaf(toplay) - dthv = dth*(1.+0.61*qm) + 0.61*th*dqh + ur = max(0.1, sqrt(us*us+vs*vs)) !limit set to 0.1 + dth = thm - taf(toplay) + dqh = qm - qaf(toplay) + dthv = dth*(1.+0.61*qm) + 0.61*th*dqh zldis = hu - displa_lays(3) IF(zldis <= 0.0) THEN @@ -820,12 +891,12 @@ SUBROUTINE LeafTempPC (ipatch,npft,deltim,csoilc,dewmx ,htvp ,& IF (DEF_USE_CBL_HEIGHT) THEN CALL moninobukm_leddy(hu,ht,hq,displa_lays(toplay),z0mv,z0hv,z0qv,obu,um, & - displa_lay(toplay),z0m_lay(toplay), hpbl, ustar,fh2m,fq2m, & - htop_lay(toplay),fmtop,fm,fh,fq,fht,fqt,phih) + displa_lay(toplay),z0m_lay(toplay),hpbl,ustar,fh2m,fq2m, & + htop_lay(toplay),fmtop,fm,fh,fq,fht,fqt,phih) ELSE CALL moninobukm(hu,ht,hq,displa_lays(toplay),z0mv,z0hv,z0qv,obu,um, & - displa_lay(toplay),z0m_lay(toplay),ustar,fh2m,fq2m, & - htop_lay(toplay),fmtop,fm,fh,fq,fht,fqt,phih) + displa_lay(toplay),z0m_lay(toplay),ustar,fh2m,fq2m, & + htop_lay(toplay),fmtop,fm,fh,fq,fht,fqt,phih) ENDIF ! Aerodynamic resistance @@ -881,18 +952,18 @@ SUBROUTINE LeafTempPC (ipatch,npft,deltim,csoilc,dewmx ,htvp ,& ELSE ! calculate utop of this layer utop_lay(i) = uprofile(ubot_lay(upplay), fcover_lays(upplay), bee, 0., & - z0mg, hbot_lay(upplay), htop_lay(i), htop_lay(i)) + z0mg, hbot_lay(upplay), htop_lay(i), htop_lay(i)) ! calculate ktop of this layer ktop_lay(i) = kprofile(kbot_lay(upplay), fcover_lays(upplay), bee, 0., & - displa_lays(toplay)/htop_lay(toplay), & - hbot_lay(upplay), htop_lay(i), obug, ustarg, htop_lay(i)) + displa_lays(toplay)/htop_lay(toplay), & + hbot_lay(upplay), htop_lay(i), obug, ustarg, htop_lay(i)) ! areodynamic resistance between this layer top and above layer bottom - ! 03/15/2020, yuan: TODO, vertical gaps between layers, fc = fcover_lays(upplay) or just 0? + ! 03/15/2020, yuan: vertical gaps between layers, fc = fcover_lays(upplay) or just 0? rd(upplay) = rd(upplay) + frd(kbot_lay(upplay), hbot_lay(upplay), htop_lay(i), & - hbot_lay(upplay), htop_lay(i), displa_lays(toplay)/htop_lay(toplay), & - z0h_g, obug, ustarg, z0mg, 0., bee, fcover_lays(upplay)) + hbot_lay(upplay), htop_lay(i), displa_lays(toplay)/htop_lay(toplay), & + z0h_g, obug, ustarg, z0mg, 0., bee, fcover_lays(upplay)) ENDIF @@ -901,31 +972,31 @@ SUBROUTINE LeafTempPC (ipatch,npft,deltim,csoilc,dewmx ,htvp ,& ! wind speed at layer bottom ubot_lay(i) = uprofile(utop_lay(i), fcover_lay(i), bee, a_lay(i), & - z0mg, htop_lay(i), hbot_lay(i), hbot_lay(i)) + z0mg, htop_lay(i), hbot_lay(i), hbot_lay(i)) IF (it == 1) THEN ueff_lay_norm(i) = ueffect(1., htop_lay(i), hbot_lay(i), & - z0mg, a_lay(i), bee, fcover_lay(i)) + z0mg, a_lay(i), bee, fcover_lay(i)) ENDIF ueff_lay(i) = utop_lay(i)*ueff_lay_norm(i) ! normalized eddy coefficient (K) at layer bottom kbot_lay(i) = kprofile(ktop_lay(i), fcover_lay(i), bee, a_lay(i), & - displa_lays(toplay)/htop_lay(toplay), & - htop_lay(i), hbot_lay(i), obug, ustarg, hbot_lay(i)) + displa_lays(toplay)/htop_lay(toplay), & + htop_lay(i), hbot_lay(i), obug, ustarg, hbot_lay(i)) ! areodynamic resistance from effective fluxes exchange height of ! of this layer to the top of this layer IF (upplay > 0) THEN rd(upplay) = rd(upplay) + frd(ktop_lay(i), htop_lay(i), hbot_lay(i), & - htop_lay(i), displa_lay(i)+z0m_lay(i), displa_lays(toplay)/htop_lay(toplay), & - z0h_g, obug, ustarg, z0mg, a_lay(i), bee, fcover_lay(i)) + htop_lay(i), displa_lay(i)+z0m_lay(i), displa_lays(toplay)/htop_lay(toplay), & + z0h_g, obug, ustarg, z0mg, a_lay(i), bee, fcover_lay(i)) ENDIF rd(i) = rd(i) + frd(ktop_lay(i), htop_lay(i), hbot_lay(i), & - displa_lay(i)+z0m_lay(i), max(z0qg,hbot_lay(i)), & - displa_lays(toplay)/htop_lay(toplay), z0h_g, obug, ustarg, & - z0mg, a_lay(i), bee, fcover_lay(i)) + displa_lay(i)+z0m_lay(i), max(z0qg,hbot_lay(i)), & + displa_lays(toplay)/htop_lay(toplay), z0h_g, obug, ustarg, & + z0mg, a_lay(i), bee, fcover_lay(i)) upplay = i @@ -938,21 +1009,21 @@ SUBROUTINE LeafTempPC (ipatch,npft,deltim,csoilc,dewmx ,htvp ,& ! uncomment the below when the upper codes change to hbot_lay !rd(botlay) = rd(botlay) + kintegral(kbot_lay(botlay), fcover_lays(botlay), bee, 0., & - ! z0mg, displa_lays(toplay)/htop_lay(toplay), & - ! hbot_lay(botlay), z0qg, obug, ustarg, hbot_lay(botlay), z0qg ) + ! z0mg, displa_lays(toplay)/htop_lay(toplay), & + ! hbot_lay(botlay), z0qg, obug, ustarg, hbot_lay(botlay), z0qg ) rd(botlay) = rd(botlay) + frd(kbot_lay(botlay), hbot_lay(botlay), z0qg, & - hbot_lay(botlay), z0qg, displa_lays(toplay)/htop_lay(toplay), & - z0h_g, obug, ustarg, z0mg, 0., bee, fcover_lays(botlay)) + hbot_lay(botlay), z0qg, displa_lays(toplay)/htop_lay(toplay), & + z0h_g, obug, ustarg, z0mg, 0., bee, fcover_lays(botlay)) ! ...................................................................... ! Bulk boundary layer resistance of leaves ! ...................................................................... rb(:) = 0. - DO i = 1, npft + DO i = ps, pe IF (fcover(i)>0 .and. lsai(i)>1.e-6) THEN - clev = canlev(i) + clev = canlay(i) cf = 0.01*sqrtdi(i)*sqrt(ueff_lay(clev)) rb(i) = 1./cf ENDIF @@ -983,77 +1054,86 @@ SUBROUTINE LeafTempPC (ipatch,npft,deltim,csoilc,dewmx ,htvp ,& ! stomatal resistances !----------------------------------------------------------------------- - DO i = 1, npft + DO i = ps, pe + p = pftclass(i) IF(fcover(i)>0 .and. lai(i)>0.001) THEN rbsun = rb(i) / laisun(i) rbsha = rb(i) / laisha(i) - clev = canlev(i) + clev = canlay(i) eah = qaf(clev) * psrf / ( 0.622 + 0.378 * qaf(clev) ) !pa - IF(DEF_USE_OZONESTRESS)THEN - CALL CalcOzoneStress(o3coefv_sun(i),o3coefg_sun(i),forc_ozone,psrf,th,ram,& - rssun(i),rbsun,lai(i),lai_old(i),i,o3uptakesun(i),deltim) - CALL CalcOzoneStress(o3coefv_sha(i),o3coefg_sha(i),forc_ozone,psrf,th,ram,& - rssha(i),rbsha,lai(i),lai_old(i),i,o3uptakesha(i),deltim) - lai_old(i) = lai(i) - ENDIF - IF(DEF_USE_PLANTHYDRAULICS)THEN - CALL PlantHydraulicStress_twoleaf (nl_soil ,nvegwcs ,z_soi ,& - dz_soi ,rootfr(:,i),psrf ,qsatl(i) ,qsatl(i) ,& - qaf(clev) ,tl(i) ,tl(i) ,rbsun ,rbsha ,& - raw ,rd(clev) ,rstfacsun(i),rstfacsha(i),cintsun(:,i),& - cintsha(:,i),laisun(i),laisha(i) ,rhoair ,fwet(i) ,& - sai(i) ,kmax_sun(i),kmax_sha(i),kmax_xyl(i),kmax_root(i),& - psi50_sun(i),psi50_sha(i),psi50_xyl(i),psi50_root(i),htop(i),& - ck(i) ,smp ,hk ,hksati ,vegwp(:,i) ,& - etrsun(i) ,etrsha(i) ,rootr(:,i) ,sigf(i) ,qg ,& - qm ,gs0sun(i) ,gs0sha(i) ,k_soil_root,k_ax_root ) - etr(i) = etrsun(i) + etrsha(i) + IF (DEF_USE_PLANTHYDRAULICS) THEN + rstfacsun(i) = 1. + rstfacsha(i) = 1. END IF ! note: calculate resistance for sunlit/shaded leaves !----------------------------------------------------------------------- - CALL stomata (vmax25(i) ,effcon(i) ,slti(i) ,hlti(i) ,& - shti(i) ,hhti(i) ,trda(i) ,trdm(i) ,trop(i) ,& - gradm(i) ,binter(i) ,thm ,psrf ,po2m ,& - pco2m ,pco2a ,eah ,ei(i) ,tl(i) , parsun(i) ,& + CALL stomata ( vmax25(i) ,effcon(i) ,slti(i) ,hlti(i) ,& + shti(i) ,hhti(i) ,trda(i) ,trdm(i) ,trop(i) ,& + g1(i) ,g0(i) ,gradm(i) ,binter(i) ,thm ,& + psrf ,po2m ,pco2m ,pco2a ,eah ,& + ei(i) ,tl(i) ,parsun(i) ,& !Ozone stress variables - o3coefv_sun(i), o3coefg_sun(i), & + o3coefv_sun(i), o3coefg_sun(i),& !End ozone stress variables - rbsun ,raw ,rstfacsun(i),cintsun(:,i),& - assimsun(i),respcsun(i),rssun(i) & - ) - - CALL stomata (vmax25(i) ,effcon(i) ,slti(i) ,hlti(i) ,& - shti(i) ,hhti(i) ,trda(i) ,trdm(i) ,trop(i) ,& - gradm(i) ,binter(i) ,thm ,psrf ,po2m ,& - pco2m ,pco2a ,eah ,ei(i) ,tl(i) ,parsha(i) ,& + rbsun ,raw ,rstfacsun(i),cintsun(:,i),& + assimsun(i),respcsun(i),rssun(i) ) + + CALL stomata ( vmax25(i) ,effcon(i) ,slti(i) ,hlti(i) ,& + shti(i) ,hhti(i) ,trda(i) ,trdm(i) ,trop(i) ,& + g1(i) ,g0(i) ,gradm(i) ,binter(i) ,thm ,& + psrf ,po2m ,pco2m ,pco2a ,eah ,& + ei(i) ,tl(i) ,parsha(i) ,& !Ozone stress variables - o3coefv_sun(i), o3coefg_sun(i), & + o3coefv_sun(i), o3coefg_sun(i),& !End ozone stress variables - rbsha ,raw ,rstfacsha(i) ,cintsha(:,i),& - assimsha(i),respcsha(i),rssha(i) & - ) - - IF(DEF_USE_PLANTHYDRAULICS)THEN - gssun(i) = min( 1.e6, 1./(rssun(i)*tl(i)/tprcor) ) / cintsun(3,i) * 1.e6 - gssha(i) = min( 1.e6, 1./(rssha(i)*tl(i)/tprcor) ) / cintsha(3,i) * 1.e6 - gs0sun(i) = gssun(i)/amax1(rstfacsun(i),1.e-2) - gs0sha(i) = gssha(i)/amax1(rstfacsha(i),1.e-2) - - gb_mol_sun(i) = 1./rbsun * tprcor/tl(i) / cintsun(3,i) * 1.e6 ! leaf to canopy - gb_mol_sha(i) = 1./rbsha * tprcor/tl(i) / cintsha(3,i) * 1.e6 ! leaf to canopy - END IF + rbsha ,raw ,rstfacsha(i),cintsha(:,i),& + assimsha(i),respcsha(i),rssha(i) ) + + IF (DEF_USE_PLANTHYDRAULICS) THEN + + gs0sun(i) = min( 1.e6, 1./(rssun(i)*tl(i)/tprcor) )/ laisun(i) * 1.e6 + gs0sha(i) = min( 1.e6, 1./(rssha(i)*tl(i)/tprcor) )/ laisha(i) * 1.e6 + + CALL PlantHydraulicStress_twoleaf (nl_soil ,nvegwcs ,z_soi ,& + dz_soi ,rootfr(:,i) ,psrf ,qsatl(i) ,qaf(clev) ,& + tl(i) ,rbsun ,rss ,raw ,sum(rd(1:clev)),& + rstfacsun(i) ,rstfacsha(i) ,cintsun(:,i) ,cintsha(:,i) ,laisun(i) ,& + laisha(i) ,rhoair ,fwet(i) ,sai(i) ,kmax_sun(i) ,& + kmax_sha(i) ,kmax_xyl(i) ,kmax_root(i) ,psi50_sun(i) ,psi50_sha(i) ,& + psi50_xyl(i) ,psi50_root(i),htop(i) ,ck(i) ,smp ,& + hk ,hksati ,vegwp(:,i) ,etrsun(i) ,etrsha(i) ,& + rootflux(:,i),qg ,qm ,gs0sun(i) ,gs0sha(i) ,& + k_soil_root ,k_ax_root ,gssun(i) ,gssha(i) ) + + etr(i) = etrsun(i) + etrsha(i) + gssun(i) = gssun(i) * laisun(i) + gssha(i) = gssha(i) * laisha(i) + + CALL update_photosyn(tl(i), po2m, pco2m, pco2a, parsun(i), psrf, rstfacsun(i), rb(i), gssun(i), & + effcon(i), vmax25(i), gradm(i), trop(i), slti(i), hlti(i), shti(i), hhti(i), & + trda(i), trdm(i), cintsun(:,i), assimsun(i), respcsun(i)) + + CALL update_photosyn(tl(i), po2m, pco2m, pco2a, parsha(i), psrf, rstfacsha(i), rb(i), gssha(i), & + effcon(i), vmax25(i), gradm(i), trop(i), slti(i), hlti(i), shti(i), hhti(i), & + trda(i), trdm(i), cintsha(:,i), assimsha(i), respcsha(i)) + + ! leaf scale stomata resisitence + rssun(i) = tprcor / tl(i) * 1.e6 /gssun(i) + rssha(i) = tprcor / tl(i) * 1.e6 /gssha(i) + + ENDIF ELSE rssun(i) = 2.e4; assimsun(i) = 0.; respcsun(i) = 0. rssha(i) = 2.e4; assimsha(i) = 0.; respcsha(i) = 0. - IF(DEF_USE_PLANTHYDRAULICS)THEN + IF (DEF_USE_PLANTHYDRAULICS) THEN etr(i) = 0. - rootr(:,i) = 0. - END IF + rootflux(:,i) = 0. + ENDIF ENDIF ENDDO @@ -1070,10 +1150,10 @@ SUBROUTINE LeafTempPC (ipatch,npft,deltim,csoilc,dewmx ,htvp ,& cfh(:) = 0. cfw(:) = 0. - DO i = 1, npft + DO i = ps, pe IF (fcover(i)>0 .and. lsai(i)>1.e-6) THEN - clev = canlev(i) + clev = canlay(i) delta(i) = 0.0 IF(qsatl(i)-qaf(clev) .gt. 0.) delta(i) = 1.0 @@ -1104,7 +1184,19 @@ SUBROUTINE LeafTempPC (ipatch,npft,deltim,csoilc,dewmx ,htvp ,& ENDIF cgh(i) = 1. / rd(i) - cgw(i) = 1. / rd(i) + IF (i == botlay) THEN + IF (qg < qaf(botlay)) THEN + cgw(i) = 1. / rd(i) !dew case. no soil resistance + ELSE + IF (DEF_RSS_SCHEME .eq. 4) THEN + cgw(i) = rss/ rd(i) + ELSE + cgw(i) = 1. / (rd(i) + rss) + ENDIF + ENDIF + ELSE + cgw(i) = 1. / rd(i) + ENDIF ENDIF ENDDO @@ -1112,9 +1204,9 @@ SUBROUTINE LeafTempPC (ipatch,npft,deltim,csoilc,dewmx ,htvp ,& wtshi(:) = cah(:) + cgh(:) wtsqi(:) = caw(:) + cgw(:) - DO i = 1, npft + DO i = ps, pe IF (fcover(i)>0 .and. lsai(i)>1.e-6) THEN - clev = canlev(i) + clev = canlay(i) wtshi(clev) = wtshi(clev) + fcover(i)*cfh(i) wtsqi(clev) = wtsqi(clev) + fcover(i)*cfw(i) ENDIF @@ -1137,9 +1229,9 @@ SUBROUTINE LeafTempPC (ipatch,npft,deltim,csoilc,dewmx ,htvp ,& wtll(:) = 0. wtlql(:) = 0. - DO i = 1, npft + DO i = ps, pe IF (fcover(i)>0 .and. lsai(i)>1.e-6) THEN - clev = canlev(i) + clev = canlay(i) wtl0(i) = cfh(i) * wtshi(clev) * fcover(i) wtll(clev) = wtll(clev) + wtl0(i)*tl(i) @@ -1163,7 +1255,7 @@ SUBROUTINE LeafTempPC (ipatch,npft,deltim,csoilc,dewmx ,htvp ,& tmpw1 = wtg0(botlay)*tg + wtll(botlay) fact = 1. - wtg0(toplay)*wta0(botlay) - taf(toplay) = ( wta0(toplay)*thm + wtg0(toplay)*tmpw1 + wtll(toplay) ) / fact + taf(toplay) = ( wta0(toplay)*thm + wtg0(toplay)*tmpw1 + wtll(toplay) ) / fact tmpw1 = wtgq0(botlay)*qg + wtlql(botlay) facq = 1. - wtgq0(toplay)*wtaq0(botlay) @@ -1202,9 +1294,9 @@ SUBROUTINE LeafTempPC (ipatch,npft,deltim,csoilc,dewmx ,htvp ,& ! calculate L for each canopy layer L(:) = 0. - DO i = 1, npft + DO i = ps, pe IF (fcover(i)>0 .and. lsai(i)>1.e-6) THEN - clev = canlev(i) + clev = canlay(i) ! according to absorption = emissivity, fcover -> fshade L(clev) = L(clev) + fshade(i) * (1-thermk(i)) * stefnc * tl(i)**4 ENDIF @@ -1215,7 +1307,7 @@ SUBROUTINE LeafTempPC (ipatch,npft,deltim,csoilc,dewmx ,htvp ,& Ltd(3) = thermk_lay(3) * tdn(4,3) * frl Ltd(2) = thermk_lay(2) * ( tdn(4,2)*frl + tdn(3,2)*(Ltd(3) + L(3)) ) Ltd(1) = thermk_lay(1) * ( tdn(4,1)*frl + tdn(3,1)*(Ltd(3) + L(3)) + & - tdn(2,1)*(Ltd(2) + L(2)) ) + tdn(2,1)*(Ltd(2) + L(2)) ) ! calculate Ld = Ltd + L Ld(0) = 0. @@ -1227,7 +1319,13 @@ SUBROUTINE LeafTempPC (ipatch,npft,deltim,csoilc,dewmx ,htvp ,& ! calcilate Lg = (1-emg)*dlrad + emg*stefnc*tg**4 ! dlrad = Lin(0) +IF (.not.DEF_SPLIT_SOILSNOW) THEN Lg = (1 - emg)*Lin(0) + emg*stefnc*tg**4 +ELSE + Lg = (1 - emg)*Lin(0) & + + (1.-fsno)*emg*stefnc*t_soil**4 & + + fsno*emg*stefnc*t_snow**4 +ENDIF ! calculate Ltu Ltu(1) = thermk_lay(1) * tup(0,1) * Lg @@ -1245,9 +1343,9 @@ SUBROUTINE LeafTempPC (ipatch,npft,deltim,csoilc,dewmx ,htvp ,& ! calculate Lv Lv(:) = 0. - DO i = 1, npft - IF (fshade(i) > 0) THEN - clev = canlev(i) + DO i = ps, pe + IF (fshade(i)>0 .and. canlay(i)>0) THEN + clev = canlay(i) Lv(i) = fshade(i)/fshade_lay(clev) * (1-thermk(i)) * Lin(clev) / fcover(i) & - 2. * fshade(i) * (1-thermk(i)) * stefnc * tl(i)**4 / fcover(i) ENDIF @@ -1255,9 +1353,9 @@ SUBROUTINE LeafTempPC (ipatch,npft,deltim,csoilc,dewmx ,htvp ,& ! calculate delata(Lv) dLv(:) = 0. - DO i = 1, npft - IF (fshade(i) > 0) THEN - clev = canlev(i) + DO i = ps, pe + IF (fshade(i)>0 .and. canlay(i)>0) THEN + clev = canlay(i) dLv(i) = (4.*dLvpar(clev)*(1-emg)*fshade(i)*(1-thermk(i)) - 8.) & * fshade(i) * (1-thermk(i)) * stefnc * tl(i)**3 / fcover(i) ENDIF @@ -1268,11 +1366,11 @@ SUBROUTINE LeafTempPC (ipatch,npft,deltim,csoilc,dewmx ,htvp ,& irab(:) = Lv(:) dirab_dtl(:) = dLv(:) - DO i = 1, npft + DO i = ps, pe IF (fcover(i)>0 .and. lsai(i)>1.e-6) THEN - clev = canlev(i) + clev = canlay(i) fac(i) = 1. - thermk(i) ! sensible heat fluxes and their derivatives @@ -1320,12 +1418,12 @@ SUBROUTINE LeafTempPC (ipatch,npft,deltim,csoilc,dewmx ,htvp ,& ENDIF ENDIF - IF(.not. DEF_USE_PLANTHYDRAULICS)THEN + IF (.not. DEF_USE_PLANTHYDRAULICS) THEN IF(etr(i).ge.etrc(i))THEN etr(i) = etrc(i) etr_dtl(i) = 0. ENDIF - END IF + ENDIF evplwet(i) = rhoair * (1.-delta(i)*(1.-fwet(i))) * lsai(i)/rb(i) & * ( qsatl(i) - qaf(clev) ) @@ -1370,21 +1468,22 @@ SUBROUTINE LeafTempPC (ipatch,npft,deltim,csoilc,dewmx ,htvp ,& !----------------------------------------------------------------------- dtl(it,i) = (sabv(i) + irab(i) - fsenl(i) - hvap*fevpl(i) & - + cpliq*qintr_rain(i)*(t_precip-tl(i)) + cpice*qintr_snow(i)*(t_precip-tl(i))) & - / (lsai(i)*clai/deltim - dirab_dtl(i) + fsenl_dtl(i) + hvap*fevpl_dtl(i) & - + cpliq*qintr_rain(i) + cpice*qintr_snow(i)) + + cpliq*qintr_rain(i)*(t_precip-tl(i)) + cpice*qintr_snow(i)*(t_precip-tl(i))) & + / (lsai(i)*clai/deltim - dirab_dtl(i) + fsenl_dtl(i) + hvap*fevpl_dtl(i) & + + cpliq*qintr_rain(i) + cpice*qintr_snow(i)) + dtl_noadj(i) = dtl(it,i) ! check magnitude of change in leaf temperature limit to maximum allowed value - IF(it .le. itmax) THEN + IF (it .le. itmax) THEN ! put brakes on large temperature excursions IF(abs(dtl(it,i)).gt.delmax)THEN dtl(it,i) = delmax*dtl(it,i)/abs(dtl(it,i)) ENDIF - ! NOTE: could be a bug IF dtl*dtl==0, changed from lt->le + ! NOTE: could be a bug if dtl*dtl==0, changed from lt->le IF((it.ge.2) .and. (dtl(it-1,i)*dtl(it,i).le.0.))THEN dtl(it,i) = 0.5*(dtl(it-1,i) + dtl(it,i)) ENDIF @@ -1399,7 +1498,7 @@ SUBROUTINE LeafTempPC (ipatch,npft,deltim,csoilc,dewmx ,htvp ,& del(i) = sqrt( dtl(it,i)*dtl(it,i) ) dele(i) = dtl(it,i) * dtl(it,i) * & - ( dirab_dtl(i)**2 + fsenl_dtl(i)**2 + hvap*fevpl_dtl(i)**2 ) + ( dirab_dtl(i)**2 + fsenl_dtl(i)**2 + hvap*fevpl_dtl(i)**2 ) dele(i) = sqrt(dele(i)) !----------------------------------------------------------------------- @@ -1416,12 +1515,12 @@ SUBROUTINE LeafTempPC (ipatch,npft,deltim,csoilc,dewmx ,htvp ,& ! canopy air humidity ! calculate wtll, wtlql - wtll(:) = 0. + wtll (:) = 0. wtlql(:) = 0. - DO i = 1, npft + DO i = ps, pe IF (fcover(i)>0 .and. lsai(i)>1.e-6) THEN - clev = canlev(i) + clev = canlay(i) wtll(clev) = wtll(clev) + wtl0(i)*tl(i) wtlql(clev) = wtlql(clev) + wtlq0(i)*qsatl(i) ENDIF @@ -1477,8 +1576,12 @@ SUBROUTINE LeafTempPC (ipatch,npft,deltim,csoilc,dewmx ,htvp ,& ! level vegetation should have different gdh2o, i.e., ! different rd(layer) values. gah2o = 1.0/raw * tprcor/thm !mol m-2 s-1 - gdh2o = 1.0/rd(botlay) * tprcor/thm !mol m-2 s-1 + IF (DEF_RSS_SCHEME .eq. 4) THEN + gdh2o = rss/rd(botlay) * tprcor/thm !mol m-2 s-1 + ELSE + gdh2o = 1.0/(rd(botlay)+rss) * tprcor/thm !mol m-2 s-1 + ENDIF pco2a = pco2m - 1.37*psrf/max(0.446,gah2o) * & sum(fcover*(assimsun + assimsha - respcsun - respcsha - rsoil)) @@ -1537,13 +1640,21 @@ SUBROUTINE LeafTempPC (ipatch,npft,deltim,csoilc,dewmx ,htvp ,& ! END stability iteration ! ====================================================================== + IF(DEF_USE_OZONESTRESS)THEN + CALL CalcOzoneStress(o3coefv_sun(i),o3coefg_sun(i),forc_ozone,psrf,th,ram,& + rssun(i),rbsun,lai(i),lai_old(i),p,o3uptakesun(i),deltim) + CALL CalcOzoneStress(o3coefv_sha(i),o3coefg_sha(i),forc_ozone,psrf,th,ram,& + rssha(i),rbsha,lai(i),lai_old(i),p,o3uptakesha(i),deltim) + lai_old(i) = lai(i) + ENDIF + z0m = z0mv zol = zeta rib = min(5.,zol*ustar**2/(vonkar**2/fh*um**2)) ! canopy fluxes and total assimilation amd respiration - DO i = 1, npft + DO i = ps, pe IF (fcover(i)>0 .and. lsai(i)>1.e-6) THEN IF(lai(i) .gt. 0.001) THEN @@ -1559,54 +1670,101 @@ SUBROUTINE LeafTempPC (ipatch,npft,deltim,csoilc,dewmx ,htvp ,& ! canopy fluxes and total assimilation amd respiration fsenl(i) = fsenl(i) + fsenl_dtl(i)*dtl(it-1,i) & - ! add the imbalanced energy below due to T adjustment to sensibel heat - + (dtl_noadj(i)-dtl(it-1,i)) * (lsai(i)*clai/deltim - dirab_dtl(i) & - + fsenl_dtl(i) + hvap*fevpl_dtl(i) + cpliq*qintr_rain(i) + cpice*qintr_snow(i)) & - ! add the imbalanced energy below due to q adjustment to sensibel heat - + hvap*erre(i) - - etr0(i) = etr(i) - etr(i) = etr(i) + etr_dtl(i)*dtl(it-1,i) - IF(DEF_USE_PLANTHYDRAULICS)THEN + ! add the imbalanced energy below due to T adjustment to sensibel heat + + (dtl_noadj(i)-dtl(it-1,i)) * (lsai(i)*clai/deltim - dirab_dtl(i) & + + fsenl_dtl(i) + hvap*fevpl_dtl(i) + cpliq*qintr_rain(i) + cpice*qintr_snow(i)) & + ! add the imbalanced energy below due to q adjustment to sensibel heat + + hvap*erre(i) + + etr0(i) = etr(i) + etr (i) = etr(i) + etr_dtl(i)*dtl(it-1,i) + + IF (DEF_USE_PLANTHYDRAULICS) THEN + !TODO@yuan: rootflux may not be consistent with etr, + ! water imbalance could happen. IF(abs(etr0(i)) .ge. 1.e-15)THEN - rootr(:,i) = rootr(:,i) * etr(i) / etr0(i) + rootflux(:,i) = rootflux(:,i) * etr(i) / etr0(i) ELSE - rootr(:,i) = rootr(:,i) + dz_soi / sum(dz_soi) * etr_dtl(i)* dtl(it-1,i) - END IF - END IF + rootflux(:,i) = rootflux(:,i) + dz_soi / sum(dz_soi) * etr_dtl(i)* dtl(it-1,i) + ENDIF + + !NOTE: temporal solution to make etr and rootflux consistent. + !TODO: need double check + sumrootflux = sum(rootflux(:,i), rootflux(:,i)>0.) + IF (abs(sumrootflux) > 0.) THEN + rootflux(:,i) = max(rootflux(:,i),0.) * (etr(i)/sumrootflux) + ELSE + rootflux(:,i) = etr(i)*rootfr(:,i) + ENDIF + ENDIF + evplwet(i) = evplwet(i) + evplwet_dtl(i)*dtl(it-1,i) - fevpl(i) = fevpl_noadj(i) - fevpl(i) = fevpl(i) + fevpl_dtl(i)*dtl(it-1,i) + fevpl (i) = fevpl_noadj(i) + fevpl (i) = fevpl(i) + fevpl_dtl(i)*dtl(it-1,i) - elwmax = ldew(i)/deltim + elwmax = ldew(i)/deltim ! 03/02/2018, yuan: convert fc to whole area ! because ldew now is for the whole area ! may need to change to canopy covered area ! 09/14/2019, yuan: change back to canopy area - elwdif = max(0., evplwet(i)-elwmax) + elwdif = max(0., evplwet(i)-elwmax) evplwet(i) = min(evplwet(i), elwmax) fevpl(i) = fevpl(i) - elwdif fsenl(i) = fsenl(i) + hvap*elwdif - hprl(i) = cpliq*qintr_rain(i)*(t_precip-tl(i)) + cpice*qintr_snow(i)*(t_precip-tl(i)) + hprl (i) = cpliq*qintr_rain(i)*(t_precip-tl(i)) + cpice*qintr_snow(i)*(t_precip-tl(i)) !----------------------------------------------------------------------- ! Update dew accumulation (kg/m2) !----------------------------------------------------------------------- -!#ifdef CLM5_INTERCEPTION -! IF (ldew_rain(i).gt.evplwet(i)*deltim) THEN -! ldew_rain(i) = ldew_rain(i)-evplwet(i)*deltim -! ldew_snow(i) = ldew_snow(i) -! ldew=ldew_rain(i)+ldew_snow(i) -! ELSE -! ldew_rain(i) = 0.0 -! ldew_snow(i) = max(0., ldew(i)-evplwet(i)*deltim) -! ldew(i) = ldew_snow(i) -! ENDIF -!#else - ldew(i) = max(0., ldew(i)-evplwet(i)*deltim) -!#endif + IF (DEF_Interception_scheme .eq. 1) THEN !colm2014 + ldew(i) = max(0., ldew(i)-evplwet(i)*deltim) + ELSEIF (DEF_Interception_scheme .eq. 2) THEN!CLM4.5 + ldew(i) = max(0., ldew(i)-evplwet(i)*deltim) + ELSEIF (DEF_Interception_scheme .eq. 3) THEN !CLM5 + IF (ldew_rain(i) .gt. evplwet(i)*deltim) THEN + ldew_rain(i) = ldew_rain(i)-evplwet(i)*deltim + ldew_snow(i) = ldew_snow(i) + ldew(i)=ldew_rain(i)+ldew_snow(i) + ELSE + ldew_rain(i) = 0.0 + ldew_snow(i) = max(0., ldew(i)-evplwet(i)*deltim) + ldew (i) = ldew_snow(i) + ENDIF + ELSEIF (DEF_Interception_scheme .eq. 4) THEN !Noah-MP + IF (ldew_rain(i) .gt. evplwet(i)*deltim) THEN + ldew_rain(i) = ldew_rain(i)-evplwet(i)*deltim + ldew_snow(i) = ldew_snow(i) + ldew(i)=ldew_rain(i)+ldew_snow(i) + ELSE + ldew_rain(i) = 0.0 + ldew_snow(i) = max(0., ldew(i)-evplwet(i)*deltim) + ldew (i) = ldew_snow(i) + ENDIF + ELSEIF (DEF_Interception_scheme .eq. 5) THEN !MATSIRO + IF (ldew_rain(i) .gt. evplwet(i)*deltim) THEN + ldew_rain(i) = ldew_rain(i)-evplwet(i)*deltim + ldew_snow(i) = ldew_snow(i) + ldew(i)=ldew_rain(i)+ldew_snow(i) + ELSE + ldew_rain(i) = 0.0 + ldew_snow(i) = max(0., ldew(i)-evplwet(i)*deltim) + ldew (i) = ldew_snow(i) + ENDIF + ELSEIF (DEF_Interception_scheme .eq. 6) THEN !VIC + IF (ldew_rain(i) .gt. evplwet(i)*deltim) THEN + ldew_rain(i) = ldew_rain(i)-evplwet(i)*deltim + ldew_snow(i) = ldew_snow(i) + ldew(i)=ldew_rain(i)+ldew_snow(i) + ELSE + ldew_rain(i) = 0.0 + ldew_snow(i) = max(0., ldew(i)-evplwet(i)*deltim) + ldew (i) = ldew_snow(i) + ENDIF + ELSE + CALL abort + ENDIF !----------------------------------------------------------------------- ! balance check @@ -1618,10 +1776,9 @@ SUBROUTINE LeafTempPC (ipatch,npft,deltim,csoilc,dewmx ,htvp ,& #if(defined CoLMDEBUG) IF(abs(err) .gt. .2) & - write(6,*) 'energy imbalance in LeafTempPC.F90', & + write(6,*) 'energy imbalance in LeafTemperaturePC.F90', & i,it-1,err,sabv(i),irab(i),fsenl(i),hvap*fevpl(i),hprl(i) #endif - ENDIF ENDDO @@ -1630,6 +1787,7 @@ SUBROUTINE LeafTempPC (ipatch,npft,deltim,csoilc,dewmx ,htvp ,& !----------------------------------------------------------------------- dlrad = Lin(0) & + sum( 4.* fshade * (1-thermk) * stefnc * tlbef**3 * dtl(it-1,:) ) + ulrad = Lin(4) - sum( fcover * dLv * dtl(it-1,:) ) & - emg * sum( 4.* fshade * (1-thermk) * stefnc * tlbef**3 * dtl(it-1,:) ) @@ -1644,8 +1802,38 @@ SUBROUTINE LeafTempPC (ipatch,npft,deltim,csoilc,dewmx ,htvp ,& ! fluxes from ground to canopy space !----------------------------------------------------------------------- +! 03/07/2020, yuan: TODO-done, calculate fseng_soil/snow, fevpg_soil/snow + IF (numlay .eq. 1) THEN + ttaf = thm + tqaf = qm + ENDIF + + IF (numlay .eq. 2) THEN + ttaf = taf(toplay) + tqaf = qaf(toplay) + ENDIF + + IF (numlay .eq. 3) THEN + ttaf = taf(2) + tqaf = qaf(2) + ENDIF + + !NOTE: the below EQs for check purpose only + ! taf = wta0*thm + wtg0*tg + wtl0*tl + ! taf(1) = wta0(1)*taf(2) + wtg0(1)*tg + wtll(1) + ! qaf(1) = wtaq0(1)*qaf(2) + wtgq0(1)*qg + wtlql(1) + ! taf(botlay) = wta0(botlay)*taf(toplay) + wtg0(botlay)*tg + wtll(botlay) + ! qaf(botlay) = wtaq0(botlay)*qaf(toplay) + wtgq0(botlay)*qg + wtlql(botlay) + ! taf(toplay) = wta0(toplay)*thm + wtg0(toplay)*tg + wtll(toplay) + ! qaf(toplay) = wtaq0(toplay)*qm + wtgq0(toplay)*qg + wtlql(toplay) + fseng = cpair*rhoair*cgh(botlay)*(tg-taf(botlay)) + fseng_soil = cpair*rhoair*cgh(botlay)*((1.-wtg0(botlay))*t_soil-wta0(botlay)*ttaf-wtll(botlay)) + fseng_snow = cpair*rhoair*cgh(botlay)*((1.-wtg0(botlay))*t_snow-wta0(botlay)*ttaf-wtll(botlay)) + fevpg = rhoair*cgw(botlay)*(qg-qaf(botlay)) + fevpg_soil = rhoair*cgw(botlay)*((1.-wtgq0(botlay))*q_soil-wtaq0(botlay)*tqaf-wtlql(botlay)) + fevpg_snow = rhoair*cgw(botlay)*((1.-wtgq0(botlay))*q_snow-wtaq0(botlay)*tqaf-wtlql(botlay)) !----------------------------------------------------------------------- ! Derivative of soil energy flux with respect to soil temperature (cgrnd) @@ -1668,7 +1856,7 @@ SUBROUTINE LeafTempPC (ipatch,npft,deltim,csoilc,dewmx ,htvp ,& tref = thm + vonkar/(fh-fht)*dth * (fh2m/vonkar - fh/vonkar) qref = qm + vonkar/(fq-fqt)*dqh * (fq2m/vonkar - fq/vonkar) - END SUBROUTINE LeafTempPC + END SUBROUTINE LeafTemperaturePC !---------------------------------------------------------------------- @@ -1684,19 +1872,19 @@ SUBROUTINE dewfraction (sigf,lai,sai,dewmx,ldew,ldew_rain,ldew_snow,fwet,fdry) USE MOD_Precision IMPLICIT NONE - real(r8), intent(in) :: sigf !fraction of veg cover, excluding snow-covered veg [-] - real(r8), intent(in) :: lai !leaf area index [-] - real(r8), intent(in) :: sai !stem area index [-] - real(r8), intent(in) :: dewmx !maximum allowed dew [0.1 mm] - real(r8), intent(in) :: ldew !depth of water on foliage [kg/m2/s] - real(r8), intent(in) :: ldew_rain !depth of rain on foliage [kg/m2/s] - real(r8), intent(in) :: ldew_snow !depth of snow on foliage [kg/m2/s] - real(r8), intent(out) :: fwet !fraction of foliage covered by water [-] - real(r8), intent(out) :: fdry !fraction of foliage that is green and dry [-] - - real(r8) lsai !lai + sai - real(r8) dewmxi !inverse of maximum allowed dew [1/mm] - real(r8) vegt !sigf*lsai, NOTE: remove sigf + real(r8), intent(in) :: sigf !fraction of veg cover, excluding snow-covered veg [-] + real(r8), intent(in) :: lai !leaf area index [-] + real(r8), intent(in) :: sai !stem area index [-] + real(r8), intent(in) :: dewmx !maximum allowed dew [0.1 mm] + real(r8), intent(in) :: ldew !depth of water on foliage [kg/m2/s] + real(r8), intent(in) :: ldew_rain !depth of rain on foliage [kg/m2/s] + real(r8), intent(in) :: ldew_snow !depth of snow on foliage [kg/m2/s] + real(r8), intent(out) :: fwet !fraction of foliage covered by water [-] + real(r8), intent(out) :: fdry !fraction of foliage that is green and dry [-] + + real(r8) lsai !lai + sai + real(r8) dewmxi !inverse of maximum allowed dew [1/mm] + real(r8) vegt !sigf*lsai, NOTE: remove sigf ! !----------------------------------------------------------------------- ! Fwet is the fraction of all vegetation surfaces which are wet @@ -1721,594 +1909,5 @@ SUBROUTINE dewfraction (sigf,lai,sai,dewmx,ldew,ldew_rain,ldew_snow,fwet,fdry) END SUBROUTINE dewfraction -!---------------------------------------------------------------------- - - real(r8) FUNCTION uprofile(utop, fc, bee, alpha, z0mg, htop, hbot, z) - - USE MOD_Precision - USE MOD_FrictionVelocity - IMPLICIT NONE - - real(r8), intent(in) :: utop - real(r8), intent(in) :: fc - real(r8), intent(in) :: bee - real(r8), intent(in) :: alpha - real(r8), intent(in) :: z0mg - real(r8), intent(in) :: htop - real(r8), intent(in) :: hbot - real(r8), intent(in) :: z - - real(r8) :: ulog,uexp - - ! when canopy LAI->0, z0->zs, fac->1, u->umoninobuk - ! canopy LAI->large, fac->0 or=0, u->log profile - ulog = utop*log(z/z0mg)/log(htop/z0mg) - uexp = utop*exp(-alpha*(1-(z-hbot)/(htop-hbot))) - - uprofile = bee*fc*min(uexp,ulog) + (1-bee*fc)*ulog - - RETURN - END FUNCTION uprofile - - real(r8) FUNCTION kprofile(ktop, fc, bee, alpha, & - displah, htop, hbot, obu, ustar, z) - - USE MOD_Precision - USE MOD_FrictionVelocity - IMPLICIT NONE - - real(r8), parameter :: com1 = 0.4 - real(r8), parameter :: com2 = 0.08 - - real(r8), intent(in) :: ktop - real(r8), intent(in) :: fc - real(r8), intent(in) :: bee - real(r8), intent(in) :: alpha - real(r8), intent(in) :: displah - real(r8), intent(in) :: htop - real(r8), intent(in) :: hbot - real(r8), intent(in) :: obu - real(r8), intent(in) :: ustar - real(r8), intent(in) :: z - - real(r8) :: fac - real(r8) :: kcob, klin, kexp - - klin = ktop*z/htop - - fac = 1. / (1.+exp(-(displah-com1)/com2)) - kcob = 1. / (fac/klin + (1.-fac)/kmoninobuk(0.,obu,ustar,z)) - - kexp = ktop*exp(-alpha*(1-(z-hbot)/(htop-hbot))) - - kprofile = 1./( bee*fc/min(kexp,kcob) + (1-bee*fc)/kcob ) - - RETURN - END FUNCTION kprofile - - real(r8) FUNCTION uintegral(utop, fc, bee, alpha, z0mg, htop, hbot) - - USE MOD_Precision - IMPLICIT NONE - - real(r8), intent(in) :: utop - real(r8), intent(in) :: fc - real(r8), intent(in) :: bee - real(r8), intent(in) :: alpha - real(r8), intent(in) :: z0mg - real(r8), intent(in) :: htop - real(r8), intent(in) :: hbot - - integer :: i, n - real(r8) :: dz, z, u - - ! 09/26/2017: change fixed n -> fixed dz - dz = 0.01 - n = int( (htop-hbot) / dz ) + 1 - - uintegral = 0. - - DO i = 1, n - IF (i < n) THEN - z = htop - (i-0.5)*dz - ELSE - dz = htop - hbot - (n-1)*dz - z = hbot + 0.5*dz - ENDIF - - u = uprofile(utop, fc, bee, alpha, z0mg, htop, hbot, z) - - u = max(0._r8, u) - !uintegral = uintegral + sqrt(u)*dz / (htop-hbot) -! 03/04/2020, yuan: NOTE: the above is hard to solve - !NOTE: The integral cannot be solved analytically after - !the square root sign of u, and the integral can be approximated - !directly for u, In this way, there is no need to square - uintegral = uintegral + u*dz / (htop-hbot) - ENDDO - - !uintegral = uintegral * uintegral - - RETURN - END FUNCTION uintegral - - - real(r8) FUNCTION ueffect(utop, htop, hbot, & - z0mg, alpha, bee, fc) - USE MOD_Precision - IMPLICIT NONE - - real(r8), intent(in) :: utop - real(r8), intent(in) :: htop - real(r8), intent(in) :: hbot - real(r8), intent(in) :: z0mg - real(r8), intent(in) :: alpha - real(r8), intent(in) :: bee - real(r8), intent(in) :: fc - - real(r8) :: roots(2), uint - integer :: rootn - - rootn = 0 - uint = 0. - - CALL ufindroots(htop,hbot,(htop+hbot)/2., & - utop, htop, hbot, z0mg, alpha, roots, rootn) - - IF (rootn == 0) THEN !no root - uint = uint + fuint(utop, htop, hbot, & - htop, hbot, z0mg, alpha, bee, fc) - ENDIF - - IF (rootn == 1) THEN - uint = uint + fuint(utop, htop, roots(1), & - htop, hbot, z0mg, alpha, bee, fc) - uint = uint + fuint(utop, roots(1), hbot, & - htop, hbot, z0mg, alpha, bee, fc) - ENDIF - - IF (rootn == 2) THEN - uint = uint + fuint(utop, htop, roots(1), & - htop, hbot, z0mg, alpha, bee, fc) - uint = uint + fuint(utop, roots(1), roots(2), & - htop, hbot, z0mg, alpha, bee, fc) - uint = uint + fuint(utop, roots(2), hbot, & - htop, hbot, z0mg, alpha, bee, fc) - ENDIF - - ueffect = uint / (htop-hbot) - - RETURN - END FUNCTION ueffect - - - real(r8) FUNCTION fuint(utop, ztop, zbot, & - htop, hbot, z0mg, alpha, bee, fc) - - USE MOD_Precision - IMPLICIT NONE - - real(r8), intent(in) :: utop, ztop, zbot - real(r8), intent(in) :: htop, hbot - real(r8), intent(in) :: z0mg, alpha - real(r8), intent(in) :: bee, fc - - ! local variables - real(r8) :: fuexpint, fulogint - - fulogint = utop/log(htop/z0mg) *& - (ztop*log(ztop/z0mg) - zbot*log(zbot/z0mg) + zbot - ztop) - - IF (udif((ztop+zbot)/2.,utop,htop,hbot,z0mg,alpha) <= 0) THEN - ! uexp is smaller - fuexpint = utop*(htop-hbot)/alpha*( & - exp(-alpha*(htop-ztop)/(htop-hbot))-& - exp(-alpha*(htop-zbot)/(htop-hbot)) ) - - fuint = bee*fc*fuexpint + (1.-bee*fc)*fulogint - ELSE - ! ulog is smaller - fuint = fulogint - ENDIF - - RETURN - END FUNCTION fuint - - - RECURSIVE SUBROUTINE ufindroots(ztop,zbot,zmid, & - utop, htop, hbot, z0mg, alpha, roots, rootn) - - USE MOD_Precision - IMPLICIT NONE - - real(r8), intent(in) :: ztop, zbot, zmid - real(r8), intent(in) :: utop, htop, hbot - real(r8), intent(in) :: z0mg, alpha - - real(r8), intent(inout) :: roots(2) - integer, intent(inout) :: rootn - - ! local variables - real(r8) :: udif_ub, udif_lb - - udif_ub = udif(ztop,utop,htop,hbot,z0mg,alpha) - udif_lb = udif(zmid,utop,htop,hbot,z0mg,alpha) - - IF (udif_ub*udif_lb == 0) THEN - IF (udif_lb == 0) THEN !root found - rootn = rootn + 1 - IF (rootn > 2) THEN - print *, "U root number > 2, abort!" - CALL abort - ENDIF - roots(rootn) = zmid - ENDIF - ELSE IF (udif_ub*udif_lb < 0) THEN - IF (ztop-zmid < 0.01) THEN - rootn = rootn + 1 !root found - IF (rootn > 2) THEN - print *, "U root number > 2, abort!" - CALL abort - ENDIF - roots(rootn) = (ztop+zmid)/2. - ELSE - CALL ufindroots(ztop,zmid,(ztop+zmid)/2., & - utop, htop, hbot, z0mg, alpha, roots, rootn) - ENDIF - ENDIF - - udif_ub = udif(zmid,utop,htop,hbot,z0mg,alpha) - udif_lb = udif(zbot,utop,htop,hbot,z0mg,alpha) - - IF (udif_ub*udif_lb == 0) THEN - IF (udif_ub == 0) THEN !root found - rootn = rootn + 1 - IF (rootn > 2) THEN - print *, "U root number > 2, abort!" - CALL abort - ENDIF - roots(rootn) = zmid - ENDIF - ELSE IF (udif_ub*udif_lb < 0) THEN - IF (zmid-zbot < 0.01) THEN - rootn = rootn + 1 !root found - IF (rootn > 2) THEN - print *, "U root number > 2, abort!" - CALL abort - ENDIF - roots(rootn) = (zmid+zbot)/2. - ELSE - CALL ufindroots(zmid,zbot,(zmid+zbot)/2., & - utop, htop, hbot, z0mg, alpha, roots, rootn) - ENDIF - ENDIF - - END SUBROUTINE ufindroots - - - real(r8) FUNCTION udif(z, utop, htop, hbot, z0mg, alpha) - - USE MOD_Precision - IMPLICIT NONE - - real(r8), intent(in) :: z, utop, htop, hbot - real(r8), intent(in) :: z0mg, alpha - - real(r8) :: uexp, ulog - - uexp = utop*exp(-alpha*(1-(z-hbot)/(htop-hbot))) - ulog = utop*log(z/z0mg)/log(htop/z0mg) - - udif = uexp - ulog - - RETURN - END FUNCTION udif - - - real(r8) FUNCTION kintegral(ktop, fc, bee, alpha, z0mg, & - displah, htop, hbot, obu, ustar, ztop, zbot) - USE MOD_Precision - IMPLICIT NONE - - real(r8), intent(in) :: ktop - real(r8), intent(in) :: fc - real(r8), intent(in) :: bee - real(r8), intent(in) :: alpha - real(r8), intent(in) :: z0mg - real(r8), intent(in) :: displah - real(r8), intent(in) :: htop - real(r8), intent(in) :: hbot - real(r8), intent(in) :: obu - real(r8), intent(in) :: ustar - real(r8), intent(in) :: ztop - real(r8), intent(in) :: zbot - - integer :: i, n - real(r8) :: dz, z, k - - kintegral = 0. - - IF (ztop <= zbot) THEN - RETURN - ENDIF - - ! 09/26/2017: change fixed n -> fixed dz - dz = 0.01 - n = int( (ztop-zbot) / dz ) + 1 - - DO i = 1, n - IF (i < n) THEN - z = ztop - (i-0.5)*dz - ELSE - dz = ztop - zbot - (n-1)*dz - z = zbot + 0.5*dz - ENDIF - - k = kprofile(ktop, fc, bee, alpha, & - displah, htop, hbot, obu, ustar, z) - - kintegral = kintegral + 1./k * dz - - ENDDO - - RETURN - END FUNCTION kintegral - - real(r8) FUNCTION frd(ktop, htop, hbot, & - ztop, zbot, displah, z0h, obu, ustar, & - z0mg, alpha, bee, fc) - - USE MOD_Precision - IMPLICIT NONE - - real(r8), intent(in) :: ktop, htop, hbot - real(r8), intent(in) :: ztop, zbot - real(r8), intent(in) :: displah, z0h, obu, ustar - real(r8), intent(in) :: z0mg, alpha, bee, fc - - ! local parameters - real(r8), parameter :: com1 = 0.4 - real(r8), parameter :: com2 = 0.08 - - real(r8) :: roots(2), fac, kint - integer :: rootn - - rootn = 0 - kint = 0. - - ! calculate fac - fac = 1. / (1.+exp(-(displah-com1)/com2)) - - CALL kfindroots(ztop,zbot,(ztop+zbot)/2., & - ktop, htop, hbot, obu, ustar, fac, alpha, roots, rootn) - - !print *, roots, rootn - IF (rootn == 0) THEN !no root - kint = kint + fkint(ktop, ztop, zbot, htop, hbot, & - z0h, obu, ustar, fac, alpha, bee, fc) - ENDIF - - IF (rootn == 1) THEN - kint = kint + fkint(ktop, ztop, roots(1), htop, hbot, & - z0h, obu, ustar, fac, alpha, bee, fc) - kint = kint + fkint(ktop, roots(1), zbot, htop, hbot, & - z0h, obu, ustar, fac, alpha, bee, fc) - ENDIF - - IF (rootn == 2) THEN - kint = kint + fkint(ktop, ztop, roots(1), htop, hbot, & - z0h, obu, ustar, fac, alpha, bee, fc) - kint = kint + fkint(ktop, roots(1), roots(2), htop, hbot, & - z0h, obu, ustar, fac, alpha, bee, fc) - kint = kint + fkint(ktop, roots(2), zbot, htop, hbot, & - z0h, obu, ustar, fac, alpha, bee, fc) - ENDIF - - frd = kint - - RETURN - END FUNCTION frd - - - real(r8) FUNCTION fkint(ktop, ztop, zbot, htop, hbot, & - z0h, obu, ustar, fac, alpha, bee, fc) - - USE MOD_Precision - USE MOD_FrictionVelocity - IMPLICIT NONE - - real(r8), intent(in) :: ktop, ztop, zbot - real(r8), intent(in) :: htop, hbot - real(r8), intent(in) :: z0h, obu, ustar, fac, alpha - real(r8), intent(in) :: bee, fc - - ! local variables - real(r8) :: fkexpint, fkcobint - - !NOTE: - ! klin = ktop*z/htop - ! kcob = 1./(fac/klin + (1.-fac)/kmoninobuk(0.,obu,ustar,z)) - fkcobint = fac*htop/ktop*(log(ztop)-log(zbot)) +& - (1.-fac)*kintmoninobuk(0.,z0h,obu,ustar,ztop,zbot) - - IF (kdif((ztop+zbot)/2.,ktop,htop,hbot,obu,ustar,fac,alpha) <= 0) THEN - ! kexp is smaller - IF (alpha > 0) THEN - fkexpint = -(htop-hbot)/alpha/ktop*( & - exp(alpha*(htop-ztop)/(htop-hbot))-& - exp(alpha*(htop-zbot)/(htop-hbot)) ) - ELSE - fkexpint = (ztop-zbot)/ktop - ENDIF - - fkint = bee*fc*fkexpint + (1.-bee*fc)*fkcobint - ELSE - ! kcob is smaller - fkint = fkcobint - ENDIF - - RETURN - END FUNCTION fkint - - - RECURSIVE SUBROUTINE kfindroots(ztop,zbot,zmid, & - ktop, htop, hbot, obu, ustar, fac, alpha, roots, rootn) - - USE MOD_Precision - IMPLICIT NONE - - real(r8), intent(in) :: ztop, zbot, zmid - real(r8), intent(in) :: ktop, htop, hbot - real(r8), intent(in) :: obu, ustar, fac, alpha - - real(r8), intent(inout) :: roots(2) - integer, intent(inout) :: rootn - - ! local variables - real(r8) :: kdif_ub, kdif_lb - - !print *, "*** CALL recursive SUBROUTINE kfindroots!!" - kdif_ub = kdif(ztop,ktop,htop,hbot,obu,ustar,fac,alpha) - kdif_lb = kdif(zmid,ktop,htop,hbot,obu,ustar,fac,alpha) - - IF (kdif_ub*kdif_lb == 0) THEN - IF (kdif_lb == 0) THEN !root found - rootn = rootn + 1 - IF (rootn > 2) THEN - print *, "K root number > 2, abort!" - CALL abort - ENDIF - roots(rootn) = zmid - ENDIF - ELSE IF (kdif_ub*kdif_lb < 0) THEN - IF (ztop-zmid < 0.01) THEN - rootn = rootn + 1 !root found - IF (rootn > 2) THEN - print *, "K root number > 2, abort!" - CALL abort - ENDIF - roots(rootn) = (ztop+zmid)/2. - ELSE - CALL kfindroots(ztop,zmid,(ztop+zmid)/2., & - ktop, htop, hbot, obu, ustar, fac, alpha, roots, rootn) - ENDIF - ENDIF - - kdif_ub = kdif(zmid,ktop,htop,hbot,obu,ustar,fac,alpha) - kdif_lb = kdif(zbot,ktop,htop,hbot,obu,ustar,fac,alpha) - - IF (kdif_ub*kdif_lb == 0) THEN - IF (kdif_ub == 0) THEN !root found - rootn = rootn + 1 - IF (rootn > 2) THEN - print *, "K root number > 2, abort!" - CALL abort - ENDIF - roots(rootn) = zmid - ENDIF - ELSE IF (kdif_ub*kdif_lb < 0) THEN - IF (zmid-zbot < 0.01) THEN - rootn = rootn + 1 !root found - IF (rootn > 2) THEN - print *, "K root number > 2, abort!" - CALL abort - ENDIF - roots(rootn) = (zmid+zbot)/2. - ELSE - CALL kfindroots(zmid,zbot,(zmid+zbot)/2., & - ktop, htop, hbot, obu, ustar, fac, alpha, roots, rootn) - ENDIF - ENDIF - - END SUBROUTINE kfindroots - - - real(r8) FUNCTION kdif(z, ktop, htop, hbot, & - obu, ustar, fac, alpha) - - USE MOD_Precision - USE MOD_FrictionVelocity - IMPLICIT NONE - - real(r8), intent(in) :: z, ktop, htop, hbot - real(r8), intent(in) :: obu, ustar, fac, alpha - - real(r8) :: kexp, klin, kcob - - kexp = ktop*exp(-alpha*(1-(z-hbot)/(htop-hbot))) - - klin = ktop*z/htop - kcob = 1./(fac/klin + (1.-fac)/kmoninobuk(0.,obu,ustar,z)) - - kdif = kexp - kcob - - RETURN - END FUNCTION kdif - - - SUBROUTINE cal_z0_displa (lai, h, fc, z0, displa) - - USE MOD_Const_Physical, only: vonkar - IMPLICIT NONE - - real(r8), intent(in) :: lai - real(r8), intent(in) :: h - real(r8), intent(in) :: fc - real(r8), intent(out) :: z0 - real(r8), intent(out) :: displa - - real(r8), parameter :: Cd = 0.2 !leaf drag coefficient - real(r8), parameter :: cd1 = 7.5 !a free parameter for d/h calculation, Raupach 1992, 1994 - real(r8), parameter :: psih = 0.193 !psih = ln(cw) - 1 + cw^-1, cw = 2, Raupach 1994 - - ! local variables - real(r8) :: fai, sqrtdragc, temp1, delta , lai0 - - ! when assume z0=0.01, displa=0 - ! to calculate lai0, delta displa - !---------------------------------------------------- - sqrtdragc = -vonkar/(log(0.01/h) - psih) - sqrtdragc = max(sqrtdragc, 0.0031**0.5) - IF (sqrtdragc .le. 0.3) THEN - fai = (sqrtdragc**2-0.003) / 0.3 - fai = min(fai, fc*(1-exp(-20.))) - ELSE - fai = 0.29 - print *, "z0m, displa error!" - ENDIF - - ! calculate delta displa when z0 = 0.01 - lai0 = -log(1.-fai/fc)/0.5 - temp1 = (2.*cd1*fai)**0.5 - delta = -h * ( fc*1.1*log(1. + (Cd*lai0*fc)**0.25) + & - (1.-fc)*(1.-(1.-exp(-temp1))/temp1) ) - - ! calculate z0m, displa - !---------------------------------------------------- - ! NOTE: potential bug below, only apply for spheric - ! crowns. For other cases, fc*(...) ==> a*fc*(...) - fai = fc*(1. - exp(-0.5*lai)) - sqrtdragc = min( (0.003+0.3*fai)**0.5, 0.3 ) - temp1 = (2.*cd1*fai)**0.5 - - IF (lai > lai0) THEN - displa = delta + h*( & - ( fc)*1.1*log(1. + (Cd*lai*fc)**0.25) + & - (1-fc)*(1.-(1.-exp(-temp1))/temp1) ) - ELSE - displa = h*( & - ( fc)*1.1*log(1. + (Cd*lai*fc)**0.25) + & - (1-fc)*(1.-(1.-exp(-temp1))/temp1) ) - ENDIF - - displa = max(displa, 0.) - z0 = (h-displa) * exp(-vonkar/sqrtdragc + psih) - - IF (z0 < 0.01) THEN - z0 = 0.01 - displa = 0. - ENDIF - - END SUBROUTINE cal_z0_displa END MODULE MOD_LeafTemperaturePC diff --git a/main/MOD_NdepData.F90 b/main/MOD_NdepData.F90 index eb3ec6de..73f39dc5 100644 --- a/main/MOD_NdepData.F90 +++ b/main/MOD_NdepData.F90 @@ -23,7 +23,7 @@ MODULE MOD_NdepData CONTAINS ! ---------- - SUBROUTINE init_ndep_data (YY) + SUBROUTINE init_ndep_data_annually (YY) !---------------------- ! DESCTIPTION: @@ -54,12 +54,48 @@ SUBROUTINE init_ndep_data (YY) IF (allocated(lon)) deallocate(lon) IF (allocated(lat)) deallocate(lat) - CALL update_ndep_data (YY, iswrite = .true.) + CALL update_ndep_data_annually (YY, iswrite = .true.) - END SUBROUTINE init_ndep_data + END SUBROUTINE init_ndep_data_annually + + ! ---------- + SUBROUTINE init_ndep_data_monthly (YY,MM) !sf_add + + !---------------------- + ! DESCTIPTION: + ! open ndep netcdf file from DEF_dir_runtime, read latitude and longitude info. + ! Initialize ndep data read in. + + use MOD_TimeManager + USE MOD_Namelist + USE MOD_Grid + USE MOD_NetCDFSerial + USE MOD_LandPatch + IMPLICIT NONE + + integer, intent(in) :: YY,MM !sf_add + + ! Local Variables + REAL(r8), allocatable :: lat(:), lon(:) + + file_ndep = trim(DEF_dir_runtime) // '/ndep/fndep_colm_monthly.nc' !sf_add + + CALL ncio_read_bcast_serial (file_ndep, 'lat', lat) + CALL ncio_read_bcast_serial (file_ndep, 'lon', lon) + + CALL grid_ndep%define_by_center (lat, lon) + + call mg2p_ndep%build (grid_ndep, landpatch) + + IF (allocated(lon)) deallocate(lon) + IF (allocated(lat)) deallocate(lat) + + CALL update_ndep_data_monthly (YY, MM ,iswrite = .true.) !sf_add + + END SUBROUTINE init_ndep_data_monthly ! ---------- - SUBROUTINE update_ndep_data (YY, iswrite) + SUBROUTINE update_ndep_data_annually (YY, iswrite) ! =========================================================== ! ! !DESCRIPTION: @@ -119,7 +155,73 @@ SUBROUTINE update_ndep_data (YY, iswrite) call check_vector_data ('ndep', ndep) #endif - END SUBROUTINE update_ndep_data + END SUBROUTINE update_ndep_data_annually + + ! ---------- + SUBROUTINE update_ndep_data_monthly (YY, MM, iswrite) !sf_add +! =========================================================== +! +! !DESCRIPTION: +! Read in the Nitrogen deposition data from CLM5. +! +! !REFERENCE: +! Galloway, J.N., et al. 2004. Nitrogen cycles: past, present, and future. Biogeochem. 70:153-226. +! +! !ORIGINAL: +! Created by Xingjie Lu and Shupeng Zhang, 2022 +! =========================================================== + + use MOD_SPMD_Task + USE MOD_Namelist, only : DEF_USE_PN + USE MOD_DataType + USE MOD_NetCDFBlock + use MOD_LandPatch + use MOD_Vars_TimeInvariants + USE MOD_RangeCheck + IMPLICIT NONE + + integer, intent(in) :: YY,MM ! sf_add + logical, INTENT(in) :: iswrite + + ! Local Variables + TYPE(block_data_real8_2d) :: f_xy_ndep + integer :: itime, npatch, m + + itime = (max(min(YY,2006),1849) - 1849)*12 + MM ! sf_add +! print*,"YY=",YY ! sf_add +! print*,"MM=",MM ! sf_add +! print*,"itime=",itime ! sf_add + + IF (p_is_io) THEN + CALL allocate_block_data (grid_ndep, f_xy_ndep) + CALL ncio_read_block_time (file_ndep, 'NDEP_month', grid_ndep, itime, f_xy_ndep) ! sf_add + ENDIF + + call mg2p_ndep%map_aweighted (f_xy_ndep, ndep) + + if (p_is_worker .and. iswrite) then + if (numpatch > 0) then + do npatch = 1, numpatch + m = patchclass(npatch) + if(m == 0)then + ndep_to_sminn(npatch) = 0. + else + if(DEF_USE_PN)then + ndep_to_sminn(npatch) = ndep(npatch) / 3600. / 365. / 24. * 5 + else + ndep_to_sminn(npatch) = ndep(npatch) / 3600. / 365. / 24. + end if + end if + end do + + ENDIF + ENDIF + +#ifdef RangeCheck + call check_vector_data ('ndep', ndep) +#endif + + END SUBROUTINE update_ndep_data_monthly END MODULE MOD_NdepData #endif diff --git a/main/MOD_NetSolar.F90 b/main/MOD_NetSolar.F90 index 5ecbd8bf..02660bf3 100644 --- a/main/MOD_NetSolar.F90 +++ b/main/MOD_NetSolar.F90 @@ -20,8 +20,8 @@ MODULE MOD_NetSolar SUBROUTINE netsolar (ipatch,idate,deltim,dlon,patchtype,& forc_sols,forc_soll,forc_solsd,forc_solld,& - alb,ssun,ssha,lai,sai,rho,tau,ssno,& - parsun,parsha,sabvsun,sabvsha,sabg,sabg_lyr,sr,& + alb,ssun,ssha,lai,sai,rho,tau,ssoi,ssno,ssno_lyr,& + parsun,parsha,sabvsun,sabvsha,sabg,sabg_soil,sabg_snow,fsno,sabg_snow_lyr,sr,& solvd,solvi,solnd,solni,srvd,srvi,srnd,srni,& solvdln,solviln,solndln,solniln,srvdln,srviln,srndln,srniln) ! @@ -44,81 +44,84 @@ SUBROUTINE netsolar (ipatch,idate,deltim,dlon,patchtype,& USE MOD_Vars_Global USE MOD_Namelist, only: DEF_USE_SNICAR USE MOD_TimeManager, only: isgreenwich -#ifdef LULC_IGBP_PFT - USE MOD_LandPFT, only : patch_pft_s, patch_pft_e +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + USE MOD_LandPFT, only: patch_pft_s, patch_pft_e USE MOD_Vars_PFTimeInvariants USE MOD_Vars_PFTimeVariables USE MOD_Vars_1DPFTFluxes #endif -#ifdef LULC_IGBP_PC - USE MOD_LandPC - USE MOD_Vars_PCTimeInvariants - USE MOD_Vars_PCTimeVariables - USE MOD_Vars_1DPCFluxes -#endif IMPLICIT NONE ! Dummy argument - INTEGER, intent(in) :: ipatch !patch index - INTEGER, intent(in) :: idate(3) !model time - INTEGER, intent(in) :: patchtype !land water TYPE (99-sea) + integer, intent(in) :: ipatch !patch index + integer, intent(in) :: idate(3) !model time + integer, intent(in) :: patchtype !land patch type (99-sea) - REAL(r8), intent(in) :: dlon !logitude in radians - REAL(r8), intent(in) :: deltim !seconds in a time step [second] + real(r8), intent(in) :: dlon !logitude in radians + real(r8), intent(in) :: deltim !seconds in a time step [second] - REAL(r8), intent(in) :: & + real(r8), intent(in) :: & forc_sols, &! atm vis direct beam solar rad onto srf [W/m2] forc_soll, &! atm nir direct beam solar rad onto srf [W/m2] forc_solsd, &! atm vis diffuse solar rad onto srf [W/m2] forc_solld ! atm nir diffuse solar rad onto srf [W/m2] - REAL(r8), dimension(1:2,1:2), intent(in) :: & - alb, &! averaged albedo [-] - ssun, &! sunlit canopy absorption for solar radiation - ssha ! shaded canopy absorption for solar radiation - - REAL(r8), dimension(1:2,1:2,maxsnl+1:1), intent(inout) :: & - ssno ! snow layer absorption - - REAL(r8), intent(in) :: & - lai, &! leaf area index - sai, &! stem area index - rho(2,2), &! leaf reflectance (iw=iband, il=life and dead) - tau(2,2) ! leaf transmittance (iw=iband, il=life and dead) - - REAL(r8), intent(out) :: & - parsun, &! PAR absorbed by sunlit vegetation [W/m2] - parsha, &! PAR absorbed by shaded vegetation [W/m2] - sabvsun, &! solar absorbed by sunlit vegetation [W/m2] - sabvsha, &! solar absorbed by shaded vegetation [W/m2] - sabg, &! solar absorbed by ground [W/m2] - sr, &! total reflected solar radiation (W/m2) - solvd, &! incident direct beam vis solar radiation (W/m2) - solvi, &! incident diffuse beam vis solar radiation (W/m2) - solnd, &! incident direct beam nir solar radiation (W/m2) - solni, &! incident diffuse beam nir solar radiation (W/m2) - srvd, &! reflected direct beam vis solar radiation (W/m2) - srvi, &! reflected diffuse beam vis solar radiation (W/m2) - srnd, &! reflected direct beam nir solar radiation (W/m2) - srni, &! reflected diffuse beam nir solar radiation (W/m2) - solvdln, &! incident direct beam vis solar radiation at local noon(W/m2) - solviln, &! incident diffuse beam vis solar radiation at local noon(W/m2) - solndln, &! incident direct beam nir solar radiation at local noon(W/m2) - solniln, &! incident diffuse beam nir solar radiation at local noon(W/m2) - srvdln, &! reflected direct beam vis solar radiation at local noon(W/m2) - srviln, &! reflected diffuse beam vis solar radiation at local noon(W/m2) - srndln, &! reflected direct beam nir solar radiation at local noon(W/m2) - srniln ! reflected diffuse beam nir solar radiation at local noon(W/m2) - - REAL(r8), intent(out) :: & - sabg_lyr(maxsnl+1:1) ! solar absorbed by snow layers [W/m2] + real(r8), dimension(1:2,1:2), intent(in) :: & + alb ! averaged albedo [-] + + real(r8), dimension(1:2,1:2), intent(inout) :: & + ssun, &! sunlit canopy absorption for solar radiation + ssha, &! shaded canopy absorption for solar radiation + ssoi, &! ground soil absorption [-] + ssno ! ground snow absorption [-] + + real(r8), dimension(1:2,1:2,maxsnl+1:1), intent(inout) :: & + ssno_lyr ! snow layer absorption + + real(r8), intent(in) :: & + lai, &! leaf area index + sai, &! stem area index + rho(2,2), &! leaf reflectance (iw=iband, il=life and dead) + tau(2,2) ! leaf transmittance (iw=iband, il=life and dead) + + real(r8), intent(out) :: & + parsun, &! PAR absorbed by sunlit vegetation [W/m2] + parsha, &! PAR absorbed by shaded vegetation [W/m2] + sabvsun, &! solar absorbed by sunlit vegetation [W/m2] + sabvsha, &! solar absorbed by shaded vegetation [W/m2] + sabg, &! solar absorbed by ground [W/m2] +! 03/06/2020, yuan: + sabg_soil, &! solar absorbed by ground soil [W/m2] + sabg_snow, &! solar absorbed by ground snow [W/m2] + fsno, &! snow fractional cover + sr, &! total reflected solar radiation (W/m2) + solvd, &! incident direct beam vis solar radiation (W/m2) + solvi, &! incident diffuse beam vis solar radiation (W/m2) + solnd, &! incident direct beam nir solar radiation (W/m2) + solni, &! incident diffuse beam nir solar radiation (W/m2) + srvd, &! reflected direct beam vis solar radiation (W/m2) + srvi, &! reflected diffuse beam vis solar radiation (W/m2) + srnd, &! reflected direct beam nir solar radiation (W/m2) + srni, &! reflected diffuse beam nir solar radiation (W/m2) + solvdln, &! incident direct beam vis solar radiation at local noon(W/m2) + solviln, &! incident diffuse beam vis solar radiation at local noon(W/m2) + solndln, &! incident direct beam nir solar radiation at local noon(W/m2) + solniln, &! incident diffuse beam nir solar radiation at local noon(W/m2) + srvdln, &! reflected direct beam vis solar radiation at local noon(W/m2) + srviln, &! reflected diffuse beam vis solar radiation at local noon(W/m2) + srndln, &! reflected direct beam nir solar radiation at local noon(W/m2) + srniln ! reflected diffuse beam nir solar radiation at local noon(W/m2) + + real(r8), intent(out) :: & + sabg_snow_lyr(maxsnl+1:1) ! solar absorbed by snow layers [W/m2] ! ----------------local variables --------------------------------- - INTEGER :: local_secs - REAL(r8) :: radpsec, sabvg + integer :: local_secs + real(r8) :: radpsec, sabvg, sabg_noadj + + integer ps, pe, p - INTEGER ps, pe, pc !======================================================================= sabvsun = 0. @@ -126,32 +129,47 @@ SUBROUTINE netsolar (ipatch,idate,deltim,dlon,patchtype,& parsun = 0. parsha = 0. - sabg = 0. - sabg_lyr(:) = 0. + IF (lai+sai <= 1.e-6) THEN + ssun(:,:) = 0. + ssha(:,:) = 0. + ENDIF - IF (patchtype == 0) THEN + sabg = 0. + sabg_soil = 0. + sabg_snow = 0. + sabg_snow_lyr(:) = 0. -#ifdef LULC_IGBP_PFT + IF (patchtype == 0) THEN +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) ps = patch_pft_s(ipatch) pe = patch_pft_e(ipatch) + sabvsun_p(ps:pe) = 0. sabvsha_p(ps:pe) = 0. - parsun_p(ps:pe) = 0. - parsha_p(ps:pe) = 0. -#endif + parsun_p (ps:pe) = 0. + parsha_p (ps:pe) = 0. -#ifdef LULC_IGBP_PC - pc = patch2pc(ipatch) - sabvsun_c(:,pc) = 0. - sabvsha_c(:,pc) = 0. - parsun_c(:,pc) = 0. - parsha_c(:,pc) = 0. + DO p = ps, pe + IF (lai_p(p)+sai_p(p) <= 1.e-6) THEN + ssun_p(:,:,p) = 0. + ssha_p(:,:,p) = 0. + ENDIF + ENDDO + + ssun(1,1) = sum( ssun_p(1,1,ps:pe)*pftfrac(ps:pe) ) + ssun(1,2) = sum( ssun_p(1,2,ps:pe)*pftfrac(ps:pe) ) + ssun(2,1) = sum( ssun_p(2,1,ps:pe)*pftfrac(ps:pe) ) + ssun(2,2) = sum( ssun_p(2,2,ps:pe)*pftfrac(ps:pe) ) + + ssha(1,1) = sum( ssha_p(1,1,ps:pe)*pftfrac(ps:pe) ) + ssha(1,2) = sum( ssha_p(1,2,ps:pe)*pftfrac(ps:pe) ) + ssha(2,1) = sum( ssha_p(2,1,ps:pe)*pftfrac(ps:pe) ) + ssha(2,2) = sum( ssha_p(2,2,ps:pe)*pftfrac(ps:pe) ) #endif ENDIF - IF (forc_sols+forc_soll+forc_solsd+forc_solld > 0.) THEN - IF (patchtype < 4) THEN !non lake and ocean + IF (patchtype < 4) THEN !non lake and ocean ! Radiative fluxes onto surface parsun = forc_sols*ssun(1,1) + forc_solsd*ssun(1,2) parsha = forc_sols*ssha(1,1) + forc_solsd*ssha(1,2) @@ -165,7 +183,8 @@ SUBROUTINE netsolar (ipatch,idate,deltim,dlon,patchtype,& IF (patchtype == 0) THEN -#ifdef LULC_IGBP_PFT +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + parsun_p(ps:pe) = forc_sols*ssun_p(1,1,ps:pe) + forc_solsd*ssun_p(1,2,ps:pe) parsha_p(ps:pe) = forc_sols*ssha_p(1,1,ps:pe) + forc_solsd*ssha_p(1,2,ps:pe) sabvsun_p(ps:pe) = forc_sols*ssun_p(1,1,ps:pe) + forc_solsd*ssun_p(1,2,ps:pe) & @@ -173,44 +192,62 @@ SUBROUTINE netsolar (ipatch,idate,deltim,dlon,patchtype,& sabvsha_p(ps:pe) = forc_sols*ssha_p(1,1,ps:pe) + forc_solsd*ssha_p(1,2,ps:pe) & + forc_soll*ssha_p(2,1,ps:pe) + forc_solld*ssha_p(2,2,ps:pe) #endif - -#ifdef LULC_IGBP_PC - parsun_c(:,pc) = forc_sols*ssun_c(1,1,:,pc) + forc_solsd*ssun_c(1,2,:,pc) - parsha_c(:,pc) = forc_sols*ssha_c(1,1,:,pc) + forc_solsd*ssha_c(1,2,:,pc) - sabvsun_c(:,pc) = forc_sols*ssun_c(1,1,:,pc) + forc_solsd*ssun_c(1,2,:,pc) & - + forc_soll*ssun_c(2,1,:,pc) + forc_solld*ssun_c(2,2,:,pc) - sabvsha_c(:,pc) = forc_sols*ssha_c(1,1,:,pc) + forc_solsd*ssha_c(1,2,:,pc) & - + forc_soll*ssha_c(2,1,:,pc) + forc_solld*ssha_c(2,2,:,pc) -#endif - ENDIF - ELSE !lake or ocean + ELSE !lake and ocean sabvg = forc_sols *(1.-alb(1,1)) + forc_soll *(1.-alb(2,1)) & + forc_solsd*(1.-alb(1,2)) + forc_solld*(1.-alb(2,2)) - sabg = sabvg + sabg = sabvg ENDIF - IF (DEF_USE_SNICAR) THEN + ! calculate soil and snow solar absorption + sabg_soil = forc_sols*ssoi(1,1) + forc_solsd*ssoi(1,2) & + + forc_soll*ssoi(2,1) + forc_solld*ssoi(2,2) + sabg_snow = forc_sols*ssno(1,1) + forc_solsd*ssno(1,2) & + + forc_soll*ssno(2,1) + forc_solld*ssno(2,2) + + sabg_soil = sabg_soil * (1.-fsno) + sabg_snow = sabg_snow * fsno - IF (patchtype < 4) THEN !non lake and ocean - ! normalization - IF(sum(ssno(1,1,:))>0.) ssno(1,1,:) = (1-alb(1,1)-ssun(1,1)-ssha(1,1)) * ssno(1,1,:)/sum(ssno(1,1,:)) - IF(sum(ssno(1,2,:))>0.) ssno(1,2,:) = (1-alb(1,2)-ssun(1,2)-ssha(1,2)) * ssno(1,2,:)/sum(ssno(1,2,:)) - IF(sum(ssno(2,1,:))>0.) ssno(2,1,:) = (1-alb(2,1)-ssun(2,1)-ssha(2,1)) * ssno(2,1,:)/sum(ssno(2,1,:)) - IF(sum(ssno(2,2,:))>0.) ssno(2,2,:) = (1-alb(2,2)-ssun(2,2)-ssha(2,2)) * ssno(2,2,:)/sum(ssno(2,2,:)) - ELSE !lake case - ! normalization - IF(sum(ssno(1,1,:))>0.) ssno(1,1,:) = (1-alb(1,1)) * ssno(1,1,:)/sum(ssno(1,1,:)) - IF(sum(ssno(1,2,:))>0.) ssno(1,2,:) = (1-alb(1,2)) * ssno(1,2,:)/sum(ssno(1,2,:)) - IF(sum(ssno(2,1,:))>0.) ssno(2,1,:) = (1-alb(2,1)) * ssno(2,1,:)/sum(ssno(2,1,:)) - IF(sum(ssno(2,2,:))>0.) ssno(2,2,:) = (1-alb(2,2)) * ssno(2,2,:)/sum(ssno(2,2,:)) + ! balance check and adjustment for soil and snow absorption + IF (sabg_soil+sabg_snow-sabg>1.e-6) THEN ! this could happen when there is adjust to ssun,ssha + print *, "MOD_NetSolar.F90: NOTE imbalance in spliting soil and snow surface!" + print *, "sabg:", sabg, "sabg_soil:", sabg_soil, "sabg_snow", sabg_snow + print *, "sabg_soil+sabg_snow:", sabg_soil+sabg_snow, "fsno:", fsno + + sabg_noadj = sabg_soil + sabg_snow + + IF (sabg_noadj > 0.) THEN + sabg_soil = sabg_soil * sabg/sabg_noadj + sabg_snow = sabg_snow * sabg/sabg_noadj + ssoi(:,:) = ssoi(:,:) * sabg/sabg_noadj + ssno(:,:) = ssno(:,:) * sabg/sabg_noadj ENDIF + ENDIF + + ! snow layer absorption calculation and adjustment for SNICAR model + IF (DEF_USE_SNICAR) THEN + ! adjust snow layer absorption due to multiple reflection between ground and canopy + IF(sum(ssno_lyr(1,1,:))>0.) ssno_lyr(1,1,:) = ssno(1,1) * ssno_lyr(1,1,:)/sum(ssno_lyr(1,1,:)) + IF(sum(ssno_lyr(1,2,:))>0.) ssno_lyr(1,2,:) = ssno(1,2) * ssno_lyr(1,2,:)/sum(ssno_lyr(1,2,:)) + IF(sum(ssno_lyr(2,1,:))>0.) ssno_lyr(2,1,:) = ssno(2,1) * ssno_lyr(2,1,:)/sum(ssno_lyr(2,1,:)) + IF(sum(ssno_lyr(2,2,:))>0.) ssno_lyr(2,2,:) = ssno(2,2) * ssno_lyr(2,2,:)/sum(ssno_lyr(2,2,:)) ! snow layer absorption - sabg_lyr(:) = forc_sols*ssno(1,1,:) + forc_solsd*ssno(1,2,:) & - + forc_soll*ssno(2,1,:) + forc_solld*ssno(2,2,:) + sabg_snow_lyr(:) = forc_sols*ssno_lyr(1,1,:) + forc_solsd*ssno_lyr(1,2,:) & + + forc_soll*ssno_lyr(2,1,:) + forc_solld*ssno_lyr(2,2,:) + + ! convert to the whole area producted by snow fractional cover + sabg_snow_lyr(:) = sabg_snow_lyr(:)*fsno + + ! attribute the first layer absorption to soil absorption + sabg_soil = sabg_soil + sabg_snow_lyr(1) + sabg_snow = sabg_snow - sabg_snow_lyr(1) + + ! make the soil absorption consistent + sabg_snow_lyr(1) = sabg_soil ENDIF + ENDIF solvd = forc_sols diff --git a/main/MOD_NewSnow.F90 b/main/MOD_NewSnow.F90 index 263675e9..b19c4f26 100644 --- a/main/MOD_NewSnow.F90 +++ b/main/MOD_NewSnow.F90 @@ -18,7 +18,7 @@ MODULE MOD_NewSnow subroutine newsnow (patchtype,maxsnl,deltim,t_grnd,pg_rain,pg_snow,bifall,& t_precip,zi_soisno,z_soisno,dz_soisno,t_soisno,& - wliq_soisno,wice_soisno,fiold,snl,sag,scv,snowdp,fsno) + wliq_soisno,wice_soisno,fiold,snl,sag,scv,snowdp,fsno,wetwat) !======================================================================= ! add new snow nodes. @@ -26,6 +26,7 @@ subroutine newsnow (patchtype,maxsnl,deltim,t_grnd,pg_rain,pg_snow,bifall,& !======================================================================= ! use MOD_Precision + USE MOD_Namelist, only : DEF_USE_VariablySaturatedFlow use MOD_Const_Physical, only : tfrz, cpliq, cpice implicit none @@ -33,7 +34,7 @@ subroutine newsnow (patchtype,maxsnl,deltim,t_grnd,pg_rain,pg_snow,bifall,& ! ------------------------ Dummy Argument ------------------------------ integer, INTENT(in) :: maxsnl ! maximum number of snow layers - integer, INTENT(in) :: patchtype ! land water type (0=soil, 1=urban and built-up, + integer, INTENT(in) :: patchtype ! land patch type (0=soil, 1=urban and built-up, ! 2=wetland, 3=land ice, 4=land water bodies, 99=ocean) real(r8), INTENT(in) :: deltim ! model time step [second] real(r8), INTENT(in) :: t_grnd ! ground surface temperature [k] @@ -54,6 +55,8 @@ subroutine newsnow (patchtype,maxsnl,deltim,t_grnd,pg_rain,pg_snow,bifall,& real(r8), INTENT(inout) :: scv ! snow mass (kg/m2) real(r8), INTENT(inout) :: snowdp ! snow depth (m) real(r8), INTENT(inout) :: fsno ! fraction of soil covered by snow [-] + + real(r8), INTENT(inout), optional :: wetwat ! wetland water [mm] ! ----------------------- Local Variables ----------------------------- @@ -69,6 +72,9 @@ subroutine newsnow (patchtype,maxsnl,deltim,t_grnd,pg_rain,pg_snow,bifall,& scv = scv + pg_snow*deltim ! snow water equivalent (mm) if(patchtype==2 .AND. t_grnd>tfrz)then ! snowfall on warmer wetland + IF (present(wetwat) .and. DEF_USE_VariablySaturatedFlow) THEN + wetwat = wetwat + scv + ENDIF scv=0.; snowdp=0.; sag=0.; fsno = 0. endif diff --git a/main/MOD_PhaseChange.F90 b/main/MOD_PhaseChange.F90 index 7412f6db..852f273c 100644 --- a/main/MOD_PhaseChange.F90 +++ b/main/MOD_PhaseChange.F90 @@ -19,8 +19,8 @@ MODULE MOD_PhaseChange !----------------------------------------------------------------------- - subroutine meltf (itypwat,lb,nl_soil,deltim, & - fact,brr,hs,dhsdT, & + subroutine meltf (patchtype,lb,nl_soil,deltim, & + fact,brr,hs,hs_soil,hs_snow,fsno,dhsdT, & t_soisno_bef,t_soisno,wliq_soisno,wice_soisno,imelt, & scv,snowdp,sm,xmf,porsl,psi0,& #ifdef Campbell_SOIL_MODEL @@ -58,7 +58,7 @@ subroutine meltf (itypwat,lb,nl_soil,deltim, & !----------------------------------------------------------------------- - integer, INTENT(in) :: itypwat !land water type (0=soil,1=urban or built-up,2=wetland, + integer, INTENT(in) :: patchtype !land patch type (0=soil,1=urban or built-up,2=wetland, !3=land ice, 4=deep lake, 5=shallow lake) integer, INTENT(in) :: nl_soil ! upper bound of array (i.e., soil layers) integer, INTENT(in) :: lb ! lower bound of array (i.e., snl +1) @@ -67,6 +67,9 @@ subroutine meltf (itypwat,lb,nl_soil,deltim, & real(r8), INTENT(in) :: brr (lb:nl_soil) ! real(r8), INTENT(in) :: fact(lb:nl_soil) ! temporary variables real(r8), INTENT(in) :: hs ! net ground heat flux into the surface + real(r8), INTENT(in) :: hs_soil ! net ground heat flux into the surface soil + real(r8), INTENT(in) :: hs_snow ! net ground heat flux into the surface snow + real(r8), INTENT(in) :: fsno ! snow fractional cover real(r8), INTENT(in) :: dhsdT ! temperature derivative of "hs" real(r8), INTENT(in) :: porsl(1:nl_soil) ! soil porosity [-] real(r8), INTENT(in) :: psi0 (1:nl_soil) ! soil water suction, negative potential [mm] @@ -125,7 +128,7 @@ subroutine meltf (itypwat,lb,nl_soil,deltim, & IF (DEF_USE_SUPERCOOL_WATER) THEN DO j = 1, nl_soil supercool(j) = 0.0 - if(t_soisno(j) < tfrz .and. itypwat <=2 ) then + if(t_soisno(j) < tfrz .and. patchtype <=2 ) then smp = hfus * (t_soisno(j)-tfrz)/(grav*t_soisno(j)) * 1000. ! mm if (porsl(j) > 0.) then #ifdef Campbell_SOIL_MODEL @@ -184,11 +187,25 @@ subroutine meltf (itypwat,lb,nl_soil,deltim, & do j = lb, nl_soil if(imelt(j) > 0)then tinc = t_soisno(j)-t_soisno_bef(j) - if(j > lb)then - hm(j) = brr(j) - tinc/fact(j) - else - hm(j) = hs + dhsdT*tinc + brr(j) - tinc/fact(j) + + if(j > lb)then ! => not the top layer + IF (j==1 .and. DEF_SPLIT_SOILSNOW .and. patchtype<3) THEN + ! -> interface soil layer + ! 03/08/2020, yuan: seperate soil/snow heat flux, exclude glacier(3) + hm(j) = hs_soil + (1.-fsno)*dhsdT*tinc + brr(j) - tinc/fact(j) + ELSE ! -> internal layers other than the interface soil layer + hm(j) = brr(j) - tinc/fact(j) + ENDIF + else ! => top layer + IF (j==1 .or. (.not.DEF_SPLIT_SOILSNOW) .or. patchtype==3) THEN + ! -> soil layer + hm(j) = hs + dhsdT*tinc + brr(j) - tinc/fact(j) + ELSE ! -> snow cover + ! 03/08/2020, yuan: seperate soil/snow heat flux, exclude glacier(3) + hm(j) = hs_snow + fsno*dhsdT*tinc + brr(j) - tinc/fact(j) + ENDIF endif + endif enddo @@ -253,13 +270,24 @@ subroutine meltf (itypwat,lb,nl_soil,deltim, & wliq_soisno(j) = max(0.,wmass0(j)-wice_soisno(j)) if(abs(heatr) > 0.)then - if(j > lb)then - t_soisno(j) = t_soisno(j) + fact(j)*heatr - else - t_soisno(j) = t_soisno(j) + fact(j)*heatr/(1.-fact(j)*dhsdT) + if(j > lb)then ! => not the top layer + IF (j==1 .and. DEF_SPLIT_SOILSNOW .and. patchtype<3) THEN + ! -> interface soil layer + t_soisno(j) = t_soisno(j) + fact(j)*heatr/(1.-fact(j)*(1.-fsno)*dhsdT) + ELSE ! -> internal layers other than the interface soil layer + t_soisno(j) = t_soisno(j) + fact(j)*heatr + ENDIF + else ! => top layer + IF (j==1 .or. (.not.DEF_SPLIT_SOILSNOW) .or. patchtype==3) THEN + ! -> soil layer + t_soisno(j) = t_soisno(j) + fact(j)*heatr/(1.-fact(j)*dhsdT) + ELSE ! -> snow cover + t_soisno(j) = t_soisno(j) + fact(j)*heatr/(1.-fact(j)*fsno*dhsdT) + ENDIF endif + if (DEF_USE_SUPERCOOL_WATER) then - IF(j <= 0 .or. itypwat == 3)THEN !snow + IF(j <= 0 .or. patchtype == 3)THEN !snow if(wliq_soisno(j)*wice_soisno(j) > 0.) t_soisno(j) = tfrz ENDIF ELSE @@ -286,8 +314,8 @@ subroutine meltf (itypwat,lb,nl_soil,deltim, & end subroutine meltf - subroutine meltf_snicar (itypwat,lb,nl_soil,deltim, & - fact,brr,hs,dhsdT,sabg_lyr, & + subroutine meltf_snicar (patchtype,lb,nl_soil,deltim, & + fact,brr,hs,hs_soil,hs_snow,fsno,sabg_snow_lyr,dhsdT, & t_soisno_bef,t_soisno,wliq_soisno,wice_soisno,imelt, & scv,snowdp,sm,xmf,porsl,psi0,& #ifdef Campbell_SOIL_MODEL @@ -326,7 +354,7 @@ subroutine meltf_snicar (itypwat,lb,nl_soil,deltim, & !----------------------------------------------------------------------- - integer, INTENT(in) :: itypwat !land water type (0=soil,1=urban or built-up,2=wetland, + integer, INTENT(in) :: patchtype !land patch type (0=soil,1=urban or built-up,2=wetland, !3=land ice, 4=deep lake, 5=shallow lake) integer, INTENT(in) :: nl_soil ! upper bound of array (i.e., soil layers) integer, INTENT(in) :: lb ! lower bound of array (i.e., snl +1) @@ -335,8 +363,11 @@ subroutine meltf_snicar (itypwat,lb,nl_soil,deltim, & real(r8), INTENT(in) :: brr (lb:nl_soil) ! real(r8), INTENT(in) :: fact(lb:nl_soil) ! temporary variables real(r8), INTENT(in) :: hs ! net ground heat flux into the surface + real(r8), INTENT(in) :: hs_soil ! net ground heat flux into the surface soil + real(r8), INTENT(in) :: hs_snow ! net ground heat flux into the surface snow + real(r8), INTENT(in) :: fsno ! snow fractional cover real(r8), INTENT(in) :: dhsdT ! temperature derivative of "hs" - real(r8), INTENT(in) :: sabg_lyr (lb:1) ! snow layer absorption [W/m-2] + real(r8), INTENT(in) :: sabg_snow_lyr (lb:1)! snow layer absorption [W/m-2] real(r8), INTENT(in) :: porsl(1:nl_soil) ! soil porosity [-] real(r8), INTENT(in) :: psi0 (1:nl_soil) ! soil water suction, negative potential [mm] #ifdef Campbell_SOIL_MODEL @@ -395,7 +426,7 @@ subroutine meltf_snicar (itypwat,lb,nl_soil,deltim, & if (DEF_USE_SUPERCOOL_WATER) then DO j = 1, nl_soil supercool(j) = 0.0 - if(t_soisno(j) < tfrz .and. itypwat <= 2) then + if(t_soisno(j) < tfrz .and. patchtype <= 2) then smp = hfus * (t_soisno(j)-tfrz)/(grav*t_soisno(j)) * 1000. ! mm if (porsl(j) > 0.) then #ifdef Campbell_SOIL_MODEL @@ -455,15 +486,29 @@ subroutine meltf_snicar (itypwat,lb,nl_soil,deltim, & do j = lb, nl_soil if(imelt(j) > 0)then tinc = t_soisno(j)-t_soisno_bef(j) - if(j > lb)then - IF (j <= 1) THEN - hm(j) = brr(j) - tinc/fact(j) + sabg_lyr(j) - ELSE - hm(j) = brr(j) - tinc/fact(j) + + if(j > lb)then ! => not the top layer + IF (j==1 .and. DEF_SPLIT_SOILSNOW .and. patchtype<3) THEN + ! -> interface soil layer + ! 03/08/2020, yuan: seperate soil/snow heat flux, exclude glacier(3) + hm(j) = hs_soil + (1.-fsno)*dhsdT*tinc + brr(j) - tinc/fact(j) + ELSE ! -> internal layers other than the interface soil layer + IF (j<1 .or. (j==1 .and. patchtype==3)) THEN + hm(j) = brr(j) - tinc/fact(j) + sabg_snow_lyr(j) + ELSE + hm(j) = brr(j) - tinc/fact(j) + ENDIF + ENDIF + else ! => top layer + IF (j==1 .or. (.not.DEF_SPLIT_SOILSNOW) .or. patchtype==3) THEN + ! -> soil layer + hm(j) = hs + dhsdT*tinc + brr(j) - tinc/fact(j) + ELSE ! -> snow cover + ! 03/08/2020, yuan: seperate soil/snow heat flux, exclude glacier(3) + hm(j) = hs_snow + fsno*dhsdT*tinc + brr(j) - tinc/fact(j) ENDIF - else - hm(j) = hs + dhsdT*tinc + brr(j) - tinc/fact(j) endif + endif enddo @@ -528,13 +573,24 @@ subroutine meltf_snicar (itypwat,lb,nl_soil,deltim, & wliq_soisno(j) = max(0.,wmass0(j)-wice_soisno(j)) if(abs(heatr) > 0.)then - if(j > lb)then - t_soisno(j) = t_soisno(j) + fact(j)*heatr - else - t_soisno(j) = t_soisno(j) + fact(j)*heatr/(1.-fact(j)*dhsdT) + if(j > lb)then ! => not the top layer + IF (j==1 .and. DEF_SPLIT_SOILSNOW .and. patchtype<3) THEN + ! -> interface soil layer + t_soisno(j) = t_soisno(j) + fact(j)*heatr/(1.-fact(j)*(1.-fsno)*dhsdT) + ELSE ! -> internal layers other than the interface soil layer + t_soisno(j) = t_soisno(j) + fact(j)*heatr + ENDIF + else ! => top layer + IF (j==1 .or. (.not.DEF_SPLIT_SOILSNOW) .or. patchtype==3) THEN + ! -> soil layer + t_soisno(j) = t_soisno(j) + fact(j)*heatr/(1.-fact(j)*dhsdT) + ELSE ! -> snow cover + t_soisno(j) = t_soisno(j) + fact(j)*heatr/(1.-fact(j)*fsno*dhsdT) + ENDIF endif + if (DEF_USE_SUPERCOOL_WATER) then - IF(j <= 0 .or. itypwat == 3)THEN !snow + IF(j <= 0 .or. patchtype == 3)THEN !snow if(wliq_soisno(j)*wice_soisno(j) > 0.) t_soisno(j) = tfrz ENDIF ELSE diff --git a/main/MOD_PlantHydraulic.F90 b/main/MOD_PlantHydraulic.F90 index b8531719..b4fa559e 100644 --- a/main/MOD_PlantHydraulic.F90 +++ b/main/MOD_PlantHydraulic.F90 @@ -3,17 +3,16 @@ MODULE MOD_PlantHydraulic !----------------------------------------------------------------------- use MOD_Precision + use MOD_Namelist, only: DEF_RSS_SCHEME + use MOD_SPMD_Task IMPLICIT NONE SAVE ! PUBLIC MEMBER FUNCTIONS: - public :: PlantHydraulicStress_oneleaf public :: PlantHydraulicStress_twoleaf - public :: getvegwp_oneleaf public :: getvegwp_twoleaf ! PRIVATE MEMBER FUNCTIONS: - private :: calcstress_oneleaf private :: calcstress_twoleaf @@ -25,208 +24,17 @@ MODULE MOD_PlantHydraulic - subroutine PlantHydraulicStress_oneleaf (nl_soil ,nvegwcs ,z_soi ,& - dz_soi ,rootfr ,psrf ,qsatl ,qaf ,tl ,& - rb ,ra ,rd ,rstfac ,cint ,lai ,& - rhoair ,fwet ,sai ,kmax_sun ,kmax_sha ,kmax_xyl ,& - kmax_root ,psi50_sun ,psi50_sha ,psi50_xyl ,psi50_root ,htop ,& - ck ,smp ,hk ,hksati ,vegwp ,etr ,& - rootr ,sigf ,qg ,qm ,gs0 ,k_soil_root,& - k_ax_root) - -!======================================================================= -! -! calculation of plant hydraulic stress -! -! Author: Xingjie Lu, 16/01/2019, modified from CLM5 plant_hydraulic_stress module -! -!---------------------------------------------------------------------- - - use MOD_Precision - IMPLICIT NONE - - integer ,intent(in) :: nl_soil ! upper bound of array - integer ,intent(in) :: nvegwcs ! upper bound of array - real(r8),intent(in), dimension(nl_soil) :: & - z_soi, &! soil node depth (m) - dz_soi ! soil layer thicknesses (m) - real(r8),intent(inout), dimension(nvegwcs) :: & - vegwp ! vegetation water potential - real(r8),intent(inout):: & - gs0 ! maximum stomata conductance - - real(r8),intent(in) :: & - sigf ! fraction of veg cover, excluding snow-covered veg [-] - - real(r8),intent(inout) :: & - psrf, &! surface atmospheric pressure (pa) - qsatl, &! specific humidity [kg/kg] - qaf, &! humidity of canopy air [kg/kg] - qg, &! specific humidity at ground surface [kg/kg] - qm, &! specific humidity at reference height [kg/kg] - tl, &! leaf temperature (K) - - rb, &! boundary resistance from canopy to cas (s m-1) - rd, &! aerodynamical resistance between ground and canopy air - ra ! aerodynamic resistance from cas to refence height (s m-1) - real(r8),intent(inout) :: & - rstfac ! canopy resistance stress factors to soil moisture - - real(r8),intent(inout) :: & - lai, &! leaf area index, one-sided - sai, &! stem area index - kmax_sun, & - kmax_sha, & - kmax_xyl, & - kmax_root, & - psi50_sun, &! water potential at 50% loss of sunlit leaf tissue conductance (mmH2O) - psi50_sha, &! water potential at 50% loss of shaded leaf tissue conductance (mmH2O) - psi50_xyl, &! water potential at 50% loss of xylem tissue conductance (mmH2O) - psi50_root, &! water potential at 50% loss of root tissue conductance (mmH2O) - htop, &! canopy top [m] - ck, &! shape-fitting parameter for vulnerability curve (-) - rhoair, &! density [kg/m**3] - fwet ! fraction of foliage that is wet [-] - - real(r8),intent(in), dimension(3) :: & - cint ! scaling up from leaf to canopy - - real(r8),intent(in), dimension(nl_soil) :: & - smp, & ! precipitation sensible heat from canopy - rootfr, & ! root fraction - hksati, & ! hydraulic conductivity at saturation [mm h2o/s] - hk ! soil hydraulic conducatance [mm h2o/s] - - - real(r8),intent(out) :: &! ATTENTION : all for canopy not leaf - etr ! transpiration (mm/s) - - real(r8),intent(out),dimension(nl_soil) :: & - rootr ! root water uptake from different layers - - real(r8),intent(inout),dimension(nl_soil) :: k_soil_root ! radial root and soil conductance - real(r8),intent(inout),dimension(nl_soil) :: k_ax_root ! axial root conductance - -!-------------------- local -------------------------------------------- - - integer, parameter :: iterationtotal = 6 - - real(r8) c3, &! c3 vegetation : 1; 0 for c4 - - tprcor, &! coefficient for unit transfer - gbh2o, &! one side leaf boundary layer conductance of sunlit leaf (canopy scale:mol m-2 s-1) - gb_mol ! one side leaf boundary layer conductance of sunlit leaf (leaf scale:umol H2O m-2 s-1) - - real(r8), dimension(nl_soil) :: & - fs !root conductance scale factor (reduction in conductance due to decreasing (more negative) root water potential) - real(r8), dimension(nl_soil) :: & - rai ! soil-root interface conductance [mm/s] - - real(r8) :: soilflux ! soil-root interface conductance [mm/s] - real(r8) :: soil_conductance ! soil conductance - real(r8) :: root_conductance ! root conductance - real(r8) :: r_soil ! root spacing [m] - real(r8) :: root_biomass_density ! root biomass density [g/m3] - real(r8) :: root_cross_sec_area ! root cross sectional area [m2] - real(r8) :: root_length_density ! root length density [m/m3] - real(r8) :: croot_average_length ! average coarse root length [m] - real(r8) :: rs_resis ! combined soil-root resistance [s] - - real(r8), parameter :: croot_lateral_length = 0.25_r8 ! specified lateral coarse root length [m] - real(r8), parameter :: c_to_b = 2.0_r8 !(g biomass /g C) - real(r8), parameter :: rpi = 3.14159265358979_r8 - integer , parameter :: root = 4 - real(r8), parameter :: toldb = 1.e-2_r8 ! tolerance for satisfactory bsun/bsha solution - real(r8), parameter :: K_axs = 2.0e-1 - -! temporary input - real(r8), parameter :: froot_carbon = 288.392056287006_r8 - real(r8), parameter :: root_radius = 2.9e-4_r8 - real(r8), parameter :: root_density = 310000._r8 - real(r8), parameter :: froot_leaf = 1.5_r8 - real(r8), parameter :: krmax = 3.981071705534969e-009_r8 - - real(r8),dimension(nvegwcs) :: x ! vegetation water potential - - integer j - -!----------------calculate root-soil interface conductance----------------- -do j = 1,nl_soil - -! calculate conversion from conductivity to conductance - root_biomass_density = c_to_b * froot_carbon * rootfr(j) / dz_soi(j) -! ensure minimum root biomass (using 1gC/m2) - root_biomass_density = max(c_to_b*1._r8,root_biomass_density) - - ! Root length density: m root per m3 soil - root_cross_sec_area = rpi*root_radius**2 - root_length_density = root_biomass_density / (root_density * root_cross_sec_area) - - ! Root-area index (RAI) - rai(j) = (sai+lai) * froot_leaf * rootfr(j) - -! fix coarse root_average_length to specified length - croot_average_length = croot_lateral_length - -! calculate r_soil using Gardner/spa equation (Bonan, GMD, 2014) - r_soil = sqrt(1./(rpi*root_length_density)) - - ! length scale approach - soil_conductance = min(hksati(j),hk(j))/(1.e3*r_soil) - -! use vegetation plc function to adjust root conductance - fs(j)= plc(smp(j),psi50_root,ck) - -! krmax is root conductance per area per length - root_conductance = (fs(j)*rai(j)*krmax)/(croot_average_length + z_soi(j)) - soil_conductance = max(soil_conductance, 1.e-16_r8) - root_conductance = max(root_conductance, 1.e-16_r8) - -! sum resistances in soil and root - rs_resis = 1._r8/soil_conductance + 1._r8/root_conductance - -! conductance is inverse resistance -! explicitly set conductance to zero for top soil layer - if(rai(j)*rootfr(j) > 0._r8) then - k_soil_root(j) = 1._r8/rs_resis - else - k_soil_root(j) = 0. - end if - k_ax_root(j) = (rootfr(j)/(dz_soi(j)*1000))*K_axs*0.6 -end do -!======================================================================= - - tprcor = 44.6*273.16*psrf/1.013e5 - -! one side leaf boundary layer conductance for water vapor [=1/(2*rb)] -! ATTENTION: rb in CLM is for one side leaf, but for SiB2 rb for -! 2-side leaf, so the gbh2o shold be " 0.5/rb * tprcor/tl " - gbh2o = 1./rb * tprcor/tl ! mol m-2 s-1 - - gb_mol = gbh2o / cint(3) * 1.e6 ! leaf to canopy - -! rb is for single leaf, but here the flux is for canopy, thus -! gbh2osun = gbh2osun * cintsun(3) ! debug by Xingjie Lu - - x = vegwp(1:nvegwcs) - call calcstress_oneleaf(x, nvegwcs, rstfac, etr, rootr, gb_mol, gs0, & - qsatl, qaf, qg, qm, rhoair, psrf, fwet, lai, sai, htop, tl, kmax_sun, & - kmax_sha, kmax_xyl, kmax_root, psi50_sun, psi50_sha, psi50_xyl, psi50_root,& - ck, nl_soil, z_soi, ra, rd, smp, k_soil_root, k_ax_root, sigf) - vegwp(1:nvegwcs) = x - - end subroutine PlantHydraulicStress_oneleaf - - subroutine PlantHydraulicStress_twoleaf (nl_soil ,nvegwcs ,z_soi ,& - dz_soi ,rootfr ,psrf ,qsatlsun ,qsatlsha ,& - qaf ,tlsun ,tlsha ,rbsun ,rbsha ,& + subroutine PlantHydraulicStress_twoleaf (nl_soil ,nvegwcs ,z_soi ,& + dz_soi ,rootfr ,psrf ,qsatl ,& + qaf ,tl ,rb ,rss, & ra ,rd ,rstfacsun ,rstfacsha ,cintsun ,& cintsha ,laisun ,laisha ,rhoair ,fwet ,& sai ,kmax_sun ,kmax_sha ,kmax_xyl ,kmax_root ,& psi50_sun ,psi50_sha ,psi50_xyl ,psi50_root ,htop ,& ck ,smp ,hk ,hksati ,vegwp ,& - etrsun ,etrsha ,rootr ,sigf ,qg ,& - qm ,gs0sun ,gs0sha ,k_soil_root,k_ax_root ) + etrsun ,etrsha ,rootflux ,qg ,& + qm ,gs0sun ,gs0sha ,k_soil_root,k_ax_root ,& + gssun ,gssha) !======================================================================= ! @@ -236,337 +44,195 @@ subroutine PlantHydraulicStress_twoleaf (nl_soil ,nvegwcs ,z_soi ,& ! !---------------------------------------------------------------------- - use MOD_Precision - IMPLICIT NONE - - integer ,intent(in) :: nl_soil ! upper bound of array - integer ,intent(in) :: nvegwcs ! upper bound of array - real(r8),intent(in), dimension(nl_soil) :: & - z_soi, &! soil node depth (m) - dz_soi ! soil layer thicknesses (m) - real(r8),intent(inout), dimension(nvegwcs) :: & - vegwp ! vegetation water potential - real(r8),intent(inout):: & - gs0sun, & ! maximum stomata conductance of sunlit leaf - gs0sha ! maximum stomata conductance of shaded leaf - - real(r8),intent(in) :: & - sigf, & ! fraction of veg cover, excluding snow-covered veg [-] - psrf, & ! surface atmospheric pressure (pa) - qg, &! specific humidity at ground surface [kg/kg] - qm ! specific humidity at reference height [kg/kg] - - real(r8),intent(inout) :: & - qsatlsun, &! sunlit leaf specific humidity [kg/kg] - qsatlsha, &! shaded leaf specific humidity [kg/kg] - qaf, &! humidity of canopy air [kg/kg] - tlsun, &! sunlit leaf temperature (K) - tlsha, &! shaded leaf temperature (K) - - rbsun, &! boundary resistance from sunlit canopy to cas (s m-1) - rbsha, &! boundary resistance from shaded canopy to cas (s m-1) - rd, &! aerodynamical resistance between ground and canopy air - ra ! aerodynamic resistance from cas to refence height (s m-1) - real(r8),intent(inout) :: & - rstfacsun, &! canopy resistance stress factors to soil moisture for sunlit leaf - rstfacsha ! canopy resistance stress factors to soil moisture for shaded leaf - - real(r8),intent(in) :: & - laisun, &! sunlit leaf area index, one-sided - laisha, &! shaded leaf area index, one-sided - sai, &! stem area index - kmax_sun, & - kmax_sha, & - kmax_xyl, & - kmax_root, & - psi50_sun, &! water potential at 50% loss of sunlit leaf tissue conductance (mmH2O) - psi50_sha, &! water potential at 50% loss of shaded leaf tissue conductance (mmH2O) - psi50_xyl, &! water potential at 50% loss of xylem tissue conductance (mmH2O) - psi50_root, &! water potential at 50% loss of root tissue conductance (mmH2O) - htop, &! canopy top [m] - ck, &! shape-fitting parameter for vulnerability curve (-) - rhoair, &! density [kg/m**3] - fwet ! fraction of foliage that is wet [-] - - real(r8),intent(in), dimension(3) :: & - cintsun, &! scaling up from sunlit leaf to canopy - cintsha ! scaling up from shaded leaf to canopy - - real(r8),intent(in), dimension(nl_soil) :: & - smp, & ! precipitation sensible heat from canopy - rootfr, & ! root fraction - hksati, & ! hydraulic conductivity at saturation [mm h2o/s] - hk ! soil hydraulic conducatance [mm h2o/s] - - - real(r8),intent(out) :: &! ATTENTION : all for canopy not leaf - etrsun, &! transpiration from sunlit leaf (mm/s) - etrsha ! transpiration from shaded leaf (mm/s) - - real(r8),intent(out),dimension(nl_soil) :: & - rootr ! root water uptake from different layers - - real(r8),intent(inout),dimension(nl_soil) :: k_soil_root ! radial root and soil conductance - real(r8),intent(inout),dimension(nl_soil) :: k_ax_root ! axial root conductance + use MOD_Precision + IMPLICIT NONE + + integer ,intent(in) :: nl_soil ! upper bound of array + integer ,intent(in) :: nvegwcs ! upper bound of array + real(r8),intent(in), dimension(nl_soil) :: & + z_soi, &! soil node depth (m) + dz_soi ! soil layer thicknesses (m) + real(r8),intent(inout), dimension(nvegwcs) :: & + vegwp ! vegetation water potential + real(r8),intent(inout):: & + gs0sun, & ! maximum stomata conductance of sunlit leaf + gs0sha ! maximum stomata conductance of shaded leaf + + real(r8),intent(in) :: & + rss, &! soil surface resistance [s/m] + psrf, & ! surface atmospheric pressure (pa) + qg, &! specific humidity at ground surface [kg/kg] + qm ! specific humidity at reference height [kg/kg] + + real(r8),intent(in) :: & + qsatl, &! leaf specific humidity [kg/kg] + qaf, &! humidity of canopy air [kg/kg] + tl, &! leaf temperature (K) + + rb, &! boundary resistance from canopy to cas (s m-1) + rd, &! aerodynamical resistance between ground and canopy air + ra ! aerodynamic resistance from cas to refence height (s m-1) + + real(r8),intent(inout) :: & + rstfacsun, &! canopy resistance stress factors to soil moisture for sunlit leaf + rstfacsha ! canopy resistance stress factors to soil moisture for shaded leaf + + real(r8),intent(in) :: & + laisun, &! sunlit leaf area index, one-sided + laisha, &! shaded leaf area index, one-sided + sai, &! stem area index + kmax_sun, & + kmax_sha, & + kmax_xyl, & + kmax_root, & + psi50_sun, &! water potential at 50% loss of sunlit leaf tissue conductance (mmH2O) + psi50_sha, &! water potential at 50% loss of shaded leaf tissue conductance (mmH2O) + psi50_xyl, &! water potential at 50% loss of xylem tissue conductance (mmH2O) + psi50_root, &! water potential at 50% loss of root tissue conductance (mmH2O) + htop, &! canopy top [m] + ck, &! shape-fitting parameter for vulnerability curve (-) + rhoair, &! density [kg/m**3] + fwet ! fraction of foliage that is wet [-] + + real(r8),intent(in), dimension(3) :: & + cintsun, &! scaling up from sunlit leaf to canopy + cintsha ! scaling up from shaded leaf to canopy + + real(r8),intent(in), dimension(nl_soil) :: & + smp, & ! precipitation sensible heat from canopy + rootfr, & ! root fraction + hksati, & ! hydraulic conductivity at saturation [mm h2o/s] + hk ! soil hydraulic conducatance [mm h2o/s] + + + real(r8),intent(out) :: &! ATTENTION : all for canopy not leaf + etrsun, &! transpiration from sunlit leaf (mm/s) + etrsha ! transpiration from shaded leaf (mm/s) + + real(r8),intent(out),dimension(nl_soil) :: & + rootflux ! root water uptake from different layers + + real(r8),intent(inout),dimension(nl_soil) :: k_soil_root ! radial root and soil conductance + real(r8),intent(inout),dimension(nl_soil) :: k_ax_root ! axial root conductance + real(r8),intent(inout) :: gssun ! sunlit leaf conductance + real(r8),intent(inout) :: gssha ! shaded leaf conductance + !-------------------- local -------------------------------------------- - integer, parameter :: iterationtotal = 6 - - real(r8) c3, &! c3 vegetation : 1; 0 for c4 - - tprcor, &! coefficient for unit transfer - gbh2osun, &! one side leaf boundary layer conductance of sunlit leaf (canopy scale:mol m-2 s-1) - gbh2osha, &! one side leaf boundary layer conductance of shaded leaf (canopy scale:mol m-2 s-1) - gb_mol_sun, &! one side leaf boundary layer conductance of sunlit leaf (leaf scale:umol H2O m-2 s-1) - gb_mol_sha ! one side leaf boundary layer conductance of shaded leaf (leaf scale:umol H2O m-2 s-1) - - real(r8), dimension(nl_soil) :: & - fs !root conductance scale factor (reduction in conductance due to decreasing (more negative) root water potential) - real(r8), dimension(nl_soil) :: & - rai ! soil-root interface conductance [mm/s] - - real(r8) :: soilflux ! soil-root interface conductance [mm/s] - real(r8) :: soil_conductance ! soil conductance - real(r8) :: root_conductance ! root conductance - real(r8) :: r_soil ! root spacing [m] - real(r8) :: root_biomass_density ! root biomass density [g/m3] - real(r8) :: root_cross_sec_area ! root cross sectional area [m2] - real(r8) :: root_length_density ! root length density [m/m3] - real(r8) :: croot_average_length ! average coarse root length [m] - real(r8) :: rs_resis ! combined soil-root resistance [s] - - real(r8), parameter :: croot_lateral_length = 0.25_r8 ! specified lateral coarse root length [m] - real(r8), parameter :: c_to_b = 2.0_r8 !(g biomass /g C) - real(r8), parameter :: rpi = 3.14159265358979_r8 - integer , parameter :: root = 4 - real(r8), parameter :: toldb = 1.e-2_r8 ! tolerance for satisfactory bsun/bsha solution - real(r8), parameter :: K_axs = 2.0e-1 - -! temporary input - real(r8), parameter :: froot_carbon = 288.392056287006_r8 - real(r8), parameter :: root_radius = 2.9e-4_r8 - real(r8), parameter :: root_density = 310000._r8 - real(r8), parameter :: froot_leaf = 1.5_r8 - real(r8), parameter :: krmax = 3.981071705534969e-009_r8 - - real(r8),dimension(nvegwcs) :: x ! vegetation water potential - - integer j + integer, parameter :: iterationtotal = 6 + + real(r8) c3, &! c3 vegetation : 1; 0 for c4 + + tprcor, &! coefficient for unit transfer + gb_mol ! one side leaf boundary layer conductance of sunlit leaf (leaf scale:umol H2O m-2 s-1) + + real(r8), dimension(nl_soil) :: & + fs !root conductance scale factor (reduction in conductance due to decreasing (more negative) root water potential) + real(r8), dimension(nl_soil) :: & + rai ! soil-root interface conductance [mm/s] + + real(r8) :: soilflux ! soil-root interface conductance [mm/s] + real(r8) :: soil_conductance ! soil conductance + real(r8) :: root_conductance ! root conductance + real(r8) :: r_soil ! root spacing [m] + real(r8) :: root_biomass_density ! root biomass density [g/m3] + real(r8) :: root_cross_sec_area ! root cross sectional area [m2] + real(r8) :: root_length_density ! root length density [m/m3] + real(r8) :: croot_average_length ! average coarse root length [m] + real(r8) :: rs_resis ! combined soil-root resistance [s] + real(r8) :: cf ! s m**2/umol -> s/m + + real(r8), parameter :: croot_lateral_length = 0.25_r8 ! specified lateral coarse root length [m] + real(r8), parameter :: c_to_b = 2.0_r8 !(g biomass /g C) + real(r8), parameter :: rpi = 3.14159265358979_r8 + integer , parameter :: root = 4 + real(r8), parameter :: toldb = 1.e-2_r8 ! tolerance for satisfactory bsun/bsha solution + real(r8), parameter :: K_axs = 2.0e-1 + + ! temporary input + real(r8), parameter :: froot_carbon = 288.392056287006_r8 + real(r8), parameter :: root_radius = 2.9e-4_r8 + real(r8), parameter :: root_density = 310000._r8 + real(r8), parameter :: froot_leaf = 1.5_r8 + real(r8), parameter :: krmax = 3.981071705534969e-009_r8 + + real(r8),dimension(nvegwcs) :: x ! vegetation water potential + + integer j !----------------calculate root-soil interface conductance----------------- -do j = 1,nl_soil + do j = 1,nl_soil -! calculate conversion from conductivity to conductance - root_biomass_density = c_to_b * froot_carbon * rootfr(j) / dz_soi(j) -! ensure minimum root biomass (using 1gC/m2) - root_biomass_density = max(c_to_b*1._r8,root_biomass_density) + ! calculate conversion from conductivity to conductance + root_biomass_density = c_to_b * froot_carbon * rootfr(j) / dz_soi(j) + ! ensure minimum root biomass (using 1gC/m2) + root_biomass_density = max(c_to_b*1._r8,root_biomass_density) - ! Root length density: m root per m3 soil - root_cross_sec_area = rpi*root_radius**2 - root_length_density = root_biomass_density / (root_density * root_cross_sec_area) + ! Root length density: m root per m3 soil + root_cross_sec_area = rpi*root_radius**2 + root_length_density = root_biomass_density / (root_density * root_cross_sec_area) - ! Root-area index (RAI) - rai(j) = (sai+laisun+laisha) * froot_leaf * rootfr(j) + ! Root-area index (RAI) + rai(j) = (sai+laisun+laisha) * froot_leaf * rootfr(j) -! fix coarse root_average_length to specified length - croot_average_length = croot_lateral_length + ! fix coarse root_average_length to specified length + croot_average_length = croot_lateral_length -! calculate r_soil using Gardner/spa equation (Bonan, GMD, 2014) - r_soil = sqrt(1./(rpi*root_length_density)) + ! calculate r_soil using Gardner/spa equation (Bonan, GMD, 2014) + r_soil = sqrt(1./(rpi*root_length_density)) - ! length scale approach - soil_conductance = min(hksati(j),hk(j))/(1.e3*r_soil) + ! length scale approach + soil_conductance = min(hksati(j),hk(j))/(1.e3*r_soil) -! use vegetation plc function to adjust root conductance - fs(j)= plc(smp(j),psi50_root,ck) + ! use vegetation plc function to adjust root conductance + fs(j)= plc(amax1(smp(j),-1._r8),psi50_root,ck) -! krmax is root conductance per area per length - root_conductance = (fs(j)*rai(j)*krmax)/(croot_average_length + z_soi(j)) - soil_conductance = max(soil_conductance, 1.e-16_r8) - root_conductance = max(root_conductance, 1.e-16_r8) + ! krmax is root conductance per area per length + root_conductance = (fs(j)*rai(j)*krmax)/(croot_average_length + z_soi(j)) + soil_conductance = max(soil_conductance, 1.e-16_r8) + root_conductance = max(root_conductance, 1.e-16_r8) -! sum resistances in soil and root - rs_resis = 1._r8/soil_conductance + 1._r8/root_conductance + ! sum resistances in soil and root + rs_resis = 1._r8/soil_conductance + 1._r8/root_conductance -! conductance is inverse resistance -! explicitly set conductance to zero for top soil layer - if(rai(j)*rootfr(j) > 0._r8) then - k_soil_root(j) = 1._r8/rs_resis - else - k_soil_root(j) = 0. - end if - k_ax_root(j) = (rootfr(j)/(dz_soi(j)*1000))*K_axs*0.6 -end do + ! conductance is inverse resistance + ! explicitly set conductance to zero for top soil layer + if(rai(j)*rootfr(j) > 0._r8) then + k_soil_root(j) = 1._r8/rs_resis + else + k_soil_root(j) = 0. + end if + k_ax_root(j) = (rootfr(j)/(dz_soi(j)*1000))*K_axs*0.6 + end do !======================================================================= tprcor = 44.6*273.16*psrf/1.013e5 + cf = tprcor/tl * 1.e6_r8 ! gb->gbmol conversion factor -! one side leaf boundary layer conductance for water vapor [=1/(2*rb)] -! ATTENTION: rb in CLM is for one side leaf, but for SiB2 rb for -! 2-side leaf, so the gbh2o shold be " 0.5/rb * tprcor/tl " - gbh2osun = 1./rbsun * tprcor/tlsun ! mol m-2 s-1 - gbh2osha = 1./rbsha * tprcor/tlsha ! mol m-2 s-1 - - gb_mol_sun = gbh2osun / cintsun(3) * 1.e6 ! leaf to canopy - gb_mol_sha = gbh2osha / cintsha(3) * 1.e6 - -! rb is for single leaf, but here the flux is for canopy, thus -! gbh2osun = gbh2osun * cintsun(3) ! Commented by Xingjie Lu, -! gbh2osha = gbh2osha * cintsha(3) + ! one side leaf boundary layer conductance for water vapor [=1/(2*rb)] + ! ATTENTION: rb in CLM is for one side leaf, but for SiB2 rb for + ! 2-side leaf, so the gbh2o shold be " 0.5/rb * tprcor/tl " + gb_mol = 1./rb * cf ! resistence to conductance (s/m -> umol/m**2/s) x = vegwp(1:nvegwcs) - call calcstress_twoleaf(x, nvegwcs, rstfacsun, rstfacsha, etrsun, etrsha, rootr,& - gb_mol_sun, gb_mol_sha, gs0sun, gs0sha, qsatlsun, qsatlsha, qaf, qg, qm, rhoair, & - psrf, fwet, laisun, laisha, sai, htop, tlsun, tlsha, kmax_sun, & - kmax_sha, kmax_xyl, kmax_root, psi50_sun, psi50_sha, psi50_xyl, psi50_root, ck, & - nl_soil, z_soi, ra, rd, smp, k_soil_root, k_ax_root, sigf) - + call calcstress_twoleaf(x, nvegwcs, rstfacsun, rstfacsha, etrsun, etrsha, rootflux,& + gb_mol, gs0sun, gs0sha, qsatl, qaf, qg, qm, rhoair, & + psrf, fwet, laisun, laisha, sai, htop, tl, kmax_sun, & + kmax_sha, kmax_xyl, kmax_root, psi50_sun, psi50_sha, psi50_xyl, psi50_root, ck, & + nl_soil, z_soi, rss, ra, rd, smp, k_soil_root, k_ax_root, gssun, gssha) vegwp(1:nvegwcs) = x end subroutine PlantHydraulicStress_twoleaf - subroutine calcstress_oneleaf(x,nvegwcs, rstfac, etr, rootr,& - gb_mol, gs0, qsatl, qaf, qg, qm,rhoair, & - psrf, fwet, lai, sai, htop, tl, kmax_sun, & - kmax_sha, kmax_xyl, kmax_root, psi50_sun, psi50_sha, psi50_xyl, psi50_root, ck, & - nl_soil, z_soi, raw, rd, smp, k_soil_root, k_ax_root, sigf) - ! - ! DESCRIPTIONS - ! compute the transpiration stress using a plant hydraulics approach - ! calls spacF, spacA, and getvegwp - ! - ! !ARGUMENTS: - integer , intent(in) :: nvegwcs - real(r8) , intent(inout) :: x(nvegwcs) ! working copy of vegwp(p,:) - real(r8) , intent(out) :: rstfac ! canopy transpiration wetness factor (0 to 1) - real(r8) , intent(out) :: etr ! actual transpiration (mm/s) - real(r8) , intent(out) :: rootr(nl_soil) ! root water uptake from different layers - integer , intent(in) :: nl_soil - real(r8) , intent(in) :: z_soi(nl_soil) - real(r8) , intent(in) :: gb_mol ! leaf boundary layer conductance (umol H2O/m**2/s) - real(r8) , intent(in) :: gs0 ! maximum shaded Ball-Berry minimum leaf conductance (umol H2O/m**2/s) - real(r8) , intent(in) :: qsatl ! leaf specific humidity [kg/kg] - real(r8) , intent(in) :: qaf ! humidity of canopy air [kg/kg] - real(r8) , intent(in) :: qg ! specific humidity at ground surface [kg/kg] - real(r8) , intent(in) :: qm ! specific humidity at reference height [kg/kg] - real(r8) , intent(in) :: rhoair ! density [kg/m**3] - real(r8) , intent(in) :: psrf ! atmospheric pressure [Pa] - real(r8) , intent(in) :: fwet ! fraction of foliage that is green and dry [-] - real(r8) , intent(in) :: raw ! moisture resistance [s/m] - real(r8) , intent(in) :: rd ! aerodynamical resistance between ground and canopy air - real(r8) , intent(in) :: lai ! leaf area index - real(r8) , intent(in) :: sai ! stem area index - real(r8) , intent(in) :: htop ! canopy top [m] - real(r8) , intent(in) :: tl ! leaf temperature - real(r8) , intent(in) :: kmax_sun - real(r8) , intent(in) :: kmax_sha - real(r8) , intent(in) :: kmax_xyl - real(r8) , intent(in) :: kmax_root - real(r8) , intent(in) :: psi50_sun ! water potential at 50% loss of sunlit leaf tissue conductance (mmH2O) - real(r8) , intent(in) :: psi50_sha ! water potential at 50% loss of shaded leaf tissue conductance (mmH2O) - real(r8) , intent(in) :: psi50_xyl ! water potential at 50% loss of xylem tissue conductance (mmH2O) - real(r8) , intent(in) :: psi50_root ! water potential at 50% loss of root tissue conductance (mmH2O) - real(r8) , intent(in) :: ck ! - real(r8) , intent(in) :: smp(nl_soil) ! soil matrix potential - real(r8) , intent(in) :: k_soil_root(nl_soil) ! soil-root interface conductance [mm/s] - real(r8) , intent(in) :: k_ax_root(nl_soil) ! root axial-direction conductance [mm/s] - real(r8) , intent(in) :: sigf ! fraction of veg cover, excluding snow-covered veg [-] - - real(r8) :: wtl ! heat conductance for leaf [m/s] - real(r8) :: dx(nvegwcs) ! change in vegwp from one iter to the next [mm] - real(r8) :: efpot ! potential latent energy flux [kg/m2/s] - real(r8) :: rppdry ! fraction of potential evaporation through transp - shaded [-] - real(r8) :: qflx ! maximum transpiration without water stress [kg/m2/s] - real(r8) :: gs ! local gs_mol copies, actual stomata conductance - real(r8) :: qeroot,dqeroot ! local gs_mol copies - real(r8),dimension(nl_soil) :: xroot ! local gs_mol copies - integer :: i,j ! index - real(r8) :: cf ! s m**2/umol -> s/m -! integer :: iter,iterqflx ! newton's method iteration number -! logical :: flag ! signal that matrix was not invertible -! logical :: night ! signal to store vegwp within this routine, b/c it is night-time and full suite won't be called - integer, parameter :: itmax=50 ! exit newton's method if iters>itmax -! real(r8),parameter :: toldx=1.e-9 !tolerances for a satisfactory solution -! real(r8),parameter :: tolf = 1.e-6_r8 -! real(r8),parameter :: tolf_leafxyl = 1.e-16_r8 -! real(r8),parameter :: tolf_root = 1.e-14_r8 !tolerances for a satisfactory solution -! logical :: havegs ! signals direction of calculation gs->qflx or qflx->gs -! logical :: haroot ! signals direction of calculation x_root_top->qeroot or qeroot->x_root_top - real(r8) :: soilflux ! total soil column transpiration [mm/s] - real(r8) :: x_root_top - real(r8) :: maxscale -! real(r8), parameter :: tol_lai=1.e-7_r8 ! minimum lai where transpiration is calc'd - integer, parameter :: leafsun=1 - integer, parameter :: leafsha=2 - integer, parameter :: xyl=3 - integer, parameter :: root=4 - !------------------------------------------------------------------------------ - - - !temporary flag for night time vegwp(sun)>0 - - gs=gs0 - call getqflx_gs2qflx_oneleaf(gb_mol,gs,qflx,qsatl,qaf,rhoair,psrf,lai,sai,fwet,tl,sigf,raw,rd,qg,qm) - x_root_top = x(root) - if(qflx>0)then - call getrootqflx_x2qe(nl_soil,smp,x_root_top ,z_soi,k_soil_root,k_ax_root,qeroot,dqeroot) - - call spacAF_oneleaf(x,nvegwcs,dx,nl_soil,qflx,lai,sai,htop,& - qeroot,dqeroot,kmax_sun,kmax_sha,kmax_xyl,kmax_root,& - psi50_sun,psi50_sha,psi50_xyl,psi50_root,ck) - - if ( maxval(abs(dx)) > 200000._r8) then - maxscale = min(maxval(abs(dx)),maxval(abs(x))) / 2 - dx = maxscale * dx / maxval(abs(dx))! * log(maxval(abs(dx))/maxscale) !rescale step to max of 50000 - end if - - x=x+dx - - ! this is a catch to force spac gradient to atmosphere - if ( x(xyl) > x(root) ) x(xyl) = x(root) - if ( x(leafsun) > x(xyl) ) x(leafsun) = x(xyl) - if ( x(leafsha) > x(xyl) ) x(leafsha) = x(xyl) - - ! compute attenuated flux - etr=qflx*plc(x(leafsha),psi50_sha,ck) - - ! retrieve stressed stomatal conductance - call getqflx_qflx2gs_oneleaf(gb_mol,gs,etr,qsatl,qaf,rhoair,psrf,lai,sai,fwet,tl,sigf,raw,rd,qg,qm) - - ! compute water stress - ! .. generally -> B= gs_stressed / gs_unstressed - ! .. when gs=0 -> B= plc( x ) - rstfac = amax1(gs/gs0,1.e-2_r8) - call getrootqflx_qe2x(nl_soil,smp,z_soi,k_soil_root,k_ax_root,etr,xroot,x_root_top) - - x(root) = x_root_top - do j = 1,nl_soil - rootr(j) = k_soil_root(j)*(smp(j)-xroot(j)) - enddo - soilflux = sum(rootr(:)) - else - if ( x(xyl) > x(root) ) x(xyl) = x(root) - if ( x(leafsun) > x(xyl) ) x(leafsun) = x(xyl) - if ( x(leafsha) > x(xyl) ) x(leafsha) = x(xyl) - etr = 0._r8 - rstfac = amax1(plc(x(leafsha),psi50_sha,ck),1.e-2_r8) - gs = gs0 * rstfac - rootr = 0._r8 - end if - - soilflux = sum(rootr(:)) - - end subroutine calcstress_oneleaf - - subroutine calcstress_twoleaf(x,nvegwcs,rstfacsun, rstfacsha, etrsun, etrsha, rootr,& - gb_mol_sun, gb_mol_sha, gs0sun, gs0sha, qsatlsun, qsatlsha, qaf, qg, qm,rhoair,& - psrf, fwet, laisun, laisha, sai, htop, tlsun, tlsha, kmax_sun, kmax_sha, kmax_xyl, kmax_root, & - psi50_sun, psi50_sha, psi50_xyl, psi50_root, ck, nl_soil, z_soi, raw, rd, smp, & - k_soil_root, k_ax_root, sigf) + subroutine calcstress_twoleaf(x,nvegwcs,rstfacsun, rstfacsha, etrsun, etrsha, rootflux,& + gb_mol, gs0sun, gs0sha, qsatl, qaf, qg, qm,rhoair,& + psrf, fwet, laisun, laisha, sai, htop, tl, kmax_sun, kmax_sha, kmax_xyl, kmax_root, & + psi50_sun, psi50_sha, psi50_xyl, psi50_root, ck, nl_soil, z_soi, rss, raw, rd, smp, & + k_soil_root, k_ax_root, gssun, gssha) ! ! DESCRIPTIONS ! compute the transpiration stress using a plant hydraulics approach @@ -579,29 +245,27 @@ subroutine calcstress_twoleaf(x,nvegwcs,rstfacsun, rstfacsha, etrsun, etrsha, ro real(r8) , intent(out) :: rstfacsha ! shaded sunlit canopy transpiration wetness factor (0 to 1) real(r8) , intent(out) :: etrsun ! transpiration from sunlit leaf (mm/s) real(r8) , intent(out) :: etrsha ! transpiration from shaded leaf (mm/s) - real(r8) , intent(out) :: rootr(nl_soil) ! root water uptake from different layers + real(r8) , intent(out) :: rootflux(nl_soil) ! root water uptake from different layers integer , intent(in) :: nl_soil real(r8) , intent(in) :: z_soi(nl_soil) - real(r8) , intent(in) :: gb_mol_sun ! sunlit leaf boundary layer conductance (umol H2O/m**2/s) - real(r8) , intent(in) :: gb_mol_sha ! shaded leaf boundary layer conductance (umol H2O/m**2/s) + real(r8) , intent(in) :: gb_mol ! leaf boundary layer conductance (umol H2O/m**2/s) real(r8) , intent(in) :: gs0sun ! sunlit Ball-Berry minimum leaf conductance (umol H2O/m**2/s) real(r8) , intent(in) :: gs0sha ! shaded Ball-Berry minimum leaf conductance (umol H2O/m**2/s) - real(r8) , intent(in) :: qsatlsun ! sunlit leaf specific humidity [kg/kg] - real(r8) , intent(in) :: qsatlsha ! shaded leaf specific humidity [kg/kg] + real(r8) , intent(in) :: qsatl ! leaf specific humidity [kg/kg] real(r8) , intent(in) :: qaf ! humidity of canopy air [kg/kg] real(r8) , intent(in) :: qg ! specific humidity at ground surface [kg/kg] real(r8) , intent(in) :: qm ! specific humidity at reference height [kg/kg] real(r8) , intent(in) :: rhoair ! density [kg/m**3] real(r8) , intent(in) :: psrf ! atmospheric pressure [Pa] real(r8) , intent(in) :: fwet ! fraction of foliage that is green and dry [-] + real(r8) , intent(in) :: rss ! soil surface resistance [s/m] real(r8) , intent(in) :: raw ! moisture resistance [s/m] real(r8) , intent(in) :: rd ! aerodynamical resistance between ground and canopy air real(r8) , intent(in) :: laisun ! Sunlit leaf area index real(r8) , intent(in) :: laisha ! Shaded leaf area index real(r8) , intent(in) :: sai ! stem area index real(r8) , intent(in) :: htop ! canopy top [m] - real(r8) , intent(in) :: tlsun ! sunlit leaf temperature - real(r8) , intent(in) :: tlsha ! shaded leaf temperature + real(r8) , intent(in) :: tl ! leaf temperature real(r8) , intent(in) :: kmax_sun real(r8) , intent(in) :: kmax_sha real(r8) , intent(in) :: kmax_xyl @@ -614,17 +278,16 @@ subroutine calcstress_twoleaf(x,nvegwcs,rstfacsun, rstfacsha, etrsun, etrsha, ro real(r8) , intent(in) :: smp(nl_soil) ! soil matrix potential real(r8) , intent(in) :: k_soil_root(nl_soil) ! soil-root interface conductance [mm/s] real(r8) , intent(in) :: k_ax_root(nl_soil) ! root axial-direction conductance [mm/s] - real(r8) , intent(in) :: sigf ! fraction of veg cover, excluding snow-covered veg [-] - real(r8) :: wtl ! heat conductance for leaf [m/s] + real(r8) , intent(out) :: gssun ! sunlit leaf conductance + real(r8) , intent(out) :: gssha ! shaded leaf conductance + + + real(r8) :: wtl ! water conductance for leaf [m/s] real(r8) :: A(nvegwcs,nvegwcs) ! matrix relating d(vegwp) and f: d(vegwp)=A*f real(r8) :: f(nvegwcs) ! flux divergence (mm/s) real(r8) :: dx(nvegwcs) ! change in vegwp from one iter to the next [mm] - real(r8) :: efpot ! potential latent energy flux [kg/m2/s] - real(r8) :: rppdry_sun ! fraction of potential evaporation through transp - sunlit [-] - real(r8) :: rppdry_sha ! fraction of potential evaporation through transp - shaded [-] real(r8) :: qflx_sun ! [kg/m2/s] real(r8) :: qflx_sha ! [kg/m2/s] - real(r8) :: gssun,gssha ! local gs_mol copies real(r8) :: qeroot,dqeroot real(r8),dimension(nl_soil) :: xroot ! local gs_mol copies integer :: i,j ! index @@ -651,15 +314,15 @@ subroutine calcstress_twoleaf(x,nvegwcs,rstfacsun, rstfacsha, etrsun, etrsha, ro integer, parameter :: xyl=3 integer, parameter :: root=4 real(r8) fsto1,fsto2,fx,fr,grav1 + real(r8) tprcor !------------------------------------------------------------------------------ - !temporary flag for night time vegwp(sun)>0 gssun=gs0sun gssha=gs0sha - call getqflx_gs2qflx_twoleaf(gb_mol_sun,gb_mol_sha,gssun,gssha,qflx_sun,qflx_sha,qsatlsun,qsatlsha,qaf, & - rhoair,psrf,laisun,laisha,sai,fwet,tlsun,tlsha,sigf,raw,rd,qg,qm) + call getqflx_gs2qflx_twoleaf(gb_mol,gssun,gssha,qflx_sun,qflx_sha,qsatl,qaf, & + rhoair,psrf,laisun,laisha,sai,fwet,tl,rss,raw,rd,qg,qm) x_root_top = x(root) if(qflx_sun .gt. 0 .or. qflx_sha .gt. 0)then @@ -686,19 +349,20 @@ subroutine calcstress_twoleaf(x,nvegwcs,rstfacsun, rstfacsha, etrsun, etrsha, ro etrsha=qflx_sha*plc(x(leafsha),psi50_sha,ck) ! retrieve stressed stomatal conductance - call getqflx_qflx2gs_twoleaf(gb_mol_sun,gb_mol_sha,gssun,gssha,etrsun,etrsha,qsatlsun,qsatlsha,qaf, & - rhoair,psrf,laisun,laisha,sai,fwet,tlsun,tlsha,sigf,raw,rd,qg,qm) + call getqflx_qflx2gs_twoleaf(gb_mol,gssun,gssha,etrsun,etrsha,qsatl,qaf, & + rhoair,psrf,laisun,laisha,sai,fwet,tl,rss,raw,rd,qg,qm) + tprcor = 44.6*273.16*psrf/1.013e5 ! compute water stress ! .. generally -> B= gs_stressed / gs_unstressed ! .. when gs=0 -> B= plc( x ) - rstfacsun = amax1(gssun/gs0sun,1.e-2_r8) - rstfacsha = amax1(gssha/gs0sha,1.e-2_r8) + rstfacsun = amax1(gssun/gs0sun,1.e-2_r8) + rstfacsha = amax1(gssha/gs0sha,1.e-2_r8) qeroot = etrsun + etrsha call getrootqflx_qe2x(nl_soil,smp,z_soi,k_soil_root,k_ax_root,qeroot,xroot,x_root_top) x(root) = x_root_top do j = 1,nl_soil - rootr(j) = k_soil_root(j)*(smp(j)-xroot(j)) + rootflux(j) = k_soil_root(j)*(smp(j)-xroot(j)) enddo else if ( x(xyl) > x(root) ) x(xyl) = x(root) @@ -710,115 +374,13 @@ subroutine calcstress_twoleaf(x,nvegwcs,rstfacsun, rstfacsha, etrsun, etrsha, ro rstfacsha = amax1(plc(x(leafsha),psi50_sha,ck),1.e-2_r8) gssun = gs0sun * rstfacsun gssha = gs0sha * rstfacsha - rootr = 0._r8 + rootflux = 0._r8 end if - soilflux = sum(rootr(:)) + soilflux = sum(rootflux(:)) end subroutine calcstress_twoleaf - !------------------------------------------------------------------------------ - - subroutine spacAF_oneleaf(x,nvegwcs,dx,nl_soil,qflx,lai,sai,htop,& - qeroot,dqeroot,kmax_sun,kmax_sha,kmax_xyl,kmax_root,& - psi50_sun,psi50_sha,psi50_xyl,psi50_root,ck) - ! - ! DESCRIPTION - ! Returns invA, the inverse matrix relating delta(vegwp) to f - ! d(vegwp)=invA*f - ! evaluated at vegwp(p) - ! - ! The methodology is currently hardcoded for linear algebra assuming the - ! number of vegetation segments is four. Thus the matrix A and it's inverse - ! invA are both 3x3 matrices. A more general method could be done using for - ! example a LINPACK linear algebra solver. - ! - ! !ARGUMENTS: - integer , intent(in) :: nvegwcs - real(r8) , intent(in) :: x(nvegwcs) ! working copy of veg water potential for patch p [mm H2O] - real(r8) , intent(out) :: dx(nvegwcs) ! matrix relating d(vegwp) and f: d(vegwp)=invA*f - integer , intent(in) :: nl_soil - real(r8) , intent(in) :: qflx ! leaf transpiration [kg/m2/s] - real(r8) , intent(in) :: lai ! Shaded leaf area index - real(r8) , intent(in) :: sai ! Stem area index - real(r8) , intent(in) :: htop ! Canopy top [m] - real(r8) , intent(in) :: qeroot ! soil-root interface conductance [mm/s] - real(r8) , intent(in) :: dqeroot ! soil-root interface conductance [mm/s] - real(r8) , intent(in) :: kmax_sun - real(r8) , intent(in) :: kmax_sha - real(r8) , intent(in) :: kmax_xyl - real(r8) , intent(in) :: kmax_root - real(r8) , intent(in) :: psi50_sun ! water potential at 50% loss of sunlit leaf tissue conductance (mmH2O) - real(r8) , intent(in) :: psi50_sha ! water potential at 50% loss of shaded leaf tissue conductance (mmH2O) - real(r8) , intent(in) :: psi50_xyl ! water potential at 50% loss of xylem tissue conductance (mmH2O) - real(r8) , intent(in) :: psi50_root ! water potential at 50% loss of root tissue conductance (mmH2O) - real(r8) , intent(in) :: ck - ! - ! !LOCAL VARIABLES: - real(r8) :: wtl ! heat conductance for leaf [m/s] - real(r8) :: fsto ! transpiration reduction function [-] - real(r8) :: fx ! fraction of maximum conductance, xylem-to-leaf [-] - real(r8) :: fr ! fraction of maximum conductance, root-to-xylem [-] - real(r8) :: dfsto ! 1st derivative of fsto w.r.t. change in vegwp - real(r8) :: dfx ! 1st derivative of fx w.r.t. change in vegwp - real(r8) :: dfr ! 1st derivative of fr w.r.t. change in vegwp - real(r8) :: A11, A12, A21, A22, A23, A32, A33 ! matrix relating vegwp to flux divergence f=A*d(vegwp) - real(r8) :: leading ! inverse of determiniant - real(r8) :: determ ! determinant of matrix - real(r8) :: grav1 ! gravitational potential surface to canopy top (mm H2O) - real(r8) :: f(nvegwcs) - real(r8), parameter :: tol_lai=1.e-7_r8 ! minimum lai where transpiration is calc'd - integer, parameter :: leafsun=1 - integer, parameter :: leafsha=2 - integer, parameter :: xyl=3 - integer, parameter :: root=4 - integer :: j ! index - !------------------------------------------------------------------------------ - - grav1 = htop*1000._r8 - - !compute conductance attentuation for each segment - fsto= plc(x(leafsha),psi50_sha,ck) - fx= plc(x(xyl),psi50_xyl,ck) - fr= plc(x(root),psi50_root,ck) - - !compute 1st deriv of conductance attenuation for each segment - dfsto= d1plc(x(leafsha),psi50_sha,ck) - dfx= d1plc(x(xyl),psi50_xyl,ck) - dfr= d1plc(x(root),psi50_root,ck) - - A11 = - lai * kmax_sha * fx& - - qflx * dfsto - A12 = lai * kmax_sha * dfx * (x(xyl)-x(leafsha))& - + lai * kmax_sha * fx - A21 = lai * kmax_sha * fx - A22 = - lai * kmax_sha * dfx * (x(xyl)-x(leafsha)) - lai * kmax_sha * fx& - - sai * kmax_xyl / htop * fr - A23 = sai * kmax_xyl / htop * dfr * (x(root)-x(xyl)-grav1)& - + sai * kmax_xyl / htop * fr - A32 = sai * kmax_xyl / htop * fr - A33 = - sai * kmax_xyl / htop * fr& - - sai * kmax_xyl / htop * dfr * (x(root)-x(xyl)-grav1)& - + dqeroot - - f(leafsha) = qflx * fsto - lai * kmax_sha * fx * (x(xyl)-x(leafsha)) - f(xyl) = lai * kmax_sha * fx * (x(xyl)-x(leafsha)) & - - sai * kmax_xyl / htop * fr * (x(root)-x(xyl)-grav1) - f(root) = sai * kmax_xyl / htop * fr * (x(root)-x(xyl)-grav1) - qeroot - determ=A11*A22*A33-A23*A11*A32-A12*A21*A33 - - if(determ .ne. 0)then - dx(leafsha) = (- A12*A33*f(xyl) + A12*A23*f(root) + (A22*A33 - A23*A32)*f(leafsha)) / determ - dx(xyl) = ( A11*A33*f(xyl) - A11*A23*f(root) - A21*A33*f(leafsha)) / determ - dx(root) = (- A11*A32*f(xyl) + (A11*A22 - A12*A21)*f(root) + A21*A32*f(leafsha)) / determ - - dx(leafsun) = x(leafsha) - x(leafsun) + dx(leafsha) - else - dx = 0._r8 - end if - - end subroutine spacAF_oneleaf - !------------------------------------------------------------------------------ subroutine spacAF_twoleaf(x,nvegwcs,dx,nl_soil,qflx_sun,qflx_sha,laisun,laisha,sai,htop,& qeroot,dqeroot,kmax_sun,kmax_sha,kmax_xyl,kmax_root,& @@ -957,12 +519,10 @@ subroutine spacAF_twoleaf(x,nvegwcs,dx,nl_soil,qflx_sun,qflx_sha,laisun,laisha,s end subroutine spacAF_twoleaf !-------------------------------------------------------------------------------- - - !-------------------------------------------------------------------------------- - subroutine getvegwp_oneleaf(x, nvegwcs, nl_soil, z_soi, gb_mol, gs_mol, & - qsatl, qaf,qg,qm,rhoair, psrf, fwet, lai, htop, sai, tl, sigf,& - raw, rd, smp, k_soil_root, k_ax_root, kmax_xyl, kmax_root, & - psi50_sun, psi50_sha, psi50_xyl, psi50_root, ck, soilflux, rootr, etr) + subroutine getvegwp_twoleaf(x, nvegwcs, nl_soil, z_soi, gb_mol, gs_mol_sun, gs_mol_sha, & + qsatl, qaf,qg,qm,rhoair, psrf, fwet, laisun, laisha, htop, sai, tl, rss, & + raw, rd, smp, k_soil_root, k_ax_root, kmax_xyl, kmax_root, rstfacsun, rstfacsha, & + psi50_sun, psi50_sha, psi50_xyl, psi50_root, ck, rootflux, etrsun, etrsha) ! !DESCRIPTION: ! Calculates transpiration and returns corresponding vegwp in x ! @@ -976,105 +536,10 @@ subroutine getvegwp_oneleaf(x, nvegwcs, nl_soil, z_soi, gb_mol, gs_mol, & real(r8) , intent(out) :: x(nvegwcs) ! working copy of veg water potential for patch p integer , intent(in) :: nl_soil ! number of soil layers real(r8) , intent(in) :: z_soi(nl_soil) ! node depth [m] - real(r8) , intent(in) :: gb_mol ! Shaded leaf boundary layer conductance [umol H2O/m**2/s] - real(r8) , intent(inout) :: gs_mol ! Ball-Berry leaf conductance [umol H2O/m**2/s] - real(r8) , intent(in) :: qsatl ! Shalit leaf specific humidity [kg/kg] - real(r8) , intent(in) :: qaf ! humidity of canopy air [kg/kg] - real(r8) , intent(in) :: qg ! specific humidity at ground surface [kg/kg] - real(r8) , intent(in) :: qm ! specific humidity at reference height [kg/kg] - real(r8) , intent(in) :: rhoair ! density [kg/m**3] - real(r8) , intent(in) :: psrf ! atmospheric pressure [Pa] - real(r8) , intent(in) :: fwet ! fraction of foliage that is green and dry [-] - real(r8) , intent(in) :: lai ! Shaded leaf area index - real(r8) , intent(in) :: htop ! canopy top [m] - real(r8) , intent(in) :: sai ! stem area index - real(r8) , intent(in) :: tl ! shaded leaf temperature - real(r8) , intent(in) :: sigf ! fraction of veg cover, excluding snow-covered veg [-] - real(r8) , intent(in) :: kmax_xyl - real(r8) , intent(in) :: kmax_root - real(r8) , intent(in) :: psi50_sun ! water potential at 50% loss of sunlit leaf tissue conductance (mmH2O) - real(r8) , intent(in) :: psi50_sha ! water potential at 50% loss of shaded leaf tissue conductance (mmH2O) - real(r8) , intent(in) :: psi50_xyl ! water potential at 50% loss of xylem tissue conductance (mmH2O) - real(r8) , intent(in) :: psi50_root ! water potential at 50% loss of root tissue conductance (mmH2O) - real(r8) , intent(in) :: ck ! - real(r8) , intent(in) :: raw ! moisture resistance [s/m] - real(r8) , intent(in) :: rd ! aerodynamical resistance between ground and canopy air - real(r8) , intent(in) :: smp(nl_soil) ! soil matrix potential - real(r8) , intent(in) :: k_soil_root(nl_soil) ! soil-root interface conductance [mm/s] - real(r8) , intent(in) :: k_ax_root(nl_soil) ! root axial-direction conductance [mm/s] - real(r8) , intent(out) :: soilflux ! total soil column transpiration [mm/s] - real(r8) , intent(out) :: etr ! transpiration from shaded leaf (mm/s) - real(r8) , intent(out) :: rootr(nl_soil) ! root water uptake from different layers - ! - ! !LOCAL VARIABLES: - real(r8) :: qeroot - real(r8) :: dummy - real(r8) :: fx ! fraction of maximum conductance, xylem-to-leaf [-] - real(r8) :: fr ! fraction of maximum conductance, root-to-xylem [-] - real(r8) :: x_root_top - real(r8) :: xroot(nl_soil) - real(r8) :: grav1 ! gravitational potential surface to canopy top (mm H2O) - real(r8) :: grav2(nl_soil) ! soil layer gravitational potential relative to surface (mm H2O) - integer :: j ! index - logical :: havegs ! signals direction of calculation gs->qflx or qflx->gs - logical :: haroot ! signals direction of calculation x_root_top->qeroot or qeroot->x_root_top - integer, parameter :: leafsun=1 - integer, parameter :: leafsha=2 - integer, parameter :: xyl=3 - integer, parameter :: root=4 - !---------------------------------------------------------------------- - grav1 = 1000._r8 * htop - grav2(1:nl_soil) = 1000._r8 * z_soi(1:nl_soil) - - !compute transpiration demand - havegs=.true. - call getqflx_gs2qflx_oneleaf(gb_mol,gs_mol,etr,qsatl,qaf, & - rhoair,psrf,lai,sai,fwet,tl,sigf,raw,rd,qg,qm) - - !calculate root water potential - call getrootqflx_qe2x(nl_soil,smp,z_soi,k_soil_root,k_ax_root,etr,xroot,x_root_top) - - !calculate xylem water potential - fr = plc(x(root),psi50_root,ck) - x(xyl) = x(root) - grav1 - etr/(fr*kmax_root/htop*sai) - - !calculate sun/sha leaf water potential - fx = plc(x(xyl),psi50_xyl,ck) - x(leafsha) = x(xyl) - etr/(fx*kmax_xyl*lai) - x(leafsun) = x(xyl) - - !calculate soil flux - do j = 1,nl_soil - rootr(j) = k_soil_root(j)*(smp(j)-xroot(j)) - enddo - soilflux = sum(rootr(:)) - - end subroutine getvegwp_oneleaf - - !-------------------------------------------------------------------------------- - subroutine getvegwp_twoleaf(x, nvegwcs, nl_soil, z_soi, gb_mol_sun, gb_mol_sha, gs_mol_sun, gs_mol_sha, & - qsatlsun, qsatlsha, qaf,qg,qm,rhoair, psrf, fwet, laisun, laisha, htop, sai, tlsun, tlsha, sigf,& - raw, rd, smp, k_soil_root, k_ax_root, kmax_xyl, kmax_root, & - psi50_sun, psi50_sha, psi50_xyl, psi50_root, ck, soilflux, rootr, etrsun, etrsha) - ! !DESCRIPTION: - ! Calculates transpiration and returns corresponding vegwp in x - ! - ! !USES: - ! calls getqflx - use MOD_Const_Physical, only : tfrz - implicit none - ! - ! !ARGUMENTS: - integer , intent(in) :: nvegwcs - real(r8) , intent(out) :: x(nvegwcs) ! working copy of veg water potential for patch p - integer , intent(in) :: nl_soil ! number of soil layers - real(r8) , intent(in) :: z_soi(nl_soil) ! node depth [m] - real(r8) , intent(in) :: gb_mol_sun ! Sunlit leaf boundary layer conductance [umol H2O/m**2/s] - real(r8) , intent(in) :: gb_mol_sha ! Shaded leaf boundary layer conductance [umol H2O/m**2/s] + real(r8) , intent(in) :: gb_mol ! Leaf boundary layer conductance [umol H2O/m**2/s] real(r8) , intent(inout) :: gs_mol_sun ! Ball-Berry leaf conductance [umol H2O/m**2/s] real(r8) , intent(inout) :: gs_mol_sha ! Ball-Berry leaf conductance [umol H2O/m**2/s] - real(r8) , intent(in) :: qsatlsun ! Sunlit leaf specific humidity [kg/kg] - real(r8) , intent(in) :: qsatlsha ! Shalit leaf specific humidity [kg/kg] + real(r8) , intent(in) :: qsatl ! Sunlit leaf specific humidity [kg/kg] real(r8) , intent(in) :: qaf ! humidity of canopy air [kg/kg] real(r8) , intent(in) :: qg ! specific humidity at ground surface [kg/kg] real(r8) , intent(in) :: qm ! specific humidity at reference height [kg/kg] @@ -1085,25 +550,25 @@ subroutine getvegwp_twoleaf(x, nvegwcs, nl_soil, z_soi, gb_mol_sun, gb_mol_sha, real(r8) , intent(in) :: laisha ! Shaded leaf area index real(r8) , intent(in) :: htop ! canopy top [m] real(r8) , intent(in) :: sai ! stem area index - real(r8) , intent(in) :: tlsun ! sunlit leaf temperature - real(r8) , intent(in) :: tlsha ! shaded leaf temperature - real(r8) , intent(in) :: sigf ! fraction of veg cover, excluding snow-covered veg [-] + real(r8) , intent(in) :: tl ! leaf temperature real(r8) , intent(in) :: kmax_xyl real(r8) , intent(in) :: kmax_root + real(r8) , intent(in) :: rstfacsun + real(r8) , intent(in) :: rstfacsha real(r8) , intent(in) :: psi50_sun ! water potential at 50% loss of sunlit leaf tissue conductance (mmH2O) real(r8) , intent(in) :: psi50_sha ! water potential at 50% loss of shaded leaf tissue conductance (mmH2O) real(r8) , intent(in) :: psi50_xyl ! water potential at 50% loss of xylem tissue conductance (mmH2O) real(r8) , intent(in) :: psi50_root ! water potential at 50% loss of root tissue conductance (mmH2O) real(r8) , intent(in) :: ck ! + real(r8) , intent(in) :: rss ! soil surface resistance [s/m] real(r8) , intent(in) :: raw ! moisture resistance [s/m] real(r8) , intent(in) :: rd ! aerodynamical resistance between ground and canopy air real(r8) , intent(in) :: smp(nl_soil) ! soil matrix potential real(r8) , intent(in) :: k_soil_root(nl_soil) ! soil-root interface conductance [mm/s] real(r8) , intent(in) :: k_ax_root(nl_soil) ! root axial-direction conductance [mm/s] - real(r8) , intent(out) :: soilflux ! total soil column transpiration [mm/s] real(r8) , intent(out) :: etrsun ! transpiration from sunlit leaf (mm/s) real(r8) , intent(out) :: etrsha ! transpiration from shaded leaf (mm/s) - real(r8) , intent(out) :: rootr(nl_soil) ! root water uptake from different layers + real(r8) , intent(out) :: rootflux(nl_soil) ! root water uptake from different layers ! ! !LOCAL VARIABLES: ! real(r8) :: qflx_sun ! Sunlit leaf transpiration [kg/m2/s] @@ -1123,19 +588,21 @@ subroutine getvegwp_twoleaf(x, nvegwcs, nl_soil, z_soi, gb_mol_sun, gb_mol_sha, integer, parameter :: leafsha=2 integer, parameter :: xyl=3 integer, parameter :: root=4 + real(r8) :: soilflux ! total soil column transpiration [mm/s] !---------------------------------------------------------------------- grav1 = 1000._r8 * htop grav2(1:nl_soil) = 1000._r8 * z_soi(1:nl_soil) !compute transpiration demand havegs=.true. - call getqflx_gs2qflx_twoleaf(gb_mol_sun,gb_mol_sha,gs_mol_sun,gs_mol_sha,etrsun,etrsha,qsatlsun,qsatlsha,qaf, & - rhoair,psrf,laisun,laisha,sai,fwet,tlsun,tlsha,sigf,raw,rd,qg,qm) + call getqflx_gs2qflx_twoleaf(gb_mol,gs_mol_sun,gs_mol_sha,etrsun,etrsha,qsatl,qaf, & + rhoair,psrf,laisun,laisha,sai,fwet,tl,rss,raw,rd,qg,qm,rstfacsun,rstfacsha) !calculate root water potential qeroot = etrsun + etrsha call getrootqflx_qe2x(nl_soil,smp,z_soi,k_soil_root,k_ax_root,qeroot,xroot,x_root_top) + x(root) = x_root_top !calculate xylem water potential fr = plc(x(root),psi50_root,ck) @@ -1146,17 +613,19 @@ subroutine getvegwp_twoleaf(x, nvegwcs, nl_soil, z_soi, gb_mol_sun, gb_mol_sha, x(leafsha) = x(xyl) - (etrsha/(fx*kmax_xyl*laisha)) x(leafsun) = x(xyl) - (etrsun/(fx*kmax_xyl*laisun)) + !calculate soil flux do j = 1,nl_soil - rootr(j) = k_soil_root(j)*(smp(j)-xroot(j)) + rootflux(j) = k_soil_root(j)*(smp(j)-xroot(j)) enddo - soilflux = sum(rootr(:)) + + soilflux = sum(rootflux(:)) end subroutine getvegwp_twoleaf !-------------------------------------------------------------------------------- - subroutine getqflx_gs2qflx_oneleaf(gb_mol,gs_mol,qflx,qsatl,qaf, & - rhoair,psrf,lai,sai,fwet,tl,sigf,raw,rd,qg,qm) + subroutine getqflx_gs2qflx_twoleaf(gb_mol,gs_mol_sun,gs_mol_sha,qflx_sun,qflx_sha,qsatl,qaf,& + rhoair,psrf,laisun,laisha,sai,fwet,tl,rss,raw,rd,qg,qm,rstfacsun,rstfacsha) ! !DESCRIPTION: ! calculate sunlit and shaded transpiration using gb_MOL and gs_MOL ! !USES: @@ -1164,174 +633,91 @@ subroutine getqflx_gs2qflx_oneleaf(gb_mol,gs_mol,qflx,qsatl,qaf, & implicit none ! ! !ARGUMENTS: - real(r8) , intent(in) :: gb_mol ! Shaded leaf boundary layer conductance (umol H2O/m**2/s), leaf scale - real(r8) , intent(inout) :: gs_mol ! Ball-Berry leaf conductance (umol H2O/m**2/s), leaf scale - real(r8) , intent(inout) :: qflx ! Shaded leaf transpiration [kg/m2/s] - real(r8) , intent(in) :: qsatl ! Shaded leaf specific humidity [kg/kg] + real(r8) , intent(in) :: gb_mol ! leaf boundary layer conductance (mol H2O/m**2/s), leaf scale + real(r8) , intent(inout) :: gs_mol_sun ! Ball-Berry leaf conductance (mol H2O/m**2/s), leaf scale + real(r8) , intent(inout) :: gs_mol_sha ! Ball-Berry leaf conductance (mol H2O/m**2/s), leaf scale + real(r8) , intent(inout) :: qflx_sun ! Sunlit leaf transpiration [kg/m2/s] + real(r8) , intent(inout) :: qflx_sha ! Shaded leaf transpiration [kg/m2/s] + real(r8) , intent(in) :: qsatl ! leaf specific humidity [kg/kg] real(r8) , intent(in) :: qaf ! humidity of canopy air [kg/kg] real(r8) , intent(in) :: qg ! specific humidity at ground surface [kg/kg] real(r8) , intent(in) :: qm ! specific humidity at reference height [kg/kg] - real(r8) , intent(in) :: rhoair ! density (kg/m**3) - real(r8) , intent(in) :: psrf ! atmospheric pressure (Pa) - real(r8) , intent(in) :: lai ! shaded leaf area index (m2/m2) + real(r8) , intent(in) :: rhoair ! density (kg/m**3) + real(r8) , intent(in) :: psrf ! atmospheric pressure (Pa) + real(r8) , intent(in) :: laisun ! sunlit leaf area index (m2/m2) + real(r8) , intent(in) :: laisha ! shaded leaf area index (m2/m2) real(r8) , intent(in) :: sai ! stem area index (m2/m2) real(r8) , intent(in) :: fwet ! fraction of foliage that is green and dry [-] - real(r8) , intent(in) :: tl ! shaded leaf temperature - real(r8) , intent(in) :: sigf ! fraction of veg cover, excluding snow-covered veg [-] + real(r8) , intent(in) :: tl ! shaded leaf temperature + real(r8) , intent(in) :: rss ! soil surface resistance [s/m] real(r8) , intent(in) :: raw ! moisture resistance [s/m] real(r8) , intent(in) :: rd ! aerodynamical resistance between ground and canopy air + real(r8) ,optional, intent(in) :: rstfacsun + real(r8) ,optional, intent(in) :: rstfacsha ! ! !LOCAL VARIABLES: - real(r8) :: wtl ! heat conductance for shaded leaf boundary [m/s] - real(r8) :: efpot ! potential latent energy flux for shaded leaf [kg/m2/s] - real(r8) :: rppdry ! fraction of potential evaporation through transp - shaded [-] - real(r8) :: cf ! s m**2/umol -> s/m - real(r8) :: tprcor !tf*psur*100./1.013e5 + real(r8) :: cf ! (umol/m**3) r = cf./g gmol(umol/m**2/s) -> r(s/m) + real(r8) :: tprcor ! tf*psur*100./1.013e5 real(r8) :: wtaq0 ! normalized latent heat conductance for air [-] real(r8) :: wtgq0 ! normalized latent heat conductance for ground [-] - real(r8) :: wtlq0 ! normalized latent heat cond. for air and shaded leaf [-] + real(r8) :: wtlq0 ! normalized latent heat cond. for air and sunlit leaf [-] real(r8) :: wtsqi ! latent heat resistance for air, grd and leaf [-] real(r8) :: delta real(r8) :: caw ! latent heat conductance for air [m/s] real(r8) :: cgw ! latent heat conductance for ground [m/s] - real(r8) :: cfw ! latent heat conductance for sunlit leaf [m/s] + real(r8) :: cfw ! latent heat conductance for leaf [m/s] !---------------------------------------------------------------------- tprcor = 44.6*273.16*psrf/1.013e5 - cf = tprcor/tl * 1.e6_r8 ! gb->gbmol conversion factor - wtl = (lai+sai)*gb_mol + cf = tprcor/tl * 1.e6_r8 ! gb->gbmol conversion factor delta = 0.0 if(qsatl-qaf .gt. 0.) delta = 1.0 - caw = sigf / raw - cgw = sigf / rd - cfw = sigf * ( (1.-delta*(1.-fwet)) * (lai+sai) * gb_mol /cf & - + (1. - fwet) * delta * lai / (1._r8/gb_mol+1._r8/gs_mol)/cf) + caw = 1. / raw + IF (qg < qaf)THEN + cgw = 1. / rd + ELSE + IF (DEF_RSS_SCHEME .eq. 4) THEN + cgw = rss / rd + ELSE + cgw = 1. / (rd + rss) + END IF + END IF + cfw = (1.-delta*(1.-fwet)) * (laisun+laisha+sai)*gb_mol/cf + (1.-fwet)*delta*& + (laisun/(1._r8/gb_mol+1._r8/gs_mol_sun)/cf+laisha/(1._r8/gb_mol+1._r8/gs_mol_sha)/cf) wtsqi = 1. / ( caw + cgw + cfw ) wtaq0 = caw * wtsqi wtgq0 = cgw * wtsqi wtlq0 = cfw * wtsqi - efpot = sigf*rhoair*wtl*delta& - * ((wtaq0+wtgq0)*qsatl-wtaq0*qm-wtgq0*qg) - - rppdry = (1.-fwet)/gb_mol*(lai/(1._r8/gb_mol+1._r8/gs_mol))/(lai+sai) - qflx = efpot*rppdry/cf - if(qflx < 1.e-7_r8)then - qflx = 0._r8 + qflx_sun = rhoair * (1.-fwet) * delta & + * laisun / (1./gb_mol+1./gs_mol_sun)/cf & + * ( (wtaq0 + wtgq0)*qsatl - wtaq0*qm - wtgq0*qg ) +! if(qflx_sun < 1.e-7_r8)then +! qflx_sun = 0._r8 +! end if + if(present(rstfacsun))then + if(rstfacsun .le. 1.e-2)qflx_sun = 0._r8 end if - - end subroutine getqflx_gs2qflx_oneleaf - - !-------------------------------------------------------------------------------- - subroutine getqflx_gs2qflx_twoleaf(gb_mol_sun,gb_mol_sha,gs_mol_sun,gs_mol_sha,qflx_sun,qflx_sha,qsatlsun,qsatlsha,qaf,& - rhoair,psrf,laisun,laisha,sai,fwet,tlsun,tlsha,sigf,raw,rd,qg,qm) - ! !DESCRIPTION: - ! calculate sunlit and shaded transpiration using gb_MOL and gs_MOL - ! !USES: - ! - implicit none - ! - ! !ARGUMENTS: - real(r8) , intent(in) :: gb_mol_sun ! Sunlit leaf boundary layer conductance (mol H2O/m**2/s), leaf scale - real(r8) , intent(in) :: gb_mol_sha ! Shaded leaf boundary layer conductance (mol H2O/m**2/s), leaf scale - real(r8) , intent(inout) :: gs_mol_sun ! Ball-Berry leaf conductance (mol H2O/m**2/s), leaf scale - real(r8) , intent(inout) :: gs_mol_sha ! Ball-Berry leaf conductance (mol H2O/m**2/s), leaf scale - real(r8) , intent(inout) :: qflx_sun ! Sunlit leaf transpiration [kg/m2/s] - real(r8) , intent(inout) :: qflx_sha ! Shaded leaf transpiration [kg/m2/s] - real(r8) , intent(in) :: qsatlsun ! Sunlit leaf specific humidity [kg/kg] - real(r8) , intent(in) :: qsatlsha ! Shaded leaf specific humidity [kg/kg] - real(r8) , intent(in) :: qaf ! humidity of canopy air [kg/kg] - real(r8) , intent(in) :: qg ! specific humidity at ground surface [kg/kg] - real(r8) , intent(in) :: qm ! specific humidity at reference height [kg/kg] - real(r8) , intent(in) :: rhoair ! density (kg/m**3) - real(r8) , intent(in) :: psrf ! atmospheric pressure (Pa) - real(r8) , intent(in) :: laisun ! sunlit leaf area index (m2/m2) - real(r8) , intent(in) :: laisha ! shaded leaf area index (m2/m2) - real(r8) , intent(in) :: sai ! stem area index (m2/m2) - real(r8) , intent(in) :: fwet ! fraction of foliage that is green and dry [-] - real(r8) , intent(in) :: tlsun ! shaded leaf temperature - real(r8) , intent(in) :: tlsha ! shaded leaf temperature - real(r8) , intent(in) :: sigf ! fraction of veg cover, excluding snow-covered veg [-] - real(r8) , intent(in) :: raw ! moisture resistance [s/m] - real(r8) , intent(in) :: rd ! aerodynamical resistance between ground and canopy air - - ! - ! !LOCAL VARIABLES: - real(r8) :: wtlsun ! heat conductance for sunlit leaf boundary [m/s] - real(r8) :: wtlsha ! heat conductance for shaded leaf boundary [m/s] - real(r8) :: efpotsun ! potential latent energy flux for sunlit leaf [kg/m2/s] - real(r8) :: efpotsha ! potential latent energy flux for shaded leaf [kg/m2/s] - real(r8) :: rppdry_sun ! fraction of potential evaporation through transp - sunlit [-] - real(r8) :: rppdry_sha ! fraction of potential evaporation through transp - shaded [-] - real(r8) :: cfsun ! s m**2/umol -> s/m - real(r8) :: cfsha ! s m**2/umol -> s/m - real(r8) :: tprcor !tf*psur*100./1.013e5 - - real(r8) :: wtaq0 ! normalized latent heat conductance for air [-] - real(r8) :: wtgq0 ! normalized latent heat conductance for ground [-] - real(r8) :: wtlsunq0 ! normalized latent heat cond. for air and sunlit leaf [-] - real(r8) :: wtlshaq0 ! normalized latent heat cond. for air and shaded leaf [-] - real(r8) :: wtsqi ! latent heat resistance for air, grd and leaf [-] - - real(r8) :: delta1 - real(r8) :: delta2 - real(r8) :: caw ! latent heat conductance for air [m/s] - real(r8) :: cgw ! latent heat conductance for ground [m/s] - real(r8) :: cfsunw ! latent heat conductance for sunlit leaf [m/s] - real(r8) :: cfshaw ! latent heat conductance for shaded leaf [m/s] - - !---------------------------------------------------------------------- - tprcor = 44.6*273.16*psrf/1.013e5 - cfsun = tprcor/tlsun * 1.e6_r8 ! gb->gbmol conversion factor - cfsha = tprcor/tlsha * 1.e6_r8 ! gb->gbmol conversion factor - wtlsun = (laisun+laisha+sai)*gb_mol_sun - wtlsha = (laisun+laisha+sai)*gb_mol_sha - - delta1 = 0.0 - delta2 = 0.0 - if(qsatlsun-qaf .gt. 0.) delta1 = 1.0 - if(qsatlsha-qaf .gt. 0.) delta2 = 1.0 - - caw = sigf / raw - cgw = sigf / rd - cfsunw = sigf * ( (1.-delta1*(1.-fwet)) * laisun * gb_mol_sun /cfsun & - + (1. - fwet) * delta1 * laisun / (1._r8/gb_mol_sun+1._r8/gs_mol_sun)/cfsun) - cfshaw = sigf * ( (1.-delta2*(1.-fwet)) * (laisha+sai) * gb_mol_sha /cfsha & - + (1. - fwet) * delta2 * laisha / (1._r8/gb_mol_sha+1._r8/gs_mol_sha)/cfsha) - wtsqi = 1. / ( caw + cgw + cfsunw + cfshaw ) - - wtaq0 = caw * wtsqi - wtgq0 = cgw * wtsqi - wtlsunq0 = cfsunw * wtsqi - wtlshaq0 = cfshaw * wtsqi - - efpotsun = sigf*rhoair*wtlsun*delta1& - * ((wtaq0+wtgq0+wtlshaq0)*qsatlsun-wtaq0*qm-wtgq0*qg-wtlshaq0*qsatlsha) - efpotsha = sigf*rhoair*wtlsha*delta2& - * ((wtaq0+wtgq0+wtlsunq0)*qsatlsha-wtaq0*qm-wtgq0*qg-wtlsunq0*qsatlsun) - - - rppdry_sun = (1.-fwet)/gb_mol_sun*(laisun/(1._r8/gb_mol_sun+1._r8/gs_mol_sun))/(laisun+laisha+sai) - qflx_sun = efpotsun*rppdry_sun/cfsun - if(qflx_sun < 1.e-7_r8)then - qflx_sun = 0._r8 - end if - rppdry_sha = (1.-fwet)/gb_mol_sha*(laisha/(1._r8/gb_mol_sha+1._r8/gs_mol_sha))/(laisun+laisha+sai) - qflx_sha = efpotsha*rppdry_sha/cfsha - if(qflx_sha < 1.e-7)then - qflx_sha = 0._r8 + qflx_sha = rhoair * (1.-fwet) * delta & + * laisha / (1./gb_mol+1./gs_mol_sha)/cf & + * ( (wtaq0 + wtgq0)*qsatl - wtaq0*qm - wtgq0*qg ) +! if(qflx_sha < 1.e-7)then +! qflx_sha = 0._r8 +! end if + if(present(rstfacsha))then + if(rstfacsha .le. 1.e-2)qflx_sha = 0._r8 end if end subroutine getqflx_gs2qflx_twoleaf - subroutine getqflx_qflx2gs_oneleaf(gb_mol,gs_mol,qflx,qsatl,qaf,rhoair,psrf,lai,sai,& - fwet,tl,sigf,raw,rd,qg,qm) + subroutine getqflx_qflx2gs_twoleaf(gb_mol,gs_mol_sun,gs_mol_sha,qflx_sun,qflx_sha,qsatl,qaf, & + rhoair,psrf,laisun,laisha,sai,fwet,tl,rss,raw,rd,qg,qm) ! !DESCRIPTION: ! calculate sunlit and shaded transpiration using gb_MOL and gs_MOL ! !USES: @@ -1339,91 +725,23 @@ subroutine getqflx_qflx2gs_oneleaf(gb_mol,gs_mol,qflx,qsatl,qaf,rhoair,psrf,lai, implicit none ! ! !ARGUMENTS: - real(r8) , intent(in) :: gb_mol ! Shaded leaf boundary layer conductance (mol H2O/m**2/s), leaf scale - real(r8) , intent(inout) :: gs_mol ! Ball-Berry leaf conductance (mol H2O/m**2/s), leaf scale - real(r8) , intent(in) :: qflx ! Shaded leaf transpiration [kg/m2/s] - real(r8) , intent(in) :: qsatl ! Shaded leaf specific humidity [kg/kg] - real(r8) , intent(in) :: qaf ! humidity of canopy air [kg/kg] - real(r8) , intent(in) :: qg ! specific humidity at ground surface [kg/kg] - real(r8) , intent(in) :: qm ! specific humidity at reference height [kg/kg] - real(r8) , intent(in) :: rhoair ! density (kg/m**3) - real(r8) , intent(in) :: psrf ! atmospheric pressure (Pa) - real(r8) , intent(in) :: lai ! shaded leaf area index (m2/m2) - real(r8) , intent(in) :: sai ! stem area index (m2/m2) - real(r8) , intent(in) :: fwet ! fraction of foliage that is green and dry [-] - real(r8) , intent(in) :: tl ! shaded leaf temperature - real(r8) , intent(in) :: sigf ! fraction of veg cover, excluding snow-covered veg [-] - real(r8) , intent(in) :: raw ! moisture resistance [s/m] - real(r8) , intent(in) :: rd ! aerodynamical resistance between ground and canopy air - - ! - ! !LOCAL VARIABLES: - real(r8) :: wtl ! heat conductance for shaded leaf boundary [m/s] - real(r8) :: efpot ! potential latent energy flux for shaded leaf [kg/m2/s] - real(r8) :: rppdry ! fraction of potential evaporation through transp - shaded [-] - real(r8) :: cf ! s m**2/umol -> s/m - real(r8) :: tprcor !tf*psur*100./1.013e5 - - real(r8) :: wtaq0 ! normalized latent heat conductance for air [-] - real(r8) :: wtgq0 ! normalized latent heat conductance for ground [-] - real(r8) :: wtlq0 ! normalized latent heat cond. for air and shaded leaf [-] - real(r8) :: cqi_wet ! latent heat conductance for air, grd and wet leaf [-] - - real(r8) :: delta - real(r8) :: caw ! latent heat conductance for air [m/s] - real(r8) :: cgw ! latent heat conductance for ground [m/s] - real(r8) :: cfw_dry ! latent heat conductance for dry leaf [m/s] - real(r8) :: cfw_wet ! latent heat conductance for wet leaf [m/s] - - !---------------------------------------------------------------------- - if (qflx > 0._r8)then - tprcor = 44.6*273.16*psrf/1.013e5 - cf = tprcor/tl * 1.e6_r8 ! gb->gbmol conversion factor - wtl = (lai+sai)*gb_mol - - delta = 0.0 - if(qsatl-qaf .gt. 0.) delta = 1.0 - - caw = sigf / raw - cgw = sigf / rd - cfw_wet = sigf * (1.-delta*(1.-fwet)) * (lai+sai) * gb_mol /cf - cqi_wet = caw + cgw + cfw_wet - - cfw_dry = qflx/rhoair*cqi_wet / (caw*(qsatl-qm)+cgw*(qsatl-qg)-qflx/rhoair) - gs_mol = 1._r8 / (sigf * (1. - fwet) * delta * lai / cfw_dry / cf - 1._r8 / gb_mol) - endif - - end subroutine getqflx_qflx2gs_oneleaf - - subroutine getqflx_qflx2gs_twoleaf(gb_mol_sun,gb_mol_sha,gs_mol_sun,gs_mol_sha,qflx_sun,qflx_sha,qsatlsun,qsatlsha,qaf, & - rhoair,psrf,laisun,laisha,sai,fwet,tlsun,tlsha,sigf,raw,rd,qg,qm) - ! !DESCRIPTION: - ! calculate sunlit and shaded transpiration using gb_MOL and gs_MOL - ! !USES: - ! - implicit none - ! - ! !ARGUMENTS: - real(r8) , intent(in) :: gb_mol_sun ! Sunlit leaf boundary layer conductance (mol H2O/m**2/s), leaf scale - real(r8) , intent(in) :: gb_mol_sha ! Shaded leaf boundary layer conductance (mol H2O/m**2/s), leaf scale + real(r8) , intent(in) :: gb_mol ! leaf boundary layer conductance (mol H2O/m**2/s), leaf scale real(r8) , intent(inout) :: gs_mol_sun ! Ball-Berry leaf conductance (mol H2O/m**2/s), leaf scale real(r8) , intent(inout) :: gs_mol_sha ! Ball-Berry leaf conductance (mol H2O/m**2/s), leaf scale real(r8) , intent(inout) :: qflx_sun ! Sunlit leaf transpiration [kg/m2/s] real(r8) , intent(inout) :: qflx_sha ! Shaded leaf transpiration [kg/m2/s] - real(r8) , intent(in) :: qsatlsun ! Sunlit leaf specific humidity [kg/kg] - real(r8) , intent(in) :: qsatlsha ! Shaded leaf specific humidity [kg/kg] + real(r8) , intent(in) :: qsatl ! leaf specific humidity [kg/kg] real(r8) , intent(in) :: qaf ! humidity of canopy air [kg/kg] real(r8) , intent(in) :: qg ! specific humidity at ground surface [kg/kg] real(r8) , intent(in) :: qm ! specific humidity at reference height [kg/kg] - real(r8) , intent(in) :: rhoair ! density (kg/m**3) - real(r8) , intent(in) :: psrf ! atmospheric pressure (Pa) + real(r8) , intent(in) :: rhoair ! density (kg/m**3) + real(r8) , intent(in) :: psrf ! atmospheric pressure (Pa) real(r8) , intent(in) :: laisun ! sunlit leaf area index (m2/m2) real(r8) , intent(in) :: laisha ! shaded leaf area index (m2/m2) real(r8) , intent(in) :: sai ! stem area index (m2/m2) real(r8) , intent(in) :: fwet ! fraction of foliage that is green and dry [-] - real(r8) , intent(in) :: tlsun ! sunlit leaf temperature - real(r8) , intent(in) :: tlsha ! shaded leaf temperature - real(r8) , intent(in) :: sigf ! fraction of veg cover, excluding snow-covered veg [-] + real(r8) , intent(in) :: tl ! leaf temperature + real(r8) , intent(in) :: rss ! soil surface resistance [s/m] real(r8) , intent(in) :: raw ! moisture resistance [s/m] real(r8) , intent(in) :: rd ! aerodynamical resistance between ground and canopy air @@ -1431,12 +749,7 @@ subroutine getqflx_qflx2gs_twoleaf(gb_mol_sun,gb_mol_sha,gs_mol_sun,gs_mol_sha,q ! !LOCAL VARIABLES: real(r8) :: wtlsun ! heat conductance for sunlit leaf boundary [m/s] real(r8) :: wtlsha ! heat conductance for shaded leaf boundary [m/s] - real(r8) :: efpotsun ! potential latent energy flux for sunlit leaf [kg/m2/s] - real(r8) :: efpotsha ! potential latent energy flux for shaded leaf [kg/m2/s] - real(r8) :: rppdry_sun ! fraction of potential evaporation through transp - sunlit [-] - real(r8) :: rppdry_sha ! fraction of potential evaporation through transp - shaded [-] - real(r8) :: cfsun ! s m**2/umol -> s/m - real(r8) :: cfsha ! s m**2/umol -> s/m + real(r8) :: cf ! s m**2/umol -> s/m real(r8) :: tprcor !tf*psur*100./1.013e5 real(r8) :: wtaq0 ! normalized latent heat conductance for air [-] @@ -1444,65 +757,57 @@ subroutine getqflx_qflx2gs_twoleaf(gb_mol_sun,gb_mol_sha,gs_mol_sun,gs_mol_sha,q real(r8) :: wtlsunq0 ! normalized latent heat cond. for air and sunlit leaf [-] real(r8) :: wtlshaq0 ! normalized latent heat cond. for air and shaded leaf [-] - real(r8) :: delta1 - real(r8) :: delta2 + real(r8) :: delta real(r8) :: caw ! latent heat conductance for air [m/s] real(r8) :: cgw ! latent heat conductance for ground [m/s] - real(r8) :: cfsunw_dry ! latent heat conductance for sunlit dry leaf [m/s] - real(r8) :: cfsunw_wet ! latent heat conductance for sunlit wet leaf [m/s] - real(r8) :: cfshaw_dry ! latent heat conductance for shaded dry leaf [m/s] - real(r8) :: cfshaw_wet ! latent heat conductance for shaded wet leaf [m/s] + real(r8) :: cwet ! latent heat conductance for wet leaf [m/s] + real(r8) :: csunw_dry ! latent heat conductance for sunlit dry leaf [m/s] + real(r8) :: cshaw_dry ! latent heat conductance for shaded dry leaf [m/s] real(r8) :: cqi_wet ! latent heat conductance for air, grd and wet leaf [-] - real(r8) :: Delta,deltaq, & ! temporary variables to solve cfsunw_dry and cfshaw_dry - A1,B1,C1,A2,B2,C2 ! in binary quadratic equations + real(r8) :: cqi_leaf ! (wtaq0 + wtgq0)*qsatl - wtaq0*qm - wtgq0*qg [m/s] + real(r8) :: A1,B1,C1,A2,B2,C2 ! in binary quadratic equations !---------------------------------------------------------------------- if(qflx_sun .gt. 0 .or. qflx_sha .gt. 0)then - tprcor = 44.6*273.16*psrf/1.013e5 - cfsun = tprcor/tlsun * 1.e6_r8 ! gb->gbmol conversion factor - cfsha = tprcor/tlsha * 1.e6_r8 ! gb->gbmol conversion factor - wtlsun = (laisun+laisha+sai)*gb_mol_sun - wtlsha = (laisun+laisha+sai)*gb_mol_sha - - delta1 = 0.0 - delta2 = 0.0 - if(qsatlsun-qaf .gt. 0.) delta1 = 1.0 - if(qsatlsha-qaf .gt. 0.) delta2 = 1.0 - - caw = sigf / raw - cgw = sigf / rd - cfsunw_wet = sigf * (1.-delta1*(1.-fwet)) * laisun * gb_mol_sun / cfsun - cfshaw_wet = sigf * (1.-delta2*(1.-fwet)) * (laisha+sai) * gb_mol_sha / cfsha - - cqi_wet = ( caw + cgw + cfsunw_wet + cfshaw_wet ) - - deltaq = qsatlsun - qsatlsha - + tprcor = 44.6*273.16*psrf/1.013e5 + cf = tprcor/tl * 1.e6_r8 ! gb->gbmol conversion factor + + delta = 0.0 + if(qsatl-qaf .gt. 0.) delta = 1.0 + + caw = 1. / raw + IF (qg < qaf)THEN + cgw = 1. / rd + ELSE + IF (DEF_RSS_SCHEME .eq. 4) THEN + cgw = rss / rd + ELSE + cgw = 1. / (rd + rss) + END IF + END IF + cwet = (1.-delta*(1.-fwet)) * (laisun + laisha + sai) * gb_mol / cf + cqi_wet = caw + cgw + cwet + cqi_leaf = caw * (qsatl - qm) + cgw * (qsatl - qg) + + ! Solve equations: + ! A1 * csunw_dry + B1 * cfshaw_dry = C1 + ! A2 * csunw_dry + B2 * cfshaw_dry = C2 + + A1 = cqi_leaf - qflx_sun / rhoair B1 = - qflx_sun / rhoair - A1 = caw * (qsatlsun - qm) + cgw * (qsatlsun - qg) + cfshaw_wet * deltaq + B1 - C1 = qflx_sun / rhoair * cqi_wet - B2 = - qflx_sha / rhoair - A2 = caw * (qsatlsha - qm) + cgw * (qsatlsha - qg) - cfsunw_wet * deltaq + B2 - C2 = qflx_sha / rhoair * cqi_wet - - if(deltaq .ne. 0 .and. qflx_sun .gt. 1.e-20 .and. qflx_sha .gt. 1.e-20)then !solve equations deltaq*cfsunw_dry*cfshaw_dry+A1*cfsunw_dry+B1*cfshaw_dry-C1 = 0 - ! && -deltaq*cfsunw_dry*cfshaw_dry+A2*cfshaw_dry+B2*cfsunw_dry-C2 = 0 - Delta = A1**2*A2**2-2*A1*A2*B1*B2-2*A1*A2*C1*deltaq+2*A1*A2*C2*deltaq+4*A1*B1*C2*deltaq-4*A2*B2*C1*deltaq & - + B1**2*B2**2-2*B1*B2*C1*deltaq+2*B1*B2*C2*deltaq+C1**2*deltaq**2+2*C1*C2*deltaq**2+C2**2*deltaq**2 - - cfsunw_dry = (C1*deltaq+C2*deltaq-sqrt(Delta)+A1*A2-B1*B2)/(2*(A1+B2)*deltaq) - cfshaw_dry = (C1*deltaq+C2*deltaq+sqrt(Delta)-A1*A2+B1*B2)/(2*(A2+B1)*deltaq) - else ! solve equations A1*cfsunw_dry+B1*cfshaw_dry-C1 = 0 - ! && A2*cfshaw_dry+B2*cfsunw_dry-C2 = 0 - cfsunw_dry = (A2*C1-B1*C2)/(A1*A2-B1*B2) - cfshaw_dry = (A1*C2-B2*C1)/(A1*A2-B1*B2) - end if + C1 = qflx_sun * cqi_wet / rhoair + A2 = - qflx_sha / rhoair + B2 = cqi_leaf - qflx_sha / rhoair + C2 = qflx_sha * cqi_wet / rhoair + + csunw_dry = (B1*C2 - B2*C1)/(B1*A2 - B2*A1) + cshaw_dry = (A1*C2 - A2*C1)/(A1*B2 - B1*A2) if (qflx_sun > 0._r8) then - gs_mol_sun = 1._r8 / (sigf * (1. - fwet) * delta1 * laisun / cfsunw_dry / cfsun - 1._r8 / gb_mol_sun) + gs_mol_sun = 1._r8 / ((1. - fwet) * delta * laisun / csunw_dry / cf - 1._r8 / gb_mol) endif if (qflx_sha > 0._r8) then - gs_mol_sha = 1._r8 / (sigf * (1. - fwet) * delta2 * laisha / cfshaw_dry / cfsha - 1._r8 / gb_mol_sha) + gs_mol_sha = 1._r8 / ((1. - fwet) * delta * laisha / cshaw_dry / cf - 1._r8 / gb_mol) endif end if @@ -1719,7 +1024,7 @@ function plc(x,psi50,ck) ! else plc=2._r8**tmp ! end if -! if ( plc < 0.00001_r8) plc = 0._r8 + if ( plc < 0.00001_r8) plc = 1.e-5_r8 ! case default ! write(*,*),'must choose plc method' ! end select diff --git a/main/MOD_Qsadv.F90 b/main/MOD_Qsadv.F90 index c83e1e2e..344146e5 100644 --- a/main/MOD_Qsadv.F90 +++ b/main/MOD_Qsadv.F90 @@ -73,9 +73,9 @@ SUBROUTINE qsadv(T,p,es,esdT,qs,qsdT) td = T-273.16 - IF (td < -75.0 .or. td > 75.0) THEN +! IF (td < -75.0 .or. td > 75.0) THEN !* print *, "qsadv: abnormal temperature", T - ENDIF +! ENDIF IF (td < -75.0) td = -75.0 IF (td > 75.0) td = 75.0 diff --git a/main/MOD_RainSnowTemp.F90 b/main/MOD_RainSnowTemp.F90 index 18e0badd..6520d4a4 100644 --- a/main/MOD_RainSnowTemp.F90 +++ b/main/MOD_RainSnowTemp.F90 @@ -19,7 +19,7 @@ MODULE MOD_RainSnowTemp !----------------------------------------------------------------------- - SUBROUTINE rain_snow_temp (itypwat,& + SUBROUTINE rain_snow_temp (patchtype,& forc_t,forc_q,forc_psrf,forc_prc,forc_prl,forc_us,forc_vs,tcrit,& prc_rain,prc_snow,prl_rain,prl_snow,t_precip,bifall) @@ -35,7 +35,7 @@ SUBROUTINE rain_snow_temp (itypwat,& IMPLICIT NONE ! ------------------------ Dummy Argument ------------------------------ - integer, INTENT(in) :: itypwat ! land water type (3=glaciers) + integer, INTENT(in) :: patchtype ! land patch type (3=glaciers) real(r8), INTENT(in) :: forc_t ! temperature at agcm reference height [kelvin] @@ -81,16 +81,16 @@ SUBROUTINE rain_snow_temp (itypwat,& if(t_precip - tfrz > 3.0)then flfall = 1.0 ! fraction of liquid water within falling precip - else if (t_precip >= tfrz -2.0)then + else if (t_precip - tfrz >= -2.0)then flfall = max(0.0, 1.0 - 1.0/(1.0+5.00e-5*exp(2.0*(t_precip-tfrz+4.)))) !Figure 5c of Behrangi et al. (2018) !* flfall = max(0.0, 1.0 - 1.0/(1.0+6.99e-5*exp(2.0*(t_precip-tfrz+3.97)))) !Equation 1 of Wang et al. (2019) else flfall = 0.0 endif - + ELSEIF (trim(DEF_precip_phase_discrimination_scheme) == 'II') THEN glaciers = .false. - if (itypwat == 3) glaciers = .true. + if (patchtype == 3) glaciers = .true. if(glaciers) then all_snow_t_c = -2.0 @@ -110,14 +110,14 @@ SUBROUTINE rain_snow_temp (itypwat,& ELSEIF (trim(DEF_precip_phase_discrimination_scheme) == 'III') THEN ! Phillip Harder and John Pomeroy (2013) ! Estimating precipitation phase using a psychrometric energy - ! balance method . Hydrol Process, 27, 1901–1914 + ! balance method . Hydrol Process, 27, 1901–1914 ! Hydromet_Temp [K] - call Hydromet_Temp(forc_t-273.15,forc_psrf,forc_q,t_hydro) + CALL Hydromet_Temp(forc_psrf,(forc_t-273.15),forc_q,t_hydro) - if(t_hydro > 5.0)then + if(t_hydro > 3.0)then flfall = 1.0 ! fraction of liquid water within falling precip - else if ((t_hydro >= -5.0).and.(t_hydro <= 5.0))then - flfall = max(0.0, 1.0/(1.0+2.50286*0.125006**t_hydro)) + else if ((t_hydro >= -3.0).and.(t_hydro <= 3.0))then + flfall = max(0.0, 1.0/(1.0+2.50286*0.125006**t_hydro)) else flfall = 0.0 endif @@ -152,7 +152,7 @@ SUBROUTINE rain_snow_temp (itypwat,& if (t_precip < tfrz) t_precip = tfrz else t_precip = min(tfrz,t_precip) - if(flfall > 0.0)then + if(flfall > 1.e-6)then t_precip = tfrz - sqrt((1.0/flfall)-1.0)/100.0 endif endif @@ -205,9 +205,9 @@ SUBROUTINE NewSnowBulkDensity(forc_t,forc_us,forc_vs,bifall) end if END SUBROUTINE NewSnowBulkDensity - - !!============================================== - + + !!============================================== + !----------------------------------------------------------------------------- SUBROUTINE HYDROMET_TEMP(PPA, PTA, PQA,PTI) !DESCRIPTION @@ -225,11 +225,11 @@ SUBROUTINE HYDROMET_TEMP(PPA, PTA, PQA,PTI) ! Hydrological Processes 27(13), 1901-1914. https://dx.doi.org/10.1002/hyp.9799 !REVISION HISTORY !---------------- - !---2023.07.30 Aobo Tan & Zhongwang Wei @ SYSU + !---2023.07.30 Aobo Tan & Zhongwang Wei @ SYSU real(r8), INTENT(in) :: PPA ! Air pressure (Pa) - real(r8), INTENT(in) :: PTA ! Air temperature (deg C) - real(r8), INTENT(in) :: PQA ! Air specific humidity (kg/kg) + real(r8), INTENT(in) :: PTA ! Air temperature (deg C) + real(r8), INTENT(in) :: PQA ! Air specific humidity (kg/kg) real(r8), INTENT(out) :: PTI ! Hydrometeo temprtature in deg C real(r8) :: ZD !diffusivity of water vapour in air [m^2 s-1] real(r8) :: ZLAMBDAT !thermal conductivity of air [J m^-1 s^-1 K^-1] @@ -257,8 +257,8 @@ SUBROUTINE HYDROMET_TEMP(PPA, PTA, PQA,PTI) !TODO:check use of dry air? ! 4. Compute density of dry air [kg m-3] - ZRHODA = PPA/(287.04*(PTA+273.15)) - + ZRHODA = PPA/(287.04*(PTA+273.15)) + ! 5. Compute saturated water vapour pressure [Pa] IF(PTA>0) THEN EVSAT = 611.0*EXP(17.27*PTA/(PTA+237.3)) @@ -268,19 +268,19 @@ SUBROUTINE HYDROMET_TEMP(PPA, PTA, PQA,PTI) ! 6. Solve iteratively to get Ti in Harder and Pomeroy (2013). using a Newton-Raphston approach !set the 1st guess to PTA - ZT = PTA + ZT = PTA !loop until convergence DO JITER = 1,10 - ZTINI = ZT ! - + ZTINI = ZT ! + IF(ZT>0) THEN ESAT = 611.0*EXP(17.27*ZT/(ZT+237.3)) ELSE ESAT = 611.0*EXP(21.87*ZT/(ZT+265.5)) ENDIF - + RHO_VSAT = ESAT/(461.5*(ZT+273.15)) ! Saturated water vapour density - + ZF = ZT - PTA - ZD*ZL/ZLAMBDAT * ( PQA*ZRHODA - RHO_VSAT) IF(ZT>0) THEN @@ -289,12 +289,12 @@ SUBROUTINE HYDROMET_TEMP(PPA, PTA, PQA,PTI) ELSE RHO_VSAT_DIFF = 611.0/( 461.5*(ZT+273.15)) * EXP( 21.87*ZT/(ZT+ 265.5)) * & (-1/(ZT+273.15) + 21.87* 265.5/((ZT+ 265.5))**2.) - ENDIF - + ENDIF + ZFDIFF = 1 + ZD*ZL/ZLAMBDAT * RHO_VSAT_DIFF ZT = ZTINI - ZF/ZFDIFF - IF(ABS(ZT- ZTINI) .LT. 0.01) EXIT + IF(ABS(ZT- ZTINI) .LT. 0.01) EXIT ENDDO PTI = ZT END SUBROUTINE HYDROMET_TEMP diff --git a/main/MOD_SnowFraction.F90 b/main/MOD_SnowFraction.F90 index add6c819..e58456f0 100644 --- a/main/MOD_SnowFraction.F90 +++ b/main/MOD_SnowFraction.F90 @@ -9,12 +9,9 @@ MODULE MOD_SnowFraction ! PUBLIC MEMBER FUNCTIONS: PUBLIC :: snowfraction -#ifdef LULC_IGBP_PFT +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) PUBLIC :: snowfraction_pftwrap #endif -#ifdef LULC_IGBP_PC - PUBLIC :: snowfraction_pcwrap -#endif !----------------------------------------------------------------------- @@ -82,18 +79,18 @@ subroutine snowfraction (lai,sai,z0m,zlnd,scv,snowdp,wt,sigf,fsno) end subroutine snowfraction -#ifdef LULC_IGBP_PFT +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) subroutine snowfraction_pftwrap (ipatch,zlnd,scv,snowdp,wt,sigf,fsno) !======================================================================= ! ! !DESCRIPTION: -! A wrap SUBROUTINE to calculate snow cover fraction for PFT run +! A wrap SUBROUTINE to calculate snow cover fraction for PFT|PC run ! ! REVISIONS: -! Hua Yuan, 10/2019: initial code adapted from snowfraction() by Yongjiu Dai +! Hua Yuan, 06/2019: initial code adapted from snowfraction() by Yongjiu Dai ! -! Hua Yuan, 10/2019: removed sigf_p to be compatible with PFT classification +! Hua Yuan, 08/2019: removed sigf_p to be compatible with PFT classification !======================================================================= use MOD_Precision @@ -161,79 +158,4 @@ subroutine snowfraction_pftwrap (ipatch,zlnd,scv,snowdp,wt,sigf,fsno) end subroutine snowfraction_pftwrap #endif -#ifdef LULC_IGBP_PC - subroutine snowfraction_pcwrap (ipatch,zlnd,scv,snowdp,wt,sigf,fsno) - -!======================================================================= -! -! !DESCRIPTION: -! A wrap SUBROUTINE to calculate snow cover fraction for PC run -! -! REVISIONS: -! Hua Yuan, 10/2019: initial code adapted from snowfraction() by Yongjiu Dai -! -! Hua Yuan, 10/2019: removed sigf_c to be compatible with PFT classification -!======================================================================= - - use MOD_Precision - USE MOD_LandPC - USE MOD_Vars_PCTimeInvariants - USE MOD_Vars_PCTimeVariables - implicit none - -! dummy arguments - INTEGER, INTENT(in) :: ipatch ! patch index - - real(r8), INTENT(in) :: scv ! snow water equivalent [mm or kg/m3] - real(r8), INTENT(in) :: snowdp ! snow depth [m] - real(r8), INTENT(in) :: zlnd ! aerodynamic roughness length over soil surface [m] - - real(r8), INTENT(out) :: wt ! fraction of vegetation covered with snow [-] - real(r8), INTENT(out) :: sigf ! fraction of veg cover, excluding snow-covered veg [-] - real(r8), INTENT(out) :: fsno ! fraction of soil covered by snow [-] - - real(r8) :: fmelt ! dimensionless metling factor - real(r8), parameter :: m = 1.0 ! the value of m used in CLM4.5 is 1.0. - ! while the value of m given by Niu et al (2007) is 1.6 - ! while Niu (2012) suggested 3.0 -!----------------------------------------------------------------------- - ! local variables - INTEGER p, pc - REAL(r8) wt_tmp - - wt_tmp = 0. - pc = patch2pc(ipatch) - - DO p = 0, N_PFT-1 - if(tlai_c(p,pc)+tsai_c(p,pc) > 1.e-6) then - ! Fraction of vegetation buried (covered) by snow - wt = 0.1*snowdp/z0m_c(p,pc) - wt = wt/(1.+wt) - - ! Fraction of vegetation cover free of snow - sigf_c(p,pc) = 1. - wt - else - wt = 0. - sigf_c(p,pc) = 0. - endif - - !if(sigf_c(p,pc) < 0.001) sigf_c(p,pc) = 0. - !if(sigf_c(p,pc) > 0.999) sigf_c(p,pc) = 1. - - wt_tmp = wt_tmp + wt*pcfrac(p,pc) - ENDDO - - wt = wt_tmp - sigf = sum(sigf_c(:,pc) * pcfrac(:,pc)) - -! Fraction of soil covered by snow - fsno = 0.0 - if(snowdp > 0.) then - fmelt = (scv/snowdp/100.) ** m - fsno = tanh(snowdp/(2.5 * zlnd * fmelt)) - end if - - end subroutine snowfraction_pcwrap -#endif - END MODULE MOD_SnowFraction diff --git a/main/MOD_SoilSnowHydrology.F90 b/main/MOD_SoilSnowHydrology.F90 index 382e4ec2..a02cdc08 100644 --- a/main/MOD_SoilSnowHydrology.F90 +++ b/main/MOD_SoilSnowHydrology.F90 @@ -5,15 +5,21 @@ MODULE MOD_SoilSnowHydrology !----------------------------------------------------------------------- use MOD_Precision use MOD_Namelist, only: DEF_USE_PLANTHYDRAULICS, DEF_USE_SNICAR, & - DEF_URBAN_RUN + DEF_URBAN_RUN, DEF_USE_IRRIGATION, & + DEF_SPLIT_SOILSNOW #if(defined CaMa_Flood) USE YOS_CMF_INPUT, ONLY: LWINFILT #endif +#ifdef CROP + use MOD_LandPFT, only: patch_pft_s, patch_pft_e + use MOD_Irrigation, only: CalIrrigationApplicationFluxes +#endif + use MOD_LandPatch, only: landpatch IMPLICIT NONE SAVE ! PUBLIC MEMBER FUNCTIONS: - public :: WATER + public :: WATER_2014 PUBLIC :: WATER_VSF public :: snowwater public :: soilwater @@ -33,11 +39,14 @@ MODULE MOD_SoilSnowHydrology - subroutine WATER (ipatch,patchtype ,lb ,nl_soil ,deltim,& + subroutine WATER_2014 (ipatch,patchtype,lb ,nl_soil ,deltim,& z_soisno ,dz_soisno ,zi_soisno ,& - bsw ,porsl ,psi0 ,hksati ,rootr ,& + bsw ,porsl ,psi0 ,hksati ,rootr ,rootflux, & t_soisno ,wliq_soisno ,wice_soisno ,smp ,hk ,pg_rain ,sm ,& etr ,qseva ,qsdew ,qsubl ,qfros ,& + qseva_soil ,qsdew_soil ,qsubl_soil ,qfros_soil ,& + qseva_snow ,qsdew_snow ,qsubl_snow ,qfros_snow ,& + fsno ,& rsur ,rnof ,qinfl ,wtfact ,pondmx,& ssi ,wimp ,smpmin ,zwt ,wa ,& qcharge ,errw_rsub & @@ -56,12 +65,12 @@ subroutine WATER (ipatch,patchtype ,lb ,nl_soil ,deltim,& ! ! Original author : Yongjiu Dai, /09/1999/, /08/2002/, /04/2014/ ! -! FLOW DIAGRAM FOR WATER.F90 +! FLOW DIAGRAM FOR WATER_2014.F90 ! -! WATER ===> snowwater -! surfacerunoff -! soilwater -! subsurfacerunoff +! WATER_2014 ===> snowwater +! surfacerunoff +! soilwater +! subsurfacerunoff ! !======================================================================= @@ -73,7 +82,7 @@ subroutine WATER (ipatch,patchtype ,lb ,nl_soil ,deltim,& !-----------------------Argument---------- ------------------------------ integer, INTENT(in) :: & ipatch ,& ! patch index - patchtype ! land water type (0=soil, 1=urban or built-up, 2=wetland, + patchtype ! land patch type (0=soil, 1=urban or built-up, 2=wetland, ! 3=land ice, 4=land water bodies, 99=ocean integer, INTENT(in) :: & @@ -95,7 +104,8 @@ subroutine WATER (ipatch,patchtype ,lb ,nl_soil ,deltim,& porsl(1:nl_soil) , &! saturated volumetric soil water content(porosity) psi0(1:nl_soil) , &! saturated soil suction (mm) (NEGATIVE) hksati(1:nl_soil), &! hydraulic conductivity at saturation (mm h2o/s) - rootr(1:nl_soil) , &! root resistance of a layer, all layers add to 1.0 + rootr(1:nl_soil) , &! water uptake farction from different layers, all layers add to 1.0 + rootflux(1:nl_soil),&! root uptake from different layer, all layers add to transpiration t_soisno(lb:nl_soil), &! soil/snow skin temperature (K) pg_rain , &! rainfall after removal of interception (mm h2o/s) @@ -104,7 +114,16 @@ subroutine WATER (ipatch,patchtype ,lb ,nl_soil ,deltim,& qseva , &! ground surface evaporation rate (mm h2o/s) qsdew , &! ground surface dew formation (mm h2o /s) [+] qsubl , &! sublimation rate from snow pack (mm h2o /s) [+] - qfros ! surface dew added to snow pack (mm h2o /s) [+] + qfros , &! surface dew added to snow pack (mm h2o /s) [+] + qseva_soil , &! ground soil surface evaporation rate (mm h2o/s) + qsdew_soil , &! ground soil surface dew formation (mm h2o /s) [+] + qsubl_soil , &! sublimation rate from soil ice pack (mm h2o /s) [+] + qfros_soil , &! surface dew added to soil ice pack (mm h2o /s) [+] + qseva_snow , &! ground snow surface evaporation rate (mm h2o/s) + qsdew_snow , &! ground snow surface dew formation (mm h2o /s) [+] + qsubl_snow , &! sublimation rate from snow pack (mm h2o /s) [+] + qfros_snow , &! surface dew added to snow pack (mm h2o /s) [+] + fsno ! snow fractional cover #if(defined CaMa_Flood) real(r8), INTENT(inout) :: flddepth ! inundation water depth [mm] real(r8), INTENT(in) :: fldfrc ! inundation water depth [0-1] @@ -161,14 +180,27 @@ subroutine WATER (ipatch,patchtype ,lb ,nl_soil ,deltim,& #if(defined CaMa_Flood) real(r8) ::gfld ,rsur_fld, qinfl_fld_subgrid ! inundation water input from top (mm/s) #endif + +#ifdef CROP + integer :: ps, pe + integer :: irrig_flag ! 1 if sprinker, 2 if others + real(r8) :: qflx_irrig_drip + real(r8) :: qflx_irrig_sprinkler + real(r8) :: qflx_irrig_flood + real(r8) :: qflx_irrig_paddy +#endif + !======================================================================= ! [1] update the liquid water within snow layer and the water onto soil !======================================================================= + +IF ((.not.DEF_SPLIT_SOILSNOW) .or. (patchtype==1 .and. DEF_URBAN_RUN)) THEN + if (lb>=1)then gwat = pg_rain + sm - qseva else - IF (.not. DEF_USE_SNICAR .or. (patchtype==1 .and. DEF_URBAN_RUN)) THEN + IF ((.not.DEF_USE_SNICAR) .or. (patchtype==1 .and. DEF_URBAN_RUN)) THEN call snowwater (lb,deltim,ssi,wimp,& pg_rain,qseva,qsdew,qsubl,qfros,& dz_soisno(lb:0),wice_soisno(lb:0),wliq_soisno(lb:0),gwat) @@ -182,6 +214,38 @@ subroutine WATER (ipatch,patchtype ,lb ,nl_soil ,deltim,& ENDIF endif +ELSE + + if (lb>=1)then + gwat = pg_rain + sm - qseva_soil + else + IF (.not. DEF_USE_SNICAR) THEN + call snowwater (lb,deltim,ssi,wimp,& + pg_rain*fsno,qseva_snow,qsdew_snow,qsubl_snow,qfros_snow,& + dz_soisno(lb:0),wice_soisno(lb:0),wliq_soisno(lb:0),gwat) + ELSE + call snowwater_snicar (lb,deltim,ssi,wimp,& + pg_rain*fsno,qseva_snow,qsdew_snow,qsubl_snow,qfros_snow,& + dz_soisno(lb:0),wice_soisno(lb:0),wliq_soisno(lb:0),gwat,& + forc_aer,& + mss_bcpho(lb:0), mss_bcphi(lb:0), mss_ocpho(lb:0), mss_ocphi(lb:0),& + mss_dst1(lb:0), mss_dst2(lb:0), mss_dst3(lb:0), mss_dst4(lb:0) ) + ENDIF + gwat = gwat + pg_rain*(1-fsno) - qseva_soil + endif +ENDIF + +#ifdef CROP + if(DEF_USE_IRRIGATION)then + if(patchtype==0)then + ps = patch_pft_s(ipatch) + pe = patch_pft_e(ipatch) + call CalIrrigationApplicationFluxes(ipatch,ps,pe,deltim,qflx_irrig_drip,qflx_irrig_sprinkler,qflx_irrig_flood,qflx_irrig_paddy,irrig_flag=2) + gwat = gwat + qflx_irrig_drip + qflx_irrig_flood + qflx_irrig_paddy + end if + end if +#endif + !======================================================================= ! [2] surface runoff and infiltration !======================================================================= @@ -216,6 +280,7 @@ subroutine WATER (ipatch,patchtype ,lb ,nl_soil ,deltim,& ! infiltration into surface soil layer qinfl = gwat - rsur + #if(defined CaMa_Flood) IF (LWINFILT) then ! re-infiltration [mm/s] calculation. @@ -257,7 +322,7 @@ subroutine WATER (ipatch,patchtype ,lb ,nl_soil ,deltim,& call soilwater(patchtype,nl_soil,deltim,wimp,smpmin,& qinfl,etr,z_soisno(1:),dz_soisno(1:),zi_soisno(0:),& t_soisno(1:),vol_liq,vol_ice,smp,hk,icefrac,eff_porosity,& - porsl,hksati,bsw,psi0,rootr,& + porsl,hksati,bsw,psi0,rootr,rootflux,& zwt,dwat,qcharge) ! update the mass of liquid water @@ -265,6 +330,7 @@ subroutine WATER (ipatch,patchtype ,lb ,nl_soil ,deltim,& wliq_soisno(j) = wliq_soisno(j)+dwat(j)*dzmm(j) enddo + !======================================================================= ! [4] subsurface runoff and the corrections !======================================================================= @@ -278,8 +344,8 @@ subroutine WATER (ipatch,patchtype ,lb ,nl_soil ,deltim,& ! total runoff (mm/s) rnof = rsubst + rsur - ! Renew the ice and liquid mass due to condensation +IF ((.not.DEF_SPLIT_SOILSNOW) .or. (patchtype==1 .and. DEF_URBAN_RUN)) THEN if(lb >= 1)then ! make consistent with how evap_grnd removed in infiltration wliq_soisno(1) = max(0., wliq_soisno(1) + qsdew * deltim) @@ -292,6 +358,17 @@ subroutine WATER (ipatch,patchtype ,lb ,nl_soil ,deltim,& if(lb >= 1)then err_solver = err_solver-(qsdew+qfros-qsubl)*deltim endif + +ELSE + wliq_soisno(1) = max(0., wliq_soisno(1) + qsdew_soil * deltim) + wice_soisno(1) = max(0., wice_soisno(1) + (qfros_soil-qsubl_soil) * deltim) + + err_solver = (sum(wliq_soisno(1:))+sum(wice_soisno(1:))+wa) - w_sum & + - (gwat-etr-rnof-errw_rsub)*deltim + + err_solver = err_solver-(qsdew_soil+qfros_soil-qsubl_soil)*deltim +ENDIF + #if(defined CaMa_Flood) IF (LWINFILT) THEN err_solver = err_solver-(gfld-rsur_fld)*fldfrc*deltim @@ -343,7 +420,7 @@ subroutine WATER (ipatch,patchtype ,lb ,nl_soil ,deltim,& endif - end subroutine WATER + end subroutine WATER_2014 !----------------------------------------------------------------------- subroutine WATER_VSF (ipatch, patchtype,lb ,nl_soil ,deltim ,& @@ -355,14 +432,17 @@ subroutine WATER_VSF (ipatch, patchtype,lb ,nl_soil ,deltim ,& theta_r ,alpha_vgm ,n_vgm ,L_vgm , & sc_vgm ,fc_vgm , & #endif - porsl ,psi0 ,hksati ,rootr , & + porsl ,psi0 ,hksati ,rootr ,rootflux,& t_soisno ,wliq_soisno ,wice_soisno ,smp ,hk ,& pg_rain ,sm , & etr ,qseva ,qsdew ,qsubl ,qfros ,& + qseva_soil ,qsdew_soil ,qsubl_soil ,qfros_soil ,& + qseva_snow ,qsdew_snow ,qsubl_snow ,qfros_snow ,& + fsno ,& rsur ,rnof ,qinfl ,wtfact ,ssi ,& pondmx , & - wimp ,zwt ,wdsrf ,wa ,qcharge,& - errw_rsub & + wimp ,zwt ,wdsrf ,wa ,wetwat ,& + qcharge ,errw_rsub & #if(defined CaMa_Flood) ,flddepth,fldfrc,qinfl_fld& #endif @@ -385,26 +465,22 @@ subroutine WATER_VSF (ipatch, patchtype,lb ,nl_soil ,deltim ,& ! With Explicit Tracking of Wetting Front and Water Table Locations. ! Water Resources Research. doi:10.1029/2019wr025368 ! -! FLOW DIAGRAM FOR WATER_VSF.F90 -! -! WATER ===> snowwater -! surfacerunoff [caculated by lateral flow when defined Lateral_Flow] -! subsurfacerunoff [caculated by lateral flow when defined Lateral_Flow] -! soilwater [Variably Saturated Flow algorithm] -! !=================================================================================== use MOD_Precision USE MOD_Hydro_SoilWater + USE MOD_Vars_TimeInvariants, only : wetwatmax use MOD_Const_Physical, only : denice, denh2o, tfrz - USE MOD_Vars_1DFluxes, only : rsub +#ifdef DataAssimilation + USE MOD_DA_GRACE, only : fslp_k +#endif implicit none !-----------------------Argument---------- ------------------------------ integer, INTENT(in) :: & ipatch ,& ! patch index - patchtype ! land water type (0=soil, 1=urban or built-up, 2=wetland, + patchtype ! land patch type (0=soil, 1=urban or built-up, 2=wetland, ! 3=land ice, 4=land water bodies, 99=ocean integer, INTENT(in) :: & @@ -424,17 +500,18 @@ subroutine WATER_VSF (ipatch, patchtype,lb ,nl_soil ,deltim ,& bsw (1:nl_soil), &! clapp and hornbereger "b" parameter [-] #endif #ifdef vanGenuchten_Mualem_SOIL_MODEL - theta_r (1:nl_soil), & - alpha_vgm(1:nl_soil), & - n_vgm (1:nl_soil), & - L_vgm (1:nl_soil), & - sc_vgm (1:nl_soil), & - fc_vgm (1:nl_soil), & + theta_r (1:nl_soil), & ! residual moisture content [-] + alpha_vgm(1:nl_soil), & ! a parameter corresponding approximately to the inverse of the air-entry value + n_vgm (1:nl_soil), & ! a shape parameter [dimensionless] + L_vgm (1:nl_soil), & ! pore-connectivity parameter [dimensionless] + sc_vgm (1:nl_soil), & ! saturation at the air entry value in the classical vanGenuchten model [-] + fc_vgm (1:nl_soil), & ! a scaling factor by using air entry value in the Mualem model [-] #endif porsl(1:nl_soil) , &! saturated volumetric soil water content(porosity) psi0(1:nl_soil) , &! saturated soil suction (mm) (NEGATIVE) hksati(1:nl_soil), &! hydraulic conductivity at saturation (mm h2o/s) - rootr(1:nl_soil) , &! root resistance of a layer, all layers add to 1.0 + rootr(1:nl_soil) , &! water uptake farction from different layers, all layers add to 1.0 + rootflux(1:nl_soil),&! root uptake from different layer, all layers add to transpiration t_soisno(lb:nl_soil), &! soil/snow skin temperature (K) pg_rain , &! rainfall after removal of interception (mm h2o/s) @@ -443,12 +520,22 @@ subroutine WATER_VSF (ipatch, patchtype,lb ,nl_soil ,deltim ,& qseva , &! ground surface evaporation rate (mm h2o/s) qsdew , &! ground surface dew formation (mm h2o /s) [+] qsubl , &! sublimation rate from snow pack (mm h2o /s) [+] - qfros ! surface dew added to snow pack (mm h2o /s) [+] + qfros , &! surface dew added to snow pack (mm h2o /s) [+] + qseva_soil , &! ground soil surface evaporation rate (mm h2o/s) + qsdew_soil , &! ground soil surface dew formation (mm h2o /s) [+] + qsubl_soil , &! sublimation rate from soil ice pack (mm h2o /s) [+] + qfros_soil , &! surface dew added to soil ice pack (mm h2o /s) [+] + qseva_snow , &! ground snow surface evaporation rate (mm h2o/s) + qsdew_snow , &! ground snow surface dew formation (mm h2o /s) [+] + qsubl_snow , &! sublimation rate from snow pack (mm h2o /s) [+] + qfros_snow , &! surface dew added to snow pack (mm h2o /s) [+] + fsno ! snow fractional cover #if(defined CaMa_Flood) real(r8), INTENT(inout) :: flddepth ! inundation water input from top (mm/s) real(r8), INTENT(in) :: fldfrc ! inundation water input from top (mm/s) real(r8), INTENT(out) :: qinfl_fld ! inundation water input from top (mm/s) #endif + real(r8), INTENT(inout) :: & wice_soisno(lb:nl_soil) , &! ice lens (kg/m2) wliq_soisno(lb:nl_soil) , &! liquid water (kg/m2) @@ -456,7 +543,8 @@ subroutine WATER_VSF (ipatch, patchtype,lb ,nl_soil ,deltim ,& hk (1:nl_soil) , &! hydraulic conductivity [mm h2o/m] zwt , &! the depth from ground (soil) surface to water table [m] wdsrf , &! depth of surface water [mm] - wa ! water storage in aquifer [mm] + wa , &! water storage in aquifer [mm] + wetwat ! water storage in wetland [mm] real(r8), INTENT(out) :: & rsur , &! surface runoff (mm h2o/s) @@ -496,7 +584,7 @@ subroutine WATER_VSF (ipatch, patchtype,lb ,nl_soil ,deltim ,& icefrac(1:nl_soil) ! ice fraction (-) real(r8) :: err_solver, w_sum, wresi(1:nl_soil) - REAL(r8) :: qraing + REAL(r8) :: qgtop REAL(r8) :: zwtmm REAL(r8) :: sp_zc(1:nl_soil), sp_zi(0:nl_soil), sp_dz(1:nl_soil) ! in mm @@ -504,6 +592,15 @@ subroutine WATER_VSF (ipatch, patchtype,lb ,nl_soil ,deltim ,& REAL(r8) :: dzsum, dz REAL(r8) :: icefracsum, fracice_rsub, imped +#ifdef CROP + integer :: ps, pe + integer :: irrig_flag ! 1 if sprinker, 2 if others + real(r8) :: qflx_irrig_drip + real(r8) :: qflx_irrig_sprinkler + real(r8) :: qflx_irrig_flood + real(r8) :: qflx_irrig_paddy +#endif + #ifdef Campbell_SOIL_MODEL real(r8) :: theta_r(1:nl_soil) #endif @@ -527,12 +624,13 @@ subroutine WATER_VSF (ipatch, patchtype,lb ,nl_soil ,deltim ,& ! [1] update the liquid water within snow layer and the water onto soil !======================================================================= +IF ((.not.DEF_SPLIT_SOILSNOW) .or. (patchtype==1 .and. DEF_URBAN_RUN)) THEN + if (lb>=1)then - ! gwat = pg_rain + sm - qseva + qsdew - gwat = pg_rain + sm + qsdew + gwat = pg_rain + sm - qseva else - IF (.not. DEF_USE_SNICAR .or. (patchtype==1 .and. DEF_URBAN_RUN)) THEN + IF ((.not.DEF_USE_SNICAR) .or. (patchtype==1 .and. DEF_URBAN_RUN)) THEN call snowwater (lb,deltim,ssi,wimp,& pg_rain,qseva,qsdew,qsubl,qfros,& dz_soisno(lb:0),wice_soisno(lb:0),wliq_soisno(lb:0),gwat) @@ -546,6 +644,39 @@ subroutine WATER_VSF (ipatch, patchtype,lb ,nl_soil ,deltim ,& ENDIF endif +ELSE + + if (lb>=1)then + gwat = pg_rain + sm - qseva_soil + else + IF (.not. DEF_USE_SNICAR) THEN + call snowwater (lb,deltim,ssi,wimp,& + pg_rain*fsno,qseva_snow,qsdew_snow,qsubl_snow,qfros_snow,& + dz_soisno(lb:0),wice_soisno(lb:0),wliq_soisno(lb:0),gwat) + ELSE + call snowwater_snicar (lb,deltim,ssi,wimp,& + pg_rain*fsno,qseva_snow,qsdew_snow,qsubl_snow,qfros_snow,& + dz_soisno(lb:0),wice_soisno(lb:0),wliq_soisno(lb:0),gwat,& + forc_aer,& + mss_bcpho(lb:0), mss_bcphi(lb:0), mss_ocpho(lb:0), mss_ocphi(lb:0),& + mss_dst1(lb:0), mss_dst2(lb:0), mss_dst3(lb:0), mss_dst4(lb:0) ) + ENDIF + gwat = gwat + pg_rain*(1-fsno) - qseva_soil + endif +ENDIF + + +#ifdef CROP + if(DEF_USE_IRRIGATION)then + if(patchtype==0)then + ps = patch_pft_s(ipatch) + pe = patch_pft_e(ipatch) + call CalIrrigationApplicationFluxes(ipatch,ps,pe,deltim,qflx_irrig_drip,qflx_irrig_sprinkler,qflx_irrig_flood,qflx_irrig_paddy,irrig_flag=2) + gwat = gwat + qflx_irrig_drip + qflx_irrig_flood + qflx_irrig_paddy + end if + end if +#endif + !======================================================================= ! [2] surface runoff and infiltration !======================================================================= @@ -555,15 +686,8 @@ subroutine WATER_VSF (ipatch, patchtype,lb ,nl_soil ,deltim ,& ! For water balance check, the sum of water in soil column before the calcultion w_sum = sum(wliq_soisno(1:nl_soil)) + sum(wice_soisno(1:nl_soil)) + wa + wdsrf - ! Renew the ice and liquid mass due to condensation - if(lb >= 1)then - ! make consistent with how evap_grnd removed in infiltration - wliq_soisno(1) = max(0., wliq_soisno(1) - qseva * deltim) - wice_soisno(1) = max(0., wice_soisno(1) + (qfros-qsubl) * deltim) - end if - - ! Due to the increase in volume after freezing, the total volume of water and - ! ice may exceed the porosity of the soil. This excess water is temporarily + ! Due to the increase in volume after freezing, the total volume of water and + ! ice may exceed the porosity of the soil. This excess water is temporarily ! stored in "wresi". After calculating the movement of soil water, "wresi" ! is added back to "wliq_soisno". wresi(1:nl_soil) = 0. @@ -582,12 +706,14 @@ subroutine WATER_VSF (ipatch, patchtype,lb ,nl_soil ,deltim ,& vol_liq(j) = wliq_soisno(j)/(dz_soisno(j)*denh2o) vol_liq(j) = min(eff_porosity(j), max(0., vol_liq(j))) wresi(j) = wliq_soisno(j) - dz_soisno(j) * denh2o * vol_liq(j) + ELSE + vol_liq(j) = 0. ENDIF enddo ! surface runoff including water table and surface staturated area -#ifndef LATERAL_FLOW +#ifndef CatchLateralFlow if (gwat > 0.) then call surfacerunoff (nl_soil,wtfact,wimp,porsl,psi0,hksati,& z_soisno(1:),dz_soisno(1:),zi_soisno(0:),& @@ -596,12 +722,16 @@ subroutine WATER_VSF (ipatch, patchtype,lb ,nl_soil ,deltim ,& rsur = 0. endif +#ifdef DataAssimilation + rsur = max(min(rsur * fslp_k(ipatch), gwat), 0.) +#endif + ! infiltration into surface soil layer - qraing = gwat - rsur + qgtop = gwat - rsur #else ! for lateral flow, "rsur" is calculated in HYDRO/MOD_Hydro_SurfaceFlow.F90 ! and is removed from surface water there. - qraing = gwat + qgtop = gwat #endif #if(defined CaMa_Flood) @@ -628,10 +758,11 @@ subroutine WATER_VSF (ipatch, patchtype,lb ,nl_soil ,deltim ,& ENDIF qinfl_fld=qinfl_fld_subgrid*fldfrc ! [mm/s] re-infiltration in grid. - qraing=qinfl_fld+qraing ! [mm/s] total infiltration in grid. + qgtop=qinfl_fld+qgtop ! [mm/s] total infiltration in grid. flddepth=flddepth-deltim*qinfl_fld_subgrid ! renew flood depth [mm], the flood depth is reduced by re-infiltration but only in inundation area. ENDIF #endif + !======================================================================= ! [3] determine the change of soil water !======================================================================= @@ -643,12 +774,12 @@ subroutine WATER_VSF (ipatch, patchtype,lb ,nl_soil ,deltim ,& ! check consistancy between water table location and liquid water content DO j = 1, nl_soil - IF ((vol_liq(j) < eff_porosity(j)-1.e-6) .and. (zwtmm <= sp_zi(j-1))) THEN + IF ((vol_liq(j) < eff_porosity(j)-1.e-8) .and. (zwtmm <= sp_zi(j-1))) THEN zwtmm = sp_zi(j) ENDIF ENDDO -#ifndef LATERAL_FLOW +#ifndef CatchLateralFlow !-- Topographic runoff ---------------------------------------------------------- imped = 1.0 IF (zwtmm < sp_zi(nl_soil)) THEN @@ -669,8 +800,11 @@ subroutine WATER_VSF (ipatch, patchtype,lb ,nl_soil ,deltim ,& ENDIF ENDIF - rsub(ipatch) = imped * 5.5e-3 * exp(-2.5*zwt) ! drainage (positive = out of soil column) - rsubst = rsub(ipatch) + rsubst = imped * 5.5e-3 * exp(-2.5*zwt) ! drainage (positive = out of soil column) +#ifdef DataAssimilation + rsubst = rsubst * fslp_k(ipatch) +#endif + #else ! for lateral flow: ! "rsub" is calculated and removed from soil water in HYDRO/MOD_Hydro_SubsurfaceFlow.F90 @@ -715,12 +849,27 @@ subroutine WATER_VSF (ipatch, patchtype,lb ,nl_soil ,deltim ,& wdsrf = max(0., wdsrf) + IF ((.not. is_permeable(1)) .and. (qgtop < 0.)) THEN + IF (wdsrf > 0) THEN + wdsrf = wdsrf + qgtop * deltim + IF (wdsrf < 0) THEN + wliq_soisno(1) = max(0., wliq_soisno(1) + wdsrf) + wdsrf = 0 + ENDIF + ELSE + wliq_soisno(1) = max(0., wliq_soisno(1) + qgtop * deltim) + ENDIF + + qgtop = 0. + + ENDIF + CALL soil_water_vertical_movement ( & nl_soil, deltim, sp_zc(1:nl_soil), sp_zi(0:nl_soil), is_permeable(1:nl_soil), & eff_porosity(1:nl_soil), theta_r(1:nl_soil), psi0(1:nl_soil), hksati(1:nl_soil), & nprms, prms(:,1:nl_soil), porsl(nl_soil), & - qraing, etr, rootr(1:nl_soil), rsubst, qinfl, & - wdsrf, zwtmm, wa, vol_liq(1:nl_soil), smp(1:nl_soil), hk(1:nl_soil)) + qgtop, etr, rootr(1:nl_soil), rootflux(1:nl_soil), rsubst, qinfl, & + wdsrf, zwtmm, wa, vol_liq(1:nl_soil), smp(1:nl_soil), hk(1:nl_soil), 1.e-3) ! update the mass of liquid water DO j = nl_soil, 1, -1 @@ -742,34 +891,53 @@ subroutine WATER_VSF (ipatch, patchtype,lb ,nl_soil ,deltim ,& zwt = zwtmm/1000.0 -#ifndef LATERAL_FLOW + ! Renew the ice and liquid mass due to condensation +IF ((.not.DEF_SPLIT_SOILSNOW) .or. (patchtype==1 .and. DEF_URBAN_RUN)) THEN + if(lb >= 1)then + ! make consistent with how evap_grnd removed in infiltration + wliq_soisno(1) = max(0., wliq_soisno(1) + qsdew * deltim) + wice_soisno(1) = max(0., wice_soisno(1) + (qfros-qsubl) * deltim) + end if +ELSE + wliq_soisno(1) = max(0., wliq_soisno(1) + qsdew_soil * deltim) + wice_soisno(1) = max(0., wice_soisno(1) + (qfros_soil-qsubl_soil) * deltim) +ENDIF + +#ifndef CatchLateralFlow IF (wdsrf > pondmx) THEN rsur = rsur + (wdsrf - pondmx) / deltim wdsrf = pondmx ENDIF -#endif - ! total runoff (mm/s) - rnof = rsub(ipatch) + rsur + ! total runoff (mm/s) + rnof = rsubst + rsur +#endif -#ifndef LATERAL_FLOW +#ifndef CatchLateralFlow err_solver = (sum(wliq_soisno(1:))+sum(wice_soisno(1:))+wa+wdsrf) - w_sum & - (gwat-etr-rsur-rsubst)*deltim #else err_solver = (sum(wliq_soisno(1:))+sum(wice_soisno(1:))+wa+wdsrf) - w_sum & - - (gwat-etr-rsubst)*deltim + - (gwat-etr)*deltim #endif + +IF ((.not.DEF_SPLIT_SOILSNOW) .or. (patchtype==1 .and. DEF_URBAN_RUN)) THEN if(lb >= 1)then - err_solver = err_solver - (qfros-qseva-qsubl)*deltim + err_solver = err_solver - (qsdew+qfros-qsubl)*deltim endif +ELSE + err_solver = err_solver-(qsdew_soil+qfros_soil-qsubl_soil)*deltim +ENDIF + #if(defined CaMa_Flood) IF (LWINFILT) THEN err_solver = err_solver-(gfld-rsur_fld)*fldfrc*deltim ENDIF #endif + #if(defined CoLMDEBUG) if(abs(err_solver) > 1.e-3)then - write(6,'(A,E20.5)') 'Warning (WATER_VSF): water balance violation', err_solver + write(6,'(A,E20.5,I0)') 'Warning (WATER_VSF): water balance violation', err_solver,landpatch%eindex(ipatch) endif IF (any(wliq_soisno < -1.e-3)) THEN write(6,'(A,10E20.5)') 'Warning (WATER_VSF): negative soil water', wliq_soisno(1:nl_soil) @@ -777,39 +945,56 @@ subroutine WATER_VSF (ipatch, patchtype,lb ,nl_soil ,deltim ,& #endif !======================================================================= -! [6] assumed hydrological scheme for the wetland and glacier +! [6] assumed hydrological scheme for the wetland !======================================================================= else if(patchtype==2)then ! WETLAND qinfl = 0. -#ifndef LATERAL_FLOW - rsur = max(0.,gwat) - rsub(ipatch) = 0 -#endif - rnof = rsur + rsub(ipatch) - do j = 1, nl_soil + zwt = 0. + qcharge = 0. + + + IF (lb >= 1) THEN + wetwat = wdsrf + wa + wetwat + (gwat - etr + qsdew + qfros - qsubl) * deltim + ELSE + wetwat = wdsrf + wa + wetwat + (gwat - etr) * deltim + ENDIF + + wresi(:) = 0. + DO j = 1, nl_soil if(t_soisno(j)>tfrz)then - wice_soisno(j) = 0.0 - wliq_soisno(j) = porsl(j)*dz_soisno(j)*1000. + wresi(j) = max(wliq_soisno(j) - porsl(j)*dz_soisno(j)*1000., 0.) + wliq_soisno(j) = wliq_soisno(j) - wresi(j) endif - enddo - endif - if(patchtype==3)then ! LAND ICE - qinfl = 0. -#ifndef LATERAL_FLOW - rsur = max(0.0,gwat) - rsub(ipatch) = 0 + ENDDO + + wetwat = wetwat + sum(wresi) + + IF (wetwat > wetwatmax) THEN + wdsrf = wetwat - wetwatmax + wetwat = wetwatmax + wa = 0. + ELSEIF (wetwat < 0) THEN + wa = wetwat + wdsrf = 0. + wetwat = 0. + ELSE + wdsrf = 0. + wa = 0. + ENDIF + +#ifndef CatchLateralFlow + IF (wdsrf > pondmx) THEN + rsur = (wdsrf - pondmx) / deltim + wdsrf = pondmx + ELSE + rsur = 0. + ENDIF + rnof = rsur #endif - rnof = rsur + rsub(ipatch) - wice_soisno(1:nl_soil) = dz_soisno(1:nl_soil)*1000. - wliq_soisno(1:nl_soil) = 0.0 endif - wa = 0. - zwt = 0. - qcharge = 0. - endif errw_rsub = 0. @@ -1432,7 +1617,7 @@ end subroutine surfacerunoff subroutine soilwater(patchtype,nl_soil,deltim,wimp,smpmin,& qinfl,etr,z_soisno,dz_soisno,zi_soisno,& t_soisno,vol_liq,vol_ice,smp,hk,icefrac,eff_porosity,& - porsl,hksati,bsw,psi0,rootr,& + porsl,hksati,bsw,psi0,rootr,rootflux,& zwt,dwat,qcharge) !----------------------------------------------------------------------- @@ -1506,7 +1691,7 @@ subroutine soilwater(patchtype,nl_soil,deltim,wimp,smpmin,& IMPLICIT NONE - INTEGER , intent(in) :: patchtype ! land water type + INTEGER , intent(in) :: patchtype ! land patch type integer , INTENT(in) :: nl_soil ! number of soil layers real(r8), INTENT(in) :: deltim ! land model time step (sec) real(r8), INTENT(in) :: wimp ! water impremeable if porosity less than wimp @@ -1530,6 +1715,7 @@ subroutine soilwater(patchtype,nl_soil,deltim,wimp,smpmin,& real(r8), INTENT(in) :: bsw (1:nl_soil) ! Clapp and Hornberger "b" real(r8), INTENT(in) :: psi0 (1:nl_soil) ! minimum soil suction (mm) [-] real(r8), INTENT(in) :: rootr (1:nl_soil) ! effective fraction of roots in each soil layer + real(r8), INTENT(in) :: rootflux(1:nl_soil)! root uptake from different layers, all layers add to transpiration real(r8), INTENT(in) :: zwt ! the depth from ground (soil) surface to water table [m] real(r8), intent(out) :: dwat(1:nl_soil) ! change of soil water [m3/m3] @@ -1595,7 +1781,7 @@ subroutine soilwater(patchtype,nl_soil,deltim,wimp,smpmin,& ! Compute matric potential and derivative based on liquid water content only do j = 1, nl_soil - if(DEF_USE_PLANTHYDRAULICS .and. (patchtype/=1 .or. .not.DEF_URBAN_RUN))then + if(DEF_USE_PLANTHYDRAULICS .and. (patchtype/=1 .or. (.not.DEF_URBAN_RUN)))then if(t_soisno(j)>=tfrz) then if(porsl(j)<1.e-6)then ! bed rock s_node = 0.001 @@ -1711,8 +1897,8 @@ subroutine soilwater(patchtype,nl_soil,deltim,wimp,smpmin,& amx(j) = 0. bmx(j) = dzmm(j)/deltim + dqodw1(j) cmx(j) = dqodw2(j) - if(DEF_USE_PLANTHYDRAULICS .and. (patchtype/=1 .or. .not.DEF_URBAN_RUN))then - rmx(j) = qin(j) - qout(j) - rootr(j) + if(DEF_USE_PLANTHYDRAULICS .and. (patchtype/=1 .or. (.not.DEF_URBAN_RUN)))then + rmx(j) = qin(j) - qout(j) - rootflux(j) else rmx(j) = qin(j) - qout(j) - etr*rootr(j) end if @@ -1731,8 +1917,8 @@ subroutine soilwater(patchtype,nl_soil,deltim,wimp,smpmin,& amx(j) = -dqidw0(j) bmx(j) = dzmm(j)/deltim - dqidw1(j) + dqodw1(j) cmx(j) = dqodw2(j) - if(DEF_USE_PLANTHYDRAULICS .and. (patchtype/=1 .or. .not.DEF_URBAN_RUN))then - rmx(j) = qin(j) - qout(j) - rootr(j) + if(DEF_USE_PLANTHYDRAULICS .and. (patchtype/=1 .or. (.not.DEF_URBAN_RUN)))then + rmx(j) = qin(j) - qout(j) - rootflux(j) else rmx(j) = qin(j) - qout(j) - etr*rootr(j) end if @@ -1758,8 +1944,8 @@ subroutine soilwater(patchtype,nl_soil,deltim,wimp,smpmin,& amx(j) = -dqidw0(j) bmx(j) = dzmm(j)/deltim - dqidw1(j) + dqodw1(j) cmx(j) = dqodw2(j) - if(DEF_USE_PLANTHYDRAULICS .and. (patchtype/=1 .or. .not.DEF_URBAN_RUN))then - rmx(j) = qin(j) - qout(j) - rootr(j) + if(DEF_USE_PLANTHYDRAULICS .and. (patchtype/=1 .or. (.not.DEF_URBAN_RUN)))then + rmx(j) = qin(j) - qout(j) - rootflux(j) else rmx(j) = qin(j) - qout(j) - etr*rootr(j) end if @@ -1772,8 +1958,8 @@ subroutine soilwater(patchtype,nl_soil,deltim,wimp,smpmin,& ! The mass balance error (mm) for this time step is errorw = -deltim*(qin(1)-qout(nl_soil)-dqodw1(nl_soil)*dwat(nl_soil)) do j = 1, nl_soil - if(DEF_USE_PLANTHYDRAULICS .and. (patchtype/=1 .or. .not.DEF_URBAN_RUN))then - errorw = errorw+dwat(j)*dzmm(j)+rootr(j)*deltim + if(DEF_USE_PLANTHYDRAULICS .and. (patchtype/=1 .or. (.not.DEF_URBAN_RUN)))then + errorw = errorw+dwat(j)*dzmm(j)+rootflux(j)*deltim else errorw = errorw+dwat(j)*dzmm(j)+etr*rootr(j)*deltim end if diff --git a/main/MOD_SoilSurfaceResistance.F90 b/main/MOD_SoilSurfaceResistance.F90 new file mode 100644 index 00000000..c464b5c8 --- /dev/null +++ b/main/MOD_SoilSurfaceResistance.F90 @@ -0,0 +1,313 @@ +#include + +MODULE MOD_SoilSurfaceResistance + ! ----------------------------------------------------------------------- + ! !DESCRIPTION: + ! Calculate the soil surface resistance with multiple parameterization schemes + ! + ! Created by Zhuo Liu and Hua Yuan, 06/2023 + ! + ! !REVISIONS: + ! + ! ----------------------------------------------------------------------- + ! !USE + + USE MOD_Precision + IMPLICIT NONE + SAVE + + PUBLIC :: SoilSurfaceResistance + + ! soil-gas diffusivity schemes: + ! 1: BBC (Buckingham-Burdine-Campbell Model), Moldrup et al., 1999. + ! 2: P_WLR (Penman Water Linear Reduction Model), Moldrup et al., 2000 + ! 3: MI_WLR (Millington Water Linear Reduction Model), Moldrup et al., 2000 + ! 4: MA_WLR (Marshal Water Linear Reduction Model), Moldrup et al., 2000 + ! 5: M_Q, Millington and Quirk, 1961 + ! 6: 3POE (Three-Porosity-Encased), Moldrup et al., 2005 +#ifdef Campbell_SOIL_MODEL + integer, parameter :: soil_gas_diffusivity_scheme = 1 +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + integer, parameter :: soil_gas_diffusivity_scheme = 6 +#endif + + +CONTAINS +!----------------------------------------------------------------------- + + SUBROUTINE SoilSurfaceResistance (nl_soil,forc_rhoair,hksati,porsl,psi0, & +#ifdef Campbell_SOIL_MODEL + bsw, & +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + theta_r, alpha_vgm, n_vgm, L_vgm, sc_vgm, fc_vgm, & +#endif + dz_soisno,t_soisno,wliq_soisno,wice_soisno,fsno,qg,rss) + + !======================================================================= + ! !DESCRIPTION: + ! Main SUBROUTINE to CALL soil resistance model + ! - Options for soil surface resistance schemes + ! 1: SL14, Swenson and Lawrence (2014) + ! 2: SZ09, Sakaguchi and Zeng (2009) + ! 3: TR13, Tang and Riley (2013) + ! 4: LP92, Lee and Pielke (1992) + ! 5: S92, Sellers et al (1992) + ! + ! NOTE: Support for both Campbell and VG soil parameters. + !======================================================================= + + USE MOD_Precision + USE MOD_Const_Physical, only: denice, denh2o + USE MOD_Namelist, only: DEF_RSS_SCHEME + USE MOD_Hydro_SoilFunction + IMPLICIT NONE + + +!-----------------------Argument----------------------------------------- + + integer, intent(in) :: & + nl_soil ! upper bound of array + + real(r8), intent(in) :: & + forc_rhoair, &! density air [kg/m**3] + hksati (1:nl_soil), &! hydraulic conductivity at saturation [mm h2o/s] + porsl (1:nl_soil), &! soil porosity [-] + psi0 (1:nl_soil), &! saturated soil suction [mm] (NEGATIVE) +#ifdef Campbell_SOIL_MODEL + bsw (1:nl_soil), &! clapp and hornbereger "b" parameter [-] +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + theta_r (1:nl_soil), &! residual moisture content [-] + alpha_vgm (1:nl_soil), &! a parameter corresponding approximately to the inverse of the air-entry value + n_vgm (1:nl_soil), &! pore-connectivity parameter [dimensionless] + L_vgm (1:nl_soil), &! a shape parameter [dimensionless] + sc_vgm (1:nl_soil), &! saturation at the air entry value in the classical vanGenuchten model [-] + fc_vgm (1:nl_soil), &! a scaling factor by using air entry value in the Mualem model [-] +#endif + dz_soisno (1:nl_soil), &! layer thickness [m] + t_soisno (1:nl_soil), &! soil/snow skin temperature [K] + wliq_soisno (1:nl_soil), &! liquid water [kg/m2] + wice_soisno (1:nl_soil), &! ice lens [kg/m2] + fsno, &! fractional snow cover [-] + qg ! ground specific humidity [kg/kg] + + real(r8), intent(out) :: & + rss ! soil surface resistance [s/m] + +!-----------------------Local Variables------------------------------ + + REAL(r8) :: & + wx, &! patitial volume of ice and water of surface layer + vol_liq, &! water content by volume [m3/m3] + s_node, &! vol_liq/porosity + smp_node, &! matrix potential [m] + eff_porosity, &! effective porosity = porosity - vol_ice + aird, &! “air-dry” soil moisture value + d0, &! water vapor diffusivity in open air [m2/s] + eps, &! air filled pore space + dg, &! gaseous diffusivity [m2/s] + dsl, &! soil dry surface layer thickness [m] + dw, &! aqueous diffusivity [m2/s] + hk, &! hydraulic conductivity [m h2o/s] + m_vgm, &! pore-connectivity related parameter [dimensionless] + S, &! Van Genuchten relative saturation [-] + wfc, &! field capacity of the first layer soil + rg_1, &! inverse of vapor diffusion resistance [m/s] + rw_1, &! inverse of volatilization resistance [m/s] + rss_1, &! inverse of soil surface resistance [m/s] + tao, &! tortuosity of the vapor flow paths through the soil matrix + eps100, &! air-filled porosity at −1000 mm of water matric potential + fac, &! temporal variable for calculating wx/porsl + fac_fc, &! temporal variable for calculating wx/wfc + B ! bunsen solubility coefficient + +!-----------------------End Variables list--------------------------- + + + ! calculate the top soil volumetric water content (m3/m3), soil matrix potential + ! and soil hydraulic conductivity + vol_liq = max(wliq_soisno(1),1.0e-6_r8)/(denh2o*dz_soisno(1)) + s_node = min(1., vol_liq/porsl(1)) + + ! calculate effective soil porosity + eff_porosity = max(0.01_r8,porsl(1)-min(porsl(1), wice_soisno(1)/(dz_soisno(1)*denice))) + + +#ifdef Campbell_SOIL_MODEL + smp_node = (psi0(1)/1000.)*s_node**(-bsw(1)) + hk = (hksati(1)/1000.)*(vol_liq/porsl(1))**(2.*bsw(1)+3.) + + ! calculate air free pore space + aird = porsl(1)*(psi0(1)/-1.e7_r8)**(1./bsw(1)) +#endif + +#ifdef vanGenuchten_Mualem_SOIL_MODEL + smp_node = soil_psi_from_vliq (s_node*(porsl(1)-theta_r(1)) + theta_r(1), & + porsl(1), theta_r(1), psi0(1), & + 5, (/alpha_vgm(1), n_vgm(1), L_vgm(1), sc_vgm(1), fc_vgm(1)/)) + hk = soil_hk_from_psi (smp_node, psi0(1), hksati(1), & + 5, (/alpha_vgm(1), n_vgm(1), L_vgm(1), sc_vgm(1), fc_vgm(1)/)) + + smp_node = smp_node/1000. + hk = hk/1000. + + ! calculate air free pore space + aird = soil_vliq_from_psi (-1.e7_r8, porsl(1), theta_r(1), psi0(1), & + 5, (/alpha_vgm(1), n_vgm(1), L_vgm(1), sc_vgm(1), fc_vgm(1)/)) +#endif + + ! D0 : 2.12e-5 unit: m2 s-1 + ! ref1: CLM5 Documentation formula (5.81) + ! ref2: Sakaguchi and Zeng, 2009 + ! ref3: Tang and Riley, 2013. Figure 2, 3, 4, and 5. + d0 = 2.12e-5*(t_soisno(1)/273.15)**1.75 + eps = porsl(1) - aird + + + SELECTCASE (soil_gas_diffusivity_scheme) + + ! 1: BBC + CASE (1) +#ifdef Campbell_SOIL_MODEL + tao = eps*eps*(eps/porsl(1))**(3._r8/max(3._r8,bsw(1))) +#endif + + ! 2: P_WLR + CASE (2) + tao = 0.66*eps*(eps/porsl(1)) + + ! 3: MI_WLR + CASE (3) + tao = eps**(4._r8/3._r8)*(eps/porsl(1)) + + ! 4: MA_WLR + CASE (4) + tao = eps**(3./2.)*(eps/porsl(1)) + + ! 5: M_Q + CASE (5) + tao = eps**(4._r8/3._r8)*(eps/porsl(1))**(2.0_r8) + + ! 6: 3POE + CASE (6) +#ifdef Campbell_SOIL_MODEL + eps100 = porsl(1) - porsl(1)*(psi0(1)/-1000.)**(1./bsw(1)) +#endif + +#ifdef vanGenuchten_Mualem_SOIL_MODEL + eps100 = porsl(1) - soil_vliq_from_psi (-1000., porsl(1), theta_r(1), psi0(1), & + 5, (/alpha_vgm(1), n_vgm(1), L_vgm(1), sc_vgm(1), fc_vgm(1)/)) +#endif + tao = porsl(1)*porsl(1)*(eps/porsl(1))**(2.+log(eps100**0.25_r8)/log(eps100/porsl(1))) + + ENDSELECT + + + ! calculate gas and water diffusivity (dg and dw) + dg = d0*tao + + !NOTE: dw is only for TR13 scheme +#ifdef Campbell_SOIL_MODEL + ! TR13, Eq.(A5): + dw = -hk*bsw(1)*smp_node/vol_liq +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + ! TR13, Eqs. (A2), (A7), (A8) and (A10): + ! dw = -hk*(m-1)/(k*m*(theta_s-theta_r))*S**(-1/m)*(1-S**(1/m))**(-m) + ! where k=alpha_vgm, S=(1+(-k*smp_node)**(n))**(-m), m=m_vgm=1-1/n_vgm + m_vgm = 1. - 1./n_vgm(1) + S = (1. + (- alpha_vgm(1)*smp_node)**(n_vgm(1)))**(-m_vgm) + dw = -hk*(m_vgm-1.)/(alpha_vgm(1)*m_vgm*(porsl(1)-theta_r(1))) & + * S**(-1./m_vgm)*(1.-S**(1./m_vgm))**(-m_vgm) +#endif + + SELECTCASE (DEF_RSS_SCHEME) + + ! calculate rss by SL14 + CASE (1) + dsl = dz_soisno(1)*max(1.e-6_r8,(0.8*eff_porosity - vol_liq)) & + /max(1.e-6_r8,(0.8*porsl(1)- aird)) + + dsl = max(dsl,0._r8) + dsl = min(dsl,0.2_r8) + + rss = dsl/dg + !fordebug only + !write(*,*) dsl, dg, aird, vol_liq/porsl(1), eff_porosity, wice_soisno(1),vol_liq, rss + + ! calculate rss by SZ09 + CASE (2) + dsl = dz_soisno(1)*(exp((1._r8 - vol_liq/porsl(1))**5) - 1._r8)/ (exp(1._r8) - 1._r8) + dsl = min(dsl,0.2_r8) + dsl = max(dsl,0._r8) + + rss = dsl/dg + + ! calculate rss by TR13 + CASE (3) + ! TR13, Eq. (11) and Eq. (12): + B = denh2o/(qg*forc_rhoair) + ! TR13, Eq. (13): + rg_1 = 2.0_r8*dg*eps/dz_soisno(1) + rw_1 = 2.0_r8*dw*B*vol_liq/dz_soisno(1) + rss_1 = rg_1 + rw_1 + rss = 1.0/rss_1 + + ! LP92 beta scheme + CASE (4) + wx = (max(wliq_soisno(1),1.e-6)/denh2o+wice_soisno(1)/denice)/dz_soisno(1) + fac = min(1._r8, wx/porsl(1)) + fac = max(fac , 0.001_r8) +#ifdef Campbell_SOIL_MODEL + wfc = porsl(1)*(0.1/(86400.*hksati(1)))**(1./(2.*bsw(1)+3.)) + !NOTE: CoLM wfc = (-339.9/soil_psi_s_l(ipatch))**(-1.0*soil_lambda_l(ipatch)) * soil_theta_s_l(ipatch) + !wfc = porsl(1)*(-3399._r8/psi0(1))**(-1./bsw(1)) +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + wfc = theta_r(1)+(porsl(1)-theta_r(1))*(1+(alpha_vgm(1)*339.9)**n_vgm(1))**(1.0/n_vgm(1)-1) +#endif + !write(*,*) wfc !fordebug only + + ! Lee and Pielke 1992 beta + IF (wx < wfc ) THEN !when water content of ths top layer is less than that at F.C. + fac_fc = min(1._r8, wx/wfc) + fac_fc = max(fac_fc,0.001_r8) + rss = 0.25_r8*(1._r8 - cos(fac_fc*3.1415926))**2._r8 + ELSE !when water content of ths top layer is more than that at F.C. + rss = 1._r8 + ENDIF + + ! Sellers, 1992 + CASE (5) + wx = (max(wliq_soisno(1),1.e-6)/denh2o+wice_soisno(1)/denice)/dz_soisno(1) + fac = min(1._r8, wx/porsl(1)) + fac = max(fac , 0.001_r8) + !rss = exp(8.206-4.255*fac) !original Sellers (1992) + rss = exp(8.206-6.0*fac) !adjusted Sellers (1992) to decrease rss + !for wet soil according to Noah-MP v5 + ENDSELECT + + ! account for snow fractional cover for rss + IF (DEF_RSS_SCHEME .ne. 4) THEN + ! with 1/rss = fsno/rss_snow + (1-fsno)/rss_soil, + ! assuming rss_snow = 1, so rss is calibrated as: + IF (1.-fsno+fsno*rss > 0.) THEN + rss = rss / (1.-fsno+fsno*rss) + ELSE + rss = 0. + ENDIF + rss = min(1.e6_r8,rss) + ENDIF + + ! account for snow fractional cover for LP92 beta scheme + !NOTE: rss here is for soil beta value + IF (DEF_RSS_SCHEME .eq. 4) THEN + ! modify soil beta by snow cover, assuming soil beta for snow surface is 1. + rss = (1.-fsno)*rss + fsno + ENDIF + + END Subroutine SoilSurfaceResistance + +END MODULE MOD_SoilSurfaceResistance diff --git a/main/MOD_SoilThermalParameters.F90 b/main/MOD_SoilThermalParameters.F90 index afb95d86..d6647342 100644 --- a/main/MOD_SoilThermalParameters.F90 +++ b/main/MOD_SoilThermalParameters.F90 @@ -49,7 +49,7 @@ subroutine hCapacity (patchtype,lb,nl_soil,csol,porsl,wice_soisno,wliq_soisno,sc integer, INTENT(in) :: lb ! lower bound of array integer, INTENT(in) :: nl_soil ! upper bound of array - integer, INTENT(in) :: patchtype! land water type (0=soil, 1=urban, 2=wetland, + integer, INTENT(in) :: patchtype! land patch type (0=soil, 1=urban, 2=wetland, real(r8), INTENT(in) :: csol(1:nl_soil) ! heat capacity of soil soilds [J/(m3 K)] real(r8), INTENT(in) :: porsl(1:nl_soil) ! soil porosity real(r8), INTENT(in) :: wice_soisno(lb:nl_soil) ! ice lens [kg/m2] @@ -108,7 +108,7 @@ subroutine hConductivity (patchtype,lb,nl_soil,& integer, INTENT(in) :: lb ! lower bound of array integer, INTENT(in) :: nl_soil ! upper bound of array - integer, INTENT(in) :: patchtype! land water type (0=soil, 1=urban, 2=wetland, + integer, INTENT(in) :: patchtype! land patch type (0=soil, 1=urban, 2=wetland, ! 3=land ice, 4=deep lake, 5=shallow lake) real(r8), INTENT(in) :: dkdry(1:nl_soil) ! thermal conductivity for dry soil [W/m-K] real(r8), INTENT(in) :: dksatu(1:nl_soil) ! Thermal conductivity of saturated soil [W/m-K] diff --git a/main/MOD_Thermal.F90 b/main/MOD_Thermal.F90 index 107801b3..505d5a96 100644 --- a/main/MOD_Thermal.F90 +++ b/main/MOD_Thermal.F90 @@ -34,10 +34,10 @@ SUBROUTINE THERMAL (ipatch ,patchtype ,lb ,deltim ,& BA_alpha ,BA_beta ,& lai ,laisun ,laisha ,& sai ,htop ,hbot ,sqrtdi ,& - rootfr ,rstfacsun_out ,rstfacsha_out ,& + rootfr ,rstfacsun_out,rstfacsha_out,rss ,& gssun_out ,gssha_out ,& assimsun_out,etrsun_out ,assimsha_out,etrsha_out ,& -! photosynthesis and plant hydraulic variables +!photosynthesis and plant hydraulic variables effcon ,vmax25 ,hksati ,smp ,hk,& kmax_sun ,kmax_sha ,kmax_xyl ,kmax_root ,& psi50_sun ,psi50_sha ,psi50_xyl ,psi50_root ,& @@ -46,13 +46,13 @@ SUBROUTINE THERMAL (ipatch ,patchtype ,lb ,deltim ,& lai_old ,o3uptakesun ,o3uptakesha ,forc_ozone, & !end ozone stress variables slti ,hlti ,shti ,hhti ,& - trda ,trdm ,trop ,gradm ,& - binter ,extkn ,forc_hgt_u ,forc_hgt_t ,& - forc_hgt_q ,forc_us ,forc_vs ,forc_t ,& - forc_q, forc_rhoair, forc_psrf, forc_pco2m, & - forc_hpbl ,& + trda ,trdm ,trop ,g1 ,& + g0 ,gradm ,binter ,extkn ,& + forc_hgt_u ,forc_hgt_t ,forc_hgt_q ,forc_us ,& + forc_vs ,forc_t ,forc_q ,forc_rhoair,& + forc_psrf ,forc_pco2m ,forc_hpbl ,& forc_po2m ,coszen ,parsun ,parsha ,& - sabvsun ,sabvsha ,sabg ,frl ,& + sabvsun ,sabvsha ,sabg,sabg_soil,sabg_snow,frl,& extkb ,extkd ,thermk ,fsno ,& sigf ,dz_soisno ,z_soisno ,zi_soisno ,& tleaf ,t_soisno ,wice_soisno ,wliq_soisno,& @@ -60,14 +60,17 @@ SUBROUTINE THERMAL (ipatch ,patchtype ,lb ,deltim ,& taux ,tauy ,fsena ,fevpa ,& lfevpa ,fsenl ,fevpl ,etr ,& fseng ,fevpg ,olrg ,fgrnd ,& - rootr ,qseva ,qsdew ,qsubl ,& - qfros ,sm ,tref ,qref ,& + rootr ,rootflux ,& + qseva ,qsdew ,qsubl ,qfros ,& + qseva_soil ,qsdew_soil ,qsubl_soil ,qfros_soil ,& + qseva_snow ,qsdew_snow ,qsubl_snow ,qfros_snow ,& + sm ,tref ,qref ,& trad ,rst ,assim ,respc ,& errore ,emis ,z0m ,zol ,& rib ,ustar ,qstar ,tstar ,& fm ,fh ,fq ,pg_rain ,& pg_snow ,t_precip ,qintr_rain ,qintr_snow ,& - snofrz ,sabg_lyr ) + snofrz ,sabg_snow_lyr ) !======================================================================= ! this is the main subroutine to execute the calculation @@ -78,19 +81,20 @@ SUBROUTINE THERMAL (ipatch ,patchtype ,lb ,deltim ,& ! FLOW DIAGRAM FOR THERMAL.F90 ! ! THERMAL ===> qsadv -! groundfluxes -! eroot |dewfraction -! LeafTemp | |qsadv -! LeafTempPC | ----------> |moninobukini -! |moninobuk -! |MOD_AssimStomataConductance +! GroundFluxes +! eroot |dewfraction +! LeafTemperature | |qsadv +! LeafTemperaturePC | ----------> |moninobukini +! |moninobuk +! |MOD_AssimStomataConductance ! -! groundTem ----------> meltf +! GroundTemperature ----------> meltf ! ! ! REVISIONS: -! Hua Yuan, 12/2019: added initial codes for PFT and Plant Community (PC) +! Hua Yuan, 08/2019: added initial codes for PFT and Plant Community (PC) ! vegetation classification processes +! ! Nan Wei, 01/2021: added variables passing of plant hydraulics and precipitation sensible heat ! with canopy and ground for PFT and Plant Community (PC) !======================================================================= @@ -104,175 +108,177 @@ SUBROUTINE THERMAL (ipatch ,patchtype ,lb ,deltim ,& USE MOD_Eroot USE MOD_GroundFluxes USE MOD_LeafTemperature + USE MOD_LeafTemperaturePC USE MOD_GroundTemperature USE MOD_Qsadv -#ifdef LULC_IGBP_PFT - USE MOD_LandPFT, only : patch_pft_s, patch_pft_e + USE MOD_SoilSurfaceResistance +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + USE MOD_LandPFT, only: patch_pft_s, patch_pft_e + USE MOD_Vars_TimeInvariants, only: patchclass USE MOD_Vars_PFTimeInvariants USE MOD_Vars_PFTimeVariables USE MOD_Vars_1DPFTFluxes #endif -#ifdef LULC_IGBP_PC - USE MOD_LandPC - USE MOD_Vars_PCTimeInvariants - USE MOD_Vars_PCTimeVariables - USE MOD_Vars_1DPCFluxes - USE MOD_LeafTemperaturePC -#endif #ifdef vanGenuchten_Mualem_SOIL_MODEL - USE MOD_Hydro_SoilFunction, only : soil_psi_from_vliq + USE MOD_Hydro_SoilFunction, only: soil_psi_from_vliq #endif -USE MOD_SPMD_Task - USE MOD_Namelist, only: DEF_USE_PLANTHYDRAULICS + USE MOD_SPMD_Task + USE MOD_Namelist, only: DEF_USE_PLANTHYDRAULICS, DEF_RSS_SCHEME, DEF_SPLIT_SOILSNOW, & + DEF_USE_LCT,DEF_USE_PFT,DEF_USE_PC IMPLICIT NONE !---------------------Argument------------------------------------------ integer, intent(in) :: & - ipatch, &! patch index - lb, &! lower bound of array - patchtype ! land water type (0=soil, 1=urban or built-up, 2=wetland, + ipatch, &! patch index + lb, &! lower bound of array + patchtype ! land patch type (0=soil, 1=urban or built-up, 2=wetland, ! 3=glacier/ice sheet, 4=land water bodies) + real(r8), intent(inout) :: & + sai ! stem area index [-] real(r8), intent(in) :: & - deltim, &! model time step [second] - trsmx0, &! max transpiration for moist soil+100% veg. [mm/s] - zlnd, &! roughness length for soil [m] - zsno, &! roughness length for snow [m] - csoilc, &! drag coefficient for soil under canopy [-] - dewmx, &! maximum dew - capr, &! tuning factor to turn first layer T into surface T - cnfac, &! Crank Nicholson factor between 0 and 1 - - ! soil physical parameters - vf_quartz (1:nl_soil), &! volumetric fraction of quartz within mineral soil - vf_gravels(1:nl_soil), &! volumetric fraction of gravels - vf_om (1:nl_soil), &! volumetric fraction of organic matter - vf_sand (1:nl_soil), &! volumetric fraction of sand - wf_gravels(1:nl_soil), &! gravimetric fraction of gravels - wf_sand (1:nl_soil), &! gravimetric fraction of sand - csol (1:nl_soil), &! heat capacity of soil solids [J/(m3 K)] - porsl (1:nl_soil), &! soil porosity [-] - psi0 (1:nl_soil), &! soil water suction, negative potential [mm] + deltim, &! model time step [second] + trsmx0, &! max transpiration for moist soil+100% veg. [mm/s] + zlnd, &! roughness length for soil [m] + zsno, &! roughness length for snow [m] + csoilc, &! drag coefficient for soil under canopy [-] + dewmx, &! maximum dew + capr, &! tuning factor to turn first layer T into surface T + cnfac, &! Crank Nicholson factor between 0 and 1 + + ! soil physical parameters + vf_quartz (1:nl_soil), &! volumetric fraction of quartz within mineral soil + vf_gravels(1:nl_soil), &! volumetric fraction of gravels + vf_om (1:nl_soil), &! volumetric fraction of organic matter + vf_sand (1:nl_soil), &! volumetric fraction of sand + wf_gravels(1:nl_soil), &! gravimetric fraction of gravels + wf_sand (1:nl_soil), &! gravimetric fraction of sand + csol (1:nl_soil), &! heat capacity of soil solids [J/(m3 K)] + porsl (1:nl_soil), &! soil porosity [-] + psi0 (1:nl_soil), &! soil water suction, negative potential [mm] #ifdef Campbell_SOIL_MODEL - bsw(1:nl_soil), &! clapp and hornbereger "b" parameter [-] + bsw(1:nl_soil), &! clapp and hornbereger "b" parameter [-] #endif #ifdef vanGenuchten_Mualem_SOIL_MODEL - theta_r (1:nl_soil), & - alpha_vgm(1:nl_soil), & - n_vgm (1:nl_soil), & - L_vgm (1:nl_soil), & - sc_vgm (1:nl_soil), & - fc_vgm (1:nl_soil), & + theta_r (1:nl_soil), &! residual moisture content [-] + alpha_vgm (1:nl_soil), &! a parameter corresponding approximately to the inverse of the air-entry value + n_vgm (1:nl_soil), &! pore-connectivity parameter [dimensionless] + L_vgm (1:nl_soil), &! a shape parameter [dimensionless] + sc_vgm (1:nl_soil), &! saturation at the air entry value in the classical vanGenuchten model [-] + fc_vgm (1:nl_soil), &! a scaling factor by using air entry value in the Mualem model [-] #endif - k_solids (1:nl_soil), &! thermal conductivity of minerals soil [W/m-K] - dkdry (1:nl_soil), &! thermal conductivity of dry soil [W/m-K] - dksatu (1:nl_soil), &! thermal conductivity of saturated unfrozen soil [W/m-K] - dksatf (1:nl_soil), &! thermal conductivity of saturated frozen soil [W/m-K] - hksati (1:nl_soil), &! hydraulic conductivity at saturation [mm h2o/s] - BA_alpha (1:nl_soil), &! alpha in Balland and Arp(2005) thermal conductivity scheme - BA_beta (1:nl_soil), &! beta in Balland and Arp(2005) thermal conductivity scheme - - ! vegetation parameters - lai, &! adjusted leaf area index for seasonal variation [-] - sai, &! stem area index [-] - htop, &! canopy crown top height [m] - hbot, &! canopy crown bottom height [m] - sqrtdi, &! inverse sqrt of leaf dimension [m**-0.5] - rootfr(1:nl_soil),&! root fraction - - effcon, &! quantum efficiency of RuBP regeneration (mol CO2/mol quanta) - vmax25, &! maximum carboxylation rate at 25 C at canopy top - kmax_sun, & - kmax_sha, & - kmax_xyl, & - kmax_root, & - psi50_sun, &! water potential at 50% loss of sunlit leaf tissue conductance (mmH2O) - psi50_sha, &! water potential at 50% loss of shaded leaf tissue conductance (mmH2O) - psi50_xyl, &! water potential at 50% loss of xylem tissue conductance (mmH2O) - psi50_root, &! water potential at 50% loss of root tissue conductance (mmH2O) - ck, &! shape-fitting parameter for vulnerability curve (-) - slti, &! slope of low temperature inhibition function [s3] - hlti, &! 1/2 point of low temperature inhibition function [s4] - shti, &! slope of high temperature inhibition function [s1] - hhti, &! 1/2 point of high temperature inhibition function [s2] - trda, &! temperature coefficient in gs-a model [s5] - trdm, &! temperature coefficient in gs-a model [s6] - trop, &! temperature coefficient in gs-a model - gradm, &! conductance-photosynthesis slope parameter - binter, &! conductance-photosynthesis intercept - extkn, &! coefficient of leaf nitrogen allocation - - ! atmospherical variables and observational height - forc_hgt_u, &! observational height of wind [m] - forc_hgt_t, &! observational height of temperature [m] - forc_hgt_q, &! observational height of humidity [m] - forc_us, &! wind component in eastward direction [m/s] - forc_vs, &! wind component in northward direction [m/s] - forc_t, &! temperature at agcm reference height [kelvin] - forc_q, &! specific humidity at agcm reference height [kg/kg] - forc_rhoair, &! density air [kg/m3] - forc_psrf, &! atmosphere pressure at the surface [pa] - forc_pco2m, &! CO2 concentration in atmos. (pascals) - forc_po2m, &! O2 concentration in atmos. (pascals) - forc_hpbl, &! atmospheric boundary layer height [m] - pg_rain, &! rainfall onto ground including canopy runoff [kg/(m2 s)] - pg_snow, &! snowfall onto ground including canopy runoff [kg/(m2 s)] - t_precip, &! snowfall/rainfall temperature [kelvin] - qintr_rain, &! rainfall interception (mm h2o/s) - qintr_snow, &! snowfall interception (mm h2o/s) - - ! radiative fluxes - coszen, &! cosine of the solar zenith angle - parsun, &! photosynthetic active radiation by sunlit leaves (W m-2) - parsha, &! photosynthetic active radiation by shaded leaves (W m-2) - sabvsun, &! solar radiation absorbed by vegetation [W/m2] - sabvsha, &! solar radiation absorbed by vegetation [W/m2] - sabg, &! solar radiation absorbed by ground [W/m2] - frl, &! atmospheric infrared (longwave) radiation [W/m2] - extkb, &! (k, g(mu)/mu) direct solar extinction coefficient - extkd, &! diffuse and scattered diffuse PAR extinction coefficient - thermk, &! canopy gap fraction for tir radiation - - ! state variable (1) - fsno, &! fraction of ground covered by snow - sigf, &! fraction of veg cover, excluding snow-covered veg [-] - dz_soisno(lb:nl_soil), &! layer thickiness [m] - z_soisno (lb:nl_soil), &! node depth [m] - zi_soisno(lb-1:nl_soil) ! interface depth [m] + k_solids (1:nl_soil), &! thermal conductivity of minerals soil [W/m-K] + dkdry (1:nl_soil), &! thermal conductivity of dry soil [W/m-K] + dksatu (1:nl_soil), &! thermal conductivity of saturated unfrozen soil [W/m-K] + dksatf (1:nl_soil), &! thermal conductivity of saturated frozen soil [W/m-K] + hksati (1:nl_soil), &! hydraulic conductivity at saturation [mm h2o/s] + BA_alpha (1:nl_soil), &! alpha in Balland and Arp(2005) thermal conductivity scheme + BA_beta (1:nl_soil), &! beta in Balland and Arp(2005) thermal conductivity scheme + + ! vegetation parameters + lai, &! adjusted leaf area index for seasonal variation [-] + htop, &! canopy crown top height [m] + hbot, &! canopy crown bottom height [m] + sqrtdi, &! inverse sqrt of leaf dimension [m**-0.5] + rootfr(1:nl_soil),&! root fraction + + effcon, &! quantum efficiency of RuBP regeneration (mol CO2/mol quanta) + vmax25, &! maximum carboxylation rate at 25 C at canopy top + kmax_sun, &! Plant Hydraulics Paramters + kmax_sha, &! Plant Hydraulics Paramters + kmax_xyl, &! Plant Hydraulics Paramters + kmax_root, &! Plant Hydraulics Paramters + psi50_sun, &! water potential at 50% loss of sunlit leaf tissue conductance (mmH2O) + psi50_sha, &! water potential at 50% loss of shaded leaf tissue conductance (mmH2O) + psi50_xyl, &! water potential at 50% loss of xylem tissue conductance (mmH2O) + psi50_root, &! water potential at 50% loss of root tissue conductance (mmH2O) + ck, &! shape-fitting parameter for vulnerability curve (-) + slti, &! slope of low temperature inhibition function [s3] + hlti, &! 1/2 point of low temperature inhibition function [s4] + shti, &! slope of high temperature inhibition function [s1] + hhti, &! 1/2 point of high temperature inhibition function [s2] + trda, &! temperature coefficient in gs-a model [s5] + trdm, &! temperature coefficient in gs-a model [s6] + trop, &! temperature coefficient in gs-a model + g1, &! conductance-photosynthesis slope parameter for medlyn model + g0, &! conductance-photosynthesis intercept for medlyn model + gradm, &! conductance-photosynthesis slope parameter + binter, &! conductance-photosynthesis intercept + extkn, &! coefficient of leaf nitrogen allocation + + ! atmospherical variables and observational height + forc_hgt_u, &! observational height of wind [m] + forc_hgt_t, &! observational height of temperature [m] + forc_hgt_q, &! observational height of humidity [m] + forc_us, &! wind component in eastward direction [m/s] + forc_vs, &! wind component in northward direction [m/s] + forc_t, &! temperature at agcm reference height [kelvin] + forc_q, &! specific humidity at agcm reference height [kg/kg] + forc_rhoair, &! density air [kg/m3] + forc_psrf, &! atmosphere pressure at the surface [pa] + forc_pco2m, &! CO2 concentration in atmos. (pascals) + forc_po2m, &! O2 concentration in atmos. (pascals) + forc_hpbl, &! atmospheric boundary layer height [m] + pg_rain, &! rainfall onto ground including canopy runoff [kg/(m2 s)] + pg_snow, &! snowfall onto ground including canopy runoff [kg/(m2 s)] + t_precip, &! snowfall/rainfall temperature [kelvin] + qintr_rain, &! rainfall interception (mm h2o/s) + qintr_snow, &! snowfall interception (mm h2o/s) + + ! radiative fluxes + coszen, &! cosine of the solar zenith angle + parsun, &! photosynthetic active radiation by sunlit leaves (W m-2) + parsha, &! photosynthetic active radiation by shaded leaves (W m-2) + sabvsun, &! solar radiation absorbed by vegetation [W/m2] + sabvsha, &! solar radiation absorbed by vegetation [W/m2] + sabg, &! solar radiation absorbed by ground [W/m2] + sabg_soil, &! solar radiation absorbed by ground soil [W/m2] + sabg_snow, &! solar radiation absorbed by ground snow [W/m2] + frl, &! atmospheric infrared (longwave) radiation [W/m2] + extkb, &! (k, g(mu)/mu) direct solar extinction coefficient + extkd, &! diffuse and scattered diffuse PAR extinction coefficient + thermk, &! canopy gap fraction for tir radiation + + ! state variable (1) + fsno, &! fraction of ground covered by snow + sigf, &! fraction of veg cover, excluding snow-covered veg [-] + dz_soisno(lb:nl_soil), &! layer thickiness [m] + z_soisno (lb:nl_soil), &! node depth [m] + zi_soisno(lb-1:nl_soil) ! interface depth [m] real(r8), intent(in) :: & - sabg_lyr(lb:1) ! snow layer aborption + sabg_snow_lyr(lb:1) ! snow layer aborption - ! state variables (2) + ! state variables (2) real(r8), intent(inout) :: & - vegwp(1:nvegwcs),&! vegetation water potential - gs0sun, &! - gs0sha, &! + vegwp(1:nvegwcs),&! vegetation water potential + gs0sun, &! working copy of sunlit stomata conductance + gs0sha, &! working copy of shalit stomata conductance !Ozone stress variables - lai_old , & ! lai in last time step - o3uptakesun, & ! Ozone does, sunlit leaf (mmol O3/m^2) - o3uptakesha, & ! Ozone does, shaded leaf (mmol O3/m^2) - forc_ozone , & ! Ozone + lai_old , &! lai in last time step + o3uptakesun, &! Ozone does, sunlit leaf (mmol O3/m^2) + o3uptakesha, &! Ozone does, shaded leaf (mmol O3/m^2) + forc_ozone , &! Ozone !end ozone stress variables - tleaf, &! shaded leaf temperature [K] - t_soisno(lb:nl_soil), &! soil temperature [K] - wice_soisno(lb:nl_soil),&! ice lens [kg/m2] - wliq_soisno(lb:nl_soil),&! liqui water [kg/m2] - smp(1:nl_soil) ,&! soil matrix potential [mm] - hk(1:nl_soil) ,&! hydraulic conductivity [mm h2o/s] - - ldew, &! depth of water on foliage [kg/(m2 s)] - ldew_rain, &! depth of rain on foliage [kg/(m2 s)] - ldew_snow, &! depth of rain on foliage [kg/(m2 s)] - scv, &! snow cover, water equivalent [mm, kg/m2] - snowdp ! snow depth [m] + tleaf, &! shaded leaf temperature [K] + t_soisno(lb:nl_soil), &! soil temperature [K] + wice_soisno(lb:nl_soil),&! ice lens [kg/m2] + wliq_soisno(lb:nl_soil),&! liqui water [kg/m2] + smp(1:nl_soil) ,&! soil matrix potential [mm] + hk(1:nl_soil) ,&! hydraulic conductivity [mm h2o/s] + + ldew, &! depth of water on foliage [kg/(m2 s)] + ldew_rain, &! depth of rain on foliage [kg/(m2 s)] + ldew_snow, &! depth of rain on foliage [kg/(m2 s)] + scv, &! snow cover, water equivalent [mm, kg/m2] + snowdp ! snow depth [m] real(r8), intent(out) :: & - snofrz (lb:0) !snow freezing rate (col,lyr) [kg m-2 s-1] + snofrz (lb:0) !snow freezing rate (col,lyr) [kg m-2 s-1] - integer, intent(out) :: & + integer, intent(out) :: & imelt(lb:nl_soil) ! flag for melting or freezing [-] real(r8), intent(out) :: & @@ -283,58 +289,72 @@ SUBROUTINE THERMAL (ipatch ,patchtype ,lb ,deltim ,& rstfacsun_out,&! factor of soil water stress on sunlit leaf rstfacsha_out ! factor of soil water stress on shaded leaf real(r8), intent(out) :: & - assimsun_out ,& - etrsun_out ,& - assimsha_out ,& - etrsha_out + assimsun_out ,&! diagnostic sunlit leaf assim value for output + etrsun_out ,&! diagnostic sunlit leaf etr value for output + assimsha_out ,&! diagnostic shaded leaf assim for output + etrsha_out ! diagnostic shaded leaf etr for output - ! Output fluxes + ! Output fluxes real(r8), intent(out) :: & - taux, &! wind stress: E-W [kg/m/s**2] - tauy, &! wind stress: N-S [kg/m/s**2] - fsena, &! sensible heat from canopy height to atmosphere [W/m2] - fevpa, &! evapotranspiration from canopy height to atmosphere [mm/s] - lfevpa, &! latent heat flux from canopy height to atmosphere [W/m2] - fsenl, &! ensible heat from leaves [W/m2] - fevpl, &! evaporation+transpiration from leaves [mm/s] - etr, &! transpiration rate [mm/s] - fseng, &! sensible heat flux from ground [W/m2] - fevpg, &! evaporation heat flux from ground [mm/s] - olrg, &! outgoing long-wave radiation from ground+canopy - fgrnd, &! ground heat flux [W/m2] - rootr(1:nl_soil),&! root resistance of a layer, all layers add to 1 - - qseva, &! ground surface evaporation rate (mm h2o/s) - qsdew, &! ground surface dew formation (mm h2o /s) [+] - qsubl, &! sublimation rate from snow pack (mm h2o /s) [+] - qfros, &! surface dew added to snow pack (mm h2o /s) [+] - - sm, &! rate of snowmelt [kg/(m2 s)] - tref, &! 2 m height air temperature [kelvin] - qref, &! 2 m height air specific humidity - trad, &! radiative temperature [K] - - rst, &! stomatal resistance (s m-1) - assim, &! assimilation - respc, &! respiration - - ! additional variables required by coupling with WRF or RSM model - emis, &! averaged bulk surface emissivity - z0m, &! effective roughness [m] - zol, &! dimensionless height (z/L) used in Monin-Obukhov theory - rib, &! bulk Richardson number in surface layer - ustar, &! u* in similarity theory [m/s] - qstar, &! q* in similarity theory [kg/kg] - tstar, &! t* in similarity theory [K] - fm, &! integral of profile function for momentum - fh, &! integral of profile function for heat - fq ! integral of profile function for moisture + taux, &! wind stress: E-W [kg/m/s**2] + tauy, &! wind stress: N-S [kg/m/s**2] + fsena, &! sensible heat from canopy height to atmosphere [W/m2] + fevpa, &! evapotranspiration from canopy height to atmosphere [mm/s] + lfevpa, &! latent heat flux from canopy height to atmosphere [W/m2] + fsenl, &! ensible heat from leaves [W/m2] + fevpl, &! evaporation+transpiration from leaves [mm/s] + etr, &! transpiration rate [mm/s] + fseng, &! sensible heat flux from ground [W/m2] + fevpg, &! evaporation heat flux from ground [mm/s] + olrg, &! outgoing long-wave radiation from ground+canopy + fgrnd, &! ground heat flux [W/m2] + rootr(1:nl_soil),&! water uptake farction from different layers, all layers add to 1.0 + rootflux(1:nl_soil),&! root uptake from different layer, all layers add to transpiration + + qseva, &! ground surface evaporation rate (mm h2o/s) + qsdew, &! ground surface dew formation (mm h2o /s) [+] + qsubl, &! sublimation rate from snow pack (mm h2o /s) [+] + qfros, &! surface dew added to snow pack (mm h2o /s) [+] + qseva_soil, &! ground soil surface evaporation rate (mm h2o/s) + qsdew_soil, &! ground soil surface dew formation (mm h2o /s) [+] + qsubl_soil, &! sublimation rate from soil ice pack (mm h2o /s) [+] + qfros_soil, &! surface dew added to soil ice pack (mm h2o /s) [+] + qseva_snow, &! ground snow surface evaporation rate (mm h2o/s) + qsdew_snow, &! ground snow surface dew formation (mm h2o /s) [+] + qsubl_snow, &! sublimation rate from snow pack (mm h2o /s) [+] + qfros_snow, &! surface dew added to snow pack (mm h2o /s) [+] + + sm, &! rate of snowmelt [kg/(m2 s)] + tref, &! 2 m height air temperature [kelvin] + qref, &! 2 m height air specific humidity + trad, &! radiative temperature [K] + rss, &! bare soil resistance for evaporation [s/m] + rst, &! stomatal resistance (s m-1) + assim, &! assimilation + respc, &! respiration + + ! additional variables required by coupling with WRF or RSM model + emis, &! averaged bulk surface emissivity + z0m, &! effective roughness [m] + zol, &! dimensionless height (z/L) used in Monin-Obukhov theory + rib, &! bulk Richardson number in surface layer + ustar, &! u* in similarity theory [m/s] + qstar, &! q* in similarity theory [kg/kg] + tstar, &! t* in similarity theory [K] + fm, &! integral of profile function for momentum + fh, &! integral of profile function for heat + fq ! integral of profile function for moisture !---------------------Local Variables----------------------------------- integer i,j real(r8) :: & + fseng_soil, &! sensible heat flux from soil fraction + fseng_snow, &! sensible heat flux from snow fraction + fevpg_soil, &! latent heat flux from soil fraction + fevpg_snow, &! latent heat flux from snow fraction + cgrnd, &! deriv. of soil energy flux wrt to soil temp [w/m2/k] cgrndl, &! deriv, of soil sensible heat flux wrt soil temp [w/m2/k] cgrnds, &! deriv of soil latent heat flux wrt soil temp [w/m**2/k] @@ -357,6 +377,9 @@ SUBROUTINE THERMAL (ipatch ,patchtype ,lb ,deltim ,& olrb, &! olrg assuming blackbody emission [W/m2] psit, &! negative potential of soil qg, &! ground specific humidity [kg/kg] +! 03/07/2020, yuan: + q_soil, &! ground soil specific humudity [kg/kg] + q_snow, &! ground snow specific humudity [kg/kg] qsatg, &! saturated humidity [kg/kg] qsatgdT, &! d(qsatg)/dT qred, &! soil surface relative humidity @@ -367,6 +390,8 @@ SUBROUTINE THERMAL (ipatch ,patchtype ,lb ,deltim ,& rstfac, &! factor of soil water stress t_grnd, &! ground surface temperature [K] t_grnd_bef, &! ground surface temperature [K] + t_soil, &! ground soil temperature + t_snow, &! ground snow temperature t_soisno_bef(lb:nl_soil), &! soil/snow temperature before update tinc, &! temperature difference of two time step ur, &! wind speed at reference height [m/s] @@ -385,8 +410,8 @@ SUBROUTINE THERMAL (ipatch ,patchtype ,lb ,deltim ,& integer p, ps, pe, pc -#ifdef LULC_IGBP_PFT real(r8), allocatable :: rootr_p (:,:) + real(r8), allocatable :: rootflux_p (:,:) real(r8), allocatable :: etrc_p (:) real(r8), allocatable :: rstfac_p (:) real(r8), allocatable :: rstfacsun_p (:) @@ -395,6 +420,12 @@ SUBROUTINE THERMAL (ipatch ,patchtype ,lb ,deltim ,& real(r8), allocatable :: gssha_p (:) real(r8), allocatable :: fsun_p (:) real(r8), allocatable :: sabv_p (:) + +! 03/06/2020, yuan: added + REAL(r8), allocatable :: fseng_soil_p (:) + REAL(r8), allocatable :: fseng_snow_p (:) + REAL(r8), allocatable :: fevpg_soil_p (:) + REAL(r8), allocatable :: fevpg_snow_p (:) real(r8), allocatable :: cgrnd_p (:) real(r8), allocatable :: cgrnds_p (:) real(r8), allocatable :: cgrndl_p (:) @@ -413,30 +444,12 @@ SUBROUTINE THERMAL (ipatch ,patchtype ,lb ,deltim ,& real(r8), allocatable :: etrsun_p (:) real(r8), allocatable :: assimsha_p (:) real(r8), allocatable :: etrsha_p (:) -#endif -#ifdef LULC_IGBP_PC - real(r8) :: rootr_c (nl_soil,0:N_PFT-1) - real(r8) :: etrc_c (0:N_PFT-1) - real(r8) :: rstfac_c (0:N_PFT-1) - real(r8) :: rstfacsun_c (0:N_PFT-1) - real(r8) :: rstfacsha_c (0:N_PFT-1) - real(r8) :: gssun_c (0:N_PFT-1) - real(r8) :: gssha_c (0:N_PFT-1) - real(r8) :: laisun_c (0:N_PFT-1) - real(r8) :: laisha_c (0:N_PFT-1) - real(r8) :: fsun_c (0:N_PFT-1) - real(r8) :: sabv_c (0:N_PFT-1) - real(r8) :: hprl_c (0:N_PFT-1) - real(r8) :: assimsun_c (0:N_PFT-1) - real(r8) :: etrsun_c (0:N_PFT-1) - real(r8) :: assimsha_c (0:N_PFT-1) - real(r8) :: etrsha_c (0:N_PFT-1) -#endif !======================================================================= ! [1] Initial set and propositional variables !======================================================================= + ! emissivity emg = 0.96 IF (scv>0. .or. patchtype==3) emg = 0.97 @@ -447,8 +460,7 @@ SUBROUTINE THERMAL (ipatch ,patchtype ,lb ,deltim ,& lfevpa = 0.; fsenl = 0. fevpl = 0.; etr = 0. fseng = 0.; fevpg = 0. - dlrad = frl - ulrad = frl*(1.-emg) + emg*stefnc*t_soisno(lb)**4 + cgrnds = 0.; cgrndl = 0. cgrnd = 0.; tref = 0. qref = 0.; rst = 2.0e4 @@ -459,10 +471,24 @@ SUBROUTINE THERMAL (ipatch ,patchtype ,lb ,deltim ,& zol = 0.; rib = 0. ustar = 0.; qstar = 0. tstar = 0.; rootr = 0. + rootflux = 0. - ! temperature and water mass from previous time step + dlrad = frl + + t_soil = t_soisno(1) + t_snow = t_soisno(lb) + +IF (.not.DEF_SPLIT_SOILSNOW) THEN t_grnd = t_soisno(lb) + ulrad = frl*(1.-emg) + emg*stefnc*t_grnd**4 +ELSE + t_grnd = fsno*t_snow + (1.-fsno)*t_soil + ulrad = frl*(1.-emg) & + + fsno*emg*stefnc*t_snow**4 & + + (1.-fsno)*emg*stefnc*t_soil**4 +ENDIF + ! temperature and water mass from previous time step t_soisno_bef(lb:) = t_soisno(lb:) t_grnd_bef = t_grnd wice0(lb:) = wice_soisno(lb:) @@ -473,18 +499,19 @@ SUBROUTINE THERMAL (ipatch ,patchtype ,lb ,deltim ,& IF (wliq_soisno(lb)<=0. .and. wice_soisno(lb)>0.) htvp = hsub ! potential temperatur at the reference height - thm = forc_t + 0.0098*forc_hgt_t !intermediate variable equivalent to - !forc_t*(pgcm/forc_psrf)**(rgas/cpair) - th = forc_t*(100000./forc_psrf)**(rgas/cpair) !potential T - thv = th*(1.+0.61*forc_q) !virtual potential T - ur = max(0.1,sqrt(forc_us*forc_us+forc_vs*forc_vs)) !limit set to 0.1 + thm = forc_t + 0.0098*forc_hgt_t !intermediate variable equivalent to + !forc_t*(pgcm/forc_psrf)**(rgas/cpair) + th = forc_t*(100000./forc_psrf)**(rgas/cpair) !potential T + thv = th*(1.+0.61*forc_q) !virtual potential T + ur = max(0.1,sqrt(forc_us*forc_us+forc_vs*forc_vs)) !limit set to 0.1 + !======================================================================= ! [2] specific humidity and its derivative at ground surface !======================================================================= qred = 1. - CALL qsadv(t_grnd,forc_psrf,eg,degdT,qsatg,qsatgdT) + hr = 1. IF (patchtype<=1) THEN !soil ground wx = (wliq_soisno(1)/denh2o + wice_soisno(1)/denice)/dz_soisno(1) @@ -508,38 +535,84 @@ SUBROUTINE THERMAL (ipatch ,patchtype ,lb ,deltim ,& qred = (1.-fsno)*hr + fsno ENDIF - qg = qred*qsatg - dqgdT = qred*qsatgdT +IF (.not. DEF_SPLIT_SOILSNOW) THEN + CALL qsadv(t_grnd,forc_psrf,eg,degdT,qsatg,qsatgdT) + + qg = qred*qsatg + dqgdT = qred*qsatgdT IF (qsatg > forc_q .and. forc_q > qred*qsatg) THEN qg = forc_q; dqgdT = 0. ENDIF + q_soil = qg + q_snow = qg + +ELSE + call qsadv(t_soil,forc_psrf,eg,degdT,qsatg,qsatgdT) + + q_soil = hr*qsatg + dqgdT = (1.-fsno)*hr*qsatgdT + + if(qsatg > forc_q .and. forc_q > hr*qsatg)then + q_soil = forc_q; dqgdT = 0. + ENDIF + + call qsadv(t_snow,forc_psrf,eg,degdT,qsatg,qsatgdT) + + q_snow = qsatg + dqgdT = dqgdT + fsno*qsatgdT + + ! weighted average qg + qg = (1.-fsno)*q_soil + fsno*q_snow +ENDIF + + ! calculate soil surface resistance (rss) + ! ------------------------------------------------ + !NOTE: (1) DEF_RSS_SCHEME=0 means no rss considered + ! (2) Do NOT calculate rss for the first timestep + IF (DEF_RSS_SCHEME>0 .and. rss/=spval) THEN + + !NOTE: If the beta scheme is used, the rss is not soil resistance, + !but soil beta factor (soil wetness relative to field capacity [0-1]). + CALL SoilSurfaceResistance (nl_soil,forc_rhoair,hksati,porsl,psi0, & +#ifdef Campbell_SOIL_MODEL + bsw, & +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + theta_r, alpha_vgm, n_vgm, L_vgm, sc_vgm, fc_vgm, & +#endif + dz_soisno,t_soisno,wliq_soisno,wice_soisno,fsno,qg,rss) + ELSE + rss = 0. + ENDIF + !======================================================================= ! [3] Compute sensible and latent fluxes and their derivatives with respect ! to ground temperature using ground temperatures from previous time step. +! TODO: modify code description !======================================================================= -IF (patchtype == 0) THEN - -!======================================================================= -!======================================================================= -#if(defined LULC_USGS || defined LULC_IGBP) - CALL groundfluxes (zlnd,zsno,forc_hgt_u,forc_hgt_t,forc_hgt_q, & - forc_hpbl, & + ! Always CALL GroundFluxes for bare ground CASE + CALL GroundFluxes (zlnd,zsno,forc_hgt_u,forc_hgt_t,forc_hgt_q,forc_hpbl, & forc_us,forc_vs,forc_t,forc_q,forc_rhoair,forc_psrf, & - ur,thm,th,thv,t_grnd,qg,dqgdT,htvp, & + ur,thm,th,thv,t_grnd,qg,rss,dqgdT,htvp, & fsno,cgrnd,cgrndl,cgrnds, & - taux,tauy,fseng,fevpg,tref,qref, & + t_soil,t_snow,q_soil,q_snow, & + !taux,tauy,fseng,fevpg,tref,qref, & + taux,tauy,fseng,fseng_soil,fseng_snow, & + fevpg,fevpg_soil,fevpg_snow,tref,qref, & z0m_g,z0h_g,zol_g,rib_g,ustar_g,qstar_g,tstar_g,fm_g,fh_g,fq_g) - ! SAVE variables for bareground case obu_g = forc_hgt_u / zol_g + !======================================================================= ! [4] Canopy temperature, fluxes from the canopy !======================================================================= +IF ( patchtype==0.and.DEF_USE_LCT .or. patchtype>0 ) THEN + sabv = sabvsun + sabvsha IF (lai+sai > 1e-6) THEN @@ -564,21 +637,24 @@ SUBROUTINE THERMAL (ipatch ,patchtype ,lb ,deltim ,& rstfacsun_out = rstfac rstfacsha_out = rstfac - CALL LeafTemp (ipatch,1,deltim ,csoilc ,dewmx ,htvp ,& + CALL LeafTemperature(ipatch,1,deltim,csoilc,dewmx ,htvp ,& lai ,sai ,htop ,hbot ,sqrtdi ,& effcon ,vmax25 ,slti ,hlti ,shti ,& - hhti ,trda ,trdm ,trop ,gradm ,& - binter ,extkn ,extkb ,extkd ,forc_hgt_u ,& - forc_hgt_t ,forc_hgt_q ,forc_us ,forc_vs ,thm ,& - th ,thv ,forc_q ,forc_psrf ,forc_rhoair,& - parsun ,parsha ,sabv ,frl ,fsun ,& - thermk ,rstfacsun_out ,rstfacsha_out ,& + hhti ,trda ,trdm ,trop ,g1 ,& + g0 ,gradm ,binter ,extkn ,extkb ,& + extkd ,forc_hgt_u ,forc_hgt_t,forc_hgt_q ,forc_us ,& + forc_vs ,thm ,th ,thv ,forc_q ,& + forc_psrf ,forc_rhoair,parsun ,parsha ,sabv ,& + frl ,fsun ,thermk ,rstfacsun_out,rstfacsha_out,& gssun_out ,gssha_out ,forc_po2m ,forc_pco2m ,z0h_g ,& obu_g ,ustar_g ,zlnd ,zsno ,fsno ,& - sigf ,etrc ,t_grnd ,qg ,dqgdT ,& + sigf ,etrc ,t_grnd ,qg,rss ,& + t_soil ,t_snow ,q_soil ,q_snow ,dqgdT ,& emg ,tleaf ,ldew ,ldew_rain ,ldew_snow ,& taux ,tauy ,& - fseng ,fevpg ,cgrnd ,cgrndl ,cgrnds ,& + fseng ,fseng_soil ,fseng_snow,& + fevpg ,fevpg_soil ,fevpg_snow,& + cgrnd ,cgrndl ,cgrnds ,& tref ,qref ,rst ,assim ,respc ,& fsenl ,fevpl ,etr ,dlrad ,ulrad ,& z0m ,zol ,rib ,ustar ,qstar ,& @@ -593,12 +669,8 @@ SUBROUTINE THERMAL (ipatch ,patchtype ,lb ,deltim ,& !end ozone stress variables forc_hpbl ,& qintr_rain ,qintr_snow,t_precip ,hprl ,smp ,& - hk(1:) ,hksati(1:),rootr(1:) ) - ENDIF - - ! equate canopy temperature to air over bareland. - ! required as sigf=0 carried over to next time step - IF (lai+sai <= 1e-6) THEN + hk(1:) ,hksati(1:),rootflux(1:) ) + ELSE tleaf = forc_t laisun = 0. laisha = 0. @@ -607,20 +679,22 @@ SUBROUTINE THERMAL (ipatch ,patchtype ,lb ,deltim ,& ldew = 0. rstfacsun_out = 0. rstfacsha_out = 0. - if(DEF_USE_PLANTHYDRAULICS)THEN + if (DEF_USE_PLANTHYDRAULICS) THEN vegwp = -2.5e4 ENDIF ENDIF -#endif + +ENDIF -!======================================================================= -#ifdef LULC_IGBP_PFT +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) +IF (patchtype == 0) THEN ps = patch_pft_s(ipatch) pe = patch_pft_e(ipatch) allocate ( rootr_p (nl_soil, ps:pe) ) + allocate ( rootflux_p(nl_soil,ps:pe)) allocate ( etrc_p (ps:pe) ) allocate ( rstfac_p (ps:pe) ) allocate ( rstfacsun_p (ps:pe) ) @@ -629,6 +703,11 @@ SUBROUTINE THERMAL (ipatch ,patchtype ,lb ,deltim ,& allocate ( gssha_p (ps:pe) ) allocate ( fsun_p (ps:pe) ) allocate ( sabv_p (ps:pe) ) +IF (DEF_USE_PFT .or. patchclass(ipatch)==CROPLAND) THEN + allocate ( fseng_soil_p (ps:pe) ) + allocate ( fseng_snow_p (ps:pe) ) + allocate ( fevpg_soil_p (ps:pe) ) + allocate ( fevpg_snow_p (ps:pe) ) allocate ( cgrnd_p (ps:pe) ) allocate ( cgrnds_p (ps:pe) ) allocate ( cgrndl_p (ps:pe) ) @@ -642,29 +721,16 @@ SUBROUTINE THERMAL (ipatch ,patchtype ,lb ,deltim ,& allocate ( fm_p (ps:pe) ) allocate ( fh_p (ps:pe) ) allocate ( fq_p (ps:pe) ) +ENDIF allocate ( hprl_p (ps:pe) ) allocate ( assimsun_p (ps:pe) ) allocate ( etrsun_p (ps:pe) ) allocate ( assimsha_p (ps:pe) ) allocate ( etrsha_p (ps:pe) ) - ! always DO CALL groundfluxes - CALL groundfluxes (zlnd,zsno,forc_hgt_u,forc_hgt_t,forc_hgt_q, & - forc_hpbl, & - forc_us,forc_vs,forc_t,forc_q,forc_rhoair,forc_psrf, & - ur,thm,th,thv,t_grnd,qg,dqgdT,htvp, & - fsno,cgrnd,cgrndl,cgrnds, & - taux,tauy,fseng,fevpg,tref,qref, & - z0m_g,z0h_g,zol_g,rib_g,ustar_g,qstar_g,tstar_g,fm_g,fh_g,fq_g) - - obu_g = forc_hgt_u / zol_g - -!======================================================================= -! [4] Canopy temperature, fluxes from the canopy -!======================================================================= - sabv_p(ps:pe) = sabvsun_p(ps:pe) + sabvsha_p(ps:pe) sabv = sabvsun + sabvsha + DO i = ps, pe p = pftclass(i) @@ -686,26 +752,49 @@ SUBROUTINE THERMAL (ipatch ,patchtype ,lb ,deltim ,& IF (coszen<=0.0 .or. sabv_p(i)<1.) fsun_p(i) = 0.5 - laisun_p(i) = lai_p(i)*fsun_p(i) - laisha_p(i) = lai_p(i)*(1-fsun_p(i)) + laisun_p(i) = lai_p(i)*fsun_p(i) + laisha_p(i) = lai_p(i)*(1-fsun_p(i)) rstfacsun_p(i) = rstfac_p(i) rstfacsha_p(i) = rstfac_p(i) + ELSE + laisun_p(i) = 0. + laisha_p(i) = 0. + ldew_rain_p(i) = 0. + ldew_snow_p(i) = 0. + ldew_p(i) = 0. + rootr_p(:,i) = 0. + rootflux_p(:,i)= 0. + rstfacsun_p(i) = 0. + rstfacsha_p(i) = 0. + ENDIF + ENDDO + - CALL LeafTemp (ipatch,p,deltim,csoilc ,dewmx ,htvp ,& +IF (DEF_USE_PFT .or. patchclass(ipatch)==CROPLAND) THEN + + DO i = ps, pe + p = pftclass(i) + IF (lai_p(i)+sai_p(i) > 1e-6) THEN + + CALL LeafTemperature(ipatch,p,deltim,csoilc,dewmx ,htvp ,& lai_p(i) ,sai_p(i) ,htop_p(i) ,hbot_p(i) ,sqrtdi_p(p),& effcon_p(p),vmax25_p(p),slti_p(p) ,hlti_p(p) ,shti_p(p) ,& - hhti_p(p) ,trda_p(p) ,trdm_p(p) ,trop_p(p) ,gradm_p(p) ,& - binter_p(p),extkn_p(p) ,extkb_p(i) ,extkd_p(i) ,forc_hgt_u ,& - forc_hgt_t ,forc_hgt_q ,forc_us ,forc_vs ,thm ,& - th ,thv ,forc_q ,forc_psrf ,forc_rhoair,& - parsun_p(i),parsha_p(i),sabv_p(i) ,frl ,fsun_p(i) ,& - thermk_p(i),rstfacsun_p(i) ,rstfacsha_p(i) ,& + hhti_p(p) ,trda_p(p) ,trdm_p(p) ,trop_p(p) ,g1_p(p) ,& + g0_p(p) ,gradm_p(p) ,binter_p(p),extkn_p(p) ,extkb_p(i) ,& + extkd_p(i) ,forc_hgt_u ,forc_hgt_t ,forc_hgt_q ,forc_us ,& + forc_vs ,thm ,th ,thv ,forc_q ,& + forc_psrf ,forc_rhoair,parsun_p(i),parsha_p(i),sabv_p(i) ,& + frl ,fsun_p(i) ,thermk_p(i),rstfacsun_p(i),rstfacsha_p(i),& gssun_p(i) ,gssha_p(i) ,forc_po2m ,forc_pco2m ,z0h_g ,& obu_g ,ustar_g ,zlnd ,zsno ,fsno ,& - sigf_p(i) ,etrc_p(i) ,t_grnd ,qg ,dqgdT ,& + sigf_p(i) ,etrc_p(i) ,t_grnd ,qg,rss ,& + t_soil ,t_snow ,q_soil ,q_snow ,& + dqgdT ,& emg ,tleaf_p(i) ,ldew_p(i) ,ldew_rain_p(i),ldew_snow_p(i),& taux_p(i) ,tauy_p(i) ,& - fseng_p(i) ,fevpg_p(i) ,cgrnd_p(i) ,cgrndl_p(i),cgrnds_p(i),& + fseng_p(i),fseng_soil_p(i),fseng_snow_p(i), & + fevpg_p(i),fevpg_soil_p(i),fevpg_snow_p(i), & + cgrnd_p(i) ,cgrndl_p(i),cgrnds_p(i),& tref_p(i) ,qref_p(i) ,rst_p(i) ,assim_p(i) ,respc_p(i) ,& fsenl_p(i) ,fevpl_p(i) ,etr_p(i) ,dlrad_p(i) ,ulrad_p(i) ,& z0m_p(i) ,zol_p(i) ,rib_p(i) ,ustar_p(i) ,qstar_p(i) ,& @@ -720,27 +809,21 @@ SUBROUTINE THERMAL (ipatch ,patchtype ,lb ,deltim ,& !end ozone stress variables forc_hpbl ,& qintr_rain_p(i),qintr_snow_p(i),t_precip,hprl_p(i),smp ,& - hk(1:) ,hksati(1:),rootr_p(1:,i) ) + hk(1:) ,hksati(1:),rootflux_p(1:,i) ) ELSE - CALL groundfluxes (zlnd,zsno,forc_hgt_u,forc_hgt_t,forc_hgt_q, & - forc_hpbl, & + CALL GroundFluxes (zlnd,zsno,forc_hgt_u,forc_hgt_t,forc_hgt_q,forc_hpbl, & forc_us,forc_vs,forc_t,forc_q,forc_rhoair,forc_psrf, & - ur,thm,th,thv,t_grnd,qg,dqgdT,htvp, & + ur,thm,th,thv,t_grnd,qg,rss,dqgdT,htvp, & fsno,cgrnd_p(i),cgrndl_p(i),cgrnds_p(i), & - taux_p(i),tauy_p(i),fseng_p(i),fevpg_p(i),tref_p(i),qref_p(i), & - z0m_p(i),z0h_g,zol_p(i),rib_p(i),ustar_p(i),qstar_p(i),tstar_p(i),fm_p(i),fh_p(i),fq_p(i)) + t_soil,t_snow,q_soil,q_snow, & + taux_p(i),tauy_p(i),fseng_p(i),fseng_soil_p(i),fseng_snow_p(i), & + fevpg_p(i),fevpg_soil_p(i),fevpg_snow_p(i),tref_p(i),qref_p(i), & + z0m_p(i),z0h_g,zol_p(i),rib_p(i),ustar_p(i),& + qstar_p(i),tstar_p(i),fm_p(i),fh_p(i),fq_p(i)) tleaf_p (i) = forc_t - laisun_p (i) = 0. - laisha_p (i) = 0. - ldew_rain_p (i) = 0. - ldew_snow_p (i) = 0. - ldew_p (i) = 0. - rootr_p (:,i) = 0. - rstfacsun_p (i) = 0. - rstfacsha_p (i) = 0. gssun_p (i) = 0. gssha_p (i) = 0. assimsun_p (i) = 0. @@ -754,48 +837,119 @@ SUBROUTINE THERMAL (ipatch ,patchtype ,lb ,deltim ,& fevpl_p (i) = 0. etr_p (i) = 0. dlrad_p (i) = frl + +IF (.not.DEF_SPLIT_SOILSNOW) THEN ulrad_p (i) = frl*(1.-emg) + emg*stefnc*t_grnd**4 +ELSE + ulrad_p (i) = frl*(1.-emg) & + + fsno*emg*stefnc*t_snow**4 & + + (1.-fsno)*emg*stefnc*t_soil**4 +ENDIF hprl_p (i) = 0. - IF(DEF_USE_PLANTHYDRAULICS)THEN + IF (DEF_USE_PLANTHYDRAULICS) THEN vegwp_p(:,i) = -2.5e4 ENDIF ENDIF ENDDO - laisun = sum( laisun_p (ps:pe)*pftfrac(ps:pe) ) - laisha = sum( laisha_p (ps:pe)*pftfrac(ps:pe) ) - dlrad = sum( dlrad_p (ps:pe)*pftfrac(ps:pe) ) - ulrad = sum( ulrad_p (ps:pe)*pftfrac(ps:pe) ) - tleaf = sum( tleaf_p (ps:pe)*pftfrac(ps:pe) ) - ldew_rain = sum( ldew_rain_p (ps:pe)*pftfrac(ps:pe) ) - ldew_snow = sum( ldew_snow_p (ps:pe)*pftfrac(ps:pe) ) - ldew = sum( ldew_p (ps:pe)*pftfrac(ps:pe) ) - tref = sum( tref_p (ps:pe)*pftfrac(ps:pe) ) - qref = sum( qref_p (ps:pe)*pftfrac(ps:pe) ) +ENDIF + + +IF (DEF_USE_PC .and. patchclass(ipatch)/=CROPLAND) THEN + + ! initialization + rst_p (ps:pe) = 2.0e4 + assim_p (ps:pe) = 0. + respc_p (ps:pe) = 0. + fsenl_p (ps:pe) = 0. + fevpl_p (ps:pe) = 0. + etr_p (ps:pe) = 0. + hprl_p (ps:pe) = 0. + z0m_p (ps:pe) = (1.-fsno)*zlnd + fsno*zsno + + IF (DEF_USE_PLANTHYDRAULICS) THEN + vegwp_p (:,ps:pe) = -2.5e4 + ENDIF + + CALL LeafTemperaturePC (ipatch,ps,pe ,deltim ,csoilc ,dewmx ,& + htvp ,pftclass(ps:pe) ,pftfrac(ps:pe) ,htop_p(ps:pe) ,hbot_p(ps:pe) ,& + lai_p(ps:pe) ,sai_p(ps:pe) ,extkb_p(ps:pe) ,extkd_p(ps:pe) ,forc_hgt_u ,& + forc_hgt_t ,forc_hgt_q ,forc_us ,forc_vs ,forc_t ,& + thm ,th ,thv ,forc_q ,forc_psrf ,& + forc_rhoair ,parsun_p(ps:pe) ,parsha_p(ps:pe) ,fsun_p(:) ,sabv_p(:) ,& + frl ,thermk_p(ps:pe) ,fshade_p(ps:pe) ,rstfacsun_p(:) ,rstfacsha_p(:) ,& + gssun_p(:) ,gssha_p(:) ,forc_po2m ,forc_pco2m ,z0h_g ,& + obu_g ,ustar_g ,zlnd ,zsno ,fsno ,& + sigf_p(ps:pe) ,etrc_p(:) ,t_grnd ,qg,rss ,dqgdT ,& + emg ,t_soil ,t_snow ,q_soil ,q_snow ,& + z0m_p(ps:pe) ,tleaf_p(ps:pe) ,ldew_p(ps:pe) ,ldew_rain_p(ps:pe),ldew_snow_p(ps:pe),& + taux ,tauy ,fseng ,fseng_soil ,fseng_snow ,& + fevpg ,fevpg_soil ,fevpg_snow ,cgrnd ,cgrndl ,& + cgrnds ,tref ,qref ,rst_p(ps:pe) ,assim_p(ps:pe) ,& + respc_p(ps:pe) ,fsenl_p(ps:pe) ,fevpl_p(ps:pe) ,etr_p(ps:pe) ,dlrad ,& + ulrad ,z0m ,zol ,rib ,ustar ,& + qstar ,tstar ,fm ,fh ,fq ,& + vegwp_p(:,ps:pe) ,gs0sun_p(ps:pe) ,gs0sha_p(ps:pe) ,assimsun_p(:) ,etrsun_p(:) ,& + assimsha_p(:) ,etrsha_p(:) ,& +!Ozone stress variables + o3coefv_sun_p(ps:pe) ,o3coefv_sha_p(ps:pe) ,o3coefg_sun_p(ps:pe) ,o3coefg_sha_p(ps:pe) ,& + lai_old_p(ps:pe) ,o3uptakesun_p(ps:pe) ,o3uptakesha_p(ps:pe) ,forc_ozone ,& +!End ozone stress variables + forc_hpbl ,& + qintr_rain_p(ps:pe) ,qintr_snow_p(ps:pe) ,t_precip ,hprl_p(:) ,& + smp ,hk(1:) ,hksati(1:) ,rootflux_p(:,:) ) +ENDIF + + ! aggragation PFTs to a patch + laisun = sum( laisun_p (ps:pe)*pftfrac(ps:pe) ) + laisha = sum( laisha_p (ps:pe)*pftfrac(ps:pe) ) + tleaf = sum( tleaf_p (ps:pe)*pftfrac(ps:pe) ) + ldew_rain = sum( ldew_rain_p (ps:pe)*pftfrac(ps:pe) ) + ldew_snow = sum( ldew_snow_p (ps:pe)*pftfrac(ps:pe) ) + ldew = sum( ldew_p (ps:pe)*pftfrac(ps:pe) ) ! may have problem with rst, but the same for LC - rst = sum( rst_p (ps:pe)*pftfrac(ps:pe) ) - assim = sum( assim_p (ps:pe)*pftfrac(ps:pe) ) - respc = sum( respc_p (ps:pe)*pftfrac(ps:pe) ) - taux = sum( taux_p (ps:pe)*pftfrac(ps:pe) ) - tauy = sum( tauy_p (ps:pe)*pftfrac(ps:pe) ) - fseng = sum( fseng_p (ps:pe)*pftfrac(ps:pe) ) - fevpg = sum( fevpg_p (ps:pe)*pftfrac(ps:pe) ) - cgrnd = sum( cgrnd_p (ps:pe)*pftfrac(ps:pe) ) - cgrndl = sum( cgrndl_p (ps:pe)*pftfrac(ps:pe) ) - cgrnds = sum( cgrnds_p (ps:pe)*pftfrac(ps:pe) ) - fsenl = sum( fsenl_p (ps:pe)*pftfrac(ps:pe) ) - fevpl = sum( fevpl_p (ps:pe)*pftfrac(ps:pe) ) - etr = sum( etr_p (ps:pe)*pftfrac(ps:pe) ) - z0m = sum( z0m_p (ps:pe)*pftfrac(ps:pe) ) - zol = sum( zol_p (ps:pe)*pftfrac(ps:pe) ) - rib = sum( rib_p (ps:pe)*pftfrac(ps:pe) ) - ustar = sum( ustar_p (ps:pe)*pftfrac(ps:pe) ) - qstar = sum( qstar_p (ps:pe)*pftfrac(ps:pe) ) - tstar = sum( tstar_p (ps:pe)*pftfrac(ps:pe) ) - fm = sum( fm_p (ps:pe)*pftfrac(ps:pe) ) - fh = sum( fh_p (ps:pe)*pftfrac(ps:pe) ) - fq = sum( fq_p (ps:pe)*pftfrac(ps:pe) ) + rst = sum( rst_p (ps:pe)*pftfrac(ps:pe) ) + assim = sum( assim_p (ps:pe)*pftfrac(ps:pe) ) + respc = sum( respc_p (ps:pe)*pftfrac(ps:pe) ) + fsenl = sum( fsenl_p (ps:pe)*pftfrac(ps:pe) ) + fevpl = sum( fevpl_p (ps:pe)*pftfrac(ps:pe) ) + etr = sum( etr_p (ps:pe)*pftfrac(ps:pe) ) +IF (DEF_USE_PFT .or. patchclass(ipatch)==CROPLAND) THEN + dlrad = sum( dlrad_p (ps:pe)*pftfrac(ps:pe) ) + ulrad = sum( ulrad_p (ps:pe)*pftfrac(ps:pe) ) + tref = sum( tref_p (ps:pe)*pftfrac(ps:pe) ) + qref = sum( qref_p (ps:pe)*pftfrac(ps:pe) ) + taux = sum( taux_p (ps:pe)*pftfrac(ps:pe) ) + tauy = sum( tauy_p (ps:pe)*pftfrac(ps:pe) ) + fseng = sum( fseng_p (ps:pe)*pftfrac(ps:pe) ) + fseng_soil = sum( fseng_soil_p(ps:pe)*pftfrac(ps:pe) ) + fseng_snow = sum( fseng_snow_p(ps:pe)*pftfrac(ps:pe) ) + fevpg = sum( fevpg_p (ps:pe)*pftfrac(ps:pe) ) + fevpg_soil = sum( fevpg_soil_p(ps:pe)*pftfrac(ps:pe) ) + fevpg_snow = sum( fevpg_snow_p(ps:pe)*pftfrac(ps:pe) ) + cgrnd = sum( cgrnd_p (ps:pe)*pftfrac(ps:pe) ) + cgrndl = sum( cgrndl_p (ps:pe)*pftfrac(ps:pe) ) + cgrnds = sum( cgrnds_p (ps:pe)*pftfrac(ps:pe) ) + z0m = sum( z0m_p (ps:pe)*pftfrac(ps:pe) ) + zol = sum( zol_p (ps:pe)*pftfrac(ps:pe) ) + rib = sum( rib_p (ps:pe)*pftfrac(ps:pe) ) + ustar = sum( ustar_p (ps:pe)*pftfrac(ps:pe) ) + qstar = sum( qstar_p (ps:pe)*pftfrac(ps:pe) ) + tstar = sum( tstar_p (ps:pe)*pftfrac(ps:pe) ) + fm = sum( fm_p (ps:pe)*pftfrac(ps:pe) ) + fh = sum( fh_p (ps:pe)*pftfrac(ps:pe) ) + fq = sum( fq_p (ps:pe)*pftfrac(ps:pe) ) +ENDIF + rstfacsun_out = sum( rstfacsun_p (ps:pe)*pftfrac(ps:pe) ) + rstfacsha_out = sum( rstfacsha_p (ps:pe)*pftfrac(ps:pe) ) + gssun_out = sum( gssun_p (ps:pe)*pftfrac(ps:pe) ) + gssha_out = sum( gssha_p (ps:pe)*pftfrac(ps:pe) ) + assimsun_out = sum( assimsun_p (ps:pe)*pftfrac(ps:pe) ) + etrsun_out = sum( etrsun_p (ps:pe)*pftfrac(ps:pe) ) + assimsha_out = sum( assimsha_p (ps:pe)*pftfrac(ps:pe) ) + etrsha_out = sum( etrsha_p (ps:pe)*pftfrac(ps:pe) ) + hprl = sum( hprl_p (ps:pe)*pftfrac(ps:pe) ) IF(DEF_USE_PLANTHYDRAULICS)THEN DO j = 1, nvegwcs @@ -804,7 +958,7 @@ SUBROUTINE THERMAL (ipatch ,patchtype ,lb ,deltim ,& IF (abs(etr) > 0.) THEN DO j = 1, nl_soil - rootr(j) = sum(rootr_p(j,ps:pe)*pftfrac(ps:pe)) + rootflux(j) = sum(rootflux_p(j,ps:pe)*pftfrac(ps:pe)) ENDDO ENDIF ELSE @@ -815,23 +969,20 @@ SUBROUTINE THERMAL (ipatch ,patchtype ,lb ,deltim ,& ENDIF ENDIF - rstfacsun_out = sum( rstfacsun_p (ps:pe) * pftfrac(ps:pe) ) - rstfacsha_out = sum( rstfacsha_p (ps:pe) * pftfrac(ps:pe) ) - gssun_out = sum( gssun_p (ps:pe) * pftfrac(ps:pe) ) - gssha_out = sum( gssha_p (ps:pe) * pftfrac(ps:pe) ) - assimsun_out = sum( assimsun_p (ps:pe) * pftfrac(ps:pe) ) - etrsun_out = sum( etrsun_p (ps:pe) * pftfrac(ps:pe) ) - assimsha_out = sum( assimsha_p (ps:pe) * pftfrac(ps:pe) ) - etrsha_out = sum( etrsha_p (ps:pe) * pftfrac(ps:pe) ) - hprl = sum( hprl_p (ps:pe) * pftfrac(ps:pe) ) - - deallocate ( rootr_p ) + deallocate ( rootflux_p ) deallocate ( etrc_p ) deallocate ( rstfac_p ) deallocate ( rstfacsun_p ) deallocate ( rstfacsha_p ) + deallocate ( gssun_p ) + deallocate ( gssha_p ) deallocate ( fsun_p ) deallocate ( sabv_p ) +IF (DEF_USE_PFT .or. patchclass(ipatch)==CROPLAND) THEN + deallocate ( fseng_soil_p) + deallocate ( fseng_snow_p) + deallocate ( fevpg_soil_p) + deallocate ( fevpg_snow_p) deallocate ( cgrnd_p ) deallocate ( cgrnds_p ) deallocate ( cgrndl_p ) @@ -845,284 +996,22 @@ SUBROUTINE THERMAL (ipatch ,patchtype ,lb ,deltim ,& deallocate ( fm_p ) deallocate ( fh_p ) deallocate ( fq_p ) +ENDIF deallocate ( hprl_p ) + deallocate ( assimsun_p ) + deallocate ( etrsun_p ) + deallocate ( assimsha_p ) + deallocate ( etrsha_p ) +ENDIF #endif -!======================================================================= -#ifdef LULC_IGBP_PC - - pc = patch2pc(ipatch) - - ! always DO CALL groundfluxes first - CALL groundfluxes (zlnd,zsno,forc_hgt_u,forc_hgt_t,forc_hgt_q, & - forc_hpbl, & - forc_us,forc_vs,forc_t,forc_q,forc_rhoair,forc_psrf, & - ur,thm,th,thv,t_grnd,qg,dqgdT,htvp, & - fsno,cgrnd,cgrndl,cgrnds, & - taux,tauy,fseng,fevpg,tref,qref, & - z0m_g,z0h_g,zol_g,rib_g,ustar_g,qstar_g,tstar_g,fm_g,fh_g,fq_g) - - ! SAVE variables for bareground case - obu_g = forc_hgt_u / zol_g - - -!======================================================================= -! [4] Canopy temperature, fluxes from the canopy -!======================================================================= - - sabv_c(:) = sabvsun_c(:,pc) + sabvsha_c(:,pc) - sabv = sabvsun + sabvsha - hprl_c(:) = 0. - - DO p = 0, N_PFT-1 - - IF (lai_c(p,pc)+sai_c(p,pc) > 1e-6) THEN - - ! soil water strees factor on stomatal resistance - CALL eroot (nl_soil,trsmx0,porsl,& -#ifdef Campbell_SOIL_MODEL - bsw,& -#endif -#ifdef vanGenuchten_Mualem_SOIL_MODEL - theta_r, alpha_vgm, n_vgm, L_vgm, sc_vgm, fc_vgm, & -#endif - psi0,rootfr_p(:,p),& - dz_soisno,t_soisno,wliq_soisno,rootr_c(:,p),etrc_c(p),rstfac_c(p)) - - ! fraction of sunlit and shaded leaves of canopy - fsun_c(p) = ( 1. - exp(-min(extkb_c(p,pc)*lai_c(p,pc),40.))) & - / max( min(extkb_c(p,pc)*lai_c(p,pc),40.), 1.e-6 ) - - ! 01/06/2020, yuan: change to 0.5 - IF (coszen<=0.0 .or. sabv_c(p)<1.) fsun_c(p) = 0.5 - - laisun_c(p) = lai_c(p,pc)*fsun_c(p) - laisha_c(p) = lai_c(p,pc)*(1-fsun_c(p)) - rstfacsun_c(p) = rstfac_c(p) - rstfacsha_c(p) = rstfac_c(p) - - ELSE - laisun_c(p) = 0. - laisha_c(p) = 0. - ldew_rain_c(p,pc) = 0. - ldew_snow_c(p,pc) = 0. - ldew_c(p,pc) = 0. - rootr_c(:,p) = 0. - rstfacsun_c(p) = 0. - rstfacsha_c(p) = 0. - - IF(DEF_USE_PLANTHYDRAULICS)THEN - vegwp_c (:,p,pc) = -2.5e4 - ENDIF - ENDIF - - ENDDO - ! initialization - tleaf_c (:,pc) = forc_t !??? - rst_c (:,pc) = 2.0e4 - assim_c (:,pc) = 0. - respc_c (:,pc) = 0. - fsenl_c (:,pc) = 0. - fevpl_c (:,pc) = 0. - etr_c (:,pc) = 0. - z0m_c (:,pc) = (1.-fsno)*zlnd + fsno*zsno - - - IF (lai+sai > 1e-6) THEN - - CALL LeafTempPC ( ipatch,N_PFT ,deltim ,csoilc ,dewmx ,& - htvp ,pcfrac(:,pc) ,canlay(:) ,htop_c(:,pc) ,hbot_c(:,pc) ,& - lai_c(:,pc) ,sai_c(:,pc) ,sqrtdi_p(:) ,effcon_p(:) ,vmax25_p(:) ,& - slti_p(:) ,hlti_p(:) ,shti_p(:) ,hhti_p(:) ,trda_p(:) ,& - trdm_p(:) ,trop_p(:) ,gradm_p(:) ,binter_p(:) ,extkn_p(:) ,& - extkb_c(:,pc) ,extkd_c(:,pc) ,forc_hgt_u ,forc_hgt_t ,forc_hgt_q ,& - forc_us ,forc_vs ,thm ,th ,thv ,& - forc_q ,forc_psrf ,forc_rhoair ,parsun_c(:,pc),parsha_c(:,pc),& - fsun_c(:) ,sabv_c(:) ,frl ,thermk_c(:,pc),fshade_c(:,pc),& - rstfacsun_c(:) ,rstfacsha_c(:) ,& - gssun_c(:) ,gssha_c(:) ,forc_po2m ,forc_pco2m ,z0h_g ,obu_g,& - ustar_g ,zlnd ,zsno ,fsno ,sigf_c(:,pc) ,& - etrc_c(:) ,t_grnd ,qg ,dqgdT ,emg ,& - z0m_c(:,pc),tleaf_c(:,pc),ldew_c(:,pc),ldew_rain_c(:,pc),ldew_snow_c(:,pc),& - taux ,tauy ,& - fseng ,fevpg ,cgrnd ,cgrndl ,cgrnds ,& - tref ,qref ,rst_c(:,pc) ,assim_c(:,pc) ,respc_c(:,pc) ,& - fsenl_c(:,pc) ,fevpl_c(:,pc) ,etr_c(:,pc) ,dlrad ,ulrad ,& - z0m ,zol ,rib ,ustar ,qstar ,& - tstar ,fm ,fh ,fq ,rootfr_p(:,:) ,& - kmax_sun_p(:) ,kmax_sha_p(:) ,kmax_xyl_p(:) ,kmax_root_p(:),psi50_sun_p(:),& - psi50_sha_p(:),psi50_xyl_p(:),psi50_root_p(:),ck_p(:) ,vegwp_c(:,:,pc),& - gs0sun_c(:,pc),gs0sha_c(:,pc) ,& - assimsun_c(:) ,etrsun_c(:) ,assimsha_c(:) ,etrsha_c(:) ,& -!Ozone stress variables - o3coefv_sun_c(:,pc) ,o3coefv_sha_c(:,pc) ,o3coefg_sun_c(:,pc) ,o3coefg_sha_c(:,pc), & - lai_old_c(:,pc), o3uptakesun_c(:,pc), o3uptakesha_c(:,pc),forc_ozone, & -!End ozone stress variables - forc_hpbl ,& - qintr_rain_c(:,pc),qintr_snow_c(:,pc),t_precip,hprl_c(:) ,smp ,& - hk(1:) ,hksati(1:) ,rootr_c(:,:) ) - ELSE - laisun_c (:) = 0. - laisha_c (:) = 0. - tleaf_c (:,pc) = forc_t - ldew_rain_c (:,pc) = 0. - ldew_snow_c (:,pc) = 0. - ldew_c (:,pc) = 0. - rst_c (:,pc) = 2.0e4 - assim_c (:,pc) = 0. - respc_c (:,pc) = 0. - fsenl_c (:,pc) = 0. - fevpl_c (:,pc) = 0. - etr_c (:,pc) = 0. - hprl_c (:) = 0. - - IF(DEF_USE_PLANTHYDRAULICS)THEN - vegwp_c (:,:,pc) = -2.5e4 - ENDIF - ENDIF - - laisun = sum( laisun_c (:) *pcfrac(:,pc) ) - laisha = sum( laisha_c (:) *pcfrac(:,pc) ) - tleaf = sum( tleaf_c (:,pc)*pcfrac(:,pc) ) - ldew_rain = sum( ldew_rain_c (:,pc)*pcfrac(:,pc) ) - ldew_snow = sum( ldew_snow_c (:,pc)*pcfrac(:,pc) ) - ldew = sum( ldew_c (:,pc)*pcfrac(:,pc) ) - rst = sum( rst_c (:,pc)*pcfrac(:,pc) ) - assim = sum( assim_c (:,pc)*pcfrac(:,pc) ) - respc = sum( respc_c (:,pc)*pcfrac(:,pc) ) - fsenl = sum( fsenl_c (:,pc)*pcfrac(:,pc) ) - fevpl = sum( fevpl_c (:,pc)*pcfrac(:,pc) ) - etr = sum( etr_c (:,pc)*pcfrac(:,pc) ) - - IF(DEF_USE_PLANTHYDRAULICS)THEN - DO j = 1, nvegwcs - vegwp(j) = sum( vegwp_c(j,:,pc)*pcfrac(:,pc) ) - ENDDO - - ! loop for each soil layer - IF (abs(etr) > 0.) THEN - DO j = 1, nl_soil - rootr(j) = sum(rootr_c(j,:)*pcfrac(:,pc)) - ENDDO - ENDIF - ELSE - ! loop for each soil layer - IF (abs(etr) > 0.) THEN - DO j = 1, nl_soil - rootr(j) = sum(rootr_c(j,:)*etr_c(:,pc)*pcfrac(:,pc)) / etr - ENDDO - ENDIF - ENDIF - - rstfacsun_out = sum( rstfacsun_c(:) * pcfrac(:,pc) ) - rstfacsha_out = sum( rstfacsha_c(:) * pcfrac(:,pc) ) - gssun_out = sum( gssun_c (:) * pcfrac(:,pc) ) - gssha_out = sum( gssha_c (:) * pcfrac(:,pc) ) - assimsun_out = sum( assimsun_c (:) * pcfrac(:,pc) ) - etrsun_out = sum( etrsun_c (:) * pcfrac(:,pc) ) - assimsha_out = sum( assimsha_c (:) * pcfrac(:,pc) ) - etrsha_out = sum( etrsha_c (:) * pcfrac(:,pc) ) - hprl = sum( hprl_c (:) * pcfrac(:,pc) ) - -#endif - -! For patchtype/=0, not a soil patch -ELSE - CALL groundfluxes (zlnd,zsno,forc_hgt_u,forc_hgt_t,forc_hgt_q, & - forc_hpbl, & - forc_us,forc_vs,forc_t,forc_q,forc_rhoair,forc_psrf, & - ur,thm,th,thv,t_grnd,qg,dqgdT,htvp, & - fsno,cgrnd,cgrndl,cgrnds, & - taux,tauy,fseng,fevpg,tref,qref, & - z0m_g,z0h_g,zol_g,rib_g,ustar_g,qstar_g,tstar_g,fm_g,fh_g,fq_g) - - ! SAVE variables for bareground case - obu_g = forc_hgt_u / zol_g - -!======================================================================= -! [4] Canopy temperature, fluxes from the canopy -!======================================================================= - - sabv = sabvsun + sabvsha - - IF (lai+sai > 1e-6) THEN - - ! soil water stress factor on stomatal resistance - CALL eroot (nl_soil,trsmx0,porsl,& -#ifdef Campbell_SOIL_MODEL - bsw,& -#endif -#ifdef vanGenuchten_Mualem_SOIL_MODEL - theta_r, alpha_vgm, n_vgm, L_vgm, sc_vgm, fc_vgm, & -#endif - psi0,rootfr,dz_soisno,t_soisno,wliq_soisno,rootr,etrc,rstfac) - - ! fraction of sunlit and shaded leaves of canopy - fsun = ( 1. - exp(-min(extkb*lai,40.))) / max( min(extkb*lai,40.), 1.e-6 ) - - IF (coszen<=0.0 .or. sabv<1.) fsun = 0.5 - - laisun = lai*fsun - laisha = lai*(1-fsun) - rstfacsun_out = rstfac - rstfacsha_out = rstfac - - CALL LeafTemp (ipatch,1,deltim ,csoilc ,dewmx ,htvp ,& - lai ,sai ,htop ,hbot ,sqrtdi ,& - effcon ,vmax25 ,slti ,hlti ,shti ,& - hhti ,trda ,trdm ,trop ,gradm ,& - binter ,extkn ,extkb ,extkd ,forc_hgt_u ,& - forc_hgt_t ,forc_hgt_q ,forc_us ,forc_vs ,thm ,& - th ,thv ,forc_q ,forc_psrf ,forc_rhoair,& - parsun ,parsha ,sabv ,frl ,fsun ,& - thermk ,rstfacsun_out ,rstfacsha_out ,& - gssun_out ,gssha_out ,forc_po2m ,forc_pco2m ,z0h_g ,& - obu_g ,ustar_g ,zlnd ,zsno ,fsno ,& - sigf ,etrc ,t_grnd ,qg ,dqgdT ,& - emg ,tleaf ,ldew ,ldew_rain ,ldew_snow ,& - taux ,tauy ,& - fseng ,fevpg ,cgrnd ,cgrndl ,cgrnds ,& - tref ,qref ,rst ,assim ,respc ,& - fsenl ,fevpl ,etr ,dlrad ,ulrad ,& - z0m ,zol ,rib ,ustar ,qstar ,& - tstar ,fm ,fh ,fq ,rootfr ,& - kmax_sun ,kmax_sha ,kmax_xyl ,kmax_root ,psi50_sun ,& - psi50_sha ,psi50_xyl ,psi50_root,ck ,vegwp ,& - gs0sun ,gs0sha ,& - assimsun_out,etrsun_out,assimsha_out ,etrsha_out ,& -! Ozone stress variables - o3coefv_sun ,o3coefv_sha ,o3coefg_sun ,o3coefg_sha ,& - lai_old ,o3uptakesun ,o3uptakesha ,forc_ozone ,& -! End ozone stress variables - forc_hpbl ,& - qintr_rain ,qintr_snow,t_precip ,hprl ,smp ,& - hk(1:) ,hksati(1:),rootr(1:) ) - ENDIF - - ! equate canopy temperature to air over bareland. - ! required as sigf=0 carried over to next time step - IF (lai+sai <= 1e-6) THEN - tleaf = forc_t - laisun = 0. - laisha = 0. - ldew_rain = 0. - ldew_snow = 0. - ldew = 0. - rstfacsun_out = 0. - rstfacsha_out = 0. - IF(DEF_USE_PLANTHYDRAULICS)THEN - vegwp = -2.5e4 - ENDIF - ENDIF - -ENDIF !======================================================================= ! [5] Gound temperature !======================================================================= - CALL groundtem (patchtype,lb,nl_soil,deltim,& + CALL GroundTemperature (patchtype,lb,nl_soil,deltim,& capr,cnfac,vf_quartz,vf_gravels,vf_om,vf_sand,wf_gravels,wf_sand,& porsl,psi0,& #ifdef Campbell_SOIL_MODEL @@ -1135,37 +1024,53 @@ SUBROUTINE THERMAL (ipatch ,patchtype ,lb ,deltim ,& csol,k_solids,dksatu,dksatf,dkdry,& BA_alpha,BA_beta,& sigf,dz_soisno,z_soisno,zi_soisno,& - t_soisno,wice_soisno,wliq_soisno,scv,snowdp,& - frl,dlrad,sabg,sabg_lyr,fseng,fevpg,cgrnd,htvp,emg,& + t_soisno,t_grnd,t_soil,t_snow,wice_soisno,wliq_soisno,scv,snowdp,fsno,& + frl,dlrad,sabg,sabg_soil,sabg_snow,sabg_snow_lyr,& + fseng,fseng_soil,fseng_snow,fevpg,fevpg_soil,fevpg_snow,cgrnd,htvp,emg,& imelt,snofrz,sm,xmf,fact,pg_rain,pg_snow,t_precip) !======================================================================= ! [6] Correct fluxes to present soil temperature !======================================================================= - t_grnd = t_soisno(lb) - tinc = t_soisno(lb) - t_soisno_bef(lb) - fseng = fseng + tinc*cgrnds - fevpg = fevpg + tinc*cgrndl + IF (.not.DEF_SPLIT_SOILSNOW) THEN + t_grnd = t_soisno(lb) + tinc = t_soisno(lb) - t_soisno_bef(lb) + ELSE + t_grnd = fsno*t_soisno(lb) + (1.0-fsno)*t_soisno(1) + tinc = t_grnd - t_grnd_bef + ENDIF + + fseng = fseng + tinc*cgrnds + fseng_soil = fseng_soil + tinc*cgrnds + fseng_snow = fseng_snow + tinc*cgrnds + fevpg = fevpg + tinc*cgrndl + fevpg_soil = fevpg_soil + tinc*cgrndl + fevpg_snow = fevpg_snow + tinc*cgrndl ! calculation of evaporative potential; flux in kg m-2 s-1. ! egidif holds the excess energy IF all water is evaporated ! during the timestep. this energy is later added to the sensible heat flux. - egsmax = (wice_soisno(lb)+wliq_soisno(lb)) / deltim - egidif = max( 0., fevpg - egsmax ) - fevpg = min( fevpg, egsmax ) - fseng = fseng + htvp*egidif - -! total fluxes to atmosphere - fsena = fsenl + fseng - fevpa = fevpl + fevpg - lfevpa = hvap*fevpl + htvp*fevpg ! W/m^2 (accouting for sublimation) - qseva = 0. qsubl = 0. qfros = 0. qsdew = 0. + qseva_soil = 0. + qsubl_soil = 0. + qfros_soil = 0. + qsdew_soil = 0. + qseva_snow = 0. + qsubl_snow = 0. + qfros_snow = 0. + qsdew_snow = 0. + + +IF (.not. DEF_SPLIT_SOILSNOW) THEN + egsmax = (wice_soisno(lb)+wliq_soisno(lb)) / deltim + egidif = max( 0., fevpg - egsmax ) + fevpg = min( fevpg, egsmax ) + fseng = fseng + htvp*egidif IF (fevpg >= 0.) THEN ! not allow for sublimation in melting (melting ==> evap. ==> sublimation) @@ -1179,12 +1084,88 @@ SUBROUTINE THERMAL (ipatch ,patchtype ,lb ,deltim ,& ENDIF ENDIF +ELSE + IF (lb < 1) THEN ! snow layer exist + egsmax = (wice_soisno(lb)+wliq_soisno(lb)) / deltim + egidif = max( 0., fevpg_snow - egsmax ) + fevpg_snow = min ( fevpg_snow, egsmax ) + fseng_snow = fseng_snow + htvp*egidif + ELSE ! no snow layer, attribute to soil + fevpg_soil = fevpg_soil*(1.-fsno) + fevpg_snow*fsno + ENDIF + + egsmax = (wice_soisno(1)+wliq_soisno(1)) / deltim + egidif = max( 0., fevpg_soil - egsmax ) + fevpg_soil = min ( fevpg_soil, egsmax ) + fseng_soil = fseng_soil + htvp*egidif + + IF (lb < 1) THEN ! snow layer exist + fseng = fseng_soil*(1.-fsno) + fseng_snow*fsno + fevpg = fevpg_soil*(1.-fsno) + fevpg_snow*fsno + ELSE ! no snow layer, attribute to soil + fseng = fseng_soil; fseng_snow = 0. + fevpg = fevpg_soil; fevpg_snow = 0. + ENDIF + + if(fevpg_snow >= 0.)then +! not allow for sublimation in melting (melting ==> evap. ==> sublimation) + qseva_snow = min(wliq_soisno(lb)/deltim, fevpg_snow) + qsubl_snow = fevpg_snow - qseva_snow + qseva_snow = qseva_snow*fsno + qsubl_snow = qsubl_snow*fsno + else + ! snow temperature < tfrz + if(t_soisno(lb) < tfrz)then + qfros_snow = abs(fevpg_snow*fsno) + else + qsdew_snow = abs(fevpg_snow*fsno) + endif + endif + + if(fevpg_soil >= 0.)then +! not allow for sublimation in melting (melting ==> evap. ==> sublimation) + qseva_soil = min(wliq_soisno(1)/deltim, fevpg_soil) + qsubl_soil = fevpg_soil - qseva_soil + else + ! soil temperature < tfrz + if(t_soisno(1) < tfrz)then + qfros_soil = abs(fevpg_soil) + else + qsdew_soil = abs(fevpg_soil) + endif + endif + + IF (lb < 1) THEN ! snow layer exists + qseva_soil = qseva_soil*(1.-fsno) + qsubl_soil = qsubl_soil*(1.-fsno) + qfros_soil = qfros_soil*(1.-fsno) + qsdew_soil = qsdew_soil*(1.-fsno) + ENDIF +ENDIF + + +! total fluxes to atmosphere + fsena = fsenl + fseng + fevpa = fevpl + fevpg + lfevpa = hvap*fevpl + htvp*fevpg ! W/m^2 (accouting for sublimation) + ! ground heat flux +IF (.not.DEF_SPLIT_SOILSNOW) THEN fgrnd = sabg + dlrad*emg & - emg*stefnc*t_grnd_bef**4 & - emg*stefnc*t_grnd_bef**3*(4.*tinc) & - - (fseng+fevpg*htvp) + cpliq * pg_rain * (t_precip - t_grnd) & - + cpice * pg_snow * (t_precip - t_grnd) + - (fseng+fevpg*htvp) & + + cpliq*pg_rain*(t_precip-t_grnd) & + + cpice*pg_snow*(t_precip-t_grnd) +ELSE + fgrnd = sabg + dlrad*emg & + - fsno*emg*stefnc*t_snow**4 & + - (1.-fsno)*emg*stefnc*t_soil**4 & + - emg*stefnc*t_grnd_bef**3*(4.*tinc) & + - (fseng+fevpg*htvp) & + + cpliq*pg_rain*(t_precip-t_grnd) & + + cpice*pg_snow*(t_precip-t_grnd) +ENDIF ! outgoing long-wave radiation from canopy + ground olrg = ulrad & @@ -1199,7 +1180,8 @@ SUBROUTINE THERMAL (ipatch ,patchtype ,lb ,deltim ,& ! radiative temperature IF (olrg < 0) THEN - print *, "olrg abnormal value: ",ipatch, olrg, tinc, ulrad + print *, "MOD_Thermal.F90: Error! Negative outgoing longwave radiation flux: " + write(6,*) ipatch, olrg, tinc, ulrad write(6,*) ipatch,errore,sabv,sabg,frl,olrg,fsenl,fseng,hvap*fevpl,htvp*fevpg,xmf,fgrnd ENDIF @@ -1216,37 +1198,30 @@ SUBROUTINE THERMAL (ipatch ,patchtype ,lb ,deltim ,& fm = fm_g fh = fh_g fq = fq_g - ELSE - ustar = ustar - tstar = tstar - qstar = qstar - rib = rib - zol = zol - z0m = z0m - fm = fm - fh = fh - fq = fq ENDIF + !======================================================================= ! [7] energy balance error !======================================================================= ! one way to check energy - errore = sabv + sabg + frl - olrg - fsena - lfevpa - fgrnd + errore = sabv + sabg + frl - olrg - fsena - lfevpa - fgrnd + hprl & + + cpliq*pg_rain*(t_precip-t_grnd) + cpice*pg_snow*(t_precip-t_grnd) ! another way to check energy - errore = sabv + sabg + frl - olrg - fsena - lfevpa - xmf + hprl + & - cpliq * pg_rain * (t_precip - t_grnd) + cpice * pg_snow * (t_precip - t_grnd) + errore = sabv + sabg + frl - olrg - fsena - lfevpa - xmf + hprl & + + cpliq*pg_rain*(t_precip-t_grnd) + cpice*pg_snow*(t_precip-t_grnd) DO j = lb, nl_soil errore = errore - (t_soisno(j)-t_soisno_bef(j))/fact(j) ENDDO #if (defined CoLMDEBUG) IF (abs(errore) > .5) THEN - write(6,*) 'THERMAL.F90: energy balance violation' + write(6,*) 'MOD_Thermal.F90: energy balance violation' write(6,*) ipatch,errore,sabv,sabg,frl,olrg,fsenl,fseng,hvap*fevpl,htvp*fevpg,xmf,hprl - STOP + write(6,*) cpliq*pg_rain*(t_precip-t_grnd), cpice*pg_snow*(t_precip-t_grnd) + CALL CoLM_stop () ENDIF 100 format(10(f15.3)) #endif diff --git a/main/MOD_UserSpecifiedForcing.F90 b/main/MOD_UserSpecifiedForcing.F90 index 0661af6a..592a880d 100644 --- a/main/MOD_UserSpecifiedForcing.F90 +++ b/main/MOD_UserSpecifiedForcing.F90 @@ -713,6 +713,7 @@ SUBROUTINE metpreprocess(grid, forcn) if (qsat_tmp < forcn(2)%blk(ib,jb)%val(i,j)) then forcn(2)%blk(ib,jb)%val(i,j) = qsat_tmp endif + if (forcn(2)%blk(ib,jb)%val(i,j)<0.5E-05) forcn(2)%blk(ib,jb)%val(i,j) = 0.5E-05 case ('WFDE5') diff --git a/main/MOD_Vars_1DAccFluxes.F90 b/main/MOD_Vars_1DAccFluxes.F90 index 42db0c34..f2e3c390 100644 --- a/main/MOD_Vars_1DAccFluxes.F90 +++ b/main/MOD_Vars_1DAccFluxes.F90 @@ -39,6 +39,10 @@ module MOD_Vars_1DAccFluxes real(r8), allocatable :: a_rsur (:) real(r8), allocatable :: a_rsub (:) real(r8), allocatable :: a_rnof (:) +#ifdef CatchLateralFlow + real(r8), allocatable :: a_xwsur (:) + real(r8), allocatable :: a_xwsub (:) +#endif real(r8), allocatable :: a_qintr (:) real(r8), allocatable :: a_qinfl (:) real(r8), allocatable :: a_qdrip (:) @@ -46,10 +50,12 @@ module MOD_Vars_1DAccFluxes real(r8), allocatable :: a_rstfacsha (:) real(r8), allocatable :: a_gssun (:) real(r8), allocatable :: a_gssha (:) + real(r8), allocatable :: a_rss (:) real(r8), allocatable :: a_wdsrf (:) real(r8), allocatable :: a_zwt (:) real(r8), allocatable :: a_wa (:) real(r8), allocatable :: a_wat (:) + real(r8), allocatable :: a_wetwat (:) real(r8), allocatable :: a_assim (:) real(r8), allocatable :: a_respc (:) real(r8), allocatable :: a_assimsun (:) !1 @@ -212,6 +218,14 @@ module MOD_Vars_1DAccFluxes real(r8), allocatable :: a_fertnitro_rice1 (:) real(r8), allocatable :: a_fertnitro_rice2 (:) real(r8), allocatable :: a_fertnitro_sugarcane (:) + real(r8), allocatable :: a_irrig_method_corn (:) + real(r8), allocatable :: a_irrig_method_swheat (:) + real(r8), allocatable :: a_irrig_method_wwheat (:) + real(r8), allocatable :: a_irrig_method_soybean (:) + real(r8), allocatable :: a_irrig_method_cotton (:) + real(r8), allocatable :: a_irrig_method_rice1 (:) + real(r8), allocatable :: a_irrig_method_rice2 (:) + real(r8), allocatable :: a_irrig_method_sugarcane (:) real(r8), allocatable :: a_cphase (:) real(r8), allocatable :: a_gddplant (:) real(r8), allocatable :: a_gddmaturity (:) @@ -223,6 +237,11 @@ module MOD_Vars_1DAccFluxes real(r8), allocatable :: a_grainc_to_cropprodc(:) real(r8), allocatable :: a_grainc_to_seed (:) real(r8), allocatable :: a_fert_to_sminn (:) + + real(r8), allocatable :: a_irrig_rate (:) + real(r8), allocatable :: a_deficit_irrig (:) + real(r8), allocatable :: a_sum_irrig (:) + real(r8), allocatable :: a_sum_irrig_count (:) #endif real(r8), allocatable :: a_ndep_to_sminn (:) real(r8), allocatable :: a_abm (:) @@ -312,7 +331,10 @@ subroutine allocate_acc_fluxes use MOD_SPMD_Task USE MOD_LandElm use MOD_LandPatch - USE MOD_LandUrban, only : numurban + USE MOD_LandUrban, only: numurban +#ifdef CROP + USE MOD_LandCrop +#endif USE MOD_Vars_Global implicit none @@ -351,6 +373,10 @@ subroutine allocate_acc_fluxes allocate (a_rsur (numpatch)) allocate (a_rsub (numpatch)) allocate (a_rnof (numpatch)) +#ifdef CatchLateralFlow + allocate (a_xwsur (numpatch)) + allocate (a_xwsub (numpatch)) +#endif allocate (a_qintr (numpatch)) allocate (a_qinfl (numpatch)) allocate (a_qdrip (numpatch)) @@ -358,11 +384,13 @@ subroutine allocate_acc_fluxes allocate (a_rstfacsha (numpatch)) allocate (a_gssun (numpatch)) allocate (a_gssha (numpatch)) + allocate (a_rss (numpatch)) allocate (a_wdsrf (numpatch)) allocate (a_zwt (numpatch)) allocate (a_wa (numpatch)) allocate (a_wat (numpatch)) + allocate (a_wetwat (numpatch)) allocate (a_assim (numpatch)) allocate (a_respc (numpatch)) @@ -527,6 +555,14 @@ subroutine allocate_acc_fluxes allocate (a_fertnitro_rice1 (numpatch)) allocate (a_fertnitro_rice2 (numpatch)) allocate (a_fertnitro_sugarcane(numpatch)) + allocate (a_irrig_method_corn (numpatch)) + allocate (a_irrig_method_swheat (numpatch)) + allocate (a_irrig_method_wwheat (numpatch)) + allocate (a_irrig_method_soybean (numpatch)) + allocate (a_irrig_method_cotton (numpatch)) + allocate (a_irrig_method_rice1 (numpatch)) + allocate (a_irrig_method_rice2 (numpatch)) + allocate (a_irrig_method_sugarcane(numpatch)) allocate (a_cphase (numpatch)) allocate (a_hui (numpatch)) allocate (a_gddmaturity (numpatch)) @@ -538,6 +574,11 @@ subroutine allocate_acc_fluxes allocate (a_grainc_to_cropprodc(numpatch)) allocate (a_grainc_to_seed (numpatch)) allocate (a_fert_to_sminn (numpatch)) + + allocate (a_irrig_rate (numpatch)) + allocate (a_deficit_irrig (numpatch)) + allocate (a_sum_irrig (numpatch)) + allocate (a_sum_irrig_count (numpatch)) #endif allocate (a_ndep_to_sminn (numpatch)) @@ -623,7 +664,7 @@ subroutine allocate_acc_fluxes IF (p_is_worker) THEN #if (defined CROP) - CALL elm_patch%build (landelm, landpatch, use_frac = .true., shadowfrac = pctcrop) + CALL elm_patch%build (landelm, landpatch, use_frac = .true., sharedfrac = pctshrpch) #else CALL elm_patch%build (landelm, landpatch, use_frac = .true.) #endif @@ -673,18 +714,24 @@ subroutine deallocate_acc_fluxes () deallocate (a_rsur ) deallocate (a_rsub ) deallocate (a_rnof ) +#ifdef CatchLateralFlow + deallocate (a_xwsur ) + deallocate (a_xwsub ) +#endif deallocate (a_qintr ) deallocate (a_qinfl ) deallocate (a_qdrip ) deallocate (a_rstfacsun ) deallocate (a_rstfacsha ) - deallocate (a_gssun ) - deallocate (a_gssha ) + deallocate (a_gssun ) + deallocate (a_gssha ) + deallocate (a_rss ) deallocate (a_wdsrf ) deallocate (a_zwt ) deallocate (a_wa ) deallocate (a_wat ) + deallocate (a_wetwat ) deallocate (a_assim ) deallocate (a_respc ) @@ -850,6 +897,14 @@ subroutine deallocate_acc_fluxes () deallocate (a_fertnitro_rice1 ) deallocate (a_fertnitro_rice2 ) deallocate (a_fertnitro_sugarcane) + deallocate (a_irrig_method_corn ) + deallocate (a_irrig_method_swheat ) + deallocate (a_irrig_method_wwheat ) + deallocate (a_irrig_method_soybean ) + deallocate (a_irrig_method_cotton ) + deallocate (a_irrig_method_rice1 ) + deallocate (a_irrig_method_rice2 ) + deallocate (a_irrig_method_sugarcane) deallocate (a_cphase ) deallocate (a_hui ) deallocate (a_vf ) @@ -861,6 +916,11 @@ subroutine deallocate_acc_fluxes () deallocate (a_grainc_to_cropprodc) deallocate (a_grainc_to_seed ) deallocate (a_fert_to_sminn ) + + deallocate (a_irrig_rate ) + deallocate (a_deficit_irrig ) + deallocate (a_sum_irrig ) + deallocate (a_sum_irrig_count ) #endif deallocate (a_ndep_to_sminn ) @@ -994,6 +1054,10 @@ SUBROUTINE FLUSH_acc_fluxes () a_rsur (:) = spval a_rsub (:) = spval a_rnof (:) = spval +#ifdef CatchLateralFlow + a_xwsur (:) = spval + a_xwsub (:) = spval +#endif a_qintr (:) = spval a_qinfl (:) = spval a_qdrip (:) = spval @@ -1001,11 +1065,13 @@ SUBROUTINE FLUSH_acc_fluxes () a_rstfacsha(:) = spval a_gssun (:) = spval a_gssha (:) = spval + a_rss (:) = spval a_wdsrf (:) = spval a_zwt (:) = spval a_wa (:) = spval a_wat (:) = spval + a_wetwat (:) = spval a_assim (:) = spval a_respc (:) = spval a_assimsun(:) = spval !1 @@ -1170,6 +1236,14 @@ SUBROUTINE FLUSH_acc_fluxes () a_fertnitro_rice1 (:) = spval a_fertnitro_rice2 (:) = spval a_fertnitro_sugarcane(:) = spval + a_irrig_method_corn (:) = spval + a_irrig_method_swheat (:) = spval + a_irrig_method_wwheat (:) = spval + a_irrig_method_soybean (:) = spval + a_irrig_method_cotton (:) = spval + a_irrig_method_rice1 (:) = spval + a_irrig_method_rice2 (:) = spval + a_irrig_method_sugarcane(:) = spval a_cphase (:) = spval a_vf (:) = spval a_gddmaturity (:) = spval @@ -1181,6 +1255,10 @@ SUBROUTINE FLUSH_acc_fluxes () a_grainc_to_cropprodc(:) = spval a_grainc_to_seed (:) = spval a_fert_to_sminn (:) = spval + a_irrig_rate (:) = spval + a_deficit_irrig (:) = spval + a_sum_irrig (:) = spval + a_sum_irrig_count (:) = spval #endif a_ndep_to_sminn (:) = spval @@ -1273,12 +1351,12 @@ SUBROUTINE accumulate_fluxes use MOD_Precision use MOD_SPMD_Task - USE mod_forcing, only : forcmask - USE MOD_Mesh, only : numelm + USE mod_forcing, only: forcmask + USE MOD_Mesh, only: numelm USE MOD_LandElm - use MOD_LandPatch, only : numpatch, elm_patch - USE MOD_LandUrban, only : numurban - use MOD_Const_Physical, only : vonkar, stefnc, cpair, rgas, grav + use MOD_LandPatch, only: numpatch, elm_patch + USE MOD_LandUrban, only: numurban + use MOD_Const_Physical, only: vonkar, stefnc, cpair, rgas, grav use MOD_Vars_TimeInvariants use MOD_Vars_TimeVariables use MOD_Vars_1DForcing @@ -1287,8 +1365,9 @@ SUBROUTINE accumulate_fluxes USE MOD_Namelist, only: DEF_USE_CBL_HEIGHT, DEF_USE_OZONESTRESS, DEF_USE_PLANTHYDRAULICS, DEF_USE_NITRIF USE MOD_TurbulenceLEddy use MOD_Vars_Global -#ifdef LATERAL_FLOW - USE MOD_Hydro_Hist, only : accumulate_fluxes_basin +#ifdef CatchLateralFlow + USE MOD_Hydro_Vars_1DFluxes + USE MOD_Hydro_Hist, only: accumulate_fluxes_basin #endif IMPLICIT NONE @@ -1296,7 +1375,6 @@ SUBROUTINE accumulate_fluxes ! Local Variables real(r8), allocatable :: r_trad (:) - real(r8), allocatable :: r_ustar (:) real(r8), allocatable :: r_ustar2(:) !define a temporary for estimating us10m only, output should be r_ustar. Shaofeng, 2023.05.20 real(r8), allocatable :: r_tstar (:) @@ -1311,7 +1389,7 @@ SUBROUTINE accumulate_fluxes real(r8), allocatable :: r_vs10m (:) real(r8), allocatable :: r_fm10m (:) - logical, allocatable :: patchmask (:) + logical, allocatable :: filter (:) !--------------------------------------------------------------------- integer ib, jb, i, j, ielm, istt, iend @@ -1367,63 +1445,80 @@ SUBROUTINE accumulate_fluxes rnet = sabg + sabvsun + sabvsha - olrg + forc_frl END WHERE ELSE - rnet = sabg + sabvsun + sabvsha - olrg + forc_frl + WHERE(patchmask) + rnet = sabg + sabvsun + sabvsha - olrg + forc_frl + END WHERE ENDIF call acc1d (rnet , a_rnet ) call acc1d (xerr , a_xerr ) call acc1d (zerr , a_zerr ) call acc1d (rsur , a_rsur ) +#ifndef CatchLateralFlow + WHERE ((rsur /= spval) .and. (rnof /= spval)) + rsub = rnof - rsur + ELSEWHERE + rsub = spval + END WHERE +#endif call acc1d (rsub , a_rsub ) call acc1d (rnof , a_rnof ) +#ifdef CatchLateralFlow + CALL acc1d (xwsur , a_xwsur ) + CALL acc1d (xwsub , a_xwsub ) +#endif call acc1d (qintr , a_qintr ) call acc1d (qinfl , a_qinfl ) call acc1d (qdrip , a_qdrip ) call acc1d (rstfacsun_out , a_rstfacsun ) call acc1d (rstfacsha_out , a_rstfacsha ) - call acc1d (gssun_out , a_gssun ) - call acc1d (gssha_out , a_gssha ) - - call acc1d (wdsrf , a_wdsrf ) - call acc1d (zwt , a_zwt ) - call acc1d (wa , a_wa ) - call acc1d (wat , a_wat ) - call acc1d (assim , a_assim ) - call acc1d (respc , a_respc ) - - call acc1d (assimsun_out , a_assimsun ) - call acc1d (assimsha_out , a_assimsha ) - call acc1d (etrsun_out , a_etrsun ) - call acc1d (etrsha_out , a_etrsha ) - - call acc1d (qcharge , a_qcharge ) - - call acc1d (t_grnd , a_t_grnd ) - call acc1d (tleaf , a_tleaf ) - call acc1d (ldew_rain , a_ldew_rain ) - call acc1d (ldew_snow , a_ldew_snow ) - call acc1d (ldew , a_ldew ) - call acc1d (scv , a_scv ) - call acc1d (snowdp , a_snowdp ) - call acc1d (fsno , a_fsno ) - call acc1d (sigf , a_sigf ) - call acc1d (green , a_green ) - call acc1d (lai , a_lai ) - call acc1d (laisun , a_laisun ) - call acc1d (laisha , a_laisha ) - call acc1d (sai , a_sai ) - - call acc3d (alb , a_alb ) - - call acc1d (emis , a_emis ) - call acc1d (z0m , a_z0m ) - - allocate (r_trad (numpatch)) + + call acc1d (gssun_out , a_gssun ) + call acc1d (gssha_out , a_gssha ) + + call acc1d (rss , a_rss ) + call acc1d (wdsrf , a_wdsrf ) + call acc1d (zwt , a_zwt ) + call acc1d (wa , a_wa ) + call acc1d (wat , a_wat ) + call acc1d (wetwat , a_wetwat ) + call acc1d (assim , a_assim ) + call acc1d (respc , a_respc ) + call acc1d (assimsun_out , a_assimsun ) + call acc1d (assimsha_out , a_assimsha ) + call acc1d (etrsun_out , a_etrsun ) + call acc1d (etrsha_out , a_etrsha ) + + call acc1d (qcharge, a_qcharge) + + call acc1d (t_grnd , a_t_grnd ) + call acc1d (tleaf , a_tleaf ) + call acc1d (ldew_rain, a_ldew_rain) + call acc1d (ldew_snow, a_ldew_snow) + call acc1d (ldew , a_ldew ) + call acc1d (scv , a_scv ) + call acc1d (snowdp , a_snowdp ) + call acc1d (fsno , a_fsno ) + call acc1d (sigf , a_sigf ) + call acc1d (green , a_green ) + call acc1d (lai , a_lai ) + call acc1d (laisun , a_laisun ) + call acc1d (laisha , a_laisha ) + call acc1d (sai , a_sai ) + + call acc3d (alb , a_alb ) + + call acc1d (emis , a_emis ) + call acc1d (z0m , a_z0m ) + + allocate (r_trad (numpatch)) ; r_trad(:) = spval do i = 1, numpatch IF (DEF_forcing%has_missing_value) THEN IF (.not. forcmask(i)) cycle ENDIF + + IF (.not. patchmask(i)) CYCLE r_trad(i) = (olrg(i)/stefnc)**0.25 end do call acc1d (r_trad , a_trad ) @@ -1566,6 +1661,14 @@ SUBROUTINE accumulate_fluxes call acc1d (fertnitro_rice1 , a_fertnitro_rice1 ) call acc1d (fertnitro_rice2 , a_fertnitro_rice2 ) call acc1d (fertnitro_sugarcane, a_fertnitro_sugarcane) + call acc1d (real(irrig_method_corn ,r8), a_irrig_method_corn ) + call acc1d (real(irrig_method_swheat ,r8), a_irrig_method_swheat ) + call acc1d (real(irrig_method_wwheat ,r8), a_irrig_method_wwheat ) + call acc1d (real(irrig_method_soybean ,r8), a_irrig_method_soybean ) + call acc1d (real(irrig_method_cotton ,r8), a_irrig_method_cotton ) + call acc1d (real(irrig_method_rice1 ,r8), a_irrig_method_rice1 ) + call acc1d (real(irrig_method_rice2 ,r8), a_irrig_method_rice2 ) + call acc1d (real(irrig_method_sugarcane,r8), a_irrig_method_sugarcane) call acc1d (cphase , a_cphase ) call acc1d (hui , a_hui ) call acc1d (vf , a_vf ) @@ -1577,6 +1680,16 @@ SUBROUTINE accumulate_fluxes call acc1d (grainc_to_cropprodc, a_grainc_to_cropprodc) call acc1d (grainc_to_seed , a_grainc_to_seed ) call acc1d (fert_to_sminn , a_fert_to_sminn ) + + ! call acc1d (irrig_rate , a_irrig_rate ) + ! call acc1d (deficit_irrig , a_deficit_irrig ) + ! call acc1d (sum_irrig , a_sum_irrig ) + ! call acc1d (sum_irrig_count , a_sum_irrig_count ) + call acc1d (irrig_rate , a_irrig_rate ) + call acc1d (deficit_irrig , a_deficit_irrig ) + a_sum_irrig = sum_irrig + a_sum_irrig_count = sum_irrig_count + #endif call acc1d (ndep_to_sminn , a_ndep_to_sminn ) if(DEF_USE_FIRE)then @@ -1710,36 +1823,39 @@ SUBROUTINE accumulate_fluxes istt = elm_patch%substt(ielm) iend = elm_patch%subend(ielm) - allocate (patchmask (istt:iend)) - patchmask(:) = .true. + allocate (filter (istt:iend)) + filter(:) = .true. + + filter(:) = patchmask(istt:iend) IF (DEF_forcing%has_missing_value) THEN - patchmask = forcmask(istt:iend) + WHERE (.not. forcmask(istt:iend)) filter = .false. + filter = filter .and. forcmask(istt:iend) ENDIF - IF (.not. any(patchmask)) THEN - deallocate(patchmask) + IF (.not. any(filter)) THEN + deallocate(filter) CYCLE ENDIF - sumwt = sum(elm_patch%subfrc(istt:iend), mask = patchmask) + sumwt = sum(elm_patch%subfrc(istt:iend), mask = filter) ! Aggregate variables from patches to element (gridcell in latitude-longitude mesh) - z0m_av = sum(z0m (istt:iend) * elm_patch%subfrc(istt:iend), mask = patchmask) / sumwt - hgt_u = sum(forc_hgt_u (istt:iend) * elm_patch%subfrc(istt:iend), mask = patchmask) / sumwt - hgt_t = sum(forc_hgt_t (istt:iend) * elm_patch%subfrc(istt:iend), mask = patchmask) / sumwt - hgt_q = sum(forc_hgt_q (istt:iend) * elm_patch%subfrc(istt:iend), mask = patchmask) / sumwt - us = sum(forc_us (istt:iend) * elm_patch%subfrc(istt:iend), mask = patchmask) / sumwt - vs = sum(forc_vs (istt:iend) * elm_patch%subfrc(istt:iend), mask = patchmask) / sumwt - tm = sum(forc_t (istt:iend) * elm_patch%subfrc(istt:iend), mask = patchmask) / sumwt - qm = sum(forc_q (istt:iend) * elm_patch%subfrc(istt:iend), mask = patchmask) / sumwt - psrf = sum(forc_psrf (istt:iend) * elm_patch%subfrc(istt:iend), mask = patchmask) / sumwt - taux_e = sum(taux (istt:iend) * elm_patch%subfrc(istt:iend), mask = patchmask) / sumwt - tauy_e = sum(tauy (istt:iend) * elm_patch%subfrc(istt:iend), mask = patchmask) / sumwt - fsena_e = sum(fsena (istt:iend) * elm_patch%subfrc(istt:iend), mask = patchmask) / sumwt - fevpa_e = sum(fevpa (istt:iend) * elm_patch%subfrc(istt:iend), mask = patchmask) / sumwt + z0m_av = sum(z0m (istt:iend) * elm_patch%subfrc(istt:iend), mask = filter) / sumwt + hgt_u = sum(forc_hgt_u (istt:iend) * elm_patch%subfrc(istt:iend), mask = filter) / sumwt + hgt_t = sum(forc_hgt_t (istt:iend) * elm_patch%subfrc(istt:iend), mask = filter) / sumwt + hgt_q = sum(forc_hgt_q (istt:iend) * elm_patch%subfrc(istt:iend), mask = filter) / sumwt + us = sum(forc_us (istt:iend) * elm_patch%subfrc(istt:iend), mask = filter) / sumwt + vs = sum(forc_vs (istt:iend) * elm_patch%subfrc(istt:iend), mask = filter) / sumwt + tm = sum(forc_t (istt:iend) * elm_patch%subfrc(istt:iend), mask = filter) / sumwt + qm = sum(forc_q (istt:iend) * elm_patch%subfrc(istt:iend), mask = filter) / sumwt + psrf = sum(forc_psrf (istt:iend) * elm_patch%subfrc(istt:iend), mask = filter) / sumwt + taux_e = sum(taux (istt:iend) * elm_patch%subfrc(istt:iend), mask = filter) / sumwt + tauy_e = sum(tauy (istt:iend) * elm_patch%subfrc(istt:iend), mask = filter) / sumwt + fsena_e = sum(fsena (istt:iend) * elm_patch%subfrc(istt:iend), mask = filter) / sumwt + fevpa_e = sum(fevpa (istt:iend) * elm_patch%subfrc(istt:iend), mask = filter) / sumwt if (DEF_USE_CBL_HEIGHT) then !//TODO: Shaofeng, 2023.05.18 - hpbl = sum(forc_hpbl(istt:iend) * elm_patch%subfrc(istt:iend), mask = patchmask) / sumwt + hpbl = sum(forc_hpbl(istt:iend) * elm_patch%subfrc(istt:iend), mask = filter) / sumwt ENDIF z0h_av = z0m_av @@ -1819,7 +1935,7 @@ SUBROUTINE accumulate_fluxes r_vs10m (istt:iend) = r_vs10m_e r_fm10m (istt:iend) = r_fm10m_e - deallocate(patchmask) + deallocate(filter) end do @@ -1878,7 +1994,7 @@ SUBROUTINE accumulate_fluxes end if end if -#ifdef LATERAL_FLOW +#ifdef CatchLateralFlow CALL accumulate_fluxes_basin () #endif diff --git a/main/MOD_Vars_1DFluxes.F90 b/main/MOD_Vars_1DFluxes.F90 index 4d98a54e..e1b0a127 100644 --- a/main/MOD_Vars_1DFluxes.F90 +++ b/main/MOD_Vars_1DFluxes.F90 @@ -6,16 +6,13 @@ MODULE MOD_Vars_1DFluxes ! ------------------------------- USE MOD_Precision -#ifdef LULC_IGBP_PFT +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) USE MOD_Vars_1DPFTFluxes #endif -#ifdef LULC_IGBP_PC - USE MOD_Vars_1DPCFluxes -#endif #ifdef BGC USE MOD_BGC_Vars_1DFluxes #endif -#ifdef LATERAL_FLOW +#ifdef CatchLateralFlow USE MOD_Hydro_Vars_1DFluxes #endif #ifdef URBAN_MODEL @@ -62,7 +59,6 @@ MODULE MOD_Vars_1DFluxes REAL(r8), allocatable :: rnet (:) !net radiation by surface [W/m2] REAL(r8), allocatable :: xerr (:) !the error of water banace [mm/s] REAL(r8), allocatable :: zerr (:) !the error of energy balance [W/m2] - REAL(r8), allocatable :: rsur (:) !surface runoff (mm h2o/s) REAL(r8), allocatable :: rsub (:) !subsurface runoff (mm h2o/s) REAL(r8), allocatable :: rnof (:) !total runoff (mm h2o/s) @@ -154,19 +150,15 @@ SUBROUTINE allocate_1D_Fluxes end if end if -#ifdef LULC_IGBP_PFT +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) CALL allocate_1D_PFTFluxes #endif -#ifdef LULC_IGBP_PC - CALL allocate_1D_PCFluxes -#endif - #ifdef BGC CALL allocate_1D_BGCFluxes #endif -#ifdef LATERAL_FLOW +#ifdef CatchLateralFlow CALL allocate_1D_HydroFluxes #endif @@ -222,7 +214,6 @@ SUBROUTINE deallocate_1D_Fluxes () deallocate ( rnet ) ! net radiation by surface [W/m2] deallocate ( xerr ) ! the error of water banace [mm/s] deallocate ( zerr ) ! the error of energy balance [W/m2] - deallocate ( rsur ) ! surface runoff (mm h2o/s) deallocate ( rsub ) ! subsurface runoff (mm h2o/s) deallocate ( rnof ) ! total runoff (mm h2o/s) @@ -239,19 +230,15 @@ SUBROUTINE deallocate_1D_Fluxes () end if end if -#ifdef LULC_IGBP_PFT +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) CALL deallocate_1D_PFTFluxes #endif -#ifdef LULC_IGBP_PC - CALL deallocate_1D_PCFluxes -#endif - #ifdef BGC CALL deallocate_1D_BGCFluxes #endif -#ifdef LATERAL_FLOW +#ifdef CatchLateralFlow CALL deallocate_1D_HydroFluxes #endif diff --git a/main/MOD_Vars_1DPCFluxes.F90 b/main/MOD_Vars_1DPCFluxes.F90 deleted file mode 100644 index 914c57fe..00000000 --- a/main/MOD_Vars_1DPCFluxes.F90 +++ /dev/null @@ -1,151 +0,0 @@ -#include - -#ifdef LULC_IGBP_PC - -MODULE MOD_Vars_1DPCFluxes -! ----------------------------------------------------------------- -! !DESCRIPTION: -! Define Plant Community flux variables -! -! Created by Hua Yuan, 08/2019 -! ----------------------------------------------------------------- - - USE MOD_Precision - IMPLICIT NONE - SAVE - -! ----------------------------------------------------------------- -! Fluxes -! ----------------------------------------------------------------- - REAL(r8), allocatable :: fsenl_c (:,:) !sensible heat from leaves [W/m2] - REAL(r8), allocatable :: fevpl_c (:,:) !evaporation+transpiration from leaves [mm/s] - REAL(r8), allocatable :: etr_c (:,:) !transpiration rate [mm/s] - REAL(r8), allocatable :: fseng_c (:,:) !sensible heat flux from ground [W/m2] - REAL(r8), allocatable :: fevpg_c (:,:) !evaporation heat flux from ground [mm/s] - REAL(r8), allocatable :: parsun_c (:,:) !solar absorbed by sunlit vegetation [W/m2] - REAL(r8), allocatable :: parsha_c (:,:) !solar absorbed by shaded vegetation [W/m2] - REAL(r8), allocatable :: sabvsun_c (:,:) !solar absorbed by sunlit vegetation [W/m2] - REAL(r8), allocatable :: sabvsha_c (:,:) !solar absorbed by shaded vegetation [W/m2] - REAL(r8), allocatable :: qintr_c (:,:) !interception (mm h2o/s) - REAL(r8), allocatable :: qintr_rain_c(:,:)!rainfall interception (mm h2o/s) - REAL(r8), allocatable :: qintr_snow_c(:,:)!snowfall interception (mm h2o/s) - REAL(r8), allocatable :: assim_c (:,:) !canopy assimilation rate (mol m-2 s-1) - REAL(r8), allocatable :: respc_c (:,:) !canopy respiration (mol m-2 s-1) - -! PUBLIC MEMBER FUNCTIONS: - PUBLIC :: allocate_1D_PCFluxes - PUBLIC :: deallocate_1D_PCFluxes - PUBLIC :: set_1D_PCFluxes - -! PRIVATE MEMBER FUNCTIONS: - -!----------------------------------------------------------------------- - - CONTAINS - -!----------------------------------------------------------------------- - - SUBROUTINE allocate_1D_PCFluxes - ! -------------------------------------------------------------------- - ! Allocates memory for CoLM 1d [numpc] variables - ! -------------------------------------------------------------------- - - USE MOD_SPMD_Task - USE MOD_LandPC - USE MOD_Precision - USE MOD_Vars_Global - IMPLICIT NONE - - IF (p_is_worker) THEN - IF (numpc > 0) THEN - - allocate (fsenl_c (0:N_PFT-1,numpc)) ; fsenl_c (:,:) = spval ! sensible heat from leaves [W/m2] - allocate (fevpl_c (0:N_PFT-1,numpc)) ; fevpl_c (:,:) = spval ! evaporation+transpiration from leaves [mm/s] - allocate (etr_c (0:N_PFT-1,numpc)) ; etr_c (:,:) = spval ! transpiration rate [mm/s] - allocate (fseng_c (0:N_PFT-1,numpc)) ; fseng_c (:,:) = spval ! sensible heat flux from ground [W/m2] - allocate (fevpg_c (0:N_PFT-1,numpc)) ; fevpg_c (:,:) = spval ! evaporation heat flux from ground [mm/s] - allocate (parsun_c (0:N_PFT-1,numpc)) ; parsun_c (:,:) = spval ! solar absorbed by sunlit vegetation [W/m2] - allocate (parsha_c (0:N_PFT-1,numpc)) ; parsha_c (:,:) = spval ! solar absorbed by shaded vegetation [W/m2] - allocate (sabvsun_c (0:N_PFT-1,numpc)) ; sabvsun_c (:,:) = spval ! solar absorbed by sunlit vegetation [W/m2] - allocate (sabvsha_c (0:N_PFT-1,numpc)) ; sabvsha_c (:,:) = spval ! solar absorbed by shaded vegetation [W/m2] - allocate (qintr_c (0:N_PFT-1,numpc)) ; qintr_c (:,:) = spval ! interception (mm h2o/s) - allocate (qintr_rain_c(0:N_PFT-1,numpc)) ; qintr_rain_c(:,:) = spval ! rainfall interception (mm h2o/s) - allocate (qintr_snow_c(0:N_PFT-1,numpc)) ; qintr_snow_c(:,:) = spval ! snowfall interception (mm h2o/s) - allocate (assim_c (0:N_PFT-1,numpc)) ; assim_c (:,:) = spval ! canopy assimilation rate (mol m-2 s-1) - allocate (respc_c (0:N_PFT-1,numpc)) ; respc_c (:,:) = spval ! canopy respiration (mol m-2 s-1) - - ENDIF - ENDIF - - END SUBROUTINE allocate_1D_PCFluxes - - SUBROUTINE deallocate_1D_PCFluxes - ! -------------------------------------------------------------------- - ! deallocates memory for CoLM 1d [numpc] variables - ! -------------------------------------------------------------------- - USE MOD_SPMD_Task - USE MOD_LandPC - - IF (p_is_worker) THEN - IF (numpc > 0) THEN - - deallocate (fsenl_c ) - deallocate (fevpl_c ) - deallocate (etr_c ) - deallocate (fseng_c ) - deallocate (fevpg_c ) - deallocate (parsun_c ) - deallocate (parsha_c ) - deallocate (sabvsun_c ) - deallocate (sabvsha_c ) - deallocate (qintr_c ) - deallocate (qintr_rain_c) - deallocate (qintr_snow_c) - deallocate (assim_c ) - deallocate (respc_c ) - - ENDIF - ENDIF - - END SUBROUTINE deallocate_1D_PCFluxes - - SUBROUTINE set_1D_PCFluxes (Values, Nan) - ! -------------------------------------------------------------------- - ! Allocates memory for CoLM 1d [numpc] variables - ! -------------------------------------------------------------------- - - USE MOD_SPMD_Task - USE MOD_LandPC - USE MOD_Precision - USE MOD_Vars_Global - IMPLICIT NONE - REAL(r8),intent(in) :: Values - REAL(r8),intent(in) :: Nan - - IF (p_is_worker) THEN - IF (numpc > 0) THEN - - fsenl_c (:,:) = Values ! sensible heat from leaves [W/m2] - fevpl_c (:,:) = Values ! evaporation+transpiration from leaves [mm/s] - etr_c (:,:) = Values ! transpiration rate [mm/s] - fseng_c (:,:) = Values ! sensible heat flux from ground [W/m2] - fevpg_c (:,:) = Values ! evaporation heat flux from ground [mm/s] - parsun_c (:,:) = Values ! solar absorbed by sunlit vegetation [W/m2] - parsha_c (:,:) = Values ! solar absorbed by shaded vegetation [W/m2] - sabvsun_c (:,:) = Values ! solar absorbed by sunlit vegetation [W/m2] - sabvsha_c (:,:) = Values ! solar absorbed by shaded vegetation [W/m2] - qintr_c (:,:) = Values ! interception (mm h2o/s) - qintr_rain_c(:,:) = Values ! rainfall interception (mm h2o/s) - qintr_snow_c(:,:) = Values ! snowfall interception (mm h2o/s) - assim_c (:,:) = Values ! canopy assimilation rate (mol m-2 s-1) - respc_c (:,:) = Values ! canopy respiration (mol m-2 s-1) - - ENDIF - ENDIF - - END SUBROUTINE set_1D_PCFluxes - -END MODULE MOD_Vars_1DPCFluxes - -#endif -! ---------- EOP ------------ diff --git a/main/MOD_Vars_1DPFTFluxes.F90 b/main/MOD_Vars_1DPFTFluxes.F90 index a85e5ef4..8103226b 100644 --- a/main/MOD_Vars_1DPFTFluxes.F90 +++ b/main/MOD_Vars_1DPFTFluxes.F90 @@ -1,6 +1,6 @@ #include -#ifdef LULC_IGBP_PFT +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) MODULE MOD_Vars_1DPFTFluxes ! ----------------------------------------------------------------- diff --git a/main/MOD_Vars_Global.F90 b/main/MOD_Vars_Global.F90 index 4668f2a2..ff87a861 100644 --- a/main/MOD_Vars_Global.F90 +++ b/main/MOD_Vars_Global.F90 @@ -12,6 +12,7 @@ MODULE MOD_Vars_Global ! ! !USES: USE MOD_Precision + USE MOD_Namelist IMPLICIT NONE SAVE @@ -41,11 +42,8 @@ MODULE MOD_Vars_Global integer, parameter :: N_CFT = 64 #endif -#ifdef URBAN_LCZ - integer, parameter :: N_URB = 10 -#else - integer, parameter :: N_URB = 3 -#endif + ! urban type number + integer :: N_URB ! vertical layer number integer, parameter :: maxsnl = -5 @@ -94,15 +92,21 @@ MODULE MOD_Vars_Global integer, parameter :: ntrp_soybean = 77 ! tropical soybean integer, parameter :: nirrig_trp_soybean = 78 ! irrigated tropical soybean - real(r8) :: z_soi (1:nl_soil) !node depth [m] - real(r8) :: z_soih(1:nl_soil) !interface level below a zsoi level [m] - real(r8) :: zi_soi(1:nl_soil) !interface level below a zsoi level [m] - real(r8) :: dz_soi(1:nl_soil) !soil node thickness [m] + real(r8) :: z_soi (1:nl_soil) ! node depth [m] + real(r8) :: dz_soi(1:nl_soil) ! soil node thickness [m] + real(r8) :: zi_soi(1:nl_soil) ! interface level below a zsoi level [m] + + real(r8), parameter :: spval = -1.e36_r8 ! missing value + integer , parameter :: spval_i4 = -9999 ! missing value + real(r8), parameter :: PI = 4*atan(1.) ! pi value + real(r8), parameter :: deg2rad = 1.745329251994330e-2_r8 ! degree to radius - real(r8), parameter :: spval = -1.e36_r8 !missing value - integer , parameter :: spval_i4= -9999 !missing value - real(r8), parameter :: PI = 4*atan(1.) !pi value - real(r8), parameter :: deg2rad = 1.745329251994330e-2_r8 + integer , parameter :: irrig_start_time = 21600 ! local time of irrigation start + real(r8), parameter :: irrig_max_depth = 1._r8 ! max irrigation depth + real(r8), parameter :: irrig_threshold_fraction = 1._r8 ! irrigation thershold + real(r8), parameter :: irrig_min_cphase = 1._r8 ! crop phenology when begin irrigation + real(r8), parameter :: irrig_max_cphase = 4._r8 ! crop phenology when end irrigation + integer , parameter :: irrig_time_per_day = 14400 ! irrigation last time ! PUBLIC MEMBER FUNCTIONS: PUBLIC :: Init_GlobalVars @@ -115,27 +119,31 @@ SUBROUTINE Init_GlobalVars integer :: nsl + ! node depths of each soil layer DO nsl = 1, nl_soil - z_soi(nsl) = 0.025*(exp(0.5*(nsl-0.5))-1.) !node depths + z_soi(nsl) = 0.025*(exp(0.5*(nsl-0.5))-1.) ENDDO - dz_soi(1) = 0.5*(z_soi(1)+z_soi(2)) !=zsoih(1) + ! thickness between two soil layer interfaces + dz_soi(1) = 0.5*(z_soi(1)+z_soi(2)) !=zi_soi(1) dz_soi(nl_soil) = z_soi(nl_soil)-z_soi(nl_soil-1) DO nsl = 2, nl_soil-1 - ! thickness between two interfaces dz_soi(nsl) = 0.5*(z_soi(nsl+1)-z_soi(nsl-1)) ENDDO - z_soih(nl_soil) = z_soi(nl_soil) + 0.5*dz_soi(nl_soil) - DO nsl = 1, nl_soil-1 - z_soih(nsl) = 0.5*(z_soi(nsl)+z_soi(nsl+1)) !interface depths - ENDDO - + ! interface depths of soil layers zi_soi(1) = dz_soi(1) DO nsl = 2, nl_soil zi_soi(nsl) = zi_soi(nsl-1) + dz_soi(nsl) ENDDO + ! set urban class number + IF (DEF_URBAN_type_scheme == 1) THEN + N_URB = 3 + ELSE IF(DEF_URBAN_type_scheme == 2) THEN + N_URB = 10 + ENDIF + ! ndecomp_pools_vr = ndecomp_pools * nl_soil END SUBROUTINE Init_GlobalVars diff --git a/main/MOD_Vars_TimeInvariants.F90 b/main/MOD_Vars_TimeInvariants.F90 index e3fee5b1..bd57f8dd 100644 --- a/main/MOD_Vars_TimeInvariants.F90 +++ b/main/MOD_Vars_TimeInvariants.F90 @@ -4,7 +4,7 @@ ! Created by Yongjiu Dai, 03/2014 ! ------------------------------- -#ifdef LULC_IGBP_PFT +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) MODULE MOD_Vars_PFTimeInvariants ! ----------------------------------------------------------------- ! !DESCRIPTION: @@ -18,7 +18,7 @@ MODULE MOD_Vars_PFTimeInvariants IMPLICIT NONE SAVE - ! for LULC_IGBP_PFT + ! for LULC_IGBP_PFT and LULC_IGBP_PC INTEGER , allocatable :: pftclass (:) !PFT type REAL(r8), allocatable :: pftfrac (:) !PFT fractional cover REAL(r8), allocatable :: htop_p (:) !canopy top height [m] @@ -29,7 +29,7 @@ MODULE MOD_Vars_PFTimeInvariants PUBLIC :: READ_PFTimeInvariants PUBLIC :: WRITE_PFTimeInvariants PUBLIC :: deallocate_PFTimeInvariants -#ifdef RangeCheck +#ifdef RangeCheck PUBLIC :: check_PFTimeInvariants #endif @@ -66,6 +66,10 @@ SUBROUTINE READ_PFTimeInvariants (file_restart) use MOD_NetCDFVector USE MOD_LandPFT +#ifdef CROP + USE MOD_LandCrop, only : pctshrpch + USE MOD_LandPatch, only : landpatch +#endif IMPLICIT NONE character(LEN=*), intent(in) :: file_restart @@ -74,6 +78,9 @@ SUBROUTINE READ_PFTimeInvariants (file_restart) call ncio_read_vector (file_restart, 'pftfrac ', landpft, pftfrac ) ! call ncio_read_vector (file_restart, 'htop_p ', landpft, htop_p ) ! call ncio_read_vector (file_restart, 'hbot_p ', landpft, hbot_p ) ! +#ifdef CROP + call ncio_read_vector (file_restart, 'pct_crops', landpatch, pctshrpch) ! +#endif end subroutine READ_PFTimeInvariants @@ -83,6 +90,10 @@ SUBROUTINE WRITE_PFTimeInvariants (file_restart) use MOD_LandPFT USE MOD_Namelist USE MOD_Vars_Global +#ifdef CROP + USE MOD_LandCrop, only : pctshrpch + USE MOD_LandPatch, only : landpatch +#endif IMPLICIT NONE ! Local variables @@ -99,6 +110,11 @@ SUBROUTINE WRITE_PFTimeInvariants (file_restart) call ncio_write_vector (file_restart, 'htop_p ', 'pft', landpft, htop_p , compress) ! call ncio_write_vector (file_restart, 'hbot_p ', 'pft', landpft, hbot_p , compress) ! +#ifdef CROP + CALL ncio_define_dimension_vector (file_restart, landpatch, 'patch') + call ncio_write_vector (file_restart, 'pct_crops', 'patch', landpatch, pctshrpch, compress) ! +#endif + end subroutine WRITE_PFTimeInvariants SUBROUTINE deallocate_PFTimeInvariants @@ -107,6 +123,9 @@ SUBROUTINE deallocate_PFTimeInvariants ! -------------------------------------------------- USE MOD_SPMD_Task USE MOD_LandPFT +#ifdef CROP + USE MOD_LandCrop, only : pctshrpch +#endif IF (p_is_worker) THEN IF (numpft > 0) THEN @@ -115,19 +134,28 @@ SUBROUTINE deallocate_PFTimeInvariants deallocate (htop_p ) deallocate (hbot_p ) ENDIF +#ifdef CROP + IF (allocated(pctshrpch)) deallocate(pctshrpch) +#endif ENDIF END SUBROUTINE deallocate_PFTimeInvariants -#ifdef RangeCheck +#ifdef RangeCheck SUBROUTINE check_PFTimeInvariants () use MOD_RangeCheck +#ifdef CROP + USE MOD_LandCrop, only : pctshrpch +#endif IMPLICIT NONE call check_vector_data ('pftfrac', pftfrac) ! call check_vector_data ('htop_p ', htop_p ) ! call check_vector_data ('hbot_p ', hbot_p ) ! +#ifdef CROP + call check_vector_data ('pct crop', pctshrpch) ! +#endif end subroutine check_PFTimeInvariants #endif @@ -135,153 +163,15 @@ end subroutine check_PFTimeInvariants END MODULE MOD_Vars_PFTimeInvariants #endif - - -#ifdef LULC_IGBP_PC -MODULE MOD_Vars_PCTimeInvariants -! ----------------------------------------------------------------- -! !DESCRIPTION: -! Define Plant Community time invariables -! -! Added by Hua Yuan, 08/2019 -! ----------------------------------------------------------------- - - USE MOD_Precision - USE MOD_Vars_Global - IMPLICIT NONE - SAVE - - ! for LULC_IGBP_PC - REAL(r8), allocatable :: pcfrac(:,:) !PC fractional cover - REAL(r8), allocatable :: htop_c(:,:) !canopy top height [m] - REAL(r8), allocatable :: hbot_c(:,:) !canopy bottom height [m] - -! PUBLIC MEMBER FUNCTIONS: - PUBLIC :: allocate_PCTimeInvariants - PUBLIC :: READ_PCTimeInvariants - PUBLIC :: WRITE_PCTimeInvariants - PUBLIC :: deallocate_PCTimeInvariants -#ifdef RangeCheck - PUBLIC :: check_PCTimeInvariants -#endif - -! PRIVATE MEMBER FUNCTIONS: - -!----------------------------------------------------------------------- - - CONTAINS - -!----------------------------------------------------------------------- - - SUBROUTINE allocate_PCTimeInvariants - ! -------------------------------------------------------------------- - ! Allocates memory for CoLM Plant Community (PC) [numpc] variables - ! -------------------------------------------------------------------- - - USE MOD_Precision - USE MOD_SPMD_Task - USE MOD_LandPC - USE MOD_Vars_Global - IMPLICIT NONE - - IF (p_is_worker) THEN - - IF (numpc > 0) THEN - allocate (pcfrac (0:N_PFT-1,numpc)) - allocate (htop_c (0:N_PFT-1,numpc)) - allocate (hbot_c (0:N_PFT-1,numpc)) - ENDIF - ENDIF - - END SUBROUTINE allocate_PCTimeInvariants - - SUBROUTINE READ_PCTimeInvariants (file_restart) - - use MOD_NetCDFVector - USE MOD_Vars_Global - USE MOD_LandPC - IMPLICIT NONE - - character(LEN=*), intent(in) :: file_restart - - call ncio_read_vector (file_restart, 'pcfrac', N_PFT, landpc, pcfrac) ! - call ncio_read_vector (file_restart, 'htop_c', N_PFT, landpc, htop_c) ! - call ncio_read_vector (file_restart, 'hbot_c', N_PFT, landpc, hbot_c) ! - - end subroutine READ_PCTimeInvariants - - SUBROUTINE WRITE_PCTimeInvariants (file_restart) - - use MOD_NetCDFVector - use MOD_LandPC - USE MOD_Namelist - USE MOD_Vars_Global - IMPLICIT NONE - - ! Local variables - character(len=*), intent(in) :: file_restart - integer :: compress - - compress = DEF_REST_COMPRESS_LEVEL - - call ncio_create_file_vector (file_restart, landpc) - CALL ncio_define_dimension_vector (file_restart, landpc, 'pc') - CALL ncio_define_dimension_vector (file_restart, landpc, 'pft', N_PFT) - - call ncio_write_vector (file_restart, 'pcfrac', 'pft', N_PFT, 'pc', landpc, pcfrac, compress) ! - call ncio_write_vector (file_restart, 'htop_c', 'pft', N_PFT, 'pc', landpc, htop_c, compress) ! - call ncio_write_vector (file_restart, 'hbot_c', 'pft', N_PFT, 'pc', landpc, hbot_c, compress) ! - - end subroutine WRITE_PCTimeInvariants - - SUBROUTINE deallocate_PCTimeInvariants -! -------------------------------------------------- -! Deallocates memory for CoLM Plant Community (PC) variables -! -------------------------------------------------- - - USE MOD_SPMD_Task - USE MOD_LandPC - - IF (p_is_worker) THEN - IF (numpc > 0) THEN - deallocate (pcfrac ) - deallocate (htop_c ) - deallocate (hbot_c ) - ENDIF - ENDIF - - END SUBROUTINE deallocate_PCTimeInvariants - -#ifdef RangeCheck - SUBROUTINE check_PCTimeInvariants () - - use MOD_RangeCheck - IMPLICIT NONE - - call check_vector_data ('pcfrc ', pcfrac) ! - call check_vector_data ('htop_c', htop_c) ! - call check_vector_data ('hbot_c', hbot_c) ! - - end subroutine check_PCTimeInvariants -#endif - -END MODULE MOD_Vars_PCTimeInvariants -#endif - - - MODULE MOD_Vars_TimeInvariants ! ------------------------------- ! Created by Yongjiu Dai, 03/2014 ! ------------------------------- - use MOD_Precision -#ifdef LULC_IGBP_PFT + USE MOD_Precision +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) USE MOD_Vars_PFTimeInvariants #endif -#ifdef LULC_IGBP_PC - USE MOD_Vars_PCTimeInvariants -#endif #ifdef BGC USE MOD_BGC_Vars_TimeInvariants #endif @@ -294,7 +184,8 @@ MODULE MOD_Vars_TimeInvariants ! ----------------------------------------------------------------- ! surface classification and soil information INTEGER, allocatable :: patchclass (:) !index of land cover type of the patches at the fraction > 0 - INTEGER, allocatable :: patchtype (:) !land water type + INTEGER, allocatable :: patchtype (:) !land patch type + LOGICAL, allocatable :: patchmask (:) !patch mask REAL(r8), allocatable :: patchlatr (:) !latitude in radians REAL(r8), allocatable :: patchlonr (:) !longitude in radians @@ -321,12 +212,12 @@ MODULE MOD_Vars_TimeInvariants REAL(r8), allocatable :: psi0 (:,:) !minimum soil suction [mm] (NOTE: "-" valued) REAL(r8), allocatable :: bsw (:,:) !clapp and hornbereger "b" parameter [-] #ifdef vanGenuchten_Mualem_SOIL_MODEL - REAL(r8), allocatable :: theta_r (:,:) - REAL(r8), allocatable :: alpha_vgm (:,:) - REAL(r8), allocatable :: L_vgm (:,:) - REAL(r8), allocatable :: n_vgm (:,:) - REAL(r8), allocatable :: sc_vgm (:,:) - REAL(r8), allocatable :: fc_vgm (:,:) + REAL(r8), allocatable :: theta_r (:,:) !residual moisture content [-] + REAL(r8), allocatable :: alpha_vgm (:,:) !a parameter corresponding approximately to the inverse of the air-entry value + REAL(r8), allocatable :: L_vgm (:,:) !pore-connectivity parameter [dimensionless] + REAL(r8), allocatable :: n_vgm (:,:) !a shape parameter [dimensionless] + REAL(r8), allocatable :: sc_vgm (:,:) !saturation at the air entry value in the classical vanGenuchten model [-] + REAL(r8), allocatable :: fc_vgm (:,:) !a scaling factor by using air entry value in the Mualem model [-] #endif REAL(r8), allocatable :: hksati (:,:) !hydraulic conductivity at saturation [mm h2o/s] REAL(r8), allocatable :: csol (:,:) !heat capacity of soil solids [J/(m3 K)] @@ -357,6 +248,7 @@ MODULE MOD_Vars_TimeInvariants REAL(r8) :: smpmin !restriction for min of soil poten. (mm) REAL(r8) :: trsmx0 !max transpiration for moist soil+100% veg. [mm/s] REAL(r8) :: tcrit !critical temp. to determine rain or snow + REAL(r8) :: wetwatmax !maximum wetland water (mm) ! PUBLIC MEMBER FUNCTIONS: public :: allocate_TimeInvariants @@ -389,6 +281,7 @@ SUBROUTINE allocate_TimeInvariants () allocate (patchclass (numpatch)) allocate (patchtype (numpatch)) + allocate (patchmask (numpatch)) allocate (patchlonr (numpatch)) allocate (patchlatr (numpatch)) @@ -435,14 +328,10 @@ SUBROUTINE allocate_TimeInvariants () allocate (ibedrock (numpatch)) end if -#ifdef LULC_IGBP_PFT +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) CALL allocate_PFTimeInvariants #endif -#ifdef LULC_IGBP_PC - CALL allocate_PCTimeInvariants -#endif - #ifdef BGC CALL allocate_BGCTimeInvariants #endif @@ -466,7 +355,7 @@ SUBROUTINE READ_TimeInvariants (lc_year, casename, dir_restart) use MOD_SPMD_Task use MOD_NetCDFVector use MOD_NetCDFSerial -#ifdef RangeCheck +#ifdef RangeCheck USE MOD_RangeCheck #endif USE MOD_LandPatch @@ -481,12 +370,12 @@ SUBROUTINE READ_TimeInvariants (lc_year, casename, dir_restart) ! Local variables character(LEN=256) :: file_restart, cyear - write(cyear,'(i4.4)') lc_year - file_restart = trim(dir_restart) // '/' // trim(casename) //'_restart_const' // '_lc' // trim(cyear) // '.nc' + file_restart = trim(dir_restart) // '/const/' // trim(casename) //'_restart_const' // '_lc' // trim(cyear) // '.nc' call ncio_read_vector (file_restart, 'patchclass', landpatch, patchclass) ! call ncio_read_vector (file_restart, 'patchtype' , landpatch, patchtype ) ! + call ncio_read_vector (file_restart, 'patchmask' , landpatch, patchmask ) ! call ncio_read_vector (file_restart, 'patchlonr' , landpatch, patchlonr ) ! call ncio_read_vector (file_restart, 'patchlatr' , landpatch, patchlatr ) ! @@ -512,12 +401,12 @@ SUBROUTINE READ_TimeInvariants (lc_year, casename, dir_restart) call ncio_read_vector (file_restart, 'psi0 ' , nl_soil, landpatch, psi0 ) ! minimum soil suction [mm] (NOTE: "-" valued) call ncio_read_vector (file_restart, 'bsw ' , nl_soil, landpatch, bsw ) ! clapp and hornbereger "b" parameter [-] #ifdef vanGenuchten_Mualem_SOIL_MODEL - call ncio_read_vector (file_restart, 'theta_r ' , nl_soil, landpatch, theta_r ) - call ncio_read_vector (file_restart, 'alpha_vgm' , nl_soil, landpatch, alpha_vgm ) - call ncio_read_vector (file_restart, 'L_vgm ' , nl_soil, landpatch, L_vgm ) - call ncio_read_vector (file_restart, 'n_vgm ' , nl_soil, landpatch, n_vgm ) - call ncio_read_vector (file_restart, 'sc_vgm ' , nl_soil, landpatch, sc_vgm ) - call ncio_read_vector (file_restart, 'fc_vgm ' , nl_soil, landpatch, fc_vgm ) + call ncio_read_vector (file_restart, 'theta_r ' , nl_soil, landpatch, theta_r ) ! residual moisture content [-] + call ncio_read_vector (file_restart, 'alpha_vgm' , nl_soil, landpatch, alpha_vgm ) ! a parameter corresponding approximately to the inverse of the air-entry value + call ncio_read_vector (file_restart, 'L_vgm ' , nl_soil, landpatch, L_vgm ) ! pore-connectivity parameter [dimensionless] + call ncio_read_vector (file_restart, 'n_vgm ' , nl_soil, landpatch, n_vgm ) ! a shape parameter [dimensionless] + call ncio_read_vector (file_restart, 'sc_vgm ' , nl_soil, landpatch, sc_vgm ) ! saturation at the air entry value in the classical vanGenuchten model [-] + call ncio_read_vector (file_restart, 'fc_vgm ' , nl_soil, landpatch, fc_vgm ) ! a scaling factor by using air entry value in the Mualem model [-] #endif call ncio_read_vector (file_restart, 'hksati ' , nl_soil, landpatch, hksati ) ! hydraulic conductivity at saturation [mm h2o/s] call ncio_read_vector (file_restart, 'csol ' , nl_soil, landpatch, csol ) ! heat capacity of soil solids [J/(m3 K)] @@ -531,8 +420,8 @@ SUBROUTINE READ_TimeInvariants (lc_year, casename, dir_restart) call ncio_read_vector (file_restart, 'hbot' , landpatch, hbot) ! IF(DEF_USE_BEDROCK)THEN - call ncio_read_vector (file_restart, 'debdrock' , landpatch, dbedrock) ! - call ncio_read_vector (file_restart, 'ibedrock' , landpatch, ibedrock) ! + call ncio_read_vector (file_restart, 'debdrock' , landpatch, dbedrock) ! + call ncio_read_vector (file_restart, 'ibedrock' , landpatch, ibedrock) ! ENDIF call ncio_read_bcast_serial (file_restart, 'zlnd ', zlnd ) ! roughness length for soil [m] @@ -549,28 +438,24 @@ SUBROUTINE READ_TimeInvariants (lc_year, casename, dir_restart) call ncio_read_bcast_serial (file_restart, 'smpmin', smpmin) ! restriction for min of soil poten. (mm) call ncio_read_bcast_serial (file_restart, 'trsmx0', trsmx0) ! max transpiration for moist soil+100% veg. [mm/s] call ncio_read_bcast_serial (file_restart, 'tcrit ', tcrit ) ! critical temp. to determine rain or snow + call ncio_read_bcast_serial (file_restart, 'wetwatmax', wetwatmax) ! maximum wetland water (mm) -#if (defined LULC_IGBP_PFT) - file_restart = trim(dir_restart) // '/' // trim(casename) //'_restart_pft_const' // '_lc' // trim(cyear) // '.nc' +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + file_restart = trim(dir_restart) // '/const/' // trim(casename) //'_restart_pft_const' // '_lc' // trim(cyear) // '.nc' CALL READ_PFTimeInvariants (file_restart) #endif -#if (defined LULC_IGBP_PC) - file_restart = trim(dir_restart) // '/' // trim(casename) //'_restart_pc_const' // '_lc' // trim(cyear) // '.nc' - CALL READ_PCTimeInvariants (file_restart) -#endif - #if (defined BGC) - file_restart = trim(dir_restart) // '/' // trim(casename) //'_restart_bgc_const' // '_lc' // trim(cyear) // '.nc' + file_restart = trim(dir_restart) // '/const/' // trim(casename) //'_restart_bgc_const' // '_lc' // trim(cyear) // '.nc' CALL READ_BGCTimeInvariants (file_restart) #endif #if (defined URBAN_MODEL) - file_restart = trim(dir_restart) // '/' // trim(casename) //'_restart_urb_const' // '_lc' // trim(cyear) // '.nc' + file_restart = trim(dir_restart) // '/const/' // trim(casename) //'_restart_urb_const' // '_lc' // trim(cyear) // '.nc' CALL READ_UrbanTimeInvariants (file_restart) #endif -#ifdef RangeCheck +#ifdef RangeCheck call check_TimeInvariants () #endif @@ -611,7 +496,15 @@ SUBROUTINE WRITE_TimeInvariants (lc_year, casename, dir_restart) compress = DEF_REST_COMPRESS_LEVEL write(cyear,'(i4.4)') lc_year - file_restart = trim(dir_restart) // '/' // trim(casename) //'_restart_const' //'_lc'// trim(cyear) // '.nc' + + IF (p_is_master) THEN + CALL system('mkdir -p ' // trim(dir_restart)//'/const') + ENDIF +#ifdef USEMPI + call mpi_barrier (p_comm_glb, p_err) +#endif + + file_restart = trim(dir_restart) // '/const/' // trim(casename) //'_restart_const' //'_lc'// trim(cyear) // '.nc' call ncio_create_file_vector (file_restart, landpatch) @@ -628,6 +521,7 @@ SUBROUTINE WRITE_TimeInvariants (lc_year, casename, dir_restart) call ncio_write_vector (file_restart, 'patchclass', 'patch', landpatch, patchclass) ! call ncio_write_vector (file_restart, 'patchtype' , 'patch', landpatch, patchtype ) ! + call ncio_write_vector (file_restart, 'patchmask' , 'patch', landpatch, patchmask ) ! call ncio_write_vector (file_restart, 'patchlonr' , 'patch', landpatch, patchlonr ) ! call ncio_write_vector (file_restart, 'patchlatr' , 'patch', landpatch, patchlatr ) ! @@ -654,12 +548,12 @@ SUBROUTINE WRITE_TimeInvariants (lc_year, casename, dir_restart) call ncio_write_vector (file_restart, 'bsw ', 'soil', nl_soil, 'patch', landpatch, bsw , compress) ! clapp and hornbereger "b" parameter [-] #ifdef vanGenuchten_Mualem_SOIL_MODEL - call ncio_write_vector (file_restart, 'theta_r ' , 'soil', nl_soil, 'patch', landpatch, theta_r , compress) - call ncio_write_vector (file_restart, 'alpha_vgm' , 'soil', nl_soil, 'patch', landpatch, alpha_vgm , compress) - call ncio_write_vector (file_restart, 'L_vgm ' , 'soil', nl_soil, 'patch', landpatch, L_vgm , compress) - call ncio_write_vector (file_restart, 'n_vgm ' , 'soil', nl_soil, 'patch', landpatch, n_vgm , compress) - call ncio_write_vector (file_restart, 'sc_vgm ' , 'soil', nl_soil, 'patch', landpatch, sc_vgm , compress) - call ncio_write_vector (file_restart, 'fc_vgm ' , 'soil', nl_soil, 'patch', landpatch, fc_vgm , compress) + call ncio_write_vector (file_restart, 'theta_r ' , 'soil', nl_soil, 'patch', landpatch, theta_r , compress) ! residual moisture content [-] + call ncio_write_vector (file_restart, 'alpha_vgm' , 'soil', nl_soil, 'patch', landpatch, alpha_vgm , compress) ! a parameter corresponding approximately to the inverse of the air-entry value + call ncio_write_vector (file_restart, 'L_vgm ' , 'soil', nl_soil, 'patch', landpatch, L_vgm , compress) ! pore-connectivity parameter [dimensionless] + call ncio_write_vector (file_restart, 'n_vgm ' , 'soil', nl_soil, 'patch', landpatch, n_vgm , compress) ! a shape parameter [dimensionless] + call ncio_write_vector (file_restart, 'sc_vgm ' , 'soil', nl_soil, 'patch', landpatch, sc_vgm , compress) ! saturation at the air entry value in the classical vanGenuchten model [-] + call ncio_write_vector (file_restart, 'fc_vgm ' , 'soil', nl_soil, 'patch', landpatch, fc_vgm , compress) ! a scaling factor by using air entry value in the Mualem model [-] #endif call ncio_write_vector (file_restart, 'hksati ' , 'soil', nl_soil, 'patch', landpatch, hksati , compress) ! hydraulic conductivity at saturation [mm h2o/s] call ncio_write_vector (file_restart, 'csol ' , 'soil', nl_soil, 'patch', landpatch, csol , compress) ! heat capacity of soil solids [J/(m3 K)] @@ -674,13 +568,19 @@ SUBROUTINE WRITE_TimeInvariants (lc_year, casename, dir_restart) call ncio_write_vector (file_restart, 'hbot' , 'patch', landpatch, hbot) ! IF(DEF_USE_BEDROCK)THEN - call ncio_write_vector (file_restart, 'debdrock' , 'patch', landpatch, dbedrock) ! - call ncio_write_vector (file_restart, 'ibedrock' , 'patch', landpatch, ibedrock) ! + call ncio_write_vector (file_restart, 'debdrock' , 'patch', landpatch, dbedrock) ! + call ncio_write_vector (file_restart, 'ibedrock' , 'patch', landpatch, ibedrock) ! ENDIF +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + if (p_is_master) then +#ifndef VectorInOneFile call ncio_create_file (file_restart) +#endif call ncio_write_serial (file_restart, 'zlnd ', zlnd ) ! roughness length for soil [m] call ncio_write_serial (file_restart, 'zsno ', zsno ) ! roughness length for snow [m] @@ -696,26 +596,26 @@ SUBROUTINE WRITE_TimeInvariants (lc_year, casename, dir_restart) call ncio_write_serial (file_restart, 'smpmin', smpmin) ! restriction for min of soil poten. (mm) call ncio_write_serial (file_restart, 'trsmx0', trsmx0) ! max transpiration for moist soil+100% veg. [mm/s] call ncio_write_serial (file_restart, 'tcrit ', tcrit ) ! critical temp. to determine rain or snow + call ncio_write_serial (file_restart, 'wetwatmax', wetwatmax) ! maximum wetland water (mm) end if -#if (defined LULC_IGBP_PFT) - file_restart = trim(dir_restart) // '/' // trim(casename) //'_restart_pft_const' //'_lc'// trim(cyear) // '.nc' - CALL WRITE_PFTimeInvariants (file_restart) +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) #endif -#if (defined LULC_IGBP_PC) - file_restart = trim(dir_restart) // '/' // trim(casename) //'_restart_pc_const' //'_lc'// trim(cyear) // '.nc' - CALL WRITE_PCTimeInvariants (file_restart) +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + file_restart = trim(dir_restart) // '/const/' // trim(casename) //'_restart_pft_const' //'_lc'// trim(cyear) // '.nc' + CALL WRITE_PFTimeInvariants (file_restart) #endif #if (defined BGC) - file_restart = trim(dir_restart) // '/' // trim(casename) //'_restart_bgc_const' //'_lc'// trim(cyear) // '.nc' + file_restart = trim(dir_restart) // '/const/' // trim(casename) //'_restart_bgc_const' //'_lc'// trim(cyear) // '.nc' CALL WRITE_BGCTimeInvariants (file_restart) #endif #if (defined URBAN_MODEL) - file_restart = trim(dir_restart) // '/' // trim(casename) //'_restart_urb_const' //'_lc'// trim(cyear) // '.nc' + file_restart = trim(dir_restart) // '/const/' // trim(casename) //'_restart_urb_const' //'_lc'// trim(cyear) // '.nc' CALL WRITE_UrbanTimeInvariants (file_restart) #endif @@ -738,6 +638,7 @@ SUBROUTINE deallocate_TimeInvariants () deallocate (patchclass ) deallocate (patchtype ) + deallocate (patchmask ) deallocate (patchlonr ) deallocate (patchlatr ) @@ -788,14 +689,10 @@ SUBROUTINE deallocate_TimeInvariants () end if end if -#ifdef LULC_IGBP_PFT +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) CALL deallocate_PFTimeInvariants #endif -#ifdef LULC_IGBP_PC - CALL deallocate_PCTimeInvariants -#endif - #ifdef BGC CALL deallocate_BGCTimeInvariants #endif @@ -823,47 +720,47 @@ SUBROUTINE check_TimeInvariants () call mpi_barrier (p_comm_glb, p_err) #endif - call check_vector_data ('lakedepth ', lakedepth ) ! - call check_vector_data ('dz_lake ', dz_lake ) ! new lake scheme - - call check_vector_data ('soil_s_v_alb', soil_s_v_alb) ! albedo of visible of the saturated soil - call check_vector_data ('soil_d_v_alb', soil_d_v_alb) ! albedo of visible of the dry soil - call check_vector_data ('soil_s_n_alb', soil_s_n_alb) ! albedo of near infrared of the saturated soil - call check_vector_data ('soil_d_n_alb', soil_d_n_alb) ! albedo of near infrared of the dry soil - call check_vector_data ('vf_quartz ', vf_quartz ) ! volumetric fraction of quartz within mineral soil - call check_vector_data ('vf_gravels ', vf_gravels ) ! volumetric fraction of gravels - call check_vector_data ('vf_om ', vf_om ) ! volumetric fraction of organic matter - call check_vector_data ('vf_sand ', vf_sand ) ! volumetric fraction of sand - call check_vector_data ('wf_gravels ', wf_gravels ) ! gravimetric fraction of gravels - call check_vector_data ('wf_sand ', wf_sand ) ! gravimetric fraction of sand - call check_vector_data ('OM_density ', OM_density ) ! OM density - call check_vector_data ('BD_all ', BD_all ) ! bulk density of soils - call check_vector_data ('wfc ', wfc ) ! field capacity - call check_vector_data ('porsl ', porsl ) ! fraction of soil that is voids [-] - call check_vector_data ('psi0 ', psi0 ) ! minimum soil suction [mm] (NOTE: "-" valued) - call check_vector_data ('bsw ', bsw ) ! clapp and hornbereger "b" parameter [-] + call check_vector_data ('lakedepth [m] ', lakedepth ) ! + call check_vector_data ('dz_lake [m] ', dz_lake ) ! new lake scheme + + call check_vector_data ('soil_s_v_alb [-] ', soil_s_v_alb) ! albedo of visible of the saturated soil + call check_vector_data ('soil_d_v_alb [-] ', soil_d_v_alb) ! albedo of visible of the dry soil + call check_vector_data ('soil_s_n_alb [-] ', soil_s_n_alb) ! albedo of near infrared of the saturated soil + call check_vector_data ('soil_d_n_alb [-] ', soil_d_n_alb) ! albedo of near infrared of the dry soil + call check_vector_data ('vf_quartz [m3/m3] ', vf_quartz ) ! volumetric fraction of quartz within mineral soil + call check_vector_data ('vf_gravels [m3/m3] ', vf_gravels ) ! volumetric fraction of gravels + call check_vector_data ('vf_om [m3/m3] ', vf_om ) ! volumetric fraction of organic matter + call check_vector_data ('vf_sand [m3/m3] ', vf_sand ) ! volumetric fraction of sand + call check_vector_data ('wf_gravels [kg/kg] ', wf_gravels ) ! gravimetric fraction of gravels + call check_vector_data ('wf_sand [kg/kg] ', wf_sand ) ! gravimetric fraction of sand + call check_vector_data ('OM_density [kg/m3] ', OM_density ) ! OM density + call check_vector_data ('BD_all [kg/m3] ', BD_all ) ! bulk density of soils + call check_vector_data ('wfc [m3/m3] ', wfc ) ! field capacity + call check_vector_data ('porsl [m3/m3] ', porsl ) ! fraction of soil that is voids [-] + call check_vector_data ('psi0 [mm] ', psi0 ) ! minimum soil suction [mm] (NOTE: "-" valued) + call check_vector_data ('bsw [-] ', bsw ) ! clapp and hornbereger "b" parameter [-] #ifdef vanGenuchten_Mualem_SOIL_MODEL - call check_vector_data ('theta_r ', theta_r ) - call check_vector_data ('alpha_vgm ', alpha_vgm ) - call check_vector_data ('L_vgm ', L_vgm ) - call check_vector_data ('n_vgm ', n_vgm ) - call check_vector_data ('sc_vgm ', sc_vgm ) - call check_vector_data ('fc_vgm ', fc_vgm ) -#endif - call check_vector_data ('hksati ', hksati ) ! hydraulic conductivity at saturation [mm h2o/s] - call check_vector_data ('csol ', csol ) ! heat capacity of soil solids [J/(m3 K)] - call check_vector_data ('k_solids ', k_solids ) ! thermal conductivity of soil solids [W/m-K] - call check_vector_data ('dksatu ', dksatu ) ! thermal conductivity of unfrozen saturated soil [W/m-K] - call check_vector_data ('dksatf ', dksatf ) ! thermal conductivity of frozen saturated soil [W/m-K] - call check_vector_data ('dkdry ', dkdry ) ! thermal conductivity for dry soil [W/(m-K)] - call check_vector_data ('BA_alpha ', BA_alpha ) ! alpha in Balland and Arp(2005) thermal conductivity scheme - call check_vector_data ('BA_beta ', BA_beta ) ! beta in Balland and Arp(2005) thermal conductivity scheme - - call check_vector_data ('htop ', htop ) - call check_vector_data ('hbot ', hbot ) + call check_vector_data ('theta_r [m3/m3] ', theta_r ) ! residual moisture content [-] + call check_vector_data ('alpha_vgm [-] ', alpha_vgm ) ! a parameter corresponding approximately to the inverse of the air-entry value + call check_vector_data ('L_vgm [-] ', L_vgm ) ! pore-connectivity parameter [dimensionless] + call check_vector_data ('n_vgm [-] ', n_vgm ) ! a shape parameter [dimensionless] + call check_vector_data ('sc_vgm [-] ', sc_vgm ) ! saturation at the air entry value in the classical vanGenuchten model [-] + call check_vector_data ('fc_vgm [-] ', fc_vgm ) ! a scaling factor by using air entry value in the Mualem model [-] +#endif + call check_vector_data ('hksati [mm/s] ', hksati ) ! hydraulic conductivity at saturation [mm h2o/s] + call check_vector_data ('csol [J/m3/K]', csol ) ! heat capacity of soil solids [J/(m3 K)] + call check_vector_data ('k_solids [W/m/K] ', k_solids ) ! thermal conductivity of soil solids [W/m-K] + call check_vector_data ('dksatu [W/m/K] ', dksatu ) ! thermal conductivity of unfrozen saturated soil [W/m-K] + call check_vector_data ('dksatf [W/m/K] ', dksatf ) ! thermal conductivity of frozen saturated soil [W/m-K] + call check_vector_data ('dkdry [W/m/K] ', dkdry ) ! thermal conductivity for dry soil [W/(m-K)] + call check_vector_data ('BA_alpha [-] ', BA_alpha ) ! alpha in Balland and Arp(2005) thermal conductivity scheme + call check_vector_data ('BA_beta [-] ', BA_beta ) ! beta in Balland and Arp(2005) thermal conductivity scheme + + call check_vector_data ('htop [m] ', htop ) + call check_vector_data ('hbot [m] ', hbot ) IF(DEF_USE_BEDROCK)THEN - call check_vector_data ('dbedrock ', dbedrock ) ! + call check_vector_data ('dbedrock [m] ', dbedrock ) ! ENDIF #ifdef USEMPI @@ -871,30 +768,28 @@ SUBROUTINE check_TimeInvariants () #endif if (p_is_master) then - write(*,'(A7,E20.10)') 'zlnd ', zlnd ! roughness length for soil [m] - write(*,'(A7,E20.10)') 'zsno ', zsno ! roughness length for snow [m] - write(*,'(A7,E20.10)') 'csoilc', csoilc ! drag coefficient for soil under canopy [-] - write(*,'(A7,E20.10)') 'dewmx ', dewmx ! maximum dew - write(*,'(A7,E20.10)') 'wtfact', wtfact ! fraction of model area with high water table - write(*,'(A7,E20.10)') 'capr ', capr ! tuning factor to turn first layer T into surface T - write(*,'(A7,E20.10)') 'cnfac ', cnfac ! Crank Nicholson factor between 0 and 1 - write(*,'(A7,E20.10)') 'ssi ', ssi ! irreducible water saturation of snow - write(*,'(A7,E20.10)') 'wimp ', wimp ! water impremeable if porosity less than wimp - write(*,'(A7,E20.10)') 'pondmx', pondmx ! ponding depth (mm) - write(*,'(A7,E20.10)') 'smpmax', smpmax ! wilting point potential in mm - write(*,'(A7,E20.10)') 'smpmin', smpmin ! restriction for min of soil poten. (mm) - write(*,'(A7,E20.10)') 'trsmx0', trsmx0 ! max transpiration for moist soil+100% veg. [mm/s] - write(*,'(A7,E20.10)') 'tcrit ', tcrit ! critical temp. to determine rain or snow + write(*,'(/,A)') 'Checking Constants ...' + write(*,'(A,E20.10)') 'zlnd [m] ', zlnd ! roughness length for soil [m] + write(*,'(A,E20.10)') 'zsno [m] ', zsno ! roughness length for snow [m] + write(*,'(A,E20.10)') 'csoilc [-] ', csoilc ! drag coefficient for soil under canopy [-] + write(*,'(A,E20.10)') 'dewmx [mm] ', dewmx ! maximum dew + write(*,'(A,E20.10)') 'wtfact [-] ', wtfact ! fraction of model area with high water table + write(*,'(A,E20.10)') 'capr [-] ', capr ! tuning factor to turn first layer T into surface T + write(*,'(A,E20.10)') 'cnfac [-] ', cnfac ! Crank Nicholson factor between 0 and 1 + write(*,'(A,E20.10)') 'ssi [-] ', ssi ! irreducible water saturation of snow + write(*,'(A,E20.10)') 'wimp [m3/m3]', wimp ! water impremeable if porosity less than wimp + write(*,'(A,E20.10)') 'pondmx [mm] ', pondmx ! ponding depth (mm) + write(*,'(A,E20.10)') 'smpmax [mm] ', smpmax ! wilting point potential in mm + write(*,'(A,E20.10)') 'smpmin [mm] ', smpmin ! restriction for min of soil poten. (mm) + write(*,'(A,E20.10)') 'trsmx0 [mm/s] ', trsmx0 ! max transpiration for moist soil+100% veg. [mm/s] + write(*,'(A,E20.10)') 'tcrit [K] ', tcrit ! critical temp. to determine rain or snow + write(*,'(A,E20.10)') 'wetwatmax [mm]', wetwatmax ! maximum wetland water (mm) end if -#ifdef LULC_IGBP_PFT +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) CALL check_PFTimeInvariants #endif -#ifdef LULC_IGBP_PC - CALL check_PCTimeInvariants -#endif - #ifdef BGC CALL check_BGCTimeInvariants #endif diff --git a/main/MOD_Vars_TimeVariables.F90 b/main/MOD_Vars_TimeVariables.F90 index 323f74f0..52ccbb8b 100644 --- a/main/MOD_Vars_TimeVariables.F90 +++ b/main/MOD_Vars_TimeVariables.F90 @@ -4,7 +4,7 @@ ! Created by Yongjiu Dai, 03/2014 ! ------------------------------- -#if (defined LULC_IGBP_PFT) +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) MODULE MOD_Vars_PFTimeVariables ! ----------------------------------------------------------------- ! !DESCRIPTION: @@ -24,33 +24,35 @@ MODULE MOD_Vars_PFTimeVariables ! ----------------------------------------------------------------- ! Time-varying state variables which reaquired by restart run - ! for LULC_IGBP_PFT - REAL(r8), allocatable :: tleaf_p (:) !shaded leaf temperature [K] - REAL(r8), allocatable :: ldew_p (:) !depth of water on foliage [mm] - real(r8), allocatable :: ldew_rain_p (:)!depth of rain on foliage [mm] - real(r8), allocatable :: ldew_snow_p (:)!depth of snow on foliage [mm] - REAL(r8), allocatable :: sigf_p (:) !fraction of veg cover, excluding snow-covered veg [-] - REAL(r8), allocatable :: tlai_p (:) !leaf area index - REAL(r8), allocatable :: lai_p (:) !leaf area index - REAL(r8), allocatable :: laisun_p (:) !sunlit leaf area index - REAL(r8), allocatable :: laisha_p (:) !shaded leaf area index - REAL(r8), allocatable :: tsai_p (:) !stem area index - REAL(r8), allocatable :: sai_p (:) !stem area index - REAL(r8), allocatable :: ssun_p (:,:,:) !sunlit canopy absorption for solar radiation (0-1) - REAL(r8), allocatable :: ssha_p (:,:,:) !shaded canopy absorption for solar radiation (0-1) - REAL(r8), allocatable :: thermk_p (:) !canopy gap fraction for tir radiation - REAL(r8), allocatable :: extkb_p (:) !(k, g(mu)/mu) direct solar extinction coefficient - REAL(r8), allocatable :: extkd_p (:) !diffuse and scattered diffuse PAR extinction coefficient - REAL(r8), allocatable :: tref_p (:) !2 m height air temperature [kelvin] - REAL(r8), allocatable :: qref_p (:) !2 m height air specific humidity - REAL(r8), allocatable :: rst_p (:) !canopy stomatal resistance (s/m) - REAL(r8), allocatable :: z0m_p (:) !effective roughness [m] + ! for LULC_IGBP_PFT or LULC_IGBP_PC + real(r8), allocatable :: tleaf_p (:) !shaded leaf temperature [K] + real(r8), allocatable :: ldew_p (:) !depth of water on foliage [mm] + real(r8), allocatable :: ldew_rain_p (:) !depth of rain on foliage [mm] + real(r8), allocatable :: ldew_snow_p (:) !depth of snow on foliage [mm] + real(r8), allocatable :: sigf_p (:) !fraction of veg cover, excluding snow-covered veg [-] + real(r8), allocatable :: tlai_p (:) !leaf area index + real(r8), allocatable :: lai_p (:) !leaf area index + real(r8), allocatable :: laisun_p (:) !sunlit leaf area index + real(r8), allocatable :: laisha_p (:) !shaded leaf area index + real(r8), allocatable :: tsai_p (:) !stem area index + real(r8), allocatable :: sai_p (:) !stem area index + real(r8), allocatable :: ssun_p (:,:,:) !sunlit canopy absorption for solar radiation (0-1) + real(r8), allocatable :: ssha_p (:,:,:) !shaded canopy absorption for solar radiation (0-1) + real(r8), allocatable :: thermk_p (:) !canopy gap fraction for tir radiation + real(r8), allocatable :: fshade_p (:) !canopy shade fraction for tir radiation + real(r8), allocatable :: extkb_p (:) !(k, g(mu)/mu) direct solar extinction coefficient + real(r8), allocatable :: extkd_p (:) !diffuse and scattered diffuse PAR extinction coefficient + !TODO@yuan: to check the below for PC whether they are needed + real(r8), allocatable :: tref_p (:) !2 m height air temperature [kelvin] + real(r8), allocatable :: qref_p (:) !2 m height air specific humidity + real(r8), allocatable :: rst_p (:) !canopy stomatal resistance (s/m) + real(r8), allocatable :: z0m_p (:) !effective roughness [m] ! Plant Hydraulic variables - real(r8), allocatable :: vegwp_p (:,:) ! vegetation water potential [mm] - real(r8), allocatable :: gs0sun_p (:) ! working copy of sunlit stomata conductance - real(r8), allocatable :: gs0sha_p (:) ! working copy of shalit stomata conductance + real(r8), allocatable :: vegwp_p (:,:) !vegetation water potential [mm] + real(r8), allocatable :: gs0sun_p (:) !working copy of sunlit stomata conductance + real(r8), allocatable :: gs0sha_p (:) !working copy of shalit stomata conductance ! end plant hydraulic variables -!Ozone Stress Variables +! Ozone Stress Variables real(r8), allocatable :: o3coefv_sun_p(:) !Ozone stress factor for photosynthesis on sunlit leaf real(r8), allocatable :: o3coefv_sha_p(:) !Ozone stress factor for photosynthesis on shaded leaf real(r8), allocatable :: o3coefg_sun_p(:) !Ozone stress factor for stomata on sunlit leaf @@ -58,7 +60,10 @@ MODULE MOD_Vars_PFTimeVariables real(r8), allocatable :: lai_old_p (:) !lai in last time step real(r8), allocatable :: o3uptakesun_p(:) !Ozone does, sunlit leaf (mmol O3/m^2) real(r8), allocatable :: o3uptakesha_p(:) !Ozone does, shaded leaf (mmol O3/m^2) -!End Ozone Stress Variables +! End Ozone Stress Variables +! irrigation variables + integer , allocatable :: irrig_method_p(:)!irrigation method +! end irrigation variables ! PUBLIC MEMBER FUNCTIONS: PUBLIC :: allocate_PFTimeVariables @@ -103,6 +108,7 @@ SUBROUTINE allocate_PFTimeVariables () allocate (ssun_p (2,2,numpft)) ; ssun_p (:,:,:) = spval !sunlit canopy absorption for solar radiation (0-1) allocate (ssha_p (2,2,numpft)) ; ssha_p (:,:,:) = spval !shaded canopy absorption for solar radiation (0-1) allocate (thermk_p (numpft)) ; thermk_p (:) = spval !canopy gap fraction for tir radiation + allocate (fshade_p (numpft)) ; fshade_p (:) = spval !canopy shade fraction for tir radiation allocate (extkb_p (numpft)) ; extkb_p (:) = spval !(k, g(mu)/mu) direct solar extinction coefficient allocate (extkd_p (numpft)) ; extkd_p (:) = spval !diffuse and scattered diffuse PAR extinction coefficient allocate (tref_p (numpft)) ; tref_p (:) = spval !2 m height air temperature [kelvin] @@ -123,6 +129,8 @@ SUBROUTINE allocate_PFTimeVariables () allocate (o3uptakesun_p(numpft)) ; o3uptakesun_p(:) = spval !Ozone does, sunlit leaf (mmol O3/m^2) allocate (o3uptakesha_p(numpft)) ; o3uptakesha_p(:) = spval !Ozone does, shaded leaf (mmol O3/m^2) ! End allocate Ozone Stress Variables + allocate (irrig_method_p(numpft))! irrigation method + ENDIF ENDIF @@ -134,8 +142,8 @@ END SUBROUTINE allocate_PFTimeVariables SUBROUTINE READ_PFTimeVariables (file_restart) - USE MOD_Namelist, only: DEF_USE_PLANTHYDRAULICS, DEF_USE_OZONESTRESS - use MOD_NetCDFVector + USE MOD_Namelist, only: DEF_USE_PLANTHYDRAULICS, DEF_USE_OZONESTRESS, DEF_USE_IRRIGATION + USE MOD_NetCDFVector USE MOD_LandPFT USE MOD_Vars_Global @@ -143,36 +151,40 @@ SUBROUTINE READ_PFTimeVariables (file_restart) character(LEN=*), intent(in) :: file_restart - call ncio_read_vector (file_restart, 'tleaf_p ', landpft, tleaf_p ) ! - call ncio_read_vector (file_restart, 'ldew_p ', landpft, ldew_p ) ! - call ncio_read_vector (file_restart, 'ldew_rain_p', landpft, ldew_rain_p) !depth of rain on foliage [mm] - call ncio_read_vector (file_restart, 'ldew_snow_p', landpft, ldew_snow_p) !depth of snow on foliage [mm] - call ncio_read_vector (file_restart, 'sigf_p ', landpft, sigf_p ) ! - call ncio_read_vector (file_restart, 'tlai_p ', landpft, tlai_p ) ! - call ncio_read_vector (file_restart, 'lai_p ', landpft, lai_p ) ! -! call ncio_read_vector (file_restart, 'laisun_p ', landpft, laisun_p ) ! -! call ncio_read_vector (file_restart, 'laisha_p ', landpft, laisha_p ) ! - call ncio_read_vector (file_restart, 'tsai_p ', landpft, tsai_p ) ! - call ncio_read_vector (file_restart, 'sai_p ', landpft, sai_p ) ! - call ncio_read_vector (file_restart, 'ssun_p ', 2,2, landpft, ssun_p) ! - call ncio_read_vector (file_restart, 'ssha_p ', 2,2, landpft, ssha_p) ! - call ncio_read_vector (file_restart, 'thermk_p ', landpft, thermk_p ) ! - call ncio_read_vector (file_restart, 'extkb_p ', landpft, extkb_p ) ! - call ncio_read_vector (file_restart, 'extkd_p ', landpft, extkd_p ) ! - call ncio_read_vector (file_restart, 'tref_p ', landpft, tref_p ) ! - call ncio_read_vector (file_restart, 'qref_p ', landpft, qref_p ) ! - call ncio_read_vector (file_restart, 'rst_p ', landpft, rst_p ) ! - call ncio_read_vector (file_restart, 'z0m_p ', landpft, z0m_p ) ! - IF(DEF_USE_PLANTHYDRAULICS)THEN - call ncio_read_vector (file_restart, 'vegwp_p ', nvegwcs, landpft, vegwp_p ) ! - call ncio_read_vector (file_restart, 'gs0sun_p ', landpft, gs0sun_p ) ! - call ncio_read_vector (file_restart, 'gs0sha_p ', landpft, gs0sha_p ) ! - END IF - IF(DEF_USE_OZONESTRESS)THEN - call ncio_read_vector (file_restart, 'lai_old_p ', landpft, lai_old_p , defval = 0._r8) - call ncio_read_vector (file_restart, 'o3uptakesun_p', landpft, o3uptakesun_p, defval = 0._r8) - call ncio_read_vector (file_restart, 'o3uptakesha_p', landpft, o3uptakesha_p, defval = 0._r8) - ENDIF + CALL ncio_read_vector (file_restart, 'tleaf_p ', landpft, tleaf_p ) ! + CALL ncio_read_vector (file_restart, 'ldew_p ', landpft, ldew_p ) ! + CALL ncio_read_vector (file_restart, 'ldew_rain_p', landpft, ldew_rain_p) !depth of rain on foliage [mm] + CALL ncio_read_vector (file_restart, 'ldew_snow_p', landpft, ldew_snow_p) !depth of snow on foliage [mm] + CALL ncio_read_vector (file_restart, 'sigf_p ', landpft, sigf_p ) ! + CALL ncio_read_vector (file_restart, 'tlai_p ', landpft, tlai_p ) ! + CALL ncio_read_vector (file_restart, 'lai_p ', landpft, lai_p ) ! +! CALL ncio_read_vector (file_restart, 'laisun_p ', landpft, laisun_p ) ! +! CALL ncio_read_vector (file_restart, 'laisha_p ', landpft, laisha_p ) ! + CALL ncio_read_vector (file_restart, 'tsai_p ', landpft, tsai_p ) ! + CALL ncio_read_vector (file_restart, 'sai_p ', landpft, sai_p ) ! + CALL ncio_read_vector (file_restart, 'ssun_p ', 2,2, landpft, ssun_p) ! + CALL ncio_read_vector (file_restart, 'ssha_p ', 2,2, landpft, ssha_p) ! + CALL ncio_read_vector (file_restart, 'thermk_p ', landpft, thermk_p ) ! + CALL ncio_read_vector (file_restart, 'fshade_p ', landpft, fshade_p ) ! + CALL ncio_read_vector (file_restart, 'extkb_p ', landpft, extkb_p ) ! + CALL ncio_read_vector (file_restart, 'extkd_p ', landpft, extkd_p ) ! + CALL ncio_read_vector (file_restart, 'tref_p ', landpft, tref_p ) ! + CALL ncio_read_vector (file_restart, 'qref_p ', landpft, qref_p ) ! + CALL ncio_read_vector (file_restart, 'rst_p ', landpft, rst_p ) ! + CALL ncio_read_vector (file_restart, 'z0m_p ', landpft, z0m_p ) ! +IF(DEF_USE_PLANTHYDRAULICS)THEN + CALL ncio_read_vector (file_restart, 'vegwp_p ', nvegwcs, landpft, vegwp_p ) ! + CALL ncio_read_vector (file_restart, 'gs0sun_p ', landpft, gs0sun_p ) ! + CALL ncio_read_vector (file_restart, 'gs0sha_p ', landpft, gs0sha_p ) ! +ENDIF +IF(DEF_USE_OZONESTRESS)THEN + CALL ncio_read_vector (file_restart, 'lai_old_p ', landpft, lai_old_p , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'o3uptakesun_p', landpft, o3uptakesun_p, defval = 0._r8) + CALL ncio_read_vector (file_restart, 'o3uptakesha_p', landpft, o3uptakesha_p, defval = 0._r8) +ENDIF +IF(DEF_USE_IRRIGATION)THEN + CALL ncio_read_vector (file_restart,'irrig_method_p', landpft,irrig_method_p, defval = 1) +ENDIF #ifdef BGC CALL read_BGCPFTimeVariables (file_restart) @@ -182,57 +194,62 @@ END SUBROUTINE READ_PFTimeVariables SUBROUTINE WRITE_PFTimeVariables (file_restart) - use MOD_Namelist, only : DEF_REST_COMPRESS_LEVEL, DEF_USE_PLANTHYDRAULICS, DEF_USE_OZONESTRESS - USE MOD_LandPFT - use MOD_NetCDFVector - USE MOD_Vars_Global - IMPLICIT NONE + USE MOD_Namelist, only : DEF_REST_COMPRESS_LEVEL, DEF_USE_PLANTHYDRAULICS, DEF_USE_OZONESTRESS, & + DEF_USE_IRRIGATION + USE MOD_LandPFT + USE MOD_NetCDFVector + USE MOD_Vars_Global + IMPLICIT NONE - character(LEN=*), intent(in) :: file_restart + character(LEN=*), intent(in) :: file_restart - ! Local variables - integer :: compress + ! Local variables + integer :: compress - compress = DEF_REST_COMPRESS_LEVEL + compress = DEF_REST_COMPRESS_LEVEL - call ncio_create_file_vector (file_restart, landpft) - CALL ncio_define_dimension_vector (file_restart, landpft, 'pft') - CALL ncio_define_dimension_vector (file_restart, landpft, 'band', 2) - CALL ncio_define_dimension_vector (file_restart, landpft, 'rtyp', 2) - if(DEF_USE_PLANTHYDRAULICS)then - CALL ncio_define_dimension_vector (file_restart, landpft, 'vegnodes', nvegwcs) - end if - - call ncio_write_vector (file_restart, 'tleaf_p ', 'pft', landpft, tleaf_p , compress) ! - call ncio_write_vector (file_restart, 'ldew_p ', 'pft', landpft, ldew_p , compress) ! - call ncio_write_vector (file_restart, 'ldew_rain_p', 'pft', landpft, ldew_rain_p, compress) !depth of rain on foliage [mm] - call ncio_write_vector (file_restart, 'ldew_snow_p', 'pft', landpft, ldew_snow_p, compress) !depth of snow on foliage [mm] - call ncio_write_vector (file_restart, 'sigf_p ', 'pft', landpft, sigf_p , compress) ! - call ncio_write_vector (file_restart, 'tlai_p ', 'pft', landpft, tlai_p , compress) ! - call ncio_write_vector (file_restart, 'lai_p ', 'pft', landpft, lai_p , compress) ! -! call ncio_write_vector (file_restart, 'laisun_p ', 'pft', landpft, laisun_p , compress) ! -! call ncio_write_vector (file_restart, 'laisha_p ', 'pft', landpft, laisha_p , compress) ! - call ncio_write_vector (file_restart, 'tsai_p ', 'pft', landpft, tsai_p , compress) ! - call ncio_write_vector (file_restart, 'sai_p ', 'pft', landpft, sai_p , compress) ! - call ncio_write_vector (file_restart, 'ssun_p ', 'band', 2, 'rtyp', 2, 'pft', landpft, ssun_p, compress) ! - call ncio_write_vector (file_restart, 'ssha_p ', 'band', 2, 'rtyp', 2, 'pft', landpft, ssha_p, compress) ! - call ncio_write_vector (file_restart, 'thermk_p ', 'pft', landpft, thermk_p , compress) ! - call ncio_write_vector (file_restart, 'extkb_p ', 'pft', landpft, extkb_p , compress) ! - call ncio_write_vector (file_restart, 'extkd_p ', 'pft', landpft, extkd_p , compress) ! - call ncio_write_vector (file_restart, 'tref_p ', 'pft', landpft, tref_p , compress) ! - call ncio_write_vector (file_restart, 'qref_p ', 'pft', landpft, qref_p , compress) ! - call ncio_write_vector (file_restart, 'rst_p ', 'pft', landpft, rst_p , compress) ! - call ncio_write_vector (file_restart, 'z0m_p ', 'pft', landpft, z0m_p , compress) ! - IF(DEF_USE_PLANTHYDRAULICS)then - call ncio_write_vector (file_restart, 'vegwp_p ' , 'vegnodes', nvegwcs, 'pft', landpft, vegwp_p, compress) - call ncio_write_vector (file_restart, 'gs0sun_p ' , 'pft', landpft, gs0sun_p , compress) ! - call ncio_write_vector (file_restart, 'gs0sha_p ' , 'pft', landpft, gs0sha_p , compress) ! - END IF - IF(DEF_USE_OZONESTRESS)THEN - call ncio_write_vector (file_restart, 'lai_old_p ', 'pft', landpft, lai_old_p , compress) - call ncio_write_vector (file_restart, 'o3uptakesun_p', 'pft', landpft, o3uptakesun_p, compress) - call ncio_write_vector (file_restart, 'o3uptakesha_p', 'pft', landpft, o3uptakesha_p, compress) - ENDIF + CALL ncio_create_file_vector (file_restart, landpft) + CALL ncio_define_dimension_vector (file_restart, landpft, 'pft') + CALL ncio_define_dimension_vector (file_restart, landpft, 'band', 2) + CALL ncio_define_dimension_vector (file_restart, landpft, 'rtyp', 2) +IF(DEF_USE_PLANTHYDRAULICS)THEN + CALL ncio_define_dimension_vector (file_restart, landpft, 'vegnodes', nvegwcs) +ENDIF + + CALL ncio_write_vector (file_restart, 'tleaf_p ', 'pft', landpft, tleaf_p , compress) ! + CALL ncio_write_vector (file_restart, 'ldew_p ', 'pft', landpft, ldew_p , compress) ! + CALL ncio_write_vector (file_restart, 'ldew_rain_p', 'pft', landpft, ldew_rain_p, compress) !depth of rain on foliage [mm] + CALL ncio_write_vector (file_restart, 'ldew_snow_p', 'pft', landpft, ldew_snow_p, compress) !depth of snow on foliage [mm] + CALL ncio_write_vector (file_restart, 'sigf_p ', 'pft', landpft, sigf_p , compress) ! + CALL ncio_write_vector (file_restart, 'tlai_p ', 'pft', landpft, tlai_p , compress) ! + CALL ncio_write_vector (file_restart, 'lai_p ', 'pft', landpft, lai_p , compress) ! +! CALL ncio_write_vector (file_restart, 'laisun_p ', 'pft', landpft, laisun_p , compress) ! +! CALL ncio_write_vector (file_restart, 'laisha_p ', 'pft', landpft, laisha_p , compress) ! + CALL ncio_write_vector (file_restart, 'tsai_p ', 'pft', landpft, tsai_p , compress) ! + CALL ncio_write_vector (file_restart, 'sai_p ', 'pft', landpft, sai_p , compress) ! + CALL ncio_write_vector (file_restart, 'ssun_p ', 'band', 2, 'rtyp', 2, 'pft', landpft, ssun_p, compress) ! + CALL ncio_write_vector (file_restart, 'ssha_p ', 'band', 2, 'rtyp', 2, 'pft', landpft, ssha_p, compress) ! + CALL ncio_write_vector (file_restart, 'thermk_p ', 'pft', landpft, thermk_p , compress) ! + CALL ncio_write_vector (file_restart, 'fshade_p ', 'pft', landpft, fshade_p , compress) ! + CALL ncio_write_vector (file_restart, 'extkb_p ', 'pft', landpft, extkb_p , compress) ! + CALL ncio_write_vector (file_restart, 'extkd_p ', 'pft', landpft, extkd_p , compress) ! + CALL ncio_write_vector (file_restart, 'tref_p ', 'pft', landpft, tref_p , compress) ! + CALL ncio_write_vector (file_restart, 'qref_p ', 'pft', landpft, qref_p , compress) ! + CALL ncio_write_vector (file_restart, 'rst_p ', 'pft', landpft, rst_p , compress) ! + CALL ncio_write_vector (file_restart, 'z0m_p ', 'pft', landpft, z0m_p , compress) ! +IF(DEF_USE_PLANTHYDRAULICS)THEN + CALL ncio_write_vector (file_restart, 'vegwp_p ' , 'vegnodes', nvegwcs, 'pft', landpft, vegwp_p, compress) + CALL ncio_write_vector (file_restart, 'gs0sun_p ' , 'pft', landpft, gs0sun_p , compress) ! + CALL ncio_write_vector (file_restart, 'gs0sha_p ' , 'pft', landpft, gs0sha_p , compress) ! +ENDIF +IF(DEF_USE_OZONESTRESS)THEN + CALL ncio_write_vector (file_restart, 'lai_old_p ', 'pft', landpft, lai_old_p , compress) + CALL ncio_write_vector (file_restart, 'o3uptakesun_p', 'pft', landpft, o3uptakesun_p, compress) + CALL ncio_write_vector (file_restart, 'o3uptakesha_p', 'pft', landpft, o3uptakesha_p, compress) +ENDIF +IF(DEF_USE_IRRIGATION)THEN + CALL ncio_write_vector (file_restart,'irrig_method_p','pft', landpft, irrig_method_p, compress) +ENDIF #ifdef BGC CALL WRITE_BGCPFTimeVariables (file_restart) @@ -264,6 +281,7 @@ SUBROUTINE deallocate_PFTimeVariables deallocate (ssun_p ) !sunlit canopy absorption for solar radiation (0-1) deallocate (ssha_p ) !shaded canopy absorption for solar radiation (0-1) deallocate (thermk_p ) !canopy gap fraction for tir radiation + deallocate (fshade_p ) !canopy gap fraction for tir radiation deallocate (extkb_p ) !(k, g(mu)/mu) direct solar extinction coefficient deallocate (extkd_p ) !diffuse and scattered diffuse PAR extinction coefficient deallocate (tref_p ) !2 m height air temperature [kelvin] @@ -274,7 +292,7 @@ SUBROUTINE deallocate_PFTimeVariables deallocate (vegwp_p ) !vegetation water potential [mm] deallocate (gs0sun_p ) !working copy of sunlit stomata conductance deallocate (gs0sha_p ) !working copy of shalit stomata conductance -! end plant hydraulic variables +! END plant hydraulic variables ! Ozone Stress variables deallocate (o3coefv_sun_p ) !Ozone stress factor for photosynthesis on sunlit leaf deallocate (o3coefv_sha_p ) !Ozone stress factor for photosynthesis on shaded leaf @@ -283,6 +301,7 @@ SUBROUTINE deallocate_PFTimeVariables deallocate (lai_old_p ) !lai in last time step deallocate (o3uptakesun_p ) !Ozone does, sunlit leaf (mmol O3/m^2) deallocate (o3uptakesha_p ) !Ozone does, shaded leaf (mmol O3/m^2) + deallocate (irrig_method_p) ! Ozone Stress variables ENDIF ENDIF @@ -296,45 +315,49 @@ END SUBROUTINE deallocate_PFTimeVariables #ifdef RangeCheck SUBROUTINE check_PFTimeVariables - use MOD_RangeCheck - use MOD_Namelist, only : DEF_USE_PLANTHYDRAULICS, DEF_USE_OZONESTRESS + USE MOD_RangeCheck + USE MOD_Namelist, only : DEF_USE_PLANTHYDRAULICS, DEF_USE_OZONESTRESS, DEF_USE_IRRIGATION IMPLICIT NONE - call check_vector_data ('tleaf_p ', tleaf_p ) ! - call check_vector_data ('ldew_p ', ldew_p ) ! - call check_vector_data ('ldew_rain_p', ldew_rain_p ) !depth of rain on foliage [mm] - call check_vector_data ('ldew_snow_p', ldew_snow_p ) !depth of snow on foliage [mm] - call check_vector_data ('sigf_p ', sigf_p ) ! - call check_vector_data ('tlai_p ', tlai_p ) ! - call check_vector_data ('lai_p ', lai_p ) ! - call check_vector_data ('laisun_p ', lai_p ) ! - call check_vector_data ('laisha_p ', lai_p ) ! - call check_vector_data ('tsai_p ', tsai_p ) ! - call check_vector_data ('sai_p ', sai_p ) ! - call check_vector_data ('ssun_p ', ssun_p ) ! - call check_vector_data ('ssha_p ', ssha_p ) ! - call check_vector_data ('thermk_p ', thermk_p ) ! - call check_vector_data ('extkb_p ', extkb_p ) ! - call check_vector_data ('extkd_p ', extkd_p ) ! - call check_vector_data ('tref_p ', tref_p ) ! - call check_vector_data ('qref_p ', qref_p ) ! - call check_vector_data ('rst_p ', rst_p ) ! - call check_vector_data ('z0m_p ', z0m_p ) ! - IF(DEF_USE_PLANTHYDRAULICS)THEN - call check_vector_data ('vegwp_p ', vegwp_p ) ! - call check_vector_data ('gs0sun_p ', gs0sun_p ) ! - call check_vector_data ('gs0sha_p ', gs0sha_p ) ! - ENDIF - IF(DEF_USE_OZONESTRESS)THEN - call check_vector_data ('o3coefv_sun_p', o3coefv_sun_p) - call check_vector_data ('o3coefv_sha_p', o3coefv_sha_p) - call check_vector_data ('o3coefg_sun_p', o3coefg_sun_p) - call check_vector_data ('o3coefg_sha_p', o3coefg_sha_p) - call check_vector_data ('lai_old_p ', lai_old_p ) - call check_vector_data ('o3uptakesun_p', o3uptakesun_p) - call check_vector_data ('o3uptakesha_p', o3uptakesha_p) - ENDIF + CALL check_vector_data ('tleaf_p ', tleaf_p ) ! + CALL check_vector_data ('ldew_p ', ldew_p ) ! + CALL check_vector_data ('ldew_rain_p', ldew_rain_p ) !depth of rain on foliage [mm] + CALL check_vector_data ('ldew_snow_p', ldew_snow_p ) !depth of snow on foliage [mm] + CALL check_vector_data ('sigf_p ', sigf_p ) ! + CALL check_vector_data ('tlai_p ', tlai_p ) ! + CALL check_vector_data ('lai_p ', lai_p ) ! + CALL check_vector_data ('laisun_p ', lai_p ) ! + CALL check_vector_data ('laisha_p ', lai_p ) ! + CALL check_vector_data ('tsai_p ', tsai_p ) ! + CALL check_vector_data ('sai_p ', sai_p ) ! + CALL check_vector_data ('ssun_p ', ssun_p ) ! + CALL check_vector_data ('ssha_p ', ssha_p ) ! + CALL check_vector_data ('thermk_p ', thermk_p ) ! + CALL check_vector_data ('fshade_p ', fshade_p ) ! + CALL check_vector_data ('extkb_p ', extkb_p ) ! + CALL check_vector_data ('extkd_p ', extkd_p ) ! + CALL check_vector_data ('tref_p ', tref_p ) ! + CALL check_vector_data ('qref_p ', qref_p ) ! + CALL check_vector_data ('rst_p ', rst_p ) ! + CALL check_vector_data ('z0m_p ', z0m_p ) ! +IF(DEF_USE_PLANTHYDRAULICS)THEN + CALL check_vector_data ('vegwp_p ', vegwp_p ) ! + CALL check_vector_data ('gs0sun_p ', gs0sun_p ) ! + CALL check_vector_data ('gs0sha_p ', gs0sha_p ) ! +ENDIF +IF(DEF_USE_OZONESTRESS)THEN + CALL check_vector_data ('o3coefv_sun_p', o3coefv_sun_p) + CALL check_vector_data ('o3coefv_sha_p', o3coefv_sha_p) + CALL check_vector_data ('o3coefg_sun_p', o3coefg_sun_p) + CALL check_vector_data ('o3coefg_sha_p', o3coefg_sha_p) + CALL check_vector_data ('lai_old_p ', lai_old_p ) + CALL check_vector_data ('o3uptakesun_p', o3uptakesun_p) + CALL check_vector_data ('o3uptakesha_p', o3uptakesha_p) +ENDIF +IF(DEF_USE_IRRIGATION)THEN + CALL check_vector_data ('irrig_method_p', irrig_method_p) +ENDIF #ifdef BGC CALL check_BGCPFTimeVariables @@ -347,340 +370,20 @@ END MODULE MOD_Vars_PFTimeVariables #endif - -#if (defined LULC_IGBP_PC) -MODULE MOD_Vars_PCTimeVariables -! ----------------------------------------------------------------- -! !DESCRIPTION: -! Define Plant Community time variables -! -! Added by Hua Yuan, 08/2019 -! ----------------------------------------------------------------- - - USE MOD_Precision - USE MOD_TimeManager - IMPLICIT NONE - SAVE -! ----------------------------------------------------------------- -! Time-varying state variables which reaquired by restart run - - ! for LULC_IGBP_PC - REAL(r8), allocatable :: tleaf_c (:,:) !leaf temperature [K] - REAL(r8), allocatable :: ldew_c (:,:) !depth of water on foliage [mm] -!#ifdef CLM5_INTERCEPTION - real(r8), allocatable :: ldew_rain_c(:,:) !depth of rain on foliage [mm] - real(r8), allocatable :: ldew_snow_c(:,:) !depth of rain on foliage [mm] -!#endif - REAL(r8), allocatable :: sigf_c (:,:) !fraction of veg cover, excluding snow-covered veg [-] - REAL(r8), allocatable :: tlai_c (:,:) !leaf area index - REAL(r8), allocatable :: lai_c (:,:) !leaf area index - REAL(r8), allocatable :: tsai_c (:,:) !stem area index - REAL(r8), allocatable :: sai_c (:,:) !stem area index - REAL(r8), allocatable :: ssun_c (:,:,:,:) !sunlit canopy absorption for solar radiation (0-1) - REAL(r8), allocatable :: ssha_c (:,:,:,:) !shaded canopy absorption for solar radiation (0-1) - REAL(r8), allocatable :: thermk_c (:,:) !canopy gap fraction for tir radiation - REAL(r8), allocatable :: fshade_c (:,:) !canopy gap fraction for tir radiation - REAL(r8), allocatable :: extkb_c (:,:) !(k, g(mu)/mu) direct solar extinction coefficient - REAL(r8), allocatable :: extkd_c (:,:) !diffuse and scattered diffuse PAR extinction coefficient - REAL(r8), allocatable :: rst_c (:,:) !canopy stomatal resistance (s/m) - REAL(r8), allocatable :: z0m_c (:,:) !effective roughness [m] -!Plant Hydraulic parameters - real(r8), allocatable :: vegwp_c (:,:,:) !vegetation water potential [mm] - real(r8), allocatable :: gs0sun_c (:,:) !working copy of sunlit stomata conductance - real(r8), allocatable :: gs0sha_c (:,:) !working copy of shalit stomata conductance -!end plant hydraulic parameters -!Ozone Stress Variables - real(r8), allocatable :: o3coefv_sun_c(:,:) !Ozone stress factor for photosynthesis on sunlit leaf - real(r8), allocatable :: o3coefv_sha_c(:,:) !Ozone stress factor for photosynthesis on shaded leaf - real(r8), allocatable :: o3coefg_sun_c(:,:) !Ozone stress factor for stomata on sunlit leaf - real(r8), allocatable :: o3coefg_sha_c(:,:) !Ozone stress factor for stomata on shaded leaf - real(r8), allocatable :: lai_old_c (:,:) !lai in last time step - real(r8), allocatable :: o3uptakesun_c(:,:) !Ozone does, sunlit leaf (mmol O3/m^2) - real(r8), allocatable :: o3uptakesha_c(:,:) !Ozone does, shaded leaf (mmol O3/m^2) -!End Ozone Stress Variables - -! PUBLIC MEMBER FUNCTIONS: - PUBLIC :: allocate_PCTimeVariables - PUBLIC :: deallocate_PCTimeVariables - PUBLIC :: READ_PCTimeVariables - PUBLIC :: WRITE_PCTimeVariables -#ifdef RangeCheck - PUBLIC :: check_PCTimeVariables -#endif - -! PRIVATE MEMBER FUNCTIONS: - -!----------------------------------------------------------------------- - -CONTAINS - -!----------------------------------------------------------------------- - - SUBROUTINE allocate_PCTimeVariables () -! ------------------------------------------------------ -! Allocates memory for CoLM Plant Community (PC) 1D [numpc] variables -! ------------------------------------------------------ - USE MOD_Precision - USE MOD_Vars_Global - USE MOD_SPMD_Task - USE MOD_LandPC - IMPLICIT NONE - - IF (p_is_worker) THEN - IF (numpc > 0) THEN - allocate (tleaf_c (0:N_PFT-1,numpc)) ; tleaf_c (:,:) = spval !leaf temperature [K] - allocate (ldew_c (0:N_PFT-1,numpc)) ; ldew_c (:,:) = spval !depth of water on foliage [mm] - allocate (ldew_rain_c(0:N_PFT-1,numpc)) ; ldew_rain_c (:,:) = spval !depth of rain on foliage [mm] - allocate (ldew_snow_c(0:N_PFT-1,numpc)) ; ldew_snow_c (:,:) = spval !depth of snow on foliage [mm] - allocate (sigf_c (0:N_PFT-1,numpc)) ; sigf_c (:,:) = spval !fraction of veg cover, excluding snow-covered veg [-] - allocate (tlai_c (0:N_PFT-1,numpc)) ; tlai_c (:,:) = spval !leaf area index - allocate (lai_c (0:N_PFT-1,numpc)) ; lai_c (:,:) = spval !leaf area index - allocate (tsai_c (0:N_PFT-1,numpc)) ; tsai_c (:,:) = spval !stem area index - allocate (sai_c (0:N_PFT-1,numpc)) ; sai_c (:,:) = spval !stem area index - allocate (ssun_c (2,2,0:N_PFT-1,numpc)) ; ssun_c (:,:,:,:) = spval !sunlit canopy absorption for solar radiation (0-1) - allocate (ssha_c (2,2,0:N_PFT-1,numpc)) ; ssha_c (:,:,:,:) = spval !shaded canopy absorption for solar radiation (0-1) - allocate (thermk_c (0:N_PFT-1,numpc)) ; thermk_c (:,:) = spval !canopy gap fraction for tir radiation - allocate (fshade_c (0:N_PFT-1,numpc)) ; fshade_c (:,:) = spval !canopy gap fraction for tir radiation - allocate (extkb_c (0:N_PFT-1,numpc)) ; extkb_c (:,:) = spval !(k, g(mu)/mu) direct solar extinction coefficient - allocate (extkd_c (0:N_PFT-1,numpc)) ; extkd_c (:,:) = spval !diffuse and scattered diffuse PAR extinction coefficient - allocate (rst_c (0:N_PFT-1,numpc)) ; rst_c (:,:) = spval !canopy stomatal resistance (s/m) - allocate (z0m_c (0:N_PFT-1,numpc)) ; z0m_c (:,:) = spval !effective roughness [m] -!Plant Hydraulic parameters; raulic parameters - allocate (vegwp_c(1:nvegwcs,0:N_PFT-1,numpc)); vegwp_c (:,:,:) = spval - allocate (gs0sun_c (0:N_PFT-1,numpc)) ; gs0sun_c (:,:) = spval - allocate (gs0sha_c (0:N_PFT-1,numpc)) ; gs0sha_c (:,:) = spval -!end plant hydraulic parameters -!Ozone Stress Variables - allocate (o3coefv_sun_c(0:N_PFT-1,numpc)) ; o3coefv_sun_c(:,:) = spval !Ozone stress factor for photosynthesis on sunlit leaf - allocate (o3coefv_sha_c(0:N_PFT-1,numpc)) ; o3coefv_sha_c(:,:) = spval !Ozone stress factor for photosynthesis on shaded leaf - allocate (o3coefg_sun_c(0:N_PFT-1,numpc)) ; o3coefg_sun_c(:,:) = spval !Ozone stress factor for stomata on sunlit leaf - allocate (o3coefg_sha_c(0:N_PFT-1,numpc)) ; o3coefg_sha_c(:,:) = spval !Ozone stress factor for stomata on shaded leaf - allocate (lai_old_c (0:N_PFT-1,numpc)) ; lai_old_c (:,:) = spval !lai in last time step - allocate (o3uptakesun_c(0:N_PFT-1,numpc)) ; o3uptakesun_c(:,:) = spval !Ozone does, sunlit leaf (mmol O3/m^2) - allocate (o3uptakesha_c(0:N_PFT-1,numpc)) ; o3uptakesha_c(:,:) = spval !Ozone does, shaded leaf (mmol O3/m^2) -!End Ozone Stress Variables - ENDIF - ENDIF - - END SUBROUTINE allocate_PCTimeVariables - - SUBROUTINE READ_PCTimeVariables (file_restart) - - USE MOD_Vars_Global - use MOD_Namelist, only: DEF_USE_PLANTHYDRAULICS, DEF_USE_OZONESTRESS - use MOD_NetCDFVector - USE MOD_LandPC - IMPLICIT NONE - - character(LEN=*), intent(in) :: file_restart - - call ncio_read_vector (file_restart, 'tleaf_c ', N_PFT, landpc, tleaf_c ) ! - call ncio_read_vector (file_restart, 'ldew_c ', N_PFT, landpc, ldew_c ) ! - call ncio_read_vector (file_restart, 'ldew_rain_c', N_PFT, landpc, ldew_rain_c) !depth of rain on foliage [mm] - call ncio_read_vector (file_restart, 'ldew_snow_c', N_PFT, landpc, ldew_snow_c) !depth of snow on foliage [mm] - call ncio_read_vector (file_restart, 'sigf_c ', N_PFT, landpc, sigf_c ) ! - call ncio_read_vector (file_restart, 'tlai_c ', N_PFT, landpc, tlai_c ) ! - call ncio_read_vector (file_restart, 'lai_c ', N_PFT, landpc, lai_c ) ! - call ncio_read_vector (file_restart, 'tsai_c ', N_PFT, landpc, tsai_c ) ! - call ncio_read_vector (file_restart, 'sai_c ', N_PFT, landpc, sai_c ) ! - call ncio_read_vector (file_restart, 'ssun_c ', 2,2,N_PFT, landpc, ssun_c ) ! - call ncio_read_vector (file_restart, 'ssha_c ', 2,2,N_PFT, landpc, ssha_c ) ! - call ncio_read_vector (file_restart, 'thermk_c ', N_PFT, landpc, thermk_c ) ! - call ncio_read_vector (file_restart, 'fshade_c ', N_PFT, landpc, fshade_c ) ! - call ncio_read_vector (file_restart, 'extkb_c ', N_PFT, landpc, extkb_c ) ! - call ncio_read_vector (file_restart, 'extkd_c ', N_PFT, landpc, extkd_c ) ! - call ncio_read_vector (file_restart, 'rst_c ', N_PFT, landpc, rst_c ) ! - call ncio_read_vector (file_restart, 'z0m_c ', N_PFT, landpc, z0m_c ) ! - if(DEF_USE_PLANTHYDRAULICS)then - call ncio_read_vector (file_restart, 'vegwp_c ', nvegwcs, N_PFT, landpc, vegwp_c ) ! - call ncio_read_vector (file_restart, 'gs0sun_c ', N_PFT, landpc, gs0sun_c ) ! - call ncio_read_vector (file_restart, 'gs0sha_c ', N_PFT, landpc, gs0sha_c ) ! - end if - IF(DEF_USE_OZONESTRESS)THEN -!Ozone Stress Variables - call ncio_read_vector (file_restart, 'o3coefv_sun_c', N_PFT, landpc, o3coefv_sun_c)!Ozone stress factor for photosynthesis on sunlit leaf - call ncio_read_vector (file_restart, 'o3coefv_sha_c', N_PFT, landpc, o3coefv_sha_c) !Ozone stress factor for photosynthesis on shaded leaf - call ncio_read_vector (file_restart, 'o3coefg_sun_c', N_PFT, landpc, o3coefg_sun_c) !Ozone stress factor for stomata on sunlit leaf - call ncio_read_vector (file_restart, 'o3coefg_sha_c', N_PFT, landpc, o3coefg_sha_c) !Ozone stress factor for stomata on shaded leaf - call ncio_read_vector (file_restart, 'lai_old_c ', N_PFT, landpc, lai_old_c ) !lai in last time step - call ncio_read_vector (file_restart, 'o3uptakesun_c', N_PFT, landpc, o3uptakesun_c) !Ozone does, sunlit leaf (mmol O3/m^2) - call ncio_read_vector (file_restart, 'o3uptakesha_c', N_PFT, landpc, o3uptakesha_c) !Ozone does, shaded leaf (mmol O3/m^2) -!End Ozone Stress Variables - ENDIF - - END SUBROUTINE READ_PCTimeVariables - - SUBROUTINE WRITE_PCTimeVariables (file_restart) - - USE MOD_Vars_Global - use MOD_Namelist, only : DEF_REST_COMPRESS_LEVEL, DEF_USE_PLANTHYDRAULICS, DEF_USE_OZONESTRESS - USE MOD_LandPC - use MOD_NetCDFVector - IMPLICIT NONE - - character(LEN=*), intent(in) :: file_restart - - ! Local variables - integer :: compress - - compress = DEF_REST_COMPRESS_LEVEL - - call ncio_create_file_vector (file_restart, landpc ) - CALL ncio_define_dimension_vector (file_restart, landpc, 'pc' ) - CALL ncio_define_dimension_vector (file_restart, landpc, 'pft' , N_PFT) - CALL ncio_define_dimension_vector (file_restart, landpc, 'band', 2 ) - CALL ncio_define_dimension_vector (file_restart, landpc, 'rtyp', 2 ) - if(DEF_USE_PLANTHYDRAULICS)then - CALL ncio_define_dimension_vector (file_restart, landpc, 'vegnodes', nvegwcs) - end if - - call ncio_write_vector (file_restart, 'tleaf_c ', 'pft', N_PFT, 'pc', landpc, tleaf_c , compress) ! - call ncio_write_vector (file_restart, 'ldew_c ', 'pft', N_PFT, 'pc', landpc, ldew_c , compress) ! - call ncio_write_vector (file_restart, 'ldew_rain_c', 'pft', N_PFT, 'pc', landpc, ldew_rain_c, compress) ! depth of rain on foliage [mm] - call ncio_write_vector (file_restart, 'ldew_snow_c', 'pft', N_PFT, 'pc', landpc, ldew_snow_c, compress) ! depth of snow on foliage [mm] - - call ncio_write_vector (file_restart, 'sigf_c ', 'pft', N_PFT, 'pc', landpc, sigf_c , compress) ! - call ncio_write_vector (file_restart, 'tlai_c ', 'pft', N_PFT, 'pc', landpc, tlai_c , compress) ! - call ncio_write_vector (file_restart, 'lai_c ', 'pft', N_PFT, 'pc', landpc, lai_c , compress) ! - call ncio_write_vector (file_restart, 'tsai_c ', 'pft', N_PFT, 'pc', landpc, tsai_c , compress) ! - call ncio_write_vector (file_restart, 'sai_c ', 'pft', N_PFT, 'pc', landpc, sai_c , compress) ! - call ncio_write_vector (file_restart, 'ssun_c ', 'band', 2, 'rtyp', 2, 'pft', N_PFT, 'pc', landpc, ssun_c, compress) ! - call ncio_write_vector (file_restart, 'ssha_c ', 'band', 2, 'rtyp', 2, 'pft', N_PFT, 'pc', landpc, ssha_c, compress) ! - call ncio_write_vector (file_restart, 'thermk_c ', 'pft', N_PFT, 'pc', landpc, thermk_c , compress) ! - call ncio_write_vector (file_restart, 'fshade_c ', 'pft', N_PFT, 'pc', landpc, fshade_c , compress) ! - call ncio_write_vector (file_restart, 'extkb_c ', 'pft', N_PFT, 'pc', landpc, extkb_c , compress) ! - call ncio_write_vector (file_restart, 'extkd_c ', 'pft', N_PFT, 'pc', landpc, extkd_c , compress) ! - call ncio_write_vector (file_restart, 'rst_c ', 'pft', N_PFT, 'pc', landpc, rst_c , compress) ! - call ncio_write_vector (file_restart, 'z0m_c ', 'pft', N_PFT, 'pc', landpc, z0m_c , compress) ! - if(DEF_USE_PLANTHYDRAULICS)then - call ncio_write_vector (file_restart, 'vegwp_c ', 'vegnodes', nvegwcs, 'pft', N_PFT , 'pc' , landpc, vegwp_c, compress) - call ncio_write_vector (file_restart, 'gs0sun_c ', 'pft' , N_PFT , 'pc' , landpc, gs0sun_c, compress) ! - call ncio_write_vector (file_restart, 'gs0sha_c ', 'pft' , N_PFT , 'pc' , landpc, gs0sha_c, compress) ! - end if - IF(DEF_USE_OZONESTRESS)THEN -!Ozone Stress Variables - call ncio_write_vector (file_restart, 'o3coefv_sun_c', 'pft' , N_PFT , 'pc' , landpc, o3coefv_sun_c, compress)!Ozone stress factor for photosynthesis on sunlit leaf - call ncio_write_vector (file_restart, 'o3coefv_sha_c', 'pft' , N_PFT , 'pc' , landpc, o3coefv_sha_c, compress) !Ozone stress factor for photosynthesis on shaded leaf - call ncio_write_vector (file_restart, 'o3coefg_sun_c', 'pft' , N_PFT , 'pc' , landpc, o3coefg_sun_c, compress) !Ozone stress factor for stomata on sunlit leaf - call ncio_write_vector (file_restart, 'o3coefg_sha_c', 'pft' , N_PFT , 'pc' , landpc, o3coefg_sha_c, compress) !Ozone stress factor for stomata on shaded leaf - call ncio_write_vector (file_restart, 'lai_old_c ', 'pft' , N_PFT , 'pc' , landpc, lai_old_c , compress) !lai in last time step - call ncio_write_vector (file_restart, 'o3uptakesun_c', 'pft' , N_PFT , 'pc' , landpc, o3uptakesun_c, compress) !Ozone does, sunlit leaf (mmol O3/m^2) - call ncio_write_vector (file_restart, 'o3uptakesha_c', 'pft' , N_PFT , 'pc' , landpc, o3uptakesha_c, compress) !Ozone does, shaded leaf (mmol O3/m^2) - ENDIF - - END SUBROUTINE WRITE_PCTimeVariables - - - SUBROUTINE deallocate_PCTimeVariables -! -------------------------------------------------- -! Deallocates memory for CoLM Plant Community (PC) 1D [numpc] variables -! -------------------------------------------------- - - USE MOD_SPMD_Task - USE MOD_LandPC - - IF (p_is_worker) THEN - IF (numpc > 0) THEN - deallocate (tleaf_c ) !leaf temperature [K] - deallocate (ldew_c ) !depth of water on foliage [mm] - deallocate (ldew_rain_c ) !depth of water on foliage [mm] - deallocate (ldew_snow_c ) !depth of water on foliage [mm] - deallocate (sigf_c ) !fraction of veg cover, excluding snow-covered veg [-] - deallocate (tlai_c ) !leaf area index - deallocate (lai_c ) !leaf area index - deallocate (tsai_c ) !stem area index - deallocate (sai_c ) !stem area index - deallocate (ssun_c ) !sunlit canopy absorption for solar radiation (0-1) - deallocate (ssha_c ) !shaded canopy absorption for solar radiation (0-1) - deallocate (thermk_c ) !canopy gap fraction for tir radiation - deallocate (fshade_c ) !canopy gap fraction for tir radiation - deallocate (extkb_c ) !(k, g(mu)/mu) direct solar extinction coefficient - deallocate (extkd_c ) !diffuse and scattered diffuse PAR extinction coefficient - deallocate (rst_c ) !canopy stomatal resistance (s/m) - deallocate (z0m_c ) !effective roughness [m] -!Plant Hydraulic parameters - deallocate (vegwp_c ) !vegetation water potential [mm] - deallocate (gs0sun_c ) !working copy of sunlit stomata conductance - deallocate (gs0sha_c ) !working copy of shalit stomata conductance -!end plant hydraulic parameters -!Ozone Stress Variables - deallocate (o3coefv_sun_c) !Ozone stress factor for photosynthesis on sunlit leaf - deallocate (o3coefv_sha_c) !Ozone stress factor for photosynthesis on shaded leaf - deallocate (o3coefg_sun_c) !Ozone stress factor for stomata on sunlit leaf - deallocate (o3coefg_sha_c) !Ozone stress factor for stomata on shaded leaf - deallocate (lai_old_c ) !lai in last time step - deallocate (o3uptakesun_c) !Ozone does, sunlit leaf (mmol O3/m^2) - deallocate (o3uptakesha_c) !Ozone does, shaded leaf (mmol O3/m^2) -!End Ozone Stress Variables - ENDIF - ENDIF - - END SUBROUTINE deallocate_PCTimeVariables - -#ifdef RangeCheck - SUBROUTINE check_PCTimeVariables - - use MOD_RangeCheck - use MOD_Namelist, only: DEF_USE_PLANTHYDRAULICS, DEF_USE_OZONESTRESS - IMPLICIT NONE - - call check_vector_data ('tleaf_c ', tleaf_c ) ! - call check_vector_data ('ldew_c ', ldew_c ) ! - call check_vector_data ('ldew_rain_c', ldew_rain_c) ! depth of rain on foliage [mm] - call check_vector_data ('ldew_snow_c', ldew_snow_c) ! depth of snow on foliage [mm] - call check_vector_data ('sigf_c ', sigf_c ) ! - call check_vector_data ('tlai_c ', tlai_c ) ! - call check_vector_data ('lai_c ', lai_c ) ! - call check_vector_data ('tsai_c ', tsai_c ) ! - call check_vector_data ('sai_c ', sai_c ) ! - call check_vector_data ('ssun_c ', ssun_c ) ! - call check_vector_data ('ssha_c ', ssha_c ) ! - call check_vector_data ('thermk_c ', thermk_c ) ! - call check_vector_data ('fshade_c ', fshade_c ) ! - call check_vector_data ('extkb_c ', extkb_c ) ! - call check_vector_data ('extkd_c ', extkd_c ) ! - call check_vector_data ('rst_c ', rst_c ) ! - call check_vector_data ('z0m_c ', z0m_c ) ! - if(DEF_USE_PLANTHYDRAULICS)then - call check_vector_data ('vegwp_c ', vegwp_c ) ! - call check_vector_data ('gs0sun_c ', gs0sun_c ) ! - call check_vector_data ('gs0sha_c ', gs0sha_c ) ! - end if - IF(DEF_USE_OZONESTRESS)THEN - call check_vector_data ('o3coefv_sun_c', o3coefv_sun_c) !Ozone stress factor for photosynthesis on sunlit leaf - call check_vector_data ('o3coefv_sha_c', o3coefv_sha_c) !Ozone stress factor for photosynthesis on shaded leaf - call check_vector_data ('o3coefg_sun_c', o3coefg_sun_c) !Ozone stress factor for stomata on sunlit leaf - call check_vector_data ('o3coefg_sha_c', o3coefg_sha_c) !Ozone stress factor for stomata on shaded leaf - call check_vector_data ('lai_old_c ', lai_old_c ) !lai in last time step - call check_vector_data ('o3uptakesun_c', o3uptakesun_c) !Ozone does, sunlit leaf (mmol O3/m^2) - call check_vector_data ('o3uptakesha_c', o3uptakesha_c) !Ozone does, shaded leaf (mmol O3/m^2) - END IF - - END SUBROUTINE check_PCTimeVariables -#endif - -END MODULE MOD_Vars_PCTimeVariables -#endif - - - MODULE MOD_Vars_TimeVariables ! ------------------------------- ! Created by Yongjiu Dai, 03/2014 ! ------------------------------- - use MOD_Precision - use MOD_TimeManager -#ifdef LULC_IGBP_PFT + USE MOD_Precision + USE MOD_TimeManager +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) USE MOD_Vars_PFTimeVariables #endif -#ifdef LULC_IGBP_PC - USE MOD_Vars_PCTimeVariables -#endif #ifdef BGC USE MOD_BGC_Vars_TimeVariables #endif -#ifdef LATERAL_FLOW +#ifdef CatchLateralFlow USE MOD_Hydro_Vars_TimeVariables #endif #ifdef URBAN_MODEL @@ -691,107 +394,133 @@ MODULE MOD_Vars_TimeVariables SAVE ! ----------------------------------------------------------------- ! Time-varying state variables which reaquired by restart run - real(r8), allocatable :: z_sno (:,:) ! node depth [m] - real(r8), allocatable :: dz_sno (:,:) ! interface depth [m] - real(r8), allocatable :: t_soisno (:,:) ! soil temperature [K] - real(r8), allocatable :: wliq_soisno(:,:) ! liquid water in layers [kg/m2] - real(r8), allocatable :: wice_soisno(:,:) ! ice lens in layers [kg/m2] - real(r8), allocatable :: h2osoi (:,:) ! volumetric soil water in layers [m3/m3] - real(r8), allocatable :: smp (:,:) ! soil matrix potential [mm] - real(r8), allocatable :: hk (:,:) ! hydraulic conductivity [mm h2o/s] - real(r8), allocatable :: rootr(:,:) ! water exchange between soil and root. Positive: soil->root [?] + real(r8), allocatable :: z_sno (:,:) ! node depth [m] + real(r8), allocatable :: dz_sno (:,:) ! interface depth [m] + real(r8), allocatable :: t_soisno (:,:) ! soil temperature [K] + real(r8), allocatable :: wliq_soisno (:,:) ! liquid water in layers [kg/m2] + real(r8), allocatable :: wice_soisno (:,:) ! ice lens in layers [kg/m2] + real(r8), allocatable :: h2osoi (:,:) ! volumetric soil water in layers [m3/m3] + real(r8), allocatable :: smp (:,:) ! soil matrix potential [mm] + real(r8), allocatable :: hk (:,:) ! hydraulic conductivity [mm h2o/s] + real(r8), allocatable :: rootr (:,:) ! transpiration contribution fraction from different layers + real(r8), allocatable :: rootflux (:,:) ! water exchange between soil and root. Positive: soil->root [?] !Plant Hydraulic variables - real(r8), allocatable :: vegwp(:,:) ! vegetation water potential [mm] - real(r8), allocatable :: gs0sun (:) ! working copy of sunlit stomata conductance - real(r8), allocatable :: gs0sha (:) ! working copy of shalit stomata conductance -!end plant hydraulic variables + real(r8), allocatable :: vegwp (:,:) ! vegetation water potential [mm] + real(r8), allocatable :: gs0sun (:) ! working copy of sunlit stomata conductance + real(r8), allocatable :: gs0sha (:) ! working copy of shalit stomata conductance +!END plant hydraulic variables !Ozone stress variables - real(r8), allocatable :: o3coefv_sun (:) ! Ozone stress factor for photosynthesis on sunlit leaf - real(r8), allocatable :: o3coefv_sha (:) ! Ozone stress factor for photosynthesis on shaded leaf - real(r8), allocatable :: o3coefg_sun (:) ! Ozone stress factor for stomata on sunlit leaf - real(r8), allocatable :: o3coefg_sha (:) ! Ozone stress factor for stomata on shaded leaf - real(r8), allocatable :: lai_old (:) ! lai in last time step - real(r8), allocatable :: o3uptakesun (:) ! Ozone does, sunlit leaf (mmol O3/m^2) - real(r8), allocatable :: o3uptakesha (:) ! Ozone does, shaded leaf (mmol O3/m^2) + real(r8), allocatable :: o3coefv_sun (:) ! Ozone stress factor for photosynthesis on sunlit leaf + real(r8), allocatable :: o3coefv_sha (:) ! Ozone stress factor for photosynthesis on shaded leaf + real(r8), allocatable :: o3coefg_sun (:) ! Ozone stress factor for stomata on sunlit leaf + real(r8), allocatable :: o3coefg_sha (:) ! Ozone stress factor for stomata on shaded leaf + real(r8), allocatable :: lai_old (:) ! lai in last time step + real(r8), allocatable :: o3uptakesun (:) ! Ozone does, sunlit leaf (mmol O3/m^2) + real(r8), allocatable :: o3uptakesha (:) ! Ozone does, shaded leaf (mmol O3/m^2) !End ozone stress variables - real(r8), allocatable :: rstfacsun_out(:) ! factor of soil water stress on sunlit leaf - real(r8), allocatable :: rstfacsha_out(:) ! factor of soil water stress on shaded leaf - real(r8), allocatable :: gssun_out (:) ! stomata conductance on sunlit leaf - real(r8), allocatable :: gssha_out (:) ! stomata conductance on shaded leaf - real(r8), allocatable :: t_grnd (:) ! ground surface temperature [K] - - real(r8), allocatable :: assimsun_out (:) !1 - real(r8), allocatable :: assimsha_out (:) !1 - real(r8), allocatable :: etrsun_out (:) !1 - real(r8), allocatable :: etrsha_out (:) !1 - - real(r8), allocatable :: tleaf (:) ! leaf temperature [K] - real(r8), allocatable :: ldew (:) ! depth of water on foliage [mm] - real(r8), allocatable :: ldew_rain (:) ! depth of rain on foliage [mm] - real(r8), allocatable :: ldew_snow (:) ! depth of rain on foliage [mm] - real(r8), allocatable :: sag (:) ! non dimensional snow age [-] - real(r8), allocatable :: scv (:) ! snow cover, water equivalent [mm] - real(r8), allocatable :: snowdp (:) ! snow depth [meter] - real(r8), allocatable :: fveg (:) ! fraction of vegetation cover - real(r8), allocatable :: fsno (:) ! fraction of snow cover on ground - real(r8), allocatable :: sigf (:) ! fraction of veg cover, excluding snow-covered veg [-] - real(r8), allocatable :: green (:) ! leaf greenness - real(r8), allocatable :: tlai (:) ! leaf area index - real(r8), allocatable :: lai (:) ! leaf area index - real(r8), allocatable :: laisun (:) ! leaf area index for sunlit leaf - real(r8), allocatable :: laisha (:) ! leaf area index for shaded leaf - real(r8), allocatable :: tsai (:) ! stem area index - real(r8), allocatable :: sai (:) ! stem area index - real(r8), allocatable :: coszen (:) ! cosine of solar zenith angle - real(r8), allocatable :: alb (:,:,:) ! averaged albedo [-] - real(r8), allocatable :: ssun (:,:,:) ! sunlit canopy absorption for solar radiation (0-1) - real(r8), allocatable :: ssha (:,:,:) ! shaded canopy absorption for solar radiation (0-1) - real(r8), allocatable :: thermk (:) ! canopy gap fraction for tir radiation - real(r8), allocatable :: extkb (:) ! (k, g(mu)/mu) direct solar extinction coefficient - real(r8), allocatable :: extkd (:) ! diffuse and scattered diffuse PAR extinction coefficient - real(r8), allocatable :: zwt (:) ! the depth to water table [m] - real(r8), allocatable :: wa (:) ! water storage in aquifer [mm] - real(r8), allocatable :: wat (:) ! total water storage [mm] - real(r8), allocatable :: wdsrf (:) ! depth of surface water [mm] - - real(r8), allocatable :: t_lake (:,:) ! lake layer teperature [K] - real(r8), allocatable :: lake_icefrac(:,:)! lake mass fraction of lake layer that is frozen - real(r8), allocatable :: savedtke1 (:) ! top level eddy conductivity (W/m K) - - REAL(r8), allocatable :: snw_rds (:,:) ! effective grain radius (col,lyr) [microns, m-6] - REAL(r8), allocatable :: mss_bcpho (:,:) ! mass of hydrophobic BC in snow (col,lyr) [kg] - REAL(r8), allocatable :: mss_bcphi (:,:) ! mass of hydrophillic BC in snow (col,lyr) [kg] - REAL(r8), allocatable :: mss_ocpho (:,:) ! mass of hydrophobic OC in snow (col,lyr) [kg] - REAL(r8), allocatable :: mss_ocphi (:,:) ! mass of hydrophillic OC in snow (col,lyr) [kg] - REAL(r8), allocatable :: mss_dst1 (:,:) ! mass of dust species 1 in snow (col,lyr) [kg] - REAL(r8), allocatable :: mss_dst2 (:,:) ! mass of dust species 2 in snow (col,lyr) [kg] - REAL(r8), allocatable :: mss_dst3 (:,:) ! mass of dust species 3 in snow (col,lyr) [kg] - REAL(r8), allocatable :: mss_dst4 (:,:) ! mass of dust species 4 in snow (col,lyr) [kg] - REAL(r8), allocatable :: ssno (:,:,:,:) ! snow layer absorption [-] - - real(r8), allocatable :: trad (:) ! radiative temperature of surface [K] - real(r8), allocatable :: tref (:) ! 2 m height air temperature [kelvin] - real(r8), allocatable :: qref (:) ! 2 m height air specific humidity - real(r8), allocatable :: rst (:) ! canopy stomatal resistance (s/m) - real(r8), allocatable :: emis (:) ! averaged bulk surface emissivity - real(r8), allocatable :: z0m (:) ! effective roughness [m] - real(r8), allocatable :: displa (:) ! zero displacement height [m] - real(r8), allocatable :: zol (:) ! dimensionless height (z/L) used in Monin-Obukhov theory - real(r8), allocatable :: rib (:) ! bulk Richardson number in surface layer - real(r8), allocatable :: ustar (:) ! u* in similarity theory [m/s] - real(r8), allocatable :: qstar (:) ! q* in similarity theory [kg/kg] - real(r8), allocatable :: tstar (:) ! t* in similarity theory [K] - real(r8), allocatable :: fm (:) ! integral of profile function for momentum - real(r8), allocatable :: fh (:) ! integral of profile function for heat - real(r8), allocatable :: fq (:) ! integral of profile function for moisture - + real(r8), allocatable :: rstfacsun_out (:) ! factor of soil water stress on sunlit leaf + real(r8), allocatable :: rstfacsha_out (:) ! factor of soil water stress on shaded leaf + real(r8), allocatable :: gssun_out (:) ! stomata conductance on sunlit leaf + real(r8), allocatable :: gssha_out (:) ! stomata conductance on shaded leaf + real(r8), allocatable :: t_grnd (:) ! ground surface temperature [K] + + real(r8), allocatable :: assimsun_out (:) ! diagnostic sunlit leaf assim value for output + real(r8), allocatable :: assimsha_out (:) ! diagnostic sunlit leaf etr value for output + real(r8), allocatable :: etrsun_out (:) ! diagnostic shaded leaf assim for output + real(r8), allocatable :: etrsha_out (:) ! diagnostic shaded leaf etr for output + + real(r8), allocatable :: tleaf (:) ! leaf temperature [K] + real(r8), allocatable :: ldew (:) ! depth of water on foliage [mm] + real(r8), allocatable :: ldew_rain (:) ! depth of rain on foliage [mm] + real(r8), allocatable :: ldew_snow (:) ! depth of rain on foliage [mm] + real(r8), allocatable :: sag (:) ! non dimensional snow age [-] + real(r8), allocatable :: scv (:) ! snow cover, water equivalent [mm] + real(r8), allocatable :: snowdp (:) ! snow depth [meter] + real(r8), allocatable :: fveg (:) ! fraction of vegetation cover + real(r8), allocatable :: fsno (:) ! fraction of snow cover on ground + real(r8), allocatable :: sigf (:) ! fraction of veg cover, excluding snow-covered veg [-] + real(r8), allocatable :: green (:) ! leaf greenness + real(r8), allocatable :: tlai (:) ! leaf area index + real(r8), allocatable :: lai (:) ! leaf area index + real(r8), allocatable :: laisun (:) ! leaf area index for sunlit leaf + real(r8), allocatable :: laisha (:) ! leaf area index for shaded leaf + real(r8), allocatable :: tsai (:) ! stem area index + real(r8), allocatable :: sai (:) ! stem area index + real(r8), allocatable :: coszen (:) ! cosine of solar zenith angle + real(r8), allocatable :: alb (:,:,:) ! averaged albedo [-] + real(r8), allocatable :: ssun (:,:,:) ! sunlit canopy absorption for solar radiation (0-1) + real(r8), allocatable :: ssha (:,:,:) ! shaded canopy absorption for solar radiation (0-1) + real(r8), allocatable :: ssoi (:,:,:) ! soil absorption for solar radiation (0-1) + real(r8), allocatable :: ssno (:,:,:) ! snow absorption for solar radiation (0-1) + real(r8), allocatable :: thermk (:) ! canopy gap fraction for tir radiation + real(r8), allocatable :: extkb (:) ! (k, g(mu)/mu) direct solar extinction coefficient + real(r8), allocatable :: extkd (:) ! diffuse and scattered diffuse PAR extinction coefficient + real(r8), allocatable :: zwt (:) ! the depth to water table [m] + real(r8), allocatable :: wa (:) ! water storage in aquifer [mm] + real(r8), allocatable :: wetwat (:) ! water storage in wetland [mm] + real(r8), allocatable :: wat (:) ! total water storage [mm] + real(r8), allocatable :: wdsrf (:) ! depth of surface water [mm] + real(r8), allocatable :: rss (:) ! soil surface resistance [s/m] + + real(r8), allocatable :: t_lake (:,:) ! lake layer teperature [K] + real(r8), allocatable :: lake_icefrac(:,:) ! lake mass fraction of lake layer that is frozen + real(r8), allocatable :: savedtke1 (:) ! top level eddy conductivity (W/m K) + + real(r8), allocatable :: snw_rds (:,:) ! effective grain radius (col,lyr) [microns, m-6] + real(r8), allocatable :: mss_bcpho (:,:) ! mass of hydrophobic BC in snow (col,lyr) [kg] + real(r8), allocatable :: mss_bcphi (:,:) ! mass of hydrophillic BC in snow (col,lyr) [kg] + real(r8), allocatable :: mss_ocpho (:,:) ! mass of hydrophobic OC in snow (col,lyr) [kg] + real(r8), allocatable :: mss_ocphi (:,:) ! mass of hydrophillic OC in snow (col,lyr) [kg] + real(r8), allocatable :: mss_dst1 (:,:) ! mass of dust species 1 in snow (col,lyr) [kg] + real(r8), allocatable :: mss_dst2 (:,:) ! mass of dust species 2 in snow (col,lyr) [kg] + real(r8), allocatable :: mss_dst3 (:,:) ! mass of dust species 3 in snow (col,lyr) [kg] + real(r8), allocatable :: mss_dst4 (:,:) ! mass of dust species 4 in snow (col,lyr) [kg] + real(r8), allocatable :: ssno_lyr(:,:,:,:) ! snow layer absorption [-] + + real(r8), allocatable :: trad (:) ! radiative temperature of surface [K] + real(r8), allocatable :: tref (:) ! 2 m height air temperature [kelvin] + real(r8), allocatable :: qref (:) ! 2 m height air specific humidity + real(r8), allocatable :: rst (:) ! canopy stomatal resistance (s/m) + real(r8), allocatable :: emis (:) ! averaged bulk surface emissivity + real(r8), allocatable :: z0m (:) ! effective roughness [m] + real(r8), allocatable :: displa (:) ! zero displacement height [m] + real(r8), allocatable :: zol (:) ! dimensionless height (z/L) used in Monin-Obukhov theory + real(r8), allocatable :: rib (:) ! bulk Richardson number in surface layer + real(r8), allocatable :: ustar (:) ! u* in similarity theory [m/s] + real(r8), allocatable :: qstar (:) ! q* in similarity theory [kg/kg] + real(r8), allocatable :: tstar (:) ! t* in similarity theory [K] + real(r8), allocatable :: fm (:) ! integral of profile function for momentum + real(r8), allocatable :: fh (:) ! integral of profile function for heat + real(r8), allocatable :: fq (:) ! integral of profile function for moisture + + real(r8), allocatable :: irrig_rate (:) ! irrigation rate [mm s-1] + real(r8), allocatable :: deficit_irrig (:) ! irrigation amount [kg/m2] + real(r8), allocatable :: sum_irrig (:) ! total irrigation amount [kg/m2] + real(r8), allocatable :: sum_irrig_count (:) ! total irrigation counts [-] + integer , allocatable :: n_irrig_steps_left (:) ! left steps for once irrigation [-] + real(r8), allocatable :: tairday (:) ! daily mean temperature [degree C] + real(r8), allocatable :: usday (:) ! daily mean wind component in eastward direction [m/s] + real(r8), allocatable :: vsday (:) ! daily mean wind component in northward direction [m/s] + real(r8), allocatable :: pairday (:) ! daily mean pressure [kPa] + real(r8), allocatable :: rnetday (:) ! daily net radiation flux [MJ/m2/day] + real(r8), allocatable :: fgrndday (:) ! daily ground heat flux [MJ/m2/day] + real(r8), allocatable :: potential_evapotranspiration (:) ! daily potential evapotranspiration [mm/day] + + integer , allocatable :: irrig_method_corn (:) ! irrigation method for corn (0-3) + integer , allocatable :: irrig_method_swheat (:) ! irrigation method for spring wheat (0-3) + integer , allocatable :: irrig_method_wwheat (:) ! irrigation method for winter wheat (0-3) + integer , allocatable :: irrig_method_soybean (:) ! irrigation method for soybean (0-3) + integer , allocatable :: irrig_method_cotton (:) ! irrigation method for cotton (0-3) + integer , allocatable :: irrig_method_rice1 (:) ! irrigation method for rice1 (0-3) + integer , allocatable :: irrig_method_rice2 (:) ! irrigation method for rice2 (0-3) + integer , allocatable :: irrig_method_sugarcane (:) ! irrigation method for sugarcane (0-3) ! PUBLIC MEMBER FUNCTIONS: - public :: allocate_TimeVariables - public :: deallocate_TimeVariables - public :: READ_TimeVariables - public :: WRITE_TimeVariables + PUBLIC :: allocate_TimeVariables + PUBLIC :: deallocate_TimeVariables + PUBLIC :: READ_TimeVariables + PUBLIC :: WRITE_TimeVariables #ifdef RangeCheck - public :: check_TimeVariables + PUBLIC :: check_TimeVariables #endif @@ -806,16 +535,16 @@ SUBROUTINE allocate_TimeVariables ! Allocates memory for CoLM 1d [numpatch] variables ! ------------------------------------------------------ - use MOD_Precision + USE MOD_Precision USE MOD_Vars_Global - use MOD_SPMD_Task - use MOD_LandPatch, only: numpatch + USE MOD_SPMD_Task + USE MOD_LandPatch, only: numpatch IMPLICIT NONE - if (p_is_worker) then + IF (p_is_worker) THEN - if (numpatch > 0) then + IF (numpatch > 0) THEN allocate (z_sno (maxsnl+1:0, numpatch)); z_sno (:,:) = spval allocate (dz_sno (maxsnl+1:0, numpatch)); dz_sno (:,:) = spval @@ -826,11 +555,12 @@ SUBROUTINE allocate_TimeVariables allocate (hk (1:nl_soil,numpatch)); hk (:,:) = spval allocate (h2osoi (1:nl_soil,numpatch)); h2osoi (:,:) = spval allocate (rootr (1:nl_soil,numpatch)); rootr (:,:) = spval + allocate (rootflux (1:nl_soil,numpatch)); rootflux (:,:) = spval !Plant Hydraulic variables allocate (vegwp (1:nvegwcs,numpatch)); vegwp (:,:) = spval allocate (gs0sun (numpatch)); gs0sun (:) = spval allocate (gs0sha (numpatch)); gs0sha (:) = spval -!end plant hydraulic variables +!END plant hydraulic variables !Ozone Stress variables allocate (o3coefv_sun (numpatch)); o3coefv_sun (:) = spval allocate (o3coefv_sha (numpatch)); o3coefv_sha (:) = spval @@ -840,6 +570,7 @@ SUBROUTINE allocate_TimeVariables allocate (o3uptakesun (numpatch)); o3uptakesun (:) = spval allocate (o3uptakesha (numpatch)); o3uptakesha (:) = spval !End ozone stress variables + allocate (rstfacsun_out (numpatch)); rstfacsun_out (:) = spval allocate (rstfacsha_out (numpatch)); rstfacsha_out (:) = spval allocate (gssun_out (numpatch)); gssun_out (:) = spval @@ -871,14 +602,17 @@ SUBROUTINE allocate_TimeVariables allocate (alb (2,2,numpatch)); alb (:,:,:) = spval allocate (ssun (2,2,numpatch)); ssun (:,:,:) = spval allocate (ssha (2,2,numpatch)); ssha (:,:,:) = spval + allocate (ssoi (2,2,numpatch)); ssoi (:,:,:) = spval + allocate (ssno (2,2,numpatch)); ssno (:,:,:) = spval allocate (thermk (numpatch)); thermk (:) = spval allocate (extkb (numpatch)); extkb (:) = spval allocate (extkd (numpatch)); extkd (:) = spval allocate (zwt (numpatch)); zwt (:) = spval allocate (wa (numpatch)); wa (:) = spval + allocate (wetwat (numpatch)); wetwat (:) = spval allocate (wat (numpatch)); wat (:) = spval allocate (wdsrf (numpatch)); wdsrf (:) = spval - + allocate (rss (numpatch)); rss (:) = spval allocate (t_lake (nl_lake,numpatch)); t_lake (:,:) = spval allocate (lake_icefrac (nl_lake,numpatch)); lake_icefrac(:,:) = spval allocate (savedtke1 (numpatch)); savedtke1 (:) = spval @@ -892,7 +626,7 @@ SUBROUTINE allocate_TimeVariables allocate (mss_dst2 (maxsnl+1:0,numpatch)); mss_dst2 (:,:) = spval allocate (mss_dst3 (maxsnl+1:0,numpatch)); mss_dst3 (:,:) = spval allocate (mss_dst4 (maxsnl+1:0,numpatch)); mss_dst4 (:,:) = spval - allocate (ssno (2,2,maxsnl+1:1,numpatch)); ssno (:,:,:,:) = spval + allocate (ssno_lyr (2,2,maxsnl+1:1,numpatch)); ssno_lyr(:,:,:,:) = spval allocate (trad (numpatch)); trad (:) = spval allocate (tref (numpatch)); tref (:) = spval @@ -910,22 +644,40 @@ SUBROUTINE allocate_TimeVariables allocate (fh (numpatch)); fh (:) = spval allocate (fq (numpatch)); fq (:) = spval - end if - end if - -#ifdef LULC_IGBP_PFT + allocate ( irrig_rate (numpatch)); irrig_rate (:) = spval + allocate ( deficit_irrig (numpatch)); deficit_irrig (:) = spval + allocate ( sum_irrig (numpatch)); sum_irrig (:) = spval + allocate ( sum_irrig_count (numpatch)); sum_irrig_count (:) = spval + allocate ( n_irrig_steps_left (numpatch)); n_irrig_steps_left (:) = spval_i4 + allocate ( tairday (numpatch)); tairday (:) = spval + allocate ( usday (numpatch)); usday (:) = spval + allocate ( vsday (numpatch)); vsday (:) = spval + allocate ( pairday (numpatch)); pairday (:) = spval + allocate ( rnetday (numpatch)); rnetday (:) = spval + allocate ( fgrndday (numpatch)); fgrndday (:) = spval + allocate ( potential_evapotranspiration(numpatch)); potential_evapotranspiration(:) = spval + + allocate ( irrig_method_corn (numpatch)); irrig_method_corn (:) = spval_i4 + allocate ( irrig_method_swheat (numpatch)); irrig_method_swheat (:) = spval_i4 + allocate ( irrig_method_wwheat (numpatch)); irrig_method_wwheat (:) = spval_i4 + allocate ( irrig_method_soybean (numpatch)); irrig_method_soybean (:) = spval_i4 + allocate ( irrig_method_cotton (numpatch)); irrig_method_cotton (:) = spval_i4 + allocate ( irrig_method_rice1 (numpatch)); irrig_method_rice1 (:) = spval_i4 + allocate ( irrig_method_rice2 (numpatch)); irrig_method_rice2 (:) = spval_i4 + allocate ( irrig_method_sugarcane (numpatch)); irrig_method_sugarcane (:) = spval_i4 + + ENDIF + ENDIF + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) CALL allocate_PFTimeVariables #endif -#ifdef LULC_IGBP_PC - CALL allocate_PCTimeVariables -#endif - #ifdef BGC CALL allocate_BGCTimeVariables #endif -#ifdef LATERAL_FLOW +#ifdef CatchLateralFlow CALL allocate_HydroTimeVariables #endif @@ -939,17 +691,17 @@ END SUBROUTINE allocate_TimeVariables SUBROUTINE deallocate_TimeVariables () - use MOD_SPMD_Task - use MOD_LandPatch, only: numpatch - implicit none + USE MOD_SPMD_Task + USE MOD_LandPatch, only: numpatch + IMPLICIT NONE ! -------------------------------------------------- ! Deallocates memory for CoLM 1d [numpatch] variables ! -------------------------------------------------- - if (p_is_worker) then + IF (p_is_worker) THEN - if (numpatch > 0) then + IF (numpatch > 0) THEN deallocate (z_sno ) deallocate (dz_sno ) @@ -960,6 +712,7 @@ SUBROUTINE deallocate_TimeVariables () deallocate (hk ) deallocate (h2osoi ) deallocate (rootr ) + deallocate (rootflux ) !Plant Hydraulic variables deallocate (vegwp ) deallocate (gs0sun ) @@ -978,10 +731,10 @@ SUBROUTINE deallocate_TimeVariables () deallocate (rstfacsha_out ) deallocate (gssun_out ) deallocate (gssha_out ) - deallocate ( assimsun_out ) - deallocate ( assimsha_out ) - deallocate ( etrsun_out ) - deallocate ( etrsha_out ) + deallocate (assimsun_out ) + deallocate (assimsha_out ) + deallocate (etrsun_out ) + deallocate (etrsha_out ) deallocate (t_grnd ) deallocate (tleaf ) @@ -1005,13 +758,17 @@ SUBROUTINE deallocate_TimeVariables () deallocate (alb ) deallocate (ssun ) deallocate (ssha ) + deallocate (ssoi ) + deallocate (ssno ) deallocate (thermk ) deallocate (extkb ) deallocate (extkd ) deallocate (zwt ) deallocate (wa ) + deallocate (wetwat ) deallocate (wat ) deallocate (wdsrf ) + deallocate (rss ) deallocate (t_lake ) ! new lake scheme deallocate (lake_icefrac ) ! new lake scheme @@ -1026,7 +783,7 @@ SUBROUTINE deallocate_TimeVariables () deallocate (mss_dst2 ) deallocate (mss_dst3 ) deallocate (mss_dst4 ) - deallocate (ssno ) + deallocate (ssno_lyr ) deallocate (trad ) deallocate (tref ) @@ -1044,22 +801,40 @@ SUBROUTINE deallocate_TimeVariables () deallocate (fh ) deallocate (fq ) - end if - end if + deallocate (irrig_rate ) + deallocate (deficit_irrig ) + deallocate (sum_irrig ) + deallocate (sum_irrig_count ) + deallocate (n_irrig_steps_left ) + + deallocate (tairday ) + deallocate (usday ) + deallocate (vsday ) + deallocate (pairday ) + deallocate (rnetday ) + deallocate (fgrndday ) + deallocate (potential_evapotranspiration) + + deallocate ( irrig_method_corn ) + deallocate ( irrig_method_swheat ) + deallocate ( irrig_method_wwheat ) + deallocate ( irrig_method_soybean ) + deallocate ( irrig_method_cotton ) + deallocate ( irrig_method_rice1 ) + deallocate ( irrig_method_rice2 ) + deallocate ( irrig_method_sugarcane) + ENDIF + ENDIF -#if (defined LULC_IGBP_PFT) +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) CALL deallocate_PFTimeVariables #endif -#if (defined LULC_IGBP_PC) - CALL deallocate_PCTimeVariables -#endif - #if (defined BGC) CALL deallocate_BGCTimeVariables #endif -#ifdef LATERAL_FLOW +#ifdef CatchLateralFlow CALL deallocate_HydroTimeVariables #endif @@ -1071,10 +846,10 @@ END SUBROUTINE deallocate_TimeVariables !--------------------------------------- - function save_to_restart (idate, deltim, itstamp, ptstamp) result(rwrite) + FUNCTION save_to_restart (idate, deltim, itstamp, ptstamp) result(rwrite) - use MOD_Namelist - implicit none + USE MOD_Namelist + IMPLICIT NONE logical :: rwrite @@ -1084,26 +859,26 @@ function save_to_restart (idate, deltim, itstamp, ptstamp) result(rwrite) ! added by yuan, 08/31/2014 - select case (trim(adjustl(DEF_WRST_FREQ))) - case ('TIMESTEP') + SELECTCASE (trim(adjustl(DEF_WRST_FREQ))) + CASE ('TIMESTEP') rwrite = .true. - case ('HOURLY') + CASE ('HOURLY') rwrite = isendofhour (idate, deltim) - case ('DAILY') + CASE ('DAILY') rwrite = isendofday(idate, deltim) - case ('MONTHLY') + CASE ('MONTHLY') rwrite = isendofmonth(idate, deltim) - case ('YEARLY') + CASE ('YEARLY') rwrite = isendofyear(idate, deltim) - case default + CASE default write(*,*) 'Warning: Please use one of TIMESTEP/HOURLY/DAILY/MONTHLY/YEARLY for restart frequency.' - end select + ENDSELECT - if (rwrite) then + IF (rwrite) THEN rwrite = (ptstamp < itstamp) - end if + ENDIF - end function save_to_restart + END FUNCTION save_to_restart !--------------------------------------- SUBROUTINE WRITE_TimeVariables (idate, lc_year, site, dir_restart) @@ -1112,33 +887,42 @@ SUBROUTINE WRITE_TimeVariables (idate, lc_year, site, dir_restart) ! Original version: Yongjiu Dai, September 15, 1999, 03/2014 !======================================================================= - use MOD_Namelist, only : DEF_REST_COMPRESS_LEVEL, DEF_USE_PLANTHYDRAULICS, DEF_USE_OZONESTRESS + USE MOD_SPMD_Task + USE MOD_Namelist, only : DEF_REST_COMPRESS_LEVEL, DEF_USE_PLANTHYDRAULICS, DEF_USE_OZONESTRESS, & + DEF_USE_IRRIGATION USE MOD_LandPatch - use MOD_NetCDFVector + USE MOD_NetCDFVector USE MOD_Vars_Global IMPLICIT NONE - integer, INTENT(in) :: idate(3) - INTEGER, intent(in) :: lc_year !year of land cover TYPE data + integer, intent(in) :: idate(3) + integer, intent(in) :: lc_year !year of land cover type data character(LEN=*), intent(in) :: site character(LEN=*), intent(in) :: dir_restart ! Local variables character(LEN=256) :: file_restart character(len=14) :: cdate - CHARACTER(len=256) :: cyear !CHARACTER for lc_year + character(len=256) :: cyear !character for lc_year integer :: compress compress = DEF_REST_COMPRESS_LEVEL ! land cover type year write(cyear,'(i4.4)') lc_year - write(cdate,'(i4.4,"-",i3.3,"-",i5.5)') idate(1), idate(2), idate(3) - file_restart = trim(dir_restart)// '/' // trim(site) //'_restart_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' + IF (p_is_master) THEN + CALL system('mkdir -p ' // trim(dir_restart)//'/'//trim(cdate)) + ENDIF +#ifdef USEMPI + call mpi_barrier (p_comm_glb, p_err) +#endif + + file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' - call ncio_create_file_vector (file_restart, landpatch) + + CALL ncio_create_file_vector (file_restart, landpatch) CALL ncio_define_dimension_vector (file_restart, landpatch, 'patch') CALL ncio_define_dimension_vector (file_restart, landpatch, 'snow', -maxsnl ) @@ -1147,113 +931,135 @@ SUBROUTINE WRITE_TimeVariables (idate, lc_year, site, dir_restart) CALL ncio_define_dimension_vector (file_restart, landpatch, 'soil', nl_soil) CALL ncio_define_dimension_vector (file_restart, landpatch, 'lake', nl_lake) - if(DEF_USE_PLANTHYDRAULICS)then - CALL ncio_define_dimension_vector (file_restart, landpatch, 'vegnodes', nvegwcs) - end if +IF(DEF_USE_PLANTHYDRAULICS)THEN + CALL ncio_define_dimension_vector (file_restart, landpatch, 'vegnodes', nvegwcs) +ENDIF CALL ncio_define_dimension_vector (file_restart, landpatch, 'band', 2) CALL ncio_define_dimension_vector (file_restart, landpatch, 'rtyp', 2) ! Time-varying state variables which reaquired by restart run - call ncio_write_vector (file_restart, 'z_sno ' , 'snow', -maxsnl, 'patch', landpatch, z_sno , compress) ! node depth [m] - call ncio_write_vector (file_restart, 'dz_sno ' , 'snow', -maxsnl, 'patch', landpatch, dz_sno, compress) ! interface depth [m] - call ncio_write_vector (file_restart, 't_soisno' , 'soilsnow', nl_soil-maxsnl, 'patch', landpatch, t_soisno , compress) ! soil temperature [K] - call ncio_write_vector (file_restart, 'wliq_soisno', 'soilsnow', nl_soil-maxsnl, 'patch', landpatch, wliq_soisno, compress) ! liquid water in layers [kg/m2] - call ncio_write_vector (file_restart, 'wice_soisno', 'soilsnow', nl_soil-maxsnl, 'patch', landpatch, wice_soisno, compress) ! ice lens in layers [kg/m2] - call ncio_write_vector (file_restart, 'smp', 'soil', nl_soil, 'patch', landpatch, smp, compress) ! soil matrix potential [mm] - call ncio_write_vector (file_restart, 'hk', 'soil', nl_soil, 'patch', landpatch, hk, compress) ! hydraulic conductivity [mm h2o/s] - IF(DEF_USE_PLANTHYDRAULICS)THEN - call ncio_write_vector (file_restart, 'vegwp', 'vegnodes', nvegwcs, 'patch', landpatch, vegwp, compress) ! vegetation water potential [mm] - call ncio_write_vector (file_restart, 'gs0sun', 'patch', landpatch, gs0sun, compress) ! working copy of sunlit stomata conductance - call ncio_write_vector (file_restart, 'gs0sha', 'patch', landpatch, gs0sha, compress) ! working copy of shalit stomata conductance - ENDIF - IF(DEF_USE_OZONESTRESS)THEN - call ncio_write_vector (file_restart, 'lai_old ', 'patch', landpatch, lai_old , compress) - call ncio_write_vector (file_restart, 'o3uptakesun', 'patch', landpatch, o3uptakesun, compress) - call ncio_write_vector (file_restart, 'o3uptakesha', 'patch', landpatch, o3uptakesha, compress) - ENDIF - call ncio_write_vector (file_restart, 't_grnd ' , 'patch', landpatch, t_grnd , compress) ! ground surface temperature [K] - call ncio_write_vector (file_restart, 'tleaf ' , 'patch', landpatch, tleaf , compress) ! leaf temperature [K] - call ncio_write_vector (file_restart, 'ldew ' , 'patch', landpatch, ldew , compress) ! depth of water on foliage [mm] - call ncio_write_vector (file_restart, 'ldew_rain' , 'patch', landpatch, ldew_rain , compress) ! depth of water on foliage [mm] - call ncio_write_vector (file_restart, 'ldew_snow' , 'patch', landpatch, ldew_snow , compress) ! depth of water on foliage [mm] - call ncio_write_vector (file_restart, 'sag ' , 'patch', landpatch, sag , compress) ! non dimensional snow age [-] - call ncio_write_vector (file_restart, 'scv ' , 'patch', landpatch, scv , compress) ! snow cover, water equivalent [mm] - call ncio_write_vector (file_restart, 'snowdp ' , 'patch', landpatch, snowdp , compress) ! snow depth [meter] - call ncio_write_vector (file_restart, 'fveg ' , 'patch', landpatch, fveg , compress) ! fraction of vegetation cover - call ncio_write_vector (file_restart, 'fsno ' , 'patch', landpatch, fsno , compress) ! fraction of snow cover on ground - call ncio_write_vector (file_restart, 'sigf ' , 'patch', landpatch, sigf , compress) ! fraction of veg cover, excluding snow-covered veg [-] - call ncio_write_vector (file_restart, 'green ' , 'patch', landpatch, green , compress) ! leaf greenness - call ncio_write_vector (file_restart, 'lai ' , 'patch', landpatch, lai , compress) ! leaf area index - call ncio_write_vector (file_restart, 'tlai ' , 'patch', landpatch, tlai , compress) ! leaf area index - call ncio_write_vector (file_restart, 'sai ' , 'patch', landpatch, sai , compress) ! stem area index - call ncio_write_vector (file_restart, 'tsai ' , 'patch', landpatch, tsai , compress) ! stem area index - call ncio_write_vector (file_restart, 'coszen ' , 'patch', landpatch, coszen , compress) ! cosine of solar zenith angle - call ncio_write_vector (file_restart, 'alb ' , 'band', 2, 'rtyp', 2, 'patch', landpatch, alb , compress) ! averaged albedo [-] - call ncio_write_vector (file_restart, 'ssun ' , 'band', 2, 'rtyp', 2, 'patch', landpatch, ssun, compress) ! sunlit canopy absorption for solar radiation (0-1) - call ncio_write_vector (file_restart, 'ssha ' , 'band', 2, 'rtyp', 2, 'patch', landpatch, ssha, compress) ! shaded canopy absorption for solar radiation (0-1) - call ncio_write_vector (file_restart, 'thermk ' , 'patch', landpatch, thermk , compress) ! canopy gap fraction for tir radiation - call ncio_write_vector (file_restart, 'extkb ' , 'patch', landpatch, extkb , compress) ! (k, g(mu)/mu) direct solar extinction coefficient - call ncio_write_vector (file_restart, 'extkd ' , 'patch', landpatch, extkd , compress) ! diffuse and scattered diffuse PAR extinction coefficient - call ncio_write_vector (file_restart, 'zwt ' , 'patch', landpatch, zwt , compress) ! the depth to water table [m] - call ncio_write_vector (file_restart, 'wa ' , 'patch', landpatch, wa , compress) ! water storage in aquifer [mm] - call ncio_write_vector (file_restart, 'wdsrf ' , 'patch', landpatch, wdsrf , compress) ! depth of surface water [mm] - - call ncio_write_vector (file_restart, 't_lake ' , 'lake', nl_lake, 'patch', landpatch, t_lake , compress) ! - call ncio_write_vector (file_restart, 'lake_icefrc', 'lake', nl_lake, 'patch', landpatch, lake_icefrac, compress) ! - call ncio_write_vector (file_restart, 'savedtke1 ', 'patch', landpatch, savedtke1 , compress) ! - call ncio_write_vector (file_restart, 'snw_rds ', 'snow', -maxsnl, 'patch', landpatch, snw_rds , compress) - call ncio_write_vector (file_restart, 'mss_bcpho', 'snow', -maxsnl, 'patch', landpatch, mss_bcpho, compress) - call ncio_write_vector (file_restart, 'mss_bcphi', 'snow', -maxsnl, 'patch', landpatch, mss_bcphi, compress) - call ncio_write_vector (file_restart, 'mss_ocpho', 'snow', -maxsnl, 'patch', landpatch, mss_ocpho, compress) - call ncio_write_vector (file_restart, 'mss_ocphi', 'snow', -maxsnl, 'patch', landpatch, mss_ocphi, compress) - call ncio_write_vector (file_restart, 'mss_dst1 ', 'snow', -maxsnl, 'patch', landpatch, mss_dst1 , compress) - call ncio_write_vector (file_restart, 'mss_dst2 ', 'snow', -maxsnl, 'patch', landpatch, mss_dst2 , compress) - call ncio_write_vector (file_restart, 'mss_dst3 ', 'snow', -maxsnl, 'patch', landpatch, mss_dst3 , compress) - call ncio_write_vector (file_restart, 'mss_dst4 ', 'snow', -maxsnl, 'patch', landpatch, mss_dst4 , compress) - call ncio_write_vector (file_restart, 'ssno', 'band', 2, 'rtyp', 2, 'snowp1', -maxsnl+1, 'patch', landpatch, ssno, compress) + CALL ncio_write_vector (file_restart, 'z_sno ' , 'snow', -maxsnl, 'patch', landpatch, z_sno , compress) ! node depth [m] + CALL ncio_write_vector (file_restart, 'dz_sno ' , 'snow', -maxsnl, 'patch', landpatch, dz_sno, compress) ! interface depth [m] + CALL ncio_write_vector (file_restart, 't_soisno' , 'soilsnow', nl_soil-maxsnl, 'patch', landpatch, t_soisno , compress) ! soil temperature [K] + CALL ncio_write_vector (file_restart, 'wliq_soisno', 'soilsnow', nl_soil-maxsnl, 'patch', landpatch, wliq_soisno, compress) ! liquid water in layers [kg/m2] + CALL ncio_write_vector (file_restart, 'wice_soisno', 'soilsnow', nl_soil-maxsnl, 'patch', landpatch, wice_soisno, compress) ! ice lens in layers [kg/m2] + CALL ncio_write_vector (file_restart, 'smp', 'soil', nl_soil, 'patch', landpatch, smp, compress) ! soil matrix potential [mm] + CALL ncio_write_vector (file_restart, 'hk', 'soil', nl_soil, 'patch', landpatch, hk, compress) ! hydraulic conductivity [mm h2o/s] +IF(DEF_USE_PLANTHYDRAULICS)THEN + CALL ncio_write_vector (file_restart, 'vegwp', 'vegnodes', nvegwcs, 'patch', landpatch, vegwp, compress) ! vegetation water potential [mm] + CALL ncio_write_vector (file_restart, 'gs0sun', 'patch', landpatch, gs0sun, compress) ! working copy of sunlit stomata conductance + CALL ncio_write_vector (file_restart, 'gs0sha', 'patch', landpatch, gs0sha, compress) ! working copy of shalit stomata conductance +ENDIF +IF(DEF_USE_OZONESTRESS)THEN + CALL ncio_write_vector (file_restart, 'lai_old ', 'patch', landpatch, lai_old , compress) + CALL ncio_write_vector (file_restart, 'o3uptakesun', 'patch', landpatch, o3uptakesun, compress) + CALL ncio_write_vector (file_restart, 'o3uptakesha', 'patch', landpatch, o3uptakesha, compress) +ENDIF + CALL ncio_write_vector (file_restart, 't_grnd ' , 'patch', landpatch, t_grnd , compress) ! ground surface temperature [K] + CALL ncio_write_vector (file_restart, 'tleaf ' , 'patch', landpatch, tleaf , compress) ! leaf temperature [K] + CALL ncio_write_vector (file_restart, 'ldew ' , 'patch', landpatch, ldew , compress) ! depth of water on foliage [mm] + CALL ncio_write_vector (file_restart, 'ldew_rain' , 'patch', landpatch, ldew_rain , compress) ! depth of water on foliage [mm] + CALL ncio_write_vector (file_restart, 'ldew_snow' , 'patch', landpatch, ldew_snow , compress) ! depth of water on foliage [mm] + CALL ncio_write_vector (file_restart, 'sag ' , 'patch', landpatch, sag , compress) ! non dimensional snow age [-] + CALL ncio_write_vector (file_restart, 'scv ' , 'patch', landpatch, scv , compress) ! snow cover, water equivalent [mm] + CALL ncio_write_vector (file_restart, 'snowdp ' , 'patch', landpatch, snowdp , compress) ! snow depth [meter] + CALL ncio_write_vector (file_restart, 'fveg ' , 'patch', landpatch, fveg , compress) ! fraction of vegetation cover + CALL ncio_write_vector (file_restart, 'fsno ' , 'patch', landpatch, fsno , compress) ! fraction of snow cover on ground + CALL ncio_write_vector (file_restart, 'sigf ' , 'patch', landpatch, sigf , compress) ! fraction of veg cover, excluding snow-covered veg [-] + CALL ncio_write_vector (file_restart, 'green ' , 'patch', landpatch, green , compress) ! leaf greenness + CALL ncio_write_vector (file_restart, 'lai ' , 'patch', landpatch, lai , compress) ! leaf area index + CALL ncio_write_vector (file_restart, 'tlai ' , 'patch', landpatch, tlai , compress) ! leaf area index + CALL ncio_write_vector (file_restart, 'sai ' , 'patch', landpatch, sai , compress) ! stem area index + CALL ncio_write_vector (file_restart, 'tsai ' , 'patch', landpatch, tsai , compress) ! stem area index + CALL ncio_write_vector (file_restart, 'coszen ' , 'patch', landpatch, coszen , compress) ! cosine of solar zenith angle + CALL ncio_write_vector (file_restart, 'alb ' , 'band', 2, 'rtyp', 2, 'patch', landpatch, alb , compress) ! averaged albedo [-] + CALL ncio_write_vector (file_restart, 'ssun ' , 'band', 2, 'rtyp', 2, 'patch', landpatch, ssun, compress) ! sunlit canopy absorption for solar radiation (0-1) + CALL ncio_write_vector (file_restart, 'ssha ' , 'band', 2, 'rtyp', 2, 'patch', landpatch, ssha, compress) ! shaded canopy absorption for solar radiation (0-1) + CALL ncio_write_vector (file_restart, 'ssoi ' , 'band', 2, 'rtyp', 2, 'patch', landpatch, ssoi, compress) ! shaded canopy absorption for solar radiation (0-1) + CALL ncio_write_vector (file_restart, 'ssno ' , 'band', 2, 'rtyp', 2, 'patch', landpatch, ssno, compress) ! shaded canopy absorption for solar radiation (0-1) + CALL ncio_write_vector (file_restart, 'thermk ' , 'patch', landpatch, thermk , compress) ! canopy gap fraction for tir radiation + CALL ncio_write_vector (file_restart, 'extkb ' , 'patch', landpatch, extkb , compress) ! (k, g(mu)/mu) direct solar extinction coefficient + CALL ncio_write_vector (file_restart, 'extkd ' , 'patch', landpatch, extkd , compress) ! diffuse and scattered diffuse PAR extinction coefficient + CALL ncio_write_vector (file_restart, 'zwt ' , 'patch', landpatch, zwt , compress) ! the depth to water table [m] + CALL ncio_write_vector (file_restart, 'wa ' , 'patch', landpatch, wa , compress) ! water storage in aquifer [mm] + CALL ncio_write_vector (file_restart, 'wetwat ' , 'patch', landpatch, wetwat , compress) ! water storage in wetland [mm] + CALL ncio_write_vector (file_restart, 'wdsrf ' , 'patch', landpatch, wdsrf , compress) ! depth of surface water [mm] + CALL ncio_write_vector (file_restart, 'rss ' , 'patch', landpatch, rss , compress) ! soil surface resistance [s/m] + + CALL ncio_write_vector (file_restart, 't_lake ' , 'lake', nl_lake, 'patch', landpatch, t_lake , compress) ! + CALL ncio_write_vector (file_restart, 'lake_icefrc', 'lake', nl_lake, 'patch', landpatch, lake_icefrac, compress) ! + CALL ncio_write_vector (file_restart, 'savedtke1 ', 'patch', landpatch, savedtke1 , compress) ! + CALL ncio_write_vector (file_restart, 'snw_rds ', 'snow', -maxsnl, 'patch', landpatch, snw_rds , compress) + CALL ncio_write_vector (file_restart, 'mss_bcpho', 'snow', -maxsnl, 'patch', landpatch, mss_bcpho, compress) + CALL ncio_write_vector (file_restart, 'mss_bcphi', 'snow', -maxsnl, 'patch', landpatch, mss_bcphi, compress) + CALL ncio_write_vector (file_restart, 'mss_ocpho', 'snow', -maxsnl, 'patch', landpatch, mss_ocpho, compress) + CALL ncio_write_vector (file_restart, 'mss_ocphi', 'snow', -maxsnl, 'patch', landpatch, mss_ocphi, compress) + CALL ncio_write_vector (file_restart, 'mss_dst1 ', 'snow', -maxsnl, 'patch', landpatch, mss_dst1 , compress) + CALL ncio_write_vector (file_restart, 'mss_dst2 ', 'snow', -maxsnl, 'patch', landpatch, mss_dst2 , compress) + CALL ncio_write_vector (file_restart, 'mss_dst3 ', 'snow', -maxsnl, 'patch', landpatch, mss_dst3 , compress) + CALL ncio_write_vector (file_restart, 'mss_dst4 ', 'snow', -maxsnl, 'patch', landpatch, mss_dst4 , compress) + CALL ncio_write_vector (file_restart, 'ssno_lyr', 'band', 2, 'rtyp', 2, 'snowp1', -maxsnl+1, 'patch', landpatch, ssno_lyr, compress) ! Additional va_vectorriables required by reginal model (such as WRF ) RSM) - call ncio_write_vector (file_restart, 'trad ', 'patch', landpatch, trad , compress) ! radiative temperature of surface [K] - call ncio_write_vector (file_restart, 'tref ', 'patch', landpatch, tref , compress) ! 2 m height air temperature [kelvin] - call ncio_write_vector (file_restart, 'qref ', 'patch', landpatch, qref , compress) ! 2 m height air specific humidity - call ncio_write_vector (file_restart, 'rst ', 'patch', landpatch, rst , compress) ! canopy stomatal resistance (s/m) - call ncio_write_vector (file_restart, 'emis ', 'patch', landpatch, emis , compress) ! averaged bulk surface emissivity - call ncio_write_vector (file_restart, 'z0m ', 'patch', landpatch, z0m , compress) ! effective roughness [m] - call ncio_write_vector (file_restart, 'zol ', 'patch', landpatch, zol , compress) ! dimensionless height (z/L) used in Monin-Obukhov theory - call ncio_write_vector (file_restart, 'rib ', 'patch', landpatch, rib , compress) ! bulk Richardson number in surface layer - call ncio_write_vector (file_restart, 'ustar', 'patch', landpatch, ustar, compress) ! u* in similarity theory [m/s] - call ncio_write_vector (file_restart, 'qstar', 'patch', landpatch, qstar, compress) ! q* in similarity theory [kg/kg] - call ncio_write_vector (file_restart, 'tstar', 'patch', landpatch, tstar, compress) ! t* in similarity theory [K] - call ncio_write_vector (file_restart, 'fm ', 'patch', landpatch, fm , compress) ! integral of profile function for momentum - call ncio_write_vector (file_restart, 'fh ', 'patch', landpatch, fh , compress) ! integral of profile function for heat - call ncio_write_vector (file_restart, 'fq ', 'patch', landpatch, fq , compress) ! integral of profile function for moisture - -#if (defined LULC_IGBP_PFT) - file_restart = trim(dir_restart)// '/' // trim(site) //'_restart_pft_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' + CALL ncio_write_vector (file_restart, 'trad ', 'patch', landpatch, trad , compress) ! radiative temperature of surface [K] + CALL ncio_write_vector (file_restart, 'tref ', 'patch', landpatch, tref , compress) ! 2 m height air temperature [kelvin] + CALL ncio_write_vector (file_restart, 'qref ', 'patch', landpatch, qref , compress) ! 2 m height air specific humidity + CALL ncio_write_vector (file_restart, 'rst ', 'patch', landpatch, rst , compress) ! canopy stomatal resistance (s/m) + CALL ncio_write_vector (file_restart, 'emis ', 'patch', landpatch, emis , compress) ! averaged bulk surface emissivity + CALL ncio_write_vector (file_restart, 'z0m ', 'patch', landpatch, z0m , compress) ! effective roughness [m] + CALL ncio_write_vector (file_restart, 'zol ', 'patch', landpatch, zol , compress) ! dimensionless height (z/L) used in Monin-Obukhov theory + CALL ncio_write_vector (file_restart, 'rib ', 'patch', landpatch, rib , compress) ! bulk Richardson number in surface layer + CALL ncio_write_vector (file_restart, 'ustar', 'patch', landpatch, ustar, compress) ! u* in similarity theory [m/s] + CALL ncio_write_vector (file_restart, 'qstar', 'patch', landpatch, qstar, compress) ! q* in similarity theory [kg/kg] + CALL ncio_write_vector (file_restart, 'tstar', 'patch', landpatch, tstar, compress) ! t* in similarity theory [K] + CALL ncio_write_vector (file_restart, 'fm ', 'patch', landpatch, fm , compress) ! integral of profile function for momentum + CALL ncio_write_vector (file_restart, 'fh ', 'patch', landpatch, fh , compress) ! integral of profile function for heat + CALL ncio_write_vector (file_restart, 'fq ', 'patch', landpatch, fq , compress) ! integral of profile function for moisture + +IF (DEF_USE_IRRIGATION) THEN + CALL Ncio_write_vector (file_restart, 'irrig_rate ' , 'patch',landpatch,irrig_rate , compress) + CALL Ncio_write_vector (file_restart, 'deficit_irrig ' , 'patch',landpatch,deficit_irrig , compress) + CALL Ncio_write_vector (file_restart, 'sum_irrig ' , 'patch',landpatch,sum_irrig , compress) + CALL Ncio_write_vector (file_restart, 'sum_irrig_count ' , 'patch',landpatch,sum_irrig_count , compress) + CALL Ncio_write_vector (file_restart, 'n_irrig_steps_left ' , 'patch',landpatch,n_irrig_steps_left , compress) + CALL Ncio_write_vector (file_restart, 'tairday ' , 'patch',landpatch,tairday , compress) + CALL Ncio_write_vector (file_restart, 'usday ' , 'patch',landpatch,usday , compress) + CALL Ncio_write_vector (file_restart, 'vsday ' , 'patch',landpatch,vsday , compress) + CALL Ncio_write_vector (file_restart, 'pairday ' , 'patch',landpatch,pairday , compress) + CALL Ncio_write_vector (file_restart, 'rnetday ' , 'patch',landpatch,rnetday , compress) + CALL Ncio_write_vector (file_restart, 'fgrndday ' , 'patch',landpatch,fgrndday , compress) + CALL Ncio_write_vector (file_restart, 'potential_evapotranspiration', 'patch',landpatch, potential_evapotranspiration, compress) + CALL Ncio_write_vector (file_restart, 'irrig_method_corn ' , 'patch',landpatch,irrig_method_corn , compress) + CALL Ncio_write_vector (file_restart, 'irrig_method_swheat ' , 'patch',landpatch,irrig_method_swheat , compress) + CALL Ncio_write_vector (file_restart, 'irrig_method_wwheat ' , 'patch',landpatch,irrig_method_wwheat , compress) + CALL Ncio_write_vector (file_restart, 'irrig_method_soybean ' , 'patch',landpatch,irrig_method_soybean , compress) + CALL Ncio_write_vector (file_restart, 'irrig_method_cotton ' , 'patch',landpatch,irrig_method_cotton , compress) + CALL Ncio_write_vector (file_restart, 'irrig_method_rice1 ' , 'patch',landpatch,irrig_method_rice1 , compress) + CALL Ncio_write_vector (file_restart, 'irrig_method_rice2 ' , 'patch',landpatch,irrig_method_rice2 , compress) + CALL Ncio_write_vector (file_restart, 'irrig_method_sugarcane' , 'patch',landpatch,irrig_method_sugarcane, compress) +ENDIF + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_pft_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' CALL WRITE_PFTimeVariables (file_restart) #endif -#if (defined LULC_IGBP_PC) - file_restart = trim(dir_restart)// '/' // trim(site) //'_restart_pc_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' - CALL WRITE_PCTimeVariables (file_restart) -#endif - #if (defined BGC) - file_restart = trim(dir_restart)// '/' // trim(site) //'_restart_bgc_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' + file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_bgc_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' CALL WRITE_BGCTimeVariables (file_restart) #endif -#if (defined LATERAL_FLOW) - file_restart = trim(dir_restart)// '/' // trim(site) //'_restart_basin_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' +#if (defined CatchLateralFlow) + file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_basin_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' CALL WRITE_HydroTimeVariables (file_restart) #endif #if (defined URBAN_MODEL) - file_restart = trim(dir_restart)// '/' // trim(site) //'_restart_urban_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' + file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_urban_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' CALL WRITE_UrbanTimeVariables (file_restart) #endif - end subroutine WRITE_TimeVariables + END SUBROUTINE WRITE_TimeVariables !--------------------------------------- SUBROUTINE READ_TimeVariables (idate, lc_year, site, dir_restart) @@ -1262,9 +1068,9 @@ SUBROUTINE READ_TimeVariables (idate, lc_year, site, dir_restart) ! Original version: Yongjiu Dai, September 15, 1999, 03/2014 !======================================================================= - use MOD_Namelist - use MOD_SPMD_Task - use MOD_NetCDFVector + USE MOD_Namelist + USE MOD_SPMD_Task + USE MOD_NetCDFVector #ifdef RangeCheck USE MOD_RangeCheck #endif @@ -1273,8 +1079,8 @@ SUBROUTINE READ_TimeVariables (idate, lc_year, site, dir_restart) IMPLICIT NONE - integer, INTENT(in) :: idate(3) - INTEGER, intent(in) :: lc_year !year of land cover type data + integer, intent(in) :: idate(3) + integer, intent(in) :: lc_year !year of land cover type data character(LEN=*), intent(in) :: site character(LEN=*), intent(in) :: dir_restart @@ -1283,205 +1089,263 @@ SUBROUTINE READ_TimeVariables (idate, lc_year, site, dir_restart) character(len=14) :: cdate, cyear #ifdef USEMPI - call mpi_barrier (p_comm_glb, p_err) + CALL mpi_barrier (p_comm_glb, p_err) #endif - if (p_is_master) then + IF (p_is_master) THEN write(*,'(/,A26)') 'Loading Time Variables ...' - end if + ENDIF ! land cover type year write(cyear,'(i4.4)') lc_year write(cdate,'(i4.4,"-",i3.3,"-",i5.5)') idate(1), idate(2), idate(3) - file_restart = trim(dir_restart) // '/' // trim(site) //'_restart_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' + file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' ! Time-varying state variables which reaquired by restart run - call ncio_read_vector (file_restart, 'z_sno ' , -maxsnl, landpatch, z_sno ) ! node depth [m] - call ncio_read_vector (file_restart, 'dz_sno ' , -maxsnl, landpatch, dz_sno) ! interface depth [m] - call ncio_read_vector (file_restart, 't_soisno' , nl_soil-maxsnl, landpatch, t_soisno ) ! soil temperature [K] - call ncio_read_vector (file_restart, 'wliq_soisno', nl_soil-maxsnl, landpatch, wliq_soisno) ! liquid water in layers [kg/m2] - call ncio_read_vector (file_restart, 'wice_soisno', nl_soil-maxsnl, landpatch, wice_soisno) ! ice lens in layers [kg/m2] - call ncio_read_vector (file_restart, 'smp', nl_soil, landpatch, smp ) ! soil matrix potential [mm] - call ncio_read_vector (file_restart, 'hk', nl_soil, landpatch, hk ) ! hydraulic conductivity [mm h2o/s] - if(DEF_USE_PLANTHYDRAULICS)then - call ncio_read_vector (file_restart, 'vegwp', nvegwcs, landpatch, vegwp ) ! vegetation water potential [mm] - call ncio_read_vector (file_restart, 'gs0sun ', landpatch, gs0sun ) ! working copy of sunlit stomata conductance - call ncio_read_vector (file_restart, 'gs0sha ', landpatch, gs0sha ) ! working copy of shalit stomata conductance - end if - IF(DEF_USE_OZONESTRESS)THEN - call ncio_read_vector (file_restart, 'lai_old ', landpatch, lai_old ) - call ncio_read_vector (file_restart, 'o3uptakesun', landpatch, o3uptakesun) - call ncio_read_vector (file_restart, 'o3uptakesha', landpatch, o3uptakesha) - ENDIF - call ncio_read_vector (file_restart, 't_grnd ' , landpatch, t_grnd ) ! ground surface temperature [K] - call ncio_read_vector (file_restart, 'tleaf ' , landpatch, tleaf ) ! leaf temperature [K] - call ncio_read_vector (file_restart, 'ldew ' , landpatch, ldew ) ! depth of water on foliage [mm] - call ncio_read_vector (file_restart, 'ldew_rain' , landpatch, ldew_rain ) ! depth of rain on foliage [mm] - call ncio_read_vector (file_restart, 'ldew_snow' , landpatch, ldew_snow ) ! depth of snow on foliage [mm] - call ncio_read_vector (file_restart, 'sag ' , landpatch, sag ) ! non dimensional snow age [-] - call ncio_read_vector (file_restart, 'scv ' , landpatch, scv ) ! snow cover, water equivalent [mm] - call ncio_read_vector (file_restart, 'snowdp ' , landpatch, snowdp ) ! snow depth [meter] - call ncio_read_vector (file_restart, 'fveg ' , landpatch, fveg ) ! fraction of vegetation cover - call ncio_read_vector (file_restart, 'fsno ' , landpatch, fsno ) ! fraction of snow cover on ground - call ncio_read_vector (file_restart, 'sigf ' , landpatch, sigf ) ! fraction of veg cover, excluding snow-covered veg [-] - call ncio_read_vector (file_restart, 'green ' , landpatch, green ) ! leaf greenness - call ncio_read_vector (file_restart, 'lai ' , landpatch, lai ) ! leaf area index - call ncio_read_vector (file_restart, 'tlai ' , landpatch, tlai ) ! leaf area index - call ncio_read_vector (file_restart, 'sai ' , landpatch, sai ) ! stem area index - call ncio_read_vector (file_restart, 'tsai ' , landpatch, tsai ) ! stem area index - call ncio_read_vector (file_restart, 'coszen ' , landpatch, coszen ) ! cosine of solar zenith angle - call ncio_read_vector (file_restart, 'alb ' , 2, 2, landpatch, alb ) ! averaged albedo [-] - call ncio_read_vector (file_restart, 'ssun ' , 2, 2, landpatch, ssun ) ! sunlit canopy absorption for solar radiation (0-1) - call ncio_read_vector (file_restart, 'ssha ' , 2, 2, landpatch, ssha ) ! shaded canopy absorption for solar radiation (0-1) - call ncio_read_vector (file_restart, 'thermk ' , landpatch, thermk ) ! canopy gap fraction for tir radiation - call ncio_read_vector (file_restart, 'extkb ' , landpatch, extkb ) ! (k, g(mu)/mu) direct solar extinction coefficient - call ncio_read_vector (file_restart, 'extkd ' , landpatch, extkd ) ! diffuse and scattered diffuse PAR extinction coefficient - call ncio_read_vector (file_restart, 'zwt ' , landpatch, zwt ) ! the depth to water table [m] - call ncio_read_vector (file_restart, 'wa ' , landpatch, wa ) ! water storage in aquifer [mm] - call ncio_read_vector (file_restart, 'wdsrf ' , landpatch, wdsrf ) ! depth of surface water [mm] - - call ncio_read_vector (file_restart, 't_lake ' , nl_lake, landpatch, t_lake ) ! - call ncio_read_vector (file_restart, 'lake_icefrc', nl_lake, landpatch, lake_icefrac) ! - call ncio_read_vector (file_restart, 'savedtke1', landpatch, savedtke1) ! - - call ncio_read_vector (file_restart, 'snw_rds ', -maxsnl, landpatch, snw_rds ) ! - call ncio_read_vector (file_restart, 'mss_bcpho', -maxsnl, landpatch, mss_bcpho) ! - call ncio_read_vector (file_restart, 'mss_bcphi', -maxsnl, landpatch, mss_bcphi) ! - call ncio_read_vector (file_restart, 'mss_ocpho', -maxsnl, landpatch, mss_ocpho) ! - call ncio_read_vector (file_restart, 'mss_ocphi', -maxsnl, landpatch, mss_ocphi) ! - call ncio_read_vector (file_restart, 'mss_dst1 ', -maxsnl, landpatch, mss_dst1 ) ! - call ncio_read_vector (file_restart, 'mss_dst2 ', -maxsnl, landpatch, mss_dst2 ) ! - call ncio_read_vector (file_restart, 'mss_dst3 ', -maxsnl, landpatch, mss_dst3 ) ! - call ncio_read_vector (file_restart, 'mss_dst4 ', -maxsnl, landpatch, mss_dst4 ) ! - call ncio_read_vector (file_restart, 'ssno', 2,2, -maxsnl+1, landpatch, ssno) ! + CALL ncio_read_vector (file_restart, 'z_sno ' , -maxsnl, landpatch, z_sno ) ! node depth [m] + CALL ncio_read_vector (file_restart, 'dz_sno ' , -maxsnl, landpatch, dz_sno) ! interface depth [m] + CALL ncio_read_vector (file_restart, 't_soisno' , nl_soil-maxsnl, landpatch, t_soisno ) ! soil temperature [K] + CALL ncio_read_vector (file_restart, 'wliq_soisno', nl_soil-maxsnl, landpatch, wliq_soisno) ! liquid water in layers [kg/m2] + CALL ncio_read_vector (file_restart, 'wice_soisno', nl_soil-maxsnl, landpatch, wice_soisno) ! ice lens in layers [kg/m2] + CALL ncio_read_vector (file_restart, 'smp', nl_soil, landpatch, smp ) ! soil matrix potential [mm] + CALL ncio_read_vector (file_restart, 'hk', nl_soil, landpatch, hk ) ! hydraulic conductivity [mm h2o/s] +IF(DEF_USE_PLANTHYDRAULICS)THEN + CALL ncio_read_vector (file_restart, 'vegwp', nvegwcs, landpatch, vegwp ) ! vegetation water potential [mm] + CALL ncio_read_vector (file_restart, 'gs0sun ', landpatch, gs0sun ) ! working copy of sunlit stomata conductance + CALL ncio_read_vector (file_restart, 'gs0sha ', landpatch, gs0sha ) ! working copy of shalit stomata conductance +ENDIF +IF(DEF_USE_OZONESTRESS)THEN + CALL ncio_read_vector (file_restart, 'lai_old ', landpatch, lai_old ) + CALL ncio_read_vector (file_restart, 'o3uptakesun', landpatch, o3uptakesun) + CALL ncio_read_vector (file_restart, 'o3uptakesha', landpatch, o3uptakesha) +ENDIF + CALL ncio_read_vector (file_restart, 't_grnd ' , landpatch, t_grnd ) ! ground surface temperature [K] + CALL ncio_read_vector (file_restart, 'tleaf ' , landpatch, tleaf ) ! leaf temperature [K] + CALL ncio_read_vector (file_restart, 'ldew ' , landpatch, ldew ) ! depth of water on foliage [mm] + CALL ncio_read_vector (file_restart, 'ldew_rain' , landpatch, ldew_rain ) ! depth of rain on foliage [mm] + CALL ncio_read_vector (file_restart, 'ldew_snow' , landpatch, ldew_snow ) ! depth of snow on foliage [mm] + CALL ncio_read_vector (file_restart, 'sag ' , landpatch, sag ) ! non dimensional snow age [-] + CALL ncio_read_vector (file_restart, 'scv ' , landpatch, scv ) ! snow cover, water equivalent [mm] + CALL ncio_read_vector (file_restart, 'snowdp ' , landpatch, snowdp ) ! snow depth [meter] + CALL ncio_read_vector (file_restart, 'fveg ' , landpatch, fveg ) ! fraction of vegetation cover + CALL ncio_read_vector (file_restart, 'fsno ' , landpatch, fsno ) ! fraction of snow cover on ground + CALL ncio_read_vector (file_restart, 'sigf ' , landpatch, sigf ) ! fraction of veg cover, excluding snow-covered veg [-] + CALL ncio_read_vector (file_restart, 'green ' , landpatch, green ) ! leaf greenness + CALL ncio_read_vector (file_restart, 'lai ' , landpatch, lai ) ! leaf area index + CALL ncio_read_vector (file_restart, 'tlai ' , landpatch, tlai ) ! leaf area index + CALL ncio_read_vector (file_restart, 'sai ' , landpatch, sai ) ! stem area index + CALL ncio_read_vector (file_restart, 'tsai ' , landpatch, tsai ) ! stem area index + CALL ncio_read_vector (file_restart, 'coszen ' , landpatch, coszen ) ! cosine of solar zenith angle + CALL ncio_read_vector (file_restart, 'alb ' , 2, 2, landpatch, alb ) ! averaged albedo [-] + CALL ncio_read_vector (file_restart, 'ssun ' , 2, 2, landpatch, ssun ) ! sunlit canopy absorption for solar radiation (0-1) + CALL ncio_read_vector (file_restart, 'ssha ' , 2, 2, landpatch, ssha ) ! shaded canopy absorption for solar radiation (0-1) + CALL ncio_read_vector (file_restart, 'ssoi ' , 2, 2, landpatch, ssoi ) ! soil absorption for solar radiation (0-1) + CALL ncio_read_vector (file_restart, 'ssno ' , 2, 2, landpatch, ssno ) ! snow absorption for solar radiation (0-1) + CALL ncio_read_vector (file_restart, 'thermk ' , landpatch, thermk ) ! canopy gap fraction for tir radiation + CALL ncio_read_vector (file_restart, 'extkb ' , landpatch, extkb ) ! (k, g(mu)/mu) direct solar extinction coefficient + CALL ncio_read_vector (file_restart, 'extkd ' , landpatch, extkd ) ! diffuse and scattered diffuse PAR extinction coefficient + CALL ncio_read_vector (file_restart, 'zwt ' , landpatch, zwt ) ! the depth to water table [m] + CALL ncio_read_vector (file_restart, 'wa ' , landpatch, wa ) ! water storage in aquifer [mm] + CALL ncio_read_vector (file_restart, 'wetwat ' , landpatch, wetwat ) ! water storage in wetland [mm] + CALL ncio_read_vector (file_restart, 'wdsrf ' , landpatch, wdsrf ) ! depth of surface water [mm] + CALL ncio_read_vector (file_restart, 'rss ' , landpatch, rss ) ! soil surface resistance [s/m] + + CALL ncio_read_vector (file_restart, 't_lake ' , nl_lake, landpatch, t_lake ) ! + CALL ncio_read_vector (file_restart, 'lake_icefrc', nl_lake, landpatch, lake_icefrac) ! + CALL ncio_read_vector (file_restart, 'savedtke1', landpatch, savedtke1) ! + + CALL ncio_read_vector (file_restart, 'snw_rds ', -maxsnl, landpatch, snw_rds ) ! + CALL ncio_read_vector (file_restart, 'mss_bcpho', -maxsnl, landpatch, mss_bcpho) ! + CALL ncio_read_vector (file_restart, 'mss_bcphi', -maxsnl, landpatch, mss_bcphi) ! + CALL ncio_read_vector (file_restart, 'mss_ocpho', -maxsnl, landpatch, mss_ocpho) ! + CALL ncio_read_vector (file_restart, 'mss_ocphi', -maxsnl, landpatch, mss_ocphi) ! + CALL ncio_read_vector (file_restart, 'mss_dst1 ', -maxsnl, landpatch, mss_dst1 ) ! + CALL ncio_read_vector (file_restart, 'mss_dst2 ', -maxsnl, landpatch, mss_dst2 ) ! + CALL ncio_read_vector (file_restart, 'mss_dst3 ', -maxsnl, landpatch, mss_dst3 ) ! + CALL ncio_read_vector (file_restart, 'mss_dst4 ', -maxsnl, landpatch, mss_dst4 ) ! + CALL ncio_read_vector (file_restart, 'ssno_lyr', 2,2, -maxsnl+1, landpatch, ssno_lyr) ! ! Additional variables required by reginal model (such as WRF ) RSM) - call ncio_read_vector (file_restart, 'trad ', landpatch, trad ) ! radiative temperature of surface [K] - call ncio_read_vector (file_restart, 'tref ', landpatch, tref ) ! 2 m height air temperature [kelvin] - call ncio_read_vector (file_restart, 'qref ', landpatch, qref ) ! 2 m height air specific humidity - call ncio_read_vector (file_restart, 'rst ', landpatch, rst ) ! canopy stomatal resistance (s/m) - call ncio_read_vector (file_restart, 'emis ', landpatch, emis ) ! averaged bulk surface emissivity - call ncio_read_vector (file_restart, 'z0m ', landpatch, z0m ) ! effective roughness [m] - call ncio_read_vector (file_restart, 'zol ', landpatch, zol ) ! dimensionless height (z/L) used in Monin-Obukhov theory - call ncio_read_vector (file_restart, 'rib ', landpatch, rib ) ! bulk Richardson number in surface layer - call ncio_read_vector (file_restart, 'ustar', landpatch, ustar) ! u* in similarity theory [m/s] - call ncio_read_vector (file_restart, 'qstar', landpatch, qstar) ! q* in similarity theory [kg/kg] - call ncio_read_vector (file_restart, 'tstar', landpatch, tstar) ! t* in similarity theory [K] - call ncio_read_vector (file_restart, 'fm ', landpatch, fm ) ! integral of profile function for momentum - call ncio_read_vector (file_restart, 'fh ', landpatch, fh ) ! integral of profile function for heat - call ncio_read_vector (file_restart, 'fq ', landpatch, fq ) ! integral of profile function for moisture - -#if (defined LULC_IGBP_PFT) - file_restart = trim(dir_restart)// '/' // trim(site) //'_restart_pft_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' + CALL ncio_read_vector (file_restart, 'trad ', landpatch, trad ) ! radiative temperature of surface [K] + CALL ncio_read_vector (file_restart, 'tref ', landpatch, tref ) ! 2 m height air temperature [kelvin] + CALL ncio_read_vector (file_restart, 'qref ', landpatch, qref ) ! 2 m height air specific humidity + CALL ncio_read_vector (file_restart, 'rst ', landpatch, rst ) ! canopy stomatal resistance (s/m) + CALL ncio_read_vector (file_restart, 'emis ', landpatch, emis ) ! averaged bulk surface emissivity + CALL ncio_read_vector (file_restart, 'z0m ', landpatch, z0m ) ! effective roughness [m] + CALL ncio_read_vector (file_restart, 'zol ', landpatch, zol ) ! dimensionless height (z/L) used in Monin-Obukhov theory + CALL ncio_read_vector (file_restart, 'rib ', landpatch, rib ) ! bulk Richardson number in surface layer + CALL ncio_read_vector (file_restart, 'ustar', landpatch, ustar) ! u* in similarity theory [m/s] + CALL ncio_read_vector (file_restart, 'qstar', landpatch, qstar) ! q* in similarity theory [kg/kg] + CALL ncio_read_vector (file_restart, 'tstar', landpatch, tstar) ! t* in similarity theory [K] + CALL ncio_read_vector (file_restart, 'fm ', landpatch, fm ) ! integral of profile function for momentum + CALL ncio_read_vector (file_restart, 'fh ', landpatch, fh ) ! integral of profile function for heat + CALL ncio_read_vector (file_restart, 'fq ', landpatch, fq ) ! integral of profile function for moisture + +IF (DEF_USE_IRRIGATION) THEN + CALL ncio_read_vector (file_restart, 'irrig_rate ' , landpatch, irrig_rate ) + CALL ncio_read_vector (file_restart, 'deficit_irrig ' , landpatch, deficit_irrig ) + CALL ncio_read_vector (file_restart, 'sum_irrig ' , landpatch, sum_irrig ) + CALL ncio_read_vector (file_restart, 'sum_irrig_count ' , landpatch, sum_irrig_count ) + CALL ncio_read_vector (file_restart, 'n_irrig_steps_left ' , landpatch, n_irrig_steps_left ) + CALL ncio_read_vector (file_restart, 'tairday ' , landpatch, tairday ) + CALL ncio_read_vector (file_restart, 'usday ' , landpatch, usday ) + CALL ncio_read_vector (file_restart, 'vsday ' , landpatch, vsday ) + CALL ncio_read_vector (file_restart, 'pairday ' , landpatch, pairday ) + CALL ncio_read_vector (file_restart, 'rnetday ' , landpatch, rnetday ) + CALL ncio_read_vector (file_restart, 'fgrndday ' , landpatch, fgrndday ) + CALL ncio_read_vector (file_restart, 'potential_evapotranspiration' , landpatch, potential_evapotranspiration) + CALL ncio_read_vector (file_restart, 'irrig_method_corn ' , landpatch, irrig_method_corn ) + CALL ncio_read_vector (file_restart, 'irrig_method_swheat ' , landpatch, irrig_method_swheat ) + CALL ncio_read_vector (file_restart, 'irrig_method_wwheat ' , landpatch, irrig_method_wwheat ) + CALL ncio_read_vector (file_restart, 'irrig_method_soybean ' , landpatch, irrig_method_soybean ) + CALL ncio_read_vector (file_restart, 'irrig_method_cotton ' , landpatch, irrig_method_cotton ) + CALL ncio_read_vector (file_restart, 'irrig_method_rice1 ' , landpatch, irrig_method_rice1 ) + CALL ncio_read_vector (file_restart, 'irrig_method_rice2 ' , landpatch, irrig_method_rice2 ) + CALL ncio_read_vector (file_restart, 'irrig_method_sugarcane' , landpatch, irrig_method_sugarcane) +ENDIF + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_pft_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' CALL READ_PFTimeVariables (file_restart) #endif -#if (defined LULC_IGBP_PC) - file_restart = trim(dir_restart)// '/' // trim(site) //'_restart_pc_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' - CALL READ_PCTimeVariables (file_restart) -#endif - #if (defined BGC) - file_restart = trim(dir_restart)// '/' // trim(site) //'_restart_bgc_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' + file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_bgc_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' CALL READ_BGCTimeVariables (file_restart) #endif -#if (defined LATERAL_FLOW) - file_restart = trim(dir_restart)// '/' // trim(site) //'_restart_basin_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' +#if (defined CatchLateralFlow) + file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_basin_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' CALL READ_HydroTimeVariables (file_restart) #endif #if (defined URBAN_MODEL) - file_restart = trim(dir_restart)// '/' // trim(site) //'_restart_urban_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' + file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_urban_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' CALL READ_UrbanTimeVariables (file_restart) #endif #ifdef RangeCheck - call check_TimeVariables + CALL check_TimeVariables #endif - if (p_is_master) then + IF (p_is_master) THEN write(*,*) 'Loading Time Variables done.' - end if + ENDIF - end subroutine READ_TimeVariables + END SUBROUTINE READ_TimeVariables !--------------------------------------- #ifdef RangeCheck SUBROUTINE check_TimeVariables () - use MOD_SPMD_Task - use MOD_RangeCheck - use MOD_Namelist, only: DEF_USE_PLANTHYDRAULICS, DEF_USE_OZONESTRESS + USE MOD_SPMD_Task + USE MOD_RangeCheck + USE MOD_Namelist, only: DEF_USE_PLANTHYDRAULICS, DEF_USE_OZONESTRESS, DEF_USE_IRRIGATION, & + DEF_USE_SNICAR IMPLICIT NONE #ifdef USEMPI - call mpi_barrier (p_comm_glb, p_err) + CALL mpi_barrier (p_comm_glb, p_err) #endif - if (p_is_master) then + IF (p_is_master) THEN write(*,'(/,A27)') 'Checking Time Variables ...' - end if - - call check_vector_data ('z_sno [m] ', z_sno ) ! node depth [m] - call check_vector_data ('dz_sno [m] ', dz_sno) ! interface depth [m] - call check_vector_data ('t_soisno [K] ', t_soisno ) ! soil temperature [K] - call check_vector_data ('wliq_soisno [kg/m2]', wliq_soisno) ! liquid water in layers [kg/m2] - call check_vector_data ('wice_soisno [kg/m2]', wice_soisno) ! ice lens in layers [kg/m2] - call check_vector_data ('smp [mm] ', smp ) ! soil matrix potential [mm] - call check_vector_data ('hk [mm/s] ', hk ) ! hydraulic conductivity [mm h2o/s] - if(DEF_USE_PLANTHYDRAULICS)then - call check_vector_data ('vegwp [m] ', vegwp ) ! vegetation water potential [mm] - call check_vector_data ('gs0sun [] ', gs0sun ) ! working copy of sunlit stomata conductance - call check_vector_data ('gs0sha [] ', gs0sha ) ! working copy of shalit stomata conductance - end if - IF(DEF_USE_OZONESTRESS)THEN - call check_vector_data ('o3coefv_sun', o3coefv_sun) - call check_vector_data ('o3coefv_sha', o3coefv_sha) - call check_vector_data ('o3coefg_sun', o3coefg_sun) - call check_vector_data ('o3coefg_sha', o3coefg_sha) - call check_vector_data ('lai_old ', lai_old ) - call check_vector_data ('o3uptakesun', o3uptakesun) - call check_vector_data ('o3uptakesha', o3uptakesha) ENDIF - call check_vector_data ('t_grnd [K] ', t_grnd ) ! ground surface temperature [K] - call check_vector_data ('tleaf [K] ', tleaf ) ! leaf temperature [K] - call check_vector_data ('ldew [mm] ', ldew ) ! depth of water on foliage [mm] - call check_vector_data ('ldew_rain [mm] ', ldew_rain ) ! depth of rain on foliage [mm] - call check_vector_data ('ldew_snow [mm] ', ldew_snow ) ! depth of snow on foliage [mm] - call check_vector_data ('sag [-] ', sag ) ! non dimensional snow age [-] - call check_vector_data ('scv [mm] ', scv ) ! snow cover, water equivalent [mm] - call check_vector_data ('snowdp [m] ', snowdp ) ! snow depth [meter] - call check_vector_data ('fveg [-] ', fveg ) ! fraction of vegetation cover - call check_vector_data ('fsno [-] ', fsno ) ! fraction of snow cover on ground - call check_vector_data ('sigf [-] ', sigf ) ! fraction of veg cover, excluding snow-covered veg [-] - call check_vector_data ('green [-] ', green ) ! leaf greenness - call check_vector_data ('lai [-] ', lai ) ! leaf area index - call check_vector_data ('tlai [-] ', tlai ) ! leaf area index - call check_vector_data ('sai [-] ', sai ) ! stem area index - call check_vector_data ('tsai [-] ', tsai ) ! stem area index - call check_vector_data ('coszen [-] ', coszen ) ! cosine of solar zenith angle - call check_vector_data ('alb [-] ', alb ) ! averaged albedo [-] - call check_vector_data ('ssun [-] ', ssun ) ! sunlit canopy absorption for solar radiation (0-1) - call check_vector_data ('ssha [-] ', ssha ) ! shaded canopy absorption for solar radiation (0-1) - call check_vector_data ('thermk [-] ', thermk ) ! canopy gap fraction for tir radiation - call check_vector_data ('extkb [-] ', extkb ) ! (k, g(mu)/mu) direct solar extinction coefficient - call check_vector_data ('extkd [-] ', extkd ) ! diffuse and scattered diffuse PAR extinction coefficient - call check_vector_data ('zwt [m] ', zwt ) ! the depth to water table [m] - call check_vector_data ('wa [mm] ', wa ) ! water storage in aquifer [mm] - call check_vector_data ('wdsrf [mm] ', wdsrf ) ! depth of surface water [mm] - - call check_vector_data ('t_lake [K] ', t_lake )! - call check_vector_data ('lake_icefrc [-] ', lake_icefrac)! - call check_vector_data ('savedtke1 [W/m K]', savedtke1 )! - -#if (defined LULC_IGBP_PFT) - CALL check_PFTimeVariables -#endif -#if (defined LULC_IGBP_PC) - CALL check_PCTimeVariables + CALL check_vector_data ('t_grnd [K] ', t_grnd ) ! ground surface temperature [K] + CALL check_vector_data ('tleaf [K] ', tleaf ) ! leaf temperature [K] + CALL check_vector_data ('ldew [mm] ', ldew ) ! depth of water on foliage [mm] + CALL check_vector_data ('ldew_rain [mm] ', ldew_rain ) ! depth of rain on foliage [mm] + CALL check_vector_data ('ldew_snow [mm] ', ldew_snow ) ! depth of snow on foliage [mm] + CALL check_vector_data ('sag [-] ', sag ) ! non dimensional snow age [-] + CALL check_vector_data ('scv [mm] ', scv ) ! snow cover, water equivalent [mm] + CALL check_vector_data ('snowdp [m] ', snowdp ) ! snow depth [meter] + CALL check_vector_data ('fveg [-] ', fveg ) ! fraction of vegetation cover + CALL check_vector_data ('fsno [-] ', fsno ) ! fraction of snow cover on ground + CALL check_vector_data ('sigf [-] ', sigf ) ! fraction of veg cover, excluding snow-covered veg [-] + CALL check_vector_data ('green [-] ', green ) ! leaf greenness + CALL check_vector_data ('lai [-] ', lai ) ! leaf area index + CALL check_vector_data ('tlai [-] ', tlai ) ! leaf area index + CALL check_vector_data ('sai [-] ', sai ) ! stem area index + CALL check_vector_data ('tsai [-] ', tsai ) ! stem area index + CALL check_vector_data ('coszen [-] ', coszen ) ! cosine of solar zenith angle + CALL check_vector_data ('alb [-] ', alb ) ! averaged albedo [-] + CALL check_vector_data ('ssun [-] ', ssun ) ! sunlit canopy absorption for solar radiation (0-1) + CALL check_vector_data ('ssha [-] ', ssha ) ! shaded canopy absorption for solar radiation (0-1) + CALL check_vector_data ('ssoi [-] ', ssoi ) ! soil absorption for solar radiation (0-1) + CALL check_vector_data ('ssno [-] ', ssno ) ! snow absorption for solar radiation (0-1) + CALL check_vector_data ('thermk [-] ', thermk ) ! canopy gap fraction for tir radiation + CALL check_vector_data ('extkb [-] ', extkb ) ! (k, g(mu)/mu) direct solar extinction coefficient + CALL check_vector_data ('extkd [-] ', extkd ) ! diffuse and scattered diffuse PAR extinction coefficient + CALL check_vector_data ('zwt [m] ', zwt ) ! the depth to water table [m] + CALL check_vector_data ('wa [mm] ', wa ) ! water storage in aquifer [mm] + CALL check_vector_data ('wetwat [mm] ', wetwat ) ! water storage in wetland [mm] + CALL check_vector_data ('wdsrf [mm] ', wdsrf ) ! depth of surface water [mm] + CALL check_vector_data ('rss [s/m] ', rss ) ! soil surface resistance [s/m] + CALL check_vector_data ('t_lake [K] ', t_lake )! + CALL check_vector_data ('lake_icefrc [-] ', lake_icefrac)! + CALL check_vector_data ('savedtke1 [W/m K]', savedtke1 )! + CALL check_vector_data ('z_sno [m] ', z_sno ) ! node depth [m] + CALL check_vector_data ('dz_sno [m] ', dz_sno) ! interface depth [m] + CALL check_vector_data ('t_soisno [K] ', t_soisno ) ! soil temperature [K] + CALL check_vector_data ('wliq_soisno [kg/m2]', wliq_soisno) ! liquid water in layers [kg/m2] + CALL check_vector_data ('wice_soisno [kg/m2]', wice_soisno) ! ice lens in layers [kg/m2] + CALL check_vector_data ('smp [mm] ', smp ) ! soil matrix potential [mm] + CALL check_vector_data ('hk [mm/s] ', hk ) ! hydraulic conductivity [mm h2o/s] +IF(DEF_USE_PLANTHYDRAULICS)THEN + CALL check_vector_data ('vegwp [m] ', vegwp ) ! vegetation water potential [mm] + CALL check_vector_data ('gs0sun [] ', gs0sun ) ! working copy of sunlit stomata conductance + CALL check_vector_data ('gs0sha [] ', gs0sha ) ! working copy of shalit stomata conductance +ENDIF +IF(DEF_USE_OZONESTRESS)THEN + CALL check_vector_data ('o3coefv_sun ', o3coefv_sun) + CALL check_vector_data ('o3coefv_sha ', o3coefv_sha) + CALL check_vector_data ('o3coefg_sun ', o3coefg_sun) + CALL check_vector_data ('o3coefg_sha ', o3coefg_sha) + CALL check_vector_data ('lai_old ', lai_old ) + CALL check_vector_data ('o3uptakesun ', o3uptakesun) + CALL check_vector_data ('o3uptakesha ', o3uptakesha) +ENDIF + +IF (DEF_USE_SNICAR) THEN + CALL check_vector_data ('snw_rds [m-6] ', snw_rds ) ! + CALL check_vector_data ('mss_bcpho [Kg] ', mss_bcpho ) ! + CALL check_vector_data ('mss_bcphi [Kg] ', mss_bcphi ) ! + CALL check_vector_data ('mss_ocpho [Kg] ', mss_ocpho ) ! + CALL check_vector_data ('mss_ocphi [Kg] ', mss_ocphi ) ! + CALL check_vector_data ('mss_dst1 [Kg] ', mss_dst1 ) ! + CALL check_vector_data ('mss_dst2 [Kg] ', mss_dst2 ) ! + CALL check_vector_data ('mss_dst3 [Kg] ', mss_dst3 ) ! + CALL check_vector_data ('mss_dst4 [Kg] ', mss_dst4 ) ! + CALL check_vector_data ('ssno_lyr [-] ', ssno_lyr ) ! +ENDIF + +IF (DEF_USE_IRRIGATION) THEN + CALL check_vector_data ('irrig_rate ' , irrig_rate ) + CALL check_vector_data ('deficit_irrig ' , deficit_irrig ) + CALL check_vector_data ('sum_irrig ' , sum_irrig ) + CALL check_vector_data ('sum_irrig_count ' , sum_irrig_count ) + CALL check_vector_data ('n_irrig_steps_left ' , n_irrig_steps_left ) + CALL check_vector_data ('tairday ' , tairday ) + CALL check_vector_data ('usday ' , usday ) + CALL check_vector_data ('vsday ' , vsday ) + CALL check_vector_data ('pairday ' , pairday ) + CALL check_vector_data ('rnetday ' , rnetday ) + CALL check_vector_data ('fgrndday ' , fgrndday ) + CALL check_vector_data ('potential_evapotranspiration' , potential_evapotranspiration) + CALL check_vector_data ('irrig_method_corn ' , irrig_method_corn ) + CALL check_vector_data ('irrig_method_swheat ' , irrig_method_swheat ) + CALL check_vector_data ('irrig_method_wwheat ' , irrig_method_wwheat ) + CALL check_vector_data ('irrig_method_soybean ' , irrig_method_soybean ) + CALL check_vector_data ('irrig_method_cotton ' , irrig_method_cotton ) + CALL check_vector_data ('irrig_method_rice1 ' , irrig_method_rice1 ) + CALL check_vector_data ('irrig_method_rice2 ' , irrig_method_rice2 ) + CALL check_vector_data ('irrig_method_sugarcane' , irrig_method_sugarcane) +ENDIF + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + CALL check_PFTimeVariables #endif #if (defined BGC) @@ -1489,10 +1353,10 @@ SUBROUTINE check_TimeVariables () #endif #ifdef USEMPI - call mpi_barrier (p_comm_glb, p_err) + CALL mpi_barrier (p_comm_glb, p_err) #endif - end subroutine check_TimeVariables + END SUBROUTINE check_TimeVariables #endif diff --git a/main/URBAN/MOD_Urban_BEM.F90 b/main/URBAN/MOD_Urban_BEM.F90 index 8fe999fb..3639d0f8 100644 --- a/main/URBAN/MOD_Urban_BEM.F90 +++ b/main/URBAN/MOD_Urban_BEM.F90 @@ -16,7 +16,7 @@ MODULE MOD_Urban_BEM CONTAINS - !------------------------------------------------- + !----------------------------------------------------------------------------------- SUBROUTINE SimpleBEM ( deltim, rhoair, fcover, H, troom_max, troom_min, & troof_nl_bef, twsun_nl_bef, twsha_nl_bef, & troof_nl, twsun_nl, twsha_nl, & @@ -27,55 +27,55 @@ SUBROUTINE SimpleBEM ( deltim, rhoair, fcover, H, troom_max, troom_min, & IMPLICIT NONE REAL(r8), intent(in) :: & - deltim, &! seconds in a time step [second] - rhoair, &! density air [kg/m3] - fcover(0:2),&! fractional cover of roof, wall - H, &! average building height [m] - troom_max, &! maximum temperature of inner building - troom_min, &! minimum temperature of inner building - troof_nl_bef,&!roof temperature at layer nl_roof - twsun_nl_bef,&!sunlit wall temperature at layer nl_wall - twsha_nl_bef,&!shaded wall temperature at layer nl_wall - troof_nl, &! roof temperature at layer nl_roof - twsun_nl, &! sunlit wall temperature at layer nl_wall - twsha_nl, &! shaded wall temperature at layer nl_wall - tkdz_roof, &! temporal var for heat transfer of roof - tkdz_wsun, &! temporal var for heat transfer of sunlit wall - tkdz_wsha, &! temporal var for heat transfer of shaded wall - taf ! temperature of urban air + deltim, &! seconds in a time step [second] + rhoair, &! density air [kg/m3] + fcover(0:2), &! fractional cover of roof, wall + H, &! average building height [m] + troom_max, &! maximum temperature of inner building + troom_min, &! minimum temperature of inner building + troof_nl_bef, &!roof temperature at layer nl_roof + twsun_nl_bef, &!sunlit wall temperature at layer nl_wall + twsha_nl_bef, &!shaded wall temperature at layer nl_wall + troof_nl, &! roof temperature at layer nl_roof + twsun_nl, &! sunlit wall temperature at layer nl_wall + twsha_nl, &! shaded wall temperature at layer nl_wall + tkdz_roof, &! temporal var for heat transfer of roof + tkdz_wsun, &! temporal var for heat transfer of sunlit wall + tkdz_wsha, &! temporal var for heat transfer of shaded wall + taf ! temperature of urban air REAL(r8), intent(inout) :: & - troom, &! temperature of inner building - troof_inner,&! temperature of inner roof - twsun_inner,&! temperature of inner sunlit wall - twsha_inner ! temperature of inner shaded wall + troom, &! temperature of inner building + troof_inner, &! temperature of inner roof + twsun_inner, &! temperature of inner sunlit wall + twsha_inner ! temperature of inner shaded wall REAL(r8), intent(out) :: & - Fhah, &! flux from heating - Fhac, &! flux from heat or cool AC - Fwst, &! waste heat from cool or heat - Fach ! flux from air exchange + Fhah, &! flux from heating + Fhac, &! flux from heat or cool AC + Fwst, &! waste heat from cool or heat + Fach ! flux from air exchange ! local variables - REAL(r8) :: & - ACH, &! air exchange coefficience - hcv_roof, &! convective exchange ceofficience for roof<->room - hcv_wall, &! convective exchange ceofficience for wall<->room - waste_coef, &! waste coefficient - waste_cool, &! waste heat for AC cooling - waste_heat ! waste heat for AC heating - - REAL(r8) :: & - f_wsun, &! weight factor for sunlit wall - f_wsha ! weight factor for shaded wall - - REAL(r8) :: & - A(4,4), &! Heat transfer matrix - Ainv(4,4), &! Inverse of Heat transfer matrix - B(4), &! B for Ax=B - X(4) ! x for Ax=B - - REAL(r8) :: & + REAL(r8) :: & + ACH, &! air exchange coefficience + hcv_roof, &! convective exchange ceofficience for roof<->room + hcv_wall, &! convective exchange ceofficience for wall<->room + waste_coef, &! waste coefficient + waste_cool, &! waste heat for AC cooling + waste_heat ! waste heat for AC heating + + REAL(r8) :: & + f_wsun, &! weight factor for sunlit wall + f_wsha ! weight factor for shaded wall + + REAL(r8) :: & + A(4,4), &! Heat transfer matrix + Ainv(4,4), &! Inverse of Heat transfer matrix + B(4), &! B for Ax=B + X(4) ! x for Ax=B + + REAL(r8) :: & troom_pro, &! projected room temperature troom_bef, &! temperature of inner building troof_inner_bef, &! temperature of inner roof @@ -84,9 +84,10 @@ SUBROUTINE SimpleBEM ( deltim, rhoair, fcover, H, troom_max, troom_min, & LOGICAL :: cooling, heating + ! Option for continuous AC LOGICAL, parameter :: Constant_AC = .true. - !================================================================= + !=================================================================================== ! ! o Solve the following equations ! o variables: troom, troof_inner, twsun_inner, twsha_innter @@ -102,7 +103,7 @@ SUBROUTINE SimpleBEM ( deltim, rhoair, fcover, H, troom_max, troom_min, & ! ------*H*rhoair*cpair*(Taf-Troom') + Hc_roof + Hc_wsun + Hc_wsha ! 3600 ! .................................(4) - !================================================================= + !=================================================================================== ACH = 0.3 !air exchange coefficience hcv_roof = 4.040 !convective exchange ceofficience for roof<->room (W m-2 K-1) @@ -193,7 +194,7 @@ SUBROUTINE SimpleBEM ( deltim, rhoair, fcover, H, troom_max, troom_min, & twsun_inner = (B(2)-A(2,4)*troom)/A(2,2) twsha_inner = (B(3)-A(3,4)*troom)/A(3,3) - Fhac = 0.5*hcv_roof*(troof_inner_bef-troom_bef) + 0.5*hcv_roof*(troof_inner-troom) + Fhac = 0.5*hcv_roof*(troof_inner_bef-troom_bef) + 0.5*hcv_roof*(troof_inner-troom) Fhac = 0.5*hcv_wall*(twsun_inner_bef-troom_bef)*f_wsun + 0.5*hcv_wall*(twsun_inner-troom)*f_wsun + Fhac Fhac = 0.5*hcv_wall*(twsha_inner_bef-troom_bef)*f_wsha + 0.5*hcv_wall*(twsha_inner-troom)*f_wsha + Fhac Fhah = Fhac @@ -208,6 +209,6 @@ SUBROUTINE SimpleBEM ( deltim, rhoair, fcover, H, troom_max, troom_min, & Fwst = Fwst*fcover(0) Fhac = Fhac*fcover(0) - END SUBROUTINE + END SUBROUTINE SimpleBEM END MODULE MOD_Urban_BEM diff --git a/main/URBAN/MOD_Urban_Const_LCZ.F90 b/main/URBAN/MOD_Urban_Const_LCZ.F90 index 00640040..5b464f61 100644 --- a/main/URBAN/MOD_Urban_Const_LCZ.F90 +++ b/main/URBAN/MOD_Urban_Const_LCZ.F90 @@ -1,5 +1,4 @@ #include -#ifdef URBAN_LCZ MODULE MOD_Urban_Const_LCZ ! ----------------------------------------------------------------------- @@ -63,7 +62,7 @@ MODULE MOD_Urban_Const_LCZ = (/0.25, 0.2 , 0.2 , 0.25, 0.25, 0.25, 0.2 , 0.25, 0.25, 0.2 /) ! albeodo of impervious road [-] - REAL(r8), parameter, dimension(10) :: albroad_lcz & + REAL(r8), parameter, dimension(10) :: albimproad_lcz & = (/0.15, 0.15, 0.18, 0.20, 0.20, 0.21, 0.24, 0.17, 0.23, 0.21/) ! albeodo of pervious road [-] @@ -115,4 +114,3 @@ MODULE MOD_Urban_Const_LCZ !TODO:AHE coding END MODULE MOD_Urban_Const_LCZ -#endif diff --git a/main/URBAN/MOD_Urban_Flux.F90 b/main/URBAN/MOD_Urban_Flux.F90 index dc7ee967..f132f79c 100644 --- a/main/URBAN/MOD_Urban_Flux.F90 +++ b/main/URBAN/MOD_Urban_Flux.F90 @@ -14,9 +14,6 @@ MODULE MOD_Urban_Flux PUBLIC :: UrbanVegFlux PUBLIC :: dewfraction -! PRIVATE MEMBER FUNCTIONS: - PRIVATE :: cal_z0_displa - ! Exponential extinction factor (alpha) options: ! 1. Masson, 2000; Oleson et al., 2008 ! 2. Swaid, 1993; Kusaka, 2001; Lee and Park, 2008 @@ -61,6 +58,7 @@ SUBROUTINE UrbanOnlyFlux ( & USE MOD_Precision USE MOD_Const_Physical, only: cpair,vonkar,grav USE MOD_FrictionVelocity + USE MOD_CanopyLayerProfile IMPLICIT NONE !----------------------- Dummy argument -------------------------------- @@ -541,11 +539,11 @@ SUBROUTINE UrbanOnlyFlux ( & rd(3) = frd(ktop, hroof, 0., hroof, displau+z0mu, displa/hroof, z0h_g, & obug, ustarg, z0mg, alpha, bee, 1.) - !REAL(r8) FUNCTION uintegral(utop, fc, bee, alpha, z0mg, htop, hbot, ztop, zbot) - !ueff_lay(2) = uintegral(utop, 1., bee, alpha, z0mg, hroof, 0., hroof, z0mg) + !REAL(r8) FUNCTION uintegralz(utop, fc, bee, alpha, z0mg, htop, hbot, ztop, zbot) + !ueff_lay(2) = uintegralz(utop, 1., bee, alpha, z0mg, hroof, 0., hroof, z0mg) - !REAL(r8) FUNCTION ueffect(utop, htop, hbot, ztop, zbot, z0mg, alpha, bee, fc) - ueff_lay(2) = ueffect(utop, hroof, 0., hroof, z0mg, z0mg, alpha, bee, 1.) + !REAL(r8) FUNCTION ueffectz(utop, htop, hbot, ztop, zbot, z0mg, alpha, bee, fc) + ueff_lay(2) = ueffectz(utop, hroof, 0., hroof, z0mg, z0mg, alpha, bee, 1.) !rd(2) = kintegral(ktop, 1., bee, alpha, z0mg, displa/hroof, & ! hroof, 0., obug, ustarg, displau+z0mu, z0qg) @@ -880,8 +878,9 @@ SUBROUTINE UrbanVegFlux ( & htop ,hbot ,lai ,sai ,& sqrtdi ,effcon ,vmax25 ,slti ,& hlti ,shti ,hhti ,trda ,& - trdm ,trop ,gradm ,binter ,& - extkn ,extkd ,dewmx ,etrc ,& + trdm ,trop ,g1 ,g0 ,& + gradm ,binter ,extkn ,extkd ,& + dewmx ,etrc ,& ! Status of surface z0h_g ,obug ,ustarg ,zlnd ,& zsno ,fsno_roof ,fsno_gimp ,fsno_gper ,& @@ -912,6 +911,7 @@ SUBROUTINE UrbanVegFlux ( & USE MOD_Precision USE MOD_Const_Physical, only: vonkar,grav,hvap,cpair,stefnc USE MOD_FrictionVelocity + USE MOD_CanopyLayerProfile USE MOD_AssimStomataConductance IMPLICIT NONE @@ -984,6 +984,8 @@ SUBROUTINE UrbanVegFlux ( & trda, &! temperature coefficient in gs-a model (s5) trdm, &! temperature coefficient in gs-a model (s6) trop, &! temperature coefficient in gs-a model (273+25) + g1, &! conductance-photosynthesis slope parameter for medlyn model + g0, &! conductance-photosynthesis intercept for medlyn model gradm, &! conductance-photosynthesis slope parameter binter, &! conductance-photosynthesis intercept @@ -1588,12 +1590,12 @@ SUBROUTINE UrbanVegFlux ( & rd(3) = frd(ktop, hroof, 0., hroof, displau+z0mu, displa/hroof, z0h_g, & obug, ustarg, z0mg, alpha, bee, 1.) - ! REAL(r8) FUNCTION uintegral(utop, fc, bee, alpha, z0mg, htop, hbot, ztop, zbot) - !ueff_lay(2) = uintegral(utop, 1., bee, alpha, z0mg, hroof, 0., hroof, z0mg) + ! REAL(r8) FUNCTION uintegralz(utop, fc, bee, alpha, z0mg, htop, hbot, ztop, zbot) + !ueff_lay(2) = uintegralz(utop, 1., bee, alpha, z0mg, hroof, 0., hroof, z0mg) - ! REAL(r8) FUNCTION ueffect(utop, htop, hbot, & + ! REAL(r8) FUNCTION ueffectz(utop, htop, hbot, & ! ztop, zbot, z0mg, alpha, bee, fc) - ueff_lay(2) = ueffect(utop, hroof, 0., hroof, z0mg, z0mg, alpha, bee, 1.) + ueff_lay(2) = ueffectz(utop, hroof, 0., hroof, z0mg, z0mg, alpha, bee, 1.) IF (numlay == 3) THEN ! REAL(r8) FUNCTION kintegral(ktop, fc, bee, alpha, z0mg, & @@ -1628,12 +1630,12 @@ SUBROUTINE UrbanVegFlux ( & obug, ustarg, z0mg, alpha, bee, 1.) ENDIF - !ueff_lay(2) = uintegral(utop, 1., bee, alpha, z0mg, hroof, 0., hroof, z0mg) + !ueff_lay(2) = uintegralz(utop, 1., bee, alpha, z0mg, hroof, 0., hroof, z0mg) !print *, "htop/hbot:", htop, hbot !fordebug - !ueff_veg = uintegral(utop, 1., bee, alpha, z0mg, hroof, 0., htop, hbot) + !ueff_veg = uintegralz(utop, 1., bee, alpha, z0mg, hroof, 0., htop, hbot) - !ueff_lay_(2) = ueffect(utop, hroof, 0., hroof, z0mg, z0mg, alpha, bee, 1.) - ueff_veg = ueffect(utop, hroof, 0., htop, hbot, z0mg, alpha, bee, 1.) + !ueff_lay_(2) = ueffectz(utop, hroof, 0., hroof, z0mg, z0mg, alpha, bee, 1.) + ueff_veg = ueffectz(utop, hroof, 0., htop, hbot, z0mg, alpha, bee, 1.) ! Masson, 2000: Account for different canyon orientations ! 2/PI is a factor derived from 0-360deg integration @@ -1694,9 +1696,9 @@ SUBROUTINE UrbanVegFlux ( & !----------------------------------------------------------------------- CALL stomata (vmax25,effcon ,slti ,hlti ,& shti ,hhti ,trda ,trdm ,trop ,& - gradm ,binter ,thm ,psrf ,po2m ,& - pco2m ,pco2a ,eah ,ei(3) ,tu(3) ,& - par ,& + g1 ,g0 ,gradm ,binter ,thm ,& + psrf ,po2m ,pco2m ,pco2a ,eah ,& + ei(3) ,tu(3) ,par ,& o3coefv ,o3coefg ,& rb(3)/lai,raw ,rstfac ,cint(:),& assim ,respc ,rs & @@ -2519,621 +2521,5 @@ SUBROUTINE dewfraction (sigf,lai,sai,dewmx,ldew,fwet) ENDIF END SUBROUTINE dewfraction -!---------------------------------------------------------------------- - - REAL(r8) FUNCTION uprofile(utop, fc, bee, alpha, z0mg, htop, hbot, z) - - USE MOD_Precision - USE MOD_FrictionVelocity - IMPLICIT NONE - - REAL(r8), intent(in) :: utop - REAL(r8), intent(in) :: fc - REAL(r8), intent(in) :: bee - REAL(r8), intent(in) :: alpha - REAL(r8), intent(in) :: z0mg - REAL(r8), intent(in) :: htop - REAL(r8), intent(in) :: hbot - REAL(r8), intent(in) :: z - - REAL(r8) :: ulog,uexp - - ulog = utop*log(z/z0mg)/log(htop/z0mg) - uexp = utop*exp(-alpha*(1-(z-hbot)/(htop-hbot))) - - uprofile = bee*fc*min(uexp,ulog) + (1-bee*fc)*ulog - - RETURN - END FUNCTION uprofile - - REAL(r8) FUNCTION kprofile(ktop, fc, bee, alpha, & - displah, htop, hbot, obu, ustar, z) - - USE MOD_Precision - USE MOD_FrictionVelocity - IMPLICIT NONE - - REAL(r8), parameter :: com1 = 0.4 - REAL(r8), parameter :: com2 = 0.08 - - REAL(r8), intent(in) :: ktop - REAL(r8), intent(in) :: fc - REAL(r8), intent(in) :: bee - REAL(r8), intent(in) :: alpha - REAL(r8), intent(in) :: displah - REAL(r8), intent(in) :: htop - REAL(r8), intent(in) :: hbot - REAL(r8), intent(in) :: obu - REAL(r8), intent(in) :: ustar - REAL(r8), intent(in) :: z - - REAL(r8) :: kexp - REAL(r8) :: klin, klins - REAL(r8) :: kcob - REAL(r8) :: fac - - klin = ktop*z/htop - - ! 02/07/2018: changed combination - fac = 1. / (1.+exp(-(displah-com1)/com2)) - kcob = 1. / (fac/klin + (1.-fac)/kmoninobuk(0.,obu,ustar,z)) - - kexp = ktop*exp(-alpha*(htop-z)/(htop-hbot)) - kprofile = 1./( bee*fc/min(kexp,kcob) + (1-bee*fc)/kcob ) - - RETURN - - END FUNCTION kprofile - - REAL(r8) FUNCTION uintegral(utop, fc, bee, alpha, z0mg, & - htop, hbot, ztop, zbot) - - USE MOD_Precision - IMPLICIT NONE - - REAL(r8), intent(in) :: utop - REAL(r8), intent(in) :: fc - REAL(r8), intent(in) :: bee - REAL(r8), intent(in) :: alpha - REAL(r8), intent(in) :: z0mg - REAL(r8), intent(in) :: htop - REAL(r8), intent(in) :: hbot - REAL(r8), intent(in) :: ztop - REAL(r8), intent(in) :: zbot - - INTEGER :: i, n - REAL(r8) :: dz, z, u - - ! 09/26/2017: change fixed n -> fixed dz - dz = 0.001 !fordebug only - n = int( (ztop-zbot) / dz ) + 1 - - uintegral = 0. - - DO i = 1, n - IF (i < n) THEN - z = ztop - (i-0.5)*dz - ELSE - dz = ztop - zbot - (n-1)*dz - z = zbot + 0.5*dz - ENDIF - - u = uprofile(utop, fc, bee, alpha, z0mg, htop, hbot, z) - - u = max(0._r8, u) - !uintegral = uintegral + sqrt(u)*dz / (htop-hbot) -! 03/04/2020, yuan: TODO-hard to solve - !NOTE: The integral cannot be solved analytically after - !the square root sign of u, and the integral can be approximated - !directly for u, In this way, there is no need to square - uintegral = uintegral + u*dz / (ztop-zbot) - ENDDO - - !uintegral = uintegral * uintegral - - RETURN - - END FUNCTION uintegral - - - ! Calculate the effective wind speed between ztop and zbot - REAL(r8) FUNCTION ueffect(utop, htop, hbot, & - ztop, zbot, z0mg, alpha, bee, fc) - USE MOD_Precision - IMPLICIT NONE - - REAL(r8), intent(in) :: utop - REAL(r8), intent(in) :: htop - REAL(r8), intent(in) :: hbot - REAL(r8), intent(in) :: ztop - REAL(r8), intent(in) :: zbot - REAL(r8), intent(in) :: z0mg - REAL(r8), intent(in) :: alpha - REAL(r8), intent(in) :: bee - REAL(r8), intent(in) :: fc - - REAL(r8) :: roots(2), uint - INTEGER :: rootn - - rootn = 0 - uint = 0. - - ! The dichotomy method to find the root satisfies a certain accuracy, - ! assuming that there are at most 2 roots - CALL ufindroots(ztop,zbot,(ztop+zbot)/2., & - utop, htop, hbot, z0mg, alpha, roots, rootn) - -! 03/10/2020, yuan: integration for wind speed - IF (rootn == 0) THEN ! no root - uint = uint + fuint(utop, ztop, zbot, & - htop, hbot, z0mg, alpha, bee, fc) - ENDIF - - IF (rootn == 1) THEN - uint = uint + fuint(utop, ztop, roots(1), & - htop, hbot, z0mg, alpha, bee, fc) - uint = uint + fuint(utop, roots(1), zbot, & - htop, hbot, z0mg, alpha, bee, fc) - ENDIF - - IF (rootn == 2) THEN - uint = uint + fuint(utop, ztop, roots(1), & - htop, hbot, z0mg, alpha, bee, fc) - uint = uint + fuint(utop, roots(1), roots(2), & - htop, hbot, z0mg, alpha, bee, fc) - uint = uint + fuint(utop, roots(2), zbot, & - htop, hbot, z0mg, alpha, bee, fc) - ENDIF - - ueffect = uint / (ztop-zbot) - - RETURN - - END FUNCTION ueffect - - - REAL(r8) FUNCTION fuint(utop, ztop, zbot, & - htop, hbot, z0mg, alpha, bee, fc) - - USE MOD_Precision - IMPLICIT NONE - - REAL(r8), intent(in) :: utop, ztop, zbot - REAL(r8), intent(in) :: htop, hbot - REAL(r8), intent(in) :: z0mg, alpha - REAL(r8), intent(in) :: bee, fc - - ! local variables - REAL(r8) :: fuexpint, fulogint - - fulogint = utop/log(htop/z0mg) *& - !(ztop*log(ztop/z0mg) - zbot*log(zbot/z0mg) + zbot - ztop) / (ztop-zbot) - (ztop*log(ztop/z0mg) - zbot*log(zbot/z0mg) + zbot - ztop) - - IF (udif((ztop+zbot)/2.,utop,htop,hbot,z0mg,alpha) <= 0) THEN - ! uexp is smaller - fuexpint = utop*(htop-hbot)/alpha*( & - ! yuan, 12/28/2020: - exp(-alpha*(htop-ztop)/(htop-hbot))-& - exp(-alpha*(htop-zbot)/(htop-hbot)) ) - ! yuan, 06/01/2021: - !exp(-alpha*(ztop-ztop)/(htop-hbot))-& - !exp(-alpha*(ztop-zbot)/(htop-hbot)) ) - - fuint = bee*fc*fuexpint + (1.-bee*fc)*fulogint - ELSE - ! ulog is smaller - fuint = fulogint - ENDIF - - RETURN - - END FUNCTION fuint - - - RECURSIVE SUBROUTINE ufindroots(ztop,zbot,zmid, & - utop, htop, hbot, z0mg, alpha, roots, rootn) - - USE MOD_Precision - IMPLICIT NONE - - REAL(r8), intent(in) :: ztop, zbot, zmid - REAL(r8), intent(in) :: utop, htop, hbot - REAL(r8), intent(in) :: z0mg, alpha - - REAL(r8), intent(inout) :: roots(2) - INTEGER, intent(inout) :: rootn - - ! local variables - REAL(r8) :: udif_ub, udif_lb - - udif_ub = udif(ztop,utop,htop,hbot,z0mg,alpha) - udif_lb = udif(zmid,utop,htop,hbot,z0mg,alpha) - - IF (udif_ub*udif_lb == 0) THEN - IF (udif_lb == 0) THEN !root found - rootn = rootn + 1 - IF (rootn > 2) THEN - print *, "U root number > 2, abort!" - CALL abort - ENDIF - roots(rootn) = zmid - ENDIF - ELSE IF (udif_ub*udif_lb < 0) THEN - IF (ztop-zmid < 0.01) THEN - rootn = rootn + 1 !root found - IF (rootn > 2) THEN - print *, "U root number > 2, abort!" - CALL abort - ENDIF - roots(rootn) = (ztop+zmid)/2. - ELSE - CALL ufindroots(ztop,zmid,(ztop+zmid)/2., & - utop, htop, hbot, z0mg, alpha, roots, rootn) - ENDIF - ENDIF - - udif_ub = udif(zmid,utop,htop,hbot,z0mg,alpha) - udif_lb = udif(zbot,utop,htop,hbot,z0mg,alpha) - - IF (udif_ub*udif_lb == 0) THEN - IF (udif_ub == 0) THEN !root found - rootn = rootn + 1 - IF (rootn > 2) THEN - print *, "U root number > 2, abort!" - CALL abort - ENDIF - roots(rootn) = zmid - ENDIF - ELSE IF (udif_ub*udif_lb < 0) THEN - IF (zmid-zbot < 0.01) THEN - rootn = rootn + 1 !root found - IF (rootn > 2) THEN - print *, "U root number > 2, abort!" - CALL abort - ENDIF - roots(rootn) = (zmid+zbot)/2. - ELSE - CALL ufindroots(zmid,zbot,(zmid+zbot)/2., & - utop, htop, hbot, z0mg, alpha, roots, rootn) - ENDIF - ENDIF - - END SUBROUTINE ufindroots - - - REAL(r8) FUNCTION udif(z, utop, htop, hbot, z0mg, alpha) - - USE MOD_Precision - IMPLICIT NONE - - REAL(r8), intent(in) :: z, utop, htop, hbot - REAL(r8), intent(in) :: z0mg, alpha - - REAL(r8) :: uexp, ulog - - ! yuan, 12/28/2020: - uexp = utop*exp(-alpha*(htop-z)/(htop-hbot)) - ulog = utop*log(z/z0mg)/log(htop/z0mg) - - udif = uexp - ulog - - RETURN - - END FUNCTION udif - - - ! 03/08/2020, yuan: change it to analytical solution - REAL(r8) FUNCTION kintegral(ktop, fc, bee, alpha, z0mg, & - displah, htop, hbot, obu, ustar, ztop, zbot) - USE MOD_Precision - IMPLICIT NONE - - REAL(r8), intent(in) :: ktop - REAL(r8), intent(in) :: fc - REAL(r8), intent(in) :: bee - REAL(r8), intent(in) :: alpha - REAL(r8), intent(in) :: z0mg - REAL(r8), intent(in) :: displah - REAL(r8), intent(in) :: htop - REAL(r8), intent(in) :: hbot - REAL(r8), intent(in) :: obu - REAL(r8), intent(in) :: ustar - REAL(r8), intent(in) :: ztop - REAL(r8), intent(in) :: zbot - - INTEGER :: i, n - REAL(r8) :: dz, z, k - - kintegral = 0. - - IF (ztop <= zbot) THEN - RETURN - ENDIF - - ! 09/26/2017: change fixed n -> fixed dz - dz = 0.001 ! fordebug only - n = int( (ztop-zbot) / dz ) + 1 - - DO i = 1, n - IF (i < n) THEN - z = ztop - (i-0.5)*dz - ELSE - dz = ztop - zbot - (n-1)*dz - z = zbot + 0.5*dz - ENDIF - - k = kprofile(ktop, fc, bee, alpha, & - displah, htop, hbot, obu, ustar, z) - - kintegral = kintegral + 1./k * dz - - ENDDO - - RETURN - - END FUNCTION kintegral - - - REAL(r8) FUNCTION frd(ktop, htop, hbot, & - ztop, zbot, displah, z0h, obu, ustar, & - z0mg, alpha, bee, fc) - - USE MOD_Precision - IMPLICIT NONE - - REAL(r8), intent(in) :: ktop, htop, hbot - REAL(r8), intent(in) :: ztop, zbot - REAL(r8), intent(in) :: displah, z0h, obu, ustar - REAL(r8), intent(in) :: z0mg, alpha, bee, fc - - ! local parameters - REAL(r8), parameter :: com1 = 0.4 - REAL(r8), parameter :: com2 = 0.08 - - REAL(r8) :: roots(2), fac, kint - INTEGER :: rootn - - rootn = 0 - kint = 0. - - ! calculate fac - ! yuan, 12/28/2020: - fac = 1. / (1.+exp(-(displah-com1)/com2)) - roots(:) = 0. - - CALL kfindroots(ztop,zbot,(ztop+zbot)/2., & - ktop, htop, hbot, obu, ustar, fac, alpha, roots, rootn) - - !print *, roots, rootn - IF (rootn == 0) THEN !no root - kint = kint + fkint(ktop, ztop, zbot, htop, hbot, & - z0h, obu, ustar, fac, alpha, bee, fc) - ENDIF - - IF (rootn == 1) THEN - kint = kint + fkint(ktop, ztop, roots(1), htop, hbot, & - z0h, obu, ustar, fac, alpha, bee, fc) - kint = kint + fkint(ktop, roots(1), zbot, htop, hbot, & - z0h, obu, ustar, fac, alpha, bee, fc) - ENDIF - - IF (rootn == 2) THEN - kint = kint + fkint(ktop, ztop, roots(1), htop, hbot, & - z0h, obu, ustar, fac, alpha, bee, fc) - kint = kint + fkint(ktop, roots(1), roots(2), htop, hbot, & - z0h, obu, ustar, fac, alpha, bee, fc) - kint = kint + fkint(ktop, roots(2), zbot, htop, hbot, & - z0h, obu, ustar, fac, alpha, bee, fc) - ENDIF - - frd = kint - - RETURN - - END FUNCTION frd - - - REAL(r8) FUNCTION fkint(ktop, ztop, zbot, htop, hbot, & - z0h, obu, ustar, fac, alpha, bee, fc) - - USE MOD_Precision - USE MOD_FrictionVelocity - IMPLICIT NONE - - REAL(r8), intent(in) :: ktop, ztop, zbot - REAL(r8), intent(in) :: htop, hbot - REAL(r8), intent(in) :: z0h, obu, ustar, fac, alpha - REAL(r8), intent(in) :: bee, fc - - ! local variables - REAL(r8) :: fkexpint, fkcobint - - !NOTE: - ! klin = ktop*z/htop - ! kcob = 1./(fac/klin + (1.-fac)/kmoninobuk(0.,obu,ustar,z)) - fkcobint = fac*htop/ktop*(log(ztop)-log(zbot)) +& - (1.-fac)*kintmoninobuk(0.,z0h,obu,ustar,ztop,zbot) - - IF (kdif((ztop+zbot)/2.,ktop,htop,hbot,obu,ustar,fac,alpha) <= 0) THEN - ! kexp is smaller - IF (alpha > 0) THEN - fkexpint = -(htop-hbot)/alpha/ktop*( & - exp(alpha*(htop-ztop)/(htop-hbot))-& - exp(alpha*(htop-zbot)/(htop-hbot)) ) - ELSE - fkexpint = (ztop-zbot)/ktop - ENDIF - - fkint = bee*fc*fkexpint + (1.-bee*fc)*fkcobint - ELSE - ! kcob is smaller - fkint = fkcobint - ENDIF - - RETURN - END FUNCTION fkint - - - RECURSIVE SUBROUTINE kfindroots(ztop,zbot,zmid, & - ktop, htop, hbot, obu, ustar, fac, alpha, roots, rootn) - - USE MOD_Precision - IMPLICIT NONE - - REAL(r8), intent(in) :: ztop, zbot, zmid - REAL(r8), intent(in) :: ktop, htop, hbot - REAL(r8), intent(in) :: obu, ustar, fac, alpha - - REAL(r8), intent(inout) :: roots(2) - INTEGER, intent(inout) :: rootn - - ! local variables - REAL(r8) :: kdif_ub, kdif_lb - - !print *, "*** CALL recursive SUBROUTINE kfindroots!!" - kdif_ub = kdif(ztop,ktop,htop,hbot,obu,ustar,fac,alpha) - kdif_lb = kdif(zmid,ktop,htop,hbot,obu,ustar,fac,alpha) - - IF (kdif_ub*kdif_lb == 0) THEN - IF (kdif_lb == 0) THEN !root found - rootn = rootn + 1 - IF (rootn > 2) THEN - print *, "K root number > 2, abort!" - CALL abort - ENDIF - roots(rootn) = zmid - ENDIF - ELSE IF (kdif_ub*kdif_lb < 0) THEN - IF (ztop-zmid < 0.01) THEN - rootn = rootn + 1 !root found - IF (rootn > 2) THEN - print *, "K root number > 2, abort!" - CALL abort - ENDIF - roots(rootn) = (ztop+zmid)/2. - ELSE - CALL kfindroots(ztop,zmid,(ztop+zmid)/2., & - ktop, htop, hbot, obu, ustar, fac, alpha, roots, rootn) - ENDIF - ENDIF - - kdif_ub = kdif(zmid,ktop,htop,hbot,obu,ustar,fac,alpha) - kdif_lb = kdif(zbot,ktop,htop,hbot,obu,ustar,fac,alpha) - - IF (kdif_ub*kdif_lb == 0) THEN - IF (kdif_ub == 0) THEN !root found - rootn = rootn + 1 - IF (rootn > 2) THEN - print *, "K root number > 2, abort!" - CALL abort - ENDIF - roots(rootn) = zmid - ENDIF - ELSE IF (kdif_ub*kdif_lb < 0) THEN - IF (zmid-zbot < 0.01) THEN - rootn = rootn + 1 !root found - IF (rootn > 2) THEN - print *, "K root number > 2, abort!" - CALL abort - ENDIF - roots(rootn) = (zmid+zbot)/2. - ELSE - CALL kfindroots(zmid,zbot,(zmid+zbot)/2., & - ktop, htop, hbot, obu, ustar, fac, alpha, roots, rootn) - ENDIF - ENDIF - - END SUBROUTINE kfindroots - - - REAL(r8) FUNCTION kdif(z, ktop, htop, hbot, & - obu, ustar, fac, alpha) - - USE MOD_Precision - USE MOD_FrictionVelocity - IMPLICIT NONE - - REAL(r8), intent(in) :: z, ktop, htop, hbot - REAL(r8), intent(in) :: obu, ustar, fac, alpha - - REAL(r8) :: kexp, klin, kcob - - kexp = ktop*exp(-alpha*(htop-z)/(htop-hbot)) - - klin = ktop*z/htop - kcob = 1./(fac/klin + (1.-fac)/kmoninobuk(0.,obu,ustar,z)) - - kdif = kexp - kcob - - RETURN - - END FUNCTION kdif - - - SUBROUTINE cal_z0_displa (lai, h, fc, z0, displa) - - USE MOD_Const_Physical, only: vonkar - IMPLICIT NONE - - REAL(r8), intent(in) :: lai - REAL(r8), intent(in) :: h - REAL(r8), intent(in) :: fc - REAL(r8), intent(out) :: z0 - REAL(r8), intent(out) :: displa - - REAL(r8), parameter :: Cd = 0.2 !leaf drag coefficient - REAL(r8), parameter :: cd1 = 7.5 !a free parameter for d/h calculation, Raupach 1992, 1994 - REAL(r8), parameter :: psih = 0.193 !psih = ln(cw) - 1 + cw^-1, cw = 2, Raupach 1994 - - ! local variables - REAL(r8) :: fai, sqrtdragc, temp1, delta , lai0 - - ! when assume z0=0.01, displa=0 - ! to calculate lai0, delta displa - !---------------------------------------------------- - sqrtdragc = -vonkar/(log(0.01/h) - psih) - sqrtdragc = max(sqrtdragc, 0.0031**0.5) - IF (sqrtdragc .le. 0.3) THEN - fai = (sqrtdragc**2-0.003) / 0.3 - fai = min(fai, fc*(1-exp(-20.))) - ELSE - fai = 0.29 - print *, "z0m, displa error!" - ENDIF - - ! calculate delta displa when z0 = 0.01 - lai0 = -log(1.-fai/fc)/0.5 - temp1 = (2.*cd1*fai)**0.5 - delta = -h * ( fc*1.1*log(1. + (Cd*lai0*fc)**0.25) + & - (1.-fc)*(1.-(1.-exp(-temp1))/temp1) ) - - ! calculate z0m, displa - !---------------------------------------------------- - ! NOTE: potential bug below, ONLY apply for spheric - ! crowns. For other cases, fc*(...) ==> a*fc*(...) - fai = fc*(1. - exp(-0.5*lai)) - sqrtdragc = min( (0.003+0.3*fai)**0.5, 0.3 ) - temp1 = (2.*cd1*fai)**0.5 - - IF (lai > lai0) THEN - displa = delta + h*( & - ( fc)*1.1*log(1. + (Cd*lai*fc)**0.25) + & - (1-fc)*(1.-(1.-exp(-temp1))/temp1) ) - ELSE - displa = h*( & - ( fc)*1.1*log(1. + (Cd*lai*fc)**0.25) + & - (1-fc)*(1.-(1.-exp(-temp1))/temp1) ) - ENDIF - - displa = max(displa, 0.) - z0 = (h-displa) * exp(-vonkar/sqrtdragc + psih) - - IF (z0 < 0.01) THEN - z0 = 0.01 - displa = 0. - ENDIF - - END SUBROUTINE cal_z0_displa END MODULE MOD_Urban_Flux diff --git a/main/URBAN/MOD_Urban_Hydrology.F90 b/main/URBAN/MOD_Urban_Hydrology.F90 index d888cd5c..2e84daab 100644 --- a/main/URBAN/MOD_Urban_Hydrology.F90 +++ b/main/URBAN/MOD_Urban_Hydrology.F90 @@ -21,7 +21,7 @@ SUBROUTINE UrbanHydrology ( & froof ,fgper ,flake ,bsw ,& porsl ,psi0 ,hksati ,wtfact ,& pondmx ,ssi ,wimp ,smpmin ,& - rootr ,etr ,fseng ,fgrnd ,& + rootr,rootflux ,etr ,fseng ,fgrnd ,& t_gpersno ,t_lakesno ,t_lake ,dz_lake ,& z_gpersno ,z_lakesno ,zi_gpersno ,zi_lakesno ,& dz_roofsno ,dz_gimpsno ,dz_gpersno ,dz_lakesno ,& @@ -66,7 +66,7 @@ SUBROUTINE UrbanHydrology ( & !-----------------------Argument---------------------------------------- INTEGER, intent(in) :: & ipatch ,&! patch index - patchtype ,&! land water TYPE (0=soil, 1=urban or built-up, 2=wetland, + patchtype ,&! land patch type (0=soil, 1=urban or built-up, 2=wetland, ! 3=land ice, 4=land water bodies, 99=ocean lbr ,&! lower bound of array lbi ,&! lower bound of array @@ -121,9 +121,11 @@ SUBROUTINE UrbanHydrology ( & sm_gper ,&! snow melt (mm h2o/s) w_old ! liquid water mass of the column at the previous time step (mm) + REAL(r8), intent(inout) :: rootflux(1:nl_soil) + #if(defined CaMa_Flood) real(r8), INTENT(inout) :: flddepth ! inundation water depth [mm] - real(r8), INTENT(in) :: fldfrc ! inundation water depth [0-1] + real(r8), INTENT(in) :: fldfrc ! inundation water depth [0-1] real(r8), INTENT(out) :: qinfl_fld ! grid averaged inundation water input from top (mm/s) #endif @@ -218,13 +220,20 @@ SUBROUTINE UrbanHydrology ( & !======================================================================= ! [1] for pervious road, the same as soil !======================================================================= - - CALL WATER ( ipatch,patchtype ,lbp ,nl_soil ,deltim ,& + rootflux(:) = rootr(:)*etr + CALL WATER_2014 (ipatch,patchtype, lbp ,nl_soil ,deltim ,& z_gpersno ,dz_gpersno ,zi_gpersno ,& - bsw ,porsl ,psi0 ,hksati ,rootr ,& + bsw ,porsl ,psi0 ,hksati,rootr,rootflux,& t_gpersno ,wliq_gpersno,wice_gpersno,smp,hk,pgper_rain,sm_gper,& etr ,qseva_gper ,qsdew_gper ,qsubl_gper,qfros_gper,& - rsur_gper ,rnof_gper ,qinfl ,wtfact ,pondmx ,& + !NOTE: temporal input, as urban mode doesn't support split soil&snow + ! set all the same for soil and snow surface, + ! and fsno=0. (no physical meaning here) + qseva_gper ,qsdew_gper ,qsubl_gper,qfros_gper,& + qseva_gper ,qsdew_gper ,qsubl_gper,qfros_gper,& + 0. ,& ! fsno, not active + rsur_gper ,& + rnof_gper ,qinfl ,wtfact ,pondmx ,& ssi ,wimp ,smpmin ,zwt ,wa ,& qcharge ,errw_rsub & #if(defined CaMa_Flood) @@ -317,6 +326,7 @@ SUBROUTINE UrbanHydrology ( & ! --------------------------- z_lakesno ,dz_lakesno ,zi_lakesno ,t_lakesno ,& wice_lakesno ,wliq_lakesno ,t_lake ,lake_icefrac ,& + gwat , & dfseng ,dfgrnd ,snll ,scv_lake ,& snowdp_lake ,sm_lake ,forc_us ,forc_vs & ! SNICAR model variables diff --git a/main/URBAN/MOD_Urban_ImperviousTemperature.F90 b/main/URBAN/MOD_Urban_ImperviousTemperature.F90 index 090c5d8d..26923bde 100644 --- a/main/URBAN/MOD_Urban_ImperviousTemperature.F90 +++ b/main/URBAN/MOD_Urban_ImperviousTemperature.F90 @@ -51,7 +51,7 @@ SUBROUTINE UrbanImperviousTem (patchtype,lb,deltim, & IMPLICIT NONE integer, intent(in) :: lb !lower bound of array - integer, intent(in) :: patchtype !land water type (0=soil,1=urban or built-up,2=wetland, + integer, intent(in) :: patchtype !land patch type (0=soil,1=urban or built-up,2=wetland, !3=land ice, 4=deep lake, 5=shallow lake) real(r8), intent(in) :: deltim !seconds in a time step [second] real(r8), intent(in) :: capr !tuning factor to turn first layer T into surface T diff --git a/main/URBAN/MOD_Urban_LAIReadin.F90 b/main/URBAN/MOD_Urban_LAIReadin.F90 index bc3281cd..a2bb2e88 100644 --- a/main/URBAN/MOD_Urban_LAIReadin.F90 +++ b/main/URBAN/MOD_Urban_LAIReadin.F90 @@ -27,6 +27,9 @@ SUBROUTINE UrbanLAI_readin (year, time, dir_landdata) USE MOD_Vars_TimeInvariants USE MOD_Urban_Vars_TimeInvariants USE MOD_NetCDFVector +#ifdef SinglePoint + USE MOD_SingleSrfdata +#endif IMPLICIT NONE @@ -36,19 +39,23 @@ SUBROUTINE UrbanLAI_readin (year, time, dir_landdata) CHARACTER(LEN=256) :: lndname CHARACTER(len=256) :: cyear, ctime - INTEGER :: u, npatch + INTEGER :: u, npatch, iyear ! READ in Leaf area index and stem area index write(ctime,'(i2.2)') time write(cyear,'(i4.4)') year - !TODO-done: parameter input for time year +#ifdef SinglePoint + iyear = findloc(SITE_LAI_year, year, dim=1) + urb_lai(:) = SITE_LAI_monthly(time,iyear) + urb_sai(:) = SITE_SAI_monthly(time,iyear) +#else lndname = trim(dir_landdata)//'/urban/'//trim(cyear)//'/LAI/urban_LAI_'//trim(ctime)//'.nc' call ncio_read_vector (lndname, 'TREE_LAI', landurban, urb_lai) lndname = trim(dir_landdata)//'/urban/'//trim(cyear)//'/LAI/urban_SAI_'//trim(ctime)//'.nc' call ncio_read_vector (lndname, 'TREE_SAI', landurban, urb_sai) - +#endif ! loop for urban atch to assign fraction of green leaf IF (p_is_worker) THEN DO u = 1, numurban diff --git a/main/URBAN/MOD_Urban_PerviousTemperature.F90 b/main/URBAN/MOD_Urban_PerviousTemperature.F90 index 2b30da04..9760534f 100644 --- a/main/URBAN/MOD_Urban_PerviousTemperature.F90 +++ b/main/URBAN/MOD_Urban_PerviousTemperature.F90 @@ -58,7 +58,7 @@ SUBROUTINE UrbanPerviousTem (patchtype,lb,deltim, & IMPLICIT NONE integer, intent(in) :: lb !lower bound of array - integer, intent(in) :: patchtype !land water type (0=soil,1=urban or built-up,2=wetland, + integer, intent(in) :: patchtype !land patch type (0=soil,1=urban or built-up,2=wetland, !3=land ice, 4=deep lake, 5=shallow lake) real(r8), intent(in) :: deltim !seconds in a time step [second] real(r8), intent(in) :: capr !tuning factor to turn first layer T into surface T @@ -272,7 +272,10 @@ SUBROUTINE UrbanPerviousTem (patchtype,lb,deltim, & ENDDO CALL meltf (patchtype,lb,nl_soil,deltim, & - fact(lb:),brr(lb:),hs,dhsdT, & + !NOTE: compatibility settings for spliting soil&snow + ! temporal input, as urban mode doesn't support split soil&snow + ! hs_soil=hs, hs_snow=hs, fsno=0. + fact(lb:),brr(lb:),hs,hs,hs,0.,dhsdT, & t_gpersno_bef(lb:),t_gpersno(lb:),wliq_gpersno(lb:),wice_gpersno(lb:),imelt(lb:), & scv_gper,snowdp_gper,sm,xmf,porsl,psi0,& #ifdef Campbell_SOIL_MODEL diff --git a/main/URBAN/MOD_Urban_Shortwave.F90 b/main/URBAN/MOD_Urban_Shortwave.F90 index ea0fbaec..c10fc455 100644 --- a/main/URBAN/MOD_Urban_Shortwave.F90 +++ b/main/URBAN/MOD_Urban_Shortwave.F90 @@ -6,6 +6,7 @@ MODULE MOD_Urban_Shortwave USE MOD_LandUrban USE MOD_Vars_Global USE MOD_3DCanopyRadiation, only: tee, phi + USE MOD_SPMD_Task IMPLICIT NONE SAVE @@ -678,14 +679,14 @@ FUNCTION MatrixInverse(A) result(Ainv) ! using partial pivoting with row interchanges. CALL DGETRF(n, n, Ainv, n, ipiv, info) IF (info /= 0) THEN - stop 'Matrix is numerically singular!' + CALL CoLM_stop('Matrix is numerically singular!') ENDIF ! DGETRI computes the inverse of a matrix using the LU factorization ! computed by DGETRF. CALL DGETRI(n, Ainv, n, ipiv, work, n, info) IF (info /= 0) THEN - stop 'Matrix inversion failed!' + CALL CoLM_stop('Matrix inversion failed!') ENDIF END FUNCTION MatrixInverse diff --git a/main/URBAN/MOD_Urban_Thermal.F90 b/main/URBAN/MOD_Urban_Thermal.F90 index db12cedc..a95d9f50 100644 --- a/main/URBAN/MOD_Urban_Thermal.F90 +++ b/main/URBAN/MOD_Urban_Thermal.F90 @@ -55,7 +55,8 @@ SUBROUTINE UrbanTHERMAL ( & dewmx ,sqrtdi ,rootfr ,effcon ,& vmax25 ,slti ,hlti ,shti ,& hhti ,trda ,trdm ,trop ,& - gradm ,binter ,extkn ,& + g1 ,g0 ,gradm ,binter ,& + extkn ,& ! surface status fsno_roof ,fsno_gimp ,fsno_gper ,scv_roof ,& @@ -128,7 +129,7 @@ SUBROUTINE UrbanTHERMAL ( & INTEGER, intent(in) :: & idate(3) ,& ipatch ,&! patch index - patchtype ,&! land cover type (0=soil, 1=urban or built-up, 2=wetland, + patchtype ,&! land patch type (0=soil, 1=urban or built-up, 2=wetland, ! 3=glacier/ice sheet, 4=land water bodies) lbr ,&! lower bound of array lbi ,&! lower bound of array @@ -263,6 +264,8 @@ SUBROUTINE UrbanTHERMAL ( & trda ,&! temperature coefficient in gs-a model [s5] trdm ,&! temperature coefficient in gs-a model [s6] trop ,&! temperature coefficient in gs-a model + g1 ,&! conductance-photosynthesis slope parameter for medlyn model + g0 ,&! conductance-photosynthesis intercept for medlyn model gradm ,&! conductance-photosynthesis slope parameter binter ,&! conductance-photosynthesis intercept extkn ! coefficient of leaf nitrogen allocation @@ -842,8 +845,9 @@ SUBROUTINE UrbanTHERMAL ( & htop ,hbot ,lai ,sai ,& sqrtdi ,effcon ,vmax25 ,slti ,& hlti ,shti ,hhti ,trda ,& - trdm ,trop ,gradm ,binter ,& - extkn ,extkd ,dewmx ,etrc ,& + trdm ,trop ,g1 ,g0 ,& + gradm ,binter ,extkn ,extkd ,& + dewmx ,etrc ,& ! surface status z0h_g ,obu_g ,ustar_g ,zlnd ,& zsno ,fsno_roof ,fsno_gimp ,fsno_gper ,& diff --git a/main/URBAN/MOD_Urban_Vars_TimeVariables.F90 b/main/URBAN/MOD_Urban_Vars_TimeVariables.F90 index 445ba46a..b0847909 100644 --- a/main/URBAN/MOD_Urban_Vars_TimeVariables.F90 +++ b/main/URBAN/MOD_Urban_Vars_TimeVariables.F90 @@ -66,10 +66,10 @@ MODULE MOD_Urban_Vars_TimeVariables REAL(r8), allocatable :: sag_gper (:) !pervious ground snow age [-] REAL(r8), allocatable :: sag_lake (:) !urban lake snow age [-] - REAL(r8), allocatable :: scv_roof (:) !roof snow cover [-] - REAL(r8), allocatable :: scv_gimp (:) !impervious ground snow cover [-] - REAL(r8), allocatable :: scv_gper (:) !pervious ground snow cover [-] - REAL(r8), allocatable :: scv_lake (:) !urban lake snow cover [-] + REAL(r8), allocatable :: scv_roof (:) !roof snow mass [kg/m2] + REAL(r8), allocatable :: scv_gimp (:) !impervious ground snow mass [kg/m2] + REAL(r8), allocatable :: scv_gper (:) !pervious ground snow mass [kg/m2] + REAL(r8), allocatable :: scv_lake (:) !urban lake snow mass [kg/m2] REAL(r8), allocatable :: fsno_roof (:) !roof snow fraction [-] REAL(r8), allocatable :: fsno_gimp (:) !impervious ground snow fraction [-] @@ -233,6 +233,7 @@ SUBROUTINE READ_UrbanTimeVariables (file_restart) call ncio_read_vector (file_restart, 'lwsha', landurban, lwsha) ! call ncio_read_vector (file_restart, 'lgimp', landurban, lgimp) ! call ncio_read_vector (file_restart, 'lgper', landurban, lgper) ! + call ncio_read_vector (file_restart, 'lveg' , landurban, lveg ) ! call ncio_read_vector (file_restart, 'z_sno_roof' , -maxsnl, landurban, z_sno_roof ) ! call ncio_read_vector (file_restart, 'z_sno_gimp' , -maxsnl, landurban, z_sno_gimp ) ! @@ -267,6 +268,7 @@ SUBROUTINE READ_UrbanTimeVariables (file_restart) call ncio_read_vector (file_restart, 'sag_roof' , landurban, sag_roof ) ! call ncio_read_vector (file_restart, 'sag_gimp' , landurban, sag_gimp ) ! call ncio_read_vector (file_restart, 'sag_gper' , landurban, sag_gper ) ! + call ncio_read_vector (file_restart, 'sag_lake' , landurban, sag_lake ) ! call ncio_read_vector (file_restart, 'scv_roof' , landurban, scv_roof ) ! call ncio_read_vector (file_restart, 'scv_gimp' , landurban, scv_gimp ) ! call ncio_read_vector (file_restart, 'scv_gper' , landurban, scv_gper ) ! @@ -339,6 +341,7 @@ SUBROUTINE WRITE_UrbanTimeVariables (file_restart) call ncio_write_vector (file_restart, 'lwsha', 'urban', landurban, lwsha, compress) ! call ncio_write_vector (file_restart, 'lgimp', 'urban', landurban, lgimp, compress) ! call ncio_write_vector (file_restart, 'lgper', 'urban', landurban, lgper, compress) ! + call ncio_write_vector (file_restart, 'lveg' , 'urban', landurban, lveg , compress) ! call ncio_write_vector (file_restart, 'z_sno_roof' , 'snow', -maxsnl, 'urban', landurban, z_sno_roof , compress) ! call ncio_write_vector (file_restart, 'z_sno_gimp' , 'snow', -maxsnl, 'urban', landurban, z_sno_gimp , compress) ! @@ -373,6 +376,7 @@ SUBROUTINE WRITE_UrbanTimeVariables (file_restart) call ncio_write_vector (file_restart, 'sag_roof' , 'urban', landurban, sag_roof , compress) ! call ncio_write_vector (file_restart, 'sag_gimp' , 'urban', landurban, sag_gimp , compress) ! call ncio_write_vector (file_restart, 'sag_gper' , 'urban', landurban, sag_gper , compress) ! + call ncio_write_vector (file_restart, 'sag_lake' , 'urban', landurban, sag_lake , compress) ! call ncio_write_vector (file_restart, 'scv_roof' , 'urban', landurban, scv_roof , compress) ! call ncio_write_vector (file_restart, 'scv_gimp' , 'urban', landurban, scv_gimp , compress) ! call ncio_write_vector (file_restart, 'scv_gper' , 'urban', landurban, scv_gper , compress) ! diff --git a/main/URBAN/Urban_CoLMMAIN.F90 b/main/URBAN/Urban_CoLMMAIN.F90 index 3231dad0..360d42b7 100644 --- a/main/URBAN/Urban_CoLMMAIN.F90 +++ b/main/URBAN/Urban_CoLMMAIN.F90 @@ -35,8 +35,9 @@ SUBROUTINE UrbanCoLMMAIN ( & htop ,hbot ,sqrtdi ,chil ,& effcon ,vmax25 ,slti ,hlti ,& shti ,hhti ,trda ,trdm ,& - trop ,gradm ,binter ,extkn ,& - rho ,tau ,rootfr ,& + trop ,g1 ,g0 ,gradm ,& + binter ,extkn ,rho ,tau ,& + rootfr ,& ! atmospheric forcing forc_pco2m ,forc_po2m ,forc_us ,forc_vs ,& @@ -86,7 +87,7 @@ SUBROUTINE UrbanCoLMMAIN ( & flddepth, fldfrc, fevpg_fld, qinfl_fld, & #endif ! additional diagnostic variables for output - laisun ,laisha ,& + laisun ,laisha ,rss ,& rstfac ,h2osoi ,wat ,& ! FLUXES @@ -146,7 +147,7 @@ SUBROUTINE UrbanCoLMMAIN ( & ipatch ,&! maximum number of snow layers idate(3) ,&! next time-step /year/julian day/second in a day/ patchclass ,&! land cover type of USGS classification or others - patchtype ! land water type (0=soil, 1=urban and built-up, + patchtype ! land patch type (0=soil, 1=urban and built-up, ! 2=wetland, 3=land ice, 4=land water bodies, 99 = ocean) REAL(r8),intent(in) :: & @@ -233,6 +234,8 @@ SUBROUTINE UrbanCoLMMAIN ( & trda ,&! temperature coefficient in gs-a model [s5] trdm ,&! temperature coefficient in gs-a model [s6] trop ,&! temperature coefficient in gs-a model + g1 ,&! conductance-photosynthesis slope parameter for medlyn model + g0 ,&! conductance-photosynthesis intercept for medlyn model gradm ,&! conductance-photosynthesis slope parameter binter ,&! conductance-photosynthesis intercep extkn ,&! coefficient of leaf nitrogen allocation @@ -418,6 +421,7 @@ SUBROUTINE UrbanCoLMMAIN ( & laisun ,&! sunlit leaf area index laisha ,&! shaded leaf area index rstfac ,&! factor of soil water stress + rss ,&! soil surface resistance wat ,&! total water storage h2osoi(nl_soil)! volumetric soil water in layers [m3/m3] @@ -544,10 +548,10 @@ SUBROUTINE UrbanCoLMMAIN ( & qfros_gimp ,&! surface dew added to snow pack (mm h2o /s) [+] qfros_gper ,&! surface dew added to snow pack (mm h2o /s) [+] qfros_lake ,&! surface dew added to snow pack (mm h2o /s) [+] - scvold_roof,&! snow cover for previous time step [mm] - scvold_gimp,&! snow cover for previous time step [mm] - scvold_gper,&! snow cover for previous time step [mm] - scvold_lake,&! snow cover for previous time step [mm] + scvold_roof,&! snow mass on roof for previous time step [kg/m2] + scvold_gimp,&! snow mass on impervious surfaces for previous time step [kg/m2] + scvold_gper,&! snow mass on pervious surfaces for previous time step [kg/m2] + scvold_lake,&! snow mass on lake for previous time step [kg/m2] sm_roof ,&! rate of snowmelt [kg/(m2 s)] sm_gimp ,&! rate of snowmelt [kg/(m2 s)] sm_gper ,&! rate of snowmelt [kg/(m2 s)] @@ -558,6 +562,7 @@ SUBROUTINE UrbanCoLMMAIN ( & totwb_gper ,&! water mass at the begining of time step wt ,&! fraction of vegetation buried (covered) by snow [-] rootr(1:nl_soil),&! root resistance of a layer, all layers add to 1.0 + rootflux(1:nl_soil),&! root resistance of a layer, all layers add to 1.0 zi_wall ( 0:nl_wall) ,&! interface level below a "z" level [m] z_roofsno (maxsnl+1:nl_roof) ,&! layer depth [m] @@ -631,7 +636,7 @@ SUBROUTINE UrbanCoLMMAIN ( & ! and precipitation information (rain/snow fall and precip temperature !====================================================================== - CALL netsolar_urban (ipatch,idate,deltim,patchlonr,& + CALL netsolar_urban (ipatch,idate,patchlonr,deltim,& forc_sols,forc_soll,forc_solsd,forc_solld,lai,sai,rho,tau,& alb(:,:),ssun(:,:),ssha(:,:),sroof(:,:),swsun(:,:),& swsha(:,:),sgimp(:,:),sgper(:,:),slake(:,:),& @@ -694,11 +699,11 @@ SUBROUTINE UrbanCoLMMAIN ( & zi_roofsno(j) = zi_roofsno(j-1) + dz_roofsno(j) ENDDO - totwb_roof = scv_roof + wice_roofsno(1)+wliq_roofsno(1) + totwb_roof = scv_roof + wice_roofsno(1) + wliq_roofsno(1) fioldr(:) = 0.0 IF (snlr < 0) THEN fioldr(snlr+1:0) = wice_roofsno(snlr+1:0) / & - (wliq_roofsno(snlr+1:0)+wice_roofsno(snlr+1:0)) + (wliq_roofsno(snlr+1:0) + wice_roofsno(snlr+1:0)) ENDIF !============================================================ @@ -718,11 +723,11 @@ SUBROUTINE UrbanCoLMMAIN ( & zi_gimpsno(1:nl_soil) = zi_soi(1:nl_soil) - totwb_gimp = scv_gimp + wice_gimpsno(1)+wliq_gimpsno(1) + totwb_gimp = scv_gimp + wice_gimpsno(1) + wliq_gimpsno(1) fioldi(:) = 0.0 IF (snli < 0) THEN fioldi(snli+1:0) = wice_gimpsno(snli+1:0) / & - (wliq_gimpsno(snli+1:0)+wice_gimpsno(snli+1:0)) + (wliq_gimpsno(snli+1:0) + wice_gimpsno(snli+1:0)) ENDIF !============================================================ @@ -742,11 +747,11 @@ SUBROUTINE UrbanCoLMMAIN ( & zi_gpersno(1:nl_soil) = zi_soi(1:nl_soil) - totwb_gper = ldew + scv_gper + sum(wice_gpersno(1:)+wliq_gpersno(1:)) + wa + totwb_gper = ldew + scv_gper + sum(wice_gpersno(1:) + wliq_gpersno(1:)) + wa fioldp(:) = 0.0 IF (snlp < 0) THEN fioldp(snlp+1:0) = wice_gpersno(snlp+1:0) / & - (wliq_gpersno(snlp+1:0)+wice_gpersno(snlp+1:0)) + (wliq_gpersno(snlp+1:0) + wice_gpersno(snlp+1:0)) ENDIF !============================================================ @@ -754,7 +759,7 @@ SUBROUTINE UrbanCoLMMAIN ( & snll = 0 DO j = maxsnl+1, 0 - IF (wliq_lakesno(j)+wice_lakesno(j) > 0.) snll = snll - 1 + IF (wliq_lakesno(j) + wice_lakesno(j) > 0.) snll = snll - 1 ENDDO zi_lakesno(0) = 0. @@ -770,11 +775,11 @@ SUBROUTINE UrbanCoLMMAIN ( & fioldl(:) = 0.0 IF (snll <0 ) THEN fioldl(snll+1:0) = wice_lakesno(snll+1:0) / & - (wliq_lakesno(snll+1:0)+wice_lakesno(snll+1:0)) + (wliq_lakesno(snll+1:0) + wice_lakesno(snll+1:0)) ENDIF !============================================================ - totwb = sum(wice_soisno(1:)+wliq_soisno(1:)) + totwb = sum(wice_soisno(1:) + wliq_soisno(1:)) totwb = totwb + scv + ldew*fveg + wa*(1-froof)*fgper !---------------------------------------------------------------------- @@ -913,7 +918,8 @@ SUBROUTINE UrbanCoLMMAIN ( & dewmx ,sqrtdi ,rootfr(:) ,effcon ,& vmax25 ,slti ,hlti ,shti ,& hhti ,trda ,trdm ,trop ,& - gradm ,binter ,extkn ,& + g1 ,g0 ,gradm ,binter ,& + extkn ,& ! surface status fsno_roof ,fsno_gimp ,fsno_gper ,scv_roof ,& scv_gimp ,scv_gper ,scv_lake ,snowdp_roof ,& @@ -954,10 +960,10 @@ SUBROUTINE UrbanCoLMMAIN ( & hpbl ) !---------------------------------------------------------------------- -! [4] Urban hydrology +! [5] Urban hydrology !---------------------------------------------------------------------- IF (fveg > 0) THEN - ! covert to unit area + ! convert to unit area etrgper = etr/(1-froof)/fgper ELSE etrgper = 0. @@ -973,7 +979,7 @@ SUBROUTINE UrbanCoLMMAIN ( & froof ,fgper ,flake ,bsw ,& porsl ,psi0 ,hksati ,wtfact ,& pondmx ,ssi ,wimp ,smpmin ,& - rootr ,etrgper ,fseng ,fgrnd ,& + rootr,rootflux ,etrgper ,fseng ,fgrnd ,& t_gpersno(lbp:) ,t_lakesno(:) ,t_lake ,dz_lake ,& z_gpersno(lbp:) ,z_lakesno(:) ,zi_gpersno(lbp-1:) ,zi_lakesno(:) ,& dz_roofsno(lbr:) ,dz_gimpsno(lbi:) ,dz_gpersno(lbp:) ,dz_lakesno(:) ,& @@ -1153,9 +1159,9 @@ SUBROUTINE UrbanCoLMMAIN ( & scv = scv_roof*froof + scv_gper*(1-froof)*fgper + scv_gimp*(1-froof)*(1-fgper) !scv = scv*(1-flake) + scv_lake*flake - endwb = sum(wice_soisno(1:)+wliq_soisno(1:)) + endwb = sum(wice_soisno(1:) + wliq_soisno(1:)) endwb = endwb + scv + ldew*fveg + wa*(1-froof)*fgper - errorw = (endwb-totwb) - (forc_prc+forc_prl-fevpa-rnof-errw_rsub)*deltim + errorw = (endwb - totwb) - (forc_prc + forc_prl - fevpa - rnof - errw_rsub)*deltim xerr = errorw/deltim #if(defined CoLMDEBUG) diff --git a/mkinidata/CoLMINI.F90 b/mkinidata/CoLMINI.F90 index 6d7786d8..cc8488f9 100644 --- a/mkinidata/CoLMINI.F90 +++ b/mkinidata/CoLMINI.F90 @@ -31,12 +31,9 @@ PROGRAM CoLMINI USE MOD_Const_LC USE MOD_Const_PFT USE MOD_TimeManager -#ifdef LULC_IGBP_PFT +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) USE MOD_LandPFT #endif -#ifdef LULC_IGBP_PC - USE MOD_LandPC -#endif #ifdef URBAN_MODEL USE MOD_LandUrban #endif @@ -50,6 +47,8 @@ PROGRAM CoLMINI USE MOD_HRUVector #endif USE MOD_Initialize + ! SNICAR + USE MOD_SnowSnicar, only: SnowAge_init, SnowOptics_init implicit none ! ----------------local variables --------------------------------- @@ -92,7 +91,11 @@ PROGRAM CoLMINI #ifdef SinglePoint fsrfdata = trim(dir_landdata) // '/srfdata.nc' +#ifndef URBAN_MODEL CALL read_surface_data_single (fsrfdata, mksrfdata=.false.) +#else + CALL read_urban_surface_data_single (fsrfdata, mksrfdata=.false., mkrun=.true.) +#endif #endif CALL monthday2julian(s_year,s_month,s_day,s_julian) @@ -121,15 +124,11 @@ PROGRAM CoLMINI call pixelset_load_from_file (dir_landdata, 'landpatch', landpatch, numpatch, lc_year) -#ifdef LULC_IGBP_PFT +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) call pixelset_load_from_file (dir_landdata, 'landpft', landpft, numpft, lc_year) CALL map_patch_to_pft #endif -#ifdef LULC_IGBP_PC - call pixelset_load_from_file (dir_landdata, 'landpc', landpc, numpc, lc_year) - CALL map_patch_to_pc -#endif #ifdef URBAN_MODEL CALL pixelset_load_from_file (dir_landdata, 'landurban', landurban, numurban, lc_year) CALL map_patch_to_urban @@ -141,6 +140,10 @@ PROGRAM CoLMINI #endif #endif + ! Read in SNICAR optical and aging parameters + CALL SnowOptics_init( DEF_file_snowoptics ) ! SNICAR optical parameters + CALL SnowAge_init( DEF_file_snowaging ) ! SNICAR aging parameters + CALL initialize (casename, dir_landdata, dir_restart, idate, lc_year, greenwich) #ifdef SinglePoint diff --git a/mkinidata/MOD_HtopReadin.F90 b/mkinidata/MOD_HtopReadin.F90 index 8580dd0f..c355e6c3 100644 --- a/mkinidata/MOD_HtopReadin.F90 +++ b/mkinidata/MOD_HtopReadin.F90 @@ -31,15 +31,10 @@ SUBROUTINE HTOP_readin (dir_landdata, lc_year) USE MOD_Const_PFT USE MOD_Vars_TimeInvariants USE MOD_LandPatch -#ifdef LULC_IGBP_PFT +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) USE MOD_LandPFT USE MOD_Vars_PFTimeInvariants USE MOD_Vars_PFTimeVariables -#endif -#ifdef LULC_IGBP_PC - USE MOD_LandPC - USE MOD_Vars_PCTimeInvariants - USE MOD_Vars_PCTimeVariables #endif USE MOD_NetCDFVector #ifdef SinglePoint @@ -111,7 +106,7 @@ SUBROUTINE HTOP_readin (dir_landdata, lc_year) #endif -#ifdef LULC_IGBP_PFT +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) #ifdef SinglePoint allocate(htoppft(numpft)) htoppft = pack(SITE_htop_pfts, SITE_pctpfts > 0.) @@ -158,42 +153,6 @@ SUBROUTINE HTOP_readin (dir_landdata, lc_year) IF (allocated(htoppft)) deallocate(htoppft) #endif -#ifdef LULC_IGBP_PC -#ifdef SinglePoint - allocate(htoplc(1)) - htoplc(:) = sum(SITE_htop_pfts * SITE_pctpfts) -#else - lndname = trim(landdir)//'/htop_patches.nc' - CALL ncio_read_vector (lndname, 'htop_patches', landpatch, htoplc ) -#endif - - IF (p_is_worker) THEN - do npatch = 1, numpatch - t = patchtype(npatch) - m = patchclass(npatch) - IF (t == 0) THEN - p = patch2pc(npatch) - htop_c(:,p) = htop0_p(:) - hbot_c(:,p) = hbot0_p(:) - - DO n = 1, N_PFT-1 - ! 01/06/2020, yuan: adjust htop reading - IF (n < 9 .and. htoplc(npatch)>2.) THEN - htop_c(n,p) = htoplc(npatch) - ENDIF - ENDDO - htop(npatch) = sum(htop_c(:,p)*pcfrac(:,p)) - hbot(npatch) = sum(hbot_c(:,p)*pcfrac(:,p)) - ELSE - htop(npatch) = htop0(m) - hbot(npatch) = hbot0(m) - ENDIF - end do - ENDIF - - IF (allocated(htoplc)) deallocate(htoplc) -#endif - END SUBROUTINE HTOP_readin END MODULE MOD_HtopReadin diff --git a/mkinidata/MOD_IniTimeVariable.F90 b/mkinidata/MOD_IniTimeVariable.F90 index 8cb0e0ad..728976b5 100644 --- a/mkinidata/MOD_IniTimeVariable.F90 +++ b/mkinidata/MOD_IniTimeVariable.F90 @@ -4,6 +4,9 @@ MODULE MOD_IniTimeVariable !----------------------------------------------------------------------- USE MOD_Precision +#ifdef BGC + use MOD_BGC_CNSummary, only: CNDriverSummarizeStates, CNDriverSummarizeFluxes +#endif IMPLICIT NONE SAVE @@ -29,11 +32,11 @@ SUBROUTINE IniTimeVar(ipatch, patchtype& ,snowdp,fveg,fsno,sigf,green,lai,sai,coszen& ,snw_rds,mss_bcpho,mss_bcphi,mss_ocpho,mss_ocphi& ,mss_dst1,mss_dst2,mss_dst3,mss_dst4& - ,alb,ssun,ssha,ssno,thermk,extkb,extkd& + ,alb,ssun,ssha,ssoi,ssno,ssno_lyr,thermk,extkb,extkd& ,trad,tref,qref,rst,emis,zol,rib& ,ustar,qstar,tstar,fm,fh,fq& #if(defined BGC) - ,totlitc, totsomc, totcwdc, decomp_cpools, decomp_cpools_vr, ctrunc_veg, ctrunc_soil, ctrunc_vr & + ,use_cnini, totlitc, totsomc, totcwdc, decomp_cpools, decomp_cpools_vr, ctrunc_veg, ctrunc_soil, ctrunc_vr & ,totlitn, totsomn, totcwdn, decomp_npools, decomp_npools_vr, ntrunc_veg, ntrunc_soil, ntrunc_vr & ,totvegc, totvegn, totcolc, totcoln, col_endcb, col_begcb, col_endnb, col_begnb & ,col_vegendcb, col_vegbegcb, col_soilendcb, col_soilbegcb & @@ -60,7 +63,7 @@ SUBROUTINE IniTimeVar(ipatch, patchtype& ,diagVX_n_vr_acc , upperVX_n_vr_acc , lowerVX_n_vr_acc & !------------------------------------------------------------ #endif - ,use_soilini, nl_soil_ini, soil_z, soil_t, soil_w, snow_d & + ,use_soilini, nl_soil_ini, soil_z, soil_t, soil_w, use_snowini, snow_d & ,use_wtd, zwtmm, zc_soimm, zi_soimm, vliq_r, nprms, prms) !======================================================================= @@ -71,25 +74,21 @@ SUBROUTINE IniTimeVar(ipatch, patchtype& USE MOD_Precision USE MOD_Utils - USE MOD_Const_Physical, only: tfrz + USE MOD_Const_Physical, only: tfrz, denh2o, denice USE MOD_Vars_TimeVariables, only: tlai, tsai, wdsrf - USE MOD_Const_PFT, only: isevg, woody, leafcn, deadwdcn, slatop + USE MOD_Const_PFT, only: isevg, woody, leafcn, frootcn, livewdcn, deadwdcn, slatop USE MOD_Vars_TimeInvariants, only : ibedrock, dbedrock -#if(defined LULC_IGBP_PFT) +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) USE MOD_LandPFT, only : patch_pft_s, patch_pft_e USE MOD_Vars_PFTimeInvariants USE MOD_Vars_PFTimeVariables -#endif -#if(defined LULC_IGBP_PC) - USE MOD_LandPC - USE MOD_Vars_PCTimeInvariants - USE MOD_Vars_PCTimeVariables #endif USE MOD_Vars_Global USE MOD_Albedo USE MOD_Namelist USE MOD_Hydro_SoilWater USE MOD_SnowFraction + USE MOD_SPMD_Task IMPLICIT NONE @@ -119,12 +118,17 @@ SUBROUTINE IniTimeVar(ipatch, patchtype& z0m ! aerodynamic roughness length [m] LOGICAL, intent(in) :: use_soilini +#ifdef BGC + LOGICAL, intent(in) :: use_cnini +#endif INTEGER, intent(in) :: nl_soil_ini REAL(r8), intent(in) :: &! soil_z(nl_soil_ini), &! soil layer depth for initial (m) soil_t(nl_soil_ini), &! soil temperature from initial file (K) - soil_w(nl_soil_ini), &! soil wetness from initial file (-) - snow_d ! snow depth (m) + soil_w(nl_soil_ini) ! soil wetness from initial file (-) + + LOGICAL, intent(in) :: use_snowini + REAL(r8), intent(in) :: snow_d ! snow depth (m) LOGICAL, intent(in) :: use_wtd REAL(r8), intent(in) :: zwtmm @@ -167,12 +171,16 @@ SUBROUTINE IniTimeVar(ipatch, patchtype& alb (2,2), &! averaged albedo [-] ssun(2,2), &! sunlit canopy absorption for solar radiation ssha(2,2), &! shaded canopy absorption for solar radiation + ssoi(2,2), &! ground soil absorption [-] + ssno(2,2), &! ground snow absorption [-] thermk, &! canopy gap fraction for tir radiation extkb, &! (k, g(mu)/mu) direct solar extinction coefficient extkd, &! diffuse and scattered diffuse PAR extinction coefficient - wa, &! water storage in aquifer [mm] - zwt, &! the depth to water table [m] + wa ! water storage in aquifer [mm] + REAL(r8), intent(inout) :: &! + zwt ! the depth to water table [m] + REAL(r8), intent(out) :: &! snw_rds ( maxsnl+1:0 ), &! effective grain radius (col,lyr) [microns, m-6] mss_bcphi( maxsnl+1:0 ), &! mass concentration of hydrophilic BC (col,lyr) [kg/kg] mss_bcpho( maxsnl+1:0 ), &! mass concentration of hydrophobic BC (col,lyr) [kg/kg] @@ -182,7 +190,7 @@ SUBROUTINE IniTimeVar(ipatch, patchtype& mss_dst2 ( maxsnl+1:0 ), &! mass concentration of dust aerosol species 2 (col,lyr) [kg/kg] mss_dst3 ( maxsnl+1:0 ), &! mass concentration of dust aerosol species 3 (col,lyr) [kg/kg] mss_dst4 ( maxsnl+1:0 ), &! mass concentration of dust aerosol species 4 (col,lyr) [kg/kg] - ssno (2,2,maxsnl+1:1 ), &! snow absorption [-] + ssno_lyr (2,2,maxsnl+1:1 ), &! snow layer absorption [-] ! Additional variables required by reginal model (WRF & RSM) ! --------------------------------------------------------- @@ -317,13 +325,13 @@ SUBROUTINE IniTimeVar(ipatch, patchtype& #endif INTEGER j, snl, m, ivt - REAL(r8) wet(nl_soil), vliq, wt, ssw, oro, rhosno_ini, a + REAL(r8) wet(nl_soil), zi_soi_a(0:nl_soil), psi, vliq, wt, ssw, oro, rhosno_ini, a ! SNICAR REAL(r8) pg_snow ! snowfall onto ground including canopy runoff [kg/(m2 s)] REAL(r8) snofrz (maxsnl+1:0) ! snow freezing rate (col,lyr) [kg m-2 s-1] - INTEGER ps, pe, pc + INTEGER ps, pe !----------------------------------------------------------------------- IF(patchtype <= 5)THEN ! land grid @@ -333,47 +341,134 @@ SUBROUTINE IniTimeVar(ipatch, patchtype& ! snowdp, sag, scv, fsno, snl, z_soisno, dz_soisno IF (use_soilini) THEN + zi_soi_a(:) = (/0., zi_soi/) + DO j = 1, nl_soil CALL polint(soil_z,soil_t,nl_soil_ini,z_soisno(j),t_soisno(j)) - CALL polint(soil_z,soil_w,nl_soil_ini,z_soisno(j),wet(j)) - a = min(soil_t(1),soil_t(2),soil_t(3))-5. - t_soisno(j) = max(t_soisno(j), a) - a = max(soil_t(1),soil_t(2),soil_t(3))+5. - t_soisno(j) = min(t_soisno(j), a) + ENDDO - a = min(soil_w(1),soil_w(2),soil_w(3)) - wet(j) = max(wet(j), a, 0.1) - a = max(soil_w(1),soil_w(2),soil_w(3)) - wet(j) = min(wet(j), a, 0.5) + IF (patchtype <= 1) THEN ! soil or urban - wet(j) = min(wet(j), porsl(j)) + DO j = 1, nl_soil - IF(t_soisno(j).ge.tfrz)THEN - wliq_soisno(j) = wet(j)*dz_soisno(j)*1000. - wice_soisno(j) = 0. + CALL polint(soil_z,soil_w,nl_soil_ini,z_soisno(j),wet(j)) + + wet(j) = min(max(wet(j),0.), porsl(j)) + + IF (zwt <= zi_soi_a(j-1)) THEN + wet(j) = porsl(j) + ELSEIF (zwt < zi_soi_a(j)) THEN + wet(j) = ((zi_soi_a(j)-zwt)*porsl(j) + (zwt-zi_soi_a(j-1))*wet(j)) & + / (zi_soi_a(j)-zi_soi_a(j-1)) + ENDIF + + IF(t_soisno(j).ge.tfrz)THEN + wliq_soisno(j) = wet(j)*dz_soisno(j)*denh2o + wice_soisno(j) = 0. + ELSE + wliq_soisno(j) = 0. + wice_soisno(j) = wet(j)*dz_soisno(j)*denice + ENDIF + ENDDO + + ! get wa from zwt + IF (zwt > zi_soi_a(nl_soil)) THEN + psi = psi0(nl_soil) - (zwt*1000. - zi_soi_a(nl_soil)*1000.) * 0.5 + vliq = soil_vliq_from_psi (psi, porsl(nl_soil), vliq_r(nl_soil), psi0(nl_soil), & + nprms, prms(:,nl_soil)) + wa = -(zwt*1000. - zi_soi_a(nl_soil)*1000.)*(porsl(nl_soil)-vliq) ELSE + wa = 0. + ENDIF + + ELSEIF ((patchtype == 2) .or. (patchtype == 4)) THEN ! (2) wetland or (4) lake + + DO j = 1, nl_soil + IF(t_soisno(j).ge.tfrz)THEN + wliq_soisno(j) = porsl(j)*dz_soisno(j)*denh2o + wice_soisno(j) = 0. + ELSE + wliq_soisno(j) = 0. + wice_soisno(j) = porsl(j)*dz_soisno(j)*denice + ENDIF + ENDDO + + wa = 0. + + ELSEIF (patchtype == 3) THEN ! land ice + + DO j = 1, nl_soil wliq_soisno(j) = 0. - wice_soisno(j) = wet(j)*dz_soisno(j)*1000. + wice_soisno(j) = dz_soisno(j)*denice + ENDDO + + wa = 0. + + ENDIF + + IF (.not. DEF_USE_VariablySaturatedFlow) THEN + wa = wa + 5000. + ENDIF + + ELSE + + ! soil temperature, water content + DO j = 1, nl_soil + IF(patchtype==3)THEN !land ice + t_soisno(j) = 253. + wliq_soisno(j) = 0. + wice_soisno(j) = dz_soisno(j)*denice + ELSE + t_soisno(j) = 283. + wliq_soisno(j) = dz_soisno(j)*porsl(j)*denh2o + wice_soisno(j) = 0. ENDIF ENDDO + ENDIF + + z0m = htop * z0mr +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + IF(patchtype==0)THEN + ps = patch_pft_s(ipatch) + pe = patch_pft_e(ipatch) + IF (ps>0 .and. pe>0) THEN + z0m_p(ps:pe) = htop_p(ps:pe) * z0mr + ENDIF + ENDIF +#endif + + IF (use_snowini) THEN + rhosno_ini = 250. snowdp = snow_d sag = 0. scv = snowdp*rhosno_ini - z0m = htop * z0mr -#ifdef LULC_IGBP_PFT - ps = patch_pft_s(ipatch) - pe = patch_pft_e(ipatch) - z0m_p(ps:pe) = htop_p(ps:pe) * z0mr -#endif - ! 08/02/2019, yuan: NOTE! need to be changed in future - ! for LULC_IGBP_PFT or LULC_IGBP_PC - ! have done but not for SOILINI right now + ! 08/02/2019, yuan: NOTE! need to be changed in future. + ! 12/05/2023, yuan: DONE for snowini, change sai. CALL snowfraction (tlai(ipatch),tsai(ipatch),z0m,zlnd,scv,snowdp,wt,sigf,fsno) CALL snow_ini (patchtype,maxsnl,snowdp,snl,z_soisno,dz_soisno) + lai = tlai(ipatch) + sai = tsai(ipatch) * sigf + + IF (patchtype == 0) THEN +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + ps = patch_pft_s(ipatch) + pe = patch_pft_e(ipatch) + CALL snowfraction_pftwrap (ipatch,zlnd,scv,snowdp,wt,sigf,fsno) + if(DEF_USE_LAIFEEDBACK)then + lai = sum(lai_p(ps:pe)*pftfrac(ps:pe)) + else + lai_p(ps:pe) = tlai_p(ps:pe) + lai = tlai(ipatch) + endif + sai_p(ps:pe) = tsai_p(ps:pe) * sigf_p(ps:pe) + sai = sum(sai_p(ps:pe)*pftfrac(ps:pe)) +#endif + ENDIF + IF(snl.lt.0)THEN DO j = snl+1, 0 t_soisno(j) = min(tfrz-1., t_soisno(1)) @@ -392,30 +487,11 @@ SUBROUTINE IniTimeVar(ipatch, patchtype& ELSE - ! soil temperature, water content - DO j = 1, nl_soil - IF(patchtype==3)THEN !land ice - t_soisno(j) = 253. - wliq_soisno(j) = 0. - wice_soisno(j) = dz_soisno(j)*1000. - ELSE - t_soisno(j) = 283. - wliq_soisno(j) = dz_soisno(j)*porsl(j)*1000. - wice_soisno(j) = 0. - ENDIF - ENDDO - snowdp = 0. sag = 0. scv = 0. fsno = 0. snl = 0 - z0m = htop * z0mr -#ifdef LULC_IGBP_PFT - ps = patch_pft_s(ipatch) - pe = patch_pft_e(ipatch) - z0m_p(ps:pe) = htop_p(ps:pe) * z0mr -#endif ! snow temperature and water content t_soisno (maxsnl+1:0) = -999. @@ -430,19 +506,28 @@ SUBROUTINE IniTimeVar(ipatch, patchtype& ! Variables: wa, zwt IF (.not. use_wtd) THEN - IF (DEF_USE_VARIABLY_SATURATED_FLOW) THEN - wa = 0. - zwt = zi_soimm(nl_soil)/1000. - ELSE - ! water table depth (initially at 1.0 m below the model bottom; wa when zwt - ! is below the model bottom zi(nl_soil) - wa = 4800. !assuming aquifer capacity is 5000 mm - zwt = (25. + z_soisno(nl_soil))+dz_soisno(nl_soil)/2. - wa/1000./0.2 !to result in zwt = zi(nl_soil) + 1.0 m + IF (.not. use_soilini) THEN + IF (DEF_USE_VariablySaturatedFlow) THEN + wa = 0. + zwt = zi_soimm(nl_soil)/1000. + ELSE + ! water table depth (initially at 1.0 m below the model bottom; wa when zwt + ! is below the model bottom zi(nl_soil) + wa = 4800. !assuming aquifer capacity is 5000 mm + zwt = (25. + z_soisno(nl_soil))+dz_soisno(nl_soil)/2. - wa/1000./0.2 !to result in zwt = zi(nl_soil) + 1.0 m + ENDIF ENDIF ELSE - IF (patchtype /= 3) THEN + IF (patchtype <= 1) THEN CALL get_water_equilibrium_state (zwtmm, nl_soil, wliq_soisno(1:nl_soil), smp, hk, wa, & zc_soimm, zi_soimm, porsl, vliq_r, psi0, hksati, nprms, prms) + ELSE + wa = 0. + zwt = 0. + ENDIF + + IF (.not. DEF_USE_VariablySaturatedFlow) THEN + wa = wa + 5000. ENDIF ENDIF @@ -472,13 +557,13 @@ SUBROUTINE IniTimeVar(ipatch, patchtype& END IF IF (patchtype == 0) THEN -#ifdef LULC_IGBP_PFT +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) ps = patch_pft_s(ipatch) pe = patch_pft_e(ipatch) ldew_rain_p(ps:pe) = 0. ldew_snow_p(ps:pe) = 0. ldew_p(ps:pe) = 0. - tleaf_p(ps:pe) = t_soisno(1) + tleaf_p(ps:pe)= t_soisno(1) tref_p(ps:pe) = t_soisno(1) qref_p(ps:pe) = 0.3 IF(DEF_USE_PLANTHYDRAULICS)THEN @@ -487,19 +572,6 @@ SUBROUTINE IniTimeVar(ipatch, patchtype& gs0sha_p(ps:pe) = 1.0e4 END IF #endif - -#ifdef LULC_IGBP_PC - pc = patch2pc(ipatch) - ldew_rain_c(:,pc) = 0. - ldew_snow_c(:,pc) = 0. - ldew_c(:,pc) = 0. - tleaf_c(:,pc) = t_soisno(1) - IF(DEF_USE_PLANTHYDRAULICS)THEN - vegwp_c(1:nvegwcs,:,pc) = -2.5e4 - gs0sun_c(:,pc) = 1.0e4 - gs0sha_c(:,pc) = 1.0e4 - END IF -#endif ENDIF ! (5) Ground @@ -509,39 +581,31 @@ SUBROUTINE IniTimeVar(ipatch, patchtype& ! (6) Leaf area ! Variables: sigf, lai, sai - IF (patchtype == 0) THEN -#if(defined LULC_USGS || defined LULC_IGBP) - sigf = fveg - lai = tlai(ipatch) - sai = tsai(ipatch) * sigf -#endif - -#ifdef LULC_IGBP_PFT - ps = patch_pft_s(ipatch) - pe = patch_pft_e(ipatch) - sigf_p (ps:pe) = 1. - lai_p(ps:pe) = tlai_p(ps:pe) - sai_p(ps:pe) = tsai_p(ps:pe) * sigf_p(ps:pe) - sigf = 1. - lai = tlai(ipatch) - sai = sum(sai_p(ps:pe) * pftfrac(ps:pe)) + IF (.not. use_snowini) THEN + IF (patchtype == 0) THEN +#if (defined LULC_USGS || defined LULC_IGBP) + sigf = fveg + lai = tlai(ipatch) + sai = tsai(ipatch) * sigf #endif -#ifdef LULC_IGBP_PC - pc = patch2pc(ipatch) - sigf_c(:,pc) = 1. - lai_c(:,pc) = tlai_c(:,pc) - sai_c(:,pc) = tsai_c(:,pc) * sigf_c(:,pc) +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + ps = patch_pft_s(ipatch) + pe = patch_pft_e(ipatch) + sigf_p (ps:pe) = 1. + lai_p(ps:pe) = tlai_p(ps:pe) + sai_p(ps:pe) = tsai_p(ps:pe) * sigf_p(ps:pe) - sigf = 1. - lai = tlai(ipatch) - sai = sum(sai_c(:,pc)*pcfrac(:,pc)) + sigf = 1. + lai = tlai(ipatch) + sai = sum(sai_p(ps:pe) * pftfrac(ps:pe)) #endif - ELSE - sigf = fveg - lai = tlai(ipatch) - sai = tsai(ipatch) * sigf + ELSE + sigf = fveg + lai = tlai(ipatch) + sai = tsai(ipatch) * sigf + ENDIF ENDIF ! (7) SNICAR @@ -579,7 +643,9 @@ SUBROUTINE IniTimeVar(ipatch, patchtype& col_vegbegnb = 0.0 col_soilendnb = 0.0 col_soilbegnb = 0.0 - decomp_cpools_vr (:,:) = 0.0 + if(.not. use_cnini)then + decomp_cpools_vr (:,:) = 0.0 + end if decomp_cpools (:) = 0.0 ctrunc_vr (:) = 0.0 ctrunc_veg = 0.0 @@ -588,14 +654,18 @@ SUBROUTINE IniTimeVar(ipatch, patchtype& altmax_lastyear = 10.0 altmax_lastyear_indx = 10 lag_npp = 0.0 - decomp_npools_vr (:,:) = 0.0 + if(.not. use_cnini)then + decomp_npools_vr (:,:) = 0.0 + end if decomp_npools (:) = 0.0 ntrunc_vr (:) = 0.0 ntrunc_veg = 0.0 ntrunc_soil = 0.0 - smin_no3_vr (:) = 5.0 - smin_nh4_vr (:) = 5.0 - sminn_vr (:) = 10.0 + if(.not. use_cnini)then + smin_no3_vr (:) = 5.0 + smin_nh4_vr (:) = 5.0 + sminn_vr (:) = 10.0 + end if sminn = 0.0 do j = 1, nl_soil sminn = sminn + sminn_vr(j) * dz_soisno(j) @@ -611,6 +681,7 @@ SUBROUTINE IniTimeVar(ipatch, patchtype& tsoi17 = 273.15_r8 rh30 = 0._r8 accumnstep = 0._r8 + !---------------SASU variables----------------------- decomp0_cpools_vr (:,:) = 0.0 I_met_c_vr_acc (:) = 0.0 @@ -634,7 +705,7 @@ SUBROUTINE IniTimeVar(ipatch, patchtype& AKX_soil1_exit_c_vr_acc (:) = 0.0 AKX_soil2_exit_c_vr_acc (:) = 0.0 AKX_soil3_exit_c_vr_acc (:) = 0.0 - + decomp0_npools_vr (:,:) = 0.0 I_met_n_vr_acc (:) = 0.0 I_cel_n_vr_acc (:) = 0.0 @@ -657,18 +728,18 @@ SUBROUTINE IniTimeVar(ipatch, patchtype& AKX_soil1_exit_n_vr_acc (:) = 0.0 AKX_soil2_exit_n_vr_acc (:) = 0.0 AKX_soil3_exit_n_vr_acc (:) = 0.0 - + diagVX_c_vr_acc (:,:) = 0.0 upperVX_c_vr_acc (:,:) = 0.0 lowerVX_c_vr_acc (:,:) = 0.0 diagVX_n_vr_acc (:,:) = 0.0 upperVX_n_vr_acc (:,:) = 0.0 lowerVX_n_vr_acc (:,:) = 0.0 - + !---------------------------------------------------- skip_balance_check = .false. - -#if(defined LULC_IGBP_PFT) + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) IF (patchtype == 0) THEN do m = ps, pe ivt = pftclass(m) @@ -677,49 +748,74 @@ SUBROUTINE IniTimeVar(ipatch, patchtype& leafc_storage_p (m) = 0.0 leafn_p (m) = 0.0 leafn_storage_p (m) = 0.0 + frootc_p (m) = 0.0 + frootc_storage_p (m) = 0.0 + frootn_p (m) = 0.0 + frootn_storage_p (m) = 0.0 else if(isevg(ivt))then - leafc_p (m) = 100.0 + if(.not. use_cnini)then + leafc_p (m) = 100.0 + frootc_p (m) = 0.0 + end if leafc_storage_p (m) = 0.0 + frootc_storage_p (m) = 0.0 else if(ivt >= npcropmin) then leafc_p (m) = 0.0 leafc_storage_p (m) = 0.0 + frootc_p (m) = 0.0 + frootc_storage_p (m) = 0.0 else - leafc_p (m) = 0.0 - leafc_storage_p (m) = 100.0 + if(.not. use_cnini)then + leafc_p (m) = 0.0 + leafc_storage_p (m) = 100.0 + frootc_p (m) = 0.0 + frootc_storage_p (m) = 0.0 + end if end if - leafn_p (m) = leafc_p (m) / leafcn (ivt) - leafn_storage_p (m) = leafc_storage_p(m) / leafcn (ivt) + leafn_p (m) = leafc_p (m) / leafcn (ivt) + leafn_storage_p (m) = leafc_storage_p(m) / leafcn (ivt) + frootn_p (m) = frootc_p (m) / frootcn (ivt) + frootn_storage_p (m) = frootc_storage_p(m) / frootcn (ivt) end if if(woody(ivt) .eq. 1)then - deadstemc_p (m) = 0.1 - deadstemn_p (m) = deadstemc_p (m) / deadwdcn(ivt) + if(.not. use_cnini)then + deadstemc_p (m) = 0.1 + livestemc_p (m) = 0.0 + deadcrootc_p (m) = 0.0 + livecrootc_p (m) = 0.0 + end if + livestemn_p (m) = livestemc_p (m) / livewdcn(ivt) + deadstemn_p (m) = deadstemc_p (m) / deadwdcn(ivt) + livecrootn_p (m) = livecrootc_p (m) / livewdcn(ivt) + deadcrootn_p (m) = deadcrootc_p (m) / deadwdcn(ivt) else - deadstemc_p (m) = 0.0 - deadstemn_p (m) = 0.0 + livestemc_p (m) = 0.0 + deadstemc_p (m) = 0.0 + livestemn_p (m) = 0.0 + deadstemn_p (m) = 0.0 + livecrootc_p (m) = 0.0 + deadcrootc_p (m) = 0.0 + livecrootn_p (m) = 0.0 + deadcrootn_p (m) = 0.0 end if - totcolc = totcolc + (leafc_p(m) + leafc_storage_p(m) + deadstemc_p(m))* pftfrac(m) - totvegc = totvegc + (leafc_p(m) + leafc_storage_p(m) + deadstemc_p(m))* pftfrac(m) - totcoln = totcoln + (leafn_p(m) + leafn_storage_p(m) + deadstemn_p(m))* pftfrac(m) - totvegn = totvegn + (leafn_p(m) + leafn_storage_p(m) + deadstemn_p(m))* pftfrac(m) +! totcolc = totcolc + (leafc_p(m) + leafc_storage_p(m) + deadstemc_p(m))* pftfrac(m) +! totvegc = totvegc + (leafc_p(m) + leafc_storage_p(m) + deadstemc_p(m))* pftfrac(m) +! totcoln = totcoln + (leafn_p(m) + leafn_storage_p(m) + deadstemn_p(m))* pftfrac(m) +! totvegn = totvegn + (leafn_p(m) + leafn_storage_p(m) + deadstemn_p(m))* pftfrac(m) end do IF(DEF_USE_OZONESTRESS)THEN o3uptakesun_p (ps:pe) = 0._r8 o3uptakesha_p (ps:pe) = 0._r8 ENDIF leafc_xfer_p (ps:pe) = 0.0 - frootc_p (ps:pe) = 0.0 - frootc_storage_p (ps:pe) = 0.0 frootc_xfer_p (ps:pe) = 0.0 - livestemc_p (ps:pe) = 0.0 livestemc_storage_p (ps:pe) = 0.0 livestemc_xfer_p (ps:pe) = 0.0 deadstemc_storage_p (ps:pe) = 0.0 deadstemc_xfer_p (ps:pe) = 0.0 - livecrootc_p (ps:pe) = 0.0 livecrootc_storage_p (ps:pe) = 0.0 livecrootc_xfer_p (ps:pe) = 0.0 - deadcrootc_p (ps:pe) = 0.0 deadcrootc_storage_p (ps:pe) = 0.0 deadcrootc_xfer_p (ps:pe) = 0.0 grainc_p (ps:pe) = 0.0 @@ -732,20 +828,16 @@ SUBROUTINE IniTimeVar(ipatch, patchtype& cpool_p (ps:pe) = 0.0 ctrunc_p (ps:pe) = 0.0 cropprod1c_p (ps:pe) = 0.0 - + leafn_xfer_p (ps:pe) = 0.0 - frootn_p (ps:pe) = 0.0 frootn_storage_p (ps:pe) = 0.0 frootn_xfer_p (ps:pe) = 0.0 - livestemn_p (ps:pe) = 0.0 livestemn_storage_p (ps:pe) = 0.0 livestemn_xfer_p (ps:pe) = 0.0 deadstemn_storage_p (ps:pe) = 0.0 deadstemn_xfer_p (ps:pe) = 0.0 - livecrootn_p (ps:pe) = 0.0 livecrootn_storage_p (ps:pe) = 0.0 livecrootn_xfer_p (ps:pe) = 0.0 - deadcrootn_p (ps:pe) = 0.0 deadcrootn_storage_p (ps:pe) = 0.0 deadcrootn_xfer_p (ps:pe) = 0.0 grainn_p (ps:pe) = 0.0 @@ -755,9 +847,9 @@ SUBROUTINE IniTimeVar(ipatch, patchtype& ntrunc_p (ps:pe) = 0.0 cropseedn_deficit_p (ps:pe) = 0.0 retransn_p (ps:pe) = 0.0 - + harvdate_p (ps:pe) = 99999999 - + tempsum_potential_gpp_p (ps:pe) = 0.0 tempmax_retransn_p (ps:pe) = 0.0 tempavg_tref_p (ps:pe) = 0.0 @@ -768,7 +860,7 @@ SUBROUTINE IniTimeVar(ipatch, patchtype& annavg_tref_p (ps:pe) = 280.0 annsum_npp_p (ps:pe) = 0.0 annsum_litfall_p (ps:pe) = 0.0 - + bglfr_p (ps:pe) = 0.0 bgtr_p (ps:pe) = 0.0 lgsf_p (ps:pe) = 0.0 @@ -779,7 +871,7 @@ SUBROUTINE IniTimeVar(ipatch, patchtype& gdd820_p (ps:pe) = 0.0 gdd1020_p (ps:pe) = 0.0 nyrs_crop_active_p (ps:pe) = 0 - + offset_flag_p (ps:pe) = 0.0 offset_counter_p (ps:pe) = 0.0 onset_flag_p (ps:pe) = 0.0 @@ -794,10 +886,10 @@ SUBROUTINE IniTimeVar(ipatch, patchtype& prev_leafc_to_litter_p (ps:pe) = 0.0 prev_frootc_to_litter_p (ps:pe) = 0.0 days_active_p (ps:pe) = 0.0 - + burndate_p (ps:pe) = 10000 grain_flag_p (ps:pe) = 0.0 - + #ifdef CROP ! crop variables croplive_p (ps:pe) = .false. @@ -811,7 +903,7 @@ SUBROUTINE IniTimeVar(ipatch, patchtype& astemi_p (ps:pe) = spval aleafi_p (ps:pe) = spval gddmaturity_p (ps:pe) = spval - + cropplant_p (ps:pe) = .false. idop_p (ps:pe) = 99999999 cumvd_p (ps:pe) = spval @@ -823,15 +915,20 @@ SUBROUTINE IniTimeVar(ipatch, patchtype& tref_min_inst_p (ps:pe) = spval tref_max_inst_p (ps:pe) = spval latbaset_p (ps:pe) = spval + fert_p (ps:pe) = 0._r8 #endif - + if(DEF_USE_LAIFEEDBACK)then tlai_p (ps:pe) = slatop(pftclass(ps:pe)) * leafc_p(ps:pe) tlai_p (ps:pe) = max(0._r8, tlai_p(ps:pe)) lai_p (ps:pe) = tlai_p(ps:pe) lai = sum(lai_p(ps:pe) * pftfrac(ps:pe)) end if - + +#ifdef BGC + call CNDriverSummarizeStates(ipatch,ps,pe,nl_soil,dz_soi,ndecomp_pools,.true.) +#endif + ! SASU varaibles leafc0_p (ps:pe) = 0.0 leafc0_storage_p (ps:pe) = 0.0 @@ -854,7 +951,7 @@ SUBROUTINE IniTimeVar(ipatch, patchtype& grainc0_p (ps:pe) = 0.0 grainc0_storage_p (ps:pe) = 0.0 grainc0_xfer_p (ps:pe) = 0.0 - + leafn0_p (ps:pe) = 0.0 leafn0_storage_p (ps:pe) = 0.0 leafn0_xfer_p (ps:pe) = 0.0 @@ -877,7 +974,7 @@ SUBROUTINE IniTimeVar(ipatch, patchtype& grainn0_storage_p (ps:pe) = 0.0 grainn0_xfer_p (ps:pe) = 0.0 retransn0_p (ps:pe) = 0.0 - + I_leafc_p_acc (ps:pe) = 0._r8 I_leafc_st_p_acc (ps:pe) = 0._r8 I_frootc_p_acc (ps:pe) = 0._r8 @@ -906,7 +1003,7 @@ SUBROUTINE IniTimeVar(ipatch, patchtype& I_deadcrootn_st_p_acc (ps:pe) = 0._r8 I_grainn_p_acc (ps:pe) = 0._r8 I_grainn_st_p_acc (ps:pe) = 0._r8 - + AKX_leafc_xf_to_leafc_p_acc (ps:pe) = 0._r8 AKX_frootc_xf_to_frootc_p_acc (ps:pe) = 0._r8 AKX_livestemc_xf_to_livestemc_p_acc (ps:pe) = 0._r8 @@ -916,7 +1013,7 @@ SUBROUTINE IniTimeVar(ipatch, patchtype& AKX_grainc_xf_to_grainc_p_acc (ps:pe) = 0._r8 AKX_livestemc_to_deadstemc_p_acc (ps:pe) = 0._r8 AKX_livecrootc_to_deadcrootc_p_acc (ps:pe) = 0._r8 - + AKX_leafc_st_to_leafc_xf_p_acc (ps:pe) = 0._r8 AKX_frootc_st_to_frootc_xf_p_acc (ps:pe) = 0._r8 AKX_livestemc_st_to_livestemc_xf_p_acc (ps:pe) = 0._r8 @@ -924,7 +1021,7 @@ SUBROUTINE IniTimeVar(ipatch, patchtype& AKX_livecrootc_st_to_livecrootc_xf_p_acc (ps:pe) = 0._r8 AKX_deadcrootc_st_to_deadcrootc_xf_p_acc (ps:pe) = 0._r8 AKX_grainc_st_to_grainc_xf_p_acc (ps:pe) = 0._r8 - + AKX_leafc_exit_p_acc (ps:pe) = 0._r8 AKX_frootc_exit_p_acc (ps:pe) = 0._r8 AKX_livestemc_exit_p_acc (ps:pe) = 0._r8 @@ -932,7 +1029,7 @@ SUBROUTINE IniTimeVar(ipatch, patchtype& AKX_livecrootc_exit_p_acc (ps:pe) = 0._r8 AKX_deadcrootc_exit_p_acc (ps:pe) = 0._r8 AKX_grainc_exit_p_acc (ps:pe) = 0._r8 - + AKX_leafc_st_exit_p_acc (ps:pe) = 0._r8 AKX_frootc_st_exit_p_acc (ps:pe) = 0._r8 AKX_livestemc_st_exit_p_acc (ps:pe) = 0._r8 @@ -940,7 +1037,7 @@ SUBROUTINE IniTimeVar(ipatch, patchtype& AKX_livecrootc_st_exit_p_acc (ps:pe) = 0._r8 AKX_deadcrootc_st_exit_p_acc (ps:pe) = 0._r8 AKX_grainc_st_exit_p_acc (ps:pe) = 0._r8 - + AKX_leafc_xf_exit_p_acc (ps:pe) = 0._r8 AKX_frootc_xf_exit_p_acc (ps:pe) = 0._r8 AKX_livestemc_xf_exit_p_acc (ps:pe) = 0._r8 @@ -948,7 +1045,7 @@ SUBROUTINE IniTimeVar(ipatch, patchtype& AKX_livecrootc_xf_exit_p_acc (ps:pe) = 0._r8 AKX_deadcrootc_xf_exit_p_acc (ps:pe) = 0._r8 AKX_grainc_xf_exit_p_acc (ps:pe) = 0._r8 - + AKX_leafn_xf_to_leafn_p_acc (ps:pe) = 0._r8 AKX_frootn_xf_to_frootn_p_acc (ps:pe) = 0._r8 AKX_livestemn_xf_to_livestemn_p_acc (ps:pe) = 0._r8 @@ -958,7 +1055,7 @@ SUBROUTINE IniTimeVar(ipatch, patchtype& AKX_grainn_xf_to_grainn_p_acc (ps:pe) = 0._r8 AKX_livestemn_to_deadstemn_p_acc (ps:pe) = 0._r8 AKX_livecrootn_to_deadcrootn_p_acc (ps:pe) = 0._r8 - + AKX_leafn_st_to_leafn_xf_p_acc (ps:pe) = 0._r8 AKX_frootn_st_to_frootn_xf_p_acc (ps:pe) = 0._r8 AKX_livestemn_st_to_livestemn_xf_p_acc (ps:pe) = 0._r8 @@ -966,12 +1063,12 @@ SUBROUTINE IniTimeVar(ipatch, patchtype& AKX_livecrootn_st_to_livecrootn_xf_p_acc (ps:pe) = 0._r8 AKX_deadcrootn_st_to_deadcrootn_xf_p_acc (ps:pe) = 0._r8 AKX_grainn_st_to_grainn_xf_p_acc (ps:pe) = 0._r8 - + AKX_leafn_to_retransn_p_acc (ps:pe) = 0._r8 AKX_frootn_to_retransn_p_acc (ps:pe) = 0._r8 AKX_livestemn_to_retransn_p_acc (ps:pe) = 0._r8 AKX_livecrootn_to_retransn_p_acc (ps:pe) = 0._r8 - + AKX_retransn_to_leafn_p_acc (ps:pe) = 0._r8 AKX_retransn_to_frootn_p_acc (ps:pe) = 0._r8 AKX_retransn_to_livestemn_p_acc (ps:pe) = 0._r8 @@ -979,7 +1076,7 @@ SUBROUTINE IniTimeVar(ipatch, patchtype& AKX_retransn_to_livecrootn_p_acc (ps:pe) = 0._r8 AKX_retransn_to_deadcrootn_p_acc (ps:pe) = 0._r8 AKX_retransn_to_grainn_p_acc (ps:pe) = 0._r8 - + AKX_retransn_to_leafn_st_p_acc (ps:pe) = 0._r8 AKX_retransn_to_frootn_st_p_acc (ps:pe) = 0._r8 AKX_retransn_to_livestemn_st_p_acc (ps:pe) = 0._r8 @@ -987,7 +1084,7 @@ SUBROUTINE IniTimeVar(ipatch, patchtype& AKX_retransn_to_livecrootn_st_p_acc (ps:pe) = 0._r8 AKX_retransn_to_deadcrootn_st_p_acc (ps:pe) = 0._r8 AKX_retransn_to_grainn_st_p_acc (ps:pe) = 0._r8 - + AKX_leafn_exit_p_acc (ps:pe) = 0._r8 AKX_frootn_exit_p_acc (ps:pe) = 0._r8 AKX_livestemn_exit_p_acc (ps:pe) = 0._r8 @@ -996,7 +1093,7 @@ SUBROUTINE IniTimeVar(ipatch, patchtype& AKX_deadcrootn_exit_p_acc (ps:pe) = 0._r8 AKX_grainn_exit_p_acc (ps:pe) = 0._r8 AKX_retransn_exit_p_acc (ps:pe) = 0._r8 - + AKX_leafn_st_exit_p_acc (ps:pe) = 0._r8 AKX_frootn_st_exit_p_acc (ps:pe) = 0._r8 AKX_livestemn_st_exit_p_acc (ps:pe) = 0._r8 @@ -1004,7 +1101,7 @@ SUBROUTINE IniTimeVar(ipatch, patchtype& AKX_livecrootn_st_exit_p_acc (ps:pe) = 0._r8 AKX_deadcrootn_st_exit_p_acc (ps:pe) = 0._r8 AKX_grainn_st_exit_p_acc (ps:pe) = 0._r8 - + AKX_leafn_xf_exit_p_acc (ps:pe) = 0._r8 AKX_frootn_xf_exit_p_acc (ps:pe) = 0._r8 AKX_livestemn_xf_exit_p_acc (ps:pe) = 0._r8 @@ -1012,7 +1109,7 @@ SUBROUTINE IniTimeVar(ipatch, patchtype& AKX_livecrootn_xf_exit_p_acc (ps:pe) = 0._r8 AKX_deadcrootn_xf_exit_p_acc (ps:pe) = 0._r8 AKX_grainn_xf_exit_p_acc (ps:pe) = 0._r8 - + end if #endif #endif @@ -1029,7 +1126,7 @@ SUBROUTINE IniTimeVar(ipatch, patchtype& snl,wliq_soisno,wice_soisno,snw_rds,snofrz,& mss_bcpho,mss_bcphi,mss_ocpho,mss_ocphi,& mss_dst1,mss_dst2,mss_dst3,mss_dst4,& - alb,ssun,ssha,ssno,thermk,extkb,extkd) + alb,ssun,ssha,ssoi,ssno,ssno_lyr,thermk,extkb,extkd) ELSE !ocean grid t_soisno(:) = 300. wice_soisno(:) = 0. @@ -1056,7 +1153,9 @@ SUBROUTINE IniTimeVar(ipatch, patchtype& CALL albocean (oro,scv,coszen,alb) ssun(:,:) = 0.0 ssha(:,:) = 0.0 - ssno(:,:,:) = 0.0 + ssoi(:,:) = 0.0 + ssno(:,:) = 0.0 + ssno_lyr(:,:,:) = 0.0 thermk = 0.0 extkb = 0.0 extkd = 0.0 diff --git a/mkinidata/MOD_Initialize.F90 b/mkinidata/MOD_Initialize.F90 index dc55aec4..a7948c2f 100644 --- a/mkinidata/MOD_Initialize.F90 +++ b/mkinidata/MOD_Initialize.F90 @@ -44,15 +44,10 @@ SUBROUTINE initialize (casename, dir_landdata, dir_restart, & use MOD_Const_Physical use MOD_Vars_TimeInvariants use MOD_Vars_TimeVariables -#ifdef LULC_IGBP_PFT +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) USE MOD_LandPFT USE MOD_Vars_PFTimeInvariants USE MOD_Vars_PFTimeVariables -#endif -#ifdef LULC_IGBP_PC - USE MOD_LandPC - USE MOD_Vars_PCTimeInvariants - USE MOD_Vars_PCTimeVariables #endif USE MOD_Const_LC USE MOD_Const_PFT @@ -69,10 +64,14 @@ SUBROUTINE initialize (casename, dir_landdata, dir_restart, & USE MOD_Hydro_SoilFunction #endif USE MOD_Mapping_Grid2Pset -#ifdef LATERAL_FLOW +#ifdef CatchLateralFlow USE MOD_Mesh USE MOD_LandHRU USE MOD_LandPatch + USE MOD_ElmVector + USE MOD_HRUVector + USE MOD_Catch_HillslopeNetwork + USE MOD_Catch_RiverLakeNetwork #endif #ifdef CROP USE MOD_CropReadin @@ -103,23 +102,85 @@ SUBROUTINE initialize (casename, dir_landdata, dir_restart, & ! for SOIL INIT of water, temperature, snow depth LOGICAL :: use_soilini + LOGICAL :: use_cnini + LOGICAL :: use_snowini character(len=256) :: fsoildat + character(len=256) :: fsnowdat + character(len=256) :: fcndat type(grid_type) :: gsoil + type(grid_type) :: gsnow + type(grid_type) :: gcn type(mapping_grid2pset_type) :: ms2p + type(mapping_grid2pset_type) :: mc2p + type(mapping_grid2pset_type) :: mc2f + type(mapping_grid2pset_type) :: msoil2p, msnow2p - integer :: nl_soil_ini + integer :: nl_soil_ini + real(r8) :: missing_value real(r8), allocatable :: soil_z(:) type(block_data_real8_2d) :: snow_d_grid type(block_data_real8_3d) :: soil_t_grid type(block_data_real8_3d) :: soil_w_grid + type(block_data_real8_2d) :: zwt_grid + + type(block_data_real8_3d) :: litr1c_grid + type(block_data_real8_3d) :: litr2c_grid + type(block_data_real8_3d) :: litr3c_grid + type(block_data_real8_3d) :: cwdc_grid + type(block_data_real8_3d) :: soil1c_grid + type(block_data_real8_3d) :: soil2c_grid + type(block_data_real8_3d) :: soil3c_grid + type(block_data_real8_3d) :: litr1n_grid + type(block_data_real8_3d) :: litr2n_grid + type(block_data_real8_3d) :: litr3n_grid + type(block_data_real8_3d) :: cwdn_grid + type(block_data_real8_3d) :: soil1n_grid + type(block_data_real8_3d) :: soil2n_grid + type(block_data_real8_3d) :: soil3n_grid + type(block_data_real8_3d) :: sminn_grid + type(block_data_real8_3d) :: smin_nh4_grid + type(block_data_real8_3d) :: smin_no3_grid + type(block_data_real8_2d) :: leafc_grid + type(block_data_real8_2d) :: leafc_storage_grid + type(block_data_real8_2d) :: frootc_grid + type(block_data_real8_2d) :: frootc_storage_grid + type(block_data_real8_2d) :: livestemc_grid + type(block_data_real8_2d) :: deadstemc_grid + type(block_data_real8_2d) :: livecrootc_grid + type(block_data_real8_2d) :: deadcrootc_grid real(r8), allocatable :: snow_d(:) real(r8), allocatable :: soil_t(:,:) real(r8), allocatable :: soil_w(:,:) - + logical , allocatable :: validval(:) + + real(r8), allocatable :: litr1c_vr(:,:) + real(r8), allocatable :: litr2c_vr(:,:) + real(r8), allocatable :: litr3c_vr(:,:) + real(r8), allocatable :: cwdc_vr (:,:) + real(r8), allocatable :: soil1c_vr(:,:) + real(r8), allocatable :: soil2c_vr(:,:) + real(r8), allocatable :: soil3c_vr(:,:) + real(r8), allocatable :: litr1n_vr(:,:) + real(r8), allocatable :: litr2n_vr(:,:) + real(r8), allocatable :: litr3n_vr(:,:) + real(r8), allocatable :: cwdn_vr (:,:) + real(r8), allocatable :: soil1n_vr(:,:) + real(r8), allocatable :: soil2n_vr(:,:) + real(r8), allocatable :: soil3n_vr(:,:) + real(r8), allocatable :: min_nh4_vr(:,:) + real(r8), allocatable :: min_no3_vr(:,:) + real(r8), allocatable :: leafcin_p(:) + real(r8), allocatable :: leafc_storagein_p(:) + real(r8), allocatable :: frootcin_p(:) + real(r8), allocatable :: frootc_storagein_p(:) + real(r8), allocatable :: livestemcin_p(:) + real(r8), allocatable :: deadstemcin_p(:) + real(r8), allocatable :: livecrootcin_p(:) + real(r8), allocatable :: deadcrootcin_p(:) ! for SOIL Water INIT by using water table depth LOGICAL :: use_wtd @@ -148,8 +209,8 @@ SUBROUTINE initialize (casename, dir_landdata, dir_restart, & integer :: year, jday ! Julian day and seconds INTEGER :: month, mday - integer :: i,j,ipatch,nsl,ps,pe,ivt,m, u ! indices - INTEGER :: hs, he + integer :: i,j,ipatch,nsl,hs,he,ps,pe,ivt,m, u ! indices + real(r8) :: totalvolume integer :: Julian_8day integer :: ltyp @@ -178,14 +239,26 @@ SUBROUTINE initialize (casename, dir_landdata, dir_restart, & if (p_is_worker) then patchclass = landpatch%settyp + patchmask = .true. DO ipatch = 1, numpatch - patchtype(ipatch) = patchtypes(patchclass(ipatch)) + + m = patchclass(ipatch) + patchtype(ipatch) = patchtypes(m) + + ! ***** patch mask setting ***** + ! --------------------------------------- + + IF (DEF_URBAN_ONLY .and. m.ne.URBAN) THEN + patchmask(ipatch) = .false. + CYCLE + ENDIF + ENDDO call landpatch%get_lonlat_radian (patchlonr, patchlatr) -#ifdef LULC_IGBP_PFT +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) pftclass = landpft%settyp #endif @@ -205,6 +278,9 @@ SUBROUTINE initialize (casename, dir_landdata, dir_restart, & IF (p_is_worker) THEN IF (numpatch > 0) THEN wdsrf(:) = 0._r8 + + wetwat(:) = 0._r8 + WHERE (patchtype == 2) wetwat = 200._r8 ! for wetland ENDIF ENDIF ! ------------------------------------------ @@ -261,6 +337,7 @@ SUBROUTINE initialize (casename, dir_landdata, dir_restart, & smpmin = -1.e8 !Restriction for min of soil poten. (mm) trsmx0 = 2.e-4 !Max transpiration for moist soil+100% veg. [mm/s] tcrit = 2.5 !critical temp. to determine rain or snow + wetwatmax = 200.0 !maximum wetland water (mm) #ifdef BGC ! bgc constant @@ -377,7 +454,7 @@ SUBROUTINE initialize (casename, dir_landdata, dir_restart, & bt_min = 0.3_r8 bt_max = 0.7_r8 pot_hmn_ign_counts_alpha = 0.0035_r8 - g0 = 0.05_r8 + g0_fire = 0.05_r8 sf = 0.1_r8 sf_no3 = 1._r8 @@ -435,10 +512,10 @@ SUBROUTINE initialize (casename, dir_landdata, dir_restart, & !2.3 READ in or GUSSES land state information ! ........................................... - ! for SOIL INIT of water, temperature, snow depth - IF (DEF_USE_SOIL_INIT) THEN + ! for SOIL INIT of water, temperature + IF (DEF_USE_SoilInit) THEN - fsoildat = DEF_file_soil_init + fsoildat = DEF_file_SoilInit IF (p_is_master) THEN inquire (file=trim(fsoildat), exist=use_soilini) ENDIF @@ -448,35 +525,66 @@ SUBROUTINE initialize (casename, dir_landdata, dir_restart, & IF (use_soilini) THEN - call ncio_read_bcast_serial (fsoildat, 'soil_z', soil_z) + ! soil layer depth (m) + call ncio_read_bcast_serial (fsoildat, 'soildepth', soil_z) + nl_soil_ini = size(soil_z) + + call gsoil%define_from_file (fsoildat, latname = 'lat', lonname = 'lon') + + CALL julian2monthday (idate(1), idate(2), month, mday) + + IF (p_is_master) THEN + CALL ncio_get_attr (fsoildat, 'zwt', 'missing_value', missing_value) + ENDIF +#ifdef USEMPI + CALL mpi_bcast (missing_value, 1, MPI_REAL8, p_root, p_comm_glb, p_err) +#endif if (p_is_io) then ! soil layer temperature (K) - call allocate_block_data (gsoil, soil_t_grid, nl_soil_ini) - call ncio_read_block (fsoildat, 'soil_t', gsoil, nl_soil_ini, soil_t_grid) + call allocate_block_data (gsoil, soil_t_grid, nl_soil_ini) + call ncio_read_block_time (fsoildat, 'soiltemp', & + gsoil, nl_soil_ini, month, soil_t_grid) ! soil layer wetness (-) - call allocate_block_data (gsoil, soil_w_grid, nl_soil_ini) - call ncio_read_block (fsoildat, 'soil_w', gsoil, nl_soil_ini, soil_w_grid) - ! snow depth (m) - call allocate_block_data (gsoil, snow_d_grid) - call ncio_read_block (fsoildat, 'snow_d', gsoil, snow_d_grid) + call allocate_block_data (gsoil, soil_w_grid, nl_soil_ini) + call ncio_read_block_time (fsoildat, 'soilwat', & + gsoil, nl_soil_ini, month, soil_w_grid) + ! water table depth (m) + call allocate_block_data (gsoil, zwt_grid) + call ncio_read_block_time (fsoildat, 'zwt', gsoil, month, zwt_grid) end if - call gsoil%define_from_file (fsoildat) - call ms2p%build (gsoil, landpatch) - if (p_is_worker) then - nl_soil_ini = nl_soil - allocate (soil_z (nl_soil_ini)) - allocate (snow_d (numpatch)) - allocate (soil_t (nl_soil_ini,numpatch)) - allocate (soil_w (nl_soil_ini,numpatch)) + IF (numpatch > 0) THEN + allocate (soil_t (nl_soil_ini,numpatch)) + allocate (soil_w (nl_soil_ini,numpatch)) + allocate (validval (numpatch)) + ENDIF end if - call ms2p%map_aweighted (soil_t_grid, nl_soil_ini, soil_t) - call ms2p%map_aweighted (soil_w_grid, nl_soil_ini, soil_w) - call ms2p%map_aweighted (snow_d_grid, snow_d) + call msoil2p%build (gsoil, landpatch, zwt_grid, missing_value, validval) + call msoil2p%map_aweighted (soil_t_grid, nl_soil_ini, soil_t) + call msoil2p%map_aweighted (soil_w_grid, nl_soil_ini, soil_w) + call msoil2p%map_aweighted (zwt_grid, zwt) + + IF (p_is_worker) THEN + DO i = 1, numpatch + IF (.not. validval(i)) THEN + IF (patchtype(i) == 3) THEN + soil_t(:,i) = 250. + ELSE + soil_t(:,i) = 280. + ENDIF + + soil_w(:,i) = 1. + zwt(i) = 0. + + ENDIF + ENDDO + ENDIF + + IF (allocated(validval)) deallocate(validval) ENDIF @@ -488,21 +596,288 @@ SUBROUTINE initialize (casename, dir_landdata, dir_restart, & !! not used, just for filling arguments if (p_is_worker) then allocate (soil_z (nl_soil)) - allocate (snow_d (numpatch)) allocate (soil_t (nl_soil,numpatch)) allocate (soil_w (nl_soil,numpatch)) end if ENDIF +#ifdef BGC + IF (DEF_USE_CN_INIT) THEN + fcndat = DEF_file_cn_init + IF (p_is_master) THEN + inquire (file=trim(fcndat), exist=use_cnini) + IF (use_cnini) THEN + write(*,'(/, 2A)') 'Use carbon & nitrogen and derived equilibrium state ' & + // ' to initialize soil & vegetation biogeochemistry: ', trim(fcndat) + ELSE + write(*,*) 'no initial data for biogeochemistry: ',trim(fcndat) + ENDIF + ENDIF +#ifdef USEMPI + call mpi_bcast (use_cnini, 1, MPI_LOGICAL, p_root, p_comm_glb, p_err) +#endif + + IF (use_cnini) THEN + + call gcn%define_from_file (fcndat,"lat","lon") + call mc2p%build (gcn, landpatch) + call mc2f%build (gcn, landpft) + + if (p_is_io) then + ! soil layer litter & carbon (gC m-3) + call allocate_block_data (gcn, litr1c_grid, nl_soil) + call ncio_read_block (fcndat, 'litr1c_vr', gcn, nl_soil, litr1c_grid) + + call allocate_block_data (gcn, litr2c_grid, nl_soil) + call ncio_read_block (fcndat, 'litr2c_vr', gcn, nl_soil, litr2c_grid) + + call allocate_block_data (gcn, litr3c_grid, nl_soil) + call ncio_read_block (fcndat, 'litr3c_vr', gcn, nl_soil, litr3c_grid) + + call allocate_block_data (gcn, cwdc_grid, nl_soil) + call ncio_read_block (fcndat, 'cwdc_vr', gcn, nl_soil , cwdc_grid) + + call allocate_block_data (gcn, soil1c_grid, nl_soil) + call ncio_read_block (fcndat, 'soil1c_vr', gcn, nl_soil, soil1c_grid) + + call allocate_block_data (gcn, soil2c_grid, nl_soil) + call ncio_read_block (fcndat, 'soil2c_vr', gcn, nl_soil, soil2c_grid) + + call allocate_block_data (gcn, soil3c_grid, nl_soil) + call ncio_read_block (fcndat, 'soil3c_vr', gcn, nl_soil, soil3c_grid) + + ! soil layer litter & nitrogen (gN m-3) + call allocate_block_data (gcn, litr1n_grid, nl_soil) + call ncio_read_block (fcndat, 'litr1n_vr', gcn, nl_soil, litr1n_grid) + + call allocate_block_data (gcn, litr2n_grid, nl_soil) + call ncio_read_block (fcndat, 'litr2n_vr', gcn, nl_soil, litr2n_grid) + + call allocate_block_data (gcn, litr3n_grid, nl_soil) + call ncio_read_block (fcndat, 'litr3n_vr', gcn, nl_soil, litr3n_grid) + + call allocate_block_data (gcn, cwdn_grid, nl_soil) + call ncio_read_block (fcndat, 'cwdn_vr', gcn, nl_soil , cwdn_grid) + + call allocate_block_data (gcn, soil1n_grid, nl_soil) + call ncio_read_block (fcndat, 'soil1n_vr', gcn, nl_soil, soil1n_grid) + + call allocate_block_data (gcn, soil2n_grid, nl_soil) + call ncio_read_block (fcndat, 'soil2n_vr', gcn, nl_soil, soil2n_grid) + + call allocate_block_data (gcn, soil3n_grid, nl_soil) + call ncio_read_block (fcndat, 'soil3n_vr', gcn, nl_soil, soil3n_grid) + + call allocate_block_data (gcn, soil3n_grid, nl_soil) + call ncio_read_block (fcndat, 'soil3n_vr', gcn, nl_soil, soil3n_grid) + + call allocate_block_data (gcn, smin_nh4_grid, nl_soil) + call ncio_read_block (fcndat, 'smin_nh4_vr', gcn, nl_soil, smin_nh4_grid) + + call allocate_block_data (gcn, smin_no3_grid, nl_soil) + call ncio_read_block (fcndat, 'smin_no3_vr', gcn, nl_soil, smin_no3_grid) + + call allocate_block_data (gcn, leafc_grid) + call ncio_read_block (fcndat, 'leafc', gcn, leafc_grid) + + call allocate_block_data (gcn, leafc_storage_grid) + call ncio_read_block (fcndat, 'leafc_storage', gcn, leafc_storage_grid) + + call allocate_block_data (gcn, frootc_grid) + call ncio_read_block (fcndat, 'frootc', gcn, frootc_grid) + + call allocate_block_data (gcn, frootc_storage_grid) + call ncio_read_block (fcndat, 'frootc_storage', gcn, frootc_storage_grid) + + call allocate_block_data (gcn, livestemc_grid) + call ncio_read_block (fcndat, 'livestemc', gcn, livestemc_grid) + + call allocate_block_data (gcn, deadstemc_grid) + call ncio_read_block (fcndat, 'deadstemc', gcn, deadstemc_grid) + + call allocate_block_data (gcn, livecrootc_grid) + call ncio_read_block (fcndat, 'livecrootc', gcn, livecrootc_grid) + + call allocate_block_data (gcn, deadcrootc_grid) + call ncio_read_block (fcndat, 'deadcrootc', gcn, deadcrootc_grid) + + end if + + if (p_is_worker) then + allocate (litr1c_vr (nl_soil,numpatch)) + allocate (litr2c_vr (nl_soil,numpatch)) + allocate (litr3c_vr (nl_soil,numpatch)) + allocate (cwdc_vr (nl_soil,numpatch)) + allocate (soil1c_vr (nl_soil,numpatch)) + allocate (soil2c_vr (nl_soil,numpatch)) + allocate (soil3c_vr (nl_soil,numpatch)) + allocate (litr1n_vr (nl_soil,numpatch)) + allocate (litr2n_vr (nl_soil,numpatch)) + allocate (litr3n_vr (nl_soil,numpatch)) + allocate (cwdn_vr (nl_soil,numpatch)) + allocate (soil1n_vr (nl_soil,numpatch)) + allocate (soil2n_vr (nl_soil,numpatch)) + allocate (soil3n_vr (nl_soil,numpatch)) + allocate (min_nh4_vr(nl_soil,numpatch)) + allocate (min_no3_vr(nl_soil,numpatch)) + allocate (leafcin_p (numpft)) + allocate (leafc_storagein_p (numpft)) + allocate (frootcin_p (numpft)) + allocate (frootc_storagein_p (numpft)) + allocate (livestemcin_p (numpft)) + allocate (deadstemcin_p (numpft)) + allocate (livecrootcin_p (numpft)) + allocate (deadcrootcin_p (numpft)) + end if + + call mc2p%map_aweighted (litr1c_grid, nl_soil, litr1c_vr) + call mc2p%map_aweighted (litr2c_grid, nl_soil, litr2c_vr) + call mc2p%map_aweighted (litr3c_grid, nl_soil, litr3c_vr) + call mc2p%map_aweighted (cwdc_grid , nl_soil, cwdc_vr ) + call mc2p%map_aweighted (soil1c_grid, nl_soil, soil1c_vr) + call mc2p%map_aweighted (soil2c_grid, nl_soil, soil2c_vr) + call mc2p%map_aweighted (soil3c_grid, nl_soil, soil3c_vr) + call mc2p%map_aweighted (litr1n_grid, nl_soil, litr1n_vr) + call mc2p%map_aweighted (litr2n_grid, nl_soil, litr2n_vr) + call mc2p%map_aweighted (litr3n_grid, nl_soil, litr3n_vr) + call mc2p%map_aweighted (cwdn_grid , nl_soil, cwdn_vr ) + call mc2p%map_aweighted (soil1n_grid, nl_soil, soil1n_vr) + call mc2p%map_aweighted (soil2n_grid, nl_soil, soil2n_vr) + call mc2p%map_aweighted (soil3n_grid, nl_soil, soil3n_vr) + call mc2p%map_aweighted (smin_nh4_grid , nl_soil, min_nh4_vr ) + call mc2p%map_aweighted (smin_no3_grid , nl_soil, min_no3_vr ) + call mc2f%map_aweighted (leafc_grid, leafcin_p ) + call mc2f%map_aweighted (leafc_storage_grid, leafc_storagein_p ) + call mc2f%map_aweighted (frootc_grid, frootcin_p ) + call mc2f%map_aweighted (frootc_storage_grid, frootc_storagein_p ) + call mc2f%map_aweighted (livestemc_grid, livestemcin_p ) + call mc2f%map_aweighted (deadstemc_grid, deadstemcin_p ) + call mc2f%map_aweighted (livecrootc_grid, livecrootcin_p ) + call mc2f%map_aweighted (deadcrootc_grid, deadcrootcin_p ) + + if (p_is_worker) then + do i = 1, numpatch + ps = patch_pft_s(i) + pe = patch_pft_e(i) + do nsl = 1, nl_soil + decomp_cpools_vr(nsl, i_met_lit, i) = litr1c_vr(nsl, i) + decomp_cpools_vr(nsl, i_cel_lit, i) = litr2c_vr(nsl, i) + decomp_cpools_vr(nsl, i_lig_lit, i) = litr3c_vr(nsl, i) + decomp_cpools_vr(nsl, i_cwd , i) = cwdc_vr (nsl, i) + decomp_cpools_vr(nsl, i_soil1 , i) = soil1c_vr(nsl, i) + decomp_cpools_vr(nsl, i_soil2 , i) = soil2c_vr(nsl, i) + decomp_cpools_vr(nsl, i_soil3 , i) = soil3c_vr(nsl, i) + decomp_npools_vr(nsl, i_met_lit, i) = litr1n_vr(nsl, i) + decomp_npools_vr(nsl, i_cel_lit, i) = litr2n_vr(nsl, i) + decomp_npools_vr(nsl, i_lig_lit, i) = litr3n_vr(nsl, i) + decomp_npools_vr(nsl, i_cwd , i) = cwdn_vr (nsl, i) + decomp_npools_vr(nsl, i_soil1 , i) = soil1n_vr(nsl, i) + decomp_npools_vr(nsl, i_soil2 , i) = soil2n_vr(nsl, i) + decomp_npools_vr(nsl, i_soil3 , i) = soil3n_vr(nsl, i) + smin_nh4_vr (nsl, i) = min_nh4_vr(nsl,i) + smin_no3_vr (nsl, i) = min_no3_vr(nsl,i) + sminn_vr (nsl, i) = min_nh4_vr(nsl,i)+min_no3_vr(nsl,i) + end do + if (patchtype(i) == 0)then + do m = ps, pe + ivt = pftclass(m) + if(isevg(ivt))then + leafc_p (m) = leafcin_p(m) + frootc_p (m) = frootcin_p(m) + else + leafc_p (m) = leafcin_p(m) + leafc_storage_p (m) = leafc_storagein_p(m) + frootc_p (m) = frootcin_p(m) + frootc_storage_p (m) = frootc_storagein_p(m) + end if + if(woody(ivt).eq. 1)then + deadstemc_p (m) = deadstemcin_p(m) + livestemc_p (m) = livestemcin_p(m) + deadcrootc_p (m) = deadcrootcin_p(m) + livecrootc_p (m) = livecrootcin_p(m) + end if + end do + end if + end do + end if + + ENDIF + + ELSE + use_cnini = .false. + ENDIF +#endif + + if (p_is_worker) then + IF (numpatch > 0) THEN + allocate (snow_d (numpatch)) + ENDIF + end if + + IF (DEF_USE_SnowInit) THEN + + fsnowdat = DEF_file_SnowInit + IF (p_is_master) THEN + inquire (file=trim(fsnowdat), exist=use_snowini) + ENDIF +#ifdef USEMPI + call mpi_bcast (use_snowini, 1, MPI_LOGICAL, p_root, p_comm_glb, p_err) +#endif + + IF (use_snowini) THEN + + call gsnow%define_from_file (fsnowdat, latname = 'lat', lonname = 'lon') + + CALL julian2monthday (idate(1), idate(2), month, mday) + + IF (p_is_master) THEN + CALL ncio_get_attr (fsnowdat, 'snowdepth', 'missing_value', missing_value) + ENDIF +#ifdef USEMPI + CALL mpi_bcast (missing_value, 1, MPI_REAL8, p_root, p_comm_glb, p_err) +#endif + + if (p_is_io) then + ! snow depth (m) + call allocate_block_data (gsnow, snow_d_grid) + call ncio_read_block_time (fsnowdat, 'snowdepth', gsnow, month, snow_d_grid) + end if + + if (p_is_worker) then + IF (numpatch > 0) THEN + allocate (validval (numpatch)) + ENDIF + end if + + call msnow2p%build (gsnow, landpatch, snow_d_grid, missing_value, validval) + call msnow2p%map_aweighted (snow_d_grid, snow_d) + + IF (p_is_worker) THEN + WHERE (.not. validval) + snow_d = 0. + END WHERE + ENDIF + + IF (allocated(validval)) deallocate(validval) + + ENDIF + + ELSE + use_snowini = .false. + ENDIF + + ! for SOIL Water INIT by using water table depth - fwtd = trim(DEF_dir_runtime) // 'wtd.nc' + fwtd = trim(DEF_dir_runtime) // '/wtd.nc' IF (p_is_master) THEN inquire (file=trim(fwtd), exist=use_wtd) + IF (use_soilini) use_wtd = .false. IF (use_wtd) THEN write(*,'(/, 2A)') 'Use water table depth and derived equilibrium state ' & // ' to initialize soil water content: ', trim(fwtd) ENDIF ENDIF + #ifdef USEMPI call mpi_bcast (use_wtd, 1, MPI_LOGICAL, p_root, p_comm_glb, p_err) #endif @@ -530,10 +905,10 @@ SUBROUTINE initialize (casename, dir_landdata, dir_restart, & if (p_is_worker) then do i = 1, numpatch - IF (DEF_USE_SOILINI) THEN - do nsl = 1, nl_soil - t_soisno(nsl,i) = soil_t(min(nl_soil_ini,nsl),i) - enddo + IF (use_soilini) THEN + DO nsl = 1, nl_soil + CALL polint(soil_z,soil_t(:,i),nl_soil_ini,z_soi(nsl),t_soisno(nsl,i)) + ENDDO ELSE t_soisno(1:,i) = 283. ENDIF @@ -581,7 +956,7 @@ SUBROUTINE initialize (casename, dir_landdata, dir_restart, & CALL CROP_readin () if (p_is_worker) then do i = 1, numpatch - if(patchtype(i) .eq. 0)then + if(patchtype(i) .eq. 0)then ps = patch_pft_s(i) pe = patch_pft_e(i) do m = ps, pe @@ -598,6 +973,13 @@ SUBROUTINE initialize (casename, dir_landdata, dir_restart, & end if end do end if + if(DEF_USE_IRRIGATION)then + irrig_rate(:) = 0._r8 + deficit_irrig(:) = 0._r8 + sum_irrig(:) = 0._r8 + sum_irrig_count(:) = 0._r8 + n_irrig_steps_left(:) = 0 + end if #endif #endif @@ -666,12 +1048,13 @@ SUBROUTINE initialize (casename, dir_landdata, dir_restart, & ,snowdp(i),fveg(i),fsno(i),sigf(i),green(i),lai(i),sai(i),coszen(i)& ,snw_rds(:,i),mss_bcpho(:,i),mss_bcphi(:,i),mss_ocpho(:,i),mss_ocphi(:,i)& ,mss_dst1(:,i),mss_dst2(:,i),mss_dst3(:,i),mss_dst4(:,i)& - ,alb(1:,1:,i),ssun(1:,1:,i),ssha(1:,1:,i),ssno(1:,1:,:,i)& + ,alb(1:,1:,i),ssun(1:,1:,i),ssha(1:,1:,i)& + ,ssoi(1:,1:,i),ssno(1:,1:,i),ssno_lyr(1:,1:,:,i)& ,thermk(i),extkb(i),extkd(i)& ,trad(i),tref(i),qref(i),rst(i),emis(i),zol(i),rib(i)& ,ustar(i),qstar(i),tstar(i),fm(i),fh(i),fq(i)& #ifdef BGC - ,totlitc(i), totsomc(i), totcwdc(i), decomp_cpools(:,i), decomp_cpools_vr(:,:,i) & + ,use_cnini, totlitc(i), totsomc(i), totcwdc(i), decomp_cpools(:,i), decomp_cpools_vr(:,:,i) & ,ctrunc_veg(i), ctrunc_soil(i), ctrunc_vr(:,i) & ,totlitn(i), totsomn(i), totcwdn(i), decomp_npools(:,i), decomp_npools_vr(:,:,i) & ,ntrunc_veg(i), ntrunc_soil(i), ntrunc_vr(:,i) & @@ -682,8 +1065,8 @@ SUBROUTINE initialize (casename, dir_landdata, dir_restart, & ,altmax(i) , altmax_lastyear(i), altmax_lastyear_indx(i), lag_npp(i) & ,sminn_vr(:,i), sminn(i), smin_no3_vr (:,i), smin_nh4_vr (:,i)& ,prec10(i), prec60(i), prec365 (i), prec_today(i), prec_daily(:,i), tsoi17(i), rh30(i), accumnstep(i) , skip_balance_check(i) & - !------------------------SASU variables----------------------- - ,decomp0_cpools_vr (:,:,i), decomp0_npools_vr (:,:,i) & +!------------------------SASU variables----------------------- ,decomp0_cpools_vr (:,:,i), decomp0_npools_vr (:,:,i) & + ,decomp0_cpools_vr (:,:,i), decomp0_npools_vr (:,:,i) & ,I_met_c_vr_acc (:,i), I_cel_c_vr_acc (:,i), I_lig_c_vr_acc (:,i), I_cwd_c_vr_acc (:,i) & ,AKX_met_to_soil1_c_vr_acc (:,i), AKX_cel_to_soil1_c_vr_acc (:,i), AKX_lig_to_soil2_c_vr_acc (:,i), AKX_soil1_to_soil2_c_vr_acc(:,i) & ,AKX_cwd_to_cel_c_vr_acc (:,i), AKX_cwd_to_lig_c_vr_acc (:,i), AKX_soil1_to_soil3_c_vr_acc(:,i), AKX_soil2_to_soil1_c_vr_acc(:,i) & @@ -701,7 +1084,7 @@ SUBROUTINE initialize (casename, dir_landdata, dir_restart, & !------------------------------------------------------------ #endif ! for SOIL INIT of water, temperature, snow depth - ,use_soilini, nl_soil_ini, soil_z, soil_t(1:,i), soil_w(1:,i), snow_d(i) & + ,use_soilini, nl_soil_ini, soil_z, soil_t(1:,i), soil_w(1:,i), use_snowini, snow_d(i) & ! for SOIL Water INIT by using water table depth ,use_wtd, zwtmm, zc_soimm, zi_soimm, vliq_r, nprms, prms) @@ -781,29 +1164,59 @@ SUBROUTINE initialize (casename, dir_landdata, dir_restart, & ! ------------------------------------------ ! ----- -#ifdef LATERAL_FLOW +#ifdef CatchLateralFlow + + CALL hillslope_network_init () + CALL river_lake_network_init () -#if (defined CROP) - IF (p_is_worker) CALL hru_patch%build (landhru, landpatch, use_frac = .true., shadowfrac = pctcrop) -#else - IF (p_is_worker) CALL hru_patch%build (landhru, landpatch, use_frac = .true.) -#endif IF (p_is_worker) THEN - IF (numelm > 0) THEN - wdsrf_bsn(:) = 0 - veloc_riv(:) = 0 + + IF (numpatch > 0) THEN + wdsrf(:) = 0. ENDIF - IF (numhru > 0) THEN - veloc_hru(:) = 0 + DO i = 1, numelm + IF (lake_id(i) > 0) THEN + ps = elm_patch%substt(i) + pe = elm_patch%subend(i) + wdsrf(ps:pe) = lakedepth(ps:pe) * 1.0e3 ! m to mm + ELSE + IF (hillslope_network(i)%indx(1) == 0) THEN + hs = basin_hru%substt(i) + ps = hru_patch%substt(hs) + pe = hru_patch%subend(hs) + wdsrf(ps:pe) = riverdpth(i) * 1.0e3 ! m to mm + ENDIF + ENDIF + ENDDO + IF (numhru > 0) THEN DO i = 1, numhru ps = hru_patch%substt(i) pe = hru_patch%subend(i) wdsrf_hru(i) = sum(wdsrf(ps:pe) * hru_patch%subfrc(ps:pe)) wdsrf_hru(i) = wdsrf_hru(i) / 1.0e3 ! mm to m ENDDO + veloc_hru(:) = 0 + wdsrf_hru_prev(:) = wdsrf_hru(:) + ENDIF + + IF (numelm > 0) THEN + DO i = 1, numelm + hs = basin_hru%substt(i) + he = basin_hru%subend(i) + IF (lake_id(i) <= 0) THEN + wdsrf_bsn(i) = minval(hillslope_network(i)%hand + wdsrf_hru(hs:he)) + ELSE + ! lake + totalvolume = sum(wdsrf_hru(hs:he) * lakes(i)%area0) + wdsrf_bsn(i) = lakes(i)%surface(totalvolume) + ENDIF + ENDDO + veloc_riv(:) = 0 + wdsrf_bsn_prev(:) = wdsrf_bsn(:) ENDIF + ENDIF #endif ! ............................................................... diff --git a/mkinidata/MOD_PercentagesPFTReadin.F90 b/mkinidata/MOD_PercentagesPFTReadin.F90 index 7e08f32e..65945bf5 100644 --- a/mkinidata/MOD_PercentagesPFTReadin.F90 +++ b/mkinidata/MOD_PercentagesPFTReadin.F90 @@ -25,17 +25,16 @@ SUBROUTINE pct_readin (dir_landdata, lc_year) use MOD_SPMD_Task USE MOD_NetCDFVector USE MOD_LandPatch +#ifdef CROP + USE MOD_LandCrop +#endif #ifdef RangeCheck USE MOD_RangeCheck #endif -#ifdef LULC_IGBP_PFT +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) use MOD_LandPFT use MOD_Vars_PFTimeInvariants, only : pftfrac #endif -#ifdef LULC_IGBP_PC - use MOD_LandPC - use MOD_Vars_PCTimeInvariants, only : pcfrac -#endif #ifdef SinglePoint USE MOD_SingleSrfdata #endif @@ -49,7 +48,7 @@ SUBROUTINE pct_readin (dir_landdata, lc_year) INTEGER :: npatch, ipatch write(cyear,'(i4.4)') lc_year -#ifdef LULC_IGBP_PFT +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) #ifndef SinglePoint lndname = trim(dir_landdata)//'/pctpft/'//trim(cyear)//'/pct_pfts.nc' call ncio_read_vector (lndname, 'pct_pfts', landpft, pftfrac) @@ -60,25 +59,25 @@ SUBROUTINE pct_readin (dir_landdata, lc_year) #if (defined CROP) #ifndef SinglePoint lndname = trim(dir_landdata)//'/pctpft/'//trim(cyear)//'/pct_crops.nc' - call ncio_read_vector (lndname, 'pct_crops', landpatch, pctcrop) + call ncio_read_vector (lndname, 'pct_crops', landpatch, pctshrpch) #else - allocate (pctcrop (numpatch)) - IF (SITE_landtype == 12) THEN - pctcrop = pack(SITE_pctcrop, SITE_pctcrop > 0.) + allocate (pctshrpch (numpatch)) + IF (SITE_landtype == CROPLAND) THEN + pctshrpch = pack(SITE_pctcrop, SITE_pctcrop > 0.) ELSE - pctcrop = 0. + pctshrpch = 0. ENDIF #endif #endif #ifdef RangeCheck IF (p_is_worker) THEN - npatch = count(landpatch%settyp == 1) + npatch = count(patchtypes(landpatch%settyp) == 0) allocate (sumpct (npatch)) npatch = 0 DO ipatch = 1, numpatch - IF (landpatch%settyp(ipatch) == 1) THEN + IF (patchtypes(landpatch%settyp(ipatch)) == 0) THEN npatch = npatch + 1 sumpct(npatch) = sum(pftfrac(patch_pft_s(ipatch):patch_pft_e(ipatch))) ENDIF @@ -88,26 +87,9 @@ SUBROUTINE pct_readin (dir_landdata, lc_year) CALL check_vector_data ('Sum PFT pct', sumpct) #if (defined CROP) - CALL check_vector_data ('CROP pct', pctcrop) + CALL check_vector_data ('CROP pct', pctshrpch) #endif -#endif -#endif - -#ifdef LULC_IGBP_PC -#ifndef SinglePoint - lndname = trim(dir_landdata)//'/pctpft/'//trim(cyear)//'/pct_pcs.nc' - CALL ncio_read_vector (lndname, 'pct_pcs', N_PFT, landpc, pcfrac) -#else - pcfrac(:,1) = SITE_pctpfts -#endif - -#ifdef RangeCheck - IF (p_is_worker) THEN - allocate (sumpct (numpc)) - sumpct = sum(pcfrac,dim=1) - ENDIF - CALL check_vector_data ('Sum PFT pct', sumpct) #endif #endif diff --git a/mkinidata/MOD_SoilParametersReadin.F90 b/mkinidata/MOD_SoilParametersReadin.F90 index 5dd91aca..d4612025 100644 --- a/mkinidata/MOD_SoilParametersReadin.F90 +++ b/mkinidata/MOD_SoilParametersReadin.F90 @@ -88,7 +88,7 @@ SUBROUTINE soil_parameters_readin (dir_landdata, lc_year) write(cyear,'(i4.4)') lc_year landdir = trim(dir_landdata) // '/soil/' // trim(cyear) - write(*,*) 'soil parameter readin',landdir + ! write(*,*) 'soil parameter readin',landdir if (p_is_worker) then if (numpatch > 0) then diff --git a/mkinidata/MOD_UrbanReadin.F90 b/mkinidata/MOD_UrbanReadin.F90 index 5ea6eaee..73d5c39e 100644 --- a/mkinidata/MOD_UrbanReadin.F90 +++ b/mkinidata/MOD_UrbanReadin.F90 @@ -37,8 +37,9 @@ SUBROUTINE Urban_readin (dir_landdata, lc_year)!(dir_srfdata,dir_atmdata,nam_urb USE MOD_NetCDFSerial USE MOD_LandPatch USE MOD_LandUrban -#ifdef URBAN_LCZ - USE UrbanLCZ_Const + USE MOD_Urban_Const_LCZ +#ifdef SinglePoint + USE MOD_SingleSrfdata #endif IMPLICIT NONE @@ -54,11 +55,6 @@ SUBROUTINE Urban_readin (dir_landdata, lc_year)!(dir_srfdata,dir_atmdata,nam_urb REAL(r8) :: thick_roof, thick_wall -#ifdef USE_POINT_DATA -#ifdef USE_OBS_PARA - REAL(r8) :: rfwt, rfht, tpct, wpct, hw_point, htop_point, prwt -#endif -#endif ! parameters for LUCY INTEGER , allocatable :: lucyid(:) ! LUCY region id REAL(r8), allocatable :: popden(:) ! population density [person/km2] @@ -74,15 +70,67 @@ SUBROUTINE Urban_readin (dir_landdata, lc_year)!(dir_srfdata,dir_atmdata,nam_urb REAL(r8), allocatable :: thickroof (:) ! thickness of roof [m] REAL(r8), allocatable :: thickwall (:) ! thickness of wall [m] + write(cyear,'(i4.4)') lc_year + allocate (lucyid (numurban)) -#ifndef URBAN_LCZ +IF (DEF_URBAN_type_scheme == 1) THEN allocate (thickroof (numurban)) allocate (thickwall (numurban)) +#ifdef SinglePoint + ! allocate (hwr (numurban) ) + ! allocate (fgper (numurban) ) + + lucyid(:) = SITE_lucyid + hwr (:) = SITE_hwr + fgper (:) = SITE_fgper + + ! allocate ( em_roof (numurban) ) + ! allocate ( em_wall (numurban) ) + ! allocate ( em_gimp (numurban) ) + ! allocate ( em_gper (numurban) ) + + em_roof(:) = SITE_em_roof + em_wall(:) = SITE_em_wall + em_gimp(:) = SITE_em_gimp + em_gper(:) = SITE_em_gper + + ! allocate ( t_roommax (numurban) ) + ! allocate ( t_roommin (numurban) ) + + t_roommax(:) = SITE_t_roommax + t_roommin(:) = SITE_t_roommin + thickroof(:) = SITE_thickroof + thickwall(:) = SITE_thickwall + + ! allocate ( alb_roof (2, 2, numurban) ) + ! allocate ( alb_wall (2, 2, numurban) ) + ! allocate ( alb_gimp (2, 2, numurban) ) + ! allocate ( alb_gper (2, 2, numurban) ) + + alb_roof(:,:,1) = SITE_alb_roof + alb_wall(:,:,1) = SITE_alb_wall + alb_gimp(:,:,1) = SITE_alb_gimp + alb_gper(:,:,1) = SITE_alb_gper + + ! allocate ( cv_roof (10, numurban) ) + ! allocate ( cv_wall (10, numurban) ) + ! allocate ( cv_gimp (10, numurban) ) + ! allocate ( tk_roof (10, numurban) ) + ! allocate ( tk_wall (10, numurban) ) + ! allocate ( tk_gimp (10, numurban) ) + + cv_roof(:,1) = SITE_cv_roof + cv_wall(:,1) = SITE_cv_wall + cv_gimp(:,1) = SITE_cv_gimp + tk_roof(:,1) = SITE_tk_roof + tk_wall(:,1) = SITE_tk_wall + tk_gimp(:,1) = SITE_tk_gimp + +#else ! READ in urban data - write(cyear,'(i4.4)') lc_year lndname = trim(dir_landdata)//'/urban/'//trim(cyear)//'/urban.nc' print*,trim(lndname) CALL ncio_read_vector (lndname, 'CANYON_HWR ' , landurban, hwr ) ! average building height to their distance @@ -109,22 +157,25 @@ SUBROUTINE Urban_readin (dir_landdata, lc_year)!(dir_srfdata,dir_atmdata,nam_urb CALL ncio_read_vector (lndname, 'TK_WALL' , nl_wall, landurban, tk_wall) ! thermal conductivity of wall [W/m-K] CALL ncio_read_vector (lndname, 'TK_IMPROAD' , nl_soil, landurban, tk_gimp) ! thermal conductivity of impervious road [W/m-K] #endif +ENDIF -!TODO: add point case #ifdef SinglePoint - lndname = trim(dir_atmdata)//'/'//trim(nam_atmdata) - print*, lndname - CALL ncio_read_bcast_serial (landname, "impervious_area_fraction" , prwt ) ! imperivous area fraciton to total surface - CALL ncio_read_bcast_serial (landname, "tree_area_fraction" , fveg_urb) ! urban tree percentage - CALL ncio_read_bcast_serial (landname, "water_area_fraction" , flake ) ! urban lake precentage - CALL ncio_read_bcast_serial (landname, "roof_area_fraction" , froof ) ! roof fractional cover - CALL ncio_read_bcast_serial (landname, "building_mean_height" , hroof ) ! average building height - CALL ncio_read_bcast_serial (landname, "tree_mean_height" , htop_urb) ! urban tree crown top - CALL ncio_read_bcast_serial (landname, "canyon_height_width_ratio", hwr ) ! average building height to their distance - - wtperroad (1,1,:) = 1 - (prwt-rfwt)/(1-rfwt-wpct) !1. - prwt -#endif - + ! allocate( pop_den (numurban) ) + ! allocate( lucyid (numurban) ) + ! allocate( froof (numurban) ) + ! allocate( hroof (numurban) ) + ! allocate( flake (numurban) ) + ! allocate( fveg_urb (numurban) ) + ! allocate( htop_urb (numurban) ) + + pop_den = SITE_popden + lucyid = SITE_lucyid + froof = SITE_froof + hroof = SITE_hroof + flake = SITE_flake_urb + fveg_urb = SITE_fveg_urb + htop_urb = SITE_htop_urb +#else !TODO: Variables distinguish between time-varying and time-invariant variables ! write(cyear,'(i4.4)') lc_year lndname = trim(dir_landdata)//'/urban/'//trim(cyear)//'/POP.nc' @@ -154,16 +205,17 @@ SUBROUTINE Urban_readin (dir_landdata, lc_year)!(dir_srfdata,dir_atmdata,nam_urb lndname = trim(dir_landdata)//'/urban/'//trim(cyear)//'/htop_urb.nc' print*, lndname CALL ncio_read_vector (lndname, 'URBAN_TREE_TOP', landurban, htop_urb) +#endif dir_rawdata = DEF_dir_rawdata lndname = trim(dir_rawdata)//'/urban/'//'/LUCY_rawdata.nc' print*, lndname - CALL ncio_read_bcast_serial (lndname, "vehicle" , lvehicle ) - CALL ncio_read_bcast_serial (lndname, "weekendday" , lweek_holiday) - CALL ncio_read_bcast_serial (lndname, "weekendhour", lweh_prof ) - CALL ncio_read_bcast_serial (lndname, "weekdayhour", lwdh_prof ) - CALL ncio_read_bcast_serial (lndname, "metabolism" , lhum_prof ) - CALL ncio_read_bcast_serial (lndname, "holiday" , lfix_holiday ) + CALL ncio_read_bcast_serial (lndname, "NUMS_VEHC" , lvehicle ) + CALL ncio_read_bcast_serial (lndname, "WEEKEND_DAY" , lweek_holiday) + CALL ncio_read_bcast_serial (lndname, "TraffProf_24hr_holiday", lweh_prof ) + CALL ncio_read_bcast_serial (lndname, "TraffProf_24hr_work" , lwdh_prof ) + CALL ncio_read_bcast_serial (lndname, "HumMetabolic_24hr" , lhum_prof ) + CALL ncio_read_bcast_serial (lndname, "FIXED_HOLIDAY" , lfix_holiday ) IF (p_is_worker) THEN @@ -191,7 +243,7 @@ SUBROUTINE Urban_readin (dir_landdata, lc_year)!(dir_srfdata,dir_atmdata,nam_urb fix_holiday (:,u) = 0. ENDIF -#ifndef URBAN_LCZ +IF (DEF_URBAN_type_scheme == 1) THEN thick_roof = thickroof (u) !thickness of roof [m] thick_wall = thickwall (u) !thickness of wall [m] @@ -203,18 +255,18 @@ SUBROUTINE Urban_readin (dir_landdata, lc_year)!(dir_srfdata,dir_atmdata,nam_urb t_roommax(u) = 373.16 t_roommin(u) = 180.00 ENDIF -#else +ELSE IF (DEF_URBAN_type_scheme == 2) THEN ! read in LCZ constants hwr (u) = canyonhwr_lcz (landurban%settyp(u)) !average building height to their distance fgper(u) = wtperroad_lcz (landurban%settyp(u)) !pervious fraction to ground area DO ns = 1,2 - DO nr = 1,2 - alb_roof(ns,nr,u) = albroof_lcz (landurban%settyp(u)) !albedo of roof - alb_wall(ns,nr,u) = albwall_lcz (landurban%settyp(u)) !albedo of walls - alb_gimp(ns,nr,u) = albimproad_lcz (landurban%settyp(u)) !albedo of impervious - alb_gper(ns,nr,u) = albperroad_lcz (landurban%settyp(u)) !albedo of pervious road - ENDDO + DO nr = 1,2 + alb_roof(ns,nr,u) = albroof_lcz (landurban%settyp(u)) !albedo of roof + alb_wall(ns,nr,u) = albwall_lcz (landurban%settyp(u)) !albedo of walls + alb_gimp(ns,nr,u) = albimproad_lcz (landurban%settyp(u)) !albedo of impervious + alb_gper(ns,nr,u) = albperroad_lcz (landurban%settyp(u)) !albedo of pervious road + ENDDO ENDDO em_roof(u) = emroof_lcz (landurban%settyp(u)) !emissivity of roof @@ -234,7 +286,7 @@ SUBROUTINE Urban_readin (dir_landdata, lc_year)!(dir_srfdata,dir_atmdata,nam_urb DO ulev = 1, nl_soil cv_gimp(:,u) = cvimproad_lcz (landurban%settyp(u)) !heat capacity of impervious [J/(m2 K)] - tk_gimp(:,u) = tkperroad_lcz (landurban%settyp(u)) !thermal conductivity of impervious [W/m-K] + tk_gimp(:,u) = tkimproad_lcz (landurban%settyp(u)) !thermal conductivity of impervious [W/m-K] ENDDO thick_roof = thickroof_lcz (landurban%settyp(u)) !thickness of roof [m] @@ -247,7 +299,7 @@ SUBROUTINE Urban_readin (dir_landdata, lc_year)!(dir_srfdata,dir_atmdata,nam_urb t_roommax(u) = 373.16 !maximum temperature of inner room [K] t_roommin(u) = 180.00 !minimum temperature of inner room [K] ENDIF -#endif +ENDIF IF (DEF_URBAN_WATER) THEN flake(u) = flake(u)/100. !urban water fractional cover diff --git a/mksrfdata/Aggregation_DBedrock.F90 b/mksrfdata/Aggregation_DBedrock.F90 index e21854a7..5ffea55f 100644 --- a/mksrfdata/Aggregation_DBedrock.F90 +++ b/mksrfdata/Aggregation_DBedrock.F90 @@ -85,7 +85,7 @@ SUBROUTINE Aggregation_DBedrock ( & allocate (dbedrock_patches (numpatch)) DO ipatch = 1, numpatch - CALL aggregation_request_data (landpatch, ipatch, gland, area = area_one, & + CALL aggregation_request_data (landpatch, ipatch, gland, zip = USE_zip_for_aggregation, area = area_one, & data_r8_2d_in1 = dbedrock, data_r8_2d_out1 = dbedrock_one) dbedrock_patches (ipatch) = sum(dbedrock_one * area_one) / sum(area_one) ENDDO diff --git a/mksrfdata/Aggregation_ForestHeight.F90 b/mksrfdata/Aggregation_ForestHeight.F90 index fce7ae83..2d0e6c72 100644 --- a/mksrfdata/Aggregation_ForestHeight.F90 +++ b/mksrfdata/Aggregation_ForestHeight.F90 @@ -32,12 +32,9 @@ SUBROUTINE Aggregation_ForestHeight ( & USE MOD_Const_LC USE MOD_5x5DataReadin -#ifdef LULC_IGBP_PFT +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) USE MOD_LandPFT #endif -#ifdef LULC_IGBP_PC - USE MOD_LandPC -#endif #ifdef SinglePoint USE MOD_SingleSrfdata #endif @@ -121,7 +118,7 @@ SUBROUTINE Aggregation_ForestHeight ( & L = landpatch%settyp(ipatch) if(L/=0 .and. L/=1 .and. L/=16 .and. L/=24)then ! NOT OCEAN(0)/URBAN and BUILT-UP(1)/WATER BODIES(16)/ICE(24) - CALL aggregation_request_data (landpatch, ipatch, gland, & + CALL aggregation_request_data (landpatch, ipatch, gland, zip = USE_zip_for_aggregation, & data_r8_2d_in1 = tree_height, data_r8_2d_out1 = tree_height_one) tree_height_patches (ipatch) = median (tree_height_one, size(tree_height_one)) ELSE @@ -186,8 +183,8 @@ SUBROUTINE Aggregation_ForestHeight ( & DO ipatch = 1, numpatch IF (landpatch%settyp(ipatch) /= 0) THEN - CALL aggregation_request_data (landpatch, ipatch, gland, area = area_one, & - data_r8_2d_in1 = htop, data_r8_2d_out1 = htop_one) + CALL aggregation_request_data (landpatch, ipatch, gland, zip = USE_zip_for_aggregation, & + area = area_one, data_r8_2d_in1 = htop, data_r8_2d_out1 = htop_one) htop_patches(ipatch) = sum(htop_one * area_one) / sum(area_one) ENDIF @@ -230,7 +227,7 @@ SUBROUTINE Aggregation_ForestHeight ( & ENDIF #endif -#ifdef LULC_IGBP_PFT +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) IF (p_is_io) THEN CALL allocate_block_data (gland, htop) CALL allocate_block_data (gland, pftPCT, N_PFT_modis, lb1 = 0) @@ -255,13 +252,18 @@ SUBROUTINE Aggregation_ForestHeight ( & DO ipatch = 1, numpatch - CALL aggregation_request_data (landpatch, ipatch, gland, area = area_one, & - data_r8_2d_in1 = htop, data_r8_2d_out1 = htop_one, & + CALL aggregation_request_data (landpatch, ipatch, gland, zip = USE_zip_for_aggregation, & + area = area_one, data_r8_2d_in1 = htop, data_r8_2d_out1 = htop_one, & data_r8_3d_in1 = pftPCT, data_r8_3d_out1 = pct_one, n1_r8_3d_in1 = 16, lb1_r8_3d_in1 = 0) htop_patches(ipatch) = sum(htop_one * area_one) / sum(area_one) - IF (landpatch%settyp(ipatch) == 1) THEN + !IF (landpatch%settyp(ipatch) == 1) THEN +#ifndef CROP + IF (patchtypes(landpatch%settyp(ipatch)) == 0) THEN +#else + IF (patchtypes(landpatch%settyp(ipatch)) == 0 .and. landpatch%settyp(ipatch)/=CROPLAND) THEN +#endif DO ip = patch_pft_s(ipatch), patch_pft_e(ipatch) p = landpft%settyp(ip) sumarea = sum(pct_one(p,:) * area_one) @@ -272,7 +274,7 @@ SUBROUTINE Aggregation_ForestHeight ( & ENDIF ENDDO #ifdef CROP - ELSEIF (landpatch%settyp(ipatch) == 12) THEN + ELSEIF (landpatch%settyp(ipatch) == CROPLAND) THEN ip = patch_pft_s(ipatch) htop_pfts(ip) = htop_patches(ipatch) #endif @@ -336,96 +338,4 @@ SUBROUTINE Aggregation_ForestHeight ( & ENDIF #endif -#ifdef LULC_IGBP_PC - IF (p_is_io) THEN - CALL allocate_block_data (gland, htop) - CALL allocate_block_data (gland, pftPCT, N_PFT_modis, lb1 = 0) - ENDIF - - dir_5x5 = trim(dir_rawdata) // '/plant_15s' - suffix = 'MOD'//trim(cyear) - - IF (p_is_io) THEN - CALL read_5x5_data (dir_5x5, suffix, gland, 'HTOP', htop ) - CALL read_5x5_data_pft (dir_5x5, suffix, gland, 'PCT_PFT', pftPCT) -#ifdef USEMPI - CALL aggregation_data_daemon (gland, & - data_r8_2d_in1 = htop, data_r8_3d_in1 = pftPCT, n1_r8_3d_in1 = 16) -#endif - ENDIF - - IF (p_is_worker) THEN - - allocate (htop_patches (numpatch)) - allocate (htop_pcs (0:N_PFT-1, numpc)) - - DO ipatch = 1, numpatch - - CALL aggregation_request_data (landpatch, ipatch, gland, area = area_one, & - data_r8_2d_in1 = htop, data_r8_2d_out1 = htop_one, & - data_r8_3d_in1 = pftPCT, data_r8_3d_out1 = pct_one, n1_r8_3d_in1 = 16, lb1_r8_3d_in1 = 0) - - htop_patches(ipatch) = sum(htop_one * area_one) / sum(area_one) - - IF (patchtypes(landpatch%settyp(ipatch)) == 0) THEN - ip = patch2pc(ipatch) - DO ipft = 0, N_PFT-1 - sumarea = sum(pct_one(ipft,:) * area_one) - IF (sumarea > 0) THEN - htop_pcs(ipft,ip) = sum(htop_one * pct_one(ipft,:) * area_one) / sumarea - ELSE - htop_pcs(ipft,ip) = htop_patches(ipatch) - ENDIF - ENDDO - ENDIF - ENDDO - -#ifdef USEMPI - CALL aggregation_worker_done () -#endif - ENDIF - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - -#ifdef RangeCheck - CALL check_vector_data ('HTOP_patches ', htop_patches) - CALL check_vector_data ('HTOP_pcs ', htop_pcs ) -#endif - -#ifndef SinglePoint - lndname = trim(landdir)//'/htop_patches.nc' - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') - CALL ncio_write_vector (lndname, 'htop_patches', 'patch', landpatch, htop_patches, 1) - -#ifdef SrfdataDiag - typpatch = (/(ityp, ityp = 0, N_land_classification)/) - lndname = trim(dir_model_landdata) // '/diag/htop_patch_' // trim(cyear) // '.nc' - CALL srfdata_map_and_write (htop_patches, landpatch%settyp, typpatch, m_patch2diag, & - -1.0e36_r8, lndname, 'htop', compress = 1, write_mode = 'one') -#endif - - lndname = trim(landdir)//'/htop_pcs.nc' - CALL ncio_create_file_vector (lndname, landpc) - CALL ncio_define_dimension_vector (lndname, landpc, 'pc') - CALL ncio_define_dimension_vector (lndname, landpc, 'pft', N_PFT) - CALL ncio_write_vector (lndname, 'htop_pcs', 'pft', N_PFT, 'pc', landpc, htop_pcs, 1) - -#else - allocate (SITE_htop_pfts(N_PFT)) - SITE_htop_pfts(:) = htop_pcs(:,1) -#endif - - IF (p_is_worker) THEN - IF (allocated(htop_patches)) deallocate (htop_patches) - IF (allocated(htop_pcs )) deallocate (htop_pcs ) - IF (allocated(htop_one)) deallocate (htop_one) - IF (allocated(pct_one )) deallocate (pct_one ) - IF (allocated(area_one)) deallocate (area_one) - ENDIF -#endif - - END SUBROUTINE Aggregation_ForestHeight diff --git a/mksrfdata/Aggregation_LAI.F90 b/mksrfdata/Aggregation_LAI.F90 index 53a7ff7d..16913d48 100644 --- a/mksrfdata/Aggregation_LAI.F90 +++ b/mksrfdata/Aggregation_LAI.F90 @@ -32,12 +32,9 @@ SUBROUTINE Aggregation_LAI (gridlai, dir_rawdata, dir_model_landdata, lc_year) USE MOD_Const_LC USE MOD_5x5DataReadin -#ifdef LULC_IGBP_PFT +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) USE MOD_LandPFT #endif -#ifdef LULC_IGBP_PC - USE MOD_LandPC -#endif #ifdef SinglePoint USE MOD_SingleSrfdata #endif @@ -165,7 +162,7 @@ SUBROUTINE Aggregation_LAI (gridlai, dir_rawdata, dir_model_landdata, lc_year) ! 8-day LAI ELSE start_year = simulation_lai_year_start - end_year = simulation_lai_year_end + end_year = simulation_lai_year_end ntime = 46 ENDIF @@ -192,108 +189,110 @@ SUBROUTINE Aggregation_LAI (gridlai, dir_rawdata, dir_model_landdata, lc_year) #endif - DO iy = start_year, end_year + IF(.not. DEF_USE_LAIFEEDBACK)THEN + DO iy = start_year, end_year !IF (.not. DEF_LAI_MONTHLY) THEN ! lai data of each year -> case/landdata/year - write(cyear,'(i4.4)') iy - CALL system('mkdir -p ' // trim(landdir) // trim(cyear)) + write(cyear,'(i4.4)') iy + CALL system('mkdir -p ' // trim(landdir) // trim(cyear)) !ENDIF ! loop for month or 8-day - DO itime = 1, ntime + DO itime = 1, ntime ! ----------------------- ! read in leaf area index ! ----------------------- - IF (DEF_LAI_MONTHLY) THEN - write(c3, '(i2.2)') itime - ELSE - Julian_day = 1 + (itime-1)*8 - write(c3, '(i3.3)') Julian_day - ENDIF - - IF (p_is_master) THEN - write(*,'(A,I4,A1,I3,A1,I3)') 'Aggregate LAI :', iy, ':', itime, '/', ntime - endif - - IF (p_is_io) THEN IF (DEF_LAI_MONTHLY) THEN - dir_5x5 = trim(dir_rawdata) // '/plant_15s' - suffix = 'MOD'//trim(cyear) - CALL read_5x5_data_time (dir_5x5, suffix, gridlai, 'MONTHLY_LC_LAI', itime, LAI) + write(c3, '(i2.2)') itime ELSE - lndname = trim(dir_rawdata)//'/lai_15s_8day/lai_8-day_15s_'//trim(cyear)//'.nc' - CALL ncio_read_block_time (lndname, 'lai', gridlai, itime, LAI) - CALL block_data_linear_transform (LAI, scl = 0.1) + Julian_day = 1 + (itime-1)*8 + write(c3, '(i3.3)') Julian_day ENDIF + IF (p_is_master) THEN + write(*,'(A,I4,A1,I3,A1,I3)') 'Aggregate LAI :', iy, ':', itime, '/', ntime + endif + + IF (p_is_io) THEN + IF (DEF_LAI_MONTHLY) THEN + dir_5x5 = trim(dir_rawdata) // '/plant_15s' + suffix = 'MOD'//trim(cyear) + CALL read_5x5_data_time (dir_5x5, suffix, gridlai, 'MONTHLY_LC_LAI', itime, LAI) + ELSE + lndname = trim(dir_rawdata)//'/lai_15s_8day/lai_8-day_15s_'//trim(cyear)//'.nc' + CALL ncio_read_block_time (lndname, 'lai', gridlai, itime, LAI) + CALL block_data_linear_transform (LAI, scl = 0.1) + ENDIF + #ifdef USEMPI - CALL aggregation_data_daemon (gridlai, data_r8_2d_in1 = LAI) + CALL aggregation_data_daemon (gridlai, data_r8_2d_in1 = LAI) #endif - ENDIF + ENDIF ! --------------------------------------------------------------- ! aggregate the plant leaf area index from the resolution of raw data to modelling resolution ! --------------------------------------------------------------- - IF (p_is_worker) THEN - DO ipatch = 1, numpatch - CALL aggregation_request_data (landpatch, ipatch, gridlai, area = area_one, & - data_r8_2d_in1 = LAI, data_r8_2d_out1 = lai_one) - LAI_patches(ipatch) = sum(lai_one * area_one) / sum(area_one) - ENDDO + IF (p_is_worker) THEN + DO ipatch = 1, numpatch + CALL aggregation_request_data (landpatch, ipatch, gridlai, zip = USE_zip_for_aggregation, & + area = area_one, data_r8_2d_in1 = LAI, data_r8_2d_out1 = lai_one) + LAI_patches(ipatch) = sum(lai_one * area_one) / sum(area_one) + ENDDO #ifdef USEMPI - CALL aggregation_worker_done () + CALL aggregation_worker_done () #endif - ENDIF + ENDIF #ifdef RangeCheck - CALL check_vector_data ('LAI value '//trim(c3), LAI_patches) + CALL check_vector_data ('LAI value '//trim(c3), LAI_patches) #endif #ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) + CALL mpi_barrier (p_comm_glb, p_err) #endif ! --------------------------------------------------- ! write out the plant leaf area index of grid patches ! --------------------------------------------------- #ifndef SinglePoint - IF (DEF_LAI_MONTHLY) THEN - lndname = trim(landdir) // trim(cyear) // '/LAI_patches' // trim(c3) // '.nc' - ELSE - !TODO: rename filename of 8-day LAI - lndname = trim(landdir) // trim(cyear) // '/LAI_patches' // trim(c3) // '.nc' - ENDIF + IF (DEF_LAI_MONTHLY) THEN + lndname = trim(landdir) // trim(cyear) // '/LAI_patches' // trim(c3) // '.nc' + ELSE + !TODO: rename filename of 8-day LAI + lndname = trim(landdir) // trim(cyear) // '/LAI_patches' // trim(c3) // '.nc' + ENDIF - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') - CALL ncio_write_vector (lndname, 'LAI_patches', 'patch', landpatch, LAI_patches, 1) + CALL ncio_create_file_vector (lndname, landpatch) + CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') + CALL ncio_write_vector (lndname, 'LAI_patches', 'patch', landpatch, LAI_patches, 1) #ifdef SrfdataDiag - typpatch = (/(ityp, ityp = 0, N_land_classification)/) - lndname = trim(dir_model_landdata) // '/diag/LAI_patch_'// trim(cyear) // '.nc' - IF (DEF_LAI_MONTHLY) THEN - varname = 'LAI' - ELSE + typpatch = (/(ityp, ityp = 0, N_land_classification)/) + lndname = trim(dir_model_landdata) // '/diag/LAI_patch_'// trim(cyear) // '.nc' + IF (DEF_LAI_MONTHLY) THEN + varname = 'LAI' + ELSE !TODO: rename file name of 8-day LAI - varname = 'LAI_8-day' - ENDIF - CALL srfdata_map_and_write (LAI_patches, landpatch%settyp, typpatch, m_patch2diag, & - -1.0e36_r8, lndname, trim(varname), compress = 0, write_mode = 'one', & - lastdimname = 'Itime', lastdimvalue = itime) + varname = 'LAI_8-day' + ENDIF + CALL srfdata_map_and_write (LAI_patches, landpatch%settyp, typpatch, m_patch2diag, & + -1.0e36_r8, lndname, trim(varname), compress = 0, write_mode = 'one', & + lastdimname = 'Itime', lastdimvalue = itime) #endif #else ! single point cases !TODO: parameter input for time year - IF (DEF_LAI_MONTHLY) THEN - SITE_LAI_monthly(itime,iy) = LAI_patches(1) - ELSE - SITE_LAI_8day(itime,iy) = LAI_patches(1) - ENDIF + IF (DEF_LAI_MONTHLY) THEN + SITE_LAI_monthly(itime,iy) = LAI_patches(1) + ELSE + SITE_LAI_8day(itime,iy) = LAI_patches(1) + ENDIF #endif + ENDDO ENDDO - ENDDO + ENDIF ! ----- SAI ----- IF (DEF_LAI_MONTHLY) THEN @@ -337,8 +336,8 @@ SUBROUTINE Aggregation_LAI (gridlai, dir_rawdata, dir_model_landdata, lc_year) IF (p_is_worker) THEN DO ipatch = 1, numpatch - CALL aggregation_request_data (landpatch, ipatch, gridlai, area = area_one, & - data_r8_2d_in1 = SAI, data_r8_2d_out1 = sai_one) + CALL aggregation_request_data (landpatch, ipatch, gridlai, zip = USE_zip_for_aggregation, & + area = area_one, data_r8_2d_in1 = SAI, data_r8_2d_out1 = sai_one) SAI_patches(ipatch) = sum(sai_one * area_one) / sum(area_one) ENDDO @@ -386,21 +385,28 @@ SUBROUTINE Aggregation_LAI (gridlai, dir_rawdata, dir_model_landdata, lc_year) ENDIF #endif -! PFT LAI!!!!! -#ifdef LULC_IGBP_PFT +! For both PFT and PC run LAI!!!!! +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) ! add time variation of LAI ! monthly average LAI ! if use lai change, LAI data of simulation start year and end year will be made ! if not use lai change, only make LAI data of defined lc year +#ifdef LULCC + ! 07/2023, NOTE: if defined LULCC, only one year (lc_year) lai processed. + start_year = lc_year + end_year = lc_year + ntime = 12 +#else IF (DEF_LAI_CHANGE_YEARLY) THEN start_year = simulation_lai_year_start - end_year = simulation_lai_year_end + end_year = simulation_lai_year_end ntime = 12 ELSE start_year = lc_year end_year = lc_year ntime = 12 ENDIF +#endif IF (p_is_io) THEN CALL allocate_block_data (gridlai, pftLSAI, N_PFT_modis, lb1 = 0) @@ -433,114 +439,121 @@ SUBROUTINE Aggregation_LAI (gridlai, dir_rawdata, dir_model_landdata, lc_year) CALL read_5x5_data_pft (dir_5x5, suffix, gridlai, 'PCT_PFT', pftPCT) ENDIF - DO month = 1, 12 - IF (p_is_io) THEN - CALL read_5x5_data_pft_time (dir_5x5, suffix, gridlai, 'MONTHLY_PFT_LAI', month, pftLSAI) + IF(.not. DEF_USE_LAIFEEDBACK)THEN + DO month = 1, 12 + IF (p_is_io) THEN + CALL read_5x5_data_pft_time (dir_5x5, suffix, gridlai, 'MONTHLY_PFT_LAI', month, pftLSAI) #ifdef USEMPI - CALL aggregation_data_daemon (gridlai, & - data_r8_3d_in1 = pftPCT, n1_r8_3d_in1 = 16, & - data_r8_3d_in2 = pftLSAI, n1_r8_3d_in2 = 16) + CALL aggregation_data_daemon (gridlai, & + data_r8_3d_in1 = pftPCT, n1_r8_3d_in1 = 16, & + data_r8_3d_in2 = pftLSAI, n1_r8_3d_in2 = 16) #endif - ENDIF + ENDIF ! --------------------------------------------------------------- ! aggregate the plant leaf area index from the resolution of raw data to modelling resolution ! --------------------------------------------------------------- - IF (p_is_worker) THEN - DO ipatch = 1, numpatch - CALL aggregation_request_data (landpatch, ipatch, gridlai, area = area_one, & - data_r8_3d_in1 = pftPCT, data_r8_3d_out1 = pct_pft_one, n1_r8_3d_in1 = 16, lb1_r8_3d_in1 = 0, & - data_r8_3d_in2 = pftLSAI, data_r8_3d_out2 = lai_pft_one, n1_r8_3d_in2 = 16, lb1_r8_3d_in2 = 0) - - IF (allocated(lai_one)) deallocate(lai_one) - allocate(lai_one(size(area_one))) + IF (p_is_worker) THEN + DO ipatch = 1, numpatch + CALL aggregation_request_data (landpatch, ipatch, gridlai, zip = USE_zip_for_aggregation, area = area_one, & + data_r8_3d_in1 = pftPCT, data_r8_3d_out1 = pct_pft_one, n1_r8_3d_in1 = 16, lb1_r8_3d_in1 = 0, & + data_r8_3d_in2 = pftLSAI, data_r8_3d_out2 = lai_pft_one, n1_r8_3d_in2 = 16, lb1_r8_3d_in2 = 0) + + IF (allocated(lai_one)) deallocate(lai_one) + allocate(lai_one(size(area_one))) - IF (allocated(pct_one)) deallocate(pct_one) - allocate(pct_one(size(area_one))) + IF (allocated(pct_one)) deallocate(pct_one) + allocate(pct_one(size(area_one))) - pct_one = sum(pct_pft_one,dim=1) - pct_one = max(pct_one, 1.0e-6) + pct_one = sum(pct_pft_one,dim=1) + pct_one = max(pct_one, 1.0e-6) - lai_one = sum(lai_pft_one * pct_pft_one, dim=1) / pct_one - LAI_patches(ipatch) = sum(lai_one * area_one) / sum(area_one) + lai_one = sum(lai_pft_one * pct_pft_one, dim=1) / pct_one + LAI_patches(ipatch) = sum(lai_one * area_one) / sum(area_one) - IF (landpatch%settyp(ipatch) == 1) THEN - DO ip = patch_pft_s(ipatch), patch_pft_e(ipatch) - p = landpft%settyp(ip) - sumarea = sum(pct_pft_one(p,:) * area_one) - IF (sumarea > 0) THEN - LAI_pfts(ip) = sum(lai_pft_one(p,:) * pct_pft_one(p,:) * area_one) / sumarea - ELSE + !IF (landpatch%settyp(ipatch) == 1) THEN +#ifndef CROP + IF (patchtypes(landpatch%settyp(ipatch)) == 0) THEN +#else + IF (patchtypes(landpatch%settyp(ipatch)) == 0 .and. landpatch%settyp(ipatch)/=CROPLAND) THEN +#endif + DO ip = patch_pft_s(ipatch), patch_pft_e(ipatch) + p = landpft%settyp(ip) + sumarea = sum(pct_pft_one(p,:) * area_one) + IF (sumarea > 0) THEN + LAI_pfts(ip) = sum(lai_pft_one(p,:) * pct_pft_one(p,:) * area_one) / sumarea + ELSE ! 07/2023, yuan: bug may exist below !LAI_pfts(ip) = LAI_patches(ipatch) - LAI_pfts(ip) = 0. - ENDIF - ENDDO + LAI_pfts(ip) = 0. + ENDIF + ENDDO #ifdef CROP - ELSEIF (landpatch%settyp(ipatch) == 12) THEN - ip = patch_pft_s(ipatch) - LAI_pfts(ip) = LAI_patches(ipatch) + ELSEIF (landpatch%settyp(ipatch) == CROPLAND) THEN + ip = patch_pft_s(ipatch) + LAI_pfts(ip) = LAI_patches(ipatch) #endif - ENDIF - ENDDO + ENDIF + ENDDO #ifdef USEMPI - CALL aggregation_worker_done () + CALL aggregation_worker_done () #endif - ENDIF + ENDIF - write(c2,'(i2.2)') month + write(c2,'(i2.2)') month #ifdef RangeCheck - CALL check_vector_data ('LAI_patches ' // trim(c2), LAI_patches) - CALL check_vector_data ('LAI_pfts ' // trim(c2), LAI_pfts ) + CALL check_vector_data ('LAI_patches ' // trim(c2), LAI_patches) + CALL check_vector_data ('LAI_pfts ' // trim(c2), LAI_pfts ) #endif #ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) + CALL mpi_barrier (p_comm_glb, p_err) #endif ! --------------------------------------------------- ! write out the plant leaf area index of grid patches ! --------------------------------------------------- #ifndef SinglePoint - lndname = trim(landdir)//trim(cyear)//'/LAI_patches'//trim(c2)//'.nc' - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') - CALL ncio_write_vector (lndname, 'LAI_patches', 'patch', landpatch, LAI_patches, 1) + lndname = trim(landdir)//trim(cyear)//'/LAI_patches'//trim(c2)//'.nc' + CALL ncio_create_file_vector (lndname, landpatch) + CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') + CALL ncio_write_vector (lndname, 'LAI_patches', 'patch', landpatch, LAI_patches, 1) #ifdef SrfdataDiag - typpatch = (/(ityp, ityp = 0, N_land_classification)/) - lndname = trim(dir_model_landdata) // '/diag/LAI_patch_'// trim(cyear) // '.nc' - varname = 'LAI' - CALL srfdata_map_and_write (LAI_patches, landpatch%settyp, typpatch, m_patch2diag, & - -1.0e36_r8, lndname, trim(varname), compress = 0, write_mode = 'one', & - lastdimname = 'Itime', lastdimvalue = month) + typpatch = (/(ityp, ityp = 0, N_land_classification)/) + lndname = trim(dir_model_landdata) // '/diag/LAI_patch_'// trim(cyear) // '.nc' + varname = 'LAI' + CALL srfdata_map_and_write (LAI_patches, landpatch%settyp, typpatch, m_patch2diag, & + -1.0e36_r8, lndname, trim(varname), compress = 0, write_mode = 'one', & + lastdimname = 'Itime', lastdimvalue = month) #endif - lndname = trim(landdir)//trim(cyear)//'/LAI_pfts'//trim(c2)//'.nc' - CALL ncio_create_file_vector (lndname, landpft) - CALL ncio_define_dimension_vector (lndname, landpft, 'pft') - CALL ncio_write_vector (lndname, 'LAI_pfts', 'pft', landpft, LAI_pfts, 1) + lndname = trim(landdir)//trim(cyear)//'/LAI_pfts'//trim(c2)//'.nc' + CALL ncio_create_file_vector (lndname, landpft) + CALL ncio_define_dimension_vector (lndname, landpft, 'pft') + CALL ncio_write_vector (lndname, 'LAI_pfts', 'pft', landpft, LAI_pfts, 1) #ifdef SrfdataDiag #ifndef CROP - typpft = (/(ityp, ityp = 0, N_PFT-1)/) + typpft = (/(ityp, ityp = 0, N_PFT-1)/) #else - typpft = (/(ityp, ityp = 0, N_PFT+N_CFT-1)/) + typpft = (/(ityp, ityp = 0, N_PFT+N_CFT-1)/) #endif - lndname = trim(dir_model_landdata) // '/diag/LAI_pft_'// trim(cyear) // '.nc' - varname = 'LAI_pft' - CALL srfdata_map_and_write (LAI_pfts, landpft%settyp, typpft, m_pft2diag, & - -1.0e36_r8, lndname, trim(varname), compress = 0, write_mode = 'one', & - lastdimname = 'Itime', lastdimvalue = month) + lndname = trim(dir_model_landdata) // '/diag/LAI_pft_'// trim(cyear) // '.nc' + varname = 'LAI_pft' + CALL srfdata_map_and_write (LAI_pfts, landpft%settyp, typpft, m_pft2diag, & + -1.0e36_r8, lndname, trim(varname), compress = 0, write_mode = 'one', & + lastdimname = 'Itime', lastdimvalue = month) #endif #else !TODO: single point case - SITE_LAI_pfts_monthly(:,month,iy) = LAI_pfts(:) + SITE_LAI_pfts_monthly(:,month,iy) = LAI_pfts(:) #endif ! loop end of month - ENDDO + ENDDO + ENDIF ! IF (p_is_worker) THEN ! IF (allocated(LAI_patches)) deallocate(LAI_patches) ! IF (allocated(LAI_pfts )) deallocate(LAI_pfts ) @@ -567,7 +580,7 @@ SUBROUTINE Aggregation_LAI (gridlai, dir_rawdata, dir_model_landdata, lc_year) IF (p_is_worker) THEN DO ipatch = 1, numpatch - CALL aggregation_request_data (landpatch, ipatch, gridlai, area = area_one, & + CALL aggregation_request_data (landpatch, ipatch, gridlai, zip = USE_zip_for_aggregation, area = area_one, & data_r8_3d_in1 = pftPCT, data_r8_3d_out1 = pct_pft_one, n1_r8_3d_in1 = 16, lb1_r8_3d_in1 = 0, & data_r8_3d_in2 = pftLSAI, data_r8_3d_out2 = sai_pft_one, n1_r8_3d_in2 = 16, lb1_r8_3d_in2 = 0) @@ -583,7 +596,12 @@ SUBROUTINE Aggregation_LAI (gridlai, dir_rawdata, dir_model_landdata, lc_year) sai_one = sum(sai_pft_one * pct_pft_one, dim=1) / pct_one SAI_patches(ipatch) = sum(sai_one * area_one) / sum(area_one) - IF (landpatch%settyp(ipatch) == 1) THEN + !IF (landpatch%settyp(ipatch) == 1) THEN +#ifndef CROP + IF (patchtypes(landpatch%settyp(ipatch)) == 0) THEN +#else + IF (patchtypes(landpatch%settyp(ipatch)) == 0 .and. landpatch%settyp(ipatch)/=CROPLAND) THEN +#endif DO ip = patch_pft_s(ipatch), patch_pft_e(ipatch) p = landpft%settyp(ip) sumarea = sum(pct_pft_one(p,:) * area_one) @@ -596,7 +614,7 @@ SUBROUTINE Aggregation_LAI (gridlai, dir_rawdata, dir_model_landdata, lc_year) ENDIF ENDDO #ifdef CROP - ELSEIF (landpatch%settyp(ipatch) == 12) THEN + ELSEIF (landpatch%settyp(ipatch) == CROPLAND) THEN ip = patch_pft_s(ipatch) SAI_pfts(ip) = SAI_patches(ipatch) #endif @@ -674,239 +692,4 @@ SUBROUTINE Aggregation_LAI (gridlai, dir_rawdata, dir_model_landdata, lc_year) ENDIF #endif -! PC LAI!!!!!!!! -#ifdef LULC_IGBP_PC - ! add time variation of LAI - ! monthly average LAI - ! if use lai change, LAI data of simulation start year and end year will be made - ! if not use lai change, only make LAI data of defined lc year - IF (DEF_LAI_CHANGE_YEARLY) THEN - start_year = simulation_lai_year_start - end_year = simulation_lai_year_end - ntime = 12 - ELSE - start_year = lc_year - end_year = lc_year - ntime = 12 - ENDIF - - IF (p_is_io) THEN - CALL allocate_block_data (gridlai, pftLSAI, N_PFT_modis, lb1 = 0) - CALL allocate_block_data (gridlai, pftPCT, N_PFT_modis, lb1 = 0) - ENDIF - - IF (p_is_worker) THEN - allocate(LAI_patches (numpatch)) - allocate(LAI_pcs (0:N_PFT-1, numpc)) - allocate(SAI_patches (numpatch)) - allocate(SAI_pcs (0:N_PFT-1, numpc)) - ENDIF - -#ifdef SinglePoint - allocate (SITE_LAI_year (start_year:end_year)) - SITE_LAI_year = (/(iy, iy = start_year, end_year)/) - - !TODO-yuan-done: for multiple years - allocate (SITE_LAI_pfts_monthly (0:N_PFT-1,12,start_year:end_year)) - allocate (SITE_SAI_pfts_monthly (0:N_PFT-1,12,start_year:end_year)) -#endif - - dir_5x5 = trim(dir_rawdata) // '/plant_15s' - DO iy = start_year, end_year - write(cyear,'(i4.4)') iy - suffix = 'MOD'//trim(cyear) - CALL system('mkdir -p ' // trim(landdir) // trim(cyear)) - - IF (p_is_io) THEN - CALL read_5x5_data_pft (dir_5x5, suffix, gridlai, 'PCT_PFT', pftPCT) - ENDIF - - DO month = 1, 12 - IF (p_is_io) THEN - ! change var name to MONTHLY_PFT_LAI - CALL read_5x5_data_pft_time (dir_5x5, suffix, gridlai, 'MONTHLY_PFT_LAI', month, pftLSAI) -#ifdef USEMPI - CALL aggregation_data_daemon (gridlai, & - data_r8_3d_in1 = pftPCT, n1_r8_3d_in1 = 16, & - data_r8_3d_in2 = pftLSAI, n1_r8_3d_in2 = 16) -#endif - ENDIF - - ! --------------------------------------------------------------- - ! aggregate the plant leaf area index from the resolution of raw data to modelling resolution - ! --------------------------------------------------------------- - - IF (p_is_worker) THEN - DO ipatch = 1, numpatch - CALL aggregation_request_data (landpatch, ipatch, gridlai, area = area_one, & - data_r8_3d_in1 = pftPCT, data_r8_3d_out1 = pct_pft_one, n1_r8_3d_in1 = 16, lb1_r8_3d_in1 = 0, & - data_r8_3d_in2 = pftLSAI, data_r8_3d_out2 = lai_pft_one, n1_r8_3d_in2 = 16, lb1_r8_3d_in2 = 0) - - IF (allocated(lai_one)) deallocate(lai_one) - allocate(lai_one(size(area_one))) - - IF (allocated(pct_one)) deallocate(pct_one) - allocate(pct_one(size(area_one))) - - pct_one = sum(pct_pft_one,dim=1) - pct_one = max(pct_one, 1.0e-6) - - lai_one = sum(lai_pft_one * pct_pft_one, dim=1) / pct_one - LAI_patches(ipatch) = sum(lai_one * area_one) / sum(area_one) - - IF (patchtypes(landpatch%settyp(ipatch)) == 0) THEN - ipc = patch2pc(ipatch) - DO ipft = 0, N_PFT-1 - sumarea = sum(pct_pft_one(ipft,:) * area_one) - IF (sumarea > 0) THEN - LAI_pcs(ipft,ipc) = sum(lai_pft_one(ipft,:) * pct_pft_one(ipft,:) * area_one) / sumarea - ELSE - ! 07/2023, yuan: bug may exist below - !LAI_pcs(ipft,ipc) = LAI_patches(ipatch) - LAI_pcs(ipft,ipc) = 0. - ENDIF - ENDDO - ENDIF - ENDDO - -#ifdef USEMPI - CALL aggregation_worker_done () -#endif - ENDIF - - write(c2,'(i2.2)') month -#ifdef RangeCheck - CALL check_vector_data ('LAI_patches ' // trim(c2), LAI_patches) - CALL check_vector_data ('LAI_pcs ' // trim(c2), LAI_pcs ) -#endif -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - - ! --------------------------------------------------- - ! write out the plant leaf area index of grid patches - ! --------------------------------------------------- -#ifndef SinglePoint - lndname = trim(landdir)//trim(cyear)//'/LAI_patches'//trim(c2)//'.nc' - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') - CALL ncio_write_vector (lndname, 'LAI_patches', 'patch', landpatch, LAI_patches, 1) - - lndname = trim(landdir)//trim(cyear)//'/LAI_pcs'//trim(c2)//'.nc' - CALL ncio_create_file_vector (lndname, landpc) - CALL ncio_define_dimension_vector (lndname, landpc, 'pc') - CALL ncio_define_dimension_vector (lndname, landpc, 'pft', N_PFT) - CALL ncio_write_vector (lndname, 'LAI_pcs', 'pft', N_PFT, 'pc', landpc, LAI_pcs, 1) -#else - SITE_LAI_pfts_monthly(:,month,iy) = LAI_pcs(:,1) -#endif - ! loop end of month - ENDDO - - ! IF (p_is_worker) THEN - ! IF (allocated(LAI_patches)) deallocate(LAI_patches) - ! IF (allocated(LAI_pcs )) deallocate(LAI_pcs ) - ! IF (allocated(lai_one )) deallocate(lai_one ) - ! IF (allocated(pct_one )) deallocate(pct_one ) - ! IF (allocated(pct_pft_one)) deallocate(pct_pft_one) - ! IF (allocated(area_one )) deallocate(area_one ) - ! ENDIF - - DO month = 1, 12 - IF (p_is_io) THEN - ! change var name to MONTHLY_PFT_SAI - CALL read_5x5_data_pft_time (dir_5x5, suffix, gridlai, 'MONTHLY_PFT_SAI', month, pftLSAI) -#ifdef USEMPI - CALL aggregation_data_daemon (gridlai, & - data_r8_3d_in1 = pftPCT, n1_r8_3d_in1 = 16, & - data_r8_3d_in2 = pftLSAI, n1_r8_3d_in2 = 16) -#endif - ENDIF - - ! --------------------------------------------------------------- - ! aggregate the plant leaf area index from the resolution of raw data to modelling resolution - ! --------------------------------------------------------------- - - IF (p_is_worker) THEN - DO ipatch = 1, numpatch - - CALL aggregation_request_data (landpatch, ipatch, gridlai, area = area_one, & - data_r8_3d_in1 = pftPCT, data_r8_3d_out1 = pct_pft_one, n1_r8_3d_in1 = 16, lb1_r8_3d_in1 = 0, & - data_r8_3d_in2 = pftLSAI, data_r8_3d_out2 = sai_pft_one, n1_r8_3d_in2 = 16, lb1_r8_3d_in2 = 0) - - IF (allocated(sai_one)) deallocate(sai_one) - allocate(sai_one(size(area_one))) - - IF (allocated(pct_one)) deallocate(pct_one) - allocate(pct_one(size(area_one))) - - pct_one = sum(pct_pft_one,dim=1) - pct_one = max(pct_one, 1.0e-6) - - sai_one = sum(sai_pft_one * pct_pft_one, dim=1) / pct_one - SAI_patches(ipatch) = sum(sai_one * area_one) / sum(area_one) - - IF (patchtypes(landpatch%settyp(ipatch)) == 0) THEN - ipc = patch2pc(ipatch) - DO ipft = 0, N_PFT-1 - sumarea = sum(pct_pft_one(ipft,:) * area_one) - IF (sumarea > 0) THEN - SAI_pcs(ipft,ipc) = sum(sai_pft_one(ipft,:) * pct_pft_one(ipft,:) * area_one) / sumarea - ELSE - ! 07/2023, yuan: bug may exist below - !SAI_pcs(ipft,ipc) = SAI_patches(ipatch) - SAI_pcs(ipft,ipc) = 0. - ENDIF - ENDDO - ENDIF - ENDDO - -#ifdef USEMPI - CALL aggregation_worker_done () -#endif - ENDIF - - write(c2,'(i2.2)') month -#ifdef RangeCheck - CALL check_vector_data ('SAI_patches ' // trim(c2), SAI_patches) - CALL check_vector_data ('SAI_pcs ' // trim(c2), SAI_pcs ) -#endif -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - - ! --------------------------------------------------- - ! write out the plant stem area index of grid patches - ! --------------------------------------------------- -#ifndef SinglePoint - lndname = trim(landdir)//trim(cyear)//'/SAI_patches'//trim(c2)//'.nc' - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') - CALL ncio_write_vector (lndname, 'SAI_patches', 'patch', landpatch, SAI_patches, 1) - - lndname = trim(landdir)//trim(cyear)//'/SAI_pcs'//trim(c2)//'.nc' - CALL ncio_create_file_vector (lndname, landpc) - CALL ncio_define_dimension_vector (lndname, landpc, 'pc') - CALL ncio_define_dimension_vector (lndname, landpc, 'pft', N_PFT) - CALL ncio_write_vector (lndname, 'SAI_pcs', 'pft', N_PFT, 'pc', landpc, SAI_pcs, 1) -#else - !TODO: single points - SITE_SAI_pfts_monthly(:,month,iy) = SAI_pcs(:,1) -#endif - ! loop end of month - ENDDO - ENDDO - IF (p_is_worker) THEN - IF (allocated(LAI_patches)) deallocate(LAI_patches) - IF (allocated(LAI_pcs )) deallocate(LAI_pcs ) - IF (allocated(lai_one )) deallocate(lai_one ) - IF (allocated(SAI_patches)) deallocate(SAI_patches) - IF (allocated(SAI_pcs )) deallocate(SAI_pcs ) - IF (allocated(sai_one )) deallocate(sai_one ) - IF (allocated(pct_one )) deallocate(pct_one ) - IF (allocated(pct_pft_one)) deallocate(pct_pft_one) - IF (allocated(area_one )) deallocate(area_one ) - ENDIF -#endif - END SUBROUTINE Aggregation_LAI diff --git a/mksrfdata/Aggregation_LakeDepth.F90 b/mksrfdata/Aggregation_LakeDepth.F90 index d8ca93fe..ad1305bf 100644 --- a/mksrfdata/Aggregation_LakeDepth.F90 +++ b/mksrfdata/Aggregation_LakeDepth.F90 @@ -113,19 +113,8 @@ SUBROUTINE Aggregation_LakeDepth ( & DO ipatch = 1, numpatch L = landpatch%settyp(ipatch) -#ifdef LULC_USGS - IF(L==16)THEN ! LAND WATER BODIES (16) -#endif -#ifdef LULC_IGBP - IF(L==17)THEN ! LAND WATER BODIES (17) -#endif -#ifdef LULC_IGBP_PFT - IF(L==17)THEN ! LAND WATER BODIES (17) -#endif -#ifdef LULC_IGBP_PC - IF(L==17)THEN ! LAND WATER BODIES (17) -#endif - CALL aggregation_request_data (landpatch, ipatch, gland, & + IF(L==WATERBODY)THEN ! LAND WATER BODIES (17) + CALL aggregation_request_data (landpatch, ipatch, gland, zip = USE_zip_for_aggregation, & data_r8_2d_in1 = lakedepth, data_r8_2d_out1 = lakedepth_one) lakedepth_patches (ipatch) = median (lakedepth_one, size(lakedepth_one)) ELSE diff --git a/mksrfdata/Aggregation_PercentagesPFT.F90 b/mksrfdata/Aggregation_PercentagesPFT.F90 index 1cd033bc..4d912a8d 100644 --- a/mksrfdata/Aggregation_PercentagesPFT.F90 +++ b/mksrfdata/Aggregation_PercentagesPFT.F90 @@ -18,6 +18,9 @@ SUBROUTINE Aggregation_PercentagesPFT (gland, dir_rawdata, dir_model_landdata, l USE MOD_SPMD_Task USE MOD_Grid USE MOD_LandPatch +#ifdef CROP + USE MOD_LandCrop +#endif USE MOD_NetCDFBlock USE MOD_NetCDFVector #ifdef RangeCheck @@ -28,12 +31,9 @@ SUBROUTINE Aggregation_PercentagesPFT (gland, dir_rawdata, dir_model_landdata, l USE MOD_Const_LC USE MOD_5x5DataReadin -#ifdef LULC_IGBP_PFT +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) USE MOD_LandPFT #endif -#ifdef LULC_IGBP_PC - USE MOD_LandPC -#endif #ifdef SinglePoint USE MOD_SingleSrfdata #endif @@ -60,13 +60,9 @@ SUBROUTINE Aggregation_PercentagesPFT (gland, dir_rawdata, dir_model_landdata, l ! for PFT TYPE (block_data_real8_3d) :: pftPCT REAL(r8), allocatable :: pct_one(:), area_one(:) -#ifdef LULC_IGBP_PFT +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) REAL(r8), allocatable :: pct_pft_one(:,:) REAL(r8), allocatable :: pct_pfts(:) -#endif -#ifdef LULC_IGBP_PC - REAL(r8), allocatable :: pct_pft_one(:,:) - REAL(r8), allocatable :: pct_pcs(:,:) #endif INTEGER :: ipatch, ipc, ipft, p REAL(r8) :: sumarea @@ -94,7 +90,7 @@ SUBROUTINE Aggregation_PercentagesPFT (gland, dir_rawdata, dir_model_landdata, l #endif -#ifdef LULC_IGBP_PFT +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) #ifdef SinglePoint IF (USE_SITE_pctpfts) THEN @@ -120,10 +116,19 @@ SUBROUTINE Aggregation_PercentagesPFT (gland, dir_rawdata, dir_model_landdata, l allocate(pct_pfts (numpft)) DO ipatch = 1, numpatch - IF (landpatch%settyp(ipatch) == 1) THEN - CALL aggregation_request_data (landpatch, ipatch, gland, area = area_one, & + !IF (landpatch%settyp(ipatch) == 1) THEN +#ifndef CROP + IF (patchtypes(landpatch%settyp(ipatch)) == 0) THEN +#else + IF (patchtypes(landpatch%settyp(ipatch)) == 0 .and. landpatch%settyp(ipatch)/=CROPLAND) THEN +#endif + CALL aggregation_request_data (landpatch, ipatch, gland, zip = USE_zip_for_aggregation, area = area_one, & data_r8_3d_in1 = pftPCT, data_r8_3d_out1 = pct_pft_one, n1_r8_3d_in1 = N_PFT_modis, lb1_r8_3d_in1 = 0) +#ifdef CROP + pct_pft_one(N_PFT_modis-1,:) = 0. +#endif + pct_one = sum(pct_pft_one, dim=1) pct_one = max(pct_one, 1.0e-6) sumarea = sum(area_one) @@ -137,7 +142,7 @@ SUBROUTINE Aggregation_PercentagesPFT (gland, dir_rawdata, dir_model_landdata, l pct_pfts(patch_pft_s(ipatch):patch_pft_e(ipatch)) & / sum(pct_pfts(patch_pft_s(ipatch):patch_pft_e(ipatch))) #ifdef CROP - ELSEIF (landpatch%settyp(ipatch) == 12) THEN + ELSEIF (landpatch%settyp(ipatch) == CROPLAND) THEN pct_pfts(patch_pft_s(ipatch):patch_pft_e(ipatch)) = 1. #endif ENDIF @@ -189,96 +194,22 @@ SUBROUTINE Aggregation_PercentagesPFT (gland, dir_rawdata, dir_model_landdata, l lndname = trim(landdir)//'/pct_crops.nc' CALL ncio_create_file_vector (lndname, landpatch) CALL ncio_define_dimension_vector (lndname, landpatch, 'patch') - CALL ncio_write_vector (lndname, 'pct_crops', 'patch', landpatch, pctcrop, 1) + CALL ncio_write_vector (lndname, 'pct_crops', 'patch', landpatch, pctshrpch, 1) #ifdef SrfdataDiag typcrop = (/(ityp, ityp = 1, N_CFT)/) - lndname = trim(dir_model_landdata) // '/diag/pct_crops_patch_' // trim(cyear) // '.nc' - CALL srfdata_map_and_write (pctcrop, cropclass, typcrop, m_patch2diag, & - -1.0e36_r8, lndname, 'pctcrop', compress = 1, write_mode = 'one') + lndname = trim(dir_model_landdata) // '/diag/pct_crop_patch_' // trim(cyear) // '.nc' + CALL srfdata_map_and_write (pctshrpch, cropclass, typcrop, m_patch2diag, & + -1.0e36_r8, lndname, 'pct_crop_patch', compress = 1, write_mode = 'one') #endif #else allocate (SITE_croptyp(numpatch)) allocate (SITE_pctcrop(numpatch)) SITE_croptyp = cropclass - SITE_pctcrop = pctcrop + SITE_pctcrop = pctshrpch #endif #endif #endif -#ifdef LULC_IGBP_PC - -#ifdef SinglePoint - IF (USE_SITE_pctpfts) THEN - RETURN - ENDIF -#endif - - dir_5x5 = trim(dir_rawdata) // '/plant_15s' - suffix = 'MOD'//trim(cyear) - - IF (p_is_io) THEN - CALL allocate_block_data (gland, pftPCT, N_PFT_modis, lb1 = 0) - CALL read_5x5_data_pft (dir_5x5, suffix, gland, 'PCT_PFT', pftPCT) -#ifdef USEMPI - CALL aggregation_data_daemon (gland, data_r8_3d_in1 = pftPCT, n1_r8_3d_in1 = N_PFT_modis) -#endif - ENDIF - - IF (p_is_worker) THEN - allocate(pct_pcs (0:N_PFT-1, numpc)) - - DO ipatch = 1, numpatch - - IF (patchtypes(landpatch%settyp(ipatch)) == 0) THEN - CALL aggregation_request_data (landpatch, ipatch, gland, area = area_one, & - data_r8_3d_in1 = pftPCT, data_r8_3d_out1 = pct_pft_one, n1_r8_3d_in1 = N_PFT_modis, lb1_r8_3d_in1 = 0) - - pct_pft_one = max(pct_pft_one, 0.) - - pct_one = sum(pct_pft_one, dim=1) - pct_one = max(pct_one, 1.0e-6) - - ipc = patch2pc(ipatch) - DO ipft = 0, N_PFT-1 - sumarea = sum(area_one) - pct_pcs(ipft,ipc) = sum(pct_pft_one(ipft,:) / pct_one * area_one) / sumarea - ENDDO - ENDIF - ENDDO - -#ifdef USEMPI - CALL aggregation_worker_done () -#endif - ENDIF - -#ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) -#endif - -#ifdef RangeCheck - CALL check_vector_data ('PCT_PCs ', pct_pcs) -#endif - -#ifndef SinglePoint - lndname = trim(landdir)//'/pct_pcs.nc' - CALL ncio_create_file_vector (lndname, landpatch) - CALL ncio_define_dimension_vector (lndname, landpc, 'pc') - CALL ncio_define_dimension_vector (lndname, landpc, 'pft', N_PFT) - CALL ncio_write_vector (lndname, 'pct_pcs', 'pft', N_PFT, 'pc', landpc, pct_pcs, 1) -#else - allocate (SITE_pctpfts (N_PFT)) - SITE_pctpfts = pct_pcs(:,1) -#endif - - IF (p_is_worker) THEN - IF (allocated(pct_pcs )) deallocate(pct_pcs ) - IF (allocated(pct_one )) deallocate(pct_one ) - IF (allocated(area_one )) deallocate(area_one ) - IF (allocated(pct_pft_one)) deallocate(pct_pft_one) - ENDIF - -#endif - END SUBROUTINE Aggregation_PercentagesPFT diff --git a/mksrfdata/Aggregation_SoilBrightness.F90 b/mksrfdata/Aggregation_SoilBrightness.F90 index 3be4b270..7e056bbe 100644 --- a/mksrfdata/Aggregation_SoilBrightness.F90 +++ b/mksrfdata/Aggregation_SoilBrightness.F90 @@ -166,7 +166,7 @@ SUBROUTINE Aggregation_SoilBrightness ( & #else IF(L/=17 .and. L/=15)THEN ! NOT OCEAN(0)/WATER BODIES(17)/GLACIER and ICE SHEET(15) #endif - CALL aggregation_request_data (landpatch, ipatch, gland, & + CALL aggregation_request_data (landpatch, ipatch, gland, zip = USE_zip_for_aggregation, & data_r8_2d_in1 = a_s_v_refl, data_r8_2d_out1 = soil_one) soil_s_v_alb (ipatch) = median (soil_one, size(soil_one)) @@ -202,7 +202,7 @@ SUBROUTINE Aggregation_SoilBrightness ( & #else IF(L/=17 .and. L/=15)THEN ! NOT OCEAN(0)/WATER BODIES(17)/GLACIER and ICE SHEET(15) #endif - CALL aggregation_request_data (landpatch, ipatch, gland, & + CALL aggregation_request_data (landpatch, ipatch, gland, zip = USE_zip_for_aggregation, & data_r8_2d_in1 = a_d_v_refl, data_r8_2d_out1 = soil_one) soil_d_v_alb (ipatch) = median (soil_one, size(soil_one)) @@ -238,7 +238,7 @@ SUBROUTINE Aggregation_SoilBrightness ( & #else IF(L/=17 .and. L/=15)THEN ! NOT OCEAN(0)/WATER BODIES(17)/GLACIER and ICE SHEET(15) #endif - CALL aggregation_request_data (landpatch, ipatch, gland, & + CALL aggregation_request_data (landpatch, ipatch, gland, zip = USE_zip_for_aggregation, & data_r8_2d_in1 = a_s_n_refl, data_r8_2d_out1 = soil_one) soil_s_n_alb (ipatch) = median (soil_one, size(soil_one)) @@ -274,7 +274,7 @@ SUBROUTINE Aggregation_SoilBrightness ( & #else IF(L/=17 .and. L/=15)THEN ! NOT OCEAN(0)/WATER BODIES(17)/GLACIER and ICE SHEET(15) #endif - CALL aggregation_request_data (landpatch, ipatch, gland, & + CALL aggregation_request_data (landpatch, ipatch, gland, zip = USE_zip_for_aggregation, & data_r8_2d_in1 = a_d_n_refl, data_r8_2d_out1 = soil_one) soil_d_n_alb (ipatch) = median (soil_one, size(soil_one)) diff --git a/mksrfdata/Aggregation_SoilParameters.F90 b/mksrfdata/Aggregation_SoilParameters.F90 index c0783f9d..f5dca060 100644 --- a/mksrfdata/Aggregation_SoilParameters.F90 +++ b/mksrfdata/Aggregation_SoilParameters.F90 @@ -52,7 +52,7 @@ SUBROUTINE Aggregation_SoilParameters ( & ! local variables: ! --------------------------------------------------------------- - CHARACTER(len=256) :: landdir, lndname, cyear, soildir + CHARACTER(len=256) :: landdir, lndname, cyear CHARACTER(len=256) :: c INTEGER :: nsl, ipatch, L, np, LL, ipxstt, ipxend @@ -174,12 +174,6 @@ SUBROUTINE Aggregation_SoilParameters ( & external SW_VG_dist ! the objective function to be fitted for van Genuchten SW retention curve ! external Ke_Sr_dist ! the objective function to be fitted for Balland and Arp (2005) Ke-Sr relationship -#ifdef LULC_USGS - soildir = '/soil_USGS/' -#else - soildir = '/soil_IGBP/' -#endif - write(cyear,'(i4.4)') lc_year landdir = trim(dir_model_landdata) // '/soil/' // trim(cyear) @@ -267,7 +261,7 @@ SUBROUTINE Aggregation_SoilParameters ( & IF (p_is_io) THEN CALL allocate_block_data (gland, vf_quartz_mineral_s_grid) - lndname = trim(dir_rawdata)//trim(soildir)//'vf_quartz_mineral_s.nc' + lndname = trim(dir_rawdata)//'/soil/vf_quartz_mineral_s.nc' CALL ncio_read_block (lndname, 'vf_quartz_mineral_s_l'//trim(c), gland, vf_quartz_mineral_s_grid) #ifdef USEMPI CALL aggregation_data_daemon (gland, data_r8_2d_in1 = vf_quartz_mineral_s_grid) @@ -280,7 +274,7 @@ SUBROUTINE Aggregation_SoilParameters ( & L = landpatch%settyp(ipatch) IF (L /= 0) THEN - CALL aggregation_request_data (landpatch, ipatch, gland, area = area_one, & + CALL aggregation_request_data (landpatch, ipatch, gland, zip = USE_zip_for_aggregation, area = area_one, & data_r8_2d_in1 = vf_quartz_mineral_s_grid, data_r8_2d_out1 = vf_quartz_mineral_s_one) vf_quartz_mineral_s_patches (ipatch) = sum (vf_quartz_mineral_s_one * (area_one/sum(area_one))) ELSE @@ -331,15 +325,15 @@ SUBROUTINE Aggregation_SoilParameters ( & IF (p_is_io) THEN CALL allocate_block_data (gland, vf_gravels_s_grid) - lndname = trim(dir_rawdata)//trim(soildir)//'vf_gravels_s.nc' + lndname = trim(dir_rawdata)//'/soil/vf_gravels_s.nc' CALL ncio_read_block (lndname, 'vf_gravels_s_l'//trim(c), gland, vf_gravels_s_grid) CALL allocate_block_data (gland, vf_sand_s_grid) - lndname = trim(dir_rawdata)//trim(soildir)//'vf_sand_s.nc' + lndname = trim(dir_rawdata)//'/soil/vf_sand_s.nc' CALL ncio_read_block (lndname, 'vf_sand_s_l'//trim(c), gland, vf_sand_s_grid) CALL allocate_block_data (gland, vf_om_s_grid) - lndname = trim(dir_rawdata)//trim(soildir)//'vf_om_s.nc' + lndname = trim(dir_rawdata)//'/soil/vf_om_s.nc' CALL ncio_read_block (lndname, 'vf_om_s_l'//trim(c), gland, vf_om_s_grid) #ifdef USEMPI @@ -354,7 +348,7 @@ SUBROUTINE Aggregation_SoilParameters ( & L = landpatch%settyp(ipatch) IF (L /= 0) THEN - CALL aggregation_request_data (landpatch, ipatch, gland, area = area_one, & + CALL aggregation_request_data (landpatch, ipatch, gland, zip = USE_zip_for_aggregation, area = area_one, & data_r8_2d_in1 = vf_gravels_s_grid, data_r8_2d_out1 = vf_gravels_s_one, & data_r8_2d_in2 = vf_sand_s_grid, data_r8_2d_out2 = vf_sand_s_one, & data_r8_2d_in3 = vf_om_s_grid, data_r8_2d_out3 = vf_om_s_one) @@ -366,11 +360,8 @@ SUBROUTINE Aggregation_SoilParameters ( & ! the parameter values of Balland and Arp (2005) Ke-Sr relationship, ! modified by Barry-Macaulay et al.(2015), Evaluation of soil thermal conductivity models - ipxstt = landpatch%ipxstt(ipatch) - ipxend = landpatch%ipxend(ipatch) - - allocate(BA_alpha_one (ipxstt:ipxend)) - allocate(BA_beta_one (ipxstt:ipxend)) + allocate(BA_alpha_one (size(area_one))) + allocate(BA_beta_one (size(area_one))) where ((vf_gravels_s_one + vf_sand_s_one) > 0.4) BA_alpha_one = 0.38 BA_beta_one = 35.0 @@ -562,7 +553,7 @@ SUBROUTINE Aggregation_SoilParameters ( & IF (p_is_io) THEN CALL allocate_block_data (gland, wf_gravels_s_grid) - lndname = trim(dir_rawdata)//trim(soildir)//'wf_gravels_s.nc' + lndname = trim(dir_rawdata)//'/soil/wf_gravels_s.nc' CALL ncio_read_block (lndname, 'wf_gravels_s_l'//trim(c), gland, wf_gravels_s_grid) #ifdef USEMPI CALL aggregation_data_daemon (gland, data_r8_2d_in1 = wf_gravels_s_grid) @@ -575,7 +566,7 @@ SUBROUTINE Aggregation_SoilParameters ( & L = landpatch%settyp(ipatch) IF (L /= 0) THEN - CALL aggregation_request_data (landpatch, ipatch, gland, area = area_one, & + CALL aggregation_request_data (landpatch, ipatch, gland, zip = USE_zip_for_aggregation, area = area_one, & data_r8_2d_in1 = wf_gravels_s_grid, data_r8_2d_out1 = wf_gravels_s_one) wf_gravels_s_patches (ipatch) = sum (wf_gravels_s_one * (area_one/sum(area_one))) ELSE @@ -624,7 +615,7 @@ SUBROUTINE Aggregation_SoilParameters ( & IF (p_is_io) THEN CALL allocate_block_data (gland, wf_sand_s_grid) - lndname = trim(dir_rawdata)//trim(soildir)//'wf_sand_s.nc' + lndname = trim(dir_rawdata)//'/soil/wf_sand_s.nc' CALL ncio_read_block (lndname, 'wf_sand_s_l'//trim(c), gland, wf_sand_s_grid) #ifdef USEMPI CALL aggregation_data_daemon (gland, data_r8_2d_in1 = wf_sand_s_grid) @@ -637,7 +628,7 @@ SUBROUTINE Aggregation_SoilParameters ( & L = landpatch%settyp(ipatch) IF (L /= 0) THEN - CALL aggregation_request_data (landpatch, ipatch, gland, area = area_one, & + CALL aggregation_request_data (landpatch, ipatch, gland, zip = USE_zip_for_aggregation, area = area_one, & data_r8_2d_in1 = wf_sand_s_grid, data_r8_2d_out1 = wf_sand_s_one) wf_sand_s_patches (ipatch) = sum (wf_sand_s_one * (area_one/sum(area_one))) ELSE @@ -687,7 +678,7 @@ SUBROUTINE Aggregation_SoilParameters ( & IF (p_is_io) THEN CALL allocate_block_data (gland, L_vgm_grid) - lndname = trim(dir_rawdata)//trim(soildir)//'VGM_L.nc' + lndname = trim(dir_rawdata)//'/soil/VGM_L.nc' CALL ncio_read_block (lndname, 'VGM_L_l'//trim(c), gland, L_vgm_grid) #ifdef USEMPI CALL aggregation_data_daemon (gland, data_r8_2d_in1 = L_vgm_grid) @@ -700,7 +691,7 @@ SUBROUTINE Aggregation_SoilParameters ( & L = landpatch%settyp(ipatch) IF (L /= 0) THEN - CALL aggregation_request_data (landpatch, ipatch, gland, & + CALL aggregation_request_data (landpatch, ipatch, gland, zip = USE_zip_for_aggregation, & data_r8_2d_in1 = L_vgm_grid, data_r8_2d_out1 = L_vgm_one) L_vgm_patches (ipatch) = median (L_vgm_one, size(L_vgm_one), spval) ELSE @@ -752,19 +743,19 @@ SUBROUTINE Aggregation_SoilParameters ( & IF (p_is_io) THEN CALL allocate_block_data (gland, theta_r_grid) - lndname = trim(dir_rawdata)//trim(soildir)//'VGM_theta_r.nc' + lndname = trim(dir_rawdata)//'/soil/VGM_theta_r.nc' CALL ncio_read_block (lndname, 'VGM_theta_r_l'//trim(c), gland, theta_r_grid) CALL allocate_block_data (gland, alpha_vgm_grid) - lndname = trim(dir_rawdata)//trim(soildir)//'VGM_alpha.nc' + lndname = trim(dir_rawdata)//'/soil/VGM_alpha.nc' CALL ncio_read_block (lndname, 'VGM_alpha_l'//trim(c), gland, alpha_vgm_grid) CALL allocate_block_data (gland, n_vgm_grid) - lndname = trim(dir_rawdata)//trim(soildir)//'VGM_n.nc' + lndname = trim(dir_rawdata)//'/soil/VGM_n.nc' CALL ncio_read_block (lndname, 'VGM_n_l'//trim(c), gland, n_vgm_grid) CALL allocate_block_data (gland, theta_s_grid) - lndname = trim(dir_rawdata)//trim(soildir)//'theta_s.nc' + lndname = trim(dir_rawdata)//'/soil/theta_s.nc' CALL ncio_read_block (lndname, 'theta_s_l'//trim(c), gland, theta_s_grid) #ifdef USEMPI @@ -780,30 +771,28 @@ SUBROUTINE Aggregation_SoilParameters ( & L = landpatch%settyp(ipatch) IF (L /= 0) THEN - CALL aggregation_request_data (landpatch, ipatch, gland, area = area_one, & + CALL aggregation_request_data (landpatch, ipatch, gland, zip = USE_zip_for_aggregation, area = area_one, & data_r8_2d_in1 = theta_r_grid, data_r8_2d_out1 = theta_r_one, & data_r8_2d_in2 = alpha_vgm_grid, data_r8_2d_out2 = alpha_vgm_one, & data_r8_2d_in3 = n_vgm_grid, data_r8_2d_out3 = n_vgm_one, & data_r8_2d_in4 = theta_s_grid, data_r8_2d_out4 = theta_s_one) - theta_r_patches (ipatch) = median (theta_r_one, size(theta_r_one), spval) + theta_r_patches (ipatch) = sum (theta_r_one * (area_one/sum(area_one))) alpha_vgm_patches (ipatch) = median (alpha_vgm_one, size(alpha_vgm_one), spval) n_vgm_patches (ipatch) = median (n_vgm_one, size(n_vgm_one), spval) theta_s_patches (ipatch) = sum (theta_s_one * (area_one/sum(area_one))) IF (DEF_USE_SOILPAR_UPS_FIT) THEN np = size(theta_r_one) - ipxstt = landpatch%ipxstt(ipatch) - ipxend = landpatch%ipxend(ipatch) IF( np > 1 ) then - allocate ( ydatv (ipxstt:ipxend,npointw) ) + allocate ( ydatv (1:np,npointw) ) ! the jacobian matrix required in Levenberg–Marquardt fitting method allocate ( fjacv (npointw,nv) ) ! calculated in SW_VG_dist ! the values of objective functions to be fitted allocate ( fvecv (npointw) ) ! calculated in SW_VG_dist ! SW VG retentions at fine grids for each patch - do LL = ipxstt,ipxend + do LL = 1,np ydatv(LL,:) = theta_r_one(LL)+(theta_s_one(LL) - theta_r_one(LL)) & * (1+(alpha_vgm_one(LL)*xdat)**n_vgm_one(LL))**(1.0/n_vgm_one(LL)-1) end do @@ -952,15 +941,15 @@ SUBROUTINE Aggregation_SoilParameters ( & IF (p_is_io) THEN CALL allocate_block_data (gland, theta_s_grid) - lndname = trim(dir_rawdata)//trim(soildir)//'theta_s.nc' + lndname = trim(dir_rawdata)//'/soil/theta_s.nc' CALL ncio_read_block (lndname, 'theta_s_l'//trim(c), gland, theta_s_grid) CALL allocate_block_data (gland, psi_s_grid) - lndname = trim(dir_rawdata)//trim(soildir)//'psi_s.nc' + lndname = trim(dir_rawdata)//'/soil/psi_s.nc' CALL ncio_read_block (lndname, 'psi_s_l'//trim(c), gland, psi_s_grid) CALL allocate_block_data (gland, lambda_grid) - lndname = trim(dir_rawdata)//trim(soildir)//'lambda.nc' + lndname = trim(dir_rawdata)//'/soil/lambda.nc' CALL ncio_read_block (lndname, 'lambda_l'//trim(c), gland, lambda_grid) #ifdef USEMPI @@ -975,7 +964,7 @@ SUBROUTINE Aggregation_SoilParameters ( & L = landpatch%settyp(ipatch) IF (L /= 0) THEN - CALL aggregation_request_data (landpatch, ipatch, gland, area = area_one, & + CALL aggregation_request_data (landpatch, ipatch, gland, zip = USE_zip_for_aggregation, area = area_one, & data_r8_2d_in1 = theta_s_grid, data_r8_2d_out1 = theta_s_one, & data_r8_2d_in2 = psi_s_grid, data_r8_2d_out2 = psi_s_one, & data_r8_2d_in3 = lambda_grid, data_r8_2d_out3 = lambda_one) @@ -985,18 +974,16 @@ SUBROUTINE Aggregation_SoilParameters ( & IF (DEF_USE_SOILPAR_UPS_FIT) THEN np = size(psi_s_one) - ipxstt = landpatch%ipxstt(ipatch) - ipxend = landpatch%ipxend(ipatch) IF( np > 1 ) then - allocate ( ydatc (ipxstt:ipxend,npointw) ) + allocate ( ydatc (1:np,npointw) ) ! the jacobian matrix required in Levenberg–Marquardt fitting method allocate ( fjacc (npointw,nc) ) ! calculated in SW_CB_dist ! the values of objective functions to be fitted allocate ( fvecc (npointw) ) ! calculated in SW_CB_dist ! SW CB retentions at fine grids for each patch - do LL = ipxstt,ipxend + do LL = 1,np ydatc(LL,:) = (-1.0*xdat/psi_s_one(LL))**(-1.0*lambda_one(LL)) * theta_s_one(LL) end do @@ -1114,7 +1101,7 @@ SUBROUTINE Aggregation_SoilParameters ( & ! (14) saturated hydraulic conductivity [cm/day] IF (p_is_io) THEN CALL allocate_block_data (gland, k_s_grid) - lndname = trim(dir_rawdata)//trim(soildir)//'k_s.nc' + lndname = trim(dir_rawdata)//'/soil/k_s.nc' CALL ncio_read_block (lndname, 'k_s_l'//trim(c), gland, k_s_grid) #ifdef USEMPI CALL aggregation_data_daemon (gland, data_r8_2d_in1 = k_s_grid) @@ -1127,7 +1114,7 @@ SUBROUTINE Aggregation_SoilParameters ( & L = landpatch%settyp(ipatch) IF (L /= 0) THEN - CALL aggregation_request_data (landpatch, ipatch, gland, area = area_one, & + CALL aggregation_request_data (landpatch, ipatch, gland, zip = USE_zip_for_aggregation, area = area_one, & data_r8_2d_in1 = k_s_grid, data_r8_2d_out1 = k_s_one) k_s_patches (ipatch) = product(k_s_one**(area_one/sum(area_one))) ELSE @@ -1173,7 +1160,7 @@ SUBROUTINE Aggregation_SoilParameters ( & ! (15) heat capacity of soil solids [J/(m3 K)] IF (p_is_io) THEN CALL allocate_block_data (gland, csol_grid) - lndname = trim(dir_rawdata)//trim(soildir)//'csol.nc' + lndname = trim(dir_rawdata)//'/soil/csol.nc' CALL ncio_read_block (lndname, 'csol_l'//trim(c), gland, csol_grid) #ifdef USEMPI CALL aggregation_data_daemon (gland, data_r8_2d_in1 = csol_grid) @@ -1186,7 +1173,7 @@ SUBROUTINE Aggregation_SoilParameters ( & L = landpatch%settyp(ipatch) IF (L /= 0) THEN - CALL aggregation_request_data (landpatch, ipatch, gland, area = area_one, & + CALL aggregation_request_data (landpatch, ipatch, gland, zip = USE_zip_for_aggregation, area = area_one, & data_r8_2d_in1 = csol_grid, data_r8_2d_out1 = csol_one) csol_patches (ipatch) = sum(csol_one*(area_one/sum(area_one))) ELSE @@ -1232,7 +1219,7 @@ SUBROUTINE Aggregation_SoilParameters ( & ! (16) thermal conductivity of unfrozen saturated soil [W/m-K] IF (p_is_io) THEN CALL allocate_block_data (gland, tksatu_grid) - lndname = trim(dir_rawdata)//trim(soildir)//'tksatu.nc' + lndname = trim(dir_rawdata)//'/soil/tksatu.nc' CALL ncio_read_block (lndname, 'tksatu_l'//trim(c), gland, tksatu_grid) #ifdef USEMPI CALL aggregation_data_daemon (gland, data_r8_2d_in1 = tksatu_grid) @@ -1245,7 +1232,7 @@ SUBROUTINE Aggregation_SoilParameters ( & L = landpatch%settyp(ipatch) IF (L /= 0) THEN - CALL aggregation_request_data (landpatch, ipatch, gland, area = area_one, & + CALL aggregation_request_data (landpatch, ipatch, gland, zip = USE_zip_for_aggregation, area = area_one, & data_r8_2d_in1 = tksatu_grid, data_r8_2d_out1 = tksatu_one) tksatu_patches (ipatch) = product(tksatu_one**(area_one/sum(area_one))) ELSE @@ -1291,7 +1278,7 @@ SUBROUTINE Aggregation_SoilParameters ( & ! (17) thermal conductivity of frozen saturated soil [W/m-K] IF (p_is_io) THEN CALL allocate_block_data (gland, tksatf_grid) - lndname = trim(dir_rawdata)//trim(soildir)//'tksatf.nc' + lndname = trim(dir_rawdata)//'/soil/tksatf.nc' CALL ncio_read_block (lndname, 'tksatf_l'//trim(c), gland, tksatf_grid) #ifdef USEMPI CALL aggregation_data_daemon (gland, data_r8_2d_in1 = tksatf_grid) @@ -1304,7 +1291,7 @@ SUBROUTINE Aggregation_SoilParameters ( & L = landpatch%settyp(ipatch) IF (L /= 0) THEN - CALL aggregation_request_data (landpatch, ipatch, gland, area = area_one, & + CALL aggregation_request_data (landpatch, ipatch, gland, zip = USE_zip_for_aggregation, area = area_one, & data_r8_2d_in1 = tksatf_grid, data_r8_2d_out1 = tksatf_one) tksatf_patches (ipatch) = product(tksatf_one**(area_one/sum(area_one))) ELSE @@ -1350,7 +1337,7 @@ SUBROUTINE Aggregation_SoilParameters ( & ! (18) thermal conductivity for dry soil [W/(m-K)] IF (p_is_io) THEN CALL allocate_block_data (gland, tkdry_grid) - lndname = trim(dir_rawdata)//trim(soildir)//'tkdry.nc' + lndname = trim(dir_rawdata)//'/soil/tkdry.nc' CALL ncio_read_block (lndname, 'tkdry_l'//trim(c), gland, tkdry_grid) #ifdef USEMPI CALL aggregation_data_daemon (gland, data_r8_2d_in1 = tkdry_grid) @@ -1363,7 +1350,7 @@ SUBROUTINE Aggregation_SoilParameters ( & L = landpatch%settyp(ipatch) IF (L /= 0) THEN - CALL aggregation_request_data (landpatch, ipatch, gland, area = area_one, & + CALL aggregation_request_data (landpatch, ipatch, gland, zip = USE_zip_for_aggregation, area = area_one, & data_r8_2d_in1 = tkdry_grid, data_r8_2d_out1 = tkdry_one) tkdry_patches (ipatch) = product(tkdry_one**(area_one/sum(area_one))) ELSE @@ -1409,7 +1396,7 @@ SUBROUTINE Aggregation_SoilParameters ( & ! (19) thermal conductivity of soil solids [W/m-K] IF (p_is_io) THEN CALL allocate_block_data (gland, k_solids_grid) - lndname = trim(dir_rawdata)//trim(soildir)//'k_solids.nc' + lndname = trim(dir_rawdata)//'/soil/k_solids.nc' CALL ncio_read_block (lndname, 'k_solids_l'//trim(c), gland, k_solids_grid) #ifdef USEMPI CALL aggregation_data_daemon (gland, data_r8_2d_in1 = k_solids_grid) @@ -1422,7 +1409,7 @@ SUBROUTINE Aggregation_SoilParameters ( & L = landpatch%settyp(ipatch) IF (L /= 0) THEN - CALL aggregation_request_data (landpatch, ipatch, gland, area = area_one, & + CALL aggregation_request_data (landpatch, ipatch, gland, zip = USE_zip_for_aggregation, area = area_one, & data_r8_2d_in1 = k_solids_grid, data_r8_2d_out1 = k_solids_one) k_solids_patches (ipatch) = product(k_solids_one**(area_one/sum(area_one))) ELSE @@ -1469,7 +1456,7 @@ SUBROUTINE Aggregation_SoilParameters ( & IF (p_is_io) THEN CALL allocate_block_data (gland, OM_density_s_grid) - lndname = trim(dir_rawdata)//trim(soildir)//'OM_density_s.nc' + lndname = trim(dir_rawdata)//'/soil/OM_density_s.nc' CALL ncio_read_block (lndname, 'OM_density_s_l'//trim(c), gland, OM_density_s_grid) #ifdef USEMPI CALL aggregation_data_daemon (gland, data_r8_2d_in1 = OM_density_s_grid) @@ -1482,7 +1469,7 @@ SUBROUTINE Aggregation_SoilParameters ( & L = landpatch%settyp(ipatch) IF (L /= 0) THEN - CALL aggregation_request_data (landpatch, ipatch, gland, area = area_one, & + CALL aggregation_request_data (landpatch, ipatch, gland, zip = USE_zip_for_aggregation, area = area_one, & data_r8_2d_in1 = OM_density_s_grid, data_r8_2d_out1 = OM_density_s_one) OM_density_s_patches (ipatch) = sum (OM_density_s_one * (area_one/sum(area_one))) ELSE @@ -1530,7 +1517,7 @@ SUBROUTINE Aggregation_SoilParameters ( & IF (p_is_io) THEN CALL allocate_block_data (gland, BD_all_s_grid) - lndname = trim(dir_rawdata)//trim(soildir)//'BD_all_s.nc' + lndname = trim(dir_rawdata)//'/soil/BD_all_s.nc' CALL ncio_read_block (lndname, 'BD_all_s_l'//trim(c), gland, BD_all_s_grid) #ifdef USEMPI CALL aggregation_data_daemon (gland, data_r8_2d_in1 = BD_all_s_grid) @@ -1543,7 +1530,7 @@ SUBROUTINE Aggregation_SoilParameters ( & L = landpatch%settyp(ipatch) IF (L /= 0) THEN - CALL aggregation_request_data (landpatch, ipatch, gland, area = area_one, & + CALL aggregation_request_data (landpatch, ipatch, gland, zip = USE_zip_for_aggregation, area = area_one, & data_r8_2d_in1 = BD_all_s_grid, data_r8_2d_out1 = BD_all_s_one) BD_all_s_patches (ipatch) = sum (BD_all_s_one * (area_one/sum(area_one))) ELSE @@ -1763,7 +1750,7 @@ subroutine SW_CB_dist ( m, n, x, fvec, fjac, ldfjac, iflag, xdat, npoint, ydatc, end subroutine SW_CB_dist -subroutine SW_VG_dist ( m, n, x, fvec, fjac, ldfjac, iflag, xdat, npoint, ydatv, nptf, phi, isiter ) +subroutine SW_VG_dist ( m, n, x, fvec, fjac, ldfjac, iflag, xdat, npoint, ydatv, nptf, phi, isiter) !================================================================= ! DESCRIPTION: diff --git a/mksrfdata/Aggregation_Topography.F90 b/mksrfdata/Aggregation_Topography.F90 index 3280f9f9..3345aa85 100644 --- a/mksrfdata/Aggregation_Topography.F90 +++ b/mksrfdata/Aggregation_Topography.F90 @@ -26,6 +26,8 @@ SUBROUTINE Aggregation_Topography ( & USE MOD_Utils #ifdef SrfdataDiag + USE MOD_Mesh, only : numelm + USE MOD_LandElm USE MOD_SrfdataDiag #endif @@ -39,10 +41,10 @@ SUBROUTINE Aggregation_Topography ( & ! local variables: ! --------------------------------------------------------------- CHARACTER(len=256) :: landdir, lndname, cyear - INTEGER :: ipatch + INTEGER :: ipatch, i, ps, pe TYPE (block_data_real8_2d) :: topography - REAL(r8), allocatable :: topography_patches(:) + REAL(r8), allocatable :: topography_patches(:), topo_elm(:) REAL(r8), allocatable :: topography_one(:), area_one(:) #ifdef SrfdataDiag INTEGER :: typpatch(N_land_classification+1), ityp @@ -87,7 +89,7 @@ SUBROUTINE Aggregation_Topography ( & allocate (topography_patches (numpatch)) DO ipatch = 1, numpatch - CALL aggregation_request_data (landpatch, ipatch, gtopo, area = area_one, & + CALL aggregation_request_data (landpatch, ipatch, gtopo, zip = USE_zip_for_aggregation, area = area_one, & data_r8_2d_in1 = topography, data_r8_2d_out1 = topography_one) IF (any(topography_one /= -9999.0)) THEN topography_patches (ipatch) = & @@ -121,7 +123,22 @@ SUBROUTINE Aggregation_Topography ( & typpatch = (/(ityp, ityp = 0, N_land_classification)/) lndname = trim(dir_model_landdata) // '/diag/topo_' // trim(cyear) // '.nc' CALL srfdata_map_and_write (topography_patches, landpatch%settyp, typpatch, m_patch2diag, & - -1.0e36_r8, lndname, 'topography', compress = 0, write_mode = 'one') + -1.0e36_r8, lndname, 'topography', compress = 1, write_mode = 'one') + + IF (p_is_worker) THEN + allocate(topo_elm(numelm)) + DO i = 1, numelm + ps = elm_patch%substt(i) + pe = elm_patch%subend(i) + topo_elm(i) = sum(topography_patches(ps:pe) * elm_patch%subfrc(ps:pe)) + ENDDO + ENDIF + + lndname = trim(dir_model_landdata) // '/diag/topo_elm_' // trim(cyear) // '.nc' + CALL srfdata_map_and_write (topo_elm, landelm%settyp, (/0/), m_elm2diag, & + -1.0e36_r8, lndname, 'topo_elm', compress = 1, write_mode = 'one') + + IF (allocated(topo_elm)) deallocate(topo_elm) #endif #else SITE_topography = topography_patches(1) diff --git a/mksrfdata/Aggregation_Urban.F90 b/mksrfdata/Aggregation_Urban.F90 index d9da74fa..79b83a2c 100644 --- a/mksrfdata/Aggregation_Urban.F90 +++ b/mksrfdata/Aggregation_Urban.F90 @@ -25,12 +25,13 @@ SUBROUTINE Aggregation_Urban (dir_rawdata, dir_srfdata, lc_year, & USE MOD_Utils, only: num_max_frequency USE MOD_LandUrban USE MOD_Vars_Global, only: N_URB -#ifdef URBAN_LCZ USE MOD_Urban_Const_LCZ, only: wtroof_lcz, htroof_lcz -#endif #ifdef SinglePoint USE MOD_SingleSrfdata #endif +#ifdef RangeCheck + USE MOD_RangeCheck +#endif #ifdef SrfdataDiag USE MOD_SrfdataDiag #endif @@ -88,7 +89,6 @@ SUBROUTINE Aggregation_Urban (dir_rawdata, dir_srfdata, lc_year, & REAL(r8), allocatable, dimension(:) :: ulai_one REAL(r8), allocatable, dimension(:) :: slai_one -#ifndef URBAN_LCZ ! urban morphological and thermal paras of NCAR data ! input variables, look-up-table data REAL(r8), allocatable, DIMENSION(:,:) :: hwrcan, wtrd, emroof, emwall, ncar_wt @@ -129,24 +129,25 @@ SUBROUTINE Aggregation_Urban (dir_rawdata, dir_srfdata, lc_year, & REAL(r8), ALLOCATABLE, DIMENSION(:,:,:) :: alb_wall REAL(r8), ALLOCATABLE, DIMENSION(:,:,:) :: alb_imrd REAL(r8), ALLOCATABLE, DIMENSION(:,:,:) :: alb_perd -#endif ! landfile variables CHARACTER(len=256) landsrfdir, landdir, landname, suffix - CHARACTER(len=4) cyear, c5year, cmonth, clay + CHARACTER(len=4) cyear, c5year, cmonth, clay, c1, iyear ! local vars REAL(r8) :: sumarea ! index - INTEGER :: iurban, urb_typidx, urb_regidx - INTEGER :: pop_i, imonth, start_year, end_year - INTEGER :: ipxstt, ipxend, ipxl, il, iy + INTEGER :: iurban, urb_typidx, urb_regidx + INTEGER :: pop_i, imonth, start_year, end_year + INTEGER :: ipxstt, ipxend, ipxl, il, iy ! for surface data diag #ifdef SrfdataDiag INTEGER :: ityp - INTEGER :: typindex(N_URB) + INTEGER, allocatable, dimension(:) :: typindex + + allocate( typindex(N_URB) ) #endif write(cyear,'(i4.4)') lc_year @@ -171,7 +172,7 @@ SUBROUTINE Aggregation_Urban (dir_rawdata, dir_srfdata, lc_year, & landname = TRIM(dir_rawdata)//'urban/LUCY_countryid.nc' CALL allocate_block_data (grid_urban_5km, LUCY_reg) - CALL ncio_read_block (landname, 'Country_id', grid_urban_5km, LUCY_reg) + CALL ncio_read_block (landname, 'LUCY_COUNTRY_ID', grid_urban_5km, LUCY_reg) #ifdef USEMPI CALL aggregation_data_daemon (grid_urban_5km, data_i4_2d_in1 = LUCY_reg) @@ -187,7 +188,8 @@ SUBROUTINE Aggregation_Urban (dir_rawdata, dir_srfdata, lc_year, & ! loop for each urban patch to get the LUCY id of all fine grid ! of iurban patch, then assign the most frequence id to this urban patch DO iurban = 1, numurban - CALL aggregation_request_data (landurban, iurban, grid_urban_5km, & + + CALL aggregation_request_data (landurban, iurban, grid_urban_5km, zip = USE_zip_for_aggregation, & data_i4_2d_in1 = LUCY_reg, data_i4_2d_out1 = LUCY_reg_one) ! the most frequence id to this urban patch LUCY_coun(iurban) = num_max_frequency (LUCY_reg_one) @@ -197,6 +199,7 @@ SUBROUTINE Aggregation_Urban (dir_rawdata, dir_srfdata, lc_year, & #endif ENDIF +#ifndef SinglePoint ! output landname = trim(landsrfdir)//'/LUCY_country_id.nc' CALL ncio_create_file_vector (landname, landurban) @@ -209,11 +212,19 @@ SUBROUTINE Aggregation_Urban (dir_rawdata, dir_srfdata, lc_year, & ! CALL srfdata_map_and_write (LUCY_coun*1.0, landurban%settyp, typindex, m_urb2diag, & ! -1.0e36_r8, landname, 'LUCY_id_'//trim(cyear), compress = 0, write_mode = 'one') #endif +#else + SITE_lucyid(:) = LUCY_coun +#endif + #ifdef USEMPI CALL mpi_barrier (p_comm_glb, p_err) #endif +#ifdef RangeCheck + CALL check_vector_data ('LUCY_ID ', LUCY_coun) +#endif + ! ******* POP_DEN ******* ! allocate and read the grided population raw data(500m) ! NOTE, the population is year-by-year @@ -222,7 +233,7 @@ SUBROUTINE Aggregation_Urban (dir_rawdata, dir_srfdata, lc_year, & CALL allocate_block_data (grid_urban_500m, pop) landdir = TRIM(dir_rawdata)//'/urban/' - suffix = 'URB'//trim(c5year) + suffix = 'URBSRF'//trim(c5year) ! populaiton data is year by year, ! so pop_i is calculated to determine the dimension of POP data reads @@ -233,7 +244,7 @@ SUBROUTINE Aggregation_Urban (dir_rawdata, dir_srfdata, lc_year, & ENDIF ! read the population data of total 5x5 region - CALL read_5x5_data_time (landdir, suffix, grid_urban_500m, "POP", pop_i, pop) + CALL read_5x5_data_time (landdir, suffix, grid_urban_500m, "POP_DEN", pop_i, pop) #ifdef USEMPI CALL aggregation_data_daemon (grid_urban_500m, data_r8_2d_in1 = pop) @@ -250,8 +261,8 @@ SUBROUTINE Aggregation_Urban (dir_rawdata, dir_srfdata, lc_year, & DO iurban = 1, numurban ! request all fine grid data and area of the iurban urban patch ! a one dimension vector will be returned - CALL aggregation_request_data (landurban, iurban, grid_urban_500m, area = area_one, & - data_r8_2d_in1 = pop, data_r8_2d_out1 = pop_one) + CALL aggregation_request_data (landurban, iurban, grid_urban_500m, zip = USE_zip_for_aggregation, & + area = area_one, data_r8_2d_in1 = pop, data_r8_2d_out1 = pop_one) where (pop_one < 0) area_one = 0 @@ -267,6 +278,7 @@ SUBROUTINE Aggregation_Urban (dir_rawdata, dir_srfdata, lc_year, & #endif ENDIF +#ifndef SinglePoint ! output landname = trim(dir_srfdata) // '/urban/'//trim(cyear)//'/POP.nc' CALL ncio_create_file_vector (landname, landurban) @@ -279,11 +291,21 @@ SUBROUTINE Aggregation_Urban (dir_rawdata, dir_srfdata, lc_year, & CALL srfdata_map_and_write (pop_den, landurban%settyp, typindex, m_urb2diag, & -1.0e36_r8, landname, 'POP_DEN_'//trim(cyear), compress = 0, write_mode = 'one') #endif +#else + IF (.not. USE_SITE_urban_paras) THEN + SITE_popden(:) = pop_den + ENDIF +#endif + #ifdef USEMPI CALL mpi_barrier (p_comm_glb, p_err) #endif +#ifdef RangeCheck + CALL check_vector_data ('POP_DEN ', pop_den) +#endif + ! ******* Tree : PCT_Tree, HTOP ******* ! allocate and read the grided tree cover and tree height raw data(500m) ! NOTE, tree cover raw data is available every five years, @@ -291,7 +313,7 @@ SUBROUTINE Aggregation_Urban (dir_rawdata, dir_srfdata, lc_year, & IF (p_is_io) THEN landdir = TRIM(dir_rawdata)//'/urban/' - suffix = 'URB'//trim(c5year) + suffix = 'URBSRF'//trim(c5year) CALL allocate_block_data (grid_urban_500m, gfcc_tc) CALL read_5x5_data (landdir, suffix, grid_urban_500m, "PCT_Tree", gfcc_tc) @@ -315,7 +337,7 @@ SUBROUTINE Aggregation_Urban (dir_rawdata, dir_srfdata, lc_year, & ! loop for urban patch to aggregate tree cover and height data with area-weighted average DO iurban = 1, numurban - CALL aggregation_request_data (landurban, iurban, grid_urban_500m, area = area_one, & + CALL aggregation_request_data (landurban, iurban, grid_urban_500m, zip = USE_zip_for_aggregation, area = area_one, & data_r8_2d_in1 = gfcc_tc, data_r8_2d_out1 = gfcc_tc_one, & data_r8_2d_in2 = gedi_th, data_r8_2d_out2 = gedi_th_one) @@ -341,6 +363,7 @@ SUBROUTINE Aggregation_Urban (dir_rawdata, dir_srfdata, lc_year, & #endif ENDIF +#ifndef SinglePoint ! output landname = trim(dir_srfdata) // '/urban/'//trim(cyear)//'/PCT_Tree.nc' CALL ncio_create_file_vector (landname, landurban) @@ -363,11 +386,22 @@ SUBROUTINE Aggregation_Urban (dir_rawdata, dir_srfdata, lc_year, & CALL srfdata_map_and_write (htop_urb, landurban%settyp, typindex, m_urb2diag, & -1.0e36_r8, landname, 'URBAN_TREE_TOP_'//trim(cyear), compress = 0, write_mode = 'one') #endif +#else + IF (.not. USE_SITE_urban_paras) THEN + SITE_fveg_urb(:) = pct_tree + SITE_htop_urb(:) = htop_urb + ENDIF +#endif #ifdef USEMPI CALL mpi_barrier (p_comm_glb, p_err) #endif +#ifdef RangeCheck + CALL check_vector_data ('Urban Tree Cover ', pct_tree) + CALL check_vector_data ('Urban Tree Top ' , htop_urb) +#endif + ! ******* PCT_Water ******* ! allocate and read grided water cover raw data IF (p_is_io) THEN @@ -375,7 +409,7 @@ SUBROUTINE Aggregation_Urban (dir_rawdata, dir_srfdata, lc_year, & CALL allocate_block_data (grid_urban_500m, gl30_wt) landdir = TRIM(dir_rawdata)//'/urban/' - suffix = 'URB'//trim(c5year) + suffix = 'URBSRF'//trim(c5year) CALL read_5x5_data (landdir, suffix, grid_urban_500m, "PCT_Water", gl30_wt) #ifdef USEMPI @@ -390,7 +424,7 @@ SUBROUTINE Aggregation_Urban (dir_rawdata, dir_srfdata, lc_year, & pct_urbwt (:) = 0. ! loop for urban patch to aggregate water cover data with area-weighted average DO iurban = 1, numurban - CALL aggregation_request_data (landurban, iurban, grid_urban_500m, area = area_one, & + CALL aggregation_request_data (landurban, iurban, grid_urban_500m, zip = USE_zip_for_aggregation, area = area_one, & data_r8_2d_in1 = gl30_wt, data_r8_2d_out1 = gl30_wt_one) where (gl30_wt_one < 0) @@ -407,6 +441,7 @@ SUBROUTINE Aggregation_Urban (dir_rawdata, dir_srfdata, lc_year, & #endif ENDIF +#ifndef SinglePoint ! output landname = trim(dir_srfdata) // '/urban/'//trim(cyear)//'/PCT_Water.nc' CALL ncio_create_file_vector (landname, landurban) @@ -419,21 +454,30 @@ SUBROUTINE Aggregation_Urban (dir_rawdata, dir_srfdata, lc_year, & CALL srfdata_map_and_write (pct_urbwt, landurban%settyp, typindex, m_urb2diag, & -1.0e36_r8, landname, 'PCT_Water_'//trim(cyear), compress = 0, write_mode = 'one') #endif +#else + IF (.not. USE_SITE_urban_paras) THEN + SITE_flake_urb(:) = pct_urbwt + ENDIF +#endif #ifdef USEMPI CALL mpi_barrier (p_comm_glb, p_err) #endif +#ifdef RangeCheck + CALL check_vector_data ('Urban Water Cover ', pct_urbwt) +#endif + ! ******* Building : Weight, HTOP_Roof ******* ! if building data is missing, how to look-up-table? ! a new arry with region id was used for look-up-table (urban_reg) -#ifndef URBAN_LCZ +IF (DEF_URBAN_type_scheme == 1) THEN ! only used when urban patch have nan data of building height and fraction - landname = TRIM(dir_rawdata)//'urban/urban_properties.nc' + landname = TRIM(dir_rawdata)//'urban/NCAR_urban_properties.nc' CALL ncio_read_bcast_serial (landname, "WTLUNIT_ROOF" , ncar_wt ) CALL ncio_read_bcast_serial (landname, "HT_ROOF" , ncar_ht ) -#endif +ENDIF ! allocate and read grided building hegight and cover raw data IF (p_is_io) THEN @@ -441,16 +485,16 @@ SUBROUTINE Aggregation_Urban (dir_rawdata, dir_srfdata, lc_year, & CALL allocate_block_data (grid_urban_500m, wtrf) CALL allocate_block_data (grid_urban_500m, htrf) - landdir = TRIM(dir_rawdata)//'urban/' - suffix = 'URB'//trim(c5year) + landdir = TRIM(dir_rawdata)//'urban_type/' + suffix = 'URBTYP' CALL read_5x5_data (landdir, suffix, grid_urban_500m, "REGION_ID", reg_typid) landdir = TRIM(dir_rawdata)//'/urban/' - suffix = 'URB'//trim(c5year) - CALL read_5x5_data (landdir, suffix, grid_urban_500m, "WTLUNIT_ROOF", wtrf) + suffix = 'URBSRF'//trim(c5year) + CALL read_5x5_data (landdir, suffix, grid_urban_500m, "PCT_ROOF", wtrf) landdir = TRIM(dir_rawdata)//'/urban/' - suffix = 'URB'//trim(c5year) + suffix = 'URBSRF'//trim(c5year) CALL read_5x5_data (landdir, suffix, grid_urban_500m, "HT_ROOF", htrf) #ifdef USEMPI @@ -465,12 +509,12 @@ SUBROUTINE Aggregation_Urban (dir_rawdata, dir_srfdata, lc_year, & ! loop for urban patch to aggregate building height and fraction data with area-weighted average DO iurban = 1, numurban - CALL aggregation_request_data (landurban, iurban, grid_urban_500m, area = area_one, & + CALL aggregation_request_data (landurban, iurban, grid_urban_500m, zip = USE_zip_for_aggregation, area = area_one, & data_i4_2d_in1 = reg_typid, data_i4_2d_out1 = reg_typid_one, & data_r8_2d_in1 = wtrf, data_r8_2d_out1 = wt_roof_one, & data_r8_2d_in2 = htrf, data_r8_2d_out2 = ht_roof_one) -#ifndef URBAN_LCZ +IF (DEF_URBAN_type_scheme == 1) THEN ! when urban patch has no data, use table data to fill gap ! urban type and region id for look-up-table urb_typidx = landurban%settyp(iurban) @@ -492,7 +536,7 @@ SUBROUTINE Aggregation_Urban (dir_rawdata, dir_srfdata, lc_year, & where (ht_roof_one <= 0) ht_roof_one = ncar_ht(urb_typidx,reg_typid_one) END where -#else +ELSE IF (DEF_URBAN_type_scheme == 2) THEN ! same for above, but for LCZ case ! LCZ type for look-up-table urb_typidx = landurban%settyp(iurban) @@ -504,7 +548,7 @@ SUBROUTINE Aggregation_Urban (dir_rawdata, dir_srfdata, lc_year, & where (ht_roof_one <= 0) ht_roof_one = htroof_lcz(urb_typidx) END where -#endif +ENDIF ! area-weight average wt_roof(iurban) = sum(wt_roof_one * area_one) / sum(area_one) @@ -517,6 +561,7 @@ SUBROUTINE Aggregation_Urban (dir_rawdata, dir_srfdata, lc_year, & #endif ENDIF +#ifndef SinglePoint ! output landname = trim(dir_srfdata) // '/urban/'//trim(cyear)//'/WT_ROOF.nc' CALL ncio_create_file_vector (landname, landurban) @@ -539,12 +584,24 @@ SUBROUTINE Aggregation_Urban (dir_rawdata, dir_srfdata, lc_year, & CALL srfdata_map_and_write (wt_roof, landurban%settyp, typindex, m_urb2diag, & -1.0e36_r8, landname, 'WT_ROOF_'//trim(cyear), compress = 0, write_mode = 'one') #endif +#else + IF (.not. USE_SITE_urban_paras) THEN + SITE_froof(:) = wt_roof + SITE_hroof(:) = ht_roof + ENDIF +#endif #ifdef USEMPI CALL mpi_barrier (p_comm_glb, p_err) #endif +#ifdef RangeCheck + CALL check_vector_data ('Urban Roof Fraction ', wt_roof) + CALL check_vector_data ('Urban Roof Height ' , ht_roof) +#endif + ! ******* LAI, SAI ******* +#ifndef LULCC IF (DEF_LAI_CHANGE_YEARLY) THEN start_year = DEF_simulation_time%start_year end_year = DEF_simulation_time%end_year @@ -552,9 +609,12 @@ SUBROUTINE Aggregation_Urban (dir_rawdata, dir_srfdata, lc_year, & start_year = lc_year end_year = lc_year ENDIF - ! allocate and read grided LSAI raw data - landdir = TRIM(dir_rawdata)//'/urban_lai_5x5/' - suffix = 'UrbLAI_v5_'//trim(c5year) +#else + start_year = lc_year + end_year = lc_year +#endif + + IF (p_is_io) THEN CALL allocate_block_data (grid_urban_500m, ulai) @@ -569,10 +629,28 @@ SUBROUTINE Aggregation_Urban (dir_rawdata, dir_srfdata, lc_year, & sai_urb(:) = 0. ENDIF +#ifdef SinglePoint + allocate (SITE_LAI_year (start_year:end_year)) + SITE_LAI_year = (/(iy, iy = start_year, end_year)/) + + allocate (SITE_LAI_monthly (12,start_year:end_year)) + allocate (SITE_SAI_monthly (12,start_year:end_year)) +#endif + DO iy = start_year, end_year - write(cyear,'(i4.4)') iy - landsrfdir = trim(dir_srfdata) // '/urban/' // trim(cyear) // '/LAI' + + IF (iy < 2000) THEN + write(iyear,'(i4.4)') 2000 + ELSE + write(iyear,'(i4.4)') iy + ENDIF + + landsrfdir = trim(dir_srfdata) // '/urban/' // trim(iyear) // '/LAI' CALL system('mkdir -p ' // trim(adjustl(landsrfdir))) + + ! allocate and read grided LSAI raw data + landdir = TRIM(dir_rawdata)//'/urban_lai_5x5/' + suffix = 'UrbLAI_'//trim(iyear) ! loop for month DO imonth = 1, 12 @@ -597,7 +675,7 @@ SUBROUTINE Aggregation_Urban (dir_rawdata, dir_srfdata, lc_year, & ! loop for urban patch to aggregate LSAI data DO iurban = 1, numurban - CALL aggregation_request_data (landurban, iurban, grid_urban_500m, area = area_one, & + CALL aggregation_request_data (landurban, iurban, grid_urban_500m, zip = USE_zip_for_aggregation, area = area_one, & data_r8_2d_in1 = gfcc_tc, data_r8_2d_out1 = gfcc_tc_one, & data_r8_2d_in2 = ulai , data_r8_2d_out2 = ulai_one , & data_r8_2d_in3 = usai , data_r8_2d_out3 = slai_one ) @@ -620,38 +698,50 @@ SUBROUTINE Aggregation_Urban (dir_rawdata, dir_srfdata, lc_year, & #endif ENDIF - ! output - landname = trim(dir_srfdata) // '/urban/'//trim(cyear)//'/LAI/urban_LAI_'//trim(cmonth)//'.nc' +#ifndef SinglePoint + ! output + landname = trim(dir_srfdata) // '/urban/'//trim(iyear)//'/LAI/urban_LAI_'//trim(cmonth)//'.nc' CALL ncio_create_file_vector (landname, landurban) CALL ncio_define_dimension_vector (landname, landurban, 'urban') CALL ncio_write_vector (landname, 'TREE_LAI', 'urban', landurban, lai_urb, 1) - landname = trim(dir_srfdata) // '/urban/'//trim(cyear)//'/LAI/urban_SAI_'//trim(cmonth)//'.nc' + landname = trim(dir_srfdata) // '/urban/'//trim(iyear)//'/LAI/urban_SAI_'//trim(cmonth)//'.nc' CALL ncio_create_file_vector (landname, landurban) CALL ncio_define_dimension_vector (landname, landurban, 'urban') CALL ncio_write_vector (landname, 'TREE_SAI', 'urban', landurban, sai_urb, 1) #ifdef SrfdataDiag typindex = (/(ityp, ityp = 1, N_URB)/) - landname = trim(dir_srfdata) // '/diag/Urban_Tree_LAI_' // trim(cyear) // '.nc' + landname = trim(dir_srfdata) // '/diag/Urban_Tree_LAI_' // trim(iyear) // '.nc' CALL srfdata_map_and_write (lai_urb, landurban%settyp, typindex, m_urb2diag, & -1.0e36_r8, landname, 'TREE_LAI_'//trim(cmonth), compress = 0, write_mode = 'one') typindex = (/(ityp, ityp = 1, N_URB)/) - landname = trim(dir_srfdata) // '/diag/Urban_Tree_SAI_' // trim(cyear) // '.nc' + landname = trim(dir_srfdata) // '/diag/Urban_Tree_SAI_' // trim(iyear) // '.nc' CALL srfdata_map_and_write (sai_urb, landurban%settyp, typindex, m_urb2diag, & -1.0e36_r8, landname, 'TREE_SAI_'//trim(cmonth), compress = 0, write_mode = 'one') #endif +#else + SITE_LAI_monthly(imonth,iy) = lai_urb(1) + SITE_SAI_monthly(imonth,iy) = sai_urb(1) +#endif #ifdef USEMPI CALL mpi_barrier (p_comm_glb, p_err) #endif + + write(c1,'(i2.2)') imonth + +#ifdef RangeCheck + CALL check_vector_data ('Urban Tree LAI '//trim(c1), lai_urb) + CALL check_vector_data ('Urban Tree SAI '//trim(c1), sai_urb) +#endif ENDDO ENDDO -#ifndef URBAN_LCZ +IF (DEF_URBAN_type_scheme == 1) THEN ! look up table of NCAR urban properties (using look-up tables) - landname = TRIM(dir_rawdata)//'urban/urban_properties.nc' + landname = TRIM(dir_rawdata)//'urban/NCAR_urban_properties.nc' CALL ncio_read_bcast_serial (landname, "CANYON_HWR" , hwrcan ) CALL ncio_read_bcast_serial (landname, "WTROAD_PERV" , wtrd ) @@ -740,15 +830,15 @@ SUBROUTINE Aggregation_Urban (dir_rawdata, dir_srfdata, lc_year, & ! loop for each urban patch to aggregate NCAR urban morphological and thermal paras with area-weighted average DO iurban = 1, numurban - CALL aggregation_request_data (landurban, iurban, grid_urban_500m, area = area_one, & + CALL aggregation_request_data (landurban, iurban, grid_urban_500m, zip = USE_zip_for_aggregation, area = area_one, & data_i4_2d_in2 = reg_typid, data_i4_2d_out2 = reg_typid_one) ! urban region and type id for look-up-table urb_typidx = landurban%settyp(iurban) !urb_regidx = urban_reg(iurban) - ipxstt = landurban%ipxstt(iurban) - ipxend = landurban%ipxend(iurban) + ! ipxstt = landurban%ipxstt(iurban) + ! ipxend = landurban%ipxend(iurban) sumarea = sum(area_one) @@ -762,7 +852,7 @@ SUBROUTINE Aggregation_Urban (dir_rawdata, dir_srfdata, lc_year, & ENDIF ! loop for each finer grid to aggregate data - DO ipxl = ipxstt, ipxend + DO ipxl = 1, size(area_one) ! ipxstt, ipxend urb_regidx = reg_typid_one(ipxl) area_urb(urb_typidx,iurban) = area_urb(urb_typidx,iurban) + area_one(ipxl) @@ -842,6 +932,7 @@ SUBROUTINE Aggregation_Urban (dir_rawdata, dir_srfdata, lc_year, & #endif ENDIF +#ifndef SinglePoint !output write(cyear,'(i4.4)') lc_year landname = trim(dir_srfdata) // '/urban/'//trim(cyear)//'/urban.nc' @@ -884,33 +975,76 @@ SUBROUTINE Aggregation_Urban (dir_rawdata, dir_srfdata, lc_year, & CALL srfdata_map_and_write (hwr_can, landurban%settyp, typindex, m_urb2diag, & -1.0e36_r8, landname, 'CANYON_HWR_'//trim(cyear), compress = 0, write_mode = 'one') - ! typindex = (/(ityp, ityp = 1, N_URB)/) - ! landname = trim(dir_srfdata) // '/diag/PCT_Urban.nc' - ! CALL srfdata_map_and_write (area_tb, landurban%settyp, typindex, m_urb2diag, & - ! -1.0e36_r8, landname, 'PCT_Urban', compress = 0, write_mode = 'one') - ! typindex = (/(ityp, ityp = 1, N_URB)/) - ! landname = trim(dir_srfdata) // '/diag/PCT_Urban.nc' - ! CALL srfdata_map_and_write (area_hd, landurban%settyp, typindex, m_urb2diag, & - ! -1.0e36_r8, landname, 'PCT_Urban', compress = 0, write_mode = 'one') - ! typindex = (/(ityp, ityp = 1, N_URB)/) - ! landname = trim(dir_srfdata) // '/diag/PCT_Urban.nc' - ! CALL srfdata_map_and_write (area_md, landurban%settyp, typindex, m_urb2diag, & - ! -1.0e36_r8, landname, 'PCT_Urban', compress = 0, write_mode = 'one') - typindex = (/(ityp, ityp = 1, N_URB)/) landname = trim(dir_srfdata) // '/diag/cv_imrd' // trim(cyear) // '.nc' + DO il = 1, 10 write(clay, '(i2.2)') il CALL srfdata_map_and_write (cv_imrd(il,:), landurban%settyp, typindex, m_urb2diag, & - -1.0e36_r8, landname, 'CV_IMPROAD_'//trim(clay), compress = 0, write_mode = 'one') + -1.0e36_r8, landname, 'CV_IMPROAD', compress = 0, write_mode = 'one', lastdimname = 'layer', lastdimvalue = il) + ! CALL srfdata_map_and_write (cv_imrd(il,:), landurban%settyp, typindex, m_urb2diag, & + ! -1.0e36_r8, landname, 'CV_IMPROAD_'//trim(clay), compress = 0, write_mode = 'one') ENDDO + deallocate(typindex) +#endif +#else + + SITE_em_roof (:) = em_roof + SITE_em_wall (:) = em_wall + SITE_em_gimp (:) = em_imrd + SITE_em_gper (:) = em_perd + SITE_t_roommax(:) = tb_max + SITE_t_roommin(:) = tb_min + SITE_thickroof(:) = th_roof + SITE_thickwall(:) = th_wall + + SITE_cv_roof (:) = cv_roof(:,1) + SITE_cv_wall (:) = cv_wall(:,1) + SITE_cv_gimp (:) = cv_imrd(:,1) + SITE_tk_roof (:) = tk_roof(:,1) + SITE_tk_wall (:) = tk_wall(:,1) + SITE_tk_gimp (:) = tk_imrd(:,1) + + SITE_alb_roof (:,:) = alb_roof(:,:,1) + SITE_alb_wall (:,:) = alb_wall(:,:,1) + SITE_alb_gimp (:,:) = alb_imrd(:,:,1) + SITE_alb_gper (:,:) = alb_perd(:,:,1) + + IF (.not. USE_SITE_urban_paras) THEN + SITE_hwr (:) = hwr_can + SITE_fgper(:) = wt_rd + SITE_fgimp(:) = 1 - SITE_fgper + ENDIF +#endif + +#ifdef RangeCheck + CALL check_vector_data ('CANYON_HWR ' , hwr_can ) + CALL check_vector_data ('WTROAD_PERV ' , wt_rd ) + CALL check_vector_data ('EM_ROOF ' , em_roof ) + CALL check_vector_data ('EM_WALL ' , em_wall ) + CALL check_vector_data ('EM_IMPROAD ' , em_imrd ) + CALL check_vector_data ('EM_PERROAD ' , em_perd ) + CALL check_vector_data ('ALB_ROOF ' , alb_roof) + CALL check_vector_data ('ALB_WALL ' , alb_wall) + CALL check_vector_data ('ALB_IMPROAD ' , alb_imrd) + CALL check_vector_data ('ALB_PERROAD ' , alb_perd) + CALL check_vector_data ('TK_ROOF ' , tk_roof ) + CALL check_vector_data ('TK_WALL ' , tk_wall ) + CALL check_vector_data ('TK_IMPROAD ' , tk_imrd ) + CALL check_vector_data ('CV_ROOF ' , cv_roof ) + CALL check_vector_data ('CV_WALL ' , cv_wall ) + CALL check_vector_data ('CV_IMPROAD ' , cv_imrd ) + CALL check_vector_data ('THICK_ROOF ' , th_roof ) + CALL check_vector_data ('THICK_WALL ' , th_wall ) + CALL check_vector_data ('T_BUILDING_MIN ', tb_min ) + CALL check_vector_data ('T_BUILDING_MAX ', tb_max ) #endif #ifdef USEMPI CALL mpi_barrier (p_comm_glb, p_err) #endif -#endif +ENDIF IF (p_is_worker) THEN IF (allocated(LUCY_coun)) deallocate (LUCY_coun) @@ -922,7 +1056,7 @@ SUBROUTINE Aggregation_Urban (dir_rawdata, dir_srfdata, lc_year, & IF (allocated(ht_roof )) deallocate (ht_roof ) IF (allocated(lai_urb )) deallocate (lai_urb ) IF (allocated(sai_urb )) deallocate (sai_urb ) -#ifndef URBAN_LCZ +IF (DEF_URBAN_type_scheme == 1) THEN IF (allocated(ncar_ht )) deallocate (ncar_ht ) IF (allocated(ncar_wt )) deallocate (ncar_wt ) IF (allocated(area_urb )) deallocate (area_urb ) @@ -948,7 +1082,7 @@ SUBROUTINE Aggregation_Urban (dir_rawdata, dir_srfdata, lc_year, & IF (allocated(alb_wall )) deallocate (alb_wall ) IF (allocated(alb_imrd )) deallocate (alb_imrd ) IF (allocated(alb_perd )) deallocate (alb_perd ) -#endif +ENDIF IF (allocated(area_one )) deallocate(area_one ) IF (allocated(LUCY_reg_one)) deallocate(LUCY_reg_one) IF (allocated(pop_one )) deallocate(pop_one ) diff --git a/mksrfdata/MKSRFDATA.F90 b/mksrfdata/MKSRFDATA.F90 index 56d741ba..5f507581 100644 --- a/mksrfdata/MKSRFDATA.F90 +++ b/mksrfdata/MKSRFDATA.F90 @@ -59,14 +59,14 @@ PROGRAM MKSRFDATA USE MOD_LandPatch USE MOD_SrfdataRestart USE MOD_Const_LC -#ifdef LULC_IGBP_PFT +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) USE MOD_LandPFT #endif -#ifdef LULC_IGBP_PC - USE MOD_LandPC -#endif #ifdef URBAN_MODEL USE MOD_LandUrban +#endif +#ifdef CROP + USE MOD_LandCrop #endif USE MOD_RegionClip #ifdef SrfdataDiag @@ -87,7 +87,7 @@ PROGRAM MKSRFDATA REAL(r8) :: edges ! southern edge of grid (degrees) REAL(r8) :: edgew ! western edge of grid (degrees) - TYPE (grid_type) :: gridlai, gtopo + TYPE (grid_type) :: gsoil, gridlai, gtopo TYPE (grid_type) :: grid_urban_5km, grid_urban_500m INTEGER :: lc_year @@ -107,7 +107,11 @@ PROGRAM MKSRFDATA CALL read_namelist (nlfile) #ifdef SinglePoint +#ifndef URBAN_MODEL CALL read_surface_data_single (SITE_fsrfdata, mksrfdata=.true.) +#else + CALL read_urban_surface_data_single (SITE_fsrfdata, mksrfdata=.true.) +#endif #endif IF (USE_srfdata_from_larger_region) THEN @@ -187,18 +191,18 @@ PROGRAM MKSRFDATA #ifdef LULC_IGBP CALL gpatch%define_by_name ('colm_500m') #endif -#ifdef LULC_IGBP_PFT - CALL gpatch%define_by_name ('colm_500m') -#endif -#ifdef LULC_IGBP_PC +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) CALL gpatch%define_by_name ('colm_500m') #endif #if (defined CROP) ! define grid for crop parameters - CALL gcrop%define_by_ndims (720,360) + CALL gcrop%define_from_file (trim(DEF_dir_rawdata)//'/global_CFT_surface_data.nc', 'lat', 'lon') #endif - ! define grid for land characteristics + ! define grid for soil parameters raw data + CALL gsoil%define_by_name ('colm_500m') + + ! define grid for LAI raw data CALL gridlai%define_by_name ('colm_500m') ! define grid for topography @@ -222,6 +226,7 @@ PROGRAM MKSRFDATA CALL pixel%assimilate_grid (ghru) #endif CALL pixel%assimilate_grid (gpatch) + CALL pixel%assimilate_grid (gsoil) CALL pixel%assimilate_grid (gridlai) #ifdef URBAN_MODEL @@ -246,6 +251,7 @@ PROGRAM MKSRFDATA CALL pixel%map_to_grid (ghru) #endif CALL pixel%map_to_grid (gpatch) + CALL pixel%map_to_grid (gsoil) CALL pixel%map_to_grid (gridlai) #ifdef URBAN_MODEL @@ -290,12 +296,12 @@ PROGRAM MKSRFDATA CALL landurban_build(lc_year) #endif -#ifdef LULC_IGBP_PFT - CALL landpft_build(lc_year) +#ifdef CROP + CALL landcrop_build (lc_year) #endif -#ifdef LULC_IGBP_PC - CALL landpc_build(lc_year) +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + CALL landpft_build(lc_year) #endif ! ................................................................ @@ -316,14 +322,10 @@ PROGRAM MKSRFDATA CALL pixelset_save_to_file (dir_landdata, 'landpatch', landpatch, lc_year) -#ifdef LULC_IGBP_PFT +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) CALL pixelset_save_to_file (dir_landdata, 'landpft' , landpft , lc_year) #endif -#ifdef LULC_IGBP_PC - CALL pixelset_save_to_file (dir_landdata, 'landpc' , landpc , lc_year) -#endif - #ifdef URBAN_MODEL CALL pixelset_save_to_file (dir_landdata, 'landurban', landurban, lc_year) #endif @@ -332,6 +334,11 @@ PROGRAM MKSRFDATA ! 3. Mapping land characteristic parameters to the model grids ! ................................................................ #ifdef SrfdataDiag +#if (defined CROP) + CALL elm_patch%build (landelm, landpatch, use_frac = .true., sharedfrac = pctshrpch) +#else + CALL elm_patch%build (landelm, landpatch, use_frac = .true.) +#endif #ifdef GRIDBASED CALL gdiag%define_by_copy (gridmesh) #else @@ -347,12 +354,12 @@ PROGRAM MKSRFDATA CALL Aggregation_LakeDepth (gpatch , dir_rawdata, dir_landdata, lc_year) - CALL Aggregation_SoilParameters (gpatch , dir_rawdata, dir_landdata, lc_year) + CALL Aggregation_SoilParameters (gsoil, dir_rawdata, dir_landdata, lc_year) CALL Aggregation_SoilBrightness (gpatch , dir_rawdata, dir_landdata, lc_year) IF (DEF_USE_BEDROCK) THEN - CALL Aggregation_DBedrock (gpatch , dir_rawdata, dir_landdata) + CALL Aggregation_DBedrock (gpatch , dir_rawdata, dir_landdata) ENDIF CALL Aggregation_LAI (gridlai, dir_rawdata, dir_landdata, lc_year) @@ -371,10 +378,14 @@ PROGRAM MKSRFDATA ! ................................................................ #ifdef SinglePoint -#if (defined LULC_IGBP_PFT) +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) CALL write_surface_data_single (numpatch, numpft) #else +#ifndef URBAN_MODEL CALL write_surface_data_single (numpatch) +#else + CALL write_urban_surface_data_single (numurban) +#endif #endif CALL single_srfdata_final () #endif diff --git a/mksrfdata/MOD_AggregationRequestData.F90 b/mksrfdata/MOD_AggregationRequestData.F90 index 6163c29a..56fef1df 100644 --- a/mksrfdata/MOD_AggregationRequestData.F90 +++ b/mksrfdata/MOD_AggregationRequestData.F90 @@ -272,8 +272,8 @@ END SUBROUTINE aggregation_data_daemon #endif !---------------------------------------------------- - SUBROUTINE aggregation_request_data ( & - pixelset, iset, grid_in, area, & + SUBROUTINE aggregation_request_data ( & + pixelset, iset, grid_in, zip, area, & data_r8_2d_in1, data_r8_2d_out1, & data_r8_2d_in2, data_r8_2d_out2, & data_r8_2d_in3, data_r8_2d_out3, & @@ -302,6 +302,7 @@ SUBROUTINE aggregation_request_data ( & INTEGER, intent(in) :: iset TYPE (grid_type), intent(in) :: grid_in + logical, intent(in) :: zip REAL(r8), allocatable, intent(out), optional :: area(:) @@ -340,53 +341,103 @@ SUBROUTINE aggregation_request_data ( & INTEGER, intent(in), optional :: filledvalue_i4 ! Local Variables - INTEGER :: nreq, smesg(2), isrc, idest, iproc - INTEGER :: ilon, ilat, xblk, yblk, xloc, yloc - INTEGER :: ipxl, ie, ipxstt, ipxend, lb1 - INTEGER, allocatable :: ylist(:), xlist(:), ipt(:), ibuf(:) - - REAL(r8), allocatable :: rbuf_r8_1d(:), rbuf_r8_2d(:,:) - INTEGER , allocatable :: rbuf_i4_1d(:) - + INTEGER :: totalreq, ireq, nreq, smesg(2), isrc, idest, iproc + INTEGER :: ilon, ilat, xblk, yblk, xloc, yloc, iloc, nx, ny, ix, iy, ig + INTEGER :: ie, ipxstt, ipxend, npxl, ipxl, lb1, xgrdthis, ygrdthis + INTEGER, allocatable :: ylist(:), xlist(:), ipt(:), ibuf(:), rbuf_i4_1d(:) + INTEGER, allocatable :: xsorted(:), ysorted(:), xy2d(:,:) + REAL(r8), allocatable :: area2d(:,:), rbuf_r8_1d(:), rbuf_r8_2d(:,:) LOGICAL, allocatable :: msk(:) ie = pixelset%ielm (iset) ipxstt = pixelset%ipxstt(iset) ipxend = pixelset%ipxend(iset) + npxl = ipxend - ipxstt + 1 + + IF (zip) THEN + + allocate (xsorted(npxl)) + allocate (ysorted(npxl)) + + nx = 0; ny = 0 + DO ipxl = ipxstt, ipxend + xgrdthis = grid_in%xgrd(mesh(ie)%ilon(ipxl)) + ygrdthis = grid_in%ygrd(mesh(ie)%ilat(ipxl)) + CALL insert_into_sorted_list1 (xgrdthis, nx, xsorted, iloc) + CALL insert_into_sorted_list1 (ygrdthis, ny, ysorted, iloc) + ENDDO + + allocate (xy2d (nx,ny)); xy2d(:,:) = 0 + + IF (present(area)) THEN + allocate(area2d(nx,ny)); area2d(:,:) = 0. + ENDIF - IF (present (area)) THEN - allocate (area (ipxstt:ipxend)) DO ipxl = ipxstt, ipxend - area(ipxl) = areaquad (& - pixel%lat_s(mesh(ie)%ilat(ipxl)), pixel%lat_n(mesh(ie)%ilat(ipxl)), & - pixel%lon_w(mesh(ie)%ilon(ipxl)), pixel%lon_e(mesh(ie)%ilon(ipxl)) ) + xgrdthis = grid_in%xgrd(mesh(ie)%ilon(ipxl)) + ygrdthis = grid_in%ygrd(mesh(ie)%ilat(ipxl)) + + ix = find_in_sorted_list1(xgrdthis, nx, xsorted) + iy = find_in_sorted_list1(ygrdthis, ny, ysorted) + + xy2d(ix,iy) = xy2d(ix,iy) + 1 + + IF (present(area)) THEN + area2d(ix,iy) = area2d(ix,iy) + areaquad (& + pixel%lat_s(mesh(ie)%ilat(ipxl)), pixel%lat_n(mesh(ie)%ilat(ipxl)), & + pixel%lon_w(mesh(ie)%ilon(ipxl)), pixel%lon_e(mesh(ie)%ilon(ipxl)) ) + ENDIF ENDDO - ENDIF - IF (present(data_r8_2d_in1) .and. present(data_r8_2d_out1)) THEN - allocate (data_r8_2d_out1 (ipxstt:ipxend)) - ENDIF + totalreq = count(xy2d > 0) - IF (present(data_r8_2d_in2) .and. present(data_r8_2d_out2)) THEN - allocate (data_r8_2d_out2 (ipxstt:ipxend)) - ENDIF + allocate (xlist (totalreq)) + allocate (ylist (totalreq)) - IF (present(data_r8_2d_in3) .and. present(data_r8_2d_out3)) THEN - allocate (data_r8_2d_out3 (ipxstt:ipxend)) - ENDIF + IF (present(area)) allocate(area(totalreq)) + + ig = 0 + DO ix = 1, nx + DO iy = 1, ny + IF (xy2d(ix,iy) > 0) THEN + ig = ig + 1 + xlist(ig) = xsorted(ix) + ylist(ig) = ysorted(iy) + IF (present(area)) area (ig) = area2d(ix,iy) + ENDIF + ENDDO + ENDDO - IF (present(data_r8_2d_in4) .and. present(data_r8_2d_out4)) THEN - allocate (data_r8_2d_out4 (ipxstt:ipxend)) - ENDIF + deallocate (xsorted, ysorted, xy2d) + IF (present(area)) deallocate (area2d) - IF (present(data_r8_2d_in5) .and. present(data_r8_2d_out5)) THEN - allocate (data_r8_2d_out5 (ipxstt:ipxend)) - ENDIF + ELSE + + allocate(xlist (npxl)) + allocate(ylist (npxl)) - IF (present(data_r8_2d_in6) .and. present(data_r8_2d_out6)) THEN - allocate (data_r8_2d_out6 (ipxstt:ipxend)) - ENDIF + IF (present(area)) allocate (area (npxl)) + + totalreq = npxl + DO ipxl = ipxstt, ipxend + xlist(ipxl-ipxstt+1) = grid_in%xgrd(mesh(ie)%ilon(ipxl)) + ylist(ipxl-ipxstt+1) = grid_in%ygrd(mesh(ie)%ilat(ipxl)) + IF (present(area)) THEN + area(ipxl-ipxstt+1) = areaquad (& + pixel%lat_s(mesh(ie)%ilat(ipxl)), pixel%lat_n(mesh(ie)%ilat(ipxl)), & + pixel%lon_w(mesh(ie)%ilon(ipxl)), pixel%lon_e(mesh(ie)%ilon(ipxl)) ) + ENDIF + ENDDO + + ENDIF + + IF (present(data_r8_2d_in1) .and. present(data_r8_2d_out1)) allocate (data_r8_2d_out1 (totalreq)) + IF (present(data_r8_2d_in2) .and. present(data_r8_2d_out2)) allocate (data_r8_2d_out2 (totalreq)) + IF (present(data_r8_2d_in3) .and. present(data_r8_2d_out3)) allocate (data_r8_2d_out3 (totalreq)) + IF (present(data_r8_2d_in4) .and. present(data_r8_2d_out4)) allocate (data_r8_2d_out4 (totalreq)) + IF (present(data_r8_2d_in5) .and. present(data_r8_2d_out5)) allocate (data_r8_2d_out5 (totalreq)) + IF (present(data_r8_2d_in6) .and. present(data_r8_2d_out6)) allocate (data_r8_2d_out6 (totalreq)) IF (present(data_r8_3d_in1) .and. present(data_r8_3d_out1) .and. present(n1_r8_3d_in1)) THEN IF (present(lb1_r8_3d_in1)) THEN @@ -394,7 +445,7 @@ SUBROUTINE aggregation_request_data ( & ELSE lb1 = 1 ENDIF - allocate (data_r8_3d_out1 (lb1:lb1-1+n1_r8_3d_in1,ipxstt:ipxend)) + allocate (data_r8_3d_out1 (lb1:lb1-1+n1_r8_3d_in1,totalreq)) ENDIF IF (present(data_r8_3d_in2) .and. present(data_r8_3d_out2) .and. present(n1_r8_3d_in2)) THEN @@ -403,18 +454,18 @@ SUBROUTINE aggregation_request_data ( & ELSE lb1 = 1 ENDIF - allocate (data_r8_3d_out2 (lb1:lb1-1+n1_r8_3d_in2,ipxstt:ipxend)) + allocate (data_r8_3d_out2 (lb1:lb1-1+n1_r8_3d_in2,totalreq)) ENDIF IF (present(data_i4_2d_in1) .and. present(data_i4_2d_out1)) THEN - allocate (data_i4_2d_out1 (ipxstt:ipxend)) + allocate (data_i4_2d_out1 (totalreq)) IF (present(filledvalue_i4)) THEN data_i4_2d_out1 = filledvalue_i4 ENDIF ENDIF IF (present(data_i4_2d_in2) .and. present(data_i4_2d_out2)) THEN - allocate (data_i4_2d_out2 (ipxstt:ipxend)) + allocate (data_i4_2d_out2 (totalreq)) IF (present(filledvalue_i4)) THEN data_i4_2d_out2 = filledvalue_i4 ENDIF @@ -422,25 +473,15 @@ SUBROUTINE aggregation_request_data ( & #ifdef USEMPI - allocate (xlist (ipxstt:ipxend)) - allocate (ylist (ipxstt:ipxend)) - allocate (ipt (ipxstt:ipxend)) - allocate (msk (ipxstt:ipxend)) + allocate (ipt (totalreq)) + allocate (msk (totalreq)) ipt(:) = -1 - DO ipxl = ipxstt, ipxend - xlist(ipxl) = grid_in%xgrd(mesh(ie)%ilon(ipxl)) - ylist(ipxl) = grid_in%ygrd(mesh(ie)%ilat(ipxl)) - - IF ((xlist(ipxl) < 0) .or. (ylist(ipxl) < 0)) THEN - write(*,*) 'Warning: request data out of range.' - ELSE - xblk = grid_in%xblk(xlist(ipxl)) - yblk = grid_in%yblk(ylist(ipxl)) - ipt(ipxl) = gblock%pio(xblk,yblk) - ENDIF - + DO ireq = 1, totalreq + xblk = grid_in%xblk(xlist(ireq)) + yblk = grid_in%yblk(ylist(ireq)) + ipt(ireq) = gblock%pio(xblk,yblk) ENDDO DO iproc = 0, p_np_io-1 @@ -455,10 +496,10 @@ SUBROUTINE aggregation_request_data ( & allocate (ibuf (nreq)) - ibuf = pack(xlist, msk) + ibuf = pack(xlist(1:totalreq), msk) CALL mpi_send (ibuf, nreq, MPI_INTEGER, idest, mpi_tag_data, p_comm_glb, p_err) - ibuf = pack(ylist, msk) + ibuf = pack(ylist(1:totalreq), msk) CALL mpi_send (ibuf, nreq, MPI_INTEGER, idest, mpi_tag_data, p_comm_glb, p_err) isrc = idest @@ -545,62 +586,53 @@ SUBROUTINE aggregation_request_data ( & #else - DO ipxl = ipxstt, ipxend + DO ireq = 1, totalreq - ilon = grid_in%xgrd(mesh(ie)%ilon(ipxl)) - ilat = grid_in%ygrd(mesh(ie)%ilat(ipxl)) - - IF ((ilon < 0) .or. (ilat < 0)) THEN - write(*,*) 'Warning: request data out of range.' - cycle - ENDIF - - xblk = grid_in%xblk(ilon) - yblk = grid_in%yblk(ilat) - xloc = grid_in%xloc(ilon) - yloc = grid_in%yloc(ilat) + xblk = grid_in%xblk(xlist(ireq)) + yblk = grid_in%yblk(ylist(ireq)) + xloc = grid_in%xloc(xlist(ireq)) + yloc = grid_in%yloc(ylist(ireq)) IF (present(data_r8_2d_in1) .and. present(data_r8_2d_out1)) THEN - data_r8_2d_out1(ipxl) = data_r8_2d_in1%blk(xblk,yblk)%val(xloc,yloc) + data_r8_2d_out1(ireq) = data_r8_2d_in1%blk(xblk,yblk)%val(xloc,yloc) ENDIF IF (present(data_r8_2d_in2) .and. present(data_r8_2d_out2)) THEN - data_r8_2d_out2(ipxl) = data_r8_2d_in2%blk(xblk,yblk)%val(xloc,yloc) + data_r8_2d_out2(ireq) = data_r8_2d_in2%blk(xblk,yblk)%val(xloc,yloc) ENDIF IF (present(data_r8_2d_in3) .and. present(data_r8_2d_out3)) THEN - data_r8_2d_out3(ipxl) = data_r8_2d_in3%blk(xblk,yblk)%val(xloc,yloc) + data_r8_2d_out3(ireq) = data_r8_2d_in3%blk(xblk,yblk)%val(xloc,yloc) ENDIF IF (present(data_r8_2d_in4) .and. present(data_r8_2d_out4)) THEN - data_r8_2d_out4(ipxl) = data_r8_2d_in4%blk(xblk,yblk)%val(xloc,yloc) + data_r8_2d_out4(ireq) = data_r8_2d_in4%blk(xblk,yblk)%val(xloc,yloc) ENDIF IF (present(data_r8_2d_in5) .and. present(data_r8_2d_out5)) THEN - data_r8_2d_out5(ipxl) = data_r8_2d_in5%blk(xblk,yblk)%val(xloc,yloc) + data_r8_2d_out5(ireq) = data_r8_2d_in5%blk(xblk,yblk)%val(xloc,yloc) ENDIF IF (present(data_r8_2d_in6) .and. present(data_r8_2d_out6)) THEN - data_r8_2d_out6(ipxl) = data_r8_2d_in6%blk(xblk,yblk)%val(xloc,yloc) + data_r8_2d_out6(ireq) = data_r8_2d_in6%blk(xblk,yblk)%val(xloc,yloc) ENDIF IF (present(data_r8_3d_in1) .and. present(data_r8_3d_out1) .and. present(n1_r8_3d_in1)) THEN - data_r8_3d_out1(:,ipxl) = data_r8_3d_in1%blk(xblk,yblk)%val(:,xloc,yloc) + data_r8_3d_out1(:,ireq) = data_r8_3d_in1%blk(xblk,yblk)%val(:,xloc,yloc) ENDIF IF (present(data_r8_3d_in2) .and. present(data_r8_3d_out2) .and. present(n1_r8_3d_in2)) THEN - data_r8_3d_out2(:,ipxl) = data_r8_3d_in2%blk(xblk,yblk)%val(:,xloc,yloc) + data_r8_3d_out2(:,ireq) = data_r8_3d_in2%blk(xblk,yblk)%val(:,xloc,yloc) ENDIF IF (present(data_i4_2d_in1) .and. present(data_i4_2d_out1)) THEN - data_i4_2d_out1(ipxl) = data_i4_2d_in1%blk(xblk,yblk)%val(xloc,yloc) + data_i4_2d_out1(ireq) = data_i4_2d_in1%blk(xblk,yblk)%val(xloc,yloc) ENDIF IF (present(data_i4_2d_in2) .and. present(data_i4_2d_out2)) THEN - data_i4_2d_out2(ipxl) = data_i4_2d_in2%blk(xblk,yblk)%val(xloc,yloc) + data_i4_2d_out2(ireq) = data_i4_2d_in2%blk(xblk,yblk)%val(xloc,yloc) ENDIF - ENDDO #endif diff --git a/mksrfdata/MOD_ElmVector.F90 b/mksrfdata/MOD_ElmVector.F90 index d9a2612d..d5845fa0 100644 --- a/mksrfdata/MOD_ElmVector.F90 +++ b/mksrfdata/MOD_ElmVector.F90 @@ -22,7 +22,7 @@ MODULE MOD_ElmVector INTEGER :: totalnumelm TYPE(pointer_int32_1d), allocatable :: elm_data_address (:) - INTEGER, allocatable :: eindex_glb (:) + INTEGER*8, allocatable :: eindex_glb (:) CONTAINS @@ -36,6 +36,9 @@ SUBROUTINE elm_vector_init USE MOD_Mesh USE MOD_LandElm USE MOD_LandPatch +#ifdef CROP + USE MOD_LandCrop +#endif IMPLICIT NONE ! Local Variables @@ -44,12 +47,13 @@ SUBROUTINE elm_vector_init INTEGER :: i, idsp INTEGER, allocatable :: vec_worker_dsp (:) - INTEGER, allocatable :: indexelm (:) - INTEGER, allocatable :: order (:) + + INTEGER*8, allocatable :: indexelm (:) + INTEGER, allocatable :: order (:) IF (p_is_worker) THEN #if (defined CROP) - CALL elm_patch%build (landelm, landpatch, use_frac = .true., shadowfrac = pctcrop) + CALL elm_patch%build (landelm, landpatch, use_frac = .true., sharedfrac = pctshrpch) #else CALL elm_patch%build (landelm, landpatch, use_frac = .true.) #endif @@ -74,7 +78,7 @@ SUBROUTINE elm_vector_init mesg = (/p_iam_glb, numelm/) call mpi_send (mesg, 2, MPI_INTEGER, p_root, mpi_tag_mesg, p_comm_glb, p_err) IF (numelm > 0) THEN - call mpi_send (indexelm, numelm, MPI_INTEGER, p_root, mpi_tag_data, p_comm_glb, p_err) + call mpi_send (indexelm, numelm, MPI_INTEGER8, p_root, mpi_tag_data, p_comm_glb, p_err) ENDIF #else IF (numelm > 0) THEN @@ -115,7 +119,7 @@ SUBROUTINE elm_vector_init ndata = mesg(2) IF (ndata > 0) THEN idsp = vec_worker_dsp(p_itis_worker(isrc)) - call mpi_recv (eindex_glb(idsp+1:idsp+ndata), ndata, MPI_INTEGER, isrc, & + call mpi_recv (eindex_glb(idsp+1:idsp+ndata), ndata, MPI_INTEGER8, isrc, & mpi_tag_data, p_comm_glb, p_stat, p_err) ENDIF ENDDO diff --git a/mksrfdata/MOD_HRUVector.F90 b/mksrfdata/MOD_HRUVector.F90 index 10ddbaad..936e2af0 100644 --- a/mksrfdata/MOD_HRUVector.F90 +++ b/mksrfdata/MOD_HRUVector.F90 @@ -22,8 +22,8 @@ MODULE MOD_HRUVector INTEGER :: totalnumhru TYPE(pointer_int32_1d), allocatable :: hru_data_address (:) - INTEGER, allocatable :: eindx_hru (:) - INTEGER, allocatable :: htype_hru (:) + INTEGER*8, allocatable :: eindx_hru (:) + INTEGER, allocatable :: htype_hru (:) CONTAINS @@ -37,6 +37,9 @@ SUBROUTINE hru_vector_init USE MOD_LandHRU USE MOD_LandPatch USE MOD_ElmVector +#ifdef CROP + USE MOD_LandCrop +#endif IMPLICIT NONE ! Local Variables @@ -56,7 +59,7 @@ SUBROUTINE hru_vector_init CALL basin_hru%build (landelm, landhru, use_frac = .true.) #if (defined CROP) - CALL hru_patch%build (landhru, landpatch, use_frac = .true., shadowfrac = pctcrop) + CALL hru_patch%build (landhru, landpatch, use_frac = .true., sharedfrac = pctshrpch) #else CALL hru_patch%build (landhru, landpatch, use_frac = .true.) #endif @@ -106,7 +109,7 @@ SUBROUTINE hru_vector_init #else nhru_bsn_glb(elm_data_address(0)%val) = nhru_bsn IF (sum(nhru_bsn) > 0) THEN - allocate(hru_data_address(p_itis_worker(isrc))%val (sum(nhru_bsn))) + allocate(hru_data_address(0)%val (sum(nhru_bsn))) ENDIF #endif ENDIF @@ -186,6 +189,12 @@ SUBROUTINE hru_vector_init #else htype_hru(hru_data_address(0)%val) = landhru%settyp #endif + + ! To distinguish between lake HRUs and hillslopes, the program sets the + ! type of lake HRUs as a negative number. + ! Set it as a positive number for output. + htype_hru = abs(htype_hru) + ENDIF #ifdef USEMPI diff --git a/mksrfdata/MOD_LandCrop.F90 b/mksrfdata/MOD_LandCrop.F90 new file mode 100644 index 00000000..50a2c382 --- /dev/null +++ b/mksrfdata/MOD_LandCrop.F90 @@ -0,0 +1,167 @@ +#include + +#ifdef CROP +MODULE MOD_LandCrop + + !------------------------------------------------------------------------------------ + ! DESCRIPTION: + ! + ! Build crop patches. + ! + ! Created by Shupeng Zhang, Sep 2023 + ! porting codes from Hua Yuan's OpenMP version to MPI parallel version. + !------------------------------------------------------------------------------------ + + USE MOD_Precision + USE MOD_Grid + IMPLICIT NONE + + ! ---- Instance ---- + TYPE(grid_type) :: gcrop + INTEGER, allocatable :: cropclass (:) + REAL(r8), allocatable :: pctshrpch (:) + +CONTAINS + + ! ------------------------------- + SUBROUTINE landcrop_build (lc_year) + + USE MOD_SPMD_Task + USE MOD_Namelist + USE MOD_Block + USE MOD_DataType + USE MOD_LandElm +#ifdef CATCHMENT + USE MOD_LandHRU +#endif + USE MOD_LandPatch + USE MOD_NetCDFBlock + USE MOD_PixelsetShared + USE MOD_5x5DataReadin +#ifdef SinglePoint + USE MOD_SingleSrfdata +#endif + + IMPLICIT NONE + + INTEGER, intent(in) :: lc_year + + ! Local Variables + CHARACTER(len=255) :: cyear, file_patch, dir_5x5, suffix + INTEGER :: npatch_glb + TYPE(block_data_real8_2d) :: pctcrop_xy + TYPE(block_data_real8_3d) :: pctshared_xy + TYPE(block_data_real8_3d) :: cropdata + INTEGER :: sharedfilter(1), cropfilter(1) + integer :: iblkme, ib, jb + real(r8), allocatable :: pctshared (:) + integer , allocatable :: classshared(:) + + write(cyear,'(i4.4)') lc_year + IF (p_is_master) THEN + write(*,'(A)') 'Making patches (crop shared) :' + ENDIF + +#if (defined SinglePoint && defined CROP) + IF ((SITE_landtype == CROPLAND) .and. (USE_SITE_pctcrop)) THEN + + numpatch = count(SITE_pctcrop > 0.) + + allocate (pctshrpch (numpatch)) + allocate (cropclass(numpatch)) + cropclass = pack(SITE_croptyp, SITE_pctcrop > 0.) + pctshrpch = pack(SITE_pctcrop, SITE_pctcrop > 0.) + + pctshrpch = pctshrpch / sum(pctshrpch) + + allocate (landpatch%eindex (numpatch)) + allocate (landpatch%ipxstt (numpatch)) + allocate (landpatch%ipxend (numpatch)) + allocate (landpatch%settyp (numpatch)) + allocate (landpatch%ielm (numpatch)) + + landpatch%eindex(:) = 1 + landpatch%ielm (:) = 1 + landpatch%ipxstt(:) = 1 + landpatch%ipxend(:) = 1 + landpatch%settyp(:) = CROPLAND + + landpatch%nset = numpatch + CALL landpatch%set_vecgs + + RETURN + ENDIF +#endif + +#ifdef USEMPI + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + IF (p_is_io) THEN + + dir_5x5 = trim(DEF_dir_rawdata) // '/plant_15s' + suffix = 'MOD'//trim(cyear) + + CALL allocate_block_data (gpatch, pctcrop_xy) + CALL read_5x5_data (dir_5x5, suffix, gpatch, 'PCT_CROP', pctcrop_xy) + + CALL allocate_block_data (gpatch, pctshared_xy, 2) + DO iblkme = 1, gblock%nblkme + ib = gblock%xblkme(iblkme) + jb = gblock%yblkme(iblkme) + pctshared_xy%blk(ib,jb)%val(1,:,:) = 1. - pctcrop_xy%blk(ib,jb)%val/100. + pctshared_xy%blk(ib,jb)%val(2,:,:) = pctcrop_xy%blk(ib,jb)%val/100. + ENDDO + ENDIF + + sharedfilter = (/ 1 /) + + CALL pixelsetshared_build (landpatch, gpatch, pctshared_xy, 2, sharedfilter, & + pctshared, classshared) + + IF (p_is_worker) THEN + IF (landpatch%nset > 0) THEN + WHERE (classshared == 2) landpatch%settyp = CROPLAND + ENDIF + ENDIF + + IF (p_is_io) THEN + file_patch = trim(DEF_dir_rawdata) // '/global_CFT_surface_data.nc' + CALL allocate_block_data (gcrop, cropdata, N_CFT) + CALL ncio_read_block (file_patch, 'PCT_CFT', gcrop, N_CFT, cropdata) + ENDIF + + cropfilter = (/ CROPLAND /) + + CALL pixelsetshared_build (landpatch, gcrop, cropdata, N_CFT, cropfilter, & + pctshrpch, cropclass, fracin = pctshared) + + numpatch = landpatch%nset + + IF (allocated(pctshared )) deallocate(pctshared ) + IF (allocated(classshared)) deallocate(classshared) + +#ifdef USEMPI + IF (p_is_worker) THEN + CALL mpi_reduce (numpatch, npatch_glb, 1, MPI_INTEGER, MPI_SUM, p_root, p_comm_worker, p_err) + IF (p_iam_worker == 0) THEN + write(*,'(A,I12,A)') 'Total: ', npatch_glb, ' patches (with crop).' + ENDIF + ENDIF + + CALL mpi_barrier (p_comm_glb, p_err) +#else + write(*,'(A,I12,A)') 'Total: ', numpatch, ' patches.' +#endif + + CALL elm_patch%build (landelm, landpatch, use_frac = .true., sharedfrac = pctshrpch) +#ifdef CATCHMENT + CALL hru_patch%build (landhru, landpatch, use_frac = .true., sharedfrac = pctshrpch) +#endif + + CALL write_patchfrac (DEF_dir_landdata, lc_year) + + END SUBROUTINE landcrop_build + +END MODULE MOD_LandCrop +#endif diff --git a/mksrfdata/MOD_LandHRU.F90 b/mksrfdata/MOD_LandHRU.F90 index 20de0c8b..64ca13dd 100644 --- a/mksrfdata/MOD_LandHRU.F90 +++ b/mksrfdata/MOD_LandHRU.F90 @@ -57,8 +57,9 @@ SUBROUTINE landhru_build () ! Local Variables TYPE (block_data_int32_2d) :: hrudata INTEGER :: iwork, ncat, nhru, ie, typsgn, npxl, ipxl - integer, allocatable :: numhru_all_g(:), catnum(:), lakeid(:) - INTEGER, allocatable :: types(:), order(:), ibuff(:) + integer*8, allocatable :: catnum(:) + integer, allocatable :: numhru_all_g(:), lakeid(:) + INTEGER, allocatable :: types(:), order(:), ibuff(:) INTEGER :: nhru_glb #ifdef USEMPI @@ -85,7 +86,7 @@ SUBROUTINE landhru_build () allocate (catnum(ncat)) allocate (ibuff (ncat)) - call mpi_recv (catnum, ncat, MPI_INTEGER4, p_address_worker(iwork), mpi_tag_data, & + call mpi_recv (catnum, ncat, MPI_INTEGER8, p_address_worker(iwork), mpi_tag_data, & p_comm_glb, p_stat, p_err) nhru = sum(numhru_all_g(catnum)) @@ -106,7 +107,7 @@ SUBROUTINE landhru_build () call mpi_send (numelm, 1, MPI_INTEGER4, p_root, mpi_tag_size, p_comm_glb, p_err) IF (numelm > 0) THEN allocate (lakeid (numelm)) - call mpi_send (landelm%eindex, numelm, MPI_INTEGER4, p_root, mpi_tag_data, p_comm_glb, p_err) + call mpi_send (landelm%eindex, numelm, MPI_INTEGER8, p_root, mpi_tag_data, p_comm_glb, p_err) call mpi_recv (numhru, 1, MPI_INTEGER4, p_root, mpi_tag_size, p_comm_glb, p_stat, p_err) call mpi_recv (lakeid, numelm, MPI_INTEGER4, p_root, mpi_tag_data, p_comm_glb, p_stat, p_err) ENDIF @@ -150,7 +151,7 @@ SUBROUTINE landhru_build () allocate (types (1:npxl)) - CALL aggregation_request_data (landelm, ie, ghru, & + CALL aggregation_request_data (landelm, ie, ghru, zip = .false., & data_i4_2d_in1 = hrudata, data_i4_2d_out1 = ibuff) types = ibuff diff --git a/mksrfdata/MOD_LandPC.F90 b/mksrfdata/MOD_LandPC.F90 deleted file mode 100644 index bf1ef531..00000000 --- a/mksrfdata/MOD_LandPC.F90 +++ /dev/null @@ -1,185 +0,0 @@ -#include - -#ifdef LULC_IGBP_PC - -MODULE MOD_LandPC - - !------------------------------------------------------------------------------------ - ! DESCRIPTION: - ! - ! Build pixelset "landpc" (Plant Community). - ! - ! In CoLM, the global/regional area is divided into a hierarchical structure: - ! 1. If GRIDBASED or UNSTRUCTURED is defined, it is - ! ELEMENT >>> PATCH - ! 2. If CATCHMENT is defined, it is - ! ELEMENT >>> HRU >>> PATCH - ! If Plant Function Type classification is used, PATCH is further divided into PFT. - ! If Plant Community classification is used, PATCH is further divided into PC. - ! - ! "landpc" refers to pixelset PC. - ! - ! Created by Shupeng Zhang, May 2023 - ! porting codes from Hua Yuan's OpenMP version to MPI parallel version. - !------------------------------------------------------------------------------------ - - USE MOD_Pixelset - IMPLICIT NONE - - ! ---- Instance ---- - INTEGER :: numpc - TYPE(pixelset_type) :: landpc - - INTEGER, allocatable :: patch2pc(:) !projection from patch to PC - INTEGER, allocatable :: pc2patch(:) !projection from PC to patch - -CONTAINS - - ! ------------------------------- - SUBROUTINE landpc_build (lc_year) - - USE MOD_Precision - USE MOD_SPMD_Task - USE MOD_LandPatch - USE MOD_Const_LC - IMPLICIT NONE - - INTEGER, intent(in) :: lc_year - - ! Local Variables - INTEGER :: ipatch, ipc, npc, m, npc_glb - - IF (p_is_master) THEN - write(*,'(A)') 'Making land plant community tiles :' - ENDIF - -#ifdef SinglePoint - IF (patchtypes(SITE_landtype) == 0) THEN - numpc = 1 - allocate (patch2pc (1)) - allocate (pc2patch (1)) - patch2pc(1) = 1 - pc2patch(1) = 1 - - allocate (landpc%eindex (numpc)) - allocate (landpc%settyp (numpc)) - allocate (landpc%ipxstt (numpc)) - allocate (landpc%ipxend (numpc)) - allocate (landpc%ielm (numpc)) - - landpc%eindex(1) = 1 - landpc%ipxstt(1) = 1 - landpc%ipxend(1) = 1 - landpc%settyp(1) = SITE_landtype - landpc%ielm (1) = 1 - ELSE - numpc = 0 - ENDIF - - landpc%nset = numpc - CALL landpc%set_vecgs - - RETURN -#endif - - if (p_is_worker) then - - numpc = 0 - - DO ipatch = 1, numpatch - m = landpatch%settyp(ipatch) - IF (patchtypes(m) == 0) THEN - numpc = numpc + 1 - ENDIF - ENDDO - - IF (numpc > 0) THEN - - allocate (pc2patch (numpc )) - allocate (patch2pc (numpatch)) - - patch2pc(:) = -1 - - allocate (landpc%eindex (numpc)) - allocate (landpc%settyp (numpc)) - allocate (landpc%ipxstt (numpc)) - allocate (landpc%ipxend (numpc)) - allocate (landpc%ielm (numpc)) - - npc = 0 - DO ipatch = 1, numpatch - m = landpatch%settyp(ipatch) - IF (patchtypes(m) == 0) THEN - - npc = npc + 1 - - landpc%ielm (npc) = landpatch%ielm (ipatch) - landpc%eindex(npc) = landpatch%eindex(ipatch) - landpc%ipxstt(npc) = landpatch%ipxstt(ipatch) - landpc%ipxend(npc) = landpatch%ipxend(ipatch) - landpc%settyp(npc) = m - - pc2patch(npc) = ipatch - patch2pc(ipatch) = npc - - ENDIF - ENDDO - ENDIF - ENDIF - - landpc%nset = numpc - CALL landpc%set_vecgs - -#ifdef USEMPI - IF (p_is_worker) THEN - CALL mpi_reduce (numpc, npc_glb, 1, MPI_INTEGER, MPI_SUM, p_root, p_comm_worker, p_err) - IF (p_iam_worker == 0) THEN - write(*,'(A,I12,A)') 'Total: ', npc_glb, ' plant community tiles.' - ENDIF - ENDIF - - CALL mpi_barrier (p_comm_glb, p_err) -#else - write(*,'(A,I12,A)') 'Total: ', numpc, ' plant community tiles.' -#endif - - END SUBROUTINE landpc_build - - ! ---------------------- - SUBROUTINE map_patch_to_pc - - USE MOD_SPMD_Task - USE MOD_LandPatch - USE MOD_Const_LC - IMPLICIT NONE - - INTEGER :: ipatch, ipc - - IF (p_is_worker) THEN - - IF ((numpatch <= 0) .or. (numpc <= 0)) return - - IF (allocated(pc2patch)) deallocate(pc2patch) - IF (allocated(patch2pc)) deallocate(patch2pc) - - allocate (pc2patch (numpc )) - allocate (patch2pc (numpatch)) - - ipc = 0 - DO ipatch = 1, numpatch - IF (patchtypes(landpatch%settyp(ipatch)) == 0) THEN - ipc = ipc + 1 - patch2pc(ipatch) = ipc - pc2patch(ipc) = ipatch - ELSE - patch2pc(ipatch) = -1 - ENDIF - ENDDO - - ENDIF - - END SUBROUTINE map_patch_to_pc - -END MODULE MOD_LandPC - -#endif diff --git a/mksrfdata/MOD_LandPFT.F90 b/mksrfdata/MOD_LandPFT.F90 index 630a5ff9..7723a35f 100644 --- a/mksrfdata/MOD_LandPFT.F90 +++ b/mksrfdata/MOD_LandPFT.F90 @@ -1,6 +1,6 @@ #include -#ifdef LULC_IGBP_PFT +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) MODULE MOD_LandPFT @@ -16,7 +16,7 @@ MODULE MOD_LandPFT ! ELEMENT >>> HRU >>> PATCH ! If Plant Function Type classification is used, PATCH is further divided into PFT. ! If Plant Community classification is used, PATCH is further divided into PC. - ! + ! ! "landpft" refers to pixelset PFT. ! ! Created by Shupeng Zhang, May 2023 @@ -54,6 +54,9 @@ SUBROUTINE landpft_build (lc_year) USE MOD_LandPatch USE MOD_AggregationRequestData USE MOD_Const_LC +#ifdef CROP + USE MOD_LandCrop +#endif IMPLICIT NONE @@ -74,7 +77,11 @@ SUBROUTINE landpft_build (lc_year) #ifdef SinglePoint IF (USE_SITE_pctpfts) THEN - IF (landpatch%settyp(1) == 1) THEN +#ifndef CROP + IF (patchtypes(landpatch%settyp(1)) == 0) THEN +#else + IF (patchtypes(landpatch%settyp(1)) == 0 .and. landpatch%settyp(1)/=CROPLAND) THEN +#endif numpft = count(SITE_pctpfts > 0.) #ifdef CROP ELSEIF (landpatch%settyp(1) == CROPLAND) THEN @@ -101,7 +108,11 @@ SUBROUTINE landpft_build (lc_year) allocate(pft2patch (numpft)) - IF (landpatch%settyp(1) == 1) THEN +#ifndef CROP + IF (patchtypes(landpatch%settyp(1)) == 0) THEN +#else + IF (patchtypes(landpatch%settyp(1)) == 0 .and. landpatch%settyp(1)/=CROPLAND) THEN +#endif landpft%settyp = pack(SITE_pfttyp, SITE_pctpfts > 0.) pft2patch (:) = 1 @@ -118,7 +129,7 @@ SUBROUTINE landpft_build (lc_year) #endif ENDIF ELSE - write(*,*) 'Warning : land type ', landpatch%settyp(1), ' for LULC_IGBP_PFT' + write(*,*) 'Warning : land type ', landpatch%settyp(1), ' for LULC_IGBP_PFT|LULC_IGBP_PC' patch_pft_s(:) = -1 patch_pft_e(:) = -1 ENDIF @@ -162,20 +173,25 @@ SUBROUTINE landpft_build (lc_year) ENDIF DO ipatch = 1, numpatch - IF (landpatch%settyp(ipatch) == 1) THEN - - CALL aggregation_request_data (landpatch, ipatch, gpatch, area = area_one, & + !IF (landpatch%settyp(ipatch) == 1) THEN +#ifndef CROP + IF (patchtypes(landpatch%settyp(ipatch)) == 0) THEN +#else + IF (patchtypes(landpatch%settyp(ipatch)) == 0 .and. landpatch%settyp(ipatch)/=CROPLAND) THEN +#endif + CALL aggregation_request_data (landpatch, ipatch, gpatch, zip = .false., area = area_one, & data_r8_3d_in1 = pctpft, data_r8_3d_out1 = pctpft_one, n1_r8_3d_in1 = N_PFT_modis, lb1_r8_3d_in1 = 0) - sumarea = sum(area_one) - - DO ipft = 0, N_PFT-1 - pctpft_patch(ipft,ipatch) = sum(pctpft_one(ipft,:) * area_one) / sumarea - ENDDO + sumarea = sum(area_one * sum(pctpft_one(0:N_PFT-1,:),dim=1)) - IF (sum(pctpft_patch(:,ipatch)) <= 0.0) THEN + IF (sumarea <= 0.0) THEN patchmask(ipatch) = .false. + ELSE + DO ipft = 0, N_PFT-1 + pctpft_patch(ipft,ipatch) = sum(pctpft_one(ipft,:) * area_one) / sumarea + ENDDO ENDIF + ENDIF ENDDO @@ -199,7 +215,7 @@ SUBROUTINE landpft_build (lc_year) IF (numpft > 0) THEN - allocate (pft2patch (numpft)) + allocate (pft2patch (numpft)) allocate (landpft%eindex (numpft)) allocate (landpft%settyp (numpft)) @@ -213,7 +229,12 @@ SUBROUTINE landpft_build (lc_year) IF (patchmask(ipatch)) THEN npatch = npatch + 1 - IF (landpatch%settyp(ipatch) == 1) THEN + !IF (landpatch%settyp(ipatch) == 1) THEN +#ifndef CROP + IF (patchtypes(landpatch%settyp(ipatch)) == 0) THEN +#else + IF (patchtypes(landpatch%settyp(ipatch)) == 0 .and. landpatch%settyp(ipatch)/=CROPLAND) THEN +#endif patch_pft_s(npatch) = npft + 1 patch_pft_e(npatch) = npft + count(pctpft_patch(:,ipatch) > 0) @@ -290,6 +311,7 @@ SUBROUTINE map_patch_to_pft USE MOD_SPMD_Task USE MOD_LandPatch + USE MOD_Const_LC IMPLICIT NONE INTEGER :: ipatch, ipft @@ -308,13 +330,19 @@ SUBROUTINE map_patch_to_pft ipft = 1 DO ipatch = 1, numpatch - IF (landpatch%settyp(ipatch) == 1) THEN + !IF (landpatch%settyp(ipatch) == 1) THEN +#ifndef CROP + IF (patchtypes(landpatch%settyp(ipatch)) == 0) THEN +#else + IF (patchtypes(landpatch%settyp(ipatch)) == 0 .and. landpatch%settyp(ipatch)/=CROPLAND) THEN +#endif patch_pft_s(ipatch) = ipft DO WHILE (ipft <= numpft) IF ((landpft%eindex(ipft) == landpatch%eindex(ipatch)) & - .and. (landpft%ipxstt(ipft) == landpatch%ipxstt(ipatch))) THEN + .and. (landpft%ipxstt(ipft) == landpatch%ipxstt(ipatch)) & + .and. (landpft%settyp(ipft) < N_PFT)) THEN pft2patch (ipft ) = ipatch patch_pft_e(ipatch) = ipft ipft = ipft + 1 diff --git a/mksrfdata/MOD_LandPatch.F90 b/mksrfdata/MOD_LandPatch.F90 index b0145775..55a41232 100644 --- a/mksrfdata/MOD_LandPatch.F90 +++ b/mksrfdata/MOD_LandPatch.F90 @@ -14,7 +14,7 @@ MODULE MOD_LandPatch ! ELEMENT >>> HRU >>> PATCH ! If Plant Function Type classification is used, PATCH is further divided into PFT. ! If Plant Community classification is used, PATCH is further divided into PC. - ! + ! ! "landpatch" refers to pixelset PATCH. ! ! Created by Shupeng Zhang, May 2023 @@ -36,12 +36,6 @@ MODULE MOD_LandPatch TYPE(grid_type) :: gpatch TYPE(pixelset_type) :: landpatch -#if (defined CROP) - TYPE(grid_type) :: gcrop - REAL(r8), allocatable :: pctcrop (:) - INTEGER, allocatable :: cropclass (:) -#endif - TYPE(subset_type) :: elm_patch TYPE(superset_type) :: patch2elm @@ -68,9 +62,6 @@ SUBROUTINE landpatch_build (lc_year) #endif USE MOD_Namelist USE MOD_NetCDFBlock -#if (defined CROP) - USE MOD_PixelsetShadow -#endif USE MOD_AggregationRequestData IMPLICIT NONE @@ -82,14 +73,11 @@ SUBROUTINE landpatch_build (lc_year) TYPE (block_data_int32_2d) :: patchdata INTEGER :: iloc, npxl, ipxl, numset INTEGER :: ie, iset, ipxstt, ipxend - INTEGER, allocatable :: types(:), order(:), ibuff(:) - INTEGER, allocatable :: eindex_tmp(:), settyp_tmp(:), ipxstt_tmp(:), ipxend_tmp(:), ielm_tmp(:) - LOGICAL, allocatable :: msk(:) + INTEGER, allocatable :: types(:), order(:), ibuff(:) + INTEGER*8, allocatable :: eindex_tmp(:) + INTEGER, allocatable :: settyp_tmp(:), ipxstt_tmp(:), ipxend_tmp(:), ielm_tmp(:) + LOGICAL, allocatable :: msk(:) INTEGER :: npatch_glb -#if (defined CROP) - TYPE(block_data_real8_3d) :: cropdata - INTEGER :: cropfilter(1) -#endif INTEGER :: dominant_type INTEGER, allocatable :: npxl_types (:) @@ -98,35 +86,31 @@ SUBROUTINE landpatch_build (lc_year) write(*,'(A)') 'Making land patches :' ENDIF -#if (defined SinglePoint && defined LULC_IGBP_PFT && defined CROP) - IF ((SITE_landtype == CROPLAND) .and. (USE_SITE_pctcrop)) THEN - - numpatch = count(SITE_pctcrop > 0.) - - allocate (pctcrop (numpatch)) - allocate (cropclass(numpatch)) - cropclass = pack(SITE_croptyp, SITE_pctcrop > 0.) - pctcrop = pack(SITE_pctcrop, SITE_pctcrop > 0.) +#ifdef SinglePoint +#ifdef CROP + IF ((SITE_landtype == CROPLAND) .and. USE_SITE_pctcrop) THEN + RETURN + ENDIF +#endif - pctcrop = pctcrop / sum(pctcrop) + numpatch = 1 - allocate (landpatch%eindex (numpatch)) - allocate (landpatch%ipxstt (numpatch)) - allocate (landpatch%ipxend (numpatch)) - allocate (landpatch%settyp (numpatch)) - allocate (landpatch%ielm (numpatch)) + allocate (landpatch%eindex (numpatch)) + allocate (landpatch%ipxstt (numpatch)) + allocate (landpatch%ipxend (numpatch)) + allocate (landpatch%settyp (numpatch)) + allocate (landpatch%ielm (numpatch)) - landpatch%eindex(:) = 1 - landpatch%ielm (:) = 1 - landpatch%ipxstt(:) = 1 - landpatch%ipxend(:) = 1 - landpatch%settyp(:) = CROPLAND + landpatch%eindex(:) = 1 + landpatch%ielm (:) = 1 + landpatch%ipxstt(:) = 1 + landpatch%ipxend(:) = 1 + landpatch%settyp(:) = SITE_landtype - landpatch%nset = numpatch - CALL landpatch%set_vecgs + landpatch%nset = numpatch + CALL landpatch%set_vecgs - RETURN - ENDIF + RETURN #endif #ifdef USEMPI @@ -187,9 +171,9 @@ SUBROUTINE landpatch_build (lc_year) #ifndef SinglePoint #ifdef CATCHMENT - CALL aggregation_request_data (landhru, iset, gpatch, & + CALL aggregation_request_data (landhru, iset, gpatch, zip = .false., & #else - CALL aggregation_request_data (landelm, iset, gpatch, & + CALL aggregation_request_data (landelm, iset, gpatch, zip = .false., & #endif data_i4_2d_in1 = patchdata, data_i4_2d_out1 = ibuff) @@ -204,26 +188,26 @@ SUBROUTINE landpatch_build (lc_year) IF (landhru%settyp(iset) <= 0) THEN types(ipxstt:ipxend) = WATERBODY ENDIF + WHERE (types == 0) + ! set land in MERITHydro while ocean in landtype data as water body + types = WATERBODY + END WHERE + WHERE (types == 11) + types = 10 + END WHERE #endif -#ifdef LULC_IGBP_PFT - ! For classification of plant function types, merge all land types with soil ground - DO ipxl = ipxstt, ipxend - IF (types(ipxl) > 0) THEN - IF (patchtypes(types(ipxl)) == 0) THEN -#if (defined CROP) - !12 Croplands - !14 Cropland/Natural Vegetation Mosaics ? - IF (types(ipxl) /= CROPLAND) THEN + IF ((DEF_USE_PFT .and. (.not. DEF_SOLO_PFT)) .or. DEF_FAST_PC) THEN + ! For classification of plant function types or fast PC, + ! merge all land types with soil ground + DO ipxl = ipxstt, ipxend + IF (types(ipxl) > 0) THEN + IF (patchtypes(types(ipxl)) == 0) THEN types(ipxl) = 1 ENDIF -#else - types(ipxl) = 1 -#endif ENDIF - ENDIF - ENDDO -#endif + ENDDO + ENDIF allocate (order (ipxstt:ipxend)) order = (/ (ipxl, ipxl = ipxstt, ipxend) /) @@ -316,25 +300,7 @@ SUBROUTINE landpatch_build (lc_year) IF (allocated(msk)) deallocate(msk) ENDIF -#ifdef URBAN_MODEL - continue -#else -#if (defined CROP) - IF (p_is_io) THEN -! file_patch = trim(DEF_dir_rawdata) // '/global_0.5x0.5.MOD2005_V4.5_CFT_mergetoclmpft.nc' - file_patch = trim(DEF_dir_rawdata) // '/global_0.5x0.5.MOD2005_V4.5_CFT_lf-merged-20220930.nc' - CALL allocate_block_data (gcrop, cropdata, N_CFT) - CALL ncio_read_block (file_patch, 'PCT_CFT', gcrop, N_CFT, cropdata) - ENDIF - - cropfilter = (/ CROPLAND /) - - CALL pixelsetshadow_build (landpatch, gcrop, cropdata, N_CFT, cropfilter, & - pctcrop, cropclass) - - numpatch = landpatch%nset -#endif - +#if (!defined(URBAN_MODEL) && !defined(CROP)) #ifdef USEMPI IF (p_is_worker) THEN CALL mpi_reduce (numpatch, npatch_glb, 1, MPI_INTEGER, MPI_SUM, p_root, p_comm_worker, p_err) @@ -348,22 +314,14 @@ SUBROUTINE landpatch_build (lc_year) write(*,'(A,I12,A)') 'Total: ', numpatch, ' patches.' #endif -#if (defined CROP) - CALL elm_patch%build (landelm, landpatch, use_frac = .true., shadowfrac = pctcrop) -#else CALL elm_patch%build (landelm, landpatch, use_frac = .true.) -#endif - #ifdef CATCHMENT -#if (defined CROP) - CALL hru_patch%build (landhru, landpatch, use_frac = .true., shadowfrac = pctcrop) -#else CALL hru_patch%build (landhru, landpatch, use_frac = .true.) -#endif #endif CALL write_patchfrac (DEF_dir_landdata, lc_year) #endif + END SUBROUTINE landpatch_build ! ----- diff --git a/mksrfdata/MOD_LandUrban.F90 b/mksrfdata/MOD_LandUrban.F90 index fad99079..625c2f20 100644 --- a/mksrfdata/MOD_LandUrban.F90 +++ b/mksrfdata/MOD_LandUrban.F90 @@ -16,6 +16,10 @@ MODULE MOD_LandUrban USE MOD_Grid USE MOD_Pixelset USE MOD_Vars_Global, only: N_URB, URBAN +#ifdef SinglePoint + USE MOD_SingleSrfdata +#endif + IMPLICIT NONE ! ---- Instance ---- @@ -38,6 +42,7 @@ MODULE MOD_LandUrban SUBROUTINE landurban_build (lc_year) USE MOD_Precision + USE MOD_Vars_Global USE MOD_SPMD_Task USE MOD_NetCDFBlock USE MOD_Grid @@ -49,9 +54,6 @@ SUBROUTINE landurban_build (lc_year) USE MOD_LandElm #ifdef CATCHMENT USE MOD_LandHRU -#endif -#if (defined CROP) - USE MOD_PixelsetShadow #endif USE MOD_AggregationRequestData USE MOD_Utils @@ -63,11 +65,6 @@ SUBROUTINE landurban_build (lc_year) CHARACTER(len=256) :: dir_urban TYPE (block_data_int32_2d) :: data_urb_class ! urban type index -#if (defined CROP) - TYPE(block_data_real8_3d) :: cropdata - INTEGER :: cropfilter(1) - CHARACTER(len=256) :: file_patch -#endif ! local vars INTEGER, allocatable :: ibuff(:), types(:), order(:) @@ -78,11 +75,11 @@ SUBROUTINE landurban_build (lc_year) ! local vars for landpath and landurban INTEGER :: numpatch_ - INTEGER, allocatable :: eindex_(:) - INTEGER, allocatable :: ipxstt_(:) - INTEGER, allocatable :: ipxend_(:) - INTEGER, allocatable :: settyp_(:) - INTEGER, allocatable :: ielm_ (:) + INTEGER*8, allocatable :: eindex_(:) + INTEGER, allocatable :: ipxstt_(:) + INTEGER, allocatable :: ipxend_(:) + INTEGER, allocatable :: settyp_(:) + INTEGER, allocatable :: ielm_ (:) INTEGER :: numurban_ INTEGER, allocatable :: urbclass (:) @@ -100,20 +97,20 @@ SUBROUTINE landurban_build (lc_year) ! allocate and read the grided LCZ/NCAR urban type if (p_is_io) then - dir_urban = trim(DEF_dir_rawdata) // '/urban' + dir_urban = trim(DEF_dir_rawdata) // '/urban_type' CALL allocate_block_data (gurban, data_urb_class) CALL flush_block_data (data_urb_class, 0) - write(cyear,'(i4.4)') int(lc_year/5)*5 - suffix = 'URB'//trim(cyear) -#ifdef URBAN_LCZ - CALL read_5x5_data (dir_urban, suffix, gurban, 'LCZ', data_urb_class) -#else + !write(cyear,'(i4.4)') int(lc_year/5)*5 + suffix = 'URBTYP' +IF (DEF_URBAN_type_scheme == 1) THEN ! NOTE!!! ! region id is assigned in aggreagation_urban.F90 now CALL read_5x5_data (dir_urban, suffix, gurban, 'URBAN_DENSITY_CLASS', data_urb_class) -#endif +ELSE IF (DEF_URBAN_type_scheme == 2) THEN + CALL read_5x5_data (dir_urban, suffix, gurban, 'LCZ_DOM', data_urb_class) +ENDIF #ifdef USEMPI CALL aggregation_data_daemon (gurban, data_i4_2d_in1 = data_urb_class) @@ -151,21 +148,21 @@ SUBROUTINE landurban_build (lc_year) ipxstt = landpatch%ipxstt(ipatch) ipxend = landpatch%ipxend(ipatch) - CALL aggregation_request_data (landpatch, ipatch, gurban, & + CALL aggregation_request_data (landpatch, ipatch, gurban, zip = .false., & data_i4_2d_in1 = data_urb_class, data_i4_2d_out1 = ibuff) -#ifndef URBAN_LCZ +IF (DEF_URBAN_type_scheme == 1) THEN ! Some urban patches and NCAR data are inconsistent (NCAR has no urban ID), ! so the these points are assigned by the 3(medium density), or can define by ueser where (ibuff < 1 .or. ibuff > 3) ibuff = 3 END where -#else +ELSE IF(DEF_URBAN_type_scheme == 2) THEN ! Same for NCAR, fill the gap LCZ class of urban patch if LCZ data is non-urban - where (ibuff > 10) + where (ibuff > 10 .or. ibuff == 0) ibuff = 9 END where -#endif +ENDIF npxl = ipxend - ipxstt + 1 @@ -298,22 +295,49 @@ SUBROUTINE landurban_build (lc_year) write(*,'(A,I12,A)') 'Total: ', numurban, ' urban tiles.' #endif -#if (defined CROP) - IF (p_is_io) THEN - !file_patch = trim(DEF_dir_rawdata) // '/global_0.5x0.5.MOD2005_V4.5_CFT_mergetoclmpft.nc' - file_patch = trim(DEF_dir_rawdata) // '/global_0.5x0.5.MOD2005_V4.5_CFT_lf-merged-20220930.nc' - CALL allocate_block_data (gcrop, cropdata, N_CFT) - CALL ncio_read_block (file_patch, 'PCT_CFT', gcrop, N_CFT, cropdata) - ENDIF - - cropfilter = (/ CROPLAND /) - - CALL pixelsetshadow_build (landpatch, gcrop, cropdata, N_CFT, cropfilter, & - pctcrop, cropclass) - - numpatch = landpatch%nset +#ifdef SinglePoint + + allocate ( SITE_urbtyp (numurban) ) + allocate ( SITE_lucyid (numurban) ) + +IF (.not. USE_SITE_urban_paras) THEN + allocate ( SITE_fveg_urb (numurban) ) + allocate ( SITE_htop_urb (numurban) ) + allocate ( SITE_flake_urb(numurban) ) + + allocate ( SITE_popden (numurban) ) + allocate ( SITE_froof (numurban) ) + allocate ( SITE_hroof (numurban) ) + allocate ( SITE_hwr (numurban) ) + allocate ( SITE_fgper (numurban) ) + allocate ( SITE_fgimp (numurban) ) +ENDIF + + allocate ( SITE_em_roof (numurban) ) + allocate ( SITE_em_wall (numurban) ) + allocate ( SITE_em_gimp (numurban) ) + allocate ( SITE_em_gper (numurban) ) + allocate ( SITE_t_roommax(numurban) ) + allocate ( SITE_t_roommin(numurban) ) + allocate ( SITE_thickroof(numurban) ) + allocate ( SITE_thickwall(numurban) ) + + allocate ( SITE_cv_roof (nl_roof) ) + allocate ( SITE_cv_wall (nl_wall) ) + allocate ( SITE_cv_gimp (nl_soil) ) + allocate ( SITE_tk_roof (nl_roof) ) + allocate ( SITE_tk_wall (nl_wall) ) + allocate ( SITE_tk_gimp (nl_soil) ) + + allocate ( SITE_alb_roof (2, 2) ) + allocate ( SITE_alb_wall (2, 2) ) + allocate ( SITE_alb_gimp (2, 2) ) + allocate ( SITE_alb_gper (2, 2) ) + + SITE_urbtyp(:) = landurban%settyp #endif +#ifndef CROP #ifdef USEMPI IF (p_is_worker) THEN CALL mpi_reduce (numpatch, npatch_glb, 1, MPI_INTEGER, MPI_SUM, p_root, p_comm_worker, p_err) @@ -327,21 +351,12 @@ SUBROUTINE landurban_build (lc_year) write(*,'(A,I12,A)') 'Total: ', numpatch, ' patches.' #endif -#if (defined CROP) - CALL elm_patch%build (landelm, landpatch, use_frac = .true., shadowfrac = pctcrop) -#else CALL elm_patch%build (landelm, landpatch, use_frac = .true.) -#endif - #ifdef CATCHMENT -#if (defined CROP) - CALL hru_patch%build (landhru, landpatch, use_frac = .true., shadowfrac = pctcrop) -#else CALL hru_patch%build (landhru, landpatch, use_frac = .true.) #endif -#endif - CALL write_patchfrac (DEF_dir_landdata, lc_year) +#endif IF (allocated(ibuff)) deallocate (ibuff) IF (allocated(types)) deallocate (types) diff --git a/mksrfdata/MOD_MeshFilter.F90 b/mksrfdata/MOD_MeshFilter.F90 index d89bbf2a..38126f7e 100644 --- a/mksrfdata/MOD_MeshFilter.F90 +++ b/mksrfdata/MOD_MeshFilter.F90 @@ -90,7 +90,7 @@ SUBROUTINE mesh_filter (gridf, ffilter, fvname) jelm = 0 DO ielm = 1, numelm - CALL aggregation_request_data (landelm, ielm, gridf, & + CALL aggregation_request_data (landelm, ielm, gridf, zip = .false., & data_i4_2d_in1 = datafilter, data_i4_2d_out1 = ifilter, & filledvalue_i4 = -1) diff --git a/mksrfdata/MOD_PixelsetShadow.F90 b/mksrfdata/MOD_PixelsetShared.F90 similarity index 61% rename from mksrfdata/MOD_PixelsetShadow.F90 rename to mksrfdata/MOD_PixelsetShared.F90 index 6fdae842..eb0ecd6e 100644 --- a/mksrfdata/MOD_PixelsetShadow.F90 +++ b/mksrfdata/MOD_PixelsetShared.F90 @@ -1,23 +1,23 @@ #include -MODULE MOD_PixelsetShadow +MODULE MOD_PixelsetShared !---------------------------------------------------------------------------------------- ! DESCRIPTION: ! - ! Shadows of pixelset refer to two or more pixelsets sharing the same geographic area. + ! Shared pixelset refer to two or more pixelsets sharing the same geographic area. ! ! For example, for patch of crops, multiple crops can be planted on a piece of land. ! When planting these crops, different irrigation schemes may be used. Thus the water ! and energy processes have difference in crops and should be modeled independently. - ! By using shadows, crop patch is splitted to two or more shadowed patches. - ! Each shadow is assigned with a percentage of area and has its own states. + ! By using shared pixelset, crop patch is splitted to two or more shared patches. + ! Each shared patch is assigned with a percentage of area and has its own states. ! - ! Example of shadowed pixelsets + ! Example of shared pixelsets ! |<------------------- ELEMENT ------------------>| <-- level 1 ! | subset 1 | subset 2 | subset 3 | <-- level 2 - ! | subset 2 shadow 1 50% | - ! | subset 2 shadow 2 20% | <-- subset 2 shadows - ! | subset 2 shadow 3 30% | + ! | subset 2 shared 1 50% | + ! | subset 2 shared 2 20% | <-- subset 2 shares + ! | subset 2 shared 3 30% | ! ! ! Created by Shupeng Zhang, May 2023 @@ -26,8 +26,8 @@ MODULE MOD_PixelsetShadow CONTAINS - SUBROUTINE pixelsetshadow_build (pixelset, gshadow, datashadow, nmaxshadow, typfilter, & - fracout, shadowclass, fracin) + SUBROUTINE pixelsetshared_build (pixelset, gshared, datashared, nmaxshared, typfilter, & + fracout, sharedclass, fracin) USE MOD_SPMD_Task USE MOD_Grid @@ -40,21 +40,22 @@ SUBROUTINE pixelsetshadow_build (pixelset, gshadow, datashadow, nmaxshadow, typf IMPLICIT NONE TYPE(pixelset_type), intent(inout) :: pixelset - TYPE(grid_type), intent(in) :: gshadow - TYPE(block_data_real8_3d), intent(in) :: datashadow - INTEGER, intent(in) :: nmaxshadow + TYPE(grid_type), intent(in) :: gshared + TYPE(block_data_real8_3d), intent(in) :: datashared + INTEGER, intent(in) :: nmaxshared INTEGER, intent(in) :: typfilter(:) REAL(r8), intent(out), allocatable :: fracout(:) - INTEGER, intent(out), allocatable :: shadowclass(:) + INTEGER, intent(out), allocatable :: sharedclass(:) REAL(r8), intent(in), optional :: fracin (:) ! Local Variables - REAL(r8), allocatable :: pctshadow(:,:) - REAL(r8), allocatable :: datashadow1d(:,:), areapixel(:), rbuff(:,:) - INTEGER :: nsetshadow, ipset, jpset - INTEGER :: ipxl, ie, ipxstt, ipxend, ishadow - INTEGER, allocatable :: eindex1(:), ielm1(:), ipxstt1(:), ipxend1(:), settyp1(:) + REAL(r8), allocatable :: pctshared(:,:) + REAL(r8), allocatable :: datashared1d(:,:), areapixel(:), rbuff(:,:) + INTEGER :: nsetshared, ipset, jpset + INTEGER :: ipxl, ie, ipxstt, ipxend, ishared + INTEGER*8,allocatable :: eindex1(:) + INTEGER, allocatable :: ielm1(:), ipxstt1(:), ipxend1(:), settyp1(:) #ifdef USEMPI CALL mpi_barrier (p_comm_glb, p_err) @@ -62,15 +63,15 @@ SUBROUTINE pixelsetshadow_build (pixelset, gshadow, datashadow, nmaxshadow, typf #ifdef USEMPI IF (p_is_io) THEN - CALL aggregation_data_daemon (gshadow, data_r8_3d_in1 = datashadow, n1_r8_3d_in1 = nmaxshadow) + CALL aggregation_data_daemon (gshared, data_r8_3d_in1 = datashared, n1_r8_3d_in1 = nmaxshared) ENDIF #endif IF (p_is_worker) THEN - nsetshadow = 0 + nsetshared = 0 - allocate (pctshadow(nmaxshadow,pixelset%nset)) + allocate (pctshared(nmaxshared,pixelset%nset)) DO ipset = 1, pixelset%nset IF (any(typfilter(:) == pixelset%settyp(ipset))) THEN @@ -79,12 +80,12 @@ SUBROUTINE pixelsetshadow_build (pixelset, gshadow, datashadow, nmaxshadow, typf ipxstt = pixelset%ipxstt(ipset) ipxend = pixelset%ipxend(ipset) - allocate (datashadow1d (nmaxshadow, ipxstt:ipxend)) + allocate (datashared1d (nmaxshared, ipxstt:ipxend)) - CALL aggregation_request_data (pixelset, ipset, gshadow, & - data_r8_3d_in1 = datashadow, data_r8_3d_out1 = rbuff, n1_r8_3d_in1 = nmaxshadow) + CALL aggregation_request_data (pixelset, ipset, gshared, zip = .false., & + data_r8_3d_in1 = datashared, data_r8_3d_out1 = rbuff, n1_r8_3d_in1 = nmaxshared) - datashadow1d = rbuff + datashared1d = rbuff allocate (areapixel(ipxstt:ipxend)) DO ipxl = ipxstt, ipxend @@ -93,21 +94,21 @@ SUBROUTINE pixelsetshadow_build (pixelset, gshadow, datashadow, nmaxshadow, typf pixel%lon_w(mesh(ie)%ilon(ipxl)), pixel%lon_e(mesh(ie)%ilon(ipxl)) ) ENDDO - DO ishadow = 1, nmaxshadow - pctshadow(ishadow,ipset) = sum(datashadow1d(ishadow,:) * areapixel) + DO ishared = 1, nmaxshared + pctshared(ishared,ipset) = sum(datashared1d(ishared,:) * areapixel) ENDDO - IF (any(pctshadow(:,ipset) > 0.)) THEN - nsetshadow = nsetshadow + count(pctshadow(:,ipset) > 0.) - pctshadow(:,ipset) = pctshadow(:,ipset) / sum(pctshadow(:,ipset)) + IF (any(pctshared(:,ipset) > 0.)) THEN + nsetshared = nsetshared + count(pctshared(:,ipset) > 0.) + pctshared(:,ipset) = pctshared(:,ipset) / sum(pctshared(:,ipset)) ENDIF deallocate (rbuff ) deallocate (areapixel ) - deallocate (datashadow1d) + deallocate (datashared1d) ELSE - nsetshadow = nsetshadow + 1 + nsetshared = nsetshared + 1 ENDIF ENDDO @@ -139,21 +140,21 @@ SUBROUTINE pixelsetshadow_build (pixelset, gshadow, datashadow, nmaxshadow, typf deallocate (pixelset%settyp) deallocate (pixelset%ielm ) - allocate (pixelset%eindex(nsetshadow)) - allocate (pixelset%ipxstt(nsetshadow)) - allocate (pixelset%ipxend(nsetshadow)) - allocate (pixelset%settyp(nsetshadow)) - allocate (pixelset%ielm (nsetshadow)) + allocate (pixelset%eindex(nsetshared)) + allocate (pixelset%ipxstt(nsetshared)) + allocate (pixelset%ipxend(nsetshared)) + allocate (pixelset%settyp(nsetshared)) + allocate (pixelset%ielm (nsetshared)) - allocate (fracout (nsetshadow)) - allocate (shadowclass(nsetshadow)) + allocate (fracout (nsetshared)) + allocate (sharedclass(nsetshared)) jpset = 0 DO ipset = 1, pixelset%nset IF (any(typfilter(:) == settyp1(ipset))) THEN - IF (any(pctshadow(:,ipset) > 0.)) THEN - DO ishadow = 1, nmaxshadow - IF (pctshadow(ishadow,ipset) > 0.) THEN + IF (any(pctshared(:,ipset) > 0.)) THEN + DO ishared = 1, nmaxshared + IF (pctshared(ishared,ipset) > 0.) THEN jpset = jpset + 1 pixelset%eindex(jpset) = eindex1(ipset) pixelset%ipxstt(jpset) = ipxstt1(ipset) @@ -162,12 +163,12 @@ SUBROUTINE pixelsetshadow_build (pixelset, gshadow, datashadow, nmaxshadow, typf pixelset%ielm (jpset) = ielm1 (ipset) IF (present(fracin)) THEN - fracout(jpset) = fracin(ipset) * pctshadow(ishadow,ipset) + fracout(jpset) = fracin(ipset) * pctshared(ishared,ipset) ELSE - fracout(jpset) = pctshadow(ishadow,ipset) + fracout(jpset) = pctshared(ishared,ipset) ENDIF - shadowclass(jpset) = ishadow + sharedclass(jpset) = ishared ENDIF ENDDO ENDIF @@ -185,18 +186,18 @@ SUBROUTINE pixelsetshadow_build (pixelset, gshadow, datashadow, nmaxshadow, typf fracout(jpset) = 1. ENDIF - shadowclass(jpset) = 0 ! no meaning + sharedclass(jpset) = 0 ! no meaning ENDIF ENDDO - pixelset%nset = nsetshadow + pixelset%nset = nsetshared deallocate (eindex1) deallocate (ipxstt1) deallocate (ipxend1) deallocate (settyp1) deallocate (ielm1 ) - deallocate (pctshadow) + deallocate (pctshared) ENDIF @@ -204,6 +205,6 @@ SUBROUTINE pixelsetshadow_build (pixelset, gshadow, datashadow, nmaxshadow, typf CALL pixelset%set_vecgs - END SUBROUTINE pixelsetshadow_build + END SUBROUTINE pixelsetshared_build -END MODULE MOD_PixelsetShadow +END MODULE MOD_PixelsetShared diff --git a/mksrfdata/MOD_RegionClip.F90 b/mksrfdata/MOD_RegionClip.F90 index 04aa4e5d..340c5fcd 100644 --- a/mksrfdata/MOD_RegionClip.F90 +++ b/mksrfdata/MOD_RegionClip.F90 @@ -32,20 +32,18 @@ SUBROUTINE srfdata_region_clip (dir_landdata_in, dir_landdata_out) CHARACTER(len=256) :: file_in, file_out, fileblock INTEGER :: iproc, iblk, jblk, ie, ipxl, ilon, ilat, i1 INTEGER :: nelm_in, nelm_out - INTEGER, allocatable :: nelm_blk(:,:), IOproc(:,:) - INTEGER, allocatable :: elmindex(:), elmnpxl(:), elmpixels(:,:,:) + INTEGER, allocatable :: nelm_blk(:,:), IOproc(:,:) + INTEGER*8, allocatable :: elmindex(:) + INTEGER, allocatable :: elmnpxl(:), elmpixels(:,:,:) LOGICAL, allocatable :: elmmask (:) LOGICAL, allocatable :: patchmask(:) #ifdef CATCHMENT LOGICAL, allocatable :: hrumask (:) #endif -#ifdef LULC_IGBP_PFT +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) LOGICAL, allocatable :: pftmask (:) #endif -#ifdef LULC_IGBP_PC - LOGICAL, allocatable :: pcmask (:) -#endif INTEGER :: month, YY, itime, Julian_day, nsl integer :: start_year, end_year @@ -186,13 +184,9 @@ SUBROUTINE srfdata_region_clip (dir_landdata_in, dir_landdata_out) #ifdef CATCHMENT CALL clip_pixelset (dir_landdata_in, 'landhru' , iblk, jblk, elmmask, elmindex, hrumask ) #endif -#ifdef LULC_IGBP_PFT +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) CALL clip_pixelset (dir_landdata_in, 'landpft' , iblk, jblk, elmmask, elmindex, pftmask ) #endif -#ifdef LULC_IGBP_PC - CALL clip_pixelset (dir_landdata_in, 'landpc' , iblk, jblk, elmmask, elmindex, pcmask ) -#endif - CALL system('mkdir -p ' // trim(dir_landdata_out) // '/mesh') file_in = trim(dir_landdata_in) // '/mesh/mesh.nc' file_out = trim(dir_landdata_out) // '/mesh/mesh.nc' @@ -234,7 +228,7 @@ SUBROUTINE srfdata_region_clip (dir_landdata_in, dir_landdata_out) CALL clip_vector (file_in, file_out, iblk, jblk, 'patchfrac_hru', patchmask) #endif -#ifdef LULC_IGBP_PFT +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) CALL system('mkdir -p ' // trim(dir_landdata_out) // '/landpft') file_in = trim(dir_landdata_in) // '/landpft/landpft.nc' file_out = trim(dir_landdata_out) // '/landpft/landpft.nc' @@ -243,16 +237,6 @@ SUBROUTINE srfdata_region_clip (dir_landdata_in, dir_landdata_out) CALL clip_vector (file_in, file_out, iblk, jblk, 'ipxend', pftmask) CALL clip_vector (file_in, file_out, iblk, jblk, 'settyp', pftmask) #endif - -#ifdef LULC_IGBP_PC - CALL system('mkdir -p ' // trim(dir_landdata_out) // '/landpc') - file_in = trim(dir_landdata_in) // '/landpc/landpc.nc' - file_out = trim(dir_landdata_out) // '/landpc/landpc.nc' - CALL clip_vector (file_in, file_out, iblk, jblk, 'eindex', pcmask) - CALL clip_vector (file_in, file_out, iblk, jblk, 'ipxstt', pcmask) - CALL clip_vector (file_in, file_out, iblk, jblk, 'ipxend', pcmask) - CALL clip_vector (file_in, file_out, iblk, jblk, 'settyp', pcmask) -#endif ENDIF ! Leaf Area Index @@ -298,7 +282,7 @@ SUBROUTINE srfdata_region_clip (dir_landdata_in, dir_landdata_out) ENDDO ENDIF -#ifdef LULC_IGBP_PFT +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) DO month = 1, 12 write(c2,'(i2.2)') month @@ -312,20 +296,6 @@ SUBROUTINE srfdata_region_clip (dir_landdata_in, dir_landdata_out) ENDDO #endif -#ifdef LULC_IGBP_PC - DO month = 1, 12 - write(c2,'(i2.2)') month - - file_in = trim(dir_landdata_in) // '/LAI/LAI_pcs' // trim(c2) // '.nc' - file_out = trim(dir_landdata_out) // '/LAI/LAI_pcs' // trim(c2) // '.nc' - CALL clip_vector (file_in, file_out, iblk, jblk, 'LAI_pcs', pcmask) - - file_in = trim(dir_landdata_in) // '/LAI/SAI_pcs' // trim(c2) // '.nc' - file_out = trim(dir_landdata_out) // '/LAI/SAI_pcs' // trim(c2) // '.nc' - CALL clip_vector (file_in, file_out, iblk, jblk, 'SAI_pcs', pcmask) - ENDDO -#endif - ! depth to bedrock IF(DEF_USE_BEDROCK)THEN CALL system('mkdir -p ' // trim(dir_landdata_out) // '/dbedrock') @@ -339,16 +309,11 @@ SUBROUTINE srfdata_region_clip (dir_landdata_in, dir_landdata_out) file_in = trim(dir_landdata_in) // '/htop/htop_patches.nc' file_out = trim(dir_landdata_out) // '/htop/htop_patches.nc' CALL clip_vector (file_in, file_out, iblk, jblk, 'htop_patches', patchmask) -#ifdef LULC_IGBP_PFT +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) file_in = trim(dir_landdata_in) // '/htop/htop_pfts.nc' file_out = trim(dir_landdata_out) // '/htop/htop_pfts.nc' CALL clip_vector (file_in, file_out, iblk, jblk, 'htop_pfts', pftmask) #endif -#ifdef LULC_IGBP_PC - file_in = trim(dir_landdata_in) // '/htop/htop_pcs.nc' - file_out = trim(dir_landdata_out) // '/htop/htop_pcs.nc' - CALL clip_vector (file_in, file_out, iblk, jblk, 'htop_pcs', pcmask) -#endif ! lake depth CALL system('mkdir -p ' // trim(dir_landdata_out) // '/lakedepth') @@ -358,7 +323,7 @@ SUBROUTINE srfdata_region_clip (dir_landdata_in, dir_landdata_out) ! plant function type percentage CALL system('mkdir -p ' // trim(dir_landdata_out) // '/pctpft') -#ifdef LULC_IGBP_PFT +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) file_in = trim(dir_landdata_in) // '/pctpft/pct_pfts.nc' file_out = trim(dir_landdata_out) // '/pctpft/pct_pfts.nc' CALL clip_vector (file_in, file_out, iblk, jblk, 'pct_pfts', pftmask) @@ -367,11 +332,6 @@ SUBROUTINE srfdata_region_clip (dir_landdata_in, dir_landdata_out) file_out = trim(dir_landdata_out) // '/pctpft/pct_crops.nc' CALL clip_vector (file_in, file_out, iblk, jblk, 'pct_crops', patchmask) #endif -#endif -#ifdef LULC_IGBP_PC - file_in = trim(dir_landdata_in) // '/pctpft/pct_pcs.nc' - file_out = trim(dir_landdata_out) // '/pctpft/pct_pcs.nc' - CALL clip_vector (file_in, file_out, iblk, jblk, 'pct_pcs', pcmask) #endif ! soil @@ -574,12 +534,9 @@ SUBROUTINE srfdata_region_clip (dir_landdata_in, dir_landdata_out) #ifdef CATCHMENT IF (allocated(hrumask )) deallocate(hrumask ) #endif -#ifdef LULC_IGBP_PFT +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) IF (allocated(pftmask )) deallocate(pftmask ) #endif -#ifdef LULC_IGBP_PC - IF (allocated(pcmask )) deallocate(pcmask ) -#endif END SUBROUTINE srfdata_region_clip @@ -595,7 +552,8 @@ SUBROUTINE clip_pixelset (dir_landdata_in, psetname, iblk, jblk, elmmask, elmind CHARACTER(len=*), intent(in) :: psetname INTEGER, intent(in) :: iblk, jblk LOGICAL, intent(in) :: elmmask (:) - INTEGER, intent(in) :: elmindex(:) + + INTEGER*8, intent(in) :: elmindex(:) LOGICAL, allocatable, intent(out) :: psetmask (:) @@ -603,7 +561,7 @@ SUBROUTINE clip_pixelset (dir_landdata_in, psetname, iblk, jblk, elmmask, elmind CHARACTER(len=256) :: filename, fileblock LOGICAL :: fexists INTEGER :: nset, ie, iset - INTEGER, allocatable :: eindex_p(:) + INTEGER*8, allocatable :: eindex_p(:) filename = trim(dir_landdata_in) // '/' // trim(psetname) // '/' // trim(psetname) // '.nc' CALL get_filename_block (filename, iblk, jblk, fileblock) @@ -662,6 +620,9 @@ SUBROUTINE clip_vector (file_in, file_out, iblk, jblk, varname, vecmask) INTEGER, allocatable :: data_i4_out1 (:) INTEGER, allocatable :: data_i4_out2 (:,:) INTEGER, allocatable :: data_i4_out3 (:,:,:) + + INTEGER*8, allocatable :: data_i8_in1 (:) + INTEGER*8, allocatable :: data_i8_out1 (:) REAL(r8), allocatable :: data_r8_in1 (:) REAL(r8), allocatable :: data_r8_in2 (:,:) @@ -749,6 +710,16 @@ SUBROUTINE clip_vector (file_in, file_out, iblk, jblk, varname, vecmask) deallocate (data_i4_in1 ) deallocate (data_i4_out1) + elseif (xtype == NF90_INT64) THEN + allocate (data_i8_in1 (vlen_in)) + CALL nccheck( nf90_get_var (ncidin, varidin , data_i8_in1) ) + + allocate (data_i8_out1 (vlen_out)) + data_i8_out1 = pack(data_i8_in1, vecmask) + CALL nccheck( nf90_put_var (ncidout, varidout, data_i8_out1) ) + + deallocate (data_i8_in1 ) + deallocate (data_i8_out1) elseif (xtype == NF90_DOUBLE) THEN allocate (data_r8_in1 (vlen_in)) CALL nccheck( nf90_get_var (ncidin, varidin , data_r8_in1) ) diff --git a/mksrfdata/MOD_SingleSrfdata.F90 b/mksrfdata/MOD_SingleSrfdata.F90 index 4845bd12..d0aaae27 100644 --- a/mksrfdata/MOD_SingleSrfdata.F90 +++ b/mksrfdata/MOD_SingleSrfdata.F90 @@ -16,7 +16,7 @@ MODULE MOD_SingleSrfdata USE MOD_Namelist IMPLICIT NONE SAVE - + REAL(r8) :: SITE_lon_location = 0. REAL(r8) :: SITE_lat_location = 0. @@ -81,9 +81,44 @@ MODULE MOD_SingleSrfdata REAL(r8), allocatable :: SITE_soil_BA_beta (:) REAL(r8) :: SITE_dbedrock = 0. - + REAL(r8) :: SITE_topography = 0. + INTEGER , allocatable :: SITE_urbtyp (:) + + REAL(r8), allocatable :: SITE_lucyid (:) + + REAL(r8), allocatable :: SITE_fveg_urb (:) + REAL(r8), allocatable :: SITE_htop_urb (:) + REAL(r8), allocatable :: SITE_flake_urb(:) + REAL(r8), allocatable :: SITE_froof (:) + REAL(r8), allocatable :: SITE_hroof (:) + REAL(r8), allocatable :: SITE_fgimp (:) + REAL(r8), allocatable :: SITE_fgper (:) + REAL(r8), allocatable :: SITE_hwr (:) + REAL(r8), allocatable :: SITE_popden (:) + + REAL(r8), allocatable :: SITE_em_roof (:) + REAL(r8), allocatable :: SITE_em_wall (:) + REAL(r8), allocatable :: SITE_em_gimp (:) + REAL(r8), allocatable :: SITE_em_gper (:) + REAL(r8), allocatable :: SITE_t_roommax(:) + REAL(r8), allocatable :: SITE_t_roommin(:) + REAL(r8), allocatable :: SITE_thickroof(:) + REAL(r8), allocatable :: SITE_thickwall(:) + + REAL(r8), allocatable :: SITE_cv_roof (:) + REAL(r8), allocatable :: SITE_cv_wall (:) + REAL(r8), allocatable :: SITE_cv_gimp (:) + REAL(r8), allocatable :: SITE_tk_roof (:) + REAL(r8), allocatable :: SITE_tk_wall (:) + REAL(r8), allocatable :: SITE_tk_gimp (:) + + REAL(r8), allocatable :: SITE_alb_roof (:,:) + REAL(r8), allocatable :: SITE_alb_wall (:,:) + REAL(r8), allocatable :: SITE_alb_gimp (:,:) + REAL(r8), allocatable :: SITE_alb_gper (:,:) + CONTAINS ! ----- @@ -101,10 +136,10 @@ SUBROUTINE read_surface_data_single (fsrfdata, mksrfdata) ! Local Variables INTEGER :: iyear, itime - + CALL ncio_read_serial (fsrfdata, 'latitude', SITE_lat_location) CALL ncio_read_serial (fsrfdata, 'longitude', SITE_lon_location) - + #ifdef LULC_USGS CALL ncio_read_serial (fsrfdata, 'USGS_classification', SITE_landtype) #else @@ -112,17 +147,17 @@ SUBROUTINE read_surface_data_single (fsrfdata, mksrfdata) #endif CALL normalize_longitude (SITE_lon_location) - + DEF_domain%edges = floor(SITE_lat_location) DEF_domain%edgen = DEF_domain%edges + 1.0 DEF_domain%edgew = floor(SITE_lon_location) DEF_domain%edgee = DEF_domain%edgew + 1.0 IF (.not. isgreenwich) THEN - LocalLongitude = SITE_lon_location + LocalLongitude = SITE_lon_location ENDIF -#if (defined LULC_IGBP_PFT) +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) IF ((.not. mksrfdata) .or. USE_SITE_pctpfts) THEN CALL ncio_read_serial (fsrfdata, 'pfttyp', SITE_pfttyp ) ! otherwise, retrieve from database by MOD_LandPFT.F90 @@ -137,7 +172,7 @@ SUBROUTINE read_surface_data_single (fsrfdata, mksrfdata) #ifdef CROP IF ((.not. mksrfdata) .or. USE_SITE_pctcrop) THEN - IF (SITE_landtype == 12) THEN + IF (SITE_landtype == CROPLAND) THEN CALL ncio_read_serial (fsrfdata, 'croptyp', SITE_croptyp) CALL ncio_read_serial (fsrfdata, 'pctcrop', SITE_pctcrop) ! otherwise, retrieve from database by MOD_LandPatch.F90 @@ -220,7 +255,7 @@ SUBROUTINE read_surface_data_single (fsrfdata, mksrfdata) CALL ncio_read_serial (fsrfdata, 'depth_to_bedrock', SITE_dbedrock) ENDIF ENDIF - + IF ((.not. mksrfdata) .or. USE_SITE_topography) THEN ! otherwise, retrieve from database by Aggregation_Topography.F90 CALL ncio_read_serial (fsrfdata, 'elevation', SITE_topography) @@ -228,6 +263,142 @@ SUBROUTINE read_surface_data_single (fsrfdata, mksrfdata) END SUBROUTINE read_surface_data_single + ! ----- + SUBROUTINE read_urban_surface_data_single (fsrfdata, mksrfdata, mkrun) + USE MOD_TimeManager + USE MOD_NetCDFSerial + USE MOD_Namelist + USE MOD_Utils + USE MOD_Vars_Global, only : PI, URBAN + IMPLICIT NONE + + CHARACTER(len=*), intent(in) :: fsrfdata + LOGICAL, intent(in) :: mksrfdata + LOGICAL, intent(in), optional :: mkrun + + SITE_landtype = URBAN + CALL ncio_read_serial (fsrfdata, 'latitude', SITE_lat_location) + CALL ncio_read_serial (fsrfdata, 'longitude', SITE_lon_location) + + DEF_domain%edges = floor(SITE_lat_location) + DEF_domain%edgen = DEF_domain%edges + 1.0 + DEF_domain%edgew = floor(SITE_lon_location) + DEF_domain%edgee = DEF_domain%edgew + 1.0 + + IF (.not. isgreenwich) THEN + LocalLongitude = SITE_lon_location + ENDIF + + IF (.not. present(mkrun)) THEN + IF ((.not. mksrfdata) .or. USE_SITE_urban_paras) THEN + + CALL ncio_read_serial (fsrfdata, 'tree_area_fraction' , SITE_fveg_urb ) + CALL ncio_read_serial (fsrfdata, 'tree_mean_height' , SITE_htop_urb ) + CALL ncio_read_serial (fsrfdata, 'water_area_fraction' , SITE_flake_urb ) + CALL ncio_read_serial (fsrfdata, 'roof_area_fraction' , SITE_froof ) + CALL ncio_read_serial (fsrfdata, 'building_mean_height' , SITE_hroof ) + CALL ncio_read_serial (fsrfdata, 'impervious_area_fraction' , SITE_fgimp ) + CALL ncio_read_serial (fsrfdata, 'canyon_height_width_ratio' , SITE_hwr ) + CALL ncio_read_serial (fsrfdata, 'resident_population_density', SITE_popden ) + + SITE_fgper = 1 - (SITE_fgimp-SITE_froof)/(1-SITE_froof-SITE_flake_urb) + SITE_fveg_urb = SITE_fveg_urb * 100 + SITE_flake_urb= SITE_flake_urb* 100 + ENDIF + ELSE + CALL ncio_read_serial (fsrfdata, 'LAI_year' , SITE_LAI_year ) + CALL ncio_read_serial (fsrfdata, 'TREE_LAI' , SITE_LAI_monthly) + CALL ncio_read_serial (fsrfdata, 'TREE_SAI' , SITE_SAI_monthly) + + CALL ncio_read_serial (fsrfdata, 'URBAN_TYPE' , SITE_urbtyp ) + CALL ncio_read_serial (fsrfdata, 'LUCY_id' , SITE_lucyid ) + CALL ncio_read_serial (fsrfdata, 'PCT_Tree' , SITE_fveg_urb ) + CALL ncio_read_serial (fsrfdata, 'URBAN_TREE_TOP', SITE_htop_urb ) + CALL ncio_read_serial (fsrfdata, 'PCT_Water' , SITE_flake_urb ) + CALL ncio_read_serial (fsrfdata, 'WT_ROOF' , SITE_froof ) + CALL ncio_read_serial (fsrfdata, 'HT_ROOF' , SITE_hroof ) + CALL ncio_read_serial (fsrfdata, 'WTROAD_PERV' , SITE_fgper ) + CALL ncio_read_serial (fsrfdata, 'CANYON_HWR' , SITE_hwr ) + CALL ncio_read_serial (fsrfdata, 'POP_DEN' , SITE_popden ) + + CALL ncio_read_serial (fsrfdata, 'EM_ROOF' , SITE_em_roof ) + CALL ncio_read_serial (fsrfdata, 'EM_WALL' , SITE_em_wall ) + CALL ncio_read_serial (fsrfdata, 'EM_IMPROAD' , SITE_em_gimp ) + CALL ncio_read_serial (fsrfdata, 'EM_PERROAD' , SITE_em_gper ) + CALL ncio_read_serial (fsrfdata, 'T_BUILDING_MAX', SITE_t_roommax ) + CALL ncio_read_serial (fsrfdata, 'T_BUILDING_MIN', SITE_t_roommin ) + CALL ncio_read_serial (fsrfdata, 'THICK_ROOF' , SITE_thickroof ) + CALL ncio_read_serial (fsrfdata, 'THICK_WALL' , SITE_thickwall ) + + CALL ncio_read_serial (fsrfdata, 'ALB_ROOF' , SITE_alb_roof ) + CALL ncio_read_serial (fsrfdata, 'ALB_WALL' , SITE_alb_wall ) + CALL ncio_read_serial (fsrfdata, 'ALB_IMPROAD' , SITE_alb_gimp ) + CALL ncio_read_serial (fsrfdata, 'ALB_PERROAD' , SITE_alb_gper ) + + CALL ncio_read_serial (fsrfdata, 'CV_ROOF' , SITE_cv_roof ) + CALL ncio_read_serial (fsrfdata, 'CV_WALL' , SITE_cv_wall ) + CALL ncio_read_serial (fsrfdata, 'CV_IMPROAD' , SITE_cv_gimp ) + CALL ncio_read_serial (fsrfdata, 'TK_ROOF' , SITE_tk_roof ) + CALL ncio_read_serial (fsrfdata, 'TK_WALL' , SITE_tk_wall ) + CALL ncio_read_serial (fsrfdata, 'TK_IMPROAD' , SITE_tk_gimp ) + ENDIF + + IF ((.not. mksrfdata) .or. USE_SITE_lakedepth) THEN + ! otherwise, retrieve from database by Aggregation_LakeDepth.F90 + CALL ncio_read_serial (fsrfdata, 'lakedepth', SITE_lakedepth) + ENDIF + + IF ((.not. mksrfdata) .or. USE_SITE_soilreflectance) THEN + ! otherwise, retrieve from database by Aggregation_SoilBrightness.F90 + CALL ncio_read_serial (fsrfdata, 'soil_s_v_alb', SITE_soil_s_v_alb) + CALL ncio_read_serial (fsrfdata, 'soil_d_v_alb', SITE_soil_d_v_alb) + CALL ncio_read_serial (fsrfdata, 'soil_s_n_alb', SITE_soil_s_n_alb) + CALL ncio_read_serial (fsrfdata, 'soil_d_n_alb', SITE_soil_d_n_alb) + ENDIF + + IF ((.not. mksrfdata) .or. USE_SITE_soilparameters) THEN + ! otherwise, retrieve from database by Aggregation_SoilParameters.F90 + CALL ncio_read_serial (fsrfdata, 'soil_vf_quartz_mineral', SITE_soil_vf_quartz_mineral) + CALL ncio_read_serial (fsrfdata, 'soil_vf_gravels ', SITE_soil_vf_gravels ) + CALL ncio_read_serial (fsrfdata, 'soil_vf_sand ', SITE_soil_vf_sand ) + CALL ncio_read_serial (fsrfdata, 'soil_vf_om ', SITE_soil_vf_om ) + CALL ncio_read_serial (fsrfdata, 'soil_wf_gravels ', SITE_soil_wf_gravels ) + CALL ncio_read_serial (fsrfdata, 'soil_wf_sand ', SITE_soil_wf_sand ) + CALL ncio_read_serial (fsrfdata, 'soil_OM_density ', SITE_soil_OM_density ) + CALL ncio_read_serial (fsrfdata, 'soil_BD_all ', SITE_soil_BD_all ) + CALL ncio_read_serial (fsrfdata, 'soil_theta_s ', SITE_soil_theta_s ) + CALL ncio_read_serial (fsrfdata, 'soil_k_s ', SITE_soil_k_s ) + CALL ncio_read_serial (fsrfdata, 'soil_csol ', SITE_soil_csol ) + CALL ncio_read_serial (fsrfdata, 'soil_tksatu ', SITE_soil_tksatu ) + CALL ncio_read_serial (fsrfdata, 'soil_tksatf ', SITE_soil_tksatf ) + CALL ncio_read_serial (fsrfdata, 'soil_tkdry ', SITE_soil_tkdry ) + CALL ncio_read_serial (fsrfdata, 'soil_k_solids ', SITE_soil_k_solids ) + CALL ncio_read_serial (fsrfdata, 'soil_psi_s ', SITE_soil_psi_s ) + CALL ncio_read_serial (fsrfdata, 'soil_lambda ', SITE_soil_lambda ) +#ifdef vanGenuchten_Mualem_SOIL_MODEL + CALL ncio_read_serial (fsrfdata, 'soil_theta_r ', SITE_soil_theta_r ) + CALL ncio_read_serial (fsrfdata, 'soil_alpha_vgm ', SITE_soil_alpha_vgm ) + CALL ncio_read_serial (fsrfdata, 'soil_L_vgm ', SITE_soil_L_vgm ) + CALL ncio_read_serial (fsrfdata, 'soil_n_vgm ', SITE_soil_n_vgm ) +#endif + CALL ncio_read_serial (fsrfdata, 'soil_BA_alpha ', SITE_soil_BA_alpha ) + CALL ncio_read_serial (fsrfdata, 'soil_BA_beta ', SITE_soil_BA_beta ) + ENDIF + + IF (DEF_USE_BEDROCK) THEN + IF ((.not. mksrfdata) .or. USE_SITE_dbedrock) THEN + ! otherwise, retrieve from database by Aggregation_DBedrock.F90 + CALL ncio_read_serial (fsrfdata, 'depth_to_bedrock', SITE_dbedrock) + ENDIF + ENDIF + + IF ((.not. mksrfdata) .or. USE_SITE_topography) THEN + ! otherwise, retrieve from database by Aggregation_Topography.F90 + CALL ncio_read_serial (fsrfdata, 'elevation', SITE_topography) + ENDIF + + END SUBROUTINE read_urban_surface_data_single + ! ----- SUBROUTINE write_surface_data_single (numpatch, numpft) @@ -250,13 +421,10 @@ SUBROUTINE write_surface_data_single (numpatch, numpft) CALL ncio_define_dimension (fsrfdata, 'soil', nl_soil ) CALL ncio_define_dimension (fsrfdata, 'patch', numpatch) -#if (defined LULC_IGBP_PFT) +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) CALL ncio_define_dimension (fsrfdata, 'pft', numpft) #endif -#if (defined LULC_IGBP_PC) - CALL ncio_define_dimension (fsrfdata, 'pft', N_PFT) -#endif - + CALL ncio_define_dimension (fsrfdata, 'LAI_year', size(SITE_LAI_year)) IF (DEF_LAI_MONTHLY) THEN CALL ncio_define_dimension (fsrfdata, 'month', 12) @@ -273,7 +441,7 @@ SUBROUTINE write_surface_data_single (numpatch, numpft) CALL ncio_write_serial (fsrfdata, 'IGBP_classification', SITE_landtype) #endif -#if (defined LULC_IGBP_PFT) +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) CALL ncio_write_serial (fsrfdata, 'pfttyp', SITE_pfttyp, 'pft') CALL ncio_put_attr (fsrfdata, 'pfttyp', 'source', datasource(USE_SITE_pctpfts)) #endif @@ -282,7 +450,7 @@ SUBROUTINE write_surface_data_single (numpatch, numpft) CALL ncio_put_attr (fsrfdata, 'pctpfts', 'source', datasource(USE_SITE_pctpfts)) #endif #if (defined CROP) - IF (SITE_landtype == 12) THEN + IF (SITE_landtype == CROPLAND) THEN CALL ncio_write_serial (fsrfdata, 'croptyp', SITE_croptyp, 'patch') CALL ncio_write_serial (fsrfdata, 'pctcrop', SITE_pctcrop, 'patch') CALL ncio_put_attr (fsrfdata, 'croptyp', 'source', datasource(USE_SITE_pctcrop)) @@ -392,6 +560,182 @@ SUBROUTINE write_surface_data_single (numpatch, numpft) END SUBROUTINE write_surface_data_single + ! ----- + SUBROUTINE write_urban_surface_data_single (numurban) + + USE MOD_NetCDFSerial + USE MOD_Namelist + USE MOD_Const_LC + IMPLICIT NONE + + INTEGER, intent(in) :: numurban + + ! Local Variables + CHARACTER(len=256) :: fsrfdata + INTEGER :: iyear, itime + CHARACTER(len=8) :: source + + fsrfdata = trim(DEF_dir_landdata) // '/srfdata.nc' + + CALL ncio_create_file (fsrfdata) + + CALL ncio_define_dimension (fsrfdata, 'soil', nl_soil ) + CALL ncio_define_dimension (fsrfdata, 'patch', numurban) + + CALL ncio_define_dimension (fsrfdata, 'LAI_year', size(SITE_LAI_year)) + CALL ncio_define_dimension (fsrfdata, 'month', 12) + + CALL ncio_define_dimension (fsrfdata, 'ulev' , 10) + CALL ncio_define_dimension (fsrfdata, 'numsolar', 2 ) + CALL ncio_define_dimension (fsrfdata, 'numrad' , 2 ) + + CALL ncio_write_serial (fsrfdata, 'latitude', SITE_lat_location) + CALL ncio_write_serial (fsrfdata, 'longitude', SITE_lon_location) + + source = datasource(USE_SITE_urban_LAI) + CALL ncio_write_serial (fsrfdata, 'LAI_year', SITE_LAI_year, 'LAI_year') + CALL ncio_write_serial (fsrfdata, 'TREE_LAI', SITE_LAI_monthly, 'month', 'LAI_year') + CALL ncio_write_serial (fsrfdata, 'TREE_SAI', SITE_SAI_monthly, 'month', 'LAI_year') + CALL ncio_put_attr (fsrfdata, 'TREE_LAI', 'source', source) + CALL ncio_put_attr (fsrfdata, 'TREE_SAI', 'source', source) + + CALL ncio_write_serial (fsrfdata, 'lakedepth', SITE_lakedepth) + CALL ncio_put_attr (fsrfdata, 'lakedepth', 'source', datasource(USE_SITE_lakedepth)) + + CALL ncio_write_serial (fsrfdata, 'URBAN_TYPE' , SITE_urbtyp , 'patch') + CALL ncio_write_serial (fsrfdata, 'LUCY_id' , SITE_lucyid , 'patch') + !CALL ncio_put_attr (fsrfdata, 'LUCY_id' , 'source', source) + source = datasource(USE_SITE_urban_paras) + CALL ncio_write_serial (fsrfdata, 'PCT_Tree' , SITE_fveg_urb , 'patch') + CALL ncio_write_serial (fsrfdata, 'URBAN_TREE_TOP', SITE_htop_urb , 'patch') + CALL ncio_write_serial (fsrfdata, 'PCT_Water' , SITE_flake_urb , 'patch') + CALL ncio_write_serial (fsrfdata, 'WT_ROOF' , SITE_froof , 'patch') + CALL ncio_write_serial (fsrfdata, 'HT_ROOF' , SITE_hroof , 'patch') + CALL ncio_write_serial (fsrfdata, 'WTROAD_PERV' , SITE_fgper , 'patch') + CALL ncio_write_serial (fsrfdata, 'CANYON_HWR' , SITE_hwr , 'patch') + CALL ncio_write_serial (fsrfdata, 'POP_DEN' , SITE_popden , 'patch') + + CALL ncio_put_attr (fsrfdata, 'PCT_Tree' , 'source', source) + CALL ncio_put_attr (fsrfdata, 'URBAN_TREE_TOP', 'source', source) + CALL ncio_put_attr (fsrfdata, 'PCT_Water' , 'source', source) + CALL ncio_put_attr (fsrfdata, 'WT_ROOF' , 'source', source) + CALL ncio_put_attr (fsrfdata, 'HT_ROOF' , 'source', source) + CALL ncio_put_attr (fsrfdata, 'WTROAD_PERV' , 'source', source) + CALL ncio_put_attr (fsrfdata, 'CANYON_HWR' , 'source', source) + CALL ncio_put_attr (fsrfdata, 'POP_DEN' , 'source', source) + + source = datasource(USE_SITE_thermal_paras) + CALL ncio_write_serial (fsrfdata, 'EM_ROOF' , SITE_em_roof , 'patch') + CALL ncio_write_serial (fsrfdata, 'EM_WALL' , SITE_em_wall , 'patch') + CALL ncio_write_serial (fsrfdata, 'EM_IMPROAD' , SITE_em_gimp , 'patch') + CALL ncio_write_serial (fsrfdata, 'EM_PERROAD' , SITE_em_gper , 'patch') + CALL ncio_write_serial (fsrfdata, 'T_BUILDING_MAX', SITE_t_roommax , 'patch') + CALL ncio_write_serial (fsrfdata, 'T_BUILDING_MIN', SITE_t_roommin , 'patch') + CALL ncio_write_serial (fsrfdata, 'THICK_ROOF' , SITE_thickroof , 'patch') + CALL ncio_write_serial (fsrfdata, 'THICK_WALL' , SITE_thickwall , 'patch') + + CALL ncio_put_attr (fsrfdata, 'EM_ROOF' , 'source', source) + CALL ncio_put_attr (fsrfdata, 'EM_WALL' , 'source', source) + CALL ncio_put_attr (fsrfdata, 'EM_IMPROAD' , 'source', source) + CALL ncio_put_attr (fsrfdata, 'EM_PERROAD' , 'source', source) + CALL ncio_put_attr (fsrfdata, 'T_BUILDING_MAX', 'source', source) + CALL ncio_put_attr (fsrfdata, 'T_BUILDING_MIN', 'source', source) + CALL ncio_put_attr (fsrfdata, 'THICK_ROOF' , 'source', source) + CALL ncio_put_attr (fsrfdata, 'THICK_WALL' , 'source', source) + + CALL ncio_write_serial (fsrfdata, 'ALB_ROOF' , SITE_alb_roof , 'numrad', 'numsolar') + CALL ncio_write_serial (fsrfdata, 'ALB_WALL' , SITE_alb_wall , 'numrad', 'numsolar') + CALL ncio_write_serial (fsrfdata, 'ALB_IMPROAD' , SITE_alb_gimp , 'numrad', 'numsolar') + CALL ncio_write_serial (fsrfdata, 'ALB_PERROAD' , SITE_alb_gper , 'numrad', 'numsolar') + + CALL ncio_put_attr (fsrfdata, 'ALB_ROOF' , 'source', source) + CALL ncio_put_attr (fsrfdata, 'ALB_WALL' , 'source', source) + CALL ncio_put_attr (fsrfdata, 'ALB_IMPROAD' , 'source', source) + CALL ncio_put_attr (fsrfdata, 'ALB_PERROAD' , 'source', source) + + CALL ncio_write_serial (fsrfdata, 'CV_ROOF' , SITE_cv_roof , 'ulev') + CALL ncio_write_serial (fsrfdata, 'CV_WALL' , SITE_cv_wall , 'ulev') + CALL ncio_write_serial (fsrfdata, 'CV_IMPROAD' , SITE_cv_gimp , 'ulev') + CALL ncio_write_serial (fsrfdata, 'TK_ROOF' , SITE_tk_roof , 'ulev') + CALL ncio_write_serial (fsrfdata, 'TK_WALL' , SITE_tk_wall , 'ulev') + CALL ncio_write_serial (fsrfdata, 'TK_IMPROAD' , SITE_tk_gimp , 'ulev') + CALL ncio_put_attr (fsrfdata, 'CV_ROOF' , 'source', source) + CALL ncio_put_attr (fsrfdata, 'CV_WALL' , 'source', source) + CALL ncio_put_attr (fsrfdata, 'CV_IMPROAD' , 'source', source) + CALL ncio_put_attr (fsrfdata, 'TK_ROOF' , 'source', source) + CALL ncio_put_attr (fsrfdata, 'TK_WALL' , 'source', source) + CALL ncio_put_attr (fsrfdata, 'TK_IMPROAD' , 'source', source) + + + source = datasource(USE_SITE_soilreflectance) + CALL ncio_write_serial (fsrfdata, 'soil_s_v_alb', SITE_soil_s_v_alb) + CALL ncio_put_attr (fsrfdata, 'soil_s_v_alb', 'source', source) + CALL ncio_write_serial (fsrfdata, 'soil_d_v_alb', SITE_soil_d_v_alb) + CALL ncio_put_attr (fsrfdata, 'soil_d_v_alb', 'source', source) + CALL ncio_write_serial (fsrfdata, 'soil_s_n_alb', SITE_soil_s_n_alb) + CALL ncio_put_attr (fsrfdata, 'soil_s_n_alb', 'source', source) + CALL ncio_write_serial (fsrfdata, 'soil_d_n_alb', SITE_soil_d_n_alb) + CALL ncio_put_attr (fsrfdata, 'soil_d_n_alb', 'source', source) + + source = datasource(USE_SITE_soilparameters) + CALL ncio_write_serial (fsrfdata, 'soil_vf_quartz_mineral', SITE_soil_vf_quartz_mineral, 'soil') + CALL ncio_write_serial (fsrfdata, 'soil_vf_gravels ', SITE_soil_vf_gravels , 'soil') + CALL ncio_write_serial (fsrfdata, 'soil_vf_sand ', SITE_soil_vf_sand , 'soil') + CALL ncio_write_serial (fsrfdata, 'soil_vf_om ', SITE_soil_vf_om , 'soil') + CALL ncio_write_serial (fsrfdata, 'soil_wf_gravels ', SITE_soil_wf_gravels , 'soil') + CALL ncio_write_serial (fsrfdata, 'soil_wf_sand ', SITE_soil_wf_sand , 'soil') + CALL ncio_write_serial (fsrfdata, 'soil_OM_density ', SITE_soil_OM_density , 'soil') + CALL ncio_write_serial (fsrfdata, 'soil_BD_all ', SITE_soil_BD_all , 'soil') + CALL ncio_write_serial (fsrfdata, 'soil_theta_s ', SITE_soil_theta_s , 'soil') + CALL ncio_write_serial (fsrfdata, 'soil_k_s ', SITE_soil_k_s , 'soil') + CALL ncio_write_serial (fsrfdata, 'soil_csol ', SITE_soil_csol , 'soil') + CALL ncio_write_serial (fsrfdata, 'soil_tksatu ', SITE_soil_tksatu , 'soil') + CALL ncio_write_serial (fsrfdata, 'soil_tksatf ', SITE_soil_tksatf , 'soil') + CALL ncio_write_serial (fsrfdata, 'soil_tkdry ', SITE_soil_tkdry , 'soil') + CALL ncio_write_serial (fsrfdata, 'soil_k_solids ', SITE_soil_k_solids , 'soil') + CALL ncio_put_attr (fsrfdata, 'soil_vf_quartz_mineral', 'source', source) + CALL ncio_put_attr (fsrfdata, 'soil_vf_gravels ', 'source', source) + CALL ncio_put_attr (fsrfdata, 'soil_vf_sand ', 'source', source) + CALL ncio_put_attr (fsrfdata, 'soil_vf_om ', 'source', source) + CALL ncio_put_attr (fsrfdata, 'soil_wf_gravels ', 'source', source) + CALL ncio_put_attr (fsrfdata, 'soil_wf_sand ', 'source', source) + CALL ncio_put_attr (fsrfdata, 'soil_OM_density ', 'source', source) + CALL ncio_put_attr (fsrfdata, 'soil_BD_all ', 'source', source) + CALL ncio_put_attr (fsrfdata, 'soil_theta_s ', 'source', source) + CALL ncio_put_attr (fsrfdata, 'soil_k_s ', 'source', source) + CALL ncio_put_attr (fsrfdata, 'soil_csol ', 'source', source) + CALL ncio_put_attr (fsrfdata, 'soil_tksatu ', 'source', source) + CALL ncio_put_attr (fsrfdata, 'soil_tksatf ', 'source', source) + CALL ncio_put_attr (fsrfdata, 'soil_tkdry ', 'source', source) + CALL ncio_put_attr (fsrfdata, 'soil_k_solids ', 'source', source) + CALL ncio_write_serial (fsrfdata, 'soil_psi_s ', SITE_soil_psi_s , 'soil') + CALL ncio_write_serial (fsrfdata, 'soil_lambda', SITE_soil_lambda, 'soil') + CALL ncio_put_attr (fsrfdata, 'soil_psi_s ', 'source', source) + CALL ncio_put_attr (fsrfdata, 'soil_lambda', 'source', source) +#ifdef vanGenuchten_Mualem_SOIL_MODEL + CALL ncio_write_serial (fsrfdata, 'soil_theta_r ', SITE_soil_theta_r , 'soil') + CALL ncio_write_serial (fsrfdata, 'soil_alpha_vgm', SITE_soil_alpha_vgm, 'soil') + CALL ncio_write_serial (fsrfdata, 'soil_L_vgm ', SITE_soil_L_vgm , 'soil') + CALL ncio_write_serial (fsrfdata, 'soil_n_vgm ', SITE_soil_n_vgm , 'soil') + CALL ncio_put_attr (fsrfdata, 'soil_theta_r ', 'source', source) + CALL ncio_put_attr (fsrfdata, 'soil_alpha_vgm', 'source', source) + CALL ncio_put_attr (fsrfdata, 'soil_L_vgm ', 'source', source) + CALL ncio_put_attr (fsrfdata, 'soil_n_vgm ', 'source', source) +#endif + CALL ncio_write_serial (fsrfdata, 'soil_BA_alpha', SITE_soil_BA_alpha, 'soil') + CALL ncio_write_serial (fsrfdata, 'soil_BA_beta ', SITE_soil_BA_beta , 'soil') + CALL ncio_put_attr (fsrfdata, 'soil_BA_alpha', 'source', source) + CALL ncio_put_attr (fsrfdata, 'soil_BA_beta ', 'source', source) + + IF(DEF_USE_BEDROCK)THEN + CALL ncio_write_serial (fsrfdata, 'depth_to_bedrock', SITE_dbedrock) + CALL ncio_put_attr (fsrfdata, 'depth_to_bedrock', 'source', datasource(USE_SITE_dbedrock)) + ENDIF + + CALL ncio_write_serial (fsrfdata, 'elevation', SITE_topography) + CALL ncio_put_attr (fsrfdata, 'elevation', 'source', datasource(USE_SITE_topography)) + + END SUBROUTINE write_urban_surface_data_single ! --------- CHARACTER(len=8) FUNCTION datasource (is_site) diff --git a/mksrfdata/MOD_SrfdataDiag.F90 b/mksrfdata/MOD_SrfdataDiag.F90 index 98a02d7a..4cea3995 100644 --- a/mksrfdata/MOD_SrfdataDiag.F90 +++ b/mksrfdata/MOD_SrfdataDiag.F90 @@ -5,11 +5,11 @@ MODULE MOD_SrfdataDiag !----------------------------------------------------------------------------------------- ! DESCRIPTION: ! - ! This module includes subroutines for checking the results of making surface data. + ! This module includes subroutines for checking the results of making surface data. ! - ! The surface data in vector form is mapped to gridded data with last + ! The surface data in vector form is mapped to gridded data with last ! three dimensions of [type,longitude,latitude], which can be viewed by other softwares. - ! + ! ! In GRIDBASED, the grid of gridded data is just the grid of the mesh. ! In UNSTRUCTURED or CATCHMENT, the grid is user defined and the mapping uses area ! weighted scheme. @@ -27,9 +27,11 @@ MODULE MOD_SrfdataDiag ! PUBLIC variables and subroutines type(grid_type) :: gdiag + + TYPE(mapping_pset2grid_type) :: m_elm2diag TYPE(mapping_pset2grid_type) :: m_patch2diag -#ifdef LULC_IGBP_PFT +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) TYPE(mapping_pset2grid_type) :: m_pft2diag #endif #ifdef URBAN_MODEL @@ -49,8 +51,12 @@ MODULE MOD_SrfdataDiag SUBROUTINE srfdata_diag_init (dir_landdata) USE MOD_SPMD_Task + USE MOD_LandElm USE MOD_LandPatch -#ifdef LULC_IGBP_PFT +#ifdef CROP + USE MOD_LandCrop +#endif +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) USE MOD_LandPFT #endif #ifdef URBAN_MODEL @@ -65,6 +71,7 @@ SUBROUTINE srfdata_diag_init (dir_landdata) CHARACTER(len=256) :: landdir, landname INTEGER :: ityp INTEGER :: typindex(N_land_classification+1) + real(r8), allocatable :: elmid_r8(:) landdir = trim(dir_landdata) // '/diag/' IF (p_is_master) THEN @@ -72,14 +79,16 @@ SUBROUTINE srfdata_diag_init (dir_landdata) ENDIF call srf_concat%set (gdiag) + + CALL m_elm2diag%build (landelm, gdiag) #ifndef CROP CALL m_patch2diag%build (landpatch, gdiag) #else - CALL m_patch2diag%build (landpatch, gdiag, pctcrop) + CALL m_patch2diag%build (landpatch, gdiag, pctshrpch) #endif -#ifdef LULC_IGBP_PFT +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) CALL m_pft2diag%build (landpft, gdiag) #endif @@ -89,6 +98,16 @@ SUBROUTINE srfdata_diag_init (dir_landdata) srf_data_id = 666 + IF (p_is_worker) THEN + allocate (elmid_r8 (landelm%nset)); elmid_r8 = real(landelm%eindex, r8) + ENDIF + + landname = trim(dir_landdata)//'/diag/element.nc' + CALL srfdata_map_and_write (elmid_r8, landelm%settyp, (/0/), m_elm2diag, & + -1.0e36_r8, landname, 'element', compress = 1, write_mode = 'one') + + IF (p_is_worker) deallocate (elmid_r8) + typindex = (/(ityp, ityp = 0, N_land_classification)/) landname = trim(dir_landdata)//'/diag/patchfrac_elm.nc' CALL srfdata_map_and_write (elm_patch%subfrc, landpatch%settyp, typindex, m_patch2diag, & @@ -129,7 +148,7 @@ subroutine srfdata_map_and_write ( & integer, intent(in) :: compress character (len=*), intent(in), optional :: write_mode - + character (len=*), intent(in), optional :: lastdimname integer, intent(in), optional :: lastdimvalue @@ -144,7 +163,7 @@ subroutine srfdata_map_and_write ( & character(len=256) :: fileblock real(r8), allocatable :: rbuf(:,:,:), sbuf(:,:,:), vdata(:,:,:) LOGICAL :: fexists - integer :: ilastdim + integer :: ilastdim IF (present(write_mode)) THEN wmode = trim(write_mode) @@ -235,6 +254,7 @@ subroutine srfdata_map_and_write ( & inquire (file=trim(filename), exist=fexists) IF (.not. fexists) THEN + CALL ncio_create_file (filename) call ncio_define_dimension (filename, 'TypeIndex', ntyps) @@ -356,226 +376,6 @@ subroutine srfdata_map_and_write ( & end subroutine srfdata_map_and_write -! ! ------ SUBROUTINE ------ -! subroutine srfdata_map_and_write_int ( & -! vsrfdata, settyp, typindex, m_srf, spv, filename, dataname, & -! compress, write_mode) - -! use MOD_SPMD_Task -! use MOD_Namelist -! use MOD_Block -! use MOD_Grid -! USE MOD_DataType -! USE MOD_NetCDFSerial -! implicit none - -! INTEGER , intent(in) :: vsrfdata (:) -! INTEGER , intent(in) :: settyp (:) -! INTEGER , intent(in) :: typindex (:) - -! TYPE(mapping_pset2grid_type), intent(in) :: m_srf - -! INTEGER , intent(in) :: spv - -! character (len=*), intent(in) :: filename -! character (len=*), intent(in) :: dataname -! integer, intent(in) :: compress - -! character (len=*), intent(in), optional :: write_mode - -! ! Local variables -! type(block_data_real8_3d) :: wdata, sumwt -! REAL(r8), allocatable :: vecone (:) - -! CHARACTER(len=10) :: wmode -! integer :: iblkme, ib, jb, iblk, jblk, idata, ixseg, iyseg -! integer :: ntyps, xcnt, ycnt, xbdsp, ybdsp, xgdsp, ygdsp -! integer :: rmesg(3), smesg(3), isrc -! character(len=256) :: fileblock -! real(r8), allocatable :: rbuf(:,:,:), sbuf(:,:,:), vdata(:,:,:) -! LOGICAL :: fexists - -! IF (present(write_mode)) THEN -! wmode = trim(write_mode) -! ELSE -! wmode = 'one' -! ENDIF - -! ntyps = size(typindex) - -! IF (p_is_io) THEN -! call allocate_block_data (gdiag, sumwt, ntyps) -! call allocate_block_data (gdiag, wdata, ntyps) -! ENDIF - -! IF (p_is_worker) THEN -! IF (size(vsrfdata) > 0) THEN -! allocate (vecone (size(vsrfdata))) -! vecone(:) = 1.0 -! ENDIF -! ENDIF - -! CALL m_srf%map_split (vecone , settyp, typindex, sumwt, spv) -! CALL m_srf%map_split (vsrfdata, settyp, typindex, wdata, spv) - -! IF (p_is_io) THEN -! DO iblkme = 1, gblock%nblkme -! ib = gblock%xblkme(iblkme) -! jb = gblock%yblkme(iblkme) - -! where ((sumwt%blk(ib,jb)%val > 0.) .and. (wdata%blk(ib,jb)%val /= spv)) -! wdata%blk(ib,jb)%val = wdata%blk(ib,jb)%val / sumwt%blk(ib,jb)%val -! elsewhere -! wdata%blk(ib,jb)%val = spv -! end where -! ENDDO -! ENDIF - -! if (trim(wmode) == 'one') then - -! if (p_is_master) then - -! allocate (vdata (ntyps, srf_concat%ginfo%nlon, srf_concat%ginfo%nlat)) -! vdata(:,:,:) = spv - -! #ifdef USEMPI -! do idata = 1, srf_concat%ndatablk - -! call mpi_recv (rmesg, 3, MPI_INTEGER, MPI_ANY_SOURCE, & -! srf_data_id, p_comm_glb, p_stat, p_err) - -! isrc = rmesg(1) -! ixseg = rmesg(2) -! iyseg = rmesg(3) - -! xgdsp = srf_concat%xsegs(ixseg)%gdsp -! ygdsp = srf_concat%ysegs(iyseg)%gdsp -! xcnt = srf_concat%xsegs(ixseg)%cnt -! ycnt = srf_concat%ysegs(iyseg)%cnt - -! allocate (rbuf (ntyps,xcnt,ycnt)) - -! call mpi_recv (rbuf, ntyps * xcnt * ycnt, MPI_DOUBLE, & -! isrc, srf_data_id, p_comm_glb, p_stat, p_err) - -! vdata (:,xgdsp+1:xgdsp+xcnt,ygdsp+1:ygdsp+ycnt) = rbuf - -! deallocate (rbuf) -! end do -! #else -! do iyseg = 1, srf_concat%nyseg -! do ixseg = 1, srf_concat%nxseg -! iblk = srf_concat%xsegs(ixseg)%blk -! jblk = srf_concat%ysegs(iyseg)%blk -! xbdsp = srf_concat%xsegs(ixseg)%bdsp -! ybdsp = srf_concat%ysegs(iyseg)%bdsp -! xgdsp = srf_concat%xsegs(ixseg)%gdsp -! ygdsp = srf_concat%ysegs(iyseg)%gdsp -! xcnt = srf_concat%xsegs(ixseg)%cnt -! ycnt = srf_concat%ysegs(iyseg)%cnt - -! vdata (:,xgdsp+1:xgdsp+xcnt, ygdsp+1:ygdsp+ycnt) = & -! wdata%blk(iblk,jblk)%val(:,xbdsp+1:xbdsp+xcnt,ybdsp+1:ybdsp+ycnt) -! end do -! ENDDO -! #endif - -! write(*,*) 'Please check gridded data < ', trim(dataname), ' > in ', trim(filename) - -! inquire (file=trim(filename), exist=fexists) -! IF (.not. fexists) THEN -! CALL ncio_create_file (filename) - -! call ncio_define_dimension (filename, 'TypeIndex', ntyps) -! call ncio_define_dimension (filename, 'lon' , srf_concat%ginfo%nlon) -! call ncio_define_dimension (filename, 'lat' , srf_concat%ginfo%nlat) - -! call ncio_write_serial (filename, 'lat', srf_concat%ginfo%lat_c, 'lat') -! CALL ncio_put_attr (filename, 'lat', 'long_name', 'latitude') -! CALL ncio_put_attr (filename, 'lat', 'units', 'degrees_north') - -! call ncio_write_serial (filename, 'lon', srf_concat%ginfo%lon_c, 'lon') -! CALL ncio_put_attr (filename, 'lon', 'long_name', 'longitude') -! CALL ncio_put_attr (filename, 'lon', 'units', 'degrees_east') - -! call ncio_write_serial (filename, 'TypeIndex', typindex, 'TypeIndex') -! ENDIF - -! call ncio_write_serial (filename, dataname, vdata, 'TypeIndex', 'lon', 'lat', compress) - -! CALL ncio_put_attr (filename, dataname, 'missing_value', spv) - -! deallocate (vdata) - -! ENDIF - -! #ifdef USEMPI -! if (p_is_io) then - -! do iyseg = 1, srf_concat%nyseg -! do ixseg = 1, srf_concat%nxseg - -! iblk = srf_concat%xsegs(ixseg)%blk -! jblk = srf_concat%ysegs(iyseg)%blk - -! if (gblock%pio(iblk,jblk) == p_iam_glb) then - -! xbdsp = srf_concat%xsegs(ixseg)%bdsp -! ybdsp = srf_concat%ysegs(iyseg)%bdsp -! xcnt = srf_concat%xsegs(ixseg)%cnt -! ycnt = srf_concat%ysegs(iyseg)%cnt - -! allocate (sbuf (ntyps,xcnt,ycnt)) -! sbuf = wdata%blk(iblk,jblk)%val(:,xbdsp+1:xbdsp+xcnt,ybdsp+1:ybdsp+ycnt) - -! smesg = (/p_iam_glb, ixseg, iyseg/) -! call mpi_send (smesg, 3, MPI_INTEGER, & -! p_root, srf_data_id, p_comm_glb, p_err) -! call mpi_send (sbuf, ntyps*xcnt*ycnt, MPI_DOUBLE, & -! p_root, srf_data_id, p_comm_glb, p_err) - -! deallocate (sbuf) -! end if -! end do -! end do -! end if -! #endif - -! srf_data_id = srf_data_id + 1 - -! elseif (trim(wmode) == 'block') then - -! if (p_is_io) then - -! DO iblkme = 1, gblock%nblkme -! iblk = gblock%xblkme(iblkme) -! jblk = gblock%yblkme(iblkme) - -! if ((gdiag%xcnt(iblk) == 0) .or. (gdiag%ycnt(jblk) == 0)) cycle - -! call get_filename_block (filename, iblk, jblk, fileblock) - -! inquire (file=trim(filename), exist=fexists) -! IF (.not. fexists) THEN -! CALL ncio_create_file (fileblock) -! call ncio_define_dimension (fileblock, 'TypeIndex', ntyps) -! CALL srf_write_grid_info (fileblock, gdiag, iblk, jblk) -! ENDIF - -! call ncio_write_serial (fileblock, dataname, & -! wdata%blk(iblk,jblk)%val, 'TypeIndex', 'lon', 'lat', compress) - -! CALL ncio_put_attr (fileblock, dataname, 'missing_value', spv) - -! end do - -! end if -! end if - -! IF (allocated(vecone)) deallocate(vecone) - -! end subroutine srfdata_map_and_write_int - !------------------ subroutine srf_write_grid_info (fileblock, grid, iblk, jblk) diff --git a/mksrfdata/MOD_SrfdataRestart.F90 b/mksrfdata/MOD_SrfdataRestart.F90 index e3e7cee5..be3d26b0 100644 --- a/mksrfdata/MOD_SrfdataRestart.F90 +++ b/mksrfdata/MOD_SrfdataRestart.F90 @@ -37,12 +37,14 @@ SUBROUTINE mesh_save_to_file (dir_landdata, lc_year) ! Local variables CHARACTER(len=256) :: filename, fileblock, cyear - INTEGER :: ie, je, nelm, elen, iblk, jblk, iworker, i - INTEGER, allocatable :: nelm_worker(:), ndsp_worker(:) - INTEGER, allocatable :: elmindx(:) - INTEGER, allocatable :: npxlall(:) - INTEGER, allocatable :: elmpixels(:,:,:) - REAL(r8),allocatable :: lon(:), lat(:) + INTEGER :: ie, je, nelm, totlen, tothis, iblk, jblk, iworker, i + INTEGER, allocatable :: nelm_worker(:), ndsp_worker(:) + INTEGER*8, allocatable :: elmindx(:) + INTEGER, allocatable :: npxlall(:) + INTEGER, allocatable :: elmpixels(:,:) + REAL(r8), allocatable :: lon(:), lat(:) + + INTEGER :: nsend, nrecv, ndone, ndsp ! add parameter input for time year write(cyear,'(i4.4)') lc_year @@ -67,33 +69,32 @@ SUBROUTINE mesh_save_to_file (dir_landdata, lc_year) IF (gblock%pio(iblk,jblk) == p_address_io(p_my_group)) THEN #endif nelm = 0 - elen = 0 + totlen = 0 DO ie = 1, numelm IF ((mesh(ie)%xblk == iblk) .and. (mesh(ie)%yblk == jblk)) THEN nelm = nelm + 1 - elen = max(elen, mesh(ie)%npxl) + totlen = totlen + mesh(ie)%npxl ENDIF ENDDO -#ifdef USEMPI - CALL mpi_allreduce (MPI_IN_PLACE, elen, 1, MPI_INTEGER, MPI_MAX, p_comm_group, p_err) -#endif - IF (nelm > 0) THEN allocate (elmindx (nelm)) allocate (npxlall (nelm)) - allocate (elmpixels (2,elen,nelm)) + allocate (elmpixels (2,totlen)) je = 0 + ndsp = 0 DO ie = 1, numelm IF ((mesh(ie)%xblk == iblk) .and. (mesh(ie)%yblk == jblk)) THEN je = je + 1 elmindx(je) = mesh(ie)%indx npxlall(je) = mesh(ie)%npxl - elmpixels(1,1:npxlall(je),je) = mesh(ie)%ilon - elmpixels(2,1:npxlall(je),je) = mesh(ie)%ilat + elmpixels(1,ndsp+1:ndsp+npxlall(je)) = mesh(ie)%ilon + elmpixels(2,ndsp+1:ndsp+npxlall(je)) = mesh(ie)%ilat + + ndsp = ndsp + npxlall(je) ENDIF ENDDO ENDIF @@ -102,18 +103,23 @@ SUBROUTINE mesh_save_to_file (dir_landdata, lc_year) CALL mpi_gather (nelm, 1, MPI_INTEGER, & MPI_INULL_P, 1, MPI_INTEGER, p_root, p_comm_group, p_err) - CALL mpi_gatherv (elmindx, nelm, MPI_INTEGER, & - MPI_INULL_P, MPI_INULL_P, MPI_INULL_P, MPI_INTEGER, & ! insignificant on workers + CALL mpi_gatherv (elmindx, nelm, MPI_INTEGER8, & + MPI_INULL_P, MPI_INULL_P, MPI_INULL_P, MPI_INTEGER8, & ! insignificant on workers p_root, p_comm_group, p_err) CALL mpi_gatherv (npxlall, nelm, MPI_INTEGER, & MPI_INULL_P, MPI_INULL_P, MPI_INULL_P, MPI_INTEGER, & ! insignificant on workers p_root, p_comm_group, p_err) - DO ie = 1, nelm - CALL mpi_send (elmpixels(:,:,ie), 2*elen, MPI_INTEGER, & - p_root, mpi_tag_data, p_comm_group, p_err) - ENDDO + ndone = 0 + DO WHILE (ndone < totlen) + nsend = max(min(totlen-ndone, MesgMaxSize/8), 1) + CALL mpi_send (nsend, 1, & + MPI_INTEGER, p_root, mpi_tag_size, p_comm_group, p_err) + CALL mpi_send (elmpixels(:,ndone+1:ndone+nsend), 2*nsend, & + MPI_INTEGER, p_root, mpi_tag_data, p_comm_group, p_err) + ndone = ndone + nsend + ENDDO ENDIF ENDIF #endif @@ -122,9 +128,6 @@ SUBROUTINE mesh_save_to_file (dir_landdata, lc_year) IF (p_is_io) THEN IF (gblock%pio(iblk,jblk) == p_iam_glb) THEN - elen = 0 - CALL mpi_allreduce (MPI_IN_PLACE, elen, 1, MPI_INTEGER, MPI_MAX, p_comm_group, p_err) - allocate (nelm_worker (0:p_np_group-1)) nelm_worker(0) = 0 CALL mpi_gather (MPI_IN_PLACE, 0, MPI_INTEGER, & @@ -139,8 +142,8 @@ SUBROUTINE mesh_save_to_file (dir_landdata, lc_year) ENDDO allocate (elmindx (nelm)) - CALL mpi_gatherv (MPI_IN_PLACE, 0, MPI_INTEGER, & - elmindx, nelm_worker(0:), ndsp_worker(0:), MPI_INTEGER, & + CALL mpi_gatherv (MPI_IN_PLACE, 0, MPI_INTEGER8, & + elmindx, nelm_worker(0:), ndsp_worker(0:), MPI_INTEGER8, & p_root, p_comm_group, p_err) allocate (npxlall (nelm)) @@ -148,11 +151,23 @@ SUBROUTINE mesh_save_to_file (dir_landdata, lc_year) npxlall, nelm_worker(0:), ndsp_worker(0:), MPI_INTEGER, & p_root, p_comm_group, p_err) - allocate (elmpixels (2, elen, nelm)) + totlen = sum(npxlall) + allocate (elmpixels (2, totlen)) + + ndone = 0 DO iworker = 1, p_np_group-1 - DO ie = ndsp_worker(iworker)+1, ndsp_worker(iworker)+nelm_worker(iworker) - CALL mpi_recv (elmpixels(:,:,ie), 2*elen, MPI_INTEGER, & - iworker, mpi_tag_data, p_comm_group, p_stat, p_err) + + ndsp = ndsp_worker(iworker) + tothis = ndone + sum(npxlall(ndsp+1:ndsp+nelm_worker(iworker))) + + DO WHILE (ndone < tothis) + + CALL mpi_recv (nrecv, 1, & + MPI_INTEGER, iworker, mpi_tag_size, p_comm_group, p_stat, p_err) + CALL mpi_recv (elmpixels(:,ndone+1:ndone+nrecv), 2*nrecv, & + MPI_INTEGER, iworker, mpi_tag_data, p_comm_group, p_stat, p_err) + + ndone = ndone + nrecv ENDDO ENDDO ENDIF @@ -166,13 +181,13 @@ SUBROUTINE mesh_save_to_file (dir_landdata, lc_year) CALL ncio_create_file (fileblock) CALL ncio_define_dimension (fileblock, 'element',nelm) - CALL ncio_define_dimension (fileblock, 'np_max', elen) CALL ncio_define_dimension (fileblock, 'ncoor', 2 ) + CALL ncio_define_dimension (fileblock, 'pixel', totlen) CALL ncio_write_serial (fileblock, 'elmindex', elmindx, 'element') CALL ncio_write_serial (fileblock, 'elmnpxl', npxlall, 'element') CALL ncio_write_serial (fileblock, 'elmpixels', elmpixels, & - 'ncoor', 'np_max', 'element', compress = 1) + 'ncoor', 'pixel', compress = 1) ENDIF ENDIF ENDIF @@ -246,8 +261,10 @@ SUBROUTINE mesh_load_from_file (dir_landdata, lc_year) ! Local variables CHARACTER(len=256) :: filename, fileblock, cyear - INTEGER :: iblkme, iblk, jblk, ie, nelm, ndsp - INTEGER, allocatable :: elmindx(:), npxl(:), pixels(:,:,:) + INTEGER :: iblkme, iblk, jblk, ie, nelm, ndsp, pdsp + INTEGER*8, allocatable :: elmindx(:) + INTEGER, allocatable :: datasize(:) + INTEGER, allocatable :: npxl(:), pixels(:,:), pixels2d(:,:,:) #ifdef USEMPI CALL mpi_barrier (p_comm_glb, p_err) @@ -282,8 +299,15 @@ SUBROUTINE mesh_load_from_file (dir_landdata, lc_year) CALL get_filename_block (filename, iblk, jblk, fileblock) CALL ncio_read_serial (fileblock, 'elmindex', elmindx) CALL ncio_read_serial (fileblock, 'elmnpxl', npxl ) - CALL ncio_read_serial (fileblock, 'elmpixels', pixels ) + CALL ncio_inquire_varsize (fileblock, 'elmpixels', datasize) + IF (size(datasize) == 3) THEN + CALL ncio_read_serial (fileblock, 'elmpixels', pixels2d) + ELSE + CALL ncio_read_serial (fileblock, 'elmpixels', pixels) + ENDIF + + pdsp = 0 DO ie = 1, nelm mesh(ie+ndsp)%indx = elmindx(ie) mesh(ie+ndsp)%npxl = npxl(ie) @@ -293,8 +317,14 @@ SUBROUTINE mesh_load_from_file (dir_landdata, lc_year) allocate (mesh(ie+ndsp)%ilon (npxl(ie))) allocate (mesh(ie+ndsp)%ilat (npxl(ie))) - mesh(ie+ndsp)%ilon = pixels(1,1:npxl(ie),ie) - mesh(ie+ndsp)%ilat = pixels(2,1:npxl(ie),ie) + IF (size(datasize) == 3) THEN + mesh(ie+ndsp)%ilon = pixels2d(1,1:npxl(ie),ie) + mesh(ie+ndsp)%ilat = pixels2d(2,1:npxl(ie),ie) + ELSE + mesh(ie+ndsp)%ilon = pixels(1,pdsp+1:pdsp+npxl(ie)) + mesh(ie+ndsp)%ilat = pixels(2,pdsp+1:pdsp+npxl(ie)) + pdsp = pdsp + npxl(ie) + ENDIF ENDDO ndsp = ndsp + nelm @@ -302,9 +332,11 @@ SUBROUTINE mesh_load_from_file (dir_landdata, lc_year) ENDDO ENDIF - IF (allocated(elmindx)) deallocate(elmindx) - IF (allocated(npxl )) deallocate(npxl ) - IF (allocated(pixels)) deallocate(pixels ) + IF (allocated(elmindx )) deallocate(elmindx ) + IF (allocated(npxl )) deallocate(npxl ) + IF (allocated(datasize)) deallocate(datasize) + IF (allocated(pixels )) deallocate(pixels ) + IF (allocated(pixels2d)) deallocate(pixels2d) ENDIF @@ -389,11 +421,12 @@ SUBROUTINE pixelset_load_from_file (dir_landdata, psetname, pixelset, numset, lc INTEGER, intent(out) :: numset ! Local variables - CHARACTER(len=256) :: filename, fileblock, cyear + CHARACTER(len=256) :: filename, fileblock, blockname, cyear INTEGER :: iset, nset, ndsp, iblkme, iblk, jblk, ie, je, nave, nres, left, iproc INTEGER :: nsend, nrecv - INTEGER, allocatable :: rbuff(:), iworker(:), sbuff(:) - LOGICAL, allocatable :: msk(:) + INTEGER*8, allocatable :: rbuff(:), sbuff(:) + INTEGER, allocatable :: iworker(:) + LOGICAL, allocatable :: msk(:) LOGICAL :: fexists, fexists_any write(cyear,'(i4.4)') lc_year @@ -417,6 +450,12 @@ SUBROUTINE pixelset_load_from_file (dir_landdata, psetname, pixelset, numset, lc iblk = gblock%xblkme(iblkme) jblk = gblock%yblkme(iblkme) +#ifdef VectorInOneFile + CALL get_blockname (iblk, jblk, blockname) + CALL ncio_inquire_length_grp (filename, 'eindex', & + trim(psetname)//'_'//trim(blockname), nset) + pixelset%nset = pixelset%nset + nset +#else CALL get_filename_block (filename, iblk, jblk, fileblock) inquire (file=trim(fileblock), exist=fexists) @@ -426,19 +465,19 @@ SUBROUTINE pixelset_load_from_file (dir_landdata, psetname, pixelset, numset, lc ENDIF fexists_any = fexists_any .or. fexists - +#endif ENDDO +#ifdef VectorInOneFile + fexists_any = pixelset%nset > 0 +#endif + #ifdef USEMPI CALL mpi_allreduce (MPI_IN_PLACE, fexists_any, 1, MPI_LOGICAL, MPI_LOR, p_comm_io, p_err) #endif IF (.not. fexists_any) THEN write(*,*) 'Warning : restart file ' //trim(filename)// ' not found.' -#ifdef USEMPI - CALL mpi_abort (p_comm_glb, p_err) -#else - STOP -#endif + CALL CoLM_stop () ENDIF IF (pixelset%nset > 0) THEN @@ -450,6 +489,21 @@ SUBROUTINE pixelset_load_from_file (dir_landdata, psetname, pixelset, numset, lc iblk = gblock%xblkme(iblkme) jblk = gblock%yblkme(iblkme) +#ifdef VectorInOneFile + CALL get_blockname (iblk, jblk, blockname) + CALL ncio_inquire_length_grp (filename, 'eindex', & + trim(psetname)//'_'//trim(blockname), nset) + + IF (nset > 0) THEN + + CALL ncio_read_serial_grp_int64_1d (filename, 'eindex', & + trim(psetname)//'_'//trim(blockname), rbuff) + + pixelset%eindex(ndsp+1:ndsp+nset) = rbuff + + ndsp = ndsp + nset + ENDIF +#else CALL get_filename_block (filename, iblk, jblk, fileblock) inquire (file=trim(fileblock), exist=fexists) IF (fexists) THEN @@ -461,6 +515,7 @@ SUBROUTINE pixelset_load_from_file (dir_landdata, psetname, pixelset, numset, lc ndsp = ndsp + nset ENDIF +#endif ENDDO ENDIF @@ -506,7 +561,7 @@ SUBROUTINE pixelset_load_from_file (dir_landdata, psetname, pixelset, numset, lc IF (nsend > 0) THEN allocate (sbuff(nsend)) sbuff = pack(pixelset%eindex, msk) - CALL mpi_send (sbuff, nsend, MPI_INTEGER, iproc, mpi_tag_data, p_comm_group, p_err) + CALL mpi_send (sbuff, nsend, MPI_INTEGER8, iproc, mpi_tag_data, p_comm_group, p_err) deallocate (sbuff) ENDIF ENDDO @@ -526,7 +581,7 @@ SUBROUTINE pixelset_load_from_file (dir_landdata, psetname, pixelset, numset, lc pixelset%nset = nrecv IF (nrecv > 0) THEN allocate (pixelset%eindex (nrecv)) - CALL mpi_recv (pixelset%eindex, nrecv, MPI_INTEGER, & + CALL mpi_recv (pixelset%eindex, nrecv, MPI_INTEGER8, & p_root, mpi_tag_data, p_comm_group, p_stat, p_err) ENDIF ENDIF diff --git a/postprocess/HistConcatenate.F90 b/postprocess/HistConcatenate.F90 index d8a13f17..0f1628c2 100755 --- a/postprocess/HistConcatenate.F90 +++ b/postprocess/HistConcatenate.F90 @@ -85,6 +85,9 @@ program hist_concatenate call hist_concatenate_var_2d (filehist, 'f_fevpa ', timelen, compress, & 'evapotranspiration from canopy height to atmosphere','mm/s') + call hist_concatenate_var_2d (filehist, 'f_fevpg ', timelen, compress, & + 'evaporation heat flux from ground [mm/s]') + call hist_concatenate_var_2d (filehist, 'f_fsenl ', timelen, compress, & 'sensible heat from leaves','W/m2') diff --git a/postprocess/SrfDataConcatenate.F90 b/postprocess/SrfDataConcatenate.F90 index 1cbd7d92..d4a494e0 100644 --- a/postprocess/SrfDataConcatenate.F90 +++ b/postprocess/SrfDataConcatenate.F90 @@ -10,8 +10,9 @@ program srfdata_concatenate character(len=256) :: tmpfile, file_list_cmd INTEGER :: timevals (8) - LOGICAL :: dim1to2 - INTEGER :: filter, nfile, ifile, nthis, dsp, ntotal, bsnmax + LOGICAL :: dim1to2 + INTEGER :: filter, nfile, ifile, nthis, dsp, ntotal + INTEGER*8 :: bsnmax character(len=256) :: line, blockinfo, varfile, levfile, landfile REAL(r8), allocatable :: longitude(:), latitude(:) @@ -21,17 +22,18 @@ program srfdata_concatenate REAL(r8), allocatable :: val(:) END TYPE TYPE :: varint - INTEGER, allocatable :: val(:) + INTEGER*8, allocatable :: val(:) END TYPE TYPE(varreal), allocatable :: varvec(:) TYPE(varint ), allocatable :: bsnvec(:) - REAL(r8), allocatable :: varcache1(:), varcache2(:,:) - INTEGER , allocatable :: bsncache1(:), bsncache2(:,:) - REAL(r8), allocatable :: vardata(:) - INTEGER , allocatable :: eindex (:), settyp(:) - INTEGER , allocatable :: order (:) + REAL(r8), allocatable :: varcache1(:), varcache2(:,:) + INTEGER*8, allocatable :: bsncache1(:), bsncache2(:,:) + REAL(r8), allocatable :: vardata(:) + INTEGER*8, allocatable :: eindex (:) + INTEGER , allocatable :: settyp (:) + INTEGER , allocatable :: order (:) INTEGER :: stat, i, j, ibasin REAL(r8), parameter :: spval = -1.e36_r8 !missing value diff --git a/preprocess/Forcings/GDAS_GPCP/step2_Merge_Data.sh b/preprocess/Forcings/GDAS_GPCP/step2_Merge_Data.sh index c6a6d4ed..b327df97 100644 --- a/preprocess/Forcings/GDAS_GPCP/step2_Merge_Data.sh +++ b/preprocess/Forcings/GDAS_GPCP/step2_Merge_Data.sh @@ -3,6 +3,7 @@ #Year1="1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017" +mkdir -p GDAS_GPCP Year1="2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016" for Year in ${Year1};do Month1="01 02 03 04 05 06 07 08 09 10 11 12" @@ -28,4 +29,12 @@ DAY=`expr ${DAY} + 1` done done #month cdo mergetime GLDAS_NOAH025_3H.A${Year}${Month}*_*.nc GLDAS_NOAH025_3H.A${Year}${Month}.nc +cdo selname,LWdown_f_tavg GLDAS_NOAH025_3H.A${Year}${Month}.nc GDAS_GPCP/GLDAS_GDAS_3H_LWdown.${Year}${Month}.nc +cdo selname,SWdown_f_tavg GLDAS_NOAH025_3H.A${Year}${Month}.nc GDAS_GPCP/GLDAS_GDAS_3H_SWdown.${Year}${Month}.nc +cdo selname,Tair_f_inst GLDAS_NOAH025_3H.A${Year}${Month}.nc GDAS_GPCP/GLDAS_GDAS_3H_Tair.${Year}${Month}.nc +cdo selname,Qair_f_inst GLDAS_NOAH025_3H.A${Year}${Month}.nc GDAS_GPCP/GLDAS_GDAS_3H_Qair.${Year}${Month}.nc +cdo selname,Psurf_f_inst GLDAS_NOAH025_3H.A${Year}${Month}.nc GDAS_GPCP/GLDAS_GDAS_3H_Psurf.${Year}${Month}.nc +cdo selname,Wind_f_inst GLDAS_NOAH025_3H.A${Year}${Month}.nc GDAS_GPCP/GLDAS_GDAS_3H_Wind.${Year}${Month}.nc +cdo selname,Rainf_f_tavg GLDAS_NOAH025_3H.A${Year}${Month}.nc GDAS_GPCP/GLDAS_GDAS_3H_tot_prcip.${Year}${Month}.nc +rm GLDAS_NOAH025_3H.A${Year}*.nc done #year diff --git a/preprocess/Forcings/GDAS_GPCP/step3_Reduce_Dimension.sh b/preprocess/Forcings/GDAS_GPCP/step3_Reduce_Dimension.sh index ce5196ef..7c8481fd 100644 --- a/preprocess/Forcings/GDAS_GPCP/step3_Reduce_Dimension.sh +++ b/preprocess/Forcings/GDAS_GPCP/step3_Reduce_Dimension.sh @@ -6,22 +6,17 @@ #!/bin/bash SYear=2002 EYear=2022 -varnames="PRE PRS SHU SSRA TMP WIN" Months="01 02 03 04 05 06 07 08 09 10 11 12" -#varnames="tot_prcip Psurf" -#for varname in ${varnames}; do - while [ ${SYear} -le ${EYear} ] ; do - Year=${SYear} - for Month in ${Months};do - cdo --reduce_dim -f nc4c copy GDAS_GPCP/GLDAS_GDAS_3H_tot_prcip.${Year}${Month}.nc GDAS_GPCP/GLDAS_GDAS_3H_tot_prcip.${Year}${Month}.nc4 - cdo --reduce_dim -f nc4c copy GDAS_GPCP/GLDAS_GDAS_3H_Psurf.${Year}${Month}.nc GDAS_GPCP/GLDAS_GDAS_3H_Psurf.${Year}${Month}.nc4 - cdo --reduce_dim -f nc4c copy GDAS_GPCP/GLDAS_GDAS_3H_Qair.${Year}${Month}.nc GDAS_GPCP/GLDAS_GDAS_3H_Qair.${Year}${Month}.nc4 - cdo --reduce_dim -f nc4c copy GDAS_GPCP/GLDAS_GDAS_3H_LWdown.${Year}${Month}.nc GDAS_GPCP/GLDAS_GDAS_3H_LWdown.${Year}${Month}.nc4 - cdo --reduce_dim -f nc4c copy GDAS_GPCP/GLDAS_GDAS_3H_SWdown.${Year}${Month}.nc GDAS_GPCP/GLDAS_GDAS_3H_SWdown.${Year}${Month}.nc4 - cdo --reduce_dim -f nc4c copy GDAS_GPCP/GLDAS_GDAS_3H_Tair.${Year}${Month}.nc GDAS_GPCP/GLDAS_GDAS_3H_Tair.${Year}${Month}.nc4 - cdo --reduce_dim -f nc4c copy GDAS_GPCP/GLDAS_GDAS_3H_Wind.${Year}${Month}.nc GDAS_GPCP/GLDAS_GDAS_3H_Wind.${Year}${Month}.nc4 - done - - SYear=`expr $SYear + 1` +while [ ${SYear} -le ${EYear} ] ; do + Year=${SYear} + for Month in ${Months};do + cdo --reduce_dim -f nc4c copy GDAS_GPCP/GLDAS_GDAS_3H_tot_prcip.${Year}${Month}.nc GDAS_GPCP/GLDAS_GDAS_3H_tot_prcip.${Year}${Month}.nc4 + cdo --reduce_dim -f nc4c copy GDAS_GPCP/GLDAS_GDAS_3H_Psurf.${Year}${Month}.nc GDAS_GPCP/GLDAS_GDAS_3H_Psurf.${Year}${Month}.nc4 + cdo --reduce_dim -f nc4c copy GDAS_GPCP/GLDAS_GDAS_3H_Qair.${Year}${Month}.nc GDAS_GPCP/GLDAS_GDAS_3H_Qair.${Year}${Month}.nc4 + cdo --reduce_dim -f nc4c copy GDAS_GPCP/GLDAS_GDAS_3H_LWdown.${Year}${Month}.nc GDAS_GPCP/GLDAS_GDAS_3H_LWdown.${Year}${Month}.nc4 + cdo --reduce_dim -f nc4c copy GDAS_GPCP/GLDAS_GDAS_3H_SWdown.${Year}${Month}.nc GDAS_GPCP/GLDAS_GDAS_3H_SWdown.${Year}${Month}.nc4 + cdo --reduce_dim -f nc4c copy GDAS_GPCP/GLDAS_GDAS_3H_Tair.${Year}${Month}.nc GDAS_GPCP/GLDAS_GDAS_3H_Tair.${Year}${Month}.nc4 + cdo --reduce_dim -f nc4c copy GDAS_GPCP/GLDAS_GDAS_3H_Wind.${Year}${Month}.nc GDAS_GPCP/GLDAS_GDAS_3H_Wind.${Year}${Month}.nc4 + done + SYear=`expr $SYear + 1` done -#done \ No newline at end of file diff --git a/preprocess/Forcings/MSWX/step2_Merge_Data.sh b/preprocess/Forcings/MSWX/step2_Merge_Data.sh index 9442a2b7..eb71636e 100644 --- a/preprocess/Forcings/MSWX/step2_Merge_Data.sh +++ b/preprocess/Forcings/MSWX/step2_Merge_Data.sh @@ -4,7 +4,6 @@ # code for remove the dimension of z to reduce the size of data and make it easy to read in colm # prepared by: zhongwang Wei @ SYSU 2021-10-20, Zhongwang007@gmail.com -#!/bin/bash SYear=2002 EYear=2022 INPath=MSWX @@ -36,7 +35,8 @@ cd ${INPath}/${Var} while [ ${SYear} -le ${EYear} ] ; do Year=${SYear} for Month in ${Months};do - cdo -b F32 -f nc mergetime 3hourly/${Year}${Month}*.nc4 ${Var}_${Year}${Month}.nc + cdo -b F32 -f nc mergetime 3hourly/${Year}${Month}*.nc4 var_temp.nc + cdo invertlat var_temp.nc ${Var}_${Year}${Month}.nc done SYear=`expr $SYear + 1` done diff --git a/run/China_Grid_50km_IGBP_VG.nml b/run/China_Grid_50km_IGBP_VG.nml new file mode 100644 index 00000000..fbc89172 --- /dev/null +++ b/run/China_Grid_50km_IGBP_VG.nml @@ -0,0 +1,68 @@ +&nl_colm + +! Author: Shupeng Zhang +! Description : include soil state init from data. + + DEF_CASE_NAME = 'China_Grid_10km_IGBP_VG' + + DEF_domain%edges = 0.0 + DEF_domain%edgen = 55.0 + DEF_domain%edgew = 70.0 + DEF_domain%edgee = 140.0 + + DEF_simulation_time%greenwich = .TRUE. + DEF_simulation_time%start_year = 2010 + DEF_simulation_time%start_month = 1 + DEF_simulation_time%start_day = 1 + DEF_simulation_time%start_sec = 0 + DEF_simulation_time%end_year = 2015 + DEF_simulation_time%end_month = 12 + DEF_simulation_time%end_day = 31 + DEF_simulation_time%end_sec = 86400 + DEF_simulation_time%spinup_year = 0 + DEF_simulation_time%spinup_month = 1 + DEF_simulation_time%spinup_day = 365 + DEF_simulation_time%spinup_sec = 86400 + DEF_simulation_time%spinup_repeat = 0 + + DEF_simulation_time%timestep = 1800. + + DEF_dir_rawdata = '/tera07/CoLMrawdata/' + DEF_dir_runtime = '/tera07/CoLMruntime/' + DEF_dir_output = '/tera05/zhangsp/cases' + + ! ----- land units and land sets ----- + ! for GRIDBASED + DEF_GRIDBASED_lon_res = 0.5 + DEF_GRIDBASED_lat_res = 0.5 + + ! soil state init + DEF_USE_SoilInit = .true. + DEF_file_SoilInit = '/tera05/zhangsp/data/soilstate/soilstate.nc' + + ! LAI setting + DEF_LAI_MONTHLY = .true. + DEF_LAI_CHANGE_YEARLY = .false. + + DEF_USE_PLANTHYDRAULICS = .false. + + ! ----- forcing ----- + ! Options : + ! PRINCETON | GSWP3 | QIAN | CRUNCEPV4 | CRUNCEPV7 | ERA5LAND | ERA5 | MSWX + ! WFDE5 | CRUJRA | WFDEI | JRA55 | GDAS | CMFD | POINT + DEF_forcing_namelist = '/tera04/zhangsp/git/CoLM202X/run/forcing/ERA5LAND.nml' + + ! ----- history ----- + DEF_hist_grid_as_forcing = .true. + DEF_WRST_FREQ = 'YEARLY' ! write restart file frequency: HOURLY/DAILY/MONTHLY/YEARLY + DEF_HIST_FREQ = 'MONTHLY' ! write history file frequency: HOURLY/DAILY/MONTHLY/YEARLY + DEF_HIST_groupby = 'MONTH' ! history in one file: DAY/MONTH/YEAR + DEF_HIST_mode = 'one' ! history in one or block + DEF_REST_COMPRESS_LEVEL = 1 + DEF_HIST_COMPRESS_LEVEL = 1 + + DEF_HIST_WriteBack = .true. + + DEF_hist_vars_out_default = .true. + +/ diff --git a/run/gridbased_era5_pft_1981-2020.nml b/run/Global_Grid_2x2_PFT_VG_BGC.nml similarity index 60% rename from run/gridbased_era5_pft_1981-2020.nml rename to run/Global_Grid_2x2_PFT_VG_BGC.nml index 03fa2b06..4fb1cf8e 100644 --- a/run/gridbased_era5_pft_1981-2020.nml +++ b/run/Global_Grid_2x2_PFT_VG_BGC.nml @@ -1,61 +1,57 @@ &nl_colm - DEF_CASE_NAME = 'gridbase_era5_2deg_hist' +!Author: Xingjie Lu + + DEF_CASE_NAME = 'GlobalBGCPFTnoCROPHist1851-2014-newPHS' DEF_domain%edges = -90.0 DEF_domain%edgen = 90.0 DEF_domain%edgew = -180.0 DEF_domain%edgee = 180.0 -! DEF_domain%edges = 21.0 -! DEF_domain%edgen = 27.0 -! DEF_domain%edgew = 100.0 -! DEF_domain%edgee = 115.0 - - DEF_nx_blocks = 3 - DEF_ny_blocks = 3 - DEF_PIO_groupsize = 6 + DEF_nx_blocks = 18 + DEF_ny_blocks = 9 + DEF_PIO_groupsize = 12 DEF_simulation_time%greenwich = .TRUE. - DEF_simulation_time%start_year = 1980 - DEF_simulation_time%start_month = 1 - DEF_simulation_time%start_day = 365 + DEF_simulation_time%start_year = 1849 + DEF_simulation_time%start_month = 12 + DEF_simulation_time%start_day = 31 DEF_simulation_time%start_sec = 86400 - DEF_simulation_time%end_year = 2021 - DEF_simulation_time%end_month = 1 - DEF_simulation_time%end_day = 365 + DEF_simulation_time%end_year = 2014 + DEF_simulation_time%end_month = 12 + DEF_simulation_time%end_day = 31 DEF_simulation_time%end_sec = 86400 - DEF_simulation_time%spinup_year = 1980 + DEF_simulation_time%spinup_year = 0 DEF_simulation_time%spinup_month = 1 DEF_simulation_time%spinup_day = 365 DEF_simulation_time%spinup_sec = 86400 - DEF_simulation_time%spinup_repeat = 2 + DEF_simulation_time%spinup_repeat = 0 DEF_simulation_time%timestep = 1800. - DEF_dir_rawdata = '/share/home/dq010/CoLM/data/rawdata/CROP-NITRIF/CLMrawdata_igbp' - DEF_dir_output = '/share/home/dq010/CoLM/CoLM202X-CROP//cases' + DEF_dir_rawdata = '/share/home/dq010/CoLM/data/rawdata/CROP-NITRIF/CLMrawdata_updating//' + DEF_dir_runtime = '/share/home/dq010/CoLM/data/rawdata/CROP-NITRIF/CoLMruntime//' + DEF_dir_output = '/share/home/dq010/CoLM/CoLM202X-CROP/cases/' ! ----- land units and land sets ----- ! for GRIDBASED - DEF_file_mesh = '/share/home/dq010/CoLM/data/landdata/landmask_igbp_144x96.nc' + DEF_GRIDBASED_lon_res = 2.5 + DEF_GRIDBASED_lat_res = 1.875 ! LAI setting DEF_LAI_MONTHLY = .true. - - ! Model settings - DEF_LANDONLY = .true. - DEF_USE_DOMINANT_PATCHTYPE = .false. - DEF_USE_VARIABLY_SATURATED_FLOW = .true. + DEF_LAI_CHANGE_YEARLY = .false. ! Canopy DEF Interception scheme selection DEF_Interception_scheme=1 !1:CoLM2014；2:CLM4.5; 3:CLM5; 4:Noah-MP; 5:MATSIRO; 6:VIC +! DEF_USE_IRRIGATION = .true. ! ----- forcing ----- ! Options : ! PRINCETON | GSWP3 | QIAN | CRUNCEPV4 | CRUNCEPV7 | ERA5LAND | ERA5 | MSWX ! WFDE5 | CRUJRA | WFDEI | JRA55 | GDAS | CMFD | POINT - DEF_forcing_namelist = '/share/home/dq010/CoLM/CoLM202X-CROP//run/forcing/ERA5-boat.nml' + DEF_forcing_namelist = '/share/home/dq010/CoLM/CoLM202X-CROP//run/forcing/GSWP3-boat.nml' ! ----- history ----- DEF_hist_lon_res = 2.5 @@ -67,7 +63,7 @@ DEF_REST_COMPRESS_LEVEL = 1 DEF_HIST_COMPRESS_LEVEL = 1 - DEF_hist_vars_namelist = '/share/home/dq010/CoLM/CoLM202X-CROP//cases/test_20221221_full/history.nml' - DEF_hist_vars_turnon_all = .true. + DEF_hist_vars_namelist = '/share/home/dq010/CoLM/CoLM202X-CROP/cases/GlobalBGCPFTnoCROPHist1851-2014-newPHS/history.nml' + DEF_hist_vars_out_default = .true. / diff --git a/run/Global_Grid_50km_IGBP_CB_URBAN.nml b/run/Global_Grid_50km_IGBP_CB_URBAN.nml new file mode 100644 index 00000000..5707b1b3 --- /dev/null +++ b/run/Global_Grid_50km_IGBP_CB_URBAN.nml @@ -0,0 +1,117 @@ +&nl_colm + +!Author: Wenzong Dong + + DEF_CASE_NAME = 'GlobalURBANIGBPHist2000-2020' + + DEF_domain%edges = -90.0 + DEF_domain%edgen = 90.0 + DEF_domain%edgew = -180.0 + DEF_domain%edgee = 180.0 + + DEF_nx_blocks = 30 + DEF_ny_blocks = 30 + DEF_PIO_groupsize = 6 + + DEF_simulation_time%greenwich = .TRUE. + DEF_simulation_time%start_year = 1995 + DEF_simulation_time%start_month = 1 + DEF_simulation_time%start_day = 1 + DEF_simulation_time%start_sec = 0 + DEF_simulation_time%end_year = 2021 + DEF_simulation_time%end_month = 1 + DEF_simulation_time%end_day = 1 + DEF_simulation_time%end_sec = 0 + DEF_simulation_time%spinup_year = 2000 + DEF_simulation_time%spinup_month = 1 + DEF_simulation_time%spinup_day = 1 + DEF_simulation_time%spinup_sec = 0 + DEF_simulation_time%spinup_repeat= 0 + + DEF_simulation_time%timestep = 1800. + + DEF_dir_rawdata = '/stu01/dongwz/data/CoLMrawdata/' + DEF_dir_runtime = '/stu01/dongwz/data/CoLMruntime/' + DEF_dir_output = '/stu01/dongwz/cases' + + ! ----- land units and land sets ----- + ! for GRIDBASED + DEF_GRIDBASED_lon_res = 0.5 + DEF_GRIDBASED_lat_res = 0.5 + + ! LAI setting + DEF_LAI_MONTHLY = .true. + DEF_LAI_CHANGE_YEARLY = .false. + + ! LandCover setting + DEF_LC_YEAR = 2005 + + !---- Urban options ---- + ! urban type options + ! Options : + ! 1: NCAR Urban Classification, 3 urban type with Tall Building, High Density and Medium Density + ! 2: LCZ Classification, 10 urban type with LCZ 1-10 + DEF_URBAN_type_scheme = 1 + + ! urban module options + DEF_URBAN_ONLY = .false. + DEF_URBAN_TREE = .true. + DEF_URBAN_WATER= .true. + DEF_URBAN_BEM = .true. + DEF_URBAN_LUCY = .true. + ! ----------------------- + + ! Canopy DEF Interception scheme selection + DEF_Interception_scheme=1 !1:CoLM2014；2:CLM4.5; 3:CLM5; 4:Noah-MP; 5:MATSIRO; 6:VIC + + ! ---- Hydrology module ---- + DEF_USE_SUPERCOOL_WATER = .false. + DEF_USE_VARIABLY_SATURATED_FLOW = .false. + DEF_USE_PLANTHYDRAULICS = .false. + ! -------------------------- + + ! ---- SNICAR ---- + DEF_USE_SNICAR = .false. + DEF_Aerosol_Readin = .true. + DEF_Aerosol_Clim = .false. + ! ---------------- + + ! ---- Ozone MODULE ---- + DEF_USE_OZONESTRESS = .false. + DEF_USE_OZONEDATA = .false. + ! ---------------------- + + ! ---- Bedrock ---- + DEF_USE_BEDROCK = .false. + ! ----------------- + + ! ---- Split Soil Snow ---- + DEF_SPLIT_SOILSNOW = .false. + ! ------------------------- + + ! ---- Forcing Downscalling ---- + DEF_USE_Forcing_Downscaling = .false. + DEF_DS_precipitation_adjust_scheme = 'II' + DEF_DS_longwave_adjust_scheme = 'II' + ! ------------------------------ + + ! ----- forcing ----- + ! Options : + ! PRINCETON | GSWP3 | QIAN | CRUNCEPV4 | CRUNCEPV7 | ERA5LAND | ERA5 | MSWX + ! WFDE5 | CRUJRA | WFDEI | JRA55 | GDAS | CMFD | POINT + DEF_forcing_namelist = '/home/dongwz/github/CoLM-master/CoLM202X/run/forcing/CRUNCEPV7.nml' + + ! ----- history ----- + DEF_hist_lon_res = 0.5 + DEF_hist_lat_res = 0.5 + DEF_WRST_FREQ = 'MONTHLY' ! write restart file frequency: HOURLY/DAILY/MONTHLY/YEARLY + DEF_HIST_FREQ = 'MONTHLY' ! write history file frequency: HOURLY/DAILY/MONTHLY/YEARLY + DEF_HIST_groupby = 'MONTH' ! history in one file: DAY/MONTH/YEAR + DEF_HIST_mode = 'one' ! history in one or block + DEF_REST_COMPRESS_LEVEL = 1 + DEF_HIST_COMPRESS_LEVEL = 1 + + DEF_hist_vars_namelist = '/tera04/zhangsp/CoLM202X/github/CoLM202X/run/history.nml' + DEF_hist_vars_out_default = .true. + +/ diff --git a/run/GreaterBay_Grid_10km_IGBP_VG.nml b/run/GreaterBay_Grid_10km_IGBP_VG.nml new file mode 100644 index 00000000..5318edd5 --- /dev/null +++ b/run/GreaterBay_Grid_10km_IGBP_VG.nml @@ -0,0 +1,66 @@ +&nl_colm + +! Author: Shupeng Zhang +! Description : include soil state init from data. + + DEF_CASE_NAME = 'GreaterBay_Grid_10km_IGBP_VG' + + DEF_domain%edges = 20.0 + DEF_domain%edgen = 25.0 + DEF_domain%edgew = 109.0 + DEF_domain%edgee = 118.0 + + DEF_simulation_time%greenwich = .TRUE. + DEF_simulation_time%start_year = 2010 + DEF_simulation_time%start_month = 1 + DEF_simulation_time%start_day = 1 + DEF_simulation_time%start_sec = 0 + DEF_simulation_time%end_year = 2015 + DEF_simulation_time%end_month = 12 + DEF_simulation_time%end_day = 31 + DEF_simulation_time%end_sec = 86400 + DEF_simulation_time%spinup_year = 0 + DEF_simulation_time%spinup_month = 1 + DEF_simulation_time%spinup_day = 365 + DEF_simulation_time%spinup_sec = 86400 + DEF_simulation_time%spinup_repeat = 0 + + DEF_simulation_time%timestep = 1800. + + DEF_dir_rawdata = '/tera07/CoLMrawdata/' + DEF_dir_runtime = '/tera07/CoLMruntime/' + DEF_dir_output = '/tera05/zhangsp/cases' + + ! ----- land units and land sets ----- + ! for GRIDBASED + DEF_GRIDBASED_lon_res = 0.1 + DEF_GRIDBASED_lat_res = 0.1 + + ! soil state init + DEF_USE_SoilInit = .true. + DEF_file_SoilInit = '/tera05/zhangsp/data/soilstate/soilstate.nc' + + ! LAI setting + DEF_LAI_MONTHLY = .true. + DEF_LAI_CHANGE_YEARLY = .false. + + ! ----- forcing ----- + ! Options : + ! PRINCETON | GSWP3 | QIAN | CRUNCEPV4 | CRUNCEPV7 | ERA5LAND | ERA5 | MSWX + ! WFDE5 | CRUJRA | WFDEI | JRA55 | GDAS | CMFD | POINT + DEF_forcing_namelist = '/tera04/zhangsp/git/CoLM202X/run/forcing/ERA5LAND.nml' + + ! ----- history ----- + DEF_hist_grid_as_forcing = .true. + DEF_WRST_FREQ = 'YEARLY' ! write restart file frequency: HOURLY/DAILY/MONTHLY/YEARLY + DEF_HIST_FREQ = 'MONTHLY' ! write history file frequency: HOURLY/DAILY/MONTHLY/YEARLY + DEF_HIST_groupby = 'MONTH' ! history in one file: DAY/MONTH/YEAR + DEF_HIST_mode = 'one' ! history in one or block + DEF_REST_COMPRESS_LEVEL = 1 + DEF_HIST_COMPRESS_LEVEL = 1 + + DEF_HIST_WriteBack = .true. + + DEF_hist_vars_out_default = .true. + +/ diff --git a/run/NmlNameFormatReadme b/run/NmlNameFormatReadme new file mode 100644 index 00000000..7f3ab4a6 --- /dev/null +++ b/run/NmlNameFormatReadme @@ -0,0 +1,128 @@ +########################################################################################### + Rules to Name your nml file + + Your nml file should be named in following format: + + REGION{_STRUCTURE}{_RES}_LANDTYPE_SOILMODEL[_BGC][_URBAN][_LULCC].nml + + eg. Global_Grid_2x2_PFT_VG_BGC.nml + SiteCNDin_IGBP_CB.nml + + Please leave your name at begining of the namelist file, + eg. Author: Xingjie Lu +########################################################################################### + + Detailed description of each tag in the namelist format: + + Region (mandatory): + The abbrevation of the model simulation region. + Existing definitions of the model simulation regions includes: + + -------------------------------------------------------------------------------------- + Abbreviation Description Edges + -------------------------------------------------------------------------------------- + Global Global region: edges = -90.0; edgen = 90.0; + edgew = -180.0; edgee = 180.0 + RegChina China region: edges = 18.0; edgen = 54.0; + edgew = 73.0; edgee = 135.0 + RegPearl Pearl catchment region: edges = 21.0; edgen = 27.0; + edgew = 100.0; edgee = 115.0 + RegTibet Tibet Plateau region: edges = 25.0; edgen = 40.0; + edgew = 75.0; edgee = 105.0 + ... + SiteCNDin Dinghushan site: latitude = 23.17329979; + longitude = 112.5361023 + ... + -------------------------------------------------------------------------------------- + + STRUCTURE (conditional, only applicable for global and regional simulation, not for site) + The abbreviation of the model spatial structure. + Existing definitions of the model spatail structure includes: + + -------------------------------------------------------------------------------------- + Abbreviation Description + -------------------------------------------------------------------------------------- + Grid Latitude-longitude grid: grid cells are partitioned by latitudes + and longitudes with a constant interval. + Unstr Unstructure grid: grid cells are formed by polygons according to the + heteorogeneity of soil properties, vegetation types and ... + Catch Catchment grid: grid cells represent catchment units, + which is generated from the DEM data. + -------------------------------------------------------------------------------------- + + RES (conditional: only applicable when "STRUCTURE=Grid"): + The abbreviation of the grid resolution. + Existing definitions of grid resolution includes: + + --------------------------------------------------------------------------------------- + Abbreviation Description (longitude resolution x latitude resolution (in degree)) + --------------------------------------------------------------------------------------- + 2x2 2.5x1.875 + 1x1 1x1 + 50km 0.5x0.5 + 25km 0.25x0.25 + 10km 0.1x0.1 + --------------------------------------------------------------------------------------- + + LANDTYPE (mandatory): + The abbreviation of the land cover type classification, including the subgrid structure. + Existing definition of the land cover type classification includes: + + --------------------------------------------------------------------------------------- + Abbreviation Description Patch subgrid + --------------------------------------------------------------------------------------- + USGS USGS land cover patch No patch subgrid + IGBP IGBP land cover patch No patch subgrid + PFT IGBP land cover patch All soil patches within a grid cell has been + with plant functional aggregated and divided into multiple PFT + type subgrid subgrids + PC IGBP land cover patch Each IGBP patch has been divided into + with plant community multiple PFT subgrids + subgrid. + --------------------------------------------------------------------------------------- + + SOILMODEL (mandatory): + The abbreviation of soil hydraulics models. + Existing definition of the soil hydraulics models include: + + --------------------------------------------------------------------------------------- + Abbreviation Long name + --------------------------------------------------------------------------------------- + CB Campbell model + VG vanGenuchten Mualem model + --------------------------------------------------------------------------------------- + + BGC (optional, if not present, the namelist must indicate a bgc off simulation): + The abbreviation of biogeochemical model switches. + Existing definition of the biogeochemical model switches include: + + --------------------------------------------------------------------------------------- + Abbreviation Description + --------------------------------------------------------------------------------------- + (not present) BGC is turned off + BGC BGC is defined, but CROP is undef in define.h + BGCCROP Both BGC and CROP are defined in define.h + --------------------------------------------------------------------------------------- + + URBAN (optional, if not present, the namelist must correspond to a no urban simulation): + The abbreviation of urban model switches. + Existing definition of the urban model switches include: + + --------------------------------------------------------------------------------------- + Abbreviation Description + --------------------------------------------------------------------------------------- + (not present) The urban model is turned off + URBAN URBAN is defined, and the urban model is on + --------------------------------------------------------------------------------------- + + LULCC (optional, if not present, the namelist must correspond to a no land use change simulation): + The abbreviation of land use change model switches. + Existing definition of the land use change model switches include: + + --------------------------------------------------------------------------------------- + Abbreviation Description + --------------------------------------------------------------------------------------- + (not present) The land use change model is turned off + LULCC LULCC is defined, and the land use change model is on + --------------------------------------------------------------------------------------- + diff --git a/run/SinglePoint.nml b/run/SinglePoint.nml deleted file mode 100644 index da11d5de..00000000 --- a/run/SinglePoint.nml +++ /dev/null @@ -1,62 +0,0 @@ -&nl_colm - - DEF_CASE_NAME = 'CN_Dan' - - ! surface data from SITE. - SITE_fsrfdata = '/tera06/zhwei/CoLM_Forcing/PLUMBER2/Srfdata/CN-Dan_2004-2005_FLUXNET2015_Srf.nc' - ! path to surface database - DEF_dir_rawdata = '/tera07/CoLMrawdata/' - DEF_dir_runtime = '/tera07/CoLMruntime/' - - ! true : surface data from SITE - ! false : surface data is retrieved from database. - USE_SITE_pctpfts = .false. - USE_SITE_pctcrop = .false. - USE_SITE_htop = .false. - USE_SITE_LAI = .false. - USE_SITE_lakedepth = .false. - USE_SITE_soilreflectance = .false. - USE_SITE_soilparameters = .false. - USE_SITE_topography = .false. - - DEF_simulation_time%greenwich = .false. - DEF_simulation_time%start_year = 2004 - DEF_simulation_time%start_month = 1 - DEF_simulation_time%start_day = 1 - DEF_simulation_time%start_sec = 0 - DEF_simulation_time%end_year = 2005 - DEF_simulation_time%end_month = 12 - DEF_simulation_time%end_day = 31 - DEF_simulation_time%end_sec = 86400 - DEF_simulation_time%spinup_year = 2004 - DEF_simulation_time%spinup_month = 1 - DEF_simulation_time%spinup_day = 31 - DEF_simulation_time%spinup_sec = 86400 - DEF_simulation_time%spinup_repeat = 2 - - DEF_simulation_time%timestep = 1800. - - DEF_dir_output = '/tera06/zhangsp/cases/SinglePoint/' - - ! LAI setting - DEF_LAI_MONTHLY = .false. - - ! Canopy DEF Interception scheme selection - DEF_Interception_scheme = 1 ! 1:CoLM2014；2:CLM4.5; 3:CLM5; 4:Noah-MP; 5:MATSIRO; 6:VIC - - ! ----- forcing ----- - DEF_forcing_namelist = '/tera04/zhangsp/CoLM202X/github/CoLM202X/run/forcing/POINT.nml' - - ! ----- history ----- - DEF_hist_lon_res = 1. - DEF_hist_lat_res = 1. - DEF_WRST_FREQ = 'YEARLY' ! write restart file frequency: HOURLY/DAILY/MONTHLY/YEARLY - DEF_HIST_FREQ = 'DAILY' ! write history file frequency: HOURLY/DAILY/MONTHLY/YEARLY - DEF_HIST_groupby = 'YEAR' ! history in one file: DAY/MONTH/YEAR - DEF_REST_COMPRESS_LEVEL = 0 - DEF_HIST_COMPRESS_LEVEL = 0 - - DEF_hist_vars_namelist = '/tera04/zhangsp/CoLM202X/github/CoLM202X/run/history.nml' - DEF_hist_vars_turnon_all = .true. - -/ diff --git a/run/cama_flood.nml b/run/cama_flood.nml deleted file mode 100755 index 0d0056b9..00000000 --- a/run/cama_flood.nml +++ /dev/null @@ -1,111 +0,0 @@ -&NRUNVER -LADPSTP = .FALSE. ! true: use adaptive time step -LFPLAIN = .TRUE. ! true: consider floodplain (false: only river channel) -LKINE = .FALSE. ! true: use kinematic wave -LFLDOUT = .TRUE. ! true: floodplain flow (high-water channel flow) active -LPTHOUT = .TRUE. ! true: activate bifurcation scheme -LDAMOUT = .FALSE. ! true: activate dam operation (under development) -LLEVEE = .FALSE. ! true: activate levee scheme (under development) - - -LROSPLIT = .FALSE. ! true: input if surface (Qs) and sub-surface (Qsb) runoff -LWEVAP = .FALSE. ! true: input water evaporation to extract from floodplain -LWEVAPFIX = .FALSE. ! true: water balance closure extracting water from evap when available -LWINFILT = .FALSE. ! true: input water infiltration to extract from floodplain -LWINFILTFIX = .FALSE. ! true: water balance closure extracting water from Infiltration when available -LWEXTRACTRIV = .FALSE. ! true: also extract water from rivers -LSLOPEMOUTH = .FALSE. ! true: prescribe water level slope == elevation slope on river month - -LGDWDLY = .FALSE. ! true: Activate ground water reservoir and delay -LSLPMIX = .FALSE. ! true: activate mixed kinematic and local inertia based on slope - -LMEANSL = .FALSE. ! true: boundary condition for mean sea level -LSEALEV = .FALSE. ! true: boundary condition for variable sea level -!LOUTINS = .FALSE. ! true: diagnose instantaneous discharge - -LRESTART = .FALSE. ! true: initial condition from restart file -LSTOONLY = .FALSE. ! true: storage only restart (mainly for data assimilation) -LOUTPUT = .TRUE. ! true: use standard output (to file) -LOUTINI = .FALSE. ! true: output initial storage (netCDF only) - -LGRIDMAP = .TRUE. ! true: for standard XY gridded 2D map -LLEAPYR = .TRUE. ! true: neglect leap year (Feb29 skipped) - -LMAPEND = .FALSE. ! true: for map data endian conversion -LSTG_ES = .FALSE. ! true: for Vector Processor optimization (CMF_OPT_FLDSTG_ES) -/ -&NDIMTIME -CDIMINFO = "../CaMa/map/CaMaMap4CoLM_glb_0.25in_0.25out/CRU-diminfo.txt" ! text file for dimention information -DT = 21600 ! time step length (sec) -IFRQ_INP = 6 ! input forcing update frequency (hour) -/ -&NPARAM -PMANRIV = 0.03D0 ! manning coefficient river -PMANFLD = 0.10D0 ! manning coefficient floodplain -PGRV = 9.8D0 ! gravity accerelation -PDSTMTH = 10000.D0 ! downstream distance at river mouth [m] -PCADP = 0.7 ! CFL coefficient -PMINSLP = 1.D-5 ! minimum slope (kinematic wave) -IMIS = -9999 ! missing value for integer -RMIS = 1.E36 ! missing value for real*4 -DMIS = 1.E36 ! missing value for real*8 -CSUFBIN = '.bin' ! file suffix for plain binary 2D map -CSUFVEC = '.vec' ! file suffix for plain binary 1D vector -CSUFPTH = '.pth' ! file suffix for plain binary bifurcation channel -CSUFCDF = '.nc' ! file suffix for netCDF -/ -&NSIMTIME -SYEAR = 1900 ! start year : will not gonna used in here -SMON = 01 ! month : will not gonna used in here -SDAY = 01 ! day : will not gonna used in here -SHOUR = 00 ! hour : will not gonna used in here -EYEAR = 2020 ! end year : will not gonna used in here -EMON = 01 ! month : will not gonna used in here -EDAY = 01 ! day : will not gonna used in here -EHOUR = 00 ! hour : will not gonna used in here -/ -&NMAP -LMAPCDF = .FALSE. ! * true for netCDF map input -CNEXTXY = "../CaMa/map/CaMaMap4CoLM_glb_0.25in_0.25out/nextxy.bin" ! river network nextxy -CGRAREA = "../CaMa/map/CaMaMap4CoLM_glb_0.25in_0.25out/ctmare.bin" ! catchment area -CELEVTN = "../CaMa/map/CaMaMap4CoLM_glb_0.25in_0.25out/elevtn.bin" ! bank top elevation -CNXTDST = "../CaMa/map/CaMaMap4CoLM_glb_0.25in_0.25out/nxtdst.bin" ! distance to next outlet -CRIVLEN = "../CaMa/map/CaMaMap4CoLM_glb_0.25in_0.25out/rivlen.bin" ! river channel length -CFLDHGT = "../CaMa/map/CaMaMap4CoLM_glb_0.25in_0.25out/fldhgt.bin" ! floodplain elevation profile -CRIVWTH = "../CaMa/map/CaMaMap4CoLM_glb_0.25in_0.25out/rivwth_gwdlr.bin" ! channel width -CRIVHGT = "../CaMa/map/CaMaMap4CoLM_glb_0.25in_0.25out/rivhgt.bin" ! channel depth -CRIVMAN = "../CaMa/map/CaMaMap4CoLM_glb_0.25in_0.25out/rivman.bin" ! river manning coefficient -CPTHOUT = "../CaMa/map/CaMaMap4CoLM_glb_0.25in_0.25out/bifprm.txt" ! bifurcation channel table -CGDWDLY = "" ! Groundwater Delay Parameter -CMEANSL = "" ! mean sea level -CRIVCLINC = "" ! * river map netcdf -CRIVPARNC = "" ! * river parameter netcdf (width, height, manning, ground water delay) -CMEANSLNC = "" ! * mean sea level netCDF -!CMPIREG = "../CaMa/map/CaMaMap4CoLM_glb_0.25in_0.25out/mpireg-2.bin" -/ -&NRESTART -CRESTSTO = "" ! restart file -CRESTDIR = "./" ! restart directory -CVNREST = "restart" ! restart variable name -LRESTCDF = .FALSE. ! * true for netCDF restart file -IFRQ_RST = 0 ! restart write frequency (1-24: hour, 0:end of run) -/ -&NFORCE -LINTERP = .FALSE. ! true for runoff interpolation using input matrix -LINPEND = .TRUE. ! true for runoff endian conversion -LITRPCDF = .FALSE. ! * true for netCDF input matrix -CINPMAT = "../CaMa/map/CaMaMap4CoLM_glb_0.25in_0.25out/CRU-inpmat.bin" ! input matrix file name -DROFUNIT = 1.0 ! runoff unit conversion - -/ -&NOUTPUT -COUTDIR = "../../cases/" ! OUTPUT DIRECTORY -!CVARSOUT="wevap,winfilt,rivout,rivsto,rivdph,rivvel,fldout,fldsto,flddph,fldfrc,fldare,sfcelv,outflw,storge,pthflw,pthout,maxsto,maxflw,maxdph" # list output variable (comma separated) -CVARSOUT = "wevap,winfilt,outflw,fldout,flddph,fldfrc,fldare,runoff" ! Comma-separated list of output variables to save -COUTTAG = "test" ! Output Tag Name for each experiment -LOUTVEC = .FALSE ! TRUE FOR VECTORIAL OUTPUT, FALSE FOR NX,NY OUTPUT -LOUTCDF = .TRUE. ! * true for netcdf outptu false for binary -NDLEVEL = 1 ! * NETCDF DEFLATION LEVEL -IFRQ_OUT = 1 ! output data write frequency (hour) -/ - diff --git a/run/catchment_pearl_era5_pft.nml b/run/catchment_pearl_era5_pft.nml deleted file mode 100644 index 5ee23600..00000000 --- a/run/catchment_pearl_era5_pft.nml +++ /dev/null @@ -1,65 +0,0 @@ -&nl_colm - - DEF_CASE_NAME = 'catchment_pearl' - - DEF_domain%edges = 21.0 - DEF_domain%edgen = 27.0 - DEF_domain%edgew = 100.0 - DEF_domain%edgee = 115.0 - - DEF_nx_blocks = 30 - DEF_ny_blocks = 30 - DEF_PIO_groupsize = 6 - - DEF_simulation_time%greenwich = .TRUE. - DEF_simulation_time%start_year = 2000 - DEF_simulation_time%start_month = 1 - DEF_simulation_time%start_day = 1 - DEF_simulation_time%start_sec = 0 - DEF_simulation_time%end_year = 2003 - DEF_simulation_time%end_month = 12 - DEF_simulation_time%end_day = 31 - DEF_simulation_time%end_sec = 86400 - DEF_simulation_time%spinup_year = 2000 - DEF_simulation_time%spinup_month = 12 - DEF_simulation_time%spinup_day = 31 - DEF_simulation_time%spinup_sec = 86400 - DEF_simulation_time%timestep = 1800. - - DEF_simulation_time%spinup_repeat = 2 - - DEF_dir_rawdata = '/tera05/zhangsp/data/CLMrawdata_hydro/' - DEF_dir_output = '/tera05/zhangsp/cases' - - ! for CATCHMENT - Catchment_data_in_ONE_file = .true. - DEF_path_catchment_data = '/tera04/zhangsp/hillslope/output/pearl.nc' - - ! LAI setting - DEF_LAI_MONTHLY = .true. - - ! Model settings - DEF_LANDONLY = .true. - DEF_USE_DOMINANT_PATCHTYPE = .false. - DEF_USE_VARIABLY_SATURATED_FLOW = .true. - - ! Canopy DEF Interception scheme selection - DEF_Interception_scheme=1 !1:CoLM2014；2:CLM4.5; 3:CLM5; 4:Noah-MP; 5:MATSIRO; 6:VIC - - ! ----- forcing ----- - DEF_forcing_namelist = '/tera05/zhangsp/data/forcing/ERA5.nml' - - ! ----- history ----- - DEF_HISTORY_IN_VECTOR = .true. - - DEF_WRST_FREQ = 'MONTHLY' ! write restart file frequency: HOURLY/DAILY/MONTHLY/YEARLY - DEF_HIST_FREQ = 'DAILY' ! write history file frequency: HOURLY/DAILY/MONTHLY/YEARLY - DEF_HIST_groupby = 'MONTH' ! history in one file: DAY/MONTH/YEAR - - DEF_REST_COMPRESS_LEVEL = 1 - DEF_HIST_COMPRESS_LEVEL = 1 - - DEF_hist_vars_turnon_all = .true. - DEF_hist_vars_namelist = '/tera04/zhangsp/CoLM202X/current/run/history.nml' - -/ diff --git a/run/create_clone b/run/create_clone new file mode 100755 index 00000000..b5a2f377 --- /dev/null +++ b/run/create_clone @@ -0,0 +1,59 @@ +#!/bin/bash + +#---------------------------------------------------------- + +# usage: ./create_clone $SourcePath/$SourceName $DestPath/DestName +# no "/" at end of both paths. + +#---------------------------------------------------------- +if [ $# -ne 2 ];then + echo "error: argument number. 2 arguments are expected. $# arguments were used" + exit +else + if [ "${1:0:1}" == '/' ];then + SourceName=`echo "${1##*/}"` + SourcePath=`echo "${1%/*}"` + echo $SourceName + echo $SourcePath + else + TMPPATHNAME=$PWD/$1 + SourceName=`echo "${TMPPATHNAME##*/}"` + SourcePath=`echo "${TMPPATHNAME%/*}"` + echo $SourcePath + echo $SourceName + fi + if [ "${2:0:1}" == '/' ];then + DestName=`echo "${2##*/}"` + DestPath=`echo "${2%/*}"` + echo $DestName + echo $DestPath + else + TMPPATHNAME=$PWD/$2 + DestName=`echo "${TMPPATHNAME##*/}"` + DestPath=`echo "${TMPPATHNAME%/*}"` + echo $DestPath + echo $DestName + fi +fi + +mkdir -p $DestPath/$DestName +cd $DestPath/$DestName +mkdir -p history +mkdir -p restart +ln -sf $SourcePath/$SourceName/landdata ./ +echo copy scripts and namelist +cp -p $SourcePath/$SourceName/mksrf.submit ./ +sed -i "s/$SourceName/$DestName/g" ./mksrf.submit +cp -p $SourcePath/$SourceName/init.submit ./ +sed -i "s/$SourceName/$DestName/g" ./init.submit +cp -p $SourcePath/$SourceName/case.submit ./ +sed -i "s/$SourceName/$DestName/g" ./case.submit +cp -p $SourcePath/$SourceName/input_$SourceName.nml ./input_$DestName.nml +sed -i "s/$SourceName/$DestName/g" ./input_$DestName.nml + +echo copy source files +cp -pr $SourcePath/$SourceName/bld $DestPath/$DestName/ +echo copy restart files +cp -pr $SourcePath/$SourceName/restart/$SourceName*nc $DestPath/$DestName/restart/ +cd $DestPath/$DestName/restart/ +rename $SourceName $DestName *nc diff --git a/run/create_newcase b/run/create_newcase new file mode 100755 index 00000000..c36cebba --- /dev/null +++ b/run/create_newcase @@ -0,0 +1,297 @@ +#!/bin/bash +#./create_newcase CASENAME + +#-------------------------------------------------------------------------------------- +# Assign following path before running the scripts + +#machine = earthlab +#ROOT=/public/home/sysu_daiyj_01/data/luxj/CoLM202X-GPAM/ +#RAWDATA=/data/sysu_daiyj_01/data_mpi/CLMrawdata_igbp/ +#RUNTIME=/data/sysu_daiyj_01/data_mpi/CoLMruntime/ +#MAKEOPTION=$ROOT/include/Makeoptions +#FORCINGNML=$ROOT/run/forcing/GSWP3.nml + +#machine = land +ROOT=/home/luxj/CoLM202X/ +RAWDATA=/tera07/CoLMrawdata/ +RUNTIME=/tera07/CoLMruntime/ +MAKEOPTION=$ROOT/include/Makeoption +FORCINGNML=$ROOT/run/forcing/GSWP3.nml + +#-------------------------------------------------------------------------------------- + +#usage: ./create_newcase $CASEPATH/CASENAME + +#------------------------------------------------------------------------------------- + +if [ $# -ne 1 ];then + echo 'error: argument number. 1 argument is expected, $# arguments were given' + exit +else + if [ "${1:0:1}" == '/' ];then + CASENAME=`echo "${1##*/}"` + CASEPATH=`echo "${1%/*}"` + echo $CASEPATH + echo $CASENAME + else + CASEPATHNAME=$PWD/$1 + CASENAME=`echo "${CASEPATHNAME##*/}"` + CASEPATH=`echo "${CASEPATHNAME%/*}"` + echo $CASEPATH + echo $CASENAME + fi +fi +mkdir -p $CASEPATH/$CASENAME + +cd $CASEPATH/$CASENAME +mkdir -p history +mkdir -p restart +mkdir -p landdata +cat>input_${CASENAME}.nml<history.nml<mksrf.submit< ../../logmksrfdata +EOF + +cat>init.submit< ../../logini +EOF + +cat>'case.submit'< ../../log + +EOF + +cd ${CASEPATH}/$CASENAME/ +mkdir -p bld +cp -pr $ROOT/CaMa bld/ +mkdir -p bld/CaMa/map +ln -sf $RAWDATA/CaMaMap4CoLM_glb_0.25in_0.25out ${CASEPATH}/$CASENAME/bld/CaMa/map/CaMaMap4CoLM_glb_0.25in_0.25out +cp -pr $ROOT/main bld/ +cp -pr $ROOT/include bld/ +cp -pr $ROOT/mksrfdata bld/ +cp -pr $ROOT/mkinidata bld/ +cp -pr $ROOT/postprocess bld/ +cp -pr $ROOT/preprocess bld/ +cp -pr $ROOT/share bld/ +cp -p $ROOT/Makefile bld/ +ln -sf $MAKEOPTION bld/include/Makeoptions +cp -pr $ROOT/run/ bld/ diff --git a/run/forcing/CLDAS.nml b/run/forcing/CLDAS.nml index 73a749f9..cff11f19 100644 --- a/run/forcing/CLDAS.nml +++ b/run/forcing/CLDAS.nml @@ -11,6 +11,8 @@ DEF_forcing%regional = .true. DEF_forcing%regbnd = 0.0 65.0 60.0 160.0 + DEF_forcing%has_missing_value = .true. + DEF_forcing%missing_value_name = 'missing_value' DEF_forcing%NVAR = 8 ! variable number of forcing data DEF_forcing%startyr = 2008 ! start year of forcing data diff --git a/run/forcing/CMFD.nml b/run/forcing/CMFD.nml index 78314cc5..f15614fb 100644 --- a/run/forcing/CMFD.nml +++ b/run/forcing/CMFD.nml @@ -12,6 +12,8 @@ DEF_forcing%regional = .true. DEF_forcing%regbnd = 15.0 55.0 70.0 140.0 DEF_forcing%has_missing_value = .true. + DEF_forcing%missing_value_name= 'missing_value' + DEF_forcing%NVAR = 8 ! variable number of forcing data DEF_forcing%startyr = 1979 ! start year of forcing data diff --git a/run/forcing/CRUJRA.nml b/run/forcing/CRUJRA.nml index d160f861..383da390 100644 --- a/run/forcing/CRUJRA.nml +++ b/run/forcing/CRUJRA.nml @@ -8,6 +8,9 @@ DEF_forcing%HEIGHT_V = 50.0 DEF_forcing%HEIGHT_T = 40. DEF_forcing%HEIGHT_Q = 40. + + DEF_forcing%has_missing_value = .true. + DEF_forcing%missing_value_name = 'missing_value' DEF_forcing%NVAR = 8 ! variable number of forcing data DEF_forcing%startyr = 1901 ! start year of forcing data @@ -28,14 +31,14 @@ DEF_forcing%groupby = 'year' ! file grouped by year/month - DEF_forcing%fprefix(1) = 'tmp/crujra.v2.3.5d.tmp.' - DEF_forcing%fprefix(2) = 'spfh/crujra.v2.3.5d.spfh.' - DEF_forcing%fprefix(3) = 'pres/crujra.v2.3.5d.pres.' - DEF_forcing%fprefix(4) = 'pre/crujra.v2.3.5d.pre.' - DEF_forcing%fprefix(5) = 'ugrd/crujra.v2.3.5d.ugrd.' - DEF_forcing%fprefix(6) = 'vgrd/crujra.v2.3.5d.vgrd.' - DEF_forcing%fprefix(7) = 'dswrf/crujra.v2.3.5d.dswrf.' - DEF_forcing%fprefix(8) = 'dlwrf/crujra.v2.3.5d.dlwrf.' + DEF_forcing%fprefix(1) = 'tmp/crujra.v2.4.5d.tmp.' + DEF_forcing%fprefix(2) = 'spfh/crujra.v2.4.5d.spfh.' + DEF_forcing%fprefix(3) = 'pres/crujra.v2.4.5d.pres.' + DEF_forcing%fprefix(4) = 'pre/crujra.v2.4.5d.pre.' + DEF_forcing%fprefix(5) = 'ugrd/crujra.v2.4.5d.ugrd.' + DEF_forcing%fprefix(6) = 'vgrd/crujra.v2.4.5d.vgrd.' + DEF_forcing%fprefix(7) = 'dswrf/crujra.v2.4.5d.dswrf.' + DEF_forcing%fprefix(8) = 'dlwrf/crujra.v2.4.5d.dlwrf.' DEF_forcing%vname = 'tmp' 'spfh' 'pres' 'pre' 'ugrd' 'vgrd' 'dswrf' 'dlwrf' diff --git a/run/forcing/ERA5LAND.nml b/run/forcing/ERA5LAND.nml index 5511eec6..edb1bd6e 100644 --- a/run/forcing/ERA5LAND.nml +++ b/run/forcing/ERA5LAND.nml @@ -10,7 +10,8 @@ DEF_forcing%HEIGHT_Q = 40. DEF_forcing%has_missing_value = .true. - + DEF_forcing%missing_value_name = 'missing_value' + DEF_forcing%NVAR = 8 ! variable number of forcing data DEF_forcing%startyr = 1950 ! start year of forcing data DEF_forcing%startmo = 1 ! start month of forcing data diff --git a/run/forcing/GDAS.nml b/run/forcing/GDAS.nml index 967778a5..088a8896 100644 --- a/run/forcing/GDAS.nml +++ b/run/forcing/GDAS.nml @@ -11,6 +11,11 @@ DEF_forcing%regional = .true. DEF_forcing%regbnd = -60.0 90.0 -180.0 180.0 + + DEF_forcing%has_missing_value = .true. + missing_value_name = 'missing_value' + + DEF_forcing%NVAR = 8 ! variable number of forcing data DEF_forcing%startyr = 2002 ! start year of forcing data diff --git a/run/forcing/JRA55.nml b/run/forcing/JRA55.nml index 5a199217..6bd93d62 100644 --- a/run/forcing/JRA55.nml +++ b/run/forcing/JRA55.nml @@ -1,7 +1,7 @@ &nl_colm_forcing ! ----- forcing ----- - DEF_dir_forcing ='/tera06/zhwei/CoLM_Forcing/JRA55/' + DEF_dir_forcing ='/share/home/dq013/zhwei/colm/data/CoLM_Forcing/JRA55/' DEF_forcing%dataset = 'JRA55' DEF_forcing%solarin_all_band = .true. @@ -38,7 +38,18 @@ DEF_forcing%fprefix(8) = 'dlwrf/dlwrf' - DEF_forcing%vname = 'var11' 'var51' 'var1' 'var61' 'var33' 'var34' 'var204' 'var205' + DEF_forcing%fprefix(1) = 't2m_r/tmp' + DEF_forcing%fprefix(2) = 'spfh/spfh' + DEF_forcing%fprefix(3) = 'pres/pres' + DEF_forcing%fprefix(4) = 'tprat/tprat' + DEF_forcing%fprefix(5) = 'ugrd/ugrd' + DEF_forcing%fprefix(6) = 'vgrd/vgrd' + DEF_forcing%fprefix(7) = 'dswrf/dswrf' + DEF_forcing%fprefix(8) = 'dlwrf/dlwrf' + + + DEF_forcing%vname = 'var11' 'SPFH_GDS4_HTGL' 'PRES_GDS4_SFC_ave3h' 'TPRAT_GDS4_SFC_ave3h' 'UGRD_GDS4_HTGL' 'VGRD_GDS4_HTGL' 'DSWRF_GDS4_SFC_ave3h' 'DLWRF_GDS4_SFC_ave3h' DEF_forcing%tintalgo = 'linear' 'linear' 'linear' 'nearest' 'NULL' 'linear' 'coszen' 'linear' + / diff --git a/run/forcing/MSWX.nml b/run/forcing/MSWX.nml index 6e27ccab..e2e8cac7 100644 --- a/run/forcing/MSWX.nml +++ b/run/forcing/MSWX.nml @@ -6,8 +6,8 @@ DEF_forcing%dataset = 'MSWX' DEF_forcing%solarin_all_band = .true. DEF_forcing%HEIGHT_V = 50.0 - DEF_forcing%HEIGHT_T = 30. - DEF_forcing%HEIGHT_Q = 30. + DEF_forcing%HEIGHT_T = 40. + DEF_forcing%HEIGHT_Q = 40. DEF_forcing%NVAR = 8 ! variable number of forcing data DEF_forcing%startyr = 1979 ! start year of forcing data diff --git a/run/forcing/TPMFD.nml b/run/forcing/TPMFD.nml index e4188315..54c6e19b 100644 --- a/run/forcing/TPMFD.nml +++ b/run/forcing/TPMFD.nml @@ -8,7 +8,12 @@ DEF_forcing%HEIGHT_V = 50.0 DEF_forcing%HEIGHT_T = 40.0 DEF_forcing%HEIGHT_Q = 40.0 - + + DEF_forcing%regional = .true. + DEF_forcing%regbnd = 25.4166 41.3818 61.0 105.678 + DEF_forcing%has_missing_value = .true. + DEF_forcing%missing_value_name= 'missing_value' + DEF_forcing%NVAR = 8 ! variable number of forcing data DEF_forcing%startyr = 1979 ! start year of forcing data DEF_forcing%startmo = 1 ! start month of forcing data diff --git a/run/forcing/WFDE5.nml b/run/forcing/WFDE5.nml index 5dba321d..ffad969b 100644 --- a/run/forcing/WFDE5.nml +++ b/run/forcing/WFDE5.nml @@ -6,8 +6,11 @@ DEF_forcing%dataset = 'WFDE5' DEF_forcing%solarin_all_band = .true. DEF_forcing%HEIGHT_V = 50.0 - DEF_forcing%HEIGHT_T = 30. - DEF_forcing%HEIGHT_Q = 30. + DEF_forcing%HEIGHT_T = 40. + DEF_forcing%HEIGHT_Q = 40. + + DEF_forcing%has_missing_value = .true. + DEF_forcing%missing_value_name = '_FillValue' DEF_forcing%NVAR = 8 ! variable number of forcing data DEF_forcing%startyr = 1979 ! start year of forcing data diff --git a/run/forcing/WFDEI.nml b/run/forcing/WFDEI.nml index 42bb196a..c0fa1d68 100644 --- a/run/forcing/WFDEI.nml +++ b/run/forcing/WFDEI.nml @@ -6,8 +6,12 @@ DEF_forcing%dataset = 'WFDEI' DEF_forcing%solarin_all_band = .true. DEF_forcing%HEIGHT_V = 50.0 - DEF_forcing%HEIGHT_T = 30. - DEF_forcing%HEIGHT_Q = 30. + DEF_forcing%HEIGHT_T = 40. + DEF_forcing%HEIGHT_Q = 40. + + DEF_forcing%has_missing_value = .true. + DEF_forcing%missing_value_name = '_FillValue' + DEF_forcing%NVAR = 8 ! variable number of forcing data DEF_forcing%startyr = 1979 ! start year of forcing data diff --git a/run/gridbased_CMIP6_IGBP_2017_2099_CHINA.nml b/run/gridbased_CMIP6_IGBP_2017_2099_CHINA.nml deleted file mode 100644 index d1aec6c1..00000000 --- a/run/gridbased_CMIP6_IGBP_2017_2099_CHINA.nml +++ /dev/null @@ -1,70 +0,0 @@ -&nl_colm - - DEF_CASE_NAME = 'gridbased_CMIP6_BGC_CHINA_CO2' - DEF_domain%edges = 10 - DEF_domain%edgen = 60 - DEF_domain%edgew = 70.0 - DEF_domain%edgee = 140.0 - - DEF_nx_blocks = 36 - DEF_ny_blocks = 36 - DEF_PIO_groupsize = 6 - - DEF_simulation_time%greenwich = .TRUE. - DEF_simulation_time%start_year = 1934 - DEF_simulation_time%start_month = 12 - DEF_simulation_time%start_day = 31 - DEF_simulation_time%start_sec = 86400 - DEF_simulation_time%end_year = 2099 - DEF_simulation_time%end_month = 12 - DEF_simulation_time%end_day = 31 - DEF_simulation_time%end_sec = 86400 - DEF_simulation_time%spinup_year = 2019 - DEF_simulation_time%spinup_month = 12 - DEF_simulation_time%spinup_day = 31 - DEF_simulation_time%spinup_sec = 86400 - DEF_simulation_time%spinup_repeat = 3 - - DEF_simulation_time%timestep = 3600. - - DEF_dir_rawdata = '/share/home/dq010/CoLM/data/rawdata/CROP-NITRIF/CLMrawdata_igbp/' - DEF_dir_output = '/share/home/dq013/zhwei/colm/output/' - - ! ----- land units and land sets ----- - ! for GRIDBASED - DEF_file_mesh = '/share/home/dq013/zhwei/colm/data/landdata/landmask_igbp_25km.nc' - - ! LAI setting - DEF_LAI_MONTHLY = .true. - - ! Model settings - DEF_LANDONLY = .true. - DEF_USE_DOMINANT_PATCHTYPE = .false. - DEF_USE_VARIABLY_SATURATED_FLOW = .false. - ! option to use different CO2 path data if CMIP6 is used. - DEF_SSP='585' !126,245,370,585 are available - ! Canopy DEF Interception scheme selection - DEF_Interception_scheme=1 !1:CoLM2014；2:CLM4.5; 3:CLM5; 4:Noah-MP; 5:MATSIRO; 6:VIC - - ! ----- forcing ----- - ! Options : - ! PRINCETON | GSWP3 | QIAN | CRUNCEPV4 | CRUNCEPV7 | ERA5LAND | ERA5 | MSWX - ! WFDE5 | CRUJRA | WFDEI | JRA55 | GDAS | CMFD | POINT - ! CLDAS - DEF_forcing_namelist = '/share/home/dq013/zhwei/colm/CoLM202X_20230130/run/forcing/MPI-ESM1-2-HR_ssp585.nml' - - ! ----- history ----- - DEF_hist_grid_as_forcing = .false. - DEF_hist_lon_res = 0.25 - DEF_hist_lat_res = 0.25 - DEF_WRST_FREQ = 'YEARLY' ! write restart file frequency: HOURLY/DAILY/MONTHLY/YEARLY - DEF_HIST_FREQ = 'DAILY' ! write history file frequency: HOURLY/DAILY/MONTHLY/YEARLY - DEF_HIST_groupby = 'MONTH' ! history in one file: DAY/MONTH/YEAR - DEF_HIST_mode = 'one' ! history in one or block - - DEF_REST_COMPRESS_LEVEL = 1 - DEF_HIST_COMPRESS_LEVEL = 1 - - DEF_hist_vars_namelist = './history.nml' - DEF_hist_vars_turnon_all = .true. - / diff --git a/run/gridbased_IGBP-U.nml b/run/gridbased_IGBP-U.nml deleted file mode 100644 index 213b7f10..00000000 --- a/run/gridbased_IGBP-U.nml +++ /dev/null @@ -1,82 +0,0 @@ -&nl_colm - - DEF_CASE_NAME = 'gridbased_IGBP-U' - - DEF_domain%edges = 20.0 - DEF_domain%edgen = 25.0 - DEF_domain%edgew = 110.0 - DEF_domain%edgee = 115.0 - - DEF_nx_blocks = 30 - DEF_ny_blocks = 30 - DEF_PIO_groupsize = 6 - - DEF_simulation_time%greenwich = .TRUE. - DEF_simulation_time%start_year = 2000 - DEF_simulation_time%start_month = 12 - DEF_simulation_time%start_day = 31 - DEF_simulation_time%start_sec = 84600 - DEF_simulation_time%end_year = 2020 - DEF_simulation_time%end_month = 1 - DEF_simulation_time%end_day = 1 - DEF_simulation_time%end_sec = 0 - DEF_simulation_time%spinup_year = 2002 - DEF_simulation_time%spinup_month = 1 - DEF_simulation_time%spinup_day = 31 - DEF_simulation_time%spinup_sec = 86400 - DEF_simulation_time%spinup_repeat = 2 - - DEF_simulation_time%timestep = 1800. - - DEF_dir_rawdata = '/stu01/dongwz/data/CLMrawdata/' - DEF_dir_output = '/stu01/dongwz/cases' - - ! ----- land units and land sets ----- - ! for GRIDBASED - DEF_file_mesh = '/tera05/zhangsp/data/landdata/mask/landmask_igbp_50km.nc' - - ! LAI CHANGE - DEF_LAI_CHANGE_YEARLY = .false. - DEF_LC_YEAR = 2005 - - !---- Urban type options ---- - ! Options : - ! 1: NCAR Urban Classification, 3 urban type with Tall Building, High Density and Medium Density - ! 2: LCZ Classification, 10 urban type with LCZ 1-10 - !DEF_URBAN_type_scheme = 1 - - ! Urban options - DEF_URBAN_TREE = .true. - DEF_URBAN_WATER= .false. - DEF_URBAN_BEM = .false. - DEF_URBAN_LUCY = .false. - - ! LAI setting - DEF_LAI_MONTHLY = .true. - - ! Canopy DEF Interception scheme selection - DEF_Interception_scheme=1 !1:CoLM2014；2:CLM4.5; 3:CLM5; 4:Noah-MP; 5:MATSIRO; 6:VIC - - ! ----- forcing ----- - ! Options : - ! PRINCETON | GSWP3 | QIAN | CRUNCEPV4 | CRUNCEPV7 | ERA5LAND | ERA5 | MSWX - ! WFDE5 | CRUJRA | WFDEI | JRA55 | GDAS | CMFD | POINT - ! CLDAS - DEF_forcing_namelist = '/home/dongwz/github/urban/sunan/CoLM202X/run/forcing/CRUNCEPV7.nml' - - ! ----- history ----- - DEF_hist_grid_as_forcing = .true. - DEF_hist_lon_res = 0.5 - DEF_hist_lat_res = 0.5 - DEF_WRST_FREQ = 'DAILY' ! write restart file frequency: HOURLY/DAILY/MONTHLY/YEARLY - DEF_HIST_FREQ = 'DAILY' ! write history file frequency: HOURLY/DAILY/MONTHLY/YEARLY - DEF_HIST_groupby = 'DAY' ! history in one file: DAY/MONTH/YEAR - DEF_HIST_mode = 'one' ! history in one or block - - DEF_REST_COMPRESS_LEVEL = 1 - DEF_HIST_COMPRESS_LEVEL = 1 - - DEF_hist_vars_namelist = '/tera04/zhangsp/CoLM202X/github/CoLM202X/run/history.nml' - DEF_hist_vars_turnon_all = .true. - -/ diff --git a/run/gridbased_era5_IGBP_CHINA.nml b/run/gridbased_era5_IGBP_CHINA.nml deleted file mode 100755 index 45bcc80b..00000000 --- a/run/gridbased_era5_IGBP_CHINA.nml +++ /dev/null @@ -1,72 +0,0 @@ -&nl_colm - - DEF_CASE_NAME = 'gridbased_era5_IGBP_CHINA' - DEF_domain%edges = 10.0 - DEF_domain%edgen = 60.0 - DEF_domain%edgew = 70.0 - DEF_domain%edgee = 140.0 - - DEF_nx_blocks = 36 - DEF_ny_blocks = 36 - DEF_PIO_groupsize = 9 - - DEF_simulation_time%greenwich = .TRUE. - DEF_simulation_time%start_year = 2001 - DEF_simulation_time%start_month = 1 - DEF_simulation_time%start_day = 1 - DEF_simulation_time%start_sec = 0 - DEF_simulation_time%end_year = 2003 - DEF_simulation_time%end_month = 12 - DEF_simulation_time%end_day = 31 - DEF_simulation_time%end_sec = 86400 - DEF_simulation_time%spinup_year = 2001 - DEF_simulation_time%spinup_month = 12 - DEF_simulation_time%spinup_day = 31 - DEF_simulation_time%spinup_sec = 86400 - DEF_simulation_time%spinup_repeat = 0 - - DEF_simulation_time%timestep = 3600. - - DEF_dir_rawdata = '/tera07/CLMrawdata/' - DEF_dir_output = '/tera05/liusf/cases_debuged-0515' - - ! ----- land units and land sets ----- - ! for GRIDBASED - DEF_file_mesh = '/tera05/zhangsp/data/landdata/mask/landmask_igbp_25km.nc' - - ! LAI setting - DEF_LAI_MONTHLY = .true. - - ! whether use CBL height (hpbl) and turn on the large-eddy turbulence scheme (LZD2022) - DEF_USE_CBL_HEIGHT = .false. - - ! Model settings - DEF_LANDONLY = .true. - DEF_USE_DOMINANT_PATCHTYPE = .false. - DEF_USE_VARIABLY_SATURATED_FLOW = .true. - - ! Canopy DEF Interception scheme selection - DEF_Interception_scheme=1 !1:CoLM2014；2:CLM4.5; 3:CLM5; 4:Noah-MP; 5:MATSIRO; 6:VIC - - ! ----- forcing ----- - ! Options : - ! PRINCETON | GSWP3 | QIAN | CRUNCEPV4 | CRUNCEPV7 | ERA5LAND | ERA5 | MSWX - ! WFDE5 | CRUJRA | WFDEI | JRA55 | GDAS | CMFD | POINT - ! CLDAS - DEF_forcing_namelist = '/tera04/liusf/CoLM202X_dev-leddy_20230511_debuged-0515/run/forcing/ERA5_LEddy.nml' - - ! ----- history ----- - DEF_hist_grid_as_forcing = .false. - DEF_hist_lon_res = 0.25 - DEF_hist_lat_res = 0.25 - DEF_WRST_FREQ = 'YEARLY' ! write restart file frequency: HOURLY/DAILY/MONTHLY/YEARLY - DEF_HIST_FREQ = 'DAILY' ! write history file frequency: HOURLY/DAILY/MONTHLY/YEARLY - DEF_HIST_groupby = 'MONTH' ! history in one file: DAY/MONTH/YEAR - DEF_HIST_mode = 'one' ! history in one or block - - DEF_REST_COMPRESS_LEVEL = 1 - DEF_HIST_COMPRESS_LEVEL = 1 - - DEF_hist_vars_namelist = './history.nml' - DEF_hist_vars_turnon_all = .true. - / diff --git a/run/gridbased_era5_IGBP_LEddy_CHINA.nml b/run/gridbased_era5_IGBP_LEddy_CHINA.nml deleted file mode 100755 index d15c8125..00000000 --- a/run/gridbased_era5_IGBP_LEddy_CHINA.nml +++ /dev/null @@ -1,72 +0,0 @@ -&nl_colm - - DEF_CASE_NAME = 'gridbased_era5_IGBP_LEddy_CHINA' - DEF_domain%edges = 10.0 - DEF_domain%edgen = 60.0 - DEF_domain%edgew = 70.0 - DEF_domain%edgee = 140.0 - - DEF_nx_blocks = 36 - DEF_ny_blocks = 36 - DEF_PIO_groupsize = 9 - - DEF_simulation_time%greenwich = .TRUE. - DEF_simulation_time%start_year = 2001 - DEF_simulation_time%start_month = 1 - DEF_simulation_time%start_day = 1 - DEF_simulation_time%start_sec = 0 - DEF_simulation_time%end_year = 2003 - DEF_simulation_time%end_month = 12 - DEF_simulation_time%end_day = 31 - DEF_simulation_time%end_sec = 86400 - DEF_simulation_time%spinup_year = 2001 - DEF_simulation_time%spinup_month = 12 - DEF_simulation_time%spinup_day = 31 - DEF_simulation_time%spinup_sec = 86400 - DEF_simulation_time%spinup_repeat = 0 - - DEF_simulation_time%timestep = 3600. - - DEF_dir_rawdata = '/tera07/CLMrawdata/' - DEF_dir_output = '/tera05/liusf/cases_debuged-0515' - - ! ----- land units and land sets ----- - ! for GRIDBASED - DEF_file_mesh = '/tera05/zhangsp/data/landdata/mask/landmask_igbp_25km.nc' - - ! LAI setting - DEF_LAI_MONTHLY = .true. - - ! whether use CBL height (hpbl) and turn on the large-eddy turbulence scheme (LZD2022) - DEF_USE_CBL_HEIGHT = .true. - - ! Model settings - DEF_LANDONLY = .true. - DEF_USE_DOMINANT_PATCHTYPE = .false. - DEF_USE_VARIABLY_SATURATED_FLOW = .true. - - ! Canopy DEF Interception scheme selection - DEF_Interception_scheme=1 !1:CoLM2014；2:CLM4.5; 3:CLM5; 4:Noah-MP; 5:MATSIRO; 6:VIC - - ! ----- forcing ----- - ! Options : - ! PRINCETON | GSWP3 | QIAN | CRUNCEPV4 | CRUNCEPV7 | ERA5LAND | ERA5 | MSWX - ! WFDE5 | CRUJRA | WFDEI | JRA55 | GDAS | CMFD | POINT - ! CLDAS - DEF_forcing_namelist = '/tera04/liusf/CoLM202X_dev-leddy_20230511_debuged-0515/run/forcing/ERA5_LEddy.nml' - - ! ----- history ----- - DEF_hist_grid_as_forcing = .false. - DEF_hist_lon_res = 0.25 - DEF_hist_lat_res = 0.25 - DEF_WRST_FREQ = 'YEARLY' ! write restart file frequency: HOURLY/DAILY/MONTHLY/YEARLY - DEF_HIST_FREQ = 'DAILY' ! write history file frequency: HOURLY/DAILY/MONTHLY/YEARLY - DEF_HIST_groupby = 'MONTH' ! history in one file: DAY/MONTH/YEAR - DEF_HIST_mode = 'one' ! history in one or block - - DEF_REST_COMPRESS_LEVEL = 1 - DEF_HIST_COMPRESS_LEVEL = 1 - - DEF_hist_vars_namelist = './history.nml' - DEF_hist_vars_turnon_all = .true. - / diff --git a/run/gridbased_era5_IGBP_cama_test.nml b/run/gridbased_era5_IGBP_cama_test.nml deleted file mode 100755 index 8d3eb99b..00000000 --- a/run/gridbased_era5_IGBP_cama_test.nml +++ /dev/null @@ -1,72 +0,0 @@ -&nl_colm - - DEF_CASE_NAME = 'gridbased_era5_IGBP_cama_test_0428' - DEF_domain%edges = -90.0 - DEF_domain%edgen = 90.0 - DEF_domain%edgew = -180.0 - DEF_domain%edgee = 180.0 - - DEF_nx_blocks = 36 - DEF_ny_blocks = 36 - DEF_PIO_groupsize = 6 - - DEF_simulation_time%greenwich = .TRUE. - DEF_simulation_time%start_year = 1990 - DEF_simulation_time%start_month = 1 - DEF_simulation_time%start_day = 1 - DEF_simulation_time%start_sec = 0 - DEF_simulation_time%end_year = 1997 - DEF_simulation_time%end_month = 12 - DEF_simulation_time%end_day = 31 - DEF_simulation_time%end_sec = 86400 - DEF_simulation_time%spinup_year = 1989 - DEF_simulation_time%spinup_month = 1 - DEF_simulation_time%spinup_day = 31 - DEF_simulation_time%spinup_sec = 86400 - DEF_simulation_time%spinup_repeat = 0 - - DEF_simulation_time%timestep = 3600. - - DEF_dir_rawdata = '/tera07/CLMrawdata/' - DEF_dir_output = '/tera04/zhwei/colm/cases' - - ! ----- land units and land sets ----- - ! for GRIDBASED - DEF_file_mesh = '/tera05/zhangsp/data/landdata/mask/landmask_igbp_25km.nc' - - ! LAI setting - DEF_LAI_MONTHLY = .true. - - ! whether use CBL height - DEF_USE_CBL_HEIGHT = .true. - - ! Model settings - DEF_LANDONLY = .true. - DEF_USE_DOMINANT_PATCHTYPE = .false. - DEF_USE_VARIABLY_SATURATED_FLOW = .true. - - ! Canopy DEF Interception scheme selection - DEF_Interception_scheme=1 !1:CoLM2014；2:CLM4.5; 3:CLM5; 4:Noah-MP; 5:MATSIRO; 6:VIC - - ! ----- forcing ----- - ! Options : - ! PRINCETON | GSWP3 | QIAN | CRUNCEPV4 | CRUNCEPV7 | ERA5LAND | ERA5 | MSWX - ! WFDE5 | CRUJRA | WFDEI | JRA55 | GDAS | CMFD | POINT - ! CLDAS - DEF_forcing_namelist = '/tera04/zhwei/colm/CoLM202X/run/forcing/ERA5.nml' - - ! ----- history ----- - DEF_hist_grid_as_forcing = .false. - DEF_hist_lon_res = 0.25 - DEF_hist_lat_res = 0.25 - DEF_WRST_FREQ = 'YEARLY' ! write restart file frequency: HOURLY/DAILY/MONTHLY/YEARLY - DEF_HIST_FREQ = 'DAILY' ! write history file frequency: HOURLY/DAILY/MONTHLY/YEARLY - DEF_HIST_groupby = 'MONTH' ! history in one file: DAY/MONTH/YEAR - DEF_HIST_mode = 'one' ! history in one or block - - DEF_REST_COMPRESS_LEVEL = 1 - DEF_HIST_COMPRESS_LEVEL = 1 - - DEF_hist_vars_namelist = './history.nml' - DEF_hist_vars_turnon_all = .true. - / diff --git a/run/gridbased_era5_USGS_cama_test.nml b/run/gridbased_era5_USGS_cama_test.nml deleted file mode 100644 index 06ed6691..00000000 --- a/run/gridbased_era5_USGS_cama_test.nml +++ /dev/null @@ -1,66 +0,0 @@ -&nl_colm - - DEF_CASE_NAME = 'gridbased_era5_USGS_cama_full_coupled' - - DEF_domain%edges = -90.0 - DEF_domain%edgen = 90.0 - DEF_domain%edgew = -180.0 - DEF_domain%edgee = 180.0 - - DEF_nx_blocks = 30 - DEF_ny_blocks = 30 - DEF_PIO_groupsize = 6 - - DEF_simulation_time%greenwich = .TRUE. - DEF_simulation_time%start_year = 1996 - DEF_simulation_time%start_month = 1 - DEF_simulation_time%start_day = 1 - DEF_simulation_time%start_sec = 0 - DEF_simulation_time%end_year = 2020 - DEF_simulation_time%end_month = 12 - DEF_simulation_time%end_day = 31 - DEF_simulation_time%end_sec = 86400 - DEF_simulation_time%spinup_year = 2000 - DEF_simulation_time%spinup_month = 1 - DEF_simulation_time%spinup_day = 31 - DEF_simulation_time%spinup_sec = 86400 - DEF_simulation_time%spinup_repeat = 0 - - DEF_simulation_time%timestep = 3600. - - DEF_dir_rawdata = '/tera05/zhangsp/data/CLMrawdata_usgs/' - DEF_dir_output = '/tera05/zhangsp/cases' - - ! ----- land units and land sets ----- - ! for GRIDBASED - DEF_file_mesh = '/tera04/zhwei/colm/data/landdata/usgs_nc/common/landmask_usgs_30km.nc' - - ! LAI setting - DEF_LAI_MONTHLY = .true. - - ! Canopy DEF Interception scheme selection - DEF_Interception_scheme=1 !1:CoLM2014；2:CLM4.5; 3:CLM5; 4:Noah-MP; 5:MATSIRO; 6:VIC - - ! ----- forcing ----- - ! Options : - ! PRINCETON | GSWP3 | QIAN | CRUNCEPV4 | CRUNCEPV7 | ERA5LAND | ERA5 | MSWX - ! WFDE5 | CRUJRA | WFDEI | JRA55 | GDAS | CMFD | POINT - ! CLDAS - DEF_forcing_namelist = '/tera04/zhangsp/CoLM202X/github/CoLM202X/run/forcing/ERA5.nml' - - ! ----- history ----- - DEF_hist_grid_as_forcing = .true. - DEF_hist_lon_res = 0.25 - DEF_hist_lat_res = 0.25 - DEF_WRST_FREQ = 'YEARLY' ! write restart file frequency: HOURLY/DAILY/MONTHLY/YEARLY - DEF_HIST_FREQ = 'DAILY' ! write history file frequency: HOURLY/DAILY/MONTHLY/YEARLY - DEF_HIST_groupby = 'DAY' ! history in one file: DAY/MONTH/YEAR - DEF_HIST_mode = 'one' ! history in one or block - - DEF_REST_COMPRESS_LEVEL = 1 - DEF_HIST_COMPRESS_LEVEL = 1 - - DEF_hist_vars_namelist = '/tera04/zhangsp/CoLM202X/github/CoLM202X/run/history.nml' - DEF_hist_vars_turnon_all = .true. - -/ diff --git a/run/gridbased_era5_pft_100km.nml b/run/gridbased_era5_pft_100km.nml deleted file mode 100644 index 2b3a7b4e..00000000 --- a/run/gridbased_era5_pft_100km.nml +++ /dev/null @@ -1,66 +0,0 @@ -&nl_colm - - DEF_CASE_NAME = 'gridbased_era5_pft_100km' - - DEF_domain%edges = -90.0 - DEF_domain%edgen = 90.0 - DEF_domain%edgew = -180.0 - DEF_domain%edgee = 180.0 - - DEF_nx_blocks = 30 - DEF_ny_blocks = 30 - DEF_PIO_groupsize = 6 - - DEF_simulation_time%greenwich = .TRUE. - DEF_simulation_time%start_year = 2002 - DEF_simulation_time%start_month = 1 - DEF_simulation_time%start_day = 1 - DEF_simulation_time%start_sec = 0 - DEF_simulation_time%end_year = 2002 - DEF_simulation_time%end_month = 12 - DEF_simulation_time%end_day = 31 - DEF_simulation_time%end_sec = 86400 - DEF_simulation_time%spinup_year = 2002 - DEF_simulation_time%spinup_month = 1 - DEF_simulation_time%spinup_day = 31 - DEF_simulation_time%spinup_sec = 86400 - DEF_simulation_time%spinup_repeat = 2 - - DEF_simulation_time%timestep = 1800. - - DEF_dir_rawdata = '/tera05/zhangsp/data/CLMrawdata_igbp/' - DEF_dir_output = '/tera05/zhangsp/cases' - - ! ----- land units and land sets ----- - ! for GRIDBASED - DEF_file_mesh = '/tera05/zhangsp/data/landdata/mask/landmask_igbp_100km.nc' - - ! LAI setting - DEF_LAI_MONTHLY = .true. - - ! Canopy DEF Interception scheme selection - DEF_Interception_scheme=1 !1:CoLM2014；2:CLM4.5; 3:CLM5; 4:Noah-MP; 5:MATSIRO; 6:VIC - - ! ----- forcing ----- - ! Options : - ! PRINCETON | GSWP3 | QIAN | CRUNCEPV4 | CRUNCEPV7 | ERA5LAND | ERA5 | MSWX - ! WFDE5 | CRUJRA | WFDEI | JRA55 | GDAS | CMFD | POINT - ! CLDAS - DEF_forcing_namelist = '/tera04/zhangsp/CoLM202X/github/CoLM202X/run/forcing/ERA5.nml' - - ! ----- history ----- - DEF_hist_grid_as_forcing = .true. - DEF_hist_lon_res = 1.0 - DEF_hist_lat_res = 1.0 - DEF_WRST_FREQ = 'MONTHLY' ! write restart file frequency: HOURLY/DAILY/MONTHLY/YEARLY - DEF_HIST_FREQ = 'MONTHLY' ! write history file frequency: HOURLY/DAILY/MONTHLY/YEARLY - DEF_HIST_groupby = 'MONTH' ! history in one file: DAY/MONTH/YEAR - DEF_HIST_mode = 'one' ! history in one or block - - DEF_REST_COMPRESS_LEVEL = 1 - DEF_HIST_COMPRESS_LEVEL = 1 - - DEF_hist_vars_namelist = '/tera04/zhangsp/CoLM202X/github/CoLM202X/run/history.nml' - DEF_hist_vars_turnon_all = .true. - -/ diff --git a/run/gridbased_pearl_CMFD_igbp_100km.nml b/run/gridbased_pearl_CMFD_igbp_100km.nml deleted file mode 100644 index 808419d4..00000000 --- a/run/gridbased_pearl_CMFD_igbp_100km.nml +++ /dev/null @@ -1,69 +0,0 @@ -&nl_colm - - DEF_CASE_NAME = 'gridbased_pearl' - - DEF_domain%edges = 21.0 - DEF_domain%edgen = 27.0 - DEF_domain%edgew = 100.0 - DEF_domain%edgee = 115.0 - - DEF_simulation_time%greenwich = .TRUE. - DEF_simulation_time%start_year = 2001 - DEF_simulation_time%start_month = 1 - DEF_simulation_time%start_day = 1 - DEF_simulation_time%start_sec = 0 - DEF_simulation_time%end_year = 2003 - DEF_simulation_time%end_month = 12 - DEF_simulation_time%end_day = 31 - DEF_simulation_time%end_sec = 86400 - DEF_simulation_time%spinup_year = 2000 - DEF_simulation_time%spinup_month = 12 - DEF_simulation_time%spinup_day = 31 - DEF_simulation_time%spinup_sec = 86400 - DEF_simulation_time%timestep = 1800. - - DEF_simulation_time%spinup_repeat = 2 - - DEF_dir_rawdata = '/tera07/CoLMrawdata/' - DEF_dir_runtime = '/tera07/CoLMruntime/' - DEF_dir_output = '/tera05/zhangsp/cases' - - ! for GRIDBASED - DEF_file_mesh = 'NONE' !'/tera05/zhangsp/data/landdata/mask/landmask_igbp_10km.nc' - ! When DEF_file_mesh is unavailable, resolutions can be used to define grid. - DEF_GRIDBASED_lon_res = 0.1 - DEF_GRIDBASED_lat_res = 0.1 - ! DEF_file_mesh_filter = '/tera05/zhangsp/data/landdata/filter/pearl_mesh_filter.nc' - - ! LAI setting - DEF_LAI_MONTHLY = .true. - DEF_LAI_CHANGE_YEARLY = .false. - - ! Model settings - DEF_LANDONLY = .true. - DEF_USE_DOMINANT_PATCHTYPE = .false. - DEF_USE_VARIABLY_SATURATED_FLOW = .true. - - ! Canopy DEF Interception scheme selection - DEF_Interception_scheme=1 !1:CoLM2014；2:CLM4.5; 3:CLM5; 4:Noah-MP; 5:MATSIRO; 6:VIC - - ! ----- forcing ----- - DEF_forcing_namelist = '/tera04/zhangsp/CoLM202X/github/CoLM202X/run/forcing/CMFD.nml' - - ! ----- history ----- - DEF_hist_grid_as_forcing = .false. - ! available when DEF_hist_grid_as_forcing is false. - DEF_hist_lon_res = 0.1 - DEF_hist_lat_res = 0.1 - - DEF_WRST_FREQ = 'MONTHLY' ! write restart file frequency: HOURLY/DAILY/MONTHLY/YEARLY - DEF_HIST_FREQ = 'MONTHLY' ! write history file frequency: HOURLY/DAILY/MONTHLY/YEARLY - DEF_HIST_groupby = 'MONTH' ! history in one file: DAY/MONTH/YEAR - - DEF_REST_COMPRESS_LEVEL = 1 - DEF_HIST_COMPRESS_LEVEL = 1 - - DEF_hist_vars_turnon_all = .true. - DEF_hist_vars_namelist = '/tera04/zhangsp/CoLM202X/current/run/history.nml' - -/ diff --git a/run/heihe_era5land_igbp_lf.nml b/run/heihe_era5land_igbp_lf.nml deleted file mode 100644 index 72543dae..00000000 --- a/run/heihe_era5land_igbp_lf.nml +++ /dev/null @@ -1,63 +0,0 @@ -&nl_colm - - DEF_CASE_NAME = 'heihe_lf' - - DEF_domain%edges = 35.0 - DEF_domain%edgen = 45.0 - DEF_domain%edgew = 97.0 - DEF_domain%edgee = 102.0 - - DEF_nx_blocks = 30 - DEF_ny_blocks = 30 - DEF_PIO_groupsize = 50 - - DEF_simulation_time%greenwich = .TRUE. - DEF_simulation_time%start_year = 2001 - DEF_simulation_time%start_month = 1 - DEF_simulation_time%start_day = 1 - DEF_simulation_time%start_sec = 0 - DEF_simulation_time%end_year = 2015 - DEF_simulation_time%end_month = 12 - DEF_simulation_time%end_day = 31 - DEF_simulation_time%end_sec = 86400 - DEF_simulation_time%spinup_year = 2001 - DEF_simulation_time%spinup_month = 1 - DEF_simulation_time%spinup_day = 1 - DEF_simulation_time%spinup_sec = 0 - DEF_simulation_time%timestep = 1800. - - DEF_simulation_time%spinup_repeat = 2 - - DEF_dir_rawdata = '/tera05/zhangsp/data/CLMrawdata_hydro/' - DEF_dir_output = '/tera05/zhangsp/cases' - - ! for CATCHMENT - Catchment_data_in_ONE_file = .true. - DEF_path_catchment_data = '/tera04/zhangsp/hillslope/output/heihe.nc' - - ! LAI setting - DEF_LAI_CLIM = .false. - - ! Canopy DEF Interception scheme selection - DEF_Interception_scheme=1 !1:CoLM2014；2:CLM4.5; 3:CLM5; 4:Noah-MP; 5:MATSIRO; 6:VIC - - ! ----- forcing ----- - DEF_forcing_namelist = '/tera04/zhangsp/CoLM202X/current/run/forcing/ERA5LAND.nml' - - ! ----- history ----- - DEF_HISTORY_IN_VECTOR = .false. - - DEF_hist_lon_res = 0.05 - DEF_hist_lat_res = 0.05 - DEF_WRST_FREQ = 'MONTHLY' ! write restart file frequency: HOURLY/DAILY/MONTHLY/YEARLY - DEF_HIST_FREQ = 'DAILY' ! write history file frequency: HOURLY/DAILY/MONTHLY/YEARLY - DEF_HIST_groupby = 'YEAR' ! history in one file: DAY/MONTH/YEAR - DEF_HIST_mode = 'one' ! history in one or block - - DEF_REST_COMPRESS_LEVEL = 1 - DEF_HIST_COMPRESS_LEVEL = 1 - - DEF_hist_vars_turnon_all = .false. - DEF_hist_vars_namelist = '/tera04/zhangsp/CoLM202X/current/run/history.nml' - -/ diff --git a/run/history.nml b/run/history.nml deleted file mode 100644 index e6cc86c0..00000000 --- a/run/history.nml +++ /dev/null @@ -1,108 +0,0 @@ -&nl_colm_history - - ! ----- history ----- - DEF_hist_vars%xy_us = .true. - DEF_hist_vars%xy_vs = .true. - DEF_hist_vars%xy_t = .true. - DEF_hist_vars%xy_q = .true. - DEF_hist_vars%xy_prc = .true. - DEF_hist_vars%xy_prl = .true. - DEF_hist_vars%xy_pbot = .true. - DEF_hist_vars%xy_frl = .true. - DEF_hist_vars%xy_solarin = .true. - DEF_hist_vars%xy_rain = .true. - DEF_hist_vars%xy_snow = .true. - DEF_hist_vars%xy_hpbl = .true. - - DEF_hist_vars%taux = .true. - DEF_hist_vars%tauy = .true. - DEF_hist_vars%fsena = .true. - DEF_hist_vars%lfevpa = .true. - DEF_hist_vars%fevpa = .true. - DEF_hist_vars%fsenl = .true. - DEF_hist_vars%fevpl = .true. - DEF_hist_vars%etr = .true. - DEF_hist_vars%fseng = .true. - DEF_hist_vars%fevpg = .true. - DEF_hist_vars%fgrnd = .true. - DEF_hist_vars%sabvsun = .true. - DEF_hist_vars%sabvsha = .true. - DEF_hist_vars%sabg = .true. - DEF_hist_vars%olrg = .true. - DEF_hist_vars%rnet = .true. - DEF_hist_vars%xerr = .true. - DEF_hist_vars%zerr = .true. - DEF_hist_vars%rsur = .true. - DEF_hist_vars%rnof = .true. - DEF_hist_vars%qintr = .true. - DEF_hist_vars%qinfl = .true. - DEF_hist_vars%qdrip = .true. - DEF_hist_vars%wat = .true. - DEF_hist_vars%assim = .true. - DEF_hist_vars%respc = .true. - DEF_hist_vars%qcharge = .true. - DEF_hist_vars%t_grnd = .true. - DEF_hist_vars%tleaf = .true. - DEF_hist_vars%ldew = .true. - DEF_hist_vars%scv = .true. - DEF_hist_vars%snowdp = .true. - DEF_hist_vars%fsno = .true. - DEF_hist_vars%sigf = .true. - DEF_hist_vars%green = .true. - DEF_hist_vars%lai = .true. - DEF_hist_vars%laisun = .true. - DEF_hist_vars%laisha = .true. - DEF_hist_vars%sai = .true. - DEF_hist_vars%alb = .true. - DEF_hist_vars%emis = .true. - DEF_hist_vars%z0m = .true. - DEF_hist_vars%trad = .true. - DEF_hist_vars%tref = .true. - DEF_hist_vars%qref = .true. - - DEF_hist_vars%t_soisno = .true. - DEF_hist_vars%wliq_soisno = .true. - DEF_hist_vars%wice_soisno = .true. - - DEF_hist_vars%h2osoi = .true. - DEF_hist_vars%rstfacsun = .true. - DEF_hist_vars%rstfacsha = .true. - DEF_hist_vars%rootr = .true. - DEF_hist_vars%vegwp = .true. - DEF_hist_vars%dpond = .true. - DEF_hist_vars%zwt = .true. - DEF_hist_vars%wa = .true. - - DEF_hist_vars%t_lake = .true. - DEF_hist_vars%lake_icefrac = .true. - - DEF_hist_vars%ustar = .true. - DEF_hist_vars%tstar = .true. - DEF_hist_vars%qstar = .true. - DEF_hist_vars%zol = .true. - DEF_hist_vars%rib = .true. - DEF_hist_vars%fm = .true. - DEF_hist_vars%fh = .true. - DEF_hist_vars%fq = .true. - DEF_hist_vars%us10m = .true. - DEF_hist_vars%vs10m = .true. - DEF_hist_vars%fm10m = .true. - DEF_hist_vars%sr = .true. - DEF_hist_vars%solvd = .true. - DEF_hist_vars%solvi = .true. - DEF_hist_vars%solnd = .true. - DEF_hist_vars%solni = .true. - DEF_hist_vars%srvd = .true. - DEF_hist_vars%srvi = .true. - DEF_hist_vars%srnd = .true. - DEF_hist_vars%srni = .true. - DEF_hist_vars%solvdln = .true. - DEF_hist_vars%solviln = .true. - DEF_hist_vars%solndln = .true. - DEF_hist_vars%solniln = .true. - DEF_hist_vars%srvdln = .true. - DEF_hist_vars%srviln = .true. - DEF_hist_vars%srndln = .true. - DEF_hist_vars%srniln = .true. - -/ diff --git a/run/huaihe_CRUJRA_igbp_lf.nml b/run/huaihe_CRUJRA_igbp_lf.nml deleted file mode 100644 index 4fab1106..00000000 --- a/run/huaihe_CRUJRA_igbp_lf.nml +++ /dev/null @@ -1,57 +0,0 @@ -&nl_colm - - DEF_CASE_NAME = 'huaihe' - - DEF_domain%edges = 33.0 - DEF_domain%edgen = 37.0 - DEF_domain%edgew = 114.0 - DEF_domain%edgee = 120.0 - - DEF_simulation_time%greenwich = .TRUE. - DEF_simulation_time%start_year = 2001 - DEF_simulation_time%start_month = 1 - DEF_simulation_time%start_day = 1 - DEF_simulation_time%start_sec = 0 - DEF_simulation_time%end_year = 2015 - DEF_simulation_time%end_month = 12 - DEF_simulation_time%end_day = 31 - DEF_simulation_time%end_sec = 86400 - DEF_simulation_time%spinup_year = 2001 - DEF_simulation_time%spinup_month = 1 - DEF_simulation_time%spinup_day = 1 - DEF_simulation_time%spinup_sec = 0 - DEF_simulation_time%timestep = 1800. - - DEF_simulation_time%spinup_repeat = 2 - - DEF_dir_rawdata = '/tera07/CoLMrawdata/' - DEF_dir_runtime = '/tera07/CoLMruntime/' - DEF_dir_output = '/tera05/zhangsp/cases' - - ! for CATCHMENT - DEF_CatchmentMesh_data = '/tera04/zhangsp/hillslope/output/huaihe_100km2.nc' - - ! LAI setting - DEF_LAI_MONTHLY = .true. - DEF_LAI_CHANGE_YEARLY = .false. - - ! ----- forcing ----- - DEF_forcing_namelist = '/tera04/zhangsp/CoLM202X/github/CoLM202X/run/forcing/CRUJRA.nml' - - ! ----- history ----- - DEF_HISTORY_IN_VECTOR = .false. - - DEF_hist_lon_res = 0.05 - DEF_hist_lat_res = 0.05 - DEF_WRST_FREQ = 'MONTHLY' ! write restart file frequency: HOURLY/DAILY/MONTHLY/YEARLY - DEF_HIST_FREQ = 'DAILY' ! write history file frequency: HOURLY/DAILY/MONTHLY/YEARLY - DEF_HIST_groupby = 'YEAR' ! history in one file: DAY/MONTH/YEAR - DEF_HIST_mode = 'one' ! history in one or block - - DEF_REST_COMPRESS_LEVEL = 1 - DEF_HIST_COMPRESS_LEVEL = 1 - - DEF_hist_vars_turnon_all = .false. - DEF_hist_vars_namelist = '/tera04/zhangsp/CoLM202X/github/CoLM202X/run/history.nml' - -/ diff --git a/run/input_GRID_PFT_URBANOFF_CAMBELL_CAMAOFF_BGCON_CROPON.nml b/run/input_GRID_PFT_URBANOFF_CAMBELL_CAMAOFF_BGCON_CROPON.nml deleted file mode 100644 index 4ebea96c..00000000 --- a/run/input_GRID_PFT_URBANOFF_CAMBELL_CAMAOFF_BGCON_CROPON.nml +++ /dev/null @@ -1,67 +0,0 @@ -&nl_colm - - DEF_CASE_NAME = 'GRID_PFT_URBANOFF_CAMBELL_CAMAOFF_BGCON_CROPON' - - DEF_domain%edges = -90.0 - DEF_domain%edgen = 0.0 - DEF_domain%edgew = -180.0 - DEF_domain%edgee = 180.0 - -! DEF_domain%edges = 30.0 -! DEF_domain%edgen = 35.0 -! DEF_domain%edgew = 105.0 -! DEF_domain%edgee = 110.0 - - DEF_nx_blocks = 9 - DEF_ny_blocks = 9 - DEF_PIO_groupsize = 6 - - DEF_simulation_time%greenwich = .TRUE. - DEF_simulation_time%start_year = 2000 - DEF_simulation_time%start_month = 12 - DEF_simulation_time%start_day = 31 - DEF_simulation_time%start_sec = 86400 - DEF_simulation_time%end_year = 2001 - DEF_simulation_time%end_month = 1 - DEF_simulation_time%end_day = 31 - DEF_simulation_time%end_sec = 86400 - DEF_simulation_time%spinup_year = 1980 - DEF_simulation_time%spinup_month = 1 - DEF_simulation_time%spinup_day = 365 - DEF_simulation_time%spinup_sec = 86400 - - DEF_simulation_time%timestep = 1800. - - DEF_dir_rawdata = '/tera07/CoLMrawdata/' - DEF_dir_output = '/tera05/zhangsp/cases/' - - ! ----- land units and land sets ----- - ! for GRIDBASED - DEF_file_mesh = '/tera05/zhangsp/data/landdata/mask/landmask_igbp_144x96.nc' - - ! LAI setting - DEF_LAI_MONTHLY = .true. - - ! Canopy DEF Interception scheme selection - DEF_Interception_scheme=1 !1:CoLM2014；2:CLM4.5; 3:CLM5; 4:Noah-MP; 5:MATSIRO; 6:VIC - - ! ----- forcing ----- - ! Options : - ! PRINCETON | GSWP3 | QIAN | CRUNCEPV4 | CRUNCEPV7 | ERA5LAND | ERA5 | MSWX - ! WFDE5 | CRUJRA | WFDEI | JRA55 | GDAS | CMFD | POINT - DEF_forcing_namelist = '/tera04/zhangsp/CoLM202X/github/CoLM202X/run/forcing/ERA5.nml' - - ! ----- history ----- - DEF_hist_lon_res = 2.5 - DEF_hist_lat_res = 1.875 - DEF_WRST_FREQ = 'YEARLY' ! write restart file frequency: HOURLY/DAILY/MONTHLY/YEARLY - DEF_HIST_FREQ = 'MONTHLY' ! write history file frequency: HOURLY/DAILY/MONTHLY/YEARLY - DEF_HIST_groupby = 'MONTH' ! history in one file: DAY/MONTH/YEAR - DEF_HIST_mode = 'one' ! history in one or block - DEF_REST_COMPRESS_LEVEL = 1 - DEF_HIST_COMPRESS_LEVEL = 1 - - DEF_hist_vars_namelist = '/tera04/zhangsp/CoLM202X/github/CoLM202X/run/history.nml' - DEF_hist_vars_turnon_all = .true. - -/ diff --git a/run/input_IT-CA3-PFT.nml b/run/input_IT-CA3-PFT.nml deleted file mode 100644 index b10a4bda..00000000 --- a/run/input_IT-CA3-PFT.nml +++ /dev/null @@ -1,62 +0,0 @@ -&nl_colm - - DEF_CASE_NAME = 'IT-CA3-PFT' - - ! surface data from SITE. - SITE_fsrfdata = '/tera06/zhwei/CoLM_Forcing/PLUMBER2/Srfdata/IT-CA3_2012-2013_FLUXNET2015_Srf.nc' - ! path to surface database - DEF_dir_rawdata = '/tera07/CoLMrawdata/' - DEF_dir_runtime = '/tera07/CoLMruntime/' - - ! true : surface data from SITE - ! false : surface data is retrieved from database. - USE_SITE_pctpfts = .false. - USE_SITE_pctcrop = .false. - USE_SITE_htop = .false. - USE_SITE_LAI = .false. - USE_SITE_lakedepth = .false. - USE_SITE_soilreflectance = .false. - USE_SITE_soilparameters = .false. - USE_SITE_topography = .false. - - DEF_simulation_time%greenwich = .FALSE. - DEF_simulation_time%start_year = 2012 - DEF_simulation_time%start_month = 1 - DEF_simulation_time%start_day = 1 - DEF_simulation_time%start_sec = 1800 - DEF_simulation_time%end_year = 2013 - DEF_simulation_time%end_month = 12 - DEF_simulation_time%end_day = 31 - DEF_simulation_time%end_sec = 86400 - DEF_simulation_time%spinup_year = 2012 - DEF_simulation_time%spinup_month = 1 - DEF_simulation_time%spinup_day = 1 - DEF_simulation_time%spinup_sec = 1800 - DEF_simulation_time%spinup_repeat = 2 - - DEF_simulation_time%timestep = 1800. - - DEF_dir_output = '/tera02/wein/cases_mpi/' - - ! LAI setting - DEF_LAI_MONTHLY = .true. - - ! Canopy DEF Interception scheme selection - DEF_Interception_scheme = 1 ! 1:CoLM2014；2:CLM4.5; 3:CLM5; 4:Noah-MP; 5:MATSIRO; 6:VIC - - ! ----- forcing ----- - DEF_forcing_namelist = '/tera04/luxj/CoLM202X-chris/run/forcing/POINT-IT-CA3.nml' - - ! ----- history ----- - DEF_hist_lon_res = 1. - DEF_hist_lat_res = 1. - DEF_WRST_FREQ = 'MONTHLY' ! write restart file frequency: HOURLY/DAILY/MONTHLY/YEARLY - DEF_HIST_FREQ = 'MONTHLY' ! write history file frequency: HOURLY/DAILY/MONTHLY/YEARLY - DEF_HIST_groupby = 'MONTH' ! history in one file: DAY/MONTH/YEAR - DEF_REST_COMPRESS_LEVEL = 0 - DEF_HIST_COMPRESS_LEVEL = 0 - - DEF_hist_vars_namelist = '/tera04/luxj/CoLM202X-test/run/history.nml' - DEF_hist_vars_turnon_all = .true. - - / diff --git a/run/job.slurm b/run/job.slurm new file mode 100644 index 00000000..a51df164 --- /dev/null +++ b/run/job.slurm @@ -0,0 +1,9 @@ +#!/bin/bash + +#SBATCH -N 1 -n 40 + +export LD_LIBRARY_PATH=/opt/netcdf-c-4.9.2-fortran-4.6.0-gnu/lib:/opt/hdf5-1.14.0-gnu/lib:$LD_LIBRARY_PATH + +# mpirun -np 40 run/mksrfdata.x run/GreaterBay_Grid_10km_IGBP_VG.nml +mpirun -np 40 run/mkinidata.x run/GreaterBay_Grid_10km_IGBP_VG.nml +mpirun -np 40 run/colm.x run/GreaterBay_Grid_10km_IGBP_VG.nml diff --git a/run/pearl_small.nml b/run/pearl_small.nml deleted file mode 100644 index b39b2ac8..00000000 --- a/run/pearl_small.nml +++ /dev/null @@ -1,67 +0,0 @@ -&nl_colm - - DEF_CASE_NAME = 'gridbased_pearl_small' - - DEF_domain%edges = 23.0 - DEF_domain%edgen = 26.0 - DEF_domain%edgew = 108.0 - DEF_domain%edgee = 112.0 - - DEF_dir_existing_srfdata = '/tera05/zhangsp/cases/gridbased_pearl/landdata' - USE_srfdata_from_larger_region = .true. - - DEF_simulation_time%greenwich = .TRUE. - DEF_simulation_time%start_year = 2000 - DEF_simulation_time%start_month = 1 - DEF_simulation_time%start_day = 1 - DEF_simulation_time%start_sec = 0 - DEF_simulation_time%end_year = 2003 - DEF_simulation_time%end_month = 12 - DEF_simulation_time%end_day = 31 - DEF_simulation_time%end_sec = 86400 - DEF_simulation_time%spinup_year = 2000 - DEF_simulation_time%spinup_month = 12 - DEF_simulation_time%spinup_day = 31 - DEF_simulation_time%spinup_sec = 86400 - DEF_simulation_time%timestep = 1800. - - DEF_simulation_time%spinup_repeat = 2 - - DEF_dir_rawdata = '/tera07/CLMrawdata/' - DEF_dir_output = '/tera05/zhangsp/cases' - - ! for GRIDBASED - DEF_file_mesh = '/tera05/zhangsp/data/landdata/mask/landmask_igbp_10km.nc' - ! DEF_file_mesh_filter = '/tera05/zhangsp/data/landdata/filter/pearl_mesh_filter.nc' - - ! LAI setting - DEF_LAI_MONTHLY = .true. - - ! Model settings - DEF_LANDONLY = .true. - DEF_USE_DOMINANT_PATCHTYPE = .false. - DEF_USE_VARIABLY_SATURATED_FLOW = .true. - - ! Canopy DEF Interception scheme selection - DEF_Interception_scheme=1 !1:CoLM2014；2:CLM4.5; 3:CLM5; 4:Noah-MP; 5:MATSIRO; 6:VIC - - ! ----- forcing ----- - DEF_forcing_namelist = '/tera04/zhangsp/CoLM202X/current/run/forcing/CMFD.nml' - - ! ----- history ----- - DEF_hist_grid_as_forcing = .false. - ! available when DEF_hist_grid_as_forcing is false. - DEF_hist_lon_res = 0.1 - DEF_hist_lat_res = 0.1 - - DEF_WRST_FREQ = 'MONTHLY' ! write restart file frequency: HOURLY/DAILY/MONTHLY/YEARLY - DEF_HIST_FREQ = 'MONTHLY' ! write history file frequency: HOURLY/DAILY/MONTHLY/YEARLY - DEF_HIST_groupby = 'MONTH' ! history in one file: DAY/MONTH/YEAR - - DEF_REST_COMPRESS_LEVEL = 1 - DEF_HIST_COMPRESS_LEVEL = 1 - - DEF_hist_vars_turnon_all = .true. - DEF_hist_vars_namelist = '/tera04/zhangsp/CoLM202X/current/run/history.nml' - -/ diff --git a/run/unstructured_pearl_ERA5Land_usgs.nml b/run/unstructured_pearl_ERA5Land_usgs.nml deleted file mode 100644 index 5dc21813..00000000 --- a/run/unstructured_pearl_ERA5Land_usgs.nml +++ /dev/null @@ -1,66 +0,0 @@ -&nl_colm - - DEF_CASE_NAME = 'unstructured_pearl' - - DEF_domain%edges = 21.0 - DEF_domain%edgen = 27.0 - DEF_domain%edgew = 100.0 - DEF_domain%edgee = 115.0 - - DEF_nx_blocks = 30 - DEF_ny_blocks = 30 - DEF_PIO_groupsize = 6 - - DEF_simulation_time%greenwich = .TRUE. - DEF_simulation_time%start_year = 2000 - DEF_simulation_time%start_month = 1 - DEF_simulation_time%start_day = 1 - DEF_simulation_time%start_sec = 0 - DEF_simulation_time%end_year = 2003 - DEF_simulation_time%end_month = 12 - DEF_simulation_time%end_day = 31 - DEF_simulation_time%end_sec = 86400 - DEF_simulation_time%spinup_year = 2000 - DEF_simulation_time%spinup_month = 12 - DEF_simulation_time%spinup_day = 31 - DEF_simulation_time%spinup_sec = 86400 - DEF_simulation_time%timestep = 1800. - - DEF_simulation_time%spinup_repeat = 2 - - DEF_dir_rawdata = '/tera05/zhangsp/data/CLMrawdata_usgs/' - DEF_dir_output = '/tera05/zhangsp/cases' - - ! for GRIDBASED - DEF_file_mesh = '/tera05/zhangsp/data/landdata/mesh_cwrf.nc' - DEF_file_mesh_filter = '/tera05/zhangsp/data/landdata/filter/pearl_mesh_filter.nc' - - ! LAI setting - DEF_LAI_MONTHLY = .false. - - ! Model settings - DEF_LANDONLY = .true. - DEF_USE_DOMINANT_PATCHTYPE = .false. - DEF_USE_VARIABLY_SATURATED_FLOW = .false. - - ! Canopy DEF Interception scheme selection - DEF_Interception_scheme=1 !1:CoLM2014；2:CLM4.5; 3:CLM5; 4:Noah-MP; 5:MATSIRO; 6:VIC - - ! ----- forcing ----- - DEF_forcing_namelist = '/tera04/zhangsp/CoLM202X/current/run/forcing/ERA5LAND.nml' - - ! ----- history ----- - DEF_HISTORY_IN_VECTOR = .false. - DEF_hist_grid_as_forcing = .true. - - DEF_WRST_FREQ = 'MONTHLY' ! write restart file frequency: HOURLY/DAILY/MONTHLY/YEARLY - DEF_HIST_FREQ = 'MONTHLY' ! write history file frequency: HOURLY/DAILY/MONTHLY/YEARLY - DEF_HIST_groupby = 'MONTH' ! history in one file: DAY/MONTH/YEAR - - DEF_REST_COMPRESS_LEVEL = 1 - DEF_HIST_COMPRESS_LEVEL = 1 - - DEF_hist_vars_turnon_all = .true. - DEF_hist_vars_namelist = '/tera04/zhangsp/CoLM202X/current/run/history.nml' - -/ diff --git a/share/MOD_Block.F90 b/share/MOD_Block.F90 index 40bb1f16..808b63c5 100644 --- a/share/MOD_Block.F90 +++ b/share/MOD_Block.F90 @@ -101,21 +101,18 @@ SUBROUTINE block_set_by_size (this, nxblk_in, nyblk_in) ! Local Variables INTEGER :: iblk, jblk - INTEGER, parameter :: iset(24) = & - (/1, 2, 3, 4, 5, 6, 8, 9, 10, 12, 15, 18, & - 20, 24, 30, 36, 40, 45, 60, 72, 90, 120, 180, 360/) - IF ((findloc(iset,nyblk_in,dim=1) <= 0) .or. & - (findloc(iset,nxblk_in,dim=1) <= 0) ) THEN + IF ((mod(360,nxblk_in) /= 0) .or. (mod(180,nyblk_in) /= 0)) THEN IF (p_is_master) THEN - write(*,*) 'Number of blocks should be in the set (', iset, ')' + write(*,*) 'Number of blocks in longitude should be a factor of 360 ' + write(*,*) ' and Number of blocks in latitude should be a factor of 180.' ENDIF #ifdef USEMPI CALL mpi_barrier (p_comm_glb, p_err) - CALL mpi_abort (p_comm_glb, p_err) #endif + CALL CoLM_stop () ENDIF @@ -142,8 +139,8 @@ SUBROUTINE block_set_by_size (this, nxblk_in, nyblk_in) ENDDO IF (p_is_master) THEN - write (*,*) 'Block information:' - write (*,'(I3,A,I3,A)') this%nxblk, ' blocks in longitude,', & + write (*,'(A)') 'Block information:' + write (*,'(I4,A,I4,A)') this%nxblk, ' blocks in longitude,', & this%nyblk, ' blocks in latitude.' write (*,*) ENDIF @@ -546,15 +543,14 @@ SUBROUTINE block_free_mem (this) END SUBROUTINE block_free_mem - ! -------------------------------- - SUBROUTINE get_filename_block (filename, iblk, jblk, fileblock) + ! ----- + SUBROUTINE get_blockname (iblk, jblk, blockname) IMPLICIT NONE - CHARACTER(len=*), intent(in) :: filename INTEGER, intent(in) :: iblk, jblk - CHARACTER(len=*), intent(out) :: fileblock + CHARACTER(len=*), intent(out) :: blockname ! Local variables CHARACTER(len=4) :: cx @@ -573,6 +569,26 @@ SUBROUTINE get_filename_block (filename, iblk, jblk, fileblock) write (cx, '(A1,I3.3)') 'e', floor(gblock%lon_w(iblk)) ENDIF + blockname = trim(cx) // '_' // trim(cy) + + END SUBROUTINE get_blockname + + ! -------------------------------- + SUBROUTINE get_filename_block (filename, iblk, jblk, fileblock) + + IMPLICIT NONE + + CHARACTER(len=*), intent(in) :: filename + INTEGER, intent(in) :: iblk, jblk + + CHARACTER(len=*), intent(out) :: fileblock + + ! Local variables + CHARACTER(len=8) :: blockname + INTEGER :: i + + CALL get_blockname (iblk, jblk, blockname) + i = len_trim (filename) DO while (i > 0) IF (filename(i:i) == '.') exit @@ -580,9 +596,9 @@ SUBROUTINE get_filename_block (filename, iblk, jblk, fileblock) ENDDO IF (i > 0) THEN - fileblock = filename(1:i-1) // '_' // trim(cx) // '_' // trim(cy) // '.nc' + fileblock = filename(1:i-1) // '_' // blockname // '.nc' ELSE - fileblock = filename // '_' // trim(cx) // '_' // trim(cy) // '.nc' + fileblock = filename // '_' // blockname // '.nc' ENDIF END SUBROUTINE get_filename_block diff --git a/share/MOD_DataType.F90 b/share/MOD_DataType.F90 index c2202f68..34e8483e 100644 --- a/share/MOD_DataType.F90 +++ b/share/MOD_DataType.F90 @@ -40,6 +40,20 @@ MODULE MOD_DataType final :: pointer_int32_1d_free_mem END TYPE pointer_int32_1d + !------- + TYPE :: pointer_int64_1d + INTEGER*8, allocatable :: val(:) + CONTAINS + final :: pointer_int64_1d_free_mem + END TYPE pointer_int64_1d + + !------- + TYPE :: pointer_logic_1d + logical, allocatable :: val(:) + CONTAINS + final :: pointer_logic_1d_free_mem + END TYPE pointer_logic_1d + !------- TYPE :: pointer_int32_2d INTEGER, allocatable :: val (:,:) @@ -144,6 +158,32 @@ SUBROUTINE pointer_int32_1d_free_mem (this) END SUBROUTINE pointer_int32_1d_free_mem + !------------------ + SUBROUTINE pointer_int64_1d_free_mem (this) + + IMPLICIT NONE + + TYPE(pointer_int64_1d) :: this + + IF (allocated(this%val)) THEN + deallocate(this%val) + ENDIF + + END SUBROUTINE pointer_int64_1d_free_mem + + !------------------ + SUBROUTINE pointer_logic_1d_free_mem (this) + + IMPLICIT NONE + + TYPE(pointer_logic_1d) :: this + + IF (allocated(this%val)) THEN + deallocate(this%val) + ENDIF + + END SUBROUTINE pointer_logic_1d_free_mem + !------------------ SUBROUTINE pointer_int32_2d_free_mem (this) diff --git a/share/MOD_Grid.F90 b/share/MOD_Grid.F90 index da10bbc4..c4b2611d 100644 --- a/share/MOD_Grid.F90 +++ b/share/MOD_Grid.F90 @@ -238,6 +238,8 @@ SUBROUTINE grid_define_by_ndims (this, lon_points, lat_points) this%lon_e(ilon) = -180.0 + del_lon * ilon ENDDO + this%lon_e(this%nlon) = -180.0 + CALL this%normalize () CALL this%set_blocks () @@ -372,24 +374,40 @@ SUBROUTINE grid_define_by_center (this, lat_in, lon_in, & END SUBROUTINE grid_define_by_center !----------------------------------------------------- - SUBROUTINE grid_define_from_file (this, filename) + SUBROUTINE grid_define_from_file (this, filename, latname, lonname) USE MOD_NetCDFSerial IMPLICIT NONE class (grid_type) :: this CHARACTER(len=*), intent(in) :: filename + CHARACTER(len=*), intent(in), optional :: latname, lonname - CALL ncio_read_bcast_serial (filename, 'lat_s', this%lat_s) - CALL ncio_read_bcast_serial (filename, 'lat_n', this%lat_n) - CALL ncio_read_bcast_serial (filename, 'lon_w', this%lon_w) - CALL ncio_read_bcast_serial (filename, 'lon_e', this%lon_e) + ! Local Variables + real(r8), allocatable :: lon_in(:) + real(r8), allocatable :: lat_in(:) - this%nlat = size(this%lat_s) - this%nlon = size(this%lon_w) + IF (.not. (present(latname) .and. present(lonname))) THEN - CALL this%normalize () - CALL this%set_blocks () + CALL ncio_read_bcast_serial (filename, 'lat_s', this%lat_s) + CALL ncio_read_bcast_serial (filename, 'lat_n', this%lat_n) + CALL ncio_read_bcast_serial (filename, 'lon_w', this%lon_w) + CALL ncio_read_bcast_serial (filename, 'lon_e', this%lon_e) + + this%nlat = size(this%lat_s) + this%nlon = size(this%lon_w) + + CALL this%normalize () + CALL this%set_blocks () + + ELSE + + call ncio_read_bcast_serial (filename, latname, lat_in) + call ncio_read_bcast_serial (filename, lonname, lon_in) + call this%define_by_center (lat_in, lon_in) + + deallocate (lat_in, lon_in) + ENDIF END SUBROUTINE grid_define_from_file diff --git a/share/MOD_Mapping_Grid2Pset.F90 b/share/MOD_Mapping_Grid2Pset.F90 index 69451eec..a25166ff 100644 --- a/share/MOD_Mapping_Grid2Pset.F90 +++ b/share/MOD_Mapping_Grid2Pset.F90 @@ -41,6 +41,8 @@ MODULE MOD_Mapping_Grid2Pset procedure, PRIVATE :: map_aweighted_3d => map_g2p_aweighted_3d generic, PUBLIC :: map_aweighted => map_aweighted_2d, map_aweighted_3d + procedure, PUBLIC :: map_max_frenquency_2d => map_g2p_max_frequency_2d + final :: mapping_grid2pset_free_mem END TYPE mapping_grid2pset_type @@ -97,10 +99,8 @@ SUBROUTINE mapping_grid2pset_build (this, fgrid, pixelset, gfilter, missing_valu #endif IF (p_is_master) THEN - write(*,100) - 100 format (/, 'Making mapping from grid to pixel set') - write(*,*) fgrid%nlat, 'grids in latitude' - write(*,*) fgrid%nlon, 'grids in longitude' + write(*,"('Making mapping from grid to pixel set: ', I7, A, I7, A)") & + fgrid%nlat, ' grids in latitude', fgrid%nlon, ' grids in longitude' ENDIF IF (allocated(this%grid%xblk)) deallocate(this%grid%xblk) @@ -757,6 +757,102 @@ SUBROUTINE map_g2p_aweighted_3d (this, gdata, ndim1, pdata) END SUBROUTINE map_g2p_aweighted_3d + !----------------------------------------------------- + SUBROUTINE map_g2p_max_frequency_2d (this, gdata, pdata) + + USE MOD_Precision + USE MOD_Grid + USE MOD_Pixelset + USE MOD_DataType + USE MOD_SPMD_Task + USE MOD_Vars_Global, only : spval + IMPLICIT NONE + + class (mapping_grid2pset_type) :: this + + TYPE(block_data_int32_2d), intent(in) :: gdata + integer, intent(out) :: pdata(:) + + ! Local variables + INTEGER :: iproc, idest, isrc + INTEGER :: ig, ilon, ilat, xblk, yblk, xloc, yloc, iloc, iset + + integer, allocatable :: gbuff(:) + TYPE(pointer_int32_1d), allocatable :: pbuff(:) + + IF (p_is_io) THEN + + DO iproc = 0, p_np_worker-1 + IF (this%glist(iproc)%ng > 0) THEN + + allocate (gbuff (this%glist(iproc)%ng)) + + DO ig = 1, this%glist(iproc)%ng + ilon = this%glist(iproc)%ilon(ig) + ilat = this%glist(iproc)%ilat(ig) + xblk = this%grid%xblk (ilon) + yblk = this%grid%yblk (ilat) + xloc = this%grid%xloc (ilon) + yloc = this%grid%yloc (ilat) + + gbuff(ig) = gdata%blk(xblk,yblk)%val(xloc,yloc) + + ENDDO + +#ifdef USEMPI + idest = p_address_worker(iproc) + CALL mpi_send (gbuff, this%glist(iproc)%ng, MPI_INTEGER, & + idest, mpi_tag_data, p_comm_glb, p_err) + + deallocate (gbuff) +#endif + ENDIF + ENDDO + + ENDIF + + IF (p_is_worker) THEN + + allocate (pbuff (0:p_np_io-1)) + + DO iproc = 0, p_np_io-1 + IF (this%glist(iproc)%ng > 0) THEN + + allocate (pbuff(iproc)%val (this%glist(iproc)%ng)) + +#ifdef USEMPI + isrc = p_address_io(iproc) + CALL mpi_recv (pbuff(iproc)%val, this%glist(iproc)%ng, MPI_INTEGER, & + isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) +#else + pbuff(0)%val = gbuff + deallocate (gbuff) +#endif + ENDIF + ENDDO + + DO iset = 1, this%npset + IF (allocated(this%gweight(iset)%val)) THEN + ig = maxloc(this%gweight(iset)%val, dim=1) + iproc = this%address(iset)%val(1,ig) + iloc = this%address(iset)%val(2,ig) + pdata(iset) = pbuff(iproc)%val(iloc) + ELSE + pdata(iset) = -9999 + ENDIF + ENDDO + + DO iproc = 0, p_np_io-1 + IF (this%glist(iproc)%ng > 0) THEN + deallocate (pbuff(iproc)%val) + ENDIF + ENDDO + + deallocate (pbuff) + + ENDIF + + END SUBROUTINE map_g2p_max_frequency_2d !----------------------------------------------------- SUBROUTINE mapping_grid2pset_free_mem (this) diff --git a/share/MOD_Mapping_Pset2Grid.F90 b/share/MOD_Mapping_Pset2Grid.F90 index e50b0440..7c227bd2 100644 --- a/share/MOD_Mapping_Pset2Grid.F90 +++ b/share/MOD_Mapping_Pset2Grid.F90 @@ -101,10 +101,8 @@ SUBROUTINE mapping_pset2grid_build (this, pixelset, fgrid, pctpset) #endif IF (p_is_master) THEN - write(*,101) - 101 format (/, 'Making mapping from pixel set to grid ...') - write(*,*) fgrid%nlat, 'grids in latitude' - write(*,*) fgrid%nlon, 'grids in longitude' + write(*,"('Making mapping from pixel set to grid: ', I7, A, I7, A)") & + fgrid%nlat, ' grids in latitude', fgrid%nlon, ' grids in longitude' ENDIF IF (allocated(this%grid%xblk)) deallocate(this%grid%xblk) diff --git a/share/MOD_Mesh.F90 b/share/MOD_Mesh.F90 index 2a8e6276..5a9dc376 100644 --- a/share/MOD_Mesh.F90 +++ b/share/MOD_Mesh.F90 @@ -39,8 +39,8 @@ MODULE MOD_Mesh ! ---- data types ---- TYPE :: irregular_elm_type - INTEGER :: indx - INTEGER :: xblk, yblk + INTEGER*8 :: indx + INTEGER :: xblk, yblk INTEGER :: npxl INTEGER, allocatable :: ilon(:) @@ -143,12 +143,15 @@ SUBROUTINE mesh_build () INTEGER :: smesg(5), rmesg(5) INTEGER, allocatable :: nelm_worker(:) - TYPE(pointer_int32_1d), allocatable :: elist_worker(:) + TYPE(pointer_int64_1d), allocatable :: elist_worker(:) - INTEGER, allocatable :: elist(:), iaddr(:) - INTEGER, allocatable :: elist2(:,:), xlist2(:,:), ylist2(:,:) + INTEGER*8 :: elmid + INTEGER*8, allocatable :: elist(:), elist2(:,:), sbuf64(:), elist_recv(:) + + INTEGER, allocatable :: iaddr(:) + INTEGER, allocatable :: xlist2(:,:), ylist2(:,:) INTEGER, allocatable :: sbuf(:), ipt2(:,:) - INTEGER, allocatable :: elist_recv(:), xlist_recv(:), ylist_recv(:) + INTEGER, allocatable :: xlist_recv(:), ylist_recv(:) INTEGER, allocatable :: npxl_blk(:,:) LOGICAL, allocatable :: msk2(:,:), msk(:) INTEGER, allocatable :: xlist(:), ylist(:) @@ -232,23 +235,23 @@ SUBROUTINE mesh_build () yg = gridmesh%ydsp(jblk) + yloc - ie = gridmesh%nlon * (yg-1) + xg + elmid = int(gridmesh%nlon,8) * (yg-1) + xg ELSE - ie = 0 + elmid = 0 ENDIF #endif #ifdef CATCHMENT - ie = datamesh%blk(iblk,jblk)%val(xloc,yloc) + elmid = datamesh%blk(iblk,jblk)%val(xloc,yloc) #endif #ifdef UNSTRUCTURED - ie = datamesh%blk(iblk,jblk)%val(xloc,yloc) + elmid = datamesh%blk(iblk,jblk)%val(xloc,yloc) #endif - IF (ie > 0) THEN + IF (elmid > 0) THEN - iworker = mod(ie, p_np_worker) + iworker = mod(elmid, p_np_worker) CALL insert_into_sorted_list1 ( & - ie, nelm_worker(iworker), elist_worker(iworker)%val, iloc) + elmid, nelm_worker(iworker), elist_worker(iworker)%val, iloc) IF (nelm_worker(iworker) == size(elist_worker(iworker)%val)) THEN CALL expand_list (elist_worker(iworker)%val, 0.2_r8) @@ -395,21 +398,21 @@ SUBROUTINE mesh_build () #ifdef GRIDBASED IF (datamesh%blk(iblk,jblk)%val(xloc,yloc) > 0) THEN - ie = gridmesh%nlon * (yg-1) + xg + elmid = int(gridmesh%nlon,8) * (yg-1) + xg ELSE - ie = 0 + elmid = 0 ENDIF #endif #ifdef CATCHMENT - ie = datamesh%blk(iblk,jblk)%val(xloc,yloc) + elmid = datamesh%blk(iblk,jblk)%val(xloc,yloc) #endif #ifdef UNSTRUCTURED - ie = datamesh%blk(iblk,jblk)%val(xloc,yloc) + elmid = datamesh%blk(iblk,jblk)%val(xloc,yloc) #endif xlist2(ixloc,iyloc) = ix ylist2(ixloc,iyloc) = iy - elist2(ixloc,iyloc) = ie + elist2(ixloc,iyloc) = elmid IF (dlonp < 1.0e-6_r8) THEN elist2(ixloc,iyloc) = 0 @@ -424,6 +427,8 @@ SUBROUTINE mesh_build () allocate (sbuf (nxp*nyp)) allocate (ipt2 (nxp,nyp)) + allocate (sbuf64 (nxp*nyp)) + ipt2 = mod(elist2, p_np_worker) DO iproc = 0, p_np_worker-1 msk2 = (ipt2 == iproc) .and. (elist2 > 0) @@ -437,9 +442,9 @@ SUBROUTINE mesh_build () CALL mpi_send (smesg(1:2), 2, MPI_INTEGER, & idest, mpi_tag_mesg, p_comm_glb, p_err) - sbuf(1:nsend) = pack(elist2, msk2) + sbuf64(1:nsend) = pack(elist2, msk2) ! send(04) - CALL mpi_send (sbuf(1:nsend), nsend, MPI_INTEGER, & + CALL mpi_send (sbuf64(1:nsend), nsend, MPI_INTEGER8, & idest, mpi_tag_data, p_comm_glb, p_err) sbuf(1:nsend) = pack(xlist2, msk2) @@ -457,17 +462,18 @@ SUBROUTINE mesh_build () deallocate (sbuf ) deallocate (ipt2 ) + deallocate (sbuf64) #else DO iy = 1, nyp DO ix = 1, nxp - ie = elist2(ix,iy) - IF (ie > 0) THEN + elmid = elist2(ix,iy) + IF (elmid > 0) THEN - CALL insert_into_sorted_list1 (ie, nelm, elist, iloc, is_new) + CALL insert_into_sorted_list1 (elmid, nelm, elist, iloc, is_new) - msk2 = (elist2 == ie) + msk2 = (elist2 == elmid) npxl = count(msk2) IF (is_new) THEN @@ -476,7 +482,7 @@ SUBROUTINE mesh_build () ENDIF iaddr(iloc) = nelm - meshtmp(iaddr(iloc))%indx = ie + meshtmp(iaddr(iloc))%indx = elmid meshtmp(iaddr(iloc))%npxl = npxl ELSE meshtmp(iaddr(iloc))%npxl = meshtmp(iaddr(iloc))%npxl + npxl @@ -535,7 +541,7 @@ SUBROUTINE mesh_build () allocate (elist_recv (nrecv)) ! recv(04) - CALL mpi_recv (elist_recv, nrecv, MPI_INTEGER, & + CALL mpi_recv (elist_recv, nrecv, MPI_INTEGER8, & isrc, mpi_tag_data, p_comm_glb, p_stat, p_err) allocate (xlist_recv (nrecv)) @@ -552,13 +558,13 @@ SUBROUTINE mesh_build () DO irecv = 1, nrecv - ie = elist_recv(irecv) + elmid = elist_recv(irecv) - IF (ie > 0) THEN + IF (elmid > 0) THEN - CALL insert_into_sorted_list1 (ie, nelm, elist, iloc, is_new) + CALL insert_into_sorted_list1 (elmid, nelm, elist, iloc, is_new) - msk = (elist_recv == ie) + msk = (elist_recv == elmid) npxl = count(msk) IF (is_new) THEN @@ -567,7 +573,7 @@ SUBROUTINE mesh_build () ENDIF iaddr(iloc) = nelm - meshtmp(iaddr(iloc))%indx = ie + meshtmp(iaddr(iloc))%indx = elmid meshtmp(iaddr(iloc))%npxl = npxl ELSE meshtmp(iaddr(iloc))%npxl = meshtmp(iaddr(iloc))%npxl + npxl @@ -686,12 +692,17 @@ SUBROUTINE mesh_build () idest = gblock%pio (meshtmp(ie)%xblk, meshtmp(ie)%yblk) - smesg(1) = p_iam_glb - smesg(2:3) = (/meshtmp(ie)%indx, meshtmp(ie)%npxl/) - smesg(4:5) = (/meshtmp(ie)%xblk, meshtmp(ie)%yblk/) - ! send(09) - CALL mpi_send (smesg(1:5), 5, MPI_INTEGER, & + ! send(09-1) + CALL mpi_send (p_iam_glb, 1, MPI_INTEGER, & + idest, mpi_tag_mesg, p_comm_glb, p_err) + ! send(09-2) + CALL mpi_send (meshtmp(ie)%indx, 1, MPI_INTEGER8, & + idest, mpi_tag_mesg, p_comm_glb, p_err) + ! send(09-3) + smesg(1:3) = (/meshtmp(ie)%xblk, meshtmp(ie)%yblk, meshtmp(ie)%npxl/) + CALL mpi_send (smesg(1:3), 3, MPI_INTEGER, & idest, mpi_tag_mesg, p_comm_glb, p_err) + ! send(10) CALL mpi_send (meshtmp(ie)%ilon, meshtmp(ie)%npxl, MPI_INTEGER, & idest, mpi_tag_data, p_comm_glb, p_err) @@ -713,21 +724,26 @@ SUBROUTINE mesh_build () blkcnt(:,:) = 0 DO ie = 1, numelm - ! recv(09) - CALL mpi_recv (rmesg, 5, MPI_INTEGER, & + ! recv(09-1) + CALL mpi_recv (isrc, 1, MPI_INTEGER, & MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err) + ! recv(09-2) + CALL mpi_recv (elmid, 1, MPI_INTEGER8, & + isrc, mpi_tag_mesg, p_comm_glb, p_stat, p_err) + ! recv(09-3) + CALL mpi_recv (rmesg(1:3), 3, MPI_INTEGER, & + isrc, mpi_tag_mesg, p_comm_glb, p_stat, p_err) - isrc = rmesg(1) - xblk = rmesg(4) - yblk = rmesg(5) + xblk = rmesg(1) + yblk = rmesg(2) blkcnt(xblk,yblk) = blkcnt(xblk,yblk) + 1 je = blkdsp(xblk,yblk) + blkcnt(xblk,yblk) - mesh(je)%indx = rmesg(2) + mesh(je)%indx = elmid + mesh(je)%xblk = rmesg(1) + mesh(je)%yblk = rmesg(2) mesh(je)%npxl = rmesg(3) - mesh(je)%xblk = rmesg(4) - mesh(je)%yblk = rmesg(5) allocate (mesh(je)%ilon (mesh(je)%npxl)) allocate (mesh(je)%ilat (mesh(je)%npxl)) @@ -803,6 +819,9 @@ SUBROUTINE mesh_build () DO ie = 1, blkcnt(iblk,jblk) CALL copy_elm (meshtmp(blkdsp(iblk,jblk)+order(ie)), & mesh(blkdsp(iblk,jblk)+ie)) +#ifdef GRIDBASED + ! mesh(blkdsp(iblk,jblk)+ie)%indx = ie +#endif ENDDO deallocate (elmindx) @@ -905,9 +924,10 @@ SUBROUTINE scatter_mesh_from_io_to_worker DO ie = ndsp+1, ndsp+nsend idest = iproc - smesg(1:2) = (/mesh(ie)%indx, mesh(ie)%npxl/) - smesg(3:4) = (/mesh(ie)%xblk, mesh(ie)%yblk/) - CALL mpi_send (smesg(1:4), 4, MPI_INTEGER, & + CALL mpi_send (mesh(ie)%indx, 1, MPI_INTEGER8, & + idest, mpi_tag_mesg, p_comm_group, p_err) + smesg(1:3) = (/mesh(ie)%xblk, mesh(ie)%yblk, mesh(ie)%npxl/) + CALL mpi_send (smesg(1:3), 3, MPI_INTEGER, & idest, mpi_tag_mesg, p_comm_group, p_err) CALL mpi_send (mesh(ie)%ilon, mesh(ie)%npxl, & MPI_INTEGER, idest, mpi_tag_data, p_comm_group, p_err) @@ -929,13 +949,14 @@ SUBROUTINE scatter_mesh_from_io_to_worker allocate (mesh (numelm)) DO ie = 1, numelm - CALL mpi_recv (rmesg, 4, MPI_INTEGER, & + CALL mpi_recv (mesh(ie)%indx, 1, MPI_INTEGER8, & + p_root, mpi_tag_mesg, p_comm_group, p_stat, p_err) + CALL mpi_recv (rmesg, 3, MPI_INTEGER, & p_root, mpi_tag_mesg, p_comm_group, p_stat, p_err) - mesh(ie)%indx = rmesg(1) - mesh(ie)%npxl = rmesg(2) - mesh(ie)%xblk = rmesg(3) - mesh(ie)%yblk = rmesg(4) + mesh(ie)%xblk = rmesg(1) + mesh(ie)%yblk = rmesg(2) + mesh(ie)%npxl = rmesg(3) allocate (mesh(ie)%ilon (mesh(ie)%npxl)) allocate (mesh(ie)%ilat (mesh(ie)%npxl)) diff --git a/share/MOD_Namelist.F90 b/share/MOD_Namelist.F90 index 6cd8477a..769487c2 100644 --- a/share/MOD_Namelist.F90 +++ b/share/MOD_Namelist.F90 @@ -32,21 +32,24 @@ MODULE MOD_Namelist INTEGER :: DEF_PIO_groupsize = 12 ! ----- For Single Point ----- -#ifdef SinglePoint - - CHARACTER(len=256) :: SITE_fsrfdata = 'null' - - LOGICAL :: USE_SITE_pctpfts = .true. - LOGICAL :: USE_SITE_pctcrop = .true. - LOGICAL :: USE_SITE_htop = .true. - LOGICAL :: USE_SITE_LAI = .true. - LOGICAL :: USE_SITE_lakedepth = .true. - LOGICAL :: USE_SITE_soilreflectance = .true. - LOGICAL :: USE_SITE_soilparameters = .true. - LOGICAL :: USE_SITE_dbedrock = .true. - LOGICAL :: USE_SITE_topography = .true. - logical :: USE_SITE_HistWriteBack = .true. -#endif + + CHARACTER(len=256) :: SITE_fsrfdata = 'null' + + LOGICAL :: USE_SITE_pctpfts = .true. + LOGICAL :: USE_SITE_pctcrop = .true. + LOGICAL :: USE_SITE_htop = .true. + LOGICAL :: USE_SITE_LAI = .true. + LOGICAL :: USE_SITE_lakedepth = .true. + LOGICAL :: USE_SITE_soilreflectance = .true. + LOGICAL :: USE_SITE_soilparameters = .true. + LOGICAL :: USE_SITE_dbedrock = .true. + LOGICAL :: USE_SITE_topography = .true. + logical :: USE_SITE_HistWriteBack = .true. + logical :: USE_SITE_ForcingReadAhead = .true. + LOGICAL :: USE_SITE_urban_paras = .true. + LOGICAL :: USE_SITE_thermal_paras = .false. + LOGICAL :: USE_SITE_urban_LAI = .false. + ! ----- simulation time type ----- TYPE nl_simulation_time_type @@ -64,7 +67,7 @@ MODULE MOD_Namelist INTEGER :: spinup_day = 1 INTEGER :: spinup_sec = 0 INTEGER :: spinup_repeat = 1 - REAL(r8) :: timestep = 3600. + REAL(r8) :: timestep = 1800. END TYPE nl_simulation_time_type TYPE (nl_simulation_time_type) :: DEF_simulation_time @@ -95,18 +98,39 @@ MODULE MOD_Namelist ! only available for USGS/IGBP/PFT CLASSIFICATION LOGICAL :: USE_srfdata_from_3D_gridded_data = .false. + ! ----- Subgrid scheme ----- + logical :: DEF_USE_USGS = .false. + logical :: DEF_USE_IGBP = .false. + logical :: DEF_USE_LCT = .false. + logical :: DEF_USE_PFT = .false. + logical :: DEF_USE_PC = .false. + logical :: DEF_SOLO_PFT = .false. + logical :: DEF_FAST_PC = .false. + CHARACTER(len=256) :: DEF_SUBGRID_SCHEME = 'LCT' + + ! ----- compress data in aggregation when send data from IO to worker ----- + logical :: USE_zip_for_aggregation = .true. + ! ----- Leaf Area Index ----- !add by zhongwang wei @ sysu 2021/12/23 !To allow read satellite observed LAI ! 06/2023, note by hua yuan: change DEF_LAI_CLIM to DEF_LAI_MONTHLY logical :: DEF_LAI_MONTHLY = .true. - INTEGER :: DEF_Interception_scheme = 1 !1:CoLM；2:CLM4.5; 3:CLM5; 4:Noah-MP; 5:MATSIRO; 6:VIC + ! ----- Atmospheric Nitrogen Deposition ----- + !add by Fang Shang @ pku 2023/08 + !1: To allow annuaul ndep data to be read in + !2: To allow monthly ndep data to be read in + INTEGER :: DEF_NDEP_FREQUENCY = 1 + INTEGER :: DEF_Interception_scheme = 1 !1:CoLM；2:CLM4.5; 3:CLM5; 4:Noah-MP; 5:MATSIRO; 6:VIC; 7:JULES ! ------LAI change and Land cover year setting ---------- ! 06/2023, add by wenzong dong and hua yuan: use for updating LAI with simulation year LOGICAL :: DEF_LAI_CHANGE_YEARLY = .true. ! 05/2023, add by Xingjie Lu: use for updating LAI with leaf carbon - LOGICAL :: DEF_USE_LAIFEEDBACK = .true. + LOGICAL :: DEF_USE_LAIFEEDBACK = .false. + + ! use irrigation + LOGICAL :: DEF_USE_IRRIGATION = .false. ! 06/2023, add by hua yuan and wenzong dong ! ------ Land use and land cover (LULC) related ------- @@ -116,11 +140,15 @@ MODULE MOD_Namelist ! Options for LULCC year-to-year transfer schemes ! 1: Same Type Assignment scheme (STA), state variables assignment for the same TYPE (LC, PFT or PC) - ! 2: Energy and Mass Conservation scheme (EMC), DO energy and mass conservation calculation + ! 2: Mass and Energy Conservation scheme (MEC), DO mass and energy conservation calculation INTEGER :: DEF_LULCC_SCHEME = 1 ! ------ Urban model related ------- - !INTEGER :: DEF_URBAN_type_scheme = 1 + ! Options for urban type scheme + ! 1: NCAR Urban Classification, 3 urban type with Tall Building, High Density and Medium Density + ! 2: LCZ Classification, 10 urban type with LCZ 1-10 + INTEGER :: DEF_URBAN_type_scheme = 1 + LOGICAL :: DEF_URBAN_ONLY = .false. logical :: DEF_URBAN_RUN = .false. LOGICAL :: DEF_URBAN_BEM = .true. LOGICAL :: DEF_URBAN_TREE = .true. @@ -147,16 +175,32 @@ MODULE MOD_Namelist ! 2: Read a global soil color map from CLM INTEGER :: DEF_SOIL_REFL_SCHEME = 2 + ! Options for soil surface resistance schemes + ! 0: NONE soil surface resistance + ! 1: SL14, Swenson and Lawrence (2014) + ! 2: SZ09, Sakaguchi and Zeng (2009) + ! 3: TR13, Tang and Riley (2013) + ! 4: LP92, Lee and Pielke (1992) + ! 5: S92, Sellers et al (1992) + INTEGER :: DEF_RSS_SCHEME = 1 + + + ! Treat exposed soil and snow surface separatly, including + ! solar absorption, sensible/latent heat, ground temperature, + ! ground heat flux and groud evp/dew/subl/fros. + ! Corresponding vars are named as ***_soil, ***_snow. + logical :: DEF_SPLIT_SOILSNOW = .false. + ! ----- Model settings ----- - LOGICAL :: DEF_LANDONLY = .true. - LOGICAL :: DEF_USE_DOMINANT_PATCHTYPE = .false. - LOGICAL :: DEF_USE_VARIABLY_SATURATED_FLOW = .true. - LOGICAL :: DEF_USE_BEDROCK = .false. - LOGICAL :: DEF_USE_OZONESTRESS = .false. - LOGICAL :: DEF_USE_OZONEDATA = .false. + LOGICAL :: DEF_LANDONLY = .true. + LOGICAL :: DEF_USE_DOMINANT_PATCHTYPE = .false. + LOGICAL :: DEF_USE_VariablySaturatedFlow = .true. + LOGICAL :: DEF_USE_BEDROCK = .false. + LOGICAL :: DEF_USE_OZONESTRESS = .false. + LOGICAL :: DEF_USE_OZONEDATA = .false. ! .true. for running SNICAR model - logical :: DEF_USE_SNICAR = .true. + logical :: DEF_USE_SNICAR = .false. ! .true. read aerosol deposition data from file or .false. set in the code logical :: DEF_Aerosol_Readin = .true. @@ -164,20 +208,34 @@ MODULE MOD_Namelist ! .true. Read aerosol deposition climatology data or .false. yearly changed logical :: DEF_Aerosol_Clim = .false. + ! ----- lateral flow related ----- + logical :: DEF_USE_EstimatedRiverDepth = .true. + CHARACTER(len=5) :: DEF_precip_phase_discrimination_scheme = 'II' CHARACTER(len=256) :: DEF_SSP='585' ! Co2 path for CMIP6 future scenario. + ! ! irrigation method temporary + INTEGER :: DEF_IRRIGATION_METHOD = 1 + ! ----- Initialization ----- - LOGICAL :: DEF_USE_SOIL_INIT = .false. - CHARACTER(len=256) :: DEF_file_soil_init = 'null' + LOGICAL :: DEF_USE_SoilInit = .false. + CHARACTER(len=256) :: DEF_file_SoilInit = 'null' + + LOGICAL :: DEF_USE_SnowInit = .false. + CHARACTER(len=256) :: DEF_file_SnowInit = 'null' + + LOGICAL :: DEF_USE_CN_INIT = .false. + CHARACTER(len=256) :: DEF_file_cn_init = 'null' CHARACTER(len=256) :: DEF_file_snowoptics = 'null' CHARACTER(len=256) :: DEF_file_snowaging = 'null' + CHARACTER(len=256) :: DEF_ElementNeighbour_file = 'null' + ! ----- history ----- LOGICAL :: DEF_HISTORY_IN_VECTOR = .false. - LOGICAL :: DEF_hist_grid_as_forcing = .false. + LOGICAL :: DEF_hist_grid_as_forcing = .false. REAL(r8) :: DEF_hist_lon_res = 0.5 REAL(r8) :: DEF_hist_lat_res = 0.5 @@ -185,11 +243,15 @@ MODULE MOD_Namelist CHARACTER(len=256) :: DEF_HIST_FREQ = 'none' ! write history file frequency: TIMESTEP/HOURLY/DAILY/MONTHLY/YEARLY CHARACTER(len=256) :: DEF_HIST_groupby = 'MONTH' ! history file in one file: DAY/MONTH/YEAR CHARACTER(len=256) :: DEF_HIST_mode = 'one' + LOGICAL :: DEF_HIST_WriteBack = .false. INTEGER :: DEF_REST_COMPRESS_LEVEL = 1 INTEGER :: DEF_HIST_COMPRESS_LEVEL = 1 CHARACTER(len=256) :: DEF_hist_vars_namelist = 'null' - LOGICAL :: DEF_hist_vars_turnon_all = .true. + LOGICAL :: DEF_hist_vars_out_default = .true. + + ! ----- Data Assimilation ----- + character(len=256) :: DEF_DA_obsdir = 'null' ! ----- forcing ----- CHARACTER(len=256) :: DEF_forcing_namelist = 'null' @@ -209,6 +271,7 @@ MODULE MOD_Namelist LOGICAL :: regional = .false. REAL(r8) :: regbnd(4) = (/-90.0, 90.0, -180.0, 180.0/) LOGICAL :: has_missing_value = .false. + character(len=256) :: missing_value_name = 'missing_value' INTEGER :: NVAR = 8 ! variable number of forcing data INTEGER :: startyr = 2000 ! start year of forcing data @@ -258,6 +321,8 @@ MODULE MOD_Namelist LOGICAL :: DEF_USE_CBL_HEIGHT = .false. !Plant Hydraulics LOGICAL :: DEF_USE_PLANTHYDRAULICS = .true. + !Medlyn stomata model + LOGICAL :: DEF_USE_MEDLYNST = .false. !Semi-Analytic-Spin-Up LOGICAL :: DEF_USE_SASU = .false. !Punctuated nitrogen addition Spin up @@ -311,10 +376,15 @@ MODULE MOD_Namelist LOGICAL :: rsur = .true. LOGICAL :: rsub = .true. LOGICAL :: rnof = .true. + LOGICAL :: xwsur = .true. + LOGICAL :: xwsub = .true. LOGICAL :: qintr = .true. LOGICAL :: qinfl = .true. LOGICAL :: qdrip = .true. LOGICAL :: wat = .true. + LOGICAL :: wat_inst = .true. + LOGICAL :: wetwat = .true. + LOGICAL :: wetwat_inst = .true. LOGICAL :: assim = .true. LOGICAL :: respc = .true. LOGICAL :: qcharge = .true. @@ -334,6 +404,7 @@ MODULE MOD_Namelist LOGICAL :: emis = .true. LOGICAL :: z0m = .true. LOGICAL :: trad = .true. + LOGICAL :: rss = .true. LOGICAL :: tref = .true. LOGICAL :: qref = .true. #ifdef URBAN_MODEL @@ -358,8 +429,8 @@ MODULE MOD_Namelist LOGICAL :: t_roof = .true. LOGICAL :: t_wall = .true. #endif - LOGICAL :: assimsun = .true. !1 - LOGICAL :: assimsha = .true. !1 + LOGICAL :: assimsun = .true. !1 + LOGICAL :: assimsha = .true. !1 LOGICAL :: etrsun = .true. !1 LOGICAL :: etrsha = .true. !1 #ifdef BGC @@ -511,6 +582,20 @@ MODULE MOD_Namelist LOGICAL :: fertnitro_rice1 = .true. LOGICAL :: fertnitro_rice2 = .true. LOGICAL :: fertnitro_sugarcane= .true. + LOGICAL :: irrig_method_corn = .true. + LOGICAL :: irrig_method_swheat = .true. + LOGICAL :: irrig_method_wwheat = .true. + LOGICAL :: irrig_method_soybean = .true. + LOGICAL :: irrig_method_cotton = .true. + LOGICAL :: irrig_method_rice1 = .true. + LOGICAL :: irrig_method_rice2 = .true. + LOGICAL :: irrig_method_sugarcane= .true. + + LOGICAL :: irrig_rate = .true. + LOGICAL :: deficit_irrig = .true. + LOGICAL :: sum_irrig = .true. + LOGICAL :: sum_irrig_count = .true. + #endif LOGICAL :: ndep_to_sminn = .true. LOGICAL :: CONC_O2_UNSAT = .true. @@ -537,8 +622,10 @@ MODULE MOD_Namelist LOGICAL :: wfc = .true. LOGICAL :: OM_density = .true. LOGICAL :: wdsrf = .true. + LOGICAL :: wdsrf_inst = .true. LOGICAL :: zwt = .true. LOGICAL :: wa = .true. + LOGICAL :: wa_inst = .true. LOGICAL :: t_lake = .true. LOGICAL :: lake_icefrac = .true. @@ -592,10 +679,11 @@ MODULE MOD_Namelist LOGICAL :: srndln = .true. LOGICAL :: srniln = .true. - LOGICAL :: rsubs_bsn = .true. - LOGICAL :: rsubs_hru = .true. + LOGICAL :: xsubs_bsn = .true. + LOGICAL :: xsubs_hru = .true. LOGICAL :: riv_height = .true. LOGICAL :: riv_veloct = .true. + LOGICAL :: discharge = .true. LOGICAL :: wdsrf_hru = .true. LOGICAL :: veloc_hru = .true. @@ -632,6 +720,10 @@ SUBROUTINE read_namelist (nlfile) USE_SITE_dbedrock, & USE_SITE_topography, & USE_SITE_HistWriteBack, & + USE_SITE_ForcingReadAhead,& + USE_SITE_urban_paras, & + USE_SITE_thermal_paras, & + USE_SITE_urban_LAI, & #endif DEF_nx_blocks, & DEF_ny_blocks, & @@ -648,17 +740,28 @@ SUBROUTINE read_namelist (nlfile) #endif DEF_file_mesh_filter, & + DEF_USE_LCT, & + DEF_USE_PFT, & + DEF_USE_PC, & + DEF_FAST_PC, & + DEF_SOLO_PFT, & + DEF_SUBGRID_SCHEME, & + DEF_LAI_MONTHLY, & !add by zhongwang wei @ sysu 2021/12/23 + DEF_NDEP_FREQUENCY, & !add by Fang Shang @ pku 2023/08 DEF_Interception_scheme, & !add by zhongwang wei @ sysu 2022/05/23 DEF_SSP, & !add by zhongwang wei @ sysu 2023/02/07 DEF_LAI_CHANGE_YEARLY, & DEF_USE_LAIFEEDBACK, & !add by Xingjie Lu, use for updating LAI with leaf carbon + DEF_USE_IRRIGATION, & ! use irrigation + DEF_IRRIGATION_METHOD, & ! use irrigation temporary DEF_LC_YEAR, & DEF_LULCC_SCHEME, & - !DEF_URBAN_type_scheme, & + DEF_URBAN_type_scheme, & + DEF_URBAN_ONLY, & DEF_URBAN_RUN, & !add by hua yuan, open urban model or not DEF_URBAN_BEM, & !add by hua yuan, open urban BEM model or not DEF_URBAN_TREE, & !add by hua yuan, modeling urban tree or not @@ -669,13 +772,17 @@ SUBROUTINE read_namelist (nlfile) DEF_THERMAL_CONDUCTIVITY_SCHEME, & DEF_USE_SUPERCOOL_WATER, & DEF_SOIL_REFL_SCHEME, & + DEF_RSS_SCHEME, & + DEF_SPLIT_SOILSNOW, & DEF_dir_existing_srfdata, & USE_srfdata_from_larger_region, & USE_srfdata_from_3D_gridded_data,& + USE_zip_for_aggregation, & DEF_USE_CBL_HEIGHT, & !add by zhongwang wei @ sysu 2022/12/31 DEF_USE_PLANTHYDRAULICS, & !add by xingjie lu @ sysu 2023/05/28 + DEF_USE_MEDLYNST, & !add by xingjie lu @ sysu 2023/05/28 DEF_USE_SASU, & !add by Xingjie Lu @ sysu 2023/06/27 DEF_USE_PN, & !add by Xingjie Lu @ sysu 2023/06/27 DEF_USE_FERT, & !add by Xingjie Lu @ sysu 2023/06/27 @@ -685,22 +792,33 @@ SUBROUTINE read_namelist (nlfile) DEF_LANDONLY, & DEF_USE_DOMINANT_PATCHTYPE, & - DEF_USE_VARIABLY_SATURATED_FLOW, & + DEF_USE_VariablySaturatedFlow, & DEF_USE_BEDROCK, & DEF_USE_OZONESTRESS, & DEF_USE_OZONEDATA, & DEF_USE_SNICAR, & DEF_Aerosol_Readin, & DEF_Aerosol_Clim, & + DEF_USE_EstimatedRiverDepth, & DEF_precip_phase_discrimination_scheme, & - DEF_USE_SOIL_INIT, & - DEF_file_soil_init, & + DEF_USE_SoilInit, & + DEF_file_SoilInit, & + + DEF_USE_SnowInit, & + DEF_file_SnowInit, & + + DEF_USE_CN_INIT, & + DEF_file_cn_init, & DEF_file_snowoptics, & DEF_file_snowaging , & + DEF_ElementNeighbour_file, & + + DEF_DA_obsdir, & + DEF_forcing_namelist, & DEF_USE_Forcing_Downscaling, & @@ -715,10 +833,11 @@ SUBROUTINE read_namelist (nlfile) DEF_HIST_FREQ, & DEF_HIST_groupby, & DEF_HIST_mode, & + DEF_HIST_WriteBack, & DEF_REST_COMPRESS_LEVEL, & DEF_HIST_COMPRESS_LEVEL, & DEF_hist_vars_namelist, & - DEF_hist_vars_turnon_all + DEF_hist_vars_out_default namelist /nl_colm_forcing/ DEF_dir_forcing, DEF_forcing namelist /nl_colm_history/ DEF_hist_vars @@ -729,19 +848,14 @@ SUBROUTINE read_namelist (nlfile) open(10, status='OLD', file=nlfile, form="FORMATTED") read(10, nml=nl_colm, iostat=ierr) IF (ierr /= 0) THEN - write(*,*) ' ***** ERROR: Problem reading namelist.' - write(*,*) trim(nlfile), ierr -#ifdef USEMPI - CALL mpi_abort (p_comm_glb, p_err) -#endif + CALL CoLM_Stop (' ***** ERROR: Problem reading namelist: '// trim(nlfile)) ENDIF close(10) open(10, status='OLD', file=trim(DEF_forcing_namelist), form="FORMATTED") read(10, nml=nl_colm_forcing, iostat=ierr) IF (ierr /= 0) THEN - write(*,*) ' ***** ERROR: Problem reading forcing namelist.' - write(*,*) trim(DEF_forcing_namelist), ierr + CALL CoLM_Stop (' ***** ERROR: Problem reading namelist: '// trim(DEF_forcing_namelist)) ENDIF close(10) #ifdef SinglePoint @@ -772,14 +886,42 @@ SUBROUTINE read_namelist (nlfile) ! ----- SOIL model related ------ Macros&Namelist conflicts and dependency management #if (defined vanGenuchten_Mualem_SOIL_MODEL) write(*,*) ' ***** ' - write(*,*) 'Note: DEF_USE_VARIABLY_SATURATED_FLOW is automaticlly set to .true. ' + write(*,*) 'Note: DEF_USE_VariablySaturatedFlow is automaticlly set to .true. ' write(*,*) 'when using vanGenuchten_Mualem_SOIL_MODEL. ' - DEF_USE_VARIABLY_SATURATED_FLOW = .true. + DEF_USE_VariablySaturatedFlow = .true. +#endif +#if (defined CatchLateralFlow) + write(*,*) ' ***** ' + write(*,*) 'Note: DEF_USE_VariablySaturatedFlow is automaticlly set to .true. ' + write(*,*) 'when defined CatchLateralFlow. ' + DEF_USE_VariablySaturatedFlow = .true. #endif ! ----- subgrid type related ------ Macros&Namelist conflicts and dependency management +#if (defined LULC_USGS || defined LULC_IGBP) + DEF_USE_LCT = .true. + DEF_USE_PFT = .false. + DEF_USE_PC = .false. + DEF_FAST_PC = .false. + DEF_SOLO_PFT = .false. +#endif + +#ifdef LULC_IGBP_PFT + DEF_USE_LCT = .false. + DEF_USE_PFT = .true. + DEF_USE_PC = .false. + DEF_FAST_PC = .false. +#endif + +#ifdef LULC_IGBP_PC + DEF_USE_LCT = .false. + DEF_USE_PFT = .false. + DEF_USE_PC = .true. + DEF_SOLO_PFT = .false. +#endif + #if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) IF (.not.DEF_LAI_MONTHLY) THEN write(*,*) ' ***** ' @@ -844,6 +986,13 @@ SUBROUTINE read_namelist (nlfile) write(*,*) 'Warning: Soy nitrogen fixation is on when CROP is off.' write(*,*) 'DEF_USE_CNSOYFIXN is set to false automatically when CROP is turned off.' ENDIF + + if(DEF_USE_IRRIGATION)then + DEF_USE_IRRIGATION = .false. + write(*,*) ' ***** ' + write(*,*) 'Warning: irrigation is on when CROP is off.' + write(*,*) 'DEF_USE_IRRIGATION is set to false automatically when CROP is turned off.' + ENDIF #endif IF(.not. DEF_USE_OZONESTRESS)then @@ -898,7 +1047,7 @@ SUBROUTINE read_namelist (nlfile) #if (defined LULC_USGS || defined BGC) write(*,*) ' ***** ' write(*,*) 'Fatal ERROR: LULCC is not supported for LULC_USGS/BGC at present. STOP! ' - STOP + CALL CoLM_stop () #endif IF (.not.DEF_LAI_MONTHLY) THEN write(*,*) ' ***** ' @@ -915,17 +1064,35 @@ SUBROUTINE read_namelist (nlfile) ENDIF #if (defined LULC_IGBP_PC || defined URBAN) + !write(*,*) ' ***** ' + !write(*,*) 'Fatal ERROR: LULCC is not supported for LULC_IGBP_PC/URBAN at present. STOP! ' + !write(*,*) 'It is coming soon. ' + ![update] 24/10/2023: right now IGBP/PFT/PC and Urban are all supported. + !CALL CoLM_stop () +#endif + +#if (defined SinglePoint) write(*,*) ' ***** ' - write(*,*) 'Fatal ERROR: LULCC is not supported for LULC_IGBP_PC/URBAN at present. STOP! ' - write(*,*) 'It is coming soon. ' - STOP + write(*,*) 'Fatal ERROR: LULCC is not supported for Single Point run at present. STOP! ' + write(*,*) 'It will come later. ' + CALL CoLM_stop () #endif #endif -! ----- [Complement IF needed] ----- Macros&Namelist conflicts and dependency management +! ----- single point run ----- Macros&Namelist conflicts and dependency management +#if (defined SinglePoint) +#ifdef SrfdataDiag + write(*,*) ' ***** ' + write(*,*) 'Surface data diagnose is closed in SinglePoint case.' +#undef SrfdataDiag +#endif +#endif + + +! ----- [Complement IF needed] ----- Macros&Namelist conflicts and dependency management ! -----END Macros&Namelist conflicts and dependency management ----- @@ -964,7 +1131,7 @@ SUBROUTINE read_namelist (nlfile) CALL mpi_bcast (DEF_simulation_time%spinup_sec, 1, mpi_integer, p_root, p_comm_glb, p_err) CALL mpi_bcast (DEF_simulation_time%spinup_repeat, 1, mpi_integer, p_root, p_comm_glb, p_err) - CALL mpi_bcast (DEF_simulation_time%timestep, 1, mpi_real8, p_root, p_comm_glb, p_err) + CALL mpi_bcast (DEF_simulation_time%timestep, 1, mpi_real8, p_root, p_comm_glb, p_err) CALL mpi_bcast (DEF_dir_rawdata, 256, mpi_character, p_root, p_comm_glb, p_err) CALL mpi_bcast (DEF_dir_runtime, 256, mpi_character, p_root, p_comm_glb, p_err) @@ -977,36 +1144,50 @@ SUBROUTINE read_namelist (nlfile) #if (defined GRIDBASED || defined UNSTRUCTURED) CALL mpi_bcast (DEF_file_mesh, 256, mpi_character, p_root, p_comm_glb, p_err) - CALL mpi_bcast (DEF_GRIDBASED_lon_res, 1, mpi_real8, p_root, p_comm_glb, p_err) - CALL mpi_bcast (DEF_GRIDBASED_lat_res, 1, mpi_real8, p_root, p_comm_glb, p_err) + CALL mpi_bcast (DEF_GRIDBASED_lon_res, 1, mpi_real8, p_root, p_comm_glb, p_err) + CALL mpi_bcast (DEF_GRIDBASED_lat_res, 1, mpi_real8, p_root, p_comm_glb, p_err) #endif #ifdef CATCHMENT CALL mpi_bcast (DEF_CatchmentMesh_data, 256, mpi_character, p_root, p_comm_glb, p_err) #endif - CALL mpi_bcast (DEF_file_mesh_filter, 256, mpi_character, p_root, p_comm_glb, p_err) + CALL mpi_bcast (DEF_file_mesh_filter, 256, mpi_character, p_root, p_comm_glb, p_err) - CALL mpi_bcast (DEF_dir_existing_srfdata, 256, mpi_character, p_root, p_comm_glb, p_err) + CALL mpi_bcast (DEF_dir_existing_srfdata, 256, mpi_character, p_root, p_comm_glb, p_err) call mpi_bcast (USE_srfdata_from_larger_region, 1, mpi_logical, p_root, p_comm_glb, p_err) call mpi_bcast (USE_srfdata_from_3D_gridded_data, 1, mpi_logical, p_root, p_comm_glb, p_err) + call mpi_bcast (USE_zip_for_aggregation, 1, mpi_logical, p_root, p_comm_glb, p_err) - CALL mpi_bcast (DEF_LAI_CHANGE_YEARLY, 1, mpi_logical, p_root, p_comm_glb, p_err) + ! 07/2023, added by yuan: subgrid setting related + CALL mpi_bcast (DEF_USE_LCT, 1, mpi_logical, p_root, p_comm_glb, p_err) + CALL mpi_bcast (DEF_USE_PFT, 1, mpi_logical, p_root, p_comm_glb, p_err) + CALL mpi_bcast (DEF_USE_PC, 1, mpi_logical, p_root, p_comm_glb, p_err) + CALL mpi_bcast (DEF_FAST_PC, 1, mpi_logical, p_root, p_comm_glb, p_err) + CALL mpi_bcast (DEF_SOLO_PFT, 1, mpi_logical, p_root, p_comm_glb, p_err) + CALL mpi_bcast (DEF_SUBGRID_SCHEME, 256, mpi_character, p_root, p_comm_glb, p_err) + + CALL mpi_bcast (DEF_LAI_CHANGE_YEARLY, 1, mpi_logical, p_root, p_comm_glb, p_err) ! 05/2023, added by Xingjie lu - CALL mpi_bcast (DEF_USE_LAIFEEDBACK, 1, mpi_logical, p_root, p_comm_glb, p_err) + CALL mpi_bcast (DEF_USE_LAIFEEDBACK, 1, mpi_logical, p_root, p_comm_glb, p_err) + CALL mpi_bcast (DEF_USE_IRRIGATION , 1, mpi_logical, p_root, p_comm_glb, p_err) + + ! use irrigation temporary + ! CALL mpi_bcast (DEF_IRRIGATION_METHOD, 1, mpi_logical, p_root, p_comm_glb, p_err) ! LULC related - CALL mpi_bcast (DEF_LC_YEAR, 1, mpi_integer, p_root, p_comm_glb, p_err) - CALL mpi_bcast (DEF_LULCC_SCHEME, 1, mpi_integer, p_root, p_comm_glb, p_err) + CALL mpi_bcast (DEF_LC_YEAR, 1, mpi_integer, p_root, p_comm_glb, p_err) + CALL mpi_bcast (DEF_LULCC_SCHEME, 1, mpi_integer, p_root, p_comm_glb, p_err) - !CALL mpi_bcast (DEF_URBAN_type_scheme, 1, mpi_integer, p_root, p_comm_glb, p_err) + CALL mpi_bcast (DEF_URBAN_type_scheme, 1, mpi_integer, p_root, p_comm_glb, p_err) ! 05/2023, added by yuan - CALL mpi_bcast (DEF_URBAN_RUN, 1, mpi_logical, p_root, p_comm_glb, p_err) - CALL mpi_bcast (DEF_URBAN_BEM, 1, mpi_logical, p_root, p_comm_glb, p_err) - CALL mpi_bcast (DEF_URBAN_TREE, 1, mpi_logical, p_root, p_comm_glb, p_err) - CALL mpi_bcast (DEF_URBAN_WATER, 1, mpi_logical, p_root, p_comm_glb, p_err) - CALL mpi_bcast (DEF_URBAN_LUCY, 1, mpi_logical, p_root, p_comm_glb, p_err) + CALL mpi_bcast (DEF_URBAN_ONLY, 1, mpi_logical, p_root, p_comm_glb, p_err) + CALL mpi_bcast (DEF_URBAN_RUN, 1, mpi_logical, p_root, p_comm_glb, p_err) + CALL mpi_bcast (DEF_URBAN_BEM, 1, mpi_logical, p_root, p_comm_glb, p_err) + CALL mpi_bcast (DEF_URBAN_TREE, 1, mpi_logical, p_root, p_comm_glb, p_err) + CALL mpi_bcast (DEF_URBAN_WATER, 1, mpi_logical, p_root, p_comm_glb, p_err) + CALL mpi_bcast (DEF_URBAN_LUCY, 1, mpi_logical, p_root, p_comm_glb, p_err) ! 06/2023, added by weinan CALL mpi_bcast (DEF_USE_SOILPAR_UPS_FIT, 1, mpi_logical, p_root, p_comm_glb, p_err) @@ -1015,39 +1196,57 @@ SUBROUTINE read_namelist (nlfile) ! 06/2023, added by hua yuan CALL mpi_bcast (DEF_SOIL_REFL_SCHEME, 1, mpi_integer, p_root, p_comm_glb, p_err) + ! 07/2023, added by zhuo liu + CALL mpi_bcast (DEF_RSS_SCHEME, 1, mpi_integer, p_root, p_comm_glb, p_err) + ! 08/2023, added by hua yuan + CALL mpi_bcast (DEF_SPLIT_SOILSNOW, 1, mpi_logical, p_root, p_comm_glb, p_err) call mpi_bcast (DEF_LAI_MONTHLY, 1, mpi_logical, p_root, p_comm_glb, p_err) + call mpi_bcast (DEF_NDEP_FREQUENCY, 1, mpi_integer, p_root, p_comm_glb, p_err) call mpi_bcast (DEF_Interception_scheme, 1, mpi_integer, p_root, p_comm_glb, p_err) - call mpi_bcast (DEF_SSP, 256, mpi_character, p_root, p_comm_glb, p_err) + call mpi_bcast (DEF_SSP, 256, mpi_character, p_root, p_comm_glb, p_err) - call mpi_bcast (DEF_USE_CBL_HEIGHT, 1, mpi_logical, p_root, p_comm_glb, p_err) + call mpi_bcast (DEF_USE_CBL_HEIGHT , 1, mpi_logical, p_root, p_comm_glb, p_err) call mpi_bcast (DEF_USE_PLANTHYDRAULICS, 1, mpi_logical, p_root, p_comm_glb, p_err) - call mpi_bcast (DEF_USE_SASU, 1, mpi_logical, p_root, p_comm_glb, p_err) - call mpi_bcast (DEF_USE_PN, 1, mpi_logical, p_root, p_comm_glb, p_err) - call mpi_bcast (DEF_USE_FERT, 1, mpi_logical, p_root, p_comm_glb, p_err) - call mpi_bcast (DEF_USE_NITRIF, 1, mpi_logical, p_root, p_comm_glb, p_err) - call mpi_bcast (DEF_USE_CNSOYFIXN, 1, mpi_logical, p_root, p_comm_glb, p_err) - call mpi_bcast (DEF_USE_FIRE, 1, mpi_logical, p_root, p_comm_glb, p_err) - - call mpi_bcast (DEF_LANDONLY, 1, mpi_logical, p_root, p_comm_glb, p_err) - call mpi_bcast (DEF_USE_DOMINANT_PATCHTYPE, 1, mpi_logical, p_root, p_comm_glb, p_err) - call mpi_bcast (DEF_USE_VARIABLY_SATURATED_FLOW,1, mpi_logical, p_root, p_comm_glb, p_err) - call mpi_bcast (DEF_USE_BEDROCK ,1, mpi_logical, p_root, p_comm_glb, p_err) - call mpi_bcast (DEF_USE_OZONESTRESS ,1, mpi_logical, p_root, p_comm_glb, p_err) - call mpi_bcast (DEF_USE_OZONEDATA ,1, mpi_logical, p_root, p_comm_glb, p_err) + call mpi_bcast (DEF_USE_MEDLYNST , 1, mpi_logical, p_root, p_comm_glb, p_err) + call mpi_bcast (DEF_USE_SASU , 1, mpi_logical, p_root, p_comm_glb, p_err) + call mpi_bcast (DEF_USE_PN , 1, mpi_logical, p_root, p_comm_glb, p_err) + call mpi_bcast (DEF_USE_FERT , 1, mpi_logical, p_root, p_comm_glb, p_err) + call mpi_bcast (DEF_USE_NITRIF , 1, mpi_logical, p_root, p_comm_glb, p_err) + call mpi_bcast (DEF_USE_CNSOYFIXN , 1, mpi_logical, p_root, p_comm_glb, p_err) + call mpi_bcast (DEF_USE_FIRE , 1, mpi_logical, p_root, p_comm_glb, p_err) + + call mpi_bcast (DEF_LANDONLY , 1, mpi_logical, p_root, p_comm_glb, p_err) + call mpi_bcast (DEF_USE_DOMINANT_PATCHTYPE , 1, mpi_logical, p_root, p_comm_glb, p_err) + call mpi_bcast (DEF_USE_VariablySaturatedFlow, 1, mpi_logical, p_root, p_comm_glb, p_err) + call mpi_bcast (DEF_USE_BEDROCK , 1, mpi_logical, p_root, p_comm_glb, p_err) + call mpi_bcast (DEF_USE_OZONESTRESS , 1, mpi_logical, p_root, p_comm_glb, p_err) + call mpi_bcast (DEF_USE_OZONEDATA , 1, mpi_logical, p_root, p_comm_glb, p_err) CALL mpi_bcast (DEF_precip_phase_discrimination_scheme, 5, mpi_character, p_root, p_comm_glb, p_err) - call mpi_bcast (DEF_USE_SOIL_INIT, 1, mpi_logical, p_root, p_comm_glb, p_err) - CALL mpi_bcast (DEF_file_soil_init, 256, mpi_character, p_root, p_comm_glb, p_err) + call mpi_bcast (DEF_USE_SoilInit, 1, mpi_logical, p_root, p_comm_glb, p_err) + CALL mpi_bcast (DEF_file_SoilInit, 256, mpi_character, p_root, p_comm_glb, p_err) + + call mpi_bcast (DEF_USE_SnowInit, 1, mpi_logical, p_root, p_comm_glb, p_err) + CALL mpi_bcast (DEF_file_SnowInit, 256, mpi_character, p_root, p_comm_glb, p_err) + + call mpi_bcast (DEF_USE_CN_INIT, 1, mpi_logical, p_root, p_comm_glb, p_err) + CALL mpi_bcast (DEF_file_cn_init, 256, mpi_character, p_root, p_comm_glb, p_err) call mpi_bcast (DEF_USE_SNICAR, 1, mpi_logical, p_root, p_comm_glb, p_err) CALL mpi_bcast (DEF_file_snowoptics, 256, mpi_character, p_root, p_comm_glb, p_err) CALL mpi_bcast (DEF_file_snowaging , 256, mpi_character, p_root, p_comm_glb, p_err) + + CALL mpi_bcast (DEF_ElementNeighbour_file, 256, mpi_character, p_root, p_comm_glb, p_err) + + CALL mpi_bcast (DEF_DA_obsdir , 256, mpi_character, p_root, p_comm_glb, p_err) call mpi_bcast (DEF_Aerosol_Readin, 1, mpi_logical, p_root, p_comm_glb, p_err) call mpi_bcast (DEF_Aerosol_Clim, 1, mpi_logical, p_root, p_comm_glb, p_err) + call mpi_bcast (DEF_USE_EstimatedRiverDepth, 1, mpi_logical, p_root, p_comm_glb, p_err) + CALL mpi_bcast (DEF_HISTORY_IN_VECTOR, 1, mpi_logical, p_root, p_comm_glb, p_err) CALL mpi_bcast (DEF_hist_lon_res, 1, mpi_real8, p_root, p_comm_glb, p_err) @@ -1059,6 +1258,7 @@ SUBROUTINE read_namelist (nlfile) CALL mpi_bcast (DEF_HIST_FREQ, 256, mpi_character, p_root, p_comm_glb, p_err) CALL mpi_bcast (DEF_HIST_groupby, 256, mpi_character, p_root, p_comm_glb, p_err) CALL mpi_bcast (DEF_HIST_mode, 256, mpi_character, p_root, p_comm_glb, p_err) + CALL mpi_bcast (DEF_HIST_WriteBack, 1, mpi_logical, p_root, p_comm_glb, p_err) CALL mpi_bcast (DEF_REST_COMPRESS_LEVEL, 1, mpi_integer, p_root, p_comm_glb, p_err) CALL mpi_bcast (DEF_HIST_COMPRESS_LEVEL, 1, mpi_integer, p_root, p_comm_glb, p_err) @@ -1074,6 +1274,7 @@ SUBROUTINE read_namelist (nlfile) CALL mpi_bcast (DEF_forcing%regional, 1, mpi_logical, p_root, p_comm_glb, p_err) CALL mpi_bcast (DEF_forcing%regbnd, 4, mpi_real8, p_root, p_comm_glb, p_err) CALL mpi_bcast (DEF_forcing%has_missing_value, 1, mpi_logical, p_root, p_comm_glb, p_err) + CALL mpi_bcast (DEF_forcing%missing_value_name,256,mpi_character, p_root, p_comm_glb, p_err) CALL mpi_bcast (DEF_forcing%NVAR, 1, mpi_integer, p_root, p_comm_glb, p_err) CALL mpi_bcast (DEF_forcing%startyr, 1, mpi_integer, p_root, p_comm_glb, p_err) CALL mpi_bcast (DEF_forcing%startmo, 1, mpi_integer, p_root, p_comm_glb, p_err) @@ -1099,9 +1300,6 @@ SUBROUTINE read_namelist (nlfile) call mpi_bcast (DEF_forcing%CBL_tintalgo, 256, mpi_character, p_root, p_comm_glb, p_err) CALL mpi_bcast (DEF_forcing%CBL_dtime, 1, mpi_integer, p_root, p_comm_glb, p_err) CALL mpi_bcast (DEF_forcing%CBL_offset, 1, mpi_integer, p_root, p_comm_glb, p_err) - - CALL mpi_bcast (DEF_file_snowoptics, 256, mpi_character, p_root, p_comm_glb, p_err) - CALL mpi_bcast (DEF_file_snowaging, 256, mpi_character, p_root, p_comm_glb, p_err) #endif CALL sync_hist_vars (set_defaults = .true.) @@ -1114,6 +1312,10 @@ SUBROUTINE read_namelist (nlfile) ELSE open(10, status='OLD', file=trim(DEF_hist_vars_namelist), form="FORMATTED") read(10, nml=nl_colm_history, iostat=ierr) + IF (ierr /= 0) THEN + CALL CoLM_Stop (' ***** ERROR: Problem reading namelist: ' & + // trim(DEF_hist_vars_namelist)) + ENDIF close(10) ENDIF @@ -1165,10 +1367,15 @@ SUBROUTINE sync_hist_vars (set_defaults) CALL sync_hist_vars_one (DEF_hist_vars%rsur , set_defaults) CALL sync_hist_vars_one (DEF_hist_vars%rsub , set_defaults) CALL sync_hist_vars_one (DEF_hist_vars%rnof , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%xwsur , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%xwsub , set_defaults) CALL sync_hist_vars_one (DEF_hist_vars%qintr , set_defaults) CALL sync_hist_vars_one (DEF_hist_vars%qinfl , set_defaults) CALL sync_hist_vars_one (DEF_hist_vars%qdrip , set_defaults) CALL sync_hist_vars_one (DEF_hist_vars%wat , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%wat_inst , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%wetwat , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%wetwat_inst , set_defaults) CALL sync_hist_vars_one (DEF_hist_vars%assim , set_defaults) CALL sync_hist_vars_one (DEF_hist_vars%respc , set_defaults) CALL sync_hist_vars_one (DEF_hist_vars%qcharge , set_defaults) @@ -1188,6 +1395,7 @@ SUBROUTINE sync_hist_vars (set_defaults) CALL sync_hist_vars_one (DEF_hist_vars%emis , set_defaults) CALL sync_hist_vars_one (DEF_hist_vars%z0m , set_defaults) CALL sync_hist_vars_one (DEF_hist_vars%trad , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%rss , set_defaults) CALL sync_hist_vars_one (DEF_hist_vars%tref , set_defaults) CALL sync_hist_vars_one (DEF_hist_vars%qref , set_defaults) #ifdef URBAN_MODEL @@ -1212,6 +1420,10 @@ SUBROUTINE sync_hist_vars (set_defaults) CALL sync_hist_vars_one (DEF_hist_vars%t_roof , set_defaults) CALL sync_hist_vars_one (DEF_hist_vars%t_wall , set_defaults) #endif + CALL sync_hist_vars_one (DEF_hist_vars%assimsun , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%assimsha , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%etrsun , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%etrsha , set_defaults) #ifdef BGC CALL sync_hist_vars_one (DEF_hist_vars%leafc , set_defaults) CALL sync_hist_vars_one (DEF_hist_vars%leafc_storage , set_defaults) @@ -1292,10 +1504,6 @@ SUBROUTINE sync_hist_vars (set_defaults) CALL sync_hist_vars_one (DEF_hist_vars%leafc_c3arcgrass , set_defaults) CALL sync_hist_vars_one (DEF_hist_vars%leafc_c3grass , set_defaults) CALL sync_hist_vars_one (DEF_hist_vars%leafc_c4grass , set_defaults) - CALL sync_hist_vars_one (DEF_hist_vars%assimsun , set_defaults) - CALL sync_hist_vars_one (DEF_hist_vars%assimsha , set_defaults) - CALL sync_hist_vars_one (DEF_hist_vars%etrsun , set_defaults) - CALL sync_hist_vars_one (DEF_hist_vars%etrsha , set_defaults) #ifdef CROP CALL sync_hist_vars_one (DEF_hist_vars%cphase , set_defaults) CALL sync_hist_vars_one (DEF_hist_vars%cropprod1c , set_defaults) @@ -1346,6 +1554,12 @@ SUBROUTINE sync_hist_vars (set_defaults) CALL sync_hist_vars_one (DEF_hist_vars%cropprodc_irrigated_trop_soybean, set_defaults) CALL sync_hist_vars_one (DEF_hist_vars%cropprodc_unmanagedcrop , set_defaults) CALL sync_hist_vars_one (DEF_hist_vars%fert_to_sminn , set_defaults) + if(DEF_USE_IRRIGATION)then + CALL sync_hist_vars_one (DEF_hist_vars%irrig_rate , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%deficit_irrig , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%sum_irrig , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%sum_irrig_count , set_defaults) + endif #endif CALL sync_hist_vars_one (DEF_hist_vars%ndep_to_sminn , set_defaults) if(DEF_USE_FIRE)then @@ -1372,8 +1586,10 @@ SUBROUTINE sync_hist_vars (set_defaults) CALL sync_hist_vars_one (DEF_hist_vars%wfc , set_defaults) CALL sync_hist_vars_one (DEF_hist_vars%OM_density , set_defaults) CALL sync_hist_vars_one (DEF_hist_vars%wdsrf , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%wdsrf_inst , set_defaults) CALL sync_hist_vars_one (DEF_hist_vars%zwt , set_defaults) CALL sync_hist_vars_one (DEF_hist_vars%wa , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%wa_inst , set_defaults) CALL sync_hist_vars_one (DEF_hist_vars%t_lake , set_defaults) CALL sync_hist_vars_one (DEF_hist_vars%lake_icefrac, set_defaults) @@ -1427,10 +1643,11 @@ SUBROUTINE sync_hist_vars (set_defaults) CALL sync_hist_vars_one (DEF_hist_vars%srndln , set_defaults) CALL sync_hist_vars_one (DEF_hist_vars%srniln , set_defaults) - CALL sync_hist_vars_one (DEF_hist_vars%rsubs_bsn , set_defaults) - CALL sync_hist_vars_one (DEF_hist_vars%rsubs_hru , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%xsubs_bsn , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%xsubs_hru , set_defaults) CALL sync_hist_vars_one (DEF_hist_vars%riv_height , set_defaults) CALL sync_hist_vars_one (DEF_hist_vars%riv_veloct , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%discharge , set_defaults) CALL sync_hist_vars_one (DEF_hist_vars%wdsrf_hru , set_defaults) CALL sync_hist_vars_one (DEF_hist_vars%veloc_hru , set_defaults) @@ -1446,7 +1663,7 @@ SUBROUTINE sync_hist_vars_one (onoff, set_defaults) IF (p_is_master) THEN IF (set_defaults) THEN - onoff = DEF_hist_vars_turnon_all + onoff = DEF_hist_vars_out_default ENDIF ENDIF diff --git a/share/MOD_NetCDFBlock.F90 b/share/MOD_NetCDFBlock.F90 index 61f4bd92..3218bfe5 100644 --- a/share/MOD_NetCDFBlock.F90 +++ b/share/MOD_NetCDFBlock.F90 @@ -14,26 +14,27 @@ MODULE MOD_NetCDFBlock ! Notice: each file contains vector data in one block. ! 3. Block : read blocked data by IO ! Notice: input file is a single file. - ! + ! ! This module contains subroutines of "3. Block". ! ! Created by Shupeng Zhang, May 2023 !---------------------------------------------------------------------------------- - USE netcdf + USE netcdf USE MOD_NetCDFSerial IMPLICIT NONE ! PUBLIC subroutines interface ncio_read_block - MODULE procedure ncio_read_block_int32_2d - MODULE procedure ncio_read_block_real8_2d - MODULE procedure ncio_read_block_real8_3d + MODULE procedure ncio_read_block_int32_2d + MODULE procedure ncio_read_block_real8_2d + MODULE procedure ncio_read_block_real8_3d END interface ncio_read_block - + interface ncio_read_block_time - MODULE procedure ncio_read_block_int32_2d_time - MODULE procedure ncio_read_block_real8_2d_time + MODULE procedure ncio_read_block_int32_2d_time + MODULE procedure ncio_read_block_real8_2d_time + MODULE procedure ncio_read_block_real8_3d_time END interface ncio_read_block_time PUBLIC :: ncio_read_site_time @@ -42,14 +43,14 @@ MODULE MOD_NetCDFBlock ! ---- SUBROUTINE ncio_read_block_int32_2d (filename, dataname, grid, rdata) - + USE netcdf USE MOD_Block USE MOD_Grid USE MOD_DataType USE MOD_SPMD_Task IMPLICIT NONE - + CHARACTER (len=*), intent(in) :: filename CHARACTER (len=*), intent(in) :: dataname TYPE (grid_type), intent(in) :: grid @@ -62,12 +63,12 @@ SUBROUTINE ncio_read_block_int32_2d (filename, dataname, grid, rdata) INTEGER :: iblkme IF (p_is_io) THEN - + CALL check_ncfile_exist (filename) - CALL nccheck (nf90_open(trim(filename), NF90_NOWRITE, ncid) ) - CALL nccheck (nf90_inq_varid(ncid, trim(dataname), varid) ) - - DO iblkme = 1, gblock%nblkme + CALL nccheck (nf90_open(trim(filename), NF90_NOWRITE, ncid) ,trace=trim(filename)//' cannot open') + CALL nccheck (nf90_inq_varid(ncid, trim(dataname), varid) ,trace=trim(dataname)//' in file '//trim(filename)) + + DO iblkme = 1, gblock%nblkme iblk = gblock%xblkme(iblkme) jblk = gblock%yblkme(iblkme) @@ -93,7 +94,7 @@ SUBROUTINE ncio_read_block_int32_2d (filename, dataname, grid, rdata) ENDIF ENDDO - + CALL nccheck( nf90_close(ncid) ) ENDIF @@ -102,14 +103,14 @@ END SUBROUTINE ncio_read_block_int32_2d ! ---- SUBROUTINE ncio_read_block_real8_2d (filename, dataname, grid, rdata) - + USE netcdf USE MOD_Block USE MOD_Grid USE MOD_DataType USE MOD_SPMD_Task IMPLICIT NONE - + CHARACTER (len=*), intent(in) :: filename CHARACTER (len=*), intent(in) :: dataname TYPE (grid_type), intent(in) :: grid @@ -122,12 +123,12 @@ SUBROUTINE ncio_read_block_real8_2d (filename, dataname, grid, rdata) INTEGER :: iblkme IF (p_is_io) THEN - + CALL check_ncfile_exist (filename) - CALL nccheck (nf90_open(trim(filename), NF90_NOWRITE, ncid) ) - CALL nccheck (nf90_inq_varid(ncid, trim(dataname), varid) ) - - DO iblkme = 1, gblock%nblkme + CALL nccheck (nf90_open(trim(filename), NF90_NOWRITE, ncid) ,trace=trim(filename)//' cannot open') + CALL nccheck (nf90_inq_varid(ncid, trim(dataname), varid) ,trace=trim(dataname)//' in file '//trim(filename)) + + DO iblkme = 1, gblock%nblkme iblk = gblock%xblkme(iblkme) jblk = gblock%yblkme(iblkme) @@ -153,7 +154,7 @@ SUBROUTINE ncio_read_block_real8_2d (filename, dataname, grid, rdata) ENDIF ENDDO - + CALL nccheck( nf90_close(ncid) ) ENDIF @@ -162,14 +163,14 @@ END SUBROUTINE ncio_read_block_real8_2d ! ---- SUBROUTINE ncio_read_block_real8_3d (filename, dataname, grid, ndim1, rdata) - + USE netcdf USE MOD_Block USE MOD_Grid USE MOD_DataType USE MOD_SPMD_Task IMPLICIT NONE - + CHARACTER (len=*), intent(in) :: filename CHARACTER (len=*), intent(in) :: dataname TYPE (grid_type), intent(in) :: grid @@ -183,12 +184,12 @@ SUBROUTINE ncio_read_block_real8_3d (filename, dataname, grid, ndim1, rdata) INTEGER :: iblkme IF (p_is_io) THEN - + CALL check_ncfile_exist (filename) - CALL nccheck (nf90_open(trim(filename), NF90_NOWRITE, ncid) ) - CALL nccheck (nf90_inq_varid(ncid, trim(dataname), varid) ) - - DO iblkme = 1, gblock%nblkme + CALL nccheck (nf90_open(trim(filename), NF90_NOWRITE, ncid) ,trace=trim(filename)//' cannot open') + CALL nccheck (nf90_inq_varid(ncid, trim(dataname), varid) ,trace=trim(dataname)//' in file '//trim(filename)) + + DO iblkme = 1, gblock%nblkme iblk = gblock%xblkme(iblkme) jblk = gblock%yblkme(iblkme) @@ -215,7 +216,7 @@ SUBROUTINE ncio_read_block_real8_3d (filename, dataname, grid, ndim1, rdata) ENDIF ENDDO - + CALL nccheck( nf90_close(ncid) ) ENDIF @@ -224,14 +225,14 @@ END SUBROUTINE ncio_read_block_real8_3d ! ---- SUBROUTINE ncio_read_block_int32_2d_time (filename, dataname, grid, itime, rdata) - + USE netcdf USE MOD_Block USE MOD_Grid USE MOD_DataType USE MOD_SPMD_Task IMPLICIT NONE - + CHARACTER (len=*), intent(in) :: filename CHARACTER (len=*), intent(in) :: dataname TYPE (grid_type), intent(in) :: grid @@ -245,12 +246,12 @@ SUBROUTINE ncio_read_block_int32_2d_time (filename, dataname, grid, itime, rdata INTEGER :: iblkme IF (p_is_io) THEN - + CALL check_ncfile_exist (filename) - CALL nccheck (nf90_open(trim(filename), NF90_NOWRITE, ncid) ) - CALL nccheck (nf90_inq_varid(ncid, trim(dataname), varid) ) - - DO iblkme = 1, gblock%nblkme + CALL nccheck (nf90_open(trim(filename), NF90_NOWRITE, ncid) ,trace=trim(filename)//' cannot open') + CALL nccheck (nf90_inq_varid(ncid, trim(dataname), varid) ,trace=trim(dataname)//' in file '//trim(filename)) + + DO iblkme = 1, gblock%nblkme iblk = gblock%xblkme(iblkme) jblk = gblock%yblkme(iblkme) @@ -277,7 +278,7 @@ SUBROUTINE ncio_read_block_int32_2d_time (filename, dataname, grid, itime, rdata ENDIF ENDDO - + CALL nccheck( nf90_close(ncid) ) ENDIF @@ -286,14 +287,14 @@ END SUBROUTINE ncio_read_block_int32_2d_time ! ---- SUBROUTINE ncio_read_block_real8_2d_time (filename, dataname, grid, itime, rdata) - + USE netcdf USE MOD_Block USE MOD_Grid USE MOD_DataType USE MOD_SPMD_Task IMPLICIT NONE - + CHARACTER (len=*), intent(in) :: filename CHARACTER (len=*), intent(in) :: dataname TYPE (grid_type), intent(in) :: grid @@ -307,12 +308,12 @@ SUBROUTINE ncio_read_block_real8_2d_time (filename, dataname, grid, itime, rdata INTEGER :: iblkme IF (p_is_io) THEN - + CALL check_ncfile_exist (filename) - CALL nccheck (nf90_open(trim(filename), NF90_NOWRITE, ncid) ) - CALL nccheck (nf90_inq_varid(ncid, trim(dataname), varid) ) - - DO iblkme = 1, gblock%nblkme + CALL nccheck (nf90_open(trim(filename), NF90_NOWRITE, ncid) ,trace=trim(filename)//' cannot open') + CALL nccheck (nf90_inq_varid(ncid, trim(dataname), varid) ,trace=trim(dataname)//' in file '//trim(filename)) + + DO iblkme = 1, gblock%nblkme iblk = gblock%xblkme(iblkme) jblk = gblock%yblkme(iblkme) @@ -325,7 +326,7 @@ SUBROUTINE ncio_read_block_real8_2d_time (filename, dataname, grid, itime, rdata count3(3) = 1 IF (count3(1) == grid%xcnt(iblk)) THEN CALL nccheck (nf90_get_var(ncid, varid, rdata%blk(iblk,jblk)%val, & - start3, count3) ) + start3, count3) ,trace=trim(filename)) ELSE CALL nccheck (nf90_get_var(ncid, varid, & rdata%blk(iblk,jblk)%val(1:count3(1),:), start3, count3) ) @@ -338,22 +339,85 @@ SUBROUTINE ncio_read_block_real8_2d_time (filename, dataname, grid, itime, rdata ENDIF ENDDO - + CALL nccheck( nf90_close(ncid) ) ENDIF END SUBROUTINE ncio_read_block_real8_2d_time + ! ---- + SUBROUTINE ncio_read_block_real8_3d_time (filename, dataname, grid, ndim1, itime, rdata) + + USE netcdf + USE MOD_Block + USE MOD_Grid + USE MOD_DataType + USE MOD_SPMD_Task + IMPLICIT NONE + + CHARACTER (len=*), intent(in) :: filename + CHARACTER (len=*), intent(in) :: dataname + TYPE (grid_type), intent(in) :: grid + INTEGER, intent(in) :: ndim1, itime + + TYPE (block_data_real8_3d), intent(inout) :: rdata + + ! Local variables + INTEGER :: iblk, jblk, ndims(3), start4(4), count4(4), start_mem + INTEGER :: ncid, varid + INTEGER :: iblkme + + IF (p_is_io) THEN + + CALL check_ncfile_exist (filename) + CALL nccheck (nf90_open(trim(filename), NF90_NOWRITE, ncid) ,trace=trim(filename)//' cannot open') + CALL nccheck (nf90_inq_varid(ncid, trim(dataname), varid) ,trace=trim(dataname)//' in file '//trim(filename)) + + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + + ndims = (/ndim1, grid%xcnt(iblk), grid%ycnt(jblk)/) + IF (any(ndims == 0)) cycle + + start4 = (/1, grid%xdsp(iblk)+1, grid%ydsp(jblk)+1, itime/) + count4(1) = ndim1 + count4(2) = min(grid%xcnt(iblk), grid%nlon-grid%xdsp(iblk)) + count4(3) = grid%ycnt(jblk) + count4(4) = 1 + IF (count4(2) == grid%xcnt(iblk)) THEN + CALL nccheck (nf90_get_var(ncid, varid, rdata%blk(iblk,jblk)%val, & + start4, count4) ,trace=trim(filename)) + ELSE + CALL nccheck (nf90_get_var(ncid, varid, & + rdata%blk(iblk,jblk)%val(:,1:count4(2),:), start4, count4) ) + + start4(2) = 1 + start_mem = count4(2) + 1 + count4(2) = grid%xdsp(iblk) + grid%xcnt(iblk) - grid%nlon + CALL nccheck (nf90_get_var(ncid, varid, & + rdata%blk(iblk,jblk)%val(:,start_mem:ndims(2),:), start4, count4) ) + ENDIF + + ENDDO + + CALL nccheck( nf90_close(ncid) ) + + ENDIF + + END SUBROUTINE ncio_read_block_real8_3d_time + ! ---- SUBROUTINE ncio_read_site_time (filename, dataname, itime, rdata) - + USE netcdf USE MOD_Block USE MOD_DataType USE MOD_SPMD_Task + USE MOD_Namelist IMPLICIT NONE - + CHARACTER (len=*), intent(in) :: filename CHARACTER (len=*), intent(in) :: dataname INTEGER, intent(in) :: itime @@ -362,20 +426,31 @@ SUBROUTINE ncio_read_site_time (filename, dataname, itime, rdata) ! Local variables INTEGER :: start3(3), count3(3) - INTEGER :: ncid, varid + INTEGER :: varid, dimid + INTEGER, SAVE :: ncid, time_dim + LOGICAL, SAVE :: fid = .false. IF (p_is_io) THEN - CALL check_ncfile_exist (filename) - CALL nccheck (nf90_open(trim(filename), NF90_NOWRITE, ncid) ,trace=trim(filename)) - CALL nccheck (nf90_inq_varid(ncid, trim(dataname), varid) ,trace=trim(dataname)) - + + IF (.not. fid) THEN + fid = .true. + CALL nccheck (nf90_open(trim(filename), NF90_NOWRITE, ncid), trace=trim(filename)//' cannot open') + + CALL nccheck (nf90_inq_dimid(ncid, 'time', dimid), trace=trim(filename)) + CALL nccheck (nf90_inquire_dimension(ncid, dimid, len=time_dim), trace=trim(filename)) + ENDIF + + CALL nccheck (nf90_inq_varid(ncid, trim(dataname), varid) ,trace=trim(dataname)//' in file '//trim(filename)) + start3 = (/1, 1, itime/) count3 = (/1, 1, 1/) CALL nccheck (nf90_get_var(ncid, varid, & rdata%blk(gblock%xblkme(1),gblock%yblkme(1))%val, start3, count3) ) - - CALL nccheck( nf90_close(ncid) ) + + IF ((itime==time_dim) .and. trim(dataname)==DEF_forcing%vname(DEF_forcing%NVAR)) THEN + CALL nccheck( nf90_close(ncid) ) + ENDIF ENDIF diff --git a/share/MOD_NetCDFSerial.F90 b/share/MOD_NetCDFSerial.F90 index 8342c68b..582f92b9 100644 --- a/share/MOD_NetCDFSerial.F90 +++ b/share/MOD_NetCDFSerial.F90 @@ -48,6 +48,7 @@ MODULE MOD_NetCDFSerial MODULE procedure ncio_read_serial_real8_0d MODULE procedure ncio_read_serial_int8_1d MODULE procedure ncio_read_serial_int32_1d + MODULE procedure ncio_read_serial_int64_1d MODULE procedure ncio_read_serial_real8_1d MODULE procedure ncio_read_serial_int8_2d MODULE procedure ncio_read_serial_int16_2d @@ -77,6 +78,10 @@ MODULE MOD_NetCDFSerial MODULE procedure ncio_read_part_serial_int32_2d END interface ncio_read_part_serial + interface ncio_read_period_serial + MODULE procedure ncio_read_period_serial_real8_2d + END interface ncio_read_period_serial + interface ncio_define_dimension MODULE procedure ncio_define_dimension_int32 @@ -88,11 +93,13 @@ MODULE MOD_NetCDFSerial MODULE procedure ncio_write_serial_real8_0d MODULE procedure ncio_write_serial_int8_1d MODULE procedure ncio_write_serial_int32_1d + MODULE procedure ncio_write_serial_int64_1d MODULE procedure ncio_write_serial_real8_1d MODULE procedure ncio_write_serial_logical_1d MODULE procedure ncio_write_serial_int8_2d MODULE procedure ncio_write_serial_int16_2d MODULE procedure ncio_write_serial_int32_2d + MODULE procedure ncio_write_serial_int64_2d MODULE procedure ncio_write_serial_real4_2d MODULE procedure ncio_write_serial_real8_2d MODULE procedure ncio_write_serial_int32_3d @@ -130,11 +137,7 @@ SUBROUTINE nccheck (status, trace) write(*,'(A)') 'Netcdf error: ' //trim(nf90_strerror(status)) ENDIF -#ifdef USEMPI - CALL mpi_abort (p_comm_glb, p_err) -#else - stop 2 -#endif + CALL CoLM_stop () ENDIF END SUBROUTINE nccheck @@ -152,11 +155,7 @@ SUBROUTINE check_ncfile_exist (filename) inquire (file=trim(filename), exist=fexists) IF (.not. fexists) THEN write(*,*) trim(filename), ' does not exist.' -#ifdef USEMPI - CALL mpi_abort (p_comm_glb, p_err) -#else - stop 2 -#endif + CALL CoLM_stop () ENDIF END SUBROUTINE check_ncfile_exist @@ -442,6 +441,34 @@ SUBROUTINE ncio_read_serial_int32_1d (filename, dataname, rdata) END SUBROUTINE ncio_read_serial_int32_1d + !--------------------------------------------------------- + SUBROUTINE ncio_read_serial_int64_1d (filename, dataname, rdata) + + USE netcdf + IMPLICIT NONE + + CHARACTER(len=*), intent(in) :: filename + CHARACTER(len=*), intent(in) :: dataname + INTEGER*8, allocatable, intent(out) :: rdata (:) + + ! Local variables + INTEGER :: ncid, varid + INTEGER, allocatable :: varsize(:) + + CALL check_ncfile_exist (filename) + + CALL ncio_inquire_varsize(filename, dataname, varsize) + allocate (rdata (varsize(1)) ) + + CALL nccheck( nf90_open(trim(filename), NF90_NOWRITE, ncid) ) + CALL nccheck( nf90_inq_varid(ncid, trim(dataname), varid) ) + CALL nccheck( nf90_get_var(ncid, varid, rdata) ) + CALL nccheck( nf90_close(ncid) ) + + deallocate (varsize) + + END SUBROUTINE ncio_read_serial_int64_1d + !--------------------------------------------------------- SUBROUTINE ncio_read_serial_real8_1d (filename, dataname, rdata) @@ -1005,6 +1032,38 @@ SUBROUTINE ncio_read_part_serial_int32_2d (filename, dataname, datastt, dataend, END SUBROUTINE ncio_read_part_serial_int32_2d + !--------------------------------------------------------- + SUBROUTINE ncio_read_period_serial_real8_2d (filename, dataname, timestt, timeend, rdata) + + USE netcdf + IMPLICIT NONE + + CHARACTER(len=*), intent(in) :: filename + CHARACTER(len=*), intent(in) :: dataname + INTEGER, intent(in) :: timestt, timeend + + real(r8), allocatable, intent(out) :: rdata (:,:,:) + + ! Local variables + INTEGER :: ncid, varid + INTEGER, allocatable :: varsize(:) + + CALL check_ncfile_exist (filename) + + CALL ncio_inquire_varsize (filename, dataname, varsize) + + allocate (rdata (varsize(1), varsize(2), timestt:timeend) ) + + CALL nccheck( nf90_open(trim(filename), NF90_NOWRITE, ncid) ) + CALL nccheck( nf90_inq_varid(ncid, trim(dataname), varid) ) + CALL nccheck( nf90_get_var(ncid, varid, rdata, & + (/1,1,timestt/), (/varsize(1),varsize(2), timeend-timestt+1/)) ) + CALL nccheck( nf90_close(ncid) ) + + deallocate(varsize) + + END SUBROUTINE ncio_read_period_serial_real8_2d + ! ------------------------------- SUBROUTINE ncio_define_dimension_int32 (filename, dimname, dimlen) @@ -1247,6 +1306,48 @@ SUBROUTINE ncio_write_serial_int32_1d (filename, dataname, wdata, dimname, compr END SUBROUTINE ncio_write_serial_int32_1d + !--------------------------------------------------------- + SUBROUTINE ncio_write_serial_int64_1d (filename, dataname, wdata, dimname, compress) + + USE netcdf + IMPLICIT NONE + + CHARACTER(len=*), intent(in) :: filename + CHARACTER(len=*), intent(in) :: dataname + INTEGER*8, intent(in) :: wdata (:) + + CHARACTER(len=*), intent(in), optional :: dimname + INTEGER, intent(in), optional :: compress + + ! Local variables + INTEGER :: ncid, varid, dimid, status + + CALL nccheck( nf90_open(trim(filename), NF90_WRITE, ncid) ) + status = nf90_inq_varid(ncid, trim(dataname), varid) + IF (status /= NF90_NOERR) THEN + IF (.not. present(dimname)) THEN + write(*,*) 'Warning: no dimension name for ', trim(dataname) + RETURN + ENDIF + + CALL nccheck (nf90_inq_dimid(ncid, trim(dimname), dimid)) + + CALL nccheck (nf90_redef(ncid)) + IF (present(compress)) THEN + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_INT64, dimid, varid, & + deflate_level = compress)) + ELSE + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_INT64, dimid, varid)) + ENDIF + + CALL nccheck (nf90_enddef(ncid)) + ENDIF + + CALL nccheck( nf90_put_var(ncid, varid, wdata) ) + CALL nccheck( nf90_close(ncid) ) + + END SUBROUTINE ncio_write_serial_int64_1d + !--------------------------------------------------------- SUBROUTINE ncio_write_serial_real8_1d (filename, dataname, wdata, dimname, compress) @@ -1455,6 +1556,50 @@ SUBROUTINE ncio_write_serial_int32_2d (filename, dataname, wdata, & END SUBROUTINE ncio_write_serial_int32_2d + !--------------------------------------------------------- + SUBROUTINE ncio_write_serial_int64_2d (filename, dataname, wdata, & + dim1name, dim2name, compress) + + USE netcdf + IMPLICIT NONE + + CHARACTER(len=*), intent(in) :: filename + CHARACTER(len=*), intent(in) :: dataname + INTEGER*8, intent(in) :: wdata (:,:) + + CHARACTER(len=*), intent(in), optional :: dim1name, dim2name + INTEGER, intent(in), optional :: compress + + ! Local variables + INTEGER :: ncid, varid, dimid(2), status + + CALL nccheck( nf90_open(trim(filename), NF90_WRITE, ncid) ) + status = nf90_inq_varid(ncid, trim(dataname), varid) + IF (status /= NF90_NOERR) THEN + IF (.not. (present(dim1name) .and. present(dim2name))) THEN + write(*,*) 'Warning: no dimension name for ', trim(dataname) + RETURN + ENDIF + + CALL nccheck (nf90_inq_dimid(ncid, trim(dim1name), dimid(1))) + CALL nccheck (nf90_inq_dimid(ncid, trim(dim2name), dimid(2))) + + CALL nccheck (nf90_redef(ncid)) + IF (present(compress)) THEN + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_INT64, dimid, varid, & + deflate_level = compress)) + ELSE + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_INT64, dimid, varid)) + ENDIF + + CALL nccheck (nf90_enddef(ncid)) + ENDIF + + CALL nccheck( nf90_put_var(ncid, varid, wdata) ) + CALL nccheck( nf90_close(ncid) ) + + END SUBROUTINE ncio_write_serial_int64_2d + !--------------------------------------------------------- SUBROUTINE ncio_write_serial_real4_2d (filename, dataname, wdata, & dim1name, dim2name, compress) diff --git a/share/MOD_NetCDFVector.F90 b/share/MOD_NetCDFVector.F90 index 1a155026..b40f873a 100644 --- a/share/MOD_NetCDFVector.F90 +++ b/share/MOD_NetCDFVector.F90 @@ -1,7 +1,5 @@ #include -MODULE MOD_NetCDFVector - !---------------------------------------------------------------------------------- ! DESCRIPTION: ! @@ -16,10 +14,25 @@ MODULE MOD_NetCDFVector ! Notice: input file is a single file. ! ! This module contains subroutines of "2. Vector". + ! + ! Two implementations can be used, + ! 1) A vector is saved in multiple files, each associated with a block. + ! READ/WRITE are fast in this way and compression can be used. + ! However, there may be too many files, especially when blocks are small. + ! CHOOSE this implementation by "#undef VectorInOneFile" in include/define.h + ! 2) A vector is saved in a single file. + ! READ/WRITE may be slow in this way and compression is not used. + ! CHOOSE this implementation by "#define VectorInOneFile" in include/define.h + ! ! ! Created by Shupeng Zhang, May 2023 !---------------------------------------------------------------------------------- +#ifndef VectorInOneFile + +MODULE MOD_NetCDFVector + + USE MOD_DataType IMPLICIT NONE @@ -28,6 +41,7 @@ MODULE MOD_NetCDFVector interface ncio_read_vector MODULE procedure ncio_read_vector_logical_1d MODULE procedure ncio_read_vector_int32_1d + MODULE procedure ncio_read_vector_int64_1d MODULE procedure ncio_read_vector_real8_1d MODULE procedure ncio_read_vector_real8_2d MODULE procedure ncio_read_vector_real8_3d @@ -41,6 +55,7 @@ MODULE MOD_NetCDFVector MODULE procedure ncio_write_vector_logical_1d MODULE procedure ncio_write_vector_int32_1d MODULE procedure ncio_write_vector_int32_3d + MODULE procedure ncio_write_vector_int64_1d MODULE procedure ncio_write_vector_real8_1d MODULE procedure ncio_write_vector_real8_2d MODULE procedure ncio_write_vector_real8_3d @@ -70,7 +85,7 @@ SUBROUTINE ncio_read_vector_int32_1d ( & INTEGER :: iblkgrp, iblk, jblk, istt, iend CHARACTER(len=256) :: fileblock INTEGER, allocatable :: sbuff(:), rbuff(:) - logical :: any_file_exists + logical :: any_file_exists, this_file_exists IF (p_is_worker) THEN IF ((pixelset%nset > 0) .and. (.not. allocated(rdata))) THEN @@ -88,10 +103,12 @@ SUBROUTINE ncio_read_vector_int32_1d ( & allocate (sbuff (pixelset%vecgs%vlen(iblk,jblk))) CALL get_filename_block (filename, iblk, jblk, fileblock) + + inquire (file = trim(fileblock), exist = this_file_exists) + any_file_exists = any_file_exists .or. this_file_exists IF (ncio_var_exist(fileblock,dataname)) THEN CALL ncio_read_serial (fileblock, dataname, sbuff) - any_file_exists = .true. ELSEIF (present(defval)) THEN sbuff(:) = defval ENDIF @@ -117,11 +134,7 @@ SUBROUTINE ncio_read_vector_int32_1d ( & #endif IF (.not. any_file_exists) THEN write(*,*) 'Warning : restart file ' //trim(filename)// ' not found.' -#ifdef USEMPI - CALL mpi_abort (p_comm_glb, p_err) -#else - STOP -#endif + CALL CoLM_stop () ENDIF ENDIF @@ -158,6 +171,113 @@ SUBROUTINE ncio_read_vector_int32_1d ( & END SUBROUTINE ncio_read_vector_int32_1d + !--------------------------------------------------------- + SUBROUTINE ncio_read_vector_int64_1d ( & + filename, dataname, pixelset, rdata, defval) + + USE MOD_NetCDFSerial + USE MOD_SPMD_Task + USE MOD_Block + USE MOD_Pixelset + IMPLICIT NONE + + CHARACTER(len=*), intent(in) :: filename + CHARACTER(len=*), intent(in) :: dataname + TYPE(pixelset_type), intent(in) :: pixelset + + INTEGER*8, allocatable, intent(inout) :: rdata (:) + INTEGER, intent(in), optional :: defval + + ! Local variables + INTEGER :: iblkgrp, iblk, jblk, istt, iend + CHARACTER(len=256) :: fileblock + INTEGER*8, allocatable :: sbuff(:), rbuff(:) + logical :: any_file_exists, this_file_exists + + IF (p_is_worker) THEN + IF ((pixelset%nset > 0) .and. (.not. allocated(rdata))) THEN + allocate (rdata (pixelset%nset)) + ENDIF + ENDIF + + any_file_exists = .false. + + IF (p_is_io) THEN + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + allocate (sbuff (pixelset%vecgs%vlen(iblk,jblk))) + CALL get_filename_block (filename, iblk, jblk, fileblock) + + inquire (file = trim(fileblock), exist = this_file_exists) + any_file_exists = any_file_exists .or. this_file_exists + + IF (ncio_var_exist(fileblock,dataname)) THEN + CALL ncio_read_serial (fileblock, dataname, sbuff) + ELSEIF (present(defval)) THEN + sbuff(:) = defval + ENDIF + +#ifdef USEMPI + CALL mpi_scatterv ( & + sbuff, pixelset%vecgs%vcnt(:,iblk,jblk), & + pixelset%vecgs%vdsp(:,iblk,jblk), MPI_INTEGER8, & + MPI_IN_PLACE, 0, MPI_INTEGER8, & + p_root, p_comm_group, p_err) +#else + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + rdata(istt:iend) = sbuff +#endif + + deallocate (sbuff) + + ENDDO + +#ifdef USEMPI + CALL mpi_allreduce (MPI_IN_PLACE, any_file_exists, 1, MPI_LOGICAL, MPI_LOR, p_comm_io, p_err) +#endif + IF (.not. any_file_exists) THEN + write(*,*) 'Warning : restart file ' //trim(filename)// ' not found.' + CALL CoLM_stop () + ENDIF + ENDIF + +#ifdef USEMPI + IF (p_is_worker) THEN + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + allocate (rbuff (pixelset%vecgs%vlen(iblk,jblk))) + ELSE + allocate (rbuff(1)) + ENDIF + + CALL mpi_scatterv ( & + MPI_INULL_P, MPI_INULL_P, MPI_INULL_P, MPI_INTEGER8, & ! insignificant on workers + rbuff, pixelset%vecgs%vlen(iblk,jblk), MPI_INTEGER8, & + p_root, p_comm_group, p_err) + + IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + rdata(istt:iend) = rbuff + ENDIF + + IF (allocated(rbuff)) deallocate (rbuff) + + ENDDO + + ENDIF +#endif + + END SUBROUTINE ncio_read_vector_int64_1d + !--------------------------------------------------------- SUBROUTINE ncio_read_vector_logical_1d (filename, dataname, pixelset, rdata, & defval) @@ -179,7 +299,7 @@ SUBROUTINE ncio_read_vector_logical_1d (filename, dataname, pixelset, rdata, & INTEGER :: iblkgrp, iblk, jblk, istt, iend CHARACTER(len=256) :: fileblock INTEGER(1), allocatable :: sbuff(:), rbuff(:) - logical :: any_file_exists + logical :: any_file_exists, this_file_exists IF (p_is_worker) THEN IF ((pixelset%nset > 0) .and. (.not. allocated(rdata))) THEN @@ -198,9 +318,11 @@ SUBROUTINE ncio_read_vector_logical_1d (filename, dataname, pixelset, rdata, & allocate (sbuff (pixelset%vecgs%vlen(iblk,jblk))) CALL get_filename_block (filename, iblk, jblk, fileblock) + inquire (file = trim(fileblock), exist = this_file_exists) + any_file_exists = any_file_exists .or. this_file_exists + IF (ncio_var_exist(fileblock,dataname)) THEN CALL ncio_read_serial (fileblock, dataname, sbuff) - any_file_exists = .true. ELSEIF (present(defval)) THEN IF (defval) THEN sbuff(:) = 1 @@ -230,11 +352,7 @@ SUBROUTINE ncio_read_vector_logical_1d (filename, dataname, pixelset, rdata, & #endif IF (.not. any_file_exists) THEN write(*,*) 'Warning : restart file ' //trim(filename)// ' not found.' -#ifdef USEMPI - CALL mpi_abort (p_comm_glb, p_err) -#else - STOP -#endif + CALL CoLM_stop () ENDIF ENDIF @@ -293,7 +411,7 @@ SUBROUTINE ncio_read_vector_real8_1d (filename, dataname, pixelset, rdata, & INTEGER :: iblkgrp, iblk, jblk, istt, iend CHARACTER(len=256) :: fileblock REAL(r8), allocatable :: sbuff(:), rbuff(:) - logical :: any_file_exists + logical :: any_file_exists, this_file_exists IF (p_is_worker) THEN IF ((pixelset%nset > 0) .and. (.not. allocated(rdata))) THEN @@ -312,9 +430,11 @@ SUBROUTINE ncio_read_vector_real8_1d (filename, dataname, pixelset, rdata, & allocate (sbuff (pixelset%vecgs%vlen(iblk,jblk))) CALL get_filename_block (filename, iblk, jblk, fileblock) + inquire (file = trim(fileblock), exist = this_file_exists) + any_file_exists = any_file_exists .or. this_file_exists + IF (ncio_var_exist(fileblock,dataname)) THEN CALL ncio_read_serial (fileblock, dataname, sbuff) - any_file_exists = .true. ELSEIF (present(defval)) THEN sbuff(:) = defval ENDIF @@ -340,11 +460,7 @@ SUBROUTINE ncio_read_vector_real8_1d (filename, dataname, pixelset, rdata, & #endif IF (.not. any_file_exists) THEN write(*,*) 'Warning : restart file ' //trim(filename)// ' not found.' -#ifdef USEMPI - CALL mpi_abort (p_comm_glb, p_err) -#else - STOP -#endif + CALL CoLM_stop () ENDIF ENDIF @@ -404,7 +520,7 @@ SUBROUTINE ncio_read_vector_real8_2d ( & INTEGER :: iblkgrp, iblk, jblk, istt, iend CHARACTER(len=256) :: fileblock REAL(r8), allocatable :: sbuff(:,:), rbuff(:,:) - logical :: any_file_exists + logical :: any_file_exists, this_file_exists IF (p_is_worker) THEN IF ((pixelset%nset > 0) .and. (.not. allocated(rdata))) THEN @@ -423,9 +539,11 @@ SUBROUTINE ncio_read_vector_real8_2d ( & allocate (sbuff (ndim1, pixelset%vecgs%vlen(iblk,jblk))) CALL get_filename_block (filename, iblk, jblk, fileblock) + inquire (file = trim(fileblock), exist = this_file_exists) + any_file_exists = any_file_exists .or. this_file_exists + IF (ncio_var_exist(fileblock,dataname)) THEN CALL ncio_read_serial (fileblock, dataname, sbuff) - any_file_exists = .true. ELSEIF (present(defval)) THEN sbuff(:,:) = defval ENDIF @@ -451,11 +569,7 @@ SUBROUTINE ncio_read_vector_real8_2d ( & #endif IF (.not. any_file_exists) THEN write(*,*) 'Warning : restart file ' //trim(filename)// ' not found.' -#ifdef USEMPI - CALL mpi_abort (p_comm_glb, p_err) -#else - STOP -#endif + CALL CoLM_stop () ENDIF ENDIF @@ -515,7 +629,7 @@ SUBROUTINE ncio_read_vector_real8_3d ( & INTEGER :: iblkgrp, iblk, jblk, istt, iend CHARACTER(len=256) :: fileblock REAL(r8), allocatable :: sbuff(:,:,:), rbuff(:,:,:) - logical :: any_file_exists + logical :: any_file_exists, this_file_exists IF (p_is_worker) THEN IF ((pixelset%nset > 0) .and. (.not. allocated(rdata))) THEN @@ -534,9 +648,11 @@ SUBROUTINE ncio_read_vector_real8_3d ( & allocate (sbuff (ndim1,ndim2, pixelset%vecgs%vlen(iblk,jblk))) CALL get_filename_block (filename, iblk, jblk, fileblock) + inquire (file = trim(fileblock), exist = this_file_exists) + any_file_exists = any_file_exists .or. this_file_exists + IF (ncio_var_exist(fileblock,dataname)) THEN CALL ncio_read_serial (fileblock, dataname, sbuff) - any_file_exists = .true. ELSEIF (present(defval)) THEN sbuff(:,:,:) = defval ENDIF @@ -562,11 +678,7 @@ SUBROUTINE ncio_read_vector_real8_3d ( & #endif IF (.not. any_file_exists) THEN write(*,*) 'Warning : restart file ' //trim(filename)// ' not found.' -#ifdef USEMPI - CALL mpi_abort (p_comm_glb, p_err) -#else - STOP -#endif + CALL CoLM_stop () ENDIF ENDIF @@ -626,7 +738,7 @@ SUBROUTINE ncio_read_vector_real8_4d ( & INTEGER :: iblkgrp, iblk, jblk, istt, iend CHARACTER(len=256) :: fileblock REAL(r8), allocatable :: sbuff(:,:,:,:), rbuff(:,:,:,:) - logical :: any_file_exists + logical :: any_file_exists, this_file_exists IF (p_is_worker) THEN IF ((pixelset%nset > 0) .and. (.not. allocated(rdata))) THEN @@ -645,9 +757,11 @@ SUBROUTINE ncio_read_vector_real8_4d ( & allocate (sbuff (ndim1,ndim2,ndim3, pixelset%vecgs%vlen(iblk,jblk))) CALL get_filename_block (filename, iblk, jblk, fileblock) + inquire (file = trim(fileblock), exist = this_file_exists) + any_file_exists = any_file_exists .or. this_file_exists + IF (ncio_var_exist(fileblock,dataname)) THEN CALL ncio_read_serial (fileblock, dataname, sbuff) - any_file_exists = .true. ELSEIF (present(defval)) THEN sbuff(:,:,:,:) = defval ENDIF @@ -673,11 +787,7 @@ SUBROUTINE ncio_read_vector_real8_4d ( & #endif IF (.not. any_file_exists) THEN write(*,*) 'Warning : restart file ' //trim(filename)// ' not found.' -#ifdef USEMPI - CALL mpi_abort (p_comm_glb, p_err) -#else - STOP -#endif + CALL CoLM_stop () ENDIF ENDIF @@ -1056,6 +1166,92 @@ SUBROUTINE ncio_write_vector_int32_3d ( & END SUBROUTINE ncio_write_vector_int32_3d + !--------------------------------------------------------- + SUBROUTINE ncio_write_vector_int64_1d ( & + filename, dataname, dimname, pixelset, wdata, compress_level) + + USE MOD_NetCDFSerial + USE MOD_SPMD_Task + USE MOD_Block + USE MOD_Pixelset + IMPLICIT NONE + + CHARACTER(len=*), intent(in) :: filename + CHARACTER(len=*), intent(in) :: dataname + CHARACTER(len=*), intent(in) :: dimname + TYPE(pixelset_type), intent(in) :: pixelset + INTEGER*8, intent(in) :: wdata (:) + + INTEGER, intent(in), optional :: compress_level + + ! Local variables + INTEGER :: iblkgrp, iblk, jblk, istt, iend + CHARACTER(len=256) :: fileblock + INTEGER*8, allocatable :: sbuff(:), rbuff(:) + + IF (p_is_io) THEN + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + allocate (rbuff (pixelset%vecgs%vlen(iblk,jblk))) +#ifdef USEMPI + CALL mpi_gatherv (MPI_IN_PLACE, 0, MPI_INTEGER8, & + rbuff, pixelset%vecgs%vcnt(:,iblk,jblk), & + pixelset%vecgs%vdsp(:,iblk,jblk), MPI_INTEGER8, & + p_root, p_comm_group, p_err) +#else + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + rbuff = wdata(istt:iend) +#endif + + CALL get_filename_block (filename, iblk, jblk, fileblock) + + IF (present(compress_level)) THEN + CALL ncio_write_serial (fileblock, dataname, rbuff, dimname, & + compress = compress_level) + ELSE + CALL ncio_write_serial (fileblock, dataname, rbuff, dimname) + ENDIF + + deallocate (rbuff) + + ENDDO + + ENDIF + +#ifdef USEMPI + IF (p_is_worker) THEN + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + allocate (sbuff (pixelset%vecgs%vlen(iblk,jblk))) + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + sbuff = wdata(istt:iend) + ELSE + allocate (sbuff (1)) + ENDIF + + CALL mpi_gatherv ( & + sbuff, pixelset%vecgs%vlen(iblk,jblk), MPI_INTEGER8, & + MPI_INULL_P, MPI_INULL_P, MPI_INULL_P, MPI_INTEGER8, & ! insignificant on workers + p_root, p_comm_group, p_err) + + IF (allocated(sbuff)) deallocate (sbuff) + + ENDDO + + ENDIF +#endif + + END SUBROUTINE ncio_write_vector_int64_1d + !--------------------------------------------------------- SUBROUTINE ncio_write_vector_real8_1d ( & filename, dataname, dimname, pixelset, wdata, compress_level) @@ -1411,3 +1607,1751 @@ SUBROUTINE ncio_write_vector_real8_4d ( & END SUBROUTINE ncio_write_vector_real8_4d END MODULE MOD_NetCDFVector + +#else +! IF defined VectorInOneFile, Put vector in one file. + +MODULE MOD_NetCDFVector + + USE netcdf + USE MOD_DataType + USE MOD_SPMD_Task + USE MOD_Block + USE MOD_Pixelset + USE MOD_NetCDFSerial, only : nccheck + IMPLICIT NONE + + ! PUBLIC subroutines + + PUBLIC :: ncio_create_file_vector + PUBLIC :: ncio_define_dimension_vector + + interface ncio_read_vector + MODULE procedure ncio_read_vector_logical_1d + MODULE procedure ncio_read_vector_int32_1d + MODULE procedure ncio_read_vector_int64_1d + MODULE procedure ncio_read_vector_real8_1d + MODULE procedure ncio_read_vector_real8_2d + MODULE procedure ncio_read_vector_real8_3d + MODULE procedure ncio_read_vector_real8_4d + END interface ncio_read_vector + + interface ncio_write_vector + MODULE procedure ncio_write_vector_logical_1d + MODULE procedure ncio_write_vector_int32_1d + MODULE procedure ncio_write_vector_int64_1d + MODULE procedure ncio_write_vector_real8_1d + MODULE procedure ncio_write_vector_real8_2d + MODULE procedure ncio_write_vector_real8_3d + MODULE procedure ncio_write_vector_real8_4d + END interface ncio_write_vector + +CONTAINS + + ! ----- + SUBROUTINE ncio_open_vector (filename, dataname, exit_on_err, ncid, grpid, vecname, noerr) + + IMPLICIT NONE + + CHARACTER(len=*), intent(in) :: filename + CHARACTER(len=*), intent(in) :: dataname + logical, intent(in) :: exit_on_err + + integer, intent(out) :: ncid, grpid + logical, intent(out) :: noerr + CHARACTER(len=*), intent(out) :: vecname + + noerr = (nf90_open(trim(filename), NF90_NOWRITE, ncid) == NF90_NOERR) + IF (.not. noerr) write(*,*) 'Warning: '//trim(filename)//' not found.' + + IF (noerr) noerr = (nf90_inq_ncid(ncid, trim(dataname), grpid) == NF90_NOERR) + IF (.not. noerr) write(*,*) 'Warning: '//trim(dataname)//' in '//trim(filename)//' not found.' + + IF (noerr) noerr = (nf90_get_att(grpid, NF90_GLOBAL, 'vector_name', vecname) == NF90_NOERR) + IF (.not. noerr) write(*,*) 'Warning: '//trim(vecname)//' in '//trim(filename)//' not found.' + + IF ((.not. noerr) .and. (exit_on_err)) THEN + write(*,'(A)') 'Netcdf error in reading ' // trim(dataname) // ' from ' // trim(filename) + CALL CoLM_Stop () + ENDIF + + END SUBROUTINE ncio_open_vector + + !--------------------------------------------------------- + SUBROUTINE ncio_inquire_length_grp (filename, dataname, blkname, length) + + IMPLICIT NONE + + CHARACTER(len=*), intent(in) :: filename + CHARACTER(len=*), intent(in) :: dataname + CHARACTER(len=*), intent(in) :: blkname + INTEGER, intent(out) :: length + + ! Local variables + INTEGER :: ncid, varid, grpid, ndims + INTEGER, allocatable :: dimids(:) + logical :: noerr + + CALL nccheck( nf90_open(trim(filename), NF90_NOWRITE, ncid) ) + CALL nccheck( nf90_inq_ncid(ncid, trim(dataname), grpid) ) + + noerr = (nf90_inq_varid(grpid, trim(blkname), varid) == NF90_NOERR) + + IF (noerr) THEN + CALL nccheck( nf90_inquire_variable(grpid, varid, ndims = ndims) ) + allocate (dimids(ndims)) + CALL nccheck( nf90_inquire_variable(grpid, varid, dimids = dimids) ) + CALL nccheck( nf90_inquire_dimension(grpid, dimids(ndims), len = length) ) + deallocate (dimids) + ELSE + length = 0 + ENDIF + + CALL nccheck( nf90_close(ncid) ) + + END SUBROUTINE ncio_inquire_length_grp + + !--------------------------------------------------------- + SUBROUTINE ncio_read_serial_grp_int64_1d (filename, dataname, blkname, rdata) + + IMPLICIT NONE + + CHARACTER(len=*), intent(in) :: filename + CHARACTER(len=*), intent(in) :: dataname + CHARACTER(len=*), intent(in) :: blkname + INTEGER*8, allocatable, intent(out) :: rdata (:) + + ! Local variables + INTEGER :: ncid, grpid, varid, varlen + INTEGER, allocatable :: varsize(:) + + CALL ncio_inquire_length_grp (filename, dataname, blkname, varlen) + + IF (varlen > 0) THEN + allocate (rdata (varlen) ) + CALL nccheck( nf90_open(trim(filename), NF90_NOWRITE, ncid) ) + CALL nccheck( nf90_inq_ncid(ncid, trim(dataname), grpid) ) + CALL nccheck( nf90_inq_varid(grpid, trim(blkname), varid) ) + CALL nccheck( nf90_get_var(grpid, varid, rdata) ) + CALL nccheck( nf90_close(ncid) ) + ENDIF + + END SUBROUTINE ncio_read_serial_grp_int64_1d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_vector_int32_1d ( & + filename, dataname, pixelset, rdata, defval) + + IMPLICIT NONE + + CHARACTER(len=*), intent(in) :: filename + CHARACTER(len=*), intent(in) :: dataname + TYPE(pixelset_type), intent(in) :: pixelset + + INTEGER, allocatable, intent(inout) :: rdata (:) + INTEGER, intent(in), optional :: defval + + ! Local variables + INTEGER :: ncid, grpid, varid, iblkgrp, iblk, jblk, istt, iend + CHARACTER(len=256) :: blockname, vecname, varname + INTEGER, allocatable :: sbuff(:), rbuff(:) + LOGICAL :: noerr, ok + + IF (p_is_worker) THEN + IF ((pixelset%nset > 0) .and. (.not. allocated(rdata))) THEN + allocate (rdata (pixelset%nset)) + ENDIF + ENDIF + + IF (p_is_io) THEN + + CALL ncio_open_vector (filename, dataname, .not. present(defval), & + ncid, grpid, vecname, noerr) + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + allocate (sbuff (pixelset%vecgs%vlen(iblk,jblk))) + + IF (noerr) THEN + CALL get_blockname (iblk, jblk, blockname) + varname = trim(vecname)//'_'//trim(blockname) + ok = (nf90_inq_varid(grpid, trim(varname), varid) == NF90_NOERR) + IF (ok) ok = (nf90_get_var(grpid, varid, sbuff) == NF90_NOERR) + ELSE + ok = .false. + ENDIF + + IF (.not. ok) then + IF (.not. present(defval)) THEN + write(*,'(A)') 'Netcdf error in reading ' & + // trim(varname) // ' from ' // trim(filename) + CALL CoLM_Stop () + ELSE + sbuff = defval + ENDIF + ENDIF + +#ifdef USEMPI + CALL mpi_scatterv ( & + sbuff, pixelset%vecgs%vcnt(:,iblk,jblk), & + pixelset%vecgs%vdsp(:,iblk,jblk), MPI_INTEGER, & + MPI_IN_PLACE, 0, MPI_INTEGER, & + p_root, p_comm_group, p_err) +#else + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + rdata(istt:iend) = sbuff +#endif + + deallocate (sbuff) + + ENDDO + + IF (noerr) CALL nccheck( nf90_close(ncid), trim(filename) // ' close failed' ) + + ENDIF + +#ifdef USEMPI + IF (p_is_worker) THEN + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + allocate (rbuff (pixelset%vecgs%vlen(iblk,jblk))) + ELSE + allocate (rbuff(1)) + ENDIF + + CALL mpi_scatterv ( & + MPI_INULL_P, MPI_INULL_P, MPI_INULL_P, MPI_INTEGER, & ! insignificant on workers + rbuff, pixelset%vecgs%vlen(iblk,jblk), MPI_INTEGER, & + p_root, p_comm_group, p_err) + + IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + rdata(istt:iend) = rbuff + ENDIF + + IF (allocated(rbuff)) deallocate (rbuff) + + ENDDO + + ENDIF +#endif + + END SUBROUTINE ncio_read_vector_int32_1d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_vector_int64_1d ( & + filename, dataname, pixelset, rdata, defval) + + IMPLICIT NONE + + CHARACTER(len=*), intent(in) :: filename + CHARACTER(len=*), intent(in) :: dataname + TYPE(pixelset_type), intent(in) :: pixelset + + INTEGER*8, allocatable, intent(inout) :: rdata (:) + INTEGER, intent(in), optional :: defval + + ! Local variables + INTEGER :: ncid, grpid, varid, iblkgrp, iblk, jblk, istt, iend + CHARACTER(len=256) :: blockname, varname, vecname + INTEGER*8, allocatable :: sbuff(:), rbuff(:) + LOGICAL :: noerr, ok + + IF (p_is_worker) THEN + IF ((pixelset%nset > 0) .and. (.not. allocated(rdata))) THEN + allocate (rdata (pixelset%nset)) + ENDIF + ENDIF + + IF (p_is_io) THEN + + CALL ncio_open_vector (filename, dataname, .not. present(defval), & + ncid, grpid, vecname, noerr) + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + allocate (sbuff (pixelset%vecgs%vlen(iblk,jblk))) + + IF (noerr) THEN + CALL get_blockname (iblk, jblk, blockname) + varname = trim(vecname)//'_'//trim(blockname) + ok = (nf90_inq_varid(grpid, trim(varname), varid) == NF90_NOERR) + IF (ok) ok = (nf90_get_var(grpid, varid, sbuff) == NF90_NOERR) + ELSE + ok = .false. + ENDIF + + IF (.not. ok) then + IF (.not. present(defval)) THEN + write(*,'(A)') 'Netcdf error in reading ' & + // trim(varname) // ' from ' // trim(filename) + CALL CoLM_Stop () + ELSE + sbuff = defval + ENDIF + ENDIF + +#ifdef USEMPI + CALL mpi_scatterv ( & + sbuff, pixelset%vecgs%vcnt(:,iblk,jblk), & + pixelset%vecgs%vdsp(:,iblk,jblk), MPI_INTEGER8, & + MPI_IN_PLACE, 0, MPI_INTEGER8, & + p_root, p_comm_group, p_err) +#else + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + rdata(istt:iend) = sbuff +#endif + + deallocate (sbuff) + + ENDDO + + IF (noerr) CALL nccheck( nf90_close(ncid), trim(filename) // ' close failed' ) + + ENDIF + +#ifdef USEMPI + IF (p_is_worker) THEN + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + allocate (rbuff (pixelset%vecgs%vlen(iblk,jblk))) + ELSE + allocate (rbuff(1)) + ENDIF + + CALL mpi_scatterv ( & + MPI_INULL_P, MPI_INULL_P, MPI_INULL_P, MPI_INTEGER8, & ! insignificant on workers + rbuff, pixelset%vecgs%vlen(iblk,jblk), MPI_INTEGER8, & + p_root, p_comm_group, p_err) + + IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + rdata(istt:iend) = rbuff + ENDIF + + IF (allocated(rbuff)) deallocate (rbuff) + + ENDDO + + ENDIF +#endif + + END SUBROUTINE ncio_read_vector_int64_1d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_vector_logical_1d (filename, dataname, pixelset, rdata, & + defval) + + IMPLICIT NONE + + CHARACTER(len=*), intent(in) :: filename + CHARACTER(len=*), intent(in) :: dataname + TYPE(pixelset_type), intent(in) :: pixelset + + LOGICAL, allocatable, intent(inout) :: rdata (:) + LOGICAL, intent(in), optional :: defval + + ! Local variables + INTEGER :: ncid, grpid, varid, iblkgrp, iblk, jblk, istt, iend + CHARACTER(len=256) :: blockname, varname, vecname + INTEGER(1), allocatable :: sbuff(:), rbuff(:) + LOGICAL :: noerr, ok + + IF (p_is_worker) THEN + IF ((pixelset%nset > 0) .and. (.not. allocated(rdata))) THEN + allocate (rdata (pixelset%nset)) + ENDIF + ENDIF + + IF (p_is_io) THEN + + CALL ncio_open_vector (filename, dataname, .not. present(defval), & + ncid, grpid, vecname, noerr) + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + allocate (sbuff (pixelset%vecgs%vlen(iblk,jblk))) + + IF (noerr) THEN + CALL get_blockname (iblk, jblk, blockname) + varname = trim(vecname)//'_'//trim(blockname) + ok = (nf90_inq_varid(grpid, trim(varname), varid) == NF90_NOERR) + IF (ok) ok = (nf90_get_var(grpid, varid, sbuff) == NF90_NOERR) + ELSE + ok = .false. + ENDIF + + IF (.not. ok) then + IF (.not. present(defval)) THEN + write(*,'(A)') 'Netcdf error in reading ' & + // trim(varname) // ' from ' // trim(filename) + CALL CoLM_Stop () + ELSE + IF (defval) THEN + sbuff = 1 + ELSE + sbuff = 0 + ENDIF + ENDIF + ENDIF + +#ifdef USEMPI + CALL mpi_scatterv ( & + sbuff, pixelset%vecgs%vcnt(:,iblk,jblk), & + pixelset%vecgs%vdsp(:,iblk,jblk), MPI_INTEGER1, & + MPI_IN_PLACE, 0, MPI_INTEGER1, & + p_root, p_comm_group, p_err) +#else + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + rdata(istt:iend) = (sbuff == 1) +#endif + + deallocate (sbuff) + + ENDDO + + IF (noerr) CALL nccheck( nf90_close(ncid), trim(filename) // ' close failed' ) + + ENDIF + +#ifdef USEMPI + IF (p_is_worker) THEN + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + allocate (rbuff (pixelset%vecgs%vlen(iblk,jblk))) + ELSE + allocate (rbuff(1)) + ENDIF + + CALL mpi_scatterv ( & + MPI_INULL_P, MPI_INULL_P, MPI_INULL_P, MPI_INTEGER1, & ! insignificant on workers + rbuff, pixelset%vecgs%vlen(iblk,jblk), MPI_INTEGER1, & + p_root, p_comm_group, p_err) + + IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + rdata(istt:iend) = (rbuff == 1) + ENDIF + + IF (allocated(rbuff)) deallocate (rbuff) + + ENDDO + + ENDIF +#endif + + END SUBROUTINE ncio_read_vector_logical_1d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_vector_real8_1d (filename, dataname, pixelset, rdata, & + defval) + + IMPLICIT NONE + + CHARACTER(len=*), intent(in) :: filename + CHARACTER(len=*), intent(in) :: dataname + TYPE(pixelset_type), intent(in) :: pixelset + + REAL(r8), allocatable, intent(inout) :: rdata (:) + REAL(r8), intent(in), optional :: defval + + ! Local variables + INTEGER :: ncid, grpid, varid, iblkgrp, iblk, jblk, istt, iend + CHARACTER(len=256) :: blockname, varname, vecname + REAL(r8), allocatable :: sbuff(:), rbuff(:) + LOGICAL :: noerr, ok + + IF (p_is_worker) THEN + IF ((pixelset%nset > 0) .and. (.not. allocated(rdata))) THEN + allocate (rdata (pixelset%nset)) + ENDIF + ENDIF + + IF (p_is_io) THEN + + CALL ncio_open_vector (filename, dataname, .not. present(defval), & + ncid, grpid, vecname, noerr) + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + allocate (sbuff (pixelset%vecgs%vlen(iblk,jblk))) + + IF (noerr) THEN + CALL get_blockname (iblk, jblk, blockname) + varname = trim(vecname)//'_'//trim(blockname) + ok = (nf90_inq_varid(grpid, trim(varname), varid) == NF90_NOERR) + IF (ok) ok = (nf90_get_var(grpid, varid, sbuff) == NF90_NOERR) + ELSE + ok = .false. + ENDIF + + IF (.not. ok) then + IF (.not. present(defval)) THEN + write(*,'(A)') 'Netcdf error in reading ' & + // trim(varname) // ' from ' // trim(filename) + CALL CoLM_Stop () + ELSE + sbuff = defval + ENDIF + ENDIF + +#ifdef USEMPI + CALL mpi_scatterv ( & + sbuff, pixelset%vecgs%vcnt(:,iblk,jblk), & + pixelset%vecgs%vdsp(:,iblk,jblk), MPI_REAL8, & + MPI_IN_PLACE, 0, MPI_REAL8, & + p_root, p_comm_group, p_err) +#else + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + rdata(istt:iend) = sbuff +#endif + + deallocate (sbuff) + + ENDDO + + IF (noerr) CALL nccheck( nf90_close(ncid), trim(filename) // ' close failed' ) + + ENDIF + +#ifdef USEMPI + IF (p_is_worker) THEN + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + allocate (rbuff (pixelset%vecgs%vlen(iblk,jblk))) + ELSE + allocate (rbuff(1)) + ENDIF + + CALL mpi_scatterv ( & + MPI_RNULL_P, MPI_INULL_P, MPI_INULL_P, MPI_REAL8, & ! insignificant on workers + rbuff, pixelset%vecgs%vlen(iblk,jblk), MPI_REAL8, & + p_root, p_comm_group, p_err) + + IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + rdata(istt:iend) = rbuff + ENDIF + + IF (allocated(rbuff)) deallocate (rbuff) + + ENDDO + + ENDIF +#endif + + END SUBROUTINE ncio_read_vector_real8_1d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_vector_real8_2d ( & + filename, dataname, ndim1, pixelset, rdata, defval) + + IMPLICIT NONE + + CHARACTER(len=*), intent(in) :: filename + CHARACTER(len=*), intent(in) :: dataname + INTEGER, intent(in) :: ndim1 + TYPE(pixelset_type), intent(in) :: pixelset + + REAL(r8), allocatable, intent(inout) :: rdata (:,:) + REAL(r8), intent(in), optional :: defval + + ! Local variables + INTEGER :: ncid, grpid, varid, iblkgrp, iblk, jblk, istt, iend + CHARACTER(len=256) :: blockname, varname, vecname + REAL(r8), allocatable :: sbuff(:,:), rbuff(:,:) + LOGICAL :: noerr, ok + + IF (p_is_worker) THEN + IF ((pixelset%nset > 0) .and. (.not. allocated(rdata))) THEN + allocate (rdata (ndim1, pixelset%nset)) + ENDIF + ENDIF + + IF (p_is_io) THEN + + CALL ncio_open_vector (filename, dataname, .not. present(defval), & + ncid, grpid, vecname, noerr) + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + allocate (sbuff (ndim1, pixelset%vecgs%vlen(iblk,jblk))) + + IF (noerr) THEN + CALL get_blockname (iblk, jblk, blockname) + varname = trim(vecname)//'_'//trim(blockname) + ok = (nf90_inq_varid(grpid, trim(varname), varid) == NF90_NOERR) + IF (ok) ok = (nf90_get_var(grpid, varid, sbuff) == NF90_NOERR) + ELSE + ok = .false. + ENDIF + + IF (.not. ok) then + IF (.not. present(defval)) THEN + write(*,'(A)') 'Netcdf error in reading ' & + // trim(varname) // ' from ' // trim(filename) + CALL CoLM_Stop () + ELSE + sbuff = defval + ENDIF + ENDIF + +#ifdef USEMPI + CALL mpi_scatterv ( & + sbuff, ndim1 * pixelset%vecgs%vcnt(:,iblk,jblk), & + ndim1 * pixelset%vecgs%vdsp(:,iblk,jblk), MPI_REAL8, & + MPI_IN_PLACE, 0, MPI_REAL8, & + p_root, p_comm_group, p_err) +#else + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + rdata(:,istt:iend) = sbuff +#endif + + deallocate (sbuff) + + ENDDO + + IF (noerr) CALL nccheck( nf90_close(ncid), trim(filename) // ' close failed' ) + + ENDIF + +#ifdef USEMPI + IF (p_is_worker) THEN + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + allocate (rbuff (ndim1, pixelset%vecgs%vlen(iblk,jblk))) + ELSE + allocate (rbuff(1,1)) + ENDIF + + CALL mpi_scatterv ( & + MPI_RNULL_P, MPI_INULL_P, MPI_INULL_P, MPI_REAL8, & ! insignificant on workers + rbuff, ndim1 * pixelset%vecgs%vlen(iblk,jblk), MPI_REAL8, & + p_root, p_comm_group, p_err) + + IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + rdata(:,istt:iend) = rbuff + ENDIF + + IF (allocated(rbuff)) deallocate (rbuff) + + ENDDO + + ENDIF +#endif + + END SUBROUTINE ncio_read_vector_real8_2d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_vector_real8_3d ( & + filename, dataname, ndim1, ndim2, pixelset, rdata, defval) + + IMPLICIT NONE + + CHARACTER(len=*), intent(in) :: filename + CHARACTER(len=*), intent(in) :: dataname + INTEGER, intent(in) :: ndim1, ndim2 + TYPE(pixelset_type), intent(in) :: pixelset + + REAL(r8), allocatable, intent(inout) :: rdata (:,:,:) + REAL(r8), intent(in), optional :: defval + + ! Local variables + INTEGER :: ncid, grpid, varid, iblkgrp, iblk, jblk, istt, iend + CHARACTER(len=256) :: blockname, varname, vecname + REAL(r8), allocatable :: sbuff(:,:,:), rbuff(:,:,:) + LOGICAL :: noerr, ok + + IF (p_is_worker) THEN + IF ((pixelset%nset > 0) .and. (.not. allocated(rdata))) THEN + allocate (rdata (ndim1,ndim2, pixelset%nset)) + ENDIF + ENDIF + + IF (p_is_io) THEN + + CALL ncio_open_vector (filename, dataname, .not. present(defval), & + ncid, grpid, vecname, noerr) + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + allocate (sbuff (ndim1,ndim2, pixelset%vecgs%vlen(iblk,jblk))) + + IF (noerr) THEN + CALL get_blockname (iblk, jblk, blockname) + varname = trim(vecname)//'_'//trim(blockname) + ok = (nf90_inq_varid(grpid, trim(varname), varid) == NF90_NOERR) + IF (ok) ok = (nf90_get_var(grpid, varid, sbuff) == NF90_NOERR) + ELSE + ok = .false. + ENDIF + + IF (.not. ok) then + IF (.not. present(defval)) THEN + write(*,'(A)') 'Netcdf error in reading ' & + // trim(varname) // ' from ' // trim(filename) + CALL CoLM_Stop () + ELSE + sbuff = defval + ENDIF + ENDIF + +#ifdef USEMPI + CALL mpi_scatterv ( & + sbuff, ndim1 * ndim2 * pixelset%vecgs%vcnt(:,iblk,jblk), & + ndim1 * ndim2 * pixelset%vecgs%vdsp(:,iblk,jblk), MPI_REAL8, & + MPI_IN_PLACE, 0, MPI_REAL8, & + p_root, p_comm_group, p_err) +#else + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + rdata(:,:,istt:iend) = sbuff +#endif + + deallocate (sbuff) + + ENDDO + + IF (noerr) CALL nccheck( nf90_close(ncid), trim(filename) // ' close failed' ) + + ENDIF + +#ifdef USEMPI + IF (p_is_worker) THEN + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + allocate (rbuff (ndim1,ndim2, pixelset%vecgs%vlen(iblk,jblk))) + ELSE + allocate (rbuff(1,1,1)) + ENDIF + + CALL mpi_scatterv ( & + MPI_RNULL_P, MPI_INULL_P, MPI_INULL_P, MPI_REAL8, & ! insignificant on workers + rbuff, ndim1 * ndim2 * pixelset%vecgs%vlen(iblk,jblk), MPI_REAL8, & + p_root, p_comm_group, p_err) + + IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + rdata(:,:,istt:iend) = rbuff + ENDIF + + IF (allocated(rbuff)) deallocate (rbuff) + + ENDDO + + ENDIF +#endif + + END SUBROUTINE ncio_read_vector_real8_3d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_vector_real8_4d ( & + filename, dataname, ndim1, ndim2, ndim3, pixelset, rdata, defval) + + IMPLICIT NONE + + CHARACTER(len=*), intent(in) :: filename + CHARACTER(len=*), intent(in) :: dataname + INTEGER, intent(in) :: ndim1, ndim2, ndim3 + TYPE(pixelset_type), intent(in) :: pixelset + + REAL(r8), allocatable, intent(inout) :: rdata (:,:,:,:) + REAL(r8), intent(in), optional :: defval + + ! Local variables + INTEGER :: ncid, grpid, varid, iblkgrp, iblk, jblk, istt, iend + CHARACTER(len=256) :: blockname, varname, vecname + REAL(r8), allocatable :: sbuff(:,:,:,:), rbuff(:,:,:,:) + LOGICAL :: noerr, ok + + IF (p_is_worker) THEN + IF ((pixelset%nset > 0) .and. (.not. allocated(rdata))) THEN + allocate (rdata (ndim1,ndim2,ndim3, pixelset%nset)) + ENDIF + ENDIF + + IF (p_is_io) THEN + + CALL ncio_open_vector (filename, dataname, .not. present(defval), & + ncid, grpid, vecname, noerr) + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + allocate (sbuff (ndim1,ndim2,ndim3, pixelset%vecgs%vlen(iblk,jblk))) + + IF (noerr) THEN + CALL get_blockname (iblk, jblk, blockname) + varname = trim(vecname)//'_'//trim(blockname) + ok = (nf90_inq_varid(grpid, trim(varname), varid) == NF90_NOERR) + IF (ok) ok = (nf90_get_var(grpid, varid, sbuff) == NF90_NOERR) + ELSE + ok = .false. + ENDIF + + IF (.not. ok) then + IF (.not. present(defval)) THEN + write(*,'(A)') 'Netcdf error in reading ' & + // trim(varname) // ' from ' // trim(filename) + CALL CoLM_Stop () + ELSE + sbuff = defval + ENDIF + ENDIF + +#ifdef USEMPI + CALL mpi_scatterv ( & + sbuff, ndim1 * ndim2 * ndim3 * pixelset%vecgs%vcnt(:,iblk,jblk), & + ndim1 * ndim2 * ndim3 * pixelset%vecgs%vdsp(:,iblk,jblk), MPI_REAL8, & + MPI_IN_PLACE, 0, MPI_REAL8, & + p_root, p_comm_group, p_err) +#else + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + rdata(:,:,:,istt:iend) = sbuff +#endif + + deallocate (sbuff) + + ENDDO + + IF (noerr) CALL nccheck( nf90_close(ncid), trim(filename) // ' close failed' ) + + ENDIF + +#ifdef USEMPI + IF (p_is_worker) THEN + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + allocate (rbuff (ndim1,ndim2,ndim3, pixelset%vecgs%vlen(iblk,jblk))) + ELSE + allocate (rbuff(1,1,1,1)) + ENDIF + + CALL mpi_scatterv ( & + MPI_RNULL_P, MPI_INULL_P, MPI_INULL_P, MPI_REAL8, & ! insignificant on workers + rbuff, ndim1 * ndim2 * ndim3 * pixelset%vecgs%vlen(iblk,jblk), MPI_REAL8, & + p_root, p_comm_group, p_err) + + IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + rdata(:,:,:,istt:iend) = rbuff + ENDIF + + IF (allocated(rbuff)) deallocate (rbuff) + + ENDDO + + ENDIF +#endif + + END SUBROUTINE ncio_read_vector_real8_4d + + !--------------------------------------------------------- + SUBROUTINE ncio_create_file_vector (filename, pixelset) + + IMPLICIT NONE + + CHARACTER(len=*), intent(in) :: filename + TYPE(pixelset_type), intent(in) :: pixelset + + ! Local Variables + INTEGER :: ncid, mode + + IF (p_is_io) THEN + mode = ior(NF90_NETCDF4,NF90_CLOBBER) +#ifdef USEMPI + mode = ior(mode,NF90_MPIIO) + CALL nccheck( nf90_create(trim(filename), mode, ncid, & + comm = p_comm_io, info = MPI_INFO_NULL) ) +#else + CALL nccheck( nf90_create(trim(filename), mode, ncid) +#endif + CALL nccheck( nf90_close(ncid) ) +#ifdef USEMPI + CALL mpi_barrier (p_comm_io, p_err) +#endif + ENDIF + + END SUBROUTINE ncio_create_file_vector + + !--------------------------------------------------------- + SUBROUTINE ncio_define_dimension_vector (filename, pixelset, dimname, dimlen) + + IMPLICIT NONE + + CHARACTER(len=*), intent(in) :: filename + TYPE(pixelset_type), intent(in) :: pixelset + CHARACTER(len=*), intent(in) :: dimname + INTEGER, optional, intent(in) :: dimlen + + ! Local variables + INTEGER :: ncid, dimid, iblkall, iblk, jblk, err + CHARACTER(len=8) :: blockname + + IF (p_is_io) THEN + +#ifdef USEMPI + CALL nccheck( nf90_open (trim(filename), ior(NF90_WRITE,NF90_NETCDF4), ncid, & + comm = p_comm_io, info = MPI_INFO_NULL) ) +#else + CALL nccheck( nf90_open (trim(filename), ior(NF90_WRITE,NF90_NETCDF4), ncid) +#endif + + CALL nccheck (nf90_redef(ncid)) + + IF (present(dimlen)) THEN + err = nf90_inq_dimid(ncid, trim(dimname), dimid) + IF (err /= NF90_NOERR) THEN + CALL nccheck( nf90_def_dim(ncid, trim(dimname), dimlen, dimid) ) + ENDIF + ELSE + + DO iblkall = 1, pixelset%nblkall + + iblk = pixelset%xblkall(iblkall) + jblk = pixelset%yblkall(iblkall) + CALL get_blockname (iblk, jblk, blockname) + + err = nf90_inq_dimid(ncid, trim(dimname)//'_'//trim(blockname), dimid) + IF (err /= NF90_NOERR) THEN + CALL nccheck( nf90_def_dim(ncid, trim(dimname)//'_'//trim(blockname), & + pixelset%vlenall(iblk,jblk), dimid) ) + ENDIF + + ENDDO + ENDIF + + CALL nccheck (nf90_enddef(ncid)) + CALL nccheck (nf90_close (ncid)) +#ifdef USEMPI + CALL mpi_barrier (p_comm_io, p_err) +#endif + ENDIF + + END SUBROUTINE ncio_define_dimension_vector + + !--------------------------------------------------------- + SUBROUTINE ncio_define_variable_vector ( & + ncid, pixelset, vecname, dataname, datatype, grpid, & + dim1name, dim2name, dim3name, compress) + + IMPLICIT NONE + + INTEGER, intent(in) :: ncid + INTEGER, intent(in) :: datatype + TYPE(pixelset_type), intent(in) :: pixelset + CHARACTER(len=*), intent(in) :: vecname + CHARACTER(len=*), intent(in) :: dataname + + CHARACTER(len=*), optional, intent(in) :: dim1name, dim2name, dim3name + INTEGER, optional, intent(in) :: compress + + INTEGER, intent(out) :: grpid + + ! Local variables + INTEGER :: ndims, idim, iblkall, varid + CHARACTER(len=256) :: varname, blockname + INTEGER, allocatable :: dimids(:), dimlen(:) + integer :: filterid = 307 + + ndims = 1 + IF (present(dim1name)) ndims = ndims + 1 + IF (present(dim2name)) ndims = ndims + 1 + IF (present(dim3name)) ndims = ndims + 1 + + allocate (dimids(ndims)) + allocate (dimlen(ndims)) + + idim = 1 + IF (present(dim1name)) THEN + CALL nccheck (nf90_inq_dimid(ncid, trim(dim1name), dimids(idim))) + CALL nccheck (nf90_inquire_dimension(ncid, dimids(idim), len=dimlen(idim))) + idim = idim + 1 + ENDIF + IF (present(dim2name)) THEN + CALL nccheck (nf90_inq_dimid(ncid, trim(dim2name), dimids(idim))) + CALL nccheck (nf90_inquire_dimension(ncid, dimids(idim), len=dimlen(idim))) + idim = idim + 1 + ENDIF + IF (present(dim3name)) THEN + CALL nccheck (nf90_inq_dimid(ncid, trim(dim3name), dimids(idim))) + CALL nccheck (nf90_inquire_dimension(ncid, dimids(idim), len=dimlen(idim))) + idim = idim + 1 + ENDIF + + CALL nccheck( nf90_def_grp(ncid, trim(dataname), grpid)) + CALL nccheck( nf90_redef(grpid)) + + CALL nccheck( nf90_put_att(grpid, NF90_GLOBAL, 'vector_name', trim(vecname))) + + DO iblkall = 1, pixelset%nblkall + CALL get_blockname (pixelset%xblkall(iblkall), pixelset%yblkall(iblkall), blockname) + varname = trim(vecname)//'_'//trim(blockname) + CALL nccheck (nf90_inq_dimid(ncid, trim(varname), dimids(ndims))) + CALL nccheck (nf90_inquire_dimension(ncid, dimids(ndims), len=dimlen(ndims))) + call nccheck (nf90_def_var(grpid, trim(varname), datatype, dimids, varid, & + chunksizes = dimlen) ) + IF (present(compress)) THEN + ! CALL nccheck( nf90_def_var_filter(grpid, varid, filterid, 1, (/compress/)) ) + ENDIF + ENDDO + + CALL nccheck (nf90_enddef(ncid)) + + deallocate (dimids) + deallocate (dimlen) + + END SUBROUTINE ncio_define_variable_vector + + !--------------------------------------------------------- + SUBROUTINE ncio_write_vector_int32_1d ( & + filename, dataname, vecname, pixelset, wdata, compress_level) + + IMPLICIT NONE + + CHARACTER(len=*), intent(in) :: filename + CHARACTER(len=*), intent(in) :: dataname + CHARACTER(len=*), intent(in) :: vecname + TYPE(pixelset_type), intent(in) :: pixelset + INTEGER, intent(in) :: wdata (:) + + INTEGER, intent(in), optional :: compress_level + + ! Local variables + INTEGER :: ncid, grpid, varid, iblkall, iblkgrp, iblk, jblk, istt, iend + CHARACTER(len=8) :: blockname + INTEGER, allocatable :: sbuff(:), rbuff(:) + + IF (p_is_io) THEN + +#ifdef USEMPI + CALL nccheck( nf90_open(trim(filename), ior(NF90_WRITE,NF90_NETCDF4), ncid, & + comm = p_comm_io, info = MPI_INFO_NULL) ) +#else + CALL nccheck( nf90_open(trim(filename), ior(NF90_WRITE,NF90_NETCDF4), ncid) +#endif + + IF (present(compress_level)) THEN + CALL ncio_define_variable_vector (ncid, pixelset, vecname, dataname, NF90_INT, & + grpid, compress = compress_level) + ELSE + CALL ncio_define_variable_vector (ncid, pixelset, vecname, dataname, NF90_INT, & + grpid) + ENDIF + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + allocate (rbuff (pixelset%vecgs%vlen(iblk,jblk))) +#ifdef USEMPI + CALL mpi_gatherv (MPI_IN_PLACE, 0, MPI_INTEGER, & + rbuff, pixelset%vecgs%vcnt(:,iblk,jblk), & + pixelset%vecgs%vdsp(:,iblk,jblk), MPI_INTEGER, & + p_root, p_comm_group, p_err) +#else + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + rbuff = wdata(istt:iend) +#endif + + CALL get_blockname (iblk, jblk, blockname) + CALL nccheck( nf90_inq_varid(grpid, trim(vecname)//'_'//trim(blockname), varid)) + CALL nccheck( nf90_put_var (grpid, varid, rbuff) ) + + deallocate (rbuff) + + ENDDO + + CALL nccheck( nf90_close(ncid) ) +#ifdef USEMPI + CALL mpi_barrier (p_comm_io, p_err) +#endif + + ENDIF + +#ifdef USEMPI + IF (p_is_worker) THEN + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + allocate (sbuff (pixelset%vecgs%vlen(iblk,jblk))) + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + sbuff = wdata(istt:iend) + ELSE + allocate (sbuff (1)) + ENDIF + + CALL mpi_gatherv ( & + sbuff, pixelset%vecgs%vlen(iblk,jblk), MPI_INTEGER, & + MPI_INULL_P, MPI_INULL_P, MPI_INULL_P, MPI_INTEGER, & ! insignificant on workers + p_root, p_comm_group, p_err) + + IF (allocated(sbuff)) deallocate (sbuff) + + ENDDO + + ENDIF +#endif + + END SUBROUTINE ncio_write_vector_int32_1d + + !--------------------------------------------------------- + SUBROUTINE ncio_write_vector_logical_1d ( & + filename, dataname, vecname, pixelset, wdata, compress_level) + + IMPLICIT NONE + + CHARACTER(len=*), intent(in) :: filename + CHARACTER(len=*), intent(in) :: dataname + CHARACTER(len=*), intent(in) :: vecname + TYPE(pixelset_type), intent(in) :: pixelset + LOGICAL, intent(in) :: wdata (:) + + INTEGER, intent(in), optional :: compress_level + + ! Local variables + INTEGER :: ncid, grpid, varid, iblkall, iblkgrp, iblk, jblk, istt, iend, i + CHARACTER(len=8) :: blockname + INTEGER(1), allocatable :: sbuff(:), rbuff(:) + + IF (p_is_io) THEN + +#ifdef USEMPI + CALL nccheck( nf90_open(trim(filename), ior(NF90_WRITE,NF90_NETCDF4), ncid, & + comm = p_comm_io, info = MPI_INFO_NULL) ) +#else + CALL nccheck( nf90_open(trim(filename), ior(NF90_WRITE,NF90_NETCDF4), ncid) +#endif + + IF (present(compress_level)) THEN + CALL ncio_define_variable_vector (ncid, pixelset, vecname, dataname, NF90_BYTE, & + grpid, compress = compress_level) + ELSE + CALL ncio_define_variable_vector (ncid, pixelset, vecname, dataname, NF90_BYTE, & + grpid) + ENDIF + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + allocate (rbuff (pixelset%vecgs%vlen(iblk,jblk))) +#ifdef USEMPI + CALL mpi_gatherv (MPI_IN_PLACE, 0, MPI_INTEGER1, & + rbuff, pixelset%vecgs%vcnt(:,iblk,jblk), & + pixelset%vecgs%vdsp(:,iblk,jblk), MPI_INTEGER1, & + p_root, p_comm_group, p_err) +#else + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + do i = istt, iend + if(wdata(i))then + rbuff(i-istt+1) = 1 + else + rbuff(i-istt+1) = 0 + end if + end do +#endif + + CALL get_blockname (iblk, jblk, blockname) + CALL nccheck( nf90_inq_varid(grpid, trim(vecname)//'_'//trim(blockname), varid)) + CALL nccheck( nf90_put_var (grpid, varid, rbuff) ) + + deallocate (rbuff) + + ENDDO + + CALL nccheck( nf90_close(ncid) ) +#ifdef USEMPI + CALL mpi_barrier (p_comm_io, p_err) +#endif + + ENDIF + +#ifdef USEMPI + IF (p_is_worker) THEN + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + allocate (sbuff (pixelset%vecgs%vlen(iblk,jblk))) + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + do i = istt, iend + if(wdata(i))then + sbuff(i-istt+1) = 1 + else + sbuff(i-istt+1) = 0 + end if + end do + ELSE + allocate (sbuff (1)) + ENDIF + + CALL mpi_gatherv ( & + sbuff, pixelset%vecgs%vlen(iblk,jblk), MPI_INTEGER1, & + MPI_INULL_P, MPI_INULL_P, MPI_INULL_P, MPI_INTEGER1, & ! insignificant on workers + p_root, p_comm_group, p_err) + + IF (allocated(sbuff)) deallocate (sbuff) + + ENDDO + + ENDIF +#endif + + END SUBROUTINE ncio_write_vector_logical_1d + + !--------------------------------------------------------- + SUBROUTINE ncio_write_vector_int64_1d ( & + filename, dataname, vecname, pixelset, wdata, compress_level) + + IMPLICIT NONE + + CHARACTER(len=*), intent(in) :: filename + CHARACTER(len=*), intent(in) :: dataname + CHARACTER(len=*), intent(in) :: vecname + TYPE(pixelset_type), intent(in) :: pixelset + INTEGER*8, intent(in) :: wdata (:) + + INTEGER, intent(in), optional :: compress_level + + ! Local variables + INTEGER :: ncid, grpid, varid, iblkall, iblkgrp, iblk, jblk, istt, iend + CHARACTER(len=8) :: blockname + INTEGER*8, allocatable :: sbuff(:), rbuff(:) + + IF (p_is_io) THEN + +#ifdef USEMPI + CALL nccheck( nf90_open(trim(filename), ior(NF90_WRITE,NF90_NETCDF4), ncid, & + comm = p_comm_io, info = MPI_INFO_NULL) ) +#else + CALL nccheck( nf90_open(trim(filename), ior(NF90_WRITE,NF90_NETCDF4), ncid) +#endif + + IF (present(compress_level)) THEN + CALL ncio_define_variable_vector (ncid, pixelset, vecname, dataname, NF90_INT64, & + grpid, compress = compress_level) + ELSE + CALL ncio_define_variable_vector (ncid, pixelset, vecname, dataname, NF90_INT64, & + grpid) + ENDIF + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + allocate (rbuff (pixelset%vecgs%vlen(iblk,jblk))) +#ifdef USEMPI + CALL mpi_gatherv (MPI_IN_PLACE, 0, MPI_INTEGER8, & + rbuff, pixelset%vecgs%vcnt(:,iblk,jblk), & + pixelset%vecgs%vdsp(:,iblk,jblk), MPI_INTEGER8, & + p_root, p_comm_group, p_err) +#else + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + rbuff = wdata(istt:iend) +#endif + + CALL get_blockname (iblk, jblk, blockname) + CALL nccheck( nf90_inq_varid(grpid, trim(vecname)//'_'//trim(blockname), varid)) + CALL nccheck( nf90_put_var (grpid, varid, rbuff) ) + + deallocate (rbuff) + + ENDDO + + CALL nccheck( nf90_close(ncid) ) +#ifdef USEMPI + CALL mpi_barrier (p_comm_io, p_err) +#endif + + ENDIF + +#ifdef USEMPI + IF (p_is_worker) THEN + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + allocate (sbuff (pixelset%vecgs%vlen(iblk,jblk))) + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + sbuff = wdata(istt:iend) + ELSE + allocate (sbuff (1)) + ENDIF + + CALL mpi_gatherv ( & + sbuff, pixelset%vecgs%vlen(iblk,jblk), MPI_INTEGER8, & + MPI_INULL_P, MPI_INULL_P, MPI_INULL_P, MPI_INTEGER8, & ! insignificant on workers + p_root, p_comm_group, p_err) + + IF (allocated(sbuff)) deallocate (sbuff) + + ENDDO + + ENDIF +#endif + + END SUBROUTINE ncio_write_vector_int64_1d + + !--------------------------------------------------------- + SUBROUTINE ncio_write_vector_real8_1d ( & + filename, dataname, vecname, pixelset, wdata, compress_level) + + IMPLICIT NONE + + CHARACTER(len=*), intent(in) :: filename + CHARACTER(len=*), intent(in) :: dataname + CHARACTER(len=*), intent(in) :: vecname + TYPE(pixelset_type), intent(in) :: pixelset + REAL(r8), intent(in) :: wdata (:) + + INTEGER, intent(in), optional :: compress_level + + ! Local variables + INTEGER :: ncid, grpid, varid, iblkall, iblkgrp, iblk, jblk, istt, iend + CHARACTER(len=8) :: blockname + REAL(r8), allocatable :: sbuff(:), rbuff(:) + + IF (p_is_io) THEN + +#ifdef USEMPI + CALL nccheck( nf90_open(trim(filename), ior(NF90_WRITE,NF90_NETCDF4), ncid, & + comm = p_comm_io, info = MPI_INFO_NULL) ) +#else + CALL nccheck( nf90_open(trim(filename), ior(NF90_WRITE,NF90_NETCDF4), ncid) +#endif + + IF (present(compress_level)) THEN + CALL ncio_define_variable_vector (ncid, pixelset, vecname, dataname, NF90_DOUBLE, & + grpid, compress = compress_level) + ELSE + CALL ncio_define_variable_vector (ncid, pixelset, vecname, dataname, NF90_DOUBLE, & + grpid) + ENDIF + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + allocate (rbuff (pixelset%vecgs%vlen(iblk,jblk))) +#ifdef USEMPI + CALL mpi_gatherv ( MPI_IN_PLACE, 0, MPI_REAL8, & + rbuff, pixelset%vecgs%vcnt(:,iblk,jblk), & + pixelset%vecgs%vdsp(:,iblk,jblk), MPI_REAL8, & + p_root, p_comm_group, p_err) +#else + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + rbuff = wdata(istt:iend) +#endif + + CALL get_blockname (iblk, jblk, blockname) + CALL nccheck( nf90_inq_varid(grpid, trim(vecname)//'_'//trim(blockname), varid)) + CALL nccheck( nf90_put_var (grpid, varid, rbuff) ) + + deallocate (rbuff) + + ENDDO + + CALL nccheck( nf90_close(ncid) ) +#ifdef USEMPI + CALL mpi_barrier (p_comm_io, p_err) +#endif + ENDIF + +#ifdef USEMPI + IF (p_is_worker) THEN + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + allocate (sbuff (pixelset%vecgs%vlen(iblk,jblk))) + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + sbuff = wdata(istt:iend) + ELSE + allocate (sbuff (1)) + ENDIF + + CALL mpi_gatherv ( & + sbuff, pixelset%vecgs%vlen(iblk,jblk), MPI_REAL8, & + MPI_RNULL_P, MPI_INULL_P, MPI_INULL_P, MPI_REAL8, & ! insignificant on workers + p_root, p_comm_group, p_err) + + IF (allocated(sbuff)) deallocate (sbuff) + + ENDDO + + ENDIF +#endif + + END SUBROUTINE ncio_write_vector_real8_1d + + !--------------------------------------------------------- + SUBROUTINE ncio_write_vector_real8_2d ( & + filename, dataname, dim1name, ndim1, & + vecname, pixelset, wdata, compress_level) + + IMPLICIT NONE + + CHARACTER(len=*), intent(in) :: filename + CHARACTER(len=*), intent(in) :: dataname + CHARACTER(len=*), intent(in) :: dim1name, vecname + INTEGER, intent(in) :: ndim1 + TYPE(pixelset_type), intent(in) :: pixelset + REAL(r8), intent(in) :: wdata (:,:) + + INTEGER, intent(in), optional :: compress_level + + ! Local variables + INTEGER :: ncid, grpid, varid, iblkall, iblkgrp, iblk, jblk, istt, iend + CHARACTER(len=8) :: blockname + REAL(r8), allocatable :: sbuff(:,:), rbuff(:,:) + + IF (p_is_io) THEN + +#ifdef USEMPI + CALL nccheck( nf90_open(trim(filename), ior(NF90_WRITE,NF90_NETCDF4), ncid, & + comm = p_comm_io, info = MPI_INFO_NULL) ) +#else + CALL nccheck( nf90_open(trim(filename), ior(NF90_WRITE,NF90_NETCDF4), ncid) +#endif + + IF (present(compress_level)) THEN + CALL ncio_define_variable_vector (ncid, pixelset, vecname, dataname, NF90_DOUBLE, & + grpid, dim1name = dim1name, compress = compress_level) + ELSE + CALL ncio_define_variable_vector (ncid, pixelset, vecname, dataname, NF90_DOUBLE, & + grpid, dim1name = dim1name) + ENDIF + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + allocate (rbuff (ndim1, pixelset%vecgs%vlen(iblk,jblk))) +#ifdef USEMPI + CALL mpi_gatherv (MPI_IN_PLACE, 0, MPI_REAL8, & + rbuff, ndim1 * pixelset%vecgs%vcnt(:,iblk,jblk), & + ndim1 * pixelset%vecgs%vdsp(:,iblk,jblk), MPI_REAL8, & + p_root, p_comm_group, p_err) +#else + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + rbuff = wdata(:,istt:iend) +#endif + + CALL get_blockname (iblk, jblk, blockname) + CALL nccheck( nf90_inq_varid(grpid, trim(vecname)//'_'//trim(blockname), varid)) + CALL nccheck( nf90_put_var (grpid, varid, rbuff) ) + + deallocate (rbuff) + + ENDDO + + CALL nccheck( nf90_close(ncid) ) +#ifdef USEMPI + CALL mpi_barrier (p_comm_io, p_err) +#endif + ENDIF + +#ifdef USEMPI + IF (p_is_worker) THEN + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + allocate (sbuff (ndim1,pixelset%vecgs%vlen(iblk,jblk))) + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + sbuff = wdata(:,istt:iend) + ELSE + allocate (sbuff (1,1)) + ENDIF + + CALL mpi_gatherv ( & + sbuff, ndim1 * pixelset%vecgs%vlen(iblk,jblk), MPI_REAL8, & + MPI_RNULL_P, MPI_INULL_P, MPI_INULL_P, MPI_REAL8, & ! insignificant on workers + p_root, p_comm_group, p_err) + + IF (allocated(sbuff)) deallocate (sbuff) + + ENDDO + + ENDIF +#endif + + END SUBROUTINE ncio_write_vector_real8_2d + + !--------------------------------------------------------- + SUBROUTINE ncio_write_vector_real8_3d ( & + filename, dataname, dim1name, ndim1, dim2name, ndim2, & + vecname, pixelset, wdata, compress_level) + + IMPLICIT NONE + + CHARACTER(len=*), intent(in) :: filename + CHARACTER(len=*), intent(in) :: dataname + CHARACTER(len=*), intent(in) :: dim1name, dim2name, vecname + TYPE(pixelset_type), intent(in) :: pixelset + INTEGER, intent(in) :: ndim1, ndim2 + REAL(r8), intent(in) :: wdata (:,:,:) + + INTEGER, intent(in), optional :: compress_level + + ! Local variables + INTEGER :: ncid, grpid, varid, iblkall, iblkgrp, iblk, jblk, istt, iend + CHARACTER(len=8) :: blockname + REAL(r8), allocatable :: sbuff(:,:,:), rbuff(:,:,:) + + IF (p_is_io) THEN + +#ifdef USEMPI + CALL nccheck( nf90_open(trim(filename), ior(NF90_WRITE,NF90_NETCDF4), ncid, & + comm = p_comm_io, info = MPI_INFO_NULL) ) +#else + CALL nccheck( nf90_open(trim(filename), ior(NF90_WRITE,NF90_NETCDF4), ncid) +#endif + + IF (present(compress_level)) THEN + CALL ncio_define_variable_vector (ncid, pixelset, vecname, dataname, NF90_DOUBLE, & + grpid, dim1name = dim1name, dim2name = dim2name, compress = compress_level) + ELSE + CALL ncio_define_variable_vector (ncid, pixelset, vecname, dataname, NF90_DOUBLE, & + grpid, dim1name = dim1name, dim2name = dim2name) + ENDIF + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + allocate (rbuff (ndim1, ndim2, pixelset%vecgs%vlen(iblk,jblk))) +#ifdef USEMPI + CALL mpi_gatherv (MPI_IN_PLACE, 0, MPI_REAL8, & + rbuff, ndim1 * ndim2 * pixelset%vecgs%vcnt(:,iblk,jblk), & + ndim1 * ndim2 * pixelset%vecgs%vdsp(:,iblk,jblk), MPI_REAL8, & + p_root, p_comm_group, p_err) +#else + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + rbuff = wdata(:,:,istt:iend) +#endif + + CALL get_blockname (iblk, jblk, blockname) + CALL nccheck( nf90_inq_varid(grpid, trim(vecname)//'_'//trim(blockname), varid)) + CALL nccheck( nf90_put_var (grpid, varid, rbuff) ) + + deallocate (rbuff) + + ENDDO + + CALL nccheck( nf90_close(ncid) ) +#ifdef USEMPI + CALL mpi_barrier (p_comm_io, p_err) +#endif + ENDIF + +#ifdef USEMPI + IF (p_is_worker) THEN + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + allocate (sbuff (ndim1,ndim2,pixelset%vecgs%vlen(iblk,jblk))) + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + sbuff = wdata(:,:,istt:iend) + ELSE + allocate (sbuff (1,1,1)) + ENDIF + + CALL mpi_gatherv ( sbuff, & + ndim1 * ndim2 * pixelset%vecgs%vlen(iblk,jblk), MPI_REAL8, & + MPI_RNULL_P, MPI_INULL_P, MPI_INULL_P, MPI_REAL8, & ! insignificant on workers + p_root, p_comm_group, p_err) + + IF (allocated(sbuff)) deallocate (sbuff) + + ENDDO + + ENDIF +#endif + + END SUBROUTINE ncio_write_vector_real8_3d + + !--------------------------------------------------------- + SUBROUTINE ncio_write_vector_real8_4d ( & + filename, dataname, dim1name, ndim1, dim2name, ndim2, dim3name, ndim3, & + vecname, pixelset, wdata, compress_level) + + IMPLICIT NONE + + CHARACTER(len=*), intent(in) :: filename + CHARACTER(len=*), intent(in) :: dataname + CHARACTER(len=*), intent(in) :: dim1name, dim2name, dim3name, vecname + INTEGER, intent(in) :: ndim1, ndim2, ndim3 + TYPE(pixelset_type), intent(in) :: pixelset + REAL(r8), intent(in) :: wdata (:,:,:,:) + + INTEGER, intent(in), optional :: compress_level + + ! Local variables + INTEGER :: ncid, grpid, varid, iblkall, iblkgrp, iblk, jblk, istt, iend + CHARACTER(len=8) :: blockname + REAL(r8), allocatable :: sbuff(:,:,:,:), rbuff(:,:,:,:) + + IF (p_is_io) THEN + +#ifdef USEMPI + CALL nccheck( nf90_open(trim(filename), ior(NF90_WRITE,NF90_NETCDF4), ncid, & + comm = p_comm_io, info = MPI_INFO_NULL) ) +#else + CALL nccheck( nf90_open(trim(filename), ior(NF90_WRITE,NF90_NETCDF4), ncid) +#endif + + IF (present(compress_level)) THEN + CALL ncio_define_variable_vector (ncid, pixelset, vecname, dataname, NF90_DOUBLE, & + grpid, dim1name = dim1name, dim2name = dim2name, dim3name = dim3name, & + compress = compress_level) + ELSE + CALL ncio_define_variable_vector (ncid, pixelset, vecname, dataname, NF90_DOUBLE, & + grpid, dim1name = dim1name, dim2name = dim2name, dim3name = dim3name) + ENDIF + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + allocate (rbuff (ndim1, ndim2, ndim3, pixelset%vecgs%vlen(iblk,jblk))) +#ifdef USEMPI + CALL mpi_gatherv (MPI_IN_PLACE, 0, MPI_REAL8, & + rbuff, ndim1 * ndim2 * ndim3 * pixelset%vecgs%vcnt(:,iblk,jblk), & + ndim1 * ndim2 * ndim3 * pixelset%vecgs%vdsp(:,iblk,jblk), MPI_REAL8, & + p_root, p_comm_group, p_err) +#else + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + rbuff = wdata(:,:,:,istt:iend) +#endif + + CALL get_blockname (iblk, jblk, blockname) + CALL nccheck( nf90_inq_varid(grpid, trim(vecname)//'_'//trim(blockname), varid)) + CALL nccheck( nf90_put_var (grpid, varid, rbuff) ) + + deallocate (rbuff) + + ENDDO + + CALL nccheck( nf90_close(ncid) ) +#ifdef USEMPI + CALL mpi_barrier (p_comm_io, p_err) +#endif + ENDIF + +#ifdef USEMPI + IF (p_is_worker) THEN + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + allocate (sbuff (ndim1,ndim2,ndim3,pixelset%vecgs%vlen(iblk,jblk))) + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + sbuff = wdata(:,:,:,istt:iend) + ELSE + allocate (sbuff (1,1,1,1)) + ENDIF + + CALL mpi_gatherv ( sbuff, & + ndim1 * ndim2 * ndim3 * pixelset%vecgs%vlen(iblk,jblk), MPI_REAL8, & + MPI_RNULL_P, MPI_INULL_P, MPI_INULL_P, MPI_REAL8, & ! insignificant on workers + p_root, p_comm_group, p_err) + + IF (allocated(sbuff)) deallocate (sbuff) + + ENDDO + + ENDIF +#endif + + END SUBROUTINE ncio_write_vector_real8_4d + +END MODULE MOD_NetCDFVector + +#endif diff --git a/share/MOD_Pixelset.F90 b/share/MOD_Pixelset.F90 index 9e07c0ac..993ea0d6 100644 --- a/share/MOD_Pixelset.F90 +++ b/share/MOD_Pixelset.F90 @@ -69,7 +69,8 @@ MODULE MOD_Pixelset INTEGER :: nset - INTEGER, allocatable :: eindex(:) + INTEGER*8, allocatable :: eindex(:) + INTEGER, allocatable :: ipxstt(:) INTEGER, allocatable :: ipxend(:) INTEGER, allocatable :: settyp(:) @@ -80,8 +81,14 @@ MODULE MOD_Pixelset INTEGER, allocatable :: xblkgrp (:) INTEGER, allocatable :: yblkgrp (:) + INTEGER :: nblkall + INTEGER, allocatable :: xblkall (:) + INTEGER, allocatable :: yblkall (:) + TYPE(vec_gather_scatter_type) :: vecgs + integer, allocatable :: vlenall(:,:) + CONTAINS procedure, PUBLIC :: set_vecgs => vec_gather_scatter_set procedure, PUBLIC :: get_lonlat_radian => pixelset_get_lonlat_radian @@ -253,6 +260,11 @@ SUBROUTINE pixelset_free_mem (this) IF (allocated(this%xblkgrp)) deallocate(this%xblkgrp) IF (allocated(this%yblkgrp)) deallocate(this%yblkgrp) + IF (allocated(this%xblkall)) deallocate(this%xblkall) + IF (allocated(this%yblkall)) deallocate(this%yblkall) + + IF (allocated(this%vlenall)) deallocate(this%vlenall) + END SUBROUTINE pixelset_free_mem ! -------------------------------- @@ -262,17 +274,23 @@ SUBROUTINE pixelset_forc_free_mem (this) class(pixelset_type) :: this - IF (allocated(this%eindex)) deallocate(this%eindex) - IF (allocated(this%ipxstt)) deallocate(this%ipxstt) - IF (allocated(this%ipxend)) deallocate(this%ipxend) - IF (allocated(this%settyp)) deallocate(this%settyp) + IF (allocated(this%eindex )) deallocate(this%eindex ) + IF (allocated(this%ipxstt )) deallocate(this%ipxstt ) + IF (allocated(this%ipxend )) deallocate(this%ipxend ) + IF (allocated(this%settyp )) deallocate(this%settyp ) - IF (allocated(this%ielm )) deallocate(this%ielm ) + IF (allocated(this%ielm )) deallocate(this%ielm ) IF (allocated(this%xblkgrp)) deallocate(this%xblkgrp) IF (allocated(this%yblkgrp)) deallocate(this%yblkgrp) + + IF (allocated(this%xblkall)) deallocate(this%xblkall) + IF (allocated(this%yblkall)) deallocate(this%yblkall) + + IF (allocated(this%vlenall)) deallocate(this%vlenall) END SUBROUTINE pixelset_forc_free_mem + ! -------------------------------- SUBROUTINE copy_pixelset(pixel_from, pixel_to) IMPLICIT NONE @@ -280,15 +298,22 @@ SUBROUTINE copy_pixelset(pixel_from, pixel_to) TYPE(pixelset_type), intent(in) :: pixel_from TYPE(pixelset_type), intent(out) :: pixel_to - pixel_to%eindex = pixel_from%eindex - pixel_to%ipxstt = pixel_from%ipxstt - pixel_to%ipxend = pixel_from%ipxend - pixel_to%ielm = pixel_from%ielm + pixel_to%nset = pixel_from%nset + pixel_to%eindex = pixel_from%eindex + pixel_to%ipxstt = pixel_from%ipxstt + pixel_to%ipxend = pixel_from%ipxend + pixel_to%settyp = pixel_from%settyp + pixel_to%ielm = pixel_from%ielm + + pixel_to%nblkgrp = pixel_from%nblkgrp + pixel_to%xblkgrp = pixel_from%xblkgrp + pixel_to%yblkgrp = pixel_from%yblkgrp + + pixel_to%nblkall = pixel_from%nblkall + pixel_to%xblkall = pixel_from%xblkall + pixel_to%yblkall = pixel_from%yblkall - pixel_to%nset = pixel_from%nset - pixel_to%nblkgrp= pixel_from%nblkgrp - pixel_to%xblkgrp= pixel_from%xblkgrp - pixel_to%yblkgrp= pixel_from%yblkgrp + pixel_to%vlenall = pixel_from%vlenall END SUBROUTINE ! -------------------------------- @@ -303,7 +328,7 @@ SUBROUTINE vec_gather_scatter_set (this) ! Local variables INTEGER :: iproc - INTEGER :: iset, ie, xblk, yblk, iblk, jblk, scnt, iblkgrp + INTEGER :: iset, ie, xblk, yblk, iblk, jblk, scnt, iblkgrp, iblkall LOGICAL, allocatable :: nonzero(:,:) #ifdef USEMPI @@ -420,6 +445,40 @@ SUBROUTINE vec_gather_scatter_set (this) deallocate(nonzero) ENDIF + IF (p_is_io) THEN + + IF (.not. allocated(this%vlenall)) THEN + allocate (this%vlenall(gblock%nxblk,gblock%nyblk)) + ENDIF + + this%vlenall = this%vecgs%vlen +#ifdef USEMPI + CALL mpi_allreduce (MPI_IN_PLACE, this%vlenall, gblock%nxblk * gblock%nyblk, & + MPI_INTEGER, MPI_SUM, p_comm_io, p_err) +#endif + + + this%nblkall = count(this%vlenall > 0) + + IF (allocated(this%xblkall)) deallocate(this%xblkall) + IF (allocated(this%yblkall)) deallocate(this%yblkall) + + allocate (this%xblkall (this%nblkall)) + allocate (this%yblkall (this%nblkall)) + + iblkall = 0 + DO jblk = 1, gblock%nyblk + DO iblk = 1, gblock%nxblk + IF (this%vlenall(iblk,jblk) > 0) THEN + iblkall = iblkall + 1 + this%xblkall(iblkall) = iblk + this%yblkall(iblkall) = jblk + ENDIF + ENDDO + ENDDO + + ENDIF + END SUBROUTINE vec_gather_scatter_set ! -------------------------------- @@ -431,11 +490,11 @@ SUBROUTINE pixelset_pack (this, mask, nset_packed) LOGICAL, intent(in) :: mask(:) INTEGER, intent(out) :: nset_packed - INTEGER, allocatable :: eindex1(:) - INTEGER, allocatable :: ipxstt1(:) - INTEGER, allocatable :: ipxend1(:) - INTEGER, allocatable :: settyp1(:) - INTEGER, allocatable :: ielm1 (:) + INTEGER*8, allocatable :: eindex1(:) + INTEGER, allocatable :: ipxstt1(:) + INTEGER, allocatable :: ipxend1(:) + INTEGER, allocatable :: settyp1(:) + INTEGER, allocatable :: ielm1 (:) IF (p_is_worker) THEN @@ -510,7 +569,7 @@ SUBROUTINE vec_gather_scatter_free_mem (this) END SUBROUTINE vec_gather_scatter_free_mem ! -------------------------------- - SUBROUTINE subset_build (this, superset, subset, use_frac, shadowfrac) + SUBROUTINE subset_build (this, superset, subset, use_frac, sharedfrac) USE MOD_Mesh USE MOD_Pixel @@ -522,7 +581,7 @@ SUBROUTINE subset_build (this, superset, subset, use_frac, shadowfrac) TYPE (pixelset_type), intent(in) :: superset TYPE (pixelset_type), intent(in) :: subset LOGICAL, intent(in) :: use_frac - REAL(r8), intent(in), optional :: shadowfrac (:) + REAL(r8), intent(in), optional :: sharedfrac (:) ! Local Variables INTEGER :: isuperset, isubset, ielm, ipxl, istt, iend @@ -576,8 +635,8 @@ SUBROUTINE subset_build (this, superset, subset, use_frac, shadowfrac) pixel%lon_w(mesh(ielm)%ilon(ipxl)), & pixel%lon_e(mesh(ielm)%ilon(ipxl)) ) ENDDO - IF (present(shadowfrac)) THEN - this%subfrc(isubset) = this%subfrc(isubset) * shadowfrac(isubset) + IF (present(sharedfrac)) THEN + this%subfrc(isubset) = this%subfrc(isubset) * sharedfrac(isubset) ENDIF ENDDO diff --git a/share/MOD_RangeCheck.F90 b/share/MOD_RangeCheck.F90 index 4b3c8f80..72e95102 100644 --- a/share/MOD_RangeCheck.F90 +++ b/share/MOD_RangeCheck.F90 @@ -148,11 +148,7 @@ SUBROUTINE check_block_data_real8_2d (varname, gdata, spv_in, largevalue) #if(defined CoLMDEBUG) IF (len_trim(info) > 0) THEN -#ifdef USEMPI - CALL mpi_abort (p_comm_glb, p_err) -#else - STOP -#endif + CALL CoLM_stop () ENDIF #endif @@ -254,11 +250,7 @@ SUBROUTINE check_vector_data_real8_1d (varname, vdata, spv_in, largevalue) #if(defined CoLMDEBUG) IF (len_trim(info) > 0) THEN -#ifdef USEMPI - CALL mpi_abort (p_comm_glb, p_err) -#else - STOP -#endif + CALL CoLM_stop () ENDIF #endif @@ -361,11 +353,7 @@ SUBROUTINE check_vector_data_real8_2d (varname, vdata, spv_in, largevalue) #if(defined CoLMDEBUG) IF (len_trim(info) > 0) THEN -#ifdef USEMPI - CALL mpi_abort (p_comm_glb, p_err) -#else - STOP -#endif + CALL CoLM_stop () ENDIF #endif @@ -471,11 +459,7 @@ SUBROUTINE check_vector_data_real8_3d (varname, vdata, spv_in, largevalue) #if(defined CoLMDEBUG) IF (len_trim(info) > 0) THEN -#ifdef USEMPI - CALL mpi_abort (p_comm_glb, p_err) -#else - STOP -#endif + CALL CoLM_stop () ENDIF #endif @@ -583,11 +567,7 @@ SUBROUTINE check_vector_data_real8_4d (varname, vdata, spv_in, largevalue) #if(defined CoLMDEBUG) IF (len_trim(info) > 0) THEN -#ifdef USEMPI - CALL mpi_abort (p_comm_glb, p_err) -#else - STOP -#endif + CALL CoLM_stop () ENDIF #endif diff --git a/share/MOD_SPMD_Task.F90 b/share/MOD_SPMD_Task.F90 index c1e11c7d..569df251 100644 --- a/share/MOD_SPMD_Task.F90 +++ b/share/MOD_SPMD_Task.F90 @@ -30,7 +30,7 @@ MODULE MOD_SPMD_Task USE MOD_Precision IMPLICIT NONE - + include 'mpif.h' #ifndef USEMPI @@ -57,6 +57,10 @@ MODULE MOD_SPMD_Task LOGICAL :: p_is_master LOGICAL :: p_is_io LOGICAL :: p_is_worker + LOGICAL :: p_is_writeback + + INTEGER :: p_comm_glb_plus + INTEGER :: p_iam_glb_plus ! Global communicator INTEGER :: p_comm_glb @@ -97,29 +101,35 @@ MODULE MOD_SPMD_Task INTEGER :: MPI_INULL_P(1) REAL(r8) :: MPI_RNULL_P(1) + INTEGER, PARAMETER :: MesgMaxSize = 4194304 ! 4MB + ! subroutines PUBLIC :: spmd_init PUBLIC :: spmd_exit PUBLIC :: divide_processes_into_groups +#endif + CONTAINS +#ifdef USEMPI !----------------------------------------- SUBROUTINE spmd_init (MyComm_r) IMPLICIT NONE - integer, intent(in), optional :: MyComm_r + integer, intent(in), optional :: MyComm_r LOGICAL mpi_inited - CALL MPI_INITIALIZED( mpi_inited, p_err ) + + CALL MPI_INITIALIZED (mpi_inited, p_err) IF ( .NOT. mpi_inited ) THEN CALL mpi_init (p_err) ENDIF - + if (present(MyComm_r)) then - p_comm_glb = MyComm_r + CALL MPI_Comm_dup (MyComm_r, p_comm_glb, p_err) else - p_comm_glb = MPI_COMM_WORLD + CALL MPI_Comm_dup (MPI_COMM_WORLD, p_comm_glb, p_err) endif ! 1. Constructing global communicator. @@ -127,9 +137,36 @@ SUBROUTINE spmd_init (MyComm_r) CALL mpi_comm_size (p_comm_glb, p_np_glb, p_err) p_is_master = (p_iam_glb == p_root) + p_is_writeback = .false. END SUBROUTINE spmd_init + ! ----- ----- + SUBROUTINE spmd_assign_writeback () + + CALL MPI_Comm_dup (p_comm_glb, p_comm_glb_plus, p_err) + + CALL MPI_Comm_free (p_comm_glb, p_err) + + CALL mpi_comm_rank (p_comm_glb_plus, p_iam_glb_plus, p_err) + + p_is_writeback = (p_iam_glb_plus == 0) + + IF (.not. p_is_writeback) THEN + + ! Reconstruct global communicator. + CALL mpi_comm_split (p_comm_glb_plus, 0, p_iam_glb_plus, p_comm_glb, p_err) + CALL mpi_comm_rank (p_comm_glb, p_iam_glb, p_err) + CALL mpi_comm_size (p_comm_glb, p_np_glb, p_err) + p_is_master = (p_iam_glb == p_root) + + ELSE + CALL mpi_comm_split (p_comm_glb_plus, MPI_UNDEFINED, p_iam_glb_plus, p_comm_glb, p_err) + p_is_master = .false. + ENDIF + + END SUBROUTINE spmd_assign_writeback + !----------------------------------------- SUBROUTINE divide_processes_into_groups (numblocks, groupsize) @@ -265,7 +302,9 @@ SUBROUTINE spmd_exit IF (allocated(p_itis_worker )) deallocate (p_itis_worker ) IF (allocated(p_address_worker)) deallocate (p_address_worker) - CALL mpi_barrier (p_comm_glb, p_err) + IF (.not. p_is_writeback) THEN + CALL mpi_barrier (p_comm_glb, p_err) + ENDIF CALL mpi_finalize(p_err) @@ -273,4 +312,20 @@ END SUBROUTINE spmd_exit #endif + ! -- STOP all processes -- + SUBROUTINE CoLM_stop (mesg) + + IMPLICIT NONE + character(len=*), optional :: mesg + + IF (present(mesg)) write(*,*) trim(mesg) + +#ifdef USEMPI + CALL mpi_abort (p_comm_glb, p_err) +#else + STOP +#endif + + END SUBROUTINE CoLM_stop + END MODULE MOD_SPMD_Task diff --git a/share/MOD_TimeManager.F90 b/share/MOD_TimeManager.F90 index 68811435..d6bfbf99 100644 --- a/share/MOD_TimeManager.F90 +++ b/share/MOD_TimeManager.F90 @@ -153,16 +153,23 @@ LOGICAL FUNCTION lessequal(tstamp1, tstamp2) TYPE(timestamp), intent(in) :: tstamp1 TYPE(timestamp), intent(in) :: tstamp2 + INTEGER(kind=4) :: idate1(3), idate2(3) INTEGER(kind=4) :: ts1, ts2 - ts1 = tstamp1%year*1000 + tstamp1%day - ts2 = tstamp2%year*1000 + tstamp2%day + idate1 = (/tstamp1%year, tstamp1%day, tstamp1%sec/) + idate2 = (/tstamp2%year, tstamp2%day, tstamp2%sec/) + + CALL adj2end(idate1) + CALL adj2end(idate2) + + ts1 = idate1(1)*1000 + idate1(2) + ts2 = idate2(1)*1000 + idate2(2) lessequal = .false. IF (ts1 < ts2) lessequal = .true. - IF (ts1==ts2 .AND. tstamp1%sec<=tstamp2%sec) THEN + IF (ts1==ts2 .AND. idate1(3)<=idate2(3)) THEN lessequal = .true. ENDIF @@ -181,7 +188,6 @@ LOGICAL FUNCTION lessthan(tstamp1, tstamp2) idate1 = (/tstamp1%year, tstamp1%day, tstamp1%sec/) idate2 = (/tstamp2%year, tstamp2%day, tstamp2%sec/) - CALL adj2end(idate1) CALL adj2end(idate2) diff --git a/share/MOD_Utils.F90 b/share/MOD_Utils.F90 index 51a2ed9b..ab073046 100644 --- a/share/MOD_Utils.F90 +++ b/share/MOD_Utils.F90 @@ -17,15 +17,24 @@ MODULE MOD_Utils interface expand_list MODULE procedure expand_list_int32 + MODULE procedure expand_list_int64 MODULE procedure expand_list_real8 END interface expand_list PUBLIC :: append_to_list - PUBLIC :: insert_into_sorted_list1 + interface insert_into_sorted_list1 + MODULE procedure insert_into_sorted_list1_int32 + MODULE procedure insert_into_sorted_list1_int64 + END interface insert_into_sorted_list1 + PUBLIC :: insert_into_sorted_list2 - PUBLIC :: find_in_sorted_list1 + interface find_in_sorted_list1 + MODULE procedure find_in_sorted_list1_int32 + MODULE procedure find_in_sorted_list1_int64 + END interface find_in_sorted_list1 + PUBLIC :: find_in_sorted_list2 PUBLIC :: find_nearest_south @@ -113,6 +122,34 @@ SUBROUTINE expand_list_int32 (list, percent) END SUBROUTINE expand_list_int32 + !-------------------------------------------------- + SUBROUTINE expand_list_int64 (list, percent) + + USE MOD_Precision + IMPLICIT NONE + + INTEGER*8, allocatable, intent(inout) :: list (:) + REAL(r8), intent(in) :: percent + + ! Local variables + INTEGER :: n0, n1 + INTEGER*8, allocatable :: temp (:) + + n0 = size(list) + + allocate (temp(n0)) + temp = list + + n1 = ceiling(n0 * (1+percent)) + + deallocate(list) + allocate (list(n1)) + list(1:n0) = temp + + deallocate (temp) + + END SUBROUTINE expand_list_int64 + !-------------------------------------------------- SUBROUTINE expand_list_real8 (list, percent) @@ -181,7 +218,7 @@ SUBROUTINE append_to_list (list1, list2) END SUBROUTINE append_to_list !-------------------------------------------------- - SUBROUTINE insert_into_sorted_list1 (x, n, list, iloc, is_new_out) + SUBROUTINE insert_into_sorted_list1_int32 (x, n, list, iloc, is_new_out) IMPLICIT NONE @@ -243,7 +280,72 @@ SUBROUTINE insert_into_sorted_list1 (x, n, list, iloc, is_new_out) is_new_out = is_new ENDIF - END SUBROUTINE insert_into_sorted_list1 + END SUBROUTINE insert_into_sorted_list1_int32 + + !-------------------------------------------------- + SUBROUTINE insert_into_sorted_list1_int64 (x, n, list, iloc, is_new_out) + + IMPLICIT NONE + + INTEGER*8, intent(in) :: x + INTEGER, intent(inout) :: n + INTEGER*8, intent(inout) :: list(:) + INTEGER, intent(out) :: iloc + LOGICAL, intent(out), optional :: is_new_out + + ! Local variables + LOGICAL :: is_new + INTEGER :: ileft, iright + + IF (n == 0) THEN + iloc = 1 + is_new = .true. + ELSEIF (x <= list(1)) THEN + iloc = 1 + is_new = (x /= list(1)) + ELSEIF (x > list(n)) THEN + iloc = n + 1 + is_new = .true. + ELSEIF (x == list(n)) THEN + iloc = n + is_new = .false. + ELSE + ileft = 1 + iright = n + + DO WHILE (.true.) + IF (iright - ileft > 1) THEN + iloc = (ileft + iright) / 2 + IF (x > list(iloc)) THEN + ileft = iloc + ELSEIF (x < list(iloc)) THEN + iright = iloc + ELSE + is_new = .false. + exit + ENDIF + ELSE + iloc = iright + is_new = .true. + exit + ENDIF + ENDDO + ENDIF + + IF (is_new) THEN + IF (iloc <= n) THEN + list(iloc+1:n+1) = list(iloc:n) + ENDIF + + list(iloc) = x + n = n + 1 + ENDIF + + IF (present(is_new_out)) THEN + is_new_out = is_new + ENDIF + + END SUBROUTINE insert_into_sorted_list1_int64 !-------------------------------------------------- SUBROUTINE insert_into_sorted_list2 (x, y, n, xlist, ylist, iloc, is_new_out) @@ -313,7 +415,7 @@ SUBROUTINE insert_into_sorted_list2 (x, y, n, xlist, ylist, iloc, is_new_out) END SUBROUTINE insert_into_sorted_list2 !-------------------------------------------------- - FUNCTION find_in_sorted_list1 (x, n, list) result(iloc) + FUNCTION find_in_sorted_list1_int32 (x, n, list) result(iloc) IMPLICIT NONE @@ -352,7 +454,49 @@ FUNCTION find_in_sorted_list1 (x, n, list) result(iloc) ENDIF ENDIF - END FUNCTION find_in_sorted_list1 + END FUNCTION find_in_sorted_list1_int32 + + !-------------------------------------------------- + FUNCTION find_in_sorted_list1_int64 (x, n, list) result(iloc) + + IMPLICIT NONE + + INTEGER :: iloc + + INTEGER*8, intent(in) :: x + INTEGER, intent(in) :: n + INTEGER*8, intent(in) :: list (n) + + ! Local variables + INTEGER :: i, ileft, iright + + iloc = 0 + IF (n > 0) THEN + IF ((x >= list(1)) .and. (x <= list(n))) THEN + IF (x == list(1)) THEN + iloc = 1 + ELSEIF (x == list(n)) THEN + iloc = n + ELSE + ileft = 1 + iright = n + + DO WHILE (iright - ileft > 1) + i = (ileft + iright) / 2 + IF (x == list(i)) THEN + iloc = i + exit + ELSEIF (x > list(i)) THEN + ileft = i + ELSEIF (x < list(i)) THEN + iright = i + ENDIF + ENDDO + ENDIF + ENDIF + ENDIF + + END FUNCTION find_in_sorted_list1_int64 !-------------------------------------------------- FUNCTION find_in_sorted_list2 (x, y, n, xlist, ylist) result(iloc) @@ -687,15 +831,13 @@ recursive SUBROUTINE quicksort_int64 (nA, A, order) USE MOD_Precision IMPLICIT NONE - INTEGER*8, intent(in) :: nA + INTEGER, intent(in) :: nA INTEGER*8, intent(inout) :: A (nA) - INTEGER*8, intent(inout) :: order (nA) + INTEGER, intent(inout) :: order (nA) ! Local variables - INTEGER*8 :: left, right - INTEGER*8 :: pivot - INTEGER*8 :: marker - INTEGER*8 :: itemp + INTEGER*8 :: left, right, pivot, itemp + INTEGER :: marker IF (nA > 1) THEN @@ -928,7 +1070,7 @@ FUNCTION arclen (lat1, lon1, lat2, lon2) USE MOD_Precision IMPLICIT NONE - REAL(r8) :: arclen + REAL(r8) :: arclen ! in km REAL(r8), intent(in) :: lat1, lon1, lat2, lon2 REAL(r8), parameter :: re = 6.37122e3 ! kilometer