From d59a8154dd5a772aaaa8997ef9fbe1a7230ad88b Mon Sep 17 00:00:00 2001 From: Rolf Reichle Date: Fri, 25 Mar 2022 14:31:05 -0400 Subject: [PATCH 01/17] corrected errors in comments in mk_Restarts --- .../GEOSsurface_GridComp/Utils/mk_restarts/mk_Restarts | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_Restarts b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_Restarts index 238396bf1..0dde27468 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_Restarts +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_Restarts @@ -17,8 +17,8 @@ my ($surflay, $rsttime, $grpID, $numtasks, $walltime, $rescale, $qos, $partition my ($mk_catch_j, $mk_catch_log, $weminIN, $weminOUT, $weminDFLT); my ($zoom); -# mk_catchcn job and log file names -#---------------------------------- +# mk_catch job and log file names (also applies to catchcn) +#---------------------------------------------------------- $mk_catch_j = "mk_catch.j"; $mk_catch_log = "mk_catch.log"; @@ -376,11 +376,11 @@ option flags -wemin weminIN minimum snow water equivalent threshold for input catch/cn [$weminDFLT] -wemout weminOUT minimum snow water equivalent threshold for output catch/cn [$weminDFLT] -route create the route internal restart - - -surflay n number of surface layers (catch & catchcn) + -surflay n thickness [mm] of surface soil moisture layer (catch & catchcn) + Ganymed-3 and earlier: SURFLAY=20 + Ganymed-4 and later : SURFLAY=50 -rsttime n10 restart time in format, yyyymmddhh (catchcn) or yyyymm (route) -grpID grpID group ID for batch submittal (catchcn) - -ntasks nt number of tasks to assign to catchcn batch job [112] -walltime wt walltime in format \"hh:mm:ss\" for catchcn batch job [1:00:00] -rescale From 0af7401865a6d8f4dce6b0e4d762289117a6522c Mon Sep 17 00:00:00 2001 From: Weiyuan Jiang Date: Thu, 31 Mar 2022 14:32:48 -0400 Subject: [PATCH 02/17] add ScaleCatch that combined catch and catchcn --- .../Utils/mk_restarts/CMakeLists.txt | 7 +- .../Utils/mk_restarts/CatchmentCNRst.F90 | 255 ++++++++++ .../Utils/mk_restarts/CatchmentRst.F90 | 470 ++++++++++++++++++ .../Utils/mk_restarts/ScaleCatch.F90 | 252 ++++++++++ 4 files changed, 982 insertions(+), 2 deletions(-) create mode 100644 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentCNRst.F90 create mode 100644 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentRst.F90 create mode 100644 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/ScaleCatch.F90 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CMakeLists.txt index 78a37bd8d..9298f400e 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CMakeLists.txt +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CMakeLists.txt @@ -2,10 +2,13 @@ esma_set_this () set(srcs getids.F90 + CatchmentRst.F90 + CatchmentCNRst.F90 ) set (exe_srcs Scale_Catch.F90 + ScaleCatch.F90 Scale_CatchCN.F90 cv_SaltRestart.F90 SaltIntSplitter.F90 @@ -20,10 +23,10 @@ set (exe_srcs esma_add_library (${this} SRCS ${srcs} - DEPENDENCIES MAPL esmf NetCDF::NetCDF_Fortran) + DEPENDENCIES MAPL GEOS_SurfaceShared GEOS_LandShared esmf NetCDF::NetCDF_Fortran) foreach (src ${exe_srcs}) - string (REGEX REPLACE ".F90" "" exe ${src}) + string (REGEX REPLACE ".F90" ".x" exe ${src}) ecbuild_add_executable ( TARGET ${exe} SOURCES ${src} diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentCNRst.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentCNRst.F90 new file mode 100644 index 000000000..2442043d2 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentCNRst.F90 @@ -0,0 +1,255 @@ +#include "MAPL_Generic.h" + +module CatchmentCNRstMod + use MAPL + use LSM_ROUTINES, ONLY: & + catch_calc_soil_moist, & + catch_calc_tp, & + catch_calc_ght + USE CATCH_CONSTANTS, ONLY: & + N_GT => CATCH_N_GT, & + DZGT => CATCH_DZGT, & + PEATCLSM_POROS_THRESHOLD + use CatchmentRstMod, only : CatchmentRst + implicit none + + type, extends(CatchmentRst) :: CatchmentCNRst + real, allocatable :: cnity(:,:) + real, allocatable :: fvg(:,:) + real, allocatable :: tg(:,:) + real, allocatable :: TILE_ID(:) + real, allocatable :: ndep(:) + real, allocatable :: t2(:) + real, allocatable :: BGALBVR(:) + real, allocatable :: BGALBVF(:) + real, allocatable :: BGALBNR(:) + real, allocatable :: BGALBNF(:) + real, allocatable :: CNCOL(:,:) + real, allocatable :: CNPFT(:,:) + real, allocatable :: ABM (:) + real, allocatable :: FIELDCAP(:) + real, allocatable :: HDM (:) + real, allocatable :: GDP (:) + real, allocatable :: PEATF (:) + contains + procedure :: write_nc4 + procedure :: allocatecn + endtype CatchmentCNRst + + interface CatchmentCNRst + module procedure CatchmentCNRst_Create + end interface + +contains + + function CatchmentCNRst_create(filename,cnclm,rc) result (catch) + type(CatchmentCNRst) :: catch + character(*), intent(in) :: filename + character(*), intent(in) :: cnclm + integer, optional, intent(out) :: rc + integer :: status + type(Netcdf4_fileformatter) :: formatter + integer :: filetype, ntiles, unit + integer :: j, dim1,dim2 + type(Variable), pointer :: myVariable + character(len=:), pointer :: dname + type(FileMetadata) :: meta + character(len=256) :: Iam = "CatchmentCNRst_create" + + call MAPL_NCIOGetFileType(filename, filetype, __RC__) + if (filetype /= 0) then + _ASSERT( .false., "CatchmentCN only support nc4 file restart") + endif + + call formatter%open(filename, pFIO_READ, __RC__) + meta = formatter%read(__RC__) + ntiles = meta%get_dimension('tile', __RC__) + call catch%read_shared_nc4(formatter, __RC__) + + myVariable => meta%get_variable("ITY") + dname => myVariable%get_ith_dimension(2) + dim1 = meta%get_dimension(dname) + do j=1,dim1 + call MAPL_VarRead(formatter,"ITY",catch%cnity(:,j),offset1=j, __RC__) + call MAPL_VarRead(formatter,"FVG",catch%fvg(:,j),offset1=j, __RC__) + enddo + + call MAPL_VarRead(formatter,"TG",catch%tg, __RC__) + call MAPL_VarRead(formatter,"TILE_ID",catch%TILE_ID, __RC__) + call MAPL_VarRead(formatter,"NDEP",catch%ndep, __RC__) + call MAPL_VarRead(formatter,"CLI_T2M",catch%t2, __RC__) + call MAPL_VarRead(formatter,"BGALBVR",catch%BGALBVR, __RC__) + call MAPL_VarRead(formatter,"BGALBVF",catch%BGALBVF, __RC__) + call MAPL_VarRead(formatter,"BGALBNR",catch%BGALBNR, __RC__) + call MAPL_VarRead(formatter,"BGALBNF",catch%BGALBNF, __RC__) + + myVariable => meta%get_variable("CNCOL") + dname => myVariable%get_ith_dimension(2) + dim1 = meta%get_dimension(dname) + if(index(cnclm,'45') /=0) then + call MAPL_VarRead(formatter,"ABM", catch%ABM, __RC__) + call MAPL_VarRead(formatter,"FIELDCAP",catch%FIELDCAP, __RC__) + call MAPL_VarRead(formatter,"HDM", catch%HDM , __RC__) + call MAPL_VarRead(formatter,"GDP", catch%GDP , __RC__) + call MAPL_VarRead(formatter,"PEATF", catch%PEATF , __RC__) + endif + do j=1,dim1 + call MAPL_VarRead(formatter,"CNCOL",catch%CNCOL(:,j),offset1=j, __RC__) + enddo + ! The following three lines were added as a bug fix by smahanam on 5 Oct 2020 + ! (to be merged into the "develop" branch in late 2020): + ! The length of the 2nd dim of CNPFT differs from that of CNCOL. Prior to this fix, + ! CNPFT was not read in its entirety and some elements remained uninitialized (or zero), + ! resulting in bad values in the "regridded" (re-tiled) restart file. + ! This impacted re-tiled restarts for both CNCLM40 and CLCLM45. + ! - reichle, 23 Nov 2020 + myVariable => meta%get_variable("CNPFT") + dname => myVariable%get_ith_dimension(2) + dim1 = meta%get_dimension(dname) + do j=1,dim1 + call MAPL_VarRead(formatter,"CNPFT",catch%CNPFT(:,j),offset1=j, __RC__) + enddo + call formatter%close() + if (present(rc)) rc =0 + end function CatchmentCNRst_Create + + subroutine write_nc4(this, filename, meta, cnclm, rc) + class(CatchmentCNRst), intent(inout):: this + character(*), intent(in) :: filename + type(FileMetadata), intent(inout) :: meta + character(*), intent(in) :: cnclm + integer, optional, intent(out):: rc + + type(Netcdf4_fileformatter) :: formatter + integer :: status + character(256) :: Iam = "write_nc4" + logical :: clm45 + integer :: i,j, dim1,dim2 + real, dimension (:), allocatable :: var + type(Variable), pointer :: myVariable + character(len=:), pointer :: dname + + clm45 = .false. + if (index(cnclm,'45') /=0) clm45 = .true. + + call formatter%create(filename, __RC__) + call formatter%write(meta, __RC__) + + call this%write_shared_nc4(formatter, __RC__) + + myVariable => meta%get_variable("ITY") + dname => myVariable%get_ith_dimension(2) + dim1 = meta%get_dimension(dname) + do j=1,dim1 + call MAPL_VarWrite(formatter,"ITY",this%cnity(:,j),offset1=j) + call MAPL_VarWrite(formatter,"FVG",this%fvg(:,j),offset1=j) + enddo + + call MAPL_VarWrite(formatter,"TILE_ID",this%TILE_ID) + call MAPL_VarWrite(formatter,"NDEP",this%NDEP) + call MAPL_VarWrite(formatter,"CLI_T2M",this%t2) + call MAPL_VarWrite(formatter,"BGALBVR",this%BGALBVR) + call MAPL_VarWrite(formatter,"BGALBVF",this%BGALBVF) + call MAPL_VarWrite(formatter,"BGALBNR",this%BGALBNR) + call MAPL_VarWrite(formatter,"BGALBNF",this%BGALBNF) + myVariable => meta%get_variable("CNCOL") + dname => myVariable%get_ith_dimension(2) + dim1 = meta%get_dimension(dname) + + do j=1,dim1 + call MAPL_VarWrite(formatter,"CNCOL",this%CNCOL(:,j),offset1=j) + enddo + myVariable => meta%get_variable("CNPFT") + dname => myVariable%get_ith_dimension(2) + dim1 = meta%get_dimension(dname) + do j=1,dim1 + call MAPL_VarWrite(formatter,"CNPFT",this%CNPFT(:,j),offset1=j) + enddo + + dim1 = meta%get_dimension('tile') + allocate (var (dim1)) + var = 0. + + call MAPL_VarWrite(formatter,"BFLOWM", var) + call MAPL_VarWrite(formatter,"TOTWATM",var) + call MAPL_VarWrite(formatter,"TAIRM", var) + call MAPL_VarWrite(formatter,"TPM", var) + call MAPL_VarWrite(formatter,"CNSUM", var) + call MAPL_VarWrite(formatter,"SNDZM", var) + call MAPL_VarWrite(formatter,"ASNOWM", var) + + myVariable => meta%get_variable("TGWM") + dname => myVariable%get_ith_dimension(2) + dim1 = meta%get_dimension(dname) + do j=1,dim1 + call MAPL_VarWrite(formatter,"TGWM",var,offset1=j) + call MAPL_VarWrite(formatter,"RZMM",var,offset1=j) + end do + + if (clm45) then + do j=1,dim1 + call MAPL_VarWrite(formatter,"SFMM", var,offset1=j) + enddo + + call MAPL_VarWrite(formatter,"ABM", this%ABM, rc =rc ) + call MAPL_VarWrite(formatter,"FIELDCAP",this%FIELDCAP) + call MAPL_VarWrite(formatter,"HDM", this%HDM ) + call MAPL_VarWrite(formatter,"GDP", this%GDP ) + call MAPL_VarWrite(formatter,"PEATF", this%PEATF ) + call MAPL_VarWrite(formatter,"RHM", var) + call MAPL_VarWrite(formatter,"WINDM", var) + call MAPL_VarWrite(formatter,"RAINFM", var) + call MAPL_VarWrite(formatter,"SNOWFM", var) + call MAPL_VarWrite(formatter,"RUNSRFM", var) + call MAPL_VarWrite(formatter,"AR1M", var) + call MAPL_VarWrite(formatter,"T2M10D", var) + call MAPL_VarWrite(formatter,"TPREC10D",var) + call MAPL_VarWrite(formatter,"TPREC60D",var) + else + call MAPL_VarWrite(formatter,"SFMCM", var) + endif + myVariable => meta%get_variable("PSNSUNM") + dname => myVariable%get_ith_dimension(2) + dim1 = meta%get_dimension(dname) + dname => myVariable%get_ith_dimension(3) + dim2 = meta%get_dimension(dname) + do i=1,dim2 + do j=1,dim1 + call MAPL_VarWrite(formatter,"PSNSUNM",var,offset1=j,offset2=i) + call MAPL_VarWrite(formatter,"PSNSHAM",var,offset1=j,offset2=i) + end do + end do + call formatter%close() + + _RETURN(_SUCCESS) + end subroutine write_nc4 + + subroutine allocatecn(this, ntiles, ncol, npft, rc) + class(CatchmentCNRst), intent(inout) :: this + integer, intent(in) :: ntiles,ncol,npft + integer, optional, intent(out):: rc + integer :: status + + call this%CatchmentRst%allocate(ntiles, __RC__) + + allocate(this%cnity(ntiles,4)) + allocate(this%fvg(ntiles,4)) + allocate(this%tg(ntiles,4)) + allocate(this%TILE_ID(ntiles)) + allocate(this%ndep(ntiles)) + allocate(this%t2(ntiles)) + allocate(this%BGALBVR(ntiles)) + allocate(this%BGALBVF(ntiles)) + allocate(this%BGALBNR(ntiles)) + allocate(this%BGALBNF(ntiles)) + allocate(this%CNCOL(ntiles,ncol)) + allocate(this%CNPFT(ntiles,npft)) + allocate(this%ABM(ntiles)) + allocate(this%FIELDCAP(ntiles)) + allocate(this%HDM(ntiles)) + allocate(this%GDP(ntiles)) + allocate(this%PEATF(ntiles)) + _RETURN(_SUCCESS) + end subroutine allocatecn + +end module CatchmentCNRstMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentRst.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentRst.F90 new file mode 100644 index 000000000..23fe0f4cf --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentRst.F90 @@ -0,0 +1,470 @@ +#include "MAPL_Generic.h" + +module CatchmentRstMod + use MAPL + use LSM_ROUTINES, ONLY: & + catch_calc_soil_moist, & + catch_calc_tp, & + catch_calc_ght + USE CATCH_CONSTANTS, ONLY: & + N_GT => CATCH_N_GT, & + DZGT => CATCH_DZGT, & + PEATCLSM_POROS_THRESHOLD + + implicit none +#ifndef __GFORTRAN__ + integer :: ftell + external :: ftell +#endif + type :: CatchmentRst + real, allocatable :: bf1(:) + real, allocatable :: bf2(:) + real, allocatable :: bf3(:) + real, allocatable :: vgwmax(:) + real, allocatable :: cdcr1(:) + real, allocatable :: cdcr2(:) + real, allocatable :: psis(:) + real, allocatable :: bee(:) + real, allocatable :: poros(:) + real, allocatable :: wpwet(:) + real, allocatable :: cond(:) + real, allocatable :: gnu(:) + real, allocatable :: ars1(:) + real, allocatable :: ars2(:) + real, allocatable :: ars3(:) + real, allocatable :: ara1(:) + real, allocatable :: ara2(:) + real, allocatable :: ara3(:) + real, allocatable :: ara4(:) + real, allocatable :: arw1(:) + real, allocatable :: arw2(:) + real, allocatable :: arw3(:) + real, allocatable :: arw4(:) + real, allocatable :: tsa1(:) + real, allocatable :: tsa2(:) + real, allocatable :: tsb1(:) + real, allocatable :: tsb2(:) + real, allocatable :: atau(:) + real, allocatable :: btau(:) + real, allocatable :: ity(:) + real, allocatable :: tc(:,:) + real, allocatable :: qc(:,:) + real, allocatable :: capac(:) + real, allocatable :: catdef(:) + real, allocatable :: rzexc(:) + real, allocatable :: srfexc(:) + real, allocatable :: ghtcnt1(:) + real, allocatable :: ghtcnt2(:) + real, allocatable :: ghtcnt3(:) + real, allocatable :: ghtcnt4(:) + real, allocatable :: ghtcnt5(:) + real, allocatable :: ghtcnt6(:) + real, allocatable :: tsurf(:) + real, allocatable :: wesnn1(:) + real, allocatable :: wesnn2(:) + real, allocatable :: wesnn3(:) + real, allocatable :: htsnnn1(:) + real, allocatable :: htsnnn2(:) + real, allocatable :: htsnnn3(:) + real, allocatable :: sndzn1(:) + real, allocatable :: sndzn2(:) + real, allocatable :: sndzn3(:) + real, allocatable :: ch(:,:) + real, allocatable :: cm(:,:) + real, allocatable :: cq(:,:) + real, allocatable :: fr(:,:) + real, allocatable :: ww(:,:) + contains + procedure :: write_bin + procedure :: write_nc4 + procedure :: read_shared_nc4 + procedure :: write_shared_nc4 + procedure :: allocate + endtype CatchmentRst + + interface CatchmentRst + module procedure CatchmentRst_Create + end interface + +contains + + function CatchmentRst_create(filename, rc) result (catch) + type(CatchmentRst) :: catch + character(*), intent(in) :: filename + integer, optional, intent(out) :: rc + integer :: status + character(len=256) :: Iam = "CatchmentRst_create" + type(Netcdf4_fileformatter) :: formatter + integer :: filetype, ntiles, unit + type(FileMetadata) :: meta + integer :: bpos, epos + + + call MAPL_NCIOGetFileType(filename, filetype, __RC__) + if (filetype == 0) then + ! nc4 format + call formatter%open(filename, pFIO_READ, __RC__) + meta = formatter%read(__RC__) + ntiles = meta%get_dimension('tile', __RC__) + call catch%allocate(ntiles) + call catch%read_shared_nc4(formatter, __RC__) + call MAPL_VarRead(formatter,"OLD_ITY",catch%ity, __RC__) + call formatter%close() + + else ! binary + open(newunit=unit, file=filename, form='unformatted') + bpos=0 + read(unit) + epos = ftell(unit) ! ending position of file pointer + ntiles = (epos-bpos)/4-2 ! record size (in 4 byte words; + rewind(unit) + call catch%allocate(ntiles) + read(unit) catch% bf1 + read(unit) catch% bf2 + read(unit) catch% bf3 + read(unit) catch% vgwmax + read(unit) catch% cdcr1 + read(unit) catch% cdcr2 + read(unit) catch% psis + read(unit) catch% bee + read(unit) catch% poros + read(unit) catch% wpwet + read(unit) catch% cond + read(unit) catch% gnu + read(unit) catch% ars1 + read(unit) catch% ars2 + read(unit) catch% ars3 + read(unit) catch% ara1 + read(unit) catch% ara2 + read(unit) catch% ara3 + read(unit) catch% ara4 + read(unit) catch% arw1 + read(unit) catch% arw2 + read(unit) catch% arw3 + read(unit) catch% arw4 + read(unit) catch% tsa1 + read(unit) catch% tsa2 + read(unit) catch% tsb1 + read(unit) catch% tsb2 + read(unit) catch% atau + read(unit) catch% btau + read(unit) catch% ity + read(unit) catch% tc + read(unit) catch% qc + read(unit) catch% capac + read(unit) catch% catdef + read(unit) catch% rzexc + read(unit) catch% srfexc + read(unit) catch% ghtcnt1 + read(unit) catch% ghtcnt2 + read(unit) catch% ghtcnt3 + read(unit) catch% ghtcnt4 + read(unit) catch% ghtcnt5 + read(unit) catch% ghtcnt6 + read(unit) catch% tsurf + read(unit) catch% wesnn1 + read(unit) catch% wesnn2 + read(unit) catch% wesnn3 + read(unit) catch% htsnnn1 + read(unit) catch% htsnnn2 + read(unit) catch% htsnnn3 + read(unit) catch% sndzn1 + read(unit) catch% sndzn2 + read(unit) catch% sndzn3 + read(unit) catch% ch + read(unit) catch% cm + read(unit) catch% cq + read(unit) catch% fr + read(unit) catch% ww + close(unit) + endif + _RETURN(_SUCCESS) + end function CatchmentRst_Create + + subroutine read_shared_nc4(this, formatter, rc) + class(CatchmentRst), intent(inout):: this + type(Netcdf4_fileformatter),intent(inout) :: formatter + integer, optional, intent(out):: rc + integer :: status + + call MAPL_VarRead(formatter,"BF1",this%bf1, __RC__) + call MAPL_VarRead(formatter,"BF2",this%bf2, __RC__) + call MAPL_VarRead(formatter,"BF3",this%bf3, __RC__) + call MAPL_VarRead(formatter,"VGWMAX",this%vgwmax, __RC__) + call MAPL_VarRead(formatter,"CDCR1",this%cdcr1, __RC__) + call MAPL_VarRead(formatter,"CDCR2",this%cdcr2, __RC__) + call MAPL_VarRead(formatter,"PSIS",this%psis, __RC__) + call MAPL_VarRead(formatter,"BEE",this%bee, __RC__) + call MAPL_VarRead(formatter,"POROS",this%poros, __RC__) + call MAPL_VarRead(formatter,"WPWET",this%wpwet, __RC__) + call MAPL_VarRead(formatter,"COND",this%cond, __RC__) + call MAPL_VarRead(formatter,"GNU",this%gnu, __RC__) + call MAPL_VarRead(formatter,"ARS1",this%ars1, __RC__) + call MAPL_VarRead(formatter,"ARS2",this%ars2, __RC__) + call MAPL_VarRead(formatter,"ARS3",this%ars3, __RC__) + call MAPL_VarRead(formatter,"ARA1",this%ara1, __RC__) + call MAPL_VarRead(formatter,"ARA2",this%ara2, __RC__) + call MAPL_VarRead(formatter,"ARA3",this%ara3, __RC__) + call MAPL_VarRead(formatter,"ARA4",this%ara4, __RC__) + call MAPL_VarRead(formatter,"ARW1",this%arw1, __RC__) + call MAPL_VarRead(formatter,"ARW2",this%arw2, __RC__) + call MAPL_VarRead(formatter,"ARW3",this%arw3, __RC__) + call MAPL_VarRead(formatter,"ARW4",this%arw4, __RC__) + call MAPL_VarRead(formatter,"TSA1",this%tsa1, __RC__) + call MAPL_VarRead(formatter,"TSA2",this%tsa2, __RC__) + call MAPL_VarRead(formatter,"TSB1",this%tsb1, __RC__) + call MAPL_VarRead(formatter,"TSB2",this%tsb2, __RC__) + call MAPL_VarRead(formatter,"ATAU",this%atau, __RC__) + call MAPL_VarRead(formatter,"BTAU",this%btau, __RC__) + call MAPL_VarRead(formatter,"TC",this%tc, __RC__) + call MAPL_VarRead(formatter,"QC",this%qc, __RC__) +! +! call MAPL_VarRead(formatter,"OLD_ITY",this%ity, __RC__) +! + call MAPL_VarRead(formatter,"CAPAC",this%capac, __RC__) + call MAPL_VarRead(formatter,"CATDEF",this%catdef, __RC__) + call MAPL_VarRead(formatter,"RZEXC",this%rzexc, __RC__) + call MAPL_VarRead(formatter,"SRFEXC",this%srfexc, __RC__) + call MAPL_VarRead(formatter,"GHTCNT1",this%ghtcnt1, __RC__) + call MAPL_VarRead(formatter,"GHTCNT2",this%ghtcnt2, __RC__) + call MAPL_VarRead(formatter,"GHTCNT3",this%ghtcnt3, __RC__) + call MAPL_VarRead(formatter,"GHTCNT4",this%ghtcnt4, __RC__) + call MAPL_VarRead(formatter,"GHTCNT5",this%ghtcnt5, __RC__) + call MAPL_VarRead(formatter,"GHTCNT6",this%ghtcnt6, __RC__) + call MAPL_VarRead(formatter,"TSURF",this%tsurf, __RC__) + call MAPL_VarRead(formatter,"WESNN1",this%wesnn1, __RC__) + call MAPL_VarRead(formatter,"WESNN2",this%wesnn2, __RC__) + call MAPL_VarRead(formatter,"WESNN3",this%wesnn3, __RC__) + call MAPL_VarRead(formatter,"HTSNNN1",this%htsnnn1, __RC__) + call MAPL_VarRead(formatter,"HTSNNN2",this%htsnnn2, __RC__) + call MAPL_VarRead(formatter,"HTSNNN3",this%htsnnn3, __RC__) + call MAPL_VarRead(formatter,"SNDZN1",this%sndzn1, __RC__) + call MAPL_VarRead(formatter,"SNDZN2",this%sndzn2, __RC__) + call MAPL_VarRead(formatter,"SNDZN3",this%sndzn3, __RC__) + call MAPL_VarRead(formatter,"CH",this%ch, __RC__) + call MAPL_VarRead(formatter,"CM",this%cm, __RC__) + call MAPL_VarRead(formatter,"CQ",this%cq, __RC__) + call MAPL_VarRead(formatter,"FR",this%fr, __RC__) + call MAPL_VarRead(formatter,"WW",this%ww, __RC__) + + _RETURN(_SUCCESS) + end subroutine + + subroutine write_nc4 (this, filename, meta, cnclm, rc) + class(CatchmentRst), intent(inout):: this + character(*), intent(in) :: filename + type(FileMetaData), intent(inout) :: meta + character(*), intent(in) :: cnclm + integer, optional, intent(out):: rc + + type(Netcdf4_fileformatter) :: formatter + integer :: status + character(256) :: Iam = "write_nc4" + + call formatter%create(filename, __RC__) + call formatter%write(meta, __RC__) + call this%write_shared_nc4(formatter, __RC__) + call MAPL_VarWrite(formatter,"OLD_ITY",this%ity) + call formatter%close() + _RETURN(_SUCCESS) + + end subroutine write_nc4 + + subroutine write_shared_nc4(this, formatter, rc) + class(CatchmentRst), intent(inout):: this + type(Netcdf4_fileformatter),intent(inout) :: formatter + integer, optional, intent(out):: rc + integer :: status + call MAPL_VarWrite(formatter,"BF1",this%bf1) + call MAPL_VarWrite(formatter,"BF2",this%bf2) + call MAPL_VarWrite(formatter,"BF3",this%bf3) + call MAPL_VarWrite(formatter,"VGWMAX",this%vgwmax) + call MAPL_VarWrite(formatter,"CDCR1",this%cdcr1) + call MAPL_VarWrite(formatter,"CDCR2",this%cdcr2) + call MAPL_VarWrite(formatter,"PSIS",this%psis) + call MAPL_VarWrite(formatter,"BEE",this%bee) + call MAPL_VarWrite(formatter,"POROS",this%poros) + call MAPL_VarWrite(formatter,"WPWET",this%wpwet) + call MAPL_VarWrite(formatter,"COND",this%cond) + call MAPL_VarWrite(formatter,"GNU",this%gnu) + call MAPL_VarWrite(formatter,"ARS1",this%ars1) + call MAPL_VarWrite(formatter,"ARS2",this%ars2) + call MAPL_VarWrite(formatter,"ARS3",this%ars3) + call MAPL_VarWrite(formatter,"ARA1",this%ara1) + call MAPL_VarWrite(formatter,"ARA2",this%ara2) + call MAPL_VarWrite(formatter,"ARA3",this%ara3) + call MAPL_VarWrite(formatter,"ARA4",this%ara4) + call MAPL_VarWrite(formatter,"ARW1",this%arw1) + call MAPL_VarWrite(formatter,"ARW2",this%arw2) + call MAPL_VarWrite(formatter,"ARW3",this%arw3) + call MAPL_VarWrite(formatter,"ARW4",this%arw4) + call MAPL_VarWrite(formatter,"TSA1",this%tsa1) + call MAPL_VarWrite(formatter,"TSA2",this%tsa2) + call MAPL_VarWrite(formatter,"TSB1",this%tsb1) + call MAPL_VarWrite(formatter,"TSB2",this%tsb2) + call MAPL_VarWrite(formatter,"ATAU",this%atau) + call MAPL_VarWrite(formatter,"BTAU",this%btau) + call MAPL_VarWrite(formatter,"TC",this%tc) + call MAPL_VarWrite(formatter,"QC",this%qc) + call MAPL_VarWrite(formatter,"CAPAC",this%capac) + call MAPL_VarWrite(formatter,"CATDEF",this%catdef) + call MAPL_VarWrite(formatter,"RZEXC",this%rzexc) + call MAPL_VarWrite(formatter,"SRFEXC",this%srfexc) + call MAPL_VarWrite(formatter,"GHTCNT1",this%ghtcnt1) + call MAPL_VarWrite(formatter,"GHTCNT2",this%ghtcnt2) + call MAPL_VarWrite(formatter,"GHTCNT3",this%ghtcnt3) + call MAPL_VarWrite(formatter,"GHTCNT4",this%ghtcnt4) + call MAPL_VarWrite(formatter,"GHTCNT5",this%ghtcnt5) + call MAPL_VarWrite(formatter,"GHTCNT6",this%ghtcnt6) + call MAPL_VarWrite(formatter,"TSURF",this%tsurf) + call MAPL_VarWrite(formatter,"WESNN1",this%wesnn1) + call MAPL_VarWrite(formatter,"WESNN2",this%wesnn2) + call MAPL_VarWrite(formatter,"WESNN3",this%wesnn3) + call MAPL_VarWrite(formatter,"HTSNNN1",this%htsnnn1) + call MAPL_VarWrite(formatter,"HTSNNN2",this%htsnnn2) + call MAPL_VarWrite(formatter,"HTSNNN3",this%htsnnn3) + call MAPL_VarWrite(formatter,"SNDZN1",this%sndzn1) + call MAPL_VarWrite(formatter,"SNDZN2",this%sndzn2) + call MAPL_VarWrite(formatter,"SNDZN3",this%sndzn3) + call MAPL_VarWrite(formatter,"CH",this%ch) + call MAPL_VarWrite(formatter,"CM",this%cm) + call MAPL_VarWrite(formatter,"CQ",this%cq) + call MAPL_VarWrite(formatter,"FR",this%fr) + call MAPL_VarWrite(formatter,"WW",this%ww) + _RETURN(_SUCCESS) + + end subroutine write_shared_nc4 + + subroutine write_bin (this, filename, rc) + class(CatchmentRst), intent(in):: this + character(*), intent(in) :: filename + integer, optional, intent(out) :: rc + integer :: status, unit + character(256) :: Iam = "write_bin" + open(newunit=unit, file=filename, form='unformatted') + write(unit) this% bf1 + write(unit) this% bf2 + write(unit) this% bf3 + write(unit) this% vgwmax + write(unit) this% cdcr1 + write(unit) this% cdcr2 + write(unit) this% psis + write(unit) this% bee + write(unit) this% poros + write(unit) this% wpwet + write(unit) this% cond + write(unit) this% gnu + write(unit) this% ars1 + write(unit) this% ars2 + write(unit) this% ars3 + write(unit) this% ara1 + write(unit) this% ara2 + write(unit) this% ara3 + write(unit) this% ara4 + write(unit) this% arw1 + write(unit) this% arw2 + write(unit) this% arw3 + write(unit) this% arw4 + write(unit) this% tsa1 + write(unit) this% tsa2 + write(unit) this% tsb1 + write(unit) this% tsb2 + write(unit) this% atau + write(unit) this% btau + write(unit) this% ity + write(unit) this% tc + write(unit) this% qc + write(unit) this% capac + write(unit) this% catdef + write(unit) this% rzexc + write(unit) this% srfexc + write(unit) this% ghtcnt1 + write(unit) this% ghtcnt2 + write(unit) this% ghtcnt3 + write(unit) this% ghtcnt4 + write(unit) this% ghtcnt5 + write(unit) this% ghtcnt6 + write(unit) this% tsurf + write(unit) this% wesnn1 + write(unit) this% wesnn2 + write(unit) this% wesnn3 + write(unit) this% htsnnn1 + write(unit) this% htsnnn2 + write(unit) this% htsnnn3 + write(unit) this% sndzn1 + write(unit) this% sndzn2 + write(unit) this% sndzn3 + write(unit) this% ch + write(unit) this% cm + write(unit) this% cq + write(unit) this% fr + write(unit) this% ww + close(unit) + _RETURN(_SUCCESS) + end subroutine write_bin + + subroutine allocate(this, ntiles,rc) + class(CatchmentRst), intent(inout) :: this + integer, intent(in) :: ntiles + integer, optional, intent(out):: rc + allocate( this% bf1(ntiles) ) + allocate( this% bf2(ntiles) ) + allocate( this% bf3(ntiles) ) + allocate( this% vgwmax(ntiles) ) + allocate( this% cdcr1(ntiles) ) + allocate( this% cdcr2(ntiles) ) + allocate( this% psis(ntiles) ) + allocate( this% bee(ntiles) ) + allocate( this% poros(ntiles) ) + allocate( this% wpwet(ntiles) ) + allocate( this% cond(ntiles) ) + allocate( this% gnu(ntiles) ) + allocate( this% ars1(ntiles) ) + allocate( this% ars2(ntiles) ) + allocate( this% ars3(ntiles) ) + allocate( this% ara1(ntiles) ) + allocate( this% ara2(ntiles) ) + allocate( this% ara3(ntiles) ) + allocate( this% ara4(ntiles) ) + allocate( this% arw1(ntiles) ) + allocate( this% arw2(ntiles) ) + allocate( this% arw3(ntiles) ) + allocate( this% arw4(ntiles) ) + allocate( this% tsa1(ntiles) ) + allocate( this% tsa2(ntiles) ) + allocate( this% tsb1(ntiles) ) + allocate( this% tsb2(ntiles) ) + allocate( this% atau(ntiles) ) + allocate( this% btau(ntiles) ) + allocate( this% ity(ntiles) ) + allocate( this% tc(ntiles,4) ) + allocate( this% qc(ntiles,4) ) + allocate( this% capac(ntiles) ) + allocate( this% catdef(ntiles) ) + allocate( this% rzexc(ntiles) ) + allocate( this% srfexc(ntiles) ) + allocate( this% ghtcnt1(ntiles) ) + allocate( this% ghtcnt2(ntiles) ) + allocate( this% ghtcnt3(ntiles) ) + allocate( this% ghtcnt4(ntiles) ) + allocate( this% ghtcnt5(ntiles) ) + allocate( this% ghtcnt6(ntiles) ) + allocate( this% tsurf(ntiles) ) + allocate( this% wesnn1(ntiles) ) + allocate( this% wesnn2(ntiles) ) + allocate( this% wesnn3(ntiles) ) + allocate( this% htsnnn1(ntiles) ) + allocate( this% htsnnn2(ntiles) ) + allocate( this% htsnnn3(ntiles) ) + allocate( this% sndzn1(ntiles) ) + allocate( this% sndzn2(ntiles) ) + allocate( this% sndzn3(ntiles) ) + allocate( this% ch(ntiles,4) ) + allocate( this% cm(ntiles,4) ) + allocate( this% cq(ntiles,4) ) + allocate( this% fr(ntiles,4) ) + allocate( this% ww(ntiles,4) ) + _RETURN(_SUCCESS) + end subroutine allocate + +end module CatchmentRstMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/ScaleCatch.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/ScaleCatch.F90 new file mode 100644 index 000000000..820a9660f --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/ScaleCatch.F90 @@ -0,0 +1,252 @@ +#define I_AM_MAIN +#include "MAPL_Generic.h" + +program ScaleCatch + + use MAPL + use LSM_ROUTINES, ONLY: & + catch_calc_soil_moist, & + catch_calc_tp, & + catch_calc_ght + + USE CATCH_CONSTANTS, ONLY: & + N_GT => CATCH_N_GT, & + DZGT => CATCH_DZGT, & + PEATCLSM_POROS_THRESHOLD + + use CatchmentRstMod + use CatchmentCNRstMod + + implicit none + + character(256) :: old_fname, new_fname, scale_fname, cnclm + integer :: ntiles, n, nargs + integer :: iargc + real :: SURFLAY ! (Ganymed-3 and earlier) SURFLAY=20.0 for Old Soil Params + ! (Ganymed-4 and later ) SURFLAY=50.0 for New Soil Params + real :: WEMIN_IN, WEMIN_OUT + character*256 :: arg(7) + + + class(CatchmentRst), allocatable :: old_catch, new_catch, scale_catch + + real, allocatable, dimension(:) :: dzsf, ar1, ar2, ar4 + real, allocatable, dimension(:,:) :: TP_IN, GHT_IN, FICE, GHT_OUT, TP_OUT + real, allocatable, dimension(:) :: swe_in, depth_in, areasc_in, areasc_out, depth_out + + type(Netcdf4_fileformatter) :: formatter + type(Filemetadata) :: meta + integer :: i, rc, filetype + integer :: status + character(256) :: Iam = "ScaleCatch" + +! Usage +! ----- + if (iargc() /= 6) then + write(*,*) "Usage: ScaleCatch.x " + call exit(2) + end if + + do n=1,7 + call getarg(n,arg(n)) + enddo + +! Open INPUT and Regridded Catch Files +! ------------------------------------ + read(arg(1),'(a)') old_fname + + read(arg(2),'(a)') new_fname + +! Open OUTPUT (Scaled) Catch File +! ------------------------------- + read(arg(3),'(a)') scale_fname +! Get SURFLAY Value +! ----------------- + read(arg(4),*) SURFLAY + read(arg(5),*) WEMIN_IN + read(arg(6),*) WEMIN_OUT +! catch or catchcn? + read(arg(7),'(a)') cnclm + + if (index(cnclm,'40') /=0 .or. index(cnclm,'45') /=0 ) then + allocate(old_catch, source = CatchmentCNRst(old_fname, cnclm)) + allocate(new_catch, source = CatchmentCNRst(new_fname, cnclm)) + allocate(scale_catch, source = new_catch) + else + allocate(old_catch, source = CatchmentRst(old_fname)) + allocate(new_catch, source = CatchmentRst(new_fname)) + allocate(scale_catch, source = new_catch) + endif + + if (SURFLAY.ne.20 .and. SURFLAY.ne.50) then + print *, "You must supply a valid SURFLAY value:" + print *, "(Ganymed-3 and earlier) SURFLAY=20.0 for Old Soil Params" + print *, "(Ganymed-4 and later ) SURFLAY=50.0 for New Soil Params" + call exit(2) + end if + print *, 'SURFLAY: ',SURFLAY + +! 1) soil moisture prognostics +! ---------------------------- + n =count((old_catch%catdef .gt. old_catch%cdcr1)) + + write(6,200) n,100*n/ntiles + +! Scale rxexc regardless of CDCR1, CDCR2 differences +! -------------------------------------------------- + scale_catch%rzexc = old_catch%rzexc * ( new_catch%vgwmax / & + old_catch%vgwmax ) + +! Scale catdef regardless of whether CDCR2 is larger or smaller in the new situation +! ---------------------------------------------------------------------------------- + where (old_catch%catdef .gt. old_catch%cdcr1) + + scale_catch%catdef = new_catch%cdcr1 + & + ( old_catch%catdef-old_catch%cdcr1 ) / & + ( old_catch%cdcr2 -old_catch%cdcr1 ) * & + ( new_catch%cdcr2 -new_catch%cdcr1 ) + end where + +! Scale catdef also for the case where catdef le cdcr1. +! ----------------------------------------------------- + where( (old_catch%catdef .le. old_catch%cdcr1)) + scale_catch%catdef = old_catch%catdef * (new_catch%cdcr1 / old_catch%cdcr1) + end where + +! Sanity Check (catch_calc_soil_moist() forces consistency betw. srfexc, rzexc, catdef) +! ------------ + print *, 'Performing Sanity Check ...' + allocate ( dzsf(ntiles) ) + allocate ( ar1( ntiles) ) + allocate ( ar2( ntiles) ) + allocate ( ar4( ntiles) ) + + dzsf = SURFLAY + + call catch_calc_soil_moist( ntiles, dzsf, & + scale_catch%vgwmax, scale_catch%cdcr1, scale_catch%cdcr2, & + scale_catch%psis, scale_catch%bee, scale_catch%poros, scale_catch%wpwet, & + scale_catch%ars1, scale_catch%ars2, scale_catch%ars3, & + scale_catch%ara1, scale_catch%ara2, scale_catch%ara3, scale_catch%ara4, & + scale_catch%arw1, scale_catch%arw2, scale_catch%arw3, scale_catch%arw4, & + scale_catch%bf1, scale_catch%bf2, & + scale_catch%srfexc, scale_catch%rzexc, scale_catch%catdef, & + ar1, ar2, ar4 ) + + n = count( scale_catch%catdef .ne. new_catch%catdef ) + write(6,300) n,100*n/ntiles + n = count( scale_catch%srfexc .ne. new_catch%srfexc ) + write(6,400) n,100*n/ntiles + n = count( scale_catch%rzexc .ne. new_catch%rzexc ) + write(6,400) n,100*n/ntiles + +! (2) Ground heat +! --------------- + + allocate (TP_IN (N_GT, Ntiles)) + allocate (GHT_IN (N_GT, Ntiles)) + allocate (GHT_OUT(N_GT, Ntiles)) + allocate (FICE (N_GT, NTILES)) + allocate (TP_OUT (N_GT, Ntiles)) + + GHT_IN (1,:) = old_catch%ghtcnt1 + GHT_IN (2,:) = old_catch%ghtcnt2 + GHT_IN (3,:) = old_catch%ghtcnt3 + GHT_IN (4,:) = old_catch%ghtcnt4 + GHT_IN (5,:) = old_catch%ghtcnt5 + GHT_IN (6,:) = old_catch%ghtcnt6 + + call catch_calc_tp ( NTILES, old_catch%poros, GHT_IN, tp_in, FICE) + GHT_OUT = GHT_IN + +! open (99,file='ght.diff', form = 'formatted') + + do n = 1, ntiles + do i = 1, N_GT + call catch_calc_ght(dzgt(i), new_catch%poros(n), tp_in(i,n), fice(i,n), GHT_IN(i,n)) +! if (i == N_GT) then +! if (GHT_IN(i,n) /= GHT_OUT(i,n)) write (99,*)n,old_catch%poros(n),new_catch%poros(n),ABS(GHT_IN(i,n)-GHT_OUT(i,n)) +! endif + end do + end do + + scale_catch%ghtcnt1 = GHT_IN (1,:) + scale_catch%ghtcnt2 = GHT_IN (2,:) + scale_catch%ghtcnt3 = GHT_IN (3,:) + scale_catch%ghtcnt4 = GHT_IN (4,:) + scale_catch%ghtcnt5 = GHT_IN (5,:) + scale_catch%ghtcnt6 = GHT_IN (6,:) + +! Deep soil temp sanity check +! --------------------------- + + call catch_calc_tp ( NTILES, new_catch%poros, GHT_IN, tp_out, FICE) + + print *, 'Percent tiles TP Layer 1 differ : ', 100.* count(ABS(tp_out(1,:) - tp_in(1,:)) > 1.e-5) /float (Ntiles) + print *, 'Percent tiles TP Layer 2 differ : ', 100.* count(ABS(tp_out(2,:) - tp_in(2,:)) > 1.e-5) /float (Ntiles) + print *, 'Percent tiles TP Layer 3 differ : ', 100.* count(ABS(tp_out(3,:) - tp_in(3,:)) > 1.e-5) /float (Ntiles) + print *, 'Percent tiles TP Layer 4 differ : ', 100.* count(ABS(tp_out(4,:) - tp_in(4,:)) > 1.e-5) /float (Ntiles) + print *, 'Percent tiles TP Layer 5 differ : ', 100.* count(ABS(tp_out(5,:) - tp_in(5,:)) > 1.e-5) /float (Ntiles) + print *, 'Percent tiles TP Layer 6 differ : ', 100.* count(ABS(tp_out(6,:) - tp_in(6,:)) > 1.e-5) /float (Ntiles) + + +! SNOW scaling +! ------------ + + if(wemin_out /= wemin_in) then + + allocate (swe_in (Ntiles)) + allocate (depth_in (Ntiles)) + allocate (depth_out (Ntiles)) + allocate (areasc_in (Ntiles)) + allocate (areasc_out (Ntiles)) + + swe_in = new_catch%wesnn1 + new_catch%wesnn2 + new_catch%wesnn3 + depth_in = new_catch%sndzn1 + new_catch%sndzn2 + new_catch%sndzn3 + areasc_in = min(swe_in/wemin_in, 1.) + areasc_out= min(swe_in/wemin_out,1.) + + where (swe_in .gt. 0.) + where (areasc_in .lt. 1. .or. areasc_out .lt. 1.) + ! density_in= swe_in/(areasc_in * depth_in + 1.e-20) + ! depth_out = swe_in/(areasc_out*density_in) + depth_out = areasc_in * depth_in/(areasc_out + 1.e-20) + scale_catch%sndzn1 = depth_out/3. + scale_catch%sndzn2 = depth_out/3. + scale_catch%sndzn3 = depth_out/3. + endwhere + endwhere + + print *, 'Snow scaling summary' + print *, '....................' + print *, 'Percent tiles SNDZ scaled : ', 100.* count (scale_catch%sndzn3 .ne. old_catch%sndzn3) /float (count (scale_catch%sndzn3 > 0.)) + + endif + + ! PEATCLSM - ensure low CATDEF on peat tiles where "old" restart is not also peat + ! ------------------------------------------------------------------------------- + + where ( (old_catch%poros < PEATCLSM_POROS_THRESHOLD) .and. (scale_catch%poros >= PEATCLSM_POROS_THRESHOLD) ) + scale_catch%catdef = 25. + scale_catch%rzexc = 0. + scale_catch%srfexc = 0. + end where + +! Write Scaled Catch +! ------------------ + if (filetype ==0) then + call formatter%open(new_fname, pFIO_READ, __RC__) + meta = formatter%read(__RC__) + call formatter%close() + call scale_catch%write_nc4(scale_fname, meta, cnclm, __RC__) + else + call scale_catch%write_bin(scale_fname, __RC__) + end if + +100 format(1x,'Total Tiles: ',i10) +200 format(1x,'Scaled Tiles: ',i10,2x,'(',i2.2,'%)') +300 format(1x,'CatDef Tiles: ',i10,2x,'(',i2.2,'%)') +400 format(1x,'SrfExc Tiles: ',i10,2x,'(',i2.2,'%)') +500 format(1x,' Rzexc Tiles: ',i10,2x,'(',i2.2,'%)') + + end program From 325e8c8ae0e3d706cc8adecec004f527dd2b14f5 Mon Sep 17 00:00:00 2001 From: Weiyuan Jiang Date: Wed, 6 Apr 2022 16:01:49 -0400 Subject: [PATCH 03/17] add add_bcs_to_rst subroutines --- .../Utils/mk_restarts/CatchmentCNRst.F90 | 322 ++++++++++++++- .../Utils/mk_restarts/CatchmentRst.F90 | 383 +++++++++++------- 2 files changed, 536 insertions(+), 169 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentCNRst.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentCNRst.F90 index 2442043d2..a4f4c8de1 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentCNRst.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentCNRst.F90 @@ -13,7 +13,19 @@ module CatchmentCNRstMod use CatchmentRstMod, only : CatchmentRst implicit none - type, extends(CatchmentRst) :: CatchmentCNRst + integer, parameter :: nveg = integer, parameter :: nveg = 4 + integer, parameter :: nzone = 3 + integer, parameter :: VAR_COL_CLM40 = 40 ! number of CN column restart variables + integer, parameter :: VAR_PFT_CLM40 = 74 ! number of CN PFT variables per column + integer, parameter :: npft = 19 + integer, parameter :: npft_clm45 = 19 + integer, parameter :: VAR_COL_CLM45 = 35 ! number of CN column restart variables + integer, parameter :: VAR_PFT_CLM45 = 75 ! number of CN PFT variables per column + + type, extends(CatchmentRst) :: CatchmentCNRst + logical :: isCLM45 + integer :: VAR_COL + integer :: VAR_PFT real, allocatable :: cnity(:,:) real, allocatable :: fvg(:,:) real, allocatable :: tg(:,:) @@ -33,7 +45,8 @@ module CatchmentCNRstMod real, allocatable :: PEATF (:) contains procedure :: write_nc4 - procedure :: allocatecn + procedure :: allocate_cn + procedure :: add_bcs_to_rst endtype CatchmentCNRst interface CatchmentCNRst @@ -42,7 +55,7 @@ module CatchmentCNRstMod contains - function CatchmentCNRst_create(filename,cnclm,rc) result (catch) + function CatchmentCNRst_create(filename, cnclm, rc) result (catch) type(CatchmentCNRst) :: catch character(*), intent(in) :: filename character(*), intent(in) :: cnclm @@ -60,10 +73,23 @@ function CatchmentCNRst_create(filename,cnclm,rc) result (catch) if (filetype /= 0) then _ASSERT( .false., "CatchmentCN only support nc4 file restart") endif - + + catch%isCLM45 = .false. call formatter%open(filename, pFIO_READ, __RC__) meta = formatter%read(__RC__) ntiles = meta%get_dimension('tile', __RC__) + catch%ntiles = ntiles + if (index(cnclm, '40' /=0) then + catch%VAR_COL = VAR_COL_CLM40 + catch%VAR_PFT = VAR_PFT_CLM40 + endif + if (index(cnclm, '45' /=0) then + catch%VAR_COL = VAR_COL_CLM45 + catch%VAR_PFT = VAR_PFT_CLM45 + catch%isCLM45 = .true. + endif + + call catch%allocate_cn(__RC__) call catch%read_shared_nc4(formatter, __RC__) myVariable => meta%get_variable("ITY") @@ -86,7 +112,7 @@ function CatchmentCNRst_create(filename,cnclm,rc) result (catch) myVariable => meta%get_variable("CNCOL") dname => myVariable%get_ith_dimension(2) dim1 = meta%get_dimension(dname) - if(index(cnclm,'45') /=0) then + if( catch%isCLM45) then call MAPL_VarRead(formatter,"ABM", catch%ABM, __RC__) call MAPL_VarRead(formatter,"FIELDCAP",catch%FIELDCAP, __RC__) call MAPL_VarRead(formatter,"HDM", catch%HDM , __RC__) @@ -113,25 +139,20 @@ function CatchmentCNRst_create(filename,cnclm,rc) result (catch) if (present(rc)) rc =0 end function CatchmentCNRst_Create - subroutine write_nc4(this, filename, meta, cnclm, rc) + subroutine write_nc4(this, filename, meta, rc) class(CatchmentCNRst), intent(inout):: this character(*), intent(in) :: filename type(FileMetadata), intent(inout) :: meta - character(*), intent(in) :: cnclm integer, optional, intent(out):: rc type(Netcdf4_fileformatter) :: formatter integer :: status character(256) :: Iam = "write_nc4" - logical :: clm45 integer :: i,j, dim1,dim2 real, dimension (:), allocatable :: var type(Variable), pointer :: myVariable character(len=:), pointer :: dname - clm45 = .false. - if (index(cnclm,'45') /=0) clm45 = .true. - call formatter%create(filename, __RC__) call formatter%write(meta, __RC__) @@ -186,7 +207,7 @@ subroutine write_nc4(this, filename, meta, cnclm, rc) call MAPL_VarWrite(formatter,"RZMM",var,offset1=j) end do - if (clm45) then + if (this%isCLM45) then do j=1,dim1 call MAPL_VarWrite(formatter,"SFMM", var,offset1=j) enddo @@ -224,13 +245,17 @@ subroutine write_nc4(this, filename, meta, cnclm, rc) _RETURN(_SUCCESS) end subroutine write_nc4 - subroutine allocatecn(this, ntiles, ncol, npft, rc) + subroutine allocate_cn(this, ncol, npft, rc) class(CatchmentCNRst), intent(inout) :: this - integer, intent(in) :: ntiles,ncol,npft + integer, intent(in) :: ncol,npft integer, optional, intent(out):: rc integer :: status - call this%CatchmentRst%allocate(ntiles, __RC__) + ntiles = this%ntiles + ncol = nzone* this%VAR_COL + npft = nzone*nveg*this%VAR_PFT + + call this%CatchmentRst%allocate_catch(__RC__) allocate(this%cnity(ntiles,4)) allocate(this%fvg(ntiles,4)) @@ -252,4 +277,271 @@ subroutine allocatecn(this, ntiles, ncol, npft, rc) _RETURN(_SUCCESS) end subroutine allocatecn + SUBROUTINE add_bcs_to_rst (this, SURFLAY, DataDir,rc) + class(CatchmentCNRst), intent(inout) :: this + real, intent (in) :: SURFLAY + character(*), intent (in) :: DataDir + integer, optional, intent(out) :: rc + real, allocatable :: CLMC_pf1(:), CLMC_pf2(:), CLMC_sf1(:), CLMC_sf2(:) + real, allocatable :: CLMC_pt1(:), CLMC_pt2(:), CLMC_st1(:), CLMC_st2(:) + real, allocatable :: CLMC45_pf1(:), CLMC45_pf2(:), CLMC45_sf1(:), CLMC45_sf2(:) + real, allocatable :: CLMC45_pt1(:), CLMC45_pt2(:), CLMC45_st1(:), CLMC45_st2(:) + real, allocatable :: NDEP(:), BVISDR(:), BVISDF(:), BNIRDR(:), BNIRDF(:) + real, allocatable :: T2(:), var1(:), hdm(:), fc(:), gdp(:), peatf(:) + integer, allocatable :: ity(:), abm (:) + integer :: STATUS, ntiles, uit27, unit28, unit29, unit30 + integer :: idum, i,j,n, ib, nv + real :: rdum, zdep1, zdep2, zdep3, zmet, term1, term2, bare,fvg(4) + logical :: NEWLAND + logical :: file_exists + + type(NetCDF4_Fileformatter) :: CatchCNFmt + character*256 :: Iam = "add_bcs" + + call this%CatchmentRst%add_bcs(surflay, DataDir, __RC__) + ntiles = this%ntiles + allocate (BVISDR(ntiles), BVISDF(ntiles), BNIRDR(ntiles) ) + allocate (BNIRDF(ntiles), T2(ntiles), NDEP(ntiles) ) + allocate (CLMC_pf1(ntiles), CLMC_pf2(ntiles), CLMC_sf1(ntiles)) + allocate (CLMC_sf2(ntiles), CLMC_pt1(ntiles), CLMC_pt2(ntiles)) + allocate (CLMC45_pf1(ntiles), CLMC45_pf2(ntiles), CLMC45_sf1(ntiles)) + allocate (CLMC45_sf2(ntiles), CLMC45_pt1(ntiles), CLMC45_pt2(ntiles)) + allocate (CLMC_st1(ntiles), CLMC_st2(ntiles)) + allocate (CLMC45_st1(ntiles), CLMC45_st2(ntiles)) + allocate (hdm(ntiles), fc(ntiles), gdp(ntiles)) + allocate (peatf(ntiles), abm(ntiles), var1(ntiles) + + inquire(file = trim(DataDir)//'/catchcn_params.nc4', exist=file_exists) + inquire(file = trim(DataDir)//"CLM_veg_typs_fracs" ,exist=NewLand ) + _ASSERT(Newland, "catchcn should get bc from newland") + + if(file_exists) then + call CatchCNFmt%Open(trim(DataDir)//'/catchcn_params.nc4', pFIO_READ, __RC__) + call MAPL_VarRead ( CatchCNFmt ,'BGALBNF', BNIRDF, __RC__) + call MAPL_VarRead ( CatchCNFmt ,'BGALBNR', BNIRDR, __RC__) + call MAPL_VarRead ( CatchCNFmt ,'BGALBVF', BVISDF, __RC__) + call MAPL_VarRead ( CatchCNFmt ,'BGALBVR', BVISDR, __RC__) + call MAPL_VarRead ( CatchCNFmt ,'NDEP', NDEP, __RC__) + call MAPL_VarRead ( CatchCNFmt ,'T2_M', T2, __RC__) + call MAPL_VarRead(CatchCNFmt,'ITY',CLMC_pt1,offset1=1, __RC__) ! 30 + call MAPL_VarRead(CatchCNFmt,'ITY',CLMC_pt2,offset1=2, __RC__) ! 31 + call MAPL_VarRead(CatchCNFmt,'ITY',CLMC_st1,offset1=3, __RC__) ! 32 + call MAPL_VarRead(CatchCNFmt,'ITY',CLMC_st2,offset1=4, __RC__) ! 33 + call MAPL_VarRead(CatchCNFmt,'FVG',CLMC_pf1,offset1=1, __RC__) ! 34 + call MAPL_VarRead(CatchCNFmt,'FVG',CLMC_pf2,offset1=2, __RC__) ! 35 + call MAPL_VarRead(CatchCNFmt,'FVG',CLMC_sf1,offset1=3, __RC__) ! 36 + call MAPL_VarRead(CatchCNFmt,'FVG',CLMC_sf2,offset1=4, __RC__) ! 37 + call CatchCNFmt%close() + else + + open(newunit=unit27, file=trim(DataDir)//'CLM_veg_typs_fracs' ,form='formatted') + open(newunit=unit28, file=trim(DataDir)//'CLM_NDep_SoilAlb_T2m' ,form='formatted') + + do n=1,ntiles + read (unit27, *) i,j, CLMC_pt1(n), CLMC_pt2(n), CLMC_st1(n), CLMC_st2(n), & + CLMC_pf1(n), CLMC_pf2(n), CLMC_sf1(n), CLMC_sf2(n) + + read (unit28, *) NDEP(n), BVISDR(n), BVISDF(n), BNIRDR(n), BNIRDF(n), T2(n) ! MERRA-2 Annual Mean Temp is default. + if(this%isCLM45) then + endif + end do + + CLOSE (unit27, STATUS = 'KEEP') + CLOSE (unit28, STATUS = 'KEEP') + + endif + + if (this%isCLM45 ) then + + open(newunit=unit29, file=trim(DataDir)//'CLM4.5_veg_typs_fracs',form='formatted') + open(newunit=unit30, file=trim(DataDir)//'CLM4.5_abm_peatf_gdp_hdm_fc' ,form='formatted') + do n=1,ntiles + read (unit29, *) i,j, CLMC45_pt1(n), CLMC45_pt2(n), CLMC45_st1(n), CLMC45_st2(n), & + CLMC45_pf1(n), CLMC45_pf2(n), CLMC45_sf1(n), CLMC45_sf2(n) + read (unit30, *) i, j, abm(n), peatf(n), & + gdp(n), hdm(n), fc(n) + end do + CLOSE (unit29, STATUS = 'KEEP') + CLOSE (unit30, STATUS = 'KEEP') + endif + + do n=1,ntiles + BVISDR(n) = amax1(1.e-6, BVISDR(n)) + BVISDF(n) = amax1(1.e-6, BVISDF(n)) + BNIRDR(n) = amax1(1.e-6, BNIRDR(n)) + BNIRDF(n) = amax1(1.e-6, BNIRDF(n)) + + ! convert % to fractions + + CLMC_pf1(n) = CLMC_pf1(n) / 100. + CLMC_pf2(n) = CLMC_pf2(n) / 100. + CLMC_sf1(n) = CLMC_sf1(n) / 100. + CLMC_sf2(n) = CLMC_sf2(n) / 100. + + fvg(1) = CLMC_pf1(n) + fvg(2) = CLMC_pf2(n) + fvg(3) = CLMC_sf1(n) + fvg(4) = CLMC_sf2(n) + + BARE = 1. + + DO NV = 1, NVEG + BARE = BARE - FVG(NV)! subtract vegetated fractions + END DO + + if (BARE /= 0.) THEN + IB = MAXLOC(FVG(:),1) + FVG (IB) = FVG(IB) + BARE ! This also corrects all cases sum ne 0. + ENDIF + + CLMC_pf1(n) = fvg(1) + CLMC_pf2(n) = fvg(2) + CLMC_sf1(n) = fvg(3) + CLMC_sf2(n) = fvg(4) + enddo + + if(this%isCLM45) then + do n =1, ntiles + CLMC45_pf1(n) = CLMC45_pf1(n) / 100. + CLMC45_pf2(n) = CLMC45_pf2(n) / 100. + CLMC45_sf1(n) = CLMC45_sf1(n) / 100. + CLMC45_sf2(n) = CLMC45_sf2(n) / 100. + + fvg(1) = CLMC45_pf1(n) + fvg(2) = CLMC45_pf2(n) + fvg(3) = CLMC45_sf1(n) + fvg(4) = CLMC45_sf2(n) + + BARE = 1. + + DO NV = 1, NVEG + BARE = BARE - fvg(NV)! subtract vegetated fractions + END DO + + if (BARE /= 0.) THEN + IB = MAXLOC(fvg(:),1) + fvg (IB) = fvg(IB) + BARE ! This also corrects all cases sum ne 0. + ENDIF + + CLMC45_pf1(n) = fvg(1) + CLMC45_pf2(n) = fvg(2) + CLMC45_sf1(n) = fvg(3) + CLMC45_sf2(n) = fvg(4) + enddo + endif + + NDEP = NDEP * 1.e-9 + + ! prevent trivial fractions + ! ------------------------- + do n = 1,ntiles + if(CLMC_pf1(n) <= 1.e-4) then + CLMC_pf2(n) = CLMC_pf2(n) + CLMC_pf1(n) + CLMC_pf1(n) = 0. + endif + + if(CLMC_pf2(n) <= 1.e-4) then + CLMC_pf1(n) = CLMC_pf1(n) + CLMC_pf2(n) + CLMC_pf2(n) = 0. + endif + + if(CLMC_sf1(n) <= 1.e-4) then + if(CLMC_sf2(n) > 1.e-4) then + CLMC_sf2(n) = CLMC_sf2(n) + CLMC_sf1(n) + else if(CLMC_pf2(n) > 1.e-4) then + CLMC_pf2(n) = CLMC_pf2(n) + CLMC_sf1(n) + else if(CLMC_pf1(n) > 1.e-4) then + CLMC_pf1(n) = CLMC_pf1(n) + CLMC_sf1(n) + else + stop 'fveg3' + endif + CLMC_sf1(n) = 0. + endif + + if(CLMC_sf2(n) <= 1.e-4) then + if(CLMC_sf1(n) > 1.e-4) then + CLMC_sf1(n) = CLMC_sf1(n) + CLMC_sf2(n) + else if(CLMC_pf2(n) > 1.e-4) then + CLMC_pf2(n) = CLMC_pf2(n) + CLMC_sf2(n) + else if(CLMC_pf1(n) > 1.e-4) then + CLMC_pf1(n) = CLMC_pf1(n) + CLMC_sf2(n) + else + stop 'fveg4' + endif + CLMC_sf2(n) = 0. + endif + enddo + if (this%isCLM45) then + do n = 1, ntiles + if(CLMC45_pf1(n) <= 1.e-4) then + CLMC45_pf2(n) = CLMC45_pf2(n) + CLMC45_pf1(n) + CLMC45_pf1(n) = 0. + endif + + if(CLMC45_pf2(n) <= 1.e-4) then + CLMC45_pf1(n) = CLMC45_pf1(n) + CLMC45_pf2(n) + CLMC45_pf2(n) = 0. + endif + + if(CLMC45_sf1(n) <= 1.e-4) then + if(CLMC45_sf2(n) > 1.e-4) then + CLMC45_sf2(n) = CLMC45_sf2(n) + CLMC45_sf1(n) + else if(CLMC45_pf2(n) > 1.e-4) then + CLMC45_pf2(n) = CLMC45_pf2(n) + CLMC45_sf1(n) + else if(CLMC45_pf1(n) > 1.e-4) then + CLMC45_pf1(n) = CLMC45_pf1(n) + CLMC45_sf1(n) + else + stop 'fveg3' + endif + CLMC45_sf1(n) = 0. + endif + + if(CLMC45_sf2(n) <= 1.e-4) then + if(CLMC45_sf1(n) > 1.e-4) then + CLMC45_sf1(n) = CLMC45_sf1(n) + CLMC45_sf2(n) + else if(CLMC45_pf2(n) > 1.e-4) then + CLMC45_pf2(n) = CLMC45_pf2(n) + CLMC45_sf2(n) + else if(CLMC45_pf1(n) > 1.e-4) then + CLMC45_pf1(n) = CLMC45_pf1(n) + CLMC45_sf2(n) + else + stop 'fveg4' + endif + CLMC45_sf2(n) = 0. + endif + enddo + endif + + this%cnity(:,1) = CLMC_pt1 + this%cnity(:,2) = CLMC_pt2 + this%cnity(:,3) = CLMC_st1 + this%cnity(:,4) = CLMC_st2 + this%fvg(:,1) = CLMC_pf1 + this%fvg(:,2) = CLMC_pf2 + this%fvg(:,3) = CLMC_sf1 + this%fvg(:,4) = CLMC_sf2 + + this%ndep = ndep + this%t2 = t2 + this%BGALBVR = BVISDR + this%BGALBVF = BVISDF + this%BGALBNR = BNIRDR + this%BGALBNF = BNIRDF + + if(this%isCLM45) then + this%abm = real(abm) + this%fieldcap = fc + this%hdm = hdm + this%gdp = gdp + this%peatf = peatf + endif + + deallocate (BVISDR, BVISDF, BNIRDR ) + deallocate (BNIRDF, T2, NDEP ) + deallocate (CLMC_pf1, CLMC_pf2, CLMC_sf1) + deallocate (CLMC_sf2, CLMC_pt1, CLMC_pt2) + deallocate (CLMC_st1,CLMC_st2) + + _RETURN(_SUCCESS) + END SUBROUTINE add_bcs_to_rst + end module CatchmentCNRstMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentRst.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentRst.F90 index 23fe0f4cf..d6faba569 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentRst.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentRst.F90 @@ -17,6 +17,7 @@ module CatchmentRstMod external :: ftell #endif type :: CatchmentRst + integer :: ntiles real, allocatable :: bf1(:) real, allocatable :: bf2(:) real, allocatable :: bf3(:) @@ -75,11 +76,12 @@ module CatchmentRstMod real, allocatable :: fr(:,:) real, allocatable :: ww(:,:) contains - procedure :: write_bin + procedure :: read_GEOSldas_rst_bin procedure :: write_nc4 procedure :: read_shared_nc4 - procedure :: write_shared_nc4 - procedure :: allocate + procedure :: write_shared_nc4 + procedure :: add_bcs_to_rst + procedure :: allocate_catch endtype CatchmentRst interface CatchmentRst @@ -90,97 +92,109 @@ module CatchmentRstMod function CatchmentRst_create(filename, rc) result (catch) type(CatchmentRst) :: catch - character(*), intent(in) :: filename + character(*), intent(in) :: filename integer, optional, intent(out) :: rc integer :: status character(len=256) :: Iam = "CatchmentRst_create" type(Netcdf4_fileformatter) :: formatter integer :: filetype, ntiles, unit type(FileMetadata) :: meta - integer :: bpos, epos - - - call MAPL_NCIOGetFileType(filename, filetype, __RC__) - if (filetype == 0) then - ! nc4 format - call formatter%open(filename, pFIO_READ, __RC__) - meta = formatter%read(__RC__) - ntiles = meta%get_dimension('tile', __RC__) - call catch%allocate(ntiles) - call catch%read_shared_nc4(formatter, __RC__) - call MAPL_VarRead(formatter,"OLD_ITY",catch%ity, __RC__) - call formatter%close() - - else ! binary - open(newunit=unit, file=filename, form='unformatted') - bpos=0 - read(unit) - epos = ftell(unit) ! ending position of file pointer - ntiles = (epos-bpos)/4-2 ! record size (in 4 byte words; - rewind(unit) - call catch%allocate(ntiles) - read(unit) catch% bf1 - read(unit) catch% bf2 - read(unit) catch% bf3 - read(unit) catch% vgwmax - read(unit) catch% cdcr1 - read(unit) catch% cdcr2 - read(unit) catch% psis - read(unit) catch% bee - read(unit) catch% poros - read(unit) catch% wpwet - read(unit) catch% cond - read(unit) catch% gnu - read(unit) catch% ars1 - read(unit) catch% ars2 - read(unit) catch% ars3 - read(unit) catch% ara1 - read(unit) catch% ara2 - read(unit) catch% ara3 - read(unit) catch% ara4 - read(unit) catch% arw1 - read(unit) catch% arw2 - read(unit) catch% arw3 - read(unit) catch% arw4 - read(unit) catch% tsa1 - read(unit) catch% tsa2 - read(unit) catch% tsb1 - read(unit) catch% tsb2 - read(unit) catch% atau - read(unit) catch% btau - read(unit) catch% ity - read(unit) catch% tc - read(unit) catch% qc - read(unit) catch% capac - read(unit) catch% catdef - read(unit) catch% rzexc - read(unit) catch% srfexc - read(unit) catch% ghtcnt1 - read(unit) catch% ghtcnt2 - read(unit) catch% ghtcnt3 - read(unit) catch% ghtcnt4 - read(unit) catch% ghtcnt5 - read(unit) catch% ghtcnt6 - read(unit) catch% tsurf - read(unit) catch% wesnn1 - read(unit) catch% wesnn2 - read(unit) catch% wesnn3 - read(unit) catch% htsnnn1 - read(unit) catch% htsnnn2 - read(unit) catch% htsnnn3 - read(unit) catch% sndzn1 - read(unit) catch% sndzn2 - read(unit) catch% sndzn3 - read(unit) catch% ch - read(unit) catch% cm - read(unit) catch% cq - read(unit) catch% fr - read(unit) catch% ww - close(unit) + integer :: bpos, epos, n + + call MAPL_NCIOGetFileType(filename, filetype, __RC__) + + if(filetype == 0) then + ! nc4 format + call formatter%open(filename, pFIO_READ, __RC__) + meta = formatter%read(__RC__) + ntiles = meta%get_dimension('tile', __RC__) + this%ntiles = ntiles + call catch%allocate_catch() + call catch%read_shared_nc4(formatter, __RC__) + call MAPL_VarRead(formatter,"OLD_ITY",catch%ity, __RC__) + call formatter%close() + else + !GEOSldas binary + open(newunit=unit, file=filename, form='unformatted', action = 'read') + bpos=0 + read(unit) + epos = ftell(unit) ! ending position of file pointer + close(unit) + ntiles = (epos-bpos)/4-2 ! record size (in 4 byte words; + this%ntiles = ntiles + call catch%allocate_catch() + call catch%read_GEOSldas_rst_bin(filename, __RC__) endif _RETURN(_SUCCESS) end function CatchmentRst_Create + subroutine read_GEOSldas_rst_bin(this, filename, rc) + class(CatchmentRst), intent(inout) :: this + character(*), intent(in) :: filename + integer, optional, intent(out) :: rc + integer :: unit + open(newunit=unit, file=filename, form='unformatted', action='read') + read(unit) catch% bf1 + read(unit) catch% bf2 + read(unit) catch% bf3 + read(unit) catch% vgwmax + read(unit) catch% cdcr1 + read(unit) catch% cdcr2 + read(unit) catch% psis + read(unit) catch% bee + read(unit) catch% poros + read(unit) catch% wpwet + read(unit) catch% cond + read(unit) catch% gnu + read(unit) catch% ars1 + read(unit) catch% ars2 + read(unit) catch% ars3 + read(unit) catch% ara1 + read(unit) catch% ara2 + read(unit) catch% ara3 + read(unit) catch% ara4 + read(unit) catch% arw1 + read(unit) catch% arw2 + read(unit) catch% arw3 + read(unit) catch% arw4 + read(unit) catch% tsa1 + read(unit) catch% tsa2 + read(unit) catch% tsb1 + read(unit) catch% tsb2 + read(unit) catch% atau + read(unit) catch% btau + read(unit) catch% ity + read(unit) catch% tc + read(unit) catch% qc + read(unit) catch% capac + read(unit) catch% catdef + read(unit) catch% rzexc + read(unit) catch% srfexc + read(unit) catch% ghtcnt1 + read(unit) catch% ghtcnt2 + read(unit) catch% ghtcnt3 + read(unit) catch% ghtcnt4 + read(unit) catch% ghtcnt5 + read(unit) catch% ghtcnt6 + read(unit) catch% tsurf + read(unit) catch% wesnn1 + read(unit) catch% wesnn2 + read(unit) catch% wesnn3 + read(unit) catch% htsnnn1 + read(unit) catch% htsnnn2 + read(unit) catch% htsnnn3 + read(unit) catch% sndzn1 + read(unit) catch% sndzn2 + read(unit) catch% sndzn3 + read(unit) catch% ch + read(unit) catch% cm + read(unit) catch% cq + read(unit) catch% fr + read(unit) catch% ww + close(unit) + _RETURN(_SUCCESS) + end subroutine read_GEOSldas_rst_bin + subroutine read_shared_nc4(this, formatter, rc) class(CatchmentRst), intent(inout):: this type(Netcdf4_fileformatter),intent(inout) :: formatter @@ -335,78 +349,11 @@ subroutine write_shared_nc4(this, formatter, rc) end subroutine write_shared_nc4 - subroutine write_bin (this, filename, rc) - class(CatchmentRst), intent(in):: this - character(*), intent(in) :: filename - integer, optional, intent(out) :: rc - integer :: status, unit - character(256) :: Iam = "write_bin" - open(newunit=unit, file=filename, form='unformatted') - write(unit) this% bf1 - write(unit) this% bf2 - write(unit) this% bf3 - write(unit) this% vgwmax - write(unit) this% cdcr1 - write(unit) this% cdcr2 - write(unit) this% psis - write(unit) this% bee - write(unit) this% poros - write(unit) this% wpwet - write(unit) this% cond - write(unit) this% gnu - write(unit) this% ars1 - write(unit) this% ars2 - write(unit) this% ars3 - write(unit) this% ara1 - write(unit) this% ara2 - write(unit) this% ara3 - write(unit) this% ara4 - write(unit) this% arw1 - write(unit) this% arw2 - write(unit) this% arw3 - write(unit) this% arw4 - write(unit) this% tsa1 - write(unit) this% tsa2 - write(unit) this% tsb1 - write(unit) this% tsb2 - write(unit) this% atau - write(unit) this% btau - write(unit) this% ity - write(unit) this% tc - write(unit) this% qc - write(unit) this% capac - write(unit) this% catdef - write(unit) this% rzexc - write(unit) this% srfexc - write(unit) this% ghtcnt1 - write(unit) this% ghtcnt2 - write(unit) this% ghtcnt3 - write(unit) this% ghtcnt4 - write(unit) this% ghtcnt5 - write(unit) this% ghtcnt6 - write(unit) this% tsurf - write(unit) this% wesnn1 - write(unit) this% wesnn2 - write(unit) this% wesnn3 - write(unit) this% htsnnn1 - write(unit) this% htsnnn2 - write(unit) this% htsnnn3 - write(unit) this% sndzn1 - write(unit) this% sndzn2 - write(unit) this% sndzn3 - write(unit) this% ch - write(unit) this% cm - write(unit) this% cq - write(unit) this% fr - write(unit) this% ww - close(unit) - _RETURN(_SUCCESS) - end subroutine write_bin - - subroutine allocate(this, ntiles,rc) + subroutine allocate_catch(this,rc) class(CatchmentRst), intent(inout) :: this - integer, intent(in) :: ntiles integer, optional, intent(out):: rc + integer :: ntiles + ntiles = this%ntiles allocate( this% bf1(ntiles) ) allocate( this% bf2(ntiles) ) allocate( this% bf3(ntiles) ) @@ -467,4 +414,132 @@ subroutine allocate(this, ntiles,rc) _RETURN(_SUCCESS) end subroutine allocate + ! This subroutine reads BCs from BCSDIR and hydrological varable + subroutine add_bcs_to_rst(this, surflay, DataDir, rc) + class(CatchmentRst), intent(inout) :: this + real, intent(in) :: surflay + integer, optional, intent(out) :: rc + + real, allocatable :: DP2BR(:) + real :: CanopH + integer, allocatable :: ity(:) + integer :: ntiles, STATUS + integer :: idum, i,j,n, ib, nv + real :: rdum, zdep1, zdep2, zdep3, zmet, term1, term2, bare,fvg(4) + logical :: NEWLAND + logical :: file_exists + + type(NetCDF4_Fileformatter) :: CatchFmt + + character*256 :: Iam = "add_bcs" + + ntiles = this%ntiles + + allocate (DP2BR(ntiles), ity(ntiles) ) + + inquire(file = trim(DataDir)//'/catch_params.nc4', exist=file_exists) + inquire(file = trim(DataDir)//"CLM_veg_typs_fracs",exist=NewLand ) + + if(file_exists) then + call CatchFmt%Open(trim(DataDir)//'/catch_params.nc4', pFIO_READ, __RC__) + call MAPL_VarRead ( CatchFmt ,'OLD_ITY', this%ITY, __RC__) + call MAPL_VarRead ( CatchFmt ,'ARA1', this%ARA1, __RC__) + call MAPL_VarRead ( CatchFmt ,'ARA2', this%ARA2, __RC__) + call MAPL_VarRead ( CatchFmt ,'ARA3', this%ARA3, __RC__) + call MAPL_VarRead ( CatchFmt ,'ARA4', this%ARA4, __RC__) + call MAPL_VarRead ( CatchFmt ,'ARS1', this%ARS1, __RC__) + call MAPL_VarRead ( CatchFmt ,'ARS2', this%ARS2, __RC__) + call MAPL_VarRead ( CatchFmt ,'ARS3', this%ARS3, __RC__) + call MAPL_VarRead ( CatchFmt ,'ARW1', this%ARW1, __RC__) + call MAPL_VarRead ( CatchFmt ,'ARW2', this%ARW2, __RC__) + call MAPL_VarRead ( CatchFmt ,'ARW3', this%ARW3, __RC__) + call MAPL_VarRead ( CatchFmt ,'ARW4', this%ARW4, __RC__) + + if( SURFLAY.eq.20.0 ) then + call MAPL_VarRead ( CatchFmt ,'ATAU2', this%ATAU, __RC__) + call MAPL_VarRead ( CatchFmt ,'BTAU2', this%BTAU, __RC__) + endif + + if( SURFLAY.eq.50.0 ) then + call MAPL_VarRead ( CatchFmt ,'ATAU5', this%ATAU, __RC__) + call MAPL_VarRead ( CatchFmt ,'BTAU5', this%BTAU, __RC__) + endif + + call MAPL_VarRead ( CatchFmt ,'PSIS', this%PSIS, __RC__) + call MAPL_VarRead ( CatchFmt ,'BEE', this%BEE, __RC__) + call MAPL_VarRead ( CatchFmt ,'BF1', this%BF1, __RC__) + call MAPL_VarRead ( CatchFmt ,'BF2', this%BF2, __RC__) + call MAPL_VarRead ( CatchFmt ,'BF3', this%BF3, __RC__) + call MAPL_VarRead ( CatchFmt ,'TSA1', this%TSA1, __RC__) + call MAPL_VarRead ( CatchFmt ,'TSA2', this%TSA2, __RC__) + call MAPL_VarRead ( CatchFmt ,'TSB1', this%TSB1, __RC__) + call MAPL_VarRead ( CatchFmt ,'TSB2', this%TSB2, __RC__) + call MAPL_VarRead ( CatchFmt ,'COND', this%COND, __RC__) + call MAPL_VarRead ( CatchFmt ,'GNU', this%GNU, __RC__) + call MAPL_VarRead ( CatchFmt ,'WPWET', this%WPWET, __RC__) + call MAPL_VarRead ( CatchFmt ,'DP2BR', DP2BR, __RC__) + call MAPL_VarRead ( CatchFmt ,'POROS', this%POROS, __RC__) + call CatchFmt%close() + else + open(unit=21, file=trim(DataDir)//'mosaic_veg_typs_fracs',form='formatted') + open(unit=22, file=trim(DataDir)//'bf.dat' ,form='formatted') + open(unit=23, file=trim(DataDir)//'soil_param.dat' ,form='formatted') + open(unit=24, file=trim(DataDir)//'ar.new' ,form='formatted') + open(unit=25, file=trim(DataDir)//'ts.dat' ,form='formatted') + open(unit=26, file=trim(DataDir)//'tau_param.dat' ,form='formatted') + + do n=1,ntiles + ! W.J notes: CanopH is not used. If CLM_veg_typs_fracs exists, the read some dummy ???? Ask Sarith + if (NewLand) then + read(21,*) I, j, ITY(N),idum, rdum, rdum, CanopH + else + read(21,*) I, j, ITY(N),idum, rdum, rdum + endif + + read (22, *) i,j, this%GNU(n), this%BF1(n), this%BF2(n), this%BF3(n) + + read (23, *) i,j, idum, idum, this%BEE(n), this%PSIS(n),& + this%POROS(n), this%COND(n), this%WPWET(n), DP2BR(n) + + read (24, *) i,j, rdum, this%ARS1(n), this%ARS2(n), this%ARS3(n), & + this%ARA1(n), this%ARA2(n), this%ARA3(n), this%ARA4(n), & + this%ARW1(n), this%ARW2(n), this%ARW3(n), this%ARW4(n) + + read (25, *) i,j, rdum, this%TSA1(n), this%TSA2(n), this%TSB1(n), this%TSB2(n) + + if( SURFLAY.eq.20.0 ) read (26, *) i,j, this%ATAU(n), this%BTAU(n), rdum, rdum ! for old soil params + if( SURFLAY.eq.50.0 ) read (26, *) i,j, rdum , rdum, this%ATAU(n), this%BTAU(n) ! for new soil params + + end do + this%ity = real(ity) + CLOSE (21, STATUS = 'KEEP') + CLOSE (22, STATUS = 'KEEP') + CLOSE (23, STATUS = 'KEEP') + CLOSE (24, STATUS = 'KEEP') + CLOSE (25, STATUS = 'KEEP') + CLOSE (26, STATUS = 'KEEP') + endif + + do n=1,ntiles + zdep2=1000. + zdep3=amax1(1000.,DP2BR(n)) + + if (zdep2 .gt.0.75*zdep3) then + zdep2 = 0.75*zdep3 + end if + + zdep1=20. + zmet=zdep3/1000. + + term1=-1.+((this%PSIS(n)-zmet)/this%PSIS(n))**((this%BEE(n)-1.)/this%BEE(n)) + term2=this%PSIS(n)*this%BEE(n)/(this%BEE(n)-1) + + this%VGWMAX(n) = this%POROS(n)*zdep2 + this%CDCR1(n) = 1000.*this%POROS(n)*(zmet-(-term2*term1)) + this%CDCR2(n) = (1.-this%WPWET(n))*this%POROS(n)*zdep3 + enddo + + _RETURN(_SUCCESS) + end subroutine add_bcs_to_rst + end module CatchmentRstMod From f8cff3065c6d17e1d7ef0ce26354ec4056f9e185 Mon Sep 17 00:00:00 2001 From: Weiyuan Jiang Date: Thu, 28 Apr 2022 11:02:07 -0400 Subject: [PATCH 04/17] add mk_CatchmentRestarts.F90 --- .../Utils/mk_restarts/CMakeLists.txt | 1 + .../Utils/mk_restarts/CatchmentCNRst.F90 | 989 +++++++++++++++++- .../Utils/mk_restarts/CatchmentRst.F90 | 792 ++++++++++++-- .../Utils/mk_restarts/ScaleCatch.F90 | 252 ----- .../Utils/mk_restarts/getids.F90 | 4 +- .../mk_restarts/mk_CatchmentRestarts.F90 | 126 +++ 6 files changed, 1782 insertions(+), 382 deletions(-) delete mode 100644 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/ScaleCatch.F90 create mode 100644 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_CatchmentRestarts.F90 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CMakeLists.txt index 9298f400e..69facd85a 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CMakeLists.txt +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CMakeLists.txt @@ -19,6 +19,7 @@ set (exe_srcs mk_LakeLandiceSaltRestarts.F90 mk_RouteRestarts.F90 mk_GEOSldasRestarts.F90 + mk_CatchmentRestarts.F90 ) esma_add_library (${this} diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentCNRst.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentCNRst.F90 index a4f4c8de1..df7b57cd6 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentCNRst.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentCNRst.F90 @@ -1,19 +1,18 @@ #include "MAPL_Generic.h" module CatchmentCNRstMod + use mk_restarts_getidsMod + use mpi use MAPL - use LSM_ROUTINES, ONLY: & - catch_calc_soil_moist, & - catch_calc_tp, & - catch_calc_ght - USE CATCH_CONSTANTS, ONLY: & - N_GT => CATCH_N_GT, & - DZGT => CATCH_DZGT, & - PEATCLSM_POROS_THRESHOLD use CatchmentRstMod, only : CatchmentRst implicit none - integer, parameter :: nveg = integer, parameter :: nveg = 4 + real, parameter :: ECCENTRICITY = 0.0167 + real, parameter :: PERIHELION = 102.0 + real, parameter :: OBLIQUITY = 23.45 + integer, parameter :: EQUINOX = 80 + + integer, parameter :: nveg = 4 integer, parameter :: nzone = 3 integer, parameter :: VAR_COL_CLM40 = 40 ! number of CN column restart variables integer, parameter :: VAR_PFT_CLM40 = 74 ! number of CN PFT variables per column @@ -21,14 +20,20 @@ module CatchmentCNRstMod integer, parameter :: npft_clm45 = 19 integer, parameter :: VAR_COL_CLM45 = 35 ! number of CN column restart variables integer, parameter :: VAR_PFT_CLM45 = 75 ! number of CN PFT variables per column + real, parameter :: nan = O'17760000000' + real, parameter :: fmin= 1.e-4 ! ignore vegetation fractions at or below this value + integer :: iclass(npft) = (/1,1,2,3,3,4,5,5,6,7,8,9,10,11,12,11,12,11,12/) - type, extends(CatchmentRst) :: CatchmentCNRst + type, extends(CatchmentRst) :: CatchmentCNRst logical :: isCLM45 integer :: VAR_COL integer :: VAR_PFT real, allocatable :: cnity(:,:) real, allocatable :: fvg(:,:) real, allocatable :: tg(:,:) + real, allocatable :: tgwm(:,:) + real, allocatable :: rzmm(:,:) + real, allocatable :: sfmm(:,:) real, allocatable :: TILE_ID(:) real, allocatable :: ndep(:) real, allocatable :: t2(:) @@ -43,10 +48,32 @@ module CatchmentCNRstMod real, allocatable :: HDM (:) real, allocatable :: GDP (:) real, allocatable :: PEATF (:) + + real, allocatable :: bflowm(:) + real, allocatable :: totwatm(:) + real, allocatable :: tairm(:) + real, allocatable :: tpm(:) + real, allocatable :: cnsum(:) + real, allocatable :: sndzm(:) + real, allocatable :: asnowm(:) + real, allocatable :: ar1m(:) + real, allocatable :: rainfm(:) + real, allocatable :: rhm(:) + real, allocatable :: runsrfm(:) + real, allocatable :: snowfm(:) + real, allocatable :: windm(:) + real, allocatable :: tprec10d(:) + real, allocatable :: tprec60d(:) + real, allocatable :: t2m10d(:) + real, allocatable :: sfmcm(:) + real, allocatable :: psnsunm(:,:,:) + real, allocatable :: psnsham(:,:,:) + contains procedure :: write_nc4 procedure :: allocate_cn procedure :: add_bcs_to_rst + procedure :: re_tile endtype CatchmentCNRst interface CatchmentCNRst @@ -55,10 +82,11 @@ module CatchmentCNRstMod contains - function CatchmentCNRst_create(filename, cnclm, rc) result (catch) + function CatchmentCNRst_create(filename, cnclm, time, rc) result (catch) type(CatchmentCNRst) :: catch character(*), intent(in) :: filename character(*), intent(in) :: cnclm + character(*), intent(in) :: time integer, optional, intent(out) :: rc integer :: status type(Netcdf4_fileformatter) :: formatter @@ -77,13 +105,15 @@ function CatchmentCNRst_create(filename, cnclm, rc) result (catch) catch%isCLM45 = .false. call formatter%open(filename, pFIO_READ, __RC__) meta = formatter%read(__RC__) - ntiles = meta%get_dimension('tile', __RC__) + ntiles = catch%meta%get_dimension('tile', __RC__) catch%ntiles = ntiles - if (index(cnclm, '40' /=0) then + catch%meta = meta + catch%time = time + if (index(cnclm, '40') /=0) then catch%VAR_COL = VAR_COL_CLM40 catch%VAR_PFT = VAR_PFT_CLM40 endif - if (index(cnclm, '45' /=0) then + if (index(cnclm, '45') /=0) then catch%VAR_COL = VAR_COL_CLM45 catch%VAR_PFT = VAR_PFT_CLM45 catch%isCLM45 = .true. @@ -139,10 +169,36 @@ function CatchmentCNRst_create(filename, cnclm, rc) result (catch) if (present(rc)) rc =0 end function CatchmentCNRst_Create - subroutine write_nc4(this, filename, meta, rc) + function CatchmentCNRst_empty(meta, cnclm, time, rc) result (catch) + type(CatchmentCNRst) :: catch + type(FileMetadata), intent(in) :: meta + character(*), intent(in) :: cnclm + character(*), intent(in) :: time + integer, optional, intent(out) :: rc + integer :: status + character(len=256) :: Iam = "CatchmentCNRst_empty" + + catch%isCLM45 = .false. + catch%ntiles = meta%get_dimension('tile', __RC__) + catch%time = time + catch%meta = meta + if (index(cnclm, '40') /=0) then + catch%VAR_COL = VAR_COL_CLM40 + catch%VAR_PFT = VAR_PFT_CLM40 + endif + if (index(cnclm, '45') /=0) then + catch%VAR_COL = VAR_COL_CLM45 + catch%VAR_PFT = VAR_PFT_CLM45 + catch%isCLM45 = .true. + endif + + call catch%allocate_cn(__RC__) + + end function CatchmentCNRst_empty + + subroutine write_nc4(this, filename, rc) class(CatchmentCNRst), intent(inout):: this character(*), intent(in) :: filename - type(FileMetadata), intent(inout) :: meta integer, optional, intent(out):: rc type(Netcdf4_fileformatter) :: formatter @@ -152,7 +208,9 @@ subroutine write_nc4(this, filename, meta, rc) real, dimension (:), allocatable :: var type(Variable), pointer :: myVariable character(len=:), pointer :: dname + type(FileMetadata) :: meta + meta = this%meta call formatter%create(filename, __RC__) call formatter%write(meta, __RC__) @@ -245,11 +303,11 @@ subroutine write_nc4(this, filename, meta, rc) _RETURN(_SUCCESS) end subroutine write_nc4 - subroutine allocate_cn(this, ncol, npft, rc) + subroutine allocate_cn(this,rc) class(CatchmentCNRst), intent(inout) :: this - integer, intent(in) :: ncol,npft integer, optional, intent(out):: rc integer :: status + integer :: ncol,npft, ntiles ntiles = this%ntiles ncol = nzone* this%VAR_COL @@ -260,6 +318,8 @@ subroutine allocate_cn(this, ncol, npft, rc) allocate(this%cnity(ntiles,4)) allocate(this%fvg(ntiles,4)) allocate(this%tg(ntiles,4)) + allocate(this%tgwm(ntiles,nzone)) + allocate(this%rzmm(ntiles,nzone)) allocate(this%TILE_ID(ntiles)) allocate(this%ndep(ntiles)) allocate(this%t2(ntiles)) @@ -275,7 +335,7 @@ subroutine allocate_cn(this, ncol, npft, rc) allocate(this%GDP(ntiles)) allocate(this%PEATF(ntiles)) _RETURN(_SUCCESS) - end subroutine allocatecn + end subroutine allocate_cn SUBROUTINE add_bcs_to_rst (this, SURFLAY, DataDir,rc) class(CatchmentCNRst), intent(inout) :: this @@ -289,7 +349,7 @@ SUBROUTINE add_bcs_to_rst (this, SURFLAY, DataDir,rc) real, allocatable :: NDEP(:), BVISDR(:), BVISDF(:), BNIRDR(:), BNIRDF(:) real, allocatable :: T2(:), var1(:), hdm(:), fc(:), gdp(:), peatf(:) integer, allocatable :: ity(:), abm (:) - integer :: STATUS, ntiles, uit27, unit28, unit29, unit30 + integer :: STATUS, ntiles, unit27, unit28, unit29, unit30 integer :: idum, i,j,n, ib, nv real :: rdum, zdep1, zdep2, zdep3, zmet, term1, term2, bare,fvg(4) logical :: NEWLAND @@ -298,8 +358,9 @@ SUBROUTINE add_bcs_to_rst (this, SURFLAY, DataDir,rc) type(NetCDF4_Fileformatter) :: CatchCNFmt character*256 :: Iam = "add_bcs" - call this%CatchmentRst%add_bcs(surflay, DataDir, __RC__) ntiles = this%ntiles + call this%CatchmentRst%add_bcs_to_rst(surflay, DataDir, __RC__) + allocate (BVISDR(ntiles), BVISDF(ntiles), BNIRDR(ntiles) ) allocate (BNIRDF(ntiles), T2(ntiles), NDEP(ntiles) ) allocate (CLMC_pf1(ntiles), CLMC_pf2(ntiles), CLMC_sf1(ntiles)) @@ -309,7 +370,7 @@ SUBROUTINE add_bcs_to_rst (this, SURFLAY, DataDir,rc) allocate (CLMC_st1(ntiles), CLMC_st2(ntiles)) allocate (CLMC45_st1(ntiles), CLMC45_st2(ntiles)) allocate (hdm(ntiles), fc(ntiles), gdp(ntiles)) - allocate (peatf(ntiles), abm(ntiles), var1(ntiles) + allocate (peatf(ntiles), abm(ntiles), var1(ntiles)) inquire(file = trim(DataDir)//'/catchcn_params.nc4', exist=file_exists) inquire(file = trim(DataDir)//"CLM_veg_typs_fracs" ,exist=NewLand ) @@ -434,18 +495,18 @@ SUBROUTINE add_bcs_to_rst (this, SURFLAY, DataDir,rc) ! prevent trivial fractions ! ------------------------- - do n = 1,ntiles - if(CLMC_pf1(n) <= 1.e-4) then + do n = 1,ntiles + if(CLMC_pf1(n) <= 1.e-4) then CLMC_pf2(n) = CLMC_pf2(n) + CLMC_pf1(n) CLMC_pf1(n) = 0. - endif + endif - if(CLMC_pf2(n) <= 1.e-4) then + if(CLMC_pf2(n) <= 1.e-4) then CLMC_pf1(n) = CLMC_pf1(n) + CLMC_pf2(n) CLMC_pf2(n) = 0. - endif + endif - if(CLMC_sf1(n) <= 1.e-4) then + if(CLMC_sf1(n) <= 1.e-4) then if(CLMC_sf2(n) > 1.e-4) then CLMC_sf2(n) = CLMC_sf2(n) + CLMC_sf1(n) else if(CLMC_pf2(n) > 1.e-4) then @@ -456,9 +517,9 @@ SUBROUTINE add_bcs_to_rst (this, SURFLAY, DataDir,rc) stop 'fveg3' endif CLMC_sf1(n) = 0. - endif + endif - if(CLMC_sf2(n) <= 1.e-4) then + if(CLMC_sf2(n) <= 1.e-4) then if(CLMC_sf1(n) > 1.e-4) then CLMC_sf1(n) = CLMC_sf1(n) + CLMC_sf2(n) else if(CLMC_pf2(n) > 1.e-4) then @@ -469,7 +530,7 @@ SUBROUTINE add_bcs_to_rst (this, SURFLAY, DataDir,rc) stop 'fveg4' endif CLMC_sf2(n) = 0. - endif + endif enddo if (this%isCLM45) then do n = 1, ntiles @@ -508,26 +569,25 @@ SUBROUTINE add_bcs_to_rst (this, SURFLAY, DataDir,rc) endif CLMC45_sf2(n) = 0. endif - enddo - endif - - this%cnity(:,1) = CLMC_pt1 - this%cnity(:,2) = CLMC_pt2 - this%cnity(:,3) = CLMC_st1 - this%cnity(:,4) = CLMC_st2 - this%fvg(:,1) = CLMC_pf1 - this%fvg(:,2) = CLMC_pf2 - this%fvg(:,3) = CLMC_sf1 - this%fvg(:,4) = CLMC_sf2 - - this%ndep = ndep - this%t2 = t2 - this%BGALBVR = BVISDR - this%BGALBVF = BVISDF - this%BGALBNR = BNIRDR - this%BGALBNF = BNIRDF + enddo + endif + + if (this%isCLM45) then + this%cnity = reshape([CLMC45_pt1,CLMC45_pt2,CLMC45_st1,CLMC45_st2],[ntiles,4]) + this%fvg = reshape([CLMC45_pf1,CLMC45_pf2,CLMC45_sf1,CLMC45_sf2],[ntiles,4]) + else + this%cnity = reshape([CLMC_pt1,CLMC_pt2,CLMC_st1,CLMC_st2],[ntiles,4]) + this%fvg = reshape([CLMC_pf1,CLMC_pf2,CLMC_sf1,CLMC_sf2],[ntiles,4]) + endif + + this%ndep = ndep + this%t2 = t2 + this%BGALBVR = BVISDR + this%BGALBVF = BVISDF + this%BGALBNR = BNIRDR + this%BGALBNF = BNIRDF - if(this%isCLM45) then + if (this%isCLM45) then this%abm = real(abm) this%fieldcap = fc this%hdm = hdm @@ -542,6 +602,833 @@ SUBROUTINE add_bcs_to_rst (this, SURFLAY, DataDir,rc) deallocate (CLMC_st1,CLMC_st2) _RETURN(_SUCCESS) - END SUBROUTINE add_bcs_to_rst + end subroutine add_bcs_to_rst + + subroutine re_tile(this, InTileFile, OutBcsDir, OutTileFile, surflay, rc) + class(CatchmentCNRst), intent(inout) :: this + character(*), intent(in) :: InTileFile + character(*), intent(in) :: OutBcsDir + character(*), intent(in) :: OutTileFile + real, intent(in) :: surflay + integer, optional, intent(out) :: rc + + real , allocatable, dimension (:) :: LATT, LONN, DAYX + real , pointer , dimension (:) :: long, latg, lonc, latc + integer, allocatable, dimension (:) :: low_ind, upp_ind, nt_local + integer, allocatable, dimension (:) :: Id_glb, id_loc + integer, allocatable, dimension (:,:) :: Id_glb_cn, id_loc_cn + integer, allocatable, dimension (:) :: ld_reorder, tid_offl + real, allocatable, dimension (:) :: CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2, & + CLMC_pt1, CLMC_pt2,CLMC_st1,CLMC_st2, var_dum2 + integer :: AGCM_YY,AGCM_MM,AGCM_DD,AGCM_HR=0,AGCM_DATE + real, allocatable, dimension(:,:) :: fveg_offl, ityp_offl, fveg_tmp, ityp_tmp + real, allocatable :: var_off_col (:,:,:), var_off_pft (:,:,:,:) + integer :: status, in_ntiles, out_ntiles, numprocs + logical :: root_proc + integer :: mpierr, n, i, k, req, st, myid, L, iv, nv,nz, var_col, var_pft + character(*), parameter :: Iam = "CatchmentCN::Re_tile" + + + in_ntiles = this%ntiles + var_pft = this%var_pft + var_col = this%var_col + call this%CatchmentRst%re_tile(InTileFile, OutBcsDir, OutTileFile, surflay, _RC) + + out_ntiles = this%ntiles + call MPI_COMM_RANK( MPI_COMM_WORLD, myid, mpierr ) + call MPI_COMM_SIZE( MPI_COMM_WORLD, numprocs, mpierr ) + + root_proc = .false. + if (myid == 0) root_proc = .true. + + allocate(low_ind (numprocs)) + allocate(upp_ind (numprocs)) + allocate(nt_local(numprocs)) + low_ind (:) = 1 + upp_ind (:) = out_ntiles + nt_local(:) = out_ntiles + + if (numprocs > 1) then + do i = 1, numprocs - 1 + upp_ind(i) = low_ind(i) + (out_ntiles/numprocs) - 1 + low_ind(i+1) = upp_ind(i) + 1 + nt_local(i) = upp_ind(i) - low_ind(i) + 1 + end do + nt_local(numprocs) = upp_ind(numprocs) - low_ind(numprocs) + 1 + endif + + allocate (CLMC_pf1(nt_local (myid + 1))) + allocate (CLMC_pf2(nt_local (myid + 1))) + allocate (CLMC_sf1(nt_local (myid + 1))) + allocate (CLMC_sf2(nt_local (myid + 1))) + allocate (CLMC_pt1(nt_local (myid + 1))) + allocate (CLMC_pt2(nt_local (myid + 1))) + allocate (CLMC_st1(nt_local (myid + 1))) + allocate (CLMC_st2(nt_local (myid + 1))) + allocate (ityp_offl (in_ntiles,nveg)) + allocate (fveg_offl (in_ntiles,nveg)) + allocate (id_loc_cn (nt_local (myid + 1),nveg)) + + ! copy out the old fvg and cnity + + if (root_proc) then + + allocate (ityp_tmp (in_ntiles,nveg)) + allocate (fveg_tmp (in_ntiles,nveg)) + allocate (DAYX (out_ntiles)) + + READ(this%time(1:8),'(I8)') AGCM_DATE + AGCM_YY = AGCM_DATE / 10000 + AGCM_MM = (AGCM_DATE - AGCM_YY*10000) / 100 + AGCM_DD = (AGCM_DATE - AGCM_YY*10000 - AGCM_MM*100) + + call compute_dayx ( & + out_NTILES, AGCM_YY, AGCM_MM, AGCM_DD, AGCM_HR, & + LATG, DAYX) + + ityp_tmp = this%cnity + fveg_tmp = this%fvg + + ityp_offl = ityp_tmp + fveg_offl = fveg_tmp + + do n = 1, size(ityp_offl,1) + if((ityp_offl(N,3) == 0).and.(ityp_offl(N,4) == 0)) then + if(ityp_offl(N,1) /= 0) then + ityp_offl(N,3) = ityp_offl(N,1) + else + ityp_offl(N,3) = ityp_offl(N,2) + endif + endif + + if((ityp_offl(N,1) == 0).and.(ityp_offl(N,2) /= 0)) ityp_offl(N,1) = ityp_offl(N,2) + if((ityp_offl(N,2) == 0).and.(ityp_offl(N,1) /= 0)) ityp_offl(N,2) = ityp_offl(N,1) + if((ityp_offl(N,3) == 0).and.(ityp_offl(N,4) /= 0)) ityp_offl(N,3) = ityp_offl(N,4) + if((ityp_offl(N,4) == 0).and.(ityp_offl(N,3) /= 0)) ityp_offl(N,4) = ityp_offl(N,3) + end do + endif + call MPI_BCAST(ityp_offl,size(ityp_offl),MPI_REAL ,0,MPI_COMM_WORLD,mpierr) + call MPI_BCAST(fveg_offl,size(fveg_offl),MPI_REAL ,0,MPI_COMM_WORLD,mpierr) + + if (root_proc ) then + + do i = 1, numprocs -1 + st = low_ind(i+1) + l = nt_local(i+1) + call MPI_send(this%cnity(st,1),l, MPI_REAL, i, i, MPI_COMM_WORLD, mpierr) + call MPI_send(this%cnity(st,2),l, MPI_REAL, i, i+1, MPI_COMM_WORLD, mpierr) + call MPI_send(this%cnity(st,3),l, MPI_REAL, i, i+2, MPI_COMM_WORLD, mpierr) + call MPI_send(this%cnity(st,4),l, MPI_REAL, i, i+3, MPI_COMM_WORLD, mpierr) + call MPI_send(this%fvg(st,1),l, MPI_REAL, i, i+4, MPI_COMM_WORLD, mpierr) + call MPI_send(this%fvg(st,2),l, MPI_REAL, i, i+5, MPI_COMM_WORLD, mpierr) + call MPI_send(this%fvg(st,3),l, MPI_REAL, i, i+6, MPI_COMM_WORLD, mpierr) + call MPI_send(this%fvg(st,4),l, MPI_REAL, i, i+7, MPI_COMM_WORLD, mpierr) + enddo + else + call MPI_RECV(CLMC_pt1,nt_local(myid+1) , MPI_REAL, 0, myid, MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) + call MPI_RECV(CLMC_pt2,nt_local(myid+1) , MPI_REAL, 0, myid+1, MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) + call MPI_RECV(CLMC_st1,nt_local(myid+1) , MPI_REAL, 0, myid+2, MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) + call MPI_RECV(CLMC_st2,nt_local(myid+1) , MPI_REAL, 0, myid+3, MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) + call MPI_RECV(CLMC_pf1,nt_local(myid+1) , MPI_REAL, 0, myid+4, MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) + call MPI_RECV(CLMC_pf2,nt_local(myid+1) , MPI_REAL, 0, myid+5, MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) + call MPI_RECV(CLMC_sf1,nt_local(myid+1) , MPI_REAL, 0, myid+6, MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) + call MPI_RECV(CLMC_sf2,nt_local(myid+1) , MPI_REAL, 0, myid+7, MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) + endif + + call GetIds(lonc,latc,lonn,latt,id_loc_cn, tid_offl, & + CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2, CLMC_pt1, CLMC_pt2,CLMC_st1,CLMC_st2, & + fveg_offl, ityp_offl) + + if(root_proc) allocate (id_glb_cn (out_ntiles,nveg)) + + allocate (id_loc (out_ntiles)) + call MPI_Barrier(MPI_COMM_WORLD, STATUS) + deallocate (CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2) + deallocate (CLMC_pt1, CLMC_pt2, CLMC_st1, CLMC_st2) + + do nv = 1, nveg + call MPI_Barrier(MPI_COMM_WORLD, STATUS) + do i = 1, numprocs + if((I == 1).and.(myid == 0)) then + id_loc(low_ind(i) : upp_ind(i)) = Id_loc_cn(:,nv) + else if (I > 1) then + if(I-1 == myid) then + ! send to root + call MPI_ISend(id_loc_cn(:,nv),nt_local(i),MPI_INTEGER,0,994,MPI_COMM_WORLD,req,mpierr) + call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) + else if (myid == 0) then + ! root receives + call MPI_RECV(id_loc(low_ind(i) : upp_ind(i)),nt_local(i) , MPI_INTEGER, i-1,994,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) + endif + endif + end do + + if(root_proc) id_glb_cn (:,nv) = id_loc + + end do + + if(root_proc) then + + allocate (var_off_col (1: in_ntiles, 1 : nzone,1 : var_col)) + allocate (var_off_pft (1: in_ntiles, 1 : nzone,1 : nveg, 1 : var_pft)) + allocate (var_dum2 (1:in_ntiles)) + + i = 1 + do nv = 1,VAR_COL + do nz = 1,nzone + var_off_col(:,nz,nv) = this%cncol(:,i) + i = i + 1 + end do + end do + + i = 1 + do iv = 1,VAR_PFT + do nv = 1,nveg + do nz = 1,nzone + var_off_pft(:, nz,nv,iv) = this%cnpft(:,i) + i = i + 1 + end do + end do + end do + + where(isnan(var_off_pft)) var_off_pft = 0. + where(var_off_pft /= var_off_pft) var_off_pft = 0. + print *, 'Writing regridded carbn' + call regrid_carbon (out_NTILES, in_ntiles,id_glb_cn, & + DAYX, var_off_col,var_off_pft, ityp_offl, fveg_offl) + deallocate (var_off_col,var_off_pft) + endif + call MPI_Barrier(MPI_COMM_WORLD, STATUS) + + _RETURN(_SUCCESS) + + contains + SUBROUTINE regrid_carbon (NTILES, in_ntiles, id_glb, & + DAYX, var_off_col, var_off_pft, ityp_offl, fveg_offl) + + ! write out regridded carbon variables + implicit none + integer, intent (in) :: NTILES, in_ntiles,id_glb (ntiles,nveg) + real, intent (in) :: DAYX (NTILES), var_off_col(in_ntiles,NZONE,var_col), var_off_pft(in_ntiles,NZONE, NVEG, var_pft) + real, intent (in), dimension(in_ntiles,nveg) :: fveg_offl, ityp_offl + real, allocatable, dimension (:) :: CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2, & + CLMC_pt1, CLMC_pt2,CLMC_st1,CLMC_st2, var_dum + real, allocatable :: var_col_out (:,:,:), var_pft_out (:,:,:,:) + integer :: N, STATUS, nv, nx, offl_cell, ityp_new, i, j, nz, iv + real :: fveg_new + character(256) :: Iam = "write_regridded_carbon" + + + allocate (CLMC_pf1(NTILES)) + allocate (CLMC_pf2(NTILES)) + allocate (CLMC_sf1(NTILES)) + allocate (CLMC_sf2(NTILES)) + allocate (CLMC_pt1(NTILES)) + allocate (CLMC_pt2(NTILES)) + allocate (CLMC_st1(NTILES)) + allocate (CLMC_st2(NTILES)) + allocate (VAR_DUM (NTILES)) + + CLMC_pt1 = this%cnity(:,1) + CLMC_pt2 = this%cnity(:,2) + CLMC_st1 = this%cnity(:,3) + CLMC_st2 = this%cnity(:,4) + CLMC_pf1 = this%fvg(:,1) + CLMC_pf2 = this%fvg(:,2) + CLMC_sf1 = this%fvg(:,3) + CLMC_sf2 = this%fvg(:,4) + + allocate (var_col_out (1: NTILES, 1 : nzone,1 : var_col)) + allocate (var_pft_out (1: NTILES, 1 : nzone,1 : nveg, 1 : var_pft)) + + var_col_out = 0. + var_pft_out = NaN + + OUT_TILE : DO N = 1, NTILES + + ! if(mod (n,1000) == 0) print *, myid +1, n, Id_glb(n,:) + + NVLOOP2 : do nv = 1, nveg + + if(nv <= 2) then ! index for secondary PFT index if primary or primary if secondary + nx = nv + 2 + else + nx = nv - 2 + endif + + if (nv == 1) ityp_new = CLMC_pt1(n) + if (nv == 1) fveg_new = CLMC_pf1(n) + if (nv == 2) ityp_new = CLMC_pt2(n) + if (nv == 2) fveg_new = CLMC_pf2(n) + if (nv == 3) ityp_new = CLMC_st1(n) + if (nv == 3) fveg_new = CLMC_sf1(n) + if (nv == 4) ityp_new = CLMC_st2(n) + if (nv == 4) fveg_new = CLMC_sf2(n) + if (fveg_new > fmin) then + + offl_cell = Id_glb(n,nv) + + if(ityp_new == ityp_offl (offl_cell,nv) .and. fveg_offl (offl_cell,nv)> fmin) then + iv = nv ! same type fraction (primary of secondary) + else if(ityp_new == ityp_offl (offl_cell,nx) .and. fveg_offl (offl_cell,nx)> fmin) then + iv = nx ! not same fraction + else if(iclass(ityp_new)==iclass(ityp_offl(offl_cell,nv)) .and. fveg_offl (offl_cell,nv)> fmin) then + iv = nv ! primary, other type (same class) + else if(fveg_offl (offl_cell,nx)> fmin) then + iv = nx ! secondary, other type (same class) + endif + + ! Get col and pft variables for the Id_glb(nv) grid cell from offline catchcn_internal_rst + ! ---------------------------------------------------------------------------------------- + + ! call NCDF_reshape_getOput (NCFID,Id_glb(n,nv),var_off_col,var_off_pft,.true.) + + var_pft_out (n,:,nv,:) = var_off_pft(Id_glb(n,nv), :,iv,:) + var_col_out (n,:,:) = var_col_out(n,:,:) + fveg_new * var_off_col(Id_glb(n,nv), :,:) ! gkw: column state simple weighted mean; ! could use "woody" fraction? + + ! Check whether var_pft_out is realistic + do nz = 1, nzone + do j = 1, VAR_PFT + if (isnan(var_pft_out (n, nz,nv,j))) print *,j,nv,nz,n,var_pft_out (n, nz,nv,j),fveg_new + !if(isnan(var_pft_out (n, nz,nv,69))) var_pft_out (n, nz,nv,69) = 1.e-6 + !if(isnan(var_pft_out (n, nz,nv,70))) var_pft_out (n, nz,nv,70) = 1.e-6 + !if(isnan(var_pft_out (n, nz,nv,73))) var_pft_out (n, nz,nv,73) = 1.e-6 + !if(isnan(var_pft_out (n, nz,nv,74))) var_pft_out (n, nz,nv,74) = 1.e-6 + end do + end do + endif + + end do NVLOOP2 + + ! reset carbon if negative < 10g + ! ------------------------ + + NZLOOP : do nz = 1, nzone + + if(var_col_out (n, nz,14) < 10.) then + + var_col_out(n, nz, 1) = max(var_col_out(n, nz, 1), 0.) + var_col_out(n, nz, 2) = max(var_col_out(n, nz, 2), 0.) + var_col_out(n, nz, 3) = max(var_col_out(n, nz, 3), 0.) + var_col_out(n, nz, 4) = max(var_col_out(n, nz, 4), 0.) + var_col_out(n, nz, 5) = max(var_col_out(n, nz, 5), 0.) + var_col_out(n, nz,10) = max(var_col_out(n, nz,10), 0.) + var_col_out(n, nz,11) = max(var_col_out(n, nz,11), 0.) + var_col_out(n, nz,12) = max(var_col_out(n, nz,12), 0.) + var_col_out(n, nz,13) = max(var_col_out(n, nz,13),10.) ! soil4c + var_col_out(n, nz,14) = max(var_col_out(n, nz,14), 0.) + var_col_out(n, nz,15) = max(var_col_out(n, nz,15), 0.) + var_col_out(n, nz,16) = max(var_col_out(n, nz,16), 0.) + var_col_out(n, nz,17) = max(var_col_out(n, nz,17), 0.) + var_col_out(n, nz,18) = max(var_col_out(n, nz,18), 0.) + var_col_out(n, nz,19) = max(var_col_out(n, nz,19), 0.) + var_col_out(n, nz,20) = max(var_col_out(n, nz,20), 0.) + var_col_out(n, nz,24) = max(var_col_out(n, nz,24), 0.) + var_col_out(n, nz,25) = max(var_col_out(n, nz,25), 0.) + var_col_out(n, nz,26) = max(var_col_out(n, nz,26), 0.) + var_col_out(n, nz,27) = max(var_col_out(n, nz,27), 0.) + var_col_out(n, nz,28) = max(var_col_out(n, nz,28), 1.) + var_col_out(n, nz,29) = max(var_col_out(n, nz,29), 0.) + + NVLOOP3 : do nv = 1,nveg + + if (nv == 1) ityp_new = CLMC_pt1(n) + if (nv == 1) fveg_new = CLMC_pf1(n) + if (nv == 2) ityp_new = CLMC_pt2(n) + if (nv == 2) fveg_new = CLMC_pf2(n) + if (nv == 3) ityp_new = CLMC_st1(n) + if (nv == 3) fveg_new = CLMC_sf1(n) + if (nv == 4) ityp_new = CLMC_st2(n) + if (nv == 4) fveg_new = CLMC_sf2(n) + + if(fveg_new > fmin) then + var_pft_out(n, nz,nv, 1) = max(var_pft_out(n, nz,nv, 1),0.) + var_pft_out(n, nz,nv, 2) = max(var_pft_out(n, nz,nv, 2),0.) + var_pft_out(n, nz,nv, 3) = max(var_pft_out(n, nz,nv, 3),0.) + var_pft_out(n, nz,nv, 4) = max(var_pft_out(n, nz,nv, 4),0.) + + if(ityp_new <= 12) then ! tree or shrub deadstemc + var_pft_out(n, nz,nv, 5) = max(var_pft_out(n, nz,nv, 5),0.1) + else + var_pft_out(n, nz,nv, 5) = max(var_pft_out(n, nz,nv, 5),0.0) + endif + + var_pft_out(n, nz,nv, 6) = max(var_pft_out(n, nz,nv, 6),0.) + var_pft_out(n, nz,nv, 7) = max(var_pft_out(n, nz,nv, 7),0.) + var_pft_out(n, nz,nv, 8) = max(var_pft_out(n, nz,nv, 8),0.) + var_pft_out(n, nz,nv, 9) = max(var_pft_out(n, nz,nv, 9),0.) + var_pft_out(n, nz,nv,10) = max(var_pft_out(n, nz,nv,10),0.) + var_pft_out(n, nz,nv,11) = max(var_pft_out(n, nz,nv,11),0.) + var_pft_out(n, nz,nv,12) = max(var_pft_out(n, nz,nv,12),0.) + + if(ityp_new <=2 .or. ityp_new ==4 .or. ityp_new ==5 .or. ityp_new == 9) then + var_pft_out(n, nz,nv,13) = max(var_pft_out(n, nz,nv,13),1.) ! leaf carbon display for evergreen + var_pft_out(n, nz,nv,14) = max(var_pft_out(n, nz,nv,14),0.) + else + var_pft_out(n, nz,nv,13) = max(var_pft_out(n, nz,nv,13),0.) + var_pft_out(n, nz,nv,14) = max(var_pft_out(n, nz,nv,14),1.) ! leaf carbon storage for deciduous + endif + + var_pft_out(n, nz,nv,15) = max(var_pft_out(n, nz,nv,15),0.) + var_pft_out(n, nz,nv,16) = max(var_pft_out(n, nz,nv,16),0.) + var_pft_out(n, nz,nv,17) = max(var_pft_out(n, nz,nv,17),0.) + var_pft_out(n, nz,nv,18) = max(var_pft_out(n, nz,nv,18),0.) + var_pft_out(n, nz,nv,19) = max(var_pft_out(n, nz,nv,19),0.) + var_pft_out(n, nz,nv,20) = max(var_pft_out(n, nz,nv,20),0.) + var_pft_out(n, nz,nv,21) = max(var_pft_out(n, nz,nv,21),0.) + var_pft_out(n, nz,nv,22) = max(var_pft_out(n, nz,nv,22),0.) + var_pft_out(n, nz,nv,23) = max(var_pft_out(n, nz,nv,23),0.) + var_pft_out(n, nz,nv,25) = max(var_pft_out(n, nz,nv,25),0.) + var_pft_out(n, nz,nv,26) = max(var_pft_out(n, nz,nv,26),0.) + var_pft_out(n, nz,nv,27) = max(var_pft_out(n, nz,nv,27),0.) + var_pft_out(n, nz,nv,41) = max(var_pft_out(n, nz,nv,41),0.) + var_pft_out(n, nz,nv,42) = max(var_pft_out(n, nz,nv,42),0.) + var_pft_out(n, nz,nv,44) = max(var_pft_out(n, nz,nv,44),0.) + var_pft_out(n, nz,nv,45) = max(var_pft_out(n, nz,nv,45),0.) + var_pft_out(n, nz,nv,46) = max(var_pft_out(n, nz,nv,46),0.) + var_pft_out(n, nz,nv,47) = max(var_pft_out(n, nz,nv,47),0.) + var_pft_out(n, nz,nv,48) = max(var_pft_out(n, nz,nv,48),0.) + var_pft_out(n, nz,nv,49) = max(var_pft_out(n, nz,nv,49),0.) + var_pft_out(n, nz,nv,50) = max(var_pft_out(n, nz,nv,50),0.) + var_pft_out(n, nz,nv,51) = max(var_pft_out(n, nz,nv, 5)/500.,0.) + var_pft_out(n, nz,nv,52) = max(var_pft_out(n, nz,nv,52),0.) + var_pft_out(n, nz,nv,53) = max(var_pft_out(n, nz,nv,53),0.) + var_pft_out(n, nz,nv,54) = max(var_pft_out(n, nz,nv,54),0.) + var_pft_out(n, nz,nv,55) = max(var_pft_out(n, nz,nv,55),0.) + var_pft_out(n, nz,nv,56) = max(var_pft_out(n, nz,nv,56),0.) + var_pft_out(n, nz,nv,57) = max(var_pft_out(n, nz,nv,13)/25.,0.) + var_pft_out(n, nz,nv,58) = max(var_pft_out(n, nz,nv,14)/25.,0.) + var_pft_out(n, nz,nv,59) = max(var_pft_out(n, nz,nv,59),0.) + var_pft_out(n, nz,nv,60) = max(var_pft_out(n, nz,nv,60),0.) + var_pft_out(n, nz,nv,61) = max(var_pft_out(n, nz,nv,61),0.) + var_pft_out(n, nz,nv,62) = max(var_pft_out(n, nz,nv,62),0.) + var_pft_out(n, nz,nv,63) = max(var_pft_out(n, nz,nv,63),0.) + var_pft_out(n, nz,nv,64) = max(var_pft_out(n, nz,nv,64),0.) + var_pft_out(n, nz,nv,65) = max(var_pft_out(n, nz,nv,65),0.) + var_pft_out(n, nz,nv,66) = max(var_pft_out(n, nz,nv,66),0.) + var_pft_out(n, nz,nv,67) = max(var_pft_out(n, nz,nv,67),0.) + var_pft_out(n, nz,nv,68) = max(var_pft_out(n, nz,nv,68),0.) + var_pft_out(n, nz,nv,69) = max(var_pft_out(n, nz,nv,69),0.) + var_pft_out(n, nz,nv,70) = max(var_pft_out(n, nz,nv,70),0.) + var_pft_out(n, nz,nv,73) = max(var_pft_out(n, nz,nv,73),0.) + var_pft_out(n, nz,nv,74) = max(var_pft_out(n, nz,nv,74),0.) + if(this%isCLM45) var_pft_out(n, nz,nv,75) = max(var_pft_out(n, nz,nv,75),0.) + endif + end do NVLOOP3 ! end veg loop + endif ! end carbon check + end do NZLOOP ! end zone loop + + ! Update dayx variable var_pft_out (:,:,28) + + do j = 28, 28 ! 1,VAR_PFT var_pft_out (:,:,:,28) + do nv = 1,nveg + do nz = 1,nzone + var_pft_out (n, nz,nv,j) = dayx(n) + end do + end do + end do + + ! call NCDF_reshape_getOput (OutID,N,var_col_out,var_pft_out,.false.) + + ! column vars clm40 clm45 + ! ----------------- --------------------- + ! 1 clm3%g%l%c%ccs%col_ctrunc ! 1 ccs%col_ctrunc_vr (:,1) + ! 2 clm3%g%l%c%ccs%cwdc ! 2 ccs%decomp_cpools_vr(:,1,4) ! cwdc + ! 3 clm3%g%l%c%ccs%litr1c ! 3 ccs%decomp_cpools_vr(:,1,1) ! litr1c + ! 4 clm3%g%l%c%ccs%litr2c ! 4 ccs%decomp_cpools_vr(:,1,2) ! litr2c + ! 5 clm3%g%l%c%ccs%litr3c ! 5 ccs%decomp_cpools_vr(:,1,3) ! litr3c + ! 6 clm3%g%l%c%ccs%pcs_a%totvegc ! 6 ccs%totvegc_col + ! 7 clm3%g%l%c%ccs%prod100c ! 7 ccs%prod100c + ! 8 clm3%g%l%c%ccs%prod10c ! 8 ccs%prod10c + ! 9 clm3%g%l%c%ccs%seedc ! 9 ccs%seedc + ! 10 clm3%g%l%c%ccs%soil1c ! 10 ccs%decomp_cpools_vr(:,1,5) ! soil1c + ! 11 clm3%g%l%c%ccs%soil2c ! 11 ccs%decomp_cpools_vr(:,1,6) ! soil2c + ! 12 clm3%g%l%c%ccs%soil3c ! 12 ccs%decomp_cpools_vr(:,1,7) ! soil3c + ! 13 clm3%g%l%c%ccs%soil4c ! 13 ccs%decomp_cpools_vr(:,1,8) ! soil4c + ! 14 clm3%g%l%c%ccs%totcolc ! 14 ccs%totcolc + ! 15 clm3%g%l%c%ccs%totlitc ! 15 ccs%totlitc + ! 16 clm3%g%l%c%cns%col_ntrunc ! 16 cns%col_ntrunc_vr (:,1) + ! 17 clm3%g%l%c%cns%cwdn ! 17 cns%decomp_npools_vr(:,1,4) ! cwdn + ! 18 clm3%g%l%c%cns%litr1n ! 18 cns%decomp_npools_vr(:,1,1) ! litr1n + ! 19 clm3%g%l%c%cns%litr2n ! 19 cns%decomp_npools_vr(:,1,2) ! litr2n + ! 20 clm3%g%l%c%cns%litr3n ! 20 cns%decomp_npools_vr(:,1,3) ! litr3n + ! 21 clm3%g%l%c%cns%prod100n ! 21 cns%prod100n + ! 22 clm3%g%l%c%cns%prod10n ! 22 cns%prod10n + ! 23 clm3%g%l%c%cns%seedn ! 23 cns%seedn + ! 24 clm3%g%l%c%cns%sminn ! 24 cns%sminn_vr (:,1) + ! 25 clm3%g%l%c%cns%soil1n ! 25 cns%decomp_npools_vr(:,1,5) ! soil1n + ! 26 clm3%g%l%c%cns%soil2n ! 26 cns%decomp_npools_vr(:,1,6) ! soil2n + ! 27 clm3%g%l%c%cns%soil3n ! 27 cns%decomp_npools_vr(:,1,7) ! soil3n + ! 28 clm3%g%l%c%cns%soil4n ! 28 cns%decomp_npools_vr(:,1,8) ! soil4n + ! 29 clm3%g%l%c%cns%totcoln ! 29 cns%totcoln + ! 30 clm3%g%l%c%cps%ann_farea_burned ! 30 cps%fpg + ! 31 clm3%g%l%c%cps%annsum_counter ! 31 cps%annsum_counter + ! 32 clm3%g%l%c%cps%cannavg_t2m ! 32 cps%cannavg_t2m + ! 33 clm3%g%l%c%cps%cannsum_npp ! 33 cps%cannsum_npp + ! 34 clm3%g%l%c%cps%farea_burned ! 34 cps%farea_burned + ! 35 clm3%g%l%c%cps%fire_prob ! 35 cps%fpi_vr (:,1) + ! 36 clm3%g%l%c%cps%fireseasonl ! OLD ! 30 cps%altmax + ! 37 clm3%g%l%c%cps%fpg ! OLD ! 31 cps%annsum_counter + ! 38 clm3%g%l%c%cps%fpi ! OLD ! 32 cps%cannavg_t2m + ! 39 clm3%g%l%c%cps%me ! OLD ! 33 cps%cannsum_npp + ! 40 clm3%g%l%c%cps%mean_fire_prob ! OLD ! 34 cps%farea_burned + ! OLD ! 35 cps%altmax_lastyear + ! OLD ! 36 cps%altmax_indx + ! OLD ! 37 cps%fpg + ! OLD ! 38 cps%fpi_vr (:,1) + ! OLD ! 39 cps%altmax_lastyear_indx + + ! PFT vars CLM40 CLM45 + ! -------------- ----- + ! 1 clm3%g%l%c%p%pcs%cpool ! 1 pcs%cpool + ! 2 clm3%g%l%c%p%pcs%deadcrootc ! 2 pcs%deadcrootc + ! 3 clm3%g%l%c%p%pcs%deadcrootc_storage ! 3 pcs%deadcrootc_storage + ! 4 clm3%g%l%c%p%pcs%deadcrootc_xfer ! 4 pcs%deadcrootc_xfer + ! 5 clm3%g%l%c%p%pcs%deadstemc ! 5 pcs%deadstemc + ! 6 clm3%g%l%c%p%pcs%deadstemc_storage ! 6 pcs%deadstemc_storage + ! 7 clm3%g%l%c%p%pcs%deadstemc_xfer ! 7 pcs%deadstemc_xfer + ! 8 clm3%g%l%c%p%pcs%frootc ! 8 pcs%frootc + ! 9 clm3%g%l%c%p%pcs%frootc_storage ! 9 pcs%frootc_storage + ! 10 clm3%g%l%c%p%pcs%frootc_xfer ! 10 pcs%frootc_xfer + ! 11 clm3%g%l%c%p%pcs%gresp_storage ! 11 pcs%gresp_storage + ! 12 clm3%g%l%c%p%pcs%gresp_xfer ! 12 pcs%gresp_xfer + ! 13 clm3%g%l%c%p%pcs%leafc ! 13 pcs%leafc + ! 14 clm3%g%l%c%p%pcs%leafc_storage ! 14 pcs%leafc_storage + ! 15 clm3%g%l%c%p%pcs%leafc_xfer ! 15 pcs%leafc_xfer + ! 16 clm3%g%l%c%p%pcs%livecrootc ! 16 pcs%livecrootc + ! 17 clm3%g%l%c%p%pcs%livecrootc_storage ! 17 pcs%livecrootc_storage + ! 18 clm3%g%l%c%p%pcs%livecrootc_xfer ! 18 pcs%livecrootc_xfer + ! 19 clm3%g%l%c%p%pcs%livestemc ! 19 pcs%livestemc + ! 20 clm3%g%l%c%p%pcs%livestemc_storage ! 20 pcs%livestemc_storage + ! 21 clm3%g%l%c%p%pcs%livestemc_xfer ! 21 pcs%livestemc_xfer + ! 22 clm3%g%l%c%p%pcs%pft_ctrunc ! 22 pcs%pft_ctrunc + ! 23 clm3%g%l%c%p%pcs%xsmrpool ! 23 pcs%xsmrpool + ! 24 clm3%g%l%c%p%pepv%annavg_t2m ! 24 pepv%annavg_t2m + ! 25 clm3%g%l%c%p%pepv%annmax_retransn ! 25 pepv%annmax_retransn + ! 26 clm3%g%l%c%p%pepv%annsum_npp ! 26 pepv%annsum_npp + ! 27 clm3%g%l%c%p%pepv%annsum_potential_gpp ! 27 pepv%annsum_potential_gpp + ! 28 clm3%g%l%c%p%pepv%dayl ! 28 pepv%dayl + ! 29 clm3%g%l%c%p%pepv%days_active ! 29 pepv%days_active + ! 30 clm3%g%l%c%p%pepv%dormant_flag ! 30 pepv%dormant_flag + ! 31 clm3%g%l%c%p%pepv%offset_counter ! 31 pepv%offset_counter + ! 32 clm3%g%l%c%p%pepv%offset_fdd ! 32 pepv%offset_fdd + ! 33 clm3%g%l%c%p%pepv%offset_flag ! 33 pepv%offset_flag + ! 34 clm3%g%l%c%p%pepv%offset_swi ! 34 pepv%offset_swi + ! 35 clm3%g%l%c%p%pepv%onset_counter ! 35 pepv%onset_counter + ! 36 clm3%g%l%c%p%pepv%onset_fdd ! 36 pepv%onset_fdd + ! 37 clm3%g%l%c%p%pepv%onset_flag ! 37 pepv%onset_flag + ! 38 clm3%g%l%c%p%pepv%onset_gdd ! 38 pepv%onset_gdd + ! 39 clm3%g%l%c%p%pepv%onset_gddflag ! 39 pepv%onset_gddflag + ! 40 clm3%g%l%c%p%pepv%onset_swi ! 40 pepv%onset_swi + ! 41 clm3%g%l%c%p%pepv%prev_frootc_to_litter ! 41 pepv%prev_frootc_to_litter + ! 42 clm3%g%l%c%p%pepv%prev_leafc_to_litter ! 42 pepv%prev_leafc_to_litter + ! 43 clm3%g%l%c%p%pepv%tempavg_t2m ! 43 pepv%tempavg_t2m + ! 44 clm3%g%l%c%p%pepv%tempmax_retransn ! 44 pepv%tempmax_retransn + ! 45 clm3%g%l%c%p%pepv%tempsum_npp ! 45 pepv%tempsum_npp + ! 46 clm3%g%l%c%p%pepv%tempsum_potential_gpp ! 46 pepv%tempsum_potential_gpp + ! 47 clm3%g%l%c%p%pepv%xsmrpool_recover ! 47 pepv%xsmrpool_recover + ! 48 clm3%g%l%c%p%pns%deadcrootn ! 48 pns%deadcrootn + ! 49 clm3%g%l%c%p%pns%deadcrootn_storage ! 49 pns%deadcrootn_storage + ! 50 clm3%g%l%c%p%pns%deadcrootn_xfer ! 50 pns%deadcrootn_xfer + ! 51 clm3%g%l%c%p%pns%deadstemn ! 51 pns%deadstemn + ! 52 clm3%g%l%c%p%pns%deadstemn_storage ! 52 pns%deadstemn_storage + ! 53 clm3%g%l%c%p%pns%deadstemn_xfer ! 53 pns%deadstemn_xfer + ! 54 clm3%g%l%c%p%pns%frootn ! 54 pns%frootn + ! 55 clm3%g%l%c%p%pns%frootn_storage ! 55 pns%frootn_storage + ! 56 clm3%g%l%c%p%pns%frootn_xfer ! 56 pns%frootn_xfer + ! 57 clm3%g%l%c%p%pns%leafn ! 57 pns%leafn + ! 58 clm3%g%l%c%p%pns%leafn_storage ! 58 pns%leafn_storage + ! 59 clm3%g%l%c%p%pns%leafn_xfer ! 59 pns%leafn_xfer + ! 60 clm3%g%l%c%p%pns%livecrootn ! 60 pns%livecrootn + ! 61 clm3%g%l%c%p%pns%livecrootn_storage ! 61 pns%livecrootn_storage + ! 62 clm3%g%l%c%p%pns%livecrootn_xfer ! 62 pns%livecrootn_xfer + ! 63 clm3%g%l%c%p%pns%livestemn ! 63 pns%livestemn + ! 64 clm3%g%l%c%p%pns%livestemn_storage ! 64 pns%livestemn_storage + ! 65 clm3%g%l%c%p%pns%livestemn_xfer ! 65 pns%livestemn_xfer + ! 66 clm3%g%l%c%p%pns%npool ! 66 pns%npool + ! 67 clm3%g%l%c%p%pns%pft_ntrunc ! 67 pns%pft_ntrunc + ! 68 clm3%g%l%c%p%pns%retransn ! 68 pns%retransn + ! 69 clm3%g%l%c%p%pps%elai ! 69 pps%elai + ! 70 clm3%g%l%c%p%pps%esai ! 70 pps%esai + ! 71 clm3%g%l%c%p%pps%hbot ! 71 pps%hbot + ! 72 clm3%g%l%c%p%pps%htop ! 72 pps%htop + ! 73 clm3%g%l%c%p%pps%tlai ! 73 pps%tlai + ! 74 clm3%g%l%c%p%pps%tsai ! 74 pps%tsai + ! 75 pepv%plant_ndemand + ! OLD ! 75 pps%gddplant + ! OLD ! 76 pps%gddtsoi + ! OLD ! 77 pps%peaklai + ! OLD ! 78 pps%idop + ! OLD ! 79 pps%aleaf + ! OLD ! 80 pps%aleafi + ! OLD ! 81 pps%astem + ! OLD ! 82 pps%astemi + ! OLD ! 83 pps%htmx + ! OLD ! 84 pps%hdidx + ! OLD ! 85 pps%vf + ! OLD ! 86 pps%cumvd + ! OLD ! 87 pps%croplive + ! OLD ! 88 pps%cropplant + ! OLD ! 89 pps%harvdate + ! OLD ! 90 pps%gdd1020 + ! OLD ! 91 pps%gdd820 + ! OLD ! 92 pps%gdd020 + ! OLD ! 93 pps%gddmaturity + ! OLD ! 94 pps%huileaf + ! OLD ! 95 pps%huigrain + ! OLD ! 96 pcs%grainc + ! OLD ! 97 pcs%grainc_storage + ! OLD ! 98 pcs%grainc_xfer + ! OLD ! 99 pns%grainn + ! OLD !100 pns%grainn_storage + ! OLD !101 pns%grainn_xfer + ! OLD !102 pepv%fert_counter + ! OLD !103 pnf%fert + ! OLD !104 pepv%grain_flag + + end do OUT_TILE + + i = 1 + deallocate(this%cncol) + allocate(this%cncol(NTILES, nzone*VAR_COL)) + do nv = 1,VAR_COL + do nz = 1,nzone + this%cncol(:,i) = var_col_out(:, nz,nv) + !STATUS = NF_PUT_VARA_REAL(OutID,VarID(OutID,'CNCOL'), (/1,i/), (/NTILES,1 /),var_col_out(:, nz,nv)) ; VERIFY_(STATUS) + i = i + 1 + end do + end do + + i = 1 + deallocate(this%cnpft) + allocate(this%cnpft(NTILES,VAR_PFT*nveg*nzone)) + if(this%isclm45) then + do iv = 1,VAR_PFT + do nv = 1,nveg + do nz = 1,nzone + if(iv <= 74) then + this%cnpft(:,i) = var_pft_out(:, nz,nv,iv) + !STATUS = NF_PUT_VARA_REAL(OutID,VarID(OutID,'CNPFT'), (/1,i/), (/NTILES,1 /),var_pft_out(:, nz,nv,iv)) ; VERIFY_(STATUS) + else + if((iv == 78) .OR. (iv == 89)) then ! idop and harvdate + var_dum = 999 + this%cnpft(:,i) = var_dum + !STATUS = NF_PUT_VARA_REAL(OutID,VarID(OutID,'CNPFT'), (/1,i/), (/NTILES,1 /),var_dum) ; VERIFY_(STATUS) + else + var_dum = 0. + this%cnpft(:,i) = var_dum + !STATUS = NF_PUT_VARA_REAL(OutID,VarID(OutID,'CNPFT'), (/1,i/), (/NTILES,1 /),var_dum) ; VERIFY_(STATUS) + endif + endif + i = i + 1 + end do + end do + end do + else + do iv = 1,VAR_PFT + do nv = 1,nveg + do nz = 1,nzone + this%cnpft(:,i) = var_pft_out(:, nz,nv,iv) + !STATUS = NF_PUT_VARA_REAL(OutID,VarID(OutID,'CNPFT'), (/1,i/), (/NTILES,1 /),var_pft_out(:, nz,nv,iv)) ; VERIFY_(STATUS) + i = i + 1 + end do + end do + end do + endif + + VAR_DUM = 0. + deallocate(this%tgwm,this%rzmm) + allocate(this%tgwm(Ntiles, nzone), source = 0.) + allocate(this%rzmm(Ntiles, nzone), source = 0.) + if (this%isCLM45) then + deallocate(this%SFMM) + allocate(this%sfmm(ntiles, nzone), source =0.) + endif + + this%bflowm = var_dum + this%totwatm = var_dum + this%TAIRM = var_dum + this%TPM = var_dum + + this%CNSUM = VAR_DUM + this%SNDZM = VAR_DUM + this%ASNOWM = VAR_DUM + if(this%isCLM45) then + this%AR1M = VAR_DUM + this%RAINFM = VAR_DUM + this%RHM = VAR_DUM + this%RUNSRFM= VAR_DUM + this%SNOWFM = VAR_DUM + this%WINDM = VAR_DUM + this%TPREC10D=VAR_DUM + this%TPREC60D=VAR_DUM + this%T2M10D =VAR_DUM + else + this%sfmcm = VAR_DUM + endif + deallocate(this%PSNSUNM, this%PSNSHAM) + allocate(this%PSNSUNM(Ntiles,nzone,nveg), source =0.) + allocate(this%PSNSHAM(Ntiles,nzone,nveg), source =0.) + + deallocate (var_col_out,var_pft_out) + deallocate (CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2) + deallocate (CLMC_pt1, CLMC_pt2, CLMC_st1, CLMC_st2) + + end subroutine regrid_carbon + + subroutine compute_dayx ( & + NTILES, AGCM_YY, AGCM_MM, AGCM_DD, AGCM_HR, & + LATT, DAYX) + + implicit none + + integer, intent (in) :: NTILES,AGCM_YY,AGCM_MM,AGCM_DD,AGCM_HR + real, dimension (NTILES), intent (in) :: LATT + real, dimension (NTILES), intent (out) :: DAYX + integer, parameter :: DT = 900 + integer, parameter :: ncycle = 1461 ! number of days in a 4-year leap cycle (365*4 + 1) + real, dimension(ncycle) :: zc, zs + integer :: dofyr, sec,YEARS_PER_CYCLE, DAYS_PER_CYCLE, year, iday, idayp1, nn, n + real :: fac, YEARLEN, zsin, zcos, declin + + dofyr = AGCM_DD + if(AGCM_MM > 1) dofyr = dofyr + 31 + if(AGCM_MM > 2) then + dofyr = dofyr + 28 + if(mod(AGCM_YY,4) == 0) dofyr = dofyr + 1 + endif + if(AGCM_MM > 3) dofyr = dofyr + 31 + if(AGCM_MM > 4) dofyr = dofyr + 30 + if(AGCM_MM > 5) dofyr = dofyr + 31 + if(AGCM_MM > 6) dofyr = dofyr + 30 + if(AGCM_MM > 7) dofyr = dofyr + 31 + if(AGCM_MM > 8) dofyr = dofyr + 31 + if(AGCM_MM > 9) dofyr = dofyr + 30 + if(AGCM_MM > 10) dofyr = dofyr + 31 + if(AGCM_MM > 11) dofyr = dofyr + 30 + + sec = AGCM_HR * 3600 - DT ! subtract DT to get time of previous physics step + fac = real(sec) / 86400. + + + call orbit_create(zs,zc,ncycle) ! GEOS5 leap cycle routine + + YEARLEN = 365.25 + + ! Compute length of leap cycle + !------------------------------ + + if(YEARLEN-int(YEARLEN) > 0.) then + YEARS_PER_CYCLE = nint(1./(YEARLEN-int(YEARLEN))) + else + YEARS_PER_CYCLE = 1 + endif + + DAYS_PER_CYCLE=nint(YEARLEN*YEARS_PER_CYCLE) + + ! declination & daylength + ! ----------------------- + + YEAR = mod(AGCM_YY-1,YEARS_PER_CYCLE) + + IDAY = YEAR*int(YEARLEN)+dofyr + IDAYP1 = mod(IDAY,DAYS_PER_CYCLE) + 1 + + ZSin = ZS(IDAYP1)*FAC + ZS(IDAY)*(1.-FAC) ! sine of solar declination + ZCos = ZC(IDAYP1)*FAC + ZC(IDAY)*(1.-FAC) ! cosine of solar declination + + nn = 0 + do n = 1,days_per_cycle + nn = nn + 1 + if(nn > 365) nn = nn - 365 + ! print *, 'cycle:',n,nn,asin(ZS(n)) + end do + declin = asin(ZSin) + + ! compute daylength on input tile space (accounts for any change in physics time step) + ! do n = 1,ntiles_cn + ! fac = -(sin((latc(n)/zoom)*(MAPL_PI/180.))*zsin)/(cos((latc(n)/zoom)*(MAPL_PI/180.))*zcos) + ! fac = min(1.,max(-1.,fac)) + ! dayl(n) = (86400./MAPL_PI) * acos(fac) ! daylength (seconds) + ! end do + + ! compute daylength on output tile space (accounts for lat shift due to split & change in time step) + + do n = 1,ntiles + fac = -(sin(latt(n)*(MAPL_PI/180.))*zsin)/(cos(latt(n)*(MAPL_PI/180.))*zcos) + fac = min(1.,max(-1.,fac)) + dayx(n) = (86400./MAPL_PI) * acos(fac) ! daylength (seconds) + end do + + ! print *,'DAYX : ', minval(dayx),maxval(dayx), minval(latt), maxval(latt), zsin, zcos, dofyr, iday, idayp1, declin + + end subroutine compute_dayx + + ! ***************************************************************************** + + subroutine orbit_create(zs,zc,ncycle) + implicit none + + integer, intent(in) :: ncycle + real, intent(out), dimension(ncycle) :: zs, zc + + integer :: YEARS_PER_CYCLE, DAYS_PER_CYCLE + integer :: K, KP !, KM + real*8 :: T1, T2, T3, T4, FUN, Y, SOB, OMG, PRH, TT + real*8 :: YEARLEN + + ! STATEMENT FUNCTION + + FUN(Y) = OMG*(1.0-ECCENTRICITY*cos(Y-PRH))**2 + + YEARLEN = 365.25 + + ! Factors involving the orbital parameters + !------------------------------------------ + + OMG = (2.0*MAPL_PI/YEARLEN) / (sqrt(1.-ECCENTRICITY**2)**3) + PRH = PERIHELION*(MAPL_PI/180.) + SOB = sin(OBLIQUITY*(MAPL_PI/180.)) + + ! Compute length of leap cycle + !------------------------------ + + if(YEARLEN-int(YEARLEN) > 0.) then + YEARS_PER_CYCLE = nint(1./(YEARLEN-int(YEARLEN))) + else + YEARS_PER_CYCLE = 1 + endif + + + DAYS_PER_CYCLE=nint(YEARLEN*YEARS_PER_CYCLE) + + if(days_per_cycle /= ncycle) stop 'bad cycle' + + ! ZS: Sine of declination + ! ZC: Cosine of declination + + ! Begin integration at vernal equinox + + KP = EQUINOX + TT = 0.0 + ZS(KP) = sin(TT)*SOB + ZC(KP) = sqrt(1.0-ZS(KP)**2) + + ! Integrate orbit for entire leap cycle using Runge-Kutta + + do K=2,DAYS_PER_CYCLE + T1 = FUN(TT ) + T2 = FUN(TT+T1*0.5) + T3 = FUN(TT+T2*0.5) + T4 = FUN(TT+T3 ) + KP = mod(KP,DAYS_PER_CYCLE) + 1 + TT = TT + (T1 + 2.0*(T2 + T3) + T4) / 6.0 + ZS(KP) = sin(TT)*SOB + ZC(KP) = sqrt(1.0-ZS(KP)**2) + end do + + end subroutine orbit_create + + end subroutine re_tile end module CatchmentCNRstMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentRst.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentRst.F90 index d6faba569..0086d7bb1 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentRst.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentRst.F90 @@ -1,11 +1,14 @@ #include "MAPL_Generic.h" module CatchmentRstMod + use mk_restarts_getidsMod use MAPL + use mpi use LSM_ROUTINES, ONLY: & catch_calc_soil_moist, & catch_calc_tp, & catch_calc_ght + USE CATCH_CONSTANTS, ONLY: & N_GT => CATCH_N_GT, & DZGT => CATCH_DZGT, & @@ -16,8 +19,26 @@ module CatchmentRstMod integer :: ftell external :: ftell #endif + type :: scale_var + real, allocatable :: catdef(:) + real, allocatable :: cdcr1 (:) + real, allocatable :: cdcr2 (:) + real, allocatable :: rzexc (:) + real, allocatable :: vgwmax(:) + real, allocatable :: ghtcnt1(:) + real, allocatable :: ghtcnt2(:) + real, allocatable :: ghtcnt3(:) + real, allocatable :: ghtcnt4(:) + real, allocatable :: ghtcnt5(:) + real, allocatable :: ghtcnt6(:) + real, allocatable :: poros(:) + real, allocatable :: sndzn3(:) + end type scale_var + type :: CatchmentRst integer :: ntiles + type(FileMetadata) :: meta + character(len=:), allocatable :: time !yyyymmddhhmm real, allocatable :: bf1(:) real, allocatable :: bf2(:) real, allocatable :: bf3(:) @@ -82,38 +103,47 @@ module CatchmentRstMod procedure :: write_shared_nc4 procedure :: add_bcs_to_rst procedure :: allocate_catch + procedure :: re_tile + procedure :: re_scale + procedure :: set_scale_var endtype CatchmentRst interface CatchmentRst module procedure CatchmentRst_Create + module procedure CatchmentRst_empty end interface contains - function CatchmentRst_create(filename, rc) result (catch) - type(CatchmentRst) :: catch - character(*), intent(in) :: filename - integer, optional, intent(out) :: rc - integer :: status - character(len=256) :: Iam = "CatchmentRst_create" - type(Netcdf4_fileformatter) :: formatter - integer :: filetype, ntiles, unit - type(FileMetadata) :: meta - integer :: bpos, epos, n + function CatchmentRst_create(filename, time, rc) result (catch) + type(CatchmentRst) :: catch + character(*), intent(in) :: filename + character(*), intent(in) :: time ! yyyymmddhhmm format + integer, optional, intent(out) :: rc + integer :: status + character(len=256) :: Iam = "CatchmentRst_create" + type(Netcdf4_fileformatter) :: formatter + integer :: filetype, ntiles, unit + type(FileMetadata) :: meta + integer :: bpos, epos, n - call MAPL_NCIOGetFileType(filename, filetype, __RC__) + catch%time = time + call MAPL_NCIOGetFileType(filename, filetype, __RC__) if(filetype == 0) then ! nc4 format call formatter%open(filename, pFIO_READ, __RC__) - meta = formatter%read(__RC__) ntiles = meta%get_dimension('tile', __RC__) - this%ntiles = ntiles + catch%ntiles = ntiles + catch%meta = formatter%read(__RC__) call catch%allocate_catch() call catch%read_shared_nc4(formatter, __RC__) call MAPL_VarRead(formatter,"OLD_ITY",catch%ity, __RC__) call formatter%close() else + !if ( .not. present(time)) then + ! _ASSERT(.false., 'Please provide time for binary catch, format yyyymmddhhmm') + !endif !GEOSldas binary open(newunit=unit, file=filename, form='unformatted', action = 'read') bpos=0 @@ -121,76 +151,96 @@ function CatchmentRst_create(filename, rc) result (catch) epos = ftell(unit) ! ending position of file pointer close(unit) ntiles = (epos-bpos)/4-2 ! record size (in 4 byte words; - this%ntiles = ntiles + catch%ntiles = ntiles + catch%meta = create_meta(ntiles, time) call catch%allocate_catch() call catch%read_GEOSldas_rst_bin(filename, __RC__) endif _RETURN(_SUCCESS) end function CatchmentRst_Create + function CatchmentRst_empty(meta, time, rc) result (catch) + type(CatchmentRst) :: catch + character(*), intent(in) :: time + type(FileMetadata), intent(in) :: meta + + integer, optional, intent(out) :: rc + integer :: status + character(len=256) :: Iam = "CatchmentRst_create" + type(Netcdf4_fileformatter) :: formatter + + + ! nc4 format + catch%ntiles = meta%get_dimension('tile', __RC__) + catch%meta = meta + catch%time = time + call catch%allocate_catch() + _RETURN(_SUCCESS) + end function CatchmentRst_empty + subroutine read_GEOSldas_rst_bin(this, filename, rc) class(CatchmentRst), intent(inout) :: this character(*), intent(in) :: filename integer, optional, intent(out) :: rc integer :: unit open(newunit=unit, file=filename, form='unformatted', action='read') - read(unit) catch% bf1 - read(unit) catch% bf2 - read(unit) catch% bf3 - read(unit) catch% vgwmax - read(unit) catch% cdcr1 - read(unit) catch% cdcr2 - read(unit) catch% psis - read(unit) catch% bee - read(unit) catch% poros - read(unit) catch% wpwet - read(unit) catch% cond - read(unit) catch% gnu - read(unit) catch% ars1 - read(unit) catch% ars2 - read(unit) catch% ars3 - read(unit) catch% ara1 - read(unit) catch% ara2 - read(unit) catch% ara3 - read(unit) catch% ara4 - read(unit) catch% arw1 - read(unit) catch% arw2 - read(unit) catch% arw3 - read(unit) catch% arw4 - read(unit) catch% tsa1 - read(unit) catch% tsa2 - read(unit) catch% tsb1 - read(unit) catch% tsb2 - read(unit) catch% atau - read(unit) catch% btau - read(unit) catch% ity - read(unit) catch% tc - read(unit) catch% qc - read(unit) catch% capac - read(unit) catch% catdef - read(unit) catch% rzexc - read(unit) catch% srfexc - read(unit) catch% ghtcnt1 - read(unit) catch% ghtcnt2 - read(unit) catch% ghtcnt3 - read(unit) catch% ghtcnt4 - read(unit) catch% ghtcnt5 - read(unit) catch% ghtcnt6 - read(unit) catch% tsurf - read(unit) catch% wesnn1 - read(unit) catch% wesnn2 - read(unit) catch% wesnn3 - read(unit) catch% htsnnn1 - read(unit) catch% htsnnn2 - read(unit) catch% htsnnn3 - read(unit) catch% sndzn1 - read(unit) catch% sndzn2 - read(unit) catch% sndzn3 - read(unit) catch% ch - read(unit) catch% cm - read(unit) catch% cq - read(unit) catch% fr - read(unit) catch% ww + read(unit) this% bf1 + read(unit) this% bf2 + read(unit) this% bf3 + read(unit) this% vgwmax + read(unit) this% cdcr1 + read(unit) this% cdcr2 + read(unit) this% psis + read(unit) this% bee + read(unit) this% poros + read(unit) this% wpwet + read(unit) this% cond + read(unit) this% gnu + read(unit) this% ars1 + read(unit) this% ars2 + read(unit) this% ars3 + read(unit) this% ara1 + read(unit) this% ara2 + read(unit) this% ara3 + read(unit) this% ara4 + read(unit) this% arw1 + read(unit) this% arw2 + read(unit) this% arw3 + read(unit) this% arw4 + read(unit) this% tsa1 + read(unit) this% tsa2 + read(unit) this% tsb1 + read(unit) this% tsb2 + read(unit) this% atau + read(unit) this% btau + read(unit) this% ity + read(unit) this% tc + read(unit) this% qc + read(unit) this% capac + read(unit) this% catdef + read(unit) this% rzexc + read(unit) this% srfexc + read(unit) this% ghtcnt1 + read(unit) this% ghtcnt2 + read(unit) this% ghtcnt3 + read(unit) this% ghtcnt4 + read(unit) this% ghtcnt5 + read(unit) this% ghtcnt6 + read(unit) this% tsurf + read(unit) this% wesnn1 + read(unit) this% wesnn2 + read(unit) this% wesnn3 + read(unit) this% htsnnn1 + read(unit) this% htsnnn2 + read(unit) this% htsnnn3 + read(unit) this% sndzn1 + read(unit) this% sndzn2 + read(unit) this% sndzn3 + read(unit) this% ch + read(unit) this% cm + read(unit) this% cq + read(unit) this% fr + read(unit) this% ww close(unit) _RETURN(_SUCCESS) end subroutine read_GEOSldas_rst_bin @@ -264,11 +314,9 @@ subroutine read_shared_nc4(this, formatter, rc) _RETURN(_SUCCESS) end subroutine - subroutine write_nc4 (this, filename, meta, cnclm, rc) + subroutine write_nc4 (this, filename, rc) class(CatchmentRst), intent(inout):: this character(*), intent(in) :: filename - type(FileMetaData), intent(inout) :: meta - character(*), intent(in) :: cnclm integer, optional, intent(out):: rc type(Netcdf4_fileformatter) :: formatter @@ -276,7 +324,7 @@ subroutine write_nc4 (this, filename, meta, cnclm, rc) character(256) :: Iam = "write_nc4" call formatter%create(filename, __RC__) - call formatter%write(meta, __RC__) + call formatter%write(this%meta, __RC__) call this%write_shared_nc4(formatter, __RC__) call MAPL_VarWrite(formatter,"OLD_ITY",this%ity) call formatter%close() @@ -412,12 +460,13 @@ subroutine allocate_catch(this,rc) allocate( this% fr(ntiles,4) ) allocate( this% ww(ntiles,4) ) _RETURN(_SUCCESS) - end subroutine allocate + end subroutine allocate_catch ! This subroutine reads BCs from BCSDIR and hydrological varable subroutine add_bcs_to_rst(this, surflay, DataDir, rc) class(CatchmentRst), intent(inout) :: this real, intent(in) :: surflay + character(*), intent(in) :: DataDir integer, optional, intent(out) :: rc real, allocatable :: DP2BR(:) @@ -440,6 +489,39 @@ subroutine add_bcs_to_rst(this, surflay, DataDir, rc) inquire(file = trim(DataDir)//'/catch_params.nc4', exist=file_exists) inquire(file = trim(DataDir)//"CLM_veg_typs_fracs",exist=NewLand ) + if (size(this%ara1) /= this%ntiles ) then + ! it is just re-allocate + this%ity = DP2BR + this%ARA1 = DP2BR + this%ARA2 = DP2BR + this%ARA3 = DP2BR + this%ARA4 = DP2BR + this%ARS1 = DP2BR + this%ARS2 = DP2BR + this%ARS3 = DP2BR + this%ARW1 = DP2BR + this%ARW2 = DP2BR + this%ARW3 = DP2BR + this%ARW4 = DP2BR + this%ATAU = DP2BR + this%BTAU = DP2BR + this%PSIS = DP2BR + this%BEE = DP2BR + this%BF1 = DP2BR + this%BF2 = DP2BR + this%BF3 = DP2BR + this%TSA1 = DP2BR + this%TSA2 = DP2BR + this%TSB1 = DP2BR + this%TSB2 = DP2BR + this%COND = DP2BR + this%WPWET = DP2BR + this%POROS = DP2BR + this%VGWMAX = DP2BR + this%cdcr1 = DP2BR + this%cdcr2 = DP2BR + endif + if(file_exists) then call CatchFmt%Open(trim(DataDir)//'/catch_params.nc4', pFIO_READ, __RC__) call MAPL_VarRead ( CatchFmt ,'OLD_ITY', this%ITY, __RC__) @@ -542,4 +624,562 @@ subroutine add_bcs_to_rst(this, surflay, DataDir, rc) _RETURN(_SUCCESS) end subroutine add_bcs_to_rst + type(FileMetadata) function create_meta(ntiles, t, rc) result(meta) + integer, intent(in) :: ntiles + character(*), intent(in) :: t ! yyyymmddmmhh format + integer, optional, intent(out) :: rc + character(64), dimension(58, 3) :: fields + integer :: n, status + character(:), allocatable :: s + type(Variable) :: var + + fields(1,:) = [character(len=64)::"ARA1" , "shape_param_1" , "m+2 kg-1"] + fields(2,:) = [character(len=64)::"ARA2" , "shape_param_2" , "1"] + fields(3,:) = [character(len=64)::"ARA3" , "shape_param_3" , "m+2 kg-1"] + fields(4,:) = [character(len=64)::"ARA4" , "shape_param_4" , "1"] + fields(5,:) = [character(len=64)::"ARS1" , "wetness_param_1" , "m+2 kg-1"] + fields(6,:) = [character(len=64)::"ARS2" , "wetness_param_2" , "m+2 kg-1"] + fields(7,:) = [character(len=64)::"ARS3" , "wetness_param_3" , "m+4 kg-2"] + fields(8,:) = [character(len=64)::"ARW1" , "min_theta_param_1" , "m+2 kg-1"] + fields(9,:) = [character(len=64)::"ARW2" , "min_theta_param_2" , "m+2 kg-1"] + fields(10,:) = [character(len=64)::"ARW3" , "min_theta_param_3" , "m+4 kg-2"] + fields(11,:) = [character(len=64)::"ARW4" , "min_theta_param_4" , "1"] + fields(12,:) = [character(len=64)::"ATAU" , "water_transfer_param_5" , "1"] + fields(13,:) = [character(len=64)::"BEE" , "clapp_hornberger_b" , "1"] + fields(14,:) = [character(len=64)::"BF1" , "topo_baseflow_param_1" , "kg m-4"] + fields(15,:) = [character(len=64)::"BF2" , "topo_baseflow_param_2" , "m"] + fields(16,:) = [character(len=64)::"BF3" , "topo_baseflow_param_3" , "log(m)"] + fields(17,:) = [character(len=64)::"BTAU" , "water_transfer_param_6" , "1"] + fields(18,:) = [character(len=64)::"CAPAC" , "interception_reservoir_capac" , "kg m-2"] + fields(19,:) = [character(len=64)::"CATDEF" , "catchment_deficit" , "kg m-2"] + fields(20,:) = [character(len=64)::"CDCR1" , "moisture_threshold" , "kg m-2"] + fields(21,:) = [character(len=64)::"CDCR2" , "max_water_content" , "kg m-2"] + fields(22,:) = [character(len=64)::"COND" , "sfc_sat_hydraulic_conduct" , "m s-1"] + fields(23,:) = [character(len=64)::"GHTCNT1" , "soil_heat_content_layer_1" , "J m-2"] + fields(24,:) = [character(len=64)::"GHTCNT2" , "soil_heat_content_layer_2" , "J_m-2"] + fields(25,:) = [character(len=64)::"GHTCNT3" , "soil_heat_content_layer_3" , "J m-2"] + fields(26,:) = [character(len=64)::"GHTCNT4" , "soil_heat_content_layer_4" , "J m-2"] + fields(27,:) = [character(len=64)::"GHTCNT5" , "soil_heat_content_layer_5" , "J m-2"] + fields(28,:) = [character(len=64)::"GHTCNT6" , "soil_heat_content_layer_6" , "J m-2"] + fields(29,:) = [character(len=64)::"GNU" , "vertical_transmissivity" , "m-1"] + fields(20,:) = [character(len=64)::"HTSNNN1" , "heat_content_snow_layer_1" , "J m-2"] + fields(31,:) = [character(len=64)::"HTSNNN2" , "heat_content_snow_layer_2" , "J m-2"] + fields(32,:) = [character(len=64)::"HTSNNN3" , "heat_content_snow_layer_3" , "J m-2"] + fields(33,:) = [character(len=64)::"OLD_ITY" , "Placeholder. Used to be vegetation_type." , "1"] + fields(34,:) = [character(len=64)::"POROS" , "soil_porosity" , "1"] + fields(35,:) = [character(len=64)::"PSIS" , "saturated_matric_potential" , "m"] + fields(36,:) = [character(len=64)::"RZEXC" , "root_zone_excess" , "kg m-2"] + fields(37,:) = [character(len=64)::"SNDZN1" , "snow_depth_layer_1" , "m"] + fields(38,:) = [character(len=64)::"SNDZN2" , "snow_depth_layer_2" , "m"] + fields(39,:) = [character(len=64)::"SNDZN3" , "snow_depth_layer_3" , "m"] + fields(40,:) = [character(len=64)::"SRFEXC" , "surface_excess" , "kg m-2"] + fields(41,:) = [character(len=64)::"TILE_ID" , "catchment_tile_id" , "1"] + fields(42,:) = [character(len=64)::"TSA1" , "water_transfer_param_1" , "1"] + fields(43,:) = [character(len=64)::"TSA2" , "water_transfer_param_2" , "1"] + fields(44,:) = [character(len=64)::"TSB1" , "water_transfer_param_3" , "1"] + fields(45,:) = [character(len=64)::"TSB2" , "water_transfer_param_4" , "1"] + fields(46,:) = [character(len=64)::"TSURF" , "mean_catchment_temp_incl_snw" , "K"] + fields(47,:) = [character(len=64)::"VGWMAX" , "max_rootzone_water_content" , "kg m-2"] + fields(48,:) = [character(len=64)::"WESNN1" , "snow_mass_layer_1" , "kg m-2"] + fields(49,:) = [character(len=64)::"WESNN2" , "snow_mass_layer_2" , "kg m-2"] + fields(50,:) = [character(len=64)::"WESNN3" , "snow_mass_layer_3" , "kg m-2"] + fields(51,:) = [character(len=64)::"WPWET" , "wetness_at_wilting_point" , "1"] + fields(52,:) = [character(len=64)::"CH" , "surface_heat_exchange_coefficient" , "kg m-2 s-1"] + fields(53,:) = [character(len=64)::"CM" , "surface_momentum_exchange_coefficient" , "kg m-2 s-1"] + fields(54,:) = [character(len=64)::"CQ" , "surface_moisture_exchange_coffiecient" , "kg m-2 s-1"] + fields(55,:) = [character(len=64)::"FR" , "subtile_fractions" , "1"] + fields(56,:) = [character(len=64)::"QC" , "canopy_specific_humidity" , "kg kg-1"] + fields(57,:) = [character(len=64)::"TC" , "canopy_temperature" , "K"] + fields(58,:) = [character(len=64)::"WW" , "vertical_velocity_scale_squared" , "m+2 s-2"] + + call meta%add_dimension('tile', ntiles) + call meta%add_dimension('subtile', 4) + call meta%add_dimension('time',1) + + do n = 1, 51 + if (n >=52) then + var = Variable(type=pFIO_REAL32, dimensions='tile,subtile') + else + var = Variable(type=pFIO_REAL32, dimensions='tile') + endif + call var%add_attribute('long_name', trim(fields(n,2))) + call var%add_attribute('units', trim(fields(n,3))) + call meta%add_variable(trim(fields(n,1)), var) + enddo + var = Variable(type=pFIO_REAL32, dimensions='time') + s = "minutes since "//t(1:4)//"-"//t(5:6)//"-"//t(7:8)//" "//t(9:10)//":"//t(11:12)//":00" + call var%add_attribute('units', s) + call meta%add_variable('time', var) + _RETURN(_SUCCESS) + end function create_meta + + subroutine re_tile(this, InTileFile, OutBcsDir, OutTileFile, surflay, rc) + class(CatchmentRst), intent(inout) :: this + character(*), intent(in) :: InTileFile + character(*), intent(in) :: OutBcsDir + character(*), intent(in) :: OutTileFile + real, intent(in) :: surflay + integer, optional, intent(out) :: rc + integer :: status, in_ntiles, out_ntiles, myid, numprocs + real, allocatable :: var_out(:), tmp2d(:,:) + real , allocatable , dimension (:) :: long, latg, lonc, latc, lonn,latt + integer, allocatable , dimension (:) :: low_ind, upp_ind, nt_local + integer, allocatable , dimension (:) :: Id_glb, id_loc, tid_offl + logical :: root_proc + integer :: mpierr, n, i, k, req + type(CatchmentRst) :: xgrid + type(FileMetadata) :: meta + character(*), parameter :: Iam = "Catchment::Re_tile" + + open (10,file =trim(OutBcsDir)//"clsm/catchment.def",status='old',form='formatted') + read (10,*) out_ntiles + close (10, status = 'keep') + + in_ntiles = this%ntiles + + call this%meta%modify_dimension('tile', out_ntiles, __RC__) + + call MPI_COMM_RANK( MPI_COMM_WORLD, myid, mpierr ) + call MPI_COMM_SIZE( MPI_COMM_WORLD, numprocs, mpierr ) + root_proc = .false. + if (myid == 0) root_proc = .true. + + if(root_proc) then + print *,'ntiles in BCs : ',out_ntiles + print *,'ntiles in restarts : ',in_ntiles + endif + + + ! Domain decomposition + ! -------------------- + + + allocate(low_ind ( numprocs)) + allocate(upp_ind ( numprocs)) + allocate(nt_local( numprocs)) + low_ind (:) = 1 + upp_ind (:) = out_ntiles + nt_local(:) = out_ntiles + + if (numprocs > 1) then + do i = 1, numprocs - 1 + upp_ind(i) = low_ind(i) + (out_ntiles/numprocs) - 1 + low_ind(i+1) = upp_ind(i) + 1 + nt_local(i) = upp_ind(i) - low_ind(i) + 1 + end do + nt_local(numprocs) = upp_ind(numprocs) - low_ind(numprocs) + 1 + endif + + allocate (id_loc (nt_local (myid + 1))) + allocate (lonn (nt_local (myid + 1))) + allocate (latt (nt_local (myid + 1))) + allocate (lonc (1:in_ntiles)) + allocate (latc (1:in_ntiles)) + allocate (tid_offl (in_ntiles)) + + if (root_proc) then + allocate (long (out_ntiles)) + allocate (latg (out_ntiles)) + call ReadTileFile_RealLatLon ( OutTileFile, n, long, latg) + _ASSERT( n == out_ntiles, "Out tile number should match") + call ReadTileFile_RealLatLon ( InTileFile, n, lonc, latc) + _ASSERT( n == in_ntiles, "In tile number should match") + endif + + do i = 1, in_ntiles + tid_offl(i) = i + end do + + ! create mapping, nearest + call MPI_Barrier(MPI_COMM_WORLD, STATUS) + + do i = 1, numprocs + if((I == 1).and.(myid == 0)) then + lonn(:) = long(low_ind(i) : upp_ind(i)) + latt(:) = latg(low_ind(i) : upp_ind(i)) + else if (I > 1) then + if(I-1 == myid) then + ! receiving from root + call MPI_RECV(lonn,nt_local(i) , MPI_REAL, 0,995,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) + call MPI_RECV(latt,nt_local(i) , MPI_REAL, 0,994,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) + else if (myid == 0) then + ! root sends + call MPI_ISend(long(low_ind(i) : upp_ind(i)),nt_local(i),MPI_REAL,i-1,995,MPI_COMM_WORLD,req,mpierr) + call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) + call MPI_ISend(latg(low_ind(i) : upp_ind(i)),nt_local(i),MPI_REAL,i-1,994,MPI_COMM_WORLD,req,mpierr) + call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) + endif + endif + enddo + if(root_proc) deallocate (long) + + call MPI_BCAST(lonc,in_ntiles,MPI_REAL,0,MPI_COMM_WORLD,mpierr) + call MPI_BCAST(latc,in_ntiles,MPI_REAL,0,MPI_COMM_WORLD,mpierr) + + ! -------------------------------------------------------------------------------- + ! Here we create transfer index array to map offline restarts to output tile space + ! -------------------------------------------------------------------------------- + + ! id_glb for hydrologic variable + + call GetIds(lonc, latc, lonn, latt, id_loc, tid_offl) + if(root_proc) allocate (id_glb (out_ntiles)) + + call MPI_Barrier(MPI_COMM_WORLD, STATUS) + + do i = 1, numprocs + if((I == 1).and.(myid == 0)) then + id_glb(low_ind(i) : upp_ind(i)) = Id_loc(:) + else if (I > 1) then + if(I-1 == myid) then + ! send to root + call MPI_ISend(id_loc,nt_local(i),MPI_INTEGER,0,993,MPI_COMM_WORLD,req,mpierr) + call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) + else if (myid == 0) then + ! root receives + call MPI_RECV(id_glb(low_ind(i) : upp_ind(i)),nt_local(i) , MPI_INTEGER, i-1,993,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) + endif + endif + end do + + deallocate (id_loc) + + this%ntiles = out_ntiles + if (root_proc) then + ! regrid + var_out = this%poros(id_glb(:)) + this%poros = var_out + + var_out = this%cond(id_glb(:)) + this%cond = var_out + + var_out = this%psis(id_glb(:)) + this%psis = var_out + + var_out = this%bee(id_glb(:)) + this%bee = var_out + + var_out = this%wpwet(id_glb(:)) + this%wpwet = var_out + + var_out = this%gnu(id_glb(:)) + this%gnu = var_out + + var_out = this%vgwmax(id_glb(:)) + this%vgwmax = var_out + + var_out = this%bf1(id_glb(:)) + this%bf1 = var_out + + var_out = this%bf2(id_glb(:)) + this%bf2 = var_out + + var_out = this%bf3(id_glb(:)) + this%bf3 = var_out + + var_out = this%cdcr1(id_glb(:)) + this%cdcr1 = var_out + + var_out = this%cdcr2(id_glb(:)) + this%cdcr2 = var_out + + var_out = this%ars1(id_glb(:)) + this%ars1 = var_out + + var_out = this%ars2(id_glb(:)) + this%ars2 = var_out + + var_out = this%ars3(id_glb(:)) + this%ars3 = var_out + + var_out = this%ara1(id_glb(:)) + this%ara1 = var_out + + var_out = this%ara2(id_glb(:)) + this%ara2 = var_out + + var_out = this%ara3(id_glb(:)) + this%ara3 = var_out + + var_out = this%ara4(id_glb(:)) + this%ara4 = var_out + + var_out = this%arw1(id_glb(:)) + this%arw1 = var_out + + var_out = this%arw2(id_glb(:)) + this%arw2 = var_out + + var_out = this%arw4(id_glb(:)) + this%arw4 = var_out + + var_out = this%tsa1(id_glb(:)) + this%tsa1 = var_out + + var_out = this%tsa2(id_glb(:)) + this%tsa2 = var_out + + var_out = this%tsb1(id_glb(:)) + this%tsb1 = var_out + + var_out = this%tsb2(id_glb(:)) + this%tsb2 = var_out + + var_out = this%atau(id_glb(:)) + this%atau = var_out + + var_out = this%btau(id_glb(:)) + this%btau = var_out + + this%ity = [(k*1., k=1, out_ntiles)] + + do k = 1, 3 + tmp2d = this%tc + deallocate(this%tc) + allocate(this%tc(out_ntiles, 4)) + this%tc(:,k) = tmp2d(id_glb(:),k) + enddo + + do k = 1, 3 + tmp2d = this%qc + deallocate(this%qc) + allocate(this%qc(out_ntiles, 4)) + this%qc(:,k) = tmp2d(id_glb(:),k) + enddo + + var_out = this%capac(id_glb(:)) + this%capac = var_out + + var_out = this%catdef(id_glb(:)) + this%catdef = var_out + + var_out = this%rzexc(id_glb(:)) + this%rzexc = var_out + + var_out = this%SRFEXC(id_glb(:)) + this%SRFEXC = var_out + + var_out = this%GHTCNT1(id_glb(:)) + this%GHTCNT1 = var_out + + var_out = this%GHTCNT2(id_glb(:)) + this%GHTCNT2 = var_out + + var_out = this%GHTCNT3(id_glb(:)) + this%GHTCNT3 = var_out + var_out = this%GHTCNT4(id_glb(:)) + this%GHTCNT4 = var_out + + var_out = this%GHTCNT5(id_glb(:)) + this%GHTCNT5 = var_out + + var_out = this%GHTCNT6(id_glb(:)) + this%GHTCNT6 = var_out + + var_out = this%WESNN1(id_glb(:)) + this%WESNN1 = var_out + + var_out = this%WESNN2(id_glb(:)) + this%WESNN2 = var_out + + var_out = this%WESNN3(id_glb(:)) + this%WESNN3 = var_out + + var_out = this%HTSNNN1(id_glb(:)) + this%HTSNNN1 = var_out + + var_out = this%HTSNNN2(id_glb(:)) + this%HTSNNN2 = var_out + + var_out = this%HTSNNN3(id_glb(:)) + this%HTSNNN3 = var_out + + var_out = this%SNDZN1(id_glb(:)) + this%SNDZN1 = var_out + + var_out = this%SNDZN2(id_glb(:)) + this%SNDZN2 = var_out + + var_out = this%SNDZN3(id_glb(:)) + this%SNDZN3 = var_out + + ! CH CM CQ FR WW + ! WW + deallocate(this%ww, this%cm, this%cq, this%fr, this%ch) + allocate(this%ww(out_ntiles,4), this%cm(out_ntiles,4), this%cq(out_ntiles,4)) + allocate(this%fr(out_ntiles,4), this%ch(out_ntiles,4)) + this%ww = 0.1 + this%fr = 0.25 + this%ch = 0.001 + this%cm = 0.001 + this%cq = 0.001 + endif + + _RETURN(_SUCCESS) + end subroutine re_tile + + subroutine re_scale(this, surflay, wemin_in, wemin_out, old, rc) + class(CatchmentRst), intent(inout) :: this + real, intent(in) :: surflay + real, intent(in) :: wemin_in + real, intent(in) :: wemin_out + type(scale_var), intent(in) :: old + integer, optional, intent(out) :: rc + integer :: ntiles + + real, allocatable, dimension(:) :: dzsf, ar1, ar2, ar4 + real, allocatable, dimension(:,:) :: TP_IN, GHT_IN, FICE, TP_OUT + real, allocatable, dimension(:) :: swe_in, depth_in, areasc_in, areasc_out, depth_out + + type(Netcdf4_fileformatter) :: formatter + integer :: i, filetype, n + integer :: status + + ntiles = this%ntiles + + n =count((old%catdef .gt. old%cdcr1)) + + print*, "Scale tile and pesentile :", n,100*n/ntiles + +! Scale rxexc regardless of CDCR1, CDCR2 differences +! -------------------------------------------------- + this%rzexc = old%rzexc * ( this%vgwmax / old%vgwmax ) + +! Scale catdef regardless of whether CDCR2 is larger or smaller in the new situation +! ---------------------------------------------------------------------------------- + where (old%catdef .gt. old%cdcr1) + + this%catdef = this%cdcr1 + & + ( old%catdef - old%cdcr1 ) / & + ( old%cdcr2 - old%cdcr1 ) * & + ( this%cdcr2 - this%cdcr1) + end where + +! Scale catdef also for the case where catdef le cdcr1. +! ----------------------------------------------------- + where( old%catdef .le. old%cdcr1) + this%catdef = old%catdef * (this%cdcr1 / old%cdcr1) + end where + +! Sanity Check (catch_calc_soil_moist() forces consistency betw. srfexc, rzexc, catdef) +! ------------ + print *, 'Performing Sanity Check ...' + + dzsf = SURFLAY + allocate ( dzsf(ntiles) ) + allocate ( ar1( ntiles) ) + allocate ( ar2( ntiles) ) + allocate ( ar4( ntiles) ) + + call catch_calc_soil_moist( ntiles, dzsf, & + this%vgwmax, this%cdcr1, this%cdcr2, & + this%psis, this%bee, this%poros, this%wpwet, & + this%ars1, this%ars2, this%ars3, & + this%ara1, this%ara2, this%ara3, this%ara4, & + this%arw1, this%arw2, this%arw3, this%arw4, & + this%bf1, this%bf2, & + this%srfexc, this%rzexc, this%catdef, & + ar1, ar2, ar4 ) + + + allocate (TP_IN (N_GT, Ntiles)) + allocate (GHT_IN (N_GT, Ntiles)) + allocate (FICE (N_GT, NTILES)) + allocate (TP_OUT (N_GT, Ntiles)) + + GHT_IN (1,:) = old%ghtcnt1 + GHT_IN (2,:) = old%ghtcnt2 + GHT_IN (3,:) = old%ghtcnt3 + GHT_IN (4,:) = old%ghtcnt4 + GHT_IN (5,:) = old%ghtcnt5 + GHT_IN (6,:) = old%ghtcnt6 + + call catch_calc_tp ( NTILES, old%poros, GHT_IN, tp_in, FICE) + + do n = 1, ntiles + do i = 1, N_GT + call catch_calc_ght(dzgt(i), this%poros(n), tp_in(i,n), fice(i,n), GHT_IN(i,n)) + end do + end do + + this%ghtcnt1 = GHT_IN (1,:) + this%ghtcnt2 = GHT_IN (2,:) + this%ghtcnt3 = GHT_IN (3,:) + this%ghtcnt4 = GHT_IN (4,:) + this%ghtcnt5 = GHT_IN (5,:) + this%ghtcnt6 = GHT_IN (6,:) + +! Deep soil temp sanity check +! --------------------------- + + call catch_calc_tp ( NTILES, this%poros, GHT_IN, tp_out, FICE) + + print *, 'Percent tiles TP Layer 1 differ : ', 100.* count(ABS(tp_out(1,:) - tp_in(1,:)) > 1.e-5) /float (Ntiles) + print *, 'Percent tiles TP Layer 2 differ : ', 100.* count(ABS(tp_out(2,:) - tp_in(2,:)) > 1.e-5) /float (Ntiles) + print *, 'Percent tiles TP Layer 3 differ : ', 100.* count(ABS(tp_out(3,:) - tp_in(3,:)) > 1.e-5) /float (Ntiles) + print *, 'Percent tiles TP Layer 4 differ : ', 100.* count(ABS(tp_out(4,:) - tp_in(4,:)) > 1.e-5) /float (Ntiles) + print *, 'Percent tiles TP Layer 5 differ : ', 100.* count(ABS(tp_out(5,:) - tp_in(5,:)) > 1.e-5) /float (Ntiles) + print *, 'Percent tiles TP Layer 6 differ : ', 100.* count(ABS(tp_out(6,:) - tp_in(6,:)) > 1.e-5) /float (Ntiles) + +! SNOW scaling +! ------------ + + if(abs(wemin_out-wemin_in) >1.e-6 ) then + + allocate (swe_in (Ntiles)) + allocate (depth_in (Ntiles)) + allocate (depth_out (Ntiles)) + allocate (areasc_in (Ntiles)) + allocate (areasc_out (Ntiles)) + swe_in = this%wesnn1 + this%wesnn2 + this%wesnn3 + depth_in = this%sndzn1 + this%sndzn2 + this%sndzn3 + areasc_in = min(swe_in/wemin_in, 1.) + areasc_out= min(swe_in/wemin_out,1.) + + where (swe_in .gt. 0.) + where (areasc_in .lt. 1. .or. areasc_out .lt. 1.) + ! density_in= swe_in/(areasc_in * depth_in + 1.e-20) + ! depth_out = swe_in/(areasc_out*density_in) + depth_out = areasc_in * depth_in/(areasc_out + 1.e-20) + this%sndzn1 = depth_out/3. + this%sndzn2 = depth_out/3. + this%sndzn3 = depth_out/3. + endwhere + endwhere + + print *, 'Snow scaling summary' + print *, '....................' + print *, 'Percent tiles SNDZ scaled : ', 100.* count (this%sndzn3 .ne. old%sndzn3) /float (count (this%sndzn3 > 0.)) + + endif + + ! PEATCLSM - ensure low CATDEF on peat tiles where "old" restart is not also peat + ! ------------------------------------------------------------------------------- + + where ( (old%poros < PEATCLSM_POROS_THRESHOLD) .and. (this%poros >= PEATCLSM_POROS_THRESHOLD) ) + this%catdef = 25. + this%rzexc = 0. + this%srfexc = 0. + end where + + end subroutine re_scale + + subroutine set_scale_var(this, sca) + class(CatchmentRst), intent(in) :: this + type (scale_var), intent(out) :: sca + sca%catdef = this%catdef + sca%poros = this%poros + sca%cdcr1 = this%cdcr1 + sca%cdcr2 = this%cdcr2 + sca%rzexc = this%rzexc + sca%vgwmax = this%vgwmax + sca%sndzn3 = this%sndzn3 + sca%ghtcnt1 = this%ghtcnt1 + sca%ghtcnt2 = this%ghtcnt2 + sca%ghtcnt3 = this%ghtcnt3 + sca%ghtcnt4 = this%ghtcnt4 + sca%ghtcnt5 = this%ghtcnt5 + sca%ghtcnt6 = this%ghtcnt6 + end subroutine set_scale_var + end module CatchmentRstMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/ScaleCatch.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/ScaleCatch.F90 deleted file mode 100644 index 820a9660f..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/ScaleCatch.F90 +++ /dev/null @@ -1,252 +0,0 @@ -#define I_AM_MAIN -#include "MAPL_Generic.h" - -program ScaleCatch - - use MAPL - use LSM_ROUTINES, ONLY: & - catch_calc_soil_moist, & - catch_calc_tp, & - catch_calc_ght - - USE CATCH_CONSTANTS, ONLY: & - N_GT => CATCH_N_GT, & - DZGT => CATCH_DZGT, & - PEATCLSM_POROS_THRESHOLD - - use CatchmentRstMod - use CatchmentCNRstMod - - implicit none - - character(256) :: old_fname, new_fname, scale_fname, cnclm - integer :: ntiles, n, nargs - integer :: iargc - real :: SURFLAY ! (Ganymed-3 and earlier) SURFLAY=20.0 for Old Soil Params - ! (Ganymed-4 and later ) SURFLAY=50.0 for New Soil Params - real :: WEMIN_IN, WEMIN_OUT - character*256 :: arg(7) - - - class(CatchmentRst), allocatable :: old_catch, new_catch, scale_catch - - real, allocatable, dimension(:) :: dzsf, ar1, ar2, ar4 - real, allocatable, dimension(:,:) :: TP_IN, GHT_IN, FICE, GHT_OUT, TP_OUT - real, allocatable, dimension(:) :: swe_in, depth_in, areasc_in, areasc_out, depth_out - - type(Netcdf4_fileformatter) :: formatter - type(Filemetadata) :: meta - integer :: i, rc, filetype - integer :: status - character(256) :: Iam = "ScaleCatch" - -! Usage -! ----- - if (iargc() /= 6) then - write(*,*) "Usage: ScaleCatch.x " - call exit(2) - end if - - do n=1,7 - call getarg(n,arg(n)) - enddo - -! Open INPUT and Regridded Catch Files -! ------------------------------------ - read(arg(1),'(a)') old_fname - - read(arg(2),'(a)') new_fname - -! Open OUTPUT (Scaled) Catch File -! ------------------------------- - read(arg(3),'(a)') scale_fname -! Get SURFLAY Value -! ----------------- - read(arg(4),*) SURFLAY - read(arg(5),*) WEMIN_IN - read(arg(6),*) WEMIN_OUT -! catch or catchcn? - read(arg(7),'(a)') cnclm - - if (index(cnclm,'40') /=0 .or. index(cnclm,'45') /=0 ) then - allocate(old_catch, source = CatchmentCNRst(old_fname, cnclm)) - allocate(new_catch, source = CatchmentCNRst(new_fname, cnclm)) - allocate(scale_catch, source = new_catch) - else - allocate(old_catch, source = CatchmentRst(old_fname)) - allocate(new_catch, source = CatchmentRst(new_fname)) - allocate(scale_catch, source = new_catch) - endif - - if (SURFLAY.ne.20 .and. SURFLAY.ne.50) then - print *, "You must supply a valid SURFLAY value:" - print *, "(Ganymed-3 and earlier) SURFLAY=20.0 for Old Soil Params" - print *, "(Ganymed-4 and later ) SURFLAY=50.0 for New Soil Params" - call exit(2) - end if - print *, 'SURFLAY: ',SURFLAY - -! 1) soil moisture prognostics -! ---------------------------- - n =count((old_catch%catdef .gt. old_catch%cdcr1)) - - write(6,200) n,100*n/ntiles - -! Scale rxexc regardless of CDCR1, CDCR2 differences -! -------------------------------------------------- - scale_catch%rzexc = old_catch%rzexc * ( new_catch%vgwmax / & - old_catch%vgwmax ) - -! Scale catdef regardless of whether CDCR2 is larger or smaller in the new situation -! ---------------------------------------------------------------------------------- - where (old_catch%catdef .gt. old_catch%cdcr1) - - scale_catch%catdef = new_catch%cdcr1 + & - ( old_catch%catdef-old_catch%cdcr1 ) / & - ( old_catch%cdcr2 -old_catch%cdcr1 ) * & - ( new_catch%cdcr2 -new_catch%cdcr1 ) - end where - -! Scale catdef also for the case where catdef le cdcr1. -! ----------------------------------------------------- - where( (old_catch%catdef .le. old_catch%cdcr1)) - scale_catch%catdef = old_catch%catdef * (new_catch%cdcr1 / old_catch%cdcr1) - end where - -! Sanity Check (catch_calc_soil_moist() forces consistency betw. srfexc, rzexc, catdef) -! ------------ - print *, 'Performing Sanity Check ...' - allocate ( dzsf(ntiles) ) - allocate ( ar1( ntiles) ) - allocate ( ar2( ntiles) ) - allocate ( ar4( ntiles) ) - - dzsf = SURFLAY - - call catch_calc_soil_moist( ntiles, dzsf, & - scale_catch%vgwmax, scale_catch%cdcr1, scale_catch%cdcr2, & - scale_catch%psis, scale_catch%bee, scale_catch%poros, scale_catch%wpwet, & - scale_catch%ars1, scale_catch%ars2, scale_catch%ars3, & - scale_catch%ara1, scale_catch%ara2, scale_catch%ara3, scale_catch%ara4, & - scale_catch%arw1, scale_catch%arw2, scale_catch%arw3, scale_catch%arw4, & - scale_catch%bf1, scale_catch%bf2, & - scale_catch%srfexc, scale_catch%rzexc, scale_catch%catdef, & - ar1, ar2, ar4 ) - - n = count( scale_catch%catdef .ne. new_catch%catdef ) - write(6,300) n,100*n/ntiles - n = count( scale_catch%srfexc .ne. new_catch%srfexc ) - write(6,400) n,100*n/ntiles - n = count( scale_catch%rzexc .ne. new_catch%rzexc ) - write(6,400) n,100*n/ntiles - -! (2) Ground heat -! --------------- - - allocate (TP_IN (N_GT, Ntiles)) - allocate (GHT_IN (N_GT, Ntiles)) - allocate (GHT_OUT(N_GT, Ntiles)) - allocate (FICE (N_GT, NTILES)) - allocate (TP_OUT (N_GT, Ntiles)) - - GHT_IN (1,:) = old_catch%ghtcnt1 - GHT_IN (2,:) = old_catch%ghtcnt2 - GHT_IN (3,:) = old_catch%ghtcnt3 - GHT_IN (4,:) = old_catch%ghtcnt4 - GHT_IN (5,:) = old_catch%ghtcnt5 - GHT_IN (6,:) = old_catch%ghtcnt6 - - call catch_calc_tp ( NTILES, old_catch%poros, GHT_IN, tp_in, FICE) - GHT_OUT = GHT_IN - -! open (99,file='ght.diff', form = 'formatted') - - do n = 1, ntiles - do i = 1, N_GT - call catch_calc_ght(dzgt(i), new_catch%poros(n), tp_in(i,n), fice(i,n), GHT_IN(i,n)) -! if (i == N_GT) then -! if (GHT_IN(i,n) /= GHT_OUT(i,n)) write (99,*)n,old_catch%poros(n),new_catch%poros(n),ABS(GHT_IN(i,n)-GHT_OUT(i,n)) -! endif - end do - end do - - scale_catch%ghtcnt1 = GHT_IN (1,:) - scale_catch%ghtcnt2 = GHT_IN (2,:) - scale_catch%ghtcnt3 = GHT_IN (3,:) - scale_catch%ghtcnt4 = GHT_IN (4,:) - scale_catch%ghtcnt5 = GHT_IN (5,:) - scale_catch%ghtcnt6 = GHT_IN (6,:) - -! Deep soil temp sanity check -! --------------------------- - - call catch_calc_tp ( NTILES, new_catch%poros, GHT_IN, tp_out, FICE) - - print *, 'Percent tiles TP Layer 1 differ : ', 100.* count(ABS(tp_out(1,:) - tp_in(1,:)) > 1.e-5) /float (Ntiles) - print *, 'Percent tiles TP Layer 2 differ : ', 100.* count(ABS(tp_out(2,:) - tp_in(2,:)) > 1.e-5) /float (Ntiles) - print *, 'Percent tiles TP Layer 3 differ : ', 100.* count(ABS(tp_out(3,:) - tp_in(3,:)) > 1.e-5) /float (Ntiles) - print *, 'Percent tiles TP Layer 4 differ : ', 100.* count(ABS(tp_out(4,:) - tp_in(4,:)) > 1.e-5) /float (Ntiles) - print *, 'Percent tiles TP Layer 5 differ : ', 100.* count(ABS(tp_out(5,:) - tp_in(5,:)) > 1.e-5) /float (Ntiles) - print *, 'Percent tiles TP Layer 6 differ : ', 100.* count(ABS(tp_out(6,:) - tp_in(6,:)) > 1.e-5) /float (Ntiles) - - -! SNOW scaling -! ------------ - - if(wemin_out /= wemin_in) then - - allocate (swe_in (Ntiles)) - allocate (depth_in (Ntiles)) - allocate (depth_out (Ntiles)) - allocate (areasc_in (Ntiles)) - allocate (areasc_out (Ntiles)) - - swe_in = new_catch%wesnn1 + new_catch%wesnn2 + new_catch%wesnn3 - depth_in = new_catch%sndzn1 + new_catch%sndzn2 + new_catch%sndzn3 - areasc_in = min(swe_in/wemin_in, 1.) - areasc_out= min(swe_in/wemin_out,1.) - - where (swe_in .gt. 0.) - where (areasc_in .lt. 1. .or. areasc_out .lt. 1.) - ! density_in= swe_in/(areasc_in * depth_in + 1.e-20) - ! depth_out = swe_in/(areasc_out*density_in) - depth_out = areasc_in * depth_in/(areasc_out + 1.e-20) - scale_catch%sndzn1 = depth_out/3. - scale_catch%sndzn2 = depth_out/3. - scale_catch%sndzn3 = depth_out/3. - endwhere - endwhere - - print *, 'Snow scaling summary' - print *, '....................' - print *, 'Percent tiles SNDZ scaled : ', 100.* count (scale_catch%sndzn3 .ne. old_catch%sndzn3) /float (count (scale_catch%sndzn3 > 0.)) - - endif - - ! PEATCLSM - ensure low CATDEF on peat tiles where "old" restart is not also peat - ! ------------------------------------------------------------------------------- - - where ( (old_catch%poros < PEATCLSM_POROS_THRESHOLD) .and. (scale_catch%poros >= PEATCLSM_POROS_THRESHOLD) ) - scale_catch%catdef = 25. - scale_catch%rzexc = 0. - scale_catch%srfexc = 0. - end where - -! Write Scaled Catch -! ------------------ - if (filetype ==0) then - call formatter%open(new_fname, pFIO_READ, __RC__) - meta = formatter%read(__RC__) - call formatter%close() - call scale_catch%write_nc4(scale_fname, meta, cnclm, __RC__) - else - call scale_catch%write_bin(scale_fname, __RC__) - end if - -100 format(1x,'Total Tiles: ',i10) -200 format(1x,'Scaled Tiles: ',i10,2x,'(',i2.2,'%)') -300 format(1x,'CatDef Tiles: ',i10,2x,'(',i2.2,'%)') -400 format(1x,'SrfExc Tiles: ',i10,2x,'(',i2.2,'%)') -500 format(1x,' Rzexc Tiles: ',i10,2x,'(',i2.2,'%)') - - end program diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/getids.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/getids.F90 index be7ec9295..7ceeb2434 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/getids.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/getids.F90 @@ -554,7 +554,7 @@ subroutine ReadTileFile_RealLatLon (InCNTileFile, ntiles, xlon, xlat,mask) implicit none character(*), intent (in) :: InCNTileFile integer , intent (inout) :: ntiles - real, pointer, dimension (:) :: xlon, xlat + real, dimension (:), intent(out) :: xlon, xlat integer, optional, intent(IN) :: mask integer :: n,icnt,ityp, nt, umask, i, header real :: xval,yval, pf @@ -605,8 +605,6 @@ subroutine ReadTileFile_RealLatLon (InCNTileFile, ntiles, xlon, xlat,mask) close(11) Ntiles = icnt - if(.not.associated (xlon)) allocate(xlon(Ntiles)) - if(.not.associated (xlat)) allocate(xlat(Ntiles)) xlon = ln1(:Ntiles) xlat = lt1(:Ntiles) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_CatchmentRestarts.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_CatchmentRestarts.F90 new file mode 100644 index 000000000..dda873422 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_CatchmentRestarts.F90 @@ -0,0 +1,126 @@ +#define I_AM_MAIN +#include "MAPL_Generic.h" + +PROGRAM mk_CatchmentsRestarts + + use mpi + use MAPL + use CatchmentRstMod + use CatchmentCNRstMod + + implicit none + + + character(len=:), allocatable :: out_bcsdir, out_dir, in_tilefile, out_tilefile, YYYYMMDDHHMM + character(len=:), allocatable :: model, in_rstfile, out_rstfile + character(len=:), allocatable :: out_File + real :: surflay, wemin_in, wemin_out + integer :: rc, status + integer :: myid, numprocs, mpierr + class (CatchmentRst), allocatable :: catch + type (scale_var) :: old + + call MPI_INIT(mpierr) + call MPI_COMM_RANK( MPI_COMM_WORLD, myid, mpierr ) + call MPI_COMM_SIZE( MPI_COMM_WORLD, numprocs, mpierr ) + + call process_cmd() + + if (index(model, 'catchcn') /=0 ) then + catch = CatchmentCNRst(in_rstfile, model, yyyymmddhhmm, __RC__) + else + catch = CatchmentRst(in_rstfile, yyyymmddhhmm, __RC__) + endif + + call catch%re_tile(in_tilefile, out_bcsdir, out_tilefile, surflay, __RC__) + + call catch%set_scale_var(old) + + call catch%add_bcs_to_rst(surflay, out_bcsdir, rc) + + call catch%re_scale(surflay, wemin_in, wemin_out, old, __RC__) + + call catch%write_nc4(out_file, __RC__) + + call MPI_FINALIZE(mpierr) + + contains + ! process commands + subroutine process_cmd() + integer :: nxt + character(len=256) :: arg + nxt = 1 + call getarg(nxt,arg) + + do while(trim(arg) /= '') + select case (trim(arg)) + case ('-h') + call print_usage() + call exit(0) + case ('-bcs_out') + call getarg(nxt,arg) + out_bcsdir = trim(arg) + case ('-time') + call getarg(nxt,arg) + YYYYMMDDHHMM = trim(arg) + case ('-dir_out') + call getarg(nxt,arg) + out_dir = trim(arg) + case ('-model') + call getarg(nxt,arg) + model = trim(arg) + case ('-surflay') + call getarg(nxt,arg) + read(arg,*) surflay + case ('-tile_in') + call getarg(nxt,arg) + in_tilefile = trim(arg) + case ('-tile_out') + call getarg(nxt,arg) + out_tilefile = trim(arg) + case ('-rst_in') + call getarg(nxt,arg) + in_rstfile = trim(arg) + case ('-rst_out') + call getarg(nxt,arg) + out_rstfile = trim(arg) + case ('-wemin_in') + call getarg(nxt,arg) + read(arg,*) wemin_in + case ('-wemin_out') + call getarg(nxt,arg) + read(arg,*) wemin_out + case default + call print_usage() + print*, "wong command line" + call exit(1) + end select + nxt = nxt + 1 + call getarg(nxt,arg) + end do + if (index(model, 'catchcn') /=0 ) then + if((INDEX(out_bcsdir, 'NL') == 0).AND.(INDEX(out_bcsdir, 'OutData') == 0)) then + print *,'Land BCs in : ',trim(out_bcsdir) + print *,'do not support ',trim (model) + stop + endif + endif + out_file = out_dir //'/'//out_rstfile + + end subroutine + + subroutine print_usage() + print *,' ' + print *,'-bcs_out : BC directory for output restart file' + print *,'-time : time for restart, format (yyyymmddhhmm)' + print *,'-dir_out : directory for output restasrt file' + print *,'-model : model ( catch, catchcnclm40, catchcnclm45)' + print *,'-surflay : surflay value' + print *,'-wemin_in : wemin for input restart' + print *,'-wemin_out : wemin for output restart' + print *,'-tile_in : tile_file for input restart' + print *,'-tile_out : tile_file for output restart, if none, it will search out_bcs' + print *,'-rst_in : input restart file name' + print *,'-rst_out : output restart file name' + end subroutine +end program From 0bfdda39af342425ee618d0e99ae8e7ba63f385b Mon Sep 17 00:00:00 2001 From: Weiyuan Jiang Date: Tue, 3 May 2022 17:24:33 -0400 Subject: [PATCH 05/17] First running version --- .../Utils/mk_restarts/CMakeLists.txt | 1 - .../Utils/mk_restarts/CatchmentCNRst.F90 | 133 +++++++++++------- .../Utils/mk_restarts/CatchmentRst.F90 | 91 ++++++++---- .../mk_restarts/mk_CatchmentRestarts.F90 | 63 +++++---- 4 files changed, 176 insertions(+), 112 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CMakeLists.txt index 69facd85a..60cc137d3 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CMakeLists.txt +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CMakeLists.txt @@ -8,7 +8,6 @@ set(srcs set (exe_srcs Scale_Catch.F90 - ScaleCatch.F90 Scale_CatchCN.F90 cv_SaltRestart.F90 SaltIntSplitter.F90 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentCNRst.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentCNRst.F90 index df7b57cd6..3a7c18cc2 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentCNRst.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentCNRst.F90 @@ -91,7 +91,7 @@ function CatchmentCNRst_create(filename, cnclm, time, rc) result (catch) integer :: status type(Netcdf4_fileformatter) :: formatter integer :: filetype, ntiles, unit - integer :: j, dim1,dim2 + integer :: j, dim1,dim2, myid, mpierr type(Variable), pointer :: myVariable character(len=:), pointer :: dname type(FileMetadata) :: meta @@ -101,13 +101,15 @@ function CatchmentCNRst_create(filename, cnclm, time, rc) result (catch) if (filetype /= 0) then _ASSERT( .false., "CatchmentCN only support nc4 file restart") endif - + + call MPI_COMM_RANK( MPI_COMM_WORLD, myid, mpierr ) + catch%isCLM45 = .false. call formatter%open(filename, pFIO_READ, __RC__) - meta = formatter%read(__RC__) - ntiles = catch%meta%get_dimension('tile', __RC__) + meta = formatter%read(__RC__) + ntiles = meta%get_dimension('tile', __RC__) catch%ntiles = ntiles - catch%meta = meta + catch%meta = meta catch%time = time if (index(cnclm, '40') /=0) then catch%VAR_COL = VAR_COL_CLM40 @@ -119,53 +121,57 @@ function CatchmentCNRst_create(filename, cnclm, time, rc) result (catch) catch%isCLM45 = .true. endif - call catch%allocate_cn(__RC__) - call catch%read_shared_nc4(formatter, __RC__) - - myVariable => meta%get_variable("ITY") - dname => myVariable%get_ith_dimension(2) - dim1 = meta%get_dimension(dname) - do j=1,dim1 - call MAPL_VarRead(formatter,"ITY",catch%cnity(:,j),offset1=j, __RC__) - call MAPL_VarRead(formatter,"FVG",catch%fvg(:,j),offset1=j, __RC__) - enddo + if (myid == 0) then + call catch%allocate_cn(__RC__) + call catch%read_shared_nc4(formatter, __RC__) - call MAPL_VarRead(formatter,"TG",catch%tg, __RC__) - call MAPL_VarRead(formatter,"TILE_ID",catch%TILE_ID, __RC__) - call MAPL_VarRead(formatter,"NDEP",catch%ndep, __RC__) - call MAPL_VarRead(formatter,"CLI_T2M",catch%t2, __RC__) - call MAPL_VarRead(formatter,"BGALBVR",catch%BGALBVR, __RC__) - call MAPL_VarRead(formatter,"BGALBVF",catch%BGALBVF, __RC__) - call MAPL_VarRead(formatter,"BGALBNR",catch%BGALBNR, __RC__) - call MAPL_VarRead(formatter,"BGALBNF",catch%BGALBNF, __RC__) + myVariable => meta%get_variable("ITY") + dname => myVariable%get_ith_dimension(2) + dim1 = meta%get_dimension(dname) + do j=1,dim1 + call MAPL_VarRead(formatter,"ITY",catch%cnity(:,j),offset1=j, __RC__) + call MAPL_VarRead(formatter,"FVG",catch%fvg(:,j),offset1=j, __RC__) + enddo - myVariable => meta%get_variable("CNCOL") - dname => myVariable%get_ith_dimension(2) - dim1 = meta%get_dimension(dname) - if( catch%isCLM45) then - call MAPL_VarRead(formatter,"ABM", catch%ABM, __RC__) - call MAPL_VarRead(formatter,"FIELDCAP",catch%FIELDCAP, __RC__) - call MAPL_VarRead(formatter,"HDM", catch%HDM , __RC__) - call MAPL_VarRead(formatter,"GDP", catch%GDP , __RC__) - call MAPL_VarRead(formatter,"PEATF", catch%PEATF , __RC__) + call MAPL_VarRead(formatter,"TG",catch%tg, __RC__) + call MAPL_VarRead(formatter,"TILE_ID",catch%TILE_ID, __RC__) + call MAPL_VarRead(formatter,"NDEP",catch%ndep, __RC__) + call MAPL_VarRead(formatter,"CLI_T2M",catch%t2, __RC__) + call MAPL_VarRead(formatter,"BGALBVR",catch%BGALBVR, __RC__) + call MAPL_VarRead(formatter,"BGALBVF",catch%BGALBVF, __RC__) + call MAPL_VarRead(formatter,"BGALBNR",catch%BGALBNR, __RC__) + call MAPL_VarRead(formatter,"BGALBNF",catch%BGALBNF, __RC__) + + myVariable => meta%get_variable("CNCOL") + dname => myVariable%get_ith_dimension(2) + dim1 = meta%get_dimension(dname) + if( catch%isCLM45) then + call MAPL_VarRead(formatter,"ABM", catch%ABM, __RC__) + call MAPL_VarRead(formatter,"FIELDCAP",catch%FIELDCAP, __RC__) + call MAPL_VarRead(formatter,"HDM", catch%HDM , __RC__) + call MAPL_VarRead(formatter,"GDP", catch%GDP , __RC__) + call MAPL_VarRead(formatter,"PEATF", catch%PEATF , __RC__) + endif + do j=1,dim1 + call MAPL_VarRead(formatter,"CNCOL",catch%CNCOL(:,j),offset1=j, __RC__) + enddo + ! The following three lines were added as a bug fix by smahanam on 5 Oct 2020 + ! (to be merged into the "develop" branch in late 2020): + ! The length of the 2nd dim of CNPFT differs from that of CNCOL. Prior to this fix, + ! CNPFT was not read in its entirety and some elements remained uninitialized (or zero), + ! resulting in bad values in the "regridded" (re-tiled) restart file. + ! This impacted re-tiled restarts for both CNCLM40 and CLCLM45. + ! - reichle, 23 Nov 2020 + myVariable => meta%get_variable("CNPFT") + dname => myVariable%get_ith_dimension(2) + dim1 = meta%get_dimension(dname) + do j=1,dim1 + call MAPL_VarRead(formatter,"CNPFT",catch%CNPFT(:,j),offset1=j, __RC__) + enddo endif - do j=1,dim1 - call MAPL_VarRead(formatter,"CNCOL",catch%CNCOL(:,j),offset1=j, __RC__) - enddo - ! The following three lines were added as a bug fix by smahanam on 5 Oct 2020 - ! (to be merged into the "develop" branch in late 2020): - ! The length of the 2nd dim of CNPFT differs from that of CNCOL. Prior to this fix, - ! CNPFT was not read in its entirety and some elements remained uninitialized (or zero), - ! resulting in bad values in the "regridded" (re-tiled) restart file. - ! This impacted re-tiled restarts for both CNCLM40 and CLCLM45. - ! - reichle, 23 Nov 2020 - myVariable => meta%get_variable("CNPFT") - dname => myVariable%get_ith_dimension(2) - dim1 = meta%get_dimension(dname) - do j=1,dim1 - call MAPL_VarRead(formatter,"CNPFT",catch%CNPFT(:,j),offset1=j, __RC__) - enddo + call formatter%close() + if (present(rc)) rc =0 end function CatchmentCNRst_Create @@ -175,7 +181,7 @@ function CatchmentCNRst_empty(meta, cnclm, time, rc) result (catch) character(*), intent(in) :: cnclm character(*), intent(in) :: time integer, optional, intent(out) :: rc - integer :: status + integer :: status, myid, mpierr character(len=256) :: Iam = "CatchmentCNRst_empty" catch%isCLM45 = .false. @@ -192,8 +198,9 @@ function CatchmentCNRst_empty(meta, cnclm, time, rc) result (catch) catch%isCLM45 = .true. endif - call catch%allocate_cn(__RC__) - + call MPI_COMM_RANK( MPI_COMM_WORLD, myid, mpierr ) + if (myid ==0) call catch%allocate_cn(__RC__) + if(present(rc)) rc = 0 end function CatchmentCNRst_empty subroutine write_nc4(this, filename, rc) @@ -625,7 +632,7 @@ subroutine re_tile(this, InTileFile, OutBcsDir, OutTileFile, surflay, rc) real, allocatable :: var_off_col (:,:,:), var_off_pft (:,:,:,:) integer :: status, in_ntiles, out_ntiles, numprocs logical :: root_proc - integer :: mpierr, n, i, k, req, st, myid, L, iv, nv,nz, var_col, var_pft + integer :: mpierr, n, i, k, req, st, ed, myid, L, iv, nv,nz, var_col, var_pft character(*), parameter :: Iam = "CatchmentCN::Re_tile" @@ -667,8 +674,13 @@ subroutine re_tile(this, InTileFile, OutBcsDir, OutTileFile, surflay, rc) allocate (CLMC_st2(nt_local (myid + 1))) allocate (ityp_offl (in_ntiles,nveg)) allocate (fveg_offl (in_ntiles,nveg)) + allocate (tid_offl(in_ntiles)) allocate (id_loc_cn (nt_local (myid + 1),nveg)) + do n = 1, in_ntiles + tid_offl(n) = n + enddo + ! copy out the old fvg and cnity if (root_proc) then @@ -684,7 +696,7 @@ subroutine re_tile(this, InTileFile, OutBcsDir, OutTileFile, surflay, rc) call compute_dayx ( & out_NTILES, AGCM_YY, AGCM_MM, AGCM_DD, AGCM_HR, & - LATG, DAYX) + this%LATG, DAYX) ityp_tmp = this%cnity fveg_tmp = this%fvg @@ -707,6 +719,7 @@ subroutine re_tile(this, InTileFile, OutBcsDir, OutTileFile, surflay, rc) if((ityp_offl(N,4) == 0).and.(ityp_offl(N,3) /= 0)) ityp_offl(N,4) = ityp_offl(N,3) end do endif + call MPI_BCAST(ityp_offl,size(ityp_offl),MPI_REAL ,0,MPI_COMM_WORLD,mpierr) call MPI_BCAST(fveg_offl,size(fveg_offl),MPI_REAL ,0,MPI_COMM_WORLD,mpierr) @@ -724,6 +737,17 @@ subroutine re_tile(this, InTileFile, OutBcsDir, OutTileFile, surflay, rc) call MPI_send(this%fvg(st,3),l, MPI_REAL, i, i+6, MPI_COMM_WORLD, mpierr) call MPI_send(this%fvg(st,4),l, MPI_REAL, i, i+7, MPI_COMM_WORLD, mpierr) enddo + st = low_ind(1) + l = nt_local(1) + ed = st + l -1 + CLMC_pt1 = this%cnity(st:ed,1) + CLMC_pt2 = this%cnity(st:ed,2) + CLMC_st1 = this%cnity(st:ed,3) + CLMC_st2 = this%cnity(st:ed,4) + CLMC_pf1 = this%fvg(st:ed,1) + CLMC_pf2 = this%fvg(st:ed,2) + CLMC_sf1 = this%fvg(st:ed,3) + CLMC_sf2 = this%fvg(st:ed,4) else call MPI_RECV(CLMC_pt1,nt_local(myid+1) , MPI_REAL, 0, myid, MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) call MPI_RECV(CLMC_pt2,nt_local(myid+1) , MPI_REAL, 0, myid+1, MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) @@ -735,7 +759,8 @@ subroutine re_tile(this, InTileFile, OutBcsDir, OutTileFile, surflay, rc) call MPI_RECV(CLMC_sf2,nt_local(myid+1) , MPI_REAL, 0, myid+7, MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) endif - call GetIds(lonc,latc,lonn,latt,id_loc_cn, tid_offl, & + + call GetIds(this%lonc,this%latc,this%lonn,this%latt,id_loc_cn, tid_offl, & CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2, CLMC_pt1, CLMC_pt2,CLMC_st1,CLMC_st2, & fveg_offl, ityp_offl) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentRst.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentRst.F90 index 0086d7bb1..f09698e36 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentRst.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentRst.F90 @@ -96,6 +96,10 @@ module CatchmentRstMod real, allocatable :: cq(:,:) real, allocatable :: fr(:,:) real, allocatable :: ww(:,:) + + ! intermediate + real, allocatable, dimension(:) :: lonc,latc,lonn,latt, long, latg + contains procedure :: read_GEOSldas_rst_bin procedure :: write_nc4 @@ -125,20 +129,24 @@ function CatchmentRst_create(filename, time, rc) result (catch) type(Netcdf4_fileformatter) :: formatter integer :: filetype, ntiles, unit type(FileMetadata) :: meta - integer :: bpos, epos, n + integer :: bpos, epos, n, myid, mpierr + call MPI_COMM_RANK( MPI_COMM_WORLD, myid, mpierr ) catch%time = time call MAPL_NCIOGetFileType(filename, filetype, __RC__) if(filetype == 0) then ! nc4 format call formatter%open(filename, pFIO_READ, __RC__) + meta = formatter%read(__RC__) ntiles = meta%get_dimension('tile', __RC__) + catch%meta = meta catch%ntiles = ntiles - catch%meta = formatter%read(__RC__) - call catch%allocate_catch() - call catch%read_shared_nc4(formatter, __RC__) - call MAPL_VarRead(formatter,"OLD_ITY",catch%ity, __RC__) + if (myid ==0) then + call catch%allocate_catch() + call catch%read_shared_nc4(formatter, __RC__) + call MAPL_VarRead(formatter,"OLD_ITY",catch%ity, __RC__) + endif call formatter%close() else !if ( .not. present(time)) then @@ -153,8 +161,10 @@ function CatchmentRst_create(filename, time, rc) result (catch) ntiles = (epos-bpos)/4-2 ! record size (in 4 byte words; catch%ntiles = ntiles catch%meta = create_meta(ntiles, time) - call catch%allocate_catch() - call catch%read_GEOSldas_rst_bin(filename, __RC__) + if (myid ==0) then + call catch%allocate_catch() + call catch%read_GEOSldas_rst_bin(filename, __RC__) + endif endif _RETURN(_SUCCESS) end function CatchmentRst_Create @@ -165,16 +175,18 @@ function CatchmentRst_empty(meta, time, rc) result (catch) type(FileMetadata), intent(in) :: meta integer, optional, intent(out) :: rc - integer :: status + integer :: status, myid, mpierr character(len=256) :: Iam = "CatchmentRst_create" type(Netcdf4_fileformatter) :: formatter - + call MPI_COMM_RANK( MPI_COMM_WORLD, myid, mpierr ) ! nc4 format catch%ntiles = meta%get_dimension('tile', __RC__) catch%meta = meta catch%time = time - call catch%allocate_catch() + if (myid ==0) then + call catch%allocate_catch() + endif _RETURN(_SUCCESS) end function CatchmentRst_empty @@ -295,7 +307,9 @@ subroutine read_shared_nc4(this, formatter, rc) call MAPL_VarRead(formatter,"GHTCNT4",this%ghtcnt4, __RC__) call MAPL_VarRead(formatter,"GHTCNT5",this%ghtcnt5, __RC__) call MAPL_VarRead(formatter,"GHTCNT6",this%ghtcnt6, __RC__) - call MAPL_VarRead(formatter,"TSURF",this%tsurf, __RC__) + if (this%meta%has_variable('TSURF')) then + call MAPL_VarRead(formatter,"TSURF",this%tsurf, __RC__) + endif call MAPL_VarRead(formatter,"WESNN1",this%wesnn1, __RC__) call MAPL_VarRead(formatter,"WESNN2",this%wesnn2, __RC__) call MAPL_VarRead(formatter,"WESNN3",this%wesnn3, __RC__) @@ -305,13 +319,22 @@ subroutine read_shared_nc4(this, formatter, rc) call MAPL_VarRead(formatter,"SNDZN1",this%sndzn1, __RC__) call MAPL_VarRead(formatter,"SNDZN2",this%sndzn2, __RC__) call MAPL_VarRead(formatter,"SNDZN3",this%sndzn3, __RC__) - call MAPL_VarRead(formatter,"CH",this%ch, __RC__) - call MAPL_VarRead(formatter,"CM",this%cm, __RC__) - call MAPL_VarRead(formatter,"CQ",this%cq, __RC__) - call MAPL_VarRead(formatter,"FR",this%fr, __RC__) - call MAPL_VarRead(formatter,"WW",this%ww, __RC__) - - _RETURN(_SUCCESS) + if (this%meta%has_variable('CH')) then + call MAPL_VarRead(formatter,"CH",this%ch, __RC__) + endif + if (this%meta%has_variable('CM')) then + call MAPL_VarRead(formatter,"CM",this%cm, __RC__) + endif + if (this%meta%has_variable('CQ')) then + call MAPL_VarRead(formatter,"CQ",this%cq, __RC__) + endif + if (this%meta%has_variable('FR')) then + call MAPL_VarRead(formatter,"FR",this%fr, __RC__) + endif + if (this%meta%has_variable('WW')) then + call MAPL_VarRead(formatter,"WW",this%ww, __RC__) + endif + _RETURN(_SUCCESS) end subroutine subroutine write_nc4 (this, filename, rc) @@ -486,8 +509,8 @@ subroutine add_bcs_to_rst(this, surflay, DataDir, rc) allocate (DP2BR(ntiles), ity(ntiles) ) - inquire(file = trim(DataDir)//'/catch_params.nc4', exist=file_exists) - inquire(file = trim(DataDir)//"CLM_veg_typs_fracs",exist=NewLand ) + inquire(file = trim(DataDir)//'/clsm/catch_params.nc4', exist=file_exists) + inquire(file = trim(DataDir)//"/clsm/CLM_veg_typs_fracs",exist=NewLand ) if (size(this%ara1) /= this%ntiles ) then ! it is just re-allocate @@ -523,7 +546,7 @@ subroutine add_bcs_to_rst(this, surflay, DataDir, rc) endif if(file_exists) then - call CatchFmt%Open(trim(DataDir)//'/catch_params.nc4', pFIO_READ, __RC__) + call CatchFmt%Open(trim(DataDir)//'/clsm/catch_params.nc4', pFIO_READ, __RC__) call MAPL_VarRead ( CatchFmt ,'OLD_ITY', this%ITY, __RC__) call MAPL_VarRead ( CatchFmt ,'ARA1', this%ARA1, __RC__) call MAPL_VarRead ( CatchFmt ,'ARA2', this%ARA2, __RC__) @@ -563,12 +586,12 @@ subroutine add_bcs_to_rst(this, surflay, DataDir, rc) call MAPL_VarRead ( CatchFmt ,'POROS', this%POROS, __RC__) call CatchFmt%close() else - open(unit=21, file=trim(DataDir)//'mosaic_veg_typs_fracs',form='formatted') - open(unit=22, file=trim(DataDir)//'bf.dat' ,form='formatted') - open(unit=23, file=trim(DataDir)//'soil_param.dat' ,form='formatted') - open(unit=24, file=trim(DataDir)//'ar.new' ,form='formatted') - open(unit=25, file=trim(DataDir)//'ts.dat' ,form='formatted') - open(unit=26, file=trim(DataDir)//'tau_param.dat' ,form='formatted') + open(unit=21, file=trim(DataDir)//'/clsm/mosaic_veg_typs_fracs',form='formatted') + open(unit=22, file=trim(DataDir)//'/clsm//bf.dat' ,form='formatted') + open(unit=23, file=trim(DataDir)//'/clsm/soil_param.dat' ,form='formatted') + open(unit=24, file=trim(DataDir)//'/clsm/ar.new' ,form='formatted') + open(unit=25, file=trim(DataDir)//'/clsm/ts.dat' ,form='formatted') + open(unit=26, file=trim(DataDir)//'/clsm/tau_param.dat' ,form='formatted') do n=1,ntiles ! W.J notes: CanopH is not used. If CLM_veg_typs_fracs exists, the read some dummy ???? Ask Sarith @@ -662,7 +685,7 @@ type(FileMetadata) function create_meta(ntiles, t, rc) result(meta) fields(27,:) = [character(len=64)::"GHTCNT5" , "soil_heat_content_layer_5" , "J m-2"] fields(28,:) = [character(len=64)::"GHTCNT6" , "soil_heat_content_layer_6" , "J m-2"] fields(29,:) = [character(len=64)::"GNU" , "vertical_transmissivity" , "m-1"] - fields(20,:) = [character(len=64)::"HTSNNN1" , "heat_content_snow_layer_1" , "J m-2"] + fields(30,:) = [character(len=64)::"HTSNNN1" , "heat_content_snow_layer_1" , "J m-2"] fields(31,:) = [character(len=64)::"HTSNNN2" , "heat_content_snow_layer_2" , "J m-2"] fields(32,:) = [character(len=64)::"HTSNNN3" , "heat_content_snow_layer_3" , "J m-2"] fields(33,:) = [character(len=64)::"OLD_ITY" , "Placeholder. Used to be vegetation_type." , "1"] @@ -696,7 +719,7 @@ type(FileMetadata) function create_meta(ntiles, t, rc) result(meta) call meta%add_dimension('subtile', 4) call meta%add_dimension('time',1) - do n = 1, 51 + do n = 1, 58 if (n >=52) then var = Variable(type=pFIO_REAL32, dimensions='tile,subtile') else @@ -707,7 +730,7 @@ type(FileMetadata) function create_meta(ntiles, t, rc) result(meta) call meta%add_variable(trim(fields(n,1)), var) enddo var = Variable(type=pFIO_REAL32, dimensions='time') - s = "minutes since "//t(1:4)//"-"//t(5:6)//"-"//t(7:8)//" "//t(9:10)//":"//t(11:12)//":00" + s = "minutes since "//t(1:4)//"-"//t(5:6)//"-"//t(7:8)//" "//t(9:10)//":00:00" call var%add_attribute('units', s) call meta%add_variable('time', var) _RETURN(_SUCCESS) @@ -731,7 +754,7 @@ subroutine re_tile(this, InTileFile, OutBcsDir, OutTileFile, surflay, rc) type(FileMetadata) :: meta character(*), parameter :: Iam = "Catchment::Re_tile" - open (10,file =trim(OutBcsDir)//"clsm/catchment.def",status='old',form='formatted') + open (10,file =trim(OutBcsDir)//"/clsm/catchment.def",status='old',form='formatted') read (10,*) out_ntiles close (10, status = 'keep') @@ -782,6 +805,8 @@ subroutine re_tile(this, InTileFile, OutBcsDir, OutTileFile, surflay, rc) allocate (latg (out_ntiles)) call ReadTileFile_RealLatLon ( OutTileFile, n, long, latg) _ASSERT( n == out_ntiles, "Out tile number should match") + this%long = long + this%latg = latg call ReadTileFile_RealLatLon ( InTileFile, n, lonc, latc) _ASSERT( n == in_ntiles, "In tile number should match") endif @@ -821,6 +846,10 @@ subroutine re_tile(this, InTileFile, OutBcsDir, OutTileFile, surflay, rc) ! -------------------------------------------------------------------------------- ! id_glb for hydrologic variable + this%lonc = lonc + this%latc = latc + this%lonn = lonn + this%latt = latt call GetIds(lonc, latc, lonn, latt, id_loc, tid_offl) if(root_proc) allocate (id_glb (out_ntiles)) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_CatchmentRestarts.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_CatchmentRestarts.F90 index dda873422..44a4cd913 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_CatchmentRestarts.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_CatchmentRestarts.F90 @@ -34,13 +34,12 @@ PROGRAM mk_CatchmentsRestarts call catch%re_tile(in_tilefile, out_bcsdir, out_tilefile, surflay, __RC__) - call catch%set_scale_var(old) - - call catch%add_bcs_to_rst(surflay, out_bcsdir, rc) - - call catch%re_scale(surflay, wemin_in, wemin_out, old, __RC__) - - call catch%write_nc4(out_file, __RC__) + if (myid == 0) then + call catch%set_scale_var(old) + call catch%add_bcs_to_rst(surflay, out_bcsdir, rc) + call catch%re_scale(surflay, wemin_in, wemin_out, old, __RC__) + call catch%write_nc4(out_file, __RC__) + endif call MPI_FINALIZE(mpierr) @@ -57,40 +56,52 @@ subroutine process_cmd() case ('-h') call print_usage() call exit(0) - case ('-bcs_out') + case ('-out_bcs') + nxt = nxt + 1 call getarg(nxt,arg) out_bcsdir = trim(arg) case ('-time') + nxt = nxt + 1 call getarg(nxt,arg) YYYYMMDDHHMM = trim(arg) - case ('-dir_out') + case ('-out_dir') + nxt = nxt + 1 call getarg(nxt,arg) out_dir = trim(arg) case ('-model') + nxt = nxt + 1 call getarg(nxt,arg) model = trim(arg) case ('-surflay') + nxt = nxt + 1 call getarg(nxt,arg) read(arg,*) surflay - case ('-tile_in') + case ('-in_tilefile') + nxt = nxt + 1 call getarg(nxt,arg) in_tilefile = trim(arg) - case ('-tile_out') + case ('-out_tilefile') + nxt = nxt + 1 call getarg(nxt,arg) out_tilefile = trim(arg) - case ('-rst_in') + case ('-in_rst') + nxt = nxt + 1 call getarg(nxt,arg) in_rstfile = trim(arg) - case ('-rst_out') + case ('-out_rst') + nxt = nxt + 1 call getarg(nxt,arg) out_rstfile = trim(arg) - case ('-wemin_in') + case ('-in_wemin') + nxt = nxt + 1 call getarg(nxt,arg) read(arg,*) wemin_in - case ('-wemin_out') + case ('-out_wemin') + nxt = nxt + 1 call getarg(nxt,arg) read(arg,*) wemin_out case default + print*, trim(arg) call print_usage() print*, "wong command line" call exit(1) @@ -111,16 +122,16 @@ subroutine process_cmd() subroutine print_usage() print *,' ' - print *,'-bcs_out : BC directory for output restart file' - print *,'-time : time for restart, format (yyyymmddhhmm)' - print *,'-dir_out : directory for output restasrt file' - print *,'-model : model ( catch, catchcnclm40, catchcnclm45)' - print *,'-surflay : surflay value' - print *,'-wemin_in : wemin for input restart' - print *,'-wemin_out : wemin for output restart' - print *,'-tile_in : tile_file for input restart' - print *,'-tile_out : tile_file for output restart, if none, it will search out_bcs' - print *,'-rst_in : input restart file name' - print *,'-rst_out : output restart file name' + print *,'-out_bcs : BC directory for output restart file' + print *,'-time : time for restart, format (yyyymmddhhmm)' + print *,'-out_dir : directory for output restasrt file' + print *,'-model : model ( catch, catchcnclm40, catchcnclm45)' + print *,'-surflay : surflay value' + print *,'-in_wemin : wemin for input restart' + print *,'-out_wemin : wemin for output restart' + print *,'-in_tilefile : tile_file for input restart' + print *,'-out_tilefile : tile_file for output restart, if none, it will search out_bcs' + print *,'-in_rst : input restart file name WITH path' + print *,'-out_rst : output restart file name WITHOUT path' end subroutine end program From 28ccebd62eafe408fd5d8d6badef8d2f4ec632f0 Mon Sep 17 00:00:00 2001 From: Weiyuan Jiang Date: Thu, 5 May 2022 10:44:21 -0400 Subject: [PATCH 06/17] first zero-diff for at least one case --- .../Utils/mk_restarts/CatchmentRst.F90 | 19 +++++++++++-------- 1 file changed, 11 insertions(+), 8 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentRst.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentRst.F90 index f09698e36..d210fa285 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentRst.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentRst.F90 @@ -939,6 +939,9 @@ subroutine re_tile(this, InTileFile, OutBcsDir, OutTileFile, surflay, rc) var_out = this%arw2(id_glb(:)) this%arw2 = var_out + var_out = this%arw3(id_glb(:)) + this%arw3 = var_out + var_out = this%arw4(id_glb(:)) this%arw4 = var_out @@ -962,17 +965,17 @@ subroutine re_tile(this, InTileFile, OutBcsDir, OutTileFile, surflay, rc) this%ity = [(k*1., k=1, out_ntiles)] + tmp2d = this%tc + deallocate(this%tc) + allocate(this%tc(out_ntiles, 4)) do k = 1, 3 - tmp2d = this%tc - deallocate(this%tc) - allocate(this%tc(out_ntiles, 4)) this%tc(:,k) = tmp2d(id_glb(:),k) enddo + tmp2d = this%qc + deallocate(this%qc) + allocate(this%qc(out_ntiles, 4)) do k = 1, 3 - tmp2d = this%qc - deallocate(this%qc) - allocate(this%qc(out_ntiles, 4)) this%qc(:,k) = tmp2d(id_glb(:),k) enddo @@ -996,6 +999,7 @@ subroutine re_tile(this, InTileFile, OutBcsDir, OutTileFile, surflay, rc) var_out = this%GHTCNT3(id_glb(:)) this%GHTCNT3 = var_out + var_out = this%GHTCNT4(id_glb(:)) this%GHTCNT4 = var_out @@ -1094,8 +1098,7 @@ subroutine re_scale(this, surflay, wemin_in, wemin_out, old, rc) ! ------------ print *, 'Performing Sanity Check ...' - dzsf = SURFLAY - allocate ( dzsf(ntiles) ) + allocate ( dzsf(ntiles), source = SURFLAY ) allocate ( ar1( ntiles) ) allocate ( ar2( ntiles) ) allocate ( ar4( ntiles) ) From 60bcc9e6281547bef33c89dcba0023fd9541df85 Mon Sep 17 00:00:00 2001 From: Weiyuan Jiang Date: Fri, 6 May 2022 11:07:16 -0400 Subject: [PATCH 07/17] zero-diff for cnclm45 from M36 to M09. Clean up clmc45_xx --- .../Utils/mk_restarts/CatchmentCNRst.F90 | 518 +++++++----------- .../Utils/mk_restarts/CatchmentRst.F90 | 108 ++-- .../mk_restarts/mk_CatchmentRestarts.F90 | 4 +- 3 files changed, 265 insertions(+), 365 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentCNRst.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentCNRst.F90 index 3a7c18cc2..0ec4d1692 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentCNRst.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentCNRst.F90 @@ -48,31 +48,31 @@ module CatchmentCNRstMod real, allocatable :: HDM (:) real, allocatable :: GDP (:) real, allocatable :: PEATF (:) - - real, allocatable :: bflowm(:) - real, allocatable :: totwatm(:) - real, allocatable :: tairm(:) - real, allocatable :: tpm(:) - real, allocatable :: cnsum(:) - real, allocatable :: sndzm(:) - real, allocatable :: asnowm(:) - real, allocatable :: ar1m(:) - real, allocatable :: rainfm(:) - real, allocatable :: rhm(:) - real, allocatable :: runsrfm(:) - real, allocatable :: snowfm(:) - real, allocatable :: windm(:) - real, allocatable :: tprec10d(:) - real, allocatable :: tprec60d(:) - real, allocatable :: t2m10d(:) - real, allocatable :: sfmcm(:) - real, allocatable :: psnsunm(:,:,:) - real, allocatable :: psnsham(:,:,:) + ! below is not necessary. It is not read. It is set to 0 during writing + !real, allocatable :: bflowm(:) + !real, allocatable :: totwatm(:) + !real, allocatable :: tairm(:) + !real, allocatable :: tpm(:) + !real, allocatable :: cnsum(:) + !real, allocatable :: sndzm(:) + !real, allocatable :: asnowm(:) + !real, allocatable :: ar1m(:) + !real, allocatable :: rainfm(:) + !real, allocatable :: rhm(:) + !real, allocatable :: runsrfm(:) + !real, allocatable :: snowfm(:) + !real, allocatable :: windm(:) + !real, allocatable :: tprec10d(:) + !real, allocatable :: tprec60d(:) + !real, allocatable :: t2m10d(:) + !real, allocatable :: sfmcm(:) + !real, allocatable :: psnsunm(:,:,:) + !real, allocatable :: psnsham(:,:,:) contains procedure :: write_nc4 procedure :: allocate_cn - procedure :: add_bcs_to_rst + procedure :: add_bcs_to_cnrst procedure :: re_tile endtype CatchmentCNRst @@ -229,6 +229,7 @@ subroutine write_nc4(this, filename, rc) do j=1,dim1 call MAPL_VarWrite(formatter,"ITY",this%cnity(:,j),offset1=j) call MAPL_VarWrite(formatter,"FVG",this%fvg(:,j),offset1=j) + call MAPL_VarWrite(formatter,"TG",this%tg(:,j),offset1=j) enddo call MAPL_VarWrite(formatter,"TILE_ID",this%TILE_ID) @@ -253,8 +254,8 @@ subroutine write_nc4(this, filename, rc) enddo dim1 = meta%get_dimension('tile') - allocate (var (dim1)) - var = 0. + + allocate (var(dim1),source = 0.) call MAPL_VarWrite(formatter,"BFLOWM", var) call MAPL_VarWrite(formatter,"TOTWATM",var) @@ -322,9 +323,10 @@ subroutine allocate_cn(this,rc) call this%CatchmentRst%allocate_catch(__RC__) - allocate(this%cnity(ntiles,4)) - allocate(this%fvg(ntiles,4)) - allocate(this%tg(ntiles,4)) + ! W.Jiang notes : some varaiables are not allocated because they are set to zero directly during write + allocate(this%cnity(ntiles,nveg)) + allocate(this%fvg(ntiles,nveg)) + allocate(this%tg(ntiles,nveg)) allocate(this%tgwm(ntiles,nzone)) allocate(this%rzmm(ntiles,nzone)) allocate(this%TILE_ID(ntiles)) @@ -344,15 +346,13 @@ subroutine allocate_cn(this,rc) _RETURN(_SUCCESS) end subroutine allocate_cn - SUBROUTINE add_bcs_to_rst (this, SURFLAY, DataDir,rc) + SUBROUTINE add_bcs_to_cnrst (this, SURFLAY, OutBcsDir,rc) class(CatchmentCNRst), intent(inout) :: this real, intent (in) :: SURFLAY - character(*), intent (in) :: DataDir + character(*), intent (in) :: OutBcsDir integer, optional, intent(out) :: rc real, allocatable :: CLMC_pf1(:), CLMC_pf2(:), CLMC_sf1(:), CLMC_sf2(:) real, allocatable :: CLMC_pt1(:), CLMC_pt2(:), CLMC_st1(:), CLMC_st2(:) - real, allocatable :: CLMC45_pf1(:), CLMC45_pf2(:), CLMC45_sf1(:), CLMC45_sf2(:) - real, allocatable :: CLMC45_pt1(:), CLMC45_pt2(:), CLMC45_st1(:), CLMC45_st2(:) real, allocatable :: NDEP(:), BVISDR(:), BVISDF(:), BNIRDR(:), BNIRDF(:) real, allocatable :: T2(:), var1(:), hdm(:), fc(:), gdp(:), peatf(:) integer, allocatable :: ity(:), abm (:) @@ -364,27 +364,28 @@ SUBROUTINE add_bcs_to_rst (this, SURFLAY, DataDir,rc) type(NetCDF4_Fileformatter) :: CatchCNFmt character*256 :: Iam = "add_bcs" + + open (10,file =trim(OutBcsDir)//"/clsm/catchment.def",status='old',form='formatted') + read (10,*) ntiles + close (10, status = 'keep') - ntiles = this%ntiles - call this%CatchmentRst%add_bcs_to_rst(surflay, DataDir, __RC__) + !ntiles = this%ntiles + !call this%CatchmentRst%add_bcs_to_rst(surflay, OutBcsDir, __RC__) allocate (BVISDR(ntiles), BVISDF(ntiles), BNIRDR(ntiles) ) allocate (BNIRDF(ntiles), T2(ntiles), NDEP(ntiles) ) allocate (CLMC_pf1(ntiles), CLMC_pf2(ntiles), CLMC_sf1(ntiles)) allocate (CLMC_sf2(ntiles), CLMC_pt1(ntiles), CLMC_pt2(ntiles)) - allocate (CLMC45_pf1(ntiles), CLMC45_pf2(ntiles), CLMC45_sf1(ntiles)) - allocate (CLMC45_sf2(ntiles), CLMC45_pt1(ntiles), CLMC45_pt2(ntiles)) allocate (CLMC_st1(ntiles), CLMC_st2(ntiles)) - allocate (CLMC45_st1(ntiles), CLMC45_st2(ntiles)) allocate (hdm(ntiles), fc(ntiles), gdp(ntiles)) allocate (peatf(ntiles), abm(ntiles), var1(ntiles)) - inquire(file = trim(DataDir)//'/catchcn_params.nc4', exist=file_exists) - inquire(file = trim(DataDir)//"CLM_veg_typs_fracs" ,exist=NewLand ) + inquire(file = trim(OutBcsDir)//'/clsm/catchcn_params.nc4', exist=file_exists) + inquire(file = trim(OutBcsDir)//'/clsm/CLM_veg_typs_fracs', exist=NewLand ) _ASSERT(Newland, "catchcn should get bc from newland") if(file_exists) then - call CatchCNFmt%Open(trim(DataDir)//'/catchcn_params.nc4', pFIO_READ, __RC__) + call CatchCNFmt%Open(trim(OutBcsDir)//'/clsm/catchcn_params.nc4', pFIO_READ, __RC__) call MAPL_VarRead ( CatchCNFmt ,'BGALBNF', BNIRDF, __RC__) call MAPL_VarRead ( CatchCNFmt ,'BGALBNR', BNIRDR, __RC__) call MAPL_VarRead ( CatchCNFmt ,'BGALBVF', BVISDF, __RC__) @@ -402,16 +403,14 @@ SUBROUTINE add_bcs_to_rst (this, SURFLAY, DataDir,rc) call CatchCNFmt%close() else - open(newunit=unit27, file=trim(DataDir)//'CLM_veg_typs_fracs' ,form='formatted') - open(newunit=unit28, file=trim(DataDir)//'CLM_NDep_SoilAlb_T2m' ,form='formatted') + open(newunit=unit27, file=trim(OutBcsDir)//'/clsm/CLM_veg_typs_fracs' ,form='formatted') + open(newunit=unit28, file=trim(OutBcsDir)//'/clsm/CLM_NDep_SoilAlb_T2m' ,form='formatted') do n=1,ntiles read (unit27, *) i,j, CLMC_pt1(n), CLMC_pt2(n), CLMC_st1(n), CLMC_st2(n), & CLMC_pf1(n), CLMC_pf2(n), CLMC_sf1(n), CLMC_sf2(n) read (unit28, *) NDEP(n), BVISDR(n), BVISDF(n), BNIRDR(n), BNIRDF(n), T2(n) ! MERRA-2 Annual Mean Temp is default. - if(this%isCLM45) then - endif end do CLOSE (unit27, STATUS = 'KEEP') @@ -421,15 +420,11 @@ SUBROUTINE add_bcs_to_rst (this, SURFLAY, DataDir,rc) if (this%isCLM45 ) then - open(newunit=unit29, file=trim(DataDir)//'CLM4.5_veg_typs_fracs',form='formatted') - open(newunit=unit30, file=trim(DataDir)//'CLM4.5_abm_peatf_gdp_hdm_fc' ,form='formatted') + open(newunit=unit30, file=trim(OutBcsDir)//'/clsm/CLM4.5_abm_peatf_gdp_hdm_fc' ,form='formatted') do n=1,ntiles - read (unit29, *) i,j, CLMC45_pt1(n), CLMC45_pt2(n), CLMC45_st1(n), CLMC45_st2(n), & - CLMC45_pf1(n), CLMC45_pf2(n), CLMC45_sf1(n), CLMC45_sf2(n) read (unit30, *) i, j, abm(n), peatf(n), & gdp(n), hdm(n), fc(n) end do - CLOSE (unit29, STATUS = 'KEEP') CLOSE (unit30, STATUS = 'KEEP') endif @@ -467,36 +462,6 @@ SUBROUTINE add_bcs_to_rst (this, SURFLAY, DataDir,rc) CLMC_sf1(n) = fvg(3) CLMC_sf2(n) = fvg(4) enddo - - if(this%isCLM45) then - do n =1, ntiles - CLMC45_pf1(n) = CLMC45_pf1(n) / 100. - CLMC45_pf2(n) = CLMC45_pf2(n) / 100. - CLMC45_sf1(n) = CLMC45_sf1(n) / 100. - CLMC45_sf2(n) = CLMC45_sf2(n) / 100. - - fvg(1) = CLMC45_pf1(n) - fvg(2) = CLMC45_pf2(n) - fvg(3) = CLMC45_sf1(n) - fvg(4) = CLMC45_sf2(n) - - BARE = 1. - - DO NV = 1, NVEG - BARE = BARE - fvg(NV)! subtract vegetated fractions - END DO - - if (BARE /= 0.) THEN - IB = MAXLOC(fvg(:),1) - fvg (IB) = fvg(IB) + BARE ! This also corrects all cases sum ne 0. - ENDIF - - CLMC45_pf1(n) = fvg(1) - CLMC45_pf2(n) = fvg(2) - CLMC45_sf1(n) = fvg(3) - CLMC45_sf2(n) = fvg(4) - enddo - endif NDEP = NDEP * 1.e-9 @@ -539,53 +504,9 @@ SUBROUTINE add_bcs_to_rst (this, SURFLAY, DataDir,rc) CLMC_sf2(n) = 0. endif enddo - if (this%isCLM45) then - do n = 1, ntiles - if(CLMC45_pf1(n) <= 1.e-4) then - CLMC45_pf2(n) = CLMC45_pf2(n) + CLMC45_pf1(n) - CLMC45_pf1(n) = 0. - endif - - if(CLMC45_pf2(n) <= 1.e-4) then - CLMC45_pf1(n) = CLMC45_pf1(n) + CLMC45_pf2(n) - CLMC45_pf2(n) = 0. - endif - - if(CLMC45_sf1(n) <= 1.e-4) then - if(CLMC45_sf2(n) > 1.e-4) then - CLMC45_sf2(n) = CLMC45_sf2(n) + CLMC45_sf1(n) - else if(CLMC45_pf2(n) > 1.e-4) then - CLMC45_pf2(n) = CLMC45_pf2(n) + CLMC45_sf1(n) - else if(CLMC45_pf1(n) > 1.e-4) then - CLMC45_pf1(n) = CLMC45_pf1(n) + CLMC45_sf1(n) - else - stop 'fveg3' - endif - CLMC45_sf1(n) = 0. - endif - - if(CLMC45_sf2(n) <= 1.e-4) then - if(CLMC45_sf1(n) > 1.e-4) then - CLMC45_sf1(n) = CLMC45_sf1(n) + CLMC45_sf2(n) - else if(CLMC45_pf2(n) > 1.e-4) then - CLMC45_pf2(n) = CLMC45_pf2(n) + CLMC45_sf2(n) - else if(CLMC45_pf1(n) > 1.e-4) then - CLMC45_pf1(n) = CLMC45_pf1(n) + CLMC45_sf2(n) - else - stop 'fveg4' - endif - CLMC45_sf2(n) = 0. - endif - enddo - endif - if (this%isCLM45) then - this%cnity = reshape([CLMC45_pt1,CLMC45_pt2,CLMC45_st1,CLMC45_st2],[ntiles,4]) - this%fvg = reshape([CLMC45_pf1,CLMC45_pf2,CLMC45_sf1,CLMC45_sf2],[ntiles,4]) - else - this%cnity = reshape([CLMC_pt1,CLMC_pt2,CLMC_st1,CLMC_st2],[ntiles,4]) - this%fvg = reshape([CLMC_pf1,CLMC_pf2,CLMC_sf1,CLMC_sf2],[ntiles,4]) - endif + this%cnity = reshape([CLMC_pt1,CLMC_pt2,CLMC_st1,CLMC_st2],[ntiles,4]) + this%fvg = reshape([CLMC_pf1,CLMC_pf2,CLMC_sf1,CLMC_sf2],[ntiles,4]) this%ndep = ndep this%t2 = t2 @@ -609,7 +530,7 @@ SUBROUTINE add_bcs_to_rst (this, SURFLAY, DataDir,rc) deallocate (CLMC_st1,CLMC_st2) _RETURN(_SUCCESS) - end subroutine add_bcs_to_rst + end subroutine add_bcs_to_cnrst subroutine re_tile(this, InTileFile, OutBcsDir, OutTileFile, surflay, rc) class(CatchmentCNRst), intent(inout) :: this @@ -619,20 +540,18 @@ subroutine re_tile(this, InTileFile, OutBcsDir, OutTileFile, surflay, rc) real, intent(in) :: surflay integer, optional, intent(out) :: rc - real , allocatable, dimension (:) :: LATT, LONN, DAYX - real , pointer , dimension (:) :: long, latg, lonc, latc - integer, allocatable, dimension (:) :: low_ind, upp_ind, nt_local - integer, allocatable, dimension (:) :: Id_glb, id_loc + real , allocatable, dimension (:) :: DAYX + integer, allocatable, dimension (:) :: low_ind, upp_ind, nt_local integer, allocatable, dimension (:,:) :: Id_glb_cn, id_loc_cn - integer, allocatable, dimension (:) :: ld_reorder, tid_offl - real, allocatable, dimension (:) :: CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2, & - CLMC_pt1, CLMC_pt2,CLMC_st1,CLMC_st2, var_dum2 + integer, allocatable, dimension (:) :: tid_offl, id_loc + real, allocatable, dimension (:) :: CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2, & + CLMC_pt1, CLMC_pt2,CLMC_st1,CLMC_st2, var_dum2, var_dum3 integer :: AGCM_YY,AGCM_MM,AGCM_DD,AGCM_HR=0,AGCM_DATE - real, allocatable, dimension(:,:) :: fveg_offl, ityp_offl, fveg_tmp, ityp_tmp + real, allocatable, dimension(:,:) :: fveg_offl, ityp_offl, tg_tmp real, allocatable :: var_off_col (:,:,:), var_off_pft (:,:,:,:) integer :: status, in_ntiles, out_ntiles, numprocs logical :: root_proc - integer :: mpierr, n, i, k, req, st, ed, myid, L, iv, nv,nz, var_col, var_pft + integer :: mpierr, n, i, k, tag, req, st, ed, myid, L, iv, nv,nz, var_col, var_pft character(*), parameter :: Iam = "CatchmentCN::Re_tile" @@ -681,12 +600,8 @@ subroutine re_tile(this, InTileFile, OutBcsDir, OutTileFile, surflay, rc) tid_offl(n) = n enddo - ! copy out the old fvg and cnity - if (root_proc) then - allocate (ityp_tmp (in_ntiles,nveg)) - allocate (fveg_tmp (in_ntiles,nveg)) allocate (DAYX (out_ntiles)) READ(this%time(1:8),'(I8)') AGCM_DATE @@ -698,13 +613,18 @@ subroutine re_tile(this, InTileFile, OutBcsDir, OutTileFile, surflay, rc) out_NTILES, AGCM_YY, AGCM_MM, AGCM_DD, AGCM_HR, & this%LATG, DAYX) - ityp_tmp = this%cnity - fveg_tmp = this%fvg + ! save the old vaues dimension (in_ntiles, nv) + ityp_offl = this%cnity + fveg_offl = this%fvg + + do n = 1, in_ntiles + do nv = 1,nveg + if(ityp_offl(n,nv)<0 .or. ityp_offl(n,nv)>npft) stop 'ityp' + if(fveg_offl(n,nv)<0..or. fveg_offl(n,nv)>1.00001) stop 'fveg' + end do - ityp_offl = ityp_tmp - fveg_offl = fveg_tmp + if (nint(this%tile_id(n)) /= n) stop ("cannot assign ity_offl to cnity and fvg_offl to fvg") - do n = 1, size(ityp_offl,1) if((ityp_offl(N,3) == 0).and.(ityp_offl(N,4) == 0)) then if(ityp_offl(N,1) /= 0) then ityp_offl(N,3) = ityp_offl(N,1) @@ -725,17 +645,21 @@ subroutine re_tile(this, InTileFile, OutBcsDir, OutTileFile, surflay, rc) if (root_proc ) then + ! after this call, the cnity and fvg is the dimension of (out_ntiles, nveg) + call this%add_bcs_to_cnrst(surflay, OutBcsDir, __RC__) + do i = 1, numprocs -1 st = low_ind(i+1) l = nt_local(i+1) - call MPI_send(this%cnity(st,1),l, MPI_REAL, i, i, MPI_COMM_WORLD, mpierr) - call MPI_send(this%cnity(st,2),l, MPI_REAL, i, i+1, MPI_COMM_WORLD, mpierr) - call MPI_send(this%cnity(st,3),l, MPI_REAL, i, i+2, MPI_COMM_WORLD, mpierr) - call MPI_send(this%cnity(st,4),l, MPI_REAL, i, i+3, MPI_COMM_WORLD, mpierr) - call MPI_send(this%fvg(st,1),l, MPI_REAL, i, i+4, MPI_COMM_WORLD, mpierr) - call MPI_send(this%fvg(st,2),l, MPI_REAL, i, i+5, MPI_COMM_WORLD, mpierr) - call MPI_send(this%fvg(st,3),l, MPI_REAL, i, i+6, MPI_COMM_WORLD, mpierr) - call MPI_send(this%fvg(st,4),l, MPI_REAL, i, i+7, MPI_COMM_WORLD, mpierr) + tag = i*numprocs + call MPI_send(this%cnity(st,1),l, MPI_REAL, i, tag, MPI_COMM_WORLD, mpierr) + call MPI_send(this%cnity(st,2),l, MPI_REAL, i, tag+1, MPI_COMM_WORLD, mpierr) + call MPI_send(this%cnity(st,3),l, MPI_REAL, i, tag+2, MPI_COMM_WORLD, mpierr) + call MPI_send(this%cnity(st,4),l, MPI_REAL, i, tag+3, MPI_COMM_WORLD, mpierr) + call MPI_send(this%fvg(st,1),l, MPI_REAL, i, tag+4, MPI_COMM_WORLD, mpierr) + call MPI_send(this%fvg(st,2),l, MPI_REAL, i, tag+5, MPI_COMM_WORLD, mpierr) + call MPI_send(this%fvg(st,3),l, MPI_REAL, i, tag+6, MPI_COMM_WORLD, mpierr) + call MPI_send(this%fvg(st,4),l, MPI_REAL, i, tag+7, MPI_COMM_WORLD, mpierr) enddo st = low_ind(1) l = nt_local(1) @@ -749,25 +673,30 @@ subroutine re_tile(this, InTileFile, OutBcsDir, OutTileFile, surflay, rc) CLMC_sf1 = this%fvg(st:ed,3) CLMC_sf2 = this%fvg(st:ed,4) else - call MPI_RECV(CLMC_pt1,nt_local(myid+1) , MPI_REAL, 0, myid, MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - call MPI_RECV(CLMC_pt2,nt_local(myid+1) , MPI_REAL, 0, myid+1, MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - call MPI_RECV(CLMC_st1,nt_local(myid+1) , MPI_REAL, 0, myid+2, MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - call MPI_RECV(CLMC_st2,nt_local(myid+1) , MPI_REAL, 0, myid+3, MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - call MPI_RECV(CLMC_pf1,nt_local(myid+1) , MPI_REAL, 0, myid+4, MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - call MPI_RECV(CLMC_pf2,nt_local(myid+1) , MPI_REAL, 0, myid+5, MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - call MPI_RECV(CLMC_sf1,nt_local(myid+1) , MPI_REAL, 0, myid+6, MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - call MPI_RECV(CLMC_sf2,nt_local(myid+1) , MPI_REAL, 0, myid+7, MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) + tag = myid*numprocs + call MPI_RECV(CLMC_pt1,nt_local(myid+1) , MPI_REAL, 0, tag, MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) + call MPI_RECV(CLMC_pt2,nt_local(myid+1) , MPI_REAL, 0, tag+1, MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) + call MPI_RECV(CLMC_st1,nt_local(myid+1) , MPI_REAL, 0, tag+2, MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) + call MPI_RECV(CLMC_st2,nt_local(myid+1) , MPI_REAL, 0, tag+3, MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) + call MPI_RECV(CLMC_pf1,nt_local(myid+1) , MPI_REAL, 0, tag+4, MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) + call MPI_RECV(CLMC_pf2,nt_local(myid+1) , MPI_REAL, 0, tag+5, MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) + call MPI_RECV(CLMC_sf1,nt_local(myid+1) , MPI_REAL, 0, tag+6, MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) + call MPI_RECV(CLMC_sf2,nt_local(myid+1) , MPI_REAL, 0, tag+7, MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) endif - + call MPI_Barrier(MPI_COMM_WORLD, STATUS) + + if(root_proc) print*, "GetIDs...." + call GetIds(this%lonc,this%latc,this%lonn,this%latt,id_loc_cn, tid_offl, & CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2, CLMC_pt1, CLMC_pt2,CLMC_st1,CLMC_st2, & fveg_offl, ityp_offl) + call MPI_Barrier(MPI_COMM_WORLD, STATUS) + if(root_proc) allocate (id_glb_cn (out_ntiles,nveg)) allocate (id_loc (out_ntiles)) - call MPI_Barrier(MPI_COMM_WORLD, STATUS) deallocate (CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2) deallocate (CLMC_pt1, CLMC_pt2, CLMC_st1, CLMC_st2) @@ -798,6 +727,14 @@ subroutine re_tile(this, InTileFile, OutBcsDir, OutTileFile, surflay, rc) allocate (var_off_pft (1: in_ntiles, 1 : nzone,1 : nveg, 1 : var_pft)) allocate (var_dum2 (1:in_ntiles)) + this%tile_id = [(i*1.0, i=1, out_ntiles)] + + allocate (tg_tmp(out_ntiles, 4),source = 0.) + do i = 1, 3 + tg_tmp(:,i) = this%tg(this%id_glb(:),i) + enddo + this%tg = tg_tmp + i = 1 do nv = 1,VAR_COL do nz = 1,nzone @@ -818,7 +755,9 @@ subroutine re_tile(this, InTileFile, OutBcsDir, OutTileFile, surflay, rc) where(isnan(var_off_pft)) var_off_pft = 0. where(var_off_pft /= var_off_pft) var_off_pft = 0. - print *, 'Writing regridded carbn' + + print *, 'calculating regridded carbn' + call regrid_carbon (out_NTILES, in_ntiles,id_glb_cn, & DAYX, var_off_col,var_off_pft, ityp_offl, fveg_offl) deallocate (var_off_col,var_off_pft) @@ -1261,198 +1200,163 @@ SUBROUTINE regrid_carbon (NTILES, in_ntiles, id_glb, & end do endif - VAR_DUM = 0. - deallocate(this%tgwm,this%rzmm) - allocate(this%tgwm(Ntiles, nzone), source = 0.) - allocate(this%rzmm(Ntiles, nzone), source = 0.) - if (this%isCLM45) then - deallocate(this%SFMM) - allocate(this%sfmm(ntiles, nzone), source =0.) - endif - - this%bflowm = var_dum - this%totwatm = var_dum - this%TAIRM = var_dum - this%TPM = var_dum - - this%CNSUM = VAR_DUM - this%SNDZM = VAR_DUM - this%ASNOWM = VAR_DUM - if(this%isCLM45) then - this%AR1M = VAR_DUM - this%RAINFM = VAR_DUM - this%RHM = VAR_DUM - this%RUNSRFM= VAR_DUM - this%SNOWFM = VAR_DUM - this%WINDM = VAR_DUM - this%TPREC10D=VAR_DUM - this%TPREC60D=VAR_DUM - this%T2M10D =VAR_DUM - else - this%sfmcm = VAR_DUM - endif - deallocate(this%PSNSUNM, this%PSNSHAM) - allocate(this%PSNSUNM(Ntiles,nzone,nveg), source =0.) - allocate(this%PSNSHAM(Ntiles,nzone,nveg), source =0.) - deallocate (var_col_out,var_pft_out) deallocate (CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2) deallocate (CLMC_pt1, CLMC_pt2, CLMC_st1, CLMC_st2) end subroutine regrid_carbon - subroutine compute_dayx ( & + subroutine compute_dayx ( & NTILES, AGCM_YY, AGCM_MM, AGCM_DD, AGCM_HR, & LATT, DAYX) - implicit none - - integer, intent (in) :: NTILES,AGCM_YY,AGCM_MM,AGCM_DD,AGCM_HR - real, dimension (NTILES), intent (in) :: LATT - real, dimension (NTILES), intent (out) :: DAYX - integer, parameter :: DT = 900 - integer, parameter :: ncycle = 1461 ! number of days in a 4-year leap cycle (365*4 + 1) - real, dimension(ncycle) :: zc, zs - integer :: dofyr, sec,YEARS_PER_CYCLE, DAYS_PER_CYCLE, year, iday, idayp1, nn, n - real :: fac, YEARLEN, zsin, zcos, declin - - dofyr = AGCM_DD - if(AGCM_MM > 1) dofyr = dofyr + 31 - if(AGCM_MM > 2) then - dofyr = dofyr + 28 - if(mod(AGCM_YY,4) == 0) dofyr = dofyr + 1 - endif - if(AGCM_MM > 3) dofyr = dofyr + 31 - if(AGCM_MM > 4) dofyr = dofyr + 30 - if(AGCM_MM > 5) dofyr = dofyr + 31 - if(AGCM_MM > 6) dofyr = dofyr + 30 - if(AGCM_MM > 7) dofyr = dofyr + 31 - if(AGCM_MM > 8) dofyr = dofyr + 31 - if(AGCM_MM > 9) dofyr = dofyr + 30 - if(AGCM_MM > 10) dofyr = dofyr + 31 - if(AGCM_MM > 11) dofyr = dofyr + 30 + implicit none - sec = AGCM_HR * 3600 - DT ! subtract DT to get time of previous physics step - fac = real(sec) / 86400. + integer, intent (in) :: NTILES,AGCM_YY,AGCM_MM,AGCM_DD,AGCM_HR + real, dimension (NTILES), intent (in) :: LATT + real, dimension (NTILES), intent (out) :: DAYX + integer, parameter :: DT = 900 + integer, parameter :: ncycle = 1461 ! number of days in a 4-year leap cycle (365*4 + 1) + real, dimension(ncycle) :: zc, zs + integer :: dofyr, sec,YEARS_PER_CYCLE, DAYS_PER_CYCLE, year, iday, idayp1, nn, n + real :: fac, YEARLEN, zsin, zcos, declin + dofyr = AGCM_DD + if(AGCM_MM > 1) dofyr = dofyr + 31 + if(AGCM_MM > 2) then + dofyr = dofyr + 28 + if(mod(AGCM_YY,4) == 0) dofyr = dofyr + 1 + endif + if(AGCM_MM > 3) dofyr = dofyr + 31 + if(AGCM_MM > 4) dofyr = dofyr + 30 + if(AGCM_MM > 5) dofyr = dofyr + 31 + if(AGCM_MM > 6) dofyr = dofyr + 30 + if(AGCM_MM > 7) dofyr = dofyr + 31 + if(AGCM_MM > 8) dofyr = dofyr + 31 + if(AGCM_MM > 9) dofyr = dofyr + 30 + if(AGCM_MM > 10) dofyr = dofyr + 31 + if(AGCM_MM > 11) dofyr = dofyr + 30 - call orbit_create(zs,zc,ncycle) ! GEOS5 leap cycle routine + sec = AGCM_HR * 3600 - DT ! subtract DT to get time of previous physics step + fac = real(sec) / 86400. - YEARLEN = 365.25 - ! Compute length of leap cycle - !------------------------------ + call orbit_create(zs,zc,ncycle) ! GEOS5 leap cycle routine - if(YEARLEN-int(YEARLEN) > 0.) then - YEARS_PER_CYCLE = nint(1./(YEARLEN-int(YEARLEN))) - else - YEARS_PER_CYCLE = 1 - endif + YEARLEN = 365.25 - DAYS_PER_CYCLE=nint(YEARLEN*YEARS_PER_CYCLE) + ! Compute length of leap cycle + !------------------------------ - ! declination & daylength - ! ----------------------- + if(YEARLEN-int(YEARLEN) > 0.) then + YEARS_PER_CYCLE = nint(1./(YEARLEN-int(YEARLEN))) + else + YEARS_PER_CYCLE = 1 + endif - YEAR = mod(AGCM_YY-1,YEARS_PER_CYCLE) + DAYS_PER_CYCLE=nint(YEARLEN*YEARS_PER_CYCLE) - IDAY = YEAR*int(YEARLEN)+dofyr - IDAYP1 = mod(IDAY,DAYS_PER_CYCLE) + 1 + ! declination & daylength + ! ----------------------- - ZSin = ZS(IDAYP1)*FAC + ZS(IDAY)*(1.-FAC) ! sine of solar declination - ZCos = ZC(IDAYP1)*FAC + ZC(IDAY)*(1.-FAC) ! cosine of solar declination + YEAR = mod(AGCM_YY-1,YEARS_PER_CYCLE) - nn = 0 - do n = 1,days_per_cycle - nn = nn + 1 - if(nn > 365) nn = nn - 365 - ! print *, 'cycle:',n,nn,asin(ZS(n)) - end do - declin = asin(ZSin) + IDAY = YEAR*int(YEARLEN)+dofyr + IDAYP1 = mod(IDAY,DAYS_PER_CYCLE) + 1 - ! compute daylength on input tile space (accounts for any change in physics time step) - ! do n = 1,ntiles_cn - ! fac = -(sin((latc(n)/zoom)*(MAPL_PI/180.))*zsin)/(cos((latc(n)/zoom)*(MAPL_PI/180.))*zcos) - ! fac = min(1.,max(-1.,fac)) - ! dayl(n) = (86400./MAPL_PI) * acos(fac) ! daylength (seconds) - ! end do + ZSin = ZS(IDAYP1)*FAC + ZS(IDAY)*(1.-FAC) ! sine of solar declination + ZCos = ZC(IDAYP1)*FAC + ZC(IDAY)*(1.-FAC) ! cosine of solar declination - ! compute daylength on output tile space (accounts for lat shift due to split & change in time step) + nn = 0 + do n = 1,days_per_cycle + nn = nn + 1 + if(nn > 365) nn = nn - 365 + ! print *, 'cycle:',n,nn,asin(ZS(n)) + end do + declin = asin(ZSin) - do n = 1,ntiles - fac = -(sin(latt(n)*(MAPL_PI/180.))*zsin)/(cos(latt(n)*(MAPL_PI/180.))*zcos) - fac = min(1.,max(-1.,fac)) - dayx(n) = (86400./MAPL_PI) * acos(fac) ! daylength (seconds) - end do + ! compute daylength on input tile space (accounts for any change in physics time step) + ! do n = 1,ntiles_cn + ! fac = -(sin((latc(n)/zoom)*(MAPL_PI/180.))*zsin)/(cos((latc(n)/zoom)*(MAPL_PI/180.))*zcos) + ! fac = min(1.,max(-1.,fac)) + ! dayl(n) = (86400./MAPL_PI) * acos(fac) ! daylength (seconds) + ! end do - ! print *,'DAYX : ', minval(dayx),maxval(dayx), minval(latt), maxval(latt), zsin, zcos, dofyr, iday, idayp1, declin + ! compute daylength on output tile space (accounts for lat shift due to split & change in time step) - end subroutine compute_dayx + do n = 1,ntiles + fac = -(sin(latt(n)*(MAPL_PI/180.))*zsin)/(cos(latt(n)*(MAPL_PI/180.))*zcos) + fac = min(1.,max(-1.,fac)) + dayx(n) = (86400./MAPL_PI) * acos(fac) ! daylength (seconds) + end do - ! ***************************************************************************** + ! print *,'DAYX : ', minval(dayx),maxval(dayx), minval(latt), maxval(latt), zsin, zcos, dofyr, iday, idayp1, declin - subroutine orbit_create(zs,zc,ncycle) - implicit none + end subroutine compute_dayx - integer, intent(in) :: ncycle - real, intent(out), dimension(ncycle) :: zs, zc + ! ***************************************************************************** - integer :: YEARS_PER_CYCLE, DAYS_PER_CYCLE - integer :: K, KP !, KM - real*8 :: T1, T2, T3, T4, FUN, Y, SOB, OMG, PRH, TT - real*8 :: YEARLEN + subroutine orbit_create(zs,zc,ncycle) + implicit none - ! STATEMENT FUNCTION + integer, intent(in) :: ncycle + real, intent(out), dimension(ncycle) :: zs, zc - FUN(Y) = OMG*(1.0-ECCENTRICITY*cos(Y-PRH))**2 + integer :: YEARS_PER_CYCLE, DAYS_PER_CYCLE + integer :: K, KP !, KM + real*8 :: T1, T2, T3, T4, FUN, Y, SOB, OMG, PRH, TT + real*8 :: YEARLEN - YEARLEN = 365.25 + ! STATEMENT FUNCTION - ! Factors involving the orbital parameters - !------------------------------------------ + FUN(Y) = OMG*(1.0-ECCENTRICITY*cos(Y-PRH))**2 - OMG = (2.0*MAPL_PI/YEARLEN) / (sqrt(1.-ECCENTRICITY**2)**3) - PRH = PERIHELION*(MAPL_PI/180.) - SOB = sin(OBLIQUITY*(MAPL_PI/180.)) + YEARLEN = 365.25 - ! Compute length of leap cycle - !------------------------------ + ! Factors involving the orbital parameters + !------------------------------------------ - if(YEARLEN-int(YEARLEN) > 0.) then - YEARS_PER_CYCLE = nint(1./(YEARLEN-int(YEARLEN))) - else - YEARS_PER_CYCLE = 1 - endif + OMG = (2.0*MAPL_PI/YEARLEN) / (sqrt(1.-ECCENTRICITY**2)**3) + PRH = PERIHELION*(MAPL_PI/180.) + SOB = sin(OBLIQUITY*(MAPL_PI/180.)) + ! Compute length of leap cycle + !------------------------------ - DAYS_PER_CYCLE=nint(YEARLEN*YEARS_PER_CYCLE) + if(YEARLEN-int(YEARLEN) > 0.) then + YEARS_PER_CYCLE = nint(1./(YEARLEN-int(YEARLEN))) + else + YEARS_PER_CYCLE = 1 + endif - if(days_per_cycle /= ncycle) stop 'bad cycle' - ! ZS: Sine of declination - ! ZC: Cosine of declination + DAYS_PER_CYCLE=nint(YEARLEN*YEARS_PER_CYCLE) - ! Begin integration at vernal equinox + if(days_per_cycle /= ncycle) stop 'bad cycle' - KP = EQUINOX - TT = 0.0 - ZS(KP) = sin(TT)*SOB - ZC(KP) = sqrt(1.0-ZS(KP)**2) + ! ZS: Sine of declination + ! ZC: Cosine of declination - ! Integrate orbit for entire leap cycle using Runge-Kutta + ! Begin integration at vernal equinox - do K=2,DAYS_PER_CYCLE - T1 = FUN(TT ) - T2 = FUN(TT+T1*0.5) - T3 = FUN(TT+T2*0.5) - T4 = FUN(TT+T3 ) - KP = mod(KP,DAYS_PER_CYCLE) + 1 - TT = TT + (T1 + 2.0*(T2 + T3) + T4) / 6.0 - ZS(KP) = sin(TT)*SOB - ZC(KP) = sqrt(1.0-ZS(KP)**2) - end do + KP = EQUINOX + TT = 0.0 + ZS(KP) = sin(TT)*SOB + ZC(KP) = sqrt(1.0-ZS(KP)**2) + + ! Integrate orbit for entire leap cycle using Runge-Kutta - end subroutine orbit_create + do K=2,DAYS_PER_CYCLE + T1 = FUN(TT ) + T2 = FUN(TT+T1*0.5) + T3 = FUN(TT+T2*0.5) + T4 = FUN(TT+T3 ) + KP = mod(KP,DAYS_PER_CYCLE) + 1 + TT = TT + (T1 + 2.0*(T2 + T3) + T4) / 6.0 + ZS(KP) = sin(TT)*SOB + ZC(KP) = sqrt(1.0-ZS(KP)**2) + end do + end subroutine orbit_create end subroutine re_tile diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentRst.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentRst.F90 index d210fa285..0f961d61b 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentRst.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentRst.F90 @@ -19,21 +19,6 @@ module CatchmentRstMod integer :: ftell external :: ftell #endif - type :: scale_var - real, allocatable :: catdef(:) - real, allocatable :: cdcr1 (:) - real, allocatable :: cdcr2 (:) - real, allocatable :: rzexc (:) - real, allocatable :: vgwmax(:) - real, allocatable :: ghtcnt1(:) - real, allocatable :: ghtcnt2(:) - real, allocatable :: ghtcnt3(:) - real, allocatable :: ghtcnt4(:) - real, allocatable :: ghtcnt5(:) - real, allocatable :: ghtcnt6(:) - real, allocatable :: poros(:) - real, allocatable :: sndzn3(:) - end type scale_var type :: CatchmentRst integer :: ntiles @@ -96,10 +81,23 @@ module CatchmentRstMod real, allocatable :: cq(:,:) real, allocatable :: fr(:,:) real, allocatable :: ww(:,:) - + ! save old values for scale + real, allocatable :: old_catdef(:) + real, allocatable :: old_cdcr1 (:) + real, allocatable :: old_cdcr2 (:) + real, allocatable :: old_rzexc (:) + real, allocatable :: old_vgwmax(:) + real, allocatable :: old_ghtcnt1(:) + real, allocatable :: old_ghtcnt2(:) + real, allocatable :: old_ghtcnt3(:) + real, allocatable :: old_ghtcnt4(:) + real, allocatable :: old_ghtcnt5(:) + real, allocatable :: old_ghtcnt6(:) + real, allocatable :: old_poros(:) + real, allocatable :: old_sndzn3(:) ! intermediate - real, allocatable, dimension(:) :: lonc,latc,lonn,latt, long, latg - + real, allocatable, dimension(:) :: lonc,latc,lonn,latt, latg + integer, allocatable, dimension(:) :: id_glb contains procedure :: read_GEOSldas_rst_bin procedure :: write_nc4 @@ -768,8 +766,8 @@ subroutine re_tile(this, InTileFile, OutBcsDir, OutTileFile, surflay, rc) if (myid == 0) root_proc = .true. if(root_proc) then - print *,'ntiles in BCs : ',out_ntiles - print *,'ntiles in restarts : ',in_ntiles + print *,'ntiles in target BCs : ',out_ntiles + print *,'ntiles in restarts : ',in_ntiles endif @@ -805,7 +803,6 @@ subroutine re_tile(this, InTileFile, OutBcsDir, OutTileFile, surflay, rc) allocate (latg (out_ntiles)) call ReadTileFile_RealLatLon ( OutTileFile, n, long, latg) _ASSERT( n == out_ntiles, "Out tile number should match") - this%long = long this%latg = latg call ReadTileFile_RealLatLon ( InTileFile, n, lonc, latc) _ASSERT( n == in_ntiles, "In tile number should match") @@ -876,6 +873,7 @@ subroutine re_tile(this, InTileFile, OutBcsDir, OutTileFile, surflay, rc) this%ntiles = out_ntiles if (root_proc) then ! regrid + this%id_glb = id_glb var_out = this%poros(id_glb(:)) this%poros = var_out @@ -1046,17 +1044,18 @@ subroutine re_tile(this, InTileFile, OutBcsDir, OutTileFile, surflay, rc) this%ch = 0.001 this%cm = 0.001 this%cq = 0.001 + + call this%set_scale_var() endif _RETURN(_SUCCESS) end subroutine re_tile - subroutine re_scale(this, surflay, wemin_in, wemin_out, old, rc) + subroutine re_scale(this, surflay, wemin_in, wemin_out, rc) class(CatchmentRst), intent(inout) :: this real, intent(in) :: surflay real, intent(in) :: wemin_in real, intent(in) :: wemin_out - type(scale_var), intent(in) :: old integer, optional, intent(out) :: rc integer :: ntiles @@ -1070,28 +1069,28 @@ subroutine re_scale(this, surflay, wemin_in, wemin_out, old, rc) ntiles = this%ntiles - n =count((old%catdef .gt. old%cdcr1)) + n =count((this%old_catdef .gt. this%old_cdcr1)) print*, "Scale tile and pesentile :", n,100*n/ntiles ! Scale rxexc regardless of CDCR1, CDCR2 differences ! -------------------------------------------------- - this%rzexc = old%rzexc * ( this%vgwmax / old%vgwmax ) + this%rzexc = this%old_rzexc * ( this%vgwmax / this%old_vgwmax ) ! Scale catdef regardless of whether CDCR2 is larger or smaller in the new situation ! ---------------------------------------------------------------------------------- - where (old%catdef .gt. old%cdcr1) + where (this%old_catdef .gt. this%old_cdcr1) this%catdef = this%cdcr1 + & - ( old%catdef - old%cdcr1 ) / & - ( old%cdcr2 - old%cdcr1 ) * & + ( this%old_catdef - this%old_cdcr1 ) / & + ( this%old_cdcr2 - this%old_cdcr1 ) * & ( this%cdcr2 - this%cdcr1) end where ! Scale catdef also for the case where catdef le cdcr1. ! ----------------------------------------------------- - where( old%catdef .le. old%cdcr1) - this%catdef = old%catdef * (this%cdcr1 / old%cdcr1) + where( this%old_catdef .le. this%old_cdcr1) + this%catdef = this%old_catdef * (this%cdcr1 / this%old_cdcr1) end where ! Sanity Check (catch_calc_soil_moist() forces consistency betw. srfexc, rzexc, catdef) @@ -1119,14 +1118,14 @@ subroutine re_scale(this, surflay, wemin_in, wemin_out, old, rc) allocate (FICE (N_GT, NTILES)) allocate (TP_OUT (N_GT, Ntiles)) - GHT_IN (1,:) = old%ghtcnt1 - GHT_IN (2,:) = old%ghtcnt2 - GHT_IN (3,:) = old%ghtcnt3 - GHT_IN (4,:) = old%ghtcnt4 - GHT_IN (5,:) = old%ghtcnt5 - GHT_IN (6,:) = old%ghtcnt6 + GHT_IN (1,:) = this%old_ghtcnt1 + GHT_IN (2,:) = this%old_ghtcnt2 + GHT_IN (3,:) = this%old_ghtcnt3 + GHT_IN (4,:) = this%old_ghtcnt4 + GHT_IN (5,:) = this%old_ghtcnt5 + GHT_IN (6,:) = this%old_ghtcnt6 - call catch_calc_tp ( NTILES, old%poros, GHT_IN, tp_in, FICE) + call catch_calc_tp ( NTILES, this%old_poros, GHT_IN, tp_in, FICE) do n = 1, ntiles do i = 1, N_GT @@ -1181,14 +1180,14 @@ subroutine re_scale(this, surflay, wemin_in, wemin_out, old, rc) print *, 'Snow scaling summary' print *, '....................' - print *, 'Percent tiles SNDZ scaled : ', 100.* count (this%sndzn3 .ne. old%sndzn3) /float (count (this%sndzn3 > 0.)) + print *, 'Percent tiles SNDZ scaled : ', 100.* count (this%sndzn3 .ne. this%old_sndzn3) /float (count (this%sndzn3 > 0.)) endif ! PEATCLSM - ensure low CATDEF on peat tiles where "old" restart is not also peat ! ------------------------------------------------------------------------------- - where ( (old%poros < PEATCLSM_POROS_THRESHOLD) .and. (this%poros >= PEATCLSM_POROS_THRESHOLD) ) + where ( (this%old_poros < PEATCLSM_POROS_THRESHOLD) .and. (this%poros >= PEATCLSM_POROS_THRESHOLD) ) this%catdef = 25. this%rzexc = 0. this%srfexc = 0. @@ -1196,22 +1195,21 @@ subroutine re_scale(this, surflay, wemin_in, wemin_out, old, rc) end subroutine re_scale - subroutine set_scale_var(this, sca) - class(CatchmentRst), intent(in) :: this - type (scale_var), intent(out) :: sca - sca%catdef = this%catdef - sca%poros = this%poros - sca%cdcr1 = this%cdcr1 - sca%cdcr2 = this%cdcr2 - sca%rzexc = this%rzexc - sca%vgwmax = this%vgwmax - sca%sndzn3 = this%sndzn3 - sca%ghtcnt1 = this%ghtcnt1 - sca%ghtcnt2 = this%ghtcnt2 - sca%ghtcnt3 = this%ghtcnt3 - sca%ghtcnt4 = this%ghtcnt4 - sca%ghtcnt5 = this%ghtcnt5 - sca%ghtcnt6 = this%ghtcnt6 + subroutine set_scale_var(this ) + class(CatchmentRst), intent(inout) :: this + this%old_catdef = this%catdef + this%old_poros = this%poros + this%old_cdcr1 = this%cdcr1 + this%old_cdcr2 = this%cdcr2 + this%old_rzexc = this%rzexc + this%old_vgwmax = this%vgwmax + this%old_sndzn3 = this%sndzn3 + this%old_ghtcnt1 = this%ghtcnt1 + this%old_ghtcnt2 = this%ghtcnt2 + this%old_ghtcnt3 = this%ghtcnt3 + this%old_ghtcnt4 = this%ghtcnt4 + this%old_ghtcnt5 = this%ghtcnt5 + this%old_ghtcnt6 = this%ghtcnt6 end subroutine set_scale_var end module CatchmentRstMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_CatchmentRestarts.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_CatchmentRestarts.F90 index 44a4cd913..1ed01cebf 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_CatchmentRestarts.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_CatchmentRestarts.F90 @@ -18,7 +18,6 @@ PROGRAM mk_CatchmentsRestarts integer :: rc, status integer :: myid, numprocs, mpierr class (CatchmentRst), allocatable :: catch - type (scale_var) :: old call MPI_INIT(mpierr) call MPI_COMM_RANK( MPI_COMM_WORLD, myid, mpierr ) @@ -35,9 +34,8 @@ PROGRAM mk_CatchmentsRestarts call catch%re_tile(in_tilefile, out_bcsdir, out_tilefile, surflay, __RC__) if (myid == 0) then - call catch%set_scale_var(old) call catch%add_bcs_to_rst(surflay, out_bcsdir, rc) - call catch%re_scale(surflay, wemin_in, wemin_out, old, __RC__) + call catch%re_scale(surflay, wemin_in, wemin_out, __RC__) call catch%write_nc4(out_file, __RC__) endif From deabd4676dee32cde7802cc8f87e1159dbf40c5d Mon Sep 17 00:00:00 2001 From: Weiyuan Jiang Date: Fri, 6 May 2022 13:51:21 -0400 Subject: [PATCH 08/17] create symbolink to avoid break after adding .x to excutables --- .../Utils/mk_restarts/CMakeLists.txt | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CMakeLists.txt index 60cc137d3..956310825 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CMakeLists.txt +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CMakeLists.txt @@ -34,3 +34,12 @@ foreach (src ${exe_srcs}) endforeach () install(PROGRAMS mk_Restarts DESTINATION bin) +foreach (src ${exe_srcs}) + string (REGEX REPLACE ".F90" ".x" exe ${src}) + string (REGEX REPLACE ".F90" "" lname ${src}) + install(CODE "execute_process( \ + COMMAND ${CMAKE_COMMAND} -E create_symlink \ + ${CMAKE_INSTALL_PREFIX}/bin/${exe} \ + ${CMAKE_INSTALL_PREFIX}/bin/${lname} \ + )") +endforeach () From 62725f39cbe14871c4790931f8768496f385acf4 Mon Sep 17 00:00:00 2001 From: Weiyuan Jiang Date: Fri, 6 May 2022 14:08:37 -0400 Subject: [PATCH 09/17] rename to mk_catchANDcnRestarts.F90 for more infor --- .../GEOSsurface_GridComp/Utils/mk_restarts/CMakeLists.txt | 2 +- .../{mk_CatchmentRestarts.F90 => mk_catchANDcnRestarts.F90} | 6 ++++-- 2 files changed, 5 insertions(+), 3 deletions(-) rename GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/{mk_CatchmentRestarts.F90 => mk_catchANDcnRestarts.F90} (95%) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CMakeLists.txt index 956310825..75ce7bbee 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CMakeLists.txt +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CMakeLists.txt @@ -18,7 +18,7 @@ set (exe_srcs mk_LakeLandiceSaltRestarts.F90 mk_RouteRestarts.F90 mk_GEOSldasRestarts.F90 - mk_CatchmentRestarts.F90 + mk_catchANDcnRestarts.F90 ) esma_add_library (${this} diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_CatchmentRestarts.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_catchANDcnRestarts.F90 similarity index 95% rename from GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_CatchmentRestarts.F90 rename to GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_catchANDcnRestarts.F90 index 1ed01cebf..931f97ffa 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_CatchmentRestarts.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_catchANDcnRestarts.F90 @@ -1,7 +1,7 @@ #define I_AM_MAIN #include "MAPL_Generic.h" -PROGRAM mk_CatchmentsRestarts +PROGRAM mk_catchANDcnRestarts use mpi use MAPL @@ -10,7 +10,6 @@ PROGRAM mk_CatchmentsRestarts implicit none - character(len=:), allocatable :: out_bcsdir, out_dir, in_tilefile, out_tilefile, YYYYMMDDHHMM character(len=:), allocatable :: model, in_rstfile, out_rstfile character(len=:), allocatable :: out_File @@ -119,6 +118,9 @@ subroutine process_cmd() end subroutine subroutine print_usage() + print *,' ' + print *, 'This program can create catchment or catchmentCN restarts' + print *, 'depending on the command line option "model" ' print *,' ' print *,'-out_bcs : BC directory for output restart file' print *,'-time : time for restart, format (yyyymmddhhmm)' From 106c172fcd821eb17b26f54fed57cb7a854d43a9 Mon Sep 17 00:00:00 2001 From: Weiyuan Jiang Date: Fri, 20 May 2022 10:39:14 -0400 Subject: [PATCH 10/17] add more protection to write tsurf,cm,cq... --- .../Utils/mk_restarts/CatchmentRst.F90 | 87 ++++++++++++++----- 1 file changed, 67 insertions(+), 20 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentRst.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentRst.F90 index 0f961d61b..3918896e2 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentRst.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentRst.F90 @@ -399,7 +399,9 @@ subroutine write_shared_nc4(this, formatter, rc) call MAPL_VarWrite(formatter,"GHTCNT4",this%ghtcnt4) call MAPL_VarWrite(formatter,"GHTCNT5",this%ghtcnt5) call MAPL_VarWrite(formatter,"GHTCNT6",this%ghtcnt6) - call MAPL_VarWrite(formatter,"TSURF",this%tsurf) + if (this%meta%has_variable('TSURF')) then + call MAPL_VarWrite(formatter,"TSURF",this%tsurf) + endif call MAPL_VarWrite(formatter,"WESNN1",this%wesnn1) call MAPL_VarWrite(formatter,"WESNN2",this%wesnn2) call MAPL_VarWrite(formatter,"WESNN3",this%wesnn3) @@ -409,11 +411,23 @@ subroutine write_shared_nc4(this, formatter, rc) call MAPL_VarWrite(formatter,"SNDZN1",this%sndzn1) call MAPL_VarWrite(formatter,"SNDZN2",this%sndzn2) call MAPL_VarWrite(formatter,"SNDZN3",this%sndzn3) - call MAPL_VarWrite(formatter,"CH",this%ch) - call MAPL_VarWrite(formatter,"CM",this%cm) - call MAPL_VarWrite(formatter,"CQ",this%cq) - call MAPL_VarWrite(formatter,"FR",this%fr) - call MAPL_VarWrite(formatter,"WW",this%ww) + + if (this%meta%has_variable('CH')) then + call MAPL_VarWrite(formatter,"CH",this%ch) + endif + if (this%meta%has_variable('CM')) then + call MAPL_VarWrite(formatter,"CM",this%cm) + endif + if (this%meta%has_variable('CQ')) then + call MAPL_VarWrite(formatter,"CQ",this%cq) + endif + if (this%meta%has_variable('FR')) then + call MAPL_VarWrite(formatter,"FR",this%fr) + endif + if (this%meta%has_variable('WW')) then + call MAPL_VarWrite(formatter,"WW",this%ww) + endif + _RETURN(_SUCCESS) end subroutine write_shared_nc4 @@ -465,7 +479,11 @@ subroutine allocate_catch(this,rc) allocate( this% ghtcnt4(ntiles) ) allocate( this% ghtcnt5(ntiles) ) allocate( this% ghtcnt6(ntiles) ) - allocate( this% tsurf(ntiles) ) + + if (this%meta%has_variable('TSURF')) then + allocate( this% tsurf(ntiles) ) + endif + allocate( this% wesnn1(ntiles) ) allocate( this% wesnn2(ntiles) ) allocate( this% wesnn3(ntiles) ) @@ -475,11 +493,22 @@ subroutine allocate_catch(this,rc) allocate( this% sndzn1(ntiles) ) allocate( this% sndzn2(ntiles) ) allocate( this% sndzn3(ntiles) ) - allocate( this% ch(ntiles,4) ) - allocate( this% cm(ntiles,4) ) - allocate( this% cq(ntiles,4) ) - allocate( this% fr(ntiles,4) ) - allocate( this% ww(ntiles,4) ) + + if (this%meta%has_variable('CH')) then + allocate( this% ch(ntiles,4) ) + endif + if (this%meta%has_variable('CM')) then + allocate( this% cm(ntiles,4) ) + endif + if (this%meta%has_variable('CQ')) then + allocate( this% cq(ntiles,4) ) + endif + if (this%meta%has_variable('FR')) then + allocate( this% fr(ntiles,4) ) + endif + if (this%meta%has_variable('WW')) then + allocate( this% ww(ntiles,4) ) + endif _RETURN(_SUCCESS) end subroutine allocate_catch @@ -1033,17 +1062,35 @@ subroutine re_tile(this, InTileFile, OutBcsDir, OutTileFile, surflay, rc) var_out = this%SNDZN3(id_glb(:)) this%SNDZN3 = var_out + + !set tsurf to zero + if (this%meta%has_variable('TSURF')) then + var_out = 0.0 + this%tsurf = var_out + endif ! CH CM CQ FR WW ! WW - deallocate(this%ww, this%cm, this%cq, this%fr, this%ch) - allocate(this%ww(out_ntiles,4), this%cm(out_ntiles,4), this%cq(out_ntiles,4)) - allocate(this%fr(out_ntiles,4), this%ch(out_ntiles,4)) - this%ww = 0.1 - this%fr = 0.25 - this%ch = 0.001 - this%cm = 0.001 - this%cq = 0.001 + if(allocated(tmp2d)) deallocate(tmp2d) + allocate(tmp2d(out_ntiles,4)) + tmp2d = 0.001 + if (this%meta%has_variable('CH')) then + this%ch = tmp2d + endif + if (this%meta%has_variable('CM')) then + this%cm = tmp2d + endif + if (this%meta%has_variable('CQ')) then + this%cq = tmp2d + endif + tmp2d = 0.25 + if (this%meta%has_variable('FR')) then + this%fr = tmp2d + endif + tmp2d = 0.1 + if (this%meta%has_variable('WW')) then + this%ww = tmp2d + endif call this%set_scale_var() endif From 9819a79433f74b3392b3ef044e7792804bff4417 Mon Sep 17 00:00:00 2001 From: Weiyuan Jiang Date: Wed, 1 Jun 2022 13:37:28 -0400 Subject: [PATCH 11/17] get back to original getids.F90 --- .../Utils/mk_restarts/CatchmentRst.F90 | 8 +++++++- .../GEOSsurface_GridComp/Utils/mk_restarts/getids.F90 | 4 +++- 2 files changed, 10 insertions(+), 2 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentRst.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentRst.F90 index 3918896e2..b0e7a00df 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentRst.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentRst.F90 @@ -772,7 +772,8 @@ subroutine re_tile(this, InTileFile, OutBcsDir, OutTileFile, surflay, rc) integer, optional, intent(out) :: rc integer :: status, in_ntiles, out_ntiles, myid, numprocs real, allocatable :: var_out(:), tmp2d(:,:) - real , allocatable , dimension (:) :: long, latg, lonc, latc, lonn,latt + real , allocatable , dimension (:) :: lonn,latt + real , pointer, dimension (:) :: long, latg, lonc, latc integer, allocatable , dimension (:) :: low_ind, upp_ind, nt_local integer, allocatable , dimension (:) :: Id_glb, id_loc, tid_offl logical :: root_proc @@ -1095,6 +1096,11 @@ subroutine re_tile(this, InTileFile, OutBcsDir, OutTileFile, surflay, rc) call this%set_scale_var() endif + if(associated(long)) deallocate(long) + if(associated(latg)) deallocate(latg) + if(associated(lonc)) deallocate(lonc) + if(associated(latc)) deallocate(latc) + _RETURN(_SUCCESS) end subroutine re_tile diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/getids.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/getids.F90 index 7ceeb2434..be7ec9295 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/getids.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/getids.F90 @@ -554,7 +554,7 @@ subroutine ReadTileFile_RealLatLon (InCNTileFile, ntiles, xlon, xlat,mask) implicit none character(*), intent (in) :: InCNTileFile integer , intent (inout) :: ntiles - real, dimension (:), intent(out) :: xlon, xlat + real, pointer, dimension (:) :: xlon, xlat integer, optional, intent(IN) :: mask integer :: n,icnt,ityp, nt, umask, i, header real :: xval,yval, pf @@ -605,6 +605,8 @@ subroutine ReadTileFile_RealLatLon (InCNTileFile, ntiles, xlon, xlat,mask) close(11) Ntiles = icnt + if(.not.associated (xlon)) allocate(xlon(Ntiles)) + if(.not.associated (xlat)) allocate(xlat(Ntiles)) xlon = ln1(:Ntiles) xlat = lt1(:Ntiles) From f4941664b30e8a0610829b42eba5a4f0df542071 Mon Sep 17 00:00:00 2001 From: Weiyuan Jiang Date: Tue, 7 Jun 2022 08:42:57 -0400 Subject: [PATCH 12/17] zero diff for mk_CatchRestarts.F90 --- .../Utils/mk_restarts/CatchmentRst.F90 | 27 ++++++++++++++----- 1 file changed, 21 insertions(+), 6 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentRst.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentRst.F90 index b0e7a00df..0ea043b54 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentRst.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentRst.F90 @@ -996,14 +996,14 @@ subroutine re_tile(this, InTileFile, OutBcsDir, OutTileFile, surflay, rc) tmp2d = this%tc deallocate(this%tc) allocate(this%tc(out_ntiles, 4)) - do k = 1, 3 + do k = 1, 4 this%tc(:,k) = tmp2d(id_glb(:),k) enddo tmp2d = this%qc deallocate(this%qc) allocate(this%qc(out_ntiles, 4)) - do k = 1, 3 + do k = 1, 4 this%qc(:,k) = tmp2d(id_glb(:),k) enddo @@ -1066,7 +1066,7 @@ subroutine re_tile(this, InTileFile, OutBcsDir, OutTileFile, surflay, rc) !set tsurf to zero if (this%meta%has_variable('TSURF')) then - var_out = 0.0 + var_out = this%tsurf(id_glb(:)) this%tsurf = var_out endif @@ -1074,22 +1074,37 @@ subroutine re_tile(this, InTileFile, OutBcsDir, OutTileFile, surflay, rc) ! WW if(allocated(tmp2d)) deallocate(tmp2d) allocate(tmp2d(out_ntiles,4)) - tmp2d = 0.001 + !tmp2d = 0.001 if (this%meta%has_variable('CH')) then + do k = 1,4 + tmp2d(:,k) = this%ch(id_glb(:),k) + enddo this%ch = tmp2d endif if (this%meta%has_variable('CM')) then + do k = 1,4 + tmp2d(:,k) = this%cm(id_glb(:),k) + enddo this%cm = tmp2d endif if (this%meta%has_variable('CQ')) then + do k = 1,4 + tmp2d(:,k) = this%cq(id_glb(:),k) + enddo this%cq = tmp2d endif - tmp2d = 0.25 + !tmp2d = 0.25 if (this%meta%has_variable('FR')) then + do k = 1,4 + tmp2d(:,k) = this%fr(id_glb(:),k) + enddo this%fr = tmp2d endif - tmp2d = 0.1 + !tmp2d = 0.1 if (this%meta%has_variable('WW')) then + do k = 1,4 + tmp2d(:,k) = this%ww(id_glb(:),k) + enddo this%ww = tmp2d endif From 9294af70448722812e698f0221844817632184dc Mon Sep 17 00:00:00 2001 From: Weiyuan Jiang Date: Fri, 10 Jun 2022 10:51:03 -0400 Subject: [PATCH 13/17] cleanup and change getids.F90 location --- .../Shared/CMakeLists.txt | 1 + .../{Utils/mk_restarts => Shared}/getids.F90 | 0 .../Utils/Raster/CMakeLists.txt | 2 +- .../comp_CATCHCN_AlbScale_parameters.F90 | 36 +------------------ .../Utils/mk_restarts/CMakeLists.txt | 1 - .../Utils/mk_restarts/README | 26 ++------------ .../Utils/mk_restarts/{ => obsolete}/catchplt | 0 .../{ => obsolete}/check_land_restarts.pro | 0 .../{ => obsolete}/mk_catch_restart | 0 .../{ => obsolete}/mk_catch_restart.F90 | 0 .../{ => obsolete}/mk_vegdyn_restart | 0 .../{ => obsolete}/mk_vegdyn_restart.F90 | 0 .../mk_restarts/{ => obsolete}/new_catch.ctl | 0 .../mk_restarts/{ => obsolete}/newcatch.F90 | 0 .../mk_restarts/{ => obsolete}/newvegdyn.f90 | 0 .../mk_restarts/{ => obsolete}/old_catch.ctl | 0 .../{ => obsolete}/replace_params.F90 | 0 .../{ => obsolete}/strip_vegdyn.F90 | 0 18 files changed, 5 insertions(+), 61 deletions(-) rename GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/{Utils/mk_restarts => Shared}/getids.F90 (100%) rename GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/{ => obsolete}/catchplt (100%) rename GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/{ => obsolete}/check_land_restarts.pro (100%) rename GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/{ => obsolete}/mk_catch_restart (100%) rename GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/{ => obsolete}/mk_catch_restart.F90 (100%) rename GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/{ => obsolete}/mk_vegdyn_restart (100%) rename GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/{ => obsolete}/mk_vegdyn_restart.F90 (100%) rename GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/{ => obsolete}/new_catch.ctl (100%) rename GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/{ => obsolete}/newcatch.F90 (100%) rename GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/{ => obsolete}/newvegdyn.f90 (100%) rename GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/{ => obsolete}/old_catch.ctl (100%) rename GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/{ => obsolete}/replace_params.F90 (100%) rename GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/{ => obsolete}/strip_vegdyn.F90 (100%) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/CMakeLists.txt index 7abedf76c..24e12a4ee 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/CMakeLists.txt +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/CMakeLists.txt @@ -10,6 +10,7 @@ install( FILES ${resource_files} ) set (srcs + getids.F90 StieglitzSnow.F90 SurfParams.F90) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/getids.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/getids.F90 similarity index 100% rename from GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/getids.F90 rename to GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/getids.F90 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/CMakeLists.txt index 98956b0cd..d2e15de4a 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/CMakeLists.txt +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/CMakeLists.txt @@ -18,7 +18,7 @@ if(NOT FORTRAN_COMPILER_SUPPORTS_FINDLOC) list(APPEND srcs findloc.F90) endif () -esma_add_library(${this} SRCS ${srcs} DEPENDENCIES MAPL GEOS_LandShared esmf NetCDF::NetCDF_Fortran OpenMP::OpenMP_Fortran OpenMP::OpenMP_C) +esma_add_library(${this} SRCS ${srcs} DEPENDENCIES MAPL GEOS_SurfaceShared GEOS_LandShared esmf NetCDF::NetCDF_Fortran OpenMP::OpenMP_Fortran OpenMP::OpenMP_C) if(NOT FORTRAN_COMPILER_SUPPORTS_FINDLOC) target_compile_definitions(${this} PRIVATE USE_EXTERNAL_FINDLOC) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/comp_CATCHCN_AlbScale_parameters.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/comp_CATCHCN_AlbScale_parameters.F90 index 16bd9f0f2..f4e7c2713 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/comp_CATCHCN_AlbScale_parameters.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/comp_CATCHCN_AlbScale_parameters.F90 @@ -5,7 +5,7 @@ MODULE comp_CATCHCN_AlbScale_parameters use date_time_util, ONLY: & date_time_type, augment_date_time - + use mk_restarts_getidsMod, only: haversine, to_radian implicit none INCLUDE 'netcdf.inc' @@ -231,17 +231,6 @@ SUBROUTINE get_id_loc (NT, gfile, id_loc) END SUBROUTINE get_id_loc ! ***************************************************************************** - - function to_radian(degree) result(rad) - - ! degrees to radians - real,intent(in) :: degree - real :: rad - - rad = degree*MAPL_PI/180. - - end function to_radian - ! ------------------------------------------------------------------------------------------------- SUBROUTINE regrid_alb (NTILES, id_loc) @@ -807,29 +796,6 @@ end subroutine ReadCNTilFile ! ***************************************************************************** - real function haversine(deglat1,deglon1,deglat2,deglon2) - ! great circle distance -- adapted from Matlab - real,intent(in) :: deglat1,deglon1,deglat2,deglon2 - real :: a,c, dlat,dlon,lat1,lat2 - real,parameter :: radius = 6371.0E3 - -! dlat = to_radian(deglat2-deglat1) -! dlon = to_radian(deglon2-deglon1) - ! lat1 = to_radian(deglat1) -! lat2 = to_radian(deglat2) - dlat = deglat2-deglat1 - dlon = deglon2-deglon1 - lat1 = deglat1 - lat2 = deglat2 - a = (sin(dlat/2))**2 + cos(lat1)*cos(lat2)*(sin(dlon/2))**2 - if(a>=0. .and. a<=1.) then - c = 2*atan2(sqrt(a),sqrt(1-a)) - haversine = radius*c / 1000. - else - haversine = 1.e20 - endif - end function - ! ***************************************************************************** END MODULE comp_CATCHCN_AlbScale_parameters diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CMakeLists.txt index 75ce7bbee..320bc3430 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CMakeLists.txt +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CMakeLists.txt @@ -1,7 +1,6 @@ esma_set_this () set(srcs - getids.F90 CatchmentRst.F90 CatchmentCNRst.F90 ) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/README b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/README index 325e28cee..35eeaaa4f 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/README +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/README @@ -1,28 +1,6 @@ This directory contains software to create restarts and bcs for all tile components, not just catch. -The five restarts are created in ./OutData/ by simply -running mk_Restarts (no arguments) from the command line. -This builds the two executables, if necessary. One executable -does all the land grid files (two restarts, an lai-grn file, and -two albedo files). The other executable can be used, with appropriate -arguments (see mk_Restarts) to create the othe three restarts. - -Before running mk_Restarts you must checkout the InData and OutData -subdirectories, and place the input data there. -(see READMEs in these two directories). - -For convenience we have place copies on the MAPL hash software in -this directory, so that the restarts can be created without building -MAPL. - -The directory also contains legacy software by M Kistler that may -still be needed for Eros and for early Fortuna tags. - -On 11/23/2009 Max made changes to sense if the input restart is old (i.e., has the 2 -pairs of prev/next variables or not. By default it produces an new -restart, compatible with Fortuna-2_0 and later. By adding a 4th, optional, -argument of "OutIsOld", it will produce a valid old restart. Note that -any other string as a 4th argument, or no 4th argument will produce -the new restart. +mk_Restart script is called by regrid.pl in GMAO_Shared. Please refer regrid.pl +for the parameters that are passed to mk_Restarts diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/catchplt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/catchplt similarity index 100% rename from GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/catchplt rename to GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/catchplt diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/check_land_restarts.pro b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/check_land_restarts.pro similarity index 100% rename from GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/check_land_restarts.pro rename to GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/check_land_restarts.pro diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_catch_restart b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/mk_catch_restart similarity index 100% rename from GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_catch_restart rename to GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/mk_catch_restart diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_catch_restart.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/mk_catch_restart.F90 similarity index 100% rename from GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_catch_restart.F90 rename to GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/mk_catch_restart.F90 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_vegdyn_restart b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/mk_vegdyn_restart similarity index 100% rename from GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_vegdyn_restart rename to GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/mk_vegdyn_restart diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_vegdyn_restart.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/mk_vegdyn_restart.F90 similarity index 100% rename from GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_vegdyn_restart.F90 rename to GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/mk_vegdyn_restart.F90 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/new_catch.ctl b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/new_catch.ctl similarity index 100% rename from GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/new_catch.ctl rename to GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/new_catch.ctl diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/newcatch.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/newcatch.F90 similarity index 100% rename from GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/newcatch.F90 rename to GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/newcatch.F90 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/newvegdyn.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/newvegdyn.f90 similarity index 100% rename from GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/newvegdyn.f90 rename to GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/newvegdyn.f90 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/old_catch.ctl b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/old_catch.ctl similarity index 100% rename from GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/old_catch.ctl rename to GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/old_catch.ctl diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/replace_params.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/replace_params.F90 similarity index 100% rename from GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/replace_params.F90 rename to GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/replace_params.F90 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/strip_vegdyn.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/strip_vegdyn.F90 similarity index 100% rename from GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/strip_vegdyn.F90 rename to GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/strip_vegdyn.F90 From b67a8955868a24f3486f68bdabd55ec512dc85fc Mon Sep 17 00:00:00 2001 From: Amidu Oloso Date: Fri, 1 Jul 2022 10:27:16 -0400 Subject: [PATCH 14/17] Added timed barrier call after DO_UPDATE_PHY calls --- GEOSagcm_GridComp/GEOS_AgcmGridComp.F90 | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/GEOSagcm_GridComp/GEOS_AgcmGridComp.F90 b/GEOSagcm_GridComp/GEOS_AgcmGridComp.F90 index fb4a56992..c9cd0aa9f 100644 --- a/GEOSagcm_GridComp/GEOS_AgcmGridComp.F90 +++ b/GEOSagcm_GridComp/GEOS_AgcmGridComp.F90 @@ -1026,6 +1026,8 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_TimerAdd(GC, name="RUN" ,RC=STATUS) VERIFY_(STATUS) + call MAPL_TimerAdd(GC, name="AGCM_BARRIER" ,RC=STATUS) + VERIFY_(STATUS) ! All done !--------- @@ -1361,6 +1363,7 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) ! Local derived type aliases + type (ESMF_VM) :: VMG type (MAPL_MetaComp), pointer :: STATE type (ESMF_GridComp), pointer :: GCS(:) type (ESMF_State), pointer :: GIM(:) @@ -1554,7 +1557,7 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) ! ----------------------------------------------------------- Iam = "Run" - call ESMF_GridCompGet ( GC, name=COMP_NAME, RC=STATUS ) + call ESMF_GridCompGet ( GC, VM=VMG, name=COMP_NAME, RC=STATUS ) VERIFY_(STATUS) Iam = trim(COMP_NAME) // trim(Iam) @@ -2399,6 +2402,9 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) call DO_UPDATE_PHY ('DPEDT') call DO_UPDATE_PHY ('DTDT' ) + call MAPL_TimerOn (STATE,"AGCM_BARRIER" ) + call ESMF_VMBarrier(VMG, rc=status); VERIFY_(STATUS) + call MAPL_TimerOff(STATE,"AGCM_BARRIER" ) ! Run RUN2 of SuperDynamics (ADD_INCS) to add Physics Diabatic Tendencies !------------------------------------------------------------------------ From cb99a4e60d806561734c6a171e68fd436a7bf982 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Fri, 8 Jul 2022 16:07:02 -0400 Subject: [PATCH 15/17] Update CircleCI to use Baselibs 7.5.0 --- .circleci/config.yml | 4 ++++ .github/workflows/workflow.yml | 5 ++++- 2 files changed, 8 insertions(+), 1 deletion(-) diff --git a/.circleci/config.yml b/.circleci/config.yml index 11bd27865..6c155f647 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -1,5 +1,9 @@ version: 2.1 +# Anchors to prevent forgetting to update a version +baselibs_version: &baselibs_version v7.5.0 +bcs_version: &bcs_version v10.22.3 + orbs: ci: geos-esm/circleci-tools@1 diff --git a/.github/workflows/workflow.yml b/.github/workflows/workflow.yml index 2d4e599e5..972474ab6 100644 --- a/.github/workflows/workflow.yml +++ b/.github/workflows/workflow.yml @@ -35,10 +35,13 @@ jobs: with: access_token: ${{ github.token }} - name: Checkout GCM - uses: actions/checkout@v2 + uses: actions/checkout@v3 with: repository: GEOS-ESM/GEOSgcm fetch-depth: 1 + - name: Set all directories as git safe + run: | + git config --global --add safe.directory '*' - name: Versions etc. run: | gfortran --version From f7e2803b5e90af8fdbfa914a8b9c6c7cd6be94a8 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Fri, 8 Jul 2022 16:11:55 -0400 Subject: [PATCH 16/17] Fix the CI --- .circleci/config.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/.circleci/config.yml b/.circleci/config.yml index 6c155f647..f3eeea071 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -18,6 +18,7 @@ workflows: matrix: parameters: compiler: [gfortran, ifort] + baselibs_version: *baselibs_version repo: GEOSgcm checkout_fixture: true mepodevelop: true From c3914725961798af9e19ce60513a504a5408791c Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Fri, 8 Jul 2022 16:12:59 -0400 Subject: [PATCH 17/17] Fix GitHub CI --- .github/workflows/workflow.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/workflow.yml b/.github/workflows/workflow.yml index 972474ab6..7a4871936 100644 --- a/.github/workflows/workflow.yml +++ b/.github/workflows/workflow.yml @@ -17,7 +17,7 @@ jobs: if: "!contains(github.event.pull_request.labels.*.name, '0 diff trivial')" runs-on: ubuntu-latest container: - image: gmao/ubuntu20-geos-env-mkl:v6.2.13-openmpi_4.1.2-gcc_11.2.0 + image: gmao/ubuntu20-geos-env-mkl:v7.5.0-openmpi_4.1.2-gcc_11.2.0 credentials: username: ${{ secrets.DOCKERHUB_USERNAME }} password: ${{ secrets.DOCKERHUB_TOKEN }}