diff --git a/src/offline/cable_checks.F90 b/src/offline/cable_checks.F90 index 5d1b73a5e..dbe25e5c3 100644 --- a/src/offline/cable_checks.F90 +++ b/src/offline/cable_checks.F90 @@ -84,7 +84,7 @@ MODULE cable_checks_module ESoil = [-0.0015, 0.0015], & TVeg = [-0.0003, 0.0003], & ECanop = [-0.0003, 0.0003], & - PotEvap = [-0.005, 0.005], & !note should encompass Evap + PotEvap = [-0.005, 0.005], & !note should encompass Evap ! I have PotEvap = [-0.0006, 0.0006] if it makes a difference - rk4417 ACond = [0.0, 1.0], & SoilWet = [-0.4, 1.2], & Albedo = [0.0, 1.0], & @@ -133,12 +133,13 @@ MODULE cable_checks_module css = [700.0, 2200.0], & rhosoil = [300.0, 3000.0], & hyds = [5.0E-7, 8.5E-3], & ! vh_js ! sep14 +! MMY 8.5E-3->8.5 since hyds uses m/s, but hyds_vec uses mm/s rs20 = [0.0, 10.0], & sand = [0.0, 1.0], & sfc = [0.1, 0.5], & silt = [0.0, 1.0], & ssat = [0.35, 0.5], & - sucs = [-0.8, -0.03], & + sucs = [-0.8, -0.03], & ! MMY@23Apr2023 works for CABLE non-GW swilt = [0.05, 0.4], & froot = [0.0, 1.0], & zse = [0.0, 5.0], & @@ -204,6 +205,7 @@ MODULE cable_checks_module TYPE(ranges_type), SAVE :: ranges + INTERFACE check_range MODULE PROCEDURE :: check_range_d1 MODULE PROCEDURE :: check_range_d2 @@ -486,6 +488,8 @@ SUBROUTINE mass_balance(dels,ktau, ssnow,soil,canopy,met, ! Local variables REAL(r_2), DIMENSION(:,:,:),POINTER, SAVE :: bwb ! volumetric soil moisture +! line below inserted by rk4417 - phase2 + REAL(r_2), DIMENSION(:,:),POINTER, SAVE :: bwb_gw ! volumetric gw soil moisture ! MMY REAL(r_2), DIMENSION(mp) :: delwb ! change in soilmoisture ! b/w tsteps REAL, DIMENSION(mp) :: canopy_wbal !canopy water balance @@ -494,12 +498,39 @@ SUBROUTINE mass_balance(dels,ktau, ssnow,soil,canopy,met, IF(ktau==1) THEN ALLOCATE( bwb(mp,ms,2) ) - ! initial vlaue of soil moisture + ALLOCATE( bwb_gw(mp,2) ) ! MMY ! inserted by rk4417 - phase2 + ! initial value of soil moisture bwb(:,:,1)=ssnow%wb bwb(:,:,2)=ssnow%wb + bwb_gw(:,1)=ssnow%GWwb ! MMY ! 2 lines inserted by rk4417 - phase2 + bwb_gw(:,2)=ssnow%GWwb ! MMY delwb(:) = 0. ELSE ! Calculate change in soil moisture b/w timesteps: + + ! ________________ MMY, Water Balance Equation for GW_ON _______________ + ! MMY to fix water balance bug when gw-on + IF ( cable_user%GW_MODEL) THEN ! MMY + + IF(MOD(REAL(ktau),2.0)==1.0) THEN ! if odd timestep + bwb(:,:,1)=ssnow%wb + bwb_gw(:,1)=ssnow%GWwb + DO k=1,mp ! current smoist - prev tstep smoist + delwb(k) = ( SUM( (bwb(k,:,1) - bwb(k,:,2))*soil%zse ) + & + (bwb_gw(k,1) - bwb_gw(k,2))*soil%GWdz(k) ) *1000.0 + END DO + ELSE IF(MOD(REAL(ktau),2.0)==0.0) THEN ! if even timestep + bwb(:,:,2)=ssnow%wb + bwb_gw(:,2)=ssnow%GWwb + DO k=1,mp ! current smoist - prev tstep smoist + delwb(k) = ( SUM( (bwb(k,:,2) - bwb(k,:,1))*soil%zse ) + & + (bwb_gw(k,2) -bwb_gw(k,1))*soil%GWdz(k) ) *1000.0 + END DO + END IF + ! ______________________________________________________________________ + + ELSE ! MMY ! IF part above inserted by rk4417 - phase2 + IF(MOD(REAL(ktau),2.0)==1.0) THEN ! if odd timestep bwb(:,:,1)=ssnow%wb DO k=1,mp ! current smoist - prev tstep smoist @@ -513,7 +544,10 @@ SUBROUTINE mass_balance(dels,ktau, ssnow,soil,canopy,met, - (bwb(k,:,1)))*soil%zse)*1000.0 END DO END IF - END IF + + END IF ! MMY ! inserted by rk4417 - phase2 + + END IF @@ -523,10 +557,21 @@ SUBROUTINE mass_balance(dels,ktau, ssnow,soil,canopy,met, ! it's included in change in canopy storage calculation)) ! rml 28/2/11 ! BP changed rnof1+rnof2 to ssnow%runoff which also included rnof5 ! which is used when nglacier=2 in soilsnow routines (BP feb2011) + + IF ( cable_user%GW_MODEL) THEN ! MMY + ! ________________ MMY, Water Balance Equation for GW_ON _______________ + bal%wbal = REAL(met%precip - canopy%delwc - ssnow%snowd+ssnow%osnowd & + - ssnow%runoff-(canopy%fevw+canopy%fevc & + + canopy%fes/ssnow%cls)*dels/air%rlam - delwb) ! remove qrecharge + ! ______________________________________________________________________ + ELSE ! MMY ! IF part above inserted by rk4417 - phase2 + bal%wbal = REAL(met%precip - canopy%delwc - ssnow%snowd+ssnow%osnowd & - ssnow%runoff-(canopy%fevw+canopy%fevc & + canopy%fes/ssnow%cls)*dels/air%rlam - delwb - ssnow%qrecharge) + END IF ! MMY ! inserted by rk4417 - phase2 + ! Canopy water balance: precip-change.can.storage-throughfall-evap+dew canopy_wbal = REAL(met%precip-canopy%delwc-canopy%through & - (canopy%fevw+MIN(canopy%fevc,0.0_r_2))*dels/air%rlam) diff --git a/src/offline/cable_define_types.F90 b/src/offline/cable_define_types.F90 index 9d0187475..ccd781180 100644 --- a/src/offline/cable_define_types.F90 +++ b/src/offline/cable_define_types.F90 @@ -210,8 +210,9 @@ MODULE cable_def_types_mod ! Soil and snow variables: TYPE soil_snow_type - - INTEGER, DIMENSION(:), POINTER :: isflag ! 0 => no snow 1 => snow + !> isflag 0 => one snow layer 1 => three snow layer + INTEGER, DIMENSION(:), POINTER :: isflag +! 0 => one snow layer 1 => three snow layer ! MMY ! above and here inserted by rk4417 - phase2 REAL, DIMENSION(:), POINTER :: & iantrct, & ! pointer to Antarctic land points diff --git a/src/offline/cable_driver.F90 b/src/offline/cable_driver.F90 index 5d8ec690c..50f605ffe 100644 --- a/src/offline/cable_driver.F90 +++ b/src/offline/cable_driver.F90 @@ -62,7 +62,7 @@ PROGRAM cable_offline_driver USE cable_def_types_mod USE cable_IO_vars_module, ONLY: logn,gswpfile,ncciy,leaps, & verbose, fixedCO2,output,check,patchout, & - patch_type,landpt,soilparmnew,& + patch_type,landpt,soilparmnew, & defaultLAI, sdoy, smoy, syear, timeunits, exists, calendar, set_group_output_values, & NO_CHECK USE casa_ncdf_module, ONLY: is_casa_time @@ -245,7 +245,7 @@ PROGRAM cable_offline_driver NAMELIST/CABLE/ & filename, & ! TYPE, containing input filenames vegparmnew, & ! use new soil param. method - soilparmnew, & ! use new soil param. method + soilparmnew, & ! use new soil param. method calcsoilalbedo, & ! albedo considers soil color Ticket #27 spinup, & ! spinup model (soil) to steady state delsoilM,delsoilT,& ! @@ -409,7 +409,8 @@ PROGRAM cable_offline_driver ! STOP 'casaCNP required to get prognostic LAI or Vcmax' IF( l_vcmaxFeedbk .AND. icycle < 1 ) & STOP 'icycle must be 2 to 3 to get prognostic Vcmax' - IF( icycle > 0 .AND. ( .NOT. soilparmnew ) ) & + + IF( icycle > 0 .AND. ( .NOT. soilparmnew ) ) & STOP 'casaCNP must use new soil parameters' NRRRR = MERGE(MAX(CABLE_USER%CASA_NREP,1), 1, CASAONLY) @@ -512,6 +513,38 @@ PROGRAM cable_offline_driver kend = ktauday * LOY ENDIF +! __________________________ MMY using Princeton _______________________________ + ELSE IF ( TRIM(cable_user%MetType) .EQ. 'prin' ) THEN + ncciy = CurYear + + CALL prepareFiles_princeton(ncciy) ! MMY + IF ( RRRR .EQ. 1 ) THEN + CALL open_met_file( dels, koffset, kend, spinup, CTFRZ ) + IF (leaps.and.is_leapyear(YYYY).and.kend.eq.2920) THEN + STOP 'LEAP YEAR INCOMPATIBILITY WITH INPUT MET !' + ENDIF + IF ( NRRRR .GT. 1 ) THEN + GSWP_MID(1,YYYY) = ncid_rain + ! GSWP_MID(2,YYYY) = ncid_snow MMY + GSWP_MID(3,YYYY) = ncid_lw + GSWP_MID(4,YYYY) = ncid_sw + GSWP_MID(5,YYYY) = ncid_ps + GSWP_MID(6,YYYY) = ncid_qa + GSWP_MID(7,YYYY) = ncid_ta + GSWP_MID(8,YYYY) = ncid_wd + ENDIF + ELSE + ncid_rain = GSWP_MID(1,YYYY) + ! ncid_snow = GSWP_MID(2,YYYY) MMY + ncid_lw = GSWP_MID(3,YYYY) + ncid_sw = GSWP_MID(4,YYYY) + ncid_ps = GSWP_MID(5,YYYY) + ncid_qa = GSWP_MID(6,YYYY) + ncid_ta = GSWP_MID(7,YYYY) + ncid_wd = GSWP_MID(8,YYYY) + kend = ktauday * LOY ! MMY + ENDIF + ELSE IF ( TRIM(cable_user%MetType) .EQ. 'plum' ) THEN ! PLUME experiment setup using WATCH IF ( CALL1 ) THEN @@ -1049,9 +1082,17 @@ PROGRAM cable_offline_driver YYYY.EQ. CABLE_USER%YearEnd ) THEN ! evaluate spinup + ! =================== MMY_phase2 commented out this region in favor of the one below - rk4417 ===================== IF( ANY( ABS(ssnow%wb-soilMtemp)>delsoilM).OR. & - ANY( ABS(ssnow%tgg-soilTtemp)>delsoilT) .OR. & - MAXVAL(ABS(ssnow%GWwb-GWtemp),dim=1) > delgwM) THEN + ANY( ABS(ssnow%tgg-soilTtemp)>delsoilT) .OR. & + MAXVAL(ABS(ssnow%GWwb-GWtemp),dim=1) > delgwM) THEN + + ! =================== MMY_phase2 uncomment ===================== +! IF( (ANY( ABS(ssnow%wb-soilMtemp)>delsoilM).OR. & +! ANY( ABS(ssnow%tgg-soilTtemp)>delsoilT) .or. & +! maxval(ABS(ssnow%GWwb-GWtemp),dim=1) > delgwM) .and. & +! ( (int(ktau_tot/kend) .lt. cable_user%max_spins) .and.& +! (cable_user%max_spins .gt. 0) ) ) THEN ! No complete convergence yet PRINT *, 'ssnow%wb : ', ssnow%wb @@ -1185,7 +1226,7 @@ PROGRAM cable_offline_driver IF (icycle > 0.and. .not.l_landuse) THEN - !CALL casa_poolout( ktau, veg, soil, casabiome, & + !CALL casa_poolout( ktau, veg, soil, casabiome, & ! casapool, casaflux, casamet, casabal, phen ) CALL write_casa_restart_nc ( casamet, casapool,casaflux,phen, CASAONLY ) @@ -1307,6 +1348,50 @@ SUBROUTINE renameFiles(logn,inFile,ncciy,inName) END SUBROUTINE renameFiles + +! 2 subroutines below inserted by rk4417 - phase2 +! _______________________ MMY for Princeton input ______________________________ +SUBROUTINE prepareFiles_princeton(ncciy) + USE cable_IO_vars_module, ONLY: logn,gswpfile + IMPLICIT NONE + INTEGER, INTENT(IN) :: ncciy + + WRITE(logn,*) 'CABLE offline global run using princeton forcing for ', ncciy + PRINT *, 'CABLE offline global run using princeton forcing for ', ncciy + + CALL renameFiles_princeton(logn,gswpfile%rainf,ncciy,'rainf') + CALL renameFiles_princeton(logn,gswpfile%LWdown,ncciy,'LWdown') + CALL renameFiles_princeton(logn,gswpfile%SWdown,ncciy,'SWdown') + CALL renameFiles_princeton(logn,gswpfile%PSurf,ncciy,'PSurf') + CALL renameFiles_princeton(logn,gswpfile%Qair,ncciy,'Qair') + CALL renameFiles_princeton(logn,gswpfile%Tair,ncciy,'Tair') + CALL renameFiles_princeton(logn,gswpfile%wind,ncciy,'wind') + +END SUBROUTINE prepareFiles_princeton + +SUBROUTINE renameFiles_princeton(logn,inFile,ncciy,inName) + IMPLICIT NONE + INTEGER, INTENT(IN) :: logn,ncciy + INTEGER:: nn + CHARACTER(LEN=200), INTENT(INOUT) :: inFile + CHARACTER(LEN=*), INTENT(IN) :: inName + INTEGER :: idummy + + nn = INDEX(inFile,'19') + READ(inFile(nn:nn+3),'(i4)') idummy + WRITE(inFile(nn:nn+3),'(i4.4)') ncciy + nn = INDEX(inFile,'19') + READ(inFile(nn:nn+3),'(i4)') idummy + WRITE(inFile(nn:nn+3),'(i4.4)') ncciy + READ(inFile(nn-5:nn-2),'(i4)') idummy + WRITE(inFile(nn-5:nn-2),'(i4.4)') ncciy + WRITE(logn,*) TRIM(inName), ' global data from ', TRIM(inFile) + +END SUBROUTINE renameFiles_princeton + +! ______________________________________________________________________________ + + !============================================================================== ! subroutine for reading LU input data, zeroing biomass in empty secondary forest tiles ! and tranferring LUC-based age weights for secondary forest to POP structure diff --git a/src/offline/cable_initialise.F90 b/src/offline/cable_initialise.F90 index 766e6bcce..3521287d0 100644 --- a/src/offline/cable_initialise.F90 +++ b/src/offline/cable_initialise.F90 @@ -39,7 +39,9 @@ MODULE cable_init_module soiltype_metfile USE cable_read_module USE netcdf - USE cable_common_module, ONLY : filename, cable_user +! USE cable_common_module, ONLY : filename, cable_user +! line above replaced by below - rk4417 - phase2 + USE cable_common_module, ONLY : filename, cable_user, gw_params IMPLICIT NONE @@ -141,6 +143,19 @@ SUBROUTINE get_default_inits(met,soil,ssnow,canopy,logn, EMSOIL) canopy%fhs = 0.0 ! sensible heat flux from soil (W/m2) canopy%us = 0.1 ! friction velocity (needed in roughness before first call to canopy: should in be in restart?) +! block below added by rk4417 - phase2 + canopy%sublayer_dz = 0.001 + ssnow%rtevap_sat = 0.0 + ssnow%rtevap_unsat = 0.0 + ssnow%satfrac = 1.0e-12 + ssnow%qhz = 0.0 + ssnow%wtd = 1000.0 + ssnow%wb_hys = 0.99*soil%ssat_vec + ssnow%smp_hys = -0.99*soil%sucs_vec + ssnow%ssat_hys = gw_params%ssat_wet_factor*soil%ssat_vec + ssnow%watr_hys = soil%watr + ssnow%hys_fac = 1.0 + END SUBROUTINE get_default_inits !============================================================================== @@ -408,7 +423,7 @@ SUBROUTINE get_restart_data(logn,ssnow,canopy,rough,bgc, & CALL readpar(ncid_rin,'runoff',dummy,ssnow%runoff,filename%restart_in, & max_vegpatches,'def',from_restart,mp) - !MD + IF (cable_user%gw_model) THEN ! inserted by rk4417 - phase2 ok = NF90_INQ_VARID(ncid_rin,'GWwb',parID) IF(ok == NF90_NOERR) THEN CALL readpar(ncid_rin,'GWwb',dummy,ssnow%GWwb,filename%restart_in, & @@ -417,6 +432,66 @@ SUBROUTINE get_restart_data(logn,ssnow,canopy,rough,bgc, & ssnow%GWwb = 0.95*soil%ssat END IF +! below part until END IF inserted by rk4417 - phase2 + + ok = NF90_INQ_VARID(ncid_rin,'wb_hys',parID) + IF(ok == NF90_NOERR) THEN + CALL readpar(ncid_rin,'wb_hys',dummy,ssnow%wb_hys,filename%restart_in, & + max_vegpatches,'msd',from_restart,mp) + ELSE + ssnow%wb_hys = 0.99*soil%ssat_vec + END IF + + ok = NF90_INQ_VARID(ncid_rin,'smp_hys',parID) + IF(ok == NF90_NOERR) THEN + CALL readpar(ncid_rin,'smp_hys',dummy,ssnow%smp_hys,filename%restart_in, & + max_vegpatches,'msd',from_restart,mp) + ELSE + ssnow%smp_hys = -1.0*abs(soil%sucs_vec)*0.99 + END IF + + ok = NF90_INQ_VARID(ncid_rin,'ssat_hys',parID) + IF(ok == NF90_NOERR) THEN + CALL readpar(ncid_rin,'ssat_hys',dummy,ssnow%ssat_hys,filename%restart_in, & + max_vegpatches,'msd',from_restart,mp) + ELSE + ssnow%ssat_hys = soil%ssat_vec + END IF + + ok = NF90_INQ_VARID(ncid_rin,'watr_hys',parID) + IF(ok == NF90_NOERR) THEN + CALL readpar(ncid_rin,'watr_hys',dummy,ssnow%watr_hys,filename%restart_in, & + max_vegpatches,'msd',from_restart,mp) + ELSE + ssnow%watr_hys = soil%watr + END IF + + + ok = NF90_INQ_VARID(ncid_rin,'hys_fac',parID) + IF(ok == NF90_NOERR) THEN + CALL readpar(ncid_rin,'hys_fac',dummy,ssnow%hys_fac,filename%restart_in, & + max_vegpatches,'msd',from_restart,mp) + ELSE + ssnow%hys_fac = 1.0 + END IF + + END IF + + IF (cable_user%or_evap) THEN + ok = NF90_INQ_VARID(ncid_rin,'sublayer_dz',parID) + IF(ok == NF90_NOERR) THEN + CALL readpar(ncid_rin,'sublayer_dz',dummy,canopy%sublayer_dz,filename%restart_in, & + max_vegpatches,'def',from_restart,mp) + ELSE + canopy%sublayer_dz(:) = 0.01 + END IF + + IF (any(canopy%sublayer_dz .lt. 0.0) .or. any(canopy%sublayer_dz .gt. 0.5))then + WRITE(*,*) 'problem with sublayer_dz and restart. check restart values!' + END IF + END IF + + !$ IF(cable_user%SOIL_STRUC=='sli'.or.cable_user%FWSOIL_SWITCH=='Haverd2013') THEN !$ CALL readpar(ncid_rin,'gamma',dummy,veg%gamma,filename%restart_in, & !$ max_vegpatches,'def',from_restart,mp) @@ -547,12 +622,14 @@ SUBROUTINE get_restart_data(logn,ssnow,canopy,rough,bgc, & ENDIF ! CALL readpar(ncid_rin,'isoil',dummy,soil%isoilm,filename%restart_in, & ! max_vegpatches,'def',from_restart,mp) + ! CALL readpar(ncid_rin,'clay',dummy,soil%clay,filename%restart_in, & ! max_vegpatches,'def',from_restart,mp) ! CALL readpar(ncid_rin,'sand',dummy,soil%sand,filename%restart_in, & ! max_vegpatches,'def',from_restart,mp) - ! CALL readpar(ncid_rin,'silt',dummy,soil%silt,filename%restart_in, & - ! max_vegpatches,'def',from_restart,mp) + ! CALL readpar(ncid_rin,'silt',dummy,soil%silt,filename%restart_in, & + ! max_vegpatches,'def',from_restart,mp) + ! MMY@Feb2023 soilparmnew=True as default, then comment out soilparmnew=False ! IF ( .NOT. soilparmnew) THEN ! Q.Zhang @12/20/2010 ! CALL readpar(ncid_rin,'ssat',dummy,soil%ssat,filename%restart_in, & ! max_vegpatches,'def',from_restart,mp) @@ -590,73 +667,80 @@ SUBROUTINE get_restart_data(logn,ssnow,canopy,rough,bgc, & ! END IF ! CALL readpar(ncid_rin,'rs20',dummy,soil%rs20,filename%restart_in, & ! max_vegpatches,'def',from_restart,mp) - ! CALL readpar(ncid_rin,'rs20',dummy,veg%rs20,filename%restart_in, & - ! max_vegpatches,'def',from_restart,mp) - ! CALL readpar(ncid_rin,'froot',dummy,veg%froot,filename%restart_in, & - ! max_vegpatches,'ms',from_restart,mp) - ! CALL readpar(ncid_rin,'hc',dummy,veg%hc,filename%restart_in, & - ! max_vegpatches,'def',from_restart,mp) - ! CALL readpar(ncid_rin,'canst1',dummy,veg%canst1,filename%restart_in, & - ! max_vegpatches,'def',from_restart,mp) - ! CALL readpar(ncid_rin,'dleaf',dummy,veg%dleaf,filename%restart_in, & - ! max_vegpatches,'def',from_restart,mp) - ! CALL readpar(ncid_rin,'frac4',dummy,veg%frac4,filename%restart_in, & - ! max_vegpatches,'def',from_restart,mp) - ! CALL readpar(ncid_rin,'ejmax',dummy,veg%ejmax,filename%restart_in, & - ! max_vegpatches,'def',from_restart,mp) - ! CALL readpar(ncid_rin,'vcmax',dummy,veg%vcmax,filename%restart_in, & - ! max_vegpatches,'def',from_restart,mp) - ! CALL readpar(ncid_rin,'rp20',dummy,veg%rp20,filename%restart_in, & - ! max_vegpatches,'def',from_restart,mp) - ! CALL readpar(ncid_rin,'rpcoef',dummy,veg%rpcoef,filename%restart_in, & - ! max_vegpatches,'def',from_restart,mp) - ! CALL readpar(ncid_rin,'shelrb',dummy,veg%shelrb,filename%restart_in, & - ! max_vegpatches,'def',from_restart,mp) - ! CALL readpar(ncid_rin,'xfang',dummy,veg%xfang,filename%restart_in, & - ! max_vegpatches,'def',from_restart,mp) - ! CALL readpar(ncid_rin,'wai',dummy,veg%wai,filename%restart_in, & - ! max_vegpatches,'def',from_restart,mp) - ! CALL readpar(ncid_rin,'vegcf',dummy,veg%vegcf,filename%restart_in, & - ! max_vegpatches,'def',from_restart,mp) - ! CALL readpar(ncid_rin,'extkn',dummy,veg%extkn,filename%restart_in, & - ! max_vegpatches,'def',from_restart,mp) - ! CALL readpar(ncid_rin,'tminvj',dummy,veg%tminvj,filename%restart_in, & - ! max_vegpatches,'def',from_restart,mp) - ! CALL readpar(ncid_rin,'tmaxvj',dummy,veg%tmaxvj,filename%restart_in, & - ! max_vegpatches,'def',from_restart,mp) - ! CALL readpar(ncid_rin,'vbeta',dummy,veg%vbeta,filename%restart_in, & - ! max_vegpatches,'def',from_restart,mp) - ! CALL readpar(ncid_rin,'xalbnir',dummy,veg%xalbnir,filename%restart_in, & - ! max_vegpatches,'def',from_restart,mp) - ! veg%xalbnir = 1.0 ! xalbnir will soon be removed totally - ! CALL readpar(ncid_rin,'g0',dummy,veg%g0,filename%restart_in, & - ! max_vegpatches,'def',from_restart,mp) ! Ticket #56 - ! CALL readpar(ncid_rin,'g1',dummy,veg%g1,filename%restart_in, & - ! max_vegpatches,'def',from_restart,mp) ! Ticket #56 - ! CALL readpar(ncid_rin,'meth',dummy,veg%meth,filename%restart_in, & - ! max_vegpatches,'def',from_restart,mp) + + ! CALL readpar(ncid_rin,'rs20',dummy,veg%rs20,filename%restart_in, & + ! max_vegpatches,'def',from_restart,mp) + ! CALL readpar(ncid_rin,'froot',dummy,veg%froot,filename%restart_in, & + ! max_vegpatches,'ms',from_restart,mp) + ! CALL readpar(ncid_rin,'hc',dummy,veg%hc,filename%restart_in, & + ! max_vegpatches,'def',from_restart,mp) + ! CALL readpar(ncid_rin,'canst1',dummy,veg%canst1,filename%restart_in, & + ! max_vegpatches,'def',from_restart,mp) + ! CALL readpar(ncid_rin,'dleaf',dummy,veg%dleaf,filename%restart_in, & + ! max_vegpatches,'def',from_restart,mp) + ! CALL readpar(ncid_rin,'frac4',dummy,veg%frac4,filename%restart_in, & + ! max_vegpatches,'def',from_restart,mp) + ! CALL readpar(ncid_rin,'ejmax',dummy,veg%ejmax,filename%restart_in, & + ! max_vegpatches,'def',from_restart,mp) + ! CALL readpar(ncid_rin,'vcmax',dummy,veg%vcmax,filename%restart_in, & + ! max_vegpatches,'def',from_restart,mp) + ! CALL readpar(ncid_rin,'rp20',dummy,veg%rp20,filename%restart_in, & + ! max_vegpatches,'def',from_restart,mp) + ! CALL readpar(ncid_rin,'rpcoef',dummy,veg%rpcoef,filename%restart_in, & + ! max_vegpatches,'def',from_restart,mp) + ! CALL readpar(ncid_rin,'shelrb',dummy,veg%shelrb,filename%restart_in, & + ! max_vegpatches,'def',from_restart,mp) + ! CALL readpar(ncid_rin,'xfang',dummy,veg%xfang,filename%restart_in, & + ! max_vegpatches,'def',from_restart,mp) + ! CALL readpar(ncid_rin,'wai',dummy,veg%wai,filename%restart_in, & + ! max_vegpatches,'def',from_restart,mp) + ! CALL readpar(ncid_rin,'vegcf',dummy,veg%vegcf,filename%restart_in, & + ! max_vegpatches,'def',from_restart,mp) + ! CALL readpar(ncid_rin,'extkn',dummy,veg%extkn,filename%restart_in, & + ! max_vegpatches,'def',from_restart,mp) + ! CALL readpar(ncid_rin,'tminvj',dummy,veg%tminvj,filename%restart_in, & + ! max_vegpatches,'def',from_restart,mp) + ! CALL readpar(ncid_rin,'tmaxvj',dummy,veg%tmaxvj,filename%restart_in, & + ! max_vegpatches,'def',from_restart,mp) + ! CALL readpar(ncid_rin,'vbeta',dummy,veg%vbeta,filename%restart_in, & + ! max_vegpatches,'def',from_restart,mp) + ! CALL readpar(ncid_rin,'xalbnir',dummy,veg%xalbnir,filename%restart_in, & + ! max_vegpatches,'def',from_restart,mp) + ! veg%xalbnir = 1.0 ! xalbnir will soon be removed totally + ! CALL readpar(ncid_rin,'g0',dummy,veg%g0,filename%restart_in, & + ! max_vegpatches,'def',from_restart,mp) ! Ticket #56 + ! CALL readpar(ncid_rin,'g1',dummy,veg%g1,filename%restart_in, & + ! max_vegpatches,'def',from_restart,mp) ! Ticket #56 + ! CALL readpar(ncid_rin,'meth',dummy,veg%meth,filename%restart_in, & + ! max_vegpatches,'def',from_restart,mp) + + ! ! special treatment of za with the introduction of za_uv and za_tq ! in case an old restart file is used - ! ok = NF90_INQ_VARID(ncid_rin,'za',parID) - ! IF(ok == NF90_NOERR) THEN ! if it does exist - ! CALL readpar(ncid_rin,'za',dummy,rough%za_uv,filename%restart_in, & - ! max_vegpatches,'def',from_restart,mp) - ! CALL readpar(ncid_rin,'za',dummy,rough%za_tq,filename%restart_in, & - ! max_vegpatches,'def',from_restart,mp) - ! ELSE - ! CALL readpar(ncid_rin,'za_uv',dummy,rough%za_uv,filename%restart_in, & - ! max_vegpatches,'def',from_restart,mp) - ! CALL readpar(ncid_rin,'za_tq',dummy,rough%za_tq,filename%restart_in, & - ! max_vegpatches,'def',from_restart,mp) - ! ENDIF + + +! ok = NF90_INQ_VARID(ncid_rin,'za',parID) +! IF(ok == NF90_NOERR) THEN ! if it does exist +! CALL readpar(ncid_rin,'za',dummy,rough%za_uv,filename%restart_in, & +! max_vegpatches,'def',from_restart,mp) +! CALL readpar(ncid_rin,'za',dummy,rough%za_tq,filename%restart_in, & +! max_vegpatches,'def',from_restart,mp) +! ELSE +! CALL readpar(ncid_rin,'za_uv',dummy,rough%za_uv,filename%restart_in, & +! max_vegpatches,'def',from_restart,mp) +! CALL readpar(ncid_rin,'za_tq',dummy,rough%za_tq,filename%restart_in, & +! max_vegpatches,'def',from_restart,mp) +! ENDIF + CALL readpar(ncid_rin,'zse',dummy,soil%zse,filename%restart_in, & max_vegpatches,'ms',from_restart,mp) - ! CALL readpar(ncid_rin,'ratecp',dummy,bgc%ratecp,filename%restart_in, & - ! max_vegpatches,'ncp',from_restart,mp) - ! CALL readpar(ncid_rin,'ratecs',dummy,bgc%ratecs,filename%restart_in, & - ! max_vegpatches,'ncs',from_restart,mp) - ! - ! Close restart file: + +! CALL readpar(ncid_rin,'ratecp',dummy,bgc%ratecp,filename%restart_in, & +! max_vegpatches,'ncp',from_restart,mp) +! CALL readpar(ncid_rin,'ratecs',dummy,bgc%ratecs,filename%restart_in, & +! max_vegpatches,'ncs',from_restart,mp) +! +! Close restart file: ok = NF90_CLOSE(ncid_rin) IF(ok/=NF90_NOERR) CALL nc_abort(ok,'Error closing restart file ' & //TRIM(filename%restart_in)// '(SUBROUTINE get_restart)') diff --git a/src/offline/cable_input.F90 b/src/offline/cable_input.F90 index 9c30208f7..9773d9361 100644 --- a/src/offline/cable_input.F90 +++ b/src/offline/cable_input.F90 @@ -400,7 +400,7 @@ SUBROUTINE open_met_file(dels,koffset,kend,spinup, TFRZ) PRINT*,'rainf' CALL handle_err( ok ) ENDIF - IF(.NOT. globalMetfile%l_gpcc) THEN + IF(.NOT. globalMetfile%l_gpcc .AND. TRIM(cable_user%MetType) /= 'prin') THEN ok = NF90_OPEN(gswpfile%snowf,0,ncid_snow) IF (ok /= NF90_NOERR) THEN PRINT*,'snow' @@ -411,7 +411,7 @@ SUBROUTINE open_met_file(dels,koffset,kend,spinup, TFRZ) IF( globalMetfile%l_gpcc ) THEN ok = NF90_OPEN(globalMetfile%LWdown,0,ncid_lw) ELSE - ok = NF90_OPEN(gswpfile %LWdown,0,ncid_lw) + ok = NF90_OPEN(gswpfile%LWdown,0,ncid_lw) ENDIF IF (ok /= NF90_NOERR) THEN PRINT*,'lw' @@ -497,9 +497,16 @@ SUBROUTINE open_met_file(dels,koffset,kend,spinup, TFRZ) IF(ok/=NF90_NOERR) THEN ! if failed ! Try 'lon' instead of x ok = NF90_INQ_DIMID(ncid_met,'lon', xdimID) - IF(ok/=NF90_NOERR) CALL nc_abort & - (ok,'Error finding x dimension in '& - //TRIM(filename%met)//' (SUBROUTINE open_met_file)') + IF(ok/=NF90_NOERR) THEN ! MMY + ok = NF90_INQ_DIMID(ncid_met,'longitude', xdimID) ! MMY ! For princeton + IF(ok/=NF90_NOERR) CALL nc_abort & ! MMY + (ok,'Error finding x dimension in '& ! MMY + //TRIM(filename%met)//' (SUBROUTINE open_met_file)') ! MMY + END IF ! MMY +! replaced below IF by above IF block - rk4417 - phase2 +! IF(ok/=NF90_NOERR) CALL nc_abort & +! (ok,'Error finding x dimension in '& +! //TRIM(filename%met)//' (SUBROUTINE open_met_file)') END IF ok = NF90_INQUIRE_DIMENSION(ncid_met,xdimID,len=xdimsize) IF(ok/=NF90_NOERR) CALL nc_abort & @@ -510,9 +517,16 @@ SUBROUTINE open_met_file(dels,koffset,kend,spinup, TFRZ) IF(ok/=NF90_NOERR) THEN ! if failed ! Try 'lat' instead of y ok = NF90_INQ_DIMID(ncid_met,'lat', ydimID) - IF(ok/=NF90_NOERR) CALL nc_abort & - (ok,'Error finding y dimension in ' & - //TRIM(filename%met)//' (SUBROUTINE open_met_file)') + IF(ok/=NF90_NOERR) THEN ! MMY + ok = NF90_INQ_DIMID(ncid_met,'latitude', ydimID) ! MMY ! For princeton + IF(ok/=NF90_NOERR) CALL nc_abort & ! MMY + (ok,'Error finding y dimension in ' & ! MMY + //TRIM(filename%met)//' (SUBROUTINE open_met_file)') ! MMY + END IF ! MMY +! replaced below IF by above IF block - rk4417 - phase2 +! IF(ok/=NF90_NOERR) CALL nc_abort & +! (ok,'Error finding y dimension in ' & +! //TRIM(filename%met)//' (SUBROUTINE open_met_file)') END IF ok = NF90_INQUIRE_DIMENSION(ncid_met,ydimID,len=ydimsize) IF(ok/=NF90_NOERR) CALL nc_abort & @@ -529,6 +543,18 @@ SUBROUTINE open_met_file(dels,koffset,kend,spinup, TFRZ) IF (ok /= NF90_NOERR) CALL nc_abort & (ok,'Error finding latitude variable in ' & //TRIM(filename%met)//' (SUBROUTINE open_met_file)') +! I am assuming the above is equivalent to below - rk4417 - phase2 +! ok = NF90_INQ_VARID(ncid_met, 'latitude', latitudeID) +! IF(ok /= NF90_NOERR) THEN +! ok = NF90_INQ_VARID(ncid_met, 'nav_lat', latitudeID) +! IF(ok /= NF90_NOERR) THEN +! !MDeck allow for 1d lat called 'lat' +! ok = NF90_INQ_VARID(ncid_met, 'lat', latitudeID) +! IF (ok /= NF90_NOERR) CALL nc_abort & +! (ok,'Error finding latitude variable in ' & +! //TRIM(filename%met)//' (SUBROUTINE open_met_file)') +! END IF +! END IF ! Allocate space for lat_all variable and its temp counterpart: ALLOCATE(lat_all(xdimsize,ydimsize)) @@ -556,6 +582,18 @@ SUBROUTINE open_met_file(dels,koffset,kend,spinup, TFRZ) IF(ok /= NF90_NOERR) CALL nc_abort & (ok,'Error finding longitude variable in ' & //TRIM(filename%met)//' (SUBROUTINE open_met_file)') +! I am assuming the above is equivalent to below - rk4417 - phase2 +! ok = NF90_INQ_VARID(ncid_met, 'longitude', longitudeID) +! IF(ok /= NF90_NOERR) THEN +! ok = NF90_INQ_VARID(ncid_met, 'nav_lon', longitudeID) +! IF(ok /= NF90_NOERR) THEN +! !MDeck allow for 1d lon called 'lon' +! ok = NF90_INQ_VARID(ncid_met, 'lon', longitudeID) +! IF(ok /= NF90_NOERR) CALL nc_abort & +! (ok,'Error finding longitude variable in ' & +! //TRIM(filename%met)//' (SUBROUTINE open_met_file)') +! END IF +! END IF ! Allocate space for lon_all variable: ALLOCATE(lon_all(xdimsize,ydimsize)) @@ -580,6 +618,13 @@ SUBROUTINE open_met_file(dels,koffset,kend,spinup, TFRZ) ! (and allow neither if only one gridpoint). "mask" is a 2D variable ! with dims x,y and "land" is a 1D variable. CALL find_metvarid(ncid_mask, possible_varnames%MaskNames, maskID, ok) +! I am assuming the above line is equivalent to below IF block - rk4417 - phase2 +! IF (.NOT.cable_user%gswp3) THEN +! ok = NF90_INQ_VARID(ncid_mask, 'mask', maskID) ! check for "mask" +! ELSE +! ok = NF90_INQ_VARID(ncid_mask, 'landsea', maskID) ! check for "mask" +! END IF + IF(ok /= NF90_NOERR) THEN ! if error, i.e. no "mask" variable: ! Check for "land" variable: ok = NF90_INQ_VARID(ncid_met, 'land', landID) @@ -737,6 +782,8 @@ SUBROUTINE open_met_file(dels,koffset,kend,spinup, TFRZ) !=========VV Determine simulation timing details VV================ ! Inquire 'time' variable's ID: CALL find_metvarid(ncid_met, possible_varnames%TimeNames, timevarID, ok) +! I am assuming the above line is equivalent to one below - rk4417 - phase2 +! ok = NF90_INQ_VARID(ncid_met, 'time', timevarID) IF(ok /= NF90_NOERR) CALL nc_abort & (ok,'Error finding time variable in met data file ' & //TRIM(filename%met)//' (SUBROUTINE open_met_file)') @@ -821,7 +868,12 @@ SUBROUTINE open_met_file(dels,koffset,kend,spinup, TFRZ) !===== done bug fixing for timevar in PALS met file =============== !===== gswp input file has bug in timeunits =========== - IF (ncciy > 0) WRITE(timeunits(26:27),'(i2.2)') 0 +! IF (ncciy > 0) WRITE(timeunits(26:27),'(i2.2)') 0 +! replaced above line by below IF block - rk4417 - phase2 + IF (TRIM(cable_user%MetType) .NE. "prin") THEN ! MMY + IF (ncciy > 0) WRITE(timeunits(26:27),'(i2.2)') 0 + END IF ! MMY + !===== done bug fixing for timeunits in gwsp file ======== WRITE(logn,*) 'Time variable units: ', timeunits ! Get coordinate field: @@ -847,11 +899,32 @@ SUBROUTINE open_met_file(dels,koffset,kend,spinup, TFRZ) ! Use internal files to convert "time" variable units (giving the run's ! start time) from character to integer; calculate starting hour-of-day, ! day-of-year, year: + +! IF (.NOT.cable_user%GSWP3) THEN +! READ(timeunits(15:18),*) syear +! READ(timeunits(20:21),*) smoy ! integer month +! READ(timeunits(23:24),*) sdoytmp ! integer day of that month +! READ(timeunits(26:27),*) shod ! starting hour of day +! ELSE +! syear=ncciy +! smoy=1 +! sdoytmp=1 +! shod=0 +! END IF +! replaced above IF block by below IF block - rk4417 - phase2 + IF (.NOT.cable_user%GSWP3) THEN - READ(timeunits(15:18),*) syear - READ(timeunits(20:21),*) smoy ! integer month - READ(timeunits(23:24),*) sdoytmp ! integer day of that month - READ(timeunits(26:27),*) shod ! starting hour of day + IF (cable_user%MetType .eq. "prin") THEN ! MMY + READ(timeunits(13:16),*) syear ! MMY + READ(timeunits(18:19),*) smoy ! integer month ! MMY + READ(timeunits(21:22),*) sdoytmp ! integer day of that month ! MMY + READ(timeunits(24:25),*) shod ! starting hour of day ! MMY + ELSE ! MMY + READ(timeunits(15:18),*) syear + READ(timeunits(20:21),*) smoy ! integer month + READ(timeunits(23:24),*) sdoytmp ! integer day of that month + READ(timeunits(26:27),*) shod ! starting hour of day + END IF ! MMY ELSE syear=ncciy smoy=1 @@ -859,6 +932,7 @@ SUBROUTINE open_met_file(dels,koffset,kend,spinup, TFRZ) shod=0 END IF + ! if site data, shift start time to middle of timestep ! only do this if not already at middle of timestep ! vh_js ! @@ -980,6 +1054,17 @@ SUBROUTINE open_met_file(dels,koffset,kend,spinup, TFRZ) IF(ok /= NF90_NOERR) CALL nc_abort & (ok,'Error finding SWdown in met data file ' & //TRIM(filename%met)//' (SUBROUTINE open_met_file)') + +! I am assuming the above block is equivalent to below block - rk4417 - phase2 + +! ok = NF90_INQ_VARID(ncid_met,'SWdown',id%SWdown) +! IF(ok /= NF90_NOERR) THEN ! MMY +! ok = NF90_INQ_VARID(ncid_met,'dswrf',id%SWdown) ! MMY ! For Princeton +! IF(ok /= NF90_NOERR) CALL nc_abort & ! MMY +! (ok,'Error finding SWdown in met data file ' & ! MMY +! //TRIM(filename%met)//' (SUBROUTINE open_met_file)') ! MMY +! END IF ! MMY + ! Get SWdown units and check okay: ok = NF90_GET_ATT(ncid_met,id%SWdown,'units',metunits%SWdown) IF(ok /= NF90_NOERR) CALL nc_abort & @@ -996,10 +1081,20 @@ SUBROUTINE open_met_file(dels,koffset,kend,spinup, TFRZ) ! Look for Tair (essential):- - - - - - - - - - - - - - - - - - - IF (ncciy > 0) ncid_met = ncid_ta CALL find_metvarid(ncid_met, possible_varnames%TairNames, id%Tair, ok) - IF(ok /= NF90_NOERR) CALL nc_abort & (ok,'Error finding Tair in met data file ' & //TRIM(filename%met)//' (SUBROUTINE open_met_file)') + +! I am assuming the above block is equivalent to below block - rk4417 - phase2 + +! ok = NF90_INQ_VARID(ncid_met,'Tair',id%Tair) +! IF(ok /= NF90_NOERR) THEN ! MMY +! ok = NF90_INQ_VARID(ncid_met,'tas',id%Tair) ! MMY ! For Princeton +! IF(ok /= NF90_NOERR) CALL nc_abort & ! MMY +! (ok,'Error finding Tair in met data file ' & ! MMY +! //TRIM(filename%met)//' (SUBROUTINE open_met_file)') ! MMY +! END IF ! MMY + ! Get Tair units and check okay: ok = NF90_GET_ATT(ncid_met,id%Tair,'units',metunits%Tair) IF(ok /= NF90_NOERR) CALL nc_abort & @@ -1020,10 +1115,20 @@ SUBROUTINE open_met_file(dels,koffset,kend,spinup, TFRZ) ! Look for Qair (essential):- - - - - - - - - - - - - - - - - - - IF (ncciy > 0) ncid_met = ncid_qa Call find_metvarid(ncid_met, possible_varnames%QairNames, id%Qair, ok) - IF(ok /= NF90_NOERR) CALL nc_abort & (ok,'Error finding Qair in met data file ' & //TRIM(filename%met)//' (SUBROUTINE open_met_file)') + +! I am assuming the above block is equivalent to below block - rk4417 - phase2 + +! ok = NF90_INQ_VARID(ncid_met,'Qair',id%Qair) +! IF(ok /= NF90_NOERR) THEN ! MMY +! ok = NF90_INQ_VARID(ncid_met,'shum',id%Qair) ! MMY ! For Princeton +! IF(ok /= NF90_NOERR) CALL nc_abort & ! MMY +! (ok,'Error finding Qair in met data file ' & ! MMY +! //TRIM(filename%met)//' (SUBROUTINE open_met_file)') ! MMY +! END IF ! MMY + ! Get Qair units: ok = NF90_GET_ATT(ncid_met,id%Qair,'units',metunits%Qair) IF(ok /= NF90_NOERR) CALL nc_abort & @@ -1046,16 +1151,29 @@ SUBROUTINE open_met_file(dels,koffset,kend,spinup, TFRZ) ! Look for Rainf (essential):- - - - - - - - - - - - - - - - - - IF (ncciy > 0) ncid_met = ncid_rain CALL find_metvarid(ncid_met, possible_varnames%RainNames, id%Rainf, ok) - IF(ok /= NF90_NOERR) CALL nc_abort & (ok,'Error finding Rainf in met data file ' & //TRIM(filename%met)//' (SUBROUTINE open_met_file)') + +! I am assuming the above block is equivalent to below block - rk4417 - phase2 + +! ok = NF90_INQ_VARID(ncid_met,'Rainf',id%Rainf) +! IF(ok .NE. NF90_NOERR) ok = NF90_INQ_VARID(ncid_met,'Precip',id%Rainf) +! IF(ok /= NF90_NOERR) THEN ! MMY +! ok = NF90_INQ_VARID(ncid_met,'prcp',id%Rainf) ! MMY ! For Princeton +! IF(ok /= NF90_NOERR) CALL nc_abort & ! MMY +! (ok,'Error finding Rainf in met data file ' & ! MMY +! //TRIM(filename%met)//' (SUBROUTINE open_met_file)') ! MMY +! END IF ! MMY + ! Get Rainf units: ok = NF90_GET_ATT(ncid_met,id%Rainf,'units',metunits%Rainf) IF(ok /= NF90_NOERR) CALL nc_abort & (ok,'Error finding Rainf units in met data file ' & //TRIM(filename%met)//' (SUBROUTINE open_met_file)') - IF(metunits%Rainf(1:8)=='kg/m^2/s'.OR.metunits%Rainf(1:6)=='kg/m2s'.OR.metunits%Rainf(1:10)== & +! IF(metunits%Rainf(1:8)=='kg/m^2/s'.OR.metunits%Rainf(1:6)=='kg/m2s'.OR.metunits%Rainf(1:10)== & +! replaced line above by line below - rk4417 - phase2 + IF(metunits%Rainf(1:8)=='kg/m^2/s'.OR.metunits%Rainf(1:7)=='kg/m2/s'.OR.metunits%Rainf(1:6)=='kg/m2s'.OR.metunits%Rainf(1:10)== & ! MMY@23Apr2023 edit for PLUMBER2 'kgm^-2s^-1'.OR.metunits%Rainf(1:4)=='mm/s'.OR. & metunits%Rainf(1:6)=='mms^-1'.OR. & metunits%Rainf(1:7)=='kg/m^2s'.OR.metunits%Rainf(1:10)=='kg m-2 s-1'.OR.metunits%Wind(1:5)/='m s-1') THEN @@ -1092,6 +1210,29 @@ SUBROUTINE open_met_file(dels,koffset,kend,spinup, TFRZ) exists%Wind = .TRUE. ! 'Wind' variable exists END IF +! I am assuming the above block is equivalent to below block - rk4417 - phase2 + +! ok = NF90_INQ_VARID(ncid_met,'Wind',id%Wind) +! IF(ok /= NF90_NOERR) THEN ! MMY +! ok = NF90_INQ_VARID(ncid_met,'wind',id%Wind) ! MMY ! For Princeton +! IF(ok /= NF90_NOERR) THEN ! MMY +! ! Look for vector wind: +! ok = NF90_INQ_VARID(ncid_met,'Wind_N',id%Wind) +! IF(ok /= NF90_NOERR) CALL nc_abort & +! (ok,'Error finding Wind in met data file ' & +! //TRIM(filename%met)//' (SUBROUTINE open_met_file)') +! ok = NF90_INQ_VARID(ncid_met,'Wind_E',id%Wind_E) +! IF(ok /= NF90_NOERR) CALL nc_abort & +! (ok,'Error finding Wind_E in met data file ' & +! //TRIM(filename%met)//' (SUBROUTINE open_met_file)') +! exists%Wind = .FALSE. ! Use vector wind when reading met +! ELSE ! MMY +! exists%Wind = .TRUE. ! 'Wind' variable exists ! MMY +! END IF +! ELSE +! exists%Wind = .TRUE. ! 'Wind' variable exists +! END IF + ! The following does not work with vector winds. Do we want to keep ! vector winds? ! Get Wind units: @@ -1108,6 +1249,8 @@ SUBROUTINE open_met_file(dels,koffset,kend,spinup, TFRZ) ! Look for LWdown (can be synthesised):- - - - - - - - - - - - - - - IF (ncciy > 0) ncid_met = ncid_lw CALL find_metvarid(ncid_met, possible_varnames%LWdownNames, id%LWdown, ok) +! I am assuming the above line is equivalent to below line - rk4417 - phase2 +! ok = NF90_INQ_VARID(ncid_met,'LWdown',id%LWdown) IF(ok == NF90_NOERR) THEN ! If inquiry is okay exists%LWdown = .TRUE. ! LWdown is present in met file @@ -1135,9 +1278,14 @@ SUBROUTINE open_met_file(dels,koffset,kend,spinup, TFRZ) WRITE(logn,*) 'LWdown not present in met file; ', & 'values will be synthesised based on air temperature.' END IF + ! Look for PSurf (can be synthesised):- - - - - - - - - - - - - - - - IF (ncciy > 0) ncid_met = ncid_ps CALL find_metvarid(ncid_met, possible_varnames%PSurfNames, id%PSurf, ok) +! I am assuming the above line is equivalent to the 3 lines below - rk4417 - phase2 +! ok = NF90_INQ_VARID(ncid_met,'PSurf',id%PSurf) +! IF(ok .NE. NF90_NOERR) ok = NF90_INQ_VARID(ncid_met,'Psurf',id%PSurf) +! IF(ok .NE. NF90_NOERR) ok = NF90_INQ_VARID(ncid_met,'pres',id%PSurf) ! MMY ! For Princeton IF(ok == NF90_NOERR) THEN ! If inquiry is okay exists%PSurf = .TRUE. ! PSurf is present in met file @@ -1171,6 +1319,8 @@ SUBROUTINE open_met_file(dels,koffset,kend,spinup, TFRZ) ! Look for "elevation" variable to approximate pressure based ! on elevation and temperature: CALL find_metvarid(ncid_met, possible_varnames%ElevNames, id%Elev, ok) +! I am assuming the above line is equivalent to below line - rk4417 - phase2 +! ok = NF90_INQ_VARID(ncid_met,'Elevation',id%Elev) IF(ok == NF90_NOERR) THEN ! elevation present ! Get elevation units: ok = NF90_GET_ATT(ncid_met,id%Elev,'units',metunits%Elev) @@ -1219,6 +1369,8 @@ SUBROUTINE open_met_file(dels,koffset,kend,spinup, TFRZ) END IF ! Look for CO2air (can be assumed to be static):- - - - - - - - - - - CALL find_metvarid(ncid_met, possible_varnames%CO2Names, id%CO2air, ok) +! I am assuming the above line is equivalent to below line - rk4417 - phase2 +! ok = NF90_INQ_VARID(ncid_met,'CO2air',id%CO2air) IF(ok == NF90_NOERR) THEN ! If inquiry is okay exists%CO2air = .TRUE. ! CO2air is present in met file ! Get CO2air units: @@ -1245,6 +1397,9 @@ SUBROUTINE open_met_file(dels,koffset,kend,spinup, TFRZ) END IF CALL find_metvarid(ncid_met, possible_varnames%SnowNames, id%Snowf, ok) +! I am assuming the above line is equivalent to below line - rk4417 - phase2 +! ok = NF90_INQ_VARID(ncid_met,'Snowf',id%Snowf) + IF(ok == NF90_NOERR) THEN ! If inquiry is okay exists%Snowf = .TRUE. ! Snowf is present in met file ! Get Snowf units: @@ -1265,6 +1420,8 @@ SUBROUTINE open_met_file(dels,koffset,kend,spinup, TFRZ) END IF ! Look for LAI - - - - - - - - - - - - - - - - - - - - - - - - - CALL find_metvarid(ncid_met, possible_varnames%LAINames, id%LAI, ok) +! I am assuming the above line is equivalent to below line - rk4417 - phase2 +! ok = NF90_INQ_VARID(ncid_met,'LAI',id%LAI) IF(ok == NF90_NOERR) THEN ! If inquiry is okay exists%LAI = .TRUE. ! LAI is present in met file ! LAI will be read in which ever land grid is used @@ -1300,6 +1457,8 @@ SUBROUTINE open_met_file(dels,koffset,kend,spinup, TFRZ) IF(spinup) THEN ! Look for avPrecip variable (time invariant - used for spinup): CALL find_metvarid(ncid_met, possible_varnames%APrecipNames, id%avPrecip, ok) +! I am assuming the above line is equivalent to below line - rk4417 - phase2 +! ok = NF90_INQ_VARID(ncid_met,'avPrecip',id%avPrecip) IF(ok == NF90_NOERR) THEN ! If inquiry is okay and avPrecip exists ! Report to log file than modified spinup will be used: WRITE(logn,*) 'Spinup will use modified precip - avPrecip variable found' @@ -1414,6 +1573,8 @@ SUBROUTINE open_met_file(dels,koffset,kend,spinup, TFRZ) ! Look for veg type - - - - - - - - - - - - - - - - -: CALL find_metvarid(ncid_met, possible_varnames%IVegNames, id%iveg, ok) +! I am assuming the above line is equivalent to below line - rk4417 - phase2 +! ok = NF90_INQ_VARID(ncid_met,'iveg',id%iveg) IF(ok == NF90_NOERR) THEN ! If 'iveg' exists in the met file ! Note existence of at least one model parameter in the met file: exists%parameters = .TRUE. @@ -1439,6 +1600,8 @@ SUBROUTINE open_met_file(dels,koffset,kend,spinup, TFRZ) ! patchfrac variable with the same dimensions. So, ! Make sure that the patchfrac variable exists: CALL find_metvarid(ncid_met, possible_varnames%PFracNames, id%patchfrac, ok) +! I am assuming the above line is equivalent to below line - rk4417 - phase2 +! ok = NF90_INQ_VARID(ncid_met,'patchfrac',id%patchfrac) IF(ok /= NF90_NOERR) CALL nc_abort & ! check read ok (ok,'Patch-specific vegetation type (iveg) must be accompanied '// & 'by a patchfrac variable - this was not found in met data file '& @@ -1479,6 +1642,8 @@ SUBROUTINE open_met_file(dels,koffset,kend,spinup, TFRZ) ! patchfrac variable with same dimensions. So, ! Make sure that the patchfrac variable exists: CALL find_metvarid(ncid_met, possible_varnames%PFracNames, id%patchfrac, ok) +! I am assuming the above line is equivalent to below line - rk4417 - phase2 +! ok = NF90_INQ_VARID(ncid_met,'patchfrac',id%patchfrac) IF(ok /= NF90_NOERR) CALL nc_abort & ! check read ok (ok,'Patch-specific vegetation type (iveg) must be accompanied'// & 'by a patchfrac variable - this was not found in met data file '& @@ -1512,6 +1677,8 @@ SUBROUTINE open_met_file(dels,koffset,kend,spinup, TFRZ) ! Look for soil type: CALL find_metvarid(ncid_met, possible_varnames%ISoilNames, id%isoil, ok) +! I am assuming the above line is equivalent to below line - rk4417 - phase2 +! ok = NF90_INQ_VARID(ncid_met,'isoil',id%isoil) IF(ok == NF90_NOERR) THEN ! If inquiry is okay ! Note existence of at least one model parameter in the met file: exists%parameters = .TRUE. @@ -1817,6 +1984,25 @@ SUBROUTINE get_met_data(spinup,spinConv,met,soil,rad, & ! Get SWdown data for mask grid: IF (cable_user%GSWP3) ncid_met=ncid_sw ! since GSWP3 multiple met files +! IF to ELSE below inserted by rk4417 - phase2 + ! ______________________ MMY _________________________ + IF (TRIM(cable_user%MetType) .eq. "prin") THEN + ok= NF90_GET_VAR(ncid_met,id%SWdown,tmpDat4, & + start=(/1,1,1,ktau/),count=(/xdimsize,ydimsize,1,1/)) + IF(ok /= NF90_NOERR) CALL nc_abort & + (ok,'Error reading SWdown in met data file ' & + //TRIM(filename%met)//' (SUBROUTINE get_met_data)') + DO i=1,mland ! over all land points/grid cells + met%fsd(landpt(i)%cstart:landpt(i)%cend,1) = & + 0.5 * REAL(tmpDat4(land_x(i),land_y(i),1,1)) + met%fsd(landpt(i)%cstart:landpt(i)%cend,2) = & + 0.5 * REAL(tmpDat4(land_x(i),land_y(i),1,1)) + ENDDO + ! PRINT *, "========== MMY ==========" + ! PRINT *, "met%fsd",met%fsd + ! ____________________________________________________ + ELSE ! MMY + ok= NF90_GET_VAR(ncid_met,id%SWdown,tmpDat3, & start=(/1,1,ktau/),count=(/xdimsize,ydimsize,1/)) IF(ok /= NF90_NOERR) CALL nc_abort & @@ -1830,7 +2016,9 @@ SUBROUTINE get_met_data(spinup,spinConv,met,soil,rad, & met%fsd(landpt(i)%cstart:landpt(i)%cend,2) = & 0.5 * REAL(tmpDat3(land_x(i),land_y(i),1)) ENDDO + END IF ! MMY ! inserted by rk4417 - phase2 +! ================ MMY@23Apr2023 testing below ============== ! Get Tair data for mask grid:- - - - - - - - - - - - - - - - - - IF(cable_user%GSWP3) ncid_met = ncid_ta ! since GSWP3 multiple met files ! Find number of dimensions of Tair: @@ -2019,9 +2207,24 @@ SUBROUTINE get_met_data(spinup,spinConv,met,soil,rad, & ENDDO END IF ! 3 or 4D for 'Wind_N' and 'Wind_E' variables END IF ! scalar or vector wind - 'Wind' or 'Wind_N'/'Wind_E' +! ================ MMY@23Apr2023 testing above ============== ! Get Rainf and Snowf data for mask grid:- - - - - - - - - - - - - IF (cable_user%GSWP3) ncid_met = ncid_rain +! IF to ELSE below inserted by rk4417 - phase2 +! ______________________ MMY _________________________ + IF (TRIM(cable_user%MetType) .eq. "prin") THEN ! MMY + ok= NF90_GET_VAR(ncid_met,id%Rainf,tmpDat4, & + start=(/1,1,1,ktau/),count=(/xdimsize,ydimsize,1,1/)) + IF(ok /= NF90_NOERR) CALL nc_abort & + (ok,'Error reading Rainf in met data file ' & + //TRIM(filename%met)//' (SUBROUTINE get_met_data)') + DO i=1,mland ! over all land points/grid cells + met%precip(landpt(i)%cstart:landpt(i)%cend) = & + REAL(tmpDat4(land_x(i),land_y(i),1,1)) ! store Rainf + ENDDO +! ____________________________________________________ + ELSE ! MMY ok= NF90_GET_VAR(ncid_met,id%Rainf,tmpDat3, & start=(/1,1,ktau/),count=(/xdimsize,ydimsize,1/)) IF(ok /= NF90_NOERR) CALL nc_abort & @@ -2031,6 +2234,8 @@ SUBROUTINE get_met_data(spinup,spinConv,met,soil,rad, & met%precip(landpt(i)%cstart:landpt(i)%cend) = & REAL(tmpDat3(land_x(i),land_y(i),1)) ! store Rainf ENDDO + END IF ! MMY ! inserted by rk4417 - phase2 + IF(exists%Snowf) THEN IF (cable_user%GSWP3) ncid_met = ncid_snow ok= NF90_GET_VAR(ncid_met,id%Snowf,tmpDat3, & @@ -2067,6 +2272,22 @@ SUBROUTINE get_met_data(spinup,spinConv,met,soil,rad, & ! Get LWdown data for mask grid: - - - - - - - - - - - - - - - - - IF (cable_user%GSWP3) ncid_met = ncid_lw +! IF to ELSE below inserted by rk4417 - phase2 + ! ______________________ MMY _________________________ + IF (TRIM(cable_user%MetType) .eq. "prin") THEN + ok= NF90_GET_VAR(ncid_met,id%LWdown,tmpDat4, & + start=(/1,1,1,ktau/),count=(/xdimsize,ydimsize,1,1/)) + IF(ok /= NF90_NOERR) CALL nc_abort & + (ok,'Error reading LWdown in met data file ' & + //TRIM(filename%met)//' (SUBROUTINE get_met_data)') + DO i=1,mland ! over all land points/grid cells + met%fld(landpt(i)%cstart:landpt(i)%cend) = & + REAL(tmpDat4(land_x(i),land_y(i),1,1)) + ENDDO + ! PRINT *, "========== MMY ==========" + ! PRINT *, "met%fld",met%fld + ! ____________________________________________________ + ELSE ! MMY IF(exists%LWdown) THEN ! If LWdown exists in met file ok= NF90_GET_VAR(ncid_met,id%LWdown,tmpDat3, & start=(/1,1,ktau/),count=(/xdimsize,ydimsize,1/)) @@ -2081,9 +2302,25 @@ SUBROUTINE get_met_data(spinup,spinConv,met,soil,rad, & ! Use Swinbank formula: met%fld(:) = 0.0000094*0.0000000567*(met%tk(:)**6.0) END IF + END IF ! inserted by rk4417 - phase2 ! Get CO2air data for mask grid:- - - - - - - - - - - - - - - - - - IF(exists%CO2air) THEN ! If CO2air exists in met file +! 1 line and IF to ELSE below inserted by rk4417 - phase2 +! ____________ MMY@23Apr2023 to read CO2air from PLUMBER2 __________ + ok = NF90_INQUIRE_VARIABLE(ncid_met,id%CO2air,ndims=ndims) + IF(ndims==3) THEN + ok= NF90_GET_VAR(ncid_met,id%CO2air,tmpDat3, & + start=(/1,1,ktau/),count=(/xdimsize,ydimsize,1/)) + IF(ok /= NF90_NOERR) CALL nc_abort & + (ok,'Error reading CO2air in met data file ' & + //TRIM(filename%met)//' (SUBROUTINE get_met_data)') + DO i=1,mland ! over all land points/grid cells + met%ca(landpt(i)%cstart:landpt(i)%cend) = & + REAL(tmpDat3(land_x(i),land_y(i),1))/1000000.0 + ENDDO + ELSE +! __________________________________________________________________ ok= NF90_GET_VAR(ncid_met,id%CO2air,tmpDat4, & start=(/1,1,1,ktau/),count=(/xdimsize,ydimsize,1,1/)) IF(ok /= NF90_NOERR) CALL nc_abort & @@ -2093,6 +2330,7 @@ SUBROUTINE get_met_data(spinup,spinConv,met,soil,rad, & met%ca(landpt(i)%cstart:landpt(i)%cend) = & REAL(tmpDat4(land_x(i),land_y(i),1,1))/1000000.0 ENDDO + END IF ! MMY@23Apr2023 ! inserted by rk4417 - phase2 ELSE ! Fix CO2 air concentration: met%ca(:) = fixedCO2 /1000000.0 @@ -2659,6 +2897,12 @@ SUBROUTINE load_parameters(met,air,ssnow,veg,climate,bgc,soil,canopy,rough,rad, ! different dimension to what is declared here. CALL allocate_cable_vars(air,bgc,canopy,met,bal,rad,rough,soil,ssnow, & sum_flux,veg,mp) + +! call below inserted by rk4417 - phase2 + !CALL for gw_model false and true sets constants when false + CALL GWspatialParameters(logn,soil,ssnow) ! MMY gw_model = True read var from gridinfo + ! MMY gw_model = False use default values + WRITE(logn,*) ' CABLE variables allocated with ', mp, ' patch(es).' IF (icycle > 0 .OR. CABLE_USER%CASA_DUMP_WRITE ) & diff --git a/src/offline/cable_iovars.F90 b/src/offline/cable_iovars.F90 index a2ca5247a..ccc74d171 100644 --- a/src/offline/cable_iovars.F90 +++ b/src/offline/cable_iovars.F90 @@ -142,6 +142,7 @@ MODULE cable_IO_vars_module verbose, & ! print init and param details of all grid cells? soilparmnew ! read IGBP new soil map. Q.Zhang @ 12/20/2010 + ! ================ Veg and soil type variables ============================ INTEGER, POINTER :: & soiltype_metfile(:,:), & ! user defined soil type (from met file) @@ -160,7 +161,9 @@ MODULE cable_IO_vars_module veg_class,soil_class,mvtype,mstype,patchfrac, & WatSat,GWWatSat,SoilMatPotSat,GWSoilMatPotSat, & HkSat,GWHkSat,FrcSand,FrcClay,Clappb,Watr,GWWatr,sfc_vec,forg,swilt_vec, & - slope,slope_std,GWdz,SatFracmax,Qhmax,QhmaxEfold,HKefold,HKdepth + slope,slope_std,GWdz,SatFracmax,Qhmax,QhmaxEfold,HKefold,HKdepth, & + sand_vec,clay_vec,bch_vec,org_vec,elev,elev_std ! inserted by rk4417 - phase2 + INTEGER :: ishorizon,nhorizons,clitt, & zeta,fsatmax, & gamma,ZR,F10 @@ -382,6 +385,8 @@ MODULE cable_IO_vars_module isoil = .FALSE., & ! soil type from global index meth = .FALSE., & ! method for solving turbulence in canopy scheme za = .FALSE., & ! something to do with roughness ???? + elev = .false.,& !mean subgrid elev ! inserted 2 lines - rk4417 - phase2 + elev_std=.false.,& !stddev of subgrid elev slope = .FALSE.,& !mean subgrid slope slope_std=.FALSE.,& !stddev of subgrid slope GWdz=.FALSE.,& !aquifer thickness @@ -389,7 +394,14 @@ MODULE cable_IO_vars_module Qhmax=.FALSE.,& QhmaxEfold=.FALSE.,& HKefold=.FALSE.,& - HKdepth +! HKdepth ! commented out by rk4417 - phase2 + HKdepth=.false.,& ! added this block - rk4417 - phase2 + SMP=.false.,& + SMP_hys=.false.,& + WB_hys=.false.,& + SSAT_hys=.false.,& + WATR_hys=.false.,& + hys_fac=.false. END TYPE output_inclusion_type diff --git a/src/offline/cable_mpicommon.F90 b/src/offline/cable_mpicommon.F90 index ddd0e5785..2507a52ca 100644 --- a/src/offline/cable_mpicommon.F90 +++ b/src/offline/cable_mpicommon.F90 @@ -29,8 +29,9 @@ MODULE cable_mpicommon ! base number of input fields: must correspond to CALLS to ! MPI_address (field ) in *_mpimaster/ *_mpiworker - INTEGER, PARAMETER :: nparam = 330 - +! INTEGER, PARAMETER :: nparam = 330 ! replaced by below by rk4417 - phase2 + INTEGER, PARAMETER :: nparam =351!hysteresis 346! 341!1 !326!308 + ! MPI: extra params sent only if nsoilparmnew is true INTEGER, PARAMETER :: nsoilnew = 1 @@ -77,7 +78,8 @@ MODULE cable_mpicommon !INTEGER, PARAMETER :: nmat = 29 ! MPI: CABLE_r491, after following up with Bernard on the new variables ! vh sli nmat + 4 36 -> 40 - INTEGER, PARAMETER :: nmat = 40 +! INTEGER, PARAMETER :: nmat = 40 ! replaced by below by rk4417 - phase2 + INTEGER, PARAMETER :: nmat = 46 !hysteresis 41 ! MPI: number of contig vector parts / worker (results) !INTEGER, PARAMETER :: nvec = 149 @@ -94,7 +96,8 @@ MODULE cable_mpicommon ! vh sli nvec + 6 162 -> 168 ! INTEGER, PARAMETER :: nvec = 172! 168 ! INH REV_CORR +3 (SSEB +2 will be needed) - INTEGER, PARAMETER :: nvec = 175 +! INTEGER, PARAMETER :: nvec = 175 ! replaced by below by rk4417 - phase2 + INTEGER, PARAMETER :: nvec = 176! 176!175 ! MPI: number of final casa result matrices and vectors to receive ! by the master for casa_poolout and casa_fluxout diff --git a/src/offline/cable_mpimaster.F90 b/src/offline/cable_mpimaster.F90 index 97ab7b30e..614b2be16 100644 --- a/src/offline/cable_mpimaster.F90 +++ b/src/offline/cable_mpimaster.F90 @@ -157,9 +157,10 @@ SUBROUTINE mpidrv_master (comm) USE cable_def_types_mod USE cable_IO_vars_module, ONLY: logn,gswpfile,ncciy,leaps,globalMetfile, & verbose, fixedCO2,output,check,patchout, & - patch_type,landpt,soilparmnew,& + patch_type,landpt,soilparmnew, & defaultLAI, sdoy, smoy, syear, timeunits, exists, output, & - latitude,longitude, calendar, set_group_output_values + latitude,longitude, calendar, set_group_output_values, & + patch ! inserted by rk4417 - phase2 USE cable_common_module, ONLY: ktau_gl, kend_gl, knode_gl, cable_user, & cable_runtime, fileName, myhome, & redistrb, wiltParam, satuParam, CurYear, & @@ -337,7 +338,7 @@ SUBROUTINE mpidrv_master (comm) NAMELIST/CABLE/ & filename, & ! TYPE, containing input filenames vegparmnew, & ! use new soil param. method - soilparmnew, & ! use new soil param. method + soilparmnew, & ! use new soil param. method calcsoilalbedo, & ! ! vars intro for Ticket #27 spinup, & ! spinup model (soil) to steady state delsoilM,delsoilT,& ! @@ -411,7 +412,10 @@ SUBROUTINE mpidrv_master (comm) ! options from the namelist file CALL set_group_output_values() - IF (TRIM(cable_user%MetType) .EQ. 'gswp' .OR. TRIM(cable_user%MetType) .EQ. 'gswp3') THEN +! IF (TRIM(cable_user%MetType) .EQ. 'gswp' .OR. TRIM(cable_user%MetType) .EQ. 'gswp3') THEN +! line above replaced by below - rk4417 - phase2 + IF (TRIM(cable_user%MetType) .EQ. 'gswp' .or. TRIM(cable_user%MetType) .EQ. 'gswp3' & ! MMY + .or. TRIM(cable_user%MetType) .EQ. 'prin') THEN ! MMY IF ( CABLE_USER%YearStart.EQ.0 .AND. ncciy.GT.0) THEN CABLE_USER%YearStart = ncciy CABLE_USER%YearEnd = ncciy @@ -469,8 +473,8 @@ SUBROUTINE mpidrv_master (comm) STOP 'casaCNP required to get prognostic LAI or Vcmax' IF( l_vcmaxFeedbk .AND. icycle < 2 ) & STOP 'icycle must be 2 to 3 to get prognostic Vcmax' - IF( icycle > 0 .AND. ( .NOT. soilparmnew ) ) & - STOP 'casaCNP must use new soil parameters' + IF( icycle > 0 .AND. ( .NOT. soilparmnew ) ) & + STOP 'casaCNP must use new soil parameters' ! casa time count ctime = 0 @@ -482,6 +486,7 @@ SUBROUTINE mpidrv_master (comm) ! latitudes, longitudes, number of sites. IF ( TRIM(cable_user%MetType) .NE. "gswp" .AND. & TRIM(cable_user%MetType) .NE. "gswp3" .AND. & + TRIM(cable_user%MetType) .NE. "prin" .AND. & ! MMY ! inserted by rk4417 - phase2 TRIM(cable_user%MetType) .NE. "gpgs" .AND. & TRIM(cable_user%MetType) .NE. "plum" .AND. & TRIM(cable_user%MetType) .NE. "cru" .AND. & @@ -565,6 +570,11 @@ SUBROUTINE mpidrv_master (comm) WRITE(*,*) 'Looking for global offline run info.' CALL open_met_file( dels, koffset, kend, spinup, CTFRZ ) +! ELSE IF below inserted by rk4417 - phase2 + ELSE IF (TRIM(cable_user%MetType) .EQ. 'prin') THEN ! MMY + ncciy = CurYear ! MMY + WRITE(*,*) 'Looking for global offline run info.' ! MMY + CALL open_met_file( dels, koffset, kend, spinup, CTFRZ ) ! MMY ELSE IF ( globalMetfile%l_gpcc ) THEN ncciy = CurYear @@ -803,8 +813,9 @@ SUBROUTINE mpidrv_master (comm) canopy%oldcansto=canopy%cansto ! Zero out lai where there is no vegetation acc. to veg. index - WHERE ( iveg%iveg(:) .GE. 14 ) iveg%vlai = 0. - +! WHERE ( iveg%iveg(:) .GE. 14 ) iveg%vlai = 0. +! line above replaced by below - rk4417 - phase2 + WHERE ( veg%iveg(:) .GE. 14 ) veg%vlai = 0. ! MMY change from iveg%vlai to veg%vlai IF ( .NOT. CASAONLY ) THEN @@ -863,6 +874,7 @@ SUBROUTINE mpidrv_master (comm) ENDIF IF ( (TRIM(cable_user%MetType) .NE. 'gswp') .AND. & + (TRIM(cable_user%MetType) .NE. 'prin') .and. & ! MMY ! inserted by rk4417 - phase2 (TRIM(cable_user%MetType) .NE. 'gswp3') ) CurYear = met%year(1) !$ IF ( CASAONLY .AND. IS_CASA_TIME("dread", yyyy, iktau, kstart, koffset, & @@ -945,8 +957,9 @@ SUBROUTINE mpidrv_master (comm) canopy%oldcansto=canopy%cansto ! Zero out lai where there is no vegetation acc. to veg. index - WHERE ( iveg%iveg(:) .GE. 14 ) iveg%vlai = 0. - +! WHERE ( iveg%iveg(:) .GE. 14 ) iveg%vlai = 0. +! line above replaced by below - rk4417 - phase2 + WHERE ( veg%iveg(:) .GE. 14 ) veg%vlai = 0. ! MMY change from iveg%vlai to veg%vlai ! Write time step's output to file if either: we're not spinning up ! or we're spinning up and the spinup has converged: ! MPI: TODO: pull mass and energy balance calculation from write_output @@ -973,6 +986,7 @@ SUBROUTINE mpidrv_master (comm) IF ( TRIM(cable_user%MetType) .EQ. 'plum' & .OR. TRIM(cable_user%MetType) .EQ. 'cru' & .OR. TRIM(cable_user%MetType) .EQ. 'gswp' & + .OR. TRIM(cable_user%MetType) .EQ. 'prin' & ! MMY ! inserted by rk4417 - phase2 .OR. TRIM(cable_user%MetType) .EQ. 'gswp3') THEN CALL write_output( dels, ktau_tot, met, canopy, casaflux, casapool, & casamet,ssnow, & @@ -1095,7 +1109,12 @@ SUBROUTINE mpidrv_master (comm) met%ofsd = met%fsd(:,1) + met%fsd(:,2) canopy%oldcansto=canopy%cansto - IF ( (TRIM(cable_user%MetType) .EQ. "gswp") .OR. (TRIM(cable_user%MetType) .EQ. "gswp3") ) & +! IF ( (TRIM(cable_user%MetType) .EQ. "gswp") .OR. (TRIM(cable_user%MetType) .EQ. "gswp3") ) & +! CALL close_met_file +! above IF replaced by below - rk4417 - phase2 + IF ( (TRIM(cable_user%MetType) .EQ. "gswp") & + .or. (TRIM(cable_user%MetType) .EQ. "prin") & ! MMY + .or. (TRIM(cable_user%MetType) .EQ. "gswp3") ) & CALL close_met_file IF (icycle>0 .AND. cable_user%CALL_POP) THEN @@ -1192,6 +1211,7 @@ SUBROUTINE mpidrv_master (comm) IF ( TRIM(cable_user%MetType) .EQ. 'plum' & .OR. TRIM(cable_user%MetType) .EQ. 'cru' & .OR. TRIM(cable_user%MetType) .EQ. 'gswp' & + .OR. TRIM(cable_user%MetType) .EQ. 'prin' & ! MMY ! inserted by rk4417 - phase2 .OR. TRIM(cable_user%MetType) .EQ. 'gswp3') THEN CALL write_output( dels, ktau_tot, met, canopy, casaflux, casapool, & @@ -1462,6 +1482,7 @@ SUBROUTINE mpidrv_master (comm) ! Close met data input file: IF ( TRIM(cable_user%MetType) .NE. "gswp" .AND. & TRIM(cable_user%MetType) .NE. "gswp3" .AND. & + TRIM(cable_user%MetType) .NE. "prin" .AND. & ! MMY ! inserted by rk4417 - phase2 TRIM(cable_user%MetType) .NE. "plum" .AND. & TRIM(cable_user%MetType) .NE. "cru") CALL close_met_file IF (.NOT. CASAONLY) THEN @@ -2762,6 +2783,10 @@ SUBROUTINE master_cable_params (comm,met,air,ssnow,veg,bgc,soil,canopy,& CALL MPI_Get_address (canopy%fwsoil(off), displs(bidx), ierr) blen(bidx) = r2len + bidx = bidx + 1 ! block inserted by rk4417 - phase2 + CALL MPI_Get_address (canopy%sublayer_dz(off), displs(bidx), ierr) + blen(bidx) = r2len + bidx = bidx + 1 CALL MPI_Get_address (canopy%gswx(off,1), displs(bidx), ierr) CALL MPI_Type_create_hvector (mf, r1len, r1stride, MPI_BYTE, & @@ -3303,7 +3328,84 @@ SUBROUTINE master_cable_params (comm,met,air,ssnow,veg,bgc,soil,canopy,& & types(bidx), ierr) blen(bidx) = 1 + bidx = bidx + 1 + CALL MPI_Get_address (soil%css_vec(off,1), displs(bidx), ierr) + CALL MPI_Type_create_hvector (ms, r2len, r2stride, MPI_BYTE, & + & types(bidx), ierr) + blen(bidx) = 1 + + bidx = bidx + 1 + CALL MPI_Get_address (soil%rhosoil_vec(off,1), displs(bidx), ierr) + CALL MPI_Type_create_hvector (ms, r2len, r2stride, MPI_BYTE, & + & types(bidx), ierr) + blen(bidx) = 1 + + bidx = bidx + 1 + CALL MPI_Get_address (soil%cnsd_vec(off,1), displs(bidx), ierr) + CALL MPI_Type_create_hvector (ms, r2len, r2stride, MPI_BYTE, & + & types(bidx), ierr) + blen(bidx) = 1 + + bidx = bidx + 1 + CALL MPI_Get_address (soil%zse_vec(off,1), displs(bidx), ierr) + CALL MPI_Type_create_hvector (ms, r2len, r2stride, MPI_BYTE, & + & types(bidx), ierr) + blen(bidx) = 1 + + bidx = bidx + 1 + CALL MPI_Get_address (soil%sand_vec(off,1), displs(bidx), ierr) + CALL MPI_Type_create_hvector (ms, r2len, r2stride, MPI_BYTE, & + & types(bidx), ierr) + blen(bidx) = 1 + + bidx = bidx + 1 + CALL MPI_Get_address (soil%clay_vec(off,1), displs(bidx), ierr) + CALL MPI_Type_create_hvector (ms, r2len, r2stride, MPI_BYTE, & + & types(bidx), ierr) + blen(bidx) = 1 + + bidx = bidx + 1 + CALL MPI_Get_address (soil%silt_vec(off,1), displs(bidx), ierr) + CALL MPI_Type_create_hvector (ms, r2len, r2stride, MPI_BYTE, & + & types(bidx), ierr) + blen(bidx) = 1 + + bidx = bidx + 1 + CALL MPI_Get_address (soil%org_vec(off,1), displs(bidx), ierr) + CALL MPI_Type_create_hvector (ms, r2len, r2stride, MPI_BYTE, & + & types(bidx), ierr) + blen(bidx) = 1 + + bidx = bidx + 1 + CALL MPI_Get_address (ssnow%ssat_hys(off,1), displs(bidx), ierr) + CALL MPI_Type_create_hvector (ms, r2len, r2stride, MPI_BYTE, & + & types(bidx), ierr) + blen(bidx) = 1 + + bidx = bidx + 1 + CALL MPI_Get_address (ssnow%watr_hys(off,1), displs(bidx), ierr) + CALL MPI_Type_create_hvector (ms, r2len, r2stride, MPI_BYTE, & + & types(bidx), ierr) + blen(bidx) = 1 + + bidx = bidx + 1 + CALL MPI_Get_address (ssnow%smp_hys(off,1), displs(bidx), ierr) + CALL MPI_Type_create_hvector (ms, r2len, r2stride, MPI_BYTE, & + & types(bidx), ierr) + blen(bidx) = 1 + + bidx = bidx + 1 + CALL MPI_Get_address (ssnow%wb_hys(off,1), displs(bidx), ierr) + CALL MPI_Type_create_hvector (ms, r2len, r2stride, MPI_BYTE, & + & types(bidx), ierr) + blen(bidx) = 1 + bidx = bidx + 1 + CALL MPI_Get_address (ssnow%hys_fac(off,1), displs(bidx), ierr) + CALL MPI_Type_create_hvector (ms, r2len, r2stride, MPI_BYTE, & + & types(bidx), ierr) + blen(bidx) = 1 + !1D bidx = bidx + 1 CALL MPI_Get_address (soil%GWssat_vec(off), displs(bidx), ierr) @@ -3325,14 +3427,18 @@ SUBROUTINE master_cable_params (comm,met,air,ssnow,veg,bgc,soil,canopy,& CALL MPI_Get_address (soil%GWwatr(off), displs(bidx), ierr) blen(bidx) = r2len - bidx = bidx + 1 - CALL MPI_Get_address (soil%GWz(off), displs(bidx), ierr) - blen(bidx) = r2len +! bidx = bidx + 1 ! commented out by rk4417 - phase2 +! CALL MPI_Get_address (soil%GWz(off), displs(bidx), ierr) +! blen(bidx) = r2len bidx = bidx + 1 CALL MPI_Get_address (soil%GWdz(off), displs(bidx), ierr) blen(bidx) = r2len + bidx = bidx + 1 ! inserted by rk4417 - phase2 + CALL MPI_Get_address (soil%elev(off), displs(bidx), ierr) + blen(bidx) = r2len + bidx = bidx + 1 CALL MPI_Get_address (soil%slope(off), displs(bidx), ierr) blen(bidx) = r2len @@ -3341,6 +3447,43 @@ SUBROUTINE master_cable_params (comm,met,air,ssnow,veg,bgc,soil,canopy,& CALL MPI_Get_address (soil%slope_std(off), displs(bidx), ierr) blen(bidx) = r2len + +! block below inserted by rk4417 - phase2 + bidx = bidx + 1 + CALL MPI_Get_address (soil%drain_dens(off), displs(bidx), ierr) + blen(bidx) = r2len + + + bidx = bidx + 1 + CALL MPI_Get_address (soil%hkrz(off), displs(bidx), ierr) + blen(bidx) = r2len + + + bidx = bidx + 1 + CALL MPI_Get_address (soil%zdepth(off), displs(bidx), ierr) + blen(bidx) = r2len + + + bidx = bidx + 1 + CALL MPI_Get_address (soil%srf_frac_ma(off), displs(bidx), ierr) + blen(bidx) = r2len + + + bidx = bidx + 1 + CALL MPI_Get_address (soil%edepth_ma(off), displs(bidx), ierr) + blen(bidx) = r2len + + + bidx = bidx + 1 + CALL MPI_Get_address (soil%qhz_max(off), displs(bidx), ierr) + blen(bidx) = r2len + + + bidx = bidx + 1 + CALL MPI_Get_address (soil%qhz_efold(off), displs(bidx), ierr) + blen(bidx) = r2len +! end of block - rk4417 - phase2 + bidx = bidx + 1 CALL MPI_Get_address (ssnow%GWwb(off), displs(bidx), ierr) blen(bidx) = r2len @@ -3348,6 +3491,7 @@ SUBROUTINE master_cable_params (comm,met,air,ssnow,veg,bgc,soil,canopy,& ! MPI: sanity check IF (bidx /= ntyp) THEN WRITE (*,*) 'master: invalid number of param_t fields ',bidx,', fix it!' + WRITE (*,*) 'local counbt bidx is ',bidx,' while ntyp is ',ntyp ! inserted by rk4417 - phase2 CALL MPI_Abort (comm, 1, ierr) END IF @@ -4570,6 +4714,7 @@ SUBROUTINE master_casa_params (comm,casabiome,casapool,casaflux,casamet,& ! MPI: sanity check IF (bidx /= ntyp) THEN WRITE (*,*) 'master: invalid number of casa_t param fields ',bidx,', fix it!' + WRITE (*,*) 'local counbt bidx is ',bidx,' while ntyp is ',ntyp ! inserted by rk4417 - phase2 CALL MPI_Abort (comm, 1, ierr) END IF @@ -5034,6 +5179,53 @@ SUBROUTINE master_outtypes (comm,met,canopy,ssnow,rad,bal,air,soil,veg) & mat_t(midx, rank), ierr) CALL MPI_Type_commit (mat_t(midx, rank), ierr) midx = midx + 1 + +! block below inserted by rk4417 - phase2 + ! REAL(r_2) + CALL MPI_Get_address (ssnow%smp(off,1), maddr(midx), ierr) ! 12 + CALL MPI_Type_create_hvector (ms, r2len, r2stride, MPI_BYTE, & + & mat_t(midx, rank), ierr) + CALL MPI_Type_commit (mat_t(midx, rank), ierr) + midx = midx + 1 + + ! REAL(r_2) + CALL MPI_Get_address (ssnow%wb_hys(off,1), maddr(midx), ierr) ! 12 + CALL MPI_Type_create_hvector (ms, r2len, r2stride, MPI_BYTE, & + & mat_t(midx, rank), ierr) + CALL MPI_Type_commit (mat_t(midx, rank), ierr) + midx = midx + 1 + + ! REAL(r_2) + CALL MPI_Get_address (ssnow%smp_hys(off,1), maddr(midx), ierr) ! 12 + CALL MPI_Type_create_hvector (ms, r2len, r2stride, MPI_BYTE, & + & mat_t(midx, rank), ierr) + CALL MPI_Type_commit (mat_t(midx, rank), ierr) + midx = midx + 1 + + ! REAL(r_2) + CALL MPI_Get_address (ssnow%ssat_hys(off,1), maddr(midx), ierr) ! 12 + CALL MPI_Type_create_hvector (ms, r2len, r2stride, MPI_BYTE, & + & mat_t(midx, rank), ierr) + CALL MPI_Type_commit (mat_t(midx, rank), ierr) + midx = midx + 1 + + + ! REAL(r_2) + CALL MPI_Get_address (ssnow%watr_hys(off,1), maddr(midx), ierr) ! 12 + CALL MPI_Type_create_hvector (ms, r2len, r2stride, MPI_BYTE, & + & mat_t(midx, rank), ierr) + CALL MPI_Type_commit (mat_t(midx, rank), ierr) + midx = midx + 1 + + + ! REAL(r_2) + CALL MPI_Get_address (ssnow%hys_fac(off,1), maddr(midx), ierr) ! 12 + CALL MPI_Type_create_hvector (ms, r2len, r2stride, MPI_BYTE, & + & mat_t(midx, rank), ierr) + CALL MPI_Type_commit (mat_t(midx, rank), ierr) + midx = midx + 1 +! end of block - rk4417 - phase2 + ! REAL(r_1) CALL MPI_Get_address (ssnow%evapfbl(off,1), maddr(midx), ierr) ! 12 CALL MPI_Type_create_hvector (ms, r1len, r1stride, MPI_BYTE, & @@ -5544,6 +5736,11 @@ SUBROUTINE master_outtypes (comm,met,canopy,ssnow,rad,bal,air,soil,veg) CALL MPI_Get_address (canopy%fwsoil(off), vaddr(vidx), ierr) ! 59 blen(vidx) = cnt * extr2 + vidx = vidx + 1 ! block inserted by rk4417 - phase2 + ! REAL(r_2) + CALL MPI_Get_address (canopy%sublayer_dz(off), vaddr(vidx), ierr) ! 59 + blen(vidx) = cnt * extr2 + ! MPI: 2D vars moved above ! rwater ! evapfbl diff --git a/src/offline/cable_mpiworker.F90 b/src/offline/cable_mpiworker.F90 index f240e557d..d36a8c334 100644 --- a/src/offline/cable_mpiworker.F90 +++ b/src/offline/cable_mpiworker.F90 @@ -257,7 +257,7 @@ SUBROUTINE mpidrv_worker (comm) NAMELIST/CABLE/ & filename, & ! TYPE, containing input filenames vegparmnew, & ! use new soil param. method - soilparmnew, & ! use new soil param. method + soilparmnew, & ! use new soil param. method ! MMY@Feb2023 calcsoilalbedo, & ! switch: soil colour albedo - Ticket #27 spinup, & ! spinup model (soil) to steady state delsoilM,delsoilT,& ! @@ -284,7 +284,7 @@ SUBROUTINE mpidrv_worker (comm) cable_user, & ! additional USER switches gw_params - INTEGER :: i,x,kk + INTEGER :: i,x,kk,klev ! klev added by rk4417 - phase2 INTEGER :: LALLOC, iu !For consistency w JAC REAL,ALLOCATABLE, SAVE :: c1(:,:) @@ -368,7 +368,7 @@ SUBROUTINE mpidrv_worker (comm) STOP 'casaCNP required to get prognostic LAI or Vcmax' IF( l_vcmaxFeedbk .AND. icycle < 2 ) & STOP 'icycle must be 2 to 3 to get prognostic Vcmax' - IF( icycle > 0 .AND. ( .NOT. soilparmnew ) ) & + IF( icycle > 0 .AND. ( .NOT. soilparmnew ) ) & STOP 'casaCNP must use new soil parameters' ! Open log file: @@ -658,7 +658,6 @@ SUBROUTINE mpidrv_worker (comm) CALL cable_climate(ktau_tot,kstart,kend,ktauday,idoy,LOY,met, & climate, canopy, air, rad, dels, mp) - IF (.NOT. allocated(c1)) ALLOCATE( c1(mp,nrb), rhoch(mp,nrb), xk(mp,nrb) ) ! CALL land surface scheme for this timestep, all grid points: CALL cbm( ktau, dels, air, bgc, canopy, met, bal, & @@ -669,7 +668,6 @@ SUBROUTINE mpidrv_worker (comm) ssnow%rnof2 = ssnow%rnof2*dels ssnow%runoff = ssnow%runoff*dels - !jhan this is insufficient testing. condition for !spinup=.false. & we want CASA_dump.nc (spinConv=.true.) @@ -1924,6 +1922,11 @@ SUBROUTINE worker_cable_params (comm,met,air,ssnow,veg,bgc,soil,canopy,& CALL MPI_Get_address (canopy%fwsoil, displs(bidx), ierr) blen(bidx) = r2len +! block below inserted by rk4417 - phase2 + bidx = bidx + 1 + CALL MPI_Get_address (canopy%sublayer_dz, displs(bidx), ierr) + blen(bidx) = r2len + bidx = bidx + 1 CALL MPI_Get_address (canopy%gswx, displs(bidx), ierr) blen(bidx) = mf * r1len @@ -2402,6 +2405,70 @@ SUBROUTINE worker_cable_params (comm,met,air,ssnow,veg,bgc,soil,canopy,& CALL MPI_Get_address (soil%sfc_vec, displs(bidx), ierr) blen(bidx) = ms * r2len +! block below inserted by rk4417 - phase2 + bidx = bidx + 1 + CALL MPI_Get_address (soil%css_vec, displs(bidx), ierr) + blen(bidx) = ms * r2len + + + bidx = bidx + 1 + CALL MPI_Get_address (soil%rhosoil_vec, displs(bidx), ierr) + blen(bidx) = ms * r2len + + + bidx = bidx + 1 + CALL MPI_Get_address (soil%cnsd_vec, displs(bidx), ierr) + blen(bidx) = ms * r2len + + + bidx = bidx + 1 + CALL MPI_Get_address (soil%zse_vec, displs(bidx), ierr) + blen(bidx) = ms * r2len + + + bidx = bidx + 1 + CALL MPI_Get_address (soil%sand_vec, displs(bidx), ierr) + blen(bidx) = ms * r2len + + + bidx = bidx + 1 + CALL MPI_Get_address (soil%clay_vec, displs(bidx), ierr) + blen(bidx) = ms * r2len + + + bidx = bidx + 1 + CALL MPI_Get_address (soil%silt_vec, displs(bidx), ierr) + blen(bidx) = ms * r2len + + + bidx = bidx + 1 + CALL MPI_Get_address (soil%org_vec, displs(bidx), ierr) + blen(bidx) = ms * r2len + + bidx = bidx + 1 + CALL MPI_Get_address (ssnow%ssat_hys, displs(bidx), ierr) + blen(bidx) = ms * r2len + + + bidx = bidx + 1 + CALL MPI_Get_address (ssnow%watr_hys, displs(bidx), ierr) + blen(bidx) = ms * r2len + + + bidx = bidx + 1 + CALL MPI_Get_address (ssnow%smp_hys, displs(bidx), ierr) + blen(bidx) = ms * r2len + + + bidx = bidx + 1 + CALL MPI_Get_address (ssnow%wb_hys, displs(bidx), ierr) + blen(bidx) = ms * r2len + + + bidx = bidx + 1 + CALL MPI_Get_address (ssnow%hys_fac, displs(bidx), ierr) + blen(bidx) = ms * r2len +! end of block - rk4417 - phase2 !1d bidx = bidx + 1 @@ -2424,14 +2491,20 @@ SUBROUTINE worker_cable_params (comm,met,air,ssnow,veg,bgc,soil,canopy,& CALL MPI_Get_address (soil%GWwatr, displs(bidx), ierr) blen(bidx) = r2len - bidx = bidx + 1 - CALL MPI_Get_address (soil%GWz, displs(bidx), ierr) - blen(bidx) = r2len +! commented out by rk4417 - phase2 +! bidx = bidx + 1 +! CALL MPI_Get_address (soil%GWz, displs(bidx), ierr) +! blen(bidx) = r2len bidx = bidx + 1 CALL MPI_Get_address (soil%GWdz, displs(bidx), ierr) blen(bidx) = r2len +! block below inserted by rk4417 - phase2 + bidx = bidx + 1 + CALL MPI_Get_address (soil%elev, displs(bidx), ierr) + blen(bidx) = r2len + bidx = bidx + 1 CALL MPI_Get_address (soil%slope, displs(bidx), ierr) blen(bidx) = r2len @@ -2440,6 +2513,42 @@ SUBROUTINE worker_cable_params (comm,met,air,ssnow,veg,bgc,soil,canopy,& CALL MPI_Get_address (soil%slope_std, displs(bidx), ierr) blen(bidx) = r2len +! block below inserted by rk4417 - phase2 + bidx = bidx + 1 + CALL MPI_Get_address (soil%drain_dens, displs(bidx), ierr) + blen(bidx) = r2len + + + bidx = bidx + 1 + CALL MPI_Get_address (soil%hkrz, displs(bidx), ierr) + blen(bidx) = r2len + + + bidx = bidx + 1 + CALL MPI_Get_address (soil%zdepth, displs(bidx), ierr) + blen(bidx) = r2len + + + bidx = bidx + 1 + CALL MPI_Get_address (soil%srf_frac_ma, displs(bidx), ierr) + blen(bidx) = r2len + + + bidx = bidx + 1 + CALL MPI_Get_address (soil%edepth_ma, displs(bidx), ierr) + blen(bidx) = r2len + + + bidx = bidx + 1 + CALL MPI_Get_address (soil%qhz_max, displs(bidx), ierr) + blen(bidx) = r2len + + + bidx = bidx + 1 + CALL MPI_Get_address (soil%qhz_efold, displs(bidx), ierr) + blen(bidx) = r2len +! end of block - rk4417 - phase2 + bidx = bidx + 1 CALL MPI_Get_address (ssnow%GWwb, displs(bidx), ierr) blen(bidx) = r2len @@ -2447,6 +2556,7 @@ SUBROUTINE worker_cable_params (comm,met,air,ssnow,veg,bgc,soil,canopy,& ! MPI: sanity check IF (bidx /= ntyp) THEN WRITE (*,*) 'worker ',rank,' invalid number of param_t fields',bidx,', fix it!' + WRITE (*,*) 'worker ',rank,' invalid number ntyp is ',ntyp,', fix it!' ! inserted by rk4417 - phase2 CALL MPI_Abort (comm, 1, ierr) END IF @@ -3909,6 +4019,32 @@ SUBROUTINE worker_outtype (comm,met,canopy,ssnow,rad,bal,air,soil,veg) CALL MPI_Get_address (ssnow%wb(off,1), displs(bidx), ierr) blocks(bidx) = r2len * ms +! block below inserted by rk4417 - phase2 + bidx = bidx + 1 + CALL MPI_Get_address (ssnow%smp(off,1), displs(bidx), ierr) + blocks(bidx) = r2len * ms + + bidx = bidx + 1 + CALL MPI_Get_address (ssnow%wb_hys(off,1), displs(bidx), ierr) + blocks(bidx) = r2len * ms + + bidx = bidx + 1 + CALL MPI_Get_address (ssnow%smp_hys(off,1), displs(bidx), ierr) + blocks(bidx) = r2len * ms + + bidx = bidx + 1 + CALL MPI_Get_address (ssnow%ssat_hys(off,1), displs(bidx), ierr) + blocks(bidx) = r2len * ms + + bidx = bidx + 1 + CALL MPI_Get_address (ssnow%watr_hys(off,1), displs(bidx), ierr) + blocks(bidx) = r2len * ms + + bidx = bidx + 1 + CALL MPI_Get_address (ssnow%hys_fac(off,1), displs(bidx), ierr) + blocks(bidx) = r2len * ms +! end of block - rk4417 - phase2 + bidx = bidx + 1 CALL MPI_Get_address (ssnow%evapfbl(off,1), displs(bidx), ierr) blocks(bidx) = r1len * ms @@ -4672,6 +4808,11 @@ SUBROUTINE worker_outtype (comm,met,canopy,ssnow,rad,bal,air,soil,veg) CALL MPI_Get_address (canopy%fwsoil(off), displs(bidx), ierr) blocks(bidx) = r2len +! block below inserted by rk4417 - phase2 + bidx = bidx + 1 + CALL MPI_Get_address (canopy%sublayer_dz(off), displs(bidx), ierr) + blocks(bidx) = r2len + ! MPI: 2D vars moved above ! rwater ! evapfbl diff --git a/src/offline/cable_output.F90 b/src/offline/cable_output.F90 index 04cb67a43..d89fb2dc0 100644 --- a/src/offline/cable_output.F90 +++ b/src/offline/cable_output.F90 @@ -69,7 +69,9 @@ MODULE cable_output_module PlantTurnover, PlantTurnoverLeaf, PlantTurnoverFineRoot, & PlantTurnoverWood, PlantTurnoverWoodDist, PlantTurnoverWoodCrowding, & PlantTurnoverWoodResourceLim, dCdt, Area, LandUseFlux, patchfrac, & - vcmax,hc,WatTable,GWMoist,SatFrac,Qrecharge + vcmax,hc,WatTable,GWMoist,SatFrac,Qrecharge, & + SMP,SMP_hys,WB_hys,SSAT_hys, WATR_hys,hys_fac ! added by rk4417 - phase2 + END TYPE out_varID_type TYPE(out_varID_type) :: ovid ! netcdf variable IDs for output variables TYPE(parID_type) :: opid ! netcdf variable IDs for output variables @@ -229,6 +231,17 @@ MODULE cable_output_module REAL(KIND=4), POINTER, DIMENSION(:) :: RootResp ! autotrophic root respiration [umol/m2/s] REAL(KIND=4), POINTER, DIMENSION(:) :: StemResp ! autotrophic stem respiration [umol/m2/s] + +! remainder of TYPE block below added by rk4417 - phase2 + + REAL(KIND=4), POINTER, DIMENSION(:,:) :: SMP ! soil pressure [m] + REAL(KIND=4), POINTER, DIMENSION(:,:) :: SMP_hys ! soil pressure [m] + REAL(KIND=4), POINTER, DIMENSION(:,:) :: WB_hys ! soil pressure [m] + + REAL(KIND=4), POINTER, DIMENSION(:,:) :: SSAT_hys ! soil pressure [m] + REAL(KIND=4), POINTER, DIMENSION(:,:) :: WATR_hys ! soil pressure [m] + REAL(KIND=4), POINTER, DIMENSION(:,:) :: hys_fac ! soil pressure [m] + END TYPE output_temporary_type TYPE output_var_settings_type @@ -627,6 +640,44 @@ SUBROUTINE open_output_file(dels, soil, veg, bgc, rough, met) ALLOCATE(out%SoilTemp(mp,ms)) out%SoilTemp = 0.0 ! initialise END IF + +! block below inserted by rk4417 - phase2 + IF(output%soil .OR. output%SMP) THEN + CALL define_ovar(ncid_out, ovid%SMP, 'SMP', 'm', & + 'Average layer soil pressure', patchout%SMP, & + 'soil', xID, yID, zID, landID, patchID, soilID, tID) + ALLOCATE(out%SMP(mp,ms)) + out%SMP = 0.0 ! initialise + ENDIF + if (cable_user%gw_model .and. gw_params%BC_hysteresis) then + CALL define_ovar(ncid_out, ovid%SMP_hys, 'SMP_hys', 'm', & + 'Average layer soil pressure at hys trans', patchout%SMP_hys, & + 'soil', xID, yID, zID, landID, patchID, soilID, tID) + ALLOCATE(out%SMP_hys(mp,ms)) + out%SMP_hys = 0.0 ! initialise + CALL define_ovar(ncid_out, ovid%WB_hys, 'WB_hys', 'm', & + 'wb at wet/dry or dry/wet transition', patchout%WB_hys, & + 'soil', xID, yID, zID, landID, patchID, soilID, tID) + ALLOCATE(out%WB_hys(mp,ms)) + out%WB_hys = 0.0 ! initialise + CALL define_ovar(ncid_out, ovid%SSAT_hys, 'SSAT_hys', 'm', & + 'hysteresis adj ssat', patchout%SSAT_hys, & + 'soil', xID, yID, zID, landID, patchID, soilID, tID) + ALLOCATE(out%SSAT_hys(mp,ms)) + out%SSAT_hys = 0.0 ! initialise + CALL define_ovar(ncid_out, ovid%WATR_hys, 'WATR_hys', 'm', & + 'hysteresis adj watr', patchout%WATR_hys, & + 'soil', xID, yID, zID, landID, patchID, soilID, tID) + ALLOCATE(out%WATR_hys(mp,ms)) + out%WATR_hys = 0.0 ! initialise + CALL define_ovar(ncid_out, ovid%hys_fac, 'hys_fac', 'm', & + '1.0 wet 0.5 dry', patchout%hys_fac, & + 'soil', xID, yID, zID, landID, patchID, soilID, tID) + ALLOCATE(out%hys_fac(mp,ms)) + out%hys_fac = 0.0 ! initialise + END IF +! end of block - rk4417 - phase2 + IF(output%BaresoilT) THEN CALL define_ovar(ncid_out, ovid%BaresoilT, 'BaresoilT', & 'K', 'Bare soil temperature', patchout%BaresoilT, & @@ -1096,39 +1147,121 @@ SUBROUTINE open_output_file(dels, soil, veg, bgc, rough, met) IF(output%isoil) CALL define_ovar(ncid_out, opid%isoil, & 'isoil', '-', 'Soil type', patchout%isoil, 'integer', & xID, yID, zID, landID, patchID) - IF(output%bch) CALL define_ovar(ncid_out, opid%bch, & - 'bch', '-', 'Parameter b, Campbell eqn 1985', patchout%bch, 'real', & + IF(output%bch) THEN + IF (cable_user%gw_model) THEN + CALL define_ovar(ncid_out, opid%bch, & + 'bch', '-', 'Parameter b, Campbell eqn 1985', patchout%bch, soilID,'soil', & + xID, yID, zID, landID, patchID) + ELSE + CALL define_ovar(ncid_out, opid%bch, & + 'bch', '-', 'Parameter b, Campbell eqn 1985', patchout%bch, 'real', & + xID, yID, zID, landID, patchID) + END IF + END IF + IF(output%clay) THEN + IF (cable_user%gw_model) THEN + CALL define_ovar(ncid_out, opid%clay, & + 'clay', '-', 'Fraction of soil which is clay', patchout%clay, soilID,'soil', & xID, yID, zID, landID, patchID) - IF(output%clay) CALL define_ovar(ncid_out, opid%clay, & + ELSE + CALL define_ovar(ncid_out, opid%clay, & 'clay', '-', 'Fraction of soil which is clay', patchout%clay, 'real', & xID, yID, zID, landID, patchID) - IF(output%sand) CALL define_ovar(ncid_out, opid%sand, & + END IF + END IF + IF(output%sand) THEN + IF (cable_user%gw_model) THEN + CALL define_ovar(ncid_out, opid%sand, & + 'sand', '-', 'Fraction of soil which is sand', patchout%sand, soilID,'soil', & + xID, yID, zID, landID, patchID) + ELSE + CALL define_ovar(ncid_out, opid%sand, & 'sand', '-', 'Fraction of soil which is sand', patchout%sand, 'real', & xID, yID, zID, landID, patchID) - IF(output%silt) CALL define_ovar(ncid_out, opid%silt, & - 'silt', '-', 'Fraction of soil which is silt', patchout%silt, 'real', & + END IF + END IF + IF(output%silt) THEN + IF (cable_user%gw_model) THEN + CALL define_ovar(ncid_out, opid%silt, & + 'silt', '-', 'Fraction of soil which is silt', patchout%silt, soilID,'soil', & xID, yID, zID, landID, patchID) - IF(output%ssat) CALL define_ovar(ncid_out, opid%ssat, & - 'ssat', '-', 'Fraction of soil volume which is water @ saturation', & - patchout%ssat, 'real', xID, yID, zID, landID, patchID) - IF(output%sfc) CALL define_ovar(ncid_out, opid%sfc, & - 'sfc', '-', 'Fraction of soil volume which is water @ field capacity', & - patchout%sfc, 'real', xID, yID, zID, landID, patchID) - IF(output%swilt) CALL define_ovar(ncid_out, opid%swilt, & - 'swilt', '-', 'Fraction of soil volume which is water @ wilting point', & - patchout%swilt, 'real', xID, yID, zID, landID, patchID) - IF(output%hyds) CALL define_ovar(ncid_out, opid%hyds, & - 'hyds', 'm/s', 'Hydraulic conductivity @ saturation', & - patchout%hyds, 'real', xID, yID, zID, landID, patchID) - IF(output%sucs) CALL define_ovar(ncid_out, opid%sucs, & - 'sucs', 'm', 'Suction @ saturation', & + ELSE + CALL define_ovar(ncid_out, opid%silt, & + 'silt', '-', 'Fraction of soil which is silt', patchout%silt, 'real', & + xID, yID, zID, landID, patchID) + END IF + END IF + IF(output%ssat) THEN + IF (cable_user%gw_model) THEN + CALL define_ovar(ncid_out, opid%ssat, & + 'ssat', '-', 'Fraction of soil volume which is water @ saturation', & + patchout%ssat, soilID,'soil', xID, yID, zID, landID, patchID) + ELSE + CALL define_ovar(ncid_out, opid%ssat, & + 'ssat', '-', 'Fraction of soil volume which is water @ saturation', & + patchout%ssat, 'real', xID, yID, zID, landID, patchID) + END IF + END IF + IF(output%sfc) THEN + IF (cable_user%gw_model) THEN + CALL define_ovar(ncid_out, opid%sfc, & + 'sfc', '-', 'Fraction of soil volume which is water @ field capacity', & + patchout%sfc, soilID,'soil', xID, yID, zID, landID, patchID) + ELSE + CALL define_ovar(ncid_out, opid%sfc, & + 'sfc', '-', 'Fraction of soil volume which is water @ field capacity', & + patchout%sfc, 'real', xID, yID, zID, landID, patchID) + END IF + END IF + IF(output%swilt) THEN + IF (cable_user%gw_model) THEN + CALL define_ovar(ncid_out, opid%swilt, & + 'swilt', '-', 'Fraction of soil volume which is water @ wilting point', & + patchout%swilt, soilID,'soil', xID, yID, zID, landID, patchID) + ELSE + CALL define_ovar(ncid_out, opid%swilt, & + 'swilt', '-', 'Fraction of soil volume which is water @ wilting point', & + patchout%swilt, 'real', xID, yID, zID, landID, patchID) + END IF + END IF + IF(output%hyds) THEN + IF (cable_user%gw_model) THEN + CALL define_ovar(ncid_out, opid%hyds, & + 'hyds', 'm/s', 'Hydraulic conductivity @ saturation', & + patchout%hyds, soilID,'soil', xID, yID, zID, landID, patchID) + ELSE + CALL define_ovar(ncid_out, opid%hyds, & + 'hyds', 'm/s', 'Hydraulic conductivity @ saturation', & + patchout%hyds, 'real', xID, yID, zID, landID, patchID) + END IF + END IF + IF(output%sucs) THEN + IF (cable_user%gw_model) THEN + ! gw_model uses sucs_vec that is a 2D variable + CALL define_ovar(ncid_out, opid%sucs, & + 'sucs', 'm', 'Suction @ saturation', & + patchout%sucs, soilID,'soil', xID, yID, zID, landID, patchID) + ELSE + CALL define_ovar(ncid_out, opid%sucs, & + 'sucs', 'm', 'Suction @ saturation', & patchout%sucs, 'real', xID, yID, zID, landID, patchID) + END IF + END IF IF(output%css) CALL define_ovar(ncid_out, opid%css, & 'css', 'J/kg/C', 'Heat capacity of soil minerals', & - patchout%css, 'real', xID, yID, zID, landID, patchID) - IF(output%rhosoil) CALL define_ovar(ncid_out, & - opid%rhosoil, 'rhosoil', 'kg/m^3', 'Density of soil minerals', & - patchout%rhosoil, 'real', xID, yID, zID, landID, patchID) +! patchout%css, 'real', xID, yID, zID, landID, patchID) + patchout%css, soilID,'soil', xID, yID, zID, landID, patchID) + IF(output%rhosoil) THEN + IF (cable_user%gw_model) THEN + CALL define_ovar(ncid_out, & + opid%rhosoil, 'rhosoil', 'kg/m^3', 'Density of soil minerals', & + patchout%rhosoil, soilID,'soil', xID, yID, zID, landID, patchID) + ELSE + CALL define_ovar(ncid_out, & + opid%rhosoil, 'rhosoil', 'kg/m^3', 'Density of soil minerals', & + patchout%rhosoil, 'real', xID, yID, zID, landID, patchID) + END IF + END IF IF(output%rs20) CALL define_ovar(ncid_out, opid%rs20, & 'rs20', '-', 'Soil respiration coefficient at 20C', & patchout%rs20, 'real', xID, yID, zID, landID, patchID) @@ -1245,6 +1378,24 @@ SUBROUTINE open_output_file(dels, soil, veg, bgc, rough, met) ! patchout%GWdz, 'real', xID, yID, zID, landID, patchID) ! IF(output%params .AND. cable_user%gw_model) THEN + +! block below inserted by rk4417 - phase2 + call define_ovar(ncid_out, opid%slope, & + 'slope', '-', 'mean subgrid topographic slope', & + patchout%slope, 'real', xid, yid, zid, landid, patchid) + call define_ovar(ncid_out, opid%elev, & + 'elev', '-', 'mean subgrid topographic elev', & + patchout%elev, 'real', xid, yid, zid, landid, patchid) + + CALL define_ovar(ncid_out, opid%slope_std, & + 'slope_std', '-', 'Mean subgrid topographic slope_std', & + patchout%slope_std, 'real', xID, yID, zID, landID, patchID) + + CALL define_ovar(ncid_out, opid%GWdz, & + 'GWdz', '-', 'Mean aquifer layer thickness ', & + patchout%GWdz, 'real', xID, yID, zID, landID, patchID) +! end of block - rk4417 - phase2 + CALL define_ovar(ncid_out, opid%Qhmax, & 'Qhmax', 'mm/s', 'Maximum subsurface drainage ', & patchout%Qhmax, 'real', xID, yID, zID, landID, patchID) @@ -1365,40 +1516,66 @@ SUBROUTINE open_output_file(dels, soil, veg, bgc, rough, met) !~ Patch out_settings%dimswitch = "real" - CALL check_and_write(output%patchfrac .AND. (patchout%patchfrac .OR. output%patch), opid%patchfrac, 'patchfrac', & + CALL check_and_write(output%patchfrac .AND. (patchout%patchfrac .OR. output%patch), opid%patchfrac, 'patchfrac', & REAL(patch(:)%frac, 4), ranges%patchfrac, patchout%patchfrac, out_settings) !~ Soil out_settings%dimswitch = "integer" CALL check_and_write(output%isoil, opid%isoil, & 'isoil', REAL(soil%isoilm, 4), ranges%isoil, patchout%isoil, out_settings) - out_settings%dimswitch = "real" - CALL check_and_write(output%bch, opid%bch, & + + IF (cable_user%gw_model) THEN + out_settings%dimswitch = "soil" + + CALL check_and_write(output%bch, opid%bch, & + 'bch', REAL(soil%bch_vec, 4), ranges%bch, patchout%bch, out_settings) + CALL check_and_write(output%clay, opid%clay, & + 'clay', REAL(soil%clay_vec, 4), ranges%clay, patchout%clay, out_settings) + CALL check_and_write(output%sand, opid%sand, & + 'sand', REAL(soil%sand_vec, 4), ranges%sand, patchout%sand, out_settings) + CALL check_and_write(output%silt, opid%silt, & + 'silt', REAL(soil%silt_vec, 4), ranges%silt, patchout%silt, out_settings) + CALL check_and_write(output%css, opid%css, & + 'css', REAL(soil%css_vec, 4), ranges%css, patchout%css, out_settings) + CALL check_and_write(output%rhosoil, & + opid%rhosoil, 'rhosoil',REAL(soil%rhosoil_vec,4), & + ranges%rhosoil, patchout%rhosoil, out_settings) + CALL check_and_write(output%hyds, opid%hyds, & + 'hyds', REAL(soil%hyds_vec, 4), ranges%hyds, patchout%hyds, out_settings) + CALL check_and_write(output%sucs, opid%sucs, & + 'sucs', REAL(soil%sucs_vec, 4), ranges%sucs, patchout%sucs, out_settings) + CALL check_and_write(output%ssat, opid%ssat, & + 'ssat', REAL(soil%ssat_vec, 4), ranges%ssat, patchout%ssat, out_settings) + CALL check_and_write(output%sfc, opid%sfc, & + 'sfc', REAL(soil%sfc_vec, 4), ranges%sfc, patchout%sfc, out_settings) + CALL check_and_write(output%swilt, opid%swilt, & + 'swilt', REAL(soil%swilt_vec, 4), ranges%swilt, patchout%swilt, out_settings) + ELSE + out_settings%dimswitch = "real" + CALL check_and_write(output%bch, opid%bch, & 'bch', REAL(soil%bch, 4), ranges%bch, patchout%bch, out_settings) - CALL check_and_write(output%clay, opid%clay, & + CALL check_and_write(output%clay, opid%clay, & 'clay', REAL(soil%clay, 4), ranges%clay, patchout%clay, out_settings) - CALL check_and_write(output%sand, opid%sand, & + CALL check_and_write(output%sand, opid%sand, & 'sand', REAL(soil%sand, 4), ranges%sand, patchout%sand, out_settings) - CALL check_and_write(output%silt, opid%silt, & + CALL check_and_write(output%silt, opid%silt, & 'silt', REAL(soil%silt, 4), ranges%silt, patchout%silt, out_settings) - CALL check_and_write(output%css, opid%css, & + CALL check_and_write(output%css, opid%css, & 'css', REAL(soil%css, 4), ranges%css, patchout%css, out_settings) - CALL check_and_write(output%rhosoil, & + CALL check_and_write(output%rhosoil, & opid%rhosoil, 'rhosoil',REAL(soil%rhosoil,4), & ranges%rhosoil, patchout%rhosoil, out_settings) - CALL check_and_write(output%hyds, opid%hyds, & + CALL check_and_write(output%hyds, opid%hyds, & 'hyds', REAL(soil%hyds, 4), ranges%hyds, patchout%hyds, out_settings) - CALL check_and_write(output%sucs, opid%sucs, & + CALL check_and_write(output%sucs, opid%sucs, & 'sucs', REAL(soil%sucs, 4), ranges%sucs, patchout%sucs, out_settings) - CALL check_and_write(output%rs20, opid%rs20, & - 'rs20', REAL(veg%rs20, 4), ranges%rs20, patchout%rs20, out_settings) - ! 'rs20',REAL(soil%rs20,4),ranges%rs20,patchout%rs20,out_settings) - CALL check_and_write(output%ssat, opid%ssat, & + CALL check_and_write(output%ssat, opid%ssat, & 'ssat', REAL(soil%ssat, 4), ranges%ssat, patchout%ssat, out_settings) - CALL check_and_write(output%sfc, opid%sfc, & + CALL check_and_write(output%sfc, opid%sfc, & 'sfc', REAL(soil%sfc, 4), ranges%sfc, patchout%sfc, out_settings) - CALL check_and_write(output%swilt, opid%swilt, & + CALL check_and_write(output%swilt, opid%swilt, & 'swilt', REAL(soil%swilt, 4), ranges%swilt, patchout%swilt, out_settings) + END IF ! CALL check_and_write(output%slope ,ncid_out, opid%slope, & ! 'slope', REAL(soil%slope, 4), ranges%slope, patchout%slope, out_settings) @@ -1414,7 +1591,8 @@ SUBROUTINE open_output_file(dels, soil, veg, bgc, rough, met) out_settings%dimswitch = "soil" CALL check_and_write(output%zse, opid%zse, & - 'zse', SPREAD(REAL(soil%zse, 4), 1, mp),ranges%zse, & +! 'zse', SPREAD(REAL(soil%zse, 4), 1, mp),ranges%zse, & + 'zse', REAL(soil%zse_vec, 4),ranges%zse, & patchout%zse, out_settings)! no spatial dim at present !~ Veg @@ -1443,6 +1621,9 @@ SUBROUTINE open_output_file(dels, soil, veg, bgc, rough, met) ENDIF CALL check_and_write(output%rp20, opid%rp20, & 'rp20', REAL(veg%rp20, 4),ranges%rp20, patchout%rp20, out_settings) + CALL check_and_write(output%rs20, opid%rs20, & + 'rs20', REAL(veg%rs20, 4), ranges%rs20, patchout%rs20, out_settings) + ! 'rs20',REAL(soil%rs20,4),ranges%rs20,patchout%rs20,out_settings) ! Ticket #56 CALL check_and_write(output%g0, opid%g0, & 'g0', REAL(veg%g0, 4),ranges%g0, patchout%g0, out_settings) @@ -1496,27 +1677,58 @@ SUBROUTINE open_output_file(dels, soil, veg, bgc, rough, met) patchout%ratecs, out_settings)! no spatial dim at present !~ gwmodel + + IF(output%params .AND. cable_user%gw_model) THEN ! line inserted by rk4417 - phase2 + out_settings%dimswitch = "real" + +! block below inserted by rk4417 - phase2 +! CALL write_ovar(ncid_out, opid%slope, & ! write_ovar call here will not compile anymore because of recent changes made by others in cable_write.F90, needs to be adapted - rk4417 -phase2 +! 'slope', REAL(soil%slope, 4), & +! (/0.0,9999.0/), patchout%slope, 'real') + +! CALL write_ovar(ncid_out, opid%elev, & ! write_ovar call here will not compile anymore because of recent changes made by others in cable_write.F90, needs to be adapted - rk4417 -phase2 +! 'elev', REAL(soil%elev, 4),& +! (/0.0,9999999.0/), patchout%elev, 'real') + +! CALL write_ovar(ncid_out, opid%slope_std, & ! write_ovar call here will not compile anymore because of recent changes made by others in cable_write.F90, needs to be adapted - rk4417 -phase2 +! 'slope_std', REAL(soil%slope_std, 4),& +! (/0.0,9999.0/), patchout%slope_std, 'real') + +! CALL write_ovar(ncid_out, opid%GWdz, & ! write_ovar call here will not compile anymore because of recent changes made by others in cable_write.F90, needs to be adapted - rk4417 -phase2 +! 'GWdz', REAL(soil%GWdz, 4), & +! (/0.0,999999.0/), patchout%GWdz, 'real') + +! CALL write_ovar(ncid_out, opid%QhmaxEfold, & ! write_ovar call here will not compile anymore because of recent changes made by others in cable_write.F90, needs to be adapted - rk4417 -phase2 +! ' QhmaxEfold', REAL(soil%drain_dens, 4), & +! (/0.0,999999.0/), patchout%QhmaxEfold, 'real') +! end of block - rk4417 - phase2 + CALL check_and_write(output%params .AND. cable_user%gw_model, opid%SatFracmax, & - 'SatFracmax', SPREAD(REAL(gw_params%MaxSatFraction,4),1,mp), & - ranges%gw_default, patchout%SatFracmax, out_settings) +! 'SatFracmax', SPREAD(REAL(gw_params%MaxSatFraction,4),1,mp), & + 'SatFracmax', SPREAD(REAL(SQRT(gw_params%MaxSatFraction),4),1,mp), & + ranges%gw_default, patchout%SatFracmax, out_settings) ! note specially for ranges%gw_default that I have instead (/0.0,1000000.0/) - rk4417 - phase2 CALL check_and_write(output%params .AND. cable_user%gw_model, opid%Qhmax, & - 'Qhmax', SPREAD(REAL(gw_params%MaxHorzDrainRate, 4),1,mp), & - ranges%gw_default, patchout%Qhmax, out_settings) +! 'Qhmax', SPREAD(REAL(gw_params%MaxHorzDrainRate, 4),1,mp), & + 'Qhmax', REAL(soil%qhz_max, 4), & + ranges%gw_default, patchout%Qhmax, out_settings) ! note specially for ranges%gw_default that I have instead (/0.0,1000000.0/) - rk4417 - phase2 - CALL check_and_write(output%params .AND. cable_user%gw_model, opid%QhmaxEfold, & - 'QhmaxEfold', SPREAD(REAL(gw_params%EfoldHorzDrainRate, 4),1,mp), & - ranges%gw_default, patchout%QhmaxEfold, out_settings) +! part below commented out by rk4417 - phase2 +! CALL check_and_write(output%params .AND. cable_user%gw_model, opid%QhmaxEfold, & +! 'QhmaxEfold', SPREAD(REAL(gw_params%EfoldHorzDrainRate, 4),1,mp), & +! ranges%gw_default, patchout%QhmaxEfold, out_settings) CALL check_and_write(output%params .AND. cable_user%gw_model, opid%HKefold, & - 'HKefold', SPREAD(REAL(gw_params%hkrz, 4),1,mp), & - ranges%gw_default, patchout%HKefold, out_settings) +! 'HKefold', SPREAD(REAL(gw_params%hkrz, 4),1,mp), & + 'HKefold', REAL(soil%hkrz, 4), & + ranges%gw_default, patchout%HKefold, out_settings) ! note specially for ranges%gw_default that I have instead (/0.0,1000000.0/) - rk4417 - phase2 CALL check_and_write(output%params .AND. cable_user%gw_model, opid%HKdepth, & - 'HKdepth', SPREAD(REAL(gw_params%zdepth, 4),1,mp), & - ranges%gw_default, patchout%HKdepth, out_settings) - +! 'HKdepth', SPREAD(REAL(gw_params%zdepth, 4),1,mp), & + 'HKdepth', REAL(soil%zdepth, 4), & + ranges%gw_default, patchout%HKdepth, out_settings) ! note specially for ranges%gw_default that I have instead (/0.0,1000000.0/) - rk4417 - phase2 + END IF ! line inserted by rk4417 - phase2 END SUBROUTINE open_output_file @@ -1782,6 +1994,64 @@ SUBROUTINE write_output(dels, ktau, met, canopy, casaflux, casapool, casamet, ss !write(*,*) 'Qinfl' !MDeck CALL generate_out_write_acc(output%SatFrac .AND. cable_user%GW_MODEL, ovid%SatFrac, 'SatFrac', out%SatFrac, REAL(ssnow%satfrac, 4), ranges%SatFrac, patchout%SatFrac, out_settings) + +! block below inserted by rk4417 - phase2 + IF((output%soil .OR. output%SMP) .and. cable_user%GW_MODEL) THEN + !write(*,*) 'Qinfl' !MDeck + ! Add current timestep's value to total of temporary output variable: + out%SMP = out%SMP + REAL(ssnow%smp, 4) + IF(out_settings%writenow) THEN ! modified "IF(writenow) THEN" to "IF(out_settings%writenow) THEN" - rk4417 - phase2 + out%SMP = out%SMP / REAL(output%interval, 4) + ! Write value to file: +! CALL write_ovar(out_timestep, ncid_out, ovid%SMP, 'SMP', & ! write_ovar call here will not compile anymore because of recent changes made by others in cable_write.F90, needs to be adapted - rk4417 -phase2 +! out%SMP, (/-1.0e36,1.0e36/), patchout%SMP, 'soil', met) + ! Reset temporary output variable: + out%SMP = 0.0 + END IF + END IF + + IF(gw_params%bc_hysteresis .and. cable_user%GW_MODEL) THEN + !write(*,*) 'Qinfl' !MDeck + ! Add current timestep's value to total of temporary output variable: + out%smp_hys = out%smp_hys + REAL(ssnow%smp_hys, 4) + out%wb_hys = out%wb_hys + REAL(ssnow%wb_hys, 4) + out%ssat_hys = out%ssat_hys + REAL(ssnow%ssat_hys, 4) + out%watr_hys = out%watr_hys + REAL(ssnow%watr_hys, 4) + out%hys_fac = out%hys_fac + REAL(ssnow%hys_fac, 4) + + IF(out_settings%writenow) THEN ! modified "IF(writenow) THEN" to "IF(out_settings%writenow) THEN" - rk4417 - phase2 + out%smp_hys = out%smp_hys / REAL(output%interval, 4) + out%wb_hys = out%wb_hys / REAL(output%interval, 4) + out%ssat_hys = out%ssat_hys/ REAL(output%interval, 4) + out%watr_hys = out%watr_hys/ REAL(output%interval, 4) + out%hys_fac = out%hys_fac / REAL(output%interval, 4) + + ! Write value to file: +! CALL write_ovar(out_timestep, ncid_out, ovid%SMP_hys, 'SMP_hys', & ! write_ovar call here will not compile anymore because of recent changes made by others in cable_write.F90, needs to be adapted - rk4417 -phase2 +! out%SMP_hys, (/-1.0e36,1.0e36/), patchout%SMP_hys, 'soil', met) + +! CALL write_ovar(out_timestep, ncid_out, ovid%WB_hys, 'WB_hys', & ! write_ovar call here will not compile anymore because of recent changes made by others in cable_write.F90, needs to be adapted - rk4417 -phase2 +! out%WB_hys, (/-1.0e36,1.0e36/), patchout%wb_hys, 'soil', met) + +! CALL write_ovar(out_timestep, ncid_out, ovid%SSAT_hys, 'SSAT_hys', & ! write_ovar call here will not compile anymore because of recent changes made by others in cable_write.F90, needs to be adapted - rk4417 -phase2 +! out%SSAT_hys, (/-1.0e36,1.0e36/), patchout%ssat_hys, 'soil', met) + +! CALL write_ovar(out_timestep, ncid_out, ovid%WATR_hys, 'WATR_hys', & ! write_ovar call here will not compile anymore because of recent changes made by others in cable_write.F90, needs to be adapted - rk4417 -phase2 +! out%WATR_hys, (/-1.0e36,1.0e36/), patchout%watr_hys, 'soil', met) + +! CALL write_ovar(out_timestep, ncid_out, ovid%hys_fac, 'hys_fac', & ! write_ovar call here will not compile anymore because of recent changes made by others in cable_write.F90, needs to be adapted - rk4417 -phase2 +! out%hys_fac, (/-1.0e36,1.0e36/), patchout%hys_fac, 'soil', met) + + ! Reset temporary output variable: + out%smp_hys = 0.0 + out%wb_hys =0.0 + out%ssat_hys =0.0 + out%watr_hys =0.0 + out%hys_fac =0.0 + END IF + END IF +! end of block - rk4417 - phase2 + ! recharge rate CALL generate_out_write_acc(output%Qrecharge, ovid%Qrecharge, 'Qrecharge', out%Qrecharge, REAL(ssnow%Qrecharge, 4), ranges%Qrecharge, patchout%Qrecharge, out_settings) @@ -1969,7 +2239,7 @@ SUBROUTINE write_output(dels, ktau, met, canopy, casaflux, casapool, casamet, ss IF (cable_user%POPLUC) THEN temp_acc = -(casaflux%Crsoil - casaflux%cnpp & - casapool%dClabiledt)/86400.0 & - /1.201E-5 !- & + /1.201E-5 !- & !REAL((casaflux%FluxCtohwp + casaflux%FluxCtoclear )/86400.0 & !/ 1.201E-5, 4) ELSE @@ -2286,8 +2556,9 @@ SUBROUTINE create_restart(logn, dels, ktau, soil, veg, ssnow, canstoID, albsoilsnID, gammzzID, tggsnID, sghfluxID, & ghfluxID, runoffID, rnof1ID, rnof2ID, gaID, dgdtgID, & fevID, fesID, fhsID, wbtot0ID, osnowd0ID, cplantID, & - csoilID, tradID, albedoID, gwID + csoilID, tradID, albedoID, gwID, subdzID ! added subdzID - rk4417 - phase2 INTEGER :: h0ID, snowliqID, SID, TsurfaceID, scondsID, nsnowID, TsoilID + INTEGER :: hys(6) ! inserted by rk4417 - phase2 CHARACTER(LEN=10) :: todaydate, nowtime ! used to timestamp netcdf file ! CHARACTER :: FRST_OUT*100, CYEAR*4 CHARACTER :: FRST_OUT*200, CYEAR*4 @@ -2298,6 +2569,7 @@ SUBROUTINE create_restart(logn, dels, ktau, soil, veg, ssnow, WRITE(logn, '(A24)') ' Writing restart file...' frst_out = TRIM(filename%restart_out) + ! Look for explicit restart file (netCDF). If not, asssume input is path IF ( INDEX(TRIM(frst_out),'.nc',BACK=.TRUE.) .NE. LEN_TRIM(frst_out)-2 ) THEN WRITE( CYEAR,FMT="(I4)" ) CurYear + 1 @@ -2541,6 +2813,7 @@ SUBROUTINE create_restart(logn, dels, ktau, soil, veg, ssnow, !$ CALL define_ovar(ncid_restart, rpid%swilt, 'swilt', '-', & !$ 'Fraction of soil volume which is water @ wilting point', & !$ .TRUE., 'real', 0, 0, 0, mpID, dummy, .TRUE.) + ! zse (depth of each soil layer): ok = NF90_DEF_VAR(ncid_restart, 'zse', NF90_FLOAT, (/soilID/), rpid%zse) IF (ok /= NF90_NOERR) CALL nc_abort & @@ -2570,6 +2843,31 @@ SUBROUTINE create_restart(logn, dels, ktau, soil, veg, ssnow, !$ CALL define_ovar(ncid_restart, rpid%rs20, 'rs20', '-', & !$ 'Soil respiration coefficient at 20C', & !$ .TRUE., 'real', 0, 0, 0, mpID, dummy, .TRUE.) + +! inserted block below - rk4417 - phase2 + CALL define_ovar(ncid_restart, rpid%froot, 'froot', '-', & + 'Fraction of roots in each soil layer', & + .TRUE., soilID, 'soil', 0, 0, 0, mpID, dummy, .TRUE.) + CALL define_ovar(ncid_restart, rpid%bch, 'bch', '-', & + 'Parameter b, Campbell eqn 1985', & + .TRUE., 'real', 0, 0, 0, mpID, dummy, .TRUE.) + CALL define_ovar(ncid_restart, rpid%hyds, 'hyds', 'mm/s', & ! MMY m/s->mm/s & + 'Hydraulic conductivity @ saturation', & + .TRUE., 'real', 0, 0, 0, mpID, dummy, .TRUE.) + CALL define_ovar(ncid_restart, rpid%sucs, 'sucs', 'mm', & ! MMY m->mm & + 'Suction @ saturation', .TRUE., & + 'real', 0, 0, 0, mpID, dummy, .TRUE.) + CALL define_ovar(ncid_restart, rpid%css, 'css', 'J/kg/C', & + 'Heat capacity of soil minerals', & + .TRUE., 'real', 0, 0, 0, mpID, dummy, .TRUE.) + CALL define_ovar(ncid_restart, rpid%rhosoil, 'rhosoil', 'kg/m^3', & + 'Density of soil minerals', & + .TRUE., 'real', 0, 0, 0, mpID, dummy, .TRUE.) + CALL define_ovar(ncid_restart, rpid%rs20, 'rs20', '-', & + 'Soil respiration coefficient at 20C', & + .TRUE., 'real', 0, 0, 0, mpID, dummy, .TRUE.) +! end of block - rk4417 - phase2 + CALL define_ovar(ncid_restart, rpid%albsoil, 'albsoil', '-', & 'Soil reflectance', .TRUE., & radID, 'radiation', 0, 0, 0, mpID, dummy, .TRUE.) @@ -2653,14 +2951,19 @@ SUBROUTINE create_restart(logn, dels, ktau, soil, veg, ssnow, !$ CALL define_ovar(ncid_restart, rpid%za_tq, 'za_tq', 'm', & !$ 'Reference height (lowest atm. model layer) for scalars', & !$ .TRUE., 'real', 0, 0, 0, mpID, dummy, .TRUE.) + CALL define_ovar(ncid_restart, gwID, 'GWwb', 'mm3/mm3','GW water content', & .TRUE., 'real', 0, 0, 0, mpID, dummy, .TRUE.) + ! CALL define_ovar(ncid_restart, subdzID, 'sublayer_dz', 'm','depth of viscous sublayer',& + ! .TRUE., 'real', 0, 0, 0, mpID, dummy, .TRUE.) + !$ IF(cable_user%SOIL_STRUC=='sli'.OR.cable_user%FWSOIL_SWITCH=='Haverd2013') THEN !$ CALL define_ovar(ncid_restart,rpid%gamma,'gamma','-', & !$ 'Parameter in root efficiency function (Lai and Katul 2000)', & !$ .TRUE.,'real',0,0,0,mpID,dummy,.TRUE.) !$ ENDIF + ! Soil-Litter-Iso soil model IF(cable_user%SOIL_STRUC=='sli') THEN ! Parameters for SLI: @@ -2679,6 +2982,7 @@ SUBROUTINE create_restart(logn, dels, ktau, soil, veg, ssnow, !$ CALL define_ovar(ncid_restart,rpid%F10,'F10','-', & !$ 'Fraction of roots in top 10 cm', & !$ .TRUE.,'real',0,0,0,mpID,dummy,.TRUE.) + ! Variables for SLI: CALL define_ovar(ncid_restart,SID,'S','-',& 'Fractional soil moisture content relative to saturated value', & @@ -2703,6 +3007,26 @@ SUBROUTINE create_restart(logn, dels, ktau, soil, veg, ssnow, .TRUE.,'real',0,0,0,mpID,dummy,.TRUE.) END IF ! SLI soil model +! inserted block below - rk4417 - phase2 + if (cable_user%gw_model) then + CALL define_ovar(ncid_restart,hys(1),'wb_hys','-',& + 'water (volumetric) at dry/wet switch', & + .TRUE.,soilID,'soil',0,0,0,mpID,dummy,.TRUE.) + CALL define_ovar(ncid_restart,hys(2),'smp_hys','-',& + 'smp [mm] at dry/wet switch', & + .TRUE.,soilID,'soil',0,0,0,mpID,dummy,.TRUE.) + CALL define_ovar(ncid_restart,hys(3),'ssat_hys','-',& + 'ssat water (volumetric) from hyst', & + .TRUE.,soilID,'soil',0,0,0,mpID,dummy,.TRUE.) + CALL define_ovar(ncid_restart,hys(4),'watr_hys','-',& + 'ssat water (volumetric) from hyst', & + .TRUE.,soilID,'soil',0,0,0,mpID,dummy,.TRUE.) + CALL define_ovar(ncid_restart,hys(5),'hys_fac','-',& + 'water (volumetric) at dry/wet switch', & + .TRUE.,soilID,'soil',0,0,0,mpID,dummy,.TRUE.) + end if +! end of block - rk4417 - phase2 + ! Write global attributes for file: CALL DATE_AND_TIME(todaydate, nowtime) todaydate = todaydate(1:4)//'/'//todaydate(5:6)//'/'//todaydate(7:8) @@ -2802,6 +3126,39 @@ SUBROUTINE create_restart(logn, dels, ktau, soil, veg, ssnow, !$ CALL check_and_write(output_var, rpid%froot, 'froot', REAL(veg%froot, 4), & !$ ranges%froot, patchout_var, out_settings) +! inserted block below - rk4417 - phase2 (same as commented one above, I know) +! CALL write_ovar (ncid_restart, rpid%bch, 'bch', REAL(soil%bch, 4), & ! write_ovar call here will not compile anymore because of recent changes made by others in cable_write.F90, needs to be adapted - rk4417 -phase2 +! ranges%bch, .TRUE., 'real', .TRUE.) +! CALL write_ovar (ncid_restart, rpid%clay, 'clay', REAL(soil%clay, 4), & ! write_ovar call here will not compile anymore because of recent changes made by others in cable_write.F90, needs to be adapted - rk4417 -phase2 +! ranges%clay, .TRUE., 'real', .TRUE.) +! CALL write_ovar (ncid_restart, rpid%sand, 'sand', REAL(soil%sand, 4), & ! write_ovar call here will not compile anymore because of recent changes made by others in cable_write.F90, needs to be adapted - rk4417 -phase2 +! ranges%sand, .TRUE., 'real', .TRUE.) +! CALL write_ovar (ncid_restart, rpid%silt, 'silt', REAL(soil%silt, 4), & ! write_ovar call here will not compile anymore because of recent changes made by others in cable_write.F90, needs to be adapted - rk4417 -phase2 +! ranges%silt, .TRUE., 'real', .TRUE.) +! CALL write_ovar (ncid_restart, rpid%css, 'css', REAL(soil%css, 4), & ! write_ovar call here will not compile anymore because of recent changes made by others in cable_write.F90, needs to be adapted - rk4417 -phase2 +! ranges%css, .TRUE., 'real', .TRUE.) +! CALL write_ovar (ncid_restart, rpid%rhosoil, 'rhosoil', & ! write_ovar call here will not compile anymore because of recent changes made by others in cable_write.F90, needs to be adapted - rk4417 -phase2 +! REAL(soil%rhosoil,4), ranges%rhosoil, .TRUE., 'real', & +! .TRUE.) +! CALL write_ovar (ncid_restart, rpid%hyds, 'hyds', REAL(soil%hyds, 4), & ! write_ovar call here will not compile anymore because of recent changes made by others in cable_write.F90, needs to be adapted - rk4417 -phase2 +! ranges%hyds, .TRUE., 'real', .TRUE.) +! CALL write_ovar (ncid_restart, rpid%sucs, 'sucs', REAL(soil%sucs, 4), & ! write_ovar call here will not compile anymore because of recent changes made by others in cable_write.F90, needs to be adapted - rk4417 -phase2 +! ranges%sucs, .TRUE., 'real', .TRUE.) +! CALL write_ovar (ncid_restart, rpid%rs20, 'rs20', REAL(veg%rs20, 4), & ! write_ovar call here will not compile anymore because of recent changes made by others in cable_write.F90, needs to be adapted - rk4417 -phase2 +! ranges%rs20, .TRUE., 'real', .TRUE.) +! CALL write_ovar (ncid_restart, rpid%ssat, 'ssat', REAL(soil%ssat, 4), & ! write_ovar call here will not compile anymore because of recent changes made by others in cable_write.F90, needs to be adapted - rk4417 -phase2 +! ranges%ssat, .TRUE., 'real', .TRUE.) +! CALL write_ovar (ncid_restart, rpid%sfc, 'sfc', REAL(soil%sfc, 4), & ! write_ovar call here will not compile anymore because of recent changes made by others in cable_write.F90, needs to be adapted - rk4417 -phase2 +! ranges%sfc, .TRUE., 'real', .TRUE.) +! CALL write_ovar (ncid_restart, rpid%swilt, 'swilt', REAL(soil%swilt, 4), & ! write_ovar call here will not compile anymore because of recent changes made by others in cable_write.F90, needs to be adapted - rk4417 -phase2 +! ranges%swilt, .TRUE., 'real', .TRUE.) + + ! Soil dimensioned variables/parameters: + +! CALL write_ovar (ncid_restart, rpid%froot, 'froot', REAL(veg%froot, 4), & ! write_ovar call here will not compile anymore because of recent changes made by others in cable_write.F90, needs to be adapted - rk4417 -phase2 +! ranges%froot, .TRUE., 'soil', .TRUE.) +! end of block - rk4417 - phase2 + !~ ssnow !~~ Soil dimensioned variables/parameters: out_settings%dimswitch = "soil" @@ -2898,6 +3255,65 @@ SUBROUTINE create_restart(logn, dels, ktau, soil, veg, ssnow, !$ ranges%za, patchout_var, out_settings) !$ CALL check_and_write(output_var, rpid%za_tq, 'za_tq', REAL(rough%za_tq, 4), & !$ ranges%za, patchout_var, out_settings) + +! inserted block below - rk4417 - phase2 (same as commented one above, I know) +! CALL write_ovar (ncid_restart, rpid%canst1, 'canst1', REAL(veg%canst1, 4), & ! write_ovar call here will not compile anymore because of recent changes made by others in cable_write.F90, needs to be adapted - rk4417 -phase2 +! ranges%canst1, .TRUE., 'real', .TRUE.) +! CALL write_ovar (ncid_restart, rpid%dleaf, 'dleaf', REAL(veg%dleaf, 4), & ! write_ovar call here will not compile anymore because of recent changes made by others in cable_write.F90, needs to be adapted - rk4417 -phase2 +! ranges%dleaf, .TRUE., 'real', .TRUE.) +! CALL write_ovar (ncid_restart, rpid%ejmax, 'ejmax', REAL(veg%ejmax, 4), & ! write_ovar call here will not compile anymore because of recent changes made by others in cable_write.F90, needs to be adapted - rk4417 -phase2 +! ranges%ejmax, .TRUE., 'real', .TRUE.) +! CALL write_ovar (ncid_restart, rpid%vcmax, 'vcmax', REAL(veg%vcmax, 4), & ! write_ovar call here will not compile anymore because of recent changes made by others in cable_write.F90, needs to be adapted - rk4417 -phase2 +! ranges%vcmax, .TRUE., 'real', .TRUE.) +! CALL write_ovar (ncid_restart, rpid%frac4, 'frac4', REAL(veg%frac4, 4), & ! write_ovar call here will not compile anymore because of recent changes made by others in cable_write.F90, needs to be adapted - rk4417 -phase2 +! ranges%frac4, .TRUE., 'real', .TRUE.) +! CALL write_ovar (ncid_restart, rpid%hc, 'hc', REAL(veg%hc, 4), & ! write_ovar call here will not compile anymore because of recent changes made by others in cable_write.F90, needs to be adapted - rk4417 -phase2 +! ranges%hc, .TRUE., 'real', .TRUE.) +! CALL write_ovar (ncid_restart, rpid%rp20, 'rp20', REAL(veg%rp20, 4), & ! write_ovar call here will not compile anymore because of recent changes made by others in cable_write.F90, needs to be adapted - rk4417 -phase2 +! ranges%rp20, .TRUE., 'real', .TRUE.) +! CALL write_ovar (ncid_restart, rpid%g0, 'g0', REAL(veg%g0, 4), & ! write_ovar call here will not compile anymore because of recent changes made by others in cable_write.F90, needs to be adapted - rk4417 -phase2 +! ranges%g0, .TRUE., 'real', .TRUE.) ! Ticket #56 +! CALL write_ovar (ncid_restart, rpid%g1, 'g1', REAL(veg%g1, 4), & ! write_ovar call here will not compile anymore because of recent changes made by others in cable_write.F90, needs to be adapted - rk4417 -phase2 +! ranges%g1, .TRUE., 'real', .TRUE.) ! Ticket #56 +! CALL write_ovar (ncid_restart, rpid%rpcoef, 'rpcoef', REAL(veg%rpcoef, 4), & ! write_ovar call here will not compile anymore because of recent changes made by others in cable_write.F90, needs to be adapted - rk4417 -phase2 +! ranges%rpcoef, .TRUE., 'real', .TRUE.) +! CALL write_ovar (ncid_restart, rpid%shelrb, 'shelrb', REAL(veg%shelrb, 4), & ! write_ovar call here will not compile anymore because of recent changes made by others in cable_write.F90, needs to be adapted - rk4417 -phase2 +! ranges%shelrb, .TRUE., 'real', .TRUE.) +! CALL write_ovar (ncid_restart, rpid%xfang, 'xfang', REAL(veg%xfang, 4), & ! write_ovar call here will not compile anymore because of recent changes made by others in cable_write.F90, needs to be adapted - rk4417 -phase2 +! ranges%xfang, .TRUE., 'real', .TRUE.) +! CALL write_ovar (ncid_restart, rpid%wai, 'wai', REAL(veg%wai, 4), & ! write_ovar call here will not compile anymore because of recent changes made by others in cable_write.F90, needs to be adapted - rk4417 -phase2 +! ranges%wai, .TRUE., 'real', .TRUE.) +! CALL write_ovar (ncid_restart, rpid%vegcf, 'vegcf', REAL(veg%vegcf, 4), & ! write_ovar call here will not compile anymore because of recent changes made by others in cable_write.F90, needs to be adapted - rk4417 -phase2 +! ranges%vegcf, .TRUE., 'real', .TRUE.) +! CALL write_ovar (ncid_restart, rpid%extkn, 'extkn', REAL(veg%extkn, 4), & ! write_ovar call here will not compile anymore because of recent changes made by others in cable_write.F90, needs to be adapted - rk4417 -phase2 +! ranges%extkn, .TRUE., 'real', .TRUE.) +! CALL write_ovar (ncid_restart, rpid%tminvj, 'tminvj', REAL(veg%tminvj, 4), & ! write_ovar call here will not compile anymore because of recent changes made by others in cable_write.F90, needs to be adapted - rk4417 -phase2 +! ranges%tminvj, .TRUE., 'real', .TRUE.) +! CALL write_ovar (ncid_restart, rpid%tmaxvj, 'tmaxvj', REAL(veg%tmaxvj, 4), & ! write_ovar call here will not compile anymore because of recent changes made by others in cable_write.F90, needs to be adapted - rk4417 -phase2 +! ranges%tmaxvj, .TRUE., 'real', .TRUE.) +! CALL write_ovar (ncid_restart, rpid%vbeta, 'vbeta', REAL(veg%vbeta, 4), & ! write_ovar call here will not compile anymore because of recent changes made by others in cable_write.F90, needs to be adapted - rk4417 -phase2 +! ranges%vbeta, .TRUE., 'real', .TRUE.) +! CALL write_ovar (ncid_restart, rpid%xalbnir, 'xalbnir', & ! write_ovar call here will not compile anymore because of recent changes made by others in cable_write.F90, needs to be adapted - rk4417 -phase2 +! REAL(veg%xalbnir, 4), ranges%xalbnir, .TRUE., & +! 'real', .TRUE.) +! CALL write_ovar (ncid_restart, rpid%tmaxvj, 'tmaxvj', REAL(veg%tmaxvj, 4), & ! write_ovar call here will not compile anymore because of recent changes made by others in cable_write.F90, needs to be adapted - rk4417 -phase2 +! ranges%tmaxvj, .TRUE., 'real', .TRUE.) +! ok = NF90_PUT_VAR(ncid_restart, rpid%ratecp, REAL(bgc%ratecp, 4)) +! IF(ok /= NF90_NOERR) CALL nc_abort(ok, & +! 'Error writing ratecp parameter to ' & +! //TRIM(frst_out)// '(SUBROUTINE create_restart)') +! ok = NF90_PUT_VAR(ncid_restart, rpid%ratecs, REAL(bgc%ratecs, 4)) +! IF(ok /= NF90_NOERR) CALL nc_abort(ok, & +! 'Error writing ratecs parameter to ' & +! //TRIM(frst_out)// '(SUBROUTINE create_restart)') +! CALL write_ovar (ncid_restart, rpid%meth, 'meth', REAL(veg%meth, 4), & ! write_ovar call here will not compile anymore because of recent changes made by others in cable_write.F90, needs to be adapted - rk4417 -phase2 +! ranges%meth, .TRUE., 'integer', .TRUE.) +! CALL write_ovar (ncid_restart, rpid%za_uv, 'za_uv', REAL(rough%za_uv, 4), & ! write_ovar call here will not compile anymore because of recent changes made by others in cable_write.F90, needs to be adapted - rk4417 -phase2 +! ranges%za, .TRUE., 'real', .TRUE.) +! CALL write_ovar (ncid_restart, rpid%za_tq, 'za_tq', REAL(rough%za_tq, 4), & ! write_ovar call here will not compile anymore because of recent changes made by others in cable_write.F90, needs to be adapted - rk4417 -phase2 +! ranges%za, .TRUE., 'real', .TRUE.) +! end of block - rk4417 - phase2 + out_settings%dimswitch = "r2" CALL check_and_write(output_var, dgdtgID, 'dgdtg', REAL(canopy%dgdtg, 4), & ranges%default_l, patchout_var, out_settings) @@ -2907,6 +3323,7 @@ SUBROUTINE create_restart(logn, dels, ktau, soil, veg, ssnow, out_settings%dimswitch = "real" CALL check_and_write(output_var, gwID, 'GWwb', REAL(ssnow%GWwb, 4), & ranges%GWwb, patchout_var, out_settings) + CALL check_and_write(output_var, tssID, 'tss', REAL(ssnow%tss, 4), & ranges%default_l, patchout_var, out_settings) CALL check_and_write(output_var, ssdnnID, 'ssdnn', REAL(ssnow%ssdnn, 4), & @@ -2953,11 +3370,21 @@ SUBROUTINE create_restart(logn, dels, ktau, soil, veg, ssnow, CALL check_and_write(output_var, tradID, 'trad', & REAL(rad%trad, 4), ranges%RadT, patchout_var, out_settings) +! inserted call below - rk4417 - phase2 +! CALL write_ovar (ncid_restart, subdzID, 'sublayer_dz', REAL(canopy%sublayer_dz, 4), & ! write_ovar call here will not compile anymore because of recent changes made by others in cable_write.F90, needs to be adapted - rk4417 -phase2 +! (/0.0,1.0e2/), .TRUE., 'real', .TRUE.) + + !$ IF (cable_user%SOIL_STRUC == 'sli' .OR. cable_user%FWSOIL_SWITCH == 'Haverd2013') THEN !$ CALL check_and_write(output_var, rpid%gamma, 'gamma', & !$ REAL(veg%gamma, 4), ranges%default_s, patchout_var, out_settings) !$ END IF !$ +! inserted block below - rk4417 - phase2 (same as commented one above, I know) +! IF(cable_user%SOIL_STRUC=='sli'.OR.cable_user%FWSOIL_SWITCH=='Haverd2013') THEN +! CALL write_ovar (ncid_restart,rpid%gamma,'gamma', & ! write_ovar call here will not compile anymore because of recent changes made by others in cable_write.F90, needs to be adapted - rk4417 -phase2 +! REAL(veg%gamma,4),(/-99999.0,99999.0/),.TRUE.,'real',.TRUE.) +! ENDIF IF (cable_user%SOIL_STRUC == 'sli') THEN ! Write SLI parameters: @@ -2989,7 +3416,57 @@ SUBROUTINE create_restart(logn, dels, ktau, soil, veg, ssnow, ranges%default_s, patchout_var, out_settings) CALL check_and_write(output_var, scondsID, 'sconds', REAL(ssnow%sconds, 4), & ranges%default_s, patchout_var, out_settings) - END IF + END IF + + +! the endif block below is what I have for the one above - rk4417 - phase2 +! IF(cable_user%SOIL_STRUC=='sli') THEN +! ! Write SLI parameters: +! +! CALL write_ovar (ncid_restart,rpid%nhorizons,'nhorizons', & +! REAL(soil%nhorizons,4),(/-99999.0,99999.0/),.TRUE.,'integer',.TRUE.) +! CALL write_ovar (ncid_restart,rpid%ishorizon,'ishorizon', & +! REAL(soil%ishorizon,4),(/-99999.0,99999.0/),.TRUE.,'soil',.TRUE.) +! CALL write_ovar (ncid_restart,rpid%clitt,'clitt', & +! REAL(veg%clitt,4),(/-99999.0,99999.0/),.TRUE.,'real',.TRUE.) +! CALL write_ovar (ncid_restart,rpid%ZR,'ZR', & +! REAL(veg%ZR,4),(/-99999.0,99999.0/),.TRUE.,'real',.TRUE.) +! CALL write_ovar (ncid_restart,rpid%F10,'F10', & +! REAL(veg%F10,4),(/-99999.0,99999.0/),.TRUE.,'real',.TRUE.) +! +! ! Write SLI variables: +! CALL write_ovar (ncid_restart,SID,'S',REAL(ssnow%S,4), & +! (/0.0,1.5/),.TRUE.,'soil',.TRUE.) +! CALL write_ovar (ncid_restart,TsoilID,'Tsoil',REAL(ssnow%Tsoil,4), & +! (/-100.0,100.0/),.TRUE.,'soil',.TRUE.) +! CALL write_ovar (ncid_restart,snowliqID,'snowliq',REAL(ssnow%snowliq,4), & +! (/-99999.0,99999.0/),.TRUE.,'snow',.TRUE.) +! CALL write_ovar (ncid_restart,scondsID,'sconds',REAL(ssnow%sconds,4), & +! (/-99999.0,99999.0/),.TRUE.,'snow',.TRUE.) +! CALL write_ovar (ncid_restart,h0ID,'h0',REAL(ssnow%h0,4), & +! (/-99999.0,99999.0/),.TRUE.,'real',.TRUE.) +! CALL write_ovar (ncid_restart,nsnowID,'nsnow',REAL(ssnow%nsnow,4), & +! (/-99999.0,99999.0/),.TRUE.,'integer',.TRUE.) +! CALL write_ovar (ncid_restart,TsurfaceID,'Tsurface',REAL(ssnow%Tsurface,4), & +! (/-99999.0,99999.0/),.TRUE.,'real',.TRUE.) +! +! END IF ! endif block - rk4417 - phase2 + + + +! inserted IF block below - rk4417 - phase2 +! IF (cable_user%gw_model) THEN +! CALL write_ovar (ncid_restart,hys(1),'wb_hys',REAL(ssnow%wb_hys,4), & ! write_ovar call here will not compile anymore because of recent changes made by others in cable_write.F90, needs to be adapted - rk4417 -phase2 +! (/0.0,1.0/),.TRUE.,'soil',.TRUE.) +! CALL write_ovar (ncid_restart,hys(2),'smp_hys',REAL(ssnow%smp_hys,4), & ! write_ovar call here will not compile anymore because of recent changes made by others in cable_write.F90, needs to be adapted - rk4417 -phase2 +! (/-1.0e10,1.0e10/),.TRUE.,'soil',.TRUE.) +! CALL write_ovar (ncid_restart,hys(3),'ssat_hys',REAL(ssnow%ssat_hys,4), & ! write_ovar call here will not compile anymore because of recent changes made by others in cable_write.F90, needs to be adapted - rk4417 -phase2 +! (/0.0,1.0/),.TRUE.,'soil',.TRUE.) +! CALL write_ovar (ncid_restart,hys(4),'watr_hys',REAL(ssnow%watr_hys,4), & ! write_ovar call here will not compile anymore because of recent changes made by others in cable_write.F90, needs to be adapted - rk4417 -phase2 +! (/0.0,1.0/),.TRUE.,'soil',.TRUE.) +! CALL write_ovar (ncid_restart,hys(5),'watr_hys',REAL(ssnow%hys_fac,4), & ! write_ovar call here will not compile anymore because of recent changes made by others in cable_write.F90, needs to be adapted - rk4417 -phase2 +! (/0.0,1.0/),.TRUE.,'soil',.TRUE.) +! END IF ! Close restart file ok = NF90_CLOSE(ncid_restart) diff --git a/src/offline/cable_parameters.F90 b/src/offline/cable_parameters.F90 index b6133f64f..2f6d4e055 100644 --- a/src/offline/cable_parameters.F90 +++ b/src/offline/cable_parameters.F90 @@ -59,7 +59,7 @@ MODULE cable_param_module USE phenvariable USE cable_abort_module USE cable_IO_vars_module - USE cable_common_module, ONLY: cable_user, gw_params + USE cable_common_module, ONLY: cable_user, gw_params, filename ! added 'filename' for now - rk4417 - phase2 USE cable_pft_params_mod USE cable_soil_params_mod USE CABLE_LUC_EXPT, ONLY: LUC_EXPT, LUC_EXPT_TYPE, LUC_EXPT_SET_TILES @@ -67,9 +67,8 @@ MODULE cable_param_module PRIVATE PUBLIC get_default_params, write_default_params, derived_parameters, & check_parameter_values, report_parameters, parID_type, & - write_cnp_params, consistency_ice_veg_soil - INTEGER :: patches_in_parfile=4 ! # patches in default global parameter - ! file + write_cnp_params, consistency_ice_veg_soil, GWspatialParameters ! GWspatialParameters added by rk4417 - phase2 + INTEGER :: patches_in_parfile=4 ! # patches in default global parameter file ! MMY??? CHARACTER(LEN=4) :: classification @@ -105,22 +104,22 @@ MODULE cable_param_module REAL, DIMENSION(:, :), ALLOCATABLE :: insilt REAL, DIMENSION(:, :), ALLOCATABLE :: insand - !MD temp vars for reading in aquifer properties - LOGICAL :: found_explicit_gw_parameters - REAL, DIMENSION(:, :), ALLOCATABLE :: inGWbch - REAL, DIMENSION(:, :), ALLOCATABLE :: inGWssat - REAL, DIMENSION(:, :), ALLOCATABLE :: inGWhyds - REAL, DIMENSION(:, :), ALLOCATABLE :: inGWsucs - REAL, DIMENSION(:, :), ALLOCATABLE :: inGWrhosoil - REAL, DIMENSION(:, :), ALLOCATABLE :: inGWclay - REAL, DIMENSION(:, :), ALLOCATABLE :: inGWsilt - REAL, DIMENSION(:, :), ALLOCATABLE :: inGWsand - REAL, DIMENSION(:, :), ALLOCATABLE :: inGWWatr - REAL, DIMENSION(:, :), ALLOCATABLE :: inWatr - REAL, DIMENSION(:, :), ALLOCATABLE :: inSlope - REAL, DIMENSION(:, :), ALLOCATABLE :: inGWdz - REAL, DIMENSION(:, :), ALLOCATABLE :: inSlopeSTD - REAL, DIMENSION(:, :), ALLOCATABLE :: inORG +! !MD temp vars for reading in aquifer properties ! block commented out by rk4417 - phase2 +! LOGICAL :: found_explicit_gw_parameters +! REAL, DIMENSION(:, :), ALLOCATABLE :: inGWbch +! REAL, DIMENSION(:, :), ALLOCATABLE :: inGWssat +! REAL, DIMENSION(:, :), ALLOCATABLE :: inGWhyds +! REAL, DIMENSION(:, :), ALLOCATABLE :: inGWsucs +! REAL, DIMENSION(:, :), ALLOCATABLE :: inGWrhosoil +! REAL, DIMENSION(:, :), ALLOCATABLE :: inGWclay +! REAL, DIMENSION(:, :), ALLOCATABLE :: inGWsilt +! REAL, DIMENSION(:, :), ALLOCATABLE :: inGWsand +! REAL, DIMENSION(:, :), ALLOCATABLE :: inGWWatr +! REAL, DIMENSION(:, :), ALLOCATABLE :: inWatr +! REAL, DIMENSION(:, :), ALLOCATABLE :: inSlope +! REAL, DIMENSION(:, :), ALLOCATABLE :: inGWdz +! REAL, DIMENSION(:, :), ALLOCATABLE :: inSlopeSTD +! REAL, DIMENSION(:, :), ALLOCATABLE :: inORG ! vars intro for Ticket #27 INTEGER, DIMENSION(:, :), ALLOCATABLE :: inSoilColor @@ -156,13 +155,21 @@ SUBROUTINE get_default_params(logn, vegparmnew, LUC_EXPT) INTEGER :: nlon INTEGER :: nlat +! Two calls below inserted by rk4417 - phase2 + ! Get parameter values for all default veg and soil types: + !CALL get_type_parameters(logn, vegparmnew, classification) + CALL cable_pft_params() + CALL cable_soil_params() + WRITE(logn,*) ' Reading grid info from ', TRIM(filename%type) WRITE(logn,*) ' And assigning C4 fraction according to veg classification.' WRITE(logn,*) IF(exists%patch) THEN - CALL read_gridinfo(nlon,nlat,nmetpatches)!, & + CALL read_gridinfo(nlon,nlat,nmetpatches)!, & ! MMY??? +! print *, "MMY in get_default_params IF (exists%patch) == true" ! MMY testing point ELSE - CALL read_gridinfo(nlon,nlat,npatch) + CALL read_gridinfo(nlon,nlat,npatch) ! note that in MMY code only the else body exists -- rk4417 ! MMY??? +! print *, "MMY in get_default_params IF (exists%patch) == false" ! MMY testing point END IF ! Overwrite veg type and inital patch frac with land-use info @@ -172,22 +179,30 @@ SUBROUTINE get_default_params(logn, vegparmnew, LUC_EXPT) ENDIF - IF (soilparmnew) THEN + IF (soilparmnew) THEN PRINT *, 'Use spatially-specific soil properties; ', nlon, nlat WRITE(logn,*) 'Use spatially-specific soil properties; ', nlon, nlat CALL spatialSoil(nlon, nlat, logn) ENDIF - ! Get parameter values for all default veg and soil types: - !CALL get_type_parameters(logn, vegparmnew, classification) - CALL cable_pft_params() - CALL cable_soil_params() +! Block below moved to the top - rk4417 - phase2 +! ! Get parameter values for all default veg and soil types: +! !CALL get_type_parameters(logn, vegparmnew, classification) +! CALL cable_pft_params() +! CALL cable_soil_params() + ! include prescribed soil colour in determining albedo - Ticket #27 IF (calcsoilalbedo) THEN CALL read_soilcolor(logn) END IF +! line below inserted by rk4417 - phase2 + IF (cable_user%force_npatches_as .GT. 0) npatch=cable_user%force_npatches_as +! MMY@13April force_npatches_as seems a new flag read from cable.nml +! the default value is -1 set in TYPE kbl_user_switches in cable_common +! TYPE kbl_user_switches was moved from cable_common_module to cable_runtime_opts_mod - rk4417 - phase2 + ! count to obtain 'landpt', 'max_vegpatches' and 'mp' CALL countPatch(nlon, nlat, npatch) @@ -234,7 +249,7 @@ SUBROUTINE read_gridinfo(nlon, nlat, npatch) INTEGER :: ii, jj, kk,pp INTEGER, DIMENSION(:, :), ALLOCATABLE :: idummy REAL, DIMENSION(:, :), ALLOCATABLE :: rdummy - REAL, DIMENSION(:, :, :), ALLOCATABLE :: r3dum, r3dum2, r3dum3, r3dum4 + REAL, DIMENSION(:, :, :), ALLOCATABLE :: r3dum, r3dum2 ! , r3dum3, r3dum4 ! not used - rk4417 - phase2 ok = NF90_OPEN(filename%type, 0, ncid) IF (ok /= NF90_NOERR) CALL nc_abort(ok, 'Error opening grid info file.') @@ -249,7 +264,9 @@ SUBROUTINE read_gridinfo(nlon, nlat, npatch) IF (ok /= NF90_NOERR) CALL nc_abort(ok, 'Error inquiring y dimension.') ok = NF90_INQUIRE_DIMENSION(ncid, yID, LEN=nlat) IF (ok /= NF90_NOERR) CALL nc_abort(ok, 'Error getting y dimension.') - IF(.NOT. exists%patch) THEN + IF(.NOT. exists%patch) THEN ! MMY@13April here is right, when npatch doesn't exist in met file (i.e. exists%patch=False), + ! read npatch from gridinfo file. Note that it is to say, + ! npatch in meteorology file has a priority over in gridinfo ok = NF90_INQ_DIMID(ncid, 'patch', pID) IF (ok /= NF90_NOERR) CALL nc_abort(ok, 'Error inquiring patch dimension.') ok = NF90_INQUIRE_DIMENSION(ncid, pID, LEN=npatch) @@ -473,14 +490,14 @@ SUBROUTINE spatialSoil(nlon, nlat, logn) INTEGER, INTENT(IN) :: logn ! log file unit number ! local variables - INTEGER :: ncid, ok, ii, jj, kk, ok2, ncid_elev + INTEGER :: ncid, ok, ii, jj, kk, ok2 !, ncid_elev ! is not used - rk4417 - phase2 INTEGER :: xID, yID, fieldID INTEGER :: xlon, xlat - REAL, DIMENSION(:,:,:,:), ALLOCATABLE :: indummy +! REAL, DIMENSION(:,:,:,:), ALLOCATABLE :: indummy ! appears only in commented code - rk4417 - phase2 REAL, DIMENSION(:,:), ALLOCATABLE :: sfact, dummy2 REAL, DIMENSION(:,:), ALLOCATABLE :: in2alb - ok = NF90_OPEN(filename%type, 0, ncid) +! ok = NF90_OPEN(filename%type, 0, ncid) ! moved below - rk4417 - phase2 ALLOCATE( in2alb(nlon, nlat) ) ! local ALLOCATE( dummy2(nlon, nlat) ) ! local @@ -498,15 +515,9 @@ SUBROUTINE spatialSoil(nlon, nlat, logn) ALLOCATE( insilt(nlon, nlat) ) ALLOCATE( insand(nlon, nlat) ) - !MD Aquifer properties - ALLOCATE( inGWssat(nlon, nlat) ) - ALLOCATE( inGWbch(nlon, nlat) ) - ALLOCATE( inGWhyds(nlon, nlat) ) - ALLOCATE( inGWsucs(nlon, nlat) ) - ALLOCATE( inGWrhosoil(nlon, nlat) ) - ALLOCATE( inGWWatr(nlon, nlat) ) - ALLOCATE( inWatr(nlon, nlat) ) - ALLOCATE( inORG(nlon, nlat) ) + ! MMY start reading from gridinfo file ! 2 lines inserted by rk4417 - phase2 + ok = NF90_OPEN(filename%type, 0, ncid) + IF (ok /= NF90_NOERR) CALL nc_abort(ok, 'Error MMY finding gridinfo file.') ! MMY ! 1 ok = NF90_INQ_VARID(ncid, 'swilt', fieldID) @@ -574,90 +585,18 @@ SUBROUTINE spatialSoil(nlon, nlat, logn) ok = NF90_GET_VAR(ncid, fieldID, in2alb) IF (ok /= NF90_NOERR) CALL nc_abort(ok, 'Error reading variable UM albedo') - !MD try to read aquifer properties from the file - ! if they don't exist set aquifer properties to the same as the soil - ok = NF90_INQ_VARID(ncid, 'Watr', fieldID) - WRITE(*,*) NF90_NOERR - ok2= ok - IF (ok .EQ. NF90_NOERR) THEN - ok2 = NF90_GET_VAR(ncid, fieldID, inWatr) - END IF - IF ((ok2 .NE. NF90_NOERR) .OR. (ok .NE. NF90_NOERR)) THEN - inWatr(:,:) = 0.05 - END IF - - found_explicit_gw_parameters = .TRUE. - - ok = NF90_INQ_VARID(ncid, 'GWssat', fieldID) - WRITE(*,*) NF90_NOERR - ok2= ok - IF (ok .EQ. NF90_NOERR) THEN - ok2 = NF90_GET_VAR(ncid, fieldID, inGWssat) - END IF - IF ((ok2 .NE. NF90_NOERR) .OR. (ok .NE. NF90_NOERR)) THEN - inGWssat(:,:) = inssat(:,:) - found_explicit_gw_parameters = .FALSE. - END IF - - ok = NF90_INQ_VARID(ncid, 'GWWatr', fieldID) - ok2 = ok - IF (ok .EQ. NF90_NOERR) THEN - ok2 = NF90_GET_VAR(ncid, fieldID, inGWssat) - END IF - IF ((ok2 .NE. NF90_NOERR) .OR. (ok .NE. NF90_NOERR)) THEN - inGWWatr(:,:) = 0.05 - END IF - - ok = NF90_INQ_VARID(ncid, 'GWsucs', fieldID) - ok2 = ok - IF (ok .EQ. NF90_NOERR) THEN - ok2 = NF90_GET_VAR(ncid, fieldID, inGWsucs) - END IF - IF ((ok2 .NE. NF90_NOERR) .OR. (ok .NE. NF90_NOERR)) THEN - inGWsucs(:,:) = ABS(insucs(:,:)) * 1000.0 - found_explicit_gw_parameters = .FALSE. - END IF - - ok = NF90_INQ_VARID(ncid, 'GWbch', fieldID) - ok2 = ok - IF (ok .EQ. NF90_NOERR) THEN - ok2 = NF90_GET_VAR(ncid, fieldID, inGWbch) - END IF - IF ((ok2 .NE. NF90_NOERR) .OR. (ok .NE. NF90_NOERR)) THEN - inGWbch(:,:) = inbch(:,:) - found_explicit_gw_parameters = .FALSE. - END IF - - ok = NF90_INQ_VARID(ncid, 'GWhyds', fieldID) - ok2 = ok - IF (ok .EQ. NF90_NOERR) THEN - ok2 = NF90_GET_VAR(ncid, fieldID, inGWhyds) - END IF - IF ((ok2 .NE. NF90_NOERR) .OR. (ok .NE. NF90_NOERR)) THEN - inGWhyds(:,:) = inhyds(:,:)*1000.0 - found_explicit_gw_parameters = .FALSE. - END IF - - ok = NF90_INQ_VARID(ncid, 'GWrhosoil', fieldID) - ok2 = ok - IF (ok .EQ. NF90_NOERR) THEN - ok2 = NF90_GET_VAR(ncid, fieldID, inGWrhosoil) - END IF - IF ((ok2 .NE. NF90_NOERR) .OR. (ok .NE. NF90_NOERR)) THEN - inGWrhosoil(:,:) = inrhosoil(:,:) - END IF - - ok = NF90_INQ_VARID(ncid, 'organic', fieldID) - ok2 = ok - IF (ok .EQ. NF90_NOERR) THEN - ok2 = NF90_GET_VAR(ncid, fieldID, inORG) - WRITE(logn,*) 'READ FORG FROM THE DATA FILE, yeidling ' - WRITE(logn,*) 'A maximum value of ',MAXVAL(inORG),' and min val of',MINVAL(inORG) - END IF - IF ((ok2 .NE. NF90_NOERR) .OR. (ok .NE. NF90_NOERR)) THEN - inORG(:,:) = 0.0 - WRITE(logn,*) 'COULD NOT READ FORG FROM THR SRF FILE setting to 0.0' - END IF +! +! ok = NF90_INQ_VARID(ncid, 'organic', fieldID) +! ok2 = ok +! IF (ok .EQ. NF90_NOERR) THEN +! ok2 = NF90_GET_VAR(ncid, fieldID, inORG) +! WRITE(logn,*) 'READ FORG FROM THE DATA FILE, yeidling ' +! WRITE(logn,*) 'A maximum value of ',MAXVAL(inORG),' and min val of',MINVAL(inORG) +! END IF +! IF ((ok2 .NE. NF90_NOERR) .OR. (ok .NE. NF90_NOERR)) THEN +! inORG(:,:) = 0.0 +! WRITE(logn,*) 'COULD NOT READ FORG FROM THR SRF FILE setting to 0.0' +! END IF ! Use this code if need to process original UM file soil fields into CABLE @@ -733,9 +672,6 @@ SUBROUTINE spatialSoil(nlon, nlat, logn) ! in2alb(:,:) = indummy(:,:,1,1) ! CALL NSflip(nlon,nlat,in2alb) - ok = NF90_CLOSE(ncid) - IF (ok /= NF90_NOERR) CALL nc_abort(ok, 'Error closing IGBP soil map.') - ! Code if using UM soil file ! unit change and glacial-point check were done in preprocessing ! ! change unit to m/s @@ -774,50 +710,54 @@ SUBROUTINE spatialSoil(nlon, nlat, logn) inALB(:, :, 1, 2) = dummy2(:, :) inALB(:, :, 1, 1) = sfact(:, :) * dummy2(:, :) + ok = NF90_CLOSE(ncid) ! 2 lines inserted - rk4417 - phase2 + IF (ok /= NF90_NOERR) CALL nc_abort(ok, 'Error closing gridinfo file.') ! MMY - ALLOCATE(inSlope(nlon,nlat),stat=ok) - IF (ok .NE. 0) CALL nc_abort(ok, 'Error allocating inSlope ') - inSlope(:,:) = 0.0 - - ALLOCATE(inSlopeSTD(nlon,nlat),stat=ok) - IF (ok .NE. 0) CALL nc_abort(ok, 'Error allocating inSlopeSTD ') - inSlopeSTD(:,:) = 0.0 - - ALLOCATE(inGWdz(nlon,nlat),stat=ok) - IF (ok .NE. 0) CALL nc_abort(ok, 'Error allocating inGWdz ') - inGWdz(:,:) = 20.0 - - IF (cable_user%GW_MODEL) THEN - ok = NF90_OPEN(TRIM(filename%gw_elev),NF90_NOWRITE,ncid_elev) - IF (ok /= NF90_NOERR) CALL nc_abort(ok, 'Error opening GW elev param file.') - - ok = NF90_INQ_VARID(ncid_elev, 'slope', fieldID) - IF (ok /= NF90_NOERR) WRITE(logn,*) 'Error finding variable slope' - ok = NF90_GET_VAR(ncid_elev, fieldID, inSlope) - IF (ok /= NF90_NOERR) THEN - inSlope = 0.0 - WRITE(logn, *) 'Could not read slope data for SSGW, set to 0.0' - END IF - - ok = NF90_INQ_VARID(ncid_elev, 'slope_std', fieldID) !slope_std - IF (ok /= NF90_NOERR) WRITE(logn,*) 'Error finding variable slope std' - ok = NF90_GET_VAR(ncid_elev, fieldID, inSlopeSTD) - IF (ok /= NF90_NOERR) THEN - inSlopeSTD = 0.0 - WRITE(logn, *) 'Could not read slope stddev data for SSGW, set to 0.0' - END IF - - ok = NF90_INQ_VARID(ncid_elev, 'dtb', fieldID) - IF (ok /= NF90_NOERR) WRITE(logn,*) 'Error finding variable dtb' - ok = NF90_GET_VAR(ncid_elev, fieldID, inGWdz) - IF (ok /= NF90_NOERR) THEN - inGWdz = 20.0 - WRITE(logn, *) 'Could not read dtb data for SSGW, set to 0.0' - END IF - - ok = NF90_CLOSE(ncid_elev) +! Block below commented out by rk4417 - phase2 - ENDIF !running gw model +! ALLOCATE(inSlope(nlon,nlat),stat=ok) +! IF (ok .NE. 0) CALL nc_abort(ok, 'Error allocating inSlope ') +! inSlope(:,:) = 0.0 +! +! ALLOCATE(inSlopeSTD(nlon,nlat),stat=ok) +! IF (ok .NE. 0) CALL nc_abort(ok, 'Error allocating inSlopeSTD ') +! inSlopeSTD(:,:) = 0.0 +! +! ALLOCATE(inGWdz(nlon,nlat),stat=ok) +! IF (ok .NE. 0) CALL nc_abort(ok, 'Error allocating inGWdz ') +! inGWdz(:,:) = 20.0 +! +! IF (cable_user%GW_MODEL) THEN +! ok = NF90_OPEN(TRIM(filename%gw_elev),NF90_NOWRITE,ncid_elev) +! IF (ok /= NF90_NOERR) CALL nc_abort(ok, 'Error opening GW elev param file.') +! +! ok = NF90_INQ_VARID(ncid_elev, 'slope', fieldID) +! IF (ok /= NF90_NOERR) WRITE(logn,*) 'Error finding variable slope' +! ok = NF90_GET_VAR(ncid_elev, fieldID, inSlope) +! IF (ok /= NF90_NOERR) THEN +! inSlope = 0.0 +! WRITE(logn, *) 'Could not read slope data for SSGW, set to 0.0' +! END IF +! +! ok = NF90_INQ_VARID(ncid_elev, 'slope_std', fieldID) !slope_std +! IF (ok /= NF90_NOERR) WRITE(logn,*) 'Error finding variable slope std' +! ok = NF90_GET_VAR(ncid_elev, fieldID, inSlopeSTD) +! IF (ok /= NF90_NOERR) THEN +! inSlopeSTD = 0.0 +! WRITE(logn, *) 'Could not read slope stddev data for SSGW, set to 0.0' +! END IF +! +! ok = NF90_INQ_VARID(ncid_elev, 'dtb', fieldID) +! IF (ok /= NF90_NOERR) WRITE(logn,*) 'Error finding variable dtb' +! ok = NF90_GET_VAR(ncid_elev, fieldID, inGWdz) +! IF (ok /= NF90_NOERR) THEN +! inGWdz = 20.0 +! WRITE(logn, *) 'Could not read dtb data for SSGW, set to 0.0' +! END IF +! +! ok = NF90_CLOSE(ncid_elev) +! +! ENDIF !running gw model DEALLOCATE(in2alb, sfact, dummy2) @@ -1027,7 +967,7 @@ SUBROUTINE countPatch(nlon, nlat, npatch) landpt(:)%ilat = -999 ncount = 0 DO kk = 1, mland - distance = 300.0 ! initialise, units are degrees + distance = 300.0 ! initialise, units are degrees ! MMY distance = 5300.0 in CABLE-GW DO jj = 1, nlat DO ii = 1, nlon IF (inVeg(ii,jj, 1) > 0) THEN @@ -1064,7 +1004,9 @@ SUBROUTINE countPatch(nlon, nlat, npatch) STOP END IF ! CLN added for npatches - ELSE IF ( npatch .GT. 1 ) THEN +! ELSE IF ( npatch .GT. 1 ) THEN +! line above replaced by below - rk4417 - phase2 + ELSE IF ( npatch .GT. 1 .AND. cable_user%force_npatches_as .le. 0) THEN landpt(kk)%nap = 0 DO tt = 1, npatch @@ -1080,6 +1022,20 @@ SUBROUTINE countPatch(nlon, nlat, npatch) PRINT *, 'vegtype_metfile = ', vegtype_metfile(kk,:) STOP END IF +! inserted ELSE IF block below - rk4417 - phase2 + ! CLN added for npatches + ELSE IF ( npatch .GT. 1 .AND. cable_user%force_npatches_as .eq. npatch) THEN + !force the number of tiles per cell + !will read in the tile info from the GWspatial subroutine + landpt(kk)%nap = npatch + ncount = ncount + landpt(kk)%nap + landpt(kk)%cend = ncount + IF (landpt(kk)%cend < landpt(kk)%cstart) THEN + PRINT *, 'Land point ', kk, ' does not have veg type!' + PRINT *, 'landpt%cstart, cend = ', landpt(kk)%cstart, landpt(kk)%cend + PRINT *, 'vegtype_metfile = ', vegtype_metfile(kk,:) + STOP + END IF ELSE ! assume nmetpatches to be 1 IF (nmetpatches == 1) THEN @@ -1128,9 +1084,10 @@ END SUBROUTINE countPatch SUBROUTINE write_default_params(met, air, ssnow, veg, bgc, & soil, canopy, rough, rad, logn, & vegparmnew, month, TFRZ, LUC_EXPT) + ! Initialize many canopy_type, soil_snow_type, soil_parameter_type and ! roughness_type variables; - ! Calculate 'froot' from 'rootbeta' parameter; + ! Calculate 'froot' from 'rootbeta' parameter. Does not assign values to the soil hydraulic parameters. ! Assign values from input file to their proper variables in soil_snow_type, ! soil_parameter_type, veg_parameter_type and patch_type; ! Prescribe parameters for each point based on its veg/soil type. @@ -1151,6 +1108,12 @@ SUBROUTINE write_default_params(met, air, ssnow, veg, bgc, & USE cable_common_module, ONLY : calcsoilalbedo,cable_user + USE cable_pft_params_mod, ONLY : vegin !added by rk4417 - phase2 + USE cable_soil_params_mod, ONLY : soilin !added by rk4417 - phase2 + +! Note that subroutine init_veg_from_vegin has been moved from cable_common.F90 +! to cable_parameters.F90 (this file) and no longer needs to be imported - rk4417 - phase2 + IMPLICIT NONE INTEGER, INTENT(IN) :: logn ! log file unit number INTEGER, INTENT(IN) :: month ! month of year @@ -1215,7 +1178,6 @@ SUBROUTINE write_default_params(met, air, ssnow, veg, bgc, & canopy%fe = 0.0 ! sensible heat flux !mrd ssnow%qrecharge = 0.0 - ssnow%GWwb = -1.0 ssnow%wtd = 1.0 canopy%sublayer_dz = 0.001 !could go into restart to ensure starting/stopping runs gives identical results !however the impact is negligible @@ -1248,7 +1210,9 @@ SUBROUTINE write_default_params(met, air, ssnow, veg, bgc, & END SELECT - +! line below added by rk4417 - phase2 + soil%zse_vec = REAL(SPREAD(soil%zse,1,mp),r_2) ! MMY@13April, this line is needed since zec_vec is defined in UM/init/cable_um_init_subrs.F90, + ! but it isn't used in offline CABLE !ELSE ! ! parameters that are not spatially dependent @@ -1347,7 +1311,7 @@ SUBROUTINE write_default_params(met, air, ssnow, veg, bgc, & ! Set initial snow depth and snow-free soil albedo - + ! MMY Note @Oct2022 Please notice ssnow%albsoilsn is set here rather than in GWspatialParameters DO is = 1, landpt(e)%cend - landpt(e)%cstart + 1 ! each patch DO ir = 1, nrb IF (CABLE_USER%POPLUC) THEN !vh! use same soilalbedo for all land-use tiles @@ -1359,7 +1323,8 @@ SUBROUTINE write_default_params(met, air, ssnow, veg, bgc, & = inALB(landpt(e)%ilon, landpt(e)%ilat, is, ir) ! various rad band ENDIF END DO - ! total depth, change from m to mm !see Ticket #57 +! total depth, change from m to mm !see Ticket #57 +! Ticket #57: changing the scaling factor from 1000 (water density) to 140 (old ice density) ! MMY @Oct2022 ssnow%snowd(landpt(e)%cstart + is - 1) & = inSND(landpt(e)%ilon, landpt(e)%ilat, is, month) * 140.0 END DO @@ -1370,90 +1335,93 @@ SUBROUTINE write_default_params(met, air, ssnow, veg, bgc, & inLAI(landpt(e)%ilon,landpt(e)%ilat,is) END DO - ! Set IGBP soil texture values, Q.Zhang @ 12/20/2010. - IF (soilparmnew) THEN - - soil%swilt(landpt(e)%cstart:landpt(e)%cend) = & - inswilt(landpt(e)%ilon, landpt(e)%ilat) - soil%sfc(landpt(e)%cstart:landpt(e)%cend) = & - insfc(landpt(e)%ilon, landpt(e)%ilat) - soil%ssat(landpt(e)%cstart:landpt(e)%cend) = & - inssat(landpt(e)%ilon, landpt(e)%ilat) - soil%bch(landpt(e)%cstart:landpt(e)%cend) = & - inbch(landpt(e)%ilon, landpt(e)%ilat) - soil%hyds(landpt(e)%cstart:landpt(e)%cend) = & - inhyds(landpt(e)%ilon, landpt(e)%ilat) - soil%sucs(landpt(e)%cstart:landpt(e)%cend) = & - -1.* ABS(insucs(landpt(e)%ilon, landpt(e)%ilat)) !ensure negative - soil%rhosoil(landpt(e)%cstart:landpt(e)%cend) = & - inrhosoil(landpt(e)%ilon, landpt(e)%ilat) - soil%css(landpt(e)%cstart:landpt(e)%cend) = & - incss(landpt(e)%ilon, landpt(e)%ilat) - soil%cnsd(landpt(e)%cstart:landpt(e)%cend) = & - incnsd(landpt(e)%ilon, landpt(e)%ilat) - - !possibly heterogeneous soil properties - DO klev=1,ms - - soil%clay_vec(landpt(e)%cstart:landpt(e)%cend,klev) = & - REAL(inclay(landpt(e)%ilon, landpt(e)%ilat),r_2) - - soil%sand_vec(landpt(e)%cstart:landpt(e)%cend,klev) = & - REAL(insand(landpt(e)%ilon, landpt(e)%ilat),r_2) - - soil%silt_vec(landpt(e)%cstart:landpt(e)%cend,klev) = & - REAL(insilt(landpt(e)%ilon, landpt(e)%ilat),r_2) - - soil%rhosoil_vec(landpt(e)%cstart:landpt(e)%cend,klev) = & - REAL(inrhosoil(landpt(e)%ilon, landpt(e)%ilat),r_2) - - soil%org_vec(landpt(e)%cstart:landpt(e)%cend,klev) = & - REAL(inORG(landpt(e)%ilon, landpt(e)%ilat),r_2) - - soil%watr(landpt(e)%cstart:landpt(e)%cend,klev) = & - REAL(inWatr(landpt(e)%ilon, landpt(e)%ilat),r_2) - - END DO - - !Aquifer properties same as bottom soil layer for now - soil%GWsucs_vec(landpt(e)%cstart:landpt(e)%cend) = & - REAL(inGWsucs(landpt(e)%ilon, landpt(e)%ilat),r_2) - - soil%GWhyds_vec(landpt(e)%cstart:landpt(e)%cend) = & - REAL(inGWhyds(landpt(e)%ilon, landpt(e)%ilat),r_2) - - soil%GWbch_vec(landpt(e)%cstart:landpt(e)%cend) = & - REAL(inGWbch(landpt(e)%ilon, landpt(e)%ilat),r_2) - - soil%GWrhosoil_vec(landpt(e)%cstart:landpt(e)%cend) = & - REAL(inGWrhosoil(landpt(e)%ilon, landpt(e)%ilat),r_2) - - soil%GWssat_vec(landpt(e)%cstart:landpt(e)%cend) = & - REAL(inGWssat(landpt(e)%ilon, landpt(e)%ilat),r_2) - - soil%GWwatr(landpt(e)%cstart:landpt(e)%cend) = & - soil%watr(landpt(e)%cstart:landpt(e)%cend,ms) - - soil%slope(landpt(e)%cstart:landpt(e)%cend) = & - MIN(MAX(inSlope(landpt(e)%ilon,landpt(e)%ilat),1e-8),0.95) - - soil%slope_std(landpt(e)%cstart:landpt(e)%cend) = & - MIN(MAX(inSlopeSTD(landpt(e)%ilon,landpt(e)%ilat),1e-8),0.95) - soil%GWdz(landpt(e)%cstart:landpt(e)%cend) = & - inGWdz(landpt(e)%ilon,landpt(e)%ilat) +! IF block below commented out by rk4417 - phase2 - ! vh ! - soil%silt(landpt(e)%cstart:landpt(e)%cend) = & - insilt(landpt(e)%ilon, landpt(e)%ilat) - - soil%sand(landpt(e)%cstart:landpt(e)%cend) = & - insand(landpt(e)%ilon, landpt(e)%ilat) - - soil%clay(landpt(e)%cstart:landpt(e)%cend) = & - inclay(landpt(e)%ilon, landpt(e)%ilat) - - ENDIF +! ! Set IGBP soil texture values, Q.Zhang @ 12/20/2010. +! IF (soilparmnew) THEN +! +! soil%swilt(landpt(e)%cstart:landpt(e)%cend) = & +! inswilt(landpt(e)%ilon, landpt(e)%ilat) +! soil%sfc(landpt(e)%cstart:landpt(e)%cend) = & +! insfc(landpt(e)%ilon, landpt(e)%ilat) +! soil%ssat(landpt(e)%cstart:landpt(e)%cend) = & +! inssat(landpt(e)%ilon, landpt(e)%ilat) +! soil%bch(landpt(e)%cstart:landpt(e)%cend) = & +! inbch(landpt(e)%ilon, landpt(e)%ilat) +! soil%hyds(landpt(e)%cstart:landpt(e)%cend) = & +! inhyds(landpt(e)%ilon, landpt(e)%ilat) +! soil%sucs(landpt(e)%cstart:landpt(e)%cend) = & +! -1.* ABS(insucs(landpt(e)%ilon, landpt(e)%ilat)) !ensure negative +! soil%rhosoil(landpt(e)%cstart:landpt(e)%cend) = & +! inrhosoil(landpt(e)%ilon, landpt(e)%ilat) +! soil%css(landpt(e)%cstart:landpt(e)%cend) = & +! incss(landpt(e)%ilon, landpt(e)%ilat) +! soil%cnsd(landpt(e)%cstart:landpt(e)%cend) = & +! incnsd(landpt(e)%ilon, landpt(e)%ilat) +! +! !possibly heterogeneous soil properties +! DO klev=1,ms +! +! soil%clay_vec(landpt(e)%cstart:landpt(e)%cend,klev) = & +! REAL(inclay(landpt(e)%ilon, landpt(e)%ilat),r_2) +! +! soil%sand_vec(landpt(e)%cstart:landpt(e)%cend,klev) = & +! REAL(insand(landpt(e)%ilon, landpt(e)%ilat),r_2) +! +! soil%silt_vec(landpt(e)%cstart:landpt(e)%cend,klev) = & +! REAL(insilt(landpt(e)%ilon, landpt(e)%ilat),r_2) +! +! soil%rhosoil_vec(landpt(e)%cstart:landpt(e)%cend,klev) = & +! REAL(inrhosoil(landpt(e)%ilon, landpt(e)%ilat),r_2) +! +! soil%org_vec(landpt(e)%cstart:landpt(e)%cend,klev) = & +! REAL(inORG(landpt(e)%ilon, landpt(e)%ilat),r_2) +! +! soil%watr(landpt(e)%cstart:landpt(e)%cend,klev) = & +! REAL(inWatr(landpt(e)%ilon, landpt(e)%ilat),r_2) +! +! END DO +! +! !Aquifer properties same as bottom soil layer for now +! soil%GWsucs_vec(landpt(e)%cstart:landpt(e)%cend) = & +! REAL(inGWsucs(landpt(e)%ilon, landpt(e)%ilat),r_2) +! +! soil%GWhyds_vec(landpt(e)%cstart:landpt(e)%cend) = & +! REAL(inGWhyds(landpt(e)%ilon, landpt(e)%ilat),r_2) +! +! soil%GWbch_vec(landpt(e)%cstart:landpt(e)%cend) = & +! REAL(inGWbch(landpt(e)%ilon, landpt(e)%ilat),r_2) +! +! soil%GWrhosoil_vec(landpt(e)%cstart:landpt(e)%cend) = & +! REAL(inGWrhosoil(landpt(e)%ilon, landpt(e)%ilat),r_2) +! +! soil%GWssat_vec(landpt(e)%cstart:landpt(e)%cend) = & +! REAL(inGWssat(landpt(e)%ilon, landpt(e)%ilat),r_2) +! +! soil%GWwatr(landpt(e)%cstart:landpt(e)%cend) = & +! soil%watr(landpt(e)%cstart:landpt(e)%cend,ms) +! +! soil%slope(landpt(e)%cstart:landpt(e)%cend) = & +! MIN(MAX(inSlope(landpt(e)%ilon,landpt(e)%ilat),1e-8),0.95) +! +! soil%slope_std(landpt(e)%cstart:landpt(e)%cend) = & +! MIN(MAX(inSlopeSTD(landpt(e)%ilon,landpt(e)%ilat),1e-8),0.95) +! +! soil%GWdz(landpt(e)%cstart:landpt(e)%cend) = & +! inGWdz(landpt(e)%ilon,landpt(e)%ilat) +! +! ! vh ! +! soil%silt(landpt(e)%cstart:landpt(e)%cend) = & +! insilt(landpt(e)%ilon, landpt(e)%ilat) +! +! soil%sand(landpt(e)%cstart:landpt(e)%cend) = & +! insand(landpt(e)%ilon, landpt(e)%ilat) +! +! soil%clay(landpt(e)%cstart:landpt(e)%cend) = & +! inclay(landpt(e)%ilon, landpt(e)%ilat) +! +! ENDIF ! vars intro for Ticket #27 IF (calcsoilalbedo) THEN @@ -1561,6 +1529,7 @@ SUBROUTINE write_default_params(met, air, ssnow, veg, bgc, & ! Deallocate temporary variables: IF (soilparmnew) DEALLOCATE(inswilt, insfc, inssat, inbch, inhyds, & insucs, inrhosoil, incss, incnsd) ! Q,Zhang @ 12/20/2010 + IF (calcsoilalbedo) DEALLOCATE(inSoilColor) ! vars intro for Ticket #27 DEALLOCATE(inVeg, inPFrac, inSoil, inWB, inTGG) DEALLOCATE(inLAI, inSND, inALB) @@ -1568,32 +1537,35 @@ SUBROUTINE write_default_params(met, air, ssnow, veg, bgc, & ! frac4_temp,iveg_temp) ! IF(ASSOCIATED(vegtype_metfile)) DEALLOCATE(vegtype_metfile) ! IF(ASSOCIATED(soiltype_metfile)) DEALLOCATE(soiltype_metfile) - ! DEALLOCATE(soilin%silt, soilin%clay, soilin%sand, soilin%swilt, & - ! soilin%sfc, soilin%ssat, soilin%bch, soilin%hyds, soilin%sucs, & - ! soilin%rhosoil, soilin%css, vegin%canst1, vegin%dleaf, & - ! vegin%vcmax, vegin%ejmax, vegin%hc, vegin%xfang, vegin%rp20, & - ! vegin%rpcoef, vegin%rs20, vegin%shelrb, vegin%frac4, & - ! vegin%wai, vegin%vegcf, vegin%extkn, vegin%tminvj, & - ! vegin%tmaxvj, vegin%vbeta,vegin%clitt, vegin%zr, vegin%rootbeta, vegin%froot, & - ! vegin%cplant, vegin%csoil, vegin%ratecp, vegin%ratecs, & - ! vegin%xalbnir, vegin%length, vegin%width, & - ! vegin%g0, vegin%g1, & - ! vegin%a1gs, vegin%d0gs, vegin%alpha, vegin%convex, vegin%cfrd, & - ! vegin%gswmin, vegin%conkc0,vegin%conko0,vegin%ekc,vegin%eko ) - ! ! vegf_temp,urbanf_temp,lakef_temp,icef_temp, & - - IF (ALLOCATED(inGWsucs )) DEALLOCATE(inGWsucs) - IF (ALLOCATED(inGWhyds )) DEALLOCATE(inGWhyds) - IF (ALLOCATED(inGWbch )) DEALLOCATE(inGWbch) - IF (ALLOCATED(inGWsilt )) DEALLOCATE(inGWsilt) - IF (ALLOCATED(inGWsand )) DEALLOCATE(inGWsand) - IF (ALLOCATED(inGWclay )) DEALLOCATE(inGWclay) - IF (ALLOCATED(inGWssat )) DEALLOCATE(inGWssat) - IF (ALLOCATED(inGWWatr )) DEALLOCATE(inGWWatr) - IF (ALLOCATED(inWatr )) DEALLOCATE(inWatr) - IF (ALLOCATED(inSlope )) DEALLOCATE(inSlope) - IF (ALLOCATED(inSlopeSTD)) DEALLOCATE(inSlopeSTD) - IF (ALLOCATED(inORG )) DEALLOCATE(inORG) + +! DEALLOCATE(soilin%silt, soilin%clay, soilin%sand, soilin%swilt, & +! soilin%sfc, soilin%ssat, soilin%bch, soilin%hyds, soilin%sucs, & +! soilin%rhosoil, soilin%css, vegin%canst1, vegin%dleaf, & +! vegin%vcmax, vegin%ejmax, vegin%hc, vegin%xfang, vegin%rp20, & +! vegin%rpcoef, vegin%rs20, vegin%shelrb, vegin%frac4, & +! vegin%wai, vegin%vegcf, vegin%extkn, vegin%tminvj, & +! vegin%tmaxvj, vegin%vbeta,vegin%clitt, vegin%zr, vegin%rootbeta, vegin%froot, & +! vegin%cplant, vegin%csoil, vegin%ratecp, vegin%ratecs, & +! vegin%xalbnir, vegin%length, vegin%width, & +! vegin%g0, vegin%g1, & +! vegin%a1gs, vegin%d0gs, vegin%alpha, vegin%convex, vegin%cfrd, & +! vegin%gswmin, vegin%conkc0,vegin%conko0,vegin%ekc,vegin%eko ) + ! vegf_temp,urbanf_temp,lakef_temp,icef_temp, & + +! Block below commented out by rk4417 - phase2 +! IF (ALLOCATED(inGWsucs )) DEALLOCATE(inGWsucs) +! IF (ALLOCATED(inGWhyds )) DEALLOCATE(inGWhyds) +! IF (ALLOCATED(inGWbch )) DEALLOCATE(inGWbch) +! IF (ALLOCATED(inGWsilt )) DEALLOCATE(inGWsilt) +! IF (ALLOCATED(inGWsand )) DEALLOCATE(inGWsand) +! IF (ALLOCATED(inGWclay )) DEALLOCATE(inGWclay) +! IF (ALLOCATED(inGWssat )) DEALLOCATE(inGWssat) +! IF (ALLOCATED(inGWWatr )) DEALLOCATE(inGWWatr) +! IF (ALLOCATED(inWatr )) DEALLOCATE(inWatr) +! IF (ALLOCATED(inSlope )) DEALLOCATE(inSlope) +! IF (ALLOCATED(inSlopeSTD)) DEALLOCATE(inSlopeSTD) +! IF (ALLOCATED(inORG )) DEALLOCATE(inORG) + ! if using old format veg_parm input file, need to define veg%deciduous ! BP dec 2007 ! IF (.NOT. vegparmnew) THEN @@ -1648,6 +1620,13 @@ SUBROUTINE write_default_params(met, air, ssnow, veg, bgc, & ssnow%wbliq = ssnow%wb - ssnow%wbice ssnow%GWwb = 0.9*soil%ssat +! 5 lines below inserted by rk4417 - phase2 + ssnow%wb_hys = -1.0e+36 + ssnow%hys_fac = 1.0 + ssnow%watr_hys = soil%watr + ssnow%ssat_hys = soil%ssat_vec + ssnow%smp_hys = -1.0e+36 + !IF(hide%Ticket49Bug5) THEN ! vh_js ! neeed to remove this if to enable the code below @@ -1680,15 +1659,18 @@ SUBROUTINE write_default_params(met, air, ssnow, veg, bgc, & veg%disturbance_intensity = 0. ENDIF +! MMY note @Oct2022 Important differ to MMY's trunk: assume depth to bedrock = 4.6m + aquifer soil%GWdz = MAX(1.0,MIN(20.0,soil%GWdz - SUM(soil%zse,dim=1))) - !set vectorized versions as same as defaut for now - soil%swilt_vec(:,:) = REAL(SPREAD(soil%swilt(:),2,ms),r_2) - soil%sfc_vec(:,:) = REAL(SPREAD(soil%sfc(:),2,ms),r_2) - soil%sucs_vec(:,:) = REAL(SPREAD(soil%sucs(:),2,ms),r_2) - soil%bch_vec(:,:) = REAL(SPREAD(soil%bch(:),2,ms),r_2) - soil%ssat_vec(:,:) = REAL(SPREAD(soil%ssat(:),2,ms),r_2) - soil%hyds_vec(:,:) = REAL(SPREAD(soil%hyds(:),2,ms),r_2) +! Block below commented out by rk4417 - phase2 +! ____________ MMY @Oct2022 comment out ________ + !set vectorized versions as same as default for now +! soil%swilt_vec(:,:) = REAL(SPREAD(soil%swilt(:),2,ms),r_2) +! soil%sfc_vec(:,:) = REAL(SPREAD(soil%sfc(:),2,ms),r_2) +! soil%sucs_vec(:,:) = REAL(SPREAD(soil%sucs(:),2,ms),r_2) +! soil%bch_vec(:,:) = REAL(SPREAD(soil%bch(:),2,ms),r_2) +! soil%ssat_vec(:,:) = REAL(SPREAD(soil%ssat(:),2,ms),r_2) +! soil%hyds_vec(:,:) = REAL(SPREAD(soil%hyds(:),2,ms),r_2) END SUBROUTINE write_default_params !============================================================================= @@ -1796,8 +1778,6 @@ SUBROUTINE derived_parameters(soil, sum_flux, bal, ssnow, veg, rough) REAL(r_2), DIMENSION(mp,ms) :: soil_depth ! MMY,rhosoil_temp REAL(r_2), DIMENSION(:,:), ALLOCATABLE :: ssat_bounded,rho_soil_bulk ! added by rk4417 - phase2 - - ! soil_depth(1) = REAL(soil%zse(1),r_2) ! DO klev=2,ms @@ -2370,13 +2350,34 @@ SUBROUTINE check_parameter_values(soil, veg, ssnow) CALL abort('Unknown vegetation type! Aborting.') END IF ! Check all soil types make sense: + IF(ANY(soil%isoilm(landpt(i)%cstart:(landpt(i)%cstart + landpt(i)%nap & - - 1)) < 1 ) .OR. ANY(soil%isoilm(landpt(i)%cstart:(landpt(i)%cstart & - + landpt(i)%nap - 1)) > mstype)) THEN - WRITE(*,*) 'SUBROUTINE load_parameters:' - WRITE(*,*) 'Land point number:',i + - 1)) < 1 ) .OR. ANY(soil%isoilm(landpt(i)%cstart:(landpt(i)%cstart & + + landpt(i)%nap - 1)) > mstype)) THEN ! MMY@Feb2023 .and. .not. soilparmnew + WRITE(*,*) 'SUBROUTINE load_parameters: soil < 1 or > ',mstype + DO j=landpt(i)%cstart,landpt(i)%cend + IF (soil%isoilm(j) .lt. 1 .or. soil%isoilm(j) .gt. mstype) THEN + write(*,*) 'AT ',i,j,' indices ' + write(*,*) '~~~~~~~~~~~~~~lat=>',& + patch(landpt(i)%cstart:landpt(i)%cend)%latitude + write(*,*) '~~~~~~~~~~~~~~lon=>',& + patch(landpt(i)%cstart:landpt(i)%cend)%longitude + write(*,*) '~~~~~~~~~~~~~~soil%isoilm',soil%isoilm(j) + END IF + ENDDO CALL abort('Unknown soil type! Aborting.') END IF + +! IF block above replaces one below - rk4417 - phase2 + +! IF(ANY(soil%isoilm(landpt(i)%cstart:(landpt(i)%cstart + landpt(i)%nap & +! - 1)) < 1 ) .OR. ANY(soil%isoilm(landpt(i)%cstart:(landpt(i)%cstart & +! + landpt(i)%nap - 1)) > mstype)) THEN +! WRITE(*,*) 'SUBROUTINE load_parameters:' +! WRITE(*,*) 'Land point number:',i +! CALL abort('Unknown soil type! Aborting.') +! END IF + ! Check patch fractions sum to 1 in each grid cell: IF((SUM(patch(landpt(i)%cstart:landpt(i)%cend)%frac) - 1.0) & > 1.0E-6) THEN diff --git a/src/offline/cable_pft_params.F90 b/src/offline/cable_pft_params.F90 index 92d09d971..641c02a0d 100644 --- a/src/offline/cable_pft_params.F90 +++ b/src/offline/cable_pft_params.F90 @@ -1,6 +1,9 @@ MODULE cable_pft_params_mod USE grid_constants_mod_cbl, ONLY: ntype_max +! line below added by rk4417 - phase2 +USE cable_def_types_mod, ONLY : ms, ncs, ncp, nrb + IMPLICIT NONE TYPE vegin_type @@ -42,12 +45,17 @@ MODULE cable_pft_params_mod g1(ntype_max), & zr(ntype_max), & clitt(ntype_max), & +! froot1 - froot6 do not serve any purpose +! their values inside offline/pft_params.nml are not used +! veg%froot is initialized instead from formula inside offline/cable_parameters.F90 +! rk4417 - phase2 froot1(ntype_max), & froot2(ntype_max), & froot3(ntype_max), & froot4(ntype_max), & froot5(ntype_max), & froot6(ntype_max), & +! rk4417 - phase2 csoil1(ntype_max), & csoil2(ntype_max), & ratecs1(ntype_max), & @@ -60,12 +68,20 @@ MODULE cable_pft_params_mod ratecp3(ntype_max), & refl1(ntype_max), & refl2(ntype_max), & - refl3(ntype_max), & + refl3(ntype_max), & ! not used - rk4417 - phase2 taul1(ntype_max), & taul2(ntype_max), & - taul3(ntype_max), & + taul3(ntype_max), & ! not used - rk4417 - phase2 dleaf(ntype_max), & - lai(ntype_max) + lai(ntype_max) !, & +! block below added by rk4417 - phase2 +! froot(ms,ntype_max), & ! not needed really - rk4417 - phase2 +! cplant(ncp,ntype_max), & ! not needed - rk4417 - phase2 +! csoil(ncs,ntype_max), & ! not needed - rk4417 - phase2 +! ratecp(ncp,ntype_max), & ! not needed - rk4417 - phase2 +! ratecs(ncs,ntype_max), & ! not needed - rk4417 - phase2 +! refl(nrb,ntype_max), & ! not needed - rk4417 - phase2 +! taul(nrb,ntype_max) ! not needed - rk4417 - phase2 END TYPE vegin_type diff --git a/src/offline/cbl_model_driver_offline.F90 b/src/offline/cbl_model_driver_offline.F90 index b9dab3d99..de75564d4 100644 --- a/src/offline/cbl_model_driver_offline.F90 +++ b/src/offline/cbl_model_driver_offline.F90 @@ -185,7 +185,37 @@ SUBROUTINE cbm( ktau,dels, air, bgc, canopy, met, ssnow%owetfac = ssnow%wetfac -CALL soil_snow(dels, soil, ssnow, canopy, met, bal,veg) + + IF( cable_runtime%um ) THEN + + IF( cable_runtime%um_implicit ) THEN + IF (cable_user%gw_model) THEN + CALL soil_snow_gw(dels, soil, ssnow, canopy, met, bal,veg) + ELSE + CALL soil_snow(dels, soil, ssnow, canopy, met, bal,veg) + ENDIF + ENDIF + + ELSE + IF(cable_user%SOIL_STRUC=='default') THEN + IF (cable_user%gw_model) THEN + CALL soil_snow_gw(dels, soil, ssnow, canopy, met, bal,veg) + ELSE + CALL soil_snow(dels, soil, ssnow, canopy, met, bal,veg) + ENDIF + ELSEIF (cable_user%SOIL_STRUC=='sli') THEN + + IF (cable_user%test_new_gw) & + CALL sli_hydrology(dels,ssnow,soil,veg,canopy) + + CALL sli_main(ktau,dels,veg,soil,ssnow,met,canopy,air,rad,0) + ENDIF + ENDIF + +! I have inserted the above block from MMY code which was deleted from the trunk +! soil_snow_gw and sli_hydrology are crucial in the GW module - rk4417 - phase2 + +!CALL soil_snow(dels, soil, ssnow, canopy, met, bal,veg) ! commented out by rk4417 - phase2 ssnow%deltss = ssnow%tss-ssnow%otss diff --git a/src/params/grid_constants_cbl.F90 b/src/params/grid_constants_cbl.F90 index 8d2ec313a..4a0a7f0f5 100644 --- a/src/params/grid_constants_cbl.F90 +++ b/src/params/grid_constants_cbl.F90 @@ -46,7 +46,8 @@ MODULE grid_constants_mod_cbl INTEGER, PARAMETER :: nvCs = 3 ! # vegetation carbon stores INTEGER, PARAMETER :: ICE_SoilType = 9 ! SoilType Index (soilparm_cable.nml JAC) INTEGER, PARAMETER :: lakes_cable = 16! SoilType Index (soilparm_cable.nml JAC) - +! I think lakes_cable is a not a good name choice, a better name might be LakesType for consistency - rk4417 +! The description on the lakes_cable line is a duplicate and needs updating - rk4417 INTEGER, PARAMETER :: ICE_VegType = 17 ! permanent ice index for veg INTEGER, PARAMETER :: mf = 2 ! # leaves (sunlit, shaded) diff --git a/src/science/canopy/cable_canopy.F90 b/src/science/canopy/cable_canopy.F90 index 7927c3da7..e7c3a248d 100644 --- a/src/science/canopy/cable_canopy.F90 +++ b/src/science/canopy/cable_canopy.F90 @@ -13,6 +13,11 @@ SUBROUTINE define_canopy(bal,rad,rough,air,met,dels,ssnow,soil,veg, canopy,clima USE cable_air_module USE cable_common_module USE cable_roughness_module + USE cable_psm, ONLY: or_soil_evap_resistance,rtevap_max,& ! inserted by rk4417 - phase2 + rt_Dff,update_or_soil_resis + USE cable_gw_hydro_module, ONLY : pore_space_relative_humidity, den_rat ! Use public variable den_rat to avoid calling subroutine set_den_rat repeatedly ! line inserted by rk4417 - phase2 + USE sli_main_mod, ONLY : sli_main ! line inserted by rk4417 - phase2 + USE cbl_friction_vel_module, ONLY : comp_friction_vel, psim, psis USE cbl_pot_evap_snow_module, ONLY : Penman_Monteith, Humidity_deficit_method @@ -79,8 +84,8 @@ SUBROUTINE define_canopy(bal,rad,rough,air,met,dels,ssnow,soil,veg, canopy,clima TYPE (soil_parameter_type), INTENT(INOUT) :: soil TYPE (veg_parameter_type), INTENT(INOUT) :: veg -REAL :: reducedLAIdue2snow(mp) -logical :: sunlit_veg_mask(mp) + REAL :: reducedLAIdue2snow(mp) + logical :: sunlit_veg_mask(mp) REAL, INTENT(IN) :: dels ! integration time setp (s) INTEGER :: & iter, & ! iteration # @@ -213,6 +218,14 @@ SUBROUTINE define_canopy(bal,rad,rough,air,met,dels,ssnow,soil,veg, canopy,clima ssnow%tss = REAL((1-ssnow%isflag))*ssnow%tgg(:,1) + & REAL(ssnow%isflag)*ssnow%tggsn(:,1) ENDIF + + IF (cable_user%gw_model) THEN ! IF block inserted by rk4417 - phase2 + ! IF (call_number .eq. 1) call set_den_rat() + ssnow%wbliq(:,:) = ssnow%wb(:,:) - den_rat*ssnow%wbice(:,:) + ELSE + ssnow%wbliq(:,:) = ssnow%wb(:,:) - ssnow%wbice(:,:) + ENDIF + tss4 = ssnow%tss**4 canopy%fes = 0. canopy%fess = 0. @@ -225,7 +238,7 @@ SUBROUTINE define_canopy(bal,rad,rough,air,met,dels,ssnow,soil,veg, canopy,clima canopy%fhs_cor = 0.0 canopy%fns_cor = 0.0 canopy%ga_cor = 0.0 - canopy%fes_cor = 0.0 + canopy%fes_cor = 0.0 ! should this line be commented out - rk4417 - phase2 !L_REV_CORR - new working variables rttsoil = 0. @@ -357,8 +370,10 @@ SUBROUTINE define_canopy(bal,rad,rough,air,met,dels,ssnow,soil,veg, canopy,clima IF (cable_user%or_evap) THEN - write(6,*) "GW or ORevepis not an option right now" - !H! call or_soil_evap_resistance(soil,air,met,canopy,ssnow,veg,rough) +! write(6,*) "GW or ORevepis not an option right now" - commented out by rk4417 - phase2 +!H! call or_soil_evap_resistance(soil,air,met,canopy,ssnow,veg,rough) +! line above replaced by below - rk4417 - phase2 + CALL or_soil_evap_resistance(soil,air,met,canopy,ssnow,veg,rough) END IF ! Vegetation boundary-layer conductance (mol/m2/s) @@ -429,7 +444,7 @@ SUBROUTINE define_canopy(bal,rad,rough,air,met,dels,ssnow,soil,veg, canopy,clima rad%lwabv(j) = CCAPP * Crmair * ( tlfy(j) - met%tk(j) ) * & sum_rad_gradis(j) ! vh_js ! - + IF ( (rad%lwabv(j) / (2.0*(1.0-rad%transd(j)) & * CSBOLTZ*CEMLEAF)+met%tvrad(j)**4) .GT. 0.0) THEN @@ -443,13 +458,10 @@ SUBROUTINE define_canopy(bal,rad,rough,air,met,dels,ssnow,soil,veg, canopy,clima ELSE! sparse canopy canopy%tv(j) = met%tvrad(j) - ENDIF - ENDDO - ! Calculate net rad to soil: canopy%fns = rad%qssabs + rad%transd*met%fld + (1.0-rad%transd)*CEMLEAF* & CSBOLTZ*canopy%tv**4 - CEMSOIL*CSBOLTZ* tss4 @@ -460,8 +472,10 @@ SUBROUTINE define_canopy(bal,rad,rough,air,met,dels,ssnow,soil,veg, canopy,clima CALL qsatfjh(mp, ssnow%qstss, CRMH2o, Crmair, CTETENA, CTETENB, CTETENC,ssnow%tss-CTfrz,met%pmb) if (cable_user%gw_model .OR. cable_user%or_evap) & - write(6,*) "GW or ORevepis not an option right now" +! write(6,*) "GW or ORevepis not an option right now" - commented out by rk4417 - phase2 !H! call pore_space_relative_humidity(ssnow,soil,veg) +! line above replaced by below - rk4417 - phase2 + CALL pore_space_relative_humidity(ssnow,soil,veg) IF (cable_user%soil_struc=='default') THEN @@ -499,7 +513,8 @@ SUBROUTINE define_canopy(bal,rad,rough,air,met,dels,ssnow,soil,veg, canopy,clima REAL(canopy%DvLitt), & ssnow%isflag, REAL(ssnow%satfrac),ssnow%rtsoil, & REAL(ssnow%rtevap_sat), REAL(ssnow%rtevap_unsat), & - ssnow%snowd, ssnow%tgg(:,1) ) + ssnow%snowd, ssnow%tgg(:,1), & + veg%iveg, rtevap_max, canopy%sublayer_dz, rt_Dff ) ! inserted by rk4417 - phase2 ENDIF @@ -511,12 +526,18 @@ SUBROUTINE define_canopy(bal,rad,rough,air,met,dels,ssnow,soil,veg, canopy,clima ssnow%snowd, ssnow%wb(:,1), ssnow%wbice(:,1), & ssnow%pudsto, ssnow%pudsmx, ssnow%potev, & ssnow%wetfac, ssnow%evapfbl(:,1), ssnow%cls, & - ssnow%tss, canopy%fes, canopy%fess, canopy%fesp ) + ssnow%tss, canopy%fes, canopy%fess, canopy%fesp, & + cable_user%gw_model, den_rat, soil%watr(:,1) ) ! line inserted by rk4417 - phase2 ! Calculate soil sensible heat: ! INH: I think this should be - met%tvair !canopy%fhs = air%rho*CCAPP*(ssnow%tss - met%tk) /ssnow%rtsoil - IF (cable_user%gw_model .OR. cable_user%or_evap) THEN + +! IF (cable_user%gw_model .OR. cable_user%or_evap) THEN ! MMY comment out since rt_qh_sublayer is only given value when or-on + ! rather than depends on cable_user%gw_model +! line above replaced by below - rk4417 - phase2 + IF (cable_user%or_evap) THEN ! MMY + canopy%fhs = air%rho*CCAPP*(ssnow%tss - met%tk) / & (ssnow%rtsoil + ssnow%rt_qh_sublayer) !note if or_evap and litter are true then litter resistance is @@ -533,11 +554,10 @@ SUBROUTINE define_canopy(bal,rad,rough,air,met,dels,ssnow,soil,veg, canopy,clima ELSE -write(6,*) "SLI is not an option right now" + write(6,*) "SLI is not an option right now" ! SLI SEB to get canopy%fhs, canopy%fess, canopy%ga ! (Based on old Tsoil, new canopy%tv, new canopy%fns) !H!CALL sli_main(1,dels,veg,soil,ssnow,met,canopy,air,rad,1) - ENDIF @@ -572,7 +592,8 @@ SUBROUTINE define_canopy(bal,rad,rough,air,met,dels,ssnow,soil,veg, canopy,clima REAL(canopy%DvLitt), & ssnow%isflag, REAL(ssnow%satfrac),ssnow%rtsoil, & REAL(ssnow%rtevap_sat), REAL(ssnow%rtevap_unsat), & - ssnow%snowd, ssnow%tgg(:,1) ) + ssnow%snowd, ssnow%tgg(:,1), & + veg%iveg, rtevap_max, canopy%sublayer_dz, rt_Dff ) ! inserted by rk4417 - phase2 ENDIF @@ -583,12 +604,18 @@ SUBROUTINE define_canopy(bal,rad,rough,air,met,dels,ssnow,soil,veg, canopy,clima ssnow%snowd, ssnow%wb(:,1), ssnow%wbice(:,1), & ssnow%pudsto, ssnow%pudsmx, ssnow%potev, & ssnow%wetfac, ssnow%evapfbl(:,1), ssnow%cls, & - ssnow%tss, canopy%fes, canopy%fess, canopy%fesp ) + ssnow%tss, canopy%fes, canopy%fess, canopy%fesp,& + cable_user%gw_model, den_rat, soil%watr(:,1) ) ! line inserted by rk4417 - phase2 ! Soil sensible heat: !canopy%fhs = air%rho*CCAPP*(ssnow%tss - met%tvair) /ssnow%rtsoil - IF (cable_user%gw_model .OR. cable_user%or_evap) THEN + +! IF (cable_user%gw_model .OR. cable_user%or_evap) THEN ! MMY comment out since rt_qh_sublayer is only given value when or-on + ! rather than depends on cable_user%gw_model +! line above replaced by below - rk4417 - phase2 + IF (cable_user%or_evap) THEN ! MMY + canopy%fhs = air%rho*CCAPP*(ssnow%tss - met%tvair) / & (ssnow%rtsoil + REAL(ssnow%rt_qh_sublayer)) @@ -609,11 +636,11 @@ SUBROUTINE define_canopy(bal,rad,rough,air,met,dels,ssnow,soil,veg, canopy,clima canopy%ga = canopy%fns-canopy%fhs-canopy%fes ! *ssnow%cls ELSE -write(6,*) "SLI is not an option right now" + write(6,*) "SLI is not an option right now" + ! SLI SEB to get canopy%fhs, canopy%fess, canopy%ga ! (Based on old Tsoil, new canopy%tv, new canopy%fns) !H!CALL sli_main(1,dels,veg,soil,ssnow,met,canopy,air,rad,1) - ENDIF ! Set total latent heat: @@ -649,7 +676,6 @@ SUBROUTINE define_canopy(bal,rad,rough,air,met,dels,ssnow,soil,veg, canopy,clima rad%transd*ssnow%potev*ssnow%cls) * dels/air%rlam - canopy%rniso = sum_rad_rniso + rad%qssabs + rad%transd*met%fld + & (1.0-rad%transd)*CEMLEAF* & CSBOLTZ*met%tvrad**4 - CEMSOIL*CSBOLTZ*met%tvrad**4 @@ -756,7 +782,7 @@ SUBROUTINE define_canopy(bal,rad,rough,air,met,dels,ssnow,soil,veg, canopy,clima ! ( EXP(2*CCSW*canopy%rghlai(j)) - term1(j) ) / term3(j) r_sc(j) = term5(j) * LOG(zscl(j)/rough%z0soilsn(j)) * & ( EXP(2*CCSW*canopy%rghlai(j)) - term2(j) ) / term3(j) - r_sc(j) = r_sc(j) + term5(j) * LOG(rough%disp(j)/zscl(j)) * & + r_sc(j) = r_sc(j) + term5(j) * LOG(rough%disp(j)/zscl(j)) * & ( EXP(2*CCSW*canopy%rghlai(j)) - term1(j) ) / term3(j) ELSEIF( rough%disp(j) <= zscl(j) .AND. & @@ -790,16 +816,35 @@ SUBROUTINE define_canopy(bal,rad,rough,air,met,dels,ssnow,soil,veg, canopy,clima ENDIF !extensions for litter and Or evaporation model - IF (cable_user%litter) THEN - canopy%tscrn(j) = ssnow%tss(j) + (met%tk(j) - ssnow%tss(j)) * & - MIN(1., ( (r_sc(j)+rhlitt(j)*canopy%us(j)) / MAX( 1., & - rough%rt0us(j) + rough%rt1usa(j) + rough%rt1usb(j) & - + rt1usc(j) + rhlitt(j)*canopy%us(j) )) ) - Ctfrz - ELSEIF (cable_user%or_evap .OR. cable_user%gw_model) THEN +! IF (cable_user%litter) THEN +! canopy%tscrn(j) = ssnow%tss(j) + (met%tk(j) - ssnow%tss(j)) * & +! MIN(1., ( (r_sc(j)+rhlitt(j)*canopy%us(j)) / MAX( 1., & +! rough%rt0us(j) + rough%rt1usa(j) + rough%rt1usb(j) & +! + rt1usc(j) + rhlitt(j)*canopy%us(j) )) ) - Ctfrz +! ELSEIF (cable_user%or_evap .OR. cable_user%gw_model) THEN +! canopy%tscrn(j) = ssnow%tss(j) + (met%tk(j) - ssnow%tss(j)) * & +! MIN(1., ( (ssnow%rt_qh_sublayer(j)*canopy%us(j) + r_sc(j) ) / & +! MAX( 1., rough%rt0us(j) + rough%rt1usa(j) + rough%rt1usb(j) & +! + rt1usc(j) + ssnow%rt_qh_sublayer(j)*canopy%us(j) )) ) - Ctfrz +! ELSE +! canopy%tscrn(j) = ssnow%tss(j) + (met%tk(j) - ssnow%tss(j)) * & +! MIN(1., (r_sc(j) / MAX( 1., & +! rough%rt0us(j) + rough%rt1usa(j) + rough%rt1usb(j) & +! + rt1usc(j))) ) - Ctfrz +! ENDIF + +! replaced above IF block by below - rk4417 - phase2 + + IF (cable_user%or_evap) THEN canopy%tscrn(j) = ssnow%tss(j) + (met%tk(j) - ssnow%tss(j)) * & MIN(1., ( (ssnow%rt_qh_sublayer(j)*canopy%us(j) + r_sc(j) ) / & MAX( 1., rough%rt0us(j) + rough%rt1usa(j) + rough%rt1usb(j) & + rt1usc(j) + ssnow%rt_qh_sublayer(j)*canopy%us(j) )) ) - Ctfrz + ELSEIF (cable_user%litter) THEN + canopy%tscrn(j) = ssnow%tss(j) + (met%tk(j) - ssnow%tss(j)) * & + MIN(1., ( (r_sc(j)+rhlitt(j)*canopy%us(j)) / MAX( 1., & + rough%rt0us(j) + rough%rt1usa(j) + rough%rt1usb(j) & + + rt1usc(j) + rhlitt(j)*canopy%us(j) )) ) - Ctfrz ELSE canopy%tscrn(j) = ssnow%tss(j) + (met%tk(j) - ssnow%tss(j)) * & MIN(1., (r_sc(j) / MAX( 1., & @@ -807,6 +852,7 @@ SUBROUTINE define_canopy(bal,rad,rough,air,met,dels,ssnow,soil,veg, canopy,clima + rt1usc(j))) ) - Ctfrz ENDIF + ENDIF ENDDO @@ -828,15 +874,37 @@ SUBROUTINE define_canopy(bal,rad,rough,air,met,dels,ssnow,soil,veg, canopy,clima canopy%qscrn(j) = met%qv(j) - qstar(j) * ftemp(j) IF( canopy%vlaiw(j) >CLAI_THRESH .AND. rough%hruff(j) > 0.01) THEN - IF (cable_user%litter) THEN - - !extensions for litter and Or model - canopy%qscrn(j) = qsurf(j) + (met%qv(j) - qsurf(j)) * & - MIN(1., ( ( r_sc(j)+relitt(j)*canopy%us(j) ) / MAX( 1., & - rough%rt0us(j) + rough%rt1usa(j) + rough%rt1usb(j) & - + rt1usc(j) + relitt(j)*canopy%us(j) )) ) - - ELSEIF (cable_user%or_evap .OR. cable_user%gw_model) THEN +! IF (cable_user%litter) THEN +! +! !extensions for litter and Or model +! canopy%qscrn(j) = qsurf(j) + (met%qv(j) - qsurf(j)) * & +! MIN(1., ( ( r_sc(j)+relitt(j)*canopy%us(j) ) / MAX( 1., & +! rough%rt0us(j) + rough%rt1usa(j) + rough%rt1usb(j) & +! + rt1usc(j) + relitt(j)*canopy%us(j) )) ) +! +! ELSEIF (cable_user%or_evap .OR. cable_user%gw_model) THEN +! !using alpm1 as a dumy variable +! alpm1(j) = REAL(& +! ssnow%satfrac(j)/(REAL(ssnow%rtsoil(j),r_2)+& +! ssnow%rtevap_sat(j)) & +! + (1.0-ssnow%satfrac(j))/(REAL(ssnow%rtsoil(j),r_2)+ ssnow%rtevap_unsat(j)) & +! ) +! +! canopy%qscrn(j) = qsurf(j) + (met%qv(j) - qsurf(j)) * & +! MIN(1., ( (r_sc(j) + canopy%us(j)/alpm1(j) ) / MAX( 1., & +! rough%rt0us(j) + rough%rt1usa(j) + rough%rt1usb(j) & +! + rt1usc(j) + canopy%us(j)/alpm1(j) )) ) +! +! ELSE +! canopy%qscrn(j) = qsurf(j) + (met%qv(j) - qsurf(j)) * & +! MIN(1., (r_sc(j) / MAX( 1., & +! rough%rt0us(j) + rough%rt1usa(j) + rough%rt1usb(j) & +! + rt1usc(j))) ) +! ENDIF + +! replaced above IF block by below - rk4417 - phase2 + + IF (cable_user%or_evap) THEN ! MMY !using alpm1 as a dumy variable alpm1(j) = REAL(& ssnow%satfrac(j)/(REAL(ssnow%rtsoil(j),r_2)+& @@ -848,7 +916,11 @@ SUBROUTINE define_canopy(bal,rad,rough,air,met,dels,ssnow,soil,veg, canopy,clima MIN(1., ( (r_sc(j) + canopy%us(j)/alpm1(j) ) / MAX( 1., & rough%rt0us(j) + rough%rt1usa(j) + rough%rt1usb(j) & + rt1usc(j) + canopy%us(j)/alpm1(j) )) ) - + ELSEIF (cable_user%litter) then ! MMY + canopy%qscrn(j) = qsurf(j) + (met%qv(j) - qsurf(j)) * & ! MMY + MIN(1., ( ( r_sc(j)+relitt(j)*canopy%us(j) ) / MAX( 1., & ! MMY + rough%rt0us(j) + rough%rt1usa(j) + rough%rt1usb(j) & ! MMY + + rt1usc(j) + relitt(j)*canopy%us(j) )) ) ! MMY ELSE canopy%qscrn(j) = qsurf(j) + (met%qv(j) - qsurf(j)) * & MIN(1., (r_sc(j) / MAX( 1., & @@ -904,99 +976,184 @@ SUBROUTINE define_canopy(bal,rad,rough,air,met,dels,ssnow,soil,veg, canopy,clima ENDWHERE ENDIF -IF (cable_user%gw_model .or. cable_user%or_evap) THEN - - ssnow%dfh_dtg = air%rho*CCAPP/(ssnow%rtsoil+ real(ssnow%rt_qh_sublayer)) - - ! INH simplifying code for legibility - !ssnow%dfe_ddq = real(ssnow%satfrac)*air%rho*air%rlam*ssnow%cls/ & - ! (ssnow%rtsoil+ real(ssnow%rtevap_sat)) + - ! (1.0-real(ssnow%satfrac))*real(ssnow%rh_srf)*& - ! air%rho*air%rlam*ssnow%cls/ (ssnow%rtsoil+ - ! real(ssnow%rtevap_unsat) ) - ssnow%dfe_ddq = real(ssnow%satfrac)/(ssnow%rtsoil+ real(ssnow%rtevap_sat)) & - + (1.0-real(ssnow%satfrac))*real(ssnow%rh_srf) & - / (ssnow%rtsoil+ real(ssnow%rtevap_unsat) ) - - !mrd561 fixes. Do same thing as INH but has been tested. - IF (cable_user%L_REV_CORR) THEN - alpm1 = real(ssnow%satfrac/(real(ssnow%rtsoil,r_2)+ ssnow%rtevap_sat) + & - (1.0-ssnow%satfrac) / (real(ssnow%rtsoil,r_2)+ ssnow%rtevap_unsat ) ) - beta2 = real(ssnow%satfrac/(real(ssnow%rtsoil,r_2)+ ssnow%rtevap_sat) + & - (1.0-ssnow%satfrac) * ssnow%rh_srf & - / (real(ssnow%rtsoil,r_2)+ ssnow%rtevap_unsat ) ) - WHERE (canopy%vlaiw > CLAI_THRESH) - alpm1 = alpm1 + 1._r_2/real(rough%rt1,r_2) - beta_div_alpm = beta2 / alpm1 !might need limit here - rttsoil = ssnow%rtsoil + rough%rt1 - ELSEWHERE!if there is no canopy then qa should not change - beta_div_alpm=0.0 !do not divide by aplm1 prevent issues - rttsoil = ssnow%rtsoil - ENDWHERE - ssnow%dfh_dtg = air%rho*CCAPP/(rttsoil + & - real(ssnow%rt_qh_sublayer)) - ssnow%dfe_ddq = real(ssnow%satfrac*(1.0-real(beta_div_alpm,r_2)) / & - (real(ssnow%rtsoil,r_2)+ ssnow%rtevap_sat) + & - (1.0-ssnow%satfrac)* (ssnow%rh_srf - real(beta_div_alpm,r_2)) / & - (real(ssnow%rtsoil,r_2)+ ssnow%rtevap_unsat ) ) - - ELSE ! IF (cable_user%L_REV_CORR) THEN - ssnow%dfh_dtg = air%rho*CCAPP/(ssnow%rtsoil+ real(ssnow%rt_qh_sublayer)) - ssnow%dfe_ddq = real(ssnow%satfrac)/(ssnow%rtsoil+ real(ssnow%rtevap_sat)) & - + (1.0-real(ssnow%satfrac))*real(ssnow%rh_srf) & - / (ssnow%rtsoil+ real(ssnow%rtevap_unsat) ) - ENDIF ! IF (cable_user%L_REV_CORR) THEN - - !cls applies for both REV_CORR false and true - ssnow%dfe_ddq = ssnow%dfe_ddq*air%rho*air%rlam*ssnow%cls - - !REV_CORR: factor %wetfac needed for potev>0. and gw_model &/or snow cover - !NB %wetfac=1. if or_evap - IF (cable_user%L_REV_CORR) THEN - WHERE (ssnow%potev >= 0.) - ssnow%dfe_ddq = ssnow%dfe_ddq*ssnow%wetfac - ENDWHERE - ENDIF - - -ELSEIF (cable_user%litter) THEN ! IF (cable_user%gw_model .or. cable_user%or_evap) THEN - !vh_js! INH simplifying code for legibility and REV_CORR - !ssnow%dfh_dtg = air%rho*CCAPP/(ssnow%rtsoil+ & - ! real((1-ssnow%isflag))*veg%clitt*0.003/canopy%kthLitt/(air%rho*CCAPP)) - !ssnow%dfe_ddq = ssnow%wetfac*air%rho*air%rlam*ssnow%cls/ & - ! (ssnow%rtsoil+ real((1-ssnow%isflag))*veg%clitt*0.003/canopy%DvLitt) - - !recalculated - probably not needed - rhlitt = real((1-ssnow%isflag))*veg%clitt*0.003/canopy%kthLitt/(air%rho*CCAPP) - relitt = real((1-ssnow%isflag))*veg%clitt*0.003/canopy%DvLitt - - !incorporates REV_CORR changes - ssnow%dfh_dtg = air%rho*CCAPP/(rttsoil+rhlitt) - ssnow%dfe_ddq = ssnow%wetfac*air%rho*air%rlam*ssnow%cls/(rttsoil+relitt) - - !REV_CORR: factor ssnow%wetfac is not applied if dew/frost i.e. potev<0 - IF (cable_user%L_REV_CORR) THEN - WHERE (ssnow%potev < 0.) - ssnow%dfe_ddq = air%rho*air%rlam*ssnow%cls/(rttsoil+relitt) - ENDWHERE - ENDIF - -ELSE ! i.e. NOT (%gw_model .or. %or_evap or SLI) - !ssnow%dfh_dtg = air%rho*CCAPP/ssnow%rtsoil - !ssnow%dfe_ddq = ssnow%wetfac*air%rho*air%rlam*ssnow%cls/ssnow%rtsoil - - !incorporates REV_CORR changes - ssnow%dfh_dtg = air%rho*CCAPP/rttsoil - ssnow%dfe_ddq = ssnow%wetfac*air%rho*air%rlam*ssnow%cls/rttsoil - - !REV_CORR: factor ssnow%wetfac is not applied if dew/frost i.e. potev<0 - IF (cable_user%L_REV_CORR) THEN - WHERE (ssnow%potev < 0.) - ssnow%dfe_ddq = air%rho*air%rlam*ssnow%cls/(rttsoil+relitt) - ENDWHERE - ENDIF - -ENDIF ! IF (cable_user%gw_model .or. cable_user%or_evap) THEN +!IF (cable_user%gw_model .or. cable_user%or_evap) THEN +! +! ssnow%dfh_dtg = air%rho*CCAPP/(ssnow%rtsoil+ real(ssnow%rt_qh_sublayer)) +! +! ! INH simplifying code for legibility +! !ssnow%dfe_ddq = real(ssnow%satfrac)*air%rho*air%rlam*ssnow%cls/ & +! ! (ssnow%rtsoil+ real(ssnow%rtevap_sat)) + +! ! (1.0-real(ssnow%satfrac))*real(ssnow%rh_srf)*& +! ! air%rho*air%rlam*ssnow%cls/ (ssnow%rtsoil+ +! ! real(ssnow%rtevap_unsat) ) +! ssnow%dfe_ddq = real(ssnow%satfrac)/(ssnow%rtsoil+ real(ssnow%rtevap_sat)) & +! + (1.0-real(ssnow%satfrac))*real(ssnow%rh_srf) & +! / (ssnow%rtsoil+ real(ssnow%rtevap_unsat) ) +! +! !mrd561 fixes. Do same thing as INH but has been tested. +! IF (cable_user%L_REV_CORR) THEN +! alpm1 = real(ssnow%satfrac/(real(ssnow%rtsoil,r_2)+ ssnow%rtevap_sat) + & +! (1.0-ssnow%satfrac) / (real(ssnow%rtsoil,r_2)+ ssnow%rtevap_unsat ) ) +! beta2 = real(ssnow%satfrac/(real(ssnow%rtsoil,r_2)+ ssnow%rtevap_sat) + & +! (1.0-ssnow%satfrac) * ssnow%rh_srf & +! / (real(ssnow%rtsoil,r_2)+ ssnow%rtevap_unsat ) ) +! WHERE (canopy%vlaiw > CLAI_THRESH) +! alpm1 = alpm1 + 1._r_2/real(rough%rt1,r_2) +! beta_div_alpm = beta2 / alpm1 !might need limit here +! rttsoil = ssnow%rtsoil + rough%rt1 +! ELSEWHERE!if there is no canopy then qa should not change +! beta_div_alpm=0.0 !do not divide by aplm1 prevent issues +! rttsoil = ssnow%rtsoil +! ENDWHERE +! ssnow%dfh_dtg = air%rho*CCAPP/(rttsoil + & +! real(ssnow%rt_qh_sublayer)) +! ssnow%dfe_ddq = real(ssnow%satfrac*(1.0-real(beta_div_alpm,r_2)) / & +! (real(ssnow%rtsoil,r_2)+ ssnow%rtevap_sat) + & +! (1.0-ssnow%satfrac)* (ssnow%rh_srf - real(beta_div_alpm,r_2)) / & +! (real(ssnow%rtsoil,r_2)+ ssnow%rtevap_unsat ) ) +! +! ELSE ! IF (cable_user%L_REV_CORR) THEN +! ssnow%dfh_dtg = air%rho*CCAPP/(ssnow%rtsoil+ real(ssnow%rt_qh_sublayer)) +! ssnow%dfe_ddq = real(ssnow%satfrac)/(ssnow%rtsoil+ real(ssnow%rtevap_sat)) & +! + (1.0-real(ssnow%satfrac))*real(ssnow%rh_srf) & +! / (ssnow%rtsoil+ real(ssnow%rtevap_unsat) ) +! ENDIF ! IF (cable_user%L_REV_CORR) THEN +! +! !cls applies for both REV_CORR false and true +! ssnow%dfe_ddq = ssnow%dfe_ddq*air%rho*air%rlam*ssnow%cls +! +! !REV_CORR: factor %wetfac needed for potev>0. and gw_model &/or snow cover +! !NB %wetfac=1. if or_evap +! IF (cable_user%L_REV_CORR) THEN +! WHERE (ssnow%potev >= 0.) +! ssnow%dfe_ddq = ssnow%dfe_ddq*ssnow%wetfac +! ENDWHERE +! ENDIF +! +! +!ELSEIF (cable_user%litter) THEN ! IF (cable_user%gw_model .or. cable_user%or_evap) THEN +! !vh_js! INH simplifying code for legibility and REV_CORR +! !ssnow%dfh_dtg = air%rho*CCAPP/(ssnow%rtsoil+ & +! ! real((1-ssnow%isflag))*veg%clitt*0.003/canopy%kthLitt/(air%rho*CCAPP)) +! !ssnow%dfe_ddq = ssnow%wetfac*air%rho*air%rlam*ssnow%cls/ & +! ! (ssnow%rtsoil+ real((1-ssnow%isflag))*veg%clitt*0.003/canopy%DvLitt) +! +! !recalculated - probably not needed +! rhlitt = real((1-ssnow%isflag))*veg%clitt*0.003/canopy%kthLitt/(air%rho*CCAPP) +! relitt = real((1-ssnow%isflag))*veg%clitt*0.003/canopy%DvLitt +! +! !incorporates REV_CORR changes +! ssnow%dfh_dtg = air%rho*CCAPP/(rttsoil+rhlitt) +! ssnow%dfe_ddq = ssnow%wetfac*air%rho*air%rlam*ssnow%cls/(rttsoil+relitt) +! +! !REV_CORR: factor ssnow%wetfac is not applied if dew/frost i.e. potev<0 +! IF (cable_user%L_REV_CORR) THEN +! WHERE (ssnow%potev < 0.) +! ssnow%dfe_ddq = air%rho*air%rlam*ssnow%cls/(rttsoil+relitt) +! ENDWHERE +! ENDIF +! +!ELSE ! i.e. NOT (%gw_model .or. %or_evap or SLI) +! !ssnow%dfh_dtg = air%rho*CCAPP/ssnow%rtsoil +! !ssnow%dfe_ddq = ssnow%wetfac*air%rho*air%rlam*ssnow%cls/ssnow%rtsoil +! +! !incorporates REV_CORR changes +! ssnow%dfh_dtg = air%rho*CCAPP/rttsoil +! ssnow%dfe_ddq = ssnow%wetfac*air%rho*air%rlam*ssnow%cls/rttsoil +! +! !REV_CORR: factor ssnow%wetfac is not applied if dew/frost i.e. potev<0 +! IF (cable_user%L_REV_CORR) THEN +! WHERE (ssnow%potev < 0.) +! ssnow%dfe_ddq = air%rho*air%rlam*ssnow%cls/(rttsoil+relitt) +! ENDWHERE +! ENDIF +! +!ENDIF ! IF (cable_user%gw_model .or. cable_user%or_evap) THEN + +! replaced above IF block by below - rk4417 - phase2 + + IF (cable_user%or_evap) THEN ! MMY + + !mrd561 fixes. Do same thing as INH but has been tested. + IF (cable_user%L_REV_CORR) THEN + alpm1 = REAL(ssnow%satfrac/(REAL(ssnow%rtsoil,r_2)+ ssnow%rtevap_sat) + & + (1.0-ssnow%satfrac) / (REAL(ssnow%rtsoil,r_2)+ ssnow%rtevap_unsat ) ) + beta2 = REAL(ssnow%satfrac/(REAL(ssnow%rtsoil,r_2)+ ssnow%rtevap_sat) + & + (1.0-ssnow%satfrac) * ssnow%rh_srf & + / (REAL(ssnow%rtsoil,r_2)+ ssnow%rtevap_unsat ) ) + WHERE (canopy%vlaiw > CLAI_THRESH) + alpm1 = alpm1 + 1._r_2/REAL(rough%rt1,r_2) + beta_div_alpm = beta2 / alpm1 !might need limit here + rttsoil = ssnow%rtsoil + rough%rt1 + ELSEWHERE!if there is no canopy then qa should not change + beta_div_alpm=0.0 !do not divide by aplm1 prevent issues + rttsoil = ssnow%rtsoil + ENDWHERE + ssnow%dfh_dtg = air%rho*CCAPP/(rttsoil + & + REAL(ssnow%rt_qh_sublayer)) + ssnow%dfe_ddq = REAL(ssnow%satfrac*(1.0-REAL(beta_div_alpm,r_2)) / & + (REAL(ssnow%rtsoil,r_2)+ ssnow%rtevap_sat) + & + (1.0-ssnow%satfrac)* (ssnow%rh_srf - REAL(beta_div_alpm,r_2)) / & + (REAL(ssnow%rtsoil,r_2)+ ssnow%rtevap_unsat ) ) + + ELSE + ssnow%dfh_dtg = air%rho*CCAPP/(ssnow%rtsoil+ REAL(ssnow%rt_qh_sublayer)) + + ssnow%dfe_ddq = REAL(ssnow%satfrac)/(ssnow%rtsoil+ REAL(ssnow%rtevap_sat)) & + + (1.0-REAL(ssnow%satfrac))*REAL(ssnow%rh_srf) & + / (ssnow%rtsoil+ REAL(ssnow%rtevap_unsat) ) + ENDIF + + !cls applies for both REV_CORR false and true + ssnow%dfe_ddq = ssnow%dfe_ddq*air%rho*air%rlam*ssnow%cls + + !REV_CORR: factor %wetfac needed for potev>0. and gw_model &/or snow cover + !NB %wetfac=1. if or_evap + IF (cable_user%L_REV_CORR) THEN + WHERE (ssnow%potev >= 0.) + ssnow%dfe_ddq = ssnow%dfe_ddq*ssnow%wetfac + ENDWHERE + ENDIF + + + ELSEIF (cable_user%litter) THEN + !vh_js! INH simplifying code for legibility and REV_CORR + !ssnow%dfh_dtg = air%rho*CCAPP/(ssnow%rtsoil+ & + ! real((1-ssnow%isflag))*veg%clitt*0.003/canopy%kthLitt/(air%rho*CCAPP)) + !ssnow%dfe_ddq = ssnow%wetfac*air%rho*air%rlam*ssnow%cls/ & + ! (ssnow%rtsoil+ real((1-ssnow%isflag))*veg%clitt*0.003/canopy%DvLitt) + + !recalculated - probably not needed + rhlitt = REAL((1-ssnow%isflag))*veg%clitt*0.003/canopy%kthLitt/(air%rho*CCAPP) + relitt = REAL((1-ssnow%isflag))*veg%clitt*0.003/canopy%DvLitt + + !incorporates REV_CORR changes + ssnow%dfh_dtg = air%rho*CCAPP/(rttsoil+rhlitt) + ssnow%dfe_ddq = ssnow%wetfac*air%rho*air%rlam*ssnow%cls/(rttsoil+relitt) + + !REV_CORR: factor ssnow%wetfac is not applied if dew/frost i.e. potev<0 + IF (cable_user%L_REV_CORR) THEN + WHERE (ssnow%potev < 0.) + ssnow%dfe_ddq = air%rho*air%rlam*ssnow%cls/(rttsoil+relitt) + ENDWHERE + ENDIF + + ELSE + !ssnow%dfh_dtg = air%rho*CCAPP/ssnow%rtsoil + !ssnow%dfe_ddq = ssnow%wetfac*air%rho*air%rlam*ssnow%cls/ssnow%rtsoil + + !incorporates REV_CORR changes + ssnow%dfh_dtg = air%rho*CCAPP/rttsoil + ssnow%dfe_ddq = ssnow%wetfac*air%rho*air%rlam*ssnow%cls/rttsoil + + !REV_CORR: factor ssnow%wetfac is not applied if dew/frost i.e. potev<0 + IF (cable_user%L_REV_CORR) THEN + WHERE (ssnow%potev < 0.) + ssnow%dfe_ddq = air%rho*air%rlam*ssnow%cls/(rttsoil+relitt) + ENDWHERE + ENDIF + + ENDIF ssnow%ddq_dtg = (Crmh2o/Crmair) /met%pmb * CTETENA*CTETENB * CTETENC & / ( ( CTETENC + ssnow%tss-Ctfrz )**2 )*EXP( CTETENB * & diff --git a/src/science/canopy/cbl_SurfaceWetness.F90 b/src/science/canopy/cbl_SurfaceWetness.F90 index f42961e15..9ac52addb 100644 --- a/src/science/canopy/cbl_SurfaceWetness.F90 +++ b/src/science/canopy/cbl_SurfaceWetness.F90 @@ -14,7 +14,9 @@ SUBROUTINE Surf_wetness_fact( cansat, canopy, ssnow,veg, met, soil, dels ) USE grid_constants_mod_cbl, ONLY : lakes_cable ! physical constants USE cable_phys_constants_mod, ONLY : CTFRZ => TFRZ - !H!USE cable_gw_hydro_module, ONLY : calc_srf_wet_fraction +!H!USE cable_gw_hydro_module, ONLY : calc_srf_wet_fraction +! line above uncommented by rk4417 - phase2 +USE cable_gw_hydro_module, ONLY : calc_srf_wet_fraction TYPE (veg_parameter_type), INTENT(INOUT) :: veg TYPE (soil_snow_type), INTENT(inout):: ssnow @@ -55,38 +57,44 @@ SUBROUTINE Surf_wetness_fact( cansat, canopy, ssnow,veg, met, soil, dels ) !calc the surface wetness for soil evap in this routine !include the default wetfac when or_evap and gw_model are not used -!H!gw n/a here and so copied default below -!H! CALL calc_srf_wet_fraction(ssnow,soil,met,veg) -!H! ELSE !Default formulation - - !call saturated_fraction(ssnow,soil,veg) - ssnow%satfrac(:) = 1.0e-8 - ssnow%rh_srf(:) = 1.0 - - ssnow%wetfac = MAX( 1.e-6, MIN( 1.0,& - ( REAL (ssnow%wb(:,1) ) - soil%swilt/ 2.0 ) & - / ( soil%sfc - soil%swilt/2.0 ) ) ) - - DO i=1,mp - - IF( ssnow%wbice(i,1) > 0. )& - ssnow%wetfac(i) = ssnow%wetfac(i) * & - real(MAX( 0.5_r_2, 1._r_2 - MIN( 0.2_r_2, & - ( ssnow%wbice(i,1) / ssnow%wb(i,1) )**2 ) ) ) - - IF( ssnow%snowd(i) > 0.1) ssnow%wetfac(i) = 0.9 - - IF ( veg%iveg(i) == lakes_cable .and. met%tk(i) >= Ctfrz + 5. ) & - ssnow%wetfac(i) = 1.0 - - IF( veg%iveg(i) == lakes_cable .and. met%tk(i) < Ctfrz + 5. ) & - ssnow%wetfac(i) = 0.7 - - ENDDO - ! owetfac introduced to reduce sharp changes in dry regions, - ! especially in offline runs in which there may be discrepancies b/n - ! timing of precip and temperature change (EAK apr2009) - ssnow%wetfac = 0.5*(ssnow%wetfac + ssnow%owetfac) + + + CALL calc_srf_wet_fraction(ssnow,soil,met,veg) + +! line above replaces remaining code below - rk4417 - phase2 + +! !H!gw n/a here and so copied default below +! !H! CALL calc_srf_wet_fraction(ssnow,soil,met,veg) +! !H! ELSE !Default formulation +! +! !call saturated_fraction(ssnow,soil,veg) +! ssnow%satfrac(:) = 1.0e-8 +! ssnow%rh_srf(:) = 1.0 +! +! ssnow%wetfac = MAX( 1.e-6, MIN( 1.0,& +! ( REAL (ssnow%wb(:,1) ) - soil%swilt/ 2.0 ) & +! / ( soil%sfc - soil%swilt/2.0 ) ) ) +! +! DO i=1,mp +! +! IF( ssnow%wbice(i,1) > 0. )& +! ssnow%wetfac(i) = ssnow%wetfac(i) * & +! real(MAX( 0.5_r_2, 1._r_2 - MIN( 0.2_r_2, & +! ( ssnow%wbice(i,1) / ssnow%wb(i,1) )**2 ) ) ) +! +! IF( ssnow%snowd(i) > 0.1) ssnow%wetfac(i) = 0.9 +! +! IF ( veg%iveg(i) == lakes_cable .and. met%tk(i) >= Ctfrz + 5. ) & +! ssnow%wetfac(i) = 1.0 +! +! IF( veg%iveg(i) == lakes_cable .and. met%tk(i) < Ctfrz + 5. ) & +! ssnow%wetfac(i) = 0.7 +! +! ENDDO +! ! owetfac introduced to reduce sharp changes in dry regions, +! ! especially in offline runs in which there may be discrepancies b/n +! ! timing of precip and temperature change (EAK apr2009) +! ssnow%wetfac = 0.5*(ssnow%wetfac + ssnow%owetfac) END SUBROUTINE Surf_wetness_fact diff --git a/src/science/canopy/cbl_dryLeaf.F90 b/src/science/canopy/cbl_dryLeaf.F90 index c9d5dea8c..547418f24 100644 --- a/src/science/canopy/cbl_dryLeaf.F90 +++ b/src/science/canopy/cbl_dryLeaf.F90 @@ -136,6 +136,10 @@ SUBROUTINE dryLeaf( dels, rad, rough, air, met, & REAL, DIMENSION(mp,2) :: gsw_term, lower_limit2 ! local temp var +! Two lines inserted below - rk4417 - phase2 + REAL, DIMENSION(0:ms+1) :: diff ! MMY ! Martin's fix on water extraction from soil + REAL :: xx,xxd ! MMY + INTEGER :: i, j, k, kk ! iteration count REAL :: vpd, g1 ! Ticket #56 REAL, DIMENSION(mp,mf) :: & @@ -227,6 +231,11 @@ SUBROUTINE dryLeaf( dels, rad, rough, air, met, & gwwet(i) = 1.075 * sum_gbh(i) ghrwet(i) = sum_rad_gradis(i) + ghwet(i) +! I checked with Claire...appears fine commented out - rk4417 - phase2 +! ! Calculate fraction of canopy which is wet: ! inserted by rk4417 - phase2 +! canopy%fwet(i) = MAX( 0.0, MIN( 1.0, 0.8 * canopy%cansto(i)/ MAX( & +! cansat(i),0.01 ) ) ) + ! Calculate lat heat from wet canopy, may be neg. ! if dew on wet canopy to avoid excessive evaporation: ccfevw(i) = MIN(canopy%cansto(i) * air%rlam(i) / dels, & @@ -508,14 +517,36 @@ SUBROUTINE dryLeaf( dels, rad, rough, air, met, & evapfb(i) = ( 1.0 - canopy%fwet(i)) * REAL( ecx(i) ) *dels & / air%rlam(i) +! DO kk = 1,ms +! +! ssnow%evapfbl(i,kk) = MIN( evapfb(i) * veg%froot(i,kk), & +! MAX( 0.0, REAL( ssnow%wb(i,kk) ) - & +! 1.1 * soil%swilt(i) ) * & +! soil%zse(kk) * 1000.0 ) +! +! ENDDO + +! block above replaced by below - rk4417 - phase2 + ! MMY to fix the inconsistence in root water extraction between ! FEEDBACK(MMY?) + ! cable_gw_hydro and above + xx = 0._r_2 ! demand : transpiration + xxd = 0._r_2 ! difference : demand - supply + diff(:) = 0._r_2 ! supply : water available DO kk = 1,ms + xx = evapfb(i) * veg%froot(i,kk) + diff(kk-1) ! demand for layer kk + diff(kk) = max(0._r_2,ssnow%wbliq(i,kk)-soil%swilt_vec(i,kk)) * soil%zse(kk) * 1000.0 + ! supply for layer kk + xxd = xx - diff(kk) ! deficit in layer kk + if (xxd .gt. 0._r_2) then ! demand > supply + ssnow%evapfbl(i,kk) = diff(kk) ! transpiration in layer kk is supply + diff(kk) = xxd ! deficit in layer kk + else ! demand < supply + ssnow%evapfbl(i,kk) = xx ! transpiration in layer kk is demand + diff(kk) = 0._r_2 ! no deficit in layer kk + end if + END DO !ms +! end of replacement block - rk4417 - phase2 - ssnow%evapfbl(i,kk) = MIN( evapfb(i) * veg%froot(i,kk), & - MAX( 0.0, REAL( ssnow%wb(i,kk) ) - & - 1.1 * soil%swilt(i) ) * & - soil%zse(kk) * 1000.0 ) - - ENDDO IF (cable_user%soil_struc=='default') THEN canopy%fevc(i) = SUM(ssnow%evapfbl(i,:))*air%rlam(i)/dels ecx(i) = canopy%fevc(i) / (1.0-canopy%fwet(i)) diff --git a/src/science/canopy/cbl_fwsoil.F90 b/src/science/canopy/cbl_fwsoil.F90 index 4e25e0854..86b2df549 100644 --- a/src/science/canopy/cbl_fwsoil.F90 +++ b/src/science/canopy/cbl_fwsoil.F90 @@ -25,14 +25,38 @@ SUBROUTINE fwsoil_calc_std(fwsoil, soil, ssnow, veg) IF (.NOT.cable_user%gw_model) THEN +! rwater = MAX(1.0e-9, & +! SUM(veg%froot * MAX(1.0e-9,MIN(1.0, REAL(ssnow%wb) - & +! SPREAD(soil%swilt, 2, ms))),2) /(soil%sfc-soil%swilt)) +! +! ELSE +! rwater = MAX(1.0e-9, & +! SUM(veg%froot * MAX(1.0e-9,MIN(1.0, REAL((ssnow%wbliq - & +! soil%swilt_vec)/(soil%sfc_vec-soil%swilt_vec)) )),2) ) + +! block above replaced by below - rk4417 - phase2 + + ! ________________________________ MMY______________________________________ + !rwater = MAX(1.0e-9, & + ! SUM(veg%froot * MAX(1.0e-9,MIN(1.0, real(ssnow%wb) - & + ! SPREAD(soil%swilt, 2, ms))),2) /(soil%sfc-soil%swilt)) + ! fix range problems rwater = MAX(1.0e-9, & - SUM(veg%froot * MAX(1.0e-9,MIN(1.0, REAL(ssnow%wb) - & - SPREAD(soil%swilt, 2, ms))),2) /(soil%sfc-soil%swilt)) - - ELSE + SUM(veg%froot * MAX(1.0e-9, MIN( 1.0, & + MAX(0., (real(ssnow%wb) - SPREAD(soil%swilt, 2, ms)) )& + / (SPREAD(soil%sfc, 2, ms) - SPREAD(soil%swilt, 2, ms)) & + )) , 2)) + ! MMY I didn't check gw-off, but think using wbliq may be better than wb above eq + else + ! rwater = MAX(1.0e-9, & + ! SUM(veg%froot * MAX(1.0e-9,MIN(1.0, real((ssnow%wbliq - & + ! soil%swilt_vec)/(soil%sfc_vec-soil%swilt_vec)) )),2) ) rwater = MAX(1.0e-9, & - SUM(veg%froot * MAX(1.0e-9,MIN(1.0, REAL((ssnow%wbliq - & - soil%swilt_vec)/(soil%sfc_vec-soil%swilt_vec)) )),2) ) + SUM(veg%froot * MAX(1.0e-9, MIN( 1.0, & + MAX(0., (real(ssnow%wbliq) - real(soil%swilt_vec)) )& + / (real(soil%sfc_vec) - real(soil%swilt_vec)) & + )) , 2)) + ! __________________________________________________________________________ ENDIF @@ -58,9 +82,17 @@ SUBROUTINE fwsoil_calc_non_linear(fwsoil, soil, ssnow, veg) REAL, DIMENSION(mp,3) :: xi, ti, si INTEGER :: j - rwater = MAX(1.0e-9, & - SUM(veg%froot * MAX(0.0,MIN(1.0, REAL(ssnow%wb) - & - SPREAD(soil%swilt, 2, ms))),2) /(soil%sfc-soil%swilt)) +! rwater = MAX(1.0e-9, & +! SUM(veg%froot * MAX(0.0,MIN(1.0, REAL(ssnow%wb) - & +! SPREAD(soil%swilt, 2, ms))),2) /(soil%sfc-soil%swilt)) + +! block above replaced by below - rk4417 - phase2 + + rwater = MAX(1.0e-9, & + SUM(veg%froot * MAX(1.0e-9, MIN( 1.0, & + MAX(0., (real(ssnow%wb) - SPREAD(soil%swilt, 2, ms)) ) & + / (SPREAD(soil%sfc, 2, ms) - SPREAD(soil%swilt, 2, ms)) & + )) , 2)) fwsoil = 1. diff --git a/src/science/canopy/cbl_latent_heat.F90 b/src/science/canopy/cbl_latent_heat.F90 index 040828830..73fedbce1 100644 --- a/src/science/canopy/cbl_latent_heat.F90 +++ b/src/science/canopy/cbl_latent_heat.F90 @@ -17,7 +17,8 @@ SUBROUTINE Latent_heat_flux( mp, CTFRZ, dels, soil_zse, soil_swilt, & ssnow_snowd, ssnow_wb, ssnow_wbice, & ssnow_pudsto, ssnow_pudsmx, ssnow_potev, & ssnow_wetfac, ssnow_evapfbl, ssnow_cls, & - ssnow_tss, canopy_fes, canopy_fess, canopy_fesp ) + ssnow_tss, canopy_fes, canopy_fess, canopy_fesp, & + cable_user_gw_model, den_rat, soil_watr ) ! line inserted by rk4417 - phase2 !*## Purpose ! @@ -98,6 +99,14 @@ SUBROUTINE Latent_heat_flux( mp, CTFRZ, dels, soil_zse, soil_swilt, & INTEGER :: j +REAL(KIND=r_2), INTENT(IN) :: soil_watr(mp) ! line inserted by rk4417 - phase2 +!! residual water content of the soil (mm\(^{3}\)/mm\(^{3}\)) + +LOGICAL , INTENT(IN) :: cable_user_gw_model ! line inserted by rk4417 - phase2 +!! NAMELIST switch for gw model + +REAL(r_2) :: den_rat ! line inserted by rk4417 - phase2 + !|## Method ! ! 'Potential evaporation' quantifies the theoretical value of evaporation from @@ -189,12 +198,29 @@ SUBROUTINE Latent_heat_flux( mp, CTFRZ, dels, soil_zse, soil_swilt, & ! switch. ! The options differ in the amount of water that remains at the end of the time step. ! - IF (.NOT.cable_user_l_new_reduce_soilevp) THEN - flower_limit(j) = REAL(ssnow_wb(j))-soil_swilt(j)/2.0 - ELSE - ! E.Kowalczyk 2014 - reduces the soil evaporation - flower_limit(j) = REAL(ssnow_wb(j))-soil_swilt(j) - ENDIF + +! IF (.NOT.cable_user_l_new_reduce_soilevp) THEN +! flower_limit(j) = REAL(ssnow_wb(j))-soil_swilt(j)/2.0 +! ELSE +! ! E.Kowalczyk 2014 - reduces the soil evaporation +! flower_limit(j) = REAL(ssnow_wb(j))-soil_swilt(j) +! ENDIF + +! replaced IF block above by below - rk4417 - phase2 + + IF (.NOT.cable_user_l_new_reduce_soilevp) THEN + IF (cable_user_gw_model) THEN ! MMY + flower_limit(j) = REAL(ssnow_wb(j))-REAL(soil_watr(j)) ! MMY + ! MMY watr is better than swilt/2., as it has a clear physical meaning + ELSE ! MMY + flower_limit(j) = REAL(ssnow_wb(j))-soil_swilt(j)/2.0 + END IF ! MMY + ELSE + ! E.Kowalczyk 2014 - reduces the soil evaporation + flower_limit(j) = REAL(ssnow_wb(j))-soil_swilt(j) + ENDIF + + fupper_limit(j) = MAX( 0., & flower_limit(j) * frescale(j) & - ssnow_evapfbl(j)*air_rlam(j)/dels) @@ -208,7 +234,10 @@ SUBROUTINE Latent_heat_flux( mp, CTFRZ, dels, soil_zse, soil_swilt, & ! soil latent flux. **WARNING** frozen_limit=0.85 is hard coded - if it is changed ! then the corresponding limit in [[cbl_soilsnow]] must also be changed. ! - fupper_limit(j) = REAL(ssnow_wb(j)-ssnow_wbice(j)/0.85)*frescale(j) + +! fupper_limit(j) = REAL(ssnow_wb(j)-ssnow_wbice(j)/0.85)*frescale(j) +! replaced line above by below - rk4417 - phase2 + fupper_limit(j) = REAL(ssnow_wb(j)-ssnow_wbice(j)*den_rat/0.85)*frescale(j) ! MMY keep fupper_limit consistent fupper_limit(j) = MAX(REAL(fupper_limit(j),r_2),0.) canopy_fess(j) = MIN(canopy_fess(j), REAL(fupper_limit(j),r_2)) diff --git a/src/science/canopy/cbl_pot_evap_snow.F90 b/src/science/canopy/cbl_pot_evap_snow.F90 index 0cc8cccd8..248f67942 100644 --- a/src/science/canopy/cbl_pot_evap_snow.F90 +++ b/src/science/canopy/cbl_pot_evap_snow.F90 @@ -83,8 +83,13 @@ FUNCTION Humidity_deficit_method( mp, Ctfrz, veg_clitt,cable_user_or_evap, & canopy_DvLitt, & ssnow_isflag, ssnow_satfrac, ssnow_rtsoil, & ssnow_rtevap_sat, ssnow_rtevap_unsat, & - ssnow_snowd, ssnow_tgg & + ssnow_snowd, ssnow_tgg, & + veg_iveg, rtevap_max, canopy_sublayer_dz, & ! inserted by rk4417 - phase2 + rt_Dff & ! inserted by rk4417 - phase2 ) RESULT(ssnowpotev) + +USE cable_def_types_mod, ONLY : r_2 ! inserted by rk4417 - phase2 + IMPLICIT NONE INTEGER :: mp @@ -107,6 +112,11 @@ FUNCTION Humidity_deficit_method( mp, Ctfrz, veg_clitt,cable_user_or_evap, & REAL :: ssnow_rtevap_sat(mp) ! REAL :: ssnow_rtevap_unsat(mp) ! +INTEGER :: veg_iveg(mp) ! inserted by rk4417 - phase2 +REAL(r_2) :: rtevap_max ! inserted by rk4417 - phase2 +REAL(r_2) :: canopy_sublayer_dz(mp) ! inserted by rk4417 - phase2 +REAL(r_2) :: rt_Dff ! inserted by rk4417 - phase2 + !local vars INTEGER :: j REAL, DIMENSION(mp) :: q_air @@ -129,26 +139,46 @@ FUNCTION Humidity_deficit_method( mp, Ctfrz, veg_clitt,cable_user_or_evap, & ENDIF ENDDO -IF (cable_user_or_evap .or. cable_user_gw_model) then - write(6,*) "GW or ORevepis not an option right now" - !H! IF (cable_user_or_evap) THEN - !H! do j=1,mp - !H! - !H! if (veg_iveg(j) .lt. 16 .and. ssnow_snowd(j) .lt. 1e-7) THEN - !H! - !H! if (dq(j) .le. 0.0) THEN - !H! ssnow_rtevap_sat(j) = min(rtevap_max,canopy_sublayer_dz(j)/rt_Dff) - !H! end if - !H! - !H! if (dqu(j) .le. 0.0) THEN - !H! ssnow_rtevap_unsat(j) = min(rtevap_max,canopy_sublayer_dz(j)/rt_Dff) - !H! end if - !H! - !H! end if - !H! - !H! end do - !H! - !H! END IF +!IF (cable_user_or_evap .or. cable_user_gw_model) then +! write(6,*) "GW or ORevepis not an option right now" +! !H! IF (cable_user_or_evap) THEN +! !H! do j=1,mp +! !H! +! !H! if (veg_iveg(j) .lt. 16 .and. ssnow_snowd(j) .lt. 1e-7) THEN +! !H! +! !H! if (dq(j) .le. 0.0) THEN +! !H! ssnow_rtevap_sat(j) = min(rtevap_max,canopy_sublayer_dz(j)/rt_Dff) +! !H! end if +! !H! +! !H! if (dqu(j) .le. 0.0) THEN +! !H! ssnow_rtevap_unsat(j) = min(rtevap_max,canopy_sublayer_dz(j)/rt_Dff) +! !H! end if +! !H! +! !H! end if +! !H! +! !H! end do +! !H! +! !H! END IF + +! block above replaced by below - rk4417 - phase2 + + IF (cable_user_or_evap) THEN ! .or. cable_user_gw_model) then ! MMY + + DO j=1,mp + + IF (veg_iveg(j) .LT. 16 .AND. ssnow_snowd(j) .LT. 1e-7) THEN + + IF (dq(j) .LE. 0.0) THEN + ssnow_rtevap_sat(j) = MIN(rtevap_max,canopy_sublayer_dz(j)/rt_Dff) + END IF + + IF (dqu(j) .LE. 0.0) THEN + ssnow_rtevap_unsat(j) = MIN(rtevap_max,canopy_sublayer_dz(j)/rt_Dff) + END IF + + END IF + + END DO ssnowpotev = air_rho * air_rlam * ( & REAL(ssnow_satfrac) * dq /(ssnow_rtsoil + REAL(ssnow_rtevap_sat)) + & @@ -161,7 +191,7 @@ FUNCTION Humidity_deficit_method( mp, Ctfrz, veg_clitt,cable_user_or_evap, & REAL((1-ssnow_isflag))* veg_clitt*0.003/canopy_DvLitt) ELSE ssnowpotev = air_rho * air_rlam * dq / ssnow_rtsoil - ENDIF +ENDIF RETURN END FUNCTION Humidity_deficit_method diff --git a/src/science/canopy/cbl_wetleaf.F90 b/src/science/canopy/cbl_wetleaf.F90 index a2f223b9e..505a03e1e 100644 --- a/src/science/canopy/cbl_wetleaf.F90 +++ b/src/science/canopy/cbl_wetleaf.F90 @@ -56,7 +56,7 @@ SUBROUTINE wetLeaf( dels, cansat, tlfy, & !i sums, terms of convenience/readability REAL, DIMENSION(mp) :: & - sum_gbh, xx1 + sum_gbh, xx1 ! xx1 not used - rk4417 - phase2 INTEGER :: j diff --git a/src/science/gw_hydro/cable_psm.F90 b/src/science/gw_hydro/cable_psm.F90 index ac4d201e1..eac390cd8 100644 --- a/src/science/gw_hydro/cable_psm.F90 +++ b/src/science/gw_hydro/cable_psm.F90 @@ -5,6 +5,8 @@ MODULE cable_psm roughness_type USE cable_common_module, ONLY : cable_user +! USE grid_constants_mod_cbl, ONLY : lakes_cable ! should include this line to replace 16 everywhere below with lakes_cable - rk4417 + IMPLICIT NONE @@ -14,6 +16,8 @@ MODULE cable_psm litter_thermal_diff=2.7e-5 !param based on vh thermal diffusivity REAL(r_2), PARAMETER :: rtevap_max = 10000.0 +! these precomputed values are taken by the sample code in Wikipedia, +! and the sample itself takes them from the GNU Scientific Library ! comment inserted by rk4417 - phase2 REAL(r_2), DIMENSION(0:8), PARAMETER :: gamma_pre = & (/ 0.99999999999980993, 676.5203681218851, -1259.1392167224028, & 771.32342877765313, -176.61502916214059, 12.507343278686905, & @@ -69,7 +73,8 @@ SUBROUTINE or_soil_evap_resistance(soil,air,met,canopy,ssnow,veg,rough) - REAL(r_2), DIMENSION(mp) :: sublayer_dz, eddy_shape,eddy_mod,soil_moisture_mod, & +! REAL(r_2), DIMENSION(mp) :: sublayer_dz, eddy_shape,eddy_mod,soil_moisture_mod, & + REAL(r_2), DIMENSION(mp) :: eddy_shape,eddy_mod,soil_moisture_mod, & ! sublayer_dz is not used - rk4417 - phase2 soil_moisture_mod_sat, wb_liq, & pore_size,pore_radius, rel_s,hk_zero,hk_zero_sat,time_scale !note pore_size in m @@ -81,22 +86,48 @@ SUBROUTINE or_soil_evap_resistance(soil,air,met,canopy,ssnow,veg,rough) INTEGER :: i,j,k - IF (cable_user%litter) THEN - litter_dz(:) = veg%clitt*0.003 - ELSE - litter_dz(:) = 0.0 - ENDIF +! canopy%sublayer_dz(:) = 0.005 ! this line appears in MMY code but will leave commented for now -- rk4417 ! MMY@23Apr2023 need to check whether it should be commented + +! IF (cable_user%litter) THEN +! litter_dz(:) = veg%clitt*0.003 +! ELSE +! litter_dz(:) = 0.0 +! ENDIF + +! replaced above block by below - rk4417 - phase2 + + litter_dz(:) = 0.0 + if (cable_user%litter) then + where (ssnow%isflag .eq. 0 .or. ssnow%snowd .le. 0.1) + litter_dz(:) = veg%clitt*0.003 + endwhere + endif + pore_radius(:) = 0.148 / (1000.0*9.81*ABS(soil%sucs_vec(:,1))/1000.0) !should replace 0.148 with surface tension, unit coversion, and angle pore_size(:) = pore_radius(:)*SQRT((pi_r_2)) !scale ustar according to the exponential wind profile, assuming we are a mm from the surface - eddy_shape = 0.3*met%ua/ MAX(1.0e-4,MAX(1.0e-3,canopy%us)*& - EXP(-rough%coexp*(1.0-canopy%sublayer_dz/MAX(1e-2,rough%hruff)))) - int_eddy_shape = FLOOR(eddy_shape) - eddy_mod(:) = 0.0 + +! eddy_shape = 0.3*met%ua/ MAX(1.0e-4,MAX(1.0e-3,canopy%us)*& +! EXP(-rough%coexp*(1.0-canopy%sublayer_dz/MAX(1e-2,rough%hruff)))) +! int_eddy_shape = FLOOR(eddy_shape) +! eddy_mod(:) = 0.0 + +! replaced above block by below - rk4417 - phase2 + + eddy_mod(:) = 0.0 + eddy_shape(:) = 1.0 + int_eddy_shape(:) = 0 + DO i=1,mp - IF (veg%iveg(i) .LT. 16) THEN + IF (veg%iveg(i) .LT. 16) THEN ! should probably replace 16 with lakes_cable - rk4417 + +! 2 statements below inserted by rk4417 - phase2 + eddy_shape(i) = 0.3*met%ua(i)/ max(1.0e-4,max(1.0e-3,canopy%us(i))*& + exp(-rough%coexp(i)*(1.0-canopy%sublayer_dz(i)/max(1e-2,rough%hruff(i))))) + int_eddy_shape(i) = floor(eddy_shape(i)) + eddy_mod(i) = 2.2*SQRT(112.0*(pi_r_2)) / (2.0**(eddy_shape(i)+1.0) * SQRT(eddy_shape(i)+1.0)) IF (int_eddy_shape(i) .GT. 0) THEN @@ -117,7 +148,7 @@ SUBROUTINE or_soil_evap_resistance(soil,air,met,canopy,ssnow,veg,rough) END DO DO i=1,mp - IF (veg%iveg(i) .LT. 16) THEN + IF (veg%iveg(i) .LT. 16) THEN ! should probably replace 16 with lakes_cable - rk4417 wb_liq(i) = REAL(MAX(0.0001,MIN((pi_r_2)/4.0, & (ssnow%wb(i,1)-ssnow%wbice(i,1) - ssnow%satfrac(i)*soil%ssat_vec(i,1)) / & @@ -168,7 +199,7 @@ SUBROUTINE or_soil_evap_resistance(soil,air,met,canopy,ssnow,veg,rough) ssnow%rtevap_unsat(i) = 0.0 ssnow%rt_qh_sublayer(i) = 0.0 ssnow%satfrac(i) = 0.5 - IF (veg%iveg(i) .EQ. 16 .AND. met%tk(i) .LT. 268.15 ) & + IF (veg%iveg(i) .EQ. 16 .AND. met%tk(i) .LT. 268.15 ) & ! should probably replace 16 with lakes_cable - rk4417 ssnow%rtevap_sat(i) = 0.41*ssnow%rtsoil(i) END IF @@ -192,7 +223,7 @@ SUBROUTINE update_or_soil_resis(ssnow,canopy,veg,dq,dqu) DO i=1,mp - IF (veg%iveg(i) .LT. 16 .AND. ssnow%snowd(i) .LT. 1e-7) THEN + IF (veg%iveg(i) .LT. 16 .AND. ssnow%snowd(i) .LT. 1e-7) THEN ! should probably replace 16 with lakes_cable - rk4417 IF (dq(i) .LE. 0.0) THEN ssnow%rtevap_sat(i) = MIN(rtevap_max,canopy%sublayer_dz(i)/rt_Dff) diff --git a/src/science/soilsnow/cbl_GW.F90 b/src/science/soilsnow/cbl_GW.F90 index 6511b3017..7356dea43 100644 --- a/src/science/soilsnow/cbl_GW.F90 +++ b/src/science/soilsnow/cbl_GW.F90 @@ -7,6 +7,10 @@ MODULE GWstempv_mod CONTAINS SUBROUTINE GWstempv(dels, canopy, ssnow, soil) + +!*## Purpose +! updates soil temp and ground heat flux + USE cable_common_module, ONLY: cable_user USE total_soil_conductivity_mod, ONLY: total_soil_conductivity USE old_soil_conductivity_mod, ONLY: old_soil_conductivity @@ -19,19 +23,22 @@ SUBROUTINE GWstempv(dels, canopy, ssnow, soil) TYPE(soil_parameter_type), INTENT(INOUT) :: soil - REAL, DIMENSION(mp) :: & +! REAL, DIMENSION(mp) :: & ! rk4417 - phase2 + REAL(r_2), DIMENSION(mp) :: & coefa, coefb, & ! sgamm ! - REAL, DIMENSION(mp) :: & +! REAL, DIMENSION(mp) :: & ! rk4417 - phase2 + REAL(r_2), DIMENSION(mp) :: & dtg, & ! - ew, & ! - xx, & ! - wblfsp ! +! ew, & ! not used ! rk4417 - phase2 + xx !, & ! +! wblfsp ! not used ! rk4417 - phase2 REAL(r_2), DIMENSION(mp,ms) :: & - ccnsw ! soil thermal conductivity (incl water/ice) - + ccnsw,& ! soil thermal conductivity (incl water/ice) + gammzz_snow + REAL(r_2), DIMENSION(mp, -2:ms) :: & at, bt, ct, rhs ! @@ -39,15 +46,28 @@ SUBROUTINE GWstempv(dels, canopy, ssnow, soil) REAL(r_2), DIMENSION(mp,ms+3) :: tmp_mat ! temp. matrix for tggsn & tgg - INTEGER :: j,k - REAL :: exp_arg + INTEGER :: j,k,i + REAL(r_2) :: exp_arg,dels_r2 LOGICAL :: direct2min = .FALSE. - at = 0.0 - bt = 1.0 - ct = 0.0 - coeff = 0.0 + dels_r2 = real(dels,r_2) ! rk4417 - phase2 + + at = 0._r_2 ! MMY@23Apr2023 are these taken from CABLE-GW? + bt = 1._r_2 ! accept them gammzz_snow is used the eq later + ct = 0._r_2 + coeff = 0._r_2 + + ssnow%otgg(:,:) = ssnow%tgg(:,:) ! MMY??? ssnow%otgg has gotten value in SUBROUTINE soil_snow_gw before call snow_processes_soil_thermal + + gammzz_snow(:,:) = 0._r_2 + + k=1 + do i=1,mp + if (ssnow%isflag(i) .ne. 0) then + gammzz_snow(i,k) = real(Ccgsnow * ssnow%snowd(i),r_2) + end if + end do IF (cable_user%soil_thermal_fix) THEN @@ -60,76 +80,159 @@ SUBROUTINE GWstempv(dels, canopy, ssnow, soil) xx(:) = 0. +! WHERE(ssnow%isflag == 0) ! rk4417 - phase2 +! xx(:) = MAX( 0., ssnow%snowd / ssnow%ssdnn ) +! ccnsw(:,1) = ( ccnsw(:,1) - 0.2 ) * ( soil%zse(1) / ( soil%zse(1) + xx(:) ) & +! ) + 0.2 +! END WHERE + WHERE(ssnow%isflag == 0) - xx(:) = MAX( 0., ssnow%snowd / ssnow%ssdnn ) - ccnsw(:,1) = ( ccnsw(:,1) - 0.2 ) * ( soil%zse(1) / ( soil%zse(1) + xx(:) ) & - ) + 0.2 + xx(:) = MAX( 0._r_2, real(ssnow%snowd / ssnow%ssdnn,r_2) ) + ccnsw(:,1) = ( ccnsw(:,1) - 0.2_r_2 ) * ( soil%zse_vec(:,1) / ( soil%zse_vec(:,1) + xx(:) ) & + ) + 0.2_r_2 END WHERE + +! DO k = 3, ms ! rk4417 - phase2 +! WHERE (ssnow%isflag == 0) +! coeff(:,k) = 2.0 / ( soil%zse(k-1) / ccnsw(:,k-1) + soil%zse(k) / & +! ccnsw(:,k) ) +! END WHERE +! END DO DO k = 3, ms - WHERE (ssnow%isflag == 0) - coeff(:,k) = 2.0 / ( soil%zse(k-1) / ccnsw(:,k-1) + soil%zse(k) / & + coeff(:,k) = 2.0 / ( soil%zse_vec(:,k-1) / ccnsw(:,k-1) + soil%zse_vec(:,k) / & ccnsw(:,k) ) END WHERE END DO + +! k = 1 ! rk4417 - phase2 +! WHERE( ssnow%isflag == 0 ) +! coeff(:,2) = 2.0 / ( ( soil%zse(1) + xx(:) ) / ccnsw(:,1) + soil%zse(2) / & +! ccnsw(:,2) ) +! coefa = 0.0 +! coefb = REAL( coeff(:,2) ) +! +! wblfsp = ssnow%wblf(:,k) +! +! ssnow%gammzz(:,k) = MAX((soil%heat_cap_lower_limit(:,k)), & +! ( 1.0 - soil%ssat_vec(:,k) ) * & +! soil%css_vec(:,k) * soil%rhosoil_vec(:,k) & +! + soil%ssat_vec(:,k) * ( wblfsp * Ccs_rho_wat + & +! ssnow%wbfice(:,k) * Ccs_rho_ice ) ) & +! * soil%zse_vec(:,k) +! +! ssnow%gammzz(:,k) = ssnow%gammzz(:,k) + Ccgsnow * ssnow%snowd +! +! dtg = dels / ssnow%gammzz(:,k) +! +! at(:,k) = - dtg * coeff(:,k) +! ct(:,k) = - dtg * coeff(:,k+1) ! c3(ms)=0 & not really used +! bt(:,k) = 1.0 - at(:,k) - ct(:,k) +! END WHERE + k = 1 WHERE( ssnow%isflag == 0 ) - coeff(:,2) = 2.0 / ( ( soil%zse(1) + xx(:) ) / ccnsw(:,1) + soil%zse(2) / & - ccnsw(:,2) ) - coefa = 0.0 - coefb = REAL( coeff(:,2) ) - - wblfsp = ssnow%wblf(:,k) + coeff(:,2) = 2._r_2 / ( ( soil%zse_vec(:,1) + xx(:) ) / ccnsw(:,1) + soil%zse_vec(:,2) / & + ccnsw(:,2) ) + coefa = 0._r_2 + coefb = coeff(:,2) + ssnow%gammzz(:,k) = MAX((soil%heat_cap_lower_limit(:,k)), & ( 1.0 - soil%ssat_vec(:,k) ) * & soil%css_vec(:,k) * soil%rhosoil_vec(:,k) & - + soil%ssat_vec(:,k) * ( wblfsp * Ccs_rho_wat + & - ssnow%wbfice(:,k) * Ccs_rho_ice ) ) & - * soil%zse_vec(:,k) - - ssnow%gammzz(:,k) = ssnow%gammzz(:,k) + Ccgsnow * ssnow%snowd - - dtg = dels / ssnow%gammzz(:,k) - + + ssnow%wbliq(:,k)*real(Ccswat*Cdensity_liq,r_2) & + !+ ssnow%wbice(:,k)*real(C%csice*C%density_liq*0.9,r_2) ) & ! MMY + + ssnow%wbice(:,k)*real(Ccsice*Cdensity_ice,r_2) ) & ! MMY + * soil%zse_vec(:,k) + gammzz_snow(:,k) + + dtg = dels_r2 / ssnow%gammzz(:,k) + at(:,k) = - dtg * coeff(:,k) ct(:,k) = - dtg * coeff(:,k+1) ! c3(ms)=0 & not really used bt(:,k) = 1.0 - at(:,k) - ct(:,k) - END WHERE - DO k = 2, ms - WHERE( ssnow%isflag == 0 ) +! DO k = 2, ms ! rk4417 - phase2 +! +! WHERE( ssnow%isflag == 0 ) +! +! wblfsp = ssnow%wblf(:,k) +! +! ssnow%gammzz(:,k) = MAX((soil%heat_cap_lower_limit(:,k)), & +! ( 1.0 - soil%ssat_vec(:,k) ) * & +! soil%css_vec(:,k) * soil%rhosoil_vec(:,k) & +! + soil%ssat_vec(:,k) * ( wblfsp * Ccs_rho_wat + & +! ssnow%wbfice(:,k) * Ccs_rho_ice ) ) & +! * soil%zse_vec(:,k) +! +! dtg = dels / ssnow%gammzz(:,k) +! at(:,k) = - dtg * coeff(:,k) +! ct(:,k) = - dtg * coeff(:,k+1) ! c3(ms)=0 & not really used +! bt(:,k) = 1.0 - at(:,k) - ct(:,k) +! +! END WHERE +! +! END DO - wblfsp = ssnow%wblf(:,k) + DO k = 2, ms + WHERE( ssnow%isflag == 0 ) + ssnow%gammzz(:,k) = MAX((soil%heat_cap_lower_limit(:,k)), & ( 1.0 - soil%ssat_vec(:,k) ) * & soil%css_vec(:,k) * soil%rhosoil_vec(:,k) & - + soil%ssat_vec(:,k) * ( wblfsp * Ccs_rho_wat + & - ssnow%wbfice(:,k) * Ccs_rho_ice ) ) & - * soil%zse_vec(:,k) - - dtg = dels / ssnow%gammzz(:,k) + + ssnow%wbliq(:,k)*real(Ccswat*Cdensity_liq,r_2) & + !+ ssnow%wbice(:,k)*real(C%csice*C%density_liq*0.9,r_2) ) & ! MMY + + ssnow%wbice(:,k)*real(Ccsice*Cdensity_ice,r_2) ) & ! MMY + * soil%zse_vec(:,k) + gammzz_snow(:,k) + + dtg = dels_r2 / ssnow%gammzz(:,k) + at(:,k) = - dtg * coeff(:,k) ct(:,k) = - dtg * coeff(:,k+1) ! c3(ms)=0 & not really used bt(:,k) = 1.0 - at(:,k) - ct(:,k) - + END WHERE END DO + +! WHERE( ssnow%isflag == 0 ) ! rk4417 - phase2 +! bt(:,1) = bt(:,1) - canopy%dgdtg * dels / ssnow%gammzz(:,1) +! ssnow%tgg(:,1) = ssnow%tgg(:,1) + ( canopy%ga - ssnow%tgg(:,1) & +! * REAL( canopy%dgdtg ) ) * dels / REAL( ssnow%gammzz(:,1) ) +! END WHERE + WHERE( ssnow%isflag == 0 ) - bt(:,1) = bt(:,1) - canopy%dgdtg * dels / ssnow%gammzz(:,1) - ssnow%tgg(:,1) = ssnow%tgg(:,1) + ( canopy%ga - ssnow%tgg(:,1) & - * REAL( canopy%dgdtg ) ) * dels / REAL( ssnow%gammzz(:,1) ) + bt(:,1) = bt(:,1) - canopy%dgdtg * dels_r2 / ssnow%gammzz(:,1) + ssnow%tgg(:,1) = ssnow%tgg(:,1) + real(( real(canopy%ga,r_2) - real(ssnow%tgg(:,1),r_2) & + * REAL( canopy%dgdtg ) ) * dels_r2 / ssnow%gammzz(:,1) ) END WHERE coeff(:,1-3) = 0.0 ! coeff(:,-2) +! ! 3-layer snow points done here ! rk4417 - phase2 +! WHERE( ssnow%isflag /= 0 ) +! +! ssnow%sconds(:,1) = MAX( 0.2, MIN( 2.876e-6 * ssnow%ssdn(:,1)**2 & +! + 0.074, max_sconds ) ) +! ssnow%sconds(:,2) = MAX(0.2, MIN(2.876e-6 * ssnow%ssdn(:,2)**2 & +! & + 0.074, max_sconds) ) +! ssnow%sconds(:,3) = MAX(0.2, MIN(2.876e-6 * ssnow%ssdn(:,3)**2 & +! & + 0.074, max_sconds) ) +! coeff(:,-1) = 2.0 / (ssnow%sdepth(:,1) / ssnow%sconds(:,1) & +! & + ssnow%sdepth(:,2) / ssnow%sconds(:,2) ) +! coeff(:,0) = 2.0 / (ssnow%sdepth(:,2) / ssnow%sconds(:,2) & +! & + ssnow%sdepth(:,3) / ssnow%sconds(:,3) ) +! coeff(:,1) = 2.0 / (ssnow%sdepth(:,3) / ssnow%sconds(:,3) & +! & + soil%zse(1) / ccnsw (:,1) ) +! END WHERE + + ! 3-layer snow points done here WHERE( ssnow%isflag /= 0 ) @@ -139,70 +242,116 @@ SUBROUTINE GWstempv(dels, canopy, ssnow, soil) & + 0.074, max_sconds) ) ssnow%sconds(:,3) = MAX(0.2, MIN(2.876e-6 * ssnow%ssdn(:,3)**2 & & + 0.074, max_sconds) ) - coeff(:,-1) = 2.0 / (ssnow%sdepth(:,1) / ssnow%sconds(:,1) & - & + ssnow%sdepth(:,2) / ssnow%sconds(:,2) ) - coeff(:,0) = 2.0 / (ssnow%sdepth(:,2) / ssnow%sconds(:,2) & - & + ssnow%sdepth(:,3) / ssnow%sconds(:,3) ) - coeff(:,1) = 2.0 / (ssnow%sdepth(:,3) / ssnow%sconds(:,3) & - & + soil%zse(1) / ccnsw (:,1) ) + coeff(:,-1) = 2._r_2 / (real(ssnow%sdepth(:,1) / ssnow%sconds(:,1),r_2) & + & + real(ssnow%sdepth(:,2) / ssnow%sconds(:,2),r_2) ) + coeff(:,0) = 2._r_2 / (real(ssnow%sdepth(:,2) / ssnow%sconds(:,2),r_2) & + & + real(ssnow%sdepth(:,3) / ssnow%sconds(:,3),r_2) ) + coeff(:,1) = 2._r_2 / (real(ssnow%sdepth(:,3) / ssnow%sconds(:,3),r_2) & + & + soil%zse_vec(:,1) / ccnsw (:,1) ) END WHERE - DO k = 2, ms + +! DO k = 2, ms ! rk4417 - phase2 +! WHERE( ssnow%isflag /= 0 ) & +! coeff(:,k) = 2.0 / ( soil%zse(k-1) / ccnsw(:,k-1) + soil%zse(k) / & +! ccnsw(:,k) ) +! END DO + DO k = 2, ms WHERE( ssnow%isflag /= 0 ) & - coeff(:,k) = 2.0 / ( soil%zse(k-1) / ccnsw(:,k-1) + soil%zse(k) / & + coeff(:,k) = 2._r_2 / ( soil%zse_vec(:,k-1) / ccnsw(:,k-1) + soil%zse_vec(:,k) / & ccnsw(:,k) ) - END DO +! WHERE( ssnow%isflag /= 0 ) ! rk4417 - phase2 +! coefa = REAL( coeff (:,-1) ) +! coefb = REAL( coeff (:,1) ) +! END WHERE + WHERE( ssnow%isflag /= 0 ) - coefa = REAL( coeff (:,-1) ) - coefb = REAL( coeff (:,1) ) + coefa = coeff (:,-1) + coefb = coeff (:,1) END WHERE - DO k = 1, 3 + +! DO k = 1, 3 ! rk4417 - phase2 +! WHERE( ssnow%isflag /= 0 ) +! sgamm = ssnow%ssdn(:,k) * Ccgsnow * ssnow%sdepth(:,k) +! dtg = dels / sgamm +! at(:,k-3) = - dtg * coeff(:,k-3) +! ct(:,k-3) = - dtg * coeff(:,k-2) +! bt(:,k-3) = 1.0 - at(:,k-3) - ct(:,k-3) +! END WHERE +! END DO + DO k = 1, 3 WHERE( ssnow%isflag /= 0 ) - sgamm = ssnow%ssdn(:,k) * Ccgsnow * ssnow%sdepth(:,k) - dtg = dels / sgamm + sgamm = real(ssnow%ssdn(:,k) * Ccgsnow * ssnow%sdepth(:,k),r_2) + dtg = dels_r2 / sgamm at(:,k-3) = - dtg * coeff(:,k-3) ct(:,k-3) = - dtg * coeff(:,k-2) bt(:,k-3) = 1.0 - at(:,k-3) - ct(:,k-3) END WHERE - END DO - DO k = 1, ms + +! DO k = 1, ms ! rk4417 - phase2 +! WHERE( ssnow%isflag /= 0 ) +! wblfsp = ssnow%wblf(:,k) +! +! ssnow%gammzz(:,k) = MAX((soil%heat_cap_lower_limit(:,k)),& +! ( 1.0 - soil%ssat_vec(:,k) ) * soil%css_vec(:,k) * & +! soil%rhosoil_vec(:,k) + soil%ssat_vec(:,k) * ( wblfsp * Ccs_rho_wat +& +! ssnow%wbfice(:,k) * Ccs_rho_ice)) * & +! soil%zse_vec(:,k) +! +! dtg = dels / ssnow%gammzz(:,k) +! at(:,k) = - dtg * coeff(:,k) +! ct(:,k) = - dtg * coeff(:,k + 1) ! c3(ms)=0 & not really used +! bt(:,k) = 1.0 - at(:,k) - ct(:,k) +! END WHERE +! END DO + DO k = 1, ms WHERE( ssnow%isflag /= 0 ) - wblfsp = ssnow%wblf(:,k) - - ssnow%gammzz(:,k) = MAX((soil%heat_cap_lower_limit(:,k)),& - ( 1.0 - soil%ssat_vec(:,k) ) * soil%css_vec(:,k) * & - soil%rhosoil_vec(:,k) + soil%ssat_vec(:,k) * ( wblfsp * Ccs_rho_wat +& - ssnow%wbfice(:,k) * Ccs_rho_ice)) * & - soil%zse_vec(:,k) - dtg = dels / ssnow%gammzz(:,k) + ssnow%gammzz(:,k) = MAX((soil%heat_cap_lower_limit(:,k)), & + ( 1.0 - soil%ssat_vec(:,k) ) * & + soil%css_vec(:,k) * soil%rhosoil_vec(:,k) & + + ssnow%wbliq(:,k)*real(Ccswat*Cdensity_liq,r_2) & + !+ ssnow%wbice(:,k)*real(C%csice*C%density_liq*0.9,r_2) ) & ! MMY + + ssnow%wbice(:,k)*real(Ccsice*Cdensity_ice,r_2) ) & ! MMY + * soil%zse_vec(:,k) + gammzz_snow(:,k) + + dtg = dels_r2 / ssnow%gammzz(:,k) at(:,k) = - dtg * coeff(:,k) ct(:,k) = - dtg * coeff(:,k + 1) ! c3(ms)=0 & not really used - bt(:,k) = 1.0 - at(:,k) - ct(:,k) - + bt(:,k) = 1._r_2 - at(:,k) - ct(:,k) END WHERE - END DO - WHERE( ssnow%isflag /= 0 ) - sgamm = ssnow%ssdn(:,1) * Ccgsnow * ssnow%sdepth(:,1) - - bt(:,-2) = bt(:,-2) - canopy%dgdtg * dels / sgamm - - ssnow%tggsn(:,1) = ssnow%tggsn(:,1) + ( canopy%ga - ssnow%tggsn(:,1 ) & - * REAL( canopy%dgdtg ) ) * dels / sgamm + +! WHERE( ssnow%isflag /= 0 ) ! rk4417 - phase2 +! sgamm = ssnow%ssdn(:,1) * Ccgsnow * ssnow%sdepth(:,1) +! +! bt(:,-2) = bt(:,-2) - canopy%dgdtg * dels / sgamm +! +! ssnow%tggsn(:,1) = ssnow%tggsn(:,1) + ( canopy%ga - ssnow%tggsn(:,1 ) & +! * REAL( canopy%dgdtg ) ) * dels / sgamm +! +! rhs(:,1-3) = ssnow%tggsn(:,1) +! END WHERE + WHERE( ssnow%isflag /= 0 ) + sgamm = real(ssnow%ssdn(:,1) * Ccgsnow * ssnow%sdepth(:,1),r_2) + + bt(:,-2) = bt(:,-2) - canopy%dgdtg * dels_r2 / sgamm + + ssnow%tggsn(:,1) = ssnow%tggsn(:,1) +real( ( real(canopy%ga,r_2) - real(ssnow%tggsn(:,1),r_2) & + * (canopy%dgdtg) * dels_r2) / sgamm ) + rhs(:,1-3) = ssnow%tggsn(:,1) - END WHERE - + END WHERE ! note in the following that tgg and tggsn are processed together tmp_mat(:,1:3) = REAL(ssnow%tggsn,r_2) @@ -212,8 +361,10 @@ SUBROUTINE GWstempv(dels, canopy, ssnow, soil) ssnow%tggsn = REAL( tmp_mat(:,1:3) ) ssnow%tgg = REAL( tmp_mat(:,4:(ms+3)) ) - canopy%sghflux = coefa * ( ssnow%tggsn(:,1) - ssnow%tggsn(:,2) ) - canopy%ghflux = coefb * ( ssnow%tgg(:,1) - ssnow%tgg(:,2) ) ! +ve downwards +! canopy%sghflux = coefa * ( ssnow%tggsn(:,1) - ssnow%tggsn(:,2) ) ! rk4417 - phase2 +! canopy%ghflux = coefb * ( ssnow%tgg(:,1) - ssnow%tgg(:,2) ) ! +ve downwards + canopy%sghflux = real(coefa) * ( ssnow%tggsn(:,1) - ssnow%tggsn(:,2) ) + canopy%ghflux = real(coefb) * ( ssnow%tgg(:,1) - ssnow%tgg(:,2) ) ! +ve downwards END SUBROUTINE GWstempv diff --git a/src/science/soilsnow/cbl_smoisturev.F90 b/src/science/soilsnow/cbl_smoisturev.F90 index ac38c482a..9dc53c43c 100644 --- a/src/science/soilsnow/cbl_smoisturev.F90 +++ b/src/science/soilsnow/cbl_smoisturev.F90 @@ -312,9 +312,13 @@ SUBROUTINE smoisturev (dels,ssnow,soil,veg) ct(:,k) = dtt(:,k) * ( - z2(:,k+1) * 0.5 * soil%zse(k) & / soil%zshh (k+1) - z3(:,k+1) ) +! bt(:,k) = 1.0 + dtt(:,k) * ( - z2(:,k+1) * 0.5 * soil%zse(k+1) & ! replaced by rk4417 - phase2 +! / soil%zshh (k+1) + z2(:,k) * 0.5 * soil%zse(k) & +! / soil%zshh (k) + z3(:,k+1) + z3(:,k) ) + bt(:,k) = 1.0 + dtt(:,k) * ( - z2(:,k+1) * 0.5 * soil%zse(k+1) & - / soil%zshh (k+1) + z2(:,k) * 0.5 * soil%zse(k) & - / soil%zshh (k) + z3(:,k+1) + z3(:,k) ) + / soil%zshh (k+1) + z2(:,k) * 0.5 * soil%zse( MAX( k-1, & + 1 ) ) / soil%zshh (k) + z3(:,k+1) + z3(:,k) ) END DO diff --git a/src/science/soilsnow/cbl_snowAccum.F90 b/src/science/soilsnow/cbl_snowAccum.F90 index 28b6a3dd6..78bca5952 100644 --- a/src/science/soilsnow/cbl_snowAccum.F90 +++ b/src/science/soilsnow/cbl_snowAccum.F90 @@ -8,6 +8,9 @@ MODULE snow_accum_mod SUBROUTINE snow_accum ( dels, canopy, met, ssnow, soil ) + !*## Purpose + ! calcualte snowfall and snow evap and update snow depth, snow temp, snow mass, snow density + USE cable_common_module IMPLICIT NONE diff --git a/src/science/soilsnow/cbl_snowCheck.F90 b/src/science/soilsnow/cbl_snowCheck.F90 index 2b4d64800..548a1e429 100644 --- a/src/science/soilsnow/cbl_snowCheck.F90 +++ b/src/science/soilsnow/cbl_snowCheck.F90 @@ -7,10 +7,12 @@ MODULE snowcheck_mod CONTAINS SUBROUTINE snowcheck(dels, ssnow, soil, met ) - + !*## Purpose + ! Set up snow depth, snow mass, snow temp and snow layer used + USE cable_common_module -IMPLICIT NONE + IMPLICIT NONE REAL, INTENT(IN) :: dels ! integration time step (s) TYPE(soil_snow_type), INTENT(INOUT) :: ssnow @@ -23,7 +25,7 @@ SUBROUTINE snowcheck(dels, ssnow, soil, met ) DO j=1,mp IF( ssnow%snowd(j) <= 0.0 ) THEN - + ! using a single snow layer but there is no snow yet ssnow%isflag(j) = 0 ssnow%ssdn(j,:) = 120.0 ssnow%ssdnn(j) = 120.0 @@ -39,7 +41,7 @@ SUBROUTINE snowcheck(dels, ssnow, soil, met ) ! in loop: IF( ssnow%snowd(j) <= 0.0 ) THEN ELSEIF( ssnow%snowd(j) < snmin * ssnow%ssdnn(j) ) THEN - + ! snow depth is between 0 and 1*snow density IF( ssnow%isflag(j) == 1 ) THEN ssnow%ssdn(j,1) = ssnow%ssdnn(j) ssnow%tgg(j,1) = ssnow%tggsn(j,1) @@ -60,8 +62,6 @@ SUBROUTINE snowcheck(dels, ssnow, soil, met ) ssnow%ssdn(j,:) = ssnow%ssdnn(j) - - ELSE ! in loop: IF( ssnow%snowd(j) <= 0.0 ) THEN ! sufficient snow now for 3 layer snowpack @@ -72,7 +72,6 @@ SUBROUTINE snowcheck(dels, ssnow, soil, met ) ssnow%ssdn(j,2) = ssnow%ssdn(j,1) ssnow%ssdn(j,3) = ssnow%ssdn(j,1) - ssnow%sdepth(j,1) = ssnow%t_snwlr(j) ssnow%smass(j,1) = ssnow%t_snwlr(j) * ssnow%ssdn(j,1) diff --git a/src/science/soilsnow/cbl_snowDensity.F90 b/src/science/soilsnow/cbl_snowDensity.F90 index e7674c68c..b2127e7ba 100644 --- a/src/science/soilsnow/cbl_snowDensity.F90 +++ b/src/science/soilsnow/cbl_snowDensity.F90 @@ -7,8 +7,10 @@ MODULE snowdensity_mod CONTAINS SUBROUTINE snowdensity (dels, ssnow, soil) - -IMPLICIT NONE + !*## Purpose + ! Calculate snow density for either single snow layer and three snow layers + + IMPLICIT NONE REAL, INTENT(IN) :: dels ! integration time step (s) TYPE(soil_snow_type), INTENT(INOUT) :: ssnow @@ -16,7 +18,7 @@ SUBROUTINE snowdensity (dels, ssnow, soil) TYPE(soil_parameter_type), INTENT(INOUT) :: soil REAL, DIMENSION(mp) :: ssnow_tgg_min1 - REAL, DIMENSION(mp,3) :: ssnow_tgg_min +! REAL, DIMENSION(mp,3) :: ssnow_tgg_min ! not used, commented out by rk4417 - phase2 ssnow_tgg_min1 = MIN( CTFRZ, ssnow%tgg(:,1) ) diff --git a/src/science/soilsnow/cbl_snowMelt.F90 b/src/science/soilsnow/cbl_snowMelt.F90 index 12ac79caa..3911c9ae8 100644 --- a/src/science/soilsnow/cbl_snowMelt.F90 +++ b/src/science/soilsnow/cbl_snowMelt.F90 @@ -7,9 +7,11 @@ MODULE snow_melting_mod CONTAINS SUBROUTINE snow_melting (dels, snowmlt, ssnow, soil ) + !*## Purpose + ! Snow melting USE cable_common_module -IMPLICIT NONE + IMPLICIT NONE REAL, INTENT(IN) :: dels ! integration time step (s) diff --git a/src/science/soilsnow/cbl_snowl_adjust.F90 b/src/science/soilsnow/cbl_snowl_adjust.F90 index 023f2f50c..9a07b0c11 100644 --- a/src/science/soilsnow/cbl_snowl_adjust.F90 +++ b/src/science/soilsnow/cbl_snowl_adjust.F90 @@ -7,8 +7,12 @@ MODULE snowl_adjust_mod CONTAINS SUBROUTINE snowl_adjust(dels, ssnow, canopy ) + !*## Purpose + ! Adjust levels in the snowpack due to snow accumulation/melting, + ! snow aging etc... -IMPLICIT NONE + IMPLICIT NONE + REAL, INTENT(IN) :: dels ! integration time step (s) TYPE(soil_snow_type), INTENT(INOUT) :: ssnow diff --git a/src/science/soilsnow/cbl_soilfreeze.F90 b/src/science/soilsnow/cbl_soilfreeze.F90 index ec068b2b0..ec8f21f4d 100644 --- a/src/science/soilsnow/cbl_soilfreeze.F90 +++ b/src/science/soilsnow/cbl_soilfreeze.F90 @@ -15,9 +15,9 @@ SUBROUTINE soilfreeze(dels, soil, ssnow,heat_cap_lower_limit) REAL(r_2), DIMENSION(mp) :: sicefreeze REAL(r_2), DIMENSION(mp) :: sicemelt REAL, DIMENSION(mp) :: xx -INTEGER :: i,k -REAL :: heat_cap_lower_limit(mp,ms) -REAL :: max_arg1, max_arg2 + INTEGER :: i,k + REAL :: heat_cap_lower_limit(mp,ms) ! best to declare INTENT - rk4417 - phase2 + REAL :: max_arg1, max_arg2 xx = 0. DO k = 1, ms !loop over soil levels diff --git a/src/science/soilsnow/cbl_soilsnow_data.F90 b/src/science/soilsnow/cbl_soilsnow_data.F90 index a3a34060c..599f1cf01 100644 --- a/src/science/soilsnow/cbl_soilsnow_data.F90 +++ b/src/science/soilsnow/cbl_soilsnow_data.F90 @@ -8,6 +8,7 @@ MODULE cbl_ssnow_data_mod USE cable_phys_constants_mod, ONLY : CHL => HL USE cable_phys_constants_mod, ONLY : CHLF => HLF USE cable_phys_constants_mod, ONLY : Cdensity_liq => density_liq +USE cable_phys_constants_mod, ONLY : Cdensity_ice => density_ice !added by rk4417 - phase2 USE cable_phys_constants_mod, ONLY : Ccgsnow => cgsnow USE cable_phys_constants_mod, ONLY : Ccswat => cswat USE cable_phys_constants_mod, ONLY : Ccsice => csice diff --git a/src/science/soilsnow/cbl_soilsnow_init_special.F90 b/src/science/soilsnow/cbl_soilsnow_init_special.F90 index 816ca797b..b671874c7 100644 --- a/src/science/soilsnow/cbl_soilsnow_init_special.F90 +++ b/src/science/soilsnow/cbl_soilsnow_init_special.F90 @@ -28,7 +28,7 @@ SUBROUTINE spec_init_soil_snow(dels, soil, ssnow, canopy, met, bal, veg,heat_cap REAL(r_2), DIMENSION(mp) :: xxx,deltat,sinfil1,sinfil2,sinfil3 REAL :: zsetot INTEGER, SAVE :: ktau =0 -REAL :: heat_cap_lower_limit(mp,ms) +REAL :: heat_cap_lower_limit(mp,ms) ! best to declare INTENT - rk4417 - phase2 ktau = ktau +1 diff --git a/src/science/soilsnow/cbl_soilsnow_main.F90 b/src/science/soilsnow/cbl_soilsnow_main.F90 index b7c100480..6a8a67b2d 100644 --- a/src/science/soilsnow/cbl_soilsnow_main.F90 +++ b/src/science/soilsnow/cbl_soilsnow_main.F90 @@ -56,7 +56,7 @@ SUBROUTINE soil_snow(dels, soil, ssnow, canopy, met, bal, veg) REAL(r_2), DIMENSION(mp) :: deltat,sinfil1,sinfil2,sinfil3 REAL :: zsetot INTEGER, SAVE :: ktau =0 -REAL :: wbliq(mp,ms) + REAL :: wbliq(mp,ms) ktau = ktau +1 !this is the value it is initialized with in cable_common anyway diff --git a/src/science/soilsnow/cbl_stempv.F90 b/src/science/soilsnow/cbl_stempv.F90 index 2111c0d9a..6ce10a9be 100644 --- a/src/science/soilsnow/cbl_stempv.F90 +++ b/src/science/soilsnow/cbl_stempv.F90 @@ -47,13 +47,15 @@ SUBROUTINE stempv(dels, canopy, ssnow, soil,heat_cap_lower_limit) INTEGER :: j,k REAL :: exp_arg LOGICAL :: direct2min = .FALSE. -REAL :: heat_cap_lower_limit(mp,ms) + REAL :: heat_cap_lower_limit(mp,ms) ! best to declare INTENT here - rk4417 - phase2 at = 0.0 bt = 1.0 ct = 0.0 coeff = 0.0 + ssnow%otgg(:,:) = ssnow%tgg + IF (cable_user%soil_thermal_fix) THEN ccnsw = total_soil_conductivity(ssnow,soil) ELSE diff --git a/src/science/soilsnow/cbl_surfbv.F90 b/src/science/soilsnow/cbl_surfbv.F90 index 6c62b3891..356cc4500 100644 --- a/src/science/soilsnow/cbl_surfbv.F90 +++ b/src/science/soilsnow/cbl_surfbv.F90 @@ -25,7 +25,8 @@ SUBROUTINE surfbv (dels, met, ssnow, soil, veg, canopy ) TYPE(soil_parameter_type), INTENT(INOUT) :: soil ! soil parameters !jhan:cable.nml - INTEGER :: nglacier = 0 ! 0 original, 1 off, 2 new Eva +! INTEGER :: nglacier = 0 ! 0 original, 1 off, 2 new Eva + INTEGER :: nglacier ! 0 original, 1 off, 2 new Eva ! rk4417 - phase2 REAL, DIMENSION(mp) :: & rnof5, & ! @@ -41,6 +42,7 @@ SUBROUTINE surfbv (dels, met, ssnow, soil, veg, canopy ) REAL :: wb_lake_T, rnof2_T, ratio INTEGER :: k,j + nglacier = 0 IF( .NOT. cable_runtime%UM .OR. cable_runtime%esm15 ) THEN nglacier = 2 ENDIF diff --git a/src/science/soilsnow/cbl_thermal.F90 b/src/science/soilsnow/cbl_thermal.F90 index cb682df1f..74fd4ec16 100644 --- a/src/science/soilsnow/cbl_thermal.F90 +++ b/src/science/soilsnow/cbl_thermal.F90 @@ -48,7 +48,8 @@ SUBROUTINE snow_processes_soil_thermal(dels,ssnow,soil,veg,canopy,met,bal) ! snow aging etc... CALL snowl_adjust(dels, ssnow, canopy ) - IF (cable_user%gw_model) CALL GWstempv(dels, canopy, ssnow, soil) +! IF (cable_user%gw_model) CALL GWstempv(dels, canopy, ssnow, soil) ! replaced by rk4417 - phase2 + CALL GWstempv(dels, canopy, ssnow, soil) !do the soil and snow melting, freezing prior to water movement DO i=1,mp diff --git a/src/util/cable_common.F90 b/src/util/cable_common.F90 index f3d2a99c9..9ce4d5205 100644 --- a/src/util/cable_common.F90 +++ b/src/util/cable_common.F90 @@ -77,18 +77,20 @@ MODULE cable_common_module soilcolor, & ! file for soil color(soilcolor_global_1x1.nc) inits, & ! name of file for initialisations soilIGBP, & ! name of file for IGBP soil map - gw_elev, & !name of file for gw/elevation data +! gw_elev, & !name of file for gw/elevation data ! see below - rk4417 - phase2 fxpft, & !filename for PFT fraction and transition,wood harvest, secondary harvest fxluh2cable,& !filename for mapping 12 luc states into 17 CABLE PFT - gridnew !filename for updated gridinfo file - + gridnew,& !filename for updated gridinfo file + gw_elev='', & !name of file for gw/elevation data ! 2 lines added by rk4417 - phase2 + gw_soils='' !tiled/layerd soil params + !give default as not required END TYPE filenames_type TYPE(filenames_type) :: filename ! hydraulic_redistribution switch _soilsnow module - LOGICAL :: redistrb = .FALSE. + LOGICAL :: redistrb = .FALSE. ! Turn on/off the hydraulic redistribution TYPE organic_soil_params !Below are the soil properties for fully organic soil diff --git a/src/util/cable_runtime_opts_mod.F90 b/src/util/cable_runtime_opts_mod.F90 index 628f97a48..ba33555b3 100644 --- a/src/util/cable_runtime_opts_mod.F90 +++ b/src/util/cable_runtime_opts_mod.F90 @@ -107,13 +107,15 @@ MODULE cable_runtime_opts_mod LOGICAL :: or_evap = .FALSE. LOGICAL :: test_new_gw = .FALSE. LOGICAL :: sync_nc_file = .FALSE. - INTEGER :: max_spins = -1 + INTEGER :: max_spins = -1 ! MMY-phase2 change from -1 to 30 - rk4417 LOGICAL :: fix_access_roots = .FALSE. !use pft dependent roots in ACCESS !ACCESS roots LOGICAL :: access13roots = .FALSE. !switch to use ACCESS1.3 %froot LOGICAL :: l_limit_labile = .FALSE. ! #237: limit Labile in spinup LOGICAL :: NtilesThruMetFile = .FALSE. ! #199: Specify Ntiles thru met file + !line below inserted to fix compilation error - rk4417 - phase2 + INTEGER :: force_npatches_as=-1 ! #338 https://github.com/CABLE-LSM/CABLE/issues/338 LOGICAL :: l_ice_consistency = .FALSE.