diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_convect.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_convect.F90 index 86dfb58e3..dc631fa6c 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_convect.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_convect.F90 @@ -8,7 +8,7 @@ module gw_convect use gw_utils, only: GW_PRC, GW_R8, get_unit_vector, dot_2d, midpoint_interp use gw_common, only: GWBand, qbo_hdepth_scaling, gw_drag_prof, hr_cf, & calc_taucd, momentum_flux, momentum_fixer, & - energy_momentum_adjust, energy_change, energy_fixer + energy_momentum_adjust, energy_change, energy_fixer use MAPL_ConstantsMod, only: MAPL_RGAS, MAPL_CP, MAPL_GRAV @@ -83,7 +83,7 @@ subroutine gw_beres_init (file_name, band, desc, pgwv, gw_dc, fcrit2, wavelength ! Vars needed by NetCDF operators integer :: ncid, dimid, varid, status - + status = nf_open(file_name , 0, ncid) status = NF_INQ_DIMID(ncid, 'PS', dimid) @@ -100,7 +100,7 @@ subroutine gw_beres_init (file_name, band, desc, pgwv, gw_dc, fcrit2, wavelength allocate( mfcc(hd_mfcc , mw_mfcc, ps_mfcc) ) allocate( hdcc(hd_mfcc) ) - + status = NF_INQ_VARID(ncid, 'HD', varid) IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status) status = NF_GET_VAR_DOUBLE(ncid, varid, hdcc ) @@ -131,7 +131,7 @@ subroutine gw_beres_init (file_name, band, desc, pgwv, gw_dc, fcrit2, wavelength ! midpoint of spectrum in netcdf file is ps_mfcc (odd number) divided by 2, plus 1 ! E.g., ps_mfcc = 81. So, ps_mfcc_mid = 41 - ! 1 11 21 31 32 33 34 35 36 37 38 39 40 41 42 43 ... + ! 1 11 21 31 32 33 34 35 36 37 38 39 40 41 42 43 ... ! -40 -30 -20 -10 -9 -8 -7 -6 -5 -4 -3 -2 -1 0 +1 +2 ... ps_mfcc_mid= INT(ngwv_file/2) + 1 @@ -142,9 +142,9 @@ subroutine gw_beres_init (file_name, band, desc, pgwv, gw_dc, fcrit2, wavelength allocate(desc%mfcc(desc%maxh,-desc%maxuh:desc%maxuh,-band%ngwv:band%ngwv), stat=status ) - desc%mfcc( : , -desc%maxuh:desc%maxuh , -band%ngwv :band%ngwv ) & + desc%mfcc( : , -desc%maxuh:desc%maxuh , -band%ngwv :band%ngwv ) & = mfcc( :, : , -band%ngwv+ps_mfcc_mid:band%ngwv+ps_mfcc_mid ) - + ! While not currently documented in the file, it uses kilometers. Convert ! to meters. desc%hd = hdcc * 1000.0 @@ -176,7 +176,7 @@ subroutine gw_beres_init (file_name, band, desc, pgwv, gw_dc, fcrit2, wavelength cw(kc) = 10.0*(4.0/real(band%ngwv))*kc cw(kc) = exp(-(cw(kc)/30.)**2) enddo - cw = cw*(sum(cw4)/sum(cw)) + cw = cw*(sum(cw4)/sum(cw)) desc%et_bkg_dqcdt_forcing = et_use_dqcdt do i=1,ncol ! include forced background stress in extra tropics @@ -199,7 +199,7 @@ subroutine gw_beres_init (file_name, band, desc, pgwv, gw_dc, fcrit2, wavelength enddo deallocate( cw, cw4 ) end if - + end subroutine gw_beres_init !------------------------------------ @@ -377,15 +377,15 @@ subroutine gw_beres_src(ncol, pver, band, desc, pint, u, v, & ! Source wind speed and direction. do i=1,ncol - uconv(i) = u(i,desc%k(i)) - vconv(i) = v(i,desc%k(i)) + uconv(i) = u(i,int(desc%k(i))) + vconv(i) = v(i,int(desc%k(i))) enddo ! Get the unit vector components and magnitude at the source level. ubi1d = 0.0 call get_unit_vector(uconv, vconv, xv, yv, ubi1d) do i=1,ncol - ubi(i,desc%k(i)+1) = ubi1d(i) + ubi(i,int(desc%k(i))+1) = ubi1d(i) enddo ! Project the local wind at midpoints onto the source wind. @@ -408,12 +408,12 @@ subroutine gw_beres_src(ncol, pver, band, desc, pint, u, v, & uh(i) = uh(i)/(boti(i)-topi(i)+1) ! Find the cell speed where the storm speed is > 10 m/s. ! Storm speed is taken to be the source wind speed. - CS(i) = sign(max(abs(ubm(i,desc%k(i)))-10.0, 0.0), ubm(i,desc%k(i))) + CS(i) = sign(max(abs(ubm(i,int(desc%k(i))))-10.0, 0.0), ubm(i,int(desc%k(i)))) uh(i) = uh(i) - CS(i) else ! For shallow convection, wind is relative to ground, and "heating ! region" wind is just the source level wind. - uh(i) = ubm(i,desc%k(i)) + uh(i) = ubm(i,int(desc%k(i))) endif enddo @@ -466,7 +466,7 @@ subroutine gw_beres_src(ncol, pver, band, desc, pint, u, v, & ! Adjust for critical level filtering. tau0(Umini(i):Umaxi(i)) = 0.0 - + tau(i,:,topi(i)+1) = tau0 else @@ -476,9 +476,9 @@ subroutine gw_beres_src(ncol, pver, band, desc, pint, u, v, & ! use latitudinal dependence ! include forced background stress in extra tropical large-scale systems ! Set the phase speeds and wave numbers in the direction of the source wind. - ! Set the source stress magnitude (positive only, note that the sign of the + ! Set the source stress magnitude (positive only, note that the sign of the ! stress is the same as (c-u). - tau(i,:,desc%k(i)+1) = desc%taubck(i,:) + tau(i,:,int(desc%k(i))+1) = desc%taubck(i,:) topi(i) = desc%k(i) else ! Find largest condensate change level, for frontal detection @@ -491,9 +491,9 @@ subroutine gw_beres_src(ncol, pver, band, desc, pint, u, v, & end do ! include forced background stress in extra tropical large-scale systems ! Set the phase speeds and wave numbers in the direction of the source wind. - ! Set the source stress magnitude (positive only, note that the sign of the + ! Set the source stress magnitude (positive only, note that the sign of the ! stress is the same as (c-u). - tau(i,:,desc%k(i)+1) = desc%taubck(i,:) * MIN(10.0,MAX(1.0,abs(q0(i)/1.e-9))) + tau(i,:,int(desc%k(i))+1) = desc%taubck(i,:) * MIN(10.0,MAX(1.0,abs(q0(i)/1.e-9))) topi(i) = desc%k(i) endif @@ -618,7 +618,7 @@ subroutine gw_beres_ifc( band, & ubm, ubi, xv, yv, c, hdepth, maxq0, lats, dqcdt=dqcdt) ! Solve for the drag profile with convective sources. - call gw_drag_prof(ncol, pver, band, pint, delp, rdelp, & + call gw_drag_prof(ncol, pver, band, pint, delp, rdelp, & src_level, tend_level, dt, t, & piln, rhoi, nm, ni, ubm, ubi, xv, yv, & c, kvtt, tau, utgw, vtgw, ttgw, gwut, alpha) @@ -642,18 +642,18 @@ end subroutine gw_beres_ifc !-------------------------------------------------------------------------- subroutine handle_err(status) - + implicit none - + #include - + integer status - + if (status .ne. nf_noerr) then print *, nf_strerror(status) stop 'Stopped' endif - + end subroutine handle_err diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/CMakeLists.txt index 33a7d5717..1f287c107 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/CMakeLists.txt +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/CMakeLists.txt @@ -65,7 +65,7 @@ endif () esma_add_library (${this} SRCS ${srcs} - DEPENDENCIES GEOS_Shared GMAO_mpeu MAPL Chem_Shared Chem_Base ESMF::ESMF FMS::fms) + DEPENDENCIES GEOS_Shared GMAO_mpeu MAPL Chem_Shared Chem_Base ESMF::ESMF) file (GLOB_RECURSE rc_files CONFIGURE_DEPENDS RELATIVE ${CMAKE_CURRENT_SOURCE_DIR} *.rc *.yaml) foreach ( file ${rc_files} ) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkMITAquaRaster.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkMITAquaRaster.F90 index 7edff67ed..8f33c4b29 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkMITAquaRaster.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkMITAquaRaster.F90 @@ -5,7 +5,7 @@ program MAIN use LogRectRasterizeMod, ONLY: LRRasterize use MAPL_ExceptionHandling - use, intrinsic :: iso_fortran_env, only: REAL64 + use, intrinsic :: iso_fortran_env, only: REAL64, INT64 implicit none integer, parameter :: IUNIT = 11, OUNIT = 12 @@ -14,9 +14,9 @@ program MAIN INTEGER :: NC INTEGER :: NX, NY - integer :: STATARRAY(12) - integer(REAL64) :: filesize - integer(REAL64) :: Length + integer :: ios + integer(INT64) :: filesize + integer(INT64) :: Length integer :: K integer :: i, j integer :: KF, L, NF @@ -84,7 +84,7 @@ program MAIN ! 161,162,179,180,197,198,215,216,233,234] !#15x15 nprocs = 360 !# blankList(1:108) -! [1,2,3,4,5,6,7,8,9,10,11,12,14,15,16,17,18,21,22,23,24,& +! [1,2,3,4,5,6,7,8,9,10,11,12,14,15,16,17,18,21,22,23,24,& ! 65,71,75,76,90,95,96,101,102,109,110,111,112,113,114,115,116,117,118,119,& ! 120,121,122,123,124,125,126,127,128,129,130,131,132,& ! 188,189,190,193,194,195,196,199,& @@ -112,7 +112,7 @@ program MAIN print *, trim(Usage) call exit(1) end if - + nxt = 1 call get_command_argument(nxt,arg) do while(arg(1:1)=='-') @@ -152,10 +152,11 @@ program MAIN BLNKSZ = count(blanklist /= 0) ! Open Facet 3 first. It is always a square (CS or LLC) - open (IUNIT,file=trim(GridDir)//'/tile003.mitgrid', status='old') - call fstat(IUNIT,statarray) - close (IUNIT) - filesize = statarray(8) + inquire(file=trim(GridDir)//'/tile003.mitgrid', size=filesize, iostat=ios) + if (ios /= 0) then + print *, 'Error opening file: ', trim(GridDir)//'/tile003.mitgrid' + call exit(1) + end if !ALT: Kludge for LLC4320 if (filesize <= 0) filesize = 2389893248 @@ -181,11 +182,11 @@ program MAIN LENGTH = nx*ny*REAL64 ! Open Facet 1 to check sizes CS or LLC) - open (IUNIT,file=trim(GridDir)//'/tile001.mitgrid', status='old') - call fstat(IUNIT,statarray) - close (IUNIT) - - filesize = statarray(8) + inquire(file=trim(GridDir)//'/tile001.mitgrid', size=filesize, iostat=ios) + if (ios /= 0) then + print *, 'Error opening file: ', trim(GridDir)//'/tile001.mitgrid' + call exit(1) + end if !ALT: Kludge for LLC4320 if (filesize <= 0) filesize = 7168573568 @@ -303,7 +304,7 @@ program MAIN open (IUNIT, FILE=trim(GridDir)//trim(FACEFILE), & ACCESS='DIRECT', RECL=LENGTH, STATUS='OLD',convert='big_endian') -! read (IUNIT,REC=5) rA +! read (IUNIT,REC=5) rA read (IUNIT,REC=6) XG read (IUNIT,REC=7) YG diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentCNRst.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentCNRst.F90 index 43a16b7b9..4fd9b7154 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentCNRst.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentCNRst.F90 @@ -2,7 +2,7 @@ module CatchmentCNRstMod use mk_restarts_getidsMod, ONLY: & - GetIds + GetIds use mpi use ESMF use MAPL @@ -11,7 +11,7 @@ module CatchmentCNRstMod VAR_COL_40, VAR_PFT_40, VAR_COL_45, VAR_PFT_45, & npft => numpft_CN use nanMod , only : nan - + implicit none real, parameter :: fmin= 1.e-4 ! ignore vegetation fractions at or below this value @@ -41,7 +41,7 @@ module CatchmentCNRstMod real, allocatable :: FIELDCAP(:) real, allocatable :: HDM (:) real, allocatable :: GDP (:) - real, allocatable :: PEATF (:) + real, allocatable :: PEATF (:) real, allocatable :: bflowm(:) real, allocatable :: totwatm(:) @@ -62,11 +62,11 @@ module CatchmentCNRstMod real, allocatable :: sfmcm(:) real, allocatable :: psnsunm(:,:,:) real, allocatable :: psnsham(:,:,:) - + contains procedure :: write_nc4 - procedure :: allocate_cn - procedure :: add_bcs_to_cnrst + procedure :: allocate_cn + procedure :: add_bcs_to_cnrst procedure :: re_tile endtype CatchmentCNRst @@ -95,9 +95,9 @@ function CatchmentCNRst_create(filename, cnclm, time, rc) result (catch) if (filetype /= 0) then _ASSERT( .false., "CatchmentCN only support nc4 file restart") endif - + call MPI_COMM_RANK( MPI_COMM_WORLD, myid, mpierr ) - + catch%isCLM45 = .false. catch%isCLM40 = .false. call formatter%open(filename, pFIO_READ, __RC__) @@ -162,21 +162,21 @@ function CatchmentCNRst_create(filename, cnclm, time, rc) result (catch) ! (to be merged into the "develop" branch in late 2020): ! The length of the 2nd dim of CNPFT differs from that of CNCOL. Prior to this fix, ! CNPFT was not read in its entirety and some elements remained uninitialized (or zero), - ! resulting in bad values in the "regridded" (re-tiled) restart file. + ! resulting in bad values in the "regridded" (re-tiled) restart file. ! This impacted re-tiled restarts for both CNCLM40 and CLCLM45. ! - reichle, 23 Nov 2020 call MAPL_VarRead(formatter,"CNPFT",catch%CNPFT, __RC__) ! more reading - call MAPL_VarRead(formatter, "BFLOWM", catch%bflowm ,_RC) - call MAPL_VarRead(formatter, "TOTWATM", catch%totwatm,_RC) - call MAPL_VarRead(formatter, "TAIRM", catch%tairm ,_RC) - call MAPL_VarRead(formatter, "TPM", catch%tpm ,_RC) - call MAPL_VarRead(formatter, "CNSUM", catch%cnsum ,_RC) - call MAPL_VarRead(formatter, "SNDZM", catch%sndzm ,_RC) - call MAPL_VarRead(formatter, "ASNOWM", catch%asnowm ,_RC) - call MAPL_VarRead(formatter, "PSNSUNM", catch%psnsunm,_RC) - call MAPL_VarRead(formatter, "PSNSHAM", catch%psnsham,_RC) + call MAPL_VarRead(formatter, "BFLOWM", catch%bflowm ,_RC) + call MAPL_VarRead(formatter, "TOTWATM", catch%totwatm,_RC) + call MAPL_VarRead(formatter, "TAIRM", catch%tairm ,_RC) + call MAPL_VarRead(formatter, "TPM", catch%tpm ,_RC) + call MAPL_VarRead(formatter, "CNSUM", catch%cnsum ,_RC) + call MAPL_VarRead(formatter, "SNDZM", catch%sndzm ,_RC) + call MAPL_VarRead(formatter, "ASNOWM", catch%asnowm ,_RC) + call MAPL_VarRead(formatter, "PSNSUNM", catch%psnsunm,_RC) + call MAPL_VarRead(formatter, "PSNSHAM", catch%psnsham,_RC) call MAPL_VarRead(formatter, "RZMM", catch%rzmm ,_RC) call MAPL_VarRead(formatter, "TGWM", catch%tgwm ,_RC) endif @@ -286,7 +286,7 @@ subroutine write_nc4(this, filename, rc) call MAPL_VarWrite(formatter,"PSNSHAM", this%PSNSHAM ) call formatter%close() - + _RETURN(_SUCCESS) end subroutine write_nc4 @@ -297,7 +297,7 @@ subroutine allocate_cn(this,rc) integer :: ncol,npft, ntiles ntiles = this%ntiles - ncol = nzone* this%VAR_COL + ncol = nzone* this%VAR_COL npft = nzone*nveg*this%VAR_PFT call this%CatchmentRst%allocate_catch(__RC__) @@ -359,8 +359,8 @@ SUBROUTINE add_bcs_to_cnrst (this, SURFLAY, OutBcsDir,rc) character(*), intent (in) :: OutBcsDir integer, optional, intent(out) :: rc real, allocatable :: CLMC_pf1(:), CLMC_pf2(:), CLMC_sf1(:), CLMC_sf2(:) - real, allocatable :: CLMC_pt1(:), CLMC_pt2(:), CLMC_st1(:), CLMC_st2(:) - real, allocatable :: NDEP(:), BVISDR(:), BVISDF(:), BNIRDR(:), BNIRDF(:) + real, allocatable :: CLMC_pt1(:), CLMC_pt2(:), CLMC_st1(:), CLMC_st2(:) + real, allocatable :: NDEP(:), BVISDR(:), BVISDF(:), BNIRDR(:), BNIRDF(:) real, allocatable :: T2(:), hdm(:), fc(:), gdp(:), peatf(:) integer, allocatable :: ity(:), abm (:) integer :: STATUS, ntiles, unit27, unit28, unit29, unit30 @@ -375,12 +375,12 @@ SUBROUTINE add_bcs_to_cnrst (this, SURFLAY, OutBcsDir,rc) open (10,file =trim(OutBcsDir)//"/clsm/catchment.def",status='old',form='formatted') read (10,*) ntiles close (10, status = 'keep') - + !ntiles = this%ntiles !call this%CatchmentRst%add_bcs_to_rst(surflay, OutBcsDir, __RC__) allocate (BVISDR(ntiles), BVISDF(ntiles), BNIRDR(ntiles) ) - allocate (BNIRDF(ntiles), T2(ntiles), NDEP(ntiles) ) + allocate (BNIRDF(ntiles), T2(ntiles), NDEP(ntiles) ) allocate (CLMC_pf1(ntiles), CLMC_pf2(ntiles), CLMC_sf1(ntiles)) allocate (CLMC_sf2(ntiles), CLMC_pt1(ntiles), CLMC_pt2(ntiles)) allocate (CLMC_st1(ntiles), CLMC_st2(ntiles)) @@ -392,7 +392,7 @@ SUBROUTINE add_bcs_to_cnrst (this, SURFLAY, OutBcsDir,rc) _ASSERT(Newland, "catchcn should get bc from newland") if(file_exists) then - call CatchCNFmt%Open(trim(OutBcsDir)//'/clsm/catchcn_params.nc4', pFIO_READ, __RC__) + call CatchCNFmt%Open(trim(OutBcsDir)//'/clsm/catchcn_params.nc4', pFIO_READ, __RC__) call MAPL_VarRead ( CatchCNFmt ,'BGALBNF', BNIRDF, __RC__) call MAPL_VarRead ( CatchCNFmt ,'BGALBNR', BNIRDR, __RC__) call MAPL_VarRead ( CatchCNFmt ,'BGALBVF', BVISDF, __RC__) @@ -416,10 +416,10 @@ SUBROUTINE add_bcs_to_cnrst (this, SURFLAY, OutBcsDir,rc) do n=1,ntiles read (unit27, *) i,j, CLMC_pt1(n), CLMC_pt2(n), CLMC_st1(n), CLMC_st2(n), & CLMC_pf1(n), CLMC_pf2(n), CLMC_sf1(n), CLMC_sf2(n) - + read (unit28, *) NDEP(n), BVISDR(n), BVISDF(n), BNIRDR(n), BNIRDF(n), T2(n) ! MERRA-2 Annual Mean Temp is default. end do - + CLOSE (unit27, STATUS = 'KEEP') CLOSE (unit28, STATUS = 'KEEP') @@ -434,7 +434,7 @@ SUBROUTINE add_bcs_to_cnrst (this, SURFLAY, OutBcsDir,rc) end do CLOSE (unit30, STATUS = 'KEEP') endif - + do n=1,ntiles BVISDR(n) = amax1(1.e-6, BVISDR(n)) BVISDF(n) = amax1(1.e-6, BVISDF(n)) @@ -442,36 +442,36 @@ SUBROUTINE add_bcs_to_cnrst (this, SURFLAY, OutBcsDir,rc) BNIRDF(n) = amax1(1.e-6, BNIRDF(n)) ! convert % to fractions - + CLMC_pf1(n) = CLMC_pf1(n) / 100. CLMC_pf2(n) = CLMC_pf2(n) / 100. CLMC_sf1(n) = CLMC_sf1(n) / 100. CLMC_sf2(n) = CLMC_sf2(n) / 100. - + fvg(1) = CLMC_pf1(n) fvg(2) = CLMC_pf2(n) fvg(3) = CLMC_sf1(n) fvg(4) = CLMC_sf2(n) - - BARE = 1. - + + BARE = 1. + DO NV = 1, NVEG - BARE = BARE - FVG(NV)! subtract vegetated fractions + BARE = BARE - FVG(NV)! subtract vegetated fractions END DO - + if (BARE /= 0.) THEN IB = MAXLOC(FVG(:),1) FVG (IB) = FVG(IB) + BARE ! This also corrects all cases sum ne 0. ENDIF - + CLMC_pf1(n) = fvg(1) CLMC_pf2(n) = fvg(2) CLMC_sf1(n) = fvg(3) CLMC_sf2(n) = fvg(4) enddo - + NDEP = NDEP * 1.e-9 - + ! prevent trivial fractions ! ------------------------- do n = 1,ntiles @@ -479,12 +479,12 @@ SUBROUTINE add_bcs_to_cnrst (this, SURFLAY, OutBcsDir,rc) CLMC_pf2(n) = CLMC_pf2(n) + CLMC_pf1(n) CLMC_pf1(n) = 0. endif - + if(CLMC_pf2(n) <= 1.e-4) then CLMC_pf1(n) = CLMC_pf1(n) + CLMC_pf2(n) CLMC_pf2(n) = 0. endif - + if(CLMC_sf1(n) <= 1.e-4) then if(CLMC_sf2(n) > 1.e-4) then CLMC_sf2(n) = CLMC_sf2(n) + CLMC_sf1(n) @@ -497,7 +497,7 @@ SUBROUTINE add_bcs_to_cnrst (this, SURFLAY, OutBcsDir,rc) endif CLMC_sf1(n) = 0. endif - + if(CLMC_sf2(n) <= 1.e-4) then if(CLMC_sf1(n) > 1.e-4) then CLMC_sf1(n) = CLMC_sf1(n) + CLMC_sf2(n) @@ -510,7 +510,7 @@ SUBROUTINE add_bcs_to_cnrst (this, SURFLAY, OutBcsDir,rc) endif CLMC_sf2(n) = 0. endif - enddo + enddo this%cnity = reshape([CLMC_pt1,CLMC_pt2,CLMC_st1,CLMC_st2],[ntiles,4]) this%fvg = reshape([CLMC_pf1,CLMC_pf2,CLMC_sf1,CLMC_sf2],[ntiles,4]) @@ -521,7 +521,7 @@ SUBROUTINE add_bcs_to_cnrst (this, SURFLAY, OutBcsDir,rc) this%BGALBVF = BVISDF this%BGALBNR = BNIRDR this%BGALBNF = BNIRDF - + if (this%isCLM45) then this%abm = real(abm) this%fieldcap = fc @@ -531,7 +531,7 @@ SUBROUTINE add_bcs_to_cnrst (this, SURFLAY, OutBcsDir,rc) endif deallocate (BVISDR, BVISDF, BNIRDR ) - deallocate (BNIRDF, T2, NDEP ) + deallocate (BNIRDF, T2, NDEP ) deallocate (CLMC_pf1, CLMC_pf2, CLMC_sf1) deallocate (CLMC_sf2, CLMC_pt1, CLMC_pt2) deallocate (CLMC_st1,CLMC_st2) @@ -546,7 +546,7 @@ subroutine re_tile(this, InTileFile, OutBcsDir, OutTileFile, surflay, rc) character(*), intent(in) :: OutTileFile real, intent(in) :: surflay integer, optional, intent(out) :: rc - + real , allocatable, dimension (:) :: DAYX integer, allocatable, dimension (:) :: low_ind, upp_ind, nt_local integer, allocatable, dimension (:,:) :: Id_glb_cn, id_loc_cn @@ -565,7 +565,7 @@ subroutine re_tile(this, InTileFile, OutBcsDir, OutTileFile, surflay, rc) type(MAPL_SunOrbit) :: ORBIT type(ESMF_Time) :: CURRENT_TIME type(ESMF_TimeInterval) :: timeStep - type(ESMF_Clock) :: CLOCK + type(ESMF_Clock) :: CLOCK type(ESMF_Config) :: CF character(*), parameter :: Iam = "CatchmentCN::Re_tile" @@ -576,7 +576,7 @@ subroutine re_tile(this, InTileFile, OutBcsDir, OutTileFile, surflay, rc) var_col = this%var_col call this%CatchmentRst%re_tile(InTileFile, OutBcsDir, OutTileFile, surflay, _RC) - out_ntiles = this%ntiles + out_ntiles = this%ntiles call MPI_COMM_RANK( MPI_COMM_WORLD, myid, mpierr ) call MPI_COMM_SIZE( MPI_COMM_WORLD, numprocs, mpierr ) @@ -657,7 +657,7 @@ subroutine re_tile(this, InTileFile, OutBcsDir, OutTileFile, surflay, rc) VERIFY_(status) ORBIT = MAPL_SunOrbitCreateFromConfig(CF, CLOCK, .false., RC=status) - VERIFY_(status) + VERIFY_(status) !4) current daylight duration lat_tmp = this%latg*MAPL_PI/180. @@ -736,7 +736,7 @@ subroutine re_tile(this, InTileFile, OutBcsDir, OutTileFile, surflay, rc) endif call MPI_Barrier(MPI_COMM_WORLD, STATUS) - + if(root_proc) print*, "GetIDs...." call GetIds(this%lonc,this%latc,this%lonn,this%latt,id_loc_cn, tid_offl, & @@ -786,7 +786,7 @@ subroutine re_tile(this, InTileFile, OutBcsDir, OutTileFile, surflay, rc) allocate (tg_tmp(out_ntiles, 4),source = 0.) do i = 1, 3 tg_tmp(:,i) = this%tg(this%id_glb(:),i) - enddo + enddo this%tg = tg_tmp deallocate(tg_tmp) @@ -955,10 +955,10 @@ SUBROUTINE regrid_carbon (NTILES, in_ntiles, id_glb, & offl_cell = Id_glb(n,nv) if(ityp_new == ityp_offl (offl_cell,nv) .and. fveg_offl (offl_cell,nv)> fmin) then - iv = nv ! same type fraction (primary of secondary) + iv = nv ! same type fraction (primary of secondary) else if(ityp_new == ityp_offl (offl_cell,nx) .and. fveg_offl (offl_cell,nx)> fmin) then iv = nx ! not same fraction - else if(iclass(ityp_new)==iclass(ityp_offl(offl_cell,nv)) .and. fveg_offl (offl_cell,nv)> fmin) then + else if(iclass(ityp_new)==iclass(int(ityp_offl(offl_cell,nv))) .and. fveg_offl (offl_cell,nv)> fmin) then iv = nv ! primary, other type (same class) else if(fveg_offl (offl_cell,nx)> fmin) then iv = nx ! secondary, other type (same class) @@ -967,7 +967,7 @@ SUBROUTINE regrid_carbon (NTILES, in_ntiles, id_glb, & ! Get col and pft variables for the Id_glb(nv) grid cell from offline catchcn_internal_rst ! ---------------------------------------------------------------------------------------- - ! call NCDF_reshape_getOput (NCFID,Id_glb(n,nv),var_off_col,var_off_pft,.true.) + ! call NCDF_reshape_getOput (NCFID,Id_glb(n,nv),var_off_col,var_off_pft,.true.) var_pft_out (n,:,nv,:) = var_off_pft(Id_glb(n,nv), :,iv,:) var_col_out (n,:,:) = var_col_out(n,:,:) + fveg_new * var_off_col(Id_glb(n,nv), :,:) ! gkw: column state simple weighted mean; ! could use "woody" fraction? @@ -977,9 +977,9 @@ SUBROUTINE regrid_carbon (NTILES, in_ntiles, id_glb, & do j = 1, VAR_PFT if (isnan(var_pft_out (n, nz,nv,j))) print *,j,nv,nz,n,var_pft_out (n, nz,nv,j),fveg_new !if(isnan(var_pft_out (n, nz,nv,69))) var_pft_out (n, nz,nv,69) = 1.e-6 - !if(isnan(var_pft_out (n, nz,nv,70))) var_pft_out (n, nz,nv,70) = 1.e-6 + !if(isnan(var_pft_out (n, nz,nv,70))) var_pft_out (n, nz,nv,70) = 1.e-6 !if(isnan(var_pft_out (n, nz,nv,73))) var_pft_out (n, nz,nv,73) = 1.e-6 - !if(isnan(var_pft_out (n, nz,nv,74))) var_pft_out (n, nz,nv,74) = 1.e-6 + !if(isnan(var_pft_out (n, nz,nv,74))) var_pft_out (n, nz,nv,74) = 1.e-6 end do end do endif @@ -1001,7 +1001,7 @@ SUBROUTINE regrid_carbon (NTILES, in_ntiles, id_glb, & var_col_out(n, nz,10) = max(var_col_out(n, nz,10), 0.) var_col_out(n, nz,11) = max(var_col_out(n, nz,11), 0.) var_col_out(n, nz,12) = max(var_col_out(n, nz,12), 0.) - var_col_out(n, nz,13) = max(var_col_out(n, nz,13),10.) ! soil4c + var_col_out(n, nz,13) = max(var_col_out(n, nz,13),10.) ! soil4c var_col_out(n, nz,14) = max(var_col_out(n, nz,14), 0.) var_col_out(n, nz,15) = max(var_col_out(n, nz,15), 0.) var_col_out(n, nz,16) = max(var_col_out(n, nz,16), 0.) @@ -1100,8 +1100,8 @@ SUBROUTINE regrid_carbon (NTILES, in_ntiles, id_glb, & var_pft_out(n, nz,nv,74) = max(var_pft_out(n, nz,nv,74),0.) if(this%isCLM45) var_pft_out(n, nz,nv,75) = max(var_pft_out(n, nz,nv,75),0.) endif - end do NVLOOP3 ! end veg loop - endif ! end carbon check + end do NVLOOP3 ! end veg loop + endif ! end carbon check end do NZLOOP ! end zone loop ! Update dayx variable var_pft_out (:,:,28) @@ -1114,163 +1114,163 @@ SUBROUTINE regrid_carbon (NTILES, in_ntiles, id_glb, & end do end do - ! call NCDF_reshape_getOput (OutID,N,var_col_out,var_pft_out,.false.) + ! call NCDF_reshape_getOput (OutID,N,var_col_out,var_pft_out,.false.) ! column vars clm40 clm45 ! ----------------- --------------------- - ! 1 clm3%g%l%c%ccs%col_ctrunc ! 1 ccs%col_ctrunc_vr (:,1) - ! 2 clm3%g%l%c%ccs%cwdc ! 2 ccs%decomp_cpools_vr(:,1,4) ! cwdc - ! 3 clm3%g%l%c%ccs%litr1c ! 3 ccs%decomp_cpools_vr(:,1,1) ! litr1c - ! 4 clm3%g%l%c%ccs%litr2c ! 4 ccs%decomp_cpools_vr(:,1,2) ! litr2c - ! 5 clm3%g%l%c%ccs%litr3c ! 5 ccs%decomp_cpools_vr(:,1,3) ! litr3c - ! 6 clm3%g%l%c%ccs%pcs_a%totvegc ! 6 ccs%totvegc_col - ! 7 clm3%g%l%c%ccs%prod100c ! 7 ccs%prod100c - ! 8 clm3%g%l%c%ccs%prod10c ! 8 ccs%prod10c - ! 9 clm3%g%l%c%ccs%seedc ! 9 ccs%seedc - ! 10 clm3%g%l%c%ccs%soil1c ! 10 ccs%decomp_cpools_vr(:,1,5) ! soil1c - ! 11 clm3%g%l%c%ccs%soil2c ! 11 ccs%decomp_cpools_vr(:,1,6) ! soil2c - ! 12 clm3%g%l%c%ccs%soil3c ! 12 ccs%decomp_cpools_vr(:,1,7) ! soil3c - ! 13 clm3%g%l%c%ccs%soil4c ! 13 ccs%decomp_cpools_vr(:,1,8) ! soil4c - ! 14 clm3%g%l%c%ccs%totcolc ! 14 ccs%totcolc - ! 15 clm3%g%l%c%ccs%totlitc ! 15 ccs%totlitc - ! 16 clm3%g%l%c%cns%col_ntrunc ! 16 cns%col_ntrunc_vr (:,1) - ! 17 clm3%g%l%c%cns%cwdn ! 17 cns%decomp_npools_vr(:,1,4) ! cwdn - ! 18 clm3%g%l%c%cns%litr1n ! 18 cns%decomp_npools_vr(:,1,1) ! litr1n - ! 19 clm3%g%l%c%cns%litr2n ! 19 cns%decomp_npools_vr(:,1,2) ! litr2n - ! 20 clm3%g%l%c%cns%litr3n ! 20 cns%decomp_npools_vr(:,1,3) ! litr3n - ! 21 clm3%g%l%c%cns%prod100n ! 21 cns%prod100n - ! 22 clm3%g%l%c%cns%prod10n ! 22 cns%prod10n - ! 23 clm3%g%l%c%cns%seedn ! 23 cns%seedn - ! 24 clm3%g%l%c%cns%sminn ! 24 cns%sminn_vr (:,1) - ! 25 clm3%g%l%c%cns%soil1n ! 25 cns%decomp_npools_vr(:,1,5) ! soil1n - ! 26 clm3%g%l%c%cns%soil2n ! 26 cns%decomp_npools_vr(:,1,6) ! soil2n - ! 27 clm3%g%l%c%cns%soil3n ! 27 cns%decomp_npools_vr(:,1,7) ! soil3n - ! 28 clm3%g%l%c%cns%soil4n ! 28 cns%decomp_npools_vr(:,1,8) ! soil4n - ! 29 clm3%g%l%c%cns%totcoln ! 29 cns%totcoln - ! 30 clm3%g%l%c%cps%ann_farea_burned ! 30 cps%fpg - ! 31 clm3%g%l%c%cps%annsum_counter ! 31 cps%annsum_counter - ! 32 clm3%g%l%c%cps%cannavg_t2m ! 32 cps%cannavg_t2m - ! 33 clm3%g%l%c%cps%cannsum_npp ! 33 cps%cannsum_npp - ! 34 clm3%g%l%c%cps%farea_burned ! 34 cps%farea_burned - ! 35 clm3%g%l%c%cps%fire_prob ! 35 cps%fpi_vr (:,1) - ! 36 clm3%g%l%c%cps%fireseasonl ! OLD ! 30 cps%altmax - ! 37 clm3%g%l%c%cps%fpg ! OLD ! 31 cps%annsum_counter - ! 38 clm3%g%l%c%cps%fpi ! OLD ! 32 cps%cannavg_t2m - ! 39 clm3%g%l%c%cps%me ! OLD ! 33 cps%cannsum_npp - ! 40 clm3%g%l%c%cps%mean_fire_prob ! OLD ! 34 cps%farea_burned - ! OLD ! 35 cps%altmax_lastyear - ! OLD ! 36 cps%altmax_indx - ! OLD ! 37 cps%fpg + ! 1 clm3%g%l%c%ccs%col_ctrunc ! 1 ccs%col_ctrunc_vr (:,1) + ! 2 clm3%g%l%c%ccs%cwdc ! 2 ccs%decomp_cpools_vr(:,1,4) ! cwdc + ! 3 clm3%g%l%c%ccs%litr1c ! 3 ccs%decomp_cpools_vr(:,1,1) ! litr1c + ! 4 clm3%g%l%c%ccs%litr2c ! 4 ccs%decomp_cpools_vr(:,1,2) ! litr2c + ! 5 clm3%g%l%c%ccs%litr3c ! 5 ccs%decomp_cpools_vr(:,1,3) ! litr3c + ! 6 clm3%g%l%c%ccs%pcs_a%totvegc ! 6 ccs%totvegc_col + ! 7 clm3%g%l%c%ccs%prod100c ! 7 ccs%prod100c + ! 8 clm3%g%l%c%ccs%prod10c ! 8 ccs%prod10c + ! 9 clm3%g%l%c%ccs%seedc ! 9 ccs%seedc + ! 10 clm3%g%l%c%ccs%soil1c ! 10 ccs%decomp_cpools_vr(:,1,5) ! soil1c + ! 11 clm3%g%l%c%ccs%soil2c ! 11 ccs%decomp_cpools_vr(:,1,6) ! soil2c + ! 12 clm3%g%l%c%ccs%soil3c ! 12 ccs%decomp_cpools_vr(:,1,7) ! soil3c + ! 13 clm3%g%l%c%ccs%soil4c ! 13 ccs%decomp_cpools_vr(:,1,8) ! soil4c + ! 14 clm3%g%l%c%ccs%totcolc ! 14 ccs%totcolc + ! 15 clm3%g%l%c%ccs%totlitc ! 15 ccs%totlitc + ! 16 clm3%g%l%c%cns%col_ntrunc ! 16 cns%col_ntrunc_vr (:,1) + ! 17 clm3%g%l%c%cns%cwdn ! 17 cns%decomp_npools_vr(:,1,4) ! cwdn + ! 18 clm3%g%l%c%cns%litr1n ! 18 cns%decomp_npools_vr(:,1,1) ! litr1n + ! 19 clm3%g%l%c%cns%litr2n ! 19 cns%decomp_npools_vr(:,1,2) ! litr2n + ! 20 clm3%g%l%c%cns%litr3n ! 20 cns%decomp_npools_vr(:,1,3) ! litr3n + ! 21 clm3%g%l%c%cns%prod100n ! 21 cns%prod100n + ! 22 clm3%g%l%c%cns%prod10n ! 22 cns%prod10n + ! 23 clm3%g%l%c%cns%seedn ! 23 cns%seedn + ! 24 clm3%g%l%c%cns%sminn ! 24 cns%sminn_vr (:,1) + ! 25 clm3%g%l%c%cns%soil1n ! 25 cns%decomp_npools_vr(:,1,5) ! soil1n + ! 26 clm3%g%l%c%cns%soil2n ! 26 cns%decomp_npools_vr(:,1,6) ! soil2n + ! 27 clm3%g%l%c%cns%soil3n ! 27 cns%decomp_npools_vr(:,1,7) ! soil3n + ! 28 clm3%g%l%c%cns%soil4n ! 28 cns%decomp_npools_vr(:,1,8) ! soil4n + ! 29 clm3%g%l%c%cns%totcoln ! 29 cns%totcoln + ! 30 clm3%g%l%c%cps%ann_farea_burned ! 30 cps%fpg + ! 31 clm3%g%l%c%cps%annsum_counter ! 31 cps%annsum_counter + ! 32 clm3%g%l%c%cps%cannavg_t2m ! 32 cps%cannavg_t2m + ! 33 clm3%g%l%c%cps%cannsum_npp ! 33 cps%cannsum_npp + ! 34 clm3%g%l%c%cps%farea_burned ! 34 cps%farea_burned + ! 35 clm3%g%l%c%cps%fire_prob ! 35 cps%fpi_vr (:,1) + ! 36 clm3%g%l%c%cps%fireseasonl ! OLD ! 30 cps%altmax + ! 37 clm3%g%l%c%cps%fpg ! OLD ! 31 cps%annsum_counter + ! 38 clm3%g%l%c%cps%fpi ! OLD ! 32 cps%cannavg_t2m + ! 39 clm3%g%l%c%cps%me ! OLD ! 33 cps%cannsum_npp + ! 40 clm3%g%l%c%cps%mean_fire_prob ! OLD ! 34 cps%farea_burned + ! OLD ! 35 cps%altmax_lastyear + ! OLD ! 36 cps%altmax_indx + ! OLD ! 37 cps%fpg ! OLD ! 38 cps%fpi_vr (:,1) - ! OLD ! 39 cps%altmax_lastyear_indx + ! OLD ! 39 cps%altmax_lastyear_indx - ! PFT vars CLM40 CLM45 + ! PFT vars CLM40 CLM45 ! -------------- ----- - ! 1 clm3%g%l%c%p%pcs%cpool ! 1 pcs%cpool - ! 2 clm3%g%l%c%p%pcs%deadcrootc ! 2 pcs%deadcrootc - ! 3 clm3%g%l%c%p%pcs%deadcrootc_storage ! 3 pcs%deadcrootc_storage - ! 4 clm3%g%l%c%p%pcs%deadcrootc_xfer ! 4 pcs%deadcrootc_xfer - ! 5 clm3%g%l%c%p%pcs%deadstemc ! 5 pcs%deadstemc - ! 6 clm3%g%l%c%p%pcs%deadstemc_storage ! 6 pcs%deadstemc_storage - ! 7 clm3%g%l%c%p%pcs%deadstemc_xfer ! 7 pcs%deadstemc_xfer - ! 8 clm3%g%l%c%p%pcs%frootc ! 8 pcs%frootc - ! 9 clm3%g%l%c%p%pcs%frootc_storage ! 9 pcs%frootc_storage - ! 10 clm3%g%l%c%p%pcs%frootc_xfer ! 10 pcs%frootc_xfer - ! 11 clm3%g%l%c%p%pcs%gresp_storage ! 11 pcs%gresp_storage - ! 12 clm3%g%l%c%p%pcs%gresp_xfer ! 12 pcs%gresp_xfer - ! 13 clm3%g%l%c%p%pcs%leafc ! 13 pcs%leafc - ! 14 clm3%g%l%c%p%pcs%leafc_storage ! 14 pcs%leafc_storage - ! 15 clm3%g%l%c%p%pcs%leafc_xfer ! 15 pcs%leafc_xfer - ! 16 clm3%g%l%c%p%pcs%livecrootc ! 16 pcs%livecrootc - ! 17 clm3%g%l%c%p%pcs%livecrootc_storage ! 17 pcs%livecrootc_storage - ! 18 clm3%g%l%c%p%pcs%livecrootc_xfer ! 18 pcs%livecrootc_xfer - ! 19 clm3%g%l%c%p%pcs%livestemc ! 19 pcs%livestemc - ! 20 clm3%g%l%c%p%pcs%livestemc_storage ! 20 pcs%livestemc_storage - ! 21 clm3%g%l%c%p%pcs%livestemc_xfer ! 21 pcs%livestemc_xfer - ! 22 clm3%g%l%c%p%pcs%pft_ctrunc ! 22 pcs%pft_ctrunc - ! 23 clm3%g%l%c%p%pcs%xsmrpool ! 23 pcs%xsmrpool - ! 24 clm3%g%l%c%p%pepv%annavg_t2m ! 24 pepv%annavg_t2m - ! 25 clm3%g%l%c%p%pepv%annmax_retransn ! 25 pepv%annmax_retransn - ! 26 clm3%g%l%c%p%pepv%annsum_npp ! 26 pepv%annsum_npp - ! 27 clm3%g%l%c%p%pepv%annsum_potential_gpp ! 27 pepv%annsum_potential_gpp - ! 28 clm3%g%l%c%p%pepv%dayl ! 28 pepv%dayl - ! 29 clm3%g%l%c%p%pepv%days_active ! 29 pepv%days_active - ! 30 clm3%g%l%c%p%pepv%dormant_flag ! 30 pepv%dormant_flag - ! 31 clm3%g%l%c%p%pepv%offset_counter ! 31 pepv%offset_counter - ! 32 clm3%g%l%c%p%pepv%offset_fdd ! 32 pepv%offset_fdd - ! 33 clm3%g%l%c%p%pepv%offset_flag ! 33 pepv%offset_flag - ! 34 clm3%g%l%c%p%pepv%offset_swi ! 34 pepv%offset_swi - ! 35 clm3%g%l%c%p%pepv%onset_counter ! 35 pepv%onset_counter - ! 36 clm3%g%l%c%p%pepv%onset_fdd ! 36 pepv%onset_fdd - ! 37 clm3%g%l%c%p%pepv%onset_flag ! 37 pepv%onset_flag - ! 38 clm3%g%l%c%p%pepv%onset_gdd ! 38 pepv%onset_gdd - ! 39 clm3%g%l%c%p%pepv%onset_gddflag ! 39 pepv%onset_gddflag - ! 40 clm3%g%l%c%p%pepv%onset_swi ! 40 pepv%onset_swi - ! 41 clm3%g%l%c%p%pepv%prev_frootc_to_litter ! 41 pepv%prev_frootc_to_litter - ! 42 clm3%g%l%c%p%pepv%prev_leafc_to_litter ! 42 pepv%prev_leafc_to_litter - ! 43 clm3%g%l%c%p%pepv%tempavg_t2m ! 43 pepv%tempavg_t2m - ! 44 clm3%g%l%c%p%pepv%tempmax_retransn ! 44 pepv%tempmax_retransn - ! 45 clm3%g%l%c%p%pepv%tempsum_npp ! 45 pepv%tempsum_npp - ! 46 clm3%g%l%c%p%pepv%tempsum_potential_gpp ! 46 pepv%tempsum_potential_gpp - ! 47 clm3%g%l%c%p%pepv%xsmrpool_recover ! 47 pepv%xsmrpool_recover - ! 48 clm3%g%l%c%p%pns%deadcrootn ! 48 pns%deadcrootn - ! 49 clm3%g%l%c%p%pns%deadcrootn_storage ! 49 pns%deadcrootn_storage - ! 50 clm3%g%l%c%p%pns%deadcrootn_xfer ! 50 pns%deadcrootn_xfer - ! 51 clm3%g%l%c%p%pns%deadstemn ! 51 pns%deadstemn - ! 52 clm3%g%l%c%p%pns%deadstemn_storage ! 52 pns%deadstemn_storage - ! 53 clm3%g%l%c%p%pns%deadstemn_xfer ! 53 pns%deadstemn_xfer - ! 54 clm3%g%l%c%p%pns%frootn ! 54 pns%frootn - ! 55 clm3%g%l%c%p%pns%frootn_storage ! 55 pns%frootn_storage - ! 56 clm3%g%l%c%p%pns%frootn_xfer ! 56 pns%frootn_xfer - ! 57 clm3%g%l%c%p%pns%leafn ! 57 pns%leafn - ! 58 clm3%g%l%c%p%pns%leafn_storage ! 58 pns%leafn_storage - ! 59 clm3%g%l%c%p%pns%leafn_xfer ! 59 pns%leafn_xfer - ! 60 clm3%g%l%c%p%pns%livecrootn ! 60 pns%livecrootn - ! 61 clm3%g%l%c%p%pns%livecrootn_storage ! 61 pns%livecrootn_storage - ! 62 clm3%g%l%c%p%pns%livecrootn_xfer ! 62 pns%livecrootn_xfer - ! 63 clm3%g%l%c%p%pns%livestemn ! 63 pns%livestemn - ! 64 clm3%g%l%c%p%pns%livestemn_storage ! 64 pns%livestemn_storage - ! 65 clm3%g%l%c%p%pns%livestemn_xfer ! 65 pns%livestemn_xfer - ! 66 clm3%g%l%c%p%pns%npool ! 66 pns%npool - ! 67 clm3%g%l%c%p%pns%pft_ntrunc ! 67 pns%pft_ntrunc - ! 68 clm3%g%l%c%p%pns%retransn ! 68 pns%retransn - ! 69 clm3%g%l%c%p%pps%elai ! 69 pps%elai - ! 70 clm3%g%l%c%p%pps%esai ! 70 pps%esai - ! 71 clm3%g%l%c%p%pps%hbot ! 71 pps%hbot - ! 72 clm3%g%l%c%p%pps%htop ! 72 pps%htop - ! 73 clm3%g%l%c%p%pps%tlai ! 73 pps%tlai - ! 74 clm3%g%l%c%p%pps%tsai ! 74 pps%tsai - ! 75 pepv%plant_ndemand - ! OLD ! 75 pps%gddplant - ! OLD ! 76 pps%gddtsoi - ! OLD ! 77 pps%peaklai - ! OLD ! 78 pps%idop - ! OLD ! 79 pps%aleaf - ! OLD ! 80 pps%aleafi - ! OLD ! 81 pps%astem - ! OLD ! 82 pps%astemi - ! OLD ! 83 pps%htmx - ! OLD ! 84 pps%hdidx - ! OLD ! 85 pps%vf - ! OLD ! 86 pps%cumvd - ! OLD ! 87 pps%croplive - ! OLD ! 88 pps%cropplant - ! OLD ! 89 pps%harvdate - ! OLD ! 90 pps%gdd1020 - ! OLD ! 91 pps%gdd820 - ! OLD ! 92 pps%gdd020 - ! OLD ! 93 pps%gddmaturity - ! OLD ! 94 pps%huileaf - ! OLD ! 95 pps%huigrain - ! OLD ! 96 pcs%grainc - ! OLD ! 97 pcs%grainc_storage - ! OLD ! 98 pcs%grainc_xfer - ! OLD ! 99 pns%grainn - ! OLD !100 pns%grainn_storage - ! OLD !101 pns%grainn_xfer - ! OLD !102 pepv%fert_counter - ! OLD !103 pnf%fert - ! OLD !104 pepv%grain_flag + ! 1 clm3%g%l%c%p%pcs%cpool ! 1 pcs%cpool + ! 2 clm3%g%l%c%p%pcs%deadcrootc ! 2 pcs%deadcrootc + ! 3 clm3%g%l%c%p%pcs%deadcrootc_storage ! 3 pcs%deadcrootc_storage + ! 4 clm3%g%l%c%p%pcs%deadcrootc_xfer ! 4 pcs%deadcrootc_xfer + ! 5 clm3%g%l%c%p%pcs%deadstemc ! 5 pcs%deadstemc + ! 6 clm3%g%l%c%p%pcs%deadstemc_storage ! 6 pcs%deadstemc_storage + ! 7 clm3%g%l%c%p%pcs%deadstemc_xfer ! 7 pcs%deadstemc_xfer + ! 8 clm3%g%l%c%p%pcs%frootc ! 8 pcs%frootc + ! 9 clm3%g%l%c%p%pcs%frootc_storage ! 9 pcs%frootc_storage + ! 10 clm3%g%l%c%p%pcs%frootc_xfer ! 10 pcs%frootc_xfer + ! 11 clm3%g%l%c%p%pcs%gresp_storage ! 11 pcs%gresp_storage + ! 12 clm3%g%l%c%p%pcs%gresp_xfer ! 12 pcs%gresp_xfer + ! 13 clm3%g%l%c%p%pcs%leafc ! 13 pcs%leafc + ! 14 clm3%g%l%c%p%pcs%leafc_storage ! 14 pcs%leafc_storage + ! 15 clm3%g%l%c%p%pcs%leafc_xfer ! 15 pcs%leafc_xfer + ! 16 clm3%g%l%c%p%pcs%livecrootc ! 16 pcs%livecrootc + ! 17 clm3%g%l%c%p%pcs%livecrootc_storage ! 17 pcs%livecrootc_storage + ! 18 clm3%g%l%c%p%pcs%livecrootc_xfer ! 18 pcs%livecrootc_xfer + ! 19 clm3%g%l%c%p%pcs%livestemc ! 19 pcs%livestemc + ! 20 clm3%g%l%c%p%pcs%livestemc_storage ! 20 pcs%livestemc_storage + ! 21 clm3%g%l%c%p%pcs%livestemc_xfer ! 21 pcs%livestemc_xfer + ! 22 clm3%g%l%c%p%pcs%pft_ctrunc ! 22 pcs%pft_ctrunc + ! 23 clm3%g%l%c%p%pcs%xsmrpool ! 23 pcs%xsmrpool + ! 24 clm3%g%l%c%p%pepv%annavg_t2m ! 24 pepv%annavg_t2m + ! 25 clm3%g%l%c%p%pepv%annmax_retransn ! 25 pepv%annmax_retransn + ! 26 clm3%g%l%c%p%pepv%annsum_npp ! 26 pepv%annsum_npp + ! 27 clm3%g%l%c%p%pepv%annsum_potential_gpp ! 27 pepv%annsum_potential_gpp + ! 28 clm3%g%l%c%p%pepv%dayl ! 28 pepv%dayl + ! 29 clm3%g%l%c%p%pepv%days_active ! 29 pepv%days_active + ! 30 clm3%g%l%c%p%pepv%dormant_flag ! 30 pepv%dormant_flag + ! 31 clm3%g%l%c%p%pepv%offset_counter ! 31 pepv%offset_counter + ! 32 clm3%g%l%c%p%pepv%offset_fdd ! 32 pepv%offset_fdd + ! 33 clm3%g%l%c%p%pepv%offset_flag ! 33 pepv%offset_flag + ! 34 clm3%g%l%c%p%pepv%offset_swi ! 34 pepv%offset_swi + ! 35 clm3%g%l%c%p%pepv%onset_counter ! 35 pepv%onset_counter + ! 36 clm3%g%l%c%p%pepv%onset_fdd ! 36 pepv%onset_fdd + ! 37 clm3%g%l%c%p%pepv%onset_flag ! 37 pepv%onset_flag + ! 38 clm3%g%l%c%p%pepv%onset_gdd ! 38 pepv%onset_gdd + ! 39 clm3%g%l%c%p%pepv%onset_gddflag ! 39 pepv%onset_gddflag + ! 40 clm3%g%l%c%p%pepv%onset_swi ! 40 pepv%onset_swi + ! 41 clm3%g%l%c%p%pepv%prev_frootc_to_litter ! 41 pepv%prev_frootc_to_litter + ! 42 clm3%g%l%c%p%pepv%prev_leafc_to_litter ! 42 pepv%prev_leafc_to_litter + ! 43 clm3%g%l%c%p%pepv%tempavg_t2m ! 43 pepv%tempavg_t2m + ! 44 clm3%g%l%c%p%pepv%tempmax_retransn ! 44 pepv%tempmax_retransn + ! 45 clm3%g%l%c%p%pepv%tempsum_npp ! 45 pepv%tempsum_npp + ! 46 clm3%g%l%c%p%pepv%tempsum_potential_gpp ! 46 pepv%tempsum_potential_gpp + ! 47 clm3%g%l%c%p%pepv%xsmrpool_recover ! 47 pepv%xsmrpool_recover + ! 48 clm3%g%l%c%p%pns%deadcrootn ! 48 pns%deadcrootn + ! 49 clm3%g%l%c%p%pns%deadcrootn_storage ! 49 pns%deadcrootn_storage + ! 50 clm3%g%l%c%p%pns%deadcrootn_xfer ! 50 pns%deadcrootn_xfer + ! 51 clm3%g%l%c%p%pns%deadstemn ! 51 pns%deadstemn + ! 52 clm3%g%l%c%p%pns%deadstemn_storage ! 52 pns%deadstemn_storage + ! 53 clm3%g%l%c%p%pns%deadstemn_xfer ! 53 pns%deadstemn_xfer + ! 54 clm3%g%l%c%p%pns%frootn ! 54 pns%frootn + ! 55 clm3%g%l%c%p%pns%frootn_storage ! 55 pns%frootn_storage + ! 56 clm3%g%l%c%p%pns%frootn_xfer ! 56 pns%frootn_xfer + ! 57 clm3%g%l%c%p%pns%leafn ! 57 pns%leafn + ! 58 clm3%g%l%c%p%pns%leafn_storage ! 58 pns%leafn_storage + ! 59 clm3%g%l%c%p%pns%leafn_xfer ! 59 pns%leafn_xfer + ! 60 clm3%g%l%c%p%pns%livecrootn ! 60 pns%livecrootn + ! 61 clm3%g%l%c%p%pns%livecrootn_storage ! 61 pns%livecrootn_storage + ! 62 clm3%g%l%c%p%pns%livecrootn_xfer ! 62 pns%livecrootn_xfer + ! 63 clm3%g%l%c%p%pns%livestemn ! 63 pns%livestemn + ! 64 clm3%g%l%c%p%pns%livestemn_storage ! 64 pns%livestemn_storage + ! 65 clm3%g%l%c%p%pns%livestemn_xfer ! 65 pns%livestemn_xfer + ! 66 clm3%g%l%c%p%pns%npool ! 66 pns%npool + ! 67 clm3%g%l%c%p%pns%pft_ntrunc ! 67 pns%pft_ntrunc + ! 68 clm3%g%l%c%p%pns%retransn ! 68 pns%retransn + ! 69 clm3%g%l%c%p%pps%elai ! 69 pps%elai + ! 70 clm3%g%l%c%p%pps%esai ! 70 pps%esai + ! 71 clm3%g%l%c%p%pps%hbot ! 71 pps%hbot + ! 72 clm3%g%l%c%p%pps%htop ! 72 pps%htop + ! 73 clm3%g%l%c%p%pps%tlai ! 73 pps%tlai + ! 74 clm3%g%l%c%p%pps%tsai ! 74 pps%tsai + ! 75 pepv%plant_ndemand + ! OLD ! 75 pps%gddplant + ! OLD ! 76 pps%gddtsoi + ! OLD ! 77 pps%peaklai + ! OLD ! 78 pps%idop + ! OLD ! 79 pps%aleaf + ! OLD ! 80 pps%aleafi + ! OLD ! 81 pps%astem + ! OLD ! 82 pps%astemi + ! OLD ! 83 pps%htmx + ! OLD ! 84 pps%hdidx + ! OLD ! 85 pps%vf + ! OLD ! 86 pps%cumvd + ! OLD ! 87 pps%croplive + ! OLD ! 88 pps%cropplant + ! OLD ! 89 pps%harvdate + ! OLD ! 90 pps%gdd1020 + ! OLD ! 91 pps%gdd820 + ! OLD ! 92 pps%gdd020 + ! OLD ! 93 pps%gddmaturity + ! OLD ! 94 pps%huileaf + ! OLD ! 95 pps%huigrain + ! OLD ! 96 pcs%grainc + ! OLD ! 97 pcs%grainc_storage + ! OLD ! 98 pcs%grainc_xfer + ! OLD ! 99 pns%grainn + ! OLD !100 pns%grainn_storage + ! OLD !101 pns%grainn_xfer + ! OLD !102 pepv%fert_counter + ! OLD !103 pnf%fert + ! OLD !104 pepv%grain_flag end do OUT_TILE diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentRst.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentRst.F90 index e0cf3f7bf..4cdbbc11a 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentRst.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentRst.F90 @@ -2,7 +2,7 @@ module CatchmentRstMod use mk_restarts_getidsMod, ONLY: & - GetIds, & + GetIds, & ReadTileFile_RealLatLon use MAPL use MAPL_Base, ONLY: MAPL_UNDEF @@ -19,7 +19,7 @@ module CatchmentRstMod implicit none -#ifndef __GFORTRAN__ +#if !defined(__GFORTRAN__) && !defined(__flang__) integer :: ftell external :: ftell #endif @@ -104,11 +104,11 @@ module CatchmentRstMod real, allocatable, dimension(:) :: lonc,latc,lonn,latt, latg integer, allocatable, dimension(:) :: id_glb contains - procedure :: read_GEOSldas_rst_bin - procedure :: write_nc4 - procedure :: read_shared_nc4 + procedure :: read_GEOSldas_rst_bin + procedure :: write_nc4 + procedure :: read_shared_nc4 procedure :: write_shared_nc4 - procedure :: add_bcs_to_rst + procedure :: add_bcs_to_rst procedure :: allocate_catch procedure :: re_tile procedure :: re_scale @@ -160,7 +160,7 @@ function CatchmentRst_create(filename, time, rc) result (catch) read(unit) epos = ftell(unit) ! ending position of file pointer close(unit) - ntiles = (epos-bpos)/4-2 ! record size (in 4 byte words; + ntiles = (epos-bpos)/4-2 ! record size (in 4 byte words; catch%ntiles = ntiles catch%meta = create_meta(ntiles, time) if (myid ==0) then @@ -175,7 +175,7 @@ function CatchmentRst_empty(meta, time, rc) result (catch) type(CatchmentRst) :: catch character(*), intent(in) :: time type(FileMetadata), intent(in) :: meta - + integer, optional, intent(out) :: rc integer :: status, myid, mpierr character(len=256) :: Iam = "CatchmentRst_create" @@ -184,7 +184,7 @@ function CatchmentRst_empty(meta, time, rc) result (catch) call MPI_COMM_RANK( MPI_COMM_WORLD, myid, mpierr ) ! nc4 format catch%ntiles = meta%get_dimension('tile', __RC__) - catch%meta = meta + catch%meta = meta catch%time = time if (myid ==0) then call catch%allocate_catch() @@ -264,14 +264,14 @@ subroutine read_shared_nc4(this, formatter, rc) type(Netcdf4_fileformatter),intent(inout) :: formatter integer, optional, intent(out):: rc integer :: status - + ! these four (time-invariant) variables are used for rescaling of prognostic variables call MAPL_VarRead(formatter,"VGWMAX",this%vgwmax, __RC__) call MAPL_VarRead(formatter,"CDCR1",this%cdcr1, __RC__) call MAPL_VarRead(formatter,"CDCR2",this%cdcr2, __RC__) call MAPL_VarRead(formatter,"POROS",this%poros, __RC__) - ! Catchment model prognostic variables (and some diagnostics needed in Catch restart for GCM) + ! Catchment model prognostic variables (and some diagnostics needed in Catch restart for GCM) call MAPL_VarRead(formatter,"TC",this%tc, __RC__) call MAPL_VarRead(formatter,"QC",this%qc, __RC__) call MAPL_VarRead(formatter,"CAPAC",this%capac, __RC__) @@ -436,7 +436,7 @@ subroutine allocate_catch(this,rc) allocate( this% ghtcnt4(ntiles) ) allocate( this% ghtcnt5(ntiles) ) allocate( this% ghtcnt6(ntiles) ) - + if (this%meta%has_variable('TSURF')) then allocate( this% tsurf(ntiles) ) endif @@ -500,31 +500,31 @@ subroutine add_bcs_to_rst(this, surflay, DataDir, rc) inquire(file = trim(DataDir)//"/clsm/CLM_veg_typs_fracs",exist=NewLand ) this%ity = DP2BR - this%ARA1 = DP2BR - this%ARA2 = DP2BR - this%ARA3 = DP2BR - this%ARA4 = DP2BR - this%ARS1 = DP2BR - this%ARS2 = DP2BR - this%ARS3 = DP2BR - this%ARW1 = DP2BR - this%ARW2 = DP2BR - this%ARW3 = DP2BR - this%ARW4 = DP2BR - this%ATAU = DP2BR - this%BTAU = DP2BR - this%PSIS = DP2BR - this%BEE = DP2BR - this%BF1 = DP2BR - this%BF2 = DP2BR - this%BF3 = DP2BR - this%TSA1 = DP2BR - this%TSA2 = DP2BR - this%TSB1 = DP2BR - this%TSB2 = DP2BR - this%GNU = DP2BR - this%COND = DP2BR - this%WPWET = DP2BR + this%ARA1 = DP2BR + this%ARA2 = DP2BR + this%ARA3 = DP2BR + this%ARA4 = DP2BR + this%ARS1 = DP2BR + this%ARS2 = DP2BR + this%ARS3 = DP2BR + this%ARW1 = DP2BR + this%ARW2 = DP2BR + this%ARW3 = DP2BR + this%ARW4 = DP2BR + this%ATAU = DP2BR + this%BTAU = DP2BR + this%PSIS = DP2BR + this%BEE = DP2BR + this%BF1 = DP2BR + this%BF2 = DP2BR + this%BF3 = DP2BR + this%TSA1 = DP2BR + this%TSA2 = DP2BR + this%TSB1 = DP2BR + this%TSB2 = DP2BR + this%GNU = DP2BR + this%COND = DP2BR + this%WPWET = DP2BR this%POROS = DP2BR this%VGWMAX = DP2BR this%cdcr1 = DP2BR @@ -594,7 +594,7 @@ subroutine add_bcs_to_rst(this, surflay, DataDir, rc) open(unit=26, file=trim(DataDir)//'/clsm/tau_param.dat' ,form='formatted') do n=1,ntiles - ! W.J notes: CanopH is not used. If CLM_veg_typs_fracs exists, the read some dummy ???? Ask Sarith + ! W.J notes: CanopH is not used. If CLM_veg_typs_fracs exists, the read some dummy ???? Ask Sarith if (NewLand) then read(21,*) I, j, ITY(N),idum, rdum, rdum, CanopH else @@ -658,7 +658,7 @@ type(FileMetadata) function create_meta(ntiles, t, rc) result(meta) integer :: n, status character(:), allocatable :: s type(Variable) :: var - + fields(1,:) = [character(len=64)::"ARA1" , "shape_param_1" , "m+2 kg-1"] fields(2,:) = [character(len=64)::"ARA2" , "shape_param_2" , "1"] fields(3,:) = [character(len=64)::"ARA3" , "shape_param_3" , "m+2 kg-1"] @@ -776,11 +776,11 @@ subroutine re_tile(this, InTileFile, OutBcsDir, OutTileFile, surflay, rc) print *,'ntiles in restarts : ',in_ntiles endif - + ! Domain decomposition ! -------------------- - + allocate(low_ind ( numprocs)) allocate(upp_ind ( numprocs)) allocate(nt_local( numprocs)) @@ -846,7 +846,7 @@ subroutine re_tile(this, InTileFile, OutBcsDir, OutTileFile, surflay, rc) ! -------------------------------------------------------------------------------- ! Here we create transfer index array to map offline restarts to output tile space - ! -------------------------------------------------------------------------------- + ! -------------------------------------------------------------------------------- ! id_glb for hydrologic variable this%lonc = lonc @@ -962,10 +962,10 @@ subroutine re_tile(this, InTileFile, OutBcsDir, OutTileFile, surflay, rc) var_out = this%SNDZN3(id_glb(:)) this%SNDZN3 = var_out - + !set tsurf to zero if (this%meta%has_variable('TSURF')) then - var_out = this%tsurf(id_glb(:)) + var_out = this%tsurf(id_glb(:)) this%tsurf = var_out endif @@ -1015,7 +1015,7 @@ subroutine re_tile(this, InTileFile, OutBcsDir, OutTileFile, surflay, rc) if(associated(lonc)) deallocate(lonc) if(associated(latc)) deallocate(latc) - _RETURN(_SUCCESS) + _RETURN(_SUCCESS) end subroutine re_tile subroutine re_scale(this, surflay, wemin_in, wemin_out, rc) @@ -1178,6 +1178,6 @@ subroutine set_scale_var(this ) this%old_ghtcnt4 = this%ghtcnt4 this%old_ghtcnt5 = this%ghtcnt5 this%old_ghtcnt6 = this%ghtcnt6 - end subroutine set_scale_var + end subroutine set_scale_var end module CatchmentRstMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/SaltImpConverter.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/SaltImpConverter.F90 index 39976ff86..5321c0dfb 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/SaltImpConverter.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/SaltImpConverter.F90 @@ -23,12 +23,12 @@ program SaltImpConverter real*8, allocatable :: varInR8(:),varOutR8(:) integer, parameter :: zoom=1 -#ifndef __GFORTRAN__ +#if !defined(__GFORTRAN__) && !defined(__flang__) integer :: ftell external :: ftell #endif integer :: bpos, epos, ntot - integer :: foutID, status, TimID, TileID + integer :: foutID, status, TimID, TileID integer, allocatable :: nrecs(:), mrecs(:) type(Netcdf4_Fileformatter) :: InImpFmt,OutFmt,InIntFmt type(FileMetadata) :: InImpCfg,OutCfg,InIntCfg @@ -42,7 +42,7 @@ program SaltImpConverter character*256 :: OutFileName integer :: dimSizes(3) integer :: filetype,nVars - integer :: varid + integer :: varid character*256 :: vname character*256 :: longname character*256 :: units @@ -52,7 +52,7 @@ program SaltImpConverter INCLUDE 'netcdf.inc' !--------------------------------------------------------------------------- - Data impNames / & + Data impNames / & 'ALW', & 'BLW', & 'LWDNSRF', & @@ -139,31 +139,31 @@ program SaltImpConverter var_iter = variables%begin() do while (var_iter /= variables%end()) var_name => var_iter%key() - if(var_name(1:6) == 'TSKINW') & + if(var_name(1:6) == 'TSKINW') & call MAPL_VarRead(InIntFmt,var_name,TW, __RC__) - if(var_name(1:6) == 'SSKINW') & + if(var_name(1:6) == 'SSKINW') & call MAPL_VarRead(InIntFmt,var_name,SW, __RC__) call var_iter%next() - enddo + enddo variables => InImpCfg%get_variables() var_iter = variables%begin() do while (var_iter /= variables%end()) - + var_name => var_iter%key() myVariable => var_iter%value() var_dimensions => myVariable%get_dimensions() - ndims = var_dimensions%size() + ndims = var_dimensions%size() if (ndims == 1) then status = NF_DEF_VAR(FOutID, var_name , NF_FLOAT, 1 , TileID , varid) attr => myVariable%get_attribute('long_name') status = NF_PUT_ATT_TEXT(FOutID, varid, 'long_name', & LEN_TRIM(attr%get_string()), & - trim(attr%get_string())) + trim(attr%get_string())) attr => myVariable%get_attribute('units') status = NF_PUT_ATT_TEXT(FOutID, varid, 'units', & - LEN_TRIM(attr%get_string()), trim(attr%get_string()) ) - else + LEN_TRIM(attr%get_string()), trim(attr%get_string()) ) + else write(*,*)"Import States are all TileOnly:, ",trim(var_name), " is not?" stop endif @@ -176,13 +176,13 @@ program SaltImpConverter status = NF_DEF_VAR(FOutID, vname , NF_FLOAT, 1 , TileID , varid) status = NF_PUT_ATT_TEXT(FOutID, varid, 'long_name', & LEN_TRIM(longname), & - trim(longname)) + trim(longname)) status = NF_PUT_ATT_TEXT(FOutID, varid, 'units', & - LEN_TRIM(units), trim(units)) - status = NF_ENDDEF(FOutID) + LEN_TRIM(units), trim(units)) + status = NF_ENDDEF(FOutID) + + - - variables => InImpCfg%get_variables() var_iter = variables%begin() do while (var_iter /= variables%end()) @@ -190,18 +190,18 @@ program SaltImpConverter write(*,*)"Writing ",trim(var_name) myVariable => var_iter%value() var_dimensions => myVariable%get_dimensions() - ndims = var_dimensions%size() + ndims = var_dimensions%size() write(*,*)"Writing ",trim(var_name) if (ndims == 1) then call MAPL_VarRead(InImpFmt,var_name,varIn, __RC__) - if(vname(1:8) == 'TS_FOUND') then - varOut(:) = TW(:) + if(vname(1:8) == 'TS_FOUND') then + varOut(:) = TW(:) else - varOut(:) = varIn(:) - endif + varOut(:) = varIn(:) + endif STATUS = NF_INQ_VARID (FoutID, trim(var_name) ,VarID) STATUS = NF_PUT_VARA_REAL(FOutID,VarID, (/1/), (/itiles/), varOut) - else + else write(*,*)"Import States are all TileOnly:, ",trim(vname), " is not?" stop endif @@ -209,10 +209,10 @@ program SaltImpConverter enddo vname = "SS_FOUND" STATUS = NF_INQ_VARID (FoutID, trim(VNAME) ,VarID) - varOut(:) = SW(:) + varOut(:) = SW(:) STATUS = NF_PUT_VARA_REAL(FOutID,VarID, (/1/), (/itiles/), varOut) - - status = NF_CLOSE (FoutID) + + status = NF_CLOSE (FoutID) else @@ -226,7 +226,7 @@ program SaltImpConverter status='old',convert='little_endian') ! get TW and SW from internal - ! same for AMIP and coupled + ! same for AMIP and coupled read(51) varIn read(51) TW read(51) SW @@ -271,7 +271,7 @@ program SaltImpConverter print*, 'ntot ', ntot, ' /= ', size(impNames) print*, 'this import restart file is NOT compatible with MERRA-2 tag !!!' print*, 'DOUBLE CHECK!!! BYE !!!' - stop + stop endif ! Read and Write Tile or TileTile Data until EOF @@ -291,10 +291,10 @@ program SaltImpConverter vname = "SS_FOUND" STATUS = NF_INQ_VARID (FoutID, trim(VNAME) ,VarID) - varOut(:) = SW(:) + varOut(:) = SW(:) STATUS = NF_PUT_VARA_REAL(FOutID,VarID, (/1/), (/itiles/), varOut) - status = NF_CLOSE (FoutID) + status = NF_CLOSE (FoutID) end if @@ -310,313 +310,313 @@ SUBROUTINE create_salt_import_nc4 (ntiles, fileName, NCFOutID) integer, intent (in) :: ntiles character(*), intent(in) :: fileName - integer, intent (inout) :: NCFOutID - integer :: CatchID, TimID, VID, status + integer, intent (inout) :: NCFOutID + integer :: CatchID, TimID, VID, status status = NF_CREATE (filename, NF_NETCDF4, NCFOutID) status = NF_DEF_DIM(NCFOutID, 'tile', ntiles, CatchID) status = NF_DEF_DIM(NCFOutID, 'time' , 1 , TimID) - + status = NF_DEF_VAR(NCFOutID, 'time' , NF_DOUBLE, 1 , TimID , vid) status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'units', & - LEN_TRIM('minutes since 2014-01-01 00:00:00'), trim('minutes since 2014-01-01 00:00:00')) + LEN_TRIM('minutes since 2014-01-01 00:00:00'), trim('minutes since 2014-01-01 00:00:00')) status = NF_DEF_VAR(NCFOutID, 'ALW' , NF_FLOAT, 1 , CatchID , vid) - status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& + status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& LEN_TRIM('linearization_of_surface_upwelling_longwave_flux'),& trim('linearization_of_surface_upwelling_longwave_flux')) status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'units', & LEN_TRIM('W m-2'), trim('W m-2')) status = NF_DEF_VAR(NCFOutID, 'BLW' , NF_FLOAT, 1 , CatchID , vid) - status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& + status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& LEN_TRIM('linearization_of_surface_upwelling_longwave_flux'),& trim('linearization_of_surface_upwelling_longwave_flux')) status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'units', & LEN_TRIM('W m-2 K-1'), trim('W m-2 K-1')) status = NF_DEF_VAR(NCFOutID, 'CMATM' , NF_FLOAT, 1 , CatchID , vid) - status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& + status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& LEN_TRIM('surface_exchange_coefficient_for_momentum'),& trim('surface_exchange_coefficient_for_momentum')) status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'units', & LEN_TRIM('kg m-2 s-1'), trim('kg m-2 s-1')) status = NF_DEF_VAR(NCFOutID, 'CQATM' , NF_FLOAT, 1 , CatchID , vid) - status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& + status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& LEN_TRIM('surface_exchange_coefficient_for_moisture'),& trim('surface_exchange_coefficient_for_moisture')) status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'units', & LEN_TRIM('kg m-2 s-1'), trim('kg m-2 s-1')) status = NF_DEF_VAR(NCFOutID, 'CTATM' , NF_FLOAT, 1 , CatchID , vid) - status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& + status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& LEN_TRIM('surface_exchange_coefficient_for_heat'),& trim('surface_exchange_coefficient_for_heat')) status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'units', & LEN_TRIM('kg m-2 s-1'), trim('kg m-2 s-1')) status = NF_DEF_VAR(NCFOutID, 'DEVAP' , NF_FLOAT, 1 , CatchID , vid) - status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& + status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& LEN_TRIM('derivative_of_evaporation'),& trim('derivative_of_evaporation')) status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'units', & LEN_TRIM('kg m-2 s-1'), trim('kg m-2 s-1')) status = NF_DEF_VAR(NCFOutID, 'DFNIR' , NF_FLOAT, 1 , CatchID , vid) - status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& + status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& LEN_TRIM('surface_downwelling_nir_diffuse_flux'),& trim('surface_downwelling_nir_diffuse_flux')) status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'units', & LEN_TRIM('W m-2'), trim('W m-2')) status = NF_DEF_VAR(NCFOutID, 'DFPAR' , NF_FLOAT, 1 , CatchID , vid) - status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& + status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& LEN_TRIM('surface_downwelling_par_diffuse_flux'),& trim('surface_downwelling_par_diffuse_flux')) status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'units', & LEN_TRIM('W m-2'), trim('W m-2')) status = NF_DEF_VAR(NCFOutID, 'DFUVR' , NF_FLOAT, 1 , CatchID , vid) - status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& + status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& LEN_TRIM('surface_downwelling_uvr_diffuse_flux'),& trim('surface_downwelling_uvr_diffuse_flux')) status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'units', & LEN_TRIM('W m-2'), trim('W m-2')) status = NF_DEF_VAR(NCFOutID, 'DRNIR' , NF_FLOAT, 1 , CatchID , vid) - status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& + status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& LEN_TRIM('surface_downwelling_nir_beam_flux'),& trim('surface_downwelling_nir_beam_flux')) status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'units', & LEN_TRIM('W m-2'), trim('W m-2')) status = NF_DEF_VAR(NCFOutID, 'DRPAR' , NF_FLOAT, 1 , CatchID , vid) - status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& + status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& LEN_TRIM('surface_downwelling_par_beam_flux'),& trim('surface_downwelling_par_beam_flux')) status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'units', & LEN_TRIM('W m-2'), trim('W m-2')) status = NF_DEF_VAR(NCFOutID, 'DRUVR' , NF_FLOAT, 1 , CatchID , vid) - status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& + status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& LEN_TRIM('surface_downwelling_uvr_beam_flux'),& trim('surface_downwelling_uvr_beam_flux')) status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'units', & LEN_TRIM('W m-2'), trim('W m-2')) status = NF_DEF_VAR(NCFOutID, 'DSH' , NF_FLOAT, 1 , CatchID , vid) - status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& + status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& LEN_TRIM('derivative_of_upward_sensible_heat_flux'),& trim('derivative_of_upward_sensible_heat_flux')) status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'units', & LEN_TRIM('W m-2'), trim('W m-2')) status = NF_DEF_VAR(NCFOutID, 'DZ' , NF_FLOAT, 1 , CatchID , vid) - status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& + status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& LEN_TRIM('surface_layer_height'),& trim('surface_layer_height')) status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'units', & LEN_TRIM('m'), trim('m')) status = NF_DEF_VAR(NCFOutID, 'EVAP' , NF_FLOAT, 1 , CatchID , vid) - status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& + status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& LEN_TRIM('evaporation'),& trim('evaporation')) status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'units', & LEN_TRIM('kg m-2 s-1'), trim('kg m-2 s-1')) status = NF_DEF_VAR(NCFOutID, 'FRACICE' , NF_FLOAT, 1 , CatchID , vid) - status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& + status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& LEN_TRIM('ice_covered_fraction_of_tile'),& trim('ice_covered_fraction_of_tile')) status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'units', & LEN_TRIM('1'), trim('1')) status = NF_DEF_VAR(NCFOutID, 'KPAR' , NF_FLOAT, 1 , CatchID , vid) - status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& + status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& LEN_TRIM('PAR_extinction_coefficient'),& trim('PAR_extinction_coefficient')) status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'units', & LEN_TRIM('m-1'), trim('m-1')) status = NF_DEF_VAR(NCFOutID, 'LWDNSRF' , NF_FLOAT, 1 , CatchID , vid) - status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& + status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& LEN_TRIM('surface_downwelling_longwave_flux'),& trim('surface_downwelling_longwave_flux')) status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'units', & LEN_TRIM('W m-2'), trim('W m-2')) status = NF_DEF_VAR(NCFOutID, 'PCU' , NF_FLOAT, 1 , CatchID , vid) - status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& + status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& LEN_TRIM('liquid_water_convective_precipitation'),& trim('liquid_water_convective_precipitation')) status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'units', & LEN_TRIM('kg m-2 s-1'), trim('kg m-2 s-1')) status = NF_DEF_VAR(NCFOutID, 'PLS' , NF_FLOAT, 1 , CatchID , vid) - status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& + status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& LEN_TRIM('liquid_water_large_scale_precipitation'),& trim('liquid_water_large_scale_precipitation')) status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'units', & LEN_TRIM('kg m-2 s-1'), trim('kg m-2 s-1')) status = NF_DEF_VAR(NCFOutID, 'PS' , NF_FLOAT, 1 , CatchID , vid) - status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& + status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& LEN_TRIM('surface_pressure'),& trim('surface_pressure')) status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'units', & LEN_TRIM('Pa'), trim('Pa')) status = NF_DEF_VAR(NCFOutID, 'QA' , NF_FLOAT, 1 , CatchID , vid) - status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& + status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& LEN_TRIM('surface_air_specific_humidity'),& trim('surface_air_specific_humidity')) status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'units', & LEN_TRIM('kg kg-1'), trim('kg kg-1')) status = NF_DEF_VAR(NCFOutID, 'QHATM' , NF_FLOAT, 1 , CatchID , vid) - status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& + status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& LEN_TRIM('effective_surface_specific_humidity'),& trim('effective_surface_specific_humidity')) status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'units', & LEN_TRIM('kg kg-1'), trim('kg kg-1')) status = NF_DEF_VAR(NCFOutID, 'SH' , NF_FLOAT, 1 , CatchID , vid) - status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& + status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& LEN_TRIM('upward_sensible_heat_flux'),& trim('upward_sensible_heat_flux')) status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'units', & LEN_TRIM('W m-2'), trim('W m-2')) status = NF_DEF_VAR(NCFOutID, 'SNO' , NF_FLOAT, 1 , CatchID , vid) - status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& + status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& LEN_TRIM('snowfall'),& trim('snowfall')) status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'units', & LEN_TRIM('kg m-2 s-1'), trim('kg m-2 s-1')) status = NF_DEF_VAR(NCFOutID, 'TA' , NF_FLOAT, 1 , CatchID , vid) - status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& + status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& LEN_TRIM('surface_air_temperature'),& trim('surface_air_temperature')) status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'units', & LEN_TRIM('K'), trim('K')) status = NF_DEF_VAR(NCFOutID, 'TAUX' , NF_FLOAT, 1 , CatchID , vid) - status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& + status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& LEN_TRIM('eastward_surface_stress'),& trim('eastward_surface_stress')) status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'units', & LEN_TRIM('N m-2'), trim('N m-2')) status = NF_DEF_VAR(NCFOutID, 'TAUXBOT' , NF_FLOAT, 1 , CatchID , vid) - status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& + status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& LEN_TRIM('eastward_stress_at_base_of_ice'),& trim('eastward_stress_at_base_of_ice')) status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'units', & LEN_TRIM('N m-2'), trim('N m-2')) status = NF_DEF_VAR(NCFOutID, 'TAUY' , NF_FLOAT, 1 , CatchID , vid) - status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& + status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& LEN_TRIM('northward_surface_stress'),& trim('northward_surface_stress')) status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'units', & LEN_TRIM('N m-2'), trim('N m-2')) status = NF_DEF_VAR(NCFOutID, 'TAUYBOT' , NF_FLOAT, 1 , CatchID , vid) - status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& + status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& LEN_TRIM('northward_stress_at_base_of_ice'),& trim('northward_stress_at_base_of_ice')) status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'units', & LEN_TRIM('N m-2'), trim('N m-2')) status = NF_DEF_VAR(NCFOutID, 'THATM' , NF_FLOAT, 1 , CatchID , vid) - status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& + status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& LEN_TRIM('effective_surface_skin_temperature'),& trim('effective_surface_skin_temperature')) status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'units', & LEN_TRIM('K'), trim('K')) status = NF_DEF_VAR(NCFOutID, 'TS_FOUND' , NF_FLOAT, 1 , CatchID , vid) - status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& + status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& LEN_TRIM('foundation_temperature_for_interface_layer'),& trim('foundation_temperature_for_interface_layer')) status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'units', & LEN_TRIM('K'), trim('K')) status = NF_DEF_VAR(NCFOutID, 'SS_FOUND' , NF_FLOAT, 1 , CatchID , vid) - status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& + status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& LEN_TRIM('foundation_salinity_for_interface_layer'),& trim('foundation_salinity_for_interface_layer')) status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'units', & LEN_TRIM('PSU'), trim('PSU')) status = NF_DEF_VAR(NCFOutID, 'UHATM' , NF_FLOAT, 1 , CatchID , vid) - status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& + status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& LEN_TRIM('effective_surface_zonal_velocity'),& trim('effective_surface_zonal_velocity')) status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'units', & LEN_TRIM('m s-1'), trim('m s-1')) status = NF_DEF_VAR(NCFOutID, 'UI' , NF_FLOAT, 1 , CatchID , vid) - status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& + status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& LEN_TRIM('zonal_velocity_of_surface_ice'),& trim('zonal_velocity_of_surface_ice')) status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'units', & LEN_TRIM('m s-1'), trim('m s-1')) status = NF_DEF_VAR(NCFOutID, 'UU' , NF_FLOAT, 1 , CatchID , vid) - status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& + status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& LEN_TRIM('surface_wind_speed'),& trim('surface_wind_speed')) status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'units', & LEN_TRIM('m s-1'), trim('m s-1')) status = NF_DEF_VAR(NCFOutID, 'UW' , NF_FLOAT, 1 , CatchID , vid) - status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& + status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& LEN_TRIM('zonal_velocity_of_surface_water'),& trim('zonal_velocity_of_surface_water')) status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'units', & LEN_TRIM('m s-1'), trim('m s-1')) status = NF_DEF_VAR(NCFOutID, 'UWINDLMTILE' , NF_FLOAT, 1 , CatchID , vid) - status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& + status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& LEN_TRIM('levellm_uwind'),& trim('levellm_uwind')) status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'units', & LEN_TRIM('m s-1'), trim('m s-1')) status = NF_DEF_VAR(NCFOutID, 'VHATM' , NF_FLOAT, 1 , CatchID , vid) - status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& + status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& LEN_TRIM('effective_surface_meridional_velocity'),& trim('effective_surface_meridional_velocity')) status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'units', & LEN_TRIM('m s-1'), trim('m s-1')) status = NF_DEF_VAR(NCFOutID, 'VI' , NF_FLOAT, 1 , CatchID , vid) - status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& + status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& LEN_TRIM('meridional_velocity_of_surface_ice'),& trim('meridional_velocity_of_surface_ice')) status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'units', & LEN_TRIM('m s-1'), trim('m s-1')) status = NF_DEF_VAR(NCFOutID, 'VW' , NF_FLOAT, 1 , CatchID , vid) - status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& + status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& LEN_TRIM('meridional_velocity_of_surface_water'),& trim('meridional_velocity_of_surface_water')) status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'units', & LEN_TRIM('m s-1'), trim('m s-1')) status = NF_DEF_VAR(NCFOutID, 'VWINDLMTILE' , NF_FLOAT, 1 , CatchID , vid) - status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& + status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'long_name',& LEN_TRIM('levellm_vwind'),& trim('levellm_vwind')) status = NF_PUT_ATT_TEXT(NCFOutID, vid, 'units', & LEN_TRIM('m s-1'), trim('m s-1')) - - status = NF_ENDDEF(NCFOutID) + + status = NF_ENDDEF(NCFOutID) END SUBROUTINE create_salt_import_nc4 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/SaltIntSplitter.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/SaltIntSplitter.F90 index 5ea5824ed..2b94daaf1 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/SaltIntSplitter.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/SaltIntSplitter.F90 @@ -7,7 +7,7 @@ program SaltIntSplitter use MAPL use mk_restarts_getidsMod, only: ReadTileFile_RealLatLon use gFTL_StringVector - use gFTL_StringIntegerMap + use gFTL_StringIntegerMap implicit none @@ -23,7 +23,7 @@ program SaltIntSplitter real, allocatable :: dummy(:) integer, parameter :: zoom=1 -#ifndef __GFORTRAN__ +#if !defined(__GFORTRAN__) && !defined(__flang__) integer :: ftell external :: ftell #endif @@ -90,7 +90,7 @@ program SaltIntSplitter else ungridSize = 0 end if - + dimensions => InCfg%get_dimensions() global => Incfg%get_global_var() IceCfg = FileMetaData(dimensions= dimensions, global=global) @@ -118,7 +118,7 @@ program SaltIntSplitter if((subtileSize==0) .and. (ungridSize/=0)) then call IceCfg%modify_dimension('unknown_dim4', ungridSize-1) endif - + if ((subtileSize/=0) .and. (ungridSize/=0)) then call IceCfg%modify_dimension('unknown_dim4', ungridSize-1) call WaterCfg%modify_dimension('subtile', 1) @@ -130,7 +130,7 @@ program SaltIntSplitter variables => InCfg%get_variables() var_iter = variables%begin() do while (var_iter /= variables%end()) - + var_name => var_iter%key() myVariable => var_iter%value() var_dimensions => myVariable%get_dimensions() @@ -148,16 +148,16 @@ program SaltIntSplitter dname => myVariable%get_ith_dimension(2) dimSizes(2)=InCfg%get_dimension(dname) call iceCfg%add_variable(var_name, myVariable) - if (dataType /= pFIO_REAL64) then ! R8 vars only from coupled + if (dataType /= pFIO_REAL64) then ! R8 vars only from coupled if (dimSizes(2) == 2) then ! AMIP call waterCfg%add_variable(var_name, myVariable) else - if (var_name /= 'TSKINI' .and. var_name /= 'TAUAGE') then + if (var_name /= 'TSKINI' .and. var_name /= 'TAUAGE') then call waterCfg%add_variable(var_name, myVariable) - endif + endif endif endif - ! for coupled rst, water=1, ice=2,num_subtiles + ! for coupled rst, water=1, ice=2,num_subtiles else if (ndims == 3) then call iceCfg%add_variable(var_name, myVariable) end if @@ -167,7 +167,7 @@ program SaltIntSplitter call iceCfg%add_variable(var_name, myVariable) call waterCfg%add_variable(var_name, myVariable) endif - call var_iter%next() + call var_iter%next() enddo !#################### @@ -183,7 +183,7 @@ program SaltIntSplitter variables => InCfg%get_variables() var_iter = variables%begin() do while (var_iter /= variables%end()) - + var_name => var_iter%key() myVariable => var_iter%value() var_dimensions => myVariable%get_dimensions() @@ -192,7 +192,7 @@ program SaltIntSplitter if (.not.InCfg%is_coordinate_variable(var_name)) then write(*,*)"Writing ",trim(var_name),ndims - + if (ndims == 1) then call MAPL_VarRead(InFmt,var_name,varIn, __RC__) varOut(:) = varIn(:) @@ -207,23 +207,23 @@ program SaltIntSplitter else if (ndims == 2) then dname => myVariable%get_ith_dimension(2) dimSizes(2)=InCfg%get_dimension(dname) - ! for AMIP rst, ice=1, water=2 + ! for AMIP rst, ice=1, water=2 !if (dimSizes(2) /= 2) then ! write(*,*) "not an AMIP rst" ! stop - !endif + !endif !print*,trim(var_name), dimSizes(1), dimSizes(2) - if (dataType == pFIO_REAL64) then ! R8 vars only from coupled + if (dataType == pFIO_REAL64) then ! R8 vars only from coupled if (var_name(1:2) == 'FR') then ! FR dim changes from 6 to 5 do j=2,dimSizes(2) call MAPL_VarRead(InFmt,var_name,varInR8,offset1=j, __RC__) call MAPL_VarWrite(IceFmt,var_name,varInR8,offset1=j-1) - enddo + enddo else do j=1,dimSizes(2) call MAPL_VarRead(InFmt,var_name,varInR8,offset1=j, __RC__) call MAPL_VarWrite(IceFmt,var_name,varInR8,offset1=j) - enddo + enddo endif else if (dimSizes(2) == 2) then ! AMIP call MAPL_VarRead(InFmt,var_name,varIn,offset1=1, __RC__) @@ -231,21 +231,21 @@ program SaltIntSplitter call MAPL_VarRead(InFmt,var_name,varIn,offset1=2, __RC__) call MAPL_VarWrite(WaterFmt,var_name,varIn,offset1=1) else - if (var_name == 'TSKINI' .or. var_name == 'TAUAGE') then + if (var_name == 'TSKINI' .or. var_name == 'TAUAGE') then do j=1,dimSizes(2) call MAPL_VarRead(InFmt,var_name,varIn,offset1=j, __RC__) call MAPL_VarWrite(IceFmt,var_name,varIn,offset1=j) - enddo + enddo else call MAPL_VarRead(InFmt,var_name,varIn,offset1=1, __RC__) call MAPL_VarWrite(WaterFmt,var_name,varIn,offset1=1) do j=2,dimSizes(2) call MAPL_VarRead(InFmt,var_name,varIn,offset1=j, __RC__) call MAPL_VarWrite(IceFmt,var_name,varIn,offset1=j-1) - enddo - endif + enddo + endif endif - ! for coupled rst, water=1, ice=2,num_subtiles + ! for coupled rst, water=1, ice=2,num_subtiles else if (ndims == 3) then ! only coupled model internals conatin ndims=3 vars dname => myVariable%get_ith_dimension(2) @@ -254,7 +254,7 @@ program SaltIntSplitter dimSizes(3)=InCfg%get_dimension(dname) do k=1,dimSizes(3) do j=1,dimSizes(2) - if (dataType == pFIO_REAL64) then + if (dataType == pFIO_REAL64) then call MAPL_VarRead(InFmt,var_name,varInR8,offset1=j,offset2=k, __RC__) call MAPL_VarWrite(IceFmt,var_name,varInR8,offset1=j,offset2=k) else @@ -270,8 +270,8 @@ program SaltIntSplitter call MAPL_VarWrite(IceFmt, 'time',[0.0d0]) call MAPL_VarWrite(waterFmt,'time',[0.0d0]) endif - - call var_iter%next() + + call var_iter%next() enddo @@ -347,7 +347,7 @@ program SaltIntSplitter enddo - !print*, 'Splitter only supports NETCDF rst for now!!' + !print*, 'Splitter only supports NETCDF rst for now!!' !stop 1 end if diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/Scale_Catch.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/Scale_Catch.F90 index f79225031..c41eefe28 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/Scale_Catch.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/Scale_Catch.F90 @@ -2,14 +2,14 @@ #include "MAPL_Generic.h" program Scale_Catch - + use MAPL - + use LSM_ROUTINES, ONLY: & catch_calc_soil_moist, & catch_calc_tp, & catch_calc_ght - + USE CATCH_CONSTANTS, ONLY: & N_GT => CATCH_N_GT, & DZGT => CATCH_DZGT, & @@ -18,7 +18,7 @@ program Scale_Catch implicit none character(256) :: fname1, fname2, fname3 -#ifndef __GFORTRAN__ +#if !defined(__GFORTRAN__) && !defined(__flang__) integer :: ftell external :: ftell #endif @@ -101,7 +101,7 @@ program Scale_Catch integer :: i, rc, filetype integer :: status character(256) :: Iam = "Scale_Catch" - + ! Usage ! ----- if (iargc() /= 6) then @@ -128,8 +128,8 @@ program Scale_Catch if (filetype == 0) then call formatter(1)%open(trim(fname1),pFIO_READ, __RC__) call formatter(2)%open(trim(fname2),pFIO_READ, __RC__) - cfg(1)=formatter(1)%read(__RC__) - cfg(2)=formatter(2)%read(__RC__) + cfg(1)=formatter(1)%read(__RC__) + cfg(2)=formatter(2)%read(__RC__) else open(unit=10, file=trim(fname1), form='unformatted') open(unit=20, file=trim(fname2), form='unformatted') @@ -161,7 +161,7 @@ program Scale_Catch bpos=0 read(10) epos = ftell(10) ! ending position of file pointer - ntiles = (epos-bpos)/4-2 ! record size (in 4 byte words; + ntiles = (epos-bpos)/4-2 ! record size (in 4 byte words; rewind 10 end if @@ -178,7 +178,7 @@ program Scale_Catch ! ------------------ old = 1 new = 2 - + if (filetype ==0) then call readcatch_nc4 ( catch(old), formatter(old), __RC__ ) call readcatch_nc4 ( catch(new), formatter(new), __RC__ ) @@ -202,7 +202,7 @@ program Scale_Catch ! ! where( (catch(old)%catdef .gt. catch(old)%cdcr1) .and. & ! (catch(new)%cdcr2 .gt. catch(old)%cdcr2) ) -! +! ! catch(sca)%rzexc = catch(old)%rzexc * ( catch(new)%vgwmax / & ! catch(old)%vgwmax ) ! @@ -213,7 +213,7 @@ program Scale_Catch ! end where n =count((catch(old)%catdef .gt. catch(old)%cdcr1)) - + write(6,200) n,100*n/ntiles ! Scale rxexc regardless of CDCR1, CDCR2 differences @@ -224,7 +224,7 @@ program Scale_Catch ! Scale catdef regardless of whether CDCR2 is larger or smaller in the new situation ! ---------------------------------------------------------------------------------- where (catch(old)%catdef .gt. catch(old)%cdcr1) - + catch(sca)%catdef = catch(new)%cdcr1 + & ( catch(old)%catdef-catch(old)%cdcr1 ) / & ( catch(old)%cdcr2 -catch(old)%cdcr1 ) * & @@ -279,7 +279,7 @@ program Scale_Catch GHT_IN (4,:) = catch(old)%ghtcnt4 GHT_IN (5,:) = catch(old)%ghtcnt5 GHT_IN (6,:) = catch(old)%ghtcnt6 - + call catch_calc_tp ( NTILES, catch(old)%poros, GHT_IN, tp_in, FICE) GHT_OUT = GHT_IN @@ -299,7 +299,7 @@ program Scale_Catch catch(sca)%ghtcnt3 = GHT_IN (3,:) catch(sca)%ghtcnt4 = GHT_IN (4,:) catch(sca)%ghtcnt5 = GHT_IN (5,:) - catch(sca)%ghtcnt6 = GHT_IN (6,:) + catch(sca)%ghtcnt6 = GHT_IN (6,:) ! Deep soil temp sanity check ! --------------------------- @@ -332,7 +332,7 @@ program Scale_Catch ! catch(sca)%sndzn1=catch(old)%sndzn1 ! catch(sca)%sndzn2=catch(old)%sndzn2 - ! catch(sca)%sndzn3=catch(old)%sndzn3 + ! catch(sca)%sndzn3=catch(old)%sndzn3 ! do i = 1, ntiles ! if((swe_in(i) > 0.).and. ((areasc_in(i) < 1.).OR.(areasc_out(i) < 1.))) then ! print *, i, areasc_in(i), depth_in(i) @@ -343,9 +343,9 @@ program Scale_Catch ! catch(sca)%sndzn1(i) = catch(new)%sndzn1(i)*wemin_out/wemin_in ! depth_out(i)/3. ! catch(sca)%sndzn2(i) = catch(new)%sndzn2(i)*wemin_out/wemin_in ! depth_out(i)/3. ! catch(sca)%sndzn3(i) = catch(new)%sndzn3(i)*wemin_out/wemin_in ! depth_out(i)/3. - ! endif + ! endif ! end do - + where (swe_in .gt. 0.) where (areasc_in .lt. 1. .or. areasc_out .lt. 1.) ! density_in= swe_in/(areasc_in * depth_in + 1.e-20) @@ -359,8 +359,8 @@ program Scale_Catch print *, 'Snow scaling summary' print *, '....................' - print *, 'Percent tiles SNDZ scaled : ', 100.* count (catch(sca)%sndzn3 .ne. catch(old)%sndzn3) /float (count (catch(sca)%sndzn3 > 0.)) - + print *, 'Percent tiles SNDZ scaled : ', 100.* count (catch(sca)%sndzn3 .ne. catch(old)%sndzn3) /float (count (catch(sca)%sndzn3 > 0.)) + endif ! PEATCLSM - ensure low CATDEF on peat tiles where "old" restart is not also peat diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/Scale_CatchCN.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/Scale_CatchCN.F90 index cd2bce354..b0af2f033 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/Scale_CatchCN.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/Scale_CatchCN.F90 @@ -9,16 +9,16 @@ program Scale_CatchCN catch_calc_soil_moist, & catch_calc_tp, & catch_calc_ght - + USE CATCH_CONSTANTS, ONLY: & N_GT => CATCH_N_GT, & DZGT => CATCH_DZGT, & PEATCLSM_POROS_THRESHOLD - + implicit none character(256) :: fname1, fname2, fname3 -#ifndef __GFORTRAN__ +#if !defined(__GFORTRAN__) && !defined(__flang__) integer :: ftell external :: ftell #endif @@ -35,10 +35,10 @@ program Scale_CatchCN integer :: VAR_COL, VAR_PFT integer, parameter :: VAR_COL_CLM40 = 40 ! number of CN column restart variables integer, parameter :: VAR_PFT_CLM40 = 74 ! number of CN PFT variables per column - integer, parameter :: npft = 19 + integer, parameter :: npft = 19 integer, parameter :: VAR_COL_CLM45 = 35 ! number of CN column restart variables integer, parameter :: VAR_PFT_CLM45 = 75 ! number of CN PFT variables per column - + logical :: clm45 = .false. integer :: un_dim3 @@ -115,7 +115,7 @@ program Scale_CatchCN real, pointer :: FIELDCAP(:) real, pointer :: HDM (:) real, pointer :: GDP (:) - real, pointer :: PEATF (:) + real, pointer :: PEATF (:) endtype catch_rst type(catch_rst) catch(3) @@ -127,9 +127,9 @@ program Scale_CatchCN type(Netcdf4_fileformatter) :: formatter(3) type(Filemetadata) :: cfg(3) integer :: i, rc, filetype - integer :: status + integer :: status character(256) :: Iam = "Scale_CatchCN" - + ! Usage ! ----- if (iargc() /= 6) then @@ -156,14 +156,14 @@ program Scale_CatchCN if (filetype == 0) then call formatter(1)%open(trim(fname1),pFIO_READ, __RC__) call formatter(2)%open(trim(fname2),pFIO_READ, __RC__) - cfg(1)=formatter(1)%read(__RC__) + cfg(1)=formatter(1)%read(__RC__) cfg(2)=formatter(2)%read(__RC__) ! else ! open(unit=10, file=trim(fname1), form='unformatted') ! open(unit=20, file=trim(fname2), form='unformatted') ! open(unit=30, file=trim(fname3), form='unformatted') end if - + ! Get SURFLAY Value ! ----------------- read(arg(4),*) SURFLAY @@ -178,7 +178,7 @@ program Scale_CatchCN end if print *, 'SURFLAY: ',SURFLAY - VAR_COL = VAR_COL_CLM40 + VAR_COL = VAR_COL_CLM40 VAR_PFT = VAR_PFT_CLM40 if (filetype ==0) then @@ -187,7 +187,7 @@ program Scale_CatchCN un_dim3 = cfg(1)%get_dimension('unknown_dim3', __RC__) if(un_dim3 == 105) then clm45 = .true. - VAR_COL = VAR_COL_CLM45 + VAR_COL = VAR_COL_CLM45 VAR_PFT = VAR_PFT_CLM45 print *, 'Processing CLM45 restarts : ', VAR_COL, VAR_PFT, clm45 else @@ -200,7 +200,7 @@ program Scale_CatchCN ! bpos=0 ! read(10) ! epos = ftell(10) ! ending position of file pointer -! ntiles = (epos-bpos)/4-2 ! record size (in 4 byte words; +! ntiles = (epos-bpos)/4-2 ! record size (in 4 byte words; ! rewind 10 end if @@ -217,7 +217,7 @@ program Scale_CatchCN ! ------------------ old = 1 new = 2 - + if (filetype ==0) then call readcatchcn_nc4 ( catch(old), formatter(old), cfg(old), __RC__ ) call readcatchcn_nc4 ( catch(new), formatter(new), cfg(new), __RC__ ) @@ -229,7 +229,7 @@ program Scale_CatchCN ! Create Scaled Catch ! ------------------- sca = 3 - + catch(sca) = catch(new) ! 1) soil moisture prognostics @@ -241,7 +241,7 @@ program Scale_CatchCN ! ! where( (catch(old)%catdef .gt. catch(old)%cdcr1) .and. & ! (catch(new)%cdcr2 .gt. catch(old)%cdcr2) ) -! +! ! catch(sca)%rzexc = catch(old)%rzexc * ( catch(new)%vgwmax / & ! catch(old)%vgwmax ) ! @@ -252,7 +252,7 @@ program Scale_CatchCN ! end where n =count((catch(old)%catdef .gt. catch(old)%cdcr1)) - + write(6,200) n,100*n/ntiles ! Scale rxexc regardless of CDCR1, CDCR2 differences @@ -263,7 +263,7 @@ program Scale_CatchCN ! Scale catdef regardless of whether CDCR2 is larger or smaller in the new situation ! ---------------------------------------------------------------------------------- where (catch(old)%catdef .gt. catch(old)%cdcr1) - + catch(sca)%catdef = catch(new)%cdcr1 + & ( catch(old)%catdef-catch(old)%cdcr1 ) / & ( catch(old)%cdcr2 -catch(old)%cdcr1 ) * & @@ -295,7 +295,7 @@ program Scale_CatchCN catch(sca)%bf1, catch(sca)%bf2, & catch(sca)%srfexc, catch(sca)%rzexc, catch(sca)%catdef, & ar1, ar2, ar4 ) - + n = count( catch(sca)%catdef .ne. catch(new)%catdef ) write(6,300) n,100*n/ntiles n = count( catch(sca)%srfexc .ne. catch(new)%srfexc ) @@ -318,7 +318,7 @@ program Scale_CatchCN GHT_IN (4,:) = catch(old)%ghtcnt4 GHT_IN (5,:) = catch(old)%ghtcnt5 GHT_IN (6,:) = catch(old)%ghtcnt6 - + call catch_calc_tp ( NTILES, catch(old)%poros, GHT_IN, tp_in, FICE) GHT_OUT = GHT_IN @@ -338,7 +338,7 @@ program Scale_CatchCN catch(sca)%ghtcnt3 = GHT_IN (3,:) catch(sca)%ghtcnt4 = GHT_IN (4,:) catch(sca)%ghtcnt5 = GHT_IN (5,:) - catch(sca)%ghtcnt6 = GHT_IN (6,:) + catch(sca)%ghtcnt6 = GHT_IN (6,:) ! Deep soil temp sanity check ! --------------------------- @@ -371,7 +371,7 @@ program Scale_CatchCN ! catch(sca)%sndzn1=catch(old)%sndzn1 ! catch(sca)%sndzn2=catch(old)%sndzn2 - ! catch(sca)%sndzn3=catch(old)%sndzn3 + ! catch(sca)%sndzn3=catch(old)%sndzn3 ! do i = 1, ntiles ! if((swe_in(i) > 0.).and. ((areasc_in(i) < 1.).OR.(areasc_out(i) < 1.))) then ! print *, i, areasc_in(i), depth_in(i) @@ -382,9 +382,9 @@ program Scale_CatchCN ! catch(sca)%sndzn1(i) = catch(new)%sndzn1(i)*wemin_out/wemin_in ! depth_out(i)/3. ! catch(sca)%sndzn2(i) = catch(new)%sndzn2(i)*wemin_out/wemin_in ! depth_out(i)/3. ! catch(sca)%sndzn3(i) = catch(new)%sndzn3(i)*wemin_out/wemin_in ! depth_out(i)/3. - ! endif + ! endif ! end do - + where (swe_in .gt. 0.) where (areasc_in .lt. 1. .or. areasc_out .lt. 1.) ! density_in= swe_in/(areasc_in * depth_in + 1.e-20) @@ -398,8 +398,8 @@ program Scale_CatchCN print *, 'Snow scaling summary' print *, '....................' - print *, 'Percent tiles SNDZ scaled : ', 100.* count (catch(sca)%sndzn3 .ne. catch(old)%sndzn3) /float (count (catch(sca)%sndzn3 > 0.)) - + print *, 'Percent tiles SNDZ scaled : ', 100.* count (catch(sca)%sndzn3 .ne. catch(old)%sndzn3) /float (count (catch(sca)%sndzn3 > 0.)) + endif ! PEATCLSM - ensure low CATDEF on peat tiles where "old" restart is not also peat @@ -433,9 +433,9 @@ program Scale_CatchCN contains subroutine allocatch (ntiles,catch) - + integer ntiles - + type(catch_rst) catch allocate( catch% bf1(ntiles) ) @@ -511,7 +511,7 @@ subroutine allocatch (ntiles,catch) allocate( catch% HDM(ntiles) ) allocate( catch% GDP(ntiles) ) allocate( catch% PEATF(ntiles) ) - + return end subroutine allocatch @@ -602,7 +602,7 @@ subroutine readcatchcn_nc4 (catch,formatter,cfg, rc) myVariable => cfg%get_variable("CNCOL") dname => myVariable%get_ith_dimension(2) dim1 = cfg%get_dimension(dname) - if(clm45) then + if(clm45) then call MAPL_VarRead(formatter,"ABM", catch%ABM, __RC__) call MAPL_VarRead(formatter,"FIELDCAP",catch%FIELDCAP, __RC__) call MAPL_VarRead(formatter,"HDM", catch%HDM , __RC__) @@ -616,12 +616,12 @@ subroutine readcatchcn_nc4 (catch,formatter,cfg, rc) ! (to be merged into the "develop" branch in late 2020): ! The length of the 2nd dim of CNPFT differs from that of CNCOL. Prior to this fix, ! CNPFT was not read in its entirety and some elements remained uninitialized (or zero), - ! resulting in bad values in the "regridded" (re-tiled) restart file. + ! resulting in bad values in the "regridded" (re-tiled) restart file. ! This impacted re-tiled restarts for both CNCLM40 and CLCLM45. ! - reichle, 23 Nov 2020 myVariable => cfg%get_variable("CNPFT") dname => myVariable%get_ith_dimension(2) - dim1 = cfg%get_dimension(dname) + dim1 = cfg%get_dimension(dname) do j=1,dim1 call MAPL_VarRead(formatter,"CNPFT",catch%CNPFT(:,j),offset1=j, __RC__) enddo @@ -852,15 +852,15 @@ subroutine writecatchcn_nc4 (catch,formatter,cfg) call MAPL_VarWrite(formatter,"TPREC10D",var) call MAPL_VarWrite(formatter,"TPREC60D",var) else - call MAPL_VarWrite(formatter,"SFMCM", var) + call MAPL_VarWrite(formatter,"SFMCM", var) endif - + myVariable => cfg%get_variable("PSNSUNM") dname => myVariable%get_ith_dimension(2) dim1 = cfg%get_dimension(dname) dname => myVariable%get_ith_dimension(3) dim2 = cfg%get_dimension(dname) - do i=1,dim2 + do i=1,dim2 do j=1,dim1 call MAPL_VarWrite(formatter,"PSNSUNM",var,offset1=j,offset2=i) call MAPL_VarWrite(formatter,"PSNSHAM",var,offset1=j,offset2=i) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/cv_SaltRestart.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/cv_SaltRestart.F90 index e3ea2f506..b1bcaa8f1 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/cv_SaltRestart.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/cv_SaltRestart.F90 @@ -25,24 +25,24 @@ program cv_SaltRestart real*4, allocatable, dimension(: ) :: rainp, rainn, snowp, snown, rrp, rrn real*4, allocatable, dimension(: ) :: swradp, swradn, lwradp, lwradn, t10p, t10n real*4, allocatable, dimension(:,:) :: tauage - real*4, allocatable, dimension(:) :: slmask + real*4, allocatable, dimension(:) :: slmask real*4, allocatable, dimension(:,:) :: QS,CH,CM,CQ,Z0,WW - real*4, allocatable, dimension(: ) :: TWMTS, DTWARM - real*4, allocatable, dimension(:) :: sst, lons, lats + real*4, allocatable, dimension(: ) :: TWMTS, DTWARM + real*4, allocatable, dimension(:) :: sst, lons, lats real*4, allocatable, dimension(:,:) :: Tsc, Ts real*4, allocatable, dimension(:) :: frice real*4, allocatable, dimension(: ) :: X1D4 real*8, allocatable, dimension(: ) :: X1D8 - real*8, allocatable, dimension(:, :) :: & + real*8, allocatable, dimension(:, :) :: & aicen , & ! concentration of ice vicen , & ! volume per unit area of ice (m) vsnon , & ! volume per unit area of snow (m) trcrn , & ! ice tracers ! 1: surface temperature of ice/snow (C) volpondn, & - apondn, & - hpondn, & + apondn, & + hpondn, & eicen , & ! energy of melting for each ice layer (J/m^2) esnon ! energy of melting for each ice layer (J/m^2) real*4 :: lono, lato @@ -64,6 +64,7 @@ program cv_SaltRestart logical :: source_is_coupled + integer :: iargc source_is_coupled = .false. @@ -110,7 +111,7 @@ program cv_SaltRestart nxt = nxt + 1 call getarg(nxt,arg) InFile2 = arg - endif + endif case ('t') TileFile = arg case default @@ -166,7 +167,7 @@ program cv_SaltRestart ntiles = GetNumTiles(tilefile) - print *, "Processing restarts with ", ntiles, "tiles" + print *, "Processing restarts with ", ntiles, "tiles" allocate(HW(ntiles),TW(ntiles),SW(ntiles),HI(ntiles),TI(ntiles),SI(ntiles), & QS(ntiles,nsub),CH(ntiles,nsub),CM(ntiles,nsub), & @@ -174,7 +175,7 @@ program cv_SaltRestart allocate(sst(ntiles), lons(ntiles), lats(ntiles), frice(ntiles)) allocate(TWMTS(ntiles), DTWARM(ntiles)) - + allocate(X1D8(ntiles)) allocate(X1D4(ntiles)) @@ -185,9 +186,9 @@ program cv_SaltRestart allocate(Ts(ntiles,nsub)) allocate(tauage(ntiles,ncat), slmask(ntiles)) - call GetTileLonLats(tilefile, ntiles, lons, lats) + call GetTileLonLats(tilefile, ntiles, lons, lats) - print*, "InFile1: ",InFile1 + print*, "InFile1: ",InFile1 print*, "TileFile: ",tilefile i = index(InFile1,'/',back=.true.) @@ -367,7 +368,7 @@ program cv_SaltRestart print*, 'Finished reading old saltwater internal restart file' - print*, 'Start writing new CICEThermo internal restart file ...' + print*, 'Start writing new CICEThermo internal restart file ...' write(20) hw write(20) tw @@ -429,70 +430,70 @@ program cv_SaltRestart X1D4 = 0.0 write(20) X1D4 nrec = nrec + 1 - + ! FR do i=1,nsub - write(20) aicen(:,i) + write(20) aicen(:,i) nrec = nrec + 1 enddo ! VOLICE do i=1,ncat - write(20) vicen(:,i) + write(20) vicen(:,i) nrec = nrec + 1 enddo ! VOLSNO do i=1,ncat - write(20) vsnon(:,i) + write(20) vsnon(:,i) nrec = nrec + 1 enddo ! VOLPOND do i=1,ncat - write(20) volpondn(:,i) + write(20) volpondn(:,i) nrec = nrec + 1 enddo ! APOND do i=1,ncat - write(20) apondn(:,i) + write(20) apondn(:,i) nrec = nrec + 1 enddo ! HPOND do i=1,ncat - write(20) hpondn(:,i) + write(20) hpondn(:,i) nrec = nrec + 1 enddo !ERGICE do k=1,nilyr do i=1,ncat - X1D8 = eicen(:,ilyr1(i)+k-1) - write(20) X1D8 + X1D8 = eicen(:,ilyr1(i)+k-1) + write(20) X1D8 nrec = nrec + 1 - enddo + enddo enddo !ERGSNO do k=1,nslyr do i=1,ncat X1D8 = esnon(:,slyr1(i)+k-1) - write(20) X1D8 + write(20) X1D8 nrec = nrec + 1 enddo enddo !TAUAGE do i=1,ncat - write(20) tauage(:,i) + write(20) tauage(:,i) nrec = nrec + 1 enddo !SLMASK - write(20) slmask + write(20) slmask nrec = nrec + 1 close(10) @@ -512,7 +513,7 @@ program cv_SaltRestart print*,frice(k), tw(k), ti(k) do i=1,ncat print*,(eicen(k,ilyr1(i)+n-1),n=1,nilyr) - enddo + enddo endif enddo !deallocate(rainp, rainn, snowp, snown, rrp, rrn, & @@ -524,7 +525,7 @@ program cv_SaltRestart eicen, esnon) deallocate(Tsc) - endif + endif !#endif @@ -540,8 +541,8 @@ integer function GetNumTiles(tilefile) integer :: mark integer :: dum, n, nt character*128 :: dumstr - - + + open(10, file=tilefile, form="formatted",status='old') read(10, fmt=*) nt @@ -558,8 +559,8 @@ integer function GetNumTiles(tilefile) if(mark .eq. 0) ntiles = ntiles + 1 enddo close(10) - - GetNumTiles = ntiles + + GetNumTiles = ntiles end function GetNumTiles @@ -573,8 +574,8 @@ subroutine GetTileLonLats(tilefile, ntiles, Lons, Lats) integer :: dum, n, nt character*128 :: dumstr real :: rdum1, rdum2 - - + + open(10, file=tilefile, form="formatted",status='old') read(10, fmt=*) nt @@ -598,7 +599,7 @@ subroutine GetTileLonLats(tilefile, ntiles, Lons, Lats) Lats(n) = rdum2 endif enddo - !do n=1,10 + !do n=1,10 ! print*, Lons(n), Lats(n) !enddo @@ -620,7 +621,7 @@ subroutine set_state_var (nx_block, ny_block, & ice_con, tsc, & aicen, trcrn, & vicen, vsnon, & - eicen, esnon) + eicen, esnon) ! ! !DESCRIPTION: ! @@ -629,15 +630,15 @@ subroutine set_state_var (nx_block, ny_block, & ! integer (kind=int_kind), intent(in) :: & nx_block, ny_block , & ! block dimensions - icells + icells integer (kind=int_kind), dimension (nx_block*ny_block), & intent(in) :: & indxi, indxj ! compressed indices for cells with ice real (kind=real_kind), dimension (nx_block,ny_block), intent(in) :: & - tile_lat, tile_lon, & - ice_con, tsc + tile_lat, tile_lon, & + ice_con, tsc real (kind=dbl_kind), dimension (nx_block,ny_block,ncat), & @@ -678,7 +679,7 @@ subroutine set_state_var (nx_block, ny_block, & ice_cov real (kind=dbl_kind), dimension(nilyr+1) :: & - salin , & ! salinity (ppt) + salin , & ! salinity (ppt) Tmlt ! melting temp, -depressT * salinity ! nilyr + 1 index is for bottom surface @@ -744,10 +745,10 @@ subroutine set_state_var (nx_block, ny_block, & real (kind=dbl_kind), parameter :: & - tnh = 1.0_dbl_kind, & + tnh = 1.0_dbl_kind, & tsh = 0.75_dbl_kind, & hsno_init = 0.20_dbl_kind , & ! initial snow thickness (m) - edge_init_nh = 70._dbl_kind, & ! initial ice edge, N.Hem. (deg) + edge_init_nh = 70._dbl_kind, & ! initial ice edge, N.Hem. (deg) edge_init_sh = -60._dbl_kind ! initial ice edge, S.Hem. (deg) real (kind=dbl_kind), parameter :: & @@ -854,11 +855,11 @@ subroutine set_state_var (nx_block, ny_block, & if(hin_max(nc-1) < hi .and. hi < hin_max(nc)) then aicen(i,j,nc) = ice_cov(i,j) - vicen(i,j,nc) = hi*aicen(i,j,nc) + vicen(i,j,nc) = hi*aicen(i,j,nc) trcrn(i,j,nt_Tsfc,nc) = min(Tsmelt, tsc(i,j) - Tffresh) !deg C if(abs(tile_lon(i,j)-lono)<1.e-4 .and. abs(tile_lat(i,j)-lato)<1.e-4) then print*, tsc(i,j), trcrn(i,j,nt_Tsfc,nc) - endif + endif do k = 1, nilyr @@ -875,9 +876,9 @@ subroutine set_state_var (nx_block, ny_block, & if(abs(tile_lon(i,j)-lono)<1.e-4 .and. & abs(tile_lat(i,j)-lato)<1.e-4) then print*, k, Ti - endif + endif enddo ! nilyr - endif + endif enddo !ncat end if ! ice_cov(i,j) >= eps04 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_CatchCNRestarts.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_CatchCNRestarts.F90 index e4ab880c8..36f8836f8 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_CatchCNRestarts.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_CatchCNRestarts.F90 @@ -4,15 +4,15 @@ program mk_CatchCNRestarts ! Usage : mk_CatchCNRestarts OutTileFile InTileFile InRestart SURFLAY RestartTime -! Version 1 : Sarith Mahanama -! sarith.p.mahanama@nasa.gov (Feb 19, 2016) -! The program follows the same nearest neighbor based procedure, as in mk_CatchRestarts.F90, -! to regrid hydrological variables and BCs-based parameters. The algorithm developed -! by Greg Walker (~gkwalker/geos5/convert_offline_cn_restart.f90) to regrid carbon -! variables that looks for a neighbor with a similar vegetation type was modified -! to improve efficiency (in subroutine regrid_carbon_vars). The two main -! modifications in this implementation include: (1) instead looping over the globe, -! it starts from a 10 x 10 window and zoom out until a similar type appears, +! Version 1 : Sarith Mahanama +! sarith.p.mahanama@nasa.gov (Feb 19, 2016) +! The program follows the same nearest neighbor based procedure, as in mk_CatchRestarts.F90, +! to regrid hydrological variables and BCs-based parameters. The algorithm developed +! by Greg Walker (~gkwalker/geos5/convert_offline_cn_restart.f90) to regrid carbon +! variables that looks for a neighbor with a similar vegetation type was modified +! to improve efficiency (in subroutine regrid_carbon_vars). The two main +! modifications in this implementation include: (1) instead looping over the globe, +! it starts from a 10 x 10 window and zoom out until a similar type appears, ! (2) uses MPI enabling parrellel computation. ! Version 2 : Sarith Mahanama (Oct 12, 2016) ! (1) updated to read both carbon and hydrological variables more recent SMAP M09 simulation from Fanwei. @@ -20,48 +20,48 @@ program mk_CatchCNRestarts ! The program produces catchcn_internal_rst in nc4 format for any user specified AGCM grid resolution. ! regrid.pl visits this program twice during the regridding process. During the first visit, the program does not use BCs data. -! It just regrids hydrological variables and BCs-based land parameters in InRestart from InTile space to OutTile -! space (InRestart could be either a catchcn_internal_rst or a catch_internal_rst). If InRestart is a -! catchcn_internal_rst, carbon variables will be regridded using the same simple nearest neighbor algorithm (getids.H) that -! was employed for regridding all other variables. If InRestart is a catch_internal_rst, carbon variables will be +! It just regrids hydrological variables and BCs-based land parameters in InRestart from InTile space to OutTile +! space (InRestart could be either a catchcn_internal_rst or a catch_internal_rst). If InRestart is a +! catchcn_internal_rst, carbon variables will be regridded using the same simple nearest neighbor algorithm (getids.H) that +! was employed for regridding all other variables. If InRestart is a catch_internal_rst, carbon variables will be ! filled with zeros. - -! During the second visit, the program uses the catchcn_internal_rst produced from the first visit as InRestart (herein -! referred to as InRestart2 which is in OutTile space already). The program reads BCs data from BCSDIR, carbon variables -! from an offline simulation on the SMAP_EASEv2_M09 grid which has been initialized by another 3000-year offline simulation, and -! hydrological from -! InRestart2 in Version 1, + +! During the second visit, the program uses the catchcn_internal_rst produced from the first visit as InRestart (herein +! referred to as InRestart2 which is in OutTile space already). The program reads BCs data from BCSDIR, carbon variables +! from an offline simulation on the SMAP_EASEv2_M09 grid which has been initialized by another 3000-year offline simulation, and +! hydrological from +! InRestart2 in Version 1, ! the same offline simulation on the SMAP_EASEv2_M09 in Version 2. -! Then, they will be regridded to OutTile space. The regridding carbon variables utilizes a more complicated algorithm which looks -! for a M09 grid cell in the neighborhood with a similar vegetation type seperately for each fractional vegetation type within the -! catchment-tile. Note, the model can have upto 4 different types per catchment-tile: primary and secondary types -! and 2 split types for each primary and secondary type. - +! Then, they will be regridded to OutTile space. The regridding carbon variables utilizes a more complicated algorithm which looks +! for a M09 grid cell in the neighborhood with a similar vegetation type seperately for each fractional vegetation type within the +! catchment-tile. Note, the model can have upto 4 different types per catchment-tile: primary and secondary types +! and 2 split types for each primary and secondary type. + ! regrid.pl will then execute Scale_CatchCN.F90 which reads catchcn_internal_rst files created in the above 2 steps, ! and scale soil moisture variables to be consistent with the new BCs-based land parameters to produce the final ! catchcn_internal_rst file. ! Output file format: Output catchcn_internal_rst is always a nc4 file. -! Here are available options: +! Here are available options: ! (1) OPT1 (for above first step) -! Input : (1) catchcn_internal_rst from an existing AGCM run (will always be nc4) -! (2) InTile and OutTile are DIFFERENT +! Input : (1) catchcn_internal_rst from an existing AGCM run (will always be nc4) +! (2) InTile and OutTile are DIFFERENT ! (3) NO land BCs ! OutPut: Every variable (BCs-based land parameters, hydrological variables, and carbon parameters) will be regridded ! from InTile to OutTile space using the simple nearest neighbor algorithm (getids.H) ! (2) OPT2 (for above first step) -! Input : (1) catch_internal_rst from an existing AGCM run (either nc4 or binary) -! (2) InTile and OutTile are DIFFERENT -! (3) NO land BCs -! OutPut: BCs-based land parameters, and hydrological variables will regridded from InTile to OutTile space +! Input : (1) catch_internal_rst from an existing AGCM run (either nc4 or binary) +! (2) InTile and OutTile are DIFFERENT +! (3) NO land BCs +! OutPut: BCs-based land parameters, and hydrological variables will regridded from InTile to OutTile space ! using the simple nearest neighbor algorithm (getids.H). All carbon variables are filled with zeros. -! (3) OPT3 (above second step) : +! (3) OPT3 (above second step) : ! Input : (1) catchcn_internal_rst (file format is always nc4) ! (2) InTile and OutTile are the same user defined OutTile -! (3) land BCs, +! (3) land BCs, ! Output: BCs-based land parameters will be replaced and carbon variables will be filled with regridded (from the ! nearest offline cell with the same vegetation type) data to produce catchcn_internal_rst @@ -70,13 +70,13 @@ program mk_CatchCNRestarts ! ====================== ! ! Process ! ! ====================== ! - + ! HAVEDATA ! | -! _______________________________________________________________________ +! _______________________________________________________________________ ! | | -! -! NO (OPT1/OPT2) YES (OPT3) +! +! NO (OPT1/OPT2) YES (OPT3) ! -------------- ---------- !OutTile : /= InTile == InTile !regridding: ID (InTile to OutTile using getids.H) ID (one-to-one i.e. 1:NTILES, no regridding) @@ -92,20 +92,20 @@ program mk_CatchCNRestarts ! | _________________________________ | ! | | | | ! V 0 /= 0 V -!call : read_catchcn_nc4 read_catch_nc4 read_catch_bin read_bcs_data +!call : read_catchcn_nc4 read_catch_nc4 read_catch_bin read_bcs_data ! | | -! ----------------------------------- -! | -! V +! ----------------------------------- +! | +! V !1) reads InRestart nVars records (1) reads InCNRestart/regrids/writes (1:65) (1) reads BCs -!2) regrids (takes hydrological initial conditions (2) writes 1:37; 66:72 -!3) writes from offline SMAP M09) (3) reads InRestart2/writes 38, 39,40=38,41:65 -!4) close files (2) close files (4) call regrid_carbon_vars (from offline SMAP M09) -! (a) reads from InCNRestart -! (b) regrids each veg type from the nearest InRestart cell -! (c) writes (73-192,193-1080) -! (d) close files -! +!2) regrids (takes hydrological initial conditions (2) writes 1:37; 66:72 +!3) writes from offline SMAP M09) (3) reads InRestart2/writes 38, 39,40=38,41:65 +!4) close files (2) close files (4) call regrid_carbon_vars (from offline SMAP M09) +! (a) reads from InCNRestart +! (b) regrids each veg type from the nearest InRestart cell +! (c) writes (73-192,193-1080) +! (d) close files +! ! ! ! OUTPUT catchcn_internal_rst will always be nc4 @@ -114,68 +114,68 @@ program mk_CatchCNRestarts ! The order of the INTERNAL STATE variables in GEOS_CatchCNGridComp ! ----------------------------------------------------------------- -! 1: BF1 -! 2: BF2 -! 3: BF3 -! 4: VGWMAX -! 5: CDCR1 -! 6: CDCR2 -! 7: PSIS -! 8: BEE -! 9: POROS -! 10: WPWET -! 11: COND -! 12: GNU -! 13: ARS1 -! 14: ARS2 -! 15: ARS3 -! 16: ARA1 -! 17: ARA2 -! 18: ARA3 -! 19: ARA4 -! 20: ARW1 -! 21: ARW2 -! 22: ARW3 -! 23: ARW4 -! 24: TSA1 -! 25: TSA2 -! 26: TSB1 -! 27: TSB2 -! 28: ATAU -! 29: BTAU +! 1: BF1 +! 2: BF2 +! 3: BF3 +! 4: VGWMAX +! 5: CDCR1 +! 6: CDCR2 +! 7: PSIS +! 8: BEE +! 9: POROS +! 10: WPWET +! 11: COND +! 12: GNU +! 13: ARS1 +! 14: ARS2 +! 15: ARS3 +! 16: ARA1 +! 17: ARA2 +! 18: ARA3 +! 19: ARA4 +! 20: ARW1 +! 21: ARW2 +! 22: ARW3 +! 23: ARW4 +! 24: TSA1 +! 25: TSA2 +! 26: TSB1 +! 27: TSB2 +! 28: ATAU +! 29: BTAU ! 30-33: ITY * NUM_VEG ! 34-37: FVEG * NUM_VEG -! 38: ((TC (n,i),n=1,n_catd),i=1,4) -! 39: ((QC (n,i),n=1,n_catd),i=1,4) -! 40: ((TG (n,i),n=1,n_catd),i=1,4) -! 41: CAPAC -! 42: CATDEF -! 43: RZEXC -! 44: SRFEXC -! 45: GHTCNT1 -! 46: GHTCNT2 -! 47: GHTCNT3 -! 48: GHTCNT4 -! 49: GHTCNT5 -! 50: GHTCNT6 -! 51: TSURF -! 52: WESNN1 -! 53: WESNN2 -! 54: WESNN3 -! 55: HTSNNN1 -! 56: HTSNNN2 -! 57: HTSNNN3 -! 58: SNDZN1 -! 59: SNDZN2 -! 60: SNDZN3 -! 61: ((CH (n,i),n=1,n_catd),i=1,4) -! 62: ((CM (n,i),n=1,n_catd),i=1,4) -! 63: ((CQ (n,i),n=1,n_catd),i=1,4) -! 64: ((FR (n,i),n=1,n_catd),i=1,4) -! 65: ((WW (n,i),n=1,n_catd),i=1,4) -! 66: cat_id -! 67: ndep -! 68: cli_t2m +! 38: ((TC (n,i),n=1,n_catd),i=1,4) +! 39: ((QC (n,i),n=1,n_catd),i=1,4) +! 40: ((TG (n,i),n=1,n_catd),i=1,4) +! 41: CAPAC +! 42: CATDEF +! 43: RZEXC +! 44: SRFEXC +! 45: GHTCNT1 +! 46: GHTCNT2 +! 47: GHTCNT3 +! 48: GHTCNT4 +! 49: GHTCNT5 +! 50: GHTCNT6 +! 51: TSURF +! 52: WESNN1 +! 53: WESNN2 +! 54: WESNN3 +! 55: HTSNNN1 +! 56: HTSNNN2 +! 57: HTSNNN3 +! 58: SNDZN1 +! 59: SNDZN2 +! 60: SNDZN3 +! 61: ((CH (n,i),n=1,n_catd),i=1,4) +! 62: ((CM (n,i),n=1,n_catd),i=1,4) +! 63: ((CQ (n,i),n=1,n_catd),i=1,4) +! 64: ((FR (n,i),n=1,n_catd),i=1,4) +! 65: ((WW (n,i),n=1,n_catd),i=1,4) +! 66: cat_id +! 67: ndep +! 68: cli_t2m ! 69: BGALBVR ! 70: BGALBVF ! 71: BGALBNR @@ -209,7 +209,7 @@ program mk_CatchCNRestarts ! initialize to non-MPI values - integer :: myid=0, numprocs=1, mpierr, mpistatus(MPI_STATUS_SIZE) + integer :: myid=0, numprocs=1, mpierr, mpistatus(MPI_STATUS_SIZE) logical :: root_proc=.true. real, parameter :: nan = O'17760000000' @@ -223,14 +223,14 @@ program mk_CatchCNRestarts integer, parameter :: ntiles_cn = 1684725 character(len=300), parameter :: & InCNRestart = '/discover/nobackup/projects/gmao/ssd/land/l_data/LandRestarts_for_Regridding/CatchCN/M09/20151231/catchcn_internal_rst', & - InCNTilFile = '/discover/nobackup/projects/gmao/bcs_shared/legacy_bcs/Icarus-NLv3/Icarus-NLv3_EASE/SMAP_EASEv2_M09/SMAP_EASEv2_M09_3856x1624.til' + InCNTilFile = '/discover/nobackup/projects/gmao/bcs_shared/legacy_bcs/Icarus-NLv3/Icarus-NLv3_EASE/SMAP_EASEv2_M09/SMAP_EASEv2_M09_3856x1624.til' character(len=256), parameter :: CatNames (57) = & (/'BF1 ','BF2 ','BF3 ','VGWMAX ','CDCR1 ', & 'CDCR2 ','PSIS ','BEE ','POROS ','WPWET ', & 'COND ','GNU ','ARS1 ','ARS2 ','ARS3 ', & 'ARA1 ','ARA2 ','ARA3 ','ARA4 ','ARW1 ', & - 'ARW2 ','ARW3 ','ARW4 ','TSA1 ','TSA2 ', & + 'ARW2 ','ARW3 ','ARW4 ','TSA1 ','TSA2 ', & 'TSB1 ','TSB2 ','ATAU ','BTAU ','OLD_ITY', & 'TC ','QC ','CAPAC ','CATDEF ','RZEXC ', & 'SRFEXC ','GHTCNT1','GHTCNT2','GHTCNT3','GHTCNT4', & @@ -244,7 +244,7 @@ program mk_CatchCNRestarts 'CDCR2 ','PSIS ','BEE ','POROS ','WPWET ', & 'COND ','GNU ','ARS1 ','ARS2 ','ARS3 ', & 'ARA1 ','ARA2 ','ARA3 ','ARA4 ','ARW1 ', & - 'ARW2 ','ARW3 ','ARW4 ','TSA1 ','TSA2 ', & + 'ARW2 ','ARW3 ','ARW4 ','TSA1 ','TSA2 ', & 'TSB1 ','TSB2 ','ATAU ','BTAU ','ITY ', & 'FVG ','TC ','QC ','TG ','CAPAC ', & 'CATDEF ','RZEXC ','SRFEXC ','GHTCNT1','GHTCNT2', & @@ -254,7 +254,7 @@ program mk_CatchCNRestarts 'CM ','CQ ','FR ','WW ','TILE_ID', & 'NDEP ','CLI_T2M','BGALBVR','BGALBVF','BGALBNR', & 'BGALBNF','CNCOL ','CNPFT ' /) - + integer :: AGCM_YY, AGCM_MM, AGCM_DD, AGCM_HR character*256 :: DataDir="OutData/clsm/" @@ -272,28 +272,28 @@ program mk_CatchCNRestarts type(FileMetadata) :: InCfg,OutCfg integer, allocatable :: low_ind(:), upp_ind(:), nt_local (:) character(256) :: Iam = "mk_CatchCNRestarts" - + call init_MPI() call MPI_Info_create(infos, STATUS) ; VERIFY_(STATUS) call MPI_Info_set(infos, "romio_cb_read", "automatic", STATUS) ; VERIFY_(STATUS) call MPI_Barrier(MPI_COMM_WORLD, STATUS) - + !----------------------------------------------------- ! Read command-line arguments, file names (inRestart, - ! inTile, outTile), determine file format, and BCs - ! availability. + ! inTile, outTile), determine file format, and BCs + ! availability. !----------------------------------------------------- - call ESMF_Initialize(LogKindFlag=ESMF_LOGKIND_NONE) - + call ESMF_Initialize(LogKindFlag=ESMF_LOGKIND_NONE) + I = iargc() - + if( I /=5 ) then print *, "Wrong Number of arguments: ", i print *, trim(Usage) stop end if - + do n=1,I call getarg(n,arg(n)) enddo @@ -311,11 +311,11 @@ program mk_CatchCNRestarts call exit(2) end if - ! Are BCs data available? + ! Are BCs data available? ! ----------------------- - + inquire(file=trim(DataDir)//"CLM_veg_typs_fracs",exist=havedata) - + ! Reading restart time stamp and constructing daylength array ! ----------------------------------------------------------- read (RestartTime (1: 4), '(i4)', IOSTAT = K) AGCM_YY ; VERIFY_(K) @@ -324,87 +324,87 @@ program mk_CatchCNRestarts read (RestartTime (9:10), '(i2)', IOSTAT = K) AGCM_HR ; VERIFY_(K) MPI_PROC0 : if (root_proc) then - + ! Read Output/Input .til files - call ReadTileFile_RealLatLon(OutTileFile, ntiles, xlon=lono, xlat=lato) + call ReadTileFile_RealLatLon(OutTileFile, ntiles, xlon=lono, xlat=lato) call ReadTileFile_RealLatLon(InTileFile,ntiles_in,xlon=loni, xlat=lati) allocate(Id (ntiles)) - + ! ------------------------------------------------ ! create output catchcn_internal_rst in nc4 format ! ------------------------------------------------ - - call InFmt%open('/discover/nobackup/projects/gmao/ssd/land/l_data/LandRestarts_for_Regridding/CatchCN/catchcn_internal_dummy',pFIO_READ, __RC__) + + call InFmt%open('/discover/nobackup/projects/gmao/ssd/land/l_data/LandRestarts_for_Regridding/CatchCN/catchcn_internal_dummy',pFIO_READ, __RC__) InCfg=InFmt%read( __RC__) call MAPL_IOCountNonDimVars(InCfg,nvars, __RC__) call MAPL_IOChangeRes(InCfg,OutCfg,(/'tile'/),(/ntiles/),__RC__) - i = index(InRestart,'/',back=.true.) + i = index(InRestart,'/',back=.true.) OutFileName = "OutData/"//trim(InRestart(i+1:)) call OutFmt%create(OutFileName, __RC__) call OutFmt%write(OutCfg, __RC__) i1= index(InRestart,'/',back=.true.) i = index(InRestart,'catchcn',back=.true.) - + endif MPI_PROC0 - + call MPI_Barrier(MPI_COMM_WORLD, mpierr) - call MPI_BCAST(NTILES , 1, MPI_INTEGER , 0,MPI_COMM_WORLD,mpierr) ; VERIFY_(mpierr) + call MPI_BCAST(NTILES , 1, MPI_INTEGER , 0,MPI_COMM_WORLD,mpierr) ; VERIFY_(mpierr) call MPI_BCAST(NTILES_IN, 1, MPI_INTEGER , 0,MPI_COMM_WORLD,mpierr) ; VERIFY_(mpierr) - + HAVE_DATA :if(havedata) then ! OPT3 ! ---- ! Get number of catchments ! ------------------------ - + open(unit=22, & file=trim(DataDir)//"catchment.def",status='old',form='formatted') - + read(22,*) ncatch - + close(22) - + if(ncatch /= ntiles) then print *, "Number of tiles in BCs data, ",Ncatch," does not match number in OutTile file ", NTILES print *, trim(OutTileFile) stop endif - + if(ntiles_in /= ntiles) then print *, "HAVEDATA : Number of tiles in InTileFile, ",NTILES_IN," does not match number in OutTileFile ", NTILES print *, trim ( InTileFile) print *, trim (OutTileFile) stop endif - - allocate (Id(ntiles)) - + + allocate (Id(ntiles)) + do i = 1,ntiles id (i) = i ! Just one-to-one mapping end do RegridSMAP = .true. - + !OPT3 (Reading/writing BCs/hydrological variables) - + if (root_proc) call read_bcs_data (ntiles, SURFLAY, OutFmt, InRestart, __RC__) - + else ! What is the format of the InRestart file? ! ----------------------------------------- call MAPL_NCIOGetFileType(InRestart, filetype, __RC__) - + if (filetype /= 0) then - + ! OPT2 (filetype =/ 0: a binary file must be a catch_internal_rst) ! ---- - clsmcn_file = .false. + clsmcn_file = .false. open(unit=InUnit,FILE=InRestart,form='unformatted', & - status='old',convert='little_endian') - + status='old',convert='little_endian') + else ! filetype = 0 : nc4, could be catch_internal_rst or catchcn_internal_rst @@ -416,8 +416,8 @@ program mk_CatchCNRestarts call InFmt%close() call MAPL_IOCountNonDimVars(InCfg,nvars) - - if(nVars == 57) clsmcn_file = .false. + + if(nVars == 57) clsmcn_file = .false. endif @@ -429,49 +429,49 @@ program mk_CatchCNRestarts ! ---------------------------------------------------- ! INPUT/OUTPUT Mapping since InTileFile =/ OutTileFile ! ---------------------------------------------------- - + if(myid > 0) allocate (loni (1:ntiles_in)) if(myid > 0) allocate (lati (1:ntiles_in)) - + allocate (tid_in (1:ntiles_in)) do n = 1, NTILES_IN tid_in (n) = n end do - + call MPI_BCAST(loni,ntiles_in,MPI_REAL,0,MPI_COMM_WORLD,mpierr) call MPI_BCAST(lati,ntiles_in,MPI_REAL,0,MPI_COMM_WORLD,mpierr) call MPI_Barrier(MPI_COMM_WORLD, mpierr) - + ! Now mapping (Id) ! ---------------- - + allocate (Id(ntiles)) ! Id contains corresponding InTileID after mapping InTiles on to OutTile ! call GetIds(loni,lati,lono,lato,zoom,Id) allocate(low_ind ( numprocs)) allocate(upp_ind ( numprocs)) allocate(nt_local( numprocs)) low_ind (:) = 1 - upp_ind (:) = NTILES - nt_local(:) = NTILES - + upp_ind (:) = NTILES + nt_local(:) = NTILES + ! Domain decomposition ! -------------------- - - if (numprocs > 1) then + + if (numprocs > 1) then do i = 1, numprocs - 1 - upp_ind(i) = low_ind(i) + (ntiles/numprocs) - 1 + upp_ind(i) = low_ind(i) + (ntiles/numprocs) - 1 low_ind(i+1) = upp_ind(i) + 1 nt_local(i) = upp_ind(i) - low_ind(i) + 1 end do nt_local(numprocs) = upp_ind(numprocs) - low_ind(numprocs) + 1 endif - + ! Get out tile lat/lots from root - + allocate (id_loc (nt_local (myid + 1))) allocate (lonn (nt_local (myid + 1))) - allocate (latt (nt_local (myid + 1))) - + allocate (latt (nt_local (myid + 1))) + do i = 1, numprocs if((I == 1).and.(myid == 0)) then lonn(:) = lono(low_ind(i) : upp_ind(i)) @@ -479,23 +479,23 @@ program mk_CatchCNRestarts else if (I > 1) then if(I-1 == myid) then ! receiving from root - + call MPI_RECV(lonn,nt_local(i) , MPI_REAL, 0,995,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) call MPI_RECV(latt,nt_local(i) , MPI_REAL, 0,994,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) else if (myid == 0) then ! root sends - + call MPI_ISend(lono(low_ind(i) : upp_ind(i)),nt_local(i),MPI_REAL,i-1,995,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) + call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) call MPI_ISend(lato(low_ind(i) : upp_ind(i)),nt_local(i),MPI_REAL,i-1,994,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) + call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) endif endif end do - + call GetIds(loni,lati,lonn,latt,id_loc, tid_in) call MPI_Barrier(MPI_COMM_WORLD, mpierr) - + do i = 1, numprocs if((I == 1).and.(myid == 0)) then id(low_ind(i) : upp_ind(i)) = Id_loc(:) @@ -503,16 +503,16 @@ program mk_CatchCNRestarts if(I-1 == myid) then ! send to root call MPI_ISend(id_loc,nt_local(i),MPI_INTEGER,0,993,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) + call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) else if (myid == 0) then ! root receives call MPI_RECV(id(low_ind(i) : upp_ind(i)),nt_local(i) , MPI_INTEGER, i-1,993,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) endif endif end do - + if(root_proc) deallocate (lono, lato,lonn,latt, tid_in) - + deallocate (loni,lati) @@ -520,7 +520,7 @@ program mk_CatchCNRestarts else - call regrid_hyd_vars (NTILES, OutFmt) + call regrid_hyd_vars (NTILES, OutFmt) ! OPT2 ! ---- @@ -535,68 +535,68 @@ program mk_CatchCNRestarts ! endif NC4ORBIN endif CATCHCN - + endif HAVE_DATA if (root_proc) then - + ! ----------------- ! BEGIN THE PROCESS ! ----------------- - + print *, " " print *, "**********************************************************************" print *, " " print *, "mk_CatchCNRestarts Configuration" print *, "--------------------------------" - print *, " " - print '(A22, i4.4,i2.2,i2.2,i2.2)', " Restart Time :",AGCM_YY,AGCM_MM,AGCM_DD,AGCM_HR + print *, " " + print '(A22, i4.4,i2.2,i2.2,i2.2)', " Restart Time :",AGCM_YY,AGCM_MM,AGCM_DD,AGCM_HR print *, 'SURFLAY : ',SURFLAY print *, 'Have BCs data : ',havedata print *, "# of tiles in InTile : ",ntiles_in print *, "# of tiles in OutTile: ",ntiles - - if(clsmcn_file) then + + if(clsmcn_file) then print *,"InRestart is from : Catchment-carbon AGCM simulation" else InRestart = trim(InCNRestart) print *,"InRestart is from : offline SMAP_EASEv2_M09" endif - + print *, "InRestart filename : ",trim(InRestart) print *, "OutRestart filename : ",trim(OutFileName) print *, "OutRestart file fmt : nc4" print *, " " print *, "**********************************************************************" print *, " " - + endif - + call MPI_BCAST(OutFileName , 256, MPI_CHARACTER, 0,MPI_COMM_WORLD,mpierr) call MPI_Barrier(MPI_COMM_WORLD, mpierr) - + if (RegridSMAP) then ntiles_in = ntiles_cn - !OPT3 (carbon variables from offline SMAP M09) - call regrid_carbon_vars (NTILES,AGCM_YY,AGCM_MM,AGCM_DD,AGCM_HR, OutFileName, OutTileFile) - ! call regrid_carbon_vars_omp (NTILES,AGCM_YY,AGCM_MM,AGCM_DD,AGCM_HR, OutFileName, OutTileFile) - + !OPT3 (carbon variables from offline SMAP M09) + call regrid_carbon_vars (NTILES,AGCM_YY,AGCM_MM,AGCM_DD,AGCM_HR, OutFileName, OutTileFile) + ! call regrid_carbon_vars_omp (NTILES,AGCM_YY,AGCM_MM,AGCM_DD,AGCM_HR, OutFileName, OutTileFile) + endif call MPI_BARRIER( MPI_COMM_WORLD, mpierr) call ESMF_Finalize(endflag=ESMF_END_KEEPMPI) call MPI_FINALIZE(mpierr) - + contains ! ***************************************************************************** - + SUBROUTINE read_bcs_data (ntiles, SURFLAY, OutFmt, InRestart, rc) ! This subroutine : ! 1) reads BCs from BCSDIR and hydrological varables from InRestart. ! InRestart is a catchcn_internal_rst nc4 file. ! - ! 2) writes out BCs and hydrological variables in catchcn_internal_rst (1:72). + ! 2) writes out BCs and hydrological variables in catchcn_internal_rst (1:72). ! output catchcn_internal_rst is nc4. implicit none @@ -607,16 +607,16 @@ SUBROUTINE read_bcs_data (ntiles, SURFLAY, OutFmt, InRestart, rc) integer, optional, intent(out) :: rc real, allocatable :: CLMC_pf1(:), CLMC_pf2(:), CLMC_sf1(:), CLMC_sf2(:) - real, allocatable :: CLMC_pt1(:), CLMC_pt2(:), CLMC_st1(:), CLMC_st2(:) + real, allocatable :: CLMC_pt1(:), CLMC_pt2(:), CLMC_st1(:), CLMC_st2(:) real, allocatable :: BF1(:), BF2(:), BF3(:), VGWMAX(:) - real, allocatable :: CDCR1(:), CDCR2(:), PSIS(:), BEE(:) + real, allocatable :: CDCR1(:), CDCR2(:), PSIS(:), BEE(:) real, allocatable :: POROS(:), WPWET(:), COND(:), GNU(:) real, allocatable :: ARS1(:), ARS2(:), ARS3(:) 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 :: NDEP(:), BVISDR(:), BVISDF(:), BNIRDR(:), BNIRDF(:) + real, allocatable :: NDEP(:), BVISDR(:), BVISDF(:), BNIRDR(:), BNIRDF(:) real, allocatable :: T2(:), var1(:) integer, allocatable :: ity(:) character*256 :: vname @@ -626,10 +626,10 @@ SUBROUTINE read_bcs_data (ntiles, SURFLAY, OutFmt, InRestart, rc) logical :: file_exists type(Netcdf4_Fileformatter) :: InFmt,CatchCNFmt, CatchFmt integer :: status - + allocate ( BF1(ntiles), BF2 (ntiles), BF3(ntiles) ) - allocate (VGWMAX(ntiles), CDCR1(ntiles), CDCR2(ntiles) ) - allocate ( PSIS(ntiles), BEE(ntiles), POROS(ntiles) ) + allocate (VGWMAX(ntiles), CDCR1(ntiles), CDCR2(ntiles) ) + allocate ( PSIS(ntiles), BEE(ntiles), POROS(ntiles) ) allocate ( WPWET(ntiles), COND(ntiles), GNU(ntiles) ) allocate ( ARS1(ntiles), ARS2(ntiles), ARS3(ntiles) ) allocate ( ARA1(ntiles), ARA2(ntiles), ARA3(ntiles) ) @@ -638,7 +638,7 @@ SUBROUTINE read_bcs_data (ntiles, SURFLAY, OutFmt, InRestart, rc) allocate ( TSA2(ntiles), TSB1(ntiles), TSB2(ntiles) ) allocate ( ATAU2(ntiles), BTAU2(ntiles), DP2BR(ntiles) ) allocate (BVISDR(ntiles), BVISDF(ntiles), BNIRDR(ntiles) ) - allocate (BNIRDF(ntiles), T2(ntiles), NDEP(ntiles) ) + allocate (BNIRDF(ntiles), T2(ntiles), NDEP(ntiles) ) allocate ( ity(ntiles), rity(ntiles), CanopH(ntiles)) allocate (CLMC_pf1(ntiles), CLMC_pf2(ntiles), CLMC_sf1(ntiles)) allocate (CLMC_sf2(ntiles), CLMC_pt1(ntiles), CLMC_pt2(ntiles)) @@ -704,20 +704,20 @@ SUBROUTINE read_bcs_data (ntiles, SURFLAY, OutFmt, InRestart, rc) call MAPL_VarRead(CatchCNFmt,'FVG',CLMC_sf2,offset1=4, __RC__) ! 37 call CatchFmt%close() call CatchCNFmt%close() - + 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') @@ -725,27 +725,27 @@ SUBROUTINE read_bcs_data (ntiles, SURFLAY, OutFmt, InRestart, rc) 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') @@ -755,7 +755,7 @@ SUBROUTINE read_bcs_data (ntiles, SURFLAY, OutFmt, InRestart, rc) CLOSE (26, STATUS = 'KEEP') CLOSE (27, STATUS = 'KEEP') CLOSE (28, STATUS = 'KEEP') - + endif do n=1,ntiles @@ -764,26 +764,26 @@ SUBROUTINE read_bcs_data (ntiles, SURFLAY, OutFmt, InRestart, rc) 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 + zdep2 = 0.75*zdep3 end if - + zdep1=20. zmet=zdep3/1000. - + term1=-1.+((PSIS(n)-zmet)/PSIS(n))**((BEE(n)-1.)/BEE(n)) term2=PSIS(n)*BEE(n)/(BEE(n)-1) - - VGWMAX(n) = POROS(n)*zdep2 - CDCR1(n) = 1000.*POROS(n)*(zmet-(-term2*term1)) + + VGWMAX(n) = POROS(n)*zdep2 + CDCR1(n) = 1000.*POROS(n)*(zmet-(-term2*term1)) CDCR2(n) = (1.-WPWET(n))*POROS(n)*zdep3 ! convert % to fractions - + CLMC_pf1(n) = CLMC_pf1(n) / 100. CLMC_pf2(n) = CLMC_pf2(n) / 100. CLMC_sf1(n) = CLMC_sf1(n) / 100. @@ -794,12 +794,12 @@ SUBROUTINE read_bcs_data (ntiles, SURFLAY, OutFmt, InRestart, rc) fvg(3) = CLMC_sf1(n) fvg(4) = CLMC_sf2(n) - BARE = 1. + BARE = 1. DO NV = 1, NVEG - BARE = BARE - FVG(NV)! subtract vegetated fractions + BARE = BARE - FVG(NV)! subtract vegetated fractions END DO - + if (BARE /= 0.) THEN IB = MAXLOC(FVG(:),1) FVG (IB) = FVG(IB) + BARE ! This also corrects all cases sum ne 0. @@ -809,11 +809,11 @@ SUBROUTINE read_bcs_data (ntiles, SURFLAY, OutFmt, InRestart, rc) CLMC_pf2(n) = fvg(2) CLMC_sf1(n) = fvg(3) CLMC_sf2(n) = fvg(4) - + enddo - + NDEP = NDEP * 1.e-9 - + ! prevent trivial fractions ! ------------------------- do n = 1,ntiles @@ -826,7 +826,7 @@ SUBROUTINE read_bcs_data (ntiles, SURFLAY, OutFmt, InRestart, rc) CLMC_pf1(n) = CLMC_pf1(n) + CLMC_pf2(n) CLMC_pf2(n) = 0. endif - + if(CLMC_sf1(n) <= 1.e-4) then if(CLMC_sf2(n) > 1.e-4) then CLMC_sf2(n) = CLMC_sf2(n) + CLMC_sf1(n) @@ -853,15 +853,15 @@ SUBROUTINE read_bcs_data (ntiles, SURFLAY, OutFmt, InRestart, rc) CLMC_sf2(n) = 0. endif end do - + ! Now writing BCs (from BCSDIR) and regridded hydrological variables 1-72 ! ----------------------------------------------------------------------- call InFmt%open(InRestart,pFIO_READ, __RC__) - - call MAPL_VarWrite(OutFmt,trim(CarbNames(1)),BF1) ! 1 + + call MAPL_VarWrite(OutFmt,trim(CarbNames(1)),BF1) ! 1 call MAPL_VarWrite(OutFmt,trim(CarbNames(2)),BF2) ! 2 call MAPL_VarWrite(OutFmt,trim(CarbNames(3)),BF3) ! 3 call MAPL_VarWrite(OutFmt,trim(CarbNames(4)),VGWMAX) ! 4 @@ -898,12 +898,12 @@ SUBROUTINE read_bcs_data (ntiles, SURFLAY, OutFmt, InRestart, rc) call MAPL_VarWrite(OutFmt,'FVG',CLMC_pf2,offset1=2) ! 35 call MAPL_VarWrite(OutFmt,'FVG',CLMC_sf1,offset1=3) ! 36 call MAPL_VarWrite(OutFmt,'FVG',CLMC_sf2,offset1=4) ! 37 - - allocate(var1(ntiles)) - ! TC QC TG - - do n = 38,40 + allocate(var1(ntiles)) + + ! TC QC TG + + do n = 38,40 if(n == 38) vname = 'TC' if(n == 39) vname = 'QC' if(n == 40) vname = 'TG' @@ -912,14 +912,14 @@ SUBROUTINE read_bcs_data (ntiles, SURFLAY, OutFmt, InRestart, rc) call MAPL_VarWrite(OutFmt,vname,var1 ,offset1=j) ! 38-40 end do end do - + ! CAPAC CATDEF RZEXC SRFEXC ... SNDZN3 - + do n=41,60 call MAPL_VarRead ( InFmt,trim(CarbNames(n-6)),var1, __RC__) call MAPL_VarWrite(OutFmt,trim(CarbNames(n-6)),var1) ! 41-60 enddo - + ! CH CM CQ FR WW var1 = 0. @@ -928,24 +928,24 @@ SUBROUTINE read_bcs_data (ntiles, SURFLAY, OutFmt, InRestart, rc) if(n == 64) var1 = 0.25 if(n == 65) var1 = 0.1 do j = 1,4 - + call MAPL_VarRead ( InFmt,trim(CarbNames(n-6)),var1 ,offset1=j, __RC__) call MAPL_VarWrite(OutFmt,trim(CarbNames(n-6)),var1 ,offset1=j) ! 61-65 end do end do - + do i=1,ntiles var1(i) = real(i) end do - - call MAPL_VarWrite(OutFmt,'TILE_ID',var1 ) ! 66 : cat_id - call MAPL_VarWrite(OutFmt,'NDEP' ,NDEP ) ! 67 : ndep - call MAPL_VarWrite(OutFmt,'CLI_T2M',T2 ) ! 68 : cli_t2m - call MAPL_VarWrite(OutFmt,'BGALBVR',BVISDR) ! 69 : BGALBVR - call MAPL_VarWrite(OutFmt,'BGALBVF',BVISDF) ! 70 : BGALBVF - call MAPL_VarWrite(OutFmt,'BGALBNR',BNIRDR) ! 71 : BGALBNR - call MAPL_VarWrite(OutFmt,'BGALBNF',BNIRDF) ! 72 : BGALBNF - + + call MAPL_VarWrite(OutFmt,'TILE_ID',var1 ) ! 66 : cat_id + call MAPL_VarWrite(OutFmt,'NDEP' ,NDEP ) ! 67 : ndep + call MAPL_VarWrite(OutFmt,'CLI_T2M',T2 ) ! 68 : cli_t2m + call MAPL_VarWrite(OutFmt,'BGALBVR',BVISDR) ! 69 : BGALBVR + call MAPL_VarWrite(OutFmt,'BGALBVF',BVISDF) ! 70 : BGALBVF + call MAPL_VarWrite(OutFmt,'BGALBNR',BNIRDR) ! 71 : BGALBNR + call MAPL_VarWrite(OutFmt,'BGALBNF',BNIRDF) ! 72 : BGALBNF + deallocate (var1) call InFmt%close() call OutFmt%close() @@ -956,14 +956,14 @@ SUBROUTINE read_bcs_data (ntiles, SURFLAY, OutFmt, InRestart, rc) ! open(20,file=trim("OutData/vegdyn_internal_rst"), & ! status="unknown", & ! form="unformatted",convert="little_endian") -! write(20) rity +! write(20) rity ! write(20) CanopH ! close(20) ! print *, "Wrote vegdyn_internal_restart" deallocate ( BF1, BF2, BF3 ) - deallocate (VGWMAX, CDCR1, CDCR2 ) - deallocate ( PSIS, BEE, POROS ) + deallocate (VGWMAX, CDCR1, CDCR2 ) + deallocate ( PSIS, BEE, POROS ) deallocate ( WPWET, COND, GNU ) deallocate ( ARS1, ARS2, ARS3 ) deallocate ( ARA1, ARA2, ARA3 ) @@ -972,7 +972,7 @@ SUBROUTINE read_bcs_data (ntiles, SURFLAY, OutFmt, InRestart, rc) deallocate ( TSA2, TSB1, TSB2 ) deallocate ( ATAU2, BTAU2, DP2BR ) deallocate (BVISDR, BVISDF, BNIRDR ) - deallocate (BNIRDF, T2, NDEP ) + deallocate (BNIRDF, T2, NDEP ) deallocate ( ity, rity, CanopH) deallocate (CLMC_pf1, CLMC_pf2, CLMC_sf1) deallocate (CLMC_sf2, CLMC_pt1, CLMC_pt2) @@ -980,21 +980,21 @@ SUBROUTINE read_bcs_data (ntiles, SURFLAY, OutFmt, InRestart, rc) if (present(rc)) rc = 0 !_RETURN(_SUCCESS) END SUBROUTINE read_bcs_data - + ! ***************************************************************************** - + SUBROUTINE read_catchcn_nc4 (NTILES_IN, NTILES, OutFmt, IDX, InRestart, rc) implicit none - ! Reads catchcn_internal_rst nc4 file, regrids every single variable and writes + ! Reads catchcn_internal_rst nc4 file, regrids every single variable and writes ! out catchcn_internal_rst in nc4 format. - ! This subroutine is called when BCs data are not available. + ! This subroutine is called when BCs data are not available. integer, intent (in) :: NTILES_IN, NTILES character(*), intent (in) :: InRestart type(Netcdf4_Fileformatter), intent (inout) :: OutFmt - integer, dimension (NTILES), intent (in) :: IDX + integer, dimension (NTILES), intent (in) :: IDX integer, optional, intent(out) :: rc type(Netcdf4_Fileformatter) :: InFmt type(FileMetadata) :: InCfg @@ -1011,13 +1011,13 @@ SUBROUTINE read_catchcn_nc4 (NTILES_IN, NTILES, OutFmt, IDX, InRestart, rc) call InFmt%open(InRestart,pFIO_READ, __RC__) InCfg = InFmt%read(__RC__) - + allocate (var1 (1:NTILES_IN)) allocate (var2 (1:NTILES_IN)) - allocate (TILE_ID (1:NTILES_IN)) + allocate (TILE_ID (1:NTILES_IN)) call MAPL_VarRead ( InFmt,'TILE_ID',var1, __RC__) - do n = 1, NTILES_IN + do n = 1, NTILES_IN tile_id (NINT (var1(n))) = n end do @@ -1025,19 +1025,19 @@ SUBROUTINE read_catchcn_nc4 (NTILES_IN, NTILES, OutFmt, IDX, InRestart, rc) var_iter = variables%begin() do while (var_iter /= variables%end()) - vname => var_iter%key() + vname => var_iter%key() var => var_iter%value() var_dimensions => var%get_dimensions() - + ndims = var_dimensions%size() if (ndims == 1) then call MAPL_VarRead ( InFmt,vname,var1, __RC__) var2 = var1 (tile_id) call MAPL_VarWrite(OutFmt,vname,var2(idx)) - + else if (ndims == 2) then - + dname => var%get_ith_dimension(2) dim1=InCfg%get_dimension(dname) do j=1,dim1 @@ -1045,9 +1045,9 @@ SUBROUTINE read_catchcn_nc4 (NTILES_IN, NTILES, OutFmt, IDX, InRestart, rc) var2 = var1 (tile_id) call MAPL_VarWrite(OutFmt,vname,var2(idx),offset1=j) enddo - + else if (ndims == 3) then - + dname => var%get_ith_dimension(2) dim1=InCfg%get_dimension(dname) dname => var%get_ith_dimension(3) @@ -1059,12 +1059,12 @@ SUBROUTINE read_catchcn_nc4 (NTILES_IN, NTILES, OutFmt, IDX, InRestart, rc) call MAPL_VarWrite(OutFmt,vname,var2(idx),offset1=j,offset2=i) enddo enddo - + end if call var_iter%next() enddo - + deallocate (var1, var2, tile_id) call InFmt%close() call OutFmt%close() @@ -1073,13 +1073,13 @@ SUBROUTINE read_catchcn_nc4 (NTILES_IN, NTILES, OutFmt, IDX, InRestart, rc) END SUBROUTINE read_catchcn_nc4 ! ***************************************************************************** - + SUBROUTINE regrid_carbon_vars ( & - NTILES,AGCM_YY,AGCM_MM,AGCM_DD,AGCM_HR, OutFileName, OutTileFile) + NTILES,AGCM_YY,AGCM_MM,AGCM_DD,AGCM_HR, OutFileName, OutTileFile) implicit none character (*), intent (in) :: OutTileFile, OutFileName - integer, intent (in) :: NTILES,AGCM_YY,AGCM_MM,AGCM_DD,AGCM_HR + integer, intent (in) :: NTILES,AGCM_YY,AGCM_MM,AGCM_DD,AGCM_HR real, allocatable, dimension (:) :: CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2, & CLMC_pt1, CLMC_pt2,CLMC_st1,CLMC_st2 @@ -1095,8 +1095,8 @@ SUBROUTINE regrid_carbon_vars ( & integer, allocatable, dimension (:) :: sub_tid, sub_ityp1, sub_ityp2,icl_ityp1 real , pointer, dimension (:) :: sub_lon, sub_lat, rev_dist, sub_fevg1, sub_fevg2,& lonc, latc, LATT, LONN, DAYX, long, latg, var_dum, TILE_ID, var_dum2 - real, allocatable :: var_off_col (:,:,:), var_off_pft (:,:,:,:) - real, allocatable :: var_col_out (:,:,:), var_pft_out (:,:,:,:) + real, allocatable :: var_off_col (:,:,:), var_off_pft (:,:,:,:) + real, allocatable :: var_col_out (:,:,:), var_pft_out (:,:,:,:) integer, allocatable :: low_ind(:), upp_ind(:), nt_local (:) integer :: AGCM_YYY, AGCM_MMM, AGCM_DDD, AGCM_HRR, AGCM_MI, AGCM_S, dofyr type(MAPL_SunOrbit) :: ORBIT @@ -1115,15 +1115,15 @@ SUBROUTINE regrid_carbon_vars ( & allocate(nt_local( numprocs)) low_ind (:) = 1 - upp_ind (:) = NTILES - nt_local(:) = NTILES + upp_ind (:) = NTILES + nt_local(:) = NTILES ! Domain decomposition ! -------------------- - if (numprocs > 1) then + if (numprocs > 1) then do i = 1, numprocs - 1 - upp_ind(i) = low_ind(i) + (ntiles/numprocs) - 1 + upp_ind(i) = low_ind(i) + (ntiles/numprocs) - 1 low_ind(i+1) = upp_ind(i) + 1 nt_local(i) = upp_ind(i) - low_ind(i) + 1 end do @@ -1145,9 +1145,9 @@ SUBROUTINE regrid_carbon_vars ( & allocate (latc (1:ntiles_cn)) if (root_proc) then - + ! -------------------------------------------- - ! Read exact lonn, latt from output .til file + ! Read exact lonn, latt from output .til file ! -------------------------------------------- allocate (long (ntiles)) @@ -1191,14 +1191,14 @@ SUBROUTINE regrid_carbon_vars ( & ORBIT = MAPL_SunOrbitCreateFromConfig(CF, CLOCK, .false., RC=status) VERIFY_(status) - + ! compute current daylight duration !---------------------------------- call MAPL_SunGetDaylightDuration(ORBIT,latg,dayx,currTime=CURRENT_TIME,RC=STATUS) VERIFY_(STATUS) ! --------------------------------------------- - ! Read exact lonc, latc from offline .til File + ! Read exact lonc, latc from offline .til File ! --------------------------------------------- call ReadTileFile_RealLatLon(InCNTilFile,i,xlon=lonc,xlat=latc) @@ -1227,33 +1227,33 @@ SUBROUTINE regrid_carbon_vars ( & else if (myid == 0) then ! root sends call MPI_ISend(long(low_ind(i) : upp_ind(i)),nt_local(i),MPI_REAL,i-1,995,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) + call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) call MPI_ISend(latg(low_ind(i) : upp_ind(i)),nt_local(i),MPI_REAL,i-1,994,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) + call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) endif endif end do - + if(root_proc) deallocate (long, latg) - + call MPI_BCAST(lonc,ntiles_cn,MPI_REAL,0,MPI_COMM_WORLD,mpierr) call MPI_BCAST(latc,ntiles_cn,MPI_REAL,0,MPI_COMM_WORLD,mpierr) ! Open GKW/Fzeng SMAP M09 catchcn_internal_rst and output catchcn_internal_rst ! ---------------------------------------------------------------------------- ! call MPI_Info_create(info, STATUS) - ! call MPI_Info_set(info, "romio_cb_read", "automatic", STATUS) + ! call MPI_Info_set(info, "romio_cb_read", "automatic", STATUS) ! STATUS = NF_OPEN_PAR (trim(InCNRestart),IOR(NF_NOWRITE,NF_MPIIO),MPI_COMM_WORLD, info,NCFID) ! STATUS = NF_OPEN_PAR (trim(OutFileName),IOR(NF_WRITE ,NF_MPIIO),MPI_COMM_WORLD, info,OUTID) - + STATUS = NF_OPEN_PAR (trim(OutFileName),IOR(NF_NOWRITE,NF_MPIIO),MPI_COMM_WORLD, infos,OUTID) ; VERIFY_(STATUS) ! if(root_proc) then ! STATUS = NF_OPEN (trim(OutFileName),NF_WRITE,OUTID) - ! + ! ! else ! STATUS = NF_OPEN (trim(OutFileName),NF_NOWRITE,OUTID) ! endif - ! + ! IF (STATUS .NE. NF_NOERR) CALL HANDLE_ERR(STATUS, 'OUTPUT RESTART FAILED') STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/low_ind(myid+1),1/), (/nt_local(myid+1),1/),CLMC_pt1) @@ -1264,27 +1264,27 @@ SUBROUTINE regrid_carbon_vars ( & STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/low_ind(myid+1),2/), (/nt_local(myid+1),1/),CLMC_pf2) STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/low_ind(myid+1),3/), (/nt_local(myid+1),1/),CLMC_sf1) STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/low_ind(myid+1),4/), (/nt_local(myid+1),1/),CLMC_sf2) - + if (root_proc) then - + STATUS = NF_OPEN (trim(InCNRestart),NF_NOWRITE,NCFID) IF (STATUS .NE. NF_NOERR) CALL HANDLE_ERR(STATUS, 'OFFLINE RESTART FAILED') allocate (TILE_ID (1:ntiles_cn)) - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TILE_ID' ), (/1/), (/NTILES_cn/),TILE_ID) + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TILE_ID' ), (/1/), (/NTILES_cn/),TILE_ID) do n = 1,ntiles_cn - + K = NINT (TILE_ID (n)) STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ITY'), (/n,1/), (/1,4/),ityp_offl(k,:)) STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'FVG'), (/n,1/), (/1,4/),fveg_offl(k,:)) - + tid_offl (n) = n - + do nv = 1,nveg if(ityp_offl(k,nv)<0 .or. ityp_offl(k,nv)>npft) stop 'ityp' - if(fveg_offl(k,nv)<0..or. fveg_offl(k,nv)>1.00001) stop 'fveg' + if(fveg_offl(k,nv)<0..or. fveg_offl(k,nv)>1.00001) stop 'fveg' end do if((ityp_offl(k,3) == 0).and.(ityp_offl(k,4) == 0)) then @@ -1294,36 +1294,36 @@ SUBROUTINE regrid_carbon_vars ( & ityp_offl(k,3) = ityp_offl(k,2) endif endif - + if((ityp_offl(k,1) == 0).and.(ityp_offl(k,2) /= 0)) ityp_offl(k,1) = ityp_offl(k,2) if((ityp_offl(k,2) == 0).and.(ityp_offl(k,1) /= 0)) ityp_offl(k,2) = ityp_offl(k,1) if((ityp_offl(k,3) == 0).and.(ityp_offl(k,4) /= 0)) ityp_offl(k,3) = ityp_offl(k,4) if((ityp_offl(k,4) == 0).and.(ityp_offl(k,3) /= 0)) ityp_offl(k,4) = ityp_offl(k,3) - + end do - + endif - + call MPI_BCAST(tid_offl ,size(tid_offl ),MPI_INTEGER,0,MPI_COMM_WORLD,mpierr) call MPI_BCAST(ityp_offl,size(ityp_offl),MPI_REAL ,0,MPI_COMM_WORLD,mpierr) - call MPI_BCAST(fveg_offl,size(fveg_offl),MPI_REAL ,0,MPI_COMM_WORLD,mpierr) + call MPI_BCAST(fveg_offl,size(fveg_offl),MPI_REAL ,0,MPI_COMM_WORLD,mpierr) ! -------------------------------------------------------------------------------- ! Here we create transfer index array to map offline restarts to output tile space - ! -------------------------------------------------------------------------------- + ! -------------------------------------------------------------------------------- call GetIds(lonc,latc,lonn,latt,id_loc, tid_offl, & CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2, CLMC_pt1, CLMC_pt2,CLMC_st1,CLMC_st2, & fveg_offl, ityp_offl) deallocate (CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2, CLMC_pt1, CLMC_pt2,CLMC_st1,CLMC_st2,lonc,latc,lonn,latt) - + ! update id_glb in root if(root_proc) then allocate (id_glb (ntiles,4)) allocate (id_vec (ntiles)) endif - + do nv = 1, nveg call MPI_Barrier(MPI_COMM_WORLD, STATUS) ! call MPI_GATHERV( & @@ -1338,24 +1338,24 @@ SUBROUTINE regrid_carbon_vars ( & if(I-1 == myid) then ! send to root call MPI_ISend(id_loc(:,nv),nt_local(i),MPI_INTEGER,0,993,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) + call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) else if (myid == 0) then ! root receives call MPI_RECV(id_vec(low_ind(i) : upp_ind(i)),nt_local(i) , MPI_INTEGER, i-1,993,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) endif endif end do - + if(root_proc) id_glb (:,nv) = id_vec - + end do - + call MPI_Barrier(MPI_COMM_WORLD, STATUS) STATUS = NF_CLOSE (OutID) ! write out regridded carbon variables if(root_proc) then - + STATUS = NF_OPEN (trim(OutFileName),NF_WRITE,OUTID) ; VERIFY_(STATUS) allocate (CLMC_pf1(NTILES)) allocate (CLMC_pf2(NTILES)) @@ -1379,28 +1379,28 @@ SUBROUTINE regrid_carbon_vars ( & allocate (var_off_col (1: NTILES_CN, 1 : nzone,1 : var_col)) allocate (var_off_pft (1: NTILES_CN, 1 : nzone,1 : nveg, 1 : var_pft)) - + allocate (var_col_out (1: NTILES, 1 : nzone,1 : var_col)) - allocate (var_pft_out (1: NTILES, 1 : nzone,1 : nveg, 1 : var_pft)) + allocate (var_pft_out (1: NTILES, 1 : nzone,1 : nveg, 1 : var_pft)) i = 1 do nv = 1,VAR_COL do nz = 1,nzone STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CNCOL'), (/1,i/), (/NTILES_CN,1 /),VAR_DUM2) do k = 1, NTILES_CN - var_off_col(TILE_ID(K), nz,nv) = VAR_DUM2(K) + var_off_col(int(TILE_ID(K)), nz,nv) = VAR_DUM2(K) end do i = i + 1 end do end do - + i = 1 do iv = 1,VAR_PFT do nv = 1,nveg do nz = 1,nzone STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CNPFT'), (/1,i/), (/NTILES_CN,1 /),VAR_DUM2) do k = 1, NTILES_CN - var_off_pft(TILE_ID(K), nz,nv,iv) = VAR_DUM2(K) + var_off_pft(int(TILE_ID(K)), nz,nv,iv) = VAR_DUM2(K) end do i = i + 1 end do @@ -1409,9 +1409,9 @@ SUBROUTINE regrid_carbon_vars ( & var_col_out = 0. var_pft_out = NaN - - where(isnan(var_off_pft)) var_off_pft = 0. - where(var_off_pft /= var_off_pft) var_off_pft = 0. + + where(isnan(var_off_pft)) var_off_pft = 0. + where(var_off_pft /= var_off_pft) var_off_pft = 0. OUT_TILE : DO N = 1, NTILES @@ -1431,39 +1431,39 @@ SUBROUTINE regrid_carbon_vars ( & if (nv == 2) fveg_new = CLMC_pf2(n) if (nv == 3) ityp_new = CLMC_st1(n) if (nv == 3) fveg_new = CLMC_sf1(n) - if (nv == 4) ityp_new = CLMC_st2(n) + if (nv == 4) ityp_new = CLMC_st2(n) if (nv == 4) fveg_new = CLMC_sf2(n) - + if (fveg_new > fmin) then offl_cell = Id_glb(n,nv) - + if(ityp_new == ityp_offl (offl_cell,nv) .and. fveg_offl (offl_cell,nv)> fmin) then - iv = nv ! same type fraction (primary of secondary) + iv = nv ! same type fraction (primary of secondary) else if(ityp_new == ityp_offl (offl_cell,nx) .and. fveg_offl (offl_cell,nx)> fmin) then iv = nx ! not same fraction - else if(iclass(ityp_new)==iclass(ityp_offl(offl_cell,nv)) .and. fveg_offl (offl_cell,nv)> fmin) then + else if(iclass(ityp_new)==iclass(int(ityp_offl(offl_cell,nv))) .and. fveg_offl (offl_cell,nv)> fmin) then iv = nv ! primary, other type (same class) else if(fveg_offl (offl_cell,nx)> fmin) then iv = nx ! secondary, other type (same class) endif - + ! Get col and pft variables for the Id_glb(nv) grid cell from offline catchcn_internal_rst ! ---------------------------------------------------------------------------------------- - - ! call NCDF_reshape_getOput (NCFID,Id_glb(n,nv),var_off_col,var_off_pft,.true.) - - var_pft_out (n,:,nv,:) = var_off_pft(Id_glb(n,nv), :,iv,:) + + ! call NCDF_reshape_getOput (NCFID,Id_glb(n,nv),var_off_col,var_off_pft,.true.) + + var_pft_out (n,:,nv,:) = var_off_pft(Id_glb(n,nv), :,iv,:) var_col_out (n,:,:) = var_col_out(n,:,:) + fveg_new * var_off_col(Id_glb(n,nv), :,:) ! gkw: column state simple weighted mean; ! could use "woody" fraction? - + ! Check whether var_pft_out is realistic do nz = 1, nzone do j = 1, VAR_PFT - if (isnan(var_pft_out (n, nz,nv,j))) print *,j,nv,nz,n,var_pft_out (n, nz,nv,j),fveg_new + if (isnan(var_pft_out (n, nz,nv,j))) print *,j,nv,nz,n,var_pft_out (n, nz,nv,j),fveg_new !if(isnan(var_pft_out (n, nz,nv,69))) var_pft_out (n, nz,nv,69) = 1.e-6 - !if(isnan(var_pft_out (n, nz,nv,70))) var_pft_out (n, nz,nv,70) = 1.e-6 + !if(isnan(var_pft_out (n, nz,nv,70))) var_pft_out (n, nz,nv,70) = 1.e-6 !if(isnan(var_pft_out (n, nz,nv,73))) var_pft_out (n, nz,nv,73) = 1.e-6 - !if(isnan(var_pft_out (n, nz,nv,74))) var_pft_out (n, nz,nv,74) = 1.e-6 + !if(isnan(var_pft_out (n, nz,nv,74))) var_pft_out (n, nz,nv,74) = 1.e-6 end do end do endif @@ -1472,34 +1472,34 @@ SUBROUTINE regrid_carbon_vars ( & ! reset carbon if negative < 10g ! ------------------------ - + NZLOOP : do nz = 1, nzone if(var_col_out (n, nz,14) < 10.) then - var_col_out(n, nz, 1) = max(var_col_out(n, nz, 1), 0.) - var_col_out(n, nz, 2) = max(var_col_out(n, nz, 2), 0.) - var_col_out(n, nz, 3) = max(var_col_out(n, nz, 3), 0.) - var_col_out(n, nz, 4) = max(var_col_out(n, nz, 4), 0.) - var_col_out(n, nz, 5) = max(var_col_out(n, nz, 5), 0.) - var_col_out(n, nz,10) = max(var_col_out(n, nz,10), 0.) - var_col_out(n, nz,11) = max(var_col_out(n, nz,11), 0.) - var_col_out(n, nz,12) = max(var_col_out(n, nz,12), 0.) - var_col_out(n, nz,13) = max(var_col_out(n, nz,13),10.) ! soil4c - var_col_out(n, nz,14) = max(var_col_out(n, nz,14), 0.) - var_col_out(n, nz,15) = max(var_col_out(n, nz,15), 0.) - var_col_out(n, nz,16) = max(var_col_out(n, nz,16), 0.) - var_col_out(n, nz,17) = max(var_col_out(n, nz,17), 0.) - var_col_out(n, nz,18) = max(var_col_out(n, nz,18), 0.) - var_col_out(n, nz,19) = max(var_col_out(n, nz,19), 0.) - var_col_out(n, nz,20) = max(var_col_out(n, nz,20), 0.) - var_col_out(n, nz,24) = max(var_col_out(n, nz,24), 0.) - var_col_out(n, nz,25) = max(var_col_out(n, nz,25), 0.) - var_col_out(n, nz,26) = max(var_col_out(n, nz,26), 0.) - var_col_out(n, nz,27) = max(var_col_out(n, nz,27), 0.) - var_col_out(n, nz,28) = max(var_col_out(n, nz,28), 1.) - var_col_out(n, nz,29) = max(var_col_out(n, nz,29), 0.) - + var_col_out(n, nz, 1) = max(var_col_out(n, nz, 1), 0.) + var_col_out(n, nz, 2) = max(var_col_out(n, nz, 2), 0.) + var_col_out(n, nz, 3) = max(var_col_out(n, nz, 3), 0.) + var_col_out(n, nz, 4) = max(var_col_out(n, nz, 4), 0.) + var_col_out(n, nz, 5) = max(var_col_out(n, nz, 5), 0.) + var_col_out(n, nz,10) = max(var_col_out(n, nz,10), 0.) + var_col_out(n, nz,11) = max(var_col_out(n, nz,11), 0.) + var_col_out(n, nz,12) = max(var_col_out(n, nz,12), 0.) + var_col_out(n, nz,13) = max(var_col_out(n, nz,13),10.) ! soil4c + var_col_out(n, nz,14) = max(var_col_out(n, nz,14), 0.) + var_col_out(n, nz,15) = max(var_col_out(n, nz,15), 0.) + var_col_out(n, nz,16) = max(var_col_out(n, nz,16), 0.) + var_col_out(n, nz,17) = max(var_col_out(n, nz,17), 0.) + var_col_out(n, nz,18) = max(var_col_out(n, nz,18), 0.) + var_col_out(n, nz,19) = max(var_col_out(n, nz,19), 0.) + var_col_out(n, nz,20) = max(var_col_out(n, nz,20), 0.) + var_col_out(n, nz,24) = max(var_col_out(n, nz,24), 0.) + var_col_out(n, nz,25) = max(var_col_out(n, nz,25), 0.) + var_col_out(n, nz,26) = max(var_col_out(n, nz,26), 0.) + var_col_out(n, nz,27) = max(var_col_out(n, nz,27), 0.) + var_col_out(n, nz,28) = max(var_col_out(n, nz,28), 1.) + var_col_out(n, nz,29) = max(var_col_out(n, nz,29), 0.) + NVLOOP3 : do nv = 1,nveg if (nv == 1) ityp_new = CLMC_pt1(n) @@ -1508,21 +1508,21 @@ SUBROUTINE regrid_carbon_vars ( & if (nv == 2) fveg_new = CLMC_pf2(n) if (nv == 3) ityp_new = CLMC_st1(n) if (nv == 3) fveg_new = CLMC_sf1(n) - if (nv == 4) ityp_new = CLMC_st2(n) + if (nv == 4) ityp_new = CLMC_st2(n) if (nv == 4) fveg_new = CLMC_sf2(n) - + if(fveg_new > fmin) then - var_pft_out(n, nz,nv, 1) = max(var_pft_out(n, nz,nv, 1),0.) - var_pft_out(n, nz,nv, 2) = max(var_pft_out(n, nz,nv, 2),0.) - var_pft_out(n, nz,nv, 3) = max(var_pft_out(n, nz,nv, 3),0.) - var_pft_out(n, nz,nv, 4) = max(var_pft_out(n, nz,nv, 4),0.) - + var_pft_out(n, nz,nv, 1) = max(var_pft_out(n, nz,nv, 1),0.) + var_pft_out(n, nz,nv, 2) = max(var_pft_out(n, nz,nv, 2),0.) + var_pft_out(n, nz,nv, 3) = max(var_pft_out(n, nz,nv, 3),0.) + var_pft_out(n, nz,nv, 4) = max(var_pft_out(n, nz,nv, 4),0.) + if(ityp_new <= 12) then ! tree or shrub deadstemc var_pft_out(n, nz,nv, 5) = max(var_pft_out(n, nz,nv, 5),0.1) - else + else var_pft_out(n, nz,nv, 5) = max(var_pft_out(n, nz,nv, 5),0.0) endif - + var_pft_out(n, nz,nv, 6) = max(var_pft_out(n, nz,nv, 6),0.) var_pft_out(n, nz,nv, 7) = max(var_pft_out(n, nz,nv, 7),0.) var_pft_out(n, nz,nv, 8) = max(var_pft_out(n, nz,nv, 8),0.) @@ -1530,15 +1530,15 @@ SUBROUTINE regrid_carbon_vars ( & var_pft_out(n, nz,nv,10) = max(var_pft_out(n, nz,nv,10),0.) var_pft_out(n, nz,nv,11) = max(var_pft_out(n, nz,nv,11),0.) var_pft_out(n, nz,nv,12) = max(var_pft_out(n, nz,nv,12),0.) - + if(ityp_new <=2 .or. ityp_new ==4 .or. ityp_new ==5 .or. ityp_new == 9) then var_pft_out(n, nz,nv,13) = max(var_pft_out(n, nz,nv,13),1.) ! leaf carbon display for evergreen var_pft_out(n, nz,nv,14) = max(var_pft_out(n, nz,nv,14),0.) else - var_pft_out(n, nz,nv,13) = max(var_pft_out(n, nz,nv,13),0.) + var_pft_out(n, nz,nv,13) = max(var_pft_out(n, nz,nv,13),0.) var_pft_out(n, nz,nv,14) = max(var_pft_out(n, nz,nv,14),1.) ! leaf carbon storage for deciduous endif - + var_pft_out(n, nz,nv,15) = max(var_pft_out(n, nz,nv,15),0.) var_pft_out(n, nz,nv,16) = max(var_pft_out(n, nz,nv,16),0.) var_pft_out(n, nz,nv,17) = max(var_pft_out(n, nz,nv,17),0.) @@ -1560,167 +1560,167 @@ SUBROUTINE regrid_carbon_vars ( & var_pft_out(n, nz,nv,48) = max(var_pft_out(n, nz,nv,48),0.) var_pft_out(n, nz,nv,49) = max(var_pft_out(n, nz,nv,49),0.) var_pft_out(n, nz,nv,50) = max(var_pft_out(n, nz,nv,50),0.) - var_pft_out(n, nz,nv,51) = max(var_pft_out(n, nz,nv, 5)/500.,0.) + var_pft_out(n, nz,nv,51) = max(var_pft_out(n, nz,nv, 5)/500.,0.) var_pft_out(n, nz,nv,52) = max(var_pft_out(n, nz,nv,52),0.) var_pft_out(n, nz,nv,53) = max(var_pft_out(n, nz,nv,53),0.) var_pft_out(n, nz,nv,54) = max(var_pft_out(n, nz,nv,54),0.) var_pft_out(n, nz,nv,55) = max(var_pft_out(n, nz,nv,55),0.) var_pft_out(n, nz,nv,56) = max(var_pft_out(n, nz,nv,56),0.) - var_pft_out(n, nz,nv,57) = max(var_pft_out(n, nz,nv,13)/25.,0.) - var_pft_out(n, nz,nv,58) = max(var_pft_out(n, nz,nv,14)/25.,0.) + var_pft_out(n, nz,nv,57) = max(var_pft_out(n, nz,nv,13)/25.,0.) + var_pft_out(n, nz,nv,58) = max(var_pft_out(n, nz,nv,14)/25.,0.) var_pft_out(n, nz,nv,59) = max(var_pft_out(n, nz,nv,59),0.) - var_pft_out(n, nz,nv,60) = max(var_pft_out(n, nz,nv,60),0.) - var_pft_out(n, nz,nv,61) = max(var_pft_out(n, nz,nv,61),0.) - var_pft_out(n, nz,nv,62) = max(var_pft_out(n, nz,nv,62),0.) - var_pft_out(n, nz,nv,63) = max(var_pft_out(n, nz,nv,63),0.) - var_pft_out(n, nz,nv,64) = max(var_pft_out(n, nz,nv,64),0.) - var_pft_out(n, nz,nv,65) = max(var_pft_out(n, nz,nv,65),0.) - var_pft_out(n, nz,nv,66) = max(var_pft_out(n, nz,nv,66),0.) - var_pft_out(n, nz,nv,67) = max(var_pft_out(n, nz,nv,67),0.) - var_pft_out(n, nz,nv,68) = max(var_pft_out(n, nz,nv,68),0.) - var_pft_out(n, nz,nv,69) = max(var_pft_out(n, nz,nv,69),0.) - var_pft_out(n, nz,nv,70) = max(var_pft_out(n, nz,nv,70),0.) - var_pft_out(n, nz,nv,73) = max(var_pft_out(n, nz,nv,73),0.) - var_pft_out(n, nz,nv,74) = max(var_pft_out(n, nz,nv,74),0.) + var_pft_out(n, nz,nv,60) = max(var_pft_out(n, nz,nv,60),0.) + var_pft_out(n, nz,nv,61) = max(var_pft_out(n, nz,nv,61),0.) + var_pft_out(n, nz,nv,62) = max(var_pft_out(n, nz,nv,62),0.) + var_pft_out(n, nz,nv,63) = max(var_pft_out(n, nz,nv,63),0.) + var_pft_out(n, nz,nv,64) = max(var_pft_out(n, nz,nv,64),0.) + var_pft_out(n, nz,nv,65) = max(var_pft_out(n, nz,nv,65),0.) + var_pft_out(n, nz,nv,66) = max(var_pft_out(n, nz,nv,66),0.) + var_pft_out(n, nz,nv,67) = max(var_pft_out(n, nz,nv,67),0.) + var_pft_out(n, nz,nv,68) = max(var_pft_out(n, nz,nv,68),0.) + var_pft_out(n, nz,nv,69) = max(var_pft_out(n, nz,nv,69),0.) + var_pft_out(n, nz,nv,70) = max(var_pft_out(n, nz,nv,70),0.) + var_pft_out(n, nz,nv,73) = max(var_pft_out(n, nz,nv,73),0.) + var_pft_out(n, nz,nv,74) = max(var_pft_out(n, nz,nv,74),0.) endif - end do NVLOOP3 ! end veg loop - endif ! end carbon check + end do NVLOOP3 ! end veg loop + endif ! end carbon check end do NZLOOP ! end zone loop - + ! Update dayx variable var_pft_out (:,:,28) - + do j = 28, 28 ! 1,VAR_PFT var_pft_out (:,:,:,28) do nv = 1,nveg do nz = 1,nzone var_pft_out (n, nz,nv,j) = dayx(n) end do end do - end do + end do + + ! call NCDF_reshape_getOput (OutID,N,var_col_out,var_pft_out,.false.) - ! call NCDF_reshape_getOput (OutID,N,var_col_out,var_pft_out,.false.) - ! column vars ! ----------- - ! 1 clm3%g%l%c%ccs%col_ctrunc - ! 2 clm3%g%l%c%ccs%cwdc - ! 3 clm3%g%l%c%ccs%litr1c - ! 4 clm3%g%l%c%ccs%litr2c - ! 5 clm3%g%l%c%ccs%litr3c - ! 6 clm3%g%l%c%ccs%pcs_a%totvegc - ! 7 clm3%g%l%c%ccs%prod100c - ! 8 clm3%g%l%c%ccs%prod10c - ! 9 clm3%g%l%c%ccs%seedc - ! 10 clm3%g%l%c%ccs%soil1c - ! 11 clm3%g%l%c%ccs%soil2c - ! 12 clm3%g%l%c%ccs%soil3c - ! 13 clm3%g%l%c%ccs%soil4c - ! 14 clm3%g%l%c%ccs%totcolc - ! 15 clm3%g%l%c%ccs%totlitc - ! 16 clm3%g%l%c%cns%col_ntrunc - ! 17 clm3%g%l%c%cns%cwdn - ! 18 clm3%g%l%c%cns%litr1n - ! 19 clm3%g%l%c%cns%litr2n - ! 20 clm3%g%l%c%cns%litr3n - ! 21 clm3%g%l%c%cns%prod100n - ! 22 clm3%g%l%c%cns%prod10n - ! 23 clm3%g%l%c%cns%seedn - ! 24 clm3%g%l%c%cns%sminn - ! 25 clm3%g%l%c%cns%soil1n - ! 26 clm3%g%l%c%cns%soil2n - ! 27 clm3%g%l%c%cns%soil3n - ! 28 clm3%g%l%c%cns%soil4n - ! 29 clm3%g%l%c%cns%totcoln - ! 30 clm3%g%l%c%cps%ann_farea_burned - ! 31 clm3%g%l%c%cps%annsum_counter - ! 32 clm3%g%l%c%cps%cannavg_t2m - ! 33 clm3%g%l%c%cps%cannsum_npp - ! 34 clm3%g%l%c%cps%farea_burned - ! 35 clm3%g%l%c%cps%fire_prob - ! 36 clm3%g%l%c%cps%fireseasonl - ! 37 clm3%g%l%c%cps%fpg - ! 38 clm3%g%l%c%cps%fpi - ! 39 clm3%g%l%c%cps%me - ! 40 clm3%g%l%c%cps%mean_fire_prob - + ! 1 clm3%g%l%c%ccs%col_ctrunc + ! 2 clm3%g%l%c%ccs%cwdc + ! 3 clm3%g%l%c%ccs%litr1c + ! 4 clm3%g%l%c%ccs%litr2c + ! 5 clm3%g%l%c%ccs%litr3c + ! 6 clm3%g%l%c%ccs%pcs_a%totvegc + ! 7 clm3%g%l%c%ccs%prod100c + ! 8 clm3%g%l%c%ccs%prod10c + ! 9 clm3%g%l%c%ccs%seedc + ! 10 clm3%g%l%c%ccs%soil1c + ! 11 clm3%g%l%c%ccs%soil2c + ! 12 clm3%g%l%c%ccs%soil3c + ! 13 clm3%g%l%c%ccs%soil4c + ! 14 clm3%g%l%c%ccs%totcolc + ! 15 clm3%g%l%c%ccs%totlitc + ! 16 clm3%g%l%c%cns%col_ntrunc + ! 17 clm3%g%l%c%cns%cwdn + ! 18 clm3%g%l%c%cns%litr1n + ! 19 clm3%g%l%c%cns%litr2n + ! 20 clm3%g%l%c%cns%litr3n + ! 21 clm3%g%l%c%cns%prod100n + ! 22 clm3%g%l%c%cns%prod10n + ! 23 clm3%g%l%c%cns%seedn + ! 24 clm3%g%l%c%cns%sminn + ! 25 clm3%g%l%c%cns%soil1n + ! 26 clm3%g%l%c%cns%soil2n + ! 27 clm3%g%l%c%cns%soil3n + ! 28 clm3%g%l%c%cns%soil4n + ! 29 clm3%g%l%c%cns%totcoln + ! 30 clm3%g%l%c%cps%ann_farea_burned + ! 31 clm3%g%l%c%cps%annsum_counter + ! 32 clm3%g%l%c%cps%cannavg_t2m + ! 33 clm3%g%l%c%cps%cannsum_npp + ! 34 clm3%g%l%c%cps%farea_burned + ! 35 clm3%g%l%c%cps%fire_prob + ! 36 clm3%g%l%c%cps%fireseasonl + ! 37 clm3%g%l%c%cps%fpg + ! 38 clm3%g%l%c%cps%fpi + ! 39 clm3%g%l%c%cps%me + ! 40 clm3%g%l%c%cps%mean_fire_prob + ! PFT vars ! -------- - ! 1 clm3%g%l%c%p%pcs%cpool - ! 2 clm3%g%l%c%p%pcs%deadcrootc - ! 3 clm3%g%l%c%p%pcs%deadcrootc_storage - ! 4 clm3%g%l%c%p%pcs%deadcrootc_xfer - ! 5 clm3%g%l%c%p%pcs%deadstemc - ! 6 clm3%g%l%c%p%pcs%deadstemc_storage - ! 7 clm3%g%l%c%p%pcs%deadstemc_xfer - ! 8 clm3%g%l%c%p%pcs%frootc - ! 9 clm3%g%l%c%p%pcs%frootc_storage - ! 10 clm3%g%l%c%p%pcs%frootc_xfer - ! 11 clm3%g%l%c%p%pcs%gresp_storage - ! 12 clm3%g%l%c%p%pcs%gresp_xfer - ! 13 clm3%g%l%c%p%pcs%leafc - ! 14 clm3%g%l%c%p%pcs%leafc_storage - ! 15 clm3%g%l%c%p%pcs%leafc_xfer - ! 16 clm3%g%l%c%p%pcs%livecrootc - ! 17 clm3%g%l%c%p%pcs%livecrootc_storage - ! 18 clm3%g%l%c%p%pcs%livecrootc_xfer - ! 19 clm3%g%l%c%p%pcs%livestemc - ! 20 clm3%g%l%c%p%pcs%livestemc_storage - ! 21 clm3%g%l%c%p%pcs%livestemc_xfer - ! 22 clm3%g%l%c%p%pcs%pft_ctrunc - ! 23 clm3%g%l%c%p%pcs%xsmrpool - ! 24 clm3%g%l%c%p%pepv%annavg_t2m - ! 25 clm3%g%l%c%p%pepv%annmax_retransn - ! 26 clm3%g%l%c%p%pepv%annsum_npp - ! 27 clm3%g%l%c%p%pepv%annsum_potential_gpp - ! 28 clm3%g%l%c%p%pepv%dayl - ! 29 clm3%g%l%c%p%pepv%days_active - ! 30 clm3%g%l%c%p%pepv%dormant_flag - ! 31 clm3%g%l%c%p%pepv%offset_counter - ! 32 clm3%g%l%c%p%pepv%offset_fdd - ! 33 clm3%g%l%c%p%pepv%offset_flag - ! 34 clm3%g%l%c%p%pepv%offset_swi - ! 35 clm3%g%l%c%p%pepv%onset_counter - ! 36 clm3%g%l%c%p%pepv%onset_fdd - ! 37 clm3%g%l%c%p%pepv%onset_flag - ! 38 clm3%g%l%c%p%pepv%onset_gdd - ! 39 clm3%g%l%c%p%pepv%onset_gddflag - ! 40 clm3%g%l%c%p%pepv%onset_swi + ! 1 clm3%g%l%c%p%pcs%cpool + ! 2 clm3%g%l%c%p%pcs%deadcrootc + ! 3 clm3%g%l%c%p%pcs%deadcrootc_storage + ! 4 clm3%g%l%c%p%pcs%deadcrootc_xfer + ! 5 clm3%g%l%c%p%pcs%deadstemc + ! 6 clm3%g%l%c%p%pcs%deadstemc_storage + ! 7 clm3%g%l%c%p%pcs%deadstemc_xfer + ! 8 clm3%g%l%c%p%pcs%frootc + ! 9 clm3%g%l%c%p%pcs%frootc_storage + ! 10 clm3%g%l%c%p%pcs%frootc_xfer + ! 11 clm3%g%l%c%p%pcs%gresp_storage + ! 12 clm3%g%l%c%p%pcs%gresp_xfer + ! 13 clm3%g%l%c%p%pcs%leafc + ! 14 clm3%g%l%c%p%pcs%leafc_storage + ! 15 clm3%g%l%c%p%pcs%leafc_xfer + ! 16 clm3%g%l%c%p%pcs%livecrootc + ! 17 clm3%g%l%c%p%pcs%livecrootc_storage + ! 18 clm3%g%l%c%p%pcs%livecrootc_xfer + ! 19 clm3%g%l%c%p%pcs%livestemc + ! 20 clm3%g%l%c%p%pcs%livestemc_storage + ! 21 clm3%g%l%c%p%pcs%livestemc_xfer + ! 22 clm3%g%l%c%p%pcs%pft_ctrunc + ! 23 clm3%g%l%c%p%pcs%xsmrpool + ! 24 clm3%g%l%c%p%pepv%annavg_t2m + ! 25 clm3%g%l%c%p%pepv%annmax_retransn + ! 26 clm3%g%l%c%p%pepv%annsum_npp + ! 27 clm3%g%l%c%p%pepv%annsum_potential_gpp + ! 28 clm3%g%l%c%p%pepv%dayl + ! 29 clm3%g%l%c%p%pepv%days_active + ! 30 clm3%g%l%c%p%pepv%dormant_flag + ! 31 clm3%g%l%c%p%pepv%offset_counter + ! 32 clm3%g%l%c%p%pepv%offset_fdd + ! 33 clm3%g%l%c%p%pepv%offset_flag + ! 34 clm3%g%l%c%p%pepv%offset_swi + ! 35 clm3%g%l%c%p%pepv%onset_counter + ! 36 clm3%g%l%c%p%pepv%onset_fdd + ! 37 clm3%g%l%c%p%pepv%onset_flag + ! 38 clm3%g%l%c%p%pepv%onset_gdd + ! 39 clm3%g%l%c%p%pepv%onset_gddflag + ! 40 clm3%g%l%c%p%pepv%onset_swi ! 41 clm3%g%l%c%p%pepv%prev_frootc_to_litter - ! 42 clm3%g%l%c%p%pepv%prev_leafc_to_litter - ! 43 clm3%g%l%c%p%pepv%tempavg_t2m - ! 44 clm3%g%l%c%p%pepv%tempmax_retransn - ! 45 clm3%g%l%c%p%pepv%tempsum_npp + ! 42 clm3%g%l%c%p%pepv%prev_leafc_to_litter + ! 43 clm3%g%l%c%p%pepv%tempavg_t2m + ! 44 clm3%g%l%c%p%pepv%tempmax_retransn + ! 45 clm3%g%l%c%p%pepv%tempsum_npp ! 46 clm3%g%l%c%p%pepv%tempsum_potential_gpp - ! 47 clm3%g%l%c%p%pepv%xsmrpool_recover - ! 48 clm3%g%l%c%p%pns%deadcrootn - ! 49 clm3%g%l%c%p%pns%deadcrootn_storage - ! 50 clm3%g%l%c%p%pns%deadcrootn_xfer - ! 51 clm3%g%l%c%p%pns%deadstemn - ! 52 clm3%g%l%c%p%pns%deadstemn_storage - ! 53 clm3%g%l%c%p%pns%deadstemn_xfer - ! 54 clm3%g%l%c%p%pns%frootn - ! 55 clm3%g%l%c%p%pns%frootn_storage - ! 56 clm3%g%l%c%p%pns%frootn_xfer - ! 57 clm3%g%l%c%p%pns%leafn - ! 58 clm3%g%l%c%p%pns%leafn_storage - ! 59 clm3%g%l%c%p%pns%leafn_xfer - ! 60 clm3%g%l%c%p%pns%livecrootn - ! 61 clm3%g%l%c%p%pns%livecrootn_storage - ! 62 clm3%g%l%c%p%pns%livecrootn_xfer - ! 63 clm3%g%l%c%p%pns%livestemn - ! 64 clm3%g%l%c%p%pns%livestemn_storage - ! 65 clm3%g%l%c%p%pns%livestemn_xfer - ! 66 clm3%g%l%c%p%pns%npool - ! 67 clm3%g%l%c%p%pns%pft_ntrunc - ! 68 clm3%g%l%c%p%pns%retransn - ! 69 clm3%g%l%c%p%pps%elai - ! 70 clm3%g%l%c%p%pps%esai - ! 71 clm3%g%l%c%p%pps%hbot - ! 72 clm3%g%l%c%p%pps%htop - ! 73 clm3%g%l%c%p%pps%tlai - ! 74 clm3%g%l%c%p%pps%tsai - + ! 47 clm3%g%l%c%p%pepv%xsmrpool_recover + ! 48 clm3%g%l%c%p%pns%deadcrootn + ! 49 clm3%g%l%c%p%pns%deadcrootn_storage + ! 50 clm3%g%l%c%p%pns%deadcrootn_xfer + ! 51 clm3%g%l%c%p%pns%deadstemn + ! 52 clm3%g%l%c%p%pns%deadstemn_storage + ! 53 clm3%g%l%c%p%pns%deadstemn_xfer + ! 54 clm3%g%l%c%p%pns%frootn + ! 55 clm3%g%l%c%p%pns%frootn_storage + ! 56 clm3%g%l%c%p%pns%frootn_xfer + ! 57 clm3%g%l%c%p%pns%leafn + ! 58 clm3%g%l%c%p%pns%leafn_storage + ! 59 clm3%g%l%c%p%pns%leafn_xfer + ! 60 clm3%g%l%c%p%pns%livecrootn + ! 61 clm3%g%l%c%p%pns%livecrootn_storage + ! 62 clm3%g%l%c%p%pns%livecrootn_xfer + ! 63 clm3%g%l%c%p%pns%livestemn + ! 64 clm3%g%l%c%p%pns%livestemn_storage + ! 65 clm3%g%l%c%p%pns%livestemn_xfer + ! 66 clm3%g%l%c%p%pns%npool + ! 67 clm3%g%l%c%p%pns%pft_ntrunc + ! 68 clm3%g%l%c%p%pns%retransn + ! 69 clm3%g%l%c%p%pps%elai + ! 70 clm3%g%l%c%p%pps%esai + ! 71 clm3%g%l%c%p%pps%hbot + ! 72 clm3%g%l%c%p%pps%htop + ! 73 clm3%g%l%c%p%pps%tlai + ! 74 clm3%g%l%c%p%pps%tsai + end do OUT_TILE - + i = 1 do nv = 1,VAR_COL do nz = 1,nzone @@ -1728,7 +1728,7 @@ SUBROUTINE regrid_carbon_vars ( & i = i + 1 end do end do - + i = 1 do iv = 1,VAR_PFT do nv = 1,nveg @@ -1743,7 +1743,7 @@ SUBROUTINE regrid_carbon_vars ( & do nz = 1,nzone STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'TGWM'), (/1,nz/), (/NTILES,1 /),VAR_DUM(:)) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'RZMM'), (/1,nz/), (/NTILES,1 /),VAR_DUM(:)) + STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'RZMM'), (/1,nz/), (/NTILES,1 /),VAR_DUM(:)) end do STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'SFMCM'), (/1/), (/NTILES/),VAR_DUM(:)) @@ -1751,34 +1751,34 @@ SUBROUTINE regrid_carbon_vars ( & STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'TOTWATM'), (/1/), (/NTILES/),VAR_DUM(:)) STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'TAIRM'), (/1/), (/NTILES/),VAR_DUM(:)) STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'TPM'), (/1/), (/NTILES/),VAR_DUM(:)) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'CNSUM'), (/1/), (/NTILES/),VAR_DUM(:)) + STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'CNSUM'), (/1/), (/NTILES/),VAR_DUM(:)) STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'SNDZM'), (/1/), (/NTILES/),VAR_DUM(:)) STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'ASNOWM'), (/1/), (/NTILES/),VAR_DUM(:)) do nv = 1,nzone do nz = 1,nveg - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'PSNSUNM'), (/1,nz,nv/), (/NTILES,1,1/),VAR_DUM(:)) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'PSNSHAM'), (/1,nz,nv/), (/NTILES,1,1/),VAR_DUM(:)) + STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'PSNSUNM'), (/1,nz,nv/), (/NTILES,1,1/),VAR_DUM(:)) + STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'PSNSHAM'), (/1,nz,nv/), (/NTILES,1,1/),VAR_DUM(:)) end do end do STATUS = NF_CLOSE (NCFID) STATUS = NF_CLOSE (OutID) - - deallocate (var_off_col,var_off_pft,var_col_out,var_pft_out) + + deallocate (var_off_col,var_off_pft,var_col_out,var_pft_out) deallocate (CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2) deallocate (CLMC_pt1, CLMC_pt2, CLMC_st1, CLMC_st2) - + endif call MPI_Barrier(MPI_COMM_WORLD, STATUS) - + END SUBROUTINE regrid_carbon_vars - ! ***************************************************************************** + ! ***************************************************************************** - SUBROUTINE NCDF_reshape_getOput (NCFID,CID,col,pft, get_var) + SUBROUTINE NCDF_reshape_getOput (NCFID,CID,col,pft, get_var) implicit none @@ -1798,18 +1798,18 @@ SUBROUTINE NCDF_reshape_getOput (NCFID,CID,col,pft, get_var) IF ((STATUS .NE. NF_NOERR).and.(get_var)) then print *,CID - CALL HANDLE_ERR(STATUS, 'Out : NCDF_reshape_getOput') + CALL HANDLE_ERR(STATUS, 'Out : NCDF_reshape_getOput') ENDIF IF ((STATUS .NE. NF_NOERR).and.(.not.get_var)) then print *,CID - CALL HANDLE_ERR(STATUS, 'In : NCDF_reshape_getOput') + CALL HANDLE_ERR(STATUS, 'In : NCDF_reshape_getOput') ENDIF END SUBROUTINE NCDF_reshape_getOput - ! ***************************************************************************** + ! ***************************************************************************** - SUBROUTINE NCDF_whole_getOput (NCFID,NTILES,col,pft, get_var) + SUBROUTINE NCDF_whole_getOput (NCFID,NTILES,col,pft, get_var) implicit none @@ -1835,11 +1835,11 @@ SUBROUTINE NCDF_whole_getOput (NCFID,NTILES,col,pft, get_var) END DO endif - IF ((STATUS .NE. NF_NOERR).and.(get_var)) CALL HANDLE_ERR(STATUS, 'Out : NCDF_whole_getOput') - IF ((STATUS .NE. NF_NOERR).and.(.not.get_var)) CALL HANDLE_ERR(STATUS, 'In : NCDF_whole_getOput') + IF ((STATUS .NE. NF_NOERR).and.(get_var)) CALL HANDLE_ERR(STATUS, 'Out : NCDF_whole_getOput') + IF ((STATUS .NE. NF_NOERR).and.(.not.get_var)) CALL HANDLE_ERR(STATUS, 'In : NCDF_whole_getOput') END SUBROUTINE NCDF_whole_getOput - + ! ----------------------------------------------------------------------- SUBROUTINE HANDLE_ERR(STATUS, Line) @@ -1856,21 +1856,21 @@ END SUBROUTINE HANDLE_ERR ! ***************************************************************************** - integer function VarID (NCFID, VNAME) - + 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)) - + CALL HANDLE_ERR(STATUS, trim(VNAME)) + end function VarID ! ***************************************************************************** - - SUBROUTINE regrid_hyd_vars (NTILES, OutFMT) + + SUBROUTINE regrid_hyd_vars (NTILES, OutFMT) implicit none integer, intent (in) :: NTILES @@ -1894,15 +1894,15 @@ SUBROUTINE regrid_hyd_vars (NTILES, OutFMT) allocate(nt_local( numprocs)) low_ind (:) = 1 - upp_ind (:) = NTILES - nt_local(:) = NTILES + upp_ind (:) = NTILES + nt_local(:) = NTILES ! Domain decomposition ! -------------------- - if (numprocs > 1) then + if (numprocs > 1) then do i = 1, numprocs - 1 - upp_ind(i) = low_ind(i) + (ntiles/numprocs) - 1 + upp_ind(i) = low_ind(i) + (ntiles/numprocs) - 1 low_ind(i+1) = upp_ind(i) + 1 nt_local(i) = upp_ind(i) - low_ind(i) + 1 end do @@ -1919,12 +1919,12 @@ SUBROUTINE regrid_hyd_vars (NTILES, OutFMT) allocate (long (ntiles)) allocate (latg (ntiles)) - allocate (ld_reorder(ntiles_cn)) + allocate (ld_reorder(ntiles_cn)) call ReadTileFile_RealLatLon (OutTileFile, i, xlon=long, xlat=latg) ! --------------------------------------------- - ! Read exact lonc, latc from offline .til File + ! Read exact lonc, latc from offline .til File ! --------------------------------------------- call ReadTileFile_RealLatLon(trim(InCNTilFile), i,xlon=lonc,xlat=latc) @@ -1932,7 +1932,7 @@ SUBROUTINE regrid_hyd_vars (NTILES, OutFMT) STATUS = NF_OPEN (trim(InCNRestart),NF_NOWRITE,NCFID) STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TILE_ID' ), (/1/), (/NTILES_CN/),tmp_var) STATUS = NF_CLOSE (NCFID) - + do n = 1, ntiles_cn ld_reorder ( NINT(tmp_var(n))) = n tid_offl(n) = n @@ -1956,9 +1956,9 @@ SUBROUTINE regrid_hyd_vars (NTILES, OutFMT) else if (myid == 0) then ! root sends call MPI_ISend(long(low_ind(i) : upp_ind(i)),nt_local(i),MPI_REAL,i-1,995,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) + call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) call MPI_ISend(latg(low_ind(i) : upp_ind(i)),nt_local(i),MPI_REAL,i-1,994,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) + call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) endif endif end do @@ -1974,18 +1974,18 @@ SUBROUTINE regrid_hyd_vars (NTILES, OutFMT) ! 0,MPI_COMM_WORLD, mpierr ) if(root_proc) deallocate (long, latg) - + call MPI_BCAST(lonc,ntiles_cn,MPI_REAL,0,MPI_COMM_WORLD,mpierr) call MPI_BCAST(latc,ntiles_cn,MPI_REAL,0,MPI_COMM_WORLD,mpierr) call MPI_BCAST(tid_offl,size(tid_offl ),MPI_INTEGER,0,MPI_COMM_WORLD,mpierr) ! -------------------------------------------------------------------------------- ! Here we create transfer index array to map offline restarts to output tile space - ! -------------------------------------------------------------------------------- + ! -------------------------------------------------------------------------------- - call GetIds(lonc,latc,lonn,latt,id_loc, tid_offl) + call GetIds(lonc,latc,lonn,latt,id_loc, tid_offl) - ! Loop through NTILES (# of tiles in output array) find the nearest neighbor from Qing. + ! Loop through NTILES (# of tiles in output array) find the nearest neighbor from Qing. if(root_proc) allocate (id_glb (ntiles)) @@ -1998,19 +1998,19 @@ SUBROUTINE regrid_hyd_vars (NTILES, OutFMT) if(I-1 == myid) then ! send to root call MPI_ISend(id_loc,nt_local(i),MPI_INTEGER,0,993,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) + call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) else if (myid == 0) then ! root receives call MPI_RECV(id_glb(low_ind(i) : upp_ind(i)),nt_local(i) , MPI_INTEGER, i-1,993,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) endif endif - end do + end do ! call MPI_GATHERV( & ! id_loc, nt_local(myid+1) , MPI_real, & ! id_glb, nt_local,low_ind-1, MPI_real, & ! 0, MPI_COMM_WORLD, mpierr ) - + if (root_proc) call put_land_vars (NTILES, id_glb, ld_reorder, OutFmt) call MPI_Barrier(MPI_COMM_WORLD, STATUS) @@ -2021,7 +2021,7 @@ END SUBROUTINE regrid_hyd_vars SUBROUTINE put_land_vars (NTILES, id_glb, ld_reorder, OutFmt) implicit none - + integer, intent (in) :: NTILES integer, intent (in) :: id_glb(NTILES), ld_reorder (NTILES_CN) integer :: i,k,n @@ -2031,7 +2031,7 @@ SUBROUTINE put_land_vars (NTILES, id_glb, ld_reorder, OutFmt) allocate (var_get (NTILES_CN)) allocate (var_put (NTILES)) - + ! Read catparam ! ------------- @@ -2059,91 +2059,91 @@ SUBROUTINE put_land_vars (NTILES, id_glb, ld_reorder, OutFmt) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'BEE',var_put) - + call MAPL_VarWrite(OutFmt,'BEE',var_put) + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'WPWET' ), (/1/), (/NTILES_CN/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'WPWET',var_put) - + call MAPL_VarWrite(OutFmt,'WPWET',var_put) + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'GNU' ), (/1/), (/NTILES_CN/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do call MAPL_VarWrite(OutFmt,'GNU',var_put) - + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'VGWMAX' ), (/1/), (/NTILES_CN/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'VGWMAX',var_put) - + call MAPL_VarWrite(OutFmt,'VGWMAX',var_put) + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'BF1' ), (/1/), (/NTILES_CN/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'BF1',var_put) + call MAPL_VarWrite(OutFmt,'BF1',var_put) STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'BF2' ), (/1/), (/NTILES_CN/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'BF2',var_put) + call MAPL_VarWrite(OutFmt,'BF2',var_put) STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'BF3' ), (/1/), (/NTILES_CN/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'BF3',var_put) - + call MAPL_VarWrite(OutFmt,'BF3',var_put) + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CDCR1' ), (/1/), (/NTILES_CN/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'CDCR1',var_put) - + call MAPL_VarWrite(OutFmt,'CDCR1',var_put) + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CDCR2' ), (/1/), (/NTILES_CN/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'CDCR2',var_put) - + call MAPL_VarWrite(OutFmt,'CDCR2',var_put) + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARS1' ), (/1/), (/NTILES_CN/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'ARS1',var_put) - + call MAPL_VarWrite(OutFmt,'ARS1',var_put) + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARS2' ), (/1/), (/NTILES_CN/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'ARS2',var_put) + call MAPL_VarWrite(OutFmt,'ARS2',var_put) STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARS3' ), (/1/), (/NTILES_CN/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'ARS3',var_put) - + call MAPL_VarWrite(OutFmt,'ARS3',var_put) + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARA1' ), (/1/), (/NTILES_CN/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'ARA1',var_put) - + call MAPL_VarWrite(OutFmt,'ARA1',var_put) + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARA2' ), (/1/), (/NTILES_CN/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'ARA2',var_put) + call MAPL_VarWrite(OutFmt,'ARA2',var_put) STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARA3' ), (/1/), (/NTILES_CN/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'ARA3',var_put) + call MAPL_VarWrite(OutFmt,'ARA3',var_put) STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARA4' ), (/1/), (/NTILES_CN/),var_get) do k = 1, NTILES @@ -2155,77 +2155,77 @@ SUBROUTINE put_land_vars (NTILES, id_glb, ld_reorder, OutFmt) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'ARW1',var_put) - + call MAPL_VarWrite(OutFmt,'ARW1',var_put) + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARW2' ), (/1/), (/NTILES_CN/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'ARW2',var_put) + call MAPL_VarWrite(OutFmt,'ARW2',var_put) STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARW3' ), (/1/), (/NTILES_CN/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'ARW3',var_put) - + call MAPL_VarWrite(OutFmt,'ARW3',var_put) + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARW4' ), (/1/), (/NTILES_CN/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'ARW4',var_put) + call MAPL_VarWrite(OutFmt,'ARW4',var_put) STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TSA1' ), (/1/), (/NTILES_CN/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'TSA1',var_put) - + call MAPL_VarWrite(OutFmt,'TSA1',var_put) + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TSA2' ), (/1/), (/NTILES_CN/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'TSA2',var_put) + call MAPL_VarWrite(OutFmt,'TSA2',var_put) STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TSB1' ), (/1/), (/NTILES_CN/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'TSB1',var_put) - + call MAPL_VarWrite(OutFmt,'TSB1',var_put) + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TSB2' ), (/1/), (/NTILES_CN/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'TSB2',var_put) - + call MAPL_VarWrite(OutFmt,'TSB2',var_put) + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ATAU' ), (/1/), (/NTILES_CN/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'ATAU',var_put) - + call MAPL_VarWrite(OutFmt,'ATAU',var_put) + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'BTAU' ), (/1/), (/NTILES_CN/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'BTAU',var_put) + call MAPL_VarWrite(OutFmt,'BTAU',var_put) STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ITY' ), (/1,1/), (/NTILES_CN,1/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'ITY',var_put, offset1=1) + call MAPL_VarWrite(OutFmt,'ITY',var_put, offset1=1) STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ITY' ), (/1,2/), (/NTILES_CN,1/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'ITY',var_put, offset1=2) + call MAPL_VarWrite(OutFmt,'ITY',var_put, offset1=2) STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ITY' ), (/1,3/), (/NTILES_CN,1/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'ITY',var_put, offset1=3) + call MAPL_VarWrite(OutFmt,'ITY',var_put, offset1=3) STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ITY' ), (/1,4/), (/NTILES_CN,1/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) @@ -2236,17 +2236,17 @@ SUBROUTINE put_land_vars (NTILES, id_glb, ld_reorder, OutFmt) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'FVG',var_put, offset1=1) + call MAPL_VarWrite(OutFmt,'FVG',var_put, offset1=1) STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'FVG' ), (/1,2/), (/NTILES_CN,1/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'FVG',var_put, offset1=2) + call MAPL_VarWrite(OutFmt,'FVG',var_put, offset1=2) STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'FVG' ), (/1,3/), (/NTILES_CN,1/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'FVG',var_put, offset1=3) + call MAPL_VarWrite(OutFmt,'FVG',var_put, offset1=3) STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'FVG' ), (/1,4/), (/NTILES_CN,1/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) @@ -2266,37 +2266,37 @@ SUBROUTINE put_land_vars (NTILES, id_glb, ld_reorder, OutFmt) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'TG',var_put, offset1=2) + call MAPL_VarWrite(OutFmt,'TG',var_put, offset1=2) STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TG' ), (/1,3/), (/NTILES_CN,1/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'TG',var_put, offset1=3) + call MAPL_VarWrite(OutFmt,'TG',var_put, offset1=3) STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TC' ), (/1,1/), (/NTILES_CN,1/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'TC',var_put, offset1=1) + call MAPL_VarWrite(OutFmt,'TC',var_put, offset1=1) STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TC' ), (/1,2/), (/NTILES_CN,1/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'TC',var_put, offset1=2) + call MAPL_VarWrite(OutFmt,'TC',var_put, offset1=2) STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TC' ), (/1,3/), (/NTILES_CN,1/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'TC',var_put, offset1=3) - + call MAPL_VarWrite(OutFmt,'TC',var_put, offset1=3) + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'QC' ), (/1,1/), (/NTILES_CN,1/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'QC',var_put, offset1=1) + call MAPL_VarWrite(OutFmt,'QC',var_put, offset1=1) STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'QC' ), (/1,2/), (/NTILES_CN,1/),var_get) do k = 1, NTILES @@ -2314,115 +2314,115 @@ SUBROUTINE put_land_vars (NTILES, id_glb, ld_reorder, OutFmt) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'CAPAC',var_put) - + call MAPL_VarWrite(OutFmt,'CAPAC',var_put) + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CATDEF' ), (/1/), (/NTILES_CN/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'CATDEF',var_put) + call MAPL_VarWrite(OutFmt,'CATDEF',var_put) STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'RZEXC' ), (/1/), (/NTILES_CN/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'RZEXC',var_put) + call MAPL_VarWrite(OutFmt,'RZEXC',var_put) STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'SRFEXC' ), (/1/), (/NTILES_CN/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'SRFEXC',var_put) - + call MAPL_VarWrite(OutFmt,'SRFEXC',var_put) + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'GHTCNT1' ), (/1/), (/NTILES_CN/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'GHTCNT1',var_put) + call MAPL_VarWrite(OutFmt,'GHTCNT1',var_put) STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'GHTCNT2' ), (/1/), (/NTILES_CN/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'GHTCNT2',var_put) + call MAPL_VarWrite(OutFmt,'GHTCNT2',var_put) STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'GHTCNT3' ), (/1/), (/NTILES_CN/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'GHTCNT3',var_put) + call MAPL_VarWrite(OutFmt,'GHTCNT3',var_put) STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'GHTCNT4' ), (/1/), (/NTILES_CN/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'GHTCNT4',var_put) + call MAPL_VarWrite(OutFmt,'GHTCNT4',var_put) STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'GHTCNT5' ), (/1/), (/NTILES_CN/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'GHTCNT5',var_put) + call MAPL_VarWrite(OutFmt,'GHTCNT5',var_put) STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'GHTCNT6' ), (/1/), (/NTILES_CN/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'GHTCNT6',var_put) + call MAPL_VarWrite(OutFmt,'GHTCNT6',var_put) STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'WESNN1' ), (/1/), (/NTILES_CN/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'WESNN1',var_put) + call MAPL_VarWrite(OutFmt,'WESNN1',var_put) STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'WESNN2' ), (/1/), (/NTILES_CN/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'WESNN2',var_put) + call MAPL_VarWrite(OutFmt,'WESNN2',var_put) STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'WESNN3' ), (/1/), (/NTILES_CN/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'WESNN3',var_put) + call MAPL_VarWrite(OutFmt,'WESNN3',var_put) STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'HTSNNN1' ), (/1/), (/NTILES_CN/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'HTSNNN1',var_put) + call MAPL_VarWrite(OutFmt,'HTSNNN1',var_put) STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'HTSNNN2' ), (/1/), (/NTILES_CN/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'HTSNNN2',var_put) + call MAPL_VarWrite(OutFmt,'HTSNNN2',var_put) STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'HTSNNN3' ), (/1/), (/NTILES_CN/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'HTSNNN3',var_put) + call MAPL_VarWrite(OutFmt,'HTSNNN3',var_put) STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'SNDZN1' ), (/1/), (/NTILES_CN/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'SNDZN1',var_put) + call MAPL_VarWrite(OutFmt,'SNDZN1',var_put) STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'SNDZN2' ), (/1/), (/NTILES_CN/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'SNDZN2',var_put) + call MAPL_VarWrite(OutFmt,'SNDZN2',var_put) STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'SNDZN3' ), (/1/), (/NTILES_CN/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'SNDZN3',var_put) + call MAPL_VarWrite(OutFmt,'SNDZN3',var_put) STATUS = NF_CLOSE ( NCFID) @@ -2432,22 +2432,22 @@ END SUBROUTINE put_land_vars ! ***************************************************************************** subroutine init_MPI() - + ! initialize MPI - + call MPI_INIT(mpierr) - + call MPI_COMM_RANK( MPI_COMM_WORLD, myid, mpierr ) call MPI_COMM_SIZE( MPI_COMM_WORLD, numprocs, mpierr ) if (myid .ne. 0) root_proc = .false. - -! write (*,*) "MPI process ", myid, " of ", numprocs, " is alive" + +! write (*,*) "MPI process ", myid, " of ", numprocs, " is alive" ! write (*,*) "MPI process ", myid, ": root_proc=", root_proc end subroutine init_MPI ! ***************************************************************************** - + end program mk_CatchCNRestarts diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_GEOSldasRestarts.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_GEOSldasRestarts.F90 index 5e3da8d3a..af444ff9e 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_GEOSldasRestarts.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_GEOSldasRestarts.F90 @@ -3,7 +3,7 @@ PROGRAM mk_GEOSldasRestarts -! USAGE/HELP (NOTICE mpirun -np 1) +! USAGE/HELP (NOTICE mpirun -np 1) ! mpirun -np 1 bin/mk_GEOSldasRestarts.x -h ! ! (1) to create an initial catch(cn)_internal_rst file ready for an offline experiment : @@ -11,26 +11,26 @@ PROGRAM mk_GEOSldasRestarts ! (1.1) mpirun -np 1 bin/mk_GEOSldasRestarts.x -a SPONSORCODE -b BCSDIR -m MODEL -s SURFLAY(20/50) -t TILFILE ! where MODEL : catch or catchcn ! (1.2) sbatch mkLDAS.j -! +! ! (2) to reorder an LDASsa restart file to the order of the BCs for use in an GCM experiment : ! -------------------------------------------------------------------------------------------- ! mpirun -np 1 bin/mk_GEOSldasRestarts.x -b BCSDIR -d YYYYMMDD -e EXPNAME -l EXPDIR -m MODEL -s SURFLAY(20/50) -r Y -t TILFILE -p PARAMFILE use netcdf use MAPL use mk_restarts_getidsMod, only: GetIDs, ReadTileFile_RealLatLon - use gFTL_StringVector + use gFTL_StringVector use ieee_arithmetic, only: isnan => ieee_is_nan USE STIEGLITZSNOW, ONLY : & - StieglitzSnow_calc_tpsnow + StieglitzSnow_calc_tpsnow implicit none include 'mpif.h' INCLUDE 'netcdf.inc' - + ! initialize to non-MPI values - + integer :: myid=0, numprocs=1, mpierr logical :: root_proc=.true. - + ! Carbon model specifics ! ---------------------- @@ -44,12 +44,12 @@ PROGRAM mk_GEOSldasRestarts real, parameter :: PERIHELION = 102.0 real, parameter :: OBLIQUITY = 23.45 integer, parameter :: EQUINOX = 80 - + integer, parameter :: nveg = 4 integer, parameter :: nzone = 3 integer, parameter :: VAR_COL_CLM40 = 40 ! number of CN column restart variables integer, parameter :: VAR_PFT_CLM40 = 74 ! number of CN PFT variables per column - integer, parameter :: npft = 19 + integer, parameter :: npft = 19 integer, parameter :: npft_clm45 = 19 integer, parameter :: VAR_COL_CLM45 = 35 ! number of CN column restart variables integer, parameter :: VAR_PFT_CLM45 = 75 ! number of CN PFT variables per column @@ -75,10 +75,10 @@ PROGRAM mk_GEOSldasRestarts InCNTilFile = '/discover/nobackup/projects/gmao/bcs_shared/legacy_bcs/Heracles-NL/SMAP_EASEv2_M09/SMAP_EASEv2_M09_3856x1624.til', & InCatRestart= '/discover/nobackup/projects/gmao/ssd/land/l_data/LandRestarts_for_Regridding/Catch/M09/20170101/catch_internal_rst', & InCatTilFile= '/discover/nobackup/projects/gmao/ssd/land/l_data/geos5/bcs/CLSM_params/mkCatchParam_SMAP_L4SM_v002/' & - //'SMAP_EASEv2_M09/SMAP_EASEv2_M09_3856x1624.til', & + //'SMAP_EASEv2_M09/SMAP_EASEv2_M09_3856x1624.til', & InCatRest45 = '/discover/nobackup/projects/gmao/ssd/land/l_data/LandRestarts_for_Regridding/Catch/M09/20170101/catch_internal_rst', & InCatTil45 = '/discover/nobackup/projects/gmao/ssd/land/l_data/geos5/bcs/CLSM_params/mkCatchParam_SMAP_L4SM_v002/' & - //'SMAP_EASEv2_M09/SMAP_EASEv2_M09_3856x1624.til' + //'SMAP_EASEv2_M09/SMAP_EASEv2_M09_3856x1624.til' REAL :: SURFLAY = 50. integer :: STATUS @@ -133,7 +133,7 @@ PROGRAM mk_GEOSldasRestarts CALL get_command (cmd) call getenv ("ESMADIR" ,ESMADIR ) nxt = 1 - + call getarg(nxt,arg) rstfile = 'NONE' do while(arg(1:1)=='-') @@ -220,18 +220,18 @@ PROGRAM mk_GEOSldasRestarts call MPI_Barrier(MPI_COMM_WORLD, STATUS) call MPI_FINALIZE(mpierr) - call exit(0) + call exit(0) elseif (trim(REORDER) == 'R') then ! This call is to regrid LDASsa/GEOSldas restarts from a different grid (RESTART: 2) - + call regrid_from_xgrid (SURFLAY, BCSDIR, YYYYMMDDHH, EXPNAME, EXPDIR, MODEL, PFILE, rstfile) - + call MPI_Barrier(MPI_COMM_WORLD, STATUS) call MPI_FINALIZE(mpierr) call exit(0) - + else ! The user does not have restarts, thus cold start (RESTART: 0) @@ -248,7 +248,7 @@ PROGRAM mk_GEOSldasRestarts open (10, file ='mkLDASsa.j', form = 'formatted', status ='unknown', action = 'write') write(10,'(a)')'#!/bin/csh -fx' - write(10,'(a)')' ' + write(10,'(a)')' ' write(10,'(a)')'#SBATCH --account='//trim(SPONSORCODE) write(10,'(a)')'#SBATCH --time=1:00:00' write(10,'(a)')'#SBATCH --ntasks=56' @@ -256,7 +256,7 @@ PROGRAM mk_GEOSldasRestarts write(10,'(a)')'###SBATCH --constraint=hasw' write(10,'(a)')'#SBATCH --output=mkLDAS.o' write(10,'(a)')'#SBATCH --error=mkLDAS.e' - write(10,'(a)')' ' + write(10,'(a)')' ' write(10,'(a)')'limit stacksize unlimited' write(10,'(a)')'source bin/g5_modules' !tmpstring = "set BINDIR=`ls -l bin | cut -d'>' -f2`" @@ -265,7 +265,7 @@ PROGRAM mk_GEOSldasRestarts write(10,'(a)')'setenv ESMADIR '//trim(ESMADIR) write(10,'(a)')'setenv MKL_CBWR SSE4_2 # ensure zero-diff across archs' write(10,'(a)')'setenv MV2_ON_DEMAND_THRESHOLD 8192 # MVAPICH2' - write(10,'(a)')' ' + write(10,'(a)')' ' write(10,'(a)')'mpirun -np 56 '//trim(cmd)//' -j Y' write(10,'(a)')'bin/'//trim(catch_scaler)//' InData/'//model//'_internal_rst OutData/'//model//'_internal_rst '//model//'_internal_rst '//trim(SFL) @@ -275,12 +275,12 @@ PROGRAM mk_GEOSldasRestarts stop endif endif - + if (root_proc) then - - ! read in ntiles + + ! read in ntiles ! ---------------------------- - + open (10,file = trim(BCSDIR)//'/clsm/catchment.def', form = 'formatted', status ='old', action = 'read') read (10,*) ntiles close (10, status ='keep') @@ -288,29 +288,29 @@ PROGRAM mk_GEOSldasRestarts endif call MPI_BCAST(NTILES , 1, MPI_INTEGER , 0,MPI_COMM_WORLD,mpierr) - + ! Regridding inquire(file='InData/'//trim(MODEL)//'_internal_rst',exist=second_visit ) if(.not. second_visit) then - call regrid_hyd_vars (NTILES, trim(MODEL)) + call regrid_hyd_vars (NTILES, trim(MODEL)) call MPI_Barrier(MPI_COMM_WORLD, STATUS) stop endif - if (root_proc) then + if (root_proc) then call read_bcs_data (NTILES, SURFLAY, trim(MODEL),'OutData/clsm/','OutData/'//trim(MODEL)//'_internal_rst', __RC__) endif call MPI_Barrier(MPI_COMM_WORLD, STATUS) - if(index(MODEL,'catchcn') /=0) then + if(index(MODEL,'catchcn') /=0) then - call regrid_carbon_vars (NTILES, model) + call regrid_carbon_vars (NTILES, model) endif call MPI_FINALIZE(mpierr) - + contains ! ***************************************************************************** @@ -326,37 +326,37 @@ SUBROUTINE regrid_from_xgrid (SURFLAY, BCSDIR, YYYYMMDDHH, EXPNAME, EXPDIR, MOD integer :: NTILES, nv, iv, i,j,k,n, nx, nz, ndims,dimSizes(3), NTILES_RST,nplus, STATUS,NCFID, req, filetype, OUTID integer, allocatable :: LDAS2BCS (:), tile_id(:) real, allocatable :: var1(:), var2(:),wesn1(:), htsn1(:), lon_rst(:), lat_rst(:) - logical :: fexist, bin_out = .false., lendian = .true. - real , allocatable, dimension (:) :: LATT, LONN, DAYX + logical :: fexist, bin_out = .false., lendian = .true. + real , allocatable, dimension (:) :: LATT, LONN, DAYX real , pointer , dimension (:) :: long, latg, lonc, latc - integer, allocatable, dimension (:) :: low_ind, upp_ind, nt_local + integer, allocatable, dimension (:) :: low_ind, upp_ind, nt_local integer, allocatable, dimension (:) :: Id_glb, id_loc - integer, allocatable, dimension (:,:) :: Id_glb_cn, id_loc_cn + integer, allocatable, dimension (:,:) :: Id_glb_cn, id_loc_cn integer, allocatable, dimension (:) :: ld_reorder, tid_offl real, allocatable, dimension (:) :: CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2, & - CLMC_pt1, CLMC_pt2,CLMC_st1,CLMC_st2, var_dum2 + CLMC_pt1, CLMC_pt2,CLMC_st1,CLMC_st2, var_dum2 integer :: AGCM_YY,AGCM_MM,AGCM_DD,AGCM_HR=0,AGCM_DATE real, allocatable, dimension(:,:) :: fveg_offl, ityp_offl, fveg_tmp, ityp_tmp - real, allocatable :: var_off_col (:,:,:), var_off_pft (:,:,:,:) + real, allocatable :: var_off_col (:,:,:), var_off_pft (:,:,:,:) type(Netcdf4_FileFormatter) :: ldFmt type(FileMetadata) :: meta_data - character(256) :: Iam = "regrid_from_xgrid" + character(256) :: Iam = "regrid_from_xgrid" ! read NTILES from output BCs and tile_coord from GEOSldas/LDASsa input restarts - + open (10,file =trim(BCSDIR)//"clsm/catchment.def",status='old',form='formatted') read (10,*) ntiles - close (10, status = 'keep') + close (10, status = 'keep') ! Determine whether LDASsa or GEOSldas if (trim(rstfile) == "NONE") then if (trim(MODEL) == 'catch') then rst_file = trim(EXPDIR)//'rs/ens'//ENS//'/Y'//YYYYMMDDHH(1:4)//'/M'//YYYYMMDDHH(5:6)//'/'//trim(ExpName)//& - '.catch_internal_rst.'//YYYYMMDDHH(1:8)//'_'//YYYYMMDDHH(9:10)//'00' + '.catch_internal_rst.'//YYYYMMDDHH(1:8)//'_'//YYYYMMDDHH(9:10)//'00' inquire(file = trim(rst_file), exist=fexist) if (.not.fexist) then rst_file = trim(EXPDIR)//'rs/ens'//ENS//'/Y'//YYYYMMDDHH(1:4)//'/M'//YYYYMMDDHH(5:6)//'/' & //trim(ExpName)//'.ens'//ENS//'.catch_ldas_rst.'// & - YYYYMMDDHH(1:8)//'_'//YYYYMMDDHH(9:10)//'00z.bin' + YYYYMMDDHH(1:8)//'_'//YYYYMMDDHH(9:10)//'00z.bin' lendian = .false. endif else !catchcn @@ -365,7 +365,7 @@ SUBROUTINE regrid_from_xgrid (SURFLAY, BCSDIR, YYYYMMDDHH, EXPNAME, EXPDIR, MOD inquire(file = trim(rst_file), exist=fexist) if (.not. fexist) then rst_file = trim(EXPDIR)//'rs/ens'//ENS//'/Y'//YYYYMMDDHH(1:4)//'/M'//YYYYMMDDHH(5:6)//'/'//trim(ExpName)//& - '.ens'//ENS//'.'//trim(MODEL)//'_ldas_rst.'//YYYYMMDDHH(1:8)//'_'//YYYYMMDDHH(9:10)//'00z' + '.ens'//ENS//'.'//trim(MODEL)//'_ldas_rst.'//YYYYMMDDHH(1:8)//'_'//YYYYMMDDHH(9:10)//'00z' lendian = .false. endif endif ! catch @@ -374,13 +374,13 @@ SUBROUTINE regrid_from_xgrid (SURFLAY, BCSDIR, YYYYMMDDHH, EXPNAME, EXPDIR, MOD if (index(rst_file, "_ldas_rst") /=0) lendian = .false. endif - if (index(MODEL, 'catchcn') /=0) then + if (index(MODEL, 'catchcn') /=0) then call ldFmt%open(trim(rst_file) , pFIO_READ,__RC__) meta_data = ldFmt%read(__RC__) call ldFmt%close(__RC__) if(meta_data%get_dimension('unknown_dim3',rc=status) == 105) then clm45 = .true. - VAR_COL = VAR_COL_CLM45 + VAR_COL = VAR_COL_CLM45 VAR_PFT = VAR_PFT_CLM45 if (root_proc) print *, 'Processing CLM45 restarts : ', VAR_COL, VAR_PFT, clm45 else @@ -403,7 +403,7 @@ SUBROUTINE regrid_from_xgrid (SURFLAY, BCSDIR, YYYYMMDDHH, EXPNAME, EXPDIR, MOD endif read (10) NTILES_RST - + if(root_proc) then print *,'NTILES in BCs : ',NTILES print *,'NTILES in restarts : ',NTILES_RST @@ -417,18 +417,18 @@ SUBROUTINE regrid_from_xgrid (SURFLAY, BCSDIR, YYYYMMDDHH, EXPNAME, EXPDIR, MOD allocate(nt_local( numprocs)) low_ind (:) = 1 - upp_ind (:) = NTILES - nt_local(:) = NTILES + upp_ind (:) = NTILES + nt_local(:) = NTILES - if (numprocs > 1) then + if (numprocs > 1) then do i = 1, numprocs - 1 - upp_ind(i) = low_ind(i) + (ntiles/numprocs) - 1 + upp_ind(i) = low_ind(i) + (ntiles/numprocs) - 1 low_ind(i+1) = upp_ind(i) + 1 nt_local(i) = upp_ind(i) - low_ind(i) + 1 end do nt_local(numprocs) = upp_ind(numprocs) - low_ind(numprocs) + 1 endif - + allocate (id_loc (nt_local (myid + 1))) allocate (lonn (nt_local (myid + 1))) allocate (latt (nt_local (myid + 1))) @@ -439,7 +439,7 @@ SUBROUTINE regrid_from_xgrid (SURFLAY, BCSDIR, YYYYMMDDHH, EXPNAME, EXPDIR, MOD if (root_proc) then allocate (long (ntiles)) allocate (latg (ntiles)) - allocate (ld_reorder(ntiles_rst)) + allocate (ld_reorder(ntiles_rst)) allocate (tile_id (1:ntiles_rst)) allocate (LDAS2BCS (1:ntiles_rst)) allocate (lon_rst (1:ntiles_rst)) @@ -451,17 +451,17 @@ SUBROUTINE regrid_from_xgrid (SURFLAY, BCSDIR, YYYYMMDDHH, EXPNAME, EXPDIR, MOD read (10) tile_id read (10) tile_id read (10) lon_rst - read (10) lat_rst + read (10) lat_rst tile_id = LDAS2BCS - do n = 1, NTILES_RST + do n = 1, NTILES_RST ld_reorder (tile_id(n)) = n tid_offl(n) = n end do do n = 1, NTILES_RST - lonc(n) = lon_rst(ld_reorder(n)) - latc(n) = lat_rst(ld_reorder(n)) + lonc(n) = lon_rst(ld_reorder(n)) + latc(n) = lat_rst(ld_reorder(n)) END DO deallocate (lon_rst, lat_rst) endif @@ -481,28 +481,28 @@ SUBROUTINE regrid_from_xgrid (SURFLAY, BCSDIR, YYYYMMDDHH, EXPNAME, EXPDIR, MOD else if (myid == 0) then ! root sends call MPI_ISend(long(low_ind(i) : upp_ind(i)),nt_local(i),MPI_REAL,i-1,995,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) + call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) call MPI_ISend(latg(low_ind(i) : upp_ind(i)),nt_local(i),MPI_REAL,i-1,994,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) + call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) endif endif end do if(root_proc) deallocate (long) - + call MPI_BCAST(lonc,ntiles_rst,MPI_REAL,0,MPI_COMM_WORLD,mpierr) call MPI_BCAST(latc,ntiles_rst,MPI_REAL,0,MPI_COMM_WORLD,mpierr) call MPI_BCAST(tid_offl,size(tid_offl ),MPI_INTEGER,0,MPI_COMM_WORLD,mpierr) ! -------------------------------------------------------------------------------- ! Here we create transfer index array to map offline restarts to output tile space - ! -------------------------------------------------------------------------------- + ! -------------------------------------------------------------------------------- ! id_glb for hydrologic variable call GetIds(lonc,latc,lonn,latt,id_loc, tid_offl) if(root_proc) allocate (id_glb (ntiles)) - + call MPI_Barrier(MPI_COMM_WORLD, STATUS) ! call MPI_GATHERV( & ! id_loc, nt_local(myid+1) , MPI_real, & @@ -515,7 +515,7 @@ SUBROUTINE regrid_from_xgrid (SURFLAY, BCSDIR, YYYYMMDDHH, EXPNAME, EXPDIR, MOD if(I-1 == myid) then ! send to root call MPI_ISend(id_loc,nt_local(i),MPI_INTEGER,0,993,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) + call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) else if (myid == 0) then ! root receives call MPI_RECV(id_glb(low_ind(i) : upp_ind(i)),nt_local(i) , MPI_INTEGER, i-1,993,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) @@ -525,8 +525,8 @@ SUBROUTINE regrid_from_xgrid (SURFLAY, BCSDIR, YYYYMMDDHH, EXPNAME, EXPDIR, MOD deallocate (id_loc) - if(root_proc) then - + if(root_proc) then + inquire(file = trim(rst_file), exist=fexist) if (.not. fexist) then print*, "WARNING!!" @@ -546,7 +546,7 @@ SUBROUTINE regrid_from_xgrid (SURFLAY, BCSDIR, YYYYMMDDHH, EXPNAME, EXPDIR, MOD else call read_ldas_restarts (NTILES, ntiles_rst, id_glb, ld_reorder, rst_file, pfile) endif - + ! ==================== ! READ AND PUT OUT BCS ! ==================== @@ -576,9 +576,9 @@ SUBROUTINE regrid_from_xgrid (SURFLAY, BCSDIR, YYYYMMDDHH, EXPNAME, EXPDIR, MOD allocate (CLMC_st1(nt_local (myid + 1))) allocate (CLMC_st2(nt_local (myid + 1))) allocate (ityp_offl (ntiles_rst,nveg)) - allocate (fveg_offl (ntiles_rst,nveg)) + allocate (fveg_offl (ntiles_rst,nveg)) allocate (id_loc_cn (nt_local (myid + 1),nveg)) - + ! STATUS = NF90_OPEN ('OutData/catchcn_internal_rst',NF_WRITE,OUTID) ; VERIFY_(STATUS) STATUS = NF_OPEN_PAR ('OutData/'//trim(model)//'_internal_rst',IOR(NF_WRITE,NF_MPIIO),MPI_COMM_WORLD, infos,OUTID) ; VERIFY_(STATUS) STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/low_ind(myid+1),1/), (/nt_local(myid+1),1/),CLMC_pt1) @@ -589,30 +589,30 @@ SUBROUTINE regrid_from_xgrid (SURFLAY, BCSDIR, YYYYMMDDHH, EXPNAME, EXPDIR, MOD STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/low_ind(myid+1),2/), (/nt_local(myid+1),1/),CLMC_pf2) STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/low_ind(myid+1),3/), (/nt_local(myid+1),1/),CLMC_sf1) STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/low_ind(myid+1),4/), (/nt_local(myid+1),1/),CLMC_sf2) - + if (root_proc) then allocate (ityp_tmp (ntiles_rst,nveg)) - allocate (fveg_tmp (ntiles_rst,nveg)) + allocate (fveg_tmp (ntiles_rst,nveg)) allocate (DAYX (NTILES)) - READ(YYYYMMDDHH(1:8),'(I8)') AGCM_DATE + READ(YYYYMMDDHH(1:8),'(I8)') AGCM_DATE AGCM_YY = AGCM_DATE / 10000 AGCM_MM = (AGCM_DATE - AGCM_YY*10000) / 100 AGCM_DD = (AGCM_DATE - AGCM_YY*10000 - AGCM_MM*100) - + call compute_dayx ( & NTILES, AGCM_YY, AGCM_MM, AGCM_DD, AGCM_HR, & - LATG, DAYX) - + LATG, DAYX) + STATUS = NF_OPEN (trim(rst_file),NF_NOWRITE,NCFID) ; VERIFY_(STATUS) STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ITY'), (/1,1/), (/ntiles_rst,4/),ityp_tmp) - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'FVG'), (/1,1/), (/ntiles_rst,4/),fveg_tmp) + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'FVG'), (/1,1/), (/ntiles_rst,4/),fveg_tmp) do n = 1, NTILES_RST ityp_offl (n,:) = ityp_tmp (ld_reorder(n),:) fveg_offl (n,:) = fveg_tmp (ld_reorder(n),:) - + if((ityp_offl(N,3) == 0).and.(ityp_offl(N,4) == 0)) then if(ityp_offl(N,1) /= 0) then ityp_offl(N,3) = ityp_offl(N,1) @@ -620,7 +620,7 @@ SUBROUTINE regrid_from_xgrid (SURFLAY, BCSDIR, YYYYMMDDHH, EXPNAME, EXPDIR, MOD ityp_offl(N,3) = ityp_offl(N,2) endif endif - + if((ityp_offl(N,1) == 0).and.(ityp_offl(N,2) /= 0)) ityp_offl(N,1) = ityp_offl(N,2) if((ityp_offl(N,2) == 0).and.(ityp_offl(N,1) /= 0)) ityp_offl(N,2) = ityp_offl(N,1) if((ityp_offl(N,3) == 0).and.(ityp_offl(N,4) /= 0)) ityp_offl(N,3) = ityp_offl(N,4) @@ -630,7 +630,7 @@ SUBROUTINE regrid_from_xgrid (SURFLAY, BCSDIR, YYYYMMDDHH, EXPNAME, EXPDIR, MOD endif call MPI_BCAST(ityp_offl,size(ityp_offl),MPI_REAL ,0,MPI_COMM_WORLD,mpierr) - call MPI_BCAST(fveg_offl,size(fveg_offl),MPI_REAL ,0,MPI_COMM_WORLD,mpierr) + call MPI_BCAST(fveg_offl,size(fveg_offl),MPI_REAL ,0,MPI_COMM_WORLD,mpierr) call GetIds(lonc,latc,lonn,latt,id_loc_cn, tid_offl, & CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2, CLMC_pt1, CLMC_pt2,CLMC_st1,CLMC_st2, & @@ -649,7 +649,7 @@ SUBROUTINE regrid_from_xgrid (SURFLAY, BCSDIR, YYYYMMDDHH, EXPNAME, EXPDIR, MOD ! id_loc (:,nv), nt_local(myid+1) , MPI_real, & ! id_vec, nt_local,low_ind-1, MPI_real, & ! 0, MPI_COMM_WORLD, mpierr ) - + do i = 1, numprocs if((I == 1).and.(myid == 0)) then id_loc(low_ind(i) : upp_ind(i)) = Id_loc_cn(:,nv) @@ -657,24 +657,24 @@ SUBROUTINE regrid_from_xgrid (SURFLAY, BCSDIR, YYYYMMDDHH, EXPNAME, EXPDIR, MOD if(I-1 == myid) then ! send to root call MPI_ISend(id_loc_cn(:,nv),nt_local(i),MPI_INTEGER,0,994,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) + call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) else if (myid == 0) then ! root receives call MPI_RECV(id_loc(low_ind(i) : upp_ind(i)),nt_local(i) , MPI_INTEGER, i-1,994,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) endif endif end do - + if(root_proc) id_glb_cn (:,nv) = id_loc - + end do - + if(root_proc) then allocate (var_off_col (1: NTILES_RST, 1 : nzone,1 : var_col)) allocate (var_off_pft (1: NTILES_RST, 1 : nzone,1 : nveg, 1 : var_pft)) allocate (var_dum2 (1:ntiles_rst)) - + i = 1 do nv = 1,VAR_COL do nz = 1,nzone @@ -685,7 +685,7 @@ SUBROUTINE regrid_from_xgrid (SURFLAY, BCSDIR, YYYYMMDDHH, EXPNAME, EXPDIR, MOD i = i + 1 end do end do - + i = 1 do iv = 1,VAR_PFT do nv = 1,nveg @@ -698,20 +698,20 @@ SUBROUTINE regrid_from_xgrid (SURFLAY, BCSDIR, YYYYMMDDHH, EXPNAME, EXPDIR, MOD end do end do end do - - where(isnan(var_off_pft)) var_off_pft = 0. - where(var_off_pft /= var_off_pft) var_off_pft = 0. + + where(isnan(var_off_pft)) var_off_pft = 0. + where(var_off_pft /= var_off_pft) var_off_pft = 0. print *, 'Writing regridded carbn' call write_regridded_carbon (NTILES, ntiles_rst, NCFID, OUTID, id_glb_cn, & - DAYX, var_off_col,var_off_pft, ityp_offl, fveg_offl) - deallocate (var_off_col,var_off_pft) + DAYX, var_off_col,var_off_pft, ityp_offl, fveg_offl) + deallocate (var_off_col,var_off_pft) endif call MPI_Barrier(MPI_COMM_WORLD, STATUS) STATUS = NF_CLOSE (OutID) endif - + END SUBROUTINE regrid_from_xgrid - + ! ***************************************************************************** SUBROUTINE reorder_LDASsa_restarts (SURFLAY, BCSDIR, YYYYMMDDHH, EXPNAME, EXPDIR, MODEL, ENS, rstfile, rc) @@ -737,9 +737,9 @@ SUBROUTINE reorder_LDASsa_restarts (SURFLAY, BCSDIR, YYYYMMDDHH, EXPNAME, EXPDI logical :: fexist, bin_out = .false. character(len=:), allocatable :: ftype character*256 :: Iam = "reorder_LDASsa_restarts" - integer :: status - - if (trim(rstfile) == "NONE") then + integer :: status + + if (trim(rstfile) == "NONE") then ftype = '' if(trim(MODEL) == 'catch') ftype='.bin' rst_file = trim(EXPDIR)//'rs/ens'//ENS//'/Y'//YYYYMMDDHH(1:4)//'/M'//YYYYMMDDHH(5:6)//'/'//trim(ExpName)//& @@ -763,7 +763,7 @@ SUBROUTINE reorder_LDASsa_restarts (SURFLAY, BCSDIR, YYYYMMDDHH, EXPNAME, EXPDI meta_data = ldFmt%read(__RC__) call ldFmt%close(__RC__) if(meta_data%get_dimension('unknown_dim3',rc=status) == 105) then - VAR_COL = VAR_COL_CLM45 + VAR_COL = VAR_COL_CLM45 VAR_PFT = VAR_PFT_CLM45 if ( .not. clm45) stop ' ERROR: Given clm45 restart, but the model is not clm45' if (root_proc) print *, 'Processing CLM45 restarts : ', VAR_COL, VAR_PFT, clm45 @@ -771,10 +771,10 @@ SUBROUTINE reorder_LDASsa_restarts (SURFLAY, BCSDIR, YYYYMMDDHH, EXPNAME, EXPDI if (root_proc) print *, 'Processing CLM40 restarts : ', VAR_COL, VAR_PFT, clm45 endif endif - + open (10,file =trim(BCSDIR)//"clsm/catchment.def",status='old',form='formatted') read (10,*) ntiles - close (10, status = 'keep') + close (10, status = 'keep') ! read NTILES from BCs and tile_coord from LDASsa experiment @@ -787,7 +787,7 @@ SUBROUTINE reorder_LDASsa_restarts (SURFLAY, BCSDIR, YYYYMMDDHH, EXPNAME, EXPDI open (10,file =trim(tile_coord),status='old',form='unformatted',convert='big_endian') read (10) i - if (i /= ntiles) then + if (i /= ntiles) then print *,'NTILES BCs/LDASsa mismatch:', i,ntiles stop endif @@ -825,196 +825,196 @@ SUBROUTINE reorder_LDASsa_restarts (SURFLAY, BCSDIR, YYYYMMDDHH, EXPNAME, EXPDI allocate(var1(ntiles)) allocate(var2(ntiles)) allocate(wesn1 (ntiles)) - allocate(htsn1 (ntiles)) + allocate(htsn1 (ntiles)) ! CH CM CQ FR WW ! WW var1 = 0.1 do j = 1,4 - call MAPL_VarWrite(OutFmt,'WW',var1 ,offset1=j) + call MAPL_VarWrite(OutFmt,'WW',var1 ,offset1=j) end do ! FR var1 = 0.25 do j = 1,4 - call MAPL_VarWrite(OutFmt,'FR',var1 ,offset1=j) + call MAPL_VarWrite(OutFmt,'FR',var1 ,offset1=j) end do - ! CH CM CQ + ! CH CM CQ var1 = 0.001 do j = 1,4 - call MAPL_VarWrite(OutFmt,'CH',var1 ,offset1=j) - call MAPL_VarWrite(OutFmt,'CM',var1 ,offset1=j) - call MAPL_VarWrite(OutFmt,'CQ',var1 ,offset1=j) + call MAPL_VarWrite(OutFmt,'CH',var1 ,offset1=j) + call MAPL_VarWrite(OutFmt,'CM',var1 ,offset1=j) + call MAPL_VarWrite(OutFmt,'CQ',var1 ,offset1=j) end do - + tile_id = LDAS2BCS - do n = 1, NTILES + do n = 1, NTILES G2D(tile_id(n)) = n end do - - if(trim(MODEL) == 'catch') then + + if(trim(MODEL) == 'catch') then open(10, file=trim(rst_file), form='unformatted', status='old', & convert='big_endian', action='read') - + var1 = real(tile_id) var2 = var1 (tile_id) - do n = 1, NTILES + do n = 1, NTILES var2(n) = var1(g2d(n)) end do call MAPL_VarWrite(OutFmt,'TILE_ID' ,var2) read(10) var1 var2 = var1 (tile_id) - do n = 1, NTILES + do n = 1, NTILES var2(n) = var1(g2d(n)) end do call MAPL_VarWrite(OutFmt,'TC' ,var2, offset1=1) read(10) var1 var2 = var1 (tile_id) - do n = 1, NTILES + do n = 1, NTILES var2(n) = var1(g2d(n)) end do call MAPL_VarWrite(OutFmt,'TC' ,var2, offset1=2) read(10) var1 var2 = var1 (tile_id) - do n = 1, NTILES + do n = 1, NTILES var2(n) = var1(g2d(n)) end do call MAPL_VarWrite(OutFmt,'TC' ,var2, offset1=3) - + read(10) var1 var2 = var1 (tile_id) - do n = 1, NTILES + do n = 1, NTILES var2(n) = var1(g2d(n)) end do call MAPL_VarWrite(OutFmt,'QC' ,var2, offset1=1) read(10) var1 var2 = var1 (tile_id) - do n = 1, NTILES + do n = 1, NTILES var2(n) = var1(g2d(n)) end do call MAPL_VarWrite(OutFmt,'QC' ,var2, offset1=2) read(10) var1 var2 = var1 (tile_id) - do n = 1, NTILES + do n = 1, NTILES var2(n) = var1(g2d(n)) end do call MAPL_VarWrite(OutFmt,'QC' ,var2, offset1=3) call MAPL_VarWrite(OutFmt,'QC' ,var2, offset1=4) - + read(10) var1 var2 = var1 (tile_id) - do n = 1, NTILES + do n = 1, NTILES var2(n) = var1(g2d(n)) end do call MAPL_VarWrite(OutFmt,'CAPAC' ,var2) read(10) var1 var2 = var1 (tile_id) - do n = 1, NTILES + do n = 1, NTILES var2(n) = var1(g2d(n)) end do call MAPL_VarWrite(OutFmt,'CATDEF' ,var2) read(10) var1 var2 = var1 (tile_id) - do n = 1, NTILES + do n = 1, NTILES var2(n) = var1(g2d(n)) end do call MAPL_VarWrite(OutFmt,'RZEXC' ,var2) read(10) var1 var2 = var1 (tile_id) - do n = 1, NTILES + do n = 1, NTILES var2(n) = var1(g2d(n)) end do call MAPL_VarWrite(OutFmt,'SRFEXC' ,var2) read(10) var1 var2 = var1 (tile_id) - do n = 1, NTILES + do n = 1, NTILES var2(n) = var1(g2d(n)) end do - call MAPL_VarWrite(OutFmt,'GHTCNT1' ,var2) + call MAPL_VarWrite(OutFmt,'GHTCNT1' ,var2) read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES + var2 = var1 (tile_id) + do n = 1, NTILES var2(n) = var1(g2d(n)) end do - call MAPL_VarWrite(OutFmt,'GHTCNT2' ,var2) + call MAPL_VarWrite(OutFmt,'GHTCNT2' ,var2) read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES + var2 = var1 (tile_id) + do n = 1, NTILES var2(n) = var1(g2d(n)) end do - call MAPL_VarWrite(OutFmt,'GHTCNT3' ,var2) + call MAPL_VarWrite(OutFmt,'GHTCNT3' ,var2) read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES + var2 = var1 (tile_id) + do n = 1, NTILES var2(n) = var1(g2d(n)) end do - call MAPL_VarWrite(OutFmt,'GHTCNT4' ,var2) + call MAPL_VarWrite(OutFmt,'GHTCNT4' ,var2) read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES + var2 = var1 (tile_id) + do n = 1, NTILES var2(n) = var1(g2d(n)) end do - call MAPL_VarWrite(OutFmt,'GHTCNT5' ,var2) + call MAPL_VarWrite(OutFmt,'GHTCNT5' ,var2) read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES + var2 = var1 (tile_id) + do n = 1, NTILES var2(n) = var1(g2d(n)) end do - call MAPL_VarWrite(OutFmt,'GHTCNT6' ,var2) + call MAPL_VarWrite(OutFmt,'GHTCNT6' ,var2) read(10) var1 - var2 = var1 (tile_id) - - do n = 1, NTILES + var2 = var1 (tile_id) + + do n = 1, NTILES var2(n) = var1(g2d(n)) end do wesn1 = var2 call MAPL_VarWrite(OutFmt,'WESNN1' ,var2) read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES + var2 = var1 (tile_id) + do n = 1, NTILES var2(n) = var1(g2d(n)) end do call MAPL_VarWrite(OutFmt,'WESNN2' ,var2) read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES + var2 = var1 (tile_id) + do n = 1, NTILES var2(n) = var1(g2d(n)) end do call MAPL_VarWrite(OutFmt,'WESNN3' ,var2) read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES + var2 = var1 (tile_id) + do n = 1, NTILES var2(n) = var1(g2d(n)) end do htsn1 = var2 call MAPL_VarWrite(OutFmt,'HTSNNN1' ,var2) read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES + var2 = var1 (tile_id) + do n = 1, NTILES var2(n) = var1(g2d(n)) end do call MAPL_VarWrite(OutFmt,'HTSNNN2' ,var2) read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES + var2 = var1 (tile_id) + do n = 1, NTILES var2(n) = var1(g2d(n)) end do call MAPL_VarWrite(OutFmt,'HTSNNN3' ,var2) read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES + var2 = var1 (tile_id) + do n = 1, NTILES var2(n) = var1(g2d(n)) end do call MAPL_VarWrite(OutFmt,'SNDZN1' ,var2) read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES + var2 = var1 (tile_id) + do n = 1, NTILES var2(n) = var1(g2d(n)) end do call MAPL_VarWrite(OutFmt,'SNDZN2' ,var2) read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES + var2 = var1 (tile_id) + do n = 1, NTILES var2(n) = var1(g2d(n)) end do call MAPL_VarWrite(OutFmt,'SNDZN3' ,var2) @@ -1025,8 +1025,8 @@ SUBROUTINE reorder_LDASsa_restarts (SURFLAY, BCSDIR, YYYYMMDDHH, EXPNAME, EXPDI call OutFmt%close() close(10) - else ! CATCHCN - + else ! CATCHCN + call InFmt%open(trim(rst_file),pFIO_READ,__RC__) meta_data = InFmt%read(__RC__) @@ -1064,7 +1064,7 @@ SUBROUTINE reorder_LDASsa_restarts (SURFLAY, BCSDIR, YYYYMMDDHH, EXPNAME, EXPDI call MAPL_VarWrite(OutFmt,vname,var2) - else if (ndims == 2) then + else if (ndims == 2) then dname => var%get_ith_dimension(2) dim1=meta_data%get_dimension(dname) @@ -1126,10 +1126,10 @@ SUBROUTINE reorder_LDASsa_restarts (SURFLAY, BCSDIR, YYYYMMDDHH, EXPNAME, EXPDI !_RETURN(_SUCCESS) END SUBROUTINE reorder_LDASsa_restarts - + ! ***************************************************************************** - - SUBROUTINE regrid_hyd_vars (NTILES, model) + + SUBROUTINE regrid_hyd_vars (NTILES, model) implicit none integer, intent (in) :: NTILES @@ -1160,15 +1160,15 @@ SUBROUTINE regrid_hyd_vars (NTILES, model) allocate(nt_local( numprocs)) low_ind (:) = 1 - upp_ind (:) = NTILES - nt_local(:) = NTILES + upp_ind (:) = NTILES + nt_local(:) = NTILES ! Domain decomposition ! -------------------- - if (numprocs > 1) then + if (numprocs > 1) then do i = 1, numprocs - 1 - upp_ind(i) = low_ind(i) + (ntiles/numprocs) - 1 + upp_ind(i) = low_ind(i) + (ntiles/numprocs) - 1 low_ind(i+1) = upp_ind(i) + 1 nt_local(i) = upp_ind(i) - low_ind(i) + 1 end do @@ -1185,26 +1185,26 @@ SUBROUTINE regrid_hyd_vars (NTILES, model) allocate (long (ntiles)) allocate (latg (ntiles)) - allocate (ld_reorder(ntiles_smap)) + allocate (ld_reorder(ntiles_smap)) call ReadTileFile_RealLatLon ('InData/OutTileFile', i, xlon=long, xlat=latg); VERIFY_(i-ntiles) ! --------------------------------------------- - ! Read exact lonc, latc from offline .til File + ! Read exact lonc, latc from offline .til File ! --------------------------------------------- - + if(index(MODEL,'catchcn') /=0) then - call ReadTileFile_RealLatLon(trim(InCNTilFile ),i,xlon=lonc,xlat=latc) + call ReadTileFile_RealLatLon(trim(InCNTilFile ),i,xlon=lonc,xlat=latc) VERIFY_(i-ntiles_smap) endif if(trim(MODEL) == 'catch' ) then - call ReadTileFile_RealLatLon(trim(InCatTilFile),i,xlon=lonc,xlat=latc) + call ReadTileFile_RealLatLon(trim(InCatTilFile),i,xlon=lonc,xlat=latc) VERIFY_(i-ntiles_smap) endif if(index(MODEL,'catchcn') /=0) then STATUS = NF_OPEN (trim(InCNRestart ),NF_NOWRITE,NCFID) ; VERIFY_(STATUS) endif if(trim(MODEL) == 'catch' ) then - STATUS = NF_OPEN (trim(InCatRestart),NF_NOWRITE,NCFID) ; VERIFY_(STATUS) + STATUS = NF_OPEN (trim(InCatRestart),NF_NOWRITE,NCFID) ; VERIFY_(STATUS) endif STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TILE_ID' ), (/1/), (/NTILES_SMAP/),tmp_var) STATUS = NF_CLOSE (NCFID) @@ -1232,9 +1232,9 @@ SUBROUTINE regrid_hyd_vars (NTILES, model) else if (myid == 0) then ! root sends call MPI_ISend(long(low_ind(i) : upp_ind(i)),nt_local(i),MPI_REAL,i-1,995,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) + call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) call MPI_ISend(latg(low_ind(i) : upp_ind(i)),nt_local(i),MPI_REAL,i-1,994,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) + call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) endif endif end do @@ -1250,18 +1250,18 @@ SUBROUTINE regrid_hyd_vars (NTILES, model) ! 0,MPI_COMM_WORLD, mpierr ) if(root_proc) deallocate (long, latg) - + call MPI_BCAST(lonc,ntiles_smap,MPI_REAL,0,MPI_COMM_WORLD,mpierr) call MPI_BCAST(latc,ntiles_smap,MPI_REAL,0,MPI_COMM_WORLD,mpierr) call MPI_BCAST(tid_offl,size(tid_offl ),MPI_INTEGER,0,MPI_COMM_WORLD,mpierr) ! -------------------------------------------------------------------------------- ! Here we create transfer index array to map offline restarts to output tile space - ! -------------------------------------------------------------------------------- + ! -------------------------------------------------------------------------------- call GetIds(lonc,latc,lonn,latt,id_loc, tid_offl) - - ! Loop through NTILES (# of tiles in output array) find the nearest neighbor from Qing. + + ! Loop through NTILES (# of tiles in output array) find the nearest neighbor from Qing. if(root_proc) allocate (id_glb (ntiles)) @@ -1277,14 +1277,14 @@ SUBROUTINE regrid_hyd_vars (NTILES, model) if(I-1 == myid) then ! send to root call MPI_ISend(id_loc,nt_local(i),MPI_INTEGER,0,993,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) + call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) else if (myid == 0) then ! root receives call MPI_RECV(id_glb(low_ind(i) : upp_ind(i)),nt_local(i) , MPI_INTEGER, i-1,993,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) endif endif - end do - + end do + if (root_proc) call put_land_vars (NTILES, ntiles_smap, id_glb, ld_reorder, model) call MPI_Barrier(MPI_COMM_WORLD, STATUS) @@ -1293,14 +1293,14 @@ END SUBROUTINE regrid_hyd_vars ! ***************************************************************************** - + SUBROUTINE read_bcs_data (ntiles, SURFLAY,MODEL, DataDir, InRestart, rc) ! This subroutine : ! 1) reads BCs from BCSDIR and hydrological varables from InRestart. ! InRestart is a catchcn_internal_rst nc4 file. ! - ! 2) writes out BCs and hydrological variables in catchcn_internal_rst (1:72). + ! 2) writes out BCs and hydrological variables in catchcn_internal_rst (1:72). ! output catchcn_internal_rst is nc4. implicit none @@ -1309,18 +1309,18 @@ SUBROUTINE read_bcs_data (ntiles, SURFLAY,MODEL, DataDir, InRestart, rc) character(*), intent (in) :: MODEL, DataDir, InRestart integer, optional, intent(out) :: rc real, allocatable :: CLMC_pf1(:), CLMC_pf2(:), CLMC_sf1(:), CLMC_sf2(:) - real, allocatable :: CLMC_pt1(:), CLMC_pt2(:), CLMC_st1(:), CLMC_st2(:) + real, allocatable :: CLMC_pt1(:), CLMC_pt2(:), CLMC_st1(:), CLMC_st2(:) real, allocatable :: CLMC45_pf1(:), CLMC45_pf2(:), CLMC45_sf1(:), CLMC45_sf2(:) - real, allocatable :: CLMC45_pt1(:), CLMC45_pt2(:), CLMC45_st1(:), CLMC45_st2(:) + real, allocatable :: CLMC45_pt1(:), CLMC45_pt2(:), CLMC45_st1(:), CLMC45_st2(:) real, allocatable :: BF1(:), BF2(:), BF3(:), VGWMAX(:) - real, allocatable :: CDCR1(:), CDCR2(:), PSIS(:), BEE(:) + real, allocatable :: CDCR1(:), CDCR2(:), PSIS(:), BEE(:) real, allocatable :: POROS(:), WPWET(:), COND(:), GNU(:) real, allocatable :: ARS1(:), ARS2(:), ARS3(:) real, allocatable :: ARA1(:), ARA2(:), ARA3(:), ARA4(:) real, allocatable :: ARW1(:), ARW2(:), ARW3(:), ARW4(:) real, allocatable :: TSA1(:), TSA2(:), TSB1(:), TSB2(:) real, allocatable :: ATAU2(:), BTAU2(:), DP2BR(:), CanopH(:) - real, allocatable :: NDEP(:), BVISDR(:), BVISDF(:), BNIRDR(:), BNIRDF(:) + real, allocatable :: NDEP(:), BVISDR(:), BVISDF(:), BNIRDR(:), BNIRDF(:) real, allocatable :: T2(:), var1(:), hdm(:), fc(:), gdp(:), peatf(:), RITY(:) integer, allocatable :: ity(:), abm (:) integer :: NCFID, STATUS @@ -1330,10 +1330,10 @@ SUBROUTINE read_bcs_data (ntiles, SURFLAY,MODEL, DataDir, InRestart, rc) logical :: file_exists type(NetCDF4_Fileformatter) :: CatchFmt,CatchCNFmt character*256 :: Iam = "read_bcs_data" - + allocate ( BF1(ntiles), BF2 (ntiles), BF3(ntiles) ) - allocate (VGWMAX(ntiles), CDCR1(ntiles), CDCR2(ntiles) ) - allocate ( PSIS(ntiles), BEE(ntiles), POROS(ntiles) ) + allocate (VGWMAX(ntiles), CDCR1(ntiles), CDCR2(ntiles) ) + allocate ( PSIS(ntiles), BEE(ntiles), POROS(ntiles) ) allocate ( WPWET(ntiles), COND(ntiles), GNU(ntiles) ) allocate ( ARS1(ntiles), ARS2(ntiles), ARS3(ntiles) ) allocate ( ARA1(ntiles), ARA2(ntiles), ARA3(ntiles) ) @@ -1342,7 +1342,7 @@ SUBROUTINE read_bcs_data (ntiles, SURFLAY,MODEL, DataDir, InRestart, rc) allocate ( TSA2(ntiles), TSB1(ntiles), TSB2(ntiles) ) allocate ( ATAU2(ntiles), BTAU2(ntiles), DP2BR(ntiles) ) allocate (BVISDR(ntiles), BVISDF(ntiles), BNIRDR(ntiles) ) - allocate (BNIRDF(ntiles), T2(ntiles), NDEP(ntiles) ) + allocate (BNIRDF(ntiles), T2(ntiles), NDEP(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)) @@ -1361,7 +1361,7 @@ SUBROUTINE read_bcs_data (ntiles, SURFLAY,MODEL, DataDir, InRestart, rc) if(file_exists) then print *,'FILE FORMAT FOR LAND BCS IS NC4' - call CatchFmt%Open(trim(DataDir)//'/catch_params.nc4', pFIO_READ, __RC__) + call CatchFmt%Open(trim(DataDir)//'/catch_params.nc4', pFIO_READ, __RC__) call MAPL_VarRead ( CatchFmt ,'OLD_ITY', RITY, __RC__) ITY = NINT (RITY) call MAPL_VarRead ( CatchFmt ,'ARA1', ARA1, __RC__) @@ -1402,7 +1402,7 @@ SUBROUTINE read_bcs_data (ntiles, SURFLAY,MODEL, DataDir, InRestart, rc) call MAPL_VarRead ( CatchFmt ,'POROS', POROS, __RC__) call CatchFmt%close() if(isCatchCN) then - call CatchCNFmt%Open(trim(DataDir)//'/catchcn_params.nc4', pFIO_READ, __RC__) + call CatchCNFmt%Open(trim(DataDir)//'/catchcn_params.nc4', pFIO_READ, __RC__) call MAPL_VarRead ( CatchCNFmt ,'BGALBNF', BNIRDF, __RC__) call MAPL_VarRead ( CatchCNFmt ,'BGALBNR', BNIRDR, __RC__) call MAPL_VarRead ( CatchCNFmt ,'BGALBVF', BVISDF, __RC__) @@ -1428,15 +1428,15 @@ SUBROUTINE read_bcs_data (ntiles, SURFLAY,MODEL, DataDir, InRestart, rc) endif endif - + else - open(unit=21, file=trim(DataDir)//'mosaic_veg_typs_fracs',form='formatted') + 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 .and. isCatchCN) 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') @@ -1448,49 +1448,49 @@ SUBROUTINE read_bcs_data (ntiles, SURFLAY,MODEL, DataDir, InRestart, rc) do n=1,ntiles var1 (n) = real (n) - ! W.J notes: CanopH is not used. If CLM_veg_typs_fracs exists, the read some dummy ???? Ask Sarith + ! W.J notes: CanopH is not used. If CLM_veg_typs_fracs exists, the read some dummy ???? Ask Sarith if (NewLand) then read(21,*) I, j, ITY(N),idum, rdum, rdum, CanopH(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 .and. isCatchCN) 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 (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, *) i, j, abm(n), peatf(n), & gdp(n), hdm(n), fc(n) endif - endif + endif end do - + CLOSE (21, STATUS = 'KEEP') CLOSE (22, STATUS = 'KEEP') CLOSE (23, STATUS = 'KEEP') CLOSE (24, STATUS = 'KEEP') CLOSE (25, STATUS = 'KEEP') CLOSE (26, STATUS = 'KEEP') - + if(NewLand .and. isCatchCN) then CLOSE (27, STATUS = 'KEEP') CLOSE (28, STATUS = 'KEEP') @@ -1500,87 +1500,87 @@ SUBROUTINE read_bcs_data (ntiles, SURFLAY,MODEL, DataDir, InRestart, rc) endif endif endif - + do n=1,ntiles var1 (n) = real (n) zdep2=1000. zdep3=amax1(1000.,DP2BR(n)) - + if (zdep2 .gt.0.75*zdep3) then - zdep2 = 0.75*zdep3 + zdep2 = 0.75*zdep3 end if - + zdep1=20. zmet=zdep3/1000. - + term1=-1.+((PSIS(n)-zmet)/PSIS(n))**((BEE(n)-1.)/BEE(n)) term2=PSIS(n)*BEE(n)/(BEE(n)-1) - - VGWMAX(n) = POROS(n)*zdep2 - CDCR1(n) = 1000.*POROS(n)*(zmet-(-term2*term1)) + + VGWMAX(n) = POROS(n)*zdep2 + CDCR1(n) = 1000.*POROS(n)*(zmet-(-term2*term1)) CDCR2(n) = (1.-WPWET(n))*POROS(n)*zdep3 if( isCatchCN) then - + BVISDR(n) = amax1(1.e-6, BVISDR(n)) BVISDF(n) = amax1(1.e-6, BVISDF(n)) BNIRDR(n) = amax1(1.e-6, BNIRDR(n)) BNIRDF(n) = amax1(1.e-6, BNIRDF(n)) ! convert % to fractions - + CLMC_pf1(n) = CLMC_pf1(n) / 100. CLMC_pf2(n) = CLMC_pf2(n) / 100. CLMC_sf1(n) = CLMC_sf1(n) / 100. CLMC_sf2(n) = CLMC_sf2(n) / 100. - + fvg(1) = CLMC_pf1(n) fvg(2) = CLMC_pf2(n) fvg(3) = CLMC_sf1(n) fvg(4) = CLMC_sf2(n) - - BARE = 1. - + + BARE = 1. + DO NV = 1, NVEG - BARE = BARE - FVG(NV)! subtract vegetated fractions + BARE = BARE - FVG(NV)! subtract vegetated fractions END DO - + if (BARE /= 0.) THEN IB = MAXLOC(FVG(:),1) FVG (IB) = FVG(IB) + BARE ! This also corrects all cases sum ne 0. ENDIF - + CLMC_pf1(n) = fvg(1) CLMC_pf2(n) = fvg(2) CLMC_sf1(n) = fvg(3) CLMC_sf2(n) = fvg(4) - + if(CLM45) then ! CLM 45 - + CLMC45_pf1(n) = CLMC45_pf1(n) / 100. CLMC45_pf2(n) = CLMC45_pf2(n) / 100. CLMC45_sf1(n) = CLMC45_sf1(n) / 100. CLMC45_sf2(n) = CLMC45_sf2(n) / 100. - + fvg(1) = CLMC45_pf1(n) fvg(2) = CLMC45_pf2(n) fvg(3) = CLMC45_sf1(n) fvg(4) = CLMC45_sf2(n) - - BARE = 1. - + + BARE = 1. + DO NV = 1, NVEG - BARE = BARE - FVG(NV)! subtract vegetated fractions + BARE = BARE - FVG(NV)! subtract vegetated fractions END DO - + if (BARE /= 0.) THEN IB = MAXLOC(FVG(:),1) FVG (IB) = FVG(IB) + BARE ! This also corrects all cases sum ne 0. ENDIF - + CLMC45_pf1(n) = fvg(1) CLMC45_pf2(n) = fvg(2) CLMC45_sf1(n) = fvg(3) @@ -1590,9 +1590,9 @@ SUBROUTINE read_bcs_data (ntiles, SURFLAY,MODEL, DataDir, InRestart, rc) enddo if( isCatchCN) then - + NDEP = NDEP * 1.e-9 - + ! prevent trivial fractions ! ------------------------- do n = 1,ntiles @@ -1600,12 +1600,12 @@ SUBROUTINE read_bcs_data (ntiles, SURFLAY,MODEL, DataDir, InRestart, rc) CLMC_pf2(n) = CLMC_pf2(n) + CLMC_pf1(n) CLMC_pf1(n) = 0. endif - + if(CLMC_pf2(n) <= 1.e-4) then CLMC_pf1(n) = CLMC_pf1(n) + CLMC_pf2(n) CLMC_pf2(n) = 0. endif - + if(CLMC_sf1(n) <= 1.e-4) then if(CLMC_sf2(n) > 1.e-4) then CLMC_sf2(n) = CLMC_sf2(n) + CLMC_sf1(n) @@ -1618,7 +1618,7 @@ SUBROUTINE read_bcs_data (ntiles, SURFLAY,MODEL, DataDir, InRestart, rc) endif CLMC_sf1(n) = 0. endif - + if(CLMC_sf2(n) <= 1.e-4) then if(CLMC_sf1(n) > 1.e-4) then CLMC_sf1(n) = CLMC_sf1(n) + CLMC_sf2(n) @@ -1631,19 +1631,19 @@ SUBROUTINE read_bcs_data (ntiles, SURFLAY,MODEL, DataDir, InRestart, rc) endif CLMC_sf2(n) = 0. endif - + if (clm45) then ! CLM45 if(CLMC45_pf1(n) <= 1.e-4) then CLMC45_pf2(n) = CLMC45_pf2(n) + CLMC45_pf1(n) CLMC45_pf1(n) = 0. endif - + if(CLMC45_pf2(n) <= 1.e-4) then CLMC45_pf1(n) = CLMC45_pf1(n) + CLMC45_pf2(n) CLMC45_pf2(n) = 0. endif - + if(CLMC45_sf1(n) <= 1.e-4) then if(CLMC45_sf2(n) > 1.e-4) then CLMC45_sf2(n) = CLMC45_sf2(n) + CLMC45_sf1(n) @@ -1656,7 +1656,7 @@ SUBROUTINE read_bcs_data (ntiles, SURFLAY,MODEL, DataDir, InRestart, rc) endif CLMC45_sf1(n) = 0. endif - + if(CLMC45_sf2(n) <= 1.e-4) then if(CLMC45_sf1(n) > 1.e-4) then CLMC45_sf1(n) = CLMC45_sf1(n) + CLMC45_sf2(n) @@ -1673,10 +1673,10 @@ SUBROUTINE read_bcs_data (ntiles, SURFLAY,MODEL, DataDir, InRestart, rc) end do endif - + ! Vegdyn Boundary Condition ! ------------------------- - + ! open(20,file=trim("vegdyn_internal_rst"), & ! status="unknown", & ! form="unformatted",convert="little_endian") @@ -1688,7 +1688,7 @@ SUBROUTINE read_bcs_data (ntiles, SURFLAY,MODEL, DataDir, InRestart, rc) ! Now writing BCs (from BCSDIR) and regridded hydrological variables 1-72 ! ----------------------------------------------------------------------- - STATUS = NF_OPEN (trim(InRestart),NF_WRITE,NCFID) ; VERIFY_(STATUS) + STATUS = NF_OPEN (trim(InRestart),NF_WRITE,NCFID) ; VERIFY_(STATUS) STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'BF1'), (/1/), (/NTILES/),BF1) STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'BF2'), (/1/), (/NTILES/),BF2) STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'BF3'), (/1/), (/NTILES/),BF3) @@ -1726,12 +1726,12 @@ SUBROUTINE read_bcs_data (ntiles, SURFLAY,MODEL, DataDir, InRestart, rc) STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ITY'), (/1,2/), (/NTILES,1/),CLMC_pt2) STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ITY'), (/1,3/), (/NTILES,1/),CLMC_st1) STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ITY'), (/1,4/), (/NTILES,1/),CLMC_st2) - + STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'FVG'), (/1,1/), (/NTILES,1/),CLMC_pf1) STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'FVG'), (/1,2/), (/NTILES,1/),CLMC_pf2) STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'FVG'), (/1,3/), (/NTILES,1/),CLMC_sf1) STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'FVG'), (/1,4/), (/NTILES,1/),CLMC_sf2) - + STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'NDEP' ), (/1/), (/NTILES/),NDEP) STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'CLI_T2M'), (/1/), (/NTILES/),T2) @@ -1739,7 +1739,7 @@ SUBROUTINE read_bcs_data (ntiles, SURFLAY,MODEL, DataDir, InRestart, rc) STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'BGALBVF'), (/1/), (/NTILES/),BVISDF) STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'BGALBNR'), (/1/), (/NTILES/),BNIRDR) STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'BGALBNF'), (/1/), (/NTILES/),BNIRDF) - + if(CLM45) then STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ABM' ), (/1/), (/NTILES/),real(ABM)) @@ -1756,8 +1756,8 @@ SUBROUTINE read_bcs_data (ntiles, SURFLAY,MODEL, DataDir, InRestart, rc) STATUS = NF_CLOSE ( NCFID) deallocate ( BF1, BF2, BF3 ) - deallocate (VGWMAX, CDCR1, CDCR2 ) - deallocate ( PSIS, BEE, POROS ) + deallocate (VGWMAX, CDCR1, CDCR2 ) + deallocate ( PSIS, BEE, POROS ) deallocate ( WPWET, COND, GNU ) deallocate ( ARS1, ARS2, ARS3 ) deallocate ( ARA1, ARA2, ARA3 ) @@ -1766,7 +1766,7 @@ SUBROUTINE read_bcs_data (ntiles, SURFLAY,MODEL, DataDir, InRestart, rc) deallocate ( TSA2, TSB1, TSB2 ) deallocate ( ATAU2, BTAU2, DP2BR ) deallocate (BVISDR, BVISDF, BNIRDR ) - deallocate (BNIRDF, T2, NDEP ) + deallocate (BNIRDF, T2, NDEP ) deallocate ( ity, CanopH) deallocate (CLMC_pf1, CLMC_pf2, CLMC_sf1) deallocate (CLMC_sf2, CLMC_pt1, CLMC_pt2) @@ -1776,7 +1776,7 @@ SUBROUTINE read_bcs_data (ntiles, SURFLAY,MODEL, DataDir, InRestart, rc) END SUBROUTINE read_bcs_data ! ***************************************************************************** - + SUBROUTINE regrid_carbon_vars (NTILES, model) implicit none @@ -1785,7 +1785,7 @@ SUBROUTINE regrid_carbon_vars (NTILES, model) character(*), intent (in) :: model character*300 :: OutTileFile = 'InData/OutTileFile' character*300 :: OutFileName - integer :: AGCM_YY=2015,AGCM_MM=1,AGCM_DD=1,AGCM_HR=0 + integer :: AGCM_YY=2015,AGCM_MM=1,AGCM_DD=1,AGCM_HR=0 real, allocatable, dimension (:) :: CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2, & CLMC_pt1, CLMC_pt2,CLMC_st1,CLMC_st2 @@ -1797,9 +1797,9 @@ SUBROUTINE regrid_carbon_vars (NTILES, model) integer :: n,i,j, k, offl_cell, STATUS,NCFID, req integer :: outid, local_id, nv, nz, iv real , allocatable, dimension (:) :: LATT, LONN, DAYX, TILE_ID, var_dum2 - real, allocatable :: var_off_col (:,:,:), var_off_pft (:,:,:,:) + real, allocatable :: var_off_col (:,:,:), var_off_pft (:,:,:,:) integer, allocatable :: low_ind(:), upp_ind(:), nt_local (:) - real , pointer , dimension (:) :: long, latg, lonc, latc + real , pointer , dimension (:) :: long, latg, lonc, latc character*256 :: Iam = "regrid_carbon_vars" OutFileName='OutData/'//trim(model)//'_internal_rst' @@ -1813,15 +1813,15 @@ SUBROUTINE regrid_carbon_vars (NTILES, model) allocate(nt_local( numprocs)) low_ind (:) = 1 - upp_ind (:) = NTILES - nt_local(:) = NTILES + upp_ind (:) = NTILES + nt_local(:) = NTILES ! Domain decomposition ! -------------------- - if (numprocs > 1) then + if (numprocs > 1) then do i = 1, numprocs - 1 - upp_ind(i) = low_ind(i) + (ntiles/numprocs) - 1 + upp_ind(i) = low_ind(i) + (ntiles/numprocs) - 1 low_ind(i+1) = upp_ind(i) + 1 nt_local(i) = upp_ind(i) - low_ind(i) + 1 end do @@ -1843,9 +1843,9 @@ SUBROUTINE regrid_carbon_vars (NTILES, model) allocate (latc (1:ntiles_cn)) if (root_proc) then - + ! -------------------------------------------- - ! Read exact lonn, latt from output .til file + ! Read exact lonn, latt from output .til file ! -------------------------------------------- allocate (long (ntiles)) @@ -1859,10 +1859,10 @@ SUBROUTINE regrid_carbon_vars (NTILES, model) call compute_dayx ( & NTILES, AGCM_YY, AGCM_MM, AGCM_DD, AGCM_HR, & - LATG, DAYX) + LATG, DAYX) ! --------------------------------------------- - ! Read exact lonc, latc from offline .til File + ! Read exact lonc, latc from offline .til File ! --------------------------------------------- call ReadTileFile_RealLatLon(trim(InCNTilFile),i,xlon=lonc,xlat=latc); VERIFY_(i-ntiles_cn) @@ -1891,25 +1891,25 @@ SUBROUTINE regrid_carbon_vars (NTILES, model) else if (myid == 0) then ! root sends call MPI_ISend(long(low_ind(i) : upp_ind(i)),nt_local(i),MPI_REAL,i-1,995,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) + call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) call MPI_ISend(latg(low_ind(i) : upp_ind(i)),nt_local(i),MPI_REAL,i-1,994,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) + call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) endif endif end do - + if(root_proc) deallocate (long, latg) - + call MPI_BCAST(lonc,ntiles_cn,MPI_REAL,0,MPI_COMM_WORLD,mpierr) call MPI_BCAST(latc,ntiles_cn,MPI_REAL,0,MPI_COMM_WORLD,mpierr) ! Open GKW/Fzeng SMAP M09 catchcn_internal_rst and output catchcn_internal_rst ! ---------------------------------------------------------------------------- - + STATUS = NF_OPEN_PAR (trim(OutFileName),IOR(NF_WRITE ,NF_MPIIO),MPI_COMM_WORLD, infos,OUTID) IF (STATUS .NE. NF_NOERR) CALL HANDLE_ERR(STATUS, 'OUTPUT RESTART FAILED') - + STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/low_ind(myid+1),1/), (/nt_local(myid+1),1/),CLMC_pt1) STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/low_ind(myid+1),2/), (/nt_local(myid+1),1/),CLMC_pt2) STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/low_ind(myid+1),3/), (/nt_local(myid+1),1/),CLMC_st1) @@ -1926,17 +1926,17 @@ SUBROUTINE regrid_carbon_vars (NTILES, model) STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TILE_ID' ), (/1/), (/NTILES_CN/),TILE_ID) do n = 1,ntiles_cn - + K = NINT (TILE_ID (n)) STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ITY'), (/n,1/), (/1,4/),ityp_offl(K,:)) STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'FVG'), (/n,1/), (/1,4/),fveg_offl(K,:)) - + tid_offl (n) = n - + do nv = 1,nveg if(ityp_offl(K,nv)<0 .or. ityp_offl(K,nv)>npft) stop 'ityp' - if(fveg_offl(K,nv)<0..or. fveg_offl(K,nv)>1.00001) stop 'fveg' + if(fveg_offl(K,nv)<0..or. fveg_offl(K,nv)>1.00001) stop 'fveg' end do if((ityp_offl(K,3) == 0).and.(ityp_offl(K,4) == 0)) then @@ -1946,42 +1946,42 @@ SUBROUTINE regrid_carbon_vars (NTILES, model) ityp_offl(K,3) = ityp_offl(K,2) endif endif - + if((ityp_offl(K,1) == 0).and.(ityp_offl(K,2) /= 0)) ityp_offl(K,1) = ityp_offl(K,2) if((ityp_offl(K,2) == 0).and.(ityp_offl(K,1) /= 0)) ityp_offl(K,2) = ityp_offl(K,1) if((ityp_offl(K,3) == 0).and.(ityp_offl(K,4) /= 0)) ityp_offl(K,3) = ityp_offl(K,4) if((ityp_offl(K,4) == 0).and.(ityp_offl(K,3) /= 0)) ityp_offl(K,4) = ityp_offl(K,3) - + end do endif - + call MPI_BCAST(tid_offl ,size(tid_offl ),MPI_INTEGER,0,MPI_COMM_WORLD,mpierr) call MPI_BCAST(ityp_offl,size(ityp_offl),MPI_REAL ,0,MPI_COMM_WORLD,mpierr) - call MPI_BCAST(fveg_offl,size(fveg_offl),MPI_REAL ,0,MPI_COMM_WORLD,mpierr) + call MPI_BCAST(fveg_offl,size(fveg_offl),MPI_REAL ,0,MPI_COMM_WORLD,mpierr) ! -------------------------------------------------------------------------------- ! Here we create transfer index array to map offline restarts to output tile space - ! -------------------------------------------------------------------------------- + ! -------------------------------------------------------------------------------- call GetIds(lonc,latc,lonn,latt,id_loc, tid_offl, & CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2, CLMC_pt1, CLMC_pt2,CLMC_st1,CLMC_st2, & fveg_offl, ityp_offl) - + ! update id_glb in root - + if(root_proc) then allocate (id_glb (ntiles, nveg)) allocate (id_vec (ntiles)) endif - + do nv = 1, nveg call MPI_Barrier(MPI_COMM_WORLD, STATUS) ! call MPI_GATHERV( & ! id_loc (:,nv), nt_local(myid+1) , MPI_real, & ! id_vec, nt_local,low_ind-1, MPI_real, & ! 0, MPI_COMM_WORLD, mpierr ) - + do i = 1, numprocs if((I == 1).and.(myid == 0)) then id_vec(low_ind(i) : upp_ind(i)) = Id_loc(:,nv) @@ -1989,16 +1989,16 @@ SUBROUTINE regrid_carbon_vars (NTILES, model) if(I-1 == myid) then ! send to root call MPI_ISend(id_loc(:,nv),nt_local(i),MPI_INTEGER,0,993,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) + call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) else if (myid == 0) then ! root receives call MPI_RECV(id_vec(low_ind(i) : upp_ind(i)),nt_local(i) , MPI_INTEGER, i-1,993,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) endif endif end do - + if(root_proc) id_glb (:,nv) = id_vec - + end do if(root_proc) then @@ -2011,33 +2011,33 @@ SUBROUTINE regrid_carbon_vars (NTILES, model) do nz = 1,nzone STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CNCOL'), (/1,i/), (/NTILES_CN,1 /),VAR_DUM2) do k = 1, NTILES_CN - var_off_col(TILE_ID(K), nz,nv) = VAR_DUM2(K) + var_off_col(int(TILE_ID(K)), nz,nv) = VAR_DUM2(K) end do i = i + 1 end do end do - + i = 1 do iv = 1,VAR_PFT do nv = 1,nveg do nz = 1,nzone STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CNPFT'), (/1,i/), (/NTILES_CN,1 /),VAR_DUM2) do k = 1, NTILES_CN - var_off_pft(TILE_ID(K), nz,nv,iv) = VAR_DUM2(K) + var_off_pft(int(TILE_ID(K)), nz,nv,iv) = VAR_DUM2(K) end do i = i + 1 end do end do end do - - where(isnan(var_off_pft)) var_off_pft = 0. - where(var_off_pft /= var_off_pft) var_off_pft = 0. + + where(isnan(var_off_pft)) var_off_pft = 0. + where(var_off_pft /= var_off_pft) var_off_pft = 0. call write_regridded_carbon (NTILES, ntiles_cn, NCFID, OUTID, id_glb, & - DAYX, var_off_col, var_off_pft, ityp_offl, fveg_offl) + DAYX, var_off_col, var_off_pft, ityp_offl, fveg_offl) deallocate (var_off_col,var_off_pft) endif - + call MPI_Barrier(MPI_COMM_WORLD, STATUS) END SUBROUTINE regrid_carbon_vars @@ -2045,21 +2045,21 @@ END SUBROUTINE regrid_carbon_vars ! --------------------------------------------------------------------------------------------------------- SUBROUTINE write_regridded_carbon (NTILES, ntiles_rst, NCFID, OUTID, id_glb, & - DAYX, var_off_col, var_off_pft, ityp_offl, fveg_offl) + DAYX, var_off_col, var_off_pft, ityp_offl, fveg_offl) ! write out regridded carbon variables implicit none integer, intent (in) :: NTILES, ntiles_rst,NCFID, OUTID, id_glb (ntiles,nveg) - real, intent (in) :: DAYX (NTILES), var_off_col(NTILES_RST,NZONE,var_col), var_off_pft(NTILES_RST,NZONE, NVEG, var_pft) + real, intent (in) :: DAYX (NTILES), var_off_col(NTILES_RST,NZONE,var_col), var_off_pft(NTILES_RST,NZONE, NVEG, var_pft) real, intent (in), dimension(ntiles_rst,nveg) :: fveg_offl, ityp_offl real, allocatable, dimension (:) :: CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2, & - CLMC_pt1, CLMC_pt2,CLMC_st1,CLMC_st2, var_dum - real, allocatable :: var_col_out (:,:,:), var_pft_out (:,:,:,:) + CLMC_pt1, CLMC_pt2,CLMC_st1,CLMC_st2, var_dum + real, allocatable :: var_col_out (:,:,:), var_pft_out (:,:,:,:) integer :: N, STATUS, nv, nx, offl_cell, ityp_new, i, j, nz, iv real :: fveg_new - character(256) :: Iam = "write_regridded_carbon" + character(256) :: Iam = "write_regridded_carbon" + - allocate (CLMC_pf1(NTILES)) allocate (CLMC_pf2(NTILES)) allocate (CLMC_sf1(NTILES)) @@ -2069,7 +2069,7 @@ SUBROUTINE write_regridded_carbon (NTILES, ntiles_rst, NCFID, OUTID, id_glb, & allocate (CLMC_st1(NTILES)) allocate (CLMC_st2(NTILES)) allocate (VAR_DUM (NTILES)) - + STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/1,1/), (/NTILES,1/),CLMC_pt1) ; VERIFY_(STATUS) STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/1,2/), (/NTILES,1/),CLMC_pt2) ; VERIFY_(STATUS) STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/1,3/), (/NTILES,1/),CLMC_st1) ; VERIFY_(STATUS) @@ -2078,123 +2078,123 @@ SUBROUTINE write_regridded_carbon (NTILES, ntiles_rst, NCFID, OUTID, id_glb, & STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/1,2/), (/NTILES,1/),CLMC_pf2) ; VERIFY_(STATUS) STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/1,3/), (/NTILES,1/),CLMC_sf1) ; VERIFY_(STATUS) STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/1,4/), (/NTILES,1/),CLMC_sf2) ; VERIFY_(STATUS) - + allocate (var_col_out (1: NTILES, 1 : nzone,1 : var_col)) - allocate (var_pft_out (1: NTILES, 1 : nzone,1 : nveg, 1 : var_pft)) - + allocate (var_pft_out (1: NTILES, 1 : nzone,1 : nveg, 1 : var_pft)) + var_col_out = 0. - var_pft_out = NaN + var_pft_out = NaN OUT_TILE : DO N = 1, NTILES - + ! if(mod (n,1000) == 0) print *, myid +1, n, Id_glb(n,:) - + NVLOOP2 : do nv = 1, nveg - + if(nv <= 2) then ! index for secondary PFT index if primary or primary if secondary nx = nv + 2 else nx = nv - 2 endif - + if (nv == 1) ityp_new = CLMC_pt1(n) if (nv == 1) fveg_new = CLMC_pf1(n) if (nv == 2) ityp_new = CLMC_pt2(n) if (nv == 2) fveg_new = CLMC_pf2(n) if (nv == 3) ityp_new = CLMC_st1(n) if (nv == 3) fveg_new = CLMC_sf1(n) - if (nv == 4) ityp_new = CLMC_st2(n) + if (nv == 4) ityp_new = CLMC_st2(n) if (nv == 4) fveg_new = CLMC_sf2(n) - + if (fveg_new > fmin) then - + offl_cell = Id_glb(n,nv) - + if(ityp_new == ityp_offl (offl_cell,nv) .and. fveg_offl (offl_cell,nv)> fmin) then - iv = nv ! same type fraction (primary of secondary) + iv = nv ! same type fraction (primary of secondary) else if(ityp_new == ityp_offl (offl_cell,nx) .and. fveg_offl (offl_cell,nx)> fmin) then iv = nx ! not same fraction - else if(iclass(ityp_new)==iclass(ityp_offl(offl_cell,nv)) .and. fveg_offl (offl_cell,nv)> fmin) then + else if(iclass(ityp_new)==iclass(int(ityp_offl(offl_cell,nv))) .and. fveg_offl (offl_cell,nv)> fmin) then iv = nv ! primary, other type (same class) else if(fveg_offl (offl_cell,nx)> fmin) then iv = nx ! secondary, other type (same class) endif - + ! Get col and pft variables for the Id_glb(nv) grid cell from offline catchcn_internal_rst ! ---------------------------------------------------------------------------------------- - - ! call NCDF_reshape_getOput (NCFID,Id_glb(n,nv),var_off_col,var_off_pft,.true.) - - var_pft_out (n,:,nv,:) = var_off_pft(Id_glb(n,nv), :,iv,:) + + ! call NCDF_reshape_getOput (NCFID,Id_glb(n,nv),var_off_col,var_off_pft,.true.) + + var_pft_out (n,:,nv,:) = var_off_pft(Id_glb(n,nv), :,iv,:) var_col_out (n,:,:) = var_col_out(n,:,:) + fveg_new * var_off_col(Id_glb(n,nv), :,:) ! gkw: column state simple weighted mean; ! could use "woody" fraction? - + ! Check whether var_pft_out is realistic do nz = 1, nzone do j = 1, VAR_PFT - if (isnan(var_pft_out (n, nz,nv,j))) print *,j,nv,nz,n,var_pft_out (n, nz,nv,j),fveg_new + if (isnan(var_pft_out (n, nz,nv,j))) print *,j,nv,nz,n,var_pft_out (n, nz,nv,j),fveg_new !if(isnan(var_pft_out (n, nz,nv,69))) var_pft_out (n, nz,nv,69) = 1.e-6 - !if(isnan(var_pft_out (n, nz,nv,70))) var_pft_out (n, nz,nv,70) = 1.e-6 + !if(isnan(var_pft_out (n, nz,nv,70))) var_pft_out (n, nz,nv,70) = 1.e-6 !if(isnan(var_pft_out (n, nz,nv,73))) var_pft_out (n, nz,nv,73) = 1.e-6 - !if(isnan(var_pft_out (n, nz,nv,74))) var_pft_out (n, nz,nv,74) = 1.e-6 + !if(isnan(var_pft_out (n, nz,nv,74))) var_pft_out (n, nz,nv,74) = 1.e-6 end do end do endif - + end do NVLOOP2 - + ! reset carbon if negative < 10g ! ------------------------ - + NZLOOP : do nz = 1, nzone - + if(var_col_out (n, nz,14) < 10.) then - - var_col_out(n, nz, 1) = max(var_col_out(n, nz, 1), 0.) - var_col_out(n, nz, 2) = max(var_col_out(n, nz, 2), 0.) - var_col_out(n, nz, 3) = max(var_col_out(n, nz, 3), 0.) - var_col_out(n, nz, 4) = max(var_col_out(n, nz, 4), 0.) - var_col_out(n, nz, 5) = max(var_col_out(n, nz, 5), 0.) - var_col_out(n, nz,10) = max(var_col_out(n, nz,10), 0.) - var_col_out(n, nz,11) = max(var_col_out(n, nz,11), 0.) - var_col_out(n, nz,12) = max(var_col_out(n, nz,12), 0.) - var_col_out(n, nz,13) = max(var_col_out(n, nz,13),10.) ! soil4c - var_col_out(n, nz,14) = max(var_col_out(n, nz,14), 0.) - var_col_out(n, nz,15) = max(var_col_out(n, nz,15), 0.) - var_col_out(n, nz,16) = max(var_col_out(n, nz,16), 0.) - var_col_out(n, nz,17) = max(var_col_out(n, nz,17), 0.) - var_col_out(n, nz,18) = max(var_col_out(n, nz,18), 0.) - var_col_out(n, nz,19) = max(var_col_out(n, nz,19), 0.) - var_col_out(n, nz,20) = max(var_col_out(n, nz,20), 0.) - var_col_out(n, nz,24) = max(var_col_out(n, nz,24), 0.) - var_col_out(n, nz,25) = max(var_col_out(n, nz,25), 0.) - var_col_out(n, nz,26) = max(var_col_out(n, nz,26), 0.) - var_col_out(n, nz,27) = max(var_col_out(n, nz,27), 0.) - var_col_out(n, nz,28) = max(var_col_out(n, nz,28), 1.) - var_col_out(n, nz,29) = max(var_col_out(n, nz,29), 0.) - + + var_col_out(n, nz, 1) = max(var_col_out(n, nz, 1), 0.) + var_col_out(n, nz, 2) = max(var_col_out(n, nz, 2), 0.) + var_col_out(n, nz, 3) = max(var_col_out(n, nz, 3), 0.) + var_col_out(n, nz, 4) = max(var_col_out(n, nz, 4), 0.) + var_col_out(n, nz, 5) = max(var_col_out(n, nz, 5), 0.) + var_col_out(n, nz,10) = max(var_col_out(n, nz,10), 0.) + var_col_out(n, nz,11) = max(var_col_out(n, nz,11), 0.) + var_col_out(n, nz,12) = max(var_col_out(n, nz,12), 0.) + var_col_out(n, nz,13) = max(var_col_out(n, nz,13),10.) ! soil4c + var_col_out(n, nz,14) = max(var_col_out(n, nz,14), 0.) + var_col_out(n, nz,15) = max(var_col_out(n, nz,15), 0.) + var_col_out(n, nz,16) = max(var_col_out(n, nz,16), 0.) + var_col_out(n, nz,17) = max(var_col_out(n, nz,17), 0.) + var_col_out(n, nz,18) = max(var_col_out(n, nz,18), 0.) + var_col_out(n, nz,19) = max(var_col_out(n, nz,19), 0.) + var_col_out(n, nz,20) = max(var_col_out(n, nz,20), 0.) + var_col_out(n, nz,24) = max(var_col_out(n, nz,24), 0.) + var_col_out(n, nz,25) = max(var_col_out(n, nz,25), 0.) + var_col_out(n, nz,26) = max(var_col_out(n, nz,26), 0.) + var_col_out(n, nz,27) = max(var_col_out(n, nz,27), 0.) + var_col_out(n, nz,28) = max(var_col_out(n, nz,28), 1.) + var_col_out(n, nz,29) = max(var_col_out(n, nz,29), 0.) + NVLOOP3 : do nv = 1,nveg - + if (nv == 1) ityp_new = CLMC_pt1(n) if (nv == 1) fveg_new = CLMC_pf1(n) if (nv == 2) ityp_new = CLMC_pt2(n) if (nv == 2) fveg_new = CLMC_pf2(n) if (nv == 3) ityp_new = CLMC_st1(n) if (nv == 3) fveg_new = CLMC_sf1(n) - if (nv == 4) ityp_new = CLMC_st2(n) + if (nv == 4) ityp_new = CLMC_st2(n) if (nv == 4) fveg_new = CLMC_sf2(n) - + if(fveg_new > fmin) then - var_pft_out(n, nz,nv, 1) = max(var_pft_out(n, nz,nv, 1),0.) - var_pft_out(n, nz,nv, 2) = max(var_pft_out(n, nz,nv, 2),0.) - var_pft_out(n, nz,nv, 3) = max(var_pft_out(n, nz,nv, 3),0.) - var_pft_out(n, nz,nv, 4) = max(var_pft_out(n, nz,nv, 4),0.) - + var_pft_out(n, nz,nv, 1) = max(var_pft_out(n, nz,nv, 1),0.) + var_pft_out(n, nz,nv, 2) = max(var_pft_out(n, nz,nv, 2),0.) + var_pft_out(n, nz,nv, 3) = max(var_pft_out(n, nz,nv, 3),0.) + var_pft_out(n, nz,nv, 4) = max(var_pft_out(n, nz,nv, 4),0.) + if(ityp_new <= 12) then ! tree or shrub deadstemc var_pft_out(n, nz,nv, 5) = max(var_pft_out(n, nz,nv, 5),0.1) - else + else var_pft_out(n, nz,nv, 5) = max(var_pft_out(n, nz,nv, 5),0.0) endif - + var_pft_out(n, nz,nv, 6) = max(var_pft_out(n, nz,nv, 6),0.) var_pft_out(n, nz,nv, 7) = max(var_pft_out(n, nz,nv, 7),0.) var_pft_out(n, nz,nv, 8) = max(var_pft_out(n, nz,nv, 8),0.) @@ -2202,15 +2202,15 @@ SUBROUTINE write_regridded_carbon (NTILES, ntiles_rst, NCFID, OUTID, id_glb, & var_pft_out(n, nz,nv,10) = max(var_pft_out(n, nz,nv,10),0.) var_pft_out(n, nz,nv,11) = max(var_pft_out(n, nz,nv,11),0.) var_pft_out(n, nz,nv,12) = max(var_pft_out(n, nz,nv,12),0.) - + if(ityp_new <=2 .or. ityp_new ==4 .or. ityp_new ==5 .or. ityp_new == 9) then var_pft_out(n, nz,nv,13) = max(var_pft_out(n, nz,nv,13),1.) ! leaf carbon display for evergreen var_pft_out(n, nz,nv,14) = max(var_pft_out(n, nz,nv,14),0.) else - var_pft_out(n, nz,nv,13) = max(var_pft_out(n, nz,nv,13),0.) + var_pft_out(n, nz,nv,13) = max(var_pft_out(n, nz,nv,13),0.) var_pft_out(n, nz,nv,14) = max(var_pft_out(n, nz,nv,14),1.) ! leaf carbon storage for deciduous endif - + var_pft_out(n, nz,nv,15) = max(var_pft_out(n, nz,nv,15),0.) var_pft_out(n, nz,nv,16) = max(var_pft_out(n, nz,nv,16),0.) var_pft_out(n, nz,nv,17) = max(var_pft_out(n, nz,nv,17),0.) @@ -2232,34 +2232,34 @@ SUBROUTINE write_regridded_carbon (NTILES, ntiles_rst, NCFID, OUTID, id_glb, & var_pft_out(n, nz,nv,48) = max(var_pft_out(n, nz,nv,48),0.) var_pft_out(n, nz,nv,49) = max(var_pft_out(n, nz,nv,49),0.) var_pft_out(n, nz,nv,50) = max(var_pft_out(n, nz,nv,50),0.) - var_pft_out(n, nz,nv,51) = max(var_pft_out(n, nz,nv, 5)/500.,0.) + var_pft_out(n, nz,nv,51) = max(var_pft_out(n, nz,nv, 5)/500.,0.) var_pft_out(n, nz,nv,52) = max(var_pft_out(n, nz,nv,52),0.) var_pft_out(n, nz,nv,53) = max(var_pft_out(n, nz,nv,53),0.) var_pft_out(n, nz,nv,54) = max(var_pft_out(n, nz,nv,54),0.) var_pft_out(n, nz,nv,55) = max(var_pft_out(n, nz,nv,55),0.) var_pft_out(n, nz,nv,56) = max(var_pft_out(n, nz,nv,56),0.) - var_pft_out(n, nz,nv,57) = max(var_pft_out(n, nz,nv,13)/25.,0.) - var_pft_out(n, nz,nv,58) = max(var_pft_out(n, nz,nv,14)/25.,0.) + var_pft_out(n, nz,nv,57) = max(var_pft_out(n, nz,nv,13)/25.,0.) + var_pft_out(n, nz,nv,58) = max(var_pft_out(n, nz,nv,14)/25.,0.) var_pft_out(n, nz,nv,59) = max(var_pft_out(n, nz,nv,59),0.) - var_pft_out(n, nz,nv,60) = max(var_pft_out(n, nz,nv,60),0.) - var_pft_out(n, nz,nv,61) = max(var_pft_out(n, nz,nv,61),0.) - var_pft_out(n, nz,nv,62) = max(var_pft_out(n, nz,nv,62),0.) - var_pft_out(n, nz,nv,63) = max(var_pft_out(n, nz,nv,63),0.) - var_pft_out(n, nz,nv,64) = max(var_pft_out(n, nz,nv,64),0.) - var_pft_out(n, nz,nv,65) = max(var_pft_out(n, nz,nv,65),0.) - var_pft_out(n, nz,nv,66) = max(var_pft_out(n, nz,nv,66),0.) - var_pft_out(n, nz,nv,67) = max(var_pft_out(n, nz,nv,67),0.) - var_pft_out(n, nz,nv,68) = max(var_pft_out(n, nz,nv,68),0.) - var_pft_out(n, nz,nv,69) = max(var_pft_out(n, nz,nv,69),0.) - var_pft_out(n, nz,nv,70) = max(var_pft_out(n, nz,nv,70),0.) - var_pft_out(n, nz,nv,73) = max(var_pft_out(n, nz,nv,73),0.) - var_pft_out(n, nz,nv,74) = max(var_pft_out(n, nz,nv,74),0.) - if(clm45) var_pft_out(n, nz,nv,75) = max(var_pft_out(n, nz,nv,75),0.) + var_pft_out(n, nz,nv,60) = max(var_pft_out(n, nz,nv,60),0.) + var_pft_out(n, nz,nv,61) = max(var_pft_out(n, nz,nv,61),0.) + var_pft_out(n, nz,nv,62) = max(var_pft_out(n, nz,nv,62),0.) + var_pft_out(n, nz,nv,63) = max(var_pft_out(n, nz,nv,63),0.) + var_pft_out(n, nz,nv,64) = max(var_pft_out(n, nz,nv,64),0.) + var_pft_out(n, nz,nv,65) = max(var_pft_out(n, nz,nv,65),0.) + var_pft_out(n, nz,nv,66) = max(var_pft_out(n, nz,nv,66),0.) + var_pft_out(n, nz,nv,67) = max(var_pft_out(n, nz,nv,67),0.) + var_pft_out(n, nz,nv,68) = max(var_pft_out(n, nz,nv,68),0.) + var_pft_out(n, nz,nv,69) = max(var_pft_out(n, nz,nv,69),0.) + var_pft_out(n, nz,nv,70) = max(var_pft_out(n, nz,nv,70),0.) + var_pft_out(n, nz,nv,73) = max(var_pft_out(n, nz,nv,73),0.) + var_pft_out(n, nz,nv,74) = max(var_pft_out(n, nz,nv,74),0.) + if(clm45) var_pft_out(n, nz,nv,75) = max(var_pft_out(n, nz,nv,75),0.) endif - end do NVLOOP3 ! end veg loop - endif ! end carbon check + end do NVLOOP3 ! end veg loop + endif ! end carbon check end do NZLOOP ! end zone loop - + ! Update dayx variable var_pft_out (:,:,28) do j = 28, 28 ! 1,VAR_PFT var_pft_out (:,:,:,28) @@ -2269,165 +2269,165 @@ SUBROUTINE write_regridded_carbon (NTILES, ntiles_rst, NCFID, OUTID, id_glb, & end do end do end do - - ! call NCDF_reshape_getOput (OutID,N,var_col_out,var_pft_out,.false.) - + + ! call NCDF_reshape_getOput (OutID,N,var_col_out,var_pft_out,.false.) + ! column vars clm40 clm45 ! ----------------- --------------------- - ! 1 clm3%g%l%c%ccs%col_ctrunc ! 1 ccs%col_ctrunc_vr (:,1) - ! 2 clm3%g%l%c%ccs%cwdc ! 2 ccs%decomp_cpools_vr(:,1,4) ! cwdc - ! 3 clm3%g%l%c%ccs%litr1c ! 3 ccs%decomp_cpools_vr(:,1,1) ! litr1c - ! 4 clm3%g%l%c%ccs%litr2c ! 4 ccs%decomp_cpools_vr(:,1,2) ! litr2c - ! 5 clm3%g%l%c%ccs%litr3c ! 5 ccs%decomp_cpools_vr(:,1,3) ! litr3c - ! 6 clm3%g%l%c%ccs%pcs_a%totvegc ! 6 ccs%totvegc_col - ! 7 clm3%g%l%c%ccs%prod100c ! 7 ccs%prod100c - ! 8 clm3%g%l%c%ccs%prod10c ! 8 ccs%prod10c - ! 9 clm3%g%l%c%ccs%seedc ! 9 ccs%seedc - ! 10 clm3%g%l%c%ccs%soil1c ! 10 ccs%decomp_cpools_vr(:,1,5) ! soil1c - ! 11 clm3%g%l%c%ccs%soil2c ! 11 ccs%decomp_cpools_vr(:,1,6) ! soil2c - ! 12 clm3%g%l%c%ccs%soil3c ! 12 ccs%decomp_cpools_vr(:,1,7) ! soil3c - ! 13 clm3%g%l%c%ccs%soil4c ! 13 ccs%decomp_cpools_vr(:,1,8) ! soil4c - ! 14 clm3%g%l%c%ccs%totcolc ! 14 ccs%totcolc - ! 15 clm3%g%l%c%ccs%totlitc ! 15 ccs%totlitc - ! 16 clm3%g%l%c%cns%col_ntrunc ! 16 cns%col_ntrunc_vr (:,1) - ! 17 clm3%g%l%c%cns%cwdn ! 17 cns%decomp_npools_vr(:,1,4) ! cwdn - ! 18 clm3%g%l%c%cns%litr1n ! 18 cns%decomp_npools_vr(:,1,1) ! litr1n - ! 19 clm3%g%l%c%cns%litr2n ! 19 cns%decomp_npools_vr(:,1,2) ! litr2n - ! 20 clm3%g%l%c%cns%litr3n ! 20 cns%decomp_npools_vr(:,1,3) ! litr3n - ! 21 clm3%g%l%c%cns%prod100n ! 21 cns%prod100n - ! 22 clm3%g%l%c%cns%prod10n ! 22 cns%prod10n - ! 23 clm3%g%l%c%cns%seedn ! 23 cns%seedn - ! 24 clm3%g%l%c%cns%sminn ! 24 cns%sminn_vr (:,1) - ! 25 clm3%g%l%c%cns%soil1n ! 25 cns%decomp_npools_vr(:,1,5) ! soil1n - ! 26 clm3%g%l%c%cns%soil2n ! 26 cns%decomp_npools_vr(:,1,6) ! soil2n - ! 27 clm3%g%l%c%cns%soil3n ! 27 cns%decomp_npools_vr(:,1,7) ! soil3n - ! 28 clm3%g%l%c%cns%soil4n ! 28 cns%decomp_npools_vr(:,1,8) ! soil4n - ! 29 clm3%g%l%c%cns%totcoln ! 29 cns%totcoln - ! 30 clm3%g%l%c%cps%ann_farea_burned ! 30 cps%fpg - ! 31 clm3%g%l%c%cps%annsum_counter ! 31 cps%annsum_counter - ! 32 clm3%g%l%c%cps%cannavg_t2m ! 32 cps%cannavg_t2m - ! 33 clm3%g%l%c%cps%cannsum_npp ! 33 cps%cannsum_npp - ! 34 clm3%g%l%c%cps%farea_burned ! 34 cps%farea_burned - ! 35 clm3%g%l%c%cps%fire_prob ! 35 cps%fpi_vr (:,1) - ! 36 clm3%g%l%c%cps%fireseasonl ! OLD ! 30 cps%altmax - ! 37 clm3%g%l%c%cps%fpg ! OLD ! 31 cps%annsum_counter - ! 38 clm3%g%l%c%cps%fpi ! OLD ! 32 cps%cannavg_t2m - ! 39 clm3%g%l%c%cps%me ! OLD ! 33 cps%cannsum_npp - ! 40 clm3%g%l%c%cps%mean_fire_prob ! OLD ! 34 cps%farea_burned - ! OLD ! 35 cps%altmax_lastyear - ! OLD ! 36 cps%altmax_indx - ! OLD ! 37 cps%fpg + ! 1 clm3%g%l%c%ccs%col_ctrunc ! 1 ccs%col_ctrunc_vr (:,1) + ! 2 clm3%g%l%c%ccs%cwdc ! 2 ccs%decomp_cpools_vr(:,1,4) ! cwdc + ! 3 clm3%g%l%c%ccs%litr1c ! 3 ccs%decomp_cpools_vr(:,1,1) ! litr1c + ! 4 clm3%g%l%c%ccs%litr2c ! 4 ccs%decomp_cpools_vr(:,1,2) ! litr2c + ! 5 clm3%g%l%c%ccs%litr3c ! 5 ccs%decomp_cpools_vr(:,1,3) ! litr3c + ! 6 clm3%g%l%c%ccs%pcs_a%totvegc ! 6 ccs%totvegc_col + ! 7 clm3%g%l%c%ccs%prod100c ! 7 ccs%prod100c + ! 8 clm3%g%l%c%ccs%prod10c ! 8 ccs%prod10c + ! 9 clm3%g%l%c%ccs%seedc ! 9 ccs%seedc + ! 10 clm3%g%l%c%ccs%soil1c ! 10 ccs%decomp_cpools_vr(:,1,5) ! soil1c + ! 11 clm3%g%l%c%ccs%soil2c ! 11 ccs%decomp_cpools_vr(:,1,6) ! soil2c + ! 12 clm3%g%l%c%ccs%soil3c ! 12 ccs%decomp_cpools_vr(:,1,7) ! soil3c + ! 13 clm3%g%l%c%ccs%soil4c ! 13 ccs%decomp_cpools_vr(:,1,8) ! soil4c + ! 14 clm3%g%l%c%ccs%totcolc ! 14 ccs%totcolc + ! 15 clm3%g%l%c%ccs%totlitc ! 15 ccs%totlitc + ! 16 clm3%g%l%c%cns%col_ntrunc ! 16 cns%col_ntrunc_vr (:,1) + ! 17 clm3%g%l%c%cns%cwdn ! 17 cns%decomp_npools_vr(:,1,4) ! cwdn + ! 18 clm3%g%l%c%cns%litr1n ! 18 cns%decomp_npools_vr(:,1,1) ! litr1n + ! 19 clm3%g%l%c%cns%litr2n ! 19 cns%decomp_npools_vr(:,1,2) ! litr2n + ! 20 clm3%g%l%c%cns%litr3n ! 20 cns%decomp_npools_vr(:,1,3) ! litr3n + ! 21 clm3%g%l%c%cns%prod100n ! 21 cns%prod100n + ! 22 clm3%g%l%c%cns%prod10n ! 22 cns%prod10n + ! 23 clm3%g%l%c%cns%seedn ! 23 cns%seedn + ! 24 clm3%g%l%c%cns%sminn ! 24 cns%sminn_vr (:,1) + ! 25 clm3%g%l%c%cns%soil1n ! 25 cns%decomp_npools_vr(:,1,5) ! soil1n + ! 26 clm3%g%l%c%cns%soil2n ! 26 cns%decomp_npools_vr(:,1,6) ! soil2n + ! 27 clm3%g%l%c%cns%soil3n ! 27 cns%decomp_npools_vr(:,1,7) ! soil3n + ! 28 clm3%g%l%c%cns%soil4n ! 28 cns%decomp_npools_vr(:,1,8) ! soil4n + ! 29 clm3%g%l%c%cns%totcoln ! 29 cns%totcoln + ! 30 clm3%g%l%c%cps%ann_farea_burned ! 30 cps%fpg + ! 31 clm3%g%l%c%cps%annsum_counter ! 31 cps%annsum_counter + ! 32 clm3%g%l%c%cps%cannavg_t2m ! 32 cps%cannavg_t2m + ! 33 clm3%g%l%c%cps%cannsum_npp ! 33 cps%cannsum_npp + ! 34 clm3%g%l%c%cps%farea_burned ! 34 cps%farea_burned + ! 35 clm3%g%l%c%cps%fire_prob ! 35 cps%fpi_vr (:,1) + ! 36 clm3%g%l%c%cps%fireseasonl ! OLD ! 30 cps%altmax + ! 37 clm3%g%l%c%cps%fpg ! OLD ! 31 cps%annsum_counter + ! 38 clm3%g%l%c%cps%fpi ! OLD ! 32 cps%cannavg_t2m + ! 39 clm3%g%l%c%cps%me ! OLD ! 33 cps%cannsum_npp + ! 40 clm3%g%l%c%cps%mean_fire_prob ! OLD ! 34 cps%farea_burned + ! OLD ! 35 cps%altmax_lastyear + ! OLD ! 36 cps%altmax_indx + ! OLD ! 37 cps%fpg ! OLD ! 38 cps%fpi_vr (:,1) - ! OLD ! 39 cps%altmax_lastyear_indx - - ! PFT vars CLM40 CLM45 + ! OLD ! 39 cps%altmax_lastyear_indx + + ! PFT vars CLM40 CLM45 ! -------------- ----- - ! 1 clm3%g%l%c%p%pcs%cpool ! 1 pcs%cpool - ! 2 clm3%g%l%c%p%pcs%deadcrootc ! 2 pcs%deadcrootc - ! 3 clm3%g%l%c%p%pcs%deadcrootc_storage ! 3 pcs%deadcrootc_storage - ! 4 clm3%g%l%c%p%pcs%deadcrootc_xfer ! 4 pcs%deadcrootc_xfer - ! 5 clm3%g%l%c%p%pcs%deadstemc ! 5 pcs%deadstemc - ! 6 clm3%g%l%c%p%pcs%deadstemc_storage ! 6 pcs%deadstemc_storage - ! 7 clm3%g%l%c%p%pcs%deadstemc_xfer ! 7 pcs%deadstemc_xfer - ! 8 clm3%g%l%c%p%pcs%frootc ! 8 pcs%frootc - ! 9 clm3%g%l%c%p%pcs%frootc_storage ! 9 pcs%frootc_storage - ! 10 clm3%g%l%c%p%pcs%frootc_xfer ! 10 pcs%frootc_xfer - ! 11 clm3%g%l%c%p%pcs%gresp_storage ! 11 pcs%gresp_storage - ! 12 clm3%g%l%c%p%pcs%gresp_xfer ! 12 pcs%gresp_xfer - ! 13 clm3%g%l%c%p%pcs%leafc ! 13 pcs%leafc - ! 14 clm3%g%l%c%p%pcs%leafc_storage ! 14 pcs%leafc_storage - ! 15 clm3%g%l%c%p%pcs%leafc_xfer ! 15 pcs%leafc_xfer - ! 16 clm3%g%l%c%p%pcs%livecrootc ! 16 pcs%livecrootc - ! 17 clm3%g%l%c%p%pcs%livecrootc_storage ! 17 pcs%livecrootc_storage - ! 18 clm3%g%l%c%p%pcs%livecrootc_xfer ! 18 pcs%livecrootc_xfer - ! 19 clm3%g%l%c%p%pcs%livestemc ! 19 pcs%livestemc - ! 20 clm3%g%l%c%p%pcs%livestemc_storage ! 20 pcs%livestemc_storage - ! 21 clm3%g%l%c%p%pcs%livestemc_xfer ! 21 pcs%livestemc_xfer - ! 22 clm3%g%l%c%p%pcs%pft_ctrunc ! 22 pcs%pft_ctrunc - ! 23 clm3%g%l%c%p%pcs%xsmrpool ! 23 pcs%xsmrpool - ! 24 clm3%g%l%c%p%pepv%annavg_t2m ! 24 pepv%annavg_t2m - ! 25 clm3%g%l%c%p%pepv%annmax_retransn ! 25 pepv%annmax_retransn - ! 26 clm3%g%l%c%p%pepv%annsum_npp ! 26 pepv%annsum_npp - ! 27 clm3%g%l%c%p%pepv%annsum_potential_gpp ! 27 pepv%annsum_potential_gpp - ! 28 clm3%g%l%c%p%pepv%dayl ! 28 pepv%dayl - ! 29 clm3%g%l%c%p%pepv%days_active ! 29 pepv%days_active - ! 30 clm3%g%l%c%p%pepv%dormant_flag ! 30 pepv%dormant_flag - ! 31 clm3%g%l%c%p%pepv%offset_counter ! 31 pepv%offset_counter - ! 32 clm3%g%l%c%p%pepv%offset_fdd ! 32 pepv%offset_fdd - ! 33 clm3%g%l%c%p%pepv%offset_flag ! 33 pepv%offset_flag - ! 34 clm3%g%l%c%p%pepv%offset_swi ! 34 pepv%offset_swi - ! 35 clm3%g%l%c%p%pepv%onset_counter ! 35 pepv%onset_counter - ! 36 clm3%g%l%c%p%pepv%onset_fdd ! 36 pepv%onset_fdd - ! 37 clm3%g%l%c%p%pepv%onset_flag ! 37 pepv%onset_flag - ! 38 clm3%g%l%c%p%pepv%onset_gdd ! 38 pepv%onset_gdd - ! 39 clm3%g%l%c%p%pepv%onset_gddflag ! 39 pepv%onset_gddflag - ! 40 clm3%g%l%c%p%pepv%onset_swi ! 40 pepv%onset_swi - ! 41 clm3%g%l%c%p%pepv%prev_frootc_to_litter ! 41 pepv%prev_frootc_to_litter - ! 42 clm3%g%l%c%p%pepv%prev_leafc_to_litter ! 42 pepv%prev_leafc_to_litter - ! 43 clm3%g%l%c%p%pepv%tempavg_t2m ! 43 pepv%tempavg_t2m - ! 44 clm3%g%l%c%p%pepv%tempmax_retransn ! 44 pepv%tempmax_retransn - ! 45 clm3%g%l%c%p%pepv%tempsum_npp ! 45 pepv%tempsum_npp - ! 46 clm3%g%l%c%p%pepv%tempsum_potential_gpp ! 46 pepv%tempsum_potential_gpp - ! 47 clm3%g%l%c%p%pepv%xsmrpool_recover ! 47 pepv%xsmrpool_recover - ! 48 clm3%g%l%c%p%pns%deadcrootn ! 48 pns%deadcrootn - ! 49 clm3%g%l%c%p%pns%deadcrootn_storage ! 49 pns%deadcrootn_storage - ! 50 clm3%g%l%c%p%pns%deadcrootn_xfer ! 50 pns%deadcrootn_xfer - ! 51 clm3%g%l%c%p%pns%deadstemn ! 51 pns%deadstemn - ! 52 clm3%g%l%c%p%pns%deadstemn_storage ! 52 pns%deadstemn_storage - ! 53 clm3%g%l%c%p%pns%deadstemn_xfer ! 53 pns%deadstemn_xfer - ! 54 clm3%g%l%c%p%pns%frootn ! 54 pns%frootn - ! 55 clm3%g%l%c%p%pns%frootn_storage ! 55 pns%frootn_storage - ! 56 clm3%g%l%c%p%pns%frootn_xfer ! 56 pns%frootn_xfer - ! 57 clm3%g%l%c%p%pns%leafn ! 57 pns%leafn - ! 58 clm3%g%l%c%p%pns%leafn_storage ! 58 pns%leafn_storage - ! 59 clm3%g%l%c%p%pns%leafn_xfer ! 59 pns%leafn_xfer - ! 60 clm3%g%l%c%p%pns%livecrootn ! 60 pns%livecrootn - ! 61 clm3%g%l%c%p%pns%livecrootn_storage ! 61 pns%livecrootn_storage - ! 62 clm3%g%l%c%p%pns%livecrootn_xfer ! 62 pns%livecrootn_xfer - ! 63 clm3%g%l%c%p%pns%livestemn ! 63 pns%livestemn - ! 64 clm3%g%l%c%p%pns%livestemn_storage ! 64 pns%livestemn_storage - ! 65 clm3%g%l%c%p%pns%livestemn_xfer ! 65 pns%livestemn_xfer - ! 66 clm3%g%l%c%p%pns%npool ! 66 pns%npool - ! 67 clm3%g%l%c%p%pns%pft_ntrunc ! 67 pns%pft_ntrunc - ! 68 clm3%g%l%c%p%pns%retransn ! 68 pns%retransn - ! 69 clm3%g%l%c%p%pps%elai ! 69 pps%elai - ! 70 clm3%g%l%c%p%pps%esai ! 70 pps%esai - ! 71 clm3%g%l%c%p%pps%hbot ! 71 pps%hbot - ! 72 clm3%g%l%c%p%pps%htop ! 72 pps%htop - ! 73 clm3%g%l%c%p%pps%tlai ! 73 pps%tlai - ! 74 clm3%g%l%c%p%pps%tsai ! 74 pps%tsai - ! 75 pepv%plant_ndemand - ! OLD ! 75 pps%gddplant - ! OLD ! 76 pps%gddtsoi - ! OLD ! 77 pps%peaklai - ! OLD ! 78 pps%idop - ! OLD ! 79 pps%aleaf - ! OLD ! 80 pps%aleafi - ! OLD ! 81 pps%astem - ! OLD ! 82 pps%astemi - ! OLD ! 83 pps%htmx - ! OLD ! 84 pps%hdidx - ! OLD ! 85 pps%vf - ! OLD ! 86 pps%cumvd - ! OLD ! 87 pps%croplive - ! OLD ! 88 pps%cropplant - ! OLD ! 89 pps%harvdate - ! OLD ! 90 pps%gdd1020 - ! OLD ! 91 pps%gdd820 - ! OLD ! 92 pps%gdd020 - ! OLD ! 93 pps%gddmaturity - ! OLD ! 94 pps%huileaf - ! OLD ! 95 pps%huigrain - ! OLD ! 96 pcs%grainc - ! OLD ! 97 pcs%grainc_storage - ! OLD ! 98 pcs%grainc_xfer - ! OLD ! 99 pns%grainn - ! OLD !100 pns%grainn_storage - ! OLD !101 pns%grainn_xfer - ! OLD !102 pepv%fert_counter - ! OLD !103 pnf%fert - ! OLD !104 pepv%grain_flag - + ! 1 clm3%g%l%c%p%pcs%cpool ! 1 pcs%cpool + ! 2 clm3%g%l%c%p%pcs%deadcrootc ! 2 pcs%deadcrootc + ! 3 clm3%g%l%c%p%pcs%deadcrootc_storage ! 3 pcs%deadcrootc_storage + ! 4 clm3%g%l%c%p%pcs%deadcrootc_xfer ! 4 pcs%deadcrootc_xfer + ! 5 clm3%g%l%c%p%pcs%deadstemc ! 5 pcs%deadstemc + ! 6 clm3%g%l%c%p%pcs%deadstemc_storage ! 6 pcs%deadstemc_storage + ! 7 clm3%g%l%c%p%pcs%deadstemc_xfer ! 7 pcs%deadstemc_xfer + ! 8 clm3%g%l%c%p%pcs%frootc ! 8 pcs%frootc + ! 9 clm3%g%l%c%p%pcs%frootc_storage ! 9 pcs%frootc_storage + ! 10 clm3%g%l%c%p%pcs%frootc_xfer ! 10 pcs%frootc_xfer + ! 11 clm3%g%l%c%p%pcs%gresp_storage ! 11 pcs%gresp_storage + ! 12 clm3%g%l%c%p%pcs%gresp_xfer ! 12 pcs%gresp_xfer + ! 13 clm3%g%l%c%p%pcs%leafc ! 13 pcs%leafc + ! 14 clm3%g%l%c%p%pcs%leafc_storage ! 14 pcs%leafc_storage + ! 15 clm3%g%l%c%p%pcs%leafc_xfer ! 15 pcs%leafc_xfer + ! 16 clm3%g%l%c%p%pcs%livecrootc ! 16 pcs%livecrootc + ! 17 clm3%g%l%c%p%pcs%livecrootc_storage ! 17 pcs%livecrootc_storage + ! 18 clm3%g%l%c%p%pcs%livecrootc_xfer ! 18 pcs%livecrootc_xfer + ! 19 clm3%g%l%c%p%pcs%livestemc ! 19 pcs%livestemc + ! 20 clm3%g%l%c%p%pcs%livestemc_storage ! 20 pcs%livestemc_storage + ! 21 clm3%g%l%c%p%pcs%livestemc_xfer ! 21 pcs%livestemc_xfer + ! 22 clm3%g%l%c%p%pcs%pft_ctrunc ! 22 pcs%pft_ctrunc + ! 23 clm3%g%l%c%p%pcs%xsmrpool ! 23 pcs%xsmrpool + ! 24 clm3%g%l%c%p%pepv%annavg_t2m ! 24 pepv%annavg_t2m + ! 25 clm3%g%l%c%p%pepv%annmax_retransn ! 25 pepv%annmax_retransn + ! 26 clm3%g%l%c%p%pepv%annsum_npp ! 26 pepv%annsum_npp + ! 27 clm3%g%l%c%p%pepv%annsum_potential_gpp ! 27 pepv%annsum_potential_gpp + ! 28 clm3%g%l%c%p%pepv%dayl ! 28 pepv%dayl + ! 29 clm3%g%l%c%p%pepv%days_active ! 29 pepv%days_active + ! 30 clm3%g%l%c%p%pepv%dormant_flag ! 30 pepv%dormant_flag + ! 31 clm3%g%l%c%p%pepv%offset_counter ! 31 pepv%offset_counter + ! 32 clm3%g%l%c%p%pepv%offset_fdd ! 32 pepv%offset_fdd + ! 33 clm3%g%l%c%p%pepv%offset_flag ! 33 pepv%offset_flag + ! 34 clm3%g%l%c%p%pepv%offset_swi ! 34 pepv%offset_swi + ! 35 clm3%g%l%c%p%pepv%onset_counter ! 35 pepv%onset_counter + ! 36 clm3%g%l%c%p%pepv%onset_fdd ! 36 pepv%onset_fdd + ! 37 clm3%g%l%c%p%pepv%onset_flag ! 37 pepv%onset_flag + ! 38 clm3%g%l%c%p%pepv%onset_gdd ! 38 pepv%onset_gdd + ! 39 clm3%g%l%c%p%pepv%onset_gddflag ! 39 pepv%onset_gddflag + ! 40 clm3%g%l%c%p%pepv%onset_swi ! 40 pepv%onset_swi + ! 41 clm3%g%l%c%p%pepv%prev_frootc_to_litter ! 41 pepv%prev_frootc_to_litter + ! 42 clm3%g%l%c%p%pepv%prev_leafc_to_litter ! 42 pepv%prev_leafc_to_litter + ! 43 clm3%g%l%c%p%pepv%tempavg_t2m ! 43 pepv%tempavg_t2m + ! 44 clm3%g%l%c%p%pepv%tempmax_retransn ! 44 pepv%tempmax_retransn + ! 45 clm3%g%l%c%p%pepv%tempsum_npp ! 45 pepv%tempsum_npp + ! 46 clm3%g%l%c%p%pepv%tempsum_potential_gpp ! 46 pepv%tempsum_potential_gpp + ! 47 clm3%g%l%c%p%pepv%xsmrpool_recover ! 47 pepv%xsmrpool_recover + ! 48 clm3%g%l%c%p%pns%deadcrootn ! 48 pns%deadcrootn + ! 49 clm3%g%l%c%p%pns%deadcrootn_storage ! 49 pns%deadcrootn_storage + ! 50 clm3%g%l%c%p%pns%deadcrootn_xfer ! 50 pns%deadcrootn_xfer + ! 51 clm3%g%l%c%p%pns%deadstemn ! 51 pns%deadstemn + ! 52 clm3%g%l%c%p%pns%deadstemn_storage ! 52 pns%deadstemn_storage + ! 53 clm3%g%l%c%p%pns%deadstemn_xfer ! 53 pns%deadstemn_xfer + ! 54 clm3%g%l%c%p%pns%frootn ! 54 pns%frootn + ! 55 clm3%g%l%c%p%pns%frootn_storage ! 55 pns%frootn_storage + ! 56 clm3%g%l%c%p%pns%frootn_xfer ! 56 pns%frootn_xfer + ! 57 clm3%g%l%c%p%pns%leafn ! 57 pns%leafn + ! 58 clm3%g%l%c%p%pns%leafn_storage ! 58 pns%leafn_storage + ! 59 clm3%g%l%c%p%pns%leafn_xfer ! 59 pns%leafn_xfer + ! 60 clm3%g%l%c%p%pns%livecrootn ! 60 pns%livecrootn + ! 61 clm3%g%l%c%p%pns%livecrootn_storage ! 61 pns%livecrootn_storage + ! 62 clm3%g%l%c%p%pns%livecrootn_xfer ! 62 pns%livecrootn_xfer + ! 63 clm3%g%l%c%p%pns%livestemn ! 63 pns%livestemn + ! 64 clm3%g%l%c%p%pns%livestemn_storage ! 64 pns%livestemn_storage + ! 65 clm3%g%l%c%p%pns%livestemn_xfer ! 65 pns%livestemn_xfer + ! 66 clm3%g%l%c%p%pns%npool ! 66 pns%npool + ! 67 clm3%g%l%c%p%pns%pft_ntrunc ! 67 pns%pft_ntrunc + ! 68 clm3%g%l%c%p%pns%retransn ! 68 pns%retransn + ! 69 clm3%g%l%c%p%pps%elai ! 69 pps%elai + ! 70 clm3%g%l%c%p%pps%esai ! 70 pps%esai + ! 71 clm3%g%l%c%p%pps%hbot ! 71 pps%hbot + ! 72 clm3%g%l%c%p%pps%htop ! 72 pps%htop + ! 73 clm3%g%l%c%p%pps%tlai ! 73 pps%tlai + ! 74 clm3%g%l%c%p%pps%tsai ! 74 pps%tsai + ! 75 pepv%plant_ndemand + ! OLD ! 75 pps%gddplant + ! OLD ! 76 pps%gddtsoi + ! OLD ! 77 pps%peaklai + ! OLD ! 78 pps%idop + ! OLD ! 79 pps%aleaf + ! OLD ! 80 pps%aleafi + ! OLD ! 81 pps%astem + ! OLD ! 82 pps%astemi + ! OLD ! 83 pps%htmx + ! OLD ! 84 pps%hdidx + ! OLD ! 85 pps%vf + ! OLD ! 86 pps%cumvd + ! OLD ! 87 pps%croplive + ! OLD ! 88 pps%cropplant + ! OLD ! 89 pps%harvdate + ! OLD ! 90 pps%gdd1020 + ! OLD ! 91 pps%gdd820 + ! OLD ! 92 pps%gdd020 + ! OLD ! 93 pps%gddmaturity + ! OLD ! 94 pps%huileaf + ! OLD ! 95 pps%huigrain + ! OLD ! 96 pcs%grainc + ! OLD ! 97 pcs%grainc_storage + ! OLD ! 98 pcs%grainc_xfer + ! OLD ! 99 pns%grainn + ! OLD !100 pns%grainn_storage + ! OLD !101 pns%grainn_xfer + ! OLD !102 pepv%fert_counter + ! OLD !103 pnf%fert + ! OLD !104 pepv%grain_flag + end do OUT_TILE i = 1 @@ -2476,7 +2476,7 @@ SUBROUTINE write_regridded_carbon (NTILES, ntiles_rst, NCFID, OUTID, id_glb, & STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'RZMM'), (/1,nz/), (/NTILES,1 /),VAR_DUM(:)) ; VERIFY_(STATUS) if(clm45) STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'SFMM'), (/1,nz/), (/NTILES,1 /),VAR_DUM(:)) ; VERIFY_(STATUS) end do - + STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'BFLOWM' ), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'TOTWATM'), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'TAIRM' ), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) @@ -2484,7 +2484,7 @@ SUBROUTINE write_regridded_carbon (NTILES, ntiles_rst, NCFID, OUTID, id_glb, & STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'CNSUM' ), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'SNDZM' ), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'ASNOWM' ), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) - + if(clm45) then STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'AR1M' ), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'RAINFM' ), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) @@ -2495,10 +2495,10 @@ SUBROUTINE write_regridded_carbon (NTILES, ntiles_rst, NCFID, OUTID, id_glb, & STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'TPREC10D'), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'TPREC60D'), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'T2M10D' ), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) - else + else STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'SFMCM'), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) endif - + do nv = 1,nzone do nz = 1,nveg STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'PSNSUNM'), (/1,nz,nv/), (/NTILES,1,1/),VAR_DUM(:)) ; VERIFY_(STATUS) @@ -2510,12 +2510,12 @@ SUBROUTINE write_regridded_carbon (NTILES, ntiles_rst, NCFID, OUTID, id_glb, & do i = 1,4 STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'WW'), (/1,i/), (/NTILES,1 /),VAR_DUM(:)) end do - + VAR_DUM = 0.25 do i = 1,4 STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'FR'), (/1,i/), (/NTILES,1 /),VAR_DUM(:)) end do - + VAR_DUM = 0.001 do i = 1,4 STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'CH'), (/1,i/), (/NTILES,1 /),VAR_DUM(:)) @@ -2525,10 +2525,10 @@ SUBROUTINE write_regridded_carbon (NTILES, ntiles_rst, NCFID, OUTID, id_glb, & STATUS = NF_CLOSE (NCFID) - deallocate (var_col_out,var_pft_out) + deallocate (var_col_out,var_pft_out) deallocate (CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2) deallocate (CLMC_pt1, CLMC_pt2, CLMC_st1, CLMC_st2) - + END SUBROUTINE write_regridded_carbon ! ***************************************************************************** @@ -2536,22 +2536,22 @@ END SUBROUTINE write_regridded_carbon SUBROUTINE put_land_vars (NTILES, ntiles_rst, id_glb, ld_reorder, model, rst_file) implicit none - character(*), intent (in) :: model + character(*), intent (in) :: model integer, intent (in) :: NTILES, ntiles_rst integer, intent (in) :: id_glb(NTILES), ld_reorder (ntiles_rst) integer :: k, rc real , dimension (:), allocatable :: var_get, var_put type(Netcdf4_FileFormatter):: OutFmt, InFmt - type(FileMetadata) :: meta_data + type(FileMetadata) :: meta_data integer :: STATUS, NCFID, OUTID character(*), intent (in), optional :: rst_file character(256) :: Iam = "put_land_vars" allocate (var_get (NTILES_RST)) allocate (var_put (NTILES)) - + ! create output catchcn_internal_rst - if(index(model,'catchcn') /=0) then + if(index(model,'catchcn') /=0) then if (clm45) then call InFmt%open('/discover/nobackup/projects/gmao/ssd/land/l_data/LandRestarts_for_Regridding/CatchCN/catchcn_internal_clm45',PFIO_READ, __RC__) else @@ -2559,7 +2559,7 @@ SUBROUTINE put_land_vars (NTILES, ntiles_rst, id_glb, ld_reorder, model, rst_fil endif endif if(trim(model) == 'catch' ) then - call InFmt%open(trim(InCatRestart), pFIO_READ, __RC__) + call InFmt%open(trim(InCatRestart), pFIO_READ, __RC__) endif meta_data = InFmt%read(__RC__) call InFmt%close(__RC__) @@ -2568,17 +2568,17 @@ SUBROUTINE put_land_vars (NTILES, ntiles_rst, id_glb, ld_reorder, model, rst_fil OutFileName = "InData/"//trim(model)//"_internal_rst" - call OutFmt%create(trim(OutFileName),__RC__) + call OutFmt%create(trim(OutFileName),__RC__) call OutFmt%write(meta_data,__RC__) - + if (present(rst_file)) then - STATUS = NF_OPEN (trim(rst_file ),NF_NOWRITE,NCFID) ; VERIFY_(STATUS) + STATUS = NF_OPEN (trim(rst_file ),NF_NOWRITE,NCFID) ; VERIFY_(STATUS) else if(index(model, 'catchcn') /=0 ) then - STATUS = NF_OPEN (trim(InCNRestart ),NF_NOWRITE,NCFID) ; VERIFY_(STATUS) + STATUS = NF_OPEN (trim(InCNRestart ),NF_NOWRITE,NCFID) ; VERIFY_(STATUS) endif if(trim(model) == 'catch') then - STATUS = NF_OPEN (trim(InCatRestart),NF_NOWRITE,NCFID) ; VERIFY_(STATUS) + STATUS = NF_OPEN (trim(InCatRestart),NF_NOWRITE,NCFID) ; VERIFY_(STATUS) endif endif @@ -2590,418 +2590,418 @@ SUBROUTINE put_land_vars (NTILES, ntiles_rst, id_glb, ld_reorder, model, rst_fil VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do call MAPL_VarWrite(OutFmt,'POROS',var_put) - + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'COND' ), (/1/), (/NTILES_RST/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do call MAPL_VarWrite(OutFmt,'COND',var_put) - + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'PSIS' ), (/1/), (/NTILES_RST/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do call MAPL_VarWrite(OutFmt,'PSIS',var_put) - + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'BEE' ), (/1/), (/NTILES_RST/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'BEE',var_put) - + call MAPL_VarWrite(OutFmt,'BEE',var_put) + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'WPWET' ), (/1/), (/NTILES_RST/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'WPWET',var_put) - + call MAPL_VarWrite(OutFmt,'WPWET',var_put) + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'GNU' ), (/1/), (/NTILES_RST/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do call MAPL_VarWrite(OutFmt,'GNU',var_put) - + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'VGWMAX' ), (/1/), (/NTILES_RST/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'VGWMAX',var_put) - + call MAPL_VarWrite(OutFmt,'VGWMAX',var_put) + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'BF1' ), (/1/), (/NTILES_RST/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'BF1',var_put) - + call MAPL_VarWrite(OutFmt,'BF1',var_put) + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'BF2' ), (/1/), (/NTILES_RST/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'BF2',var_put) - + call MAPL_VarWrite(OutFmt,'BF2',var_put) + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'BF3' ), (/1/), (/NTILES_RST/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'BF3',var_put) - + call MAPL_VarWrite(OutFmt,'BF3',var_put) + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CDCR1' ), (/1/), (/NTILES_RST/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'CDCR1',var_put) - + call MAPL_VarWrite(OutFmt,'CDCR1',var_put) + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CDCR2' ), (/1/), (/NTILES_RST/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'CDCR2',var_put) - + call MAPL_VarWrite(OutFmt,'CDCR2',var_put) + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARS1' ), (/1/), (/NTILES_RST/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'ARS1',var_put) - + call MAPL_VarWrite(OutFmt,'ARS1',var_put) + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARS2' ), (/1/), (/NTILES_RST/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'ARS2',var_put) - + call MAPL_VarWrite(OutFmt,'ARS2',var_put) + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARS3' ), (/1/), (/NTILES_RST/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'ARS3',var_put) - + call MAPL_VarWrite(OutFmt,'ARS3',var_put) + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARA1' ), (/1/), (/NTILES_RST/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'ARA1',var_put) - + call MAPL_VarWrite(OutFmt,'ARA1',var_put) + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARA2' ), (/1/), (/NTILES_RST/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'ARA2',var_put) - + call MAPL_VarWrite(OutFmt,'ARA2',var_put) + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARA3' ), (/1/), (/NTILES_RST/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'ARA3',var_put) - + call MAPL_VarWrite(OutFmt,'ARA3',var_put) + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARA4' ), (/1/), (/NTILES_RST/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do call MAPL_VarWrite(OutFmt,'ARA4',var_put) - + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARW1' ), (/1/), (/NTILES_RST/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'ARW1',var_put) - + call MAPL_VarWrite(OutFmt,'ARW1',var_put) + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARW2' ), (/1/), (/NTILES_RST/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'ARW2',var_put) - + call MAPL_VarWrite(OutFmt,'ARW2',var_put) + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARW3' ), (/1/), (/NTILES_RST/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'ARW3',var_put) - + call MAPL_VarWrite(OutFmt,'ARW3',var_put) + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARW4' ), (/1/), (/NTILES_RST/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'ARW4',var_put) - + call MAPL_VarWrite(OutFmt,'ARW4',var_put) + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TSA1' ), (/1/), (/NTILES_RST/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'TSA1',var_put) - + call MAPL_VarWrite(OutFmt,'TSA1',var_put) + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TSA2' ), (/1/), (/NTILES_RST/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'TSA2',var_put) - + call MAPL_VarWrite(OutFmt,'TSA2',var_put) + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TSB1' ), (/1/), (/NTILES_RST/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'TSB1',var_put) - + call MAPL_VarWrite(OutFmt,'TSB1',var_put) + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TSB2' ), (/1/), (/NTILES_RST/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'TSB2',var_put) - + call MAPL_VarWrite(OutFmt,'TSB2',var_put) + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ATAU' ), (/1/), (/NTILES_RST/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'ATAU',var_put) - + call MAPL_VarWrite(OutFmt,'ATAU',var_put) + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'BTAU' ), (/1/), (/NTILES_RST/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'BTAU',var_put) - + call MAPL_VarWrite(OutFmt,'BTAU',var_put) + if(index(model,'catchcn') /=0) then STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ITY' ), (/1,1/), (/NTILES_RST,1/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'ITY',var_put, offset1=1) + call MAPL_VarWrite(OutFmt,'ITY',var_put, offset1=1) STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ITY' ), (/1,2/), (/NTILES_RST,1/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'ITY',var_put, offset1=2) + call MAPL_VarWrite(OutFmt,'ITY',var_put, offset1=2) STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ITY' ), (/1,3/), (/NTILES_RST,1/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'ITY',var_put, offset1=3) + call MAPL_VarWrite(OutFmt,'ITY',var_put, offset1=3) STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ITY' ), (/1,4/), (/NTILES_RST,1/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do call MAPL_VarWrite(OutFmt,'ITY',var_put, offset1=4) - + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'FVG' ), (/1,1/), (/NTILES_RST,1/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'FVG',var_put, offset1=1) + call MAPL_VarWrite(OutFmt,'FVG',var_put, offset1=1) STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'FVG' ), (/1,2/), (/NTILES_RST,1/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'FVG',var_put, offset1=2) + call MAPL_VarWrite(OutFmt,'FVG',var_put, offset1=2) STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'FVG' ), (/1,3/), (/NTILES_RST,1/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'FVG',var_put, offset1=3) + call MAPL_VarWrite(OutFmt,'FVG',var_put, offset1=3) STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'FVG' ), (/1,4/), (/NTILES_RST,1/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do call MAPL_VarWrite(OutFmt,'FVG',var_put, offset1=4) - + ! read restart and regrid ! ----------------------- - + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TG' ), (/1,1/), (/NTILES_RST,1/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do call MAPL_VarWrite(OutFmt,'TG',var_put, offset1=1) ! if you see offset1=1 it is a 2-D var - + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TG' ), (/1,2/), (/NTILES_RST,1/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'TG',var_put, offset1=2) - + call MAPL_VarWrite(OutFmt,'TG',var_put, offset1=2) + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TG' ), (/1,3/), (/NTILES_RST,1/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'TG',var_put, offset1=3) - + call MAPL_VarWrite(OutFmt,'TG',var_put, offset1=3) + endif - + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TC' ), (/1,1/), (/NTILES_RST,1/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TC',var_put, offset1=1) - + end do + call MAPL_VarWrite(OutFmt,'TC',var_put, offset1=1) + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TC' ), (/1,2/), (/NTILES_RST,1/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'TC',var_put, offset1=2) - + call MAPL_VarWrite(OutFmt,'TC',var_put, offset1=2) + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TC' ), (/1,3/), (/NTILES_RST,1/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'TC',var_put, offset1=3) - + call MAPL_VarWrite(OutFmt,'TC',var_put, offset1=3) + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'QC' ), (/1,1/), (/NTILES_RST,1/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'QC',var_put, offset1=1) - + call MAPL_VarWrite(OutFmt,'QC',var_put, offset1=1) + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'QC' ), (/1,2/), (/NTILES_RST,1/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do call MAPL_VarWrite(OutFmt,'QC',var_put, offset1=2) - + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'QC' ), (/1,3/), (/NTILES_RST,1/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do call MAPL_VarWrite(OutFmt,'QC',var_put, offset1=3) - + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CAPAC' ), (/1/), (/NTILES_RST/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'CAPAC',var_put) - + call MAPL_VarWrite(OutFmt,'CAPAC',var_put) + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CATDEF' ), (/1/), (/NTILES_RST/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'CATDEF',var_put) - + call MAPL_VarWrite(OutFmt,'CATDEF',var_put) + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'RZEXC' ), (/1/), (/NTILES_RST/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'RZEXC',var_put) - + call MAPL_VarWrite(OutFmt,'RZEXC',var_put) + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'SRFEXC' ), (/1/), (/NTILES_RST/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'SRFEXC',var_put) - + call MAPL_VarWrite(OutFmt,'SRFEXC',var_put) + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'GHTCNT1' ), (/1/), (/NTILES_RST/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'GHTCNT1',var_put) - + call MAPL_VarWrite(OutFmt,'GHTCNT1',var_put) + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'GHTCNT2' ), (/1/), (/NTILES_RST/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'GHTCNT2',var_put) - + call MAPL_VarWrite(OutFmt,'GHTCNT2',var_put) + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'GHTCNT3' ), (/1/), (/NTILES_RST/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'GHTCNT3',var_put) - + call MAPL_VarWrite(OutFmt,'GHTCNT3',var_put) + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'GHTCNT4' ), (/1/), (/NTILES_RST/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'GHTCNT4',var_put) - + call MAPL_VarWrite(OutFmt,'GHTCNT4',var_put) + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'GHTCNT5' ), (/1/), (/NTILES_RST/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'GHTCNT5',var_put) - + call MAPL_VarWrite(OutFmt,'GHTCNT5',var_put) + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'GHTCNT6' ), (/1/), (/NTILES_RST/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'GHTCNT6',var_put) - + call MAPL_VarWrite(OutFmt,'GHTCNT6',var_put) + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'WESNN1' ), (/1/), (/NTILES_RST/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'WESNN1',var_put) - + call MAPL_VarWrite(OutFmt,'WESNN1',var_put) + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'WESNN2' ), (/1/), (/NTILES_RST/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'WESNN2',var_put) - + call MAPL_VarWrite(OutFmt,'WESNN2',var_put) + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'WESNN3' ), (/1/), (/NTILES_RST/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'WESNN3',var_put) - + call MAPL_VarWrite(OutFmt,'WESNN3',var_put) + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'HTSNNN1' ), (/1/), (/NTILES_RST/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'HTSNNN1',var_put) - + call MAPL_VarWrite(OutFmt,'HTSNNN1',var_put) + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'HTSNNN2' ), (/1/), (/NTILES_RST/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'HTSNNN2',var_put) - + call MAPL_VarWrite(OutFmt,'HTSNNN2',var_put) + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'HTSNNN3' ), (/1/), (/NTILES_RST/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'HTSNNN3',var_put) - + call MAPL_VarWrite(OutFmt,'HTSNNN3',var_put) + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'SNDZN1' ), (/1/), (/NTILES_RST/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'SNDZN1',var_put) - + call MAPL_VarWrite(OutFmt,'SNDZN1',var_put) + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'SNDZN2' ), (/1/), (/NTILES_RST/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'SNDZN2',var_put) - + call MAPL_VarWrite(OutFmt,'SNDZN2',var_put) + STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'SNDZN3' ), (/1/), (/NTILES_RST/),var_get) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'SNDZN3',var_put) + call MAPL_VarWrite(OutFmt,'SNDZN3',var_put) ! CH CM CQ FR WW ! WW VAR_PUT = 0.1 do k = 1,4 - call MAPL_VarWrite(OutFmt,'WW',VAR_PUT ,offset1=k) + call MAPL_VarWrite(OutFmt,'WW',VAR_PUT ,offset1=k) end do ! FR VAR_PUT = 0.25 do k = 1,4 - call MAPL_VarWrite(OutFmt,'FR',VAR_PUT ,offset1=k) + call MAPL_VarWrite(OutFmt,'FR',VAR_PUT ,offset1=k) end do - ! CH CM CQ + ! CH CM CQ VAR_PUT = 0.001 do k = 1,4 - call MAPL_VarWrite(OutFmt,'CH',VAR_PUT ,offset1=k) - call MAPL_VarWrite(OutFmt,'CM',VAR_PUT ,offset1=k) - call MAPL_VarWrite(OutFmt,'CQ',VAR_PUT ,offset1=k) + call MAPL_VarWrite(OutFmt,'CH',VAR_PUT ,offset1=k) + call MAPL_VarWrite(OutFmt,'CM',VAR_PUT ,offset1=k) + call MAPL_VarWrite(OutFmt,'CQ',VAR_PUT ,offset1=k) end do - call OutFmt%close(__RC__) + call OutFmt%close(__RC__) STATUS = NF_CLOSE ( NCFID) deallocate (var_get, var_put) @@ -3010,25 +3010,25 @@ SUBROUTINE put_land_vars (NTILES, ntiles_rst, id_glb, ld_reorder, model, rst_fil END SUBROUTINE put_land_vars ! ***************************************************************************** - + subroutine init_MPI() - + ! initialize MPI - + call MPI_INIT(mpierr) - + call MPI_COMM_RANK( MPI_COMM_WORLD, myid, mpierr ) call MPI_COMM_SIZE( MPI_COMM_WORLD, numprocs, mpierr ) if (myid .ne. 0) root_proc = .false. - + ! call init_MPI_types() - - write (*,*) "MPI process ", myid, " of ", numprocs, " is alive" + + write (*,*) "MPI process ", myid, " of ", numprocs, " is alive" write (*,*) "MPI process ", myid, ": root_proc=", root_proc end subroutine init_MPI - + ! ----------------------------------------------------------------------- SUBROUTINE HANDLE_ERR(STATUS, Line) @@ -3048,18 +3048,18 @@ END SUBROUTINE HANDLE_ERR subroutine compute_dayx ( & NTILES, AGCM_YY, AGCM_MM, AGCM_DD, AGCM_HR, & LATT, DAYX) - + implicit none - integer, intent (in) :: NTILES,AGCM_YY,AGCM_MM,AGCM_DD,AGCM_HR + integer, intent (in) :: NTILES,AGCM_YY,AGCM_MM,AGCM_DD,AGCM_HR real, dimension (NTILES), intent (in) :: LATT real, dimension (NTILES), intent (out) :: DAYX integer, parameter :: DT = 900 - integer, parameter :: ncycle = 1461 ! number of days in a 4-year leap cycle (365*4 + 1) + integer, parameter :: ncycle = 1461 ! number of days in a 4-year leap cycle (365*4 + 1) real, dimension(ncycle) :: zc, zs - integer :: dofyr, sec,YEARS_PER_CYCLE, DAYS_PER_CYCLE, year, iday, idayp1, nn, n + integer :: dofyr, sec,YEARS_PER_CYCLE, DAYS_PER_CYCLE, year, iday, idayp1, nn, n real :: fac, YEARLEN, zsin, zcos, declin - + dofyr = AGCM_DD if(AGCM_MM > 1) dofyr = dofyr + 31 if(AGCM_MM > 2) then @@ -3075,14 +3075,14 @@ subroutine compute_dayx ( & if(AGCM_MM > 9) dofyr = dofyr + 30 if(AGCM_MM > 10) dofyr = dofyr + 31 if(AGCM_MM > 11) dofyr = dofyr + 30 - + sec = AGCM_HR * 3600 - DT ! subtract DT to get time of previous physics step fac = real(sec) / 86400. call orbit_create(zs,zc,ncycle) ! GEOS5 leap cycle routine - + YEARLEN = 365.25 - + ! Compute length of leap cycle !------------------------------ @@ -3091,100 +3091,100 @@ subroutine compute_dayx ( & else YEARS_PER_CYCLE = 1 endif - + DAYS_PER_CYCLE=nint(YEARLEN*YEARS_PER_CYCLE) - + ! declination & daylength ! ----------------------- YEAR = mod(AGCM_YY-1,YEARS_PER_CYCLE) - + IDAY = YEAR*int(YEARLEN)+dofyr IDAYP1 = mod(IDAY,DAYS_PER_CYCLE) + 1 ZSin = ZS(IDAYP1)*FAC + ZS(IDAY)*(1.-FAC) ! sine of solar declination ZCos = ZC(IDAYP1)*FAC + ZC(IDAY)*(1.-FAC) ! cosine of solar declination - + nn = 0 do n = 1,days_per_cycle nn = nn + 1 if(nn > 365) nn = nn - 365 ! print *, 'cycle:',n,nn,asin(ZS(n)) end do - + declin = asin(ZSin) - - ! compute daylength on input tile space (accounts for any change in physics time step) + + ! compute daylength on input tile space (accounts for any change in physics time step) ! do n = 1,ntiles_cn ! fac = -(sin((latc(n)/zoom)*(MAPL_PI/180.))*zsin)/(cos((latc(n)/zoom)*(MAPL_PI/180.))*zcos) ! fac = min(1.,max(-1.,fac)) ! dayl(n) = (86400./MAPL_PI) * acos(fac) ! daylength (seconds) ! end do - + ! compute daylength on output tile space (accounts for lat shift due to split & change in time step) - + do n = 1,ntiles fac = -(sin(latt(n)*(MAPL_PI/180.))*zsin)/(cos(latt(n)*(MAPL_PI/180.))*zcos) fac = min(1.,max(-1.,fac)) dayx(n) = (86400./MAPL_PI) * acos(fac) ! daylength (seconds) end do - + ! print *,'DAYX : ', minval(dayx),maxval(dayx), minval(latt), maxval(latt), zsin, zcos, dofyr, iday, idayp1, declin - + end subroutine compute_dayx ! ***************************************************************************** subroutine orbit_create(zs,zc,ncycle) - + implicit none - + integer, intent(in) :: ncycle real, intent(out), dimension(ncycle) :: zs, zc - + integer :: YEARS_PER_CYCLE, DAYS_PER_CYCLE integer :: K, KP !, KM real*8 :: T1, T2, T3, T4, FUN, Y, SOB, OMG, PRH, TT real*8 :: YEARLEN - + ! STATEMENT FUNCTION - + FUN(Y) = OMG*(1.0-ECCENTRICITY*cos(Y-PRH))**2 - + YEARLEN = 365.25 - + ! Factors involving the orbital parameters !------------------------------------------ - + OMG = (2.0*MAPL_PI/YEARLEN) / (sqrt(1.-ECCENTRICITY**2)**3) PRH = PERIHELION*(MAPL_PI/180.) SOB = sin(OBLIQUITY*(MAPL_PI/180.)) - + ! Compute length of leap cycle !------------------------------ - + if(YEARLEN-int(YEARLEN) > 0.) then YEARS_PER_CYCLE = nint(1./(YEARLEN-int(YEARLEN))) else YEARS_PER_CYCLE = 1 endif - + DAYS_PER_CYCLE=nint(YEARLEN*YEARS_PER_CYCLE) - + if(days_per_cycle /= ncycle) stop 'bad cycle' - + ! ZS: Sine of declination ! ZC: Cosine of declination - + ! Begin integration at vernal equinox - + KP = EQUINOX TT = 0.0 ZS(KP) = sin(TT)*SOB ZC(KP) = sqrt(1.0-ZS(KP)**2) - + ! Integrate orbit for entire leap cycle using Runge-Kutta - + do K=2,DAYS_PER_CYCLE T1 = FUN(TT ) T2 = FUN(TT+T1*0.5) @@ -3195,7 +3195,7 @@ subroutine orbit_create(zs,zc,ncycle) ZS(KP) = sin(TT)*SOB ZC(KP) = sqrt(1.0-ZS(KP)**2) end do - + end subroutine orbit_create ! ***************************************************************************** @@ -3211,13 +3211,13 @@ end subroutine orbit_create ! end function to_radian ! ! ! ***************************************************************************** -! +! ! real function haversine(deglat1,deglon1,deglat2,deglon2) -! ! great circle distance -- adapted from Matlab +! ! great circle distance -- adapted from Matlab ! real,intent(in) :: deglat1,deglon1,deglat2,deglon2 ! real :: a,c, dlat,dlon,lat1,lat2 ! real,parameter :: radius = MAPL_radius -! +! !! dlat = to_radian(deglat2-deglat1) !! dlon = to_radian(deglon2-deglon1) ! ! lat1 = to_radian(deglat1) @@ -3225,7 +3225,7 @@ end subroutine orbit_create ! dlat = deglat2-deglat1 ! dlon = deglon2-deglon1 ! lat1 = deglat1 -! lat2 = deglat2 +! lat2 = deglat2 ! a = (sin(dlat/2))**2 + cos(lat1)*cos(lat2)*(sin(dlon/2))**2 ! if(a>=0. .and. a<=1.) then ! c = 2*atan2(sqrt(a),sqrt(1-a)) @@ -3237,77 +3237,77 @@ end subroutine orbit_create ! ! ! ---------------------------------------------------------------------- - integer function VarID (NCFID, VNAME) - + 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)) - + CALL HANDLE_ERR(STATUS, trim(VNAME)) + end function VarID ! ! ----------------------------------------------------------------------------- -! - - FUNCTION StrUpCase ( Input_String ) RESULT ( Output_String ) - ! -- Argument and result - CHARACTER( * ), INTENT( IN ) :: Input_String - CHARACTER( LEN( Input_String ) ) :: Output_String - ! -- Local variables - INTEGER :: i, n - - - ! -- Copy input string - Output_String = Input_String - ! -- Loop over string elements - DO i = 1, LEN( Output_String ) - ! -- Find location of letter in lower case constant string - n = INDEX( LOWER_CASE, Output_String( i:i ) ) - ! -- If current substring is a lower case letter, make it upper case - IF ( n /= 0 ) Output_String( i:i ) = UPPER_CASE( n:n ) - END DO - END FUNCTION StrUpCase +! + + FUNCTION StrUpCase ( Input_String ) RESULT ( Output_String ) + ! -- Argument and result + CHARACTER( * ), INTENT( IN ) :: Input_String + CHARACTER( LEN( Input_String ) ) :: Output_String + ! -- Local variables + INTEGER :: i, n + + + ! -- Copy input string + Output_String = Input_String + ! -- Loop over string elements + DO i = 1, LEN( Output_String ) + ! -- Find location of letter in lower case constant string + n = INDEX( LOWER_CASE, Output_String( i:i ) ) + ! -- If current substring is a lower case letter, make it upper case + IF ( n /= 0 ) Output_String( i:i ) = UPPER_CASE( n:n ) + END DO + END FUNCTION StrUpCase ! ----------------------------------------------------------------------------- - FUNCTION StrLowCase ( Input_String ) RESULT ( Output_String ) - ! -- Argument and result - CHARACTER( * ), INTENT( IN ) :: Input_String - CHARACTER( LEN( Input_String ) ) :: Output_String - ! -- Local variables - INTEGER :: i, n - - ! -- Copy input string - Output_String = Input_String - ! -- Loop over string elements - DO i = 1, LEN( Output_String ) - ! -- Find location of letter in upper case constant string - n = INDEX( UPPER_CASE, Output_String( i:i ) ) - ! -- If current substring is an upper case letter, make it lower case - IF ( n /= 0 ) Output_String( i:i ) = LOWER_CASE( n:n ) - END DO - END FUNCTION StrLowCase + FUNCTION StrLowCase ( Input_String ) RESULT ( Output_String ) + ! -- Argument and result + CHARACTER( * ), INTENT( IN ) :: Input_String + CHARACTER( LEN( Input_String ) ) :: Output_String + ! -- Local variables + INTEGER :: i, n + + ! -- Copy input string + Output_String = Input_String + ! -- Loop over string elements + DO i = 1, LEN( Output_String ) + ! -- Find location of letter in upper case constant string + n = INDEX( UPPER_CASE, Output_String( i:i ) ) + ! -- If current substring is an upper case letter, make it lower case + IF ( n /= 0 ) Output_String( i:i ) = LOWER_CASE( n:n ) + END DO + END FUNCTION StrLowCase ! ----------------------------------------------------------------------------- - - FUNCTION StrExtName ( Input_String ) RESULT ( Output_String ) - ! -- Argument and result - CHARACTER( * ), INTENT( IN ) :: Input_String - CHARACTER( LEN( Input_String ) ) :: Output_String - ! -- Local variables - INTEGER :: i, n1, n2, n3, n4, n5, n, k - - ! -- Copy input string - ! Output_String = Input_String - ! -- Loop over string elements + + FUNCTION StrExtName ( Input_String ) RESULT ( Output_String ) + ! -- Argument and result + CHARACTER( * ), INTENT( IN ) :: Input_String + CHARACTER( LEN( Input_String ) ) :: Output_String + ! -- Local variables + INTEGER :: i, n1, n2, n3, n4, n5, n, k + + ! -- Copy input string + ! Output_String = Input_String + ! -- Loop over string elements k = 1 - DO i = 1, LEN( Input_String ) + DO i = 1, LEN( Input_String ) - ! -- Find location of letter in upper case constant string + ! -- Find location of letter in upper case constant string n1 = INDEX( UPPER_CASE, Input_String( i:i ) ) n2 = INDEX( LOWER_CASE, Input_String( i:i ) ) n3 = INDEX( '.', Input_String( i:i ) ) @@ -3322,19 +3322,19 @@ FUNCTION StrExtName ( Input_String ) RESULT ( Output_String ) if (n3 /= 0) n = n3 if (n4 /= 0) n = n4 if (n5 /= 0) n = n5 - - ! -- If current substring is acceptable + + ! -- If current substring is acceptable IF ( n /= 0 ) then Output_String( k:k ) = Input_String( i:i ) k = k + 1 endif - END DO + END DO END FUNCTION StrExtName ! ---------------------------------------------------------------------------- - + SUBROUTINE write_bin (unit, InFmt, NTILES) implicit none @@ -3401,7 +3401,7 @@ SUBROUTINE write_bin (unit, InFmt, NTILES) real :: fr(ntiles,4) real :: ww(ntiles,4) character*256 :: Iam = "Write bin" - integer :: status + integer :: status call MAPL_VarRead(InFmt,"BF1",bf1, __RC__) call MAPL_VarRead(InFmt,"BF2",bf2, __RC__) @@ -3461,7 +3461,7 @@ SUBROUTINE write_bin (unit, InFmt, NTILES) call MAPL_VarRead(InFmt,"CQ",cq, __RC__) call MAPL_VarRead(InFmt,"FR",fr, __RC__) call MAPL_VarRead(InFmt,"WW",ww, __RC__) - + write(unit) bf1 write(unit) bf2 write(unit) bf3 @@ -3519,13 +3519,13 @@ SUBROUTINE write_bin (unit, InFmt, NTILES) write(unit) cq write(unit) fr write(unit) ww - + END SUBROUTINE write_bin - + ! ---------------------------------------------------------------------------- SUBROUTINE read_ldas_restarts (NTILES, ntiles_rst, id_glb, ld_reorder, rst_file, pfile) - + implicit none integer, intent (in) :: NTILES, ntiles_rst integer, intent (in) :: id_glb(NTILES), ld_reorder (ntiles_rst) @@ -3536,9 +3536,9 @@ SUBROUTINE read_ldas_restarts (NTILES, ntiles_rst, id_glb, ld_reorder, rst_file type(FileMetadata) :: meta_data allocate (var_get (NTILES_RST)) - allocate (var_put (NTILES)) + allocate (var_put (NTILES)) - call InFmt%Open(trim(InCatRestart), pFIO_READ, __RC__) + call InFmt%Open(trim(InCatRestart), pFIO_READ, __RC__) meta_data = InFmt%read(__RC__) call InFmt%close() call meta_data%modify_dimension('tile', ntiles, __RC__) @@ -3567,7 +3567,7 @@ SUBROUTINE read_ldas_restarts (NTILES, ntiles_rst, id_glb, ld_reorder, rst_file VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do call MAPL_VarWrite(OutFmt,'TC',var_put, offset1=3) - + read (10) var_get ! (cat_progn(n)%qa1, n=1,N_catd) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) @@ -3592,7 +3592,7 @@ SUBROUTINE read_ldas_restarts (NTILES, ntiles_rst, id_glb, ld_reorder, rst_file VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do call MAPL_VarWrite(OutFmt,'CAPAC',var_put) - + read (10) var_get ! (cat_progn(n)%catdef, n=1,N_catd) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) @@ -3610,7 +3610,7 @@ SUBROUTINE read_ldas_restarts (NTILES, ntiles_rst, id_glb, ld_reorder, rst_file VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do call MAPL_VarWrite(OutFmt,'SRFEXC',var_put) - + read (10) var_get ! (cat_progn(n)%ght(k), n=1,N_catd) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) @@ -3695,15 +3695,15 @@ SUBROUTINE read_ldas_restarts (NTILES, ntiles_rst, id_glb, ld_reorder, rst_file ! PARAM open(10, file=trim(pfile), form='unformatted', status='old', & - convert='big_endian', action='read') + convert='big_endian', action='read') read (10) var_get !(cat_param(n)%dpth, n=1,N_catd) - - read (10) var_get !(cat_param(n)%dzsf, n=1,N_catd) - read (10) var_get !(cat_param(n)%dzrz, n=1,N_catd) - read (10) var_get !(cat_param(n)%dzpr, n=1,N_catd) - + + read (10) var_get !(cat_param(n)%dzsf, n=1,N_catd) + read (10) var_get !(cat_param(n)%dzrz, n=1,N_catd) + read (10) var_get !(cat_param(n)%dzpr, n=1,N_catd) + do k=1,6 read (10) var_get !(cat_param(n)%dzgt(k), n=1,N_catd) end do @@ -3712,13 +3712,13 @@ SUBROUTINE read_ldas_restarts (NTILES, ntiles_rst, id_glb, ld_reorder, rst_file end do call MAPL_VarWrite(OutFmt,'TILE_ID',var_put) - read (10) var_get !(cat_param(n)%poros, n=1,N_catd) + read (10) var_get !(cat_param(n)%poros, n=1,N_catd) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do call MAPL_VarWrite(OutFmt,'POROS',var_put) - read (10) var_get !(cat_param(n)%cond, n=1,N_catd) + read (10) var_get !(cat_param(n)%cond, n=1,N_catd) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do @@ -3729,40 +3729,40 @@ SUBROUTINE read_ldas_restarts (NTILES, ntiles_rst, id_glb, ld_reorder, rst_file VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do call MAPL_VarWrite(OutFmt,'PSIS',var_put) - + read (10) var_get !(cat_param(n)%bee, n=1,N_catd) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do - call MAPL_VarWrite(OutFmt,'BEE',var_put) - + call MAPL_VarWrite(OutFmt,'BEE',var_put) + read (10) var_get !(cat_param(n)%wpwet, n=1,N_catd) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do call MAPL_VarWrite(OutFmt,'WPWET',var_put) - - read (10) var_get !(cat_param(n)%gnu, n=1,N_catd) + + read (10) var_get !(cat_param(n)%gnu, n=1,N_catd) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do call MAPL_VarWrite(OutFmt,'GNU',var_put) - - read (10) var_get !(cat_param(n)%vgwmax, n=1,N_catd) + + read (10) var_get !(cat_param(n)%vgwmax, n=1,N_catd) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do call MAPL_VarWrite(OutFmt,'VGWMAX',var_put) - - read (10) var_get !(cat_param(n)%vegcls, n=1,N_catd) + + read (10) var_get !(cat_param(n)%vegcls, n=1,N_catd) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) end do call MAPL_VarWrite(OutFmt,'OLD_ITY',var_put) - read (10) var_get !(cat_param(n)%soilcls30, n=1,N_catd) - read (10) var_get !(cat_param(n)%soilcls100, n=1,N_catd) - + read (10) var_get !(cat_param(n)%soilcls30, n=1,N_catd) + read (10) var_get !(cat_param(n)%soilcls100, n=1,N_catd) + read (10) var_get !(cat_param(n)%bf1, n=1,N_catd) do k = 1, NTILES VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_LakeLandiceSaltRestarts.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_LakeLandiceSaltRestarts.F90 index 478b6f3f9..ce1226b00 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_LakeLandiceSaltRestarts.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_LakeLandiceSaltRestarts.F90 @@ -26,7 +26,7 @@ program mk_LakeLandiceSaltRestarts real, allocatable :: dummy(:) integer :: zoom -#ifndef __GFORTRAN__ +#if !defined(__GFORTRAN__) && !defined(__flang__) integer :: ftell external :: ftell #endif @@ -125,10 +125,10 @@ program mk_LakeLandiceSaltRestarts call MAPL_VarWrite(OutFmt,vname,varOut) endif else if (ndims == 2) then - + dname => myVariable%get_ith_dimension(2) dim1=InCfg%get_dimension(dname) - + do j=1,dim1 if (dataType == pFIO_REAL64) then call MAPL_VarRead(InFmt,vname,varIn8,offset1=j, __RC__) @@ -145,7 +145,7 @@ program mk_LakeLandiceSaltRestarts endif enddo else if (ndims == 3) then - + dname => myVariable%get_ith_dimension(2) dim1=InCfg%get_dimension(dname) dname => myVariable%get_ith_dimension(3) @@ -168,12 +168,12 @@ program mk_LakeLandiceSaltRestarts endif enddo enddo - + end if end if - - call var_iter%next() + + call var_iter%next() enddo call OutFmt%close() diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 index e506b2afa..e87a40b1c 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 @@ -32,23 +32,23 @@ module GEOS_TurbulenceGridCompMod public SetServices ! !DESCRIPTION: -! +! ! {\tt GEOS\_TurbulenceGridComp} computes atmospheric tendencies due to turbulence. ! Its physics is a combination of the first-order scheme of Louis---for stable PBLs ! and free atmospheric turbulence---with a modified version of the non-local-K ! scheme proposed by Lock for unstable and cloud-topped boundary layers. ! In addition to diffusive tendencies, it adds the effects orographic form drag ! for features with horizontal scales of 2 to 20 km following Beljaars et al. (2003, -! ECMWF Tech. Memo. 427). +! ECMWF Tech. Memo. 427). ! !\vspace{12 pt} !\noindent !{\bf Grid Considerations} ! -! Like all GEOS\_Generic-based components, it works on an inherited +! Like all GEOS\_Generic-based components, it works on an inherited ! 3-dimensional ESMF grid. It assumes that the first two (inner) dimensions span the ! horizontal and the third (outer) dimension is the vertical. In the horizontal, -! one or both dimensions can be degenerate, effectively supporting +! one or both dimensions can be degenerate, effectively supporting ! single-columns (1-D), and slices (2-D). No horizontal dimension needs to be ! aligned with a particular coordinate. In the vertical, the only assumption ! is that columns are indexed from top to bottom. @@ -65,7 +65,7 @@ module GEOS_TurbulenceGridCompMod !\noindent !{\bf Time Behavior} ! -! {\tt GEOS\_TurbulenceGridComp} assumes both run stages will be invoked every +! {\tt GEOS\_TurbulenceGridComp} assumes both run stages will be invoked every ! RUN\_DT seconds, where RUN\_DT is required in the configuration. On this interval ! both run stages will perform diffusion updates using diffusivities found in the ! internal state. The diffusivities in the internal state may be refreshed intermitently @@ -89,43 +89,43 @@ module GEOS_TurbulenceGridCompMod ! to the quantity and in what form its effects are implemented. ! ! Quantities to be diffused can be marked as "Friendly-for-diffusion". In that case, -! {\tt GEOS\_TurbulenceGridComp} directly updates the quantity; otherwise it +! {\tt GEOS\_TurbulenceGridComp} directly updates the quantity; otherwise it ! merely computes its tendency, placing it in the appropriate bundle and treating ! the quantity itself as read-only. ! -! In working with bundled quantities, corresponding fields must appear in the -! same order in all bundles. Some of these fields, however, +! In working with bundled quantities, corresponding fields must appear in the +! same order in all bundles. Some of these fields, however, ! may be ``empty'' in the sense that the data pointer has not been allocated. -! +! ! {\tt GEOS\_TurbulenceGridComp} works with six bundles; three in the import ! state and three in the export state. The import bundles are: ! \begin{itemize} ! \item[] -! \makebox[1in][l]{\bf TR} +! \makebox[1in][l]{\bf TR} ! \parbox[t]{4in}{The quantity being diffused.} ! \item[] -! \makebox[1in][l]{\bf TRG} +! \makebox[1in][l]{\bf TRG} ! \parbox[t]{4in}{The surface (ground) value of the quantity being diffused. ! (Used only by Run2)} ! \item[] -! \makebox[1in][l]{\bf DTG} +! \makebox[1in][l]{\bf DTG} ! \parbox[t]{4in}{The change of TRG during the time step. (Used only by Run2)} ! \end{itemize} ! ! The export bundles are: ! \begin{itemize} ! \item[] -! \makebox[1in][l]{\bf TRI} +! \makebox[1in][l]{\bf TRI} ! \parbox[t]{4in}{The tendency of the quantity being diffused. ! (Produced by Run1, updated by Run2.) } ! \item[] -! \makebox[1in][l]{\bf FSTAR} +! \makebox[1in][l]{\bf FSTAR} ! \parbox[t]{4in}{After Run1, the ``preliminary'' (i.e., at the original surface ! value) surface flux of the diffused quantity; after Run2, its final value. ! (Produced by Run1, updated by Run2)} ! \item[] -! \makebox[1in][l]{\bf DFSTAR} -! \parbox[t]{4in}{The change of preliminary FSTAR per unit change in the +! \makebox[1in][l]{\bf DFSTAR} +! \parbox[t]{4in}{The change of preliminary FSTAR per unit change in the ! surface value. (Produced by Run1)} ! \end{itemize} ! @@ -139,7 +139,7 @@ module GEOS_TurbulenceGridCompMod ! \item DiffuseLike: ('S','Q','M') default='S' --- Use mixing coefficients for either ! heat, moisture or momentum. ! \end{itemize} -! +! ! Only fields in the TR bundle are checked for friendly status. Non-friendly ! fields in TR and all other bundles are treated with the usual Import/Export ! rules. @@ -149,7 +149,7 @@ module GEOS_TurbulenceGridCompMod !{\bf Other imports and exports} ! ! In addition to the updates of these bundles, {\tt GEOS\_TurbulenceGridComp} produces -! a number of diagnostic exports, as well as frictional heating contributions. The latter +! a number of diagnostic exports, as well as frictional heating contributions. The latter ! are NOT added by {\tt GEOS\_TurbulenceGridComp}, but merely exported to be added ! elsewhere in the GCM. ! @@ -160,13 +160,13 @@ module GEOS_TurbulenceGridCompMod ! The two-stage scheme for interacting with the surface module is as follows: ! \begin{itemize} ! \item The first run stage takes the surface values of the diffused quantities -! and the surface exchange coefficients as input. These are, of course, on the +! and the surface exchange coefficients as input. These are, of course, on the ! grid turbulence is working on. ! \item It then does the full diffusion calculation assuming the surface values are ! fixed, i.e., the explicit surface case. In addition, it also computes derivatives of the ! tendencies wrt surface values. These are to be used in the second stage. ! \item The second run stage takes the increments of the surface values as inputs -! and produces the final results, adding the implicit surface contributions. +! and produces the final results, adding the implicit surface contributions. ! \item It also computes the frictional heating due to both implicit and explicit ! surface contributions. ! \end{itemize} @@ -201,11 +201,11 @@ module GEOS_TurbulenceGridCompMod ! !DESCRIPTION: This version uses the {\tt GEOS\_GenericSetServices}, which sets ! the Initialize and Finalize services to generic versions. It also -! allocates our instance of a generic state and puts it in the +! allocates our instance of a generic state and puts it in the ! gridded component (GC). Here we only set the two-stage run method and ! declare the data services. ! \newline -! !REVISION HISTORY: +! !REVISION HISTORY: ! ??Jul2006 E.Novak./Todling - Added output defining TLM/ADM trajectory ! !INTERFACE: @@ -540,7 +540,7 @@ subroutine SetServices ( GC, RC ) RC=STATUS ) VERIFY_(STATUS) - call MAPL_AddImportSpec(GC, & + call MAPL_AddImportSpec(GC, & SHORT_NAME = 'EIS', & LONG_NAME = 'estimated_inversion_strength', & UNITS = 'K', & @@ -682,7 +682,7 @@ subroutine SetServices ( GC, RC ) DIMS = MAPL_DimsHorzOnly, & VLOCATION = MAPL_VLocationNone, & RC=STATUS ) - VERIFY_(STATUS) + VERIFY_(STATUS) end if call MAPL_AddImportSpec(GC, & @@ -728,7 +728,7 @@ subroutine SetServices ( GC, RC ) ! ! mass-flux export states -! +! call MAPL_AddExportSpec(GC, & LONG_NAME = 'EDMF_rain_tendency', & @@ -786,7 +786,7 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationEdge, & RC=STATUS ) VERIFY_(STATUS) - + call MAPL_AddExportSpec(GC, & LONG_NAME = 'EDMF_total_updraft_fractional_area', & UNITS = '1', & @@ -794,7 +794,7 @@ subroutine SetServices ( GC, RC ) DIMS = MAPL_DimsHorzVert, & VLOCATION = MAPL_VLocationCenter, & RC=STATUS ) - VERIFY_(STATUS) + VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & LONG_NAME = 'EDMF_moist_updraft_fractional_area', & @@ -967,7 +967,7 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationCenter, & RC=STATUS ) VERIFY_(STATUS) - + call MAPL_AddExportSpec(GC, & LONG_NAME = 'Vertical_velocity_variance_from_updrafts', & UNITS = 'm2 s-2', & @@ -1396,7 +1396,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - SHORT_NAME='DPDTTRB', & + SHORT_NAME='DPDTTRB', & LONG_NAME ='layer_pressure_thickness_tendency_from_turbulence', & UNITS ='Pa s-1', & DIMS = MAPL_DimsHorzVert, & @@ -1896,11 +1896,11 @@ subroutine SetServices ( GC, RC ) RC=STATUS ) VERIFY_(STATUS) - call MAPL_AddInternalSpec(GC, & - SHORT_NAME = 'ZPBL_SC', & - LONG_NAME = 'planetary_boundary_layer_height_for_shallow', & - UNITS = 'm', & - FRIENDLYTO = trim(COMP_NAME), & + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'ZPBL_SC', & + LONG_NAME = 'planetary_boundary_layer_height_for_shallow', & + UNITS = 'm', & + FRIENDLYTO = trim(COMP_NAME), & DIMS = MAPL_DimsHorzOnly, & VLOCATION = MAPL_VLocationNone, RC=STATUS ) VERIFY_(STATUS) @@ -2468,7 +2468,7 @@ subroutine SetServices ( GC, RC ) DIMS = MAPL_DimsHorzVert, & VLOCATION = MAPL_VLocationCenter, & RC=STATUS ) - VERIFY_(STATUS) + VERIFY_(STATUS) call MAPL_AddInternalSpec(GC, & SHORT_NAME = 'TKESHOC', & @@ -2551,7 +2551,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_TimerAdd(GC, name="--UPDATE" ,RC=STATUS) VERIFY_(STATUS) - + ! Set generic init and final methods ! ---------------------------------- @@ -2559,7 +2559,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) RETURN_(ESMF_SUCCESS) - + end subroutine SetServices @@ -2590,22 +2590,22 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) ! sets-up the matrix for a backward-implicit computation of the surface fluxes, ! and solves this system for a fixed surface value of the diffused quantity. Run1 ! takes as inputs the surface exchange coefficients (i.e., $\rho |U| C_{m,h,q}$) for -! momentun, heat, and moisture, as well as the pressure, temperature, moisture, +! momentun, heat, and moisture, as well as the pressure, temperature, moisture, ! and winds for the sounding. These are used only for computing the diffusivities ! and, as explained above, are not the temperatures, moistures, etc. being diffused. ! ! The computation of turbulence fluxes for fixed surface values is done at every -! time step in the contained subroutine {\tt DIFFUSE}; but the computation of +! time step in the contained subroutine {\tt DIFFUSE}; but the computation of ! diffusivities and orographic drag coefficients, as well as the set-up of the ! vertical difference matrix and its LU decomposition ! can be done intermittently for economy in the contained subroutine {\tt REFRESH}. -! The results of this calculation are stored in an internal state. -! Run1 also computes the sensitivity of the +! The results of this calculation are stored in an internal state. +! Run1 also computes the sensitivity of the ! atmospheric tendencies and the surface flux to changes in the surface value. ! ! The diffusivities are computed by calls to {\tt LOUIS\_KS} and {\tt ENTRAIN}, which -! compute the Louis et al. (1983) and Lock (2000) diffusivities. The Louis -! diffusivities are computed for all conditions, and {\tt ENTRAIN} overrides them +! compute the Louis et al. (1983) and Lock (2000) diffusivities. The Louis +! diffusivities are computed for all conditions, and {\tt ENTRAIN} overrides them ! where appropriate. Lock can be turned off from the resource file. @@ -2623,8 +2623,8 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) type (MAPL_MetaComp), pointer :: MAPL type (ESMF_Config ) :: CF - type (ESMF_State ) :: INTERNAL - type (ESMF_Alarm ) :: ALARM + type (ESMF_State ) :: INTERNAL + type (ESMF_Alarm ) :: ALARM character(len=ESMF_MAXSTR) :: GRIDNAME character(len=4) :: imchar @@ -2641,7 +2641,7 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) real, dimension(:,: ), pointer :: CU, CT, CQ, ZPBL, PHIS integer :: IM, JM, LM real :: DT - + ! EDMF-related variables real, dimension(:,:,:), pointer :: AKSS, BKSS, CKSS, YS real, dimension(:,:,:), pointer :: AKQQ, BKQQ, CKQQ, YQV,YQL,YQI @@ -2665,7 +2665,7 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) real, dimension(:,:), pointer :: LH_SPRX => null() -! Begin... +! Begin... !--------- ! Get my name and set-up traceback handle @@ -2720,7 +2720,7 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) if (associated(SH_SPRX)) SH_SPRX = SH_SPR if (associated(LH_SPRX)) LH_SPRX = LH_SPR - end if + end if ! Get all pointers that are needed by both REFRESH and DIFFUSE !------------------------------------------------------------- @@ -2820,7 +2820,7 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) ! ! edmf variables ! - + ! a,b,c and rhs for s call MAPL_GetPointer(INTERNAL, AKSS, 'AKSS', RC=STATUS) VERIFY_(STATUS) @@ -2830,7 +2830,7 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) VERIFY_(STATUS) call MAPL_GetPointer(INTERNAL, YS, 'YS', RC=STATUS) VERIFY_(STATUS) -! a,b,c for moisture and rhs for qv,ql,qi +! a,b,c for moisture and rhs for qv,ql,qi call MAPL_GetPointer(INTERNAL, AKQQ, 'AKQQ', RC=STATUS) VERIFY_(STATUS) call MAPL_GetPointer(INTERNAL, BKQQ, 'BKQQ', RC=STATUS) @@ -2838,12 +2838,12 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetPointer(INTERNAL, CKQQ, 'CKQQ', RC=STATUS) VERIFY_(STATUS) call MAPL_GetPointer(INTERNAL, YQV, 'YQV', RC=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) call MAPL_GetPointer(INTERNAL, YQL, 'YQL', RC=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) call MAPL_GetPointer(INTERNAL, YQI, 'YQI', RC=STATUS) - VERIFY_(STATUS) -! a,b,c and rhs for wind speed + VERIFY_(STATUS) +! a,b,c and rhs for wind speed call MAPL_GetPointer(INTERNAL, AKUU, 'AKUU', RC=STATUS) VERIFY_(STATUS) call MAPL_GetPointer(INTERNAL, BKUU, 'BKUU', RC=STATUS) @@ -2909,8 +2909,8 @@ subroutine REFRESH(IM,JM,LM,RC) integer, intent(IN) :: IM,JM,LM integer, optional, intent(OUT) :: RC -! !DESCRIPTION: -! {\tt REFRESH} can be called intermittently to compute new values of the +! !DESCRIPTION: +! {\tt REFRESH} can be called intermittently to compute new values of the ! diffusivities. In addition it does all possible calculations that depend ! only on these. In particular, it sets up the semi-implicit tridiagonal ! solver in the vertical and does the LU decomposition. It also includes the @@ -2921,17 +2921,17 @@ subroutine REFRESH(IM,JM,LM,RC) ! they are overridden by the Lock values ({\tt ENTRAIN}). ! Once diffusivities are computed, {\tt REFRESH} sets-up the tridiagonal ! matrices for the semi-implicit vertical diffusion calculation and performs -! their $LU$ decomposition. +! their $LU$ decomposition. ! ! {\tt REFRESH} requires surface exchange coefficients for heat, moisture, and ! momentum, The calculations in the interior are also ! done for momentum, heat, and water diffusion. Heat and water mixing ! coefficients differ only at the surface, but these affect the entire $LU$ -! decomposition, and so all three decompositions are saved in the internal state. +! decomposition, and so all three decompositions are saved in the internal state. ! ! For a conservatively diffused quantity $q$, we have ! $$ -! \frac{\partial q}{\partial t} = -g \frac{\partial }{\partial p} +! \frac{\partial q}{\partial t} = -g \frac{\partial }{\partial p} ! \left(\rho K_q \frac{\partial q}{\partial z} \right) ! $$ ! In finite difference form, using backward time differencing, this becomes @@ -2941,7 +2941,7 @@ subroutine REFRESH(IM,JM,LM,RC) ! \delta_l \left[ ! \left( \frac{\Delta t \rho K_q}{\delta_l z} \right)^* (\delta_l q)^{n+1} \right] \\ ! &&\\ -! & = & - \alpha_l ( \beta_{l+\frac{1}{2}}(q_{l+1}-q_l)^{n+1} - +! & = & - \alpha_l ( \beta_{l+\frac{1}{2}}(q_{l+1}-q_l)^{n+1} - ! \beta_{l-\frac{1}{2}}(q_l-q_{l-1})^{n+1} ) \\ ! &&\\ ! \alpha_l & = & \frac{g \Delta t}{(p_{l+\frac{1}{2}}-p_{l-\frac{1}{2}})^*} \\ @@ -2965,10 +2965,10 @@ subroutine REFRESH(IM,JM,LM,RC) ! $$ ! At the top boundary, we assume $K_q=0$, so $ \beta_{\frac{1}{2}}=0$ and $a_1=0$. ! At the surface, $ \beta_{L+\frac{1}{2}}= \rho_s |U|_s C_{m,h,q}$, the surface exchange coefficient. -! +! !EOP - + character(len=ESMF_MAXSTR) :: IAm='Refresh' integer :: STATUS @@ -3009,7 +3009,7 @@ subroutine REFRESH(IM,JM,LM,RC) real, dimension(:,: ), pointer :: SBITOP => null() real, dimension(:,: ), pointer :: KPBL => null() real, dimension(:,: ), pointer :: KPBL_SC => null() - real, dimension(:,: ), pointer :: ZPBL_SC => null() + real, dimension(:,: ), pointer :: ZPBL_SC => null() real, dimension(:,: ), pointer :: WEBRV,VSCBRV,DSIEMS,CHIS,ZCLDTOP,DELSINV,SMIXT,ZRADBS,CLDRF,VSCSFC,RADRCODE real, dimension(:,:,:), pointer :: AKSODT, CKSODT @@ -3017,7 +3017,7 @@ subroutine REFRESH(IM,JM,LM,RC) real, dimension(:,:,:), pointer :: AKVODT, CKVODT real, dimension(:,:,:), pointer :: LSHOC,BRUNTSHOC,ISOTROPY, & - LSHOC1,LSHOC2,LSHOC3, & + LSHOC1,LSHOC2,LSHOC3, & SHOCPRNUM,& TKEBUOY,TKESHEAR,TKEDISS,TKEDISSx, & SL2, SL3, W2, W3, WSL, SLQT, W3CANUTO, QT2DIAG,SL2DIAG,SLQTDIAG @@ -3030,8 +3030,8 @@ subroutine REFRESH(IM,JM,LM,RC) edmf_dry_u,edmf_moist_u, & edmf_dry_v,edmf_moist_v, & edmf_moist_qc,edmf_buoyf,edmf_mfx, & - edmf_w2, & !edmf_qt2, edmf_sl2, & - edmf_w3, edmf_wqt, edmf_slqt, & + edmf_w2, & !edmf_qt2, edmf_sl2, & + edmf_w3, edmf_wqt, edmf_slqt, & edmf_wsl, edmf_qt3, edmf_sl3, & edmf_entx, edmf_tke, slflxmf, & qtflxmf, mfaw, edmf_dqrdt, edmf_dqsdt, & @@ -3050,8 +3050,8 @@ subroutine REFRESH(IM,JM,LM,RC) logical :: PDFALLOC real :: LOUIS_B_KH, LOUIS_B_KM - real :: LOUIS_C_KH, LOUIS_C_KM - real :: LOUIS_D_KH, LOUIS_D_KM + real :: LOUIS_C_KH, LOUIS_C_KM + real :: LOUIS_D_KH, LOUIS_D_KM real :: ALHFAC, ALMFAC real :: LAMBDAM, LAMBDAM2 real :: LAMBDAH, LAMBDAH2 @@ -3088,7 +3088,7 @@ subroutine REFRESH(IM,JM,LM,RC) real :: SCM_ZETA ! Monin-Obkhov length scale (m) (for SCM_SL_FLUX == 3) real :: SCM_RH_SURF ! Surface relative humidity real :: SCM_TSURF ! Sea surface temperature (K) - + ! SCM idealized surface parameters integer :: SCM_SURF ! 0: native surface from GEOS ! else: idealized surface with prescribed cooling @@ -3102,7 +3102,7 @@ subroutine REFRESH(IM,JM,LM,RC) real, dimension(IM,JM) :: L02 real, dimension(IM,JM,LM) :: QT,THL,SL,EXF - ! Variables for idealized surface layer + ! Variables for idealized surface layer real, dimension(IM,JM), target :: bstar_scm, ustar_scm, sh_scm, evap_scm, zeta_scm real, dimension(im,jm,0:lm) :: edmfdrya, edmfmoista, & @@ -3186,9 +3186,9 @@ subroutine REFRESH(IM,JM,LM,RC) call MAPL_GetPointer(IMPORT,RADLWC, 'RADLWC', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, QLTOT, 'QLTOT', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, QITOT, 'QITOT', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, QRTOT, 'QRTOT', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, QSTOT, 'QSTOT', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, QGTOT, 'QGTOT', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, QRTOT, 'QRTOT', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, QSTOT, 'QSTOT', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT, QGTOT, 'QGTOT', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, FCLD, 'FCLD', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, BSTAR, 'BSTAR', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT, USTAR, 'USTAR', RC=STATUS); VERIFY_(STATUS) @@ -3309,8 +3309,8 @@ subroutine REFRESH(IM,JM,LM,RC) call MAPL_GetResource (MAPL, SHOCPARAMS%CEFAC, trim(COMP_NAME)//"_SHC_CEFAC:", default=1.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, SHOCPARAMS%CESFAC, trim(COMP_NAME)//"_SHC_CESFAC:", default=4., RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, SHOCPARAMS%LENOPT, trim(COMP_NAME)//"_SHC_LENOPT:", default=3, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, SHOCPARAMS%LENFAC1, trim(COMP_NAME)//"_SHC_LENFAC1:", default=8.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, SHOCPARAMS%LENFAC2, trim(COMP_NAME)//"_SHC_LENFAC2:", default=2.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, SHOCPARAMS%LENFAC1, trim(COMP_NAME)//"_SHC_LENFAC1:", default=8.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, SHOCPARAMS%LENFAC2, trim(COMP_NAME)//"_SHC_LENFAC2:", default=2.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, SHOCPARAMS%LENFAC3, trim(COMP_NAME)//"_SHC_LENFAC3:", default=1.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, SHOCPARAMS%BUOYOPT, trim(COMP_NAME)//"_SHC_BUOY_OPTION:", default=2, RC=STATUS); VERIFY_(STATUS) end if @@ -3583,7 +3583,7 @@ subroutine REFRESH(IM,JM,LM,RC) KHSFC = 0.0 KHRAD = 0.0 if(associated( ALH)) ALH = 0.0 - if(associated( ALM)) ALM = 0.0 + if(associated( ALM)) ALM = 0.0 if(associated(KHLS)) KHLS = 0.0 if(associated(KMLS)) KMLS = 0.0 @@ -3612,7 +3612,7 @@ subroutine REFRESH(IM,JM,LM,RC) endif do L=0,LM - ZL0(:,:,L) = ZLE(:,:,L) - ZLE(:,:,LM) ! edge height above the surface + ZL0(:,:,L) = ZLE(:,:,L) - ZLE(:,:,LM) ! edge height above the surface enddo if (SMTH_HGT > 0) then @@ -3641,7 +3641,7 @@ subroutine REFRESH(IM,JM,LM,RC) if (associated(ZLS)) ZLS = Z if (associated(ZLES)) ZLES = ZL0 - TV = T *( 1.0 + MAPL_VIREPS * Q - QL - QI ) + TV = T *( 1.0 + MAPL_VIREPS * Q - QL - QI ) THV = TV*(TH/T) TVE = (TV(:,:,1:LM-1) + TV(:,:,2:LM))*0.5 @@ -3687,7 +3687,7 @@ subroutine REFRESH(IM,JM,LM,RC) end if end if - RHOE(:,:,1:LM-1)=PLE(:,:,1:LM-1)/(MAPL_RGAS*TVE) + RHOE(:,:,1:LM-1)=PLE(:,:,1:LM-1)/(MAPL_RGAS*TVE) RHOE(:,:,0)=PLE(:,:,0)/(MAPL_RGAS*TV(:,:,1)) RHOE(:,:,LM)=PLE(:,:,LM)/(MAPL_RGAS*TV(:,:,LM)) @@ -3696,14 +3696,14 @@ subroutine REFRESH(IM,JM,LM,RC) call MAPL_TimerOff(MAPL,"---PRELIMS") ! Calculate liquid water potential temperature (THL) and total water (QT) - EXF=T/TH + EXF=T/TH THL=TH-(MAPL_ALHL*QL+MAPL_ALHS*QI)/(MAPL_CP*EXF) QT=Q+QL+QI ! get updraft constants call MAPL_GetResource (MAPL, DOMF, "EDMF_DOMF:", default=0, RC=STATUS) MFPARAMS%DOTRACERS = .false. - + if ( DOMF /= 0 ) then ! number of updrafts call MAPL_GetResource (MAPL, MFPARAMS%NUP, "EDMF_NUMUP:", default=10, RC=STATUS) @@ -3713,16 +3713,16 @@ subroutine REFRESH(IM,JM,LM,RC) call MAPL_GetResource (MAPL, MFPARAMS%PWMIN, "EDMF_PWMIN:", default=1.2, RC=STATUS) call MAPL_GetResource (MAPL, MFPARAMS%PWMAX, "EDMF_PWMAX:", default=3., RC=STATUS) ! - call MAPL_GetResource (MAPL, MFPARAMS%ENTUFAC, "EDMF_ENTUFAC:", default=2.0, RC=STATUS) + call MAPL_GetResource (MAPL, MFPARAMS%ENTUFAC, "EDMF_ENTUFAC:", default=2.0, RC=STATUS) call MAPL_GetResource (MAPL, MFPARAMS%WA, "EDMF_WA:", default=1.0, RC=STATUS) call MAPL_GetResource (MAPL, MFPARAMS%WB, "EDMF_WB:", default=1.5, RC=STATUS) ! coefficients for surface forcing, appropriate for L137 call MAPL_GetResource (MAPL, MFPARAMS%AlphaW, "EDMF_ALPHAW:", default=0.05, RC=STATUS) call MAPL_GetResource (MAPL, MFPARAMS%AlphaQT, "EDMF_ALPHAQT:", default=1.0, RC=STATUS) - call MAPL_GetResource (MAPL, MFPARAMS%AlphaTH, "EDMF_ALPHATH:", default=1.0, RC=STATUS) + call MAPL_GetResource (MAPL, MFPARAMS%AlphaTH, "EDMF_ALPHATH:", default=1.0, RC=STATUS) ! Entrainment rate options call MAPL_GetResource (MAPL, MFPARAMS%ET, "EDMF_ET:", default=2, RC=STATUS) - ! constant entrainment rate + ! constant entrainment rate call MAPL_GetResource (MAPL, MFPARAMS%ENT0, "EDMF_ENT0:", default=0.4, RC=STATUS) call MAPL_GetResource (MAPL, MFPARAMS%ENT0LTS, "EDMF_ENT0LTS:", default=0.8, RC=STATUS) ! L0 if ET==1 @@ -3813,7 +3813,7 @@ subroutine REFRESH(IM,JM,LM,RC) sh => sh_scm evap => evap_scm - + ustar_scm = sqrt( CU*sqrt(U(:,:,LM)**2+V(:,:,LM)**2+0.01) / RHOE(:,:,LM) ) bstar_scm = (MAPL_GRAV/(RHOE(:,:,LM)*ustar_scm)) * & @@ -3822,8 +3822,8 @@ subroutine REFRESH(IM,JM,LM,RC) bstar => bstar_scm ustar => ustar_scm - - print *,'bstar=',bstar_scm,' ustar=',ustar_scm + + print *,'bstar=',bstar_scm,' ustar=',ustar_scm call MAPL_TimerOff(MAPL,"---SURFACE") @@ -3865,15 +3865,15 @@ subroutine REFRESH(IM,JM,LM,RC) RHOE, & TKESHOC, & U, & - V, & - T, & - THL, & - THV, & - Q, & - QLTOT, & - QITOT, & - SH, & - EVAP, & + V, & + T, & + THL, & + THV, & + Q, & + QLTOT, & + QITOT, & + SH, & + EVAP, & FRLAND, & ZPBL, & ! MFTHSRC, MFQTSRC, MFW, MFAREA, & ! CLASP inputs @@ -3923,9 +3923,9 @@ subroutine REFRESH(IM,JM,LM,RC) EDMF_PLUMES_QT ) !=== Fill Exports === - if (associated(edmf_dry_a)) edmf_dry_a = edmfdrya - if (associated(edmf_moist_a)) edmf_moist_a = edmfmoista - if (associated(edmf_buoyf)) edmf_buoyf = buoyf + if (associated(edmf_dry_a)) edmf_dry_a = edmfdrya + if (associated(edmf_moist_a)) edmf_moist_a = edmfmoista + if (associated(edmf_buoyf)) edmf_buoyf = buoyf if (associated(edmf_mfx)) edmf_mfx = edmf_mf if (associated(mfaw)) mfaw = aw3 !edmf_mf/rhoe if (associated(slflxmf)) slflxmf = (aws3-awql3*mapl_alhl-awqi3*mapl_alhs)/mapl_cp @@ -3943,7 +3943,7 @@ subroutine REFRESH(IM,JM,LM,RC) if (associated(edmf_wsl)) edmf_wsl = mfwsl if (associated(edmf_tke)) edmf_tke = mftke if (associated(EDMF_FRC)) EDMF_FRC = 0.5*(edmfdrya(:,:,0:LM-1)+edmfdrya(:,:,1:LM) & - + edmfmoista(:,:,0:LM-1)+edmfmoista(:,:,1:LM)) + + edmfmoista(:,:,0:LM-1)+edmfmoista(:,:,1:LM)) do i = 1,IM do j = 1,JM k = LM @@ -3963,24 +3963,24 @@ subroutine REFRESH(IM,JM,LM,RC) awqi3 = 0.0 awu3 = 0.0 awv3 = 0.0 - buoyf = 0.0 + buoyf = 0.0 if (associated(edmf_dry_a)) edmf_dry_a = 0.0 if (associated(edmf_moist_a)) edmf_moist_a = 0.0 ! if (associated(edmf_dry_w)) edmf_dry_w = MAPL_UNDEF - if (associated(edmf_moist_w)) edmf_moist_w = MAPL_UNDEF + if (associated(edmf_moist_w)) edmf_moist_w = MAPL_UNDEF if (associated(edmf_dry_qt)) edmf_dry_qt = MAPL_UNDEF - if (associated(edmf_moist_qt)) edmf_moist_qt = MAPL_UNDEF - if (associated(edmf_dry_thl)) edmf_dry_thl = MAPL_UNDEF - if (associated(edmf_moist_thl)) edmf_moist_thl= MAPL_UNDEF - if (associated(edmf_dry_u)) edmf_dry_u = MAPL_UNDEF - if (associated(edmf_moist_u)) edmf_moist_u = MAPL_UNDEF - if (associated(edmf_dry_v)) edmf_dry_v = MAPL_UNDEF - if (associated(edmf_moist_v)) edmf_moist_v = MAPL_UNDEF - if (associated(edmf_moist_qc)) edmf_moist_qc = MAPL_UNDEF + if (associated(edmf_moist_qt)) edmf_moist_qt = MAPL_UNDEF + if (associated(edmf_dry_thl)) edmf_dry_thl = MAPL_UNDEF + if (associated(edmf_moist_thl)) edmf_moist_thl= MAPL_UNDEF + if (associated(edmf_dry_u)) edmf_dry_u = MAPL_UNDEF + if (associated(edmf_moist_u)) edmf_moist_u = MAPL_UNDEF + if (associated(edmf_dry_v)) edmf_dry_v = MAPL_UNDEF + if (associated(edmf_moist_v)) edmf_moist_v = MAPL_UNDEF + if (associated(edmf_moist_qc)) edmf_moist_qc = MAPL_UNDEF if (associated(edmf_buoyf)) edmf_buoyf = 0.0 if (associated(edmf_entx)) edmf_entx = MAPL_UNDEF - if (associated(edmf_mfx)) edmf_mfx = 0.0 + if (associated(edmf_mfx)) edmf_mfx = 0.0 if (associated(mfaw)) mfaw = 0.0 if (associated(ssrcmf)) ssrcmf = 0.0 if (associated(qlsrcmf)) qlsrcmf = 0.0 @@ -3998,7 +3998,7 @@ subroutine REFRESH(IM,JM,LM,RC) if (associated(edmf_tke)) edmf_tke = mftke if (associated(EDMF_FRC)) EDMF_FRC = 0. - drycblh = 0. + drycblh = 0. ENDIF call MAPL_TimerOff(MAPL,"---MASSFLUX") @@ -4039,7 +4039,7 @@ subroutine REFRESH(IM,JM,LM,RC) WTHV2(:,:,1:LM), & BUOYF(:,:,1:LM), & MFTKE(:,:,0:LM), & - DRYCBLH(:,:), & + DRYCBLH(:,:), & !== Input-Outputs == TKESHOC(:,:,1:LM), & TKH(:,:,1:LM), & @@ -4082,8 +4082,8 @@ subroutine REFRESH(IM,JM,LM,RC) KH, KM, RI, & LOUIS_B_KH,LOUIS_B_KM, & MINSHEAR, MINTHICK, & - LAMBDAM, LAMBDAM2, & - LAMBDAH, LAMBDAH2, & + LAMBDAM, LAMBDAM2, & + LAMBDAH, LAMBDAH2, & ALHFAC, ALMFAC, & ZKHMENV, AKHMMAX, & DU, ALH, KMLS, KHLS ) @@ -4091,12 +4091,12 @@ subroutine REFRESH(IM,JM,LM,RC) call LOUIS_KS_OPTIMIZED( IM,JM,LM,MO_MAX_ITER,DT, & Z,ZL0,TSM,USM,VSM,ZPBL,Z0,Z0H, & KH, KM, RI, & - LOUIS_B_KH,LOUIS_B_KM, & + LOUIS_B_KH,LOUIS_B_KM, & LOUIS_C_KH,LOUIS_C_KM, & LOUIS_D_KH,LOUIS_D_KM, & MINSHEAR, MINTHICK, & - LAMBDAM, LAMBDAM2, & - LAMBDAH, LAMBDAH2, & + LAMBDAM, LAMBDAM2, & + LAMBDAH, LAMBDAH2, & ALHFAC, ALMFAC, & ZKHMENV, AKHMMAX, & DU, ALM, ALH, KMLS, KHLS ) @@ -4134,7 +4134,7 @@ subroutine REFRESH(IM,JM,LM,RC) ! Inputs - Lock ! ------------- - + ALLOCATE(TDTLW_IN_dev(IM,JM,LM), __STAT__) ALLOCATE(U_STAR_dev(IM,JM), __STAT__) ALLOCATE(B_STAR_dev(IM,JM), __STAT__) @@ -4149,11 +4149,11 @@ subroutine REFRESH(IM,JM,LM,RC) ALLOCATE(PFULL_dev(IM,JM,LM), __STAT__) ALLOCATE(ZHALF_dev(IM,JM,LM+1), __STAT__) ALLOCATE(PHALF_dev(IM,JM,LM+1), __STAT__) - ALLOCATE(EIS_dev(IM,JM), __STAT__) + ALLOCATE(EIS_dev(IM,JM), __STAT__) ! Inoutputs - Lock ! ---------------- - + ALLOCATE(DIFF_M_dev(IM,JM,LM+1), __STAT__) ALLOCATE(DIFF_T_dev(IM,JM,LM+1), __STAT__) @@ -4173,7 +4173,7 @@ subroutine REFRESH(IM,JM,LM,RC) ! ------------------ ! MAT: Using device pointers on CUDA is a bit convoluted. First, we - ! only allocate the actual working arrays on the device if the + ! only allocate the actual working arrays on the device if the ! EXPORT pointer is associated. IF (ASSOCIATED(ZCLDTOP)) ALLOCATE(ZCLDTOP_DIAG_dev(IM,JM), __STAT__) @@ -4243,7 +4243,7 @@ subroutine REFRESH(IM,JM,LM,RC) ! Inoutputs - Lock ! ---------------- - + DIFF_M_dev(:,:,1:LM+1) = KM(:,:,0:LM) DIFF_T_dev(:,:,1:LM+1) = KH(:,:,0:LM) @@ -4307,7 +4307,7 @@ subroutine REFRESH(IM,JM,LM,RC) STATUS = cudaGetLastError() - if (STATUS /= 0) then + if (STATUS /= 0) then write (*,*) "Error code from ENTRAIN kernel call: ", STATUS write (*,*) "Kernel call failed: ", cudaGetErrorString(STATUS) _ASSERT(.FALSE.,'needs informative message') @@ -4327,13 +4327,13 @@ subroutine REFRESH(IM,JM,LM,RC) ! Inoutputs - Lock ! ---------------- - + KM(:,:,0:LM) = DIFF_M_dev(:,:,1:LM+1) KH(:,:,0:LM) = DIFF_T_dev(:,:,1:LM+1) ! Outputs - Lock ! -------------- - + EKM(:,:,0:LM) = K_M_ENTR_dev(:,:,1:LM+1) EKH(:,:,0:LM) = K_T_ENTR_dev(:,:,1:LM+1) KHSFC(:,:,0:LM) = K_SFC_dev(:,:,1:LM+1) @@ -4342,10 +4342,10 @@ subroutine REFRESH(IM,JM,LM,RC) ZRADML = ZRADML_dev ZRADBS = ZRADBASE_dev ZSML = ZSML_dev - + ! Diagnostics - Lock ! ------------------ - + IF (ASSOCIATED(ZCLDTOP)) ZCLDTOP = ZCLDTOP_DIAG_dev IF (ASSOCIATED(WESFC)) WESFC = WENTR_SFC_DIAG_dev IF (ASSOCIATED(WERAD)) WERAD = WENTR_RAD_DIAG_dev @@ -4369,10 +4369,10 @@ subroutine REFRESH(IM,JM,LM,RC) ! ------------------------ ! Deallocate device arrays ! ------------------------ - + ! Inputs - Lock ! ------------- - + DEALLOCATE(TDTLW_IN_dev) DEALLOCATE(U_STAR_dev) DEALLOCATE(B_STAR_dev) @@ -4389,16 +4389,16 @@ subroutine REFRESH(IM,JM,LM,RC) DEALLOCATE(PFULL_dev) DEALLOCATE(ZHALF_dev) DEALLOCATE(PHALF_dev) - + ! Inoutputs - Lock ! ---------------- - + DEALLOCATE(DIFF_M_dev) DEALLOCATE(DIFF_T_dev) - + ! Outputs - Lock ! -------------- - + DEALLOCATE(K_M_ENTR_dev) DEALLOCATE(K_T_ENTR_dev) DEALLOCATE(K_SFC_dev) @@ -4407,13 +4407,13 @@ subroutine REFRESH(IM,JM,LM,RC) DEALLOCATE(ZRADML_dev) DEALLOCATE(ZRADBASE_dev) DEALLOCATE(ZSML_dev) - + ! Diagnostics - Lock ! ------------------ ! MAT Again, we only deallocate a device array if the diagnostic ! was asked for. - + IF (ASSOCIATED(ZCLDTOP)) DEALLOCATE(ZCLDTOP_DIAG_dev) IF (ASSOCIATED(WESFC)) DEALLOCATE(WENTR_SFC_DIAG_dev) IF (ASSOCIATED(WERAD)) DEALLOCATE(WENTR_RAD_DIAG_dev) @@ -4433,7 +4433,7 @@ subroutine REFRESH(IM,JM,LM,RC) ! This step is probably unnecessary, but better safe than sorry ! as the lifetime of a device pointer is not really specified ! by NVIDIA - + IF (ASSOCIATED(ZCLDTOP)) NULLIFY(ZCLDTOP_DIAG_dev_ptr) IF (ASSOCIATED(WESFC)) NULLIFY(WENTR_SFC_DIAG_dev_ptr) IF (ASSOCIATED(WERAD)) NULLIFY(WENTR_RAD_DIAG_dev_ptr) @@ -4527,7 +4527,7 @@ subroutine REFRESH(IM,JM,LM,RC) - ! TKE + ! TKE if (associated(TKE)) then ! Reminder: TKE is on model edges if (DO_SHOC /= 0) then ! TKESHOC is not. TKE(:,:,1:LM-1) = 0.5*(TKESHOC(:,:,1:LM-1)+TKESHOC(:,:,2:LM)) @@ -4707,8 +4707,8 @@ subroutine REFRESH(IM,JM,LM,RC) ZPBLRI(I,J) = Z(I,J,L+1)+(ri_crit-RI(I,J,L))/(RI(I,J,L-1)-RI(I,J,L))*(Z(I,J,L)-Z(I,J,L+1)) end if end do - end do - end do + end do + end do where ( ZPBLRI .eq. MAPL_UNDEF ) ZPBLRI = Z(:,:,LM) ZPBLRI = MIN(ZPBLRI,Z(:,:,KPBLMIN)) @@ -4758,50 +4758,50 @@ subroutine REFRESH(IM,JM,LM,RC) end if end do - end do - end do + end do + end do end if ! ZPBLTHV -!========================================================================= -! ZPBL defined by minimum in vertical gradient of refractivity. -! As shown in Ao, et al, 2012: "Planetary boundary layer heights from -! GPS radio occultation refractivity and humidity profiles", Climate and -! Dynamics. https://doi.org/10.1029/2012JD017598 -!========================================================================= +!========================================================================= +! ZPBL defined by minimum in vertical gradient of refractivity. +! As shown in Ao, et al, 2012: "Planetary boundary layer heights from +! GPS radio occultation refractivity and humidity profiles", Climate and +! Dynamics. https://doi.org/10.1029/2012JD017598 +!========================================================================= if (associated(ZPBLRFRCT)) then - a1 = 0.776 ! K/Pa - a2 = 3.73e3 ! K2/Pa + a1 = 0.776 ! K/Pa + a2 = 3.73e3 ! K2/Pa - WVP = Q * PLO / (Q*(1.-0.622)+0.622) ! water vapor partial pressure + WVP = Q * PLO / (Q*(1.-0.622)+0.622) ! water vapor partial pressure - ! Pressure gradient term + ! Pressure gradient term dum3d(:,:,2:LM-1) = (PLO(:,:,1:LM-2)-PLO(:,:,3:LM)) / (Z(:,:,1:LM-2)-Z(:,:,3:LM)) dum3d(:,:,1) = (PLO(:,:,1)-PLO(:,:,2)) / (Z(:,:,1)-Z(:,:,2)) dum3d(:,:,LM) = (PLO(:,:,LM-1)-PLO(:,:,LM)) / (Z(:,:,LM-1)-Z(:,:,LM)) tmp3d = a1 * dum3d / T - ! Add Temperature gradient term + ! Add Temperature gradient term dum3d(:,:,2:LM-1) = (T(:,:,1:LM-2)-T(:,:,3:LM)) / (Z(:,:,1:LM-2)-Z(:,:,3:LM)) dum3d(:,:,1) = (T(:,:,1)-T(:,:,2)) / (Z(:,:,1)-Z(:,:,2)) dum3d(:,:,LM) = (T(:,:,LM-1)-T(:,:,LM)) / (Z(:,:,LM-1)-Z(:,:,LM)) tmp3d = tmp3d - (a1*plo/T**2 + 2.*a2*WVP/T**3)*dum3d - ! Add vapor pressure gradient term + ! Add vapor pressure gradient term dum3d(:,:,2:LM-1) = (WVP(:,:,1:LM-2)-WVP(:,:,3:LM)) / (Z(:,:,1:LM-2)-Z(:,:,3:LM)) dum3d(:,:,1) = (WVP(:,:,1)-WVP(:,:,2)) / (Z(:,:,1)-Z(:,:,2)) dum3d(:,:,LM) = (WVP(:,:,LM-1)-WVP(:,:,LM)) / (Z(:,:,LM-1)-Z(:,:,LM)) tmp3d = tmp3d + (a2/T**2)*dum3d - ! ZPBL is height of minimum in refractivity (tmp3d) + ! ZPBL is height of minimum in refractivity (tmp3d) do I = 1,IM do J = 1,JM - K = MINLOC(tmp3d(I,J,:),DIM=1,BACK=.TRUE.) ! return last index, if multiple + K = MINLOC(tmp3d(I,J,:),DIM=1,BACK=.TRUE.) ! return last index, if multiple ZPBLRFRCT(I,J) = Z(I,J,K) end do end do - end if ! ZPBLRFRCT + end if ! ZPBLRFRCT ! PBL height diagnostic based on specific humidity gradient @@ -4824,8 +4824,8 @@ subroutine REFRESH(IM,JM,LM,RC) end if end do - end do - end do + end do + end do end if ! ZPBLQV @@ -4865,7 +4865,7 @@ subroutine REFRESH(IM,JM,LM,RC) end do do L = K,1,-1 ! K is first level above 950mb if (PLO(I,J,L).lt.60000.) exit - + if (T(I,J,L-1).ge.T(I,J,L)) then ! if next level is warmer... LTOP = L ! L is index of minimum T so far do while (T(I,J,LTOP).ge.T(I,J,L)) ! find depth of warm layer @@ -4922,7 +4922,7 @@ subroutine REFRESH(IM,JM,LM,RC) ZPBL = MIN(ZPBL,Z(:,:,KPBLMIN)) KPBL = MAX(KPBL,float(KPBLMIN)) - + ! Calc KPBL using surface turbulence, for use in shallow scheme if (associated(KPBL_SC)) then KPBL_SC = MAPL_UNDEF @@ -4964,7 +4964,7 @@ subroutine REFRESH(IM,JM,LM,RC) if (associated(KPBL_SC) .and. associated(ZPBL_SC)) then do I = 1, IM do J = 1, JM - ZPBL_SC(I,J) = Z(I,J,KPBL_SC(I,J)) + ZPBL_SC(I,J) = Z(I,J,int(KPBL_SC(I,J))) end do end do endif @@ -5005,7 +5005,7 @@ subroutine REFRESH(IM,JM,LM,RC) ! Second difference coefficients for winds ! EKV is saved to use in the frictional heating calc. ! --------------------------------------------------- - + EKV(:,:,1:LM-1) = -KM(:,:,1:LM-1) * RDZ(:,:,1:LM-1) AKV(:,:,1 ) = 0.0 AKV(:,:,2:LM ) = EKV(:,:,1:LM-1) * DMI(:,:,2:LM ) @@ -5030,7 +5030,7 @@ subroutine REFRESH(IM,JM,LM,RC) ! ! A,B,C,D-s for mass flux ! - + AKSS(:,:,1)=0.0 AKUU(:,:,1)=0.0 @@ -5050,7 +5050,7 @@ subroutine REFRESH(IM,JM,LM,RC) CKSS(:,:,LM)=-CT*DMI(:,:,LM) CKQQ(:,:,LM)=-CQ*DMI(:,:,LM) CKUU(:,:,LM)=-CU*DMI(:,:,LM) - + if (MFPARAMS%IMPLICIT == 1 .and. MFPARAMS%DISCRETE == 0) then CKSS(:,:,1:LM-1) = - KH(:,:,1:LM-1)*RDZ(:,:,1:LM-1)*AE3(:,:,1:LM-1)*DMI(:,:,1:LM-1) & + 0.5*DMI(:,:,1:LM-1)*RHOAW3(:,:,1:LM-1) @@ -5060,14 +5060,14 @@ subroutine REFRESH(IM,JM,LM,RC) CKSS(:,:,1:LM-1) = - KH(:,:,1:LM-1)*RDZ(:,:,1:LM-1)*AE3(:,:,1:LM-1)*DMI(:,:,1:LM-1) CKUU(:,:,1:LM-1) = - KM(:,:,1:LM-1)*RDZ(:,:,1:LM-1)*AE3(:,:,1:LM-1)*DMI(:,:,1:LM-1) end if - CKQQ(:,:,1:LM-1) = CKSS(:,:,1:LM-1) - + CKQQ(:,:,1:LM-1) = CKSS(:,:,1:LM-1) + BKSS = 1.0 - (CKSS+AKSS) BKQQ = 1.0 - (CKQQ+AKQQ) BKUU = 1.0 - (CKUU+AKUU) ! Add mass flux contribution - + if (MFPARAMS%IMPLICIT == 1) then if (MFPARAMS%DISCRETE == 0) then BKSS(:,:,LM) = BKSS(:,:,LM) - DMI(:,:,LM)*RHOAW3(:,:,LM-1) @@ -5076,7 +5076,7 @@ subroutine REFRESH(IM,JM,LM,RC) BKSS(:,:,1:LM-1) = BKSS(:,:,1:LM-1) + DMI(:,:,1:LM-1)*( RHOAW3(:,:,1:LM-1) - RHOAW3(:,:,0:LM-2) ) BKQQ(:,:,1:LM-1) = BKQQ(:,:,1:LM-1) + DMI(:,:,1:LM-1)*( RHOAW3(:,:,1:LM-1) - RHOAW3(:,:,0:LM-2) ) - BKUU(:,:,1:LM-1) = BKUU(:,:,1:LM-1) + DMI(:,:,1:LM-1)*( RHOAW3(:,:,1:LM-1) - RHOAW3(:,:,0:LM-2) ) + BKUU(:,:,1:LM-1) = BKUU(:,:,1:LM-1) + DMI(:,:,1:LM-1)*( RHOAW3(:,:,1:LM-1) - RHOAW3(:,:,0:LM-2) ) else if (MFPARAMS%DISCRETE == 1) then AKSS(:,:,2:LM) = AKSS(:,:,2:LM) - DMI(:,:,2:LM)*RHOAW3(:,:,1:LM-1) AKQQ(:,:,2:LM) = AKQQ(:,:,2:LM) - DMI(:,:,2:LM)*RHOAW3(:,:,1:LM-1) @@ -5088,7 +5088,7 @@ subroutine REFRESH(IM,JM,LM,RC) end if end if -! Y-s ... these are rhs - mean value - surface flux +! Y-s ... these are rhs - mean value - surface flux ! (these are added in the diffuse and vrtisolve) @@ -5148,15 +5148,15 @@ subroutine REFRESH(IM,JM,LM,RC) ! ! Orograpghic drag follows Beljaars (2003): ! $$ -! \frac{\partial}{\partial z}\frac{\tau}{\rho} = \frac{C_B}{\lambda_B} |U(z)| U(z) +! \frac{\partial}{\partial z}\frac{\tau}{\rho} = \frac{C_B}{\lambda_B} |U(z)| U(z) ! e^{-\tilde{z}^\frac{3}{2}}\tilde{z}^{-1.2}, ! $$ -! where $z$ is the height above the surface in meters, +! where $z$ is the height above the surface in meters, ! $\tilde{z}=\frac{z}{\lambda_B}$, $\tau$ is the orographic stress at $z$, ! $\rho$ is the air density, $U(z)$ is the wind velocity, and $\lambda_B$ is a vertical length scale. ! Beljaars uses $\lambda_B = 1500$m, for which the non-dimensional parameter $C_B = 2.5101471 \times 10^{-8}$. ! These are the default values, but both can be modified from the configuration. To avoid underflow. -! the tendency is set to zero once $\tilde{z}$ exceeds 4 (i.e., 6 km from the surface for default values). +! the tendency is set to zero once $\tilde{z}$ exceeds 4 (i.e., 6 km from the surface for default values). ! !EOP @@ -5198,24 +5198,24 @@ subroutine REFRESH(IM,JM,LM,RC) ! ! LU decomposition for the mass-flux variables - ! + ! AKX=AKSS BKX=BKSS call VTRILU(AKX,BKX,CKSS) BKSS=BKX AKSS=AKX - + AKX=AKQQ BKX=BKQQ call VTRILU(AKX,BKX,CKQQ) BKQQ=BKX - AKQQ=AKX + AKQQ=AKX AKX=AKUU BKX=BKUU call VTRILU(AKX,BKX,CKUU) BKUU=BKX - AKUU=AKX + AKUU=AKX @@ -5242,7 +5242,7 @@ end subroutine REFRESH !BOP -! !CROUTINE: DIFFUSE -- Solves for semi-implicit diffusive tendencies assuming fixed surface conditions. +! !CROUTINE: DIFFUSE -- Solves for semi-implicit diffusive tendencies assuming fixed surface conditions. ! !INTERFACE: @@ -5302,7 +5302,7 @@ subroutine DIFFUSE(IM,JM,LM,RC) real :: EntExp, EntDyn real, dimension(LM) :: UPSX real, dimension(:,:,:), pointer :: edmf_mf, edmf_entx - + ! pointers to exports after diffuse real, dimension(:,:,:), pointer :: UAFDIFFUSE, VAFDIFFUSE, SAFDIFFUSE, QAFDIFFUSE @@ -5345,10 +5345,10 @@ subroutine DIFFUSE(IM,JM,LM,RC) -! Get the bundles containing the quantities to be diffused, +! Get the bundles containing the quantities to be diffused, ! their tendencies, their surface values, their surface ! fluxes, and the derivatives of their surface fluxes -! wrt the surface values. +! wrt the surface values. !---------------------------------------------------------- call ESMF_StateGet(IMPORT, 'TR' , TR, RC=STATUS); VERIFY_(STATUS) @@ -5386,7 +5386,7 @@ subroutine DIFFUSE(IM,JM,LM,RC) call MAPL_GetPointer(EXPORT, edmf_mf, 'EDMF_MF', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, edmf_entx, 'EDMF_ENTR', RC=STATUS); VERIFY_(STATUS) - + ! Count the firlds in TR... !-------------------------- @@ -5472,7 +5472,7 @@ subroutine DIFFUSE(IM,JM,LM,RC) ! If the surface values does not exists, we assume zero flux. !------------------------------------------------------------ - + if(associated(SRG)) then SG => SRG else @@ -5498,7 +5498,7 @@ subroutine DIFFUSE(IM,JM,LM,RC) if ( (trim(name) /= 'S' ) .and. (trim(name) /= 'Q' ) .and. & (trim(name) /= 'QLLS') .and. (trim(name) /= 'QILS') .and. & (trim(name) /= 'U' ) .and. (trim(name) /= 'V' )) then - + if ( TYPE=='U' ) then ! Momentum CX => CU @@ -5518,20 +5518,20 @@ subroutine DIFFUSE(IM,JM,LM,RC) ! Copy diffused quantity to temp buffer ! ------------------------------------------ - + SX = S ! Calculate EDMF tracer transport if (MFPARAMS%DOTRACERS) then do I=1,IM do J=1,JM - if (edmf_mf(I,J,LM-1).gt.1e-8) then + if (edmf_mf(I,J,LM-1).gt.1e-8) then UPSX(:) = 0. UPSX(LM-1) = SX(I,J,LM) L = LM-2 do while (edmf_mf(I,J,L).gt.1e-8 .and. L.gt.1) entdyn = max(0.,edmf_mf(I,J,L)-edmf_mf(I,J,L+1))/(edmf_mf(I,J,L+1)*DZ(I,J,L+1)) ! dynamical entrainment - entexp = exp(-(entdyn+EDMF_ENTX(I,J,L+1))*DZ(I,J,L+1)) + entexp = exp(-(entdyn+EDMF_ENTX(I,J,L+1))*DZ(I,J,L+1)) ! Effect of mixing on tracers in updraft UPSX(L) = SX(I,J,L+1)*(1.-entexp)+UPSX(L+1)*entexp @@ -5547,12 +5547,12 @@ subroutine DIFFUSE(IM,JM,LM,RC) end do ! IM SX = max( 0., SX ) ! prevent negative values from roundoff end if - + elseif (trim(name) =='S') then CX => CT DX => DKS AK => AKSS; BK => BKSS; CK => CKSS - SX=S+YS + SX=S+YS elseif (trim(name)=='Q') then CX => CQ DX => DKQ @@ -5570,16 +5570,16 @@ subroutine DIFFUSE(IM,JM,LM,RC) AK => AKQQ; BK => BKQQ; CK => CKQQ SX=S+YQI ! OPT = .FALSE. - elseif (trim(name)=='U') then + elseif (trim(name)=='U') then CX => CU DX => DKV AK => AKUU; BK => BKUU; CK => CKUU SX=S+YU - elseif (trim(name)=='V') then + elseif (trim(name)=='V') then CX => CU DX => DKV AK => AKUU; BK => BKUU; CK => CKUU - SX=S+YV + SX=S+YV end if @@ -5600,9 +5600,9 @@ subroutine DIFFUSE(IM,JM,LM,RC) end if else if ( SCM_SL /= 0 .and. SCM_SL_FLUX ==2 ) then if ( trim(name) == 'S' ) then - SF(:,:) = SHOBS + SF(:,:) = SHOBS elseif ( trim(name) == 'Q' ) then - SF(:,:) = LHOBS/MAPL_ALHL + SF(:,:) = LHOBS/MAPL_ALHL end if else if(size(SG)>0) then @@ -5618,7 +5618,7 @@ subroutine DIFFUSE(IM,JM,LM,RC) SF = SF + SH_SPRAY end if - if (trim(name) == 'Q') then + if (trim(name) == 'Q') then SF = SF + LH_SPRAY/MAPL_ALHL end if end if @@ -5662,7 +5662,7 @@ subroutine DIFFUSE(IM,JM,LM,RC) if( trim(name) == 'V' ) then if(associated(VAFDIFFUSE)) VAFDIFFUSE = SX endif - if( trim(name) == 'S' ) then + if( trim(name) == 'S' ) then if(associated(SAFDIFFUSE)) SAFDIFFUSE = SX endif if( trim(name) == 'Q' ) then @@ -5704,14 +5704,14 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) ! !ARGUMENTS: - type(ESMF_GridComp), intent(inout) :: GC ! Gridded component + type(ESMF_GridComp), intent(inout) :: GC ! Gridded component type(ESMF_State), intent(inout) :: IMPORT ! Import state type(ESMF_State), intent(inout) :: EXPORT ! Export state type(ESMF_Clock), intent(inout) :: CLOCK ! The clock integer, optional, intent( out) :: RC ! Error code: ! !DESCRIPTION: Second run stage of {\tt GEOS\_TurbulenceGridComp} performs -! the updates due to changes in surface quantities. Its input are the changes in +! the updates due to changes in surface quantities. Its input are the changes in ! surface quantities during the time step. It can also compute the frictional ! dissipation terms as exports, but these are not added to the temperatures. @@ -5728,7 +5728,7 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) type (MAPL_MetaComp), pointer :: MAPL type (ESMF_Config ) :: CF - type (ESMF_State ) :: INTERNAL + type (ESMF_State ) :: INTERNAL ! Local variables @@ -5738,7 +5738,7 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) real, pointer, dimension(:,:) :: VARFLT real, pointer, dimension(:,:) :: LATS -! Begin... +! Begin... !--------- ! Get my name and set-up traceback handle @@ -5812,12 +5812,12 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) integer, intent(IN) :: IM,JM,LM integer, optional, intent(OUT) :: RC -! !DESCRIPTION: +! !DESCRIPTION: ! Some description !EOP - - + + character(len=ESMF_MAXSTR) :: IAm='Update' integer :: STATUS @@ -5865,7 +5865,7 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) real :: SHVC_1500, SHVC_ZDEPTH real :: lat_in_degrees, lat_effect real, dimension(IM,JM) :: LATS - real :: SHVC_ALPHA, SHVC_EFFECT, SHVC_SCALING + real :: SHVC_ALPHA, SHVC_EFFECT, SHVC_SCALING logical :: DO_SHVC logical :: ALLOC_TMP integer :: KS, DO_SHOC @@ -5929,11 +5929,11 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) call MAPL_GetResource( MAPL, HGT_SURFACE, 'HGT_SURFACE:', default=HGT_SURFACE, RC=STATUS ) VERIFY_(STATUS) - CAP_INTDIS = 1.0 ! Kelvin [per time step done when applied] + CAP_INTDIS = 1.0 ! Kelvin [per time step done when applied] if (LM .eq. 72) CAP_INTDIS = 0.0 call MAPL_GetResource (MAPL, CAP_INTDIS, trim(COMP_NAME)//"_CAP_INTDIS:", default=CAP_INTDIS, RC=STATUS); VERIFY_(STATUS) - CAP_TOPDIS = 1.0 ! Kelvin [per time step done when applied] + CAP_TOPDIS = 1.0 ! Kelvin [per time step done when applied] if (LM .eq. 72) CAP_TOPDIS = 0.0 call MAPL_GetResource (MAPL, CAP_TOPDIS, trim(COMP_NAME)//"_CAP_TOPDIS:", default=CAP_TOPDIS, RC=STATUS); VERIFY_(STATUS) @@ -5989,10 +5989,10 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) call MAPL_GetPointer(INTERNAL, SINC, 'SINC', RC=STATUS) VERIFY_(STATUS) -! Get the bundles containing the quantities to be diffused, +! Get the bundles containing the quantities to be diffused, ! their tendencies, their surface values, their surface ! fluxes, and the derivatives of their surface fluxes -! wrt the surface values. +! wrt the surface values. !---------------------------------------------------------- call ESMF_StateGet(IMPORT, 'TR' , TR, RC=STATUS); VERIFY_(STATUS) @@ -6043,7 +6043,7 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) DP = PLE(:,:,1:LM)-PLE(:,:,0:LM-1) do L=0,LM - ZL0(:,:,L) = ZLE(:,:,L) - ZLE(:,:,LM) ! Edge heights above the surface + ZL0(:,:,L) = ZLE(:,:,L) - ZLE(:,:,LM) ! Edge heights above the surface enddo ZLO = 0.5*(ZL0(:,:,1:LM)+ZL0(:,:,0:LM-1)) ! Layer heights above the surface @@ -6097,7 +6097,7 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) if (associated(UFLXTRB)) U = 0.0 if (associated(VFLXTRB)) V = 0.0 -! Section 1 of 2. SHVC parameterization (W. Chao, J. Atmos. Sci., May 2012, P.1547) +! Section 1 of 2. SHVC parameterization (W. Chao, J. Atmos. Sci., May 2012, P.1547) ! Defining the top and bottom levels of the heat and moisture redistribution layer !---------------------------------------------------------------------------------- @@ -6132,37 +6132,37 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) STDV = sqrt(varflt*SHVC_SCALING) ! Scaling VARFLT based on resolution where (STDV >=700.) - z1500 = SHVC_1500 + z1500 = SHVC_1500 endwhere where ( (STDV >300.) .and. (STDV <700.) ) z1500 = 1500.+ (SHVC_1500-1500.)* (STDV - 300.)/400. - endwhere + endwhere z7000 = z1500 + SHVC_ZDEPTH L500=1. do L=LM,2,-1 - where (ZL0(:,:,L) <= z500 .and. ZL0(:,:,L-1) > z500) - L500=L-1 + where (ZL0(:,:,L) <= z500 .and. ZL0(:,:,L-1) > z500) + L500=L-1 endwhere enddo L1500=1. do L=LM,2,-1 - where (ZL0(:,:,L) <= z1500 .and. ZL0(:,:,L-1) > z1500) + where (ZL0(:,:,L) <= z1500 .and. ZL0(:,:,L-1) > z1500) L1500=L-1 endwhere enddo L7000=1. do L=LM,2,-1 - where (ZL0(:,:,L) <= z7000 .and. ZL0(:,:,L-1) > z7000) + where (ZL0(:,:,L) <= z7000 .and. ZL0(:,:,L-1) > z7000) L7000=L-1 endwhere enddo - LBOT = L1500-1 + LBOT = L1500-1 LTOPS = L7000 LTOPQ = L1500-(LM-L500)*2 @@ -6187,7 +6187,7 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) ! Get Kth field from bundle !-------------------------- - + call ESMF_FieldBundleGet(TR, K, FIELD, RC=STATUS) VERIFY_(STATUS) @@ -6259,13 +6259,13 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) SX = S if( associated(DSG) .and. SCM_SL == 0 ) then - do L=1,LM - SX(:,:,L) = SX(:,:,L) + DKX(:,:,L)*DSG + do L=1,LM + SX(:,:,L) = SX(:,:,L) + DKX(:,:,L)*DSG end do end if ! Increment the dissipation -!-------------------------- +!-------------------------- if( TYPE=='U' ) then if(associated(INTDIS)) then @@ -6287,30 +6287,30 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) DF(I,J,LM) = DF(I,J,LM)/WGTSUM do L=L300(I,J),LM INTDIS(I,J,L) = INTDIS(I,J,L) + DF(I,J,LM)*DZ(I,J,L)*(1.0-ZL0(I,J,L)/ZL0(I,J,L300(I,J)))**2 - end do + end do end do end do - if (CAP_INTDIS > 0.0) then + if (CAP_INTDIS > 0.0) then ! limit frictional heating from INTDIS by CAP_INTDIS/DT [K/s] do L=1,LM do J=1,JM do I=1,IM INTDIS(I,J,L) = SIGN(MIN(ABS(INTDIS(I,J,L)/DP(I,J,L)),CAP_INTDIS/DT)*DP(I,J,L),INTDIS(I,J,L)) - end do - end do - end do + end do + end do + end do endif endif if(associated(TOPDIS)) then TOPDIS = TOPDIS + (1.0/MAPL_CP)*FKV*SX**2 if (CAP_TOPDIS > 0.0) then ! limit frictional heating from TOPDIS by CAP_TOPDIS/DT [K/s] - do L=1,LM + do L=1,LM do J=1,JM do I=1,IM TOPDIS(I,J,L) = SIGN(MIN(ABS(TOPDIS(I,J,L)/DP(I,J,L)),CAP_TOPDIS/DT)*DP(I,J,L),TOPDIS(I,J,L)) - end do - end do + end do + end do end do endif endif @@ -6334,7 +6334,7 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) endif end if -! Section 2 of 2. SHVC parameterization (W. Chao, J. Atmos. Sci., 2012, p1547) +! Section 2 of 2. SHVC parameterization (W. Chao, J. Atmos. Sci., 2012, p1547) ! To use SHVC set SHVC_EFFECT in AGCM.rc to > 0.0. !-------------------------------------------------------------------------------- @@ -6371,7 +6371,7 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) REDUFAC = max(min((STDV(I,J)-SHVC_CRIT)/100.,0.95),0.0) end if - REDUFAC = REDUFAC * SHVC_EFFECT *lat_effect + REDUFAC = REDUFAC * SHVC_EFFECT *lat_effect SUMSOI = 0. do L=L500(i,j),LM @@ -6432,7 +6432,7 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) end if ! Fill export uf S after update - if( name=='S' ) then + if( name=='S' ) then if(associated(SAFUPDATE)) SAFUPDATE = SX endif @@ -6501,7 +6501,7 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) QTFLXMF(:,:,0) = 0. end if if (associated(QTFLXTRB)) QTFLXTRB = tmp3d + QTFLXMF - if (associated(WQT)) WQT = 0.5*( tmp3d(:,:,1:LM)+tmp3d(:,:,0:LM-1) + QTFLXMF(:,:,1:LM)+QTFLXMF(:,:,0:LM-1) ) + if (associated(WQT)) WQT = 0.5*( tmp3d(:,:,1:LM)+tmp3d(:,:,0:LM-1) + QTFLXMF(:,:,1:LM)+QTFLXMF(:,:,0:LM-1) ) end if if (associated(SLFLXTRB).or.associated(WSL)) then @@ -6515,7 +6515,7 @@ subroutine UPDATE(IM,JM,LM,LATS,RC) SLFLXMF(:,:,0) = 0. end if if (associated(SLFLXTRB)) SLFLXTRB = tmp3d/MAPL_CP + SLFLXMF - if (associated(WSL)) WSL = 0.5*( (tmp3d(:,:,1:LM)+tmp3d(:,:,0:LM-1))/MAPL_CP + SLFLXMF(:,:,1:LM)+SLFLXMF(:,:,0:LM-1) ) + if (associated(WSL)) WSL = 0.5*( (tmp3d(:,:,1:LM)+tmp3d(:,:,0:LM-1))/MAPL_CP + SLFLXMF(:,:,1:LM)+SLFLXMF(:,:,0:LM-1) ) end if if (ALLOC_TMP) deallocate(tmp3d) if (associated(UFLXTRB)) then @@ -6583,7 +6583,7 @@ end subroutine RUN2 subroutine LOUIS_KS( IM,JM,LM, & ZZ,ZE,PV,UU,VV,ZPBL, & - KH,KM,RI,LOUISKH,LOUISKM, & + KH,KM,RI,LOUISKH,LOUISKM, & MINSHEAR, MINTHICK, & LAMBDAM, LAMBDAM2, & LAMBDAH, LAMBDAH2, & @@ -6606,10 +6606,10 @@ subroutine LOUIS_KS( IM,JM,LM, & real, intent( OUT) :: KM(IM,JM,0:LM) ! Momentum diffusivity at base of each layer (m+2 s-1). real, intent( OUT) :: KH(IM,JM,0:LM) ! Heat diffusivity at base of each layer (m+2 s-1). real, intent( OUT) :: RI(IM,JM,0:LM) ! Richardson number - + ! Diagnostic outputs real, pointer :: DU_DIAG(:,:,:) ! Magnitude of wind shear (s-1). - real, pointer :: ALH_DIAG(:,:,:) ! Blackadar Length Scale diagnostic (m) [Optional] + real, pointer :: ALH_DIAG(:,:,:) ! Blackadar Length Scale diagnostic (m) [Optional] real, pointer :: KMLS_DIAG(:,:,:) ! Momentum diffusivity at base of each layer (m+2 s-1). real, pointer :: KHLS_DIAG(:,:,:) ! Heat diffusivity at base of each layer (m+2 s-1). @@ -6631,10 +6631,10 @@ subroutine LOUIS_KS( IM,JM,LM, & ! The Louis diffusivities for momentum, $K_m$, and for heat ! and moisture, $K_h$, are defined at the interior layer edges. For LM layers, ! we define diffusivities at the base of the top LM-1 layers. All indexing -! is from top to bottom of the atmosphere. +! is from top to bottom of the atmosphere. ! ! -! The Richardson number, Ri, is defined at the same edges as the diffusivities. +! The Richardson number, Ri, is defined at the same edges as the diffusivities. ! $$ ! {\rm Ri}_l = \frac{ \frac{g}{\left(\overline{\theta_v}\right)_l}\left(\frac{\delta \theta_v}{\delta z}\right)_l } ! { \left(\frac{\delta {\bf |V|}}{\delta z}\right)^2_l }, \, \, l=1,LM-1 @@ -6642,7 +6642,7 @@ subroutine LOUIS_KS( IM,JM,LM, & ! where $\theta_v=\theta(1+\epsilon q)$ is the virtual potential temperature, ! $\epsilon=\frac{M_a}{M_w}-1$, $M_a$ and $M_w$ are the molecular weights of ! dry air and water, and $q$ is the specific humidity. -! $\delta \theta_v$ is the difference of $\theta_v$ in the layers above and below the edge +! $\delta \theta_v$ is the difference of $\theta_v$ in the layers above and below the edge ! at which Ri$_l$ is defined; $\overline{\theta_v}$ is their average. ! ! The diffusivities at the layer edges have the form: @@ -6653,15 +6653,15 @@ subroutine LOUIS_KS( IM,JM,LM, & ! $$ ! K^h_l = (\ell^2_h)_l \left(\frac{\delta {\bf |V|}}{\delta z}\right)_l f_h({\rm Ri}_l), ! $$ -! where $k$ is the Von Karman constant, and $\ell$ is the +! where $k$ is the Von Karman constant, and $\ell$ is the ! Blackdar(1962) length scale, also defined at the layer edges. ! -! Different turbulent length scales can be used for heat and momentum. +! Different turbulent length scales can be used for heat and momentum. ! in both cases, we use the traditional formulation: ! $$ ! (\ell_{(m,h)})_l = \frac{kz_l}{1 + \frac{kz_l}{\lambda_{(m,h)}}}, ! $$ -! where, near the surface, the scale is proportional to $z_l$, the height above +! where, near the surface, the scale is proportional to $z_l$, the height above ! the surface of edge level $l$, and far from the surface it approaches $\lambda$. ! The length scale $\lambda$ is usually taken to be a constant (order 150 m), assuming ! the same scale for the outre boundary layer and the free atmosphere. We make it @@ -6705,8 +6705,8 @@ subroutine LOUIS_KS( IM,JM,LM, & ! $$ ! \psi = \sqrt{1+d{\rm Ri}}. ! $$ -! As in Louis et al (1982), the parameters appearing in these are taken -! as $b = c = d = 5$. +! As in Louis et al (1982), the parameters appearing in these are taken +! as $b = c = d = 5$. !EOP @@ -6810,7 +6810,7 @@ subroutine LOUIS_KS( IM,JM,LM, & call MAPL_MaxMin('LOUIS: RI', RI) call MAPL_MaxMin('LOUIS: KM', KM) call MAPL_MaxMin('LOUIS: KH', KH) - endif + endif KM = min(KM, AKHMMAX) KH = min(KH, AKHMMAX) @@ -6831,7 +6831,7 @@ end subroutine LOUIS_KS subroutine LOUIS_KS_OPTIMIZED( IM,JM,LM,MO_MAX_ITER,DTIME, & ZZ,ZE,PV,UU,VV,ZPBL,Z0,Z0H, & KH,KM,RI, & - LOUIS_B_KH,LOUIS_B_KM, & + LOUIS_B_KH,LOUIS_B_KM, & LOUIS_C_KH,LOUIS_C_KM, & LOUIS_D_KH,LOUIS_D_KM, & MINSHEAR, MINTHICK, & @@ -6850,7 +6850,7 @@ subroutine LOUIS_KS_OPTIMIZED( IM,JM,LM,MO_MAX_ITER,DTIME, & real, parameter :: MIN_DIFFUSIVITY = 0.01 ! Minimum diffusivity real, parameter :: STABILITY_EPS = 1.e-10 ! Small number for stability real, parameter :: MAX_PS_DIVISOR = 0.1 ! Maximum PS divisor - + ! Arguments (same as original) integer, intent(IN) :: IM,JM,LM,MO_MAX_ITER real, intent(IN) :: DTIME @@ -6904,7 +6904,7 @@ subroutine LOUIS_KS_OPTIMIZED( IM,JM,LM,MO_MAX_ITER,DTIME, & do j = 1, JM ! Vectorizable inner loop with minimal branching do i = 1, IM - + ! Pre-compute frequently used values ! layer thickness @@ -6921,7 +6921,7 @@ subroutine LOUIS_KS_OPTIMIZED( IM,JM,LM,MO_MAX_ITER,DTIME, & ((VV(i,j,l) - VV(i,j,l+1)) * dz_inv)**2 shear = sqrt(shear_sq) if (associated(DU_DIAG)) DU_DIAG(i,j,l) = shear - + ! Richardson number shear_sq = max(shear_sq, MINSHEAR**2) ! Limit SHEAR^2 in RI calculation ri_local = (GRAV/th_avg) * dth_local * dz_inv / shear_sq @@ -6952,7 +6952,7 @@ subroutine LOUIS_KS_OPTIMIZED( IM,JM,LM,MO_MAX_ITER,DTIME, & (1.0 + 3.0*LOUIS_B_KH*ah_local*LOUIS_C_KH*ps_local) ) else ! Stable case - ! Momentum + ! Momentum ps_local = max(sqrt(1.0 + LOUIS_D_KM*ri_local), STABILITY_EPS) km_local = am_local * ( 1.0 / (1.0 + 2.0*LOUIS_B_KM*ri_local/ps_local) ) ! Heat @@ -7151,15 +7151,15 @@ subroutine BELJAARS(IM, JM, LM, DT, & ! ! Orographic drag follows Beljaars (2003): ! $$ -! \frac{\partial}{\partial z}\frac{\tau}{\rho} = \frac{C_B}{\lambda_B} |U(z)| U(z) +! \frac{\partial}{\partial z}\frac{\tau}{\rho} = \frac{C_B}{\lambda_B} |U(z)| U(z) ! e^{-\tilde{z}^\frac{3}{2}}\tilde{z}^{-1.2}, ! $$ -! where $z$ is the height above the surface in meters, +! where $z$ is the height above the surface in meters, ! $\tilde{z}=\frac{z}{\lambda_B}$, $\tau$ is the orographic stress at $z$, ! $\rho$ is the air density, $U(z)$ is the wind velocity, and $\lambda_B$ is a vertical length scale. ! Beljaars uses $\lambda_B = 1500$m, for which the non-dimensional parameter $C_B = 2.5101471 \times 10^{-8}$. ! These are the default values, but both can be modified from the configuration. To avoid underflow. -! the tendency is set to zero once $\tilde{z}$ exceeds 4 (i.e., 6 km from the surface for default values). +! the tendency is set to zero once $\tilde{z}$ exceeds 4 (i.e., 6 km from the surface for default values). ! !EOP @@ -7198,8 +7198,8 @@ subroutine BELJAARS(IM, JM, LM, DT, & FKV(I,J,L) = FKV_temp * (PLE(I,J,L)-PLE(I,J,L-1)) end if end do - end do - end do + end do + end do else ! C_TOFD is the end product of all coeficients in eq 16 of Beljaars, 2003 (doi: 10.1256/qj.03.73) ! C_B is a factor used to amplify the variance of the filtered topography @@ -7296,7 +7296,7 @@ subroutine VTRILU(A,B,C) ! \begin{array}{rcl} ! \hat{b}_1 & = & b_1, \\ ! \hat{a}_k & = & \makebox[2 in][l]{$a_k / \hat{b}_{k-1}$,} k=2, K, \\ -! \hat{b}_k & = & \makebox[2 in][l]{$b_k - c_{k-1} \hat{a}_k$,} k=2, K. +! \hat{b}_k & = & \makebox[2 in][l]{$b_k - c_{k-1} \hat{a}_k$,} k=2, K. ! \end{array} ! $$ !EOP @@ -7367,7 +7367,7 @@ subroutine VTRISOLVE ( A,B,C,Y,YG,OPT ) logical, intent(IN) :: OPT ! !DESCRIPTION: Solves tridiagonal system that has been LU decomposed -! $LU x = f$. This is done by first solving $L g = f$ for $g$, and +! $LU x = f$. This is done by first solving $L g = f$ for $g$, and ! then solving $U x = g$ for $x$. The solutions are: ! $$ ! \begin{array}{rcl} @@ -7375,21 +7375,21 @@ subroutine VTRISOLVE ( A,B,C,Y,YG,OPT ) ! g_k & = & \makebox[2 in][l]{$f_k - g_{k-1} \hat{a}_{k}$,} k=2, K, \\ ! \end{array} ! $$ -! and +! and ! $$ ! \begin{array}{rcl} ! x_K & = & g_K /\hat{b}_K, \\ ! x_k & = & \makebox[2 in][l]{($g_k - c_k g_{k+1}) / \hat{b}_{k}$,} k=K-1, 1 \\ ! \end{array} ! $$ -! +! ! On input A contains the $\hat{a}_k$, the lower diagonal of $L$, ! B contains the $1/\hat{b}_k$, inverse of the main diagonal of $U$, ! C contains the $c_k$, the upper diagonal of $U$. The forcing, $f_k$ is -! +! ! It returns the ! solution in the r.h.s input vector, Y. A has the multiplier from the -! decomposition, B the +! decomposition, B the ! matrix (U), and C the upper diagonal of the original matrix and of U. ! YG is the LM+1 (Ground) value of Y.