diff --git a/Externals.cfg b/Externals.cfg index 9a1a53dd6..34c8b199b 100644 --- a/Externals.cfg +++ b/Externals.cfg @@ -2,7 +2,7 @@ required = True repo_url = git@github.com:GEOS-ESM/GEOSchem_GridComp.git local_path = ./GEOSagcm_GridComp/GEOSphysics_GridComp/@GEOSchem_GridComp -tag = v1.0.0 +tag = v1.0.1 protocol = git [mom] diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/mk_restarts/mk_CatchCNRestarts.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/mk_restarts/mk_CatchCNRestarts.F90 index 7dfcae7c0..ff5a71fae 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/mk_restarts/mk_CatchCNRestarts.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/mk_restarts/mk_CatchCNRestarts.F90 @@ -231,8 +231,8 @@ program mk_CatchCNRestarts integer, parameter :: ntiles_cn = 1684725 character(len=300), parameter :: & - InCNRestart = '/gpfsm/dnb42/projects/p16/ssd/land/l_data/LandRestarts_for_Regridding/CatchCN/M09/20151231/catchcn_internal_rst', & - InCNTilFile = '/discover/nobackup/ltakacs/bcs/Heracles-NL/SMAP_EASEv2_M09/SMAP_EASEv2_M09_3856x1624.til' + InCNRestart = '/discover/nobackup/rreichle/l_data/LandRestarts_for_Regridding/CatchCN/M09/20151231/catchcn_internal_rst', & + InCNTilFile = '/discover/nobackup/ltakacs/bcs/Icarus-NLv2/Icarus-NLv2_EASE/SMAP_EASEv2_M09/SMAP_EASEv2_M09_3856x1624.til' character(len=256), parameter :: CatNames (57) = & (/'BF1 ','BF2 ','BF3 ','VGWMAX ','CDCR1 ', & @@ -607,7 +607,9 @@ SUBROUTINE read_bcs_data (ntiles, SURFLAY, OutNCIO, InRestart) character*256 :: DataDir="OutData/clsm/" integer :: idum, i,j,n, ib, nv real :: rdum, zdep1, zdep2, zdep3, zmet, term1, term2, bare,fvg(4) - + logical :: file_exists + type(MAPL_NCIO) :: NCIOCatch, NCIOCatchCN + allocate ( BF1(ntiles), BF2 (ntiles), BF3(ntiles) ) allocate (VGWMAX(ntiles), CDCR1(ntiles), CDCR2(ntiles) ) allocate ( PSIS(ntiles), BEE(ntiles), POROS(ntiles) ) @@ -625,53 +627,130 @@ SUBROUTINE read_bcs_data (ntiles, SURFLAY, OutNCIO, InRestart) allocate (CLMC_sf2(ntiles), CLMC_pt1(ntiles), CLMC_pt2(ntiles)) allocate (CLMC_st1(ntiles), CLMC_st2(ntiles)) - open(unit=22, & - file=trim(DataDir)//"mosaic_veg_typs_fracs",status='old',form='formatted') - - do N=1,ntiles - read(22,*) I, j, ITY(N),idum, rdum, rdum, CanopH(N) - enddo - - rity(:) = float(ity) - - close(22) - - 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=27, file=trim(DataDir)//'CLM_veg_typs_fracs' ,form='formatted') - open(unit=28, file=trim(DataDir)//'CLM_NDep_SoilAlb_T2m' ,form='formatted') - - do n=1,ntiles - read (22, *) i,j, GNU(n), BF1(n), BF2(n), BF3(n) - - read (23, *) i,j, idum, idum, BEE(n), PSIS(n),& - POROS(n), COND(n), WPWET(n), DP2BR(n) - - read (24, *) i,j, rdum, ARS1(n), ARS2(n), ARS3(n), & - ARA1(n), ARA2(n), ARA3(n), ARA4(n), & - ARW1(n), ARW2(n), ARW3(n), ARW4(n) - - read (25, *) i,j, rdum, TSA1(n), TSA2(n), TSB1(n), TSB2(n) - - if( SURFLAY.eq.20.0 ) read (26, *) i,j, ATAU2(n), BTAU2(n), rdum, rdum ! for old soil params - if( SURFLAY.eq.50.0 ) read (26, *) i,j, rdum , rdum, ATAU2(n), BTAU2(n) ! for new soil params - - read (27, *) 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 (28, *) NDEP(n), BVISDR(n), BVISDF(n), BNIRDR(n), BNIRDF(n), T2(n) ! MERRA-2 Annual Mean Temp is default. - - 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)) + inquire(file = trim(DataDir)//'/catchcn_params.nc4', exist=file_exists) + + if(file_exists) then + + print *,'FILE FORMAT FOR LAND BCS IS NC4' + NCIOCatch = MAPL_NCIOOpen(trim(DataDir)//'/catch_params.nc4',rc=rc) + NCIOCatchCN = MAPL_NCIOOpen(trim(DataDir)//'/catchcn_params.nc4',rc=rc) + call MAPL_VarRead ( NCIOCatch ,'OLD_ITY', rity) + call MAPL_VarRead ( NCIOCatch ,'ARA1', ARA1) + call MAPL_VarRead ( NCIOCatch ,'ARA2', ARA2) + call MAPL_VarRead ( NCIOCatch ,'ARA3', ARA3) + call MAPL_VarRead ( NCIOCatch ,'ARA4', ARA4) + call MAPL_VarRead ( NCIOCatch ,'ARS1', ARS1) + call MAPL_VarRead ( NCIOCatch ,'ARS2', ARS2) + call MAPL_VarRead ( NCIOCatch ,'ARS3', ARS3) + call MAPL_VarRead ( NCIOCatch ,'ARW1', ARW1) + call MAPL_VarRead ( NCIOCatch ,'ARW2', ARW2) + call MAPL_VarRead ( NCIOCatch ,'ARW3', ARW3) + call MAPL_VarRead ( NCIOCatch ,'ARW4', ARW4) + + if( SURFLAY.eq.20.0 ) then + call MAPL_VarRead ( NCIOCatch ,'ATAU2', ATAU2) + call MAPL_VarRead ( NCIOCatch ,'BTAU2', BTAU2) + endif - zdep2=1000. - zdep3=amax1(1000.,DP2BR(n)) - + if( SURFLAY.eq.50.0 ) then + call MAPL_VarRead ( NCIOCatch ,'ATAU5', ATAU2) + call MAPL_VarRead ( NCIOCatch ,'BTAU5', BTAU2) + endif + + call MAPL_VarRead ( NCIOCatch ,'PSIS', PSIS) + call MAPL_VarRead ( NCIOCatch ,'BEE', BEE) + call MAPL_VarRead ( NCIOCatch ,'BF1', BF1) + call MAPL_VarRead ( NCIOCatch ,'BF2', BF2) + call MAPL_VarRead ( NCIOCatch ,'BF3', BF3) + call MAPL_VarRead ( NCIOCatch ,'TSA1', TSA1) + call MAPL_VarRead ( NCIOCatch ,'TSA2', TSA2) + call MAPL_VarRead ( NCIOCatch ,'TSB1', TSB1) + call MAPL_VarRead ( NCIOCatch ,'TSB2', TSB2) + call MAPL_VarRead ( NCIOCatch ,'COND', COND) + call MAPL_VarRead ( NCIOCatch ,'GNU', GNU) + call MAPL_VarRead ( NCIOCatch ,'WPWET', WPWET) + call MAPL_VarRead ( NCIOCatch ,'DP2BR', DP2BR) + call MAPL_VarRead ( NCIOCatch ,'POROS', POROS) + call MAPL_VarRead ( NCIOCatchCN ,'BGALBNF', BNIRDF) + call MAPL_VarRead ( NCIOCatchCN ,'BGALBNR', BNIRDR) + call MAPL_VarRead ( NCIOCatchCN ,'BGALBVF', BVISDF) + call MAPL_VarRead ( NCIOCatchCN ,'BGALBVR', BVISDR) + call MAPL_VarRead ( NCIOCatchCN ,'NDEP', NDEP) + call MAPL_VarRead ( NCIOCatchCN ,'T2_M', T2) + call MAPL_VarRead(NCIOCatchCN,'ITY',CLMC_pt1,offset1=1) ! 30 + call MAPL_VarRead(NCIOCatchCN,'ITY',CLMC_pt2,offset1=2) ! 31 + call MAPL_VarRead(NCIOCatchCN,'ITY',CLMC_st1,offset1=3) ! 32 + call MAPL_VarRead(NCIOCatchCN,'ITY',CLMC_st2,offset1=4) ! 33 + call MAPL_VarRead(NCIOCatchCN,'FVG',CLMC_pf1,offset1=1) ! 34 + call MAPL_VarRead(NCIOCatchCN,'FVG',CLMC_pf2,offset1=2) ! 35 + call MAPL_VarRead(NCIOCatchCN,'FVG',CLMC_sf1,offset1=3) ! 36 + call MAPL_VarRead(NCIOCatchCN,'FVG',CLMC_sf2,offset1=4) ! 37 + call MAPL_NCIOClose (NCIOCatch ) + call MAPL_NCIOClose (NCIOCatchCN) + + else + + open(unit=22, & + file=trim(DataDir)//"mosaic_veg_typs_fracs",status='old',form='formatted') + + do N=1,ntiles + read(22,*) I, j, ITY(N),idum, rdum, rdum, CanopH(N) + enddo + + rity(:) = float(ity) + + close(22) + + 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=27, file=trim(DataDir)//'CLM_veg_typs_fracs' ,form='formatted') + open(unit=28, file=trim(DataDir)//'CLM_NDep_SoilAlb_T2m' ,form='formatted') + + do n=1,ntiles + read (22, *) i,j, GNU(n), BF1(n), BF2(n), BF3(n) + + read (23, *) i,j, idum, idum, BEE(n), PSIS(n),& + POROS(n), COND(n), WPWET(n), DP2BR(n) + + read (24, *) i,j, rdum, ARS1(n), ARS2(n), ARS3(n), & + ARA1(n), ARA2(n), ARA3(n), ARA4(n), & + ARW1(n), ARW2(n), ARW3(n), ARW4(n) + + read (25, *) i,j, rdum, TSA1(n), TSA2(n), TSB1(n), TSB2(n) + + if( SURFLAY.eq.20.0 ) read (26, *) i,j, ATAU2(n), BTAU2(n), rdum, rdum ! for old soil params + if( SURFLAY.eq.50.0 ) read (26, *) i,j, rdum , rdum, ATAU2(n), BTAU2(n) ! for new soil params + + read (27, *) 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 (28, *) NDEP(n), BVISDR(n), BVISDF(n), BNIRDR(n), BNIRDF(n), T2(n) ! MERRA-2 Annual Mean Temp is default. + + end do + + CLOSE (22, STATUS = 'KEEP') + CLOSE (23, STATUS = 'KEEP') + CLOSE (24, STATUS = 'KEEP') + CLOSE (25, STATUS = 'KEEP') + CLOSE (26, STATUS = 'KEEP') + CLOSE (27, STATUS = 'KEEP') + CLOSE (28, 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)) + + zdep2=1000. + zdep3=amax1(1000.,DP2BR(n)) + if (zdep2 .gt.0.75*zdep3) then zdep2 = 0.75*zdep3 end if @@ -758,13 +837,7 @@ SUBROUTINE read_bcs_data (ntiles, SURFLAY, OutNCIO, InRestart) endif end do - CLOSE (22, STATUS = 'KEEP') - CLOSE (23, STATUS = 'KEEP') - CLOSE (24, STATUS = 'KEEP') - CLOSE (25, STATUS = 'KEEP') - CLOSE (26, STATUS = 'KEEP') - CLOSE (27, STATUS = 'KEEP') - CLOSE (28, STATUS = 'KEEP') + ! Now writing BCs (from BCSDIR) and regridded hydrological variables 1-72 ! ----------------------------------------------------------------------- diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/mk_restarts/mk_CatchRestarts.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/mk_restarts/mk_CatchRestarts.F90 index 7884918ef..c82043f08 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/mk_restarts/mk_CatchRestarts.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/mk_restarts/mk_CatchRestarts.F90 @@ -33,7 +33,7 @@ program mk_CatchRestarts real, allocatable :: ARA1(:), ARA2(:), ARA3(:), ARA4(:) real, allocatable :: ARW1(:), ARW2(:), ARW3(:), ARW4(:) real, allocatable :: TSA1(:), TSA2(:), TSB1(:), TSB2(:) - real, allocatable :: ATAU2(:), BTAU2(:), DP2BR(:), rity(:), CanopH(:) + real, allocatable :: ATAU2(:), BTAU2(:), DP2BR(:), rity(:) real :: zdep1, zdep2, zdep3, zmet, term1, term2, rdum real, allocatable :: var1(:),var2(:,:) @@ -56,6 +56,8 @@ program mk_CatchRestarts logical,allocatable :: written(:) integer :: ndims,filetype integer :: dimSizes(3),nVars + logical :: file_exists + type(MAPL_NCIO) :: NCIOCatch !--------------------------------------------------------------------------- @@ -146,16 +148,6 @@ program mk_CatchRestarts call GetIds(loni,lati,lono,lato,Id) - - open(30,file="OutData/visdf.dat", status="unknown", & - form="unformatted",convert="little_endian") - - open(31,file="OutData/nirdf.dat", status="unknown", & - form="unformatted",convert="little_endian") - - open(32,file="OutData/laigrn.data", status="unknown", & - form="unformatted",convert="little_endian") - HAVE: if(havedata) then print *,'Working from Sariths data pretiled for this resolution' @@ -163,16 +155,10 @@ program mk_CatchRestarts ! Get number of catchments open(unit=22, & - file=trim(DataDir)//"mosaic_veg_typs_fracs",status='old',form='formatted') + file=trim(DataDir)//"catchment.def",status='old',form='formatted') -! DSK c2880 grid has 14455675 land tiles - do i=1,16000000 - read(22,*,end=300) - enddo - -300 continue + read (22, *) ncatch - ncatch = i-1 close(22) if(ncatch==size(ido)) then @@ -185,25 +171,7 @@ program mk_CatchRestarts call exit(1) endif -! Read veg type data - - allocate(ity(ncatch),rity(ncatch), CanopH(ncatch)) - - open(unit=22, & - file=trim(DataDir)//"mosaic_veg_typs_fracs",status='old',form='formatted') - - do N=1,ncatch - if (NewLand) then - read(22,*) I, j, ITY(N),idum, rdum, rdum, CanopH(N) - else - read(22,*) I, j, ITY(N),idum, rdum, rdum - endif - enddo - - rity = float(ity) - - close(22) - + allocate(ity(ncatch),rity(ncatch)) allocate ( BF1(ncatch), BF2 (ncatch), BF3(ncatch) ) allocate (VGWMAX(ncatch), CDCR1(ncatch), CDCR2(ncatch) ) allocate ( PSIS(ncatch), BEE(ncatch), POROS(ncatch) ) @@ -215,102 +183,89 @@ program mk_CatchRestarts allocate ( TSA2(ncatch), TSB1(ncatch), TSB2(ncatch) ) allocate ( ATAU2(ncatch), BTAU2(ncatch), DP2BR(ncatch) ) -! allocate( alb(ncatch,12)) - -! open(unit=20, & -! file=trim(DataDir)//"modis_scale_factor.albvf.clim",status='old',form='unformatted',convert='big_endian') - -! do k=1,12 -! read(20) alb(:,k) -! end do - -! do K=0,13 -! yr = (k+11)/12 -! mn = mod(k+11,12)+1 -! yr1= (k+12)/12 -! mn1= mod(k+12,12)+1 -! write(30) float((/yr,mn,1,0,0,0,yr1,mn1,1,0,0,0,ncatch,1/)) -! write(30) alb(Ido,mod(k+11,12)+1) -! end do - -! close(20) -! close(30) - - -! open(unit=20, & -! file=trim(DataDir)//"modis_scale_factor.albnf.clim",status='old',form='unformatted',convert='big_endian') - -! do k=1,12 -! read(20) alb(:,k) -! end do - -! do K=0,13 -! yr = (k+11)/12 -! mn = mod(k+11,12)+1 -! yr1= (k+12)/12 -! mn1= mod(k+12,12)+1 -! write(31) float((/yr,mn,1,0,0,0,yr1,mn1,1,0,0,0,ncatch,1/)) -! write(31) alb(Ido,mod(k+11,12)+1) -! end do - -! close(20) -! close(31) - - -! deallocate(alb) - - - - -! Lai and greeness dataset - -! allocate( lai(ncatch), grn(ncatch)) - -! open(unit=20, & -! file=trim(DataDir)//"lai.dat",status='old',form='unformatted',convert='big_endian') -! open(unit=21, & -! file=trim(DataDir)//"green.dat",status='old',form='unformatted',convert='big_endian') - -! do k=1,12 -! read(20) lai -! read(21) grn -! write(32) lai(ido) -! write(32) grn(ido) -! end do - -! deallocate(lai,grn) - -! close(20) -! close(21) -! close(32) + inquire(file = trim(DataDir)//'/catch_params.nc4', exist=file_exists) + + if(file_exists) then + print *,'FILE FORMAT FOR LAND BCS IS NC4' + NCIOCatch = MAPL_NCIOOpen(trim(DataDir)//'/catch_params.nc4',rc=rc) + call MAPL_VarRead ( NCIOCatch ,'OLD_ITY', rity) + call MAPL_VarRead ( NCIOCatch ,'ARA1', ARA1) + call MAPL_VarRead ( NCIOCatch ,'ARA2', ARA2) + call MAPL_VarRead ( NCIOCatch ,'ARA3', ARA3) + call MAPL_VarRead ( NCIOCatch ,'ARA4', ARA4) + call MAPL_VarRead ( NCIOCatch ,'ARS1', ARS1) + call MAPL_VarRead ( NCIOCatch ,'ARS2', ARS2) + call MAPL_VarRead ( NCIOCatch ,'ARS3', ARS3) + call MAPL_VarRead ( NCIOCatch ,'ARW1', ARW1) + call MAPL_VarRead ( NCIOCatch ,'ARW2', ARW2) + call MAPL_VarRead ( NCIOCatch ,'ARW3', ARW3) + call MAPL_VarRead ( NCIOCatch ,'ARW4', ARW4) + + if( SURFLAY.eq.20.0 ) then + call MAPL_VarRead ( NCIOCatch ,'ATAU2', ATAU2) + call MAPL_VarRead ( NCIOCatch ,'BTAU2', BTAU2) + endif + + if( SURFLAY.eq.50.0 ) then + call MAPL_VarRead ( NCIOCatch ,'ATAU5', ATAU2) + call MAPL_VarRead ( NCIOCatch ,'BTAU5', BTAU2) + endif + + call MAPL_VarRead ( NCIOCatch ,'PSIS', PSIS) + call MAPL_VarRead ( NCIOCatch ,'BEE', BEE) + call MAPL_VarRead ( NCIOCatch ,'BF1', BF1) + call MAPL_VarRead ( NCIOCatch ,'BF2', BF2) + call MAPL_VarRead ( NCIOCatch ,'BF3', BF3) + call MAPL_VarRead ( NCIOCatch ,'TSA1', TSA1) + call MAPL_VarRead ( NCIOCatch ,'TSA2', TSA2) + call MAPL_VarRead ( NCIOCatch ,'TSB1', TSB1) + call MAPL_VarRead ( NCIOCatch ,'TSB2', TSB2) + call MAPL_VarRead ( NCIOCatch ,'COND', COND) + call MAPL_VarRead ( NCIOCatch ,'GNU', GNU) + call MAPL_VarRead ( NCIOCatch ,'WPWET', WPWET) + call MAPL_VarRead ( NCIOCatch ,'DP2BR', DP2BR) + call MAPL_VarRead ( NCIOCatch ,'POROS', POROS) + call MAPL_NCIOClose (NCIOCatch ) + else + open(unit=21, file=trim(DataDir)//"mosaic_veg_typs_fracs",status='old',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,ncatch + read (21,*) I, j, ITY(N) + read (22, *) i,j, GNU(n), BF1(n), BF2(n), BF3(n) + + read (23, *) i,j, idum, idum, BEE(n), PSIS(n),& + POROS(n), COND(n), WPWET(n), DP2BR(n) + + read (24, *) i,j, rdum, ARS1(n), ARS2(n), ARS3(n), & + ARA1(n), ARA2(n), ARA3(n), ARA4(n), & + ARW1(n), ARW2(n), ARW3(n), ARW4(n) + + read (25, *) i,j, rdum, TSA1(n), TSA2(n), TSB1(n), TSB2(n) + + if( SURFLAY.eq.20.0 ) read (26, *) i,j, ATAU2(n), BTAU2(n), rdum, rdum ! for old soil params + if( SURFLAY.eq.50.0 ) read (26, *) i,j, rdum , rdum, ATAU2(n), BTAU2(n) ! for new soil params + end do -! print *, "Wrote lai grn climatology" + rity = float(ity) + CLOSE (21, STATUS = 'KEEP') + CLOSE (22, STATUS = 'KEEP') + CLOSE (23, STATUS = 'KEEP') + CLOSE (24, STATUS = 'KEEP') + CLOSE (25, STATUS = 'KEEP') - 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') + endif do n=1,ncatch - read (22, *) i,j, GNU(n), BF1(n), BF2(n), BF3(n) - - read (23, *) i,j, idum, idum, BEE(n), PSIS(n),& - POROS(n), COND(n), WPWET(n), DP2BR(n) - - read (24, *) i,j, rdum, ARS1(n), ARS2(n), ARS3(n), & - ARA1(n), ARA2(n), ARA3(n), ARA4(n), & - ARW1(n), ARW2(n), ARW3(n), ARW4(n) - - read (25, *) i,j, rdum, TSA1(n), TSA2(n), TSB1(n), TSB2(n) - - if( SURFLAY.eq.20.0 ) read (26, *) i,j, ATAU2(n), BTAU2(n), rdum, rdum ! for old soil params - if( SURFLAY.eq.50.0 ) read (26, *) i,j, rdum , rdum, ATAU2(n), BTAU2(n) ! for new soil params - + zdep2=1000. zdep3=amax1(1000.,DP2BR(n)) - if (zdep2 .gt.0.75*zdep3) then + if (zdep2 > 0.75*zdep3) then zdep2 = 0.75*zdep3 end if @@ -325,7 +280,8 @@ program mk_CatchRestarts CDCR2(n) = (1.-WPWET(n))*POROS(n)*zdep3 enddo - if (filetype /=0) then + + if (filetype /=0) then do i=1,30 read(50) enddo @@ -339,47 +295,7 @@ program mk_CatchRestarts ncatch = size(pfi) - -! open(60,file=trim(DataDir)//'visdf.dat', status="unknown", & -! form="unformatted",convert="little_endian") - -! open(61,file=trim(DataDir)//'nirdf.dat', status="unknown", & -! form="unformatted",convert="little_endian") - -! open(62,file=trim(DataDir)//'lai_grn_clim', status="unknown", & -! form="unformatted",convert="little_endian") - - -! allocate( alb(ncatch,1)) - -! do K=0,13 -! read(60) timestamp -! read(60) alb -! write(30) timestamp -! write(30) alb(Id,1) -! end do - -! do K=0,13 -! read(61) timestamp -! read(61) alb -! write(31) timestamp -! write(31) alb(Id,1) -! end do - -! deallocate(alb) -! allocate( lai(ncatch), grn(ncatch)) - - -! do k=1,12 -! read(62) lai -! read(62) grn -! write(32) lai(id) -! write(32) grn(id) -! end do - -! deallocate(lai,grn) - - allocate( rity(ncatch), CanopH(ncatch)) + allocate( rity(ncatch)) allocate( BF1(ncatch), BF2 (ncatch), BF3(ncatch) ) allocate (VGWMAX(ncatch), CDCR1(ncatch), CDCR2(ncatch) ) allocate ( PSIS(ncatch), BEE(ncatch), POROS(ncatch) ) @@ -391,8 +307,6 @@ program mk_CatchRestarts allocate ( TSA2(ncatch), TSB1(ncatch), TSB2(ncatch) ) allocate ( ATAU2(ncatch), BTAU2(ncatch), DP2BR(ncatch) ) - CanopH = 0. - if (filetype == 0) then call MAPL_VarRead(InNCIO,names(1),BF1) @@ -469,17 +383,6 @@ program mk_CatchRestarts endif HAVE - -! Vegdyn Boundary Condition -! ------------------------- - open(20,file=trim("OutData/vegdyn_internal_rst"), & - status="unknown", & - form="unformatted",convert="little_endian") - write(20) rity(Idx) - if(NewLand) write(20) CanopH(Idx) - close(20) - print *, "Wrote vegdyn_internal_restart" - if (filetype == 0) then call MAPL_VarWrite(OutNCIO,names(1),BF1(Idx)) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/mk_restarts/mk_LDASsaRestarts.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/mk_restarts/mk_LDASsaRestarts.F90 index 069e42ed4..30c99514c 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/mk_restarts/mk_LDASsaRestarts.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/mk_restarts/mk_LDASsaRestarts.F90 @@ -31,7 +31,7 @@ PROGRAM mk_LDASsaRestarts ! Carbon model specifics ! ---------------------- - character*256 :: Usage="mk_LDASsaRestarts -a SPONSORCODE -b BCSDIR -d YYYYMMDD -e EXPNAME -j JOBFILE -l EXPDIR -m MODEL -r REORDER -s SURFLAY -t TILFILE" + character*256 :: Usage="mk_LDASsaRestarts -a SPONSORCODE -b BCSDIR -d YYYYMMDD -e EXPNAME -j JOBFILE -k ENS -l EXPDIR -m MODEL -r REORDER -s SURFLAY -t TILFILE" character*256 :: BCSDIR, SPONSORCODE, EXPNAME, EXPDIR, MODEL, TILFILE, YYYYMMDD, SFL character*400 :: CMD @@ -54,6 +54,7 @@ PROGRAM mk_LDASsaRestarts integer, parameter :: OutUnit = 40, InUnit = 50 character*256 :: arg, tmpstring, ESMADIR character*1 :: opt, REORDER='N', JOBFILE ='N' + character*4 :: ENS='0000' integer :: ntiles, rc, nxt character(len=300) :: OutFileName @@ -151,6 +152,8 @@ PROGRAM mk_LDASsaRestarts stop case ('j') JOBFILE = trim(arg) + case ('k') + ENS = trim(arg) case ('l') EXPDIR = trim(arg) case ('m') @@ -183,7 +186,7 @@ PROGRAM mk_LDASsaRestarts ! This call is to reorder a LDASsa restart file - call reorder_LDASsa_restarts (SURFLAY, BCSDIR, YYYYMMDD, EXPNAME, EXPDIR, MODEL) + call reorder_LDASsa_restarts (SURFLAY, BCSDIR, YYYYMMDD, EXPNAME, EXPDIR, MODEL, ENS) stop @@ -275,18 +278,39 @@ PROGRAM mk_LDASsaRestarts ! ***************************************************************************** - SUBROUTINE reorder_LDASsa_restarts (SURFLAY, BCSDIR, YYYYMMDD, EXPNAME, EXPDIR, MODEL) + SUBROUTINE reorder_LDASsa_restarts (SURFLAY, BCSDIR, YYYYMMDD, EXPNAME, EXPDIR, MODEL, ENS) implicit none real, intent (in) :: SURFLAY - character(*), intent (in) :: BCSDIR, YYYYMMDD, EXPNAME, EXPDIR, MODEL + character(*), intent (in) :: BCSDIR, YYYYMMDD, EXPNAME, EXPDIR, MODEL, ENS character(256) :: tile_coord, vname - character(300) :: rst_file + character(300) :: rst_file, out_rst_file type(MAPL_NCIO) :: InNCIO, OutNCIO integer :: NTILES, nVars, i,j,k,n, ndims,dimSizes(3) integer, allocatable :: LDAS2BCS (:), g2d(:), tile_id(:) real, allocatable :: var1(:), var2(:),wesn1(:), htsn1(:) + logical :: fexist, bin_out = .false. + + if(trim(MODEL) == 'CATCH') then + rst_file = trim(EXPDIR)//'rs/ens'//ENS//'/Y'//YYYYMMDD(1:4)//'/M'//YYYYMMDD(5:6)//'/' & + //trim(ExpName)//'.ens'//ENS//'.catch_ldas_rst.'// & + YYYYMMDD(1:8)//'_0000z.bin' + out_rst_file = 'catch'//ENS//'_internal_rst.'//trim(YYYYMMDD) + else + rst_file = trim(EXPDIR)//'rs/ens'//ENS//'/Y'//YYYYMMDD(1:4)//'/M'//YYYYMMDD(5:6)//'/'//trim(ExpName)//& + '.ens'//ENS//'.catchcn_ldas_rst.'//trim(YYYYMMDD)//'_0000z' + out_rst_file = 'catchcn'//ENS//'_internal_rst.'//trim(YYYYMMDD) + endif + + inquire(file = trim(rst_file), exist=fexist) + if (.not. fexist) then + print*, "WARNING!!" + print*, rst_file // "does not exsit" + print*, "MAY USE ENS0000 only!!" + return + endif + open (10,file =trim(BCSDIR)//"clsm/catchment.def",status='old',form='formatted') read (10,*) ntiles @@ -310,8 +334,8 @@ SUBROUTINE reorder_LDASsa_restarts (SURFLAY, BCSDIR, YYYYMMDD, EXPNAME, EXPDIR, call MAPL_NCIOGetDimSizes(InNCIO,nVars=nVars) call MAPL_NCIOChangeRes(InNCIO,OutNCIO,tileSize=ntiles,rc=rc) - if(trim(MODEL) == 'CATCH' ) call MAPL_NCIOSet( OutNCIO,filename='catch_internal_rst.'//trim(YYYYMMDD)) - if(trim(MODEL) == 'CATCHCN') call MAPL_NCIOSet( OutNCIO,filename='catchcn_internal_rst.'//trim(YYYYMMDD)) + call MAPL_NCIOSet( OutNCIO,filename=trim(out_rst_file)) + call MAPL_NCIOCreateFile(OutNCIO) call MAPL_NCIOClose ( InNCIO) @@ -356,9 +380,6 @@ SUBROUTINE reorder_LDASsa_restarts (SURFLAY, BCSDIR, YYYYMMDD, EXPNAME, EXPDIR, end do if(trim(MODEL) == 'CATCH') then - rst_file = trim(EXPDIR)//'rs/ens0000/Y'//YYYYMMDD(1:4)//'/M'//YYYYMMDD(5:6)//'/' & - //trim(ExpName)//'.ens0000.catch_ldas_rst.'// & - YYYYMMDD(1:8)//'_0000z.bin' open(10, file=trim(rst_file), form='unformatted', status='old', & convert='big_endian', action='read') @@ -531,21 +552,17 @@ SUBROUTINE reorder_LDASsa_restarts (SURFLAY, BCSDIR, YYYYMMDD, EXPNAME, EXPDIR, call MAPL_VarWrite(OutNCIO,'TC' ,var2, offset1=4) deallocate (var1, var2) call MAPL_NCIOClose (OutNCIO) - - call read_bcs_data (ntiles, SURFLAY, trim(MODEL), trim(BCSDIR)//'/clsm/','catch_internal_rst.'//trim(YYYYMMDD)) + close(10) else - - rst_file = trim(EXPDIR)//'rs/ens0000/Y'//YYYYMMDD(1:4)//'/M'//YYYYMMDD(5:6)//'/'//trim(ExpName)//& - '.ens0000.catchcn_ldas_rst.'//trim(YYYYMMDD)//'_0000z' - - InNCIO = MAPL_NCIOOpen(trim(rst_file), rc=rc) - call MAPL_NCIOGetDimSizes(InNCIO,nVars=nVars) - call MAPL_VarRead ( InNCIO,'TILE_ID',var1) - if(sum (nint(var1) - LDAS2BCS) /= 0) then + + InNCIO = MAPL_NCIOOpen(trim(rst_file), rc=rc) + call MAPL_NCIOGetDimSizes(InNCIO,nVars=nVars) + call MAPL_VarRead ( InNCIO,'TILE_ID',var1) + if(sum (nint(var1) - LDAS2BCS) /= 0) then print *, 'Tile order mismatch ', sum(var1)/ntiles, sum(LDAS2BCS)/ntiles stop - endif + endif do k=1,nVars @@ -614,8 +631,14 @@ SUBROUTINE reorder_LDASsa_restarts (SURFLAY, BCSDIR, YYYYMMDD, EXPNAME, EXPDIR, call MAPL_NCIOClose (InNCIO) call MAPL_NCIOClose (OutNCIO) - call read_bcs_data (ntiles, SURFLAY, trim(MODEL), trim(BCSDIR)//'/clsm/','catchcn_internal_rst.'//trim(YYYYMMDD)) - + endif + + call read_bcs_data (ntiles, SURFLAY, trim(MODEL), trim(BCSDIR)//'/clsm/',trim(out_rst_file)) + + if(bin_out) then + OutNCIO = MAPL_NCIOOpen(trim(out_rst_file)) + open(unit=30, file=trim(out_rst_file)//'.bin', form='unformatted') + call write_bin (30, OutNCIO, NTILES) endif END SUBROUTINE reorder_LDASsa_restarts @@ -856,12 +879,14 @@ SUBROUTINE read_bcs_data (ntiles, SURFLAY,MODEL, DataDir, InRestart) real, allocatable :: TSA1(:), TSA2(:), TSB1(:), TSB2(:) real, allocatable :: ATAU2(:), BTAU2(:), DP2BR(:), CanopH(:) real, allocatable :: NDEP(:), BVISDR(:), BVISDF(:), BNIRDR(:), BNIRDF(:) - real, allocatable :: T2(:), var1(:), hdm(:), fc(:), gdp(:), peatf(:) + real, allocatable :: T2(:), var1(:), hdm(:), fc(:), gdp(:), peatf(:), RITY(:) integer, allocatable :: ity(:), abm (:) integer :: NCFID, 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(MAPL_NCIO) :: NCIOCatch, NCIOCatchCN allocate ( BF1(ntiles), BF2 (ntiles), BF3(ntiles) ) allocate (VGWMAX(ntiles), CDCR1(ntiles), CDCR2(ntiles) ) @@ -875,7 +900,7 @@ SUBROUTINE read_bcs_data (ntiles, SURFLAY,MODEL, DataDir, InRestart) allocate ( ATAU2(ntiles), BTAU2(ntiles), DP2BR(ntiles) ) allocate (BVISDR(ntiles), BVISDF(ntiles), BNIRDR(ntiles) ) allocate (BNIRDF(ntiles), T2(ntiles), NDEP(ntiles) ) - allocate ( ity(ntiles), CanopH(ntiles)) + allocate ( ity(ntiles), CanopH(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)) @@ -883,63 +908,146 @@ SUBROUTINE read_bcs_data (ntiles, SURFLAY,MODEL, DataDir, InRestart) 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)//"CLM_veg_typs_fracs" ,exist=NewLand ) - - 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') - - if(NewLand) then - open(unit=27, file=trim(DataDir)//'CLM_veg_typs_fracs' ,form='formatted') - open(unit=28, file=trim(DataDir)//'CLM_NDep_SoilAlb_T2m' ,form='formatted') - if(clm45) then - open(unit=29, file=trim(DataDir)//'CLM4.5_veg_typs_fracs',form='formatted') - open(unit=30, file=trim(DataDir)//'CLM4.5_abm_peatf_gdp_hdm_fc' ,form='formatted') + allocate (peatf(ntiles), abm(ntiles), var1(ntiles), RITY(ntiles)) + + inquire(file = trim(DataDir)//'/catchcn_params.nc4', exist=file_exists) + inquire(file = trim(DataDir)//"CLM_veg_typs_fracs" ,exist=NewLand ) + + if(file_exists) then + + print *,'FILE FORMAT FOR LAND BCS IS NC4' + NCIOCatch = MAPL_NCIOOpen(trim(DataDir)//'/catch_params.nc4',rc=rc) + NCIOCatchCN = MAPL_NCIOOpen(trim(DataDir)//'/catchcn_params.nc4',rc=rc) + call MAPL_VarRead ( NCIOCatch ,'OLD_ITY', RITY) + ITY = NINT (RITY) + call MAPL_VarRead ( NCIOCatch ,'ARA1', ARA1) + call MAPL_VarRead ( NCIOCatch ,'ARA2', ARA2) + call MAPL_VarRead ( NCIOCatch ,'ARA3', ARA3) + call MAPL_VarRead ( NCIOCatch ,'ARA4', ARA4) + call MAPL_VarRead ( NCIOCatch ,'ARS1', ARS1) + call MAPL_VarRead ( NCIOCatch ,'ARS2', ARS2) + call MAPL_VarRead ( NCIOCatch ,'ARS3', ARS3) + call MAPL_VarRead ( NCIOCatch ,'ARW1', ARW1) + call MAPL_VarRead ( NCIOCatch ,'ARW2', ARW2) + call MAPL_VarRead ( NCIOCatch ,'ARW3', ARW3) + call MAPL_VarRead ( NCIOCatch ,'ARW4', ARW4) + + if( SURFLAY.eq.20.0 ) then + call MAPL_VarRead ( NCIOCatch ,'ATAU2', ATAU2) + call MAPL_VarRead ( NCIOCatch ,'BTAU2', BTAU2) endif - endif - do n=1,ntiles - var1 (n) = real (n) - - if (NewLand) then - read(21,*) I, j, ITY(N),idum, rdum, rdum, CanopH(N) - else - read(21,*) I, j, ITY(N),idum, rdum, rdum + if( SURFLAY.eq.50.0 ) then + call MAPL_VarRead ( NCIOCatch ,'ATAU5', ATAU2) + call MAPL_VarRead ( NCIOCatch ,'BTAU5', BTAU2) endif - read (22, *) i,j, GNU(n), BF1(n), BF2(n), BF3(n) - - read (23, *) i,j, idum, idum, BEE(n), PSIS(n),& - POROS(n), COND(n), WPWET(n), DP2BR(n) - - read (24, *) i,j, rdum, ARS1(n), ARS2(n), ARS3(n), & - ARA1(n), ARA2(n), ARA3(n), ARA4(n), & - ARW1(n), ARW2(n), ARW3(n), ARW4(n) - - read (25, *) i,j, rdum, TSA1(n), TSA2(n), TSB1(n), TSB2(n) + call MAPL_VarRead ( NCIOCatch ,'PSIS', PSIS) + call MAPL_VarRead ( NCIOCatch ,'BEE', BEE) + call MAPL_VarRead ( NCIOCatch ,'BF1', BF1) + call MAPL_VarRead ( NCIOCatch ,'BF2', BF2) + call MAPL_VarRead ( NCIOCatch ,'BF3', BF3) + call MAPL_VarRead ( NCIOCatch ,'TSA1', TSA1) + call MAPL_VarRead ( NCIOCatch ,'TSA2', TSA2) + call MAPL_VarRead ( NCIOCatch ,'TSB1', TSB1) + call MAPL_VarRead ( NCIOCatch ,'TSB2', TSB2) + call MAPL_VarRead ( NCIOCatch ,'COND', COND) + call MAPL_VarRead ( NCIOCatch ,'GNU', GNU) + call MAPL_VarRead ( NCIOCatch ,'WPWET', WPWET) + call MAPL_VarRead ( NCIOCatch ,'DP2BR', DP2BR) + call MAPL_VarRead ( NCIOCatch ,'POROS', POROS) + call MAPL_VarRead ( NCIOCatchCN ,'BGALBNF', BNIRDF) + call MAPL_VarRead ( NCIOCatchCN ,'BGALBNR', BNIRDR) + call MAPL_VarRead ( NCIOCatchCN ,'BGALBVF', BVISDF) + call MAPL_VarRead ( NCIOCatchCN ,'BGALBVR', BVISDR) + call MAPL_VarRead ( NCIOCatchCN ,'NDEP', NDEP) + call MAPL_VarRead ( NCIOCatchCN ,'T2_M', T2) + call MAPL_VarRead(NCIOCatchCN,'ITY',CLMC_pt1,offset1=1) ! 30 + call MAPL_VarRead(NCIOCatchCN,'ITY',CLMC_pt2,offset1=2) ! 31 + call MAPL_VarRead(NCIOCatchCN,'ITY',CLMC_st1,offset1=3) ! 32 + call MAPL_VarRead(NCIOCatchCN,'ITY',CLMC_st2,offset1=4) ! 33 + call MAPL_VarRead(NCIOCatchCN,'FVG',CLMC_pf1,offset1=1) ! 34 + call MAPL_VarRead(NCIOCatchCN,'FVG',CLMC_pf2,offset1=2) ! 35 + call MAPL_VarRead(NCIOCatchCN,'FVG',CLMC_sf1,offset1=3) ! 36 + call MAPL_VarRead(NCIOCatchCN,'FVG',CLMC_sf2,offset1=4) ! 37 + call MAPL_NCIOClose (NCIOCatch ) + call MAPL_NCIOClose (NCIOCatchCN) + + 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') - if( SURFLAY.eq.20.0 ) read (26, *) i,j, ATAU2(n), BTAU2(n), rdum, rdum ! for old soil params - if( SURFLAY.eq.50.0 ) read (26, *) i,j, rdum , rdum, ATAU2(n), BTAU2(n) ! for new soil params + if(NewLand) then + open(unit=27, file=trim(DataDir)//'CLM_veg_typs_fracs' ,form='formatted') + open(unit=28, file=trim(DataDir)//'CLM_NDep_SoilAlb_T2m' ,form='formatted') + if(clm45) then + open(unit=29, file=trim(DataDir)//'CLM4.5_veg_typs_fracs',form='formatted') + open(unit=30, file=trim(DataDir)//'CLM4.5_abm_peatf_gdp_hdm_fc' ,form='formatted') + endif + endif - if (NewLand) then - read (27, *) 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) + do n=1,ntiles + var1 (n) = real (n) - read (28, *) NDEP(n), BVISDR(n), BVISDF(n), BNIRDR(n), BNIRDF(n), T2(n) ! MERRA-2 Annual Mean Temp is default. - if(clm45) then - read (29, *) 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) + if (NewLand) then + read(21,*) I, j, ITY(N),idum, rdum, rdum, CanopH(N) + else + read(21,*) I, j, ITY(N),idum, rdum, rdum + endif + + read (22, *) i,j, GNU(n), BF1(n), BF2(n), BF3(n) + + read (23, *) i,j, idum, idum, BEE(n), PSIS(n),& + POROS(n), COND(n), WPWET(n), DP2BR(n) + + read (24, *) i,j, rdum, ARS1(n), ARS2(n), ARS3(n), & + ARA1(n), ARA2(n), ARA3(n), ARA4(n), & + ARW1(n), ARW2(n), ARW3(n), ARW4(n) + + read (25, *) i,j, rdum, TSA1(n), TSA2(n), TSB1(n), TSB2(n) + + if( SURFLAY.eq.20.0 ) read (26, *) i,j, ATAU2(n), BTAU2(n), rdum, rdum ! for old soil params + if( SURFLAY.eq.50.0 ) read (26, *) i,j, rdum , rdum, ATAU2(n), BTAU2(n) ! for new soil params + + if (NewLand) then + read (27, *) 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 (30,'(2I8, i3, f8.4, f8.2, f10.2, f8.4)' ) i, j, abm(n), peatf(n), & - gdp(n), hdm(n), fc(n) + read (28, *) NDEP(n), BVISDR(n), BVISDF(n), BNIRDR(n), BNIRDF(n), T2(n) ! MERRA-2 Annual Mean Temp is default. + if(clm45) then + read (29, *) 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 (30,'(2I8, i3, f8.4, f8.2, f10.2, f8.4)' ) i, j, abm(n), peatf(n), & + gdp(n), hdm(n), fc(n) + endif + endif + end do + + CLOSE (22, STATUS = 'KEEP') + CLOSE (23, STATUS = 'KEEP') + CLOSE (24, STATUS = 'KEEP') + CLOSE (25, STATUS = 'KEEP') + CLOSE (26, STATUS = 'KEEP') + + if(NewLand) then + CLOSE (27, STATUS = 'KEEP') + CLOSE (28, STATUS = 'KEEP') + if(clm45) then + CLOSE (29, STATUS = 'KEEP') + CLOSE (30, STATUS = 'KEEP') endif endif + endif + + do n=1,ntiles + var1 (n) = real (n) + BVISDR(n) = amax1(1.e-6, BVISDR(n)) BVISDF(n) = amax1(1.e-6, BVISDF(n)) BNIRDR(n) = amax1(1.e-6, BNIRDR(n)) @@ -1107,20 +1215,7 @@ SUBROUTINE read_bcs_data (ntiles, SURFLAY,MODEL, DataDir, InRestart) endif end do endif - CLOSE (22, STATUS = 'KEEP') - CLOSE (23, STATUS = 'KEEP') - CLOSE (24, STATUS = 'KEEP') - CLOSE (25, STATUS = 'KEEP') - CLOSE (26, STATUS = 'KEEP') - - if(NewLand) then - CLOSE (27, STATUS = 'KEEP') - CLOSE (28, STATUS = 'KEEP') - if(clm45) then - CLOSE (29, STATUS = 'KEEP') - CLOSE (30, STATUS = 'KEEP') - endif - endif + ! Vegdyn Boundary Condition ! ------------------------- @@ -3434,16 +3529,34 @@ subroutine ReadCNTilFile (InCNTileFile, nt, xlon, xlat) integer , intent (in) :: nt real, dimension (nt), intent(inout) :: xlon, xlat integer :: n,icnt,ityp,status - real :: xval,yval, pf - + real :: xval,yval, pf,r + character(len=100) :: tmpline + open(11,file=InCNTileFile, & form='formatted',action='read',status='old') - do n = 1,8 ! skip header + do n = 1,5 ! skip header read(11,*) end do - + icnt = 0 + + ! check if the 6th line is numeric + read(11,'(A)') tmpline + read(tmpline,*,iostat = status) r + if (status == 0 ) then ! it is a number, 5 line header + read(tmpline,*) ityp,pf,xval,yval + if(ityp == 100) then + icnt = 1 + xlon(icnt) = xval + xlat(icnt) = yval + endif + else + ! throw away 2 more lines ( 8 total) + read(11,'(A)') tmpline + read(11,'(A)') tmpline + endif + ityp = 100 do while (ityp == 100) ! loop over land tiles @@ -3785,6 +3898,196 @@ FUNCTION StrExtName ( Input_String ) RESULT ( Output_String ) END FUNCTION StrExtName + ! ---------------------------------------------------------------------------- + + SUBROUTINE write_bin (unit, NCIO, NTILES) + + implicit none + integer :: ntiles + integer :: unit + type(MAPL_NCIO) :: NCIO + + + real :: bf1(ntiles) + real :: bf2(ntiles) + real :: bf3(ntiles) + real :: vgwmax(ntiles) + real :: cdcr1(ntiles) + real :: cdcr2(ntiles) + real :: psis(ntiles) + real :: bee(ntiles) + real :: poros(ntiles) + real :: wpwet(ntiles) + real :: cond(ntiles) + real :: gnu(ntiles) + real :: ars1(ntiles) + real :: ars2(ntiles) + real :: ars3(ntiles) + real :: ara1(ntiles) + real :: ara2(ntiles) + real :: ara3(ntiles) + real :: ara4(ntiles) + real :: arw1(ntiles) + real :: arw2(ntiles) + real :: arw3(ntiles) + real :: arw4(ntiles) + real :: tsa1(ntiles) + real :: tsa2(ntiles) + real :: tsb1(ntiles) + real :: tsb2(ntiles) + real :: atau(ntiles) + real :: btau(ntiles) + real :: ity(ntiles) + real :: tc(ntiles,4) + real :: qc(ntiles,4) + real :: capac(ntiles) + real :: catdef(ntiles) + real :: rzexc(ntiles) + real :: srfexc(ntiles) + real :: ghtcnt1(ntiles) + real :: ghtcnt2(ntiles) + real :: ghtcnt3(ntiles) + real :: ghtcnt4(ntiles) + real :: ghtcnt5(ntiles) + real :: ghtcnt6(ntiles) + real :: tsurf(ntiles) + real :: wesnn1(ntiles) + real :: wesnn2(ntiles) + real :: wesnn3(ntiles) + real :: htsnnn1(ntiles) + real :: htsnnn2(ntiles) + real :: htsnnn3(ntiles) + real :: sndzn1(ntiles) + real :: sndzn2(ntiles) + real :: sndzn3(ntiles) + real :: ch(ntiles,4) + real :: cm(ntiles,4) + real :: cq(ntiles,4) + real :: fr(ntiles,4) + real :: ww(ntiles,4) + + call MAPL_VarRead(NCIO,"BF1",bf1) + call MAPL_VarRead(NCIO,"BF2",bf2) + call MAPL_VarRead(NCIO,"BF3",bf3) + call MAPL_VarRead(NCIO,"VGWMAX",vgwmax) + call MAPL_VarRead(NCIO,"CDCR1",cdcr1) + call MAPL_VarRead(NCIO,"CDCR2",cdcr2) + call MAPL_VarRead(NCIO,"PSIS",psis) + call MAPL_VarRead(NCIO,"BEE",bee) + call MAPL_VarRead(NCIO,"POROS",poros) + call MAPL_VarRead(NCIO,"WPWET",wpwet) + call MAPL_VarRead(NCIO,"COND",cond) + call MAPL_VarRead(NCIO,"GNU",gnu) + call MAPL_VarRead(NCIO,"ARS1",ars1) + call MAPL_VarRead(NCIO,"ARS2",ars2) + call MAPL_VarRead(NCIO,"ARS3",ars3) + call MAPL_VarRead(NCIO,"ARA1",ara1) + call MAPL_VarRead(NCIO,"ARA2",ara2) + call MAPL_VarRead(NCIO,"ARA3",ara3) + call MAPL_VarRead(NCIO,"ARA4",ara4) + call MAPL_VarRead(NCIO,"ARW1",arw1) + call MAPL_VarRead(NCIO,"ARW2",arw2) + call MAPL_VarRead(NCIO,"ARW3",arw3) + call MAPL_VarRead(NCIO,"ARW4",arw4) + call MAPL_VarRead(NCIO,"TSA1",tsa1) + call MAPL_VarRead(NCIO,"TSA2",tsa2) + call MAPL_VarRead(NCIO,"TSB1",tsb1) + call MAPL_VarRead(NCIO,"TSB2",tsb2) + call MAPL_VarRead(NCIO,"ATAU",atau) + call MAPL_VarRead(NCIO,"BTAU",btau) + call MAPL_VarRead(NCIO,"OLD_ITY",ity) + call MAPL_VarRead(NCIO,"TC",tc) + call MAPL_VarRead(NCIO,"QC",qc) + call MAPL_VarRead(NCIO,"OLD_ITY",ity) + call MAPL_VarRead(NCIO,"CAPAC",capac) + call MAPL_VarRead(NCIO,"CATDEF",catdef) + call MAPL_VarRead(NCIO,"RZEXC",rzexc) + call MAPL_VarRead(NCIO,"SRFEXC",srfexc) + call MAPL_VarRead(NCIO,"GHTCNT1",ghtcnt1) + call MAPL_VarRead(NCIO,"GHTCNT2",ghtcnt2) + call MAPL_VarRead(NCIO,"GHTCNT3",ghtcnt3) + call MAPL_VarRead(NCIO,"GHTCNT4",ghtcnt4) + call MAPL_VarRead(NCIO,"GHTCNT5",ghtcnt5) + call MAPL_VarRead(NCIO,"GHTCNT6",ghtcnt6) + call MAPL_VarRead(NCIO,"TSURF",tsurf) + call MAPL_VarRead(NCIO,"WESNN1",wesnn1) + call MAPL_VarRead(NCIO,"WESNN2",wesnn2) + call MAPL_VarRead(NCIO,"WESNN3",wesnn3) + call MAPL_VarRead(NCIO,"HTSNNN1",htsnnn1) + call MAPL_VarRead(NCIO,"HTSNNN2",htsnnn2) + call MAPL_VarRead(NCIO,"HTSNNN3",htsnnn3) + call MAPL_VarRead(NCIO,"SNDZN1",sndzn1) + call MAPL_VarRead(NCIO,"SNDZN2",sndzn2) + call MAPL_VarRead(NCIO,"SNDZN3",sndzn3) + call MAPL_VarRead(NCIO,"CH",ch) + call MAPL_VarRead(NCIO,"CM",cm) + call MAPL_VarRead(NCIO,"CQ",cq) + call MAPL_VarRead(NCIO,"FR",fr) + call MAPL_VarRead(NCIO,"WW",ww) + + write(unit) bf1 + write(unit) bf2 + write(unit) bf3 + write(unit) vgwmax + write(unit) cdcr1 + write(unit) cdcr2 + write(unit) psis + write(unit) bee + write(unit) poros + write(unit) wpwet + write(unit) cond + write(unit) gnu + write(unit) ars1 + write(unit) ars2 + write(unit) ars3 + write(unit) ara1 + write(unit) ara2 + write(unit) ara3 + write(unit) ara4 + write(unit) arw1 + write(unit) arw2 + write(unit) arw3 + write(unit) arw4 + write(unit) tsa1 + write(unit) tsa2 + write(unit) tsb1 + write(unit) tsb2 + write(unit) atau + write(unit) btau + write(unit) ity + write(unit) tc + write(unit) qc + write(unit) capac + write(unit) catdef + write(unit) rzexc + write(unit) srfexc + write(unit) ghtcnt1 + write(unit) ghtcnt2 + write(unit) ghtcnt3 + write(unit) ghtcnt4 + write(unit) ghtcnt5 + write(unit) ghtcnt6 + write(unit) tsurf + write(unit) wesnn1 + write(unit) wesnn2 + write(unit) wesnn3 + write(unit) htsnnn1 + write(unit) htsnnn2 + write(unit) htsnnn3 + write(unit) sndzn1 + write(unit) sndzn2 + write(unit) sndzn3 + write(unit) ch + write(unit) cm + write(unit) cq + write(unit) fr + write(unit) ww + + close (unit) + call MAPL_NCIOClose (NCIO) + + END SUBROUTINE write_bin + ! ----------------------------------------------------------------------------- END PROGRAM mk_LDASsaRestarts diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/mk_restarts/mk_RouteRestarts.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/mk_restarts/mk_RouteRestarts.F90 index 61535edf1..8bb2a6362 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/mk_restarts/mk_RouteRestarts.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/mk_restarts/mk_RouteRestarts.F90 @@ -25,6 +25,7 @@ PROGRAM mk_RouteRestarts logical, allocatable, dimension (:) :: mask integer, allocatable, dimension (:,:):: tile_id, ocean_id, lake_id integer(kind =8) :: pfaf_code + logical :: file_exists = .false. INCLUDE 'netcdf.inc' @@ -86,8 +87,23 @@ PROGRAM mk_RouteRestarts i1 = index(OutTileFile,'/') i2 = index(OutTileFile,'.',back=.true.) - OPEN (10, FILE = TRIM(OutTileFile(1:i1))//'til'//'/Pfafstetter.til', & - FORM='FORMATTED', STATUS = 'OLD', ACTION = 'READ') + inquire(file = TRIM(OutTileFile(1:i1))//'til'//'/Pfafstetter.til', exist=file_exists) + + if(file_exists) then + + OPEN (10, FILE = TRIM(OutTileFile(1:i1))//'til'//'/Pfafstetter.til', & + FORM='FORMATTED', STATUS = 'OLD', ACTION = 'READ') + + print '(a100)','ROUTE_INTERNAL_RST (PfafFile) : '// TRIM(OutTileFile(1:i1))//'til'//'/Pfafstetter.til' + + else + + OPEN (10, FILE = 'OutData2/Pfafstetter.til', & + FORM='FORMATTED', STATUS = 'OLD', ACTION = 'READ') + print '(a100)','ROUTE_INTERNAL_RST (PfafFile) : OutData2/Pfafstetter.til' + + endif + READ (10,*) N_LND DO N = 1,4 READ (10,'(A)') @@ -111,7 +127,7 @@ PROGRAM mk_RouteRestarts ! STEP 3: Find ocean/lake tile ids at river mouths ! (3a) Reading til file - print '(a100)','ROUTE_INTERNAL_RST (OutTileFile) : '// trim(OutTileFile) + print '(a150)','ROUTE_INTERNAL_RST (OutTileFile) : '// trim(OutTileFile) open (10, file=trim(OutTileFile), form='formatted', status ='old',action = 'read') read (10,*) NT,NC,NR @@ -153,15 +169,19 @@ PROGRAM mk_RouteRestarts mask = .false. mask = (type == 0) N_Ocean = count (mask = mask) + allocate (i_ocean (1:N_Ocean)) allocate (j_ocean (1:N_Ocean)) i_ocean = pack(i_glb, mask = mask) j_ocean = pack(j_glb, mask = mask) - do i = 1,N_ocean - ocean_id (i_ocean(i), j_ocean(i)) = i ! + N_Land - end do + IF(N_OCEAN > 0) THEN + do i = 1,N_ocean + ocean_id (i_ocean(i), j_ocean(i)) = i ! + N_Land + end do + ENDIF + print *,size(ocean_id,1), size(ocean_id,2) mask = .false. mask = (type == 19) N_Lakes = count (mask = mask) @@ -171,7 +191,11 @@ PROGRAM mk_RouteRestarts j_lakes = pack (j_glb, mask = mask) do i = 1,N_lakes - lake_id (i_lakes(i), j_lakes(i)) = i ! + N_ocean + N_Land + IF(N_OCEAN > 0) THEN + lake_id (i_lakes(i), j_lakes(i)) = i ! + N_ocean + N_Land + else + lake_id (i_lakes(i)+1, j_lakes(i)+1) = i ! + N_ocean + N_Land + ENDIF end do mask = .false. @@ -180,7 +204,7 @@ PROGRAM mk_RouteRestarts deallocate (mask, i_lakes, j_lakes, i_ocean, j_ocean) - ! print *,N_land, N_ocean, N_lakes, N_ice + print *,N_land, N_ocean, N_lakes, N_ice ! print *, NT, N_land + N_ocean + N_lakes + N_ice ! (3b) Reading rst file @@ -188,8 +212,17 @@ PROGRAM mk_RouteRestarts i2 = index(OutTileFile,'.',back=.true.) OutRstFile = OutTileFile(1:i1)//'rst'//OutTileFile(i1:i2)//'rst' - print '(a100)','ROUTE_INTERNAL_RST (OutRstFile) : '// trim(OutRstFile) - open (10, file=trim(OutRstFile), form='unformatted', status ='old',action = 'read', convert='little_endian') + inquire(file = trim(OutRstFile) , exist=file_exists) + if(file_exists) then + print '(a100)','ROUTE_INTERNAL_RST (OutRstFile) : '// trim(OutRstFile) + open (10, file=trim(OutRstFile), form='unformatted', status ='old',action = 'read', convert='little_endian') + else + i1 = index(OutTileFile,'/',back=.true.) + OutRstFile = 'OutData2/rst/'//OutTileFile(i1:i2)//'rst' + print '(a100)','ROUTE_INTERNAL_RST (OutRstFile) : '// trim(OutRstFile) + open (10, file=trim(OutRstFile), form='unformatted', status ='old',action = 'read', convert='little_endian') + endif + do i =1,nr read (10) tile_id(:,i) end do @@ -225,23 +258,29 @@ PROGRAM mk_RouteRestarts IM = floor((DN_lon(i) + 180.)/dx) + 1 JM = floor((DN_lat(i) + 90.)/dy) + 1 ThisTile = tile_id(IM, JM) - - im = i_glb(ThisTile) - jm = j_glb(ThisTile) - - if(ocean_id(im,jm) > 0) then - ! Ocean - ORiverMouth (i) = ocean_id(im,jm) - ! print *, 'Ocean tile at :',i,ORiverMouth (i),DN_lat(i),DN_lon(i) - elseif((ocean_id(im,jm) <= 0).and.(lake_id(im,jm) > 0)) then - ! Lake - LRiverMouth (i) = lake_id(im,jm) - ! print *, 'Lake tile at :',i, LRiverMouth (i) ,DN_lat(i),DN_lon(i) - else - ! print *, 'No ocean or lake for :',i, cum_area(i),DN_lat(i),DN_lon(i) - ! stop - endif - + + IF( ThisTile >= 1) THEN + im = i_glb(ThisTile) + jm = j_glb(ThisTile) + + if(N_OCEAN == 0) THEN + im = im + 1 + jm = jm + 1 + ENDIF + + if(ocean_id(im,jm) > 0) then + ! Ocean + ORiverMouth (i) = ocean_id(im,jm) + ! print *, 'Ocean tile at :',i,ORiverMouth (i),DN_lat(i),DN_lon(i) + elseif((ocean_id(im,jm) <= 0).and.(lake_id(im,jm) > 0)) then + ! Lake + LRiverMouth (i) = lake_id(im,jm) + ! print *, 'Lake tile at :',i, LRiverMouth (i) ,DN_lat(i),DN_lon(i) + else + ! print *, 'No ocean or lake for :',i, cum_area(i),DN_lat(i),DN_lon(i) + ! stop + endif + endif endif end do diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/Raster/GNUmakefile b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/Raster/GNUmakefile index dfba8f89c..eee55f3b9 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/Raster/GNUmakefile +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/Raster/GNUmakefile @@ -4,7 +4,7 @@ #SILENT: XY = -x 8640 -y 4320 - T = -t 200000000 + T = -t 235000000 #LAND_SURFACE_DATA = /discover/nobackup/ltakacs/bcs/LandSurfaceData_for_Catchment_Parameters LAND_SURFACE_DATA = /discover/nobackup/projects/gmao/ssd/land/l_data/LandBCs_files_for_mkCatchParam/V001/ @@ -17,9 +17,15 @@ export MASKFILE ifdef NC ATMOSGRID =CUBE ATMNAME=CF$(NC)x6C + ifeq ($(NC), 0768) + XY:=-x 17280 -y 8640 + endif ifeq ($(NC), 1440) XY:=-x 17280 -y 8640 endif + ifeq ($(NC), 1536) + XY:=-x 43200 -y 21600 + endif ifeq ($(NC), 2000) XY:=-x 21600 -y 10800 endif @@ -53,10 +59,15 @@ ifdef IMM JMO:=$(shell expr substr $(JMM) $(LENY) 4) OCEANGRID =data/MOM/$(IMO)x$(JMO)/grid_spec.nc else +ifdef IMO OCEANGRID =LATLON IMO ?= 0360 JMO ?= 0180 OCNNAME=DE$(IMO)xPE$(JMO) +else + OCEANGRID =CUBEDO + OCNNAME=$(ATMNAME) +endif endif LNDNAME=Pfafstetter @@ -78,6 +89,9 @@ all: $(DIRS) BUILD $(TILEF) CLSM $(TILEF): $(ATMOS) $(SURFC) bin/CombineRasters $(T) $(ATMNAME) $(OCNNAME)-$(LNDNAME) +ifeq ($(OCEANGRID),data/MOM/$(IMO)x$(JMO)/grid_spec.nc) + bin/mk_runofftbl $(TILNAME) +endif $(ATMOS): ifeq ($(ATMOSGRID),LATLON) @@ -87,14 +101,16 @@ else endif $(SURFC): $(OCEAN) $(LAND) - bin/CombineRasters -f 0 $(OCNNAME) $(LNDNAME) >/dev/null + bin/CombineRasters -f 0 $(T) $(OCNNAME) $(LNDNAME) >/dev/null $(OCEAN): ifeq ($(OCEANGRID),LATLON) bin/mkLatLonRaster $(XY) -b DE -p PE -t 0 $(IMO) $(JMO) >/dev/null else +ifneq ($(OCEANGRID),CUBEDO) bin/mkMOMAquaRaster $(XY) $(OCEANGRID) > /dev/null endif +endif $(LAND): $(CATCH) bin/mkLandRaster $(XY) -v $(T) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/Raster/make_bcs b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/Raster/make_bcs index a4f7d8c07..d0a52d183 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/Raster/make_bcs +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/Raster/make_bcs @@ -113,13 +113,18 @@ foreach HRCODE ($dummy) $HRCODE != 'c' & \ $HRCODE != 'd' & \ $HRCODE != 'e' & \ + $HRCODE != 'c12' & \ + $HRCODE != 'c24' & \ $HRCODE != 'c48' & \ $HRCODE != 'c90' & \ $HRCODE != 'c180' & \ $HRCODE != 'c360' & \ $HRCODE != 'c720' & \ + $HRCODE != 'c768' & \ $HRCODE != 'c1000' & \ + $HRCODE != 'c1152' & \ $HRCODE != 'c1440' & \ + $HRCODE != 'c1536' & \ $HRCODE != 'c2880' & \ $HRCODE != 'c3072' & \ $HRCODE != 'c5760' & \ @@ -147,9 +152,11 @@ echo " ${C2}T1 -- Low-Resolution Tripolar 3 deg${CR} (MOM-Tripo echo " ${C2}T2 -- Med-Resolution Tripolar 1 deg${CR} (MOM-Tripolar-Ocean: 360x200 ) " echo " ${C2}T3 -- High-Resolution Tripolar 1/2 deg${CR} (MOM-Tripolar-Ocean: 720x410 ) " echo " ${C2}T4 -- High-Resolution Tripolar 1/4 deg${CR} (MOM-Tripolar-Ocean: 1440x1080 ) " +echo " ${C2}CS -- Cubed-Sphere Ocean ${CR} (Cubed-Sphere Data-Ocean with Old Land) " echo " ${C2}NL1-- Low-Resolution Reynolds 1 deg${CR} (Lon/Lat Data-Ocean: 360x180 with New Land) " echo " ${C2}NL2-- Med-Resolution Reynolds 1/4 deg${CR} (Lon/Lat Data-Ocean: 1440x720 with New Land) " echo " ${C2}NL3-- High-Resolution OSTIA 1/8 deg${CR} (Lon/Lat Data-Ocean: 2880x1440 with New Land) " +echo " ${C2}NCS-- Cubed-Sphere Ocean ${CR} (Cubed-Sphere Data-Ocean with New Land) " set dummy = `echo $<` set dummy = `echo $dummy | tr "[:lower:]" "[:upper:]"` set orslvs = $dummy[1] @@ -163,7 +170,9 @@ foreach orslv ($dummy) $orslv != 'T4' & \ $orslv != 'NL1'& \ $orslv != 'NL2'& \ - $orslv != 'NL3' ) goto ORSLV + $orslv != 'NL3'& \ + $orslv != 'CS' & \ + $orslv != 'NCS') goto ORSLV if( $orslv != "$orslvs" ) set orslvs = `echo ${orslvs} ${orslv}` end @@ -186,13 +195,13 @@ set GLOBAL_CATCH_DATA = /discover/nobackup/ltakacs/bcs/LandSurfaceData_for_Catch foreach orslv ($orslvs) -if( $orslv == NL1 ) then +if( $orslv == NL1 | $orslv == T1 | $orslv == T2 | $orslv == T3) then # Great-Lakes & Caspian-Sea treated as Model LAKE tiles, Surface Temperatures will be Model Derived # ------------------------------------------------------------------------------------------------- set GLOBAL_CATCH_DATA = /discover/nobackup/projects/gmao/ssd/land/l_data/LandBCs_files_for_mkCatchParam/V001/GEOS5_10arcsec_mask_freshwater-lakes.nc endif -if( $orslv == NL2 | $orslv == NL3 ) then +if( $orslv == NL2 | $orslv == NL3 | $orslv == NCS ) then # Great-Lakes & Caspian-Sea treated as Model Ocean tiles, Surface Temperatures will be Model Derived # ------------------------------------------------------------------------------------------------- set GLOBAL_CATCH_DATA = /discover/nobackup/projects/gmao/ssd/land/l_data/LandBCs_files_for_mkCatchParam/V001/GEOS5_10arcsec_mask.nc @@ -204,7 +213,7 @@ if( $orslv == O1 ) then set GLOBAL_CATCH_DATA = /discover/nobackup/ltakacs/bcs/LandSurfaceData_for_Catchment_Parameters/global.cat_id.catch.ORIG.DL endif -if( $orslv == O2 ) then +if( $orslv == O2 | $orslv == CS ) then # Great-Lakes & Caspian-Sea treated as Model OCEAN tiles, Surface Temperatures will be taken from OCEAN SST Data # -------------------------------------------------------------------------------------------------------------- set GLOBAL_CATCH_DATA = /discover/nobackup/ltakacs/bcs/LandSurfaceData_for_Catchment_Parameters/global.cat_id.catch.GreatLakesCaspian_Updated.DL @@ -225,6 +234,7 @@ echo "" set LATLON_OCEAN = FALSE set TRIPOL_OCEAN = FALSE +set CUBED_SPHERE_OCEAN = FALSE if( $orslv == O1 | $orslv == NL1 ) then @ imo = 360 # Lat/Lon Data-Ocean (Reynolds 1-deg) @@ -265,10 +275,11 @@ if( $orslv == T1 | $orslv == T2 | $orslv == T3 | $orslv == T4 ) then set DATENAME = TM set POLENAME = TM endif +if( $orslv == CS | $orslv == NCS ) set CUBED_SPHERE_OCEAN = TRUE -# ------------------------------------ +# ------------------------------------- # Loop over All Atmospheric Resolutions -# ---------------------------------------- +# ------------------------------------- foreach HRCODE ($HRCODES) @@ -305,7 +316,16 @@ if( $HRCODE == e ) then set jm = 721 set grid = latlon endif - +if( $HRCODE == c12 ) then + set nc = 12 + set RC = 12x72 + set grid = cube +endif +if( $HRCODE == c24 ) then + set nc = 24 + set RC = 24x144 + set grid = cube +endif if( $HRCODE == c48 ) then set nc = 48 set RC = 48x288 @@ -331,16 +351,31 @@ if( $HRCODE == c720 ) then set RC = 720x4320 set grid = cube endif +if( $HRCODE == c768 ) then + set nc = 768 + set RC = 768x4608 + set grid = cube +endif if( $HRCODE == c1000 ) then set nc = 1000 set RC = 1000x6000 set grid = cube endif +if( $HRCODE == c1152 ) then + set nc = 1152 + set RC = 1152x6912 + set grid = cube +endif if( $HRCODE == c1440 ) then set nc = 1440 set RC = 1440x8640 set grid = cube endif +if( $HRCODE == c1536 ) then + set nc = 1536 + set RC = 1536x9216 + set grid = cube +endif if( $HRCODE == c2880 ) then set nc = 2880 set RC = 2880x17280 @@ -471,7 +506,9 @@ cd ../ CLM4.5_veg_typs_fracs \ mkCatchParam.log \ CLM_NDep_SoilAlb_T2m \ - CLM4.5_abm_peatf_gdp_hdm_fc \ + CLM4.5_abm_peatf_gdp_hdm_fc \ + catch_params.nc4 \ + catchcn_params.nc4 \ clsm cd ../ @@ -508,7 +545,16 @@ ln -s /home/yvikhlia/nobackup/coupled/Forcings/a90x540_o360x200/INPUT/ data/MOM/ ln -s /home/yvikhlia/nobackup/coupled/Forcings/a90x540_o720x410/INPUT/ data/MOM/720x410 ln -s /home/yvikhlia/nobackup/coupled/Forcings/a180x1080_o1440x1080/INPUT/ data/MOM/1440x1080 -set BCNAME = CF${NC}x6C_${DATENAME}${IMO}x${POLENAME}${JMO} +if( $CUBED_SPHERE_OCEAN == TRUE ) then + set BCNAME = CF${NC}x6C_CF${NC}x6C + set DATENAME = CF + set POLENAME = + set IMO = ${NC} + set JMO = 6C +else + set BCNAME = CF${NC}x6C_${DATENAME}${IMO}x${POLENAME}${JMO} +endif + set BCDIR = $BCNAME.scratch set BCJOB = $BCNAME.j @@ -538,6 +584,9 @@ endif if( $TRIPOL_OCEAN == TRUE ) then gmake NC=$NC IMM=$IMO JMM=$JMO MASKFILE=${MASKFILE} GLOBAL_CATCH_DATA=${GLOBAL_CATCH_DATA} OMP_NUM_THREADS=${NCPUS} | tee CF${NC}x6C_${DATENAME}${IMO}x${POLENAME}${JMO}.stdout endif +if( $CUBED_SPHERE_OCEAN == TRUE ) then + gmake NC=$NC INC=$NC MASKFILE=${MASKFILE} GLOBAL_CATCH_DATA=${GLOBAL_CATCH_DATA} OMP_NUM_THREADS=${NCPUS} | tee CF${NC}x6C_CF${NC}x6C.stdout +endif /bin/mv clsm clsm.C${NC} /bin/cp til/CF${NC}x6C_${DATENAME}${IMO}x${POLENAME}${JMO}-Pfafstetter.til clsm.C${NC} @@ -586,6 +635,8 @@ cd ../ mkCatchParam.log \ CLM_NDep_SoilAlb_T2m \ CLM4.5_abm_peatf_gdp_hdm_fc \ + catch_params.nc4 \ + catchcn_params.nc4 \ clsm cd ../ @@ -663,6 +714,7 @@ if ( $EVERSION == EASEv2 ) then setenv MASKFILE ${MASKFILE} bin/mkSMAPTilesPara_v2 -smap_grid ${MGRID} else +setenv MASKFILE ${MASKFILE} bin/mkSMAPTilesPara -smap_grid ${MGRID} endif @@ -707,6 +759,8 @@ cd ../ Grid2Catch_TransferData.nc \ CLM_NDep_SoilAlb_T2m \ CLM4.5_abm_peatf_gdp_hdm_fc \ + catch_params.nc4 \ + catchcn_params.nc4 \ clsm cd ../ diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/Raster/src/clsm_plots.pro b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/Raster/src/clsm_plots.pro index 4c100209b..9351005a5 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/Raster/src/clsm_plots.pro +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/Raster/src/clsm_plots.pro @@ -1,3 +1,111 @@ +;_____________________________________________________________________ + +FUNCTION NCDF_ISNCDF, FILENAME + +;- Set return values + +false = 0B +true = 1B + +;- Establish error handler + +catch, error_status +if error_status ne 0 then begin + catch, /cancel + return, false +endif + +;- Try opening the file + +cdfid = ncdf_open( filename ) + +;- If we get this far, open must have worked + +ncdf_close, cdfid +catch, /cancel +return, true + +END + +; ---------------- + +function nint, x, LONG = long ;Nearest Integer Function +;+ +; NAME: +; NINT +; PURPOSE: +; Nearest integer function. +; EXPLANATION: +; NINT() is similar to the intrinsic ROUND function, with the following +; two differences: +; (1) if no absolute value exceeds 32767, then the array is returned as +; as a type INTEGER instead of LONG +; (2) NINT will work on strings, e.g. print,nint(['3.4','-0.9']) will +; give [3,-1], whereas ROUND() gives an error message +; +; CALLING SEQUENCE: +; result = nint( x, [ /LONG] ) +; +; INPUT: +; X - An IDL variable, scalar or vector, usually floating or double +; Unless the LONG keyword is set, X must be between -32767.5 and +; 32767.5 to avoid integer overflow +; +; OUTPUT +; RESULT - Nearest integer to X +; +; OPTIONAL KEYWORD INPUT: +; LONG - If this keyword is set and non-zero, then the result of NINT +; is of type LONG. Otherwise, the result is of type LONG if +; any absolute values exceed 32767, and type INTEGER if all +; all absolute values are less than 32767. +; EXAMPLE: +; If X = [-0.9,-0.1,0.1,0.9] then NINT(X) = [-1,0,0,1] +; +; PROCEDURE CALL: +; None: +; REVISION HISTORY: +; Written W. Landsman January 1989 +; Added LONG keyword November 1991 +; Use ROUND if since V3.1.0 June 1993 +; Always start with ROUND function April 1995 +; Return LONG values, if some input value exceed 32767 +; and accept string values February 1998 +; Use size(/TNAME) instead of DATATYPE() October 2001 +;- +xmax = max(x,min=xmin) + xmax = abs(xmax) > abs(xmin) + if (xmax gt 32767) or keyword_set(long) then begin + if size(x,/TNAME) eq 'STRING' then b = round(float(x)) else b = round(x) + end else begin + if size(x,/TNAME) eq 'STRING' then b = fix(round(float(x))) else $ + b = fix(round(x)) + endelse + + return, b + end + +; ------------------------------------------------------------------------------------------- + +FUNCTION IS_IN_DOMAIN, xylim, x,y + +if (((x ge xylim(1)) and (x le xylim(3))) and $ + ((y ge xylim(0)) and (y le xylim(2)))) then begin + + return_value = boolean(1) + +endif else begin + + return_value = boolean(0) + +endelse + +return,return_value + +END + +; ####################################################### + FUNCTION Z0_VALUE, Z2CH, lai, SCALE4Z0 MIN_VEG_HEIGHT = 0.01 @@ -350,16 +458,32 @@ plot_lai, ncat, tile_id ; (11) vegetation height and roughness length filename = '../vegdyn.data' -openr,1,filename,/F77_UNFORMATTED -ityp = fltarr (ncat) -z2 = fltarr (ncat) -asz0 = fltarr (ncat) +ncdf_file = boolean (ncdf_isncdf(filename)) + +if (ncdf_file) then begin + + ncid = NCDF_OPEN(filename,/NOWRITE) + NCDF_VARGET, ncid,'ITY', ITYP + NCDF_VARGET, ncid,'Z2CH', Z2 + NCDF_VARGET, ncid,'ASCATZ0', ASZ0 + NCDF_CLOSE, ncid + +endif else begin + + openr,1,filename,/F77_UNFORMATTED + ityp = fltarr (ncat) + z2 = fltarr (ncat) + asz0 = fltarr (ncat) + + readu,1,ITYP + readu,1,Z2 + readu,1,ASZ0 + close,1 + +endelse -readu,1,ITYP -readu,1,Z2 -readu,1,ASZ0 ASZ0 = ASZ0 * 1000. -close,1 + plot_canoph, z2, tile_id @@ -2240,25 +2364,48 @@ end pro create_vec_file -dx = 60./60. -dy = 60./60. +dx = 1.d0/12. +dy = 1.d0/12. +DATELINE = 1 +global_bcs = 0 +WORKDIR = '/gpfsm/dnb02/smahanam/MichelBechtold/SouthAmerica/0.125/' -SRTM_maxcat = 291284 nc = long(360./dx) nr = long(180./dy) +openw,1,workdir + 'clsm/NLDAS-5arcmin_vec.data' + +if(NOT (boolean (global_bcs))) then begin + xylim = [25., -125., 53., -67.] + x = indgen (nc)*dx -180. + dx/2. + y = indgen (nr)*dy -90. + dy/2. + i1 = value_locate (x, xylim(1)) + 1 + i2 = value_locate (x, xylim(3)) + j1 = value_locate (y, xylim(0)) + 1 + j2 = value_locate (y, xylim(2)) + i_offset = i1 + j_offset = j1 + nc_domain = i2 - i1 + 1 + nr_domain = j2 - j1 + 1 + printf,1,format ='(2f8.4, i3, 4i5)', dx,dy, dateline, nc_domain,nr_domain,i_offset,j_offset +endif else begin + printf,1,dx,dy, dateline +endelse + +SRTM_maxcat = 291284 + nc_esa = 129600l nr_esa = 64800l nx = nc_esa/nc ny = nr_esa/nr -ncid = NCDF_OPEN(' /discover/nobackup/projects/gmao/ssd/land/l_data/LandBCs_files_for_mkCatchParam/V001/GEOS5_10arcsec_mask.nc') +ncid = NCDF_OPEN('/discover/nobackup/projects/gmao/ssd/land/l_data/LandBCs_files_for_mkCatchParam/V001/GEOS5_10arcsec_mask.nc') ;NCDF_VARGET, ncid,0, y ;NCDF_VARGET, ncid,1, x n = 1l -openw,1,'1-degree_vec.dat' + subset = lonarr (nc_esa,ny) for j = 0l,nr -1l do begin NCDF_VARGET, ncid,'CatchIndex', offset = [0,j*ny], count = [nc_esa,ny], SubSet @@ -2267,10 +2414,16 @@ for j = 0l,nr -1l do begin CatchIndex = SubSet(i*nx:(i+1)*nx -1,*) if(max(CatchIndex) gt SRTM_maxcat) then CatchIndex (where (CatchIndex gt SRTM_maxcat)) = 0 if (max (CatchIndex) ge 1) then begin - printf,1,format ='(i7,2(1x,f10.5),2(1x,I5))',n,j*dy -90. + dy/2.,i*dx -180. + dx/2.,I+1,J+1 -; print,format ='(i7,2(1x,f10.5))',n,j*dy -90. + dy/2.,i*dx -180. + dx/2. - n = n + 1 - endif + if(boolean (global_bcs)) then begin + printf,1,format ='(i7,2(1x,f10.5),2(1x,I5))',n,j*dy -90. + dy/2.,i*dx -180. + dx/2.,I+1,J+1 + n = n + 1 + endif else begin + if(IS_IN_DOMAIN(xylim, i*dx -180. + dx/2.,j*dy -90. + dy/2.)) then begin + printf,1,format ='(i7,2(1x,f10.5),2(1x,I5))',n,j*dy -90. + dy/2.,i*dx -180. + dx/2.,I+1 - i_offset,J+1 - j_offset + n = n + 1 + endif + endelse + endif endfor endfor close,1 @@ -2511,7 +2664,7 @@ for month = 1,12 do begin endelse contour, data_grid,x,y,levels = levels,c_colors=colors,/cell_fill,/overplot - MAP_CONTINENTS,/COASTS,color=0,MLINETHICK=2 + MAP_CONTINENTS,/COASTS,color=0,MLINETHICK=2 endfor close,1 @@ -2961,3 +3114,175 @@ image24[2,*,*] = b[snapshot] Write_JPEG, pname + '_Z0.jpg', image24, True=1, Quality=100 end + +; ------------------------------------ + +pro proc_glass + + +;IDATA = '/gpfsm/dnb43/projects/p03/RS_DATA/GLASS/LAI/AVHRR/V4/HDF/' +;ODATA = '/discover/nobackup/rreichle/l_data/LandBCs_files_for_mkCatchParam/V001/GLASS-LAI/AVHRR.v4/' +;LABEL = 'GLASS01B02.V04.A' +;yearb = 1981 +;YEARe = 2017 + +IDATA = '/gpfsm/dnb43/projects/p03/RS_DATA/GLASS/LAI/MODIS/V4/HDF/' +ODATA = '/discover/nobackup/rreichle/l_data/LandBCs_files_for_mkCatchParam/V001/GLASS-LAI/MODIS.v4/' +LABEL = 'GLASS01B01.V04.A' +yearb = 2000 +YEARe = 2017 + +nc = 7200 +nr = 3600 +nyrs = YEARe - yearb + 1 + +lwval = 0. +upval = 7. + +im = nc +jm = nr + +dx = 360. / im +dy = 180. / jm + +x = indgen(im)*dx -180. + dx/2. +y = indgen(jm)*dy -90. + dy/2. +r_in = [253,224,255,238,205,193,152, 0,124, 0, 0, 0, 0, 0, 0, 48,110, 85] +g_in = [253,238,255,238,205,255,251,255,252,255,238,205,139,128,100,128,139,107] +b_in = [253,224, 0, 0, 0,193,152,127, 0, 0, 0, 0, 0, 0, 0, 20, 61, 47] + +n_levels = n_elements (r_in) +levels=[0.,0.25,0.5,0.75,1.,1.25,1.5,10. * indgen(11)*0.05+2.] +red = intarr (256) +green= intarr (256) +blue = intarr (256) + +red (255) = 255 +green(255) = 255 +blue (255) = 255 + +for k = 0, N_levels -1 do begin + red (k+1) = r_in (k) + green(k+1) = g_in (k) + blue (k+1) = b_in (k) +endfor + +TVLCT,red,green,blue +colors = indgen (N_levels) + 1 + +limits = [-60,-180,90,180] +thisDevice = !D.Name +set_plot,'Z' +Device, Set_Resolution=[800,500], Z_Buffer=0 +Erase,255 +!p.background = 255 + +;file1 = '/gpfsm/dnb43/projects/p03/RS_DATA/GLASS/LAI/MODIS/V4/HDF/2008/GLASS01B01.V04.A2008185.hdf' +file1 = '/discover/nobackup/rreichle/l_data/LandBCs_files_for_mkCatchParam/V001/GLASS-LAI/MODIS.v4/GLASS01B01.V04.AYYYY105.nc4' +ncid = ncdf_open (file1) +NCDF_VARGET, ncid,'LAI', adum +ncdf_close,ncid + +;FileID=HDF_SD_Start(file1, /read) +;sds_id = hdf_sd_select(FileID, 0) +;hdf_sd_getdata, sds_id,adum +;HDF_SD_END, FileID +adum (where (adum eq 2550)) = !VALUES.F_NAN +adum = adum /100. + + +MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits +MAP_CONTINENTS,/COASTS,color=0,MLINETHICK=2,/USA +;contour, adum,x,y,levels = levels,c_colors=colors,/cell_fill + +snapshot = TVRD() +TVLCT, r, g, b, /Get +Device, Z_Buffer=1 +Set_Plot, thisDevice +image24 = BytArr(3, 800, 500) +image24[0,*,*] = r[snapshot] +image24[1,*,*] = g[snapshot] +image24[2,*,*] = b[snapshot] +Write_JPEG, 'global_map.jpg', image24, True=1, Quality=100 +stop + +for DOY = 1,361,8 do begin + LAI = intarr (nc,nr,nyrs) + LAI (*,*,*) = 2550 + DDD = string (DOY,'(i3.3)') + for year = yearB, yearE do begin + YYYY = string (year, '(i4.4)') + filename = IDATA + YYYY + '/' + LABEL + yyyy + DDD + '.hdf' + FileID=HDF_SD_Start(filename, /read) + sds_id = hdf_sd_select(FileID, 0) + hdf_sd_getdata, sds_id,adum + adum = adum *10 + HDF_SD_END, FileID + print, year,min(adum), max(adum) + LAI (*,*,year - yearB) = adum + + endfor + +indata = intarr (nc,nr) +indata (*,*) = 2550 + +for j = 0, nr -1 do begin + for i = 0, nc -1 do begin + if(min (LAI (i,j,*)) lt 2550) then begin + syears = where (LAI (i,j,*) lt 2550) + indata (i,j) = mean (LAI (i,j,syears)) + ; if(mean (LAI (i,j,syears)) gt 500.) then stop + ; print, n_elements (syears), mean (LAI (i,j,syears)) + endif + endfor +endfor + +print, min (indata), max(indata) + +ofile = ODATA + LABEL + 'YYYY' + DDD + '.nc4' +write_glass_output, indata, ofile + +endfor + +end + +; ---------------------------------------------------------------- + + +pro write_glass_output,indata,ofile + +nc = 7200 +nr = 3600 + +id = NCDF_CREATE(ofile, /clobber) ;Create netCDF output file +xid = NCDF_DIMDEF(id, 'N_lon', nc) ;Define x-dimension +yid = NCDF_DIMDEF(id, 'N_lat', nr) ;Define y-dimension +NCDF_ATTPUT,id, 'CellSize_arcmin' , 3,/global +NCDF_ATTPUT,id, 'CreatedBy', 'Sarith Mahanama',/global +NCDF_ATTPUT,id, 'Contact', 'sarith.p.mahanama@nasa.gov',/global +str_date=systime() +NCDF_ATTPUT,id, 'Date', str_date,/global +vid = NCDF_VARDEF(id, 'lat', yid, /DOUBLE) ;Define latitude variable +vid = NCDF_VARDEF(id, 'lon', xid, /DOUBLE) ;Define longitude variable +vid = NCDF_VARDEF(id, 'LAI', [xid, yid], /SHORT) +NCDF_ATTPUT, id, vid, 'LongName','Leaf Area Index 8-Day 0.05-degrees GEO Grid climatology' +NCDF_ATTPUT, id, vid, 'units', 'm^2/m^2' +NCDF_ATTPUT, id, vid, 'scale_factor',0.01 +NCDF_ATTPUT, id, vid, 'valid_range','0 1000' +NCDF_ATTPUT, id, vid, '_FillValue', 2550 + +NCDF_CONTROL, id, /ENDEF + +dxy = 360.d/7200.d + +x = indgen (nc)*dxy -180. + dxy/2.d +y = indgen (nr)*dxy -90. + dxy/2.d + +NCDF_VARPUT, id,'lat', y +NCDF_VARPUT, id,'lon', x +for j =0, nr -1 do begin +NCDF_VARPUT, id, 'LAI',offset=[0,nr-1 -j],count=[nc,1] , nint(indata [*,j]) +endfor +NCDF_CLOSE, id + +end diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/Raster/src/create_README.csh b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/Raster/src/create_README.csh index 11ca50179..048b3ad1f 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/Raster/src/create_README.csh +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/Raster/src/create_README.csh @@ -230,6 +230,36 @@ endif if($mylai == GEOLAND2) then set MYLAIDATES="${GEOLAND2_DATES}" endif +if($mylai == GLASSA | $mylai == GLASSM) then + set MYLAIDATES="${MODIS8_DATES}" + set sec4_geo_cite="`printf 'Xiao Z., S. Liang, J. Wang, et al., Use of General Regression Neural Networks for Generating\\n \ + the GLASS Leaf Area Index Product from Time Series MODIS Surface Reflectance. IEEE Transactions on Geoscience\\n \ + and Remote Sensing, 2013,doi:10.1109/TGRS.2013.2237780.'`" +if($mylai == GLASSA) then + set sec4_lai="`printf '8-day composites of AVHRR based GLASS (Global Land Surface Satellite) LAI v04\\n \ + data are available at 3-arcmin (7200×3600) for the period 1981-2017. \\n \ + 8-day climatology of LAI was computed from these data by temporally averaging over the 37-year period \\n \ + (by 8-day periods) on the 3-arcmin grid. Those climatological data were aggregated over \\n \ + the pixels of each land element to derive a 8-day LAI\\n \ + In order to fill gaps that may exist due to inconsistencies between LAI and GEOS5 masks as well as data gaps themselves\\n \ + we constructed, at every time slice, a 1°×1° global gridded LAI dataset \\n \ + by spatially aggregating the finer resolution LAI climatological data. Missing \\n \ + LAI values in the finer resolution datasets were filled with the value for the \\n \ + nearest neighbor on the 1°×1° global grid.'`" +endif +if($mylai == GLASSM) then + set sec4_lai="`printf '8-day composites of MODIS based GLASS (Global Land Surface Satellite) LAI v04\\n \ + data are available at 3-arcmin (7200×3600) for the period 2000-2017. \\n \ + 8-day climatology of LAI was computed from these data by temporally averaging over the 18-year period \\n \ + (by 8-day periods) on the 3-arcmin grid. Those climatological data were aggregated over \\n \ + the pixels of each land element to derive a 8-day LAI\\n \ + In order to fill gaps that may exist due to inconsistencies between LAI and GEOS5 masks as well as data gaps themselves\\n \ + we constructed, at every time slice, a 1°×1° global gridded LAI dataset \\n \ + by spatially aggregating the finer resolution LAI climatological data. Missing \\n \ + LAI values in the finer resolution datasets were filled with the value for the \\n \ + nearest neighbor on the 1°×1° global grid.'`" +endif +endif if($mylai == MODIS | $mylai == MODGEO) then set MYLAIDATES="${MODIS8_DATES}" set sec4_lai="`printf 'The Second Global Soil Wetness Project (GSWP-2: Dirmeyer and Oki, 2002)\\n \ @@ -356,6 +386,26 @@ cat << _EOI_ > clsm/intro || on Global Modeling and Data Assimilation 104606, v39, 51pp. || || URL: http://gmao.gsfc.nasa.gov/pubs/tm/ || || || +|| IMPORTANT UPDATE (5/4/2019) : || +|| In addition to the ASCII files mentioned in the text, following || +|| two nc4 files also contain parameters that are needed by models. || +|| More importantly, the restart utilities read parameters || +|| from below 2 nc4 files instead the ASCII files. || +|| || +|| (1) "catch_params.nc4" contains : || +|| OLD_ITY (primary vegetation type Section 3.2.1) || +|| BEE, PSIS, POROS, COND, WPWET, DP2BR (Section 2.2.4) || +|| ATAU2,BTAU2,ATAU5,BTAU5 (Section 6.2.1) || +|| GNU, TSA1,TSA2,TSB1,TSB2 (Section 6.2.2) || +|| BF1,BF2,BF3 (Section 6.2.3) || +|| ARS1,ARS2,ARS3,ARA1,ARA2,ARA3,ARA4,ARW1,ARW2, || +|| ARW3,ARW4 (Section 6.2.4) || +|| || +|| (1) "catchcn_params.nc4" contains : || +|| ITY (CLM-C_pt1, CLM-C_pt2, CLM-C_st1, CLM-C_st2 Section 3.3.3) || +|| FVG (CLM-C_pf1, CLM-C_pf2,CLM-C_sf1, CLM-C_sf2 Section 3.3.3) || +|| NDEP,BGALBVR, BGALBVF, BGALBNR, BGALBNF, T2_M, T2_S (Section 3.2.4)|| +|| || || Date : ${today} || || || ===================================================================================== @@ -561,7 +611,7 @@ if( $mysoil == HWSD ) then cat << _EOS1_ > clsm/soil read (10,'(i8,i8,i4,i4,3f8.4,f12.8,f7.4,f10.4,3f7.3,4f7.3,2f10.4)') & tile_index,pfaf_code,soil_class_top,soil_class_com,BEE, & - PSIS,POROS,COND, WPWET, soildepth, gravel,OrgCarbon_top, & + PSIS,POROS,COND, WPWET, DP2BR, gravel,OrgCarbon_top, & OrgCarbon_rz,sand_top,clay_top,sand_rz,clay_rz,WPWET_top, POROS_top end do @@ -580,7 +630,7 @@ cat << _EOS1_ > clsm/soil [Figure 4 : "plots/soil_param.jpg" middle-right panel] (9) WPWET [-] wilting point/porosity for the root-zone [Figure 4 : "plots/soil_param.jpg" bottom-left panel] - (10) soildepth [mm] depth to bedrock + (10) DP2BR [mm] depth to bedrock [Figure 4 : "plots/soil_param.jpg" bottom-right panel] (11) gravel [vol% ] percentage gravel in the surface layer (0-30cm) (12) OrgCarbon_top [w%] percentage organic carbon in the surface layer (0-30cm) @@ -930,9 +980,8 @@ cat << _EOV1_ > clsm/veg1 `echo "${sec3_veg_des}"` - Global 30-arcsec canopy height data, used (in some implementations) in the calculation - of surface roughness, were obtained from NASA’s Jet Propulsion Laboratory (Simrad et al., - 2011). These heights were spatially aggregated to catchment surface elements + Vegetation canopy height data were derived using the look up table in Koster et al.(1996) + for the primary vegetation type of the catchment. (plots/Canopy_Height_onTiles.jpg). Global 6km aeolian aerodynamic roughness length data (Prigent et al., 2012) were @@ -1053,20 +1102,20 @@ cat << _EOV2_ > clsm/veg2 file name: CLM_Ndep_SoilAlb do n = 1, ${NTILES} read (10, '(f10.4,4f7.4,2f8.3)') & - NDEP,VISDR, VISDF, NIRDR, NIRDF, T2_M, T2_S + NDEP,BGALBVR, BGALBVF, BGALBNR, BGALBNF, T2_M, T2_S enddo Where for each tile: (1) NDEP [ng m-2 s-1] Nitrogen deposition [Figure 11a: "plots/CLM_Ndep_T2m.jpg" top panel] - (2) VISDR [-] Direct visible soil background albedo + (2) BGALBVR [-] Direct visible soil background albedo [Figure 12a: "plots/SoilAlb.jpg" top-left panel] - (3) VISDF [-] Diffuse visible soil background albedo + (3) BGALBVF [-] Diffuse visible soil background albedo [Figure 12b: "plots/SoilAlb.jpg" top-right panel] - (4) NIRDR [-] Direct near-infrared soil background albedo + (4) BGALBNR [-] Direct near-infrared soil background albedo [Figure 12c: "plots/SoilAlb.jpg" bottom-left panel] - (5) NIRDF [-] Diffuse near-infrared soil background albedo + (5) BGALBNF [-] Diffuse near-infrared soil background albedo [Figure 12d: "plots/SoilAlb.jpg" bottom-right panel] (6) T2_M [K] Mean annual 2m air temperature from MERRA-2 (averaged over 1980-2014) [Figure 11b: "plots/CLM_Ndep_T2m.jpg" middle panel] diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/Raster/src/create_vegdyn_ndvi.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/Raster/src/create_vegdyn_ndvi.F90 new file mode 100644 index 000000000..f0be13a52 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/Raster/src/create_vegdyn_ndvi.F90 @@ -0,0 +1,430 @@ +#include "Raster.h" + +PROGRAM create_vegdyn_ndvi + +! USAGE : ./create_vegdyn_ndvi BCSDIR GFILE, IMxJM JPLH OUTDIR +! EXAMPLES +! bin/create_vegdyn_ndvi /discover/nobackup/ltakacs/bcs/Ganymed-4_0/SMAP_EASEv2/SMAP_EASEv2_M36/ SMAP_EASEv2_M36_964x406 964x406_DE 0 M2/M36/ +! bin/create_vegdyn_ndvi /discover/nobackup/ltakacs/bcs/Ganymed-4_0/SMAP_EASEv2/SMAP_EASEv2_M09/ SMAP_EASEv2_M09_3856x1624 3856x1624_DE 0 M2/M09/ +! bin/create_vegdyn_ndvi /discover/nobackup/ltakacs/bcs/Ganymed-4_0/Ganymed-4_0_MERRA-2/DC0144xPC0091_DE1440xPE0720/ DC0144xPC0091_DE1440xPE0720-Pfafstetter 144x91_DC 0 M2/DC144/ +! bin/create_vegdyn_ndvi /discover/nobackup/ltakacs/bcs/Ganymed-4_0/Ganymed-4_0_MERRA-2/DC0288xPC0181_DE1440xPE0720/ DC0288xPC0181_DE1440xPE0720-Pfafstetter 288x181_DC 0 M2/DC288/ +! bin/create_vegdyn_ndvi /discover/nobackup/ltakacs/bcs/Ganymed-4_0/Ganymed-4_0_MERRA-2/DC0576xPC0361_DE1440xPE0720/ DC0576xPC0361_DE1440xPE0720-Pfafstetter 576x361_DC 0 M2/DC576/ +! bin/create_vegdyn_ndvi /discover/nobackup/ltakacs/bcs/Ganymed-4_0/Ganymed-4_0_MERRA-2/DC1152xPC0721_DE1440xPE0720/ DC1152xPC0721_DE1440xPE0720-Pfafstetter 1152x721_DC 0 M2/DC1152/ +! bin/create_vegdyn_ndvi /discover/nobackup/projects/gmao/ssd/land/l_data/geos5/bcs/CLSM_params/mkCatchParam_SMAP_L4SM_v001/SMAP_EASEv2_M36/ SMAP_EASEv2_M36_964x406 964x406_DE 0 smapv1/M36/ +! bin/create_vegdyn_ndvi /discover/nobackup/projects/gmao/ssd/land/l_data/geos5/bcs/CLSM_params/mkCatchParam_SMAP_L4SM_v001/SMAP_EASEv2_M09/ SMAP_EASEv2_M09_3856x1624 3856x1624_DE 0 smapv1/M09/ +! bin/create_vegdyn_ndvi /discover/nobackup/projects/gmao/ssd/land/l_data/geos5/bcs/CLSM_params/mkCatchParam_SMAP_L4SM_v001/DC0576xPC0361_DE0360xPE0180/ DC0576xPC0361_DE0360xPE0180-Pfafstetter 576x361_DC 0 smapv1/DC576/ +! bin/create_vegdyn_ndvi /discover/nobackup/projects/gmao/ssd/land/l_data/geos5/bcs/CLSM_params/mkCatchParam_SMAP_L4SM_v002/SMAP_EASEv2_M36/ SMAP_EASEv2_M36_964x406 964x406_DE 1 smapv2/M36/ +! bin/create_vegdyn_ndvi /discover/nobackup/projects/gmao/ssd/land/l_data/geos5/bcs/CLSM_params/mkCatchParam_SMAP_L4SM_v002/SMAP_EASEv2_M09/ SMAP_EASEv2_M09_3856x1624 3856x1624_DE 1 smapv2/M09/ + + use rmTinyCatchParaMod + + implicit none + + integer :: NTILES, N, I, k, iargc, JPLH + integer, parameter :: nx = 8640, ny = 4320 + + character*400 :: BCSDIR, OUTDIR, GFILE, IMxJM, arg(5) + real, dimension (6) :: VGZ2 = (/35.0, 20.0, 17.0, 0.6, 0.5, 0.6/) ! Dorman and Sellers (1989) + logical :: file_exists + real, pointer, dimension (:) :: z2, z0, ityp + include 'netcdf.inc' + + I = iargc() + IMxJM ='' + GFILE ='' + + if(iargc() /= 5) then + print *, "Wrong Number of arguments: ", iargc() + print *, "Usage : ./create_vegdyn_ndvi BCSDIR GFILE, IMxJM JPLH OUTDIR" + stop + endif + + do n=1,5 + call getarg(n,arg(n)) + enddo + + read(arg(1),'(a)') BCSDIR + read(arg(2),'(a)') GFILE + read(arg(3),'(a)') IMxJM + read(arg(4),* ) JPLH + read(arg(5),'(a)') OUTDIR + + ! create dirs/links + ! ----------------- + + call system('mkdir -p data ; cd data/ ; ln -s /discover/nobackup/projects/gmao/ssd/land/l_data/LandBCs_files_for_mkCatchParam/V001/ CATCH') + call system('mkdir -p '//trim(OUTDIR)) + + open (10,file = trim(BCSDIR)//'/clsm/catchment.def', & + form= 'formatted', action = 'read', status = 'old') + read (10,*) NTILES + close (10, status = 'keep') + + print '(a)', trim(BCSDIR)//'/'//trim(GFILE) + + allocate (ityp (1:NTILES)) + allocate (z2 (1:NTILES)) + + inquire(file=trim(BCSDIR)//'/vegdyn_'//trim(IMxJM)//'.dat',exist=file_exists) + if(file_exists) then + open (10,file = trim(BCSDIR)//'/vegdyn_'//trim(IMxJM)//'.dat',& + form= 'unformatted', action = 'read', status = 'old') + read (10) ityp + close (10) + else + print '(a)', 'MISSING VEGDYN FILE reading from mosaic_veg_typs_fracs' + open (10,file = trim(BCSDIR)//'/clsm/mosaic_veg_typs_fracs',& + form= 'formatted', action = 'read', status = 'old') + do n =1, ntiles + read (10, *) k,k,ityp(n) + end do + end if + + if(JPLH == 1) then + call jpl_canoph_this (ntiles, nx,ny,trim(BCSDIR)//'/rst/'//trim(GFILE), z2) + else + Z2 = VGZ2(NINT(ITYP)) + endif + + open (20,file=trim(OUTDIR)//'vegdyn_'//trim(IMxJM)//'.dat',status='unknown',action='write',form='unformatted', & + convert='little_endian') + + write (20) ityp + write (20) Z2 + + print *,'ITYP : ', minval(ityp), maxval (ityp) + print *,'Z2 : ', minval(z2 ), maxval (z2 ) + + call ascat_r0_this (ntiles, nx,ny,trim(BCSDIR)//'/rst/'//trim(GFILE), z0) + write (20) Z0 + + close (20, status = 'keep') + + print *,'Z0 : ', minval(z0 ), maxval (z0 ) + + call gimms_clim_ndvi (ntiles, nx,ny,trim(BCSDIR)//'/rst/'//trim(GFILE), trim(OUTDIR), trim(IMxJM)) +contains + + +! ----------------------------------------------------------------------------------- + + SUBROUTINE ascat_r0_this (ntiles, nc,nr,gfiler, z0) + + implicit none + + ! 1) ASCAT roughness + ! /discover/nobackup/adarmeno/projects/k14/arlems-roughness.x3600_y1800_t1.nc4 + + integer, intent (in) :: ntiles, nc, nr + real, pointer, dimension (:), intent (inout) :: z0 + character(*), intent (in) :: gfiler + integer , parameter :: N_lon_ascat = 3600, N_lat_ascat = 1800 + integer :: i,j, status, varid, ncid + integer :: tid, cid + REAL, ALLOCATABLE, dimension (:) :: count_pix + REAL, ALLOCATABLE, dimension (:,:) :: z0_grid, data_grid + INTEGER, ALLOCATABLE, dimension (:,:) :: tile_id + character*100 :: fout + + ! READ CLM4.5 source data files and regrid + ! ---------------------------------------- + + status = NF_OPEN ('data/CATCH/arlems-roughness.x3600_y1800_t1.nc4', NF_NOWRITE, ncid) + + allocate (z0_grid (1 : NC , 1 : NR)) + allocate (data_grid (1 : N_lon_ascat, 1 : N_lat_ascat)) + + status = NF_INQ_VARID (ncid,'roughness',VarID) ; VERIFY_(STATUS) + status = NF_GET_VARA_REAL (ncid,VarID, (/1,1,1/),(/N_lon_ascat, N_lat_ascat,1/), data_grid) ; VERIFY_(STATUS) + + call RegridRasterReal(data_grid, z0_grid) + + status = NF_CLOSE(ncid) + + ! Grid to tile + ! ------------ + + ! Reading tile-id raster file + + allocate(tile_id(1:nc,1:nr)) + + open (10,file=trim(gfiler)//'.rst',status='old',action='read', & + form='unformatted',convert='little_endian') + + do j=1,nr + read(10)tile_id(:,j) + end do + + close (10,status='keep') + + allocate (z0 (1:NTILES)) + allocate (count_pix (1:NTILES)) + + z0 = 0. + count_pix = 0. + + do j = 1,nr + do i = 1, nc + if((tile_id(i,j).gt.0).and.(tile_id(i,j).le.NTILES)) then + + ! z0 0. < 0.1 + if((z0_grid(i,j) >= 2.0e-6).and.(z0_grid(i,j) <= 0.1)) then + z0 (tile_id(i,j)) = z0 (tile_id(i,j)) + z0_grid(i,j) + count_pix (tile_id(i,j)) = count_pix (tile_id(i,j)) + 1. + endif + + endif + end do + end do + + where (count_pix > 0.) z0 = z0/count_pix + where (z0 == 0.) z0 = 2.0e-6 + + deallocate (count_pix) + deallocate (z0_grid) + deallocate (tile_id) + + END SUBROUTINE ascat_r0_this + ! ---------------------------------------------------------------------------------------------------------------------------- + + SUBROUTINE gimms_clim_ndvi (ntiles, nc,nr,gfiler, ThisDir, IMxJM) + + implicit none + ! Producing : GIMMS NDVI 15-day climatology from 5 arcmin data + ! 24 values per tile + + integer, intent (in) :: NTILES, nc, nr + character(*), intent (in) :: gfiler, ThisDir, IMxJM + integer , parameter :: N_lon_gimms = 4320, N_lat_gimms = 2160 + integer :: status, varid, ncid1, ncid2,ncid + real, dimension (:,:), allocatable :: ndvi_grid, data_grid + integer, dimension (:,:), allocatable ::data_grid2 + REAL, ALLOCATABLE, dimension (:) :: ndvi, count_pix + INTEGER, ALLOCATABLE, dimension (:,:) :: tile_id + integer :: yr,mn,yr1,mn1, k,t,i,j,l + integer, parameter :: scale_fac = 10000 + real, parameter :: val_min = -0.3, val_max = 1. + + ! Grid to tile + ! ------------ + + ! Reading tile-id raster file + + allocate(tile_id(1:nc,1:nr)) + + open (10,file=trim(gfiler)//'.rst',status='old',action='read', & + form='unformatted',convert='little_endian') + + do j=1,nr + read(10)tile_id(:,j) + end do + + close (10,status='keep') + + ! READ GIMMS NDVI source data files and regrid + ! ---------------------------------------- + + status = NF_OPEN ('data/CATCH/ndvi3g_geo_v1_YYYY_0106.nc4', NF_NOWRITE, ncid1) ; VERIFY_(STATUS) + status = NF_OPEN ('data/CATCH/ndvi3g_geo_v1_YYYY_0712.nc4', NF_NOWRITE, ncid2) ; VERIFY_(STATUS) + status = NF_INQ_VARID (ncid2,'ndvi',VarID) ; VERIFY_(STATUS) + + allocate (ndvi_grid (1:NC,1:NR)) + allocate (data_grid (1 : N_lon_gimms, 1 : N_lat_gimms)) + allocate (data_grid2(1 : N_lon_gimms, 1 : N_lat_gimms)) + allocate (ndvi (1:NTILES)) + allocate (count_pix (1:NTILES)) + + ! writing tile-spaced output + ! -------------------------- + + open (31,file=trim(ThisDir)//'ndvi_clim_'//trim(IMxJM)//'.data',status='unknown',action='write',form='unformatted', & + convert='little_endian') + + do K=0,13 + yr = (k+11)/12 + mn = mod(k+11,12)+1 + yr1= (k+12)/12 + mn1= mod(k+12,12)+1 + + ndvi = 0. + count_pix = 0. + t = k + if (k == 0 ) then + t = 12 + ncid = ncid2 + write(31) float((/yr,mn,16,0,0,0,yr1,mn1,1,0,0,0,NTILES,1/)) + + status = NF_GET_VARA_INT (ncid,VarID, (/1,1,t/),(/N_lon_gimms, N_lat_gimms,1/), data_grid2) ; VERIFY_(STATUS) + + do j = 1, N_lat_gimms + data_grid (:,j) = data_grid2 (:,N_lat_gimms - (j-1)) / real(scale_fac) + end do + + call RegridRasterReal(data_grid, ndvi_grid) + + do j = 1,nr + do i = 1, nc + if((tile_id(i,j).gt.0).and.(tile_id(i,j).le.NTILES)) then + if((ndvi_grid(i,j) >= val_min).and.(ndvi_grid(i,j) <= val_max)) then + ndvi (tile_id(i,j)) = ndvi (tile_id(i,j)) + ndvi_grid(i,j) + count_pix (tile_id(i,j)) = count_pix (tile_id(i,j)) + 1. + endif + endif + end do + end do + + where (count_pix > 0.) ndvi = ndvi /count_pix + write(31) ndvi + + elseif (k == 13) then + + t = 1 + ncid = ncid1 + write(31) float((/yr,mn,1,0,0,0,yr,mn,16,0,0,0,NTILES,1/)) + + status = NF_GET_VARA_INT (ncid,VarID, (/1,1,t/),(/N_lon_gimms, N_lat_gimms,1/), data_grid2) ; VERIFY_(STATUS) + + do j = 1, N_lat_gimms + data_grid (:,j) = data_grid2 (:,N_lat_gimms - (j-1)) / real(scale_fac) + end do + + call RegridRasterReal(data_grid, ndvi_grid) + + do j = 1,nr + do i = 1, nc + if((tile_id(i,j).gt.0).and.(tile_id(i,j).le.NTILES)) then + if((ndvi_grid(i,j) >= val_min).and.(ndvi_grid(i,j) <= val_max)) then + ndvi (tile_id(i,j)) = ndvi (tile_id(i,j)) + ndvi_grid(i,j) + count_pix (tile_id(i,j)) = count_pix (tile_id(i,j)) + 1. + endif + endif + end do + end do + + where (count_pix > 0.) ndvi = ndvi /count_pix + write(31) ndvi + + else + + do l = 1, 0 , -1 + t = k*2 - l + if (k <= 6) ncid = ncid1 + if (k >= 7) ncid = ncid2 + if (k >= 7) t = t - 12 + if(l == 1) write(31) float((/yr,mn,1,0,0,0,yr,mn,16,0,0,0,NTILES,1/)) + if(l == 0) write(31) float((/yr,mn,16,0,0,0,yr1,mn1,1,0,0,0,NTILES,1/)) + + ndvi = 0. + count_pix = 0. + + status = NF_GET_VARA_INT (ncid,VarID, (/1,1,t/),(/N_lon_gimms, N_lat_gimms,1/), data_grid2) ; VERIFY_(STATUS) + + do j = 1, N_lat_gimms + data_grid (:,j) = data_grid2 (:,N_lat_gimms - (j-1)) / real(scale_fac) + end do + + call RegridRasterReal(data_grid, ndvi_grid) + + do j = 1,nr + do i = 1, nc + if((tile_id(i,j).gt.0).and.(tile_id(i,j).le.NTILES)) then + if((ndvi_grid(i,j) >= val_min).and.(ndvi_grid(i,j) <= val_max)) then + ndvi (tile_id(i,j)) = ndvi (tile_id(i,j)) + ndvi_grid(i,j) + count_pix (tile_id(i,j)) = count_pix (tile_id(i,j)) + 1. + endif + endif + end do + end do + + where (count_pix > 0.) ndvi = ndvi /count_pix + write(31) ndvi + + end do + endif + end do + + close(31,status='keep') + + END SUBROUTINE gimms_clim_ndvi + + ! ---------------------------------------------------------------------------------------------------------------------------- + + SUBROUTINE jpl_canoph_this (ntiles, nc,nr,gfiler, z2) + + implicit none + + ! 1) JPL Canopy Height + ! /discover/nobackup/rreichle/l_data/LandBCs_files_for_mkCatchParam/V001//Simard_Pinto_3DGlobalVeg_JGR.nc4 + + integer, intent (in) :: nc, nr, ntiles + real, pointer, dimension (:), intent (inout) :: z2 + character(*), intent (in) :: gfiler + integer , parameter :: N_lon_jpl = 43200, N_lat_jpl = 21600 + integer :: i,j, status, varid, ncid + REAL, ALLOCATABLE, dimension (:) :: count_pix + INTEGER, ALLOCATABLE, dimension (:,:) :: data_grid, z2_grid + INTEGER, ALLOCATABLE, dimension (:,:) :: tile_id + character*100 :: fout + + ! READ JPL source data files and regrid + ! ------------------------------------- + + status = NF_OPEN ('data/CATCH/Simard_Pinto_3DGlobalVeg_JGR.nc4', NF_NOWRITE, ncid) + + allocate (z2_grid (1 : NC , 1 : NR)) + allocate (data_grid (1 : N_lon_jpl, 1 : N_lat_jpl)) + + status = NF_INQ_VARID (ncid,'CanopyHeight',VarID) ; VERIFY_(STATUS) + status = NF_GET_VARA_INT (ncid,VarID, (/1,1/),(/N_lon_jpl, N_lat_jpl/), data_grid) ; VERIFY_(STATUS) + + call RegridRaster(data_grid, z2_grid) + + status = NF_CLOSE(ncid) + + ! Grid to tile + ! ------------ + + ! Reading tile-id raster file + + allocate(tile_id(1:nc,1:nr)) + + open (10,file=trim(gfiler)//'.rst',status='old',action='read', & + form='unformatted',convert='little_endian') + + do j=1,nr + read(10)tile_id(:,j) + end do + + close (10,status='keep') + + if(.not.associated(z2)) allocate (z2 (1:NTILES)) + allocate (count_pix (1:NTILES)) + + z2 = 0. + count_pix = 0. + + do j = 1,nr + do i = 1, nc + if((tile_id(i,j).gt.0).and.(tile_id(i,j).le.NTILES)) then + + if(z2_grid(i,j) >= 0.) then + z2 (tile_id(i,j)) = z2 (tile_id(i,j)) + real (z2_grid(i,j)) + count_pix (tile_id(i,j)) = count_pix (tile_id(i,j)) + 1. + endif + + endif + end do + end do + + where (count_pix > 0.) z2 = z2/count_pix + where (z2 < 0.01) z2 = 0.01 ! to ensure Z2 >= MIN_VEG_HEIGHT + + deallocate (count_pix) + deallocate (z2_grid) + deallocate (tile_id) + + END SUBROUTINE jpl_canoph_this + +!-------------------------------------- + + END PROGRAM create_vegdyn_ndvi diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/Raster/src/easeV2_conv.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/Raster/src/easeV2_conv.F90 index 11fa5cee8..5b7370e6b 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/Raster/src/easeV2_conv.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/Raster/src/easeV2_conv.F90 @@ -14,7 +14,12 @@ module easeV2_conv ! (wgs84_convert.pro, wgs84_inverse.pro) available from ! ftp://sidads.colorado.edu/pub/tools/easegrid/geolocation_tools/ ! + ! Official references: + ! doi:10.3390/ijgi1010032 + ! doi:10.3390/ijgi3031154 -- correction of M25 "map_scale_m" parameters! + ! ! 04-Apr-2013 - reichle + ! 11-Sep-2018 - reichle, mgirotto -- added 'M25' grid parameters ! ! ========================================================================== @@ -24,6 +29,7 @@ module easeV2_conv public :: easeV2_convert public :: easeV2_inverse + public :: easeV2_extent ! ***NEVER*** change these constants to GEOS-5 MAPL constants!!!! @@ -87,8 +93,8 @@ subroutine easeV2_convert (grid, lat, lon, col_ind, row_ind) ! local variables - integer :: cols, rows, scale - real*8 :: dlon, phi, lam, rho, map_scale_m, r0, s0, ms, x, y, sin_phi, q + integer :: cols, rows + real*8 :: dlon, phi, lam, map_scale_m, r0, s0, ms, x, y, sin_phi, q ! --------------------------------------------------------------------- @@ -229,6 +235,14 @@ subroutine easeV2_get_params( grid, map_scale_m, cols, rows, r0, s0 ) r0 = (cols-1)/2.0 s0 = (rows-1)/2.0 + else if (grid .eq. 'M25') then ! 25 km grid + + map_scale_m = 25025.2600000 ! nominal cell size in meters (see doi:10.3390/ijgi3031154) + cols = 1388 + rows = 584 + r0 = (cols-1)/2.0 + s0 = (rows-1)/2.0 + else if (grid .eq. 'M09') then ! SMAP 9 km grid map_scale_m = 9008.055210146 ! nominal cell size in meters @@ -276,6 +290,27 @@ end subroutine easeV2_get_params ! ******************************************************************* + subroutine easeV2_extent( grid, N_cols, N_rows ) + + ! simple wrapper to get N_cols (N_lon) and N_rows (N_lat) + + implicit none + + character*(*), intent(in) :: grid + integer, intent(out) :: N_cols, N_rows + + ! local variables + + real*8 :: map_scale_m, r0, s0 + + ! ------------------------------------------------ + + call easeV2_get_params( grid, map_scale_m, N_cols, N_rows, r0, s0 ) + + end subroutine easeV2_extent + + ! ******************************************************************* + end module easeV2_conv ! =============================== EOF ================================= diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/Raster/src/irrg_model.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/Raster/src/irrg_model.F90 new file mode 100644 index 000000000..1773479f2 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/Raster/src/irrg_model.F90 @@ -0,0 +1,232 @@ +#define VERIFY_(A) IF(A/=0)THEN;PRINT *,'ERROR AT LINE ', __LINE__;STOP;ENDIF +#define ASSERT_(A) if(.not.A)then;print *,'Error:',__FILE__,__LINE__;stop;endif +#include "Raster.h" + + +PROGRAM irrg_model + + use rmTinyCatchParaMod + + implicit none + + integer, parameter :: ncols = 86400, nrows_data = 36000, nrows = 43200, nc = 43200, nr = 21600 + real*4, allocatable :: var_in (:,:), cnt_pix1 (:), cnt_pix2 (:), cnt_pix3 (:), tot_cnt (:) + real, allocatable :: lai_min(:), lai_max(:), lai(:) + real :: yr,mo,dy,hr,mn,ss,yr1,mo1,dy1,hr1,mn1,ss1,nx,ny + integer :: i,j, n, r, ntiles,status, cellid, vid, NCFID + character*400 :: GFILE,arg, LAIFILE + integer, allocatable, dimension (:,:) :: tile_id + integer, pointer :: iraster (:,:) + real, allocatable :: CLM4_pf(:), CLM4_sf(:), CLM4_pt(:), CLM4_st(:) + real :: CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2 + real :: CLMC_pt1, CLMC_pt2, CLMC_st1, CLMC_st2 + INCLUDE 'netcdf.inc' + + I = iargc() + GFILE ='' + call getarg(1,arg) + read(arg,'(a)') GFILE + call getarg(2,arg) + read(arg,'(a)') LAIFILE + + allocate( var_in(ncols,nrows)) + var_in = -9999. + +! open ( 10, file = '/gpfsm/dnb43/projects/p03/LS_PARAMETERS/irrigation/global_gripc/irrigtype_salmon2013.flt', & + open ( 10, file = '/discover/nobackup/rreichle/l_data/LandBCs_files_for_mkCatchParam/V001/irrigtype_salmon2013.flt', & + form = 'unformatted', access='direct', recl=(ncols)) + + !- Read input file:: + print *, " -- Reading in input file -- " + do j = 1, nrows_data + r = nrows -j + 1 +! print *,j,r + read(10,rec=j) var_in(:, r) + do i = 1, ncols + if( var_in(i, r) == 0. ) var_in(i, r) = -9999. + if( var_in(i, r) == 4. ) var_in(i, r) = -9999. + end do + end do + close( 10 ) + +! Reading rst file + + open (10,file='rst/'//trim(gfile)//'.rst',status='old',action='read', & + form='unformatted',convert='little_endian') + allocate (tile_id (1:nc,1:nr)) + + do j=1,nr + read(10)tile_id(:,j) + end do + close (10,status='keep') + +! Reading number of catchments + + open (10,file='clsm/catchment.def',status='old',action='read', & + form='formatted') + read (10, *) ntiles + close (10, status = 'keep') + + allocate(iraster(ncols,nrows),stat=STATUS); VERIFY_(STATUS) + call RegridRaster(tile_id,iraster) + + allocate (cnt_pix1 (1:ntiles)) + allocate (cnt_pix2 (1:ntiles)) + allocate (cnt_pix3 (1:ntiles)) + allocate (tot_cnt (1:ntiles)) + allocate (CLM4_pf (1:ntiles)) + allocate (CLM4_sf (1:ntiles)) + allocate (CLM4_pt (1:ntiles)) + allocate (CLM4_st (1:ntiles)) + allocate (lai_min (ntiles)) + allocate (lai_max (ntiles)) + allocate (lai (ntiles)) + + cnt_pix1 = 0. + cnt_pix2 = 0. + cnt_pix3 = 0. + tot_cnt = 0. + + do j = 1,nrows + do i = 1,ncols + if((iraster (i,j) >=1).and.(iraster (i,j) <=ntiles)) then + tot_cnt (iraster (i,j)) = tot_cnt (iraster (i,j)) + 1. + if (var_in(i,j) == 1) cnt_pix1(iraster (i,j)) = cnt_pix1(iraster (i,j)) + 1. + if (var_in(i,j) == 2) cnt_pix2(iraster (i,j)) = cnt_pix2(iraster (i,j)) + 1. + if (var_in(i,j) == 3) cnt_pix3(iraster (i,j)) = cnt_pix3(iraster (i,j)) + 1. + endif + end do + end do + + cnt_pix1 = cnt_pix1 / tot_cnt + cnt_pix2 = cnt_pix2 / tot_cnt + cnt_pix3 = cnt_pix3 / tot_cnt + + ! CLM typs and laimin, laimax + ! --------------------------- + + open(unit=27, file='clsm/CLM_veg_typs_fracs' ,form='formatted') + + do n=1,ntiles + read (27, *) i,j, CLMC_pt1, CLMC_pt2, CLMC_st1, CLMC_st2, & + CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2, & + CLM4_pt(n), CLM4_st(n), CLM4_pf(n),CLM4_sf(n) + end do + + CLOSE (27, STATUS = 'KEEP') + + lai_max = -9999. + lai_min = 9999. + + open (31, file =trim(LAIFILE), form = 'unformatted', action = 'read', status = 'old') + + READ_LAIFILE : do i = 1,100 + + read (31, IOSTAT= STATUS) yr,mo,dy,hr,mn,ss,yr1,mo1,dy1,hr1,mn1,ss1,nx,ny + if(STATUS /= 0) exit + read(31)lai + + do n = 1, ntiles + if(lai (n) < lai_min (n)) lai_min (n) = lai (n) + if(lai (n) > lai_max (n)) lai_max (n) = lai (n) + end do + + end do READ_LAIFILE + + CLOSE (31, STATUS = 'KEEP') + +! open (10,file = 'clsm/gripc.data', form = 'unformatted', action = 'write', status = 'unknown') +! write (10) cnt_pix1 +! write (10) cnt_pix2 +! write (10) cnt_pix3 +! close (10, status = 'keep') + + status = NF_CREATE ('clsm/irrigation_internal_rst', NF_NETCDF4, NCFID) ; VERIFY_(STATUS) + status = NF_DEF_DIM(NCFID, 'tile' , NTILES, CellID) ; VERIFY_(STATUS) + status = NF_DEF_VAR(NCFID, 'IRRIGFRAC' , NF_FLOAT, 1 ,CellID, vid) ; VERIFY_(STATUS) + status = NF_PUT_ATT_TEXT(NCFID, vid, 'long_name', & + LEN_TRIM('Fraction of irrigated cropland'), & + 'fraction of irrigated cropland') ; VERIFY_(STATUS) + status = NF_PUT_ATT_TEXT(NCFID, vid, 'units', 1,'1') ; VERIFY_(STATUS) + + status = NF_DEF_VAR(NCFID, 'PADDYFRAC' , NF_FLOAT, 1 ,CellID, vid) ; VERIFY_(STATUS) + status = NF_PUT_ATT_TEXT(NCFID, vid, 'long_name', & + LEN_TRIM('fraction of paddy cropland'), & + 'fraction of paddy cropland') ; VERIFY_(STATUS) + status = NF_PUT_ATT_TEXT(NCFID, vid, 'units', 1,'1') ; VERIFY_(STATUS) + + status = NF_DEF_VAR(NCFID, 'LAIMIN' , NF_FLOAT, 1 ,CellID, vid) ; VERIFY_(STATUS) + status = NF_PUT_ATT_TEXT(NCFID, vid, 'long_name', & + LEN_TRIM('Minimum LAI'), 'Minimum LAI') ; VERIFY_(STATUS) + status = NF_PUT_ATT_TEXT(NCFID, vid, 'units', 1,'1') ; VERIFY_(STATUS) + + status = NF_DEF_VAR(NCFID, 'LAIMAX' , NF_FLOAT, 1 ,CellID, vid) ; VERIFY_(STATUS) + status = NF_PUT_ATT_TEXT(NCFID, vid, 'long_name', & + LEN_TRIM('Maximum LAI'), 'Maximum LAI') ; VERIFY_(STATUS) + status = NF_PUT_ATT_TEXT(NCFID, vid, 'units', 1,'1') ; VERIFY_(STATUS) + + status = NF_DEF_VAR(NCFID, 'CLMPT' , NF_FLOAT, 1 ,CellID, vid) ; VERIFY_(STATUS) + status = NF_PUT_ATT_TEXT(NCFID, vid, 'long_name', & + LEN_TRIM('CLM primary type'), 'CLM primary type') ; VERIFY_(STATUS) + status = NF_PUT_ATT_TEXT(NCFID, vid, 'units', 1,'1') ; VERIFY_(STATUS) + + status = NF_DEF_VAR(NCFID, 'CLMST' , NF_FLOAT, 1 ,CellID, vid) ; VERIFY_(STATUS) + status = NF_PUT_ATT_TEXT(NCFID, vid, 'long_name', & + LEN_TRIM('CLM secondary type'), 'CLM secondary type') ; VERIFY_(STATUS) + status = NF_PUT_ATT_TEXT(NCFID, vid, 'units', 1,'1') ; VERIFY_(STATUS) + + status = NF_DEF_VAR(NCFID, 'CLMPF' , NF_FLOAT, 1 ,CellID, vid) ; VERIFY_(STATUS) + status = NF_PUT_ATT_TEXT(NCFID, vid, 'long_name', & + LEN_TRIM('CLM primary fraction'), 'CLM primary fraction') ; VERIFY_(STATUS) + status = NF_PUT_ATT_TEXT(NCFID, vid, 'units', 1,'1') ; VERIFY_(STATUS) + + status = NF_DEF_VAR(NCFID, 'CLMSF' , NF_FLOAT, 1 ,CellID, vid) ; VERIFY_(STATUS) + status = NF_PUT_ATT_TEXT(NCFID, vid, 'long_name', & + LEN_TRIM('CLM secondary fraction'), 'CLM secondary fraction') ; VERIFY_(STATUS) + status = NF_PUT_ATT_TEXT(NCFID, vid, 'units', 1,'1') ; VERIFY_(STATUS) + + status = NF_ENDDEF(NCFID) + + status = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'IRRIGFRAC') ,(/1/),(/NTILES/), cnt_pix2) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'PADDYFRAC') ,(/1/),(/NTILES/), cnt_pix3) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'LAIMIN' ) ,(/1/),(/NTILES/), lai_min) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'LAIMAX' ) ,(/1/),(/NTILES/), lai_max) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'CLMPT' ) ,(/1/),(/NTILES/), CLM4_pt) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'CLMST' ) ,(/1/),(/NTILES/), CLM4_st) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'CLMPF' ) ,(/1/),(/NTILES/), CLM4_pf/100.); VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'CLMSF' ) ,(/1/),(/NTILES/), CLM4_sf/100.); VERIFY_(STATUS) + STATUS = NF_CLOSE (NCFID) + + contains + + ! ---------------------------------------------------------------------- + + integer function VarID (NCFID, VNAME) + + integer, intent (in) :: NCFID + character(*), intent (in) :: VNAME + integer :: status + + STATUS = NF_INQ_VARID (NCFID, trim(VNAME) ,VarID) + IF (STATUS .NE. NF_NOERR) & + CALL HANDLE_ERR(STATUS, trim(VNAME)) + + end function VarID + + ! ----------------------------------------------------------------------- + + SUBROUTINE HANDLE_ERR(STATUS, Line) + + INTEGER, INTENT (IN) :: STATUS + CHARACTER(*), INTENT (IN) :: Line + + IF (STATUS .NE. NF_NOERR) THEN + PRINT *, trim(Line),': ',NF_STRERROR(STATUS) + STOP 'Stopped' + ENDIF + + END SUBROUTINE HANDLE_ERR + + ! ----------------------------------------------------------------------------- + +END PROGRAM irrg_model diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/Raster/src/mkCatchParam.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/Raster/src/mkCatchParam.F90 index 48cadb469..61c30c687 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/Raster/src/mkCatchParam.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/Raster/src/mkCatchParam.F90 @@ -11,7 +11,9 @@ PROGRAM mkCatchParam ! -y: Size of latitude dimension of input raster. DEFAULT: 4320 ! -b: position of the dateline in the first box. DEFAULT: DC ! -g: Gridname (name of the .til or .rst file without file extension) -! -l: Choice of LAI data set. DEFAULT : MODISV6 +! -l: Choice of LAI data set. DEFAULT : MODGEO +! GLASSA : 8-day AVHRR climatology from the period 1981-2017 on 7200x3600 grid +! GLASSM : 8-day MODIS climatology from the period 2000-2017 on 7200x3600 grid ! MODISV6 : 8-day climatology from the period 2002.01-2016.10 on 86400x43200 grid ! MODGEO : MODIS with GEOLAND2 overlaid on South America, Afirca and Australia ! GEOLAND2: 10-day climatology from the period 1999-2011 on 40320x20160 grid @@ -53,7 +55,7 @@ PROGRAM mkCatchParam integer :: I, J, iargc, nxt real*8 :: dx, dy, lon0 logical :: regrid - character(len=400), dimension (20) :: Usage + character(len=400), dimension (22) :: Usage character*128 :: Grid2 character*2 :: poles CHARACTER*100 :: gfile,fname,pdir,rstdir @@ -84,21 +86,23 @@ PROGRAM mkCatchParam USAGE(3) =" -y: Size of latitude dimension of input raster. DEFAULT: 4320 " USAGE(4) =" -g: Gridname (name of the .til or .rst file without file extension) " USAGE(5) =" -b: Position of the dateline in the first grid box (DC or DE). DEFAULT: DC " - USAGE(6) =" -l: Choice of LAI data set. DEFAULT : MODIS " - USAGE(7) =" MODISV6 : 8-day climatology from the period 2002.01-2016.10 on 86400x43200 grid " - USAGE(8) =" MODGEO : MODIS with GEOLAND2 overlaid on South America, Africa and Australia " - USAGE(9) =" GEOLAND2: 10-day climatology from the period 1999-2011 on 40320x20160 grid " - USAGE(10)=" GSWP2 : Monthly climatology from the period 1982-1998 on 360x180 grid " - USAGE(11)=" GSWPH : Monthly climatology from the period 1982-1998 on 43200x21600 grid " - USAGE(12)=" MODIS : 8-day climatology from the period 2000-2013 on 43200x21600 grid " - USAGE(13)=" -s: Choice of soil data. DEFAULT :HWSD " - USAGE(14)=" HWSD : Merged HWSD-STATSGO2 soil properties on 43200x21600 with Woesten (1999) Parameters" - USAGE(15)=" NGDC : Reynolds soil texture classes on 4320x2160 with GSWP2 soil hydraulic parameters " - USAGE(16)=" -m: Choice of MODIS Albedo data. DEFAULT : MODIS2 " - USAGE(17)=" MODIS1: 16-day Climatology from 1'x1'(21600x10800) MODIS data from the period 2000-2004 " - USAGE(18)=" MODIS2: 8-day Climatology from 0.5'x0.5'(43200x21600) MODIS data from the period 2001-2011" - USAGE(19)=" -e: EASE : This is optional if catchment.def file is available already or " - USAGE(20)=" the til file format is pre-Fortuna-2. " + USAGE(6) =" -l: Choice of LAI data set. DEFAULT : MODGEO " + USAGE(7) =" GLASSA : 8-day AVHRR climatology from the period 1981-2017 on 7200x3600 grid " + USAGE(8) =" GLASSM : 8-day MODIS climatology from the period 2000-2017 on 7200x3600 grid " + USAGE(9) =" MODISV6 : 8-day climatology from the period 2002.01-2016.10 on 86400x43200 grid " + USAGE(10)=" MODGEO : MODIS with GEOLAND2 overlaid on South America, Africa and Australia " + USAGE(11)=" GEOLAND2: 10-day climatology from the period 1999-2011 on 40320x20160 grid " + USAGE(12)=" GSWP2 : Monthly climatology from the period 1982-1998 on 360x180 grid " + USAGE(13)=" GSWPH : Monthly climatology from the period 1982-1998 on 43200x21600 grid " + USAGE(14)=" MODIS : 8-day climatology from the period 2000-2013 on 43200x21600 grid " + USAGE(15)=" -s: Choice of soil data. DEFAULT :HWSD " + USAGE(16)=" HWSD : Merged HWSD-STATSGO2 soil properties on 43200x21600 with Woesten (1999) Parameters" + USAGE(17)=" NGDC : Reynolds soil texture classes on 4320x2160 with GSWP2 soil hydraulic parameters " + USAGE(18)=" -m: Choice of MODIS Albedo data. DEFAULT : MODIS2 " + USAGE(19)=" MODIS1: 16-day Climatology from 1'x1'(21600x10800) MODIS data from the period 2000-2004 " + USAGE(20)=" MODIS2: 8-day Climatology from 0.5'x0.5'(43200x21600) MODIS data from period 2001-2011 " + USAGE(21)=" -e: EASE : This is optional if catchment.def file is available already or " + USAGE(22)=" the til file format is pre-Fortuna-2. " ! Process Arguments !------------------ @@ -210,7 +214,9 @@ PROGRAM mkCatchParam DL = 'DE' write (log_file,'(a)')'Cube Grid - assuming DE' endif - + + CALL open_landparam_nc4_files + ! Creating catchment.def ! ---------------------- @@ -319,6 +325,16 @@ PROGRAM mkCatchParam lai_name = 'MCD15A2H.006/MODIS_' call grid2tile_modis6 (86400,43200,nc,nr,gridnamer,lai_name) endif + + if (trim(LD) == 'GLASSA') then + lai_name = 'GLASS-LAI/AVHRR.v4/GLASS01B02.V04.AYYYY' + call grid2tile_glass (nc,nr,gridnamer,lai_name) + endif + + if (trim(LD) == 'GLASSM') then + lai_name = 'GLASS-LAI/MODIS.v4/GLASS01B01.V04.AYYYY' + call grid2tile_glass (nc,nr,gridnamer,lai_name) + endif endif diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/Raster/src/mkSMAPTilesPara.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/Raster/src/mkSMAPTilesPara.F90 index 8513887d3..d29d3ac87 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/Raster/src/mkSMAPTilesPara.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/Raster/src/mkSMAPTilesPara.F90 @@ -1,4 +1,4 @@ -PROGRAM mkSMAPTilesPara +PROGRAM mkSMAPTilesPara_v1 ! This program constructs land and lake tiles for the SMAP-EASE-M09 and M36 grids (just set MGRID) ! for CLSM implementation. ! f90 -c create_smap_tiles.f90 @@ -8,37 +8,64 @@ PROGRAM mkSMAPTilesPara use easeV1_conv use rmTinyCatchParaMod use process_hres_data + use MAPL_SortMod + use MAPL_ConstantsMod implicit none - integer nc,nr,i,j,icount(21),ig,jg,i0,iop,n,d1,d2,j1 - parameter (nc=8640,nr=4320) - integer,allocatable :: tileid_index(:,:),catid(:,:),catid_index(:,:) - integer,allocatable, dimension (:) :: land_id,water_id,ice_id,pfaf_array - real, allocatable, dimension (:) :: smap_grid_area,tile_area,lat_c,lon_c + + integer i,j,ig,jg,i0,iop,n,d1,d2,j1,j2,i1,i2,ix, jx,icount,pcount + integer :: NC = i_raster, NR = j_raster, NT = 16330000, ND = 10000, ND_raster = 10000 + + integer, parameter :: SRTM_maxcat = 291284, nc_esa = 129600, nr_esa = 64800 + + ! For regridding + + integer, allocatable, target, dimension (:,:) & + :: geos_msk + REAL, allocatable, DIMENSION (:) :: loc_val + INTEGER, ALLOCATABLE, DIMENSION (:) :: density, loc_int + logical, dimension (:), allocatable :: unq_mask + integer, pointer , dimension (:,:) :: subset + integer, pointer , dimension (:) :: subset1, subset_smap + real, pointer , dimension (:) :: subset2 + integer :: dx_esa, dy_esa, NBINS, NPLUS + + integer*8, allocatable, dimension (:) :: SRTM_catid + + integer,allocatable, dimension (:,:), target :: tileid_index,catid_index + integer,allocatable, dimension (:,:) :: catid, iaster + integer,allocatable, dimension (:) :: land_id,water_id,ice_id + integer,allocatable, dimension (:) :: my_land, all_id + real, allocatable, dimension (:) :: smap_grid_area,tile_area,SRTM_CatchArea + integer*1,allocatable, dimension (:,:) :: veg, i2aster + real*4, dimension (:,:), allocatable :: q0,raster + REAL, dimension (:), allocatable :: tile_ele, tile_area_land + + INTEGER*8 :: PFAF_CODE integer l,imn,imx,jmn,jmx,mval,l_index,i_index,w_index,typ,pfaf,cindex - character(3) :: easegrid - integer*1,allocatable :: veg(:,:) - real :: clat, clon, r_smap, s_smap, smap_convert, da!, smap_inverse, & -! ezlh_convert, ezlh_inverse, easeV1_convert, easeV1_inverse + integer :: LakeType, IceType, OceanType + character(3) :: easegrid + real :: clat, clon, r_smap, s_smap, smap_convert, da real :: fr_gcm - integer :: ind_col, ind_row, status - REAL (kind=8), PARAMETER :: RADIUS=6371000.,pi=3.1415926535898 + integer :: ind_col, ind_row, status, ncid, nciv,nland_cells, DOM_INDX + REAL (kind=8), PARAMETER :: RADIUS=6378137.0,pi=3.14159265358979323846 character*100 :: veg_class (12) character*5 :: MGRID - character*100 :: gfile,gtopo30,pathout - integer :: nc_smap,nr_smap, N_args, iargc + character*100 :: gfile,gtopo30 + integer :: nc_smap,nr_smap, N_args, iargc real :: EASE_grid_area, CELL_km - real*4, dimension (:,:), allocatable :: q0 - REAL, dimension (:), allocatable :: tile_ele, tile_area_land - REAL :: dx,dy,d2r,lats,mnx,mxx,mny,mxy,sum1,sum2,jgv + REAL :: dx,dy,d2r,lats,mnx,mxx,mny,mxy,sum1,sum2,jgv, VDUM,pix_area character(40) :: arg - character*200 :: tmpstring - + character*200 :: tmpstring, tmpstring1, tmpstring2 + logical :: regrid = .false. + character*128 :: MaskFile + include 'netcdf.inc' + N_args = iargc() if(N_args < 1) then - print *,'USAGE : bin/mkSMAPTiles -smap_grid MXX' - print *,'Allowed SMAP grids are: M01 M03 M09 M25 M36' + print *,'USAGE : bin/mkSMAPTiles_v1 -smap_grid MXX' + print *,'Allowed SMAP grids are: M25' stop end if @@ -46,226 +73,368 @@ PROGRAM mkSMAPTilesPara do while ( i < N_args ) - i = i+1 - - call getarg(i,arg) - - if ( trim(arg) == '-smap_grid' ) then - i = i+1 - call getarg(i,MGRID) - - else ! stop for any other arguments - - print *,'USAGE : bin/mkSMAPTiles -smap_grid MXX' - print *,'Allowed SMAP grids are: M09 M36 Ml' - stop - - endif - - end do - - call system('cd data/ ; ln -s /discover/nobackup/projects/gmao/ssd/land/l_data/LandBCs_files_for_mkCatchParam/V001/ CATCH') - call system('cd ..') + i = i+1 + + call getarg(i,arg) + + if ( trim(arg) == '-smap_grid' ) then + i = i+1 + call getarg(i,MGRID) + + else ! stop for any other arguments + + print *,'USAGE : bin/mkSMAPTiles -smap_grid MXX' + print *,'Allowed SMAP grids are: M09 M36 Ml' + stop + + endif + + end do - gtopo30 = 'data/CATCH/srtm30_withKMS_2.5x2.5min.data' - - allocate(q0(nc,nr)) - dx = 360._8/nc - dy = 180._8/nr - d2r = PI/180._8 - - open (10,file=trim(gtopo30),form='unformatted',status='old',convert='little_endian') - read (10) q0 - close (10,status='keep') - pathout ='clsm/' - - if (trim(MGRID) == 'M09') then - - nc_smap = 3852 - nr_smap = 1632 - gfile = 'SMAP_EASE_'//trim(MGRID)//'_3852x1632' - EASE_grid_area = 81.001812568020028 - - elseif(trim(MGRID) == 'M36') then - - nc_smap = 963 - nr_smap = 408 - gfile = 'SMAP_EASE_'//trim(MGRID)//'_963x408' - EASE_grid_area = 1296.029001087600 - - elseif(trim(MGRID) == 'M25') then + call system('cd data/ ; ln -s /discover/nobackup/projects/gmao/ssd/land/l_data/LandBCs_files_for_mkCatchParam/V001/ CATCH') + call system('cd ..') + + ! Setting SMAP Grid specifications + ! -------------------------------- + + if (trim(MGRID) == 'M25') then + CELL_km = 25.067525 ! nominal cell size in kilometers nc_smap = 1383 nr_smap = 586 gfile = 'SMAP_EASE_M25_1383x586' - EASE_grid_area = 628.3808529246343824 - - else if (trim(MGRID) .eq. 'M03') then ! SMAP 3 km grid - CELL_km = 3.00003356589 ! nominal cell size in kilometers - nc_smap = 11556 - nr_smap = 4896 - gfile = 'SMAP_EASE_M03_11556x4896' - EASE_grid_area = CELL_km*CELL_km - - else if (trim(MGRID) .eq. 'M01') then ! SMAP 1 km grid - CELL_km = 1.00001118863 ! nominal cell size in kilometers - nc_smap = 34668 - nr_smap = 14688 - gfile = 'SMAP_EASE_M01_34668x114688' - EASE_grid_area = CELL_km*CELL_km - + EASE_grid_area = CELL_km*CELL_km + else ! - + print *,'Unknown SMAP Grid stopping..' stop - + endif - - ! Simple Biosphere 2 Model Legend - ! Value Class Name - ! (ftp://edcftp.cr.usgs.gov/pub/data/glcc/globe/latlon/sib22_0.leg) - ! the types vary 0-11 (array index minus 1) - - veg_class(1) = 'Ocean' - veg_class(2) = 'Broadleaf Evergreen Trees' - veg_class(3) = 'Broadleaf Deciduous Trees' - veg_class(4) = 'Broadleaf and Needleleaf Trees' - veg_class(5) = 'Needleleaf Evergreen Trees' - veg_class(6) = 'Needleleaf Deciduous Trees' - veg_class(7) = 'Short Vegetation/C4 Grassland' - veg_class(8) = 'Shrubs with Bare Soil' - veg_class(9) = 'Dwarf Trees and Shrubs' - veg_class(10) = 'Agriculture or C3 Grassland' - veg_class(11) = 'Water, Wetlands' - veg_class(12) = 'Ice/Snow' - - allocate(veg (1:nc,1:nr)) - allocate(tileid_index(1:nc,1:nr)) - allocate(catid (1:nc,1:nr)) - allocate(catid_index (1:nc,1:nr)) - allocate(land_id (1:16330000)) - allocate(water_id (1:16330000)) - allocate(ice_id (1:16330000)) - - da = radius*radius*pi*pi/24./24./180./180./1000000. - - tileid_index=0 - land_id =0 - water_id=0 - ice_id=0 - - ! reading SiB2 land cover classification data - the origin of the - ! 2.5'x2.5' vegetation raster file is global 1min IGBP data - ! (ftp://edcftp.cr.usgs.gov/pub/data/glcc/globe/latlon/sib22_0.leg) - - open (10,file='data/CATCH/sib22.5_v2.0.dat', & - form='unformatted', & - action='read', convert='big_endian',status='old') - - READ(10)veg - - close (10,status='keep') - -! ! reading 2.5'x2.5' global raster file of Pfafstetter Catchment IDs -! ! In this version, the dateline has been overlaid over the catchments those straddle -! ! across. The numbers contain for -! ! 1 global ocean catchment : Pfafstetter ID 0 -! ! 36716 global land catchments : Pfafstetter IDs 1000-5999900 -! ! 1 global inland water (lakes) catchment : Pfafstetter ID 6190000 -! ! 1 global ice catchment : Pfafstetter ID 6200000 -! - open (10,file='data/CATCH/global.cat_id.catch.DL', form='formatted', & - action='read', status='old')! - - do j=1,nr - read(10,*)(catid(i,j),i=1,nc) - end do - close (10,status='keep') + allocate(land_id (1:NT)) + allocate(water_id (1:NT)) + allocate(ice_id (1:NT)) + land_id = 0 + water_id = 0 + ice_id = 0 + OceanType = 0 + IceType =11 + LakeType =10 + + ND = 10*10**(nint(log10(1.*nr_smap))) - print *,'Read global.cat_id.catch.DL' - print *,'Min and Max of Pfafstetter IDs:', minval(catid),maxval(catid) - - ! reading the 2.5'x2.5' global raster file of tile indices for the - ! above Pfafstetter Catchments - ! 1 global ocean catchment : tile_index 36719 - ! 36716 global land catchments : tile_index 1-36716 - ! 1 global inland water (lakes) catchment : tile_index 36717 - ! 1 global ice catchment : tile_index 36718 + ! Check for the 10 arc-sec MaskFile + ! ----------------------------------- + + call getenv ("MASKFILE" ,MaskFile ) - open (10,file='data/CATCH/' & - //'PfafstatterDL.rst', form='unformatted', & - action='read',convert='little_endian', status='old') + print *, 'Using MaskFile ', trim(MaskFile) - do j=1,nr - read(10)(catid_index(i,j),i=1,nc) - end do + if (index(MaskFile,'GEOS5_10arcsec_mask') /= 0) then + ! New ESA (Veg) + SRTM (catchments) based mask file + ! is overlaid on SMAP + ! ------------------------------------------------- + + nc = 43200 ! Number of rows in raster file + nr = 21600 ! Number of columns in raster file + + regrid = .true. + dx_esa = nc_esa / nc ! x-dimension (or # of ESA columns within the raster grid cell) + dy_esa = nr_esa / nr ! y-dimension (or # of ESA rows within the raster grid cell) + + allocate(tileid_index(1:nc,1:nr)) + allocate(SRTM_catid (1:SRTM_maxcat+2)) + allocate(catid_index (1:nc,1:nr)) + allocate(veg (1:nc,1:nr)) + allocate(geos_msk (1:nc_esa,1:dy_esa)) + allocate(SRTM_CatchArea (1:SRTM_maxcat)) + + OPEN (10, FILE = 'data/CATCH/SRTM-TopoData/Pfafcatch-routing.dat', & + FORM = 'FORMATTED',STATUS='OLD',ACTION='READ') + + READ (10,*) I + DO N = 1, I + READ (10, '(i8,i15,4(1x,f9.4),1x,e10.3,4(1x,e9.3),I8,6(1x,f9.4))') & + DOM_INDX,PFAF_CODE,VDUM,VDUM,VDUM,VDUM,VDUM, & + SRTM_CatchArea (N) + END DO + CLOSE (10, STATUS='KEEP') + + dx = 360._8/nc + dy = 180._8/nr + d2r = PI/180._8 + da = MAPL_radius*MAPL_radius*pi*pi*dx*dy/180./180./1000000. + + tileid_index = 0 + catid_index = 0 + veg = 0 + + status = NF_OPEN ('data/CATCH/GEOS5_10arcsec_mask.nc', NF_NOWRITE, ncid) + status = NF_GET_VARA_INT64 (ncid,3,(/1/),(/SRTM_maxcat/),SRTM_catid(1:SRTM_maxcat)) ! Read pfafstetter IDs + if(status /=0) then + PRINT *, NF_STRERROR(STATUS) + print *, 'Problem with NF_OPEN',trim(MaskFile) + endif - close (10,status='keep') + SRTM_catid (SRTM_maxcat + 1) = 190000000 + SRTM_catid (SRTM_maxcat + 2) = 200000000 + i1 = 0 ! count # of 30-arcsec pixels - print *,'Read PfafstatterDL.rst' - print *,'Min and Max of tile indices:',minval(catid_index),maxval(catid_index) + do j=1,nr - ! Deriving SiB2 vegetation classification histogram + clat = -90. + float(j-1)*dy + dy/2. - icount=0 + status = NF_GET_VARA_INT (ncid,4,(/1,(j-1)*dy_esa +1/),(/nc_esa,dy_esa/),geos_msk) ! Read 10-arcsec rows that lie within the raster row 'j' + + if(status /=0) then + PRINT *, NF_STRERROR(STATUS) + print *, 'Problem with NF_GET_VARA_INT',trim(MaskFile),status + endif + + do i = 1,nc - do j=1,nr - do i=1,nc - icount(veg(i,j)+1)= icount(veg(i,j)+1) +1 - end do - end do + clon = -180. + float(i-1)*dx + dx/2. - open (10,file='clsm/vegetation.hst2',form='formatted') + if (associated (subset)) NULLIFY (subset) + subset => geos_msk ((i-1)*dx_esa + 1 : i*dx_esa, 1:dy_esa) ! rectangular array contains ESA pixels that lie within the raster grid cell at i,j + if(maxval (subset) > SRTM_maxcat) then + where (subset == 190000000) subset = SRTM_maxcat + 1 + where (subset == 200000000) subset = SRTM_maxcat + 2 + endif + + if (maxval (subset) > 0) then ! check whether there are Non-ocean ESA pixels + ! catID of the middle pixel + + veg (i,j) = 1 ! veg is set to land + + NPLUS = count(subset >= 1 .and. subset <= SRTM_maxcat + 2) ! Count non-ocean ESA pixels within + allocate (loc_int (1:NPLUS)) + allocate (unq_mask(1:NPLUS)) + loc_int = pack(subset,mask = (subset >= 1 .and. subset <= SRTM_maxcat + 2)) ! loc_int contains catch_indices of non-ocean ESA pixels + call MAPL_Sort (loc_int) + unq_mask = .true. + do n = 2,NPLUS + unq_mask(n) = .not.(loc_int(n) == loc_int(n-1)) ! count number of unique numbers in loc_int for binning + end do + NBINS = count(unq_mask) + + if (NBINS > 1) then + allocate(loc_val (1:NBINS)) + allocate(density (1:NBINS)) + loc_val = 1.*pack(loc_int,mask =unq_mask) ! loc_val contains available non-ocean catch_indices within the i,j grid cell, + ! Those numbers will be used as bin values + call histogram (dx_esa*dy_esa, NBINS, density, loc_val, real(subset)) ! density is the pixel count for each bin value + catid_index (i,j) = loc_val (maxloc(density,1)) ! picks maximum density as the dominant catchment_index at i,j + deallocate (loc_val, density) + else + catid_index (i,j) = loc_int (1) + endif + deallocate (loc_int, unq_mask) + + if(catid_index (i,j) == SRTM_maxcat + 1) veg (i,j) = LakeType + if(catid_index (i,j) == SRTM_maxcat + 2) veg (i,j) = IceType + if((catid_index(i,j) >= 1).and.(catid_index (i,j) <= SRTM_maxcat)) i1 = i1 + 1 + + ! count in if this is i,j pixel is a land, lake or ice within ind_col,ind_row SMAP grid cell + + call easeV1_convert(trim(MGRID), clat, clon, r_smap, s_smap) + + ind_col = nint(r_smap) + 1 + ind_row = nint(s_smap) + 1 + + if((ind_row.ge.1).and.(veg(i,j).ne.OceanType).and.(ind_row.le.nr_smap)) then + l= ind_row*ND + ind_col + + if(veg(i,j)==LakeType) then + water_id(l) = 1 + else if(veg(i,j)==IceType) then + ice_id (l) = 1 + else + land_id (l) = 1 + endif + endif + endif + end do + enddo - do i=1,12 - write (10,'(i2,i10,1x,a100)')i-1,icount(i),veg_class(i) - end do + status = NF_CLOSE (ncid) + deallocate (geos_msk) - write (10,*)'-----------------------' - write(10,*)' ',sum(icount) - close (10,status='keep') - write (*,*)'End reading Sib2 vegetation classification' -! -! While looping through the 2.5'x2.5' grid, this section counts presence of -! land, ice and water on the SMAP GIRD. -! Each SMAP grid cell is assigned with an ID = ind_row*10000 + ind_col -! ind_col, ind_row are overlying SMAP grid cell indices -! This is just the prelimiminery assessment in the process of assigning separate -! tiles for land, water and ice fractions within the SMAP Grid cell -! The program checks all the underlying 2.5x2.5 cells for each SMAP EASE grid cell separately -! and counts the number of SMAP EASE water, land and ice grid cells were observed. -! - do i = 1 ,nc + print *,'Read ', trim (MaskFile) + print *,'Min and Max of tile indices:',minval(catid_index),maxval(catid_index) - clon = -180. + float(i-1)*2.5/60. + 1.25/60. + else - do j =nr ,1 ,-1 - - clat = -90. + float(j-1)*2.5/60. + 1.25/60. - - call easeV1_convert(trim(MGRID), clat, clon, r_smap, s_smap) - -! if(trim(MGRID) == 'Ml') then -! status = ezlh_convert(trim(MGRID), clat, clon, r_smap, s_smap) -! else -! status = smap_convert(trim(MGRID), clat, clon, r_smap, s_smap) -! endif - - ind_col = nint(r_smap) + 1 - ind_row = nint(s_smap) + 1 - - if((ind_row.ge.1).and.(veg(i,j).ge.1).and.(ind_row.le.1632)) then - l= ind_row*10000 + ind_col + ! Old IGBP (Veg) + HYDRO1k (catchments) based mask will + ! Overlaid on SMAP mask + ! ----------------------------------------------------- + + allocate(iaster (i_raster,j_raster)) + allocate(i2aster (i_raster,j_raster)) + allocate(veg (1:nc,1:nr)) + allocate(catid (1:nc,1:nr)) + allocate(catid_index (1:nc,1:nr)) + allocate(tileid_index(1:nc,1:nr)) + + dx = 360._8/nc + dy = 180._8/nr + d2r = PI/180._8 + da = MAPL_radius*MAPL_radius*pi*pi*dx*dy/180./180./1000000. + + tileid_index = 0 - if(veg(i,j)==10) water_id(l) = 1 - if(veg(i,j)==11) ice_id (l) = 1 - if(veg(i,j).lt.10)land_id (l) = 1 - endif - + ! Simple Biosphere 2 Model Legend + ! Value Class Name + ! (ftp://edcftp.cr.usgs.gov/pub/data/glcc/globe/latlon/sib22_0.leg) + ! the types vary 0-11 (array index minus 1) + + veg_class(1) = 'Ocean' + veg_class(2) = 'Broadleaf Evergreen Trees' + veg_class(3) = 'Broadleaf Deciduous Trees' + veg_class(4) = 'Broadleaf and Needleleaf Trees' + veg_class(5) = 'Needleleaf Evergreen Trees' + veg_class(6) = 'Needleleaf Deciduous Trees' + veg_class(7) = 'Short Vegetation/C4 Grassland' + veg_class(8) = 'Shrubs with Bare Soil' + veg_class(9) = 'Dwarf Trees and Shrubs' + veg_class(10) = 'Agriculture or C3 Grassland' + veg_class(11) = 'Water, Wetlands' + veg_class(12) = 'Ice/Snow' + + ! reading SiB2 land cover classification data - the origin of the + ! 2.5'x2.5' vegetation raster file is global 1min IGBP data + ! (ftp://edcftp.cr.usgs.gov/pub/data/glcc/globe/latlon/sib22_0.leg) + + open (10,file='data/CATCH/sib22.5_v2.0.dat', & + form='unformatted', & + action='read', convert='big_endian',status='old') + + READ(10)i2aster + + close (10,status='keep') + + if(regrid) then + call RegridRaster1 (i2aster,veg) + else + veg = i2aster + endif + + deallocate (i2aster) + + ! reading 2.5'x2.5' global raster file of Pfafstetter Catchment IDs + ! In this version, the dateline has been overlaid over the catchments those straddle + ! across. The numbers contain for + ! 1 global ocean catchment : Pfafstetter ID 0 + ! 36716 global land catchments : Pfafstetter IDs 1000-5999900 + ! 1 global inland water (lakes) catchment : Pfafstetter ID 6190000 + ! 1 global ice catchment : Pfafstetter ID 6200000 + + open (10,file='data/CATCH/global.cat_id.catch.DL', form='formatted', & + action='read', status='old')! + + do j=1,j_raster + read(10,*)(iaster(i,j),i=1,i_raster) + end do + + close (10,status='keep') + + if(regrid) then + call RegridRaster(iaster,catid) + else + catid = iaster + endif + + print *,'Read global.cat_id.catch.DL' + print *,'Min and Max of Pfafstetter IDs:', minval(catid),maxval(catid) + + ! reading the 2.5'x2.5' global raster file of tile indices for the + ! above Pfafstetter Catchments + ! 1 global ocean catchment : tile_index 36719 + ! 36716 global land catchments : tile_index 1-36716 + ! 1 global inland water (lakes) catchment : tile_index 36717 + ! 1 global ice catchment : tile_index 36718 + ! ------------------------------------------------------------ + + open (10,file='data/CATCH/' & + //'PfafstatterDL.rst', form='unformatted', & + action='read',convert='little_endian', status='old') + + do j=1,j_raster + read(10)(iaster(i,j),i=1,i_raster) + end do + + close (10,status='keep') + + if(regrid) then + call RegridRaster(iaster,catid_index) + else + catid_index = iaster + endif + + deallocate (iaster) + + print *,'Read PfafstatterDL.rst' + print *,'Min and Max of tile indices:',minval(catid_index),maxval(catid_index) + + ! While looping through the nc x nr grid (tile raster), this section counts # of + ! SMAP grid cells that contain land, ice or water, seperately. + ! Each SMAP grid cell is assigned with an ID = ind_row*ND + ind_col. + ! This is just the prelimiminery assessment in the process of assigning separate + ! tiles for land, water and ice fractions within the SMAP Grid cell + ! The program checks each nc x nr pixels whether there is a SMAP grid cell underneath, and counts + ! number of water, land and ice pixels as seen on veg raster. + ! ----------------------------------------------------------------------------------------------- + + + do i = 1 ,nc + + clon = -180. + float(i-1)*dx + dx/2. + + do j =nr ,1 ,-1 + + clat = -90. + float(j-1)*dy + dy/2. + call easeV1_convert(trim(MGRID), clat, clon, r_smap, s_smap) + + ind_col = nint(r_smap) + 1 + ind_row = nint(s_smap) + 1 + + if((ind_row.ge.1).and.(veg(i,j).ne.OceanType).and.(ind_row.le.nr_smap)) then + l= ind_row*ND + ind_col + + if(veg(i,j)==LakeType) then + water_id(l) = 1 + else if(veg(i,j)==IceType) then + ice_id (l) = 1 + else + land_id (l) = 1 + endif + endif + end do end do - end do + endif + + ! Reading SRTM elevation data - to be consistent with AGCM + ! -------------------------------------------------------- + + allocate(raster (i_raster,j_raster)) + allocate(q0(nc,nr)) + + gtopo30 = 'data/CATCH/srtm30_withKMS_2.5x2.5min.data' + + open (10,file=trim(gtopo30),form='unformatted',status='old',convert='little_endian') + read (10) raster + close (10,status='keep') + + if(regrid) then + call RegridRasterReal(raster,q0) + else + q0 = raster + endif + + deallocate (raster) + print *,'# of Land pixels in SMAP: ',sum (land_id) print *,'# of water pixels in SMAP: ',sum (water_id) print *,'# of ice pixels in SMAP: ',sum (ice_id) @@ -273,47 +442,61 @@ PROGRAM mkSMAPTilesPara l_index=0 w_index=sum (land_id) i_index=sum (land_id) + sum (water_id) + nland_cells = w_index + + + allocate(tile_area (1:i_index + sum (ice_id))) + allocate(smap_grid_area (1:NT)) + allocate(tile_ele (1:w_index)) + allocate(tile_area_land(1:w_index)) + allocate(my_land (1:i_index + sum (ice_id))) + allocate(all_id (1:i_index + sum (ice_id))) land_id = 0 water_id= 0 ice_id = 0 -! While looping through the 2.5'x2.5' grid, this section derives land, ice and water tiles. -! Each SMAP grid cell is assigned with an ID = ind_row*10000 + ind_col -! ind_col, ind_row are overlying SMAP grid cell indices -! Based on the above calculations: -! l_index Grid cells have land fractions (sum(land_id)) -! w_index SMAP Grid cells have inland water fractions (sum(water_id)) -! i_index SMAP Grid cells have ice fractions (sum(ice_id)) -! hence, tile_index 1 to l_index represent land tiles -! tile_index l_index +1 to l_index + w_index represent water (lakes) tiles -! tile_index l_index + w_index +1 to l_index + w_index + i_index represent ice tiles -! global 2.5'x2.5' array of tileid_index(8640,4320) contains corresponding tile_index values which -! is derived in the below loop + my_land = 0 + all_id = 0 + smap_grid_area = 0. + tile_area_land = 0. + tile_ele = 0. + tile_area = 0. + + ! While looping through the nc x nr grid, this section derives land, ice and water tiles. + ! Each SMAP grid cell is assigned with an ID = ind_row*ND + ind_col + ! ind_col, ind_row are overlying SMAP grid cell indices + ! Based on the above sums: + ! l_index Grid cells have land fractions (sum(land_id)) + ! w_index SMAP Grid cells have inland water fractions (sum(water_id)) + ! i_index SMAP Grid cells have ice fractions (sum(ice_id)) + ! hence, tile_index 1 to l_index represent land tiles + ! tile_index l_index +1 to l_index + w_index represent water (lakes) tiles + ! tile_index l_index + w_index +1 to l_index + w_index + i_index represent ice tiles + ! global nc x nr array of tileid_index(nc,nr) contains corresponding tile_index values which + ! is derived in the below loop + + ND_raster = 10*10**(nint(log10(1.*NR))) + i2 = 1 do i = 1 ,nc - - clon = -180. + float(i-1)*2.5/60. + 1.25/60. + + clon = -180. + float(i-1)*dx + dx/2. do j =nr ,1 ,-1 - - clat = -90. + float(j-1)*2.5/60. + 1.25/60. - - call easeV1_convert(trim(MGRID), clat, clon, r_smap, s_smap) -! if(trim(MGRID) == 'Ml') then -! status = ezlh_convert(trim(MGRID), clat, clon, r_smap, s_smap) -! else -! status = smap_convert(trim(MGRID), clat, clon, r_smap, s_smap) -! endif - + lats = -90._8 + (j - 0.5_8)*dy + clat = -90. + float(j-1)*dy + dy/2. + call easeV1_convert(trim(MGRID), clat, clon, r_smap, s_smap) + ind_col = nint(r_smap) + 1 ind_row = nint(s_smap) + 1 - if((ind_row.ge.1).and.(veg(i,j).ge.1).and.(ind_row.le.1632)) then - - l= ind_row*10000 + ind_col - - if(veg(i,j)==10) then + l= ind_row*ND + ind_col + pix_area =(sin(d2r*(lats+0.5*dy)) -sin(d2r*(lats-0.5*dy)))*(dx*d2r) + + if((ind_row.ge.1).and.(veg(i,j).ge.1).and.(ind_row.le.nr_smap)) then + + if(veg(i,j)==LakeType) then if(water_id(l)==0) then w_index = w_index + 1 water_id(l) = w_index @@ -323,7 +506,7 @@ PROGRAM mkSMAPTilesPara endif endif - if(veg(i,j)==11) then + if(veg(i,j)==IceType) then if(ice_id(l)==0) then i_index = i_index + 1 ice_id (l) = i_index @@ -333,7 +516,7 @@ PROGRAM mkSMAPTilesPara endif endif - if(veg(i,j).lt.10) then + if(veg(i,j).lt.LakeType) then if(land_id(l)==0) then l_index = l_index + 1 land_id (l) = l_index @@ -341,90 +524,84 @@ PROGRAM mkSMAPTilesPara else tileid_index(i,j)= land_id (l) !1-l_index endif + endif + tile_area(tileid_index(i,j))= tile_area(tileid_index(i,j)) + & + pix_area + my_land(tileid_index(i,j)) = l + all_id (tileid_index(i,j)) = j*ND_raster + i endif - end do - end do -! print *,l_index,w_index -l_index ,i_index - w_index -! stop + if((ind_row.ge.1).and.(ind_row.le.nr_smap)) then + smap_grid_area(l) = smap_grid_area(l) + & + pix_area + endif - deallocate(land_id ) + ! computing tile area/elevation + ! ----------------------------- + + if((tileid_index(i,j) > 0).and.(tileid_index(i,j) <= nland_cells))then + tile_ele(tileid_index(i,j)) = tile_ele(tileid_index(i,j)) + q0(i,j) * & + pix_area + tile_area_land(tileid_index(i,j)) = tile_area_land(tileid_index(i,j)) + & + pix_area + endif + end do + end do + + deallocate(land_id, q0) deallocate(water_id) deallocate(ice_id ) - allocate(smap_grid_area(1:16330000)) - allocate(land_id(1:i_index)) - allocate(lat_c(1:i_index)) - allocate(lon_c(1:i_index)) - allocate(tile_area(1:i_index)) - allocate(water_id(1:i_index)) - allocate(ice_id (1:i_index)) - allocate(pfaf_array (1:i_index)) - - land_id = 0 - water_id= 0 - ice_id = 0 - smap_grid_area = 0. - tile_area=0. - lat_c = 0. - lon_c = 0. - - do i = 1 ,nc - - clon = -180. + float(i-1)*2.5/60. + 1.25/60. - - do j =nr ,1 ,-1 - - clat = -90. + float(j-1)*2.5/60. + 1.25/60. - call easeV1_convert(trim(MGRID), clat, clon, r_smap, s_smap) + tile_ele = tile_ele/tile_area_land -! if(trim(MGRID) == 'Ml') then -! status = ezlh_convert(trim(MGRID), clat, clon, r_smap, s_smap) -! else -! status = smap_convert(trim(MGRID), clat, clon, r_smap, s_smap) -! endif + ! adjustment Global Mean Topography to 614.649 (615.662 GTOPO 30) m + ! ----------------------------------------------------------------- + sum1=0. + sum2=0. - ind_col = nint(r_smap) + 1 - ind_row = nint(s_smap) + 1 + do j=1,l_index + sum1 = sum1 + tile_ele(j)*tile_area(j) + enddo + + if(sum1/sum(tile_area(1:l_index)).ne. 614.649D0 ) then + print *,'Global Mean Elevation (over land): ', sum1/sum(tile_area(1:l_index)) + tile_ele =tile_ele*(614.649D0 / (sum1/sum(tile_area(1:l_index)))) + sum1=0. + sum2=0. + do j=1,l_index + sum1 = sum1 + tile_ele(j)*tile_area(j) + enddo + print *,'Global Mean Elevation after scaling to SRTM : ',sum1/sum(tile_area(1:l_index)) + endif + print *,'Total Land Area :', sum(tile_area(1:l_index))* MAPL_RADIUS * MAPL_RADIUS/1000./1000., & + sum(tile_area_land(1:l_index))* MAPL_RADIUS * MAPL_RADIUS/1000./1000. - if((ind_row.ge.1).and.(ind_row.le.1632)) then + print *,'Creating ... ', trim(gfile)//'rst' - l= ind_row*10000 + ind_col - if(veg(i,j).ge.1) then - land_id(tileid_index(i,j)) = l - ice_id (tileid_index(i,j)) = j*10000 + i ! just recycling the array ice_id, from this point ice_id contains infor to derive pfaf equivalent for SMAP cells - tile_area(tileid_index(i,j))= tile_area(tileid_index(i,j)) + & - da*cos((-90.+float(j)/24. -1./48.)*pi/180.) - endif - smap_grid_area(l) = smap_grid_area(l) + & - da*cos((-90.+float(j)/24. -1./48.)*pi/180.) -! lat_c(tileid_index(i,j))=lat_c(tileid_index(i,j)) + & ! not being used -! (-90.+float(j)/24. -1./48.) -! lon_c(tileid_index(i,j))=lon_c(tileid_index(i,j)) + & ! not being used -! (-180.+float(i)/24. -1./48.) -! water_id(tileid_index(i,j)) = water_id(tileid_index(i,j)) + 1 ! not being used -! water_id(tileid_index(i,j)) = water_id(tileid_index(i,j)) + 1 - - endif - end do - end do + !------------------------------------------- - ! print *,minval(land_id),maxval(land_id) - print *,'Creating ...', trim(gfile)//'rst' open (10, file ='rst/'//trim(gfile)//'.rst',form='unformatted',status='unknown', & action='write') - + do j=1,nr write(10)(tileid_index(i,j),i=1,nc) end do - + close (10,status='keep') - open (10, file ='til/'//trim(gfile)//'.til',form='formatted',status='unknown',action='write') - write (10,*)i_index + print *,'Creating ... ', trim(gfile)//'til ,catchment.def' + + !----------------------------------------------------------- + + open (11,file='clsm/catchment.def', & + form='formatted',status='unknown') + write(11,*)l_index + + open (10, file ='til/'//trim(gfile)//'.til',form='formatted',status='unknown',action='write') + write (10,*)i_index, nc, nr write (10,*)1 - write (10,*)'SMAP-EASE-'//trim(MGRID) + write (10,*)'SMAP-EASEv2-'//trim(MGRID) write (10,*)nc_smap write (10,*)nr_smap write (10,*)'NO-OCEAN' @@ -432,139 +609,88 @@ PROGRAM mkSMAPTilesPara write (10,*) -9999 do l=1,i_index - if (l <= l_index) typ = 100 - if ((l > l_index).and.(l <= w_index)) typ =19 - if (l > w_index) typ = 20 - - pfaf = catid(ice_id(l)-10000*(ice_id(l)/10000),ice_id(l)/10000) - cindex= catid_index(ice_id(l)-10000*(ice_id(l)/10000),ice_id(l)/10000) - ig = land_id(l)-10000*(land_id(l)/10000) - jg = land_id(l)/10000 - pfaf_array(l) = pfaf - -! clat = lat_c(l)/real(water_id(l)) -! clon = lon_c(l)/real(water_id(l)) - - call easeV1_inverse (trim(MGRID), real(ig-1), real(jg-1), clat, clon) - -! if(trim(MGRID) == 'Ml') then -! status = ezlh_inverse (trim(MGRID), real(ig-1), real(jg-1), clat, clon) -! else -! status = smap_inverse (trim(MGRID), real(ig-1), real(jg-1), clat, clon) -! endif - - fr_gcm= tile_area(l)/smap_grid_area(jg*10000 + ig) - tile_area(l) = fr_gcm*EASE_grid_area - write(10,'(i10,i9,2f10.4,2i5,f16.12,i10,f13.4,i8)') & - typ,pfaf,clon,clat,ig-1,jg-1,fr_gcm ,cindex !,fr_gcm*EASE_grid_area - end do - - close (10,status='keep') -! stop - -! tile elevation - - allocate(tile_ele(1:l_index)) - allocate(tile_area_land(1:l_index)) - - tile_ele = 0. - tile_area_land = 0. - - do j=1,nr - - lats = -90._8 + (j - 0.5_8)*dy - do i=1,nc - if((tileid_index(i,j) > 0).and.(tileid_index(i,j) <= l_index))then - tile_ele(tileid_index(i,j)) = tile_ele(tileid_index(i,j)) + q0(i,j)* & - (sin(d2r*(lats+0.5*dy)) -sin(d2r*(lats-0.5*dy)))*(dx*d2r) - tile_area_land(tileid_index(i,j)) = tile_area_land(tileid_index(i,j)) + & - (sin(d2r*(lats+0.5*dy)) -sin(d2r*(lats-0.5*dy)))*(dx*d2r) - endif - enddo - enddo + ig = my_land(l)-ND*(my_land(l)/ND) + jg = my_land(l)/ND + + cindex= catid_index(all_id(l)-ND_raster*(all_id(l)/ND_raster),all_id(l)/ND_raster) - tile_ele = tile_ele/tile_area_land + if (index(MaskFile,'GEOS5_10arcsec_mask') /= 0) then + pfaf = cindex + else + pfaf = catid(all_id(l)-ND_raster*(all_id(l)/ND_raster),all_id(l)/ND_raster) + endif - ! adjustment Global Mean Topography to 614.649 (615.662 GTOPO 30) m - ! --------------------------- - sum1=0. - sum2=0. - do j=1,l_index - sum1 = sum1 + tile_ele(j)*tile_area(j) - enddo - if(sum1/sum(tile_area(1:l_index)).ne. 614.649D0 ) then - print *,'Global Mean Elevation (over land): ', sum1/sum(tile_area(1:l_index)) - tile_ele =tile_ele*(614.649D0 / (sum1/sum(tile_area(1:l_index)))) - sum1=0. - sum2=0. - do j=1,l_index - sum1 = sum1 + tile_ele(j)*tile_area(j) - enddo - print *,'Global Mean Elevation after scaling to SRTM : ',sum1/sum(tile_area(1:l_index)) - endif - -! -! Now catchment.def -! - - open (10,file='clsm/catchment.def', & - form='formatted',status='unknown') + if ((l > l_index).and.(l <= w_index)) typ =19 + if (l > w_index) typ = 20 - write (10,*)l_index + if (l <= l_index) then + typ = 100 + call easeV1_inverse (trim(MGRID), real(ig-1),real(jg-1), clat, clon) + + mnx = clon - 180./real(nc_smap) + mxx = clon + 180./real(nc_smap) + + jgv = real(jg-1) + 0.5 + + call easeV1_inverse (trim(MGRID), real(ig-1),jgv, clat, clon) - do j=1,l_index + mny = clat + + jgv = real(jg-1) - 0.5 + + call easeV1_inverse (trim(MGRID), real(ig-1),jgv, clat, clon) - ig = land_id(j)-10000*(land_id(j)/10000) - jg = land_id(j)/10000 + mxy = clat - call easeV1_inverse (trim(MGRID), real(ig-1),real(jg-1), clat, clon) + write (11,'(i8,i8,5(2x,f9.4), i4)')l,pfaf,mnx,mxx,mny,mxy,tile_ele(l) -! if(trim(MGRID) == 'Ml') then -! status = ezlh_inverse (trim(MGRID), real(ig-1),real(jg-1), clat, clon) -! else -! status = smap_inverse (trim(MGRID), real(ig-1),real(jg-1), clat, clon) -! endif + endif - mnx = clon - 180./real(nc_smap) - mxx = clon + 180./real(nc_smap) - - jgv = real(jg-1) + 0.5 - - call easeV1_inverse (trim(MGRID), real(ig-1),jgv, clat, clon) - -! if(trim(MGRID) == 'Ml') then -! status = ezlh_inverse (trim(MGRID), real(ig-1),jgv, clat, clon) -! else -! status = smap_inverse (trim(MGRID), real(ig-1),jgv, clat, clon) -! endif - mny = clat + call easeV1_inverse (trim(MGRID), real(ig-1), real(jg-1), clat, clon) + + fr_gcm= tile_area(l)/smap_grid_area(jg*ND + ig) + + if (index(MaskFile,'GEOS5_10arcsec_mask') /= 0) then + write(10,'(i10,i9,2f10.4,2i5,f19.12,i10,i15,e13.4)') & + typ,pfaf,clon,clat,ig-1,jg-1,fr_gcm ,pfaf,SRTM_catid(cindex) + else + write(10,'(i10,i9,2f10.4,2i5,f19.12,i10,e13.4,i8)') & + typ,pfaf,clon,clat,ig-1,jg-1,fr_gcm ,cindex + endif + + end do - jgv = real(jg-1) - 0.5 - - call easeV1_inverse (trim(MGRID), real(ig-1),jgv, clat, clon) - -! if(trim(MGRID) == 'Ml') then -! status = ezlh_inverse (trim(MGRID), real(ig-1),jgv, clat, clon) -! else -! status = smap_inverse (trim(MGRID), real(ig-1),jgv, clat, clon) -! endif + close (10,status='keep') + close (11,status='keep') - mxy = clat + deallocate (tileid_index,catid_index,veg) + deallocate (tile_area, smap_grid_area, tile_ele, tile_area_land, my_land, all_id) + + if (index(MaskFile,'GEOS5_10arcsec_mask') /= 0) then - write (10,'(i8,i8,5(2x,f9.4))')j,pfaf_array(j),mnx,mxx,mny,mxy,tile_ele(j) + print *,'Creating SMAP-Catch_TransferData.nc files.' - end do + !--------------------------------------------------- + deallocate (SRTM_CatchArea, SRTM_catid) + + endif + ! create Grid2Catch transfer file ! ------------------------------- - CALL CREATE_ROUT_PARA_FILE (NC, NR, trim(gfile), MGRID=MGRID) + ! CALL CREATE_ROUT_PARA_FILE (NC, NR, trim(gfile), MGRID=MGRID) + + ! now run mkCatchParam + ! -------------------- -! now run mkCatchParam - tmpstring = 'bin/mkCatchParam_openmp -e EASE -g '//trim(gfile) - print *,trim(tmpstring) + tmpstring1 = '-e EASE -g '//trim(gfile) + write(tmpstring2,'(2(a2,x,i5,x))')'-x',nc,'-y',nr + tmpstring = 'bin/mkCatchParam_openmp '//trim(tmpstring2)//' '//trim(tmpstring1) + print *,trim(tmpstring) + + call system (tmpstring) - call system (tmpstring) + END PROGRAM mkSMAPTilesPara_v1 - END PROGRAM mkSMAPTilesPara diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/Raster/src/mkSMAPTilesPara_v2.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/Raster/src/mkSMAPTilesPara_v2.F90 index d01b68c67..308d7091b 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/Raster/src/mkSMAPTilesPara_v2.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/Raster/src/mkSMAPTilesPara_v2.F90 @@ -65,7 +65,7 @@ PROGRAM mkSMAPTilesPara_v2 if(N_args < 1) then print *,'USAGE : bin/mkSMAPTiles -smap_grid MXX' - print *,'Allowed SMAP grids are: M01 M03 M09 M36' + print *,'Allowed SMAP grids are: M01 M03 M09 M25 M36' stop end if @@ -114,13 +114,13 @@ PROGRAM mkSMAPTilesPara_v2 gfile = 'SMAP_EASEv2_'//trim(MGRID)//'_964x406' EASE_grid_area = CELL_km*CELL_km - ! elseif(trim(MGRID) == 'M25') then - ! - ! CELL_km = 3.00003356589 ! nominal cell size in kilometers - ! nc_smap = 1383 - ! nr_smap = 586 - ! gfile = 'SMAP_EASE_M25_1383x586' - ! EASE_grid_area = CELL_km*CELL_km + elseif(trim(MGRID) == 'M25') then + + CELL_km = 25.0252600081 ! nominal cell size in kilometers + nc_smap = 1388 + nr_smap = 584 + gfile = 'SMAP_EASEv2_M25_1388x584' + EASE_grid_area = CELL_km*CELL_km else if (trim(MGRID) .eq. 'M03') then ! SMAP 3 km grid CELL_km = 3.0026850700487 ! nominal cell size in kilometers @@ -719,14 +719,14 @@ PROGRAM mkSMAPTilesPara_v2 ! create Grid2Catch transfer file ! ------------------------------- - CALL CREATE_ROUT_PARA_FILE (NC, NR, trim(gfile), MGRID=MGRID) + CALL CREATE_ROUT_PARA_FILE (NC, NR, trim(gfile), MGRID=MGRID) ! now run mkCatchParam ! -------------------- tmpstring1 = '-e EASE -g '//trim(gfile) write(tmpstring2,'(2(a2,x,i5,x))')'-x',nc,'-y',nr - tmpstring = 'bin/mkCatchParam_openmp '//trim(tmpstring2)//' '//trim(tmpstring1) + tmpstring = 'bin/mkCatchParam '//trim(tmpstring2)//' '//trim(tmpstring1) print *,trim(tmpstring) call system (tmpstring) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/Raster/src/mk_runofftbl.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/Raster/src/mk_runofftbl.F90 index 3fc002b06..5b6c1506e 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/Raster/src/mk_runofftbl.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/Raster/src/mk_runofftbl.F90 @@ -5,8 +5,8 @@ program Runoff implicit none - integer, parameter :: nx=8640, ny=4320 - integer*2, allocatable :: lats(:,:), lons(:,:) + integer :: nx, ny + integer, allocatable :: lats(:,:), lons(:,:) integer, pointer :: rst(:,:), SortArr(:,:), key(:) integer, pointer :: srctile(:), srcweight(:), dstweight(:), dsttile(:) real, allocatable :: SrcFraction(:), area(:), in(:), out(:) @@ -15,7 +15,8 @@ program Runoff integer :: numtrans, numclosed integer :: status character*100 :: file, fileT, fileR, fileO, fileB - character*100 :: fileLL="data/Outlet_latlon.dat" + character*100 :: fileLL="data/CATCH/Outlet_latlon." + character*5 :: C_NX, C_NY call getarg(1,file) @@ -28,6 +29,17 @@ program Runoff ! These should all be ocean pixels !--------------------------------------- +! print *, "Getting raster size from "//trim(fileT) + + open(10,file=fileT, form="formatted", status="old") + + read(10,*) np, nx, ny + close(10) +! print *, nx, ny + + write (C_NX, '(i5.5)') NX + write (C_NY, '(i5.5)') NY + print *, "Reading outlets..." allocate(lats(nx,ny), lons(nx,ny),stat=status) @@ -36,16 +48,38 @@ program Runoff stop __LINE__ endif - open (30,file=fileLL,status="old",form="unformatted") - read (30) lons - read (30) lats + open (30,file=trim(fileLL)//C_NX//'x'//C_NY,form="unformatted",status="old") + do j = 1, ny + read (30) lons(:,j) + read (30) lats(:,j) + end do close(30) +! do j=1,ny +!! if (mod(j,100) == 0) print *,'J=',j +! do i=1,nx +! ii = Lons(i,j) +! jj = lats(i,j) +! +! if(ii==-999 .or. jj==-999) then +! ! ii = i +! ! jj = j +! cycle +! endif +! +! if(ii==i .and. jj==j) then +! print *, '>>> Inland Ocean Point ', ii, jj, lons(i,j), lats(i,j) +! stop +! end if +! +! end do +! end do +! stop "DONE" ! Count the number of Ocean and land tiles in the tile file ! All land tiles preceed the ocean tiles. !---------------------------------------------------------- - print *, "Reading til file "//trim(fileT) +! print *, "Reading til file "//trim(fileT) open(10,file=fileT, form="formatted", status="old") @@ -81,7 +115,7 @@ program Runoff print *, "Reading rst file "//trim(fileR) - open(20,file=fileR,form="unformatted",status="old",convert="LITTLE_ENDIAN") + open(20,file=fileR,form="unformatted",status="old") allocate(rst(nx,ny),stat=status) if(status/=0) then @@ -95,7 +129,7 @@ program Runoff close(20) - allocate(SortArr(1000000,3)) + allocate(SortArr(2*lnd,3)) DstTile => SortArr(:,1) SrcTile => SortArr(:,2) @@ -112,20 +146,23 @@ program Runoff NumTrans=0 do j=1,ny +! if (mod(j,100) == 0) print *,'J=',j do i=1,nx if(rst(i,j)<=lnd) then ii = Lons(i,j) jj = lats(i,j) + if(ii==-999 .or. jj==-999) then +! ii = i +! jj = j + cycle + endif + if(ii==i .and. jj==j) then print *, '>>> Inland Ocean Point ', ii, jj, rst(i,j) stop end if - if(ii==-999) then - ii = i - jj = j - endif k = MAPL_HASHIncrement(HashC,rst(i,j)) k = MAPL_HASHIncrement(Hash,rst(ii,jj),rst(i,j)) @@ -149,14 +186,16 @@ program Runoff SrcTile => SortArr(:NumTrans,2) SrcWeight => SortArr(:NumTrans,3) -! Allocate space for transanction lists -!-------------------------------------- - - allocate(key(numTrans)) - print *, "Total Transactions ", NumTrans print *, MAPL_HashSize(Hash),MAPL_HashSize(HashC) + call MAPL_HashDestroy(Hash) + call MAPL_HashDestroy(HashC) + +! Allocate space for transanction lists +!-------------------------------------- + + allocate(key(numTrans),stat=status) if(status/=0) then print *, "Out of Memory" @@ -222,8 +261,7 @@ program Runoff close(10) - open(10,file=fileB, form="unformatted", Convert="LITTLE_ENDIAN", & - status="unknown") + open(10,file=fileB, form="unformatted", status="unknown") write(10) NumTrans write(10) SrcTile diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/Raster/src/mod_process_hres_data.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/Raster/src/mod_process_hres_data.F90 index b4400f4b1..23a730c9d 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/Raster/src/mod_process_hres_data.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/Raster/src/mod_process_hres_data.F90 @@ -23,7 +23,7 @@ MODULE process_hres_data public :: modis_alb_on_tiles_high,modis_scale_para_high,hres_lai_no_gswp public :: histogram, regrid_map, create_mapping, esa2mosaic , esa2clm, ESA2CLM_45 public :: grid2tile_ndep_t2m_alb, CREATE_ROUT_PARA_FILE -public :: CLM45_fixed_parameters, CLM45_clim_parameters, gimms_clim_ndvi +public :: CLM45_fixed_parameters, CLM45_clim_parameters, gimms_clim_ndvi, grid2tile_glass, open_landparam_nc4_files ! Below structure is used to regrid high resolution data to high resolution tile raster @@ -810,7 +810,9 @@ SUBROUTINE ESA2CLM (nc, nr, gfile) integer, allocatable, dimension (:,:) :: clm_veg integer :: esa_clm_veg (2) real :: esa_clm_frac(2) - + logical :: file_exists + REAL, ALLOCATABLE, DIMENSION (:,:) :: NITYP,NFVEG + ! Reading CLM pft data file !-------------------------- @@ -1325,7 +1327,14 @@ SUBROUTINE ESA2CLM (nc, nr, gfile) action = 'read') read (11, *) maxcat - + + inquire(file='clsm/catchcn_params.nc4', exist=file_exists) + if(file_exists) then + status = NF_OPEN ('clsm/catchcn_params.nc4', NF_WRITE, ncid) ; VERIFY_(STATUS) + allocate (NITYP (1:MAXCAT, 1:4)) + allocate (NFVEG (1:MAXCAT, 1:4)) + endif + do k = 1, maxcat read (11,'(i8,i8,5(2x,f9.4))') tid,cid,minlon,maxlon,minlat,maxlat @@ -1472,8 +1481,27 @@ SUBROUTINE ESA2CLM (nc, nr, gfile) write (10,'(2I8,4I3,4f7.2,2I3,2f7.2)') & tid,cid,cpt1, cpt2, cst1, cst2, cpf1, cpf2, csf1, csf2, & esa_clm_veg (1), esa_clm_veg (2), esa_clm_frac(1), esa_clm_frac(2) + + if (allocated (NITYP)) NITYP (k, :) = (/REAL(cpt1), REAL(cpt2), REAL(cst1), REAL(cst2)/) + if (allocated (NFVEG)) NFVEG (k, :) = (/cpf1, cpf2, csf1, csf2/) + end do + if(file_exists) then + + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ITY' ) ,(/1,1/),(/maxcat,1/), NITYP (:, 1)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ITY' ) ,(/1,2/),(/maxcat,1/), NITYP (:, 2)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ITY' ) ,(/1,3/),(/maxcat,1/), NITYP (:, 3)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ITY' ) ,(/1,4/),(/maxcat,1/), NITYP (:, 4)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'FVG' ) ,(/1,1/),(/maxcat,1/), NFVEG (:, 1)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'FVG' ) ,(/1,2/),(/maxcat,1/), NFVEG (:, 2)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'FVG' ) ,(/1,3/),(/maxcat,1/), NFVEG (:, 3)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'FVG' ) ,(/1,4/),(/maxcat,1/), NFVEG (:, 4)) ; VERIFY_(STATUS) + DEALLOCATE (NITYP, NFVEG) + STATUS = NF_CLOSE (NCID) ; VERIFY_(STATUS) + + endif + close (10, status = 'keep') close (11, status = 'keep') @@ -1501,7 +1529,7 @@ SUBROUTINE ESA2MOSAIC (nc, nr, gfile) integer :: NBINS, NPLUS real, pointer, dimension (:) :: z2, z0 real, dimension (6) :: VGZ2 = (/35.0, 20.0, 17.0, 0.6, 0.5, 0.6/) ! Dorman and Sellers (1989) - logical :: jpl_height = .true. + logical :: file_exists ! Reading ESA vegetation types !----------------------------- @@ -1715,16 +1743,32 @@ SUBROUTINE ESA2MOSAIC (nc, nr, gfile) close (10,status='keep') close (11,status='keep') - open (20,file='clsm/vegdyn.data',status='unknown',action='write',form='unformatted', & - convert='little_endian') - write (20) real(ityp) - write (20) z2 (:) - write (20) z0 (:) - - close (20) - + inquire(file='clsm/catch_params.nc4', exist=file_exists) - deallocate (veg, z0, z2, ityp) + if(file_exists) then + status = NF_OPEN ('clsm/catch_params.nc4', NF_WRITE, ncid ) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'OLD_ITY' ) ,(/1/),(/maxcat/), real(ityp)) ; VERIFY_(STATUS) + STATUS = NF_CLOSE (NCID) ; VERIFY_(STATUS) + endif + + inquire(file='clsm/vegdyn.data', exist=file_exists) + + if(file_exists) then + status = NF_OPEN ('clsm/vegdyn.data', NF_WRITE, ncid ) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ITY' ) ,(/1/),(/maxcat/), real(ityp)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'Z2CH' ) ,(/1/),(/maxcat/), z2 ) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ASCATZ0') ,(/1/),(/maxcat/), Z0 ) ; VERIFY_(STATUS) + STATUS = NF_CLOSE (NCID) ; VERIFY_(STATUS) + else + open (20,file='clsm/vegdyn.data',status='unknown',action='write',form='unformatted', & + convert='little_endian') + write (20) real(ityp) + write (20) z2 (:) + write (20) z0 (:) + close (20) + endif + + deallocate (veg, z0, z2, ityp) END SUBROUTINE ESA2MOSAIC @@ -2117,7 +2161,7 @@ SUBROUTINE modis_scale_para_high (ease_grid,MA,gfile) read (20,'(i8,i8,2(2x,i3),2(2x,f6.4))') & indr1,indr1,vegcls(ip2),indr1,fr_gcm,fr_gcm endif - if(ierr /= 0)write (*,*)'Problem reading' + if(ierr /= 0)write (*,*)'Problem reading', n, ease_grid end do close (10,status='keep') close (20,status='keep') @@ -3427,132 +3471,213 @@ SUBROUTINE hres_gswp2 (nc_data,nr_data,rmap, gfiler,lai_name,merge) character*100 :: fname,fout character*10 :: string character*2 :: VV,HH - integer, allocatable, dimension (:,:) :: & + integer, allocatable, target, dimension (:,:) :: & net_data1 REAL, ALLOCATABLE, dimension (:) :: vec_lai, count_lai character(len=4), dimension (:), allocatable :: MMDD, MMDD_next logical :: regrid - REAL :: sf + REAL :: sf,minlat,maxlat,minlon,maxlon logical :: first_entry = .true. type (date_time_type) :: date_time_new,bf_lai_time, & af_lai_time integer, intent(in), optional :: merge + real, parameter :: dxy = 1. + integer :: nx, ny, QSize + REAL, ALLOCATABLE, dimension (:) :: x,y,tile_lon, tile_lat + real, allocatable, target, dimension (:,:) :: data_grid + integer, pointer, dimension (:,:) :: QSub + INTEGER ::imn,imx,jmn,jmx,mval,d1,d2,l,tindex1,pfaf1 + real, pointer, dimension (:,:) :: subset if(trim(lai_name) == 'lai' ) vid = 4 if(trim(lai_name) == 'green') vid = 5 -! + + ! For Gap filling + ! --------------- + + nx = nint (360./dxy) + ny = nint (180./dxy) + allocate (x(1:nx)) + allocate (y(1:ny)) + + FORALL (i = 1:nx) x(i) = -180. + dxy/2. + (i-1)*dxy + FORALL (i = 1:ny) y(i) = -90. + dxy/2. + (i-1)*dxy + + allocate (data_grid (1 : nx, 1 : ny)) + + QSize = nint(dxy*nc_data/360.) + ! Reading number of cathment-tiles from catchment.def file ! -------------------------------------------------------- - fname='clsm/catchment.def' - open (10,file=fname,status='old',action='read',form='formatted') - read(10,*) maxcat - close (10,status='keep') - - fname =trim(c_data)//'GSWP2_30sec_VegParam/GSWP2_VegParam_H11V13.nc' - status = NF_OPEN(trim(fname),NF_NOWRITE, ncid); VERIFY_(STATUS) - status = NF_GET_att_INT(ncid,NF_GLOBAL,'i_ind_offset_LL',iLL); VERIFY_(STATUS) - status = NF_GET_att_INT(ncid,NF_GLOBAL,'j_ind_offset_LL',jLL); VERIFY_(STATUS) - status = NF_GET_att_INT(ncid,NF_GLOBAL,'N_lon_global',i_highd); VERIFY_(STATUS) - status = NF_GET_att_INT(ncid,NF_GLOBAL,'N_lat_global',j_highd); VERIFY_(STATUS) - status = NF_INQ_DIM (ncid,1,string, nc_10); VERIFY_(STATUS) - status = NF_INQ_DIM (ncid,2,string, nr_10); VERIFY_(STATUS) - status = NF_INQ_DIM (ncid,3,string, n_tslices); VERIFY_(STATUS) - allocate (MMDD (0: n_tslices + 1)) - allocate (MMDD_next (0: n_tslices + 1)) - - status = NF_GET_VARA_text(ncid, 3,(/1,1/),(/4,n_tslices/),MMDD(1:n_tslices)); VERIFY_(STATUS) - status = NF_CLOSE(ncid); VERIFY_(STATUS) - - mmdd(0) = mmdd(n_tslices) - mmdd(n_tslices + 1)= mmdd(1) - - mmdd_next(0:n_tslices - 1) = mmdd(1:n_tslices) - mmdd_next(n_tslices: n_tslices + 1) = mmdd (1:2) - - allocate(net_data1 (1:nc_10,1:nr_10)) - ! - ! writing GSWP2 data - ! ------------------ - - if(present(merge)) then - open (31,file='clsm/lai.gswp2', & - form='unformatted',status='unknown',convert='little_endian') - else - open (31,file='clsm/'//trim(lai_name)//'.dat', & - form='unformatted',status='unknown',convert='little_endian') - endif - - allocate(vec_lai (1:maxcat)) - allocate(count_lai (1:maxcat)) - - do t =0,n_tslices+1 - - time_slice = t - yr = 1 - yr1= 1 - if(t == 0) then - time_slice = n_tslices - yr = 1 - 1 - endif - - if(t >= n_tslices) then - yr1 = 1 + 1 - if(t ==n_tslices + 1) then - time_slice = 1 - yr = 1 + 1 - endif - endif - - read(mmdd(t),'(i2.2,i2.2)') mn,dd - read(mmdd_next(t),'(i2.2,i2.2)') mn1,dd1 - vec_lai = -9999. - count_lai = 0. - - do jx = 1,18 - do ix = 1,36 - write (vv,'(i2.2)')jx - write (hh,'(i2.2)')ix - fname = trim(c_data)//'GSWP2_30sec_VegParam/GSWP2_VegParam_H'//hh//'V'//vv//'.nc' - status = NF_OPEN(trim(fname),NF_NOWRITE, ncid) - if(status == 0) then - status = NF_GET_att_INT (ncid,NF_GLOBAL,'i_ind_offset_LL',iLL); VERIFY_(STATUS) - status = NF_GET_att_INT (ncid,NF_GLOBAL,'j_ind_offset_LL',jLL); VERIFY_(STATUS) - status = NF_GET_att_INT (ncid,vid,'UNDEF',d_undef); VERIFY_(STATUS) - status = NF_GET_att_REAL (ncid,vid,'ScaleFactor',sf); VERIFY_(STATUS) - status = NF_GET_VARA_INT (ncid, vid,(/1,1,time_slice/),(/nc_10,nr_10,1/),net_data1); VERIFY_(STATUS) - - do j = jLL,jLL + nr_10 -1 - do i = iLL, iLL + nc_10 -1 - if(net_data1(i-iLL +1 ,j - jLL +1) /= d_undef) then - if(rmap(i,j)%nt > 0) then - do n = 1, rmap(i,j)%nt - if(vec_lai(rmap(i,j)%tid(n)) == -9999.) vec_lai(rmap(i,j)%tid(n)) = 0. - vec_lai(rmap(i,j)%tid(n)) = vec_lai(rmap(i,j)%tid(n)) + & - sf*net_data1(i-iLL +1 ,j - jLL +1)*rmap(i,j)%count(n) - count_lai(rmap(i,j)%tid(n)) = & - count_lai(rmap(i,j)%tid(n)) + 1.*rmap(i,j)%count(n) - end do - endif - endif - enddo - enddo - status = NF_CLOSE(ncid) - endif - end do - end do - - write(31) float((/yr,mn,dd,0,0,0,yr1,mn1,dd1,0,0,0,maxcat,1/)) - where (count_lai > 0.) vec_lai = vec_lai/count_lai - where (count_lai == 0.)vec_lai = 0.0001 - write(31) vec_lai(:) - end do - close(31,status='keep') + fname='clsm/catchment.def' + open (10,file=fname,status='old',action='read',form='formatted') + read(10,*) maxcat + allocate (tile_lon(1:maxcat)) + allocate (tile_lat(1:maxcat)) + + do n = 1, maxcat + read (10,*) tindex1,pfaf1,minlon,maxlon,minlat,maxlat + tile_lon(n) = (minlon + maxlon)/2. + tile_lat(n) = (minlat + maxlat)/2. + end do + + close (10,status='keep') + + fname =trim(c_data)//'GSWP2_30sec_VegParam/GSWP2_VegParam_H11V13.nc' + status = NF_OPEN(trim(fname),NF_NOWRITE, ncid); VERIFY_(STATUS) + status = NF_GET_att_INT(ncid,NF_GLOBAL,'i_ind_offset_LL',iLL); VERIFY_(STATUS) + status = NF_GET_att_INT(ncid,NF_GLOBAL,'j_ind_offset_LL',jLL); VERIFY_(STATUS) + status = NF_GET_att_INT(ncid,NF_GLOBAL,'N_lon_global',i_highd); VERIFY_(STATUS) + status = NF_GET_att_INT(ncid,NF_GLOBAL,'N_lat_global',j_highd); VERIFY_(STATUS) + status = NF_INQ_DIM (ncid,1,string, nc_10); VERIFY_(STATUS) + status = NF_INQ_DIM (ncid,2,string, nr_10); VERIFY_(STATUS) + status = NF_INQ_DIM (ncid,3,string, n_tslices); VERIFY_(STATUS) + allocate (MMDD (0: n_tslices + 1)) + allocate (MMDD_next (0: n_tslices + 1)) + + status = NF_GET_VARA_text(ncid, 3,(/1,1/),(/4,n_tslices/),MMDD(1:n_tslices)); VERIFY_(STATUS) + status = NF_CLOSE(ncid); VERIFY_(STATUS) + + mmdd(0) = mmdd(n_tslices) + mmdd(n_tslices + 1)= mmdd(1) + + mmdd_next(0:n_tslices - 1) = mmdd(1:n_tslices) + mmdd_next(n_tslices: n_tslices + 1) = mmdd (1:2) + + allocate(net_data1 (1:nc_10,1:nr_10)) + + ! writing GSWP2 data + ! ------------------ + + if(present(merge)) then + open (31,file='clsm/lai.gswp2', & + form='unformatted',status='unknown',convert='little_endian') + else + open (31,file='clsm/'//trim(lai_name)//'.dat', & + form='unformatted',status='unknown',convert='little_endian') + endif + + allocate(vec_lai (1:maxcat)) + allocate(count_lai (1:maxcat)) + + do t =0,n_tslices+1 + + time_slice = t + yr = 1 + yr1= 1 + if(t == 0) then + time_slice = n_tslices + yr = 1 - 1 + endif + + if(t >= n_tslices) then + yr1 = 1 + 1 + if(t ==n_tslices + 1) then + time_slice = 1 + yr = 1 + 1 + endif + endif + + read(mmdd(t),'(i2.2,i2.2)') mn,dd + read(mmdd_next(t),'(i2.2,i2.2)') mn1,dd1 + + vec_lai = -9999. + count_lai = 0. + data_grid = -9999 + + do jx = 1,18 + do ix = 1,36 + write (vv,'(i2.2)')jx + write (hh,'(i2.2)')ix + fname = trim(c_data)//'GSWP2_30sec_VegParam/GSWP2_VegParam_H'//hh//'V'//vv//'.nc' + status = NF_OPEN(trim(fname),NF_NOWRITE, ncid) + if(status == 0) then + status = NF_GET_att_INT (ncid,NF_GLOBAL,'i_ind_offset_LL',iLL); VERIFY_(STATUS) + status = NF_GET_att_INT (ncid,NF_GLOBAL,'j_ind_offset_LL',jLL); VERIFY_(STATUS) + status = NF_GET_att_INT (ncid,vid,'UNDEF',d_undef); VERIFY_(STATUS) + status = NF_GET_att_REAL (ncid,vid,'ScaleFactor',sf); VERIFY_(STATUS) + status = NF_GET_VARA_INT (ncid, vid,(/1,1,time_slice/),(/nc_10,nr_10,1/),net_data1); VERIFY_(STATUS) + + do j = jLL,jLL + nr_10 -1 + do i = iLL, iLL + nc_10 -1 + if(net_data1(i-iLL +1 ,j - jLL +1) /= d_undef) then + if(rmap(i,j)%nt > 0) then + do n = 1, rmap(i,j)%nt + if(vec_lai(rmap(i,j)%tid(n)) == -9999.) vec_lai(rmap(i,j)%tid(n)) = 0. + vec_lai(rmap(i,j)%tid(n)) = vec_lai(rmap(i,j)%tid(n)) + & + sf*net_data1(i-iLL +1 ,j - jLL +1)*rmap(i,j)%count(n) + count_lai(rmap(i,j)%tid(n)) = & + count_lai(rmap(i,j)%tid(n)) + 1.*rmap(i,j)%count(n) + end do + endif + endif + enddo + enddo + + ! After experimenting with few finer methods, in order to reduce the time taken by the gap filling procedure, + ! creating a 1.-degree gridded data set from finer LAI data and use it for filling the gaps seems the most practical/manageble method. + !--------------------------------------------------------------------------------------------------------------------------------------- + + do j = ceiling(1.*jLL/QSize),ceiling(1.*jLL/QSize) -1 + nr_10/QSize + do i = ceiling(1.*iLL/QSize),ceiling(1.*iLL/QSize) -1 + nc_10/QSize + QSub => net_data1((i-1)*QSize+2-iLL :i*QSize-iLL+1, (j-1)*QSize+2-jLL :j*QSize-jLL+1) + if(maxval (QSub) > 0) data_grid(i,j) = sf*sum(QSub, QSub>0)/(max(1,count(QSub>0))) + enddo + enddo + + status = NF_CLOSE(ncid) + endif + end do + end do + + write(31) float((/yr,mn,dd,0,0,0,yr1,mn1,dd1,0,0,0,maxcat,1/)) + where (count_lai > 0.) vec_lai = vec_lai/count_lai + + ! Filling gaps + !------------- + DO n =1,maxcat + if(count_lai(n)==0.) then + + DO i = 1,nx - 1 + if ((tile_lon(n) >= x(i)).and.(tile_lon(n) < x(i+1))) ix = i + end do + DO i = 1,ny -1 + if ((tile_lat(n) >= y(i)).and.(tile_lat(n) < y(i+1))) jx = i + end do + + l = 1 + do + imx=ix + l + imn=ix - l + jmn=jx - l + jmx=jx + l + imn=MAX(imn,1) + jmn=MAX(jmn,1) + imx=MIN(imx,nx) + jmx=MIN(jmx,ny) + d1=imx-imn+1 + d2=jmx-jmn+1 + subset => data_grid(imn: imx,jmn:jmx) + + if(maxval(subset) > 0.) then + vec_lai (n) = sum(subset, subset>0.)/(max(1,count(subset>0.))) + exit + endif + l = l + 1 + NULLIFY (subset) + end do + endif + end do + write(31) vec_lai(:) + end do - deallocate (net_data1) - deallocate (count_lai) - deallocate (vec_lai) + close(31,status='keep') + + deallocate (net_data1) + deallocate (count_lai) + deallocate (vec_lai) END SUBROUTINE hres_gswp2 @@ -3606,6 +3731,8 @@ SUBROUTINE soil_para_hwsd (nx,ny,gfiler) logical :: regrid,write_file INTEGER, allocatable, dimension (:) :: soil_class_top,soil_class_com REAL :: sf,factor,wp_wetness,fac_count + logical :: file_exists + REAL, ALLOCATABLE, DIMENSION (:,:) :: parms4file ! --------- VARIABLES FOR *OPENMP* PARALLEL ENVIRONMENT ------------ ! @@ -4379,7 +4506,14 @@ SUBROUTINE soil_para_hwsd (nx,ny,gfiler) END DO END DO !$OMP ENDPARALLELDO - + + inquire(file='clsm/catch_params.nc4', exist=file_exists) + + if(file_exists) then + status = NF_OPEN ('clsm/catch_params.nc4', NF_WRITE, ncid) ; VERIFY_(STATUS) + allocate (parms4file (1:maxcat, 1:10)) + endif + fname='clsm/catchment.def' open (10,file=fname,status='old',action='read',form='formatted') read(10,*) maxcat @@ -4443,7 +4577,22 @@ SUBROUTINE soil_para_hwsd (nx,ny,gfiler) write (12,'(i8,i8,4f10.7)')tindex,pfafindex, & atau_2cm(fac_surf),btau_2cm(fac_surf),atau(fac_surf),btau(fac_surf) - + + if (allocated (parms4file)) then + + parms4file (n, 1) = a_bee(fac) + parms4file (n, 2) = a_aksat(fac)/exp(-1.0*zks*gnu) + parms4file (n, 3) = a_poros(fac) + parms4file (n, 4) = a_psis(fac) + parms4file (n, 5) = wp_wetness + parms4file (n, 6) = soildepth(n) + parms4file (n, 7) = atau_2cm(fac_surf) + parms4file (n, 8) = btau_2cm(fac_surf) + parms4file (n, 9) = atau(fac_surf) + parms4file (n,10) = btau(fac_surf) + + endif + end do write (11,'(a)')' ' write (11,'(a)')'FMT=i8,i8,i4,i4,3f8.4,f12.8,f7.4,f10.4,3f7.3,4f7.3,2f10.4' @@ -4460,6 +4609,20 @@ SUBROUTINE soil_para_hwsd (nx,ny,gfiler) atau_2cm,btau_2cm) deallocate (soildepth, grav_vec,soc_vec,poc_vec,& ncells_top,ncells_top_pro,ncells_sub_pro,soil_class_top,soil_class_com) + if(file_exists) then + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'BEE' ) ,(/1/),(/maxcat/), parms4file (:, 1)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'COND' ) ,(/1/),(/maxcat/), parms4file (:, 2)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'POROS') ,(/1/),(/maxcat/), parms4file (:, 3)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'PSIS' ) ,(/1/),(/maxcat/), parms4file (:, 4)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'WPWET') ,(/1/),(/maxcat/), parms4file (:, 5)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'DP2BR') ,(/1/),(/maxcat/), parms4file (:, 6)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ATAU2') ,(/1/),(/maxcat/), parms4file (:, 7)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'BTAU2') ,(/1/),(/maxcat/), parms4file (:, 8)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ATAU5') ,(/1/),(/maxcat/), parms4file (:, 9)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'BTAU5') ,(/1/),(/maxcat/), parms4file (:,10)) ; VERIFY_(STATUS) + STATUS = NF_CLOSE (NCID) ; VERIFY_(STATUS) + DEALLOCATE (parms4file) + endif END SUBROUTINE soil_para_hwsd ! @@ -4643,7 +4806,8 @@ SUBROUTINE grid2tile_ndep_t2m_alb (irst,jrst,gfiler) character :: ctype*1, cband*1 real :: rdum, ftot, xg, yg, fill, alonw, alats, alone, alatn, rlonw, rlats, rlone, rlatn, xx, yy - integer :: i, j, n, im, jm, lwi, idum, ntiles, nland, nv, ix, jx, itype, iband, isum, ntl, np, jalbx, ialbx + integer :: i, j, n, im, jm, lwi, idum, ntiles, nland, nv, ix, jx, itype, iband, isum, ntl, np, jalbx, ialbx, ncid, status + logical :: file_exists ! read nland from catchment.def ! ----------------------------- @@ -5009,7 +5173,21 @@ SUBROUTINE grid2tile_ndep_t2m_alb (irst,jrst,gfiler) t2mm_tile(n) ,t2mp_tile(n) ! VISDR, VISDF, NIRDR, NIRDF end do - + + inquire(file='clsm/catchcn_params.nc4', exist=file_exists) + + if(file_exists) then + status = NF_OPEN ('clsm/catchcn_params.nc4', NF_WRITE, ncid ) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'NDEP' ) ,(/1/),(/nland/), ndep_tile ) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'BGALBVR' ) ,(/1/),(/nland/), alb_tile(:,1,1)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'BGALBVF' ) ,(/1/),(/nland/), alb_tile(:,2,1)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'BGALBNR' ) ,(/1/),(/nland/), alb_tile(:,1,2)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'BGALBNF' ) ,(/1/),(/nland/), alb_tile(:,2,2)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'T2_M' ) ,(/1/),(/nland/), t2mm_tile ) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'T2_S' ) ,(/1/),(/nland/), t2mp_tile ) ; VERIFY_(STATUS) + STATUS = NF_CLOSE (NCID) ; VERIFY_(STATUS) + endif + close (10, status ='keep') end SUBROUTINE grid2tile_ndep_t2m_alb @@ -5498,7 +5676,230 @@ SUBROUTINE CLM45_clim_parameters (nc,nr,gfiler) END SUBROUTINE CLM45_clim_parameters - ! ---------------------------------------------------------------------------------------------------------------------------- +! ---------------------------------------------------------------------------------------------------------------------------- + + SUBROUTINE grid2tile_glass (ncol,nrow,gfiler,lai_name) +! +! Processing GLASS LAI (AVHRR or MODIS) and creating 8-day climatological data +! + implicit none + integer , parameter :: N_lon_glass = 7200, N_lat_glass = 3600 + integer, intent (in) :: ncol, nrow + real, parameter :: dxy = 1. + integer :: QSize + character(*) :: gfiler,lai_name + integer :: n,maxcat,i,j,k,ncid,i_highd,j_highd,nx_adj,ny_adj,ierr,nx,ny + integer :: status,iLL,jLL,ix,jx,vid,nc_10,nr_10,n_tslices,d_undef,t, & + time_slice,time_slice_next,yr,mn,dd,yr1,mn1,dd1,i1,i2,tindex1,pfaf1 + character*100 :: fname,fout + character*10 :: string + character*2 :: VV,HH + integer, allocatable, target, dimension (:,:) :: net_data1 + real, pointer, dimension (:,:) :: QSub + real, pointer, dimension (:,:) :: subset + REAL, ALLOCATABLE, dimension (:):: vec_lai, count_lai,tile_lon, tile_lat & + , x, y !, distance + real, allocatable, target, dimension (:,:) :: lai_grid, data_grid, data_grid2 + INTEGER ::imn,imx,jmn,jmx,mval,d1,d2,l, VarID + character(len=4), dimension (:), allocatable :: MMDD, MMDD_next + logical :: regrid + REAL :: sf, dum,dist_save,tile_distance,minlat,maxlat,minlon,maxlon + logical :: first_entry = .true. + type (date_time_type) :: date_time_new,bf_lai_time, & + af_lai_time, date_time_this + integer, dimension (:,:), allocatable, target :: tile_id + integer :: tileid_tile + character*3 :: ddd + +! Reading rst file +!----------------- + open (10,file=trim(gfiler)//'.rst',status='old',action='read', & + form='unformatted',convert='little_endian') + allocate (tile_id (1:ncol,1:nrow)) + + do j=1,nrow + read(10)tile_id(:,j) + end do + close (10,status='keep') + +! +! Reading number of cathment-tiles from catchment.def file +!_________________________________________________________ +! + fname='clsm/catchment.def' + open (10,file=fname,status='old',action='read',form='formatted') + read(10,*) maxcat + allocate (tile_lon(1:maxcat)) + allocate (tile_lat(1:maxcat)) + + do n = 1, maxcat + read (10,*) tindex1,pfaf1,minlon,maxlon,minlat,maxlat + tile_lon(n) = (minlon + maxlon)/2. + tile_lat(n) = (minlat + maxlat)/2. + end do + close (10,status='keep') + + fname =trim(c_data)//'/MODIS_8-DayClim/MODIS_lai_clim.H11V13.nc' + status = NF_OPEN(trim(fname),NF_NOWRITE, ncid); VERIFY_(STATUS) + status = NF_INQ_DIM (ncid,3,string, n_tslices); VERIFY_(STATUS) + allocate (MMDD (0: n_tslices + 1)) + allocate (MMDD_next (0: n_tslices + 1)) + + status = NF_GET_VARA_text(ncid, 3,(/1,1/),(/4,n_tslices/),MMDD(1:n_tslices)); VERIFY_(STATUS) + status = NF_CLOSE(ncid); VERIFY_(STATUS) + + mmdd(0) = mmdd(n_tslices) + mmdd(n_tslices + 1)= mmdd(1) + + mmdd_next(0:n_tslices - 1) = mmdd(1:n_tslices) + mmdd_next(n_tslices: n_tslices + 1) = mmdd (1:2) + + ! writing GLASS LAI + ! + open (31,file='clsm/lai.dat', & + form='unformatted',status='unknown',convert='little_endian') + + allocate (vec_lai (maxcat)) + allocate (count_lai (1:maxcat)) + + nx = nint (360./dxy) + ny = nint (180./dxy) + allocate (x(1:nx)) + allocate (y(1:ny)) + + FORALL (i = 1:nx) x(i) = -180. + dxy/2. + (i-1)*dxy + FORALL (i = 1:ny) y(i) = -90. + dxy/2. + (i-1)*dxy + + allocate (lai_grid (1 : nx, 1 : ny)) + + QSize = nint(dxy*N_lon_glass/360.) + allocate (QSub (1:QSize,1:QSize)) + allocate (net_data1 (1 : N_lon_glass, 1 : N_lat_glass)) + allocate (data_grid (1:NCOL,1:NROW)) + allocate (data_grid2 (1 : N_lon_glass, 1 : N_lat_glass)) + + do t =0,n_tslices+1 + + time_slice = t + yr = 1 + yr1= 1 + if(t == 0) then + time_slice = n_tslices + yr = 1 - 1 + endif + + if(t >= n_tslices) then + yr1 = 1 + 1 + if(t ==n_tslices + 1) then + time_slice = 1 + yr = 1 + 1 + endif + endif + + read(mmdd(t),'(i2.2,i2.2)') mn,dd + read(mmdd_next(t),'(i2.2,i2.2)') mn1,dd1 + + date_time_this%year = 2001 + date_time_this%month = mn + date_time_this%day = dd + date_time_this%hour = 0 + date_time_this%min = 0 + date_time_this%sec = 0 + call get_dofyr_pentad(date_time_this) + + write (ddd,'(i3.3)') date_time_this%dofyr + + ! Reading Interpolation or aggregation on to catchment-tiles + + vec_lai = -9999. + count_lai = 0. + lai_grid = -9999 + + status = NF_OPEN (trim(c_data)//trim(lai_name)//ddd//'.nc4', NF_NOWRITE, ncid) ; VERIFY_(STATUS) + status = NF_INQ_VARID (ncid,'LAI',VarID) ; VERIFY_(STATUS) + status = NF_GET_VARA_INT(ncid,VarID, (/1,1/),(/N_lon_glass, N_lat_glass/), net_data1) ; VERIFY_(STATUS) + + call RegridRasterReal(0.01*real(net_data1), data_grid) + data_grid2 = 0.01*real(net_data1) + + status = NF_CLOSE(ncid) + + do j = 1,nrow + do i = 1, ncol + if((tile_id(i,j).gt.0).and.(tile_id(i,j).le.MAXCAT)) then + if((data_grid(i,j) >= 0.).and.(data_grid(i,j) <= 10.)) then + if(vec_lai(tile_id(i,j)) == -9999.) vec_lai(tile_id(i,j)) = 0. + vec_lai (tile_id(i,j)) = vec_lai (tile_id(i,j)) + data_grid(i,j) + count_lai (tile_id(i,j)) = count_lai (tile_id(i,j)) + 1. + endif + endif + end do + end do + + write(31) float((/yr,mn,dd,0,0,0,yr1,mn1,dd1,0,0,0,maxcat,1/)) + + where (count_lai > 0.) vec_lai = vec_lai/count_lai + + ! After experimenting with few finer methods, in order to reduce the time taken by the gap filling procedure, + ! creating a 0.25-degree gridded data set from finer LAI data and use it for filling the gaps seems the most practical/manageble method. + !--------------------------------------------------------------------------------------------------------------------------------------- + + iLL = 1 + jLL = 1 + do j = 1, N_lat_glass/QSize + do i = 1, N_lon_glass/QSize + QSub => data_grid2((i-1)*QSize+2-iLL :i*QSize-iLL+1, (j-1)*QSize+2-jLL :j*QSize-jLL+1) + if(minval (QSub) <= 10.) lai_grid(i,j) = sum(QSub, QSub<=10.)/(max(1,count(QSub<=10.))) + enddo + enddo + + NULLIFY (QSub) + +! Filling gaps +!------------- + DO n =1,maxcat + if(count_lai(n)==0.) then + + DO i = 1,nx - 1 + if ((tile_lon(n) >= x(i)).and.(tile_lon(n) < x(i+1))) ix = i + end do + DO i = 1,ny -1 + if ((tile_lat(n) >= y(i)).and.(tile_lat(n) < y(i+1))) jx = i + end do + + l = 1 + do + imx=ix + l + imn=ix - l + jmn=jx - l + jmx=jx + l + imn=MAX(imn,1) + jmn=MAX(jmn,1) + imx=MIN(imx,nx) + jmx=MIN(jmx,ny) + d1=imx-imn+1 + d2=jmx-jmn+1 + subset => lai_grid(imn: imx,jmn:jmx) + + if(maxval(subset) > 0.) then + vec_lai (n) = sum(subset, subset>0.)/(max(1,count(subset>0.))) + exit + endif + l = l + 1 + NULLIFY (subset) + end do + endif + END DO + write(31) vec_lai(:) + end do + close(31,status='keep') + + deallocate (net_data1, tile_id) + deallocate (count_lai) + deallocate (vec_lai) + deallocate (tile_lat,tile_lon) + + END SUBROUTINE grid2tile_glass ! ---------------------------------------------------------------------------------------------------------------------------- @@ -5670,6 +6071,118 @@ SUBROUTINE gimms_clim_ndvi (nc,nr,gfiler) END SUBROUTINE gimms_clim_ndvi + ! -------------------------------------------------------------------------- + + SUBROUTINE open_landparam_nc4_files + + implicit none + integer :: NCCatOUTID, NCCatCNOUTID, NCVegOUTID + integer :: STATUS, CellID1, CellID2, CellID3, SubID + integer, dimension(8) :: date_time_values + character (22) :: time_stamp + character (100) :: MYNAME + + status = NF_CREATE ('clsm/catch_params.nc4' , NF_NETCDF4, NCCatOUTID ) ; VERIFY_(STATUS) + status = NF_CREATE ('clsm/catchcn_params.nc4', NF_NETCDF4, NCCatCNOUTID) ; VERIFY_(STATUS) + status = NF_CREATE ('clsm/vegdyn.data' , NF_NETCDF4, NCVegOUTID ) ; VERIFY_(STATUS) + + status = NF_DEF_DIM(NCCatOUTID , 'tile' , NF_UNLIMITED, CellID1) + status = NF_DEF_DIM(NCCatCNOUTID, 'tile' , NF_UNLIMITED, CellID2) + status = NF_DEF_DIM(NCVegOUTID , 'tile' , NF_UNLIMITED, CellID3) + status = NF_DEF_DIM(NCCatCNOUTID, 'unknown_dim2' , 4, SubID) + + call DEF_VAR ( NCCatOUTID, CellID1,'OLD_ITY' ,'vegetation_type.' , '1' ) + call DEF_VAR ( NCCatOUTID, CellID1,'ARA1' ,'shape_param_1' ,'m+2 kg-1' ) + call DEF_VAR ( NCCatOUTID, CellID1,'ARA2' ,'shape_param_2' ,'1' ) + call DEF_VAR ( NCCatOUTID, CellID1,'ARA3' ,'shape_param_3' ,'m+2 kg-1' ) + call DEF_VAR ( NCCatOUTID, CellID1,'ARA4' ,'shape_param_4' ,'1' ) + call DEF_VAR ( NCCatOUTID, CellID1,'ARS1' ,'wetness_param_1' ,'m+2 kg-1' ) + call DEF_VAR ( NCCatOUTID, CellID1,'ARS2' ,'wetness_param_2' ,'m+2 kg-1' ) + call DEF_VAR ( NCCatOUTID, CellID1,'ARS3' ,'wetness_param_3' ,'m+4 kg-2' ) + call DEF_VAR ( NCCatOUTID, CellID1,'ARW1' ,'min_theta_param_1' ,'m+2 kg-1' ) + call DEF_VAR ( NCCatOUTID, CellID1,'ARW2' ,'min_theta_param_2' ,'m+2 kg-1' ) + call DEF_VAR ( NCCatOUTID, CellID1,'ARW3' ,'min_theta_param_3' ,'m+4 kg-2' ) + call DEF_VAR ( NCCatOUTID, CellID1,'ARW4' ,'min_theta_param_4' ,'1' ) + call DEF_VAR ( NCCatOUTID, CellID1,'ATAU2' ,'2cm_water_transfer_param_5' ,'1' ) + call DEF_VAR ( NCCatOUTID, CellID1,'ATAU5' ,'5cm_water_transfer_param_5' ,'1' ) + call DEF_VAR ( NCCatOUTID, CellID1,'BEE' ,'clapp_hornberger_b' ,'1' ) + call DEF_VAR ( NCCatOUTID, CellID1,'BF1' ,'topo_baseflow_param_1' ,'kg m-4' ) + call DEF_VAR ( NCCatOUTID, CellID1,'BF2' ,'topo_baseflow_param_2' ,'m' ) + call DEF_VAR ( NCCatOUTID, CellID1,'BF3' ,'topo_baseflow_param_3' ,'log(m)' ) + call DEF_VAR ( NCCatOUTID, CellID1,'BTAU2' ,'2cm_water_transfer_param_6' ,'1' ) + call DEF_VAR ( NCCatOUTID, CellID1,'BTAU5' ,'5cm_water_transfer_param_6' ,'1' ) + call DEF_VAR ( NCCatOUTID, CellID1,'COND' ,'sfc_sat_hydraulic_conduct' ,'m s-1' ) + call DEF_VAR ( NCCatOUTID, CellID1,'GNU' ,'vertical_transmissivity' ,'m-1' ) + call DEF_VAR ( NCCatOUTID, CellID1,'POROS' ,'soil_porosity' ,'1' ) + call DEF_VAR ( NCCatOUTID, CellID1,'PSIS' ,'saturated_matric_potential' ,'m' ) + call DEF_VAR ( NCCatOUTID, CellID1,'TSA1' ,'water_transfer_param_1' ,'1' ) + call DEF_VAR ( NCCatOUTID, CellID1,'TSA2' ,'water_transfer_param_2' ,'1' ) + call DEF_VAR ( NCCatOUTID, CellID1,'TSB1' ,'water_transfer_param_3' ,'1' ) + call DEF_VAR ( NCCatOUTID, CellID1,'TSB2' ,'water_transfer_param_4' ,'1' ) + call DEF_VAR ( NCCatOUTID, CellID1,'WPWET' ,'wetness_at_wilting_point' ,'1' ) + call DEF_VAR ( NCCatOUTID, CellID1,'DP2BR' ,'depth_to_bedrock' ,'mm' ) + + call DEF_VAR ( NCVegOUTID, CellID3,'ITY' ,'vegetation_type' ,'1' ) + call DEF_VAR ( NCVegOUTID, CellID3,'Z2CH' ,'vegetation_height' ,'m' ) + call DEF_VAR ( NCVegOUTID, CellID3,'ASCATZ0' ,'ASCAT_roughness_length' ,'m' ) + + call DEF_VAR ( NCCatCNOUTID, CellID2,'BGALBNF' ,'MODIS soil albedo nir dif' ,'1' ) + call DEF_VAR ( NCCatCNOUTID, CellID2,'BGALBNR' ,'MODIS soil albedo nir dir' ,'1' ) + call DEF_VAR ( NCCatCNOUTID, CellID2,'BGALBVF' ,'MODIS soil albedo vis dif' ,'1' ) + call DEF_VAR ( NCCatCNOUTID, CellID2,'BGALBVR' ,'MODIS soil albedo vis dir' ,'1' ) + call DEF_VAR ( NCCatCNOUTID, CellID2,'T2_M' ,'Clim 2m temperature (MERRA2)' ,'K' ) + call DEF_VAR ( NCCatCNOUTID, CellID2,'T2_S' ,'Clim 2m temperature (Sheffield)' ,'K' ) + call DEF_VAR ( NCCatCNOUTID, CellID2,'NDEP' ,'CLM_nitrogen_deposition' ,'g m-2 s-1') + call DEF_VAR ( NCCatCNOUTID, CellID2,'FVG' ,'vegetation_fraction' ,'1' ,SubID = SubID) + call DEF_VAR ( NCCatCNOUTID, CellID2,'ITY' ,'vegetation_type' ,'1' ,SubID = SubID) + + call date_and_time(VALUES=date_time_values) + + write (time_stamp,'(i4.4,a1,i2.2,a1,i2.2,1x,a2,1x,i2.2,a1,i2.2,a1,i2.2)') & + date_time_values(1),'-',date_time_values(2),'-',date_time_values(3),'at', & + date_time_values(5),':',date_time_values(6),':',date_time_values(7) +! call system('setenv MYNAME `finger $USER | cut -d: -f3 | head -1`') +! call sleep (5) + call getenv ("USER" ,MYNAME ) + status = NF_PUT_ATT_TEXT(NCCatOUTID , NF_GLOBAL, 'CreatedBy', LEN_TRIM(MYNAME), trim(MYNAME) ) + status = NF_PUT_ATT_TEXT(NCCatOUTID , NF_GLOBAL, 'Date' , LEN_TRIM(time_stamp),trim(time_stamp)) + status = NF_PUT_ATT_TEXT(NCVegOUTID , NF_GLOBAL, 'CreatedBy', LEN_TRIM(MYNAME), trim(MYNAME) ) + status = NF_PUT_ATT_TEXT(NCVegOUTID , NF_GLOBAL, 'Date' , LEN_TRIM(time_stamp),trim(time_stamp)) + status = NF_PUT_ATT_TEXT(NCCatCNOUTID, NF_GLOBAL, 'CreatedBy', LEN_TRIM(MYNAME), trim(MYNAME) ) + status = NF_PUT_ATT_TEXT(NCCatCNOUTID, NF_GLOBAL, 'Date' , LEN_TRIM(time_stamp),trim(time_stamp)) + + status = NF_ENDDEF(NCCatOUTID ) + status = NF_ENDDEF(NCVegOUTID ) + status = NF_ENDDEF(NCCatCNOUTID) + + status = NF_CLOSE (NCCatOUTID ) + status = NF_CLOSE (NCVegOUTID ) + status = NF_CLOSE (NCCatCNOUTID) + + contains + + SUBROUTINE DEF_VAR (NCFID, CellID, VarName, long_name, units, SubID) + + implicit none + integer, intent (in) :: NCFID, CellID + character (*), intent (in) :: VarName, long_name, units + integer, intent (in), optional :: SubID + integer :: STATUS, VID + + if(present (SubID)) then + status = NF_DEF_VAR(NCFID, trim(VarName) , NF_FLOAT, 2 ,(/CellID, SubID/), vid) ; VERIFY_(STATUS) + else + status = NF_DEF_VAR(NCFID, trim(VarName) , NF_FLOAT, 1 ,(/CellID/), vid) ; VERIFY_(STATUS) + endif + + status = NF_PUT_ATT_TEXT(NCFID, vid, 'long_name', LEN_TRIM(long_name), trim(long_name)) ; VERIFY_(STATUS) + status = NF_PUT_ATT_TEXT(NCFID, vid, 'units' , LEN_TRIM(units) , trim(units)) ; VERIFY_(STATUS) + + + END SUBROUTINE DEF_VAR + + END SUBROUTINE open_landparam_nc4_files + END MODULE process_hres_data diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/Raster/src/rmTinyCatchParaMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/Raster/src/rmTinyCatchParaMod.F90 index 5f8bb6f0b..cd1c55cbe 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/Raster/src/rmTinyCatchParaMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/Raster/src/rmTinyCatchParaMod.F90 @@ -41,7 +41,8 @@ module rmTinyCatchParaMod public mineral_perc, process_gswp2_veg,center_pix, soil_class public tgen, sat_param,REFORMAT_VEGFILES,base_param,ts_param public :: Get_MidTime, Time_Interp_Fac, compute_stats, c_data - public :: ascat_r0, jpl_canoph + public :: ascat_r0, jpl_canoph, NC_VarID + logical, parameter, public :: jpl_height = .false. type :: mineral_perc real :: clay_perc @@ -2199,7 +2200,6 @@ SUBROUTINE compute_mosaic_veg_types (nx,ny,ease_grid,regrid,gfilet,gfiler) integer, pointer :: Raster(:,:) real, pointer, dimension (:) :: z2, z0 real, dimension (6) :: VGZ2 = (/35.0, 20.0, 17.0, 0.6, 0.5, 0.6/) ! Dorman and Sellers (1989) - logical :: jpl_height = .true. fname=trim(gfilet)//'.til' open (10,file=fname,status='old',action='read',form='formatted') @@ -3128,7 +3128,9 @@ SUBROUTINE create_model_para_woesten (Maskfile) character (*) :: MaskFile integer :: iwt,irz,group logical :: picked - + logical :: file_exists + REAL, ALLOCATABLE, DIMENSION (:,:) :: parms4file + integer :: ncid, status ! --------- VARIABLES FOR *OPENMP* PARALLEL ENVIRONMENT ------------ ! @@ -3354,6 +3356,25 @@ SUBROUTINE create_model_para_woesten (Maskfile) endif END DO + inquire(file='clsm/catch_params.nc4', exist=file_exists) + + if(file_exists) then + status = NF_OPEN ('clsm/catch_params.nc4', NF_WRITE, ncid) ; VERIFY_(STATUS) + allocate (parms4file (1:nbcatch, 1:25)) + status = NF_GET_VARA_REAL(NCID,NC_VarID(NCID,'BEE' ) ,(/1/),(/nbcatch/), BEE (:)) ; VERIFY_(STATUS) + status = NF_GET_VARA_REAL(NCID,NC_VarID(NCID,'COND' ) ,(/1/),(/nbcatch/), COND (:)) ; VERIFY_(STATUS) + status = NF_GET_VARA_REAL(NCID,NC_VarID(NCID,'POROS') ,(/1/),(/nbcatch/), POROS(:)) ; VERIFY_(STATUS) + status = NF_GET_VARA_REAL(NCID,NC_VarID(NCID,'PSIS' ) ,(/1/),(/nbcatch/), PSIS (:)) ; VERIFY_(STATUS) + status = NF_GET_VARA_REAL(NCID,NC_VarID(NCID,'WPWET') ,(/1/),(/nbcatch/), WPWET(:)) ; VERIFY_(STATUS) + status = NF_GET_VARA_REAL(NCID,NC_VarID(NCID,'DP2BR') ,(/1/),(/nbcatch/), soildepth (:)) ; VERIFY_(STATUS) + parms4file (:,12) = BEE (:) + parms4file (:,16) = COND (:) + parms4file (:,18) = POROS (:) + parms4file (:,19) = PSIS (:) + parms4file (:,24) = wpwet (:) + parms4file (:,25) = soildepth(:) + endif + rewind(10) allocate(low_ind(n_threads)) @@ -3491,7 +3512,7 @@ SUBROUTINE create_model_para_woesten (Maskfile) END DO DO n=1,nbcatch - read(10,'(i8,i8,i4,i4,3f8.4,f12.8,f7.4,f10.4,3f7.3,4f7.3,2f10.4)') & + read(10,'(i8,i8,i4,i4,3f8.4,f12.8,f7.4,f10.4,3f7.3,4f7.3,2f10.4)') & tindex2(n),pfaf2(n),soil_class_top(n),soil_class_com(n), & BEE(n), PSIS(n),POROS(n),COND(n),WPWET(n),soildepth(n), & grav_vec(n),soc_vec(n),poc_vec(n), & @@ -3515,6 +3536,28 @@ SUBROUTINE create_model_para_woesten (Maskfile) a_sand_surf(n),a_clay_surf(n),atile_sand(n),atile_clay(n), & wpwet_surf(n),poros_surf(n) + if (allocated (parms4file)) then + parms4file (n, 1) = ara1(n) + parms4file (n, 2) = ara2(n) + parms4file (n, 3) = ara3(n) + parms4file (n, 4) = ara4(n) + parms4file (n, 5) = ars1(n) + parms4file (n, 6) = ars2(n) + parms4file (n, 7) = ars3(n) + parms4file (n, 8) = arw1(n) + parms4file (n, 9) = arw2(n) + parms4file (n,10) = arw3(n) + parms4file (n,11) = arw4(n) + parms4file (n,13) = bf1(n) + parms4file (n,14) = bf2(n) + parms4file (n,15) = bf3(n) + parms4file (n,17) = gnu + parms4file (n,20) = tsa1(n) + parms4file (n,21) = tsa2(n) + parms4file (n,22) = tsb1(n) + parms4file (n,23) = tsb2(n) + endif + else if(preserve_soiltype) then if ((soil_class_com(n)>=1).and.(soil_class_com(n)<=84)) then @@ -3579,6 +3622,35 @@ SUBROUTINE create_model_para_woesten (Maskfile) grav_vec(k),soc_vec(k),poc_vec(k), & a_sand_surf(k),a_clay_surf(k),atile_sand(k),atile_clay(k) , & wpwet_surf(k),poros_surf(k) + + if (allocated (parms4file)) then + parms4file (n, 1) = ara1(k) + parms4file (n, 2) = ara2(k) + parms4file (n, 3) = ara3(k) + parms4file (n, 4) = ara4(k) + parms4file (n, 5) = ars1(k) + parms4file (n, 6) = ars2(k) + parms4file (n, 7) = ars3(k) + parms4file (n, 8) = arw1(k) + parms4file (n, 9) = arw2(k) + parms4file (n,10) = arw3(k) + parms4file (n,11) = arw4(k) + parms4file (n,12) = BEE(k) + parms4file (n,13) = bf1(k) + parms4file (n,14) = bf2(k) + parms4file (n,15) = bf3(k) + parms4file (n,16) = COND(k) + parms4file (n,17) = gnu + parms4file (n,18) = POROS(k) + parms4file (n,19) = PSIS(k) + parms4file (n,20) = tsa1(k) + parms4file (n,21) = tsa2(k) + parms4file (n,22) = tsb1(k) + parms4file (n,23) = tsb2(k) + parms4file (n,24) = wpwet (k) + parms4file (n,25) = soildepth(k) + endif + else dist_save = 1000000. @@ -3612,6 +3684,33 @@ SUBROUTINE create_model_para_woesten (Maskfile) a_sand_surf(k),a_clay_surf(k),atile_sand(k),atile_clay(k) , & wpwet_surf(k),poros_surf(k) + if (allocated (parms4file)) then + parms4file (n, 1) = ara1(k) + parms4file (n, 2) = ara2(k) + parms4file (n, 3) = ara3(k) + parms4file (n, 4) = ara4(k) + parms4file (n, 5) = ars1(k) + parms4file (n, 6) = ars2(k) + parms4file (n, 7) = ars3(k) + parms4file (n, 8) = arw1(k) + parms4file (n, 9) = arw2(k) + parms4file (n,10) = arw3(k) + parms4file (n,11) = arw4(k) + parms4file (n,12) = BEE(k) + parms4file (n,13) = bf1(k) + parms4file (n,14) = bf2(k) + parms4file (n,15) = bf3(k) + parms4file (n,16) = COND(k) + parms4file (n,17) = gnu + parms4file (n,18) = POROS(k) + parms4file (n,19) = PSIS(k) + parms4file (n,20) = tsa1(k) + parms4file (n,21) = tsa2(k) + parms4file (n,22) = tsb1(k) + parms4file (n,23) = tsb2(k) + parms4file (n,24) = wpwet (k) + parms4file (n,25) = soildepth(k) + endif endif endif @@ -3638,7 +3737,37 @@ SUBROUTINE create_model_para_woesten (Maskfile) close(21,status='delete') close(31,status='delete') close(41,status='keep') - endif + endif + + if(file_exists) then + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARA1' ) ,(/1/),(/nbcatch/), parms4file (:, 1)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARA2' ) ,(/1/),(/nbcatch/), parms4file (:, 2)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARA3' ) ,(/1/),(/nbcatch/), parms4file (:, 3)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARA4' ) ,(/1/),(/nbcatch/), parms4file (:, 4)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARS1' ) ,(/1/),(/nbcatch/), parms4file (:, 5)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARS2' ) ,(/1/),(/nbcatch/), parms4file (:, 6)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARS3' ) ,(/1/),(/nbcatch/), parms4file (:, 7)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARW1' ) ,(/1/),(/nbcatch/), parms4file (:, 8)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARW2' ) ,(/1/),(/nbcatch/), parms4file (:, 9)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARW3' ) ,(/1/),(/nbcatch/), parms4file (:,10)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARW4' ) ,(/1/),(/nbcatch/), parms4file (:,11)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'BEE' ) ,(/1/),(/nbcatch/), parms4file (:,12)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'BF1' ) ,(/1/),(/nbcatch/), parms4file (:,13)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'BF2' ) ,(/1/),(/nbcatch/), parms4file (:,14)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'BF3' ) ,(/1/),(/nbcatch/), parms4file (:,15)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'COND' ) ,(/1/),(/nbcatch/), parms4file (:,16)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'GNU' ) ,(/1/),(/nbcatch/), parms4file (:,17)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'POROS') ,(/1/),(/nbcatch/), parms4file (:,18)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'PSIS' ) ,(/1/),(/nbcatch/), parms4file (:,19)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'TSA1' ) ,(/1/),(/nbcatch/), parms4file (:,20)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'TSA2' ) ,(/1/),(/nbcatch/), parms4file (:,21)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'TSB1' ) ,(/1/),(/nbcatch/), parms4file (:,22)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'TSB2' ) ,(/1/),(/nbcatch/), parms4file (:,23)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'WPWET') ,(/1/),(/nbcatch/), parms4file (:,24)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'DP2BR') ,(/1/),(/nbcatch/), parms4file (:,25)) ; VERIFY_(STATUS) + STATUS = NF_CLOSE (NCID) ; VERIFY_(STATUS) + DEALLOCATE (parms4file) + endif END SUBROUTINE create_model_para_woesten @@ -4589,7 +4718,7 @@ SUBROUTINE SAT_PARAM( & ! endif ! pfc=12821 flag=0 - call curve2(arw1,arw2,arw3,arw4,cdcr1,flag) + call curve2(arw1,arw2,arw3,arw4,cdcr1,WPWET,flag) IF (FLAG.EQ.1) THEN arw1=9999. !arw1old @@ -4726,7 +4855,7 @@ SUBROUTINE SAT_PARAM( & adjust=0 flag=0 - call curve2(arw1,arw2,arw3,arw4,cdcr1,flag) + call curve2(arw1,arw2,arw3,arw4,cdcr1,WPWET,flag) IF (FLAG.EQ.1) THEN ! WRITE(*,*)'Curve2 problem in the catchment:pfc=',pfc @@ -4999,14 +5128,15 @@ END SUBROUTINE SAT_PARAM ! ****************************************************************** !c - SUBROUTINE CURVE1(ars1,ars2,ars3,cdcr1,flag) - REAL ars1,ars2,ars3,y,x,yp,cdcr1 + SUBROUTINE CURVE1(ars1,ars2,ars3,cdcr2,flag) + REAL ars1,ars2,ars3,y,x,yp,cdcr2 INTEGER i,flag !c yp=1. if (abs(ars1+ars2+ars3).le.1.e25) then - do i=0,nint(cdcr1) + do i=0,CEILING(cdcr2) x=float(i) + if(x > cdcr2) x = cdcr2 y=(1.+ars1*x)/(1.+ars2*x+ars3*x*x + 1.e-20) if((y.gt.0.0).and.(((yp -y) .lt. -1.e-4).or.(y.gt.1.)))then flag=1 @@ -5024,17 +5154,17 @@ end SUBROUTINE CURVE1 ! ****************************************************************** - SUBROUTINE CURVE2(arw1,arw2,arw3,arw4,cdcr1,flag) - REAL arw1,arw2,arw3,arw4,y,x,yp,cdcr1 + SUBROUTINE CURVE2(arw1,arw2,arw3,arw4,cdcr1,WPWET,flag) + REAL arw1,arw2,arw3,arw4,y,x,yp,cdcr1, wpwet INTEGER i,flag !c yp=1. if (abs(arw1+arw2+arw3+arw4).le.1.e25) then - do i=0,nint(cdcr1) + do i=0,CEILING(cdcr1) x=float(i) + if(x > cdcr1) x = cdcr1 y=arw4+(1.-arw4)*(1.+arw1*x)/(1.+arw2*x+arw3*x*x + 1.e-20) - - if((y.ge.arw4).and.(((yp -y) .lt. -1.e-4).or.(y.gt.1.)))then + if ((y .lt. wpwet).or.((yp -y) .lt. -1.e-4).or.(y.gt.1.)) then flag=1 goto 99 endif @@ -6758,6 +6888,33 @@ SUBROUTINE jpl_canoph (nc,nr,gfiler, z2) deallocate (tile_id) END SUBROUTINE jpl_canoph + ! ---------------------------------------------------------------------- + + integer function NC_VarID (NCFID, VNAME) + + integer, intent (in) :: NCFID + character(*), intent (in) :: VNAME + integer :: status + + STATUS = NF_INQ_VARID (NCFID, trim(VNAME) ,NC_VarID) + IF (STATUS .NE. NF_NOERR) & + CALL HANDLE_ERR(STATUS, trim(VNAME)) + + end function NC_VarID + + ! ----------------------------------------------------------------------- + + SUBROUTINE HANDLE_ERR(STATUS, Line) + + INTEGER, INTENT (IN) :: STATUS + CHARACTER(*), INTENT (IN) :: Line + + IF (STATUS .NE. NF_NOERR) THEN + PRINT *, trim(Line),': ',NF_STRERROR(STATUS) + STOP 'Stopped' + ENDIF + + END SUBROUTINE HANDLE_ERR ! ----------------------------------------------------------------------------------- diff --git a/GEOSmkiau_GridComp/GEOS_mkiauGridComp.F90 b/GEOSmkiau_GridComp/GEOS_mkiauGridComp.F90 index 05a299fa1..f1e8590c1 100644 --- a/GEOSmkiau_GridComp/GEOS_mkiauGridComp.F90 +++ b/GEOSmkiau_GridComp/GEOS_mkiauGridComp.F90 @@ -18,8 +18,9 @@ module GEOS_mkiauGridCompMod use ESMF_CFIOMOD, only: ESMF_CFIOstrTemplate use ESMF_CFIOFileMod use GEOS_UtilsMod - use GEOS_RemapMod, only: myremap => remap - use m_chars, only: uppercase +! use GEOS_RemapMod, only: myremap => remap + use m_set_eta, only: set_eta + use m_chars, only: uppercase use MAPL_GridManagerMod, only: grid_manager use MAPL_RegridderManagerMod, only: regridder_manager use MAPL_AbstractRegridderMod @@ -36,7 +37,8 @@ module GEOS_mkiauGridCompMod private class (AbstractRegridder), pointer :: ANA2BKG_regridder => null() class (AbstractRegridder), pointer :: BKG2ANA_regridder => null() - type(ESMF_Grid) :: GRIDana + type(ESMF_Grid) :: GRIDana ! Analysis Data using Horizontal:ANA Vertical:BKG + type(ESMF_Grid) :: GRIDrep ! Replay File Data using Horizontal:ANA Vertical:ANA integer :: IM integer :: JM integer :: LM @@ -515,6 +517,8 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) real, pointer, dimension(:,:,:) :: ptr3d, temp3d real, pointer, dimension(:,:) :: ptr2d, temp2d +! Background Variables from IMPORT State +! -------------------------------------- real, pointer, dimension(:,:) :: vintdiv_ana real, pointer, dimension(:,:) :: vintdiv_bkg real, pointer, dimension(:,:) :: vintdiv_cor @@ -529,17 +533,39 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) real, pointer, dimension(:,:) ::phis_bkg real, pointer, dimension(:) :: ak,bk + real, allocatable, dimension(:,:,:) :: dp_bkg + +! Analysis Variables from REPLAY Files +! ------------------------------------ + real, allocatable, dimension(:,:) :: ps_rep + real, allocatable, dimension(:,:,:) :: dp_rep + real, allocatable, dimension(:,:,:) :: u_rep + real, allocatable, dimension(:,:,:) :: v_rep + real, allocatable, dimension(:,:,:) :: t_rep + real, allocatable, dimension(:,:,:) :: q_rep + real, allocatable, dimension(:,:,:) :: o3_rep + real, allocatable, dimension(:,:,:) :: thv_rep + real, allocatable, dimension(:,:,:) :: ple_rep + real, allocatable, dimension(:,:,:) :: pk_rep + real, allocatable, dimension(:,:,:) :: pke_rep + real, allocatable, dimension(:) :: ak_rep + real, allocatable, dimension(:) :: bk_rep + +! Analysis Variables from REPLAY Files REMAPPED to Background Vertical Resolution +! ------------------------------------------------------------------------------- real, pointer, dimension(:,:) ::phis_ana real, pointer, dimension(:,:) :: ts_ana real, pointer, dimension(:,:) :: ps_ana - real, pointer, dimension(:,:,:) :: dp_ana real, pointer, dimension(:,:,:) :: u_ana real, pointer, dimension(:,:,:) :: v_ana real, pointer, dimension(:,:,:) :: t_ana real, pointer, dimension(:,:,:) :: thv_ana real, pointer, dimension(:,:,:) :: q_ana real, pointer, dimension(:,:,:) :: o3_ana - + + real, allocatable, dimension(:,:,:) :: ple_ana + real, allocatable, dimension(:,:,:) :: pk_ana + real, allocatable, dimension(:,:,:) :: pke_ana real, allocatable, dimension(:,:,:) :: qdum1 real, allocatable, dimension(:,:,:) :: qdum2 @@ -547,13 +573,13 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) real, pointer, dimension(:,:,:) :: pdum2 => null() real, pointer, dimension(:,:) :: tropp => null() - real, allocatable, dimension(:,:,:) :: dp_bkg - real, allocatable, dimension(:,:,:) :: ple_ana - real, allocatable, dimension(:,:,:) :: pk_ana - real, allocatable, dimension(:,:,:) :: pke_ana real, allocatable, dimension(:,:,:) :: du_fix real, allocatable, dimension(:,:,:) :: dv_fix + real ptopdum + real pintdum + integer ksdum + real, allocatable, dimension(:,:) :: vintdiva real, allocatable, dimension(:,:) :: vintdivb real, allocatable, dimension(:,:) :: vintdivc @@ -592,6 +618,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) type(ESMF_FieldBundle) :: bundle type(ESMF_Grid) :: GRIDbkg type(ESMF_Grid) :: GRIDana + type(ESMF_Grid) :: GRIDrep type(ESMF_Time) :: currtime type(ESMF_Calendar) :: cal type(ESMF_TimeInterval) :: FileFreq @@ -969,7 +996,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) call CFIO_Open ( REPLAY_FILEP0, 1, fid, STATUS ) VERIFY_(STATUS) - call CFIO_DimInquire ( fid, IMana_World, JMana_world, LM, nt, nvars, natts, rc=STATUS ) + call CFIO_DimInquire ( fid, IMana_World, JMana_world, LMana, nt, nvars, natts, rc=STATUS ) VERIFY_(STATUS) call CFIO_Close ( fid, STATUS ) VERIFY_(STATUS) @@ -980,7 +1007,8 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) VERIFY_(STATUS) do_transforms = ( IMbkg_World /= IMana_World ) .or. & - ( JMbkg_World /= JMana_World ) + ( JMbkg_World /= JMana_World ) .or. & + ( LMbkg /= LMana ) refresh_internal_state = .false. ! Default if (first) then @@ -988,8 +1016,8 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) else if ( mkiau_internal_state%IM /= IMana_World .or. & mkiau_internal_state%JM /= JMana_World .or. & - mkiau_internal_state%LM /= LM) then - refresh_internal_state = .true. ! somehow different background resolution + mkiau_internal_state%LM /= LMana ) then + refresh_internal_state = .true. ! Resolution of Analysis File has changed since last update end if end if @@ -998,6 +1026,8 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) call WRITE_PARALLEL("Destroying GRIDana...") call ESMF_GridDestroy(mkiau_internal_state%GRIDana, rc=status) VERIFY_(STATUS) + call ESMF_GridDestroy(mkiau_internal_state%GRIDrep, rc=status) + VERIFY_(STATUS) end if call WRITE_PARALLEL("Creating GRIDana...") @@ -1008,24 +1038,28 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) ! Get grid_dimensions from file. call CFIO_Open(REPLAY_FILEP0, 1, fid, rc=status) VERIFY_(status) - call CFIO_DimInquire (fid, IMana_World, JMana_World, LM, & - & nt, nvars, natts, rc=status) + call CFIO_DimInquire (fid, IMana_World, JMana_World, LMana, nt, nvars, natts, rc=status) VERIFY_(status) call CFIO_Close(fid, rc=status) VERIFY_(status) block use MAPL_LatLonGridFactoryMod - GRIDana = grid_manager%make_grid( & - & LatLonGridFactory(im_world=IMana_World, jm_world=JMana_World, lm=LM, & - & nx=NX, ny=NY, pole='PC', dateline= 'DC', rc=status)) + GRIDrep = grid_manager%make_grid( & + LatLonGridFactory(im_world=IMana_World, jm_world=JMana_World, lm=LMana, & + nx=NX, ny=NY, pole='PC', dateline= 'DC', rc=status) ) + VERIFY_(STATUS) + GRIDana = grid_manager%make_grid( & + LatLonGridFactory(im_world=IMana_World, jm_world=JMana_World, lm=LMbkg, & + nx=NX, ny=NY, pole='PC', dateline= 'DC', rc=status) ) VERIFY_(STATUS) end block - mkiau_internal_state%im = IMana_World - mkiau_internal_state%jm = JMana_World - mkiau_internal_state%lm = LM + mkiau_internal_state%im = IMana_World + mkiau_internal_state%jm = JMana_World + mkiau_internal_state%lm = LMana mkiau_internal_state%GRIDana = GRIDana + mkiau_internal_state%GRIDrep = GRIDrep call MAPL_GetResource(MAPL, K, Label="BKG2ANACNSRV:", default=0, RC=STATUS) VERIFY_(STATUS) @@ -1054,6 +1088,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) else if(first) call WRITE_PARALLEL("Using stored GRIDana...") GRIDana = mkiau_internal_state%GRIDana + GRIDrep = mkiau_internal_state%GRIDrep end if !ALT: Get current VM and the mpi communicator @@ -1068,30 +1103,31 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) ! Set Local Dimensions to GRIDana and GRIDbkg ! ------------------------------------------- - call MAPL_GridGet(GRIDana, localCellCountPerDim=DIMS, RC=STATUS) + call MAPL_GridGet(GRIDrep, localCellCountPerDim=DIMS, RC=STATUS) VERIFY_(STATUS) IMana = DIMS(1) JMana = DIMS(2) - LMana = LM + LMana = DIMS(3) call MAPL_GridGet(GRIDbkg, localCellCountPerDim=DIMS, RC=STATUS) VERIFY_(STATUS) IMbkg = DIMS(1) JMbkg = DIMS(2) - LMbkg = LM + LMbkg = DIMS(3) -! Set Local Dimensions to GRIDINC -! ------------------------------- +! Set Local Dimensions to GRIDINC (i.e., the GRID on which the increments are computed) +! Note: In all cases, the vertical resolution is defined by the Background +! ------------------------------------------------------------------------------------- if( trim(GRIDINC) == "ANA" ) then IM = IMana JM = JMana - LMP1 = LMana+1 endif if( trim(GRIDINC) == "BKG" ) then IM = IMbkg JM = JMbkg - LMP1 = LMbkg+1 endif + LM = LMbkg + LMP1 = LMbkg+1 if ( IHAVEAINC/=0 ) then call handleINC_ @@ -1280,13 +1316,13 @@ subroutine handleANA_ allocate( phis_bkg(IM,JM) ) allocate( ts_bkg(IM,JM) ) allocate( ps_bkg(IM,JM) ) - allocate( u_bkg(IM,JM,LM) ) - allocate( v_bkg(IM,JM,LM) ) - allocate( t_bkg(IM,JM,LM) ) - allocate( tv_bkg(IM,JM,LM) ) - allocate( q_bkg(IM,JM,LM) ) - allocate( o3_bkg(IM,JM,LM) ) - allocate ( dp_bkg(IM,JM,LM) ) + allocate( u_bkg(IM,JM,1:LM) ) + allocate( v_bkg(IM,JM,1:LM) ) + allocate( t_bkg(IM,JM,1:LM) ) + allocate( tv_bkg(IM,JM,1:LM) ) + allocate( q_bkg(IM,JM,1:LM) ) + allocate( o3_bkg(IM,JM,1:LM) ) + allocate ( dp_bkg(IM,JM,1:LM) ) allocate( ple_bkg(IM,JM,0:LM) ) ! ********************************************************************** @@ -1427,7 +1463,7 @@ subroutine handleANA_ if( NEED_BUNDLEP0 ) then RBUNDLEP0 = ESMF_FieldBundleCreate( RC=STATUS) VERIFY_(STATUS) - if ( trim(GRIDINC)=="ANA" ) call ESMF_FieldBundleSet(RBUNDLEP0, grid=GRIDana, rc=status) + if ( trim(GRIDINC)=="ANA" ) call ESMF_FieldBundleSet(RBUNDLEP0, grid=GRIDrep, rc=status) if ( trim(GRIDINC)=="BKG" ) call ESMF_FieldBundleSet(RBUNDLEP0, grid=GRIDbkg, rc=status) VERIFY_(STATUS) call MAPL_CFIORead ( REPLAY_FILEP0, REPLAY_TIMEP0, RBUNDLEP0 , RC=status) @@ -1444,7 +1480,7 @@ subroutine handleANA_ if( NEED_BUNDLEM1 ) then RBUNDLEM1 = ESMF_FieldBundleCreate( RC=STATUS) VERIFY_(STATUS) - if ( trim(GRIDINC)=="ANA" ) call ESMF_FieldBundleSet(RBUNDLEM1, grid=GRIDana, rc=status) + if ( trim(GRIDINC)=="ANA" ) call ESMF_FieldBundleSet(RBUNDLEM1, grid=GRIDrep, rc=status) if ( trim(GRIDINC)=="BKG" ) call ESMF_FieldBundleSet(RBUNDLEM1, grid=GRIDbkg, rc=status) VERIFY_(STATUS) call MAPL_CFIORead ( REPLAY_FILEM1, REPLAY_TIMEM1, RBUNDLEM1 , RC=status) @@ -1461,7 +1497,7 @@ subroutine handleANA_ if( NEED_BUNDLEP1 ) then RBUNDLEP1 = ESMF_FieldBundleCreate( RC=STATUS) VERIFY_(STATUS) - if ( trim(GRIDINC)=="ANA" ) call ESMF_FieldBundleSet(RBUNDLEP1, grid=GRIDana, rc=status) + if ( trim(GRIDINC)=="ANA" ) call ESMF_FieldBundleSet(RBUNDLEP1, grid=GRIDrep, rc=status) if ( trim(GRIDINC)=="BKG" ) call ESMF_FieldBundleSet(RBUNDLEP1, grid=GRIDbkg, rc=status) VERIFY_(STATUS) call MAPL_CFIORead ( REPLAY_FILEP1, REPLAY_TIMEP1, RBUNDLEP1 , RC=status) @@ -1477,7 +1513,7 @@ subroutine handleANA_ if( NEED_BUNDLEM2 ) then RBUNDLEM2 = ESMF_FieldBundleCreate( RC=STATUS) VERIFY_(STATUS) - if ( trim(GRIDINC)=="ANA" ) call ESMF_FieldBundleSet(RBUNDLEM2, grid=GRIDana, rc=status) + if ( trim(GRIDINC)=="ANA" ) call ESMF_FieldBundleSet(RBUNDLEM2, grid=GRIDrep, rc=status) if ( trim(GRIDINC)=="BKG" ) call ESMF_FieldBundleSet(RBUNDLEM2, grid=GRIDbkg, rc=status) VERIFY_(STATUS) call MAPL_CFIORead ( REPLAY_FILEM2, REPLAY_TIMEM2, RBUNDLEM2 , RC=status) @@ -1503,6 +1539,8 @@ subroutine handleANA_ if( first ) then if(MAPL_AM_I_ROOT() ) then print * + print *, 'REPLAY File Dimensions: ', IMana_World,JMana_World,LMana + print * print *, 'REPLAY File Variables, NQ: ', nq print *, '--------------------------' do k=1,nq @@ -1530,7 +1568,6 @@ subroutine handleANA_ allocate ( phis_ana(IM,JM) ) allocate ( ts_ana(IM,JM) ) allocate ( ps_ana(IM,JM) ) - allocate ( dp_ana(IM,JM, LM) ) allocate ( du_fix(IM,JM, LM) ) allocate ( dv_fix(IM,JM, LM) ) allocate ( u_ana(IM,JM, LM) ) @@ -1543,14 +1580,27 @@ subroutine handleANA_ allocate ( ple_ana(IM,JM,0:LM) ) allocate ( pke_ana(IM,JM,0:LM) ) - doremap = trim(cremap).eq.'YES' + allocate ( dp_rep(IM,JM, LMana) ) + allocate ( u_rep(IM,JM, LMana) ) + allocate ( v_rep(IM,JM, LMana) ) + allocate ( t_rep(IM,JM, LMana) ) + allocate ( thv_rep(IM,JM, LMana) ) + allocate ( q_rep(IM,JM, LMana) ) + allocate ( o3_rep(IM,JM, LMana) ) + allocate ( pk_rep(IM,JM, LMana) ) + allocate ( ple_rep(IM,JM,0:LMana) ) + allocate ( pke_rep(IM,JM,0:LMana) ) + + allocate ( ak_rep(0:LMana) ) + allocate ( bk_rep(0:LMana) ) + + doremap = (trim(cremap).eq.'YES') .or. (LMana.ne.LMbkg) ! Initialize ANA.ETA variables to Transformed BKG IMPORT State (In case REPLAY Variables are turned OFF) ! ------------------------------------------------------------------------------------------------------ phis_ana = phis_bkg ts_ana = ts_bkg ps_ana = ps_bkg - dp_ana = dp_bkg u_ana = u_bkg v_ana = v_bkg t_ana = t_bkg @@ -1649,21 +1699,21 @@ subroutine handleANA_ if( match('dp',REPLAY_DP,rnames(k)) ) then call ESMFL_BundleGetPointertoData(RBUNDLEP0,trim(rnames(k)),ptr3d, RC=STATUS) if(STATUS==ESMF_SUCCESS) then - dp_ana = ptr3d + dp_rep = ptr3d if( currTime /= REPLAY_TIMEP0 ) then call ESMFL_BundleGetPointertoData(RBUNDLEM1,trim(rnames(k)),ptr3d, RC=STATUS) VERIFY_(STATUS) - dp_ana = facp0*dp_ana + facm1*ptr3d + dp_rep = facp0*dp_rep + facm1*ptr3d if( REPLAY_TIME_INTERP == "CUBIC" ) then call ESMFL_BundleGetPointertoData(RBUNDLEP1,trim(rnames(k)),ptr3d, RC=STATUS) VERIFY_(STATUS) - dp_ana = dp_ana + facp1*ptr3d + dp_rep = dp_rep + facp1*ptr3d call ESMFL_BundleGetPointertoData(RBUNDLEM2,trim(rnames(k)),ptr3d, RC=STATUS) VERIFY_(STATUS) - dp_ana = dp_ana + facm2*ptr3d + dp_rep = dp_rep + facm2*ptr3d endif endif - if( REPLAY_P_FACTOR.ne.1.0 ) dp_ana = dp_ana * REPLAY_P_FACTOR + if( REPLAY_P_FACTOR.ne.1.0 ) dp_rep = dp_rep * REPLAY_P_FACTOR FOUND = .true. exit endif @@ -1682,21 +1732,21 @@ subroutine handleANA_ if( match('u',REPLAY_U,rnames(k)) ) then call ESMFL_BundleGetPointertoData(RBUNDLEP0,trim(rnames(k)),ptr3d, RC=STATUS) if(STATUS==ESMF_SUCCESS) then - u_ana = ptr3d + u_rep = ptr3d if( currTime /= REPLAY_TIMEP0 ) then call ESMFL_BundleGetPointertoData(RBUNDLEM1,trim(rnames(k)),ptr3d, RC=STATUS) VERIFY_(STATUS) - u_ana = facp0*u_ana + facm1*ptr3d + u_rep = facp0*u_rep + facm1*ptr3d if( REPLAY_TIME_INTERP == "CUBIC" ) then call ESMFL_BundleGetPointertoData(RBUNDLEP1,trim(rnames(k)),ptr3d, RC=STATUS) VERIFY_(STATUS) - u_ana = u_ana + facp1*ptr3d + u_rep = u_rep + facp1*ptr3d call ESMFL_BundleGetPointertoData(RBUNDLEM2,trim(rnames(k)),ptr3d, RC=STATUS) VERIFY_(STATUS) - u_ana = u_ana + facm2*ptr3d + u_rep = u_rep + facm2*ptr3d endif endif - if( REPLAY_U_FACTOR.ne.1.0 ) u_ana = u_ana * REPLAY_U_FACTOR + if( REPLAY_U_FACTOR.ne.1.0 ) u_rep = u_rep * REPLAY_U_FACTOR FOUND = .true. exit endif @@ -1715,21 +1765,21 @@ subroutine handleANA_ if( match('v',REPLAY_V,rnames(k)) ) then call ESMFL_BundleGetPointertoData(RBUNDLEP0,trim(rnames(k)),ptr3d, RC=STATUS) if(STATUS==ESMF_SUCCESS) then - v_ana = ptr3d + v_rep = ptr3d if( currTime /= REPLAY_TIMEP0 ) then call ESMFL_BundleGetPointertoData(RBUNDLEM1,trim(rnames(k)),ptr3d, RC=STATUS) VERIFY_(STATUS) - v_ana = facp0*v_ana + facm1*ptr3d + v_rep = facp0*v_rep + facm1*ptr3d if( REPLAY_TIME_INTERP == "CUBIC" ) then call ESMFL_BundleGetPointertoData(RBUNDLEP1,trim(rnames(k)),ptr3d, RC=STATUS) VERIFY_(STATUS) - v_ana = v_ana + facp1*ptr3d + v_rep = v_rep + facp1*ptr3d call ESMFL_BundleGetPointertoData(RBUNDLEM2,trim(rnames(k)),ptr3d, RC=STATUS) VERIFY_(STATUS) - v_ana = v_ana + facm2*ptr3d + v_rep = v_rep + facm2*ptr3d endif endif - if( REPLAY_V_FACTOR.ne.1.0 ) v_ana = v_ana * REPLAY_V_FACTOR + if( REPLAY_V_FACTOR.ne.1.0 ) v_rep = v_rep * REPLAY_V_FACTOR FOUND = .true. exit endif @@ -1752,22 +1802,22 @@ subroutine handleANA_ if( match('qv',REPLAY_QV,rnames(k)) ) then call ESMFL_BundleGetPointertoData(RBUNDLEP0,trim(rnames(k)),ptr3d, RC=STATUS) if(STATUS==ESMF_SUCCESS) then - q_ana = ptr3d + q_rep = ptr3d if( currTime /= REPLAY_TIMEP0 ) then call ESMFL_BundleGetPointertoData(RBUNDLEM1,trim(rnames(k)),ptr3d, RC=STATUS) VERIFY_(STATUS) - q_ana = facp0*q_ana + facm1*ptr3d + q_rep = facp0*q_rep + facm1*ptr3d if( REPLAY_TIME_INTERP == "CUBIC" ) then call ESMFL_BundleGetPointertoData(RBUNDLEP1,trim(rnames(k)),ptr3d, RC=STATUS) VERIFY_(STATUS) - q_ana = q_ana + facp1*ptr3d + q_rep = q_rep + facp1*ptr3d call ESMFL_BundleGetPointertoData(RBUNDLEM2,trim(rnames(k)),ptr3d, RC=STATUS) VERIFY_(STATUS) - q_ana = q_ana + facm2*ptr3d - ! q_ana = max( q_ana, 0.0 ) + q_rep = q_rep + facm2*ptr3d + ! q_rep = max( q_rep, 0.0 ) endif endif - if( REPLAY_QV_FACTOR.ne.1.0 ) q_ana = q_ana * REPLAY_QV_FACTOR + if( REPLAY_QV_FACTOR.ne.1.0 ) q_rep = q_rep * REPLAY_QV_FACTOR FOUND = .true. exit endif @@ -1786,22 +1836,22 @@ subroutine handleANA_ if( match('o3',REPLAY_O3,rnames(k)) ) then call ESMFL_BundleGetPointertoData(RBUNDLEP0,trim(rnames(k)),ptr3d, RC=STATUS) if(STATUS==ESMF_SUCCESS) then - o3_ana = ptr3d + o3_rep = ptr3d if( currTime /= REPLAY_TIMEP0 ) then call ESMFL_BundleGetPointertoData(RBUNDLEM1,trim(rnames(k)),ptr3d, RC=STATUS) VERIFY_(STATUS) - o3_ana = facp0*o3_ana + facm1*ptr3d + o3_rep = facp0*o3_rep + facm1*ptr3d if( REPLAY_TIME_INTERP == "CUBIC" ) then call ESMFL_BundleGetPointertoData(RBUNDLEP1,trim(rnames(k)),ptr3d, RC=STATUS) VERIFY_(STATUS) - o3_ana = o3_ana + facp1*ptr3d + o3_rep = o3_rep + facp1*ptr3d call ESMFL_BundleGetPointertoData(RBUNDLEM2,trim(rnames(k)),ptr3d, RC=STATUS) VERIFY_(STATUS) - o3_ana = o3_ana + facm2*ptr3d - ! o3_ana = max( o3_ana, 0.0 ) + o3_rep = o3_rep + facm2*ptr3d + ! o3_rep = max( o3_rep, 0.0 ) endif endif - if( REPLAY_O3_FACTOR.ne.1.0 ) o3_ana = o3_ana * REPLAY_O3_FACTOR + if( REPLAY_O3_FACTOR.ne.1.0 ) o3_rep = o3_rep * REPLAY_O3_FACTOR FOUND = .true. exit endif @@ -1815,15 +1865,22 @@ subroutine handleANA_ ! ANA Pressure Variables ! ---------------------- - ple_ana(:,:,0) = ak(0) - do L=1,lm - ple_ana(:,:,L) = ple_ana(:,:,L-1) + dp_ana(:,:,L) + if( LMana.eq.LMbkg ) then + ak_rep = ak + bk_rep = bk + else + call set_eta ( LMana,ksdum,ptopdum,pintdum,ak_rep,bk_rep ) + endif + + ple_rep(:,:,0) = ak_rep(0) + do L=1,LMana + ple_rep(:,:,L) = ple_rep(:,:,L-1) + dp_rep(:,:,L) enddo - pke_ana(:,:,:) = ple_ana(:,:,:)**MAPL_KAPPA - do L=1,lm - pk_ana(:,:,L) = ( pke_ana(:,:,L)-pke_ana(:,:,L-1) ) & - / ( MAPL_KAPPA*log(ple_ana(:,:,L)/ple_ana(:,:,L-1)) ) + pke_rep(:,:,:) = ple_rep(:,:,:)**MAPL_KAPPA + do L=1,LMana + pk_rep(:,:,L) = ( pke_rep(:,:,L)-pke_rep(:,:,L-1) ) & + / ( MAPL_KAPPA*log(ple_rep(:,:,L)/ple_rep(:,:,L-1)) ) enddo ! ANA Temperature Variable @@ -1846,21 +1903,21 @@ subroutine handleANA_ call ESMFL_BundleGetPointertoData(RBUNDLEP0,trim(rnames(k)),ptr3d, RC=STATUS) if(STATUS==ESMF_SUCCESS) then if( trim(REPLAY_T_TYPE).eq.'NULL' .or. trim(REPLAY_T_TYPE).eq.'T' ) then - t_ana = ptr3d + t_rep = ptr3d if( currTime /= REPLAY_TIMEP0 ) then call ESMFL_BundleGetPointertoData(RBUNDLEM1,trim(rnames(k)),ptr3d, RC=STATUS) VERIFY_(STATUS) - t_ana = facp0*t_ana + facm1*ptr3d + t_rep = facp0*t_rep + facm1*ptr3d if( REPLAY_TIME_INTERP == "CUBIC" ) then call ESMFL_BundleGetPointertoData(RBUNDLEP1,trim(rnames(k)),ptr3d, RC=STATUS) VERIFY_(STATUS) - t_ana = t_ana + facp1*ptr3d + t_rep = t_rep + facp1*ptr3d call ESMFL_BundleGetPointertoData(RBUNDLEM2,trim(rnames(k)),ptr3d, RC=STATUS) VERIFY_(STATUS) - t_ana = t_ana + facm2*ptr3d + t_rep = t_rep + facm2*ptr3d endif endif - if( REPLAY_T_FACTOR.ne.1.0 ) T_ana = T_ana * REPLAY_T_FACTOR + if( REPLAY_T_FACTOR.ne.1.0 ) T_rep = T_rep * REPLAY_T_FACTOR FOUND = .true. exit endif @@ -1870,22 +1927,22 @@ subroutine handleANA_ call ESMFL_BundleGetPointertoData(RBUNDLEP0,trim(rnames(k)),ptr3d, RC=STATUS) if(STATUS==ESMF_SUCCESS) then if( trim(REPLAY_T_TYPE).eq.'NULL' .or. trim(REPLAY_T_TYPE).eq.'TV' ) then - t_ana = ptr3d + t_rep = ptr3d if( currTime /= REPLAY_TIMEP0 ) then call ESMFL_BundleGetPointertoData(RBUNDLEM1,trim(rnames(k)),ptr3d, RC=STATUS) VERIFY_(STATUS) - t_ana = facp0*t_ana + facm1*ptr3d + t_rep = facp0*t_rep + facm1*ptr3d if( REPLAY_TIME_INTERP == "CUBIC" ) then call ESMFL_BundleGetPointertoData(RBUNDLEP1,trim(rnames(k)),ptr3d, RC=STATUS) VERIFY_(STATUS) - t_ana = t_ana + facp1*ptr3d + t_rep = t_rep + facp1*ptr3d call ESMFL_BundleGetPointertoData(RBUNDLEM2,trim(rnames(k)),ptr3d, RC=STATUS) VERIFY_(STATUS) - t_ana = t_ana + facm2*ptr3d + t_rep = t_rep + facm2*ptr3d endif endif - t_ana = t_ana/(1.0+eps*q_ana) - if( REPLAY_T_FACTOR.ne.1.0 ) T_ana = T_ana * REPLAY_T_FACTOR + t_rep = t_rep/(1.0+eps*q_rep) + if( REPLAY_T_FACTOR.ne.1.0 ) T_rep = T_rep * REPLAY_T_FACTOR FOUND = .true. exit endif @@ -1895,22 +1952,22 @@ subroutine handleANA_ call ESMFL_BundleGetPointertoData(RBUNDLEP0,trim(rnames(k)),ptr3d, RC=STATUS) if(STATUS==ESMF_SUCCESS) then if( trim(REPLAY_T_TYPE).eq.'NULL' .or. trim(REPLAY_T_TYPE).eq.'TH' ) then - t_ana = ptr3d + t_rep = ptr3d if( currTime /= REPLAY_TIMEP0 ) then call ESMFL_BundleGetPointertoData(RBUNDLEM1,trim(rnames(k)),ptr3d, RC=STATUS) VERIFY_(STATUS) - t_ana = facp0*t_ana + facm1*ptr3d + t_rep = facp0*t_rep + facm1*ptr3d if( REPLAY_TIME_INTERP == "CUBIC" ) then call ESMFL_BundleGetPointertoData(RBUNDLEP1,trim(rnames(k)),ptr3d, RC=STATUS) VERIFY_(STATUS) - t_ana = t_ana + facp1*ptr3d + t_rep = t_rep + facp1*ptr3d call ESMFL_BundleGetPointertoData(RBUNDLEM2,trim(rnames(k)),ptr3d, RC=STATUS) VERIFY_(STATUS) - t_ana = t_ana + facm2*ptr3d + t_rep = t_rep + facm2*ptr3d endif endif - t_ana = t_ana*pk_ana - if( REPLAY_T_FACTOR.ne.1.0 ) T_ana = T_ana * REPLAY_T_FACTOR + t_rep = t_rep*pk_rep + if( REPLAY_T_FACTOR.ne.1.0 ) T_rep = T_rep * REPLAY_T_FACTOR FOUND = .true. exit endif @@ -1920,22 +1977,22 @@ subroutine handleANA_ call ESMFL_BundleGetPointertoData(RBUNDLEP0,trim(rnames(k)),ptr3d, RC=STATUS) if(STATUS==ESMF_SUCCESS) then if( trim(REPLAY_T_TYPE).eq.'NULL' .or. trim(REPLAY_T_TYPE).eq.'THV' ) then - t_ana = ptr3d + t_rep = ptr3d if( currTime /= REPLAY_TIMEP0 ) then call ESMFL_BundleGetPointertoData(RBUNDLEM1,trim(rnames(k)),ptr3d, RC=STATUS) VERIFY_(STATUS) - t_ana = facp0*t_ana + facm1*ptr3d + t_rep = facp0*t_rep + facm1*ptr3d if( REPLAY_TIME_INTERP == "CUBIC" ) then call ESMFL_BundleGetPointertoData(RBUNDLEP1,trim(rnames(k)),ptr3d, RC=STATUS) VERIFY_(STATUS) - t_ana = t_ana + facp1*ptr3d + t_rep = t_rep + facp1*ptr3d call ESMFL_BundleGetPointertoData(RBUNDLEM2,trim(rnames(k)),ptr3d, RC=STATUS) VERIFY_(STATUS) - t_ana = t_ana + facm2*ptr3d + t_rep = t_rep + facm2*ptr3d endif endif - t_ana = t_ana*pk_ana/(1.0+eps*q_ana) - if( REPLAY_T_FACTOR.ne.1.0 ) T_ana = T_ana * REPLAY_T_FACTOR + t_rep = t_rep*pk_rep/(1.0+eps*q_rep) + if( REPLAY_T_FACTOR.ne.1.0 ) T_rep = T_rep * REPLAY_T_FACTOR FOUND = .true. exit endif @@ -1950,48 +2007,70 @@ subroutine handleANA_ ! Test for Re-Mapping ! ------------------- - if (doremap ) then + if (doremap) then + + if( LMana.eq.LMbkg ) then NPHIS = count( phis_ana.ne.phis_bkg ) call MAPL_CommsAllReduceMax(vm,sendbuf=NPHIS,recvbuf=NPHIS_MAX,cnt=1,rc=status) VERIFY_(STATUS) + else + NPHIS_MAX = 999 ! Force Vertical Remapping when LMana != LMbkg + endif + if( NPHIS_MAX > 0 ) then + if(first .and. MAPL_AM_I_ROOT()) then - print *, 'Vertical Remapping ANA Data to BKG Topography ...' + print *, 'Vertical Remapping ANA Data to BKG Topography and Levels ...' print * endif - ! Create ANA Virtual Potential Temperature - ! ---------------------------------------- - thv_ana = t_ana*(1.0+eps*q_ana)/pk_ana - - call myremap ( ple_ana, & - u_ana, & - v_ana, & - thv_ana, & - q_ana, & - o3_ana, & - phis_ana,phis_bkg,ak,bk,im,jm,lm ) + thv_rep = t_rep*(1.0+eps*q_rep)/pk_rep + call myremap ( ple_rep, ple_ana, & + u_rep, u_ana, & + v_rep, v_ana, & + thv_rep, thv_ana, & + q_rep, q_ana, & + o3_rep, o3_ana, & + phis_ana, phis_bkg, & + ak_rep,bk_rep, ak,bk, & + im,jm,LMana,LMbkg ) ! Create ANA Dry Temperature ! -------------------------- - ps_ana(:,:) = ple_ana(:,:,lm) - pke_ana(:,:,:) = ple_ana(:,:,:)**MAPL_KAPPA - do L=1,lm - pk_ana(:,:,L) = ( pke_ana(:,:,L)-pke_ana(:,:,L-1) ) & - / ( MAPL_KAPPA*log(ple_ana(:,:,L)/ple_ana(:,:,L-1)) ) - enddo - t_ana = thv_ana*pk_ana/(1.0+eps*q_ana) + ps_ana(:,:) = ple_ana(:,:,LMbkg) + pke_ana(:,:,:) = ple_ana(:,:,:)**MAPL_KAPPA + do L=1,LMbkg + pk_ana(:,:,L) = ( pke_ana(:,:,L)-pke_ana(:,:,L-1) ) & + / ( MAPL_KAPPA*log(ple_ana(:,:,L)/ple_ana(:,:,L-1)) ) + enddo + t_ana = thv_ana*pk_ana/(1.0+eps*q_ana) + else - if(first .and. MAPL_AM_I_ROOT()) then - print *, 'Vertical Remapping not necessary since ANA and BKG Topographies are identical.' - print * - endif + + if(first .and. MAPL_AM_I_ROOT()) then + print *, 'Vertical Remapping not necessary since ANA and BKG Topographies and Levels are identical.' + print * + endif + ple_ana = ple_rep + u_ana = u_rep + v_ana = v_rep + t_ana = t_rep + q_ana = q_rep + o3_ana = o3_rep + endif + else if(first .and. MAPL_AM_I_ROOT()) then print * - print *, 'Vertical Remapping ANA Data to BKG Topography is disabled.' + print *, 'Vertical Remapping ANA Data to BKG Topography and Levels is disabled.' print * endif + ple_ana = ple_rep + u_ana = u_rep + v_ana = v_rep + t_ana = t_rep + q_ana = q_rep + o3_ana = o3_rep endif ! ********************************************************************** @@ -2035,7 +2114,7 @@ subroutine handleANA_ call blend ( ple_ana,u_ana,v_ana,t_ana,q_ana,o3_ana, & ple_bkg,u_bkg,v_bkg,t_bkg,q_bkg,o3_bkg, & - im,jm,lm, DAMPBEG,DAMPEND, BLEND_QV_AT_TP, & + im,jm,LMbkg, DAMPBEG,DAMPEND, BLEND_QV_AT_TP, & tropp=tropp ) if( BLEND_QV_AT_TP ) then @@ -2066,7 +2145,7 @@ subroutine handleANA_ method = 1 call MAPL_TimerON(MAPL,"--WINDFIX") call windfix ( u_ana,v_ana,ple_ana, & - u_bkg,v_bkg,ple_bkg,im,jm,lm,VM,GRIDana,method, & + u_bkg,v_bkg,ple_bkg,im,jm,LMbkg,VM,GRIDana,method, & vintdiva,vintdivb,vintdivc ) call MAPL_TimerOFF(MAPL,"--WINDFIX") endif @@ -2100,18 +2179,18 @@ subroutine handleANA_ call MAPL_GetPointer(export,dvwindfix, 'DVWINDFIX', alloc=.TRUE., RC=STATUS) VERIFY_(STATUS) - allocate( ptr3d(IM,JM,lm),stat=STATUS) + allocate( ptr3d(IM,JM,LMbkg),stat=STATUS) VERIFY_(STATUS) - allocate( uptr3d(IM,JM,lm),stat=STATUS) + allocate( uptr3d(IM,JM,LMbkg),stat=STATUS) VERIFY_(STATUS) - allocate( vptr3d(IM,JM,lm),stat=STATUS) + allocate( vptr3d(IM,JM,LMbkg),stat=STATUS) VERIFY_(STATUS) uptr3d = du_fix vptr3d = dv_fix if (trim(GRIDINC)=="ANA" .and. USE_SPECFILT .and. (L_REPLAY_U .or. L_REPLAY_V) ) then - call Spectrans_VectorPar (im,jm,lm,uptr3d,vptr3d,JCAP,GRIDana,RC=STATUS) + call Spectrans_VectorPar (im,jm,LMbkg,uptr3d,vptr3d,JCAP,GRIDana,RC=STATUS) VERIFY_(STATUS) endif if (trim(GRIDINC)=="ANA" .and. do_transforms) then @@ -2143,7 +2222,7 @@ subroutine handleANA_ endif if (trim(GRIDINC)=="ANA" .and. USE_SPECFILT .and. (L_REPLAY_U .or. L_REPLAY_V) ) then - call Spectrans_VectorPar (im,jm,lm,uptr3d,vptr3d,JCAP,GRIDana,RC=STATUS) + call Spectrans_VectorPar (im,jm,LMbkg,uptr3d,vptr3d,JCAP,GRIDana,RC=STATUS) VERIFY_(STATUS) endif if (trim(GRIDINC)=="ANA" .and. do_transforms) then @@ -2171,7 +2250,7 @@ subroutine handleANA_ ptr3d = 0.0 endif if (trim(GRIDINC)=="ANA" .and. USE_SPECFILT .and. L_REPLAY_T) then - call Spectrans_ScalarPar (im,jm,lm,ptr3d,JCAP,GRIDana,RC=STATUS) + call Spectrans_ScalarPar (im,jm,LMbkg,ptr3d,JCAP,GRIDana,RC=STATUS) VERIFY_(STATUS) endif if (trim(GRIDINC)=="ANA" .and. do_transforms) then @@ -2189,7 +2268,7 @@ subroutine handleANA_ ptr3d = 0.0 endif if (trim(GRIDINC)=="ANA" .and. USE_SPECFILT .and. L_REPLAY_QV) then - call Spectrans_ScalarPar (im,jm,lm,ptr3d,JCAP,GRIDana,RC=STATUS) + call Spectrans_ScalarPar (im,jm,LMbkg,ptr3d,JCAP,GRIDana,RC=STATUS) VERIFY_(STATUS) endif if (trim(GRIDINC)=="ANA" .and. do_transforms) then @@ -2207,7 +2286,7 @@ subroutine handleANA_ ptr3d = 0.0 endif if (trim(GRIDINC)=="ANA" .and. USE_SPECFILT .and. L_REPLAY_O3) then - call Spectrans_ScalarPar (im,jm,lm,ptr3d,JCAP,GRIDana,RC=STATUS) + call Spectrans_ScalarPar (im,jm,LMbkg,ptr3d,JCAP,GRIDana,RC=STATUS) VERIFY_(STATUS) endif if (trim(GRIDINC)=="ANA" .and. do_transforms) then @@ -2220,7 +2299,7 @@ subroutine handleANA_ ! PLE ! --- deallocate( ptr3d ) - allocate( ptr3d(IM,JM,0:LM),stat=STATUS) + allocate( ptr3d(IM,JM,0:LMbkg),stat=STATUS) VERIFY_(STATUS) if( L_REPLAY_P ) then ptr3d = ple_ana-ple_bkg @@ -2344,7 +2423,6 @@ subroutine handleANA_ deallocate ( q_ana ) deallocate ( o3_ana ) deallocate ( ps_ana ) - deallocate ( dp_ana ) deallocate ( pk_ana ) deallocate ( pke_ana ) deallocate ( thv_ana ) @@ -2355,6 +2433,19 @@ subroutine handleANA_ deallocate ( vintdivb ) deallocate ( vintdivc ) + deallocate ( dp_rep ) + deallocate ( u_rep ) + deallocate ( v_rep ) + deallocate ( t_rep ) + deallocate ( thv_rep ) + deallocate ( q_rep ) + deallocate ( o3_rep ) + deallocate ( pk_rep ) + deallocate ( ple_rep ) + deallocate ( pke_rep ) + deallocate ( ak_rep ) + deallocate ( bk_rep ) + first = .false. end subroutine handleANA_ @@ -3090,4 +3181,173 @@ subroutine spectrans_scalarglob(InGlob,OutGLob,jcap,RC) RETURN_(ESMF_SUCCESS) end subroutine spectrans_scalarglob + subroutine myremap ( ple_in,ple_out, & + u_in, u_out, & + v_in, v_out, & + thv_in,thv_out, & + qv_in, qv_out, & + o3_in, o3_out, & + phis_in,phis_out, & + ak_in,bk_in, ak_out,bk_out,im,jm,LM_in,LM_out ) + +!*********************************************************************** +! +! Purpose +! Driver for Remapping Fields to New Topography and Levels +! +! Argument Description +! +! ple_in ...... input edge pressure +! u_in ....... input zonal wind +! v_in ....... input meridional wind +! thv_in ..... input virtual potential temperature +! qv_in ....... input specific humidity +! o3_in ...... input ozone + +! ple_out...... output edge pressure +! u_out ....... output zonal wind +! v_out ....... output meridional wind +! thv_out ..... output virtual potential temperature +! qv_out ...... output specific humidity +! o3_out ...... output ozone + +! phis_in... input surface geopotential +! phis_out.. output surface geopotential +! ak_in .... input vertical dimension +! bk_in .... input vertical dimension +! ak_out ... output vertical dimension +! bk_out ... output vertical dimension +! +! im ....... zonal dimension +! jm ....... meridional dimension +! LM_in .... input vertical dimension +! LM_out ... output vertical dimension +! +!*********************************************************************** +!* GODDARD LABORATORY FOR ATMOSPHERES * +!*********************************************************************** + + use GEOS_GmapMod, only: gmap + implicit none + integer im,jm,LM_in,LM_out + +! Input variables +! --------------- + real ple_in(im,jm,LM_in+1) + real u_in(im,jm,LM_in) + real v_in(im,jm,LM_in) + real thv_in(im,jm,LM_in) + real qv_in(im,jm,LM_in) + real o3_in(im,jm,LM_in) + + real ple_out(im,jm,LM_out+1) + real u_out(im,jm,LM_out) + real v_out(im,jm,LM_out) + real thv_out(im,jm,LM_out) + real qv_out(im,jm,LM_out) + real o3_out(im,jm,LM_out) + + real phis_in (im,jm) + real phis_out(im,jm) + + real ak_in (LM_in +1) + real bk_in (LM_in +1) + real ak_out(LM_out+1) + real bk_out(LM_out+1) + +! Local variables +! --------------- + real, allocatable :: phi_in (:,:,:) + real, allocatable :: pke_in (:,:,:) + + real, allocatable :: ps_out(:,:) + real, allocatable :: pke_out(:,:,:) + + real, allocatable :: q_in (:,:,:,:) + real, allocatable :: q_out(:,:,:,:) + + real kappa,cp,rgas,eps,rvap + integer i,j,L + + kappa = 2.0/7.0 + rgas = 8314.3/28.97 + rvap = 8314.3/18.01 + eps = rvap/rgas-1.0 + cp = rgas/kappa + + allocate( phi_in (im,jm,LM_in +1) ) + allocate( pke_in (im,jm,LM_in +1) ) + + allocate( ps_out (im,jm) ) + allocate( pke_out(im,jm,LM_out+1) ) + + allocate( q_in (im,jm,LM_in ,2) ) + allocate( q_out(im,jm,LM_out,2) ) + +! Construct Input Heights +! ----------------------- + pke_in(:,:,:) = ple_in(:,:,:)**kappa + + phi_in(:,:,LM_in+1) = phis_in(:,:) + do L=LM_in,1,-1 + phi_in(:,:,L) = phi_in(:,:,L+1) + cp*thv_in(:,:,L)*( pke_in(:,:,L+1)-pke_in(:,:,L) ) + enddo + +! Compute new surface pressure consistent with output topography +! -------------------------------------------------------------- + do j=1,jm + do i=1,im + L = LM_in + do while ( phi_in(i,j,L).lt.phis_out(i,j) ) + L = L-1 + enddo + ps_out(i,j) = ple_in(i,j,L+1)*( 1+(phi_in(i,j,L+1)-phis_out(i,j))/(cp*thv_in(i,j,L)*pke_in(i,j,L+1)) )**(1.0/kappa) + enddo + enddo + +! Construct pressure variables using new surface pressure +! ------------------------------------------------------- + if( LM_in .eq. LM_out ) then + do L=1,LM_in+1 + do j=1,jm + do i=1,im + ple_out(i,j,L) = ple_in(i,j,L) + bk_in(L)*( ps_out(i,j)-ple_in(i,j,LM_in+1) ) + enddo + enddo + enddo + else + do L=1,LM_out+1 + do j=1,jm + do i=1,im + ple_out(i,j,L) = ak_out(L) + bk_out(L)*ps_out(i,j) + enddo + enddo + enddo + endif + + pke_out(:,:,:) = ple_out(:,:,:)**kappa + +! Map original fv state onto new eta grid +! --------------------------------------- + q_in(:,:,:,1) = qv_in(:,:,:) + q_in(:,:,:,2) = o3_in(:,:,:) + + call gmap ( im,jm,2 , kappa, & + LM_in, pke_in ,ple_in ,u_in ,v_in ,thv_in ,q_in , & + LM_out, pke_out,ple_out,u_out,v_out,thv_out,q_out) + + qv_out(:,:,:) = q_out(:,:,:,1) + o3_out(:,:,:) = q_out(:,:,:,2) + + deallocate( phi_in ) + deallocate( pke_in ) + deallocate( ps_out ) + deallocate( pke_out ) + + deallocate( q_in ) + deallocate( q_out ) + + return + end subroutine myremap + end module GEOS_mkiauGridCompMod diff --git a/GEOSogcm_GridComp/GEOSocean_GridComp/GuestOcean_GridComp/GuestOcean_GridComp.F90 b/GEOSogcm_GridComp/GEOSocean_GridComp/GuestOcean_GridComp/GuestOcean_GridComp.F90 index 36d7a2df4..93837347e 100644 --- a/GEOSogcm_GridComp/GEOSocean_GridComp/GuestOcean_GridComp/GuestOcean_GridComp.F90 +++ b/GEOSogcm_GridComp/GEOSocean_GridComp/GuestOcean_GridComp/GuestOcean_GridComp.F90 @@ -29,7 +29,7 @@ module GuestOcean_GridCompMod ! ! {\tt GuestOcean\_GridComp} is a light-weight gridded component that serves an ! interface to ocean/data\_ocean components. -! +! !EOP type :: T_PrivateState @@ -112,7 +112,7 @@ subroutine SetServices ( GC, RC ) OCEAN_NAME="MOM" OCN = MAPL_AddChild(GC, NAME=OCEAN_NAME, SS=MOMSetServices, RC=STATUS) VERIFY_(STATUS) - end if + endif ! Set the state variable specs. ! ----------------------------- @@ -127,8 +127,8 @@ subroutine SetServices ( GC, RC ) UNITS = '1', & DIMS = MAPL_DimsHorzOnly, & VLOCATION = MAPL_VLocationNone, & - RC=status ) - VERIFY_(status) + RC=STATUS ) + VERIFY_(STATUS) call MAPL_AddImportSpec(GC, & SHORT_NAME = 'TAUX', & @@ -148,77 +148,77 @@ subroutine SetServices ( GC, RC ) RC=STATUS ) VERIFY_(STATUS) - call MAPL_AddImportSpec(GC, & + call MAPL_AddImportSpec(GC, & SHORT_NAME = 'PENUVR', & LONG_NAME = 'net_downward_penetrating_direct_UV_flux', & UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=status ) + VERIFY_(status) - call MAPL_AddImportSpec(GC, & + call MAPL_AddImportSpec(GC, & SHORT_NAME = 'PENPAR', & LONG_NAME = 'net_downward_penetrating_direct_PAR_flux', & UNITS = 'W m-2', & DIMS = MAPL_DimsHorzOnly, & VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) + RC=STATUS ) + VERIFY_(STATUS) - call MAPL_AddImportSpec(GC, & + call MAPL_AddImportSpec(GC, & SHORT_NAME = 'PENUVF', & LONG_NAME = 'net_downward_penetrating_diffuse_UV_flux', & UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & RC=STATUS ) - VERIFY_(STATUS) + VERIFY_(STATUS) - call MAPL_AddImportSpec(GC, & + call MAPL_AddImportSpec(GC, & SHORT_NAME = 'PENPAF', & LONG_NAME = 'net_downward_penetrating_diffuse_PAR_flux', & UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & RC=STATUS ) - VERIFY_(STATUS) + VERIFY_(STATUS) - call MAPL_AddImportSpec(GC ,& + call MAPL_AddImportSpec(GC, & LONG_NAME = 'net_surface_downwelling_nir_beam_flux',& UNITS = 'W m-2' ,& SHORT_NAME = 'DRNIR' ,& - DIMS = MAPL_DimsHorzOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) - call MAPL_AddImportSpec(GC ,& + call MAPL_AddImportSpec(GC, & LONG_NAME = 'net_surface_downwelling_nir_diffuse_flux',& UNITS = 'W m-2' ,& SHORT_NAME = 'DFNIR' ,& - DIMS = MAPL_DimsHorzOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec(GC, & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & SHORT_NAME = 'SWHEAT', & LONG_NAME = 'solar_heating_rate', & UNITS = 'W m-2', & DIMS = MAPL_DimsHorzVert, & VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec(GC, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & LONG_NAME = 'river_discharge_at_ocean_points',& UNITS = 'kg m-2 s-1' ,& SHORT_NAME = 'DISCHARGE' ,& - DIMS = MAPL_DimsHorzOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) !!$ call MAPL_AddImportSpec(GC, & !!$ SHORT_NAME = 'TR', & @@ -240,80 +240,80 @@ subroutine SetServices ( GC, RC ) !!$ RC=STATUS ) !!$ VERIFY_(STATUS) - call MAPL_AddImportSpec(GC ,& + call MAPL_AddImportSpec(GC, & LONG_NAME = 'surface_net_downward_longwave_flux',& - UNITS = 'W m-2' ,& + UNITS = 'W m-2', & SHORT_NAME = 'LWFLX' ,& - DIMS = MAPL_DimsHorzOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) VERIFY_(STATUS) - call MAPL_AddImportSpec(GC, & + call MAPL_AddImportSpec(GC, & LONG_NAME = 'upward_sensible_heat_flux' ,& - UNITS = 'W m-2' ,& + UNITS = 'W m-2', & SHORT_NAME = 'SHFLX' ,& - DIMS = MAPL_DimsHorzOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) VERIFY_(STATUS) - call MAPL_AddImportSpec(GC, & + call MAPL_AddImportSpec(GC, & LONG_NAME = 'evaporation' ,& UNITS = 'kg m-2 s-1' ,& SHORT_NAME = 'QFLUX' ,& - DIMS = MAPL_DimsHorzOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) VERIFY_(STATUS) - call MAPL_AddImportSpec(GC, & + call MAPL_AddImportSpec(GC, & LONG_NAME = 'ocean_snowfall' ,& UNITS = 'kg m-2 s-1' ,& SHORT_NAME = 'SNOW' ,& - DIMS = MAPL_DimsHorzOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) VERIFY_(STATUS) - - call MAPL_AddImportSpec(GC, & + + call MAPL_AddImportSpec(GC, & LONG_NAME = 'ocean_rainfall' ,& UNITS = 'kg m-2 s-1' ,& SHORT_NAME = 'RAIN' ,& DIMS = MAPL_DimsHorzOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) - - call MAPL_AddImportSpec(GC, & + + call MAPL_AddImportSpec(GC, & SHORT_NAME = 'FRESH', & LONG_NAME = 'fresh_water_flux_due_to_ice_dynamics', & - UNITS = 'kg m-2 s-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) + UNITS = 'kg m-2 s-1' ,& + DIMS = MAPL_DimsHorzOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) VERIFY_(STATUS) - call MAPL_AddImportSpec(GC, & + call MAPL_AddImportSpec(GC, & SHORT_NAME = 'FSALT', & LONG_NAME = 'salt_flux_due_to_ice_dynamics', & UNITS = 'kg m-2 s-1', & DIMS = MAPL_DimsHorzOnly, & VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) - call MAPL_AddImportSpec(GC, & + call MAPL_AddImportSpec(GC, & SHORT_NAME = 'FHOCN', & LONG_NAME = 'heat_flux_due_to_ice_dynamics', & UNITS = 'W m-2', & DIMS = MAPL_DimsHorzOnly, & VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) ! ! Need to have this internal state to fill in orphan points: - + call MAPL_AddInternalSpec(GC, & SHORT_NAME = 'TS_FOUND', & LONG_NAME = 'foundation_temperature_for_interface_layer',& @@ -324,10 +324,10 @@ subroutine SetServices ( GC, RC ) DEFAULT = 280.0, & RC=STATUS ) VERIFY_(STATUS) - + ! !EXPORT STATE: - + call MAPL_AddExportSpec(GC, & SHORT_NAME = 'MASKO', & LONG_NAME = 'ocean_mask',& @@ -337,7 +337,8 @@ subroutine SetServices ( GC, RC ) RC=STATUS ) VERIFY_(STATUS) - call MAPL_AddExportSpec(GC, & + + call MAPL_AddExportSpec(GC, & SHORT_NAME = 'SS_FOUND', & LONG_NAME = 'foundation_salinity_for_interface_layer',& UNITS = 'PSU', & @@ -346,7 +347,7 @@ subroutine SetServices ( GC, RC ) RC=STATUS ) VERIFY_(STATUS) - call MAPL_AddExportSpec(GC, & + call MAPL_AddExportSpec(GC, & SHORT_NAME = 'FRZMLT', & LONG_NAME = 'freeze_melt_potential', & UNITS = 'W m-2', & @@ -393,13 +394,13 @@ subroutine SetServices ( GC, RC ) RC=STATUS ) VERIFY_(STATUS) - call MAPL_AddExportSpec(GC, & + call MAPL_AddExportSpec(GC, & LONG_NAME = 'river_discharge_at_ocean_points',& UNITS = 'kg m-2 s-1' ,& SHORT_NAME = 'DISCHARGE' ,& - DIMS = MAPL_DimsHorzOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & @@ -408,71 +409,71 @@ subroutine SetServices ( GC, RC ) UNITS = '1', & DIMS = MAPL_DimsHorzOnly, & VLOCATION = MAPL_VLocationNone, & - RC=status ) - VERIFY_(status) + RC=STATUS ) + VERIFY_(STATUS) - call MAPL_AddExportSpec(GC ,& + call MAPL_AddExportSpec(GC, & LONG_NAME = 'surface_net_downward_longwave_flux',& UNITS = 'W m-2' ,& SHORT_NAME = 'LWFLX' ,& - DIMS = MAPL_DimsHorzOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC ,& + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & LONG_NAME = 'surface_net_downward_shortwave_flux',& UNITS = 'W m-2' ,& SHORT_NAME = 'SWFLX' ,& - DIMS = MAPL_DimsHorzOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) - call MAPL_AddExportSpec(GC, & + call MAPL_AddExportSpec(GC, & LONG_NAME = 'upward_sensible_heat_flux' ,& - UNITS = 'W m-2' ,& + UNITS = 'W m-2', & SHORT_NAME = 'SHFLX' ,& - DIMS = MAPL_DimsHorzOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) - call MAPL_AddExportSpec(GC, & + call MAPL_AddExportSpec(GC, & LONG_NAME = 'evaporation' ,& UNITS = 'kg m-2 s-1' ,& SHORT_NAME = 'QFLUX' ,& - DIMS = MAPL_DimsHorzOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - VERIFY_(STATUS) + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) - call MAPL_AddExportSpec(GC, & + call MAPL_AddExportSpec(GC, & SHORT_NAME = 'SFLX', & LONG_NAME = 'salt_flux_due_to_ice_dynamics', & UNITS = 'kg m-2 s-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) - call MAPL_AddExportSpec(GC, & + call MAPL_AddExportSpec(GC, & SHORT_NAME = 'RAIN', & LONG_NAME = 'ocean_rainfall',& UNITS = 'kg m-2 s-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=status ) + VERIFY_(status) - call MAPL_AddExportSpec(GC, & + call MAPL_AddExportSpec(GC, & SHORT_NAME = 'SNOW', & LONG_NAME = 'ocean_snowfall',& UNITS = 'kg m-2 s-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) - VERIFY_(STATUS) + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) ! Exports of child @@ -523,7 +524,7 @@ subroutine SetServices ( GC, RC ) CHILD_ID = OCN, & RC=STATUS ) VERIFY_(STATUS) - call MAPL_AddExportSpec ( GC , & + call MAPL_AddExportSpec ( GC , & SHORT_NAME = 'FRAZIL', & CHILD_ID = OCN, & RC=STATUS ) @@ -549,7 +550,7 @@ subroutine SetServices ( GC, RC ) !EOS if(DO_DATASEA==0) then - call MAPL_TerminateImport ( GC, SHORT_NAME=& + call MAPL_TerminateImport ( GC, SHORT_NAME= & [character(len=9) :: 'TAUX ','TAUY ', & 'PENUVR','PENPAR','PENUVF','PENPAF', 'DRNIR', 'DFNIR', & 'DISCHARGE', 'LWFLX', 'SHFLX', 'QFLUX', 'RAIN', 'SNOW', 'SFLX','SWHEAT'], & @@ -570,7 +571,7 @@ subroutine SetServices ( GC, RC ) !--------------------------------------------------------------------------------------- call MAPL_GenericSetServices ( GC, RC=STATUS ) - VERIFY_(STATUS) + VERIFY_(STATUS) ! Set the Profiling timers ! ------------------------ @@ -736,9 +737,7 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_TimerOn (STATE,"TOTAL" ) if(DO_DATASEA==0) then - call MAPL_GetPointer(EXPORT, MASKO, 'MASKO' , alloc=.true.,RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(GEX(OCN), MASK3D, 'MOM_3D_MASK', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(GEX(OCN), DH, 'DH', RC=STATUS); VERIFY_(STATUS) @@ -791,7 +790,7 @@ subroutine Run ( gc, import, export, clock, rc ) type (MAPL_MetaComp), pointer :: STATE type (ESMF_Time) :: EndTime - type (ESMF_Time) :: MyTime + type (ESMF_Time) :: MyTime,ct type (T_PrivateState), pointer :: PrivateSTATE type (T_PrivateState_Wrap) :: WRAP type (ESMF_GridComp ), pointer :: GCS(:) @@ -883,6 +882,7 @@ subroutine Run ( gc, import, export, clock, rc ) real, pointer :: LATS (:,:) real, parameter :: OrphanSalinity=34.0 real :: Tfreeze + character(len=ESMF_MAXSTR) :: replayMode ! Get the component's name and set-up traceback handle. ! ----------------------------------------------------- @@ -936,6 +936,25 @@ subroutine Run ( gc, import, export, clock, rc ) call ESMF_ClockGet( PrivateState%CLOCK, currTime=myTime, RC=STATUS) VERIFY_(status) + call MAPL_GetResource(state,ReplayMode, 'REPLAY_MODE:', default="NoReplay", RC=STATUS ) + if (DO_DATASEA /=0 .and. trim(replayMode)=="Regular" ) then + if (myTime > EndTime) then + call ESMF_ClockSet(PrivateState%Clock,direction=ESMF_DIRECTION_REVERSE,rc=status) + VERIFY_(status) + do + call ESMF_ClockAdvance(PrivateState%Clock,rc=status) + VERIFY_(status) + call ESMF_ClockGet(PrivateState%Clock,currTime=ct,rc=status) + VERIFY_(status) + if (ct==endTime) exit + enddo + call ESMF_ClockSet(PrivateState%Clock,direction=ESMF_DIRECTION_FORWARD,rc=status) + VERIFY_(status) + call ESMF_ClockGet( PrivateState%CLOCK, currTime=myTime, RC=STATUS) + VERIFY_(status) + end if + end if + if( MyTime <= EndTime ) then ! Time to run ! We get the ocean-land mask (now computed in Initialize of Plug) @@ -948,7 +967,7 @@ subroutine Run ( gc, import, export, clock, rc ) MASK3D=1.0 allocate(MASK(IM,JM), STAT=STATUS); VERIFY_(STATUS) MASK=1.0 - end if + end if ! Get ocean time step and misc. parameters !----------------------------------------- @@ -982,7 +1001,7 @@ subroutine Run ( gc, import, export, clock, rc ) ! Get pointers from ImExState !---------------------------- - if(Do_DATASEA==0) then + if(DO_DATASEA==0) then call MAPL_GetPointer(GIM(OCN), TAUX, 'TAUX' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(GIM(OCN), TAUY, 'TAUY' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(GIM(OCN), PENUVR, 'PENUVR' , RC=STATUS); VERIFY_(STATUS) @@ -1046,10 +1065,10 @@ subroutine Run ( gc, import, export, clock, rc ) elsewhere WGHT = 0.0 end where - + if(DO_DATASEA==0) then - ! Copy imports into ImEx variables - !--------------------------------- +! Copy imports into ImEx variables +!--------------------------------- PENUVR = PENUVRi * WGHT PENPAR = PENPARi * WGHT PENUVF = PENUVFi * WGHT @@ -1063,15 +1082,15 @@ subroutine Run ( gc, import, export, clock, rc ) RAIN = (RAINi+FRESH) * WGHT SNOW = SNOWi * WGHT SFLX = FSALT * WGHT - - ! This stress forces the ocean, combined with sea ice bottom stress later + +! This stress forces the ocean, combined with sea ice bottom stress later TAUX = TAUXi * WGHT TAUY = TAUYi * WGHT - - ! Prepare radiative heating for ocean - !------------------------------------ + +! Prepare radiative heating for ocean +!------------------------------------ if(associated(RFLUX )) RFLUX = 0.0 do L=1,LM @@ -1093,22 +1112,20 @@ subroutine Run ( gc, import, export, clock, rc ) if (associated(SNOWe)) SNOWe = SNOW if (associated(SFLXe)) SFLXe = SFLX end if !DO_DATASEA - + ! Loop the ocean model !--------------------- NUM = 0 do while ( MyTime <= endTime ) - + ! Run ocean for one time step (DT) !--------------------------------- call MAPL_TimerOff(STATE,"TOTAL") call MAPL_TimerOn (STATE,"--ModRun") - call MAPL_GenericRun(GC, IMPORT, EXPORT, PrivateState%CLOCK, RC=STATUS) VERIFY_(STATUS) - call MAPL_TimerOff(STATE,"--ModRun") call MAPL_TimerOn (STATE,"TOTAL") @@ -1138,12 +1155,12 @@ subroutine Run ( gc, import, export, clock, rc ) end where else FRZMLT = 0.0 - end if end if - + end if + where(WGHT > 0.0) TS_FOUND = TW - end where + end where ! Update orphan points if(DO_DATASEA == 0) then