From e71c83b3e6ffa0d44d2448b2581c89fa9a2a8849 Mon Sep 17 00:00:00 2001 From: "Martyn Clark (mac414)" Date: Sat, 10 Oct 2020 13:28:38 -0600 Subject: [PATCH 01/24] reduce time step if snow layer melts entirely --- build/source/engine/varSubstep.f90 | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/build/source/engine/varSubstep.f90 b/build/source/engine/varSubstep.f90 index 62878e9a5..f44508ced 100755 --- a/build/source/engine/varSubstep.f90 +++ b/build/source/engine/varSubstep.f90 @@ -399,14 +399,14 @@ subroutine varSubstep(& ! update prognostic variables call updateProg(dtSubstep,nSnow,nSoil,nLayers,doAdjustTemp,computeVegFlux,untappedMelt,stateVecTrial,checkMassBalance, & ! input: model control mpar_data,indx_data,flux_temp,prog_data,diag_data,deriv_data, & ! input-output: data structures - waterBalanceError,nrgFluxModified,err,cmessage) ! output: flags and error control + waterBalanceError,nrgFluxModified,tooMuchMelt,err,cmessage) ! output: flags and error control if(err/=0)then message=trim(message)//trim(cmessage) if(err>0) return endif ! if water balance error then reduce the length of the coupled step - if(waterBalanceError)then + if(waterBalanceError .or. tooMuchMelt)then message=trim(message)//'water balance error' reduceCoupledStep=.true. err=-20; return @@ -538,7 +538,7 @@ end subroutine varSubstep ! ********************************************************************************************************** subroutine updateProg(dt,nSnow,nSoil,nLayers,doAdjustTemp,computeVegFlux,untappedMelt,stateVecTrial,checkMassBalance, & ! input: model control mpar_data,indx_data,flux_data,prog_data,diag_data,deriv_data, & ! input-output: data structures - waterBalanceError,nrgFluxModified,err,message) ! output: flags and error control + waterBalanceError,nrgFluxModified,tooMuchMelt,err,message) ! output: flags and error control USE getVectorz_module,only:varExtract ! extract variables from the state vector USE updateVars_module,only:updateVars ! update prognostic variables implicit none @@ -562,6 +562,7 @@ subroutine updateProg(dt,nSnow,nSoil,nLayers,doAdjustTemp,computeVegFlux,untappe ! flags and error control logical(lgt) ,intent(out) :: waterBalanceError ! flag to denote that there is a water balance error logical(lgt) ,intent(out) :: nrgFluxModified ! flag to denote that the energy fluxes were modified + logical(lgt) ,intent(out) :: tooMuchMelt ! flag to denote that the energy fluxes were modified integer(i4b) ,intent(out) :: err ! error code character(*) ,intent(out) :: message ! error message ! ================================================================================================================== @@ -691,6 +692,9 @@ subroutine updateProg(dt,nSnow,nSoil,nLayers,doAdjustTemp,computeVegFlux,untappe !print*, 'after varExtract: scalarCanopyLiqTrial =', scalarCanopyLiqTrial ! trial value of canopy liquid water (kg m-2) !print*, 'after varExtract: scalarCanopyIceTrial =', scalarCanopyIceTrial ! trial value of canopy ice content (kg m-2) + ! check if there was too much melt + if(nSnow>0) tooMuchMelt = (mLayerTempTrial(1)>Tfreeze) + ! update diagnostic variables call updateVars(& ! input From 319eae758adbcb8c29bea56fd9bc3f5c991a73ab Mon Sep 17 00:00:00 2001 From: "Wouter Knoben (wmk934)" Date: Wed, 2 Dec 2020 18:16:03 -0600 Subject: [PATCH 02/24] added GRU index and hruId reporting to run_oneGru & run_oneHru --- build/source/engine/run_oneGRU.f90 | 6 +++--- build/source/engine/run_oneHRU.f90 | 2 +- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/build/source/engine/run_oneGRU.f90 b/build/source/engine/run_oneGRU.f90 index 614dd0618..96e436e09 100755 --- a/build/source/engine/run_oneGRU.f90 +++ b/build/source/engine/run_oneGRU.f90 @@ -135,8 +135,8 @@ subroutine run_oneGRU(& logical(lgt) :: computeVegFluxFlag ! flag to indicate if we are computing fluxes over vegetation (.false. means veg is buried with snow) ! initialize error control - err=0; message='run_oneGRU/' - + err=0; write(message, '(A24,I0,A2)' ) 'run_oneGRU (gru index = ',gruInfo%gru_nc,')/' + ! ----- basin initialization -------------------------------------------------------------------------------------------- ! initialize runoff variables @@ -194,7 +194,7 @@ subroutine run_oneGRU(& ! error control err,cmessage) ! intent(out): error control if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; endif - + ! update layer numbers that could be changed in run_oneHRU -- needed for model output gruInfo%hruInfo(iHRU)%nSnow = nSnow gruInfo%hruInfo(iHRU)%nSoil = nSoil diff --git a/build/source/engine/run_oneHRU.f90 b/build/source/engine/run_oneHRU.f90 index 361f43b3c..1632e1f77 100755 --- a/build/source/engine/run_oneHRU.f90 +++ b/build/source/engine/run_oneHRU.f90 @@ -140,7 +140,7 @@ subroutine run_oneHRU(& real(dp) , allocatable :: zSoilReverseSign(:) ! height at bottom of each soil layer, negative downwards (m) ! initialize error control - err=0; message='run_oneHRU/' + err=0; write(message, '(A20,I0,A2)' ) 'run_oneHRU (hruId = ',hruId,')/' ! ----- hru initialization --------------------------------------------------------------------------------------------- From 5e183fac8dd036ae1ef052085d1e9f7a8aa194fe Mon Sep 17 00:00:00 2001 From: "Wouter Knoben (wmk934)" Date: Wed, 2 Dec 2020 18:19:42 -0600 Subject: [PATCH 03/24] removed unnecessary whitespace in run_oneGru --- build/source/engine/run_oneGRU.f90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/build/source/engine/run_oneGRU.f90 b/build/source/engine/run_oneGRU.f90 index 96e436e09..653585ac7 100755 --- a/build/source/engine/run_oneGRU.f90 +++ b/build/source/engine/run_oneGRU.f90 @@ -136,7 +136,7 @@ subroutine run_oneGRU(& ! initialize error control err=0; write(message, '(A24,I0,A2)' ) 'run_oneGRU (gru index = ',gruInfo%gru_nc,')/' - + ! ----- basin initialization -------------------------------------------------------------------------------------------- ! initialize runoff variables @@ -194,7 +194,7 @@ subroutine run_oneGRU(& ! error control err,cmessage) ! intent(out): error control if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; endif - + ! update layer numbers that could be changed in run_oneHRU -- needed for model output gruInfo%hruInfo(iHRU)%nSnow = nSnow gruInfo%hruInfo(iHRU)%nSoil = nSoil From a3837a238e4778e59e2aa3fdd025401c12ea49aa Mon Sep 17 00:00:00 2001 From: "Wouter Knoben (wmk934)" Date: Fri, 1 Jan 2021 21:48:22 -0600 Subject: [PATCH 04/24] bugfix of error reporting in coupled_em balance checks: incorrect solution method was returned by opSplittin --- build/source/engine/opSplittin.f90 | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/build/source/engine/opSplittin.f90 b/build/source/engine/opSplittin.f90 index 8d08b2e4a..4ed09620f 100755 --- a/build/source/engine/opSplittin.f90 +++ b/build/source/engine/opSplittin.f90 @@ -481,7 +481,7 @@ subroutine opSplittin(& end select ! operator splitting option ! state splitting loop - stateTypeSplit: do iStateTypeSplit=1,nStateTypeSplit + stateTypeSplitLoop: do iStateTypeSplit=1,nStateTypeSplit !print*, 'iStateTypeSplit, nStateTypeSplit = ', iStateTypeSplit, nStateTypeSplit @@ -935,7 +935,7 @@ subroutine opSplittin(& where(ixStateType(ixHydLayer) ==iname_lmpLayer) ixStateType(ixHydLayer) =iname_matLayer endif ! if modifying state variables for the mass split - end do stateTypeSplit ! state type splitting loop + end do stateTypeSplitLoop ! state type splitting loop ! check !if(ixCoupling/=fullyCoupled)then @@ -946,8 +946,9 @@ subroutine opSplittin(& ! ========================================================================================================================================== ! success = exit the coupling loop - if(ixCoupling==fullyCoupled .and. .not.failure) exit coupling - + if(ixCoupling==fullyCoupled .and. .not. failure) exit coupling ! terminate DO loop early if fullyCoupled returns a solution + if(ixCoupling==stateTypeSplit .and. .not. failure) exit coupling ! terminating the DO loop here is cleaner than letting it complete, because in the latter case the coupling loop will end with ixCoupling = nCoupling+1 = 3 (a FORTRAN loop increments the index variable at the end of each iteration and stops the loop if the index > specified stop value). Variable ixCoupling is used for error reporting in coupled_em.f90 in the balance checks and we thus need to make sure ixCoupling is not incremented to be larger than nCoupling. + end do coupling ! coupling method ! check that all state variables were updated From ea09226d08ad2e20355270558f9db4902434438d Mon Sep 17 00:00:00 2001 From: "Wouter Knoben (wmk934)" Date: Tue, 5 Jan 2021 13:49:34 -0600 Subject: [PATCH 05/24] moved and split comments across multiple lines as requested in PR --- build/source/engine/opSplittin.f90 | 15 +++++++++++++-- 1 file changed, 13 insertions(+), 2 deletions(-) diff --git a/build/source/engine/opSplittin.f90 b/build/source/engine/opSplittin.f90 index 4ed09620f..3020ae20f 100755 --- a/build/source/engine/opSplittin.f90 +++ b/build/source/engine/opSplittin.f90 @@ -946,8 +946,19 @@ subroutine opSplittin(& ! ========================================================================================================================================== ! success = exit the coupling loop - if(ixCoupling==fullyCoupled .and. .not. failure) exit coupling ! terminate DO loop early if fullyCoupled returns a solution - if(ixCoupling==stateTypeSplit .and. .not. failure) exit coupling ! terminating the DO loop here is cleaner than letting it complete, because in the latter case the coupling loop will end with ixCoupling = nCoupling+1 = 3 (a FORTRAN loop increments the index variable at the end of each iteration and stops the loop if the index > specified stop value). Variable ixCoupling is used for error reporting in coupled_em.f90 in the balance checks and we thus need to make sure ixCoupling is not incremented to be larger than nCoupling. + ! terminate DO loop early if fullyCoupled returns a solution, + ! so that the loop does not proceed to ixCoupling = stateTypeSplit + if(ixCoupling==fullyCoupled .and. .not. failure) exit coupling + + ! if we reach stateTypeSplit, terminating the DO loop here is cleaner + ! than letting the loop complete, because in the latter case the coupling + ! loop will end with ixCoupling = nCoupling+1 = 3 (a FORTRAN loop + ! increments the index variable at the end of each iteration and stops + ! the loop if the index > specified stop value). Variable ixCoupling is + ! used for error reporting in coupled_em.f90 in the balance checks and + ! we thus need to make sure ixCoupling is not incremented to be larger + ! than nCoupling. + if(ixCoupling==stateTypeSplit .and. .not. failure) exit coupling end do coupling ! coupling method From 6d872f161ac1208dd3094a0fd7baae79dd51d365 Mon Sep 17 00:00:00 2001 From: "Prof. Martyn Clark" Date: Thu, 7 Jan 2021 12:26:37 -0600 Subject: [PATCH 06/24] fix water balance error associated with transpiration --- build/source/engine/varSubstep.f90 | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/build/source/engine/varSubstep.f90 b/build/source/engine/varSubstep.f90 index f44508ced..f82882d94 100755 --- a/build/source/engine/varSubstep.f90 +++ b/build/source/engine/varSubstep.f90 @@ -478,8 +478,17 @@ subroutine varSubstep(& ixMax=ubound(flux_data%var(iVar)%dat) do ixLayer=ixMin(1),ixMax(1) if(fluxMask%var(iVar)%dat(ixLayer)) then - flux_data%var(iVar)%dat(ixLayer) = flux_data%var(iVar)%dat(ixLayer) + flux_temp%var(iVar)%dat(ixLayer)*dt_wght + + ! special case of the transpiration sink from soil layers: only computed for the top soil layer + if(iVar==iLookFlux%mLayerTranspire)then + if(ixLayer==1) flux_data%var(iVar)%dat(:) = flux_data%var(iVar)%dat(:) + flux_temp%var(iVar)%dat(:)*dt_wght + + ! standard case + else + flux_data%var(iVar)%dat(ixLayer) = flux_data%var(iVar)%dat(ixLayer) + flux_temp%var(iVar)%dat(ixLayer)*dt_wght + endif fluxCount%var(iVar)%dat(ixLayer) = fluxCount%var(iVar)%dat(ixLayer) + 1 + endif end do endif ! (domain splitting) From 1c6bdd5d75b2ccbccfb23dd20ac73e19cfdd4577 Mon Sep 17 00:00:00 2001 From: arbennett Date: Mon, 11 Jan 2021 11:47:10 -0800 Subject: [PATCH 07/24] Fix for segfault --- build/source/engine/snowLiqFlx.f90 | 25 +++++++++++++++++++++---- 1 file changed, 21 insertions(+), 4 deletions(-) diff --git a/build/source/engine/snowLiqFlx.f90 b/build/source/engine/snowLiqFlx.f90 index 29cfc7ddd..a8c945412 100755 --- a/build/source/engine/snowLiqFlx.f90 +++ b/build/source/engine/snowLiqFlx.f90 @@ -92,8 +92,8 @@ subroutine snowLiqFlx(& character(*),intent(out) :: message ! error message ! ------------------------------------------------------------------------------------------------------------------------------------------ ! local variables + integer(i4b) :: i ! search index for scalar solution integer(i4b) :: iLayer ! layer index - integer(i4b) :: ixLayerDesired(1) ! layer desired (scalar solution) integer(i4b) :: ixTop ! top layer in subroutine call integer(i4b) :: ixBot ! bottom layer in subroutine call real(dp) :: multResid ! multiplier for the residual water content (-) @@ -131,10 +131,27 @@ subroutine snowLiqFlx(& if(mw_exp<1._dp)then; err=20; message=trim(message)//'meltwater exponent < 1'; return; end if ! get the indices for the snow+soil layers + ixTop = integerMissing if(scalarSolution)then - ixLayerDesired = pack(ixLayerState, ixSnowOnlyHyd/=integerMissing) - ixTop = ixLayerDesired(1) - ixBot = ixLayerDesired(1) + ! WARNING: Previously this was implemented as: + ! ixLayerDesired = pack(ixLayerState, ixSnowOnlyHyd/=integerMissing) + ! ixTop = ixLayerDesired(1) + ! ixBot = ixLayerDesired(1) + ! This implementation can result in a segfault when using JRDN layering. + ! The segfault occurs when trying to access `mw_exp` in: + ! iLayerLiqFluxSnow(iLayer) = k_snow*relSaturn**mw_exp + ! Debugging found that the `pack` statement cased `mw_exp` to no longer be accessible. + ! We have not been able to determine the underlying reason for this segfault. + do i=1,size(ixSnowOnlyHyd) + if(ixSnowOnlyHyd(i) /= integerMissing)then + ixTop=ixLayerState(i) + ixBot=ixTop + exit ! break out of loop once found + endif + end do + if(ixTop == integerMissing)then + err=20; message=trim(message)//'Unable to identify snow layer for scalar solution!'; return + end if else ixTop = 1 ixBot = nSnow From c2da2bfda3240f16fc896d5f6dc2bc4e36256c5c Mon Sep 17 00:00:00 2001 From: arbennett Date: Mon, 11 Jan 2021 11:56:29 -0800 Subject: [PATCH 08/24] Fix typo --- build/source/engine/snowLiqFlx.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/build/source/engine/snowLiqFlx.f90 b/build/source/engine/snowLiqFlx.f90 index a8c945412..53b4fb29a 100755 --- a/build/source/engine/snowLiqFlx.f90 +++ b/build/source/engine/snowLiqFlx.f90 @@ -140,7 +140,7 @@ subroutine snowLiqFlx(& ! This implementation can result in a segfault when using JRDN layering. ! The segfault occurs when trying to access `mw_exp` in: ! iLayerLiqFluxSnow(iLayer) = k_snow*relSaturn**mw_exp - ! Debugging found that the `pack` statement cased `mw_exp` to no longer be accessible. + ! Debugging found that the `pack` statement caused `mw_exp` to no longer be accessible. ! We have not been able to determine the underlying reason for this segfault. do i=1,size(ixSnowOnlyHyd) if(ixSnowOnlyHyd(i) /= integerMissing)then From bdd30a191f7d7f63cb935cfc7f628639e7451a1c Mon Sep 17 00:00:00 2001 From: Andy Wood Date: Sun, 28 Feb 2021 09:19:48 -0700 Subject: [PATCH 09/24] Added precision tolerance to balance check in updatState.f90 to avoid erroneous STOP --- build/source/engine/updatState.f90 | 32 +++++++++++++++++++++--------- 1 file changed, 23 insertions(+), 9 deletions(-) diff --git a/build/source/engine/updatState.f90 b/build/source/engine/updatState.f90 index 698c8b1cd..d69128152 100755 --- a/build/source/engine/updatState.f90 +++ b/build/source/engine/updatState.f90 @@ -52,16 +52,17 @@ subroutine updateSnow(& USE snow_utils_module,only:fracliquid ! compute volumetric fraction of liquid water implicit none ! input variables - real(dp),intent(in) :: mLayerTemp ! temperature (K) - real(dp),intent(in) :: mLayerTheta ! volume fraction of total water (-) - real(dp),intent(in) :: snowfrz_scale ! scaling parameter for the snow freezing curve (K-1) + real(dp),intent(in) :: mLayerTemp ! temperature (K) + real(dp),intent(in) :: mLayerTheta ! volume fraction of total water (-) + real(dp),intent(in) :: snowfrz_scale ! scaling parameter for the snow freezing curve (K-1) ! output variables - real(dp),intent(out) :: mLayerVolFracLiq ! volumetric fraction of liquid water (-) - real(dp),intent(out) :: mLayerVolFracIce ! volumetric fraction of ice (-) - real(dp),intent(out) :: fLiq ! fraction of liquid water (-) + real(dp),intent(out) :: mLayerVolFracLiq ! volumetric fraction of liquid water (-) + real(dp),intent(out) :: mLayerVolFracIce ! volumetric fraction of ice (-) + real(dp),intent(out) :: fLiq ! fraction of liquid water (-) ! error control - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! initialize error control err=0; message="updateSnow/" @@ -115,12 +116,25 @@ subroutine updateSoil(& real(dp) :: TcSoil ! critical soil temperature when all water is unfrozen (K) real(dp) :: xConst ! constant in the freezing curve function (m K-1) real(dp) :: mLayerPsiLiq ! liquid water matric potential (m) + real(dp),parameter :: tinyVal=epsilon(1._dp) ! used in balance check + ! initialize error control err=0; message="updateSoil/" ! compute fractional **volume** of total water (liquid plus ice) mLayerVolFracWat = volFracLiq(mLayerMatricHead,vGn_alpha,theta_res,theta_sat,vGn_n,vGn_m) - if(mLayerVolFracWat > theta_sat)then; err=20; message=trim(message)//'volume of liquid and ice exceeds porosity'; return; end if + if(mLayerVolFracWat > (theta_sat + tinyVal)) then + err=20 + message=trim(message)//'volume of liquid and ice (mLayerVolFracWat) exceeds porosity' + print*, 'mLayerVolFracWat = ', mLayerVolFracWat + print*, 'theta_sat (porosity) = ', theta_sat + print*, 'mLayerMatricHead = ', mLayerMatricHead + print*, 'theta_res = ', theta_res + print*, 'vGn_alpha = ', vGn_alpha + print*, 'vGn_n = ', vGn_n + print*, 'vGn_m = ', vGn_m + return + end if ! compute the critical soil temperature where all water is unfrozen (K) ! (eq 17 in Dall'Amico 2011) From 0667540356e938bd7bc4a9ffc4f8ce311a0fd6d0 Mon Sep 17 00:00:00 2001 From: arbennett Date: Tue, 2 Mar 2021 08:59:24 -0800 Subject: [PATCH 10/24] Add whatsnew, rename github folder --- {.github.com => .github}/CONTRIBUTING.md | 0 {.github.com => .github}/ISSUE_TEMPLATE.md | 0 {.github.com => .github}/PULL_REQUEST_TEMPLATE.md | 0 docs/whats-new.md | 13 +++++++++++++ 4 files changed, 13 insertions(+) rename {.github.com => .github}/CONTRIBUTING.md (100%) rename {.github.com => .github}/ISSUE_TEMPLATE.md (100%) rename {.github.com => .github}/PULL_REQUEST_TEMPLATE.md (100%) create mode 100644 docs/whats-new.md diff --git a/.github.com/CONTRIBUTING.md b/.github/CONTRIBUTING.md similarity index 100% rename from .github.com/CONTRIBUTING.md rename to .github/CONTRIBUTING.md diff --git a/.github.com/ISSUE_TEMPLATE.md b/.github/ISSUE_TEMPLATE.md similarity index 100% rename from .github.com/ISSUE_TEMPLATE.md rename to .github/ISSUE_TEMPLATE.md diff --git a/.github.com/PULL_REQUEST_TEMPLATE.md b/.github/PULL_REQUEST_TEMPLATE.md similarity index 100% rename from .github.com/PULL_REQUEST_TEMPLATE.md rename to .github/PULL_REQUEST_TEMPLATE.md diff --git a/docs/whats-new.md b/docs/whats-new.md new file mode 100644 index 000000000..15085da6a --- /dev/null +++ b/docs/whats-new.md @@ -0,0 +1,13 @@ +# What's new + +This page provides simple, high-level documentation about what has changed in each new release of SUMMA. + +## Version 3.0.4 (pre-release) + +- Initial addition of the "What's new" page +- Added pull request template +- Adds HRU/GRU info to error messages +- Fixes a segfault of mysterious origin when using JRDN snow layering +- Fixes a water balance error w.r.t transpiration +- Fixes the output message to report the correct solution type + From 8437cb0f98d7bc1f22387fe2a4dd7b7c6a2f9b41 Mon Sep 17 00:00:00 2001 From: Andy Wood Date: Tue, 2 Mar 2021 10:45:06 -0700 Subject: [PATCH 11/24] udpated whatsnew --- docs/whats-new.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/docs/whats-new.md b/docs/whats-new.md index 15085da6a..88934fa03 100644 --- a/docs/whats-new.md +++ b/docs/whats-new.md @@ -10,4 +10,4 @@ This page provides simple, high-level documentation about what has changed in ea - Fixes a segfault of mysterious origin when using JRDN snow layering - Fixes a water balance error w.r.t transpiration - Fixes the output message to report the correct solution type - +- Adds tolerance to balance check in updatState.f90 From 657151d828cbddfe0dbf53f3b38e8b4bb4989d62 Mon Sep 17 00:00:00 2001 From: Andy Wood Date: Sun, 4 Apr 2021 11:36:51 -0600 Subject: [PATCH 12/24] BUG FIX: correcting calculation of averageRoutedRunoff in run_oneGRU.f90 and qTimeDelay.f90 --- build/source/dshare/get_ixname.f90 | 2 ++ build/source/dshare/globalData.f90 | 2 +- build/source/dshare/popMetadat.f90 | 2 ++ build/source/dshare/var_lookup.f90 | 6 ++-- build/source/engine/checkStruc.f90 | 4 +-- build/source/engine/computFlux.f90 | 17 ++++++----- build/source/engine/derivforce.f90 | 32 +++++++++++++-------- build/source/engine/qTimeDelay.f90 | 16 +++-------- build/source/engine/read_attrb.f90 | 16 ++++++++++- build/source/engine/run_oneGRU.f90 | 45 ++++++++++++++++++------------ 10 files changed, 88 insertions(+), 54 deletions(-) mode change 100755 => 100644 build/source/engine/derivforce.f90 diff --git a/build/source/dshare/get_ixname.f90 b/build/source/dshare/get_ixname.f90 index 1d136c8ac..cf4480218 100755 --- a/build/source/dshare/get_ixname.f90 +++ b/build/source/dshare/get_ixname.f90 @@ -171,6 +171,7 @@ function get_ixAttr(varName) case('contourLength' ); get_ixAttr = iLookATTR%contourLength ! length of contour at downslope edge of HRU (m) case('HRUarea' ); get_ixAttr = iLookATTR%HRUarea ! area of each HRU (m2) case('mHeight' ); get_ixAttr = iLookATTR%mHeight ! measurement height above bare ground (m) + case('aspect' ); get_ixAttr = iLookATTR%aspect ! azimuth in degrees East of North (degrees) ! get to here if cannot find the variable case default get_ixAttr = integerMissing @@ -886,6 +887,7 @@ function get_ixbvar(varName) case('basin__AquiferRecharge' ); get_ixbvar = iLookBVAR%basin__AquiferRecharge ! recharge to the aquifer (m s-1) case('basin__AquiferBaseflow' ); get_ixbvar = iLookBVAR%basin__AquiferBaseflow ! baseflow from the aquifer (m s-1) case('basin__AquiferTranspire' ); get_ixbvar = iLookBVAR%basin__AquiferTranspire ! transpiration from the aquifer (m s-1) + case('basin__TotalRunoff' ); get_ixbvar = iLookBVAR%basin__TotalRunoff ! total runoff to channel from all active components (m s-1) ! variables to compute runoff case('routingRunoffFuture' ); get_ixbvar = iLookBVAR%routingRunoffFuture ! runoff in future time steps (m s-1) case('routingFractionFuture' ); get_ixbvar = iLookBVAR%routingFractionFuture ! fraction of runoff in future time steps (-) diff --git a/build/source/dshare/globalData.f90 b/build/source/dshare/globalData.f90 index 68300c427..e41f2f160 100755 --- a/build/source/dshare/globalData.f90 +++ b/build/source/dshare/globalData.f90 @@ -209,7 +209,7 @@ MODULE globalData type(var_info),save,public :: forc_meta(maxvarForc) ! model forcing data type(var_info),save,public :: attr_meta(maxvarAttr) ! local attributes type(var_info),save,public :: type_meta(maxvarType) ! local classification of veg, soil, etc. - type(var_info),save,public :: id_meta(maxvarId) ! local classification of veg, soil, etc. + type(var_info),save,public :: id_meta(maxvarId) ! local classification of veg, soil, etc. type(var_info),save,public :: mpar_meta(maxvarMpar) ! local model parameters for each HRU type(var_info),save,public :: indx_meta(maxvarIndx) ! local model indices for each HRU type(var_info),save,public :: prog_meta(maxvarProg) ! local state variables for each HRU diff --git a/build/source/dshare/popMetadat.f90 b/build/source/dshare/popMetadat.f90 index 37eb775d3..0a1b32add 100755 --- a/build/source/dshare/popMetadat.f90 +++ b/build/source/dshare/popMetadat.f90 @@ -106,6 +106,7 @@ subroutine popMetadat(err,message) attr_meta(iLookATTR%contourLength) = var_info('contourLength' , 'length of contour at downslope edge of HRU' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) attr_meta(iLookATTR%HRUarea) = var_info('HRUarea' , 'area of each HRU' , 'm2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) attr_meta(iLookATTR%mHeight) = var_info('mHeight' , 'measurement height above bare ground' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + attr_meta(iLookATTR%aspect) = var_info('aspect' , 'mean azimuth of HRU in degrees East of North (0)' , 'degrees' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) ! ----- ! * local parameter data... @@ -588,6 +589,7 @@ subroutine popMetadat(err,message) bvar_meta(iLookBVAR%basin__AquiferRecharge) = var_info('basin__AquiferRecharge' , 'recharge to the aquifer' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) bvar_meta(iLookBVAR%basin__AquiferBaseflow) = var_info('basin__AquiferBaseflow' , 'baseflow from the aquifer' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) bvar_meta(iLookBVAR%basin__AquiferTranspire) = var_info('basin__AquiferTranspire', 'transpiration loss from the aquifer' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + bvar_meta(iLookBVAR%basin__TotalRunoff) = var_info('basin__TotalRunoff' , 'total runoff to channel from all active components' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) bvar_meta(iLookBVAR%routingRunoffFuture) = var_info('routingRunoffFuture' , 'runoff in future time steps' , 'm s-1' , get_ixVarType('routing'), iMissVec, iMissVec, .false.) bvar_meta(iLookBVAR%routingFractionFuture) = var_info('routingFractionFuture' , 'fraction of runoff in future time steps' , '-' , get_ixVarType('routing'), iMissVec, iMissVec, .false.) bvar_meta(iLookBVAR%averageInstantRunoff) = var_info('averageInstantRunoff' , 'instantaneous runoff' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) diff --git a/build/source/dshare/var_lookup.f90 b/build/source/dshare/var_lookup.f90 index a4be930ef..1d7744c8a 100755 --- a/build/source/dshare/var_lookup.f90 +++ b/build/source/dshare/var_lookup.f90 @@ -111,6 +111,7 @@ MODULE var_lookup integer(i4b) :: contourLength = integerMissing ! length of contour at downslope edge of HRU (m) integer(i4b) :: HRUarea = integerMissing ! area of each HRU (m2) integer(i4b) :: mHeight = integerMissing ! measurement height above bare ground (m) + integer(i4b) :: aspect = integerMissing ! mean azimuth of HRU (degrees E of N, range 0-360) end type iLook_attr ! *********************************************************************************************************** @@ -703,6 +704,7 @@ MODULE var_lookup integer(i4b) :: basin__AquiferRecharge = integerMissing ! recharge to the aquifer (m s-1) integer(i4b) :: basin__AquiferBaseflow = integerMissing ! baseflow from the aquifer (m s-1) integer(i4b) :: basin__AquiferTranspire = integerMissing ! transpiration from the aquifer (m s-1) + integer(i4b) :: basin__TotalRunoff = integerMissing ! total runoff to channel from all active components (m s-1) ! define variables for runoff integer(i4b) :: routingRunoffFuture = integerMissing ! runoff in future time steps (m s-1) integer(i4b) :: routingFractionFuture = integerMissing ! fraction of runoff in future time steps (-) @@ -768,7 +770,7 @@ MODULE var_lookup type(iLook_force), public,parameter :: iLookFORCE =iLook_force ( 1, 2, 3, 4, 5, 6, 7, 8) ! named variables: model attributes - type(iLook_attr), public,parameter :: iLookATTR =iLook_attr ( 1, 2, 3, 4, 5, 6, 7) + type(iLook_attr), public,parameter :: iLookATTR =iLook_attr ( 1, 2, 3, 4, 5, 6, 7, 8) ! named variables: soil and vegetation types type(iLook_type), public,parameter :: iLookTYPE =iLook_type ( 1, 2, 3, 4) @@ -839,7 +841,7 @@ MODULE var_lookup ! named variables: basin-average variables type(iLook_bvar), public,parameter :: iLookBVAR =ilook_bvar ( 1, 2, 3, 4, 5, 6, 7, 8, 9, 10,& - 11) + 11, 12) ! named variables in varibale type structure type(iLook_varType), public,parameter :: iLookVarType =ilook_varType ( 1, 2, 3, 4, 5, 6, 7, 8, 9, 10,& diff --git a/build/source/engine/checkStruc.f90 b/build/source/engine/checkStruc.f90 index e9b0a8cdf..3c8a97151 100755 --- a/build/source/engine/checkStruc.f90 +++ b/build/source/engine/checkStruc.f90 @@ -152,10 +152,10 @@ subroutine checkPopulated(iStruct,metadata,err,message) ! loop through variables do iVar=1,size(metadata) - + ! check that this variable is populated if (trim(metadata(iVar)%varname)=='empty') then - write(message,'(a,i0,a)') trim(message)//trim(structInfo(iStruct)%structName)//'_meta structure is not populated for named variable # ',iVar, ' in structure iLook'//trim(structInfo(iStruct)%lookName) + write(message,'(a,i0,a)') trim(message)//trim(structInfo(iStruct)%structName)//'_meta structure is not populated for named variable # ',iVar,' in structure iLook'//trim(structInfo(iStruct)%lookName) err=20; return end if diff --git a/build/source/engine/computFlux.f90 b/build/source/engine/computFlux.f90 index 75b8fc486..30d367807 100755 --- a/build/source/engine/computFlux.f90 +++ b/build/source/engine/computFlux.f90 @@ -445,12 +445,12 @@ subroutine computFlux(& dGroundNetFlux_dCanairTemp, & ! intent(out): derivative in net ground flux w.r.t. canopy air temperature (W m-2 K-1) dGroundNetFlux_dCanopyTemp, & ! intent(out): derivative in net ground flux w.r.t. canopy temperature (W m-2 K-1) dGroundNetFlux_dGroundTemp, & ! intent(out): derivative in net ground flux w.r.t. ground temperature (W m-2 K-1) - ! output: liquid water flux derivarives (canopy evap) + ! output: liquid water flux derivatives (canopy evap) dCanopyEvaporation_dCanLiq, & ! intent(out): derivative in canopy evaporation w.r.t. canopy liquid water content (s-1) dCanopyEvaporation_dTCanair, & ! intent(out): derivative in canopy evaporation w.r.t. canopy air temperature (kg m-2 s-1 K-1) dCanopyEvaporation_dTCanopy, & ! intent(out): derivative in canopy evaporation w.r.t. canopy temperature (kg m-2 s-1 K-1) dCanopyEvaporation_dTGround, & ! intent(out): derivative in canopy evaporation w.r.t. ground temperature (kg m-2 s-1 K-1) - ! output: liquid water flux derivarives (ground evap) + ! output: liquid water flux derivatives (ground evap) dGroundEvaporation_dCanLiq, & ! intent(out): derivative in ground evaporation w.r.t. canopy liquid water content (s-1) dGroundEvaporation_dTCanair, & ! intent(out): derivative in ground evaporation w.r.t. canopy air temperature (kg m-2 s-1 K-1) dGroundEvaporation_dTCanopy, & ! intent(out): derivative in ground evaporation w.r.t. canopy temperature (kg m-2 s-1 K-1) @@ -713,7 +713,7 @@ subroutine computFlux(& ! check if computing soil hydrology if(nSoilOnlyHyd>0)then - ! set baseflow fluxes to zero if the baseflow routine is not used + ! set baseflow fluxes to zero if the topmodel baseflow routine is not used if(local_ixGroundwater/=qbaseTopmodel)then ! (diagnostic variables in the data structures) scalarExfiltration = 0._dp ! exfiltration from the soil profile (m s-1) @@ -729,7 +729,7 @@ subroutine computFlux(& message=trim(message)//'expect dBaseflow_dMatric to be nSoil x nSoil' err=20; return endif - + ! compute the baseflow flux call groundwatr(& ! input: model control @@ -760,6 +760,8 @@ subroutine computFlux(& scalarSoilBaseflow = sum(mLayerBaseflow) ! compute total runoff + ! (Note: scalarSoilBaseflow is zero if topmodel is not used) + ! (Note: scalarSoilBaseflow may need to re-envisioned in topmodel formulation if part of it flow into neighboring soil rather than exfiltrate) scalarTotalRunoff = scalarSurfaceRunoff + scalarSoilDrainage + scalarSoilBaseflow endif ! if computing soil hydrology @@ -771,7 +773,7 @@ subroutine computFlux(& ! check if computing aquifer fluxes if(ixAqWat/=integerMissing)then - + ! identify modeling decision if(local_ixGroundwater==bigBucket)then @@ -793,9 +795,10 @@ subroutine computFlux(& err,cmessage) ! intent(out): error control if(err/=0)then; message=trim(message)//trim(cmessage); return; endif - ! compute total runoff (overwrite previously calculated value before considering aquifer) + ! compute total runoff (overwrite previously calculated value before considering aquifer). + ! (Note: SoilDrainage goes into aquifer, not runoff) scalarTotalRunoff = scalarSurfaceRunoff + scalarAquiferBaseflow - + ! if no aquifer, then fluxes are zero else scalarAquiferTranspire = 0._dp ! transpiration loss from the aquifer (m s-1) diff --git a/build/source/engine/derivforce.f90 b/build/source/engine/derivforce.f90 old mode 100755 new mode 100644 index 563d9f1f0..eb378c4f1 --- a/build/source/engine/derivforce.f90 +++ b/build/source/engine/derivforce.f90 @@ -92,8 +92,8 @@ subroutine derivforce(time_data,forc_data,attr_data,mpar_data,prog_data,diag_dat ! cosine of the solar zenith angle real(dp) :: ahour ! hour at start of time step real(dp) :: dataStep ! data step (hours) - real(dp),parameter :: slope=0._dp ! terrain slope (assume flat) - real(dp),parameter :: azimuth=0._dp ! terrain azimuth (assume zero) + real(dp) :: slope ! HRU terrain slope (degrees) + real(dp) :: azimuth ! HRU terrain azimuth (degrees) real(dp) :: hri ! average radiation index over time step DT ! general local variables character(len=256) :: cmessage ! error message for downwind routine @@ -134,6 +134,7 @@ subroutine derivforce(time_data,forc_data,attr_data,mpar_data,prog_data,diag_dat newSnowDenMultWind => mpar_data%var(iLookPARAM%newSnowDenMultWind)%dat(1) , & ! Pahaut 1976, multiplier for new snow density applied to wind speed (kg m-7/2 s-1/2) newSnowDenMultAnd => mpar_data%var(iLookPARAM%newSnowDenMultAnd)%dat(1) , & ! Anderson 1976, multiplier for new snow density for Anderson function (K-1) newSnowDenBase => mpar_data%var(iLookPARAM%newSnowDenBase)%dat(1) , & ! Anderson 1976, base value that is rasied to the (3/2) power (K) + heightCanopyTop => mpar_data%var(iLookPARAM%heightCanopyTop)%dat(1) , & ! height of the top of the canopy layer (m) ! radiation geometry variables iyyy => time_data(iLookTIME%iyyy) , & ! year im => time_data(iLookTIME%im) , & ! month @@ -142,12 +143,13 @@ subroutine derivforce(time_data,forc_data,attr_data,mpar_data,prog_data,diag_dat imin => time_data(iLookTIME%imin) , & ! minute latitude => attr_data(iLookATTR%latitude) , & ! latitude (degrees north) longitude => attr_data(iLookATTR%longitude) , & ! longitude (degrees east) + tan_slope => attr_data(iLookATTR%tan_slope) , & ! tan HRU ground surface slope (-) + aspect => attr_data(iLookATTR%aspect) , & ! mean azimuth of HRU in degrees E of N (degrees) cosZenith => diag_data%var(iLookDIAG%scalarCosZenith)%dat(1) , & ! average cosine of the zenith angle over time step DT ! measurement height mHeight => attr_data(iLookATTR%mHeight) , & ! latitude (degrees north) adjMeasHeight => diag_data%var(iLookDIAG%scalarAdjMeasHeight)%dat(1) , & ! adjusted measurement height (m) scalarSnowDepth => prog_data%var(iLookPROG%scalarSnowDepth)%dat(1) , & ! snow depth on the ground surface (m) - heightCanopyTop => mpar_data%var(iLookPARAM%heightCanopyTop)%dat(1) , & ! height of the top of the canopy layer (m) ! model time secondsSinceRefTime => forc_data(iLookFORCE%time) , & ! time = seconds since reference time ! model forcing data @@ -215,9 +217,9 @@ subroutine derivforce(time_data,forc_data,attr_data,mpar_data,prog_data,diag_dat end select ! identifying option tmZoneInfo ! constrain timeOffset so that it is in the [-0.5, 0.5] range - if(timeOffset<-0.5)then + if(timeOffset < -0.5)then timeOffset = timeOffset+1 - else if(timeOffset>0.5)then + else if(timeOffset > 0.5)then timeOffset = timeOffset-1 endif @@ -234,11 +236,21 @@ subroutine derivforce(time_data,forc_data,attr_data,mpar_data,prog_data,diag_dat dataStep = data_step/secprhour ! time step (hours) ahour = real(jh,kind(dp)) + real(jmin,kind(dp))/minprhour - data_step/secprhour ! decimal hour (start of the step) + ! check slope/aspect intent for radiation calculation + if(aspect == -1)then + azimuth = 0._dp ! if aspect is not an input attribute, slope & azimuth = zero (flat Earth) + slope = 0._dp + else + azimuth = aspect ! in degrees + slope = atan(abs(tan_slope))*180.0D0/PI_D ! convert from m/m to degrees + endif + ! compute the cosine of the solar zenith angle call clrsky_rad(jm,jd,ahour,dataStep, & ! intent(in): time variables slope,azimuth,latitude, & ! intent(in): location variables hri,cosZenith) ! intent(out): cosine of the solar zenith angle - !write(*,'(a,1x,4(i2,1x),3(f9.3,1x))') 'im,id,ih,imin,ahour,dataStep,cosZenith = ', & + !write(*,'(a,1x,4(i2,1x),5(f9.3,1x))') 'im,id,ih,imin,ahour,dataStep,azimuth,slope,cosZenith = ', & + ! im,id,ih,imin,ahour,dataStep,azimuth,slope,cosZenith ! ensure solar radiation is non-negative if(SWRadAtm < 0._dp) SWRadAtm = 0._dp @@ -255,6 +267,9 @@ subroutine derivforce(time_data,forc_data,attr_data,mpar_data,prog_data,diag_dat spectralIncomingDiffuse(1) = SWRadAtm*(1._dp - scalarFractionDirect)*Frad_vis ! (diffuse vis) spectralIncomingDiffuse(2) = SWRadAtm*(1._dp - scalarFractionDirect)*(1._dp - Frad_vis) ! (diffuse nir) + !print*,'Frad_direct,scalarFractionDirect,directScale,SWRadAtm,Frad_vis,spectralIncomingDirect: ', & + ! frad_direct,scalarFractionDirect,directScale,SWRadAtm,Frad_vis,spectralIncomingDirect + ! ensure wind speed is above a prescribed minimum value if(windspd < minwind) windspd=minwind @@ -289,8 +304,6 @@ subroutine derivforce(time_data,forc_data,attr_data,mpar_data,prog_data,diag_dat fracrain = (Tmax - tempCritRain)/(Tmax - Tmin) snowfallTemp = 0.5_dp*(Tmin + maxFrozenSnowTemp) end if - !write(*,'(a,1x,10(f20.10,1x))') 'Tmin, twetbulb, tempRangeTimestep, tempCritRain = ', & - ! Tmin, twetbulb, tempRangeTimestep, tempCritRain ! ensure that snowfall temperature creates predominantely solid precipitation snowfallTemp = min(maxFrozenSnowTemp,snowfallTemp) ! snowfall temperature @@ -306,9 +319,6 @@ subroutine derivforce(time_data,forc_data,attr_data,mpar_data,prog_data,diag_dat snowfall = (1._dp - fracrain)*pptrate*frozenPrecipMultip end if - !print*, 'tempCritRain, tempRangeTimestep, pptrate, airtemp, rainfall, snowfall, twetbulb, relhum, snowfallTemp = ' - !print*, tempCritRain, tempRangeTimestep, pptrate, airtemp, rainfall, snowfall, twetbulb, relhum, snowfallTemp - ! compute density of new snow if(snowfall > tiny(fracrain))then ! Determine which method to use diff --git a/build/source/engine/qTimeDelay.f90 b/build/source/engine/qTimeDelay.f90 index 75cb75c0a..4997b4577 100755 --- a/build/source/engine/qTimeDelay.f90 +++ b/build/source/engine/qTimeDelay.f90 @@ -40,9 +40,7 @@ module qTimeDelay_module subroutine qOverland(& ! input ixRouting, & ! index for routing method - averageSurfaceRunoff, & ! surface runoff (m s-1) - averageSoilBaseflow, & ! baseflow from the soil profile (m s-1) - averageAquiferBaseflow,& ! baseflow from the aquifer (m s-1) + averageTotalRunoff, & ! total runoff to the channel from all active components (m s-1) fracFuture, & ! fraction of runoff in future time steps (m s-1) qFuture, & ! runoff in future time steps (m s-1) ! output @@ -52,9 +50,7 @@ subroutine qOverland(& implicit none ! input integer(i4b),intent(in) :: ixRouting ! index for routing method - real(dp),intent(in) :: averageSurfaceRunoff ! surface runoff (m s-1) - real(dp),intent(in) :: averageSoilBaseflow ! baseflow from the soil profile (m s-1) - real(dp),intent(in) :: averageAquiferBaseflow ! baseflow from the aquifer (m s-1) + real(dp),intent(in) :: averageTotalRunoff ! total runoff to the channel from all active components (m s-1) real(dp),intent(in) :: fracFuture(:) ! fraction of runoff in future time steps (m s-1) real(dp),intent(inout) :: qFuture(:) ! runoff in future time steps (m s-1) ! output @@ -68,8 +64,8 @@ subroutine qOverland(& ! initialize error control err=0; message='qOverland/' - ! compute instantaneous runoff (m s-1) - averageInstantRunoff = averageSurfaceRunoff + averageAquiferBaseflow + averageSoilBaseflow + ! assign instantaneous runoff (m s-1) (Note: this variable is redundant with averageTotalRunoff, could remove) + averageInstantRunoff = averageTotalRunoff ! compute routed runoff (m s-1) select case(ixRouting) ! (select option for sub-grid routing) @@ -91,10 +87,6 @@ subroutine qOverland(& end do qFuture(nTDH) = 0._dp - !print*, 'averageInstantRunoff, averageRoutedRunoff = ', averageInstantRunoff, averageRoutedRunoff - !print*, 'qFuture(1:100) = ', qFuture(1:100) - !pause - ! ** error checking case default; err=20; message=trim(message)//'cannot find option for sub-grid routing'; return diff --git a/build/source/engine/read_attrb.f90 b/build/source/engine/read_attrb.f90 index e07fff1a1..651a0a4a3 100755 --- a/build/source/engine/read_attrb.f90 +++ b/build/source/engine/read_attrb.f90 @@ -321,7 +321,7 @@ subroutine read_attrb(attrFile,nGRU,attrStruct,typeStruct,idStruct,err,message) end do ! ** numerical data - case('latitude','longitude','elevation','tan_slope','contourLength','HRUarea','mHeight') + case('latitude','longitude','elevation','tan_slope','contourLength','HRUarea','mHeight','aspect') ! get the index of the variable varType = numerical @@ -349,6 +349,20 @@ subroutine read_attrb(attrFile,nGRU,attrStruct,typeStruct,idStruct,err,message) end select ! select variable end do ! (looping through netcdf local attribute file) + + ! ** now handle the optional aspect variable if it's missing + varIndx = get_ixAttr('aspect') + ! check that the variable was not found in the attribute file + if(.not. checkAttr(varIndx)) then + write(*,*) NEW_LINE('A')//'INFO: aspect not found in the input attribute file, continuing ...'//NEW_LINE('A') + + do iGRU=1,nGRU + do iHRU = 1, gru_struc(iGRU)%hruCount + attrStruct%gru(iGRU)%hru(iHRU)%var(varIndx) = -1._dp ! populate variable with out-of-range value, used later + end do + end do + checkAttr(varIndx) = .true. + endif ! ********************************************************************************************** ! (4) check that we have all the desired varaibles diff --git a/build/source/engine/run_oneGRU.f90 b/build/source/engine/run_oneGRU.f90 index 653585ac7..8110c194f 100755 --- a/build/source/engine/run_oneGRU.f90 +++ b/build/source/engine/run_oneGRU.f90 @@ -54,8 +54,9 @@ module run_oneGRU_module ! provide access to the named variables that describe model decisions USE mDecisions_module,only:& ! look-up values for the choice of method for the spatial representation of groundwater - localColumn, & ! separate groundwater representation in each local soil column - singleBasin ! single groundwater store over the entire basin + localColumn, & ! separate groundwater representation in each local soil column + singleBasin, & ! single groundwater store over the entire basin + bigBucket ! a big bucket (lumped aquifer model) ! ----------------------------------------------------------------------------------------------------------------------------------- ! ----------------------------------------------------------------------------------------------------------------------------------- @@ -142,6 +143,7 @@ subroutine run_oneGRU(& ! initialize runoff variables bvarData%var(iLookBVAR%basin__SurfaceRunoff)%dat(1) = 0._dp ! surface runoff (m s-1) bvarData%var(iLookBVAR%basin__ColumnOutflow)%dat(1) = 0._dp ! outflow from all "outlet" HRUs (those with no downstream HRU) + bvarData%var(iLookBVAR%basin__TotalRunoff)%dat(1) = 0._dp ! total runoff to the channel from all active components (m s-1) ! initialize baseflow variables bvarData%var(iLookBVAR%basin__AquiferRecharge)%dat(1) = 0._dp ! recharge to the aquifer (m s-1) @@ -200,14 +202,17 @@ subroutine run_oneGRU(& gruInfo%hruInfo(iHRU)%nSoil = nSoil ! save the flag for computing the vegetation fluxes - if(computeVegFluxFlag) ixComputeVegFlux(iHRU) = yes - if(.not.computeVegFluxFlag) ixComputeVegFlux(iHRU) = no - - ! ----- compute fluxes across HRUs -------------------------------------------------------------------------------------------------- + if(computeVegFluxFlag) ixComputeVegFlux(iHRU) = yes + if(.not. computeVegFluxFlag) ixComputeVegFlux(iHRU) = no ! identify the area covered by the current HRU - fracHRU = attrHRU%hru(iHRU)%var(iLookATTR%HRUarea) / bvarData%var(iLookBVAR%basin__totalArea)%dat(1) + fracHRU = attrHRU%hru(iHRU)%var(iLookATTR%HRUarea) / bvarData%var(iLookBVAR%basin__totalArea)%dat(1) + ! (Note: for efficiency, this could this be done as a setup task, not every timestep) + ! ----- compute fluxes across HRUs -------------------------------------------------------------------------------------------------- + + ! identify lateral connectivity + ! (Note: for efficiency, this could this be done as a setup task, not every timestep) kHRU = 0 ! identify the downslope HRU dsHRU: do jHRU=1,gruInfo%hruCount @@ -219,29 +224,35 @@ subroutine run_oneGRU(& end if ! (if identified a downslope HRU) end do dsHRU - ! add inflow to the downslope HRU + ! if lateral flows are active, add inflow to the downslope HRU if(kHRU > 0)then ! if there is a downslope HRU fluxHRU%hru(kHRU)%var(iLookFLUX%mLayerColumnInflow)%dat(:) = fluxHRU%hru(kHRU)%var(iLookFLUX%mLayerColumnInflow)%dat(:) + fluxHRU%hru(iHRU)%var(iLookFLUX%mLayerColumnOutflow)%dat(:) - ! increment basin column outflow (m3 s-1) + ! otherwise just increment basin (GRU) column outflow (m3 s-1) with the hru fraction else - bvarData%var(iLookBVAR%basin__ColumnOutflow)%dat(1) = bvarData%var(iLookBVAR%basin__ColumnOutflow)%dat(1) + sum(fluxHRU%hru(iHRU)%var(iLookFLUX%mLayerColumnOutflow)%dat(:)) + bvarData%var(iLookBVAR%basin__ColumnOutflow)%dat(1) = bvarData%var(iLookBVAR%basin__ColumnOutflow)%dat(1) + sum(fluxHRU%hru(iHRU)%var(iLookFLUX%mLayerColumnOutflow)%dat(:)) end if + ! ----- calculate weighted basin (GRU) fluxes -------------------------------------------------------------------------------------- + + ! increment basin total runoff (m s-1) + bvarData%var(iLookBVAR%basin__TotalRunoff)%dat(1) = bvarData%var(iLookBVAR%basin__TotalRunoff)%dat(1) + fluxHRU%hru(iHRU)%var(iLookFLUX%scalarTotalRunoff)%dat(1) * fracHRU + ! increment basin surface runoff (m s-1) - bvarData%var(iLookBVAR%basin__SurfaceRunoff)%dat(1) = bvarData%var(iLookBVAR%basin__SurfaceRunoff)%dat(1) + fluxHRU%hru(iHRU)%var(iLookFLUX%scalarSurfaceRunoff)%dat(1) * fracHRU + bvarData%var(iLookBVAR%basin__SurfaceRunoff)%dat(1) = bvarData%var(iLookBVAR%basin__SurfaceRunoff)%dat(1) + fluxHRU%hru(iHRU)%var(iLookFLUX%scalarSurfaceRunoff)%dat(1) * fracHRU ! increment basin-average baseflow input variables (m s-1) bvarData%var(iLookBVAR%basin__AquiferRecharge)%dat(1) = bvarData%var(iLookBVAR%basin__AquiferRecharge)%dat(1) + fluxHRU%hru(iHRU)%var(iLookFLUX%scalarSoilDrainage)%dat(1) * fracHRU bvarData%var(iLookBVAR%basin__AquiferTranspire)%dat(1) = bvarData%var(iLookBVAR%basin__AquiferTranspire)%dat(1) + fluxHRU%hru(iHRU)%var(iLookFLUX%scalarAquiferTranspire)%dat(1) * fracHRU - ! increment aquifer baseflow -- ONLY if baseflow is computed individually for each HRU + ! increment aquifer baseflow -- ONLY if aquifer baseflow is computed individually for each HRU and aquifer is run ! NOTE: groundwater computed later for singleBasin - if(model_decisions(iLookDECISIONS%spatial_gw)%iDecision == localColumn)then + if(model_decisions(iLookDECISIONS%spatial_gw)%iDecision == localColumn .and. model_decisions(iLookDECISIONS%groundwatr)%iDecision == bigBucket) then bvarData%var(iLookBVAR%basin__AquiferBaseflow)%dat(1) = bvarData%var(iLookBVAR%basin__AquiferBaseflow)%dat(1) & - + fluxHRU%hru(iHRU)%var(iLookFLUX%scalarAquiferBaseflow)%dat(1) * fracHRU & - + fluxHRU%hru(iHRU)%var(iLookFLUX%scalarSoilDrainage)%dat(1) * fracHRU + + fluxHRU%hru(iHRU)%var(iLookFLUX%scalarAquiferBaseflow)%dat(1) * fracHRU end if + + ! averaging more fluxes (and/or states) can be added to this section as desired end do ! (looping through HRUs) @@ -260,9 +271,7 @@ subroutine run_oneGRU(& call qOverland(& ! input model_decisions(iLookDECISIONS%subRouting)%iDecision, & ! intent(in): index for routing method - bvarData%var(iLookBVAR%basin__SurfaceRunoff)%dat(1), & ! intent(in): surface runoff (m s-1) - bvarData%var(iLookBVAR%basin__ColumnOutflow)%dat(1)/totalArea, & ! intent(in): outflow from all "outlet" HRUs (those with no downstream HRU) - bvarData%var(iLookBVAR%basin__AquiferBaseflow)%dat(1), & ! intent(in): baseflow from the aquifer (m s-1) + bvarData%var(iLookBVAR%basin__TotalRunoff)%dat(1), & ! intent(in): total runoff to the channel from all active components (m s-1) bvarData%var(iLookBVAR%routingFractionFuture)%dat, & ! intent(in): fraction of runoff in future time steps (m s-1) bvarData%var(iLookBVAR%routingRunoffFuture)%dat, & ! intent(in): runoff in future time steps (m s-1) ! output From 92c5591a8a59e742e1d15ac99b8fd0962be0a99e Mon Sep 17 00:00:00 2001 From: Andy Wood Date: Mon, 5 Apr 2021 11:24:38 -0600 Subject: [PATCH 13/24] Minor cleanup on PR #454 (A. Wood) to add solar radiation functionality and fix basin runoff bug --- build/source/engine/checkStruc.f90 | 2 +- build/source/engine/computFlux.f90 | 6 +++--- build/source/engine/derivforce.f90 | 6 +++--- build/source/engine/read_attrb.f90 | 2 +- 4 files changed, 8 insertions(+), 8 deletions(-) diff --git a/build/source/engine/checkStruc.f90 b/build/source/engine/checkStruc.f90 index 3c8a97151..7f8ddbd83 100755 --- a/build/source/engine/checkStruc.f90 +++ b/build/source/engine/checkStruc.f90 @@ -152,7 +152,7 @@ subroutine checkPopulated(iStruct,metadata,err,message) ! loop through variables do iVar=1,size(metadata) - + ! check that this variable is populated if (trim(metadata(iVar)%varname)=='empty') then write(message,'(a,i0,a)') trim(message)//trim(structInfo(iStruct)%structName)//'_meta structure is not populated for named variable # ',iVar,' in structure iLook'//trim(structInfo(iStruct)%lookName) diff --git a/build/source/engine/computFlux.f90 b/build/source/engine/computFlux.f90 index 30d367807..9a4e1e1c9 100755 --- a/build/source/engine/computFlux.f90 +++ b/build/source/engine/computFlux.f90 @@ -729,7 +729,7 @@ subroutine computFlux(& message=trim(message)//'expect dBaseflow_dMatric to be nSoil x nSoil' err=20; return endif - + ! compute the baseflow flux call groundwatr(& ! input: model control @@ -773,7 +773,7 @@ subroutine computFlux(& ! check if computing aquifer fluxes if(ixAqWat/=integerMissing)then - + ! identify modeling decision if(local_ixGroundwater==bigBucket)then @@ -798,7 +798,7 @@ subroutine computFlux(& ! compute total runoff (overwrite previously calculated value before considering aquifer). ! (Note: SoilDrainage goes into aquifer, not runoff) scalarTotalRunoff = scalarSurfaceRunoff + scalarAquiferBaseflow - + ! if no aquifer, then fluxes are zero else scalarAquiferTranspire = 0._dp ! transpiration loss from the aquifer (m s-1) diff --git a/build/source/engine/derivforce.f90 b/build/source/engine/derivforce.f90 index eb378c4f1..b2c2f3561 100644 --- a/build/source/engine/derivforce.f90 +++ b/build/source/engine/derivforce.f90 @@ -218,9 +218,9 @@ subroutine derivforce(time_data,forc_data,attr_data,mpar_data,prog_data,diag_dat ! constrain timeOffset so that it is in the [-0.5, 0.5] range if(timeOffset < -0.5)then - timeOffset = timeOffset+1 + timeOffset = timeOffset + 1 else if(timeOffset > 0.5)then - timeOffset = timeOffset-1 + timeOffset = timeOffset - 1 endif ! compute the local time @@ -237,7 +237,7 @@ subroutine derivforce(time_data,forc_data,attr_data,mpar_data,prog_data,diag_dat ahour = real(jh,kind(dp)) + real(jmin,kind(dp))/minprhour - data_step/secprhour ! decimal hour (start of the step) ! check slope/aspect intent for radiation calculation - if(aspect == -1)then + if(aspect == nr_realMissing)then azimuth = 0._dp ! if aspect is not an input attribute, slope & azimuth = zero (flat Earth) slope = 0._dp else diff --git a/build/source/engine/read_attrb.f90 b/build/source/engine/read_attrb.f90 index 651a0a4a3..652f1f249 100755 --- a/build/source/engine/read_attrb.f90 +++ b/build/source/engine/read_attrb.f90 @@ -358,7 +358,7 @@ subroutine read_attrb(attrFile,nGRU,attrStruct,typeStruct,idStruct,err,message) do iGRU=1,nGRU do iHRU = 1, gru_struc(iGRU)%hruCount - attrStruct%gru(iGRU)%hru(iHRU)%var(varIndx) = -1._dp ! populate variable with out-of-range value, used later + attrStruct%gru(iGRU)%hru(iHRU)%var(varIndx) = nr_realMissing ! populate variable with out-of-range value, used later end do end do checkAttr(varIndx) = .true. From c5f9ef908777f5c758f7bfecaac6fde40d7a8a5f Mon Sep 17 00:00:00 2001 From: wknoben Date: Wed, 7 Apr 2021 08:39:03 -0600 Subject: [PATCH 14/24] Added note to docs about how SUMMA expects gru/hru order in nc files --- docs/input_output/SUMMA_input.md | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/docs/input_output/SUMMA_input.md b/docs/input_output/SUMMA_input.md index 82660ef34..62d4ce2fd 100644 --- a/docs/input_output/SUMMA_input.md +++ b/docs/input_output/SUMMA_input.md @@ -16,6 +16,16 @@ ASCII or text files are in a format that can be modified using a text editor. Co SUMMA input files in NetCDF format can include variables (and dimensions) other than those specified below. They will simply not be read by SUMMA, but may be useful to facilitate further analysis and/or visualization. For example, it may be convenient to include latitude and longitude in many of the spatial files to allow visualization. +#### Note on GRU and HRU order in NetCDF files +SUMMA makes certain assumptions about GRU and HRU order in its input files, as determined in the `gruId` and `hruId` variables in these files. SUMMA expects the `gruId` and `hruId` variables to have identical orders in the forcing, attributes, coldState and trialParameter `.nc` files. Note that this is unrelated to the actual values of the `gruId` and `hruId` variables. In cases where each GRU contains exactly one HRU, no action is needed beyond ensuring that these files use the same order of IDs. In cases where a GRU contains multiple HRUs, SUMMA additionally expects that the HRUs inside a given GRU are found at subsequent indices in each NetCDF file (see table for an example of correct [left] and incorrect [right] order specification; `gruId` and `hruId` values set at arbitrary values to emphasize it is the order that matters, not the values themselves). + +| Index in file | gruId | hruId | < correct
incorrect > | gruId | hruId | +|---------------|----------|-------|:---------------------------|-----------|-------| +| 1 | 10 | 100 | | 10 | 100 | +| 2 | 10 | 300 | | 20 | 200 | +| 3 | 20 | 200 | | 10 | 300 | +| 4 | 20 | 400 | | 20 | 400 | + ## Master configuration file The master configuration file is an [ASCII file](#infile_format_ASCII) and is provided to SUMMA at run-time as a command-line option. The path to this file needs to be supplied with the `-m` or `--master` command-line flag. The contents of this file orchestrate the remainder of the SUMMA run and are processed by the code in `build/source/hookup/summaFileManager.f90`. The file contents mostly consist of file paths that provide the actual information about the model configuration. It also contains the run period and forcing time zone information. From b57d76607ddad91a46c6883bed02b5abc512d5f7 Mon Sep 17 00:00:00 2001 From: Andy Wood Date: Wed, 7 Apr 2021 11:36:13 -0600 Subject: [PATCH 15/24] update to run_oneGRU to organize the total_runoff calculations, summing basin column outflow rather than soil baseflow --- build/source/engine/computFlux.f90 | 2 +- build/source/engine/derivforce.f90 | 2 +- build/source/engine/run_oneGRU.f90 | 27 ++++++++++++++++++--------- 3 files changed, 20 insertions(+), 11 deletions(-) diff --git a/build/source/engine/computFlux.f90 b/build/source/engine/computFlux.f90 index 9a4e1e1c9..7a900c96f 100755 --- a/build/source/engine/computFlux.f90 +++ b/build/source/engine/computFlux.f90 @@ -761,7 +761,7 @@ subroutine computFlux(& ! compute total runoff ! (Note: scalarSoilBaseflow is zero if topmodel is not used) - ! (Note: scalarSoilBaseflow may need to re-envisioned in topmodel formulation if part of it flow into neighboring soil rather than exfiltrate) + ! (Note: scalarSoilBaseflow may need to re-envisioned in topmodel formulation if parts of it flow into neighboring soil rather than exfiltrate) scalarTotalRunoff = scalarSurfaceRunoff + scalarSoilDrainage + scalarSoilBaseflow endif ! if computing soil hydrology diff --git a/build/source/engine/derivforce.f90 b/build/source/engine/derivforce.f90 index b2c2f3561..fbf6d7dba 100644 --- a/build/source/engine/derivforce.f90 +++ b/build/source/engine/derivforce.f90 @@ -242,7 +242,7 @@ subroutine derivforce(time_data,forc_data,attr_data,mpar_data,prog_data,diag_dat slope = 0._dp else azimuth = aspect ! in degrees - slope = atan(abs(tan_slope))*180.0D0/PI_D ! convert from m/m to degrees + slope = atan(abs(tan_slope))*180._dp/PI_D ! convert from m/m to degrees endif ! compute the cosine of the solar zenith angle diff --git a/build/source/engine/run_oneGRU.f90 b/build/source/engine/run_oneGRU.f90 index 8110c194f..1925774e6 100755 --- a/build/source/engine/run_oneGRU.f90 +++ b/build/source/engine/run_oneGRU.f90 @@ -142,6 +142,7 @@ subroutine run_oneGRU(& ! initialize runoff variables bvarData%var(iLookBVAR%basin__SurfaceRunoff)%dat(1) = 0._dp ! surface runoff (m s-1) + bvarData%var(iLookBVAR%basin__SoilDrainage)%dat(1) = 0._dp ! soil drainage (m s-1) bvarData%var(iLookBVAR%basin__ColumnOutflow)%dat(1) = 0._dp ! outflow from all "outlet" HRUs (those with no downstream HRU) bvarData%var(iLookBVAR%basin__TotalRunoff)%dat(1) = 0._dp ! total runoff to the channel from all active components (m s-1) @@ -235,23 +236,22 @@ subroutine run_oneGRU(& ! ----- calculate weighted basin (GRU) fluxes -------------------------------------------------------------------------------------- - ! increment basin total runoff (m s-1) - bvarData%var(iLookBVAR%basin__TotalRunoff)%dat(1) = bvarData%var(iLookBVAR%basin__TotalRunoff)%dat(1) + fluxHRU%hru(iHRU)%var(iLookFLUX%scalarTotalRunoff)%dat(1) * fracHRU - ! increment basin surface runoff (m s-1) - bvarData%var(iLookBVAR%basin__SurfaceRunoff)%dat(1) = bvarData%var(iLookBVAR%basin__SurfaceRunoff)%dat(1) + fluxHRU%hru(iHRU)%var(iLookFLUX%scalarSurfaceRunoff)%dat(1) * fracHRU + bvarData%var(iLookBVAR%basin__SurfaceRunoff)%dat(1) = bvarData%var(iLookBVAR%basin__SurfaceRunoff)%dat(1) + fluxHRU%hru(iHRU)%var(iLookFLUX%scalarSurfaceRunoff)%dat(1) * fracHRU - ! increment basin-average baseflow input variables (m s-1) - bvarData%var(iLookBVAR%basin__AquiferRecharge)%dat(1) = bvarData%var(iLookBVAR%basin__AquiferRecharge)%dat(1) + fluxHRU%hru(iHRU)%var(iLookFLUX%scalarSoilDrainage)%dat(1) * fracHRU - bvarData%var(iLookBVAR%basin__AquiferTranspire)%dat(1) = bvarData%var(iLookBVAR%basin__AquiferTranspire)%dat(1) + fluxHRU%hru(iHRU)%var(iLookFLUX%scalarAquiferTranspire)%dat(1) * fracHRU + ! increment basin soil drainage (m s-1) + bvarData%var(iLookBVAR%basin__SoilDrainage)%dat(1) = bvarData%var(iLookBVAR%basin__SoilDrainage)%dat(1) + fluxHRU%hru(iHRU)%var(iLookFLUX%scalarSoilDrainage)%dat(1) * fracHRU - ! increment aquifer baseflow -- ONLY if aquifer baseflow is computed individually for each HRU and aquifer is run + ! increment aquifer variables -- ONLY if aquifer baseflow is computed individually for each HRU and aquifer is run ! NOTE: groundwater computed later for singleBasin if(model_decisions(iLookDECISIONS%spatial_gw)%iDecision == localColumn .and. model_decisions(iLookDECISIONS%groundwatr)%iDecision == bigBucket) then + + bvarData%var(iLookBVAR%basin__AquiferRecharge)%dat(1) = bvarData%var(iLookBVAR%basin__AquiferRecharge)%dat(1) + fluxHRU%hru(iHRU)%var(iLookFLUX%scalarSoilDrainage)%dat(1) * fracHRU + bvarData%var(iLookBVAR%basin__AquiferTranspire)%dat(1) = bvarData%var(iLookBVAR%basin__AquiferTranspire)%dat(1) + fluxHRU%hru(iHRU)%var(iLookFLUX%scalarAquiferTranspire)%dat(1) * fracHRU bvarData%var(iLookBVAR%basin__AquiferBaseflow)%dat(1) = bvarData%var(iLookBVAR%basin__AquiferBaseflow)%dat(1) & + fluxHRU%hru(iHRU)%var(iLookFLUX%scalarAquiferBaseflow)%dat(1) * fracHRU end if - + ! averaging more fluxes (and/or states) can be added to this section as desired end do ! (looping through HRUs) @@ -266,6 +266,15 @@ subroutine run_oneGRU(& err=20; return end if + ! calculate total runoff depending on whether aquifer is connected + if(model_decisions(iLookDECISIONS%groundwatr)%iDecision == bigBucket) then + ! aquifer + bvarData%var(iLookBVAR%basin__TotalRunoff)%dat(1) = bvarData%var(iLookBVAR%basin__SurfaceRunoff)%dat(1) + bvarData%var(iLookBVAR%basin__ColumnOutflow)%dat(1)/totalArea + bvarData%var(iLookBVAR%basin__AquiferBaseflow)%dat(1) + else + ! no aquifer + bvarData%var(iLookBVAR%basin__TotalRunoff)%dat(1) = bvarData%var(iLookBVAR%basin__SurfaceRunoff)%dat(1) + bvarData%var(iLookBVAR%basin__ColumnOutflow)%dat(1)/totalArea + bvarData%var(iLookBVAR%basin__SoilDrainage)%dat(1) + endif + ! perform the routing associate(totalArea => bvarData%var(iLookBVAR%basin__totalArea)%dat(1) ) call qOverland(& From 5774f6bd572659e0b4d840087eee881977363037 Mon Sep 17 00:00:00 2001 From: arbennett Date: Wed, 12 May 2021 13:21:56 -0700 Subject: [PATCH 16/24] First pass on single precision, compiles, but does not run --- build/source/driver/summa_globalData.f90 | 2 +- build/source/driver/summa_init.f90 | 6 +- build/source/driver/summa_modelRun.f90 | 14 +- build/source/driver/summa_restart.f90 | 8 +- build/source/driver/summa_setup.f90 | 6 +- build/source/driver/summa_type.f90 | 4 +- build/source/driver/summa_util.f90 | 8 +- build/source/dshare/data_types.f90 | 16 +- build/source/dshare/globalData.f90 | 40 +- build/source/dshare/multiconst.f90 | 58 +- build/source/dshare/outpt_stat.f90 | 18 +- build/source/engine/allocspace.f90 | 20 +- build/source/engine/bigAquifer.f90 | 20 +- build/source/engine/canopySnow.f90 | 58 +- build/source/engine/check_icond.f90 | 36 +- build/source/engine/computFlux.f90 | 70 +- build/source/engine/computJacob.f90 | 38 +- build/source/engine/computResid.f90 | 32 +- build/source/engine/convE2Temp.f90 | 72 +- build/source/engine/conv_funcs.f90 | 138 +- build/source/engine/coupled_em.f90 | 156 +- build/source/engine/derivforce.f90 | 92 +- build/source/engine/diagn_evar.f90 | 74 +- build/source/engine/eval8summa.f90 | 62 +- build/source/engine/expIntegral.f90 | 38 +- build/source/engine/f2008funcs.f90 | 6 +- build/source/engine/ffile_info.f90 | 2 +- build/source/engine/getVectorz.f90 | 86 +- build/source/engine/groundwatr.f90 | 114 +- build/source/engine/layerDivide.f90 | 42 +- build/source/engine/layerMerge.f90 | 42 +- build/source/engine/mDecisions.f90 | 8 +- build/source/engine/matrixOper.f90 | 26 +- build/source/engine/nr_utility.f90 | 36 +- build/source/engine/nrtype.f90 | 11 +- build/source/engine/opSplittin.f90 | 34 +- build/source/engine/pOverwrite.f90 | 2 +- build/source/engine/paramCheck.f90 | 10 +- build/source/engine/qTimeDelay.f90 | 16 +- build/source/engine/read_attrb.f90 | 2 +- build/source/engine/read_force.f90 | 48 +- build/source/engine/read_param.f90 | 2 +- build/source/engine/read_pinit.f90 | 8 +- build/source/engine/run_oneGRU.f90 | 16 +- build/source/engine/run_oneHRU.f90 | 6 +- build/source/engine/snowAlbedo.f90 | 52 +- build/source/engine/snowLiqFlx.f90 | 36 +- build/source/engine/snow_utils.f90 | 38 +- build/source/engine/snwCompact.f90 | 80 +- build/source/engine/soilLiqFlx.f90 | 510 +++---- build/source/engine/soil_utils.f90 | 448 +++--- build/source/engine/spline_int.f90 | 48 +- build/source/engine/ssdNrgFlux.f90 | 34 +- build/source/engine/stomResist.f90 | 370 ++--- build/source/engine/summaSolve.f90 | 276 ++-- build/source/engine/sunGeomtry.f90 | 52 +- build/source/engine/systemSolv.f90 | 58 +- build/source/engine/tempAdjust.f90 | 62 +- build/source/engine/time_utils.f90 | 46 +- build/source/engine/updatState.f90 | 44 +- build/source/engine/updateVars.f90 | 96 +- build/source/engine/varSubstep.f90 | 142 +- build/source/engine/var_derive.f90 | 96 +- build/source/engine/vegLiqFlux.f90 | 30 +- build/source/engine/vegNrgFlux.f90 | 1290 ++++++++--------- build/source/engine/vegPhenlgy.f90 | 14 +- build/source/engine/vegSWavRad.f90 | 344 ++--- build/source/engine/volicePack.f90 | 50 +- build/source/netcdf/modelwrite.f90 | 4 +- build/source/netcdf/read_icond.f90 | 6 +- build/source/noah-mp/module_model_constants.F | 211 +-- build/source/noah-mp/module_sf_noahlsm.F | 17 +- build/source/noah-mp/module_sf_noahmplsm.F | 850 +++++------ build/source/noah-mp/module_sf_noahutl.F | 35 +- 74 files changed, 3475 insertions(+), 3467 deletions(-) diff --git a/build/source/driver/summa_globalData.f90 b/build/source/driver/summa_globalData.f90 index d2acf3992..92a270e09 100755 --- a/build/source/driver/summa_globalData.f90 +++ b/build/source/driver/summa_globalData.f90 @@ -107,7 +107,7 @@ subroutine summa_defineGlobalData(err, message) doJacobian=.false. ! initialize the Jacobian flag ! define double precision NaNs (shared in globalData) - dNaN = ieee_value(1._dp, ieee_quiet_nan) + dNaN = ieee_value(1._summa_prec, ieee_quiet_nan) ! populate metadata for all model variables call popMetadat(err,cmessage) diff --git a/build/source/driver/summa_init.f90 b/build/source/driver/summa_init.f90 index 1f65af736..b4e55a8f6 100755 --- a/build/source/driver/summa_init.f90 +++ b/build/source/driver/summa_init.f90 @@ -175,9 +175,9 @@ subroutine summa_initialize(summa1_struc, err, message) ncid(:) = integerMissing ! initialize the elapsed time for cumulative quantities - elapsedRead=0._dp - elapsedWrite=0._dp - elapsedPhysics=0._dp + elapsedRead=0._summa_prec + elapsedWrite=0._summa_prec + elapsedPhysics=0._summa_prec ! get the command line arguments call getCommandArguments(summa1_struc,err,cmessage) diff --git a/build/source/driver/summa_modelRun.f90 b/build/source/driver/summa_modelRun.f90 index 5080921c4..228912c86 100755 --- a/build/source/driver/summa_modelRun.f90 +++ b/build/source/driver/summa_modelRun.f90 @@ -72,16 +72,16 @@ subroutine summa_runPhysics(modelTimeStep, summa1_struc, err, message) integer(i4b) :: iGRU,jGRU,kGRU ! GRU indices ! local variables: veg phenology logical(lgt) :: computeVegFluxFlag ! flag to indicate if we are computing fluxes over vegetation (.false. means veg is buried with snow) - real(dp) :: notUsed_canopyDepth ! NOT USED: canopy depth (m) - real(dp) :: notUsed_exposedVAI ! NOT USED: exposed vegetation area index (m2 m-2) + real(summa_prec) :: notUsed_canopyDepth ! NOT USED: canopy depth (m) + real(summa_prec) :: notUsed_exposedVAI ! NOT USED: exposed vegetation area index (m2 m-2) ! local variables: parallelize the model run integer(i4b), allocatable :: ixExpense(:) ! ranked index GRU w.r.t. computational expense integer(i4b), allocatable :: totalFluxCalls(:) ! total number of flux calls for each GRU ! local variables: timing information integer*8 :: openMPstart,openMPend ! time for the start of the parallelization section integer*8, allocatable :: timeGRUstart(:) ! time GRUs start - real(dp), allocatable :: timeGRUcompleted(:) ! time required to complete each GRU - real(dp), allocatable :: timeGRU(:) ! time spent on each GRU + real(summa_prec), allocatable :: timeGRUcompleted(:) ! time required to complete each GRU + real(summa_prec), allocatable :: timeGRU(:) ! time spent on each GRU ! --------------------------------------------------------------------------------------- ! associate to elements in the data structure summaVars: associate(& @@ -171,7 +171,7 @@ subroutine summa_runPhysics(modelTimeStep, summa1_struc, err, message) ! compute the total number of flux calls from the previous time step do jGRU=1,nGRU - totalFluxCalls(jGRU) = 0._dp + totalFluxCalls(jGRU) = 0._summa_prec do iHRU=1,gru_struc(jGRU)%hruCount totalFluxCalls(jGRU) = totalFluxCalls(jGRU) + indxStruct%gru(jGRU)%hru(iHRU)%var(iLookINDEX%numberFluxCalc)%dat(1) end do @@ -268,8 +268,8 @@ subroutine summa_runPhysics(modelTimeStep, summa1_struc, err, message) !$omp critical(saveTiming) ! save timing information call system_clock(openMPend) - timeGRU(iGRU) = real(openMPend - timeGRUstart(iGRU), kind(dp)) - timeGRUcompleted(iGRU) = real(openMPend - openMPstart , kind(dp)) + timeGRU(iGRU) = real(openMPend - timeGRUstart(iGRU), kind(summa_prec)) + timeGRUcompleted(iGRU) = real(openMPend - openMPstart , kind(summa_prec)) !$omp end critical(saveTiming) end do ! (looping through GRUs) diff --git a/build/source/driver/summa_restart.f90 b/build/source/driver/summa_restart.f90 index 61b80816e..aff80fe7a 100755 --- a/build/source/driver/summa_restart.f90 +++ b/build/source/driver/summa_restart.f90 @@ -178,7 +178,7 @@ subroutine summa_readRestart(summa1_struc, err, message) ! initialize canopy drip ! NOTE: canopy drip from the previous time step is used to compute throughfall for the current time step - fluxStruct%gru(iGRU)%hru(iHRU)%var(iLookFLUX%scalarCanopyLiqDrainage)%dat(1) = 0._dp ! not used + fluxStruct%gru(iGRU)%hru(iHRU)%var(iLookFLUX%scalarCanopyLiqDrainage)%dat(1) = 0._summa_prec ! not used end do ! end looping through HRUs @@ -201,14 +201,14 @@ subroutine summa_readRestart(summa1_struc, err, message) ! the basin-average aquifer storage is not used if the groundwater is included in the local column case(localColumn) - bvarStruct%gru(iGRU)%var(iLookBVAR%basin__AquiferStorage)%dat(1) = 0._dp ! set to zero to be clear that there is no basin-average aquifer storage in this configuration + bvarStruct%gru(iGRU)%var(iLookBVAR%basin__AquiferStorage)%dat(1) = 0._summa_prec ! set to zero to be clear that there is no basin-average aquifer storage in this configuration ! the local column aquifer storage is not used if the groundwater is basin-average ! (i.e., where multiple HRUs drain to a basin-average aquifer) case(singleBasin) - bvarStruct%gru(iGRU)%var(iLookBVAR%basin__AquiferStorage)%dat(1) = 1._dp + bvarStruct%gru(iGRU)%var(iLookBVAR%basin__AquiferStorage)%dat(1) = 1._summa_prec do iHRU=1,gru_struc(iGRU)%hruCount - progStruct%gru(iGRU)%hru(iHRU)%var(iLookPROG%scalarAquiferStorage)%dat(1) = 0._dp ! set to zero to be clear that there is no local aquifer storage in this configuration + progStruct%gru(iGRU)%hru(iHRU)%var(iLookPROG%scalarAquiferStorage)%dat(1) = 0._summa_prec ! set to zero to be clear that there is no local aquifer storage in this configuration end do ! error check diff --git a/build/source/driver/summa_setup.f90 b/build/source/driver/summa_setup.f90 index 14aa86b27..17dc45e45 100755 --- a/build/source/driver/summa_setup.f90 +++ b/build/source/driver/summa_setup.f90 @@ -191,7 +191,7 @@ subroutine summa_paramSetup(summa1_struc, err, message) ! ***************************************************************************** ! define monthly fraction of green vegetation - greenVegFrac_monthly = (/0.01_dp, 0.02_dp, 0.03_dp, 0.07_dp, 0.50_dp, 0.90_dp, 0.95_dp, 0.96_dp, 0.65_dp, 0.24_dp, 0.11_dp, 0.02_dp/) + greenVegFrac_monthly = (/0.01_summa_prec, 0.02_summa_prec, 0.03_summa_prec, 0.07_summa_prec, 0.50_summa_prec, 0.90_summa_prec, 0.95_summa_prec, 0.96_summa_prec, 0.65_summa_prec, 0.24_summa_prec, 0.11_summa_prec, 0.02_summa_prec/) ! read Noah soil and vegetation tables call soil_veg_gen_parm(trim(SETTINGS_PATH)//trim(VEGPARM), & ! filename for vegetation table @@ -298,7 +298,7 @@ subroutine summa_paramSetup(summa1_struc, err, message) ! compute total area of the upstream HRUS that flow into each HRU do iHRU=1,gru_struc(iGRU)%hruCount - upArea%gru(iGRU)%hru(iHRU) = 0._dp + upArea%gru(iGRU)%hru(iHRU) = 0._summa_prec do jHRU=1,gru_struc(iGRU)%hruCount ! check if jHRU flows into iHRU; assume no exchange between GRUs if(typeStruct%gru(iGRU)%hru(jHRU)%var(iLookTYPE%downHRUindex)==typeStruct%gru(iGRU)%hru(iHRU)%var(iLookID%hruId))then @@ -309,7 +309,7 @@ subroutine summa_paramSetup(summa1_struc, err, message) ! identify the total basin area for a GRU (m2) associate(totalArea => bvarStruct%gru(iGRU)%var(iLookBVAR%basin__totalArea)%dat(1) ) - totalArea = 0._dp + totalArea = 0._summa_prec do iHRU=1,gru_struc(iGRU)%hruCount totalArea = totalArea + attrStruct%gru(iGRU)%hru(iHRU)%var(iLookATTR%HRUarea) end do diff --git a/build/source/driver/summa_type.f90 b/build/source/driver/summa_type.f90 index e44418816..ba72116a6 100755 --- a/build/source/driver/summa_type.f90 +++ b/build/source/driver/summa_type.f90 @@ -91,11 +91,11 @@ MODULE summa_type ! define miscellaneous variables integer(i4b) :: summa1open ! flag to define if the summa file is open?? integer(i4b) :: numout ! number of output variables?? - real(dp) :: ts ! model time step ?? + real(summa_prec) :: ts ! model time step ?? integer(i4b) :: nGRU ! number of grouped response units integer(i4b) :: nHRU ! number of global hydrologic response units integer(i4b) :: hruCount ! number of local hydrologic response units - real(dp),dimension(12) :: greenVegFrac_monthly ! fraction of green vegetation in each month (0-1) + real(summa_prec),dimension(12) :: greenVegFrac_monthly ! fraction of green vegetation in each month (0-1) character(len=256) :: summaFileManagerFile ! path/name of file defining directories and files end type summa1_type_dec diff --git a/build/source/driver/summa_util.f90 b/build/source/driver/summa_util.f90 index 5f1256647..7d281f52a 100755 --- a/build/source/driver/summa_util.f90 +++ b/build/source/driver/summa_util.f90 @@ -350,7 +350,7 @@ subroutine stop_program(err,message) integer(i4b) :: endModelRun(8) ! final time integer(i4b) :: localErr ! local error code integer(i4b) :: iFreq ! loop through output frequencies - real(dp) :: elpSec ! elapsed seconds + real(summa_prec) :: elpSec ! elapsed seconds ! close any remaining output files ! NOTE: use the direct NetCDF call with no error checking since the file may already be closed @@ -392,9 +392,9 @@ subroutine stop_program(err,message) ! print total elapsed time write(outunit,"(/,A,1PG15.7,A)") ' elapsed time = ', elpSec, ' s' - write(outunit,"(A,1PG15.7,A)") ' or ', elpSec/60_dp, ' m' - write(outunit,"(A,1PG15.7,A)") ' or ', elpSec/3600_dp, ' h' - write(outunit,"(A,1PG15.7,A/)") ' or ', elpSec/86400_dp, ' d' + write(outunit,"(A,1PG15.7,A)") ' or ', elpSec/60_summa_prec, ' m' + write(outunit,"(A,1PG15.7,A)") ' or ', elpSec/3600_summa_prec, ' h' + write(outunit,"(A,1PG15.7,A/)") ' or ', elpSec/86400_summa_prec, ' d' ! print the number of threads write(outunit,"(A,i10,/)") ' number threads = ', nThreads diff --git a/build/source/dshare/data_types.f90 b/build/source/dshare/data_types.f90 index cf20b1e89..0f592fbb3 100755 --- a/build/source/dshare/data_types.f90 +++ b/build/source/dshare/data_types.f90 @@ -48,8 +48,8 @@ MODULE data_types integer(i4b),allocatable :: var_ix(:) ! index of each forcing data variable in the data structure integer(i4b),allocatable :: data_id(:) ! netcdf variable id for each forcing data variable character(len=256),allocatable :: varName(:) ! netcdf variable name for each forcing data variable - real(dp) :: firstJulDay ! first julian day in forcing file - real(dp) :: convTime2Days ! factor to convert time to days + real(summa_prec) :: firstJulDay ! first julian day in forcing file + real(summa_prec) :: convTime2Days ! factor to convert time to days end type file_info ! *********************************************************************************************************** @@ -57,9 +57,9 @@ MODULE data_types ! *********************************************************************************************************** ! define a data type to store model parameter information type,public :: par_info - real(dp) :: default_val ! default parameter value - real(dp) :: lower_limit ! lower bound - real(dp) :: upper_limit ! upper bound + real(summa_prec) :: default_val ! default parameter value + real(summa_prec) :: lower_limit ! lower bound + real(summa_prec) :: upper_limit ! upper bound endtype par_info ! *********************************************************************************************************** @@ -131,7 +131,7 @@ MODULE data_types ! NOTE: use derived types here to facilitate adding the "variable" dimension ! ** double precision type type, public :: dlength - real(dp),allocatable :: dat(:) ! dat(:) + real(summa_prec),allocatable :: dat(:) ! dat(:) endtype dlength ! ** integer type (4 byte) type, public :: ilength @@ -168,7 +168,7 @@ MODULE data_types ! ** double precision type of fixed length type, public :: var_d - real(dp),allocatable :: var(:) ! var(:) + real(summa_prec),allocatable :: var(:) ! var(:) endtype var_d ! ** integer type of fixed length (4 byte) type, public :: var_i @@ -181,7 +181,7 @@ MODULE data_types ! ** double precision type of fixed length type, public :: hru_d - real(dp),allocatable :: hru(:) ! hru(:) + real(summa_prec),allocatable :: hru(:) ! hru(:) endtype hru_d ! ** integer type of fixed length (4 byte) type, public :: hru_i diff --git a/build/source/dshare/globalData.f90 b/build/source/dshare/globalData.f90 index 68300c427..8a14b8e21 100755 --- a/build/source/dshare/globalData.f90 +++ b/build/source/dshare/globalData.f90 @@ -61,8 +61,8 @@ MODULE globalData ! ---------------------------------------------------------------------------------------------------------------- ! define missing values - real(qp),parameter,public :: quadMissing = nr_quadMissing ! (from nrtype) missing quadruple precision number - real(dp),parameter,public :: realMissing = nr_realMissing ! (from nrtype) missing double precision number + real(summa_prec),parameter,public :: quadMissing = nr_quadMissing ! (from nrtype) missing quadruple precision number + real(summa_prec),parameter,public :: realMissing = nr_realMissing ! (from nrtype) missing double precision number integer(i4b),parameter,public :: integerMissing = nr_integerMissing ! (from nrtype) missing integer ! define run modes @@ -166,11 +166,11 @@ MODULE globalData integer(i4b),parameter,public :: iJac2=20 ! last layer of the Jacobian to print ! define limit checks - real(dp),parameter,public :: verySmall=tiny(1.0_dp) ! a very small number - real(dp),parameter,public :: veryBig=1.e+20_dp ! a very big number + real(summa_prec),parameter,public :: verySmall=tiny(1.0_summa_prec) ! a very small number + real(summa_prec),parameter,public :: veryBig=1.e+20_summa_prec ! a very big number ! define algorithmic control parameters - real(dp),parameter,public :: dx = 1.e-8_dp ! finite difference increment + real(summa_prec),parameter,public :: dx = 1.e-8_summa_prec ! finite difference increment ! define summary information on all data structures integer(i4b),parameter :: nStruct=13 ! number of data structures @@ -198,7 +198,7 @@ MODULE globalData ! ---------------------------------------------------------------------------------------------------------------- ! define Indian bread (NaN) - real(dp),save,public :: dNaN + real(summa_prec),save,public :: dNaN ! define default parameter values and parameter bounds type(par_info),save,public :: localParFallback(maxvarMpar) ! local column default parameters @@ -264,7 +264,7 @@ MODULE globalData type(hru2gru_map),allocatable,save,public :: index_map(:) ! hru2gru map ! define variables used for the vegetation phenology - real(dp),dimension(12), save , public :: greenVegFrac_monthly ! fraction of green vegetation in each month (0-1) + real(summa_prec),dimension(12), save , public :: greenVegFrac_monthly ! fraction of green vegetation in each month (0-1) ! define the model output file character(len=256),save,public :: fileout='' ! output filename @@ -291,13 +291,13 @@ MODULE globalData integer(i4b),save,public :: numtim ! number of time steps integer(i4b),save,public :: nHRUrun ! number of HRUs in the run domain integer(i4b),save,public :: nGRUrun ! number of GRUs in the run domain - real(dp),save,public :: data_step ! time step of the data - real(dp),save,public :: refJulday ! reference time in fractional julian days - real(dp),save,public :: refJulday_data ! reference time in fractional julian days (data files) - real(dp),save,public :: fracJulday ! fractional julian days since the start of year - real(dp),save,public :: dJulianStart ! julian day of start time of simulation - real(dp),save,public :: dJulianFinsh ! julian day of end time of simulation - real(dp),save,public :: tmZoneOffsetFracDay ! time zone offset in fractional days + real(summa_prec),save,public :: data_step ! time step of the data + real(summa_prec),save,public :: refJulday ! reference time in fractional julian days + real(summa_prec),save,public :: refJulday_data ! reference time in fractional julian days (data files) + real(summa_prec),save,public :: fracJulday ! fractional julian days since the start of year + real(summa_prec),save,public :: dJulianStart ! julian day of start time of simulation + real(summa_prec),save,public :: dJulianFinsh ! julian day of end time of simulation + real(summa_prec),save,public :: tmZoneOffsetFracDay ! time zone offset in fractional days integer(i4b),save,public :: nHRUfile ! number of HRUs in the file integer(i4b),save,public :: yearLength ! number of days in the current year integer(i4b),save,public :: urbanVegCategory ! vegetation category for urban areas @@ -315,12 +315,12 @@ MODULE globalData integer(i4b),dimension(8),save,public :: startPhysics,endPhysics ! date/time for the start and end of the physics ! define elapsed time - real(dp),save,public :: elapsedInit ! elapsed time for the initialization - real(dp),save,public :: elapsedSetup ! elapsed time for the parameter setup - real(dp),save,public :: elapsedRestart ! elapsed time to read restart data - real(dp),save,public :: elapsedRead ! elapsed time for the data read - real(dp),save,public :: elapsedWrite ! elapsed time for the stats/write - real(dp),save,public :: elapsedPhysics ! elapsed time for the physics + real(summa_prec),save,public :: elapsedInit ! elapsed time for the initialization + real(summa_prec),save,public :: elapsedSetup ! elapsed time for the parameter setup + real(summa_prec),save,public :: elapsedRestart ! elapsed time to read restart data + real(summa_prec),save,public :: elapsedRead ! elapsed time for the data read + real(summa_prec),save,public :: elapsedWrite ! elapsed time for the stats/write + real(summa_prec),save,public :: elapsedPhysics ! elapsed time for the physics ! define ancillary data structures type(var_i),save,public :: startTime ! start time for the model simulation diff --git a/build/source/dshare/multiconst.f90 b/build/source/dshare/multiconst.f90 index 764816fc6..26f9400e0 100755 --- a/build/source/dshare/multiconst.f90 +++ b/build/source/dshare/multiconst.f90 @@ -21,33 +21,33 @@ MODULE multiconst USE nrtype ! define physical constants - REAL(DP), PARAMETER :: ave_slp = 101325.0_dp ! mean sea level pressure (Pa) - REAL(DP), PARAMETER :: vkc = 0.4_dp ! von Karman constant (-) - REAL(DP), PARAMETER :: satvpfrz = 610.8_dp ! sat vapour pressure at 273.16K (Pa) - REAL(DP), PARAMETER :: w_ratio = 0.622_dp ! molecular ratio water to dry air (-) - REAL(DP), PARAMETER :: R_da = 287.053_dp ! gas constant for dry air (Pa K-1 m3 kg-1; J kg-1 K-1) - REAL(DP), PARAMETER :: R_wv = 461.285_dp ! gas constant for water vapor (Pa K-1 m3 kg-1; J kg-1 K-1) - REAL(DP), PARAMETER :: Rgas = 8.314_dp ! universal gas constant (J mol-1 K-1) - REAL(DP), PARAMETER :: gravity = 9.80616_dp ! acceleration of gravity (m s-2) - REAL(DP), PARAMETER :: Cp_air = 1005._dp ! specific heat of air (J kg-1 K-1) - REAL(DP), PARAMETER :: Cp_ice = 2114._dp ! specific heat of ice (J kg-1 K-1) - REAL(DP), PARAMETER :: Cp_soil = 850._dp ! specific heat of soil (J kg-1 K-1) - REAL(DP), PARAMETER :: Cp_water = 4181._dp ! specific heat of liquid water (J kg-1 K-1) - REAL(DP), PARAMETER :: Tfreeze = 273.16_dp ! temperature at freezing (K) - REAL(DP), PARAMETER :: TriplPt = 273.16_dp ! triple point of water (K) - REAL(DP), PARAMETER :: LH_fus = 333700.0_dp ! latent heat of fusion (J kg-1) - REAL(DP), PARAMETER :: LH_vap = 2501000.0_dp ! latent heat of vaporization (J kg-1) - REAL(DP), PARAMETER :: LH_sub = 2834700.0_dp ! latent heat of sublimation (J kg-1) - REAL(DP), PARAMETER :: sb = 5.6705d-8 ! Stefan Boltzman constant (W m-2 K-4) - REAL(DP), PARAMETER :: em_sno = 0.99_dp ! emissivity of snow (-) - REAL(DP), PARAMETER :: lambda_air = 0.026_dp ! thermal conductivity of air (W m-1 K-1) - REAL(DP), PARAMETER :: lambda_ice = 2.50_dp ! thermal conductivity of ice (W m-1 K-1) - REAL(DP), PARAMETER :: lambda_water = 0.60_dp ! thermal conductivity of liquid water (W m-1 K-1) - REAL(DP), PARAMETER :: iden_air = 1.293_dp ! intrinsic density of air (kg m-3) - REAL(DP), PARAMETER :: iden_ice = 917.0_dp ! intrinsic density of ice (kg m-3) - REAL(DP), PARAMETER :: iden_water = 1000.0_dp ! intrinsic density of liquid water (kg m-3) - REAL(DP), PARAMETER :: secprday = 86400._dp ! number of seconds in a day - REAL(DP), PARAMETER :: secprhour = 3600._dp ! number of seconds in an hour - REAL(DP), PARAMETER :: secprmin = 60._dp ! number of seconds in a minute - REAL(DP), PARAMETER :: minprhour = 60._dp ! number of minutes in an hour + real(summa_prec), PARAMETER :: ave_slp = 101325.0_summa_prec ! mean sea level pressure (Pa) + real(summa_prec), PARAMETER :: vkc = 0.4_summa_prec ! von Karman constant (-) + real(summa_prec), PARAMETER :: satvpfrz = 610.8_summa_prec ! sat vapour pressure at 273.16K (Pa) + real(summa_prec), PARAMETER :: w_ratio = 0.622_summa_prec ! molecular ratio water to dry air (-) + real(summa_prec), PARAMETER :: R_da = 287.053_summa_prec ! gas constant for dry air (Pa K-1 m3 kg-1; J kg-1 K-1) + real(summa_prec), PARAMETER :: R_wv = 461.285_summa_prec ! gas constant for water vapor (Pa K-1 m3 kg-1; J kg-1 K-1) + real(summa_prec), PARAMETER :: Rgas = 8.314_summa_prec ! universal gas constant (J mol-1 K-1) + real(summa_prec), PARAMETER :: gravity = 9.80616_summa_prec ! acceleration of gravity (m s-2) + real(summa_prec), PARAMETER :: Cp_air = 1005._summa_prec ! specific heat of air (J kg-1 K-1) + real(summa_prec), PARAMETER :: Cp_ice = 2114._summa_prec ! specific heat of ice (J kg-1 K-1) + real(summa_prec), PARAMETER :: Cp_soil = 850._summa_prec ! specific heat of soil (J kg-1 K-1) + real(summa_prec), PARAMETER :: Cp_water = 4181._summa_prec ! specific heat of liquid water (J kg-1 K-1) + real(summa_prec), PARAMETER :: Tfreeze = 273.16_summa_prec ! temperature at freezing (K) + real(summa_prec), PARAMETER :: TriplPt = 273.16_summa_prec ! triple point of water (K) + real(summa_prec), PARAMETER :: LH_fus = 333700.0_summa_prec ! latent heat of fusion (J kg-1) + real(summa_prec), PARAMETER :: LH_vap = 2501000.0_summa_prec ! latent heat of vaporization (J kg-1) + real(summa_prec), PARAMETER :: LH_sub = 2834700.0_summa_prec ! latent heat of sublimation (J kg-1) + real(summa_prec), PARAMETER :: sb = 5.6705d-8 ! Stefan Boltzman constant (W m-2 K-4) + real(summa_prec), PARAMETER :: em_sno = 0.99_summa_prec ! emissivity of snow (-) + real(summa_prec), PARAMETER :: lambda_air = 0.026_summa_prec ! thermal conductivity of air (W m-1 K-1) + real(summa_prec), PARAMETER :: lambda_ice = 2.50_summa_prec ! thermal conductivity of ice (W m-1 K-1) + real(summa_prec), PARAMETER :: lambda_water = 0.60_summa_prec ! thermal conductivity of liquid water (W m-1 K-1) + real(summa_prec), PARAMETER :: iden_air = 1.293_summa_prec ! intrinsic density of air (kg m-3) + real(summa_prec), PARAMETER :: iden_ice = 917.0_summa_prec ! intrinsic density of ice (kg m-3) + real(summa_prec), PARAMETER :: iden_water = 1000.0_summa_prec ! intrinsic density of liquid water (kg m-3) + real(summa_prec), PARAMETER :: secprday = 86400._summa_prec ! number of seconds in a day + real(summa_prec), PARAMETER :: secprhour = 3600._summa_prec ! number of seconds in an hour + real(summa_prec), PARAMETER :: secprmin = 60._summa_prec ! number of seconds in a minute + real(summa_prec), PARAMETER :: minprhour = 60._summa_prec ! number of minutes in an hour END MODULE multiconst diff --git a/build/source/dshare/outpt_stat.f90 b/build/source/dshare/outpt_stat.f90 index dbb7c3953..50b4b376d 100755 --- a/build/source/dshare/outpt_stat.f90 +++ b/build/source/dshare/outpt_stat.f90 @@ -54,7 +54,7 @@ subroutine calcStats(stat,dat,meta,resetStats,finalizeStats,statCounter,err,mess character(256) :: cmessage ! error message integer(i4b) :: iVar ! index for varaiable loop integer(i4b) :: pVar ! index into parent structure - real(dp) :: tdata ! dummy for pulling info from dat structure + real(summa_prec) :: tdata ! dummy for pulling info from dat structure ! initialize error control err=0; message='calcStats/' @@ -73,9 +73,9 @@ subroutine calcStats(stat,dat,meta,resetStats,finalizeStats,statCounter,err,mess ! extract data from the structures select type (dat) - type is (real(dp)); tdata = dat(pVar) + type is (real(summa_prec)); tdata = dat(pVar) class is (dlength) ; tdata = dat(pVar)%dat(1) - class is (ilength) ; tdata = real(dat(pVar)%dat(1), kind(dp)) + class is (ilength) ; tdata = real(dat(pVar)%dat(1), kind(summa_prec)) class default;err=20;message=trim(message)//'dat type not found';return end select @@ -114,7 +114,7 @@ subroutine calc_stats(meta,stat,tdata,resetStats,finalizeStats,statCounter,err,m ! input variables class(var_info),intent(in) :: meta ! meta data structure class(*) ,intent(inout) :: stat ! statistics structure - real(dp) ,intent(in) :: tdata ! data value + real(summa_prec) ,intent(in) :: tdata ! data value logical(lgt) ,intent(in) :: resetStats(:) ! vector of flags to reset statistics logical(lgt) ,intent(in) :: finalizeStats(:) ! vector of flags to reset statistics integer(i4b) ,intent(in) :: statCounter(:) ! number of time steps in each output frequency @@ -122,7 +122,7 @@ subroutine calc_stats(meta,stat,tdata,resetStats,finalizeStats,statCounter,err,m integer(i4b) ,intent(out) :: err ! error code character(*) ,intent(out) :: message ! error message ! internals - real(dp),dimension(maxvarFreq*2) :: tstat ! temporary stats vector + real(summa_prec),dimension(maxvarFreq*2) :: tstat ! temporary stats vector integer(i4b) :: iFreq ! index of output frequency ! initialize error control err=0; message='calc_stats/' @@ -144,12 +144,12 @@ subroutine calc_stats(meta,stat,tdata,resetStats,finalizeStats,statCounter,err,m select case(meta%statIndex(iFreq)) ! act depending on the statistic ! ------------------------------------------------------------------------------------- case (iLookStat%totl) ! * summation over period - tstat(iFreq) = 0._dp ! - resets stat at beginning of period + tstat(iFreq) = 0._summa_prec ! - resets stat at beginning of period case (iLookStat%mean) ! * mean over period - tstat(iFreq) = 0._dp ! - resets stat at beginning of period + tstat(iFreq) = 0._summa_prec ! - resets stat at beginning of period case (iLookStat%vari) ! * variance over period - tstat(iFreq) = 0._dp ! - resets E[X^2] term in var calc - tstat(maxVarFreq+iFreq) = 0._dp ! - resets E[X]^2 term + tstat(iFreq) = 0._summa_prec ! - resets E[X^2] term in var calc + tstat(maxVarFreq+iFreq) = 0._summa_prec ! - resets E[X]^2 term case (iLookStat%mini) ! * minimum over period tstat(iFreq) = huge(tstat(iFreq)) ! - resets stat at beginning of period case (iLookStat%maxi) ! * maximum over period diff --git a/build/source/engine/allocspace.f90 b/build/source/engine/allocspace.f90 index 27e73300a..cb120eff3 100755 --- a/build/source/engine/allocspace.f90 +++ b/build/source/engine/allocspace.f90 @@ -262,7 +262,7 @@ subroutine allocLocal(metaStruct,dataStruct,nSnow,nSoil,err,message) select type(dataStruct) class is (var_flagVec); call allocateDat_flag(metaStruct,nSnow,nSoil,nLayers,dataStruct,err,cmessage) class is (var_ilength); call allocateDat_int( metaStruct,nSnow,nSoil,nLayers,dataStruct,err,cmessage) - class is (var_dlength); call allocateDat_dp( metaStruct,nSnow,nSoil,nLayers,dataStruct,err,cmessage) + class is (var_dlength); call allocateDat_summa_prec( metaStruct,nSnow,nSoil,nLayers,dataStruct,err,cmessage) class default; err=20; message=trim(message)//'unable to identify derived data type for the data dimension'; return end select @@ -328,7 +328,7 @@ subroutine resizeData(metaStruct,dataStructOrig,dataStructNew,copy,err,message) ! double precision class is (var_dlength) select type(dataStructNew) - class is (var_dlength); call copyStruct_dp( dataStructOrig%var(iVar),dataStructNew%var(iVar),isCopy,err,cmessage) + class is (var_dlength); call copyStruct_summa_prec( dataStructOrig%var(iVar),dataStructNew%var(iVar),isCopy,err,cmessage) class default; err=20; message=trim(message)//'mismatch data structure for variable'//trim(metaStruct(iVar)%varname); return end select @@ -349,9 +349,9 @@ subroutine resizeData(metaStruct,dataStructOrig,dataStructNew,copy,err,message) end subroutine resizeData ! ************************************************************************************************ - ! private subroutine copyStruct_dp: copy a given data structure + ! private subroutine copyStruct_summa_prec: copy a given data structure ! ************************************************************************************************ - subroutine copyStruct_dp(varOrig,varNew,copy,err,message) + subroutine copyStruct_summa_prec(varOrig,varNew,copy,err,message) ! dummy variables type(dlength),intent(in) :: varOrig ! original data structure type(dlength),intent(inout) :: varNew ! new data structure @@ -366,7 +366,7 @@ subroutine copyStruct_dp(varOrig,varNew,copy,err,message) integer(i4b) :: lowerBoundNew ! lower bound of a given variable in the new data structure integer(i4b) :: upperBoundNew ! upper bound of a given variable in the new data structure ! initialize error control - err=0; message='copyStruct_dp/' + err=0; message='copyStruct_summa_prec/' ! get the information from the data structures call getVarInfo(varOrig,allocatedOrig,lowerBoundOrig,upperBoundOrig) @@ -433,7 +433,7 @@ subroutine getVarInfo(var,isAllocated,lowerBound,upperBound) end subroutine getVarInfo - end subroutine copyStruct_dp + end subroutine copyStruct_summa_prec ! ************************************************************************************************ ! private subroutine copyStruct_i4b: copy a given data structure @@ -524,9 +524,9 @@ end subroutine copyStruct_i4b ! ************************************************************************************************ - ! private subroutine allocateDat_dp: initialize data dimension of the data structures + ! private subroutine allocateDat_summa_prec: initialize data dimension of the data structures ! ************************************************************************************************ - subroutine allocateDat_dp(metadata,nSnow,nSoil,nLayers, & ! input + subroutine allocateDat_summa_prec(metadata,nSnow,nSoil,nLayers, & ! input varData,err,message) ! output ! access subroutines USE get_ixName_module,only:get_varTypeName ! to access type strings for error messages @@ -546,7 +546,7 @@ subroutine allocateDat_dp(metadata,nSnow,nSoil,nLayers, & ! input integer(i4b) :: nVars ! number of variables in the metadata structure ! initialize error control - err=0; message='allocateDat_dp/' + err=0; message='allocateDat_summa_prec/' ! get the number of variables in the metadata structure nVars = size(metadata) @@ -589,7 +589,7 @@ subroutine allocateDat_dp(metadata,nSnow,nSoil,nLayers, & ! input end do ! looping through variables - end subroutine allocateDat_dp + end subroutine allocateDat_summa_prec ! ************************************************************************************************ ! private subroutine allocateDat_int: initialize data dimension of the data structures diff --git a/build/source/engine/bigAquifer.f90 b/build/source/engine/bigAquifer.f90 index e9312789d..ba4a65449 100755 --- a/build/source/engine/bigAquifer.f90 +++ b/build/source/engine/bigAquifer.f90 @@ -66,24 +66,24 @@ subroutine bigAquifer(& ! ------------------------------------------------------------------------------------------------------------------------------------------------- implicit none ! input: state variables, fluxes, and parameters - real(dp),intent(in) :: scalarAquiferStorageTrial ! trial value of aquifer storage (m) - real(dp),intent(in) :: scalarCanopyTranspiration ! canopy transpiration (kg m-2 s-1) - real(dp),intent(in) :: scalarSoilDrainage ! soil drainage (m s-1) + real(summa_prec),intent(in) :: scalarAquiferStorageTrial ! trial value of aquifer storage (m) + real(summa_prec),intent(in) :: scalarCanopyTranspiration ! canopy transpiration (kg m-2 s-1) + real(summa_prec),intent(in) :: scalarSoilDrainage ! soil drainage (m s-1) ! input: diagnostic variables and parameters type(var_dlength),intent(in) :: mpar_data ! model parameters type(var_dlength),intent(in) :: diag_data ! diagnostic variables for a local HRU ! output: fluxes - real(dp),intent(out) :: scalarAquiferTranspire ! transpiration loss from the aquifer (m s-1) - real(dp),intent(out) :: scalarAquiferRecharge ! recharge to the aquifer (m s-1) - real(dp),intent(out) :: scalarAquiferBaseflow ! total baseflow from the aquifer (m s-1) - real(dp),intent(out) :: dBaseflow_dAquifer ! change in baseflow flux w.r.t. aquifer storage (s-1) + real(summa_prec),intent(out) :: scalarAquiferTranspire ! transpiration loss from the aquifer (m s-1) + real(summa_prec),intent(out) :: scalarAquiferRecharge ! recharge to the aquifer (m s-1) + real(summa_prec),intent(out) :: scalarAquiferBaseflow ! total baseflow from the aquifer (m s-1) + real(summa_prec),intent(out) :: dBaseflow_dAquifer ! change in baseflow flux w.r.t. aquifer storage (s-1) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! ----------------------------------------------------------------------------------------------------------------------------------------------------- ! local variables - real(dp) :: aquiferTranspireFrac ! fraction of total transpiration that comes from the aquifer (-) - real(dp) :: xTemp ! temporary variable (-) + real(summa_prec) :: aquiferTranspireFrac ! fraction of total transpiration that comes from the aquifer (-) + real(summa_prec) :: xTemp ! temporary variable (-) ! ------------------------------------------------------------------------------------------------------------------------------------------------- ! initialize error control err=0; message='bigAquifer/' @@ -112,7 +112,7 @@ subroutine bigAquifer(& scalarAquiferBaseflow = aquiferBaseflowRate*(xTemp**aquiferBaseflowExp) ! compute the derivative in the net aquifer flux - dBaseflow_dAquifer = -(aquiferBaseflowExp*aquiferBaseflowRate*(xTemp**(aquiferBaseflowExp - 1._dp)))/aquiferScaleFactor + dBaseflow_dAquifer = -(aquiferBaseflowExp*aquiferBaseflowRate*(xTemp**(aquiferBaseflowExp - 1._summa_prec)))/aquiferScaleFactor ! end association to data in structures end associate diff --git a/build/source/engine/canopySnow.f90 b/build/source/engine/canopySnow.f90 index cde7e0b15..c96ffe967 100755 --- a/build/source/engine/canopySnow.f90 +++ b/build/source/engine/canopySnow.f90 @@ -73,8 +73,8 @@ subroutine canopySnow(& implicit none ! ------------------------------------------------------------------------------------------------ ! input: model control - real(dp),intent(in) :: dt ! time step (seconds) - real(dp),intent(in) :: exposedVAI ! exposed vegetation area index -- leaf + stem -- after burial by snow (m2 m-2) + real(summa_prec),intent(in) :: dt ! time step (seconds) + real(summa_prec),intent(in) :: exposedVAI ! exposed vegetation area index -- leaf + stem -- after burial by snow (m2 m-2) logical(lgt),intent(in) :: computeVegFlux ! flag to indicate if we are computing fluxes over vegetation (.false. means veg is buried with snow) ! input/output: data structures type(model_options),intent(in) :: model_decisions(:) ! model decisions @@ -87,23 +87,23 @@ subroutine canopySnow(& integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! local variables - real(dp),parameter :: valueMissing=-9999._dp ! missing value + real(summa_prec),parameter :: valueMissing=-9999._summa_prec ! missing value integer(i4b) :: iter ! iteration index integer(i4b),parameter :: maxiter=50 ! maximum number of iterations - real(dp) :: unloading_melt ! unloading associated with canopy drip (kg m-2 s-1) - real(dp) :: airtemp_degC ! value of air temperature in degrees Celcius - real(dp) :: leafScaleFactor ! scaling factor for interception based on temperature (-) - real(dp) :: leafInterceptCapSnow ! storage capacity for snow per unit leaf area (kg m-2) - real(dp) :: canopyIceScaleFactor ! capacity scaling factor for throughfall (kg m-2) - real(dp) :: throughfallDeriv ! derivative in throughfall flux w.r.t. canopy storage (s-1) - real(dp) :: unloadingDeriv ! derivative in unloading flux w.r.t. canopy storage (s-1) - real(dp) :: scalarCanopyIceIter ! trial value for mass of ice on the vegetation canopy (kg m-2) (kg m-2) - real(dp) :: flux ! net flux (kg m-2 s-1) - real(dp) :: delS ! change in storage (kg m-2) - real(dp) :: resMass ! residual in mass equation (kg m-2) - real(dp) :: tempUnloadingFun ! temperature unloading functions, Eq. 14 in Roesch et al. 2001 - real(dp) :: windUnloadingFun ! temperature unloading functions, Eq. 15 in Roesch et al. 2001 - real(dp),parameter :: convTolerMass=0.0001_dp ! convergence tolerance for mass (kg m-2) + real(summa_prec) :: unloading_melt ! unloading associated with canopy drip (kg m-2 s-1) + real(summa_prec) :: airtemp_degC ! value of air temperature in degrees Celcius + real(summa_prec) :: leafScaleFactor ! scaling factor for interception based on temperature (-) + real(summa_prec) :: leafInterceptCapSnow ! storage capacity for snow per unit leaf area (kg m-2) + real(summa_prec) :: canopyIceScaleFactor ! capacity scaling factor for throughfall (kg m-2) + real(summa_prec) :: throughfallDeriv ! derivative in throughfall flux w.r.t. canopy storage (s-1) + real(summa_prec) :: unloadingDeriv ! derivative in unloading flux w.r.t. canopy storage (s-1) + real(summa_prec) :: scalarCanopyIceIter ! trial value for mass of ice on the vegetation canopy (kg m-2) (kg m-2) + real(summa_prec) :: flux ! net flux (kg m-2 s-1) + real(summa_prec) :: delS ! change in storage (kg m-2) + real(summa_prec) :: resMass ! residual in mass equation (kg m-2) + real(summa_prec) :: tempUnloadingFun ! temperature unloading functions, Eq. 14 in Roesch et al. 2001 + real(summa_prec) :: windUnloadingFun ! temperature unloading functions, Eq. 15 in Roesch et al. 2001 + real(summa_prec),parameter :: convTolerMass=0.0001_summa_prec ! convergence tolerance for mass (kg m-2) ! ------------------------------------------------------------------------------------------------------------------------------- ! initialize error control err=0; message='canopySnow/' @@ -151,7 +151,7 @@ subroutine canopySnow(& if(computeVegFlux)then unloading_melt = min(ratioDrip2Unloading*scalarCanopyLiqDrainage, scalarCanopyIce/dt) ! kg m-2 s-1 else - unloading_melt = 0._dp + unloading_melt = 0._summa_prec end if scalarCanopyIce = scalarCanopyIce - unloading_melt*dt @@ -173,11 +173,11 @@ subroutine canopySnow(& scalarCanopySnowUnloading = snowUnloadingCoeff*scalarCanopyIceIter unloadingDeriv = snowUnloadingCoeff else if (ixSnowUnload==windUnload) then - tempUnloadingFun = max(scalarCanairTemp - minTempUnloading, 0._dp) / rateTempUnloading ! (s-1) + tempUnloadingFun = max(scalarCanairTemp - minTempUnloading, 0._summa_prec) / rateTempUnloading ! (s-1) if (scalarWindspdCanopyTop >= minWindUnloading) then windUnloadingFun = abs(scalarWindspdCanopyTop) / rateWindUnloading ! (s-1) else - windUnloadingFun = 0._dp ! (s-1) + windUnloadingFun = 0._summa_prec ! (s-1) end if ! implement the "windySnow" Roesch et al. 2001 parameterization, Eq. 13 in Roesch et al. 2001 scalarCanopySnowUnloading = scalarCanopyIceIter * (tempUnloadingFun + windUnloadingFun) @@ -187,24 +187,24 @@ subroutine canopySnow(& if(scalarSnowfall -1._dp) then - leafScaleFactor = 4.0_dp - elseif(airtemp_degC > -3._dp) then - leafScaleFactor = 1.5_dp*airtemp_degC + 5.5_dp + if (airtemp_degC > -1._summa_prec) then + leafScaleFactor = 4.0_summa_prec + elseif(airtemp_degC > -3._summa_prec) then + leafScaleFactor = 1.5_summa_prec*airtemp_degC + 5.5_summa_prec else - leafScaleFactor = 1.0_dp + leafScaleFactor = 1.0_summa_prec end if leafInterceptCapSnow = refInterceptCapSnow*leafScaleFactor case default @@ -219,7 +219,7 @@ subroutine canopySnow(& end if ! (if snow is falling) ! ** compute iteration increment flux = scalarSnowfall - scalarThroughfallSnow - scalarCanopySnowUnloading ! net flux (kg m-2 s-1) - delS = (flux*dt - (scalarCanopyIceIter - scalarCanopyIce))/(1._dp + (throughfallDeriv + unloadingDeriv)*dt) + delS = (flux*dt - (scalarCanopyIceIter - scalarCanopyIce))/(1._summa_prec + (throughfallDeriv + unloadingDeriv)*dt) ! ** check for convergence resMass = scalarCanopyIceIter - (scalarCanopyIce + flux*dt) if(abs(resMass) < convTolerMass)exit diff --git a/build/source/engine/check_icond.f90 b/build/source/engine/check_icond.f90 index 9a1e9a779..0234551d7 100755 --- a/build/source/engine/check_icond.f90 +++ b/build/source/engine/check_icond.f90 @@ -82,15 +82,15 @@ subroutine check_icond(nGRU, & ! number of GRUs and HRU ! temporary variables for realism checks integer(i4b) :: iLayer ! index of model layer integer(i4b) :: iSoil ! index of soil layer - real(dp) :: fLiq ! fraction of liquid water on the vegetation canopy (-) - real(dp) :: vGn_m ! van Genutchen "m" parameter (-) - real(dp) :: tWat ! total water on the vegetation canopy (kg m-2) - real(dp) :: scalarTheta ! liquid water equivalent of total water [liquid water + ice] (-) - real(dp) :: h1,h2 ! used to check depth and height are consistent + real(summa_prec) :: fLiq ! fraction of liquid water on the vegetation canopy (-) + real(summa_prec) :: vGn_m ! van Genutchen "m" parameter (-) + real(summa_prec) :: tWat ! total water on the vegetation canopy (kg m-2) + real(summa_prec) :: scalarTheta ! liquid water equivalent of total water [liquid water + ice] (-) + real(summa_prec) :: h1,h2 ! used to check depth and height are consistent integer(i4b) :: nLayers ! total number of layers - real(dp) :: kappa ! constant in the freezing curve function (m K-1) + real(summa_prec) :: kappa ! constant in the freezing curve function (m K-1) integer(i4b) :: nSnow ! number of snow layers - real(dp),parameter :: xTol=1.e-10_dp ! small tolerance to address precision issues + real(summa_prec),parameter :: xTol=1.e-10_summa_prec ! small tolerance to address precision issues ! -------------------------------------------------------------------------------------------------------- ! Start procedure here @@ -149,14 +149,14 @@ subroutine check_icond(nGRU, & ! number of GRUs and HRU kappa = (iden_ice/iden_water)*(LH_fus/(gravity*Tfreeze)) ! NOTE: J = kg m2 s-2 ! modify the liquid water and ice in the canopy - if(scalarCanopyIce > 0._dp .and. scalarCanopyTemp > Tfreeze)then + if(scalarCanopyIce > 0._summa_prec .and. scalarCanopyTemp > Tfreeze)then message=trim(message)//'canopy ice > 0 when canopy temperature > Tfreeze' err=20; return end if fLiq = fracliquid(scalarCanopyTemp,snowfrz_scale) ! fraction of liquid water (-) tWat = scalarCanopyLiq + scalarCanopyIce ! total water (kg m-2) scalarCanopyLiq = fLiq*tWat ! mass of liquid water on the canopy (kg m-2) - scalarCanopyIce = (1._dp - fLiq)*tWat ! mass of ice on the canopy (kg m-2) + scalarCanopyIce = (1._summa_prec - fLiq)*tWat ! mass of ice on the canopy (kg m-2) ! number of layers nLayers = gru_struc(iGRU)%hruInfo(iHRU)%nSnow + gru_struc(iGRU)%hruInfo(iHRU)%nSoil @@ -168,7 +168,7 @@ subroutine check_icond(nGRU, & ! number of GRUs and HRU ! compute liquid water equivalent of total water (liquid plus ice) if (iLayer>nSnow) then ! soil layer = no volume expansion iSoil = iLayer - nSnow - vGn_m = 1._dp - 1._dp/vGn_n(iSoil) + vGn_m = 1._summa_prec - 1._summa_prec/vGn_n(iSoil) scalarTheta = mLayerVolFracIce(iLayer) + mLayerVolFracLiq(iLayer) else ! snow layer = volume expansion allowed iSoil = integerMissing @@ -184,14 +184,14 @@ subroutine check_icond(nGRU, & ! number of GRUs and HRU ! ***** snow case(iname_snow) ! (check liquid water) - if(mLayerVolFracLiq(iLayer) < 0._dp)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with volumetric fraction of liquid water < 0: layer = ',iLayer; err=20; return; end if - if(mLayerVolFracLiq(iLayer) > 1._dp)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with volumetric fraction of liquid water > 1: layer = ',iLayer; err=20; return; end if + if(mLayerVolFracLiq(iLayer) < 0._summa_prec)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with volumetric fraction of liquid water < 0: layer = ',iLayer; err=20; return; end if + if(mLayerVolFracLiq(iLayer) > 1._summa_prec)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with volumetric fraction of liquid water > 1: layer = ',iLayer; err=20; return; end if ! (check ice) - if(mLayerVolFracIce(iLayer) > 0.80_dp)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with volumetric fraction of ice > 0.80: layer = ',iLayer; err=20; return; end if - if(mLayerVolFracIce(iLayer) < 0.05_dp)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with volumetric fraction of ice < 0.05: layer = ',iLayer; err=20; return; end if + if(mLayerVolFracIce(iLayer) > 0.80_summa_prec)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with volumetric fraction of ice > 0.80: layer = ',iLayer; err=20; return; end if + if(mLayerVolFracIce(iLayer) < 0.05_summa_prec)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with volumetric fraction of ice < 0.05: layer = ',iLayer; err=20; return; end if ! check total water - if(scalarTheta > 0.80_dp)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with total water fraction [liquid + ice] > 0.80: layer = ',iLayer; err=20; return; end if - if(scalarTheta < 0.05_dp)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with total water fraction [liquid + ice] < 0.05: layer = ',iLayer; err=20; return; end if + if(scalarTheta > 0.80_summa_prec)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with total water fraction [liquid + ice] > 0.80: layer = ',iLayer; err=20; return; end if + if(scalarTheta < 0.05_summa_prec)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with total water fraction [liquid + ice] < 0.05: layer = ',iLayer; err=20; return; end if ! ***** soil case(iname_soil) @@ -200,7 +200,7 @@ subroutine check_icond(nGRU, & ! number of GRUs and HRU if(mLayerVolFracLiq(iLayer) < theta_res(iSoil)-xTol)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with volumetric fraction of liquid water < theta_res: layer = ',iLayer; err=20; return; end if if(mLayerVolFracLiq(iLayer) > theta_sat(iSoil)+xTol)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with volumetric fraction of liquid water > theta_sat: layer = ',iLayer; err=20; return; end if ! (check ice) - if(mLayerVolFracIce(iLayer) < 0._dp )then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with volumetric fraction of ice < 0: layer = ' ,iLayer; err=20; return; end if + if(mLayerVolFracIce(iLayer) < 0._summa_prec )then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with volumetric fraction of ice < 0: layer = ' ,iLayer; err=20; return; end if if(mLayerVolFracIce(iLayer) > theta_sat(iSoil)+xTol)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with volumetric fraction of ice > theta_sat: layer = ',iLayer; err=20; return; end if ! check total water if(scalarTheta < theta_res(iSoil)-xTol)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with total water fraction [liquid + ice] < theta_res: layer = ',iLayer; err=20; return; end if @@ -273,7 +273,7 @@ subroutine check_icond(nGRU, & ! number of GRUs and HRU do iLayer=1,nLayers h1 = sum(progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%mLayerDepth)%dat(1:iLayer)) ! sum of the depths up to the current layer h2 = progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%iLayerHeight)%dat(iLayer) - progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%iLayerHeight)%dat(0) ! difference between snow-atm interface and bottom of layer - if(abs(h1 - h2) > 1.e-6_dp)then + if(abs(h1 - h2) > 1.e-6_summa_prec)then write(message,'(a,1x,i0)') trim(message)//'mis-match between layer depth and layer height; layer = ', iLayer, '; sum depths = ',h1,'; height = ',h2 err=20; return end if diff --git a/build/source/engine/computFlux.f90 b/build/source/engine/computFlux.f90 index 75b8fc486..95445df4f 100755 --- a/build/source/engine/computFlux.f90 +++ b/build/source/engine/computFlux.f90 @@ -164,18 +164,18 @@ subroutine computFlux(& logical(lgt),intent(in) :: firstSplitOper ! flag to indicate if we are processing the first flux call in a splitting operation logical(lgt),intent(in) :: computeVegFlux ! flag to indicate if computing fluxes over vegetation logical(lgt),intent(in) :: scalarSolution ! flag to denote if implementing the scalar solution - real(dp),intent(in) :: drainageMeltPond ! drainage from the surface melt pond (kg m-2 s-1) + real(summa_prec),intent(in) :: drainageMeltPond ! drainage from the surface melt pond (kg m-2 s-1) ! input: state variables - real(dp),intent(in) :: scalarCanairTempTrial ! trial value for temperature of the canopy air space (K) - real(dp),intent(in) :: scalarCanopyTempTrial ! trial value for temperature of the vegetation canopy (K) - real(dp),intent(in) :: mLayerTempTrial(:) ! trial value for temperature of each snow/soil layer (K) - real(dp),intent(in) :: mLayerMatricHeadLiqTrial(:) ! trial value for the liquid water matric potential (m) - real(dp),intent(in) :: scalarAquiferStorageTrial ! trial value of aquifer storage (m) + real(summa_prec),intent(in) :: scalarCanairTempTrial ! trial value for temperature of the canopy air space (K) + real(summa_prec),intent(in) :: scalarCanopyTempTrial ! trial value for temperature of the vegetation canopy (K) + real(summa_prec),intent(in) :: mLayerTempTrial(:) ! trial value for temperature of each snow/soil layer (K) + real(summa_prec),intent(in) :: mLayerMatricHeadLiqTrial(:) ! trial value for the liquid water matric potential (m) + real(summa_prec),intent(in) :: scalarAquiferStorageTrial ! trial value of aquifer storage (m) ! input: diagnostic variables - real(dp),intent(in) :: scalarCanopyLiqTrial ! trial value for mass of liquid water on the vegetation canopy (kg m-2) - real(dp),intent(in) :: scalarCanopyIceTrial ! trial value for mass of ice on the vegetation canopy (kg m-2) - real(dp),intent(in) :: mLayerVolFracLiqTrial(:) ! trial value for volumetric fraction of liquid water (-) - real(dp),intent(in) :: mLayerVolFracIceTrial(:) ! trial value for volumetric fraction of ice (-) + real(summa_prec),intent(in) :: scalarCanopyLiqTrial ! trial value for mass of liquid water on the vegetation canopy (kg m-2) + real(summa_prec),intent(in) :: scalarCanopyIceTrial ! trial value for mass of ice on the vegetation canopy (kg m-2) + real(summa_prec),intent(in) :: mLayerVolFracLiqTrial(:) ! trial value for volumetric fraction of liquid water (-) + real(summa_prec),intent(in) :: mLayerVolFracIceTrial(:) ! trial value for volumetric fraction of ice (-) ! input: data structures type(model_options),intent(in) :: model_decisions(:) ! model decisions type(var_i), intent(in) :: type_data ! type of vegetation and soil @@ -191,8 +191,8 @@ subroutine computFlux(& type(var_dlength),intent(inout) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables ! input-output: flux vector and baseflow derivatives integer(i4b),intent(inout) :: ixSaturation ! index of the lowest saturated layer (NOTE: only computed on the first iteration) - real(dp),intent(out) :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) - real(dp),intent(out) :: fluxVec(:) ! model flux vector (mixed units) + real(summa_prec),intent(out) :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) + real(summa_prec),intent(out) :: fluxVec(:) ! model flux vector (mixed units) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message @@ -202,7 +202,7 @@ subroutine computFlux(& integer(i4b) :: local_ixGroundwater ! local index for groundwater representation integer(i4b) :: iLayer ! index of model layers logical(lgt) :: doVegNrgFlux ! flag to compute the energy flux over vegetation - real(dp),dimension(nSoil) :: dHydCond_dMatric ! derivative in hydraulic conductivity w.r.t matric head (s-1) + real(summa_prec),dimension(nSoil) :: dHydCond_dMatric ! derivative in hydraulic conductivity w.r.t matric head (s-1) character(LEN=256) :: cmessage ! error message of downwind routine ! -------------------------------------------------------------- ! initialize error control @@ -385,8 +385,8 @@ subroutine computFlux(& ! initialize liquid water fluxes throughout the snow and soil domains ! NOTE: used in the energy routines, which is called before the hydrology routines if(firstFluxCall)then - if(nSnow > 0) iLayerLiqFluxSnow(0:nSnow) = 0._dp - iLayerLiqFluxSoil(0:nSoil) = 0._dp + if(nSnow > 0) iLayerLiqFluxSnow(0:nSnow) = 0._summa_prec + iLayerLiqFluxSoil(0:nSoil) = 0._summa_prec end if ! ***** @@ -686,13 +686,13 @@ subroutine computFlux(& if(nSnow==0) then ! * case of infiltration into soil if(scalarMaxInfilRate > scalarRainPlusMelt)then ! infiltration is not rate-limited - scalarSoilControl = (1._dp - scalarFrozenArea)*scalarInfilArea + scalarSoilControl = (1._summa_prec - scalarFrozenArea)*scalarInfilArea else - scalarSoilControl = 0._dp ! (scalarRainPlusMelt exceeds maximum infiltration rate + scalarSoilControl = 0._summa_prec ! (scalarRainPlusMelt exceeds maximum infiltration rate endif else ! * case of infiltration into snow - scalarSoilControl = 1._dp + scalarSoilControl = 1._summa_prec endif ! compute drainage from the soil zone (needed for mass balance checks) @@ -716,10 +716,10 @@ subroutine computFlux(& ! set baseflow fluxes to zero if the baseflow routine is not used if(local_ixGroundwater/=qbaseTopmodel)then ! (diagnostic variables in the data structures) - scalarExfiltration = 0._dp ! exfiltration from the soil profile (m s-1) - mLayerColumnOutflow(:) = 0._dp ! column outflow from each soil layer (m3 s-1) + scalarExfiltration = 0._summa_prec ! exfiltration from the soil profile (m s-1) + mLayerColumnOutflow(:) = 0._summa_prec ! column outflow from each soil layer (m3 s-1) ! (variables needed for the numerical solution) - mLayerBaseflow(:) = 0._dp ! baseflow from each soil layer (m s-1) + mLayerBaseflow(:) = 0._summa_prec ! baseflow from each soil layer (m s-1) ! topmodel-ish shallow groundwater else ! local_ixGroundwater==qbaseTopmodel @@ -798,10 +798,10 @@ subroutine computFlux(& ! if no aquifer, then fluxes are zero else - scalarAquiferTranspire = 0._dp ! transpiration loss from the aquifer (m s-1) - scalarAquiferRecharge = 0._dp ! recharge to the aquifer (m s-1) - scalarAquiferBaseflow = 0._dp ! total baseflow from the aquifer (m s-1) - dBaseflow_dAquifer = 0._dp ! change in baseflow flux w.r.t. aquifer storage (s-1) + scalarAquiferTranspire = 0._summa_prec ! transpiration loss from the aquifer (m s-1) + scalarAquiferRecharge = 0._summa_prec ! recharge to the aquifer (m s-1) + scalarAquiferBaseflow = 0._summa_prec ! total baseflow from the aquifer (m s-1) + dBaseflow_dAquifer = 0._summa_prec ! change in baseflow flux w.r.t. aquifer storage (s-1) end if ! no aquifer endif ! if computing aquifer fluxes @@ -869,15 +869,15 @@ subroutine soilCmpres(& ! input: integer(i4b),intent(in) :: ixRichards ! choice of option for Richards' equation integer(i4b),intent(in) :: ixBeg,ixEnd ! start and end indices defining desired layers - real(dp),intent(in) :: mLayerMatricHead(:) ! matric head at the start of the time step (m) - real(dp),intent(in) :: mLayerMatricHeadTrial(:) ! trial value for matric head (m) - real(dp),intent(in) :: mLayerVolFracLiqTrial(:) ! trial value for volumetric fraction of liquid water (-) - real(dp),intent(in) :: mLayerVolFracIceTrial(:) ! trial value for volumetric fraction of ice (-) - real(dp),intent(in) :: specificStorage ! specific storage coefficient (m-1) - real(dp),intent(in) :: theta_sat(:) ! soil porosity (-) + real(summa_prec),intent(in) :: mLayerMatricHead(:) ! matric head at the start of the time step (m) + real(summa_prec),intent(in) :: mLayerMatricHeadTrial(:) ! trial value for matric head (m) + real(summa_prec),intent(in) :: mLayerVolFracLiqTrial(:) ! trial value for volumetric fraction of liquid water (-) + real(summa_prec),intent(in) :: mLayerVolFracIceTrial(:) ! trial value for volumetric fraction of ice (-) + real(summa_prec),intent(in) :: specificStorage ! specific storage coefficient (m-1) + real(summa_prec),intent(in) :: theta_sat(:) ! soil porosity (-) ! output: - real(dp),intent(inout) :: compress(:) ! soil compressibility (-) - real(dp),intent(inout) :: dCompress_dPsi(:) ! derivative in soil compressibility w.r.t. matric head (m-1) + real(summa_prec),intent(inout) :: compress(:) ! soil compressibility (-) + real(summa_prec),intent(inout) :: dCompress_dPsi(:) ! derivative in soil compressibility w.r.t. matric head (m-1) integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! local variables @@ -896,8 +896,8 @@ subroutine soilCmpres(& endif end do else - compress(:) = 0._dp - dCompress_dPsi(:) = 0._dp + compress(:) = 0._summa_prec + dCompress_dPsi(:) = 0._summa_prec end if end subroutine soilCmpres diff --git a/build/source/engine/computJacob.f90 b/build/source/engine/computJacob.f90 index 147f320c1..5c7a93b57 100755 --- a/build/source/engine/computJacob.f90 +++ b/build/source/engine/computJacob.f90 @@ -74,7 +74,7 @@ module computJacob_module implicit none ! define constants -real(dp),parameter :: verySmall=tiny(1.0_dp) ! a very small number +real(summa_prec),parameter :: verySmall=tiny(1.0_summa_prec) ! a very small number integer(i4b),parameter :: ixBandOffset=kl+ku+1 ! offset in the band Jacobian matrix private @@ -107,7 +107,7 @@ subroutine computJacob(& ! ----------------------------------------------------------------------------------------------------------------- implicit none ! input: model control - real(dp),intent(in) :: dt ! length of the time step (seconds) + real(summa_prec),intent(in) :: dt ! length of the time step (seconds) integer(i4b),intent(in) :: nSnow ! number of snow layers integer(i4b),intent(in) :: nSoil ! number of soil layers integer(i4b),intent(in) :: nLayers ! total number of layers in the snow+soil domain @@ -119,10 +119,10 @@ subroutine computJacob(& type(var_dlength),intent(in) :: prog_data ! prognostic variables for a local HRU type(var_dlength),intent(in) :: diag_data ! diagnostic variables for a local HRU type(var_dlength),intent(in) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables - real(dp),intent(in) :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) + real(summa_prec),intent(in) :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) ! input-output: Jacobian and its diagonal - real(dp),intent(inout) :: dMat(:) ! diagonal of the Jacobian matrix - real(dp),intent(out) :: aJac(:,:) ! Jacobian matrix + real(summa_prec),intent(inout) :: dMat(:) ! diagonal of the Jacobian matrix + real(summa_prec),intent(out) :: aJac(:,:) ! Jacobian matrix ! output variables integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message @@ -140,7 +140,7 @@ subroutine computJacob(& integer(i4b) :: jLayer ! index of model layer within the full state vector (hydrology) integer(i4b) :: pLayer ! indices of soil layers (used for the baseflow derivatives) ! conversion factors - real(dp) :: convLiq2tot ! factor to convert liquid water derivative to total water derivative + real(summa_prec) :: convLiq2tot ! factor to convert liquid water derivative to total water derivative ! -------------------------------------------------------------- ! associate variables from data structures associate(& @@ -244,7 +244,7 @@ subroutine computJacob(& ! initialize the Jacobian ! NOTE: this needs to be done every time, since Jacobian matrix is modified in the solver - aJac(:,:) = 0._dp ! analytical Jacobian matrix + aJac(:,:) = 0._summa_prec ! analytical Jacobian matrix ! compute terms in the Jacobian for vegetation (excluding fluxes) ! NOTE: energy for vegetation is computed *within* the iteration loop as it includes phase change @@ -285,7 +285,7 @@ subroutine computJacob(& ! * diagonal elements for the vegetation canopy (-) if(ixCasNrg/=integerMissing) aJac(ixDiag,ixCasNrg) = (dt/canopyDepth)*(-dCanairNetFlux_dCanairTemp) + dMat(ixCasNrg) if(ixVegNrg/=integerMissing) aJac(ixDiag,ixVegNrg) = (dt/canopyDepth)*(-dCanopyNetFlux_dCanopyTemp) + dMat(ixVegNrg) - if(ixVegHyd/=integerMissing) aJac(ixDiag,ixVegHyd) = -scalarFracLiqVeg*(dCanopyEvaporation_dCanLiq - scalarCanopyLiqDeriv)*dt + 1._dp ! ixVegHyd: CORRECT + if(ixVegHyd/=integerMissing) aJac(ixDiag,ixVegHyd) = -scalarFracLiqVeg*(dCanopyEvaporation_dCanLiq - scalarCanopyLiqDeriv)*dt + 1._summa_prec ! ixVegHyd: CORRECT ! * cross-derivative terms w.r.t. canopy water if(ixVegHyd/=integerMissing)then @@ -297,7 +297,7 @@ subroutine computJacob(& if(ixTopHyd/=integerMissing) aJac(ixOffDiag(ixTopHyd,ixVegHyd),ixVegHyd) = (dt/mLayerDepth(1))*(-scalarSoilControl*scalarFracLiqVeg*scalarCanopyLiqDeriv)/iden_water ! cross-derivative terms w.r.t. canopy liquid water (J m-1 kg-1) ! NOTE: dIce/dLiq = (1 - scalarFracLiqVeg); dIce*LH_fus/canopyDepth = J m-3; dLiq = kg m-2 - if(ixVegNrg/=integerMissing) aJac(ixOffDiag(ixVegNrg,ixVegHyd),ixVegHyd) = (dt/canopyDepth) *(-dCanopyNetFlux_dCanLiq) - (1._dp - scalarFracLiqVeg)*LH_fus/canopyDepth ! dF/dLiq + if(ixVegNrg/=integerMissing) aJac(ixOffDiag(ixVegNrg,ixVegHyd),ixVegHyd) = (dt/canopyDepth) *(-dCanopyNetFlux_dCanLiq) - (1._summa_prec - scalarFracLiqVeg)*LH_fus/canopyDepth ! dF/dLiq if(ixTopNrg/=integerMissing) aJac(ixOffDiag(ixTopNrg,ixVegHyd),ixVegHyd) = (dt/mLayerDepth(1))*(-dGroundNetFlux_dCanLiq) endif @@ -369,7 +369,7 @@ subroutine computJacob(& ! compute factor to convert liquid water derivative to total water derivative select case( ixHydType(iLayer) ) case(iname_watLayer); convLiq2tot = mLayerFracLiqSnow(iLayer) - case default; convLiq2tot = 1._dp + case default; convLiq2tot = 1._summa_prec end select ! - diagonal elements @@ -377,7 +377,7 @@ subroutine computJacob(& ! - lower-diagonal elements if(iLayer > 1)then - if(ixSnowOnlyHyd(iLayer-1)/=integerMissing) aJac(ixOffDiag(ixSnowOnlyHyd(iLayer-1),watState),watState) = 0._dp ! sub-diagonal: no dependence on other layers + if(ixSnowOnlyHyd(iLayer-1)/=integerMissing) aJac(ixOffDiag(ixSnowOnlyHyd(iLayer-1),watState),watState) = 0._summa_prec ! sub-diagonal: no dependence on other layers endif ! - upper diagonal elements @@ -394,7 +394,7 @@ subroutine computJacob(& if(nrgstate/=integerMissing)then ! (energy state for the current layer is within the state subset) ! (cross-derivative terms for the current layer) - aJac(ixOffDiag(nrgState,watState),watState) = -(1._dp - mLayerFracLiqSnow(iLayer))*LH_fus*iden_water ! (dF/dLiq) + aJac(ixOffDiag(nrgState,watState),watState) = -(1._summa_prec - mLayerFracLiqSnow(iLayer))*LH_fus*iden_water ! (dF/dLiq) aJac(ixOffDiag(watState,nrgState),nrgState) = (dt/mLayerDepth(iLayer))*iLayerLiqFluxSnowDeriv(iLayer)*mLayerdTheta_dTk(iLayer) ! (dVol/dT) ! (cross-derivative terms for the layer below) @@ -483,7 +483,7 @@ subroutine computJacob(& if(mLayerdTheta_dTk(jLayer) > verySmall)then ! ice is present aJac(ixOffDiag(nrgState,watState),watState) = -dVolTot_dPsi0(iLayer)*LH_fus*iden_water ! dNrg/dMat (J m-3 m-1) -- dMat changes volumetric water, and hence ice content else - aJac(ixOffDiag(nrgState,watState),watState) = 0._dp + aJac(ixOffDiag(nrgState,watState),watState) = 0._summa_prec endif ! - compute lower diagonal elements @@ -529,7 +529,7 @@ subroutine computJacob(& if(computeVegFlux)then ! (derivatives only defined when vegetation protrudes over the surface) ! * liquid water fluxes for vegetation canopy (-) - if(ixVegHyd/=integerMissing) aJac(ixVegHyd,ixVegHyd) = -scalarFracLiqVeg*(dCanopyEvaporation_dCanLiq - scalarCanopyLiqDeriv)*dt + 1._dp + if(ixVegHyd/=integerMissing) aJac(ixVegHyd,ixVegHyd) = -scalarFracLiqVeg*(dCanopyEvaporation_dCanLiq - scalarCanopyLiqDeriv)*dt + 1._summa_prec ! * cross-derivative terms for canopy water if(ixVegHyd/=integerMissing)then @@ -541,7 +541,7 @@ subroutine computJacob(& if(ixTopHyd/=integerMissing) aJac(ixTopHyd,ixVegHyd) = (dt/mLayerDepth(1))*(-scalarSoilControl*scalarFracLiqVeg*scalarCanopyLiqDeriv)/iden_water ! cross-derivative terms w.r.t. canopy liquid water (J m-1 kg-1) ! NOTE: dIce/dLiq = (1 - scalarFracLiqVeg); dIce*LH_fus/canopyDepth = J m-3; dLiq = kg m-2 - if(ixVegNrg/=integerMissing) aJac(ixVegNrg,ixVegHyd) = (dt/canopyDepth) *(-dCanopyNetFlux_dCanLiq) - (1._dp - scalarFracLiqVeg)*LH_fus/canopyDepth ! dF/dLiq + if(ixVegNrg/=integerMissing) aJac(ixVegNrg,ixVegHyd) = (dt/canopyDepth) *(-dCanopyNetFlux_dCanLiq) - (1._summa_prec - scalarFracLiqVeg)*LH_fus/canopyDepth ! dF/dLiq if(ixTopNrg/=integerMissing) aJac(ixTopNrg,ixVegHyd) = (dt/mLayerDepth(1))*(-dGroundNetFlux_dCanLiq) endif @@ -615,7 +615,7 @@ subroutine computJacob(& ! compute factor to convert liquid water derivative to total water derivative select case( ixHydType(iLayer) ) case(iname_watLayer); convLiq2tot = mLayerFracLiqSnow(iLayer) - case default; convLiq2tot = 1._dp + case default; convLiq2tot = 1._summa_prec end select ! - diagonal elements @@ -623,7 +623,7 @@ subroutine computJacob(& ! - lower-diagonal elements if(iLayer > 1)then - if(ixSnowOnlyHyd(iLayer-1)/=integerMissing) aJac(ixSnowOnlyHyd(iLayer-1),watState) = 0._dp ! sub-diagonal: no dependence on other layers + if(ixSnowOnlyHyd(iLayer-1)/=integerMissing) aJac(ixSnowOnlyHyd(iLayer-1),watState) = 0._summa_prec ! sub-diagonal: no dependence on other layers endif ! - upper diagonal elements @@ -640,7 +640,7 @@ subroutine computJacob(& if(nrgstate/=integerMissing)then ! (energy state for the current layer is within the state subset) ! (cross-derivative terms for the current layer) - aJac(nrgState,watState) = -(1._dp - mLayerFracLiqSnow(iLayer))*LH_fus*iden_water ! (dF/dLiq) + aJac(nrgState,watState) = -(1._summa_prec - mLayerFracLiqSnow(iLayer))*LH_fus*iden_water ! (dF/dLiq) aJac(watState,nrgState) = (dt/mLayerDepth(iLayer))*iLayerLiqFluxSnowDeriv(iLayer)*mLayerdTheta_dTk(iLayer) ! (dVol/dT) ! (cross-derivative terms for the layer below) @@ -738,7 +738,7 @@ subroutine computJacob(& if(mLayerdTheta_dTk(jLayer) > verySmall)then ! ice is present aJac(nrgState,watState) = -dVolTot_dPsi0(iLayer)*LH_fus*iden_water ! dNrg/dMat (J m-3 m-1) -- dMat changes volumetric water, and hence ice content else - aJac(nrgState,watState) = 0._dp + aJac(nrgState,watState) = 0._summa_prec endif ! - compute lower diagonal elements diff --git a/build/source/engine/computResid.f90 b/build/source/engine/computResid.f90 index a7d04bce8..322df20f6 100755 --- a/build/source/engine/computResid.f90 +++ b/build/source/engine/computResid.f90 @@ -105,31 +105,31 @@ subroutine computResid(& ! -------------------------------------------------------------------------------------------------------------------------------- implicit none ! input: model control - real(dp),intent(in) :: dt ! length of the time step (seconds) + real(summa_prec),intent(in) :: dt ! length of the time step (seconds) integer(i4b),intent(in) :: nSnow ! number of snow layers integer(i4b),intent(in) :: nSoil ! number of soil layers integer(i4b),intent(in) :: nLayers ! total number of layers in the snow+soil domain ! input: flux vectors - real(qp),intent(in) :: sMul(:) ! NOTE: qp ! state vector multiplier (used in the residual calculations) - real(dp),intent(in) :: fVec(:) ! flux vector + real(summa_prec),intent(in) :: sMul(:) ! NOTE: qp ! state vector multiplier (used in the residual calculations) + real(summa_prec),intent(in) :: fVec(:) ! flux vector ! input: state variables (already disaggregated into scalars and vectors) - real(dp),intent(in) :: scalarCanairTempTrial ! trial value for temperature of the canopy air space (K) - real(dp),intent(in) :: scalarCanopyTempTrial ! trial value for temperature of the vegetation canopy (K) - real(dp),intent(in) :: scalarCanopyHydTrial ! trial value for canopy water (kg m-2), either liquid water content or total water content - real(dp),intent(in) :: mLayerTempTrial(:) ! trial value for temperature of each snow/soil layer (K) - real(dp),intent(in) :: mLayerVolFracHydTrial(:) ! trial vector of volumetric water content (-), either liquid water content or total water content - real(dp),intent(in) :: scalarAquiferStorageTrial ! trial value of aquifer storage (m) + real(summa_prec),intent(in) :: scalarCanairTempTrial ! trial value for temperature of the canopy air space (K) + real(summa_prec),intent(in) :: scalarCanopyTempTrial ! trial value for temperature of the vegetation canopy (K) + real(summa_prec),intent(in) :: scalarCanopyHydTrial ! trial value for canopy water (kg m-2), either liquid water content or total water content + real(summa_prec),intent(in) :: mLayerTempTrial(:) ! trial value for temperature of each snow/soil layer (K) + real(summa_prec),intent(in) :: mLayerVolFracHydTrial(:) ! trial vector of volumetric water content (-), either liquid water content or total water content + real(summa_prec),intent(in) :: scalarAquiferStorageTrial ! trial value of aquifer storage (m) ! input: diagnostic variables defining the liquid water and ice content (function of state variables) - real(dp),intent(in) :: scalarCanopyIceTrial ! trial value for mass of ice on the vegetation canopy (kg m-2) - real(dp),intent(in) :: mLayerVolFracIceTrial(:) ! trial value for volumetric fraction of ice (-) + real(summa_prec),intent(in) :: scalarCanopyIceTrial ! trial value for mass of ice on the vegetation canopy (kg m-2) + real(summa_prec),intent(in) :: mLayerVolFracIceTrial(:) ! trial value for volumetric fraction of ice (-) ! input: data structures type(var_dlength),intent(in) :: prog_data ! prognostic variables for a local HRU type(var_dlength),intent(in) :: diag_data ! diagnostic variables for a local HRU type(var_dlength),intent(in) :: flux_data ! model fluxes for a local HRU type(var_ilength),intent(in) :: indx_data ! indices defining model states and layers ! output - real(dp),intent(out) :: rAdd(:) ! additional (sink) terms on the RHS of the state equation - real(qp),intent(out) :: rVec(:) ! NOTE: qp ! residual vector + real(summa_prec),intent(out) :: rAdd(:) ! additional (sink) terms on the RHS of the state equation + real(summa_prec),intent(out) :: rVec(:) ! NOTE: qp ! residual vector integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! -------------------------------------------------------------------------------------------------------------------------------- @@ -137,8 +137,8 @@ subroutine computResid(& ! -------------------------------------------------------------------------------------------------------------------------------- integer(i4b) :: iLayer ! index of layer within the snow+soil domain integer(i4b),parameter :: ixVegVolume=1 ! index of the desired vegetation control volumne (currently only one veg layer) - real(dp) :: scalarCanopyHyd ! canopy water content (kg m-2), either liquid water content or total water content - real(dp),dimension(nLayers) :: mLayerVolFracHyd ! vector of volumetric water content (-), either liquid water content or total water content + real(summa_prec) :: scalarCanopyHyd ! canopy water content (kg m-2), either liquid water content or total water content + real(summa_prec),dimension(nLayers) :: mLayerVolFracHyd ! vector of volumetric water content (-), either liquid water content or total water content ! -------------------------------------------------------------------------------------------------------------------------------- ! -------------------------------------------------------------------------------------------------------------------------------- ! link to the necessary variables for the residual computations @@ -189,7 +189,7 @@ subroutine computResid(& ! ----------------------- ! intialize additional terms on the RHS as zero - rAdd(:) = 0._dp + rAdd(:) = 0._summa_prec ! compute energy associated with melt freeze for the vegetation canopy if(ixVegNrg/=integerMissing) rAdd(ixVegNrg) = rAdd(ixVegNrg) + LH_fus*(scalarCanopyIceTrial - scalarCanopyIce)/canopyDepth ! energy associated with melt/freeze (J m-3) diff --git a/build/source/engine/convE2Temp.f90 b/build/source/engine/convE2Temp.f90 index 81d07e77b..7594db809 100755 --- a/build/source/engine/convE2Temp.f90 +++ b/build/source/engine/convE2Temp.f90 @@ -41,8 +41,8 @@ module convE2Temp_module ! define the look-up table used to compute temperature based on enthalpy integer(i4b),parameter :: nlook=10001 ! number of elements in the lookup table -real(dp),dimension(nlook),public :: E_lookup ! enthalpy values (J kg-1) -real(dp),dimension(nlook),public :: T_lookup ! temperature values (K) +real(summa_prec),dimension(nlook),public :: E_lookup ! enthalpy values (J kg-1) +real(summa_prec),dimension(nlook),public :: T_lookup ! temperature values (K) contains @@ -59,29 +59,29 @@ subroutine E2T_lookup(mpar_data,err,message) character(*),intent(out) :: message ! error message ! declare local variables character(len=128) :: cmessage ! error message in downwind routine - real(dp),parameter :: T_start=260.0_dp ! start temperature value where all liquid water is assumed frozen (K) - real(dp) :: T_incr,E_incr ! temperature/enthalpy increments - real(dp),dimension(nlook) :: Tk ! initial temperature vector - real(dp),dimension(nlook) :: Ey ! initial enthalpy vector - real(dp),parameter :: waterWght=1._dp ! weight applied to total water (kg m-3) --- cancels out - real(dp),dimension(nlook) :: T2deriv ! 2nd derivatives of the interpolating function at tabulated points + real(summa_prec),parameter :: T_start=260.0_summa_prec ! start temperature value where all liquid water is assumed frozen (K) + real(summa_prec) :: T_incr,E_incr ! temperature/enthalpy increments + real(summa_prec),dimension(nlook) :: Tk ! initial temperature vector + real(summa_prec),dimension(nlook) :: Ey ! initial enthalpy vector + real(summa_prec),parameter :: waterWght=1._summa_prec ! weight applied to total water (kg m-3) --- cancels out + real(summa_prec),dimension(nlook) :: T2deriv ! 2nd derivatives of the interpolating function at tabulated points integer(i4b) :: ilook ! loop through lookup table ! initialize error control err=0; message="E2T_lookup/" ! associate associate( snowfrz_scale => mpar_data%var(iLookPARAM%snowfrz_scale)%dat(1) ) ! define initial temperature vector - T_incr = (Tfreeze - T_start) / real(nlook-1, kind(dp)) ! temperature increment + T_incr = (Tfreeze - T_start) / real(nlook-1, kind(summa_prec)) ! temperature increment Tk = arth(T_start,T_incr,nlook) ! ***** compute specific enthalpy (NOTE: J m-3 --> J kg-1) ***** do ilook=1,nlook Ey(ilook) = temp2ethpy(Tk(ilook),waterWght,snowfrz_scale)/waterWght ! (J m-3 --> J kg-1) end do ! define the final enthalpy vector - E_incr = (-Ey(1)) / real(nlook-1, kind(dp)) ! enthalpy increment + E_incr = (-Ey(1)) / real(nlook-1, kind(summa_prec)) ! enthalpy increment E_lookup = arth(Ey(1),E_incr,nlook) ! use cubic spline interpolation to obtain temperature values at the desired values of enthalpy - call spline(Ey,Tk,1.e30_dp,1.e30_dp,T2deriv,err,cmessage) ! get the second derivatives + call spline(Ey,Tk,1.e30_summa_prec,1.e30_summa_prec,T2deriv,err,cmessage) ! get the second derivatives if(err/=0) then; message=trim(message)//trim(cmessage); return; end if do ilook=1,nlook call splint(Ey,Tk,T2deriv,E_lookup(ilook),T_lookup(ilook),err,cmessage) @@ -99,25 +99,25 @@ subroutine E2T_nosoil(Ey,BulkDenWater,fc_param,Tk,err,message) ! compute temperature based on enthalpy -- appropriate when no dry mass, as in snow implicit none ! declare dummy variables - real(dp),intent(in) :: Ey ! total enthalpy (J m-3) - real(dp),intent(in) :: BulkDenWater ! bulk density of water (kg m-3) - real(dp),intent(in) :: fc_param ! freezing curve parameter (K-1) - real(dp),intent(out) :: Tk ! initial temperature guess / final temperature value (K) + real(summa_prec),intent(in) :: Ey ! total enthalpy (J m-3) + real(summa_prec),intent(in) :: BulkDenWater ! bulk density of water (kg m-3) + real(summa_prec),intent(in) :: fc_param ! freezing curve parameter (K-1) + real(summa_prec),intent(out) :: Tk ! initial temperature guess / final temperature value (K) integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! declare local variables - real(dp),parameter :: dx=1.d-8 ! finite difference increment (J kg-1) - real(dp),parameter :: atol=1.d-12 ! convergence criteria (J kg-1) - real(dp) :: E_spec ! specific enthalpy (J kg-1) - real(dp) :: E_incr ! enthalpy increment + real(summa_prec),parameter :: dx=1.d-8 ! finite difference increment (J kg-1) + real(summa_prec),parameter :: atol=1.d-12 ! convergence criteria (J kg-1) + real(summa_prec) :: E_spec ! specific enthalpy (J kg-1) + real(summa_prec) :: E_incr ! enthalpy increment integer(i4b) :: niter=15 ! maximum number of iterations integer(i4b) :: iter ! iteration index integer(i4b) :: i0 ! position in lookup table - real(dp) :: Tg0,Tg1 ! trial temperatures (K) - real(dp) :: Ht0,Ht1 ! specific enthalpy, based on the trial temperatures (J kg-1) - real(dp) :: f0,f1 ! function evaluations (difference between enthalpy guesses) - real(dp) :: dh ! enthalpy derivative - real(dp) :: dT ! temperature increment + real(summa_prec) :: Tg0,Tg1 ! trial temperatures (K) + real(summa_prec) :: Ht0,Ht1 ! specific enthalpy, based on the trial temperatures (J kg-1) + real(summa_prec) :: f0,f1 ! function evaluations (difference between enthalpy guesses) + real(summa_prec) :: dh ! enthalpy derivative + real(summa_prec) :: dT ! temperature increment ! initialize error control err=0; message="E2T_nosoil/" ! convert input of total enthalpy (J m-3) to total specific enthalpy (J kg-1) @@ -130,8 +130,8 @@ subroutine E2T_nosoil(Ey,BulkDenWater,fc_param,Tk,err,message) Tg0 = (E_spec - E_lookup(1))/Cp_ice + T_lookup(1) Tg1 = Tg0+dx ! compute enthalpy - Ht0 = temp2ethpy(Tg0,1._dp,fc_param) - Ht1 = temp2ethpy(Tg1,1._dp,fc_param) + Ht0 = temp2ethpy(Tg0,1._summa_prec,fc_param) + Ht1 = temp2ethpy(Tg1,1._summa_prec,fc_param) ! compute function evaluations f0 = Ht0 - E_spec f1 = Ht1 - E_spec @@ -171,7 +171,7 @@ subroutine E2T_nosoil(Ey,BulkDenWater,fc_param,Tk,err,message) ! comute new value of Tg Tg1 = Tg0+dT ! get new function evaluation - Ht1 = temp2ethpy(Tg1,1._dp,fc_param) + Ht1 = temp2ethpy(Tg1,1._summa_prec,fc_param) f1 = Ht1 - E_spec ! compute derivative if dT dh = (f1 - f0)/dT @@ -201,17 +201,17 @@ function temp2ethpy(Tk,BulkDenWater,fc_param) ! NOTE: enthalpy is a relative value, defined as zero at Tfreeze where all water is liquid implicit none ! declare dummy variables - real(dp),intent(in) :: Tk ! layer temperature (K) - real(dp),intent(in) :: BulkDenWater ! bulk density of water (kg m-3) - real(dp),intent(in) :: fc_param ! freezing curve parameter (K-1) - real(dp) :: temp2ethpy ! return value of the function, total specific enthalpy (J m-3) + real(summa_prec),intent(in) :: Tk ! layer temperature (K) + real(summa_prec),intent(in) :: BulkDenWater ! bulk density of water (kg m-3) + real(summa_prec),intent(in) :: fc_param ! freezing curve parameter (K-1) + real(summa_prec) :: temp2ethpy ! return value of the function, total specific enthalpy (J m-3) ! declare local variables - real(dp) :: frac_liq ! fraction of liquid water - real(dp) :: enthTempWater ! temperature component of specific enthalpy for total water (liquid and ice) (J kg-1) - real(dp) :: enthMass ! mass component of specific enthalpy (J kg-1) + real(summa_prec) :: frac_liq ! fraction of liquid water + real(summa_prec) :: enthTempWater ! temperature component of specific enthalpy for total water (liquid and ice) (J kg-1) + real(summa_prec) :: enthMass ! mass component of specific enthalpy (J kg-1) ! NOTE: this function assumes the freezing curve for snow ... it needs modification to use vanGenuchten functions for soil ! compute the fraction of liquid water in the given layer - frac_liq = 1._dp / ( 1._dp + ( fc_param*( Tfreeze - min(Tk,Tfreeze) ) )**2._dp ) + frac_liq = 1._summa_prec / ( 1._summa_prec + ( fc_param*( Tfreeze - min(Tk,Tfreeze) ) )**2._summa_prec ) ! compute the temperature component of enthalpy for the soil constituent (J kg-1) !enthTempSoil = Cp_soil*(Tk - Tfreeze) ! compute the temperature component of enthalpy for total water (J kg-1) @@ -220,7 +220,7 @@ function temp2ethpy(Tk,BulkDenWater,fc_param) if(Tk>=Tfreeze) enthTempWater = Cp_water*(Tk - Tfreeze) ! compute the mass component of enthalpy -- energy required to melt ice (J kg-1) ! NOTE: negative enthalpy means require energy to bring to Tfreeze - enthMass = -LH_fus*(1._dp - frac_liq) + enthMass = -LH_fus*(1._summa_prec - frac_liq) ! finally, compute the total enthalpy (J m-3) ! NOTE: this is the case for snow (no soil).. function needs modification to use vanGenuchten functions for soil temp2ethpy = BulkDenWater*(enthTempWater + enthMass) !+ BulkDenSoil*enthTempSoil diff --git a/build/source/engine/conv_funcs.f90 b/build/source/engine/conv_funcs.f90 index 291938630..568372aec 100755 --- a/build/source/engine/conv_funcs.f90 +++ b/build/source/engine/conv_funcs.f90 @@ -36,8 +36,8 @@ module conv_funcs_module ! *************************************************************************************************************** function getLatentHeatValue(T) implicit none -real(dp),intent(in) :: T ! temperature (K) -real(dp) :: getLatentHeatValue ! latent heat of sublimation/vaporization (J kg-1) +real(summa_prec),intent(in) :: T ! temperature (K) +real(summa_prec) :: getLatentHeatValue ! latent heat of sublimation/vaporization (J kg-1) if(T > Tfreeze)then getLatentHeatValue = LH_vap ! latent heat of vaporization (J kg-1) else @@ -52,14 +52,14 @@ end function getLatentHeatValue function vapPress(q,p) implicit none ! input -real(dp),intent(in) :: q ! specific humidity (g g-1) -real(dp),intent(in) :: p ! pressure (Pa) +real(summa_prec),intent(in) :: q ! specific humidity (g g-1) +real(summa_prec),intent(in) :: p ! pressure (Pa) ! output -real(dp) :: vapPress ! vapor pressure (Pa) +real(summa_prec) :: vapPress ! vapor pressure (Pa) ! local -real(dp) :: w ! mixing ratio -!real(dp),parameter :: w_ratio = 0.622_dp ! molecular weight ratio of water to dry air (-) -w = q / (1._dp - q) ! mixing ratio (-) +real(summa_prec) :: w ! mixing ratio +!real(summa_prec),parameter :: w_ratio = 0.622_summa_prec ! molecular weight ratio of water to dry air (-) +w = q / (1._summa_prec - q) ! mixing ratio (-) vapPress = (w/(w + w_ratio))*p ! vapor pressure (Pa) end function vapPress @@ -72,22 +72,22 @@ end function vapPress subroutine satVapPress(TC, SVP, dSVP_dT) IMPLICIT NONE ! input -real(dp), intent(in) :: TC ! temperature (C) +real(summa_prec), intent(in) :: TC ! temperature (C) ! output -real(dp), intent(out) :: SVP ! saturation vapor pressure (Pa) -real(dp), intent(out) :: dSVP_dT ! d(SVP)/dT +real(summa_prec), intent(out) :: SVP ! saturation vapor pressure (Pa) +real(summa_prec), intent(out) :: dSVP_dT ! d(SVP)/dT ! local -real(dp), parameter :: X1 = 17.27_dp -real(dp), parameter :: X2 = 237.30_dp +real(summa_prec), parameter :: X1 = 17.27_summa_prec +real(summa_prec), parameter :: X2 = 237.30_summa_prec ! local (use to test derivative calculations) -real(dp),parameter :: dx = 1.e-8_dp ! finite difference increment +real(summa_prec),parameter :: dx = 1.e-8_summa_prec ! finite difference increment logical(lgt),parameter :: testDeriv=.false. ! flag to test the derivative !--------------------------------------------------------------------------------------------------- ! Units note : Pa = N m-2 = kg m-1 s-2 ! SATVPFRZ= 610.8 ! Saturation water vapour pressure at 273.16K (Pa) SVP = SATVPFRZ * EXP( (X1*TC)/(X2 + TC) ) ! Saturated Vapour Press (Pa) -dSVP_dT = SVP * (X1/(X2 + TC) - X1*TC/(X2 + TC)**2._dp) +dSVP_dT = SVP * (X1/(X2 + TC) - X1*TC/(X2 + TC)**2._summa_prec) if(testDeriv) print*, 'dSVP_dT check... ', SVP, dSVP_dT, (SATVPRESS(TC+dx) - SVP)/dx END SUBROUTINE satVapPress @@ -104,10 +104,10 @@ END SUBROUTINE satVapPress FUNCTION MSLP2AIRP(MSLP, ELEV) IMPLICIT NONE -REAL(DP), INTENT(IN) :: MSLP ! base pressure (Pa) -REAL(DP), INTENT(IN) :: ELEV ! elevation difference from base (m) +real(summa_prec), INTENT(IN) :: MSLP ! base pressure (Pa) +real(summa_prec), INTENT(IN) :: ELEV ! elevation difference from base (m) -REAL(DP) :: MSLP2AIRP ! Air pressure (Pa) +real(summa_prec) :: MSLP2AIRP ! Air pressure (Pa) MSLP2AIRP = MSLP * ( (293.-0.0065*ELEV) / 293. )**5.256 @@ -126,14 +126,14 @@ FUNCTION RLHUM2DEWPT(T, RLHUM) ! Compute Dewpoint temperature from Relative Humidity IMPLICIT NONE -REAL(DP), INTENT(IN) :: T ! Temperature (K) -REAL(DP), INTENT(IN) :: RLHUM ! Relative Humidity (%) +real(summa_prec), INTENT(IN) :: T ! Temperature (K) +real(summa_prec), INTENT(IN) :: RLHUM ! Relative Humidity (%) -REAL(DP) :: RLHUM2DEWPT ! Dewpoint Temp (K) +real(summa_prec) :: RLHUM2DEWPT ! Dewpoint Temp (K) -REAL(DP) :: VPSAT ! Sat. vapour pressure at T (Pa) -REAL(DP) :: TDCEL ! Dewpoint temp Celcius (C) +real(summa_prec) :: VPSAT ! Sat. vapour pressure at T (Pa) +real(summa_prec) :: TDCEL ! Dewpoint temp Celcius (C) ! Units note : Pa = N m-2 = kg m-1 s-2 ! SATVPFRZ= 610.8 ! Saturation water vapour pressure at 273.16K (Pa) @@ -158,13 +158,13 @@ END FUNCTION RLHUM2DEWPT FUNCTION DEWPT2RLHUM(T, DEWPT) IMPLICIT NONE -REAL(DP), INTENT(IN) :: T ! Temperature (K) -REAL(DP), INTENT(IN) :: DEWPT ! Dewpoint temp (K) +real(summa_prec), INTENT(IN) :: T ! Temperature (K) +real(summa_prec), INTENT(IN) :: DEWPT ! Dewpoint temp (K) -REAL(DP) :: DEWPT2RLHUM ! Relative Humidity (%) +real(summa_prec) :: DEWPT2RLHUM ! Relative Humidity (%) -REAL(DP) :: VPSAT ! Sat. vapour pressure at T (Pa) -REAL(DP) :: TDCEL ! Dewpt in celcius (C) +real(summa_prec) :: VPSAT ! Sat. vapour pressure at T (Pa) +real(summa_prec) :: TDCEL ! Dewpt in celcius (C) ! Units note : Pa = N m-2 = kg m-1 s-2 ! SATVPFRZ= 610.8 ! Saturation water vapour pressure at 273.16K (Pa) @@ -188,13 +188,13 @@ END FUNCTION DEWPT2RLHUM FUNCTION DEWPT2SPHM(DEWPT, PRESS) IMPLICIT NONE -REAL(DP), INTENT(IN) :: DEWPT ! Dewpoint temp (K) -REAL(DP), INTENT(IN) :: PRESS ! Pressure (Pa) +real(summa_prec), INTENT(IN) :: DEWPT ! Dewpoint temp (K) +real(summa_prec), INTENT(IN) :: PRESS ! Pressure (Pa) -REAL(DP) :: DEWPT2SPHM ! Specific Humidity (g/g) +real(summa_prec) :: DEWPT2SPHM ! Specific Humidity (g/g) -REAL(DP) :: VPAIR ! vapour pressure at T (Pa) -REAL(DP) :: TDCEL ! Dewpt in celcius (C) +real(summa_prec) :: VPAIR ! vapour pressure at T (Pa) +real(summa_prec) :: TDCEL ! Dewpt in celcius (C) ! Units note : Pa = N m-2 = kg m-1 s-2 ! SATVPFRZ= 610.8 ! Saturation water vapour pressure at 273.16K (Pa) @@ -218,10 +218,10 @@ END FUNCTION DEWPT2SPHM FUNCTION DEWPT2VPAIR(DEWPT) IMPLICIT NONE -REAL(DP), INTENT(IN) :: DEWPT ! Dewpoint temp (K) -REAL(DP) :: TDCEL ! Dewpt in celcius (C) +real(summa_prec), INTENT(IN) :: DEWPT ! Dewpoint temp (K) +real(summa_prec) :: TDCEL ! Dewpt in celcius (C) -REAL(DP) :: DEWPT2VPAIR ! Vapour Press (Pa) +real(summa_prec) :: DEWPT2VPAIR ! Vapour Press (Pa) ! Units note : Pa = N m-2 = kg m-1 s-2 ! SATVPFRZ= 610.8 ! Saturation water vapour pressure at 273.16K (Pa) @@ -243,15 +243,15 @@ END FUNCTION DEWPT2VPAIR FUNCTION SPHM2RELHM(SPHM, PRESS, TAIR) IMPLICIT NONE -REAL(DP), INTENT(IN) :: SPHM ! Specific Humidity (g/g) -REAL(DP), INTENT(IN) :: PRESS ! Pressure (Pa) -REAL(DP), INTENT(IN) :: TAIR ! Air temp +real(summa_prec), INTENT(IN) :: SPHM ! Specific Humidity (g/g) +real(summa_prec), INTENT(IN) :: PRESS ! Pressure (Pa) +real(summa_prec), INTENT(IN) :: TAIR ! Air temp -REAL(DP) :: SPHM2RELHM ! Dewpoint Temp (K) +real(summa_prec) :: SPHM2RELHM ! Dewpoint Temp (K) -REAL(DP) :: VPSAT ! vapour pressure at T (Pa) -REAL(DP) :: TDCEL ! Dewpt in celcius (C) -!REAL(DP) :: DUM ! Intermediate +real(summa_prec) :: VPSAT ! vapour pressure at T (Pa) +real(summa_prec) :: TDCEL ! Dewpt in celcius (C) +!real(summa_prec) :: DUM ! Intermediate ! Units note : Pa = N m-2 = kg m-1 s-2 ! SATVPFRZ= 610.8 ! Saturation water vapour pressure at 273.16K (Pa) @@ -274,15 +274,15 @@ END FUNCTION SPHM2RELHM FUNCTION RELHM2SPHM(RELHM, PRESS, TAIR) IMPLICIT NONE -REAL(DP), INTENT(IN) :: RELHM ! Relative Humidity (%) -REAL(DP), INTENT(IN) :: PRESS ! Pressure (Pa) -REAL(DP), INTENT(IN) :: TAIR ! Air temp +real(summa_prec), INTENT(IN) :: RELHM ! Relative Humidity (%) +real(summa_prec), INTENT(IN) :: PRESS ! Pressure (Pa) +real(summa_prec), INTENT(IN) :: TAIR ! Air temp -REAL(DP) :: RELHM2SPHM ! Specific Humidity (g/g) +real(summa_prec) :: RELHM2SPHM ! Specific Humidity (g/g) -REAL(DP) :: PVP ! Partial vapour pressure at T (Pa) -REAL(DP) :: TDCEL ! Dewpt in celcius (C) -!REAL(DP) :: DUM ! Intermediate +real(summa_prec) :: PVP ! Partial vapour pressure at T (Pa) +real(summa_prec) :: TDCEL ! Dewpt in celcius (C) +!real(summa_prec) :: DUM ! Intermediate ! Units note : Pa = N m-2 = kg m-1 s-2 ! SATVPFRZ= 610.8 ! Saturation water vapour pressure at 273.16K (Pa) @@ -300,31 +300,31 @@ END FUNCTION RELHM2SPHM FUNCTION WETBULBTMP(TAIR, RELHM, PRESS) IMPLICIT NONE ! input -REAL(DP), INTENT(IN) :: TAIR ! Air temp (K) -REAL(DP), INTENT(IN) :: RELHM ! Relative Humidity (-) -REAL(DP), INTENT(IN) :: PRESS ! Pressure (Pa) +real(summa_prec), INTENT(IN) :: TAIR ! Air temp (K) +real(summa_prec), INTENT(IN) :: RELHM ! Relative Humidity (-) +real(summa_prec), INTENT(IN) :: PRESS ! Pressure (Pa) ! output -REAL(DP) :: WETBULBTMP ! Wet bulb temperature (K) +real(summa_prec) :: WETBULBTMP ! Wet bulb temperature (K) ! locals -REAL(DP) :: Tcel ! Temperature in celcius (C) -REAL(DP) :: PVP ! Partial vapor pressure (Pa) -REAL(DP) :: TWcel ! Wet bulb temperature in celcius (C) -REAL(DP),PARAMETER :: k=6.54E-4_DP ! normalizing factor in wet bulb estimate (C-1) -REAL(DP) :: Twet_trial0 ! trial value for wet bulb temperature (C) -REAL(DP) :: Twet_trial1 ! trial value for wet bulb temperature (C) -REAL(DP) :: f0,f1 ! function evaluations (C) -REAL(DP) :: df_dT ! derivative (-) -REAL(DP) :: TWinc ! wet bulb temperature increment (C) +real(summa_prec) :: Tcel ! Temperature in celcius (C) +real(summa_prec) :: PVP ! Partial vapor pressure (Pa) +real(summa_prec) :: TWcel ! Wet bulb temperature in celcius (C) +real(summa_prec),PARAMETER :: k=6.54E-4_DP ! normalizing factor in wet bulb estimate (C-1) +real(summa_prec) :: Twet_trial0 ! trial value for wet bulb temperature (C) +real(summa_prec) :: Twet_trial1 ! trial value for wet bulb temperature (C) +real(summa_prec) :: f0,f1 ! function evaluations (C) +real(summa_prec) :: df_dT ! derivative (-) +real(summa_prec) :: TWinc ! wet bulb temperature increment (C) INTEGER(I4B) :: iter ! iterattion index -REAL(DP),PARAMETER :: Xoff=1.E-5_DP ! finite difference increment (C) -REAL(DP),PARAMETER :: Xtol=1.E-8_DP ! convergence tolerance (C) +real(summa_prec),PARAMETER :: Xoff=1.E-5_DP ! finite difference increment (C) +real(summa_prec),PARAMETER :: Xtol=1.E-8_DP ! convergence tolerance (C) INTEGER(I4B) :: maxiter=15 ! maximum number of iterations ! convert temperature to Celcius Tcel = TAIR-TFREEZE ! compute partial vapor pressure based on temperature (Pa) PVP = RELHM * SATVPRESS(Tcel) ! define an initial trial value for wetbulb temperature -TWcel = Tcel - 5._dp +TWcel = Tcel - 5._summa_prec ! iterate until convergence do iter=1,maxiter ! compute Twet estimates @@ -358,9 +358,9 @@ END FUNCTION WETBULBTMP ! *************************************************************************************************************** FUNCTION SATVPRESS(TCEL) IMPLICIT NONE -REAL(DP),INTENT(IN) :: TCEL ! Temperature (C) -REAL(DP) :: SATVPRESS ! Saturated vapor pressure (Pa) -SATVPRESS = SATVPFRZ * EXP( (17.27_dp*TCEL)/(237.30_dp + TCEL) ) ! Saturated Vapour Press (Pa) +real(summa_prec),INTENT(IN) :: TCEL ! Temperature (C) +real(summa_prec) :: SATVPRESS ! Saturated vapor pressure (Pa) +SATVPRESS = SATVPFRZ * EXP( (17.27_summa_prec*TCEL)/(237.30_summa_prec + TCEL) ) ! Saturated Vapour Press (Pa) END FUNCTION SATVPRESS diff --git a/build/source/engine/coupled_em.f90 b/build/source/engine/coupled_em.f90 index 88fd044da..a9e08b7bd 100755 --- a/build/source/engine/coupled_em.f90 +++ b/build/source/engine/coupled_em.f90 @@ -89,10 +89,10 @@ module coupled_em_module private public::coupled_em ! algorithmic parameters -real(dp),parameter :: valueMissing=-9999._dp ! missing value, used when diagnostic or state variables are undefined -real(dp),parameter :: verySmall=1.e-6_dp ! used as an additive constant to check if substantial difference among real numbers -real(dp),parameter :: mpe=1.e-6_dp ! prevents overflow error if division by zero -real(dp),parameter :: dx=1.e-6_dp ! finite difference increment +real(summa_prec),parameter :: valueMissing=-9999._summa_prec ! missing value, used when diagnostic or state variables are undefined +real(summa_prec),parameter :: verySmall=1.e-6_summa_prec ! used as an additive constant to check if substantial difference among real numbers +real(summa_prec),parameter :: mpe=1.e-6_summa_prec ! prevents overflow error if division by zero +real(summa_prec),parameter :: dx=1.e-6_summa_prec ! finite difference increment contains @@ -148,7 +148,7 @@ subroutine coupled_em(& implicit none ! model control integer(8),intent(in) :: hruId ! hruId - real(dp),intent(inout) :: dt_init ! used to initialize the size of the sub-step + real(summa_prec),intent(inout) :: dt_init ! used to initialize the size of the sub-step logical(lgt),intent(inout) :: computeVegFlux ! flag to indicate if we are computing fluxes over vegetation (.false. means veg is buried with snow) ! data structures (input) type(var_i),intent(in) :: type_data ! type of vegetation and soil @@ -172,12 +172,12 @@ subroutine coupled_em(& integer(i4b) :: nSoil ! number of soil layers integer(i4b) :: nLayers ! total number of layers integer(i4b) :: nState ! total number of state variables - real(dp) :: dtSave ! length of last input model sub-step (seconds) - real(dp) :: dt_sub ! length of model sub-step (seconds) - real(dp) :: dt_wght ! weight applied to model sub-step (dt_sub/data_step) - real(dp) :: dt_solv ! seconds in the data step that have been completed - real(dp) :: dtMultiplier ! time step multiplier (-) based on what happenned in "opSplittin" - real(dp) :: minstep,maxstep ! minimum and maximum time step length (seconds) + real(summa_prec) :: dtSave ! length of last input model sub-step (seconds) + real(summa_prec) :: dt_sub ! length of model sub-step (seconds) + real(summa_prec) :: dt_wght ! weight applied to model sub-step (dt_sub/data_step) + real(summa_prec) :: dt_solv ! seconds in the data step that have been completed + real(summa_prec) :: dtMultiplier ! time step multiplier (-) based on what happenned in "opSplittin" + real(summa_prec) :: minstep,maxstep ! minimum and maximum time step length (seconds) integer(i4b) :: nsub ! number of substeps logical(lgt) :: computeVegFluxOld ! flag to indicate if we are computing fluxes over vegetation on the previous sub step logical(lgt) :: includeAquifer ! flag to denote that an aquifer is included @@ -185,16 +185,16 @@ subroutine coupled_em(& logical(lgt) :: modifiedVegState ! flag to denote that vegetation states were modified type(var_dlength) :: flux_mean ! timestep-average model fluxes for a local HRU integer(i4b) :: nLayersRoots ! number of soil layers that contain roots - real(dp) :: exposedVAI ! exposed vegetation area index - real(dp) :: dCanopyWetFraction_dWat ! derivative in wetted fraction w.r.t. canopy total water (kg-1 m2) - real(dp) :: dCanopyWetFraction_dT ! derivative in wetted fraction w.r.t. canopy temperature (K-1) - real(dp),parameter :: varNotUsed1=-9999._dp ! variables used to calculate derivatives (not needed here) - real(dp),parameter :: varNotUsed2=-9999._dp ! variables used to calculate derivatives (not needed here) + real(summa_prec) :: exposedVAI ! exposed vegetation area index + real(summa_prec) :: dCanopyWetFraction_dWat ! derivative in wetted fraction w.r.t. canopy total water (kg-1 m2) + real(summa_prec) :: dCanopyWetFraction_dT ! derivative in wetted fraction w.r.t. canopy temperature (K-1) + real(summa_prec),parameter :: varNotUsed1=-9999._summa_prec ! variables used to calculate derivatives (not needed here) + real(summa_prec),parameter :: varNotUsed2=-9999._summa_prec ! variables used to calculate derivatives (not needed here) integer(i4b) :: iSnow ! index of snow layers integer(i4b) :: iLayer ! index of model layers - real(dp) :: massLiquid ! mass liquid water (kg m-2) - real(dp) :: superflousSub ! superflous sublimation (kg m-2 s-1) - real(dp) :: superflousNrg ! superflous energy that cannot be used for sublimation (W m-2 [J m-2 s-1]) + real(summa_prec) :: massLiquid ! mass liquid water (kg m-2) + real(summa_prec) :: superflousSub ! superflous sublimation (kg m-2 s-1) + real(summa_prec) :: superflousNrg ! superflous energy that cannot be used for sublimation (W m-2 [J m-2 s-1]) integer(i4b) :: ixSolution ! solution method used by opSplitting logical(lgt) :: firstSubStep ! flag to denote if the first time step logical(lgt) :: stepFailure ! flag to denote the need to reduce length of the coupled step and try again @@ -206,34 +206,34 @@ subroutine coupled_em(& type(var_dlength) :: prog_temp ! temporary model prognostic variables type(var_dlength) :: diag_temp ! temporary model diagnostic variables ! check SWE - real(dp) :: oldSWE ! SWE at the start of the substep - real(dp) :: newSWE ! SWE at the end of the substep - real(dp) :: delSWE ! change in SWE over the subtep - real(dp) :: effRainfall ! effective rainfall (kg m-2 s-1) - real(dp) :: effSnowfall ! effective snowfall (kg m-2 s-1) - real(dp) :: sfcMeltPond ! surface melt pond (kg m-2) - real(dp) :: massBalance ! mass balance error (kg m-2) + real(summa_prec) :: oldSWE ! SWE at the start of the substep + real(summa_prec) :: newSWE ! SWE at the end of the substep + real(summa_prec) :: delSWE ! change in SWE over the subtep + real(summa_prec) :: effRainfall ! effective rainfall (kg m-2 s-1) + real(summa_prec) :: effSnowfall ! effective snowfall (kg m-2 s-1) + real(summa_prec) :: sfcMeltPond ! surface melt pond (kg m-2) + real(summa_prec) :: massBalance ! mass balance error (kg m-2) ! balance checks integer(i4b) :: iVar ! loop through model variables - real(dp) :: totalSoilCompress ! total soil compression (kg m-2) - real(dp) :: scalarCanopyWatBalError ! water balance error for the vegetation canopy (kg m-2) - real(dp) :: scalarSoilWatBalError ! water balance error (kg m-2) - real(dp) :: scalarInitCanopyLiq ! initial liquid water on the vegetation canopy (kg m-2) - real(dp) :: scalarInitCanopyIce ! initial ice on the vegetation canopy (kg m-2) - real(dp) :: balanceCanopyWater0 ! total water stored in the vegetation canopy at the start of the step (kg m-2) - real(dp) :: balanceCanopyWater1 ! total water stored in the vegetation canopy at the end of the step (kg m-2) - real(dp) :: balanceSoilWater0 ! total soil storage at the start of the step (kg m-2) - real(dp) :: balanceSoilWater1 ! total soil storage at the end of the step (kg m-2) - real(dp) :: balanceSoilInflux ! input to the soil zone - real(dp) :: balanceSoilBaseflow ! output from the soil zone - real(dp) :: balanceSoilDrainage ! output from the soil zone - real(dp) :: balanceSoilET ! output from the soil zone - real(dp) :: balanceAquifer0 ! total aquifer storage at the start of the step (kg m-2) - real(dp) :: balanceAquifer1 ! total aquifer storage at the end of the step (kg m-2) + real(summa_prec) :: totalSoilCompress ! total soil compression (kg m-2) + real(summa_prec) :: scalarCanopyWatBalError ! water balance error for the vegetation canopy (kg m-2) + real(summa_prec) :: scalarSoilWatBalError ! water balance error (kg m-2) + real(summa_prec) :: scalarInitCanopyLiq ! initial liquid water on the vegetation canopy (kg m-2) + real(summa_prec) :: scalarInitCanopyIce ! initial ice on the vegetation canopy (kg m-2) + real(summa_prec) :: balanceCanopyWater0 ! total water stored in the vegetation canopy at the start of the step (kg m-2) + real(summa_prec) :: balanceCanopyWater1 ! total water stored in the vegetation canopy at the end of the step (kg m-2) + real(summa_prec) :: balanceSoilWater0 ! total soil storage at the start of the step (kg m-2) + real(summa_prec) :: balanceSoilWater1 ! total soil storage at the end of the step (kg m-2) + real(summa_prec) :: balanceSoilInflux ! input to the soil zone + real(summa_prec) :: balanceSoilBaseflow ! output from the soil zone + real(summa_prec) :: balanceSoilDrainage ! output from the soil zone + real(summa_prec) :: balanceSoilET ! output from the soil zone + real(summa_prec) :: balanceAquifer0 ! total aquifer storage at the start of the step (kg m-2) + real(summa_prec) :: balanceAquifer1 ! total aquifer storage at the end of the step (kg m-2) ! test balance checks logical(lgt), parameter :: printBalance=.false. ! flag to print the balance checks - real(dp), allocatable :: liqSnowInit(:) ! volumetric liquid water conetnt of snow at the start of the time step - real(dp), allocatable :: liqSoilInit(:) ! soil moisture at the start of the time step + real(summa_prec), allocatable :: liqSnowInit(:) ! volumetric liquid water conetnt of snow at the start of the time step + real(summa_prec), allocatable :: liqSoilInit(:) ! soil moisture at the start of the time step ! ---------------------------------------------------------------------------------------------------------------------------------------------- ! initialize error control err=0; message="coupled_em/" @@ -300,12 +300,12 @@ subroutine coupled_em(& if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; end if ! initialize compression and surface melt pond - sfcMeltPond = 0._dp ! change in storage associated with the surface melt pond (kg m-2) - totalSoilCompress = 0._dp ! change in soil storage associated with compression of the matrix (kg m-2) + sfcMeltPond = 0._summa_prec ! change in storage associated with the surface melt pond (kg m-2) + totalSoilCompress = 0._summa_prec ! change in soil storage associated with compression of the matrix (kg m-2) ! initialize mean fluxes do iVar=1,size(averageFlux_meta) - flux_mean%var(iVar)%dat(:) = 0._dp + flux_mean%var(iVar)%dat(:) = 0._summa_prec end do ! associate local variables with information in the data structures @@ -354,7 +354,7 @@ subroutine coupled_em(& ! short-cut to the algorithmic control parameters ! NOTE - temporary assignment of minstep to foce something reasonable - minstep = 10._dp ! mpar_data%var(iLookPARAM%minstep)%dat(1) ! minimum time step (s) + minstep = 10._summa_prec ! mpar_data%var(iLookPARAM%minstep)%dat(1) ! minimum time step (s) maxstep = mpar_data%var(iLookPARAM%maxstep)%dat(1) ! maximum time step (s) !print*, 'minstep, maxstep = ', minstep, maxstep @@ -366,7 +366,7 @@ subroutine coupled_em(& end if ! define the foliage nitrogen factor - diag_data%var(iLookDIAG%scalarFoliageNitrogenFactor)%dat(1) = 1._dp ! foliage nitrogen concentration (1.0 = saturated) + diag_data%var(iLookDIAG%scalarFoliageNitrogenFactor)%dat(1) = 1._summa_prec ! foliage nitrogen concentration (1.0 = saturated) ! save SWE oldSWE = prog_data%var(iLookPROG%scalarSWE)%dat(1) @@ -377,7 +377,7 @@ subroutine coupled_em(& ! ------------------------ ! compute the temperature of the root zone: used in vegetation phenology - diag_data%var(iLookDIAG%scalarRootZoneTemp)%dat(1) = sum(prog_data%var(iLookPROG%mLayerTemp)%dat(nSnow+1:nSnow+nLayersRoots)) / real(nLayersRoots, kind(dp)) + diag_data%var(iLookDIAG%scalarRootZoneTemp)%dat(1) = sum(prog_data%var(iLookPROG%mLayerTemp)%dat(nSnow+1:nSnow+nLayersRoots)) / real(nLayersRoots, kind(summa_prec)) ! remember if we compute the vegetation flux on the previous sub-step computeVegFluxOld = computeVegFlux @@ -421,7 +421,7 @@ subroutine coupled_em(& ! NOTE 3: use maximum per unit leaf area storage capacity for snow (kg m-2) select case(model_decisions(iLookDECISIONS%snowIncept)%iDecision) case(lightSnow); diag_data%var(iLookDIAG%scalarCanopyIceMax)%dat(1) = exposedVAI*mpar_data%var(iLookPARAM%refInterceptCapSnow)%dat(1) - case(stickySnow); diag_data%var(iLookDIAG%scalarCanopyIceMax)%dat(1) = exposedVAI*mpar_data%var(iLookPARAM%refInterceptCapSnow)%dat(1)*4._dp + case(stickySnow); diag_data%var(iLookDIAG%scalarCanopyIceMax)%dat(1) = exposedVAI*mpar_data%var(iLookPARAM%refInterceptCapSnow)%dat(1)*4._summa_prec case default; message=trim(message)//'unable to identify option for maximum branch interception capacity'; err=20; return end select ! identifying option for maximum branch interception capacity !print*, 'diag_data%var(iLookDIAG%scalarCanopyLiqMax)%dat(1) = ', diag_data%var(iLookDIAG%scalarCanopyLiqMax)%dat(1) @@ -454,9 +454,9 @@ subroutine coupled_em(& ! vegetation is completely buried by snow (or no veg exists at all) else - diag_data%var(iLookDIAG%scalarCanopyWetFraction)%dat(1) = 0._dp - dCanopyWetFraction_dWat = 0._dp - dCanopyWetFraction_dT = 0._dp + diag_data%var(iLookDIAG%scalarCanopyWetFraction)%dat(1) = 0._summa_prec + dCanopyWetFraction_dWat = 0._summa_prec + dCanopyWetFraction_dT = 0._summa_prec end if ! *** compute snow albedo... @@ -533,10 +533,10 @@ subroutine coupled_em(& ! NOTE 2: this initialization needs to be done AFTER the call to canopySnow, since canopySnow uses canopy drip drom the previous time step if(.not.computeVegFlux)then flux_data%var(iLookFLUX%scalarThroughfallRain)%dat(1) = flux_data%var(iLookFLUX%scalarRainfall)%dat(1) - flux_data%var(iLookFLUX%scalarCanopyLiqDrainage)%dat(1) = 0._dp + flux_data%var(iLookFLUX%scalarCanopyLiqDrainage)%dat(1) = 0._summa_prec else - flux_data%var(iLookFLUX%scalarThroughfallRain)%dat(1) = 0._dp - flux_data%var(iLookFLUX%scalarCanopyLiqDrainage)%dat(1) = 0._dp + flux_data%var(iLookFLUX%scalarThroughfallRain)%dat(1) = 0._summa_prec + flux_data%var(iLookFLUX%scalarCanopyLiqDrainage)%dat(1) = 0._summa_prec end if ! **************************************************************************************************** @@ -544,7 +544,7 @@ subroutine coupled_em(& ! **************************************************************************************************** ! initialize the length of the sub-step - dt_solv = 0._dp ! length of time step that has been completed (s) + dt_solv = 0._summa_prec ! length of time step that has been completed (s) dt_init = min(data_step,maxstep) ! initial substep length (s) dt_sub = dt_init ! length of substep dtSave = dt_init ! length of substep @@ -762,7 +762,7 @@ subroutine coupled_em(& if(stepFailure)then ! halve step - dt_sub = dtSave/2._dp + dt_sub = dtSave/2._summa_prec ! check that the step is not tiny if(dt_sub < minstep)then @@ -804,13 +804,13 @@ subroutine coupled_em(& scalarCanopyIce = scalarCanopyIce + scalarCanopySublimation*dt_sub ! if removed all ice, take the remaining sublimation from water - if(scalarCanopyIce < 0._dp)then + if(scalarCanopyIce < 0._summa_prec)then scalarCanopyLiq = scalarCanopyLiq + scalarCanopyIce - scalarCanopyIce = 0._dp + scalarCanopyIce = 0._summa_prec endif ! modify fluxes if there is insufficient canopy water to support the converged sublimation rate over the time step dt_sub - if(scalarCanopyLiq < 0._dp)then + if(scalarCanopyLiq < 0._summa_prec)then ! --> superfluous sublimation flux superflousSub = -scalarCanopyLiq/dt_sub ! kg m-2 s-1 superflousNrg = superflousSub*LH_sub ! W m-2 (J m-2 s-1) @@ -818,7 +818,7 @@ subroutine coupled_em(& scalarCanopySublimation = scalarCanopySublimation + superflousSub scalarLatHeatCanopyEvap = scalarLatHeatCanopyEvap + superflousNrg scalarSenHeatCanopy = scalarSenHeatCanopy - superflousNrg - scalarCanopyLiq = 0._dp + scalarCanopyLiq = 0._summa_prec endif end if ! (if computing the vegetation flux) @@ -842,7 +842,7 @@ subroutine coupled_em(& if(mLayerDepth(iSnow) < verySmall)then stepFailure = .true. doLayerMerge = .true. - dt_sub = max(dtSave/2._dp, minstep) + dt_sub = max(dtSave/2._summa_prec, minstep) cycle substeps else stepFailure = .false. @@ -1060,7 +1060,7 @@ subroutine coupled_em(& ! NOTE: need to put the balance checks in the sub-step loop so that we can re-compute if necessary scalarCanopyWatBalError = balanceCanopyWater1 - (balanceCanopyWater0 + (scalarSnowfall - averageThroughfallSnow)*data_step + (scalarRainfall - averageThroughfallRain)*data_step & - averageCanopySnowUnloading*data_step - averageCanopyLiqDrainage*data_step + averageCanopySublimation*data_step + averageCanopyEvaporation*data_step) - if(abs(scalarCanopyWatBalError) > absConvTol_liquid*iden_water*10._dp)then + if(abs(scalarCanopyWatBalError) > absConvTol_liquid*iden_water*10._summa_prec)then print*, '** canopy water balance error:' write(*,'(a,1x,f20.10)') 'data_step = ', data_step write(*,'(a,1x,f20.10)') 'balanceCanopyWater0 = ', balanceCanopyWater0 @@ -1167,7 +1167,7 @@ subroutine coupled_em(& ! check the soil water balance scalarSoilWatBalError = balanceSoilWater1 - (balanceSoilWater0 + (balanceSoilInflux + balanceSoilET - balanceSoilBaseflow - balanceSoilDrainage - totalSoilCompress) ) - if(abs(scalarSoilWatBalError) > absConvTol_liquid*iden_water*10._dp)then ! NOTE: kg m-2, so need coarse tolerance to account for precision issues + if(abs(scalarSoilWatBalError) > absConvTol_liquid*iden_water*10._summa_prec)then ! NOTE: kg m-2, so need coarse tolerance to account for precision issues write(*,*) 'solution method = ', ixSolution write(*,'(a,1x,f20.10)') 'data_step = ', data_step write(*,'(a,1x,f20.10)') 'totalSoilCompress = ', totalSoilCompress @@ -1232,24 +1232,24 @@ subroutine implctMelt(& err,message ) ! intent(out): error control implicit none ! input/output: integrated snowpack properties - real(dp),intent(inout) :: scalarSWE ! snow water equivalent (kg m-2) - real(dp),intent(inout) :: scalarSnowDepth ! snow depth (m) - real(dp),intent(inout) :: scalarSfcMeltPond ! surface melt pond (kg m-2) + real(summa_prec),intent(inout) :: scalarSWE ! snow water equivalent (kg m-2) + real(summa_prec),intent(inout) :: scalarSnowDepth ! snow depth (m) + real(summa_prec),intent(inout) :: scalarSfcMeltPond ! surface melt pond (kg m-2) ! input/output: properties of the upper-most soil layer - real(dp),intent(inout) :: soilTemp ! surface layer temperature (K) - real(dp),intent(inout) :: soilDepth ! surface layer depth (m) - real(dp),intent(inout) :: soilHeatcap ! surface layer volumetric heat capacity (J m-3 K-1) + real(summa_prec),intent(inout) :: soilTemp ! surface layer temperature (K) + real(summa_prec),intent(inout) :: soilDepth ! surface layer depth (m) + real(summa_prec),intent(inout) :: soilHeatcap ! surface layer volumetric heat capacity (J m-3 K-1) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! local variables - real(dp) :: nrgRequired ! energy required to melt all the snow (J m-2) - real(dp) :: nrgAvailable ! energy available to melt the snow (J m-2) - real(dp) :: snwDensity ! snow density (kg m-3) + real(summa_prec) :: nrgRequired ! energy required to melt all the snow (J m-2) + real(summa_prec) :: nrgAvailable ! energy available to melt the snow (J m-2) + real(summa_prec) :: snwDensity ! snow density (kg m-3) ! initialize error control err=0; message='implctMelt/' - if(scalarSWE > 0._dp)then + if(scalarSWE > 0._summa_prec)then ! only melt if temperature of the top soil layer is greater than Tfreeze if(soilTemp > Tfreeze)then ! compute the energy required to melt all the snow (J m-2) @@ -1261,7 +1261,7 @@ subroutine implctMelt(& ! compute the amount of melt, and update SWE (kg m-2) if(nrgAvailable > nrgRequired)then scalarSfcMeltPond = scalarSWE - scalarSWE = 0._dp + scalarSWE = 0._summa_prec else scalarSfcMeltPond = nrgAvailable/LH_fus scalarSWE = scalarSWE - scalarSfcMeltPond @@ -1271,10 +1271,10 @@ subroutine implctMelt(& ! update temperature of the top soil layer (K) soilTemp = soilTemp - (LH_fus*scalarSfcMeltPond/soilDepth)/soilHeatcap else ! melt is zero if the temperature of the top soil layer is less than Tfreeze - scalarSfcMeltPond = 0._dp ! kg m-2 + scalarSfcMeltPond = 0._summa_prec ! kg m-2 end if ! (if the temperature of the top soil layer is greater than Tfreeze) else ! melt is zero if the "snow without a layer" does not exist - scalarSfcMeltPond = 0._dp ! kg m-2 + scalarSfcMeltPond = 0._summa_prec ! kg m-2 end if ! (if the "snow without a layer" exists) end subroutine implctMelt diff --git a/build/source/engine/derivforce.f90 b/build/source/engine/derivforce.f90 index 563d9f1f0..b607207dc 100755 --- a/build/source/engine/derivforce.f90 +++ b/build/source/engine/derivforce.f90 @@ -74,8 +74,8 @@ subroutine derivforce(time_data,forc_data,attr_data,mpar_data,prog_data,diag_dat implicit none ! input variables integer(i4b), intent(in) :: time_data(:) ! vector of time data for a given time step - real(dp), intent(inout) :: forc_data(:) ! vector of forcing data for a given time step - real(dp), intent(in) :: attr_data(:) ! vector of model attributes + real(summa_prec), intent(inout) :: forc_data(:) ! vector of forcing data for a given time step + real(summa_prec), intent(in) :: attr_data(:) ! vector of model attributes type(var_dlength),intent(in) :: mpar_data ! vector of model parameters type(var_dlength),intent(in) :: prog_data ! data structure of model prognostic variables for a local HRU ! output variables @@ -86,33 +86,33 @@ subroutine derivforce(time_data,forc_data,attr_data,mpar_data,prog_data,diag_dat ! local time integer(i4b) :: jyyy,jm,jd ! year, month, day integer(i4b) :: jh,jmin ! hour, minute - real(dp) :: dsec ! double precision seconds (not used) - real(dp) :: timeOffset ! time offset from Grenwich (days) - real(dp) :: julianTime ! local julian time + real(summa_prec) :: dsec ! double precision seconds (not used) + real(summa_prec) :: timeOffset ! time offset from Grenwich (days) + real(summa_prec) :: julianTime ! local julian time ! cosine of the solar zenith angle - real(dp) :: ahour ! hour at start of time step - real(dp) :: dataStep ! data step (hours) - real(dp),parameter :: slope=0._dp ! terrain slope (assume flat) - real(dp),parameter :: azimuth=0._dp ! terrain azimuth (assume zero) - real(dp) :: hri ! average radiation index over time step DT + real(summa_prec) :: ahour ! hour at start of time step + real(summa_prec) :: dataStep ! data step (hours) + real(summa_prec),parameter :: slope=0._summa_prec ! terrain slope (assume flat) + real(summa_prec),parameter :: azimuth=0._summa_prec ! terrain azimuth (assume zero) + real(summa_prec) :: hri ! average radiation index over time step DT ! general local variables character(len=256) :: cmessage ! error message for downwind routine integer(i4b),parameter :: nBands=2 ! number of spectral bands - real(dp),parameter :: valueMissing=-9999._dp ! missing value - real(dp),parameter :: co2Factor=355.e-6_dp ! empirical factor to obtain partial pressure of co2 - real(dp),parameter :: o2Factor=0.209_dp ! empirical factor to obtain partial pressure of o2 - real(dp),parameter :: minMeasHeight=1._dp ! minimum measurement height (m) - real(dp) :: relhum ! relative humidity (-) - real(dp) :: fracrain ! fraction of precipitation that falls as rain - real(dp) :: maxFrozenSnowTemp ! maximum temperature of snow when the snow is predominantely frozen (K) - real(dp),parameter :: unfrozenLiq=0.01_dp ! unfrozen liquid water used to compute maxFrozenSnowTemp (-) - real(dp),parameter :: eps=epsilon(fracrain) ! a number that is almost negligible - real(dp) :: Tmin,Tmax ! minimum and maximum wet bulb temperature in the time step (K) - real(dp),parameter :: pomNewSnowDenMax=150._dp ! Upper limit for new snow density limit in Hedstrom and Pomeroy 1998. 150 was used because at was the highest observed density at air temperatures used in this study. See Figure 4 of Hedstrom and Pomeroy (1998). - real(dp),parameter :: andersonWarmDenLimit=2._dp ! Upper air temperature limit in Anderson (1976) new snow density (C) - real(dp),parameter :: andersonColdDenLimit=15._dp! Lower air temperature limit in Anderson (1976) new snow density (C) - real(dp),parameter :: andersonDenScal=1.5_dp ! Scalar parameter in Anderson (1976) new snow density function (-) - real(dp),parameter :: pahautDenWindScal=0.5_dp ! Scalar parameter for wind impacts on density using Pahaut (1976) function (-) + real(summa_prec),parameter :: valueMissing=-9999._summa_prec ! missing value + real(summa_prec),parameter :: co2Factor=355.e-6_summa_prec ! empirical factor to obtain partial pressure of co2 + real(summa_prec),parameter :: o2Factor=0.209_summa_prec ! empirical factor to obtain partial pressure of o2 + real(summa_prec),parameter :: minMeasHeight=1._summa_prec ! minimum measurement height (m) + real(summa_prec) :: relhum ! relative humidity (-) + real(summa_prec) :: fracrain ! fraction of precipitation that falls as rain + real(summa_prec) :: maxFrozenSnowTemp ! maximum temperature of snow when the snow is predominantely frozen (K) + real(summa_prec),parameter :: unfrozenLiq=0.01_summa_prec ! unfrozen liquid water used to compute maxFrozenSnowTemp (-) + real(summa_prec),parameter :: eps=epsilon(fracrain) ! a number that is almost negligible + real(summa_prec) :: Tmin,Tmax ! minimum and maximum wet bulb temperature in the time step (K) + real(summa_prec),parameter :: pomNewSnowDenMax=150._summa_prec ! Upper limit for new snow density limit in Hedstrom and Pomeroy 1998. 150 was used because at was the highest observed density at air temperatures used in this study. See Figure 4 of Hedstrom and Pomeroy (1998). + real(summa_prec),parameter :: andersonWarmDenLimit=2._summa_prec ! Upper air temperature limit in Anderson (1976) new snow density (C) + real(summa_prec),parameter :: andersonColdDenLimit=15._summa_prec! Lower air temperature limit in Anderson (1976) new snow density (C) + real(summa_prec),parameter :: andersonDenScal=1.5_summa_prec ! Scalar parameter in Anderson (1976) new snow density function (-) + real(summa_prec),parameter :: pahautDenWindScal=0.5_summa_prec ! Scalar parameter for wind impacts on density using Pahaut (1976) function (-) ! ************************************************************************************************ ! associate local variables with the information in the data structures associate(& @@ -204,13 +204,13 @@ subroutine derivforce(time_data,forc_data,attr_data,mpar_data,prog_data,diag_dat select case(trim(NC_TIME_ZONE)) ! Time zone information from NetCDF file case('ncTime') - timeOffset = longitude/360._dp - tmZoneOffsetFracDay ! time offset in days + timeOffset = longitude/360._summa_prec - tmZoneOffsetFracDay ! time offset in days ! All times in UTC case('utcTime') - timeOffset = longitude/360._dp ! time offset in days + timeOffset = longitude/360._summa_prec ! time offset in days ! All times local case('localTime') - timeOffset = 0._dp ! time offset in days + timeOffset = 0._summa_prec ! time offset in days case default; message=trim(message)//'unable to identify option for tmZoneInfo'; err=20; return end select ! identifying option tmZoneInfo @@ -232,7 +232,7 @@ subroutine derivforce(time_data,forc_data,attr_data,mpar_data,prog_data,diag_dat ! compute the decimal hour at the start of the time step dataStep = data_step/secprhour ! time step (hours) - ahour = real(jh,kind(dp)) + real(jmin,kind(dp))/minprhour - data_step/secprhour ! decimal hour (start of the step) + ahour = real(jh,kind(summa_prec)) + real(jmin,kind(summa_prec))/minprhour - data_step/secprhour ! decimal hour (start of the step) ! compute the cosine of the solar zenith angle call clrsky_rad(jm,jd,ahour,dataStep, & ! intent(in): time variables @@ -241,19 +241,19 @@ subroutine derivforce(time_data,forc_data,attr_data,mpar_data,prog_data,diag_dat !write(*,'(a,1x,4(i2,1x),3(f9.3,1x))') 'im,id,ih,imin,ahour,dataStep,cosZenith = ', & ! ensure solar radiation is non-negative - if(SWRadAtm < 0._dp) SWRadAtm = 0._dp + if(SWRadAtm < 0._summa_prec) SWRadAtm = 0._summa_prec ! compute the fraction of direct radiation using the parameterization of Nijssen and Lettenmaier (1999) - if(cosZenith > 0._dp)then + if(cosZenith > 0._summa_prec)then scalarFractionDirect = Frad_direct*cosZenith/(cosZenith + directScale) else - scalarFractionDirect = 0._dp + scalarFractionDirect = 0._summa_prec end if ! compute direct shortwave radiation, in the visible and near-infra-red part of the spectrum spectralIncomingDirect(1) = SWRadAtm*scalarFractionDirect*Frad_vis ! (direct vis) - spectralIncomingDirect(2) = SWRadAtm*scalarFractionDirect*(1._dp - Frad_vis) ! (direct nir) + spectralIncomingDirect(2) = SWRadAtm*scalarFractionDirect*(1._summa_prec - Frad_vis) ! (direct nir) ! compute diffuse shortwave radiation, in the visible and near-infra-red part of the spectrum - spectralIncomingDiffuse(1) = SWRadAtm*(1._dp - scalarFractionDirect)*Frad_vis ! (diffuse vis) - spectralIncomingDiffuse(2) = SWRadAtm*(1._dp - scalarFractionDirect)*(1._dp - Frad_vis) ! (diffuse nir) + spectralIncomingDiffuse(1) = SWRadAtm*(1._summa_prec - scalarFractionDirect)*Frad_vis ! (diffuse vis) + spectralIncomingDiffuse(2) = SWRadAtm*(1._summa_prec - scalarFractionDirect)*(1._summa_prec - Frad_vis) ! (diffuse nir) ! ensure wind speed is above a prescribed minimum value if(windspd < minwind) windspd=minwind @@ -261,8 +261,8 @@ subroutine derivforce(time_data,forc_data,attr_data,mpar_data,prog_data,diag_dat ! compute relative humidity (-) relhum = SPHM2RELHM(spechum, airpres, airtemp) ! if relative humidity exceeds saturation, then set relative and specific humidity to saturation - if(relhum > 1._dp)then - relhum = 1._dp + if(relhum > 1._summa_prec)then + relhum = 1._summa_prec spechum = RELHM2SPHM(relhum, airpres, airtemp) end if @@ -277,17 +277,17 @@ subroutine derivforce(time_data,forc_data,attr_data,mpar_data,prog_data,diag_dat maxFrozenSnowTemp = templiquid(unfrozenLiq,fc_param) ! compute fraction of rain and temperature of fresh snow - Tmin = twetbulb - tempRangeTimestep/2._dp - Tmax = twetbulb + tempRangeTimestep/2._dp + Tmin = twetbulb - tempRangeTimestep/2._summa_prec + Tmax = twetbulb + tempRangeTimestep/2._summa_prec if(Tmax < tempCritRain)then - fracrain = 0._dp + fracrain = 0._summa_prec snowfallTemp = twetbulb elseif(Tmin > tempCritRain)then - fracrain = 1._dp + fracrain = 1._summa_prec snowfallTemp = maxFrozenSnowTemp else fracrain = (Tmax - tempCritRain)/(Tmax - Tmin) - snowfallTemp = 0.5_dp*(Tmin + maxFrozenSnowTemp) + snowfallTemp = 0.5_summa_prec*(Tmin + maxFrozenSnowTemp) end if !write(*,'(a,1x,10(f20.10,1x))') 'Tmin, twetbulb, tempRangeTimestep, tempCritRain = ', & ! Tmin, twetbulb, tempRangeTimestep, tempCritRain @@ -298,12 +298,12 @@ subroutine derivforce(time_data,forc_data,attr_data,mpar_data,prog_data,diag_dat ! ensure precipitation rate can be resolved by the data model if(pptrate 0.1_dp)then ! log10(0.1) = -1 - kerstenNum = log10(relativeSat) + 1._dp + if(relativeSat > 0.1_summa_prec)then ! log10(0.1) = -1 + kerstenNum = log10(relativeSat) + 1._summa_prec else - kerstenNum = 0._dp ! dry thermal conductivity + kerstenNum = 0._summa_prec ! dry thermal conductivity endif ! ...and, compute the thermal conductivity - mLayerThermalC(iLayer) = kerstenNum*lambda_wet + (1._dp - kerstenNum)*lambda_drysoil + mLayerThermalC(iLayer) = kerstenNum*lambda_wet + (1._summa_prec - kerstenNum)*lambda_drysoil ! ** mixture of constituents case(mixConstit) - mLayerThermalC(iLayer) = thCond_soil(iSoil) * ( 1._dp - theta_sat(iSoil) ) + & ! soil component + mLayerThermalC(iLayer) = thCond_soil(iSoil) * ( 1._summa_prec - theta_sat(iSoil) ) + & ! soil component lambda_ice * mLayerVolFracIce(iLayer) + & ! ice component lambda_water * mLayerVolFracLiq(iLayer) + & ! liquid water component lambda_air * mLayerVolFracAir(iLayer) ! air component ! ** test case for the mizoguchi lab experiment, Hansson et al. VZJ 2004 case(hanssonVZJ) - fArg = 1._dp + f1*mLayerVolFracIce(iLayer)**f2 + fArg = 1._summa_prec + f1*mLayerVolFracIce(iLayer)**f2 xArg = mLayerVolFracLiq(iLayer) + fArg*mLayerVolFracIce(iLayer) mLayerThermalC(iLayer) = c1 + c2*xArg + (c1 - c4)*exp(-(c3*xArg)**c5) @@ -315,7 +315,7 @@ subroutine diagn_evar(& ! special case of hansson if(ixThCondSoil==hanssonVZJ)then - iLayerThermalC(0) = 28._dp*(0.5_dp*(iLayerHeight(1) - iLayerHeight(0))) + iLayerThermalC(0) = 28._summa_prec*(0.5_summa_prec*(iLayerHeight(1) - iLayerHeight(0))) else iLayerThermalC(0) = mLayerThermalC(1) end if diff --git a/build/source/engine/eval8summa.f90 b/build/source/engine/eval8summa.f90 index bd13c2435..03c9fb904 100755 --- a/build/source/engine/eval8summa.f90 +++ b/build/source/engine/eval8summa.f90 @@ -153,7 +153,7 @@ subroutine eval8summa(& ! -------------------------------------------------------------------------------------------------------------------------------- ! -------------------------------------------------------------------------------------------------------------------------------- ! input: model control - real(dp),intent(in) :: dt ! length of the time step (seconds) + real(summa_prec),intent(in) :: dt ! length of the time step (seconds) integer(i4b),intent(in) :: nSnow ! number of snow layers integer(i4b),intent(in) :: nSoil ! number of soil layers integer(i4b),intent(in) :: nLayers ! total number of layers @@ -164,9 +164,9 @@ subroutine eval8summa(& logical(lgt),intent(in) :: computeVegFlux ! flag to indicate if computing fluxes over vegetation logical(lgt),intent(in) :: scalarSolution ! flag to denote if implementing the scalar solution ! input: state vectors - real(dp),intent(in) :: stateVecTrial(:) ! model state vector - real(dp),intent(in) :: fScale(:) ! function scaling vector - real(qp),intent(in) :: sMul(:) ! NOTE: qp ! state vector multiplier (used in the residual calculations) + real(summa_prec),intent(in) :: stateVecTrial(:) ! model state vector + real(summa_prec),intent(in) :: fScale(:) ! function scaling vector + real(summa_prec),intent(in) :: sMul(:) ! NOTE: qp ! state vector multiplier (used in the residual calculations) ! input: data structures type(model_options),intent(in) :: model_decisions(:) ! model decisions type(var_i), intent(in) :: type_data ! type of vegetation and soil @@ -182,13 +182,13 @@ subroutine eval8summa(& type(var_dlength),intent(inout) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables ! input-output: baseflow integer(i4b),intent(inout) :: ixSaturation ! index of the lowest saturated layer (NOTE: only computed on the first iteration) - real(dp),intent(out) :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) + real(summa_prec),intent(out) :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) ! output: flux and residual vectors logical(lgt),intent(out) :: feasible ! flag to denote the feasibility of the solution - real(dp),intent(out) :: fluxVec(:) ! flux vector - real(dp),intent(out) :: resSink(:) ! sink terms on the RHS of the flux equation - real(qp),intent(out) :: resVec(:) ! NOTE: qp ! residual vector - real(dp),intent(out) :: fEval ! function evaluation + real(summa_prec),intent(out) :: fluxVec(:) ! flux vector + real(summa_prec),intent(out) :: resSink(:) ! sink terms on the RHS of the flux equation + real(summa_prec),intent(out) :: resVec(:) ! NOTE: qp ! residual vector + real(summa_prec),intent(out) :: fEval ! function evaluation ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message @@ -196,29 +196,29 @@ subroutine eval8summa(& ! local variables ! -------------------------------------------------------------------------------------------------------------------------------- ! state variables - real(dp) :: scalarCanairTempTrial ! trial value for temperature of the canopy air space (K) - real(dp) :: scalarCanopyTempTrial ! trial value for temperature of the vegetation canopy (K) - real(dp) :: scalarCanopyWatTrial ! trial value for liquid water storage in the canopy (kg m-2) - real(dp),dimension(nLayers) :: mLayerTempTrial ! trial value for temperature of layers in the snow and soil domains (K) - real(dp),dimension(nLayers) :: mLayerVolFracWatTrial ! trial value for volumetric fraction of total water (-) - real(dp),dimension(nSoil) :: mLayerMatricHeadTrial ! trial value for total water matric potential (m) - real(dp),dimension(nSoil) :: mLayerMatricHeadLiqTrial ! trial value for liquid water matric potential (m) - real(dp) :: scalarAquiferStorageTrial ! trial value of storage of water in the aquifer (m) + real(summa_prec) :: scalarCanairTempTrial ! trial value for temperature of the canopy air space (K) + real(summa_prec) :: scalarCanopyTempTrial ! trial value for temperature of the vegetation canopy (K) + real(summa_prec) :: scalarCanopyWatTrial ! trial value for liquid water storage in the canopy (kg m-2) + real(summa_prec),dimension(nLayers) :: mLayerTempTrial ! trial value for temperature of layers in the snow and soil domains (K) + real(summa_prec),dimension(nLayers) :: mLayerVolFracWatTrial ! trial value for volumetric fraction of total water (-) + real(summa_prec),dimension(nSoil) :: mLayerMatricHeadTrial ! trial value for total water matric potential (m) + real(summa_prec),dimension(nSoil) :: mLayerMatricHeadLiqTrial ! trial value for liquid water matric potential (m) + real(summa_prec) :: scalarAquiferStorageTrial ! trial value of storage of water in the aquifer (m) ! diagnostic variables - real(dp) :: scalarCanopyLiqTrial ! trial value for mass of liquid water on the vegetation canopy (kg m-2) - real(dp) :: scalarCanopyIceTrial ! trial value for mass of ice on the vegetation canopy (kg m-2) - real(dp),dimension(nLayers) :: mLayerVolFracLiqTrial ! trial value for volumetric fraction of liquid water (-) - real(dp),dimension(nLayers) :: mLayerVolFracIceTrial ! trial value for volumetric fraction of ice (-) + real(summa_prec) :: scalarCanopyLiqTrial ! trial value for mass of liquid water on the vegetation canopy (kg m-2) + real(summa_prec) :: scalarCanopyIceTrial ! trial value for mass of ice on the vegetation canopy (kg m-2) + real(summa_prec),dimension(nLayers) :: mLayerVolFracLiqTrial ! trial value for volumetric fraction of liquid water (-) + real(summa_prec),dimension(nLayers) :: mLayerVolFracIceTrial ! trial value for volumetric fraction of ice (-) ! other local variables integer(i4b) :: iLayer ! index of model layer in the snow+soil domain integer(i4b) :: jState(1) ! index of model state for the scalar solution within the soil domain integer(i4b) :: ixBeg,ixEnd ! index of indices for the soil compression routine integer(i4b),parameter :: ixVegVolume=1 ! index of the desired vegetation control volumne (currently only one veg layer) - real(dp) :: xMin,xMax ! minimum and maximum values for water content - real(dp) :: scalarCanopyHydTrial ! trial value for mass of water on the vegetation canopy (kg m-2) - real(dp),parameter :: canopyTempMax=500._dp ! expected maximum value for the canopy temperature (K) - real(dp),dimension(nLayers) :: mLayerVolFracHydTrial ! trial value for volumetric fraction of water (-), general vector merged from Wat and Liq - real(dp),dimension(nState) :: rVecScaled ! scaled residual vector + real(summa_prec) :: xMin,xMax ! minimum and maximum values for water content + real(summa_prec) :: scalarCanopyHydTrial ! trial value for mass of water on the vegetation canopy (kg m-2) + real(summa_prec),parameter :: canopyTempMax=500._summa_prec ! expected maximum value for the canopy temperature (K) + real(summa_prec),dimension(nLayers) :: mLayerVolFracHydTrial ! trial value for volumetric fraction of water (-), general vector merged from Wat and Liq + real(summa_prec),dimension(nState) :: rVecScaled ! scaled residual vector character(LEN=256) :: cmessage ! error message of downwind routine ! -------------------------------------------------------------------------------------------------------------------------------- ! association to variables in the data structures @@ -281,7 +281,7 @@ subroutine eval8summa(& ! check canopy liquid water is not negative if(ixVegHyd/=integerMissing)then - if(stateVecTrial(ixVegHyd) < 0._dp) feasible=.false. + if(stateVecTrial(ixVegHyd) < 0._summa_prec) feasible=.false. end if ! check snow temperature is below freezing @@ -299,12 +299,12 @@ subroutine eval8summa(& if (layerType(iLayer) == iname_soil) then xMin = theta_sat(iLayer-nSnow) else - xMin = 0._dp + xMin = 0._summa_prec endif ! --> maximum select case( layerType(iLayer) ) - case(iname_snow); xMax = merge(iden_ice, 1._dp - mLayerVolFracIce(iLayer), ixHydType(iLayer)==iname_watLayer) + case(iname_snow); xMax = merge(iden_ice, 1._summa_prec - mLayerVolFracIce(iLayer), ixHydType(iLayer)==iname_watLayer) case(iname_soil); xMax = merge(theta_sat(iLayer-nSnow), theta_sat(iLayer-nSnow) - mLayerVolFracIce(iLayer), ixHydType(iLayer)==iname_watLayer) end select @@ -517,8 +517,8 @@ subroutine eval8summa(& if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! (check for errors) ! compute the function evaluation - rVecScaled = fScale(:)*real(resVec(:), dp) ! scale the residual vector (NOTE: residual vector is in quadruple precision) - fEval = 0.5_dp*dot_product(rVecScaled,rVecScaled) + rVecScaled = fScale(:)*real(resVec(:), summa_prec) ! scale the residual vector (NOTE: residual vector is in quadruple precision) + fEval = 0.5_summa_prec*dot_product(rVecScaled,rVecScaled) ! end association with the information in the data structures end associate diff --git a/build/source/engine/expIntegral.f90 b/build/source/engine/expIntegral.f90 index 8045e0f04..0eed6fa5f 100755 --- a/build/source/engine/expIntegral.f90 +++ b/build/source/engine/expIntegral.f90 @@ -11,32 +11,32 @@ module expIntegral_module ! From UEB-Veg ! Computes the exponential integral function for the given value FUNCTION EXPINT (LAI) - REAL(DP) LAI - REAL(DP) EXPINT - REAL(DP) a0,a1,a2,a3,a4,a5,b1,b2,b3,b4 - real(dp),parameter :: verySmall=tiny(1.0_dp) ! a very small number + real(summa_prec) LAI + real(summa_prec) EXPINT + real(summa_prec) a0,a1,a2,a3,a4,a5,b1,b2,b3,b4 + real(summa_prec),parameter :: verySmall=tiny(1.0_summa_prec) ! a very small number IF (LAI < verySmall)THEN - EXPINT=1._dp + EXPINT=1._summa_prec ELSEIF (LAI.LE.1.0) THEN - a0=-.57721566_dp - a1=.99999193_dp - a2=-.24991055_dp - a3=.05519968_dp - a4=-.00976004_dp - a5=.00107857_dp + a0=-.57721566_summa_prec + a1=.99999193_summa_prec + a2=-.24991055_summa_prec + a3=.05519968_summa_prec + a4=-.00976004_summa_prec + a5=.00107857_summa_prec EXPINT = a0+a1*LAI+a2*LAI**2+a3*LAI**3+a4*LAI**4+a5*LAI**5 - log(LAI) ELSE - a1=8.5733287401_dp - a2=18.0590169730_dp - a3=8.6347637343_dp - a4=.2677737343_dp - b1=9.5733223454_dp - b2=25.6329561486_dp - b3=21.0996530827_dp - b4=3.9584969228_dp + a1=8.5733287401_summa_prec + a2=18.0590169730_summa_prec + a3=8.6347637343_summa_prec + a4=.2677737343_summa_prec + b1=9.5733223454_summa_prec + b2=25.6329561486_summa_prec + b3=21.0996530827_summa_prec + b4=3.9584969228_summa_prec EXPINT=(LAI**4+a1*LAI**3+a2*LAI**2+a3*LAI+a4)/ & ((LAI**4+b1*LAI**3+b2*LAI**2+b3*LAI+b4)*LAI*exp(LAI)) diff --git a/build/source/engine/f2008funcs.f90 b/build/source/engine/f2008funcs.f90 index 3dfd1eeb8..97515c885 100755 --- a/build/source/engine/f2008funcs.f90 +++ b/build/source/engine/f2008funcs.f90 @@ -75,11 +75,11 @@ end function findIndex subroutine cloneStruc_rv(dataVec,lowerBound,source,mold,err,message) implicit none ! input-output: data vector for allocation/population - real(dp),intent(inout),allocatable :: dataVec(:) ! data vector + real(summa_prec),intent(inout),allocatable :: dataVec(:) ! data vector ! input integer(i4b),intent(in) :: lowerBound ! lower bound - real(dp),intent(in),optional :: source(lowerBound:) ! dataVec = shape of source + elements of source - real(dp),intent(in),optional :: mold(lowerBound:) ! dataVec = shape of mold + real(summa_prec),intent(in),optional :: source(lowerBound:) ! dataVec = shape of source + elements of source + real(summa_prec),intent(in),optional :: mold(lowerBound:) ! dataVec = shape of mold ! error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message diff --git a/build/source/engine/ffile_info.f90 b/build/source/engine/ffile_info.f90 index d7f3b8eb5..3f6d73252 100755 --- a/build/source/engine/ffile_info.f90 +++ b/build/source/engine/ffile_info.f90 @@ -74,7 +74,7 @@ subroutine ffile_info(nGRU,err,message) integer(i4b) :: nForcing ! number of forcing variables integer(i4b) :: iGRU,localHRU_ix ! index of GRU and HRU integer(8) :: ncHruId(1) ! hruID from the forcing files - real(dp) :: dataStep_iFile ! data step for a given forcing data file + real(summa_prec) :: dataStep_iFile ! data step for a given forcing data file logical(lgt) :: xist ! .TRUE. if the file exists ! Start procedure here diff --git a/build/source/engine/getVectorz.f90 b/build/source/engine/getVectorz.f90 index ba31b4bfa..5ebd36a54 100755 --- a/build/source/engine/getVectorz.f90 +++ b/build/source/engine/getVectorz.f90 @@ -97,7 +97,7 @@ module getVectorz_module public::varExtract ! common variables -real(dp),parameter :: valueMissing=-9999._dp ! missing value +real(summa_prec),parameter :: valueMissing=-9999._summa_prec ! missing value contains @@ -120,7 +120,7 @@ subroutine popStateVec(& type(var_dlength),intent(in) :: diag_data ! diagnostic variables for a local HRU type(var_ilength),intent(in) :: indx_data ! indices defining model states and layers ! output - real(dp),intent(out) :: stateVec(:) ! model state vector (mixed units) + real(summa_prec),intent(out) :: stateVec(:) ! model state vector (mixed units) integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! -------------------------------------------------------------------------------------------------------------------------------- @@ -266,10 +266,10 @@ subroutine getScaling(& type(var_dlength),intent(in) :: diag_data ! diagnostic variables for a local HRU type(var_ilength),intent(in) :: indx_data ! indices defining model states and layers ! output: state vectors - real(dp),intent(out) :: fScale(:) ! function scaling vector (mixed units) - real(dp),intent(out) :: xScale(:) ! variable scaling vector (mixed units) - real(qp),intent(out) :: sMul(:) ! NOTE: qp ! multiplier for state vector (used in the residual calculations) - real(dp),intent(out) :: dMat(:) ! diagonal of the Jacobian matrix (excludes fluxes) + real(summa_prec),intent(out) :: fScale(:) ! function scaling vector (mixed units) + real(summa_prec),intent(out) :: xScale(:) ! variable scaling vector (mixed units) + real(summa_prec),intent(out) :: sMul(:) ! NOTE: qp ! multiplier for state vector (used in the residual calculations) + real(summa_prec),intent(out) :: dMat(:) ! diagonal of the Jacobian matrix (excludes fluxes) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message @@ -277,12 +277,12 @@ subroutine getScaling(& ! local variables ! -------------------------------------------------------------------------------------------------------------------------------- ! scaling parameters - real(dp),parameter :: fScaleLiq=0.01_dp ! func eval: characteristic scale for volumetric liquid water content (-) - real(dp),parameter :: fScaleMat=10._dp ! func eval: characteristic scale for matric head (m) - real(dp),parameter :: fScaleNrg=1000000._dp ! func eval: characteristic scale for energy (J m-3) - real(dp),parameter :: xScaleLiq=0.1_dp ! state var: characteristic scale for volumetric liquid water content (-) - real(dp),parameter :: xScaleMat=10._dp ! state var: characteristic scale for matric head (m) - real(dp),parameter :: xScaleTemp=1._dp ! state var: characteristic scale for temperature (K) + real(summa_prec),parameter :: fScaleLiq=0.01_summa_prec ! func eval: characteristic scale for volumetric liquid water content (-) + real(summa_prec),parameter :: fScaleMat=10._summa_prec ! func eval: characteristic scale for matric head (m) + real(summa_prec),parameter :: fScaleNrg=1000000._summa_prec ! func eval: characteristic scale for energy (J m-3) + real(summa_prec),parameter :: xScaleLiq=0.1_summa_prec ! state var: characteristic scale for volumetric liquid water content (-) + real(summa_prec),parameter :: xScaleMat=10._summa_prec ! state var: characteristic scale for matric head (m) + real(summa_prec),parameter :: xScaleTemp=1._summa_prec ! state var: characteristic scale for temperature (K) ! state subsets integer(i4b) :: iLayer ! index of layer within the snow+soil domain integer(i4b) :: ixStateSubset ! index within the state subset @@ -320,32 +320,32 @@ subroutine getScaling(& ! define the function and variable scaling factors for energy where(ixStateType_subset==iname_nrgCanair .or. ixStateType_subset==iname_nrgCanopy .or. ixStateType_subset==iname_nrgLayer) - fScale = 1._dp / fScaleNrg ! 1/(J m-3) - xScale = 1._dp ! K + fScale = 1._summa_prec / fScaleNrg ! 1/(J m-3) + xScale = 1._summa_prec ! K endwhere ! define the function and variable scaling factors for water on the vegetation canopy where(ixStateType_subset==iname_watCanopy .or. ixStateType_subset==iname_liqCanopy) - fScale = 1._dp / (fScaleLiq*canopyDepth*iden_water) ! 1/(kg m-2) - xScale = 1._dp ! (kg m-2) + fScale = 1._summa_prec / (fScaleLiq*canopyDepth*iden_water) ! 1/(kg m-2) + xScale = 1._summa_prec ! (kg m-2) endwhere ! define the function and variable scaling factors for water in the snow+soil domain where(ixStateType_subset==iname_watLayer .or. ixStateType_subset==iname_liqLayer) - fScale = 1._dp / fScaleLiq ! (-) - xScale = 1._dp ! (-) + fScale = 1._summa_prec / fScaleLiq ! (-) + xScale = 1._summa_prec ! (-) end where ! define the function and variable scaling factors for water in the snow+soil domain where(ixStateType_subset==iname_matLayer .or. ixStateType_subset==iname_lmpLayer) - fScale = 1._dp / fScaleLiq ! (-) - xScale = 1._dp ! (m) + fScale = 1._summa_prec / fScaleLiq ! (-) + xScale = 1._summa_prec ! (m) end where ! define the function and variable scaling factors for water storage in the aquifer where(ixStateType_subset==iname_watAquifer) - fScale = 1._dp - xScale = 1._dp + fScale = 1._summa_prec + xScale = 1._summa_prec endwhere ! ----- @@ -357,8 +357,8 @@ subroutine getScaling(& where(ixStateType_subset==iname_nrgCanair) sMul = Cp_air*iden_air ! volumetric heat capacity of air (J m-3 K-1) where(ixStateType_subset==iname_nrgCanopy) sMul = volHeatCapVeg ! volumetric heat capacity of the vegetation (J m-3 K-1) - where(ixStateType_subset==iname_watCanopy) sMul = 1._dp ! nothing else on the left hand side - where(ixStateType_subset==iname_liqCanopy) sMul = 1._dp ! nothing else on the left hand side + where(ixStateType_subset==iname_watCanopy) sMul = 1._summa_prec ! nothing else on the left hand side + where(ixStateType_subset==iname_liqCanopy) sMul = 1._summa_prec ! nothing else on the left hand side ! compute terms in the Jacobian for vegetation (excluding fluxes) ! NOTE: This is computed outside the iteration loop because it does not depend on state variables @@ -366,8 +366,8 @@ subroutine getScaling(& ! NOTE: Use the "where" statement to generalize to multiple canopy layers (currently one canopy layer) where(ixStateType_subset==iname_nrgCanair) dMat = Cp_air*iden_air ! volumetric heat capacity of air (J m-3 K-1) where(ixStateType_subset==iname_nrgCanopy) dMat = realMissing ! populated within the iteration loop - where(ixStateType_subset==iname_watCanopy) dMat = 1._dp ! nothing else on the left hand side - where(ixStateType_subset==iname_liqCanopy) dMat = 1._dp ! nothing else on the left hand side + where(ixStateType_subset==iname_watCanopy) dMat = 1._summa_prec ! nothing else on the left hand side + where(ixStateType_subset==iname_liqCanopy) dMat = 1._summa_prec ! nothing else on the left hand side ! define the energy multiplier and diagonal elements for the state vector for residual calculations (snow-soil domain) if(nSnowSoilNrg>0)then @@ -382,15 +382,15 @@ subroutine getScaling(& if(nSnowSoilHyd>0)then do concurrent (iLayer=1:nLayers,ixSnowSoilHyd(iLayer)/=integerMissing) ! (loop through non-missing energy state variables in the snow+soil domain) ixStateSubset = ixSnowSoilHyd(iLayer) ! index within the state vector - sMul(ixStateSubset) = 1._dp ! state multiplier = 1 (nothing else on the left-hand-side) - dMat(ixStateSubset) = 1._dp ! diagonal element = 1 (nothing else on the left-hand-side) + sMul(ixStateSubset) = 1._summa_prec ! state multiplier = 1 (nothing else on the left-hand-side) + dMat(ixStateSubset) = 1._summa_prec ! diagonal element = 1 (nothing else on the left-hand-side) end do ! looping through non-missing energy state variables in the snow+soil domain endif ! define the scaling factor and diagonal elements for the aquifer where(ixStateType_subset==iname_watAquifer) - sMul = 1._dp - dMat = 1._dp + sMul = 1._summa_prec + dMat = 1._summa_prec endwhere ! ------------------------------------------------------------------------------------------ @@ -431,25 +431,25 @@ subroutine varExtract(& ! -------------------------------------------------------------------------------------------------------------------------------- implicit none ! input - real(dp),intent(in) :: stateVec(:) ! model state vector (mixed units) + real(summa_prec),intent(in) :: stateVec(:) ! model state vector (mixed units) type(var_dlength),intent(in) :: diag_data ! diagnostic variables for a local HRU type(var_dlength),intent(in) :: prog_data ! prognostic variables for a local HRU type(var_ilength),intent(in) :: indx_data ! indices defining model states and layers ! output: variables for the vegetation canopy - real(dp),intent(out) :: scalarCanairTempTrial ! trial value of canopy air temperature (K) - real(dp),intent(out) :: scalarCanopyTempTrial ! trial value of canopy temperature (K) - real(dp),intent(out) :: scalarCanopyWatTrial ! trial value of canopy total water (kg m-2) - real(dp),intent(out) :: scalarCanopyLiqTrial ! trial value of canopy liquid water (kg m-2) - real(dp),intent(out) :: scalarCanopyIceTrial ! trial value of canopy ice content (kg m-2) + real(summa_prec),intent(out) :: scalarCanairTempTrial ! trial value of canopy air temperature (K) + real(summa_prec),intent(out) :: scalarCanopyTempTrial ! trial value of canopy temperature (K) + real(summa_prec),intent(out) :: scalarCanopyWatTrial ! trial value of canopy total water (kg m-2) + real(summa_prec),intent(out) :: scalarCanopyLiqTrial ! trial value of canopy liquid water (kg m-2) + real(summa_prec),intent(out) :: scalarCanopyIceTrial ! trial value of canopy ice content (kg m-2) ! output: variables for the snow-soil domain - real(dp),intent(out) :: mLayerTempTrial(:) ! trial vector of layer temperature (K) - real(dp),intent(out) :: mLayerVolFracWatTrial(:) ! trial vector of volumetric total water content (-) - real(dp),intent(out) :: mLayerVolFracLiqTrial(:) ! trial vector of volumetric liquid water content (-) - real(dp),intent(out) :: mLayerVolFracIceTrial(:) ! trial vector of volumetric ice water content (-) - real(dp),intent(out) :: mLayerMatricHeadTrial(:) ! trial vector of total water matric potential (m) - real(dp),intent(out) :: mLayerMatricHeadLiqTrial(:) ! trial vector of liquid water matric potential (m) + real(summa_prec),intent(out) :: mLayerTempTrial(:) ! trial vector of layer temperature (K) + real(summa_prec),intent(out) :: mLayerVolFracWatTrial(:) ! trial vector of volumetric total water content (-) + real(summa_prec),intent(out) :: mLayerVolFracLiqTrial(:) ! trial vector of volumetric liquid water content (-) + real(summa_prec),intent(out) :: mLayerVolFracIceTrial(:) ! trial vector of volumetric ice water content (-) + real(summa_prec),intent(out) :: mLayerMatricHeadTrial(:) ! trial vector of total water matric potential (m) + real(summa_prec),intent(out) :: mLayerMatricHeadLiqTrial(:) ! trial vector of liquid water matric potential (m) ! output: variables for the aquifer - real(dp),intent(out) :: scalarAquiferStorageTrial ! trial value of storage of water in the aquifer (m) + real(summa_prec),intent(out) :: scalarAquiferStorageTrial ! trial value of storage of water in the aquifer (m) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message diff --git a/build/source/engine/groundwatr.f90 b/build/source/engine/groundwatr.f90 index 0e16b27ae..b9aea181c 100755 --- a/build/source/engine/groundwatr.f90 +++ b/build/source/engine/groundwatr.f90 @@ -47,9 +47,9 @@ module groundwatr_module ! privacy implicit none ! constant parameters -real(dp),parameter :: valueMissing=-9999._dp ! missing value parameter -real(dp),parameter :: verySmall=epsilon(1.0_dp) ! a very small number (used to avoid divide by zero) -real(dp),parameter :: dx=1.e-8_dp ! finite difference increment +real(summa_prec),parameter :: valueMissing=-9999._summa_prec ! missing value parameter +real(summa_prec),parameter :: verySmall=epsilon(1.0_summa_prec) ! a very small number (used to avoid divide by zero) +real(summa_prec),parameter :: dx=1.e-8_summa_prec ! finite difference increment private public::groundwatr contains @@ -120,10 +120,10 @@ subroutine groundwatr(& integer(i4b),intent(in) :: nLayers ! total number of layers logical(lgt),intent(in) :: getSatDepth ! logical flag to compute index of the lowest saturated layer ! input: state and diagnostic variables - real(dp),intent(in) :: mLayerdTheta_dPsi(:) ! derivative in the soil water characteristic w.r.t. matric head in each layer (m-1) - real(dp),intent(in) :: mLayerMatricHeadLiq(:) ! matric head in each layer at the current iteration (m) - real(dp),intent(in) :: mLayerVolFracLiq(:) ! volumetric fraction of liquid water (-) - real(dp),intent(in) :: mLayerVolFracIce(:) ! volumetric fraction of ice (-) + real(summa_prec),intent(in) :: mLayerdTheta_dPsi(:) ! derivative in the soil water characteristic w.r.t. matric head in each layer (m-1) + real(summa_prec),intent(in) :: mLayerMatricHeadLiq(:) ! matric head in each layer at the current iteration (m) + real(summa_prec),intent(in) :: mLayerVolFracLiq(:) ! volumetric fraction of liquid water (-) + real(summa_prec),intent(in) :: mLayerVolFracIce(:) ! volumetric fraction of ice (-) ! input/output: data structures type(var_d),intent(in) :: attr_data ! spatial attributes type(var_dlength),intent(in) :: mpar_data ! model parameters @@ -132,8 +132,8 @@ subroutine groundwatr(& type(var_dlength),intent(inout) :: flux_data ! model fluxes for a local HRU ! output: baseflow integer(i4b),intent(inout) :: ixSaturation ! index of lowest saturated layer (NOTE: only computed on the first iteration) - real(dp),intent(out) :: mLayerBaseflow(:) ! baseflow from each soil layer (m s-1) - real(dp),intent(out) :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) + real(summa_prec),intent(out) :: mLayerBaseflow(:) ! baseflow from each soil layer (m s-1) + real(summa_prec),intent(out) :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message @@ -142,13 +142,13 @@ subroutine groundwatr(& ! --------------------------------------------------------------------------------------- ! general local variables integer(i4b) :: iLayer ! index of soil layer - real(dp),dimension(nSoil,nSoil) :: dBaseflow_dVolLiq ! derivative in the baseflow flux w.r.t. volumetric liquid water content (m s-1) + real(summa_prec),dimension(nSoil,nSoil) :: dBaseflow_dVolLiq ! derivative in the baseflow flux w.r.t. volumetric liquid water content (m s-1) ! local variables to compute the numerical Jacobian logical(lgt),parameter :: doNumericalJacobian=.false. ! flag to compute the numerical Jacobian - real(dp),dimension(nSoil) :: mLayerMatricHeadPerturbed ! perturbed matric head (m) - real(dp),dimension(nSoil) :: mLayerVolFracLiqPerturbed ! perturbed volumetric fraction of liquid water (-) - real(dp),dimension(nSoil) :: mLayerBaseflowPerturbed ! perturbed baseflow (m s-1) - real(dp),dimension(nSoil,nSoil) :: nJac ! numerical Jacobian (s-1) + real(summa_prec),dimension(nSoil) :: mLayerMatricHeadPerturbed ! perturbed matric head (m) + real(summa_prec),dimension(nSoil) :: mLayerVolFracLiqPerturbed ! perturbed volumetric fraction of liquid water (-) + real(summa_prec),dimension(nSoil) :: mLayerBaseflowPerturbed ! perturbed baseflow (m s-1) + real(summa_prec),dimension(nSoil,nSoil) :: nJac ! numerical Jacobian (s-1) ! *************************************************************************************** ! *************************************************************************************** ! initialize error control @@ -189,10 +189,10 @@ subroutine groundwatr(& ! check for an early return (no layers are "active") if(ixSaturation > nSoil)then - scalarExfiltration = 0._dp ! exfiltration from the soil profile (m s-1) - mLayerColumnOutflow(:) = 0._dp ! column outflow from each soil layer (m3 s-1) - mLayerBaseflow(:) = 0._dp ! baseflow from each soil layer (m s-1) - dBaseflow_dMatric(:,:) = 0._dp ! derivative in baseflow w.r.t. matric head (s-1) + scalarExfiltration = 0._summa_prec ! exfiltration from the soil profile (m s-1) + mLayerColumnOutflow(:) = 0._summa_prec ! column outflow from each soil layer (m3 s-1) + mLayerBaseflow(:) = 0._summa_prec ! baseflow from each soil layer (m s-1) + dBaseflow_dMatric(:,:) = 0._summa_prec ! derivative in baseflow w.r.t. matric head (s-1) return end if ! if some layers are saturated @@ -222,7 +222,7 @@ subroutine groundwatr(& ! use the chain rule to compute the baseflow derivative w.r.t. matric head (s-1) do iLayer=1,nSoil dBaseflow_dMatric(1:iLayer,iLayer) = dBaseflow_dVolLiq(1:iLayer,iLayer)*mLayerdTheta_dPsi(iLayer) - if(iLayer1)then - zActive(1:ixSaturation-1) = 0._dp - trTotal(1:ixSaturation-1) = 0._dp - trSoil(1:ixSaturation-1) = 0._dp + zActive(1:ixSaturation-1) = 0._summa_prec + trTotal(1:ixSaturation-1) = 0._summa_prec + trSoil(1:ixSaturation-1) = 0._summa_prec end if ! compute the outflow from each layer (m3 s-1) @@ -444,26 +444,26 @@ subroutine computeBaseflow(& if(availStorage < xMinEval)then ! (compute the logistic function) expF = exp((availStorage - xCenter)/xWidth) - logF = 1._dp / (1._dp + expF) + logF = 1._summa_prec / (1._summa_prec + expF) ! (compute the derivative in the logistic function w.r.t. volumetric liquid water content in each soil layer) - dLogFunc_dLiq(1:nSoil) = mLayerDepth(1:nSoil)*(expF/xWidth)/(1._dp + expF)**2._dp + dLogFunc_dLiq(1:nSoil) = mLayerDepth(1:nSoil)*(expF/xWidth)/(1._summa_prec + expF)**2._summa_prec else - logF = 0._dp - dLogFunc_dLiq(:) = 0._dp + logF = 0._summa_prec + dLogFunc_dLiq(:) = 0._summa_prec end if ! compute the exfiltartion (m s-1) - if(totalColumnInflow > totalColumnOutflow .and. logF > tiny(1._dp))then + if(totalColumnInflow > totalColumnOutflow .and. logF > tiny(1._summa_prec))then scalarExfiltration = logF*(totalColumnInflow - totalColumnOutflow) ! m s-1 !write(*,'(a,1x,10(f30.20,1x))') 'scalarExfiltration = ', scalarExfiltration else - scalarExfiltration = 0._dp + scalarExfiltration = 0._summa_prec end if ! check !write(*,'(a,1x,10(f30.20,1x))') 'zActive(1), soilDepth, availStorage, logF, scalarExfiltration = ', & ! zActive(1), soilDepth, availStorage, logF, scalarExfiltration - !if(scalarExfiltration > tiny(1.0_dp)) pause 'exfiltrating' + !if(scalarExfiltration > tiny(1.0_summa_prec)) pause 'exfiltrating' ! compute the baseflow in each layer (m s-1) mLayerBaseflow(1:nSoil) = (mLayerColumnOutflow(1:nSoil) - mLayerColumnInflow(1:nSoil))/HRUarea @@ -494,7 +494,7 @@ subroutine computeBaseflow(& ! *********************************************************************************************************************** ! initialize the derivative matrix - dBaseflow_dVolLiq(:,:) = 0._dp + dBaseflow_dVolLiq(:,:) = 0._summa_prec ! check if derivatives are actually required if(.not.derivDesired) return @@ -506,7 +506,7 @@ subroutine computeBaseflow(& depth2capacity(1:nSoil) = mLayerDepth(1:nSoil)/sum( (theta_sat(1:nSoil) - fieldCapacity)*mLayerDepth(1:nSoil) ) ! compute the change in dimensionless flux w.r.t. change in dimensionless storage (-) - dXdS(1:nSoil) = zScale_TOPMODEL*(zActive(1:nSoil)/SoilDepth)**(zScale_TOPMODEL - 1._dp) + dXdS(1:nSoil) = zScale_TOPMODEL*(zActive(1:nSoil)/SoilDepth)**(zScale_TOPMODEL - 1._summa_prec) ! loop through soil layers do iLayer=1,nSoil @@ -519,7 +519,7 @@ subroutine computeBaseflow(& end do ! looping through soil layers ! compute the derivative in the exfiltration flux w.r.t. volumetric liquid water content (m s-1) - if(qbTotal < 0._dp)then + if(qbTotal < 0._summa_prec)then do iLayer=1,nSoil dExfiltrate_dVolLiq(iLayer) = dBaseflow_dVolLiq(iLayer,iLayer)*logF + dLogFunc_dLiq(iLayer)*qbTotal end do ! looping through soil layers diff --git a/build/source/engine/layerDivide.f90 b/build/source/engine/layerDivide.f90 index 6127fbf1e..a98404261 100755 --- a/build/source/engine/layerDivide.f90 +++ b/build/source/engine/layerDivide.f90 @@ -117,21 +117,21 @@ subroutine layerDivide(& integer(i4b) :: nLayers ! total number of layers integer(i4b) :: iLayer ! layer index integer(i4b) :: jLayer ! layer index - real(dp),dimension(4) :: zmax_lower ! lower value of maximum layer depth - real(dp),dimension(4) :: zmax_upper ! upper value of maximum layer depth - real(dp) :: zmaxCheck ! value of zmax for a given snow layer + real(summa_prec),dimension(4) :: zmax_lower ! lower value of maximum layer depth + real(summa_prec),dimension(4) :: zmax_upper ! upper value of maximum layer depth + real(summa_prec) :: zmaxCheck ! value of zmax for a given snow layer integer(i4b) :: nCheck ! number of layers to check to divide logical(lgt) :: createLayer ! flag to indicate we are creating a new snow layer - real(dp) :: depthOriginal ! original layer depth before sub-division (m) - real(dp),parameter :: fracTop=0.5_dp ! fraction of old layer used for the top layer - real(dp) :: surfaceLayerSoilTemp ! temperature of the top soil layer (K) - real(dp) :: maxFrozenSnowTemp ! maximum temperature when effectively all water is frozen (K) - real(dp),parameter :: unfrozenLiq=0.01_dp ! unfrozen liquid water used to compute maxFrozenSnowTemp (-) - real(dp) :: volFracWater ! volumetric fraction of total water, liquid and ice (-) - real(dp) :: fracLiq ! fraction of liquid water (-) + real(summa_prec) :: depthOriginal ! original layer depth before sub-division (m) + real(summa_prec),parameter :: fracTop=0.5_summa_prec ! fraction of old layer used for the top layer + real(summa_prec) :: surfaceLayerSoilTemp ! temperature of the top soil layer (K) + real(summa_prec) :: maxFrozenSnowTemp ! maximum temperature when effectively all water is frozen (K) + real(summa_prec),parameter :: unfrozenLiq=0.01_summa_prec ! unfrozen liquid water used to compute maxFrozenSnowTemp (-) + real(summa_prec) :: volFracWater ! volumetric fraction of total water, liquid and ice (-) + real(summa_prec) :: fracLiq ! fraction of liquid water (-) integer(i4b),parameter :: ixVisible=1 ! named variable to define index in array of visible part of the spectrum integer(i4b),parameter :: ixNearIR=2 ! named variable to define index in array of near IR part of the spectrum - real(dp),parameter :: verySmall=1.e-10_dp ! a very small number (used for error checking) + real(summa_prec),parameter :: verySmall=1.e-10_summa_prec ! a very small number (used for error checking) ! -------------------------------------------------------------------------------------------------------- ! initialize error control err=0; message="layerDivide/" @@ -224,7 +224,7 @@ subroutine layerDivide(& ! compute volumeteric fraction of liquid water and ice volFracWater = (scalarSWE/scalarSnowDepth)/iden_water ! volumetric fraction of total water (liquid and ice) - mLayerVolFracIce(1) = (1._dp - fracLiq)*volFracWater*(iden_water/iden_ice) ! volumetric fraction of ice (-) + mLayerVolFracIce(1) = (1._summa_prec - fracLiq)*volFracWater*(iden_water/iden_ice) ! volumetric fraction of ice (-) mLayerVolFracLiq(1) = fracLiq *volFracWater ! volumetric fraction of liquid water (-) ! end association with local variables to the information in the data structures) @@ -243,7 +243,7 @@ subroutine layerDivide(& prog_data%var(iLookPROG%spectralSnowAlbedoDiffuse)%dat(ixVisible) = mpar_data%var(iLookPARAM%albedoMaxVisible)%dat(1) prog_data%var(iLookPROG%spectralSnowAlbedoDiffuse)%dat(ixNearIR) = mpar_data%var(iLookPARAM%albedoMaxNearIR)%dat(1) prog_data%var(iLookPROG%scalarSnowAlbedo)%dat(1) = ( mpar_data%var(iLookPARAM%Frad_vis)%dat(1))*mpar_data%var(iLookPARAM%albedoMaxVisible)%dat(1) + & - (1._dp - mpar_data%var(iLookPARAM%Frad_vis)%dat(1))*mpar_data%var(iLookPARAM%albedoMaxNearIR)%dat(1) + (1._summa_prec - mpar_data%var(iLookPARAM%Frad_vis)%dat(1))*mpar_data%var(iLookPARAM%albedoMaxNearIR)%dat(1) case default; err=20; message=trim(message)//'unable to identify option for snow albedo'; return end select ! identify option for snow albedo ! set direct albedo to diffuse albedo @@ -299,7 +299,7 @@ subroutine layerDivide(& layerSplit: associate(mLayerDepth => prog_data%var(iLookPROG%mLayerDepth)%dat) depthOriginal = mLayerDepth(iLayer) mLayerDepth(iLayer) = fracTop*depthOriginal - mLayerDepth(iLayer+1) = (1._dp - fracTop)*depthOriginal + mLayerDepth(iLayer+1) = (1._summa_prec - fracTop)*depthOriginal end associate layerSplit exit ! NOTE: only sub-divide one layer per substep @@ -337,7 +337,7 @@ subroutine layerDivide(& iLayerHeight(0) = -scalarSnowDepth do jLayer=1,nLayers iLayerHeight(jLayer) = iLayerHeight(jLayer-1) + mLayerDepth(jLayer) - mLayerHeight(jLayer) = (iLayerHeight(jLayer-1) + iLayerHeight(jLayer))/2._dp + mLayerHeight(jLayer) = (iLayerHeight(jLayer-1) + iLayerHeight(jLayer))/2._summa_prec end do ! check @@ -387,7 +387,7 @@ subroutine addModelLayer(dataStruct,metaStruct,ix_divide,nSnow,nLayers,err,messa integer(i4b) :: ix_lower ! lower bound of the vector integer(i4b) :: ix_upper ! upper bound of the vector logical(lgt) :: stateVariable ! .true. if variable is a state variable - real(dp),allocatable :: tempVec_dp(:) ! temporary vector (double precision) + real(summa_prec),allocatable :: tempVec_summa_prec(:) ! temporary vector (double precision) integer(i4b),allocatable :: tempVec_i4b(:) ! temporary vector (integer) character(LEN=256) :: cmessage ! error message of downwind routine ! --------------------------------------------------------------------------------------------- @@ -420,7 +420,7 @@ subroutine addModelLayer(dataStruct,metaStruct,ix_divide,nSnow,nLayers,err,messa ! check allocated if(.not.allocated(dataStruct%var(ivar)%dat))then; err=20; message='data vector is not allocated'; return; end if ! assign the data vector to the temporary vector - call cloneStruc(tempVec_dp, ix_lower, source=dataStruct%var(ivar)%dat, err=err, message=cmessage) + call cloneStruc(tempVec_summa_prec, ix_lower, source=dataStruct%var(ivar)%dat, err=err, message=cmessage) if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! reallocate space for the new vector deallocate(dataStruct%var(ivar)%dat,stat=err) @@ -431,18 +431,18 @@ subroutine addModelLayer(dataStruct,metaStruct,ix_divide,nSnow,nLayers,err,messa if(stateVariable)then if(ix_upper > 0)then ! (only copy data if the vector exists -- can be a variable for snow, with no layers) if(ix_divide > 0)then - dataStruct%var(ivar)%dat(1:ix_divide) = tempVec_dp(1:ix_divide) ! copy data - dataStruct%var(ivar)%dat(ix_divide+1) = tempVec_dp(ix_divide) ! repeat data for the sub-divided layer + dataStruct%var(ivar)%dat(1:ix_divide) = tempVec_summa_prec(1:ix_divide) ! copy data + dataStruct%var(ivar)%dat(ix_divide+1) = tempVec_summa_prec(ix_divide) ! repeat data for the sub-divided layer end if if(ix_upper > ix_divide) & - dataStruct%var(ivar)%dat(ix_divide+2:ix_upper+1) = tempVec_dp(ix_divide+1:ix_upper) ! copy data + dataStruct%var(ivar)%dat(ix_divide+2:ix_upper+1) = tempVec_summa_prec(ix_divide+1:ix_upper) ! copy data end if ! if the vector exists ! not a state variable else dataStruct%var(ivar)%dat(:) = realMissing end if ! deallocate the temporary vector: strictly not necessary, but include to be safe - deallocate(tempVec_dp,stat=err) + deallocate(tempVec_summa_prec,stat=err) if(err/=0)then; err=20; message='problem deallocating temporary data vector'; return; end if ! ** integer diff --git a/build/source/engine/layerMerge.f90 b/build/source/engine/layerMerge.f90 index 6169755dd..c33af1061 100755 --- a/build/source/engine/layerMerge.f90 +++ b/build/source/engine/layerMerge.f90 @@ -100,7 +100,7 @@ subroutine layerMerge(& ! -------------------------------------------------------------------------------------------------------- ! define local variables character(LEN=256) :: cmessage ! error message of downwind routine - real(dp),dimension(5) :: zminLayer ! minimum layer depth in each layer (m) + real(summa_prec),dimension(5) :: zminLayer ! minimum layer depth in each layer (m) logical(lgt) :: removeLayer ! flag to indicate need to remove a layer integer(i4b) :: nCheck ! number of layers to check for combination integer(i4b) :: iSnow ! index of snow layers (looping) @@ -316,18 +316,18 @@ subroutine layer_combine(mpar_data,prog_data,diag_data,flux_data,indx_data,iSnow ! ------------------------------------------------------------------------------------------------------------ ! local variables character(len=256) :: cmessage ! error message for downwind routine - real(dp) :: massIce(2) ! mass of ice in the two layers identified for combination (kg m-2) - real(dp) :: massLiq(2) ! mass of liquid water in the two layers identified for combination (kg m-2) - real(dp) :: bulkDenWat(2) ! bulk density if total water (liquid water plus ice) in the two layers identified for combination (kg m-3) - real(dp) :: cBulkDenWat ! combined bulk density of total water (liquid water plus ice) in the two layers identified for combination (kg m-3) - real(dp) :: cTemp ! combined layer temperature - real(dp) :: cDepth ! combined layer depth - real(dp) :: cVolFracIce ! combined layer volumetric fraction of ice - real(dp) :: cVolFracLiq ! combined layer volumetric fraction of liquid water - real(dp) :: l1Enthalpy,l2Enthalpy ! enthalpy in the two layers identified for combination (J m-3) - real(dp) :: cEnthalpy ! combined layer enthalpy (J m-3) - real(dp) :: fLiq ! fraction of liquid water at the combined temperature cTemp - real(dp),parameter :: eTol=1.e-1_dp ! tolerance for the enthalpy-->temperature conversion (J m-3) + real(summa_prec) :: massIce(2) ! mass of ice in the two layers identified for combination (kg m-2) + real(summa_prec) :: massLiq(2) ! mass of liquid water in the two layers identified for combination (kg m-2) + real(summa_prec) :: bulkDenWat(2) ! bulk density if total water (liquid water plus ice) in the two layers identified for combination (kg m-3) + real(summa_prec) :: cBulkDenWat ! combined bulk density of total water (liquid water plus ice) in the two layers identified for combination (kg m-3) + real(summa_prec) :: cTemp ! combined layer temperature + real(summa_prec) :: cDepth ! combined layer depth + real(summa_prec) :: cVolFracIce ! combined layer volumetric fraction of ice + real(summa_prec) :: cVolFracLiq ! combined layer volumetric fraction of liquid water + real(summa_prec) :: l1Enthalpy,l2Enthalpy ! enthalpy in the two layers identified for combination (J m-3) + real(summa_prec) :: cEnthalpy ! combined layer enthalpy (J m-3) + real(summa_prec) :: fLiq ! fraction of liquid water at the combined temperature cTemp + real(summa_prec),parameter :: eTol=1.e-1_summa_prec ! tolerance for the enthalpy-->temperature conversion (J m-3) integer(i4b) :: nSnow ! number of snow layers integer(i4b) :: nSoil ! number of soil layers integer(i4b) :: nLayers ! total number of layers @@ -390,7 +390,7 @@ subroutine layer_combine(mpar_data,prog_data,diag_data,flux_data,indx_data,iSnow ! compute volumetric fraction of ice and liquid water cVolFracLiq = fLiq *cBulkDenWat/iden_water - cVolFracIce = (1._dp - fLiq)*cBulkDenWat/iden_ice + cVolFracIce = (1._summa_prec - fLiq)*cBulkDenWat/iden_ice ! end association of local variables with information in the data structures end associate @@ -459,7 +459,7 @@ subroutine rmLyAllVars(dataStruct,metaStruct,iSnow,nSnow,nLayers,err,message) integer(i4b) :: ivar ! variable index integer(i4b) :: ix_lower ! lower bound of the vector integer(i4b) :: ix_upper ! upper bound of the vector - real(dp),allocatable :: tempVec_dp(:) ! temporary vector (double precision) + real(summa_prec),allocatable :: tempVec_summa_prec(:) ! temporary vector (double precision) integer(i4b),allocatable :: tempVec_i4b(:) ! temporary vector (integer) character(LEN=256) :: cmessage ! error message of downwind routine ! initialize error control @@ -493,20 +493,20 @@ subroutine rmLyAllVars(dataStruct,metaStruct,iSnow,nSnow,nLayers,err,message) ! check allocated if(.not.allocated(dataStruct%var(ivar)%dat))then; err=20; message='data vector is not allocated'; return; end if ! allocate the temporary vector - allocate(tempVec_dp(ix_lower:ix_upper-1), stat=err) + allocate(tempVec_summa_prec(ix_lower:ix_upper-1), stat=err) if(err/=0)then; err=20; message=trim(message)//'unable to allocate temporary vector'; return; end if ! copy elements across to the temporary vector - if(iSnow>=ix_lower) tempVec_dp(iSnow) = realMissing ! set merged layer to missing (fill in later) - if(iSnow>ix_lower) tempVec_dp(ix_lower:iSnow-1) = dataStruct%var(ivar)%dat(ix_lower:iSnow-1) - if(iSnow+1=ix_lower) tempVec_summa_prec(iSnow) = realMissing ! set merged layer to missing (fill in later) + if(iSnow>ix_lower) tempVec_summa_prec(ix_lower:iSnow-1) = dataStruct%var(ivar)%dat(ix_lower:iSnow-1) + if(iSnow+11)then - do k=2,n - arth_r(k) = arth_r(k-1) + increment - end do - end if - END FUNCTION arth_r + !FUNCTION arth_r(first,increment,n) + !implicit none + !REAL(SP), INTENT(IN) :: first,increment + !INTEGER(I4B), INTENT(IN) :: n + !REAL(SP), DIMENSION(n) :: arth_r + !INTEGER(I4B) :: k + !arth_r(1)=first + !if(n>1)then + ! do k=2,n + ! arth_r(k) = arth_r(k-1) + increment + ! end do + !end if + !END FUNCTION arth_r ! ------------------------------------------------------------------------------------------------ FUNCTION arth_d(first,increment,n) implicit none - REAL(DP), INTENT(IN) :: first,increment + real(summa_prec), INTENT(IN) :: first,increment INTEGER(I4B), INTENT(IN) :: n - REAL(DP), DIMENSION(n) :: arth_d + real(summa_prec), DIMENSION(n) :: arth_d INTEGER(I4B) :: k arth_d(1)=first if(n>1)then @@ -62,11 +62,11 @@ END FUNCTION arth_i SUBROUTINE indexx(arr,index) IMPLICIT NONE !INTEGER(I4B), DIMENSION(:), INTENT(IN) :: arr - REAL(DP), DIMENSION(:), INTENT(IN) :: arr + real(summa_prec), DIMENSION(:), INTENT(IN) :: arr INTEGER(I4B), DIMENSION(:), INTENT(OUT) :: index INTEGER(I4B), PARAMETER :: NN=15, NSTACK=50 !INTEGER(I4B) :: a - REAL(DP) :: a + real(summa_prec) :: a INTEGER(I4B) :: n,k,i,j,indext,jstack,l,r INTEGER(I4B), DIMENSION(NSTACK) :: istack n=size(arr) diff --git a/build/source/engine/nrtype.f90 b/build/source/engine/nrtype.f90 index 3e1c3de34..32d89deb2 100755 --- a/build/source/engine/nrtype.f90 +++ b/build/source/engine/nrtype.f90 @@ -8,6 +8,7 @@ MODULE nrtype INTEGER, PARAMETER :: SP = KIND(1.0) INTEGER, PARAMETER :: DP = KIND(1.0D0) INTEGER, PARAMETER :: QP = KIND(1.0D0) + INTEGER, PARAMETER :: SUMMA_PREC = SP !INTEGER, PARAMETER :: QP = SELECTED_REAL_KIND(32) INTEGER, PARAMETER :: SPC = KIND((1.0,1.0)) INTEGER, PARAMETER :: DPC = KIND((1.0D0,1.0D0)) @@ -18,11 +19,11 @@ MODULE nrtype REAL(SP), PARAMETER :: TWOPI=6.283185307179586476925286766559005768394_sp REAL(SP), PARAMETER :: SQRT2=1.41421356237309504880168872420969807856967_sp REAL(SP), PARAMETER :: EULER=0.5772156649015328606065120900824024310422_sp - REAL(DP), PARAMETER :: PI_D=3.141592653589793238462643383279502884197_dp - REAL(DP), PARAMETER :: PIO2_D=1.57079632679489661923132169163975144209858_dp - REAL(DP), PARAMETER :: TWOPI_D=6.283185307179586476925286766559005768394_dp + real(summa_prec), PARAMETER :: PI_D=3.141592653589793238462643383279502884197_summa_prec + real(summa_prec), PARAMETER :: PIO2_D=1.57079632679489661923132169163975144209858_summa_prec + real(summa_prec), PARAMETER :: TWOPI_D=6.283185307179586476925286766559005768394_summa_prec ! missing values - real(qp), parameter :: nr_quadMissing=-9999._qp ! missing quadruple precision number - real(dp), parameter :: nr_realMissing=-9999._dp ! missing double precision number + real(summa_prec), parameter :: nr_quadMissing=-9999._qp ! missing quadruple precision number + real(summa_prec), parameter :: nr_realMissing=-9999._summa_prec ! missing double precision number integer(i4b), parameter :: nr_integerMissing=-9999 ! missing integer END MODULE nrtype diff --git a/build/source/engine/opSplittin.f90 b/build/source/engine/opSplittin.f90 index 3020ae20f..474d5be68 100755 --- a/build/source/engine/opSplittin.f90 +++ b/build/source/engine/opSplittin.f90 @@ -147,10 +147,10 @@ module opSplittin_module integer(i4b),parameter :: nDomains=4 ! number of domains (vegetation, snow, soil, and aquifer) ! control parameters -real(dp),parameter :: valueMissing=-9999._dp ! missing value -real(dp),parameter :: verySmall=1.e-12_dp ! a very small number (used to check consistency) -real(dp),parameter :: veryBig=1.e+20_dp ! a very big number -real(dp),parameter :: dx = 1.e-8_dp ! finite difference increment +real(summa_prec),parameter :: valueMissing=-9999._summa_prec ! missing value +real(summa_prec),parameter :: verySmall=1.e-12_summa_prec ! a very small number (used to check consistency) +real(summa_prec),parameter :: veryBig=1.e+20_summa_prec ! a very big number +real(summa_prec),parameter :: dx = 1.e-8_summa_prec ! finite difference increment contains @@ -210,7 +210,7 @@ subroutine opSplittin(& integer(i4b),intent(in) :: nSoil ! number of soil layers integer(i4b),intent(in) :: nLayers ! total number of layers integer(i4b),intent(in) :: nState ! total number of state variables - real(dp),intent(inout) :: dt ! time step (seconds) + real(summa_prec),intent(inout) :: dt ! time step (seconds) logical(lgt),intent(in) :: firstSubStep ! flag to indicate if we are processing the first sub-step logical(lgt),intent(in) :: computeVegFlux ! flag to indicate if we are computing fluxes over vegetation (.false. means veg is buried with snow) ! input/output: data structures @@ -225,7 +225,7 @@ subroutine opSplittin(& type(var_dlength),intent(in) :: bvar_data ! model variables for the local basin type(model_options),intent(in) :: model_decisions(:) ! model decisions ! output: model control - real(dp),intent(out) :: dtMultiplier ! substep multiplier (-) + real(summa_prec),intent(out) :: dtMultiplier ! substep multiplier (-) logical(lgt),intent(out) :: tooMuchMelt ! flag to denote that ice is insufficient to support melt logical(lgt),intent(out) :: stepFailure ! flag to denote step failure integer(i4b),intent(out) :: err ! error code @@ -249,19 +249,19 @@ subroutine opSplittin(& type(var_dlength) :: diag_temp ! temporary model diagnostic variables type(var_dlength) :: flux_temp ! temporary model fluxes type(var_dlength) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables - real(dp),dimension(nLayers) :: mLayerVolFracIceInit ! initial vector for volumetric fraction of ice (-) + real(summa_prec),dimension(nLayers) :: mLayerVolFracIceInit ! initial vector for volumetric fraction of ice (-) ! ------------------------------------------------------------------------------------------------------ ! * operator splitting ! ------------------------------------------------------------------------------------------------------ ! minimum timestep - real(dp),parameter :: dtmin_coupled=1800._dp ! minimum time step for the fully coupled solution (seconds) - real(dp),parameter :: dtmin_split=60._dp ! minimum time step for the fully split solution (seconds) - real(dp),parameter :: dtmin_scalar=10._dp ! minimum time step for the scalar solution (seconds) - real(dp) :: dt_min ! minimum time step (seconds) - real(dp) :: dtInit ! initial time step (seconds) + real(summa_prec),parameter :: dtmin_coupled=1800._summa_prec ! minimum time step for the fully coupled solution (seconds) + real(summa_prec),parameter :: dtmin_split=60._summa_prec ! minimum time step for the fully split solution (seconds) + real(summa_prec),parameter :: dtmin_scalar=10._summa_prec ! minimum time step for the scalar solution (seconds) + real(summa_prec) :: dt_min ! minimum time step (seconds) + real(summa_prec) :: dtInit ! initial time step (seconds) ! explicit error tolerance (depends on state type split, so defined here) - real(dp),parameter :: errorTolLiqFlux=0.01_dp ! error tolerance in the explicit solution (liquid flux) - real(dp),parameter :: errorTolNrgFlux=10._dp ! error tolerance in the explicit solution (energy flux) + real(summa_prec),parameter :: errorTolLiqFlux=0.01_summa_prec ! error tolerance in the explicit solution (liquid flux) + real(summa_prec),parameter :: errorTolNrgFlux=10._summa_prec ! error tolerance in the explicit solution (energy flux) ! number of substeps taken for a given split integer(i4b) :: nSubsteps ! number of substeps taken for a given split ! named variables defining the coupling and solution method @@ -443,12 +443,12 @@ subroutine opSplittin(& do iVar=1,size(flux_meta) ! loop through fluxes if(flux2state_orig(iVar)%state1==integerMissing .and. flux2state_orig(iVar)%state2==integerMissing) cycle ! flux does not depend on state (e.g., input) if(flux2state_orig(iVar)%state1==iname_watCanopy .and. .not.computeVegFlux) cycle ! use input fluxes in cases where there is no canopy - flux_data%var(iVar)%dat(:) = 0._dp + flux_data%var(iVar)%dat(:) = 0._summa_prec end do ! initialize derivatives do iVar=1,size(deriv_meta) - deriv_data%var(iVar)%dat(:) = 0._dp + deriv_data%var(iVar)%dat(:) = 0._summa_prec end do ! ========================================================================================================================================== @@ -978,7 +978,7 @@ subroutine opSplittin(& end do ! use step halving if unable to complete the fully coupled solution in one substep - if(ixCoupling/=fullyCoupled .or. nSubsteps>1) dtMultiplier=0.5_dp + if(ixCoupling/=fullyCoupled .or. nSubsteps>1) dtMultiplier=0.5_summa_prec ! compute the melt in each snow and soil layer if(nSnow>0) mLayerMeltFreeze( 1:nSnow ) = -(mLayerVolFracIce( 1:nSnow ) - mLayerVolFracIceInit( 1:nSnow ))*iden_ice diff --git a/build/source/engine/pOverwrite.f90 b/build/source/engine/pOverwrite.f90 index d90b5bdd5..f522c5129 100755 --- a/build/source/engine/pOverwrite.f90 +++ b/build/source/engine/pOverwrite.f90 @@ -51,7 +51,7 @@ subroutine pOverwrite(ixVeg,ixSoil,defaultParam,err,message) integer(i4b),intent(in) :: ixVeg ! vegetation category integer(i4b),intent(in) :: ixSoil ! soil category ! define output - real(dp),intent(inout) :: defaultParam(:) ! default model parameters + real(summa_prec),intent(inout) :: defaultParam(:) ! default model parameters integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! Start procedure here diff --git a/build/source/engine/paramCheck.f90 b/build/source/engine/paramCheck.f90 index 8ca2fecef..f34b0a32e 100755 --- a/build/source/engine/paramCheck.f90 +++ b/build/source/engine/paramCheck.f90 @@ -49,9 +49,9 @@ subroutine paramCheck(mpar_data,err,message) character(*),intent(out) :: message ! error message ! local variables integer(i4b) :: iLayer ! index of model layers - real(dp),dimension(5) :: zminLayer ! minimum layer depth in each layer (m) - real(dp),dimension(4) :: zmaxLayer_lower ! lower value of maximum layer depth - real(dp),dimension(4) :: zmaxLayer_upper ! upper value of maximum layer depth + real(summa_prec),dimension(5) :: zminLayer ! minimum layer depth in each layer (m) + real(summa_prec),dimension(4) :: zmaxLayer_lower ! lower value of maximum layer depth + real(summa_prec),dimension(4) :: zmaxLayer_upper ! upper value of maximum layer depth ! Start procedure here err=0; message="paramCheck/" @@ -63,7 +63,7 @@ subroutine paramCheck(mpar_data,err,message) select case(model_decisions(iLookDECISIONS%snowLayers)%iDecision) ! SNTHERM option case(sameRulesAllLayers) - if(mpar_data%var(iLookPARAM%zmax)%dat(1)/mpar_data%var(iLookPARAM%zmin)%dat(1) < 2.5_dp)then + if(mpar_data%var(iLookPARAM%zmax)%dat(1)/mpar_data%var(iLookPARAM%zmin)%dat(1) < 2.5_summa_prec)then message=trim(message)//'zmax must be at least 2.5 times larger than zmin: this avoids merging layers that have just been divided' err=20; return end if @@ -93,7 +93,7 @@ subroutine paramCheck(mpar_data,err,message) err=20; return end if ! ensure that the maximum thickness is 3 times greater than the minimum thickness - if(zmaxLayer_upper(iLayer)/zminLayer(iLayer) < 2.5_dp .or. zmaxLayer_upper(iLayer)/zminLayer(iLayer+1) < 2.5_dp)then + if(zmaxLayer_upper(iLayer)/zminLayer(iLayer) < 2.5_summa_prec .or. zmaxLayer_upper(iLayer)/zminLayer(iLayer+1) < 2.5_summa_prec)then write(*,'(a,1x,3(f20.10,1x))') 'zmaxLayer_upper(iLayer), zminLayer(iLayer), zminLayer(iLayer+1) = ', & zmaxLayer_upper(iLayer), zminLayer(iLayer), zminLayer(iLayer+1) write(message,'(a,3(i0,a))') trim(message)//'zmaxLayer_upper for layer ',iLayer,' must be 2.5 times larger than zminLayer for layers ',& diff --git a/build/source/engine/qTimeDelay.f90 b/build/source/engine/qTimeDelay.f90 index 75cb75c0a..ff1c12a42 100755 --- a/build/source/engine/qTimeDelay.f90 +++ b/build/source/engine/qTimeDelay.f90 @@ -52,14 +52,14 @@ subroutine qOverland(& implicit none ! input integer(i4b),intent(in) :: ixRouting ! index for routing method - real(dp),intent(in) :: averageSurfaceRunoff ! surface runoff (m s-1) - real(dp),intent(in) :: averageSoilBaseflow ! baseflow from the soil profile (m s-1) - real(dp),intent(in) :: averageAquiferBaseflow ! baseflow from the aquifer (m s-1) - real(dp),intent(in) :: fracFuture(:) ! fraction of runoff in future time steps (m s-1) - real(dp),intent(inout) :: qFuture(:) ! runoff in future time steps (m s-1) + real(summa_prec),intent(in) :: averageSurfaceRunoff ! surface runoff (m s-1) + real(summa_prec),intent(in) :: averageSoilBaseflow ! baseflow from the soil profile (m s-1) + real(summa_prec),intent(in) :: averageAquiferBaseflow ! baseflow from the aquifer (m s-1) + real(summa_prec),intent(in) :: fracFuture(:) ! fraction of runoff in future time steps (m s-1) + real(summa_prec),intent(inout) :: qFuture(:) ! runoff in future time steps (m s-1) ! output - real(dp),intent(out) :: averageInstantRunoff ! instantaneous runoff (m s-1) - real(dp),intent(out) :: averageRoutedRunoff ! routed runoff (m s-1) + real(summa_prec),intent(out) :: averageInstantRunoff ! instantaneous runoff (m s-1) + real(summa_prec),intent(out) :: averageRoutedRunoff ! routed runoff (m s-1) integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! internal @@ -89,7 +89,7 @@ subroutine qOverland(& do iFuture=2,nTDH qFuture(iFuture-1) = qFuture(iFuture) end do - qFuture(nTDH) = 0._dp + qFuture(nTDH) = 0._summa_prec !print*, 'averageInstantRunoff, averageRoutedRunoff = ', averageInstantRunoff, averageRoutedRunoff !print*, 'qFuture(1:100) = ', qFuture(1:100) diff --git a/build/source/engine/read_attrb.f90 b/build/source/engine/read_attrb.f90 index e07fff1a1..45571cfd1 100755 --- a/build/source/engine/read_attrb.f90 +++ b/build/source/engine/read_attrb.f90 @@ -239,7 +239,7 @@ subroutine read_attrb(attrFile,nGRU,attrStruct,typeStruct,idStruct,err,message) integer(i4b),parameter :: numerical=102 ! named variable to denote numerical data integer(i4b),parameter :: idrelated=103 ! named variable to denote ID related data integer(i4b) :: categorical_var(1) ! temporary categorical variable from local attributes netcdf file - real(dp) :: numeric_var(1) ! temporary numeric variable from local attributes netcdf file + real(summa_prec) :: numeric_var(1) ! temporary numeric variable from local attributes netcdf file integer(8) :: idrelated_var(1) ! temporary ID related variable from local attributes netcdf file ! define mapping variables diff --git a/build/source/engine/read_force.f90 b/build/source/engine/read_force.f90 index bf3435a60..e2b81b67f 100755 --- a/build/source/engine/read_force.f90 +++ b/build/source/engine/read_force.f90 @@ -63,8 +63,8 @@ module read_force_module public::read_force ! global parameters -real(dp),parameter :: verySmall=1e-3_dp ! tiny number -real(dp),parameter :: smallOffset=1.e-8_dp ! small offset (units=days) to force ih=0 at the start of the day +real(summa_prec),parameter :: verySmall=1e-3_summa_prec ! tiny number +real(summa_prec),parameter :: smallOffset=1.e-8_summa_prec ! small offset (units=days) to force ih=0 at the start of the day contains @@ -95,8 +95,8 @@ subroutine read_force(istep,iFile,iRead,ncid,time_data,forcStruct,err,message) integer(i4b) :: iGRU,iHRU ! index of GRU and HRU character(len=256),save :: infile ! filename character(len=256) :: cmessage ! error message for downwind routine - real(dp) :: startJulDay ! julian day at the start of the year - real(dp) :: currentJulday ! Julian day of current time step + real(summa_prec) :: startJulDay ! julian day at the start of the year + real(summa_prec) :: currentJulday ! Julian day of current time step logical(lgt),parameter :: checkTime=.false. ! flag to check the time ! Start procedure here err=0; message="read_force/" @@ -173,7 +173,7 @@ subroutine read_force(istep,iFile,iRead,ncid,time_data,forcStruct,err,message) ! compute the julian day at the start of the year call compjulday(time_data(iLookTIME%iyyy), & ! input = year - 1, 1, 1, 1, 0._dp, & ! input = month, day, hour, minute, second + 1, 1, 1, 1, 0._summa_prec, & ! input = month, day, hour, minute, second startJulDay,err,cmessage) ! output = julian day (fraction of day) + error control if(err/=0)then; message=trim(message)//trim(cmessage); return; end if @@ -182,7 +182,7 @@ subroutine read_force(istep,iFile,iRead,ncid,time_data,forcStruct,err,message) time_data(iLookTIME%im), & ! input = month time_data(iLookTIME%id), & ! input = day time_data(iLookTIME%ih), & ! input = hour - time_data(iLookTIME%imin),0._dp, & ! input = minute/second + time_data(iLookTIME%imin),0._summa_prec, & ! input = minute/second currentJulday,err,cmessage) ! output = julian day (fraction of day) + error control if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! compute the time since the start of the year (in fractional days) @@ -235,7 +235,7 @@ subroutine getFirstTimestep(currentJulday,iFile,iRead,ncid,err,message) USE nr_utility_module,only:arth ! get a sequence of numbers implicit none ! define input - real(dp),intent(in) :: currentJulday ! Julian day of current time step + real(summa_prec),intent(in) :: currentJulday ! Julian day of current time step ! define input-output variables integer(i4b),intent(inout) :: iFile ! index of current forcing file in forcing file list integer(i4b),intent(inout) :: iRead ! index of read position in time dimension in current netcdf file @@ -252,9 +252,9 @@ subroutine getFirstTimestep(currentJulday,iFile,iRead,ncid,err,message) character(len=256),save :: infile ! filename character(len=256) :: cmessage ! error message for downwind routine integer(i4b) :: nFiles ! number of forcing files - real(dp) :: timeVal(1) ! single time value (restrict time read) - real(dp),allocatable :: fileTime(:) ! array of time from netcdf file - real(dp),allocatable :: diffTime(:) ! array of time differences + real(summa_prec) :: timeVal(1) ! single time value (restrict time read) + real(summa_prec),allocatable :: fileTime(:) ! array of time from netcdf file + real(summa_prec),allocatable :: diffTime(:) ! array of time differences ! Start procedure here err=0; message="getFirstTimestep/" @@ -348,7 +348,7 @@ subroutine openForcingFile(iFile,infile,ncId,err,message) character(len=256) :: cmessage ! error message for downwind routine integer(i4b) :: iyyy,im,id,ih,imin ! date integer(i4b) :: ih_tz,imin_tz ! time zone information - real(dp) :: dsec,dsec_tz ! seconds + real(summa_prec) :: dsec,dsec_tz ! seconds integer(i4b) :: varId ! variable identifier integer(i4b) :: mode ! netcdf file mode integer(i4b) :: attLen ! attribute length @@ -378,8 +378,8 @@ subroutine openForcingFile(iFile,infile,ncId,err,message) case('ncTime'); tmZoneOffsetFracDay = sign(1, ih_tz) * fracDay(ih_tz, & ! time zone hour imin_tz, & ! time zone minute dsec_tz) ! time zone second - case('utcTime'); tmZoneOffsetFracDay = 0._dp - case('localTime'); tmZoneOffsetFracDay = 0._dp + case('utcTime'); tmZoneOffsetFracDay = 0._summa_prec + case('localTime'); tmZoneOffsetFracDay = 0._summa_prec case default; err=20; message=trim(message)//'unable to identify time zone info option'; return end select ! (option time zone option) @@ -391,10 +391,10 @@ subroutine openForcingFile(iFile,infile,ncId,err,message) ! get the time multiplier needed to convert time to units of days select case( trim( refTimeString(1:index(refTimeString,' ')) ) ) - case('seconds'); forcFileInfo(iFile)%convTime2Days=86400._dp - case('minutes'); forcFileInfo(iFile)%convTime2Days=1440._dp - case('hours'); forcFileInfo(iFile)%convTime2Days=24._dp - case('days'); forcFileInfo(iFile)%convTime2Days=1._dp + case('seconds'); forcFileInfo(iFile)%convTime2Days=86400._summa_prec + case('minutes'); forcFileInfo(iFile)%convTime2Days=1440._summa_prec + case('hours'); forcFileInfo(iFile)%convTime2Days=24._summa_prec + case('days'); forcFileInfo(iFile)%convTime2Days=1._summa_prec case default; message=trim(message)//'unable to identify time units'; err=20; return end select @@ -409,7 +409,7 @@ subroutine readForcingData(currentJulday,ncId,iFile,iRead,nHRUlocal,time_data,fo USE time_utils_module,only:compJulday ! convert calendar date to julian day USE get_ixname_module,only:get_ixforce ! identify index of named variable ! dummy variables - real(dp),intent(in) :: currentJulday ! Julian day of current time step + real(summa_prec),intent(in) :: currentJulday ! Julian day of current time step integer(i4b) ,intent(in) :: ncId ! NetCDF ID integer(i4b) ,intent(in) :: iFile ! index of forcing file integer(i4b) ,intent(in) :: iRead ! index in data file @@ -422,7 +422,7 @@ subroutine readForcingData(currentJulday,ncId,iFile,iRead,nHRUlocal,time_data,fo character(len=256) :: cmessage ! error message for downwind routine integer(i4b) :: varId ! variable identifier character(len = nf90_max_name) :: varName ! dimenison name - real(dp) :: varTime(1) ! time variable of current forcing data step being read + real(summa_prec) :: varTime(1) ! time variable of current forcing data step being read ! other local variables integer(i4b) :: iGRU,iHRU ! index of GRU and HRU integer(i4b) :: iHRU_global ! index of HRU in the NetCDF file @@ -431,11 +431,11 @@ subroutine readForcingData(currentJulday,ncId,iFile,iRead,nHRUlocal,time_data,fo integer(i4b) :: iNC ! loop through variables in forcing file integer(i4b) :: iVar ! index of forcing variable in forcing data vector logical(lgt),parameter :: checkTime=.false. ! flag to check the time - real(dp) :: dsec ! double precision seconds (not used) - real(dp) :: dataJulDay ! julian day of current forcing data step being read - real(dp),dimension(nHRUlocal) :: dataVec ! vector of data - real(dp),dimension(1) :: dataVal ! single data value - real(dp),parameter :: dataMin=-1._dp ! minimum allowable data value (all forcing variables should be positive) + real(summa_prec) :: dsec ! double precision seconds (not used) + real(summa_prec) :: dataJulDay ! julian day of current forcing data step being read + real(summa_prec),dimension(nHRUlocal) :: dataVec ! vector of data + real(summa_prec),dimension(1) :: dataVal ! single data value + real(summa_prec),parameter :: dataMin=-1._summa_prec ! minimum allowable data value (all forcing variables should be positive) logical(lgt),dimension(size(forc_meta)) :: checkForce ! flags to check forcing data variables exist logical(lgt),parameter :: simultaneousRead=.true. ! flag to denote reading all HRUs at once ! Start procedure here diff --git a/build/source/engine/read_param.f90 b/build/source/engine/read_param.f90 index 05119d36f..7ce307f0d 100755 --- a/build/source/engine/read_param.f90 +++ b/build/source/engine/read_param.f90 @@ -90,7 +90,7 @@ subroutine read_param(iRunMode,checkHRU,startGRU,nHRU,nGRU,idStruct,mparStruct,b ! data in the netcdf file integer(i4b) :: parLength ! length of the parameter data integer(8),allocatable :: hruId(:) ! HRU identifier in the file - real(dp),allocatable :: parVector(:) ! model parameter vector + real(summa_prec),allocatable :: parVector(:) ! model parameter vector logical :: fexist ! inquire whether the parmTrial file exists integer(i4b) :: fHRU ! index of HRU in input file diff --git a/build/source/engine/read_pinit.f90 b/build/source/engine/read_pinit.f90 index 2a0b350b1..89982d069 100755 --- a/build/source/engine/read_pinit.f90 +++ b/build/source/engine/read_pinit.f90 @@ -132,9 +132,9 @@ subroutine read_pinit(filenm,isLocal,mpar_meta,parFallback,err,message) ! check we have populated all variables ! NOTE: ultimately need a need a parameter dictionary to ensure that the parameters used are populated if(.not.backwardsCompatible)then ! if we add new variables in future versions of the code, then some may be missing in the input file - if(any(parFallback(:)%default_val < 0.99_dp*realMissing))then + if(any(parFallback(:)%default_val < 0.99_summa_prec*realMissing))then do ivar=1,size(parFallback) - if(parFallback(ivar)%default_val < 0.99_dp*realMissing)then + if(parFallback(ivar)%default_val < 0.99_summa_prec*realMissing)then err=40; message=trim(message)//"variableNonexistent[var="//trim(mpar_meta(ivar)%varname)//"]"; return end if end do @@ -143,8 +143,8 @@ subroutine read_pinit(filenm,isLocal,mpar_meta,parFallback,err,message) else ! (need backwards compatibility) if(isLocal)then if(model_decisions(iLookDECISIONS%cIntercept)%iDecision == unDefined)then - parFallback(iLookPARAM%canopyWettingFactor)%default_val = 1._dp ! maximum wetted fraction of the canopy (-) - parFallback(iLookPARAM%canopyWettingExp)%default_val = 0.666666667_dp ! exponent in canopy wetting function (-) + parFallback(iLookPARAM%canopyWettingFactor)%default_val = 1._summa_prec ! maximum wetted fraction of the canopy (-) + parFallback(iLookPARAM%canopyWettingExp)%default_val = 0.666666667_summa_prec ! exponent in canopy wetting function (-) end if end if end if diff --git a/build/source/engine/run_oneGRU.f90 b/build/source/engine/run_oneGRU.f90 index 653585ac7..93d2f8b43 100755 --- a/build/source/engine/run_oneGRU.f90 +++ b/build/source/engine/run_oneGRU.f90 @@ -103,7 +103,7 @@ subroutine run_oneGRU(& ! model control type(gru2hru_map) , intent(inout) :: gruInfo ! HRU information for given GRU (# HRUs, #snow+soil layers) - real(dp) , intent(inout) :: dt_init(:) ! used to initialize the length of the sub-step for each HRU + real(summa_prec) , intent(inout) :: dt_init(:) ! used to initialize the length of the sub-step for each HRU integer(i4b) , intent(inout) :: ixComputeVegFlux(:) ! flag to indicate if we are computing fluxes over vegetation (false=no, true=yes) ! data structures (input) integer(i4b) , intent(in) :: timeVec(:) ! integer vector -- model time data @@ -131,7 +131,7 @@ subroutine run_oneGRU(& integer(i4b) :: nSnow ! number of snow layers integer(i4b) :: nSoil ! number of soil layers integer(i4b) :: nLayers ! total number of layers - real(dp) :: fracHRU ! fractional area of a given HRU (-) + real(summa_prec) :: fracHRU ! fractional area of a given HRU (-) logical(lgt) :: computeVegFluxFlag ! flag to indicate if we are computing fluxes over vegetation (.false. means veg is buried with snow) ! initialize error control @@ -140,17 +140,17 @@ subroutine run_oneGRU(& ! ----- basin initialization -------------------------------------------------------------------------------------------- ! initialize runoff variables - bvarData%var(iLookBVAR%basin__SurfaceRunoff)%dat(1) = 0._dp ! surface runoff (m s-1) - bvarData%var(iLookBVAR%basin__ColumnOutflow)%dat(1) = 0._dp ! outflow from all "outlet" HRUs (those with no downstream HRU) + bvarData%var(iLookBVAR%basin__SurfaceRunoff)%dat(1) = 0._summa_prec ! surface runoff (m s-1) + bvarData%var(iLookBVAR%basin__ColumnOutflow)%dat(1) = 0._summa_prec ! outflow from all "outlet" HRUs (those with no downstream HRU) ! initialize baseflow variables - bvarData%var(iLookBVAR%basin__AquiferRecharge)%dat(1) = 0._dp ! recharge to the aquifer (m s-1) - bvarData%var(iLookBVAR%basin__AquiferBaseflow)%dat(1) = 0._dp ! baseflow from the aquifer (m s-1) - bvarData%var(iLookBVAR%basin__AquiferTranspire)%dat(1) = 0._dp ! transpiration loss from the aquifer (m s-1) + bvarData%var(iLookBVAR%basin__AquiferRecharge)%dat(1) = 0._summa_prec ! recharge to the aquifer (m s-1) + bvarData%var(iLookBVAR%basin__AquiferBaseflow)%dat(1) = 0._summa_prec ! baseflow from the aquifer (m s-1) + bvarData%var(iLookBVAR%basin__AquiferTranspire)%dat(1) = 0._summa_prec ! transpiration loss from the aquifer (m s-1) ! initialize total inflow for each layer in a soil column do iHRU=1,gruInfo%hruCount - fluxHRU%hru(iHRU)%var(iLookFLUX%mLayerColumnInflow)%dat(:) = 0._dp + fluxHRU%hru(iHRU)%var(iLookFLUX%mLayerColumnInflow)%dat(:) = 0._summa_prec end do ! *********************************************************************************************************************** diff --git a/build/source/engine/run_oneHRU.f90 b/build/source/engine/run_oneHRU.f90 index 1632e1f77..5fb27c909 100755 --- a/build/source/engine/run_oneHRU.f90 +++ b/build/source/engine/run_oneHRU.f90 @@ -114,7 +114,7 @@ subroutine run_oneHRU(& ! model control integer(8) , intent(in) :: hruId ! hruId - real(dp) , intent(inout) :: dt_init ! used to initialize the length of the sub-step for each HRU + real(summa_prec) , intent(inout) :: dt_init ! used to initialize the length of the sub-step for each HRU logical(lgt) , intent(inout) :: computeVegFlux ! flag to indicate if we are computing fluxes over vegetation (false=no, true=yes) integer(i4b) , intent(inout) :: nSnow,nSoil,nLayers ! number of snow and soil layers ! data structures (input) @@ -137,7 +137,7 @@ subroutine run_oneHRU(& ! local variables character(len=256) :: cmessage ! error message - real(dp) , allocatable :: zSoilReverseSign(:) ! height at bottom of each soil layer, negative downwards (m) + real(summa_prec) , allocatable :: zSoilReverseSign(:) ! height at bottom of each soil layer, negative downwards (m) ! initialize error control err=0; write(message, '(A20,I0,A2)' ) 'run_oneHRU (hruId = ',hruId,')/' @@ -201,7 +201,7 @@ subroutine run_oneHRU(& ! ----- run the model -------------------------------------------------------------------------------------------------- ! initialize the number of flux calls - diagData%var(iLookDIAG%numFluxCalls)%dat(1) = 0._dp + diagData%var(iLookDIAG%numFluxCalls)%dat(1) = 0._summa_prec ! run the model for a single HRU call coupled_em(& diff --git a/build/source/engine/snowAlbedo.f90 b/build/source/engine/snowAlbedo.f90 index c536a437f..35544c729 100755 --- a/build/source/engine/snowAlbedo.f90 +++ b/build/source/engine/snowAlbedo.f90 @@ -81,7 +81,7 @@ subroutine snowAlbedo(& USE snow_utils_module,only:fracliquid ! compute fraction of liquid water at a given temperature ! -------------------------------------------------------------------------------------------------------------------------------------- ! input: model control - real(dp),intent(in) :: dt ! model time step + real(summa_prec),intent(in) :: dt ! model time step logical(lgt),intent(in) :: snowPresence ! logical flag to denote if snow is present ! input/output: data structures type(model_options),intent(in) :: model_decisions(:) ! model decisions @@ -95,16 +95,16 @@ subroutine snowAlbedo(& ! local variables integer(i4b),parameter :: ixVisible=1 ! named variable to define index in array of visible part of the spectrum integer(i4b),parameter :: ixNearIR=2 ! named variable to define index in array of near IR part of the spectrum - real(dp),parameter :: valueMissing=-9999._dp ! missing value -- will cause problems if snow albedo is ever used for the non-snow case - real(dp),parameter :: slushExp=10._dp ! "slush" exponent, to increase decay when snow is near Tfreeze - real(dp),parameter :: fractionLiqThresh=0.001_dp ! threshold for the fraction of liquid water to switch to spring albedo minimum - real(dp) :: fractionLiq ! fraction of liquid water (-) - real(dp) :: age1,age2,age3 ! aging factors (-) - real(dp) :: decayFactor ! albedo decay factor (-) - real(dp) :: refreshFactor ! albedo refreshment factor, representing albedo increase due to snowfall (-) - real(dp) :: albedoMin ! minimum albedo -- depends if in winter or spring conditions (-) - real(dp) :: fZen ! factor to modify albedo at low zenith angles (-) - real(dp),parameter :: bPar=2._dp ! empirical parameter in fZen + real(summa_prec),parameter :: valueMissing=-9999._summa_prec ! missing value -- will cause problems if snow albedo is ever used for the non-snow case + real(summa_prec),parameter :: slushExp=10._summa_prec ! "slush" exponent, to increase decay when snow is near Tfreeze + real(summa_prec),parameter :: fractionLiqThresh=0.001_summa_prec ! threshold for the fraction of liquid water to switch to spring albedo minimum + real(summa_prec) :: fractionLiq ! fraction of liquid water (-) + real(summa_prec) :: age1,age2,age3 ! aging factors (-) + real(summa_prec) :: decayFactor ! albedo decay factor (-) + real(summa_prec) :: refreshFactor ! albedo refreshment factor, representing albedo increase due to snowfall (-) + real(summa_prec) :: albedoMin ! minimum albedo -- depends if in winter or spring conditions (-) + real(summa_prec) :: fZen ! factor to modify albedo at low zenith angles (-) + real(summa_prec),parameter :: bPar=2._summa_prec ! empirical parameter in fZen ! initialize error control err=0; message='snowAlbedo/' ! -------------------------------------------------------------------------------------------------------------------------------------- @@ -188,18 +188,18 @@ subroutine snowAlbedo(& call computeAlbedo(spectralSnowAlbedoDiffuse(ixVisible),refreshFactor,decayFactor,albedoMaxVisible,albedoMinVisible) call computeAlbedo(spectralSnowAlbedoDiffuse(ixNearIR), refreshFactor,decayFactor,albedoMaxNearIR, albedoMinNearIR) ! compute factor to modify direct albedo at low zenith angles - if(cosZenith < 0.5_dp)then - fZen = (1._dp/bPar)*( ((1._dp + bPar)/(1._dp + 2._dp*bPar*cosZenith)) - 1._dp) + if(cosZenith < 0.5_summa_prec)then + fZen = (1._summa_prec/bPar)*( ((1._summa_prec + bPar)/(1._summa_prec + 2._summa_prec*bPar*cosZenith)) - 1._summa_prec) else - fZen = 0._dp + fZen = 0._summa_prec end if ! compute direct albedo - spectralSnowAlbedoDirect(ixVisible) = spectralSnowAlbedoDiffuse(ixVisible) + 0.4_dp*fZen*(1._dp - spectralSnowAlbedoDiffuse(ixVisible)) - spectralSnowAlbedoDirect(ixNearIR) = spectralSnowAlbedoDiffuse(ixNearIR) + 0.4_dp*fZen*(1._dp - spectralSnowAlbedoDiffuse(ixNearIR)) + spectralSnowAlbedoDirect(ixVisible) = spectralSnowAlbedoDiffuse(ixVisible) + 0.4_summa_prec*fZen*(1._summa_prec - spectralSnowAlbedoDiffuse(ixVisible)) + spectralSnowAlbedoDirect(ixNearIR) = spectralSnowAlbedoDiffuse(ixNearIR) + 0.4_summa_prec*fZen*(1._summa_prec - spectralSnowAlbedoDiffuse(ixNearIR)) ! compute average albedo - scalarSnowAlbedo = ( Frad_direct)*(Frad_vis*spectralSnowAlbedoDirect(ixVisible) + (1._dp - Frad_vis)*spectralSnowAlbedoDirect(ixNearIR) ) + & - (1._dp - Frad_direct)*(Frad_vis*spectralSnowAlbedoDirect(ixVisible) + (1._dp - Frad_vis)*spectralSnowAlbedoDirect(ixNearIR) ) + scalarSnowAlbedo = ( Frad_direct)*(Frad_vis*spectralSnowAlbedoDirect(ixVisible) + (1._summa_prec - Frad_vis)*spectralSnowAlbedoDirect(ixNearIR) ) + & + (1._summa_prec - Frad_direct)*(Frad_vis*spectralSnowAlbedoDirect(ixVisible) + (1._summa_prec - Frad_vis)*spectralSnowAlbedoDirect(ixNearIR) ) ! check that we identified the albedo option case default; err=20; message=trim(message)//'unable to identify option for snow albedo'; return @@ -207,7 +207,7 @@ subroutine snowAlbedo(& end select ! identify option for snow albedo ! check - if(scalarSnowAlbedo < 0._dp)then; err=20; message=trim(message)//'unable to identify option for snow albedo'; return; end if + if(scalarSnowAlbedo < 0._summa_prec)then; err=20; message=trim(message)//'unable to identify option for snow albedo'; return; end if ! end association to data structures end associate @@ -221,15 +221,15 @@ end subroutine snowAlbedo subroutine computeAlbedo(snowAlbedo,refreshFactor,decayFactor,albedoMax,albedoMin) implicit none ! dummy variables - real(dp),intent(inout) :: snowAlbedo ! snow albedo (-) - real(dp),intent(in) :: refreshFactor ! albedo refreshment factor (-) - real(dp),intent(in) :: decayFactor ! albedo decay factor (-) - real(dp),intent(in) :: albedoMax ! maximum albedo (-) - real(dp),intent(in) :: albedoMin ! minimum albedo (-) + real(summa_prec),intent(inout) :: snowAlbedo ! snow albedo (-) + real(summa_prec),intent(in) :: refreshFactor ! albedo refreshment factor (-) + real(summa_prec),intent(in) :: decayFactor ! albedo decay factor (-) + real(summa_prec),intent(in) :: albedoMax ! maximum albedo (-) + real(summa_prec),intent(in) :: albedoMin ! minimum albedo (-) ! local variables - real(dp) :: albedoChange ! change in albedo over the time step (-) + real(summa_prec) :: albedoChange ! change in albedo over the time step (-) ! compute change in albedo - albedoChange = refreshFactor*(albedoMax - snowAlbedo) - (decayFactor*(snowAlbedo - albedoMin)) / (1._dp + decayFactor) + albedoChange = refreshFactor*(albedoMax - snowAlbedo) - (decayFactor*(snowAlbedo - albedoMin)) / (1._summa_prec + decayFactor) snowAlbedo = snowAlbedo + albedoChange if(snowAlbedo > albedoMax) snowAlbedo = albedoMax end subroutine computeAlbedo diff --git a/build/source/engine/snowLiqFlx.f90 b/build/source/engine/snowLiqFlx.f90 index 53b4fb29a..6708821f1 100755 --- a/build/source/engine/snowLiqFlx.f90 +++ b/build/source/engine/snowLiqFlx.f90 @@ -75,18 +75,18 @@ subroutine snowLiqFlx(& logical(lgt),intent(in) :: firstFluxCall ! the first flux call logical(lgt),intent(in) :: scalarSolution ! flag to denote if implementing the scalar solution ! input: forcing for the snow domain - real(dp),intent(in) :: scalarThroughfallRain ! computed throughfall rate (kg m-2 s-1) - real(dp),intent(in) :: scalarCanopyLiqDrainage ! computed drainage of liquid water (kg m-2 s-1) + real(summa_prec),intent(in) :: scalarThroughfallRain ! computed throughfall rate (kg m-2 s-1) + real(summa_prec),intent(in) :: scalarCanopyLiqDrainage ! computed drainage of liquid water (kg m-2 s-1) ! input: model state vector - real(dp),intent(in) :: mLayerVolFracLiqTrial(:) ! trial value of volumetric fraction of liquid water at the current iteration (-) + real(summa_prec),intent(in) :: mLayerVolFracLiqTrial(:) ! trial value of volumetric fraction of liquid water at the current iteration (-) ! input-output: data structures type(var_ilength),intent(in) :: indx_data ! model indices type(var_dlength),intent(in) :: mpar_data ! model parameters type(var_dlength),intent(in) :: prog_data ! prognostic variables for a local HRU type(var_dlength),intent(inout) :: diag_data ! diagnostic variables for a local HRU ! output: fluxes and derivatives - real(dp),intent(inout) :: iLayerLiqFluxSnow(0:) ! vertical liquid water flux at layer interfaces (m s-1) - real(dp),intent(inout) :: iLayerLiqFluxSnowDeriv(0:) ! derivative in vertical liquid water flux at layer interfaces (m s-1) + real(summa_prec),intent(inout) :: iLayerLiqFluxSnow(0:) ! vertical liquid water flux at layer interfaces (m s-1) + real(summa_prec),intent(inout) :: iLayerLiqFluxSnowDeriv(0:) ! derivative in vertical liquid water flux at layer interfaces (m s-1) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message @@ -96,12 +96,12 @@ subroutine snowLiqFlx(& integer(i4b) :: iLayer ! layer index integer(i4b) :: ixTop ! top layer in subroutine call integer(i4b) :: ixBot ! bottom layer in subroutine call - real(dp) :: multResid ! multiplier for the residual water content (-) - real(dp),parameter :: residThrs=550._dp ! ice density threshold to reduce residual liquid water content (kg m-3) - real(dp),parameter :: residScal=10._dp ! scaling factor for residual liquid water content reduction factor (kg m-3) - real(dp),parameter :: maxVolIceContent=0.7_dp ! maximum volumetric ice content to store water (-) - real(dp) :: availCap ! available storage capacity [0,1] (-) - real(dp) :: relSaturn ! relative saturation [0,1] (-) + real(summa_prec) :: multResid ! multiplier for the residual water content (-) + real(summa_prec),parameter :: residThrs=550._summa_prec ! ice density threshold to reduce residual liquid water content (kg m-3) + real(summa_prec),parameter :: residScal=10._summa_prec ! scaling factor for residual liquid water content reduction factor (kg m-3) + real(summa_prec),parameter :: maxVolIceContent=0.7_summa_prec ! maximum volumetric ice content to store water (-) + real(summa_prec) :: availCap ! available storage capacity [0,1] (-) + real(summa_prec) :: relSaturn ! relative saturation [0,1] (-) ! ------------------------------------------------------------------------------------------------------------------------------------------ ! make association of local variables with information in the data structures associate(& @@ -128,7 +128,7 @@ subroutine snowLiqFlx(& end if ! check the meltwater exponent is >=1 - if(mw_exp<1._dp)then; err=20; message=trim(message)//'meltwater exponent < 1'; return; end if + if(mw_exp<1._summa_prec)then; err=20; message=trim(message)//'meltwater exponent < 1'; return; end if ! get the indices for the snow+soil layers ixTop = integerMissing @@ -159,16 +159,16 @@ subroutine snowLiqFlx(& ! define the liquid flux at the upper boundary (m s-1) iLayerLiqFluxSnow(0) = (scalarThroughfallRain + scalarCanopyLiqDrainage)/iden_water - iLayerLiqFluxSnowDeriv(0) = 0._dp + iLayerLiqFluxSnowDeriv(0) = 0._summa_prec ! compute properties fixed over the time step if(firstFluxCall)then ! loop through snow layers do iLayer=1,nSnow ! compute the reduction in liquid water holding capacity at high snow density (-) - multResid = 1._dp / ( 1._dp + exp( (mLayerVolFracIce(iLayer)*iden_ice - residThrs) / residScal) ) + multResid = 1._summa_prec / ( 1._summa_prec + exp( (mLayerVolFracIce(iLayer)*iden_ice - residThrs) / residScal) ) ! compute the pore space (-) - mLayerPoreSpace(iLayer) = 1._dp - mLayerVolFracIce(iLayer) + mLayerPoreSpace(iLayer) = 1._summa_prec - mLayerVolFracIce(iLayer) ! compute the residual volumetric liquid water content (-) mLayerThetaResid(iLayer) = Fcapil*mLayerPoreSpace(iLayer) * multResid end do ! (looping through snow layers) @@ -182,14 +182,14 @@ subroutine snowLiqFlx(& availCap = mLayerPoreSpace(iLayer) - mLayerThetaResid(iLayer) ! available capacity relSaturn = (mLayerVolFracLiqTrial(iLayer) - mLayerThetaResid(iLayer)) / availCap ! relative saturation iLayerLiqFluxSnow(iLayer) = k_snow*relSaturn**mw_exp - iLayerLiqFluxSnowDeriv(iLayer) = ( (k_snow*mw_exp)/availCap ) * relSaturn**(mw_exp - 1._dp) + iLayerLiqFluxSnowDeriv(iLayer) = ( (k_snow*mw_exp)/availCap ) * relSaturn**(mw_exp - 1._summa_prec) if(mLayerVolFracIce(iLayer) > maxVolIceContent)then ! NOTE: use start-of-step ice content, to avoid convergence problems ! ** allow liquid water to pass through under very high ice density iLayerLiqFluxSnow(iLayer) = iLayerLiqFluxSnow(iLayer) + iLayerLiqFluxSnow(iLayer-1) !NOTE: derivative may need to be updated in future. end if else ! flow does not occur - iLayerLiqFluxSnow(iLayer) = 0._dp - iLayerLiqFluxSnowDeriv(iLayer) = 0._dp + iLayerLiqFluxSnow(iLayer) = 0._summa_prec + iLayerLiqFluxSnowDeriv(iLayer) = 0._summa_prec endif ! storage above residual content end do ! loop through snow layers diff --git a/build/source/engine/snow_utils.f90 b/build/source/engine/snow_utils.f90 index 496ecfce5..6323d1ae1 100755 --- a/build/source/engine/snow_utils.f90 +++ b/build/source/engine/snow_utils.f90 @@ -47,11 +47,11 @@ module snow_utils_module ! *********************************************************************************************************** function fracliquid(Tk,fc_param) implicit none - real(dp),intent(in) :: Tk ! temperature (K) - real(dp),intent(in) :: fc_param ! freezing curve parameter (K-1) - real(dp) :: fracliquid ! fraction of liquid water (-) + real(summa_prec),intent(in) :: Tk ! temperature (K) + real(summa_prec),intent(in) :: fc_param ! freezing curve parameter (K-1) + real(summa_prec) :: fracliquid ! fraction of liquid water (-) ! compute fraction of liquid water (-) - fracliquid = 1._dp / ( 1._dp + (fc_param*( Tfreeze - min(Tk,Tfreeze) ))**2._dp ) + fracliquid = 1._summa_prec / ( 1._summa_prec + (fc_param*( Tfreeze - min(Tk,Tfreeze) ))**2._summa_prec ) end function fracliquid @@ -60,11 +60,11 @@ end function fracliquid ! *********************************************************************************************************** function templiquid(fracliquid,fc_param) implicit none - real(dp),intent(in) :: fracliquid ! fraction of liquid water (-) - real(dp),intent(in) :: fc_param ! freezing curve parameter (K-1) - real(dp) :: templiquid ! temperature (K) + real(summa_prec),intent(in) :: fracliquid ! fraction of liquid water (-) + real(summa_prec),intent(in) :: fc_param ! freezing curve parameter (K-1) + real(summa_prec) :: templiquid ! temperature (K) ! compute temperature based on the fraction of liquid water (K) - templiquid = Tfreeze - ((1._dp/fracliquid - 1._dp)/fc_param**2._dp)**(0.5_dp) + templiquid = Tfreeze - ((1._summa_prec/fracliquid - 1._summa_prec)/fc_param**2._summa_prec)**(0.5_summa_prec) end function templiquid @@ -74,17 +74,17 @@ end function templiquid function dFracLiq_dTk(Tk,fc_param) implicit none ! dummies - real(dp),intent(in) :: Tk ! temperature (K) - real(dp),intent(in) :: fc_param ! freezing curve parameter (K-1) - real(dp) :: dFracLiq_dTk ! differentiate the freezing curve (K-1) + real(summa_prec),intent(in) :: Tk ! temperature (K) + real(summa_prec),intent(in) :: fc_param ! freezing curve parameter (K-1) + real(summa_prec) :: dFracLiq_dTk ! differentiate the freezing curve (K-1) ! locals - real(dp) :: Tdep ! temperature depression (K) - real(dp) :: Tdim ! dimensionless temperature (-) + real(summa_prec) :: Tdep ! temperature depression (K) + real(summa_prec) :: Tdim ! dimensionless temperature (-) ! compute local variables (just to make things more efficient) Tdep = Tfreeze - min(Tk,Tfreeze) Tdim = fc_param*Tdep ! differentiate the freezing curve w.r.t temperature - dFracLiq_dTk = (fc_param*2._dp*Tdim) / ( ( 1._dp + Tdim**2._dp)**2._dp ) + dFracLiq_dTk = (fc_param*2._summa_prec*Tdim) / ( ( 1._summa_prec + Tdim**2._summa_prec)**2._summa_prec ) end function dFracLiq_dTk @@ -93,17 +93,17 @@ end function dFracLiq_dTk ! *********************************************************************************************************** subroutine tcond_snow(BulkDenIce,thermlcond,err,message) implicit none - real(dp),intent(in) :: BulkDenIce ! bulk density of ice (kg m-3) - real(dp),intent(out) :: thermlcond ! thermal conductivity of snow (W m-1 K-1) + real(summa_prec),intent(in) :: BulkDenIce ! bulk density of ice (kg m-3) + real(summa_prec),intent(out) :: thermlcond ! thermal conductivity of snow (W m-1 K-1) integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! initialize error control err=0; message="tcond_snow/" ! compute thermal conductivity of snow select case(model_decisions(iLookDECISIONS%thCondSnow)%iDecision) - case(Yen1965); thermlcond = 3.217d-6 * BulkDenIce**2._dp ! Yen (1965) - case(Mellor1977); thermlcond = 2.576d-6 * BulkDenIce**2._dp + 7.4d-2 ! Mellor (1977) - case(Jordan1991); thermlcond = lambda_air + (7.75d-5*BulkDenIce + 1.105d-6*(BulkDenIce**2._dp)) & + case(Yen1965); thermlcond = 3.217d-6 * BulkDenIce**2._summa_prec ! Yen (1965) + case(Mellor1977); thermlcond = 2.576d-6 * BulkDenIce**2._summa_prec + 7.4d-2 ! Mellor (1977) + case(Jordan1991); thermlcond = lambda_air + (7.75d-5*BulkDenIce + 1.105d-6*(BulkDenIce**2._summa_prec)) & * (lambda_ice-lambda_air) ! Jordan (1991) case default err=10; message=trim(message)//"unknownOption"; return diff --git a/build/source/engine/snwCompact.f90 b/build/source/engine/snwCompact.f90 index 8f3441bce..570caaf08 100755 --- a/build/source/engine/snwCompact.f90 +++ b/build/source/engine/snwCompact.f90 @@ -65,43 +65,43 @@ subroutine snwDensify(& ! compute change in snow density over the time step implicit none ! intent(in): variables - real(dp),intent(in) :: dt ! time step (seconds) + real(summa_prec),intent(in) :: dt ! time step (seconds) integer(i4b),intent(in) :: nSnow ! number of snow layers - real(dp),intent(in) :: mLayerTemp(:) ! temperature of each snow layer after iterations (K) - real(dp),intent(in) :: mLayerMeltFreeze(:) ! volumetric melt in each layer (kg m-3) + real(summa_prec),intent(in) :: mLayerTemp(:) ! temperature of each snow layer after iterations (K) + real(summa_prec),intent(in) :: mLayerMeltFreeze(:) ! volumetric melt in each layer (kg m-3) ! intent(in): parameters - real(dp),intent(in) :: densScalGrowth ! density scaling factor for grain growth (kg-1 m3) - real(dp),intent(in) :: tempScalGrowth ! temperature scaling factor for grain growth (K-1) - real(dp),intent(in) :: grainGrowthRate ! rate of grain growth (s-1) - real(dp),intent(in) :: densScalOvrbdn ! density scaling factor for overburden pressure (kg-1 m3) - real(dp),intent(in) :: tempScalOvrbdn ! temperature scaling factor for overburden pressure (K-1) - real(dp),intent(in) :: baseViscosity ! viscosity coefficient at T=T_frz and snow density=0 (kg m-2 s) + real(summa_prec),intent(in) :: densScalGrowth ! density scaling factor for grain growth (kg-1 m3) + real(summa_prec),intent(in) :: tempScalGrowth ! temperature scaling factor for grain growth (K-1) + real(summa_prec),intent(in) :: grainGrowthRate ! rate of grain growth (s-1) + real(summa_prec),intent(in) :: densScalOvrbdn ! density scaling factor for overburden pressure (kg-1 m3) + real(summa_prec),intent(in) :: tempScalOvrbdn ! temperature scaling factor for overburden pressure (K-1) + real(summa_prec),intent(in) :: baseViscosity ! viscosity coefficient at T=T_frz and snow density=0 (kg m-2 s) ! intent(inout): state variables - real(dp),intent(inout) :: mLayerDepth(:) ! depth of each layer (m) - real(dp),intent(inout) :: mLayerVolFracLiqNew(:) ! volumetric fraction of liquid water in each snow layer after iterations (-) - real(dp),intent(inout) :: mLayerVolFracIceNew(:) ! volumetric fraction of ice in each snow layer after iterations (-) + real(summa_prec),intent(inout) :: mLayerDepth(:) ! depth of each layer (m) + real(summa_prec),intent(inout) :: mLayerVolFracLiqNew(:) ! volumetric fraction of liquid water in each snow layer after iterations (-) + real(summa_prec),intent(inout) :: mLayerVolFracIceNew(:) ! volumetric fraction of ice in each snow layer after iterations (-) ! intent(out): error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! ----------------------------------------------------------------------------------------------------------------------------------------- ! define local variables integer(i4b) :: iSnow ! index of snow layers - real(dp) :: chi1,chi2,chi3,chi4,chi5 ! multipliers in the densification algorithm (-) - real(dp) :: halfWeight ! half of the weight of the current snow layer (kg m-2) - real(dp) :: weightSnow ! total weight of snow above the current snow layer (kg m-2) - real(dp) :: CR_grainGrowth ! compaction rate for grain growth (s-1) - real(dp) :: CR_ovrvdnPress ! compaction rate associated with over-burden pressure (s-1) - real(dp) :: CR_metamorph ! compaction rate for metamorphism (s-1) - real(dp) :: massIceOld ! mass of ice in the snow layer (kg m-2) - real(dp) :: massLiqOld ! mass of liquid water in the snow layer (kg m-2) - real(dp) :: scalarDepthNew ! updated layer depth (m) - real(dp) :: scalarDepthMin ! minimum layer depth (m) - real(dp) :: volFracIceLoss ! volumetric fraction of ice lost due to melt and sublimation (-) - real(dp), dimension(nSnow) :: mLayerVolFracAirNew ! volumetric fraction of air in each layer after compaction (-) - real(dp),parameter :: snwden_min=100._dp ! minimum snow density for reducing metamorphism rate (kg m-3) - real(dp),parameter :: snwDensityMax=550._dp ! maximum snow density for collapse under melt (kg m-3) - real(dp),parameter :: wetSnowThresh=0.01_dp ! threshold to discriminate between "wet" and "dry" snow - real(dp),parameter :: minLayerDensity=40._dp ! minimum snow density allowed for any layer (kg m-3) + real(summa_prec) :: chi1,chi2,chi3,chi4,chi5 ! multipliers in the densification algorithm (-) + real(summa_prec) :: halfWeight ! half of the weight of the current snow layer (kg m-2) + real(summa_prec) :: weightSnow ! total weight of snow above the current snow layer (kg m-2) + real(summa_prec) :: CR_grainGrowth ! compaction rate for grain growth (s-1) + real(summa_prec) :: CR_ovrvdnPress ! compaction rate associated with over-burden pressure (s-1) + real(summa_prec) :: CR_metamorph ! compaction rate for metamorphism (s-1) + real(summa_prec) :: massIceOld ! mass of ice in the snow layer (kg m-2) + real(summa_prec) :: massLiqOld ! mass of liquid water in the snow layer (kg m-2) + real(summa_prec) :: scalarDepthNew ! updated layer depth (m) + real(summa_prec) :: scalarDepthMin ! minimum layer depth (m) + real(summa_prec) :: volFracIceLoss ! volumetric fraction of ice lost due to melt and sublimation (-) + real(summa_prec), dimension(nSnow) :: mLayerVolFracAirNew ! volumetric fraction of air in each layer after compaction (-) + real(summa_prec),parameter :: snwden_min=100._summa_prec ! minimum snow density for reducing metamorphism rate (kg m-3) + real(summa_prec),parameter :: snwDensityMax=550._summa_prec ! maximum snow density for collapse under melt (kg m-3) + real(summa_prec),parameter :: wetSnowThresh=0.01_summa_prec ! threshold to discriminate between "wet" and "dry" snow + real(summa_prec),parameter :: minLayerDensity=40._summa_prec ! minimum snow density allowed for any layer (kg m-3) ! ----------------------------------------------------------------------------------------------------------------------------------------- ! initialize error control err=0; message="snwDensify/" @@ -110,7 +110,7 @@ subroutine snwDensify(& if(nSnow==0)return ! initialize the weight of snow above each layer (kg m-2) - weightSnow = 0._dp + weightSnow = 0._summa_prec ! loop through snow layers do iSnow=1,nSnow @@ -124,19 +124,19 @@ subroutine snwDensify(& ! *** compute the compaction associated with grain growth (s-1) ! compute the base rate of grain growth (-) - if(mLayerVolFracIceNew(iSnow)*iden_ice =snwden_min) chi1=exp(-densScalGrowth*(mLayerVolFracIceNew(iSnow)*iden_ice - snwden_min)) ! compute the reduction of grain growth under colder snow temperatures (-) chi2 = exp(-tempScalGrowth*(Tfreeze - mLayerTemp(iSnow))) ! compute the acceleration of grain growth in the presence of liquid water (-) - if(mLayerVolFracLiqNew(iSnow) > wetSnowThresh)then; chi3=2._dp ! snow is "wet" - else; chi3=1._dp; end if ! snow is "dry" + if(mLayerVolFracLiqNew(iSnow) > wetSnowThresh)then; chi3=2._summa_prec ! snow is "wet" + else; chi3=1._summa_prec; end if ! snow is "dry" ! compute the compaction associated with grain growth (s-1) CR_grainGrowth = grainGrowthRate*chi1*chi2*chi3 ! **** compute the compaction associated with over-burden pressure (s-1) ! compute the weight imposed on the current layer (kg m-2) - halfWeight = (massIceOld + massLiqOld)/2._dp ! there is some over-burden pressure from the layer itself + halfWeight = (massIceOld + massLiqOld)/2._summa_prec ! there is some over-burden pressure from the layer itself weightSnow = weightSnow + halfweight ! add half of the weight from the current layer ! compute the increase in compaction under colder snow temperatures (-) chi4 = exp(-tempScalOvrbdn*(Tfreeze - mLayerTemp(iSnow))) @@ -151,7 +151,7 @@ subroutine snwDensify(& ! NOTE: loss of ice due to snowmelt is implicit, so can be updated directly if(iden_ice*mLayerVolFracIceNew(iSnow) < snwDensityMax)then ! only collapse layers if below a critical density ! (compute volumetric losses of ice due to melt and sublimation) - volFracIceLoss = max(0._dp,mLayerMeltFreeze(iSnow)/iden_ice) ! volumetric fraction of ice lost due to melt (-) + volFracIceLoss = max(0._summa_prec,mLayerMeltFreeze(iSnow)/iden_ice) ! volumetric fraction of ice lost due to melt (-) ! (adjust snow depth to account for cavitation) scalarDepthNew = mLayerDepth(iSnow) * mLayerVolFracIceNew(iSnow)/(mLayerVolFracIceNew(iSnow) + volFracIceLoss) !print*, 'volFracIceLoss = ', volFracIceLoss @@ -163,12 +163,12 @@ subroutine snwDensify(& ! update depth due to metamorphism (implicit solution) ! Ensure that the new depth is in line with the maximum amount of compaction that ! can occur given the masses of ice and liquid in the layer - scalarDepthNew = scalarDepthNew/(1._dp + CR_metamorph*dt) + scalarDepthNew = scalarDepthNew/(1._summa_prec + CR_metamorph*dt) scalarDepthMin = (massIceOld / iden_ice) + (massLiqOld / iden_water) mLayerDepth(iSnow) = max(scalarDepthMin, scalarDepthNew) ! check that depth is reasonable - if(mLayerDepth(iSnow) < 0._dp)then + if(mLayerDepth(iSnow) < 0._summa_prec)then write(*,'(a,1x,i4,1x,10(f12.5,1x))') 'iSnow, dt, density,massIceOld, massLiqOld = ', iSnow, dt, mLayerVolFracIceNew(iSnow)*iden_ice, massIceOld, massLiqOld write(*,'(a,1x,i4,1x,10(f12.5,1x))') 'iSnow, mLayerDepth(iSnow), scalarDepthNew, mLayerVolFracIceNew(iSnow), mLayerMeltFreeze(iSnow), CR_grainGrowth*dt, CR_ovrvdnPress*dt = ', & iSnow, mLayerDepth(iSnow), scalarDepthNew, mLayerVolFracIceNew(iSnow), mLayerMeltFreeze(iSnow), CR_grainGrowth*dt, CR_ovrvdnPress*dt @@ -177,14 +177,14 @@ subroutine snwDensify(& ! update volumetric ice and liquid water content mLayerVolFracIceNew(iSnow) = massIceOld/(mLayerDepth(iSnow)*iden_ice) mLayerVolFracLiqNew(iSnow) = massLiqOld/(mLayerDepth(iSnow)*iden_water) - mLayerVolFracAirNew(iSnow) = 1.0_dp - mLayerVolFracIceNew(iSnow) - mLayerVolFracLiqNew(iSnow) + mLayerVolFracAirNew(iSnow) = 1.0_summa_prec - mLayerVolFracIceNew(iSnow) - mLayerVolFracLiqNew(iSnow) !write(*,'(a,1x,i4,1x,f9.3)') 'after compact: iSnow, density = ', iSnow, mLayerVolFracIceNew(iSnow)*iden_ice - !if(mLayerMeltFreeze(iSnow) > 20._dp) pause 'meaningful melt' + !if(mLayerMeltFreeze(iSnow) > 20._summa_prec) pause 'meaningful melt' end do ! looping through snow layers ! check depth - if(any(mLayerDepth(1:nSnow) < 0._dp))then + if(any(mLayerDepth(1:nSnow) < 0._summa_prec))then do iSnow=1,nSnow write(*,'(a,1x,i4,1x,4(f12.5,1x))') 'iSnow, mLayerDepth(iSnow)', iSnow, mLayerDepth(iSnow) end do @@ -194,7 +194,7 @@ subroutine snwDensify(& ! check for low/high snow density if(any(mLayerVolFracIceNew(1:nSnow)*iden_ice + mLayerVolFracLiqNew(1:nSnow)*iden_water + mLayerVolFracAirNew(1:nSnow)*iden_air < minLayerDensity) .or. & - any(mLayerVolFracIceNew(1:nSnow) + mLayerVolFracLiqNew(1:nSnow) + mLayerVolFracAirNew(1:nSnow) > 1._dp))then + any(mLayerVolFracIceNew(1:nSnow) + mLayerVolFracLiqNew(1:nSnow) + mLayerVolFracAirNew(1:nSnow) > 1._summa_prec))then do iSnow=1,nSnow write(*,*) 'iSnow, volFracIce, density = ', iSnow, mLayerVolFracIceNew(iSnow), mLayerVolFracIceNew(iSnow)*iden_ice end do diff --git a/build/source/engine/soilLiqFlx.f90 b/build/source/engine/soilLiqFlx.f90 index 52eb06ce6..40e2dd8e4 100755 --- a/build/source/engine/soilLiqFlx.f90 +++ b/build/source/engine/soilLiqFlx.f90 @@ -80,8 +80,8 @@ module soilLiqFlx_module private public::soilLiqFlx ! constant parameters -real(dp),parameter :: verySmall=1.e-12_dp ! a very small number (used to avoid divide by zero) -real(dp),parameter :: dx=1.e-8_dp ! finite difference increment +real(summa_prec),parameter :: verySmall=1.e-12_summa_prec ! a very small number (used to avoid divide by zero) +real(summa_prec),parameter :: dx=1.e-8_summa_prec ! finite difference increment contains @@ -150,17 +150,17 @@ subroutine soilLiqFlx(& logical(lgt),intent(in) :: scalarSolution ! flag to denote if implementing the scalar solution logical(lgt),intent(in) :: deriv_desired ! flag indicating if derivatives are desired ! input: trial model state variables - real(dp),intent(in) :: mLayerTempTrial(:) ! temperature in each layer at the current iteration (m) - real(dp),intent(in) :: mLayerMatricHeadTrial(:) ! matric head in each layer at the current iteration (m) - real(dp),intent(in) :: mLayerVolFracLiqTrial(:) ! volumetric fraction of liquid water at the current iteration (-) - real(dp),intent(in) :: mLayerVolFracIceTrial(:) ! volumetric fraction of ice at the current iteration (-) + real(summa_prec),intent(in) :: mLayerTempTrial(:) ! temperature in each layer at the current iteration (m) + real(summa_prec),intent(in) :: mLayerMatricHeadTrial(:) ! matric head in each layer at the current iteration (m) + real(summa_prec),intent(in) :: mLayerVolFracLiqTrial(:) ! volumetric fraction of liquid water at the current iteration (-) + real(summa_prec),intent(in) :: mLayerVolFracIceTrial(:) ! volumetric fraction of ice at the current iteration (-) ! input: pre-computed derivatves - real(dp),intent(in) :: mLayerdTheta_dTk(:) ! derivative in volumetric liquid water content w.r.t. temperature (K-1) - real(dp),intent(in) :: dPsiLiq_dTemp(:) ! derivative in liquid water matric potential w.r.t. temperature (m K-1) + real(summa_prec),intent(in) :: mLayerdTheta_dTk(:) ! derivative in volumetric liquid water content w.r.t. temperature (K-1) + real(summa_prec),intent(in) :: dPsiLiq_dTemp(:) ! derivative in liquid water matric potential w.r.t. temperature (m K-1) ! input: model fluxes - real(dp),intent(in) :: scalarCanopyTranspiration ! canopy transpiration (kg m-2 s-1) - real(dp),intent(in) :: scalarGroundEvaporation ! ground evaporation (kg m-2 s-1) - real(dp),intent(in) :: scalarRainPlusMelt ! rain plus melt (m s-1) + real(summa_prec),intent(in) :: scalarCanopyTranspiration ! canopy transpiration (kg m-2 s-1) + real(summa_prec),intent(in) :: scalarGroundEvaporation ! ground evaporation (kg m-2 s-1) + real(summa_prec),intent(in) :: scalarRainPlusMelt ! rain plus melt (m s-1) ! input-output: data structures type(var_dlength),intent(in) :: mpar_data ! model parameters type(var_ilength),intent(in) :: indx_data ! state vector geometry @@ -168,25 +168,25 @@ subroutine soilLiqFlx(& type(var_dlength),intent(inout) :: diag_data ! diagnostic variables for a local HRU type(var_dlength),intent(inout) :: flux_data ! model fluxes for a local HRU ! output: diagnostic variables for surface runoff - real(dp),intent(inout) :: xMaxInfilRate ! maximum infiltration rate (m s-1) - real(dp),intent(inout) :: scalarInfilArea ! fraction of unfrozen area where water can infiltrate (-) - real(dp),intent(inout) :: scalarFrozenArea ! fraction of area that is considered impermeable due to soil ice (-) - real(dp),intent(inout) :: scalarSurfaceRunoff ! surface runoff (m s-1) + real(summa_prec),intent(inout) :: xMaxInfilRate ! maximum infiltration rate (m s-1) + real(summa_prec),intent(inout) :: scalarInfilArea ! fraction of unfrozen area where water can infiltrate (-) + real(summa_prec),intent(inout) :: scalarFrozenArea ! fraction of area that is considered impermeable due to soil ice (-) + real(summa_prec),intent(inout) :: scalarSurfaceRunoff ! surface runoff (m s-1) ! output: diagnostic variables for each layer - real(dp),intent(inout) :: mLayerdTheta_dPsi(:) ! derivative in the soil water characteristic w.r.t. psi (m-1) - real(dp),intent(inout) :: mLayerdPsi_dTheta(:) ! derivative in the soil water characteristic w.r.t. theta (m) - real(dp),intent(inout) :: dHydCond_dMatric(:) ! derivative in hydraulic conductivity w.r.t matric head (s-1) + real(summa_prec),intent(inout) :: mLayerdTheta_dPsi(:) ! derivative in the soil water characteristic w.r.t. psi (m-1) + real(summa_prec),intent(inout) :: mLayerdPsi_dTheta(:) ! derivative in the soil water characteristic w.r.t. theta (m) + real(summa_prec),intent(inout) :: dHydCond_dMatric(:) ! derivative in hydraulic conductivity w.r.t matric head (s-1) ! output: liquid fluxes - real(dp),intent(inout) :: scalarSurfaceInfiltration ! surface infiltration rate (m s-1) - real(dp),intent(inout) :: iLayerLiqFluxSoil(0:) ! liquid flux at soil layer interfaces (m s-1) - real(dp),intent(inout) :: mLayerTranspire(:) ! transpiration loss from each soil layer (m s-1) - real(dp),intent(inout) :: mLayerHydCond(:) ! hydraulic conductivity in each soil layer (m s-1) + real(summa_prec),intent(inout) :: scalarSurfaceInfiltration ! surface infiltration rate (m s-1) + real(summa_prec),intent(inout) :: iLayerLiqFluxSoil(0:) ! liquid flux at soil layer interfaces (m s-1) + real(summa_prec),intent(inout) :: mLayerTranspire(:) ! transpiration loss from each soil layer (m s-1) + real(summa_prec),intent(inout) :: mLayerHydCond(:) ! hydraulic conductivity in each soil layer (m s-1) ! output: derivatives in fluxes w.r.t. state variables in the layer above and layer below (m s-1) - real(dp),intent(inout) :: dq_dHydStateAbove(0:) ! derivative in the flux in layer interfaces w.r.t. state variables in the layer above - real(dp),intent(inout) :: dq_dHydStateBelow(0:) ! derivative in the flux in layer interfaces w.r.t. state variables in the layer below + real(summa_prec),intent(inout) :: dq_dHydStateAbove(0:) ! derivative in the flux in layer interfaces w.r.t. state variables in the layer above + real(summa_prec),intent(inout) :: dq_dHydStateBelow(0:) ! derivative in the flux in layer interfaces w.r.t. state variables in the layer below ! output: derivatives in fluxes w.r.t. energy state variables -- now just temperature -- in the layer above and layer below (m s-1 K-1) - real(dp),intent(inout) :: dq_dNrgStateAbove(0:) ! derivatives in the flux w.r.t. temperature in the layer above (m s-1 K-1) - real(dp),intent(inout) :: dq_dNrgStateBelow(0:) ! derivatives in the flux w.r.t. temperature in the layer below (m s-1 K-1) + real(summa_prec),intent(inout) :: dq_dNrgStateAbove(0:) ! derivatives in the flux w.r.t. temperature in the layer above (m s-1 K-1) + real(summa_prec),intent(inout) :: dq_dNrgStateBelow(0:) ! derivatives in the flux w.r.t. temperature in the layer below (m s-1 K-1) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message @@ -208,34 +208,34 @@ subroutine soilLiqFlx(& integer(i4b),parameter :: perturbStateBelow=3 ! named variable to identify the case where we perturb the state layer below integer(i4b) :: ixPerturb ! index of element in 2-element vector to perturb integer(i4b) :: ixOriginal ! index of perturbed element in the original vector - real(dp) :: scalarVolFracLiqTrial ! trial value of volumetric liquid water content (-) - real(dp) :: scalarMatricHeadTrial ! trial value of matric head (m) - real(dp) :: scalarHydCondTrial ! trial value of hydraulic conductivity (m s-1) - real(dp) :: scalarHydCondMicro ! trial value of hydraulic conductivity of micropores (m s-1) - real(dp) :: scalarHydCondMacro ! trial value of hydraulic conductivity of macropores (m s-1) - real(dp) :: scalarFlux ! vertical flux (m s-1) - real(dp) :: scalarFlux_dStateAbove ! vertical flux with perturbation to the state above (m s-1) - real(dp) :: scalarFlux_dStateBelow ! vertical flux with perturbation to the state below (m s-1) + real(summa_prec) :: scalarVolFracLiqTrial ! trial value of volumetric liquid water content (-) + real(summa_prec) :: scalarMatricHeadTrial ! trial value of matric head (m) + real(summa_prec) :: scalarHydCondTrial ! trial value of hydraulic conductivity (m s-1) + real(summa_prec) :: scalarHydCondMicro ! trial value of hydraulic conductivity of micropores (m s-1) + real(summa_prec) :: scalarHydCondMacro ! trial value of hydraulic conductivity of macropores (m s-1) + real(summa_prec) :: scalarFlux ! vertical flux (m s-1) + real(summa_prec) :: scalarFlux_dStateAbove ! vertical flux with perturbation to the state above (m s-1) + real(summa_prec) :: scalarFlux_dStateBelow ! vertical flux with perturbation to the state below (m s-1) ! transpiration sink term - real(dp),dimension(nSoil) :: mLayerTranspireFrac ! fraction of transpiration allocated to each soil layer (-) + real(summa_prec),dimension(nSoil) :: mLayerTranspireFrac ! fraction of transpiration allocated to each soil layer (-) ! diagnostic variables - real(dp),dimension(nSoil) :: iceImpedeFac ! ice impedence factor at layer mid-points (-) - real(dp),dimension(nSoil) :: mLayerDiffuse ! diffusivity at layer mid-point (m2 s-1) - real(dp),dimension(nSoil) :: dHydCond_dVolLiq ! derivative in hydraulic conductivity w.r.t volumetric liquid water content (m s-1) - real(dp),dimension(nSoil) :: dDiffuse_dVolLiq ! derivative in hydraulic diffusivity w.r.t volumetric liquid water content (m2 s-1) - real(dp),dimension(nSoil) :: dHydCond_dTemp ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) - real(dp),dimension(0:nSoil) :: iLayerHydCond ! hydraulic conductivity at layer interface (m s-1) - real(dp),dimension(0:nSoil) :: iLayerDiffuse ! diffusivity at layer interface (m2 s-1) + real(summa_prec),dimension(nSoil) :: iceImpedeFac ! ice impedence factor at layer mid-points (-) + real(summa_prec),dimension(nSoil) :: mLayerDiffuse ! diffusivity at layer mid-point (m2 s-1) + real(summa_prec),dimension(nSoil) :: dHydCond_dVolLiq ! derivative in hydraulic conductivity w.r.t volumetric liquid water content (m s-1) + real(summa_prec),dimension(nSoil) :: dDiffuse_dVolLiq ! derivative in hydraulic diffusivity w.r.t volumetric liquid water content (m2 s-1) + real(summa_prec),dimension(nSoil) :: dHydCond_dTemp ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) + real(summa_prec),dimension(0:nSoil) :: iLayerHydCond ! hydraulic conductivity at layer interface (m s-1) + real(summa_prec),dimension(0:nSoil) :: iLayerDiffuse ! diffusivity at layer interface (m2 s-1) ! compute surface flux integer(i4b) :: nRoots ! number of soil layers with roots integer(i4b) :: ixIce ! index of the lowest soil layer that contains ice - real(dp),dimension(0:nSoil) :: iLayerHeight ! height of the layer interfaces (m) + real(summa_prec),dimension(0:nSoil) :: iLayerHeight ! height of the layer interfaces (m) ! compute fluxes and derivatives at layer interfaces - real(dp),dimension(2) :: vectorVolFracLiqTrial ! trial value of volumetric liquid water content (-) - real(dp),dimension(2) :: vectorMatricHeadTrial ! trial value of matric head (m) - real(dp),dimension(2) :: vectorHydCondTrial ! trial value of hydraulic conductivity (m s-1) - real(dp),dimension(2) :: vectorDiffuseTrial ! trial value of hydraulic diffusivity (m2 s-1) - real(dp) :: scalardPsi_dTheta ! derivative in soil water characteristix, used for perturbations when computing numerical derivatives + real(summa_prec),dimension(2) :: vectorVolFracLiqTrial ! trial value of volumetric liquid water content (-) + real(summa_prec),dimension(2) :: vectorMatricHeadTrial ! trial value of matric head (m) + real(summa_prec),dimension(2) :: vectorHydCondTrial ! trial value of hydraulic conductivity (m s-1) + real(summa_prec),dimension(2) :: vectorDiffuseTrial ! trial value of hydraulic diffusivity (m2 s-1) + real(summa_prec) :: scalardPsi_dTheta ! derivative in soil water characteristix, used for perturbations when computing numerical derivatives ! ------------------------------------------------------------------------------------------------------------------------------------------------- ! initialize error control err=0; message='soilLiqFlx/' @@ -364,7 +364,7 @@ subroutine soilLiqFlx(& end if ! check fractions sum to one - if(abs(sum(mLayerTranspireFrac) - 1._dp) > verySmall)then + if(abs(sum(mLayerTranspireFrac) - 1._summa_prec) > verySmall)then message=trim(message)//'fraction transpiration in soil layers does not sum to one' err=20; return endif @@ -373,7 +373,7 @@ subroutine soilLiqFlx(& mLayerTranspire = mLayerTranspireFrac(:)*scalarCanopyTranspiration/iden_water ! special case of prescribed head -- no transpiration - if(ixBcUpperSoilHydrology==prescribedHead) mLayerTranspire(:) = 0._dp + if(ixBcUpperSoilHydrology==prescribedHead) mLayerTranspire(:) = 0._summa_prec endif ! if need to compute transpiration @@ -435,8 +435,8 @@ subroutine soilLiqFlx(& ! ------------------------------------------------------------------------------------------------------------------------------------------------- ! set derivative w.r.t. state above to zero (does not exist) - dq_dHydStateAbove(0) = 0._dp - dq_dNrgStateAbove(0) = 0._dp + dq_dHydStateAbove(0) = 0._summa_prec + dq_dNrgStateAbove(0) = 0._summa_prec ! either one or multiple flux calls, depending on if using analytical or numerical derivatives do itry=nFlux,0,-1 ! (work backwards to ensure all computed fluxes come from the un-perturbed case) @@ -821,8 +821,8 @@ subroutine soilLiqFlx(& end if ! no dependence on the aquifer for drainage - dq_dHydStateBelow(nSoil) = 0._dp ! keep this here in case we want to couple some day.... - dq_dNrgStateBelow(nSoil) = 0._dp ! keep this here in case we want to couple some day.... + dq_dHydStateBelow(nSoil) = 0._summa_prec ! keep this here in case we want to couple some day.... + dq_dNrgStateBelow(nSoil) = 0._summa_prec ! keep this here in case we want to couple some day.... ! print drainage !print*, 'iLayerLiqFluxSoil(nSoil) = ', iLayerLiqFluxSoil(nSoil) @@ -897,66 +897,66 @@ subroutine diagv_node(& logical(lgt),intent(in) :: deriv_desired ! flag indicating if derivatives are desired integer(i4b),intent(in) :: ixRichards ! index defining the option for Richards' equation (moisture or mixdform) ! input: state and diagnostic variables - real(dp),intent(in) :: scalarTempTrial ! temperature in each layer (K) - real(dp),intent(in) :: scalarMatricHeadTrial ! matric head in each layer (m) - real(dp),intent(in) :: scalarVolFracLiqTrial ! volumetric fraction of liquid water in a given layer (-) - real(dp),intent(in) :: scalarVolFracIceTrial ! volumetric fraction of ice in a given layer (-) + real(summa_prec),intent(in) :: scalarTempTrial ! temperature in each layer (K) + real(summa_prec),intent(in) :: scalarMatricHeadTrial ! matric head in each layer (m) + real(summa_prec),intent(in) :: scalarVolFracLiqTrial ! volumetric fraction of liquid water in a given layer (-) + real(summa_prec),intent(in) :: scalarVolFracIceTrial ! volumetric fraction of ice in a given layer (-) ! input: pre-computed deriavatives - real(dp),intent(in) :: dTheta_dTk ! derivative in volumetric liquid water content w.r.t. temperature (K-1) - real(dp),intent(in) :: dPsiLiq_dTemp ! derivative in liquid water matric potential w.r.t. temperature (m K-1) + real(summa_prec),intent(in) :: dTheta_dTk ! derivative in volumetric liquid water content w.r.t. temperature (K-1) + real(summa_prec),intent(in) :: dPsiLiq_dTemp ! derivative in liquid water matric potential w.r.t. temperature (m K-1) ! input: soil parameters - real(dp),intent(in) :: vGn_alpha ! van Genutchen "alpha" parameter (m-1) - real(dp),intent(in) :: vGn_n ! van Genutchen "n" parameter (-) - real(dp),intent(in) :: vGn_m ! van Genutchen "m" parameter (-) - real(dp),intent(in) :: mpExp ! empirical exponent in macropore flow equation (-) - real(dp),intent(in) :: theta_sat ! soil porosity (-) - real(dp),intent(in) :: theta_res ! soil residual volumetric water content (-) - real(dp),intent(in) :: theta_mp ! volumetric liquid water content when macropore flow begins (-) - real(dp),intent(in) :: f_impede ! ice impedence factor (-) + real(summa_prec),intent(in) :: vGn_alpha ! van Genutchen "alpha" parameter (m-1) + real(summa_prec),intent(in) :: vGn_n ! van Genutchen "n" parameter (-) + real(summa_prec),intent(in) :: vGn_m ! van Genutchen "m" parameter (-) + real(summa_prec),intent(in) :: mpExp ! empirical exponent in macropore flow equation (-) + real(summa_prec),intent(in) :: theta_sat ! soil porosity (-) + real(summa_prec),intent(in) :: theta_res ! soil residual volumetric water content (-) + real(summa_prec),intent(in) :: theta_mp ! volumetric liquid water content when macropore flow begins (-) + real(summa_prec),intent(in) :: f_impede ! ice impedence factor (-) ! input: saturated hydraulic conductivity - real(dp),intent(in) :: scalarSatHydCond ! saturated hydraulic conductivity at the mid-point of a given layer (m s-1) - real(dp),intent(in) :: scalarSatHydCondMP ! saturated hydraulic conductivity of macropores at the mid-point of a given layer (m s-1) + real(summa_prec),intent(in) :: scalarSatHydCond ! saturated hydraulic conductivity at the mid-point of a given layer (m s-1) + real(summa_prec),intent(in) :: scalarSatHydCondMP ! saturated hydraulic conductivity of macropores at the mid-point of a given layer (m s-1) ! output: derivative in the soil water characteristic - real(dp),intent(out) :: scalardPsi_dTheta ! derivative in the soil water characteristic - real(dp),intent(out) :: scalardTheta_dPsi ! derivative in the soil water characteristic + real(summa_prec),intent(out) :: scalardPsi_dTheta ! derivative in the soil water characteristic + real(summa_prec),intent(out) :: scalardTheta_dPsi ! derivative in the soil water characteristic ! output: transmittance - real(dp),intent(out) :: scalarHydCond ! hydraulic conductivity at layer mid-points (m s-1) - real(dp),intent(out) :: scalarDiffuse ! diffusivity at layer mid-points (m2 s-1) - real(dp),intent(out) :: iceImpedeFac ! ice impedence factor in each layer (-) + real(summa_prec),intent(out) :: scalarHydCond ! hydraulic conductivity at layer mid-points (m s-1) + real(summa_prec),intent(out) :: scalarDiffuse ! diffusivity at layer mid-points (m2 s-1) + real(summa_prec),intent(out) :: iceImpedeFac ! ice impedence factor in each layer (-) ! output: transmittance derivatives - real(dp),intent(out) :: dHydCond_dVolLiq ! derivative in hydraulic conductivity w.r.t volumetric liquid water content (m s-1) - real(dp),intent(out) :: dDiffuse_dVolLiq ! derivative in hydraulic diffusivity w.r.t volumetric liquid water content (m2 s-1) - real(dp),intent(out) :: dHydCond_dMatric ! derivative in hydraulic conductivity w.r.t matric head (s-1) - real(dp),intent(out) :: dHydCond_dTemp ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) + real(summa_prec),intent(out) :: dHydCond_dVolLiq ! derivative in hydraulic conductivity w.r.t volumetric liquid water content (m s-1) + real(summa_prec),intent(out) :: dDiffuse_dVolLiq ! derivative in hydraulic diffusivity w.r.t volumetric liquid water content (m2 s-1) + real(summa_prec),intent(out) :: dHydCond_dMatric ! derivative in hydraulic conductivity w.r.t matric head (s-1) + real(summa_prec),intent(out) :: dHydCond_dTemp ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! local variables - real(dp) :: localVolFracLiq ! local volumetric fraction of liquid water - real(dp) :: scalarHydCondMP ! hydraulic conductivity of macropores at layer mid-points (m s-1) - real(dp) :: dIceImpede_dT ! derivative in ice impedance factor w.r.t. temperature (K-1) - real(dp) :: dHydCondMacro_dVolLiq ! derivative in hydraulic conductivity of macropores w.r.t volumetric liquid water content (m s-1) - real(dp) :: dHydCondMacro_dMatric ! derivative in hydraulic conductivity of macropores w.r.t matric head (s-1) - real(dp) :: dHydCondMicro_dMatric ! derivative in hydraulic conductivity of micropores w.r.t matric head (s-1) - real(dp) :: dHydCondMicro_dTemp ! derivative in hydraulic conductivity of micropores w.r.t temperature (m s-1 K-1) - real(dp) :: dPsi_dTheta2a ! derivative in dPsi_dTheta (analytical) - real(dp) :: dIceImpede_dLiq ! derivative in ice impedence factor w.r.t. volumetric liquid water content (-) - real(dp) :: hydCond_noIce ! hydraulic conductivity in the absence of ice (m s-1) - real(dp) :: dK_dLiq__noIce ! derivative in hydraulic conductivity w.r.t volumetric liquid water content, in the absence of ice (m s-1) - real(dp) :: dK_dPsi__noIce ! derivative in hydraulic conductivity w.r.t matric head, in the absence of ice (s-1) - real(dp) :: relSatMP ! relative saturation of macropores (-) + real(summa_prec) :: localVolFracLiq ! local volumetric fraction of liquid water + real(summa_prec) :: scalarHydCondMP ! hydraulic conductivity of macropores at layer mid-points (m s-1) + real(summa_prec) :: dIceImpede_dT ! derivative in ice impedance factor w.r.t. temperature (K-1) + real(summa_prec) :: dHydCondMacro_dVolLiq ! derivative in hydraulic conductivity of macropores w.r.t volumetric liquid water content (m s-1) + real(summa_prec) :: dHydCondMacro_dMatric ! derivative in hydraulic conductivity of macropores w.r.t matric head (s-1) + real(summa_prec) :: dHydCondMicro_dMatric ! derivative in hydraulic conductivity of micropores w.r.t matric head (s-1) + real(summa_prec) :: dHydCondMicro_dTemp ! derivative in hydraulic conductivity of micropores w.r.t temperature (m s-1 K-1) + real(summa_prec) :: dPsi_dTheta2a ! derivative in dPsi_dTheta (analytical) + real(summa_prec) :: dIceImpede_dLiq ! derivative in ice impedence factor w.r.t. volumetric liquid water content (-) + real(summa_prec) :: hydCond_noIce ! hydraulic conductivity in the absence of ice (m s-1) + real(summa_prec) :: dK_dLiq__noIce ! derivative in hydraulic conductivity w.r.t volumetric liquid water content, in the absence of ice (m s-1) + real(summa_prec) :: dK_dPsi__noIce ! derivative in hydraulic conductivity w.r.t matric head, in the absence of ice (s-1) + real(summa_prec) :: relSatMP ! relative saturation of macropores (-) ! local variables to test the derivative logical(lgt),parameter :: testDeriv=.false. ! local flag to test the derivative - real(dp) :: xConst ! LH_fus/(gravity*Tfreeze), used in freezing point depression equation (m K-1) - real(dp) :: vTheta ! volumetric fraction of total water (-) - real(dp) :: volLiq ! volumetric fraction of liquid water (-) - real(dp) :: volIce ! volumetric fraction of ice (-) - real(dp) :: volFracLiq1,volFracLiq2 ! different trial values of volumetric liquid water content (-) - real(dp) :: effSat ! effective saturation (-) - real(dp) :: psiLiq ! liquid water matric potential (m) - real(dp) :: hydCon ! hydraulic conductivity (m s-1) - real(dp) :: hydIce ! hydraulic conductivity after accounting for ice impedance (-) - real(dp),parameter :: dx = 1.e-8_dp ! finite difference increment (m) + real(summa_prec) :: xConst ! LH_fus/(gravity*Tfreeze), used in freezing point depression equation (m K-1) + real(summa_prec) :: vTheta ! volumetric fraction of total water (-) + real(summa_prec) :: volLiq ! volumetric fraction of liquid water (-) + real(summa_prec) :: volIce ! volumetric fraction of ice (-) + real(summa_prec) :: volFracLiq1,volFracLiq2 ! different trial values of volumetric liquid water content (-) + real(summa_prec) :: effSat ! effective saturation (-) + real(summa_prec) :: psiLiq ! liquid water matric potential (m) + real(summa_prec) :: hydCon ! hydraulic conductivity (m s-1) + real(summa_prec) :: hydIce ! hydraulic conductivity after accounting for ice impedance (-) + real(summa_prec),parameter :: dx = 1.e-8_summa_prec ! finite difference increment (m) ! initialize error control err=0; message="diagv_node/" @@ -1020,11 +1020,11 @@ subroutine diagv_node(& ! (compute derivative for macropores) if(localVolFracLiq > theta_mp)then relSatMP = (localVolFracLiq - theta_mp)/(theta_sat - theta_mp) - dHydCondMacro_dVolLiq = ((scalarSatHydCondMP - scalarSatHydCond)/(theta_sat - theta_mp))*mpExp*(relSatMP**(mpExp - 1._dp)) + dHydCondMacro_dVolLiq = ((scalarSatHydCondMP - scalarSatHydCond)/(theta_sat - theta_mp))*mpExp*(relSatMP**(mpExp - 1._summa_prec)) dHydCondMacro_dMatric = scalardTheta_dPsi*dHydCondMacro_dVolLiq else - dHydCondMacro_dVolLiq = 0._dp - dHydCondMacro_dMatric = 0._dp + dHydCondMacro_dVolLiq = 0._summa_prec + dHydCondMacro_dMatric = 0._summa_prec end if ! (compute derivatives for micropores) if(scalarVolFracIceTrial > verySmall)then @@ -1032,7 +1032,7 @@ subroutine diagv_node(& dHydCondMicro_dTemp = dPsiLiq_dTemp*dK_dPsi__noIce ! m s-1 K-1 dHydCondMicro_dMatric = hydCond_noIce*dIceImpede_dLiq*scalardTheta_dPsi + dK_dPsi__noIce*iceImpedeFac else - dHydCondMicro_dTemp = 0._dp + dHydCondMicro_dTemp = 0._summa_prec dHydCondMicro_dMatric = dHydCond_dPsi(scalarMatricHeadTrial,scalarSatHydCond,vGn_alpha,vGn_n,vGn_m,.true.) end if ! (combine derivatives) @@ -1052,7 +1052,7 @@ subroutine diagv_node(& volLiq = volFracLiq(xConst*(scalarTempTrial+dx - Tfreeze),vGn_alpha,theta_res,theta_sat,vGn_n,vGn_m) volIce = vTheta - volLiq effSat = (volLiq - theta_res)/(theta_sat - volIce - theta_res) - psiLiq = matricHead(effSat,vGn_alpha,0._dp,1._dp,vGn_n,vGn_m) ! use effective saturation, so theta_res=0 and theta_sat=1 + psiLiq = matricHead(effSat,vGn_alpha,0._summa_prec,1._summa_prec,vGn_n,vGn_m) ! use effective saturation, so theta_res=0 and theta_sat=1 hydCon = hydCond_psi(psiLiq,scalarSatHydCond,vGn_alpha,vGn_n,vGn_m) call iceImpede(volIce,f_impede,iceImpedeFac,dIceImpede_dLiq) hydIce = hydCon*iceImpedeFac @@ -1150,48 +1150,48 @@ subroutine surfaceFlx(& integer(i4b),intent(in) :: nRoots ! number of layers that contain roots integer(i4b),intent(in) :: ixIce ! index of lowest ice layer ! input: state and diagnostic variables - real(dp),intent(in) :: scalarMatricHead ! matric head in the upper-most soil layer (m) - real(dp),intent(in) :: scalarVolFracLiq ! volumetric liquid water content in the upper-most soil layer (-) - real(dp),intent(in) :: mLayerVolFracLiq(:) ! volumetric liquid water content in each soil layer (-) - real(dp),intent(in) :: mLayerVolFracIce(:) ! volumetric ice content in each soil layer (-) + real(summa_prec),intent(in) :: scalarMatricHead ! matric head in the upper-most soil layer (m) + real(summa_prec),intent(in) :: scalarVolFracLiq ! volumetric liquid water content in the upper-most soil layer (-) + real(summa_prec),intent(in) :: mLayerVolFracLiq(:) ! volumetric liquid water content in each soil layer (-) + real(summa_prec),intent(in) :: mLayerVolFracIce(:) ! volumetric ice content in each soil layer (-) ! input: depth of upper-most soil layer (m) - real(dp),intent(in) :: mLayerDepth(:) ! depth of upper-most soil layer (m) - real(dp),intent(in) :: iLayerHeight(0:) ! height at the interface of each layer (m) + real(summa_prec),intent(in) :: mLayerDepth(:) ! depth of upper-most soil layer (m) + real(summa_prec),intent(in) :: iLayerHeight(0:) ! height at the interface of each layer (m) ! input: diriclet boundary conditions - real(dp),intent(in) :: upperBoundHead ! upper boundary condition for matric head (m) - real(dp),intent(in) :: upperBoundTheta ! upper boundary condition for volumetric liquid water content (-) + real(summa_prec),intent(in) :: upperBoundHead ! upper boundary condition for matric head (m) + real(summa_prec),intent(in) :: upperBoundTheta ! upper boundary condition for volumetric liquid water content (-) ! input: flux at the upper boundary - real(dp),intent(in) :: scalarRainPlusMelt ! rain plus melt, used as input to the soil zone before computing surface runoff (m s-1) + real(summa_prec),intent(in) :: scalarRainPlusMelt ! rain plus melt, used as input to the soil zone before computing surface runoff (m s-1) ! input: transmittance - real(dp),intent(in) :: surfaceSatHydCond ! saturated hydraulic conductivity at the surface (m s-1) - real(dp),intent(in) :: dHydCond_dTemp ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) - real(dp),intent(in) :: iceImpedeFac ! ice impedence factor in the upper-most soil layer (-) + real(summa_prec),intent(in) :: surfaceSatHydCond ! saturated hydraulic conductivity at the surface (m s-1) + real(summa_prec),intent(in) :: dHydCond_dTemp ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) + real(summa_prec),intent(in) :: iceImpedeFac ! ice impedence factor in the upper-most soil layer (-) ! input: soil parameters - real(dp),intent(in) :: vGn_alpha ! van Genutchen "alpha" parameter (m-1) - real(dp),intent(in) :: vGn_n ! van Genutchen "n" parameter (-) - real(dp),intent(in) :: vGn_m ! van Genutchen "m" parameter (-) - real(dp),intent(in) :: theta_sat ! soil porosity (-) - real(dp),intent(in) :: theta_res ! soil residual volumetric water content (-) - real(dp),intent(in) :: qSurfScale ! scaling factor in the surface runoff parameterization (-) - real(dp),intent(in) :: zScale_TOPMODEL ! scaling factor used to describe decrease in hydraulic conductivity with depth (m) - real(dp),intent(in) :: rootingDepth ! rooting depth (m) - real(dp),intent(in) :: wettingFrontSuction ! Green-Ampt wetting front suction (m) - real(dp),intent(in) :: soilIceScale ! soil ice scaling factor in Gamma distribution used to define frozen area (m) - real(dp),intent(in) :: soilIceCV ! soil ice CV in Gamma distribution used to define frozen area (-) + real(summa_prec),intent(in) :: vGn_alpha ! van Genutchen "alpha" parameter (m-1) + real(summa_prec),intent(in) :: vGn_n ! van Genutchen "n" parameter (-) + real(summa_prec),intent(in) :: vGn_m ! van Genutchen "m" parameter (-) + real(summa_prec),intent(in) :: theta_sat ! soil porosity (-) + real(summa_prec),intent(in) :: theta_res ! soil residual volumetric water content (-) + real(summa_prec),intent(in) :: qSurfScale ! scaling factor in the surface runoff parameterization (-) + real(summa_prec),intent(in) :: zScale_TOPMODEL ! scaling factor used to describe decrease in hydraulic conductivity with depth (m) + real(summa_prec),intent(in) :: rootingDepth ! rooting depth (m) + real(summa_prec),intent(in) :: wettingFrontSuction ! Green-Ampt wetting front suction (m) + real(summa_prec),intent(in) :: soilIceScale ! soil ice scaling factor in Gamma distribution used to define frozen area (m) + real(summa_prec),intent(in) :: soilIceCV ! soil ice CV in Gamma distribution used to define frozen area (-) ! ----------------------------------------------------------------------------------------------------------------------------- ! input-output: hydraulic conductivity and diffusivity at the surface ! NOTE: intent(inout) because infiltration may only be computed for the first iteration - real(dp),intent(inout) :: surfaceHydCond ! hydraulic conductivity (m s-1) - real(dp),intent(inout) :: surfaceDiffuse ! hydraulic diffusivity at the surface (m + real(summa_prec),intent(inout) :: surfaceHydCond ! hydraulic conductivity (m s-1) + real(summa_prec),intent(inout) :: surfaceDiffuse ! hydraulic diffusivity at the surface (m ! output: surface runoff and infiltration flux (m s-1) - real(dp),intent(inout) :: xMaxInfilRate ! maximum infiltration rate (m s-1) - real(dp),intent(inout) :: scalarInfilArea ! fraction of unfrozen area where water can infiltrate (-) - real(dp),intent(inout) :: scalarFrozenArea ! fraction of area that is considered impermeable due to soil ice (-) - real(dp),intent(out) :: scalarSurfaceRunoff ! surface runoff (m s-1) - real(dp),intent(out) :: scalarSurfaceInfiltration ! surface infiltration (m s-1) + real(summa_prec),intent(inout) :: xMaxInfilRate ! maximum infiltration rate (m s-1) + real(summa_prec),intent(inout) :: scalarInfilArea ! fraction of unfrozen area where water can infiltrate (-) + real(summa_prec),intent(inout) :: scalarFrozenArea ! fraction of area that is considered impermeable due to soil ice (-) + real(summa_prec),intent(out) :: scalarSurfaceRunoff ! surface runoff (m s-1) + real(summa_prec),intent(out) :: scalarSurfaceInfiltration ! surface infiltration (m s-1) ! output: deriavtives in surface infiltration w.r.t. volumetric liquid water (m s-1) and matric head (s-1) in the upper-most soil layer - real(dp),intent(out) :: dq_dHydState ! derivative in surface infiltration w.r.t. state variable in the upper-most soil layer (m s-1 or s-1) - real(dp),intent(out) :: dq_dNrgState ! derivative in surface infiltration w.r.t. energy state variable in the upper-most soil layer (m s-1 K-1) + real(summa_prec),intent(out) :: dq_dHydState ! derivative in surface infiltration w.r.t. state variable in the upper-most soil layer (m s-1 or s-1) + real(summa_prec),intent(out) :: dq_dNrgState ! derivative in surface infiltration w.r.t. energy state variable in the upper-most soil layer (m s-1 K-1) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message @@ -1200,29 +1200,29 @@ subroutine surfaceFlx(& ! (general) integer(i4b) :: iLayer ! index of soil layer ! (head boundary condition) - real(dp) :: cFlux ! capillary flux (m s-1) - real(dp) :: dNum ! numerical derivative + real(summa_prec) :: cFlux ! capillary flux (m s-1) + real(summa_prec) :: dNum ! numerical derivative ! (simplified Green-Ampt infiltration) - real(dp) :: rootZoneLiq ! depth of liquid water in the root zone (m) - real(dp) :: rootZoneIce ! depth of ice in the root zone (m) - real(dp) :: availCapacity ! available storage capacity in the root zone (m) - real(dp) :: depthWettingFront ! depth to the wetting front (m) - real(dp) :: hydCondWettingFront ! hydraulic conductivity at the wetting front (m s-1) + real(summa_prec) :: rootZoneLiq ! depth of liquid water in the root zone (m) + real(summa_prec) :: rootZoneIce ! depth of ice in the root zone (m) + real(summa_prec) :: availCapacity ! available storage capacity in the root zone (m) + real(summa_prec) :: depthWettingFront ! depth to the wetting front (m) + real(summa_prec) :: hydCondWettingFront ! hydraulic conductivity at the wetting front (m s-1) ! (saturated area associated with variable storage capacity) - real(dp) :: fracCap ! fraction of pore space filled with liquid water and ice (-) - real(dp) :: fInfRaw ! infiltrating area before imposing solution constraints (-) - real(dp),parameter :: maxFracCap=0.995_dp ! maximum fraction capacity -- used to avoid numerical problems associated with an enormous derivative - real(dp),parameter :: scaleFactor=0.000001_dp ! scale factor for the smoothing function (-) - real(dp),parameter :: qSurfScaleMax=1000._dp ! maximum surface runoff scaling factor (-) + real(summa_prec) :: fracCap ! fraction of pore space filled with liquid water and ice (-) + real(summa_prec) :: fInfRaw ! infiltrating area before imposing solution constraints (-) + real(summa_prec),parameter :: maxFracCap=0.995_summa_prec ! maximum fraction capacity -- used to avoid numerical problems associated with an enormous derivative + real(summa_prec),parameter :: scaleFactor=0.000001_summa_prec ! scale factor for the smoothing function (-) + real(summa_prec),parameter :: qSurfScaleMax=1000._summa_prec ! maximum surface runoff scaling factor (-) ! (fraction of impermeable area associated with frozen ground) - real(dp) :: alpha ! shape parameter in the Gamma distribution - real(dp) :: xLimg ! upper limit of the integral + real(summa_prec) :: alpha ! shape parameter in the Gamma distribution + real(summa_prec) :: xLimg ! upper limit of the integral ! initialize error control err=0; message="surfaceFlx/" ! compute derivative in the energy state ! NOTE: revisit the need to do this - dq_dNrgState = 0._dp + dq_dNrgState = 0._summa_prec ! ***** ! compute the surface flux and its derivative @@ -1233,7 +1233,7 @@ subroutine surfaceFlx(& case(prescribedHead) ! surface runoff iz zero for the head condition - scalarSurfaceRunoff = 0._dp + scalarSurfaceRunoff = 0._summa_prec ! compute transmission and the capillary flux select case(ixRichards) ! (form of Richards' equation) @@ -1242,13 +1242,13 @@ subroutine surfaceFlx(& surfaceHydCond = hydCond_liq(upperBoundTheta,surfaceSatHydCond,theta_res,theta_sat,vGn_m) * iceImpedeFac surfaceDiffuse = dPsi_dTheta(upperBoundTheta,vGn_alpha,theta_res,theta_sat,vGn_n,vGn_m) * surfaceHydCond ! compute the capillary flux - cflux = -surfaceDiffuse*(scalarVolFracLiq - upperBoundTheta) / (mLayerDepth(1)*0.5_dp) + cflux = -surfaceDiffuse*(scalarVolFracLiq - upperBoundTheta) / (mLayerDepth(1)*0.5_summa_prec) case(mixdform) ! compute the hydraulic conductivity and diffusivity at the boundary surfaceHydCond = hydCond_psi(upperBoundHead,surfaceSatHydCond,vGn_alpha,vGn_n,vGn_m) * iceImpedeFac surfaceDiffuse = realMissing ! compute the capillary flux - cflux = -surfaceHydCond*(scalarMatricHead - upperBoundHead) / (mLayerDepth(1)*0.5_dp) + cflux = -surfaceHydCond*(scalarMatricHead - upperBoundHead) / (mLayerDepth(1)*0.5_summa_prec) case default; err=10; message=trim(message)//"unknown form of Richards' equation"; return end select ! (form of Richards' eqn) ! compute the total flux @@ -1257,19 +1257,19 @@ subroutine surfaceFlx(& if(deriv_desired)then ! compute the hydrology derivative select case(ixRichards) ! (form of Richards' equation) - case(moisture); dq_dHydState = -surfaceDiffuse/(mLayerDepth(1)/2._dp) - case(mixdform); dq_dHydState = -surfaceHydCond/(mLayerDepth(1)/2._dp) + case(moisture); dq_dHydState = -surfaceDiffuse/(mLayerDepth(1)/2._summa_prec) + case(mixdform); dq_dHydState = -surfaceHydCond/(mLayerDepth(1)/2._summa_prec) case default; err=10; message=trim(message)//"unknown form of Richards' equation"; return end select ! compute the energy derivative - dq_dNrgState = -(dHydCond_dTemp/2._dp)*(scalarMatricHead - upperBoundHead)/(mLayerDepth(1)*0.5_dp) + dHydCond_dTemp/2._dp + dq_dNrgState = -(dHydCond_dTemp/2._summa_prec)*(scalarMatricHead - upperBoundHead)/(mLayerDepth(1)*0.5_summa_prec) + dHydCond_dTemp/2._summa_prec ! compute the numerical derivative - !cflux = -surfaceHydCond*((scalarMatricHead+dx) - upperBoundHead) / (mLayerDepth(1)*0.5_dp) + !cflux = -surfaceHydCond*((scalarMatricHead+dx) - upperBoundHead) / (mLayerDepth(1)*0.5_summa_prec) !surfaceInfiltration1 = cflux + surfaceHydCond !dNum = (surfaceInfiltration1 - scalarSurfaceInfiltration)/dx else - dq_dHydState = 0._dp - dNum = 0._dp + dq_dHydState = 0._summa_prec + dNum = 0._summa_prec end if !write(*,'(a,1x,10(e30.20,1x))') 'scalarMatricHead, scalarSurfaceInfiltration, dq_dHydState, dNum = ', & ! scalarMatricHead, scalarSurfaceInfiltration, dq_dHydState, dNum @@ -1282,8 +1282,8 @@ subroutine surfaceFlx(& if(doInfiltration)then ! define the storage in the root zone (m) - rootZoneLiq = 0._dp - rootZoneIce = 0._dp + rootZoneLiq = 0._summa_prec + rootZoneIce = 0._summa_prec ! (process layers where the roots extend to the bottom of the layer) if(nRoots > 1)then do iLayer=1,nRoots-1 @@ -1306,7 +1306,7 @@ subroutine surfaceFlx(& depthWettingFront = (rootZoneLiq/availCapacity)*rootingDepth ! define the hydraulic conductivity at depth=depthWettingFront (m s-1) - hydCondWettingFront = surfaceSatHydCond * ( (1._dp - depthWettingFront/sum(mLayerDepth))**(zScale_TOPMODEL - 1._dp) ) + hydCondWettingFront = surfaceSatHydCond * ( (1._summa_prec - depthWettingFront/sum(mLayerDepth))**(zScale_TOPMODEL - 1._summa_prec) ) ! define the maximum infiltration rate (m s-1) xMaxInfilRate = hydCondWettingFront*( (wettingFrontSuction + depthWettingFront)/depthWettingFront ) ! maximum infiltration rate (m s-1) @@ -1315,15 +1315,15 @@ subroutine surfaceFlx(& ! define the infiltrating area for the non-frozen part of the cell/basin if(qSurfScale < qSurfScaleMax)then fracCap = rootZoneLiq/(maxFracCap*availCapacity) ! fraction of available root zone filled with water - fInfRaw = 1._dp - exp(-qSurfScale*(1._dp - fracCap)) ! infiltrating area -- allowed to violate solution constraints - scalarInfilArea = min(0.5_dp*(fInfRaw + sqrt(fInfRaw**2._dp + scaleFactor)), 1._dp) ! infiltrating area -- constrained + fInfRaw = 1._summa_prec - exp(-qSurfScale*(1._summa_prec - fracCap)) ! infiltrating area -- allowed to violate solution constraints + scalarInfilArea = min(0.5_summa_prec*(fInfRaw + sqrt(fInfRaw**2._summa_prec + scaleFactor)), 1._summa_prec) ! infiltrating area -- constrained else - scalarInfilArea = 1._dp + scalarInfilArea = 1._summa_prec endif ! check to ensure we are not infiltrating into a fully saturated column if(ixIce 0.9999_dp*theta_sat*sum(mLayerDepth(ixIce+1:nRoots))) scalarInfilArea=0._dp + if(sum(mLayerVolFracLiq(ixIce+1:nRoots)*mLayerDepth(ixIce+1:nRoots)) > 0.9999_summa_prec*theta_sat*sum(mLayerDepth(ixIce+1:nRoots))) scalarInfilArea=0._summa_prec !print*, 'ixIce, nRoots, scalarInfilArea = ', ixIce, nRoots, scalarInfilArea !print*, 'sum(mLayerVolFracLiq(ixIce+1:nRoots)*mLayerDepth(ixIce+1:nRoots)) = ', sum(mLayerVolFracLiq(ixIce+1:nRoots)*mLayerDepth(ixIce+1:nRoots)) !print*, 'theta_sat*sum(mLayerDepth(ixIce+1:nRoots)) = ', theta_sat*sum(mLayerDepth(ixIce+1:nRoots)) @@ -1331,25 +1331,25 @@ subroutine surfaceFlx(& ! define the impermeable area due to frozen ground if(rootZoneIce > tiny(rootZoneIce))then ! (avoid divide by zero) - alpha = 1._dp/(soilIceCV**2._dp) ! shape parameter in the Gamma distribution + alpha = 1._summa_prec/(soilIceCV**2._summa_prec) ! shape parameter in the Gamma distribution xLimg = alpha*soilIceScale/rootZoneIce ! upper limit of the integral - !scalarFrozenArea = 1._dp - gammp(alpha,xLimg) ! fraction of frozen area - scalarFrozenArea = 0._dp + !scalarFrozenArea = 1._summa_prec - gammp(alpha,xLimg) ! fraction of frozen area + scalarFrozenArea = 0._summa_prec else - scalarFrozenArea = 0._dp + scalarFrozenArea = 0._summa_prec end if !print*, 'scalarFrozenArea, rootZoneIce = ', scalarFrozenArea, rootZoneIce end if ! (if desire to compute infiltration) ! compute infiltration (m s-1) - scalarSurfaceInfiltration = (1._dp - scalarFrozenArea)*scalarInfilArea*min(scalarRainPlusMelt,xMaxInfilRate) + scalarSurfaceInfiltration = (1._summa_prec - scalarFrozenArea)*scalarInfilArea*min(scalarRainPlusMelt,xMaxInfilRate) ! compute surface runoff (m s-1) scalarSurfaceRunoff = scalarRainPlusMelt - scalarSurfaceInfiltration !print*, 'scalarRainPlusMelt, xMaxInfilRate = ', scalarRainPlusMelt, xMaxInfilRate !print*, 'scalarSurfaceInfiltration, scalarSurfaceRunoff = ', scalarSurfaceInfiltration, scalarSurfaceRunoff - !print*, '(1._dp - scalarFrozenArea), (1._dp - scalarFrozenArea)*scalarInfilArea = ', (1._dp - scalarFrozenArea), (1._dp - scalarFrozenArea)*scalarInfilArea + !print*, '(1._summa_prec - scalarFrozenArea), (1._summa_prec - scalarFrozenArea)*scalarInfilArea = ', (1._summa_prec - scalarFrozenArea), (1._summa_prec - scalarFrozenArea)*scalarInfilArea ! set surface hydraulic conductivity and diffusivity to missing (not used for flux condition) surfaceHydCond = realMissing @@ -1358,8 +1358,8 @@ subroutine surfaceFlx(& ! set numerical derivative to zero ! NOTE 1: Depends on multiple soil layers and does not jive with the current tridiagonal matrix ! NOTE 2: Need to define the derivative at every call, because intent(out) - dq_dHydState = 0._dp - dq_dNrgState = 0._dp + dq_dHydState = 0._summa_prec + dq_dNrgState = 0._summa_prec ! ***** error check case default; err=20; message=trim(message)//'unknown upper boundary condition for soil hydrology'; return @@ -1409,31 +1409,31 @@ subroutine iLayerFlux(& logical(lgt),intent(in) :: deriv_desired ! flag indicating if derivatives are desired integer(i4b),intent(in) :: ixRichards ! index defining the option for Richards' equation (moisture or mixdform) ! input: state variables - real(dp),intent(in) :: nodeMatricHeadTrial(:) ! matric head at the soil nodes (m) - real(dp),intent(in) :: nodeVolFracLiqTrial(:) ! volumetric fraction of liquid water at the soil nodes (-) + real(summa_prec),intent(in) :: nodeMatricHeadTrial(:) ! matric head at the soil nodes (m) + real(summa_prec),intent(in) :: nodeVolFracLiqTrial(:) ! volumetric fraction of liquid water at the soil nodes (-) ! input: model coordinate variables - real(dp),intent(in) :: nodeHeight(:) ! height at the mid-point of the lower layer (m) + real(summa_prec),intent(in) :: nodeHeight(:) ! height at the mid-point of the lower layer (m) ! input: temperature derivatives - real(dp),intent(in) :: dPsiLiq_dTemp(:) ! derivative in liquid water matric potential w.r.t. temperature (m K-1) - real(dp),intent(in) :: dHydCond_dTemp(:) ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) + real(summa_prec),intent(in) :: dPsiLiq_dTemp(:) ! derivative in liquid water matric potential w.r.t. temperature (m K-1) + real(summa_prec),intent(in) :: dHydCond_dTemp(:) ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) ! input: transmittance - real(dp),intent(in) :: nodeHydCondTrial(:) ! hydraulic conductivity at layer mid-points (m s-1) - real(dp),intent(in) :: nodeDiffuseTrial(:) ! diffusivity at layer mid-points (m2 s-1) + real(summa_prec),intent(in) :: nodeHydCondTrial(:) ! hydraulic conductivity at layer mid-points (m s-1) + real(summa_prec),intent(in) :: nodeDiffuseTrial(:) ! diffusivity at layer mid-points (m2 s-1) ! input: transmittance derivatives - real(dp),intent(in) :: dHydCond_dVolLiq(:) ! derivative in hydraulic conductivity w.r.t volumetric liquid water content (m s-1) - real(dp),intent(in) :: dDiffuse_dVolLiq(:) ! derivative in hydraulic diffusivity w.r.t volumetric liquid water content (m2 s-1) - real(dp),intent(in) :: dHydCond_dMatric(:) ! derivative in hydraulic conductivity w.r.t matric head (m s-1) + real(summa_prec),intent(in) :: dHydCond_dVolLiq(:) ! derivative in hydraulic conductivity w.r.t volumetric liquid water content (m s-1) + real(summa_prec),intent(in) :: dDiffuse_dVolLiq(:) ! derivative in hydraulic diffusivity w.r.t volumetric liquid water content (m2 s-1) + real(summa_prec),intent(in) :: dHydCond_dMatric(:) ! derivative in hydraulic conductivity w.r.t matric head (m s-1) ! output: tranmsmittance at the layer interface (scalars) - real(dp),intent(out) :: iLayerHydCond ! hydraulic conductivity at the interface between layers (m s-1) - real(dp),intent(out) :: iLayerDiffuse ! hydraulic diffusivity at the interface between layers (m2 s-1) + real(summa_prec),intent(out) :: iLayerHydCond ! hydraulic conductivity at the interface between layers (m s-1) + real(summa_prec),intent(out) :: iLayerDiffuse ! hydraulic diffusivity at the interface between layers (m2 s-1) ! output: vertical flux at the layer interface (scalars) - real(dp),intent(out) :: iLayerLiqFluxSoil ! vertical flux of liquid water at the layer interface (m s-1) + real(summa_prec),intent(out) :: iLayerLiqFluxSoil ! vertical flux of liquid water at the layer interface (m s-1) ! output: derivatives in fluxes w.r.t. state variables -- matric head or volumetric lquid water -- in the layer above and layer below (m s-1 or s-1) - real(dp),intent(out) :: dq_dHydStateAbove ! derivatives in the flux w.r.t. matric head or volumetric lquid water in the layer above (m s-1 or s-1) - real(dp),intent(out) :: dq_dHydStateBelow ! derivatives in the flux w.r.t. matric head or volumetric lquid water in the layer below (m s-1 or s-1) + real(summa_prec),intent(out) :: dq_dHydStateAbove ! derivatives in the flux w.r.t. matric head or volumetric lquid water in the layer above (m s-1 or s-1) + real(summa_prec),intent(out) :: dq_dHydStateBelow ! derivatives in the flux w.r.t. matric head or volumetric lquid water in the layer below (m s-1 or s-1) ! output: derivatives in fluxes w.r.t. energy state variables -- now just temperature -- in the layer above and layer below (m s-1 K-1) - real(dp),intent(out) :: dq_dNrgStateAbove ! derivatives in the flux w.r.t. temperature in the layer above (m s-1 K-1) - real(dp),intent(out) :: dq_dNrgStateBelow ! derivatives in the flux w.r.t. temperature in the layer below (m s-1 K-1) + real(summa_prec),intent(out) :: dq_dNrgStateAbove ! derivatives in the flux w.r.t. temperature in the layer above (m s-1 K-1) + real(summa_prec),intent(out) :: dq_dNrgStateBelow ! derivatives in the flux w.r.t. temperature in the layer below (m s-1 K-1) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message @@ -1443,17 +1443,17 @@ subroutine iLayerFlux(& integer(i4b),parameter :: ixLower=2 ! index of lower node in the 2-element vectors logical(lgt),parameter :: useGeometric=.false. ! switch between the arithmetic and geometric mean ! local variables (Darcy flux) - real(dp) :: dPsi ! spatial difference in matric head (m) - real(dp) :: dLiq ! spatial difference in volumetric liquid water (-) - real(dp) :: dz ! spatial difference in layer mid-points (m) - real(dp) :: cflux ! capillary flux (m s-1) + real(summa_prec) :: dPsi ! spatial difference in matric head (m) + real(summa_prec) :: dLiq ! spatial difference in volumetric liquid water (-) + real(summa_prec) :: dz ! spatial difference in layer mid-points (m) + real(summa_prec) :: cflux ! capillary flux (m s-1) ! local variables (derivative in Darcy's flux) - real(dp) :: dHydCondIface_dVolLiqAbove ! derivative in hydraulic conductivity at layer interface w.r.t. volumetric liquid water content in layer above - real(dp) :: dHydCondIface_dVolLiqBelow ! derivative in hydraulic conductivity at layer interface w.r.t. volumetric liquid water content in layer below - real(dp) :: dDiffuseIface_dVolLiqAbove ! derivative in hydraulic diffusivity at layer interface w.r.t. volumetric liquid water content in layer above - real(dp) :: dDiffuseIface_dVolLiqBelow ! derivative in hydraulic diffusivity at layer interface w.r.t. volumetric liquid water content in layer below - real(dp) :: dHydCondIface_dMatricAbove ! derivative in hydraulic conductivity at layer interface w.r.t. matric head in layer above - real(dp) :: dHydCondIface_dMatricBelow ! derivative in hydraulic conductivity at layer interface w.r.t. matric head in layer below + real(summa_prec) :: dHydCondIface_dVolLiqAbove ! derivative in hydraulic conductivity at layer interface w.r.t. volumetric liquid water content in layer above + real(summa_prec) :: dHydCondIface_dVolLiqBelow ! derivative in hydraulic conductivity at layer interface w.r.t. volumetric liquid water content in layer below + real(summa_prec) :: dDiffuseIface_dVolLiqAbove ! derivative in hydraulic diffusivity at layer interface w.r.t. volumetric liquid water content in layer above + real(summa_prec) :: dDiffuseIface_dVolLiqBelow ! derivative in hydraulic diffusivity at layer interface w.r.t. volumetric liquid water content in layer below + real(summa_prec) :: dHydCondIface_dMatricAbove ! derivative in hydraulic conductivity at layer interface w.r.t. matric head in layer above + real(summa_prec) :: dHydCondIface_dMatricBelow ! derivative in hydraulic conductivity at layer interface w.r.t. matric head in layer below ! ------------------------------------------------------------------------------------------------------------------------------------------------------------------------ ! initialize error control err=0; message="iLayerFlux/" @@ -1462,9 +1462,9 @@ subroutine iLayerFlux(& ! compute the vertical flux of liquid water ! compute the hydraulic conductivity at the interface if(useGeometric)then - iLayerHydCond = (nodeHydCondTrial(ixLower) * nodeHydCondTrial(ixUpper))**0.5_dp + iLayerHydCond = (nodeHydCondTrial(ixLower) * nodeHydCondTrial(ixUpper))**0.5_summa_prec else - iLayerHydCond = (nodeHydCondTrial(ixLower) + nodeHydCondTrial(ixUpper))*0.5_dp + iLayerHydCond = (nodeHydCondTrial(ixLower) + nodeHydCondTrial(ixUpper))*0.5_summa_prec end if !write(*,'(a,1x,5(e20.10,1x))') 'in iLayerFlux: iLayerHydCond, iLayerHydCondMP = ', iLayerHydCond, iLayerHydCondMP ! compute the height difference between nodes @@ -1472,7 +1472,7 @@ subroutine iLayerFlux(& ! compute the capillary flux select case(ixRichards) ! (form of Richards' equation) case(moisture) - iLayerDiffuse = (nodeDiffuseTrial(ixLower) * nodeDiffuseTrial(ixUpper))**0.5_dp + iLayerDiffuse = (nodeDiffuseTrial(ixLower) * nodeDiffuseTrial(ixUpper))**0.5_summa_prec dLiq = nodeVolFracLiqTrial(ixLower) - nodeVolFracLiqTrial(ixUpper) cflux = -iLayerDiffuse * dLiq/dz case(mixdform) @@ -1496,29 +1496,29 @@ subroutine iLayerFlux(& err=20; return end if ! derivatives in hydraulic conductivity at the layer interface (m s-1) - dHydCondIface_dVolLiqAbove = dHydCond_dVolLiq(ixUpper)*nodeHydCondTrial(ixLower) * 0.5_dp/max(iLayerHydCond,verySmall) - dHydCondIface_dVolLiqBelow = dHydCond_dVolLiq(ixLower)*nodeHydCondTrial(ixUpper) * 0.5_dp/max(iLayerHydCond,verySmall) + dHydCondIface_dVolLiqAbove = dHydCond_dVolLiq(ixUpper)*nodeHydCondTrial(ixLower) * 0.5_summa_prec/max(iLayerHydCond,verySmall) + dHydCondIface_dVolLiqBelow = dHydCond_dVolLiq(ixLower)*nodeHydCondTrial(ixUpper) * 0.5_summa_prec/max(iLayerHydCond,verySmall) ! derivatives in hydraulic diffusivity at the layer interface (m2 s-1) - dDiffuseIface_dVolLiqAbove = dDiffuse_dVolLiq(ixUpper)*nodeDiffuseTrial(ixLower) * 0.5_dp/max(iLayerDiffuse,verySmall) - dDiffuseIface_dVolLiqBelow = dDiffuse_dVolLiq(ixLower)*nodeDiffuseTrial(ixUpper) * 0.5_dp/max(iLayerDiffuse,verySmall) + dDiffuseIface_dVolLiqAbove = dDiffuse_dVolLiq(ixUpper)*nodeDiffuseTrial(ixLower) * 0.5_summa_prec/max(iLayerDiffuse,verySmall) + dDiffuseIface_dVolLiqBelow = dDiffuse_dVolLiq(ixLower)*nodeDiffuseTrial(ixUpper) * 0.5_summa_prec/max(iLayerDiffuse,verySmall) ! derivatives in the flux w.r.t. volumetric liquid water content dq_dHydStateAbove = -dDiffuseIface_dVolLiqAbove*dLiq/dz + iLayerDiffuse/dz + dHydCondIface_dVolLiqAbove dq_dHydStateBelow = -dDiffuseIface_dVolLiqBelow*dLiq/dz - iLayerDiffuse/dz + dHydCondIface_dVolLiqBelow case(mixdform) ! derivatives in hydraulic conductivity if(useGeometric)then - dHydCondIface_dMatricAbove = dHydCond_dMatric(ixUpper)*nodeHydCondTrial(ixLower) * 0.5_dp/max(iLayerHydCond,verySmall) - dHydCondIface_dMatricBelow = dHydCond_dMatric(ixLower)*nodeHydCondTrial(ixUpper) * 0.5_dp/max(iLayerHydCond,verySmall) + dHydCondIface_dMatricAbove = dHydCond_dMatric(ixUpper)*nodeHydCondTrial(ixLower) * 0.5_summa_prec/max(iLayerHydCond,verySmall) + dHydCondIface_dMatricBelow = dHydCond_dMatric(ixLower)*nodeHydCondTrial(ixUpper) * 0.5_summa_prec/max(iLayerHydCond,verySmall) else - dHydCondIface_dMatricAbove = dHydCond_dMatric(ixUpper)/2._dp - dHydCondIface_dMatricBelow = dHydCond_dMatric(ixLower)/2._dp + dHydCondIface_dMatricAbove = dHydCond_dMatric(ixUpper)/2._summa_prec + dHydCondIface_dMatricBelow = dHydCond_dMatric(ixLower)/2._summa_prec end if ! derivatives in the flux w.r.t. matric head dq_dHydStateAbove = -dHydCondIface_dMatricAbove*dPsi/dz + iLayerHydCond/dz + dHydCondIface_dMatricAbove dq_dHydStateBelow = -dHydCondIface_dMatricBelow*dPsi/dz - iLayerHydCond/dz + dHydCondIface_dMatricBelow ! derivative in the flux w.r.t. temperature - dq_dNrgStateAbove = -(dHydCond_dTemp(ixUpper)/2._dp)*dPsi/dz + iLayerHydCond*dPsiLiq_dTemp(ixUpper)/dz + dHydCond_dTemp(ixUpper)/2._dp - dq_dNrgStateBelow = -(dHydCond_dTemp(ixLower)/2._dp)*dPsi/dz - iLayerHydCond*dPsiLiq_dTemp(ixLower)/dz + dHydCond_dTemp(ixLower)/2._dp + dq_dNrgStateAbove = -(dHydCond_dTemp(ixUpper)/2._summa_prec)*dPsi/dz + iLayerHydCond*dPsiLiq_dTemp(ixUpper)/dz + dHydCond_dTemp(ixUpper)/2._summa_prec + dq_dNrgStateBelow = -(dHydCond_dTemp(ixLower)/2._summa_prec)*dPsi/dz - iLayerHydCond*dPsiLiq_dTemp(ixLower)/dz + dHydCond_dTemp(ixLower)/2._summa_prec case default; err=10; message=trim(message)//"unknown form of Richards' equation"; return end select else @@ -1588,50 +1588,50 @@ subroutine qDrainFlux(& integer(i4b),intent(in) :: ixRichards ! index defining the option for Richards' equation (moisture or mixdform) integer(i4b),intent(in) :: bc_lower ! index defining the type of boundary conditions ! input: state and diagnostic variables - real(dp),intent(in) :: nodeMatricHead ! matric head in the lowest unsaturated node (m) - real(dp),intent(in) :: nodeVolFracLiq ! volumetric liquid water content in the lowest unsaturated node (-) + real(summa_prec),intent(in) :: nodeMatricHead ! matric head in the lowest unsaturated node (m) + real(summa_prec),intent(in) :: nodeVolFracLiq ! volumetric liquid water content in the lowest unsaturated node (-) ! input: model coordinate variables - real(dp),intent(in) :: nodeDepth ! depth of the lowest unsaturated soil layer (m) - real(dp),intent(in) :: nodeHeight ! height of the lowest unsaturated soil node (m) + real(summa_prec),intent(in) :: nodeDepth ! depth of the lowest unsaturated soil layer (m) + real(summa_prec),intent(in) :: nodeHeight ! height of the lowest unsaturated soil node (m) ! input: diriclet boundary conditions - real(dp),intent(in) :: lowerBoundHead ! lower boundary condition for matric head (m) - real(dp),intent(in) :: lowerBoundTheta ! lower boundary condition for volumetric liquid water content (-) + real(summa_prec),intent(in) :: lowerBoundHead ! lower boundary condition for matric head (m) + real(summa_prec),intent(in) :: lowerBoundTheta ! lower boundary condition for volumetric liquid water content (-) ! input: derivative in soil water characteristix - real(dp),intent(in) :: node__dPsi_dTheta ! derivative of the soil moisture characteristic w.r.t. theta (m) + real(summa_prec),intent(in) :: node__dPsi_dTheta ! derivative of the soil moisture characteristic w.r.t. theta (m) ! input: transmittance - real(dp),intent(in) :: surfaceSatHydCond ! saturated hydraulic conductivity at the surface (m s-1) - real(dp),intent(in) :: bottomSatHydCond ! saturated hydraulic conductivity at the bottom of the unsaturated zone (m s-1) - real(dp),intent(in) :: nodeHydCond ! hydraulic conductivity at the node itself (m s-1) - real(dp),intent(in) :: iceImpedeFac ! ice impedence factor in the upper-most soil layer (-) + real(summa_prec),intent(in) :: surfaceSatHydCond ! saturated hydraulic conductivity at the surface (m s-1) + real(summa_prec),intent(in) :: bottomSatHydCond ! saturated hydraulic conductivity at the bottom of the unsaturated zone (m s-1) + real(summa_prec),intent(in) :: nodeHydCond ! hydraulic conductivity at the node itself (m s-1) + real(summa_prec),intent(in) :: iceImpedeFac ! ice impedence factor in the upper-most soil layer (-) ! input: transmittance derivatives - real(dp),intent(in) :: dHydCond_dVolLiq ! derivative in hydraulic conductivity w.r.t. volumetric liquid water content (m s-1) - real(dp),intent(in) :: dHydCond_dMatric ! derivative in hydraulic conductivity w.r.t. matric head (s-1) - real(dp),intent(in) :: dHydCond_dTemp ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) + real(summa_prec),intent(in) :: dHydCond_dVolLiq ! derivative in hydraulic conductivity w.r.t. volumetric liquid water content (m s-1) + real(summa_prec),intent(in) :: dHydCond_dMatric ! derivative in hydraulic conductivity w.r.t. matric head (s-1) + real(summa_prec),intent(in) :: dHydCond_dTemp ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) ! input: soil parameters - real(dp),intent(in) :: vGn_alpha ! van Genutchen "alpha" parameter (m-1) - real(dp),intent(in) :: vGn_n ! van Genutchen "n" parameter (-) - real(dp),intent(in) :: vGn_m ! van Genutchen "m" parameter (-) - real(dp),intent(in) :: theta_sat ! soil porosity (-) - real(dp),intent(in) :: theta_res ! soil residual volumetric water content (-) - real(dp),intent(in) :: kAnisotropic ! anisotropy factor for lateral hydraulic conductivity (-) - real(dp),intent(in) :: zScale_TOPMODEL ! scale factor for TOPMODEL-ish baseflow parameterization (m) + real(summa_prec),intent(in) :: vGn_alpha ! van Genutchen "alpha" parameter (m-1) + real(summa_prec),intent(in) :: vGn_n ! van Genutchen "n" parameter (-) + real(summa_prec),intent(in) :: vGn_m ! van Genutchen "m" parameter (-) + real(summa_prec),intent(in) :: theta_sat ! soil porosity (-) + real(summa_prec),intent(in) :: theta_res ! soil residual volumetric water content (-) + real(summa_prec),intent(in) :: kAnisotropic ! anisotropy factor for lateral hydraulic conductivity (-) + real(summa_prec),intent(in) :: zScale_TOPMODEL ! scale factor for TOPMODEL-ish baseflow parameterization (m) ! ----------------------------------------------------------------------------------------------------------------------------- ! output: hydraulic conductivity at the bottom of the unsaturated zone - real(dp),intent(out) :: bottomHydCond ! hydraulic conductivity at the bottom of the unsaturated zone (m s-1) - real(dp),intent(out) :: bottomDiffuse ! hydraulic diffusivity at the bottom of the unsatuarted zone (m2 s-1) + real(summa_prec),intent(out) :: bottomHydCond ! hydraulic conductivity at the bottom of the unsaturated zone (m s-1) + real(summa_prec),intent(out) :: bottomDiffuse ! hydraulic diffusivity at the bottom of the unsatuarted zone (m2 s-1) ! output: drainage flux from the bottom of the soil profile - real(dp),intent(out) :: scalarDrainage ! drainage flux from the bottom of the soil profile (m s-1) + real(summa_prec),intent(out) :: scalarDrainage ! drainage flux from the bottom of the soil profile (m s-1) ! output: derivatives in drainage flux - real(dp),intent(out) :: dq_dHydStateUnsat ! change in drainage flux w.r.t. change in state variable in lowest unsaturated node (m s-1 or s-1) - real(dp),intent(out) :: dq_dNrgStateUnsat ! change in drainage flux w.r.t. change in energy state variable in lowest unsaturated node (m s-1 K-1) + real(summa_prec),intent(out) :: dq_dHydStateUnsat ! change in drainage flux w.r.t. change in state variable in lowest unsaturated node (m s-1 or s-1) + real(summa_prec),intent(out) :: dq_dNrgStateUnsat ! change in drainage flux w.r.t. change in energy state variable in lowest unsaturated node (m s-1 K-1) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! ----------------------------------------------------------------------------------------------------------------------------- ! local variables - real(dp) :: zWater ! effective water table depth (m) - real(dp) :: nodePsi ! matric head in the lowest unsaturated node (m) - real(dp) :: cflux ! capillary flux (m s-1) + real(summa_prec) :: zWater ! effective water table depth (m) + real(summa_prec) :: nodePsi ! matric head in the lowest unsaturated node (m) + real(summa_prec) :: cflux ! capillary flux (m s-1) ! ----------------------------------------------------------------------------------------------------------------------------- ! initialize error control err=0; message="qDrainFlux/" @@ -1651,13 +1651,13 @@ subroutine qDrainFlux(& bottomHydCond = hydCond_liq(lowerBoundTheta,bottomSatHydCond,theta_res,theta_sat,vGn_m) * iceImpedeFac bottomDiffuse = dPsi_dTheta(lowerBoundTheta,vGn_alpha,theta_res,theta_sat,vGn_n,vGn_m) * bottomHydCond ! compute the capillary flux - cflux = -bottomDiffuse*(lowerBoundTheta - nodeVolFracLiq) / (nodeDepth*0.5_dp) + cflux = -bottomDiffuse*(lowerBoundTheta - nodeVolFracLiq) / (nodeDepth*0.5_summa_prec) case(mixdform) ! compute the hydraulic conductivity and diffusivity at the boundary bottomHydCond = hydCond_psi(lowerBoundHead,bottomSatHydCond,vGn_alpha,vGn_n,vGn_m) * iceImpedeFac bottomDiffuse = realMissing ! compute the capillary flux - cflux = -bottomHydCond*(lowerBoundHead - nodeMatricHead) / (nodeDepth*0.5_dp) + cflux = -bottomHydCond*(lowerBoundHead - nodeMatricHead) / (nodeDepth*0.5_summa_prec) case default; err=10; message=trim(message)//"unknown form of Richards' equation"; return end select ! (form of Richards' eqn) scalarDrainage = cflux + bottomHydCond @@ -1666,12 +1666,12 @@ subroutine qDrainFlux(& if(deriv_desired)then ! hydrology derivatives select case(ixRichards) ! (form of Richards' equation) - case(moisture); dq_dHydStateUnsat = bottomDiffuse/(nodeDepth/2._dp) - case(mixdform); dq_dHydStateUnsat = bottomHydCond/(nodeDepth/2._dp) + case(moisture); dq_dHydStateUnsat = bottomDiffuse/(nodeDepth/2._summa_prec) + case(mixdform); dq_dHydStateUnsat = bottomHydCond/(nodeDepth/2._summa_prec) case default; err=10; message=trim(message)//"unknown form of Richards' equation"; return end select ! energy derivatives - dq_dNrgStateUnsat = -(dHydCond_dTemp/2._dp)*(lowerBoundHead - nodeMatricHead)/(nodeDepth*0.5_dp) + dHydCond_dTemp/2._dp + dq_dNrgStateUnsat = -(dHydCond_dTemp/2._summa_prec)*(lowerBoundHead - nodeMatricHead)/(nodeDepth*0.5_summa_prec) + dHydCond_dTemp/2._summa_prec else ! (do not desire derivatives) dq_dHydStateUnsat = realMissing dq_dNrgStateUnsat = realMissing @@ -1733,10 +1733,10 @@ subroutine qDrainFlux(& ! * zero flux ! --------------------------------------------------------------------------------------------- case(zeroFlux) - scalarDrainage = 0._dp + scalarDrainage = 0._summa_prec if(deriv_desired)then - dq_dHydStateUnsat = 0._dp - dq_dNrgStateUnsat = 0._dp + dq_dHydStateUnsat = 0._summa_prec + dq_dNrgStateUnsat = 0._summa_prec else dq_dHydStateUnsat = realMissing dq_dNrgStateUnsat = realMissing diff --git a/build/source/engine/soil_utils.f90 b/build/source/engine/soil_utils.f90 index 747618ed4..012cfb11c 100755 --- a/build/source/engine/soil_utils.f90 +++ b/build/source/engine/soil_utils.f90 @@ -52,9 +52,9 @@ module soil_utils_module public::gammp ! constant parameters -real(dp),parameter :: valueMissing=-9999._dp ! missing value parameter -real(dp),parameter :: verySmall=epsilon(1.0_dp) ! a very small number (used to avoid divide by zero) -real(dp),parameter :: dx=-1.e-12_dp ! finite difference increment +real(summa_prec),parameter :: valueMissing=-9999._summa_prec ! missing value parameter +real(summa_prec),parameter :: verySmall=epsilon(1.0_summa_prec) ! a very small number (used to avoid divide by zero) +real(summa_prec),parameter :: dx=-1.e-12_summa_prec ! finite difference increment contains @@ -66,14 +66,14 @@ subroutine iceImpede(volFracIce,f_impede, & ! input ! computes the ice impedence factor (separate function, as used multiple times) implicit none ! input variables - real(dp),intent(in) :: volFracIce ! volumetric fraction of ice (-) - real(dp),intent(in) :: f_impede ! ice impedence parameter (-) + real(summa_prec),intent(in) :: volFracIce ! volumetric fraction of ice (-) + real(summa_prec),intent(in) :: f_impede ! ice impedence parameter (-) ! output variables - real(dp) :: iceImpedeFactor ! ice impedence factor (-) - real(dp) :: dIceImpede_dLiq ! derivative in ice impedence factor w.r.t. volumetric liquid water content (-) + real(summa_prec) :: iceImpedeFactor ! ice impedence factor (-) + real(summa_prec) :: dIceImpede_dLiq ! derivative in ice impedence factor w.r.t. volumetric liquid water content (-) ! compute ice impedance factor as a function of volumetric ice content - iceImpedeFactor = 10._dp**(-f_impede*volFracIce) - dIceImpede_dLiq = 0._dp + iceImpedeFactor = 10._summa_prec**(-f_impede*volFracIce) + dIceImpede_dLiq = 0._summa_prec end subroutine iceImpede @@ -85,13 +85,13 @@ subroutine dIceImpede_dTemp(volFracIce,dTheta_dT,f_impede,dIceImpede_dT) ! computes the derivative in the ice impedance factor w.r.t. temperature implicit none ! input variables - real(dp),intent(in) :: volFracIce ! volumetric fraction of ice (-) - real(dp),intent(in) :: dTheta_dT ! derivative in volumetric liquid water content w.r.t temperature (K-1) - real(dp),intent(in) :: f_impede ! ice impedence parameter (-) + real(summa_prec),intent(in) :: volFracIce ! volumetric fraction of ice (-) + real(summa_prec),intent(in) :: dTheta_dT ! derivative in volumetric liquid water content w.r.t temperature (K-1) + real(summa_prec),intent(in) :: f_impede ! ice impedence parameter (-) ! output variables - real(dp) :: dIceImpede_dT ! derivative in the ice impedance factor w.r.t. temperature (K-1) + real(summa_prec) :: dIceImpede_dT ! derivative in the ice impedance factor w.r.t. temperature (K-1) ! -- - dIceImpede_dT = log(10._dp)*f_impede*(10._dp**(-f_impede*volFracIce))*dTheta_dT + dIceImpede_dT = log(10._summa_prec)*f_impede*(10._summa_prec**(-f_impede*volFracIce))*dTheta_dT end subroutine dIceImpede_dTemp @@ -114,30 +114,30 @@ subroutine liquidHead(& ! computes the liquid water matric potential (and the derivatives w.r.t. total matric potential and temperature) implicit none ! input - real(dp),intent(in) :: matricHeadTotal ! total water matric potential (m) - real(dp),intent(in) :: volFracLiq ! volumetric fraction of liquid water (-) - real(dp),intent(in) :: volFracIce ! volumetric fraction of ice (-) - real(dp),intent(in) :: vGn_alpha,vGn_n,theta_sat,theta_res,vGn_m ! soil parameters - real(dp),intent(in) ,optional :: dVolTot_dPsi0 ! derivative in the soil water characteristic (m-1) - real(dp),intent(in) ,optional :: dTheta_dT ! derivative in volumetric total water w.r.t. temperature (K-1) + real(summa_prec),intent(in) :: matricHeadTotal ! total water matric potential (m) + real(summa_prec),intent(in) :: volFracLiq ! volumetric fraction of liquid water (-) + real(summa_prec),intent(in) :: volFracIce ! volumetric fraction of ice (-) + real(summa_prec),intent(in) :: vGn_alpha,vGn_n,theta_sat,theta_res,vGn_m ! soil parameters + real(summa_prec),intent(in) ,optional :: dVolTot_dPsi0 ! derivative in the soil water characteristic (m-1) + real(summa_prec),intent(in) ,optional :: dTheta_dT ! derivative in volumetric total water w.r.t. temperature (K-1) ! output - real(dp),intent(out) :: matricHeadLiq ! liquid water matric potential (m) - real(dp),intent(out) ,optional :: dPsiLiq_dPsi0 ! derivative in the liquid water matric potential w.r.t. the total water matric potential (-) - real(dp),intent(out) ,optional :: dPsiLiq_dTemp ! derivative in the liquid water matric potential w.r.t. temperature (m K-1) + real(summa_prec),intent(out) :: matricHeadLiq ! liquid water matric potential (m) + real(summa_prec),intent(out) ,optional :: dPsiLiq_dPsi0 ! derivative in the liquid water matric potential w.r.t. the total water matric potential (-) + real(summa_prec),intent(out) ,optional :: dPsiLiq_dTemp ! derivative in the liquid water matric potential w.r.t. temperature (m K-1) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! local - real(dp) :: xNum,xDen ! temporary variables (numeratir, denominator) - real(dp) :: effSat ! effective saturation (-) - real(dp) :: dPsiLiq_dEffSat ! derivative in liquid water matric potential w.r.t. effective saturation (m) - real(dp) :: dEffSat_dTemp ! derivative in effective saturation w.r.t. temperature (K-1) + real(summa_prec) :: xNum,xDen ! temporary variables (numeratir, denominator) + real(summa_prec) :: effSat ! effective saturation (-) + real(summa_prec) :: dPsiLiq_dEffSat ! derivative in liquid water matric potential w.r.t. effective saturation (m) + real(summa_prec) :: dEffSat_dTemp ! derivative in effective saturation w.r.t. temperature (K-1) ! ------------------------------------------------------------------------------------------------------------------------------ ! initialize error control err=0; message='liquidHead/' ! ** partially frozen soil - if(volFracIce > verySmall .and. matricHeadTotal < 0._dp)then ! check that ice exists and that the soil is unsaturated + if(volFracIce > verySmall .and. matricHeadTotal < 0._summa_prec)then ! check that ice exists and that the soil is unsaturated ! ----- ! - compute liquid water matric potential... @@ -151,11 +151,11 @@ subroutine liquidHead(& effSat = xNum/xDen ! effective saturation ! - matric head associated with liquid water - matricHeadLiq = matricHead(effSat,vGn_alpha,0._dp,1._dp,vGn_n,vGn_m) ! argument is effective saturation, so theta_res=0 and theta_sat=1 + matricHeadLiq = matricHead(effSat,vGn_alpha,0._summa_prec,1._summa_prec,vGn_n,vGn_m) ! argument is effective saturation, so theta_res=0 and theta_sat=1 ! compute derivative in liquid water matric potential w.r.t. effective saturation (m) if(present(dPsiLiq_dPsi0).or.present(dPsiLiq_dTemp))then - dPsiLiq_dEffSat = dPsi_dTheta(effSat,vGn_alpha,0._dp,1._dp,vGn_n,vGn_m) + dPsiLiq_dEffSat = dPsi_dTheta(effSat,vGn_alpha,0._summa_prec,1._summa_prec,vGn_n,vGn_m) endif ! ----- @@ -172,7 +172,7 @@ subroutine liquidHead(& endif ! (compute derivative in the liquid water matric potential w.r.t. the total water matric potential) - dPsiLiq_dPsi0 = dVolTot_dPsi0*dPsiLiq_dEffSat*xNum/(xDen**2._dp) + dPsiLiq_dPsi0 = dVolTot_dPsi0*dPsiLiq_dEffSat*xNum/(xDen**2._summa_prec) endif ! if dPsiLiq_dTemp is desired @@ -190,7 +190,7 @@ subroutine liquidHead(& endif ! (compute the derivative in the liquid water matric potential w.r.t. temperature) - dEffSat_dTemp = -dTheta_dT*xNum/(xDen**2._dp) + dTheta_dT/xDen + dEffSat_dTemp = -dTheta_dT*xNum/(xDen**2._summa_prec) + dTheta_dT/xDen dPsiLiq_dTemp = dPsiLiq_dEffSat*dEffSat_dTemp endif ! if dPsiLiq_dTemp is desired @@ -198,8 +198,8 @@ subroutine liquidHead(& ! ** unfrozen soil else ! (no ice) matricHeadLiq = matricHeadTotal - if(present(dPsiLiq_dTemp)) dPsiLiq_dPsi0 = 1._dp ! derivative=1 because values are identical - if(present(dPsiLiq_dTemp)) dPsiLiq_dTemp = 0._dp ! derivative=0 because no impact of temperature for unfrozen conditions + if(present(dPsiLiq_dTemp)) dPsiLiq_dPsi0 = 1._summa_prec ! derivative=1 because values are identical + if(present(dPsiLiq_dTemp)) dPsiLiq_dTemp = 0._summa_prec ! derivative=0 because no impact of temperature for unfrozen conditions end if ! (if ice exists) end subroutine liquidHead @@ -212,20 +212,20 @@ function hydCondMP_liq(volFracLiq,theta_sat,theta_mp,mpExp,satHydCond_ma,satHydC ! theta_sat, theta_mp, mpExp, satHydCond_ma, and satHydCond_mi implicit none ! dummies - real(dp),intent(in) :: volFracLiq ! volumetric liquid water content (-) - real(dp),intent(in) :: theta_sat ! soil porosity (-) - real(dp),intent(in) :: theta_mp ! minimum volumetric liquid water content for macropore flow (-) - real(dp),intent(in) :: mpExp ! empirical exponent in macropore flow equation (-) - real(dp),intent(in) :: satHydCond_ma ! saturated hydraulic conductivity for macropores (m s-1) - real(dp),intent(in) :: satHydCond_mi ! saturated hydraulic conductivity for micropores (m s-1) - real(dp) :: hydCondMP_liq ! hydraulic conductivity (m s-1) + real(summa_prec),intent(in) :: volFracLiq ! volumetric liquid water content (-) + real(summa_prec),intent(in) :: theta_sat ! soil porosity (-) + real(summa_prec),intent(in) :: theta_mp ! minimum volumetric liquid water content for macropore flow (-) + real(summa_prec),intent(in) :: mpExp ! empirical exponent in macropore flow equation (-) + real(summa_prec),intent(in) :: satHydCond_ma ! saturated hydraulic conductivity for macropores (m s-1) + real(summa_prec),intent(in) :: satHydCond_mi ! saturated hydraulic conductivity for micropores (m s-1) + real(summa_prec) :: hydCondMP_liq ! hydraulic conductivity (m s-1) ! locals - real(dp) :: theta_e ! effective soil moisture + real(summa_prec) :: theta_e ! effective soil moisture if(volFracLiq > theta_mp)then theta_e = (volFracLiq - theta_mp) / (theta_sat - theta_mp) hydCondMP_liq = (satHydCond_ma - satHydCond_mi) * (theta_e**mpExp) else - hydCondMP_liq = 0._dp + hydCondMP_liq = 0._summa_prec end if !write(*,'(a,4(f9.3,1x),2(e20.10))') 'in soil_utils: theta_mp, theta_sat, volFracLiq, hydCondMP_liq, satHydCond_ma, satHydCond_mi = ', & ! theta_mp, theta_sat, volFracLiq, hydCondMP_liq, satHydCond_ma, satHydCond_mi @@ -239,16 +239,16 @@ function hydCond_psi(psi,k_sat,alpha,n,m) ! computes hydraulic conductivity given psi and soil hydraulic parameters k_sat, alpha, n, and m implicit none ! dummies - real(dp),intent(in) :: psi ! soil water suction (m) - real(dp),intent(in) :: k_sat ! saturated hydraulic conductivity (m s-1) - real(dp),intent(in) :: alpha ! scaling parameter (m-1) - real(dp),intent(in) :: n ! vGn "n" parameter (-) - real(dp),intent(in) :: m ! vGn "m" parameter (-) - real(dp) :: hydCond_psi ! hydraulic conductivity (m s-1) - if(psi<0._dp)then + real(summa_prec),intent(in) :: psi ! soil water suction (m) + real(summa_prec),intent(in) :: k_sat ! saturated hydraulic conductivity (m s-1) + real(summa_prec),intent(in) :: alpha ! scaling parameter (m-1) + real(summa_prec),intent(in) :: n ! vGn "n" parameter (-) + real(summa_prec),intent(in) :: m ! vGn "m" parameter (-) + real(summa_prec) :: hydCond_psi ! hydraulic conductivity (m s-1) + if(psi<0._summa_prec)then hydCond_psi = k_sat * & - ( ( (1._dp - (psi*alpha)**(n-1._dp) * (1._dp + (psi*alpha)**n)**(-m))**2._dp ) & - / ( (1._dp + (psi*alpha)**n)**(m/2._dp) ) ) + ( ( (1._summa_prec - (psi*alpha)**(n-1._summa_prec) * (1._summa_prec + (psi*alpha)**n)**(-m))**2._summa_prec ) & + / ( (1._summa_prec + (psi*alpha)**n)**(m/2._summa_prec) ) ) else hydCond_psi = k_sat end if @@ -262,17 +262,17 @@ function hydCond_liq(volFracLiq,k_sat,theta_res,theta_sat,m) ! computes hydraulic conductivity given volFracLiq and soil hydraulic parameters k_sat, theta_sat, theta_res, and m implicit none ! dummies - real(dp),intent(in) :: volFracLiq ! volumetric liquid water content (-) - real(dp),intent(in) :: k_sat ! saturated hydraulic conductivity (m s-1) - real(dp),intent(in) :: theta_res ! residual volumetric liquid water content (-) - real(dp),intent(in) :: theta_sat ! soil porosity (-) - real(dp),intent(in) :: m ! vGn "m" parameter (-) - real(dp) :: hydCond_liq ! hydraulic conductivity (m s-1) + real(summa_prec),intent(in) :: volFracLiq ! volumetric liquid water content (-) + real(summa_prec),intent(in) :: k_sat ! saturated hydraulic conductivity (m s-1) + real(summa_prec),intent(in) :: theta_res ! residual volumetric liquid water content (-) + real(summa_prec),intent(in) :: theta_sat ! soil porosity (-) + real(summa_prec),intent(in) :: m ! vGn "m" parameter (-) + real(summa_prec) :: hydCond_liq ! hydraulic conductivity (m s-1) ! locals - real(dp) :: theta_e ! effective soil moisture + real(summa_prec) :: theta_e ! effective soil moisture if(volFracLiq < theta_sat)then theta_e = (volFracLiq - theta_res) / (theta_sat - theta_res) - hydCond_liq = k_sat*theta_e**(1._dp/2._dp) * (1._dp - (1._dp - theta_e**(1._dp/m) )**m)**2._dp + hydCond_liq = k_sat*theta_e**(1._summa_prec/2._summa_prec) * (1._summa_prec - (1._summa_prec - theta_e**(1._summa_prec/m) )**m)**2._summa_prec else hydCond_liq = k_sat end if @@ -285,15 +285,15 @@ end function hydCond_liq function volFracLiq(psi,alpha,theta_res,theta_sat,n,m) ! computes the volumetric liquid water content given psi and soil hydraulic parameters theta_res, theta_sat, alpha, n, and m implicit none - real(dp),intent(in) :: psi ! soil water suction (m) - real(dp),intent(in) :: alpha ! scaling parameter (m-1) - real(dp),intent(in) :: theta_res ! residual volumetric water content (-) - real(dp),intent(in) :: theta_sat ! porosity (-) - real(dp),intent(in) :: n ! vGn "n" parameter (-) - real(dp),intent(in) :: m ! vGn "m" parameter (-) - real(dp) :: volFracLiq ! volumetric liquid water content (-) - if(psi<0._dp)then - volFracLiq = theta_res + (theta_sat - theta_res)*(1._dp + (alpha*psi)**n)**(-m) + real(summa_prec),intent(in) :: psi ! soil water suction (m) + real(summa_prec),intent(in) :: alpha ! scaling parameter (m-1) + real(summa_prec),intent(in) :: theta_res ! residual volumetric water content (-) + real(summa_prec),intent(in) :: theta_sat ! porosity (-) + real(summa_prec),intent(in) :: n ! vGn "n" parameter (-) + real(summa_prec),intent(in) :: m ! vGn "m" parameter (-) + real(summa_prec) :: volFracLiq ! volumetric liquid water content (-) + if(psi<0._summa_prec)then + volFracLiq = theta_res + (theta_sat - theta_res)*(1._summa_prec + (alpha*psi)**n)**(-m) else volFracLiq = theta_sat end if @@ -307,23 +307,23 @@ function matricHead(theta,alpha,theta_res,theta_sat,n,m) ! computes the volumetric liquid water content given psi and soil hydraulic parameters theta_res, theta_sat, alpha, n, and m implicit none ! dummy variables - real(dp),intent(in) :: theta ! volumetric liquid water content (-) - real(dp),intent(in) :: alpha ! scaling parameter (m-1) - real(dp),intent(in) :: theta_res ! residual volumetric water content (-) - real(dp),intent(in) :: theta_sat ! porosity (-) - real(dp),intent(in) :: n ! vGn "n" parameter (-) - real(dp),intent(in) :: m ! vGn "m" parameter (-) - real(dp) :: matricHead ! matric head (m) + real(summa_prec),intent(in) :: theta ! volumetric liquid water content (-) + real(summa_prec),intent(in) :: alpha ! scaling parameter (m-1) + real(summa_prec),intent(in) :: theta_res ! residual volumetric water content (-) + real(summa_prec),intent(in) :: theta_sat ! porosity (-) + real(summa_prec),intent(in) :: n ! vGn "n" parameter (-) + real(summa_prec),intent(in) :: m ! vGn "m" parameter (-) + real(summa_prec) :: matricHead ! matric head (m) ! local variables - real(dp) :: effSat ! effective saturation (-) - real(dp),parameter :: verySmall=epsilon(1._dp) ! a very small number (avoid effective saturation of zero) + real(summa_prec) :: effSat ! effective saturation (-) + real(summa_prec),parameter :: verySmall=epsilon(1._summa_prec) ! a very small number (avoid effective saturation of zero) ! compute effective saturation effSat = max(verySmall, (theta - theta_res) / (theta_sat - theta_res)) ! compute matric head - if (effSat < 1._dp .and. effSat > 0._dp)then - matricHead = (1._dp/alpha)*( effSat**(-1._dp/m) - 1._dp)**(1._dp/n) + if (effSat < 1._summa_prec .and. effSat > 0._summa_prec)then + matricHead = (1._summa_prec/alpha)*( effSat**(-1._summa_prec/m) - 1._summa_prec)**(1._summa_prec/n) else - matricHead = 0._dp + matricHead = 0._summa_prec end if end function matricHead @@ -333,16 +333,16 @@ end function matricHead ! ****************************************************************************************************************************** function dTheta_dPsi(psi,alpha,theta_res,theta_sat,n,m) implicit none - real(dp),intent(in) :: psi ! soil water suction (m) - real(dp),intent(in) :: alpha ! scaling parameter (m-1) - real(dp),intent(in) :: theta_res ! residual volumetric water content (-) - real(dp),intent(in) :: theta_sat ! porosity (-) - real(dp),intent(in) :: n ! vGn "n" parameter (-) - real(dp),intent(in) :: m ! vGn "m" parameter (-) - real(dp) :: dTheta_dPsi ! derivative of the soil water characteristic (m-1) - if(psi<=0._dp)then + real(summa_prec),intent(in) :: psi ! soil water suction (m) + real(summa_prec),intent(in) :: alpha ! scaling parameter (m-1) + real(summa_prec),intent(in) :: theta_res ! residual volumetric water content (-) + real(summa_prec),intent(in) :: theta_sat ! porosity (-) + real(summa_prec),intent(in) :: n ! vGn "n" parameter (-) + real(summa_prec),intent(in) :: m ! vGn "m" parameter (-) + real(summa_prec) :: dTheta_dPsi ! derivative of the soil water characteristic (m-1) + if(psi<=0._summa_prec)then dTheta_dPsi = (theta_sat-theta_res) * & - (-m*(1._dp + (psi*alpha)**n)**(-m-1._dp)) * n*(psi*alpha)**(n-1._dp) * alpha + (-m*(1._summa_prec + (psi*alpha)**n)**(-m-1._summa_prec)) * n*(psi*alpha)**(n-1._summa_prec) * alpha if(abs(dTheta_dPsi) < epsilon(psi)) dTheta_dPsi = epsilon(psi) else dTheta_dPsi = epsilon(psi) @@ -356,31 +356,31 @@ end function dTheta_dPsi function dPsi_dTheta(volFracLiq,alpha,theta_res,theta_sat,n,m) implicit none ! dummies - real(dp),intent(in) :: volFracLiq ! volumetric liquid water content (-) - real(dp),intent(in) :: alpha ! scaling parameter (m-1) - real(dp),intent(in) :: theta_res ! residual volumetric water content (-) - real(dp),intent(in) :: theta_sat ! porosity (-) - real(dp),intent(in) :: n ! vGn "n" parameter (-) - real(dp),intent(in) :: m ! vGn "m" parameter (-) - real(dp) :: dPsi_dTheta ! derivative of the soil water characteristic (m) + real(summa_prec),intent(in) :: volFracLiq ! volumetric liquid water content (-) + real(summa_prec),intent(in) :: alpha ! scaling parameter (m-1) + real(summa_prec),intent(in) :: theta_res ! residual volumetric water content (-) + real(summa_prec),intent(in) :: theta_sat ! porosity (-) + real(summa_prec),intent(in) :: n ! vGn "n" parameter (-) + real(summa_prec),intent(in) :: m ! vGn "m" parameter (-) + real(summa_prec) :: dPsi_dTheta ! derivative of the soil water characteristic (m) ! locals - real(dp) :: y1,d1 ! 1st function and derivative - real(dp) :: y2,d2 ! 2nd function and derivative - real(dp) :: theta_e ! effective soil moisture + real(summa_prec) :: y1,d1 ! 1st function and derivative + real(summa_prec) :: y2,d2 ! 2nd function and derivative + real(summa_prec) :: theta_e ! effective soil moisture ! check if less than saturation if(volFracLiq < theta_sat)then ! compute effective water content theta_e = max(0.001,(volFracLiq - theta_res) / (theta_sat - theta_res)) ! compute the 1st function and derivative - y1 = theta_e**(-1._dp/m) - 1._dp - d1 = (-1._dp/m)*theta_e**(-1._dp/m - 1._dp) / (theta_sat - theta_res) + y1 = theta_e**(-1._summa_prec/m) - 1._summa_prec + d1 = (-1._summa_prec/m)*theta_e**(-1._summa_prec/m - 1._summa_prec) / (theta_sat - theta_res) ! compute the 2nd function and derivative - y2 = y1**(1._dp/n) - d2 = (1._dp/n)*y1**(1._dp/n - 1._dp) + y2 = y1**(1._summa_prec/n) + d2 = (1._summa_prec/n)*y1**(1._summa_prec/n - 1._summa_prec) ! compute the final function value dPsi_dTheta = d1*d2/alpha else - dPsi_dTheta = 0._dp + dPsi_dTheta = 0._summa_prec end if end function dPsi_dTheta @@ -391,21 +391,21 @@ end function dPsi_dTheta function dPsi_dTheta2(volFracLiq,alpha,theta_res,theta_sat,n,m,lTangent) implicit none ! dummies - real(dp),intent(in) :: volFracLiq ! volumetric liquid water content (-) - real(dp),intent(in) :: alpha ! scaling parameter (m-1) - real(dp),intent(in) :: theta_res ! residual volumetric water content (-) - real(dp),intent(in) :: theta_sat ! porosity (-) - real(dp),intent(in) :: n ! vGn "n" parameter (-) - real(dp),intent(in) :: m ! vGn "m" parameter (-) + real(summa_prec),intent(in) :: volFracLiq ! volumetric liquid water content (-) + real(summa_prec),intent(in) :: alpha ! scaling parameter (m-1) + real(summa_prec),intent(in) :: theta_res ! residual volumetric water content (-) + real(summa_prec),intent(in) :: theta_sat ! porosity (-) + real(summa_prec),intent(in) :: n ! vGn "n" parameter (-) + real(summa_prec),intent(in) :: m ! vGn "m" parameter (-) logical(lgt),intent(in) :: lTangent ! method used to compute derivative (.true. = analytical) - real(dp) :: dPsi_dTheta2 ! derivative of the soil water characteristic (m) + real(summa_prec) :: dPsi_dTheta2 ! derivative of the soil water characteristic (m) ! locals for analytical derivatives - real(dp) :: xx ! temporary variable - real(dp) :: y1,d1 ! 1st function and derivative - real(dp) :: y2,d2 ! 2nd function and derivative - real(dp) :: theta_e ! effective soil moisture + real(summa_prec) :: xx ! temporary variable + real(summa_prec) :: y1,d1 ! 1st function and derivative + real(summa_prec) :: y2,d2 ! 2nd function and derivative + real(summa_prec) :: theta_e ! effective soil moisture ! locals for numerical derivative - real(dp) :: func0,func1 ! function evaluations + real(summa_prec) :: func0,func1 ! function evaluations ! check if less than saturation if(volFracLiq < theta_sat)then ! ***** compute analytical derivatives @@ -413,12 +413,12 @@ function dPsi_dTheta2(volFracLiq,alpha,theta_res,theta_sat,n,m,lTangent) ! compute the effective saturation theta_e = (volFracLiq - theta_res) / (theta_sat - theta_res) ! get the first function and derivative - y1 = (-1._dp/m)*theta_e**(-1._dp/m - 1._dp) / (theta_sat - theta_res) - d1 = ( (m + 1._dp) / (m**2._dp * (theta_sat - theta_res)**2._dp) ) * theta_e**(-1._dp/m - 2._dp) + y1 = (-1._summa_prec/m)*theta_e**(-1._summa_prec/m - 1._summa_prec) / (theta_sat - theta_res) + d1 = ( (m + 1._summa_prec) / (m**2._summa_prec * (theta_sat - theta_res)**2._summa_prec) ) * theta_e**(-1._summa_prec/m - 2._summa_prec) ! get the second function and derivative - xx = theta_e**(-1._dp/m) - 1._dp - y2 = (1._dp/n)*xx**(1._dp/n - 1._dp) - d2 = ( -(1._dp - n)/((theta_sat - theta_res)*m*n**2._dp) ) * xx**(1._dp/n - 2._dp) * theta_e**(-1._dp/m - 1._dp) + xx = theta_e**(-1._summa_prec/m) - 1._summa_prec + y2 = (1._summa_prec/n)*xx**(1._summa_prec/n - 1._summa_prec) + d2 = ( -(1._summa_prec - n)/((theta_sat - theta_res)*m*n**2._summa_prec) ) * xx**(1._summa_prec/n - 2._summa_prec) * theta_e**(-1._summa_prec/m - 1._summa_prec) ! return the derivative dPsi_dTheta2 = (d1*y2 + y1*d2)/alpha ! ***** compute numerical derivatives @@ -429,7 +429,7 @@ function dPsi_dTheta2(volFracLiq,alpha,theta_res,theta_sat,n,m,lTangent) end if ! (case where volumetric liquid water content exceeds porosity) else - dPsi_dTheta2 = 0._dp + dPsi_dTheta2 = 0._summa_prec end if end function dPsi_dTheta2 @@ -442,41 +442,41 @@ function dHydCond_dPsi(psi,k_sat,alpha,n,m,lTangent) ! given psi and soil hydraulic parameters k_sat, alpha, n, and m implicit none ! dummies - real(dp),intent(in) :: psi ! soil water suction (m) - real(dp),intent(in) :: k_sat ! saturated hydraulic conductivity (m s-1) - real(dp),intent(in) :: alpha ! scaling parameter (m-1) - real(dp),intent(in) :: n ! vGn "n" parameter (-) - real(dp),intent(in) :: m ! vGn "m" parameter (-) + real(summa_prec),intent(in) :: psi ! soil water suction (m) + real(summa_prec),intent(in) :: k_sat ! saturated hydraulic conductivity (m s-1) + real(summa_prec),intent(in) :: alpha ! scaling parameter (m-1) + real(summa_prec),intent(in) :: n ! vGn "n" parameter (-) + real(summa_prec),intent(in) :: m ! vGn "m" parameter (-) logical(lgt),intent(in) :: lTangent ! method used to compute derivative (.true. = analytical) - real(dp) :: dHydCond_dPsi ! derivative in hydraulic conductivity w.r.t. matric head (s-1) + real(summa_prec) :: dHydCond_dPsi ! derivative in hydraulic conductivity w.r.t. matric head (s-1) ! locals for analytical derivatives - real(dp) :: f_x1 ! f(x) for part of the numerator - real(dp) :: f_x2 ! f(x) for part of the numerator - real(dp) :: f_nm ! f(x) for the numerator - real(dp) :: f_dm ! f(x) for the denominator - real(dp) :: d_x1 ! df(x)/dpsi for part of the numerator - real(dp) :: d_x2 ! df(x)/dpsi for part of the numerator - real(dp) :: d_nm ! df(x)/dpsi for the numerator - real(dp) :: d_dm ! df(x)/dpsi for the denominator + real(summa_prec) :: f_x1 ! f(x) for part of the numerator + real(summa_prec) :: f_x2 ! f(x) for part of the numerator + real(summa_prec) :: f_nm ! f(x) for the numerator + real(summa_prec) :: f_dm ! f(x) for the denominator + real(summa_prec) :: d_x1 ! df(x)/dpsi for part of the numerator + real(summa_prec) :: d_x2 ! df(x)/dpsi for part of the numerator + real(summa_prec) :: d_nm ! df(x)/dpsi for the numerator + real(summa_prec) :: d_dm ! df(x)/dpsi for the denominator ! locals for numerical derivatives - real(dp) :: hydCond0 ! hydraulic condictivity value for base case - real(dp) :: hydCond1 ! hydraulic condictivity value for perturbed case + real(summa_prec) :: hydCond0 ! hydraulic condictivity value for base case + real(summa_prec) :: hydCond1 ! hydraulic condictivity value for perturbed case ! derivative is zero if saturated - if(psi<0._dp)then + if(psi<0._summa_prec)then ! ***** compute analytical derivatives if(lTangent)then ! compute the derivative for the numerator - f_x1 = (psi*alpha)**(n - 1._dp) - f_x2 = (1._dp + (psi*alpha)**n)**(-m) - d_x1 = alpha * (n - 1._dp)*(psi*alpha)**(n - 2._dp) - d_x2 = alpha * n*(psi*alpha)**(n - 1._dp) * (-m)*(1._dp + (psi*alpha)**n)**(-m - 1._dp) - f_nm = (1._dp - f_x1*f_x2)**2._dp - d_nm = (-d_x1*f_x2 - f_x1*d_x2) * 2._dp*(1._dp - f_x1*f_x2) + f_x1 = (psi*alpha)**(n - 1._summa_prec) + f_x2 = (1._summa_prec + (psi*alpha)**n)**(-m) + d_x1 = alpha * (n - 1._summa_prec)*(psi*alpha)**(n - 2._summa_prec) + d_x2 = alpha * n*(psi*alpha)**(n - 1._summa_prec) * (-m)*(1._summa_prec + (psi*alpha)**n)**(-m - 1._summa_prec) + f_nm = (1._summa_prec - f_x1*f_x2)**2._summa_prec + d_nm = (-d_x1*f_x2 - f_x1*d_x2) * 2._summa_prec*(1._summa_prec - f_x1*f_x2) ! compute the derivative for the denominator - f_dm = (1._dp + (psi*alpha)**n)**(m/2._dp) - d_dm = alpha * n*(psi*alpha)**(n - 1._dp) * (m/2._dp)*(1._dp + (psi*alpha)**n)**(m/2._dp - 1._dp) + f_dm = (1._summa_prec + (psi*alpha)**n)**(m/2._summa_prec) + d_dm = alpha * n*(psi*alpha)**(n - 1._summa_prec) * (m/2._summa_prec)*(1._summa_prec + (psi*alpha)**n)**(m/2._summa_prec - 1._summa_prec) ! and combine - dHydCond_dPsi = k_sat*(d_nm*f_dm - d_dm*f_nm) / (f_dm**2._dp) + dHydCond_dPsi = k_sat*(d_nm*f_dm - d_dm*f_nm) / (f_dm**2._summa_prec) else ! ***** compute numerical derivatives hydcond0 = hydCond_psi(psi, k_sat,alpha,n,m) @@ -484,7 +484,7 @@ function dHydCond_dPsi(psi,k_sat,alpha,n,m,lTangent) dHydCond_dPsi = (hydcond1 - hydcond0)/dx end if else - dHydCond_dPsi = 0._dp + dHydCond_dPsi = 0._summa_prec end if end function dHydCond_dPsi @@ -498,24 +498,24 @@ end function dHydCond_dPsi function dHydCond_dLiq(volFracLiq,k_sat,theta_res,theta_sat,m,lTangent) implicit none ! dummies - real(dp),intent(in) :: volFracLiq ! volumetric fraction of liquid water (-) - real(dp),intent(in) :: k_sat ! saturated hydraulic conductivity (m s-1) - real(dp),intent(in) :: theta_res ! soil residual volumetric water content (-) - real(dp),intent(in) :: theta_sat ! soil porosity (-) - real(dp),intent(in) :: m ! vGn "m" parameter (-) + real(summa_prec),intent(in) :: volFracLiq ! volumetric fraction of liquid water (-) + real(summa_prec),intent(in) :: k_sat ! saturated hydraulic conductivity (m s-1) + real(summa_prec),intent(in) :: theta_res ! soil residual volumetric water content (-) + real(summa_prec),intent(in) :: theta_sat ! soil porosity (-) + real(summa_prec),intent(in) :: m ! vGn "m" parameter (-) logical(lgt),intent(in) :: lTangent ! method used to compute derivative (.true. = analytical) - real(dp) :: dHydCond_dLiq ! derivative in hydraulic conductivity w.r.t. matric head (s-1) + real(summa_prec) :: dHydCond_dLiq ! derivative in hydraulic conductivity w.r.t. matric head (s-1) ! locals for analytical derivatives - real(dp) :: theta_e ! effective soil moisture - real(dp) :: f1 ! f(x) for the first function - real(dp) :: d1 ! df(x)/dLiq for the first function - real(dp) :: x1,x2 ! f(x) for different parts of the second function - real(dp) :: p1,p2,p3 ! df(x)/dLiq for different parts of the second function - real(dp) :: f2 ! f(x) for the second function - real(dp) :: d2 ! df(x)/dLiq for the second function + real(summa_prec) :: theta_e ! effective soil moisture + real(summa_prec) :: f1 ! f(x) for the first function + real(summa_prec) :: d1 ! df(x)/dLiq for the first function + real(summa_prec) :: x1,x2 ! f(x) for different parts of the second function + real(summa_prec) :: p1,p2,p3 ! df(x)/dLiq for different parts of the second function + real(summa_prec) :: f2 ! f(x) for the second function + real(summa_prec) :: d2 ! df(x)/dLiq for the second function ! locals for numerical derivatives - real(dp) :: hydCond0 ! hydraulic condictivity value for base case - real(dp) :: hydCond1 ! hydraulic condictivity value for perturbed case + real(summa_prec) :: hydCond0 ! hydraulic condictivity value for base case + real(summa_prec) :: hydCond1 ! hydraulic condictivity value for perturbed case ! derivative is zero if super-saturated if(volFracLiq < theta_sat)then ! ***** compute analytical derivatives @@ -523,18 +523,18 @@ function dHydCond_dLiq(volFracLiq,k_sat,theta_res,theta_sat,m,lTangent) ! compute the effective saturation theta_e = (volFracLiq - theta_res) / (theta_sat - theta_res) ! compute the function and derivative of the first fuction - f1 = k_sat*theta_e**0.5_dp - d1 = k_sat*0.5_dp*theta_e**(-0.5_dp) / (theta_sat - theta_res) + f1 = k_sat*theta_e**0.5_summa_prec + d1 = k_sat*0.5_summa_prec*theta_e**(-0.5_summa_prec) / (theta_sat - theta_res) ! compute the function and derivative of the second function ! (first part) - x1 = 1._dp - theta_e**(1._dp/m) - p1 = (-1._dp/m)*theta_e**(1._dp/m - 1._dp) / (theta_sat - theta_res) ! differentiate (1.d - theta_e**(1.d/m) + x1 = 1._summa_prec - theta_e**(1._summa_prec/m) + p1 = (-1._summa_prec/m)*theta_e**(1._summa_prec/m - 1._summa_prec) / (theta_sat - theta_res) ! differentiate (1.d - theta_e**(1.d/m) ! (second part) x2 = x1**m - p2 = m*x1**(m - 1._dp) + p2 = m*x1**(m - 1._summa_prec) ! (final) - f2 = (1._dp - x2)**2._dp - p3 = -2._dp*(1._dp - x2) + f2 = (1._summa_prec - x2)**2._summa_prec + p3 = -2._summa_prec*(1._summa_prec - x2) ! (combine) d2 = p1*p2*p3 ! pull it all together @@ -546,7 +546,7 @@ function dHydCond_dLiq(volFracLiq,k_sat,theta_res,theta_sat,m,lTangent) dHydCond_dLiq = (hydcond1 - hydcond0)/dx end if else - dHydCond_dLiq = 0._dp + dHydCond_dLiq = 0._summa_prec end if end function dHydCond_dLiq @@ -556,9 +556,9 @@ end function dHydCond_dLiq ! ****************************************************************************************************************************** function RH_soilair(matpot,Tk) implicit none - real(dp),intent(in) :: matpot ! soil water suction -- matric potential (m) - real(dp),intent(in) :: Tk ! temperature (K) - real(dp) :: RH_soilair ! relative humidity of air in soil pore space + real(summa_prec),intent(in) :: matpot ! soil water suction -- matric potential (m) + real(summa_prec),intent(in) :: Tk ! temperature (K) + real(summa_prec) :: RH_soilair ! relative humidity of air in soil pore space ! compute relative humidity (UNITS NOTE: Pa = kg m-1 s-2, so R_wv units = m2 s-2 K-1) RH_soilair = exp( (gravity*matpot) / (R_wv*Tk) ) end function RH_soilair @@ -569,9 +569,9 @@ end function RH_soilair ! ****************************************************************************************************************************** function crit_soilT(psi) implicit none - real(dp),intent(in) :: psi ! matric head (m) - real(dp) :: crit_soilT ! critical soil temperature (K) - crit_soilT = Tfreeze + min(psi,0._dp)*gravity*Tfreeze/LH_fus + real(summa_prec),intent(in) :: psi ! matric head (m) + real(summa_prec) :: crit_soilT ! critical soil temperature (K) + crit_soilT = Tfreeze + min(psi,0._summa_prec)*gravity*Tfreeze/LH_fus end function crit_soilT @@ -580,22 +580,22 @@ end function crit_soilT ! ****************************************************************************************************************************** function dTheta_dTk(Tk,theta_res,theta_sat,alpha,n,m) implicit none - real(dp),intent(in) :: Tk ! temperature (K) - real(dp),intent(in) :: theta_res ! residual liquid water content (-) - real(dp),intent(in) :: theta_sat ! porosity (-) - real(dp),intent(in) :: alpha ! vGn scaling parameter (m-1) - real(dp),intent(in) :: n ! vGn "n" parameter (-) - real(dp),intent(in) :: m ! vGn "m" parameter (-) - real(dp) :: dTheta_dTk ! derivative of the freezing curve w.r.t. temperature (K-1) + real(summa_prec),intent(in) :: Tk ! temperature (K) + real(summa_prec),intent(in) :: theta_res ! residual liquid water content (-) + real(summa_prec),intent(in) :: theta_sat ! porosity (-) + real(summa_prec),intent(in) :: alpha ! vGn scaling parameter (m-1) + real(summa_prec),intent(in) :: n ! vGn "n" parameter (-) + real(summa_prec),intent(in) :: m ! vGn "m" parameter (-) + real(summa_prec) :: dTheta_dTk ! derivative of the freezing curve w.r.t. temperature (K-1) ! local variables - real(dp) :: kappa ! constant (m K-1) - real(dp) :: xtemp ! alpha*kappa*(Tk-Tfreeze) -- dimensionless variable (used more than once) + real(summa_prec) :: kappa ! constant (m K-1) + real(summa_prec) :: xtemp ! alpha*kappa*(Tk-Tfreeze) -- dimensionless variable (used more than once) ! compute kappa (m K-1) kappa = LH_fus/(gravity*Tfreeze) ! NOTE: J = kg m2 s-2 ! define a tempory variable that is used more than once (-) xtemp = alpha*kappa*(Tk-Tfreeze) ! differentiate the freezing curve w.r.t. temperature -- making use of the chain rule - dTheta_dTk = (alpha*kappa) * n*xtemp**(n - 1._dp) * (-m)*(1._dp + xtemp**n)**(-m - 1._dp) * (theta_sat - theta_res) + dTheta_dTk = (alpha*kappa) * n*xtemp**(n - 1._summa_prec) * (-m)*(1._summa_prec + xtemp**n)**(-m - 1._summa_prec) * (theta_sat - theta_res) end function dTheta_dTk @@ -604,12 +604,12 @@ end function dTheta_dTk ! ****************************************************************************************************************************** FUNCTION gammp(a,x) IMPLICIT NONE - REAL(DP), INTENT(IN) :: a,x - REAL(DP) :: gammp - if (x ITMAX) stop 'a too large, ITMAX too small in gcf' if (present(gln)) then @@ -661,22 +661,22 @@ END FUNCTION gcf ! ****************************************************************************************************************************** FUNCTION gser(a,x,gln) IMPLICIT NONE - REAL(DP), INTENT(IN) :: a,x - REAL(DP), OPTIONAL, INTENT(OUT) :: gln - REAL(DP) :: gser + real(summa_prec), INTENT(IN) :: a,x + real(summa_prec), OPTIONAL, INTENT(OUT) :: gln + real(summa_prec) :: gser INTEGER(I4B), PARAMETER :: ITMAX=100 - REAL(DP), PARAMETER :: EPS=epsilon(x) + real(summa_prec), PARAMETER :: EPS=epsilon(x) INTEGER(I4B) :: n - REAL(DP) :: ap,del,summ + real(summa_prec) :: ap,del,summ if (x == 0.0) then gser=0.0 RETURN end if ap=a - summ=1.0_dp/a + summ=1.0_summa_prec/a del=summ do n=1,ITMAX - ap=ap+1.0_dp + ap=ap+1.0_summa_prec del=del*x/ap summ=summ+del if (abs(del) < abs(summ)*EPS) exit @@ -697,20 +697,20 @@ END FUNCTION gser FUNCTION gammln(xx) USE nr_utility_module,only:arth ! use to build vectors with regular increments IMPLICIT NONE - REAL(DP), INTENT(IN) :: xx - REAL(DP) :: gammln - REAL(DP) :: tmp,x - REAL(DP) :: stp = 2.5066282746310005_dp - REAL(DP), DIMENSION(6) :: coef = (/76.18009172947146_dp,& - -86.50532032941677_dp,24.01409824083091_dp,& - -1.231739572450155_dp,0.1208650973866179e-2_dp,& - -0.5395239384953e-5_dp/) - if(xx <= 0._dp) stop 'xx > 0 in gammln' + real(summa_prec), INTENT(IN) :: xx + real(summa_prec) :: gammln + real(summa_prec) :: tmp,x + real(summa_prec) :: stp = 2.5066282746310005_summa_prec + real(summa_prec), DIMENSION(6) :: coef = (/76.18009172947146_summa_prec,& + -86.50532032941677_summa_prec,24.01409824083091_summa_prec,& + -1.231739572450155_summa_prec,0.1208650973866179e-2_summa_prec,& + -0.5395239384953e-5_summa_prec/) + if(xx <= 0._summa_prec) stop 'xx > 0 in gammln' x=xx - tmp=x+5.5_dp - tmp=(x+0.5_dp)*log(tmp)-tmp - gammln=tmp+log(stp*(1.000000000190015_dp+& - sum(coef(:)/arth(x+1.0_dp,1.0_dp,size(coef))))/x) + tmp=x+5.5_summa_prec + tmp=(x+0.5_summa_prec)*log(tmp)-tmp + gammln=tmp+log(stp*(1.000000000190015_summa_prec+& + sum(coef(:)/arth(x+1.0_summa_prec,1.0_summa_prec,size(coef))))/x) END FUNCTION gammln diff --git a/build/source/engine/spline_int.f90 b/build/source/engine/spline_int.f90 index 08be079a2..15199bd7d 100755 --- a/build/source/engine/spline_int.f90 +++ b/build/source/engine/spline_int.f90 @@ -13,15 +13,15 @@ SUBROUTINE spline(x,y,yp1,ypn,y2,err,message) ! computes 2nd derivatives of the interpolating function at tabulated points IMPLICIT NONE ! dummy variables - REAL(DP), DIMENSION(:), INTENT(IN) :: x,y - REAL(DP), INTENT(IN) :: yp1,ypn - REAL(DP), DIMENSION(:), INTENT(OUT) :: y2 + real(summa_prec), DIMENSION(:), INTENT(IN) :: x,y + real(summa_prec), INTENT(IN) :: yp1,ypn + real(summa_prec), DIMENSION(:), INTENT(OUT) :: y2 integer(i4b),intent(out) :: err character(*),intent(out) :: message ! local variables character(len=128) :: cmessage INTEGER(I4B) :: n - REAL(DP), DIMENSION(size(x)) :: a,b,c,r + real(summa_prec), DIMENSION(size(x)) :: a,b,c,r ! initialize error control err=0; message="f-spline/" ! check that the size of the vectors match @@ -32,24 +32,24 @@ SUBROUTINE spline(x,y,yp1,ypn,y2,err,message) end if ! start procedure c(1:n-1)=x(2:n)-x(1:n-1) - r(1:n-1)=6.0_dp*((y(2:n)-y(1:n-1))/c(1:n-1)) + r(1:n-1)=6.0_summa_prec*((y(2:n)-y(1:n-1))/c(1:n-1)) r(2:n-1)=r(2:n-1)-r(1:n-2) a(2:n-1)=c(1:n-2) - b(2:n-1)=2.0_dp*(c(2:n-1)+a(2:n-1)) + b(2:n-1)=2.0_summa_prec*(c(2:n-1)+a(2:n-1)) b(1)=1.0 b(n)=1.0 - if (yp1 > 0.99e30_dp) then + if (yp1 > 0.99e30_summa_prec) then r(1)=0.0 c(1)=0.0 else - r(1)=(3.0_dp/(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-yp1) + r(1)=(3.0_summa_prec/(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-yp1) c(1)=0.5 end if - if (ypn > 0.99e30_dp) then + if (ypn > 0.99e30_summa_prec) then r(n)=0.0 a(n)=0.0 else - r(n)=(-3.0_dp/(x(n)-x(n-1)))*((y(n)-y(n-1))/(x(n)-x(n-1))-ypn) + r(n)=(-3.0_summa_prec/(x(n)-x(n-1)))*((y(n)-y(n-1))/(x(n)-x(n-1))-ypn) a(n)=0.5 end if call tridag(a(2:n),b(1:n),c(1:n-1),r(1:n),y2(1:n),err,cmessage) @@ -62,14 +62,14 @@ END SUBROUTINE spline SUBROUTINE splint(xa,ya,y2a,x,y,err,message) IMPLICIT NONE ! declare dummy variables - REAL(DP), DIMENSION(:), INTENT(IN) :: xa,ya,y2a - REAL(DP), INTENT(IN) :: x - REAL(DP), INTENT(OUT) :: y + real(summa_prec), DIMENSION(:), INTENT(IN) :: xa,ya,y2a + real(summa_prec), INTENT(IN) :: x + real(summa_prec), INTENT(OUT) :: y integer(i4b),intent(out) :: err character(*),intent(out) :: message ! declare local variables INTEGER(I4B) :: khi,klo,n - REAL(DP) :: a,b,h + real(summa_prec) :: a,b,h ! check size of input vectors if (size(xa)==size(ya) .and. size(ya)==size(y2a)) then n=size(xa) @@ -80,10 +80,10 @@ SUBROUTINE splint(xa,ya,y2a,x,y,err,message) klo=max(min(locate(xa,x),n-1),1) khi=klo+1 h=xa(khi)-xa(klo) - if (h == 0.0_dp) then; err=20; message="f-splint/badXinput"; return; end if + if (h == 0.0_summa_prec) then; err=20; message="f-splint/badXinput"; return; end if a=(xa(khi)-x)/h b=(x-xa(klo))/h - y=a*ya(klo)+b*ya(khi)+((a**3-a)*y2a(klo)+(b**3-b)*y2a(khi))*(h**2)/6.0_dp + y=a*ya(klo)+b*ya(khi)+((a**3-a)*y2a(klo)+(b**3-b)*y2a(khi))*(h**2)/6.0_summa_prec END SUBROUTINE splint ! ************************************************************* @@ -91,8 +91,8 @@ END SUBROUTINE splint ! ************************************************************* FUNCTION locate(xx,x) IMPLICIT NONE - REAL(DP), DIMENSION(:), INTENT(IN) :: xx - REAL(DP), INTENT(IN) :: x + real(summa_prec), DIMENSION(:), INTENT(IN) :: xx + real(summa_prec), INTENT(IN) :: x INTEGER(I4B) :: locate INTEGER(I4B) :: n,jl,jm,ju LOGICAL :: ascnd @@ -124,14 +124,14 @@ END FUNCTION locate SUBROUTINE tridag(a,b,c,r,u,err,message) IMPLICIT NONE ! dummy variables - REAL(DP), DIMENSION(:), INTENT(IN) :: a,b,c,r - REAL(DP), DIMENSION(:), INTENT(OUT) :: u + real(summa_prec), DIMENSION(:), INTENT(IN) :: a,b,c,r + real(summa_prec), DIMENSION(:), INTENT(OUT) :: u integer(i4b),intent(out) :: err character(*),intent(out) :: message ! local variables - REAL(DP), DIMENSION(size(b)) :: gam + real(summa_prec), DIMENSION(size(b)) :: gam INTEGER(I4B) :: n,j - REAL(DP) :: bet + real(summa_prec) :: bet ! initialize error control err=0; message="f-spline/OK" ! check that the size of the vectors match @@ -142,12 +142,12 @@ SUBROUTINE tridag(a,b,c,r,u,err,message) end if ! start procedure bet=b(1) - if (bet == 0.0_dp) then; err=20; message="f-tridag/errorAtCodeStage-1"; return; end if + if (bet == 0.0_summa_prec) then; err=20; message="f-tridag/errorAtCodeStage-1"; return; end if u(1)=r(1)/bet do j=2,n gam(j)=c(j-1)/bet bet=b(j)-a(j-1)*gam(j) - if (bet == 0.0_dp) then; err=20; message="f-tridag/errorAtCodeStage-2"; return; end if + if (bet == 0.0_summa_prec) then; err=20; message="f-tridag/errorAtCodeStage-2"; return; end if u(j)=(r(j)-a(j-1)*u(j-1))/bet end do do j=n-1,1,-1 diff --git a/build/source/engine/ssdNrgFlux.f90 b/build/source/engine/ssdNrgFlux.f90 index cd4f371e2..e0425ce8e 100755 --- a/build/source/engine/ssdNrgFlux.f90 +++ b/build/source/engine/ssdNrgFlux.f90 @@ -83,8 +83,8 @@ module ssdNrgFlux_module private public::ssdNrgFlux ! global parameters -real(dp),parameter :: dx=1.e-10_dp ! finite difference increment (K) -real(dp),parameter :: valueMissing=-9999._dp ! missing value parameter +real(summa_prec),parameter :: dx=1.e-10_summa_prec ! finite difference increment (K) +real(summa_prec),parameter :: valueMissing=-9999._summa_prec ! missing value parameter contains ! ************************************************************************************************ @@ -117,13 +117,13 @@ subroutine ssdNrgFlux(& ! input: model control logical(lgt),intent(in) :: scalarSolution ! flag to denote if implementing the scalar solution ! input: fluxes and derivatives at the upper boundary - real(dp),intent(in) :: groundNetFlux ! net energy flux for the ground surface (W m-2) - real(dp),intent(in) :: dGroundNetFlux_dGroundTemp ! derivative in net ground flux w.r.t. ground temperature (W m-2 K-1) + real(summa_prec),intent(in) :: groundNetFlux ! net energy flux for the ground surface (W m-2) + real(summa_prec),intent(in) :: dGroundNetFlux_dGroundTemp ! derivative in net ground flux w.r.t. ground temperature (W m-2 K-1) ! input: liquid water fluxes - real(dp),intent(in) :: iLayerLiqFluxSnow(0:) ! intent(in): liquid flux at the interface of each snow layer (m s-1) - real(dp),intent(in) :: iLayerLiqFluxSoil(0:) ! intent(in): liquid flux at the interface of each soil layer (m s-1) + real(summa_prec),intent(in) :: iLayerLiqFluxSnow(0:) ! intent(in): liquid flux at the interface of each snow layer (m s-1) + real(summa_prec),intent(in) :: iLayerLiqFluxSoil(0:) ! intent(in): liquid flux at the interface of each soil layer (m s-1) ! input: trial value of model state variables - real(dp),intent(in) :: mLayerTempTrial(:) ! trial temperature of each snow/soil layer at the current iteration (K) + real(summa_prec),intent(in) :: mLayerTempTrial(:) ! trial temperature of each snow/soil layer at the current iteration (K) ! input-output: data structures type(var_dlength),intent(in) :: mpar_data ! model parameters type(var_ilength),intent(in) :: indx_data ! state vector geometry @@ -131,9 +131,9 @@ subroutine ssdNrgFlux(& type(var_dlength),intent(in) :: diag_data ! diagnostic variables for a local HRU type(var_dlength),intent(inout) :: flux_data ! model fluxes for a local HRU ! output: fluxes and derivatives at all layer interfaces - real(dp),intent(out) :: iLayerNrgFlux(0:) ! energy flux at the layer interfaces (W m-2) - real(dp),intent(out) :: dFlux_dTempAbove(0:) ! derivatives in the flux w.r.t. temperature in the layer above (J m-2 s-1 K-1) - real(dp),intent(out) :: dFlux_dTempBelow(0:) ! derivatives in the flux w.r.t. temperature in the layer below (J m-2 s-1 K-1) + real(summa_prec),intent(out) :: iLayerNrgFlux(0:) ! energy flux at the layer interfaces (W m-2) + real(summa_prec),intent(out) :: dFlux_dTempAbove(0:) ! derivatives in the flux w.r.t. temperature in the layer above (J m-2 s-1 K-1) + real(summa_prec),intent(out) :: dFlux_dTempBelow(0:) ! derivatives in the flux w.r.t. temperature in the layer below (J m-2 s-1 K-1) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message @@ -143,9 +143,9 @@ subroutine ssdNrgFlux(& integer(i4b) :: ixLayerDesired(1) ! layer desired (scalar solution) integer(i4b) :: ixTop ! top layer in subroutine call integer(i4b) :: ixBot ! bottom layer in subroutine call - real(dp) :: qFlux ! liquid flux at layer interfaces (m s-1) - real(dp) :: dz ! height difference (m) - real(dp) :: flux0,flux1,flux2 ! fluxes used to calculate derivatives (W m-2) + real(summa_prec) :: qFlux ! liquid flux at layer interfaces (m s-1) + real(summa_prec) :: dz ! height difference (m) + real(summa_prec) :: flux0,flux1,flux2 ! fluxes used to calculate derivatives (W m-2) ! ------------------------------------------------------------------------------------------------------------------------------------------------------ ! make association of local variables with information in the data structures associate(& @@ -194,8 +194,8 @@ subroutine ssdNrgFlux(& if(iLayer==nLayers)then ! flux depends on the type of lower boundary condition select case(ix_bcLowrTdyn) ! (identify the lower boundary condition for thermodynamics - case(prescribedTemp); iLayerConductiveFlux(nLayers) = -iLayerThermalC(iLayer)*(lowerBoundTemp - mLayerTempTrial(iLayer))/(mLayerDepth(iLayer)*0.5_dp) - case(zeroFlux); iLayerConductiveFlux(nLayers) = 0._dp + case(prescribedTemp); iLayerConductiveFlux(nLayers) = -iLayerThermalC(iLayer)*(lowerBoundTemp - mLayerTempTrial(iLayer))/(mLayerDepth(iLayer)*0.5_summa_prec) + case(zeroFlux); iLayerConductiveFlux(nLayers) = 0._summa_prec case default; err=20; message=trim(message)//'unable to identify lower boundary condition for thermodynamics'; return end select ! (identifying the lower boundary condition for thermodynamics) @@ -257,7 +257,7 @@ subroutine ssdNrgFlux(& ! * prescribed temperature at the lower boundary case(prescribedTemp) - dz = mLayerDepth(iLayer)*0.5_dp + dz = mLayerDepth(iLayer)*0.5_summa_prec if(ix_fDerivMeth==analytical)then ! ** analytical derivatives dFlux_dTempAbove(iLayer) = iLayerThermalC(iLayer)/dz else ! ** numerical derivatives @@ -268,7 +268,7 @@ subroutine ssdNrgFlux(& ! * zero flux at the lower boundary case(zeroFlux) - dFlux_dTempAbove(iLayer) = 0._dp + dFlux_dTempAbove(iLayer) = 0._summa_prec case default; err=20; message=trim(message)//'unable to identify lower boundary condition for thermodynamics'; return diff --git a/build/source/engine/stomResist.f90 b/build/source/engine/stomResist.f90 index 00cee9975..ad9a854df 100755 --- a/build/source/engine/stomResist.f90 +++ b/build/source/engine/stomResist.f90 @@ -94,11 +94,11 @@ module stomResist_module integer(i4b),parameter :: iLoc = 1 ! i-location integer(i4b),parameter :: jLoc = 1 ! j-location ! conversion factors -real(dp),parameter :: joule2umolConv=4.6_dp ! conversion factor from joules to umol photons (umol J-1) +real(summa_prec),parameter :: joule2umolConv=4.6_summa_prec ! conversion factor from joules to umol photons (umol J-1) ! algorithmic parameters -real(dp),parameter :: missingValue=-9999._dp ! missing value, used when diagnostic or state variables are undefined -real(dp),parameter :: mpe=1.e-6_dp ! prevents overflow error if division by zero -real(dp),parameter :: dx=1.e-6_dp ! finite difference increment +real(summa_prec),parameter :: missingValue=-9999._summa_prec ! missing value, used when diagnostic or state variables are undefined +real(summa_prec),parameter :: mpe=1.e-6_summa_prec ! prevents overflow error if division by zero +real(summa_prec),parameter :: dx=1.e-6_summa_prec ! finite difference increment contains @@ -127,9 +127,9 @@ subroutine stomResist(& USE conv_funcs_module,only:satVapPress ! function to compute the saturated vapor pressure (Pa) ! ------------------------------------------------------------------------------------------------------------------------------------------------------ ! input: state and diagnostic variables - real(dp),intent(in) :: scalarVegetationTemp ! vegetation temperature (K) - real(dp),intent(in) :: scalarSatVP_VegTemp ! saturation vapor pressure at vegetation temperature (Pa) - real(dp),intent(in) :: scalarVP_CanopyAir ! canopy air vapor pressure (Pa) + real(summa_prec),intent(in) :: scalarVegetationTemp ! vegetation temperature (K) + real(summa_prec),intent(in) :: scalarSatVP_VegTemp ! saturation vapor pressure at vegetation temperature (Pa) + real(summa_prec),intent(in) :: scalarVP_CanopyAir ! canopy air vapor pressure (Pa) ! input: data structures type(var_i),intent(in) :: type_data ! type of vegetation and soil type(var_d),intent(in) :: forc_data ! model forcing data @@ -147,10 +147,10 @@ subroutine stomResist(& integer(i4b),parameter :: ixSunlit=1 ! named variable for sunlit leaves integer(i4b),parameter :: ixShaded=2 ! named variable for shaded leaves integer(i4b) :: iSunShade ! index defining sunlit or shaded leaves - real(dp) :: absorbedPAR ! absorbed PAR (W m-2) - real(dp) :: scalarStomResist ! stomatal resistance (s m-1) - real(dp) :: scalarPhotosynthesis ! photosynthesis (umol CO2 m-2 s-1) - real(dp) :: ci ! intercellular co2 partial pressure (Pa) + real(summa_prec) :: absorbedPAR ! absorbed PAR (W m-2) + real(summa_prec) :: scalarStomResist ! stomatal resistance (s m-1) + real(summa_prec) :: scalarPhotosynthesis ! photosynthesis (umol CO2 m-2 s-1) + real(summa_prec) :: ci ! intercellular co2 partial pressure (Pa) ! ------------------------------------------------------------------------------------------------------------------------------------------------------ ! associate variables in the data structure @@ -356,10 +356,10 @@ subroutine stomResist_flex(& ! ------------------------------------------------------------------------------------------------------------------------------------------------------ ! ------------------------------------------------------------------------------------------------------------------------------------------------------ ! input: state and diagnostic variables - real(dp),intent(in) :: scalarVegetationTemp ! vegetation temperature (K) - real(dp),intent(in) :: scalarSatVP_VegTemp ! saturation vapor pressure at vegetation temperature (Pa) - real(dp),intent(in) :: scalarVP_CanopyAir ! canopy air vapor pressure (Pa) - real(dp),intent(in) :: absorbedPAR ! absorbed PAR (W m-2) + real(summa_prec),intent(in) :: scalarVegetationTemp ! vegetation temperature (K) + real(summa_prec),intent(in) :: scalarSatVP_VegTemp ! saturation vapor pressure at vegetation temperature (Pa) + real(summa_prec),intent(in) :: scalarVP_CanopyAir ! canopy air vapor pressure (Pa) + real(summa_prec),intent(in) :: absorbedPAR ! absorbed PAR (W m-2) ! input: data structures type(var_d),intent(in) :: forc_data ! model forcing data type(var_dlength),intent(in) :: mpar_data ! model parameters @@ -367,69 +367,69 @@ subroutine stomResist_flex(& type(var_dlength),intent(in) :: flux_data ! model fluxes for a local HRU type(model_options),intent(in) :: model_decisions(:) ! model decisions ! output: stomatal resistance and photosynthesis - real(dp),intent(inout) :: ci ! intercellular co2 partial pressure (Pa) - real(dp),intent(out) :: scalarStomResist ! stomatal resistance (s m-1) - real(dp),intent(out) :: scalarPhotosynthesis ! photosynthesis (umol CO2 m-2 s-1) + real(summa_prec),intent(inout) :: ci ! intercellular co2 partial pressure (Pa) + real(summa_prec),intent(out) :: scalarStomResist ! stomatal resistance (s m-1) + real(summa_prec),intent(out) :: scalarPhotosynthesis ! photosynthesis (umol CO2 m-2 s-1) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! ------------------------------------------------------------------------------------------------------------------------------------------------------ ! general local variables logical(lgt),parameter :: testDerivs=.false. ! flag to test the derivatives - real(dp) :: unitConv ! unit conversion factor (mol m-3, convert m s-1 --> mol H20 m-2 s-1) - real(dp) :: rlb ! leaf boundary layer rersistance (umol-1 m2 s) - real(dp) :: x0,x1,x2 ! temporary variables - real(dp) :: co2compPt ! co2 compensation point (Pa) - real(dp) :: fHum ! humidity function, fraction [0,1] + real(summa_prec) :: unitConv ! unit conversion factor (mol m-3, convert m s-1 --> mol H20 m-2 s-1) + real(summa_prec) :: rlb ! leaf boundary layer rersistance (umol-1 m2 s) + real(summa_prec) :: x0,x1,x2 ! temporary variables + real(summa_prec) :: co2compPt ! co2 compensation point (Pa) + real(summa_prec) :: fHum ! humidity function, fraction [0,1] ! ------------------------------------------------------------------------------------------------------------------------------------------------------ ! fixed parameters integer(i4b),parameter :: maxiter=20 ! maximum number of iterations integer(i4b),parameter :: maxiter_noahMP=3 ! maximum number of iterations for Noah-MP - real(dp),parameter :: convToler=0.0001_dp ! convergence tolerance (Pa) - real(dp),parameter :: umol_per_mol=1.e+6_dp ! factor to relate umol to mol - real(dp),parameter :: o2scaleFactor=0.105_dp ! scaling factor used to compute co2 compesation point (0.21/2) - real(dp),parameter :: h2o_co2__leafbl=1.37_dp ! factor to represent the different diffusivities of h2o and co2 in the leaf boundary layer (-) - real(dp),parameter :: h2o_co2__stomPores=1.65_dp ! factor to represent the different diffusivities of h2o and co2 in the stomatal pores (-) - real(dp),parameter :: Tref=298.16_dp ! reference temperature (25 deg C) - real(dp),parameter :: Tscale=10._dp ! scaling factor in q10 function (K) - real(dp),parameter :: c_ps2=0.7_dp ! curvature factor for electron transport (-) - real(dp),parameter :: fnf=0.6666666667_dp ! foliage nitrogen factor (-) + real(summa_prec),parameter :: convToler=0.0001_summa_prec ! convergence tolerance (Pa) + real(summa_prec),parameter :: umol_per_mol=1.e+6_summa_prec ! factor to relate umol to mol + real(summa_prec),parameter :: o2scaleFactor=0.105_summa_prec ! scaling factor used to compute co2 compesation point (0.21/2) + real(summa_prec),parameter :: h2o_co2__leafbl=1.37_summa_prec ! factor to represent the different diffusivities of h2o and co2 in the leaf boundary layer (-) + real(summa_prec),parameter :: h2o_co2__stomPores=1.65_summa_prec ! factor to represent the different diffusivities of h2o and co2 in the stomatal pores (-) + real(summa_prec),parameter :: Tref=298.16_summa_prec ! reference temperature (25 deg C) + real(summa_prec),parameter :: Tscale=10._summa_prec ! scaling factor in q10 function (K) + real(summa_prec),parameter :: c_ps2=0.7_summa_prec ! curvature factor for electron transport (-) + real(summa_prec),parameter :: fnf=0.6666666667_summa_prec ! foliage nitrogen factor (-) ! ------------------------------------------------------------------------------------------------------------------------------------------------------ ! photosynthesis - real(dp) :: Kc,Ko ! Michaelis-Menten constants for co2 and o2 (Pa) - real(dp) :: vcmax25 ! maximum Rubisco carboxylation rate at 25 deg C (umol m-2 s-1) - real(dp) :: jmax25 ! maximum electron transport rate at 25 deg C (umol m-2 s-1) - real(dp) :: vcmax ! maximum Rubisco carboxylation rate (umol m-2 s-1) - real(dp) :: jmax ! maximum electron transport rate (umol m-2 s-1) - real(dp) :: aQuad ! the quadratic coefficient in the quadratic equation - real(dp) :: bQuad ! the linear coefficient in the quadratic equation - real(dp) :: cQuad ! the constant in the quadratic equation - real(dp) :: bSign ! sign of the linear coeffcient - real(dp) :: xTemp ! temporary variable in the quadratic equation - real(dp) :: qQuad ! the "q" term in the quadratic equation - real(dp) :: root1,root2 ! roots of the quadratic function - real(dp) :: Js ! scaled electron transport rate (umol co2 m-2 s-1) - real(dp) :: I_ps2 ! PAR absorbed by PS2 (umol photon m-2 s-1) - real(dp) :: awb ! Michaelis-Menten control (Pa) - real(dp) :: cp2 ! additional controls in light-limited assimilation (Pa) - real(dp) :: psn ! leaf gross photosynthesis rate (umol co2 m-2 s-1) - real(dp) :: dA_dc ! derivative in photosynthesis w.r.t. intercellular co2 concentration + real(summa_prec) :: Kc,Ko ! Michaelis-Menten constants for co2 and o2 (Pa) + real(summa_prec) :: vcmax25 ! maximum Rubisco carboxylation rate at 25 deg C (umol m-2 s-1) + real(summa_prec) :: jmax25 ! maximum electron transport rate at 25 deg C (umol m-2 s-1) + real(summa_prec) :: vcmax ! maximum Rubisco carboxylation rate (umol m-2 s-1) + real(summa_prec) :: jmax ! maximum electron transport rate (umol m-2 s-1) + real(summa_prec) :: aQuad ! the quadratic coefficient in the quadratic equation + real(summa_prec) :: bQuad ! the linear coefficient in the quadratic equation + real(summa_prec) :: cQuad ! the constant in the quadratic equation + real(summa_prec) :: bSign ! sign of the linear coeffcient + real(summa_prec) :: xTemp ! temporary variable in the quadratic equation + real(summa_prec) :: qQuad ! the "q" term in the quadratic equation + real(summa_prec) :: root1,root2 ! roots of the quadratic function + real(summa_prec) :: Js ! scaled electron transport rate (umol co2 m-2 s-1) + real(summa_prec) :: I_ps2 ! PAR absorbed by PS2 (umol photon m-2 s-1) + real(summa_prec) :: awb ! Michaelis-Menten control (Pa) + real(summa_prec) :: cp2 ! additional controls in light-limited assimilation (Pa) + real(summa_prec) :: psn ! leaf gross photosynthesis rate (umol co2 m-2 s-1) + real(summa_prec) :: dA_dc ! derivative in photosynthesis w.r.t. intercellular co2 concentration ! ------------------------------------------------------------------------------------------------------------------------------------------------------ ! stomatal resistance - real(dp) :: gMin ! scaled minimum conductance (umol m-2 s-1) - real(dp) :: cs ! co2 partial pressure at leaf surface (Pa) - real(dp) :: csx ! control of co2 partial pressure at leaf surface on stomatal conductance (Pa) - real(dp) :: g0 ! stomatal conductance in the absence of humidity controls (umol m-2 s-1) - real(dp) :: ci_old ! intercellular co2 partial pressure (Pa) - real(dp) :: rs ! stomatal resistance (umol-1 m2 s) - real(dp) :: dg0_dc ! derivative in g0 w.r.t intercellular co2 concentration (umol m-2 s-1 Pa-1) - real(dp) :: drs_dc ! derivative in stomatal resistance w.r.t. intercellular co2 concentration - real(dp) :: dci_dc ! final derivative (-) + real(summa_prec) :: gMin ! scaled minimum conductance (umol m-2 s-1) + real(summa_prec) :: cs ! co2 partial pressure at leaf surface (Pa) + real(summa_prec) :: csx ! control of co2 partial pressure at leaf surface on stomatal conductance (Pa) + real(summa_prec) :: g0 ! stomatal conductance in the absence of humidity controls (umol m-2 s-1) + real(summa_prec) :: ci_old ! intercellular co2 partial pressure (Pa) + real(summa_prec) :: rs ! stomatal resistance (umol-1 m2 s) + real(summa_prec) :: dg0_dc ! derivative in g0 w.r.t intercellular co2 concentration (umol m-2 s-1 Pa-1) + real(summa_prec) :: drs_dc ! derivative in stomatal resistance w.r.t. intercellular co2 concentration + real(summa_prec) :: dci_dc ! final derivative (-) ! ------------------------------------------------------------------------------------------------------------------------------------------------------ ! iterative solution - real(dp) :: func1,func2 ! functions for numerical derivative calculation - real(dp) :: cMin,cMax ! solution brackets - real(dp) :: xInc ! iteration increment (Pa) + real(summa_prec) :: func1,func2 ! functions for numerical derivative calculation + real(summa_prec) :: cMin,cMax ! solution brackets + real(summa_prec) :: xInc ! iteration increment (Pa) integer(i4b) :: iter ! iteration index ! ------------------------------------------------------------------------------------------------------------------------------------------------------ ! associate variables in the data structure @@ -498,8 +498,8 @@ subroutine stomResist_flex(& ! check there is light available for photosynthesis if(absorbedPAR < tiny(absorbedPAR) .or. scalarGrowingSeasonIndex < tiny(absorbedPAR))then scalarStomResist = unitConv*umol_per_mol/(scalarTranspireLim*minStomatalConductance) - scalarPhotosynthesis = 0._dp - ci = 0._dp + scalarPhotosynthesis = 0._summa_prec + ci = 0._summa_prec return end if @@ -572,27 +572,27 @@ subroutine stomResist_flex(& ! linear function of qmax, as used in Cable [Wang et al., Ag Forest Met 1998, eq D5] case(linearJmax) x0 = quantamYield*joule2umolConv*absorbedPAR - x1 = x0*jmax / (x0 + 2.1_dp*jmax) - Js = x1/4._dp ! scaled electron transport + x1 = x0*jmax / (x0 + 2.1_summa_prec*jmax) + Js = x1/4._summa_prec ! scaled electron transport ! quadraric function of jmax, as used in CLM5 (Bonan et al., JGR 2011, Table B2) case(quadraticJmax) ! PAR absorbed by PS2 (umol photon m-2 s-1) - I_ps2 = 0.5_dp*(1._dp - fractionJ) * joule2umolConv*absorbedPAR ! Farquar (1980), eq 8: PAR absorbed by PS2 (umol photon m-2 s-1) + I_ps2 = 0.5_summa_prec*(1._summa_prec - fractionJ) * joule2umolConv*absorbedPAR ! Farquar (1980), eq 8: PAR absorbed by PS2 (umol photon m-2 s-1) ! define coefficients in the quadratic equation aQuad = c_ps2 ! quadratic coefficient = cuurvature factor for electron transport bQuad = -(I_ps2 + jmax) ! linear coefficient cQuad = I_ps2 * jmax ! free term ! compute the q term (NOTE: bQuad is always positive) bSign = abs(bQuad)/bQuad - xTemp = bQuad*bQuad - 4._dp *aQuad*cQuad - qQuad = -0.5_dp * (bQuad + bSign*sqrt(xTemp)) + xTemp = bQuad*bQuad - 4._summa_prec *aQuad*cQuad + qQuad = -0.5_summa_prec * (bQuad + bSign*sqrt(xTemp)) ! compute roots root1 = qQuad / aQuad root2 = cQuad / qQuad ! select minimum root, required to ensure J=0 when par=0 ! NOTE: Wittig et al. select the first root, which is the max in all cases I tried - Js = min(root1,root2) / 4._dp ! scaled J + Js = min(root1,root2) / 4._summa_prec ! scaled J ! check found an appropriate option case default; err=20; message=trim(message)//'unable to find option for electron transport controls on stomatal conductance'; return @@ -605,7 +605,7 @@ subroutine stomResist_flex(& ! define the humidity function select case(ix_bbHumdFunc) - case(humidLeafSurface); fHum = min( max(0.25_dp, scalarVP_CanopyAir/scalarSatVP_VegTemp), 1._dp) + case(humidLeafSurface); fHum = min( max(0.25_summa_prec, scalarVP_CanopyAir/scalarSatVP_VegTemp), 1._summa_prec) case(scaledHyperbolic); fHum = (scalarSatVP_VegTemp - scalarVP_CanopyAir)/vpScaleFactor case default; err=20; message=trim(message)//'unable to identify humidity control on stomatal conductance'; return end select @@ -614,23 +614,23 @@ subroutine stomResist_flex(& co2compPt = (Kc/Ko)*scalarO2air*o2scaleFactor ! compute the Michaelis-Menten controls (Pa) - awb = Kc*(1._dp + scalarO2air/Ko) + awb = Kc*(1._summa_prec + scalarO2air/Ko) ! compute the additional controls in light-limited assimilation - cp2 = co2compPt*2._dp + cp2 = co2compPt*2._summa_prec ! define trial value of intercellular co2 (Pa) ! NOTE: only initialize if less than the co2 compensation point; otherwise, initialize with previous value if(ix_bbNumerics==newtonRaphson)then - if(ci < co2compPt) ci = 0.7_dp*scalarCO2air + if(ci < co2compPt) ci = 0.7_summa_prec*scalarCO2air else - ci = 0.7_dp*scalarCO2air ! always initialize if not NR + ci = 0.7_summa_prec*scalarCO2air ! always initialize if not NR end if !write(*,'(a,1x,10(f20.10,1x))') 'Kc25, Kc_qFac, Ko25, Ko_qFac = ', Kc25, Kc_qFac, Ko25, Ko_qFac !write(*,'(a,1x,10(f20.10,1x))') 'scalarCO2air, ci, co2compPt, Kc, Ko = ', scalarCO2air, ci, co2compPt, Kc, Ko ! initialize brackets for the solution - cMin = 0._dp + cMin = 0._summa_prec cMax = scalarCO2air ! ********************************************************************************************************************************* @@ -670,14 +670,14 @@ subroutine stomResist_flex(& ! compute conductance in the absence of humidity g0 = cond2photo_slope*airpres*psn/csx - dg0_dc = cond2photo_slope*airpres*dA_dc*(x1*psn/cs + 1._dp)/csx + dg0_dc = cond2photo_slope*airpres*dA_dc*(x1*psn/cs + 1._summa_prec)/csx ! use quadratic function to compute stomatal resistance call quadResist(.true.,ix_bbHumdFunc,rlb,fHum,gMin,g0,dg0_dc,rs,drs_dc) ! compute intercellular co2 partial pressues (Pa) x2 = h2o_co2__stomPores * airpres ! Pa - ci = max(cs - x2*psn*rs, 0._dp) ! Pa + ci = max(cs - x2*psn*rs, 0._summa_prec) ! Pa ! print progress !if(ix_bbNumerics==NoahMPsolution)then @@ -689,7 +689,7 @@ subroutine stomResist_flex(& if(ci > tiny(ci))then dci_dc = -x1*dA_dc - x2*(psn*drs_dc + rs*dA_dc) else - dci_dc = 0._dp + dci_dc = 0._summa_prec end if ! test derivatives @@ -721,14 +721,14 @@ subroutine stomResist_flex(& end if ! compute iteration increment (Pa) - xInc = (ci - ci_old)/(1._dp - dci_dc) + xInc = (ci - ci_old)/(1._summa_prec - dci_dc) ! update - ci = max(ci_old + xInc, 0._dp) + ci = max(ci_old + xInc, 0._summa_prec) ! ensure that we stay within brackets if(ci > cMax .or. ci < cMin)then - ci = 0.5_dp * (cMin + cMax) + ci = 0.5_summa_prec * (cMin + cMax) end if ! print progress @@ -758,11 +758,11 @@ subroutine stomResist_flex(& ! internal function used to test derivatives function testFunc(ci, cond2photo_slope, airpres, scalarCO2air, ix_bbHumdFunc, ix_bbCO2point, ix_bbAssimFnc) - real(dp),intent(in) :: ci, cond2photo_slope, airpres, scalarCO2air + real(summa_prec),intent(in) :: ci, cond2photo_slope, airpres, scalarCO2air integer(i4b),intent(in) :: ix_bbHumdFunc, ix_bbCO2point, ix_bbAssimFnc - real(dp) :: testFunc - real(dp),parameter :: unUsedInput=0._dp - real(dp) :: unUsedOutput + real(summa_prec) :: testFunc + real(summa_prec),parameter :: unUsedInput=0._summa_prec + real(summa_prec) :: unUsedOutput ! compute gross photosynthesis [follow Farquar (Planta, 1980), as implemented in CLM4 and Noah-MP] call photosynthesis(.false., ix_bbAssimFnc, ci, co2compPt, awb, cp2, vcmax, Js, psn, unUsedOutput) @@ -786,7 +786,7 @@ function testFunc(ci, cond2photo_slope, airpres, scalarCO2air, ix_bbHumdFunc, ix ! compute intercellular co2 partial pressues (Pa) x2 = h2o_co2__stomPores * airpres ! Pa - testFunc = max(cs - x2*psn*rs, 0._dp) ! Pa + testFunc = max(cs - x2*psn*rs, 0._summa_prec) ! Pa end function testFunc @@ -800,37 +800,37 @@ subroutine photosynthesis(desireDeriv, ix_bbAssimFnc, ci, co2compPt, awb, cp2, v ! dummy variables logical(lgt),intent(in) :: desireDeriv ! .true. if the derivative is desired integer(i4b),intent(in) :: ix_bbAssimFnc ! model option for the function used for co2 assimilation (min func, or colimtation) - real(dp),intent(in) :: ci ! intercellular co2 concentration (Pa) - real(dp),intent(in) :: co2compPt ! co2 compensation point (Pa) - real(dp),intent(in) :: awb ! Michaelis-Menten control (Pa) - real(dp),intent(in) :: cp2 ! additional controls in light-limited assimilation (Pa) - real(dp),intent(in) :: vcmax ! maximum Rubisco carboxylation rate (umol co2 m-2 s-1) - real(dp),intent(in) :: Js ! scaled electron transport rate (umol co2 m-2 s-1) - real(dp),intent(out) :: psn ! leaf gross photosynthesis rate (umol co2 m-2 s-1) - real(dp),intent(out) :: dA_dc ! derivative in photosynthesis w.r.t. intercellular co2 concentration (umol co2 m-2 s-1 Pa-1) + real(summa_prec),intent(in) :: ci ! intercellular co2 concentration (Pa) + real(summa_prec),intent(in) :: co2compPt ! co2 compensation point (Pa) + real(summa_prec),intent(in) :: awb ! Michaelis-Menten control (Pa) + real(summa_prec),intent(in) :: cp2 ! additional controls in light-limited assimilation (Pa) + real(summa_prec),intent(in) :: vcmax ! maximum Rubisco carboxylation rate (umol co2 m-2 s-1) + real(summa_prec),intent(in) :: Js ! scaled electron transport rate (umol co2 m-2 s-1) + real(summa_prec),intent(out) :: psn ! leaf gross photosynthesis rate (umol co2 m-2 s-1) + real(summa_prec),intent(out) :: dA_dc ! derivative in photosynthesis w.r.t. intercellular co2 concentration (umol co2 m-2 s-1 Pa-1) ! local variables integer(i4b),parameter :: nFactors=3 ! number of limiting factors for assimilation (light, Rubisco, and export) integer(i4b),parameter :: ixRubi=1 ! named variable for Rubisco-limited assimilation integer(i4b),parameter :: ixLight=2 ! named variable for light-limited assimilation integer(i4b),parameter :: ixExport=3 ! named variable for export-limited assimilation integer(i4b) :: ixLimitVec(1),ixLimit ! index of factor limiting assimilation - real(dp) :: xFac(nFactors) ! temporary variable used to compute assimilation rate - real(dp) :: xPSN(nFactors) ! assimilation rate for different factors (light, Rubisco, and export) - real(dp) :: ciDiff ! difference between intercellular co2 and the co2 compensation point - real(dp) :: ciDer ! factor to account for constainted intercellular co2 in calculating derivatives - real(dp) :: x0 ! temporary variable - real(dp) :: xsPSN ! intermediate smoothed photosynthesis - real(dp) :: dAc_dc,dAj_dc,dAe_dc,dAi_dc ! derivatives in assimilation w.r.t. intercellular co2 concentration - real(dp),parameter :: theta_cj=0.98_dp ! coupling coefficient (see Sellers et al., 1996 [eq C6]; Bonan et al., 2011 [Table B1]) - real(dp),parameter :: theta_ie=0.95_dp ! coupling coefficient (see Sellers et al., 1996 [eq C6]; Bonan et al., 2011 [Table B1]) + real(summa_prec) :: xFac(nFactors) ! temporary variable used to compute assimilation rate + real(summa_prec) :: xPSN(nFactors) ! assimilation rate for different factors (light, Rubisco, and export) + real(summa_prec) :: ciDiff ! difference between intercellular co2 and the co2 compensation point + real(summa_prec) :: ciDer ! factor to account for constainted intercellular co2 in calculating derivatives + real(summa_prec) :: x0 ! temporary variable + real(summa_prec) :: xsPSN ! intermediate smoothed photosynthesis + real(summa_prec) :: dAc_dc,dAj_dc,dAe_dc,dAi_dc ! derivatives in assimilation w.r.t. intercellular co2 concentration + real(summa_prec),parameter :: theta_cj=0.98_summa_prec ! coupling coefficient (see Sellers et al., 1996 [eq C6]; Bonan et al., 2011 [Table B1]) + real(summa_prec),parameter :: theta_ie=0.95_summa_prec ! coupling coefficient (see Sellers et al., 1996 [eq C6]; Bonan et al., 2011 [Table B1]) ! ------------------------------------------------------------ ! this method follows Farquar (Planta, 1980), as implemented in CLM4 and Noah-MP ! compute the difference between intercellular co2 concentraion and the compensation point - ciDiff = max(0._dp, ci - co2compPt) + ciDiff = max(0._summa_prec, ci - co2compPt) ! impose constraints (NOTE: derivative is zero if constraints are imposed) - if(ci < co2compPt)then; ciDer = 0._dp; else; ciDer = 1._dp; end if + if(ci < co2compPt)then; ciDer = 0._summa_prec; else; ciDer = 1._summa_prec; end if ! compute Rubisco-limited assimilation xFac(ixRubi) = vcmax/(ci + awb) ! umol co2 m-2 s-1 Pa-1 @@ -841,7 +841,7 @@ subroutine photosynthesis(desireDeriv, ix_bbAssimFnc, ci, co2compPt, awb, cp2, v xPSN(ixLight) = xFac(ixLight)*ciDiff ! umol co2 m-2 s-1 ! compute export limited assimilation - xFac(ixExport) = 0.5_dp + xFac(ixExport) = 0.5_summa_prec xPSN(ixExport) = xFac(ixExport)*vcmax ! umol co2 m-2 s-1 ! print progress @@ -868,12 +868,12 @@ subroutine photosynthesis(desireDeriv, ix_bbAssimFnc, ci, co2compPt, awb, cp2, v select case(ixLimit) case(ixRubi); dA_dc = x0*ciDer - ciDiff*x0*x0/vcmax ! Rubisco-limited assimilation case(ixLight); dA_dc = x0*ciDer - ciDiff*x0*x0/Js ! light-limited assimilation - case(ixExport); dA_dc = 0._dp ! export-limited assimilation + case(ixExport); dA_dc = 0._summa_prec ! export-limited assimilation end select ! derivatives are not desired else - dA_dc = 0._dp + dA_dc = 0._summa_prec end if ! colimitation (Collatz et al., 1991; Sellers et al., 1996; Bonan et al., 2011) @@ -883,19 +883,19 @@ subroutine photosynthesis(desireDeriv, ix_bbAssimFnc, ci, co2compPt, awb, cp2, v if(desireDeriv)then dAc_dc = xFac(ixRubi)*ciDer - ciDiff*xFac(ixRubi)*xFac(ixRubi)/vcmax dAj_dc = xFac(ixLight)*ciDer - ciDiff*xFac(ixLight)*xFac(ixLight)/Js - dAe_dc = 0._dp + dAe_dc = 0._summa_prec else - dAc_dc = 0._dp - dAj_dc = 0._dp - dAe_dc = 0._dp + dAc_dc = 0._summa_prec + dAj_dc = 0._summa_prec + dAe_dc = 0._summa_prec end if ! smooth Rubisco-limitation and light limitation if(ciDiff > tiny(ciDiff))then call quadSmooth(desireDeriv, xPSN(ixRubi), xPSN(ixLight), theta_cj, dAc_dc, dAj_dc, xsPSN, dAi_dc) else - xsPSN = 0._dp - dAi_dc = 0._dp + xsPSN = 0._summa_prec + dAi_dc = 0._summa_prec end if ! smooth intermediate-limitation and export limitation @@ -942,18 +942,18 @@ subroutine quadResist(desireDeriv,ix_bbHumdFunc,rlb,fHum,gMin,g0,dg0_dc,rs,drs_d ! dummy variables logical(lgt),intent(in) :: desireDeriv ! flag to denote if the derivative is desired integer(i4b),intent(in) :: ix_bbHumdFunc ! option for humidity control on stomatal resistance - real(dp),intent(in) :: rlb ! leaf boundary layer resistance (umol-1 m2 s) - real(dp),intent(in) :: fHum ! scaled humidity function (-) - real(dp),intent(in) :: gMin ! scaled minimum stomatal consuctance (umol m-2 s-1) - real(dp),intent(in) :: g0 ! stomatal conductance in the absence of humidity controls (umol m-2 s-1) - real(dp),intent(in) :: dg0_dc ! derivative in g0 w.r.t intercellular co2 concentration (umol m-2 s-1 Pa-1) - real(dp),intent(out) :: rs ! stomatal resistance ((umol-1 m2 s) - real(dp),intent(out) :: drs_dc ! derivaive in rs w.r.t intercellular co2 concentration (umol-1 m2 s Pa-1) + real(summa_prec),intent(in) :: rlb ! leaf boundary layer resistance (umol-1 m2 s) + real(summa_prec),intent(in) :: fHum ! scaled humidity function (-) + real(summa_prec),intent(in) :: gMin ! scaled minimum stomatal consuctance (umol m-2 s-1) + real(summa_prec),intent(in) :: g0 ! stomatal conductance in the absence of humidity controls (umol m-2 s-1) + real(summa_prec),intent(in) :: dg0_dc ! derivative in g0 w.r.t intercellular co2 concentration (umol m-2 s-1 Pa-1) + real(summa_prec),intent(out) :: rs ! stomatal resistance ((umol-1 m2 s) + real(summa_prec),intent(out) :: drs_dc ! derivaive in rs w.r.t intercellular co2 concentration (umol-1 m2 s Pa-1) ! local variables - real(dp) :: aQuad,bQuad,cQuad ! coefficients in the quadratic function - real(dp) :: bSign,xTemp,qQuad ! q term in the quadratic - real(dp) :: root1,root2 ! roots of the quadratic - real(dp) :: dxT_dc,dqq_dc ! derivatives in the q term + real(summa_prec) :: aQuad,bQuad,cQuad ! coefficients in the quadratic function + real(summa_prec) :: bSign,xTemp,qQuad ! q term in the quadratic + real(summa_prec) :: root1,root2 ! roots of the quadratic + real(summa_prec) :: dxT_dc,dqq_dc ! derivatives in the q term ! define terms for the quadratic function select case(ix_bbHumdFunc) @@ -961,21 +961,21 @@ subroutine quadResist(desireDeriv,ix_bbHumdFunc,rlb,fHum,gMin,g0,dg0_dc,rs,drs_d ! original Ball-Berry case(humidLeafSurface) aQuad = g0*fHum + gMin - bQuad = (g0 + gMin)*rlb - 1._dp + bQuad = (g0 + gMin)*rlb - 1._summa_prec cQuad = -rlb ! Leuning 1995 case(scaledHyperbolic) - aQuad = g0 + gMin*(1._dp + fHum) - bQuad = (g0 + gMin)*rlb - fHum - 1._dp + aQuad = g0 + gMin*(1._summa_prec + fHum) + bQuad = (g0 + gMin)*rlb - fHum - 1._summa_prec cQuad = -rlb end select ! compute the q term in the quadratic bSign = abs(bQuad)/bQuad - xTemp = bQuad*bQuad - 4._dp *aQuad*cQuad - qquad = -0.5_dp * (bQuad + bSign*sqrt(xTemp)) + xTemp = bQuad*bQuad - 4._summa_prec *aQuad*cQuad + qquad = -0.5_summa_prec * (bQuad + bSign*sqrt(xTemp)) ! compute roots root1 = qQuad / aQuad @@ -992,10 +992,10 @@ subroutine quadResist(desireDeriv,ix_bbHumdFunc,rlb,fHum,gMin,g0,dg0_dc,rs,drs_d ! compute derivatives in qquad w.r.t. ci select case(ix_bbHumdFunc) - case(humidLeafSurface); dXt_dc = dg0_dc*(rlb*bQuad*2._dp - fHum*cQuad*4._dp) - case(scaledHyperbolic); dXt_dc = dg0_dc*(rlb*bQuad*2._dp - cQuad*4._dp) + case(humidLeafSurface); dXt_dc = dg0_dc*(rlb*bQuad*2._summa_prec - fHum*cQuad*4._summa_prec) + case(scaledHyperbolic); dXt_dc = dg0_dc*(rlb*bQuad*2._summa_prec - cQuad*4._summa_prec) end select - dqq_dc = -0.5_dp * (rlb*dg0_dc + bSign*dXt_dc*0.5_dp / sqrt(xTemp) ) + dqq_dc = -0.5_summa_prec * (rlb*dg0_dc + bSign*dXt_dc*0.5_summa_prec / sqrt(xTemp) ) ! compute derivatives in rs if(root1 > root2)then @@ -1009,7 +1009,7 @@ subroutine quadResist(desireDeriv,ix_bbHumdFunc,rlb,fHum,gMin,g0,dg0_dc,rs,drs_d ! derivatives not desired else - drs_dc = 0._dp + drs_dc = 0._summa_prec end if end subroutine quadResist @@ -1022,17 +1022,17 @@ subroutine quadSmooth(desireDeriv, x1, x2, xsFac, dx1_dc, dx2_dc, xs, dxs_dc) implicit none ! dummy variables logical(lgt),intent(in) :: desireDeriv ! flag to denote if a derivative is desired - real(dp),intent(in) :: x1,x2 ! variables to be smoothed - real(dp),intent(in) :: xsFac ! smoothing factor - real(dp),intent(in) :: dx1_dc,dx2_dc ! derivatives in variables w.r.t. something important - real(dp),intent(out) :: xs ! smoothed variable - real(dp),intent(out) :: dxs_dc ! derivative w.r.t. something important + real(summa_prec),intent(in) :: x1,x2 ! variables to be smoothed + real(summa_prec),intent(in) :: xsFac ! smoothing factor + real(summa_prec),intent(in) :: dx1_dc,dx2_dc ! derivatives in variables w.r.t. something important + real(summa_prec),intent(out) :: xs ! smoothed variable + real(summa_prec),intent(out) :: dxs_dc ! derivative w.r.t. something important ! local variables - real(dp) :: aQuad,bQuad,cQuad ! coefficients in the quadratic function - real(dp) :: bSign,xTemp,qQuad ! q term in the quadratic - real(dp) :: root1,root2 ! roots of the quadratic - real(dp) :: dbq_dc,dcq_dc ! derivatives in quadratic coefficients - real(dp) :: dxT_dc,dqq_dc ! derivatives in the q term + real(summa_prec) :: aQuad,bQuad,cQuad ! coefficients in the quadratic function + real(summa_prec) :: bSign,xTemp,qQuad ! q term in the quadratic + real(summa_prec) :: root1,root2 ! roots of the quadratic + real(summa_prec) :: dbq_dc,dcq_dc ! derivatives in quadratic coefficients + real(summa_prec) :: dxT_dc,dqq_dc ! derivatives in the q term ! uses the quadratic of the form ! xsFac*xs^2 - (x1 + x2)*xs + x1*x2 = 0 @@ -1045,8 +1045,8 @@ subroutine quadSmooth(desireDeriv, x1, x2, xsFac, dx1_dc, dx2_dc, xs, dxs_dc) ! compute the q term in the quadratic bSign = abs(bQuad)/bQuad - xTemp = bQuad*bQuad - 4._dp *aQuad*cQuad - qquad = -0.5_dp * (bQuad + bSign*sqrt(xTemp)) + xTemp = bQuad*bQuad - 4._summa_prec *aQuad*cQuad + qquad = -0.5_summa_prec * (bQuad + bSign*sqrt(xTemp)) ! compute roots root1 = qQuad / aQuad @@ -1061,8 +1061,8 @@ subroutine quadSmooth(desireDeriv, x1, x2, xsFac, dx1_dc, dx2_dc, xs, dxs_dc) dcq_dc = x1*dx2_dc + x2*dx1_dc ! compute derivatives for xTemp - dxT_dc = 2._dp*(bQuad*dbq_dc) - 4._dp*aQuad*dcq_dc - dqq_dc = -0.5_dp * (dbq_dc + bsign*dxT_dc/(2._dp*sqrt(xTemp))) + dxT_dc = 2._summa_prec*(bQuad*dbq_dc) - 4._summa_prec*aQuad*dcq_dc + dqq_dc = -0.5_summa_prec * (dbq_dc + bsign*dxT_dc/(2._summa_prec*sqrt(xTemp))) ! compute derivatives in the desired root if(root1 < root2)then @@ -1073,7 +1073,7 @@ subroutine quadSmooth(desireDeriv, x1, x2, xsFac, dx1_dc, dx2_dc, xs, dxs_dc) ! derivatives not required else - dxs_dc = 0._dp + dxs_dc = 0._summa_prec end if end subroutine quadSmooth @@ -1086,32 +1086,32 @@ end subroutine quadSmooth ! q10 function for temperature dependence function q10(a,T,Tmid,Tscale) implicit none - real(dp),intent(in) :: a ! scale factor - real(dp),intent(in) :: T ! temperature (K) - real(dp),intent(in) :: Tmid ! point where function is one (25 deg C) - real(dp),intent(in) :: Tscale ! scaling factor (K) - real(dp) :: q10 ! temperature dependence (-) + real(summa_prec),intent(in) :: a ! scale factor + real(summa_prec),intent(in) :: T ! temperature (K) + real(summa_prec),intent(in) :: Tmid ! point where function is one (25 deg C) + real(summa_prec),intent(in) :: Tscale ! scaling factor (K) + real(summa_prec) :: q10 ! temperature dependence (-) q10 = a**((T - Tmid)/Tscale) end function q10 ! Arrhenius function for temperature dependence function fT(delH,T,Tref) implicit none - real(dp),intent(in) :: delH ! activation energy in temperature function (J mol-1) - real(dp),intent(in) :: T ! temperature (K) - real(dp),intent(in) :: Tref ! reference temperature (K) - real(dp) :: fT ! temperature dependence (-) - fT = exp((delH/(Tref*Rgas))*(1._dp - Tref/T)) ! NOTE: Rgas = J K-1 mol-1 + real(summa_prec),intent(in) :: delH ! activation energy in temperature function (J mol-1) + real(summa_prec),intent(in) :: T ! temperature (K) + real(summa_prec),intent(in) :: Tref ! reference temperature (K) + real(summa_prec) :: fT ! temperature dependence (-) + fT = exp((delH/(Tref*Rgas))*(1._summa_prec - Tref/T)) ! NOTE: Rgas = J K-1 mol-1 end function fT ! function for high temperature inhibition function fHigh(delH,delS,T) implicit none - real(dp),intent(in) :: delH ! deactivation energy in high temp inhibition function (J mol-1) - real(dp),intent(in) :: delS ! entropy term in high temp inhibition function (J K-1 mol-1) - real(dp),intent(in) :: T ! temperature (K) - real(dp) :: fHigh ! high temperature inhibition (-) - fHigh = 1._dp + exp( (delS*T - delH)/(Rgas*T) ) ! NOTE: Rgas = J K-1 mol-1 + real(summa_prec),intent(in) :: delH ! deactivation energy in high temp inhibition function (J mol-1) + real(summa_prec),intent(in) :: delS ! entropy term in high temp inhibition function (J K-1 mol-1) + real(summa_prec),intent(in) :: T ! temperature (K) + real(summa_prec) :: fHigh ! high temperature inhibition (-) + fHigh = 1._summa_prec + exp( (delS*T - delH)/(Rgas*T) ) ! NOTE: Rgas = J K-1 mol-1 end function fHigh @@ -1161,34 +1161,34 @@ subroutine stomResist_NoahMP(& integer(i4b),intent(in) :: vegTypeIndex ! vegetation type index integer(i4b),intent(in) :: iLoc, jLoc ! spatial location indices ! input (forcing) - real(dp),intent(in) :: airtemp ! measured air temperature at some height above the surface (K) - real(dp),intent(in) :: airpres ! measured air pressure at some height above the surface (Pa) - real(dp),intent(in) :: scalarO2air ! atmospheric o2 concentration (Pa) - real(dp),intent(in) :: scalarCO2air ! atmospheric co2 concentration (Pa) - real(dp),intent(in),target :: scalarCanopySunlitPAR ! average absorbed par for sunlit leaves (w m-2) - real(dp),intent(in),target :: scalarCanopyShadedPAR ! average absorbed par for shaded leaves (w m-2) + real(summa_prec),intent(in) :: airtemp ! measured air temperature at some height above the surface (K) + real(summa_prec),intent(in) :: airpres ! measured air pressure at some height above the surface (Pa) + real(summa_prec),intent(in) :: scalarO2air ! atmospheric o2 concentration (Pa) + real(summa_prec),intent(in) :: scalarCO2air ! atmospheric co2 concentration (Pa) + real(summa_prec),intent(in),target :: scalarCanopySunlitPAR ! average absorbed par for sunlit leaves (w m-2) + real(summa_prec),intent(in),target :: scalarCanopyShadedPAR ! average absorbed par for shaded leaves (w m-2) ! input (state and diagnostic variables) - real(dp),intent(in) :: scalarGrowingSeasonIndex ! growing season index (0=off, 1=on) - real(dp),intent(in) :: scalarFoliageNitrogenFactor ! foliage nitrogen concentration (1=saturated) - real(dp),intent(in) :: scalarTranspireLim ! weighted average of the soil moiture factor controlling stomatal resistance (-) - real(dp),intent(in) :: scalarLeafResistance ! leaf boundary layer resistance (s m-1) - real(dp),intent(in) :: scalarVegetationTemp ! vegetation temperature (K) - real(dp),intent(in) :: scalarSatVP_VegTemp ! saturation vapor pressure at vegetation temperature (Pa) - real(dp),intent(in) :: scalarVP_CanopyAir ! canopy air vapor pressure (Pa) + real(summa_prec),intent(in) :: scalarGrowingSeasonIndex ! growing season index (0=off, 1=on) + real(summa_prec),intent(in) :: scalarFoliageNitrogenFactor ! foliage nitrogen concentration (1=saturated) + real(summa_prec),intent(in) :: scalarTranspireLim ! weighted average of the soil moiture factor controlling stomatal resistance (-) + real(summa_prec),intent(in) :: scalarLeafResistance ! leaf boundary layer resistance (s m-1) + real(summa_prec),intent(in) :: scalarVegetationTemp ! vegetation temperature (K) + real(summa_prec),intent(in) :: scalarSatVP_VegTemp ! saturation vapor pressure at vegetation temperature (Pa) + real(summa_prec),intent(in) :: scalarVP_CanopyAir ! canopy air vapor pressure (Pa) ! output - real(dp),intent(out) :: scalarStomResistSunlit ! stomatal resistance for sunlit leaves (s m-1) - real(dp),intent(out) :: scalarStomResistShaded ! stomatal resistance for shaded leaves (s m-1) - real(dp),intent(out) :: scalarPhotosynthesisSunlit ! sunlit photosynthesis (umolco2 m-2 s-1) - real(dp),intent(out) :: scalarPhotosynthesisShaded ! sunlit photosynthesis (umolco2 m-2 s-1) + real(summa_prec),intent(out) :: scalarStomResistSunlit ! stomatal resistance for sunlit leaves (s m-1) + real(summa_prec),intent(out) :: scalarStomResistShaded ! stomatal resistance for shaded leaves (s m-1) + real(summa_prec),intent(out) :: scalarPhotosynthesisSunlit ! sunlit photosynthesis (umolco2 m-2 s-1) + real(summa_prec),intent(out) :: scalarPhotosynthesisShaded ! sunlit photosynthesis (umolco2 m-2 s-1) integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! local variables integer(i4b),parameter :: ixSunlit=1 ! named variable for sunlit leaves integer(i4b),parameter :: ixShaded=2 ! named variable for shaded leaves integer(i4b) :: iSunShade ! index for sunlit/shaded leaves - real(dp),pointer :: PAR ! average absorbed PAR for sunlit/shaded leaves (w m-2) - real(dp) :: scalarStomResist ! stomatal resistance for sunlit/shaded leaves (s m-1) - real(dp) :: scalarPhotosynthesis ! photosynthesis for sunlit/shaded leaves (umolco2 m-2 s-1) + real(summa_prec),pointer :: PAR ! average absorbed PAR for sunlit/shaded leaves (w m-2) + real(summa_prec) :: scalarStomResist ! stomatal resistance for sunlit/shaded leaves (s m-1) + real(summa_prec) :: scalarPhotosynthesis ! photosynthesis for sunlit/shaded leaves (umolco2 m-2 s-1) ! initialize error control err=0; message='stomResist_NoahMP/' diff --git a/build/source/engine/summaSolve.f90 b/build/source/engine/summaSolve.f90 index ee4dfc886..59819989d 100755 --- a/build/source/engine/summaSolve.f90 +++ b/build/source/engine/summaSolve.f90 @@ -136,7 +136,7 @@ subroutine summaSolve(& implicit none ! -------------------------------------------------------------------------------------------------------------------------------- ! input: model control - real(dp),intent(in) :: dt ! length of the time step (seconds) + real(summa_prec),intent(in) :: dt ! length of the time step (seconds) integer(i4b),intent(in) :: iter ! interation index integer(i4b),intent(in) :: nSnow ! number of snow layers integer(i4b),intent(in) :: nSoil ! number of soil layers @@ -149,14 +149,14 @@ subroutine summaSolve(& logical(lgt),intent(in) :: computeVegFlux ! flag to indicate if computing fluxes over vegetation logical(lgt),intent(in) :: scalarSolution ! flag to denote if implementing the scalar solution ! input: state vectors - real(dp),intent(in) :: stateVecTrial(:) ! trial state vector - real(dp),intent(inout) :: xMin,xMax ! brackets of the root - real(dp),intent(in) :: fScale(:) ! function scaling vector - real(dp),intent(in) :: xScale(:) ! "variable" scaling vector, i.e., for state variables - real(qp),intent(in) :: rVec(:) ! NOTE: qp ! residual vector - real(qp),intent(in) :: sMul(:) ! NOTE: qp ! state vector multiplier (used in the residual calculations) - real(dp),intent(inout) :: dMat(:) ! diagonal matrix (excludes flux derivatives) - real(dp),intent(in) :: fOld ! old function evaluation + real(summa_prec),intent(in) :: stateVecTrial(:) ! trial state vector + real(summa_prec),intent(inout) :: xMin,xMax ! brackets of the root + real(summa_prec),intent(in) :: fScale(:) ! function scaling vector + real(summa_prec),intent(in) :: xScale(:) ! "variable" scaling vector, i.e., for state variables + real(summa_prec),intent(in) :: rVec(:) ! NOTE: qp ! residual vector + real(summa_prec),intent(in) :: sMul(:) ! NOTE: qp ! state vector multiplier (used in the residual calculations) + real(summa_prec),intent(inout) :: dMat(:) ! diagonal matrix (excludes flux derivatives) + real(summa_prec),intent(in) :: fOld ! old function evaluation ! input: data structures type(model_options),intent(in) :: model_decisions(:) ! model decisions type(var_i), intent(in) :: type_data ! type of vegetation and soil @@ -172,13 +172,13 @@ subroutine summaSolve(& type(var_dlength),intent(inout) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables ! input-output: baseflow integer(i4b),intent(inout) :: ixSaturation ! index of the lowest saturated layer (NOTE: only computed on the first iteration) - real(dp),intent(inout) :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) + real(summa_prec),intent(inout) :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) ! output: flux and residual vectors - real(dp),intent(out) :: stateVecNew(:) ! new state vector - real(dp),intent(out) :: fluxVecNew(:) ! new flux vector - real(dp),intent(out) :: resSinkNew(:) ! sink terms on the RHS of the flux equation - real(qp),intent(out) :: resVecNew(:) ! NOTE: qp ! new residual vector - real(dp),intent(out) :: fNew ! new function evaluation + real(summa_prec),intent(out) :: stateVecNew(:) ! new state vector + real(summa_prec),intent(out) :: fluxVecNew(:) ! new flux vector + real(summa_prec),intent(out) :: resSinkNew(:) ! sink terms on the RHS of the flux equation + real(summa_prec),intent(out) :: resVecNew(:) ! NOTE: qp ! new residual vector + real(summa_prec),intent(out) :: fNew ! new function evaluation logical(lgt),intent(out) :: converged ! convergence flag ! output: error control integer(i4b),intent(out) :: err ! error code @@ -189,13 +189,13 @@ subroutine summaSolve(& ! Jacobian matrix logical(lgt),parameter :: doNumJacobian=.false. ! flag to compute the numerical Jacobian matrix logical(lgt),parameter :: testBandDiagonal=.false. ! flag to test the band diagonal Jacobian matrix - real(dp) :: nJac(nState,nState) ! numerical Jacobian matrix - real(dp) :: aJac(nLeadDim,nState) ! Jacobian matrix - real(dp) :: aJacScaled(nLeadDim,nState) ! Jacobian matrix (scaled) - real(dp) :: aJacScaledTemp(nLeadDim,nState) ! Jacobian matrix (scaled) -- temporary copy since decomposed in lapack + real(summa_prec) :: nJac(nState,nState) ! numerical Jacobian matrix + real(summa_prec) :: aJac(nLeadDim,nState) ! Jacobian matrix + real(summa_prec) :: aJacScaled(nLeadDim,nState) ! Jacobian matrix (scaled) + real(summa_prec) :: aJacScaledTemp(nLeadDim,nState) ! Jacobian matrix (scaled) -- temporary copy since decomposed in lapack ! solution/step vectors - real(dp),dimension(nState) :: rVecScaled ! residual vector (scaled) - real(dp),dimension(nState) :: newtStepScaled ! full newton step (scaled) + real(summa_prec),dimension(nState) :: rVecScaled ! residual vector (scaled) + real(summa_prec),dimension(nState) :: newtStepScaled ! full newton step (scaled) ! step size refinement logical(lgt) :: doRefine ! flag for step refinement integer(i4b),parameter :: ixLineSearch=1001 ! step refinement = line search @@ -269,7 +269,7 @@ subroutine summaSolve(& ! ------------------------ ! scale the residual vector - rVecScaled(1:nState) = fScale(:)*real(rVec(:), dp) ! NOTE: residual vector is in quadruple precision + rVecScaled(1:nState) = fScale(:)*real(rVec(:), summa_prec) ! NOTE: residual vector is in quadruple precision ! scale matrices call scaleMatrices(ixMatrix,nState,aJac,fScale,xScale,aJacScaled,err,cmessage) @@ -342,36 +342,36 @@ subroutine lineSearchRefinement(doLineSearch,stateVecTrial,newtStepScaled,aJacSc implicit none ! input logical(lgt),intent(in) :: doLineSearch ! flag to do the line search - real(dp),intent(in) :: stateVecTrial(:) ! trial state vector - real(dp),intent(in) :: newtStepScaled(:) ! scaled newton step - real(dp),intent(in) :: aJacScaled(:,:) ! scaled jacobian matrix - real(dp),intent(in) :: rVecScaled(:) ! scaled residual vector - real(dp),intent(in) :: fOld ! old function value + real(summa_prec),intent(in) :: stateVecTrial(:) ! trial state vector + real(summa_prec),intent(in) :: newtStepScaled(:) ! scaled newton step + real(summa_prec),intent(in) :: aJacScaled(:,:) ! scaled jacobian matrix + real(summa_prec),intent(in) :: rVecScaled(:) ! scaled residual vector + real(summa_prec),intent(in) :: fOld ! old function value ! output - real(dp),intent(out) :: stateVecNew(:) ! new state vector - real(dp),intent(out) :: fluxVecNew(:) ! new flux vector - real(qp),intent(out) :: resVecNew(:) ! NOTE: qp ! new residual vector - real(dp),intent(out) :: fNew ! new function evaluation + real(summa_prec),intent(out) :: stateVecNew(:) ! new state vector + real(summa_prec),intent(out) :: fluxVecNew(:) ! new flux vector + real(summa_prec),intent(out) :: resVecNew(:) ! NOTE: qp ! new residual vector + real(summa_prec),intent(out) :: fNew ! new function evaluation logical(lgt),intent(out) :: converged ! convergence flag integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! -------------------------------------------------------------------------------------------------------- ! local character(len=256) :: cmessage ! error message of downwind routine - real(dp) :: gradScaled(nState) ! scaled gradient - real(dp) :: xInc(nState) ! iteration increment (re-scaled to original units of the state vector) + real(summa_prec) :: gradScaled(nState) ! scaled gradient + real(summa_prec) :: xInc(nState) ! iteration increment (re-scaled to original units of the state vector) logical(lgt) :: feasible ! flag to denote the feasibility of the solution integer(i4b) :: iLine ! line search index integer(i4b),parameter :: maxLineSearch=5 ! maximum number of backtracks - real(dp),parameter :: alpha=1.e-4_dp ! check on gradient - real(dp) :: xLambda ! backtrack magnitude - real(dp) :: xLambdaTemp ! temporary backtrack magnitude - real(dp) :: slopeInit ! initial slope - real(dp) :: rhs1,rhs2 ! rhs used to compute the cubic - real(dp) :: aCoef,bCoef ! coefficients in the cubic - real(dp) :: disc ! temporary variable used in cubic - real(dp) :: xLambdaPrev ! previous lambda value (used in the cubic) - real(dp) :: fPrev ! previous function evaluation (used in the cubic) + real(summa_prec),parameter :: alpha=1.e-4_summa_prec ! check on gradient + real(summa_prec) :: xLambda ! backtrack magnitude + real(summa_prec) :: xLambdaTemp ! temporary backtrack magnitude + real(summa_prec) :: slopeInit ! initial slope + real(summa_prec) :: rhs1,rhs2 ! rhs used to compute the cubic + real(summa_prec) :: aCoef,bCoef ! coefficients in the cubic + real(summa_prec) :: disc ! temporary variable used in cubic + real(summa_prec) :: xLambdaPrev ! previous lambda value (used in the cubic) + real(summa_prec) :: fPrev ! previous function evaluation (used in the cubic) ! -------------------------------------------------------------------------------------------------------- ! initialize error control err=0; message='lineSearchRefinement/' @@ -389,7 +389,7 @@ subroutine lineSearchRefinement(doLineSearch,stateVecTrial,newtStepScaled,aJacSc end if ! if computing the line search ! initialize lambda - xLambda=1._dp + xLambda=1._summa_prec ! ***** LINE SEARCH LOOP... lineSearch: do iLine=1,maxLineSearch ! try to refine the function by shrinking the step size @@ -449,8 +449,8 @@ subroutine lineSearchRefinement(doLineSearch,stateVecTrial,newtStepScaled,aJacSc ! first backtrack: use quadratic if(iLine==1)then - xLambdaTemp = -slopeInit / (2._dp*(fNew - fOld - slopeInit) ) - if(xLambdaTemp > 0.5_dp*xLambda) xLambdaTemp = 0.5_dp*xLambda + xLambdaTemp = -slopeInit / (2._summa_prec*(fNew - fOld - slopeInit) ) + if(xLambdaTemp > 0.5_summa_prec*xLambda) xLambdaTemp = 0.5_summa_prec*xLambda ! subsequent backtracks: use cubic else @@ -470,21 +470,21 @@ subroutine lineSearchRefinement(doLineSearch,stateVecTrial,newtStepScaled,aJacSc bCoef = (-xLambdaPrev*rhs1/(xLambda*xLambda) + xLambda*rhs2/(xLambdaPrev*xLambdaPrev)) / (xLambda - xLambdaPrev) ! check if a quadratic - if(aCoef==0._dp)then - xLambdaTemp = -slopeInit/(2._dp*bCoef) + if(aCoef==0._summa_prec)then + xLambdaTemp = -slopeInit/(2._summa_prec*bCoef) ! calculate cubic else - disc = bCoef*bCoef - 3._dp*aCoef*slopeInit - if(disc < 0._dp)then - xLambdaTemp = 0.5_dp*xLambda + disc = bCoef*bCoef - 3._summa_prec*aCoef*slopeInit + if(disc < 0._summa_prec)then + xLambdaTemp = 0.5_summa_prec*xLambda else - xLambdaTemp = (-bCoef + sqrt(disc))/(3._dp*aCoef) + xLambdaTemp = (-bCoef + sqrt(disc))/(3._summa_prec*aCoef) end if end if ! calculating cubic ! constrain to <= 0.5*xLambda - if(xLambdaTemp > 0.5_dp*xLambda) xLambdaTemp=0.5_dp*xLambda + if(xLambdaTemp > 0.5_summa_prec*xLambda) xLambdaTemp=0.5_summa_prec*xLambda end if ! subsequent backtracks @@ -493,7 +493,7 @@ subroutine lineSearchRefinement(doLineSearch,stateVecTrial,newtStepScaled,aJacSc fPrev = fNew ! constrain lambda - xLambda = max(xLambdaTemp, 0.1_dp*xLambda) + xLambda = max(xLambdaTemp, 0.1_summa_prec*xLambda) end do lineSearch ! backtrack loop @@ -510,16 +510,16 @@ subroutine trustRegionRefinement(doTrustRefinement,stateVecTrial,newtStepScaled, implicit none ! input logical(lgt),intent(in) :: doTrustRefinement ! flag to refine using trust regions - real(dp),intent(in) :: stateVecTrial(:) ! trial state vector - real(dp),intent(in) :: newtStepScaled(:) ! scaled newton step - real(dp),intent(in) :: aJacScaled(:,:) ! scaled jacobian matrix - real(dp),intent(in) :: rVecScaled(:) ! scaled residual vector - real(dp),intent(in) :: fOld ! old function value + real(summa_prec),intent(in) :: stateVecTrial(:) ! trial state vector + real(summa_prec),intent(in) :: newtStepScaled(:) ! scaled newton step + real(summa_prec),intent(in) :: aJacScaled(:,:) ! scaled jacobian matrix + real(summa_prec),intent(in) :: rVecScaled(:) ! scaled residual vector + real(summa_prec),intent(in) :: fOld ! old function value ! output - real(dp),intent(out) :: stateVecNew(:) ! new state vector - real(dp),intent(out) :: fluxVecNew(:) ! new flux vector - real(qp),intent(out) :: resVecNew(:) ! NOTE: qp ! new residual vector - real(dp),intent(out) :: fNew ! new function evaluation + real(summa_prec),intent(out) :: stateVecNew(:) ! new state vector + real(summa_prec),intent(out) :: fluxVecNew(:) ! new flux vector + real(summa_prec),intent(out) :: resVecNew(:) ! NOTE: qp ! new residual vector + real(summa_prec),intent(out) :: fNew ! new function evaluation logical(lgt),intent(out) :: converged ! convergence flag integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message @@ -576,31 +576,31 @@ subroutine safeRootfinder(stateVecTrial,rVecscaled,newtStepScaled,stateVecNew,fl USE globalData,only:dNaN ! double precision NaN implicit none ! input - real(dp),intent(in) :: stateVecTrial(:) ! trial state vector - real(dp),intent(in) :: rVecScaled(:) ! scaled residual vector - real(dp),intent(in) :: newtStepScaled(:) ! scaled newton step + real(summa_prec),intent(in) :: stateVecTrial(:) ! trial state vector + real(summa_prec),intent(in) :: rVecScaled(:) ! scaled residual vector + real(summa_prec),intent(in) :: newtStepScaled(:) ! scaled newton step ! output - real(dp),intent(out) :: stateVecNew(:) ! new state vector - real(dp),intent(out) :: fluxVecNew(:) ! new flux vector - real(qp),intent(out) :: resVecNew(:) ! NOTE: qp ! new residual vector - real(dp),intent(out) :: fNew ! new function evaluation + real(summa_prec),intent(out) :: stateVecNew(:) ! new state vector + real(summa_prec),intent(out) :: fluxVecNew(:) ! new flux vector + real(summa_prec),intent(out) :: resVecNew(:) ! NOTE: qp ! new residual vector + real(summa_prec),intent(out) :: fNew ! new function evaluation logical(lgt),intent(out) :: converged ! convergence flag integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! -------------------------------------------------------------------------------------------------------- ! local variables character(len=256) :: cmessage ! error message of downwind routine - real(dp),parameter :: relTolerance=0.005_dp ! force bi-section if trial is slightly larger than (smaller than) xmin (xmax) - real(dp) :: xTolerance ! relTolerance*(xmax-xmin) - real(dp) :: xInc(nState) ! iteration increment (re-scaled to original units of the state vector) - real(dp) :: rVec(nState) ! residual vector (re-scaled to original units of the state equation) + real(summa_prec),parameter :: relTolerance=0.005_summa_prec ! force bi-section if trial is slightly larger than (smaller than) xmin (xmax) + real(summa_prec) :: xTolerance ! relTolerance*(xmax-xmin) + real(summa_prec) :: xInc(nState) ! iteration increment (re-scaled to original units of the state vector) + real(summa_prec) :: rVec(nState) ! residual vector (re-scaled to original units of the state equation) logical(lgt) :: feasible ! feasibility of the solution logical(lgt) :: doBisection ! flag to do the bi-section logical(lgt) :: bracketsDefined ! flag to define if the brackets are defined !integer(i4b) :: iCheck ! check the model state variables (not used) integer(i4b),parameter :: nCheck=100 ! number of times to check the model state variables - real(dp),parameter :: delX=1._dp ! trial increment - !real(dp) :: xIncrement(nState) ! trial increment (not used) + real(summa_prec),parameter :: delX=1._summa_prec ! trial increment + !real(summa_prec) :: xIncrement(nState) ! trial increment (not used) ! -------------------------------------------------------------------------------------------------------- err=0; message='safeRootfinder/' @@ -617,10 +617,10 @@ subroutine safeRootfinder(stateVecTrial,rVecscaled,newtStepScaled,stateVecNew,fl endif ! get the residual vector - rVec = real(rVecScaled, dp)*fScale + rVec = real(rVecScaled, summa_prec)*real(fScale, summa_prec) ! update brackets - if(rVec(1)<0._dp)then + if(rVec(1)<0._summa_prec)then xMin = stateVecTrial(1) else xMax = stateVecTrial(1) @@ -631,7 +631,7 @@ subroutine safeRootfinder(stateVecTrial,rVecscaled,newtStepScaled,stateVecNew,fl ! ***** ! * case 1: the iteration increment is the same sign as the residual vector - if(xInc(1)*rVec(1) > 0._dp)then + if(xInc(1)*rVec(1) > 0._summa_prec)then ! get brackets if they do not exist if( ieee_is_nan(xMin) .or. ieee_is_nan(xMax) )then @@ -640,7 +640,7 @@ subroutine safeRootfinder(stateVecTrial,rVecscaled,newtStepScaled,stateVecNew,fl endif ! use bi-section - stateVecNew(1) = 0.5_dp*(xMin + xMax) + stateVecNew(1) = 0.5_summa_prec*(xMin + xMax) ! ***** ! * case 2: the iteration increment is the correct sign @@ -660,7 +660,7 @@ subroutine safeRootfinder(stateVecTrial,rVecscaled,newtStepScaled,stateVecNew,fl if(bracketsDefined)then xTolerance = relTolerance*(xMax-xMin) doBisection = (stateVecNew(1)xMax-xTolerance) - if(doBisection) stateVecNew(1) = 0.5_dp*(xMin+xMax) + if(doBisection) stateVecNew(1) = 0.5_summa_prec*(xMin+xMax) endif ! evaluate summa @@ -686,17 +686,17 @@ subroutine getBrackets(stateVecTrial,stateVecNew,xMin,xMax,err,message) USE,intrinsic :: ieee_arithmetic,only:ieee_is_nan ! IEEE arithmetic (check NaN) implicit none ! dummies - real(dp),intent(in) :: stateVecTrial(:) ! trial state vector - real(dp),intent(out) :: stateVecNew(:) ! new state vector - real(dp),intent(out) :: xMin,xMax ! constraints + real(summa_prec),intent(in) :: stateVecTrial(:) ! trial state vector + real(summa_prec),intent(out) :: stateVecNew(:) ! new state vector + real(summa_prec),intent(out) :: xMin,xMax ! constraints integer(i4b),intent(inout) :: err ! error code character(*),intent(out) :: message ! error message ! locals integer(i4b) :: iCheck ! check the model state variables integer(i4b),parameter :: nCheck=100 ! number of times to check the model state variables logical(lgt) :: feasible ! feasibility of the solution - real(dp),parameter :: delX=1._dp ! trial increment - real(dp) :: xIncrement(nState) ! trial increment + real(summa_prec),parameter :: delX=1._summa_prec ! trial increment + real(summa_prec) :: xIncrement(nState) ! trial increment ! initialize err=0; message='getBrackets/' @@ -724,7 +724,7 @@ subroutine getBrackets(stateVecTrial,stateVecNew,xMin,xMax,err,message) if(.not.feasible)then; message=trim(message)//'state vector is not feasible'; err=20; return; endif ! update brackets - if(real(resVecNew(1), dp)<0._dp)then + if(real(resVecNew(1), summa_prec)<0._summa_prec)then xMin = stateVecNew(1) else xMax = stateVecNew(1) @@ -754,20 +754,20 @@ end subroutine getBrackets subroutine numJacobian(stateVec,dMat,nJac,err,message) implicit none ! dummies - real(dp),intent(in) :: stateVec(:) ! trial state vector - real(dp),intent(in) :: dMat(:) ! diagonal matrix + real(summa_prec),intent(in) :: stateVec(:) ! trial state vector + real(summa_prec),intent(in) :: dMat(:) ! diagonal matrix ! output - real(dp),intent(out) :: nJac(:,:) ! numerical Jacobian + real(summa_prec),intent(out) :: nJac(:,:) ! numerical Jacobian integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! ---------------------------------------------------------------------------------------------------------- ! local character(len=256) :: cmessage ! error message of downwind routine - real(dp),parameter :: dx=1.e-8_dp ! finite difference increment - real(dp),dimension(nState) :: stateVecPerturbed ! perturbed state vector - real(dp),dimension(nState) :: fluxVecInit,fluxVecJac ! flux vector (mized units) - real(qp),dimension(nState) :: resVecInit,resVecJac ! qp ! residual vector (mixed units) - real(dp) :: func ! function value + real(summa_prec),parameter :: dx=1.e-8_summa_prec ! finite difference increment + real(summa_prec),dimension(nState) :: stateVecPerturbed ! perturbed state vector + real(summa_prec),dimension(nState) :: fluxVecInit,fluxVecJac ! flux vector (mized units) + real(summa_prec),dimension(nState) :: resVecInit,resVecJac ! qp ! residual vector (mixed units) + real(summa_prec) :: func ! function value logical(lgt) :: feasible ! flag to denote the feasibility of the solution integer(i4b) :: iJac ! index of row of the Jacobian matrix integer(i4b),parameter :: ixNumFlux=1001 ! named variable for the flux-based form of the numerical Jacobian @@ -802,7 +802,7 @@ subroutine numJacobian(stateVec,dMat,nJac,err,message) ! compute the row of the Jacobian matrix select case(ixNumType) - case(ixNumRes); nJac(:,iJac) = real(resVecJac - resVecInit, kind(dp) )/dx ! Jacobian based on residuals + case(ixNumRes); nJac(:,iJac) = real(resVecJac - resVecInit, kind(summa_prec) )/dx ! Jacobian based on residuals case(ixNumFlux); nJac(:,iJac) = -dt*(fluxVecJac(:) - fluxVecInit(:))/dx ! Jacobian based on fluxes case default; err=20; message=trim(message)//'Jacobian option not found'; return end select @@ -835,8 +835,8 @@ subroutine testBandMat(check,err,message) integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! local variables - real(dp) :: fullJac(nState,nState) ! full Jacobian matrix - real(dp) :: bandJac(nLeadDim,nState) ! band Jacobian matrix + real(summa_prec) :: fullJac(nState,nState) ! full Jacobian matrix + real(summa_prec) :: bandJac(nLeadDim,nState) ! band Jacobian matrix integer(i4b) :: iState,jState ! indices of the state vector character(LEN=256) :: cmessage ! error message of downwind routine ! initialize error control @@ -873,7 +873,7 @@ subroutine testBandMat(check,err,message) if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! (check for errors) ! initialize band matrix - bandJac(:,:) = 0._dp + bandJac(:,:) = 0._summa_prec ! transfer into the lapack band diagonal structure do iState=1,nState @@ -906,11 +906,11 @@ subroutine eval8summa_wrapper(stateVecNew,fluxVecNew,resVecNew,fNew,feasible,err USE eval8summa_module,only:eval8summa ! simulation of fluxes and residuals given a trial state vector implicit none ! input - real(dp),intent(in) :: stateVecNew(:) ! updated state vector + real(summa_prec),intent(in) :: stateVecNew(:) ! updated state vector ! output - real(dp),intent(out) :: fluxVecNew(:) ! updated flux vector - real(qp),intent(out) :: resVecNew(:) ! NOTE: qp ! updated residual vector - real(dp),intent(out) :: fNew ! new function value + real(summa_prec),intent(out) :: fluxVecNew(:) ! updated flux vector + real(summa_prec),intent(out) :: resVecNew(:) ! NOTE: qp ! updated residual vector + real(summa_prec),intent(out) :: fNew ! new function value logical(lgt),intent(out) :: feasible ! flag to denote the feasibility of the solution integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message @@ -972,20 +972,20 @@ end subroutine eval8summa_wrapper function checkConv(rVec,xInc,xVec) implicit none ! dummies - real(qp),intent(in) :: rVec(:) ! residual vector (mixed units) - real(dp),intent(in) :: xInc(:) ! iteration increment (mixed units) - real(dp),intent(in) :: xVec(:) ! state vector (mixed units) + real(summa_prec),intent(in) :: rVec(:) ! residual vector (mixed units) + real(summa_prec),intent(in) :: xInc(:) ! iteration increment (mixed units) + real(summa_prec),intent(in) :: xVec(:) ! state vector (mixed units) logical(lgt) :: checkConv ! flag to denote convergence ! locals - real(dp),dimension(mSoil) :: psiScale ! scaling factor for matric head - real(dp),parameter :: xSmall=1.e-0_dp ! a small offset - real(dp),parameter :: scalarTighten=0.1_dp ! scaling factor for the scalar solution - real(dp) :: soilWatbalErr ! error in the soil water balance - real(dp) :: canopy_max ! absolute value of the residual in canopy water (kg m-2) - real(dp),dimension(1) :: energy_max ! maximum absolute value of the energy residual (J m-3) - real(dp),dimension(1) :: liquid_max ! maximum absolute value of the volumetric liquid water content residual (-) - real(dp),dimension(1) :: matric_max ! maximum absolute value of the matric head iteration increment (m) - real(dp) :: aquifer_max ! absolute value of the residual in aquifer water (m) + real(summa_prec),dimension(mSoil) :: psiScale ! scaling factor for matric head + real(summa_prec),parameter :: xSmall=1.e-0_summa_prec ! a small offset + real(summa_prec),parameter :: scalarTighten=0.1_summa_prec ! scaling factor for the scalar solution + real(summa_prec) :: soilWatbalErr ! error in the soil water balance + real(summa_prec) :: canopy_max ! absolute value of the residual in canopy water (kg m-2) + real(summa_prec),dimension(1) :: energy_max ! maximum absolute value of the energy residual (J m-3) + real(summa_prec),dimension(1) :: liquid_max ! maximum absolute value of the volumetric liquid water content residual (-) + real(summa_prec),dimension(1) :: matric_max ! maximum absolute value of the matric head iteration increment (m) + real(summa_prec) :: aquifer_max ! absolute value of the residual in aquifer water (m) logical(lgt) :: canopyConv ! flag for canopy water balance convergence logical(lgt) :: watbalConv ! flag for soil water balance convergence logical(lgt) :: liquidConv ! flag for residual convergence @@ -1016,7 +1016,7 @@ function checkConv(rVec,xInc,xVec) ! check convergence based on the canopy water balance if(ixVegHyd/=integerMissing)then - canopy_max = real(abs(rVec(ixVegHyd)), dp)*iden_water + canopy_max = real(abs(rVec(ixVegHyd)), summa_prec)*iden_water canopyConv = (canopy_max < absConvTol_liquid) ! absolute error in canopy water balance (mm) else canopy_max = realMissing @@ -1025,7 +1025,7 @@ function checkConv(rVec,xInc,xVec) ! check convergence based on the residuals for energy (J m-3) if(size(ixNrgOnly)>0)then - energy_max = real(maxval(abs( rVec(ixNrgOnly) )), dp) + energy_max = real(maxval(abs( rVec(ixNrgOnly) )), summa_prec) energyConv = (energy_max(1) < absConvTol_energy) ! (based on the residual) else energy_max = realMissing @@ -1034,7 +1034,7 @@ function checkConv(rVec,xInc,xVec) ! check convergence based on the residuals for volumetric liquid water content (-) if(size(ixHydOnly)>0)then - liquid_max = real(maxval(abs( rVec(ixHydOnly) ) ), dp) + liquid_max = real(maxval(abs( rVec(ixHydOnly) ) ), summa_prec) ! (tighter convergence for the scalar solution) if(scalarSolution)then liquidConv = (liquid_max(1) < absConvTol_liquid*scalarTighten) ! (based on the residual) @@ -1059,7 +1059,7 @@ function checkConv(rVec,xInc,xVec) ! check convergence based on the soil water balance error (m) if(size(ixMatOnly)>0)then - soilWatBalErr = sum( real(rVec(ixMatOnly), dp)*mLayerDepth(nSnow+ixMatricHead) ) + soilWatBalErr = sum( real(rVec(ixMatOnly), summa_prec)*mLayerDepth(nSnow+ixMatricHead) ) watbalConv = (abs(soilWatbalErr) < absConvTol_liquid) ! absolute error in total soil water balance (m) else soilWatbalErr = realMissing @@ -1068,7 +1068,7 @@ function checkConv(rVec,xInc,xVec) ! check convergence based on the aquifer storage if(ixAqWat/=integerMissing)then - aquifer_max = real(abs(rVec(ixAqWat)), dp)*iden_water + aquifer_max = real(abs(rVec(ixAqWat)), summa_prec)*iden_water aquiferConv = (aquifer_max < absConvTol_liquid) ! absolute error in aquifer water balance (mm) else aquifer_max = realMissing @@ -1099,25 +1099,25 @@ subroutine imposeConstraints(stateVecTrial,xInc,err,message) USE soil_utils_module,only:crit_soilT ! compute the critical temperature below which ice exists implicit none ! dummies - real(dp),intent(in) :: stateVecTrial(:) ! trial state vector - real(dp),intent(inout) :: xInc(:) ! iteration increment + real(summa_prec),intent(in) :: stateVecTrial(:) ! trial state vector + real(summa_prec),intent(inout) :: xInc(:) ! iteration increment integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! ----------------------------------------------------------------------------------------------------- ! temporary variables for model constraints - real(dp) :: cInc ! constrained temperature increment (K) -- simplified bi-section - real(dp) :: xIncFactor ! scaling factor for the iteration increment (-) + real(summa_prec) :: cInc ! constrained temperature increment (K) -- simplified bi-section + real(summa_prec) :: xIncFactor ! scaling factor for the iteration increment (-) integer(i4b) :: iMax(1) ! index of maximum temperature - real(dp) :: scalarTemp ! temperature of an individual snow layer (K) - real(dp) :: volFracLiq ! volumetric liquid water content of an individual snow layer (-) + real(summa_prec) :: scalarTemp ! temperature of an individual snow layer (K) + real(summa_prec) :: volFracLiq ! volumetric liquid water content of an individual snow layer (-) logical(lgt),dimension(nSnow) :: drainFlag ! flag to denote when drainage exceeds available capacity logical(lgt),dimension(nSoil) :: crosFlag ! flag to denote temperature crossing from unfrozen to frozen (or vice-versa) logical(lgt) :: crosTempVeg ! flag to denoote where temperature crosses the freezing point - real(dp) :: xPsi00 ! matric head after applying the iteration increment (m) - real(dp) :: TcSoil ! critical point when soil begins to freeze (K) - real(dp) :: critDiff ! temperature difference from critical (K) - real(dp),parameter :: epsT=1.e-7_dp ! small interval above/below critical (K) - real(dp),parameter :: zMaxTempIncrement=1._dp ! maximum temperature increment (K) + real(summa_prec) :: xPsi00 ! matric head after applying the iteration increment (m) + real(summa_prec) :: TcSoil ! critical point when soil begins to freeze (K) + real(summa_prec) :: critDiff ! temperature difference from critical (K) + real(summa_prec),parameter :: epsT=1.e-7_summa_prec ! small interval above/below critical (K) + real(summa_prec),parameter :: zMaxTempIncrement=1._summa_prec ! maximum temperature increment (K) ! indices of model state variables integer(i4b) :: iState ! index of state within a specific variable type integer(i4b) :: ixNrg,ixLiq ! index of energy and mass state variables in full state vector @@ -1180,7 +1180,7 @@ subroutine imposeConstraints(stateVecTrial,xInc,err,message) crosTempVeg = .false. ! initially frozen (T < Tfreeze) - if(critDiff > 0._dp)then + if(critDiff > 0._summa_prec)then if(xInc(ixVegNrg) > critDiff)then crosTempVeg = .true. cInc = critDiff + epsT ! constrained temperature increment (K) @@ -1209,9 +1209,9 @@ subroutine imposeConstraints(stateVecTrial,xInc,err,message) if(ixVegHyd/=integerMissing)then ! check if new value of storage will be negative - if(stateVecTrial(ixVegHyd)+xInc(ixVegHyd) < 0._dp)then + if(stateVecTrial(ixVegHyd)+xInc(ixVegHyd) < 0._summa_prec)then ! scale iteration increment - cInc = -0.5_dp*stateVecTrial(ixVegHyd) ! constrained iteration increment (K) -- simplified bi-section + cInc = -0.5_summa_prec*stateVecTrial(ixVegHyd) ! constrained iteration increment (K) -- simplified bi-section xIncFactor = cInc/xInc(ixVegHyd) ! scaling factor for the iteration increment (-) xInc = xIncFactor*xInc ! new iteration increment end if @@ -1232,7 +1232,7 @@ subroutine imposeConstraints(stateVecTrial,xInc,err,message) iState = ixSnowOnlyNrg(iLayer) if(stateVecTrial(iState) + xInc(iState) > Tfreeze)then ! scale iteration increment - cInc = 0.5_dp*(Tfreeze - stateVecTrial(iState) ) ! constrained temperature increment (K) -- simplified bi-section + cInc = 0.5_summa_prec*(Tfreeze - stateVecTrial(iState) ) ! constrained temperature increment (K) -- simplified bi-section xIncFactor = cInc/xInc(iState) ! scaling factor for the iteration increment (-) xInc = xIncFactor*xInc end if ! if snow temperature > freezing @@ -1271,7 +1271,7 @@ subroutine imposeConstraints(stateVecTrial,xInc,err,message) ! * check that the iteration increment does not exceed volumetric liquid water content if(-xInc(ixSnowOnlyHyd(iLayer)) > volFracLiq)then drainFlag(iLayer) = .true. - xInc(ixSnowOnlyHyd(iLayer)) = -0.5_dp*volFracLiq + xInc(ixSnowOnlyHyd(iLayer)) = -0.5_summa_prec*volFracLiq endif end do ! looping through snow layers @@ -1304,7 +1304,7 @@ subroutine imposeConstraints(stateVecTrial,xInc,err,message) critDiff = TcSoil - stateVecTrial(ixNrg) ! * initially frozen (T < TcSoil) - if(critDiff > 0._dp)then + if(critDiff > 0._summa_prec)then ! (check crossing above zero) if(xInc(ixNrg) > critDiff)then @@ -1334,8 +1334,8 @@ subroutine imposeConstraints(stateVecTrial,xInc,err,message) ixLiq = ixMatOnly(iState) ! - place constraint for matric head - if(xInc(ixLiq) > 1._dp .and. stateVecTrial(ixLiq) > 0._dp)then - xInc(ixLiq) = 1._dp + if(xInc(ixLiq) > 1._summa_prec .and. stateVecTrial(ixLiq) > 0._summa_prec)then + xInc(ixLiq) = 1._summa_prec endif ! if constraining matric head end do ! (loop through soil layers) diff --git a/build/source/engine/sunGeomtry.f90 b/build/source/engine/sunGeomtry.f90 index 28703ad40..8d747efc6 100755 --- a/build/source/engine/sunGeomtry.f90 +++ b/build/source/engine/sunGeomtry.f90 @@ -48,32 +48,32 @@ SUBROUTINE CLRSKY_RAD(MONTH,DAY,HOUR,DT,SLOPE,AZI,LAT,HRI,COSZEN) ! Input variables INTEGER(I4B), INTENT(IN) :: MONTH ! month as mm integer INTEGER(I4B), INTENT(IN) :: DAY ! day of month as dd integer - REAL(DP), INTENT(IN) :: HOUR ! hour of day as real - REAL(DP), INTENT(IN) :: DT ! time step in units of hours - REAL(DP), INTENT(IN) :: SLOPE ! slope of ground surface in degrees - REAL(DP), INTENT(IN) :: AZI ! aspect (azimuth) of ground surface in degrees - REAL(DP), INTENT(IN) :: LAT ! latitude in degrees (negative for southern hemisphere) + real(summa_prec), INTENT(IN) :: HOUR ! hour of day as real + real(summa_prec), INTENT(IN) :: DT ! time step in units of hours + real(summa_prec), INTENT(IN) :: SLOPE ! slope of ground surface in degrees + real(summa_prec), INTENT(IN) :: AZI ! aspect (azimuth) of ground surface in degrees + real(summa_prec), INTENT(IN) :: LAT ! latitude in degrees (negative for southern hemisphere) ! Outputs - REAL(DP), INTENT(OUT) :: HRI ! average radiation index over time step DT - REAL(DP), INTENT(OUT) :: COSZEN ! average cosine of the zenith angle over time step DT + real(summa_prec), INTENT(OUT) :: HRI ! average radiation index over time step DT + real(summa_prec), INTENT(OUT) :: COSZEN ! average cosine of the zenith angle over time step DT ! Internal - REAL(DP) :: CRAD ! conversion from degrees to radians - REAL(DP) :: YRAD ! conversion from year to radians - REAL(DP) :: T ! time from noon in radians - REAL(DP) :: DELT1 ! time step in radians - REAL(DP) :: SLOPE1 ! slope of ground surface in radians - REAL(DP) :: AZI1 ! aspect (azimuth) of ground surface in radians - REAL(DP) :: LAT1 ! latitude in radians - REAL(DP) :: FJULIAN ! julian date as real - REAL(DP) :: D ! solar declination - REAL(DP) :: LP ! latitude adjusted for non-level surface (= LAT1 for level surface) - REAL(DP) :: TD ! used to calculate sunrise/set - REAL(DP) :: TPI ! used to calculate sunrise/set - REAL(DP) :: TP ! used to calculate sunrise/set - REAL(DP) :: DDT ! used to calculate sunrise/set(= 0 for level surface) - REAL(DP) :: T1 ! first time in time step or sunrise - REAL(DP) :: T2 ! last time in time step or sunset - REAL(DP) :: AUX ! Auxiliary variable used to check whether the sunset/sunrise time calculation can succeed + real(summa_prec) :: CRAD ! conversion from degrees to radians + real(summa_prec) :: YRAD ! conversion from year to radians + real(summa_prec) :: T ! time from noon in radians + real(summa_prec) :: DELT1 ! time step in radians + real(summa_prec) :: SLOPE1 ! slope of ground surface in radians + real(summa_prec) :: AZI1 ! aspect (azimuth) of ground surface in radians + real(summa_prec) :: LAT1 ! latitude in radians + real(summa_prec) :: FJULIAN ! julian date as real + real(summa_prec) :: D ! solar declination + real(summa_prec) :: LP ! latitude adjusted for non-level surface (= LAT1 for level surface) + real(summa_prec) :: TD ! used to calculate sunrise/set + real(summa_prec) :: TPI ! used to calculate sunrise/set + real(summa_prec) :: TP ! used to calculate sunrise/set + real(summa_prec) :: DDT ! used to calculate sunrise/set(= 0 for level surface) + real(summa_prec) :: T1 ! first time in time step or sunrise + real(summa_prec) :: T2 ! last time in time step or sunset + real(summa_prec) :: AUX ! Auxiliary variable used to check whether the sunset/sunrise time calculation can succeed ! ---------------------------------------------------------------------------------------- ! CONVERSION FACTORS ! degrees to radians @@ -99,7 +99,7 @@ SUBROUTINE CLRSKY_RAD(MONTH,DAY,HOUR,DT,SLOPE,AZI,LAT,HRI,COSZEN) ! In such cases AUX > 1 or AUX < -1. Fix AUX at (-)1 in those cases, to fix sunrise at 00.00 or 24.00 of the current day (instead of some time before/after the current day) AUX=-TAN(LAT1)*TAN(D) IF(abs(AUX) > 1.) THEN - TD=ACOS(SIGN(1._dp, AUX)) + TD=ACOS(SIGN(1._summa_prec, AUX)) ELSE TD=ACOS(AUX) END IF @@ -140,7 +140,7 @@ SUBROUTINE CLRSKY_RAD(MONTH,DAY,HOUR,DT,SLOPE,AZI,LAT,HRI,COSZEN) ! In such cases AUX > 1 or AUX < -1. Fix AUX at (-)1 in those cases AUX=-TAN(LAT1)*TAN(D) IF(abs(AUX) > 1.) THEN - TD=ACOS(SIGN(1._dp, AUX)) + TD=ACOS(SIGN(1._summa_prec, AUX)) ELSE TD=ACOS(AUX) END IF diff --git a/build/source/engine/systemSolv.f90 b/build/source/engine/systemSolv.f90 index aed91981e..4ab21e3a4 100755 --- a/build/source/engine/systemSolv.f90 +++ b/build/source/engine/systemSolv.f90 @@ -98,10 +98,10 @@ module systemSolv_module public::systemSolv ! control parameters -real(dp),parameter :: valueMissing=-9999._dp ! missing value -real(dp),parameter :: verySmall=1.e-12_dp ! a very small number (used to check consistency) -real(dp),parameter :: veryBig=1.e+20_dp ! a very big number -real(dp),parameter :: dx = 1.e-8_dp ! finite difference increment +real(summa_prec),parameter :: valueMissing=-9999._summa_prec ! missing value +real(summa_prec),parameter :: verySmall=1.e-12_summa_prec ! a very small number (used to check consistency) +real(summa_prec),parameter :: veryBig=1.e+20_summa_prec ! a very big number +real(summa_prec),parameter :: dx = 1.e-8_summa_prec ! finite difference increment contains @@ -152,7 +152,7 @@ subroutine systemSolv(& ! * dummy variables ! --------------------------------------------------------------------------------------- ! input: model control - real(dp),intent(in) :: dt ! time step (seconds) + real(summa_prec),intent(in) :: dt ! time step (seconds) integer(i4b),intent(in) :: nState ! total number of state variables logical(lgt),intent(in) :: firstSubStep ! flag to indicate if we are processing the first sub-step logical(lgt),intent(inout) :: firstFluxCall ! flag to define the first flux call @@ -170,12 +170,12 @@ subroutine systemSolv(& type(var_dlength),intent(inout) :: flux_temp ! model fluxes for a local HRU type(var_dlength),intent(in) :: bvar_data ! model variables for the local basin type(model_options),intent(in) :: model_decisions(:) ! model decisions - real(dp),intent(in) :: stateVecInit(:) ! initial state vector (mixed units) + real(summa_prec),intent(in) :: stateVecInit(:) ! initial state vector (mixed units) ! output: model control type(var_dlength),intent(inout) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables integer(i4b),intent(inout) :: ixSaturation ! index of the lowest saturated layer (NOTE: only computed on the first iteration) - real(dp),intent(out) :: untappedMelt(:) ! un-tapped melt energy (J m-3 s-1) - real(dp),intent(out) :: stateVecTrial(:) ! trial state vector (mixed units) + real(summa_prec),intent(out) :: untappedMelt(:) ! un-tapped melt energy (J m-3 s-1) + real(summa_prec),intent(out) :: stateVecTrial(:) ! trial state vector (mixed units) logical(lgt),intent(out) :: reduceCoupledStep ! flag to reduce the length of the coupled step logical(lgt),intent(out) :: tooMuchMelt ! flag to denote that there was too much melt integer(i4b),intent(out) :: niter ! number of iterations taken @@ -193,11 +193,11 @@ subroutine systemSolv(& integer(i4b) :: iState ! index of model state integer(i4b) :: nLeadDim ! length of the leading dimension of the Jacobian matrix (nBands or nState) integer(i4b) :: local_ixGroundwater ! local index for groundwater representation - real(dp) :: bulkDensity ! bulk density of a given layer (kg m-3) - real(dp) :: volEnthalpy ! volumetric enthalpy of a given layer (J m-3) - real(dp),parameter :: tempAccelerate=0.00_dp ! factor to force initial canopy temperatures to be close to air temperature - real(dp),parameter :: xMinCanopyWater=0.0001_dp ! minimum value to initialize canopy water (kg m-2) - real(dp),parameter :: tinyStep=0.000001_dp ! stupidly small time step (s) + real(summa_prec) :: bulkDensity ! bulk density of a given layer (kg m-3) + real(summa_prec) :: volEnthalpy ! volumetric enthalpy of a given layer (J m-3) + real(summa_prec),parameter :: tempAccelerate=0.00_summa_prec ! factor to force initial canopy temperatures to be close to air temperature + real(summa_prec),parameter :: xMinCanopyWater=0.0001_summa_prec ! minimum value to initialize canopy water (kg m-2) + real(summa_prec),parameter :: tinyStep=0.000001_summa_prec ! stupidly small time step (s) ! ------------------------------------------------------------------------------------------------------ ! * model solver ! ------------------------------------------------------------------------------------------------------ @@ -207,22 +207,22 @@ subroutine systemSolv(& integer(i4b) :: localMaxIter ! maximum number of iterations (depends on solution type) integer(i4b), parameter :: scalarMaxIter=100 ! maximum number of iterations for the scalar solution type(var_dlength) :: flux_init ! model fluxes at the start of the time step - real(dp),allocatable :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) ! NOTE: allocatable, since not always needed - real(dp) :: stateVecNew(nState) ! new state vector (mixed units) - real(dp) :: fluxVec0(nState) ! flux vector (mixed units) - real(dp) :: fScale(nState) ! characteristic scale of the function evaluations (mixed units) - real(dp) :: xScale(nState) ! characteristic scale of the state vector (mixed units) - real(dp) :: dMat(nState) ! diagonal matrix (excludes flux derivatives) - real(qp) :: sMul(nState) ! NOTE: qp ! multiplier for state vector for the residual calculations - real(qp) :: rVec(nState) ! NOTE: qp ! residual vector - real(dp) :: rAdd(nState) ! additional terms in the residual vector - real(dp) :: fOld,fNew ! function values (-); NOTE: dimensionless because scaled - real(dp) :: xMin,xMax ! state minimum and maximum (mixed units) + real(summa_prec),allocatable :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) ! NOTE: allocatable, since not always needed + real(summa_prec) :: stateVecNew(nState) ! new state vector (mixed units) + real(summa_prec) :: fluxVec0(nState) ! flux vector (mixed units) + real(summa_prec) :: fScale(nState) ! characteristic scale of the function evaluations (mixed units) + real(summa_prec) :: xScale(nState) ! characteristic scale of the state vector (mixed units) + real(summa_prec) :: dMat(nState) ! diagonal matrix (excludes flux derivatives) + real(summa_prec) :: sMul(nState) ! NOTE: qp ! multiplier for state vector for the residual calculations + real(summa_prec) :: rVec(nState) ! NOTE: qp ! residual vector + real(summa_prec) :: rAdd(nState) ! additional terms in the residual vector + real(summa_prec) :: fOld,fNew ! function values (-); NOTE: dimensionless because scaled + real(summa_prec) :: xMin,xMax ! state minimum and maximum (mixed units) logical(lgt) :: converged ! convergence flag logical(lgt) :: feasible ! feasibility flag - real(dp) :: resSinkNew(nState) ! additional terms in the residual vector - real(dp) :: fluxVecNew(nState) ! new flux vector - real(qp) :: resVecNew(nState) ! NOTE: qp ! new residual vector + real(summa_prec) :: resSinkNew(nState) ! additional terms in the residual vector + real(summa_prec) :: fluxVecNew(nState) ! new flux vector + real(summa_prec) :: resVecNew(nState) ! NOTE: qp ! new residual vector ! --------------------------------------------------------------------------------------- ! point to variables in the data structures ! --------------------------------------------------------------------------------------- @@ -533,13 +533,13 @@ subroutine systemSolv(& ! ------------------ ! set untapped melt energy to zero - untappedMelt(:) = 0._dp + untappedMelt(:) = 0._summa_prec ! update temperatures (ensure new temperature is consistent with the fluxes) if(nSnowSoilNrg>0)then do concurrent (iLayer=1:nLayers,ixSnowSoilNrg(iLayer)/=integerMissing) ! (loop through non-missing energy state variables in the snow+soil domain) iState = ixSnowSoilNrg(iLayer) - stateVecTrial(iState) = stateVecInit(iState) + (fluxVecNew(iState)*dt + resSinkNew(iState))/real(sMul(iState), dp) + stateVecTrial(iState) = stateVecInit(iState) + (fluxVecNew(iState)*dt + resSinkNew(iState))/real(sMul(iState), summa_prec) end do ! looping through non-missing energy state variables in the snow+soil domain endif diff --git a/build/source/engine/tempAdjust.f90 b/build/source/engine/tempAdjust.f90 index d9dc6dd6c..758f50431 100755 --- a/build/source/engine/tempAdjust.f90 +++ b/build/source/engine/tempAdjust.f90 @@ -65,7 +65,7 @@ subroutine tempAdjust(& implicit none ! ------------------------------------------------------------------------------------------------ ! input: derived parameters - real(dp),intent(in) :: canopyDepth ! depth of the vegetation canopy (m) + real(summa_prec),intent(in) :: canopyDepth ! depth of the vegetation canopy (m) ! input/output: data structures type(var_dlength),intent(in) :: mpar_data ! model parameters type(var_dlength),intent(inout) :: prog_data ! model prognostic variables for a local HRU @@ -78,13 +78,13 @@ subroutine tempAdjust(& integer(i4b) :: iTry ! trial index integer(i4b) :: iter ! iteration index integer(i4b),parameter :: maxiter=100 ! maximum number of iterations - real(dp) :: fLiq ! fraction of liquid water (-) - real(dp) :: tempMin,tempMax ! solution constraints for temperature (K) - real(dp) :: nrgMeltFreeze ! energy required to melt-freeze the water to the current canopy temperature (J m-3) - real(dp) :: scalarCanopyWat ! total canopy water (kg m-2) - real(dp) :: scalarCanopyIceOld ! canopy ice content after melt-freeze to the initial temperature (kg m-2) - real(dp),parameter :: resNrgToler=0.1_dp ! tolerance for the energy residual (J m-3) - real(dp) :: f1,f2,x1,x2,fTry,xTry,fDer,xInc ! iteration variables + real(summa_prec) :: fLiq ! fraction of liquid water (-) + real(summa_prec) :: tempMin,tempMax ! solution constraints for temperature (K) + real(summa_prec) :: nrgMeltFreeze ! energy required to melt-freeze the water to the current canopy temperature (J m-3) + real(summa_prec) :: scalarCanopyWat ! total canopy water (kg m-2) + real(summa_prec) :: scalarCanopyIceOld ! canopy ice content after melt-freeze to the initial temperature (kg m-2) + real(summa_prec),parameter :: resNrgToler=0.1_summa_prec ! tolerance for the energy residual (J m-3) + real(summa_prec) :: f1,f2,x1,x2,fTry,xTry,fDer,xInc ! iteration variables logical(lgt) :: fBis ! .true. if bisection ! ------------------------------------------------------------------------------------------------------------------------------- ! initialize error control @@ -120,7 +120,7 @@ subroutine tempAdjust(& ! compute the new volumetric ice content ! NOTE: new value; iterations will adjust this value for consistency with temperature - scalarCanopyIceOld = (1._dp - fLiq)*scalarCanopyWat + scalarCanopyIceOld = (1._summa_prec - fLiq)*scalarCanopyWat ! compute volumetric heat capacity of vegetation (J m-3 K-1) scalarBulkVolHeatCapVeg = specificHeatVeg*maxMassVegetation/canopyDepth + & ! vegetation component @@ -146,14 +146,14 @@ subroutine tempAdjust(& !print*, 'f1, f2 = ', f1, f2 ! ensure that we bracket the root - if(f1*f2 > 0._dp)then + if(f1*f2 > 0._summa_prec)then xInc = f1 / fDer - x2 = 1._dp + x2 = 1._summa_prec do iter=1,maxiter ! successively expand limit in order to bracket the root - x2 = x1 + sign(x2,xInc)*2._dp + x2 = x1 + sign(x2,xInc)*2._summa_prec f2 = resNrgFunc(x2,scalarCanopyTemp,scalarBulkVolHeatCapVeg,snowfrz_scale) - if(f1*f2 < 0._dp)exit + if(f1*f2 < 0._summa_prec)exit ! check that we bracketed the root ! (should get here in just a couple of expansions) if(iter==maxiter)then @@ -176,8 +176,8 @@ subroutine tempAdjust(& !print*, 'tempMin, tempMax = ', tempMin, tempMax ! get starting trial - xInc = huge(1._dp) - xTry = 0.5_dp*(x1 + x2) + xInc = huge(1._summa_prec) + xTry = 0.5_summa_prec*(x1 + x2) fTry = resNrgFunc(xTry,scalarCanopyTemp,scalarBulkVolHeatCapVeg,snowfrz_scale) fDer = resNrgDer(xTry,scalarBulkVolHeatCapVeg,snowfrz_scale) !print*, 'xTry = ', xTry @@ -194,7 +194,7 @@ subroutine tempAdjust(& ! bisect if out of range if(xTry <= tempMin .or. xTry >= tempMax)then - xTry = 0.5_dp*(tempMin + tempMax) ! new value + xTry = 0.5_summa_prec*(tempMin + tempMax) ! new value fBis = .true. ! value in range; use the newton step @@ -211,7 +211,7 @@ subroutine tempAdjust(& !print*, 'tempMin, tempMax = ', tempMin, tempMax ! update limits - if(fTry < 0._dp)then + if(fTry < 0._summa_prec)then tempMax = min(xTry,tempMax) else tempMin = max(tempMin,xTry) @@ -232,7 +232,7 @@ subroutine tempAdjust(& if(iter==maxiter)then ! (print out a 1-d x-section) do iTry=1,maxiter - xTry = 1.0_dp*real(iTry,kind(1._dp))/real(maxiter,kind(1._dp)) + 272.5_dp + xTry = 1.0_summa_prec*real(iTry,kind(1._summa_prec))/real(maxiter,kind(1._summa_prec)) + 272.5_summa_prec fTry = resNrgFunc(xTry,scalarCanopyTemp,scalarBulkVolHeatCapVeg,snowfrz_scale) write(*,'(a,1x,i4,1x,e20.10,1x,4(f20.10,1x))') 'iTry, fTry, xTry = ', iTry, fTry, xTry end do @@ -246,7 +246,7 @@ subroutine tempAdjust(& ! update state variables scalarCanopyTemp = xTry - scalarCanopyIce = (1._dp - fracliquid(xTry,snowfrz_scale))*scalarCanopyWat + scalarCanopyIce = (1._summa_prec - fracliquid(xTry,snowfrz_scale))*scalarCanopyWat scalarCanopyLiq = scalarCanopyWat - scalarCanopyIce ! end association to variables in the data structure @@ -261,13 +261,13 @@ subroutine tempAdjust(& function resNrgFunc(xTemp,xTemp0,bulkVolHeatCapVeg,snowfrz_scale) ! implicit none - real(dp),intent(in) :: xTemp ! temperature (K) - real(dp),intent(in) :: xTemp0 ! initial temperature (K) - real(dp),intent(in) :: bulkVolHeatCapVeg ! volumetric heat capacity of veg (J m-3 K-1) - real(dp),intent(in) :: snowfrz_scale ! scaling factor in freezing curve (K-1) - real(dp) :: xIce ! canopy ice content (kg m-2) - real(dp) :: resNrgFunc ! residual in energy (J m-3) - xIce = (1._dp - fracliquid(xTemp,snowfrz_scale))*scalarCanopyWat + real(summa_prec),intent(in) :: xTemp ! temperature (K) + real(summa_prec),intent(in) :: xTemp0 ! initial temperature (K) + real(summa_prec),intent(in) :: bulkVolHeatCapVeg ! volumetric heat capacity of veg (J m-3 K-1) + real(summa_prec),intent(in) :: snowfrz_scale ! scaling factor in freezing curve (K-1) + real(summa_prec) :: xIce ! canopy ice content (kg m-2) + real(summa_prec) :: resNrgFunc ! residual in energy (J m-3) + xIce = (1._summa_prec - fracliquid(xTemp,snowfrz_scale))*scalarCanopyWat resNrgFunc = -bulkVolHeatCapVeg*(xTemp - xTemp0) + LH_fus*(xIce - scalarCanopyIceOld)/canopyDepth + nrgMeltFreeze return end function resNrgFunc @@ -278,11 +278,11 @@ end function resNrgFunc ! ************************************************************************************************ function resNrgDer(xTemp,bulkVolHeatCapVeg,snowfrz_scale) implicit none - real(dp),intent(in) :: xTemp ! temperature (K) - real(dp),intent(in) :: bulkVolHeatCapVeg ! volumetric heat capacity of veg (J m-3 K-1) - real(dp),intent(in) :: snowfrz_scale ! scaling factor in freezing curve (K-1) - real(dp) :: dW_dT ! derivative in canopy ice content w.r.t. temperature (kg m-2 K-1) - real(dp) :: resNrgDer ! derivative (J m-3 K-1) + real(summa_prec),intent(in) :: xTemp ! temperature (K) + real(summa_prec),intent(in) :: bulkVolHeatCapVeg ! volumetric heat capacity of veg (J m-3 K-1) + real(summa_prec),intent(in) :: snowfrz_scale ! scaling factor in freezing curve (K-1) + real(summa_prec) :: dW_dT ! derivative in canopy ice content w.r.t. temperature (kg m-2 K-1) + real(summa_prec) :: resNrgDer ! derivative (J m-3 K-1) dW_dT = -scalarCanopyWat*dFracLiq_dTk(xTemp,snowfrz_scale) resNrgDer = bulkVolHeatCapVeg - dW_dT*LH_fus/canopyDepth return diff --git a/build/source/engine/time_utils.f90 b/build/source/engine/time_utils.f90 index f3a7e2656..490a1621c 100755 --- a/build/source/engine/time_utils.f90 +++ b/build/source/engine/time_utils.f90 @@ -46,9 +46,9 @@ subroutine extractTime(refdate,iyyy,im,id,ih,imin,dsec,ih_tz,imin_tz,dsec_tz,err ! dummy variables character(*),intent(in) :: refdate ! units string (time since...) integer(i4b),intent(out) :: iyyy,im,id,ih,imin ! time (year/month/day/hour/minute) - real(dp),intent(out) :: dsec ! seconds + real(summa_prec),intent(out) :: dsec ! seconds integer(i4b),intent(out) :: ih_tz,imin_tz ! time zone information (hour/minute) - real(dp),intent(out) :: dsec_tz ! time zone information (seconds) + real(summa_prec),intent(out) :: dsec_tz ! time zone information (seconds) integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! local variables @@ -61,7 +61,7 @@ subroutine extractTime(refdate,iyyy,im,id,ih,imin,dsec,ih_tz,imin_tz,dsec_tz,err ! we'll parse each of these in order. ! Missing ih, imin, dsec, ih_tz, imin_tz and dsec_tz fields will be set to zero without causing an error. - ih=0; imin=0; dsec=0._dp; ih_tz=0; imin_tz=0; dsec_tz=0._dp; + ih=0; imin=0; dsec=0._summa_prec; ih_tz=0; imin_tz=0; dsec_tz=0._summa_prec; ! get the length of the string n = len_trim(refdate) @@ -121,8 +121,8 @@ subroutine extractTime(refdate,iyyy,im,id,ih,imin,dsec,ih_tz,imin_tz,dsec_tz,err if(ih > 24) then; err=20; message=trim(message)//'hour > 24'; return; end if if(imin < 0) then; err=20; message=trim(message)//'minute < 0'; return; end if if(imin > 60) then; err=20; message=trim(message)//'minute > 60'; return; end if - if(dsec < 0._dp)then; err=20; message=trim(message)//'second < 0'; return; end if - if(dsec > 60._dp)then; err=20; message=trim(message)//'second > 60'; return; end if + if(dsec < 0._summa_prec)then; err=20; message=trim(message)//'second < 0'; return; end if + if(dsec > 60._summa_prec)then; err=20; message=trim(message)//'second > 60'; return; end if ! FIELD 3: Advance to the ih_tz:imin_tz string istart=nsub+1 @@ -149,8 +149,8 @@ subroutine extractTime(refdate,iyyy,im,id,ih,imin,dsec,ih_tz,imin_tz,dsec_tz,err if(ih_tz > 12) then; err=20; message=trim(message)//'time zone hour > 12'; return; end if if(imin_tz < 0) then; err=20; message=trim(message)//'time zone minute < 0'; return; end if if(imin_tz > 60) then; err=20; message=trim(message)//'time zone minute > 60'; return; end if - if(dsec_tz < 0._dp)then; err=20; message=trim(message)//'time zone second < 0'; return; end if - if(dsec_tz > 60._dp)then; err=20; message=trim(message)//'time zone second > 60'; return; end if + if(dsec_tz < 0._summa_prec)then; err=20; message=trim(message)//'time zone second < 0'; return; end if + if(dsec_tz > 60._summa_prec)then; err=20; message=trim(message)//'time zone second > 60'; return; end if contains @@ -231,7 +231,7 @@ subroutine extract_hms(substring,cdelim,hh,mm,ss,err,message) ! output integer(i4b),intent(out) :: hh ! hour integer(i4b),intent(out) :: mm ! minute - real(dp) ,intent(out) :: ss ! sec + real(summa_prec) ,intent(out) :: ss ! sec integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! local variables @@ -272,16 +272,16 @@ subroutine compjulday(iyyy,mm,id,ih,imin,dsec,& ! input ! input variables integer(i4b),intent(in) :: iyyy,mm,id ! year, month, day integer(i4b),intent(in) :: ih,imin ! hour, minute - real(dp),intent(in) :: dsec ! seconds + real(summa_prec),intent(in) :: dsec ! seconds ! output - real(dp),intent(out) :: juldayss + real(summa_prec),intent(out) :: juldayss integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! local variables integer(i4b) :: julday ! julian day integer(i4b),parameter :: igreg=15+31*(10+12*1582) !IGREG = 588829 integer(i4b) :: ja,jm,jy - real(dp) :: jfrac ! fraction of julian day + real(summa_prec) :: jfrac ! fraction of julian day ! initialize errors err=0; message="juldayss" @@ -306,7 +306,7 @@ subroutine compjulday(iyyy,mm,id,ih,imin,dsec,& ! input jfrac = fracDay(ih, imin, dsec) ! and return the julian day, expressed in fraction of a day - juldayss = real(julday,kind(dp)) + jfrac + juldayss = real(julday,kind(summa_prec)) + jfrac end subroutine compjulday @@ -320,7 +320,7 @@ subroutine compcalday(julday, & !input implicit none ! input variables - real(dp), intent(in) :: julday ! julian day + real(summa_prec), intent(in) :: julday ! julian day ! output varibles integer(i4b), intent(out) :: iyyy ! year @@ -328,7 +328,7 @@ subroutine compcalday(julday, & !input integer(i4b), intent(out) :: id ! day integer(i4b), intent(out) :: ih ! hour integer(i4b), intent(out) :: imin ! minute - real(dp), intent(out) :: dsec ! seconds + real(summa_prec), intent(out) :: dsec ! seconds integer(i4b), intent(out) :: err ! error code character(*), intent(out) :: message ! error message @@ -345,14 +345,14 @@ subroutine compcalday(julday, & !input integer(i4b),parameter :: w = 2 integer(i4b),parameter :: b = 274277 integer(i4b),parameter :: c = -38 - real(dp),parameter :: hr_per_day = 24.0_dp - real(dp),parameter :: min_per_hour = 60.0_dp + real(summa_prec),parameter :: hr_per_day = 24.0_summa_prec + real(summa_prec),parameter :: min_per_hour = 60.0_summa_prec ! local variables integer(i4b) :: f,e,g,h ! various step variables from wikipedia integer(i4b) :: step_1a,step_1b,step_1c,step_1d ! temporary variables for calendar calculations - real(dp) :: frac_day ! fractional day - real(dp) :: remainder ! remainder of modulus operation + real(summa_prec) :: frac_day ! fractional day + real(summa_prec) :: remainder ! remainder of modulus operation ! initialize errors err=0; message="compcalday" @@ -402,7 +402,7 @@ end subroutine compcalday ! *************************************************************************************** function elapsedSec(startTime, endTime) integer(i4b),intent(in) :: startTime(8),endTime(8) ! state time and end time - real(dp) :: elapsedSec ! elapsed time in seconds + real(summa_prec) :: elapsedSec ! elapsed time in seconds ! local variables integer(i4b) :: elapsedDay ! elapsed full days integer(i4b) :: yy ! index of year @@ -411,7 +411,7 @@ function elapsedSec(startTime, endTime) integer(i4b) :: days2(12) = (/31,28,31,30,31,30,31,31,30,31,30,31/) ! calculate the elapsed time smaller than a day - elapsedSec = (endTime(8)-startTime(8))*.001_dp + (endTime(7)-startTime(7)) + (endTime(6)-startTime(6))*secprmin + (endTime(5)-startTime(5))*secprhour + elapsedSec = (endTime(8)-startTime(8))*.001_summa_prec + (endTime(7)-startTime(7)) + (endTime(6)-startTime(6))*secprmin + (endTime(5)-startTime(5))*secprhour ! check if the run is within the same day otherwise calculate how many days if (endTime(1) > startTime(1) .or. endTime(2) > startTime(2) .or. endTime(3) > startTime(3)) then @@ -440,11 +440,11 @@ end function elapsedSec ! *************************************************************************************** function fracDay(ih, imin, dsec) integer(i4b),intent(in) :: ih,imin ! hour, minute - real(dp),intent(in) :: dsec ! seconds - real(dp) :: fracDay ! fraction of a day + real(summa_prec),intent(in) :: dsec ! seconds + real(summa_prec) :: fracDay ! fraction of a day ! local variable - fracDay = (real(ih,kind(dp))*secprhour + real(imin,kind(dp))*secprmin + dsec) / secprday + fracDay = (real(ih,kind(summa_prec))*secprhour + real(imin,kind(summa_prec))*secprmin + dsec) / secprday if(ih < 0) fracDay=-fracDay return end function fracDay diff --git a/build/source/engine/updatState.f90 b/build/source/engine/updatState.f90 index 698c8b1cd..006e6b532 100755 --- a/build/source/engine/updatState.f90 +++ b/build/source/engine/updatState.f90 @@ -52,13 +52,13 @@ subroutine updateSnow(& USE snow_utils_module,only:fracliquid ! compute volumetric fraction of liquid water implicit none ! input variables - real(dp),intent(in) :: mLayerTemp ! temperature (K) - real(dp),intent(in) :: mLayerTheta ! volume fraction of total water (-) - real(dp),intent(in) :: snowfrz_scale ! scaling parameter for the snow freezing curve (K-1) + real(summa_prec),intent(in) :: mLayerTemp ! temperature (K) + real(summa_prec),intent(in) :: mLayerTheta ! volume fraction of total water (-) + real(summa_prec),intent(in) :: snowfrz_scale ! scaling parameter for the snow freezing curve (K-1) ! output variables - real(dp),intent(out) :: mLayerVolFracLiq ! volumetric fraction of liquid water (-) - real(dp),intent(out) :: mLayerVolFracIce ! volumetric fraction of ice (-) - real(dp),intent(out) :: fLiq ! fraction of liquid water (-) + real(summa_prec),intent(out) :: mLayerVolFracLiq ! volumetric fraction of liquid water (-) + real(summa_prec),intent(out) :: mLayerVolFracIce ! volumetric fraction of ice (-) + real(summa_prec),intent(out) :: fLiq ! fraction of liquid water (-) ! error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message @@ -68,7 +68,7 @@ subroutine updateSnow(& ! compute the volumetric fraction of liquid water and ice (-) fLiq = fracliquid(mLayerTemp,snowfrz_scale) mLayerVolFracLiq = fLiq*mLayerTheta - mLayerVolFracIce = (1._dp - fLiq)*mLayerTheta*(iden_water/iden_ice) + mLayerVolFracIce = (1._summa_prec - fLiq)*mLayerTheta*(iden_water/iden_ice) !print*, 'mLayerTheta - (mLayerVolFracIce*(iden_ice/iden_water) + mLayerVolFracLiq) = ', mLayerTheta - (mLayerVolFracIce*(iden_ice/iden_water) + mLayerVolFracLiq) !write(*,'(a,1x,4(f20.10,1x))') 'in updateSnow: fLiq, mLayerTheta, mLayerVolFracIce = ', & ! fLiq, mLayerTheta, mLayerVolFracIce @@ -98,23 +98,23 @@ subroutine updateSoil(& USE soil_utils_module,only:matricHead ! compute the matric head based on volumetric liquid water content implicit none ! input variables - real(dp),intent(in) :: mLayerTemp ! estimate of temperature (K) - real(dp),intent(in) :: mLayerMatricHead ! matric head (m) - real(dp),intent(in) :: vGn_alpha ! van Genutchen "alpha" parameter - real(dp),intent(in) :: vGn_n ! van Genutchen "n" parameter - real(dp),intent(in) :: theta_sat ! soil porosity (-) - real(dp),intent(in) :: theta_res ! soil residual volumetric water content (-) - real(dp),intent(in) :: vGn_m ! van Genutchen "m" parameter (-) + real(summa_prec),intent(in) :: mLayerTemp ! estimate of temperature (K) + real(summa_prec),intent(in) :: mLayerMatricHead ! matric head (m) + real(summa_prec),intent(in) :: vGn_alpha ! van Genutchen "alpha" parameter + real(summa_prec),intent(in) :: vGn_n ! van Genutchen "n" parameter + real(summa_prec),intent(in) :: theta_sat ! soil porosity (-) + real(summa_prec),intent(in) :: theta_res ! soil residual volumetric water content (-) + real(summa_prec),intent(in) :: vGn_m ! van Genutchen "m" parameter (-) ! output variables - real(dp),intent(out) :: mLayerVolFracWat ! fractional volume of total water (-) - real(dp),intent(out) :: mLayerVolFracLiq ! volumetric fraction of liquid water (-) - real(dp),intent(out) :: mLayerVolFracIce ! volumetric fraction of ice (-) + real(summa_prec),intent(out) :: mLayerVolFracWat ! fractional volume of total water (-) + real(summa_prec),intent(out) :: mLayerVolFracLiq ! volumetric fraction of liquid water (-) + real(summa_prec),intent(out) :: mLayerVolFracIce ! volumetric fraction of ice (-) integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! define local variables - real(dp) :: TcSoil ! critical soil temperature when all water is unfrozen (K) - real(dp) :: xConst ! constant in the freezing curve function (m K-1) - real(dp) :: mLayerPsiLiq ! liquid water matric potential (m) + real(summa_prec) :: TcSoil ! critical soil temperature when all water is unfrozen (K) + real(summa_prec) :: xConst ! constant in the freezing curve function (m K-1) + real(summa_prec) :: mLayerPsiLiq ! liquid water matric potential (m) ! initialize error control err=0; message="updateSoil/" @@ -124,7 +124,7 @@ subroutine updateSoil(& ! compute the critical soil temperature where all water is unfrozen (K) ! (eq 17 in Dall'Amico 2011) - TcSoil = Tfreeze + min(mLayerMatricHead,0._dp)*gravity*Tfreeze/LH_fus ! (NOTE: J = kg m2 s-2, so LH_fus is in units of m2 s-2) + TcSoil = Tfreeze + min(mLayerMatricHead,0._summa_prec)*gravity*Tfreeze/LH_fus ! (NOTE: J = kg m2 s-2, so LH_fus is in units of m2 s-2) ! *** compute volumetric fraction of liquid water and ice for partially frozen soil if(mLayerTemp < TcSoil)then ! (check if soil temperature is less than the critical temperature) @@ -145,7 +145,7 @@ subroutine updateSoil(& ! all water is unfrozen mLayerPsiLiq = mLayerMatricHead mLayerVolFracLiq = mLayerVolFracWat - mLayerVolFracIce = 0._dp + mLayerVolFracIce = 0._summa_prec end if ! (check if soil is partially frozen) diff --git a/build/source/engine/updateVars.f90 b/build/source/engine/updateVars.f90 index c024f1cd2..a6b1a1f61 100755 --- a/build/source/engine/updateVars.f90 +++ b/build/source/engine/updateVars.f90 @@ -135,17 +135,17 @@ subroutine updateVars(& type(var_dlength),intent(inout) :: diag_data ! diagnostic variables for a local HRU type(var_dlength),intent(inout) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables ! output: variables for the vegetation canopy - real(dp),intent(inout) :: scalarCanopyTempTrial ! trial value of canopy temperature (K) - real(dp),intent(inout) :: scalarCanopyWatTrial ! trial value of canopy total water (kg m-2) - real(dp),intent(inout) :: scalarCanopyLiqTrial ! trial value of canopy liquid water (kg m-2) - real(dp),intent(inout) :: scalarCanopyIceTrial ! trial value of canopy ice content (kg m-2) + real(summa_prec),intent(inout) :: scalarCanopyTempTrial ! trial value of canopy temperature (K) + real(summa_prec),intent(inout) :: scalarCanopyWatTrial ! trial value of canopy total water (kg m-2) + real(summa_prec),intent(inout) :: scalarCanopyLiqTrial ! trial value of canopy liquid water (kg m-2) + real(summa_prec),intent(inout) :: scalarCanopyIceTrial ! trial value of canopy ice content (kg m-2) ! output: variables for the snow-soil domain - real(dp),intent(inout) :: mLayerTempTrial(:) ! trial vector of layer temperature (K) - real(dp),intent(inout) :: mLayerVolFracWatTrial(:) ! trial vector of volumetric total water content (-) - real(dp),intent(inout) :: mLayerVolFracLiqTrial(:) ! trial vector of volumetric liquid water content (-) - real(dp),intent(inout) :: mLayerVolFracIceTrial(:) ! trial vector of volumetric ice water content (-) - real(dp),intent(inout) :: mLayerMatricHeadTrial(:) ! trial vector of total water matric potential (m) - real(dp),intent(inout) :: mLayerMatricHeadLiqTrial(:) ! trial vector of liquid water matric potential (m) + real(summa_prec),intent(inout) :: mLayerTempTrial(:) ! trial vector of layer temperature (K) + real(summa_prec),intent(inout) :: mLayerVolFracWatTrial(:) ! trial vector of volumetric total water content (-) + real(summa_prec),intent(inout) :: mLayerVolFracLiqTrial(:) ! trial vector of volumetric liquid water content (-) + real(summa_prec),intent(inout) :: mLayerVolFracIceTrial(:) ! trial vector of volumetric ice water content (-) + real(summa_prec),intent(inout) :: mLayerMatricHeadTrial(:) ! trial vector of total water matric potential (m) + real(summa_prec),intent(inout) :: mLayerMatricHeadLiqTrial(:) ! trial vector of liquid water matric potential (m) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message @@ -160,29 +160,29 @@ subroutine updateVars(& logical(lgt) :: isCoupled ! .true. if a given variable shared another state variable in the same control volume logical(lgt) :: isNrgState ! .true. if a given variable is an energy state logical(lgt),allocatable :: computedCoupling(:) ! .true. if computed the coupling for a given state variable - real(dp) :: scalarVolFracLiq ! volumetric fraction of liquid water (-) - real(dp) :: scalarVolFracIce ! volumetric fraction of ice (-) - real(dp) :: Tcrit ! critical soil temperature below which ice exists (K) - real(dp) :: xTemp ! temporary temperature (K) - real(dp) :: effSat ! effective saturation (-) - real(dp) :: avPore ! available pore space (-) + real(summa_prec) :: scalarVolFracLiq ! volumetric fraction of liquid water (-) + real(summa_prec) :: scalarVolFracIce ! volumetric fraction of ice (-) + real(summa_prec) :: Tcrit ! critical soil temperature below which ice exists (K) + real(summa_prec) :: xTemp ! temporary temperature (K) + real(summa_prec) :: effSat ! effective saturation (-) + real(summa_prec) :: avPore ! available pore space (-) character(len=256) :: cMessage ! error message of downwind routine logical(lgt),parameter :: printFlag=.false. ! flag to turn on printing ! iterative solution for temperature - real(dp) :: meltNrg ! energy for melt+freeze (J m-3) - real(dp) :: residual ! residual in the energy equation (J m-3) - real(dp) :: derivative ! derivative in the energy equation (J m-3 K-1) - real(dp) :: tempInc ! iteration increment (K) + real(summa_prec) :: meltNrg ! energy for melt+freeze (J m-3) + real(summa_prec) :: residual ! residual in the energy equation (J m-3) + real(summa_prec) :: derivative ! derivative in the energy equation (J m-3 K-1) + real(summa_prec) :: tempInc ! iteration increment (K) integer(i4b) :: iter ! iteration index integer(i4b) :: niter ! number of iterations integer(i4b),parameter :: maxiter=100 ! maximum number of iterations - real(dp),parameter :: nrgConvTol=1.e-4_dp ! convergence tolerance for energy (J m-3) - real(dp),parameter :: tempConvTol=1.e-6_dp ! convergence tolerance for temperature (K) - real(dp) :: critDiff ! temperature difference from critical (K) - real(dp) :: tempMin ! minimum bracket for temperature (K) - real(dp) :: tempMax ! maximum bracket for temperature (K) + real(summa_prec),parameter :: nrgConvTol=1.e-4_summa_prec ! convergence tolerance for energy (J m-3) + real(summa_prec),parameter :: tempConvTol=1.e-6_summa_prec ! convergence tolerance for temperature (K) + real(summa_prec) :: critDiff ! temperature difference from critical (K) + real(summa_prec) :: tempMin ! minimum bracket for temperature (K) + real(summa_prec) :: tempMax ! maximum bracket for temperature (K) logical(lgt) :: bFlag ! flag to denote that iteration increment was constrained using bi-section - real(dp),parameter :: epsT=1.e-7_dp ! small interval above/below critical temperature (K) + real(summa_prec),parameter :: epsT=1.e-7_summa_prec ! small interval above/below critical temperature (K) ! -------------------------------------------------------------------------------------------------------------------------------- ! make association with variables in the data structures associate(& @@ -334,7 +334,7 @@ subroutine updateVars(& select case( ixStateType(ixFullVector) ) ! --> update the total water from the liquid water matric potential case(iname_lmpLayer) - effSat = volFracLiq(mLayerMatricHeadLiqTrial(ixControlIndex),vGn_alpha(ixControlIndex),0._dp,1._dp,vGn_n(ixControlIndex),vGn_m(ixControlIndex)) ! effective saturation + effSat = volFracLiq(mLayerMatricHeadLiqTrial(ixControlIndex),vGn_alpha(ixControlIndex),0._summa_prec,1._summa_prec,vGn_n(ixControlIndex),vGn_m(ixControlIndex)) ! effective saturation avPore = theta_sat(ixControlIndex) - mLayerVolFracIceTrial(iLayer) - theta_res(ixControlIndex) ! available pore space mLayerVolFracLiqTrial(iLayer) = effSat*avPore + theta_res(ixControlIndex) mLayerVolFracWatTrial(iLayer) = mLayerVolFracLiqTrial(iLayer) + mLayerVolFracIceTrial(iLayer) ! no volume expansion @@ -368,8 +368,8 @@ subroutine updateVars(& ! define brackets for the root ! NOTE: start with an enormous range; updated quickly in the iterations - tempMin = xTemp - 10._dp - tempMax = xTemp + 10._dp + tempMin = xTemp - 10._summa_prec + tempMax = xTemp + 10._summa_prec ! get iterations (set to maximum iterations if adjusting the temperature) niter = merge(maxiter, 1, do_adjustTemp) @@ -379,7 +379,7 @@ subroutine updateVars(& ! restrict temperature if(xTemp <= tempMin .or. xTemp >= tempMax)then - xTemp = 0.5_dp*(tempMin + tempMax) ! new value + xTemp = 0.5_summa_prec*(tempMin + tempMax) ! new value bFlag = .true. else bFlag = .false. @@ -394,7 +394,7 @@ subroutine updateVars(& ! NOTE 2: for case "iname_lmpLayer", dVolTot_dPsi0 = dVolLiq_dPsi if(ixDomainType==iname_soil)then select case( ixStateType(ixFullVector) ) - case(iname_lmpLayer); dVolTot_dPsi0(ixControlIndex) = dTheta_dPsi(mLayerMatricHeadLiqTrial(ixControlIndex),vGn_alpha(ixControlIndex),0._dp,1._dp,vGn_n(ixControlIndex),vGn_m(ixControlIndex))*avPore + case(iname_lmpLayer); dVolTot_dPsi0(ixControlIndex) = dTheta_dPsi(mLayerMatricHeadLiqTrial(ixControlIndex),vGn_alpha(ixControlIndex),0._summa_prec,1._summa_prec,vGn_n(ixControlIndex),vGn_m(ixControlIndex))*avPore case default; dVolTot_dPsi0(ixControlIndex) = dTheta_dPsi(mLayerMatricHeadTrial(ixControlIndex),vGn_alpha(ixControlIndex),theta_res(ixControlIndex),theta_sat(ixControlIndex),vGn_n(ixControlIndex),vGn_m(ixControlIndex)) end select endif @@ -412,8 +412,8 @@ subroutine updateVars(& ! --> unfrozen: no dependence of liquid water on temperature else select case(ixDomainType) - case(iname_veg); dTheta_dTkCanopy = 0._dp - case(iname_snow, iname_soil); mLayerdTheta_dTk(iLayer) = 0._dp + case(iname_veg); dTheta_dTkCanopy = 0._summa_prec + case(iname_snow, iname_soil); mLayerdTheta_dTk(iLayer) = 0._summa_prec case default; err=20; message=trim(message)//'expect case to be iname_veg, iname_snow, iname_soil'; return end select ! domain type endif @@ -461,7 +461,7 @@ subroutine updateVars(& ! compute mass of water on the canopy ! NOTE: possibilities for speed-up here scalarCanopyLiqTrial = scalarFracLiqVeg *scalarCanopyWatTrial - scalarCanopyIceTrial = (1._dp - scalarFracLiqVeg)*scalarCanopyWatTrial + scalarCanopyIceTrial = (1._summa_prec - scalarFracLiqVeg)*scalarCanopyWatTrial ! *** snow layers case(iname_snow) @@ -565,7 +565,7 @@ subroutine updateVars(& endif ! update bracket - if(residual < 0._dp)then + if(residual < 0._summa_prec)then tempMax = min(xTemp,tempMax) else tempMin = max(tempMin,xTemp) @@ -583,7 +583,7 @@ subroutine updateVars(& ! add constraints for snow temperature if(ixDomainType==iname_veg .or. ixDomainType==iname_snow)then - if(tempInc > Tcrit - xTemp) tempInc=(Tcrit - xTemp)*0.5_dp ! simple bi-section method + if(tempInc > Tcrit - xTemp) tempInc=(Tcrit - xTemp)*0.5_summa_prec ! simple bi-section method endif ! if the domain is vegetation or snow ! deal with the discontinuity between partially frozen and unfrozen soil @@ -591,7 +591,7 @@ subroutine updateVars(& ! difference from the temperature below which ice exists critDiff = Tcrit - xTemp ! --> initially frozen (T < Tcrit) - if(critDiff > 0._dp)then + if(critDiff > 0._summa_prec)then if(tempInc > critDiff) tempInc = critDiff + epsT ! set iteration increment to slightly above critical temperature ! --> initially unfrozen (T > Tcrit) else @@ -643,8 +643,8 @@ subroutine updateVars(& if(.not.isNrgState .and. .not.isCoupled)then ! derivatives relating liquid water matric potential to total water matric potential and temperature - dPsiLiq_dPsi0(ixControlIndex) = 1._dp ! exact correspondence (psiLiq=psi0) - dPsiLiq_dTemp(ixControlIndex) = 0._dp ! no relationship between liquid water matric potential and temperature + dPsiLiq_dPsi0(ixControlIndex) = 1._summa_prec ! exact correspondence (psiLiq=psi0) + dPsiLiq_dTemp(ixControlIndex) = 0._summa_prec ! no relationship between liquid water matric potential and temperature ! case of energy state or coupled solution else @@ -699,17 +699,17 @@ subroutine xTempSolve(& derivative ) ! intent(out) : derivative (J m-3 K-1) implicit none ! input: constant over iterations - real(dp),intent(in) :: meltNrg ! energy for melt+freeze (J m-3) - real(dp),intent(in) :: heatCap ! volumetric heat capacity (J m-3 K-1) - real(dp),intent(in) :: tempInit ! initial temperature (K) - real(dp),intent(in) :: volFracIceInit ! initial volumetric fraction of ice (-) + real(summa_prec),intent(in) :: meltNrg ! energy for melt+freeze (J m-3) + real(summa_prec),intent(in) :: heatCap ! volumetric heat capacity (J m-3 K-1) + real(summa_prec),intent(in) :: tempInit ! initial temperature (K) + real(summa_prec),intent(in) :: volFracIceInit ! initial volumetric fraction of ice (-) ! input-output: trial values - real(dp),intent(inout) :: xTemp ! trial value for temperature - real(dp),intent(in) :: dLiq_dT ! derivative in liquid water content w.r.t. temperature (K-1) - real(dp),intent(in) :: volFracIceTrial ! trial value for the volumetric fraction of ice (-) + real(summa_prec),intent(inout) :: xTemp ! trial value for temperature + real(summa_prec),intent(in) :: dLiq_dT ! derivative in liquid water content w.r.t. temperature (K-1) + real(summa_prec),intent(in) :: volFracIceTrial ! trial value for the volumetric fraction of ice (-) ! output: residual and derivative - real(dp),intent(out) :: residual ! residual (J m-3) - real(dp),intent(out) :: derivative ! derivative (J m-3 K-1) + real(summa_prec),intent(out) :: residual ! residual (J m-3) + real(summa_prec),intent(out) :: derivative ! derivative (J m-3 K-1) ! subroutine starts here residual = -heatCap*(xTemp - tempInit) + meltNrg*(volFracIceTrial - volFracIceInit) ! J m-3 derivative = heatCap + LH_fus*iden_water*dLiq_dT ! J m-3 K-1 diff --git a/build/source/engine/varSubstep.f90 b/build/source/engine/varSubstep.f90 index f82882d94..bb1b5a73e 100755 --- a/build/source/engine/varSubstep.f90 +++ b/build/source/engine/varSubstep.f90 @@ -73,7 +73,7 @@ module varSubstep_module public::varSubstep ! algorithmic parameters -real(dp),parameter :: verySmall=1.e-6_dp ! used as an additive constant to check if substantial difference among real numbers +real(summa_prec),parameter :: verySmall=1.e-6_summa_prec ! used as an additive constant to check if substantial difference among real numbers contains @@ -130,9 +130,9 @@ subroutine varSubstep(& ! * dummy variables ! --------------------------------------------------------------------------------------- ! input: model control - real(dp),intent(in) :: dt ! time step (seconds) - real(dp),intent(in) :: dtInit ! initial time step (seconds) - real(dp),intent(in) :: dt_min ! minimum time step (seconds) + real(summa_prec),intent(in) :: dt ! time step (seconds) + real(summa_prec),intent(in) :: dtInit ! initial time step (seconds) + real(summa_prec),intent(in) :: dt_min ! minimum time step (seconds) integer(i4b),intent(in) :: nState ! total number of state variables logical(lgt),intent(in) :: doAdjustTemp ! flag to indicate if we adjust the temperature logical(lgt),intent(in) :: firstSubStep ! flag to indicate if we are processing the first sub-step @@ -156,7 +156,7 @@ subroutine varSubstep(& type(var_dlength),intent(in) :: bvar_data ! model variables for the local basin ! output: model control integer(i4b),intent(inout) :: ixSaturation ! index of the lowest saturated layer (NOTE: only computed on the first iteration) - real(dp),intent(out) :: dtMultiplier ! substep multiplier (-) + real(summa_prec),intent(out) :: dtMultiplier ! substep multiplier (-) integer(i4b),intent(out) :: nSubsteps ! number of substeps taken for a given split logical(lgt),intent(out) :: failedMinimumStep ! flag to denote success of substepping for a given split logical(lgt),intent(out) :: reduceCoupledStep ! flag to denote need to reduce the length of the coupled step @@ -174,24 +174,24 @@ subroutine varSubstep(& integer(i4b) :: ixLayer ! index in a given domain integer(i4b), dimension(1) :: ixMin,ixMax ! bounds of a given flux vector ! time stepping - real(dp) :: dtSum ! sum of time from successful steps (seconds) - real(dp) :: dt_wght ! weight given to a given flux calculation - real(dp) :: dtSubstep ! length of a substep (s) + real(summa_prec) :: dtSum ! sum of time from successful steps (seconds) + real(summa_prec) :: dt_wght ! weight given to a given flux calculation + real(summa_prec) :: dtSubstep ! length of a substep (s) ! adaptive sub-stepping for the explicit solution logical(lgt) :: failedSubstep ! flag to denote success of substepping for a given split - real(dp),parameter :: safety=0.85_dp ! safety factor in adaptive sub-stepping - real(dp),parameter :: reduceMin=0.1_dp ! mimimum factor that time step is reduced - real(dp),parameter :: increaseMax=4.0_dp ! maximum factor that time step is increased + real(summa_prec),parameter :: safety=0.85_summa_prec ! safety factor in adaptive sub-stepping + real(summa_prec),parameter :: reduceMin=0.1_summa_prec ! mimimum factor that time step is reduced + real(summa_prec),parameter :: increaseMax=4.0_summa_prec ! maximum factor that time step is increased ! adaptive sub-stepping for the implicit solution integer(i4b) :: niter ! number of iterations taken integer(i4b),parameter :: n_inc=5 ! minimum number of iterations to increase time step integer(i4b),parameter :: n_dec=15 ! maximum number of iterations to decrease time step - real(dp),parameter :: F_inc = 1.25_dp ! factor used to increase time step - real(dp),parameter :: F_dec = 0.90_dp ! factor used to decrease time step + real(summa_prec),parameter :: F_inc = 1.25_summa_prec ! factor used to increase time step + real(summa_prec),parameter :: F_dec = 0.90_summa_prec ! factor used to decrease time step ! state and flux vectors - real(dp) :: untappedMelt(nState) ! un-tapped melt energy (J m-3 s-1) - real(dp) :: stateVecInit(nState) ! initial state vector (mixed units) - real(dp) :: stateVecTrial(nState) ! trial state vector (mixed units) + real(summa_prec) :: untappedMelt(nState) ! un-tapped melt energy (J m-3 s-1) + real(summa_prec) :: stateVecInit(nState) ! initial state vector (mixed units) + real(summa_prec) :: stateVecTrial(nState) ! trial state vector (mixed units) type(var_dlength) :: flux_temp ! temporary model fluxes ! flags logical(lgt) :: firstSplitOper ! flag to indicate if we are processing the first flux call in a splitting operation @@ -199,11 +199,11 @@ subroutine varSubstep(& logical(lgt) :: waterBalanceError ! flag to denote that there is a water balance error logical(lgt) :: nrgFluxModified ! flag to denote that the energy fluxes were modified ! energy fluxes - real(dp) :: sumCanopyEvaporation ! sum of canopy evaporation/condensation (kg m-2 s-1) - real(dp) :: sumLatHeatCanopyEvap ! sum of latent heat flux for evaporation from the canopy to the canopy air space (W m-2) - real(dp) :: sumSenHeatCanopy ! sum of sensible heat flux from the canopy to the canopy air space (W m-2) - real(dp) :: sumSoilCompress - real(dp),allocatable :: sumLayerCompress(:) + real(summa_prec) :: sumCanopyEvaporation ! sum of canopy evaporation/condensation (kg m-2 s-1) + real(summa_prec) :: sumLatHeatCanopyEvap ! sum of latent heat flux for evaporation from the canopy to the canopy air space (W m-2) + real(summa_prec) :: sumSenHeatCanopy ! sum of sensible heat flux from the canopy to the canopy air space (W m-2) + real(summa_prec) :: sumSoilCompress + real(summa_prec),allocatable :: sumLayerCompress(:) ! --------------------------------------------------------------------------------------- ! point to variables in the data structures ! --------------------------------------------------------------------------------------- @@ -255,17 +255,17 @@ subroutine varSubstep(& end do ! initialize the total energy fluxes (modified in updateProg) - sumCanopyEvaporation = 0._dp ! canopy evaporation/condensation (kg m-2 s-1) - sumLatHeatCanopyEvap = 0._dp ! latent heat flux for evaporation from the canopy to the canopy air space (W m-2) - sumSenHeatCanopy = 0._dp ! sensible heat flux from the canopy to the canopy air space (W m-2) - sumSoilCompress = 0._dp ! total soil compression - allocate(sumLayerCompress(nSoil)); sumLayerCompress = 0._dp ! soil compression by layer + sumCanopyEvaporation = 0._summa_prec ! canopy evaporation/condensation (kg m-2 s-1) + sumLatHeatCanopyEvap = 0._summa_prec ! latent heat flux for evaporation from the canopy to the canopy air space (W m-2) + sumSenHeatCanopy = 0._summa_prec ! sensible heat flux from the canopy to the canopy air space (W m-2) + sumSoilCompress = 0._summa_prec ! total soil compression + allocate(sumLayerCompress(nSoil)); sumLayerCompress = 0._summa_prec ! soil compression by layer ! define the first flux call in a splitting operation firstSplitOper = (.not.scalarSolution .or. iStateSplit==1) ! initialize subStep - dtSum = 0._dp ! keep track of the portion of the time step that is completed + dtSum = 0._summa_prec ! keep track of the portion of the time step that is completed nSubsteps = 0 ! loop through substeps @@ -351,7 +351,7 @@ subroutine varSubstep(& ! reduce step based on failure if(failedSubstep)then err=0; message='varSubstep/' ! recover from failed convergence - dtMultiplier = 0.5_dp ! system failure: step halving + dtMultiplier = 0.5_summa_prec ! system failure: step halving else ! ** implicit Euler: adjust step length based on iteration count @@ -360,7 +360,7 @@ subroutine varSubstep(& elseif(niter>n_dec)then dtMultiplier = F_dec else - dtMultiplier = 1._dp + dtMultiplier = 1._summa_prec endif endif ! switch between failure and success @@ -420,7 +420,7 @@ subroutine varSubstep(& ! modify step err=0 ! error recovery - dtSubstep = dtSubstep/2._dp + dtSubstep = dtSubstep/2._summa_prec ! check minimum: fail minimum step if there is an error in the update if(dtSubstep next, remove canopy evaporation -- put the unsatisfied evap into sensible heat canopyBalance1 = canopyBalance1 + scalarCanopyEvaporation*dt - if(canopyBalance1 < 0._dp)then + if(canopyBalance1 < 0._summa_prec)then ! * get superfluous water and energy superflousWat = -canopyBalance1/dt ! kg m-2 s-1 superflousNrg = superflousWat*LH_vap ! W m-2 (J m-2 s-1) ! * update fluxes and states - canopyBalance1 = 0._dp + canopyBalance1 = 0._summa_prec scalarCanopyEvaporation = scalarCanopyEvaporation + superflousWat scalarLatHeatCanopyEvap = scalarLatHeatCanopyEvap + superflousNrg scalarSenHeatCanopy = scalarSenHeatCanopy - superflousNrg @@ -766,9 +766,9 @@ subroutine updateProg(dt,nSnow,nSoil,nLayers,doAdjustTemp,computeVegFlux,untappe ! --> next, remove canopy drainage canopyBalance1 = canopyBalance1 - scalarCanopyLiqDrainage*dt - if(canopyBalance1 < 0._dp)then + if(canopyBalance1 < 0._summa_prec)then superflousWat = -canopyBalance1/dt ! kg m-2 s-1 - canopyBalance1 = 0._dp + canopyBalance1 = 0._summa_prec scalarCanopyLiqDrainage = scalarCanopyLiqDrainage + superflousWat endif @@ -795,7 +795,7 @@ subroutine updateProg(dt,nSnow,nSoil,nLayers,doAdjustTemp,computeVegFlux,untappe !write(*,'(a,1x,f20.10)') 'scalarCanopyEvaporation*dt = ', scalarCanopyEvaporation*dt !write(*,'(a,1x,f20.10)') 'scalarThroughfallRain*dt = ', scalarThroughfallRain*dt !write(*,'(a,1x,f20.10)') 'liqError = ', liqError - if(abs(liqError) > absConvTol_liquid*10._dp)then ! *10 because of precision issues + if(abs(liqError) > absConvTol_liquid*10._summa_prec)then ! *10 because of precision issues waterBalanceError = .true. return endif ! if there is a water balance error @@ -810,7 +810,7 @@ subroutine updateProg(dt,nSnow,nSoil,nLayers,doAdjustTemp,computeVegFlux,untappe baseSink = sum(mLayerBaseflow)*dt ! m s-1 --> m compSink = sum(mLayerCompress(1:nSoil) * mLayerDepth(nSnow+1:nLayers) ) ! dimensionless --> m liqError = soilBalance1 - (soilBalance0 + vertFlux + tranSink - baseSink - compSink) - if(abs(liqError) > absConvTol_liquid*10._dp)then ! *10 because of precision issues + if(abs(liqError) > absConvTol_liquid*10._summa_prec)then ! *10 because of precision issues !write(*,'(a,1x,f20.10)') 'dt = ', dt !write(*,'(a,1x,f20.10)') 'soilBalance0 = ', soilBalance0 !write(*,'(a,1x,f20.10)') 'soilBalance1 = ', soilBalance1 @@ -870,15 +870,15 @@ subroutine updateProg(dt,nSnow,nSoil,nLayers,doAdjustTemp,computeVegFlux,untappe ! *** ice ! --> check if we removed too much water - if(scalarCanopyIceTrial < 0._dp .or. any(mLayerVolFracIceTrial < 0._dp) )then + if(scalarCanopyIceTrial < 0._summa_prec .or. any(mLayerVolFracIceTrial < 0._summa_prec) )then ! ** ! canopy within numerical precision - if(scalarCanopyIceTrial < 0._dp)then + if(scalarCanopyIceTrial < 0._summa_prec)then if(scalarCanopyIceTrial > -verySmall)then scalarCanopyLiqTrial = scalarCanopyLiqTrial - scalarCanopyIceTrial - scalarCanopyIceTrial = 0._dp + scalarCanopyIceTrial = 0._summa_prec ! encountered an inconsistency: spit the dummy else @@ -897,11 +897,11 @@ subroutine updateProg(dt,nSnow,nSoil,nLayers,doAdjustTemp,computeVegFlux,untappe do iState=1,size(mLayerVolFracIceTrial) ! snow layer within numerical precision - if(mLayerVolFracIceTrial(iState) < 0._dp)then + if(mLayerVolFracIceTrial(iState) < 0._summa_prec)then if(mLayerVolFracIceTrial(iState) > -verySmall)then mLayerVolFracLiqTrial(iState) = mLayerVolFracLiqTrial(iState) - mLayerVolFracIceTrial(iState) - mLayerVolFracIceTrial(iState) = 0._dp + mLayerVolFracIceTrial(iState) = 0._summa_prec ! encountered an inconsistency: spit the dummy else @@ -924,15 +924,15 @@ subroutine updateProg(dt,nSnow,nSoil,nLayers,doAdjustTemp,computeVegFlux,untappe ! *** liquid water ! --> check if we removed too much water - if(scalarCanopyLiqTrial < 0._dp .or. any(mLayerVolFracLiqTrial < 0._dp) )then + if(scalarCanopyLiqTrial < 0._summa_prec .or. any(mLayerVolFracLiqTrial < 0._summa_prec) )then ! ** ! canopy within numerical precision - if(scalarCanopyLiqTrial < 0._dp)then + if(scalarCanopyLiqTrial < 0._summa_prec)then if(scalarCanopyLiqTrial > -verySmall)then scalarCanopyIceTrial = scalarCanopyIceTrial - scalarCanopyLiqTrial - scalarCanopyLiqTrial = 0._dp + scalarCanopyLiqTrial = 0._summa_prec ! encountered an inconsistency: spit the dummy else @@ -951,11 +951,11 @@ subroutine updateProg(dt,nSnow,nSoil,nLayers,doAdjustTemp,computeVegFlux,untappe do iState=1,size(mLayerVolFracLiqTrial) ! snow layer within numerical precision - if(mLayerVolFracLiqTrial(iState) < 0._dp)then + if(mLayerVolFracLiqTrial(iState) < 0._summa_prec)then if(mLayerVolFracLiqTrial(iState) > -verySmall)then mLayerVolFracIceTrial(iState) = mLayerVolFracIceTrial(iState) - mLayerVolFracLiqTrial(iState) - mLayerVolFracLiqTrial(iState) = 0._dp + mLayerVolFracLiqTrial(iState) = 0._summa_prec ! encountered an inconsistency: spit the dummy else diff --git a/build/source/engine/var_derive.f90 b/build/source/engine/var_derive.f90 index 8227b0407..85f369fc4 100755 --- a/build/source/engine/var_derive.f90 +++ b/build/source/engine/var_derive.f90 @@ -117,7 +117,7 @@ subroutine calcHeight(& ! loop through layers do iLayer=1,nLayers ! compute the height at the layer midpoint - mLayerHeight(iLayer) = iLayerHeight(iLayer-1) + mLayerDepth(iLayer)/2._dp + mLayerHeight(iLayer) = iLayerHeight(iLayer-1) + mLayerDepth(iLayer)/2._summa_prec ! compute the height at layer interfaces iLayerHeight(iLayer) = iLayerHeight(iLayer-1) + mLayerDepth(iLayer) end do ! (looping through layers) @@ -149,10 +149,10 @@ subroutine rootDensty(mpar_data,indx_data,prog_data,diag_data,err,message) character(*),intent(out) :: message ! error message ! declare local variables integer(i4b) :: iLayer ! loop through layers - real(dp) :: fracRootLower ! fraction of the rooting depth at the lower interface - real(dp) :: fracRootUpper ! fraction of the rooting depth at the upper interface - real(dp), parameter :: rootTolerance = 0.05_dp ! tolerance for error in doubleExp rooting option - real(dp) :: error ! machine precision error in rooting distribution + real(summa_prec) :: fracRootLower ! fraction of the rooting depth at the lower interface + real(summa_prec) :: fracRootUpper ! fraction of the rooting depth at the upper interface + real(summa_prec), parameter :: rootTolerance = 0.05_summa_prec ! tolerance for error in doubleExp rooting option + real(summa_prec) :: error ! machine precision error in rooting distribution ! initialize error control err=0; message='rootDensty/' @@ -192,16 +192,16 @@ subroutine rootDensty(mpar_data,indx_data,prog_data,diag_data,err,message) if(iLayerHeight(iLayer-1)1._dp) fracRootUpper=1._dp + if(fracRootUpper>1._summa_prec) fracRootUpper=1._summa_prec ! compute the root density mLayerRootDensity(iLayer-nSnow) = fracRootUpper**rootDistExp - fracRootLower**rootDistExp else - mLayerRootDensity(iLayer-nSnow) = 0._dp + mLayerRootDensity(iLayer-nSnow) = 0._summa_prec end if !write(*,'(a,10(f11.5,1x))') 'mLayerRootDensity(iLayer-nSnow), fracRootUpper, fracRootLower = ', & ! mLayerRootDensity(iLayer-nSnow), fracRootUpper, fracRootLower @@ -209,8 +209,8 @@ subroutine rootDensty(mpar_data,indx_data,prog_data,diag_data,err,message) ! ** option 2: double expoential profile of Zeng et al. (JHM 2001) case(doubleExp) ! compute the cumulative fraction of roots at the top and bottom of the layer - fracRootLower = 1._dp - 0.5_dp*(exp(-iLayerHeight(iLayer-1)*rootScaleFactor1) + exp(-iLayerHeight(iLayer-1)*rootScaleFactor2) ) - fracRootUpper = 1._dp - 0.5_dp*(exp(-iLayerHeight(iLayer )*rootScaleFactor1) + exp(-iLayerHeight(iLayer )*rootScaleFactor2) ) + fracRootLower = 1._summa_prec - 0.5_summa_prec*(exp(-iLayerHeight(iLayer-1)*rootScaleFactor1) + exp(-iLayerHeight(iLayer-1)*rootScaleFactor2) ) + fracRootUpper = 1._summa_prec - 0.5_summa_prec*(exp(-iLayerHeight(iLayer )*rootScaleFactor1) + exp(-iLayerHeight(iLayer )*rootScaleFactor2) ) ! compute the root density mLayerRootDensity(iLayer-nSnow) = fracRootUpper - fracRootLower !write(*,'(a,10(f11.5,1x))') 'mLayerRootDensity(iLayer-nSnow), fracRootUpper, fracRootLower = ', & @@ -225,26 +225,26 @@ subroutine rootDensty(mpar_data,indx_data,prog_data,diag_data,err,message) ! check that root density is within some reaosnable version of machine tolerance ! This is the case when root density is greater than 1. Can only happen with powerLaw option. - error = sum(mLayerRootDensity) - 1._dp - if (error > 2._dp*epsilon(rootingDepth)) then + error = sum(mLayerRootDensity) - 1._summa_prec + if (error > 2._summa_prec*epsilon(rootingDepth)) then message=trim(message)//'problem with the root density calaculation' err=20; return else - mLayerRootDensity = mLayerRootDensity - error/real(nSoil,kind(dp)) + mLayerRootDensity = mLayerRootDensity - error/real(nSoil,kind(summa_prec)) end if ! compute fraction of roots in the aquifer - if(sum(mLayerRootDensity) < 1._dp)then - scalarAquiferRootFrac = 1._dp - sum(mLayerRootDensity) + if(sum(mLayerRootDensity) < 1._summa_prec)then + scalarAquiferRootFrac = 1._summa_prec - sum(mLayerRootDensity) else - scalarAquiferRootFrac = 0._dp + scalarAquiferRootFrac = 0._summa_prec end if ! check that roots in the aquifer are appropriate - if ((ixGroundwater /= bigBucket).and.(scalarAquiferRootFrac > 2._dp*epsilon(rootingDepth)))then + if ((ixGroundwater /= bigBucket).and.(scalarAquiferRootFrac > 2._summa_prec*epsilon(rootingDepth)))then if(scalarAquiferRootFrac < rootTolerance) then - mLayerRootDensity = mLayerRootDensity + scalarAquiferRootFrac/real(nSoil, kind(dp)) - scalarAquiferRootFrac = 0._dp + mLayerRootDensity = mLayerRootDensity + scalarAquiferRootFrac/real(nSoil, kind(summa_prec)) + scalarAquiferRootFrac = 0._summa_prec else select case(ixRootProfile) case(powerLaw); message=trim(message)//'roots in the aquifer only allowed for the big bucket gw parameterization: check that rooting depth < soil depth' @@ -274,8 +274,8 @@ subroutine satHydCond(mpar_data,indx_data,prog_data,flux_data,err,message) character(*),intent(out) :: message ! error message ! declare local variables integer(i4b) :: iLayer ! loop through layers - real(dp) :: ifcDepthScaleFactor ! depth scaling factor (layer interfaces) - real(dp) :: midDepthScaleFactor ! depth scaling factor (layer midpoints) + real(summa_prec) :: ifcDepthScaleFactor ! depth scaling factor (layer interfaces) + real(summa_prec) :: midDepthScaleFactor ! depth scaling factor (layer midpoints) ! initialize error control err=0; message='satHydCond/' ! ---------------------------------------------------------------------------------- @@ -315,7 +315,7 @@ subroutine satHydCond(mpar_data,indx_data,prog_data,flux_data,err,message) if(iLayer==nLayers)then iLayerSatHydCond(iLayer-nSnow) = k_soil(nSoil) else - iLayerSatHydCond(iLayer-nSnow) = 0.5_dp * (k_soil(iLayer-nSnow) + k_soil(iLayer+1-nSnow) ) + iLayerSatHydCond(iLayer-nSnow) = 0.5_summa_prec * (k_soil(iLayer-nSnow) + k_soil(iLayer+1-nSnow) ) endif ! - conductivity at layer midpoints mLayerSatHydCond(iLayer-nSnow) = k_soil(iLayer-nSnow) @@ -327,11 +327,11 @@ subroutine satHydCond(mpar_data,indx_data,prog_data,flux_data,err,message) ! - conductivity at layer interfaces ! --> NOTE: Do we need a weighted average based on layer depth for interior layers? - if(compactedDepth/iLayerHeight(nLayers) /= 1._dp) then ! avoid divide by zero - ifcDepthScaleFactor = ( (1._dp - iLayerHeight(iLayer)/iLayerHeight(nLayers))**(zScale_TOPMODEL - 1._dp) ) / & - ( (1._dp - compactedDepth/iLayerHeight(nLayers))**(zScale_TOPMODEL - 1._dp) ) + if(compactedDepth/iLayerHeight(nLayers) /= 1._summa_prec) then ! avoid divide by zero + ifcDepthScaleFactor = ( (1._summa_prec - iLayerHeight(iLayer)/iLayerHeight(nLayers))**(zScale_TOPMODEL - 1._summa_prec) ) / & + ( (1._summa_prec - compactedDepth/iLayerHeight(nLayers))**(zScale_TOPMODEL - 1._summa_prec) ) else - ifcDepthScaleFactor = 1.0_dp + ifcDepthScaleFactor = 1.0_summa_prec endif if(iLayer==nSnow)then iLayerSatHydCond(iLayer-nSnow) = k_soil(1) * ifcDepthScaleFactor @@ -339,14 +339,14 @@ subroutine satHydCond(mpar_data,indx_data,prog_data,flux_data,err,message) if(iLayer==nLayers)then iLayerSatHydCond(iLayer-nSnow) = k_soil(nSoil) * ifcDepthScaleFactor else - iLayerSatHydCond(iLayer-nSnow) = 0.5_dp * (k_soil(iLayer-nSnow) + k_soil(iLayer+1-nSnow) ) * ifcDepthScaleFactor + iLayerSatHydCond(iLayer-nSnow) = 0.5_summa_prec * (k_soil(iLayer-nSnow) + k_soil(iLayer+1-nSnow) ) * ifcDepthScaleFactor endif ! - conductivity at layer midpoints - if(compactedDepth/iLayerHeight(nLayers) /= 1._dp) then ! avoid divide by zero - midDepthScaleFactor = ( (1._dp - mLayerHeight(iLayer)/iLayerHeight(nLayers))**(zScale_TOPMODEL - 1._dp) ) / & - ( (1._dp - compactedDepth/iLayerHeight(nLayers))**(zScale_TOPMODEL - 1._dp) ) + if(compactedDepth/iLayerHeight(nLayers) /= 1._summa_prec) then ! avoid divide by zero + midDepthScaleFactor = ( (1._summa_prec - mLayerHeight(iLayer)/iLayerHeight(nLayers))**(zScale_TOPMODEL - 1._summa_prec) ) / & + ( (1._summa_prec - compactedDepth/iLayerHeight(nLayers))**(zScale_TOPMODEL - 1._summa_prec) ) else - midDepthScaleFactor = 1.0_dp + midDepthScaleFactor = 1.0_summa_prec endif mLayerSatHydCond(iLayer-nSnow) = k_soil(iLayer-nSnow) * midDepthScaleFactor mLayerSatHydCondMP(iLayer-nSnow) = k_macropore(iLayer-nSnow) * midDepthScaleFactor @@ -384,21 +384,21 @@ subroutine fracFuture(bpar_data,bvar_data,err,message) implicit none ! input variables - real(dp),intent(in) :: bpar_data(:) ! vector of basin-average model parameters + real(summa_prec),intent(in) :: bpar_data(:) ! vector of basin-average model parameters ! output variables type(var_dlength),intent(inout) :: bvar_data ! data structure of basin-average model variables integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! internal - real(dp) :: dt ! data time step (s) + real(summa_prec) :: dt ! data time step (s) integer(i4b) :: nTDH ! number of points in the time-delay histogram integer(i4b) :: iFuture ! index in time delay histogram - real(dp) :: aLambda ! scale parameter in the Gamma distribution - real(dp) :: tFuture ! future time (end of step) - real(dp) :: pSave ! cumulative probability at the start of the step - real(dp) :: cumProb ! cumulative probability at the end of the step - real(dp) :: sumFrac ! sum of runoff fractions in all steps - real(dp),parameter :: tolerFrac=0.01_dp ! tolerance for missing fractional runoff by truncating histogram + real(summa_prec) :: aLambda ! scale parameter in the Gamma distribution + real(summa_prec) :: tFuture ! future time (end of step) + real(summa_prec) :: pSave ! cumulative probability at the start of the step + real(summa_prec) :: cumProb ! cumulative probability at the end of the step + real(summa_prec) :: sumFrac ! sum of runoff fractions in all steps + real(summa_prec),parameter :: tolerFrac=0.01_summa_prec ! tolerance for missing fractional runoff by truncating histogram ! initialize error control err=0; message='fracFuture/' ! ---------------------------------------------------------------------------------- @@ -419,22 +419,22 @@ subroutine fracFuture(bpar_data,bvar_data,err,message) nTDH = size(runoffFuture) ! initialize runoffFuture (will be overwritten by initial conditions file values if present) - runoffFuture(1:nTDH) = 0._dp + runoffFuture(1:nTDH) = 0._summa_prec ! select option for sub-grid routing select case(ixRouting) ! ** instantaneous routing case(qInstant) - fractionFuture(1) = 1._dp - fractionFuture(2:nTDH) = 0._dp + fractionFuture(1) = 1._summa_prec + fractionFuture(2:nTDH) = 0._summa_prec ! ** time delay histogram case(timeDelay) ! initialize - pSave = 0._dp ! cumulative probability at the start of the step + pSave = 0._summa_prec ! cumulative probability at the start of the step aLambda = routingGammaShape / routingGammaScale - if(routingGammaShape <= 0._dp .or. aLambda < 0._dp)then + if(routingGammaShape <= 0._summa_prec .or. aLambda < 0._summa_prec)then message=trim(message)//'bad arguments for the Gamma distribution' err=20; return end if @@ -443,19 +443,19 @@ subroutine fracFuture(bpar_data,bvar_data,err,message) ! get weight for a given bin tFuture = real(iFuture, kind(dt))*dt ! future time (end of step) cumProb = gammp(routingGammaShape,aLambda*tFuture) ! cumulative probability at the end of the step - fractionFuture(iFuture) = max(0._dp, cumProb - pSave) ! fraction of runoff in the current step + fractionFuture(iFuture) = max(0._summa_prec, cumProb - pSave) ! fraction of runoff in the current step pSave = cumProb ! save the cumulative probability for use in the next step !write(*,'(a,1x,i4,1x,3(f20.10,1x))') trim(message), iFuture, tFuture, cumProb, fractionFuture(iFuture) ! set remaining bins to zero if(fractionFuture(iFuture) < tiny(dt))then - fractionFuture(iFuture:nTDH) = 0._dp + fractionFuture(iFuture:nTDH) = 0._summa_prec exit end if end do ! (looping through future time steps) ! check that we have enough bins sumFrac = sum(fractionFuture) - if(abs(1._dp - sumFrac) > tolerFrac)then + if(abs(1._summa_prec - sumFrac) > tolerFrac)then write(*,*) 'fraction of basin runoff histogram being accounted for by time delay vector is ', sumFrac write(*,*) 'this is less than allowed by tolerFrac = ', tolerFrac message=trim(message)//'not enough bins for the time delay histogram -- fix hard-coded parameter in globalData.f90' @@ -497,7 +497,7 @@ subroutine v_shortcut(mpar_data,diag_data,err,message) ! ---------------------------------------------------------------------------------- ! compute the van Genutchen "m" parameter - vGn_m = 1._dp - 1._dp/vGn_n + vGn_m = 1._summa_prec - 1._summa_prec/vGn_n end associate end subroutine v_shortcut diff --git a/build/source/engine/vegLiqFlux.f90 b/build/source/engine/vegLiqFlux.f90 index 44fe6f695..9ca8b511b 100755 --- a/build/source/engine/vegLiqFlux.f90 +++ b/build/source/engine/vegLiqFlux.f90 @@ -67,16 +67,16 @@ subroutine vegLiqFlux(& implicit none ! input logical(lgt),intent(in) :: computeVegFlux ! flag to indicate if we are computing fluxes over vegetation (.false. means veg is buried with snow) - real(dp),intent(in) :: scalarCanopyLiqTrial ! trial mass of liquid water on the vegetation canopy at the current iteration (kg m-2) - real(dp),intent(in) :: scalarRainfall ! rainfall (kg m-2 s-1) + real(summa_prec),intent(in) :: scalarCanopyLiqTrial ! trial mass of liquid water on the vegetation canopy at the current iteration (kg m-2) + real(summa_prec),intent(in) :: scalarRainfall ! rainfall (kg m-2 s-1) ! input-output: data structures type(var_dlength),intent(in) :: mpar_data ! model parameters type(var_dlength),intent(inout) :: diag_data ! model diagnostic variables for the local basin ! output - real(dp),intent(out) :: scalarThroughfallRain ! rain that reaches the ground without ever touching the canopy (kg m-2 s-1) - real(dp),intent(out) :: scalarCanopyLiqDrainage ! drainage of liquid water from the vegetation canopy (kg m-2 s-1) - real(dp),intent(out) :: scalarThroughfallRainDeriv ! derivative in throughfall w.r.t. canopy liquid water (s-1) - real(dp),intent(out) :: scalarCanopyLiqDrainageDeriv ! derivative in canopy drainage w.r.t. canopy liquid water (s-1) + real(summa_prec),intent(out) :: scalarThroughfallRain ! rain that reaches the ground without ever touching the canopy (kg m-2 s-1) + real(summa_prec),intent(out) :: scalarCanopyLiqDrainage ! drainage of liquid water from the vegetation canopy (kg m-2 s-1) + real(summa_prec),intent(out) :: scalarThroughfallRainDeriv ! derivative in throughfall w.r.t. canopy liquid water (s-1) + real(summa_prec),intent(out) :: scalarCanopyLiqDrainageDeriv ! derivative in canopy drainage w.r.t. canopy liquid water (s-1) integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! ------------------------------------------------------------------------------------------------------------------------------------------------------ @@ -94,9 +94,9 @@ subroutine vegLiqFlux(& ! set throughfall to inputs if vegetation is completely buried with snow if(.not.computeVegFlux)then scalarThroughfallRain = scalarRainfall - scalarCanopyLiqDrainage = 0._dp - scalarThroughfallRainDeriv = 0._dp - scalarCanopyLiqDrainageDeriv = 0._dp + scalarCanopyLiqDrainage = 0._summa_prec + scalarThroughfallRainDeriv = 0._summa_prec + scalarCanopyLiqDrainageDeriv = 0._summa_prec return end if @@ -106,13 +106,13 @@ subroutine vegLiqFlux(& ! original model (no flexibility in canopy interception): 100% of rainfall is intercepted by the vegetation canopy ! NOTE: this could be done with scalarThroughfallScaleRain=0, though requires setting scalarThroughfallScaleRain in all test cases case(unDefined) - scalarThroughfallRain = 0._dp - scalarThroughfallRainDeriv = 0._dp + scalarThroughfallRain = 0._summa_prec + scalarThroughfallRainDeriv = 0._summa_prec ! fraction of rainfall hits the ground without ever touching the canopy case(sparseCanopy) scalarThroughfallRain = scalarThroughfallScaleRain*scalarRainfall - scalarThroughfallRainDeriv = 0._dp + scalarThroughfallRainDeriv = 0._summa_prec ! throughfall a function of canopy storage case(storageFunc) @@ -125,7 +125,7 @@ subroutine vegLiqFlux(& ! all rain falls through the canopy when the canopy is at capacity else scalarThroughfallRain = scalarRainfall - scalarThroughfallRainDeriv = 0._dp + scalarThroughfallRainDeriv = 0._summa_prec end if case default; err=20; message=trim(message)//'unable to identify option for canopy interception'; return @@ -137,8 +137,8 @@ subroutine vegLiqFlux(& scalarCanopyLiqDrainage = scalarCanopyDrainageCoeff*(scalarCanopyLiqTrial - scalarCanopyLiqMax) scalarCanopyLiqDrainageDeriv = scalarCanopyDrainageCoeff else - scalarCanopyLiqDrainage = 0._dp - scalarCanopyLiqDrainageDeriv = 0._dp + scalarCanopyLiqDrainage = 0._summa_prec + scalarCanopyLiqDrainageDeriv = 0._summa_prec end if !write(*,'(a,1x,f25.15)') 'scalarCanopyLiqDrainage = ', scalarCanopyLiqDrainage diff --git a/build/source/engine/vegNrgFlux.f90 b/build/source/engine/vegNrgFlux.f90 index 47bfba9a9..03f80f886 100755 --- a/build/source/engine/vegNrgFlux.f90 +++ b/build/source/engine/vegNrgFlux.f90 @@ -114,11 +114,11 @@ module vegNrgFlux_module integer(i4b),parameter :: iLoc = 1 ! i-location integer(i4b),parameter :: jLoc = 1 ! j-location ! algorithmic parameters -real(dp),parameter :: missingValue=-9999._dp ! missing value, used when diagnostic or state variables are undefined -real(dp),parameter :: verySmall=1.e-6_dp ! used as an additive constant to check if substantial difference among real numbers -real(dp),parameter :: tinyVal=epsilon(1._dp) ! used as an additive constant to check if substantial difference among real numbers -real(dp),parameter :: mpe=1.e-6_dp ! prevents overflow error if division by zero -real(dp),parameter :: dx=1.e-11_dp ! finite difference increment +real(summa_prec),parameter :: missingValue=-9999._summa_prec ! missing value, used when diagnostic or state variables are undefined +real(summa_prec),parameter :: verySmall=1.e-6_summa_prec ! used as an additive constant to check if substantial difference among real numbers +real(summa_prec),parameter :: tinyVal=epsilon(1._summa_prec) ! used as an additive constant to check if substantial difference among real numbers +real(summa_prec),parameter :: mpe=1.e-6_summa_prec ! prevents overflow error if division by zero +real(summa_prec),parameter :: dx=1.e-11_summa_prec ! finite difference increment ! control logical(lgt) :: printflag ! flag to turn on printing contains @@ -213,15 +213,15 @@ subroutine vegNrgFlux(& logical(lgt),intent(in) :: computeVegFlux ! flag to indicate if computing fluxes over vegetation ! input: model state variables - real(dp),intent(in) :: upperBoundTemp ! temperature of the upper boundary (K) --> NOTE: use air temperature - real(dp),intent(in) :: canairTempTrial ! trial value of canopy air space temperature (K) - real(dp),intent(in) :: canopyTempTrial ! trial value of canopy temperature (K) - real(dp),intent(in) :: groundTempTrial ! trial value of ground temperature (K) - real(dp),intent(in) :: canopyIceTrial ! trial value of mass of ice on the vegetation canopy (kg m-2) - real(dp),intent(in) :: canopyLiqTrial ! trial value of mass of liquid water on the vegetation canopy (kg m-2) + real(summa_prec),intent(in) :: upperBoundTemp ! temperature of the upper boundary (K) --> NOTE: use air temperature + real(summa_prec),intent(in) :: canairTempTrial ! trial value of canopy air space temperature (K) + real(summa_prec),intent(in) :: canopyTempTrial ! trial value of canopy temperature (K) + real(summa_prec),intent(in) :: groundTempTrial ! trial value of ground temperature (K) + real(summa_prec),intent(in) :: canopyIceTrial ! trial value of mass of ice on the vegetation canopy (kg m-2) + real(summa_prec),intent(in) :: canopyLiqTrial ! trial value of mass of liquid water on the vegetation canopy (kg m-2) ! input: model derivatives - real(dp),intent(in) :: dCanLiq_dTcanopy ! intent(in): derivative in canopy liquid w.r.t. canopy temperature (kg m-2 K-1) + real(summa_prec),intent(in) :: dCanLiq_dTcanopy ! intent(in): derivative in canopy liquid w.r.t. canopy temperature (kg m-2 K-1) ! input/output: data structures type(var_i),intent(in) :: type_data ! type of vegetation and soil @@ -235,41 +235,41 @@ subroutine vegNrgFlux(& type(model_options),intent(in) :: model_decisions(:) ! model decisions ! output: liquid water fluxes associated with evaporation/transpiration (needed for coupling) - real(dp),intent(out) :: returnCanopyTranspiration ! canopy transpiration (kg m-2 s-1) - real(dp),intent(out) :: returnCanopyEvaporation ! canopy evaporation/condensation (kg m-2 s-1) - real(dp),intent(out) :: returnGroundEvaporation ! ground evaporation/condensation -- below canopy or non-vegetated (kg m-2 s-1) + real(summa_prec),intent(out) :: returnCanopyTranspiration ! canopy transpiration (kg m-2 s-1) + real(summa_prec),intent(out) :: returnCanopyEvaporation ! canopy evaporation/condensation (kg m-2 s-1) + real(summa_prec),intent(out) :: returnGroundEvaporation ! ground evaporation/condensation -- below canopy or non-vegetated (kg m-2 s-1) ! output: fluxes - real(dp),intent(out) :: canairNetFlux ! net energy flux for the canopy air space (W m-2) - real(dp),intent(out) :: canopyNetFlux ! net energy flux for the vegetation canopy (W m-2) - real(dp),intent(out) :: groundNetFlux ! net energy flux for the ground surface (W m-2) + real(summa_prec),intent(out) :: canairNetFlux ! net energy flux for the canopy air space (W m-2) + real(summa_prec),intent(out) :: canopyNetFlux ! net energy flux for the vegetation canopy (W m-2) + real(summa_prec),intent(out) :: groundNetFlux ! net energy flux for the ground surface (W m-2) ! output: energy flux derivatives - real(dp),intent(out) :: dCanairNetFlux_dCanairTemp ! derivative in net canopy air space flux w.r.t. canopy air temperature (W m-2 K-1) - real(dp),intent(out) :: dCanairNetFlux_dCanopyTemp ! derivative in net canopy air space flux w.r.t. canopy temperature (W m-2 K-1) - real(dp),intent(out) :: dCanairNetFlux_dGroundTemp ! derivative in net canopy air space flux w.r.t. ground temperature (W m-2 K-1) - real(dp),intent(out) :: dCanopyNetFlux_dCanairTemp ! derivative in net canopy flux w.r.t. canopy air temperature (W m-2 K-1) - real(dp),intent(out) :: dCanopyNetFlux_dCanopyTemp ! derivative in net canopy flux w.r.t. canopy temperature (W m-2 K-1) - real(dp),intent(out) :: dCanopyNetFlux_dGroundTemp ! derivative in net canopy flux w.r.t. ground temperature (W m-2 K-1) - real(dp),intent(out) :: dGroundNetFlux_dCanairTemp ! derivative in net ground flux w.r.t. canopy air temperature (W m-2 K-1) - real(dp),intent(out) :: dGroundNetFlux_dCanopyTemp ! derivative in net ground flux w.r.t. canopy temperature (W m-2 K-1) - real(dp),intent(out) :: dGroundNetFlux_dGroundTemp ! derivative in net ground flux w.r.t. ground temperature (W m-2 K-1) + real(summa_prec),intent(out) :: dCanairNetFlux_dCanairTemp ! derivative in net canopy air space flux w.r.t. canopy air temperature (W m-2 K-1) + real(summa_prec),intent(out) :: dCanairNetFlux_dCanopyTemp ! derivative in net canopy air space flux w.r.t. canopy temperature (W m-2 K-1) + real(summa_prec),intent(out) :: dCanairNetFlux_dGroundTemp ! derivative in net canopy air space flux w.r.t. ground temperature (W m-2 K-1) + real(summa_prec),intent(out) :: dCanopyNetFlux_dCanairTemp ! derivative in net canopy flux w.r.t. canopy air temperature (W m-2 K-1) + real(summa_prec),intent(out) :: dCanopyNetFlux_dCanopyTemp ! derivative in net canopy flux w.r.t. canopy temperature (W m-2 K-1) + real(summa_prec),intent(out) :: dCanopyNetFlux_dGroundTemp ! derivative in net canopy flux w.r.t. ground temperature (W m-2 K-1) + real(summa_prec),intent(out) :: dGroundNetFlux_dCanairTemp ! derivative in net ground flux w.r.t. canopy air temperature (W m-2 K-1) + real(summa_prec),intent(out) :: dGroundNetFlux_dCanopyTemp ! derivative in net ground flux w.r.t. canopy temperature (W m-2 K-1) + real(summa_prec),intent(out) :: dGroundNetFlux_dGroundTemp ! derivative in net ground flux w.r.t. ground temperature (W m-2 K-1) ! output: liquid flux derivatives (canopy evap) - real(dp),intent(out) :: dCanopyEvaporation_dCanLiq ! derivative in canopy evaporation w.r.t. canopy liquid water content (s-1) - real(dp),intent(out) :: dCanopyEvaporation_dTCanair ! derivative in canopy evaporation w.r.t. canopy air temperature (kg m-2 s-1 K-1) - real(dp),intent(out) :: dCanopyEvaporation_dTCanopy ! derivative in canopy evaporation w.r.t. canopy temperature (kg m-2 s-1 K-1) - real(dp),intent(out) :: dCanopyEvaporation_dTGround ! derivative in canopy evaporation w.r.t. ground temperature (kg m-2 s-1 K-1) + real(summa_prec),intent(out) :: dCanopyEvaporation_dCanLiq ! derivative in canopy evaporation w.r.t. canopy liquid water content (s-1) + real(summa_prec),intent(out) :: dCanopyEvaporation_dTCanair ! derivative in canopy evaporation w.r.t. canopy air temperature (kg m-2 s-1 K-1) + real(summa_prec),intent(out) :: dCanopyEvaporation_dTCanopy ! derivative in canopy evaporation w.r.t. canopy temperature (kg m-2 s-1 K-1) + real(summa_prec),intent(out) :: dCanopyEvaporation_dTGround ! derivative in canopy evaporation w.r.t. ground temperature (kg m-2 s-1 K-1) ! output: liquid flux derivatives (ground evap) - real(dp),intent(out) :: dGroundEvaporation_dCanLiq ! derivative in ground evaporation w.r.t. canopy liquid water content (s-1) - real(dp),intent(out) :: dGroundEvaporation_dTCanair ! derivative in ground evaporation w.r.t. canopy air temperature (kg m-2 s-1 K-1) - real(dp),intent(out) :: dGroundEvaporation_dTCanopy ! derivative in ground evaporation w.r.t. canopy temperature (kg m-2 s-1 K-1) - real(dp),intent(out) :: dGroundEvaporation_dTGround ! derivative in ground evaporation w.r.t. ground temperature (kg m-2 s-1 K-1) + real(summa_prec),intent(out) :: dGroundEvaporation_dCanLiq ! derivative in ground evaporation w.r.t. canopy liquid water content (s-1) + real(summa_prec),intent(out) :: dGroundEvaporation_dTCanair ! derivative in ground evaporation w.r.t. canopy air temperature (kg m-2 s-1 K-1) + real(summa_prec),intent(out) :: dGroundEvaporation_dTCanopy ! derivative in ground evaporation w.r.t. canopy temperature (kg m-2 s-1 K-1) + real(summa_prec),intent(out) :: dGroundEvaporation_dTGround ! derivative in ground evaporation w.r.t. ground temperature (kg m-2 s-1 K-1) ! output: cross derivative terms - real(dp),intent(out) :: dCanopyNetFlux_dCanLiq ! derivative in net canopy fluxes w.r.t. canopy liquid water content (J kg-1 s-1) - real(dp),intent(out) :: dGroundNetFlux_dCanLiq ! derivative in net ground fluxes w.r.t. canopy liquid water content (J kg-1 s-1) + real(summa_prec),intent(out) :: dCanopyNetFlux_dCanLiq ! derivative in net canopy fluxes w.r.t. canopy liquid water content (J kg-1 s-1) + real(summa_prec),intent(out) :: dGroundNetFlux_dCanLiq ! derivative in net ground fluxes w.r.t. canopy liquid water content (J kg-1 s-1) ! output: error control integer(i4b),intent(out) :: err ! error code @@ -280,10 +280,10 @@ subroutine vegNrgFlux(& ! --------------------------------------------------------------------------------------- ! local (general) character(LEN=256) :: cmessage ! error message of downwind routine - real(dp) :: VAI ! vegetation area index (m2 m-2) - real(dp) :: exposedVAI ! exposed vegetation area index (m2 m-2) - real(dp) :: totalCanopyWater ! total water on the vegetation canopy (kg m-2) - real(dp) :: scalarAquiferStorage ! aquifer storage (m) + real(summa_prec) :: VAI ! vegetation area index (m2 m-2) + real(summa_prec) :: exposedVAI ! exposed vegetation area index (m2 m-2) + real(summa_prec) :: totalCanopyWater ! total water on the vegetation canopy (kg m-2) + real(summa_prec) :: scalarAquiferStorage ! aquifer storage (m) ! local (compute numerical derivatives) integer(i4b),parameter :: unperturbed=1 ! named variable to identify the case of unperturbed state variables @@ -293,135 +293,135 @@ subroutine vegNrgFlux(& integer(i4b),parameter :: perturbStateCanLiq=5 ! named variable to identify the case where we perturb the canopy liquid water content integer(i4b) :: itry ! index of flux evaluation integer(i4b) :: nFlux ! number of flux evaluations - real(dp) :: groundTemp ! value of ground temperature used in flux calculations (may be perturbed) - real(dp) :: canopyTemp ! value of canopy temperature used in flux calculations (may be perturbed) - real(dp) :: canairTemp ! value of canopy air temperature used in flux calculations (may be perturbed) - real(dp) :: try0,try1 ! trial values to evaluate specific derivatives (testing only) + real(summa_prec) :: groundTemp ! value of ground temperature used in flux calculations (may be perturbed) + real(summa_prec) :: canopyTemp ! value of canopy temperature used in flux calculations (may be perturbed) + real(summa_prec) :: canairTemp ! value of canopy air temperature used in flux calculations (may be perturbed) + real(summa_prec) :: try0,try1 ! trial values to evaluate specific derivatives (testing only) ! local (saturation vapor pressure of veg) - real(dp) :: TV_celcius ! vegetaion temperature (C) - real(dp) :: TG_celcius ! ground temperature (C) - real(dp) :: dSVPCanopy_dCanopyTemp ! derivative in canopy saturated vapor pressure w.r.t. vegetation temperature (Pa/K) - real(dp) :: dSVPGround_dGroundTemp ! derivative in ground saturated vapor pressure w.r.t. ground temperature (Pa/K) + real(summa_prec) :: TV_celcius ! vegetaion temperature (C) + real(summa_prec) :: TG_celcius ! ground temperature (C) + real(summa_prec) :: dSVPCanopy_dCanopyTemp ! derivative in canopy saturated vapor pressure w.r.t. vegetation temperature (Pa/K) + real(summa_prec) :: dSVPGround_dGroundTemp ! derivative in ground saturated vapor pressure w.r.t. ground temperature (Pa/K) ! local (wetted canopy area) - real(dp) :: fracLiquidCanopy ! fraction of liquid water in the canopy (-) - real(dp) :: canopyWetFraction ! trial value of the canopy wetted fraction (-) - real(dp) :: dCanopyWetFraction_dWat ! derivative in wetted fraction w.r.t. canopy total water (kg-1 m2) - real(dp) :: dCanopyWetFraction_dT ! derivative in wetted fraction w.r.t. canopy temperature (K-1) + real(summa_prec) :: fracLiquidCanopy ! fraction of liquid water in the canopy (-) + real(summa_prec) :: canopyWetFraction ! trial value of the canopy wetted fraction (-) + real(summa_prec) :: dCanopyWetFraction_dWat ! derivative in wetted fraction w.r.t. canopy total water (kg-1 m2) + real(summa_prec) :: dCanopyWetFraction_dT ! derivative in wetted fraction w.r.t. canopy temperature (K-1) ! local (longwave radiation) - real(dp) :: expi ! exponential integral - real(dp) :: scaleLAI ! scaled LAI (computing diffuse transmissivity) - real(dp) :: diffuseTrans ! diffuse transmissivity (-) - real(dp) :: groundEmissivity ! emissivity of the ground surface (-) - real(dp),parameter :: vegEmissivity=0.98_dp ! emissivity of vegetation (0.9665 in JULES) (-) - real(dp),parameter :: soilEmissivity=0.98_dp ! emmisivity of the soil (0.9665 in JULES) (-) - real(dp),parameter :: snowEmissivity=0.99_dp ! emissivity of snow (-) - real(dp) :: dLWNetCanopy_dTCanopy ! derivative in net canopy radiation w.r.t. canopy temperature (W m-2 K-1) - real(dp) :: dLWNetGround_dTGround ! derivative in net ground radiation w.r.t. ground temperature (W m-2 K-1) - real(dp) :: dLWNetCanopy_dTGround ! derivative in net canopy radiation w.r.t. ground temperature (W m-2 K-1) - real(dp) :: dLWNetGround_dTCanopy ! derivative in net ground radiation w.r.t. canopy temperature (W m-2 K-1) + real(summa_prec) :: expi ! exponential integral + real(summa_prec) :: scaleLAI ! scaled LAI (computing diffuse transmissivity) + real(summa_prec) :: diffuseTrans ! diffuse transmissivity (-) + real(summa_prec) :: groundEmissivity ! emissivity of the ground surface (-) + real(summa_prec),parameter :: vegEmissivity=0.98_summa_prec ! emissivity of vegetation (0.9665 in JULES) (-) + real(summa_prec),parameter :: soilEmissivity=0.98_summa_prec ! emmisivity of the soil (0.9665 in JULES) (-) + real(summa_prec),parameter :: snowEmissivity=0.99_summa_prec ! emissivity of snow (-) + real(summa_prec) :: dLWNetCanopy_dTCanopy ! derivative in net canopy radiation w.r.t. canopy temperature (W m-2 K-1) + real(summa_prec) :: dLWNetGround_dTGround ! derivative in net ground radiation w.r.t. ground temperature (W m-2 K-1) + real(summa_prec) :: dLWNetCanopy_dTGround ! derivative in net canopy radiation w.r.t. ground temperature (W m-2 K-1) + real(summa_prec) :: dLWNetGround_dTCanopy ! derivative in net ground radiation w.r.t. canopy temperature (W m-2 K-1) ! local (aerodynamic resistance) - real(dp) :: scalarCanopyStabilityCorrection_old ! stability correction for the canopy (-) - real(dp) :: scalarGroundStabilityCorrection_old ! stability correction for the ground surface (-) + real(summa_prec) :: scalarCanopyStabilityCorrection_old ! stability correction for the canopy (-) + real(summa_prec) :: scalarGroundStabilityCorrection_old ! stability correction for the ground surface (-) ! local (turbulent heat transfer) - real(dp) :: z0Ground ! roughness length of the ground (ground below the canopy or non-vegetated surface) (m) - real(dp) :: soilEvapFactor ! soil water control on evaporation from non-vegetated surfaces - real(dp) :: soilRelHumidity_noSnow ! relative humidity in the soil pores [0-1] - real(dp) :: scalarLeafConductance ! leaf conductance (m s-1) - real(dp) :: scalarCanopyConductance ! canopy conductance (m s-1) - real(dp) :: scalarGroundConductanceSH ! ground conductance for sensible heat (m s-1) - real(dp) :: scalarGroundConductanceLH ! ground conductance for latent heat -- includes soil resistance (m s-1) - real(dp) :: scalarEvapConductance ! conductance for evaporation (m s-1) - real(dp) :: scalarTransConductance ! conductance for transpiration (m s-1) - real(dp) :: scalarTotalConductanceSH ! total conductance for sensible heat (m s-1) - real(dp) :: scalarTotalConductanceLH ! total conductance for latent heat (m s-1) - real(dp) :: dGroundResistance_dTGround ! derivative in ground resistance w.r.t. ground temperature (s m-1 K-1) - real(dp) :: dGroundResistance_dTCanopy ! derivative in ground resistance w.r.t. canopy temperature (s m-1 K-1) - real(dp) :: dGroundResistance_dTCanair ! derivative in ground resistance w.r.t. canopy air temperature (s m-1 K-1) - real(dp) :: dCanopyResistance_dTCanopy ! derivative in canopy resistance w.r.t. canopy temperature (s m-1 K-1) - real(dp) :: dCanopyResistance_dTCanair ! derivative in canopy resistance w.r.t. canopy air temperature (s m-1 K-1) - real(dp) :: turbFluxCanair ! total turbulent heat fluxes exchanged at the canopy air space (W m-2) - real(dp) :: turbFluxCanopy ! total turbulent heat fluxes from the canopy to the canopy air space (W m-2) - real(dp) :: turbFluxGround ! total turbulent heat fluxes from the ground to the canopy air space (W m-2) + real(summa_prec) :: z0Ground ! roughness length of the ground (ground below the canopy or non-vegetated surface) (m) + real(summa_prec) :: soilEvapFactor ! soil water control on evaporation from non-vegetated surfaces + real(summa_prec) :: soilRelHumidity_noSnow ! relative humidity in the soil pores [0-1] + real(summa_prec) :: scalarLeafConductance ! leaf conductance (m s-1) + real(summa_prec) :: scalarCanopyConductance ! canopy conductance (m s-1) + real(summa_prec) :: scalarGroundConductanceSH ! ground conductance for sensible heat (m s-1) + real(summa_prec) :: scalarGroundConductanceLH ! ground conductance for latent heat -- includes soil resistance (m s-1) + real(summa_prec) :: scalarEvapConductance ! conductance for evaporation (m s-1) + real(summa_prec) :: scalarTransConductance ! conductance for transpiration (m s-1) + real(summa_prec) :: scalarTotalConductanceSH ! total conductance for sensible heat (m s-1) + real(summa_prec) :: scalarTotalConductanceLH ! total conductance for latent heat (m s-1) + real(summa_prec) :: dGroundResistance_dTGround ! derivative in ground resistance w.r.t. ground temperature (s m-1 K-1) + real(summa_prec) :: dGroundResistance_dTCanopy ! derivative in ground resistance w.r.t. canopy temperature (s m-1 K-1) + real(summa_prec) :: dGroundResistance_dTCanair ! derivative in ground resistance w.r.t. canopy air temperature (s m-1 K-1) + real(summa_prec) :: dCanopyResistance_dTCanopy ! derivative in canopy resistance w.r.t. canopy temperature (s m-1 K-1) + real(summa_prec) :: dCanopyResistance_dTCanair ! derivative in canopy resistance w.r.t. canopy air temperature (s m-1 K-1) + real(summa_prec) :: turbFluxCanair ! total turbulent heat fluxes exchanged at the canopy air space (W m-2) + real(summa_prec) :: turbFluxCanopy ! total turbulent heat fluxes from the canopy to the canopy air space (W m-2) + real(summa_prec) :: turbFluxGround ! total turbulent heat fluxes from the ground to the canopy air space (W m-2) ! local (turbulent heat transfer -- compute numerical derivatives) ! (temporary scalar resistances when states are perturbed) - real(dp) :: trialLeafResistance ! mean leaf boundary layer resistance per unit leaf area (s m-1) - real(dp) :: trialGroundResistance ! below canopy aerodynamic resistance (s m-1) - real(dp) :: trialCanopyResistance ! above canopy aerodynamic resistance (s m-1) - real(dp) :: notUsed_RiBulkCanopy ! bulk Richardson number for the canopy (-) - real(dp) :: notUsed_RiBulkGround ! bulk Richardson number for the ground surface (-) - real(dp) :: notUsed_z0Canopy ! roughness length of the vegetation canopy (m) - real(dp) :: notUsed_WindReductionFactor ! canopy wind reduction factor (-) - real(dp) :: notUsed_ZeroPlaneDisplacement ! zero plane displacement (m) - real(dp) :: notUsed_scalarCanopyStabilityCorrection ! stability correction for the canopy (-) - real(dp) :: notUsed_scalarGroundStabilityCorrection ! stability correction for the ground surface (-) - real(dp) :: notUsed_EddyDiffusCanopyTop ! eddy diffusivity for heat at the top of the canopy (m2 s-1) - real(dp) :: notUsed_FrictionVelocity ! friction velocity (m s-1) - real(dp) :: notUsed_WindspdCanopyTop ! windspeed at the top of the canopy (m s-1) - real(dp) :: notUsed_WindspdCanopyBottom ! windspeed at the height of the bottom of the canopy (m s-1) - real(dp) :: notUsed_dGroundResistance_dTGround ! derivative in ground resistance w.r.t. ground temperature (s m-1 K-1) - real(dp) :: notUsed_dGroundResistance_dTCanopy ! derivative in ground resistance w.r.t. canopy temperature (s m-1 K-1) - real(dp) :: notUsed_dGroundResistance_dTCanair ! derivative in ground resistance w.r.t. canopy air temperature (s m-1 K-1) - real(dp) :: notUsed_dCanopyResistance_dTCanopy ! derivative in canopy resistance w.r.t. canopy temperature (s m-1 K-1) - real(dp) :: notUsed_dCanopyResistance_dTCanair ! derivative in canopy resistance w.r.t. canopy air temperature (s m-1 K-1) + real(summa_prec) :: trialLeafResistance ! mean leaf boundary layer resistance per unit leaf area (s m-1) + real(summa_prec) :: trialGroundResistance ! below canopy aerodynamic resistance (s m-1) + real(summa_prec) :: trialCanopyResistance ! above canopy aerodynamic resistance (s m-1) + real(summa_prec) :: notUsed_RiBulkCanopy ! bulk Richardson number for the canopy (-) + real(summa_prec) :: notUsed_RiBulkGround ! bulk Richardson number for the ground surface (-) + real(summa_prec) :: notUsed_z0Canopy ! roughness length of the vegetation canopy (m) + real(summa_prec) :: notUsed_WindReductionFactor ! canopy wind reduction factor (-) + real(summa_prec) :: notUsed_ZeroPlaneDisplacement ! zero plane displacement (m) + real(summa_prec) :: notUsed_scalarCanopyStabilityCorrection ! stability correction for the canopy (-) + real(summa_prec) :: notUsed_scalarGroundStabilityCorrection ! stability correction for the ground surface (-) + real(summa_prec) :: notUsed_EddyDiffusCanopyTop ! eddy diffusivity for heat at the top of the canopy (m2 s-1) + real(summa_prec) :: notUsed_FrictionVelocity ! friction velocity (m s-1) + real(summa_prec) :: notUsed_WindspdCanopyTop ! windspeed at the top of the canopy (m s-1) + real(summa_prec) :: notUsed_WindspdCanopyBottom ! windspeed at the height of the bottom of the canopy (m s-1) + real(summa_prec) :: notUsed_dGroundResistance_dTGround ! derivative in ground resistance w.r.t. ground temperature (s m-1 K-1) + real(summa_prec) :: notUsed_dGroundResistance_dTCanopy ! derivative in ground resistance w.r.t. canopy temperature (s m-1 K-1) + real(summa_prec) :: notUsed_dGroundResistance_dTCanair ! derivative in ground resistance w.r.t. canopy air temperature (s m-1 K-1) + real(summa_prec) :: notUsed_dCanopyResistance_dTCanopy ! derivative in canopy resistance w.r.t. canopy temperature (s m-1 K-1) + real(summa_prec) :: notUsed_dCanopyResistance_dTCanair ! derivative in canopy resistance w.r.t. canopy air temperature (s m-1 K-1) ! (fluxes after perturbations in model states -- canopy air space) - real(dp) :: turbFluxCanair_dStateCanair ! turbulent exchange from the canopy air space to the atmosphere, after canopy air temperature is perturbed (W m-2) - real(dp) :: turbFluxCanair_dStateCanopy ! turbulent exchange from the canopy air space to the atmosphere, after canopy temperature is perturbed (W m-2) - real(dp) :: turbFluxCanair_dStateGround ! turbulent exchange from the canopy air space to the atmosphere, after ground temperature is perturbed (W m-2) - real(dp) :: turbFluxCanair_dStateCanliq ! turbulent exchange from the canopy air space to the atmosphere, after canopy liquid water content is perturbed (W m-2) + real(summa_prec) :: turbFluxCanair_dStateCanair ! turbulent exchange from the canopy air space to the atmosphere, after canopy air temperature is perturbed (W m-2) + real(summa_prec) :: turbFluxCanair_dStateCanopy ! turbulent exchange from the canopy air space to the atmosphere, after canopy temperature is perturbed (W m-2) + real(summa_prec) :: turbFluxCanair_dStateGround ! turbulent exchange from the canopy air space to the atmosphere, after ground temperature is perturbed (W m-2) + real(summa_prec) :: turbFluxCanair_dStateCanliq ! turbulent exchange from the canopy air space to the atmosphere, after canopy liquid water content is perturbed (W m-2) ! (fluxes after perturbations in model states -- vegetation canopy) - real(dp) :: turbFluxCanopy_dStateCanair ! total turbulent heat fluxes from the canopy to the canopy air space, after canopy air temperature is perturbed (W m-2) - real(dp) :: turbFluxCanopy_dStateCanopy ! total turbulent heat fluxes from the canopy to the canopy air space, after canopy temperature is perturbed (W m-2) - real(dp) :: turbFluxCanopy_dStateGround ! total turbulent heat fluxes from the canopy to the canopy air space, after ground temperature is perturbed (W m-2) - real(dp) :: turbFluxCanopy_dStateCanLiq ! total turbulent heat fluxes from the canopy to the canopy air space, after canopy liquid water content is perturbed (W m-2) + real(summa_prec) :: turbFluxCanopy_dStateCanair ! total turbulent heat fluxes from the canopy to the canopy air space, after canopy air temperature is perturbed (W m-2) + real(summa_prec) :: turbFluxCanopy_dStateCanopy ! total turbulent heat fluxes from the canopy to the canopy air space, after canopy temperature is perturbed (W m-2) + real(summa_prec) :: turbFluxCanopy_dStateGround ! total turbulent heat fluxes from the canopy to the canopy air space, after ground temperature is perturbed (W m-2) + real(summa_prec) :: turbFluxCanopy_dStateCanLiq ! total turbulent heat fluxes from the canopy to the canopy air space, after canopy liquid water content is perturbed (W m-2) ! (fluxes after perturbations in model states -- ground surface) - real(dp) :: turbFluxGround_dStateCanair ! total turbulent heat fluxes from the ground to the canopy air space, after canopy air temperature is perturbed (W m-2) - real(dp) :: turbFluxGround_dStateCanopy ! total turbulent heat fluxes from the ground to the canopy air space, after canopy temperature is perturbed (W m-2) - real(dp) :: turbFluxGround_dStateGround ! total turbulent heat fluxes from the ground to the canopy air space, after ground temperature is perturbed (W m-2) - real(dp) :: turbFluxGround_dStateCanLiq ! total turbulent heat fluxes from the ground to the canopy air space, after canopy liquid water content is perturbed (W m-2) + real(summa_prec) :: turbFluxGround_dStateCanair ! total turbulent heat fluxes from the ground to the canopy air space, after canopy air temperature is perturbed (W m-2) + real(summa_prec) :: turbFluxGround_dStateCanopy ! total turbulent heat fluxes from the ground to the canopy air space, after canopy temperature is perturbed (W m-2) + real(summa_prec) :: turbFluxGround_dStateGround ! total turbulent heat fluxes from the ground to the canopy air space, after ground temperature is perturbed (W m-2) + real(summa_prec) :: turbFluxGround_dStateCanLiq ! total turbulent heat fluxes from the ground to the canopy air space, after canopy liquid water content is perturbed (W m-2) ! (fluxes after perturbations in model states -- canopy evaporation) - real(dp) :: latHeatCanEvap_dStateCanair ! canopy evaporation after canopy air temperature is perturbed (W m-2) - real(dp) :: latHeatCanEvap_dStateCanopy ! canopy evaporation after canopy temperature is perturbed (W m-2) - real(dp) :: latHeatCanEvap_dStateGround ! canopy evaporation after ground temperature is perturbed (W m-2) - real(dp) :: latHeatCanEvap_dStateCanLiq ! canopy evaporation after canopy liquid water content is perturbed (W m-2) + real(summa_prec) :: latHeatCanEvap_dStateCanair ! canopy evaporation after canopy air temperature is perturbed (W m-2) + real(summa_prec) :: latHeatCanEvap_dStateCanopy ! canopy evaporation after canopy temperature is perturbed (W m-2) + real(summa_prec) :: latHeatCanEvap_dStateGround ! canopy evaporation after ground temperature is perturbed (W m-2) + real(summa_prec) :: latHeatCanEvap_dStateCanLiq ! canopy evaporation after canopy liquid water content is perturbed (W m-2) ! (flux derivatives -- canopy air space) - real(dp) :: dTurbFluxCanair_dTCanair ! derivative in net canopy air space fluxes w.r.t. canopy air temperature (W m-2 K-1) - real(dp) :: dTurbFluxCanair_dTCanopy ! derivative in net canopy air space fluxes w.r.t. canopy temperature (W m-2 K-1) - real(dp) :: dTurbFluxCanair_dTGround ! derivative in net canopy air space fluxes w.r.t. ground temperature (W m-2 K-1) - real(dp) :: dTurbFluxCanair_dCanLiq ! derivative in net canopy air space fluxes w.r.t. canopy liquid water content (J kg-1 s-1) + real(summa_prec) :: dTurbFluxCanair_dTCanair ! derivative in net canopy air space fluxes w.r.t. canopy air temperature (W m-2 K-1) + real(summa_prec) :: dTurbFluxCanair_dTCanopy ! derivative in net canopy air space fluxes w.r.t. canopy temperature (W m-2 K-1) + real(summa_prec) :: dTurbFluxCanair_dTGround ! derivative in net canopy air space fluxes w.r.t. ground temperature (W m-2 K-1) + real(summa_prec) :: dTurbFluxCanair_dCanLiq ! derivative in net canopy air space fluxes w.r.t. canopy liquid water content (J kg-1 s-1) ! (flux derivatives -- vegetation canopy) - real(dp) :: dTurbFluxCanopy_dTCanair ! derivative in net canopy turbulent fluxes w.r.t. canopy air temperature (W m-2 K-1) - real(dp) :: dTurbFluxCanopy_dTCanopy ! derivative in net canopy turbulent fluxes w.r.t. canopy temperature (W m-2 K-1) - real(dp) :: dTurbFluxCanopy_dTGround ! derivative in net canopy turbulent fluxes w.r.t. ground temperature (W m-2 K-1) - real(dp) :: dTurbFluxCanopy_dCanLiq ! derivative in net canopy turbulent fluxes w.r.t. canopy liquid water content (J kg-1 s-1) + real(summa_prec) :: dTurbFluxCanopy_dTCanair ! derivative in net canopy turbulent fluxes w.r.t. canopy air temperature (W m-2 K-1) + real(summa_prec) :: dTurbFluxCanopy_dTCanopy ! derivative in net canopy turbulent fluxes w.r.t. canopy temperature (W m-2 K-1) + real(summa_prec) :: dTurbFluxCanopy_dTGround ! derivative in net canopy turbulent fluxes w.r.t. ground temperature (W m-2 K-1) + real(summa_prec) :: dTurbFluxCanopy_dCanLiq ! derivative in net canopy turbulent fluxes w.r.t. canopy liquid water content (J kg-1 s-1) ! (flux derivatives -- ground surface) - real(dp) :: dTurbFluxGround_dTCanair ! derivative in net ground turbulent fluxes w.r.t. canopy air temperature (W m-2 K-1) - real(dp) :: dTurbFluxGround_dTCanopy ! derivative in net ground turbulent fluxes w.r.t. canopy temperature (W m-2 K-1) - real(dp) :: dTurbFluxGround_dTGround ! derivative in net ground turbulent fluxes w.r.t. ground temperature (W m-2 K-1) - real(dp) :: dTurbFluxGround_dCanLiq ! derivative in net ground turbulent fluxes w.r.t. canopy liquid water content (J kg-1 s-1) + real(summa_prec) :: dTurbFluxGround_dTCanair ! derivative in net ground turbulent fluxes w.r.t. canopy air temperature (W m-2 K-1) + real(summa_prec) :: dTurbFluxGround_dTCanopy ! derivative in net ground turbulent fluxes w.r.t. canopy temperature (W m-2 K-1) + real(summa_prec) :: dTurbFluxGround_dTGround ! derivative in net ground turbulent fluxes w.r.t. ground temperature (W m-2 K-1) + real(summa_prec) :: dTurbFluxGround_dCanLiq ! derivative in net ground turbulent fluxes w.r.t. canopy liquid water content (J kg-1 s-1) ! (liquid water flux derivatives -- canopy evap) - real(dp) :: dLatHeatCanopyEvap_dCanLiq ! derivative in latent heat of canopy evaporation w.r.t. canopy liquid water content (W kg-1) - real(dp) :: dLatHeatCanopyEvap_dTCanair ! derivative in latent heat of canopy evaporation w.r.t. canopy air temperature (W m-2 K-1) - real(dp) :: dLatHeatCanopyEvap_dTCanopy ! derivative in latent heat of canopy evaporation w.r.t. canopy temperature (W m-2 K-1) - real(dp) :: dLatHeatCanopyEvap_dTGround ! derivative in latent heat of canopy evaporation w.r.t. ground temperature (W m-2 K-1) + real(summa_prec) :: dLatHeatCanopyEvap_dCanLiq ! derivative in latent heat of canopy evaporation w.r.t. canopy liquid water content (W kg-1) + real(summa_prec) :: dLatHeatCanopyEvap_dTCanair ! derivative in latent heat of canopy evaporation w.r.t. canopy air temperature (W m-2 K-1) + real(summa_prec) :: dLatHeatCanopyEvap_dTCanopy ! derivative in latent heat of canopy evaporation w.r.t. canopy temperature (W m-2 K-1) + real(summa_prec) :: dLatHeatCanopyEvap_dTGround ! derivative in latent heat of canopy evaporation w.r.t. ground temperature (W m-2 K-1) ! (liquid water flux derivatives -- ground evap) - real(dp) :: dLatHeatGroundEvap_dCanLiq ! derivative in latent heat of ground evaporation w.r.t. canopy liquid water content (J kg-1 s-1) - real(dp) :: dLatHeatGroundEvap_dTCanair ! derivative in latent heat of ground evaporation w.r.t. canopy air temperature (W m-2 K-1) - real(dp) :: dLatHeatGroundEvap_dTCanopy ! derivative in latent heat of ground evaporation w.r.t. canopy temperature (W m-2 K-1) - real(dp) :: dLatHeatGroundEvap_dTGround ! derivative in latent heat of ground evaporation w.r.t. ground temperature (W m-2 K-1) + real(summa_prec) :: dLatHeatGroundEvap_dCanLiq ! derivative in latent heat of ground evaporation w.r.t. canopy liquid water content (J kg-1 s-1) + real(summa_prec) :: dLatHeatGroundEvap_dTCanair ! derivative in latent heat of ground evaporation w.r.t. canopy air temperature (W m-2 K-1) + real(summa_prec) :: dLatHeatGroundEvap_dTCanopy ! derivative in latent heat of ground evaporation w.r.t. canopy temperature (W m-2 K-1) + real(summa_prec) :: dLatHeatGroundEvap_dTGround ! derivative in latent heat of ground evaporation w.r.t. ground temperature (W m-2 K-1) ! --------------------------------------------------------------------------------------- ! point to variables in the data structure @@ -624,47 +624,47 @@ subroutine vegNrgFlux(& case(prescribedTemp,zeroFlux) ! derived fluxes - scalarTotalET = 0._dp ! total ET (kg m-2 s-1) - scalarNetRadiation = 0._dp ! net radiation (W m-2) + scalarTotalET = 0._summa_prec ! total ET (kg m-2 s-1) + scalarNetRadiation = 0._summa_prec ! net radiation (W m-2) ! liquid water fluxes associated with evaporation/transpiration - scalarCanopyTranspiration = 0._dp ! canopy transpiration (kg m-2 s-1) - scalarCanopyEvaporation = 0._dp ! canopy evaporation/condensation (kg m-2 s-1) - scalarGroundEvaporation = 0._dp ! ground evaporation/condensation -- below canopy or non-vegetated (kg m-2 s-1) + scalarCanopyTranspiration = 0._summa_prec ! canopy transpiration (kg m-2 s-1) + scalarCanopyEvaporation = 0._summa_prec ! canopy evaporation/condensation (kg m-2 s-1) + scalarGroundEvaporation = 0._summa_prec ! ground evaporation/condensation -- below canopy or non-vegetated (kg m-2 s-1) ! solid water fluxes associated with sublimation/frost - scalarCanopySublimation = 0._dp ! sublimation from the vegetation canopy ((kg m-2 s-1) - scalarSnowSublimation = 0._dp ! sublimation from the snow surface ((kg m-2 s-1) + scalarCanopySublimation = 0._summa_prec ! sublimation from the vegetation canopy ((kg m-2 s-1) + scalarSnowSublimation = 0._summa_prec ! sublimation from the snow surface ((kg m-2 s-1) ! set canopy fluxes to zero (no canopy) - canairNetFlux = 0._dp ! net energy flux for the canopy air space (W m-2) - canopyNetFlux = 0._dp ! net energy flux for the vegetation canopy (W m-2) + canairNetFlux = 0._summa_prec ! net energy flux for the canopy air space (W m-2) + canopyNetFlux = 0._summa_prec ! net energy flux for the vegetation canopy (W m-2) ! set canopy derivatives to zero - dCanairNetFlux_dCanairTemp = 0._dp ! derivative in net canopy air space flux w.r.t. canopy air temperature (W m-2 K-1) - dCanairNetFlux_dCanopyTemp = 0._dp ! derivative in net canopy air space flux w.r.t. canopy temperature (W m-2 K-1) - dCanairNetFlux_dGroundTemp = 0._dp ! derivative in net canopy air space flux w.r.t. ground temperature (W m-2 K-1) - dCanopyNetFlux_dCanairTemp = 0._dp ! derivative in net canopy flux w.r.t. canopy air temperature (W m-2 K-1) - dCanopyNetFlux_dCanopyTemp = 0._dp ! derivative in net canopy flux w.r.t. canopy temperature (W m-2 K-1) - dCanopyNetFlux_dGroundTemp = 0._dp ! derivative in net canopy flux w.r.t. ground temperature (W m-2 K-1) - dGroundNetFlux_dCanairTemp = 0._dp ! derivative in net ground flux w.r.t. canopy air temperature (W m-2 K-1) - dGroundNetFlux_dCanopyTemp = 0._dp ! derivative in net ground flux w.r.t. canopy temperature (W m-2 K-1) + dCanairNetFlux_dCanairTemp = 0._summa_prec ! derivative in net canopy air space flux w.r.t. canopy air temperature (W m-2 K-1) + dCanairNetFlux_dCanopyTemp = 0._summa_prec ! derivative in net canopy air space flux w.r.t. canopy temperature (W m-2 K-1) + dCanairNetFlux_dGroundTemp = 0._summa_prec ! derivative in net canopy air space flux w.r.t. ground temperature (W m-2 K-1) + dCanopyNetFlux_dCanairTemp = 0._summa_prec ! derivative in net canopy flux w.r.t. canopy air temperature (W m-2 K-1) + dCanopyNetFlux_dCanopyTemp = 0._summa_prec ! derivative in net canopy flux w.r.t. canopy temperature (W m-2 K-1) + dCanopyNetFlux_dGroundTemp = 0._summa_prec ! derivative in net canopy flux w.r.t. ground temperature (W m-2 K-1) + dGroundNetFlux_dCanairTemp = 0._summa_prec ! derivative in net ground flux w.r.t. canopy air temperature (W m-2 K-1) + dGroundNetFlux_dCanopyTemp = 0._summa_prec ! derivative in net ground flux w.r.t. canopy temperature (W m-2 K-1) ! set liquid flux derivatives to zero (canopy evap) - dCanopyEvaporation_dCanLiq = 0._dp ! derivative in canopy evaporation w.r.t. canopy liquid water content (s-1) - dCanopyEvaporation_dTCanair= 0._dp ! derivative in canopy evaporation w.r.t. canopy air temperature (kg m-2 s-1 K-1) - dCanopyEvaporation_dTCanopy= 0._dp ! derivative in canopy evaporation w.r.t. canopy temperature (kg m-2 s-1 K-1) - dCanopyEvaporation_dTGround= 0._dp ! derivative in canopy evaporation w.r.t. ground temperature (kg m-2 s-1 K-1) + dCanopyEvaporation_dCanLiq = 0._summa_prec ! derivative in canopy evaporation w.r.t. canopy liquid water content (s-1) + dCanopyEvaporation_dTCanair= 0._summa_prec ! derivative in canopy evaporation w.r.t. canopy air temperature (kg m-2 s-1 K-1) + dCanopyEvaporation_dTCanopy= 0._summa_prec ! derivative in canopy evaporation w.r.t. canopy temperature (kg m-2 s-1 K-1) + dCanopyEvaporation_dTGround= 0._summa_prec ! derivative in canopy evaporation w.r.t. ground temperature (kg m-2 s-1 K-1) ! set liquid flux derivatives to zero (ground evap) - dGroundEvaporation_dCanLiq = 0._dp ! derivative in ground evaporation w.r.t. canopy liquid water content (s-1) - dGroundEvaporation_dTCanair= 0._dp ! derivative in ground evaporation w.r.t. canopy air temperature (kg m-2 s-1 K-1) - dGroundEvaporation_dTCanopy= 0._dp ! derivative in ground evaporation w.r.t. canopy temperature (kg m-2 s-1 K-1) - dGroundEvaporation_dTGround= 0._dp ! derivative in ground evaporation w.r.t. ground temperature (kg m-2 s-1 K-1) + dGroundEvaporation_dCanLiq = 0._summa_prec ! derivative in ground evaporation w.r.t. canopy liquid water content (s-1) + dGroundEvaporation_dTCanair= 0._summa_prec ! derivative in ground evaporation w.r.t. canopy air temperature (kg m-2 s-1 K-1) + dGroundEvaporation_dTCanopy= 0._summa_prec ! derivative in ground evaporation w.r.t. canopy temperature (kg m-2 s-1 K-1) + dGroundEvaporation_dTGround= 0._summa_prec ! derivative in ground evaporation w.r.t. ground temperature (kg m-2 s-1 K-1) ! compute fluxes and derivatives -- separate approach for prescribed temperature and zero flux if(ix_bcUpprTdyn == prescribedTemp)then ! compute ground net flux (W m-2) - groundNetFlux = -diag_data%var(iLookDIAG%iLayerThermalC)%dat(0)*(groundTempTrial - upperBoundTemp)/(prog_data%var(iLookPROG%mLayerDepth)%dat(1)*0.5_dp) + groundNetFlux = -diag_data%var(iLookDIAG%iLayerThermalC)%dat(0)*(groundTempTrial - upperBoundTemp)/(prog_data%var(iLookPROG%mLayerDepth)%dat(1)*0.5_summa_prec) ! compute derivative in net ground flux w.r.t. ground temperature (W m-2 K-1) - dGroundNetFlux_dGroundTemp = -diag_data%var(iLookDIAG%iLayerThermalC)%dat(0)/(prog_data%var(iLookPROG%mLayerDepth)%dat(1)*0.5_dp) + dGroundNetFlux_dGroundTemp = -diag_data%var(iLookDIAG%iLayerThermalC)%dat(0)/(prog_data%var(iLookPROG%mLayerDepth)%dat(1)*0.5_summa_prec) elseif(model_decisions(iLookDECISIONS%bcUpprTdyn)%iDecision == zeroFlux)then - groundNetFlux = 0._dp - dGroundNetFlux_dGroundTemp = 0._dp + groundNetFlux = 0._summa_prec + dGroundNetFlux_dGroundTemp = 0._summa_prec else err=20; message=trim(message)//'unable to identify upper boundary condition for thermodynamics: expect the case to be prescribedTemp or zeroFlux'; return end if @@ -700,8 +700,8 @@ subroutine vegNrgFlux(& if(firstFluxCall .and. firstSubStep)then ! vapor pressure in the canopy air space initialized as vapor pressure of air above the vegetation canopy ! NOTE: this is needed for the stomatal resistance calculations - if(scalarVP_CanopyAir < 0._dp)then - scalarVP_CanopyAir = scalarVPair - 1._dp ! "small" offset used to assist in checking initial derivative calculations + if(scalarVP_CanopyAir < 0._summa_prec)then + scalarVP_CanopyAir = scalarVPair - 1._summa_prec ! "small" offset used to assist in checking initial derivative calculations end if end if @@ -713,17 +713,17 @@ subroutine vegNrgFlux(& if(nSnow > 0)then if(groundTempTrial > Tfreeze)then; err=20; message=trim(message)//'do not expect ground temperature > 0 when snow is on the ground'; return; end if scalarLatHeatSubVapGround = LH_sub ! sublimation from snow - scalarGroundSnowFraction = 1._dp + scalarGroundSnowFraction = 1._summa_prec ! case when the ground is snow-free else scalarLatHeatSubVapGround = LH_vap ! evaporation of water in the soil pores: this occurs even if frozen because of super-cooled water - scalarGroundSnowFraction = 0._dp + scalarGroundSnowFraction = 0._summa_prec end if ! (if there is snow on the ground) end if ! (if the first flux call) !write(*,'(a,1x,10(f30.10,1x))') 'groundTempTrial, scalarLatHeatSubVapGround = ', groundTempTrial, scalarLatHeatSubVapGround ! compute the roughness length of the ground (ground below the canopy or non-vegetated surface) - z0Ground = z0soil*(1._dp - scalarGroundSnowFraction) + z0Snow*scalarGroundSnowFraction ! roughness length (m) + z0Ground = z0soil*(1._summa_prec - scalarGroundSnowFraction) + z0Snow*scalarGroundSnowFraction ! roughness length (m) ! compute the total vegetation area index (leaf plus stem) VAI = scalarLAI + scalarSAI ! vegetation area index @@ -734,16 +734,16 @@ subroutine vegNrgFlux(& select case(ix_canopyEmis) ! *** simple exponential function case(simplExp) - scalarCanopyEmissivity = 1._dp - exp(-exposedVAI) ! effective emissivity of the canopy (-) + scalarCanopyEmissivity = 1._summa_prec - exp(-exposedVAI) ! effective emissivity of the canopy (-) ! *** canopy emissivity parameterized as a function of diffuse transmissivity case(difTrans) ! compute the exponential integral - scaleLAI = 0.5_dp*exposedVAI + scaleLAI = 0.5_summa_prec*exposedVAI expi = expInt(scaleLAI) ! compute diffuse transmissivity (-) - diffuseTrans = (1._dp - scaleLAI)*exp(-scaleLAI) + (scaleLAI**2._dp)*expi + diffuseTrans = (1._summa_prec - scaleLAI)*exp(-scaleLAI) + (scaleLAI**2._summa_prec)*expi ! compute the canopy emissivity - scalarCanopyEmissivity = (1._dp - diffuseTrans)*vegEmissivity + scalarCanopyEmissivity = (1._summa_prec - diffuseTrans)*vegEmissivity ! *** check we found the correct option case default err=20; message=trim(message)//'unable to identify option for canopy emissivity'; return @@ -751,10 +751,10 @@ subroutine vegNrgFlux(& end if ! ensure canopy longwave fluxes are zero when not computing canopy fluxes - if(.not.computeVegFlux) scalarCanopyEmissivity=0._dp + if(.not.computeVegFlux) scalarCanopyEmissivity=0._summa_prec ! compute emissivity of the ground surface (-) - groundEmissivity = scalarGroundSnowFraction*snowEmissivity + (1._dp - scalarGroundSnowFraction)*soilEmissivity ! emissivity of the ground surface (-) + groundEmissivity = scalarGroundSnowFraction*snowEmissivity + (1._summa_prec - scalarGroundSnowFraction)*soilEmissivity ! emissivity of the ground surface (-) ! compute the fraction of canopy that is wet ! NOTE: we either sublimate or evaporate over the entire substep @@ -762,10 +762,10 @@ subroutine vegNrgFlux(& ! compute the fraction of liquid water in the canopy (-) totalCanopyWater = canopyLiqTrial + canopyIceTrial - if(totalCanopyWater > tiny(1.0_dp))then + if(totalCanopyWater > tiny(1.0_summa_prec))then fracLiquidCanopy = canopyLiqTrial / (canopyLiqTrial + canopyIceTrial) else - fracLiquidCanopy = 0._dp + fracLiquidCanopy = 0._summa_prec end if ! get wetted fraction and derivatives @@ -790,9 +790,9 @@ subroutine vegNrgFlux(& if(err/=0)then; message=trim(message)//trim(cmessage); return; end if else - scalarCanopyWetFraction = 0._dp ! canopy wetted fraction (-) - dCanopyWetFraction_dWat = 0._dp ! derivative in wetted fraction w.r.t. canopy liquid water (kg-1 m2) - dCanopyWetFraction_dT = 0._dp ! derivative in wetted fraction w.r.t. canopy temperature (K-1) + scalarCanopyWetFraction = 0._summa_prec ! canopy wetted fraction (-) + dCanopyWetFraction_dWat = 0._summa_prec ! derivative in wetted fraction w.r.t. canopy liquid water (kg-1 m2) + dCanopyWetFraction_dT = 0._summa_prec ! derivative in wetted fraction w.r.t. canopy temperature (K-1) end if !write(*,'(a,1x,L1,1x,f25.15,1x))') 'computeVegFlux, scalarCanopyWetFraction = ', computeVegFlux, scalarCanopyWetFraction !print*, 'dCanopyWetFraction_dWat = ', dCanopyWetFraction_dWat @@ -1068,7 +1068,7 @@ subroutine vegNrgFlux(& if(err/=0)then; message=trim(message)//trim(cmessage); return; end if else - canopyWetFraction = 0._dp + canopyWetFraction = 0._summa_prec end if !print*, 'wetted fraction derivative = ', (canopyWetFraction - scalarCanopyWetFraction)/dx !pause @@ -1168,15 +1168,15 @@ subroutine vegNrgFlux(& ! (soil water evaporation factor [0-1]) soilEvapFactor = mLayerVolFracLiq(nSnow+1)/(theta_sat - theta_res) ! (resistance from the soil [s m-1]) - scalarSoilResistance = scalarGroundSnowFraction*1._dp + (1._dp - scalarGroundSnowFraction)*EXP(8.25_dp - 4.225_dp*soilEvapFactor) ! Sellers (1992) - !scalarSoilResistance = scalarGroundSnowFraction*0._dp + (1._dp - scalarGroundSnowFraction)*exp(8.25_dp - 6.0_dp*soilEvapFactor) ! Niu adjustment to decrease resitance for wet soil + scalarSoilResistance = scalarGroundSnowFraction*1._summa_prec + (1._summa_prec - scalarGroundSnowFraction)*EXP(8.25_summa_prec - 4.225_summa_prec*soilEvapFactor) ! Sellers (1992) + !scalarSoilResistance = scalarGroundSnowFraction*0._summa_prec + (1._summa_prec - scalarGroundSnowFraction)*exp(8.25_summa_prec - 6.0_summa_prec*soilEvapFactor) ! Niu adjustment to decrease resitance for wet soil ! (relative humidity in the soil pores [0-1]) - if(mLayerMatricHead(1) > -1.e+6_dp)then ! avoid problems with numerical precision when soil is very dry + if(mLayerMatricHead(1) > -1.e+6_summa_prec)then ! avoid problems with numerical precision when soil is very dry soilRelHumidity_noSnow = exp( (mLayerMatricHead(1)*gravity) / (groundTemp*R_wv) ) else - soilRelHumidity_noSnow = 0._dp + soilRelHumidity_noSnow = 0._summa_prec end if ! (if matric head is very low) - scalarSoilRelHumidity = scalarGroundSnowFraction*1._dp + (1._dp - scalarGroundSnowFraction)*soilRelHumidity_noSnow + scalarSoilRelHumidity = scalarGroundSnowFraction*1._summa_prec + (1._summa_prec - scalarGroundSnowFraction)*soilRelHumidity_noSnow !print*, 'mLayerMatricHead(1), scalarSoilRelHumidity = ', mLayerMatricHead(1), scalarSoilRelHumidity end if ! (if the first flux call) @@ -1396,21 +1396,21 @@ subroutine vegNrgFlux(& !print*, 'scalarLatHeatGround = ', scalarLatHeatGround ! (canopy transpiration/sublimation) if(scalarLatHeatSubVapCanopy > LH_vap+verySmall)then ! sublimation - scalarCanopyEvaporation = 0._dp + scalarCanopyEvaporation = 0._summa_prec scalarCanopySublimation = scalarLatHeatCanopyEvap/LH_sub - if(scalarLatHeatCanopyTrans > 0._dp)then ! flux directed towards the veg + if(scalarLatHeatCanopyTrans > 0._summa_prec)then ! flux directed towards the veg scalarCanopySublimation = scalarCanopySublimation + scalarLatHeatCanopyTrans/LH_sub ! frost - scalarCanopyTranspiration = 0._dp + scalarCanopyTranspiration = 0._summa_prec else scalarCanopyTranspiration = scalarLatHeatCanopyTrans/LH_vap ! transpiration is always vapor end if ! (canopy transpiration/evaporation) else ! evaporation scalarCanopyEvaporation = scalarLatHeatCanopyEvap/LH_vap - scalarCanopySublimation = 0._dp - if(scalarLatHeatCanopyTrans > 0._dp)then ! flux directed towards the veg + scalarCanopySublimation = 0._summa_prec + if(scalarLatHeatCanopyTrans > 0._summa_prec)then ! flux directed towards the veg scalarCanopyEvaporation = scalarCanopyEvaporation + scalarLatHeatCanopyTrans/LH_vap - scalarCanopyTranspiration = 0._dp + scalarCanopyTranspiration = 0._summa_prec else scalarCanopyTranspiration = scalarLatHeatCanopyTrans/LH_vap end if @@ -1419,13 +1419,13 @@ subroutine vegNrgFlux(& if(scalarLatHeatSubVapGround > LH_vap+verySmall)then ! sublimation ! NOTE: this should only occur when we have formed snow layers, so check if(nSnow == 0)then; err=20; message=trim(message)//'only expect snow sublimation when we have formed some snow layers'; return; end if - scalarGroundEvaporation = 0._dp ! ground evaporation is zero once the snowpack has formed + scalarGroundEvaporation = 0._summa_prec ! ground evaporation is zero once the snowpack has formed scalarSnowSublimation = scalarLatHeatGround/LH_sub else ! NOTE: this should only occur when we have no snow layers, so check if(nSnow > 0)then; err=20; message=trim(message)//'only expect ground evaporation when there are no snow layers'; return; end if scalarGroundEvaporation = scalarLatHeatGround/LH_vap - scalarSnowSublimation = 0._dp ! no sublimation from snow if no snow layers have formed + scalarSnowSublimation = 0._summa_prec ! no sublimation from snow if no snow layers have formed end if !print*, 'scalarSnowSublimation, scalarLatHeatGround = ', scalarSnowSublimation, scalarLatHeatGround @@ -1472,10 +1472,10 @@ subroutine vegNrgFlux(& ! sublimation else - dCanopyEvaporation_dCanLiq = 0._dp ! (s-1) - dCanopyEvaporation_dTCanair = 0._dp ! (kg m-2 s-1 K-1) - dCanopyEvaporation_dTCanopy = 0._dp ! (kg m-2 s-1 K-1) - dCanopyEvaporation_dTGround = 0._dp ! (kg m-2 s-1 K-1) + dCanopyEvaporation_dCanLiq = 0._summa_prec ! (s-1) + dCanopyEvaporation_dTCanair = 0._summa_prec ! (kg m-2 s-1 K-1) + dCanopyEvaporation_dTCanopy = 0._summa_prec ! (kg m-2 s-1 K-1) + dCanopyEvaporation_dTGround = 0._summa_prec ! (kg m-2 s-1 K-1) end if ! compute the liquid water derivarives (ground evap) @@ -1542,25 +1542,25 @@ subroutine wettedFrac(& logical(lgt),intent(in) :: deriv ! flag to denote if derivative is desired logical(lgt),intent(in) :: derNum ! flag to denote that numerical derivatives are required (otherwise, analytical derivatives are calculated) logical(lgt),intent(in) :: frozen ! flag to denote if the canopy is frozen - real(dp),intent(in) :: dLiq_dT ! derivative in canopy liquid w.r.t. canopy temperature (kg m-2 K-1) - real(dp),intent(in) :: fracLiq ! fraction of liquid water on the canopy (-) - real(dp),intent(in) :: canopyLiq ! canopy liquid water (kg m-2) - real(dp),intent(in) :: canopyIce ! canopy ice (kg m-2) - real(dp),intent(in) :: canopyLiqMax ! maximum canopy liquid water (kg m-2) - real(dp),intent(in) :: canopyIceMax ! maximum canopy ice content (kg m-2) - real(dp),intent(in) :: canopyWettingFactor ! maximum wetted fraction of the canopy (-) - real(dp),intent(in) :: canopyWettingExp ! exponent in canopy wetting function (-) + real(summa_prec),intent(in) :: dLiq_dT ! derivative in canopy liquid w.r.t. canopy temperature (kg m-2 K-1) + real(summa_prec),intent(in) :: fracLiq ! fraction of liquid water on the canopy (-) + real(summa_prec),intent(in) :: canopyLiq ! canopy liquid water (kg m-2) + real(summa_prec),intent(in) :: canopyIce ! canopy ice (kg m-2) + real(summa_prec),intent(in) :: canopyLiqMax ! maximum canopy liquid water (kg m-2) + real(summa_prec),intent(in) :: canopyIceMax ! maximum canopy ice content (kg m-2) + real(summa_prec),intent(in) :: canopyWettingFactor ! maximum wetted fraction of the canopy (-) + real(summa_prec),intent(in) :: canopyWettingExp ! exponent in canopy wetting function (-) ! output - real(dp),intent(out) :: canopyWetFraction ! canopy wetted fraction (-) - real(dp),intent(out) :: dCanopyWetFraction_dWat ! derivative in wetted fraction w.r.t. canopy total water (kg-1 m2) - real(dp),intent(out) :: dCanopyWetFraction_dT ! derivative in wetted fraction w.r.t. canopy temperature (K-1) + real(summa_prec),intent(out) :: canopyWetFraction ! canopy wetted fraction (-) + real(summa_prec),intent(out) :: dCanopyWetFraction_dWat ! derivative in wetted fraction w.r.t. canopy total water (kg-1 m2) + real(summa_prec),intent(out) :: dCanopyWetFraction_dT ! derivative in wetted fraction w.r.t. canopy temperature (K-1) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! local variables logical(lgt),parameter :: smoothing=.true. ! flag to denote that smoothing is required - real(dp) :: canopyWetFractionPert ! canopy wetted fraction after state perturbations (-) - real(dp) :: canopyWetFractionDeriv ! derivative in wetted fraction w.r.t. canopy liquid water (kg-1 m2) + real(summa_prec) :: canopyWetFractionPert ! canopy wetted fraction after state perturbations (-) + real(summa_prec) :: canopyWetFractionDeriv ! derivative in wetted fraction w.r.t. canopy liquid water (kg-1 m2) ! ----------------------------------------------------------------------------------------------------------------------------------------------- ! initialize error control err=0; message='wettedFrac/' @@ -1575,14 +1575,14 @@ subroutine wettedFrac(& canopyWetFractionDeriv = (canopyWetFractionPert - canopyWetFraction)/dx end if ! scale derivative by the fraction of water - ! NOTE: dIce/dWat = (1._dp - fracLiq), hence dWet/dWat = dIce/dWat . dWet/dLiq - dCanopyWetFraction_dWat = canopyWetFractionDeriv*(1._dp - fracLiq) + ! NOTE: dIce/dWat = (1._summa_prec - fracLiq), hence dWet/dWat = dIce/dWat . dWet/dLiq + dCanopyWetFraction_dWat = canopyWetFractionDeriv*(1._summa_prec - fracLiq) dCanopyWetFraction_dT = -canopyWetFractionDeriv*dLiq_dT ! NOTE: dIce/dT = -dLiq/dT return end if ! compute fraction of liquid water on the canopy - ! NOTE: if(.not.deriv) canopyWetFractionDeriv = 0._dp + ! NOTE: if(.not.deriv) canopyWetFractionDeriv = 0._summa_prec call wetFraction((deriv .and. .not.derNum),smoothing,canopyLiq,canopyLiqMax,canopyWettingFactor,canopyWettingExp,canopyWetFraction,canopyWetFractionDeriv) ! compute numerical derivative @@ -1611,20 +1611,20 @@ subroutine wetFraction(derDesire,smoothing,canopyLiq,canopyMax,canopyWettingFact ! dummy variables logical(lgt),intent(in) :: derDesire ! flag to denote if analytical derivatives are desired logical(lgt),intent(in) :: smoothing ! flag to denote if smoothing is required - real(dp),intent(in) :: canopyLiq ! liquid water content (kg m-2) - real(dp),intent(in) :: canopyMax ! liquid water content (kg m-2) - real(dp),intent(in) :: canopyWettingFactor ! maximum wetted fraction of the canopy (-) - real(dp),intent(in) :: canopyWettingExp ! exponent in canopy wetting function (-) + real(summa_prec),intent(in) :: canopyLiq ! liquid water content (kg m-2) + real(summa_prec),intent(in) :: canopyMax ! liquid water content (kg m-2) + real(summa_prec),intent(in) :: canopyWettingFactor ! maximum wetted fraction of the canopy (-) + real(summa_prec),intent(in) :: canopyWettingExp ! exponent in canopy wetting function (-) - real(dp),intent(out) :: canopyWetFraction ! canopy wetted fraction (-) - real(dp),intent(out) :: canopyWetFractionDeriv ! derivative in wetted fraction w.r.t. canopy liquid water (kg-1 m2) + real(summa_prec),intent(out) :: canopyWetFraction ! canopy wetted fraction (-) + real(summa_prec),intent(out) :: canopyWetFractionDeriv ! derivative in wetted fraction w.r.t. canopy liquid water (kg-1 m2) ! local variables - real(dp) :: relativeCanopyWater ! water stored on vegetation canopy, expressed as a fraction of maximum storage (-) - real(dp) :: rawCanopyWetFraction ! initial value of the canopy wet fraction (before smoothing) - real(dp) :: rawWetFractionDeriv ! derivative in canopy wet fraction w.r.t. storage (kg-1 m2) - real(dp) :: smoothFunc ! smoothing function used to improve numerical stability at times with limited water storage (-) - real(dp) :: smoothFuncDeriv ! derivative in the smoothing function w.r.t.canopy storage (kg-1 m2) - real(dp) :: verySmall=epsilon(1._dp) ! a very small number + real(summa_prec) :: relativeCanopyWater ! water stored on vegetation canopy, expressed as a fraction of maximum storage (-) + real(summa_prec) :: rawCanopyWetFraction ! initial value of the canopy wet fraction (before smoothing) + real(summa_prec) :: rawWetFractionDeriv ! derivative in canopy wet fraction w.r.t. storage (kg-1 m2) + real(summa_prec) :: smoothFunc ! smoothing function used to improve numerical stability at times with limited water storage (-) + real(summa_prec) :: smoothFuncDeriv ! derivative in the smoothing function w.r.t.canopy storage (kg-1 m2) + real(summa_prec) :: verySmall=epsilon(1._summa_prec) ! a very small number ! -------------------------------------------------------------------------------------------------------------- ! compute relative canopy water @@ -1633,18 +1633,18 @@ subroutine wetFraction(derDesire,smoothing,canopyLiq,canopyMax,canopyWettingFact ! compute an initial value of the canopy wet fraction ! - canopy below value where canopy is 100% wet - if(relativeCanopyWater < 1._dp)then + if(relativeCanopyWater < 1._summa_prec)then rawCanopyWetFraction = canopyWettingFactor*(relativeCanopyWater**canopyWettingExp) if(derDesire .and. relativeCanopyWater>verySmall)then - rawWetFractionDeriv = (canopyWettingFactor*canopyWettingExp/canopyMax)*relativeCanopyWater**(canopyWettingExp - 1._dp) + rawWetFractionDeriv = (canopyWettingFactor*canopyWettingExp/canopyMax)*relativeCanopyWater**(canopyWettingExp - 1._summa_prec) else - rawWetFractionDeriv = 0._dp + rawWetFractionDeriv = 0._summa_prec end if ! - canopy is at capacity (canopyWettingFactor) else rawCanopyWetFraction = canopyWettingFactor - rawWetFractionDeriv = 0._dp + rawWetFractionDeriv = 0._summa_prec end if ! smooth canopy wetted fraction @@ -1660,7 +1660,7 @@ subroutine wetFraction(derDesire,smoothing,canopyLiq,canopyMax,canopyWettingFact if(derDesire .and. smoothing)then ! NOTE: raw derivative is used if not smoothing canopyWetFractionDeriv = rawWetFractionDeriv*smoothFunc + rawCanopyWetFraction*smoothFuncDeriv else - canopyWetFractionDeriv = 0._dp + canopyWetFractionDeriv = 0._summa_prec end if end subroutine wetFraction @@ -1673,15 +1673,15 @@ subroutine logisticSmoother(derDesire,canopyLiq,smoothFunc,smoothFuncDeriv) implicit none ! dummy variables logical(lgt),intent(in) :: derDesire ! flag to denote if analytical derivatives are desired - real(dp),intent(in) :: canopyLiq ! liquid water content (kg m-2) - real(dp),intent(out) :: smoothFunc ! smoothing function (-) - real(dp),intent(out) :: smoothFuncDeriv ! derivative in smoothing function (kg-1 m-2) + real(summa_prec),intent(in) :: canopyLiq ! liquid water content (kg m-2) + real(summa_prec),intent(out) :: smoothFunc ! smoothing function (-) + real(summa_prec),intent(out) :: smoothFuncDeriv ! derivative in smoothing function (kg-1 m-2) ! local variables - real(dp) :: xArg ! argument used in the smoothing function (-) - real(dp) :: expX ! exp(-xArg) -- used multiple times - real(dp),parameter :: smoothThresh=0.01_dp ! mid-point of the smoothing function (kg m-2) - real(dp),parameter :: smoothScale=0.001_dp ! scaling factor for the smoothing function (kg m-2) - real(dp),parameter :: xLimit=50._dp ! don't compute exponents for > xLimit + real(summa_prec) :: xArg ! argument used in the smoothing function (-) + real(summa_prec) :: expX ! exp(-xArg) -- used multiple times + real(summa_prec),parameter :: smoothThresh=0.01_summa_prec ! mid-point of the smoothing function (kg m-2) + real(summa_prec),parameter :: smoothScale=0.001_summa_prec ! scaling factor for the smoothing function (kg m-2) + real(summa_prec),parameter :: xLimit=50._summa_prec ! don't compute exponents for > xLimit ! -------------------------------------------------------------------------------------------------------------- ! compute argument in the smoothing function xArg = (canopyLiq - smoothThresh)/smoothScale @@ -1689,19 +1689,19 @@ subroutine logisticSmoother(derDesire,canopyLiq,smoothFunc,smoothFuncDeriv) ! only compute smoothing function for small exponents if(xArg > -xLimit .and. xArg < xLimit)then ! avoid huge exponents expX = exp(-xarg) ! (also used in the derivative) - smoothFunc = 1._dp / (1._dp + expX) ! (logistic smoother) + smoothFunc = 1._summa_prec / (1._summa_prec + expX) ! (logistic smoother) if(derDesire)then - smoothFuncDeriv = expX / (smoothScale * (1._dp + expX)**2._dp) ! (derivative in the smoothing function) + smoothFuncDeriv = expX / (smoothScale * (1._summa_prec + expX)**2._summa_prec) ! (derivative in the smoothing function) else - smoothFuncDeriv = 0._dp + smoothFuncDeriv = 0._summa_prec end if ! outside limits: special case of smooth exponents else - if(xArg < 0._dp)then; smoothFunc = 0._dp ! xArg < -xLimit - else; smoothFunc = 1._dp ! xArg > xLimit + if(xArg < 0._summa_prec)then; smoothFunc = 0._summa_prec ! xArg < -xLimit + else; smoothFunc = 1._summa_prec ! xArg > xLimit end if - smoothFuncDeriv = 0._dp + smoothFuncDeriv = 0._summa_prec end if ! check for huge exponents end subroutine logisticSmoother @@ -1752,34 +1752,34 @@ subroutine longwaveBal(& integer(i4b),intent(in) :: ixDerivMethod ! choice of method used to compute derivative (analytical or numerical) logical(lgt),intent(in) :: computeVegFlux ! flag to indicate if computing fluxes over vegetation ! input: canopy and ground temperature - real(dp),intent(in) :: canopyTemp ! canopy temperature (K) - real(dp),intent(in) :: groundTemp ! ground temperature (K) + real(summa_prec),intent(in) :: canopyTemp ! canopy temperature (K) + real(summa_prec),intent(in) :: groundTemp ! ground temperature (K) ! input: canopy and ground emissivity - real(dp),intent(in) :: emc ! canopy emissivity (-) - real(dp),intent(in) :: emg ! ground emissivity (-) + real(summa_prec),intent(in) :: emc ! canopy emissivity (-) + real(summa_prec),intent(in) :: emg ! ground emissivity (-) ! input: forcing - real(dp),intent(in) :: LWRadUbound ! downwelling longwave radiation at the upper boundary (W m-2) + real(summa_prec),intent(in) :: LWRadUbound ! downwelling longwave radiation at the upper boundary (W m-2) ! output: sources - real(dp),intent(out) :: LWRadCanopy ! longwave radiation emitted from the canopy (W m-2) - real(dp),intent(out) :: LWRadGround ! longwave radiation emitted at the ground surface (W m-2) + real(summa_prec),intent(out) :: LWRadCanopy ! longwave radiation emitted from the canopy (W m-2) + real(summa_prec),intent(out) :: LWRadGround ! longwave radiation emitted at the ground surface (W m-2) ! output: individual fluxes - real(dp),intent(out) :: LWRadUbound2Canopy ! downward atmospheric longwave radiation absorbed by the canopy (W m-2) - real(dp),intent(out) :: LWRadUbound2Ground ! downward atmospheric longwave radiation absorbed by the ground (W m-2) - real(dp),intent(out) :: LWRadUbound2Ubound ! atmospheric radiation reflected by the ground and lost thru upper boundary (W m-2) - real(dp),intent(out) :: LWRadCanopy2Ubound ! longwave radiation emitted from canopy lost thru upper boundary (W m-2) - real(dp),intent(out) :: LWRadCanopy2Ground ! longwave radiation emitted from canopy absorbed by the ground (W m-2) - real(dp),intent(out) :: LWRadCanopy2Canopy ! canopy longwave reflected from ground and absorbed by the canopy (W m-2) - real(dp),intent(out) :: LWRadGround2Ubound ! longwave radiation emitted from ground lost thru upper boundary (W m-2) - real(dp),intent(out) :: LWRadGround2Canopy ! longwave radiation emitted from ground and absorbed by the canopy (W m-2) + real(summa_prec),intent(out) :: LWRadUbound2Canopy ! downward atmospheric longwave radiation absorbed by the canopy (W m-2) + real(summa_prec),intent(out) :: LWRadUbound2Ground ! downward atmospheric longwave radiation absorbed by the ground (W m-2) + real(summa_prec),intent(out) :: LWRadUbound2Ubound ! atmospheric radiation reflected by the ground and lost thru upper boundary (W m-2) + real(summa_prec),intent(out) :: LWRadCanopy2Ubound ! longwave radiation emitted from canopy lost thru upper boundary (W m-2) + real(summa_prec),intent(out) :: LWRadCanopy2Ground ! longwave radiation emitted from canopy absorbed by the ground (W m-2) + real(summa_prec),intent(out) :: LWRadCanopy2Canopy ! canopy longwave reflected from ground and absorbed by the canopy (W m-2) + real(summa_prec),intent(out) :: LWRadGround2Ubound ! longwave radiation emitted from ground lost thru upper boundary (W m-2) + real(summa_prec),intent(out) :: LWRadGround2Canopy ! longwave radiation emitted from ground and absorbed by the canopy (W m-2) ! output: net fluxes - real(dp),intent(out) :: LWNetCanopy ! net longwave radiation at the canopy (W m-2) - real(dp),intent(out) :: LWNetGround ! net longwave radiation at the ground surface (W m-2) - real(dp),intent(out) :: LWNetUbound ! net longwave radiation at the upper boundary (W m-2) + real(summa_prec),intent(out) :: LWNetCanopy ! net longwave radiation at the canopy (W m-2) + real(summa_prec),intent(out) :: LWNetGround ! net longwave radiation at the ground surface (W m-2) + real(summa_prec),intent(out) :: LWNetUbound ! net longwave radiation at the upper boundary (W m-2) ! output: flux derivatives - real(dp),intent(out) :: dLWNetCanopy_dTCanopy ! derivative in net canopy radiation w.r.t. canopy temperature (W m-2 K-1) - real(dp),intent(out) :: dLWNetGround_dTGround ! derivative in net ground radiation w.r.t. ground temperature (W m-2 K-1) - real(dp),intent(out) :: dLWNetCanopy_dTGround ! derivative in net canopy radiation w.r.t. ground temperature (W m-2 K-1) - real(dp),intent(out) :: dLWNetGround_dTCanopy ! derivative in net ground radiation w.r.t. canopy temperature (W m-2 K-1) + real(summa_prec),intent(out) :: dLWNetCanopy_dTCanopy ! derivative in net canopy radiation w.r.t. canopy temperature (W m-2 K-1) + real(summa_prec),intent(out) :: dLWNetGround_dTGround ! derivative in net ground radiation w.r.t. ground temperature (W m-2 K-1) + real(summa_prec),intent(out) :: dLWNetCanopy_dTGround ! derivative in net canopy radiation w.r.t. ground temperature (W m-2 K-1) + real(summa_prec),intent(out) :: dLWNetGround_dTCanopy ! derivative in net ground radiation w.r.t. canopy temperature (W m-2 K-1) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message @@ -1790,16 +1790,16 @@ subroutine longwaveBal(& integer(i4b),parameter :: perturbStateGround=3 ! named variable to identify the case where we perturb the ground temperature integer(i4b) :: itry ! index of flux evaluation integer(i4b) :: nFlux ! number of flux evaluations - real(dp) :: TCan ! value of canopy temperature used in flux calculations (may be perturbed) - real(dp) :: TGnd ! value of ground temperature used in flux calculations (may be perturbed) - real(dp) :: fluxBalance ! check energy closure (W m-2) - real(dp),parameter :: fluxTolerance=1.e-10_dp ! tolerance for energy closure (W m-2) - real(dp) :: dLWRadCanopy_dTCanopy ! derivative in emitted radiation at the canopy w.r.t. canopy temperature - real(dp) :: dLWRadGround_dTGround ! derivative in emitted radiation at the ground w.r.t. ground temperature - real(dp) :: LWNetCanopy_dStateCanopy ! net lw canopy flux after perturbation in canopy temperature - real(dp) :: LWNetGround_dStateCanopy ! net lw ground flux after perturbation in canopy temperature - real(dp) :: LWNetCanopy_dStateGround ! net lw canopy flux after perturbation in ground temperature - real(dp) :: LWNetGround_dStateGround ! net lw ground flux after perturbation in ground temperature + real(summa_prec) :: TCan ! value of canopy temperature used in flux calculations (may be perturbed) + real(summa_prec) :: TGnd ! value of ground temperature used in flux calculations (may be perturbed) + real(summa_prec) :: fluxBalance ! check energy closure (W m-2) + real(summa_prec),parameter :: fluxTolerance=1.e-10_summa_prec ! tolerance for energy closure (W m-2) + real(summa_prec) :: dLWRadCanopy_dTCanopy ! derivative in emitted radiation at the canopy w.r.t. canopy temperature + real(summa_prec) :: dLWRadGround_dTGround ! derivative in emitted radiation at the ground w.r.t. ground temperature + real(summa_prec) :: LWNetCanopy_dStateCanopy ! net lw canopy flux after perturbation in canopy temperature + real(summa_prec) :: LWNetGround_dStateCanopy ! net lw ground flux after perturbation in canopy temperature + real(summa_prec) :: LWNetCanopy_dStateGround ! net lw canopy flux after perturbation in ground temperature + real(summa_prec) :: LWNetGround_dStateGround ! net lw ground flux after perturbation in ground temperature ! ----------------------------------------------------------------------------------------------------------------------------------------------- ! initialize error control err=0; message='longwaveBal/' @@ -1851,28 +1851,28 @@ subroutine longwaveBal(& ! compute longwave fluxes from canopy and the ground if(computeVegFlux)then - LWRadCanopy = emc*sb*TCan**4._dp ! longwave radiation emitted from the canopy (W m-2) + LWRadCanopy = emc*sb*TCan**4._summa_prec ! longwave radiation emitted from the canopy (W m-2) else - LWRadCanopy = 0._dp + LWRadCanopy = 0._summa_prec end if - LWRadGround = emg*sb*TGnd**4._dp ! longwave radiation emitted at the ground surface (W m-2) + LWRadGround = emg*sb*TGnd**4._summa_prec ! longwave radiation emitted at the ground surface (W m-2) ! compute fluxes originating from the atmosphere - LWRadUbound2Canopy = (emc + (1._dp - emc)*(1._dp - emg)*emc)*LWRadUbound ! downward atmospheric longwave radiation absorbed by the canopy (W m-2) - LWRadUbound2Ground = (1._dp - emc)*emg*LWRadUbound ! downward atmospheric longwave radiation absorbed by the ground (W m-2) - LWRadUbound2Ubound = (1._dp - emc)*(1._dp - emg)*(1._dp - emc)*LWRadUbound ! atmospheric radiation reflected by the ground and lost thru upper boundary (W m-2) + LWRadUbound2Canopy = (emc + (1._summa_prec - emc)*(1._summa_prec - emg)*emc)*LWRadUbound ! downward atmospheric longwave radiation absorbed by the canopy (W m-2) + LWRadUbound2Ground = (1._summa_prec - emc)*emg*LWRadUbound ! downward atmospheric longwave radiation absorbed by the ground (W m-2) + LWRadUbound2Ubound = (1._summa_prec - emc)*(1._summa_prec - emg)*(1._summa_prec - emc)*LWRadUbound ! atmospheric radiation reflected by the ground and lost thru upper boundary (W m-2) ! compute fluxes originating from the canopy - LWRadCanopy2Ubound = (1._dp + (1._dp - emc)*(1._dp - emg))*LWRadCanopy ! longwave radiation emitted from canopy lost thru upper boundary (W m-2) + LWRadCanopy2Ubound = (1._summa_prec + (1._summa_prec - emc)*(1._summa_prec - emg))*LWRadCanopy ! longwave radiation emitted from canopy lost thru upper boundary (W m-2) LWRadCanopy2Ground = emg*LWRadCanopy ! longwave radiation emitted from canopy absorbed by the ground (W m-2) - LWRadCanopy2Canopy = emc*(1._dp - emg)*LWRadCanopy ! canopy longwave reflected from ground and absorbed by the canopy (W m-2) + LWRadCanopy2Canopy = emc*(1._summa_prec - emg)*LWRadCanopy ! canopy longwave reflected from ground and absorbed by the canopy (W m-2) ! compute fluxes originating from the ground surface - LWRadGround2Ubound = (1._dp - emc)*LWRadGround ! longwave radiation emitted from ground lost thru upper boundary (W m-2) + LWRadGround2Ubound = (1._summa_prec - emc)*LWRadGround ! longwave radiation emitted from ground lost thru upper boundary (W m-2) LWRadGround2Canopy = emc*LWRadGround ! longwave radiation emitted from ground and absorbed by the canopy (W m-2) ! compute net longwave radiation (W m-2) - LWNetCanopy = LWRadUbound2Canopy + LWRadGround2Canopy + LWRadCanopy2Canopy - 2._dp*LWRadCanopy ! canopy + LWNetCanopy = LWRadUbound2Canopy + LWRadGround2Canopy + LWRadCanopy2Canopy - 2._summa_prec*LWRadCanopy ! canopy LWNetGround = LWRadUbound2Ground + LWRadCanopy2Ground - LWRadGround ! ground surface LWNetUbound = LWRadUbound - LWRadUbound2Ubound - LWRadCanopy2Ubound - LWRadGround2Ubound ! upper boundary @@ -1933,10 +1933,10 @@ subroutine longwaveBal(& ! ***** analytical derivatives case(analytical) ! compute initial derivatives - dLWRadCanopy_dTCanopy = 4._dp*emc*sb*TCan**3._dp - dLWRadGround_dTGround = 4._dp*emg*sb*TGnd**3._dp + dLWRadCanopy_dTCanopy = 4._summa_prec*emc*sb*TCan**3._summa_prec + dLWRadGround_dTGround = 4._summa_prec*emg*sb*TGnd**3._summa_prec ! compute analytical derivatives - dLWNetCanopy_dTCanopy = (emc*(1._dp - emg) - 2._dp)*dLWRadCanopy_dTCanopy ! derivative in net canopy radiation w.r.t. canopy temperature (W m-2 K-1) + dLWNetCanopy_dTCanopy = (emc*(1._summa_prec - emg) - 2._summa_prec)*dLWRadCanopy_dTCanopy ! derivative in net canopy radiation w.r.t. canopy temperature (W m-2 K-1) dLWNetGround_dTGround = -dLWRadGround_dTGround ! derivative in net ground radiation w.r.t. ground temperature (W m-2 K-1) dLWNetCanopy_dTGround = emc*dLWRadGround_dTGround ! derivative in net canopy radiation w.r.t. ground temperature (W m-2 K-1) dLWNetGround_dTCanopy = emg*dLWRadCanopy_dTCanopy ! derivative in net ground radiation w.r.t. canopy temperature (W m-2 K-1) @@ -2026,49 +2026,49 @@ subroutine aeroResist(& integer(i4b),intent(in) :: ixWindProfile ! choice of canopy wind profile integer(i4b),intent(in) :: ixStability ! choice of stability function ! input: above-canopy forcing data - real(dp),intent(in) :: mHeight ! measurement height (m) - real(dp),intent(in) :: airtemp ! air temperature at some height above the surface (K) - real(dp),intent(in) :: windspd ! wind speed at some height above the surface (m s-1) + real(summa_prec),intent(in) :: mHeight ! measurement height (m) + real(summa_prec),intent(in) :: airtemp ! air temperature at some height above the surface (K) + real(summa_prec),intent(in) :: windspd ! wind speed at some height above the surface (m s-1) ! input: temperature (canopy, ground, canopy air space) - real(dp),intent(in) :: canairTemp ! temperature of the canopy air space (K) - real(dp),intent(in) :: groundTemp ! ground temperature (K) + real(summa_prec),intent(in) :: canairTemp ! temperature of the canopy air space (K) + real(summa_prec),intent(in) :: groundTemp ! ground temperature (K) ! input: diagnostic variables - real(dp),intent(in) :: exposedVAI ! exposed vegetation area index -- leaf plus stem (m2 m-2) - real(dp),intent(in) :: snowDepth ! snow depth (m) + real(summa_prec),intent(in) :: exposedVAI ! exposed vegetation area index -- leaf plus stem (m2 m-2) + real(summa_prec),intent(in) :: snowDepth ! snow depth (m) ! input: parameters - real(dp),intent(in) :: z0Ground ! roughness length of the ground (below canopy or non-vegetated surface [snow]) (m) - real(dp),intent(in) :: z0CanopyParam ! roughness length of the canopy (m) - real(dp),intent(in) :: zpdFraction ! zero plane displacement / canopy height (-) - real(dp),intent(in) :: critRichNumber ! critical value for the bulk Richardson number where turbulence ceases (-) - real(dp),intent(in) :: Louis79_bparam ! parameter in Louis (1979) stability function - real(dp),intent(in) :: Mahrt87_eScale ! exponential scaling factor in the Mahrt (1987) stability function - real(dp),intent(in) :: windReductionParam ! canopy wind reduction parameter (-) - real(dp),intent(in) :: leafExchangeCoeff ! turbulent exchange coeff between canopy surface and canopy air ( m s-(1/2) ) - real(dp),intent(in) :: leafDimension ! characteristic leaf dimension (m) - real(dp),intent(in) :: heightCanopyTop ! height at the top of the vegetation canopy (m) - real(dp),intent(in) :: heightCanopyBottom ! height at the bottom of the vegetation canopy (m) + real(summa_prec),intent(in) :: z0Ground ! roughness length of the ground (below canopy or non-vegetated surface [snow]) (m) + real(summa_prec),intent(in) :: z0CanopyParam ! roughness length of the canopy (m) + real(summa_prec),intent(in) :: zpdFraction ! zero plane displacement / canopy height (-) + real(summa_prec),intent(in) :: critRichNumber ! critical value for the bulk Richardson number where turbulence ceases (-) + real(summa_prec),intent(in) :: Louis79_bparam ! parameter in Louis (1979) stability function + real(summa_prec),intent(in) :: Mahrt87_eScale ! exponential scaling factor in the Mahrt (1987) stability function + real(summa_prec),intent(in) :: windReductionParam ! canopy wind reduction parameter (-) + real(summa_prec),intent(in) :: leafExchangeCoeff ! turbulent exchange coeff between canopy surface and canopy air ( m s-(1/2) ) + real(summa_prec),intent(in) :: leafDimension ! characteristic leaf dimension (m) + real(summa_prec),intent(in) :: heightCanopyTop ! height at the top of the vegetation canopy (m) + real(summa_prec),intent(in) :: heightCanopyBottom ! height at the bottom of the vegetation canopy (m) ! output: stability corrections - real(dp),intent(out) :: RiBulkCanopy ! bulk Richardson number for the canopy (-) - real(dp),intent(out) :: RiBulkGround ! bulk Richardson number for the ground surface (-) - real(dp),intent(out) :: canopyStabilityCorrection ! stability correction for the canopy (-) - real(dp),intent(out) :: groundStabilityCorrection ! stability correction for the ground surface (-) + real(summa_prec),intent(out) :: RiBulkCanopy ! bulk Richardson number for the canopy (-) + real(summa_prec),intent(out) :: RiBulkGround ! bulk Richardson number for the ground surface (-) + real(summa_prec),intent(out) :: canopyStabilityCorrection ! stability correction for the canopy (-) + real(summa_prec),intent(out) :: groundStabilityCorrection ! stability correction for the ground surface (-) ! output: scalar resistances - real(dp),intent(out) :: z0Canopy ! roughness length of the vegetation canopy (m) - real(dp),intent(out) :: windReductionFactor ! canopy wind reduction factor (-) - real(dp),intent(out) :: zeroPlaneDisplacement ! zero plane displacement (m) - real(dp),intent(out) :: eddyDiffusCanopyTop ! eddy diffusivity for heat at the top of the canopy (m2 s-1) - real(dp),intent(out) :: frictionVelocity ! friction velocity (m s-1) - real(dp),intent(out) :: windspdCanopyTop ! windspeed at the top of the canopy (m s-1) - real(dp),intent(out) :: windspdCanopyBottom ! windspeed at the height of the bottom of the canopy (m s-1) - real(dp),intent(out) :: leafResistance ! mean leaf boundary layer resistance per unit leaf area (s m-1) - real(dp),intent(out) :: groundResistance ! below canopy aerodynamic resistance (s m-1) - real(dp),intent(out) :: canopyResistance ! above canopy aerodynamic resistance (s m-1) + real(summa_prec),intent(out) :: z0Canopy ! roughness length of the vegetation canopy (m) + real(summa_prec),intent(out) :: windReductionFactor ! canopy wind reduction factor (-) + real(summa_prec),intent(out) :: zeroPlaneDisplacement ! zero plane displacement (m) + real(summa_prec),intent(out) :: eddyDiffusCanopyTop ! eddy diffusivity for heat at the top of the canopy (m2 s-1) + real(summa_prec),intent(out) :: frictionVelocity ! friction velocity (m s-1) + real(summa_prec),intent(out) :: windspdCanopyTop ! windspeed at the top of the canopy (m s-1) + real(summa_prec),intent(out) :: windspdCanopyBottom ! windspeed at the height of the bottom of the canopy (m s-1) + real(summa_prec),intent(out) :: leafResistance ! mean leaf boundary layer resistance per unit leaf area (s m-1) + real(summa_prec),intent(out) :: groundResistance ! below canopy aerodynamic resistance (s m-1) + real(summa_prec),intent(out) :: canopyResistance ! above canopy aerodynamic resistance (s m-1) ! output: derivatives in scalar resistances - real(dp),intent(out) :: dGroundResistance_dTGround ! derivative in ground resistance w.r.t. ground temperature (s m-1 K-1) - real(dp),intent(out) :: dGroundResistance_dTCanopy ! derivative in ground resistance w.r.t. canopy temperature (s m-1 K-1) - real(dp),intent(out) :: dGroundResistance_dTCanair ! derivative in ground resistance w.r.t. canopy air temperature (s m-1 K-1) - real(dp),intent(out) :: dCanopyResistance_dTCanopy ! derivative in canopy resistance w.r.t. canopy temperature (s m-1 K-1) - real(dp),intent(out) :: dCanopyResistance_dTCanair ! derivative in canopy resistance w.r.t. canopy air temperature (s m-1 K-1) + real(summa_prec),intent(out) :: dGroundResistance_dTGround ! derivative in ground resistance w.r.t. ground temperature (s m-1 K-1) + real(summa_prec),intent(out) :: dGroundResistance_dTCanopy ! derivative in ground resistance w.r.t. canopy temperature (s m-1 K-1) + real(summa_prec),intent(out) :: dGroundResistance_dTCanair ! derivative in ground resistance w.r.t. canopy air temperature (s m-1 K-1) + real(summa_prec),intent(out) :: dCanopyResistance_dTCanopy ! derivative in canopy resistance w.r.t. canopy temperature (s m-1 K-1) + real(summa_prec),intent(out) :: dCanopyResistance_dTCanair ! derivative in canopy resistance w.r.t. canopy air temperature (s m-1 K-1) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message @@ -2076,45 +2076,45 @@ subroutine aeroResist(& ! local variables: general character(LEN=256) :: cmessage ! error message of downwind routine ! local variables: vegetation roughness and dispalcement height - real(dp),parameter :: oneThird=1._dp/3._dp ! 1/3 - real(dp),parameter :: twoThirds=2._dp/3._dp ! 2/3 - real(dp),parameter :: C_r = 0.3 ! roughness element drag coefficient (-) from Raupach (BLM, 1994) - real(dp),parameter :: C_s = 0.003_dp ! substrate surface drag coefficient (-) from Raupach (BLM, 1994) - real(dp),parameter :: approxDragCoef_max = 0.3_dp ! maximum value of the approximate drag coefficient (-) from Raupach (BLM, 1994) - real(dp),parameter :: psi_h = 0.193_dp ! roughness sub-layer influence function (-) from Raupach (BLM, 1994) - real(dp),parameter :: c_d1 = 7.5_dp ! scaling parameter used to define displacement height (-) from Raupach (BLM, 1994) - real(dp),parameter :: cd_CM = 0.2_dp ! mean drag coefficient for individual leaves (-) from Choudhury and Monteith (QJRMS, 1988) - real(dp) :: funcLAI ! temporary variable to calculate zero plane displacement for the canopy - real(dp) :: fracCanopyHeight ! zero plane displacement expressed as a fraction of canopy height - real(dp) :: approxDragCoef ! approximate drag coefficient used in the computation of canopy roughness length (-) + real(summa_prec),parameter :: oneThird=1._summa_prec/3._summa_prec ! 1/3 + real(summa_prec),parameter :: twoThirds=2._summa_prec/3._summa_prec ! 2/3 + real(summa_prec),parameter :: C_r = 0.3 ! roughness element drag coefficient (-) from Raupach (BLM, 1994) + real(summa_prec),parameter :: C_s = 0.003_summa_prec ! substrate surface drag coefficient (-) from Raupach (BLM, 1994) + real(summa_prec),parameter :: approxDragCoef_max = 0.3_summa_prec ! maximum value of the approximate drag coefficient (-) from Raupach (BLM, 1994) + real(summa_prec),parameter :: psi_h = 0.193_summa_prec ! roughness sub-layer influence function (-) from Raupach (BLM, 1994) + real(summa_prec),parameter :: c_d1 = 7.5_summa_prec ! scaling parameter used to define displacement height (-) from Raupach (BLM, 1994) + real(summa_prec),parameter :: cd_CM = 0.2_summa_prec ! mean drag coefficient for individual leaves (-) from Choudhury and Monteith (QJRMS, 1988) + real(summa_prec) :: funcLAI ! temporary variable to calculate zero plane displacement for the canopy + real(summa_prec) :: fracCanopyHeight ! zero plane displacement expressed as a fraction of canopy height + real(summa_prec) :: approxDragCoef ! approximate drag coefficient used in the computation of canopy roughness length (-) ! local variables: resistance - real(dp) :: canopyExNeut ! surface-atmosphere exchange coefficient under neutral conditions (-) - real(dp) :: groundExNeut ! surface-atmosphere exchange coefficient under neutral conditions (-) - real(dp) :: sfc2AtmExchangeCoeff_canopy ! surface-atmosphere exchange coefficient after stability corrections (-) - real(dp) :: groundResistanceNeutral ! ground resistance under neutral conditions (s m-1) - real(dp) :: windConvFactor_fv ! factor to convert friction velocity to wind speed at top of canopy (-) - real(dp) :: windConvFactor ! factor to convert wind speed at top of canopy to wind speed at a given height in the canopy (-) - real(dp) :: referenceHeight ! z0Canopy+zeroPlaneDisplacement (m) - real(dp) :: windspdRefHeight ! windspeed at the reference height (m/s) - real(dp) :: heightAboveGround ! height above the snow surface (m) - real(dp) :: heightCanopyTopAboveSnow ! height at the top of the vegetation canopy relative to snowpack (m) - real(dp) :: heightCanopyBottomAboveSnow ! height at the bottom of the vegetation canopy relative to snowpack (m) - real(dp),parameter :: xTolerance=0.1_dp ! tolerance to handle the transition from exponential to log-below canopy + real(summa_prec) :: canopyExNeut ! surface-atmosphere exchange coefficient under neutral conditions (-) + real(summa_prec) :: groundExNeut ! surface-atmosphere exchange coefficient under neutral conditions (-) + real(summa_prec) :: sfc2AtmExchangeCoeff_canopy ! surface-atmosphere exchange coefficient after stability corrections (-) + real(summa_prec) :: groundResistanceNeutral ! ground resistance under neutral conditions (s m-1) + real(summa_prec) :: windConvFactor_fv ! factor to convert friction velocity to wind speed at top of canopy (-) + real(summa_prec) :: windConvFactor ! factor to convert wind speed at top of canopy to wind speed at a given height in the canopy (-) + real(summa_prec) :: referenceHeight ! z0Canopy+zeroPlaneDisplacement (m) + real(summa_prec) :: windspdRefHeight ! windspeed at the reference height (m/s) + real(summa_prec) :: heightAboveGround ! height above the snow surface (m) + real(summa_prec) :: heightCanopyTopAboveSnow ! height at the top of the vegetation canopy relative to snowpack (m) + real(summa_prec) :: heightCanopyBottomAboveSnow ! height at the bottom of the vegetation canopy relative to snowpack (m) + real(summa_prec),parameter :: xTolerance=0.1_summa_prec ! tolerance to handle the transition from exponential to log-below canopy ! local variables: derivatives - real(dp) :: dFV_dT ! derivative in friction velocity w.r.t. canopy air temperature - real(dp) :: dED_dT ! derivative in eddy diffusivity at the top of the canopy w.r.t. canopy air temperature - real(dp) :: dGR_dT ! derivative in neutral ground resistance w.r.t. canopy air temperature - real(dp) :: tmp1,tmp2 ! temporary variables used in calculation of ground resistance - real(dp) :: dCanopyStabilityCorrection_dRich ! derivative in stability correction w.r.t. Richardson number for the canopy (-) - real(dp) :: dGroundStabilityCorrection_dRich ! derivative in stability correction w.r.t. Richardson number for the ground surface (-) - real(dp) :: dCanopyStabilityCorrection_dAirTemp ! (not used) derivative in stability correction w.r.t. air temperature (K-1) - real(dp) :: dGroundStabilityCorrection_dAirTemp ! (not used) derivative in stability correction w.r.t. air temperature (K-1) - real(dp) :: dCanopyStabilityCorrection_dCasTemp ! derivative in canopy stability correction w.r.t. canopy air space temperature (K-1) - real(dp) :: dGroundStabilityCorrection_dCasTemp ! derivative in ground stability correction w.r.t. canopy air space temperature (K-1) - real(dp) :: dGroundStabilityCorrection_dSfcTemp ! derivative in ground stability correction w.r.t. surface temperature (K-1) - real(dp) :: singleLeafConductance ! leaf boundary layer conductance (m s-1) - real(dp) :: canopyLeafConductance ! leaf boundary layer conductance -- scaled up to the canopy (m s-1) - real(dp) :: leaf2CanopyScaleFactor ! factor to scale from the leaf to the canopy [m s-(1/2)] + real(summa_prec) :: dFV_dT ! derivative in friction velocity w.r.t. canopy air temperature + real(summa_prec) :: dED_dT ! derivative in eddy diffusivity at the top of the canopy w.r.t. canopy air temperature + real(summa_prec) :: dGR_dT ! derivative in neutral ground resistance w.r.t. canopy air temperature + real(summa_prec) :: tmp1,tmp2 ! temporary variables used in calculation of ground resistance + real(summa_prec) :: dCanopyStabilityCorrection_dRich ! derivative in stability correction w.r.t. Richardson number for the canopy (-) + real(summa_prec) :: dGroundStabilityCorrection_dRich ! derivative in stability correction w.r.t. Richardson number for the ground surface (-) + real(summa_prec) :: dCanopyStabilityCorrection_dAirTemp ! (not used) derivative in stability correction w.r.t. air temperature (K-1) + real(summa_prec) :: dGroundStabilityCorrection_dAirTemp ! (not used) derivative in stability correction w.r.t. air temperature (K-1) + real(summa_prec) :: dCanopyStabilityCorrection_dCasTemp ! derivative in canopy stability correction w.r.t. canopy air space temperature (K-1) + real(summa_prec) :: dGroundStabilityCorrection_dCasTemp ! derivative in ground stability correction w.r.t. canopy air space temperature (K-1) + real(summa_prec) :: dGroundStabilityCorrection_dSfcTemp ! derivative in ground stability correction w.r.t. surface temperature (K-1) + real(summa_prec) :: singleLeafConductance ! leaf boundary layer conductance (m s-1) + real(summa_prec) :: canopyLeafConductance ! leaf boundary layer conductance -- scaled up to the canopy (m s-1) + real(summa_prec) :: leaf2CanopyScaleFactor ! factor to scale from the leaf to the canopy [m s-(1/2)] ! ----------------------------------------------------------------------------------------------------------------------------------------- ! initialize error control err=0; message='aeroResist/' @@ -2132,27 +2132,27 @@ subroutine aeroResist(& ! First, calculate new coordinate system above snow - use these to scale wind profiles and resistances ! NOTE: the new coordinate system makes zeroPlaneDisplacement and z0Canopy consistent heightCanopyTopAboveSnow = heightCanopyTop - snowDepth - heightCanopyBottomAboveSnow = max(heightCanopyBottom - snowDepth, 0.0_dp) + heightCanopyBottomAboveSnow = max(heightCanopyBottom - snowDepth, 0.0_summa_prec) select case(ixVegTraits) ! Raupach (BLM 1994) "Simplified expressions..." case(Raupach_BLM1994) ! (compute zero-plane displacement) funcLAI = sqrt(c_d1*exposedVAI) - fracCanopyHeight = -(1._dp - exp(-funcLAI))/funcLAI + 1._dp + fracCanopyHeight = -(1._summa_prec - exp(-funcLAI))/funcLAI + 1._summa_prec zeroPlaneDisplacement = fracCanopyHeight*(heightCanopyTopAboveSnow-heightCanopyBottomAboveSnow)+heightCanopyBottomAboveSnow ! (coupute roughness length of the veg canopy) - approxDragCoef = min( sqrt(C_s + C_r*exposedVAI/2._dp), approxDragCoef_max) - z0Canopy = (1._dp - fracCanopyHeight) * exp(-vkc*approxDragCoef - psi_h) * (heightCanopyTopAboveSnow-heightCanopyBottomAboveSnow) + approxDragCoef = min( sqrt(C_s + C_r*exposedVAI/2._summa_prec), approxDragCoef_max) + z0Canopy = (1._summa_prec - fracCanopyHeight) * exp(-vkc*approxDragCoef - psi_h) * (heightCanopyTopAboveSnow-heightCanopyBottomAboveSnow) ! Choudhury and Monteith (QJRMS 1988) "A four layer model for the heat budget..." case(CM_QJRMS1988) funcLAI = cd_CM*exposedVAI - zeroPlaneDisplacement = 1.1_dp*heightCanopyTopAboveSnow*log(1._dp + funcLAI**0.25_dp) - if(funcLAI < 0.2_dp)then - z0Canopy = z0Ground + 0.3_dp*heightCanopyTopAboveSnow*funcLAI**0.5_dp + zeroPlaneDisplacement = 1.1_summa_prec*heightCanopyTopAboveSnow*log(1._summa_prec + funcLAI**0.25_summa_prec) + if(funcLAI < 0.2_summa_prec)then + z0Canopy = z0Ground + 0.3_summa_prec*heightCanopyTopAboveSnow*funcLAI**0.5_summa_prec else - z0Canopy = 0.3_dp*heightCanopyTopAboveSnow*(1._dp - zeroPlaneDisplacement/heightCanopyTopAboveSnow) + z0Canopy = 0.3_summa_prec*heightCanopyTopAboveSnow*(1._summa_prec - zeroPlaneDisplacement/heightCanopyTopAboveSnow) end if ! constant parameters dependent on the vegetation type @@ -2205,15 +2205,15 @@ subroutine aeroResist(& if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! compute turbulent exchange coefficient (-) - canopyExNeut = (vkc**2._dp) / ( log((mHeight - zeroPlaneDisplacement)/z0Canopy))**2._dp ! coefficient under conditions of neutral stability + canopyExNeut = (vkc**2._summa_prec) / ( log((mHeight - zeroPlaneDisplacement)/z0Canopy))**2._summa_prec ! coefficient under conditions of neutral stability sfc2AtmExchangeCoeff_canopy = canopyExNeut*canopyStabilityCorrection ! after stability corrections ! compute the friction velocity (m s-1) frictionVelocity = windspd * sqrt(sfc2AtmExchangeCoeff_canopy) ! compute the above-canopy resistance (s m-1) - canopyResistance = 1._dp/(sfc2AtmExchangeCoeff_canopy*windspd) - if(canopyResistance < 0._dp)then; err=20; message=trim(message)//'canopy resistance < 0'; return; end if + canopyResistance = 1._summa_prec/(sfc2AtmExchangeCoeff_canopy*windspd) + if(canopyResistance < 0._summa_prec)then; err=20; message=trim(message)//'canopy resistance < 0'; return; end if ! compute windspeed at the top of the canopy above snow depth (m s-1) ! NOTE: stability corrections cancel out @@ -2226,19 +2226,19 @@ subroutine aeroResist(& ! compute windspeed at the height z0Canopy+zeroPlaneDisplacement (m s-1) referenceHeight = z0Canopy+zeroPlaneDisplacement - windConvFactor = exp(-windReductionFactor*(1._dp - (referenceHeight/heightCanopyTopAboveSnow))) + windConvFactor = exp(-windReductionFactor*(1._summa_prec - (referenceHeight/heightCanopyTopAboveSnow))) windspdRefHeight = windspdCanopyTop*windConvFactor ! compute windspeed at the bottom of the canopy relative to the snow depth (m s-1) - windConvFactor = exp(-windReductionFactor*(1._dp - (heightCanopyBottomAboveSnow/heightCanopyTopAboveSnow))) + windConvFactor = exp(-windReductionFactor*(1._summa_prec - (heightCanopyBottomAboveSnow/heightCanopyTopAboveSnow))) windspdCanopyBottom = windspdCanopyTop*windConvFactor ! compute the leaf boundary layer resistance (s m-1) singleLeafConductance = leafExchangeCoeff*sqrt(windspdCanopyTop/leafDimension) - leaf2CanopyScaleFactor = (2._dp/windReductionFactor) * (1._dp - exp(-windReductionFactor/2._dp)) ! factor to scale from the leaf to the canopy + leaf2CanopyScaleFactor = (2._summa_prec/windReductionFactor) * (1._summa_prec - exp(-windReductionFactor/2._summa_prec)) ! factor to scale from the leaf to the canopy canopyLeafConductance = singleLeafConductance*leaf2CanopyScaleFactor - leafResistance = 1._dp/(canopyLeafConductance) - if(leafResistance < 0._dp)then; err=20; message=trim(message)//'leaf resistance < 0'; return; end if + leafResistance = 1._summa_prec/(canopyLeafConductance) + if(leafResistance < 0._summa_prec)then; err=20; message=trim(message)//'leaf resistance < 0'; return; end if ! compute eddy diffusivity for heat at the top of the canopy (m2 s-1) ! Note: use of friction velocity here includes stability adjustments @@ -2265,7 +2265,7 @@ subroutine aeroResist(& tmp2 = exp(-windReductionFactor*(z0Canopy+zeroPlaneDisplacement)/heightCanopyTopAboveSnow) groundResistanceNeutral = ( heightCanopyTopAboveSnow*exp(windReductionFactor) / (windReductionFactor*eddyDiffusCanopyTop) ) * (tmp1 - tmp2) ! (add log-below-canopy component) - groundResistanceNeutral = groundResistanceNeutral + (1._dp/(max(0.1_dp,windspdCanopyBottom)*vkc**2._dp))*(log(heightCanopyBottomAboveSnow/z0Ground))**2._dp + groundResistanceNeutral = groundResistanceNeutral + (1._summa_prec/(max(0.1_summa_prec,windspdCanopyBottom)*vkc**2._summa_prec))*(log(heightCanopyBottomAboveSnow/z0Ground))**2._summa_prec endif ! switch between exponential profile and log-below-canopy @@ -2279,7 +2279,7 @@ subroutine aeroResist(& referenceHeight, & ! input: height of the canopy air space temperature/wind (m) canairTemp, & ! input: temperature of the canopy air space (K) groundTemp, & ! input: temperature of the ground surface (K) - max(0.1_dp,windspdRefHeight), & ! input: wind speed at height z0Canopy+zeroPlaneDisplacement (m s-1) + max(0.1_summa_prec,windspdRefHeight), & ! input: wind speed at height z0Canopy+zeroPlaneDisplacement (m s-1) ! input: stability parameters critRichNumber, & ! input: critical value for the bulk Richardson number where turbulence ceases (-) Louis79_bparam, & ! input: parameter in Louis (1979) stability function @@ -2295,7 +2295,7 @@ subroutine aeroResist(& ! compute the ground resistance groundResistance = groundResistanceNeutral / groundStabilityCorrection - if(groundResistance < 0._dp)then; err=20; message=trim(message)//'ground resistance < 0 [vegetation is present]'; return; end if + if(groundResistance < 0._summa_prec)then; err=20; message=trim(message)//'ground resistance < 0 [vegetation is present]'; return; end if ! ----------------------------------------------------------------------------------------------------------------------------------------- ! ----------------------------------------------------------------------------------------------------------------------------------------- @@ -2303,15 +2303,15 @@ subroutine aeroResist(& else ! no canopy, so set huge resistances (not used) - canopyResistance = 1.e12_dp ! not used: huge resistance, so conductance is essentially zero - leafResistance = 1.e12_dp ! not used: huge resistance, so conductance is essentially zero + canopyResistance = 1.e12_summa_prec ! not used: huge resistance, so conductance is essentially zero + leafResistance = 1.e12_summa_prec ! not used: huge resistance, so conductance is essentially zero ! check that measurement height above the ground surface is above the roughness length if(mHeight < snowDepth+z0Ground)then; err=20; message=trim(message)//'measurement height < snow depth + roughness length'; return; end if ! compute the resistance between the surface and canopy air UNDER NEUTRAL CONDITIONS (s m-1) - groundExNeut = (vkc**2._dp) / ( log((mHeight - snowDepth)/z0Ground)**2._dp) ! turbulent transfer coefficient under conditions of neutral stability (-) - groundResistanceNeutral = 1._dp / (groundExNeut*windspd) + groundExNeut = (vkc**2._summa_prec) / ( log((mHeight - snowDepth)/z0Ground)**2._summa_prec) ! turbulent transfer coefficient under conditions of neutral stability (-) + groundResistanceNeutral = 1._summa_prec / (groundExNeut*windspd) ! define height above the snow surface heightAboveGround = mHeight - snowDepth @@ -2351,7 +2351,7 @@ subroutine aeroResist(& ! compute the ground resistance (after stability corrections) groundResistance = groundResistanceNeutral/groundStabilityCorrection - if(groundResistance < 0._dp)then; err=20; message=trim(message)//'ground resistance < 0 [no vegetation]'; return; end if + if(groundResistance < 0._summa_prec)then; err=20; message=trim(message)//'ground resistance < 0 [no vegetation]'; return; end if ! set all canopy variables to missing (no canopy!) z0Canopy = missingValue ! roughness length of the vegetation canopy (m) @@ -2378,32 +2378,32 @@ subroutine aeroResist(& ! ***** compute derivatives w.r.t. canopy temperature ! NOTE: derivatives are zero because using canopy air space temperature - dCanopyResistance_dTCanopy = 0._dp ! derivative in canopy resistance w.r.t. canopy temperature (s m-1 K-1) - dGroundResistance_dTCanopy = 0._dp ! derivative in ground resistance w.r.t. canopy temperature (s m-1 K-1) + dCanopyResistance_dTCanopy = 0._summa_prec ! derivative in canopy resistance w.r.t. canopy temperature (s m-1 K-1) + dGroundResistance_dTCanopy = 0._summa_prec ! derivative in ground resistance w.r.t. canopy temperature (s m-1 K-1) ! ***** compute derivatives w.r.t. ground temperature (s m-1 K-1) - dGroundResistance_dTGround = -(groundResistanceNeutral*dGroundStabilityCorrection_dSfcTemp)/(groundStabilityCorrection**2._dp) + dGroundResistance_dTGround = -(groundResistanceNeutral*dGroundStabilityCorrection_dSfcTemp)/(groundStabilityCorrection**2._summa_prec) ! ***** compute derivatives w.r.t. temperature of the canopy air space (s m-1 K-1) ! derivative in canopy resistance w.r.t. canopy air temperature (s m-1 K-1) - dCanopyResistance_dTCanair = -dCanopyStabilityCorrection_dCasTemp/(windspd*canopyExNeut*canopyStabilityCorrection**2._dp) + dCanopyResistance_dTCanair = -dCanopyStabilityCorrection_dCasTemp/(windspd*canopyExNeut*canopyStabilityCorrection**2._summa_prec) ! derivative in ground resistance w.r.t. canopy air temperature (s m-1 K-1) ! (compute derivative in NEUTRAL ground resistance w.r.t. canopy air temperature (s m-1 K-1)) - dFV_dT = windspd*canopyExNeut*dCanopyStabilityCorrection_dCasTemp/(sqrt(sfc2AtmExchangeCoeff_canopy)*2._dp) ! d(frictionVelocity)/d(canopy air temperature) + dFV_dT = windspd*canopyExNeut*dCanopyStabilityCorrection_dCasTemp/(sqrt(sfc2AtmExchangeCoeff_canopy)*2._summa_prec) ! d(frictionVelocity)/d(canopy air temperature) dED_dT = dFV_dT*vkc*(heightCanopyTopAboveSnow - zeroPlaneDisplacement) ! d(eddyDiffusCanopyTop)d(canopy air temperature) - dGR_dT = -dED_dT*(tmp1 - tmp2)*heightCanopyTopAboveSnow*exp(windReductionFactor) / (windReductionFactor*eddyDiffusCanopyTop**2._dp) ! d(groundResistanceNeutral)/d(canopy air temperature) + dGR_dT = -dED_dT*(tmp1 - tmp2)*heightCanopyTopAboveSnow*exp(windReductionFactor) / (windReductionFactor*eddyDiffusCanopyTop**2._summa_prec) ! d(groundResistanceNeutral)/d(canopy air temperature) ! (stitch everything together -- product rule) - dGroundResistance_dTCanair = dGR_dT/groundStabilityCorrection - groundResistanceNeutral*dGroundStabilityCorrection_dCasTemp/(groundStabilityCorrection**2._dp) + dGroundResistance_dTCanair = dGR_dT/groundStabilityCorrection - groundResistanceNeutral*dGroundStabilityCorrection_dCasTemp/(groundStabilityCorrection**2._summa_prec) ! ***** compute resistances for non-vegetated surfaces (e.g., snow) else ! set canopy derivatives to zero (non-vegetated, remember) - dCanopyResistance_dTCanopy = 0._dp - dGroundResistance_dTCanopy = 0._dp + dCanopyResistance_dTCanopy = 0._summa_prec + dGroundResistance_dTCanopy = 0._summa_prec ! compute derivatives for ground resistance - dGroundResistance_dTGround = -dGroundStabilityCorrection_dSfcTemp/(windspd*groundExNeut*groundStabilityCorrection**2._dp) + dGroundResistance_dTGround = -dGroundStabilityCorrection_dSfcTemp/(windspd*groundExNeut*groundStabilityCorrection**2._summa_prec) end if ! (switch between vegetated and non-vegetated surfaces) @@ -2456,33 +2456,33 @@ subroutine soilResist(& integer(i4b),intent(in) :: ixSoilResist ! choice of function for the soil moisture control on stomatal resistance integer(i4b),intent(in) :: ixGroundwater ! choice of groundwater representation ! input (variables) - real(dp),intent(in) :: mLayerMatricHead(:) ! matric head in each layer (m) - real(dp),intent(in) :: mLayerVolFracLiq(:) ! volumetric fraction of liquid water in each layer (-) - real(dp),intent(in) :: scalarAquiferStorage ! aquifer storage (m) + real(summa_prec),intent(in) :: mLayerMatricHead(:) ! matric head in each layer (m) + real(summa_prec),intent(in) :: mLayerVolFracLiq(:) ! volumetric fraction of liquid water in each layer (-) + real(summa_prec),intent(in) :: scalarAquiferStorage ! aquifer storage (m) ! input (diagnostic variables) - real(dp),intent(in) :: mLayerRootDensity(:) ! root density in each layer (-) - real(dp),intent(in) :: scalarAquiferRootFrac ! fraction of roots below the lowest unsaturated layer (-) + real(summa_prec),intent(in) :: mLayerRootDensity(:) ! root density in each layer (-) + real(summa_prec),intent(in) :: scalarAquiferRootFrac ! fraction of roots below the lowest unsaturated layer (-) ! input (parameters) - real(dp),intent(in) :: plantWiltPsi ! matric head at wilting point (m) - real(dp),intent(in) :: soilStressParam ! parameter in the exponential soil stress function (-) - real(dp),intent(in) :: critSoilWilting ! critical vol. liq. water content when plants are wilting (-) - real(dp),intent(in) :: critSoilTranspire ! critical vol. liq. water content when transpiration is limited (-) - real(dp),intent(in) :: critAquiferTranspire ! critical aquifer storage value when transpiration is limited (m) + real(summa_prec),intent(in) :: plantWiltPsi ! matric head at wilting point (m) + real(summa_prec),intent(in) :: soilStressParam ! parameter in the exponential soil stress function (-) + real(summa_prec),intent(in) :: critSoilWilting ! critical vol. liq. water content when plants are wilting (-) + real(summa_prec),intent(in) :: critSoilTranspire ! critical vol. liq. water content when transpiration is limited (-) + real(summa_prec),intent(in) :: critAquiferTranspire ! critical aquifer storage value when transpiration is limited (m) ! output - real(dp),intent(out) :: wAvgTranspireLimitFac ! intent(out): weighted average of the transpiration limiting factor (-) - real(dp),intent(out) :: mLayerTranspireLimitFac(:) ! intent(out): transpiration limiting factor in each layer (-) - real(dp),intent(out) :: aquiferTranspireLimitFac ! intent(out): transpiration limiting factor for the aquifer (-) + real(summa_prec),intent(out) :: wAvgTranspireLimitFac ! intent(out): weighted average of the transpiration limiting factor (-) + real(summa_prec),intent(out) :: mLayerTranspireLimitFac(:) ! intent(out): transpiration limiting factor in each layer (-) + real(summa_prec),intent(out) :: aquiferTranspireLimitFac ! intent(out): transpiration limiting factor for the aquifer (-) integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! local variables - real(dp) :: gx ! stress function for the soil layers - real(dp),parameter :: verySmall=epsilon(gx) ! a very small number + real(summa_prec) :: gx ! stress function for the soil layers + real(summa_prec),parameter :: verySmall=epsilon(gx) ! a very small number integer(i4b) :: iLayer ! index of soil layer ! initialize error control err=0; message='soilResist/' ! ** compute the factor limiting transpiration for each soil layer (-) - wAvgTranspireLimitFac = 0._dp ! (initialize the weighted average) + wAvgTranspireLimitFac = 0._summa_prec ! (initialize the weighted average) do iLayer=1,size(mLayerMatricHead) ! compute the soil stress function select case(ixSoilResist) @@ -2490,21 +2490,21 @@ subroutine soilResist(& gx = (mLayerVolFracLiq(iLayer) - critSoilWilting) / (critSoilTranspire - critSoilWilting) case(CLM_Type) ! thresholded linear function of matric head if(mLayerMatricHead(iLayer) > plantWiltPsi)then - gx = 1._dp - mLayerMatricHead(iLayer)/plantWiltPsi + gx = 1._summa_prec - mLayerMatricHead(iLayer)/plantWiltPsi else - gx = 0._dp + gx = 0._summa_prec end if case(SiB_Type) ! exponential of the log of matric head - if(mLayerMatricHead(iLayer) < 0._dp)then ! (unsaturated) - gx = 1._dp - exp( -soilStressParam * ( log(plantWiltPsi/mLayerMatricHead(iLayer)) ) ) + if(mLayerMatricHead(iLayer) < 0._summa_prec)then ! (unsaturated) + gx = 1._summa_prec - exp( -soilStressParam * ( log(plantWiltPsi/mLayerMatricHead(iLayer)) ) ) else ! (saturated) - gx = 1._dp + gx = 1._summa_prec end if case default ! check identified the option err=20; message=trim(message)//'cannot identify option for soil resistance'; return end select ! save the factor for the given layer (ensure between zero and one) - mLayerTranspireLimitFac(iLayer) = min( max(verySmall,gx), 1._dp) + mLayerTranspireLimitFac(iLayer) = min( max(verySmall,gx), 1._summa_prec) ! compute the weighted average (weighted by root density) wAvgTranspireLimitFac = wAvgTranspireLimitFac + mLayerTranspireLimitFac(iLayer)*mLayerRootDensity(iLayer) end do ! (looping through soil layers) @@ -2517,9 +2517,9 @@ subroutine soilResist(& err=20; return end if ! compute the factor limiting evaporation for the aquifer - aquiferTranspireLimitFac = min(scalarAquiferStorage/critAquiferTranspire, 1._dp) + aquiferTranspireLimitFac = min(scalarAquiferStorage/critAquiferTranspire, 1._summa_prec) else ! (if there are roots in the aquifer) - aquiferTranspireLimitFac = 0._dp + aquiferTranspireLimitFac = 0._summa_prec end if ! compute the weighted average (weighted by root density) @@ -2627,138 +2627,138 @@ subroutine turbFluxes(& logical(lgt),intent(in) :: computeVegFlux ! logical flag to compute vegetation fluxes (.false. if veg buried by snow) integer(i4b),intent(in) :: ixDerivMethod ! choice of method used to compute derivative (analytical or numerical) ! input: above-canopy forcing data - real(dp),intent(in) :: airtemp ! air temperature at some height above the surface (K) - real(dp),intent(in) :: airpres ! air pressure of the air above the vegetation canopy (Pa) - real(dp),intent(in) :: VPair ! vapor pressure of the air above the vegetation canopy (Pa) + real(summa_prec),intent(in) :: airtemp ! air temperature at some height above the surface (K) + real(summa_prec),intent(in) :: airpres ! air pressure of the air above the vegetation canopy (Pa) + real(summa_prec),intent(in) :: VPair ! vapor pressure of the air above the vegetation canopy (Pa) ! input: latent heat of sublimation/vaporization - real(dp),intent(in) :: latHeatSubVapCanopy ! latent heat of sublimation/vaporization for the vegetation canopy (J kg-1) - real(dp),intent(in) :: latHeatSubVapGround ! latent heat of sublimation/vaporization for the ground surface (J kg-1) + real(summa_prec),intent(in) :: latHeatSubVapCanopy ! latent heat of sublimation/vaporization for the vegetation canopy (J kg-1) + real(summa_prec),intent(in) :: latHeatSubVapGround ! latent heat of sublimation/vaporization for the ground surface (J kg-1) ! input: canopy and ground temperature - real(dp),intent(in) :: canairTemp ! temperature of the canopy air space (K) - real(dp),intent(in) :: canopyTemp ! canopy temperature (K) - real(dp),intent(in) :: groundTemp ! ground temperature (K) - real(dp),intent(in) :: satVP_CanopyTemp ! saturation vapor pressure at the temperature of the veg canopy (Pa) - real(dp),intent(in) :: satVP_GroundTemp ! saturation vapor pressure at the temperature of the ground (Pa) - real(dp),intent(in) :: dSVPCanopy_dCanopyTemp ! derivative in canopy saturation vapor pressure w.r.t. canopy temperature (Pa K-1) - real(dp),intent(in) :: dSVPGround_dGroundTemp ! derivative in ground saturation vapor pressure w.r.t. ground temperature (Pa K-1) + real(summa_prec),intent(in) :: canairTemp ! temperature of the canopy air space (K) + real(summa_prec),intent(in) :: canopyTemp ! canopy temperature (K) + real(summa_prec),intent(in) :: groundTemp ! ground temperature (K) + real(summa_prec),intent(in) :: satVP_CanopyTemp ! saturation vapor pressure at the temperature of the veg canopy (Pa) + real(summa_prec),intent(in) :: satVP_GroundTemp ! saturation vapor pressure at the temperature of the ground (Pa) + real(summa_prec),intent(in) :: dSVPCanopy_dCanopyTemp ! derivative in canopy saturation vapor pressure w.r.t. canopy temperature (Pa K-1) + real(summa_prec),intent(in) :: dSVPGround_dGroundTemp ! derivative in ground saturation vapor pressure w.r.t. ground temperature (Pa K-1) ! input: diagnostic variables - real(dp),intent(in) :: exposedVAI ! exposed vegetation area index -- leaf plus stem (m2 m-2) - real(dp),intent(in) :: canopyWetFraction ! fraction of canopy that is wet [0-1] - real(dp),intent(in) :: dCanopyWetFraction_dWat ! derivative in the canopy wetted fraction w.r.t. liquid water content (kg-1 m-2) - real(dp),intent(in) :: dCanopyWetFraction_dT ! derivative in the canopy wetted fraction w.r.t. canopy temperature (K-1) - real(dp),intent(in) :: canopySunlitLAI ! sunlit leaf area (-) - real(dp),intent(in) :: canopyShadedLAI ! shaded leaf area (-) - real(dp),intent(in) :: soilRelHumidity ! relative humidity in the soil pores [0-1] - real(dp),intent(in) :: soilResistance ! resistance from the soil (s m-1) - real(dp),intent(in) :: leafResistance ! mean leaf boundary layer resistance per unit leaf area (s m-1) - real(dp),intent(in) :: groundResistance ! below canopy aerodynamic resistance (s m-1) - real(dp),intent(in) :: canopyResistance ! above canopy aerodynamic resistance (s m-1) - real(dp),intent(in) :: stomResistSunlit ! stomatal resistance for sunlit leaves (s m-1) - real(dp),intent(in) :: stomResistShaded ! stomatal resistance for shaded leaves (s m-1) + real(summa_prec),intent(in) :: exposedVAI ! exposed vegetation area index -- leaf plus stem (m2 m-2) + real(summa_prec),intent(in) :: canopyWetFraction ! fraction of canopy that is wet [0-1] + real(summa_prec),intent(in) :: dCanopyWetFraction_dWat ! derivative in the canopy wetted fraction w.r.t. liquid water content (kg-1 m-2) + real(summa_prec),intent(in) :: dCanopyWetFraction_dT ! derivative in the canopy wetted fraction w.r.t. canopy temperature (K-1) + real(summa_prec),intent(in) :: canopySunlitLAI ! sunlit leaf area (-) + real(summa_prec),intent(in) :: canopyShadedLAI ! shaded leaf area (-) + real(summa_prec),intent(in) :: soilRelHumidity ! relative humidity in the soil pores [0-1] + real(summa_prec),intent(in) :: soilResistance ! resistance from the soil (s m-1) + real(summa_prec),intent(in) :: leafResistance ! mean leaf boundary layer resistance per unit leaf area (s m-1) + real(summa_prec),intent(in) :: groundResistance ! below canopy aerodynamic resistance (s m-1) + real(summa_prec),intent(in) :: canopyResistance ! above canopy aerodynamic resistance (s m-1) + real(summa_prec),intent(in) :: stomResistSunlit ! stomatal resistance for sunlit leaves (s m-1) + real(summa_prec),intent(in) :: stomResistShaded ! stomatal resistance for shaded leaves (s m-1) ! input: derivatives in scalar resistances - real(dp),intent(in) :: dGroundResistance_dTGround ! derivative in ground resistance w.r.t. ground temperature (s m-1 K-1) - real(dp),intent(in) :: dGroundResistance_dTCanopy ! derivative in ground resistance w.r.t. canopy temperature (s m-1 K-1) - real(dp),intent(in) :: dGroundResistance_dTCanair ! derivative in ground resistance w.r.t. canopy air temperature (s m-1 K-1) - real(dp),intent(in) :: dCanopyResistance_dTCanopy ! derivative in canopy resistance w.r.t. canopy temperature (s m-1 K-1) - real(dp),intent(in) :: dCanopyResistance_dTCanair ! derivative in canopy resistance w.r.t. canopy air temperature (s m-1 K-1) + real(summa_prec),intent(in) :: dGroundResistance_dTGround ! derivative in ground resistance w.r.t. ground temperature (s m-1 K-1) + real(summa_prec),intent(in) :: dGroundResistance_dTCanopy ! derivative in ground resistance w.r.t. canopy temperature (s m-1 K-1) + real(summa_prec),intent(in) :: dGroundResistance_dTCanair ! derivative in ground resistance w.r.t. canopy air temperature (s m-1 K-1) + real(summa_prec),intent(in) :: dCanopyResistance_dTCanopy ! derivative in canopy resistance w.r.t. canopy temperature (s m-1 K-1) + real(summa_prec),intent(in) :: dCanopyResistance_dTCanair ! derivative in canopy resistance w.r.t. canopy air temperature (s m-1 K-1) ! --------------------------------------------------------------------------------------------------------------------------------------------------------------- ! output: conductances -- used to test derivatives - real(dp),intent(out) :: leafConductance ! leaf conductance (m s-1) - real(dp),intent(out) :: canopyConductance ! canopy conductance (m s-1) - real(dp),intent(out) :: groundConductanceSH ! ground conductance for sensible heat (m s-1) - real(dp),intent(out) :: groundConductanceLH ! ground conductance for latent heat -- includes soil resistance (m s-1) - real(dp),intent(out) :: evapConductance ! conductance for evaporation (m s-1) - real(dp),intent(out) :: transConductance ! conductance for transpiration (m s-1) - real(dp),intent(out) :: totalConductanceSH ! total conductance for sensible heat (m s-1) - real(dp),intent(out) :: totalConductanceLH ! total conductance for latent heat (m s-1) + real(summa_prec),intent(out) :: leafConductance ! leaf conductance (m s-1) + real(summa_prec),intent(out) :: canopyConductance ! canopy conductance (m s-1) + real(summa_prec),intent(out) :: groundConductanceSH ! ground conductance for sensible heat (m s-1) + real(summa_prec),intent(out) :: groundConductanceLH ! ground conductance for latent heat -- includes soil resistance (m s-1) + real(summa_prec),intent(out) :: evapConductance ! conductance for evaporation (m s-1) + real(summa_prec),intent(out) :: transConductance ! conductance for transpiration (m s-1) + real(summa_prec),intent(out) :: totalConductanceSH ! total conductance for sensible heat (m s-1) + real(summa_prec),intent(out) :: totalConductanceLH ! total conductance for latent heat (m s-1) ! output: canopy air space variables - real(dp),intent(out) :: VP_CanopyAir ! vapor pressure of the canopy air space (Pa) + real(summa_prec),intent(out) :: VP_CanopyAir ! vapor pressure of the canopy air space (Pa) ! output: fluxes from the vegetation canopy - real(dp),intent(out) :: senHeatCanopy ! sensible heat flux from the canopy to the canopy air space (W m-2) - real(dp),intent(out) :: latHeatCanopyEvap ! latent heat flux associated with evaporation from the canopy to the canopy air space (W m-2) - real(dp),intent(out) :: latHeatCanopyTrans ! latent heat flux associated with transpiration from the canopy to the canopy air space (W m-2) + real(summa_prec),intent(out) :: senHeatCanopy ! sensible heat flux from the canopy to the canopy air space (W m-2) + real(summa_prec),intent(out) :: latHeatCanopyEvap ! latent heat flux associated with evaporation from the canopy to the canopy air space (W m-2) + real(summa_prec),intent(out) :: latHeatCanopyTrans ! latent heat flux associated with transpiration from the canopy to the canopy air space (W m-2) ! output: fluxes from non-vegetated surfaces (ground surface below vegetation, bare ground, or snow covered vegetation) - real(dp),intent(out) :: senHeatGround ! sensible heat flux from ground surface below vegetation, bare ground, or snow covered vegetation (W m-2) - real(dp),intent(out) :: latHeatGround ! latent heat flux from ground surface below vegetation, bare ground, or snow covered vegetation (W m-2) + real(summa_prec),intent(out) :: senHeatGround ! sensible heat flux from ground surface below vegetation, bare ground, or snow covered vegetation (W m-2) + real(summa_prec),intent(out) :: latHeatGround ! latent heat flux from ground surface below vegetation, bare ground, or snow covered vegetation (W m-2) ! output: total heat fluxes to the atmosphere - real(dp),intent(out) :: senHeatTotal ! total sensible heat flux to the atmosphere (W m-2) - real(dp),intent(out) :: latHeatTotal ! total latent heat flux to the atmosphere (W m-2) + real(summa_prec),intent(out) :: senHeatTotal ! total sensible heat flux to the atmosphere (W m-2) + real(summa_prec),intent(out) :: latHeatTotal ! total latent heat flux to the atmosphere (W m-2) ! output: net fluxes - real(dp),intent(out) :: turbFluxCanair ! net turbulent heat fluxes at the canopy air space (W m-2) - real(dp),intent(out) :: turbFluxCanopy ! net turbulent heat fluxes at the canopy (W m-2) - real(dp),intent(out) :: turbFluxGround ! net turbulent heat fluxes at the ground surface (W m-2) + real(summa_prec),intent(out) :: turbFluxCanair ! net turbulent heat fluxes at the canopy air space (W m-2) + real(summa_prec),intent(out) :: turbFluxCanopy ! net turbulent heat fluxes at the canopy (W m-2) + real(summa_prec),intent(out) :: turbFluxGround ! net turbulent heat fluxes at the ground surface (W m-2) ! output: energy flux derivatives - real(dp),intent(out) :: dTurbFluxCanair_dTCanair ! derivative in net canopy air space fluxes w.r.t. canopy air temperature (W m-2 K-1) - real(dp),intent(out) :: dTurbFluxCanair_dTCanopy ! derivative in net canopy air space fluxes w.r.t. canopy temperature (W m-2 K-1) - real(dp),intent(out) :: dTurbFluxCanair_dTGround ! derivative in net canopy air space fluxes w.r.t. ground temperature (W m-2 K-1) - real(dp),intent(out) :: dTurbFluxCanopy_dTCanair ! derivative in net canopy turbulent fluxes w.r.t. canopy air temperature (W m-2 K-1) - real(dp),intent(out) :: dTurbFluxCanopy_dTCanopy ! derivative in net canopy turbulent fluxes w.r.t. canopy temperature (W m-2 K-1) - real(dp),intent(out) :: dTurbFluxCanopy_dTGround ! derivative in net canopy turbulent fluxes w.r.t. ground temperature (W m-2 K-1) - real(dp),intent(out) :: dTurbFluxGround_dTCanair ! derivative in net ground turbulent fluxes w.r.t. canopy air temperature (W m-2 K-1) - real(dp),intent(out) :: dTurbFluxGround_dTCanopy ! derivative in net ground turbulent fluxes w.r.t. canopy temperature (W m-2 K-1) - real(dp),intent(out) :: dTurbFluxGround_dTGround ! derivative in net ground turbulent fluxes w.r.t. ground temperature (W m-2 K-1) + real(summa_prec),intent(out) :: dTurbFluxCanair_dTCanair ! derivative in net canopy air space fluxes w.r.t. canopy air temperature (W m-2 K-1) + real(summa_prec),intent(out) :: dTurbFluxCanair_dTCanopy ! derivative in net canopy air space fluxes w.r.t. canopy temperature (W m-2 K-1) + real(summa_prec),intent(out) :: dTurbFluxCanair_dTGround ! derivative in net canopy air space fluxes w.r.t. ground temperature (W m-2 K-1) + real(summa_prec),intent(out) :: dTurbFluxCanopy_dTCanair ! derivative in net canopy turbulent fluxes w.r.t. canopy air temperature (W m-2 K-1) + real(summa_prec),intent(out) :: dTurbFluxCanopy_dTCanopy ! derivative in net canopy turbulent fluxes w.r.t. canopy temperature (W m-2 K-1) + real(summa_prec),intent(out) :: dTurbFluxCanopy_dTGround ! derivative in net canopy turbulent fluxes w.r.t. ground temperature (W m-2 K-1) + real(summa_prec),intent(out) :: dTurbFluxGround_dTCanair ! derivative in net ground turbulent fluxes w.r.t. canopy air temperature (W m-2 K-1) + real(summa_prec),intent(out) :: dTurbFluxGround_dTCanopy ! derivative in net ground turbulent fluxes w.r.t. canopy temperature (W m-2 K-1) + real(summa_prec),intent(out) :: dTurbFluxGround_dTGround ! derivative in net ground turbulent fluxes w.r.t. ground temperature (W m-2 K-1) ! output: liquid flux derivatives (canopy evap) - real(dp),intent(out) :: dLatHeatCanopyEvap_dCanLiq ! derivative in latent heat of canopy evaporation w.r.t. canopy liquid water content (W kg-1) - real(dp),intent(out) :: dLatHeatCanopyEvap_dTCanair ! derivative in latent heat of canopy evaporation w.r.t. canopy air temperature (W m-2 K-1) - real(dp),intent(out) :: dLatHeatCanopyEvap_dTCanopy ! derivative in latent heat of canopy evaporation w.r.t. canopy temperature (W m-2 K-1) - real(dp),intent(out) :: dLatHeatCanopyEvap_dTGround ! derivative in latent heat of canopy evaporation w.r.t. ground temperature (W m-2 K-1) + real(summa_prec),intent(out) :: dLatHeatCanopyEvap_dCanLiq ! derivative in latent heat of canopy evaporation w.r.t. canopy liquid water content (W kg-1) + real(summa_prec),intent(out) :: dLatHeatCanopyEvap_dTCanair ! derivative in latent heat of canopy evaporation w.r.t. canopy air temperature (W m-2 K-1) + real(summa_prec),intent(out) :: dLatHeatCanopyEvap_dTCanopy ! derivative in latent heat of canopy evaporation w.r.t. canopy temperature (W m-2 K-1) + real(summa_prec),intent(out) :: dLatHeatCanopyEvap_dTGround ! derivative in latent heat of canopy evaporation w.r.t. ground temperature (W m-2 K-1) ! output: liquid flux derivatives (ground evap) - real(dp),intent(out) :: dLatHeatGroundEvap_dCanLiq ! derivative in latent heat of ground evaporation w.r.t. canopy liquid water content (J kg-1 s-1) - real(dp),intent(out) :: dLatHeatGroundEvap_dTCanair ! derivative in latent heat of ground evaporation w.r.t. canopy air temperature (W m-2 K-1) - real(dp),intent(out) :: dLatHeatGroundEvap_dTCanopy ! derivative in latent heat of ground evaporation w.r.t. canopy temperature (W m-2 K-1) - real(dp),intent(out) :: dLatHeatGroundEvap_dTGround ! derivative in latent heat of ground evaporation w.r.t. ground temperature (W m-2 K-1) + real(summa_prec),intent(out) :: dLatHeatGroundEvap_dCanLiq ! derivative in latent heat of ground evaporation w.r.t. canopy liquid water content (J kg-1 s-1) + real(summa_prec),intent(out) :: dLatHeatGroundEvap_dTCanair ! derivative in latent heat of ground evaporation w.r.t. canopy air temperature (W m-2 K-1) + real(summa_prec),intent(out) :: dLatHeatGroundEvap_dTCanopy ! derivative in latent heat of ground evaporation w.r.t. canopy temperature (W m-2 K-1) + real(summa_prec),intent(out) :: dLatHeatGroundEvap_dTGround ! derivative in latent heat of ground evaporation w.r.t. ground temperature (W m-2 K-1) ! output: cross derivatives - real(dp),intent(out) :: dTurbFluxCanair_dCanLiq ! derivative in net canopy air space fluxes w.r.t. canopy liquid water content (J kg-1 s-1) - real(dp),intent(out) :: dTurbFluxCanopy_dCanLiq ! derivative in net canopy turbulent fluxes w.r.t. canopy liquid water content (J kg-1 s-1) - real(dp),intent(out) :: dTurbFluxGround_dCanLiq ! derivative in net ground turbulent fluxes w.r.t. canopy liquid water content (J kg-1 s-1) + real(summa_prec),intent(out) :: dTurbFluxCanair_dCanLiq ! derivative in net canopy air space fluxes w.r.t. canopy liquid water content (J kg-1 s-1) + real(summa_prec),intent(out) :: dTurbFluxCanopy_dCanLiq ! derivative in net canopy turbulent fluxes w.r.t. canopy liquid water content (J kg-1 s-1) + real(summa_prec),intent(out) :: dTurbFluxGround_dCanLiq ! derivative in net ground turbulent fluxes w.r.t. canopy liquid water content (J kg-1 s-1) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! ----------------------------------------------------------------------------------------------------------------------------------------- ! local variables -- general - real(dp) :: fpart1,fpart2 ! different parts of a function - real(dp) :: dPart0,dpart1,dpart2 ! derivatives for different parts of a function + real(summa_prec) :: fpart1,fpart2 ! different parts of a function + real(summa_prec) :: dPart0,dpart1,dpart2 ! derivatives for different parts of a function ! local variables -- "constants" - real(dp) :: volHeatCapacityAir ! volumetric heat capacity of air (J m-3) - real(dp) :: latentHeatConstant ! latent heat constant (kg m-3 K-1) + real(summa_prec) :: volHeatCapacityAir ! volumetric heat capacity of air (J m-3) + real(summa_prec) :: latentHeatConstant ! latent heat constant (kg m-3 K-1) ! local variables -- derivatives for energy conductances - real(dp) :: dEvapCond_dCanopyTemp ! derivative in evap conductance w.r.t. canopy temperature - real(dp) :: dTransCond_dCanopyTemp ! derivative in trans conductance w.r.t. canopy temperature - real(dp) :: dCanopyCond_dCanairTemp ! derivative in canopy conductance w.r.t. canopy air temperature - real(dp) :: dCanopyCond_dCanopyTemp ! derivative in canopy conductance w.r.t. canopy temperature - real(dp) :: dGroundCondSH_dCanairTemp ! derivative in ground conductance of sensible heat w.r.t. canopy air temperature - real(dp) :: dGroundCondSH_dCanopyTemp ! derivative in ground conductance of sensible heat w.r.t. canopy temperature - real(dp) :: dGroundCondSH_dGroundTemp ! derivative in ground conductance of sensible heat w.r.t. ground temperature + real(summa_prec) :: dEvapCond_dCanopyTemp ! derivative in evap conductance w.r.t. canopy temperature + real(summa_prec) :: dTransCond_dCanopyTemp ! derivative in trans conductance w.r.t. canopy temperature + real(summa_prec) :: dCanopyCond_dCanairTemp ! derivative in canopy conductance w.r.t. canopy air temperature + real(summa_prec) :: dCanopyCond_dCanopyTemp ! derivative in canopy conductance w.r.t. canopy temperature + real(summa_prec) :: dGroundCondSH_dCanairTemp ! derivative in ground conductance of sensible heat w.r.t. canopy air temperature + real(summa_prec) :: dGroundCondSH_dCanopyTemp ! derivative in ground conductance of sensible heat w.r.t. canopy temperature + real(summa_prec) :: dGroundCondSH_dGroundTemp ! derivative in ground conductance of sensible heat w.r.t. ground temperature ! local variables -- derivatives for mass conductances - real(dp) :: dGroundCondLH_dCanairTemp ! derivative in ground conductance w.r.t. canopy air temperature - real(dp) :: dGroundCondLH_dCanopyTemp ! derivative in ground conductance w.r.t. canopy temperature - real(dp) :: dGroundCondLH_dGroundTemp ! derivative in ground conductance w.r.t. ground temperature + real(summa_prec) :: dGroundCondLH_dCanairTemp ! derivative in ground conductance w.r.t. canopy air temperature + real(summa_prec) :: dGroundCondLH_dCanopyTemp ! derivative in ground conductance w.r.t. canopy temperature + real(summa_prec) :: dGroundCondLH_dGroundTemp ! derivative in ground conductance w.r.t. ground temperature ! local variables -- derivatives for the canopy air space variables - real(dp) :: fPart_VP ! part of the function for vapor pressure of the canopy air space - real(dp) :: leafConductanceTr ! leaf conductance for transpiration (m s-1) - real(dp) :: dVPCanopyAir_dTCanair ! derivative in the vapor pressure of the canopy air space w.r.t. temperature of the canopy air space - real(dp) :: dVPCanopyAir_dTCanopy ! derivative in the vapor pressure of the canopy air space w.r.t. temperature of the canopy - real(dp) :: dVPCanopyAir_dTGround ! derivative in the vapor pressure of the canopy air space w.r.t. temperature of the ground - real(dp) :: dVPCanopyAir_dWetFrac ! derivative of vapor pressure in the canopy air space w.r.t. wetted fraction of the canopy - real(dp) :: dVPCanopyAir_dCanLiq ! derivative of vapor pressure in the canopy air space w.r.t. canopy liquid water content + real(summa_prec) :: fPart_VP ! part of the function for vapor pressure of the canopy air space + real(summa_prec) :: leafConductanceTr ! leaf conductance for transpiration (m s-1) + real(summa_prec) :: dVPCanopyAir_dTCanair ! derivative in the vapor pressure of the canopy air space w.r.t. temperature of the canopy air space + real(summa_prec) :: dVPCanopyAir_dTCanopy ! derivative in the vapor pressure of the canopy air space w.r.t. temperature of the canopy + real(summa_prec) :: dVPCanopyAir_dTGround ! derivative in the vapor pressure of the canopy air space w.r.t. temperature of the ground + real(summa_prec) :: dVPCanopyAir_dWetFrac ! derivative of vapor pressure in the canopy air space w.r.t. wetted fraction of the canopy + real(summa_prec) :: dVPCanopyAir_dCanLiq ! derivative of vapor pressure in the canopy air space w.r.t. canopy liquid water content ! local variables -- sensible heat flux derivatives - real(dp) :: dSenHeatTotal_dTCanair ! derivative in the total sensible heat flux w.r.t. canopy air temperature - real(dp) :: dSenHeatTotal_dTCanopy ! derivative in the total sensible heat flux w.r.t. canopy air temperature - real(dp) :: dSenHeatTotal_dTGround ! derivative in the total sensible heat flux w.r.t. ground temperature - real(dp) :: dSenHeatCanopy_dTCanair ! derivative in the canopy sensible heat flux w.r.t. canopy air temperature - real(dp) :: dSenHeatCanopy_dTCanopy ! derivative in the canopy sensible heat flux w.r.t. canopy temperature - real(dp) :: dSenHeatCanopy_dTGround ! derivative in the canopy sensible heat flux w.r.t. ground temperature - real(dp) :: dSenHeatGround_dTCanair ! derivative in the ground sensible heat flux w.r.t. canopy air temperature - real(dp) :: dSenHeatGround_dTCanopy ! derivative in the ground sensible heat flux w.r.t. canopy temperature - real(dp) :: dSenHeatGround_dTGround ! derivative in the ground sensible heat flux w.r.t. ground temperature + real(summa_prec) :: dSenHeatTotal_dTCanair ! derivative in the total sensible heat flux w.r.t. canopy air temperature + real(summa_prec) :: dSenHeatTotal_dTCanopy ! derivative in the total sensible heat flux w.r.t. canopy air temperature + real(summa_prec) :: dSenHeatTotal_dTGround ! derivative in the total sensible heat flux w.r.t. ground temperature + real(summa_prec) :: dSenHeatCanopy_dTCanair ! derivative in the canopy sensible heat flux w.r.t. canopy air temperature + real(summa_prec) :: dSenHeatCanopy_dTCanopy ! derivative in the canopy sensible heat flux w.r.t. canopy temperature + real(summa_prec) :: dSenHeatCanopy_dTGround ! derivative in the canopy sensible heat flux w.r.t. ground temperature + real(summa_prec) :: dSenHeatGround_dTCanair ! derivative in the ground sensible heat flux w.r.t. canopy air temperature + real(summa_prec) :: dSenHeatGround_dTCanopy ! derivative in the ground sensible heat flux w.r.t. canopy temperature + real(summa_prec) :: dSenHeatGround_dTGround ! derivative in the ground sensible heat flux w.r.t. ground temperature ! local variables -- latent heat flux derivatives - real(dp) :: dLatHeatCanopyTrans_dTCanair ! derivative in the canopy transpiration flux w.r.t. canopy air temperature - real(dp) :: dLatHeatCanopyTrans_dTCanopy ! derivative in the canopy transpiration flux w.r.t. canopy temperature - real(dp) :: dLatHeatCanopyTrans_dTGround ! derivative in the canopy transpiration flux w.r.t. ground temperature + real(summa_prec) :: dLatHeatCanopyTrans_dTCanair ! derivative in the canopy transpiration flux w.r.t. canopy air temperature + real(summa_prec) :: dLatHeatCanopyTrans_dTCanopy ! derivative in the canopy transpiration flux w.r.t. canopy temperature + real(summa_prec) :: dLatHeatCanopyTrans_dTGround ! derivative in the canopy transpiration flux w.r.t. ground temperature ! local variables -- wetted fraction derivatives - real(dp) :: dLatHeatCanopyEvap_dWetFrac ! derivative in the latent heat of canopy evaporation w.r.t. canopy wet fraction (W m-2) - real(dp) :: dLatHeatCanopyTrans_dWetFrac ! derivative in the latent heat of canopy transpiration w.r.t. canopy wet fraction (W m-2) - real(dp) :: dLatHeatCanopyTrans_dCanLiq ! derivative in the latent heat of canopy transpiration w.r.t. canopy liquid water (J kg-1 s-1) + real(summa_prec) :: dLatHeatCanopyEvap_dWetFrac ! derivative in the latent heat of canopy evaporation w.r.t. canopy wet fraction (W m-2) + real(summa_prec) :: dLatHeatCanopyTrans_dWetFrac ! derivative in the latent heat of canopy transpiration w.r.t. canopy wet fraction (W m-2) + real(summa_prec) :: dLatHeatCanopyTrans_dCanLiq ! derivative in the latent heat of canopy transpiration w.r.t. canopy liquid water (J kg-1 s-1) ! ----------------------------------------------------------------------------------------------------------------------------------------- ! initialize error control err=0; message='turbFluxes/' @@ -2775,12 +2775,12 @@ subroutine turbFluxes(& if(computeVegFlux)then leafConductance = exposedVAI/leafResistance leafConductanceTr = canopySunlitLAI/(leafResistance+stomResistSunlit) + canopyShadedLAI/(leafResistance+stomResistShaded) - canopyConductance = 1._dp/canopyResistance + canopyConductance = 1._summa_prec/canopyResistance else - leafConductance = 0._dp - canopyConductance = 0._dp + leafConductance = 0._summa_prec + canopyConductance = 0._summa_prec end if - groundConductanceSH = 1._dp/groundResistance + groundConductanceSH = 1._summa_prec/groundResistance ! compute total conductance for sensible heat totalConductanceSH = leafConductance + groundConductanceSH + canopyConductance @@ -2788,14 +2788,14 @@ subroutine turbFluxes(& ! compute conductances for latent heat (m s-1) if(computeVegFlux)then evapConductance = canopyWetFraction*leafConductance - transConductance = (1._dp - canopyWetFraction) * leafConductanceTr + transConductance = (1._summa_prec - canopyWetFraction) * leafConductanceTr !write(*,'(a,10(f14.8,1x))') 'canopySunlitLAI, canopyShadedLAI, stomResistSunlit, stomResistShaded, leafResistance, canopyWetFraction = ', & ! canopySunlitLAI, canopyShadedLAI, stomResistSunlit, stomResistShaded, leafResistance, canopyWetFraction else - evapConductance = 0._dp - transConductance = 0._dp + evapConductance = 0._summa_prec + transConductance = 0._summa_prec end if - groundConductanceLH = 1._dp/(groundResistance + soilResistance) ! NOTE: soilResistance accounts for fractional snow, and =0 when snow cover is 100% + groundConductanceLH = 1._summa_prec/(groundResistance + soilResistance) ! NOTE: soilResistance accounts for fractional snow, and =0 when snow cover is 100% totalConductanceLH = evapConductance + transConductance + groundConductanceLH + canopyConductance ! check sensible heat conductance @@ -2818,30 +2818,30 @@ subroutine turbFluxes(& if(computeVegFlux)then dEvapCond_dCanopyTemp = dCanopyWetFraction_dT*leafConductance ! derivative in evap conductance w.r.t. canopy temperature dTransCond_dCanopyTemp = -dCanopyWetFraction_dT*leafConductanceTr ! derivative in trans conductance w.r.t. canopy temperature - dCanopyCond_dCanairTemp = -dCanopyResistance_dTCanair/canopyResistance**2._dp ! derivative in canopy conductance w.r.t. canopy air emperature - dCanopyCond_dCanopyTemp = -dCanopyResistance_dTCanopy/canopyResistance**2._dp ! derivative in canopy conductance w.r.t. canopy temperature - dGroundCondSH_dCanairTemp = -dGroundResistance_dTCanair/groundResistance**2._dp ! derivative in ground conductance w.r.t. canopy air temperature - dGroundCondSH_dCanopyTemp = -dGroundResistance_dTCanopy/groundResistance**2._dp ! derivative in ground conductance w.r.t. canopy temperature - dGroundCondSH_dGroundTemp = -dGroundResistance_dTGround/groundResistance**2._dp ! derivative in ground conductance w.r.t. ground temperature + dCanopyCond_dCanairTemp = -dCanopyResistance_dTCanair/canopyResistance**2._summa_prec ! derivative in canopy conductance w.r.t. canopy air emperature + dCanopyCond_dCanopyTemp = -dCanopyResistance_dTCanopy/canopyResistance**2._summa_prec ! derivative in canopy conductance w.r.t. canopy temperature + dGroundCondSH_dCanairTemp = -dGroundResistance_dTCanair/groundResistance**2._summa_prec ! derivative in ground conductance w.r.t. canopy air temperature + dGroundCondSH_dCanopyTemp = -dGroundResistance_dTCanopy/groundResistance**2._summa_prec ! derivative in ground conductance w.r.t. canopy temperature + dGroundCondSH_dGroundTemp = -dGroundResistance_dTGround/groundResistance**2._summa_prec ! derivative in ground conductance w.r.t. ground temperature else - dEvapCond_dCanopyTemp = 0._dp ! derivative in evap conductance w.r.t. canopy temperature - dTransCond_dCanopyTemp = 0._dp ! derivative in trans conductance w.r.t. canopy temperature - dCanopyCond_dCanairTemp = 0._dp ! derivative in canopy conductance w.r.t. canopy air emperature - dCanopyCond_dCanopyTemp = 0._dp ! derivative in canopy conductance w.r.t. canopy temperature - dGroundCondSH_dCanairTemp = 0._dp ! derivative in ground conductance w.r.t. canopy air temperature - dGroundCondSH_dCanopyTemp = 0._dp ! derivative in ground conductance w.r.t. canopy temperature - dGroundCondSH_dGroundTemp = -dGroundResistance_dTGround/groundResistance**2._dp ! derivative in ground conductance w.r.t. ground temperature + dEvapCond_dCanopyTemp = 0._summa_prec ! derivative in evap conductance w.r.t. canopy temperature + dTransCond_dCanopyTemp = 0._summa_prec ! derivative in trans conductance w.r.t. canopy temperature + dCanopyCond_dCanairTemp = 0._summa_prec ! derivative in canopy conductance w.r.t. canopy air emperature + dCanopyCond_dCanopyTemp = 0._summa_prec ! derivative in canopy conductance w.r.t. canopy temperature + dGroundCondSH_dCanairTemp = 0._summa_prec ! derivative in ground conductance w.r.t. canopy air temperature + dGroundCondSH_dCanopyTemp = 0._summa_prec ! derivative in ground conductance w.r.t. canopy temperature + dGroundCondSH_dGroundTemp = -dGroundResistance_dTGround/groundResistance**2._summa_prec ! derivative in ground conductance w.r.t. ground temperature end if ! compute derivatives in individual conductances for latent heat w.r.t. canopy temperature (m s-1 K-1) if(computeVegFlux)then - dGroundCondLH_dCanairTemp = -dGroundResistance_dTCanair/(groundResistance+soilResistance)**2._dp ! derivative in ground conductance w.r.t. canopy air temperature - dGroundCondLH_dCanopyTemp = -dGroundResistance_dTCanopy/(groundResistance+soilResistance)**2._dp ! derivative in ground conductance w.r.t. canopy temperature - dGroundCondLH_dGroundTemp = -dGroundResistance_dTGround/(groundResistance+soilResistance)**2._dp ! derivative in ground conductance w.r.t. ground temperature + dGroundCondLH_dCanairTemp = -dGroundResistance_dTCanair/(groundResistance+soilResistance)**2._summa_prec ! derivative in ground conductance w.r.t. canopy air temperature + dGroundCondLH_dCanopyTemp = -dGroundResistance_dTCanopy/(groundResistance+soilResistance)**2._summa_prec ! derivative in ground conductance w.r.t. canopy temperature + dGroundCondLH_dGroundTemp = -dGroundResistance_dTGround/(groundResistance+soilResistance)**2._summa_prec ! derivative in ground conductance w.r.t. ground temperature else - dGroundCondLH_dCanairTemp = 0._dp ! derivative in ground conductance w.r.t. canopy air temperature - dGroundCondLH_dCanopyTemp = 0._dp ! derivative in ground conductance w.r.t. canopy temperature - dGroundCondLH_dGroundTemp = -dGroundResistance_dTGround/(groundResistance+soilResistance)**2._dp ! derivative in ground conductance w.r.t. ground temperature + dGroundCondLH_dCanairTemp = 0._summa_prec ! derivative in ground conductance w.r.t. canopy air temperature + dGroundCondLH_dCanopyTemp = 0._summa_prec ! derivative in ground conductance w.r.t. canopy temperature + dGroundCondLH_dGroundTemp = -dGroundResistance_dTGround/(groundResistance+soilResistance)**2._summa_prec ! derivative in ground conductance w.r.t. ground temperature end if end if ! (if computing analytical derivatives) @@ -2885,9 +2885,9 @@ subroutine turbFluxes(& ! * no vegetation, so fluxes are zero else - senHeatCanopy = 0._dp - latHeatCanopyEvap = 0._dp - latHeatCanopyTrans = 0._dp + senHeatCanopy = 0._summa_prec + latHeatCanopyEvap = 0._summa_prec + latHeatCanopyTrans = 0._summa_prec end if ! compute sensible and latent heat fluxes from the ground to the canopy air space (W m-2) @@ -2914,20 +2914,20 @@ subroutine turbFluxes(& ! compute derivatives of vapor pressure in the canopy air space w.r.t. all state variables ! (derivative of vapor pressure in the canopy air space w.r.t. temperature of the canopy air space) dPart1 = dCanopyCond_dCanairTemp*VPair + dGroundCondLH_dCanairTemp*satVP_GroundTemp*soilRelHumidity - dPart2 = -(dCanopyCond_dCanairTemp + dGroundCondLH_dCanairTemp)/(totalConductanceLH**2._dp) + dPart2 = -(dCanopyCond_dCanairTemp + dGroundCondLH_dCanairTemp)/(totalConductanceLH**2._summa_prec) dVPCanopyAir_dTCanair = dPart1/totalConductanceLH + fPart_VP*dPart2 ! (derivative of vapor pressure in the canopy air space w.r.t. temperature of the canopy) dPart0 = (evapConductance + transConductance)*dSVPCanopy_dCanopyTemp + (dEvapCond_dCanopyTemp + dTransCond_dCanopyTemp)*satVP_CanopyTemp dPart1 = dCanopyCond_dCanopyTemp*VPair + dPart0 + dGroundCondLH_dCanopyTemp*satVP_GroundTemp*soilRelHumidity - dPart2 = -(dCanopyCond_dCanopyTemp + dEvapCond_dCanopyTemp + dTransCond_dCanopyTemp + dGroundCondLH_dCanopyTemp)/(totalConductanceLH**2._dp) + dPart2 = -(dCanopyCond_dCanopyTemp + dEvapCond_dCanopyTemp + dTransCond_dCanopyTemp + dGroundCondLH_dCanopyTemp)/(totalConductanceLH**2._summa_prec) dVPCanopyAir_dTCanopy = dPart1/totalConductanceLH + fPart_VP*dPart2 ! (derivative of vapor pressure in the canopy air space w.r.t. temperature of the ground) dPart1 = dGroundCondLH_dGroundTemp*satVP_GroundTemp*soilRelHumidity + groundConductanceLH*dSVPGround_dGroundTemp*soilRelHumidity - dPart2 = -dGroundCondLH_dGroundTemp/(totalConductanceLH**2._dp) + dPart2 = -dGroundCondLH_dGroundTemp/(totalConductanceLH**2._summa_prec) dVPCanopyAir_dTGround = dPart1/totalConductanceLH + fPart_VP*dPart2 ! (derivative of vapor pressure in the canopy air space w.r.t. wetted fraction of the canopy) dPart1 = (leafConductance - leafConductanceTr)*satVP_CanopyTemp - dPart2 = -(leafConductance - leafConductanceTr)/(totalConductanceLH**2._dp) + dPart2 = -(leafConductance - leafConductanceTr)/(totalConductanceLH**2._summa_prec) dVPCanopyAir_dWetFrac = dPart1/totalConductanceLH + fPart_VP*dPart2 dVPCanopyAir_dCanLiq = dVPCanopyAir_dWetFrac*dCanopyWetFraction_dWat !write(*,'(a,5(f20.8,1x))') 'dVPCanopyAir_dTCanair, dVPCanopyAir_dTCanopy, dVPCanopyAir_dTGround, dVPCanopyAir_dWetFrac, dVPCanopyAir_dCanLiq = ', & @@ -2936,14 +2936,14 @@ subroutine turbFluxes(& ! sensible heat from the canopy to the atmosphere dSenHeatTotal_dTCanair = -volHeatCapacityAir*canopyConductance - volHeatCapacityAir*dCanopyCond_dCanairTemp*(canairTemp - airtemp) dSenHeatTotal_dTCanopy = -volHeatCapacityAir*dCanopyCond_dCanopyTemp*(canairTemp - airtemp) - dSenHeatTotal_dTGround = 0._dp + dSenHeatTotal_dTGround = 0._summa_prec !write(*,'(a,3(f20.8,1x))') 'dSenHeatTotal_dTCanair, dSenHeatTotal_dTCanopy, dSenHeatTotal_dTGround = ', & ! dSenHeatTotal_dTCanair, dSenHeatTotal_dTCanopy, dSenHeatTotal_dTGround ! sensible heat from the canopy to the canopy air space dSenHeatCanopy_dTCanair = volHeatCapacityAir*leafConductance dSenHeatCanopy_dTCanopy = -volHeatCapacityAir*leafConductance - dSenHeatCanopy_dTGround = 0._dp + dSenHeatCanopy_dTGround = 0._summa_prec !write(*,'(a,3(f20.8,1x))') 'dSenHeatCanopy_dTCanair, dSenHeatCanopy_dTCanopy, dSenHeatCanopy_dTGround = ', & ! dSenHeatCanopy_dTCanair, dSenHeatCanopy_dTCanopy, dSenHeatCanopy_dTGround @@ -2994,7 +2994,7 @@ subroutine turbFluxes(& ! latent heat associated with canopy transpiration w.r.t. wetted fraction of the canopy dPart1 = LH_vap*latentHeatConstant*leafConductanceTr ! NOTE: positive, since (1 - wetFrac) - fPart1 = -dPart1*(1._dp - canopyWetFraction) + fPart1 = -dPart1*(1._summa_prec - canopyWetFraction) dLatHeatCanopyTrans_dWetFrac = dPart1*(satVP_CanopyTemp - VP_CanopyAir) + fPart1*(-dVPCanopyAir_dWetFrac) !print*, 'dLatHeatCanopyTrans_dWetFrac = ', dLatHeatCanopyTrans_dWetFrac @@ -3005,30 +3005,30 @@ subroutine turbFluxes(& else ! canopy is undefined ! set derivatives for canopy fluxes to zero (no canopy, so fluxes are undefined) - dSenHeatTotal_dTCanair = 0._dp - dSenHeatTotal_dTCanopy = 0._dp - dSenHeatTotal_dTGround = 0._dp - dSenHeatCanopy_dTCanair = 0._dp - dSenHeatCanopy_dTCanopy = 0._dp - dSenHeatCanopy_dTGround = 0._dp - dLatHeatCanopyEvap_dTCanair = 0._dp - dLatHeatCanopyEvap_dTCanopy = 0._dp - dLatHeatCanopyEvap_dTGround = 0._dp - dLatHeatCanopyTrans_dTCanair = 0._dp - dLatHeatCanopyTrans_dTCanopy = 0._dp - dLatHeatCanopyTrans_dTGround = 0._dp + dSenHeatTotal_dTCanair = 0._summa_prec + dSenHeatTotal_dTCanopy = 0._summa_prec + dSenHeatTotal_dTGround = 0._summa_prec + dSenHeatCanopy_dTCanair = 0._summa_prec + dSenHeatCanopy_dTCanopy = 0._summa_prec + dSenHeatCanopy_dTGround = 0._summa_prec + dLatHeatCanopyEvap_dTCanair = 0._summa_prec + dLatHeatCanopyEvap_dTCanopy = 0._summa_prec + dLatHeatCanopyEvap_dTGround = 0._summa_prec + dLatHeatCanopyTrans_dTCanair = 0._summa_prec + dLatHeatCanopyTrans_dTCanopy = 0._summa_prec + dLatHeatCanopyTrans_dTGround = 0._summa_prec ! set derivatives for wetted area and canopy transpiration to zero (no canopy, so fluxes are undefined) - dLatHeatCanopyEvap_dWetFrac = 0._dp - dLatHeatCanopyEvap_dCanLiq = 0._dp - dLatHeatCanopyTrans_dCanLiq = 0._dp - dVPCanopyAir_dCanLiq = 0._dp + dLatHeatCanopyEvap_dWetFrac = 0._summa_prec + dLatHeatCanopyEvap_dCanLiq = 0._summa_prec + dLatHeatCanopyTrans_dCanLiq = 0._summa_prec + dVPCanopyAir_dCanLiq = 0._summa_prec ! set derivatives for ground fluxes w.r.t canopy temperature to zero (no canopy, so fluxes are undefined) - dSenHeatGround_dTCanair = 0._dp - dSenHeatGround_dTCanopy = 0._dp - dLatHeatGroundEvap_dTCanair = 0._dp - dLatHeatGroundEvap_dTCanopy = 0._dp + dSenHeatGround_dTCanair = 0._summa_prec + dSenHeatGround_dTCanopy = 0._summa_prec + dLatHeatGroundEvap_dTCanair = 0._summa_prec + dLatHeatGroundEvap_dTCanopy = 0._summa_prec ! compute derivatives for the ground fluxes w.r.t. ground temperature dSenHeatGround_dTGround = (-volHeatCapacityAir*dGroundCondSH_dGroundTemp)*(groundTemp - airtemp) + & ! d(ground sensible heat flux)/d(ground temp) @@ -3069,27 +3069,27 @@ subroutine turbFluxes(& dLatHeatCanopyEvap_dCanLiq = dLatHeatCanopyEvap_dWetFrac*dCanopyWetFraction_dWat ! derivative in latent heat of canopy evaporation w.r.t. canopy liquid water (W kg-1) dLatHeatGroundEvap_dCanLiq = latHeatSubVapGround*latentHeatConstant*groundConductanceLH*dVPCanopyAir_dCanLiq ! derivative in latent heat of ground evaporation w.r.t. canopy liquid water (J kg-1 s-1) ! (cross deriavtives) - dTurbFluxCanair_dCanLiq = 0._dp ! derivative in net canopy air space fluxes w.r.t. canopy liquid water content (J kg-1 s-1) + dTurbFluxCanair_dCanLiq = 0._summa_prec ! derivative in net canopy air space fluxes w.r.t. canopy liquid water content (J kg-1 s-1) dTurbFluxCanopy_dCanLiq = dLatHeatCanopyEvap_dCanLiq + dLatHeatCanopyTrans_dCanLiq ! derivative in net canopy turbulent fluxes w.r.t. canopy liquid water content (J kg-1 s-1) dTurbFluxGround_dCanLiq = dLatHeatGroundEvap_dCanLiq ! derivative in net ground turbulent fluxes w.r.t. canopy liquid water content (J kg-1 s-1) else ! (just make sure we return something) ! (energy derivatives) - dTurbFluxCanair_dTCanair = 0._dp - dTurbFluxCanair_dTCanopy = 0._dp - dTurbFluxCanair_dTGround = 0._dp - dTurbFluxCanopy_dTCanair = 0._dp - dTurbFluxCanopy_dTCanopy = 0._dp - dTurbFluxCanopy_dTGround = 0._dp - dTurbFluxGround_dTCanair = 0._dp - dTurbFluxGround_dTCanopy = 0._dp - dTurbFluxGround_dTGround = 0._dp + dTurbFluxCanair_dTCanair = 0._summa_prec + dTurbFluxCanair_dTCanopy = 0._summa_prec + dTurbFluxCanair_dTGround = 0._summa_prec + dTurbFluxCanopy_dTCanair = 0._summa_prec + dTurbFluxCanopy_dTCanopy = 0._summa_prec + dTurbFluxCanopy_dTGround = 0._summa_prec + dTurbFluxGround_dTCanair = 0._summa_prec + dTurbFluxGround_dTCanopy = 0._summa_prec + dTurbFluxGround_dTGround = 0._summa_prec ! (liquid water derivatives) - dLatHeatCanopyEvap_dCanLiq = 0._dp - dLatHeatGroundEvap_dCanLiq = 0._dp + dLatHeatCanopyEvap_dCanLiq = 0._summa_prec + dLatHeatGroundEvap_dCanLiq = 0._summa_prec ! (cross deriavtives) - dTurbFluxCanair_dCanLiq = 0._dp - dTurbFluxCanopy_dCanLiq = 0._dp - dTurbFluxGround_dCanLiq = 0._dp + dTurbFluxCanair_dCanLiq = 0._summa_prec + dTurbFluxCanopy_dCanLiq = 0._summa_prec + dTurbFluxGround_dCanLiq = 0._summa_prec end if end subroutine turbFluxes @@ -3123,27 +3123,27 @@ subroutine aStability(& logical(lgt),intent(in) :: computeDerivative ! flag to compute the derivative integer(i4b),intent(in) :: ixStability ! choice of stability function ! input: forcing data, diagnostic and state variables - real(dp),intent(in) :: mHeight ! measurement height (m) - real(dp),intent(in) :: airtemp ! air temperature (K) - real(dp),intent(in) :: sfcTemp ! surface temperature (K) - real(dp),intent(in) :: windspd ! wind speed (m s-1) + real(summa_prec),intent(in) :: mHeight ! measurement height (m) + real(summa_prec),intent(in) :: airtemp ! air temperature (K) + real(summa_prec),intent(in) :: sfcTemp ! surface temperature (K) + real(summa_prec),intent(in) :: windspd ! wind speed (m s-1) ! input: stability parameters - real(dp),intent(in) :: critRichNumber ! critical value for the bulk Richardson number where turbulence ceases (-) - real(dp),intent(in) :: Louis79_bparam ! parameter in Louis (1979) stability function - real(dp),intent(in) :: Mahrt87_eScale ! exponential scaling factor in the Mahrt (1987) stability function + real(summa_prec),intent(in) :: critRichNumber ! critical value for the bulk Richardson number where turbulence ceases (-) + real(summa_prec),intent(in) :: Louis79_bparam ! parameter in Louis (1979) stability function + real(summa_prec),intent(in) :: Mahrt87_eScale ! exponential scaling factor in the Mahrt (1987) stability function ! output - real(dp),intent(out) :: RiBulk ! bulk Richardson number (-) - real(dp),intent(out) :: stabilityCorrection ! stability correction for turbulent heat fluxes (-) - real(dp),intent(out) :: dStabilityCorrection_dRich ! derivative in stability correction w.r.t. Richardson number (-) - real(dp),intent(out) :: dStabilityCorrection_dAirTemp ! derivative in stability correction w.r.t. air temperature (K-1) - real(dp),intent(out) :: dStabilityCorrection_dSfcTemp ! derivative in stability correction w.r.t. surface temperature (K-1) + real(summa_prec),intent(out) :: RiBulk ! bulk Richardson number (-) + real(summa_prec),intent(out) :: stabilityCorrection ! stability correction for turbulent heat fluxes (-) + real(summa_prec),intent(out) :: dStabilityCorrection_dRich ! derivative in stability correction w.r.t. Richardson number (-) + real(summa_prec),intent(out) :: dStabilityCorrection_dAirTemp ! derivative in stability correction w.r.t. air temperature (K-1) + real(summa_prec),intent(out) :: dStabilityCorrection_dSfcTemp ! derivative in stability correction w.r.t. surface temperature (K-1) integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! local - real(dp), parameter :: verySmall=1.e-10_dp ! a very small number (avoid stability of zero) - real(dp) :: dRiBulk_dAirTemp ! derivative in the bulk Richardson number w.r.t. air temperature (K-1) - real(dp) :: dRiBulk_dSfcTemp ! derivative in the bulk Richardson number w.r.t. surface temperature (K-1) - real(dp) :: bPrime ! scaled "b" parameter for stability calculations in Louis (1979) + real(summa_prec), parameter :: verySmall=1.e-10_summa_prec ! a very small number (avoid stability of zero) + real(summa_prec) :: dRiBulk_dAirTemp ! derivative in the bulk Richardson number w.r.t. air temperature (K-1) + real(summa_prec) :: dRiBulk_dSfcTemp ! derivative in the bulk Richardson number w.r.t. surface temperature (K-1) + real(summa_prec) :: bPrime ! scaled "b" parameter for stability calculations in Louis (1979) ! ----------------------------------------------------------------------------------------------------------------------------------------- ! initialize error control err=0; message='aStability/' @@ -3164,18 +3164,18 @@ subroutine aStability(& ! set derivative to one if not computing it if(.not.computeDerivative)then - dStabilityCorrection_dRich = 1._dp - dStabilityCorrection_dAirTemp = 1._dp - dStabilityCorrection_dSfcTemp = 1._dp + dStabilityCorrection_dRich = 1._summa_prec + dStabilityCorrection_dAirTemp = 1._summa_prec + dStabilityCorrection_dSfcTemp = 1._summa_prec end if ! ***** process unstable cases - if(RiBulk<0._dp)then + if(RiBulk<0._summa_prec)then ! compute surface-atmosphere exchange coefficient (-) - stabilityCorrection = (1._dp - 16._dp*RiBulk)**0.5_dp + stabilityCorrection = (1._summa_prec - 16._summa_prec*RiBulk)**0.5_summa_prec ! compute derivative in surface-atmosphere exchange coefficient w.r.t. temperature (K-1) if(computeDerivative)then - dStabilityCorrection_dRich = (-16._dp) * 0.5_dp*(1._dp - 16._dp*RiBulk)**(-0.5_dp) + dStabilityCorrection_dRich = (-16._summa_prec) * 0.5_summa_prec*(1._summa_prec - 16._summa_prec*RiBulk)**(-0.5_summa_prec) dStabilityCorrection_dAirTemp = dRiBulk_dAirTemp * dStabilityCorrection_dRich dStabilityCorrection_dSfcTemp = dRiBulk_dSfcTemp * dStabilityCorrection_dRich end if @@ -3188,24 +3188,24 @@ subroutine aStability(& ! ("standard" stability correction, a la Anderson 1976) case(standard) ! compute surface-atmosphere exchange coefficient (-) - if(RiBulk < critRichNumber) stabilityCorrection = (1._dp - 5._dp*RiBulk)**2._dp + if(RiBulk < critRichNumber) stabilityCorrection = (1._summa_prec - 5._summa_prec*RiBulk)**2._summa_prec if(RiBulk >= critRichNumber) stabilityCorrection = verySmall ! compute derivative in surface-atmosphere exchange coefficient w.r.t. temperature (K-1) if(computeDerivative)then - if(RiBulk < critRichNumber) dStabilityCorrection_dRich = (-5._dp) * 2._dp*(1._dp - 5._dp*RiBulk) + if(RiBulk < critRichNumber) dStabilityCorrection_dRich = (-5._summa_prec) * 2._summa_prec*(1._summa_prec - 5._summa_prec*RiBulk) if(RiBulk >= critRichNumber) dStabilityCorrection_dRich = verySmall end if ! (Louis 1979) case(louisInversePower) ! scale the "b" parameter for stable conditions - bprime = Louis79_bparam/2._dp + bprime = Louis79_bparam/2._summa_prec ! compute surface-atmosphere exchange coefficient (-) - stabilityCorrection = 1._dp / ( (1._dp + bprime*RiBulk)**2._dp ) + stabilityCorrection = 1._summa_prec / ( (1._summa_prec + bprime*RiBulk)**2._summa_prec ) if(stabilityCorrection < epsilon(stabilityCorrection)) stabilityCorrection = epsilon(stabilityCorrection) ! compute derivative in surface-atmosphere exchange coefficient w.r.t. temperature (K-1) if(computeDerivative)then - dStabilityCorrection_dRich = bprime * (-2._dp)*(1._dp + bprime*RiBulk)**(-3._dp) + dStabilityCorrection_dRich = bprime * (-2._summa_prec)*(1._summa_prec + bprime*RiBulk)**(-3._summa_prec) end if ! (Mahrt 1987) @@ -3251,36 +3251,36 @@ subroutine bulkRichardson(& err,message) ! output: error control implicit none ! input - real(dp),intent(in) :: airtemp ! air temperature (K) - real(dp),intent(in) :: sfcTemp ! surface temperature (K) - real(dp),intent(in) :: windspd ! wind speed (m s-1) - real(dp),intent(in) :: mHeight ! measurement height (m) + real(summa_prec),intent(in) :: airtemp ! air temperature (K) + real(summa_prec),intent(in) :: sfcTemp ! surface temperature (K) + real(summa_prec),intent(in) :: windspd ! wind speed (m s-1) + real(summa_prec),intent(in) :: mHeight ! measurement height (m) logical(lgt),intent(in) :: computeDerivative ! flag to compute the derivative ! output - real(dp),intent(inout) :: RiBulk ! bulk Richardson number (-) - real(dp),intent(out) :: dRiBulk_dAirTemp ! derivative in the bulk Richardson number w.r.t. air temperature (K-1) - real(dp),intent(out) :: dRiBulk_dSfcTemp ! derivative in the bulk Richardson number w.r.t. surface temperature (K-1) + real(summa_prec),intent(inout) :: RiBulk ! bulk Richardson number (-) + real(summa_prec),intent(out) :: dRiBulk_dAirTemp ! derivative in the bulk Richardson number w.r.t. air temperature (K-1) + real(summa_prec),intent(out) :: dRiBulk_dSfcTemp ! derivative in the bulk Richardson number w.r.t. surface temperature (K-1) integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! local variables - real(dp) :: T_grad ! gradient in temperature between the atmosphere and surface (K) - real(dp) :: T_mean ! mean of the atmosphere and surface temperature (K) - real(dp) :: RiMult ! dimensionless scaling factor (-) + real(summa_prec) :: T_grad ! gradient in temperature between the atmosphere and surface (K) + real(summa_prec) :: T_mean ! mean of the atmosphere and surface temperature (K) + real(summa_prec) :: RiMult ! dimensionless scaling factor (-) ! initialize error control err=0; message='bulkRichardson/' ! compute local variables T_grad = airtemp - sfcTemp - T_mean = 0.5_dp*(airtemp + sfcTemp) + T_mean = 0.5_summa_prec*(airtemp + sfcTemp) RiMult = (gravity*mHeight)/(windspd*windspd) ! compute the Richardson number RiBulk = (T_grad/T_mean) * RiMult ! compute the derivative in the Richardson number if(computeDerivative)then - dRiBulk_dAirTemp = RiMult/T_mean - RiMult*T_grad/(0.5_dp*((airtemp + sfcTemp)**2._dp)) - dRiBulk_dSfcTemp = -RiMult/T_mean - RiMult*T_grad/(0.5_dp*((airtemp + sfcTemp)**2._dp)) + dRiBulk_dAirTemp = RiMult/T_mean - RiMult*T_grad/(0.5_summa_prec*((airtemp + sfcTemp)**2._summa_prec)) + dRiBulk_dSfcTemp = -RiMult/T_mean - RiMult*T_grad/(0.5_summa_prec*((airtemp + sfcTemp)**2._summa_prec)) else - dRiBulk_dAirTemp = 1._dp - dRiBulk_dSfcTemp = 1._dp + dRiBulk_dAirTemp = 1._summa_prec + dRiBulk_dSfcTemp = 1._summa_prec end if end subroutine bulkRichardson diff --git a/build/source/engine/vegPhenlgy.f90 b/build/source/engine/vegPhenlgy.f90 index cf92d886e..f46f7fd5e 100755 --- a/build/source/engine/vegPhenlgy.f90 +++ b/build/source/engine/vegPhenlgy.f90 @@ -58,8 +58,8 @@ module vegPhenlgy_module private public::vegPhenlgy ! algorithmic parameters -real(dp),parameter :: valueMissing=-9999._dp ! missing value, used when diagnostic or state variables are undefined -real(dp),parameter :: verySmall=1.e-6_dp ! used as an additive constant to check if substantial difference among real numbers +real(summa_prec),parameter :: valueMissing=-9999._summa_prec ! missing value, used when diagnostic or state variables are undefined +real(summa_prec),parameter :: verySmall=1.e-6_summa_prec ! used as an additive constant to check if substantial difference among real numbers contains @@ -93,14 +93,14 @@ subroutine vegPhenlgy(& type(var_dlength),intent(inout) :: diag_data ! diagnostic variables for a local HRU ! output logical(lgt),intent(out) :: computeVegFlux ! flag to indicate if we are computing fluxes over vegetation (.false. means veg is buried with snow) - real(dp),intent(out) :: canopyDepth ! canopy depth (m) - real(dp),intent(out) :: exposedVAI ! exposed vegetation area index (LAI + SAI) + real(summa_prec),intent(out) :: canopyDepth ! canopy depth (m) + real(summa_prec),intent(out) :: exposedVAI ! exposed vegetation area index (LAI + SAI) integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! ------------------------------------------------------------------------------------------------- ! local - real(dp) :: notUsed_heightCanopyTop ! height of the top of the canopy layer (m) - real(dp) :: heightAboveSnow ! height top of canopy is above the snow surface (m) + real(summa_prec) :: notUsed_heightCanopyTop ! height of the top of the canopy layer (m) + real(summa_prec) :: heightAboveSnow ! height top of canopy is above the snow surface (m) ! initialize error control err=0; message="vegPhenlgy/" ! ---------------------------------------------------------------------------------------------------------------------------------- @@ -181,7 +181,7 @@ subroutine vegPhenlgy(& heightAboveSnow = heightCanopyTop - scalarSnowDepth ! height top of canopy is above the snow surface (m) ! determine if need to include vegetation in the energy flux routines - computeVegFlux = (exposedVAI > 0.05_dp .and. heightAboveSnow > 0.05_dp) + computeVegFlux = (exposedVAI > 0.05_summa_prec .and. heightAboveSnow > 0.05_summa_prec) !write(*,'(a,1x,i2,1x,L1,1x,10(f12.5,1x))') 'vegTypeIndex, computeVegFlux, heightCanopyTop, heightAboveSnow, scalarSnowDepth = ', & ! vegTypeIndex, computeVegFlux, heightCanopyTop, heightAboveSnow, scalarSnowDepth diff --git a/build/source/engine/vegSWavRad.f90 b/build/source/engine/vegSWavRad.f90 index c9f72b9b4..72f6c789a 100755 --- a/build/source/engine/vegSWavRad.f90 +++ b/build/source/engine/vegSWavRad.f90 @@ -58,10 +58,10 @@ module vegSWavRad_module integer(i4b),parameter :: iLoc = 1 ! i-location integer(i4b),parameter :: jLoc = 1 ! j-location ! algorithmic parameters -real(dp),parameter :: missingValue=-9999._dp ! missing value, used when diagnostic or state variables are undefined -real(dp),parameter :: verySmall=1.e-6_dp ! used as an additive constant to check if substantial difference among real numbers -real(dp),parameter :: mpe=1.e-6_dp ! prevents overflow error if division by zero -real(dp),parameter :: dx=1.e-6_dp ! finite difference increment +real(summa_prec),parameter :: missingValue=-9999._summa_prec ! missing value, used when diagnostic or state variables are undefined +real(summa_prec),parameter :: verySmall=1.e-6_summa_prec ! used as an additive constant to check if substantial difference among real numbers +real(summa_prec),parameter :: mpe=1.e-6_summa_prec ! prevents overflow error if division by zero +real(summa_prec),parameter :: dx=1.e-6_summa_prec ! finite difference increment contains @@ -83,7 +83,7 @@ subroutine vegSWavRad(& USE NOAHMP_ROUTINES,only:radiation ! subroutine to calculate albedo and shortwave radiaiton in the canopy implicit none ! dummy variables - real(dp),intent(in) :: dt ! time step (s) -- only used in Noah-MP radiation, to compute albedo + real(summa_prec),intent(in) :: dt ! time step (s) -- only used in Noah-MP radiation, to compute albedo integer(i4b),intent(in) :: nSnow ! number of snow layers integer(i4b),intent(in) :: nSoil ! number of soil layers integer(i4b),intent(in) :: nLayers ! total number of layers @@ -96,15 +96,15 @@ subroutine vegSWavRad(& character(*),intent(out) :: message ! error message ! local variables character(LEN=256) :: cmessage ! error message of downwind routine - real(dp) :: snowmassPlusNewsnow ! sum of snow mass and new snowfall (kg m-2 [mm]) - real(dp) :: scalarGroundSnowFraction ! snow cover fraction on the ground surface (-) - real(dp),parameter :: scalarVegFraction=1._dp ! vegetation fraction (=1 forces no canopy gaps and open areas in radiation routine) - real(dp) :: scalarTotalReflectedSolar ! total reflected solar radiation (W m-2) - real(dp) :: scalarTotalAbsorbedSolar ! total absorbed solar radiation (W m-2) - real(dp) :: scalarCanopyReflectedSolar ! solar radiation reflected from the canopy (W m-2) - real(dp) :: scalarGroundReflectedSolar ! solar radiation reflected from the ground (W m-2) - real(dp) :: scalarBetweenCanopyGapFraction ! between canopy gap fraction for beam (-) - real(dp) :: scalarWithinCanopyGapFraction ! within canopy gap fraction for beam (-) + real(summa_prec) :: snowmassPlusNewsnow ! sum of snow mass and new snowfall (kg m-2 [mm]) + real(summa_prec) :: scalarGroundSnowFraction ! snow cover fraction on the ground surface (-) + real(summa_prec),parameter :: scalarVegFraction=1._summa_prec ! vegetation fraction (=1 forces no canopy gaps and open areas in radiation routine) + real(summa_prec) :: scalarTotalReflectedSolar ! total reflected solar radiation (W m-2) + real(summa_prec) :: scalarTotalAbsorbedSolar ! total absorbed solar radiation (W m-2) + real(summa_prec) :: scalarCanopyReflectedSolar ! solar radiation reflected from the canopy (W m-2) + real(summa_prec) :: scalarGroundReflectedSolar ! solar radiation reflected from the ground (W m-2) + real(summa_prec) :: scalarBetweenCanopyGapFraction ! between canopy gap fraction for beam (-) + real(summa_prec) :: scalarWithinCanopyGapFraction ! within canopy gap fraction for beam (-) ! ---------------------------------------------------------------------------------------------------------------------------------- ! make association between local variables and the information in the data structures associate(& @@ -160,9 +160,9 @@ subroutine vegSWavRad(& ! compute the ground snow fraction if(nSnow > 0)then - scalarGroundSnowFraction = 1._dp + scalarGroundSnowFraction = 1._summa_prec else - scalarGroundSnowFraction = 0._dp + scalarGroundSnowFraction = 0._summa_prec end if ! (if there is snow on the ground) ! * compute radiation fluxes... @@ -182,7 +182,7 @@ subroutine vegSWavRad(& snowmassPlusNewsnow, & ! intent(in): sum of snow mass and new snowfall (kg m-2 [mm]) dt, & ! intent(in): time step (s) scalarCosZenith, & ! intent(in): cosine of the solar zenith angle (0-1) - scalarSnowDepth*1000._dp, & ! intent(in): snow depth on the ground surface (mm) + scalarSnowDepth*1000._summa_prec, & ! intent(in): snow depth on the ground surface (mm) scalarGroundTemp, & ! intent(in): ground temperature (K) scalarCanopyTemp, & ! intent(in): canopy temperature (K) scalarGroundSnowFraction, & ! intent(in): snow cover fraction (0-1) @@ -311,32 +311,32 @@ subroutine canopy_SW(& integer(i4b),intent(in) :: isc ! soil color index logical(lgt),intent(in) :: computeVegFlux ! logical flag to compute vegetation fluxes (.false. if veg buried by snow) integer(i4b),intent(in) :: ix_canopySrad ! choice of canopy shortwave radiation method - real(dp),intent(in) :: scalarCosZenith ! cosine of the solar zenith angle (0-1) - real(dp),intent(in) :: spectralIncomingDirect(:) ! incoming direct solar radiation in each wave band (w m-2) - real(dp),intent(in) :: spectralIncomingDiffuse(:) ! incoming diffuse solar radiation in each wave band (w m-2) - real(dp),intent(in) :: spectralSnowAlbedoDirect(:) ! direct albedo of snow in each spectral band (-) - real(dp),intent(in) :: spectralSnowAlbedoDiffuse(:) ! diffuse albedo of snow in each spectral band (-) - real(dp),intent(in) :: scalarExposedLAI ! exposed leaf area index after burial by snow (m2 m-2) - real(dp),intent(in) :: scalarExposedSAI ! exposed stem area index after burial by snow (m2 m-2) - real(dp),intent(in) :: scalarVegFraction ! vegetation fraction (=1 forces no canopy gaps and open areas in radiation routine) - real(dp),intent(in) :: scalarCanopyWetFraction ! fraction of canopy that is wet (-) - real(dp),intent(in) :: scalarGroundSnowFraction ! fraction of ground that is snow covered (-) - real(dp),intent(in) :: scalarVolFracLiqUpper ! volumetric liquid water content in the upper-most soil layer (-) - real(dp),intent(in) :: scalarCanopyTempTrial ! trial value of canopy temperature (K) + real(summa_prec),intent(in) :: scalarCosZenith ! cosine of the solar zenith angle (0-1) + real(summa_prec),intent(in) :: spectralIncomingDirect(:) ! incoming direct solar radiation in each wave band (w m-2) + real(summa_prec),intent(in) :: spectralIncomingDiffuse(:) ! incoming diffuse solar radiation in each wave band (w m-2) + real(summa_prec),intent(in) :: spectralSnowAlbedoDirect(:) ! direct albedo of snow in each spectral band (-) + real(summa_prec),intent(in) :: spectralSnowAlbedoDiffuse(:) ! diffuse albedo of snow in each spectral band (-) + real(summa_prec),intent(in) :: scalarExposedLAI ! exposed leaf area index after burial by snow (m2 m-2) + real(summa_prec),intent(in) :: scalarExposedSAI ! exposed stem area index after burial by snow (m2 m-2) + real(summa_prec),intent(in) :: scalarVegFraction ! vegetation fraction (=1 forces no canopy gaps and open areas in radiation routine) + real(summa_prec),intent(in) :: scalarCanopyWetFraction ! fraction of canopy that is wet (-) + real(summa_prec),intent(in) :: scalarGroundSnowFraction ! fraction of ground that is snow covered (-) + real(summa_prec),intent(in) :: scalarVolFracLiqUpper ! volumetric liquid water content in the upper-most soil layer (-) + real(summa_prec),intent(in) :: scalarCanopyTempTrial ! trial value of canopy temperature (K) ! output - real(dp),intent(out) :: spectralBelowCanopyDirect(:) ! downward direct flux below veg layer (W m-2) - real(dp),intent(out) :: spectralBelowCanopyDiffuse(:) ! downward diffuse flux below veg layer (W m-2) - real(dp),intent(out) :: scalarBelowCanopySolar ! radiation transmitted below the canopy (W m-2) - real(dp),intent(out) :: spectralAlbGndDirect(:) ! direct albedo of underlying surface (1:nBands) (-) - real(dp),intent(out) :: spectralAlbGndDiffuse(:) ! diffuse albedo of underlying surface (1:nBands) (-) - real(dp),intent(out) :: scalarGroundAlbedo ! albedo of the ground surface (-) - real(dp),intent(out) :: scalarCanopyAbsorbedSolar ! radiation absorbed by the vegetation canopy (W m-2) - real(dp),intent(out) :: scalarGroundAbsorbedSolar ! radiation absorbed by the ground (W m-2) - real(dp),intent(out) :: scalarCanopySunlitFraction ! sunlit fraction of canopy (-) - real(dp),intent(out) :: scalarCanopySunlitLAI ! sunlit leaf area (-) - real(dp),intent(out) :: scalarCanopyShadedLAI ! shaded leaf area (-) - real(dp),intent(out) :: scalarCanopySunlitPAR ! average absorbed par for sunlit leaves (w m-2) - real(dp),intent(out) :: scalarCanopyShadedPAR ! average absorbed par for shaded leaves (w m-2) + real(summa_prec),intent(out) :: spectralBelowCanopyDirect(:) ! downward direct flux below veg layer (W m-2) + real(summa_prec),intent(out) :: spectralBelowCanopyDiffuse(:) ! downward diffuse flux below veg layer (W m-2) + real(summa_prec),intent(out) :: scalarBelowCanopySolar ! radiation transmitted below the canopy (W m-2) + real(summa_prec),intent(out) :: spectralAlbGndDirect(:) ! direct albedo of underlying surface (1:nBands) (-) + real(summa_prec),intent(out) :: spectralAlbGndDiffuse(:) ! diffuse albedo of underlying surface (1:nBands) (-) + real(summa_prec),intent(out) :: scalarGroundAlbedo ! albedo of the ground surface (-) + real(summa_prec),intent(out) :: scalarCanopyAbsorbedSolar ! radiation absorbed by the vegetation canopy (W m-2) + real(summa_prec),intent(out) :: scalarGroundAbsorbedSolar ! radiation absorbed by the ground (W m-2) + real(summa_prec),intent(out) :: scalarCanopySunlitFraction ! sunlit fraction of canopy (-) + real(summa_prec),intent(out) :: scalarCanopySunlitLAI ! sunlit leaf area (-) + real(summa_prec),intent(out) :: scalarCanopyShadedLAI ! shaded leaf area (-) + real(summa_prec),intent(out) :: scalarCanopySunlitPAR ! average absorbed par for sunlit leaves (w m-2) + real(summa_prec),intent(out) :: scalarCanopyShadedPAR ! average absorbed par for shaded leaves (w m-2) integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! ----------------------------------------------------------------------------------------------------------------------------------------------------------------- @@ -349,72 +349,72 @@ subroutine canopy_SW(& integer(i4b) :: ic ! 0=unit incoming direct; 1=unit incoming diffuse character(LEN=256) :: cmessage ! error message of downwind routine ! variables used in Nijssen-Lettenmaier method - real(dp),parameter :: multScatExp=0.81_dp ! multiple scattering exponent (-) - real(dp),parameter :: bulkCanopyAlbedo=0.25_dp ! bulk canopy albedo (-), smaller than actual canopy albedo because of shading in the canopy - real(dp),dimension(1:nBands) :: spectralIncomingSolar ! total incoming solar radiation in each spectral band (W m-2) - real(dp),dimension(1:nBands) :: spectralGroundAbsorbedDirect ! total direct radiation absorbed at the ground surface (W m-2) - real(dp),dimension(1:nBands) :: spectralGroundAbsorbedDiffuse ! total diffuse radiation absorbed at the ground surface (W m-2) - real(dp) :: Fdirect ! fraction of direct radiation (-) - real(dp) :: tauInitial ! transmission in the absence of scattering and multiple reflections (-) - real(dp) :: tauTotal ! transmission due to scattering and multiple reflections (-) + real(summa_prec),parameter :: multScatExp=0.81_summa_prec ! multiple scattering exponent (-) + real(summa_prec),parameter :: bulkCanopyAlbedo=0.25_summa_prec ! bulk canopy albedo (-), smaller than actual canopy albedo because of shading in the canopy + real(summa_prec),dimension(1:nBands) :: spectralIncomingSolar ! total incoming solar radiation in each spectral band (W m-2) + real(summa_prec),dimension(1:nBands) :: spectralGroundAbsorbedDirect ! total direct radiation absorbed at the ground surface (W m-2) + real(summa_prec),dimension(1:nBands) :: spectralGroundAbsorbedDiffuse ! total diffuse radiation absorbed at the ground surface (W m-2) + real(summa_prec) :: Fdirect ! fraction of direct radiation (-) + real(summa_prec) :: tauInitial ! transmission in the absence of scattering and multiple reflections (-) + real(summa_prec) :: tauTotal ! transmission due to scattering and multiple reflections (-) ! variables used in Mahat-Tarboton method - real(dp),parameter :: Frad_vis=0.5_dp ! fraction of radiation in the visible wave band (-) - real(dp),parameter :: gProjParam=0.5_dp ! projected leaf and stem area in the solar direction (-) - real(dp),parameter :: bScatParam=0.5_dp ! back scatter parameter (-) - real(dp) :: transCoef ! transmission coefficient (-) - real(dp) :: transCoefPrime ! "k-prime" coefficient (-) - real(dp) :: groundAlbedoDirect ! direct ground albedo (-) - real(dp) :: groundAlbedoDiffuse ! diffuse ground albedo (-) - real(dp) :: tauInfinite ! direct transmission for an infinite canopy (-) - real(dp) :: betaInfinite ! direct upward reflection factor for an infinite canopy (-) - real(dp) :: tauFinite ! direct transmission for a finite canopy (-) - real(dp) :: betaFinite ! direct reflectance for a finite canopy (-) - real(dp) :: vFactor ! scaled vegetation area used to compute diffuse radiation (-) - real(dp) :: expi ! exponential integral (-) - real(dp) :: taudInfinite ! diffuse transmission for an infinite canopy (-) - real(dp) :: taudFinite ! diffuse transmission for a finite canopy (-) - real(dp) :: betadFinite ! diffuse reflectance for a finite canopy (-) - real(dp) :: refMult ! multiple reflection factor (-) - real(dp) :: fracRadAbsDown ! fraction of radiation absorbed by vegetation on the way down - real(dp) :: fracRadAbsUp ! fraction of radiation absorbed by vegetation on the way up - real(dp) :: tauDirect ! total transmission of direct radiation (-) - real(dp) :: tauDiffuse ! total transmission of diffuse radiation (-) - real(dp) :: fractionRefDirect ! fraction of direct radiaiton lost to space (-) - real(dp) :: fractionRefDiffuse ! fraction of diffuse radiaiton lost to space (-) - real(dp),dimension(1:nBands) :: spectralBelowCanopySolar ! total below-canopy radiation for each wave band (W m-2) - real(dp),dimension(1:nBands) :: spectralTotalReflectedSolar ! total reflected radiaion for each wave band (W m-2) - real(dp),dimension(1:nBands) :: spectralGroundAbsorbedSolar ! radiation absorbed by the ground in each wave band (W m-2) - real(dp),dimension(1:nBands) :: spectralCanopyAbsorbedSolar ! radiation absorbed by the canopy in each wave band (W m-2) + real(summa_prec),parameter :: Frad_vis=0.5_summa_prec ! fraction of radiation in the visible wave band (-) + real(summa_prec),parameter :: gProjParam=0.5_summa_prec ! projected leaf and stem area in the solar direction (-) + real(summa_prec),parameter :: bScatParam=0.5_summa_prec ! back scatter parameter (-) + real(summa_prec) :: transCoef ! transmission coefficient (-) + real(summa_prec) :: transCoefPrime ! "k-prime" coefficient (-) + real(summa_prec) :: groundAlbedoDirect ! direct ground albedo (-) + real(summa_prec) :: groundAlbedoDiffuse ! diffuse ground albedo (-) + real(summa_prec) :: tauInfinite ! direct transmission for an infinite canopy (-) + real(summa_prec) :: betaInfinite ! direct upward reflection factor for an infinite canopy (-) + real(summa_prec) :: tauFinite ! direct transmission for a finite canopy (-) + real(summa_prec) :: betaFinite ! direct reflectance for a finite canopy (-) + real(summa_prec) :: vFactor ! scaled vegetation area used to compute diffuse radiation (-) + real(summa_prec) :: expi ! exponential integral (-) + real(summa_prec) :: taudInfinite ! diffuse transmission for an infinite canopy (-) + real(summa_prec) :: taudFinite ! diffuse transmission for a finite canopy (-) + real(summa_prec) :: betadFinite ! diffuse reflectance for a finite canopy (-) + real(summa_prec) :: refMult ! multiple reflection factor (-) + real(summa_prec) :: fracRadAbsDown ! fraction of radiation absorbed by vegetation on the way down + real(summa_prec) :: fracRadAbsUp ! fraction of radiation absorbed by vegetation on the way up + real(summa_prec) :: tauDirect ! total transmission of direct radiation (-) + real(summa_prec) :: tauDiffuse ! total transmission of diffuse radiation (-) + real(summa_prec) :: fractionRefDirect ! fraction of direct radiaiton lost to space (-) + real(summa_prec) :: fractionRefDiffuse ! fraction of diffuse radiaiton lost to space (-) + real(summa_prec),dimension(1:nBands) :: spectralBelowCanopySolar ! total below-canopy radiation for each wave band (W m-2) + real(summa_prec),dimension(1:nBands) :: spectralTotalReflectedSolar ! total reflected radiaion for each wave band (W m-2) + real(summa_prec),dimension(1:nBands) :: spectralGroundAbsorbedSolar ! radiation absorbed by the ground in each wave band (W m-2) + real(summa_prec),dimension(1:nBands) :: spectralCanopyAbsorbedSolar ! radiation absorbed by the canopy in each wave band (W m-2) ! vegetation properties used in 2-stream - real(dp) :: scalarExposedVAI ! one-sided leaf+stem area index (m2/m2) - real(dp) :: weightLeaf ! fraction of exposed VAI that is leaf - real(dp) :: weightStem ! fraction of exposed VAI that is stem - real(dp),dimension(1:nBands) :: spectralVegReflc ! leaf+stem reflectance (1:nbands) - real(dp),dimension(1:nBands) :: spectralVegTrans ! leaf+stem transmittance (1:nBands) + real(summa_prec) :: scalarExposedVAI ! one-sided leaf+stem area index (m2/m2) + real(summa_prec) :: weightLeaf ! fraction of exposed VAI that is leaf + real(summa_prec) :: weightStem ! fraction of exposed VAI that is stem + real(summa_prec),dimension(1:nBands) :: spectralVegReflc ! leaf+stem reflectance (1:nbands) + real(summa_prec),dimension(1:nBands) :: spectralVegTrans ! leaf+stem transmittance (1:nBands) ! output from two-stream -- direct-beam - real(dp),dimension(1:nBands) :: spectralCanopyAbsorbedDirect ! flux abs by veg layer (per unit incoming flux), (1:nBands) - real(dp),dimension(1:nBands) :: spectralTotalReflectedDirect ! flux refl above veg layer (per unit incoming flux), (1:nBands) - real(dp),dimension(1:nBands) :: spectralDirectBelowCanopyDirect ! down dir flux below veg layer (per unit in flux), (1:nBands) - real(dp),dimension(1:nBands) :: spectralDiffuseBelowCanopyDirect ! down dif flux below veg layer (per unit in flux), (1:nBands) - real(dp),dimension(1:nBands) :: spectralCanopyReflectedDirect ! flux reflected by veg layer (per unit incoming flux), (1:nBands) - real(dp),dimension(1:nBands) :: spectralGroundReflectedDirect ! flux reflected by ground (per unit incoming flux), (1:nBands) + real(summa_prec),dimension(1:nBands) :: spectralCanopyAbsorbedDirect ! flux abs by veg layer (per unit incoming flux), (1:nBands) + real(summa_prec),dimension(1:nBands) :: spectralTotalReflectedDirect ! flux refl above veg layer (per unit incoming flux), (1:nBands) + real(summa_prec),dimension(1:nBands) :: spectralDirectBelowCanopyDirect ! down dir flux below veg layer (per unit in flux), (1:nBands) + real(summa_prec),dimension(1:nBands) :: spectralDiffuseBelowCanopyDirect ! down dif flux below veg layer (per unit in flux), (1:nBands) + real(summa_prec),dimension(1:nBands) :: spectralCanopyReflectedDirect ! flux reflected by veg layer (per unit incoming flux), (1:nBands) + real(summa_prec),dimension(1:nBands) :: spectralGroundReflectedDirect ! flux reflected by ground (per unit incoming flux), (1:nBands) ! output from two-stream -- diffuse - real(dp),dimension(1:nBands) :: spectralCanopyAbsorbedDiffuse ! flux abs by veg layer (per unit incoming flux), (1:nBands) - real(dp),dimension(1:nBands) :: spectralTotalReflectedDiffuse ! flux refl above veg layer (per unit incoming flux), (1:nBands) - real(dp),dimension(1:nBands) :: spectralDirectBelowCanopyDiffuse ! down dir flux below veg layer (per unit in flux), (1:nBands) - real(dp),dimension(1:nBands) :: spectralDiffuseBelowCanopyDiffuse ! down dif flux below veg layer (per unit in flux), (1:nBands) - real(dp),dimension(1:nBands) :: spectralCanopyReflectedDiffuse ! flux reflected by veg layer (per unit incoming flux), (1:nBands) - real(dp),dimension(1:nBands) :: spectralGroundReflectedDiffuse ! flux reflected by ground (per unit incoming flux), (1:nBands) + real(summa_prec),dimension(1:nBands) :: spectralCanopyAbsorbedDiffuse ! flux abs by veg layer (per unit incoming flux), (1:nBands) + real(summa_prec),dimension(1:nBands) :: spectralTotalReflectedDiffuse ! flux refl above veg layer (per unit incoming flux), (1:nBands) + real(summa_prec),dimension(1:nBands) :: spectralDirectBelowCanopyDiffuse ! down dir flux below veg layer (per unit in flux), (1:nBands) + real(summa_prec),dimension(1:nBands) :: spectralDiffuseBelowCanopyDiffuse ! down dif flux below veg layer (per unit in flux), (1:nBands) + real(summa_prec),dimension(1:nBands) :: spectralCanopyReflectedDiffuse ! flux reflected by veg layer (per unit incoming flux), (1:nBands) + real(summa_prec),dimension(1:nBands) :: spectralGroundReflectedDiffuse ! flux reflected by ground (per unit incoming flux), (1:nBands) ! output from two-stream -- scalar variables - real(dp) :: scalarGproj ! projected leaf+stem area in solar direction - real(dp) :: scalarBetweenCanopyGapFraction ! between canopy gap fraction for beam (-) - real(dp) :: scalarWithinCanopyGapFraction ! within canopy gap fraction for beam (-) + real(summa_prec) :: scalarGproj ! projected leaf+stem area in solar direction + real(summa_prec) :: scalarBetweenCanopyGapFraction ! between canopy gap fraction for beam (-) + real(summa_prec) :: scalarWithinCanopyGapFraction ! within canopy gap fraction for beam (-) ! radiation fluxes - real(dp) :: ext ! optical depth of direct beam per unit leaf + stem area - real(dp) :: scalarCanopyShadedFraction ! shaded fraction of the canopy - real(dp) :: fractionLAI ! fraction of vegetation that is leaves - real(dp) :: visibleAbsDirect ! direct-beam radiation absorbed in the visible part of the spectrum (W m-2) - real(dp) :: visibleAbsDiffuse ! diffuse radiation absorbed in the visible part of the spectrum (W m-2) + real(summa_prec) :: ext ! optical depth of direct beam per unit leaf + stem area + real(summa_prec) :: scalarCanopyShadedFraction ! shaded fraction of the canopy + real(summa_prec) :: fractionLAI ! fraction of vegetation that is leaves + real(summa_prec) :: visibleAbsDirect ! direct-beam radiation absorbed in the visible part of the spectrum (W m-2) + real(summa_prec) :: visibleAbsDiffuse ! diffuse radiation absorbed in the visible part of the spectrum (W m-2) ! ----------------------------------------------------------------------------------------------------------------------------------------------------------------- ! initialize error control err=0; message='canopy_SW/' @@ -434,18 +434,18 @@ subroutine canopy_SW(& if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! initialize accumulated fluxes - scalarBelowCanopySolar = 0._dp ! radiation transmitted below the canopy (W m-2) - scalarCanopyAbsorbedSolar = 0._dp ! radiation absorbed by the vegetation canopy (W m-2) - scalarGroundAbsorbedSolar = 0._dp ! radiation absorbed by the ground (W m-2) + scalarBelowCanopySolar = 0._summa_prec ! radiation transmitted below the canopy (W m-2) + scalarCanopyAbsorbedSolar = 0._summa_prec ! radiation absorbed by the vegetation canopy (W m-2) + scalarGroundAbsorbedSolar = 0._summa_prec ! radiation absorbed by the ground (W m-2) ! check for an early return (no radiation or no exposed canopy) if(.not.computeVegFlux .or. scalarCosZenith < tiny(scalarCosZenith))then ! set canopy radiation to zero - scalarCanopySunlitFraction = 0._dp ! sunlit fraction of canopy (-) - scalarCanopySunlitLAI = 0._dp ! sunlit leaf area (-) + scalarCanopySunlitFraction = 0._summa_prec ! sunlit fraction of canopy (-) + scalarCanopySunlitLAI = 0._summa_prec ! sunlit leaf area (-) scalarCanopyShadedLAI = scalarExposedLAI ! shaded leaf area (-) - scalarCanopySunlitPAR = 0._dp ! average absorbed par for sunlit leaves (w m-2) - scalarCanopyShadedPAR = 0._dp ! average absorbed par for shaded leaves (w m-2) + scalarCanopySunlitPAR = 0._summa_prec ! average absorbed par for sunlit leaves (w m-2) + scalarCanopyShadedPAR = 0._summa_prec ! average absorbed par for shaded leaves (w m-2) ! compute below-canopy radiation do iBand=1,nBands ! (set below-canopy radiation to incoming radiation) @@ -453,16 +453,16 @@ subroutine canopy_SW(& spectralBelowCanopyDirect(iBand) = spectralIncomingDirect(iBand) spectralBelowCanopyDiffuse(iBand) = spectralIncomingDiffuse(iBand) else - spectralBelowCanopyDirect(iBand) = 0._dp - spectralBelowCanopyDiffuse(iBand) = 0._dp + spectralBelowCanopyDirect(iBand) = 0._summa_prec + spectralBelowCanopyDiffuse(iBand) = 0._summa_prec end if ! (accumulate radiation transmitted below the canopy) scalarBelowCanopySolar = scalarBelowCanopySolar + & ! contribution from all previous wave bands spectralBelowCanopyDirect(iBand) + spectralBelowCanopyDiffuse(iBand) ! contribution from current wave band ! (accumulate radiation absorbed by the ground) scalarGroundAbsorbedSolar = scalarGroundAbsorbedSolar + & ! contribution from all previous wave bands - spectralBelowCanopyDirect(iBand)*(1._dp - spectralAlbGndDirect(iBand)) + & ! direct radiation from current wave band - spectralBelowCanopyDiffuse(iBand)*(1._dp - spectralAlbGndDiffuse(iBand)) ! diffuse radiation from current wave band + spectralBelowCanopyDirect(iBand)*(1._summa_prec - spectralAlbGndDirect(iBand)) + & ! direct radiation from current wave band + spectralBelowCanopyDiffuse(iBand)*(1._summa_prec - spectralAlbGndDiffuse(iBand)) ! diffuse radiation from current wave band end do ! looping through wave bands return end if @@ -490,8 +490,8 @@ subroutine canopy_SW(& !print*, 'tauTotal = ', tauTotal ! compute ground albedo (-) - groundAlbedoDirect = Frad_vis*spectralAlbGndDirect(ixVisible) + (1._dp - Frad_vis)*spectralAlbGndDirect(ixNearIR) - groundAlbedoDiffuse = Frad_vis*spectralAlbGndDiffuse(ixVisible) + (1._dp - Frad_vis)*spectralAlbGndDiffuse(ixNearIR) + groundAlbedoDirect = Frad_vis*spectralAlbGndDirect(ixVisible) + (1._summa_prec - Frad_vis)*spectralAlbGndDirect(ixNearIR) + groundAlbedoDiffuse = Frad_vis*spectralAlbGndDiffuse(ixVisible) + (1._summa_prec - Frad_vis)*spectralAlbGndDiffuse(ixNearIR) ! compute radiation in each spectral band (W m-2) do iBand=1,nBands @@ -501,7 +501,7 @@ subroutine canopy_SW(& ! compute fraction of direct radiation Fdirect = spectralIncomingDirect(iBand) / (spectralIncomingSolar(iBand) + verySmall) - if(Fdirect < 0._dp .or. Fdirect > 1._dp)then + if(Fdirect < 0._summa_prec .or. Fdirect > 1._summa_prec)then print*, 'spectralIncomingDirect(iBand) = ', spectralIncomingDirect(iBand) print*, 'spectralIncomingSolar(iBand) = ', spectralIncomingSolar(iBand) print*, 'Fdirect = ', Fdirect @@ -510,8 +510,8 @@ subroutine canopy_SW(& end if ! compute ground albedo (-) - scalarGroundAlbedo = Fdirect*groundAlbedoDirect + (1._dp - Fdirect)*groundAlbedoDiffuse - if(scalarGroundAlbedo < 0._dp .or. scalarGroundAlbedo > 1._dp)then + scalarGroundAlbedo = Fdirect*groundAlbedoDirect + (1._summa_prec - Fdirect)*groundAlbedoDiffuse + if(scalarGroundAlbedo < 0._summa_prec .or. scalarGroundAlbedo > 1._summa_prec)then print*, 'groundAlbedoDirect = ', groundAlbedoDirect print*, 'groundAlbedoDiffuse = ', groundAlbedoDiffuse message=trim(message)//'BeersLaw: albedo is less than zero or greater than one' @@ -524,13 +524,13 @@ subroutine canopy_SW(& spectralBelowCanopySolar(iBand) = spectralBelowCanopyDirect(iBand) + spectralBelowCanopyDiffuse(iBand) ! compute radiation absorbed by the ground in given wave band (W m-2) - spectralGroundAbsorbedDirect(iBand) = (1._dp - scalarGroundAlbedo)*spectralBelowCanopyDirect(iBand) - spectralGroundAbsorbedDiffuse(iBand) = (1._dp - scalarGroundAlbedo)*spectralBelowCanopyDiffuse(iBand) + spectralGroundAbsorbedDirect(iBand) = (1._summa_prec - scalarGroundAlbedo)*spectralBelowCanopyDirect(iBand) + spectralGroundAbsorbedDiffuse(iBand) = (1._summa_prec - scalarGroundAlbedo)*spectralBelowCanopyDiffuse(iBand) spectralGroundAbsorbedSolar(iBand) = spectralGroundAbsorbedDirect(iBand) + spectralGroundAbsorbedDiffuse(iBand) ! compute radiation absorbed by vegetation in current wave band (W m-2) - fracRadAbsDown = (1._dp - tauTotal)*(1._dp - bulkCanopyAlbedo) ! (fraction of radiation absorbed on the way down) - fracRadAbsUp = tauTotal*scalarGroundAlbedo*(1._dp - tauTotal) ! (fraction of radiation absorbed on the way up) + fracRadAbsDown = (1._summa_prec - tauTotal)*(1._summa_prec - bulkCanopyAlbedo) ! (fraction of radiation absorbed on the way down) + fracRadAbsUp = tauTotal*scalarGroundAlbedo*(1._summa_prec - tauTotal) ! (fraction of radiation absorbed on the way up) spectralCanopyAbsorbedDirect(iBand) = spectralIncomingDirect(iBand)*(fracRadAbsDown + fracRadAbsUp) spectralCanopyAbsorbedDiffuse(iBand) = spectralIncomingDiffuse(iBand)*(fracRadAbsDown + fracRadAbsUp) spectralCanopyAbsorbedSolar(iBand) = spectralCanopyAbsorbedDirect(iBand) + spectralCanopyAbsorbedDiffuse(iBand) @@ -547,7 +547,7 @@ subroutine canopy_SW(& spectralTotalReflectedDirect(iBand) = spectralIncomingDirect(iBand) - spectralGroundAbsorbedDirect(iBand) - spectralCanopyAbsorbedDirect(iBand) spectralTotalReflectedDiffuse(iBand) = spectralIncomingDiffuse(iBand) - spectralGroundAbsorbedDiffuse(iBand) - spectralCanopyAbsorbedDiffuse(iBand) spectralTotalReflectedSolar(iBand) = spectralTotalReflectedDirect(iBand) + spectralTotalReflectedDiffuse(iBand) - if(spectralTotalReflectedDirect(iBand) < 0._dp .or. spectralTotalReflectedDiffuse(iBand) < 0._dp)then + if(spectralTotalReflectedDirect(iBand) < 0._summa_prec .or. spectralTotalReflectedDiffuse(iBand) < 0._summa_prec)then print*, 'scalarGroundAlbedo = ', scalarGroundAlbedo print*, 'tauTotal = ', tauTotal print*, 'fracRadAbsDown = ', fracRadAbsDown @@ -587,11 +587,11 @@ subroutine canopy_SW(& ! compute transmission of diffuse radiation (-) vFactor = scalarGproj*scalarExposedVAI expi = expInt(vFactor) - taudFinite = (1._dp - vFactor)*exp(-vFactor) + (vFactor**2._dp)*expi + taudFinite = (1._summa_prec - vFactor)*exp(-vFactor) + (vFactor**2._summa_prec)*expi ! compute ground albedo (-) - groundAlbedoDirect = Frad_vis*spectralAlbGndDirect(ixVisible) + (1._dp - Frad_vis)*spectralAlbGndDirect(ixNearIR) - groundAlbedoDiffuse = Frad_vis*spectralAlbGndDiffuse(ixVisible) + (1._dp - Frad_vis)*spectralAlbGndDiffuse(ixNearIR) + groundAlbedoDirect = Frad_vis*spectralAlbGndDirect(ixVisible) + (1._summa_prec - Frad_vis)*spectralAlbGndDirect(ixNearIR) + groundAlbedoDiffuse = Frad_vis*spectralAlbGndDiffuse(ixVisible) + (1._summa_prec - Frad_vis)*spectralAlbGndDiffuse(ixNearIR) ! compute radiation in each spectral band (W m-2) do iBand=1,nBands @@ -601,7 +601,7 @@ subroutine canopy_SW(& ! compute fraction of direct radiation Fdirect = spectralIncomingDirect(iBand) / (spectralIncomingSolar(iBand) + verySmall) - if(Fdirect < 0._dp .or. Fdirect > 1._dp)then + if(Fdirect < 0._summa_prec .or. Fdirect > 1._summa_prec)then print*, 'spectralIncomingDirect(iBand) = ', spectralIncomingDirect(iBand) print*, 'spectralIncomingSolar(iBand) = ', spectralIncomingSolar(iBand) print*, 'Fdirect = ', Fdirect @@ -610,8 +610,8 @@ subroutine canopy_SW(& end if ! compute ground albedo (-) - scalarGroundAlbedo = Fdirect*groundAlbedoDirect + (1._dp - Fdirect)*groundAlbedoDiffuse - if(scalarGroundAlbedo < 0._dp .or. scalarGroundAlbedo > 1._dp)then + scalarGroundAlbedo = Fdirect*groundAlbedoDirect + (1._summa_prec - Fdirect)*groundAlbedoDiffuse + if(scalarGroundAlbedo < 0._summa_prec .or. scalarGroundAlbedo > 1._summa_prec)then print*, 'groundAlbedoDirect = ', groundAlbedoDirect print*, 'groundAlbedoDiffuse = ', groundAlbedoDiffuse message=trim(message)//'NL_scatter: albedo is less than zero or greater than one' @@ -619,13 +619,13 @@ subroutine canopy_SW(& end if ! compute initial transmission in the absence of scattering and multiple reflections (-) - tauInitial = Fdirect*tauFinite + (1._dp - Fdirect)*taudFinite + tauInitial = Fdirect*tauFinite + (1._summa_prec - Fdirect)*taudFinite ! compute increase in transmission due to scattering (-) tauTotal = (tauInitial**multScatExp) ! compute multiple reflections factor - refMult = 1._dp / (1._dp - scalarGroundAlbedo*bulkCanopyAlbedo*(1._dp - taudFinite**multScatExp) ) + refMult = 1._summa_prec / (1._summa_prec - scalarGroundAlbedo*bulkCanopyAlbedo*(1._summa_prec - taudFinite**multScatExp) ) ! compute below-canopy radiation (W m-2) spectralBelowCanopyDirect(iBand) = spectralIncomingDirect(iBand)*tauTotal*refMult ! direct radiation from current wave band @@ -633,13 +633,13 @@ subroutine canopy_SW(& spectralBelowCanopySolar(iBand) = spectralBelowCanopyDirect(iBand) + spectralBelowCanopyDiffuse(iBand) ! compute radiation absorbed by the ground in given wave band (W m-2) - spectralGroundAbsorbedDirect(iBand) = (1._dp - scalarGroundAlbedo)*spectralBelowCanopyDirect(iBand) - spectralGroundAbsorbedDiffuse(iBand) = (1._dp - scalarGroundAlbedo)*spectralBelowCanopyDiffuse(iBand) + spectralGroundAbsorbedDirect(iBand) = (1._summa_prec - scalarGroundAlbedo)*spectralBelowCanopyDirect(iBand) + spectralGroundAbsorbedDiffuse(iBand) = (1._summa_prec - scalarGroundAlbedo)*spectralBelowCanopyDiffuse(iBand) spectralGroundAbsorbedSolar(iBand) = spectralGroundAbsorbedDirect(iBand) + spectralGroundAbsorbedDiffuse(iBand) ! compute radiation absorbed by vegetation in current wave band (W m-2) - fracRadAbsDown = (1._dp - tauTotal)*(1._dp - bulkCanopyAlbedo) ! (fraction of radiation absorbed on the way down) - fracRadAbsUp = tauTotal*refMult*scalarGroundAlbedo*(1._dp - taudFinite**multScatExp) ! (fraction of radiation absorbed on the way up) + fracRadAbsDown = (1._summa_prec - tauTotal)*(1._summa_prec - bulkCanopyAlbedo) ! (fraction of radiation absorbed on the way down) + fracRadAbsUp = tauTotal*refMult*scalarGroundAlbedo*(1._summa_prec - taudFinite**multScatExp) ! (fraction of radiation absorbed on the way up) spectralCanopyAbsorbedDirect(iBand) = spectralIncomingDirect(iBand)*(fracRadAbsDown + fracRadAbsUp) spectralCanopyAbsorbedDiffuse(iBand) = spectralIncomingDiffuse(iBand)*(fracRadAbsDown + fracRadAbsUp) spectralCanopyAbsorbedSolar(iBand) = spectralCanopyAbsorbedDirect(iBand) + spectralCanopyAbsorbedDiffuse(iBand) @@ -648,7 +648,7 @@ subroutine canopy_SW(& spectralTotalReflectedDirect(iBand) = spectralIncomingDirect(iBand) - spectralGroundAbsorbedDirect(iBand) - spectralCanopyAbsorbedDirect(iBand) spectralTotalReflectedDiffuse(iBand) = spectralIncomingDiffuse(iBand) - spectralGroundAbsorbedDiffuse(iBand) - spectralCanopyAbsorbedDiffuse(iBand) spectralTotalReflectedSolar(iBand) = spectralTotalReflectedDirect(iBand) + spectralTotalReflectedDiffuse(iBand) - if(spectralTotalReflectedDirect(iBand) < 0._dp .or. spectralTotalReflectedDiffuse(iBand) < 0._dp)then + if(spectralTotalReflectedDirect(iBand) < 0._summa_prec .or. spectralTotalReflectedDiffuse(iBand) < 0._summa_prec)then message=trim(message)//'NL-scatter: reflected radiation is less than zero' err=20; return end if @@ -677,43 +677,43 @@ subroutine canopy_SW(& transCoef = scalarGproj/scalarCosZenith ! define "k-prime" coefficient (-) - transCoefPrime = sqrt(1._dp - bScatParam) + transCoefPrime = sqrt(1._summa_prec - bScatParam) ! compute ground albedo (-) - groundAlbedoDirect = Frad_vis*spectralAlbGndDirect(ixVisible) + (1._dp - Frad_vis)*spectralAlbGndDirect(ixNearIR) - groundAlbedoDiffuse = Frad_vis*spectralAlbGndDiffuse(ixVisible) + (1._dp - Frad_vis)*spectralAlbGndDiffuse(ixNearIR) + groundAlbedoDirect = Frad_vis*spectralAlbGndDirect(ixVisible) + (1._summa_prec - Frad_vis)*spectralAlbGndDirect(ixNearIR) + groundAlbedoDiffuse = Frad_vis*spectralAlbGndDiffuse(ixVisible) + (1._summa_prec - Frad_vis)*spectralAlbGndDiffuse(ixNearIR) ! compute transmission for an infinite canopy (-) tauInfinite = exp(-transCoef*transCoefPrime*scalarExposedVAI) ! compute upward reflection factor for an infinite canopy (-) - betaInfinite = (1._dp - transCoefPrime)/(1._dp + transCoefPrime) + betaInfinite = (1._summa_prec - transCoefPrime)/(1._summa_prec + transCoefPrime) ! compute transmission for a finite canopy (-) - tauFinite = tauInfinite*(1._dp - betaInfinite**2._dp)/(1._dp - (betaInfinite**2._dp)*tauInfinite**2._dp) + tauFinite = tauInfinite*(1._summa_prec - betaInfinite**2._summa_prec)/(1._summa_prec - (betaInfinite**2._summa_prec)*tauInfinite**2._summa_prec) ! compute reflectance for a finite canopy (-) - betaFinite = betaInfinite*(1._dp - tauInfinite**2._dp) / (1._dp - (betaInfinite**2._dp)*(tauInfinite**2._dp)) + betaFinite = betaInfinite*(1._summa_prec - tauInfinite**2._summa_prec) / (1._summa_prec - (betaInfinite**2._summa_prec)*(tauInfinite**2._summa_prec)) ! compute transmission of diffuse radiation (-) vFactor = transCoefPrime*scalarGproj*scalarExposedVAI expi = expInt(vFactor) - taudInfinite = (1._dp - vFactor)*exp(-vFactor) + (vFactor**2._dp)*expi - taudFinite = taudInfinite*(1._dp - betaInfinite**2._dp)/(1._dp - (betaInfinite**2._dp)*taudInfinite**2._dp) + taudInfinite = (1._summa_prec - vFactor)*exp(-vFactor) + (vFactor**2._summa_prec)*expi + taudFinite = taudInfinite*(1._summa_prec - betaInfinite**2._summa_prec)/(1._summa_prec - (betaInfinite**2._summa_prec)*taudInfinite**2._summa_prec) ! compute reflectance of diffuse radiation (-) - betadFinite = betaInfinite*(1._dp - taudInfinite**2._dp) / (1._dp - (betaInfinite**2._dp)*(taudInfinite**2._dp)) + betadFinite = betaInfinite*(1._summa_prec - taudInfinite**2._summa_prec) / (1._summa_prec - (betaInfinite**2._summa_prec)*(taudInfinite**2._summa_prec)) ! compute total transmission of direct and diffuse radiation, accounting for multiple reflections (-) - refMult = 1._dp / (1._dp - groundAlbedoDiffuse*betadFinite*(1._dp - taudFinite) ) + refMult = 1._summa_prec / (1._summa_prec - groundAlbedoDiffuse*betadFinite*(1._summa_prec - taudFinite) ) tauDirect = tauFinite*refMult tauDiffuse = taudFinite*refMult ! compute fraction of radiation lost to space (-) - fractionRefDirect = ( (1._dp - groundAlbedoDirect)*betaFinite + groundAlbedoDirect*tauFinite*taudFinite) * refMult - fractionRefDiffuse = ( (1._dp - groundAlbedoDiffuse)*betadFinite + groundAlbedoDiffuse*taudFinite*taudFinite) * refMult + fractionRefDirect = ( (1._summa_prec - groundAlbedoDirect)*betaFinite + groundAlbedoDirect*tauFinite*taudFinite) * refMult + fractionRefDiffuse = ( (1._summa_prec - groundAlbedoDiffuse)*betadFinite + groundAlbedoDiffuse*taudFinite*taudFinite) * refMult ! compute radiation in each spectral band (W m-2) do iBand=1,nBands @@ -724,22 +724,22 @@ subroutine canopy_SW(& spectralBelowCanopySolar(iBand) = spectralBelowCanopyDirect(iBand) + spectralBelowCanopyDiffuse(iBand) ! compute radiation absorbed by the ground in given wave band (W m-2) - spectralGroundAbsorbedDirect(iBand) = (1._dp - groundAlbedoDirect)*spectralBelowCanopyDirect(iBand) - spectralGroundAbsorbedDiffuse(iBand) = (1._dp - groundAlbedoDiffuse)*spectralBelowCanopyDiffuse(iBand) + spectralGroundAbsorbedDirect(iBand) = (1._summa_prec - groundAlbedoDirect)*spectralBelowCanopyDirect(iBand) + spectralGroundAbsorbedDiffuse(iBand) = (1._summa_prec - groundAlbedoDiffuse)*spectralBelowCanopyDiffuse(iBand) spectralGroundAbsorbedSolar(iBand) = spectralGroundAbsorbedDirect(iBand) + spectralGroundAbsorbedDiffuse(iBand) ! compute radiation absorbed by vegetation in current wave band (W m-2) - spectralCanopyAbsorbedDirect(iBand) = spectralIncomingDirect(iBand)*(1._dp - tauFinite)*(1._dp - betaFinite) + & ! (radiation absorbed on the way down) - spectralBelowCanopyDirect(iBand)*groundAlbedoDirect*(1._dp - taudFinite) ! (radiation absorbed on the way up) - spectralCanopyAbsorbedDiffuse(iBand) = spectralIncomingDiffuse(iBand)*(1._dp - taudFinite)*(1._dp - betadFinite) + & ! (radiation absorbed on the way down) - spectralBelowCanopyDiffuse(iBand)*groundAlbedoDiffuse*(1._dp - taudFinite) ! (radiation absorbed on the way up) + spectralCanopyAbsorbedDirect(iBand) = spectralIncomingDirect(iBand)*(1._summa_prec - tauFinite)*(1._summa_prec - betaFinite) + & ! (radiation absorbed on the way down) + spectralBelowCanopyDirect(iBand)*groundAlbedoDirect*(1._summa_prec - taudFinite) ! (radiation absorbed on the way up) + spectralCanopyAbsorbedDiffuse(iBand) = spectralIncomingDiffuse(iBand)*(1._summa_prec - taudFinite)*(1._summa_prec - betadFinite) + & ! (radiation absorbed on the way down) + spectralBelowCanopyDiffuse(iBand)*groundAlbedoDiffuse*(1._summa_prec - taudFinite) ! (radiation absorbed on the way up) spectralCanopyAbsorbedSolar(iBand) = spectralCanopyAbsorbedDirect(iBand) + spectralCanopyAbsorbedDiffuse(iBand) ! compute solar radiation lost to space in given wave band (W m-2) spectralTotalReflectedDirect(iBand) = spectralIncomingDirect(iBand) - spectralGroundAbsorbedDirect(iBand) - spectralCanopyAbsorbedDirect(iBand) spectralTotalReflectedDiffuse(iBand) = spectralIncomingDiffuse(iBand) - spectralGroundAbsorbedDiffuse(iBand) - spectralCanopyAbsorbedDiffuse(iBand) spectralTotalReflectedSolar(iBand) = spectralTotalReflectedDirect(iBand) + spectralTotalReflectedDiffuse(iBand) - if(spectralTotalReflectedDirect(iBand) < 0._dp .or. spectralTotalReflectedDiffuse(iBand) < 0._dp)then + if(spectralTotalReflectedDirect(iBand) < 0._summa_prec .or. spectralTotalReflectedDiffuse(iBand) < 0._summa_prec)then message=trim(message)//'UEB_2stream: reflected radiation is less than zero' err=20; return end if @@ -851,8 +851,8 @@ subroutine canopy_SW(& ! accumulate radiation absorbed by the ground (W m-2) scalarGroundAbsorbedSolar = scalarGroundAbsorbedSolar + & ! contribution from all previous wave bands - spectralBelowCanopyDirect(iBand)*(1._dp - spectralAlbGndDirect(iBand)) + & ! direct radiation from current wave band - spectralBelowCanopyDiffuse(iBand)*(1._dp - spectralAlbGndDiffuse(iBand)) ! diffuse radiation from current wave band + spectralBelowCanopyDirect(iBand)*(1._summa_prec - spectralAlbGndDirect(iBand)) + & ! direct radiation from current wave band + spectralBelowCanopyDiffuse(iBand)*(1._summa_prec - spectralAlbGndDiffuse(iBand)) ! diffuse radiation from current wave band ! save canopy radiation absorbed in visible wavelengths ! NOTE: here flux is per unit incoming flux @@ -876,11 +876,11 @@ subroutine canopy_SW(& ! compute sunlit fraction of canopy (from CLM/Noah-MP) ext = scalarGproj/scalarCosZenith ! optical depth of direct beam per unit leaf + stem area - scalarCanopySunlitFraction = (1._dp - exp(-ext*scalarExposedVAI)) / max(ext*scalarExposedVAI,mpe) - if(scalarCanopySunlitFraction < 0.01_dp) scalarCanopySunlitFraction = 0._dp + scalarCanopySunlitFraction = (1._summa_prec - exp(-ext*scalarExposedVAI)) / max(ext*scalarExposedVAI,mpe) + if(scalarCanopySunlitFraction < 0.01_summa_prec) scalarCanopySunlitFraction = 0._summa_prec ! compute sunlit and shaded LAI - scalarCanopyShadedFraction = 1._dp - scalarCanopySunlitFraction + scalarCanopyShadedFraction = 1._summa_prec - scalarCanopySunlitFraction scalarCanopySunlitLAI = scalarExposedLAI*scalarCanopySunlitFraction scalarCanopyShadedLAI = scalarExposedLAI*scalarCanopyShadedFraction @@ -890,7 +890,7 @@ subroutine canopy_SW(& scalarCanopySunlitPAR = (visibleAbsDirect + scalarCanopySunlitFraction*visibleAbsDiffuse) * fractionLAI / max(scalarCanopySunlitLAI, mpe) scalarCanopyShadedPAR = ( scalarCanopyShadedFraction*visibleAbsDiffuse) * fractionLAI / max(scalarCanopyShadedLAI, mpe) else - scalarCanopySunlitPAR = 0._dp + scalarCanopySunlitPAR = 0._summa_prec scalarCanopyShadedPAR = (visibleAbsDirect + visibleAbsDiffuse) * fractionLAI / max(scalarCanopyShadedLAI, mpe) end if !print*, 'scalarCanopySunlitLAI, fractionLAI, visibleAbsDirect, visibleAbsDiffuse, scalarCanopySunlitPAR = ', & @@ -921,32 +921,32 @@ subroutine gndAlbedo(& ! -------------------------------------------------------------------------------------------------------------------------------------- ! input: model control integer(i4b),intent(in) :: isc ! index of soil color - real(dp),intent(in) :: scalarGroundSnowFraction ! fraction of ground that is snow covered (-) - real(dp),intent(in) :: scalarVolFracLiqUpper ! volumetric liquid water content in upper-most soil layer (-) - real(dp),intent(in) :: spectralSnowAlbedoDirect(:) ! direct albedo of snow in each spectral band (-) - real(dp),intent(in) :: spectralSnowAlbedoDiffuse(:) ! diffuse albedo of snow in each spectral band (-) + real(summa_prec),intent(in) :: scalarGroundSnowFraction ! fraction of ground that is snow covered (-) + real(summa_prec),intent(in) :: scalarVolFracLiqUpper ! volumetric liquid water content in upper-most soil layer (-) + real(summa_prec),intent(in) :: spectralSnowAlbedoDirect(:) ! direct albedo of snow in each spectral band (-) + real(summa_prec),intent(in) :: spectralSnowAlbedoDiffuse(:) ! diffuse albedo of snow in each spectral band (-) ! output - real(dp),intent(out) :: spectralAlbGndDirect(:) ! direct albedo of underlying surface (-) - real(dp),intent(out) :: spectralAlbGndDiffuse(:) ! diffuse albedo of underlying surface (-) + real(summa_prec),intent(out) :: spectralAlbGndDirect(:) ! direct albedo of underlying surface (-) + real(summa_prec),intent(out) :: spectralAlbGndDiffuse(:) ! diffuse albedo of underlying surface (-) integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! local variables integer(i4b) :: iBand ! index of spectral band - real(dp) :: xInc ! soil water correction factor for soil albedo - real(dp),dimension(1:nBands) :: spectralSoilAlbedo ! soil albedo in each spectral band + real(summa_prec) :: xInc ! soil water correction factor for soil albedo + real(summa_prec),dimension(1:nBands) :: spectralSoilAlbedo ! soil albedo in each spectral band ! initialize error control err=0; message='gndAlbedo/' ! compute soil albedo do iBand=1,nBands ! loop through spectral bands - xInc = max(0.11_dp - 0.40_dp*scalarVolFracLiqUpper, 0._dp) + xInc = max(0.11_summa_prec - 0.40_summa_prec*scalarVolFracLiqUpper, 0._summa_prec) spectralSoilAlbedo(iBand) = min(ALBSAT(isc,iBand)+xInc,ALBDRY(isc,iBand)) end do ! (looping through spectral bands) ! compute surface albedo (weighted combination of snow and soil) do iBand=1,nBands - spectralAlbGndDirect(iBand) = (1._dp - scalarGroundSnowFraction)*spectralSoilAlbedo(iBand) + scalarGroundSnowFraction*spectralSnowAlbedoDirect(iBand) - spectralAlbGndDiffuse(iBand) = (1._dp - scalarGroundSnowFraction)*spectralSoilAlbedo(iBand) + scalarGroundSnowFraction*spectralSnowAlbedoDiffuse(iBand) + spectralAlbGndDirect(iBand) = (1._summa_prec - scalarGroundSnowFraction)*spectralSoilAlbedo(iBand) + scalarGroundSnowFraction*spectralSnowAlbedoDirect(iBand) + spectralAlbGndDiffuse(iBand) = (1._summa_prec - scalarGroundSnowFraction)*spectralSoilAlbedo(iBand) + scalarGroundSnowFraction*spectralSnowAlbedoDiffuse(iBand) end do ! (looping through spectral bands) end subroutine gndAlbedo diff --git a/build/source/engine/volicePack.f90 b/build/source/engine/volicePack.f90 index 8267f4770..ea086961d 100755 --- a/build/source/engine/volicePack.f90 +++ b/build/source/engine/volicePack.f90 @@ -164,37 +164,37 @@ subroutine newsnwfall(& ! add new snowfall to the system implicit none ! input: model control - real(dp),intent(in) :: dt ! time step (seconds) + real(summa_prec),intent(in) :: dt ! time step (seconds) logical(lgt),intent(in) :: snowLayers ! logical flag if snow layers exist - real(dp),intent(in) :: fc_param ! freeezing curve parameter for snow (K-1) + real(summa_prec),intent(in) :: fc_param ! freeezing curve parameter for snow (K-1) ! input: diagnostic scalar variables - real(dp),intent(in) :: scalarSnowfallTemp ! computed temperature of fresh snow (K) - real(dp),intent(in) :: scalarNewSnowDensity ! computed density of new snow (kg m-3) - real(dp),intent(in) :: scalarThroughfallSnow ! throughfall of snow through the canopy (kg m-2 s-1) - real(dp),intent(in) :: scalarCanopySnowUnloading ! unloading of snow from the canopy (kg m-2 s-1) + real(summa_prec),intent(in) :: scalarSnowfallTemp ! computed temperature of fresh snow (K) + real(summa_prec),intent(in) :: scalarNewSnowDensity ! computed density of new snow (kg m-3) + real(summa_prec),intent(in) :: scalarThroughfallSnow ! throughfall of snow through the canopy (kg m-2 s-1) + real(summa_prec),intent(in) :: scalarCanopySnowUnloading ! unloading of snow from the canopy (kg m-2 s-1) ! input/output: state variables - real(dp),intent(inout) :: scalarSWE ! SWE (kg m-2) - real(dp),intent(inout) :: scalarSnowDepth ! total snow depth (m) - real(dp),intent(inout) :: surfaceLayerTemp ! temperature of each layer (K) - real(dp),intent(inout) :: surfaceLayerDepth ! depth of each layer (m) - real(dp),intent(inout) :: surfaceLayerVolFracIce ! volumetric fraction of ice in each layer (-) - real(dp),intent(inout) :: surfaceLayerVolFracLiq ! volumetric fraction of liquid water in each layer (-) + real(summa_prec),intent(inout) :: scalarSWE ! SWE (kg m-2) + real(summa_prec),intent(inout) :: scalarSnowDepth ! total snow depth (m) + real(summa_prec),intent(inout) :: surfaceLayerTemp ! temperature of each layer (K) + real(summa_prec),intent(inout) :: surfaceLayerDepth ! depth of each layer (m) + real(summa_prec),intent(inout) :: surfaceLayerVolFracIce ! volumetric fraction of ice in each layer (-) + real(summa_prec),intent(inout) :: surfaceLayerVolFracLiq ! volumetric fraction of liquid water in each layer (-) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! define local variables - real(dp) :: newSnowfall ! new snowfall -- throughfall and unloading (kg m-2 s-1) - real(dp) :: newSnowDepth ! new snow depth (m) - real(dp),parameter :: densityCanopySnow=200._dp ! density of snow on the vegetation canopy (kg m-3) - real(dp) :: totalMassIceSurfLayer ! total mass of ice in the surface layer (kg m-2) - real(dp) :: totalDepthSurfLayer ! total depth of the surface layer (m) - real(dp) :: volFracWater ! volumetric fraction of total water, liquid and ice (-) - real(dp) :: fracLiq ! fraction of liquid water (-) - real(dp) :: SWE ! snow water equivalent after snowfall (kg m-2) - real(dp) :: tempSWE0 ! temporary SWE before snowfall, used to check mass balance (kg m-2) - real(dp) :: tempSWE1 ! temporary SWE after snowfall, used to check mass balance (kg m-2) - real(dp) :: xMassBalance ! mass balance check (kg m-2) - real(dp),parameter :: verySmall=1.e-8_dp ! a very small number -- used to check mass balance + real(summa_prec) :: newSnowfall ! new snowfall -- throughfall and unloading (kg m-2 s-1) + real(summa_prec) :: newSnowDepth ! new snow depth (m) + real(summa_prec),parameter :: densityCanopySnow=200._summa_prec ! density of snow on the vegetation canopy (kg m-3) + real(summa_prec) :: totalMassIceSurfLayer ! total mass of ice in the surface layer (kg m-2) + real(summa_prec) :: totalDepthSurfLayer ! total depth of the surface layer (m) + real(summa_prec) :: volFracWater ! volumetric fraction of total water, liquid and ice (-) + real(summa_prec) :: fracLiq ! fraction of liquid water (-) + real(summa_prec) :: SWE ! snow water equivalent after snowfall (kg m-2) + real(summa_prec) :: tempSWE0 ! temporary SWE before snowfall, used to check mass balance (kg m-2) + real(summa_prec) :: tempSWE1 ! temporary SWE after snowfall, used to check mass balance (kg m-2) + real(summa_prec) :: xMassBalance ! mass balance check (kg m-2) + real(summa_prec),parameter :: verySmall=1.e-8_summa_prec ! a very small number -- used to check mass balance ! initialize error control err=0; message="newsnwfall/" @@ -233,7 +233,7 @@ subroutine newsnwfall(& ! compute new volumetric fraction of liquid water and ice (-) volFracWater = (SWE/totalDepthSurfLayer)/iden_water fracLiq = fracliquid(surfaceLayerTemp,fc_param) ! fraction of liquid water - surfaceLayerVolFracIce = (1._dp - fracLiq)*volFracWater*(iden_water/iden_ice) ! volumetric fraction of ice (-) + surfaceLayerVolFracIce = (1._summa_prec - fracLiq)*volFracWater*(iden_water/iden_ice) ! volumetric fraction of ice (-) surfaceLayerVolFracLiq = fracLiq *volFracWater ! volumetric fraction of liquid water (-) ! update new layer depth (m) surfaceLayerDepth = totalDepthSurfLayer diff --git a/build/source/netcdf/modelwrite.f90 b/build/source/netcdf/modelwrite.f90 index ee27a52af..8ea0d7316 100755 --- a/build/source/netcdf/modelwrite.f90 +++ b/build/source/netcdf/modelwrite.f90 @@ -176,8 +176,8 @@ subroutine writeData(finalizeStats,outputTimestep,nHRUrun,maxLayers,meta,stat,da ! output arrays integer(i4b) :: datLength ! length of each data vector integer(i4b) :: maxLength ! maximum length of each data vector - real(dp) :: realVec(nHRUrun) ! real vector for all HRUs in the run domain - real(dp) :: realArray(nHRUrun,maxLayers+1) ! real array for all HRUs in the run domain + real(summa_prec) :: realVec(nHRUrun) ! real vector for all HRUs in the run domain + real(summa_prec) :: realArray(nHRUrun,maxLayers+1) ! real array for all HRUs in the run domain integer(i4b) :: intArray(nHRUrun,maxLayers+1) ! integer array for all HRUs in the run domain integer(i4b) :: dataType ! type of data integer(i4b),parameter :: ixInteger=1001 ! named variable for integer diff --git a/build/source/netcdf/read_icond.f90 b/build/source/netcdf/read_icond.f90 index c5bdd929e..126ee6c7d 100644 --- a/build/source/netcdf/read_icond.f90 +++ b/build/source/netcdf/read_icond.f90 @@ -201,7 +201,7 @@ subroutine read_icond(iconFile, & ! intent(in): name of integer(i4b) :: ixFile ! index in file integer(i4b) :: iHRU_local ! index of HRU in the data subset integer(i4b) :: iHRU_global ! index of HRU in the netcdf file - real(dp),allocatable :: varData(:,:) ! variable data storage + real(summa_prec),allocatable :: varData(:,:) ! variable data storage integer(i4b) :: nSoil, nSnow, nToto ! # layers integer(i4b) :: nTDH ! number of points in time-delay histogram integer(i4b) :: iLayer,jLayer ! layer indices @@ -319,7 +319,7 @@ subroutine read_icond(iconFile, & ! intent(in): name of if(err==20)then; message=trim(message)//"data set to the fill value (name='"//trim(prog_meta(iVar)%varName)//"')"; return; endif ! fix the snow albedo - if(progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%scalarSnowAlbedo)%dat(1) < 0._dp)then + if(progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%scalarSnowAlbedo)%dat(1) < 0._summa_prec)then progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%scalarSnowAlbedo)%dat(1) = mparData%gru(iGRU)%hru(iHRU)%var(iLookPARAM%albedoMax)%dat(1) endif @@ -376,7 +376,7 @@ subroutine read_icond(iconFile, & ! intent(in): name of mparData%gru(iGRU)%hru(iHRU)%var(iLookPARAM%vGn_n )%dat(iLayer),& ! intent(in): van Genutchen "n" parameter mparData%gru(iGRU)%hru(iHRU)%var(iLookPARAM%theta_sat )%dat(iLayer),& ! intent(in): soil porosity (-) mparData%gru(iGRU)%hru(iHRU)%var(iLookPARAM%theta_res )%dat(iLayer),& ! intent(in): soil residual volumetric water content (-) - 1._dp - 1._dp/mparData%gru(iGRU)%hru(iHRU)%var(iLookPARAM%vGn_n)%dat(iLayer),& ! intent(in): van Genutchen "m" parameter (-) + 1._summa_prec - 1._summa_prec/mparData%gru(iGRU)%hru(iHRU)%var(iLookPARAM%vGn_n)%dat(iLayer),& ! intent(in): van Genutchen "m" parameter (-) ! output progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%mLayerVolFracWat )%dat(jLayer),& ! intent(out): volumetric fraction of total water (-) progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%mLayerVolFracLiq )%dat(jLayer),& ! intent(out): volumetric fraction of liquid water (-) diff --git a/build/source/noah-mp/module_model_constants.F b/build/source/noah-mp/module_model_constants.F index 9539d4482..d954ea0d9 100755 --- a/build/source/noah-mp/module_model_constants.F +++ b/build/source/noah-mp/module_model_constants.F @@ -2,138 +2,139 @@ ! MODULE module_model_constants + USE nrtype ! 2. Following are constants for use in defining real number bounds. ! A really small number. - REAL , PARAMETER :: epsilon = 1.E-15 + REAL(SUMMA_PREC) , PARAMETER :: epsilon = 1.E-15 ! 4. Following is information related to the physical constants. ! These are the physical constants used within the model. ! JM NOTE -- can we name this grav instead? - REAL , PARAMETER :: g = 9.81 ! acceleration due to gravity (m {s}^-2) + REAL(SUMMA_PREC) , PARAMETER :: g = 9.81 ! acceleration due to gravity (m {s}^-2) #if ( NMM_CORE == 1 ) - REAL , PARAMETER :: r_d = 287.04 - REAL , PARAMETER :: cp = 1004.6 + REAL(SUMMA_PREC) , PARAMETER :: r_d = 287.04 + REAL(SUMMA_PREC) , PARAMETER :: cp = 1004.6 #else - REAL , PARAMETER :: r_d = 287. - REAL , PARAMETER :: cp = 7.*r_d/2. + REAL(SUMMA_PREC) , PARAMETER :: r_d = 287. + REAL(SUMMA_PREC) , PARAMETER :: cp = 7.*r_d/2. #endif - REAL , PARAMETER :: r_v = 461.6 - REAL , PARAMETER :: cv = cp-r_d - REAL , PARAMETER :: cpv = 4.*r_v - REAL , PARAMETER :: cvv = cpv-r_v - REAL , PARAMETER :: cvpm = -cv/cp - REAL , PARAMETER :: cliq = 4190. - REAL , PARAMETER :: cice = 2106. - REAL , PARAMETER :: psat = 610.78 - REAL , PARAMETER :: rcv = r_d/cv - REAL , PARAMETER :: rcp = r_d/cp - REAL , PARAMETER :: rovg = r_d/g - REAL , PARAMETER :: c2 = cp * rcv + REAL(SUMMA_PREC) , PARAMETER :: r_v = 461.6 + REAL(SUMMA_PREC) , PARAMETER :: cv = cp-r_d + REAL(SUMMA_PREC) , PARAMETER :: cpv = 4.*r_v + REAL(SUMMA_PREC) , PARAMETER :: cvv = cpv-r_v + REAL(SUMMA_PREC) , PARAMETER :: cvpm = -cv/cp + REAL(SUMMA_PREC) , PARAMETER :: cliq = 4190. + REAL(SUMMA_PREC) , PARAMETER :: cice = 2106. + REAL(SUMMA_PREC) , PARAMETER :: psat = 610.78 + REAL(SUMMA_PREC) , PARAMETER :: rcv = r_d/cv + REAL(SUMMA_PREC) , PARAMETER :: rcp = r_d/cp + REAL(SUMMA_PREC) , PARAMETER :: rovg = r_d/g + REAL(SUMMA_PREC) , PARAMETER :: c2 = cp * rcv real , parameter :: mwdry = 28.966 ! molecular weight of dry air (g/mole) - REAL , PARAMETER :: p1000mb = 100000. - REAL , PARAMETER :: t0 = 300. - REAL , PARAMETER :: p0 = p1000mb - REAL , PARAMETER :: cpovcv = cp/(cp-r_d) - REAL , PARAMETER :: cvovcp = 1./cpovcv - REAL , PARAMETER :: rvovrd = r_v/r_d + REAL(SUMMA_PREC) , PARAMETER :: p1000mb = 100000. + REAL(SUMMA_PREC) , PARAMETER :: t0 = 300. + REAL(SUMMA_PREC) , PARAMETER :: p0 = p1000mb + REAL(SUMMA_PREC) , PARAMETER :: cpovcv = cp/(cp-r_d) + REAL(SUMMA_PREC) , PARAMETER :: cvovcp = 1./cpovcv + REAL(SUMMA_PREC) , PARAMETER :: rvovrd = r_v/r_d - REAL , PARAMETER :: reradius = 1./6370.0e03 + REAL(SUMMA_PREC) , PARAMETER :: reradius = 1./6370.0e03 - REAL , PARAMETER :: asselin = .025 -! REAL , PARAMETER :: asselin = .0 - REAL , PARAMETER :: cb = 25. + REAL(SUMMA_PREC) , PARAMETER :: asselin = .025 +! REAL(SUMMA_PREC) , PARAMETER :: asselin = .0 + REAL(SUMMA_PREC) , PARAMETER :: cb = 25. - REAL , PARAMETER :: XLV0 = 3.15E6 - REAL , PARAMETER :: XLV1 = 2370. - REAL , PARAMETER :: XLS0 = 2.905E6 - REAL , PARAMETER :: XLS1 = 259.532 + REAL(SUMMA_PREC) , PARAMETER :: XLV0 = 3.15E6 + REAL(SUMMA_PREC) , PARAMETER :: XLV1 = 2370. + REAL(SUMMA_PREC) , PARAMETER :: XLS0 = 2.905E6 + REAL(SUMMA_PREC) , PARAMETER :: XLS1 = 259.532 - REAL , PARAMETER :: XLS = 2.85E6 - REAL , PARAMETER :: XLV = 2.5E6 - REAL , PARAMETER :: XLF = 3.50E5 + REAL(SUMMA_PREC) , PARAMETER :: XLS = 2.85E6 + REAL(SUMMA_PREC) , PARAMETER :: XLV = 2.5E6 + REAL(SUMMA_PREC) , PARAMETER :: XLF = 3.50E5 - REAL , PARAMETER :: rhowater = 1000. - REAL , PARAMETER :: rhosnow = 100. - REAL , PARAMETER :: rhoair0 = 1.28 + REAL(SUMMA_PREC) , PARAMETER :: rhowater = 1000. + REAL(SUMMA_PREC) , PARAMETER :: rhosnow = 100. + REAL(SUMMA_PREC) , PARAMETER :: rhoair0 = 1.28 ! - REAL , PARAMETER :: n_ccn0 = 1.0E8 + REAL(SUMMA_PREC) , PARAMETER :: n_ccn0 = 1.0E8 ! - REAL , PARAMETER :: DEGRAD = 3.1415926/180. - REAL , PARAMETER :: DPD = 360./365. - - REAL , PARAMETER :: SVP1=0.6112 - REAL , PARAMETER :: SVP2=17.67 - REAL , PARAMETER :: SVP3=29.65 - REAL , PARAMETER :: SVPT0=273.15 - REAL , PARAMETER :: EP_1=R_v/R_d-1. - REAL , PARAMETER :: EP_2=R_d/R_v - REAL , PARAMETER :: KARMAN=0.4 - REAL , PARAMETER :: EOMEG=7.2921E-5 - REAL , PARAMETER :: STBOLT=5.67051E-8 - - REAL , PARAMETER :: prandtl = 1./3.0 + REAL(SUMMA_PREC) , PARAMETER :: DEGRAD = 3.1415926/180. + REAL(SUMMA_PREC) , PARAMETER :: DPD = 360./365. + + REAL(SUMMA_PREC) , PARAMETER :: SVP1=0.6112 + REAL(SUMMA_PREC) , PARAMETER :: SVP2=17.67 + REAL(SUMMA_PREC) , PARAMETER :: SVP3=29.65 + REAL(SUMMA_PREC) , PARAMETER :: SVPT0=273.15 + REAL(SUMMA_PREC) , PARAMETER :: EP_1=R_v/R_d-1. + REAL(SUMMA_PREC) , PARAMETER :: EP_2=R_d/R_v + REAL(SUMMA_PREC) , PARAMETER :: KARMAN=0.4 + REAL(SUMMA_PREC) , PARAMETER :: EOMEG=7.2921E-5 + REAL(SUMMA_PREC) , PARAMETER :: STBOLT=5.67051E-8 + + REAL(SUMMA_PREC) , PARAMETER :: prandtl = 1./3.0 ! constants for w-damping option - REAL , PARAMETER :: w_alpha = 0.3 ! strength m/s/s - REAL , PARAMETER :: w_beta = 1.0 ! activation cfl number - - REAL , PARAMETER :: pq0=379.90516 - REAL , PARAMETER :: epsq2=0.2 - REAL , PARAMETER :: a2=17.2693882 - REAL , PARAMETER :: a3=273.16 - REAL , PARAMETER :: a4=35.86 - REAL , PARAMETER :: epsq=1.e-12 - REAL , PARAMETER :: p608=rvovrd-1. + REAL(SUMMA_PREC) , PARAMETER :: w_alpha = 0.3 ! strength m/s/s + REAL(SUMMA_PREC) , PARAMETER :: w_beta = 1.0 ! activation cfl number + + REAL(SUMMA_PREC) , PARAMETER :: pq0=379.90516 + REAL(SUMMA_PREC) , PARAMETER :: epsq2=0.2 + REAL(SUMMA_PREC) , PARAMETER :: a2=17.2693882 + REAL(SUMMA_PREC) , PARAMETER :: a3=273.16 + REAL(SUMMA_PREC) , PARAMETER :: a4=35.86 + REAL(SUMMA_PREC) , PARAMETER :: epsq=1.e-12 + REAL(SUMMA_PREC) , PARAMETER :: p608=rvovrd-1. !#if ( NMM_CORE == 1 ) - REAL , PARAMETER :: climit=1.e-20 - REAL , PARAMETER :: cm1=2937.4 - REAL , PARAMETER :: cm2=4.9283 - REAL , PARAMETER :: cm3=23.5518 -! REAL , PARAMETER :: defc=8.0 -! REAL , PARAMETER :: defm=32.0 - REAL , PARAMETER :: defc=0.0 - REAL , PARAMETER :: defm=99999.0 - REAL , PARAMETER :: epsfc=1./1.05 - REAL , PARAMETER :: epswet=0.0 - REAL , PARAMETER :: fcdif=1./3. + REAL(SUMMA_PREC) , PARAMETER :: climit=1.e-20 + REAL(SUMMA_PREC) , PARAMETER :: cm1=2937.4 + REAL(SUMMA_PREC) , PARAMETER :: cm2=4.9283 + REAL(SUMMA_PREC) , PARAMETER :: cm3=23.5518 +! REAL(SUMMA_PREC) , PARAMETER :: defc=8.0 +! REAL(SUMMA_PREC) , PARAMETER :: defm=32.0 + REAL(SUMMA_PREC) , PARAMETER :: defc=0.0 + REAL(SUMMA_PREC) , PARAMETER :: defm=99999.0 + REAL(SUMMA_PREC) , PARAMETER :: epsfc=1./1.05 + REAL(SUMMA_PREC) , PARAMETER :: epswet=0.0 + REAL(SUMMA_PREC) , PARAMETER :: fcdif=1./3. #ifdef HWRF - REAL , PARAMETER :: fcm=0.0 + REAL(SUMMA_PREC) , PARAMETER :: fcm=0.0 #else - REAL , PARAMETER :: fcm=0.00003 + REAL(SUMMA_PREC) , PARAMETER :: fcm=0.00003 #endif - REAL , PARAMETER :: gma=-r_d*(1.-rcp)*0.5 - REAL , PARAMETER :: p400=40000.0 - REAL , PARAMETER :: phitp=15000.0 - REAL , PARAMETER :: pi2=2.*3.1415926 - REAL , PARAMETER :: plbtm=105000.0 - REAL , PARAMETER :: plomd=64200.0 - REAL , PARAMETER :: pmdhi=35000.0 - REAL , PARAMETER :: q2ini=0.50 - REAL , PARAMETER :: rfcp=0.25/cp - REAL , PARAMETER :: rhcrit_land=0.75 - REAL , PARAMETER :: rhcrit_sea=0.80 - REAL , PARAMETER :: rlag=14.8125 - REAL , PARAMETER :: rlx=0.90 - REAL , PARAMETER :: scq2=50.0 - REAL , PARAMETER :: slopht=0.001 - REAL , PARAMETER :: tlc=2.*0.703972477 - REAL , PARAMETER :: wa=0.15 - REAL , PARAMETER :: wght=0.35 - REAL , PARAMETER :: wpc=0.075 - REAL , PARAMETER :: z0land=0.10 + REAL(SUMMA_PREC) , PARAMETER :: gma=-r_d*(1.-rcp)*0.5 + REAL(SUMMA_PREC) , PARAMETER :: p400=40000.0 + REAL(SUMMA_PREC) , PARAMETER :: phitp=15000.0 + REAL(SUMMA_PREC) , PARAMETER :: pi2=2.*3.1415926 + REAL(SUMMA_PREC) , PARAMETER :: plbtm=105000.0 + REAL(SUMMA_PREC) , PARAMETER :: plomd=64200.0 + REAL(SUMMA_PREC) , PARAMETER :: pmdhi=35000.0 + REAL(SUMMA_PREC) , PARAMETER :: q2ini=0.50 + REAL(SUMMA_PREC) , PARAMETER :: rfcp=0.25/cp + REAL(SUMMA_PREC) , PARAMETER :: rhcrit_land=0.75 + REAL(SUMMA_PREC) , PARAMETER :: rhcrit_sea=0.80 + REAL(SUMMA_PREC) , PARAMETER :: rlag=14.8125 + REAL(SUMMA_PREC) , PARAMETER :: rlx=0.90 + REAL(SUMMA_PREC) , PARAMETER :: scq2=50.0 + REAL(SUMMA_PREC) , PARAMETER :: slopht=0.001 + REAL(SUMMA_PREC) , PARAMETER :: tlc=2.*0.703972477 + REAL(SUMMA_PREC) , PARAMETER :: wa=0.15 + REAL(SUMMA_PREC) , PARAMETER :: wght=0.35 + REAL(SUMMA_PREC) , PARAMETER :: wpc=0.075 + REAL(SUMMA_PREC) , PARAMETER :: z0land=0.10 #ifdef HWRF - REAL , PARAMETER :: z0max=0.01 + REAL(SUMMA_PREC) , PARAMETER :: z0max=0.01 #else - REAL , PARAMETER :: z0max=0.008 + REAL(SUMMA_PREC) , PARAMETER :: z0max=0.008 #endif - REAL , PARAMETER :: z0sea=0.001 + REAL(SUMMA_PREC) , PARAMETER :: z0sea=0.001 !#endif @@ -141,19 +142,19 @@ MODULE module_model_constants ! The value for P2SI *must* be set to 1.0 for Earth ! Although, now we may not need this declaration here (see above) - !REAL , PARAMETER :: P2SI = 1.0 + !REAL(SUMMA_PREC) , PARAMETER :: P2SI = 1.0 ! Orbital constants: INTEGER , PARAMETER :: PLANET_YEAR = 365 - REAL , PARAMETER :: OBLIQUITY = 23.5 - REAL , PARAMETER :: ECCENTRICITY = 0.014 - REAL , PARAMETER :: SEMIMAJORAXIS = 1.0 ! In AU + REAL(SUMMA_PREC) , PARAMETER :: OBLIQUITY = 23.5 + REAL(SUMMA_PREC) , PARAMETER :: ECCENTRICITY = 0.014 + REAL(SUMMA_PREC) , PARAMETER :: SEMIMAJORAXIS = 1.0 ! In AU ! Don't know the following values, so we'll fake them for now - REAL , PARAMETER :: zero_date = 0.0 ! Time of perihelion passage + REAL(SUMMA_PREC) , PARAMETER :: zero_date = 0.0 ! Time of perihelion passage ! Fraction into the year (from perhelion) of the ! occurrence of the Northern Spring Equinox - REAL , PARAMETER :: EQUINOX_FRACTION= 0.0 + REAL(SUMMA_PREC) , PARAMETER :: EQUINOX_FRACTION= 0.0 CONTAINS SUBROUTINE init_module_model_constants diff --git a/build/source/noah-mp/module_sf_noahlsm.F b/build/source/noah-mp/module_sf_noahlsm.F index 6d38415c0..d033784f8 100755 --- a/build/source/noah-mp/module_sf_noahlsm.F +++ b/build/source/noah-mp/module_sf_noahlsm.F @@ -1,8 +1,9 @@ MODULE module_sf_noahlsm + USE nrtype USE module_model_constants -! REAL, PARAMETER :: CP = 1004.5 - REAL, PARAMETER :: RD = 287.04, SIGMA = 5.67E-8, & +! REAL(SUMMA_PREC), PARAMETER :: CP = 1004.5 + REAL(SUMMA_PREC), PARAMETER :: RD = 287.04, SIGMA = 5.67E-8, & CPH2O = 4.218E+3,CPICE = 2.106E+3, & LSUBF = 3.335E+5, & EMISSI_S = 0.95 @@ -19,26 +20,26 @@ MODULE module_sf_noahlsm LAIMINTBL, LAIMAXTBL, & Z0MINTBL, Z0MAXTBL, & ALBEDOMINTBL, ALBEDOMAXTBL - REAL :: TOPT_DATA,CMCMAX_DATA,CFACTR_DATA,RSMAX_DATA + REAL(SUMMA_PREC) :: TOPT_DATA,CMCMAX_DATA,CFACTR_DATA,RSMAX_DATA ! SOIL PARAMETERS INTEGER :: SLCATS INTEGER, PARAMETER :: NSLTYPE=30 CHARACTER(LEN=256) SLTYPE - REAL, DIMENSION (1:NSLTYPE) :: BB,DRYSMC,F11, & + REAL(SUMMA_PREC), DIMENSION (1:NSLTYPE) :: BB,DRYSMC,F11, & MAXSMC, REFSMC,SATPSI,SATDK,SATDW, WLTSMC,QTZ ! MPC add van Genutchen parameters - REAL, DIMENSION (1:NSLTYPE) :: theta_res, theta_sat, & + REAL(SUMMA_PREC), DIMENSION (1:NSLTYPE) :: theta_res, theta_sat, & vGn_alpha, vGn_n, k_soil ! LSM GENERAL PARAMETERS INTEGER :: SLPCATS INTEGER, PARAMETER :: NSLOPE=30 - REAL, DIMENSION (1:NSLOPE) :: SLOPE_DATA - REAL :: SBETA_DATA,FXEXP_DATA,CSOIL_DATA,SALP_DATA,REFDK_DATA, & + REAL(SUMMA_PREC), DIMENSION (1:NSLOPE) :: SLOPE_DATA + REAL(SUMMA_PREC) :: SBETA_DATA,FXEXP_DATA,CSOIL_DATA,SALP_DATA,REFDK_DATA, & REFKDT_DATA,FRZK_DATA,ZBOT_DATA, SMLOW_DATA,SMHIGH_DATA, & CZIL_DATA - REAL :: LVCOEF_DATA + REAL(SUMMA_PREC) :: LVCOEF_DATA CHARACTER*256 :: err_message integer, private :: iloc, jloc diff --git a/build/source/noah-mp/module_sf_noahmplsm.F b/build/source/noah-mp/module_sf_noahmplsm.F index 8ddfedbde..898efbac7 100755 --- a/build/source/noah-mp/module_sf_noahmplsm.F +++ b/build/source/noah-mp/module_sf_noahmplsm.F @@ -1,4 +1,5 @@ module noahmp_globals + USE nrtype ! Maybe most of these can be moved to a REDPRM use statement? ! MPC -- yes, all of these variables can be local to REDPRM (see additional comments) @@ -36,33 +37,33 @@ module noahmp_globals ! Physical Constants: ! !------------------------------------------------------------------------------------------! - REAL, PARAMETER :: GRAV = 9.80616 !acceleration due to gravity (m/s2) - REAL, PARAMETER :: SB = 5.67E-08 !Stefan-Boltzmann constant (w/m2/k4) - REAL, PARAMETER :: VKC = 0.40 !von Karman constant - REAL, PARAMETER :: TFRZ = 273.16 !freezing/melting point (k) - REAL, PARAMETER :: HSUB = 2.8440E06 !latent heat of sublimation (j/kg) - REAL, PARAMETER :: HVAP = 2.5104E06 !latent heat of vaporization (j/kg) - REAL, PARAMETER :: HFUS = 0.3336E06 !latent heat of fusion (j/kg) - REAL, PARAMETER :: CWAT = 4.188E06 !specific heat capacity of water (j/m3/k) - REAL, PARAMETER :: CICE = 2.094E06 !specific heat capacity of ice (j/m3/k) - REAL, PARAMETER :: CPAIR = 1004.64 !heat capacity dry air at const pres (j/kg/k) - REAL, PARAMETER :: TKWAT = 0.6 !thermal conductivity of water (w/m/k) - REAL, PARAMETER :: TKICE = 2.2 !thermal conductivity of ice (w/m/k) - REAL, PARAMETER :: TKAIR = 0.023 !thermal conductivity of air (w/m/k) - REAL, PARAMETER :: RAIR = 287.04 !gas constant for dry air (j/kg/k) - REAL, PARAMETER :: RW = 461.269 !gas constant for water vapor (j/kg/k) - REAL, PARAMETER :: DENH2O = 1000. !density of water (kg/m3) - REAL, PARAMETER :: DENICE = 917. !density of ice (kg/m3) + REAL(SUMMA_PREC), PARAMETER :: GRAV = 9.80616 !acceleration due to gravity (m/s2) + REAL(SUMMA_PREC), PARAMETER :: SB = 5.67E-08 !Stefan-Boltzmann constant (w/m2/k4) + REAL(SUMMA_PREC), PARAMETER :: VKC = 0.40 !von Karman constant + REAL(SUMMA_PREC), PARAMETER :: TFRZ = 273.16 !freezing/melting point (k) + REAL(SUMMA_PREC), PARAMETER :: HSUB = 2.8440E06 !latent heat of sublimation (j/kg) + REAL(SUMMA_PREC), PARAMETER :: HVAP = 2.5104E06 !latent heat of vaporization (j/kg) + REAL(SUMMA_PREC), PARAMETER :: HFUS = 0.3336E06 !latent heat of fusion (j/kg) + REAL(SUMMA_PREC), PARAMETER :: CWAT = 4.188E06 !specific heat capacity of water (j/m3/k) + REAL(SUMMA_PREC), PARAMETER :: CICE = 2.094E06 !specific heat capacity of ice (j/m3/k) + REAL(SUMMA_PREC), PARAMETER :: CPAIR = 1004.64 !heat capacity dry air at const pres (j/kg/k) + REAL(SUMMA_PREC), PARAMETER :: TKWAT = 0.6 !thermal conductivity of water (w/m/k) + REAL(SUMMA_PREC), PARAMETER :: TKICE = 2.2 !thermal conductivity of ice (w/m/k) + REAL(SUMMA_PREC), PARAMETER :: TKAIR = 0.023 !thermal conductivity of air (w/m/k) + REAL(SUMMA_PREC), PARAMETER :: RAIR = 287.04 !gas constant for dry air (j/kg/k) + REAL(SUMMA_PREC), PARAMETER :: RW = 461.269 !gas constant for water vapor (j/kg/k) + REAL(SUMMA_PREC), PARAMETER :: DENH2O = 1000. !density of water (kg/m3) + REAL(SUMMA_PREC), PARAMETER :: DENICE = 917. !density of ice (kg/m3) !------------------------------------------------------------------------------------------! ! From the VEGPARM.TBL tables, as functions of vegetation category. !------------------------------------------------------------------------------------------! INTEGER :: NROOT !rooting depth [as the number of layers] ( Assigned in REDPRM ) - REAL :: RGL !parameter used in radiation stress function ( Assigned in REDPRM ) - REAL :: RSMIN !minimum Canopy Resistance [s/m] ( Assigned in REDPRM ) - REAL :: HS !parameter used in vapor pressure deficit function ( Assigned in REDPRM ) - REAL :: RSMAX !maximum stomatal resistance ( Assigned in REDPRM ) - REAL :: TOPT !optimum transpiration air temperature. + REAL(SUMMA_PREC) :: RGL !parameter used in radiation stress function ( Assigned in REDPRM ) + REAL(SUMMA_PREC) :: RSMIN !minimum Canopy Resistance [s/m] ( Assigned in REDPRM ) + REAL(SUMMA_PREC) :: HS !parameter used in vapor pressure deficit function ( Assigned in REDPRM ) + REAL(SUMMA_PREC) :: RSMAX !maximum stomatal resistance ( Assigned in REDPRM ) + REAL(SUMMA_PREC) :: TOPT !optimum transpiration air temperature. ! MPC change: make variables private for a given thread !$omp threadprivate(NROOT, RGL, RSMIN, HS, RSMAX, TOPT) @@ -70,17 +71,17 @@ module noahmp_globals !------------------------------------------------------------------------------------------! ! From the SOILPARM.TBL tables, as functions of soil category. !------------------------------------------------------------------------------------------! - REAL :: BEXP !B parameter ( Assigned in REDPRM ) - REAL :: SMCDRY !dry soil moisture threshold where direct evap from top + REAL(SUMMA_PREC) :: BEXP !B parameter ( Assigned in REDPRM ) + REAL(SUMMA_PREC) :: SMCDRY !dry soil moisture threshold where direct evap from top !layer ends (volumetric) ( Assigned in REDPRM ) - REAL :: F1 !soil thermal diffusivity/conductivity coef ( Assigned in REDPRM ) - REAL :: SMCMAX !porosity, saturated value of soil moisture (volumetric) - REAL :: SMCREF !reference soil moisture (field capacity) (volumetric) ( Assigned in REDPRM ) - REAL :: PSISAT !saturated soil matric potential ( Assigned in REDPRM ) - REAL :: DKSAT !saturated soil hydraulic conductivity ( Assigned in REDPRM ) - REAL :: DWSAT !saturated soil hydraulic diffusivity ( Assigned in REDPRM ) - REAL :: SMCWLT !wilting point soil moisture (volumetric) ( Assigned in REDPRM ) - REAL :: QUARTZ !soil quartz content ( Assigned in REDPRM ) + REAL(SUMMA_PREC) :: F1 !soil thermal diffusivity/conductivity coef ( Assigned in REDPRM ) + REAL(SUMMA_PREC) :: SMCMAX !porosity, saturated value of soil moisture (volumetric) + REAL(SUMMA_PREC) :: SMCREF !reference soil moisture (field capacity) (volumetric) ( Assigned in REDPRM ) + REAL(SUMMA_PREC) :: PSISAT !saturated soil matric potential ( Assigned in REDPRM ) + REAL(SUMMA_PREC) :: DKSAT !saturated soil hydraulic conductivity ( Assigned in REDPRM ) + REAL(SUMMA_PREC) :: DWSAT !saturated soil hydraulic diffusivity ( Assigned in REDPRM ) + REAL(SUMMA_PREC) :: SMCWLT !wilting point soil moisture (volumetric) ( Assigned in REDPRM ) + REAL(SUMMA_PREC) :: QUARTZ !soil quartz content ( Assigned in REDPRM ) ! MPC change: make variables private for a given thread !$omp threadprivate(BEXP, SMCDRY, F1, SMCMAX, SMCREF, PSISAT, DKSAT, DWSAT, SMCWLT, QUARTZ) @@ -88,16 +89,16 @@ module noahmp_globals !------------------------------------------------------------------------------------------! ! From the GENPARM.TBL file !------------------------------------------------------------------------------------------! - REAL :: SLOPE !slope index (0 - 1) ( Assigned in REDPRM ) - REAL :: CSOIL !vol. soil heat capacity [j/m3/K] ( Assigned in REDPRM ) - REAL :: ZBOT !Depth (m) of lower boundary soil temperature ( Assigned in REDPRM ) - REAL :: CZIL !Calculate roughness length of heat ( Assigned in REDPRM ) + REAL(SUMMA_PREC) :: SLOPE !slope index (0 - 1) ( Assigned in REDPRM ) + REAL(SUMMA_PREC) :: CSOIL !vol. soil heat capacity [j/m3/K] ( Assigned in REDPRM ) + REAL(SUMMA_PREC) :: ZBOT !Depth (m) of lower boundary soil temperature ( Assigned in REDPRM ) + REAL(SUMMA_PREC) :: CZIL !Calculate roughness length of heat ( Assigned in REDPRM ) ! MPC note: FRZK_DATA, REFDK_DATA, and REFKDT_DATA are used in REDPRM to compute KDT and FRZX ! (FRZK, REFDK, and REFKDT are local variables within REDPRM and do not need to be thread private) - REAL :: KDT !used in compute maximum infiltration rate (in INFIL) ( Assigned in REDPRM ) - REAL :: FRZX !used in compute maximum infiltration rate (in INFIL) ( Assigned in REDPRM ) + REAL(SUMMA_PREC) :: KDT !used in compute maximum infiltration rate (in INFIL) ( Assigned in REDPRM ) + REAL(SUMMA_PREC) :: FRZX !used in compute maximum infiltration rate (in INFIL) ( Assigned in REDPRM ) ! MPC change: make variables private for a given thread !$omp threadprivate(SLOPE, CSOIL, ZBOT, CZIL, KDT, FRZX) @@ -178,15 +179,15 @@ module noahmp_globals INTEGER :: OPT_STC != 1 !(suggested 1) ! ================================================================================================== ! runoff parameters used for SIMTOP and SIMGM: - REAL, PARAMETER :: TIMEAN = 10.5 !gridcell mean topgraphic index (global mean) - REAL, PARAMETER :: FSATMX = 0.38 !maximum surface saturated fraction (global mean) + REAL(SUMMA_PREC), PARAMETER :: TIMEAN = 10.5 !gridcell mean topgraphic index (global mean) + REAL(SUMMA_PREC), PARAMETER :: FSATMX = 0.38 !maximum surface saturated fraction (global mean) ! adjustable parameters for snow processes - REAL, PARAMETER :: M = 1.0 ! 2.50 !melting factor (-) - REAL, PARAMETER :: Z0SNO = 0.002 !snow surface roughness length (m) (0.002) - REAL, PARAMETER :: SSI = 0.03 !liquid water holding capacity for snowpack (m3/m3) (0.03) - REAL, PARAMETER :: SWEMX = 1.00 !new snow mass to fully cover old snow (mm) + REAL(SUMMA_PREC), PARAMETER :: M = 1.0 ! 2.50 !melting factor (-) + REAL(SUMMA_PREC), PARAMETER :: Z0SNO = 0.002 !snow surface roughness length (m) (0.002) + REAL(SUMMA_PREC), PARAMETER :: SSI = 0.03 !liquid water holding capacity for snowpack (m3/m3) (0.03) + REAL(SUMMA_PREC), PARAMETER :: SWEMX = 1.00 !new snow mass to fully cover old snow (mm) !equivalent to 10mm depth (density = 100 kg/m3) ! NOTES: things to add or improve @@ -200,7 +201,7 @@ END MODULE NOAHMP_GLOBALS !------------------------------------------------------------------------------------------! !------------------------------------------------------------------------------------------! MODULE NOAHMP_VEG_PARAMETERS - + use nrtype IMPLICIT NONE INTEGER, PARAMETER :: MAX_VEG_PARAMS = 33 @@ -213,63 +214,63 @@ MODULE NOAHMP_VEG_PARAMETERS INTEGER :: ISSNOW INTEGER :: EBLFOREST - REAL :: CH2OP(MVT) !maximum intercepted h2o per unit lai+sai (mm) - REAL :: DLEAF(MVT) !characteristic leaf dimension (m) - REAL :: Z0MVT(MVT) !momentum roughness length (m) - REAL :: HVT(MVT) !top of canopy (m) - REAL :: HVB(MVT) !bottom of canopy (m) - REAL :: DEN(MVT) !tree density (no. of trunks per m2) - REAL :: RC(MVT) !tree crown radius (m) - REAL :: SAIM(MVT,12) !monthly stem area index, one-sided - REAL :: LAIM(MVT,12) !monthly leaf area index, one-sided - REAL :: SLA(MVT) !single-side leaf area per Kg [m2/kg] - REAL :: DILEFC(MVT) !coeficient for leaf stress death [1/s] - REAL :: DILEFW(MVT) !coeficient for leaf stress death [1/s] - REAL :: FRAGR(MVT) !fraction of growth respiration !original was 0.3 - REAL :: LTOVRC(MVT) !leaf turnover [1/s] - - REAL :: C3PSN(MVT) !photosynthetic pathway: 0. = c4, 1. = c3 - REAL :: KC25(MVT) !co2 michaelis-menten constant at 25c (pa) - REAL :: AKC(MVT) !q10 for kc25 - REAL :: KO25(MVT) !o2 michaelis-menten constant at 25c (pa) - REAL :: AKO(MVT) !q10 for ko25 - REAL :: VCMX25(MVT) !maximum rate of carboxylation at 25c (umol co2/m**2/s) - REAL :: AVCMX(MVT) !q10 for vcmx25 - REAL :: BP(MVT) !minimum leaf conductance (umol/m**2/s) - REAL :: MP(MVT) !slope of conductance-to-photosynthesis relationship - REAL :: QE25(MVT) !quantum efficiency at 25c (umol co2 / umol photon) - REAL :: AQE(MVT) !q10 for qe25 - REAL :: RMF25(MVT) !leaf maintenance respiration at 25c (umol co2/m**2/s) - REAL :: RMS25(MVT) !stem maintenance respiration at 25c (umol co2/kg bio/s) - REAL :: RMR25(MVT) !root maintenance respiration at 25c (umol co2/kg bio/s) - REAL :: ARM(MVT) !q10 for maintenance respiration - REAL :: FOLNMX(MVT) !foliage nitrogen concentration when f(n)=1 (%) - REAL :: TMIN(MVT) !minimum temperature for photosynthesis (k) - - REAL :: XL(MVT) !leaf/stem orientation index - REAL :: RHOL(MVT,MBAND) !leaf reflectance: 1=vis, 2=nir - REAL :: RHOS(MVT,MBAND) !stem reflectance: 1=vis, 2=nir - REAL :: TAUL(MVT,MBAND) !leaf transmittance: 1=vis, 2=nir - REAL :: TAUS(MVT,MBAND) !stem transmittance: 1=vis, 2=nir - - REAL :: MRP(MVT) !microbial respiration parameter (umol co2 /kg c/ s) - REAL :: CWPVT(MVT) !empirical canopy wind parameter - - REAL :: WRRAT(MVT) !wood to non-wood ratio - REAL :: WDPOOL(MVT) !wood pool (switch 1 or 0) depending on woody or not [-] - REAL :: TDLEF(MVT) !characteristic T for leaf freezing [K] + REAL(SUMMA_PREC) :: CH2OP(MVT) !maximum intercepted h2o per unit lai+sai (mm) + REAL(SUMMA_PREC) :: DLEAF(MVT) !characteristic leaf dimension (m) + REAL(SUMMA_PREC) :: Z0MVT(MVT) !momentum roughness length (m) + REAL(SUMMA_PREC) :: HVT(MVT) !top of canopy (m) + REAL(SUMMA_PREC) :: HVB(MVT) !bottom of canopy (m) + REAL(SUMMA_PREC) :: DEN(MVT) !tree density (no. of trunks per m2) + REAL(SUMMA_PREC) :: RC(MVT) !tree crown radius (m) + REAL(SUMMA_PREC) :: SAIM(MVT,12) !monthly stem area index, one-sided + REAL(SUMMA_PREC) :: LAIM(MVT,12) !monthly leaf area index, one-sided + REAL(SUMMA_PREC) :: SLA(MVT) !single-side leaf area per Kg [m2/kg] + REAL(SUMMA_PREC) :: DILEFC(MVT) !coeficient for leaf stress death [1/s] + REAL(SUMMA_PREC) :: DILEFW(MVT) !coeficient for leaf stress death [1/s] + REAL(SUMMA_PREC) :: FRAGR(MVT) !fraction of growth respiration !original was 0.3 + REAL(SUMMA_PREC) :: LTOVRC(MVT) !leaf turnover [1/s] + + REAL(SUMMA_PREC) :: C3PSN(MVT) !photosynthetic pathway: 0. = c4, 1. = c3 + REAL(SUMMA_PREC) :: KC25(MVT) !co2 michaelis-menten constant at 25c (pa) + REAL(SUMMA_PREC) :: AKC(MVT) !q10 for kc25 + REAL(SUMMA_PREC) :: KO25(MVT) !o2 michaelis-menten constant at 25c (pa) + REAL(SUMMA_PREC) :: AKO(MVT) !q10 for ko25 + REAL(SUMMA_PREC) :: VCMX25(MVT) !maximum rate of carboxylation at 25c (umol co2/m**2/s) + REAL(SUMMA_PREC) :: AVCMX(MVT) !q10 for vcmx25 + REAL(SUMMA_PREC) :: BP(MVT) !minimum leaf conductance (umol/m**2/s) + REAL(SUMMA_PREC) :: MP(MVT) !slope of conductance-to-photosynthesis relationship + REAL(SUMMA_PREC) :: QE25(MVT) !quantum efficiency at 25c (umol co2 / umol photon) + REAL(SUMMA_PREC) :: AQE(MVT) !q10 for qe25 + REAL(SUMMA_PREC) :: RMF25(MVT) !leaf maintenance respiration at 25c (umol co2/m**2/s) + REAL(SUMMA_PREC) :: RMS25(MVT) !stem maintenance respiration at 25c (umol co2/kg bio/s) + REAL(SUMMA_PREC) :: RMR25(MVT) !root maintenance respiration at 25c (umol co2/kg bio/s) + REAL(SUMMA_PREC) :: ARM(MVT) !q10 for maintenance respiration + REAL(SUMMA_PREC) :: FOLNMX(MVT) !foliage nitrogen concentration when f(n)=1 (%) + REAL(SUMMA_PREC) :: TMIN(MVT) !minimum temperature for photosynthesis (k) + + REAL(SUMMA_PREC) :: XL(MVT) !leaf/stem orientation index + REAL(SUMMA_PREC) :: RHOL(MVT,MBAND) !leaf reflectance: 1=vis, 2=nir + REAL(SUMMA_PREC) :: RHOS(MVT,MBAND) !stem reflectance: 1=vis, 2=nir + REAL(SUMMA_PREC) :: TAUL(MVT,MBAND) !leaf transmittance: 1=vis, 2=nir + REAL(SUMMA_PREC) :: TAUS(MVT,MBAND) !stem transmittance: 1=vis, 2=nir + + REAL(SUMMA_PREC) :: MRP(MVT) !microbial respiration parameter (umol co2 /kg c/ s) + REAL(SUMMA_PREC) :: CWPVT(MVT) !empirical canopy wind parameter + + REAL(SUMMA_PREC) :: WRRAT(MVT) !wood to non-wood ratio + REAL(SUMMA_PREC) :: WDPOOL(MVT) !wood pool (switch 1 or 0) depending on woody or not [-] + REAL(SUMMA_PREC) :: TDLEF(MVT) !characteristic T for leaf freezing [K] INTEGER :: IK,IM - REAL :: TMP10(MVT*MBAND) - REAL :: TMP11(MVT*MBAND) - REAL :: TMP12(MVT*MBAND) - REAL :: TMP13(MVT*MBAND) - REAL :: TMP14(MVT*12) - REAL :: TMP15(MVT*12) - REAL :: TMP16(MVT*5) + REAL(SUMMA_PREC) :: TMP10(MVT*MBAND) + REAL(SUMMA_PREC) :: TMP11(MVT*MBAND) + REAL(SUMMA_PREC) :: TMP12(MVT*MBAND) + REAL(SUMMA_PREC) :: TMP13(MVT*MBAND) + REAL(SUMMA_PREC) :: TMP14(MVT*12) + REAL(SUMMA_PREC) :: TMP15(MVT*12) + REAL(SUMMA_PREC) :: TMP16(MVT*5) - real slarea(MVT) - real eps(MVT,5) + real(summa_prec) slarea(MVT) + real(summa_prec) eps(MVT,5) CONTAINS subroutine read_mp_veg_parameters(FILENAME_VEGTABLE,DATASET_IDENTIFIER) @@ -279,13 +280,13 @@ subroutine read_mp_veg_parameters(FILENAME_VEGTABLE,DATASET_IDENTIFIER) integer :: ierr ! Temporary arrays used in reshaping namelist arrays - REAL :: TMP10(MVT*MBAND) - REAL :: TMP11(MVT*MBAND) - REAL :: TMP12(MVT*MBAND) - REAL :: TMP13(MVT*MBAND) - REAL :: TMP14(MVT*12) - REAL :: TMP15(MVT*12) - REAL :: TMP16(MVT*5) + REAL(SUMMA_PREC) :: TMP10(MVT*MBAND) + REAL(SUMMA_PREC) :: TMP11(MVT*MBAND) + REAL(SUMMA_PREC) :: TMP12(MVT*MBAND) + REAL(SUMMA_PREC) :: TMP13(MVT*MBAND) + REAL(SUMMA_PREC) :: TMP14(MVT*12) + REAL(SUMMA_PREC) :: TMP15(MVT*12) + REAL(SUMMA_PREC) :: TMP16(MVT*5) integer :: NVEG character(len=256) :: VEG_DATASET_DESCRIPTION @@ -439,6 +440,7 @@ END MODULE NOAHMP_VEG_PARAMETERS ! ================================================================================================== ! ================================================================================================== MODULE NOAHMP_RAD_PARAMETERS + use nrtype IMPLICIT NONE @@ -446,14 +448,14 @@ MODULE NOAHMP_RAD_PARAMETERS INTEGER, PARAMETER :: MSC = 9 INTEGER, PARAMETER :: MBAND = 2 - REAL :: ALBSAT(MSC,MBAND) !saturated soil albedos: 1=vis, 2=nir - REAL :: ALBDRY(MSC,MBAND) !dry soil albedos: 1=vis, 2=nir - REAL :: ALBICE(MBAND) !albedo land ice: 1=vis, 2=nir - REAL :: ALBLAK(MBAND) !albedo frozen lakes: 1=vis, 2=nir - REAL :: OMEGAS(MBAND) !two-stream parameter omega for snow - REAL :: BETADS !two-stream parameter betad for snow - REAL :: BETAIS !two-stream parameter betad for snow - REAL :: EG(2) !emissivity + REAL(SUMMA_PREC) :: ALBSAT(MSC,MBAND) !saturated soil albedos: 1=vis, 2=nir + REAL(SUMMA_PREC) :: ALBDRY(MSC,MBAND) !dry soil albedos: 1=vis, 2=nir + REAL(SUMMA_PREC) :: ALBICE(MBAND) !albedo land ice: 1=vis, 2=nir + REAL(SUMMA_PREC) :: ALBLAK(MBAND) !albedo frozen lakes: 1=vis, 2=nir + REAL(SUMMA_PREC) :: OMEGAS(MBAND) !two-stream parameter omega for snow + REAL(SUMMA_PREC) :: BETADS !two-stream parameter betad for snow + REAL(SUMMA_PREC) :: BETAIS !two-stream parameter betad for snow + REAL(SUMMA_PREC) :: EG(2) !emissivity ! saturated soil albedos: 1=vis, 2=nir DATA(ALBSAT(I,1),I=1,8)/0.15,0.11,0.10,0.09,0.08,0.07,0.06,0.05/ @@ -480,6 +482,7 @@ END MODULE NOAHMP_RAD_PARAMETERS ! ================================================================================================== MODULE NOAHMP_ROUTINES + use nrtype USE NOAHMP_GLOBALS IMPLICIT NONE @@ -515,33 +518,33 @@ SUBROUTINE PHENOLOGY (VEGTYP , ISURBAN, SNOWH , TV , LAT , YEARLEN , JULI ! inputs INTEGER , INTENT(IN ) :: VEGTYP !vegetation type INTEGER , INTENT(IN ) :: ISURBAN!urban category - REAL , INTENT(IN ) :: SNOWH !snow height [m] - REAL , INTENT(IN ) :: TV !vegetation temperature (k) - REAL , INTENT(IN ) :: LAT !latitude (radians) + REAL(SUMMA_PREC) , INTENT(IN ) :: SNOWH !snow height [m] + REAL(SUMMA_PREC) , INTENT(IN ) :: TV !vegetation temperature (k) + REAL(SUMMA_PREC) , INTENT(IN ) :: LAT !latitude (radians) INTEGER , INTENT(IN ) :: YEARLEN!Number of days in the particular year - REAL , INTENT(IN ) :: JULIAN !Julian day of year (fractional) ( 0 <= JULIAN < YEARLEN ) - real , INTENT(IN ) :: TROOT !root-zone averaged temperature (k) - REAL , INTENT(INOUT) :: LAI !LAI, unadjusted for burying by snow - REAL , INTENT(INOUT) :: SAI !SAI, unadjusted for burying by snow + REAL(SUMMA_PREC) , INTENT(IN ) :: JULIAN !Julian day of year (fractional) ( 0 <= JULIAN < YEARLEN ) + real(summa_prec) , INTENT(IN ) :: TROOT !root-zone averaged temperature (k) + REAL(SUMMA_PREC) , INTENT(INOUT) :: LAI !LAI, unadjusted for burying by snow + REAL(SUMMA_PREC) , INTENT(INOUT) :: SAI !SAI, unadjusted for burying by snow ! outputs - REAL , INTENT(OUT ) :: HTOP !top of canopy layer (m) - REAL , INTENT(OUT ) :: ELAI !leaf area index, after burying by snow - REAL , INTENT(OUT ) :: ESAI !stem area index, after burying by snow - REAL , INTENT(OUT ) :: IGS !growing season index (0=off, 1=on) + REAL(SUMMA_PREC) , INTENT(OUT ) :: HTOP !top of canopy layer (m) + REAL(SUMMA_PREC) , INTENT(OUT ) :: ELAI !leaf area index, after burying by snow + REAL(SUMMA_PREC) , INTENT(OUT ) :: ESAI !stem area index, after burying by snow + REAL(SUMMA_PREC) , INTENT(OUT ) :: IGS !growing season index (0=off, 1=on) ! locals - REAL :: DB !thickness of canopy buried by snow (m) - REAL :: FB !fraction of canopy buried by snow - REAL :: SNOWHC !critical snow depth at which short vege + REAL(SUMMA_PREC) :: DB !thickness of canopy buried by snow (m) + REAL(SUMMA_PREC) :: FB !fraction of canopy buried by snow + REAL(SUMMA_PREC) :: SNOWHC !critical snow depth at which short vege !is fully covered by snow INTEGER :: K !index INTEGER :: IT1,IT2 !interpolation months - REAL :: DAY !current day of year ( 0 <= DAY < YEARLEN ) - REAL :: WT1,WT2 !interpolation weights - REAL :: T !current month (1.00, ..., 12.00) + REAL(SUMMA_PREC) :: DAY !current day of year ( 0 <= DAY < YEARLEN ) + REAL(SUMMA_PREC) :: WT1,WT2 !interpolation weights + REAL(SUMMA_PREC) :: T !current month (1.00, ..., 12.00) ! -------------------------------------------------------------------------------------------------- IF ( DVEG == 1 .or. DVEG == 3 .or. DVEG == 4 ) THEN @@ -626,67 +629,67 @@ SUBROUTINE RADIATION (VEGTYP ,IST ,ISC ,ICE ,NSOIL , & !in INTEGER, INTENT(IN) :: ICE !ice (ice = 1) INTEGER, INTENT(IN) :: NSOIL !number of soil layers - REAL, INTENT(IN) :: DT !time step [s] - REAL, INTENT(IN) :: QSNOW !snowfall (mm/s) - REAL, INTENT(IN) :: SNEQVO !snow mass at last time step(mm) - REAL, INTENT(IN) :: SNEQV !snow mass (mm) - REAL, INTENT(IN) :: SNOWH !snow height (mm) - REAL, INTENT(IN) :: COSZ !cosine solar zenith angle (0-1) - REAL, INTENT(IN) :: TG !ground temperature (k) - REAL, INTENT(IN) :: TV !vegetation temperature (k) - REAL, INTENT(IN) :: ELAI !LAI, one-sided, adjusted for burying by snow - REAL, INTENT(IN) :: ESAI !SAI, one-sided, adjusted for burying by snow - REAL, INTENT(IN) :: FWET !fraction of canopy that is wet - REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SMC !volumetric soil water [m3/m3] - REAL, DIMENSION(1:2) , INTENT(IN) :: SOLAD !incoming direct solar radiation (w/m2) - REAL, DIMENSION(1:2) , INTENT(IN) :: SOLAI !incoming diffuse solar radiation (w/m2) - REAL, INTENT(IN) :: FSNO !snow cover fraction (-) - REAL, INTENT(IN) :: FVEG !green vegetation fraction [0.0-1.0] + REAL(SUMMA_PREC), INTENT(IN) :: DT !time step [s] + REAL(SUMMA_PREC), INTENT(IN) :: QSNOW !snowfall (mm/s) + REAL(SUMMA_PREC), INTENT(IN) :: SNEQVO !snow mass at last time step(mm) + REAL(SUMMA_PREC), INTENT(IN) :: SNEQV !snow mass (mm) + REAL(SUMMA_PREC), INTENT(IN) :: SNOWH !snow height (mm) + REAL(SUMMA_PREC), INTENT(IN) :: COSZ !cosine solar zenith angle (0-1) + REAL(SUMMA_PREC), INTENT(IN) :: TG !ground temperature (k) + REAL(SUMMA_PREC), INTENT(IN) :: TV !vegetation temperature (k) + REAL(SUMMA_PREC), INTENT(IN) :: ELAI !LAI, one-sided, adjusted for burying by snow + REAL(SUMMA_PREC), INTENT(IN) :: ESAI !SAI, one-sided, adjusted for burying by snow + REAL(SUMMA_PREC), INTENT(IN) :: FWET !fraction of canopy that is wet + REAL(SUMMA_PREC), DIMENSION(1:NSOIL), INTENT(IN) :: SMC !volumetric soil water [m3/m3] + REAL(SUMMA_PREC), DIMENSION(1:2) , INTENT(IN) :: SOLAD !incoming direct solar radiation (w/m2) + REAL(SUMMA_PREC), DIMENSION(1:2) , INTENT(IN) :: SOLAI !incoming diffuse solar radiation (w/m2) + REAL(SUMMA_PREC), INTENT(IN) :: FSNO !snow cover fraction (-) + REAL(SUMMA_PREC), INTENT(IN) :: FVEG !green vegetation fraction [0.0-1.0] ! inout - REAL, INTENT(INOUT) :: ALBOLD !snow albedo at last time step (CLASS type) - REAL, INTENT(INOUT) :: TAUSS !non-dimensional snow age. + REAL(SUMMA_PREC), INTENT(INOUT) :: ALBOLD !snow albedo at last time step (CLASS type) + REAL(SUMMA_PREC), INTENT(INOUT) :: TAUSS !non-dimensional snow age. ! output - REAL, INTENT(OUT) :: FSUN !sunlit fraction of canopy (-) - REAL, INTENT(OUT) :: LAISUN !sunlit leaf area (-) - REAL, INTENT(OUT) :: LAISHA !shaded leaf area (-) - REAL, INTENT(OUT) :: PARSUN !average absorbed par for sunlit leaves (w/m2) - REAL, INTENT(OUT) :: PARSHA !average absorbed par for shaded leaves (w/m2) - REAL, INTENT(OUT) :: SAV !solar radiation absorbed by vegetation (w/m2) - REAL, INTENT(OUT) :: SAG !solar radiation absorbed by ground (w/m2) - REAL, INTENT(OUT) :: FSA !total absorbed solar radiation (w/m2) - REAL, INTENT(OUT) :: FSR !total reflected solar radiation (w/m2) + REAL(SUMMA_PREC), INTENT(OUT) :: FSUN !sunlit fraction of canopy (-) + REAL(SUMMA_PREC), INTENT(OUT) :: LAISUN !sunlit leaf area (-) + REAL(SUMMA_PREC), INTENT(OUT) :: LAISHA !shaded leaf area (-) + REAL(SUMMA_PREC), INTENT(OUT) :: PARSUN !average absorbed par for sunlit leaves (w/m2) + REAL(SUMMA_PREC), INTENT(OUT) :: PARSHA !average absorbed par for shaded leaves (w/m2) + REAL(SUMMA_PREC), INTENT(OUT) :: SAV !solar radiation absorbed by vegetation (w/m2) + REAL(SUMMA_PREC), INTENT(OUT) :: SAG !solar radiation absorbed by ground (w/m2) + REAL(SUMMA_PREC), INTENT(OUT) :: FSA !total absorbed solar radiation (w/m2) + REAL(SUMMA_PREC), INTENT(OUT) :: FSR !total reflected solar radiation (w/m2) !jref:start - REAL, INTENT(OUT) :: FSRV !veg. reflected solar radiation (w/m2) - REAL, INTENT(OUT) :: FSRG !ground reflected solar radiation (w/m2) - REAL, INTENT(OUT) :: BGAP - REAL, INTENT(OUT) :: WGAP + REAL(SUMMA_PREC), INTENT(OUT) :: FSRV !veg. reflected solar radiation (w/m2) + REAL(SUMMA_PREC), INTENT(OUT) :: FSRG !ground reflected solar radiation (w/m2) + REAL(SUMMA_PREC), INTENT(OUT) :: BGAP + REAL(SUMMA_PREC), INTENT(OUT) :: WGAP !jref:end ! local - REAL :: FAGE !snow age function (0 - new snow) - REAL, DIMENSION(1:2) :: ALBGRD !ground albedo (direct) - REAL, DIMENSION(1:2) :: ALBGRI !ground albedo (diffuse) - REAL, DIMENSION(1:2) :: ALBD !surface albedo (direct) - REAL, DIMENSION(1:2) :: ALBI !surface albedo (diffuse) - REAL, DIMENSION(1:2) :: FABD !flux abs by veg (per unit direct flux) - REAL, DIMENSION(1:2) :: FABI !flux abs by veg (per unit diffuse flux) - REAL, DIMENSION(1:2) :: FTDD !down direct flux below veg (per unit dir flux) - REAL, DIMENSION(1:2) :: FTID !down diffuse flux below veg (per unit dir flux) - REAL, DIMENSION(1:2) :: FTII !down diffuse flux below veg (per unit dif flux) + REAL(SUMMA_PREC) :: FAGE !snow age function (0 - new snow) + REAL(SUMMA_PREC), DIMENSION(1:2) :: ALBGRD !ground albedo (direct) + REAL(SUMMA_PREC), DIMENSION(1:2) :: ALBGRI !ground albedo (diffuse) + REAL(SUMMA_PREC), DIMENSION(1:2) :: ALBD !surface albedo (direct) + REAL(SUMMA_PREC), DIMENSION(1:2) :: ALBI !surface albedo (diffuse) + REAL(SUMMA_PREC), DIMENSION(1:2) :: FABD !flux abs by veg (per unit direct flux) + REAL(SUMMA_PREC), DIMENSION(1:2) :: FABI !flux abs by veg (per unit diffuse flux) + REAL(SUMMA_PREC), DIMENSION(1:2) :: FTDD !down direct flux below veg (per unit dir flux) + REAL(SUMMA_PREC), DIMENSION(1:2) :: FTID !down diffuse flux below veg (per unit dir flux) + REAL(SUMMA_PREC), DIMENSION(1:2) :: FTII !down diffuse flux below veg (per unit dif flux) !jref:start - REAL, DIMENSION(1:2) :: FREVI - REAL, DIMENSION(1:2) :: FREVD - REAL, DIMENSION(1:2) :: FREGI - REAL, DIMENSION(1:2) :: FREGD + REAL(SUMMA_PREC), DIMENSION(1:2) :: FREVI + REAL(SUMMA_PREC), DIMENSION(1:2) :: FREVD + REAL(SUMMA_PREC), DIMENSION(1:2) :: FREGI + REAL(SUMMA_PREC), DIMENSION(1:2) :: FREGD !jref:end - REAL :: FSHA !shaded fraction of canopy - REAL :: VAI !total LAI + stem area index, one sided + REAL(SUMMA_PREC) :: FSHA !shaded fraction of canopy + REAL(SUMMA_PREC) :: VAI !total LAI + stem area index, one sided - REAL,PARAMETER :: MPE = 1.E-6 + REAL(SUMMA_PREC),PARAMETER :: MPE = 1.E-6 LOGICAL VEG !true: vegetated for surface temperature calculation ! -------------------------------------------------------------------------------------------------- @@ -757,67 +760,67 @@ SUBROUTINE ALBEDO (VEGTYP ,IST ,ISC ,ICE ,NSOIL , & !in INTEGER, INTENT(IN) :: ISC !soil color type (1-lighest; 8-darkest) INTEGER, INTENT(IN) :: ICE !ice (ice = 1) - REAL, INTENT(IN) :: DT !time step [sec] - REAL, INTENT(IN) :: QSNOW !snowfall - REAL, INTENT(IN) :: COSZ !cosine solar zenith angle for next time step - REAL, INTENT(IN) :: SNOWH !snow height (mm) - REAL, INTENT(IN) :: TG !ground temperature (k) - REAL, INTENT(IN) :: TV !vegetation temperature (k) - REAL, INTENT(IN) :: ELAI !LAI, one-sided, adjusted for burying by snow - REAL, INTENT(IN) :: ESAI !SAI, one-sided, adjusted for burying by snow - REAL, INTENT(IN) :: FSNO !fraction of grid covered by snow - REAL, INTENT(IN) :: FWET !fraction of canopy that is wet - REAL, INTENT(IN) :: SNEQVO !snow mass at last time step(mm) - REAL, INTENT(IN) :: SNEQV !snow mass (mm) - REAL, INTENT(IN) :: FVEG !green vegetation fraction [0.0-1.0] - REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SMC !volumetric soil water (m3/m3) + REAL(SUMMA_PREC), INTENT(IN) :: DT !time step [sec] + REAL(SUMMA_PREC), INTENT(IN) :: QSNOW !snowfall + REAL(SUMMA_PREC), INTENT(IN) :: COSZ !cosine solar zenith angle for next time step + REAL(SUMMA_PREC), INTENT(IN) :: SNOWH !snow height (mm) + REAL(SUMMA_PREC), INTENT(IN) :: TG !ground temperature (k) + REAL(SUMMA_PREC), INTENT(IN) :: TV !vegetation temperature (k) + REAL(SUMMA_PREC), INTENT(IN) :: ELAI !LAI, one-sided, adjusted for burying by snow + REAL(SUMMA_PREC), INTENT(IN) :: ESAI !SAI, one-sided, adjusted for burying by snow + REAL(SUMMA_PREC), INTENT(IN) :: FSNO !fraction of grid covered by snow + REAL(SUMMA_PREC), INTENT(IN) :: FWET !fraction of canopy that is wet + REAL(SUMMA_PREC), INTENT(IN) :: SNEQVO !snow mass at last time step(mm) + REAL(SUMMA_PREC), INTENT(IN) :: SNEQV !snow mass (mm) + REAL(SUMMA_PREC), INTENT(IN) :: FVEG !green vegetation fraction [0.0-1.0] + REAL(SUMMA_PREC), DIMENSION(1:NSOIL), INTENT(IN) :: SMC !volumetric soil water (m3/m3) ! inout - REAL, INTENT(INOUT) :: ALBOLD !snow albedo at last time step (CLASS type) - REAL, INTENT(INOUT) :: TAUSS !non-dimensional snow age + REAL(SUMMA_PREC), INTENT(INOUT) :: ALBOLD !snow albedo at last time step (CLASS type) + REAL(SUMMA_PREC), INTENT(INOUT) :: TAUSS !non-dimensional snow age ! output - REAL, DIMENSION(1: 2), INTENT(OUT) :: ALBGRD !ground albedo (direct) - REAL, DIMENSION(1: 2), INTENT(OUT) :: ALBGRI !ground albedo (diffuse) - REAL, DIMENSION(1: 2), INTENT(OUT) :: ALBD !surface albedo (direct) - REAL, DIMENSION(1: 2), INTENT(OUT) :: ALBI !surface albedo (diffuse) - REAL, DIMENSION(1: 2), INTENT(OUT) :: FABD !flux abs by veg (per unit direct flux) - REAL, DIMENSION(1: 2), INTENT(OUT) :: FABI !flux abs by veg (per unit diffuse flux) - REAL, DIMENSION(1: 2), INTENT(OUT) :: FTDD !down direct flux below veg (per unit dir flux) - REAL, DIMENSION(1: 2), INTENT(OUT) :: FTID !down diffuse flux below veg (per unit dir flux) - REAL, DIMENSION(1: 2), INTENT(OUT) :: FTII !down diffuse flux below veg (per unit dif flux) - REAL, INTENT(OUT) :: FSUN !sunlit fraction of canopy (-) + REAL(SUMMA_PREC), DIMENSION(1: 2), INTENT(OUT) :: ALBGRD !ground albedo (direct) + REAL(SUMMA_PREC), DIMENSION(1: 2), INTENT(OUT) :: ALBGRI !ground albedo (diffuse) + REAL(SUMMA_PREC), DIMENSION(1: 2), INTENT(OUT) :: ALBD !surface albedo (direct) + REAL(SUMMA_PREC), DIMENSION(1: 2), INTENT(OUT) :: ALBI !surface albedo (diffuse) + REAL(SUMMA_PREC), DIMENSION(1: 2), INTENT(OUT) :: FABD !flux abs by veg (per unit direct flux) + REAL(SUMMA_PREC), DIMENSION(1: 2), INTENT(OUT) :: FABI !flux abs by veg (per unit diffuse flux) + REAL(SUMMA_PREC), DIMENSION(1: 2), INTENT(OUT) :: FTDD !down direct flux below veg (per unit dir flux) + REAL(SUMMA_PREC), DIMENSION(1: 2), INTENT(OUT) :: FTID !down diffuse flux below veg (per unit dir flux) + REAL(SUMMA_PREC), DIMENSION(1: 2), INTENT(OUT) :: FTII !down diffuse flux below veg (per unit dif flux) + REAL(SUMMA_PREC), INTENT(OUT) :: FSUN !sunlit fraction of canopy (-) !jref:start - REAL, DIMENSION(1: 2), INTENT(OUT) :: FREVD - REAL, DIMENSION(1: 2), INTENT(OUT) :: FREVI - REAL, DIMENSION(1: 2), INTENT(OUT) :: FREGD - REAL, DIMENSION(1: 2), INTENT(OUT) :: FREGI - REAL, INTENT(OUT) :: BGAP - REAL, INTENT(OUT) :: WGAP + REAL(SUMMA_PREC), DIMENSION(1: 2), INTENT(OUT) :: FREVD + REAL(SUMMA_PREC), DIMENSION(1: 2), INTENT(OUT) :: FREVI + REAL(SUMMA_PREC), DIMENSION(1: 2), INTENT(OUT) :: FREGD + REAL(SUMMA_PREC), DIMENSION(1: 2), INTENT(OUT) :: FREGI + REAL(SUMMA_PREC), INTENT(OUT) :: BGAP + REAL(SUMMA_PREC), INTENT(OUT) :: WGAP !jref:end ! ------------------------------------------------------------------------ ! ------------------------ local variables ------------------------------- ! local - REAL :: FAGE !snow age function - REAL :: ALB + REAL(SUMMA_PREC) :: FAGE !snow age function + REAL(SUMMA_PREC) :: ALB INTEGER :: IB !indices INTEGER :: NBAND !number of solar radiation wave bands INTEGER :: IC !direct beam: ic=0; diffuse: ic=1 - REAL :: WL !fraction of LAI+SAI that is LAI - REAL :: WS !fraction of LAI+SAI that is SAI - REAL :: MPE !prevents overflow for division by zero + REAL(SUMMA_PREC) :: WL !fraction of LAI+SAI that is LAI + REAL(SUMMA_PREC) :: WS !fraction of LAI+SAI that is SAI + REAL(SUMMA_PREC) :: MPE !prevents overflow for division by zero - REAL, DIMENSION(1:2) :: RHO !leaf/stem reflectance weighted by fraction LAI and SAI - REAL, DIMENSION(1:2) :: TAU !leaf/stem transmittance weighted by fraction LAI and SAI - REAL, DIMENSION(1:2) :: FTDI !down direct flux below veg per unit dif flux = 0 - REAL, DIMENSION(1:2) :: ALBSND !snow albedo (direct) - REAL, DIMENSION(1:2) :: ALBSNI !snow albedo (diffuse) + REAL(SUMMA_PREC), DIMENSION(1:2) :: RHO !leaf/stem reflectance weighted by fraction LAI and SAI + REAL(SUMMA_PREC), DIMENSION(1:2) :: TAU !leaf/stem transmittance weighted by fraction LAI and SAI + REAL(SUMMA_PREC), DIMENSION(1:2) :: FTDI !down direct flux below veg per unit dif flux = 0 + REAL(SUMMA_PREC), DIMENSION(1:2) :: ALBSND !snow albedo (direct) + REAL(SUMMA_PREC), DIMENSION(1:2) :: ALBSNI !snow albedo (diffuse) - REAL :: VAI !ELAI+ESAI - REAL :: GDIR !average projected leaf/stem area in solar direction - REAL :: EXT !optical depth direct beam per unit leaf + stem area + REAL(SUMMA_PREC) :: VAI !ELAI+ESAI + REAL(SUMMA_PREC) :: GDIR !average projected leaf/stem area in solar direction + REAL(SUMMA_PREC) :: EXT !optical depth direct beam per unit leaf + stem area ! -------------------------------------------------------------------------------------------------- @@ -928,55 +931,55 @@ SUBROUTINE SURRAD (MPE ,FSUN ,FSHA ,ELAI ,VAI , & !in INTEGER, INTENT(IN) :: ILOC INTEGER, INTENT(IN) :: JLOC - REAL, INTENT(IN) :: MPE !prevents underflow errors if division by zero - - REAL, INTENT(IN) :: FSUN !sunlit fraction of canopy - REAL, INTENT(IN) :: FSHA !shaded fraction of canopy - REAL, INTENT(IN) :: ELAI !leaf area, one-sided - REAL, INTENT(IN) :: VAI !leaf + stem area, one-sided - REAL, INTENT(IN) :: LAISUN !sunlit leaf area index, one-sided - REAL, INTENT(IN) :: LAISHA !shaded leaf area index, one-sided - - REAL, DIMENSION(1:2), INTENT(IN) :: SOLAD !incoming direct solar radiation (w/m2) - REAL, DIMENSION(1:2), INTENT(IN) :: SOLAI !incoming diffuse solar radiation (w/m2) - REAL, DIMENSION(1:2), INTENT(IN) :: FABD !flux abs by veg (per unit incoming direct flux) - REAL, DIMENSION(1:2), INTENT(IN) :: FABI !flux abs by veg (per unit incoming diffuse flux) - REAL, DIMENSION(1:2), INTENT(IN) :: FTDD !down dir flux below veg (per incoming dir flux) - REAL, DIMENSION(1:2), INTENT(IN) :: FTID !down dif flux below veg (per incoming dir flux) - REAL, DIMENSION(1:2), INTENT(IN) :: FTII !down dif flux below veg (per incoming dif flux) - REAL, DIMENSION(1:2), INTENT(IN) :: ALBGRD !ground albedo (direct) - REAL, DIMENSION(1:2), INTENT(IN) :: ALBGRI !ground albedo (diffuse) - REAL, DIMENSION(1:2), INTENT(IN) :: ALBD !overall surface albedo (direct) - REAL, DIMENSION(1:2), INTENT(IN) :: ALBI !overall surface albedo (diffuse) - - REAL, DIMENSION(1:2), INTENT(IN) :: FREVD !overall surface albedo veg (direct) - REAL, DIMENSION(1:2), INTENT(IN) :: FREVI !overall surface albedo veg (diffuse) - REAL, DIMENSION(1:2), INTENT(IN) :: FREGD !overall surface albedo grd (direct) - REAL, DIMENSION(1:2), INTENT(IN) :: FREGI !overall surface albedo grd (diffuse) + REAL(SUMMA_PREC), INTENT(IN) :: MPE !prevents underflow errors if division by zero + + REAL(SUMMA_PREC), INTENT(IN) :: FSUN !sunlit fraction of canopy + REAL(SUMMA_PREC), INTENT(IN) :: FSHA !shaded fraction of canopy + REAL(SUMMA_PREC), INTENT(IN) :: ELAI !leaf area, one-sided + REAL(SUMMA_PREC), INTENT(IN) :: VAI !leaf + stem area, one-sided + REAL(SUMMA_PREC), INTENT(IN) :: LAISUN !sunlit leaf area index, one-sided + REAL(SUMMA_PREC), INTENT(IN) :: LAISHA !shaded leaf area index, one-sided + + REAL(SUMMA_PREC), DIMENSION(1:2), INTENT(IN) :: SOLAD !incoming direct solar radiation (w/m2) + REAL(SUMMA_PREC), DIMENSION(1:2), INTENT(IN) :: SOLAI !incoming diffuse solar radiation (w/m2) + REAL(SUMMA_PREC), DIMENSION(1:2), INTENT(IN) :: FABD !flux abs by veg (per unit incoming direct flux) + REAL(SUMMA_PREC), DIMENSION(1:2), INTENT(IN) :: FABI !flux abs by veg (per unit incoming diffuse flux) + REAL(SUMMA_PREC), DIMENSION(1:2), INTENT(IN) :: FTDD !down dir flux below veg (per incoming dir flux) + REAL(SUMMA_PREC), DIMENSION(1:2), INTENT(IN) :: FTID !down dif flux below veg (per incoming dir flux) + REAL(SUMMA_PREC), DIMENSION(1:2), INTENT(IN) :: FTII !down dif flux below veg (per incoming dif flux) + REAL(SUMMA_PREC), DIMENSION(1:2), INTENT(IN) :: ALBGRD !ground albedo (direct) + REAL(SUMMA_PREC), DIMENSION(1:2), INTENT(IN) :: ALBGRI !ground albedo (diffuse) + REAL(SUMMA_PREC), DIMENSION(1:2), INTENT(IN) :: ALBD !overall surface albedo (direct) + REAL(SUMMA_PREC), DIMENSION(1:2), INTENT(IN) :: ALBI !overall surface albedo (diffuse) + + REAL(SUMMA_PREC), DIMENSION(1:2), INTENT(IN) :: FREVD !overall surface albedo veg (direct) + REAL(SUMMA_PREC), DIMENSION(1:2), INTENT(IN) :: FREVI !overall surface albedo veg (diffuse) + REAL(SUMMA_PREC), DIMENSION(1:2), INTENT(IN) :: FREGD !overall surface albedo grd (direct) + REAL(SUMMA_PREC), DIMENSION(1:2), INTENT(IN) :: FREGI !overall surface albedo grd (diffuse) ! output - REAL, INTENT(OUT) :: PARSUN !average absorbed par for sunlit leaves (w/m2) - REAL, INTENT(OUT) :: PARSHA !average absorbed par for shaded leaves (w/m2) - REAL, INTENT(OUT) :: SAV !solar radiation absorbed by vegetation (w/m2) - REAL, INTENT(OUT) :: SAG !solar radiation absorbed by ground (w/m2) - REAL, INTENT(OUT) :: FSA !total absorbed solar radiation (w/m2) - REAL, INTENT(OUT) :: FSR !total reflected solar radiation (w/m2) - REAL, INTENT(OUT) :: FSRV !reflected solar radiation by vegetation - REAL, INTENT(OUT) :: FSRG !reflected solar radiation by ground + REAL(SUMMA_PREC), INTENT(OUT) :: PARSUN !average absorbed par for sunlit leaves (w/m2) + REAL(SUMMA_PREC), INTENT(OUT) :: PARSHA !average absorbed par for shaded leaves (w/m2) + REAL(SUMMA_PREC), INTENT(OUT) :: SAV !solar radiation absorbed by vegetation (w/m2) + REAL(SUMMA_PREC), INTENT(OUT) :: SAG !solar radiation absorbed by ground (w/m2) + REAL(SUMMA_PREC), INTENT(OUT) :: FSA !total absorbed solar radiation (w/m2) + REAL(SUMMA_PREC), INTENT(OUT) :: FSR !total reflected solar radiation (w/m2) + REAL(SUMMA_PREC), INTENT(OUT) :: FSRV !reflected solar radiation by vegetation + REAL(SUMMA_PREC), INTENT(OUT) :: FSRG !reflected solar radiation by ground ! ------------------------ local variables ---------------------------------------------------- INTEGER :: IB !waveband number (1=vis, 2=nir) INTEGER :: NBAND !number of solar radiation waveband classes - REAL :: ABS !absorbed solar radiation (w/m2) - REAL :: RNIR !reflected solar radiation [nir] (w/m2) - REAL :: RVIS !reflected solar radiation [vis] (w/m2) - REAL :: LAIFRA !leaf area fraction of canopy - REAL :: TRD !transmitted solar radiation: direct (w/m2) - REAL :: TRI !transmitted solar radiation: diffuse (w/m2) - REAL, DIMENSION(1:2) :: CAD !direct beam absorbed by canopy (w/m2) - REAL, DIMENSION(1:2) :: CAI !diffuse radiation absorbed by canopy (w/m2) + REAL(SUMMA_PREC) :: ABS !absorbed solar radiation (w/m2) + REAL(SUMMA_PREC) :: RNIR !reflected solar radiation [nir] (w/m2) + REAL(SUMMA_PREC) :: RVIS !reflected solar radiation [vis] (w/m2) + REAL(SUMMA_PREC) :: LAIFRA !leaf area fraction of canopy + REAL(SUMMA_PREC) :: TRD !transmitted solar radiation: direct (w/m2) + REAL(SUMMA_PREC) :: TRI !transmitted solar radiation: diffuse (w/m2) + REAL(SUMMA_PREC), DIMENSION(1:2) :: CAD !direct beam absorbed by canopy (w/m2) + REAL(SUMMA_PREC), DIMENSION(1:2) :: CAI !diffuse radiation absorbed by canopy (w/m2) ! --------------------------------------------------------------------------------------------- NBAND = 2 @@ -1041,26 +1044,26 @@ SUBROUTINE SNOW_AGE (DT,TG,SNEQVO,SNEQV,TAUSS,FAGE) ! from BATS ! ------------------------ input/output variables -------------------------------------------------- !input - REAL, INTENT(IN) :: DT !main time step (s) - REAL, INTENT(IN) :: TG !ground temperature (k) - REAL, INTENT(IN) :: SNEQVO !snow mass at last time step(mm) - REAL, INTENT(IN) :: SNEQV !snow water per unit ground area (mm) + REAL(SUMMA_PREC), INTENT(IN) :: DT !main time step (s) + REAL(SUMMA_PREC), INTENT(IN) :: TG !ground temperature (k) + REAL(SUMMA_PREC), INTENT(IN) :: SNEQVO !snow mass at last time step(mm) + REAL(SUMMA_PREC), INTENT(IN) :: SNEQV !snow water per unit ground area (mm) !output - REAL, INTENT(OUT) :: FAGE !snow age + REAL(SUMMA_PREC), INTENT(OUT) :: FAGE !snow age !input/output - REAL, INTENT(INOUT) :: TAUSS !non-dimensional snow age + REAL(SUMMA_PREC), INTENT(INOUT) :: TAUSS !non-dimensional snow age !local - REAL :: TAGE !total aging effects - REAL :: AGE1 !effects of grain growth due to vapor diffusion - REAL :: AGE2 !effects of grain growth at freezing of melt water - REAL :: AGE3 !effects of soot - REAL :: DELA !temporary variable - REAL :: SGE !temporary variable - REAL :: DELS !temporary variable - REAL :: DELA0 !temporary variable - REAL :: ARG !temporary variable + REAL(SUMMA_PREC) :: TAGE !total aging effects + REAL(SUMMA_PREC) :: AGE1 !effects of grain growth due to vapor diffusion + REAL(SUMMA_PREC) :: AGE2 !effects of grain growth at freezing of melt water + REAL(SUMMA_PREC) :: AGE3 !effects of soot + REAL(SUMMA_PREC) :: DELA !temporary variable + REAL(SUMMA_PREC) :: SGE !temporary variable + REAL(SUMMA_PREC) :: DELS !temporary variable + REAL(SUMMA_PREC) :: DELA0 !temporary variable + REAL(SUMMA_PREC) :: ARG !temporary variable ! See Yang et al. (1997) J.of Climate for detail. !--------------------------------------------------------------------------------------------------- @@ -1095,28 +1098,28 @@ SUBROUTINE SNOWALB_BATS (NBAND,FSNO,COSZ,FAGE,ALBSND,ALBSNI) INTEGER,INTENT(IN) :: NBAND !number of waveband classes - REAL,INTENT(IN) :: COSZ !cosine solar zenith angle - REAL,INTENT(IN) :: FSNO !snow cover fraction (-) - REAL,INTENT(IN) :: FAGE !snow age correction + REAL(SUMMA_PREC),INTENT(IN) :: COSZ !cosine solar zenith angle + REAL(SUMMA_PREC),INTENT(IN) :: FSNO !snow cover fraction (-) + REAL(SUMMA_PREC),INTENT(IN) :: FAGE !snow age correction ! output - REAL, DIMENSION(1:2),INTENT(OUT) :: ALBSND !snow albedo for direct(1=vis, 2=nir) - REAL, DIMENSION(1:2),INTENT(OUT) :: ALBSNI !snow albedo for diffuse + REAL(SUMMA_PREC), DIMENSION(1:2),INTENT(OUT) :: ALBSND !snow albedo for direct(1=vis, 2=nir) + REAL(SUMMA_PREC), DIMENSION(1:2),INTENT(OUT) :: ALBSNI !snow albedo for diffuse ! --------------------------------------------------------------------------------------------- ! ------------------------ local variables ---------------------------------------------------- INTEGER :: IB !waveband class - REAL :: FZEN !zenith angle correction - REAL :: CF1 !temperary variable - REAL :: SL2 !2.*SL - REAL :: SL1 !1/SL - REAL :: SL !adjustable parameter - REAL, PARAMETER :: C1 = 0.2 !default in BATS - REAL, PARAMETER :: C2 = 0.5 !default in BATS -! REAL, PARAMETER :: C1 = 0.2 * 2. ! double the default to match Sleepers River's -! REAL, PARAMETER :: C2 = 0.5 * 2. ! snow surface albedo (double aging effects) + REAL(SUMMA_PREC) :: FZEN !zenith angle correction + REAL(SUMMA_PREC) :: CF1 !temperary variable + REAL(SUMMA_PREC) :: SL2 !2.*SL + REAL(SUMMA_PREC) :: SL1 !1/SL + REAL(SUMMA_PREC) :: SL !adjustable parameter + REAL(SUMMA_PREC), PARAMETER :: C1 = 0.2 !default in BATS + REAL(SUMMA_PREC), PARAMETER :: C2 = 0.5 !default in BATS +! REAL(SUMMA_PREC), PARAMETER :: C1 = 0.2 * 2. ! double the default to match Sleepers River's +! REAL(SUMMA_PREC), PARAMETER :: C2 = 0.5 * 2. ! snow surface albedo (double aging effects) ! --------------------------------------------------------------------------------------------- ! zero albedos for all points @@ -1150,17 +1153,17 @@ SUBROUTINE SNOWALB_CLASS (NBAND,QSNOW,DT,ALB,ALBOLD,ALBSND,ALBSNI,ILOC,JLOC) INTEGER,INTENT(IN) :: JLOC !grid index INTEGER,INTENT(IN) :: NBAND !number of waveband classes - REAL,INTENT(IN) :: QSNOW !snowfall (mm/s) - REAL,INTENT(IN) :: DT !time step (sec) - REAL,INTENT(IN) :: ALBOLD !snow albedo at last time step + REAL(SUMMA_PREC),INTENT(IN) :: QSNOW !snowfall (mm/s) + REAL(SUMMA_PREC),INTENT(IN) :: DT !time step (sec) + REAL(SUMMA_PREC),INTENT(IN) :: ALBOLD !snow albedo at last time step ! in & out - REAL, INTENT(INOUT) :: ALB ! + REAL(SUMMA_PREC), INTENT(INOUT) :: ALB ! ! output - REAL, DIMENSION(1:2),INTENT(OUT) :: ALBSND !snow albedo for direct(1=vis, 2=nir) - REAL, DIMENSION(1:2),INTENT(OUT) :: ALBSNI !snow albedo for diffuse + REAL(SUMMA_PREC), DIMENSION(1:2),INTENT(OUT) :: ALBSND !snow albedo for direct(1=vis, 2=nir) + REAL(SUMMA_PREC), DIMENSION(1:2),INTENT(OUT) :: ALBSNI !snow albedo for diffuse ! --------------------------------------------------------------------------------------------- ! ------------------------ local variables ---------------------------------------------------- @@ -1210,24 +1213,24 @@ SUBROUTINE GROUNDALB (NSOIL ,NBAND ,ICE ,IST ,ISC , & !in INTEGER, INTENT(IN) :: ICE !value of ist for land ice INTEGER, INTENT(IN) :: IST !surface type INTEGER, INTENT(IN) :: ISC !soil color class (1-lighest; 8-darkest) - REAL, INTENT(IN) :: FSNO !fraction of surface covered with snow (-) - REAL, INTENT(IN) :: TG !ground temperature (k) - REAL, INTENT(IN) :: COSZ !cosine solar zenith angle (0-1) - REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SMC !volumetric soil water content (m3/m3) - REAL, DIMENSION(1: 2), INTENT(IN) :: ALBSND !direct beam snow albedo (vis, nir) - REAL, DIMENSION(1: 2), INTENT(IN) :: ALBSNI !diffuse snow albedo (vis, nir) + REAL(SUMMA_PREC), INTENT(IN) :: FSNO !fraction of surface covered with snow (-) + REAL(SUMMA_PREC), INTENT(IN) :: TG !ground temperature (k) + REAL(SUMMA_PREC), INTENT(IN) :: COSZ !cosine solar zenith angle (0-1) + REAL(SUMMA_PREC), DIMENSION(1:NSOIL), INTENT(IN) :: SMC !volumetric soil water content (m3/m3) + REAL(SUMMA_PREC), DIMENSION(1: 2), INTENT(IN) :: ALBSND !direct beam snow albedo (vis, nir) + REAL(SUMMA_PREC), DIMENSION(1: 2), INTENT(IN) :: ALBSNI !diffuse snow albedo (vis, nir) !output - REAL, DIMENSION(1: 2), INTENT(OUT) :: ALBGRD !ground albedo (direct beam: vis, nir) - REAL, DIMENSION(1: 2), INTENT(OUT) :: ALBGRI !ground albedo (diffuse: vis, nir) + REAL(SUMMA_PREC), DIMENSION(1: 2), INTENT(OUT) :: ALBGRD !ground albedo (direct beam: vis, nir) + REAL(SUMMA_PREC), DIMENSION(1: 2), INTENT(OUT) :: ALBGRI !ground albedo (diffuse: vis, nir) !local INTEGER :: IB !waveband number (1=vis, 2=nir) - REAL :: INC !soil water correction factor for soil albedo - REAL :: ALBSOD !soil albedo (direct) - REAL :: ALBSOI !soil albedo (diffuse) + REAL(SUMMA_PREC) :: INC !soil water correction factor for soil albedo + REAL(SUMMA_PREC) :: ALBSOD !soil albedo (direct) + REAL(SUMMA_PREC) :: ALBSOI !soil albedo (diffuse) ! -------------------------------------------------------------------------------------------------- DO IB = 1, NBAND @@ -1284,68 +1287,68 @@ SUBROUTINE TWOSTREAM (IB ,IC ,VEGTYP ,COSZ ,VAI , & !in INTEGER, INTENT(IN) :: IC !0=unit incoming direct; 1=unit incoming diffuse INTEGER, INTENT(IN) :: VEGTYP !vegetation type - REAL, INTENT(IN) :: COSZ !cosine of direct zenith angle (0-1) - REAL, INTENT(IN) :: VAI !one-sided leaf+stem area index (m2/m2) - REAL, INTENT(IN) :: FWET !fraction of lai, sai that is wetted (-) - REAL, INTENT(IN) :: T !surface temperature (k) + REAL(SUMMA_PREC), INTENT(IN) :: COSZ !cosine of direct zenith angle (0-1) + REAL(SUMMA_PREC), INTENT(IN) :: VAI !one-sided leaf+stem area index (m2/m2) + REAL(SUMMA_PREC), INTENT(IN) :: FWET !fraction of lai, sai that is wetted (-) + REAL(SUMMA_PREC), INTENT(IN) :: T !surface temperature (k) - REAL, DIMENSION(1:2), INTENT(IN) :: ALBGRD !direct albedo of underlying surface (-) - REAL, DIMENSION(1:2), INTENT(IN) :: ALBGRI !diffuse albedo of underlying surface (-) - REAL, DIMENSION(1:2), INTENT(IN) :: RHO !leaf+stem reflectance - REAL, DIMENSION(1:2), INTENT(IN) :: TAU !leaf+stem transmittance - REAL, INTENT(IN) :: FVEG !green vegetation fraction [0.0-1.0] + REAL(SUMMA_PREC), DIMENSION(1:2), INTENT(IN) :: ALBGRD !direct albedo of underlying surface (-) + REAL(SUMMA_PREC), DIMENSION(1:2), INTENT(IN) :: ALBGRI !diffuse albedo of underlying surface (-) + REAL(SUMMA_PREC), DIMENSION(1:2), INTENT(IN) :: RHO !leaf+stem reflectance + REAL(SUMMA_PREC), DIMENSION(1:2), INTENT(IN) :: TAU !leaf+stem transmittance + REAL(SUMMA_PREC), INTENT(IN) :: FVEG !green vegetation fraction [0.0-1.0] ! output - REAL, DIMENSION(1:2), INTENT(OUT) :: FAB !flux abs by veg layer (per unit incoming flux) - REAL, DIMENSION(1:2), INTENT(OUT) :: FRE !flux refl above veg layer (per unit incoming flux) - REAL, DIMENSION(1:2), INTENT(OUT) :: FTD !down dir flux below veg layer (per unit in flux) - REAL, DIMENSION(1:2), INTENT(OUT) :: FTI !down dif flux below veg layer (per unit in flux) - REAL, INTENT(OUT) :: GDIR !projected leaf+stem area in solar direction - REAL, DIMENSION(1:2), INTENT(OUT) :: FREV !flux reflected by veg layer (per unit incoming flux) - REAL, DIMENSION(1:2), INTENT(OUT) :: FREG !flux reflected by ground (per unit incoming flux) + REAL(SUMMA_PREC), DIMENSION(1:2), INTENT(OUT) :: FAB !flux abs by veg layer (per unit incoming flux) + REAL(SUMMA_PREC), DIMENSION(1:2), INTENT(OUT) :: FRE !flux refl above veg layer (per unit incoming flux) + REAL(SUMMA_PREC), DIMENSION(1:2), INTENT(OUT) :: FTD !down dir flux below veg layer (per unit in flux) + REAL(SUMMA_PREC), DIMENSION(1:2), INTENT(OUT) :: FTI !down dif flux below veg layer (per unit in flux) + REAL(SUMMA_PREC), INTENT(OUT) :: GDIR !projected leaf+stem area in solar direction + REAL(SUMMA_PREC), DIMENSION(1:2), INTENT(OUT) :: FREV !flux reflected by veg layer (per unit incoming flux) + REAL(SUMMA_PREC), DIMENSION(1:2), INTENT(OUT) :: FREG !flux reflected by ground (per unit incoming flux) ! local - REAL :: OMEGA !fraction of intercepted radiation that is scattered - REAL :: OMEGAL !omega for leaves - REAL :: BETAI !upscatter parameter for diffuse radiation - REAL :: BETAIL !betai for leaves - REAL :: BETAD !upscatter parameter for direct beam radiation - REAL :: BETADL !betad for leaves - REAL :: EXT !optical depth of direct beam per unit leaf area - REAL :: AVMU !average diffuse optical depth - - REAL :: COSZI !0.001 <= cosz <= 1.000 - REAL :: ASU !single scattering albedo - REAL :: CHIL ! -0.4 <= xl <= 0.6 - - REAL :: TMP0,TMP1,TMP2,TMP3,TMP4,TMP5,TMP6,TMP7,TMP8,TMP9 - REAL :: P1,P2,P3,P4,S1,S2,U1,U2,U3 - REAL :: B,C,D,D1,D2,F,H,H1,H2,H3,H4,H5,H6,H7,H8,H9,H10 - REAL :: PHI1,PHI2,SIGMA - REAL :: FTDS,FTIS,FRES - REAL :: DENFVEG - REAL :: VAI_SPREAD + REAL(SUMMA_PREC) :: OMEGA !fraction of intercepted radiation that is scattered + REAL(SUMMA_PREC) :: OMEGAL !omega for leaves + REAL(SUMMA_PREC) :: BETAI !upscatter parameter for diffuse radiation + REAL(SUMMA_PREC) :: BETAIL !betai for leaves + REAL(SUMMA_PREC) :: BETAD !upscatter parameter for direct beam radiation + REAL(SUMMA_PREC) :: BETADL !betad for leaves + REAL(SUMMA_PREC) :: EXT !optical depth of direct beam per unit leaf area + REAL(SUMMA_PREC) :: AVMU !average diffuse optical depth + + REAL(SUMMA_PREC) :: COSZI !0.001 <= cosz <= 1.000 + REAL(SUMMA_PREC) :: ASU !single scattering albedo + REAL(SUMMA_PREC) :: CHIL ! -0.4 <= xl <= 0.6 + + REAL(SUMMA_PREC) :: TMP0,TMP1,TMP2,TMP3,TMP4,TMP5,TMP6,TMP7,TMP8,TMP9 + REAL(SUMMA_PREC) :: P1,P2,P3,P4,S1,S2,U1,U2,U3 + REAL(SUMMA_PREC) :: B,C,D,D1,D2,F,H,H1,H2,H3,H4,H5,H6,H7,H8,H9,H10 + REAL(SUMMA_PREC) :: PHI1,PHI2,SIGMA + REAL(SUMMA_PREC) :: FTDS,FTIS,FRES + REAL(SUMMA_PREC) :: DENFVEG + REAL(SUMMA_PREC) :: VAI_SPREAD !jref:start - REAL :: FREVEG,FREBAR,FTDVEG,FTIVEG,FTDBAR,FTIBAR - REAL :: THETAZ + REAL(SUMMA_PREC) :: FREVEG,FREBAR,FTDVEG,FTIVEG,FTDBAR,FTIBAR + REAL(SUMMA_PREC) :: THETAZ !jref:end ! variables for the modified two-stream scheme ! Niu and Yang (2004), JGR - REAL, PARAMETER :: PAI = 3.14159265 - REAL :: HD !crown depth (m) - REAL :: BB !vertical crown radius (m) - REAL :: THETAP !angle conversion from SZA - REAL :: FA !foliage volume density (m-1) - REAL :: NEWVAI !effective LSAI (-) + REAL(SUMMA_PREC), PARAMETER :: PAI = 3.14159265 + REAL(SUMMA_PREC) :: HD !crown depth (m) + REAL(SUMMA_PREC) :: BB !vertical crown radius (m) + REAL(SUMMA_PREC) :: THETAP !angle conversion from SZA + REAL(SUMMA_PREC) :: FA !foliage volume density (m-1) + REAL(SUMMA_PREC) :: NEWVAI !effective LSAI (-) - REAL,INTENT(INOUT) :: BGAP !between canopy gap fraction for beam (-) - REAL,INTENT(INOUT) :: WGAP !within canopy gap fraction for beam (-) + REAL(SUMMA_PREC),INTENT(INOUT) :: BGAP !between canopy gap fraction for beam (-) + REAL(SUMMA_PREC),INTENT(INOUT) :: WGAP !within canopy gap fraction for beam (-) - REAL :: KOPEN !gap fraction for diffue light (-) - REAL :: GAP !total gap fraction for beam ( <=1-shafac ) + REAL(SUMMA_PREC) :: KOPEN !gap fraction for diffue light (-) + REAL(SUMMA_PREC) :: GAP !total gap fraction for beam ( <=1-shafac ) ! ----------------------------------------------------------------- ! compute within and between gaps @@ -1429,7 +1432,7 @@ SUBROUTINE TWOSTREAM (IB ,IC ,VEGTYP ,COSZ ,VAI , & !in TMP1 = B*B - C*C H = SQRT(TMP1) / AVMU SIGMA = TMP0*TMP0 - TMP1 - if ( ABS (SIGMA) < 1.e-6 ) SIGMA = SIGN(1.e-6,SIGMA) + if ( ABS (SIGMA) < 1.e-6 ) SIGMA = SIGN(1.e-6,REAL(SIGMA)) P1 = B + AVMU*H P2 = B - AVMU*H P3 = B + TMP0 @@ -1524,27 +1527,27 @@ SUBROUTINE STOMATA (VEGTYP ,MPE ,APAR ,FOLN ,ILOC , JLOC, & !in INTEGER,INTENT(IN) :: JLOC !grid index INTEGER,INTENT(IN) :: VEGTYP !vegetation physiology type - REAL, INTENT(IN) :: IGS !growing season index (0=off, 1=on) - REAL, INTENT(IN) :: MPE !prevents division by zero errors - - REAL, INTENT(IN) :: TV !foliage temperature (k) - REAL, INTENT(IN) :: EI !vapor pressure inside leaf (sat vapor press at tv) (pa) - REAL, INTENT(IN) :: EA !vapor pressure of canopy air (pa) - REAL, INTENT(IN) :: APAR !par absorbed per unit lai (w/m2) - REAL, INTENT(IN) :: O2 !atmospheric o2 concentration (pa) - REAL, INTENT(IN) :: CO2 !atmospheric co2 concentration (pa) - REAL, INTENT(IN) :: SFCPRS !air pressure at reference height (pa) - REAL, INTENT(IN) :: SFCTMP !air temperature at reference height (k) - REAL, INTENT(IN) :: BTRAN !soil water transpiration factor (0 to 1) - REAL, INTENT(IN) :: FOLN !foliage nitrogen concentration (%) - REAL, INTENT(IN) :: RB !boundary layer resistance (s/m) + REAL(SUMMA_PREC), INTENT(IN) :: IGS !growing season index (0=off, 1=on) + REAL(SUMMA_PREC), INTENT(IN) :: MPE !prevents division by zero errors + + REAL(SUMMA_PREC), INTENT(IN) :: TV !foliage temperature (k) + REAL(SUMMA_PREC), INTENT(IN) :: EI !vapor pressure inside leaf (sat vapor press at tv) (pa) + REAL(SUMMA_PREC), INTENT(IN) :: EA !vapor pressure of canopy air (pa) + REAL(SUMMA_PREC), INTENT(IN) :: APAR !par absorbed per unit lai (w/m2) + REAL(SUMMA_PREC), INTENT(IN) :: O2 !atmospheric o2 concentration (pa) + REAL(SUMMA_PREC), INTENT(IN) :: CO2 !atmospheric co2 concentration (pa) + REAL(SUMMA_PREC), INTENT(IN) :: SFCPRS !air pressure at reference height (pa) + REAL(SUMMA_PREC), INTENT(IN) :: SFCTMP !air temperature at reference height (k) + REAL(SUMMA_PREC), INTENT(IN) :: BTRAN !soil water transpiration factor (0 to 1) + REAL(SUMMA_PREC), INTENT(IN) :: FOLN !foliage nitrogen concentration (%) + REAL(SUMMA_PREC), INTENT(IN) :: RB !boundary layer resistance (s/m) ! output - REAL, INTENT(OUT) :: RS !leaf stomatal resistance (s/m) - REAL, INTENT(OUT) :: PSN !foliage photosynthesis (umol co2 /m2/ s) [always +] + REAL(SUMMA_PREC), INTENT(OUT) :: RS !leaf stomatal resistance (s/m) + REAL(SUMMA_PREC), INTENT(OUT) :: PSN !foliage photosynthesis (umol co2 /m2/ s) [always +] ! in&out - REAL :: RLB !boundary layer resistance (s m2 / umol) + REAL(SUMMA_PREC) :: RLB !boundary layer resistance (s m2 / umol) ! --------------------------------------------------------------------------------------------- ! ------------------------ local variables ---------------------------------------------------- @@ -1554,32 +1557,32 @@ SUBROUTINE STOMATA (VEGTYP ,MPE ,APAR ,FOLN ,ILOC , JLOC, & !in DATA NITER /3/ SAVE NITER - REAL :: AB !used in statement functions - REAL :: BC !used in statement functions - REAL :: F1 !generic temperature response (statement function) - REAL :: F2 !generic temperature inhibition (statement function) - REAL :: TC !foliage temperature (degree Celsius) - REAL :: CS !co2 concentration at leaf surface (pa) - REAL :: KC !co2 Michaelis-Menten constant (pa) - REAL :: KO !o2 Michaelis-Menten constant (pa) - REAL :: A,B,C,Q !intermediate calculations for RS - REAL :: R1,R2 !roots for RS - REAL :: FNF !foliage nitrogen adjustment factor (0 to 1) - REAL :: PPF !absorb photosynthetic photon flux (umol photons/m2/s) - REAL :: WC !Rubisco limited photosynthesis (umol co2/m2/s) - REAL :: WJ !light limited photosynthesis (umol co2/m2/s) - REAL :: WE !export limited photosynthesis (umol co2/m2/s) - REAL :: CP !co2 compensation point (pa) - REAL :: CI !internal co2 (pa) - REAL :: AWC !intermediate calculation for wc - REAL :: VCMX !maximum rate of carbonylation (umol co2/m2/s) - REAL :: J !electron transport (umol co2/m2/s) - REAL :: CEA !constrain ea or else model blows up - REAL :: CF !s m2/umol -> s/m + REAL(SUMMA_PREC) :: AB !used in statement functions + REAL(SUMMA_PREC) :: BC !used in statement functions + REAL(SUMMA_PREC) :: F1 !generic temperature response (statement function) + REAL(SUMMA_PREC) :: F2 !generic temperature inhibition (statement function) + REAL(SUMMA_PREC) :: TC !foliage temperature (degree Celsius) + REAL(SUMMA_PREC) :: CS !co2 concentration at leaf surface (pa) + REAL(SUMMA_PREC) :: KC !co2 Michaelis-Menten constant (pa) + REAL(SUMMA_PREC) :: KO !o2 Michaelis-Menten constant (pa) + REAL(SUMMA_PREC) :: A,B,C,Q !intermediate calculations for RS + REAL(SUMMA_PREC) :: R1,R2 !roots for RS + REAL(SUMMA_PREC) :: FNF !foliage nitrogen adjustment factor (0 to 1) + REAL(SUMMA_PREC) :: PPF !absorb photosynthetic photon flux (umol photons/m2/s) + REAL(SUMMA_PREC) :: WC !Rubisco limited photosynthesis (umol co2/m2/s) + REAL(SUMMA_PREC) :: WJ !light limited photosynthesis (umol co2/m2/s) + REAL(SUMMA_PREC) :: WE !export limited photosynthesis (umol co2/m2/s) + REAL(SUMMA_PREC) :: CP !co2 compensation point (pa) + REAL(SUMMA_PREC) :: CI !internal co2 (pa) + REAL(SUMMA_PREC) :: AWC !intermediate calculation for wc + REAL(SUMMA_PREC) :: VCMX !maximum rate of carbonylation (umol co2/m2/s) + REAL(SUMMA_PREC) :: J !electron transport (umol co2/m2/s) + REAL(SUMMA_PREC) :: CEA !constrain ea or else model blows up + REAL(SUMMA_PREC) :: CF !s m2/umol -> s/m F1(AB,BC) = AB**((BC-25.)/10.) F2(AB) = 1. + EXP((-2.2E05+710.*(AB+273.16))/(8.314*(AB+273.16))) - REAL :: T + REAL(SUMMA_PREC) :: T ! --------------------------------------------------------------------------------------------- ! MPC change @@ -1686,26 +1689,26 @@ SUBROUTINE CANRES (PAR ,SFCTMP,RCSOIL ,EAH ,SFCPRS , & !in INTEGER, INTENT(IN) :: ILOC !grid index INTEGER, INTENT(IN) :: JLOC !grid index - REAL, INTENT(IN) :: PAR !par absorbed per unit sunlit lai (w/m2) - REAL, INTENT(IN) :: SFCTMP !canopy air temperature - REAL, INTENT(IN) :: SFCPRS !surface pressure (pa) - REAL, INTENT(IN) :: EAH !water vapor pressure (pa) - REAL, INTENT(IN) :: RCSOIL !soil moisture stress factor + REAL(SUMMA_PREC), INTENT(IN) :: PAR !par absorbed per unit sunlit lai (w/m2) + REAL(SUMMA_PREC), INTENT(IN) :: SFCTMP !canopy air temperature + REAL(SUMMA_PREC), INTENT(IN) :: SFCPRS !surface pressure (pa) + REAL(SUMMA_PREC), INTENT(IN) :: EAH !water vapor pressure (pa) + REAL(SUMMA_PREC), INTENT(IN) :: RCSOIL !soil moisture stress factor !outputs - REAL, INTENT(OUT) :: RC !canopy resistance per unit LAI - REAL, INTENT(OUT) :: PSN !foliage photosynthesis (umolco2/m2/s) + REAL(SUMMA_PREC), INTENT(OUT) :: RC !canopy resistance per unit LAI + REAL(SUMMA_PREC), INTENT(OUT) :: PSN !foliage photosynthesis (umolco2/m2/s) !local - REAL :: RCQ - REAL :: RCS - REAL :: RCT - REAL :: FF - REAL :: Q2 !water vapor mixing ratio (kg/kg) - REAL :: Q2SAT !saturation Q2 - REAL :: DQSDT2 !d(Q2SAT)/d(T) + REAL(SUMMA_PREC) :: RCQ + REAL(SUMMA_PREC) :: RCS + REAL(SUMMA_PREC) :: RCT + REAL(SUMMA_PREC) :: FF + REAL(SUMMA_PREC) :: Q2 !water vapor mixing ratio (kg/kg) + REAL(SUMMA_PREC) :: Q2SAT !saturation Q2 + REAL(SUMMA_PREC) :: DQSDT2 !d(Q2SAT)/d(T) ! RSMIN, RSMAX, TOPT, RGL, HS are canopy stress parameters set in REDPRM ! ---------------------------------------------------------------------- @@ -1748,12 +1751,12 @@ END SUBROUTINE CANRES ! ================================================================================================== SUBROUTINE CALHUM(SFCTMP, SFCPRS, Q2SAT, DQSDT2) IMPLICIT NONE - REAL, INTENT(IN) :: SFCTMP, SFCPRS - REAL, INTENT(OUT) :: Q2SAT, DQSDT2 - REAL, PARAMETER :: A2=17.67,A3=273.15,A4=29.65, ELWV=2.501E6, & + REAL(SUMMA_PREC), INTENT(IN) :: SFCTMP, SFCPRS + REAL(SUMMA_PREC), INTENT(OUT) :: Q2SAT, DQSDT2 + REAL(SUMMA_PREC), PARAMETER :: A2=17.67,A3=273.15,A4=29.65, ELWV=2.501E6, & A23M4=A2*(A3-A4), E0=0.611, RV=461.0, & EPSILON=0.622 - REAL :: ES, SFCPRSX + REAL(SUMMA_PREC) :: ES, SFCPRSX ! Q2SAT: saturated mixing ratio ES = E0 * EXP ( ELWV/RV*(1./A3 - 1./SFCTMP) ) ! convert SFCPRS from Pa to KPa @@ -1823,13 +1826,13 @@ SUBROUTINE REDPRM (VEGTYP,SOILTYP,SLOPETYP,ZSOIL,NSOIL,ISURBAN) ! General parameters INTEGER, INTENT(IN) :: NSOIL ! Layer parameters - REAL,DIMENSION(NSOIL),INTENT(IN) :: ZSOIL + REAL(SUMMA_PREC),DIMENSION(NSOIL),INTENT(IN) :: ZSOIL ! Locals - REAL :: REFDK - REAL :: REFKDT - REAL :: FRZK - REAL :: FRZFACT + REAL(SUMMA_PREC) :: REFDK + REAL(SUMMA_PREC) :: REFKDT + REAL(SUMMA_PREC) :: FRZK + REAL(SUMMA_PREC) :: FRZFACT INTEGER :: I CHARACTER(len=256) :: message ! ---------------------------------------------------------------------- @@ -1962,6 +1965,7 @@ END MODULE NOAHMP_ROUTINES ! ================================================================================================== MODULE MODULE_SF_NOAHMPLSM + use nrtype USE NOAHMP_ROUTINES USE NOAHMP_GLOBALS diff --git a/build/source/noah-mp/module_sf_noahutl.F b/build/source/noah-mp/module_sf_noahutl.F index 007961bd3..562db4578 100755 --- a/build/source/noah-mp/module_sf_noahutl.F +++ b/build/source/noah-mp/module_sf_noahutl.F @@ -1,6 +1,7 @@ MODULE module_sf_noahutl + USE nrtype - REAL, PARAMETER :: CP = 1004.5, RD = 287.04, SIGMA = 5.67E-8, & + REAL(SUMMA_PREC), PARAMETER :: CP = 1004.5, RD = 287.04, SIGMA = 5.67E-8, & CPH2O = 4.218E+3,CPICE = 2.106E+3, & LSUBF = 3.335E+5 @@ -11,20 +12,20 @@ SUBROUTINE CALTMP(T1, SFCTMP, SFCPRS, ZLVL, Q2, TH2, T1V, TH2V, RHO ) IMPLICIT NONE ! Input: - REAL, INTENT(IN) :: T1 ! Skin temperature (K) - REAL, INTENT(IN) :: SFCTMP ! Air temperature (K) at level ZLVL - REAL, INTENT(IN) :: Q2 ! Specific Humidity (kg/kg) at level ZLVL - REAL, INTENT(IN) :: SFCPRS ! Atmospheric pressure (Pa) at level ZLVL - REAL, INTENT(IN) :: ZLVL ! Height (m AGL) where atmospheric fields are valid + REAL(SUMMA_PREC), INTENT(IN) :: T1 ! Skin temperature (K) + REAL(SUMMA_PREC), INTENT(IN) :: SFCTMP ! Air temperature (K) at level ZLVL + REAL(SUMMA_PREC), INTENT(IN) :: Q2 ! Specific Humidity (kg/kg) at level ZLVL + REAL(SUMMA_PREC), INTENT(IN) :: SFCPRS ! Atmospheric pressure (Pa) at level ZLVL + REAL(SUMMA_PREC), INTENT(IN) :: ZLVL ! Height (m AGL) where atmospheric fields are valid ! Output: - REAL, INTENT(OUT) :: TH2 ! Potential temperature (considering the reference pressure to be at the surface) - REAL, INTENT(OUT) :: T1V ! Virtual skin temperature (K) - REAL, INTENT(OUT) :: TH2V ! Virtual potential temperature at ZLVL - REAL, INTENT(OUT) :: RHO ! Density + REAL(SUMMA_PREC), INTENT(OUT) :: TH2 ! Potential temperature (considering the reference pressure to be at the surface) + REAL(SUMMA_PREC), INTENT(OUT) :: T1V ! Virtual skin temperature (K) + REAL(SUMMA_PREC), INTENT(OUT) :: TH2V ! Virtual potential temperature at ZLVL + REAL(SUMMA_PREC), INTENT(OUT) :: RHO ! Density ! Local: - REAL :: T2V + REAL(SUMMA_PREC) :: T2V TH2 = SFCTMP + ( 0.0098 * ZLVL) T1V= T1 * (1.0+ 0.61 * Q2) @@ -39,18 +40,18 @@ SUBROUTINE CALHUM(SFCTMP, SFCPRS, Q2SAT, DQSDT2) IMPLICIT NONE ! Input: - REAL, INTENT(IN) :: SFCTMP - REAL, INTENT(IN) :: SFCPRS + REAL(SUMMA_PREC), INTENT(IN) :: SFCTMP + REAL(SUMMA_PREC), INTENT(IN) :: SFCPRS ! Output: - REAL, INTENT(OUT) :: Q2SAT ! Saturated specific humidity - REAL, INTENT(OUT) :: DQSDT2 + REAL(SUMMA_PREC), INTENT(OUT) :: Q2SAT ! Saturated specific humidity + REAL(SUMMA_PREC), INTENT(OUT) :: DQSDT2 ! Local - REAL, PARAMETER :: A2=17.67,A3=273.15,A4=29.65, ELWV=2.501E6, & + REAL(SUMMA_PREC), PARAMETER :: A2=17.67,A3=273.15,A4=29.65, ELWV=2.501E6, & A23M4=A2*(A3-A4), E0=611.0, RV=461.0, & EPSILON=0.622 - REAL :: ES + REAL(SUMMA_PREC) :: ES ! ES: e.g. Dutton chapter 8, eq 11 ES = E0 * EXP ( ELWV/RV*(1./A3 - 1./SFCTMP) ) From 81d20855d8a9aede0eecd10ee8375365120e4d57 Mon Sep 17 00:00:00 2001 From: arbennett Date: Wed, 12 May 2021 14:16:05 -0700 Subject: [PATCH 17/24] Move summa_prec -> rk --- build/source/driver/summa_globalData.f90 | 2 +- build/source/driver/summa_init.f90 | 6 +- build/source/driver/summa_modelRun.f90 | 14 +- build/source/driver/summa_restart.f90 | 8 +- build/source/driver/summa_setup.f90 | 6 +- build/source/driver/summa_type.f90 | 4 +- build/source/driver/summa_util.f90 | 8 +- build/source/dshare/data_types.f90 | 16 +- build/source/dshare/globalData.f90 | 40 +- build/source/dshare/multiconst.f90 | 58 +- build/source/dshare/outpt_stat.f90 | 18 +- build/source/engine/allocspace.f90 | 20 +- build/source/engine/bigAquifer.f90 | 20 +- build/source/engine/canopySnow.f90 | 58 +- build/source/engine/check_icond.f90 | 36 +- build/source/engine/computFlux.f90 | 70 +- build/source/engine/computJacob.f90 | 38 +- build/source/engine/computResid.f90 | 32 +- build/source/engine/convE2Temp.f90 | 72 +- build/source/engine/conv_funcs.f90 | 138 +- build/source/engine/coupled_em.f90 | 156 +- build/source/engine/derivforce.f90 | 92 +- build/source/engine/diagn_evar.f90 | 74 +- build/source/engine/eval8summa.f90 | 62 +- build/source/engine/expIntegral.f90 | 38 +- build/source/engine/f2008funcs.f90 | 6 +- build/source/engine/ffile_info.f90 | 2 +- build/source/engine/getVectorz.f90 | 86 +- build/source/engine/groundwatr.f90 | 114 +- build/source/engine/layerDivide.f90 | 42 +- build/source/engine/layerMerge.f90 | 42 +- build/source/engine/mDecisions.f90 | 8 +- build/source/engine/matrixOper.f90 | 26 +- build/source/engine/nr_utility.f90 | 8 +- build/source/engine/nrtype.f90 | 12 +- build/source/engine/opSplittin.f90 | 34 +- build/source/engine/pOverwrite.f90 | 2 +- build/source/engine/paramCheck.f90 | 10 +- build/source/engine/qTimeDelay.f90 | 16 +- build/source/engine/read_attrb.f90 | 2 +- build/source/engine/read_force.f90 | 48 +- build/source/engine/read_param.f90 | 2 +- build/source/engine/read_pinit.f90 | 8 +- build/source/engine/run_oneGRU.f90 | 16 +- build/source/engine/run_oneHRU.f90 | 6 +- build/source/engine/snowAlbedo.f90 | 52 +- build/source/engine/snowLiqFlx.f90 | 36 +- build/source/engine/snow_utils.f90 | 38 +- build/source/engine/snwCompact.f90 | 80 +- build/source/engine/soilLiqFlx.f90 | 510 +++---- build/source/engine/soil_utils.f90 | 448 +++--- build/source/engine/spline_int.f90 | 48 +- build/source/engine/ssdNrgFlux.f90 | 34 +- build/source/engine/stomResist.f90 | 370 ++--- build/source/engine/summaSolve.f90 | 276 ++-- build/source/engine/sunGeomtry.f90 | 52 +- build/source/engine/systemSolv.f90 | 58 +- build/source/engine/tempAdjust.f90 | 62 +- build/source/engine/time_utils.f90 | 46 +- build/source/engine/updatState.f90 | 44 +- build/source/engine/updateVars.f90 | 96 +- build/source/engine/varSubstep.f90 | 142 +- build/source/engine/var_derive.f90 | 96 +- build/source/engine/vegLiqFlux.f90 | 30 +- build/source/engine/vegNrgFlux.f90 | 1290 ++++++++--------- build/source/engine/vegPhenlgy.f90 | 14 +- build/source/engine/vegSWavRad.f90 | 344 ++--- build/source/engine/volicePack.f90 | 50 +- build/source/netcdf/modelwrite.f90 | 4 +- build/source/netcdf/read_icond.f90 | 6 +- build/source/noah-mp/module_model_constants.F | 210 +-- build/source/noah-mp/module_sf_noahlsm.F | 16 +- build/source/noah-mp/module_sf_noahmplsm.F | 842 +++++------ build/source/noah-mp/module_sf_noahutl.F | 34 +- 74 files changed, 3452 insertions(+), 3452 deletions(-) diff --git a/build/source/driver/summa_globalData.f90 b/build/source/driver/summa_globalData.f90 index 92a270e09..c9168d0f8 100755 --- a/build/source/driver/summa_globalData.f90 +++ b/build/source/driver/summa_globalData.f90 @@ -107,7 +107,7 @@ subroutine summa_defineGlobalData(err, message) doJacobian=.false. ! initialize the Jacobian flag ! define double precision NaNs (shared in globalData) - dNaN = ieee_value(1._summa_prec, ieee_quiet_nan) + dNaN = ieee_value(1._rk, ieee_quiet_nan) ! populate metadata for all model variables call popMetadat(err,cmessage) diff --git a/build/source/driver/summa_init.f90 b/build/source/driver/summa_init.f90 index b4e55a8f6..7a3305552 100755 --- a/build/source/driver/summa_init.f90 +++ b/build/source/driver/summa_init.f90 @@ -175,9 +175,9 @@ subroutine summa_initialize(summa1_struc, err, message) ncid(:) = integerMissing ! initialize the elapsed time for cumulative quantities - elapsedRead=0._summa_prec - elapsedWrite=0._summa_prec - elapsedPhysics=0._summa_prec + elapsedRead=0._rk + elapsedWrite=0._rk + elapsedPhysics=0._rk ! get the command line arguments call getCommandArguments(summa1_struc,err,cmessage) diff --git a/build/source/driver/summa_modelRun.f90 b/build/source/driver/summa_modelRun.f90 index 228912c86..77984285b 100755 --- a/build/source/driver/summa_modelRun.f90 +++ b/build/source/driver/summa_modelRun.f90 @@ -72,16 +72,16 @@ subroutine summa_runPhysics(modelTimeStep, summa1_struc, err, message) integer(i4b) :: iGRU,jGRU,kGRU ! GRU indices ! local variables: veg phenology logical(lgt) :: computeVegFluxFlag ! flag to indicate if we are computing fluxes over vegetation (.false. means veg is buried with snow) - real(summa_prec) :: notUsed_canopyDepth ! NOT USED: canopy depth (m) - real(summa_prec) :: notUsed_exposedVAI ! NOT USED: exposed vegetation area index (m2 m-2) + real(rk) :: notUsed_canopyDepth ! NOT USED: canopy depth (m) + real(rk) :: notUsed_exposedVAI ! NOT USED: exposed vegetation area index (m2 m-2) ! local variables: parallelize the model run integer(i4b), allocatable :: ixExpense(:) ! ranked index GRU w.r.t. computational expense integer(i4b), allocatable :: totalFluxCalls(:) ! total number of flux calls for each GRU ! local variables: timing information integer*8 :: openMPstart,openMPend ! time for the start of the parallelization section integer*8, allocatable :: timeGRUstart(:) ! time GRUs start - real(summa_prec), allocatable :: timeGRUcompleted(:) ! time required to complete each GRU - real(summa_prec), allocatable :: timeGRU(:) ! time spent on each GRU + real(rk), allocatable :: timeGRUcompleted(:) ! time required to complete each GRU + real(rk), allocatable :: timeGRU(:) ! time spent on each GRU ! --------------------------------------------------------------------------------------- ! associate to elements in the data structure summaVars: associate(& @@ -171,7 +171,7 @@ subroutine summa_runPhysics(modelTimeStep, summa1_struc, err, message) ! compute the total number of flux calls from the previous time step do jGRU=1,nGRU - totalFluxCalls(jGRU) = 0._summa_prec + totalFluxCalls(jGRU) = 0._rk do iHRU=1,gru_struc(jGRU)%hruCount totalFluxCalls(jGRU) = totalFluxCalls(jGRU) + indxStruct%gru(jGRU)%hru(iHRU)%var(iLookINDEX%numberFluxCalc)%dat(1) end do @@ -268,8 +268,8 @@ subroutine summa_runPhysics(modelTimeStep, summa1_struc, err, message) !$omp critical(saveTiming) ! save timing information call system_clock(openMPend) - timeGRU(iGRU) = real(openMPend - timeGRUstart(iGRU), kind(summa_prec)) - timeGRUcompleted(iGRU) = real(openMPend - openMPstart , kind(summa_prec)) + timeGRU(iGRU) = real(openMPend - timeGRUstart(iGRU), kind(rk)) + timeGRUcompleted(iGRU) = real(openMPend - openMPstart , kind(rk)) !$omp end critical(saveTiming) end do ! (looping through GRUs) diff --git a/build/source/driver/summa_restart.f90 b/build/source/driver/summa_restart.f90 index aff80fe7a..d4a73c643 100755 --- a/build/source/driver/summa_restart.f90 +++ b/build/source/driver/summa_restart.f90 @@ -178,7 +178,7 @@ subroutine summa_readRestart(summa1_struc, err, message) ! initialize canopy drip ! NOTE: canopy drip from the previous time step is used to compute throughfall for the current time step - fluxStruct%gru(iGRU)%hru(iHRU)%var(iLookFLUX%scalarCanopyLiqDrainage)%dat(1) = 0._summa_prec ! not used + fluxStruct%gru(iGRU)%hru(iHRU)%var(iLookFLUX%scalarCanopyLiqDrainage)%dat(1) = 0._rk ! not used end do ! end looping through HRUs @@ -201,14 +201,14 @@ subroutine summa_readRestart(summa1_struc, err, message) ! the basin-average aquifer storage is not used if the groundwater is included in the local column case(localColumn) - bvarStruct%gru(iGRU)%var(iLookBVAR%basin__AquiferStorage)%dat(1) = 0._summa_prec ! set to zero to be clear that there is no basin-average aquifer storage in this configuration + bvarStruct%gru(iGRU)%var(iLookBVAR%basin__AquiferStorage)%dat(1) = 0._rk ! set to zero to be clear that there is no basin-average aquifer storage in this configuration ! the local column aquifer storage is not used if the groundwater is basin-average ! (i.e., where multiple HRUs drain to a basin-average aquifer) case(singleBasin) - bvarStruct%gru(iGRU)%var(iLookBVAR%basin__AquiferStorage)%dat(1) = 1._summa_prec + bvarStruct%gru(iGRU)%var(iLookBVAR%basin__AquiferStorage)%dat(1) = 1._rk do iHRU=1,gru_struc(iGRU)%hruCount - progStruct%gru(iGRU)%hru(iHRU)%var(iLookPROG%scalarAquiferStorage)%dat(1) = 0._summa_prec ! set to zero to be clear that there is no local aquifer storage in this configuration + progStruct%gru(iGRU)%hru(iHRU)%var(iLookPROG%scalarAquiferStorage)%dat(1) = 0._rk ! set to zero to be clear that there is no local aquifer storage in this configuration end do ! error check diff --git a/build/source/driver/summa_setup.f90 b/build/source/driver/summa_setup.f90 index 17dc45e45..1b48a59dd 100755 --- a/build/source/driver/summa_setup.f90 +++ b/build/source/driver/summa_setup.f90 @@ -191,7 +191,7 @@ subroutine summa_paramSetup(summa1_struc, err, message) ! ***************************************************************************** ! define monthly fraction of green vegetation - greenVegFrac_monthly = (/0.01_summa_prec, 0.02_summa_prec, 0.03_summa_prec, 0.07_summa_prec, 0.50_summa_prec, 0.90_summa_prec, 0.95_summa_prec, 0.96_summa_prec, 0.65_summa_prec, 0.24_summa_prec, 0.11_summa_prec, 0.02_summa_prec/) + greenVegFrac_monthly = (/0.01_rk, 0.02_rk, 0.03_rk, 0.07_rk, 0.50_rk, 0.90_rk, 0.95_rk, 0.96_rk, 0.65_rk, 0.24_rk, 0.11_rk, 0.02_rk/) ! read Noah soil and vegetation tables call soil_veg_gen_parm(trim(SETTINGS_PATH)//trim(VEGPARM), & ! filename for vegetation table @@ -298,7 +298,7 @@ subroutine summa_paramSetup(summa1_struc, err, message) ! compute total area of the upstream HRUS that flow into each HRU do iHRU=1,gru_struc(iGRU)%hruCount - upArea%gru(iGRU)%hru(iHRU) = 0._summa_prec + upArea%gru(iGRU)%hru(iHRU) = 0._rk do jHRU=1,gru_struc(iGRU)%hruCount ! check if jHRU flows into iHRU; assume no exchange between GRUs if(typeStruct%gru(iGRU)%hru(jHRU)%var(iLookTYPE%downHRUindex)==typeStruct%gru(iGRU)%hru(iHRU)%var(iLookID%hruId))then @@ -309,7 +309,7 @@ subroutine summa_paramSetup(summa1_struc, err, message) ! identify the total basin area for a GRU (m2) associate(totalArea => bvarStruct%gru(iGRU)%var(iLookBVAR%basin__totalArea)%dat(1) ) - totalArea = 0._summa_prec + totalArea = 0._rk do iHRU=1,gru_struc(iGRU)%hruCount totalArea = totalArea + attrStruct%gru(iGRU)%hru(iHRU)%var(iLookATTR%HRUarea) end do diff --git a/build/source/driver/summa_type.f90 b/build/source/driver/summa_type.f90 index ba72116a6..f39ed8443 100755 --- a/build/source/driver/summa_type.f90 +++ b/build/source/driver/summa_type.f90 @@ -91,11 +91,11 @@ MODULE summa_type ! define miscellaneous variables integer(i4b) :: summa1open ! flag to define if the summa file is open?? integer(i4b) :: numout ! number of output variables?? - real(summa_prec) :: ts ! model time step ?? + real(rk) :: ts ! model time step ?? integer(i4b) :: nGRU ! number of grouped response units integer(i4b) :: nHRU ! number of global hydrologic response units integer(i4b) :: hruCount ! number of local hydrologic response units - real(summa_prec),dimension(12) :: greenVegFrac_monthly ! fraction of green vegetation in each month (0-1) + real(rk),dimension(12) :: greenVegFrac_monthly ! fraction of green vegetation in each month (0-1) character(len=256) :: summaFileManagerFile ! path/name of file defining directories and files end type summa1_type_dec diff --git a/build/source/driver/summa_util.f90 b/build/source/driver/summa_util.f90 index 7d281f52a..3bee86a07 100755 --- a/build/source/driver/summa_util.f90 +++ b/build/source/driver/summa_util.f90 @@ -350,7 +350,7 @@ subroutine stop_program(err,message) integer(i4b) :: endModelRun(8) ! final time integer(i4b) :: localErr ! local error code integer(i4b) :: iFreq ! loop through output frequencies - real(summa_prec) :: elpSec ! elapsed seconds + real(rk) :: elpSec ! elapsed seconds ! close any remaining output files ! NOTE: use the direct NetCDF call with no error checking since the file may already be closed @@ -392,9 +392,9 @@ subroutine stop_program(err,message) ! print total elapsed time write(outunit,"(/,A,1PG15.7,A)") ' elapsed time = ', elpSec, ' s' - write(outunit,"(A,1PG15.7,A)") ' or ', elpSec/60_summa_prec, ' m' - write(outunit,"(A,1PG15.7,A)") ' or ', elpSec/3600_summa_prec, ' h' - write(outunit,"(A,1PG15.7,A/)") ' or ', elpSec/86400_summa_prec, ' d' + write(outunit,"(A,1PG15.7,A)") ' or ', elpSec/60_rk, ' m' + write(outunit,"(A,1PG15.7,A)") ' or ', elpSec/3600_rk, ' h' + write(outunit,"(A,1PG15.7,A/)") ' or ', elpSec/86400_rk, ' d' ! print the number of threads write(outunit,"(A,i10,/)") ' number threads = ', nThreads diff --git a/build/source/dshare/data_types.f90 b/build/source/dshare/data_types.f90 index 0f592fbb3..a513c5ef9 100755 --- a/build/source/dshare/data_types.f90 +++ b/build/source/dshare/data_types.f90 @@ -48,8 +48,8 @@ MODULE data_types integer(i4b),allocatable :: var_ix(:) ! index of each forcing data variable in the data structure integer(i4b),allocatable :: data_id(:) ! netcdf variable id for each forcing data variable character(len=256),allocatable :: varName(:) ! netcdf variable name for each forcing data variable - real(summa_prec) :: firstJulDay ! first julian day in forcing file - real(summa_prec) :: convTime2Days ! factor to convert time to days + real(rk) :: firstJulDay ! first julian day in forcing file + real(rk) :: convTime2Days ! factor to convert time to days end type file_info ! *********************************************************************************************************** @@ -57,9 +57,9 @@ MODULE data_types ! *********************************************************************************************************** ! define a data type to store model parameter information type,public :: par_info - real(summa_prec) :: default_val ! default parameter value - real(summa_prec) :: lower_limit ! lower bound - real(summa_prec) :: upper_limit ! upper bound + real(rk) :: default_val ! default parameter value + real(rk) :: lower_limit ! lower bound + real(rk) :: upper_limit ! upper bound endtype par_info ! *********************************************************************************************************** @@ -131,7 +131,7 @@ MODULE data_types ! NOTE: use derived types here to facilitate adding the "variable" dimension ! ** double precision type type, public :: dlength - real(summa_prec),allocatable :: dat(:) ! dat(:) + real(rk),allocatable :: dat(:) ! dat(:) endtype dlength ! ** integer type (4 byte) type, public :: ilength @@ -168,7 +168,7 @@ MODULE data_types ! ** double precision type of fixed length type, public :: var_d - real(summa_prec),allocatable :: var(:) ! var(:) + real(rk),allocatable :: var(:) ! var(:) endtype var_d ! ** integer type of fixed length (4 byte) type, public :: var_i @@ -181,7 +181,7 @@ MODULE data_types ! ** double precision type of fixed length type, public :: hru_d - real(summa_prec),allocatable :: hru(:) ! hru(:) + real(rk),allocatable :: hru(:) ! hru(:) endtype hru_d ! ** integer type of fixed length (4 byte) type, public :: hru_i diff --git a/build/source/dshare/globalData.f90 b/build/source/dshare/globalData.f90 index 8a14b8e21..ec1ea83af 100755 --- a/build/source/dshare/globalData.f90 +++ b/build/source/dshare/globalData.f90 @@ -61,8 +61,8 @@ MODULE globalData ! ---------------------------------------------------------------------------------------------------------------- ! define missing values - real(summa_prec),parameter,public :: quadMissing = nr_quadMissing ! (from nrtype) missing quadruple precision number - real(summa_prec),parameter,public :: realMissing = nr_realMissing ! (from nrtype) missing double precision number + real(rk),parameter,public :: quadMissing = nr_quadMissing ! (from nrtype) missing quadruple precision number + real(rk),parameter,public :: realMissing = nr_realMissing ! (from nrtype) missing double precision number integer(i4b),parameter,public :: integerMissing = nr_integerMissing ! (from nrtype) missing integer ! define run modes @@ -166,11 +166,11 @@ MODULE globalData integer(i4b),parameter,public :: iJac2=20 ! last layer of the Jacobian to print ! define limit checks - real(summa_prec),parameter,public :: verySmall=tiny(1.0_summa_prec) ! a very small number - real(summa_prec),parameter,public :: veryBig=1.e+20_summa_prec ! a very big number + real(rk),parameter,public :: verySmall=tiny(1.0_rk) ! a very small number + real(rk),parameter,public :: veryBig=1.e+20_rk ! a very big number ! define algorithmic control parameters - real(summa_prec),parameter,public :: dx = 1.e-8_summa_prec ! finite difference increment + real(rk),parameter,public :: dx = 1.e-8_rk ! finite difference increment ! define summary information on all data structures integer(i4b),parameter :: nStruct=13 ! number of data structures @@ -198,7 +198,7 @@ MODULE globalData ! ---------------------------------------------------------------------------------------------------------------- ! define Indian bread (NaN) - real(summa_prec),save,public :: dNaN + real(rk),save,public :: dNaN ! define default parameter values and parameter bounds type(par_info),save,public :: localParFallback(maxvarMpar) ! local column default parameters @@ -264,7 +264,7 @@ MODULE globalData type(hru2gru_map),allocatable,save,public :: index_map(:) ! hru2gru map ! define variables used for the vegetation phenology - real(summa_prec),dimension(12), save , public :: greenVegFrac_monthly ! fraction of green vegetation in each month (0-1) + real(rk),dimension(12), save , public :: greenVegFrac_monthly ! fraction of green vegetation in each month (0-1) ! define the model output file character(len=256),save,public :: fileout='' ! output filename @@ -291,13 +291,13 @@ MODULE globalData integer(i4b),save,public :: numtim ! number of time steps integer(i4b),save,public :: nHRUrun ! number of HRUs in the run domain integer(i4b),save,public :: nGRUrun ! number of GRUs in the run domain - real(summa_prec),save,public :: data_step ! time step of the data - real(summa_prec),save,public :: refJulday ! reference time in fractional julian days - real(summa_prec),save,public :: refJulday_data ! reference time in fractional julian days (data files) - real(summa_prec),save,public :: fracJulday ! fractional julian days since the start of year - real(summa_prec),save,public :: dJulianStart ! julian day of start time of simulation - real(summa_prec),save,public :: dJulianFinsh ! julian day of end time of simulation - real(summa_prec),save,public :: tmZoneOffsetFracDay ! time zone offset in fractional days + real(rk),save,public :: data_step ! time step of the data + real(rk),save,public :: refJulday ! reference time in fractional julian days + real(rk),save,public :: refJulday_data ! reference time in fractional julian days (data files) + real(rk),save,public :: fracJulday ! fractional julian days since the start of year + real(rk),save,public :: dJulianStart ! julian day of start time of simulation + real(rk),save,public :: dJulianFinsh ! julian day of end time of simulation + real(rk),save,public :: tmZoneOffsetFracDay ! time zone offset in fractional days integer(i4b),save,public :: nHRUfile ! number of HRUs in the file integer(i4b),save,public :: yearLength ! number of days in the current year integer(i4b),save,public :: urbanVegCategory ! vegetation category for urban areas @@ -315,12 +315,12 @@ MODULE globalData integer(i4b),dimension(8),save,public :: startPhysics,endPhysics ! date/time for the start and end of the physics ! define elapsed time - real(summa_prec),save,public :: elapsedInit ! elapsed time for the initialization - real(summa_prec),save,public :: elapsedSetup ! elapsed time for the parameter setup - real(summa_prec),save,public :: elapsedRestart ! elapsed time to read restart data - real(summa_prec),save,public :: elapsedRead ! elapsed time for the data read - real(summa_prec),save,public :: elapsedWrite ! elapsed time for the stats/write - real(summa_prec),save,public :: elapsedPhysics ! elapsed time for the physics + real(rk),save,public :: elapsedInit ! elapsed time for the initialization + real(rk),save,public :: elapsedSetup ! elapsed time for the parameter setup + real(rk),save,public :: elapsedRestart ! elapsed time to read restart data + real(rk),save,public :: elapsedRead ! elapsed time for the data read + real(rk),save,public :: elapsedWrite ! elapsed time for the stats/write + real(rk),save,public :: elapsedPhysics ! elapsed time for the physics ! define ancillary data structures type(var_i),save,public :: startTime ! start time for the model simulation diff --git a/build/source/dshare/multiconst.f90 b/build/source/dshare/multiconst.f90 index 26f9400e0..9d27a299b 100755 --- a/build/source/dshare/multiconst.f90 +++ b/build/source/dshare/multiconst.f90 @@ -21,33 +21,33 @@ MODULE multiconst USE nrtype ! define physical constants - real(summa_prec), PARAMETER :: ave_slp = 101325.0_summa_prec ! mean sea level pressure (Pa) - real(summa_prec), PARAMETER :: vkc = 0.4_summa_prec ! von Karman constant (-) - real(summa_prec), PARAMETER :: satvpfrz = 610.8_summa_prec ! sat vapour pressure at 273.16K (Pa) - real(summa_prec), PARAMETER :: w_ratio = 0.622_summa_prec ! molecular ratio water to dry air (-) - real(summa_prec), PARAMETER :: R_da = 287.053_summa_prec ! gas constant for dry air (Pa K-1 m3 kg-1; J kg-1 K-1) - real(summa_prec), PARAMETER :: R_wv = 461.285_summa_prec ! gas constant for water vapor (Pa K-1 m3 kg-1; J kg-1 K-1) - real(summa_prec), PARAMETER :: Rgas = 8.314_summa_prec ! universal gas constant (J mol-1 K-1) - real(summa_prec), PARAMETER :: gravity = 9.80616_summa_prec ! acceleration of gravity (m s-2) - real(summa_prec), PARAMETER :: Cp_air = 1005._summa_prec ! specific heat of air (J kg-1 K-1) - real(summa_prec), PARAMETER :: Cp_ice = 2114._summa_prec ! specific heat of ice (J kg-1 K-1) - real(summa_prec), PARAMETER :: Cp_soil = 850._summa_prec ! specific heat of soil (J kg-1 K-1) - real(summa_prec), PARAMETER :: Cp_water = 4181._summa_prec ! specific heat of liquid water (J kg-1 K-1) - real(summa_prec), PARAMETER :: Tfreeze = 273.16_summa_prec ! temperature at freezing (K) - real(summa_prec), PARAMETER :: TriplPt = 273.16_summa_prec ! triple point of water (K) - real(summa_prec), PARAMETER :: LH_fus = 333700.0_summa_prec ! latent heat of fusion (J kg-1) - real(summa_prec), PARAMETER :: LH_vap = 2501000.0_summa_prec ! latent heat of vaporization (J kg-1) - real(summa_prec), PARAMETER :: LH_sub = 2834700.0_summa_prec ! latent heat of sublimation (J kg-1) - real(summa_prec), PARAMETER :: sb = 5.6705d-8 ! Stefan Boltzman constant (W m-2 K-4) - real(summa_prec), PARAMETER :: em_sno = 0.99_summa_prec ! emissivity of snow (-) - real(summa_prec), PARAMETER :: lambda_air = 0.026_summa_prec ! thermal conductivity of air (W m-1 K-1) - real(summa_prec), PARAMETER :: lambda_ice = 2.50_summa_prec ! thermal conductivity of ice (W m-1 K-1) - real(summa_prec), PARAMETER :: lambda_water = 0.60_summa_prec ! thermal conductivity of liquid water (W m-1 K-1) - real(summa_prec), PARAMETER :: iden_air = 1.293_summa_prec ! intrinsic density of air (kg m-3) - real(summa_prec), PARAMETER :: iden_ice = 917.0_summa_prec ! intrinsic density of ice (kg m-3) - real(summa_prec), PARAMETER :: iden_water = 1000.0_summa_prec ! intrinsic density of liquid water (kg m-3) - real(summa_prec), PARAMETER :: secprday = 86400._summa_prec ! number of seconds in a day - real(summa_prec), PARAMETER :: secprhour = 3600._summa_prec ! number of seconds in an hour - real(summa_prec), PARAMETER :: secprmin = 60._summa_prec ! number of seconds in a minute - real(summa_prec), PARAMETER :: minprhour = 60._summa_prec ! number of minutes in an hour + real(rk), PARAMETER :: ave_slp = 101325.0_rk ! mean sea level pressure (Pa) + real(rk), PARAMETER :: vkc = 0.4_rk ! von Karman constant (-) + real(rk), PARAMETER :: satvpfrz = 610.8_rk ! sat vapour pressure at 273.16K (Pa) + real(rk), PARAMETER :: w_ratio = 0.622_rk ! molecular ratio water to dry air (-) + real(rk), PARAMETER :: R_da = 287.053_rk ! gas constant for dry air (Pa K-1 m3 kg-1; J kg-1 K-1) + real(rk), PARAMETER :: R_wv = 461.285_rk ! gas constant for water vapor (Pa K-1 m3 kg-1; J kg-1 K-1) + real(rk), PARAMETER :: Rgas = 8.314_rk ! universal gas constant (J mol-1 K-1) + real(rk), PARAMETER :: gravity = 9.80616_rk ! acceleration of gravity (m s-2) + real(rk), PARAMETER :: Cp_air = 1005._rk ! specific heat of air (J kg-1 K-1) + real(rk), PARAMETER :: Cp_ice = 2114._rk ! specific heat of ice (J kg-1 K-1) + real(rk), PARAMETER :: Cp_soil = 850._rk ! specific heat of soil (J kg-1 K-1) + real(rk), PARAMETER :: Cp_water = 4181._rk ! specific heat of liquid water (J kg-1 K-1) + real(rk), PARAMETER :: Tfreeze = 273.16_rk ! temperature at freezing (K) + real(rk), PARAMETER :: TriplPt = 273.16_rk ! triple point of water (K) + real(rk), PARAMETER :: LH_fus = 333700.0_rk ! latent heat of fusion (J kg-1) + real(rk), PARAMETER :: LH_vap = 2501000.0_rk ! latent heat of vaporization (J kg-1) + real(rk), PARAMETER :: LH_sub = 2834700.0_rk ! latent heat of sublimation (J kg-1) + real(rk), PARAMETER :: sb = 5.6705d-8 ! Stefan Boltzman constant (W m-2 K-4) + real(rk), PARAMETER :: em_sno = 0.99_rk ! emissivity of snow (-) + real(rk), PARAMETER :: lambda_air = 0.026_rk ! thermal conductivity of air (W m-1 K-1) + real(rk), PARAMETER :: lambda_ice = 2.50_rk ! thermal conductivity of ice (W m-1 K-1) + real(rk), PARAMETER :: lambda_water = 0.60_rk ! thermal conductivity of liquid water (W m-1 K-1) + real(rk), PARAMETER :: iden_air = 1.293_rk ! intrinsic density of air (kg m-3) + real(rk), PARAMETER :: iden_ice = 917.0_rk ! intrinsic density of ice (kg m-3) + real(rk), PARAMETER :: iden_water = 1000.0_rk ! intrinsic density of liquid water (kg m-3) + real(rk), PARAMETER :: secprday = 86400._rk ! number of seconds in a day + real(rk), PARAMETER :: secprhour = 3600._rk ! number of seconds in an hour + real(rk), PARAMETER :: secprmin = 60._rk ! number of seconds in a minute + real(rk), PARAMETER :: minprhour = 60._rk ! number of minutes in an hour END MODULE multiconst diff --git a/build/source/dshare/outpt_stat.f90 b/build/source/dshare/outpt_stat.f90 index 50b4b376d..f51a6db6f 100755 --- a/build/source/dshare/outpt_stat.f90 +++ b/build/source/dshare/outpt_stat.f90 @@ -54,7 +54,7 @@ subroutine calcStats(stat,dat,meta,resetStats,finalizeStats,statCounter,err,mess character(256) :: cmessage ! error message integer(i4b) :: iVar ! index for varaiable loop integer(i4b) :: pVar ! index into parent structure - real(summa_prec) :: tdata ! dummy for pulling info from dat structure + real(rk) :: tdata ! dummy for pulling info from dat structure ! initialize error control err=0; message='calcStats/' @@ -73,9 +73,9 @@ subroutine calcStats(stat,dat,meta,resetStats,finalizeStats,statCounter,err,mess ! extract data from the structures select type (dat) - type is (real(summa_prec)); tdata = dat(pVar) + type is (real(rk)); tdata = dat(pVar) class is (dlength) ; tdata = dat(pVar)%dat(1) - class is (ilength) ; tdata = real(dat(pVar)%dat(1), kind(summa_prec)) + class is (ilength) ; tdata = real(dat(pVar)%dat(1), kind(rk)) class default;err=20;message=trim(message)//'dat type not found';return end select @@ -114,7 +114,7 @@ subroutine calc_stats(meta,stat,tdata,resetStats,finalizeStats,statCounter,err,m ! input variables class(var_info),intent(in) :: meta ! meta data structure class(*) ,intent(inout) :: stat ! statistics structure - real(summa_prec) ,intent(in) :: tdata ! data value + real(rk) ,intent(in) :: tdata ! data value logical(lgt) ,intent(in) :: resetStats(:) ! vector of flags to reset statistics logical(lgt) ,intent(in) :: finalizeStats(:) ! vector of flags to reset statistics integer(i4b) ,intent(in) :: statCounter(:) ! number of time steps in each output frequency @@ -122,7 +122,7 @@ subroutine calc_stats(meta,stat,tdata,resetStats,finalizeStats,statCounter,err,m integer(i4b) ,intent(out) :: err ! error code character(*) ,intent(out) :: message ! error message ! internals - real(summa_prec),dimension(maxvarFreq*2) :: tstat ! temporary stats vector + real(rk),dimension(maxvarFreq*2) :: tstat ! temporary stats vector integer(i4b) :: iFreq ! index of output frequency ! initialize error control err=0; message='calc_stats/' @@ -144,12 +144,12 @@ subroutine calc_stats(meta,stat,tdata,resetStats,finalizeStats,statCounter,err,m select case(meta%statIndex(iFreq)) ! act depending on the statistic ! ------------------------------------------------------------------------------------- case (iLookStat%totl) ! * summation over period - tstat(iFreq) = 0._summa_prec ! - resets stat at beginning of period + tstat(iFreq) = 0._rk ! - resets stat at beginning of period case (iLookStat%mean) ! * mean over period - tstat(iFreq) = 0._summa_prec ! - resets stat at beginning of period + tstat(iFreq) = 0._rk ! - resets stat at beginning of period case (iLookStat%vari) ! * variance over period - tstat(iFreq) = 0._summa_prec ! - resets E[X^2] term in var calc - tstat(maxVarFreq+iFreq) = 0._summa_prec ! - resets E[X]^2 term + tstat(iFreq) = 0._rk ! - resets E[X^2] term in var calc + tstat(maxVarFreq+iFreq) = 0._rk ! - resets E[X]^2 term case (iLookStat%mini) ! * minimum over period tstat(iFreq) = huge(tstat(iFreq)) ! - resets stat at beginning of period case (iLookStat%maxi) ! * maximum over period diff --git a/build/source/engine/allocspace.f90 b/build/source/engine/allocspace.f90 index cb120eff3..9ddeefc93 100755 --- a/build/source/engine/allocspace.f90 +++ b/build/source/engine/allocspace.f90 @@ -262,7 +262,7 @@ subroutine allocLocal(metaStruct,dataStruct,nSnow,nSoil,err,message) select type(dataStruct) class is (var_flagVec); call allocateDat_flag(metaStruct,nSnow,nSoil,nLayers,dataStruct,err,cmessage) class is (var_ilength); call allocateDat_int( metaStruct,nSnow,nSoil,nLayers,dataStruct,err,cmessage) - class is (var_dlength); call allocateDat_summa_prec( metaStruct,nSnow,nSoil,nLayers,dataStruct,err,cmessage) + class is (var_dlength); call allocateDat_rk( metaStruct,nSnow,nSoil,nLayers,dataStruct,err,cmessage) class default; err=20; message=trim(message)//'unable to identify derived data type for the data dimension'; return end select @@ -328,7 +328,7 @@ subroutine resizeData(metaStruct,dataStructOrig,dataStructNew,copy,err,message) ! double precision class is (var_dlength) select type(dataStructNew) - class is (var_dlength); call copyStruct_summa_prec( dataStructOrig%var(iVar),dataStructNew%var(iVar),isCopy,err,cmessage) + class is (var_dlength); call copyStruct_rk( dataStructOrig%var(iVar),dataStructNew%var(iVar),isCopy,err,cmessage) class default; err=20; message=trim(message)//'mismatch data structure for variable'//trim(metaStruct(iVar)%varname); return end select @@ -349,9 +349,9 @@ subroutine resizeData(metaStruct,dataStructOrig,dataStructNew,copy,err,message) end subroutine resizeData ! ************************************************************************************************ - ! private subroutine copyStruct_summa_prec: copy a given data structure + ! private subroutine copyStruct_rk: copy a given data structure ! ************************************************************************************************ - subroutine copyStruct_summa_prec(varOrig,varNew,copy,err,message) + subroutine copyStruct_rk(varOrig,varNew,copy,err,message) ! dummy variables type(dlength),intent(in) :: varOrig ! original data structure type(dlength),intent(inout) :: varNew ! new data structure @@ -366,7 +366,7 @@ subroutine copyStruct_summa_prec(varOrig,varNew,copy,err,message) integer(i4b) :: lowerBoundNew ! lower bound of a given variable in the new data structure integer(i4b) :: upperBoundNew ! upper bound of a given variable in the new data structure ! initialize error control - err=0; message='copyStruct_summa_prec/' + err=0; message='copyStruct_rk/' ! get the information from the data structures call getVarInfo(varOrig,allocatedOrig,lowerBoundOrig,upperBoundOrig) @@ -433,7 +433,7 @@ subroutine getVarInfo(var,isAllocated,lowerBound,upperBound) end subroutine getVarInfo - end subroutine copyStruct_summa_prec + end subroutine copyStruct_rk ! ************************************************************************************************ ! private subroutine copyStruct_i4b: copy a given data structure @@ -524,9 +524,9 @@ end subroutine copyStruct_i4b ! ************************************************************************************************ - ! private subroutine allocateDat_summa_prec: initialize data dimension of the data structures + ! private subroutine allocateDat_rk: initialize data dimension of the data structures ! ************************************************************************************************ - subroutine allocateDat_summa_prec(metadata,nSnow,nSoil,nLayers, & ! input + subroutine allocateDat_rk(metadata,nSnow,nSoil,nLayers, & ! input varData,err,message) ! output ! access subroutines USE get_ixName_module,only:get_varTypeName ! to access type strings for error messages @@ -546,7 +546,7 @@ subroutine allocateDat_summa_prec(metadata,nSnow,nSoil,nLayers, & ! input integer(i4b) :: nVars ! number of variables in the metadata structure ! initialize error control - err=0; message='allocateDat_summa_prec/' + err=0; message='allocateDat_rk/' ! get the number of variables in the metadata structure nVars = size(metadata) @@ -589,7 +589,7 @@ subroutine allocateDat_summa_prec(metadata,nSnow,nSoil,nLayers, & ! input end do ! looping through variables - end subroutine allocateDat_summa_prec + end subroutine allocateDat_rk ! ************************************************************************************************ ! private subroutine allocateDat_int: initialize data dimension of the data structures diff --git a/build/source/engine/bigAquifer.f90 b/build/source/engine/bigAquifer.f90 index ba4a65449..a51b0f393 100755 --- a/build/source/engine/bigAquifer.f90 +++ b/build/source/engine/bigAquifer.f90 @@ -66,24 +66,24 @@ subroutine bigAquifer(& ! ------------------------------------------------------------------------------------------------------------------------------------------------- implicit none ! input: state variables, fluxes, and parameters - real(summa_prec),intent(in) :: scalarAquiferStorageTrial ! trial value of aquifer storage (m) - real(summa_prec),intent(in) :: scalarCanopyTranspiration ! canopy transpiration (kg m-2 s-1) - real(summa_prec),intent(in) :: scalarSoilDrainage ! soil drainage (m s-1) + real(rk),intent(in) :: scalarAquiferStorageTrial ! trial value of aquifer storage (m) + real(rk),intent(in) :: scalarCanopyTranspiration ! canopy transpiration (kg m-2 s-1) + real(rk),intent(in) :: scalarSoilDrainage ! soil drainage (m s-1) ! input: diagnostic variables and parameters type(var_dlength),intent(in) :: mpar_data ! model parameters type(var_dlength),intent(in) :: diag_data ! diagnostic variables for a local HRU ! output: fluxes - real(summa_prec),intent(out) :: scalarAquiferTranspire ! transpiration loss from the aquifer (m s-1) - real(summa_prec),intent(out) :: scalarAquiferRecharge ! recharge to the aquifer (m s-1) - real(summa_prec),intent(out) :: scalarAquiferBaseflow ! total baseflow from the aquifer (m s-1) - real(summa_prec),intent(out) :: dBaseflow_dAquifer ! change in baseflow flux w.r.t. aquifer storage (s-1) + real(rk),intent(out) :: scalarAquiferTranspire ! transpiration loss from the aquifer (m s-1) + real(rk),intent(out) :: scalarAquiferRecharge ! recharge to the aquifer (m s-1) + real(rk),intent(out) :: scalarAquiferBaseflow ! total baseflow from the aquifer (m s-1) + real(rk),intent(out) :: dBaseflow_dAquifer ! change in baseflow flux w.r.t. aquifer storage (s-1) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! ----------------------------------------------------------------------------------------------------------------------------------------------------- ! local variables - real(summa_prec) :: aquiferTranspireFrac ! fraction of total transpiration that comes from the aquifer (-) - real(summa_prec) :: xTemp ! temporary variable (-) + real(rk) :: aquiferTranspireFrac ! fraction of total transpiration that comes from the aquifer (-) + real(rk) :: xTemp ! temporary variable (-) ! ------------------------------------------------------------------------------------------------------------------------------------------------- ! initialize error control err=0; message='bigAquifer/' @@ -112,7 +112,7 @@ subroutine bigAquifer(& scalarAquiferBaseflow = aquiferBaseflowRate*(xTemp**aquiferBaseflowExp) ! compute the derivative in the net aquifer flux - dBaseflow_dAquifer = -(aquiferBaseflowExp*aquiferBaseflowRate*(xTemp**(aquiferBaseflowExp - 1._summa_prec)))/aquiferScaleFactor + dBaseflow_dAquifer = -(aquiferBaseflowExp*aquiferBaseflowRate*(xTemp**(aquiferBaseflowExp - 1._rk)))/aquiferScaleFactor ! end association to data in structures end associate diff --git a/build/source/engine/canopySnow.f90 b/build/source/engine/canopySnow.f90 index c96ffe967..20aeebef9 100755 --- a/build/source/engine/canopySnow.f90 +++ b/build/source/engine/canopySnow.f90 @@ -73,8 +73,8 @@ subroutine canopySnow(& implicit none ! ------------------------------------------------------------------------------------------------ ! input: model control - real(summa_prec),intent(in) :: dt ! time step (seconds) - real(summa_prec),intent(in) :: exposedVAI ! exposed vegetation area index -- leaf + stem -- after burial by snow (m2 m-2) + real(rk),intent(in) :: dt ! time step (seconds) + real(rk),intent(in) :: exposedVAI ! exposed vegetation area index -- leaf + stem -- after burial by snow (m2 m-2) logical(lgt),intent(in) :: computeVegFlux ! flag to indicate if we are computing fluxes over vegetation (.false. means veg is buried with snow) ! input/output: data structures type(model_options),intent(in) :: model_decisions(:) ! model decisions @@ -87,23 +87,23 @@ subroutine canopySnow(& integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! local variables - real(summa_prec),parameter :: valueMissing=-9999._summa_prec ! missing value + real(rk),parameter :: valueMissing=-9999._rk ! missing value integer(i4b) :: iter ! iteration index integer(i4b),parameter :: maxiter=50 ! maximum number of iterations - real(summa_prec) :: unloading_melt ! unloading associated with canopy drip (kg m-2 s-1) - real(summa_prec) :: airtemp_degC ! value of air temperature in degrees Celcius - real(summa_prec) :: leafScaleFactor ! scaling factor for interception based on temperature (-) - real(summa_prec) :: leafInterceptCapSnow ! storage capacity for snow per unit leaf area (kg m-2) - real(summa_prec) :: canopyIceScaleFactor ! capacity scaling factor for throughfall (kg m-2) - real(summa_prec) :: throughfallDeriv ! derivative in throughfall flux w.r.t. canopy storage (s-1) - real(summa_prec) :: unloadingDeriv ! derivative in unloading flux w.r.t. canopy storage (s-1) - real(summa_prec) :: scalarCanopyIceIter ! trial value for mass of ice on the vegetation canopy (kg m-2) (kg m-2) - real(summa_prec) :: flux ! net flux (kg m-2 s-1) - real(summa_prec) :: delS ! change in storage (kg m-2) - real(summa_prec) :: resMass ! residual in mass equation (kg m-2) - real(summa_prec) :: tempUnloadingFun ! temperature unloading functions, Eq. 14 in Roesch et al. 2001 - real(summa_prec) :: windUnloadingFun ! temperature unloading functions, Eq. 15 in Roesch et al. 2001 - real(summa_prec),parameter :: convTolerMass=0.0001_summa_prec ! convergence tolerance for mass (kg m-2) + real(rk) :: unloading_melt ! unloading associated with canopy drip (kg m-2 s-1) + real(rk) :: airtemp_degC ! value of air temperature in degrees Celcius + real(rk) :: leafScaleFactor ! scaling factor for interception based on temperature (-) + real(rk) :: leafInterceptCapSnow ! storage capacity for snow per unit leaf area (kg m-2) + real(rk) :: canopyIceScaleFactor ! capacity scaling factor for throughfall (kg m-2) + real(rk) :: throughfallDeriv ! derivative in throughfall flux w.r.t. canopy storage (s-1) + real(rk) :: unloadingDeriv ! derivative in unloading flux w.r.t. canopy storage (s-1) + real(rk) :: scalarCanopyIceIter ! trial value for mass of ice on the vegetation canopy (kg m-2) (kg m-2) + real(rk) :: flux ! net flux (kg m-2 s-1) + real(rk) :: delS ! change in storage (kg m-2) + real(rk) :: resMass ! residual in mass equation (kg m-2) + real(rk) :: tempUnloadingFun ! temperature unloading functions, Eq. 14 in Roesch et al. 2001 + real(rk) :: windUnloadingFun ! temperature unloading functions, Eq. 15 in Roesch et al. 2001 + real(rk),parameter :: convTolerMass=0.0001_rk ! convergence tolerance for mass (kg m-2) ! ------------------------------------------------------------------------------------------------------------------------------- ! initialize error control err=0; message='canopySnow/' @@ -151,7 +151,7 @@ subroutine canopySnow(& if(computeVegFlux)then unloading_melt = min(ratioDrip2Unloading*scalarCanopyLiqDrainage, scalarCanopyIce/dt) ! kg m-2 s-1 else - unloading_melt = 0._summa_prec + unloading_melt = 0._rk end if scalarCanopyIce = scalarCanopyIce - unloading_melt*dt @@ -173,11 +173,11 @@ subroutine canopySnow(& scalarCanopySnowUnloading = snowUnloadingCoeff*scalarCanopyIceIter unloadingDeriv = snowUnloadingCoeff else if (ixSnowUnload==windUnload) then - tempUnloadingFun = max(scalarCanairTemp - minTempUnloading, 0._summa_prec) / rateTempUnloading ! (s-1) + tempUnloadingFun = max(scalarCanairTemp - minTempUnloading, 0._rk) / rateTempUnloading ! (s-1) if (scalarWindspdCanopyTop >= minWindUnloading) then windUnloadingFun = abs(scalarWindspdCanopyTop) / rateWindUnloading ! (s-1) else - windUnloadingFun = 0._summa_prec ! (s-1) + windUnloadingFun = 0._rk ! (s-1) end if ! implement the "windySnow" Roesch et al. 2001 parameterization, Eq. 13 in Roesch et al. 2001 scalarCanopySnowUnloading = scalarCanopyIceIter * (tempUnloadingFun + windUnloadingFun) @@ -187,24 +187,24 @@ subroutine canopySnow(& if(scalarSnowfall -1._summa_prec) then - leafScaleFactor = 4.0_summa_prec - elseif(airtemp_degC > -3._summa_prec) then - leafScaleFactor = 1.5_summa_prec*airtemp_degC + 5.5_summa_prec + if (airtemp_degC > -1._rk) then + leafScaleFactor = 4.0_rk + elseif(airtemp_degC > -3._rk) then + leafScaleFactor = 1.5_rk*airtemp_degC + 5.5_rk else - leafScaleFactor = 1.0_summa_prec + leafScaleFactor = 1.0_rk end if leafInterceptCapSnow = refInterceptCapSnow*leafScaleFactor case default @@ -219,7 +219,7 @@ subroutine canopySnow(& end if ! (if snow is falling) ! ** compute iteration increment flux = scalarSnowfall - scalarThroughfallSnow - scalarCanopySnowUnloading ! net flux (kg m-2 s-1) - delS = (flux*dt - (scalarCanopyIceIter - scalarCanopyIce))/(1._summa_prec + (throughfallDeriv + unloadingDeriv)*dt) + delS = (flux*dt - (scalarCanopyIceIter - scalarCanopyIce))/(1._rk + (throughfallDeriv + unloadingDeriv)*dt) ! ** check for convergence resMass = scalarCanopyIceIter - (scalarCanopyIce + flux*dt) if(abs(resMass) < convTolerMass)exit diff --git a/build/source/engine/check_icond.f90 b/build/source/engine/check_icond.f90 index 0234551d7..31d4c360c 100755 --- a/build/source/engine/check_icond.f90 +++ b/build/source/engine/check_icond.f90 @@ -82,15 +82,15 @@ subroutine check_icond(nGRU, & ! number of GRUs and HRU ! temporary variables for realism checks integer(i4b) :: iLayer ! index of model layer integer(i4b) :: iSoil ! index of soil layer - real(summa_prec) :: fLiq ! fraction of liquid water on the vegetation canopy (-) - real(summa_prec) :: vGn_m ! van Genutchen "m" parameter (-) - real(summa_prec) :: tWat ! total water on the vegetation canopy (kg m-2) - real(summa_prec) :: scalarTheta ! liquid water equivalent of total water [liquid water + ice] (-) - real(summa_prec) :: h1,h2 ! used to check depth and height are consistent + real(rk) :: fLiq ! fraction of liquid water on the vegetation canopy (-) + real(rk) :: vGn_m ! van Genutchen "m" parameter (-) + real(rk) :: tWat ! total water on the vegetation canopy (kg m-2) + real(rk) :: scalarTheta ! liquid water equivalent of total water [liquid water + ice] (-) + real(rk) :: h1,h2 ! used to check depth and height are consistent integer(i4b) :: nLayers ! total number of layers - real(summa_prec) :: kappa ! constant in the freezing curve function (m K-1) + real(rk) :: kappa ! constant in the freezing curve function (m K-1) integer(i4b) :: nSnow ! number of snow layers - real(summa_prec),parameter :: xTol=1.e-10_summa_prec ! small tolerance to address precision issues + real(rk),parameter :: xTol=1.e-10_rk ! small tolerance to address precision issues ! -------------------------------------------------------------------------------------------------------- ! Start procedure here @@ -149,14 +149,14 @@ subroutine check_icond(nGRU, & ! number of GRUs and HRU kappa = (iden_ice/iden_water)*(LH_fus/(gravity*Tfreeze)) ! NOTE: J = kg m2 s-2 ! modify the liquid water and ice in the canopy - if(scalarCanopyIce > 0._summa_prec .and. scalarCanopyTemp > Tfreeze)then + if(scalarCanopyIce > 0._rk .and. scalarCanopyTemp > Tfreeze)then message=trim(message)//'canopy ice > 0 when canopy temperature > Tfreeze' err=20; return end if fLiq = fracliquid(scalarCanopyTemp,snowfrz_scale) ! fraction of liquid water (-) tWat = scalarCanopyLiq + scalarCanopyIce ! total water (kg m-2) scalarCanopyLiq = fLiq*tWat ! mass of liquid water on the canopy (kg m-2) - scalarCanopyIce = (1._summa_prec - fLiq)*tWat ! mass of ice on the canopy (kg m-2) + scalarCanopyIce = (1._rk - fLiq)*tWat ! mass of ice on the canopy (kg m-2) ! number of layers nLayers = gru_struc(iGRU)%hruInfo(iHRU)%nSnow + gru_struc(iGRU)%hruInfo(iHRU)%nSoil @@ -168,7 +168,7 @@ subroutine check_icond(nGRU, & ! number of GRUs and HRU ! compute liquid water equivalent of total water (liquid plus ice) if (iLayer>nSnow) then ! soil layer = no volume expansion iSoil = iLayer - nSnow - vGn_m = 1._summa_prec - 1._summa_prec/vGn_n(iSoil) + vGn_m = 1._rk - 1._rk/vGn_n(iSoil) scalarTheta = mLayerVolFracIce(iLayer) + mLayerVolFracLiq(iLayer) else ! snow layer = volume expansion allowed iSoil = integerMissing @@ -184,14 +184,14 @@ subroutine check_icond(nGRU, & ! number of GRUs and HRU ! ***** snow case(iname_snow) ! (check liquid water) - if(mLayerVolFracLiq(iLayer) < 0._summa_prec)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with volumetric fraction of liquid water < 0: layer = ',iLayer; err=20; return; end if - if(mLayerVolFracLiq(iLayer) > 1._summa_prec)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with volumetric fraction of liquid water > 1: layer = ',iLayer; err=20; return; end if + if(mLayerVolFracLiq(iLayer) < 0._rk)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with volumetric fraction of liquid water < 0: layer = ',iLayer; err=20; return; end if + if(mLayerVolFracLiq(iLayer) > 1._rk)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with volumetric fraction of liquid water > 1: layer = ',iLayer; err=20; return; end if ! (check ice) - if(mLayerVolFracIce(iLayer) > 0.80_summa_prec)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with volumetric fraction of ice > 0.80: layer = ',iLayer; err=20; return; end if - if(mLayerVolFracIce(iLayer) < 0.05_summa_prec)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with volumetric fraction of ice < 0.05: layer = ',iLayer; err=20; return; end if + if(mLayerVolFracIce(iLayer) > 0.80_rk)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with volumetric fraction of ice > 0.80: layer = ',iLayer; err=20; return; end if + if(mLayerVolFracIce(iLayer) < 0.05_rk)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with volumetric fraction of ice < 0.05: layer = ',iLayer; err=20; return; end if ! check total water - if(scalarTheta > 0.80_summa_prec)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with total water fraction [liquid + ice] > 0.80: layer = ',iLayer; err=20; return; end if - if(scalarTheta < 0.05_summa_prec)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with total water fraction [liquid + ice] < 0.05: layer = ',iLayer; err=20; return; end if + if(scalarTheta > 0.80_rk)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with total water fraction [liquid + ice] > 0.80: layer = ',iLayer; err=20; return; end if + if(scalarTheta < 0.05_rk)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with total water fraction [liquid + ice] < 0.05: layer = ',iLayer; err=20; return; end if ! ***** soil case(iname_soil) @@ -200,7 +200,7 @@ subroutine check_icond(nGRU, & ! number of GRUs and HRU if(mLayerVolFracLiq(iLayer) < theta_res(iSoil)-xTol)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with volumetric fraction of liquid water < theta_res: layer = ',iLayer; err=20; return; end if if(mLayerVolFracLiq(iLayer) > theta_sat(iSoil)+xTol)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with volumetric fraction of liquid water > theta_sat: layer = ',iLayer; err=20; return; end if ! (check ice) - if(mLayerVolFracIce(iLayer) < 0._summa_prec )then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with volumetric fraction of ice < 0: layer = ' ,iLayer; err=20; return; end if + if(mLayerVolFracIce(iLayer) < 0._rk )then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with volumetric fraction of ice < 0: layer = ' ,iLayer; err=20; return; end if if(mLayerVolFracIce(iLayer) > theta_sat(iSoil)+xTol)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with volumetric fraction of ice > theta_sat: layer = ',iLayer; err=20; return; end if ! check total water if(scalarTheta < theta_res(iSoil)-xTol)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with total water fraction [liquid + ice] < theta_res: layer = ',iLayer; err=20; return; end if @@ -273,7 +273,7 @@ subroutine check_icond(nGRU, & ! number of GRUs and HRU do iLayer=1,nLayers h1 = sum(progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%mLayerDepth)%dat(1:iLayer)) ! sum of the depths up to the current layer h2 = progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%iLayerHeight)%dat(iLayer) - progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%iLayerHeight)%dat(0) ! difference between snow-atm interface and bottom of layer - if(abs(h1 - h2) > 1.e-6_summa_prec)then + if(abs(h1 - h2) > 1.e-6_rk)then write(message,'(a,1x,i0)') trim(message)//'mis-match between layer depth and layer height; layer = ', iLayer, '; sum depths = ',h1,'; height = ',h2 err=20; return end if diff --git a/build/source/engine/computFlux.f90 b/build/source/engine/computFlux.f90 index 95445df4f..eabc02e9a 100755 --- a/build/source/engine/computFlux.f90 +++ b/build/source/engine/computFlux.f90 @@ -164,18 +164,18 @@ subroutine computFlux(& logical(lgt),intent(in) :: firstSplitOper ! flag to indicate if we are processing the first flux call in a splitting operation logical(lgt),intent(in) :: computeVegFlux ! flag to indicate if computing fluxes over vegetation logical(lgt),intent(in) :: scalarSolution ! flag to denote if implementing the scalar solution - real(summa_prec),intent(in) :: drainageMeltPond ! drainage from the surface melt pond (kg m-2 s-1) + real(rk),intent(in) :: drainageMeltPond ! drainage from the surface melt pond (kg m-2 s-1) ! input: state variables - real(summa_prec),intent(in) :: scalarCanairTempTrial ! trial value for temperature of the canopy air space (K) - real(summa_prec),intent(in) :: scalarCanopyTempTrial ! trial value for temperature of the vegetation canopy (K) - real(summa_prec),intent(in) :: mLayerTempTrial(:) ! trial value for temperature of each snow/soil layer (K) - real(summa_prec),intent(in) :: mLayerMatricHeadLiqTrial(:) ! trial value for the liquid water matric potential (m) - real(summa_prec),intent(in) :: scalarAquiferStorageTrial ! trial value of aquifer storage (m) + real(rk),intent(in) :: scalarCanairTempTrial ! trial value for temperature of the canopy air space (K) + real(rk),intent(in) :: scalarCanopyTempTrial ! trial value for temperature of the vegetation canopy (K) + real(rk),intent(in) :: mLayerTempTrial(:) ! trial value for temperature of each snow/soil layer (K) + real(rk),intent(in) :: mLayerMatricHeadLiqTrial(:) ! trial value for the liquid water matric potential (m) + real(rk),intent(in) :: scalarAquiferStorageTrial ! trial value of aquifer storage (m) ! input: diagnostic variables - real(summa_prec),intent(in) :: scalarCanopyLiqTrial ! trial value for mass of liquid water on the vegetation canopy (kg m-2) - real(summa_prec),intent(in) :: scalarCanopyIceTrial ! trial value for mass of ice on the vegetation canopy (kg m-2) - real(summa_prec),intent(in) :: mLayerVolFracLiqTrial(:) ! trial value for volumetric fraction of liquid water (-) - real(summa_prec),intent(in) :: mLayerVolFracIceTrial(:) ! trial value for volumetric fraction of ice (-) + real(rk),intent(in) :: scalarCanopyLiqTrial ! trial value for mass of liquid water on the vegetation canopy (kg m-2) + real(rk),intent(in) :: scalarCanopyIceTrial ! trial value for mass of ice on the vegetation canopy (kg m-2) + real(rk),intent(in) :: mLayerVolFracLiqTrial(:) ! trial value for volumetric fraction of liquid water (-) + real(rk),intent(in) :: mLayerVolFracIceTrial(:) ! trial value for volumetric fraction of ice (-) ! input: data structures type(model_options),intent(in) :: model_decisions(:) ! model decisions type(var_i), intent(in) :: type_data ! type of vegetation and soil @@ -191,8 +191,8 @@ subroutine computFlux(& type(var_dlength),intent(inout) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables ! input-output: flux vector and baseflow derivatives integer(i4b),intent(inout) :: ixSaturation ! index of the lowest saturated layer (NOTE: only computed on the first iteration) - real(summa_prec),intent(out) :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) - real(summa_prec),intent(out) :: fluxVec(:) ! model flux vector (mixed units) + real(rk),intent(out) :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) + real(rk),intent(out) :: fluxVec(:) ! model flux vector (mixed units) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message @@ -202,7 +202,7 @@ subroutine computFlux(& integer(i4b) :: local_ixGroundwater ! local index for groundwater representation integer(i4b) :: iLayer ! index of model layers logical(lgt) :: doVegNrgFlux ! flag to compute the energy flux over vegetation - real(summa_prec),dimension(nSoil) :: dHydCond_dMatric ! derivative in hydraulic conductivity w.r.t matric head (s-1) + real(rk),dimension(nSoil) :: dHydCond_dMatric ! derivative in hydraulic conductivity w.r.t matric head (s-1) character(LEN=256) :: cmessage ! error message of downwind routine ! -------------------------------------------------------------- ! initialize error control @@ -385,8 +385,8 @@ subroutine computFlux(& ! initialize liquid water fluxes throughout the snow and soil domains ! NOTE: used in the energy routines, which is called before the hydrology routines if(firstFluxCall)then - if(nSnow > 0) iLayerLiqFluxSnow(0:nSnow) = 0._summa_prec - iLayerLiqFluxSoil(0:nSoil) = 0._summa_prec + if(nSnow > 0) iLayerLiqFluxSnow(0:nSnow) = 0._rk + iLayerLiqFluxSoil(0:nSoil) = 0._rk end if ! ***** @@ -686,13 +686,13 @@ subroutine computFlux(& if(nSnow==0) then ! * case of infiltration into soil if(scalarMaxInfilRate > scalarRainPlusMelt)then ! infiltration is not rate-limited - scalarSoilControl = (1._summa_prec - scalarFrozenArea)*scalarInfilArea + scalarSoilControl = (1._rk - scalarFrozenArea)*scalarInfilArea else - scalarSoilControl = 0._summa_prec ! (scalarRainPlusMelt exceeds maximum infiltration rate + scalarSoilControl = 0._rk ! (scalarRainPlusMelt exceeds maximum infiltration rate endif else ! * case of infiltration into snow - scalarSoilControl = 1._summa_prec + scalarSoilControl = 1._rk endif ! compute drainage from the soil zone (needed for mass balance checks) @@ -716,10 +716,10 @@ subroutine computFlux(& ! set baseflow fluxes to zero if the baseflow routine is not used if(local_ixGroundwater/=qbaseTopmodel)then ! (diagnostic variables in the data structures) - scalarExfiltration = 0._summa_prec ! exfiltration from the soil profile (m s-1) - mLayerColumnOutflow(:) = 0._summa_prec ! column outflow from each soil layer (m3 s-1) + scalarExfiltration = 0._rk ! exfiltration from the soil profile (m s-1) + mLayerColumnOutflow(:) = 0._rk ! column outflow from each soil layer (m3 s-1) ! (variables needed for the numerical solution) - mLayerBaseflow(:) = 0._summa_prec ! baseflow from each soil layer (m s-1) + mLayerBaseflow(:) = 0._rk ! baseflow from each soil layer (m s-1) ! topmodel-ish shallow groundwater else ! local_ixGroundwater==qbaseTopmodel @@ -798,10 +798,10 @@ subroutine computFlux(& ! if no aquifer, then fluxes are zero else - scalarAquiferTranspire = 0._summa_prec ! transpiration loss from the aquifer (m s-1) - scalarAquiferRecharge = 0._summa_prec ! recharge to the aquifer (m s-1) - scalarAquiferBaseflow = 0._summa_prec ! total baseflow from the aquifer (m s-1) - dBaseflow_dAquifer = 0._summa_prec ! change in baseflow flux w.r.t. aquifer storage (s-1) + scalarAquiferTranspire = 0._rk ! transpiration loss from the aquifer (m s-1) + scalarAquiferRecharge = 0._rk ! recharge to the aquifer (m s-1) + scalarAquiferBaseflow = 0._rk ! total baseflow from the aquifer (m s-1) + dBaseflow_dAquifer = 0._rk ! change in baseflow flux w.r.t. aquifer storage (s-1) end if ! no aquifer endif ! if computing aquifer fluxes @@ -869,15 +869,15 @@ subroutine soilCmpres(& ! input: integer(i4b),intent(in) :: ixRichards ! choice of option for Richards' equation integer(i4b),intent(in) :: ixBeg,ixEnd ! start and end indices defining desired layers - real(summa_prec),intent(in) :: mLayerMatricHead(:) ! matric head at the start of the time step (m) - real(summa_prec),intent(in) :: mLayerMatricHeadTrial(:) ! trial value for matric head (m) - real(summa_prec),intent(in) :: mLayerVolFracLiqTrial(:) ! trial value for volumetric fraction of liquid water (-) - real(summa_prec),intent(in) :: mLayerVolFracIceTrial(:) ! trial value for volumetric fraction of ice (-) - real(summa_prec),intent(in) :: specificStorage ! specific storage coefficient (m-1) - real(summa_prec),intent(in) :: theta_sat(:) ! soil porosity (-) + real(rk),intent(in) :: mLayerMatricHead(:) ! matric head at the start of the time step (m) + real(rk),intent(in) :: mLayerMatricHeadTrial(:) ! trial value for matric head (m) + real(rk),intent(in) :: mLayerVolFracLiqTrial(:) ! trial value for volumetric fraction of liquid water (-) + real(rk),intent(in) :: mLayerVolFracIceTrial(:) ! trial value for volumetric fraction of ice (-) + real(rk),intent(in) :: specificStorage ! specific storage coefficient (m-1) + real(rk),intent(in) :: theta_sat(:) ! soil porosity (-) ! output: - real(summa_prec),intent(inout) :: compress(:) ! soil compressibility (-) - real(summa_prec),intent(inout) :: dCompress_dPsi(:) ! derivative in soil compressibility w.r.t. matric head (m-1) + real(rk),intent(inout) :: compress(:) ! soil compressibility (-) + real(rk),intent(inout) :: dCompress_dPsi(:) ! derivative in soil compressibility w.r.t. matric head (m-1) integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! local variables @@ -896,8 +896,8 @@ subroutine soilCmpres(& endif end do else - compress(:) = 0._summa_prec - dCompress_dPsi(:) = 0._summa_prec + compress(:) = 0._rk + dCompress_dPsi(:) = 0._rk end if end subroutine soilCmpres diff --git a/build/source/engine/computJacob.f90 b/build/source/engine/computJacob.f90 index 5c7a93b57..c09d2fbae 100755 --- a/build/source/engine/computJacob.f90 +++ b/build/source/engine/computJacob.f90 @@ -74,7 +74,7 @@ module computJacob_module implicit none ! define constants -real(summa_prec),parameter :: verySmall=tiny(1.0_summa_prec) ! a very small number +real(rk),parameter :: verySmall=tiny(1.0_rk) ! a very small number integer(i4b),parameter :: ixBandOffset=kl+ku+1 ! offset in the band Jacobian matrix private @@ -107,7 +107,7 @@ subroutine computJacob(& ! ----------------------------------------------------------------------------------------------------------------- implicit none ! input: model control - real(summa_prec),intent(in) :: dt ! length of the time step (seconds) + real(rk),intent(in) :: dt ! length of the time step (seconds) integer(i4b),intent(in) :: nSnow ! number of snow layers integer(i4b),intent(in) :: nSoil ! number of soil layers integer(i4b),intent(in) :: nLayers ! total number of layers in the snow+soil domain @@ -119,10 +119,10 @@ subroutine computJacob(& type(var_dlength),intent(in) :: prog_data ! prognostic variables for a local HRU type(var_dlength),intent(in) :: diag_data ! diagnostic variables for a local HRU type(var_dlength),intent(in) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables - real(summa_prec),intent(in) :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) + real(rk),intent(in) :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) ! input-output: Jacobian and its diagonal - real(summa_prec),intent(inout) :: dMat(:) ! diagonal of the Jacobian matrix - real(summa_prec),intent(out) :: aJac(:,:) ! Jacobian matrix + real(rk),intent(inout) :: dMat(:) ! diagonal of the Jacobian matrix + real(rk),intent(out) :: aJac(:,:) ! Jacobian matrix ! output variables integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message @@ -140,7 +140,7 @@ subroutine computJacob(& integer(i4b) :: jLayer ! index of model layer within the full state vector (hydrology) integer(i4b) :: pLayer ! indices of soil layers (used for the baseflow derivatives) ! conversion factors - real(summa_prec) :: convLiq2tot ! factor to convert liquid water derivative to total water derivative + real(rk) :: convLiq2tot ! factor to convert liquid water derivative to total water derivative ! -------------------------------------------------------------- ! associate variables from data structures associate(& @@ -244,7 +244,7 @@ subroutine computJacob(& ! initialize the Jacobian ! NOTE: this needs to be done every time, since Jacobian matrix is modified in the solver - aJac(:,:) = 0._summa_prec ! analytical Jacobian matrix + aJac(:,:) = 0._rk ! analytical Jacobian matrix ! compute terms in the Jacobian for vegetation (excluding fluxes) ! NOTE: energy for vegetation is computed *within* the iteration loop as it includes phase change @@ -285,7 +285,7 @@ subroutine computJacob(& ! * diagonal elements for the vegetation canopy (-) if(ixCasNrg/=integerMissing) aJac(ixDiag,ixCasNrg) = (dt/canopyDepth)*(-dCanairNetFlux_dCanairTemp) + dMat(ixCasNrg) if(ixVegNrg/=integerMissing) aJac(ixDiag,ixVegNrg) = (dt/canopyDepth)*(-dCanopyNetFlux_dCanopyTemp) + dMat(ixVegNrg) - if(ixVegHyd/=integerMissing) aJac(ixDiag,ixVegHyd) = -scalarFracLiqVeg*(dCanopyEvaporation_dCanLiq - scalarCanopyLiqDeriv)*dt + 1._summa_prec ! ixVegHyd: CORRECT + if(ixVegHyd/=integerMissing) aJac(ixDiag,ixVegHyd) = -scalarFracLiqVeg*(dCanopyEvaporation_dCanLiq - scalarCanopyLiqDeriv)*dt + 1._rk ! ixVegHyd: CORRECT ! * cross-derivative terms w.r.t. canopy water if(ixVegHyd/=integerMissing)then @@ -297,7 +297,7 @@ subroutine computJacob(& if(ixTopHyd/=integerMissing) aJac(ixOffDiag(ixTopHyd,ixVegHyd),ixVegHyd) = (dt/mLayerDepth(1))*(-scalarSoilControl*scalarFracLiqVeg*scalarCanopyLiqDeriv)/iden_water ! cross-derivative terms w.r.t. canopy liquid water (J m-1 kg-1) ! NOTE: dIce/dLiq = (1 - scalarFracLiqVeg); dIce*LH_fus/canopyDepth = J m-3; dLiq = kg m-2 - if(ixVegNrg/=integerMissing) aJac(ixOffDiag(ixVegNrg,ixVegHyd),ixVegHyd) = (dt/canopyDepth) *(-dCanopyNetFlux_dCanLiq) - (1._summa_prec - scalarFracLiqVeg)*LH_fus/canopyDepth ! dF/dLiq + if(ixVegNrg/=integerMissing) aJac(ixOffDiag(ixVegNrg,ixVegHyd),ixVegHyd) = (dt/canopyDepth) *(-dCanopyNetFlux_dCanLiq) - (1._rk - scalarFracLiqVeg)*LH_fus/canopyDepth ! dF/dLiq if(ixTopNrg/=integerMissing) aJac(ixOffDiag(ixTopNrg,ixVegHyd),ixVegHyd) = (dt/mLayerDepth(1))*(-dGroundNetFlux_dCanLiq) endif @@ -369,7 +369,7 @@ subroutine computJacob(& ! compute factor to convert liquid water derivative to total water derivative select case( ixHydType(iLayer) ) case(iname_watLayer); convLiq2tot = mLayerFracLiqSnow(iLayer) - case default; convLiq2tot = 1._summa_prec + case default; convLiq2tot = 1._rk end select ! - diagonal elements @@ -377,7 +377,7 @@ subroutine computJacob(& ! - lower-diagonal elements if(iLayer > 1)then - if(ixSnowOnlyHyd(iLayer-1)/=integerMissing) aJac(ixOffDiag(ixSnowOnlyHyd(iLayer-1),watState),watState) = 0._summa_prec ! sub-diagonal: no dependence on other layers + if(ixSnowOnlyHyd(iLayer-1)/=integerMissing) aJac(ixOffDiag(ixSnowOnlyHyd(iLayer-1),watState),watState) = 0._rk ! sub-diagonal: no dependence on other layers endif ! - upper diagonal elements @@ -394,7 +394,7 @@ subroutine computJacob(& if(nrgstate/=integerMissing)then ! (energy state for the current layer is within the state subset) ! (cross-derivative terms for the current layer) - aJac(ixOffDiag(nrgState,watState),watState) = -(1._summa_prec - mLayerFracLiqSnow(iLayer))*LH_fus*iden_water ! (dF/dLiq) + aJac(ixOffDiag(nrgState,watState),watState) = -(1._rk - mLayerFracLiqSnow(iLayer))*LH_fus*iden_water ! (dF/dLiq) aJac(ixOffDiag(watState,nrgState),nrgState) = (dt/mLayerDepth(iLayer))*iLayerLiqFluxSnowDeriv(iLayer)*mLayerdTheta_dTk(iLayer) ! (dVol/dT) ! (cross-derivative terms for the layer below) @@ -483,7 +483,7 @@ subroutine computJacob(& if(mLayerdTheta_dTk(jLayer) > verySmall)then ! ice is present aJac(ixOffDiag(nrgState,watState),watState) = -dVolTot_dPsi0(iLayer)*LH_fus*iden_water ! dNrg/dMat (J m-3 m-1) -- dMat changes volumetric water, and hence ice content else - aJac(ixOffDiag(nrgState,watState),watState) = 0._summa_prec + aJac(ixOffDiag(nrgState,watState),watState) = 0._rk endif ! - compute lower diagonal elements @@ -529,7 +529,7 @@ subroutine computJacob(& if(computeVegFlux)then ! (derivatives only defined when vegetation protrudes over the surface) ! * liquid water fluxes for vegetation canopy (-) - if(ixVegHyd/=integerMissing) aJac(ixVegHyd,ixVegHyd) = -scalarFracLiqVeg*(dCanopyEvaporation_dCanLiq - scalarCanopyLiqDeriv)*dt + 1._summa_prec + if(ixVegHyd/=integerMissing) aJac(ixVegHyd,ixVegHyd) = -scalarFracLiqVeg*(dCanopyEvaporation_dCanLiq - scalarCanopyLiqDeriv)*dt + 1._rk ! * cross-derivative terms for canopy water if(ixVegHyd/=integerMissing)then @@ -541,7 +541,7 @@ subroutine computJacob(& if(ixTopHyd/=integerMissing) aJac(ixTopHyd,ixVegHyd) = (dt/mLayerDepth(1))*(-scalarSoilControl*scalarFracLiqVeg*scalarCanopyLiqDeriv)/iden_water ! cross-derivative terms w.r.t. canopy liquid water (J m-1 kg-1) ! NOTE: dIce/dLiq = (1 - scalarFracLiqVeg); dIce*LH_fus/canopyDepth = J m-3; dLiq = kg m-2 - if(ixVegNrg/=integerMissing) aJac(ixVegNrg,ixVegHyd) = (dt/canopyDepth) *(-dCanopyNetFlux_dCanLiq) - (1._summa_prec - scalarFracLiqVeg)*LH_fus/canopyDepth ! dF/dLiq + if(ixVegNrg/=integerMissing) aJac(ixVegNrg,ixVegHyd) = (dt/canopyDepth) *(-dCanopyNetFlux_dCanLiq) - (1._rk - scalarFracLiqVeg)*LH_fus/canopyDepth ! dF/dLiq if(ixTopNrg/=integerMissing) aJac(ixTopNrg,ixVegHyd) = (dt/mLayerDepth(1))*(-dGroundNetFlux_dCanLiq) endif @@ -615,7 +615,7 @@ subroutine computJacob(& ! compute factor to convert liquid water derivative to total water derivative select case( ixHydType(iLayer) ) case(iname_watLayer); convLiq2tot = mLayerFracLiqSnow(iLayer) - case default; convLiq2tot = 1._summa_prec + case default; convLiq2tot = 1._rk end select ! - diagonal elements @@ -623,7 +623,7 @@ subroutine computJacob(& ! - lower-diagonal elements if(iLayer > 1)then - if(ixSnowOnlyHyd(iLayer-1)/=integerMissing) aJac(ixSnowOnlyHyd(iLayer-1),watState) = 0._summa_prec ! sub-diagonal: no dependence on other layers + if(ixSnowOnlyHyd(iLayer-1)/=integerMissing) aJac(ixSnowOnlyHyd(iLayer-1),watState) = 0._rk ! sub-diagonal: no dependence on other layers endif ! - upper diagonal elements @@ -640,7 +640,7 @@ subroutine computJacob(& if(nrgstate/=integerMissing)then ! (energy state for the current layer is within the state subset) ! (cross-derivative terms for the current layer) - aJac(nrgState,watState) = -(1._summa_prec - mLayerFracLiqSnow(iLayer))*LH_fus*iden_water ! (dF/dLiq) + aJac(nrgState,watState) = -(1._rk - mLayerFracLiqSnow(iLayer))*LH_fus*iden_water ! (dF/dLiq) aJac(watState,nrgState) = (dt/mLayerDepth(iLayer))*iLayerLiqFluxSnowDeriv(iLayer)*mLayerdTheta_dTk(iLayer) ! (dVol/dT) ! (cross-derivative terms for the layer below) @@ -738,7 +738,7 @@ subroutine computJacob(& if(mLayerdTheta_dTk(jLayer) > verySmall)then ! ice is present aJac(nrgState,watState) = -dVolTot_dPsi0(iLayer)*LH_fus*iden_water ! dNrg/dMat (J m-3 m-1) -- dMat changes volumetric water, and hence ice content else - aJac(nrgState,watState) = 0._summa_prec + aJac(nrgState,watState) = 0._rk endif ! - compute lower diagonal elements diff --git a/build/source/engine/computResid.f90 b/build/source/engine/computResid.f90 index 322df20f6..a9744b3ea 100755 --- a/build/source/engine/computResid.f90 +++ b/build/source/engine/computResid.f90 @@ -105,31 +105,31 @@ subroutine computResid(& ! -------------------------------------------------------------------------------------------------------------------------------- implicit none ! input: model control - real(summa_prec),intent(in) :: dt ! length of the time step (seconds) + real(rk),intent(in) :: dt ! length of the time step (seconds) integer(i4b),intent(in) :: nSnow ! number of snow layers integer(i4b),intent(in) :: nSoil ! number of soil layers integer(i4b),intent(in) :: nLayers ! total number of layers in the snow+soil domain ! input: flux vectors - real(summa_prec),intent(in) :: sMul(:) ! NOTE: qp ! state vector multiplier (used in the residual calculations) - real(summa_prec),intent(in) :: fVec(:) ! flux vector + real(rk),intent(in) :: sMul(:) ! NOTE: qp ! state vector multiplier (used in the residual calculations) + real(rk),intent(in) :: fVec(:) ! flux vector ! input: state variables (already disaggregated into scalars and vectors) - real(summa_prec),intent(in) :: scalarCanairTempTrial ! trial value for temperature of the canopy air space (K) - real(summa_prec),intent(in) :: scalarCanopyTempTrial ! trial value for temperature of the vegetation canopy (K) - real(summa_prec),intent(in) :: scalarCanopyHydTrial ! trial value for canopy water (kg m-2), either liquid water content or total water content - real(summa_prec),intent(in) :: mLayerTempTrial(:) ! trial value for temperature of each snow/soil layer (K) - real(summa_prec),intent(in) :: mLayerVolFracHydTrial(:) ! trial vector of volumetric water content (-), either liquid water content or total water content - real(summa_prec),intent(in) :: scalarAquiferStorageTrial ! trial value of aquifer storage (m) + real(rk),intent(in) :: scalarCanairTempTrial ! trial value for temperature of the canopy air space (K) + real(rk),intent(in) :: scalarCanopyTempTrial ! trial value for temperature of the vegetation canopy (K) + real(rk),intent(in) :: scalarCanopyHydTrial ! trial value for canopy water (kg m-2), either liquid water content or total water content + real(rk),intent(in) :: mLayerTempTrial(:) ! trial value for temperature of each snow/soil layer (K) + real(rk),intent(in) :: mLayerVolFracHydTrial(:) ! trial vector of volumetric water content (-), either liquid water content or total water content + real(rk),intent(in) :: scalarAquiferStorageTrial ! trial value of aquifer storage (m) ! input: diagnostic variables defining the liquid water and ice content (function of state variables) - real(summa_prec),intent(in) :: scalarCanopyIceTrial ! trial value for mass of ice on the vegetation canopy (kg m-2) - real(summa_prec),intent(in) :: mLayerVolFracIceTrial(:) ! trial value for volumetric fraction of ice (-) + real(rk),intent(in) :: scalarCanopyIceTrial ! trial value for mass of ice on the vegetation canopy (kg m-2) + real(rk),intent(in) :: mLayerVolFracIceTrial(:) ! trial value for volumetric fraction of ice (-) ! input: data structures type(var_dlength),intent(in) :: prog_data ! prognostic variables for a local HRU type(var_dlength),intent(in) :: diag_data ! diagnostic variables for a local HRU type(var_dlength),intent(in) :: flux_data ! model fluxes for a local HRU type(var_ilength),intent(in) :: indx_data ! indices defining model states and layers ! output - real(summa_prec),intent(out) :: rAdd(:) ! additional (sink) terms on the RHS of the state equation - real(summa_prec),intent(out) :: rVec(:) ! NOTE: qp ! residual vector + real(rk),intent(out) :: rAdd(:) ! additional (sink) terms on the RHS of the state equation + real(rk),intent(out) :: rVec(:) ! NOTE: qp ! residual vector integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! -------------------------------------------------------------------------------------------------------------------------------- @@ -137,8 +137,8 @@ subroutine computResid(& ! -------------------------------------------------------------------------------------------------------------------------------- integer(i4b) :: iLayer ! index of layer within the snow+soil domain integer(i4b),parameter :: ixVegVolume=1 ! index of the desired vegetation control volumne (currently only one veg layer) - real(summa_prec) :: scalarCanopyHyd ! canopy water content (kg m-2), either liquid water content or total water content - real(summa_prec),dimension(nLayers) :: mLayerVolFracHyd ! vector of volumetric water content (-), either liquid water content or total water content + real(rk) :: scalarCanopyHyd ! canopy water content (kg m-2), either liquid water content or total water content + real(rk),dimension(nLayers) :: mLayerVolFracHyd ! vector of volumetric water content (-), either liquid water content or total water content ! -------------------------------------------------------------------------------------------------------------------------------- ! -------------------------------------------------------------------------------------------------------------------------------- ! link to the necessary variables for the residual computations @@ -189,7 +189,7 @@ subroutine computResid(& ! ----------------------- ! intialize additional terms on the RHS as zero - rAdd(:) = 0._summa_prec + rAdd(:) = 0._rk ! compute energy associated with melt freeze for the vegetation canopy if(ixVegNrg/=integerMissing) rAdd(ixVegNrg) = rAdd(ixVegNrg) + LH_fus*(scalarCanopyIceTrial - scalarCanopyIce)/canopyDepth ! energy associated with melt/freeze (J m-3) diff --git a/build/source/engine/convE2Temp.f90 b/build/source/engine/convE2Temp.f90 index 7594db809..973e2e019 100755 --- a/build/source/engine/convE2Temp.f90 +++ b/build/source/engine/convE2Temp.f90 @@ -41,8 +41,8 @@ module convE2Temp_module ! define the look-up table used to compute temperature based on enthalpy integer(i4b),parameter :: nlook=10001 ! number of elements in the lookup table -real(summa_prec),dimension(nlook),public :: E_lookup ! enthalpy values (J kg-1) -real(summa_prec),dimension(nlook),public :: T_lookup ! temperature values (K) +real(rk),dimension(nlook),public :: E_lookup ! enthalpy values (J kg-1) +real(rk),dimension(nlook),public :: T_lookup ! temperature values (K) contains @@ -59,29 +59,29 @@ subroutine E2T_lookup(mpar_data,err,message) character(*),intent(out) :: message ! error message ! declare local variables character(len=128) :: cmessage ! error message in downwind routine - real(summa_prec),parameter :: T_start=260.0_summa_prec ! start temperature value where all liquid water is assumed frozen (K) - real(summa_prec) :: T_incr,E_incr ! temperature/enthalpy increments - real(summa_prec),dimension(nlook) :: Tk ! initial temperature vector - real(summa_prec),dimension(nlook) :: Ey ! initial enthalpy vector - real(summa_prec),parameter :: waterWght=1._summa_prec ! weight applied to total water (kg m-3) --- cancels out - real(summa_prec),dimension(nlook) :: T2deriv ! 2nd derivatives of the interpolating function at tabulated points + real(rk),parameter :: T_start=260.0_rk ! start temperature value where all liquid water is assumed frozen (K) + real(rk) :: T_incr,E_incr ! temperature/enthalpy increments + real(rk),dimension(nlook) :: Tk ! initial temperature vector + real(rk),dimension(nlook) :: Ey ! initial enthalpy vector + real(rk),parameter :: waterWght=1._rk ! weight applied to total water (kg m-3) --- cancels out + real(rk),dimension(nlook) :: T2deriv ! 2nd derivatives of the interpolating function at tabulated points integer(i4b) :: ilook ! loop through lookup table ! initialize error control err=0; message="E2T_lookup/" ! associate associate( snowfrz_scale => mpar_data%var(iLookPARAM%snowfrz_scale)%dat(1) ) ! define initial temperature vector - T_incr = (Tfreeze - T_start) / real(nlook-1, kind(summa_prec)) ! temperature increment + T_incr = (Tfreeze - T_start) / real(nlook-1, kind(rk)) ! temperature increment Tk = arth(T_start,T_incr,nlook) ! ***** compute specific enthalpy (NOTE: J m-3 --> J kg-1) ***** do ilook=1,nlook Ey(ilook) = temp2ethpy(Tk(ilook),waterWght,snowfrz_scale)/waterWght ! (J m-3 --> J kg-1) end do ! define the final enthalpy vector - E_incr = (-Ey(1)) / real(nlook-1, kind(summa_prec)) ! enthalpy increment + E_incr = (-Ey(1)) / real(nlook-1, kind(rk)) ! enthalpy increment E_lookup = arth(Ey(1),E_incr,nlook) ! use cubic spline interpolation to obtain temperature values at the desired values of enthalpy - call spline(Ey,Tk,1.e30_summa_prec,1.e30_summa_prec,T2deriv,err,cmessage) ! get the second derivatives + call spline(Ey,Tk,1.e30_rk,1.e30_rk,T2deriv,err,cmessage) ! get the second derivatives if(err/=0) then; message=trim(message)//trim(cmessage); return; end if do ilook=1,nlook call splint(Ey,Tk,T2deriv,E_lookup(ilook),T_lookup(ilook),err,cmessage) @@ -99,25 +99,25 @@ subroutine E2T_nosoil(Ey,BulkDenWater,fc_param,Tk,err,message) ! compute temperature based on enthalpy -- appropriate when no dry mass, as in snow implicit none ! declare dummy variables - real(summa_prec),intent(in) :: Ey ! total enthalpy (J m-3) - real(summa_prec),intent(in) :: BulkDenWater ! bulk density of water (kg m-3) - real(summa_prec),intent(in) :: fc_param ! freezing curve parameter (K-1) - real(summa_prec),intent(out) :: Tk ! initial temperature guess / final temperature value (K) + real(rk),intent(in) :: Ey ! total enthalpy (J m-3) + real(rk),intent(in) :: BulkDenWater ! bulk density of water (kg m-3) + real(rk),intent(in) :: fc_param ! freezing curve parameter (K-1) + real(rk),intent(out) :: Tk ! initial temperature guess / final temperature value (K) integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! declare local variables - real(summa_prec),parameter :: dx=1.d-8 ! finite difference increment (J kg-1) - real(summa_prec),parameter :: atol=1.d-12 ! convergence criteria (J kg-1) - real(summa_prec) :: E_spec ! specific enthalpy (J kg-1) - real(summa_prec) :: E_incr ! enthalpy increment + real(rk),parameter :: dx=1.d-8 ! finite difference increment (J kg-1) + real(rk),parameter :: atol=1.d-12 ! convergence criteria (J kg-1) + real(rk) :: E_spec ! specific enthalpy (J kg-1) + real(rk) :: E_incr ! enthalpy increment integer(i4b) :: niter=15 ! maximum number of iterations integer(i4b) :: iter ! iteration index integer(i4b) :: i0 ! position in lookup table - real(summa_prec) :: Tg0,Tg1 ! trial temperatures (K) - real(summa_prec) :: Ht0,Ht1 ! specific enthalpy, based on the trial temperatures (J kg-1) - real(summa_prec) :: f0,f1 ! function evaluations (difference between enthalpy guesses) - real(summa_prec) :: dh ! enthalpy derivative - real(summa_prec) :: dT ! temperature increment + real(rk) :: Tg0,Tg1 ! trial temperatures (K) + real(rk) :: Ht0,Ht1 ! specific enthalpy, based on the trial temperatures (J kg-1) + real(rk) :: f0,f1 ! function evaluations (difference between enthalpy guesses) + real(rk) :: dh ! enthalpy derivative + real(rk) :: dT ! temperature increment ! initialize error control err=0; message="E2T_nosoil/" ! convert input of total enthalpy (J m-3) to total specific enthalpy (J kg-1) @@ -130,8 +130,8 @@ subroutine E2T_nosoil(Ey,BulkDenWater,fc_param,Tk,err,message) Tg0 = (E_spec - E_lookup(1))/Cp_ice + T_lookup(1) Tg1 = Tg0+dx ! compute enthalpy - Ht0 = temp2ethpy(Tg0,1._summa_prec,fc_param) - Ht1 = temp2ethpy(Tg1,1._summa_prec,fc_param) + Ht0 = temp2ethpy(Tg0,1._rk,fc_param) + Ht1 = temp2ethpy(Tg1,1._rk,fc_param) ! compute function evaluations f0 = Ht0 - E_spec f1 = Ht1 - E_spec @@ -171,7 +171,7 @@ subroutine E2T_nosoil(Ey,BulkDenWater,fc_param,Tk,err,message) ! comute new value of Tg Tg1 = Tg0+dT ! get new function evaluation - Ht1 = temp2ethpy(Tg1,1._summa_prec,fc_param) + Ht1 = temp2ethpy(Tg1,1._rk,fc_param) f1 = Ht1 - E_spec ! compute derivative if dT dh = (f1 - f0)/dT @@ -201,17 +201,17 @@ function temp2ethpy(Tk,BulkDenWater,fc_param) ! NOTE: enthalpy is a relative value, defined as zero at Tfreeze where all water is liquid implicit none ! declare dummy variables - real(summa_prec),intent(in) :: Tk ! layer temperature (K) - real(summa_prec),intent(in) :: BulkDenWater ! bulk density of water (kg m-3) - real(summa_prec),intent(in) :: fc_param ! freezing curve parameter (K-1) - real(summa_prec) :: temp2ethpy ! return value of the function, total specific enthalpy (J m-3) + real(rk),intent(in) :: Tk ! layer temperature (K) + real(rk),intent(in) :: BulkDenWater ! bulk density of water (kg m-3) + real(rk),intent(in) :: fc_param ! freezing curve parameter (K-1) + real(rk) :: temp2ethpy ! return value of the function, total specific enthalpy (J m-3) ! declare local variables - real(summa_prec) :: frac_liq ! fraction of liquid water - real(summa_prec) :: enthTempWater ! temperature component of specific enthalpy for total water (liquid and ice) (J kg-1) - real(summa_prec) :: enthMass ! mass component of specific enthalpy (J kg-1) + real(rk) :: frac_liq ! fraction of liquid water + real(rk) :: enthTempWater ! temperature component of specific enthalpy for total water (liquid and ice) (J kg-1) + real(rk) :: enthMass ! mass component of specific enthalpy (J kg-1) ! NOTE: this function assumes the freezing curve for snow ... it needs modification to use vanGenuchten functions for soil ! compute the fraction of liquid water in the given layer - frac_liq = 1._summa_prec / ( 1._summa_prec + ( fc_param*( Tfreeze - min(Tk,Tfreeze) ) )**2._summa_prec ) + frac_liq = 1._rk / ( 1._rk + ( fc_param*( Tfreeze - min(Tk,Tfreeze) ) )**2._rk ) ! compute the temperature component of enthalpy for the soil constituent (J kg-1) !enthTempSoil = Cp_soil*(Tk - Tfreeze) ! compute the temperature component of enthalpy for total water (J kg-1) @@ -220,7 +220,7 @@ function temp2ethpy(Tk,BulkDenWater,fc_param) if(Tk>=Tfreeze) enthTempWater = Cp_water*(Tk - Tfreeze) ! compute the mass component of enthalpy -- energy required to melt ice (J kg-1) ! NOTE: negative enthalpy means require energy to bring to Tfreeze - enthMass = -LH_fus*(1._summa_prec - frac_liq) + enthMass = -LH_fus*(1._rk - frac_liq) ! finally, compute the total enthalpy (J m-3) ! NOTE: this is the case for snow (no soil).. function needs modification to use vanGenuchten functions for soil temp2ethpy = BulkDenWater*(enthTempWater + enthMass) !+ BulkDenSoil*enthTempSoil diff --git a/build/source/engine/conv_funcs.f90 b/build/source/engine/conv_funcs.f90 index 568372aec..d31e229cb 100755 --- a/build/source/engine/conv_funcs.f90 +++ b/build/source/engine/conv_funcs.f90 @@ -36,8 +36,8 @@ module conv_funcs_module ! *************************************************************************************************************** function getLatentHeatValue(T) implicit none -real(summa_prec),intent(in) :: T ! temperature (K) -real(summa_prec) :: getLatentHeatValue ! latent heat of sublimation/vaporization (J kg-1) +real(rk),intent(in) :: T ! temperature (K) +real(rk) :: getLatentHeatValue ! latent heat of sublimation/vaporization (J kg-1) if(T > Tfreeze)then getLatentHeatValue = LH_vap ! latent heat of vaporization (J kg-1) else @@ -52,14 +52,14 @@ end function getLatentHeatValue function vapPress(q,p) implicit none ! input -real(summa_prec),intent(in) :: q ! specific humidity (g g-1) -real(summa_prec),intent(in) :: p ! pressure (Pa) +real(rk),intent(in) :: q ! specific humidity (g g-1) +real(rk),intent(in) :: p ! pressure (Pa) ! output -real(summa_prec) :: vapPress ! vapor pressure (Pa) +real(rk) :: vapPress ! vapor pressure (Pa) ! local -real(summa_prec) :: w ! mixing ratio -!real(summa_prec),parameter :: w_ratio = 0.622_summa_prec ! molecular weight ratio of water to dry air (-) -w = q / (1._summa_prec - q) ! mixing ratio (-) +real(rk) :: w ! mixing ratio +!real(rk),parameter :: w_ratio = 0.622_rk ! molecular weight ratio of water to dry air (-) +w = q / (1._rk - q) ! mixing ratio (-) vapPress = (w/(w + w_ratio))*p ! vapor pressure (Pa) end function vapPress @@ -72,22 +72,22 @@ end function vapPress subroutine satVapPress(TC, SVP, dSVP_dT) IMPLICIT NONE ! input -real(summa_prec), intent(in) :: TC ! temperature (C) +real(rk), intent(in) :: TC ! temperature (C) ! output -real(summa_prec), intent(out) :: SVP ! saturation vapor pressure (Pa) -real(summa_prec), intent(out) :: dSVP_dT ! d(SVP)/dT +real(rk), intent(out) :: SVP ! saturation vapor pressure (Pa) +real(rk), intent(out) :: dSVP_dT ! d(SVP)/dT ! local -real(summa_prec), parameter :: X1 = 17.27_summa_prec -real(summa_prec), parameter :: X2 = 237.30_summa_prec +real(rk), parameter :: X1 = 17.27_rk +real(rk), parameter :: X2 = 237.30_rk ! local (use to test derivative calculations) -real(summa_prec),parameter :: dx = 1.e-8_summa_prec ! finite difference increment +real(rk),parameter :: dx = 1.e-8_rk ! finite difference increment logical(lgt),parameter :: testDeriv=.false. ! flag to test the derivative !--------------------------------------------------------------------------------------------------- ! Units note : Pa = N m-2 = kg m-1 s-2 ! SATVPFRZ= 610.8 ! Saturation water vapour pressure at 273.16K (Pa) SVP = SATVPFRZ * EXP( (X1*TC)/(X2 + TC) ) ! Saturated Vapour Press (Pa) -dSVP_dT = SVP * (X1/(X2 + TC) - X1*TC/(X2 + TC)**2._summa_prec) +dSVP_dT = SVP * (X1/(X2 + TC) - X1*TC/(X2 + TC)**2._rk) if(testDeriv) print*, 'dSVP_dT check... ', SVP, dSVP_dT, (SATVPRESS(TC+dx) - SVP)/dx END SUBROUTINE satVapPress @@ -104,10 +104,10 @@ END SUBROUTINE satVapPress FUNCTION MSLP2AIRP(MSLP, ELEV) IMPLICIT NONE -real(summa_prec), INTENT(IN) :: MSLP ! base pressure (Pa) -real(summa_prec), INTENT(IN) :: ELEV ! elevation difference from base (m) +real(rk), INTENT(IN) :: MSLP ! base pressure (Pa) +real(rk), INTENT(IN) :: ELEV ! elevation difference from base (m) -real(summa_prec) :: MSLP2AIRP ! Air pressure (Pa) +real(rk) :: MSLP2AIRP ! Air pressure (Pa) MSLP2AIRP = MSLP * ( (293.-0.0065*ELEV) / 293. )**5.256 @@ -126,14 +126,14 @@ FUNCTION RLHUM2DEWPT(T, RLHUM) ! Compute Dewpoint temperature from Relative Humidity IMPLICIT NONE -real(summa_prec), INTENT(IN) :: T ! Temperature (K) -real(summa_prec), INTENT(IN) :: RLHUM ! Relative Humidity (%) +real(rk), INTENT(IN) :: T ! Temperature (K) +real(rk), INTENT(IN) :: RLHUM ! Relative Humidity (%) -real(summa_prec) :: RLHUM2DEWPT ! Dewpoint Temp (K) +real(rk) :: RLHUM2DEWPT ! Dewpoint Temp (K) -real(summa_prec) :: VPSAT ! Sat. vapour pressure at T (Pa) -real(summa_prec) :: TDCEL ! Dewpoint temp Celcius (C) +real(rk) :: VPSAT ! Sat. vapour pressure at T (Pa) +real(rk) :: TDCEL ! Dewpoint temp Celcius (C) ! Units note : Pa = N m-2 = kg m-1 s-2 ! SATVPFRZ= 610.8 ! Saturation water vapour pressure at 273.16K (Pa) @@ -158,13 +158,13 @@ END FUNCTION RLHUM2DEWPT FUNCTION DEWPT2RLHUM(T, DEWPT) IMPLICIT NONE -real(summa_prec), INTENT(IN) :: T ! Temperature (K) -real(summa_prec), INTENT(IN) :: DEWPT ! Dewpoint temp (K) +real(rk), INTENT(IN) :: T ! Temperature (K) +real(rk), INTENT(IN) :: DEWPT ! Dewpoint temp (K) -real(summa_prec) :: DEWPT2RLHUM ! Relative Humidity (%) +real(rk) :: DEWPT2RLHUM ! Relative Humidity (%) -real(summa_prec) :: VPSAT ! Sat. vapour pressure at T (Pa) -real(summa_prec) :: TDCEL ! Dewpt in celcius (C) +real(rk) :: VPSAT ! Sat. vapour pressure at T (Pa) +real(rk) :: TDCEL ! Dewpt in celcius (C) ! Units note : Pa = N m-2 = kg m-1 s-2 ! SATVPFRZ= 610.8 ! Saturation water vapour pressure at 273.16K (Pa) @@ -188,13 +188,13 @@ END FUNCTION DEWPT2RLHUM FUNCTION DEWPT2SPHM(DEWPT, PRESS) IMPLICIT NONE -real(summa_prec), INTENT(IN) :: DEWPT ! Dewpoint temp (K) -real(summa_prec), INTENT(IN) :: PRESS ! Pressure (Pa) +real(rk), INTENT(IN) :: DEWPT ! Dewpoint temp (K) +real(rk), INTENT(IN) :: PRESS ! Pressure (Pa) -real(summa_prec) :: DEWPT2SPHM ! Specific Humidity (g/g) +real(rk) :: DEWPT2SPHM ! Specific Humidity (g/g) -real(summa_prec) :: VPAIR ! vapour pressure at T (Pa) -real(summa_prec) :: TDCEL ! Dewpt in celcius (C) +real(rk) :: VPAIR ! vapour pressure at T (Pa) +real(rk) :: TDCEL ! Dewpt in celcius (C) ! Units note : Pa = N m-2 = kg m-1 s-2 ! SATVPFRZ= 610.8 ! Saturation water vapour pressure at 273.16K (Pa) @@ -218,10 +218,10 @@ END FUNCTION DEWPT2SPHM FUNCTION DEWPT2VPAIR(DEWPT) IMPLICIT NONE -real(summa_prec), INTENT(IN) :: DEWPT ! Dewpoint temp (K) -real(summa_prec) :: TDCEL ! Dewpt in celcius (C) +real(rk), INTENT(IN) :: DEWPT ! Dewpoint temp (K) +real(rk) :: TDCEL ! Dewpt in celcius (C) -real(summa_prec) :: DEWPT2VPAIR ! Vapour Press (Pa) +real(rk) :: DEWPT2VPAIR ! Vapour Press (Pa) ! Units note : Pa = N m-2 = kg m-1 s-2 ! SATVPFRZ= 610.8 ! Saturation water vapour pressure at 273.16K (Pa) @@ -243,15 +243,15 @@ END FUNCTION DEWPT2VPAIR FUNCTION SPHM2RELHM(SPHM, PRESS, TAIR) IMPLICIT NONE -real(summa_prec), INTENT(IN) :: SPHM ! Specific Humidity (g/g) -real(summa_prec), INTENT(IN) :: PRESS ! Pressure (Pa) -real(summa_prec), INTENT(IN) :: TAIR ! Air temp +real(rk), INTENT(IN) :: SPHM ! Specific Humidity (g/g) +real(rk), INTENT(IN) :: PRESS ! Pressure (Pa) +real(rk), INTENT(IN) :: TAIR ! Air temp -real(summa_prec) :: SPHM2RELHM ! Dewpoint Temp (K) +real(rk) :: SPHM2RELHM ! Dewpoint Temp (K) -real(summa_prec) :: VPSAT ! vapour pressure at T (Pa) -real(summa_prec) :: TDCEL ! Dewpt in celcius (C) -!real(summa_prec) :: DUM ! Intermediate +real(rk) :: VPSAT ! vapour pressure at T (Pa) +real(rk) :: TDCEL ! Dewpt in celcius (C) +!real(rk) :: DUM ! Intermediate ! Units note : Pa = N m-2 = kg m-1 s-2 ! SATVPFRZ= 610.8 ! Saturation water vapour pressure at 273.16K (Pa) @@ -274,15 +274,15 @@ END FUNCTION SPHM2RELHM FUNCTION RELHM2SPHM(RELHM, PRESS, TAIR) IMPLICIT NONE -real(summa_prec), INTENT(IN) :: RELHM ! Relative Humidity (%) -real(summa_prec), INTENT(IN) :: PRESS ! Pressure (Pa) -real(summa_prec), INTENT(IN) :: TAIR ! Air temp +real(rk), INTENT(IN) :: RELHM ! Relative Humidity (%) +real(rk), INTENT(IN) :: PRESS ! Pressure (Pa) +real(rk), INTENT(IN) :: TAIR ! Air temp -real(summa_prec) :: RELHM2SPHM ! Specific Humidity (g/g) +real(rk) :: RELHM2SPHM ! Specific Humidity (g/g) -real(summa_prec) :: PVP ! Partial vapour pressure at T (Pa) -real(summa_prec) :: TDCEL ! Dewpt in celcius (C) -!real(summa_prec) :: DUM ! Intermediate +real(rk) :: PVP ! Partial vapour pressure at T (Pa) +real(rk) :: TDCEL ! Dewpt in celcius (C) +!real(rk) :: DUM ! Intermediate ! Units note : Pa = N m-2 = kg m-1 s-2 ! SATVPFRZ= 610.8 ! Saturation water vapour pressure at 273.16K (Pa) @@ -300,31 +300,31 @@ END FUNCTION RELHM2SPHM FUNCTION WETBULBTMP(TAIR, RELHM, PRESS) IMPLICIT NONE ! input -real(summa_prec), INTENT(IN) :: TAIR ! Air temp (K) -real(summa_prec), INTENT(IN) :: RELHM ! Relative Humidity (-) -real(summa_prec), INTENT(IN) :: PRESS ! Pressure (Pa) +real(rk), INTENT(IN) :: TAIR ! Air temp (K) +real(rk), INTENT(IN) :: RELHM ! Relative Humidity (-) +real(rk), INTENT(IN) :: PRESS ! Pressure (Pa) ! output -real(summa_prec) :: WETBULBTMP ! Wet bulb temperature (K) +real(rk) :: WETBULBTMP ! Wet bulb temperature (K) ! locals -real(summa_prec) :: Tcel ! Temperature in celcius (C) -real(summa_prec) :: PVP ! Partial vapor pressure (Pa) -real(summa_prec) :: TWcel ! Wet bulb temperature in celcius (C) -real(summa_prec),PARAMETER :: k=6.54E-4_DP ! normalizing factor in wet bulb estimate (C-1) -real(summa_prec) :: Twet_trial0 ! trial value for wet bulb temperature (C) -real(summa_prec) :: Twet_trial1 ! trial value for wet bulb temperature (C) -real(summa_prec) :: f0,f1 ! function evaluations (C) -real(summa_prec) :: df_dT ! derivative (-) -real(summa_prec) :: TWinc ! wet bulb temperature increment (C) +real(rk) :: Tcel ! Temperature in celcius (C) +real(rk) :: PVP ! Partial vapor pressure (Pa) +real(rk) :: TWcel ! Wet bulb temperature in celcius (C) +real(rk),PARAMETER :: k=6.54E-4_DP ! normalizing factor in wet bulb estimate (C-1) +real(rk) :: Twet_trial0 ! trial value for wet bulb temperature (C) +real(rk) :: Twet_trial1 ! trial value for wet bulb temperature (C) +real(rk) :: f0,f1 ! function evaluations (C) +real(rk) :: df_dT ! derivative (-) +real(rk) :: TWinc ! wet bulb temperature increment (C) INTEGER(I4B) :: iter ! iterattion index -real(summa_prec),PARAMETER :: Xoff=1.E-5_DP ! finite difference increment (C) -real(summa_prec),PARAMETER :: Xtol=1.E-8_DP ! convergence tolerance (C) +real(rk),PARAMETER :: Xoff=1.E-5_DP ! finite difference increment (C) +real(rk),PARAMETER :: Xtol=1.E-8_DP ! convergence tolerance (C) INTEGER(I4B) :: maxiter=15 ! maximum number of iterations ! convert temperature to Celcius Tcel = TAIR-TFREEZE ! compute partial vapor pressure based on temperature (Pa) PVP = RELHM * SATVPRESS(Tcel) ! define an initial trial value for wetbulb temperature -TWcel = Tcel - 5._summa_prec +TWcel = Tcel - 5._rk ! iterate until convergence do iter=1,maxiter ! compute Twet estimates @@ -358,9 +358,9 @@ END FUNCTION WETBULBTMP ! *************************************************************************************************************** FUNCTION SATVPRESS(TCEL) IMPLICIT NONE -real(summa_prec),INTENT(IN) :: TCEL ! Temperature (C) -real(summa_prec) :: SATVPRESS ! Saturated vapor pressure (Pa) -SATVPRESS = SATVPFRZ * EXP( (17.27_summa_prec*TCEL)/(237.30_summa_prec + TCEL) ) ! Saturated Vapour Press (Pa) +real(rk),INTENT(IN) :: TCEL ! Temperature (C) +real(rk) :: SATVPRESS ! Saturated vapor pressure (Pa) +SATVPRESS = SATVPFRZ * EXP( (17.27_rk*TCEL)/(237.30_rk + TCEL) ) ! Saturated Vapour Press (Pa) END FUNCTION SATVPRESS diff --git a/build/source/engine/coupled_em.f90 b/build/source/engine/coupled_em.f90 index a9e08b7bd..7e14de0d9 100755 --- a/build/source/engine/coupled_em.f90 +++ b/build/source/engine/coupled_em.f90 @@ -89,10 +89,10 @@ module coupled_em_module private public::coupled_em ! algorithmic parameters -real(summa_prec),parameter :: valueMissing=-9999._summa_prec ! missing value, used when diagnostic or state variables are undefined -real(summa_prec),parameter :: verySmall=1.e-6_summa_prec ! used as an additive constant to check if substantial difference among real numbers -real(summa_prec),parameter :: mpe=1.e-6_summa_prec ! prevents overflow error if division by zero -real(summa_prec),parameter :: dx=1.e-6_summa_prec ! finite difference increment +real(rk),parameter :: valueMissing=-9999._rk ! missing value, used when diagnostic or state variables are undefined +real(rk),parameter :: verySmall=1.e-6_rk ! used as an additive constant to check if substantial difference among real numbers +real(rk),parameter :: mpe=1.e-6_rk ! prevents overflow error if division by zero +real(rk),parameter :: dx=1.e-6_rk ! finite difference increment contains @@ -148,7 +148,7 @@ subroutine coupled_em(& implicit none ! model control integer(8),intent(in) :: hruId ! hruId - real(summa_prec),intent(inout) :: dt_init ! used to initialize the size of the sub-step + real(rk),intent(inout) :: dt_init ! used to initialize the size of the sub-step logical(lgt),intent(inout) :: computeVegFlux ! flag to indicate if we are computing fluxes over vegetation (.false. means veg is buried with snow) ! data structures (input) type(var_i),intent(in) :: type_data ! type of vegetation and soil @@ -172,12 +172,12 @@ subroutine coupled_em(& integer(i4b) :: nSoil ! number of soil layers integer(i4b) :: nLayers ! total number of layers integer(i4b) :: nState ! total number of state variables - real(summa_prec) :: dtSave ! length of last input model sub-step (seconds) - real(summa_prec) :: dt_sub ! length of model sub-step (seconds) - real(summa_prec) :: dt_wght ! weight applied to model sub-step (dt_sub/data_step) - real(summa_prec) :: dt_solv ! seconds in the data step that have been completed - real(summa_prec) :: dtMultiplier ! time step multiplier (-) based on what happenned in "opSplittin" - real(summa_prec) :: minstep,maxstep ! minimum and maximum time step length (seconds) + real(rk) :: dtSave ! length of last input model sub-step (seconds) + real(rk) :: dt_sub ! length of model sub-step (seconds) + real(rk) :: dt_wght ! weight applied to model sub-step (dt_sub/data_step) + real(rk) :: dt_solv ! seconds in the data step that have been completed + real(rk) :: dtMultiplier ! time step multiplier (-) based on what happenned in "opSplittin" + real(rk) :: minstep,maxstep ! minimum and maximum time step length (seconds) integer(i4b) :: nsub ! number of substeps logical(lgt) :: computeVegFluxOld ! flag to indicate if we are computing fluxes over vegetation on the previous sub step logical(lgt) :: includeAquifer ! flag to denote that an aquifer is included @@ -185,16 +185,16 @@ subroutine coupled_em(& logical(lgt) :: modifiedVegState ! flag to denote that vegetation states were modified type(var_dlength) :: flux_mean ! timestep-average model fluxes for a local HRU integer(i4b) :: nLayersRoots ! number of soil layers that contain roots - real(summa_prec) :: exposedVAI ! exposed vegetation area index - real(summa_prec) :: dCanopyWetFraction_dWat ! derivative in wetted fraction w.r.t. canopy total water (kg-1 m2) - real(summa_prec) :: dCanopyWetFraction_dT ! derivative in wetted fraction w.r.t. canopy temperature (K-1) - real(summa_prec),parameter :: varNotUsed1=-9999._summa_prec ! variables used to calculate derivatives (not needed here) - real(summa_prec),parameter :: varNotUsed2=-9999._summa_prec ! variables used to calculate derivatives (not needed here) + real(rk) :: exposedVAI ! exposed vegetation area index + real(rk) :: dCanopyWetFraction_dWat ! derivative in wetted fraction w.r.t. canopy total water (kg-1 m2) + real(rk) :: dCanopyWetFraction_dT ! derivative in wetted fraction w.r.t. canopy temperature (K-1) + real(rk),parameter :: varNotUsed1=-9999._rk ! variables used to calculate derivatives (not needed here) + real(rk),parameter :: varNotUsed2=-9999._rk ! variables used to calculate derivatives (not needed here) integer(i4b) :: iSnow ! index of snow layers integer(i4b) :: iLayer ! index of model layers - real(summa_prec) :: massLiquid ! mass liquid water (kg m-2) - real(summa_prec) :: superflousSub ! superflous sublimation (kg m-2 s-1) - real(summa_prec) :: superflousNrg ! superflous energy that cannot be used for sublimation (W m-2 [J m-2 s-1]) + real(rk) :: massLiquid ! mass liquid water (kg m-2) + real(rk) :: superflousSub ! superflous sublimation (kg m-2 s-1) + real(rk) :: superflousNrg ! superflous energy that cannot be used for sublimation (W m-2 [J m-2 s-1]) integer(i4b) :: ixSolution ! solution method used by opSplitting logical(lgt) :: firstSubStep ! flag to denote if the first time step logical(lgt) :: stepFailure ! flag to denote the need to reduce length of the coupled step and try again @@ -206,34 +206,34 @@ subroutine coupled_em(& type(var_dlength) :: prog_temp ! temporary model prognostic variables type(var_dlength) :: diag_temp ! temporary model diagnostic variables ! check SWE - real(summa_prec) :: oldSWE ! SWE at the start of the substep - real(summa_prec) :: newSWE ! SWE at the end of the substep - real(summa_prec) :: delSWE ! change in SWE over the subtep - real(summa_prec) :: effRainfall ! effective rainfall (kg m-2 s-1) - real(summa_prec) :: effSnowfall ! effective snowfall (kg m-2 s-1) - real(summa_prec) :: sfcMeltPond ! surface melt pond (kg m-2) - real(summa_prec) :: massBalance ! mass balance error (kg m-2) + real(rk) :: oldSWE ! SWE at the start of the substep + real(rk) :: newSWE ! SWE at the end of the substep + real(rk) :: delSWE ! change in SWE over the subtep + real(rk) :: effRainfall ! effective rainfall (kg m-2 s-1) + real(rk) :: effSnowfall ! effective snowfall (kg m-2 s-1) + real(rk) :: sfcMeltPond ! surface melt pond (kg m-2) + real(rk) :: massBalance ! mass balance error (kg m-2) ! balance checks integer(i4b) :: iVar ! loop through model variables - real(summa_prec) :: totalSoilCompress ! total soil compression (kg m-2) - real(summa_prec) :: scalarCanopyWatBalError ! water balance error for the vegetation canopy (kg m-2) - real(summa_prec) :: scalarSoilWatBalError ! water balance error (kg m-2) - real(summa_prec) :: scalarInitCanopyLiq ! initial liquid water on the vegetation canopy (kg m-2) - real(summa_prec) :: scalarInitCanopyIce ! initial ice on the vegetation canopy (kg m-2) - real(summa_prec) :: balanceCanopyWater0 ! total water stored in the vegetation canopy at the start of the step (kg m-2) - real(summa_prec) :: balanceCanopyWater1 ! total water stored in the vegetation canopy at the end of the step (kg m-2) - real(summa_prec) :: balanceSoilWater0 ! total soil storage at the start of the step (kg m-2) - real(summa_prec) :: balanceSoilWater1 ! total soil storage at the end of the step (kg m-2) - real(summa_prec) :: balanceSoilInflux ! input to the soil zone - real(summa_prec) :: balanceSoilBaseflow ! output from the soil zone - real(summa_prec) :: balanceSoilDrainage ! output from the soil zone - real(summa_prec) :: balanceSoilET ! output from the soil zone - real(summa_prec) :: balanceAquifer0 ! total aquifer storage at the start of the step (kg m-2) - real(summa_prec) :: balanceAquifer1 ! total aquifer storage at the end of the step (kg m-2) + real(rk) :: totalSoilCompress ! total soil compression (kg m-2) + real(rk) :: scalarCanopyWatBalError ! water balance error for the vegetation canopy (kg m-2) + real(rk) :: scalarSoilWatBalError ! water balance error (kg m-2) + real(rk) :: scalarInitCanopyLiq ! initial liquid water on the vegetation canopy (kg m-2) + real(rk) :: scalarInitCanopyIce ! initial ice on the vegetation canopy (kg m-2) + real(rk) :: balanceCanopyWater0 ! total water stored in the vegetation canopy at the start of the step (kg m-2) + real(rk) :: balanceCanopyWater1 ! total water stored in the vegetation canopy at the end of the step (kg m-2) + real(rk) :: balanceSoilWater0 ! total soil storage at the start of the step (kg m-2) + real(rk) :: balanceSoilWater1 ! total soil storage at the end of the step (kg m-2) + real(rk) :: balanceSoilInflux ! input to the soil zone + real(rk) :: balanceSoilBaseflow ! output from the soil zone + real(rk) :: balanceSoilDrainage ! output from the soil zone + real(rk) :: balanceSoilET ! output from the soil zone + real(rk) :: balanceAquifer0 ! total aquifer storage at the start of the step (kg m-2) + real(rk) :: balanceAquifer1 ! total aquifer storage at the end of the step (kg m-2) ! test balance checks logical(lgt), parameter :: printBalance=.false. ! flag to print the balance checks - real(summa_prec), allocatable :: liqSnowInit(:) ! volumetric liquid water conetnt of snow at the start of the time step - real(summa_prec), allocatable :: liqSoilInit(:) ! soil moisture at the start of the time step + real(rk), allocatable :: liqSnowInit(:) ! volumetric liquid water conetnt of snow at the start of the time step + real(rk), allocatable :: liqSoilInit(:) ! soil moisture at the start of the time step ! ---------------------------------------------------------------------------------------------------------------------------------------------- ! initialize error control err=0; message="coupled_em/" @@ -300,12 +300,12 @@ subroutine coupled_em(& if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; end if ! initialize compression and surface melt pond - sfcMeltPond = 0._summa_prec ! change in storage associated with the surface melt pond (kg m-2) - totalSoilCompress = 0._summa_prec ! change in soil storage associated with compression of the matrix (kg m-2) + sfcMeltPond = 0._rk ! change in storage associated with the surface melt pond (kg m-2) + totalSoilCompress = 0._rk ! change in soil storage associated with compression of the matrix (kg m-2) ! initialize mean fluxes do iVar=1,size(averageFlux_meta) - flux_mean%var(iVar)%dat(:) = 0._summa_prec + flux_mean%var(iVar)%dat(:) = 0._rk end do ! associate local variables with information in the data structures @@ -354,7 +354,7 @@ subroutine coupled_em(& ! short-cut to the algorithmic control parameters ! NOTE - temporary assignment of minstep to foce something reasonable - minstep = 10._summa_prec ! mpar_data%var(iLookPARAM%minstep)%dat(1) ! minimum time step (s) + minstep = 10._rk ! mpar_data%var(iLookPARAM%minstep)%dat(1) ! minimum time step (s) maxstep = mpar_data%var(iLookPARAM%maxstep)%dat(1) ! maximum time step (s) !print*, 'minstep, maxstep = ', minstep, maxstep @@ -366,7 +366,7 @@ subroutine coupled_em(& end if ! define the foliage nitrogen factor - diag_data%var(iLookDIAG%scalarFoliageNitrogenFactor)%dat(1) = 1._summa_prec ! foliage nitrogen concentration (1.0 = saturated) + diag_data%var(iLookDIAG%scalarFoliageNitrogenFactor)%dat(1) = 1._rk ! foliage nitrogen concentration (1.0 = saturated) ! save SWE oldSWE = prog_data%var(iLookPROG%scalarSWE)%dat(1) @@ -377,7 +377,7 @@ subroutine coupled_em(& ! ------------------------ ! compute the temperature of the root zone: used in vegetation phenology - diag_data%var(iLookDIAG%scalarRootZoneTemp)%dat(1) = sum(prog_data%var(iLookPROG%mLayerTemp)%dat(nSnow+1:nSnow+nLayersRoots)) / real(nLayersRoots, kind(summa_prec)) + diag_data%var(iLookDIAG%scalarRootZoneTemp)%dat(1) = sum(prog_data%var(iLookPROG%mLayerTemp)%dat(nSnow+1:nSnow+nLayersRoots)) / real(nLayersRoots, kind(rk)) ! remember if we compute the vegetation flux on the previous sub-step computeVegFluxOld = computeVegFlux @@ -421,7 +421,7 @@ subroutine coupled_em(& ! NOTE 3: use maximum per unit leaf area storage capacity for snow (kg m-2) select case(model_decisions(iLookDECISIONS%snowIncept)%iDecision) case(lightSnow); diag_data%var(iLookDIAG%scalarCanopyIceMax)%dat(1) = exposedVAI*mpar_data%var(iLookPARAM%refInterceptCapSnow)%dat(1) - case(stickySnow); diag_data%var(iLookDIAG%scalarCanopyIceMax)%dat(1) = exposedVAI*mpar_data%var(iLookPARAM%refInterceptCapSnow)%dat(1)*4._summa_prec + case(stickySnow); diag_data%var(iLookDIAG%scalarCanopyIceMax)%dat(1) = exposedVAI*mpar_data%var(iLookPARAM%refInterceptCapSnow)%dat(1)*4._rk case default; message=trim(message)//'unable to identify option for maximum branch interception capacity'; err=20; return end select ! identifying option for maximum branch interception capacity !print*, 'diag_data%var(iLookDIAG%scalarCanopyLiqMax)%dat(1) = ', diag_data%var(iLookDIAG%scalarCanopyLiqMax)%dat(1) @@ -454,9 +454,9 @@ subroutine coupled_em(& ! vegetation is completely buried by snow (or no veg exists at all) else - diag_data%var(iLookDIAG%scalarCanopyWetFraction)%dat(1) = 0._summa_prec - dCanopyWetFraction_dWat = 0._summa_prec - dCanopyWetFraction_dT = 0._summa_prec + diag_data%var(iLookDIAG%scalarCanopyWetFraction)%dat(1) = 0._rk + dCanopyWetFraction_dWat = 0._rk + dCanopyWetFraction_dT = 0._rk end if ! *** compute snow albedo... @@ -533,10 +533,10 @@ subroutine coupled_em(& ! NOTE 2: this initialization needs to be done AFTER the call to canopySnow, since canopySnow uses canopy drip drom the previous time step if(.not.computeVegFlux)then flux_data%var(iLookFLUX%scalarThroughfallRain)%dat(1) = flux_data%var(iLookFLUX%scalarRainfall)%dat(1) - flux_data%var(iLookFLUX%scalarCanopyLiqDrainage)%dat(1) = 0._summa_prec + flux_data%var(iLookFLUX%scalarCanopyLiqDrainage)%dat(1) = 0._rk else - flux_data%var(iLookFLUX%scalarThroughfallRain)%dat(1) = 0._summa_prec - flux_data%var(iLookFLUX%scalarCanopyLiqDrainage)%dat(1) = 0._summa_prec + flux_data%var(iLookFLUX%scalarThroughfallRain)%dat(1) = 0._rk + flux_data%var(iLookFLUX%scalarCanopyLiqDrainage)%dat(1) = 0._rk end if ! **************************************************************************************************** @@ -544,7 +544,7 @@ subroutine coupled_em(& ! **************************************************************************************************** ! initialize the length of the sub-step - dt_solv = 0._summa_prec ! length of time step that has been completed (s) + dt_solv = 0._rk ! length of time step that has been completed (s) dt_init = min(data_step,maxstep) ! initial substep length (s) dt_sub = dt_init ! length of substep dtSave = dt_init ! length of substep @@ -762,7 +762,7 @@ subroutine coupled_em(& if(stepFailure)then ! halve step - dt_sub = dtSave/2._summa_prec + dt_sub = dtSave/2._rk ! check that the step is not tiny if(dt_sub < minstep)then @@ -804,13 +804,13 @@ subroutine coupled_em(& scalarCanopyIce = scalarCanopyIce + scalarCanopySublimation*dt_sub ! if removed all ice, take the remaining sublimation from water - if(scalarCanopyIce < 0._summa_prec)then + if(scalarCanopyIce < 0._rk)then scalarCanopyLiq = scalarCanopyLiq + scalarCanopyIce - scalarCanopyIce = 0._summa_prec + scalarCanopyIce = 0._rk endif ! modify fluxes if there is insufficient canopy water to support the converged sublimation rate over the time step dt_sub - if(scalarCanopyLiq < 0._summa_prec)then + if(scalarCanopyLiq < 0._rk)then ! --> superfluous sublimation flux superflousSub = -scalarCanopyLiq/dt_sub ! kg m-2 s-1 superflousNrg = superflousSub*LH_sub ! W m-2 (J m-2 s-1) @@ -818,7 +818,7 @@ subroutine coupled_em(& scalarCanopySublimation = scalarCanopySublimation + superflousSub scalarLatHeatCanopyEvap = scalarLatHeatCanopyEvap + superflousNrg scalarSenHeatCanopy = scalarSenHeatCanopy - superflousNrg - scalarCanopyLiq = 0._summa_prec + scalarCanopyLiq = 0._rk endif end if ! (if computing the vegetation flux) @@ -842,7 +842,7 @@ subroutine coupled_em(& if(mLayerDepth(iSnow) < verySmall)then stepFailure = .true. doLayerMerge = .true. - dt_sub = max(dtSave/2._summa_prec, minstep) + dt_sub = max(dtSave/2._rk, minstep) cycle substeps else stepFailure = .false. @@ -1060,7 +1060,7 @@ subroutine coupled_em(& ! NOTE: need to put the balance checks in the sub-step loop so that we can re-compute if necessary scalarCanopyWatBalError = balanceCanopyWater1 - (balanceCanopyWater0 + (scalarSnowfall - averageThroughfallSnow)*data_step + (scalarRainfall - averageThroughfallRain)*data_step & - averageCanopySnowUnloading*data_step - averageCanopyLiqDrainage*data_step + averageCanopySublimation*data_step + averageCanopyEvaporation*data_step) - if(abs(scalarCanopyWatBalError) > absConvTol_liquid*iden_water*10._summa_prec)then + if(abs(scalarCanopyWatBalError) > absConvTol_liquid*iden_water*10._rk)then print*, '** canopy water balance error:' write(*,'(a,1x,f20.10)') 'data_step = ', data_step write(*,'(a,1x,f20.10)') 'balanceCanopyWater0 = ', balanceCanopyWater0 @@ -1167,7 +1167,7 @@ subroutine coupled_em(& ! check the soil water balance scalarSoilWatBalError = balanceSoilWater1 - (balanceSoilWater0 + (balanceSoilInflux + balanceSoilET - balanceSoilBaseflow - balanceSoilDrainage - totalSoilCompress) ) - if(abs(scalarSoilWatBalError) > absConvTol_liquid*iden_water*10._summa_prec)then ! NOTE: kg m-2, so need coarse tolerance to account for precision issues + if(abs(scalarSoilWatBalError) > absConvTol_liquid*iden_water*10._rk)then ! NOTE: kg m-2, so need coarse tolerance to account for precision issues write(*,*) 'solution method = ', ixSolution write(*,'(a,1x,f20.10)') 'data_step = ', data_step write(*,'(a,1x,f20.10)') 'totalSoilCompress = ', totalSoilCompress @@ -1232,24 +1232,24 @@ subroutine implctMelt(& err,message ) ! intent(out): error control implicit none ! input/output: integrated snowpack properties - real(summa_prec),intent(inout) :: scalarSWE ! snow water equivalent (kg m-2) - real(summa_prec),intent(inout) :: scalarSnowDepth ! snow depth (m) - real(summa_prec),intent(inout) :: scalarSfcMeltPond ! surface melt pond (kg m-2) + real(rk),intent(inout) :: scalarSWE ! snow water equivalent (kg m-2) + real(rk),intent(inout) :: scalarSnowDepth ! snow depth (m) + real(rk),intent(inout) :: scalarSfcMeltPond ! surface melt pond (kg m-2) ! input/output: properties of the upper-most soil layer - real(summa_prec),intent(inout) :: soilTemp ! surface layer temperature (K) - real(summa_prec),intent(inout) :: soilDepth ! surface layer depth (m) - real(summa_prec),intent(inout) :: soilHeatcap ! surface layer volumetric heat capacity (J m-3 K-1) + real(rk),intent(inout) :: soilTemp ! surface layer temperature (K) + real(rk),intent(inout) :: soilDepth ! surface layer depth (m) + real(rk),intent(inout) :: soilHeatcap ! surface layer volumetric heat capacity (J m-3 K-1) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! local variables - real(summa_prec) :: nrgRequired ! energy required to melt all the snow (J m-2) - real(summa_prec) :: nrgAvailable ! energy available to melt the snow (J m-2) - real(summa_prec) :: snwDensity ! snow density (kg m-3) + real(rk) :: nrgRequired ! energy required to melt all the snow (J m-2) + real(rk) :: nrgAvailable ! energy available to melt the snow (J m-2) + real(rk) :: snwDensity ! snow density (kg m-3) ! initialize error control err=0; message='implctMelt/' - if(scalarSWE > 0._summa_prec)then + if(scalarSWE > 0._rk)then ! only melt if temperature of the top soil layer is greater than Tfreeze if(soilTemp > Tfreeze)then ! compute the energy required to melt all the snow (J m-2) @@ -1261,7 +1261,7 @@ subroutine implctMelt(& ! compute the amount of melt, and update SWE (kg m-2) if(nrgAvailable > nrgRequired)then scalarSfcMeltPond = scalarSWE - scalarSWE = 0._summa_prec + scalarSWE = 0._rk else scalarSfcMeltPond = nrgAvailable/LH_fus scalarSWE = scalarSWE - scalarSfcMeltPond @@ -1271,10 +1271,10 @@ subroutine implctMelt(& ! update temperature of the top soil layer (K) soilTemp = soilTemp - (LH_fus*scalarSfcMeltPond/soilDepth)/soilHeatcap else ! melt is zero if the temperature of the top soil layer is less than Tfreeze - scalarSfcMeltPond = 0._summa_prec ! kg m-2 + scalarSfcMeltPond = 0._rk ! kg m-2 end if ! (if the temperature of the top soil layer is greater than Tfreeze) else ! melt is zero if the "snow without a layer" does not exist - scalarSfcMeltPond = 0._summa_prec ! kg m-2 + scalarSfcMeltPond = 0._rk ! kg m-2 end if ! (if the "snow without a layer" exists) end subroutine implctMelt diff --git a/build/source/engine/derivforce.f90 b/build/source/engine/derivforce.f90 index b607207dc..8b0033632 100755 --- a/build/source/engine/derivforce.f90 +++ b/build/source/engine/derivforce.f90 @@ -74,8 +74,8 @@ subroutine derivforce(time_data,forc_data,attr_data,mpar_data,prog_data,diag_dat implicit none ! input variables integer(i4b), intent(in) :: time_data(:) ! vector of time data for a given time step - real(summa_prec), intent(inout) :: forc_data(:) ! vector of forcing data for a given time step - real(summa_prec), intent(in) :: attr_data(:) ! vector of model attributes + real(rk), intent(inout) :: forc_data(:) ! vector of forcing data for a given time step + real(rk), intent(in) :: attr_data(:) ! vector of model attributes type(var_dlength),intent(in) :: mpar_data ! vector of model parameters type(var_dlength),intent(in) :: prog_data ! data structure of model prognostic variables for a local HRU ! output variables @@ -86,33 +86,33 @@ subroutine derivforce(time_data,forc_data,attr_data,mpar_data,prog_data,diag_dat ! local time integer(i4b) :: jyyy,jm,jd ! year, month, day integer(i4b) :: jh,jmin ! hour, minute - real(summa_prec) :: dsec ! double precision seconds (not used) - real(summa_prec) :: timeOffset ! time offset from Grenwich (days) - real(summa_prec) :: julianTime ! local julian time + real(rk) :: dsec ! double precision seconds (not used) + real(rk) :: timeOffset ! time offset from Grenwich (days) + real(rk) :: julianTime ! local julian time ! cosine of the solar zenith angle - real(summa_prec) :: ahour ! hour at start of time step - real(summa_prec) :: dataStep ! data step (hours) - real(summa_prec),parameter :: slope=0._summa_prec ! terrain slope (assume flat) - real(summa_prec),parameter :: azimuth=0._summa_prec ! terrain azimuth (assume zero) - real(summa_prec) :: hri ! average radiation index over time step DT + real(rk) :: ahour ! hour at start of time step + real(rk) :: dataStep ! data step (hours) + real(rk),parameter :: slope=0._rk ! terrain slope (assume flat) + real(rk),parameter :: azimuth=0._rk ! terrain azimuth (assume zero) + real(rk) :: hri ! average radiation index over time step DT ! general local variables character(len=256) :: cmessage ! error message for downwind routine integer(i4b),parameter :: nBands=2 ! number of spectral bands - real(summa_prec),parameter :: valueMissing=-9999._summa_prec ! missing value - real(summa_prec),parameter :: co2Factor=355.e-6_summa_prec ! empirical factor to obtain partial pressure of co2 - real(summa_prec),parameter :: o2Factor=0.209_summa_prec ! empirical factor to obtain partial pressure of o2 - real(summa_prec),parameter :: minMeasHeight=1._summa_prec ! minimum measurement height (m) - real(summa_prec) :: relhum ! relative humidity (-) - real(summa_prec) :: fracrain ! fraction of precipitation that falls as rain - real(summa_prec) :: maxFrozenSnowTemp ! maximum temperature of snow when the snow is predominantely frozen (K) - real(summa_prec),parameter :: unfrozenLiq=0.01_summa_prec ! unfrozen liquid water used to compute maxFrozenSnowTemp (-) - real(summa_prec),parameter :: eps=epsilon(fracrain) ! a number that is almost negligible - real(summa_prec) :: Tmin,Tmax ! minimum and maximum wet bulb temperature in the time step (K) - real(summa_prec),parameter :: pomNewSnowDenMax=150._summa_prec ! Upper limit for new snow density limit in Hedstrom and Pomeroy 1998. 150 was used because at was the highest observed density at air temperatures used in this study. See Figure 4 of Hedstrom and Pomeroy (1998). - real(summa_prec),parameter :: andersonWarmDenLimit=2._summa_prec ! Upper air temperature limit in Anderson (1976) new snow density (C) - real(summa_prec),parameter :: andersonColdDenLimit=15._summa_prec! Lower air temperature limit in Anderson (1976) new snow density (C) - real(summa_prec),parameter :: andersonDenScal=1.5_summa_prec ! Scalar parameter in Anderson (1976) new snow density function (-) - real(summa_prec),parameter :: pahautDenWindScal=0.5_summa_prec ! Scalar parameter for wind impacts on density using Pahaut (1976) function (-) + real(rk),parameter :: valueMissing=-9999._rk ! missing value + real(rk),parameter :: co2Factor=355.e-6_rk ! empirical factor to obtain partial pressure of co2 + real(rk),parameter :: o2Factor=0.209_rk ! empirical factor to obtain partial pressure of o2 + real(rk),parameter :: minMeasHeight=1._rk ! minimum measurement height (m) + real(rk) :: relhum ! relative humidity (-) + real(rk) :: fracrain ! fraction of precipitation that falls as rain + real(rk) :: maxFrozenSnowTemp ! maximum temperature of snow when the snow is predominantely frozen (K) + real(rk),parameter :: unfrozenLiq=0.01_rk ! unfrozen liquid water used to compute maxFrozenSnowTemp (-) + real(rk),parameter :: eps=epsilon(fracrain) ! a number that is almost negligible + real(rk) :: Tmin,Tmax ! minimum and maximum wet bulb temperature in the time step (K) + real(rk),parameter :: pomNewSnowDenMax=150._rk ! Upper limit for new snow density limit in Hedstrom and Pomeroy 1998. 150 was used because at was the highest observed density at air temperatures used in this study. See Figure 4 of Hedstrom and Pomeroy (1998). + real(rk),parameter :: andersonWarmDenLimit=2._rk ! Upper air temperature limit in Anderson (1976) new snow density (C) + real(rk),parameter :: andersonColdDenLimit=15._rk! Lower air temperature limit in Anderson (1976) new snow density (C) + real(rk),parameter :: andersonDenScal=1.5_rk ! Scalar parameter in Anderson (1976) new snow density function (-) + real(rk),parameter :: pahautDenWindScal=0.5_rk ! Scalar parameter for wind impacts on density using Pahaut (1976) function (-) ! ************************************************************************************************ ! associate local variables with the information in the data structures associate(& @@ -204,13 +204,13 @@ subroutine derivforce(time_data,forc_data,attr_data,mpar_data,prog_data,diag_dat select case(trim(NC_TIME_ZONE)) ! Time zone information from NetCDF file case('ncTime') - timeOffset = longitude/360._summa_prec - tmZoneOffsetFracDay ! time offset in days + timeOffset = longitude/360._rk - tmZoneOffsetFracDay ! time offset in days ! All times in UTC case('utcTime') - timeOffset = longitude/360._summa_prec ! time offset in days + timeOffset = longitude/360._rk ! time offset in days ! All times local case('localTime') - timeOffset = 0._summa_prec ! time offset in days + timeOffset = 0._rk ! time offset in days case default; message=trim(message)//'unable to identify option for tmZoneInfo'; err=20; return end select ! identifying option tmZoneInfo @@ -232,7 +232,7 @@ subroutine derivforce(time_data,forc_data,attr_data,mpar_data,prog_data,diag_dat ! compute the decimal hour at the start of the time step dataStep = data_step/secprhour ! time step (hours) - ahour = real(jh,kind(summa_prec)) + real(jmin,kind(summa_prec))/minprhour - data_step/secprhour ! decimal hour (start of the step) + ahour = real(jh,kind(rk)) + real(jmin,kind(rk))/minprhour - data_step/secprhour ! decimal hour (start of the step) ! compute the cosine of the solar zenith angle call clrsky_rad(jm,jd,ahour,dataStep, & ! intent(in): time variables @@ -241,19 +241,19 @@ subroutine derivforce(time_data,forc_data,attr_data,mpar_data,prog_data,diag_dat !write(*,'(a,1x,4(i2,1x),3(f9.3,1x))') 'im,id,ih,imin,ahour,dataStep,cosZenith = ', & ! ensure solar radiation is non-negative - if(SWRadAtm < 0._summa_prec) SWRadAtm = 0._summa_prec + if(SWRadAtm < 0._rk) SWRadAtm = 0._rk ! compute the fraction of direct radiation using the parameterization of Nijssen and Lettenmaier (1999) - if(cosZenith > 0._summa_prec)then + if(cosZenith > 0._rk)then scalarFractionDirect = Frad_direct*cosZenith/(cosZenith + directScale) else - scalarFractionDirect = 0._summa_prec + scalarFractionDirect = 0._rk end if ! compute direct shortwave radiation, in the visible and near-infra-red part of the spectrum spectralIncomingDirect(1) = SWRadAtm*scalarFractionDirect*Frad_vis ! (direct vis) - spectralIncomingDirect(2) = SWRadAtm*scalarFractionDirect*(1._summa_prec - Frad_vis) ! (direct nir) + spectralIncomingDirect(2) = SWRadAtm*scalarFractionDirect*(1._rk - Frad_vis) ! (direct nir) ! compute diffuse shortwave radiation, in the visible and near-infra-red part of the spectrum - spectralIncomingDiffuse(1) = SWRadAtm*(1._summa_prec - scalarFractionDirect)*Frad_vis ! (diffuse vis) - spectralIncomingDiffuse(2) = SWRadAtm*(1._summa_prec - scalarFractionDirect)*(1._summa_prec - Frad_vis) ! (diffuse nir) + spectralIncomingDiffuse(1) = SWRadAtm*(1._rk - scalarFractionDirect)*Frad_vis ! (diffuse vis) + spectralIncomingDiffuse(2) = SWRadAtm*(1._rk - scalarFractionDirect)*(1._rk - Frad_vis) ! (diffuse nir) ! ensure wind speed is above a prescribed minimum value if(windspd < minwind) windspd=minwind @@ -261,8 +261,8 @@ subroutine derivforce(time_data,forc_data,attr_data,mpar_data,prog_data,diag_dat ! compute relative humidity (-) relhum = SPHM2RELHM(spechum, airpres, airtemp) ! if relative humidity exceeds saturation, then set relative and specific humidity to saturation - if(relhum > 1._summa_prec)then - relhum = 1._summa_prec + if(relhum > 1._rk)then + relhum = 1._rk spechum = RELHM2SPHM(relhum, airpres, airtemp) end if @@ -277,17 +277,17 @@ subroutine derivforce(time_data,forc_data,attr_data,mpar_data,prog_data,diag_dat maxFrozenSnowTemp = templiquid(unfrozenLiq,fc_param) ! compute fraction of rain and temperature of fresh snow - Tmin = twetbulb - tempRangeTimestep/2._summa_prec - Tmax = twetbulb + tempRangeTimestep/2._summa_prec + Tmin = twetbulb - tempRangeTimestep/2._rk + Tmax = twetbulb + tempRangeTimestep/2._rk if(Tmax < tempCritRain)then - fracrain = 0._summa_prec + fracrain = 0._rk snowfallTemp = twetbulb elseif(Tmin > tempCritRain)then - fracrain = 1._summa_prec + fracrain = 1._rk snowfallTemp = maxFrozenSnowTemp else fracrain = (Tmax - tempCritRain)/(Tmax - Tmin) - snowfallTemp = 0.5_summa_prec*(Tmin + maxFrozenSnowTemp) + snowfallTemp = 0.5_rk*(Tmin + maxFrozenSnowTemp) end if !write(*,'(a,1x,10(f20.10,1x))') 'Tmin, twetbulb, tempRangeTimestep, tempCritRain = ', & ! Tmin, twetbulb, tempRangeTimestep, tempCritRain @@ -298,12 +298,12 @@ subroutine derivforce(time_data,forc_data,attr_data,mpar_data,prog_data,diag_dat ! ensure precipitation rate can be resolved by the data model if(pptrate 0.1_summa_prec)then ! log10(0.1) = -1 - kerstenNum = log10(relativeSat) + 1._summa_prec + if(relativeSat > 0.1_rk)then ! log10(0.1) = -1 + kerstenNum = log10(relativeSat) + 1._rk else - kerstenNum = 0._summa_prec ! dry thermal conductivity + kerstenNum = 0._rk ! dry thermal conductivity endif ! ...and, compute the thermal conductivity - mLayerThermalC(iLayer) = kerstenNum*lambda_wet + (1._summa_prec - kerstenNum)*lambda_drysoil + mLayerThermalC(iLayer) = kerstenNum*lambda_wet + (1._rk - kerstenNum)*lambda_drysoil ! ** mixture of constituents case(mixConstit) - mLayerThermalC(iLayer) = thCond_soil(iSoil) * ( 1._summa_prec - theta_sat(iSoil) ) + & ! soil component + mLayerThermalC(iLayer) = thCond_soil(iSoil) * ( 1._rk - theta_sat(iSoil) ) + & ! soil component lambda_ice * mLayerVolFracIce(iLayer) + & ! ice component lambda_water * mLayerVolFracLiq(iLayer) + & ! liquid water component lambda_air * mLayerVolFracAir(iLayer) ! air component ! ** test case for the mizoguchi lab experiment, Hansson et al. VZJ 2004 case(hanssonVZJ) - fArg = 1._summa_prec + f1*mLayerVolFracIce(iLayer)**f2 + fArg = 1._rk + f1*mLayerVolFracIce(iLayer)**f2 xArg = mLayerVolFracLiq(iLayer) + fArg*mLayerVolFracIce(iLayer) mLayerThermalC(iLayer) = c1 + c2*xArg + (c1 - c4)*exp(-(c3*xArg)**c5) @@ -315,7 +315,7 @@ subroutine diagn_evar(& ! special case of hansson if(ixThCondSoil==hanssonVZJ)then - iLayerThermalC(0) = 28._summa_prec*(0.5_summa_prec*(iLayerHeight(1) - iLayerHeight(0))) + iLayerThermalC(0) = 28._rk*(0.5_rk*(iLayerHeight(1) - iLayerHeight(0))) else iLayerThermalC(0) = mLayerThermalC(1) end if diff --git a/build/source/engine/eval8summa.f90 b/build/source/engine/eval8summa.f90 index 03c9fb904..7c0d55f17 100755 --- a/build/source/engine/eval8summa.f90 +++ b/build/source/engine/eval8summa.f90 @@ -153,7 +153,7 @@ subroutine eval8summa(& ! -------------------------------------------------------------------------------------------------------------------------------- ! -------------------------------------------------------------------------------------------------------------------------------- ! input: model control - real(summa_prec),intent(in) :: dt ! length of the time step (seconds) + real(rk),intent(in) :: dt ! length of the time step (seconds) integer(i4b),intent(in) :: nSnow ! number of snow layers integer(i4b),intent(in) :: nSoil ! number of soil layers integer(i4b),intent(in) :: nLayers ! total number of layers @@ -164,9 +164,9 @@ subroutine eval8summa(& logical(lgt),intent(in) :: computeVegFlux ! flag to indicate if computing fluxes over vegetation logical(lgt),intent(in) :: scalarSolution ! flag to denote if implementing the scalar solution ! input: state vectors - real(summa_prec),intent(in) :: stateVecTrial(:) ! model state vector - real(summa_prec),intent(in) :: fScale(:) ! function scaling vector - real(summa_prec),intent(in) :: sMul(:) ! NOTE: qp ! state vector multiplier (used in the residual calculations) + real(rk),intent(in) :: stateVecTrial(:) ! model state vector + real(rk),intent(in) :: fScale(:) ! function scaling vector + real(rk),intent(in) :: sMul(:) ! NOTE: qp ! state vector multiplier (used in the residual calculations) ! input: data structures type(model_options),intent(in) :: model_decisions(:) ! model decisions type(var_i), intent(in) :: type_data ! type of vegetation and soil @@ -182,13 +182,13 @@ subroutine eval8summa(& type(var_dlength),intent(inout) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables ! input-output: baseflow integer(i4b),intent(inout) :: ixSaturation ! index of the lowest saturated layer (NOTE: only computed on the first iteration) - real(summa_prec),intent(out) :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) + real(rk),intent(out) :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) ! output: flux and residual vectors logical(lgt),intent(out) :: feasible ! flag to denote the feasibility of the solution - real(summa_prec),intent(out) :: fluxVec(:) ! flux vector - real(summa_prec),intent(out) :: resSink(:) ! sink terms on the RHS of the flux equation - real(summa_prec),intent(out) :: resVec(:) ! NOTE: qp ! residual vector - real(summa_prec),intent(out) :: fEval ! function evaluation + real(rk),intent(out) :: fluxVec(:) ! flux vector + real(rk),intent(out) :: resSink(:) ! sink terms on the RHS of the flux equation + real(rk),intent(out) :: resVec(:) ! NOTE: qp ! residual vector + real(rk),intent(out) :: fEval ! function evaluation ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message @@ -196,29 +196,29 @@ subroutine eval8summa(& ! local variables ! -------------------------------------------------------------------------------------------------------------------------------- ! state variables - real(summa_prec) :: scalarCanairTempTrial ! trial value for temperature of the canopy air space (K) - real(summa_prec) :: scalarCanopyTempTrial ! trial value for temperature of the vegetation canopy (K) - real(summa_prec) :: scalarCanopyWatTrial ! trial value for liquid water storage in the canopy (kg m-2) - real(summa_prec),dimension(nLayers) :: mLayerTempTrial ! trial value for temperature of layers in the snow and soil domains (K) - real(summa_prec),dimension(nLayers) :: mLayerVolFracWatTrial ! trial value for volumetric fraction of total water (-) - real(summa_prec),dimension(nSoil) :: mLayerMatricHeadTrial ! trial value for total water matric potential (m) - real(summa_prec),dimension(nSoil) :: mLayerMatricHeadLiqTrial ! trial value for liquid water matric potential (m) - real(summa_prec) :: scalarAquiferStorageTrial ! trial value of storage of water in the aquifer (m) + real(rk) :: scalarCanairTempTrial ! trial value for temperature of the canopy air space (K) + real(rk) :: scalarCanopyTempTrial ! trial value for temperature of the vegetation canopy (K) + real(rk) :: scalarCanopyWatTrial ! trial value for liquid water storage in the canopy (kg m-2) + real(rk),dimension(nLayers) :: mLayerTempTrial ! trial value for temperature of layers in the snow and soil domains (K) + real(rk),dimension(nLayers) :: mLayerVolFracWatTrial ! trial value for volumetric fraction of total water (-) + real(rk),dimension(nSoil) :: mLayerMatricHeadTrial ! trial value for total water matric potential (m) + real(rk),dimension(nSoil) :: mLayerMatricHeadLiqTrial ! trial value for liquid water matric potential (m) + real(rk) :: scalarAquiferStorageTrial ! trial value of storage of water in the aquifer (m) ! diagnostic variables - real(summa_prec) :: scalarCanopyLiqTrial ! trial value for mass of liquid water on the vegetation canopy (kg m-2) - real(summa_prec) :: scalarCanopyIceTrial ! trial value for mass of ice on the vegetation canopy (kg m-2) - real(summa_prec),dimension(nLayers) :: mLayerVolFracLiqTrial ! trial value for volumetric fraction of liquid water (-) - real(summa_prec),dimension(nLayers) :: mLayerVolFracIceTrial ! trial value for volumetric fraction of ice (-) + real(rk) :: scalarCanopyLiqTrial ! trial value for mass of liquid water on the vegetation canopy (kg m-2) + real(rk) :: scalarCanopyIceTrial ! trial value for mass of ice on the vegetation canopy (kg m-2) + real(rk),dimension(nLayers) :: mLayerVolFracLiqTrial ! trial value for volumetric fraction of liquid water (-) + real(rk),dimension(nLayers) :: mLayerVolFracIceTrial ! trial value for volumetric fraction of ice (-) ! other local variables integer(i4b) :: iLayer ! index of model layer in the snow+soil domain integer(i4b) :: jState(1) ! index of model state for the scalar solution within the soil domain integer(i4b) :: ixBeg,ixEnd ! index of indices for the soil compression routine integer(i4b),parameter :: ixVegVolume=1 ! index of the desired vegetation control volumne (currently only one veg layer) - real(summa_prec) :: xMin,xMax ! minimum and maximum values for water content - real(summa_prec) :: scalarCanopyHydTrial ! trial value for mass of water on the vegetation canopy (kg m-2) - real(summa_prec),parameter :: canopyTempMax=500._summa_prec ! expected maximum value for the canopy temperature (K) - real(summa_prec),dimension(nLayers) :: mLayerVolFracHydTrial ! trial value for volumetric fraction of water (-), general vector merged from Wat and Liq - real(summa_prec),dimension(nState) :: rVecScaled ! scaled residual vector + real(rk) :: xMin,xMax ! minimum and maximum values for water content + real(rk) :: scalarCanopyHydTrial ! trial value for mass of water on the vegetation canopy (kg m-2) + real(rk),parameter :: canopyTempMax=500._rk ! expected maximum value for the canopy temperature (K) + real(rk),dimension(nLayers) :: mLayerVolFracHydTrial ! trial value for volumetric fraction of water (-), general vector merged from Wat and Liq + real(rk),dimension(nState) :: rVecScaled ! scaled residual vector character(LEN=256) :: cmessage ! error message of downwind routine ! -------------------------------------------------------------------------------------------------------------------------------- ! association to variables in the data structures @@ -281,7 +281,7 @@ subroutine eval8summa(& ! check canopy liquid water is not negative if(ixVegHyd/=integerMissing)then - if(stateVecTrial(ixVegHyd) < 0._summa_prec) feasible=.false. + if(stateVecTrial(ixVegHyd) < 0._rk) feasible=.false. end if ! check snow temperature is below freezing @@ -299,12 +299,12 @@ subroutine eval8summa(& if (layerType(iLayer) == iname_soil) then xMin = theta_sat(iLayer-nSnow) else - xMin = 0._summa_prec + xMin = 0._rk endif ! --> maximum select case( layerType(iLayer) ) - case(iname_snow); xMax = merge(iden_ice, 1._summa_prec - mLayerVolFracIce(iLayer), ixHydType(iLayer)==iname_watLayer) + case(iname_snow); xMax = merge(iden_ice, 1._rk - mLayerVolFracIce(iLayer), ixHydType(iLayer)==iname_watLayer) case(iname_soil); xMax = merge(theta_sat(iLayer-nSnow), theta_sat(iLayer-nSnow) - mLayerVolFracIce(iLayer), ixHydType(iLayer)==iname_watLayer) end select @@ -517,8 +517,8 @@ subroutine eval8summa(& if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! (check for errors) ! compute the function evaluation - rVecScaled = fScale(:)*real(resVec(:), summa_prec) ! scale the residual vector (NOTE: residual vector is in quadruple precision) - fEval = 0.5_summa_prec*dot_product(rVecScaled,rVecScaled) + rVecScaled = fScale(:)*real(resVec(:), rk) ! scale the residual vector (NOTE: residual vector is in quadruple precision) + fEval = 0.5_rk*dot_product(rVecScaled,rVecScaled) ! end association with the information in the data structures end associate diff --git a/build/source/engine/expIntegral.f90 b/build/source/engine/expIntegral.f90 index 0eed6fa5f..645ef5a29 100755 --- a/build/source/engine/expIntegral.f90 +++ b/build/source/engine/expIntegral.f90 @@ -11,32 +11,32 @@ module expIntegral_module ! From UEB-Veg ! Computes the exponential integral function for the given value FUNCTION EXPINT (LAI) - real(summa_prec) LAI - real(summa_prec) EXPINT - real(summa_prec) a0,a1,a2,a3,a4,a5,b1,b2,b3,b4 - real(summa_prec),parameter :: verySmall=tiny(1.0_summa_prec) ! a very small number + real(rk) LAI + real(rk) EXPINT + real(rk) a0,a1,a2,a3,a4,a5,b1,b2,b3,b4 + real(rk),parameter :: verySmall=tiny(1.0_rk) ! a very small number IF (LAI < verySmall)THEN - EXPINT=1._summa_prec + EXPINT=1._rk ELSEIF (LAI.LE.1.0) THEN - a0=-.57721566_summa_prec - a1=.99999193_summa_prec - a2=-.24991055_summa_prec - a3=.05519968_summa_prec - a4=-.00976004_summa_prec - a5=.00107857_summa_prec + a0=-.57721566_rk + a1=.99999193_rk + a2=-.24991055_rk + a3=.05519968_rk + a4=-.00976004_rk + a5=.00107857_rk EXPINT = a0+a1*LAI+a2*LAI**2+a3*LAI**3+a4*LAI**4+a5*LAI**5 - log(LAI) ELSE - a1=8.5733287401_summa_prec - a2=18.0590169730_summa_prec - a3=8.6347637343_summa_prec - a4=.2677737343_summa_prec - b1=9.5733223454_summa_prec - b2=25.6329561486_summa_prec - b3=21.0996530827_summa_prec - b4=3.9584969228_summa_prec + a1=8.5733287401_rk + a2=18.0590169730_rk + a3=8.6347637343_rk + a4=.2677737343_rk + b1=9.5733223454_rk + b2=25.6329561486_rk + b3=21.0996530827_rk + b4=3.9584969228_rk EXPINT=(LAI**4+a1*LAI**3+a2*LAI**2+a3*LAI+a4)/ & ((LAI**4+b1*LAI**3+b2*LAI**2+b3*LAI+b4)*LAI*exp(LAI)) diff --git a/build/source/engine/f2008funcs.f90 b/build/source/engine/f2008funcs.f90 index 97515c885..52ae947e5 100755 --- a/build/source/engine/f2008funcs.f90 +++ b/build/source/engine/f2008funcs.f90 @@ -75,11 +75,11 @@ end function findIndex subroutine cloneStruc_rv(dataVec,lowerBound,source,mold,err,message) implicit none ! input-output: data vector for allocation/population - real(summa_prec),intent(inout),allocatable :: dataVec(:) ! data vector + real(rk),intent(inout),allocatable :: dataVec(:) ! data vector ! input integer(i4b),intent(in) :: lowerBound ! lower bound - real(summa_prec),intent(in),optional :: source(lowerBound:) ! dataVec = shape of source + elements of source - real(summa_prec),intent(in),optional :: mold(lowerBound:) ! dataVec = shape of mold + real(rk),intent(in),optional :: source(lowerBound:) ! dataVec = shape of source + elements of source + real(rk),intent(in),optional :: mold(lowerBound:) ! dataVec = shape of mold ! error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message diff --git a/build/source/engine/ffile_info.f90 b/build/source/engine/ffile_info.f90 index 3f6d73252..0a19efbff 100755 --- a/build/source/engine/ffile_info.f90 +++ b/build/source/engine/ffile_info.f90 @@ -74,7 +74,7 @@ subroutine ffile_info(nGRU,err,message) integer(i4b) :: nForcing ! number of forcing variables integer(i4b) :: iGRU,localHRU_ix ! index of GRU and HRU integer(8) :: ncHruId(1) ! hruID from the forcing files - real(summa_prec) :: dataStep_iFile ! data step for a given forcing data file + real(rk) :: dataStep_iFile ! data step for a given forcing data file logical(lgt) :: xist ! .TRUE. if the file exists ! Start procedure here diff --git a/build/source/engine/getVectorz.f90 b/build/source/engine/getVectorz.f90 index 5ebd36a54..5711d4342 100755 --- a/build/source/engine/getVectorz.f90 +++ b/build/source/engine/getVectorz.f90 @@ -97,7 +97,7 @@ module getVectorz_module public::varExtract ! common variables -real(summa_prec),parameter :: valueMissing=-9999._summa_prec ! missing value +real(rk),parameter :: valueMissing=-9999._rk ! missing value contains @@ -120,7 +120,7 @@ subroutine popStateVec(& type(var_dlength),intent(in) :: diag_data ! diagnostic variables for a local HRU type(var_ilength),intent(in) :: indx_data ! indices defining model states and layers ! output - real(summa_prec),intent(out) :: stateVec(:) ! model state vector (mixed units) + real(rk),intent(out) :: stateVec(:) ! model state vector (mixed units) integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! -------------------------------------------------------------------------------------------------------------------------------- @@ -266,10 +266,10 @@ subroutine getScaling(& type(var_dlength),intent(in) :: diag_data ! diagnostic variables for a local HRU type(var_ilength),intent(in) :: indx_data ! indices defining model states and layers ! output: state vectors - real(summa_prec),intent(out) :: fScale(:) ! function scaling vector (mixed units) - real(summa_prec),intent(out) :: xScale(:) ! variable scaling vector (mixed units) - real(summa_prec),intent(out) :: sMul(:) ! NOTE: qp ! multiplier for state vector (used in the residual calculations) - real(summa_prec),intent(out) :: dMat(:) ! diagonal of the Jacobian matrix (excludes fluxes) + real(rk),intent(out) :: fScale(:) ! function scaling vector (mixed units) + real(rk),intent(out) :: xScale(:) ! variable scaling vector (mixed units) + real(rk),intent(out) :: sMul(:) ! NOTE: qp ! multiplier for state vector (used in the residual calculations) + real(rk),intent(out) :: dMat(:) ! diagonal of the Jacobian matrix (excludes fluxes) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message @@ -277,12 +277,12 @@ subroutine getScaling(& ! local variables ! -------------------------------------------------------------------------------------------------------------------------------- ! scaling parameters - real(summa_prec),parameter :: fScaleLiq=0.01_summa_prec ! func eval: characteristic scale for volumetric liquid water content (-) - real(summa_prec),parameter :: fScaleMat=10._summa_prec ! func eval: characteristic scale for matric head (m) - real(summa_prec),parameter :: fScaleNrg=1000000._summa_prec ! func eval: characteristic scale for energy (J m-3) - real(summa_prec),parameter :: xScaleLiq=0.1_summa_prec ! state var: characteristic scale for volumetric liquid water content (-) - real(summa_prec),parameter :: xScaleMat=10._summa_prec ! state var: characteristic scale for matric head (m) - real(summa_prec),parameter :: xScaleTemp=1._summa_prec ! state var: characteristic scale for temperature (K) + real(rk),parameter :: fScaleLiq=0.01_rk ! func eval: characteristic scale for volumetric liquid water content (-) + real(rk),parameter :: fScaleMat=10._rk ! func eval: characteristic scale for matric head (m) + real(rk),parameter :: fScaleNrg=1000000._rk ! func eval: characteristic scale for energy (J m-3) + real(rk),parameter :: xScaleLiq=0.1_rk ! state var: characteristic scale for volumetric liquid water content (-) + real(rk),parameter :: xScaleMat=10._rk ! state var: characteristic scale for matric head (m) + real(rk),parameter :: xScaleTemp=1._rk ! state var: characteristic scale for temperature (K) ! state subsets integer(i4b) :: iLayer ! index of layer within the snow+soil domain integer(i4b) :: ixStateSubset ! index within the state subset @@ -320,32 +320,32 @@ subroutine getScaling(& ! define the function and variable scaling factors for energy where(ixStateType_subset==iname_nrgCanair .or. ixStateType_subset==iname_nrgCanopy .or. ixStateType_subset==iname_nrgLayer) - fScale = 1._summa_prec / fScaleNrg ! 1/(J m-3) - xScale = 1._summa_prec ! K + fScale = 1._rk / fScaleNrg ! 1/(J m-3) + xScale = 1._rk ! K endwhere ! define the function and variable scaling factors for water on the vegetation canopy where(ixStateType_subset==iname_watCanopy .or. ixStateType_subset==iname_liqCanopy) - fScale = 1._summa_prec / (fScaleLiq*canopyDepth*iden_water) ! 1/(kg m-2) - xScale = 1._summa_prec ! (kg m-2) + fScale = 1._rk / (fScaleLiq*canopyDepth*iden_water) ! 1/(kg m-2) + xScale = 1._rk ! (kg m-2) endwhere ! define the function and variable scaling factors for water in the snow+soil domain where(ixStateType_subset==iname_watLayer .or. ixStateType_subset==iname_liqLayer) - fScale = 1._summa_prec / fScaleLiq ! (-) - xScale = 1._summa_prec ! (-) + fScale = 1._rk / fScaleLiq ! (-) + xScale = 1._rk ! (-) end where ! define the function and variable scaling factors for water in the snow+soil domain where(ixStateType_subset==iname_matLayer .or. ixStateType_subset==iname_lmpLayer) - fScale = 1._summa_prec / fScaleLiq ! (-) - xScale = 1._summa_prec ! (m) + fScale = 1._rk / fScaleLiq ! (-) + xScale = 1._rk ! (m) end where ! define the function and variable scaling factors for water storage in the aquifer where(ixStateType_subset==iname_watAquifer) - fScale = 1._summa_prec - xScale = 1._summa_prec + fScale = 1._rk + xScale = 1._rk endwhere ! ----- @@ -357,8 +357,8 @@ subroutine getScaling(& where(ixStateType_subset==iname_nrgCanair) sMul = Cp_air*iden_air ! volumetric heat capacity of air (J m-3 K-1) where(ixStateType_subset==iname_nrgCanopy) sMul = volHeatCapVeg ! volumetric heat capacity of the vegetation (J m-3 K-1) - where(ixStateType_subset==iname_watCanopy) sMul = 1._summa_prec ! nothing else on the left hand side - where(ixStateType_subset==iname_liqCanopy) sMul = 1._summa_prec ! nothing else on the left hand side + where(ixStateType_subset==iname_watCanopy) sMul = 1._rk ! nothing else on the left hand side + where(ixStateType_subset==iname_liqCanopy) sMul = 1._rk ! nothing else on the left hand side ! compute terms in the Jacobian for vegetation (excluding fluxes) ! NOTE: This is computed outside the iteration loop because it does not depend on state variables @@ -366,8 +366,8 @@ subroutine getScaling(& ! NOTE: Use the "where" statement to generalize to multiple canopy layers (currently one canopy layer) where(ixStateType_subset==iname_nrgCanair) dMat = Cp_air*iden_air ! volumetric heat capacity of air (J m-3 K-1) where(ixStateType_subset==iname_nrgCanopy) dMat = realMissing ! populated within the iteration loop - where(ixStateType_subset==iname_watCanopy) dMat = 1._summa_prec ! nothing else on the left hand side - where(ixStateType_subset==iname_liqCanopy) dMat = 1._summa_prec ! nothing else on the left hand side + where(ixStateType_subset==iname_watCanopy) dMat = 1._rk ! nothing else on the left hand side + where(ixStateType_subset==iname_liqCanopy) dMat = 1._rk ! nothing else on the left hand side ! define the energy multiplier and diagonal elements for the state vector for residual calculations (snow-soil domain) if(nSnowSoilNrg>0)then @@ -382,15 +382,15 @@ subroutine getScaling(& if(nSnowSoilHyd>0)then do concurrent (iLayer=1:nLayers,ixSnowSoilHyd(iLayer)/=integerMissing) ! (loop through non-missing energy state variables in the snow+soil domain) ixStateSubset = ixSnowSoilHyd(iLayer) ! index within the state vector - sMul(ixStateSubset) = 1._summa_prec ! state multiplier = 1 (nothing else on the left-hand-side) - dMat(ixStateSubset) = 1._summa_prec ! diagonal element = 1 (nothing else on the left-hand-side) + sMul(ixStateSubset) = 1._rk ! state multiplier = 1 (nothing else on the left-hand-side) + dMat(ixStateSubset) = 1._rk ! diagonal element = 1 (nothing else on the left-hand-side) end do ! looping through non-missing energy state variables in the snow+soil domain endif ! define the scaling factor and diagonal elements for the aquifer where(ixStateType_subset==iname_watAquifer) - sMul = 1._summa_prec - dMat = 1._summa_prec + sMul = 1._rk + dMat = 1._rk endwhere ! ------------------------------------------------------------------------------------------ @@ -431,25 +431,25 @@ subroutine varExtract(& ! -------------------------------------------------------------------------------------------------------------------------------- implicit none ! input - real(summa_prec),intent(in) :: stateVec(:) ! model state vector (mixed units) + real(rk),intent(in) :: stateVec(:) ! model state vector (mixed units) type(var_dlength),intent(in) :: diag_data ! diagnostic variables for a local HRU type(var_dlength),intent(in) :: prog_data ! prognostic variables for a local HRU type(var_ilength),intent(in) :: indx_data ! indices defining model states and layers ! output: variables for the vegetation canopy - real(summa_prec),intent(out) :: scalarCanairTempTrial ! trial value of canopy air temperature (K) - real(summa_prec),intent(out) :: scalarCanopyTempTrial ! trial value of canopy temperature (K) - real(summa_prec),intent(out) :: scalarCanopyWatTrial ! trial value of canopy total water (kg m-2) - real(summa_prec),intent(out) :: scalarCanopyLiqTrial ! trial value of canopy liquid water (kg m-2) - real(summa_prec),intent(out) :: scalarCanopyIceTrial ! trial value of canopy ice content (kg m-2) + real(rk),intent(out) :: scalarCanairTempTrial ! trial value of canopy air temperature (K) + real(rk),intent(out) :: scalarCanopyTempTrial ! trial value of canopy temperature (K) + real(rk),intent(out) :: scalarCanopyWatTrial ! trial value of canopy total water (kg m-2) + real(rk),intent(out) :: scalarCanopyLiqTrial ! trial value of canopy liquid water (kg m-2) + real(rk),intent(out) :: scalarCanopyIceTrial ! trial value of canopy ice content (kg m-2) ! output: variables for the snow-soil domain - real(summa_prec),intent(out) :: mLayerTempTrial(:) ! trial vector of layer temperature (K) - real(summa_prec),intent(out) :: mLayerVolFracWatTrial(:) ! trial vector of volumetric total water content (-) - real(summa_prec),intent(out) :: mLayerVolFracLiqTrial(:) ! trial vector of volumetric liquid water content (-) - real(summa_prec),intent(out) :: mLayerVolFracIceTrial(:) ! trial vector of volumetric ice water content (-) - real(summa_prec),intent(out) :: mLayerMatricHeadTrial(:) ! trial vector of total water matric potential (m) - real(summa_prec),intent(out) :: mLayerMatricHeadLiqTrial(:) ! trial vector of liquid water matric potential (m) + real(rk),intent(out) :: mLayerTempTrial(:) ! trial vector of layer temperature (K) + real(rk),intent(out) :: mLayerVolFracWatTrial(:) ! trial vector of volumetric total water content (-) + real(rk),intent(out) :: mLayerVolFracLiqTrial(:) ! trial vector of volumetric liquid water content (-) + real(rk),intent(out) :: mLayerVolFracIceTrial(:) ! trial vector of volumetric ice water content (-) + real(rk),intent(out) :: mLayerMatricHeadTrial(:) ! trial vector of total water matric potential (m) + real(rk),intent(out) :: mLayerMatricHeadLiqTrial(:) ! trial vector of liquid water matric potential (m) ! output: variables for the aquifer - real(summa_prec),intent(out) :: scalarAquiferStorageTrial ! trial value of storage of water in the aquifer (m) + real(rk),intent(out) :: scalarAquiferStorageTrial ! trial value of storage of water in the aquifer (m) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message diff --git a/build/source/engine/groundwatr.f90 b/build/source/engine/groundwatr.f90 index b9aea181c..92a402ba2 100755 --- a/build/source/engine/groundwatr.f90 +++ b/build/source/engine/groundwatr.f90 @@ -47,9 +47,9 @@ module groundwatr_module ! privacy implicit none ! constant parameters -real(summa_prec),parameter :: valueMissing=-9999._summa_prec ! missing value parameter -real(summa_prec),parameter :: verySmall=epsilon(1.0_summa_prec) ! a very small number (used to avoid divide by zero) -real(summa_prec),parameter :: dx=1.e-8_summa_prec ! finite difference increment +real(rk),parameter :: valueMissing=-9999._rk ! missing value parameter +real(rk),parameter :: verySmall=epsilon(1.0_rk) ! a very small number (used to avoid divide by zero) +real(rk),parameter :: dx=1.e-8_rk ! finite difference increment private public::groundwatr contains @@ -120,10 +120,10 @@ subroutine groundwatr(& integer(i4b),intent(in) :: nLayers ! total number of layers logical(lgt),intent(in) :: getSatDepth ! logical flag to compute index of the lowest saturated layer ! input: state and diagnostic variables - real(summa_prec),intent(in) :: mLayerdTheta_dPsi(:) ! derivative in the soil water characteristic w.r.t. matric head in each layer (m-1) - real(summa_prec),intent(in) :: mLayerMatricHeadLiq(:) ! matric head in each layer at the current iteration (m) - real(summa_prec),intent(in) :: mLayerVolFracLiq(:) ! volumetric fraction of liquid water (-) - real(summa_prec),intent(in) :: mLayerVolFracIce(:) ! volumetric fraction of ice (-) + real(rk),intent(in) :: mLayerdTheta_dPsi(:) ! derivative in the soil water characteristic w.r.t. matric head in each layer (m-1) + real(rk),intent(in) :: mLayerMatricHeadLiq(:) ! matric head in each layer at the current iteration (m) + real(rk),intent(in) :: mLayerVolFracLiq(:) ! volumetric fraction of liquid water (-) + real(rk),intent(in) :: mLayerVolFracIce(:) ! volumetric fraction of ice (-) ! input/output: data structures type(var_d),intent(in) :: attr_data ! spatial attributes type(var_dlength),intent(in) :: mpar_data ! model parameters @@ -132,8 +132,8 @@ subroutine groundwatr(& type(var_dlength),intent(inout) :: flux_data ! model fluxes for a local HRU ! output: baseflow integer(i4b),intent(inout) :: ixSaturation ! index of lowest saturated layer (NOTE: only computed on the first iteration) - real(summa_prec),intent(out) :: mLayerBaseflow(:) ! baseflow from each soil layer (m s-1) - real(summa_prec),intent(out) :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) + real(rk),intent(out) :: mLayerBaseflow(:) ! baseflow from each soil layer (m s-1) + real(rk),intent(out) :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message @@ -142,13 +142,13 @@ subroutine groundwatr(& ! --------------------------------------------------------------------------------------- ! general local variables integer(i4b) :: iLayer ! index of soil layer - real(summa_prec),dimension(nSoil,nSoil) :: dBaseflow_dVolLiq ! derivative in the baseflow flux w.r.t. volumetric liquid water content (m s-1) + real(rk),dimension(nSoil,nSoil) :: dBaseflow_dVolLiq ! derivative in the baseflow flux w.r.t. volumetric liquid water content (m s-1) ! local variables to compute the numerical Jacobian logical(lgt),parameter :: doNumericalJacobian=.false. ! flag to compute the numerical Jacobian - real(summa_prec),dimension(nSoil) :: mLayerMatricHeadPerturbed ! perturbed matric head (m) - real(summa_prec),dimension(nSoil) :: mLayerVolFracLiqPerturbed ! perturbed volumetric fraction of liquid water (-) - real(summa_prec),dimension(nSoil) :: mLayerBaseflowPerturbed ! perturbed baseflow (m s-1) - real(summa_prec),dimension(nSoil,nSoil) :: nJac ! numerical Jacobian (s-1) + real(rk),dimension(nSoil) :: mLayerMatricHeadPerturbed ! perturbed matric head (m) + real(rk),dimension(nSoil) :: mLayerVolFracLiqPerturbed ! perturbed volumetric fraction of liquid water (-) + real(rk),dimension(nSoil) :: mLayerBaseflowPerturbed ! perturbed baseflow (m s-1) + real(rk),dimension(nSoil,nSoil) :: nJac ! numerical Jacobian (s-1) ! *************************************************************************************** ! *************************************************************************************** ! initialize error control @@ -189,10 +189,10 @@ subroutine groundwatr(& ! check for an early return (no layers are "active") if(ixSaturation > nSoil)then - scalarExfiltration = 0._summa_prec ! exfiltration from the soil profile (m s-1) - mLayerColumnOutflow(:) = 0._summa_prec ! column outflow from each soil layer (m3 s-1) - mLayerBaseflow(:) = 0._summa_prec ! baseflow from each soil layer (m s-1) - dBaseflow_dMatric(:,:) = 0._summa_prec ! derivative in baseflow w.r.t. matric head (s-1) + scalarExfiltration = 0._rk ! exfiltration from the soil profile (m s-1) + mLayerColumnOutflow(:) = 0._rk ! column outflow from each soil layer (m3 s-1) + mLayerBaseflow(:) = 0._rk ! baseflow from each soil layer (m s-1) + dBaseflow_dMatric(:,:) = 0._rk ! derivative in baseflow w.r.t. matric head (s-1) return end if ! if some layers are saturated @@ -222,7 +222,7 @@ subroutine groundwatr(& ! use the chain rule to compute the baseflow derivative w.r.t. matric head (s-1) do iLayer=1,nSoil dBaseflow_dMatric(1:iLayer,iLayer) = dBaseflow_dVolLiq(1:iLayer,iLayer)*mLayerdTheta_dPsi(iLayer) - if(iLayer1)then - zActive(1:ixSaturation-1) = 0._summa_prec - trTotal(1:ixSaturation-1) = 0._summa_prec - trSoil(1:ixSaturation-1) = 0._summa_prec + zActive(1:ixSaturation-1) = 0._rk + trTotal(1:ixSaturation-1) = 0._rk + trSoil(1:ixSaturation-1) = 0._rk end if ! compute the outflow from each layer (m3 s-1) @@ -444,26 +444,26 @@ subroutine computeBaseflow(& if(availStorage < xMinEval)then ! (compute the logistic function) expF = exp((availStorage - xCenter)/xWidth) - logF = 1._summa_prec / (1._summa_prec + expF) + logF = 1._rk / (1._rk + expF) ! (compute the derivative in the logistic function w.r.t. volumetric liquid water content in each soil layer) - dLogFunc_dLiq(1:nSoil) = mLayerDepth(1:nSoil)*(expF/xWidth)/(1._summa_prec + expF)**2._summa_prec + dLogFunc_dLiq(1:nSoil) = mLayerDepth(1:nSoil)*(expF/xWidth)/(1._rk + expF)**2._rk else - logF = 0._summa_prec - dLogFunc_dLiq(:) = 0._summa_prec + logF = 0._rk + dLogFunc_dLiq(:) = 0._rk end if ! compute the exfiltartion (m s-1) - if(totalColumnInflow > totalColumnOutflow .and. logF > tiny(1._summa_prec))then + if(totalColumnInflow > totalColumnOutflow .and. logF > tiny(1._rk))then scalarExfiltration = logF*(totalColumnInflow - totalColumnOutflow) ! m s-1 !write(*,'(a,1x,10(f30.20,1x))') 'scalarExfiltration = ', scalarExfiltration else - scalarExfiltration = 0._summa_prec + scalarExfiltration = 0._rk end if ! check !write(*,'(a,1x,10(f30.20,1x))') 'zActive(1), soilDepth, availStorage, logF, scalarExfiltration = ', & ! zActive(1), soilDepth, availStorage, logF, scalarExfiltration - !if(scalarExfiltration > tiny(1.0_summa_prec)) pause 'exfiltrating' + !if(scalarExfiltration > tiny(1.0_rk)) pause 'exfiltrating' ! compute the baseflow in each layer (m s-1) mLayerBaseflow(1:nSoil) = (mLayerColumnOutflow(1:nSoil) - mLayerColumnInflow(1:nSoil))/HRUarea @@ -494,7 +494,7 @@ subroutine computeBaseflow(& ! *********************************************************************************************************************** ! initialize the derivative matrix - dBaseflow_dVolLiq(:,:) = 0._summa_prec + dBaseflow_dVolLiq(:,:) = 0._rk ! check if derivatives are actually required if(.not.derivDesired) return @@ -506,7 +506,7 @@ subroutine computeBaseflow(& depth2capacity(1:nSoil) = mLayerDepth(1:nSoil)/sum( (theta_sat(1:nSoil) - fieldCapacity)*mLayerDepth(1:nSoil) ) ! compute the change in dimensionless flux w.r.t. change in dimensionless storage (-) - dXdS(1:nSoil) = zScale_TOPMODEL*(zActive(1:nSoil)/SoilDepth)**(zScale_TOPMODEL - 1._summa_prec) + dXdS(1:nSoil) = zScale_TOPMODEL*(zActive(1:nSoil)/SoilDepth)**(zScale_TOPMODEL - 1._rk) ! loop through soil layers do iLayer=1,nSoil @@ -519,7 +519,7 @@ subroutine computeBaseflow(& end do ! looping through soil layers ! compute the derivative in the exfiltration flux w.r.t. volumetric liquid water content (m s-1) - if(qbTotal < 0._summa_prec)then + if(qbTotal < 0._rk)then do iLayer=1,nSoil dExfiltrate_dVolLiq(iLayer) = dBaseflow_dVolLiq(iLayer,iLayer)*logF + dLogFunc_dLiq(iLayer)*qbTotal end do ! looping through soil layers diff --git a/build/source/engine/layerDivide.f90 b/build/source/engine/layerDivide.f90 index a98404261..24b94e2ed 100755 --- a/build/source/engine/layerDivide.f90 +++ b/build/source/engine/layerDivide.f90 @@ -117,21 +117,21 @@ subroutine layerDivide(& integer(i4b) :: nLayers ! total number of layers integer(i4b) :: iLayer ! layer index integer(i4b) :: jLayer ! layer index - real(summa_prec),dimension(4) :: zmax_lower ! lower value of maximum layer depth - real(summa_prec),dimension(4) :: zmax_upper ! upper value of maximum layer depth - real(summa_prec) :: zmaxCheck ! value of zmax for a given snow layer + real(rk),dimension(4) :: zmax_lower ! lower value of maximum layer depth + real(rk),dimension(4) :: zmax_upper ! upper value of maximum layer depth + real(rk) :: zmaxCheck ! value of zmax for a given snow layer integer(i4b) :: nCheck ! number of layers to check to divide logical(lgt) :: createLayer ! flag to indicate we are creating a new snow layer - real(summa_prec) :: depthOriginal ! original layer depth before sub-division (m) - real(summa_prec),parameter :: fracTop=0.5_summa_prec ! fraction of old layer used for the top layer - real(summa_prec) :: surfaceLayerSoilTemp ! temperature of the top soil layer (K) - real(summa_prec) :: maxFrozenSnowTemp ! maximum temperature when effectively all water is frozen (K) - real(summa_prec),parameter :: unfrozenLiq=0.01_summa_prec ! unfrozen liquid water used to compute maxFrozenSnowTemp (-) - real(summa_prec) :: volFracWater ! volumetric fraction of total water, liquid and ice (-) - real(summa_prec) :: fracLiq ! fraction of liquid water (-) + real(rk) :: depthOriginal ! original layer depth before sub-division (m) + real(rk),parameter :: fracTop=0.5_rk ! fraction of old layer used for the top layer + real(rk) :: surfaceLayerSoilTemp ! temperature of the top soil layer (K) + real(rk) :: maxFrozenSnowTemp ! maximum temperature when effectively all water is frozen (K) + real(rk),parameter :: unfrozenLiq=0.01_rk ! unfrozen liquid water used to compute maxFrozenSnowTemp (-) + real(rk) :: volFracWater ! volumetric fraction of total water, liquid and ice (-) + real(rk) :: fracLiq ! fraction of liquid water (-) integer(i4b),parameter :: ixVisible=1 ! named variable to define index in array of visible part of the spectrum integer(i4b),parameter :: ixNearIR=2 ! named variable to define index in array of near IR part of the spectrum - real(summa_prec),parameter :: verySmall=1.e-10_summa_prec ! a very small number (used for error checking) + real(rk),parameter :: verySmall=1.e-10_rk ! a very small number (used for error checking) ! -------------------------------------------------------------------------------------------------------- ! initialize error control err=0; message="layerDivide/" @@ -224,7 +224,7 @@ subroutine layerDivide(& ! compute volumeteric fraction of liquid water and ice volFracWater = (scalarSWE/scalarSnowDepth)/iden_water ! volumetric fraction of total water (liquid and ice) - mLayerVolFracIce(1) = (1._summa_prec - fracLiq)*volFracWater*(iden_water/iden_ice) ! volumetric fraction of ice (-) + mLayerVolFracIce(1) = (1._rk - fracLiq)*volFracWater*(iden_water/iden_ice) ! volumetric fraction of ice (-) mLayerVolFracLiq(1) = fracLiq *volFracWater ! volumetric fraction of liquid water (-) ! end association with local variables to the information in the data structures) @@ -243,7 +243,7 @@ subroutine layerDivide(& prog_data%var(iLookPROG%spectralSnowAlbedoDiffuse)%dat(ixVisible) = mpar_data%var(iLookPARAM%albedoMaxVisible)%dat(1) prog_data%var(iLookPROG%spectralSnowAlbedoDiffuse)%dat(ixNearIR) = mpar_data%var(iLookPARAM%albedoMaxNearIR)%dat(1) prog_data%var(iLookPROG%scalarSnowAlbedo)%dat(1) = ( mpar_data%var(iLookPARAM%Frad_vis)%dat(1))*mpar_data%var(iLookPARAM%albedoMaxVisible)%dat(1) + & - (1._summa_prec - mpar_data%var(iLookPARAM%Frad_vis)%dat(1))*mpar_data%var(iLookPARAM%albedoMaxNearIR)%dat(1) + (1._rk - mpar_data%var(iLookPARAM%Frad_vis)%dat(1))*mpar_data%var(iLookPARAM%albedoMaxNearIR)%dat(1) case default; err=20; message=trim(message)//'unable to identify option for snow albedo'; return end select ! identify option for snow albedo ! set direct albedo to diffuse albedo @@ -299,7 +299,7 @@ subroutine layerDivide(& layerSplit: associate(mLayerDepth => prog_data%var(iLookPROG%mLayerDepth)%dat) depthOriginal = mLayerDepth(iLayer) mLayerDepth(iLayer) = fracTop*depthOriginal - mLayerDepth(iLayer+1) = (1._summa_prec - fracTop)*depthOriginal + mLayerDepth(iLayer+1) = (1._rk - fracTop)*depthOriginal end associate layerSplit exit ! NOTE: only sub-divide one layer per substep @@ -337,7 +337,7 @@ subroutine layerDivide(& iLayerHeight(0) = -scalarSnowDepth do jLayer=1,nLayers iLayerHeight(jLayer) = iLayerHeight(jLayer-1) + mLayerDepth(jLayer) - mLayerHeight(jLayer) = (iLayerHeight(jLayer-1) + iLayerHeight(jLayer))/2._summa_prec + mLayerHeight(jLayer) = (iLayerHeight(jLayer-1) + iLayerHeight(jLayer))/2._rk end do ! check @@ -387,7 +387,7 @@ subroutine addModelLayer(dataStruct,metaStruct,ix_divide,nSnow,nLayers,err,messa integer(i4b) :: ix_lower ! lower bound of the vector integer(i4b) :: ix_upper ! upper bound of the vector logical(lgt) :: stateVariable ! .true. if variable is a state variable - real(summa_prec),allocatable :: tempVec_summa_prec(:) ! temporary vector (double precision) + real(rk),allocatable :: tempVec_rk(:) ! temporary vector (double precision) integer(i4b),allocatable :: tempVec_i4b(:) ! temporary vector (integer) character(LEN=256) :: cmessage ! error message of downwind routine ! --------------------------------------------------------------------------------------------- @@ -420,7 +420,7 @@ subroutine addModelLayer(dataStruct,metaStruct,ix_divide,nSnow,nLayers,err,messa ! check allocated if(.not.allocated(dataStruct%var(ivar)%dat))then; err=20; message='data vector is not allocated'; return; end if ! assign the data vector to the temporary vector - call cloneStruc(tempVec_summa_prec, ix_lower, source=dataStruct%var(ivar)%dat, err=err, message=cmessage) + call cloneStruc(tempVec_rk, ix_lower, source=dataStruct%var(ivar)%dat, err=err, message=cmessage) if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! reallocate space for the new vector deallocate(dataStruct%var(ivar)%dat,stat=err) @@ -431,18 +431,18 @@ subroutine addModelLayer(dataStruct,metaStruct,ix_divide,nSnow,nLayers,err,messa if(stateVariable)then if(ix_upper > 0)then ! (only copy data if the vector exists -- can be a variable for snow, with no layers) if(ix_divide > 0)then - dataStruct%var(ivar)%dat(1:ix_divide) = tempVec_summa_prec(1:ix_divide) ! copy data - dataStruct%var(ivar)%dat(ix_divide+1) = tempVec_summa_prec(ix_divide) ! repeat data for the sub-divided layer + dataStruct%var(ivar)%dat(1:ix_divide) = tempVec_rk(1:ix_divide) ! copy data + dataStruct%var(ivar)%dat(ix_divide+1) = tempVec_rk(ix_divide) ! repeat data for the sub-divided layer end if if(ix_upper > ix_divide) & - dataStruct%var(ivar)%dat(ix_divide+2:ix_upper+1) = tempVec_summa_prec(ix_divide+1:ix_upper) ! copy data + dataStruct%var(ivar)%dat(ix_divide+2:ix_upper+1) = tempVec_rk(ix_divide+1:ix_upper) ! copy data end if ! if the vector exists ! not a state variable else dataStruct%var(ivar)%dat(:) = realMissing end if ! deallocate the temporary vector: strictly not necessary, but include to be safe - deallocate(tempVec_summa_prec,stat=err) + deallocate(tempVec_rk,stat=err) if(err/=0)then; err=20; message='problem deallocating temporary data vector'; return; end if ! ** integer diff --git a/build/source/engine/layerMerge.f90 b/build/source/engine/layerMerge.f90 index c33af1061..37a4b12f6 100755 --- a/build/source/engine/layerMerge.f90 +++ b/build/source/engine/layerMerge.f90 @@ -100,7 +100,7 @@ subroutine layerMerge(& ! -------------------------------------------------------------------------------------------------------- ! define local variables character(LEN=256) :: cmessage ! error message of downwind routine - real(summa_prec),dimension(5) :: zminLayer ! minimum layer depth in each layer (m) + real(rk),dimension(5) :: zminLayer ! minimum layer depth in each layer (m) logical(lgt) :: removeLayer ! flag to indicate need to remove a layer integer(i4b) :: nCheck ! number of layers to check for combination integer(i4b) :: iSnow ! index of snow layers (looping) @@ -316,18 +316,18 @@ subroutine layer_combine(mpar_data,prog_data,diag_data,flux_data,indx_data,iSnow ! ------------------------------------------------------------------------------------------------------------ ! local variables character(len=256) :: cmessage ! error message for downwind routine - real(summa_prec) :: massIce(2) ! mass of ice in the two layers identified for combination (kg m-2) - real(summa_prec) :: massLiq(2) ! mass of liquid water in the two layers identified for combination (kg m-2) - real(summa_prec) :: bulkDenWat(2) ! bulk density if total water (liquid water plus ice) in the two layers identified for combination (kg m-3) - real(summa_prec) :: cBulkDenWat ! combined bulk density of total water (liquid water plus ice) in the two layers identified for combination (kg m-3) - real(summa_prec) :: cTemp ! combined layer temperature - real(summa_prec) :: cDepth ! combined layer depth - real(summa_prec) :: cVolFracIce ! combined layer volumetric fraction of ice - real(summa_prec) :: cVolFracLiq ! combined layer volumetric fraction of liquid water - real(summa_prec) :: l1Enthalpy,l2Enthalpy ! enthalpy in the two layers identified for combination (J m-3) - real(summa_prec) :: cEnthalpy ! combined layer enthalpy (J m-3) - real(summa_prec) :: fLiq ! fraction of liquid water at the combined temperature cTemp - real(summa_prec),parameter :: eTol=1.e-1_summa_prec ! tolerance for the enthalpy-->temperature conversion (J m-3) + real(rk) :: massIce(2) ! mass of ice in the two layers identified for combination (kg m-2) + real(rk) :: massLiq(2) ! mass of liquid water in the two layers identified for combination (kg m-2) + real(rk) :: bulkDenWat(2) ! bulk density if total water (liquid water plus ice) in the two layers identified for combination (kg m-3) + real(rk) :: cBulkDenWat ! combined bulk density of total water (liquid water plus ice) in the two layers identified for combination (kg m-3) + real(rk) :: cTemp ! combined layer temperature + real(rk) :: cDepth ! combined layer depth + real(rk) :: cVolFracIce ! combined layer volumetric fraction of ice + real(rk) :: cVolFracLiq ! combined layer volumetric fraction of liquid water + real(rk) :: l1Enthalpy,l2Enthalpy ! enthalpy in the two layers identified for combination (J m-3) + real(rk) :: cEnthalpy ! combined layer enthalpy (J m-3) + real(rk) :: fLiq ! fraction of liquid water at the combined temperature cTemp + real(rk),parameter :: eTol=1.e-1_rk ! tolerance for the enthalpy-->temperature conversion (J m-3) integer(i4b) :: nSnow ! number of snow layers integer(i4b) :: nSoil ! number of soil layers integer(i4b) :: nLayers ! total number of layers @@ -390,7 +390,7 @@ subroutine layer_combine(mpar_data,prog_data,diag_data,flux_data,indx_data,iSnow ! compute volumetric fraction of ice and liquid water cVolFracLiq = fLiq *cBulkDenWat/iden_water - cVolFracIce = (1._summa_prec - fLiq)*cBulkDenWat/iden_ice + cVolFracIce = (1._rk - fLiq)*cBulkDenWat/iden_ice ! end association of local variables with information in the data structures end associate @@ -459,7 +459,7 @@ subroutine rmLyAllVars(dataStruct,metaStruct,iSnow,nSnow,nLayers,err,message) integer(i4b) :: ivar ! variable index integer(i4b) :: ix_lower ! lower bound of the vector integer(i4b) :: ix_upper ! upper bound of the vector - real(summa_prec),allocatable :: tempVec_summa_prec(:) ! temporary vector (double precision) + real(rk),allocatable :: tempVec_rk(:) ! temporary vector (double precision) integer(i4b),allocatable :: tempVec_i4b(:) ! temporary vector (integer) character(LEN=256) :: cmessage ! error message of downwind routine ! initialize error control @@ -493,20 +493,20 @@ subroutine rmLyAllVars(dataStruct,metaStruct,iSnow,nSnow,nLayers,err,message) ! check allocated if(.not.allocated(dataStruct%var(ivar)%dat))then; err=20; message='data vector is not allocated'; return; end if ! allocate the temporary vector - allocate(tempVec_summa_prec(ix_lower:ix_upper-1), stat=err) + allocate(tempVec_rk(ix_lower:ix_upper-1), stat=err) if(err/=0)then; err=20; message=trim(message)//'unable to allocate temporary vector'; return; end if ! copy elements across to the temporary vector - if(iSnow>=ix_lower) tempVec_summa_prec(iSnow) = realMissing ! set merged layer to missing (fill in later) - if(iSnow>ix_lower) tempVec_summa_prec(ix_lower:iSnow-1) = dataStruct%var(ivar)%dat(ix_lower:iSnow-1) - if(iSnow+1=ix_lower) tempVec_rk(iSnow) = realMissing ! set merged layer to missing (fill in later) + if(iSnow>ix_lower) tempVec_rk(ix_lower:iSnow-1) = dataStruct%var(ivar)%dat(ix_lower:iSnow-1) + if(iSnow+11)then @@ -62,11 +62,11 @@ END FUNCTION arth_i SUBROUTINE indexx(arr,index) IMPLICIT NONE !INTEGER(I4B), DIMENSION(:), INTENT(IN) :: arr - real(summa_prec), DIMENSION(:), INTENT(IN) :: arr + real(rk), DIMENSION(:), INTENT(IN) :: arr INTEGER(I4B), DIMENSION(:), INTENT(OUT) :: index INTEGER(I4B), PARAMETER :: NN=15, NSTACK=50 !INTEGER(I4B) :: a - real(summa_prec) :: a + real(rk) :: a INTEGER(I4B) :: n,k,i,j,indext,jstack,l,r INTEGER(I4B), DIMENSION(NSTACK) :: istack n=size(arr) diff --git a/build/source/engine/nrtype.f90 b/build/source/engine/nrtype.f90 index 32d89deb2..9e82f8609 100755 --- a/build/source/engine/nrtype.f90 +++ b/build/source/engine/nrtype.f90 @@ -8,7 +8,7 @@ MODULE nrtype INTEGER, PARAMETER :: SP = KIND(1.0) INTEGER, PARAMETER :: DP = KIND(1.0D0) INTEGER, PARAMETER :: QP = KIND(1.0D0) - INTEGER, PARAMETER :: SUMMA_PREC = SP + INTEGER, PARAMETER :: rk = DP !INTEGER, PARAMETER :: QP = SELECTED_REAL_KIND(32) INTEGER, PARAMETER :: SPC = KIND((1.0,1.0)) INTEGER, PARAMETER :: DPC = KIND((1.0D0,1.0D0)) @@ -19,11 +19,11 @@ MODULE nrtype REAL(SP), PARAMETER :: TWOPI=6.283185307179586476925286766559005768394_sp REAL(SP), PARAMETER :: SQRT2=1.41421356237309504880168872420969807856967_sp REAL(SP), PARAMETER :: EULER=0.5772156649015328606065120900824024310422_sp - real(summa_prec), PARAMETER :: PI_D=3.141592653589793238462643383279502884197_summa_prec - real(summa_prec), PARAMETER :: PIO2_D=1.57079632679489661923132169163975144209858_summa_prec - real(summa_prec), PARAMETER :: TWOPI_D=6.283185307179586476925286766559005768394_summa_prec + real(rk), PARAMETER :: PI_D=3.141592653589793238462643383279502884197_rk + real(rk), PARAMETER :: PIO2_D=1.57079632679489661923132169163975144209858_rk + real(rk), PARAMETER :: TWOPI_D=6.283185307179586476925286766559005768394_rk ! missing values - real(summa_prec), parameter :: nr_quadMissing=-9999._qp ! missing quadruple precision number - real(summa_prec), parameter :: nr_realMissing=-9999._summa_prec ! missing double precision number + real(rk), parameter :: nr_quadMissing=-9999._qp ! missing quadruple precision number + real(rk), parameter :: nr_realMissing=-9999._rk ! missing double precision number integer(i4b), parameter :: nr_integerMissing=-9999 ! missing integer END MODULE nrtype diff --git a/build/source/engine/opSplittin.f90 b/build/source/engine/opSplittin.f90 index 474d5be68..e9abc2125 100755 --- a/build/source/engine/opSplittin.f90 +++ b/build/source/engine/opSplittin.f90 @@ -147,10 +147,10 @@ module opSplittin_module integer(i4b),parameter :: nDomains=4 ! number of domains (vegetation, snow, soil, and aquifer) ! control parameters -real(summa_prec),parameter :: valueMissing=-9999._summa_prec ! missing value -real(summa_prec),parameter :: verySmall=1.e-12_summa_prec ! a very small number (used to check consistency) -real(summa_prec),parameter :: veryBig=1.e+20_summa_prec ! a very big number -real(summa_prec),parameter :: dx = 1.e-8_summa_prec ! finite difference increment +real(rk),parameter :: valueMissing=-9999._rk ! missing value +real(rk),parameter :: verySmall=1.e-12_rk ! a very small number (used to check consistency) +real(rk),parameter :: veryBig=1.e+20_rk ! a very big number +real(rk),parameter :: dx = 1.e-8_rk ! finite difference increment contains @@ -210,7 +210,7 @@ subroutine opSplittin(& integer(i4b),intent(in) :: nSoil ! number of soil layers integer(i4b),intent(in) :: nLayers ! total number of layers integer(i4b),intent(in) :: nState ! total number of state variables - real(summa_prec),intent(inout) :: dt ! time step (seconds) + real(rk),intent(inout) :: dt ! time step (seconds) logical(lgt),intent(in) :: firstSubStep ! flag to indicate if we are processing the first sub-step logical(lgt),intent(in) :: computeVegFlux ! flag to indicate if we are computing fluxes over vegetation (.false. means veg is buried with snow) ! input/output: data structures @@ -225,7 +225,7 @@ subroutine opSplittin(& type(var_dlength),intent(in) :: bvar_data ! model variables for the local basin type(model_options),intent(in) :: model_decisions(:) ! model decisions ! output: model control - real(summa_prec),intent(out) :: dtMultiplier ! substep multiplier (-) + real(rk),intent(out) :: dtMultiplier ! substep multiplier (-) logical(lgt),intent(out) :: tooMuchMelt ! flag to denote that ice is insufficient to support melt logical(lgt),intent(out) :: stepFailure ! flag to denote step failure integer(i4b),intent(out) :: err ! error code @@ -249,19 +249,19 @@ subroutine opSplittin(& type(var_dlength) :: diag_temp ! temporary model diagnostic variables type(var_dlength) :: flux_temp ! temporary model fluxes type(var_dlength) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables - real(summa_prec),dimension(nLayers) :: mLayerVolFracIceInit ! initial vector for volumetric fraction of ice (-) + real(rk),dimension(nLayers) :: mLayerVolFracIceInit ! initial vector for volumetric fraction of ice (-) ! ------------------------------------------------------------------------------------------------------ ! * operator splitting ! ------------------------------------------------------------------------------------------------------ ! minimum timestep - real(summa_prec),parameter :: dtmin_coupled=1800._summa_prec ! minimum time step for the fully coupled solution (seconds) - real(summa_prec),parameter :: dtmin_split=60._summa_prec ! minimum time step for the fully split solution (seconds) - real(summa_prec),parameter :: dtmin_scalar=10._summa_prec ! minimum time step for the scalar solution (seconds) - real(summa_prec) :: dt_min ! minimum time step (seconds) - real(summa_prec) :: dtInit ! initial time step (seconds) + real(rk),parameter :: dtmin_coupled=1800._rk ! minimum time step for the fully coupled solution (seconds) + real(rk),parameter :: dtmin_split=60._rk ! minimum time step for the fully split solution (seconds) + real(rk),parameter :: dtmin_scalar=10._rk ! minimum time step for the scalar solution (seconds) + real(rk) :: dt_min ! minimum time step (seconds) + real(rk) :: dtInit ! initial time step (seconds) ! explicit error tolerance (depends on state type split, so defined here) - real(summa_prec),parameter :: errorTolLiqFlux=0.01_summa_prec ! error tolerance in the explicit solution (liquid flux) - real(summa_prec),parameter :: errorTolNrgFlux=10._summa_prec ! error tolerance in the explicit solution (energy flux) + real(rk),parameter :: errorTolLiqFlux=0.01_rk ! error tolerance in the explicit solution (liquid flux) + real(rk),parameter :: errorTolNrgFlux=10._rk ! error tolerance in the explicit solution (energy flux) ! number of substeps taken for a given split integer(i4b) :: nSubsteps ! number of substeps taken for a given split ! named variables defining the coupling and solution method @@ -443,12 +443,12 @@ subroutine opSplittin(& do iVar=1,size(flux_meta) ! loop through fluxes if(flux2state_orig(iVar)%state1==integerMissing .and. flux2state_orig(iVar)%state2==integerMissing) cycle ! flux does not depend on state (e.g., input) if(flux2state_orig(iVar)%state1==iname_watCanopy .and. .not.computeVegFlux) cycle ! use input fluxes in cases where there is no canopy - flux_data%var(iVar)%dat(:) = 0._summa_prec + flux_data%var(iVar)%dat(:) = 0._rk end do ! initialize derivatives do iVar=1,size(deriv_meta) - deriv_data%var(iVar)%dat(:) = 0._summa_prec + deriv_data%var(iVar)%dat(:) = 0._rk end do ! ========================================================================================================================================== @@ -978,7 +978,7 @@ subroutine opSplittin(& end do ! use step halving if unable to complete the fully coupled solution in one substep - if(ixCoupling/=fullyCoupled .or. nSubsteps>1) dtMultiplier=0.5_summa_prec + if(ixCoupling/=fullyCoupled .or. nSubsteps>1) dtMultiplier=0.5_rk ! compute the melt in each snow and soil layer if(nSnow>0) mLayerMeltFreeze( 1:nSnow ) = -(mLayerVolFracIce( 1:nSnow ) - mLayerVolFracIceInit( 1:nSnow ))*iden_ice diff --git a/build/source/engine/pOverwrite.f90 b/build/source/engine/pOverwrite.f90 index f522c5129..4bb19ff77 100755 --- a/build/source/engine/pOverwrite.f90 +++ b/build/source/engine/pOverwrite.f90 @@ -51,7 +51,7 @@ subroutine pOverwrite(ixVeg,ixSoil,defaultParam,err,message) integer(i4b),intent(in) :: ixVeg ! vegetation category integer(i4b),intent(in) :: ixSoil ! soil category ! define output - real(summa_prec),intent(inout) :: defaultParam(:) ! default model parameters + real(rk),intent(inout) :: defaultParam(:) ! default model parameters integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! Start procedure here diff --git a/build/source/engine/paramCheck.f90 b/build/source/engine/paramCheck.f90 index f34b0a32e..ae5991075 100755 --- a/build/source/engine/paramCheck.f90 +++ b/build/source/engine/paramCheck.f90 @@ -49,9 +49,9 @@ subroutine paramCheck(mpar_data,err,message) character(*),intent(out) :: message ! error message ! local variables integer(i4b) :: iLayer ! index of model layers - real(summa_prec),dimension(5) :: zminLayer ! minimum layer depth in each layer (m) - real(summa_prec),dimension(4) :: zmaxLayer_lower ! lower value of maximum layer depth - real(summa_prec),dimension(4) :: zmaxLayer_upper ! upper value of maximum layer depth + real(rk),dimension(5) :: zminLayer ! minimum layer depth in each layer (m) + real(rk),dimension(4) :: zmaxLayer_lower ! lower value of maximum layer depth + real(rk),dimension(4) :: zmaxLayer_upper ! upper value of maximum layer depth ! Start procedure here err=0; message="paramCheck/" @@ -63,7 +63,7 @@ subroutine paramCheck(mpar_data,err,message) select case(model_decisions(iLookDECISIONS%snowLayers)%iDecision) ! SNTHERM option case(sameRulesAllLayers) - if(mpar_data%var(iLookPARAM%zmax)%dat(1)/mpar_data%var(iLookPARAM%zmin)%dat(1) < 2.5_summa_prec)then + if(mpar_data%var(iLookPARAM%zmax)%dat(1)/mpar_data%var(iLookPARAM%zmin)%dat(1) < 2.5_rk)then message=trim(message)//'zmax must be at least 2.5 times larger than zmin: this avoids merging layers that have just been divided' err=20; return end if @@ -93,7 +93,7 @@ subroutine paramCheck(mpar_data,err,message) err=20; return end if ! ensure that the maximum thickness is 3 times greater than the minimum thickness - if(zmaxLayer_upper(iLayer)/zminLayer(iLayer) < 2.5_summa_prec .or. zmaxLayer_upper(iLayer)/zminLayer(iLayer+1) < 2.5_summa_prec)then + if(zmaxLayer_upper(iLayer)/zminLayer(iLayer) < 2.5_rk .or. zmaxLayer_upper(iLayer)/zminLayer(iLayer+1) < 2.5_rk)then write(*,'(a,1x,3(f20.10,1x))') 'zmaxLayer_upper(iLayer), zminLayer(iLayer), zminLayer(iLayer+1) = ', & zmaxLayer_upper(iLayer), zminLayer(iLayer), zminLayer(iLayer+1) write(message,'(a,3(i0,a))') trim(message)//'zmaxLayer_upper for layer ',iLayer,' must be 2.5 times larger than zminLayer for layers ',& diff --git a/build/source/engine/qTimeDelay.f90 b/build/source/engine/qTimeDelay.f90 index ff1c12a42..810c48639 100755 --- a/build/source/engine/qTimeDelay.f90 +++ b/build/source/engine/qTimeDelay.f90 @@ -52,14 +52,14 @@ subroutine qOverland(& implicit none ! input integer(i4b),intent(in) :: ixRouting ! index for routing method - real(summa_prec),intent(in) :: averageSurfaceRunoff ! surface runoff (m s-1) - real(summa_prec),intent(in) :: averageSoilBaseflow ! baseflow from the soil profile (m s-1) - real(summa_prec),intent(in) :: averageAquiferBaseflow ! baseflow from the aquifer (m s-1) - real(summa_prec),intent(in) :: fracFuture(:) ! fraction of runoff in future time steps (m s-1) - real(summa_prec),intent(inout) :: qFuture(:) ! runoff in future time steps (m s-1) + real(rk),intent(in) :: averageSurfaceRunoff ! surface runoff (m s-1) + real(rk),intent(in) :: averageSoilBaseflow ! baseflow from the soil profile (m s-1) + real(rk),intent(in) :: averageAquiferBaseflow ! baseflow from the aquifer (m s-1) + real(rk),intent(in) :: fracFuture(:) ! fraction of runoff in future time steps (m s-1) + real(rk),intent(inout) :: qFuture(:) ! runoff in future time steps (m s-1) ! output - real(summa_prec),intent(out) :: averageInstantRunoff ! instantaneous runoff (m s-1) - real(summa_prec),intent(out) :: averageRoutedRunoff ! routed runoff (m s-1) + real(rk),intent(out) :: averageInstantRunoff ! instantaneous runoff (m s-1) + real(rk),intent(out) :: averageRoutedRunoff ! routed runoff (m s-1) integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! internal @@ -89,7 +89,7 @@ subroutine qOverland(& do iFuture=2,nTDH qFuture(iFuture-1) = qFuture(iFuture) end do - qFuture(nTDH) = 0._summa_prec + qFuture(nTDH) = 0._rk !print*, 'averageInstantRunoff, averageRoutedRunoff = ', averageInstantRunoff, averageRoutedRunoff !print*, 'qFuture(1:100) = ', qFuture(1:100) diff --git a/build/source/engine/read_attrb.f90 b/build/source/engine/read_attrb.f90 index 45571cfd1..4728a0731 100755 --- a/build/source/engine/read_attrb.f90 +++ b/build/source/engine/read_attrb.f90 @@ -239,7 +239,7 @@ subroutine read_attrb(attrFile,nGRU,attrStruct,typeStruct,idStruct,err,message) integer(i4b),parameter :: numerical=102 ! named variable to denote numerical data integer(i4b),parameter :: idrelated=103 ! named variable to denote ID related data integer(i4b) :: categorical_var(1) ! temporary categorical variable from local attributes netcdf file - real(summa_prec) :: numeric_var(1) ! temporary numeric variable from local attributes netcdf file + real(rk) :: numeric_var(1) ! temporary numeric variable from local attributes netcdf file integer(8) :: idrelated_var(1) ! temporary ID related variable from local attributes netcdf file ! define mapping variables diff --git a/build/source/engine/read_force.f90 b/build/source/engine/read_force.f90 index e2b81b67f..e9e94bbda 100755 --- a/build/source/engine/read_force.f90 +++ b/build/source/engine/read_force.f90 @@ -63,8 +63,8 @@ module read_force_module public::read_force ! global parameters -real(summa_prec),parameter :: verySmall=1e-3_summa_prec ! tiny number -real(summa_prec),parameter :: smallOffset=1.e-8_summa_prec ! small offset (units=days) to force ih=0 at the start of the day +real(rk),parameter :: verySmall=1e-3_rk ! tiny number +real(rk),parameter :: smallOffset=1.e-8_rk ! small offset (units=days) to force ih=0 at the start of the day contains @@ -95,8 +95,8 @@ subroutine read_force(istep,iFile,iRead,ncid,time_data,forcStruct,err,message) integer(i4b) :: iGRU,iHRU ! index of GRU and HRU character(len=256),save :: infile ! filename character(len=256) :: cmessage ! error message for downwind routine - real(summa_prec) :: startJulDay ! julian day at the start of the year - real(summa_prec) :: currentJulday ! Julian day of current time step + real(rk) :: startJulDay ! julian day at the start of the year + real(rk) :: currentJulday ! Julian day of current time step logical(lgt),parameter :: checkTime=.false. ! flag to check the time ! Start procedure here err=0; message="read_force/" @@ -173,7 +173,7 @@ subroutine read_force(istep,iFile,iRead,ncid,time_data,forcStruct,err,message) ! compute the julian day at the start of the year call compjulday(time_data(iLookTIME%iyyy), & ! input = year - 1, 1, 1, 1, 0._summa_prec, & ! input = month, day, hour, minute, second + 1, 1, 1, 1, 0._rk, & ! input = month, day, hour, minute, second startJulDay,err,cmessage) ! output = julian day (fraction of day) + error control if(err/=0)then; message=trim(message)//trim(cmessage); return; end if @@ -182,7 +182,7 @@ subroutine read_force(istep,iFile,iRead,ncid,time_data,forcStruct,err,message) time_data(iLookTIME%im), & ! input = month time_data(iLookTIME%id), & ! input = day time_data(iLookTIME%ih), & ! input = hour - time_data(iLookTIME%imin),0._summa_prec, & ! input = minute/second + time_data(iLookTIME%imin),0._rk, & ! input = minute/second currentJulday,err,cmessage) ! output = julian day (fraction of day) + error control if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! compute the time since the start of the year (in fractional days) @@ -235,7 +235,7 @@ subroutine getFirstTimestep(currentJulday,iFile,iRead,ncid,err,message) USE nr_utility_module,only:arth ! get a sequence of numbers implicit none ! define input - real(summa_prec),intent(in) :: currentJulday ! Julian day of current time step + real(rk),intent(in) :: currentJulday ! Julian day of current time step ! define input-output variables integer(i4b),intent(inout) :: iFile ! index of current forcing file in forcing file list integer(i4b),intent(inout) :: iRead ! index of read position in time dimension in current netcdf file @@ -252,9 +252,9 @@ subroutine getFirstTimestep(currentJulday,iFile,iRead,ncid,err,message) character(len=256),save :: infile ! filename character(len=256) :: cmessage ! error message for downwind routine integer(i4b) :: nFiles ! number of forcing files - real(summa_prec) :: timeVal(1) ! single time value (restrict time read) - real(summa_prec),allocatable :: fileTime(:) ! array of time from netcdf file - real(summa_prec),allocatable :: diffTime(:) ! array of time differences + real(rk) :: timeVal(1) ! single time value (restrict time read) + real(rk),allocatable :: fileTime(:) ! array of time from netcdf file + real(rk),allocatable :: diffTime(:) ! array of time differences ! Start procedure here err=0; message="getFirstTimestep/" @@ -348,7 +348,7 @@ subroutine openForcingFile(iFile,infile,ncId,err,message) character(len=256) :: cmessage ! error message for downwind routine integer(i4b) :: iyyy,im,id,ih,imin ! date integer(i4b) :: ih_tz,imin_tz ! time zone information - real(summa_prec) :: dsec,dsec_tz ! seconds + real(rk) :: dsec,dsec_tz ! seconds integer(i4b) :: varId ! variable identifier integer(i4b) :: mode ! netcdf file mode integer(i4b) :: attLen ! attribute length @@ -378,8 +378,8 @@ subroutine openForcingFile(iFile,infile,ncId,err,message) case('ncTime'); tmZoneOffsetFracDay = sign(1, ih_tz) * fracDay(ih_tz, & ! time zone hour imin_tz, & ! time zone minute dsec_tz) ! time zone second - case('utcTime'); tmZoneOffsetFracDay = 0._summa_prec - case('localTime'); tmZoneOffsetFracDay = 0._summa_prec + case('utcTime'); tmZoneOffsetFracDay = 0._rk + case('localTime'); tmZoneOffsetFracDay = 0._rk case default; err=20; message=trim(message)//'unable to identify time zone info option'; return end select ! (option time zone option) @@ -391,10 +391,10 @@ subroutine openForcingFile(iFile,infile,ncId,err,message) ! get the time multiplier needed to convert time to units of days select case( trim( refTimeString(1:index(refTimeString,' ')) ) ) - case('seconds'); forcFileInfo(iFile)%convTime2Days=86400._summa_prec - case('minutes'); forcFileInfo(iFile)%convTime2Days=1440._summa_prec - case('hours'); forcFileInfo(iFile)%convTime2Days=24._summa_prec - case('days'); forcFileInfo(iFile)%convTime2Days=1._summa_prec + case('seconds'); forcFileInfo(iFile)%convTime2Days=86400._rk + case('minutes'); forcFileInfo(iFile)%convTime2Days=1440._rk + case('hours'); forcFileInfo(iFile)%convTime2Days=24._rk + case('days'); forcFileInfo(iFile)%convTime2Days=1._rk case default; message=trim(message)//'unable to identify time units'; err=20; return end select @@ -409,7 +409,7 @@ subroutine readForcingData(currentJulday,ncId,iFile,iRead,nHRUlocal,time_data,fo USE time_utils_module,only:compJulday ! convert calendar date to julian day USE get_ixname_module,only:get_ixforce ! identify index of named variable ! dummy variables - real(summa_prec),intent(in) :: currentJulday ! Julian day of current time step + real(rk),intent(in) :: currentJulday ! Julian day of current time step integer(i4b) ,intent(in) :: ncId ! NetCDF ID integer(i4b) ,intent(in) :: iFile ! index of forcing file integer(i4b) ,intent(in) :: iRead ! index in data file @@ -422,7 +422,7 @@ subroutine readForcingData(currentJulday,ncId,iFile,iRead,nHRUlocal,time_data,fo character(len=256) :: cmessage ! error message for downwind routine integer(i4b) :: varId ! variable identifier character(len = nf90_max_name) :: varName ! dimenison name - real(summa_prec) :: varTime(1) ! time variable of current forcing data step being read + real(rk) :: varTime(1) ! time variable of current forcing data step being read ! other local variables integer(i4b) :: iGRU,iHRU ! index of GRU and HRU integer(i4b) :: iHRU_global ! index of HRU in the NetCDF file @@ -431,11 +431,11 @@ subroutine readForcingData(currentJulday,ncId,iFile,iRead,nHRUlocal,time_data,fo integer(i4b) :: iNC ! loop through variables in forcing file integer(i4b) :: iVar ! index of forcing variable in forcing data vector logical(lgt),parameter :: checkTime=.false. ! flag to check the time - real(summa_prec) :: dsec ! double precision seconds (not used) - real(summa_prec) :: dataJulDay ! julian day of current forcing data step being read - real(summa_prec),dimension(nHRUlocal) :: dataVec ! vector of data - real(summa_prec),dimension(1) :: dataVal ! single data value - real(summa_prec),parameter :: dataMin=-1._summa_prec ! minimum allowable data value (all forcing variables should be positive) + real(rk) :: dsec ! double precision seconds (not used) + real(rk) :: dataJulDay ! julian day of current forcing data step being read + real(rk),dimension(nHRUlocal) :: dataVec ! vector of data + real(rk),dimension(1) :: dataVal ! single data value + real(rk),parameter :: dataMin=-1._rk ! minimum allowable data value (all forcing variables should be positive) logical(lgt),dimension(size(forc_meta)) :: checkForce ! flags to check forcing data variables exist logical(lgt),parameter :: simultaneousRead=.true. ! flag to denote reading all HRUs at once ! Start procedure here diff --git a/build/source/engine/read_param.f90 b/build/source/engine/read_param.f90 index 7ce307f0d..0422727db 100755 --- a/build/source/engine/read_param.f90 +++ b/build/source/engine/read_param.f90 @@ -90,7 +90,7 @@ subroutine read_param(iRunMode,checkHRU,startGRU,nHRU,nGRU,idStruct,mparStruct,b ! data in the netcdf file integer(i4b) :: parLength ! length of the parameter data integer(8),allocatable :: hruId(:) ! HRU identifier in the file - real(summa_prec),allocatable :: parVector(:) ! model parameter vector + real(rk),allocatable :: parVector(:) ! model parameter vector logical :: fexist ! inquire whether the parmTrial file exists integer(i4b) :: fHRU ! index of HRU in input file diff --git a/build/source/engine/read_pinit.f90 b/build/source/engine/read_pinit.f90 index 89982d069..9017b4448 100755 --- a/build/source/engine/read_pinit.f90 +++ b/build/source/engine/read_pinit.f90 @@ -132,9 +132,9 @@ subroutine read_pinit(filenm,isLocal,mpar_meta,parFallback,err,message) ! check we have populated all variables ! NOTE: ultimately need a need a parameter dictionary to ensure that the parameters used are populated if(.not.backwardsCompatible)then ! if we add new variables in future versions of the code, then some may be missing in the input file - if(any(parFallback(:)%default_val < 0.99_summa_prec*realMissing))then + if(any(parFallback(:)%default_val < 0.99_rk*realMissing))then do ivar=1,size(parFallback) - if(parFallback(ivar)%default_val < 0.99_summa_prec*realMissing)then + if(parFallback(ivar)%default_val < 0.99_rk*realMissing)then err=40; message=trim(message)//"variableNonexistent[var="//trim(mpar_meta(ivar)%varname)//"]"; return end if end do @@ -143,8 +143,8 @@ subroutine read_pinit(filenm,isLocal,mpar_meta,parFallback,err,message) else ! (need backwards compatibility) if(isLocal)then if(model_decisions(iLookDECISIONS%cIntercept)%iDecision == unDefined)then - parFallback(iLookPARAM%canopyWettingFactor)%default_val = 1._summa_prec ! maximum wetted fraction of the canopy (-) - parFallback(iLookPARAM%canopyWettingExp)%default_val = 0.666666667_summa_prec ! exponent in canopy wetting function (-) + parFallback(iLookPARAM%canopyWettingFactor)%default_val = 1._rk ! maximum wetted fraction of the canopy (-) + parFallback(iLookPARAM%canopyWettingExp)%default_val = 0.666666667_rk ! exponent in canopy wetting function (-) end if end if end if diff --git a/build/source/engine/run_oneGRU.f90 b/build/source/engine/run_oneGRU.f90 index 93d2f8b43..3dbcfb1e1 100755 --- a/build/source/engine/run_oneGRU.f90 +++ b/build/source/engine/run_oneGRU.f90 @@ -103,7 +103,7 @@ subroutine run_oneGRU(& ! model control type(gru2hru_map) , intent(inout) :: gruInfo ! HRU information for given GRU (# HRUs, #snow+soil layers) - real(summa_prec) , intent(inout) :: dt_init(:) ! used to initialize the length of the sub-step for each HRU + real(rk) , intent(inout) :: dt_init(:) ! used to initialize the length of the sub-step for each HRU integer(i4b) , intent(inout) :: ixComputeVegFlux(:) ! flag to indicate if we are computing fluxes over vegetation (false=no, true=yes) ! data structures (input) integer(i4b) , intent(in) :: timeVec(:) ! integer vector -- model time data @@ -131,7 +131,7 @@ subroutine run_oneGRU(& integer(i4b) :: nSnow ! number of snow layers integer(i4b) :: nSoil ! number of soil layers integer(i4b) :: nLayers ! total number of layers - real(summa_prec) :: fracHRU ! fractional area of a given HRU (-) + real(rk) :: fracHRU ! fractional area of a given HRU (-) logical(lgt) :: computeVegFluxFlag ! flag to indicate if we are computing fluxes over vegetation (.false. means veg is buried with snow) ! initialize error control @@ -140,17 +140,17 @@ subroutine run_oneGRU(& ! ----- basin initialization -------------------------------------------------------------------------------------------- ! initialize runoff variables - bvarData%var(iLookBVAR%basin__SurfaceRunoff)%dat(1) = 0._summa_prec ! surface runoff (m s-1) - bvarData%var(iLookBVAR%basin__ColumnOutflow)%dat(1) = 0._summa_prec ! outflow from all "outlet" HRUs (those with no downstream HRU) + bvarData%var(iLookBVAR%basin__SurfaceRunoff)%dat(1) = 0._rk ! surface runoff (m s-1) + bvarData%var(iLookBVAR%basin__ColumnOutflow)%dat(1) = 0._rk ! outflow from all "outlet" HRUs (those with no downstream HRU) ! initialize baseflow variables - bvarData%var(iLookBVAR%basin__AquiferRecharge)%dat(1) = 0._summa_prec ! recharge to the aquifer (m s-1) - bvarData%var(iLookBVAR%basin__AquiferBaseflow)%dat(1) = 0._summa_prec ! baseflow from the aquifer (m s-1) - bvarData%var(iLookBVAR%basin__AquiferTranspire)%dat(1) = 0._summa_prec ! transpiration loss from the aquifer (m s-1) + bvarData%var(iLookBVAR%basin__AquiferRecharge)%dat(1) = 0._rk ! recharge to the aquifer (m s-1) + bvarData%var(iLookBVAR%basin__AquiferBaseflow)%dat(1) = 0._rk ! baseflow from the aquifer (m s-1) + bvarData%var(iLookBVAR%basin__AquiferTranspire)%dat(1) = 0._rk ! transpiration loss from the aquifer (m s-1) ! initialize total inflow for each layer in a soil column do iHRU=1,gruInfo%hruCount - fluxHRU%hru(iHRU)%var(iLookFLUX%mLayerColumnInflow)%dat(:) = 0._summa_prec + fluxHRU%hru(iHRU)%var(iLookFLUX%mLayerColumnInflow)%dat(:) = 0._rk end do ! *********************************************************************************************************************** diff --git a/build/source/engine/run_oneHRU.f90 b/build/source/engine/run_oneHRU.f90 index 5fb27c909..8f92a9af8 100755 --- a/build/source/engine/run_oneHRU.f90 +++ b/build/source/engine/run_oneHRU.f90 @@ -114,7 +114,7 @@ subroutine run_oneHRU(& ! model control integer(8) , intent(in) :: hruId ! hruId - real(summa_prec) , intent(inout) :: dt_init ! used to initialize the length of the sub-step for each HRU + real(rk) , intent(inout) :: dt_init ! used to initialize the length of the sub-step for each HRU logical(lgt) , intent(inout) :: computeVegFlux ! flag to indicate if we are computing fluxes over vegetation (false=no, true=yes) integer(i4b) , intent(inout) :: nSnow,nSoil,nLayers ! number of snow and soil layers ! data structures (input) @@ -137,7 +137,7 @@ subroutine run_oneHRU(& ! local variables character(len=256) :: cmessage ! error message - real(summa_prec) , allocatable :: zSoilReverseSign(:) ! height at bottom of each soil layer, negative downwards (m) + real(rk) , allocatable :: zSoilReverseSign(:) ! height at bottom of each soil layer, negative downwards (m) ! initialize error control err=0; write(message, '(A20,I0,A2)' ) 'run_oneHRU (hruId = ',hruId,')/' @@ -201,7 +201,7 @@ subroutine run_oneHRU(& ! ----- run the model -------------------------------------------------------------------------------------------------- ! initialize the number of flux calls - diagData%var(iLookDIAG%numFluxCalls)%dat(1) = 0._summa_prec + diagData%var(iLookDIAG%numFluxCalls)%dat(1) = 0._rk ! run the model for a single HRU call coupled_em(& diff --git a/build/source/engine/snowAlbedo.f90 b/build/source/engine/snowAlbedo.f90 index 35544c729..d9555f5a8 100755 --- a/build/source/engine/snowAlbedo.f90 +++ b/build/source/engine/snowAlbedo.f90 @@ -81,7 +81,7 @@ subroutine snowAlbedo(& USE snow_utils_module,only:fracliquid ! compute fraction of liquid water at a given temperature ! -------------------------------------------------------------------------------------------------------------------------------------- ! input: model control - real(summa_prec),intent(in) :: dt ! model time step + real(rk),intent(in) :: dt ! model time step logical(lgt),intent(in) :: snowPresence ! logical flag to denote if snow is present ! input/output: data structures type(model_options),intent(in) :: model_decisions(:) ! model decisions @@ -95,16 +95,16 @@ subroutine snowAlbedo(& ! local variables integer(i4b),parameter :: ixVisible=1 ! named variable to define index in array of visible part of the spectrum integer(i4b),parameter :: ixNearIR=2 ! named variable to define index in array of near IR part of the spectrum - real(summa_prec),parameter :: valueMissing=-9999._summa_prec ! missing value -- will cause problems if snow albedo is ever used for the non-snow case - real(summa_prec),parameter :: slushExp=10._summa_prec ! "slush" exponent, to increase decay when snow is near Tfreeze - real(summa_prec),parameter :: fractionLiqThresh=0.001_summa_prec ! threshold for the fraction of liquid water to switch to spring albedo minimum - real(summa_prec) :: fractionLiq ! fraction of liquid water (-) - real(summa_prec) :: age1,age2,age3 ! aging factors (-) - real(summa_prec) :: decayFactor ! albedo decay factor (-) - real(summa_prec) :: refreshFactor ! albedo refreshment factor, representing albedo increase due to snowfall (-) - real(summa_prec) :: albedoMin ! minimum albedo -- depends if in winter or spring conditions (-) - real(summa_prec) :: fZen ! factor to modify albedo at low zenith angles (-) - real(summa_prec),parameter :: bPar=2._summa_prec ! empirical parameter in fZen + real(rk),parameter :: valueMissing=-9999._rk ! missing value -- will cause problems if snow albedo is ever used for the non-snow case + real(rk),parameter :: slushExp=10._rk ! "slush" exponent, to increase decay when snow is near Tfreeze + real(rk),parameter :: fractionLiqThresh=0.001_rk ! threshold for the fraction of liquid water to switch to spring albedo minimum + real(rk) :: fractionLiq ! fraction of liquid water (-) + real(rk) :: age1,age2,age3 ! aging factors (-) + real(rk) :: decayFactor ! albedo decay factor (-) + real(rk) :: refreshFactor ! albedo refreshment factor, representing albedo increase due to snowfall (-) + real(rk) :: albedoMin ! minimum albedo -- depends if in winter or spring conditions (-) + real(rk) :: fZen ! factor to modify albedo at low zenith angles (-) + real(rk),parameter :: bPar=2._rk ! empirical parameter in fZen ! initialize error control err=0; message='snowAlbedo/' ! -------------------------------------------------------------------------------------------------------------------------------------- @@ -188,18 +188,18 @@ subroutine snowAlbedo(& call computeAlbedo(spectralSnowAlbedoDiffuse(ixVisible),refreshFactor,decayFactor,albedoMaxVisible,albedoMinVisible) call computeAlbedo(spectralSnowAlbedoDiffuse(ixNearIR), refreshFactor,decayFactor,albedoMaxNearIR, albedoMinNearIR) ! compute factor to modify direct albedo at low zenith angles - if(cosZenith < 0.5_summa_prec)then - fZen = (1._summa_prec/bPar)*( ((1._summa_prec + bPar)/(1._summa_prec + 2._summa_prec*bPar*cosZenith)) - 1._summa_prec) + if(cosZenith < 0.5_rk)then + fZen = (1._rk/bPar)*( ((1._rk + bPar)/(1._rk + 2._rk*bPar*cosZenith)) - 1._rk) else - fZen = 0._summa_prec + fZen = 0._rk end if ! compute direct albedo - spectralSnowAlbedoDirect(ixVisible) = spectralSnowAlbedoDiffuse(ixVisible) + 0.4_summa_prec*fZen*(1._summa_prec - spectralSnowAlbedoDiffuse(ixVisible)) - spectralSnowAlbedoDirect(ixNearIR) = spectralSnowAlbedoDiffuse(ixNearIR) + 0.4_summa_prec*fZen*(1._summa_prec - spectralSnowAlbedoDiffuse(ixNearIR)) + spectralSnowAlbedoDirect(ixVisible) = spectralSnowAlbedoDiffuse(ixVisible) + 0.4_rk*fZen*(1._rk - spectralSnowAlbedoDiffuse(ixVisible)) + spectralSnowAlbedoDirect(ixNearIR) = spectralSnowAlbedoDiffuse(ixNearIR) + 0.4_rk*fZen*(1._rk - spectralSnowAlbedoDiffuse(ixNearIR)) ! compute average albedo - scalarSnowAlbedo = ( Frad_direct)*(Frad_vis*spectralSnowAlbedoDirect(ixVisible) + (1._summa_prec - Frad_vis)*spectralSnowAlbedoDirect(ixNearIR) ) + & - (1._summa_prec - Frad_direct)*(Frad_vis*spectralSnowAlbedoDirect(ixVisible) + (1._summa_prec - Frad_vis)*spectralSnowAlbedoDirect(ixNearIR) ) + scalarSnowAlbedo = ( Frad_direct)*(Frad_vis*spectralSnowAlbedoDirect(ixVisible) + (1._rk - Frad_vis)*spectralSnowAlbedoDirect(ixNearIR) ) + & + (1._rk - Frad_direct)*(Frad_vis*spectralSnowAlbedoDirect(ixVisible) + (1._rk - Frad_vis)*spectralSnowAlbedoDirect(ixNearIR) ) ! check that we identified the albedo option case default; err=20; message=trim(message)//'unable to identify option for snow albedo'; return @@ -207,7 +207,7 @@ subroutine snowAlbedo(& end select ! identify option for snow albedo ! check - if(scalarSnowAlbedo < 0._summa_prec)then; err=20; message=trim(message)//'unable to identify option for snow albedo'; return; end if + if(scalarSnowAlbedo < 0._rk)then; err=20; message=trim(message)//'unable to identify option for snow albedo'; return; end if ! end association to data structures end associate @@ -221,15 +221,15 @@ end subroutine snowAlbedo subroutine computeAlbedo(snowAlbedo,refreshFactor,decayFactor,albedoMax,albedoMin) implicit none ! dummy variables - real(summa_prec),intent(inout) :: snowAlbedo ! snow albedo (-) - real(summa_prec),intent(in) :: refreshFactor ! albedo refreshment factor (-) - real(summa_prec),intent(in) :: decayFactor ! albedo decay factor (-) - real(summa_prec),intent(in) :: albedoMax ! maximum albedo (-) - real(summa_prec),intent(in) :: albedoMin ! minimum albedo (-) + real(rk),intent(inout) :: snowAlbedo ! snow albedo (-) + real(rk),intent(in) :: refreshFactor ! albedo refreshment factor (-) + real(rk),intent(in) :: decayFactor ! albedo decay factor (-) + real(rk),intent(in) :: albedoMax ! maximum albedo (-) + real(rk),intent(in) :: albedoMin ! minimum albedo (-) ! local variables - real(summa_prec) :: albedoChange ! change in albedo over the time step (-) + real(rk) :: albedoChange ! change in albedo over the time step (-) ! compute change in albedo - albedoChange = refreshFactor*(albedoMax - snowAlbedo) - (decayFactor*(snowAlbedo - albedoMin)) / (1._summa_prec + decayFactor) + albedoChange = refreshFactor*(albedoMax - snowAlbedo) - (decayFactor*(snowAlbedo - albedoMin)) / (1._rk + decayFactor) snowAlbedo = snowAlbedo + albedoChange if(snowAlbedo > albedoMax) snowAlbedo = albedoMax end subroutine computeAlbedo diff --git a/build/source/engine/snowLiqFlx.f90 b/build/source/engine/snowLiqFlx.f90 index 6708821f1..f0330d235 100755 --- a/build/source/engine/snowLiqFlx.f90 +++ b/build/source/engine/snowLiqFlx.f90 @@ -75,18 +75,18 @@ subroutine snowLiqFlx(& logical(lgt),intent(in) :: firstFluxCall ! the first flux call logical(lgt),intent(in) :: scalarSolution ! flag to denote if implementing the scalar solution ! input: forcing for the snow domain - real(summa_prec),intent(in) :: scalarThroughfallRain ! computed throughfall rate (kg m-2 s-1) - real(summa_prec),intent(in) :: scalarCanopyLiqDrainage ! computed drainage of liquid water (kg m-2 s-1) + real(rk),intent(in) :: scalarThroughfallRain ! computed throughfall rate (kg m-2 s-1) + real(rk),intent(in) :: scalarCanopyLiqDrainage ! computed drainage of liquid water (kg m-2 s-1) ! input: model state vector - real(summa_prec),intent(in) :: mLayerVolFracLiqTrial(:) ! trial value of volumetric fraction of liquid water at the current iteration (-) + real(rk),intent(in) :: mLayerVolFracLiqTrial(:) ! trial value of volumetric fraction of liquid water at the current iteration (-) ! input-output: data structures type(var_ilength),intent(in) :: indx_data ! model indices type(var_dlength),intent(in) :: mpar_data ! model parameters type(var_dlength),intent(in) :: prog_data ! prognostic variables for a local HRU type(var_dlength),intent(inout) :: diag_data ! diagnostic variables for a local HRU ! output: fluxes and derivatives - real(summa_prec),intent(inout) :: iLayerLiqFluxSnow(0:) ! vertical liquid water flux at layer interfaces (m s-1) - real(summa_prec),intent(inout) :: iLayerLiqFluxSnowDeriv(0:) ! derivative in vertical liquid water flux at layer interfaces (m s-1) + real(rk),intent(inout) :: iLayerLiqFluxSnow(0:) ! vertical liquid water flux at layer interfaces (m s-1) + real(rk),intent(inout) :: iLayerLiqFluxSnowDeriv(0:) ! derivative in vertical liquid water flux at layer interfaces (m s-1) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message @@ -96,12 +96,12 @@ subroutine snowLiqFlx(& integer(i4b) :: iLayer ! layer index integer(i4b) :: ixTop ! top layer in subroutine call integer(i4b) :: ixBot ! bottom layer in subroutine call - real(summa_prec) :: multResid ! multiplier for the residual water content (-) - real(summa_prec),parameter :: residThrs=550._summa_prec ! ice density threshold to reduce residual liquid water content (kg m-3) - real(summa_prec),parameter :: residScal=10._summa_prec ! scaling factor for residual liquid water content reduction factor (kg m-3) - real(summa_prec),parameter :: maxVolIceContent=0.7_summa_prec ! maximum volumetric ice content to store water (-) - real(summa_prec) :: availCap ! available storage capacity [0,1] (-) - real(summa_prec) :: relSaturn ! relative saturation [0,1] (-) + real(rk) :: multResid ! multiplier for the residual water content (-) + real(rk),parameter :: residThrs=550._rk ! ice density threshold to reduce residual liquid water content (kg m-3) + real(rk),parameter :: residScal=10._rk ! scaling factor for residual liquid water content reduction factor (kg m-3) + real(rk),parameter :: maxVolIceContent=0.7_rk ! maximum volumetric ice content to store water (-) + real(rk) :: availCap ! available storage capacity [0,1] (-) + real(rk) :: relSaturn ! relative saturation [0,1] (-) ! ------------------------------------------------------------------------------------------------------------------------------------------ ! make association of local variables with information in the data structures associate(& @@ -128,7 +128,7 @@ subroutine snowLiqFlx(& end if ! check the meltwater exponent is >=1 - if(mw_exp<1._summa_prec)then; err=20; message=trim(message)//'meltwater exponent < 1'; return; end if + if(mw_exp<1._rk)then; err=20; message=trim(message)//'meltwater exponent < 1'; return; end if ! get the indices for the snow+soil layers ixTop = integerMissing @@ -159,16 +159,16 @@ subroutine snowLiqFlx(& ! define the liquid flux at the upper boundary (m s-1) iLayerLiqFluxSnow(0) = (scalarThroughfallRain + scalarCanopyLiqDrainage)/iden_water - iLayerLiqFluxSnowDeriv(0) = 0._summa_prec + iLayerLiqFluxSnowDeriv(0) = 0._rk ! compute properties fixed over the time step if(firstFluxCall)then ! loop through snow layers do iLayer=1,nSnow ! compute the reduction in liquid water holding capacity at high snow density (-) - multResid = 1._summa_prec / ( 1._summa_prec + exp( (mLayerVolFracIce(iLayer)*iden_ice - residThrs) / residScal) ) + multResid = 1._rk / ( 1._rk + exp( (mLayerVolFracIce(iLayer)*iden_ice - residThrs) / residScal) ) ! compute the pore space (-) - mLayerPoreSpace(iLayer) = 1._summa_prec - mLayerVolFracIce(iLayer) + mLayerPoreSpace(iLayer) = 1._rk - mLayerVolFracIce(iLayer) ! compute the residual volumetric liquid water content (-) mLayerThetaResid(iLayer) = Fcapil*mLayerPoreSpace(iLayer) * multResid end do ! (looping through snow layers) @@ -182,14 +182,14 @@ subroutine snowLiqFlx(& availCap = mLayerPoreSpace(iLayer) - mLayerThetaResid(iLayer) ! available capacity relSaturn = (mLayerVolFracLiqTrial(iLayer) - mLayerThetaResid(iLayer)) / availCap ! relative saturation iLayerLiqFluxSnow(iLayer) = k_snow*relSaturn**mw_exp - iLayerLiqFluxSnowDeriv(iLayer) = ( (k_snow*mw_exp)/availCap ) * relSaturn**(mw_exp - 1._summa_prec) + iLayerLiqFluxSnowDeriv(iLayer) = ( (k_snow*mw_exp)/availCap ) * relSaturn**(mw_exp - 1._rk) if(mLayerVolFracIce(iLayer) > maxVolIceContent)then ! NOTE: use start-of-step ice content, to avoid convergence problems ! ** allow liquid water to pass through under very high ice density iLayerLiqFluxSnow(iLayer) = iLayerLiqFluxSnow(iLayer) + iLayerLiqFluxSnow(iLayer-1) !NOTE: derivative may need to be updated in future. end if else ! flow does not occur - iLayerLiqFluxSnow(iLayer) = 0._summa_prec - iLayerLiqFluxSnowDeriv(iLayer) = 0._summa_prec + iLayerLiqFluxSnow(iLayer) = 0._rk + iLayerLiqFluxSnowDeriv(iLayer) = 0._rk endif ! storage above residual content end do ! loop through snow layers diff --git a/build/source/engine/snow_utils.f90 b/build/source/engine/snow_utils.f90 index 6323d1ae1..5ceeab63e 100755 --- a/build/source/engine/snow_utils.f90 +++ b/build/source/engine/snow_utils.f90 @@ -47,11 +47,11 @@ module snow_utils_module ! *********************************************************************************************************** function fracliquid(Tk,fc_param) implicit none - real(summa_prec),intent(in) :: Tk ! temperature (K) - real(summa_prec),intent(in) :: fc_param ! freezing curve parameter (K-1) - real(summa_prec) :: fracliquid ! fraction of liquid water (-) + real(rk),intent(in) :: Tk ! temperature (K) + real(rk),intent(in) :: fc_param ! freezing curve parameter (K-1) + real(rk) :: fracliquid ! fraction of liquid water (-) ! compute fraction of liquid water (-) - fracliquid = 1._summa_prec / ( 1._summa_prec + (fc_param*( Tfreeze - min(Tk,Tfreeze) ))**2._summa_prec ) + fracliquid = 1._rk / ( 1._rk + (fc_param*( Tfreeze - min(Tk,Tfreeze) ))**2._rk ) end function fracliquid @@ -60,11 +60,11 @@ end function fracliquid ! *********************************************************************************************************** function templiquid(fracliquid,fc_param) implicit none - real(summa_prec),intent(in) :: fracliquid ! fraction of liquid water (-) - real(summa_prec),intent(in) :: fc_param ! freezing curve parameter (K-1) - real(summa_prec) :: templiquid ! temperature (K) + real(rk),intent(in) :: fracliquid ! fraction of liquid water (-) + real(rk),intent(in) :: fc_param ! freezing curve parameter (K-1) + real(rk) :: templiquid ! temperature (K) ! compute temperature based on the fraction of liquid water (K) - templiquid = Tfreeze - ((1._summa_prec/fracliquid - 1._summa_prec)/fc_param**2._summa_prec)**(0.5_summa_prec) + templiquid = Tfreeze - ((1._rk/fracliquid - 1._rk)/fc_param**2._rk)**(0.5_rk) end function templiquid @@ -74,17 +74,17 @@ end function templiquid function dFracLiq_dTk(Tk,fc_param) implicit none ! dummies - real(summa_prec),intent(in) :: Tk ! temperature (K) - real(summa_prec),intent(in) :: fc_param ! freezing curve parameter (K-1) - real(summa_prec) :: dFracLiq_dTk ! differentiate the freezing curve (K-1) + real(rk),intent(in) :: Tk ! temperature (K) + real(rk),intent(in) :: fc_param ! freezing curve parameter (K-1) + real(rk) :: dFracLiq_dTk ! differentiate the freezing curve (K-1) ! locals - real(summa_prec) :: Tdep ! temperature depression (K) - real(summa_prec) :: Tdim ! dimensionless temperature (-) + real(rk) :: Tdep ! temperature depression (K) + real(rk) :: Tdim ! dimensionless temperature (-) ! compute local variables (just to make things more efficient) Tdep = Tfreeze - min(Tk,Tfreeze) Tdim = fc_param*Tdep ! differentiate the freezing curve w.r.t temperature - dFracLiq_dTk = (fc_param*2._summa_prec*Tdim) / ( ( 1._summa_prec + Tdim**2._summa_prec)**2._summa_prec ) + dFracLiq_dTk = (fc_param*2._rk*Tdim) / ( ( 1._rk + Tdim**2._rk)**2._rk ) end function dFracLiq_dTk @@ -93,17 +93,17 @@ end function dFracLiq_dTk ! *********************************************************************************************************** subroutine tcond_snow(BulkDenIce,thermlcond,err,message) implicit none - real(summa_prec),intent(in) :: BulkDenIce ! bulk density of ice (kg m-3) - real(summa_prec),intent(out) :: thermlcond ! thermal conductivity of snow (W m-1 K-1) + real(rk),intent(in) :: BulkDenIce ! bulk density of ice (kg m-3) + real(rk),intent(out) :: thermlcond ! thermal conductivity of snow (W m-1 K-1) integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! initialize error control err=0; message="tcond_snow/" ! compute thermal conductivity of snow select case(model_decisions(iLookDECISIONS%thCondSnow)%iDecision) - case(Yen1965); thermlcond = 3.217d-6 * BulkDenIce**2._summa_prec ! Yen (1965) - case(Mellor1977); thermlcond = 2.576d-6 * BulkDenIce**2._summa_prec + 7.4d-2 ! Mellor (1977) - case(Jordan1991); thermlcond = lambda_air + (7.75d-5*BulkDenIce + 1.105d-6*(BulkDenIce**2._summa_prec)) & + case(Yen1965); thermlcond = 3.217d-6 * BulkDenIce**2._rk ! Yen (1965) + case(Mellor1977); thermlcond = 2.576d-6 * BulkDenIce**2._rk + 7.4d-2 ! Mellor (1977) + case(Jordan1991); thermlcond = lambda_air + (7.75d-5*BulkDenIce + 1.105d-6*(BulkDenIce**2._rk)) & * (lambda_ice-lambda_air) ! Jordan (1991) case default err=10; message=trim(message)//"unknownOption"; return diff --git a/build/source/engine/snwCompact.f90 b/build/source/engine/snwCompact.f90 index 570caaf08..e15ea8637 100755 --- a/build/source/engine/snwCompact.f90 +++ b/build/source/engine/snwCompact.f90 @@ -65,43 +65,43 @@ subroutine snwDensify(& ! compute change in snow density over the time step implicit none ! intent(in): variables - real(summa_prec),intent(in) :: dt ! time step (seconds) + real(rk),intent(in) :: dt ! time step (seconds) integer(i4b),intent(in) :: nSnow ! number of snow layers - real(summa_prec),intent(in) :: mLayerTemp(:) ! temperature of each snow layer after iterations (K) - real(summa_prec),intent(in) :: mLayerMeltFreeze(:) ! volumetric melt in each layer (kg m-3) + real(rk),intent(in) :: mLayerTemp(:) ! temperature of each snow layer after iterations (K) + real(rk),intent(in) :: mLayerMeltFreeze(:) ! volumetric melt in each layer (kg m-3) ! intent(in): parameters - real(summa_prec),intent(in) :: densScalGrowth ! density scaling factor for grain growth (kg-1 m3) - real(summa_prec),intent(in) :: tempScalGrowth ! temperature scaling factor for grain growth (K-1) - real(summa_prec),intent(in) :: grainGrowthRate ! rate of grain growth (s-1) - real(summa_prec),intent(in) :: densScalOvrbdn ! density scaling factor for overburden pressure (kg-1 m3) - real(summa_prec),intent(in) :: tempScalOvrbdn ! temperature scaling factor for overburden pressure (K-1) - real(summa_prec),intent(in) :: baseViscosity ! viscosity coefficient at T=T_frz and snow density=0 (kg m-2 s) + real(rk),intent(in) :: densScalGrowth ! density scaling factor for grain growth (kg-1 m3) + real(rk),intent(in) :: tempScalGrowth ! temperature scaling factor for grain growth (K-1) + real(rk),intent(in) :: grainGrowthRate ! rate of grain growth (s-1) + real(rk),intent(in) :: densScalOvrbdn ! density scaling factor for overburden pressure (kg-1 m3) + real(rk),intent(in) :: tempScalOvrbdn ! temperature scaling factor for overburden pressure (K-1) + real(rk),intent(in) :: baseViscosity ! viscosity coefficient at T=T_frz and snow density=0 (kg m-2 s) ! intent(inout): state variables - real(summa_prec),intent(inout) :: mLayerDepth(:) ! depth of each layer (m) - real(summa_prec),intent(inout) :: mLayerVolFracLiqNew(:) ! volumetric fraction of liquid water in each snow layer after iterations (-) - real(summa_prec),intent(inout) :: mLayerVolFracIceNew(:) ! volumetric fraction of ice in each snow layer after iterations (-) + real(rk),intent(inout) :: mLayerDepth(:) ! depth of each layer (m) + real(rk),intent(inout) :: mLayerVolFracLiqNew(:) ! volumetric fraction of liquid water in each snow layer after iterations (-) + real(rk),intent(inout) :: mLayerVolFracIceNew(:) ! volumetric fraction of ice in each snow layer after iterations (-) ! intent(out): error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! ----------------------------------------------------------------------------------------------------------------------------------------- ! define local variables integer(i4b) :: iSnow ! index of snow layers - real(summa_prec) :: chi1,chi2,chi3,chi4,chi5 ! multipliers in the densification algorithm (-) - real(summa_prec) :: halfWeight ! half of the weight of the current snow layer (kg m-2) - real(summa_prec) :: weightSnow ! total weight of snow above the current snow layer (kg m-2) - real(summa_prec) :: CR_grainGrowth ! compaction rate for grain growth (s-1) - real(summa_prec) :: CR_ovrvdnPress ! compaction rate associated with over-burden pressure (s-1) - real(summa_prec) :: CR_metamorph ! compaction rate for metamorphism (s-1) - real(summa_prec) :: massIceOld ! mass of ice in the snow layer (kg m-2) - real(summa_prec) :: massLiqOld ! mass of liquid water in the snow layer (kg m-2) - real(summa_prec) :: scalarDepthNew ! updated layer depth (m) - real(summa_prec) :: scalarDepthMin ! minimum layer depth (m) - real(summa_prec) :: volFracIceLoss ! volumetric fraction of ice lost due to melt and sublimation (-) - real(summa_prec), dimension(nSnow) :: mLayerVolFracAirNew ! volumetric fraction of air in each layer after compaction (-) - real(summa_prec),parameter :: snwden_min=100._summa_prec ! minimum snow density for reducing metamorphism rate (kg m-3) - real(summa_prec),parameter :: snwDensityMax=550._summa_prec ! maximum snow density for collapse under melt (kg m-3) - real(summa_prec),parameter :: wetSnowThresh=0.01_summa_prec ! threshold to discriminate between "wet" and "dry" snow - real(summa_prec),parameter :: minLayerDensity=40._summa_prec ! minimum snow density allowed for any layer (kg m-3) + real(rk) :: chi1,chi2,chi3,chi4,chi5 ! multipliers in the densification algorithm (-) + real(rk) :: halfWeight ! half of the weight of the current snow layer (kg m-2) + real(rk) :: weightSnow ! total weight of snow above the current snow layer (kg m-2) + real(rk) :: CR_grainGrowth ! compaction rate for grain growth (s-1) + real(rk) :: CR_ovrvdnPress ! compaction rate associated with over-burden pressure (s-1) + real(rk) :: CR_metamorph ! compaction rate for metamorphism (s-1) + real(rk) :: massIceOld ! mass of ice in the snow layer (kg m-2) + real(rk) :: massLiqOld ! mass of liquid water in the snow layer (kg m-2) + real(rk) :: scalarDepthNew ! updated layer depth (m) + real(rk) :: scalarDepthMin ! minimum layer depth (m) + real(rk) :: volFracIceLoss ! volumetric fraction of ice lost due to melt and sublimation (-) + real(rk), dimension(nSnow) :: mLayerVolFracAirNew ! volumetric fraction of air in each layer after compaction (-) + real(rk),parameter :: snwden_min=100._rk ! minimum snow density for reducing metamorphism rate (kg m-3) + real(rk),parameter :: snwDensityMax=550._rk ! maximum snow density for collapse under melt (kg m-3) + real(rk),parameter :: wetSnowThresh=0.01_rk ! threshold to discriminate between "wet" and "dry" snow + real(rk),parameter :: minLayerDensity=40._rk ! minimum snow density allowed for any layer (kg m-3) ! ----------------------------------------------------------------------------------------------------------------------------------------- ! initialize error control err=0; message="snwDensify/" @@ -110,7 +110,7 @@ subroutine snwDensify(& if(nSnow==0)return ! initialize the weight of snow above each layer (kg m-2) - weightSnow = 0._summa_prec + weightSnow = 0._rk ! loop through snow layers do iSnow=1,nSnow @@ -124,19 +124,19 @@ subroutine snwDensify(& ! *** compute the compaction associated with grain growth (s-1) ! compute the base rate of grain growth (-) - if(mLayerVolFracIceNew(iSnow)*iden_ice =snwden_min) chi1=exp(-densScalGrowth*(mLayerVolFracIceNew(iSnow)*iden_ice - snwden_min)) ! compute the reduction of grain growth under colder snow temperatures (-) chi2 = exp(-tempScalGrowth*(Tfreeze - mLayerTemp(iSnow))) ! compute the acceleration of grain growth in the presence of liquid water (-) - if(mLayerVolFracLiqNew(iSnow) > wetSnowThresh)then; chi3=2._summa_prec ! snow is "wet" - else; chi3=1._summa_prec; end if ! snow is "dry" + if(mLayerVolFracLiqNew(iSnow) > wetSnowThresh)then; chi3=2._rk ! snow is "wet" + else; chi3=1._rk; end if ! snow is "dry" ! compute the compaction associated with grain growth (s-1) CR_grainGrowth = grainGrowthRate*chi1*chi2*chi3 ! **** compute the compaction associated with over-burden pressure (s-1) ! compute the weight imposed on the current layer (kg m-2) - halfWeight = (massIceOld + massLiqOld)/2._summa_prec ! there is some over-burden pressure from the layer itself + halfWeight = (massIceOld + massLiqOld)/2._rk ! there is some over-burden pressure from the layer itself weightSnow = weightSnow + halfweight ! add half of the weight from the current layer ! compute the increase in compaction under colder snow temperatures (-) chi4 = exp(-tempScalOvrbdn*(Tfreeze - mLayerTemp(iSnow))) @@ -151,7 +151,7 @@ subroutine snwDensify(& ! NOTE: loss of ice due to snowmelt is implicit, so can be updated directly if(iden_ice*mLayerVolFracIceNew(iSnow) < snwDensityMax)then ! only collapse layers if below a critical density ! (compute volumetric losses of ice due to melt and sublimation) - volFracIceLoss = max(0._summa_prec,mLayerMeltFreeze(iSnow)/iden_ice) ! volumetric fraction of ice lost due to melt (-) + volFracIceLoss = max(0._rk,mLayerMeltFreeze(iSnow)/iden_ice) ! volumetric fraction of ice lost due to melt (-) ! (adjust snow depth to account for cavitation) scalarDepthNew = mLayerDepth(iSnow) * mLayerVolFracIceNew(iSnow)/(mLayerVolFracIceNew(iSnow) + volFracIceLoss) !print*, 'volFracIceLoss = ', volFracIceLoss @@ -163,12 +163,12 @@ subroutine snwDensify(& ! update depth due to metamorphism (implicit solution) ! Ensure that the new depth is in line with the maximum amount of compaction that ! can occur given the masses of ice and liquid in the layer - scalarDepthNew = scalarDepthNew/(1._summa_prec + CR_metamorph*dt) + scalarDepthNew = scalarDepthNew/(1._rk + CR_metamorph*dt) scalarDepthMin = (massIceOld / iden_ice) + (massLiqOld / iden_water) mLayerDepth(iSnow) = max(scalarDepthMin, scalarDepthNew) ! check that depth is reasonable - if(mLayerDepth(iSnow) < 0._summa_prec)then + if(mLayerDepth(iSnow) < 0._rk)then write(*,'(a,1x,i4,1x,10(f12.5,1x))') 'iSnow, dt, density,massIceOld, massLiqOld = ', iSnow, dt, mLayerVolFracIceNew(iSnow)*iden_ice, massIceOld, massLiqOld write(*,'(a,1x,i4,1x,10(f12.5,1x))') 'iSnow, mLayerDepth(iSnow), scalarDepthNew, mLayerVolFracIceNew(iSnow), mLayerMeltFreeze(iSnow), CR_grainGrowth*dt, CR_ovrvdnPress*dt = ', & iSnow, mLayerDepth(iSnow), scalarDepthNew, mLayerVolFracIceNew(iSnow), mLayerMeltFreeze(iSnow), CR_grainGrowth*dt, CR_ovrvdnPress*dt @@ -177,14 +177,14 @@ subroutine snwDensify(& ! update volumetric ice and liquid water content mLayerVolFracIceNew(iSnow) = massIceOld/(mLayerDepth(iSnow)*iden_ice) mLayerVolFracLiqNew(iSnow) = massLiqOld/(mLayerDepth(iSnow)*iden_water) - mLayerVolFracAirNew(iSnow) = 1.0_summa_prec - mLayerVolFracIceNew(iSnow) - mLayerVolFracLiqNew(iSnow) + mLayerVolFracAirNew(iSnow) = 1.0_rk - mLayerVolFracIceNew(iSnow) - mLayerVolFracLiqNew(iSnow) !write(*,'(a,1x,i4,1x,f9.3)') 'after compact: iSnow, density = ', iSnow, mLayerVolFracIceNew(iSnow)*iden_ice - !if(mLayerMeltFreeze(iSnow) > 20._summa_prec) pause 'meaningful melt' + !if(mLayerMeltFreeze(iSnow) > 20._rk) pause 'meaningful melt' end do ! looping through snow layers ! check depth - if(any(mLayerDepth(1:nSnow) < 0._summa_prec))then + if(any(mLayerDepth(1:nSnow) < 0._rk))then do iSnow=1,nSnow write(*,'(a,1x,i4,1x,4(f12.5,1x))') 'iSnow, mLayerDepth(iSnow)', iSnow, mLayerDepth(iSnow) end do @@ -194,7 +194,7 @@ subroutine snwDensify(& ! check for low/high snow density if(any(mLayerVolFracIceNew(1:nSnow)*iden_ice + mLayerVolFracLiqNew(1:nSnow)*iden_water + mLayerVolFracAirNew(1:nSnow)*iden_air < minLayerDensity) .or. & - any(mLayerVolFracIceNew(1:nSnow) + mLayerVolFracLiqNew(1:nSnow) + mLayerVolFracAirNew(1:nSnow) > 1._summa_prec))then + any(mLayerVolFracIceNew(1:nSnow) + mLayerVolFracLiqNew(1:nSnow) + mLayerVolFracAirNew(1:nSnow) > 1._rk))then do iSnow=1,nSnow write(*,*) 'iSnow, volFracIce, density = ', iSnow, mLayerVolFracIceNew(iSnow), mLayerVolFracIceNew(iSnow)*iden_ice end do diff --git a/build/source/engine/soilLiqFlx.f90 b/build/source/engine/soilLiqFlx.f90 index 40e2dd8e4..5837b300d 100755 --- a/build/source/engine/soilLiqFlx.f90 +++ b/build/source/engine/soilLiqFlx.f90 @@ -80,8 +80,8 @@ module soilLiqFlx_module private public::soilLiqFlx ! constant parameters -real(summa_prec),parameter :: verySmall=1.e-12_summa_prec ! a very small number (used to avoid divide by zero) -real(summa_prec),parameter :: dx=1.e-8_summa_prec ! finite difference increment +real(rk),parameter :: verySmall=1.e-12_rk ! a very small number (used to avoid divide by zero) +real(rk),parameter :: dx=1.e-8_rk ! finite difference increment contains @@ -150,17 +150,17 @@ subroutine soilLiqFlx(& logical(lgt),intent(in) :: scalarSolution ! flag to denote if implementing the scalar solution logical(lgt),intent(in) :: deriv_desired ! flag indicating if derivatives are desired ! input: trial model state variables - real(summa_prec),intent(in) :: mLayerTempTrial(:) ! temperature in each layer at the current iteration (m) - real(summa_prec),intent(in) :: mLayerMatricHeadTrial(:) ! matric head in each layer at the current iteration (m) - real(summa_prec),intent(in) :: mLayerVolFracLiqTrial(:) ! volumetric fraction of liquid water at the current iteration (-) - real(summa_prec),intent(in) :: mLayerVolFracIceTrial(:) ! volumetric fraction of ice at the current iteration (-) + real(rk),intent(in) :: mLayerTempTrial(:) ! temperature in each layer at the current iteration (m) + real(rk),intent(in) :: mLayerMatricHeadTrial(:) ! matric head in each layer at the current iteration (m) + real(rk),intent(in) :: mLayerVolFracLiqTrial(:) ! volumetric fraction of liquid water at the current iteration (-) + real(rk),intent(in) :: mLayerVolFracIceTrial(:) ! volumetric fraction of ice at the current iteration (-) ! input: pre-computed derivatves - real(summa_prec),intent(in) :: mLayerdTheta_dTk(:) ! derivative in volumetric liquid water content w.r.t. temperature (K-1) - real(summa_prec),intent(in) :: dPsiLiq_dTemp(:) ! derivative in liquid water matric potential w.r.t. temperature (m K-1) + real(rk),intent(in) :: mLayerdTheta_dTk(:) ! derivative in volumetric liquid water content w.r.t. temperature (K-1) + real(rk),intent(in) :: dPsiLiq_dTemp(:) ! derivative in liquid water matric potential w.r.t. temperature (m K-1) ! input: model fluxes - real(summa_prec),intent(in) :: scalarCanopyTranspiration ! canopy transpiration (kg m-2 s-1) - real(summa_prec),intent(in) :: scalarGroundEvaporation ! ground evaporation (kg m-2 s-1) - real(summa_prec),intent(in) :: scalarRainPlusMelt ! rain plus melt (m s-1) + real(rk),intent(in) :: scalarCanopyTranspiration ! canopy transpiration (kg m-2 s-1) + real(rk),intent(in) :: scalarGroundEvaporation ! ground evaporation (kg m-2 s-1) + real(rk),intent(in) :: scalarRainPlusMelt ! rain plus melt (m s-1) ! input-output: data structures type(var_dlength),intent(in) :: mpar_data ! model parameters type(var_ilength),intent(in) :: indx_data ! state vector geometry @@ -168,25 +168,25 @@ subroutine soilLiqFlx(& type(var_dlength),intent(inout) :: diag_data ! diagnostic variables for a local HRU type(var_dlength),intent(inout) :: flux_data ! model fluxes for a local HRU ! output: diagnostic variables for surface runoff - real(summa_prec),intent(inout) :: xMaxInfilRate ! maximum infiltration rate (m s-1) - real(summa_prec),intent(inout) :: scalarInfilArea ! fraction of unfrozen area where water can infiltrate (-) - real(summa_prec),intent(inout) :: scalarFrozenArea ! fraction of area that is considered impermeable due to soil ice (-) - real(summa_prec),intent(inout) :: scalarSurfaceRunoff ! surface runoff (m s-1) + real(rk),intent(inout) :: xMaxInfilRate ! maximum infiltration rate (m s-1) + real(rk),intent(inout) :: scalarInfilArea ! fraction of unfrozen area where water can infiltrate (-) + real(rk),intent(inout) :: scalarFrozenArea ! fraction of area that is considered impermeable due to soil ice (-) + real(rk),intent(inout) :: scalarSurfaceRunoff ! surface runoff (m s-1) ! output: diagnostic variables for each layer - real(summa_prec),intent(inout) :: mLayerdTheta_dPsi(:) ! derivative in the soil water characteristic w.r.t. psi (m-1) - real(summa_prec),intent(inout) :: mLayerdPsi_dTheta(:) ! derivative in the soil water characteristic w.r.t. theta (m) - real(summa_prec),intent(inout) :: dHydCond_dMatric(:) ! derivative in hydraulic conductivity w.r.t matric head (s-1) + real(rk),intent(inout) :: mLayerdTheta_dPsi(:) ! derivative in the soil water characteristic w.r.t. psi (m-1) + real(rk),intent(inout) :: mLayerdPsi_dTheta(:) ! derivative in the soil water characteristic w.r.t. theta (m) + real(rk),intent(inout) :: dHydCond_dMatric(:) ! derivative in hydraulic conductivity w.r.t matric head (s-1) ! output: liquid fluxes - real(summa_prec),intent(inout) :: scalarSurfaceInfiltration ! surface infiltration rate (m s-1) - real(summa_prec),intent(inout) :: iLayerLiqFluxSoil(0:) ! liquid flux at soil layer interfaces (m s-1) - real(summa_prec),intent(inout) :: mLayerTranspire(:) ! transpiration loss from each soil layer (m s-1) - real(summa_prec),intent(inout) :: mLayerHydCond(:) ! hydraulic conductivity in each soil layer (m s-1) + real(rk),intent(inout) :: scalarSurfaceInfiltration ! surface infiltration rate (m s-1) + real(rk),intent(inout) :: iLayerLiqFluxSoil(0:) ! liquid flux at soil layer interfaces (m s-1) + real(rk),intent(inout) :: mLayerTranspire(:) ! transpiration loss from each soil layer (m s-1) + real(rk),intent(inout) :: mLayerHydCond(:) ! hydraulic conductivity in each soil layer (m s-1) ! output: derivatives in fluxes w.r.t. state variables in the layer above and layer below (m s-1) - real(summa_prec),intent(inout) :: dq_dHydStateAbove(0:) ! derivative in the flux in layer interfaces w.r.t. state variables in the layer above - real(summa_prec),intent(inout) :: dq_dHydStateBelow(0:) ! derivative in the flux in layer interfaces w.r.t. state variables in the layer below + real(rk),intent(inout) :: dq_dHydStateAbove(0:) ! derivative in the flux in layer interfaces w.r.t. state variables in the layer above + real(rk),intent(inout) :: dq_dHydStateBelow(0:) ! derivative in the flux in layer interfaces w.r.t. state variables in the layer below ! output: derivatives in fluxes w.r.t. energy state variables -- now just temperature -- in the layer above and layer below (m s-1 K-1) - real(summa_prec),intent(inout) :: dq_dNrgStateAbove(0:) ! derivatives in the flux w.r.t. temperature in the layer above (m s-1 K-1) - real(summa_prec),intent(inout) :: dq_dNrgStateBelow(0:) ! derivatives in the flux w.r.t. temperature in the layer below (m s-1 K-1) + real(rk),intent(inout) :: dq_dNrgStateAbove(0:) ! derivatives in the flux w.r.t. temperature in the layer above (m s-1 K-1) + real(rk),intent(inout) :: dq_dNrgStateBelow(0:) ! derivatives in the flux w.r.t. temperature in the layer below (m s-1 K-1) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message @@ -208,34 +208,34 @@ subroutine soilLiqFlx(& integer(i4b),parameter :: perturbStateBelow=3 ! named variable to identify the case where we perturb the state layer below integer(i4b) :: ixPerturb ! index of element in 2-element vector to perturb integer(i4b) :: ixOriginal ! index of perturbed element in the original vector - real(summa_prec) :: scalarVolFracLiqTrial ! trial value of volumetric liquid water content (-) - real(summa_prec) :: scalarMatricHeadTrial ! trial value of matric head (m) - real(summa_prec) :: scalarHydCondTrial ! trial value of hydraulic conductivity (m s-1) - real(summa_prec) :: scalarHydCondMicro ! trial value of hydraulic conductivity of micropores (m s-1) - real(summa_prec) :: scalarHydCondMacro ! trial value of hydraulic conductivity of macropores (m s-1) - real(summa_prec) :: scalarFlux ! vertical flux (m s-1) - real(summa_prec) :: scalarFlux_dStateAbove ! vertical flux with perturbation to the state above (m s-1) - real(summa_prec) :: scalarFlux_dStateBelow ! vertical flux with perturbation to the state below (m s-1) + real(rk) :: scalarVolFracLiqTrial ! trial value of volumetric liquid water content (-) + real(rk) :: scalarMatricHeadTrial ! trial value of matric head (m) + real(rk) :: scalarHydCondTrial ! trial value of hydraulic conductivity (m s-1) + real(rk) :: scalarHydCondMicro ! trial value of hydraulic conductivity of micropores (m s-1) + real(rk) :: scalarHydCondMacro ! trial value of hydraulic conductivity of macropores (m s-1) + real(rk) :: scalarFlux ! vertical flux (m s-1) + real(rk) :: scalarFlux_dStateAbove ! vertical flux with perturbation to the state above (m s-1) + real(rk) :: scalarFlux_dStateBelow ! vertical flux with perturbation to the state below (m s-1) ! transpiration sink term - real(summa_prec),dimension(nSoil) :: mLayerTranspireFrac ! fraction of transpiration allocated to each soil layer (-) + real(rk),dimension(nSoil) :: mLayerTranspireFrac ! fraction of transpiration allocated to each soil layer (-) ! diagnostic variables - real(summa_prec),dimension(nSoil) :: iceImpedeFac ! ice impedence factor at layer mid-points (-) - real(summa_prec),dimension(nSoil) :: mLayerDiffuse ! diffusivity at layer mid-point (m2 s-1) - real(summa_prec),dimension(nSoil) :: dHydCond_dVolLiq ! derivative in hydraulic conductivity w.r.t volumetric liquid water content (m s-1) - real(summa_prec),dimension(nSoil) :: dDiffuse_dVolLiq ! derivative in hydraulic diffusivity w.r.t volumetric liquid water content (m2 s-1) - real(summa_prec),dimension(nSoil) :: dHydCond_dTemp ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) - real(summa_prec),dimension(0:nSoil) :: iLayerHydCond ! hydraulic conductivity at layer interface (m s-1) - real(summa_prec),dimension(0:nSoil) :: iLayerDiffuse ! diffusivity at layer interface (m2 s-1) + real(rk),dimension(nSoil) :: iceImpedeFac ! ice impedence factor at layer mid-points (-) + real(rk),dimension(nSoil) :: mLayerDiffuse ! diffusivity at layer mid-point (m2 s-1) + real(rk),dimension(nSoil) :: dHydCond_dVolLiq ! derivative in hydraulic conductivity w.r.t volumetric liquid water content (m s-1) + real(rk),dimension(nSoil) :: dDiffuse_dVolLiq ! derivative in hydraulic diffusivity w.r.t volumetric liquid water content (m2 s-1) + real(rk),dimension(nSoil) :: dHydCond_dTemp ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) + real(rk),dimension(0:nSoil) :: iLayerHydCond ! hydraulic conductivity at layer interface (m s-1) + real(rk),dimension(0:nSoil) :: iLayerDiffuse ! diffusivity at layer interface (m2 s-1) ! compute surface flux integer(i4b) :: nRoots ! number of soil layers with roots integer(i4b) :: ixIce ! index of the lowest soil layer that contains ice - real(summa_prec),dimension(0:nSoil) :: iLayerHeight ! height of the layer interfaces (m) + real(rk),dimension(0:nSoil) :: iLayerHeight ! height of the layer interfaces (m) ! compute fluxes and derivatives at layer interfaces - real(summa_prec),dimension(2) :: vectorVolFracLiqTrial ! trial value of volumetric liquid water content (-) - real(summa_prec),dimension(2) :: vectorMatricHeadTrial ! trial value of matric head (m) - real(summa_prec),dimension(2) :: vectorHydCondTrial ! trial value of hydraulic conductivity (m s-1) - real(summa_prec),dimension(2) :: vectorDiffuseTrial ! trial value of hydraulic diffusivity (m2 s-1) - real(summa_prec) :: scalardPsi_dTheta ! derivative in soil water characteristix, used for perturbations when computing numerical derivatives + real(rk),dimension(2) :: vectorVolFracLiqTrial ! trial value of volumetric liquid water content (-) + real(rk),dimension(2) :: vectorMatricHeadTrial ! trial value of matric head (m) + real(rk),dimension(2) :: vectorHydCondTrial ! trial value of hydraulic conductivity (m s-1) + real(rk),dimension(2) :: vectorDiffuseTrial ! trial value of hydraulic diffusivity (m2 s-1) + real(rk) :: scalardPsi_dTheta ! derivative in soil water characteristix, used for perturbations when computing numerical derivatives ! ------------------------------------------------------------------------------------------------------------------------------------------------- ! initialize error control err=0; message='soilLiqFlx/' @@ -364,7 +364,7 @@ subroutine soilLiqFlx(& end if ! check fractions sum to one - if(abs(sum(mLayerTranspireFrac) - 1._summa_prec) > verySmall)then + if(abs(sum(mLayerTranspireFrac) - 1._rk) > verySmall)then message=trim(message)//'fraction transpiration in soil layers does not sum to one' err=20; return endif @@ -373,7 +373,7 @@ subroutine soilLiqFlx(& mLayerTranspire = mLayerTranspireFrac(:)*scalarCanopyTranspiration/iden_water ! special case of prescribed head -- no transpiration - if(ixBcUpperSoilHydrology==prescribedHead) mLayerTranspire(:) = 0._summa_prec + if(ixBcUpperSoilHydrology==prescribedHead) mLayerTranspire(:) = 0._rk endif ! if need to compute transpiration @@ -435,8 +435,8 @@ subroutine soilLiqFlx(& ! ------------------------------------------------------------------------------------------------------------------------------------------------- ! set derivative w.r.t. state above to zero (does not exist) - dq_dHydStateAbove(0) = 0._summa_prec - dq_dNrgStateAbove(0) = 0._summa_prec + dq_dHydStateAbove(0) = 0._rk + dq_dNrgStateAbove(0) = 0._rk ! either one or multiple flux calls, depending on if using analytical or numerical derivatives do itry=nFlux,0,-1 ! (work backwards to ensure all computed fluxes come from the un-perturbed case) @@ -821,8 +821,8 @@ subroutine soilLiqFlx(& end if ! no dependence on the aquifer for drainage - dq_dHydStateBelow(nSoil) = 0._summa_prec ! keep this here in case we want to couple some day.... - dq_dNrgStateBelow(nSoil) = 0._summa_prec ! keep this here in case we want to couple some day.... + dq_dHydStateBelow(nSoil) = 0._rk ! keep this here in case we want to couple some day.... + dq_dNrgStateBelow(nSoil) = 0._rk ! keep this here in case we want to couple some day.... ! print drainage !print*, 'iLayerLiqFluxSoil(nSoil) = ', iLayerLiqFluxSoil(nSoil) @@ -897,66 +897,66 @@ subroutine diagv_node(& logical(lgt),intent(in) :: deriv_desired ! flag indicating if derivatives are desired integer(i4b),intent(in) :: ixRichards ! index defining the option for Richards' equation (moisture or mixdform) ! input: state and diagnostic variables - real(summa_prec),intent(in) :: scalarTempTrial ! temperature in each layer (K) - real(summa_prec),intent(in) :: scalarMatricHeadTrial ! matric head in each layer (m) - real(summa_prec),intent(in) :: scalarVolFracLiqTrial ! volumetric fraction of liquid water in a given layer (-) - real(summa_prec),intent(in) :: scalarVolFracIceTrial ! volumetric fraction of ice in a given layer (-) + real(rk),intent(in) :: scalarTempTrial ! temperature in each layer (K) + real(rk),intent(in) :: scalarMatricHeadTrial ! matric head in each layer (m) + real(rk),intent(in) :: scalarVolFracLiqTrial ! volumetric fraction of liquid water in a given layer (-) + real(rk),intent(in) :: scalarVolFracIceTrial ! volumetric fraction of ice in a given layer (-) ! input: pre-computed deriavatives - real(summa_prec),intent(in) :: dTheta_dTk ! derivative in volumetric liquid water content w.r.t. temperature (K-1) - real(summa_prec),intent(in) :: dPsiLiq_dTemp ! derivative in liquid water matric potential w.r.t. temperature (m K-1) + real(rk),intent(in) :: dTheta_dTk ! derivative in volumetric liquid water content w.r.t. temperature (K-1) + real(rk),intent(in) :: dPsiLiq_dTemp ! derivative in liquid water matric potential w.r.t. temperature (m K-1) ! input: soil parameters - real(summa_prec),intent(in) :: vGn_alpha ! van Genutchen "alpha" parameter (m-1) - real(summa_prec),intent(in) :: vGn_n ! van Genutchen "n" parameter (-) - real(summa_prec),intent(in) :: vGn_m ! van Genutchen "m" parameter (-) - real(summa_prec),intent(in) :: mpExp ! empirical exponent in macropore flow equation (-) - real(summa_prec),intent(in) :: theta_sat ! soil porosity (-) - real(summa_prec),intent(in) :: theta_res ! soil residual volumetric water content (-) - real(summa_prec),intent(in) :: theta_mp ! volumetric liquid water content when macropore flow begins (-) - real(summa_prec),intent(in) :: f_impede ! ice impedence factor (-) + real(rk),intent(in) :: vGn_alpha ! van Genutchen "alpha" parameter (m-1) + real(rk),intent(in) :: vGn_n ! van Genutchen "n" parameter (-) + real(rk),intent(in) :: vGn_m ! van Genutchen "m" parameter (-) + real(rk),intent(in) :: mpExp ! empirical exponent in macropore flow equation (-) + real(rk),intent(in) :: theta_sat ! soil porosity (-) + real(rk),intent(in) :: theta_res ! soil residual volumetric water content (-) + real(rk),intent(in) :: theta_mp ! volumetric liquid water content when macropore flow begins (-) + real(rk),intent(in) :: f_impede ! ice impedence factor (-) ! input: saturated hydraulic conductivity - real(summa_prec),intent(in) :: scalarSatHydCond ! saturated hydraulic conductivity at the mid-point of a given layer (m s-1) - real(summa_prec),intent(in) :: scalarSatHydCondMP ! saturated hydraulic conductivity of macropores at the mid-point of a given layer (m s-1) + real(rk),intent(in) :: scalarSatHydCond ! saturated hydraulic conductivity at the mid-point of a given layer (m s-1) + real(rk),intent(in) :: scalarSatHydCondMP ! saturated hydraulic conductivity of macropores at the mid-point of a given layer (m s-1) ! output: derivative in the soil water characteristic - real(summa_prec),intent(out) :: scalardPsi_dTheta ! derivative in the soil water characteristic - real(summa_prec),intent(out) :: scalardTheta_dPsi ! derivative in the soil water characteristic + real(rk),intent(out) :: scalardPsi_dTheta ! derivative in the soil water characteristic + real(rk),intent(out) :: scalardTheta_dPsi ! derivative in the soil water characteristic ! output: transmittance - real(summa_prec),intent(out) :: scalarHydCond ! hydraulic conductivity at layer mid-points (m s-1) - real(summa_prec),intent(out) :: scalarDiffuse ! diffusivity at layer mid-points (m2 s-1) - real(summa_prec),intent(out) :: iceImpedeFac ! ice impedence factor in each layer (-) + real(rk),intent(out) :: scalarHydCond ! hydraulic conductivity at layer mid-points (m s-1) + real(rk),intent(out) :: scalarDiffuse ! diffusivity at layer mid-points (m2 s-1) + real(rk),intent(out) :: iceImpedeFac ! ice impedence factor in each layer (-) ! output: transmittance derivatives - real(summa_prec),intent(out) :: dHydCond_dVolLiq ! derivative in hydraulic conductivity w.r.t volumetric liquid water content (m s-1) - real(summa_prec),intent(out) :: dDiffuse_dVolLiq ! derivative in hydraulic diffusivity w.r.t volumetric liquid water content (m2 s-1) - real(summa_prec),intent(out) :: dHydCond_dMatric ! derivative in hydraulic conductivity w.r.t matric head (s-1) - real(summa_prec),intent(out) :: dHydCond_dTemp ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) + real(rk),intent(out) :: dHydCond_dVolLiq ! derivative in hydraulic conductivity w.r.t volumetric liquid water content (m s-1) + real(rk),intent(out) :: dDiffuse_dVolLiq ! derivative in hydraulic diffusivity w.r.t volumetric liquid water content (m2 s-1) + real(rk),intent(out) :: dHydCond_dMatric ! derivative in hydraulic conductivity w.r.t matric head (s-1) + real(rk),intent(out) :: dHydCond_dTemp ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! local variables - real(summa_prec) :: localVolFracLiq ! local volumetric fraction of liquid water - real(summa_prec) :: scalarHydCondMP ! hydraulic conductivity of macropores at layer mid-points (m s-1) - real(summa_prec) :: dIceImpede_dT ! derivative in ice impedance factor w.r.t. temperature (K-1) - real(summa_prec) :: dHydCondMacro_dVolLiq ! derivative in hydraulic conductivity of macropores w.r.t volumetric liquid water content (m s-1) - real(summa_prec) :: dHydCondMacro_dMatric ! derivative in hydraulic conductivity of macropores w.r.t matric head (s-1) - real(summa_prec) :: dHydCondMicro_dMatric ! derivative in hydraulic conductivity of micropores w.r.t matric head (s-1) - real(summa_prec) :: dHydCondMicro_dTemp ! derivative in hydraulic conductivity of micropores w.r.t temperature (m s-1 K-1) - real(summa_prec) :: dPsi_dTheta2a ! derivative in dPsi_dTheta (analytical) - real(summa_prec) :: dIceImpede_dLiq ! derivative in ice impedence factor w.r.t. volumetric liquid water content (-) - real(summa_prec) :: hydCond_noIce ! hydraulic conductivity in the absence of ice (m s-1) - real(summa_prec) :: dK_dLiq__noIce ! derivative in hydraulic conductivity w.r.t volumetric liquid water content, in the absence of ice (m s-1) - real(summa_prec) :: dK_dPsi__noIce ! derivative in hydraulic conductivity w.r.t matric head, in the absence of ice (s-1) - real(summa_prec) :: relSatMP ! relative saturation of macropores (-) + real(rk) :: localVolFracLiq ! local volumetric fraction of liquid water + real(rk) :: scalarHydCondMP ! hydraulic conductivity of macropores at layer mid-points (m s-1) + real(rk) :: dIceImpede_dT ! derivative in ice impedance factor w.r.t. temperature (K-1) + real(rk) :: dHydCondMacro_dVolLiq ! derivative in hydraulic conductivity of macropores w.r.t volumetric liquid water content (m s-1) + real(rk) :: dHydCondMacro_dMatric ! derivative in hydraulic conductivity of macropores w.r.t matric head (s-1) + real(rk) :: dHydCondMicro_dMatric ! derivative in hydraulic conductivity of micropores w.r.t matric head (s-1) + real(rk) :: dHydCondMicro_dTemp ! derivative in hydraulic conductivity of micropores w.r.t temperature (m s-1 K-1) + real(rk) :: dPsi_dTheta2a ! derivative in dPsi_dTheta (analytical) + real(rk) :: dIceImpede_dLiq ! derivative in ice impedence factor w.r.t. volumetric liquid water content (-) + real(rk) :: hydCond_noIce ! hydraulic conductivity in the absence of ice (m s-1) + real(rk) :: dK_dLiq__noIce ! derivative in hydraulic conductivity w.r.t volumetric liquid water content, in the absence of ice (m s-1) + real(rk) :: dK_dPsi__noIce ! derivative in hydraulic conductivity w.r.t matric head, in the absence of ice (s-1) + real(rk) :: relSatMP ! relative saturation of macropores (-) ! local variables to test the derivative logical(lgt),parameter :: testDeriv=.false. ! local flag to test the derivative - real(summa_prec) :: xConst ! LH_fus/(gravity*Tfreeze), used in freezing point depression equation (m K-1) - real(summa_prec) :: vTheta ! volumetric fraction of total water (-) - real(summa_prec) :: volLiq ! volumetric fraction of liquid water (-) - real(summa_prec) :: volIce ! volumetric fraction of ice (-) - real(summa_prec) :: volFracLiq1,volFracLiq2 ! different trial values of volumetric liquid water content (-) - real(summa_prec) :: effSat ! effective saturation (-) - real(summa_prec) :: psiLiq ! liquid water matric potential (m) - real(summa_prec) :: hydCon ! hydraulic conductivity (m s-1) - real(summa_prec) :: hydIce ! hydraulic conductivity after accounting for ice impedance (-) - real(summa_prec),parameter :: dx = 1.e-8_summa_prec ! finite difference increment (m) + real(rk) :: xConst ! LH_fus/(gravity*Tfreeze), used in freezing point depression equation (m K-1) + real(rk) :: vTheta ! volumetric fraction of total water (-) + real(rk) :: volLiq ! volumetric fraction of liquid water (-) + real(rk) :: volIce ! volumetric fraction of ice (-) + real(rk) :: volFracLiq1,volFracLiq2 ! different trial values of volumetric liquid water content (-) + real(rk) :: effSat ! effective saturation (-) + real(rk) :: psiLiq ! liquid water matric potential (m) + real(rk) :: hydCon ! hydraulic conductivity (m s-1) + real(rk) :: hydIce ! hydraulic conductivity after accounting for ice impedance (-) + real(rk),parameter :: dx = 1.e-8_rk ! finite difference increment (m) ! initialize error control err=0; message="diagv_node/" @@ -1020,11 +1020,11 @@ subroutine diagv_node(& ! (compute derivative for macropores) if(localVolFracLiq > theta_mp)then relSatMP = (localVolFracLiq - theta_mp)/(theta_sat - theta_mp) - dHydCondMacro_dVolLiq = ((scalarSatHydCondMP - scalarSatHydCond)/(theta_sat - theta_mp))*mpExp*(relSatMP**(mpExp - 1._summa_prec)) + dHydCondMacro_dVolLiq = ((scalarSatHydCondMP - scalarSatHydCond)/(theta_sat - theta_mp))*mpExp*(relSatMP**(mpExp - 1._rk)) dHydCondMacro_dMatric = scalardTheta_dPsi*dHydCondMacro_dVolLiq else - dHydCondMacro_dVolLiq = 0._summa_prec - dHydCondMacro_dMatric = 0._summa_prec + dHydCondMacro_dVolLiq = 0._rk + dHydCondMacro_dMatric = 0._rk end if ! (compute derivatives for micropores) if(scalarVolFracIceTrial > verySmall)then @@ -1032,7 +1032,7 @@ subroutine diagv_node(& dHydCondMicro_dTemp = dPsiLiq_dTemp*dK_dPsi__noIce ! m s-1 K-1 dHydCondMicro_dMatric = hydCond_noIce*dIceImpede_dLiq*scalardTheta_dPsi + dK_dPsi__noIce*iceImpedeFac else - dHydCondMicro_dTemp = 0._summa_prec + dHydCondMicro_dTemp = 0._rk dHydCondMicro_dMatric = dHydCond_dPsi(scalarMatricHeadTrial,scalarSatHydCond,vGn_alpha,vGn_n,vGn_m,.true.) end if ! (combine derivatives) @@ -1052,7 +1052,7 @@ subroutine diagv_node(& volLiq = volFracLiq(xConst*(scalarTempTrial+dx - Tfreeze),vGn_alpha,theta_res,theta_sat,vGn_n,vGn_m) volIce = vTheta - volLiq effSat = (volLiq - theta_res)/(theta_sat - volIce - theta_res) - psiLiq = matricHead(effSat,vGn_alpha,0._summa_prec,1._summa_prec,vGn_n,vGn_m) ! use effective saturation, so theta_res=0 and theta_sat=1 + psiLiq = matricHead(effSat,vGn_alpha,0._rk,1._rk,vGn_n,vGn_m) ! use effective saturation, so theta_res=0 and theta_sat=1 hydCon = hydCond_psi(psiLiq,scalarSatHydCond,vGn_alpha,vGn_n,vGn_m) call iceImpede(volIce,f_impede,iceImpedeFac,dIceImpede_dLiq) hydIce = hydCon*iceImpedeFac @@ -1150,48 +1150,48 @@ subroutine surfaceFlx(& integer(i4b),intent(in) :: nRoots ! number of layers that contain roots integer(i4b),intent(in) :: ixIce ! index of lowest ice layer ! input: state and diagnostic variables - real(summa_prec),intent(in) :: scalarMatricHead ! matric head in the upper-most soil layer (m) - real(summa_prec),intent(in) :: scalarVolFracLiq ! volumetric liquid water content in the upper-most soil layer (-) - real(summa_prec),intent(in) :: mLayerVolFracLiq(:) ! volumetric liquid water content in each soil layer (-) - real(summa_prec),intent(in) :: mLayerVolFracIce(:) ! volumetric ice content in each soil layer (-) + real(rk),intent(in) :: scalarMatricHead ! matric head in the upper-most soil layer (m) + real(rk),intent(in) :: scalarVolFracLiq ! volumetric liquid water content in the upper-most soil layer (-) + real(rk),intent(in) :: mLayerVolFracLiq(:) ! volumetric liquid water content in each soil layer (-) + real(rk),intent(in) :: mLayerVolFracIce(:) ! volumetric ice content in each soil layer (-) ! input: depth of upper-most soil layer (m) - real(summa_prec),intent(in) :: mLayerDepth(:) ! depth of upper-most soil layer (m) - real(summa_prec),intent(in) :: iLayerHeight(0:) ! height at the interface of each layer (m) + real(rk),intent(in) :: mLayerDepth(:) ! depth of upper-most soil layer (m) + real(rk),intent(in) :: iLayerHeight(0:) ! height at the interface of each layer (m) ! input: diriclet boundary conditions - real(summa_prec),intent(in) :: upperBoundHead ! upper boundary condition for matric head (m) - real(summa_prec),intent(in) :: upperBoundTheta ! upper boundary condition for volumetric liquid water content (-) + real(rk),intent(in) :: upperBoundHead ! upper boundary condition for matric head (m) + real(rk),intent(in) :: upperBoundTheta ! upper boundary condition for volumetric liquid water content (-) ! input: flux at the upper boundary - real(summa_prec),intent(in) :: scalarRainPlusMelt ! rain plus melt, used as input to the soil zone before computing surface runoff (m s-1) + real(rk),intent(in) :: scalarRainPlusMelt ! rain plus melt, used as input to the soil zone before computing surface runoff (m s-1) ! input: transmittance - real(summa_prec),intent(in) :: surfaceSatHydCond ! saturated hydraulic conductivity at the surface (m s-1) - real(summa_prec),intent(in) :: dHydCond_dTemp ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) - real(summa_prec),intent(in) :: iceImpedeFac ! ice impedence factor in the upper-most soil layer (-) + real(rk),intent(in) :: surfaceSatHydCond ! saturated hydraulic conductivity at the surface (m s-1) + real(rk),intent(in) :: dHydCond_dTemp ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) + real(rk),intent(in) :: iceImpedeFac ! ice impedence factor in the upper-most soil layer (-) ! input: soil parameters - real(summa_prec),intent(in) :: vGn_alpha ! van Genutchen "alpha" parameter (m-1) - real(summa_prec),intent(in) :: vGn_n ! van Genutchen "n" parameter (-) - real(summa_prec),intent(in) :: vGn_m ! van Genutchen "m" parameter (-) - real(summa_prec),intent(in) :: theta_sat ! soil porosity (-) - real(summa_prec),intent(in) :: theta_res ! soil residual volumetric water content (-) - real(summa_prec),intent(in) :: qSurfScale ! scaling factor in the surface runoff parameterization (-) - real(summa_prec),intent(in) :: zScale_TOPMODEL ! scaling factor used to describe decrease in hydraulic conductivity with depth (m) - real(summa_prec),intent(in) :: rootingDepth ! rooting depth (m) - real(summa_prec),intent(in) :: wettingFrontSuction ! Green-Ampt wetting front suction (m) - real(summa_prec),intent(in) :: soilIceScale ! soil ice scaling factor in Gamma distribution used to define frozen area (m) - real(summa_prec),intent(in) :: soilIceCV ! soil ice CV in Gamma distribution used to define frozen area (-) + real(rk),intent(in) :: vGn_alpha ! van Genutchen "alpha" parameter (m-1) + real(rk),intent(in) :: vGn_n ! van Genutchen "n" parameter (-) + real(rk),intent(in) :: vGn_m ! van Genutchen "m" parameter (-) + real(rk),intent(in) :: theta_sat ! soil porosity (-) + real(rk),intent(in) :: theta_res ! soil residual volumetric water content (-) + real(rk),intent(in) :: qSurfScale ! scaling factor in the surface runoff parameterization (-) + real(rk),intent(in) :: zScale_TOPMODEL ! scaling factor used to describe decrease in hydraulic conductivity with depth (m) + real(rk),intent(in) :: rootingDepth ! rooting depth (m) + real(rk),intent(in) :: wettingFrontSuction ! Green-Ampt wetting front suction (m) + real(rk),intent(in) :: soilIceScale ! soil ice scaling factor in Gamma distribution used to define frozen area (m) + real(rk),intent(in) :: soilIceCV ! soil ice CV in Gamma distribution used to define frozen area (-) ! ----------------------------------------------------------------------------------------------------------------------------- ! input-output: hydraulic conductivity and diffusivity at the surface ! NOTE: intent(inout) because infiltration may only be computed for the first iteration - real(summa_prec),intent(inout) :: surfaceHydCond ! hydraulic conductivity (m s-1) - real(summa_prec),intent(inout) :: surfaceDiffuse ! hydraulic diffusivity at the surface (m + real(rk),intent(inout) :: surfaceHydCond ! hydraulic conductivity (m s-1) + real(rk),intent(inout) :: surfaceDiffuse ! hydraulic diffusivity at the surface (m ! output: surface runoff and infiltration flux (m s-1) - real(summa_prec),intent(inout) :: xMaxInfilRate ! maximum infiltration rate (m s-1) - real(summa_prec),intent(inout) :: scalarInfilArea ! fraction of unfrozen area where water can infiltrate (-) - real(summa_prec),intent(inout) :: scalarFrozenArea ! fraction of area that is considered impermeable due to soil ice (-) - real(summa_prec),intent(out) :: scalarSurfaceRunoff ! surface runoff (m s-1) - real(summa_prec),intent(out) :: scalarSurfaceInfiltration ! surface infiltration (m s-1) + real(rk),intent(inout) :: xMaxInfilRate ! maximum infiltration rate (m s-1) + real(rk),intent(inout) :: scalarInfilArea ! fraction of unfrozen area where water can infiltrate (-) + real(rk),intent(inout) :: scalarFrozenArea ! fraction of area that is considered impermeable due to soil ice (-) + real(rk),intent(out) :: scalarSurfaceRunoff ! surface runoff (m s-1) + real(rk),intent(out) :: scalarSurfaceInfiltration ! surface infiltration (m s-1) ! output: deriavtives in surface infiltration w.r.t. volumetric liquid water (m s-1) and matric head (s-1) in the upper-most soil layer - real(summa_prec),intent(out) :: dq_dHydState ! derivative in surface infiltration w.r.t. state variable in the upper-most soil layer (m s-1 or s-1) - real(summa_prec),intent(out) :: dq_dNrgState ! derivative in surface infiltration w.r.t. energy state variable in the upper-most soil layer (m s-1 K-1) + real(rk),intent(out) :: dq_dHydState ! derivative in surface infiltration w.r.t. state variable in the upper-most soil layer (m s-1 or s-1) + real(rk),intent(out) :: dq_dNrgState ! derivative in surface infiltration w.r.t. energy state variable in the upper-most soil layer (m s-1 K-1) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message @@ -1200,29 +1200,29 @@ subroutine surfaceFlx(& ! (general) integer(i4b) :: iLayer ! index of soil layer ! (head boundary condition) - real(summa_prec) :: cFlux ! capillary flux (m s-1) - real(summa_prec) :: dNum ! numerical derivative + real(rk) :: cFlux ! capillary flux (m s-1) + real(rk) :: dNum ! numerical derivative ! (simplified Green-Ampt infiltration) - real(summa_prec) :: rootZoneLiq ! depth of liquid water in the root zone (m) - real(summa_prec) :: rootZoneIce ! depth of ice in the root zone (m) - real(summa_prec) :: availCapacity ! available storage capacity in the root zone (m) - real(summa_prec) :: depthWettingFront ! depth to the wetting front (m) - real(summa_prec) :: hydCondWettingFront ! hydraulic conductivity at the wetting front (m s-1) + real(rk) :: rootZoneLiq ! depth of liquid water in the root zone (m) + real(rk) :: rootZoneIce ! depth of ice in the root zone (m) + real(rk) :: availCapacity ! available storage capacity in the root zone (m) + real(rk) :: depthWettingFront ! depth to the wetting front (m) + real(rk) :: hydCondWettingFront ! hydraulic conductivity at the wetting front (m s-1) ! (saturated area associated with variable storage capacity) - real(summa_prec) :: fracCap ! fraction of pore space filled with liquid water and ice (-) - real(summa_prec) :: fInfRaw ! infiltrating area before imposing solution constraints (-) - real(summa_prec),parameter :: maxFracCap=0.995_summa_prec ! maximum fraction capacity -- used to avoid numerical problems associated with an enormous derivative - real(summa_prec),parameter :: scaleFactor=0.000001_summa_prec ! scale factor for the smoothing function (-) - real(summa_prec),parameter :: qSurfScaleMax=1000._summa_prec ! maximum surface runoff scaling factor (-) + real(rk) :: fracCap ! fraction of pore space filled with liquid water and ice (-) + real(rk) :: fInfRaw ! infiltrating area before imposing solution constraints (-) + real(rk),parameter :: maxFracCap=0.995_rk ! maximum fraction capacity -- used to avoid numerical problems associated with an enormous derivative + real(rk),parameter :: scaleFactor=0.000001_rk ! scale factor for the smoothing function (-) + real(rk),parameter :: qSurfScaleMax=1000._rk ! maximum surface runoff scaling factor (-) ! (fraction of impermeable area associated with frozen ground) - real(summa_prec) :: alpha ! shape parameter in the Gamma distribution - real(summa_prec) :: xLimg ! upper limit of the integral + real(rk) :: alpha ! shape parameter in the Gamma distribution + real(rk) :: xLimg ! upper limit of the integral ! initialize error control err=0; message="surfaceFlx/" ! compute derivative in the energy state ! NOTE: revisit the need to do this - dq_dNrgState = 0._summa_prec + dq_dNrgState = 0._rk ! ***** ! compute the surface flux and its derivative @@ -1233,7 +1233,7 @@ subroutine surfaceFlx(& case(prescribedHead) ! surface runoff iz zero for the head condition - scalarSurfaceRunoff = 0._summa_prec + scalarSurfaceRunoff = 0._rk ! compute transmission and the capillary flux select case(ixRichards) ! (form of Richards' equation) @@ -1242,13 +1242,13 @@ subroutine surfaceFlx(& surfaceHydCond = hydCond_liq(upperBoundTheta,surfaceSatHydCond,theta_res,theta_sat,vGn_m) * iceImpedeFac surfaceDiffuse = dPsi_dTheta(upperBoundTheta,vGn_alpha,theta_res,theta_sat,vGn_n,vGn_m) * surfaceHydCond ! compute the capillary flux - cflux = -surfaceDiffuse*(scalarVolFracLiq - upperBoundTheta) / (mLayerDepth(1)*0.5_summa_prec) + cflux = -surfaceDiffuse*(scalarVolFracLiq - upperBoundTheta) / (mLayerDepth(1)*0.5_rk) case(mixdform) ! compute the hydraulic conductivity and diffusivity at the boundary surfaceHydCond = hydCond_psi(upperBoundHead,surfaceSatHydCond,vGn_alpha,vGn_n,vGn_m) * iceImpedeFac surfaceDiffuse = realMissing ! compute the capillary flux - cflux = -surfaceHydCond*(scalarMatricHead - upperBoundHead) / (mLayerDepth(1)*0.5_summa_prec) + cflux = -surfaceHydCond*(scalarMatricHead - upperBoundHead) / (mLayerDepth(1)*0.5_rk) case default; err=10; message=trim(message)//"unknown form of Richards' equation"; return end select ! (form of Richards' eqn) ! compute the total flux @@ -1257,19 +1257,19 @@ subroutine surfaceFlx(& if(deriv_desired)then ! compute the hydrology derivative select case(ixRichards) ! (form of Richards' equation) - case(moisture); dq_dHydState = -surfaceDiffuse/(mLayerDepth(1)/2._summa_prec) - case(mixdform); dq_dHydState = -surfaceHydCond/(mLayerDepth(1)/2._summa_prec) + case(moisture); dq_dHydState = -surfaceDiffuse/(mLayerDepth(1)/2._rk) + case(mixdform); dq_dHydState = -surfaceHydCond/(mLayerDepth(1)/2._rk) case default; err=10; message=trim(message)//"unknown form of Richards' equation"; return end select ! compute the energy derivative - dq_dNrgState = -(dHydCond_dTemp/2._summa_prec)*(scalarMatricHead - upperBoundHead)/(mLayerDepth(1)*0.5_summa_prec) + dHydCond_dTemp/2._summa_prec + dq_dNrgState = -(dHydCond_dTemp/2._rk)*(scalarMatricHead - upperBoundHead)/(mLayerDepth(1)*0.5_rk) + dHydCond_dTemp/2._rk ! compute the numerical derivative - !cflux = -surfaceHydCond*((scalarMatricHead+dx) - upperBoundHead) / (mLayerDepth(1)*0.5_summa_prec) + !cflux = -surfaceHydCond*((scalarMatricHead+dx) - upperBoundHead) / (mLayerDepth(1)*0.5_rk) !surfaceInfiltration1 = cflux + surfaceHydCond !dNum = (surfaceInfiltration1 - scalarSurfaceInfiltration)/dx else - dq_dHydState = 0._summa_prec - dNum = 0._summa_prec + dq_dHydState = 0._rk + dNum = 0._rk end if !write(*,'(a,1x,10(e30.20,1x))') 'scalarMatricHead, scalarSurfaceInfiltration, dq_dHydState, dNum = ', & ! scalarMatricHead, scalarSurfaceInfiltration, dq_dHydState, dNum @@ -1282,8 +1282,8 @@ subroutine surfaceFlx(& if(doInfiltration)then ! define the storage in the root zone (m) - rootZoneLiq = 0._summa_prec - rootZoneIce = 0._summa_prec + rootZoneLiq = 0._rk + rootZoneIce = 0._rk ! (process layers where the roots extend to the bottom of the layer) if(nRoots > 1)then do iLayer=1,nRoots-1 @@ -1306,7 +1306,7 @@ subroutine surfaceFlx(& depthWettingFront = (rootZoneLiq/availCapacity)*rootingDepth ! define the hydraulic conductivity at depth=depthWettingFront (m s-1) - hydCondWettingFront = surfaceSatHydCond * ( (1._summa_prec - depthWettingFront/sum(mLayerDepth))**(zScale_TOPMODEL - 1._summa_prec) ) + hydCondWettingFront = surfaceSatHydCond * ( (1._rk - depthWettingFront/sum(mLayerDepth))**(zScale_TOPMODEL - 1._rk) ) ! define the maximum infiltration rate (m s-1) xMaxInfilRate = hydCondWettingFront*( (wettingFrontSuction + depthWettingFront)/depthWettingFront ) ! maximum infiltration rate (m s-1) @@ -1315,15 +1315,15 @@ subroutine surfaceFlx(& ! define the infiltrating area for the non-frozen part of the cell/basin if(qSurfScale < qSurfScaleMax)then fracCap = rootZoneLiq/(maxFracCap*availCapacity) ! fraction of available root zone filled with water - fInfRaw = 1._summa_prec - exp(-qSurfScale*(1._summa_prec - fracCap)) ! infiltrating area -- allowed to violate solution constraints - scalarInfilArea = min(0.5_summa_prec*(fInfRaw + sqrt(fInfRaw**2._summa_prec + scaleFactor)), 1._summa_prec) ! infiltrating area -- constrained + fInfRaw = 1._rk - exp(-qSurfScale*(1._rk - fracCap)) ! infiltrating area -- allowed to violate solution constraints + scalarInfilArea = min(0.5_rk*(fInfRaw + sqrt(fInfRaw**2._rk + scaleFactor)), 1._rk) ! infiltrating area -- constrained else - scalarInfilArea = 1._summa_prec + scalarInfilArea = 1._rk endif ! check to ensure we are not infiltrating into a fully saturated column if(ixIce 0.9999_summa_prec*theta_sat*sum(mLayerDepth(ixIce+1:nRoots))) scalarInfilArea=0._summa_prec + if(sum(mLayerVolFracLiq(ixIce+1:nRoots)*mLayerDepth(ixIce+1:nRoots)) > 0.9999_rk*theta_sat*sum(mLayerDepth(ixIce+1:nRoots))) scalarInfilArea=0._rk !print*, 'ixIce, nRoots, scalarInfilArea = ', ixIce, nRoots, scalarInfilArea !print*, 'sum(mLayerVolFracLiq(ixIce+1:nRoots)*mLayerDepth(ixIce+1:nRoots)) = ', sum(mLayerVolFracLiq(ixIce+1:nRoots)*mLayerDepth(ixIce+1:nRoots)) !print*, 'theta_sat*sum(mLayerDepth(ixIce+1:nRoots)) = ', theta_sat*sum(mLayerDepth(ixIce+1:nRoots)) @@ -1331,25 +1331,25 @@ subroutine surfaceFlx(& ! define the impermeable area due to frozen ground if(rootZoneIce > tiny(rootZoneIce))then ! (avoid divide by zero) - alpha = 1._summa_prec/(soilIceCV**2._summa_prec) ! shape parameter in the Gamma distribution + alpha = 1._rk/(soilIceCV**2._rk) ! shape parameter in the Gamma distribution xLimg = alpha*soilIceScale/rootZoneIce ! upper limit of the integral - !scalarFrozenArea = 1._summa_prec - gammp(alpha,xLimg) ! fraction of frozen area - scalarFrozenArea = 0._summa_prec + !scalarFrozenArea = 1._rk - gammp(alpha,xLimg) ! fraction of frozen area + scalarFrozenArea = 0._rk else - scalarFrozenArea = 0._summa_prec + scalarFrozenArea = 0._rk end if !print*, 'scalarFrozenArea, rootZoneIce = ', scalarFrozenArea, rootZoneIce end if ! (if desire to compute infiltration) ! compute infiltration (m s-1) - scalarSurfaceInfiltration = (1._summa_prec - scalarFrozenArea)*scalarInfilArea*min(scalarRainPlusMelt,xMaxInfilRate) + scalarSurfaceInfiltration = (1._rk - scalarFrozenArea)*scalarInfilArea*min(scalarRainPlusMelt,xMaxInfilRate) ! compute surface runoff (m s-1) scalarSurfaceRunoff = scalarRainPlusMelt - scalarSurfaceInfiltration !print*, 'scalarRainPlusMelt, xMaxInfilRate = ', scalarRainPlusMelt, xMaxInfilRate !print*, 'scalarSurfaceInfiltration, scalarSurfaceRunoff = ', scalarSurfaceInfiltration, scalarSurfaceRunoff - !print*, '(1._summa_prec - scalarFrozenArea), (1._summa_prec - scalarFrozenArea)*scalarInfilArea = ', (1._summa_prec - scalarFrozenArea), (1._summa_prec - scalarFrozenArea)*scalarInfilArea + !print*, '(1._rk - scalarFrozenArea), (1._rk - scalarFrozenArea)*scalarInfilArea = ', (1._rk - scalarFrozenArea), (1._rk - scalarFrozenArea)*scalarInfilArea ! set surface hydraulic conductivity and diffusivity to missing (not used for flux condition) surfaceHydCond = realMissing @@ -1358,8 +1358,8 @@ subroutine surfaceFlx(& ! set numerical derivative to zero ! NOTE 1: Depends on multiple soil layers and does not jive with the current tridiagonal matrix ! NOTE 2: Need to define the derivative at every call, because intent(out) - dq_dHydState = 0._summa_prec - dq_dNrgState = 0._summa_prec + dq_dHydState = 0._rk + dq_dNrgState = 0._rk ! ***** error check case default; err=20; message=trim(message)//'unknown upper boundary condition for soil hydrology'; return @@ -1409,31 +1409,31 @@ subroutine iLayerFlux(& logical(lgt),intent(in) :: deriv_desired ! flag indicating if derivatives are desired integer(i4b),intent(in) :: ixRichards ! index defining the option for Richards' equation (moisture or mixdform) ! input: state variables - real(summa_prec),intent(in) :: nodeMatricHeadTrial(:) ! matric head at the soil nodes (m) - real(summa_prec),intent(in) :: nodeVolFracLiqTrial(:) ! volumetric fraction of liquid water at the soil nodes (-) + real(rk),intent(in) :: nodeMatricHeadTrial(:) ! matric head at the soil nodes (m) + real(rk),intent(in) :: nodeVolFracLiqTrial(:) ! volumetric fraction of liquid water at the soil nodes (-) ! input: model coordinate variables - real(summa_prec),intent(in) :: nodeHeight(:) ! height at the mid-point of the lower layer (m) + real(rk),intent(in) :: nodeHeight(:) ! height at the mid-point of the lower layer (m) ! input: temperature derivatives - real(summa_prec),intent(in) :: dPsiLiq_dTemp(:) ! derivative in liquid water matric potential w.r.t. temperature (m K-1) - real(summa_prec),intent(in) :: dHydCond_dTemp(:) ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) + real(rk),intent(in) :: dPsiLiq_dTemp(:) ! derivative in liquid water matric potential w.r.t. temperature (m K-1) + real(rk),intent(in) :: dHydCond_dTemp(:) ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) ! input: transmittance - real(summa_prec),intent(in) :: nodeHydCondTrial(:) ! hydraulic conductivity at layer mid-points (m s-1) - real(summa_prec),intent(in) :: nodeDiffuseTrial(:) ! diffusivity at layer mid-points (m2 s-1) + real(rk),intent(in) :: nodeHydCondTrial(:) ! hydraulic conductivity at layer mid-points (m s-1) + real(rk),intent(in) :: nodeDiffuseTrial(:) ! diffusivity at layer mid-points (m2 s-1) ! input: transmittance derivatives - real(summa_prec),intent(in) :: dHydCond_dVolLiq(:) ! derivative in hydraulic conductivity w.r.t volumetric liquid water content (m s-1) - real(summa_prec),intent(in) :: dDiffuse_dVolLiq(:) ! derivative in hydraulic diffusivity w.r.t volumetric liquid water content (m2 s-1) - real(summa_prec),intent(in) :: dHydCond_dMatric(:) ! derivative in hydraulic conductivity w.r.t matric head (m s-1) + real(rk),intent(in) :: dHydCond_dVolLiq(:) ! derivative in hydraulic conductivity w.r.t volumetric liquid water content (m s-1) + real(rk),intent(in) :: dDiffuse_dVolLiq(:) ! derivative in hydraulic diffusivity w.r.t volumetric liquid water content (m2 s-1) + real(rk),intent(in) :: dHydCond_dMatric(:) ! derivative in hydraulic conductivity w.r.t matric head (m s-1) ! output: tranmsmittance at the layer interface (scalars) - real(summa_prec),intent(out) :: iLayerHydCond ! hydraulic conductivity at the interface between layers (m s-1) - real(summa_prec),intent(out) :: iLayerDiffuse ! hydraulic diffusivity at the interface between layers (m2 s-1) + real(rk),intent(out) :: iLayerHydCond ! hydraulic conductivity at the interface between layers (m s-1) + real(rk),intent(out) :: iLayerDiffuse ! hydraulic diffusivity at the interface between layers (m2 s-1) ! output: vertical flux at the layer interface (scalars) - real(summa_prec),intent(out) :: iLayerLiqFluxSoil ! vertical flux of liquid water at the layer interface (m s-1) + real(rk),intent(out) :: iLayerLiqFluxSoil ! vertical flux of liquid water at the layer interface (m s-1) ! output: derivatives in fluxes w.r.t. state variables -- matric head or volumetric lquid water -- in the layer above and layer below (m s-1 or s-1) - real(summa_prec),intent(out) :: dq_dHydStateAbove ! derivatives in the flux w.r.t. matric head or volumetric lquid water in the layer above (m s-1 or s-1) - real(summa_prec),intent(out) :: dq_dHydStateBelow ! derivatives in the flux w.r.t. matric head or volumetric lquid water in the layer below (m s-1 or s-1) + real(rk),intent(out) :: dq_dHydStateAbove ! derivatives in the flux w.r.t. matric head or volumetric lquid water in the layer above (m s-1 or s-1) + real(rk),intent(out) :: dq_dHydStateBelow ! derivatives in the flux w.r.t. matric head or volumetric lquid water in the layer below (m s-1 or s-1) ! output: derivatives in fluxes w.r.t. energy state variables -- now just temperature -- in the layer above and layer below (m s-1 K-1) - real(summa_prec),intent(out) :: dq_dNrgStateAbove ! derivatives in the flux w.r.t. temperature in the layer above (m s-1 K-1) - real(summa_prec),intent(out) :: dq_dNrgStateBelow ! derivatives in the flux w.r.t. temperature in the layer below (m s-1 K-1) + real(rk),intent(out) :: dq_dNrgStateAbove ! derivatives in the flux w.r.t. temperature in the layer above (m s-1 K-1) + real(rk),intent(out) :: dq_dNrgStateBelow ! derivatives in the flux w.r.t. temperature in the layer below (m s-1 K-1) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message @@ -1443,17 +1443,17 @@ subroutine iLayerFlux(& integer(i4b),parameter :: ixLower=2 ! index of lower node in the 2-element vectors logical(lgt),parameter :: useGeometric=.false. ! switch between the arithmetic and geometric mean ! local variables (Darcy flux) - real(summa_prec) :: dPsi ! spatial difference in matric head (m) - real(summa_prec) :: dLiq ! spatial difference in volumetric liquid water (-) - real(summa_prec) :: dz ! spatial difference in layer mid-points (m) - real(summa_prec) :: cflux ! capillary flux (m s-1) + real(rk) :: dPsi ! spatial difference in matric head (m) + real(rk) :: dLiq ! spatial difference in volumetric liquid water (-) + real(rk) :: dz ! spatial difference in layer mid-points (m) + real(rk) :: cflux ! capillary flux (m s-1) ! local variables (derivative in Darcy's flux) - real(summa_prec) :: dHydCondIface_dVolLiqAbove ! derivative in hydraulic conductivity at layer interface w.r.t. volumetric liquid water content in layer above - real(summa_prec) :: dHydCondIface_dVolLiqBelow ! derivative in hydraulic conductivity at layer interface w.r.t. volumetric liquid water content in layer below - real(summa_prec) :: dDiffuseIface_dVolLiqAbove ! derivative in hydraulic diffusivity at layer interface w.r.t. volumetric liquid water content in layer above - real(summa_prec) :: dDiffuseIface_dVolLiqBelow ! derivative in hydraulic diffusivity at layer interface w.r.t. volumetric liquid water content in layer below - real(summa_prec) :: dHydCondIface_dMatricAbove ! derivative in hydraulic conductivity at layer interface w.r.t. matric head in layer above - real(summa_prec) :: dHydCondIface_dMatricBelow ! derivative in hydraulic conductivity at layer interface w.r.t. matric head in layer below + real(rk) :: dHydCondIface_dVolLiqAbove ! derivative in hydraulic conductivity at layer interface w.r.t. volumetric liquid water content in layer above + real(rk) :: dHydCondIface_dVolLiqBelow ! derivative in hydraulic conductivity at layer interface w.r.t. volumetric liquid water content in layer below + real(rk) :: dDiffuseIface_dVolLiqAbove ! derivative in hydraulic diffusivity at layer interface w.r.t. volumetric liquid water content in layer above + real(rk) :: dDiffuseIface_dVolLiqBelow ! derivative in hydraulic diffusivity at layer interface w.r.t. volumetric liquid water content in layer below + real(rk) :: dHydCondIface_dMatricAbove ! derivative in hydraulic conductivity at layer interface w.r.t. matric head in layer above + real(rk) :: dHydCondIface_dMatricBelow ! derivative in hydraulic conductivity at layer interface w.r.t. matric head in layer below ! ------------------------------------------------------------------------------------------------------------------------------------------------------------------------ ! initialize error control err=0; message="iLayerFlux/" @@ -1462,9 +1462,9 @@ subroutine iLayerFlux(& ! compute the vertical flux of liquid water ! compute the hydraulic conductivity at the interface if(useGeometric)then - iLayerHydCond = (nodeHydCondTrial(ixLower) * nodeHydCondTrial(ixUpper))**0.5_summa_prec + iLayerHydCond = (nodeHydCondTrial(ixLower) * nodeHydCondTrial(ixUpper))**0.5_rk else - iLayerHydCond = (nodeHydCondTrial(ixLower) + nodeHydCondTrial(ixUpper))*0.5_summa_prec + iLayerHydCond = (nodeHydCondTrial(ixLower) + nodeHydCondTrial(ixUpper))*0.5_rk end if !write(*,'(a,1x,5(e20.10,1x))') 'in iLayerFlux: iLayerHydCond, iLayerHydCondMP = ', iLayerHydCond, iLayerHydCondMP ! compute the height difference between nodes @@ -1472,7 +1472,7 @@ subroutine iLayerFlux(& ! compute the capillary flux select case(ixRichards) ! (form of Richards' equation) case(moisture) - iLayerDiffuse = (nodeDiffuseTrial(ixLower) * nodeDiffuseTrial(ixUpper))**0.5_summa_prec + iLayerDiffuse = (nodeDiffuseTrial(ixLower) * nodeDiffuseTrial(ixUpper))**0.5_rk dLiq = nodeVolFracLiqTrial(ixLower) - nodeVolFracLiqTrial(ixUpper) cflux = -iLayerDiffuse * dLiq/dz case(mixdform) @@ -1496,29 +1496,29 @@ subroutine iLayerFlux(& err=20; return end if ! derivatives in hydraulic conductivity at the layer interface (m s-1) - dHydCondIface_dVolLiqAbove = dHydCond_dVolLiq(ixUpper)*nodeHydCondTrial(ixLower) * 0.5_summa_prec/max(iLayerHydCond,verySmall) - dHydCondIface_dVolLiqBelow = dHydCond_dVolLiq(ixLower)*nodeHydCondTrial(ixUpper) * 0.5_summa_prec/max(iLayerHydCond,verySmall) + dHydCondIface_dVolLiqAbove = dHydCond_dVolLiq(ixUpper)*nodeHydCondTrial(ixLower) * 0.5_rk/max(iLayerHydCond,verySmall) + dHydCondIface_dVolLiqBelow = dHydCond_dVolLiq(ixLower)*nodeHydCondTrial(ixUpper) * 0.5_rk/max(iLayerHydCond,verySmall) ! derivatives in hydraulic diffusivity at the layer interface (m2 s-1) - dDiffuseIface_dVolLiqAbove = dDiffuse_dVolLiq(ixUpper)*nodeDiffuseTrial(ixLower) * 0.5_summa_prec/max(iLayerDiffuse,verySmall) - dDiffuseIface_dVolLiqBelow = dDiffuse_dVolLiq(ixLower)*nodeDiffuseTrial(ixUpper) * 0.5_summa_prec/max(iLayerDiffuse,verySmall) + dDiffuseIface_dVolLiqAbove = dDiffuse_dVolLiq(ixUpper)*nodeDiffuseTrial(ixLower) * 0.5_rk/max(iLayerDiffuse,verySmall) + dDiffuseIface_dVolLiqBelow = dDiffuse_dVolLiq(ixLower)*nodeDiffuseTrial(ixUpper) * 0.5_rk/max(iLayerDiffuse,verySmall) ! derivatives in the flux w.r.t. volumetric liquid water content dq_dHydStateAbove = -dDiffuseIface_dVolLiqAbove*dLiq/dz + iLayerDiffuse/dz + dHydCondIface_dVolLiqAbove dq_dHydStateBelow = -dDiffuseIface_dVolLiqBelow*dLiq/dz - iLayerDiffuse/dz + dHydCondIface_dVolLiqBelow case(mixdform) ! derivatives in hydraulic conductivity if(useGeometric)then - dHydCondIface_dMatricAbove = dHydCond_dMatric(ixUpper)*nodeHydCondTrial(ixLower) * 0.5_summa_prec/max(iLayerHydCond,verySmall) - dHydCondIface_dMatricBelow = dHydCond_dMatric(ixLower)*nodeHydCondTrial(ixUpper) * 0.5_summa_prec/max(iLayerHydCond,verySmall) + dHydCondIface_dMatricAbove = dHydCond_dMatric(ixUpper)*nodeHydCondTrial(ixLower) * 0.5_rk/max(iLayerHydCond,verySmall) + dHydCondIface_dMatricBelow = dHydCond_dMatric(ixLower)*nodeHydCondTrial(ixUpper) * 0.5_rk/max(iLayerHydCond,verySmall) else - dHydCondIface_dMatricAbove = dHydCond_dMatric(ixUpper)/2._summa_prec - dHydCondIface_dMatricBelow = dHydCond_dMatric(ixLower)/2._summa_prec + dHydCondIface_dMatricAbove = dHydCond_dMatric(ixUpper)/2._rk + dHydCondIface_dMatricBelow = dHydCond_dMatric(ixLower)/2._rk end if ! derivatives in the flux w.r.t. matric head dq_dHydStateAbove = -dHydCondIface_dMatricAbove*dPsi/dz + iLayerHydCond/dz + dHydCondIface_dMatricAbove dq_dHydStateBelow = -dHydCondIface_dMatricBelow*dPsi/dz - iLayerHydCond/dz + dHydCondIface_dMatricBelow ! derivative in the flux w.r.t. temperature - dq_dNrgStateAbove = -(dHydCond_dTemp(ixUpper)/2._summa_prec)*dPsi/dz + iLayerHydCond*dPsiLiq_dTemp(ixUpper)/dz + dHydCond_dTemp(ixUpper)/2._summa_prec - dq_dNrgStateBelow = -(dHydCond_dTemp(ixLower)/2._summa_prec)*dPsi/dz - iLayerHydCond*dPsiLiq_dTemp(ixLower)/dz + dHydCond_dTemp(ixLower)/2._summa_prec + dq_dNrgStateAbove = -(dHydCond_dTemp(ixUpper)/2._rk)*dPsi/dz + iLayerHydCond*dPsiLiq_dTemp(ixUpper)/dz + dHydCond_dTemp(ixUpper)/2._rk + dq_dNrgStateBelow = -(dHydCond_dTemp(ixLower)/2._rk)*dPsi/dz - iLayerHydCond*dPsiLiq_dTemp(ixLower)/dz + dHydCond_dTemp(ixLower)/2._rk case default; err=10; message=trim(message)//"unknown form of Richards' equation"; return end select else @@ -1588,50 +1588,50 @@ subroutine qDrainFlux(& integer(i4b),intent(in) :: ixRichards ! index defining the option for Richards' equation (moisture or mixdform) integer(i4b),intent(in) :: bc_lower ! index defining the type of boundary conditions ! input: state and diagnostic variables - real(summa_prec),intent(in) :: nodeMatricHead ! matric head in the lowest unsaturated node (m) - real(summa_prec),intent(in) :: nodeVolFracLiq ! volumetric liquid water content in the lowest unsaturated node (-) + real(rk),intent(in) :: nodeMatricHead ! matric head in the lowest unsaturated node (m) + real(rk),intent(in) :: nodeVolFracLiq ! volumetric liquid water content in the lowest unsaturated node (-) ! input: model coordinate variables - real(summa_prec),intent(in) :: nodeDepth ! depth of the lowest unsaturated soil layer (m) - real(summa_prec),intent(in) :: nodeHeight ! height of the lowest unsaturated soil node (m) + real(rk),intent(in) :: nodeDepth ! depth of the lowest unsaturated soil layer (m) + real(rk),intent(in) :: nodeHeight ! height of the lowest unsaturated soil node (m) ! input: diriclet boundary conditions - real(summa_prec),intent(in) :: lowerBoundHead ! lower boundary condition for matric head (m) - real(summa_prec),intent(in) :: lowerBoundTheta ! lower boundary condition for volumetric liquid water content (-) + real(rk),intent(in) :: lowerBoundHead ! lower boundary condition for matric head (m) + real(rk),intent(in) :: lowerBoundTheta ! lower boundary condition for volumetric liquid water content (-) ! input: derivative in soil water characteristix - real(summa_prec),intent(in) :: node__dPsi_dTheta ! derivative of the soil moisture characteristic w.r.t. theta (m) + real(rk),intent(in) :: node__dPsi_dTheta ! derivative of the soil moisture characteristic w.r.t. theta (m) ! input: transmittance - real(summa_prec),intent(in) :: surfaceSatHydCond ! saturated hydraulic conductivity at the surface (m s-1) - real(summa_prec),intent(in) :: bottomSatHydCond ! saturated hydraulic conductivity at the bottom of the unsaturated zone (m s-1) - real(summa_prec),intent(in) :: nodeHydCond ! hydraulic conductivity at the node itself (m s-1) - real(summa_prec),intent(in) :: iceImpedeFac ! ice impedence factor in the upper-most soil layer (-) + real(rk),intent(in) :: surfaceSatHydCond ! saturated hydraulic conductivity at the surface (m s-1) + real(rk),intent(in) :: bottomSatHydCond ! saturated hydraulic conductivity at the bottom of the unsaturated zone (m s-1) + real(rk),intent(in) :: nodeHydCond ! hydraulic conductivity at the node itself (m s-1) + real(rk),intent(in) :: iceImpedeFac ! ice impedence factor in the upper-most soil layer (-) ! input: transmittance derivatives - real(summa_prec),intent(in) :: dHydCond_dVolLiq ! derivative in hydraulic conductivity w.r.t. volumetric liquid water content (m s-1) - real(summa_prec),intent(in) :: dHydCond_dMatric ! derivative in hydraulic conductivity w.r.t. matric head (s-1) - real(summa_prec),intent(in) :: dHydCond_dTemp ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) + real(rk),intent(in) :: dHydCond_dVolLiq ! derivative in hydraulic conductivity w.r.t. volumetric liquid water content (m s-1) + real(rk),intent(in) :: dHydCond_dMatric ! derivative in hydraulic conductivity w.r.t. matric head (s-1) + real(rk),intent(in) :: dHydCond_dTemp ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) ! input: soil parameters - real(summa_prec),intent(in) :: vGn_alpha ! van Genutchen "alpha" parameter (m-1) - real(summa_prec),intent(in) :: vGn_n ! van Genutchen "n" parameter (-) - real(summa_prec),intent(in) :: vGn_m ! van Genutchen "m" parameter (-) - real(summa_prec),intent(in) :: theta_sat ! soil porosity (-) - real(summa_prec),intent(in) :: theta_res ! soil residual volumetric water content (-) - real(summa_prec),intent(in) :: kAnisotropic ! anisotropy factor for lateral hydraulic conductivity (-) - real(summa_prec),intent(in) :: zScale_TOPMODEL ! scale factor for TOPMODEL-ish baseflow parameterization (m) + real(rk),intent(in) :: vGn_alpha ! van Genutchen "alpha" parameter (m-1) + real(rk),intent(in) :: vGn_n ! van Genutchen "n" parameter (-) + real(rk),intent(in) :: vGn_m ! van Genutchen "m" parameter (-) + real(rk),intent(in) :: theta_sat ! soil porosity (-) + real(rk),intent(in) :: theta_res ! soil residual volumetric water content (-) + real(rk),intent(in) :: kAnisotropic ! anisotropy factor for lateral hydraulic conductivity (-) + real(rk),intent(in) :: zScale_TOPMODEL ! scale factor for TOPMODEL-ish baseflow parameterization (m) ! ----------------------------------------------------------------------------------------------------------------------------- ! output: hydraulic conductivity at the bottom of the unsaturated zone - real(summa_prec),intent(out) :: bottomHydCond ! hydraulic conductivity at the bottom of the unsaturated zone (m s-1) - real(summa_prec),intent(out) :: bottomDiffuse ! hydraulic diffusivity at the bottom of the unsatuarted zone (m2 s-1) + real(rk),intent(out) :: bottomHydCond ! hydraulic conductivity at the bottom of the unsaturated zone (m s-1) + real(rk),intent(out) :: bottomDiffuse ! hydraulic diffusivity at the bottom of the unsatuarted zone (m2 s-1) ! output: drainage flux from the bottom of the soil profile - real(summa_prec),intent(out) :: scalarDrainage ! drainage flux from the bottom of the soil profile (m s-1) + real(rk),intent(out) :: scalarDrainage ! drainage flux from the bottom of the soil profile (m s-1) ! output: derivatives in drainage flux - real(summa_prec),intent(out) :: dq_dHydStateUnsat ! change in drainage flux w.r.t. change in state variable in lowest unsaturated node (m s-1 or s-1) - real(summa_prec),intent(out) :: dq_dNrgStateUnsat ! change in drainage flux w.r.t. change in energy state variable in lowest unsaturated node (m s-1 K-1) + real(rk),intent(out) :: dq_dHydStateUnsat ! change in drainage flux w.r.t. change in state variable in lowest unsaturated node (m s-1 or s-1) + real(rk),intent(out) :: dq_dNrgStateUnsat ! change in drainage flux w.r.t. change in energy state variable in lowest unsaturated node (m s-1 K-1) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! ----------------------------------------------------------------------------------------------------------------------------- ! local variables - real(summa_prec) :: zWater ! effective water table depth (m) - real(summa_prec) :: nodePsi ! matric head in the lowest unsaturated node (m) - real(summa_prec) :: cflux ! capillary flux (m s-1) + real(rk) :: zWater ! effective water table depth (m) + real(rk) :: nodePsi ! matric head in the lowest unsaturated node (m) + real(rk) :: cflux ! capillary flux (m s-1) ! ----------------------------------------------------------------------------------------------------------------------------- ! initialize error control err=0; message="qDrainFlux/" @@ -1651,13 +1651,13 @@ subroutine qDrainFlux(& bottomHydCond = hydCond_liq(lowerBoundTheta,bottomSatHydCond,theta_res,theta_sat,vGn_m) * iceImpedeFac bottomDiffuse = dPsi_dTheta(lowerBoundTheta,vGn_alpha,theta_res,theta_sat,vGn_n,vGn_m) * bottomHydCond ! compute the capillary flux - cflux = -bottomDiffuse*(lowerBoundTheta - nodeVolFracLiq) / (nodeDepth*0.5_summa_prec) + cflux = -bottomDiffuse*(lowerBoundTheta - nodeVolFracLiq) / (nodeDepth*0.5_rk) case(mixdform) ! compute the hydraulic conductivity and diffusivity at the boundary bottomHydCond = hydCond_psi(lowerBoundHead,bottomSatHydCond,vGn_alpha,vGn_n,vGn_m) * iceImpedeFac bottomDiffuse = realMissing ! compute the capillary flux - cflux = -bottomHydCond*(lowerBoundHead - nodeMatricHead) / (nodeDepth*0.5_summa_prec) + cflux = -bottomHydCond*(lowerBoundHead - nodeMatricHead) / (nodeDepth*0.5_rk) case default; err=10; message=trim(message)//"unknown form of Richards' equation"; return end select ! (form of Richards' eqn) scalarDrainage = cflux + bottomHydCond @@ -1666,12 +1666,12 @@ subroutine qDrainFlux(& if(deriv_desired)then ! hydrology derivatives select case(ixRichards) ! (form of Richards' equation) - case(moisture); dq_dHydStateUnsat = bottomDiffuse/(nodeDepth/2._summa_prec) - case(mixdform); dq_dHydStateUnsat = bottomHydCond/(nodeDepth/2._summa_prec) + case(moisture); dq_dHydStateUnsat = bottomDiffuse/(nodeDepth/2._rk) + case(mixdform); dq_dHydStateUnsat = bottomHydCond/(nodeDepth/2._rk) case default; err=10; message=trim(message)//"unknown form of Richards' equation"; return end select ! energy derivatives - dq_dNrgStateUnsat = -(dHydCond_dTemp/2._summa_prec)*(lowerBoundHead - nodeMatricHead)/(nodeDepth*0.5_summa_prec) + dHydCond_dTemp/2._summa_prec + dq_dNrgStateUnsat = -(dHydCond_dTemp/2._rk)*(lowerBoundHead - nodeMatricHead)/(nodeDepth*0.5_rk) + dHydCond_dTemp/2._rk else ! (do not desire derivatives) dq_dHydStateUnsat = realMissing dq_dNrgStateUnsat = realMissing @@ -1733,10 +1733,10 @@ subroutine qDrainFlux(& ! * zero flux ! --------------------------------------------------------------------------------------------- case(zeroFlux) - scalarDrainage = 0._summa_prec + scalarDrainage = 0._rk if(deriv_desired)then - dq_dHydStateUnsat = 0._summa_prec - dq_dNrgStateUnsat = 0._summa_prec + dq_dHydStateUnsat = 0._rk + dq_dNrgStateUnsat = 0._rk else dq_dHydStateUnsat = realMissing dq_dNrgStateUnsat = realMissing diff --git a/build/source/engine/soil_utils.f90 b/build/source/engine/soil_utils.f90 index 012cfb11c..99daf1ce8 100755 --- a/build/source/engine/soil_utils.f90 +++ b/build/source/engine/soil_utils.f90 @@ -52,9 +52,9 @@ module soil_utils_module public::gammp ! constant parameters -real(summa_prec),parameter :: valueMissing=-9999._summa_prec ! missing value parameter -real(summa_prec),parameter :: verySmall=epsilon(1.0_summa_prec) ! a very small number (used to avoid divide by zero) -real(summa_prec),parameter :: dx=-1.e-12_summa_prec ! finite difference increment +real(rk),parameter :: valueMissing=-9999._rk ! missing value parameter +real(rk),parameter :: verySmall=epsilon(1.0_rk) ! a very small number (used to avoid divide by zero) +real(rk),parameter :: dx=-1.e-12_rk ! finite difference increment contains @@ -66,14 +66,14 @@ subroutine iceImpede(volFracIce,f_impede, & ! input ! computes the ice impedence factor (separate function, as used multiple times) implicit none ! input variables - real(summa_prec),intent(in) :: volFracIce ! volumetric fraction of ice (-) - real(summa_prec),intent(in) :: f_impede ! ice impedence parameter (-) + real(rk),intent(in) :: volFracIce ! volumetric fraction of ice (-) + real(rk),intent(in) :: f_impede ! ice impedence parameter (-) ! output variables - real(summa_prec) :: iceImpedeFactor ! ice impedence factor (-) - real(summa_prec) :: dIceImpede_dLiq ! derivative in ice impedence factor w.r.t. volumetric liquid water content (-) + real(rk) :: iceImpedeFactor ! ice impedence factor (-) + real(rk) :: dIceImpede_dLiq ! derivative in ice impedence factor w.r.t. volumetric liquid water content (-) ! compute ice impedance factor as a function of volumetric ice content - iceImpedeFactor = 10._summa_prec**(-f_impede*volFracIce) - dIceImpede_dLiq = 0._summa_prec + iceImpedeFactor = 10._rk**(-f_impede*volFracIce) + dIceImpede_dLiq = 0._rk end subroutine iceImpede @@ -85,13 +85,13 @@ subroutine dIceImpede_dTemp(volFracIce,dTheta_dT,f_impede,dIceImpede_dT) ! computes the derivative in the ice impedance factor w.r.t. temperature implicit none ! input variables - real(summa_prec),intent(in) :: volFracIce ! volumetric fraction of ice (-) - real(summa_prec),intent(in) :: dTheta_dT ! derivative in volumetric liquid water content w.r.t temperature (K-1) - real(summa_prec),intent(in) :: f_impede ! ice impedence parameter (-) + real(rk),intent(in) :: volFracIce ! volumetric fraction of ice (-) + real(rk),intent(in) :: dTheta_dT ! derivative in volumetric liquid water content w.r.t temperature (K-1) + real(rk),intent(in) :: f_impede ! ice impedence parameter (-) ! output variables - real(summa_prec) :: dIceImpede_dT ! derivative in the ice impedance factor w.r.t. temperature (K-1) + real(rk) :: dIceImpede_dT ! derivative in the ice impedance factor w.r.t. temperature (K-1) ! -- - dIceImpede_dT = log(10._summa_prec)*f_impede*(10._summa_prec**(-f_impede*volFracIce))*dTheta_dT + dIceImpede_dT = log(10._rk)*f_impede*(10._rk**(-f_impede*volFracIce))*dTheta_dT end subroutine dIceImpede_dTemp @@ -114,30 +114,30 @@ subroutine liquidHead(& ! computes the liquid water matric potential (and the derivatives w.r.t. total matric potential and temperature) implicit none ! input - real(summa_prec),intent(in) :: matricHeadTotal ! total water matric potential (m) - real(summa_prec),intent(in) :: volFracLiq ! volumetric fraction of liquid water (-) - real(summa_prec),intent(in) :: volFracIce ! volumetric fraction of ice (-) - real(summa_prec),intent(in) :: vGn_alpha,vGn_n,theta_sat,theta_res,vGn_m ! soil parameters - real(summa_prec),intent(in) ,optional :: dVolTot_dPsi0 ! derivative in the soil water characteristic (m-1) - real(summa_prec),intent(in) ,optional :: dTheta_dT ! derivative in volumetric total water w.r.t. temperature (K-1) + real(rk),intent(in) :: matricHeadTotal ! total water matric potential (m) + real(rk),intent(in) :: volFracLiq ! volumetric fraction of liquid water (-) + real(rk),intent(in) :: volFracIce ! volumetric fraction of ice (-) + real(rk),intent(in) :: vGn_alpha,vGn_n,theta_sat,theta_res,vGn_m ! soil parameters + real(rk),intent(in) ,optional :: dVolTot_dPsi0 ! derivative in the soil water characteristic (m-1) + real(rk),intent(in) ,optional :: dTheta_dT ! derivative in volumetric total water w.r.t. temperature (K-1) ! output - real(summa_prec),intent(out) :: matricHeadLiq ! liquid water matric potential (m) - real(summa_prec),intent(out) ,optional :: dPsiLiq_dPsi0 ! derivative in the liquid water matric potential w.r.t. the total water matric potential (-) - real(summa_prec),intent(out) ,optional :: dPsiLiq_dTemp ! derivative in the liquid water matric potential w.r.t. temperature (m K-1) + real(rk),intent(out) :: matricHeadLiq ! liquid water matric potential (m) + real(rk),intent(out) ,optional :: dPsiLiq_dPsi0 ! derivative in the liquid water matric potential w.r.t. the total water matric potential (-) + real(rk),intent(out) ,optional :: dPsiLiq_dTemp ! derivative in the liquid water matric potential w.r.t. temperature (m K-1) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! local - real(summa_prec) :: xNum,xDen ! temporary variables (numeratir, denominator) - real(summa_prec) :: effSat ! effective saturation (-) - real(summa_prec) :: dPsiLiq_dEffSat ! derivative in liquid water matric potential w.r.t. effective saturation (m) - real(summa_prec) :: dEffSat_dTemp ! derivative in effective saturation w.r.t. temperature (K-1) + real(rk) :: xNum,xDen ! temporary variables (numeratir, denominator) + real(rk) :: effSat ! effective saturation (-) + real(rk) :: dPsiLiq_dEffSat ! derivative in liquid water matric potential w.r.t. effective saturation (m) + real(rk) :: dEffSat_dTemp ! derivative in effective saturation w.r.t. temperature (K-1) ! ------------------------------------------------------------------------------------------------------------------------------ ! initialize error control err=0; message='liquidHead/' ! ** partially frozen soil - if(volFracIce > verySmall .and. matricHeadTotal < 0._summa_prec)then ! check that ice exists and that the soil is unsaturated + if(volFracIce > verySmall .and. matricHeadTotal < 0._rk)then ! check that ice exists and that the soil is unsaturated ! ----- ! - compute liquid water matric potential... @@ -151,11 +151,11 @@ subroutine liquidHead(& effSat = xNum/xDen ! effective saturation ! - matric head associated with liquid water - matricHeadLiq = matricHead(effSat,vGn_alpha,0._summa_prec,1._summa_prec,vGn_n,vGn_m) ! argument is effective saturation, so theta_res=0 and theta_sat=1 + matricHeadLiq = matricHead(effSat,vGn_alpha,0._rk,1._rk,vGn_n,vGn_m) ! argument is effective saturation, so theta_res=0 and theta_sat=1 ! compute derivative in liquid water matric potential w.r.t. effective saturation (m) if(present(dPsiLiq_dPsi0).or.present(dPsiLiq_dTemp))then - dPsiLiq_dEffSat = dPsi_dTheta(effSat,vGn_alpha,0._summa_prec,1._summa_prec,vGn_n,vGn_m) + dPsiLiq_dEffSat = dPsi_dTheta(effSat,vGn_alpha,0._rk,1._rk,vGn_n,vGn_m) endif ! ----- @@ -172,7 +172,7 @@ subroutine liquidHead(& endif ! (compute derivative in the liquid water matric potential w.r.t. the total water matric potential) - dPsiLiq_dPsi0 = dVolTot_dPsi0*dPsiLiq_dEffSat*xNum/(xDen**2._summa_prec) + dPsiLiq_dPsi0 = dVolTot_dPsi0*dPsiLiq_dEffSat*xNum/(xDen**2._rk) endif ! if dPsiLiq_dTemp is desired @@ -190,7 +190,7 @@ subroutine liquidHead(& endif ! (compute the derivative in the liquid water matric potential w.r.t. temperature) - dEffSat_dTemp = -dTheta_dT*xNum/(xDen**2._summa_prec) + dTheta_dT/xDen + dEffSat_dTemp = -dTheta_dT*xNum/(xDen**2._rk) + dTheta_dT/xDen dPsiLiq_dTemp = dPsiLiq_dEffSat*dEffSat_dTemp endif ! if dPsiLiq_dTemp is desired @@ -198,8 +198,8 @@ subroutine liquidHead(& ! ** unfrozen soil else ! (no ice) matricHeadLiq = matricHeadTotal - if(present(dPsiLiq_dTemp)) dPsiLiq_dPsi0 = 1._summa_prec ! derivative=1 because values are identical - if(present(dPsiLiq_dTemp)) dPsiLiq_dTemp = 0._summa_prec ! derivative=0 because no impact of temperature for unfrozen conditions + if(present(dPsiLiq_dTemp)) dPsiLiq_dPsi0 = 1._rk ! derivative=1 because values are identical + if(present(dPsiLiq_dTemp)) dPsiLiq_dTemp = 0._rk ! derivative=0 because no impact of temperature for unfrozen conditions end if ! (if ice exists) end subroutine liquidHead @@ -212,20 +212,20 @@ function hydCondMP_liq(volFracLiq,theta_sat,theta_mp,mpExp,satHydCond_ma,satHydC ! theta_sat, theta_mp, mpExp, satHydCond_ma, and satHydCond_mi implicit none ! dummies - real(summa_prec),intent(in) :: volFracLiq ! volumetric liquid water content (-) - real(summa_prec),intent(in) :: theta_sat ! soil porosity (-) - real(summa_prec),intent(in) :: theta_mp ! minimum volumetric liquid water content for macropore flow (-) - real(summa_prec),intent(in) :: mpExp ! empirical exponent in macropore flow equation (-) - real(summa_prec),intent(in) :: satHydCond_ma ! saturated hydraulic conductivity for macropores (m s-1) - real(summa_prec),intent(in) :: satHydCond_mi ! saturated hydraulic conductivity for micropores (m s-1) - real(summa_prec) :: hydCondMP_liq ! hydraulic conductivity (m s-1) + real(rk),intent(in) :: volFracLiq ! volumetric liquid water content (-) + real(rk),intent(in) :: theta_sat ! soil porosity (-) + real(rk),intent(in) :: theta_mp ! minimum volumetric liquid water content for macropore flow (-) + real(rk),intent(in) :: mpExp ! empirical exponent in macropore flow equation (-) + real(rk),intent(in) :: satHydCond_ma ! saturated hydraulic conductivity for macropores (m s-1) + real(rk),intent(in) :: satHydCond_mi ! saturated hydraulic conductivity for micropores (m s-1) + real(rk) :: hydCondMP_liq ! hydraulic conductivity (m s-1) ! locals - real(summa_prec) :: theta_e ! effective soil moisture + real(rk) :: theta_e ! effective soil moisture if(volFracLiq > theta_mp)then theta_e = (volFracLiq - theta_mp) / (theta_sat - theta_mp) hydCondMP_liq = (satHydCond_ma - satHydCond_mi) * (theta_e**mpExp) else - hydCondMP_liq = 0._summa_prec + hydCondMP_liq = 0._rk end if !write(*,'(a,4(f9.3,1x),2(e20.10))') 'in soil_utils: theta_mp, theta_sat, volFracLiq, hydCondMP_liq, satHydCond_ma, satHydCond_mi = ', & ! theta_mp, theta_sat, volFracLiq, hydCondMP_liq, satHydCond_ma, satHydCond_mi @@ -239,16 +239,16 @@ function hydCond_psi(psi,k_sat,alpha,n,m) ! computes hydraulic conductivity given psi and soil hydraulic parameters k_sat, alpha, n, and m implicit none ! dummies - real(summa_prec),intent(in) :: psi ! soil water suction (m) - real(summa_prec),intent(in) :: k_sat ! saturated hydraulic conductivity (m s-1) - real(summa_prec),intent(in) :: alpha ! scaling parameter (m-1) - real(summa_prec),intent(in) :: n ! vGn "n" parameter (-) - real(summa_prec),intent(in) :: m ! vGn "m" parameter (-) - real(summa_prec) :: hydCond_psi ! hydraulic conductivity (m s-1) - if(psi<0._summa_prec)then + real(rk),intent(in) :: psi ! soil water suction (m) + real(rk),intent(in) :: k_sat ! saturated hydraulic conductivity (m s-1) + real(rk),intent(in) :: alpha ! scaling parameter (m-1) + real(rk),intent(in) :: n ! vGn "n" parameter (-) + real(rk),intent(in) :: m ! vGn "m" parameter (-) + real(rk) :: hydCond_psi ! hydraulic conductivity (m s-1) + if(psi<0._rk)then hydCond_psi = k_sat * & - ( ( (1._summa_prec - (psi*alpha)**(n-1._summa_prec) * (1._summa_prec + (psi*alpha)**n)**(-m))**2._summa_prec ) & - / ( (1._summa_prec + (psi*alpha)**n)**(m/2._summa_prec) ) ) + ( ( (1._rk - (psi*alpha)**(n-1._rk) * (1._rk + (psi*alpha)**n)**(-m))**2._rk ) & + / ( (1._rk + (psi*alpha)**n)**(m/2._rk) ) ) else hydCond_psi = k_sat end if @@ -262,17 +262,17 @@ function hydCond_liq(volFracLiq,k_sat,theta_res,theta_sat,m) ! computes hydraulic conductivity given volFracLiq and soil hydraulic parameters k_sat, theta_sat, theta_res, and m implicit none ! dummies - real(summa_prec),intent(in) :: volFracLiq ! volumetric liquid water content (-) - real(summa_prec),intent(in) :: k_sat ! saturated hydraulic conductivity (m s-1) - real(summa_prec),intent(in) :: theta_res ! residual volumetric liquid water content (-) - real(summa_prec),intent(in) :: theta_sat ! soil porosity (-) - real(summa_prec),intent(in) :: m ! vGn "m" parameter (-) - real(summa_prec) :: hydCond_liq ! hydraulic conductivity (m s-1) + real(rk),intent(in) :: volFracLiq ! volumetric liquid water content (-) + real(rk),intent(in) :: k_sat ! saturated hydraulic conductivity (m s-1) + real(rk),intent(in) :: theta_res ! residual volumetric liquid water content (-) + real(rk),intent(in) :: theta_sat ! soil porosity (-) + real(rk),intent(in) :: m ! vGn "m" parameter (-) + real(rk) :: hydCond_liq ! hydraulic conductivity (m s-1) ! locals - real(summa_prec) :: theta_e ! effective soil moisture + real(rk) :: theta_e ! effective soil moisture if(volFracLiq < theta_sat)then theta_e = (volFracLiq - theta_res) / (theta_sat - theta_res) - hydCond_liq = k_sat*theta_e**(1._summa_prec/2._summa_prec) * (1._summa_prec - (1._summa_prec - theta_e**(1._summa_prec/m) )**m)**2._summa_prec + hydCond_liq = k_sat*theta_e**(1._rk/2._rk) * (1._rk - (1._rk - theta_e**(1._rk/m) )**m)**2._rk else hydCond_liq = k_sat end if @@ -285,15 +285,15 @@ end function hydCond_liq function volFracLiq(psi,alpha,theta_res,theta_sat,n,m) ! computes the volumetric liquid water content given psi and soil hydraulic parameters theta_res, theta_sat, alpha, n, and m implicit none - real(summa_prec),intent(in) :: psi ! soil water suction (m) - real(summa_prec),intent(in) :: alpha ! scaling parameter (m-1) - real(summa_prec),intent(in) :: theta_res ! residual volumetric water content (-) - real(summa_prec),intent(in) :: theta_sat ! porosity (-) - real(summa_prec),intent(in) :: n ! vGn "n" parameter (-) - real(summa_prec),intent(in) :: m ! vGn "m" parameter (-) - real(summa_prec) :: volFracLiq ! volumetric liquid water content (-) - if(psi<0._summa_prec)then - volFracLiq = theta_res + (theta_sat - theta_res)*(1._summa_prec + (alpha*psi)**n)**(-m) + real(rk),intent(in) :: psi ! soil water suction (m) + real(rk),intent(in) :: alpha ! scaling parameter (m-1) + real(rk),intent(in) :: theta_res ! residual volumetric water content (-) + real(rk),intent(in) :: theta_sat ! porosity (-) + real(rk),intent(in) :: n ! vGn "n" parameter (-) + real(rk),intent(in) :: m ! vGn "m" parameter (-) + real(rk) :: volFracLiq ! volumetric liquid water content (-) + if(psi<0._rk)then + volFracLiq = theta_res + (theta_sat - theta_res)*(1._rk + (alpha*psi)**n)**(-m) else volFracLiq = theta_sat end if @@ -307,23 +307,23 @@ function matricHead(theta,alpha,theta_res,theta_sat,n,m) ! computes the volumetric liquid water content given psi and soil hydraulic parameters theta_res, theta_sat, alpha, n, and m implicit none ! dummy variables - real(summa_prec),intent(in) :: theta ! volumetric liquid water content (-) - real(summa_prec),intent(in) :: alpha ! scaling parameter (m-1) - real(summa_prec),intent(in) :: theta_res ! residual volumetric water content (-) - real(summa_prec),intent(in) :: theta_sat ! porosity (-) - real(summa_prec),intent(in) :: n ! vGn "n" parameter (-) - real(summa_prec),intent(in) :: m ! vGn "m" parameter (-) - real(summa_prec) :: matricHead ! matric head (m) + real(rk),intent(in) :: theta ! volumetric liquid water content (-) + real(rk),intent(in) :: alpha ! scaling parameter (m-1) + real(rk),intent(in) :: theta_res ! residual volumetric water content (-) + real(rk),intent(in) :: theta_sat ! porosity (-) + real(rk),intent(in) :: n ! vGn "n" parameter (-) + real(rk),intent(in) :: m ! vGn "m" parameter (-) + real(rk) :: matricHead ! matric head (m) ! local variables - real(summa_prec) :: effSat ! effective saturation (-) - real(summa_prec),parameter :: verySmall=epsilon(1._summa_prec) ! a very small number (avoid effective saturation of zero) + real(rk) :: effSat ! effective saturation (-) + real(rk),parameter :: verySmall=epsilon(1._rk) ! a very small number (avoid effective saturation of zero) ! compute effective saturation effSat = max(verySmall, (theta - theta_res) / (theta_sat - theta_res)) ! compute matric head - if (effSat < 1._summa_prec .and. effSat > 0._summa_prec)then - matricHead = (1._summa_prec/alpha)*( effSat**(-1._summa_prec/m) - 1._summa_prec)**(1._summa_prec/n) + if (effSat < 1._rk .and. effSat > 0._rk)then + matricHead = (1._rk/alpha)*( effSat**(-1._rk/m) - 1._rk)**(1._rk/n) else - matricHead = 0._summa_prec + matricHead = 0._rk end if end function matricHead @@ -333,16 +333,16 @@ end function matricHead ! ****************************************************************************************************************************** function dTheta_dPsi(psi,alpha,theta_res,theta_sat,n,m) implicit none - real(summa_prec),intent(in) :: psi ! soil water suction (m) - real(summa_prec),intent(in) :: alpha ! scaling parameter (m-1) - real(summa_prec),intent(in) :: theta_res ! residual volumetric water content (-) - real(summa_prec),intent(in) :: theta_sat ! porosity (-) - real(summa_prec),intent(in) :: n ! vGn "n" parameter (-) - real(summa_prec),intent(in) :: m ! vGn "m" parameter (-) - real(summa_prec) :: dTheta_dPsi ! derivative of the soil water characteristic (m-1) - if(psi<=0._summa_prec)then + real(rk),intent(in) :: psi ! soil water suction (m) + real(rk),intent(in) :: alpha ! scaling parameter (m-1) + real(rk),intent(in) :: theta_res ! residual volumetric water content (-) + real(rk),intent(in) :: theta_sat ! porosity (-) + real(rk),intent(in) :: n ! vGn "n" parameter (-) + real(rk),intent(in) :: m ! vGn "m" parameter (-) + real(rk) :: dTheta_dPsi ! derivative of the soil water characteristic (m-1) + if(psi<=0._rk)then dTheta_dPsi = (theta_sat-theta_res) * & - (-m*(1._summa_prec + (psi*alpha)**n)**(-m-1._summa_prec)) * n*(psi*alpha)**(n-1._summa_prec) * alpha + (-m*(1._rk + (psi*alpha)**n)**(-m-1._rk)) * n*(psi*alpha)**(n-1._rk) * alpha if(abs(dTheta_dPsi) < epsilon(psi)) dTheta_dPsi = epsilon(psi) else dTheta_dPsi = epsilon(psi) @@ -356,31 +356,31 @@ end function dTheta_dPsi function dPsi_dTheta(volFracLiq,alpha,theta_res,theta_sat,n,m) implicit none ! dummies - real(summa_prec),intent(in) :: volFracLiq ! volumetric liquid water content (-) - real(summa_prec),intent(in) :: alpha ! scaling parameter (m-1) - real(summa_prec),intent(in) :: theta_res ! residual volumetric water content (-) - real(summa_prec),intent(in) :: theta_sat ! porosity (-) - real(summa_prec),intent(in) :: n ! vGn "n" parameter (-) - real(summa_prec),intent(in) :: m ! vGn "m" parameter (-) - real(summa_prec) :: dPsi_dTheta ! derivative of the soil water characteristic (m) + real(rk),intent(in) :: volFracLiq ! volumetric liquid water content (-) + real(rk),intent(in) :: alpha ! scaling parameter (m-1) + real(rk),intent(in) :: theta_res ! residual volumetric water content (-) + real(rk),intent(in) :: theta_sat ! porosity (-) + real(rk),intent(in) :: n ! vGn "n" parameter (-) + real(rk),intent(in) :: m ! vGn "m" parameter (-) + real(rk) :: dPsi_dTheta ! derivative of the soil water characteristic (m) ! locals - real(summa_prec) :: y1,d1 ! 1st function and derivative - real(summa_prec) :: y2,d2 ! 2nd function and derivative - real(summa_prec) :: theta_e ! effective soil moisture + real(rk) :: y1,d1 ! 1st function and derivative + real(rk) :: y2,d2 ! 2nd function and derivative + real(rk) :: theta_e ! effective soil moisture ! check if less than saturation if(volFracLiq < theta_sat)then ! compute effective water content theta_e = max(0.001,(volFracLiq - theta_res) / (theta_sat - theta_res)) ! compute the 1st function and derivative - y1 = theta_e**(-1._summa_prec/m) - 1._summa_prec - d1 = (-1._summa_prec/m)*theta_e**(-1._summa_prec/m - 1._summa_prec) / (theta_sat - theta_res) + y1 = theta_e**(-1._rk/m) - 1._rk + d1 = (-1._rk/m)*theta_e**(-1._rk/m - 1._rk) / (theta_sat - theta_res) ! compute the 2nd function and derivative - y2 = y1**(1._summa_prec/n) - d2 = (1._summa_prec/n)*y1**(1._summa_prec/n - 1._summa_prec) + y2 = y1**(1._rk/n) + d2 = (1._rk/n)*y1**(1._rk/n - 1._rk) ! compute the final function value dPsi_dTheta = d1*d2/alpha else - dPsi_dTheta = 0._summa_prec + dPsi_dTheta = 0._rk end if end function dPsi_dTheta @@ -391,21 +391,21 @@ end function dPsi_dTheta function dPsi_dTheta2(volFracLiq,alpha,theta_res,theta_sat,n,m,lTangent) implicit none ! dummies - real(summa_prec),intent(in) :: volFracLiq ! volumetric liquid water content (-) - real(summa_prec),intent(in) :: alpha ! scaling parameter (m-1) - real(summa_prec),intent(in) :: theta_res ! residual volumetric water content (-) - real(summa_prec),intent(in) :: theta_sat ! porosity (-) - real(summa_prec),intent(in) :: n ! vGn "n" parameter (-) - real(summa_prec),intent(in) :: m ! vGn "m" parameter (-) + real(rk),intent(in) :: volFracLiq ! volumetric liquid water content (-) + real(rk),intent(in) :: alpha ! scaling parameter (m-1) + real(rk),intent(in) :: theta_res ! residual volumetric water content (-) + real(rk),intent(in) :: theta_sat ! porosity (-) + real(rk),intent(in) :: n ! vGn "n" parameter (-) + real(rk),intent(in) :: m ! vGn "m" parameter (-) logical(lgt),intent(in) :: lTangent ! method used to compute derivative (.true. = analytical) - real(summa_prec) :: dPsi_dTheta2 ! derivative of the soil water characteristic (m) + real(rk) :: dPsi_dTheta2 ! derivative of the soil water characteristic (m) ! locals for analytical derivatives - real(summa_prec) :: xx ! temporary variable - real(summa_prec) :: y1,d1 ! 1st function and derivative - real(summa_prec) :: y2,d2 ! 2nd function and derivative - real(summa_prec) :: theta_e ! effective soil moisture + real(rk) :: xx ! temporary variable + real(rk) :: y1,d1 ! 1st function and derivative + real(rk) :: y2,d2 ! 2nd function and derivative + real(rk) :: theta_e ! effective soil moisture ! locals for numerical derivative - real(summa_prec) :: func0,func1 ! function evaluations + real(rk) :: func0,func1 ! function evaluations ! check if less than saturation if(volFracLiq < theta_sat)then ! ***** compute analytical derivatives @@ -413,12 +413,12 @@ function dPsi_dTheta2(volFracLiq,alpha,theta_res,theta_sat,n,m,lTangent) ! compute the effective saturation theta_e = (volFracLiq - theta_res) / (theta_sat - theta_res) ! get the first function and derivative - y1 = (-1._summa_prec/m)*theta_e**(-1._summa_prec/m - 1._summa_prec) / (theta_sat - theta_res) - d1 = ( (m + 1._summa_prec) / (m**2._summa_prec * (theta_sat - theta_res)**2._summa_prec) ) * theta_e**(-1._summa_prec/m - 2._summa_prec) + y1 = (-1._rk/m)*theta_e**(-1._rk/m - 1._rk) / (theta_sat - theta_res) + d1 = ( (m + 1._rk) / (m**2._rk * (theta_sat - theta_res)**2._rk) ) * theta_e**(-1._rk/m - 2._rk) ! get the second function and derivative - xx = theta_e**(-1._summa_prec/m) - 1._summa_prec - y2 = (1._summa_prec/n)*xx**(1._summa_prec/n - 1._summa_prec) - d2 = ( -(1._summa_prec - n)/((theta_sat - theta_res)*m*n**2._summa_prec) ) * xx**(1._summa_prec/n - 2._summa_prec) * theta_e**(-1._summa_prec/m - 1._summa_prec) + xx = theta_e**(-1._rk/m) - 1._rk + y2 = (1._rk/n)*xx**(1._rk/n - 1._rk) + d2 = ( -(1._rk - n)/((theta_sat - theta_res)*m*n**2._rk) ) * xx**(1._rk/n - 2._rk) * theta_e**(-1._rk/m - 1._rk) ! return the derivative dPsi_dTheta2 = (d1*y2 + y1*d2)/alpha ! ***** compute numerical derivatives @@ -429,7 +429,7 @@ function dPsi_dTheta2(volFracLiq,alpha,theta_res,theta_sat,n,m,lTangent) end if ! (case where volumetric liquid water content exceeds porosity) else - dPsi_dTheta2 = 0._summa_prec + dPsi_dTheta2 = 0._rk end if end function dPsi_dTheta2 @@ -442,41 +442,41 @@ function dHydCond_dPsi(psi,k_sat,alpha,n,m,lTangent) ! given psi and soil hydraulic parameters k_sat, alpha, n, and m implicit none ! dummies - real(summa_prec),intent(in) :: psi ! soil water suction (m) - real(summa_prec),intent(in) :: k_sat ! saturated hydraulic conductivity (m s-1) - real(summa_prec),intent(in) :: alpha ! scaling parameter (m-1) - real(summa_prec),intent(in) :: n ! vGn "n" parameter (-) - real(summa_prec),intent(in) :: m ! vGn "m" parameter (-) + real(rk),intent(in) :: psi ! soil water suction (m) + real(rk),intent(in) :: k_sat ! saturated hydraulic conductivity (m s-1) + real(rk),intent(in) :: alpha ! scaling parameter (m-1) + real(rk),intent(in) :: n ! vGn "n" parameter (-) + real(rk),intent(in) :: m ! vGn "m" parameter (-) logical(lgt),intent(in) :: lTangent ! method used to compute derivative (.true. = analytical) - real(summa_prec) :: dHydCond_dPsi ! derivative in hydraulic conductivity w.r.t. matric head (s-1) + real(rk) :: dHydCond_dPsi ! derivative in hydraulic conductivity w.r.t. matric head (s-1) ! locals for analytical derivatives - real(summa_prec) :: f_x1 ! f(x) for part of the numerator - real(summa_prec) :: f_x2 ! f(x) for part of the numerator - real(summa_prec) :: f_nm ! f(x) for the numerator - real(summa_prec) :: f_dm ! f(x) for the denominator - real(summa_prec) :: d_x1 ! df(x)/dpsi for part of the numerator - real(summa_prec) :: d_x2 ! df(x)/dpsi for part of the numerator - real(summa_prec) :: d_nm ! df(x)/dpsi for the numerator - real(summa_prec) :: d_dm ! df(x)/dpsi for the denominator + real(rk) :: f_x1 ! f(x) for part of the numerator + real(rk) :: f_x2 ! f(x) for part of the numerator + real(rk) :: f_nm ! f(x) for the numerator + real(rk) :: f_dm ! f(x) for the denominator + real(rk) :: d_x1 ! df(x)/dpsi for part of the numerator + real(rk) :: d_x2 ! df(x)/dpsi for part of the numerator + real(rk) :: d_nm ! df(x)/dpsi for the numerator + real(rk) :: d_dm ! df(x)/dpsi for the denominator ! locals for numerical derivatives - real(summa_prec) :: hydCond0 ! hydraulic condictivity value for base case - real(summa_prec) :: hydCond1 ! hydraulic condictivity value for perturbed case + real(rk) :: hydCond0 ! hydraulic condictivity value for base case + real(rk) :: hydCond1 ! hydraulic condictivity value for perturbed case ! derivative is zero if saturated - if(psi<0._summa_prec)then + if(psi<0._rk)then ! ***** compute analytical derivatives if(lTangent)then ! compute the derivative for the numerator - f_x1 = (psi*alpha)**(n - 1._summa_prec) - f_x2 = (1._summa_prec + (psi*alpha)**n)**(-m) - d_x1 = alpha * (n - 1._summa_prec)*(psi*alpha)**(n - 2._summa_prec) - d_x2 = alpha * n*(psi*alpha)**(n - 1._summa_prec) * (-m)*(1._summa_prec + (psi*alpha)**n)**(-m - 1._summa_prec) - f_nm = (1._summa_prec - f_x1*f_x2)**2._summa_prec - d_nm = (-d_x1*f_x2 - f_x1*d_x2) * 2._summa_prec*(1._summa_prec - f_x1*f_x2) + f_x1 = (psi*alpha)**(n - 1._rk) + f_x2 = (1._rk + (psi*alpha)**n)**(-m) + d_x1 = alpha * (n - 1._rk)*(psi*alpha)**(n - 2._rk) + d_x2 = alpha * n*(psi*alpha)**(n - 1._rk) * (-m)*(1._rk + (psi*alpha)**n)**(-m - 1._rk) + f_nm = (1._rk - f_x1*f_x2)**2._rk + d_nm = (-d_x1*f_x2 - f_x1*d_x2) * 2._rk*(1._rk - f_x1*f_x2) ! compute the derivative for the denominator - f_dm = (1._summa_prec + (psi*alpha)**n)**(m/2._summa_prec) - d_dm = alpha * n*(psi*alpha)**(n - 1._summa_prec) * (m/2._summa_prec)*(1._summa_prec + (psi*alpha)**n)**(m/2._summa_prec - 1._summa_prec) + f_dm = (1._rk + (psi*alpha)**n)**(m/2._rk) + d_dm = alpha * n*(psi*alpha)**(n - 1._rk) * (m/2._rk)*(1._rk + (psi*alpha)**n)**(m/2._rk - 1._rk) ! and combine - dHydCond_dPsi = k_sat*(d_nm*f_dm - d_dm*f_nm) / (f_dm**2._summa_prec) + dHydCond_dPsi = k_sat*(d_nm*f_dm - d_dm*f_nm) / (f_dm**2._rk) else ! ***** compute numerical derivatives hydcond0 = hydCond_psi(psi, k_sat,alpha,n,m) @@ -484,7 +484,7 @@ function dHydCond_dPsi(psi,k_sat,alpha,n,m,lTangent) dHydCond_dPsi = (hydcond1 - hydcond0)/dx end if else - dHydCond_dPsi = 0._summa_prec + dHydCond_dPsi = 0._rk end if end function dHydCond_dPsi @@ -498,24 +498,24 @@ end function dHydCond_dPsi function dHydCond_dLiq(volFracLiq,k_sat,theta_res,theta_sat,m,lTangent) implicit none ! dummies - real(summa_prec),intent(in) :: volFracLiq ! volumetric fraction of liquid water (-) - real(summa_prec),intent(in) :: k_sat ! saturated hydraulic conductivity (m s-1) - real(summa_prec),intent(in) :: theta_res ! soil residual volumetric water content (-) - real(summa_prec),intent(in) :: theta_sat ! soil porosity (-) - real(summa_prec),intent(in) :: m ! vGn "m" parameter (-) + real(rk),intent(in) :: volFracLiq ! volumetric fraction of liquid water (-) + real(rk),intent(in) :: k_sat ! saturated hydraulic conductivity (m s-1) + real(rk),intent(in) :: theta_res ! soil residual volumetric water content (-) + real(rk),intent(in) :: theta_sat ! soil porosity (-) + real(rk),intent(in) :: m ! vGn "m" parameter (-) logical(lgt),intent(in) :: lTangent ! method used to compute derivative (.true. = analytical) - real(summa_prec) :: dHydCond_dLiq ! derivative in hydraulic conductivity w.r.t. matric head (s-1) + real(rk) :: dHydCond_dLiq ! derivative in hydraulic conductivity w.r.t. matric head (s-1) ! locals for analytical derivatives - real(summa_prec) :: theta_e ! effective soil moisture - real(summa_prec) :: f1 ! f(x) for the first function - real(summa_prec) :: d1 ! df(x)/dLiq for the first function - real(summa_prec) :: x1,x2 ! f(x) for different parts of the second function - real(summa_prec) :: p1,p2,p3 ! df(x)/dLiq for different parts of the second function - real(summa_prec) :: f2 ! f(x) for the second function - real(summa_prec) :: d2 ! df(x)/dLiq for the second function + real(rk) :: theta_e ! effective soil moisture + real(rk) :: f1 ! f(x) for the first function + real(rk) :: d1 ! df(x)/dLiq for the first function + real(rk) :: x1,x2 ! f(x) for different parts of the second function + real(rk) :: p1,p2,p3 ! df(x)/dLiq for different parts of the second function + real(rk) :: f2 ! f(x) for the second function + real(rk) :: d2 ! df(x)/dLiq for the second function ! locals for numerical derivatives - real(summa_prec) :: hydCond0 ! hydraulic condictivity value for base case - real(summa_prec) :: hydCond1 ! hydraulic condictivity value for perturbed case + real(rk) :: hydCond0 ! hydraulic condictivity value for base case + real(rk) :: hydCond1 ! hydraulic condictivity value for perturbed case ! derivative is zero if super-saturated if(volFracLiq < theta_sat)then ! ***** compute analytical derivatives @@ -523,18 +523,18 @@ function dHydCond_dLiq(volFracLiq,k_sat,theta_res,theta_sat,m,lTangent) ! compute the effective saturation theta_e = (volFracLiq - theta_res) / (theta_sat - theta_res) ! compute the function and derivative of the first fuction - f1 = k_sat*theta_e**0.5_summa_prec - d1 = k_sat*0.5_summa_prec*theta_e**(-0.5_summa_prec) / (theta_sat - theta_res) + f1 = k_sat*theta_e**0.5_rk + d1 = k_sat*0.5_rk*theta_e**(-0.5_rk) / (theta_sat - theta_res) ! compute the function and derivative of the second function ! (first part) - x1 = 1._summa_prec - theta_e**(1._summa_prec/m) - p1 = (-1._summa_prec/m)*theta_e**(1._summa_prec/m - 1._summa_prec) / (theta_sat - theta_res) ! differentiate (1.d - theta_e**(1.d/m) + x1 = 1._rk - theta_e**(1._rk/m) + p1 = (-1._rk/m)*theta_e**(1._rk/m - 1._rk) / (theta_sat - theta_res) ! differentiate (1.d - theta_e**(1.d/m) ! (second part) x2 = x1**m - p2 = m*x1**(m - 1._summa_prec) + p2 = m*x1**(m - 1._rk) ! (final) - f2 = (1._summa_prec - x2)**2._summa_prec - p3 = -2._summa_prec*(1._summa_prec - x2) + f2 = (1._rk - x2)**2._rk + p3 = -2._rk*(1._rk - x2) ! (combine) d2 = p1*p2*p3 ! pull it all together @@ -546,7 +546,7 @@ function dHydCond_dLiq(volFracLiq,k_sat,theta_res,theta_sat,m,lTangent) dHydCond_dLiq = (hydcond1 - hydcond0)/dx end if else - dHydCond_dLiq = 0._summa_prec + dHydCond_dLiq = 0._rk end if end function dHydCond_dLiq @@ -556,9 +556,9 @@ end function dHydCond_dLiq ! ****************************************************************************************************************************** function RH_soilair(matpot,Tk) implicit none - real(summa_prec),intent(in) :: matpot ! soil water suction -- matric potential (m) - real(summa_prec),intent(in) :: Tk ! temperature (K) - real(summa_prec) :: RH_soilair ! relative humidity of air in soil pore space + real(rk),intent(in) :: matpot ! soil water suction -- matric potential (m) + real(rk),intent(in) :: Tk ! temperature (K) + real(rk) :: RH_soilair ! relative humidity of air in soil pore space ! compute relative humidity (UNITS NOTE: Pa = kg m-1 s-2, so R_wv units = m2 s-2 K-1) RH_soilair = exp( (gravity*matpot) / (R_wv*Tk) ) end function RH_soilair @@ -569,9 +569,9 @@ end function RH_soilair ! ****************************************************************************************************************************** function crit_soilT(psi) implicit none - real(summa_prec),intent(in) :: psi ! matric head (m) - real(summa_prec) :: crit_soilT ! critical soil temperature (K) - crit_soilT = Tfreeze + min(psi,0._summa_prec)*gravity*Tfreeze/LH_fus + real(rk),intent(in) :: psi ! matric head (m) + real(rk) :: crit_soilT ! critical soil temperature (K) + crit_soilT = Tfreeze + min(psi,0._rk)*gravity*Tfreeze/LH_fus end function crit_soilT @@ -580,22 +580,22 @@ end function crit_soilT ! ****************************************************************************************************************************** function dTheta_dTk(Tk,theta_res,theta_sat,alpha,n,m) implicit none - real(summa_prec),intent(in) :: Tk ! temperature (K) - real(summa_prec),intent(in) :: theta_res ! residual liquid water content (-) - real(summa_prec),intent(in) :: theta_sat ! porosity (-) - real(summa_prec),intent(in) :: alpha ! vGn scaling parameter (m-1) - real(summa_prec),intent(in) :: n ! vGn "n" parameter (-) - real(summa_prec),intent(in) :: m ! vGn "m" parameter (-) - real(summa_prec) :: dTheta_dTk ! derivative of the freezing curve w.r.t. temperature (K-1) + real(rk),intent(in) :: Tk ! temperature (K) + real(rk),intent(in) :: theta_res ! residual liquid water content (-) + real(rk),intent(in) :: theta_sat ! porosity (-) + real(rk),intent(in) :: alpha ! vGn scaling parameter (m-1) + real(rk),intent(in) :: n ! vGn "n" parameter (-) + real(rk),intent(in) :: m ! vGn "m" parameter (-) + real(rk) :: dTheta_dTk ! derivative of the freezing curve w.r.t. temperature (K-1) ! local variables - real(summa_prec) :: kappa ! constant (m K-1) - real(summa_prec) :: xtemp ! alpha*kappa*(Tk-Tfreeze) -- dimensionless variable (used more than once) + real(rk) :: kappa ! constant (m K-1) + real(rk) :: xtemp ! alpha*kappa*(Tk-Tfreeze) -- dimensionless variable (used more than once) ! compute kappa (m K-1) kappa = LH_fus/(gravity*Tfreeze) ! NOTE: J = kg m2 s-2 ! define a tempory variable that is used more than once (-) xtemp = alpha*kappa*(Tk-Tfreeze) ! differentiate the freezing curve w.r.t. temperature -- making use of the chain rule - dTheta_dTk = (alpha*kappa) * n*xtemp**(n - 1._summa_prec) * (-m)*(1._summa_prec + xtemp**n)**(-m - 1._summa_prec) * (theta_sat - theta_res) + dTheta_dTk = (alpha*kappa) * n*xtemp**(n - 1._rk) * (-m)*(1._rk + xtemp**n)**(-m - 1._rk) * (theta_sat - theta_res) end function dTheta_dTk @@ -604,12 +604,12 @@ end function dTheta_dTk ! ****************************************************************************************************************************** FUNCTION gammp(a,x) IMPLICIT NONE - real(summa_prec), INTENT(IN) :: a,x - real(summa_prec) :: gammp - if (x ITMAX) stop 'a too large, ITMAX too small in gcf' if (present(gln)) then @@ -661,22 +661,22 @@ END FUNCTION gcf ! ****************************************************************************************************************************** FUNCTION gser(a,x,gln) IMPLICIT NONE - real(summa_prec), INTENT(IN) :: a,x - real(summa_prec), OPTIONAL, INTENT(OUT) :: gln - real(summa_prec) :: gser + real(rk), INTENT(IN) :: a,x + real(rk), OPTIONAL, INTENT(OUT) :: gln + real(rk) :: gser INTEGER(I4B), PARAMETER :: ITMAX=100 - real(summa_prec), PARAMETER :: EPS=epsilon(x) + real(rk), PARAMETER :: EPS=epsilon(x) INTEGER(I4B) :: n - real(summa_prec) :: ap,del,summ + real(rk) :: ap,del,summ if (x == 0.0) then gser=0.0 RETURN end if ap=a - summ=1.0_summa_prec/a + summ=1.0_rk/a del=summ do n=1,ITMAX - ap=ap+1.0_summa_prec + ap=ap+1.0_rk del=del*x/ap summ=summ+del if (abs(del) < abs(summ)*EPS) exit @@ -697,20 +697,20 @@ END FUNCTION gser FUNCTION gammln(xx) USE nr_utility_module,only:arth ! use to build vectors with regular increments IMPLICIT NONE - real(summa_prec), INTENT(IN) :: xx - real(summa_prec) :: gammln - real(summa_prec) :: tmp,x - real(summa_prec) :: stp = 2.5066282746310005_summa_prec - real(summa_prec), DIMENSION(6) :: coef = (/76.18009172947146_summa_prec,& - -86.50532032941677_summa_prec,24.01409824083091_summa_prec,& - -1.231739572450155_summa_prec,0.1208650973866179e-2_summa_prec,& - -0.5395239384953e-5_summa_prec/) - if(xx <= 0._summa_prec) stop 'xx > 0 in gammln' + real(rk), INTENT(IN) :: xx + real(rk) :: gammln + real(rk) :: tmp,x + real(rk) :: stp = 2.5066282746310005_rk + real(rk), DIMENSION(6) :: coef = (/76.18009172947146_rk,& + -86.50532032941677_rk,24.01409824083091_rk,& + -1.231739572450155_rk,0.1208650973866179e-2_rk,& + -0.5395239384953e-5_rk/) + if(xx <= 0._rk) stop 'xx > 0 in gammln' x=xx - tmp=x+5.5_summa_prec - tmp=(x+0.5_summa_prec)*log(tmp)-tmp - gammln=tmp+log(stp*(1.000000000190015_summa_prec+& - sum(coef(:)/arth(x+1.0_summa_prec,1.0_summa_prec,size(coef))))/x) + tmp=x+5.5_rk + tmp=(x+0.5_rk)*log(tmp)-tmp + gammln=tmp+log(stp*(1.000000000190015_rk+& + sum(coef(:)/arth(x+1.0_rk,1.0_rk,size(coef))))/x) END FUNCTION gammln diff --git a/build/source/engine/spline_int.f90 b/build/source/engine/spline_int.f90 index 15199bd7d..ceab9c9cf 100755 --- a/build/source/engine/spline_int.f90 +++ b/build/source/engine/spline_int.f90 @@ -13,15 +13,15 @@ SUBROUTINE spline(x,y,yp1,ypn,y2,err,message) ! computes 2nd derivatives of the interpolating function at tabulated points IMPLICIT NONE ! dummy variables - real(summa_prec), DIMENSION(:), INTENT(IN) :: x,y - real(summa_prec), INTENT(IN) :: yp1,ypn - real(summa_prec), DIMENSION(:), INTENT(OUT) :: y2 + real(rk), DIMENSION(:), INTENT(IN) :: x,y + real(rk), INTENT(IN) :: yp1,ypn + real(rk), DIMENSION(:), INTENT(OUT) :: y2 integer(i4b),intent(out) :: err character(*),intent(out) :: message ! local variables character(len=128) :: cmessage INTEGER(I4B) :: n - real(summa_prec), DIMENSION(size(x)) :: a,b,c,r + real(rk), DIMENSION(size(x)) :: a,b,c,r ! initialize error control err=0; message="f-spline/" ! check that the size of the vectors match @@ -32,24 +32,24 @@ SUBROUTINE spline(x,y,yp1,ypn,y2,err,message) end if ! start procedure c(1:n-1)=x(2:n)-x(1:n-1) - r(1:n-1)=6.0_summa_prec*((y(2:n)-y(1:n-1))/c(1:n-1)) + r(1:n-1)=6.0_rk*((y(2:n)-y(1:n-1))/c(1:n-1)) r(2:n-1)=r(2:n-1)-r(1:n-2) a(2:n-1)=c(1:n-2) - b(2:n-1)=2.0_summa_prec*(c(2:n-1)+a(2:n-1)) + b(2:n-1)=2.0_rk*(c(2:n-1)+a(2:n-1)) b(1)=1.0 b(n)=1.0 - if (yp1 > 0.99e30_summa_prec) then + if (yp1 > 0.99e30_rk) then r(1)=0.0 c(1)=0.0 else - r(1)=(3.0_summa_prec/(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-yp1) + r(1)=(3.0_rk/(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-yp1) c(1)=0.5 end if - if (ypn > 0.99e30_summa_prec) then + if (ypn > 0.99e30_rk) then r(n)=0.0 a(n)=0.0 else - r(n)=(-3.0_summa_prec/(x(n)-x(n-1)))*((y(n)-y(n-1))/(x(n)-x(n-1))-ypn) + r(n)=(-3.0_rk/(x(n)-x(n-1)))*((y(n)-y(n-1))/(x(n)-x(n-1))-ypn) a(n)=0.5 end if call tridag(a(2:n),b(1:n),c(1:n-1),r(1:n),y2(1:n),err,cmessage) @@ -62,14 +62,14 @@ END SUBROUTINE spline SUBROUTINE splint(xa,ya,y2a,x,y,err,message) IMPLICIT NONE ! declare dummy variables - real(summa_prec), DIMENSION(:), INTENT(IN) :: xa,ya,y2a - real(summa_prec), INTENT(IN) :: x - real(summa_prec), INTENT(OUT) :: y + real(rk), DIMENSION(:), INTENT(IN) :: xa,ya,y2a + real(rk), INTENT(IN) :: x + real(rk), INTENT(OUT) :: y integer(i4b),intent(out) :: err character(*),intent(out) :: message ! declare local variables INTEGER(I4B) :: khi,klo,n - real(summa_prec) :: a,b,h + real(rk) :: a,b,h ! check size of input vectors if (size(xa)==size(ya) .and. size(ya)==size(y2a)) then n=size(xa) @@ -80,10 +80,10 @@ SUBROUTINE splint(xa,ya,y2a,x,y,err,message) klo=max(min(locate(xa,x),n-1),1) khi=klo+1 h=xa(khi)-xa(klo) - if (h == 0.0_summa_prec) then; err=20; message="f-splint/badXinput"; return; end if + if (h == 0.0_rk) then; err=20; message="f-splint/badXinput"; return; end if a=(xa(khi)-x)/h b=(x-xa(klo))/h - y=a*ya(klo)+b*ya(khi)+((a**3-a)*y2a(klo)+(b**3-b)*y2a(khi))*(h**2)/6.0_summa_prec + y=a*ya(klo)+b*ya(khi)+((a**3-a)*y2a(klo)+(b**3-b)*y2a(khi))*(h**2)/6.0_rk END SUBROUTINE splint ! ************************************************************* @@ -91,8 +91,8 @@ END SUBROUTINE splint ! ************************************************************* FUNCTION locate(xx,x) IMPLICIT NONE - real(summa_prec), DIMENSION(:), INTENT(IN) :: xx - real(summa_prec), INTENT(IN) :: x + real(rk), DIMENSION(:), INTENT(IN) :: xx + real(rk), INTENT(IN) :: x INTEGER(I4B) :: locate INTEGER(I4B) :: n,jl,jm,ju LOGICAL :: ascnd @@ -124,14 +124,14 @@ END FUNCTION locate SUBROUTINE tridag(a,b,c,r,u,err,message) IMPLICIT NONE ! dummy variables - real(summa_prec), DIMENSION(:), INTENT(IN) :: a,b,c,r - real(summa_prec), DIMENSION(:), INTENT(OUT) :: u + real(rk), DIMENSION(:), INTENT(IN) :: a,b,c,r + real(rk), DIMENSION(:), INTENT(OUT) :: u integer(i4b),intent(out) :: err character(*),intent(out) :: message ! local variables - real(summa_prec), DIMENSION(size(b)) :: gam + real(rk), DIMENSION(size(b)) :: gam INTEGER(I4B) :: n,j - real(summa_prec) :: bet + real(rk) :: bet ! initialize error control err=0; message="f-spline/OK" ! check that the size of the vectors match @@ -142,12 +142,12 @@ SUBROUTINE tridag(a,b,c,r,u,err,message) end if ! start procedure bet=b(1) - if (bet == 0.0_summa_prec) then; err=20; message="f-tridag/errorAtCodeStage-1"; return; end if + if (bet == 0.0_rk) then; err=20; message="f-tridag/errorAtCodeStage-1"; return; end if u(1)=r(1)/bet do j=2,n gam(j)=c(j-1)/bet bet=b(j)-a(j-1)*gam(j) - if (bet == 0.0_summa_prec) then; err=20; message="f-tridag/errorAtCodeStage-2"; return; end if + if (bet == 0.0_rk) then; err=20; message="f-tridag/errorAtCodeStage-2"; return; end if u(j)=(r(j)-a(j-1)*u(j-1))/bet end do do j=n-1,1,-1 diff --git a/build/source/engine/ssdNrgFlux.f90 b/build/source/engine/ssdNrgFlux.f90 index e0425ce8e..ecc4295f8 100755 --- a/build/source/engine/ssdNrgFlux.f90 +++ b/build/source/engine/ssdNrgFlux.f90 @@ -83,8 +83,8 @@ module ssdNrgFlux_module private public::ssdNrgFlux ! global parameters -real(summa_prec),parameter :: dx=1.e-10_summa_prec ! finite difference increment (K) -real(summa_prec),parameter :: valueMissing=-9999._summa_prec ! missing value parameter +real(rk),parameter :: dx=1.e-10_rk ! finite difference increment (K) +real(rk),parameter :: valueMissing=-9999._rk ! missing value parameter contains ! ************************************************************************************************ @@ -117,13 +117,13 @@ subroutine ssdNrgFlux(& ! input: model control logical(lgt),intent(in) :: scalarSolution ! flag to denote if implementing the scalar solution ! input: fluxes and derivatives at the upper boundary - real(summa_prec),intent(in) :: groundNetFlux ! net energy flux for the ground surface (W m-2) - real(summa_prec),intent(in) :: dGroundNetFlux_dGroundTemp ! derivative in net ground flux w.r.t. ground temperature (W m-2 K-1) + real(rk),intent(in) :: groundNetFlux ! net energy flux for the ground surface (W m-2) + real(rk),intent(in) :: dGroundNetFlux_dGroundTemp ! derivative in net ground flux w.r.t. ground temperature (W m-2 K-1) ! input: liquid water fluxes - real(summa_prec),intent(in) :: iLayerLiqFluxSnow(0:) ! intent(in): liquid flux at the interface of each snow layer (m s-1) - real(summa_prec),intent(in) :: iLayerLiqFluxSoil(0:) ! intent(in): liquid flux at the interface of each soil layer (m s-1) + real(rk),intent(in) :: iLayerLiqFluxSnow(0:) ! intent(in): liquid flux at the interface of each snow layer (m s-1) + real(rk),intent(in) :: iLayerLiqFluxSoil(0:) ! intent(in): liquid flux at the interface of each soil layer (m s-1) ! input: trial value of model state variables - real(summa_prec),intent(in) :: mLayerTempTrial(:) ! trial temperature of each snow/soil layer at the current iteration (K) + real(rk),intent(in) :: mLayerTempTrial(:) ! trial temperature of each snow/soil layer at the current iteration (K) ! input-output: data structures type(var_dlength),intent(in) :: mpar_data ! model parameters type(var_ilength),intent(in) :: indx_data ! state vector geometry @@ -131,9 +131,9 @@ subroutine ssdNrgFlux(& type(var_dlength),intent(in) :: diag_data ! diagnostic variables for a local HRU type(var_dlength),intent(inout) :: flux_data ! model fluxes for a local HRU ! output: fluxes and derivatives at all layer interfaces - real(summa_prec),intent(out) :: iLayerNrgFlux(0:) ! energy flux at the layer interfaces (W m-2) - real(summa_prec),intent(out) :: dFlux_dTempAbove(0:) ! derivatives in the flux w.r.t. temperature in the layer above (J m-2 s-1 K-1) - real(summa_prec),intent(out) :: dFlux_dTempBelow(0:) ! derivatives in the flux w.r.t. temperature in the layer below (J m-2 s-1 K-1) + real(rk),intent(out) :: iLayerNrgFlux(0:) ! energy flux at the layer interfaces (W m-2) + real(rk),intent(out) :: dFlux_dTempAbove(0:) ! derivatives in the flux w.r.t. temperature in the layer above (J m-2 s-1 K-1) + real(rk),intent(out) :: dFlux_dTempBelow(0:) ! derivatives in the flux w.r.t. temperature in the layer below (J m-2 s-1 K-1) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message @@ -143,9 +143,9 @@ subroutine ssdNrgFlux(& integer(i4b) :: ixLayerDesired(1) ! layer desired (scalar solution) integer(i4b) :: ixTop ! top layer in subroutine call integer(i4b) :: ixBot ! bottom layer in subroutine call - real(summa_prec) :: qFlux ! liquid flux at layer interfaces (m s-1) - real(summa_prec) :: dz ! height difference (m) - real(summa_prec) :: flux0,flux1,flux2 ! fluxes used to calculate derivatives (W m-2) + real(rk) :: qFlux ! liquid flux at layer interfaces (m s-1) + real(rk) :: dz ! height difference (m) + real(rk) :: flux0,flux1,flux2 ! fluxes used to calculate derivatives (W m-2) ! ------------------------------------------------------------------------------------------------------------------------------------------------------ ! make association of local variables with information in the data structures associate(& @@ -194,8 +194,8 @@ subroutine ssdNrgFlux(& if(iLayer==nLayers)then ! flux depends on the type of lower boundary condition select case(ix_bcLowrTdyn) ! (identify the lower boundary condition for thermodynamics - case(prescribedTemp); iLayerConductiveFlux(nLayers) = -iLayerThermalC(iLayer)*(lowerBoundTemp - mLayerTempTrial(iLayer))/(mLayerDepth(iLayer)*0.5_summa_prec) - case(zeroFlux); iLayerConductiveFlux(nLayers) = 0._summa_prec + case(prescribedTemp); iLayerConductiveFlux(nLayers) = -iLayerThermalC(iLayer)*(lowerBoundTemp - mLayerTempTrial(iLayer))/(mLayerDepth(iLayer)*0.5_rk) + case(zeroFlux); iLayerConductiveFlux(nLayers) = 0._rk case default; err=20; message=trim(message)//'unable to identify lower boundary condition for thermodynamics'; return end select ! (identifying the lower boundary condition for thermodynamics) @@ -257,7 +257,7 @@ subroutine ssdNrgFlux(& ! * prescribed temperature at the lower boundary case(prescribedTemp) - dz = mLayerDepth(iLayer)*0.5_summa_prec + dz = mLayerDepth(iLayer)*0.5_rk if(ix_fDerivMeth==analytical)then ! ** analytical derivatives dFlux_dTempAbove(iLayer) = iLayerThermalC(iLayer)/dz else ! ** numerical derivatives @@ -268,7 +268,7 @@ subroutine ssdNrgFlux(& ! * zero flux at the lower boundary case(zeroFlux) - dFlux_dTempAbove(iLayer) = 0._summa_prec + dFlux_dTempAbove(iLayer) = 0._rk case default; err=20; message=trim(message)//'unable to identify lower boundary condition for thermodynamics'; return diff --git a/build/source/engine/stomResist.f90 b/build/source/engine/stomResist.f90 index ad9a854df..70897fd1f 100755 --- a/build/source/engine/stomResist.f90 +++ b/build/source/engine/stomResist.f90 @@ -94,11 +94,11 @@ module stomResist_module integer(i4b),parameter :: iLoc = 1 ! i-location integer(i4b),parameter :: jLoc = 1 ! j-location ! conversion factors -real(summa_prec),parameter :: joule2umolConv=4.6_summa_prec ! conversion factor from joules to umol photons (umol J-1) +real(rk),parameter :: joule2umolConv=4.6_rk ! conversion factor from joules to umol photons (umol J-1) ! algorithmic parameters -real(summa_prec),parameter :: missingValue=-9999._summa_prec ! missing value, used when diagnostic or state variables are undefined -real(summa_prec),parameter :: mpe=1.e-6_summa_prec ! prevents overflow error if division by zero -real(summa_prec),parameter :: dx=1.e-6_summa_prec ! finite difference increment +real(rk),parameter :: missingValue=-9999._rk ! missing value, used when diagnostic or state variables are undefined +real(rk),parameter :: mpe=1.e-6_rk ! prevents overflow error if division by zero +real(rk),parameter :: dx=1.e-6_rk ! finite difference increment contains @@ -127,9 +127,9 @@ subroutine stomResist(& USE conv_funcs_module,only:satVapPress ! function to compute the saturated vapor pressure (Pa) ! ------------------------------------------------------------------------------------------------------------------------------------------------------ ! input: state and diagnostic variables - real(summa_prec),intent(in) :: scalarVegetationTemp ! vegetation temperature (K) - real(summa_prec),intent(in) :: scalarSatVP_VegTemp ! saturation vapor pressure at vegetation temperature (Pa) - real(summa_prec),intent(in) :: scalarVP_CanopyAir ! canopy air vapor pressure (Pa) + real(rk),intent(in) :: scalarVegetationTemp ! vegetation temperature (K) + real(rk),intent(in) :: scalarSatVP_VegTemp ! saturation vapor pressure at vegetation temperature (Pa) + real(rk),intent(in) :: scalarVP_CanopyAir ! canopy air vapor pressure (Pa) ! input: data structures type(var_i),intent(in) :: type_data ! type of vegetation and soil type(var_d),intent(in) :: forc_data ! model forcing data @@ -147,10 +147,10 @@ subroutine stomResist(& integer(i4b),parameter :: ixSunlit=1 ! named variable for sunlit leaves integer(i4b),parameter :: ixShaded=2 ! named variable for shaded leaves integer(i4b) :: iSunShade ! index defining sunlit or shaded leaves - real(summa_prec) :: absorbedPAR ! absorbed PAR (W m-2) - real(summa_prec) :: scalarStomResist ! stomatal resistance (s m-1) - real(summa_prec) :: scalarPhotosynthesis ! photosynthesis (umol CO2 m-2 s-1) - real(summa_prec) :: ci ! intercellular co2 partial pressure (Pa) + real(rk) :: absorbedPAR ! absorbed PAR (W m-2) + real(rk) :: scalarStomResist ! stomatal resistance (s m-1) + real(rk) :: scalarPhotosynthesis ! photosynthesis (umol CO2 m-2 s-1) + real(rk) :: ci ! intercellular co2 partial pressure (Pa) ! ------------------------------------------------------------------------------------------------------------------------------------------------------ ! associate variables in the data structure @@ -356,10 +356,10 @@ subroutine stomResist_flex(& ! ------------------------------------------------------------------------------------------------------------------------------------------------------ ! ------------------------------------------------------------------------------------------------------------------------------------------------------ ! input: state and diagnostic variables - real(summa_prec),intent(in) :: scalarVegetationTemp ! vegetation temperature (K) - real(summa_prec),intent(in) :: scalarSatVP_VegTemp ! saturation vapor pressure at vegetation temperature (Pa) - real(summa_prec),intent(in) :: scalarVP_CanopyAir ! canopy air vapor pressure (Pa) - real(summa_prec),intent(in) :: absorbedPAR ! absorbed PAR (W m-2) + real(rk),intent(in) :: scalarVegetationTemp ! vegetation temperature (K) + real(rk),intent(in) :: scalarSatVP_VegTemp ! saturation vapor pressure at vegetation temperature (Pa) + real(rk),intent(in) :: scalarVP_CanopyAir ! canopy air vapor pressure (Pa) + real(rk),intent(in) :: absorbedPAR ! absorbed PAR (W m-2) ! input: data structures type(var_d),intent(in) :: forc_data ! model forcing data type(var_dlength),intent(in) :: mpar_data ! model parameters @@ -367,69 +367,69 @@ subroutine stomResist_flex(& type(var_dlength),intent(in) :: flux_data ! model fluxes for a local HRU type(model_options),intent(in) :: model_decisions(:) ! model decisions ! output: stomatal resistance and photosynthesis - real(summa_prec),intent(inout) :: ci ! intercellular co2 partial pressure (Pa) - real(summa_prec),intent(out) :: scalarStomResist ! stomatal resistance (s m-1) - real(summa_prec),intent(out) :: scalarPhotosynthesis ! photosynthesis (umol CO2 m-2 s-1) + real(rk),intent(inout) :: ci ! intercellular co2 partial pressure (Pa) + real(rk),intent(out) :: scalarStomResist ! stomatal resistance (s m-1) + real(rk),intent(out) :: scalarPhotosynthesis ! photosynthesis (umol CO2 m-2 s-1) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! ------------------------------------------------------------------------------------------------------------------------------------------------------ ! general local variables logical(lgt),parameter :: testDerivs=.false. ! flag to test the derivatives - real(summa_prec) :: unitConv ! unit conversion factor (mol m-3, convert m s-1 --> mol H20 m-2 s-1) - real(summa_prec) :: rlb ! leaf boundary layer rersistance (umol-1 m2 s) - real(summa_prec) :: x0,x1,x2 ! temporary variables - real(summa_prec) :: co2compPt ! co2 compensation point (Pa) - real(summa_prec) :: fHum ! humidity function, fraction [0,1] + real(rk) :: unitConv ! unit conversion factor (mol m-3, convert m s-1 --> mol H20 m-2 s-1) + real(rk) :: rlb ! leaf boundary layer rersistance (umol-1 m2 s) + real(rk) :: x0,x1,x2 ! temporary variables + real(rk) :: co2compPt ! co2 compensation point (Pa) + real(rk) :: fHum ! humidity function, fraction [0,1] ! ------------------------------------------------------------------------------------------------------------------------------------------------------ ! fixed parameters integer(i4b),parameter :: maxiter=20 ! maximum number of iterations integer(i4b),parameter :: maxiter_noahMP=3 ! maximum number of iterations for Noah-MP - real(summa_prec),parameter :: convToler=0.0001_summa_prec ! convergence tolerance (Pa) - real(summa_prec),parameter :: umol_per_mol=1.e+6_summa_prec ! factor to relate umol to mol - real(summa_prec),parameter :: o2scaleFactor=0.105_summa_prec ! scaling factor used to compute co2 compesation point (0.21/2) - real(summa_prec),parameter :: h2o_co2__leafbl=1.37_summa_prec ! factor to represent the different diffusivities of h2o and co2 in the leaf boundary layer (-) - real(summa_prec),parameter :: h2o_co2__stomPores=1.65_summa_prec ! factor to represent the different diffusivities of h2o and co2 in the stomatal pores (-) - real(summa_prec),parameter :: Tref=298.16_summa_prec ! reference temperature (25 deg C) - real(summa_prec),parameter :: Tscale=10._summa_prec ! scaling factor in q10 function (K) - real(summa_prec),parameter :: c_ps2=0.7_summa_prec ! curvature factor for electron transport (-) - real(summa_prec),parameter :: fnf=0.6666666667_summa_prec ! foliage nitrogen factor (-) + real(rk),parameter :: convToler=0.0001_rk ! convergence tolerance (Pa) + real(rk),parameter :: umol_per_mol=1.e+6_rk ! factor to relate umol to mol + real(rk),parameter :: o2scaleFactor=0.105_rk ! scaling factor used to compute co2 compesation point (0.21/2) + real(rk),parameter :: h2o_co2__leafbl=1.37_rk ! factor to represent the different diffusivities of h2o and co2 in the leaf boundary layer (-) + real(rk),parameter :: h2o_co2__stomPores=1.65_rk ! factor to represent the different diffusivities of h2o and co2 in the stomatal pores (-) + real(rk),parameter :: Tref=298.16_rk ! reference temperature (25 deg C) + real(rk),parameter :: Tscale=10._rk ! scaling factor in q10 function (K) + real(rk),parameter :: c_ps2=0.7_rk ! curvature factor for electron transport (-) + real(rk),parameter :: fnf=0.6666666667_rk ! foliage nitrogen factor (-) ! ------------------------------------------------------------------------------------------------------------------------------------------------------ ! photosynthesis - real(summa_prec) :: Kc,Ko ! Michaelis-Menten constants for co2 and o2 (Pa) - real(summa_prec) :: vcmax25 ! maximum Rubisco carboxylation rate at 25 deg C (umol m-2 s-1) - real(summa_prec) :: jmax25 ! maximum electron transport rate at 25 deg C (umol m-2 s-1) - real(summa_prec) :: vcmax ! maximum Rubisco carboxylation rate (umol m-2 s-1) - real(summa_prec) :: jmax ! maximum electron transport rate (umol m-2 s-1) - real(summa_prec) :: aQuad ! the quadratic coefficient in the quadratic equation - real(summa_prec) :: bQuad ! the linear coefficient in the quadratic equation - real(summa_prec) :: cQuad ! the constant in the quadratic equation - real(summa_prec) :: bSign ! sign of the linear coeffcient - real(summa_prec) :: xTemp ! temporary variable in the quadratic equation - real(summa_prec) :: qQuad ! the "q" term in the quadratic equation - real(summa_prec) :: root1,root2 ! roots of the quadratic function - real(summa_prec) :: Js ! scaled electron transport rate (umol co2 m-2 s-1) - real(summa_prec) :: I_ps2 ! PAR absorbed by PS2 (umol photon m-2 s-1) - real(summa_prec) :: awb ! Michaelis-Menten control (Pa) - real(summa_prec) :: cp2 ! additional controls in light-limited assimilation (Pa) - real(summa_prec) :: psn ! leaf gross photosynthesis rate (umol co2 m-2 s-1) - real(summa_prec) :: dA_dc ! derivative in photosynthesis w.r.t. intercellular co2 concentration + real(rk) :: Kc,Ko ! Michaelis-Menten constants for co2 and o2 (Pa) + real(rk) :: vcmax25 ! maximum Rubisco carboxylation rate at 25 deg C (umol m-2 s-1) + real(rk) :: jmax25 ! maximum electron transport rate at 25 deg C (umol m-2 s-1) + real(rk) :: vcmax ! maximum Rubisco carboxylation rate (umol m-2 s-1) + real(rk) :: jmax ! maximum electron transport rate (umol m-2 s-1) + real(rk) :: aQuad ! the quadratic coefficient in the quadratic equation + real(rk) :: bQuad ! the linear coefficient in the quadratic equation + real(rk) :: cQuad ! the constant in the quadratic equation + real(rk) :: bSign ! sign of the linear coeffcient + real(rk) :: xTemp ! temporary variable in the quadratic equation + real(rk) :: qQuad ! the "q" term in the quadratic equation + real(rk) :: root1,root2 ! roots of the quadratic function + real(rk) :: Js ! scaled electron transport rate (umol co2 m-2 s-1) + real(rk) :: I_ps2 ! PAR absorbed by PS2 (umol photon m-2 s-1) + real(rk) :: awb ! Michaelis-Menten control (Pa) + real(rk) :: cp2 ! additional controls in light-limited assimilation (Pa) + real(rk) :: psn ! leaf gross photosynthesis rate (umol co2 m-2 s-1) + real(rk) :: dA_dc ! derivative in photosynthesis w.r.t. intercellular co2 concentration ! ------------------------------------------------------------------------------------------------------------------------------------------------------ ! stomatal resistance - real(summa_prec) :: gMin ! scaled minimum conductance (umol m-2 s-1) - real(summa_prec) :: cs ! co2 partial pressure at leaf surface (Pa) - real(summa_prec) :: csx ! control of co2 partial pressure at leaf surface on stomatal conductance (Pa) - real(summa_prec) :: g0 ! stomatal conductance in the absence of humidity controls (umol m-2 s-1) - real(summa_prec) :: ci_old ! intercellular co2 partial pressure (Pa) - real(summa_prec) :: rs ! stomatal resistance (umol-1 m2 s) - real(summa_prec) :: dg0_dc ! derivative in g0 w.r.t intercellular co2 concentration (umol m-2 s-1 Pa-1) - real(summa_prec) :: drs_dc ! derivative in stomatal resistance w.r.t. intercellular co2 concentration - real(summa_prec) :: dci_dc ! final derivative (-) + real(rk) :: gMin ! scaled minimum conductance (umol m-2 s-1) + real(rk) :: cs ! co2 partial pressure at leaf surface (Pa) + real(rk) :: csx ! control of co2 partial pressure at leaf surface on stomatal conductance (Pa) + real(rk) :: g0 ! stomatal conductance in the absence of humidity controls (umol m-2 s-1) + real(rk) :: ci_old ! intercellular co2 partial pressure (Pa) + real(rk) :: rs ! stomatal resistance (umol-1 m2 s) + real(rk) :: dg0_dc ! derivative in g0 w.r.t intercellular co2 concentration (umol m-2 s-1 Pa-1) + real(rk) :: drs_dc ! derivative in stomatal resistance w.r.t. intercellular co2 concentration + real(rk) :: dci_dc ! final derivative (-) ! ------------------------------------------------------------------------------------------------------------------------------------------------------ ! iterative solution - real(summa_prec) :: func1,func2 ! functions for numerical derivative calculation - real(summa_prec) :: cMin,cMax ! solution brackets - real(summa_prec) :: xInc ! iteration increment (Pa) + real(rk) :: func1,func2 ! functions for numerical derivative calculation + real(rk) :: cMin,cMax ! solution brackets + real(rk) :: xInc ! iteration increment (Pa) integer(i4b) :: iter ! iteration index ! ------------------------------------------------------------------------------------------------------------------------------------------------------ ! associate variables in the data structure @@ -498,8 +498,8 @@ subroutine stomResist_flex(& ! check there is light available for photosynthesis if(absorbedPAR < tiny(absorbedPAR) .or. scalarGrowingSeasonIndex < tiny(absorbedPAR))then scalarStomResist = unitConv*umol_per_mol/(scalarTranspireLim*minStomatalConductance) - scalarPhotosynthesis = 0._summa_prec - ci = 0._summa_prec + scalarPhotosynthesis = 0._rk + ci = 0._rk return end if @@ -572,27 +572,27 @@ subroutine stomResist_flex(& ! linear function of qmax, as used in Cable [Wang et al., Ag Forest Met 1998, eq D5] case(linearJmax) x0 = quantamYield*joule2umolConv*absorbedPAR - x1 = x0*jmax / (x0 + 2.1_summa_prec*jmax) - Js = x1/4._summa_prec ! scaled electron transport + x1 = x0*jmax / (x0 + 2.1_rk*jmax) + Js = x1/4._rk ! scaled electron transport ! quadraric function of jmax, as used in CLM5 (Bonan et al., JGR 2011, Table B2) case(quadraticJmax) ! PAR absorbed by PS2 (umol photon m-2 s-1) - I_ps2 = 0.5_summa_prec*(1._summa_prec - fractionJ) * joule2umolConv*absorbedPAR ! Farquar (1980), eq 8: PAR absorbed by PS2 (umol photon m-2 s-1) + I_ps2 = 0.5_rk*(1._rk - fractionJ) * joule2umolConv*absorbedPAR ! Farquar (1980), eq 8: PAR absorbed by PS2 (umol photon m-2 s-1) ! define coefficients in the quadratic equation aQuad = c_ps2 ! quadratic coefficient = cuurvature factor for electron transport bQuad = -(I_ps2 + jmax) ! linear coefficient cQuad = I_ps2 * jmax ! free term ! compute the q term (NOTE: bQuad is always positive) bSign = abs(bQuad)/bQuad - xTemp = bQuad*bQuad - 4._summa_prec *aQuad*cQuad - qQuad = -0.5_summa_prec * (bQuad + bSign*sqrt(xTemp)) + xTemp = bQuad*bQuad - 4._rk *aQuad*cQuad + qQuad = -0.5_rk * (bQuad + bSign*sqrt(xTemp)) ! compute roots root1 = qQuad / aQuad root2 = cQuad / qQuad ! select minimum root, required to ensure J=0 when par=0 ! NOTE: Wittig et al. select the first root, which is the max in all cases I tried - Js = min(root1,root2) / 4._summa_prec ! scaled J + Js = min(root1,root2) / 4._rk ! scaled J ! check found an appropriate option case default; err=20; message=trim(message)//'unable to find option for electron transport controls on stomatal conductance'; return @@ -605,7 +605,7 @@ subroutine stomResist_flex(& ! define the humidity function select case(ix_bbHumdFunc) - case(humidLeafSurface); fHum = min( max(0.25_summa_prec, scalarVP_CanopyAir/scalarSatVP_VegTemp), 1._summa_prec) + case(humidLeafSurface); fHum = min( max(0.25_rk, scalarVP_CanopyAir/scalarSatVP_VegTemp), 1._rk) case(scaledHyperbolic); fHum = (scalarSatVP_VegTemp - scalarVP_CanopyAir)/vpScaleFactor case default; err=20; message=trim(message)//'unable to identify humidity control on stomatal conductance'; return end select @@ -614,23 +614,23 @@ subroutine stomResist_flex(& co2compPt = (Kc/Ko)*scalarO2air*o2scaleFactor ! compute the Michaelis-Menten controls (Pa) - awb = Kc*(1._summa_prec + scalarO2air/Ko) + awb = Kc*(1._rk + scalarO2air/Ko) ! compute the additional controls in light-limited assimilation - cp2 = co2compPt*2._summa_prec + cp2 = co2compPt*2._rk ! define trial value of intercellular co2 (Pa) ! NOTE: only initialize if less than the co2 compensation point; otherwise, initialize with previous value if(ix_bbNumerics==newtonRaphson)then - if(ci < co2compPt) ci = 0.7_summa_prec*scalarCO2air + if(ci < co2compPt) ci = 0.7_rk*scalarCO2air else - ci = 0.7_summa_prec*scalarCO2air ! always initialize if not NR + ci = 0.7_rk*scalarCO2air ! always initialize if not NR end if !write(*,'(a,1x,10(f20.10,1x))') 'Kc25, Kc_qFac, Ko25, Ko_qFac = ', Kc25, Kc_qFac, Ko25, Ko_qFac !write(*,'(a,1x,10(f20.10,1x))') 'scalarCO2air, ci, co2compPt, Kc, Ko = ', scalarCO2air, ci, co2compPt, Kc, Ko ! initialize brackets for the solution - cMin = 0._summa_prec + cMin = 0._rk cMax = scalarCO2air ! ********************************************************************************************************************************* @@ -670,14 +670,14 @@ subroutine stomResist_flex(& ! compute conductance in the absence of humidity g0 = cond2photo_slope*airpres*psn/csx - dg0_dc = cond2photo_slope*airpres*dA_dc*(x1*psn/cs + 1._summa_prec)/csx + dg0_dc = cond2photo_slope*airpres*dA_dc*(x1*psn/cs + 1._rk)/csx ! use quadratic function to compute stomatal resistance call quadResist(.true.,ix_bbHumdFunc,rlb,fHum,gMin,g0,dg0_dc,rs,drs_dc) ! compute intercellular co2 partial pressues (Pa) x2 = h2o_co2__stomPores * airpres ! Pa - ci = max(cs - x2*psn*rs, 0._summa_prec) ! Pa + ci = max(cs - x2*psn*rs, 0._rk) ! Pa ! print progress !if(ix_bbNumerics==NoahMPsolution)then @@ -689,7 +689,7 @@ subroutine stomResist_flex(& if(ci > tiny(ci))then dci_dc = -x1*dA_dc - x2*(psn*drs_dc + rs*dA_dc) else - dci_dc = 0._summa_prec + dci_dc = 0._rk end if ! test derivatives @@ -721,14 +721,14 @@ subroutine stomResist_flex(& end if ! compute iteration increment (Pa) - xInc = (ci - ci_old)/(1._summa_prec - dci_dc) + xInc = (ci - ci_old)/(1._rk - dci_dc) ! update - ci = max(ci_old + xInc, 0._summa_prec) + ci = max(ci_old + xInc, 0._rk) ! ensure that we stay within brackets if(ci > cMax .or. ci < cMin)then - ci = 0.5_summa_prec * (cMin + cMax) + ci = 0.5_rk * (cMin + cMax) end if ! print progress @@ -758,11 +758,11 @@ subroutine stomResist_flex(& ! internal function used to test derivatives function testFunc(ci, cond2photo_slope, airpres, scalarCO2air, ix_bbHumdFunc, ix_bbCO2point, ix_bbAssimFnc) - real(summa_prec),intent(in) :: ci, cond2photo_slope, airpres, scalarCO2air + real(rk),intent(in) :: ci, cond2photo_slope, airpres, scalarCO2air integer(i4b),intent(in) :: ix_bbHumdFunc, ix_bbCO2point, ix_bbAssimFnc - real(summa_prec) :: testFunc - real(summa_prec),parameter :: unUsedInput=0._summa_prec - real(summa_prec) :: unUsedOutput + real(rk) :: testFunc + real(rk),parameter :: unUsedInput=0._rk + real(rk) :: unUsedOutput ! compute gross photosynthesis [follow Farquar (Planta, 1980), as implemented in CLM4 and Noah-MP] call photosynthesis(.false., ix_bbAssimFnc, ci, co2compPt, awb, cp2, vcmax, Js, psn, unUsedOutput) @@ -786,7 +786,7 @@ function testFunc(ci, cond2photo_slope, airpres, scalarCO2air, ix_bbHumdFunc, ix ! compute intercellular co2 partial pressues (Pa) x2 = h2o_co2__stomPores * airpres ! Pa - testFunc = max(cs - x2*psn*rs, 0._summa_prec) ! Pa + testFunc = max(cs - x2*psn*rs, 0._rk) ! Pa end function testFunc @@ -800,37 +800,37 @@ subroutine photosynthesis(desireDeriv, ix_bbAssimFnc, ci, co2compPt, awb, cp2, v ! dummy variables logical(lgt),intent(in) :: desireDeriv ! .true. if the derivative is desired integer(i4b),intent(in) :: ix_bbAssimFnc ! model option for the function used for co2 assimilation (min func, or colimtation) - real(summa_prec),intent(in) :: ci ! intercellular co2 concentration (Pa) - real(summa_prec),intent(in) :: co2compPt ! co2 compensation point (Pa) - real(summa_prec),intent(in) :: awb ! Michaelis-Menten control (Pa) - real(summa_prec),intent(in) :: cp2 ! additional controls in light-limited assimilation (Pa) - real(summa_prec),intent(in) :: vcmax ! maximum Rubisco carboxylation rate (umol co2 m-2 s-1) - real(summa_prec),intent(in) :: Js ! scaled electron transport rate (umol co2 m-2 s-1) - real(summa_prec),intent(out) :: psn ! leaf gross photosynthesis rate (umol co2 m-2 s-1) - real(summa_prec),intent(out) :: dA_dc ! derivative in photosynthesis w.r.t. intercellular co2 concentration (umol co2 m-2 s-1 Pa-1) + real(rk),intent(in) :: ci ! intercellular co2 concentration (Pa) + real(rk),intent(in) :: co2compPt ! co2 compensation point (Pa) + real(rk),intent(in) :: awb ! Michaelis-Menten control (Pa) + real(rk),intent(in) :: cp2 ! additional controls in light-limited assimilation (Pa) + real(rk),intent(in) :: vcmax ! maximum Rubisco carboxylation rate (umol co2 m-2 s-1) + real(rk),intent(in) :: Js ! scaled electron transport rate (umol co2 m-2 s-1) + real(rk),intent(out) :: psn ! leaf gross photosynthesis rate (umol co2 m-2 s-1) + real(rk),intent(out) :: dA_dc ! derivative in photosynthesis w.r.t. intercellular co2 concentration (umol co2 m-2 s-1 Pa-1) ! local variables integer(i4b),parameter :: nFactors=3 ! number of limiting factors for assimilation (light, Rubisco, and export) integer(i4b),parameter :: ixRubi=1 ! named variable for Rubisco-limited assimilation integer(i4b),parameter :: ixLight=2 ! named variable for light-limited assimilation integer(i4b),parameter :: ixExport=3 ! named variable for export-limited assimilation integer(i4b) :: ixLimitVec(1),ixLimit ! index of factor limiting assimilation - real(summa_prec) :: xFac(nFactors) ! temporary variable used to compute assimilation rate - real(summa_prec) :: xPSN(nFactors) ! assimilation rate for different factors (light, Rubisco, and export) - real(summa_prec) :: ciDiff ! difference between intercellular co2 and the co2 compensation point - real(summa_prec) :: ciDer ! factor to account for constainted intercellular co2 in calculating derivatives - real(summa_prec) :: x0 ! temporary variable - real(summa_prec) :: xsPSN ! intermediate smoothed photosynthesis - real(summa_prec) :: dAc_dc,dAj_dc,dAe_dc,dAi_dc ! derivatives in assimilation w.r.t. intercellular co2 concentration - real(summa_prec),parameter :: theta_cj=0.98_summa_prec ! coupling coefficient (see Sellers et al., 1996 [eq C6]; Bonan et al., 2011 [Table B1]) - real(summa_prec),parameter :: theta_ie=0.95_summa_prec ! coupling coefficient (see Sellers et al., 1996 [eq C6]; Bonan et al., 2011 [Table B1]) + real(rk) :: xFac(nFactors) ! temporary variable used to compute assimilation rate + real(rk) :: xPSN(nFactors) ! assimilation rate for different factors (light, Rubisco, and export) + real(rk) :: ciDiff ! difference between intercellular co2 and the co2 compensation point + real(rk) :: ciDer ! factor to account for constainted intercellular co2 in calculating derivatives + real(rk) :: x0 ! temporary variable + real(rk) :: xsPSN ! intermediate smoothed photosynthesis + real(rk) :: dAc_dc,dAj_dc,dAe_dc,dAi_dc ! derivatives in assimilation w.r.t. intercellular co2 concentration + real(rk),parameter :: theta_cj=0.98_rk ! coupling coefficient (see Sellers et al., 1996 [eq C6]; Bonan et al., 2011 [Table B1]) + real(rk),parameter :: theta_ie=0.95_rk ! coupling coefficient (see Sellers et al., 1996 [eq C6]; Bonan et al., 2011 [Table B1]) ! ------------------------------------------------------------ ! this method follows Farquar (Planta, 1980), as implemented in CLM4 and Noah-MP ! compute the difference between intercellular co2 concentraion and the compensation point - ciDiff = max(0._summa_prec, ci - co2compPt) + ciDiff = max(0._rk, ci - co2compPt) ! impose constraints (NOTE: derivative is zero if constraints are imposed) - if(ci < co2compPt)then; ciDer = 0._summa_prec; else; ciDer = 1._summa_prec; end if + if(ci < co2compPt)then; ciDer = 0._rk; else; ciDer = 1._rk; end if ! compute Rubisco-limited assimilation xFac(ixRubi) = vcmax/(ci + awb) ! umol co2 m-2 s-1 Pa-1 @@ -841,7 +841,7 @@ subroutine photosynthesis(desireDeriv, ix_bbAssimFnc, ci, co2compPt, awb, cp2, v xPSN(ixLight) = xFac(ixLight)*ciDiff ! umol co2 m-2 s-1 ! compute export limited assimilation - xFac(ixExport) = 0.5_summa_prec + xFac(ixExport) = 0.5_rk xPSN(ixExport) = xFac(ixExport)*vcmax ! umol co2 m-2 s-1 ! print progress @@ -868,12 +868,12 @@ subroutine photosynthesis(desireDeriv, ix_bbAssimFnc, ci, co2compPt, awb, cp2, v select case(ixLimit) case(ixRubi); dA_dc = x0*ciDer - ciDiff*x0*x0/vcmax ! Rubisco-limited assimilation case(ixLight); dA_dc = x0*ciDer - ciDiff*x0*x0/Js ! light-limited assimilation - case(ixExport); dA_dc = 0._summa_prec ! export-limited assimilation + case(ixExport); dA_dc = 0._rk ! export-limited assimilation end select ! derivatives are not desired else - dA_dc = 0._summa_prec + dA_dc = 0._rk end if ! colimitation (Collatz et al., 1991; Sellers et al., 1996; Bonan et al., 2011) @@ -883,19 +883,19 @@ subroutine photosynthesis(desireDeriv, ix_bbAssimFnc, ci, co2compPt, awb, cp2, v if(desireDeriv)then dAc_dc = xFac(ixRubi)*ciDer - ciDiff*xFac(ixRubi)*xFac(ixRubi)/vcmax dAj_dc = xFac(ixLight)*ciDer - ciDiff*xFac(ixLight)*xFac(ixLight)/Js - dAe_dc = 0._summa_prec + dAe_dc = 0._rk else - dAc_dc = 0._summa_prec - dAj_dc = 0._summa_prec - dAe_dc = 0._summa_prec + dAc_dc = 0._rk + dAj_dc = 0._rk + dAe_dc = 0._rk end if ! smooth Rubisco-limitation and light limitation if(ciDiff > tiny(ciDiff))then call quadSmooth(desireDeriv, xPSN(ixRubi), xPSN(ixLight), theta_cj, dAc_dc, dAj_dc, xsPSN, dAi_dc) else - xsPSN = 0._summa_prec - dAi_dc = 0._summa_prec + xsPSN = 0._rk + dAi_dc = 0._rk end if ! smooth intermediate-limitation and export limitation @@ -942,18 +942,18 @@ subroutine quadResist(desireDeriv,ix_bbHumdFunc,rlb,fHum,gMin,g0,dg0_dc,rs,drs_d ! dummy variables logical(lgt),intent(in) :: desireDeriv ! flag to denote if the derivative is desired integer(i4b),intent(in) :: ix_bbHumdFunc ! option for humidity control on stomatal resistance - real(summa_prec),intent(in) :: rlb ! leaf boundary layer resistance (umol-1 m2 s) - real(summa_prec),intent(in) :: fHum ! scaled humidity function (-) - real(summa_prec),intent(in) :: gMin ! scaled minimum stomatal consuctance (umol m-2 s-1) - real(summa_prec),intent(in) :: g0 ! stomatal conductance in the absence of humidity controls (umol m-2 s-1) - real(summa_prec),intent(in) :: dg0_dc ! derivative in g0 w.r.t intercellular co2 concentration (umol m-2 s-1 Pa-1) - real(summa_prec),intent(out) :: rs ! stomatal resistance ((umol-1 m2 s) - real(summa_prec),intent(out) :: drs_dc ! derivaive in rs w.r.t intercellular co2 concentration (umol-1 m2 s Pa-1) + real(rk),intent(in) :: rlb ! leaf boundary layer resistance (umol-1 m2 s) + real(rk),intent(in) :: fHum ! scaled humidity function (-) + real(rk),intent(in) :: gMin ! scaled minimum stomatal consuctance (umol m-2 s-1) + real(rk),intent(in) :: g0 ! stomatal conductance in the absence of humidity controls (umol m-2 s-1) + real(rk),intent(in) :: dg0_dc ! derivative in g0 w.r.t intercellular co2 concentration (umol m-2 s-1 Pa-1) + real(rk),intent(out) :: rs ! stomatal resistance ((umol-1 m2 s) + real(rk),intent(out) :: drs_dc ! derivaive in rs w.r.t intercellular co2 concentration (umol-1 m2 s Pa-1) ! local variables - real(summa_prec) :: aQuad,bQuad,cQuad ! coefficients in the quadratic function - real(summa_prec) :: bSign,xTemp,qQuad ! q term in the quadratic - real(summa_prec) :: root1,root2 ! roots of the quadratic - real(summa_prec) :: dxT_dc,dqq_dc ! derivatives in the q term + real(rk) :: aQuad,bQuad,cQuad ! coefficients in the quadratic function + real(rk) :: bSign,xTemp,qQuad ! q term in the quadratic + real(rk) :: root1,root2 ! roots of the quadratic + real(rk) :: dxT_dc,dqq_dc ! derivatives in the q term ! define terms for the quadratic function select case(ix_bbHumdFunc) @@ -961,21 +961,21 @@ subroutine quadResist(desireDeriv,ix_bbHumdFunc,rlb,fHum,gMin,g0,dg0_dc,rs,drs_d ! original Ball-Berry case(humidLeafSurface) aQuad = g0*fHum + gMin - bQuad = (g0 + gMin)*rlb - 1._summa_prec + bQuad = (g0 + gMin)*rlb - 1._rk cQuad = -rlb ! Leuning 1995 case(scaledHyperbolic) - aQuad = g0 + gMin*(1._summa_prec + fHum) - bQuad = (g0 + gMin)*rlb - fHum - 1._summa_prec + aQuad = g0 + gMin*(1._rk + fHum) + bQuad = (g0 + gMin)*rlb - fHum - 1._rk cQuad = -rlb end select ! compute the q term in the quadratic bSign = abs(bQuad)/bQuad - xTemp = bQuad*bQuad - 4._summa_prec *aQuad*cQuad - qquad = -0.5_summa_prec * (bQuad + bSign*sqrt(xTemp)) + xTemp = bQuad*bQuad - 4._rk *aQuad*cQuad + qquad = -0.5_rk * (bQuad + bSign*sqrt(xTemp)) ! compute roots root1 = qQuad / aQuad @@ -992,10 +992,10 @@ subroutine quadResist(desireDeriv,ix_bbHumdFunc,rlb,fHum,gMin,g0,dg0_dc,rs,drs_d ! compute derivatives in qquad w.r.t. ci select case(ix_bbHumdFunc) - case(humidLeafSurface); dXt_dc = dg0_dc*(rlb*bQuad*2._summa_prec - fHum*cQuad*4._summa_prec) - case(scaledHyperbolic); dXt_dc = dg0_dc*(rlb*bQuad*2._summa_prec - cQuad*4._summa_prec) + case(humidLeafSurface); dXt_dc = dg0_dc*(rlb*bQuad*2._rk - fHum*cQuad*4._rk) + case(scaledHyperbolic); dXt_dc = dg0_dc*(rlb*bQuad*2._rk - cQuad*4._rk) end select - dqq_dc = -0.5_summa_prec * (rlb*dg0_dc + bSign*dXt_dc*0.5_summa_prec / sqrt(xTemp) ) + dqq_dc = -0.5_rk * (rlb*dg0_dc + bSign*dXt_dc*0.5_rk / sqrt(xTemp) ) ! compute derivatives in rs if(root1 > root2)then @@ -1009,7 +1009,7 @@ subroutine quadResist(desireDeriv,ix_bbHumdFunc,rlb,fHum,gMin,g0,dg0_dc,rs,drs_d ! derivatives not desired else - drs_dc = 0._summa_prec + drs_dc = 0._rk end if end subroutine quadResist @@ -1022,17 +1022,17 @@ subroutine quadSmooth(desireDeriv, x1, x2, xsFac, dx1_dc, dx2_dc, xs, dxs_dc) implicit none ! dummy variables logical(lgt),intent(in) :: desireDeriv ! flag to denote if a derivative is desired - real(summa_prec),intent(in) :: x1,x2 ! variables to be smoothed - real(summa_prec),intent(in) :: xsFac ! smoothing factor - real(summa_prec),intent(in) :: dx1_dc,dx2_dc ! derivatives in variables w.r.t. something important - real(summa_prec),intent(out) :: xs ! smoothed variable - real(summa_prec),intent(out) :: dxs_dc ! derivative w.r.t. something important + real(rk),intent(in) :: x1,x2 ! variables to be smoothed + real(rk),intent(in) :: xsFac ! smoothing factor + real(rk),intent(in) :: dx1_dc,dx2_dc ! derivatives in variables w.r.t. something important + real(rk),intent(out) :: xs ! smoothed variable + real(rk),intent(out) :: dxs_dc ! derivative w.r.t. something important ! local variables - real(summa_prec) :: aQuad,bQuad,cQuad ! coefficients in the quadratic function - real(summa_prec) :: bSign,xTemp,qQuad ! q term in the quadratic - real(summa_prec) :: root1,root2 ! roots of the quadratic - real(summa_prec) :: dbq_dc,dcq_dc ! derivatives in quadratic coefficients - real(summa_prec) :: dxT_dc,dqq_dc ! derivatives in the q term + real(rk) :: aQuad,bQuad,cQuad ! coefficients in the quadratic function + real(rk) :: bSign,xTemp,qQuad ! q term in the quadratic + real(rk) :: root1,root2 ! roots of the quadratic + real(rk) :: dbq_dc,dcq_dc ! derivatives in quadratic coefficients + real(rk) :: dxT_dc,dqq_dc ! derivatives in the q term ! uses the quadratic of the form ! xsFac*xs^2 - (x1 + x2)*xs + x1*x2 = 0 @@ -1045,8 +1045,8 @@ subroutine quadSmooth(desireDeriv, x1, x2, xsFac, dx1_dc, dx2_dc, xs, dxs_dc) ! compute the q term in the quadratic bSign = abs(bQuad)/bQuad - xTemp = bQuad*bQuad - 4._summa_prec *aQuad*cQuad - qquad = -0.5_summa_prec * (bQuad + bSign*sqrt(xTemp)) + xTemp = bQuad*bQuad - 4._rk *aQuad*cQuad + qquad = -0.5_rk * (bQuad + bSign*sqrt(xTemp)) ! compute roots root1 = qQuad / aQuad @@ -1061,8 +1061,8 @@ subroutine quadSmooth(desireDeriv, x1, x2, xsFac, dx1_dc, dx2_dc, xs, dxs_dc) dcq_dc = x1*dx2_dc + x2*dx1_dc ! compute derivatives for xTemp - dxT_dc = 2._summa_prec*(bQuad*dbq_dc) - 4._summa_prec*aQuad*dcq_dc - dqq_dc = -0.5_summa_prec * (dbq_dc + bsign*dxT_dc/(2._summa_prec*sqrt(xTemp))) + dxT_dc = 2._rk*(bQuad*dbq_dc) - 4._rk*aQuad*dcq_dc + dqq_dc = -0.5_rk * (dbq_dc + bsign*dxT_dc/(2._rk*sqrt(xTemp))) ! compute derivatives in the desired root if(root1 < root2)then @@ -1073,7 +1073,7 @@ subroutine quadSmooth(desireDeriv, x1, x2, xsFac, dx1_dc, dx2_dc, xs, dxs_dc) ! derivatives not required else - dxs_dc = 0._summa_prec + dxs_dc = 0._rk end if end subroutine quadSmooth @@ -1086,32 +1086,32 @@ end subroutine quadSmooth ! q10 function for temperature dependence function q10(a,T,Tmid,Tscale) implicit none - real(summa_prec),intent(in) :: a ! scale factor - real(summa_prec),intent(in) :: T ! temperature (K) - real(summa_prec),intent(in) :: Tmid ! point where function is one (25 deg C) - real(summa_prec),intent(in) :: Tscale ! scaling factor (K) - real(summa_prec) :: q10 ! temperature dependence (-) + real(rk),intent(in) :: a ! scale factor + real(rk),intent(in) :: T ! temperature (K) + real(rk),intent(in) :: Tmid ! point where function is one (25 deg C) + real(rk),intent(in) :: Tscale ! scaling factor (K) + real(rk) :: q10 ! temperature dependence (-) q10 = a**((T - Tmid)/Tscale) end function q10 ! Arrhenius function for temperature dependence function fT(delH,T,Tref) implicit none - real(summa_prec),intent(in) :: delH ! activation energy in temperature function (J mol-1) - real(summa_prec),intent(in) :: T ! temperature (K) - real(summa_prec),intent(in) :: Tref ! reference temperature (K) - real(summa_prec) :: fT ! temperature dependence (-) - fT = exp((delH/(Tref*Rgas))*(1._summa_prec - Tref/T)) ! NOTE: Rgas = J K-1 mol-1 + real(rk),intent(in) :: delH ! activation energy in temperature function (J mol-1) + real(rk),intent(in) :: T ! temperature (K) + real(rk),intent(in) :: Tref ! reference temperature (K) + real(rk) :: fT ! temperature dependence (-) + fT = exp((delH/(Tref*Rgas))*(1._rk - Tref/T)) ! NOTE: Rgas = J K-1 mol-1 end function fT ! function for high temperature inhibition function fHigh(delH,delS,T) implicit none - real(summa_prec),intent(in) :: delH ! deactivation energy in high temp inhibition function (J mol-1) - real(summa_prec),intent(in) :: delS ! entropy term in high temp inhibition function (J K-1 mol-1) - real(summa_prec),intent(in) :: T ! temperature (K) - real(summa_prec) :: fHigh ! high temperature inhibition (-) - fHigh = 1._summa_prec + exp( (delS*T - delH)/(Rgas*T) ) ! NOTE: Rgas = J K-1 mol-1 + real(rk),intent(in) :: delH ! deactivation energy in high temp inhibition function (J mol-1) + real(rk),intent(in) :: delS ! entropy term in high temp inhibition function (J K-1 mol-1) + real(rk),intent(in) :: T ! temperature (K) + real(rk) :: fHigh ! high temperature inhibition (-) + fHigh = 1._rk + exp( (delS*T - delH)/(Rgas*T) ) ! NOTE: Rgas = J K-1 mol-1 end function fHigh @@ -1161,34 +1161,34 @@ subroutine stomResist_NoahMP(& integer(i4b),intent(in) :: vegTypeIndex ! vegetation type index integer(i4b),intent(in) :: iLoc, jLoc ! spatial location indices ! input (forcing) - real(summa_prec),intent(in) :: airtemp ! measured air temperature at some height above the surface (K) - real(summa_prec),intent(in) :: airpres ! measured air pressure at some height above the surface (Pa) - real(summa_prec),intent(in) :: scalarO2air ! atmospheric o2 concentration (Pa) - real(summa_prec),intent(in) :: scalarCO2air ! atmospheric co2 concentration (Pa) - real(summa_prec),intent(in),target :: scalarCanopySunlitPAR ! average absorbed par for sunlit leaves (w m-2) - real(summa_prec),intent(in),target :: scalarCanopyShadedPAR ! average absorbed par for shaded leaves (w m-2) + real(rk),intent(in) :: airtemp ! measured air temperature at some height above the surface (K) + real(rk),intent(in) :: airpres ! measured air pressure at some height above the surface (Pa) + real(rk),intent(in) :: scalarO2air ! atmospheric o2 concentration (Pa) + real(rk),intent(in) :: scalarCO2air ! atmospheric co2 concentration (Pa) + real(rk),intent(in),target :: scalarCanopySunlitPAR ! average absorbed par for sunlit leaves (w m-2) + real(rk),intent(in),target :: scalarCanopyShadedPAR ! average absorbed par for shaded leaves (w m-2) ! input (state and diagnostic variables) - real(summa_prec),intent(in) :: scalarGrowingSeasonIndex ! growing season index (0=off, 1=on) - real(summa_prec),intent(in) :: scalarFoliageNitrogenFactor ! foliage nitrogen concentration (1=saturated) - real(summa_prec),intent(in) :: scalarTranspireLim ! weighted average of the soil moiture factor controlling stomatal resistance (-) - real(summa_prec),intent(in) :: scalarLeafResistance ! leaf boundary layer resistance (s m-1) - real(summa_prec),intent(in) :: scalarVegetationTemp ! vegetation temperature (K) - real(summa_prec),intent(in) :: scalarSatVP_VegTemp ! saturation vapor pressure at vegetation temperature (Pa) - real(summa_prec),intent(in) :: scalarVP_CanopyAir ! canopy air vapor pressure (Pa) + real(rk),intent(in) :: scalarGrowingSeasonIndex ! growing season index (0=off, 1=on) + real(rk),intent(in) :: scalarFoliageNitrogenFactor ! foliage nitrogen concentration (1=saturated) + real(rk),intent(in) :: scalarTranspireLim ! weighted average of the soil moiture factor controlling stomatal resistance (-) + real(rk),intent(in) :: scalarLeafResistance ! leaf boundary layer resistance (s m-1) + real(rk),intent(in) :: scalarVegetationTemp ! vegetation temperature (K) + real(rk),intent(in) :: scalarSatVP_VegTemp ! saturation vapor pressure at vegetation temperature (Pa) + real(rk),intent(in) :: scalarVP_CanopyAir ! canopy air vapor pressure (Pa) ! output - real(summa_prec),intent(out) :: scalarStomResistSunlit ! stomatal resistance for sunlit leaves (s m-1) - real(summa_prec),intent(out) :: scalarStomResistShaded ! stomatal resistance for shaded leaves (s m-1) - real(summa_prec),intent(out) :: scalarPhotosynthesisSunlit ! sunlit photosynthesis (umolco2 m-2 s-1) - real(summa_prec),intent(out) :: scalarPhotosynthesisShaded ! sunlit photosynthesis (umolco2 m-2 s-1) + real(rk),intent(out) :: scalarStomResistSunlit ! stomatal resistance for sunlit leaves (s m-1) + real(rk),intent(out) :: scalarStomResistShaded ! stomatal resistance for shaded leaves (s m-1) + real(rk),intent(out) :: scalarPhotosynthesisSunlit ! sunlit photosynthesis (umolco2 m-2 s-1) + real(rk),intent(out) :: scalarPhotosynthesisShaded ! sunlit photosynthesis (umolco2 m-2 s-1) integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! local variables integer(i4b),parameter :: ixSunlit=1 ! named variable for sunlit leaves integer(i4b),parameter :: ixShaded=2 ! named variable for shaded leaves integer(i4b) :: iSunShade ! index for sunlit/shaded leaves - real(summa_prec),pointer :: PAR ! average absorbed PAR for sunlit/shaded leaves (w m-2) - real(summa_prec) :: scalarStomResist ! stomatal resistance for sunlit/shaded leaves (s m-1) - real(summa_prec) :: scalarPhotosynthesis ! photosynthesis for sunlit/shaded leaves (umolco2 m-2 s-1) + real(rk),pointer :: PAR ! average absorbed PAR for sunlit/shaded leaves (w m-2) + real(rk) :: scalarStomResist ! stomatal resistance for sunlit/shaded leaves (s m-1) + real(rk) :: scalarPhotosynthesis ! photosynthesis for sunlit/shaded leaves (umolco2 m-2 s-1) ! initialize error control err=0; message='stomResist_NoahMP/' diff --git a/build/source/engine/summaSolve.f90 b/build/source/engine/summaSolve.f90 index 59819989d..5b6d23e82 100755 --- a/build/source/engine/summaSolve.f90 +++ b/build/source/engine/summaSolve.f90 @@ -136,7 +136,7 @@ subroutine summaSolve(& implicit none ! -------------------------------------------------------------------------------------------------------------------------------- ! input: model control - real(summa_prec),intent(in) :: dt ! length of the time step (seconds) + real(rk),intent(in) :: dt ! length of the time step (seconds) integer(i4b),intent(in) :: iter ! interation index integer(i4b),intent(in) :: nSnow ! number of snow layers integer(i4b),intent(in) :: nSoil ! number of soil layers @@ -149,14 +149,14 @@ subroutine summaSolve(& logical(lgt),intent(in) :: computeVegFlux ! flag to indicate if computing fluxes over vegetation logical(lgt),intent(in) :: scalarSolution ! flag to denote if implementing the scalar solution ! input: state vectors - real(summa_prec),intent(in) :: stateVecTrial(:) ! trial state vector - real(summa_prec),intent(inout) :: xMin,xMax ! brackets of the root - real(summa_prec),intent(in) :: fScale(:) ! function scaling vector - real(summa_prec),intent(in) :: xScale(:) ! "variable" scaling vector, i.e., for state variables - real(summa_prec),intent(in) :: rVec(:) ! NOTE: qp ! residual vector - real(summa_prec),intent(in) :: sMul(:) ! NOTE: qp ! state vector multiplier (used in the residual calculations) - real(summa_prec),intent(inout) :: dMat(:) ! diagonal matrix (excludes flux derivatives) - real(summa_prec),intent(in) :: fOld ! old function evaluation + real(rk),intent(in) :: stateVecTrial(:) ! trial state vector + real(rk),intent(inout) :: xMin,xMax ! brackets of the root + real(rk),intent(in) :: fScale(:) ! function scaling vector + real(rk),intent(in) :: xScale(:) ! "variable" scaling vector, i.e., for state variables + real(rk),intent(in) :: rVec(:) ! NOTE: qp ! residual vector + real(rk),intent(in) :: sMul(:) ! NOTE: qp ! state vector multiplier (used in the residual calculations) + real(rk),intent(inout) :: dMat(:) ! diagonal matrix (excludes flux derivatives) + real(rk),intent(in) :: fOld ! old function evaluation ! input: data structures type(model_options),intent(in) :: model_decisions(:) ! model decisions type(var_i), intent(in) :: type_data ! type of vegetation and soil @@ -172,13 +172,13 @@ subroutine summaSolve(& type(var_dlength),intent(inout) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables ! input-output: baseflow integer(i4b),intent(inout) :: ixSaturation ! index of the lowest saturated layer (NOTE: only computed on the first iteration) - real(summa_prec),intent(inout) :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) + real(rk),intent(inout) :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) ! output: flux and residual vectors - real(summa_prec),intent(out) :: stateVecNew(:) ! new state vector - real(summa_prec),intent(out) :: fluxVecNew(:) ! new flux vector - real(summa_prec),intent(out) :: resSinkNew(:) ! sink terms on the RHS of the flux equation - real(summa_prec),intent(out) :: resVecNew(:) ! NOTE: qp ! new residual vector - real(summa_prec),intent(out) :: fNew ! new function evaluation + real(rk),intent(out) :: stateVecNew(:) ! new state vector + real(rk),intent(out) :: fluxVecNew(:) ! new flux vector + real(rk),intent(out) :: resSinkNew(:) ! sink terms on the RHS of the flux equation + real(rk),intent(out) :: resVecNew(:) ! NOTE: qp ! new residual vector + real(rk),intent(out) :: fNew ! new function evaluation logical(lgt),intent(out) :: converged ! convergence flag ! output: error control integer(i4b),intent(out) :: err ! error code @@ -189,13 +189,13 @@ subroutine summaSolve(& ! Jacobian matrix logical(lgt),parameter :: doNumJacobian=.false. ! flag to compute the numerical Jacobian matrix logical(lgt),parameter :: testBandDiagonal=.false. ! flag to test the band diagonal Jacobian matrix - real(summa_prec) :: nJac(nState,nState) ! numerical Jacobian matrix - real(summa_prec) :: aJac(nLeadDim,nState) ! Jacobian matrix - real(summa_prec) :: aJacScaled(nLeadDim,nState) ! Jacobian matrix (scaled) - real(summa_prec) :: aJacScaledTemp(nLeadDim,nState) ! Jacobian matrix (scaled) -- temporary copy since decomposed in lapack + real(rk) :: nJac(nState,nState) ! numerical Jacobian matrix + real(rk) :: aJac(nLeadDim,nState) ! Jacobian matrix + real(rk) :: aJacScaled(nLeadDim,nState) ! Jacobian matrix (scaled) + real(rk) :: aJacScaledTemp(nLeadDim,nState) ! Jacobian matrix (scaled) -- temporary copy since decomposed in lapack ! solution/step vectors - real(summa_prec),dimension(nState) :: rVecScaled ! residual vector (scaled) - real(summa_prec),dimension(nState) :: newtStepScaled ! full newton step (scaled) + real(rk),dimension(nState) :: rVecScaled ! residual vector (scaled) + real(rk),dimension(nState) :: newtStepScaled ! full newton step (scaled) ! step size refinement logical(lgt) :: doRefine ! flag for step refinement integer(i4b),parameter :: ixLineSearch=1001 ! step refinement = line search @@ -269,7 +269,7 @@ subroutine summaSolve(& ! ------------------------ ! scale the residual vector - rVecScaled(1:nState) = fScale(:)*real(rVec(:), summa_prec) ! NOTE: residual vector is in quadruple precision + rVecScaled(1:nState) = fScale(:)*real(rVec(:), rk) ! NOTE: residual vector is in quadruple precision ! scale matrices call scaleMatrices(ixMatrix,nState,aJac,fScale,xScale,aJacScaled,err,cmessage) @@ -342,36 +342,36 @@ subroutine lineSearchRefinement(doLineSearch,stateVecTrial,newtStepScaled,aJacSc implicit none ! input logical(lgt),intent(in) :: doLineSearch ! flag to do the line search - real(summa_prec),intent(in) :: stateVecTrial(:) ! trial state vector - real(summa_prec),intent(in) :: newtStepScaled(:) ! scaled newton step - real(summa_prec),intent(in) :: aJacScaled(:,:) ! scaled jacobian matrix - real(summa_prec),intent(in) :: rVecScaled(:) ! scaled residual vector - real(summa_prec),intent(in) :: fOld ! old function value + real(rk),intent(in) :: stateVecTrial(:) ! trial state vector + real(rk),intent(in) :: newtStepScaled(:) ! scaled newton step + real(rk),intent(in) :: aJacScaled(:,:) ! scaled jacobian matrix + real(rk),intent(in) :: rVecScaled(:) ! scaled residual vector + real(rk),intent(in) :: fOld ! old function value ! output - real(summa_prec),intent(out) :: stateVecNew(:) ! new state vector - real(summa_prec),intent(out) :: fluxVecNew(:) ! new flux vector - real(summa_prec),intent(out) :: resVecNew(:) ! NOTE: qp ! new residual vector - real(summa_prec),intent(out) :: fNew ! new function evaluation + real(rk),intent(out) :: stateVecNew(:) ! new state vector + real(rk),intent(out) :: fluxVecNew(:) ! new flux vector + real(rk),intent(out) :: resVecNew(:) ! NOTE: qp ! new residual vector + real(rk),intent(out) :: fNew ! new function evaluation logical(lgt),intent(out) :: converged ! convergence flag integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! -------------------------------------------------------------------------------------------------------- ! local character(len=256) :: cmessage ! error message of downwind routine - real(summa_prec) :: gradScaled(nState) ! scaled gradient - real(summa_prec) :: xInc(nState) ! iteration increment (re-scaled to original units of the state vector) + real(rk) :: gradScaled(nState) ! scaled gradient + real(rk) :: xInc(nState) ! iteration increment (re-scaled to original units of the state vector) logical(lgt) :: feasible ! flag to denote the feasibility of the solution integer(i4b) :: iLine ! line search index integer(i4b),parameter :: maxLineSearch=5 ! maximum number of backtracks - real(summa_prec),parameter :: alpha=1.e-4_summa_prec ! check on gradient - real(summa_prec) :: xLambda ! backtrack magnitude - real(summa_prec) :: xLambdaTemp ! temporary backtrack magnitude - real(summa_prec) :: slopeInit ! initial slope - real(summa_prec) :: rhs1,rhs2 ! rhs used to compute the cubic - real(summa_prec) :: aCoef,bCoef ! coefficients in the cubic - real(summa_prec) :: disc ! temporary variable used in cubic - real(summa_prec) :: xLambdaPrev ! previous lambda value (used in the cubic) - real(summa_prec) :: fPrev ! previous function evaluation (used in the cubic) + real(rk),parameter :: alpha=1.e-4_rk ! check on gradient + real(rk) :: xLambda ! backtrack magnitude + real(rk) :: xLambdaTemp ! temporary backtrack magnitude + real(rk) :: slopeInit ! initial slope + real(rk) :: rhs1,rhs2 ! rhs used to compute the cubic + real(rk) :: aCoef,bCoef ! coefficients in the cubic + real(rk) :: disc ! temporary variable used in cubic + real(rk) :: xLambdaPrev ! previous lambda value (used in the cubic) + real(rk) :: fPrev ! previous function evaluation (used in the cubic) ! -------------------------------------------------------------------------------------------------------- ! initialize error control err=0; message='lineSearchRefinement/' @@ -389,7 +389,7 @@ subroutine lineSearchRefinement(doLineSearch,stateVecTrial,newtStepScaled,aJacSc end if ! if computing the line search ! initialize lambda - xLambda=1._summa_prec + xLambda=1._rk ! ***** LINE SEARCH LOOP... lineSearch: do iLine=1,maxLineSearch ! try to refine the function by shrinking the step size @@ -449,8 +449,8 @@ subroutine lineSearchRefinement(doLineSearch,stateVecTrial,newtStepScaled,aJacSc ! first backtrack: use quadratic if(iLine==1)then - xLambdaTemp = -slopeInit / (2._summa_prec*(fNew - fOld - slopeInit) ) - if(xLambdaTemp > 0.5_summa_prec*xLambda) xLambdaTemp = 0.5_summa_prec*xLambda + xLambdaTemp = -slopeInit / (2._rk*(fNew - fOld - slopeInit) ) + if(xLambdaTemp > 0.5_rk*xLambda) xLambdaTemp = 0.5_rk*xLambda ! subsequent backtracks: use cubic else @@ -470,21 +470,21 @@ subroutine lineSearchRefinement(doLineSearch,stateVecTrial,newtStepScaled,aJacSc bCoef = (-xLambdaPrev*rhs1/(xLambda*xLambda) + xLambda*rhs2/(xLambdaPrev*xLambdaPrev)) / (xLambda - xLambdaPrev) ! check if a quadratic - if(aCoef==0._summa_prec)then - xLambdaTemp = -slopeInit/(2._summa_prec*bCoef) + if(aCoef==0._rk)then + xLambdaTemp = -slopeInit/(2._rk*bCoef) ! calculate cubic else - disc = bCoef*bCoef - 3._summa_prec*aCoef*slopeInit - if(disc < 0._summa_prec)then - xLambdaTemp = 0.5_summa_prec*xLambda + disc = bCoef*bCoef - 3._rk*aCoef*slopeInit + if(disc < 0._rk)then + xLambdaTemp = 0.5_rk*xLambda else - xLambdaTemp = (-bCoef + sqrt(disc))/(3._summa_prec*aCoef) + xLambdaTemp = (-bCoef + sqrt(disc))/(3._rk*aCoef) end if end if ! calculating cubic ! constrain to <= 0.5*xLambda - if(xLambdaTemp > 0.5_summa_prec*xLambda) xLambdaTemp=0.5_summa_prec*xLambda + if(xLambdaTemp > 0.5_rk*xLambda) xLambdaTemp=0.5_rk*xLambda end if ! subsequent backtracks @@ -493,7 +493,7 @@ subroutine lineSearchRefinement(doLineSearch,stateVecTrial,newtStepScaled,aJacSc fPrev = fNew ! constrain lambda - xLambda = max(xLambdaTemp, 0.1_summa_prec*xLambda) + xLambda = max(xLambdaTemp, 0.1_rk*xLambda) end do lineSearch ! backtrack loop @@ -510,16 +510,16 @@ subroutine trustRegionRefinement(doTrustRefinement,stateVecTrial,newtStepScaled, implicit none ! input logical(lgt),intent(in) :: doTrustRefinement ! flag to refine using trust regions - real(summa_prec),intent(in) :: stateVecTrial(:) ! trial state vector - real(summa_prec),intent(in) :: newtStepScaled(:) ! scaled newton step - real(summa_prec),intent(in) :: aJacScaled(:,:) ! scaled jacobian matrix - real(summa_prec),intent(in) :: rVecScaled(:) ! scaled residual vector - real(summa_prec),intent(in) :: fOld ! old function value + real(rk),intent(in) :: stateVecTrial(:) ! trial state vector + real(rk),intent(in) :: newtStepScaled(:) ! scaled newton step + real(rk),intent(in) :: aJacScaled(:,:) ! scaled jacobian matrix + real(rk),intent(in) :: rVecScaled(:) ! scaled residual vector + real(rk),intent(in) :: fOld ! old function value ! output - real(summa_prec),intent(out) :: stateVecNew(:) ! new state vector - real(summa_prec),intent(out) :: fluxVecNew(:) ! new flux vector - real(summa_prec),intent(out) :: resVecNew(:) ! NOTE: qp ! new residual vector - real(summa_prec),intent(out) :: fNew ! new function evaluation + real(rk),intent(out) :: stateVecNew(:) ! new state vector + real(rk),intent(out) :: fluxVecNew(:) ! new flux vector + real(rk),intent(out) :: resVecNew(:) ! NOTE: qp ! new residual vector + real(rk),intent(out) :: fNew ! new function evaluation logical(lgt),intent(out) :: converged ! convergence flag integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message @@ -576,31 +576,31 @@ subroutine safeRootfinder(stateVecTrial,rVecscaled,newtStepScaled,stateVecNew,fl USE globalData,only:dNaN ! double precision NaN implicit none ! input - real(summa_prec),intent(in) :: stateVecTrial(:) ! trial state vector - real(summa_prec),intent(in) :: rVecScaled(:) ! scaled residual vector - real(summa_prec),intent(in) :: newtStepScaled(:) ! scaled newton step + real(rk),intent(in) :: stateVecTrial(:) ! trial state vector + real(rk),intent(in) :: rVecScaled(:) ! scaled residual vector + real(rk),intent(in) :: newtStepScaled(:) ! scaled newton step ! output - real(summa_prec),intent(out) :: stateVecNew(:) ! new state vector - real(summa_prec),intent(out) :: fluxVecNew(:) ! new flux vector - real(summa_prec),intent(out) :: resVecNew(:) ! NOTE: qp ! new residual vector - real(summa_prec),intent(out) :: fNew ! new function evaluation + real(rk),intent(out) :: stateVecNew(:) ! new state vector + real(rk),intent(out) :: fluxVecNew(:) ! new flux vector + real(rk),intent(out) :: resVecNew(:) ! NOTE: qp ! new residual vector + real(rk),intent(out) :: fNew ! new function evaluation logical(lgt),intent(out) :: converged ! convergence flag integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! -------------------------------------------------------------------------------------------------------- ! local variables character(len=256) :: cmessage ! error message of downwind routine - real(summa_prec),parameter :: relTolerance=0.005_summa_prec ! force bi-section if trial is slightly larger than (smaller than) xmin (xmax) - real(summa_prec) :: xTolerance ! relTolerance*(xmax-xmin) - real(summa_prec) :: xInc(nState) ! iteration increment (re-scaled to original units of the state vector) - real(summa_prec) :: rVec(nState) ! residual vector (re-scaled to original units of the state equation) + real(rk),parameter :: relTolerance=0.005_rk ! force bi-section if trial is slightly larger than (smaller than) xmin (xmax) + real(rk) :: xTolerance ! relTolerance*(xmax-xmin) + real(rk) :: xInc(nState) ! iteration increment (re-scaled to original units of the state vector) + real(rk) :: rVec(nState) ! residual vector (re-scaled to original units of the state equation) logical(lgt) :: feasible ! feasibility of the solution logical(lgt) :: doBisection ! flag to do the bi-section logical(lgt) :: bracketsDefined ! flag to define if the brackets are defined !integer(i4b) :: iCheck ! check the model state variables (not used) integer(i4b),parameter :: nCheck=100 ! number of times to check the model state variables - real(summa_prec),parameter :: delX=1._summa_prec ! trial increment - !real(summa_prec) :: xIncrement(nState) ! trial increment (not used) + real(rk),parameter :: delX=1._rk ! trial increment + !real(rk) :: xIncrement(nState) ! trial increment (not used) ! -------------------------------------------------------------------------------------------------------- err=0; message='safeRootfinder/' @@ -617,10 +617,10 @@ subroutine safeRootfinder(stateVecTrial,rVecscaled,newtStepScaled,stateVecNew,fl endif ! get the residual vector - rVec = real(rVecScaled, summa_prec)*real(fScale, summa_prec) + rVec = real(rVecScaled, rk)*real(fScale, rk) ! update brackets - if(rVec(1)<0._summa_prec)then + if(rVec(1)<0._rk)then xMin = stateVecTrial(1) else xMax = stateVecTrial(1) @@ -631,7 +631,7 @@ subroutine safeRootfinder(stateVecTrial,rVecscaled,newtStepScaled,stateVecNew,fl ! ***** ! * case 1: the iteration increment is the same sign as the residual vector - if(xInc(1)*rVec(1) > 0._summa_prec)then + if(xInc(1)*rVec(1) > 0._rk)then ! get brackets if they do not exist if( ieee_is_nan(xMin) .or. ieee_is_nan(xMax) )then @@ -640,7 +640,7 @@ subroutine safeRootfinder(stateVecTrial,rVecscaled,newtStepScaled,stateVecNew,fl endif ! use bi-section - stateVecNew(1) = 0.5_summa_prec*(xMin + xMax) + stateVecNew(1) = 0.5_rk*(xMin + xMax) ! ***** ! * case 2: the iteration increment is the correct sign @@ -660,7 +660,7 @@ subroutine safeRootfinder(stateVecTrial,rVecscaled,newtStepScaled,stateVecNew,fl if(bracketsDefined)then xTolerance = relTolerance*(xMax-xMin) doBisection = (stateVecNew(1)xMax-xTolerance) - if(doBisection) stateVecNew(1) = 0.5_summa_prec*(xMin+xMax) + if(doBisection) stateVecNew(1) = 0.5_rk*(xMin+xMax) endif ! evaluate summa @@ -686,17 +686,17 @@ subroutine getBrackets(stateVecTrial,stateVecNew,xMin,xMax,err,message) USE,intrinsic :: ieee_arithmetic,only:ieee_is_nan ! IEEE arithmetic (check NaN) implicit none ! dummies - real(summa_prec),intent(in) :: stateVecTrial(:) ! trial state vector - real(summa_prec),intent(out) :: stateVecNew(:) ! new state vector - real(summa_prec),intent(out) :: xMin,xMax ! constraints + real(rk),intent(in) :: stateVecTrial(:) ! trial state vector + real(rk),intent(out) :: stateVecNew(:) ! new state vector + real(rk),intent(out) :: xMin,xMax ! constraints integer(i4b),intent(inout) :: err ! error code character(*),intent(out) :: message ! error message ! locals integer(i4b) :: iCheck ! check the model state variables integer(i4b),parameter :: nCheck=100 ! number of times to check the model state variables logical(lgt) :: feasible ! feasibility of the solution - real(summa_prec),parameter :: delX=1._summa_prec ! trial increment - real(summa_prec) :: xIncrement(nState) ! trial increment + real(rk),parameter :: delX=1._rk ! trial increment + real(rk) :: xIncrement(nState) ! trial increment ! initialize err=0; message='getBrackets/' @@ -724,7 +724,7 @@ subroutine getBrackets(stateVecTrial,stateVecNew,xMin,xMax,err,message) if(.not.feasible)then; message=trim(message)//'state vector is not feasible'; err=20; return; endif ! update brackets - if(real(resVecNew(1), summa_prec)<0._summa_prec)then + if(real(resVecNew(1), rk)<0._rk)then xMin = stateVecNew(1) else xMax = stateVecNew(1) @@ -754,20 +754,20 @@ end subroutine getBrackets subroutine numJacobian(stateVec,dMat,nJac,err,message) implicit none ! dummies - real(summa_prec),intent(in) :: stateVec(:) ! trial state vector - real(summa_prec),intent(in) :: dMat(:) ! diagonal matrix + real(rk),intent(in) :: stateVec(:) ! trial state vector + real(rk),intent(in) :: dMat(:) ! diagonal matrix ! output - real(summa_prec),intent(out) :: nJac(:,:) ! numerical Jacobian + real(rk),intent(out) :: nJac(:,:) ! numerical Jacobian integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! ---------------------------------------------------------------------------------------------------------- ! local character(len=256) :: cmessage ! error message of downwind routine - real(summa_prec),parameter :: dx=1.e-8_summa_prec ! finite difference increment - real(summa_prec),dimension(nState) :: stateVecPerturbed ! perturbed state vector - real(summa_prec),dimension(nState) :: fluxVecInit,fluxVecJac ! flux vector (mized units) - real(summa_prec),dimension(nState) :: resVecInit,resVecJac ! qp ! residual vector (mixed units) - real(summa_prec) :: func ! function value + real(rk),parameter :: dx=1.e-8_rk ! finite difference increment + real(rk),dimension(nState) :: stateVecPerturbed ! perturbed state vector + real(rk),dimension(nState) :: fluxVecInit,fluxVecJac ! flux vector (mized units) + real(rk),dimension(nState) :: resVecInit,resVecJac ! qp ! residual vector (mixed units) + real(rk) :: func ! function value logical(lgt) :: feasible ! flag to denote the feasibility of the solution integer(i4b) :: iJac ! index of row of the Jacobian matrix integer(i4b),parameter :: ixNumFlux=1001 ! named variable for the flux-based form of the numerical Jacobian @@ -802,7 +802,7 @@ subroutine numJacobian(stateVec,dMat,nJac,err,message) ! compute the row of the Jacobian matrix select case(ixNumType) - case(ixNumRes); nJac(:,iJac) = real(resVecJac - resVecInit, kind(summa_prec) )/dx ! Jacobian based on residuals + case(ixNumRes); nJac(:,iJac) = real(resVecJac - resVecInit, kind(rk) )/dx ! Jacobian based on residuals case(ixNumFlux); nJac(:,iJac) = -dt*(fluxVecJac(:) - fluxVecInit(:))/dx ! Jacobian based on fluxes case default; err=20; message=trim(message)//'Jacobian option not found'; return end select @@ -835,8 +835,8 @@ subroutine testBandMat(check,err,message) integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! local variables - real(summa_prec) :: fullJac(nState,nState) ! full Jacobian matrix - real(summa_prec) :: bandJac(nLeadDim,nState) ! band Jacobian matrix + real(rk) :: fullJac(nState,nState) ! full Jacobian matrix + real(rk) :: bandJac(nLeadDim,nState) ! band Jacobian matrix integer(i4b) :: iState,jState ! indices of the state vector character(LEN=256) :: cmessage ! error message of downwind routine ! initialize error control @@ -873,7 +873,7 @@ subroutine testBandMat(check,err,message) if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! (check for errors) ! initialize band matrix - bandJac(:,:) = 0._summa_prec + bandJac(:,:) = 0._rk ! transfer into the lapack band diagonal structure do iState=1,nState @@ -906,11 +906,11 @@ subroutine eval8summa_wrapper(stateVecNew,fluxVecNew,resVecNew,fNew,feasible,err USE eval8summa_module,only:eval8summa ! simulation of fluxes and residuals given a trial state vector implicit none ! input - real(summa_prec),intent(in) :: stateVecNew(:) ! updated state vector + real(rk),intent(in) :: stateVecNew(:) ! updated state vector ! output - real(summa_prec),intent(out) :: fluxVecNew(:) ! updated flux vector - real(summa_prec),intent(out) :: resVecNew(:) ! NOTE: qp ! updated residual vector - real(summa_prec),intent(out) :: fNew ! new function value + real(rk),intent(out) :: fluxVecNew(:) ! updated flux vector + real(rk),intent(out) :: resVecNew(:) ! NOTE: qp ! updated residual vector + real(rk),intent(out) :: fNew ! new function value logical(lgt),intent(out) :: feasible ! flag to denote the feasibility of the solution integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message @@ -972,20 +972,20 @@ end subroutine eval8summa_wrapper function checkConv(rVec,xInc,xVec) implicit none ! dummies - real(summa_prec),intent(in) :: rVec(:) ! residual vector (mixed units) - real(summa_prec),intent(in) :: xInc(:) ! iteration increment (mixed units) - real(summa_prec),intent(in) :: xVec(:) ! state vector (mixed units) + real(rk),intent(in) :: rVec(:) ! residual vector (mixed units) + real(rk),intent(in) :: xInc(:) ! iteration increment (mixed units) + real(rk),intent(in) :: xVec(:) ! state vector (mixed units) logical(lgt) :: checkConv ! flag to denote convergence ! locals - real(summa_prec),dimension(mSoil) :: psiScale ! scaling factor for matric head - real(summa_prec),parameter :: xSmall=1.e-0_summa_prec ! a small offset - real(summa_prec),parameter :: scalarTighten=0.1_summa_prec ! scaling factor for the scalar solution - real(summa_prec) :: soilWatbalErr ! error in the soil water balance - real(summa_prec) :: canopy_max ! absolute value of the residual in canopy water (kg m-2) - real(summa_prec),dimension(1) :: energy_max ! maximum absolute value of the energy residual (J m-3) - real(summa_prec),dimension(1) :: liquid_max ! maximum absolute value of the volumetric liquid water content residual (-) - real(summa_prec),dimension(1) :: matric_max ! maximum absolute value of the matric head iteration increment (m) - real(summa_prec) :: aquifer_max ! absolute value of the residual in aquifer water (m) + real(rk),dimension(mSoil) :: psiScale ! scaling factor for matric head + real(rk),parameter :: xSmall=1.e-0_rk ! a small offset + real(rk),parameter :: scalarTighten=0.1_rk ! scaling factor for the scalar solution + real(rk) :: soilWatbalErr ! error in the soil water balance + real(rk) :: canopy_max ! absolute value of the residual in canopy water (kg m-2) + real(rk),dimension(1) :: energy_max ! maximum absolute value of the energy residual (J m-3) + real(rk),dimension(1) :: liquid_max ! maximum absolute value of the volumetric liquid water content residual (-) + real(rk),dimension(1) :: matric_max ! maximum absolute value of the matric head iteration increment (m) + real(rk) :: aquifer_max ! absolute value of the residual in aquifer water (m) logical(lgt) :: canopyConv ! flag for canopy water balance convergence logical(lgt) :: watbalConv ! flag for soil water balance convergence logical(lgt) :: liquidConv ! flag for residual convergence @@ -1016,7 +1016,7 @@ function checkConv(rVec,xInc,xVec) ! check convergence based on the canopy water balance if(ixVegHyd/=integerMissing)then - canopy_max = real(abs(rVec(ixVegHyd)), summa_prec)*iden_water + canopy_max = real(abs(rVec(ixVegHyd)), rk)*iden_water canopyConv = (canopy_max < absConvTol_liquid) ! absolute error in canopy water balance (mm) else canopy_max = realMissing @@ -1025,7 +1025,7 @@ function checkConv(rVec,xInc,xVec) ! check convergence based on the residuals for energy (J m-3) if(size(ixNrgOnly)>0)then - energy_max = real(maxval(abs( rVec(ixNrgOnly) )), summa_prec) + energy_max = real(maxval(abs( rVec(ixNrgOnly) )), rk) energyConv = (energy_max(1) < absConvTol_energy) ! (based on the residual) else energy_max = realMissing @@ -1034,7 +1034,7 @@ function checkConv(rVec,xInc,xVec) ! check convergence based on the residuals for volumetric liquid water content (-) if(size(ixHydOnly)>0)then - liquid_max = real(maxval(abs( rVec(ixHydOnly) ) ), summa_prec) + liquid_max = real(maxval(abs( rVec(ixHydOnly) ) ), rk) ! (tighter convergence for the scalar solution) if(scalarSolution)then liquidConv = (liquid_max(1) < absConvTol_liquid*scalarTighten) ! (based on the residual) @@ -1059,7 +1059,7 @@ function checkConv(rVec,xInc,xVec) ! check convergence based on the soil water balance error (m) if(size(ixMatOnly)>0)then - soilWatBalErr = sum( real(rVec(ixMatOnly), summa_prec)*mLayerDepth(nSnow+ixMatricHead) ) + soilWatBalErr = sum( real(rVec(ixMatOnly), rk)*mLayerDepth(nSnow+ixMatricHead) ) watbalConv = (abs(soilWatbalErr) < absConvTol_liquid) ! absolute error in total soil water balance (m) else soilWatbalErr = realMissing @@ -1068,7 +1068,7 @@ function checkConv(rVec,xInc,xVec) ! check convergence based on the aquifer storage if(ixAqWat/=integerMissing)then - aquifer_max = real(abs(rVec(ixAqWat)), summa_prec)*iden_water + aquifer_max = real(abs(rVec(ixAqWat)), rk)*iden_water aquiferConv = (aquifer_max < absConvTol_liquid) ! absolute error in aquifer water balance (mm) else aquifer_max = realMissing @@ -1099,25 +1099,25 @@ subroutine imposeConstraints(stateVecTrial,xInc,err,message) USE soil_utils_module,only:crit_soilT ! compute the critical temperature below which ice exists implicit none ! dummies - real(summa_prec),intent(in) :: stateVecTrial(:) ! trial state vector - real(summa_prec),intent(inout) :: xInc(:) ! iteration increment + real(rk),intent(in) :: stateVecTrial(:) ! trial state vector + real(rk),intent(inout) :: xInc(:) ! iteration increment integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! ----------------------------------------------------------------------------------------------------- ! temporary variables for model constraints - real(summa_prec) :: cInc ! constrained temperature increment (K) -- simplified bi-section - real(summa_prec) :: xIncFactor ! scaling factor for the iteration increment (-) + real(rk) :: cInc ! constrained temperature increment (K) -- simplified bi-section + real(rk) :: xIncFactor ! scaling factor for the iteration increment (-) integer(i4b) :: iMax(1) ! index of maximum temperature - real(summa_prec) :: scalarTemp ! temperature of an individual snow layer (K) - real(summa_prec) :: volFracLiq ! volumetric liquid water content of an individual snow layer (-) + real(rk) :: scalarTemp ! temperature of an individual snow layer (K) + real(rk) :: volFracLiq ! volumetric liquid water content of an individual snow layer (-) logical(lgt),dimension(nSnow) :: drainFlag ! flag to denote when drainage exceeds available capacity logical(lgt),dimension(nSoil) :: crosFlag ! flag to denote temperature crossing from unfrozen to frozen (or vice-versa) logical(lgt) :: crosTempVeg ! flag to denoote where temperature crosses the freezing point - real(summa_prec) :: xPsi00 ! matric head after applying the iteration increment (m) - real(summa_prec) :: TcSoil ! critical point when soil begins to freeze (K) - real(summa_prec) :: critDiff ! temperature difference from critical (K) - real(summa_prec),parameter :: epsT=1.e-7_summa_prec ! small interval above/below critical (K) - real(summa_prec),parameter :: zMaxTempIncrement=1._summa_prec ! maximum temperature increment (K) + real(rk) :: xPsi00 ! matric head after applying the iteration increment (m) + real(rk) :: TcSoil ! critical point when soil begins to freeze (K) + real(rk) :: critDiff ! temperature difference from critical (K) + real(rk),parameter :: epsT=1.e-7_rk ! small interval above/below critical (K) + real(rk),parameter :: zMaxTempIncrement=1._rk ! maximum temperature increment (K) ! indices of model state variables integer(i4b) :: iState ! index of state within a specific variable type integer(i4b) :: ixNrg,ixLiq ! index of energy and mass state variables in full state vector @@ -1180,7 +1180,7 @@ subroutine imposeConstraints(stateVecTrial,xInc,err,message) crosTempVeg = .false. ! initially frozen (T < Tfreeze) - if(critDiff > 0._summa_prec)then + if(critDiff > 0._rk)then if(xInc(ixVegNrg) > critDiff)then crosTempVeg = .true. cInc = critDiff + epsT ! constrained temperature increment (K) @@ -1209,9 +1209,9 @@ subroutine imposeConstraints(stateVecTrial,xInc,err,message) if(ixVegHyd/=integerMissing)then ! check if new value of storage will be negative - if(stateVecTrial(ixVegHyd)+xInc(ixVegHyd) < 0._summa_prec)then + if(stateVecTrial(ixVegHyd)+xInc(ixVegHyd) < 0._rk)then ! scale iteration increment - cInc = -0.5_summa_prec*stateVecTrial(ixVegHyd) ! constrained iteration increment (K) -- simplified bi-section + cInc = -0.5_rk*stateVecTrial(ixVegHyd) ! constrained iteration increment (K) -- simplified bi-section xIncFactor = cInc/xInc(ixVegHyd) ! scaling factor for the iteration increment (-) xInc = xIncFactor*xInc ! new iteration increment end if @@ -1232,7 +1232,7 @@ subroutine imposeConstraints(stateVecTrial,xInc,err,message) iState = ixSnowOnlyNrg(iLayer) if(stateVecTrial(iState) + xInc(iState) > Tfreeze)then ! scale iteration increment - cInc = 0.5_summa_prec*(Tfreeze - stateVecTrial(iState) ) ! constrained temperature increment (K) -- simplified bi-section + cInc = 0.5_rk*(Tfreeze - stateVecTrial(iState) ) ! constrained temperature increment (K) -- simplified bi-section xIncFactor = cInc/xInc(iState) ! scaling factor for the iteration increment (-) xInc = xIncFactor*xInc end if ! if snow temperature > freezing @@ -1271,7 +1271,7 @@ subroutine imposeConstraints(stateVecTrial,xInc,err,message) ! * check that the iteration increment does not exceed volumetric liquid water content if(-xInc(ixSnowOnlyHyd(iLayer)) > volFracLiq)then drainFlag(iLayer) = .true. - xInc(ixSnowOnlyHyd(iLayer)) = -0.5_summa_prec*volFracLiq + xInc(ixSnowOnlyHyd(iLayer)) = -0.5_rk*volFracLiq endif end do ! looping through snow layers @@ -1304,7 +1304,7 @@ subroutine imposeConstraints(stateVecTrial,xInc,err,message) critDiff = TcSoil - stateVecTrial(ixNrg) ! * initially frozen (T < TcSoil) - if(critDiff > 0._summa_prec)then + if(critDiff > 0._rk)then ! (check crossing above zero) if(xInc(ixNrg) > critDiff)then @@ -1334,8 +1334,8 @@ subroutine imposeConstraints(stateVecTrial,xInc,err,message) ixLiq = ixMatOnly(iState) ! - place constraint for matric head - if(xInc(ixLiq) > 1._summa_prec .and. stateVecTrial(ixLiq) > 0._summa_prec)then - xInc(ixLiq) = 1._summa_prec + if(xInc(ixLiq) > 1._rk .and. stateVecTrial(ixLiq) > 0._rk)then + xInc(ixLiq) = 1._rk endif ! if constraining matric head end do ! (loop through soil layers) diff --git a/build/source/engine/sunGeomtry.f90 b/build/source/engine/sunGeomtry.f90 index 8d747efc6..0c897dc10 100755 --- a/build/source/engine/sunGeomtry.f90 +++ b/build/source/engine/sunGeomtry.f90 @@ -48,32 +48,32 @@ SUBROUTINE CLRSKY_RAD(MONTH,DAY,HOUR,DT,SLOPE,AZI,LAT,HRI,COSZEN) ! Input variables INTEGER(I4B), INTENT(IN) :: MONTH ! month as mm integer INTEGER(I4B), INTENT(IN) :: DAY ! day of month as dd integer - real(summa_prec), INTENT(IN) :: HOUR ! hour of day as real - real(summa_prec), INTENT(IN) :: DT ! time step in units of hours - real(summa_prec), INTENT(IN) :: SLOPE ! slope of ground surface in degrees - real(summa_prec), INTENT(IN) :: AZI ! aspect (azimuth) of ground surface in degrees - real(summa_prec), INTENT(IN) :: LAT ! latitude in degrees (negative for southern hemisphere) + real(rk), INTENT(IN) :: HOUR ! hour of day as real + real(rk), INTENT(IN) :: DT ! time step in units of hours + real(rk), INTENT(IN) :: SLOPE ! slope of ground surface in degrees + real(rk), INTENT(IN) :: AZI ! aspect (azimuth) of ground surface in degrees + real(rk), INTENT(IN) :: LAT ! latitude in degrees (negative for southern hemisphere) ! Outputs - real(summa_prec), INTENT(OUT) :: HRI ! average radiation index over time step DT - real(summa_prec), INTENT(OUT) :: COSZEN ! average cosine of the zenith angle over time step DT + real(rk), INTENT(OUT) :: HRI ! average radiation index over time step DT + real(rk), INTENT(OUT) :: COSZEN ! average cosine of the zenith angle over time step DT ! Internal - real(summa_prec) :: CRAD ! conversion from degrees to radians - real(summa_prec) :: YRAD ! conversion from year to radians - real(summa_prec) :: T ! time from noon in radians - real(summa_prec) :: DELT1 ! time step in radians - real(summa_prec) :: SLOPE1 ! slope of ground surface in radians - real(summa_prec) :: AZI1 ! aspect (azimuth) of ground surface in radians - real(summa_prec) :: LAT1 ! latitude in radians - real(summa_prec) :: FJULIAN ! julian date as real - real(summa_prec) :: D ! solar declination - real(summa_prec) :: LP ! latitude adjusted for non-level surface (= LAT1 for level surface) - real(summa_prec) :: TD ! used to calculate sunrise/set - real(summa_prec) :: TPI ! used to calculate sunrise/set - real(summa_prec) :: TP ! used to calculate sunrise/set - real(summa_prec) :: DDT ! used to calculate sunrise/set(= 0 for level surface) - real(summa_prec) :: T1 ! first time in time step or sunrise - real(summa_prec) :: T2 ! last time in time step or sunset - real(summa_prec) :: AUX ! Auxiliary variable used to check whether the sunset/sunrise time calculation can succeed + real(rk) :: CRAD ! conversion from degrees to radians + real(rk) :: YRAD ! conversion from year to radians + real(rk) :: T ! time from noon in radians + real(rk) :: DELT1 ! time step in radians + real(rk) :: SLOPE1 ! slope of ground surface in radians + real(rk) :: AZI1 ! aspect (azimuth) of ground surface in radians + real(rk) :: LAT1 ! latitude in radians + real(rk) :: FJULIAN ! julian date as real + real(rk) :: D ! solar declination + real(rk) :: LP ! latitude adjusted for non-level surface (= LAT1 for level surface) + real(rk) :: TD ! used to calculate sunrise/set + real(rk) :: TPI ! used to calculate sunrise/set + real(rk) :: TP ! used to calculate sunrise/set + real(rk) :: DDT ! used to calculate sunrise/set(= 0 for level surface) + real(rk) :: T1 ! first time in time step or sunrise + real(rk) :: T2 ! last time in time step or sunset + real(rk) :: AUX ! Auxiliary variable used to check whether the sunset/sunrise time calculation can succeed ! ---------------------------------------------------------------------------------------- ! CONVERSION FACTORS ! degrees to radians @@ -99,7 +99,7 @@ SUBROUTINE CLRSKY_RAD(MONTH,DAY,HOUR,DT,SLOPE,AZI,LAT,HRI,COSZEN) ! In such cases AUX > 1 or AUX < -1. Fix AUX at (-)1 in those cases, to fix sunrise at 00.00 or 24.00 of the current day (instead of some time before/after the current day) AUX=-TAN(LAT1)*TAN(D) IF(abs(AUX) > 1.) THEN - TD=ACOS(SIGN(1._summa_prec, AUX)) + TD=ACOS(SIGN(1._rk, AUX)) ELSE TD=ACOS(AUX) END IF @@ -140,7 +140,7 @@ SUBROUTINE CLRSKY_RAD(MONTH,DAY,HOUR,DT,SLOPE,AZI,LAT,HRI,COSZEN) ! In such cases AUX > 1 or AUX < -1. Fix AUX at (-)1 in those cases AUX=-TAN(LAT1)*TAN(D) IF(abs(AUX) > 1.) THEN - TD=ACOS(SIGN(1._summa_prec, AUX)) + TD=ACOS(SIGN(1._rk, AUX)) ELSE TD=ACOS(AUX) END IF diff --git a/build/source/engine/systemSolv.f90 b/build/source/engine/systemSolv.f90 index 4ab21e3a4..b4a34edf2 100755 --- a/build/source/engine/systemSolv.f90 +++ b/build/source/engine/systemSolv.f90 @@ -98,10 +98,10 @@ module systemSolv_module public::systemSolv ! control parameters -real(summa_prec),parameter :: valueMissing=-9999._summa_prec ! missing value -real(summa_prec),parameter :: verySmall=1.e-12_summa_prec ! a very small number (used to check consistency) -real(summa_prec),parameter :: veryBig=1.e+20_summa_prec ! a very big number -real(summa_prec),parameter :: dx = 1.e-8_summa_prec ! finite difference increment +real(rk),parameter :: valueMissing=-9999._rk ! missing value +real(rk),parameter :: verySmall=1.e-12_rk ! a very small number (used to check consistency) +real(rk),parameter :: veryBig=1.e+20_rk ! a very big number +real(rk),parameter :: dx = 1.e-8_rk ! finite difference increment contains @@ -152,7 +152,7 @@ subroutine systemSolv(& ! * dummy variables ! --------------------------------------------------------------------------------------- ! input: model control - real(summa_prec),intent(in) :: dt ! time step (seconds) + real(rk),intent(in) :: dt ! time step (seconds) integer(i4b),intent(in) :: nState ! total number of state variables logical(lgt),intent(in) :: firstSubStep ! flag to indicate if we are processing the first sub-step logical(lgt),intent(inout) :: firstFluxCall ! flag to define the first flux call @@ -170,12 +170,12 @@ subroutine systemSolv(& type(var_dlength),intent(inout) :: flux_temp ! model fluxes for a local HRU type(var_dlength),intent(in) :: bvar_data ! model variables for the local basin type(model_options),intent(in) :: model_decisions(:) ! model decisions - real(summa_prec),intent(in) :: stateVecInit(:) ! initial state vector (mixed units) + real(rk),intent(in) :: stateVecInit(:) ! initial state vector (mixed units) ! output: model control type(var_dlength),intent(inout) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables integer(i4b),intent(inout) :: ixSaturation ! index of the lowest saturated layer (NOTE: only computed on the first iteration) - real(summa_prec),intent(out) :: untappedMelt(:) ! un-tapped melt energy (J m-3 s-1) - real(summa_prec),intent(out) :: stateVecTrial(:) ! trial state vector (mixed units) + real(rk),intent(out) :: untappedMelt(:) ! un-tapped melt energy (J m-3 s-1) + real(rk),intent(out) :: stateVecTrial(:) ! trial state vector (mixed units) logical(lgt),intent(out) :: reduceCoupledStep ! flag to reduce the length of the coupled step logical(lgt),intent(out) :: tooMuchMelt ! flag to denote that there was too much melt integer(i4b),intent(out) :: niter ! number of iterations taken @@ -193,11 +193,11 @@ subroutine systemSolv(& integer(i4b) :: iState ! index of model state integer(i4b) :: nLeadDim ! length of the leading dimension of the Jacobian matrix (nBands or nState) integer(i4b) :: local_ixGroundwater ! local index for groundwater representation - real(summa_prec) :: bulkDensity ! bulk density of a given layer (kg m-3) - real(summa_prec) :: volEnthalpy ! volumetric enthalpy of a given layer (J m-3) - real(summa_prec),parameter :: tempAccelerate=0.00_summa_prec ! factor to force initial canopy temperatures to be close to air temperature - real(summa_prec),parameter :: xMinCanopyWater=0.0001_summa_prec ! minimum value to initialize canopy water (kg m-2) - real(summa_prec),parameter :: tinyStep=0.000001_summa_prec ! stupidly small time step (s) + real(rk) :: bulkDensity ! bulk density of a given layer (kg m-3) + real(rk) :: volEnthalpy ! volumetric enthalpy of a given layer (J m-3) + real(rk),parameter :: tempAccelerate=0.00_rk ! factor to force initial canopy temperatures to be close to air temperature + real(rk),parameter :: xMinCanopyWater=0.0001_rk ! minimum value to initialize canopy water (kg m-2) + real(rk),parameter :: tinyStep=0.000001_rk ! stupidly small time step (s) ! ------------------------------------------------------------------------------------------------------ ! * model solver ! ------------------------------------------------------------------------------------------------------ @@ -207,22 +207,22 @@ subroutine systemSolv(& integer(i4b) :: localMaxIter ! maximum number of iterations (depends on solution type) integer(i4b), parameter :: scalarMaxIter=100 ! maximum number of iterations for the scalar solution type(var_dlength) :: flux_init ! model fluxes at the start of the time step - real(summa_prec),allocatable :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) ! NOTE: allocatable, since not always needed - real(summa_prec) :: stateVecNew(nState) ! new state vector (mixed units) - real(summa_prec) :: fluxVec0(nState) ! flux vector (mixed units) - real(summa_prec) :: fScale(nState) ! characteristic scale of the function evaluations (mixed units) - real(summa_prec) :: xScale(nState) ! characteristic scale of the state vector (mixed units) - real(summa_prec) :: dMat(nState) ! diagonal matrix (excludes flux derivatives) - real(summa_prec) :: sMul(nState) ! NOTE: qp ! multiplier for state vector for the residual calculations - real(summa_prec) :: rVec(nState) ! NOTE: qp ! residual vector - real(summa_prec) :: rAdd(nState) ! additional terms in the residual vector - real(summa_prec) :: fOld,fNew ! function values (-); NOTE: dimensionless because scaled - real(summa_prec) :: xMin,xMax ! state minimum and maximum (mixed units) + real(rk),allocatable :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) ! NOTE: allocatable, since not always needed + real(rk) :: stateVecNew(nState) ! new state vector (mixed units) + real(rk) :: fluxVec0(nState) ! flux vector (mixed units) + real(rk) :: fScale(nState) ! characteristic scale of the function evaluations (mixed units) + real(rk) :: xScale(nState) ! characteristic scale of the state vector (mixed units) + real(rk) :: dMat(nState) ! diagonal matrix (excludes flux derivatives) + real(rk) :: sMul(nState) ! NOTE: qp ! multiplier for state vector for the residual calculations + real(rk) :: rVec(nState) ! NOTE: qp ! residual vector + real(rk) :: rAdd(nState) ! additional terms in the residual vector + real(rk) :: fOld,fNew ! function values (-); NOTE: dimensionless because scaled + real(rk) :: xMin,xMax ! state minimum and maximum (mixed units) logical(lgt) :: converged ! convergence flag logical(lgt) :: feasible ! feasibility flag - real(summa_prec) :: resSinkNew(nState) ! additional terms in the residual vector - real(summa_prec) :: fluxVecNew(nState) ! new flux vector - real(summa_prec) :: resVecNew(nState) ! NOTE: qp ! new residual vector + real(rk) :: resSinkNew(nState) ! additional terms in the residual vector + real(rk) :: fluxVecNew(nState) ! new flux vector + real(rk) :: resVecNew(nState) ! NOTE: qp ! new residual vector ! --------------------------------------------------------------------------------------- ! point to variables in the data structures ! --------------------------------------------------------------------------------------- @@ -533,13 +533,13 @@ subroutine systemSolv(& ! ------------------ ! set untapped melt energy to zero - untappedMelt(:) = 0._summa_prec + untappedMelt(:) = 0._rk ! update temperatures (ensure new temperature is consistent with the fluxes) if(nSnowSoilNrg>0)then do concurrent (iLayer=1:nLayers,ixSnowSoilNrg(iLayer)/=integerMissing) ! (loop through non-missing energy state variables in the snow+soil domain) iState = ixSnowSoilNrg(iLayer) - stateVecTrial(iState) = stateVecInit(iState) + (fluxVecNew(iState)*dt + resSinkNew(iState))/real(sMul(iState), summa_prec) + stateVecTrial(iState) = stateVecInit(iState) + (fluxVecNew(iState)*dt + resSinkNew(iState))/real(sMul(iState), rk) end do ! looping through non-missing energy state variables in the snow+soil domain endif diff --git a/build/source/engine/tempAdjust.f90 b/build/source/engine/tempAdjust.f90 index 758f50431..21874d98d 100755 --- a/build/source/engine/tempAdjust.f90 +++ b/build/source/engine/tempAdjust.f90 @@ -65,7 +65,7 @@ subroutine tempAdjust(& implicit none ! ------------------------------------------------------------------------------------------------ ! input: derived parameters - real(summa_prec),intent(in) :: canopyDepth ! depth of the vegetation canopy (m) + real(rk),intent(in) :: canopyDepth ! depth of the vegetation canopy (m) ! input/output: data structures type(var_dlength),intent(in) :: mpar_data ! model parameters type(var_dlength),intent(inout) :: prog_data ! model prognostic variables for a local HRU @@ -78,13 +78,13 @@ subroutine tempAdjust(& integer(i4b) :: iTry ! trial index integer(i4b) :: iter ! iteration index integer(i4b),parameter :: maxiter=100 ! maximum number of iterations - real(summa_prec) :: fLiq ! fraction of liquid water (-) - real(summa_prec) :: tempMin,tempMax ! solution constraints for temperature (K) - real(summa_prec) :: nrgMeltFreeze ! energy required to melt-freeze the water to the current canopy temperature (J m-3) - real(summa_prec) :: scalarCanopyWat ! total canopy water (kg m-2) - real(summa_prec) :: scalarCanopyIceOld ! canopy ice content after melt-freeze to the initial temperature (kg m-2) - real(summa_prec),parameter :: resNrgToler=0.1_summa_prec ! tolerance for the energy residual (J m-3) - real(summa_prec) :: f1,f2,x1,x2,fTry,xTry,fDer,xInc ! iteration variables + real(rk) :: fLiq ! fraction of liquid water (-) + real(rk) :: tempMin,tempMax ! solution constraints for temperature (K) + real(rk) :: nrgMeltFreeze ! energy required to melt-freeze the water to the current canopy temperature (J m-3) + real(rk) :: scalarCanopyWat ! total canopy water (kg m-2) + real(rk) :: scalarCanopyIceOld ! canopy ice content after melt-freeze to the initial temperature (kg m-2) + real(rk),parameter :: resNrgToler=0.1_rk ! tolerance for the energy residual (J m-3) + real(rk) :: f1,f2,x1,x2,fTry,xTry,fDer,xInc ! iteration variables logical(lgt) :: fBis ! .true. if bisection ! ------------------------------------------------------------------------------------------------------------------------------- ! initialize error control @@ -120,7 +120,7 @@ subroutine tempAdjust(& ! compute the new volumetric ice content ! NOTE: new value; iterations will adjust this value for consistency with temperature - scalarCanopyIceOld = (1._summa_prec - fLiq)*scalarCanopyWat + scalarCanopyIceOld = (1._rk - fLiq)*scalarCanopyWat ! compute volumetric heat capacity of vegetation (J m-3 K-1) scalarBulkVolHeatCapVeg = specificHeatVeg*maxMassVegetation/canopyDepth + & ! vegetation component @@ -146,14 +146,14 @@ subroutine tempAdjust(& !print*, 'f1, f2 = ', f1, f2 ! ensure that we bracket the root - if(f1*f2 > 0._summa_prec)then + if(f1*f2 > 0._rk)then xInc = f1 / fDer - x2 = 1._summa_prec + x2 = 1._rk do iter=1,maxiter ! successively expand limit in order to bracket the root - x2 = x1 + sign(x2,xInc)*2._summa_prec + x2 = x1 + sign(x2,xInc)*2._rk f2 = resNrgFunc(x2,scalarCanopyTemp,scalarBulkVolHeatCapVeg,snowfrz_scale) - if(f1*f2 < 0._summa_prec)exit + if(f1*f2 < 0._rk)exit ! check that we bracketed the root ! (should get here in just a couple of expansions) if(iter==maxiter)then @@ -176,8 +176,8 @@ subroutine tempAdjust(& !print*, 'tempMin, tempMax = ', tempMin, tempMax ! get starting trial - xInc = huge(1._summa_prec) - xTry = 0.5_summa_prec*(x1 + x2) + xInc = huge(1._rk) + xTry = 0.5_rk*(x1 + x2) fTry = resNrgFunc(xTry,scalarCanopyTemp,scalarBulkVolHeatCapVeg,snowfrz_scale) fDer = resNrgDer(xTry,scalarBulkVolHeatCapVeg,snowfrz_scale) !print*, 'xTry = ', xTry @@ -194,7 +194,7 @@ subroutine tempAdjust(& ! bisect if out of range if(xTry <= tempMin .or. xTry >= tempMax)then - xTry = 0.5_summa_prec*(tempMin + tempMax) ! new value + xTry = 0.5_rk*(tempMin + tempMax) ! new value fBis = .true. ! value in range; use the newton step @@ -211,7 +211,7 @@ subroutine tempAdjust(& !print*, 'tempMin, tempMax = ', tempMin, tempMax ! update limits - if(fTry < 0._summa_prec)then + if(fTry < 0._rk)then tempMax = min(xTry,tempMax) else tempMin = max(tempMin,xTry) @@ -232,7 +232,7 @@ subroutine tempAdjust(& if(iter==maxiter)then ! (print out a 1-d x-section) do iTry=1,maxiter - xTry = 1.0_summa_prec*real(iTry,kind(1._summa_prec))/real(maxiter,kind(1._summa_prec)) + 272.5_summa_prec + xTry = 1.0_rk*real(iTry,kind(1._rk))/real(maxiter,kind(1._rk)) + 272.5_rk fTry = resNrgFunc(xTry,scalarCanopyTemp,scalarBulkVolHeatCapVeg,snowfrz_scale) write(*,'(a,1x,i4,1x,e20.10,1x,4(f20.10,1x))') 'iTry, fTry, xTry = ', iTry, fTry, xTry end do @@ -246,7 +246,7 @@ subroutine tempAdjust(& ! update state variables scalarCanopyTemp = xTry - scalarCanopyIce = (1._summa_prec - fracliquid(xTry,snowfrz_scale))*scalarCanopyWat + scalarCanopyIce = (1._rk - fracliquid(xTry,snowfrz_scale))*scalarCanopyWat scalarCanopyLiq = scalarCanopyWat - scalarCanopyIce ! end association to variables in the data structure @@ -261,13 +261,13 @@ subroutine tempAdjust(& function resNrgFunc(xTemp,xTemp0,bulkVolHeatCapVeg,snowfrz_scale) ! implicit none - real(summa_prec),intent(in) :: xTemp ! temperature (K) - real(summa_prec),intent(in) :: xTemp0 ! initial temperature (K) - real(summa_prec),intent(in) :: bulkVolHeatCapVeg ! volumetric heat capacity of veg (J m-3 K-1) - real(summa_prec),intent(in) :: snowfrz_scale ! scaling factor in freezing curve (K-1) - real(summa_prec) :: xIce ! canopy ice content (kg m-2) - real(summa_prec) :: resNrgFunc ! residual in energy (J m-3) - xIce = (1._summa_prec - fracliquid(xTemp,snowfrz_scale))*scalarCanopyWat + real(rk),intent(in) :: xTemp ! temperature (K) + real(rk),intent(in) :: xTemp0 ! initial temperature (K) + real(rk),intent(in) :: bulkVolHeatCapVeg ! volumetric heat capacity of veg (J m-3 K-1) + real(rk),intent(in) :: snowfrz_scale ! scaling factor in freezing curve (K-1) + real(rk) :: xIce ! canopy ice content (kg m-2) + real(rk) :: resNrgFunc ! residual in energy (J m-3) + xIce = (1._rk - fracliquid(xTemp,snowfrz_scale))*scalarCanopyWat resNrgFunc = -bulkVolHeatCapVeg*(xTemp - xTemp0) + LH_fus*(xIce - scalarCanopyIceOld)/canopyDepth + nrgMeltFreeze return end function resNrgFunc @@ -278,11 +278,11 @@ end function resNrgFunc ! ************************************************************************************************ function resNrgDer(xTemp,bulkVolHeatCapVeg,snowfrz_scale) implicit none - real(summa_prec),intent(in) :: xTemp ! temperature (K) - real(summa_prec),intent(in) :: bulkVolHeatCapVeg ! volumetric heat capacity of veg (J m-3 K-1) - real(summa_prec),intent(in) :: snowfrz_scale ! scaling factor in freezing curve (K-1) - real(summa_prec) :: dW_dT ! derivative in canopy ice content w.r.t. temperature (kg m-2 K-1) - real(summa_prec) :: resNrgDer ! derivative (J m-3 K-1) + real(rk),intent(in) :: xTemp ! temperature (K) + real(rk),intent(in) :: bulkVolHeatCapVeg ! volumetric heat capacity of veg (J m-3 K-1) + real(rk),intent(in) :: snowfrz_scale ! scaling factor in freezing curve (K-1) + real(rk) :: dW_dT ! derivative in canopy ice content w.r.t. temperature (kg m-2 K-1) + real(rk) :: resNrgDer ! derivative (J m-3 K-1) dW_dT = -scalarCanopyWat*dFracLiq_dTk(xTemp,snowfrz_scale) resNrgDer = bulkVolHeatCapVeg - dW_dT*LH_fus/canopyDepth return diff --git a/build/source/engine/time_utils.f90 b/build/source/engine/time_utils.f90 index 490a1621c..08bfcccdc 100755 --- a/build/source/engine/time_utils.f90 +++ b/build/source/engine/time_utils.f90 @@ -46,9 +46,9 @@ subroutine extractTime(refdate,iyyy,im,id,ih,imin,dsec,ih_tz,imin_tz,dsec_tz,err ! dummy variables character(*),intent(in) :: refdate ! units string (time since...) integer(i4b),intent(out) :: iyyy,im,id,ih,imin ! time (year/month/day/hour/minute) - real(summa_prec),intent(out) :: dsec ! seconds + real(rk),intent(out) :: dsec ! seconds integer(i4b),intent(out) :: ih_tz,imin_tz ! time zone information (hour/minute) - real(summa_prec),intent(out) :: dsec_tz ! time zone information (seconds) + real(rk),intent(out) :: dsec_tz ! time zone information (seconds) integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! local variables @@ -61,7 +61,7 @@ subroutine extractTime(refdate,iyyy,im,id,ih,imin,dsec,ih_tz,imin_tz,dsec_tz,err ! we'll parse each of these in order. ! Missing ih, imin, dsec, ih_tz, imin_tz and dsec_tz fields will be set to zero without causing an error. - ih=0; imin=0; dsec=0._summa_prec; ih_tz=0; imin_tz=0; dsec_tz=0._summa_prec; + ih=0; imin=0; dsec=0._rk; ih_tz=0; imin_tz=0; dsec_tz=0._rk; ! get the length of the string n = len_trim(refdate) @@ -121,8 +121,8 @@ subroutine extractTime(refdate,iyyy,im,id,ih,imin,dsec,ih_tz,imin_tz,dsec_tz,err if(ih > 24) then; err=20; message=trim(message)//'hour > 24'; return; end if if(imin < 0) then; err=20; message=trim(message)//'minute < 0'; return; end if if(imin > 60) then; err=20; message=trim(message)//'minute > 60'; return; end if - if(dsec < 0._summa_prec)then; err=20; message=trim(message)//'second < 0'; return; end if - if(dsec > 60._summa_prec)then; err=20; message=trim(message)//'second > 60'; return; end if + if(dsec < 0._rk)then; err=20; message=trim(message)//'second < 0'; return; end if + if(dsec > 60._rk)then; err=20; message=trim(message)//'second > 60'; return; end if ! FIELD 3: Advance to the ih_tz:imin_tz string istart=nsub+1 @@ -149,8 +149,8 @@ subroutine extractTime(refdate,iyyy,im,id,ih,imin,dsec,ih_tz,imin_tz,dsec_tz,err if(ih_tz > 12) then; err=20; message=trim(message)//'time zone hour > 12'; return; end if if(imin_tz < 0) then; err=20; message=trim(message)//'time zone minute < 0'; return; end if if(imin_tz > 60) then; err=20; message=trim(message)//'time zone minute > 60'; return; end if - if(dsec_tz < 0._summa_prec)then; err=20; message=trim(message)//'time zone second < 0'; return; end if - if(dsec_tz > 60._summa_prec)then; err=20; message=trim(message)//'time zone second > 60'; return; end if + if(dsec_tz < 0._rk)then; err=20; message=trim(message)//'time zone second < 0'; return; end if + if(dsec_tz > 60._rk)then; err=20; message=trim(message)//'time zone second > 60'; return; end if contains @@ -231,7 +231,7 @@ subroutine extract_hms(substring,cdelim,hh,mm,ss,err,message) ! output integer(i4b),intent(out) :: hh ! hour integer(i4b),intent(out) :: mm ! minute - real(summa_prec) ,intent(out) :: ss ! sec + real(rk) ,intent(out) :: ss ! sec integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! local variables @@ -272,16 +272,16 @@ subroutine compjulday(iyyy,mm,id,ih,imin,dsec,& ! input ! input variables integer(i4b),intent(in) :: iyyy,mm,id ! year, month, day integer(i4b),intent(in) :: ih,imin ! hour, minute - real(summa_prec),intent(in) :: dsec ! seconds + real(rk),intent(in) :: dsec ! seconds ! output - real(summa_prec),intent(out) :: juldayss + real(rk),intent(out) :: juldayss integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! local variables integer(i4b) :: julday ! julian day integer(i4b),parameter :: igreg=15+31*(10+12*1582) !IGREG = 588829 integer(i4b) :: ja,jm,jy - real(summa_prec) :: jfrac ! fraction of julian day + real(rk) :: jfrac ! fraction of julian day ! initialize errors err=0; message="juldayss" @@ -306,7 +306,7 @@ subroutine compjulday(iyyy,mm,id,ih,imin,dsec,& ! input jfrac = fracDay(ih, imin, dsec) ! and return the julian day, expressed in fraction of a day - juldayss = real(julday,kind(summa_prec)) + jfrac + juldayss = real(julday,kind(rk)) + jfrac end subroutine compjulday @@ -320,7 +320,7 @@ subroutine compcalday(julday, & !input implicit none ! input variables - real(summa_prec), intent(in) :: julday ! julian day + real(rk), intent(in) :: julday ! julian day ! output varibles integer(i4b), intent(out) :: iyyy ! year @@ -328,7 +328,7 @@ subroutine compcalday(julday, & !input integer(i4b), intent(out) :: id ! day integer(i4b), intent(out) :: ih ! hour integer(i4b), intent(out) :: imin ! minute - real(summa_prec), intent(out) :: dsec ! seconds + real(rk), intent(out) :: dsec ! seconds integer(i4b), intent(out) :: err ! error code character(*), intent(out) :: message ! error message @@ -345,14 +345,14 @@ subroutine compcalday(julday, & !input integer(i4b),parameter :: w = 2 integer(i4b),parameter :: b = 274277 integer(i4b),parameter :: c = -38 - real(summa_prec),parameter :: hr_per_day = 24.0_summa_prec - real(summa_prec),parameter :: min_per_hour = 60.0_summa_prec + real(rk),parameter :: hr_per_day = 24.0_rk + real(rk),parameter :: min_per_hour = 60.0_rk ! local variables integer(i4b) :: f,e,g,h ! various step variables from wikipedia integer(i4b) :: step_1a,step_1b,step_1c,step_1d ! temporary variables for calendar calculations - real(summa_prec) :: frac_day ! fractional day - real(summa_prec) :: remainder ! remainder of modulus operation + real(rk) :: frac_day ! fractional day + real(rk) :: remainder ! remainder of modulus operation ! initialize errors err=0; message="compcalday" @@ -402,7 +402,7 @@ end subroutine compcalday ! *************************************************************************************** function elapsedSec(startTime, endTime) integer(i4b),intent(in) :: startTime(8),endTime(8) ! state time and end time - real(summa_prec) :: elapsedSec ! elapsed time in seconds + real(rk) :: elapsedSec ! elapsed time in seconds ! local variables integer(i4b) :: elapsedDay ! elapsed full days integer(i4b) :: yy ! index of year @@ -411,7 +411,7 @@ function elapsedSec(startTime, endTime) integer(i4b) :: days2(12) = (/31,28,31,30,31,30,31,31,30,31,30,31/) ! calculate the elapsed time smaller than a day - elapsedSec = (endTime(8)-startTime(8))*.001_summa_prec + (endTime(7)-startTime(7)) + (endTime(6)-startTime(6))*secprmin + (endTime(5)-startTime(5))*secprhour + elapsedSec = (endTime(8)-startTime(8))*.001_rk + (endTime(7)-startTime(7)) + (endTime(6)-startTime(6))*secprmin + (endTime(5)-startTime(5))*secprhour ! check if the run is within the same day otherwise calculate how many days if (endTime(1) > startTime(1) .or. endTime(2) > startTime(2) .or. endTime(3) > startTime(3)) then @@ -440,11 +440,11 @@ end function elapsedSec ! *************************************************************************************** function fracDay(ih, imin, dsec) integer(i4b),intent(in) :: ih,imin ! hour, minute - real(summa_prec),intent(in) :: dsec ! seconds - real(summa_prec) :: fracDay ! fraction of a day + real(rk),intent(in) :: dsec ! seconds + real(rk) :: fracDay ! fraction of a day ! local variable - fracDay = (real(ih,kind(summa_prec))*secprhour + real(imin,kind(summa_prec))*secprmin + dsec) / secprday + fracDay = (real(ih,kind(rk))*secprhour + real(imin,kind(rk))*secprmin + dsec) / secprday if(ih < 0) fracDay=-fracDay return end function fracDay diff --git a/build/source/engine/updatState.f90 b/build/source/engine/updatState.f90 index 006e6b532..7d526bd5d 100755 --- a/build/source/engine/updatState.f90 +++ b/build/source/engine/updatState.f90 @@ -52,13 +52,13 @@ subroutine updateSnow(& USE snow_utils_module,only:fracliquid ! compute volumetric fraction of liquid water implicit none ! input variables - real(summa_prec),intent(in) :: mLayerTemp ! temperature (K) - real(summa_prec),intent(in) :: mLayerTheta ! volume fraction of total water (-) - real(summa_prec),intent(in) :: snowfrz_scale ! scaling parameter for the snow freezing curve (K-1) + real(rk),intent(in) :: mLayerTemp ! temperature (K) + real(rk),intent(in) :: mLayerTheta ! volume fraction of total water (-) + real(rk),intent(in) :: snowfrz_scale ! scaling parameter for the snow freezing curve (K-1) ! output variables - real(summa_prec),intent(out) :: mLayerVolFracLiq ! volumetric fraction of liquid water (-) - real(summa_prec),intent(out) :: mLayerVolFracIce ! volumetric fraction of ice (-) - real(summa_prec),intent(out) :: fLiq ! fraction of liquid water (-) + real(rk),intent(out) :: mLayerVolFracLiq ! volumetric fraction of liquid water (-) + real(rk),intent(out) :: mLayerVolFracIce ! volumetric fraction of ice (-) + real(rk),intent(out) :: fLiq ! fraction of liquid water (-) ! error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message @@ -68,7 +68,7 @@ subroutine updateSnow(& ! compute the volumetric fraction of liquid water and ice (-) fLiq = fracliquid(mLayerTemp,snowfrz_scale) mLayerVolFracLiq = fLiq*mLayerTheta - mLayerVolFracIce = (1._summa_prec - fLiq)*mLayerTheta*(iden_water/iden_ice) + mLayerVolFracIce = (1._rk - fLiq)*mLayerTheta*(iden_water/iden_ice) !print*, 'mLayerTheta - (mLayerVolFracIce*(iden_ice/iden_water) + mLayerVolFracLiq) = ', mLayerTheta - (mLayerVolFracIce*(iden_ice/iden_water) + mLayerVolFracLiq) !write(*,'(a,1x,4(f20.10,1x))') 'in updateSnow: fLiq, mLayerTheta, mLayerVolFracIce = ', & ! fLiq, mLayerTheta, mLayerVolFracIce @@ -98,23 +98,23 @@ subroutine updateSoil(& USE soil_utils_module,only:matricHead ! compute the matric head based on volumetric liquid water content implicit none ! input variables - real(summa_prec),intent(in) :: mLayerTemp ! estimate of temperature (K) - real(summa_prec),intent(in) :: mLayerMatricHead ! matric head (m) - real(summa_prec),intent(in) :: vGn_alpha ! van Genutchen "alpha" parameter - real(summa_prec),intent(in) :: vGn_n ! van Genutchen "n" parameter - real(summa_prec),intent(in) :: theta_sat ! soil porosity (-) - real(summa_prec),intent(in) :: theta_res ! soil residual volumetric water content (-) - real(summa_prec),intent(in) :: vGn_m ! van Genutchen "m" parameter (-) + real(rk),intent(in) :: mLayerTemp ! estimate of temperature (K) + real(rk),intent(in) :: mLayerMatricHead ! matric head (m) + real(rk),intent(in) :: vGn_alpha ! van Genutchen "alpha" parameter + real(rk),intent(in) :: vGn_n ! van Genutchen "n" parameter + real(rk),intent(in) :: theta_sat ! soil porosity (-) + real(rk),intent(in) :: theta_res ! soil residual volumetric water content (-) + real(rk),intent(in) :: vGn_m ! van Genutchen "m" parameter (-) ! output variables - real(summa_prec),intent(out) :: mLayerVolFracWat ! fractional volume of total water (-) - real(summa_prec),intent(out) :: mLayerVolFracLiq ! volumetric fraction of liquid water (-) - real(summa_prec),intent(out) :: mLayerVolFracIce ! volumetric fraction of ice (-) + real(rk),intent(out) :: mLayerVolFracWat ! fractional volume of total water (-) + real(rk),intent(out) :: mLayerVolFracLiq ! volumetric fraction of liquid water (-) + real(rk),intent(out) :: mLayerVolFracIce ! volumetric fraction of ice (-) integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! define local variables - real(summa_prec) :: TcSoil ! critical soil temperature when all water is unfrozen (K) - real(summa_prec) :: xConst ! constant in the freezing curve function (m K-1) - real(summa_prec) :: mLayerPsiLiq ! liquid water matric potential (m) + real(rk) :: TcSoil ! critical soil temperature when all water is unfrozen (K) + real(rk) :: xConst ! constant in the freezing curve function (m K-1) + real(rk) :: mLayerPsiLiq ! liquid water matric potential (m) ! initialize error control err=0; message="updateSoil/" @@ -124,7 +124,7 @@ subroutine updateSoil(& ! compute the critical soil temperature where all water is unfrozen (K) ! (eq 17 in Dall'Amico 2011) - TcSoil = Tfreeze + min(mLayerMatricHead,0._summa_prec)*gravity*Tfreeze/LH_fus ! (NOTE: J = kg m2 s-2, so LH_fus is in units of m2 s-2) + TcSoil = Tfreeze + min(mLayerMatricHead,0._rk)*gravity*Tfreeze/LH_fus ! (NOTE: J = kg m2 s-2, so LH_fus is in units of m2 s-2) ! *** compute volumetric fraction of liquid water and ice for partially frozen soil if(mLayerTemp < TcSoil)then ! (check if soil temperature is less than the critical temperature) @@ -145,7 +145,7 @@ subroutine updateSoil(& ! all water is unfrozen mLayerPsiLiq = mLayerMatricHead mLayerVolFracLiq = mLayerVolFracWat - mLayerVolFracIce = 0._summa_prec + mLayerVolFracIce = 0._rk end if ! (check if soil is partially frozen) diff --git a/build/source/engine/updateVars.f90 b/build/source/engine/updateVars.f90 index a6b1a1f61..3e1a70c2e 100755 --- a/build/source/engine/updateVars.f90 +++ b/build/source/engine/updateVars.f90 @@ -135,17 +135,17 @@ subroutine updateVars(& type(var_dlength),intent(inout) :: diag_data ! diagnostic variables for a local HRU type(var_dlength),intent(inout) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables ! output: variables for the vegetation canopy - real(summa_prec),intent(inout) :: scalarCanopyTempTrial ! trial value of canopy temperature (K) - real(summa_prec),intent(inout) :: scalarCanopyWatTrial ! trial value of canopy total water (kg m-2) - real(summa_prec),intent(inout) :: scalarCanopyLiqTrial ! trial value of canopy liquid water (kg m-2) - real(summa_prec),intent(inout) :: scalarCanopyIceTrial ! trial value of canopy ice content (kg m-2) + real(rk),intent(inout) :: scalarCanopyTempTrial ! trial value of canopy temperature (K) + real(rk),intent(inout) :: scalarCanopyWatTrial ! trial value of canopy total water (kg m-2) + real(rk),intent(inout) :: scalarCanopyLiqTrial ! trial value of canopy liquid water (kg m-2) + real(rk),intent(inout) :: scalarCanopyIceTrial ! trial value of canopy ice content (kg m-2) ! output: variables for the snow-soil domain - real(summa_prec),intent(inout) :: mLayerTempTrial(:) ! trial vector of layer temperature (K) - real(summa_prec),intent(inout) :: mLayerVolFracWatTrial(:) ! trial vector of volumetric total water content (-) - real(summa_prec),intent(inout) :: mLayerVolFracLiqTrial(:) ! trial vector of volumetric liquid water content (-) - real(summa_prec),intent(inout) :: mLayerVolFracIceTrial(:) ! trial vector of volumetric ice water content (-) - real(summa_prec),intent(inout) :: mLayerMatricHeadTrial(:) ! trial vector of total water matric potential (m) - real(summa_prec),intent(inout) :: mLayerMatricHeadLiqTrial(:) ! trial vector of liquid water matric potential (m) + real(rk),intent(inout) :: mLayerTempTrial(:) ! trial vector of layer temperature (K) + real(rk),intent(inout) :: mLayerVolFracWatTrial(:) ! trial vector of volumetric total water content (-) + real(rk),intent(inout) :: mLayerVolFracLiqTrial(:) ! trial vector of volumetric liquid water content (-) + real(rk),intent(inout) :: mLayerVolFracIceTrial(:) ! trial vector of volumetric ice water content (-) + real(rk),intent(inout) :: mLayerMatricHeadTrial(:) ! trial vector of total water matric potential (m) + real(rk),intent(inout) :: mLayerMatricHeadLiqTrial(:) ! trial vector of liquid water matric potential (m) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message @@ -160,29 +160,29 @@ subroutine updateVars(& logical(lgt) :: isCoupled ! .true. if a given variable shared another state variable in the same control volume logical(lgt) :: isNrgState ! .true. if a given variable is an energy state logical(lgt),allocatable :: computedCoupling(:) ! .true. if computed the coupling for a given state variable - real(summa_prec) :: scalarVolFracLiq ! volumetric fraction of liquid water (-) - real(summa_prec) :: scalarVolFracIce ! volumetric fraction of ice (-) - real(summa_prec) :: Tcrit ! critical soil temperature below which ice exists (K) - real(summa_prec) :: xTemp ! temporary temperature (K) - real(summa_prec) :: effSat ! effective saturation (-) - real(summa_prec) :: avPore ! available pore space (-) + real(rk) :: scalarVolFracLiq ! volumetric fraction of liquid water (-) + real(rk) :: scalarVolFracIce ! volumetric fraction of ice (-) + real(rk) :: Tcrit ! critical soil temperature below which ice exists (K) + real(rk) :: xTemp ! temporary temperature (K) + real(rk) :: effSat ! effective saturation (-) + real(rk) :: avPore ! available pore space (-) character(len=256) :: cMessage ! error message of downwind routine logical(lgt),parameter :: printFlag=.false. ! flag to turn on printing ! iterative solution for temperature - real(summa_prec) :: meltNrg ! energy for melt+freeze (J m-3) - real(summa_prec) :: residual ! residual in the energy equation (J m-3) - real(summa_prec) :: derivative ! derivative in the energy equation (J m-3 K-1) - real(summa_prec) :: tempInc ! iteration increment (K) + real(rk) :: meltNrg ! energy for melt+freeze (J m-3) + real(rk) :: residual ! residual in the energy equation (J m-3) + real(rk) :: derivative ! derivative in the energy equation (J m-3 K-1) + real(rk) :: tempInc ! iteration increment (K) integer(i4b) :: iter ! iteration index integer(i4b) :: niter ! number of iterations integer(i4b),parameter :: maxiter=100 ! maximum number of iterations - real(summa_prec),parameter :: nrgConvTol=1.e-4_summa_prec ! convergence tolerance for energy (J m-3) - real(summa_prec),parameter :: tempConvTol=1.e-6_summa_prec ! convergence tolerance for temperature (K) - real(summa_prec) :: critDiff ! temperature difference from critical (K) - real(summa_prec) :: tempMin ! minimum bracket for temperature (K) - real(summa_prec) :: tempMax ! maximum bracket for temperature (K) + real(rk),parameter :: nrgConvTol=1.e-4_rk ! convergence tolerance for energy (J m-3) + real(rk),parameter :: tempConvTol=1.e-6_rk ! convergence tolerance for temperature (K) + real(rk) :: critDiff ! temperature difference from critical (K) + real(rk) :: tempMin ! minimum bracket for temperature (K) + real(rk) :: tempMax ! maximum bracket for temperature (K) logical(lgt) :: bFlag ! flag to denote that iteration increment was constrained using bi-section - real(summa_prec),parameter :: epsT=1.e-7_summa_prec ! small interval above/below critical temperature (K) + real(rk),parameter :: epsT=1.e-7_rk ! small interval above/below critical temperature (K) ! -------------------------------------------------------------------------------------------------------------------------------- ! make association with variables in the data structures associate(& @@ -334,7 +334,7 @@ subroutine updateVars(& select case( ixStateType(ixFullVector) ) ! --> update the total water from the liquid water matric potential case(iname_lmpLayer) - effSat = volFracLiq(mLayerMatricHeadLiqTrial(ixControlIndex),vGn_alpha(ixControlIndex),0._summa_prec,1._summa_prec,vGn_n(ixControlIndex),vGn_m(ixControlIndex)) ! effective saturation + effSat = volFracLiq(mLayerMatricHeadLiqTrial(ixControlIndex),vGn_alpha(ixControlIndex),0._rk,1._rk,vGn_n(ixControlIndex),vGn_m(ixControlIndex)) ! effective saturation avPore = theta_sat(ixControlIndex) - mLayerVolFracIceTrial(iLayer) - theta_res(ixControlIndex) ! available pore space mLayerVolFracLiqTrial(iLayer) = effSat*avPore + theta_res(ixControlIndex) mLayerVolFracWatTrial(iLayer) = mLayerVolFracLiqTrial(iLayer) + mLayerVolFracIceTrial(iLayer) ! no volume expansion @@ -368,8 +368,8 @@ subroutine updateVars(& ! define brackets for the root ! NOTE: start with an enormous range; updated quickly in the iterations - tempMin = xTemp - 10._summa_prec - tempMax = xTemp + 10._summa_prec + tempMin = xTemp - 10._rk + tempMax = xTemp + 10._rk ! get iterations (set to maximum iterations if adjusting the temperature) niter = merge(maxiter, 1, do_adjustTemp) @@ -379,7 +379,7 @@ subroutine updateVars(& ! restrict temperature if(xTemp <= tempMin .or. xTemp >= tempMax)then - xTemp = 0.5_summa_prec*(tempMin + tempMax) ! new value + xTemp = 0.5_rk*(tempMin + tempMax) ! new value bFlag = .true. else bFlag = .false. @@ -394,7 +394,7 @@ subroutine updateVars(& ! NOTE 2: for case "iname_lmpLayer", dVolTot_dPsi0 = dVolLiq_dPsi if(ixDomainType==iname_soil)then select case( ixStateType(ixFullVector) ) - case(iname_lmpLayer); dVolTot_dPsi0(ixControlIndex) = dTheta_dPsi(mLayerMatricHeadLiqTrial(ixControlIndex),vGn_alpha(ixControlIndex),0._summa_prec,1._summa_prec,vGn_n(ixControlIndex),vGn_m(ixControlIndex))*avPore + case(iname_lmpLayer); dVolTot_dPsi0(ixControlIndex) = dTheta_dPsi(mLayerMatricHeadLiqTrial(ixControlIndex),vGn_alpha(ixControlIndex),0._rk,1._rk,vGn_n(ixControlIndex),vGn_m(ixControlIndex))*avPore case default; dVolTot_dPsi0(ixControlIndex) = dTheta_dPsi(mLayerMatricHeadTrial(ixControlIndex),vGn_alpha(ixControlIndex),theta_res(ixControlIndex),theta_sat(ixControlIndex),vGn_n(ixControlIndex),vGn_m(ixControlIndex)) end select endif @@ -412,8 +412,8 @@ subroutine updateVars(& ! --> unfrozen: no dependence of liquid water on temperature else select case(ixDomainType) - case(iname_veg); dTheta_dTkCanopy = 0._summa_prec - case(iname_snow, iname_soil); mLayerdTheta_dTk(iLayer) = 0._summa_prec + case(iname_veg); dTheta_dTkCanopy = 0._rk + case(iname_snow, iname_soil); mLayerdTheta_dTk(iLayer) = 0._rk case default; err=20; message=trim(message)//'expect case to be iname_veg, iname_snow, iname_soil'; return end select ! domain type endif @@ -461,7 +461,7 @@ subroutine updateVars(& ! compute mass of water on the canopy ! NOTE: possibilities for speed-up here scalarCanopyLiqTrial = scalarFracLiqVeg *scalarCanopyWatTrial - scalarCanopyIceTrial = (1._summa_prec - scalarFracLiqVeg)*scalarCanopyWatTrial + scalarCanopyIceTrial = (1._rk - scalarFracLiqVeg)*scalarCanopyWatTrial ! *** snow layers case(iname_snow) @@ -565,7 +565,7 @@ subroutine updateVars(& endif ! update bracket - if(residual < 0._summa_prec)then + if(residual < 0._rk)then tempMax = min(xTemp,tempMax) else tempMin = max(tempMin,xTemp) @@ -583,7 +583,7 @@ subroutine updateVars(& ! add constraints for snow temperature if(ixDomainType==iname_veg .or. ixDomainType==iname_snow)then - if(tempInc > Tcrit - xTemp) tempInc=(Tcrit - xTemp)*0.5_summa_prec ! simple bi-section method + if(tempInc > Tcrit - xTemp) tempInc=(Tcrit - xTemp)*0.5_rk ! simple bi-section method endif ! if the domain is vegetation or snow ! deal with the discontinuity between partially frozen and unfrozen soil @@ -591,7 +591,7 @@ subroutine updateVars(& ! difference from the temperature below which ice exists critDiff = Tcrit - xTemp ! --> initially frozen (T < Tcrit) - if(critDiff > 0._summa_prec)then + if(critDiff > 0._rk)then if(tempInc > critDiff) tempInc = critDiff + epsT ! set iteration increment to slightly above critical temperature ! --> initially unfrozen (T > Tcrit) else @@ -643,8 +643,8 @@ subroutine updateVars(& if(.not.isNrgState .and. .not.isCoupled)then ! derivatives relating liquid water matric potential to total water matric potential and temperature - dPsiLiq_dPsi0(ixControlIndex) = 1._summa_prec ! exact correspondence (psiLiq=psi0) - dPsiLiq_dTemp(ixControlIndex) = 0._summa_prec ! no relationship between liquid water matric potential and temperature + dPsiLiq_dPsi0(ixControlIndex) = 1._rk ! exact correspondence (psiLiq=psi0) + dPsiLiq_dTemp(ixControlIndex) = 0._rk ! no relationship between liquid water matric potential and temperature ! case of energy state or coupled solution else @@ -699,17 +699,17 @@ subroutine xTempSolve(& derivative ) ! intent(out) : derivative (J m-3 K-1) implicit none ! input: constant over iterations - real(summa_prec),intent(in) :: meltNrg ! energy for melt+freeze (J m-3) - real(summa_prec),intent(in) :: heatCap ! volumetric heat capacity (J m-3 K-1) - real(summa_prec),intent(in) :: tempInit ! initial temperature (K) - real(summa_prec),intent(in) :: volFracIceInit ! initial volumetric fraction of ice (-) + real(rk),intent(in) :: meltNrg ! energy for melt+freeze (J m-3) + real(rk),intent(in) :: heatCap ! volumetric heat capacity (J m-3 K-1) + real(rk),intent(in) :: tempInit ! initial temperature (K) + real(rk),intent(in) :: volFracIceInit ! initial volumetric fraction of ice (-) ! input-output: trial values - real(summa_prec),intent(inout) :: xTemp ! trial value for temperature - real(summa_prec),intent(in) :: dLiq_dT ! derivative in liquid water content w.r.t. temperature (K-1) - real(summa_prec),intent(in) :: volFracIceTrial ! trial value for the volumetric fraction of ice (-) + real(rk),intent(inout) :: xTemp ! trial value for temperature + real(rk),intent(in) :: dLiq_dT ! derivative in liquid water content w.r.t. temperature (K-1) + real(rk),intent(in) :: volFracIceTrial ! trial value for the volumetric fraction of ice (-) ! output: residual and derivative - real(summa_prec),intent(out) :: residual ! residual (J m-3) - real(summa_prec),intent(out) :: derivative ! derivative (J m-3 K-1) + real(rk),intent(out) :: residual ! residual (J m-3) + real(rk),intent(out) :: derivative ! derivative (J m-3 K-1) ! subroutine starts here residual = -heatCap*(xTemp - tempInit) + meltNrg*(volFracIceTrial - volFracIceInit) ! J m-3 derivative = heatCap + LH_fus*iden_water*dLiq_dT ! J m-3 K-1 diff --git a/build/source/engine/varSubstep.f90 b/build/source/engine/varSubstep.f90 index bb1b5a73e..1fa8eb971 100755 --- a/build/source/engine/varSubstep.f90 +++ b/build/source/engine/varSubstep.f90 @@ -73,7 +73,7 @@ module varSubstep_module public::varSubstep ! algorithmic parameters -real(summa_prec),parameter :: verySmall=1.e-6_summa_prec ! used as an additive constant to check if substantial difference among real numbers +real(rk),parameter :: verySmall=1.e-6_rk ! used as an additive constant to check if substantial difference among real numbers contains @@ -130,9 +130,9 @@ subroutine varSubstep(& ! * dummy variables ! --------------------------------------------------------------------------------------- ! input: model control - real(summa_prec),intent(in) :: dt ! time step (seconds) - real(summa_prec),intent(in) :: dtInit ! initial time step (seconds) - real(summa_prec),intent(in) :: dt_min ! minimum time step (seconds) + real(rk),intent(in) :: dt ! time step (seconds) + real(rk),intent(in) :: dtInit ! initial time step (seconds) + real(rk),intent(in) :: dt_min ! minimum time step (seconds) integer(i4b),intent(in) :: nState ! total number of state variables logical(lgt),intent(in) :: doAdjustTemp ! flag to indicate if we adjust the temperature logical(lgt),intent(in) :: firstSubStep ! flag to indicate if we are processing the first sub-step @@ -156,7 +156,7 @@ subroutine varSubstep(& type(var_dlength),intent(in) :: bvar_data ! model variables for the local basin ! output: model control integer(i4b),intent(inout) :: ixSaturation ! index of the lowest saturated layer (NOTE: only computed on the first iteration) - real(summa_prec),intent(out) :: dtMultiplier ! substep multiplier (-) + real(rk),intent(out) :: dtMultiplier ! substep multiplier (-) integer(i4b),intent(out) :: nSubsteps ! number of substeps taken for a given split logical(lgt),intent(out) :: failedMinimumStep ! flag to denote success of substepping for a given split logical(lgt),intent(out) :: reduceCoupledStep ! flag to denote need to reduce the length of the coupled step @@ -174,24 +174,24 @@ subroutine varSubstep(& integer(i4b) :: ixLayer ! index in a given domain integer(i4b), dimension(1) :: ixMin,ixMax ! bounds of a given flux vector ! time stepping - real(summa_prec) :: dtSum ! sum of time from successful steps (seconds) - real(summa_prec) :: dt_wght ! weight given to a given flux calculation - real(summa_prec) :: dtSubstep ! length of a substep (s) + real(rk) :: dtSum ! sum of time from successful steps (seconds) + real(rk) :: dt_wght ! weight given to a given flux calculation + real(rk) :: dtSubstep ! length of a substep (s) ! adaptive sub-stepping for the explicit solution logical(lgt) :: failedSubstep ! flag to denote success of substepping for a given split - real(summa_prec),parameter :: safety=0.85_summa_prec ! safety factor in adaptive sub-stepping - real(summa_prec),parameter :: reduceMin=0.1_summa_prec ! mimimum factor that time step is reduced - real(summa_prec),parameter :: increaseMax=4.0_summa_prec ! maximum factor that time step is increased + real(rk),parameter :: safety=0.85_rk ! safety factor in adaptive sub-stepping + real(rk),parameter :: reduceMin=0.1_rk ! mimimum factor that time step is reduced + real(rk),parameter :: increaseMax=4.0_rk ! maximum factor that time step is increased ! adaptive sub-stepping for the implicit solution integer(i4b) :: niter ! number of iterations taken integer(i4b),parameter :: n_inc=5 ! minimum number of iterations to increase time step integer(i4b),parameter :: n_dec=15 ! maximum number of iterations to decrease time step - real(summa_prec),parameter :: F_inc = 1.25_summa_prec ! factor used to increase time step - real(summa_prec),parameter :: F_dec = 0.90_summa_prec ! factor used to decrease time step + real(rk),parameter :: F_inc = 1.25_rk ! factor used to increase time step + real(rk),parameter :: F_dec = 0.90_rk ! factor used to decrease time step ! state and flux vectors - real(summa_prec) :: untappedMelt(nState) ! un-tapped melt energy (J m-3 s-1) - real(summa_prec) :: stateVecInit(nState) ! initial state vector (mixed units) - real(summa_prec) :: stateVecTrial(nState) ! trial state vector (mixed units) + real(rk) :: untappedMelt(nState) ! un-tapped melt energy (J m-3 s-1) + real(rk) :: stateVecInit(nState) ! initial state vector (mixed units) + real(rk) :: stateVecTrial(nState) ! trial state vector (mixed units) type(var_dlength) :: flux_temp ! temporary model fluxes ! flags logical(lgt) :: firstSplitOper ! flag to indicate if we are processing the first flux call in a splitting operation @@ -199,11 +199,11 @@ subroutine varSubstep(& logical(lgt) :: waterBalanceError ! flag to denote that there is a water balance error logical(lgt) :: nrgFluxModified ! flag to denote that the energy fluxes were modified ! energy fluxes - real(summa_prec) :: sumCanopyEvaporation ! sum of canopy evaporation/condensation (kg m-2 s-1) - real(summa_prec) :: sumLatHeatCanopyEvap ! sum of latent heat flux for evaporation from the canopy to the canopy air space (W m-2) - real(summa_prec) :: sumSenHeatCanopy ! sum of sensible heat flux from the canopy to the canopy air space (W m-2) - real(summa_prec) :: sumSoilCompress - real(summa_prec),allocatable :: sumLayerCompress(:) + real(rk) :: sumCanopyEvaporation ! sum of canopy evaporation/condensation (kg m-2 s-1) + real(rk) :: sumLatHeatCanopyEvap ! sum of latent heat flux for evaporation from the canopy to the canopy air space (W m-2) + real(rk) :: sumSenHeatCanopy ! sum of sensible heat flux from the canopy to the canopy air space (W m-2) + real(rk) :: sumSoilCompress + real(rk),allocatable :: sumLayerCompress(:) ! --------------------------------------------------------------------------------------- ! point to variables in the data structures ! --------------------------------------------------------------------------------------- @@ -255,17 +255,17 @@ subroutine varSubstep(& end do ! initialize the total energy fluxes (modified in updateProg) - sumCanopyEvaporation = 0._summa_prec ! canopy evaporation/condensation (kg m-2 s-1) - sumLatHeatCanopyEvap = 0._summa_prec ! latent heat flux for evaporation from the canopy to the canopy air space (W m-2) - sumSenHeatCanopy = 0._summa_prec ! sensible heat flux from the canopy to the canopy air space (W m-2) - sumSoilCompress = 0._summa_prec ! total soil compression - allocate(sumLayerCompress(nSoil)); sumLayerCompress = 0._summa_prec ! soil compression by layer + sumCanopyEvaporation = 0._rk ! canopy evaporation/condensation (kg m-2 s-1) + sumLatHeatCanopyEvap = 0._rk ! latent heat flux for evaporation from the canopy to the canopy air space (W m-2) + sumSenHeatCanopy = 0._rk ! sensible heat flux from the canopy to the canopy air space (W m-2) + sumSoilCompress = 0._rk ! total soil compression + allocate(sumLayerCompress(nSoil)); sumLayerCompress = 0._rk ! soil compression by layer ! define the first flux call in a splitting operation firstSplitOper = (.not.scalarSolution .or. iStateSplit==1) ! initialize subStep - dtSum = 0._summa_prec ! keep track of the portion of the time step that is completed + dtSum = 0._rk ! keep track of the portion of the time step that is completed nSubsteps = 0 ! loop through substeps @@ -351,7 +351,7 @@ subroutine varSubstep(& ! reduce step based on failure if(failedSubstep)then err=0; message='varSubstep/' ! recover from failed convergence - dtMultiplier = 0.5_summa_prec ! system failure: step halving + dtMultiplier = 0.5_rk ! system failure: step halving else ! ** implicit Euler: adjust step length based on iteration count @@ -360,7 +360,7 @@ subroutine varSubstep(& elseif(niter>n_dec)then dtMultiplier = F_dec else - dtMultiplier = 1._summa_prec + dtMultiplier = 1._rk endif endif ! switch between failure and success @@ -420,7 +420,7 @@ subroutine varSubstep(& ! modify step err=0 ! error recovery - dtSubstep = dtSubstep/2._summa_prec + dtSubstep = dtSubstep/2._rk ! check minimum: fail minimum step if there is an error in the update if(dtSubstep next, remove canopy evaporation -- put the unsatisfied evap into sensible heat canopyBalance1 = canopyBalance1 + scalarCanopyEvaporation*dt - if(canopyBalance1 < 0._summa_prec)then + if(canopyBalance1 < 0._rk)then ! * get superfluous water and energy superflousWat = -canopyBalance1/dt ! kg m-2 s-1 superflousNrg = superflousWat*LH_vap ! W m-2 (J m-2 s-1) ! * update fluxes and states - canopyBalance1 = 0._summa_prec + canopyBalance1 = 0._rk scalarCanopyEvaporation = scalarCanopyEvaporation + superflousWat scalarLatHeatCanopyEvap = scalarLatHeatCanopyEvap + superflousNrg scalarSenHeatCanopy = scalarSenHeatCanopy - superflousNrg @@ -766,9 +766,9 @@ subroutine updateProg(dt,nSnow,nSoil,nLayers,doAdjustTemp,computeVegFlux,untappe ! --> next, remove canopy drainage canopyBalance1 = canopyBalance1 - scalarCanopyLiqDrainage*dt - if(canopyBalance1 < 0._summa_prec)then + if(canopyBalance1 < 0._rk)then superflousWat = -canopyBalance1/dt ! kg m-2 s-1 - canopyBalance1 = 0._summa_prec + canopyBalance1 = 0._rk scalarCanopyLiqDrainage = scalarCanopyLiqDrainage + superflousWat endif @@ -795,7 +795,7 @@ subroutine updateProg(dt,nSnow,nSoil,nLayers,doAdjustTemp,computeVegFlux,untappe !write(*,'(a,1x,f20.10)') 'scalarCanopyEvaporation*dt = ', scalarCanopyEvaporation*dt !write(*,'(a,1x,f20.10)') 'scalarThroughfallRain*dt = ', scalarThroughfallRain*dt !write(*,'(a,1x,f20.10)') 'liqError = ', liqError - if(abs(liqError) > absConvTol_liquid*10._summa_prec)then ! *10 because of precision issues + if(abs(liqError) > absConvTol_liquid*10._rk)then ! *10 because of precision issues waterBalanceError = .true. return endif ! if there is a water balance error @@ -810,7 +810,7 @@ subroutine updateProg(dt,nSnow,nSoil,nLayers,doAdjustTemp,computeVegFlux,untappe baseSink = sum(mLayerBaseflow)*dt ! m s-1 --> m compSink = sum(mLayerCompress(1:nSoil) * mLayerDepth(nSnow+1:nLayers) ) ! dimensionless --> m liqError = soilBalance1 - (soilBalance0 + vertFlux + tranSink - baseSink - compSink) - if(abs(liqError) > absConvTol_liquid*10._summa_prec)then ! *10 because of precision issues + if(abs(liqError) > absConvTol_liquid*10._rk)then ! *10 because of precision issues !write(*,'(a,1x,f20.10)') 'dt = ', dt !write(*,'(a,1x,f20.10)') 'soilBalance0 = ', soilBalance0 !write(*,'(a,1x,f20.10)') 'soilBalance1 = ', soilBalance1 @@ -870,15 +870,15 @@ subroutine updateProg(dt,nSnow,nSoil,nLayers,doAdjustTemp,computeVegFlux,untappe ! *** ice ! --> check if we removed too much water - if(scalarCanopyIceTrial < 0._summa_prec .or. any(mLayerVolFracIceTrial < 0._summa_prec) )then + if(scalarCanopyIceTrial < 0._rk .or. any(mLayerVolFracIceTrial < 0._rk) )then ! ** ! canopy within numerical precision - if(scalarCanopyIceTrial < 0._summa_prec)then + if(scalarCanopyIceTrial < 0._rk)then if(scalarCanopyIceTrial > -verySmall)then scalarCanopyLiqTrial = scalarCanopyLiqTrial - scalarCanopyIceTrial - scalarCanopyIceTrial = 0._summa_prec + scalarCanopyIceTrial = 0._rk ! encountered an inconsistency: spit the dummy else @@ -897,11 +897,11 @@ subroutine updateProg(dt,nSnow,nSoil,nLayers,doAdjustTemp,computeVegFlux,untappe do iState=1,size(mLayerVolFracIceTrial) ! snow layer within numerical precision - if(mLayerVolFracIceTrial(iState) < 0._summa_prec)then + if(mLayerVolFracIceTrial(iState) < 0._rk)then if(mLayerVolFracIceTrial(iState) > -verySmall)then mLayerVolFracLiqTrial(iState) = mLayerVolFracLiqTrial(iState) - mLayerVolFracIceTrial(iState) - mLayerVolFracIceTrial(iState) = 0._summa_prec + mLayerVolFracIceTrial(iState) = 0._rk ! encountered an inconsistency: spit the dummy else @@ -924,15 +924,15 @@ subroutine updateProg(dt,nSnow,nSoil,nLayers,doAdjustTemp,computeVegFlux,untappe ! *** liquid water ! --> check if we removed too much water - if(scalarCanopyLiqTrial < 0._summa_prec .or. any(mLayerVolFracLiqTrial < 0._summa_prec) )then + if(scalarCanopyLiqTrial < 0._rk .or. any(mLayerVolFracLiqTrial < 0._rk) )then ! ** ! canopy within numerical precision - if(scalarCanopyLiqTrial < 0._summa_prec)then + if(scalarCanopyLiqTrial < 0._rk)then if(scalarCanopyLiqTrial > -verySmall)then scalarCanopyIceTrial = scalarCanopyIceTrial - scalarCanopyLiqTrial - scalarCanopyLiqTrial = 0._summa_prec + scalarCanopyLiqTrial = 0._rk ! encountered an inconsistency: spit the dummy else @@ -951,11 +951,11 @@ subroutine updateProg(dt,nSnow,nSoil,nLayers,doAdjustTemp,computeVegFlux,untappe do iState=1,size(mLayerVolFracLiqTrial) ! snow layer within numerical precision - if(mLayerVolFracLiqTrial(iState) < 0._summa_prec)then + if(mLayerVolFracLiqTrial(iState) < 0._rk)then if(mLayerVolFracLiqTrial(iState) > -verySmall)then mLayerVolFracIceTrial(iState) = mLayerVolFracIceTrial(iState) - mLayerVolFracLiqTrial(iState) - mLayerVolFracLiqTrial(iState) = 0._summa_prec + mLayerVolFracLiqTrial(iState) = 0._rk ! encountered an inconsistency: spit the dummy else diff --git a/build/source/engine/var_derive.f90 b/build/source/engine/var_derive.f90 index 85f369fc4..921dec335 100755 --- a/build/source/engine/var_derive.f90 +++ b/build/source/engine/var_derive.f90 @@ -117,7 +117,7 @@ subroutine calcHeight(& ! loop through layers do iLayer=1,nLayers ! compute the height at the layer midpoint - mLayerHeight(iLayer) = iLayerHeight(iLayer-1) + mLayerDepth(iLayer)/2._summa_prec + mLayerHeight(iLayer) = iLayerHeight(iLayer-1) + mLayerDepth(iLayer)/2._rk ! compute the height at layer interfaces iLayerHeight(iLayer) = iLayerHeight(iLayer-1) + mLayerDepth(iLayer) end do ! (looping through layers) @@ -149,10 +149,10 @@ subroutine rootDensty(mpar_data,indx_data,prog_data,diag_data,err,message) character(*),intent(out) :: message ! error message ! declare local variables integer(i4b) :: iLayer ! loop through layers - real(summa_prec) :: fracRootLower ! fraction of the rooting depth at the lower interface - real(summa_prec) :: fracRootUpper ! fraction of the rooting depth at the upper interface - real(summa_prec), parameter :: rootTolerance = 0.05_summa_prec ! tolerance for error in doubleExp rooting option - real(summa_prec) :: error ! machine precision error in rooting distribution + real(rk) :: fracRootLower ! fraction of the rooting depth at the lower interface + real(rk) :: fracRootUpper ! fraction of the rooting depth at the upper interface + real(rk), parameter :: rootTolerance = 0.05_rk ! tolerance for error in doubleExp rooting option + real(rk) :: error ! machine precision error in rooting distribution ! initialize error control err=0; message='rootDensty/' @@ -192,16 +192,16 @@ subroutine rootDensty(mpar_data,indx_data,prog_data,diag_data,err,message) if(iLayerHeight(iLayer-1)1._summa_prec) fracRootUpper=1._summa_prec + if(fracRootUpper>1._rk) fracRootUpper=1._rk ! compute the root density mLayerRootDensity(iLayer-nSnow) = fracRootUpper**rootDistExp - fracRootLower**rootDistExp else - mLayerRootDensity(iLayer-nSnow) = 0._summa_prec + mLayerRootDensity(iLayer-nSnow) = 0._rk end if !write(*,'(a,10(f11.5,1x))') 'mLayerRootDensity(iLayer-nSnow), fracRootUpper, fracRootLower = ', & ! mLayerRootDensity(iLayer-nSnow), fracRootUpper, fracRootLower @@ -209,8 +209,8 @@ subroutine rootDensty(mpar_data,indx_data,prog_data,diag_data,err,message) ! ** option 2: double expoential profile of Zeng et al. (JHM 2001) case(doubleExp) ! compute the cumulative fraction of roots at the top and bottom of the layer - fracRootLower = 1._summa_prec - 0.5_summa_prec*(exp(-iLayerHeight(iLayer-1)*rootScaleFactor1) + exp(-iLayerHeight(iLayer-1)*rootScaleFactor2) ) - fracRootUpper = 1._summa_prec - 0.5_summa_prec*(exp(-iLayerHeight(iLayer )*rootScaleFactor1) + exp(-iLayerHeight(iLayer )*rootScaleFactor2) ) + fracRootLower = 1._rk - 0.5_rk*(exp(-iLayerHeight(iLayer-1)*rootScaleFactor1) + exp(-iLayerHeight(iLayer-1)*rootScaleFactor2) ) + fracRootUpper = 1._rk - 0.5_rk*(exp(-iLayerHeight(iLayer )*rootScaleFactor1) + exp(-iLayerHeight(iLayer )*rootScaleFactor2) ) ! compute the root density mLayerRootDensity(iLayer-nSnow) = fracRootUpper - fracRootLower !write(*,'(a,10(f11.5,1x))') 'mLayerRootDensity(iLayer-nSnow), fracRootUpper, fracRootLower = ', & @@ -225,26 +225,26 @@ subroutine rootDensty(mpar_data,indx_data,prog_data,diag_data,err,message) ! check that root density is within some reaosnable version of machine tolerance ! This is the case when root density is greater than 1. Can only happen with powerLaw option. - error = sum(mLayerRootDensity) - 1._summa_prec - if (error > 2._summa_prec*epsilon(rootingDepth)) then + error = sum(mLayerRootDensity) - 1._rk + if (error > 2._rk*epsilon(rootingDepth)) then message=trim(message)//'problem with the root density calaculation' err=20; return else - mLayerRootDensity = mLayerRootDensity - error/real(nSoil,kind(summa_prec)) + mLayerRootDensity = mLayerRootDensity - error/real(nSoil,kind(rk)) end if ! compute fraction of roots in the aquifer - if(sum(mLayerRootDensity) < 1._summa_prec)then - scalarAquiferRootFrac = 1._summa_prec - sum(mLayerRootDensity) + if(sum(mLayerRootDensity) < 1._rk)then + scalarAquiferRootFrac = 1._rk - sum(mLayerRootDensity) else - scalarAquiferRootFrac = 0._summa_prec + scalarAquiferRootFrac = 0._rk end if ! check that roots in the aquifer are appropriate - if ((ixGroundwater /= bigBucket).and.(scalarAquiferRootFrac > 2._summa_prec*epsilon(rootingDepth)))then + if ((ixGroundwater /= bigBucket).and.(scalarAquiferRootFrac > 2._rk*epsilon(rootingDepth)))then if(scalarAquiferRootFrac < rootTolerance) then - mLayerRootDensity = mLayerRootDensity + scalarAquiferRootFrac/real(nSoil, kind(summa_prec)) - scalarAquiferRootFrac = 0._summa_prec + mLayerRootDensity = mLayerRootDensity + scalarAquiferRootFrac/real(nSoil, kind(rk)) + scalarAquiferRootFrac = 0._rk else select case(ixRootProfile) case(powerLaw); message=trim(message)//'roots in the aquifer only allowed for the big bucket gw parameterization: check that rooting depth < soil depth' @@ -274,8 +274,8 @@ subroutine satHydCond(mpar_data,indx_data,prog_data,flux_data,err,message) character(*),intent(out) :: message ! error message ! declare local variables integer(i4b) :: iLayer ! loop through layers - real(summa_prec) :: ifcDepthScaleFactor ! depth scaling factor (layer interfaces) - real(summa_prec) :: midDepthScaleFactor ! depth scaling factor (layer midpoints) + real(rk) :: ifcDepthScaleFactor ! depth scaling factor (layer interfaces) + real(rk) :: midDepthScaleFactor ! depth scaling factor (layer midpoints) ! initialize error control err=0; message='satHydCond/' ! ---------------------------------------------------------------------------------- @@ -315,7 +315,7 @@ subroutine satHydCond(mpar_data,indx_data,prog_data,flux_data,err,message) if(iLayer==nLayers)then iLayerSatHydCond(iLayer-nSnow) = k_soil(nSoil) else - iLayerSatHydCond(iLayer-nSnow) = 0.5_summa_prec * (k_soil(iLayer-nSnow) + k_soil(iLayer+1-nSnow) ) + iLayerSatHydCond(iLayer-nSnow) = 0.5_rk * (k_soil(iLayer-nSnow) + k_soil(iLayer+1-nSnow) ) endif ! - conductivity at layer midpoints mLayerSatHydCond(iLayer-nSnow) = k_soil(iLayer-nSnow) @@ -327,11 +327,11 @@ subroutine satHydCond(mpar_data,indx_data,prog_data,flux_data,err,message) ! - conductivity at layer interfaces ! --> NOTE: Do we need a weighted average based on layer depth for interior layers? - if(compactedDepth/iLayerHeight(nLayers) /= 1._summa_prec) then ! avoid divide by zero - ifcDepthScaleFactor = ( (1._summa_prec - iLayerHeight(iLayer)/iLayerHeight(nLayers))**(zScale_TOPMODEL - 1._summa_prec) ) / & - ( (1._summa_prec - compactedDepth/iLayerHeight(nLayers))**(zScale_TOPMODEL - 1._summa_prec) ) + if(compactedDepth/iLayerHeight(nLayers) /= 1._rk) then ! avoid divide by zero + ifcDepthScaleFactor = ( (1._rk - iLayerHeight(iLayer)/iLayerHeight(nLayers))**(zScale_TOPMODEL - 1._rk) ) / & + ( (1._rk - compactedDepth/iLayerHeight(nLayers))**(zScale_TOPMODEL - 1._rk) ) else - ifcDepthScaleFactor = 1.0_summa_prec + ifcDepthScaleFactor = 1.0_rk endif if(iLayer==nSnow)then iLayerSatHydCond(iLayer-nSnow) = k_soil(1) * ifcDepthScaleFactor @@ -339,14 +339,14 @@ subroutine satHydCond(mpar_data,indx_data,prog_data,flux_data,err,message) if(iLayer==nLayers)then iLayerSatHydCond(iLayer-nSnow) = k_soil(nSoil) * ifcDepthScaleFactor else - iLayerSatHydCond(iLayer-nSnow) = 0.5_summa_prec * (k_soil(iLayer-nSnow) + k_soil(iLayer+1-nSnow) ) * ifcDepthScaleFactor + iLayerSatHydCond(iLayer-nSnow) = 0.5_rk * (k_soil(iLayer-nSnow) + k_soil(iLayer+1-nSnow) ) * ifcDepthScaleFactor endif ! - conductivity at layer midpoints - if(compactedDepth/iLayerHeight(nLayers) /= 1._summa_prec) then ! avoid divide by zero - midDepthScaleFactor = ( (1._summa_prec - mLayerHeight(iLayer)/iLayerHeight(nLayers))**(zScale_TOPMODEL - 1._summa_prec) ) / & - ( (1._summa_prec - compactedDepth/iLayerHeight(nLayers))**(zScale_TOPMODEL - 1._summa_prec) ) + if(compactedDepth/iLayerHeight(nLayers) /= 1._rk) then ! avoid divide by zero + midDepthScaleFactor = ( (1._rk - mLayerHeight(iLayer)/iLayerHeight(nLayers))**(zScale_TOPMODEL - 1._rk) ) / & + ( (1._rk - compactedDepth/iLayerHeight(nLayers))**(zScale_TOPMODEL - 1._rk) ) else - midDepthScaleFactor = 1.0_summa_prec + midDepthScaleFactor = 1.0_rk endif mLayerSatHydCond(iLayer-nSnow) = k_soil(iLayer-nSnow) * midDepthScaleFactor mLayerSatHydCondMP(iLayer-nSnow) = k_macropore(iLayer-nSnow) * midDepthScaleFactor @@ -384,21 +384,21 @@ subroutine fracFuture(bpar_data,bvar_data,err,message) implicit none ! input variables - real(summa_prec),intent(in) :: bpar_data(:) ! vector of basin-average model parameters + real(rk),intent(in) :: bpar_data(:) ! vector of basin-average model parameters ! output variables type(var_dlength),intent(inout) :: bvar_data ! data structure of basin-average model variables integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! internal - real(summa_prec) :: dt ! data time step (s) + real(rk) :: dt ! data time step (s) integer(i4b) :: nTDH ! number of points in the time-delay histogram integer(i4b) :: iFuture ! index in time delay histogram - real(summa_prec) :: aLambda ! scale parameter in the Gamma distribution - real(summa_prec) :: tFuture ! future time (end of step) - real(summa_prec) :: pSave ! cumulative probability at the start of the step - real(summa_prec) :: cumProb ! cumulative probability at the end of the step - real(summa_prec) :: sumFrac ! sum of runoff fractions in all steps - real(summa_prec),parameter :: tolerFrac=0.01_summa_prec ! tolerance for missing fractional runoff by truncating histogram + real(rk) :: aLambda ! scale parameter in the Gamma distribution + real(rk) :: tFuture ! future time (end of step) + real(rk) :: pSave ! cumulative probability at the start of the step + real(rk) :: cumProb ! cumulative probability at the end of the step + real(rk) :: sumFrac ! sum of runoff fractions in all steps + real(rk),parameter :: tolerFrac=0.01_rk ! tolerance for missing fractional runoff by truncating histogram ! initialize error control err=0; message='fracFuture/' ! ---------------------------------------------------------------------------------- @@ -419,22 +419,22 @@ subroutine fracFuture(bpar_data,bvar_data,err,message) nTDH = size(runoffFuture) ! initialize runoffFuture (will be overwritten by initial conditions file values if present) - runoffFuture(1:nTDH) = 0._summa_prec + runoffFuture(1:nTDH) = 0._rk ! select option for sub-grid routing select case(ixRouting) ! ** instantaneous routing case(qInstant) - fractionFuture(1) = 1._summa_prec - fractionFuture(2:nTDH) = 0._summa_prec + fractionFuture(1) = 1._rk + fractionFuture(2:nTDH) = 0._rk ! ** time delay histogram case(timeDelay) ! initialize - pSave = 0._summa_prec ! cumulative probability at the start of the step + pSave = 0._rk ! cumulative probability at the start of the step aLambda = routingGammaShape / routingGammaScale - if(routingGammaShape <= 0._summa_prec .or. aLambda < 0._summa_prec)then + if(routingGammaShape <= 0._rk .or. aLambda < 0._rk)then message=trim(message)//'bad arguments for the Gamma distribution' err=20; return end if @@ -443,19 +443,19 @@ subroutine fracFuture(bpar_data,bvar_data,err,message) ! get weight for a given bin tFuture = real(iFuture, kind(dt))*dt ! future time (end of step) cumProb = gammp(routingGammaShape,aLambda*tFuture) ! cumulative probability at the end of the step - fractionFuture(iFuture) = max(0._summa_prec, cumProb - pSave) ! fraction of runoff in the current step + fractionFuture(iFuture) = max(0._rk, cumProb - pSave) ! fraction of runoff in the current step pSave = cumProb ! save the cumulative probability for use in the next step !write(*,'(a,1x,i4,1x,3(f20.10,1x))') trim(message), iFuture, tFuture, cumProb, fractionFuture(iFuture) ! set remaining bins to zero if(fractionFuture(iFuture) < tiny(dt))then - fractionFuture(iFuture:nTDH) = 0._summa_prec + fractionFuture(iFuture:nTDH) = 0._rk exit end if end do ! (looping through future time steps) ! check that we have enough bins sumFrac = sum(fractionFuture) - if(abs(1._summa_prec - sumFrac) > tolerFrac)then + if(abs(1._rk - sumFrac) > tolerFrac)then write(*,*) 'fraction of basin runoff histogram being accounted for by time delay vector is ', sumFrac write(*,*) 'this is less than allowed by tolerFrac = ', tolerFrac message=trim(message)//'not enough bins for the time delay histogram -- fix hard-coded parameter in globalData.f90' @@ -497,7 +497,7 @@ subroutine v_shortcut(mpar_data,diag_data,err,message) ! ---------------------------------------------------------------------------------- ! compute the van Genutchen "m" parameter - vGn_m = 1._summa_prec - 1._summa_prec/vGn_n + vGn_m = 1._rk - 1._rk/vGn_n end associate end subroutine v_shortcut diff --git a/build/source/engine/vegLiqFlux.f90 b/build/source/engine/vegLiqFlux.f90 index 9ca8b511b..854f4526c 100755 --- a/build/source/engine/vegLiqFlux.f90 +++ b/build/source/engine/vegLiqFlux.f90 @@ -67,16 +67,16 @@ subroutine vegLiqFlux(& implicit none ! input logical(lgt),intent(in) :: computeVegFlux ! flag to indicate if we are computing fluxes over vegetation (.false. means veg is buried with snow) - real(summa_prec),intent(in) :: scalarCanopyLiqTrial ! trial mass of liquid water on the vegetation canopy at the current iteration (kg m-2) - real(summa_prec),intent(in) :: scalarRainfall ! rainfall (kg m-2 s-1) + real(rk),intent(in) :: scalarCanopyLiqTrial ! trial mass of liquid water on the vegetation canopy at the current iteration (kg m-2) + real(rk),intent(in) :: scalarRainfall ! rainfall (kg m-2 s-1) ! input-output: data structures type(var_dlength),intent(in) :: mpar_data ! model parameters type(var_dlength),intent(inout) :: diag_data ! model diagnostic variables for the local basin ! output - real(summa_prec),intent(out) :: scalarThroughfallRain ! rain that reaches the ground without ever touching the canopy (kg m-2 s-1) - real(summa_prec),intent(out) :: scalarCanopyLiqDrainage ! drainage of liquid water from the vegetation canopy (kg m-2 s-1) - real(summa_prec),intent(out) :: scalarThroughfallRainDeriv ! derivative in throughfall w.r.t. canopy liquid water (s-1) - real(summa_prec),intent(out) :: scalarCanopyLiqDrainageDeriv ! derivative in canopy drainage w.r.t. canopy liquid water (s-1) + real(rk),intent(out) :: scalarThroughfallRain ! rain that reaches the ground without ever touching the canopy (kg m-2 s-1) + real(rk),intent(out) :: scalarCanopyLiqDrainage ! drainage of liquid water from the vegetation canopy (kg m-2 s-1) + real(rk),intent(out) :: scalarThroughfallRainDeriv ! derivative in throughfall w.r.t. canopy liquid water (s-1) + real(rk),intent(out) :: scalarCanopyLiqDrainageDeriv ! derivative in canopy drainage w.r.t. canopy liquid water (s-1) integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! ------------------------------------------------------------------------------------------------------------------------------------------------------ @@ -94,9 +94,9 @@ subroutine vegLiqFlux(& ! set throughfall to inputs if vegetation is completely buried with snow if(.not.computeVegFlux)then scalarThroughfallRain = scalarRainfall - scalarCanopyLiqDrainage = 0._summa_prec - scalarThroughfallRainDeriv = 0._summa_prec - scalarCanopyLiqDrainageDeriv = 0._summa_prec + scalarCanopyLiqDrainage = 0._rk + scalarThroughfallRainDeriv = 0._rk + scalarCanopyLiqDrainageDeriv = 0._rk return end if @@ -106,13 +106,13 @@ subroutine vegLiqFlux(& ! original model (no flexibility in canopy interception): 100% of rainfall is intercepted by the vegetation canopy ! NOTE: this could be done with scalarThroughfallScaleRain=0, though requires setting scalarThroughfallScaleRain in all test cases case(unDefined) - scalarThroughfallRain = 0._summa_prec - scalarThroughfallRainDeriv = 0._summa_prec + scalarThroughfallRain = 0._rk + scalarThroughfallRainDeriv = 0._rk ! fraction of rainfall hits the ground without ever touching the canopy case(sparseCanopy) scalarThroughfallRain = scalarThroughfallScaleRain*scalarRainfall - scalarThroughfallRainDeriv = 0._summa_prec + scalarThroughfallRainDeriv = 0._rk ! throughfall a function of canopy storage case(storageFunc) @@ -125,7 +125,7 @@ subroutine vegLiqFlux(& ! all rain falls through the canopy when the canopy is at capacity else scalarThroughfallRain = scalarRainfall - scalarThroughfallRainDeriv = 0._summa_prec + scalarThroughfallRainDeriv = 0._rk end if case default; err=20; message=trim(message)//'unable to identify option for canopy interception'; return @@ -137,8 +137,8 @@ subroutine vegLiqFlux(& scalarCanopyLiqDrainage = scalarCanopyDrainageCoeff*(scalarCanopyLiqTrial - scalarCanopyLiqMax) scalarCanopyLiqDrainageDeriv = scalarCanopyDrainageCoeff else - scalarCanopyLiqDrainage = 0._summa_prec - scalarCanopyLiqDrainageDeriv = 0._summa_prec + scalarCanopyLiqDrainage = 0._rk + scalarCanopyLiqDrainageDeriv = 0._rk end if !write(*,'(a,1x,f25.15)') 'scalarCanopyLiqDrainage = ', scalarCanopyLiqDrainage diff --git a/build/source/engine/vegNrgFlux.f90 b/build/source/engine/vegNrgFlux.f90 index 03f80f886..933429c8f 100755 --- a/build/source/engine/vegNrgFlux.f90 +++ b/build/source/engine/vegNrgFlux.f90 @@ -114,11 +114,11 @@ module vegNrgFlux_module integer(i4b),parameter :: iLoc = 1 ! i-location integer(i4b),parameter :: jLoc = 1 ! j-location ! algorithmic parameters -real(summa_prec),parameter :: missingValue=-9999._summa_prec ! missing value, used when diagnostic or state variables are undefined -real(summa_prec),parameter :: verySmall=1.e-6_summa_prec ! used as an additive constant to check if substantial difference among real numbers -real(summa_prec),parameter :: tinyVal=epsilon(1._summa_prec) ! used as an additive constant to check if substantial difference among real numbers -real(summa_prec),parameter :: mpe=1.e-6_summa_prec ! prevents overflow error if division by zero -real(summa_prec),parameter :: dx=1.e-11_summa_prec ! finite difference increment +real(rk),parameter :: missingValue=-9999._rk ! missing value, used when diagnostic or state variables are undefined +real(rk),parameter :: verySmall=1.e-6_rk ! used as an additive constant to check if substantial difference among real numbers +real(rk),parameter :: tinyVal=epsilon(1._rk) ! used as an additive constant to check if substantial difference among real numbers +real(rk),parameter :: mpe=1.e-6_rk ! prevents overflow error if division by zero +real(rk),parameter :: dx=1.e-11_rk ! finite difference increment ! control logical(lgt) :: printflag ! flag to turn on printing contains @@ -213,15 +213,15 @@ subroutine vegNrgFlux(& logical(lgt),intent(in) :: computeVegFlux ! flag to indicate if computing fluxes over vegetation ! input: model state variables - real(summa_prec),intent(in) :: upperBoundTemp ! temperature of the upper boundary (K) --> NOTE: use air temperature - real(summa_prec),intent(in) :: canairTempTrial ! trial value of canopy air space temperature (K) - real(summa_prec),intent(in) :: canopyTempTrial ! trial value of canopy temperature (K) - real(summa_prec),intent(in) :: groundTempTrial ! trial value of ground temperature (K) - real(summa_prec),intent(in) :: canopyIceTrial ! trial value of mass of ice on the vegetation canopy (kg m-2) - real(summa_prec),intent(in) :: canopyLiqTrial ! trial value of mass of liquid water on the vegetation canopy (kg m-2) + real(rk),intent(in) :: upperBoundTemp ! temperature of the upper boundary (K) --> NOTE: use air temperature + real(rk),intent(in) :: canairTempTrial ! trial value of canopy air space temperature (K) + real(rk),intent(in) :: canopyTempTrial ! trial value of canopy temperature (K) + real(rk),intent(in) :: groundTempTrial ! trial value of ground temperature (K) + real(rk),intent(in) :: canopyIceTrial ! trial value of mass of ice on the vegetation canopy (kg m-2) + real(rk),intent(in) :: canopyLiqTrial ! trial value of mass of liquid water on the vegetation canopy (kg m-2) ! input: model derivatives - real(summa_prec),intent(in) :: dCanLiq_dTcanopy ! intent(in): derivative in canopy liquid w.r.t. canopy temperature (kg m-2 K-1) + real(rk),intent(in) :: dCanLiq_dTcanopy ! intent(in): derivative in canopy liquid w.r.t. canopy temperature (kg m-2 K-1) ! input/output: data structures type(var_i),intent(in) :: type_data ! type of vegetation and soil @@ -235,41 +235,41 @@ subroutine vegNrgFlux(& type(model_options),intent(in) :: model_decisions(:) ! model decisions ! output: liquid water fluxes associated with evaporation/transpiration (needed for coupling) - real(summa_prec),intent(out) :: returnCanopyTranspiration ! canopy transpiration (kg m-2 s-1) - real(summa_prec),intent(out) :: returnCanopyEvaporation ! canopy evaporation/condensation (kg m-2 s-1) - real(summa_prec),intent(out) :: returnGroundEvaporation ! ground evaporation/condensation -- below canopy or non-vegetated (kg m-2 s-1) + real(rk),intent(out) :: returnCanopyTranspiration ! canopy transpiration (kg m-2 s-1) + real(rk),intent(out) :: returnCanopyEvaporation ! canopy evaporation/condensation (kg m-2 s-1) + real(rk),intent(out) :: returnGroundEvaporation ! ground evaporation/condensation -- below canopy or non-vegetated (kg m-2 s-1) ! output: fluxes - real(summa_prec),intent(out) :: canairNetFlux ! net energy flux for the canopy air space (W m-2) - real(summa_prec),intent(out) :: canopyNetFlux ! net energy flux for the vegetation canopy (W m-2) - real(summa_prec),intent(out) :: groundNetFlux ! net energy flux for the ground surface (W m-2) + real(rk),intent(out) :: canairNetFlux ! net energy flux for the canopy air space (W m-2) + real(rk),intent(out) :: canopyNetFlux ! net energy flux for the vegetation canopy (W m-2) + real(rk),intent(out) :: groundNetFlux ! net energy flux for the ground surface (W m-2) ! output: energy flux derivatives - real(summa_prec),intent(out) :: dCanairNetFlux_dCanairTemp ! derivative in net canopy air space flux w.r.t. canopy air temperature (W m-2 K-1) - real(summa_prec),intent(out) :: dCanairNetFlux_dCanopyTemp ! derivative in net canopy air space flux w.r.t. canopy temperature (W m-2 K-1) - real(summa_prec),intent(out) :: dCanairNetFlux_dGroundTemp ! derivative in net canopy air space flux w.r.t. ground temperature (W m-2 K-1) - real(summa_prec),intent(out) :: dCanopyNetFlux_dCanairTemp ! derivative in net canopy flux w.r.t. canopy air temperature (W m-2 K-1) - real(summa_prec),intent(out) :: dCanopyNetFlux_dCanopyTemp ! derivative in net canopy flux w.r.t. canopy temperature (W m-2 K-1) - real(summa_prec),intent(out) :: dCanopyNetFlux_dGroundTemp ! derivative in net canopy flux w.r.t. ground temperature (W m-2 K-1) - real(summa_prec),intent(out) :: dGroundNetFlux_dCanairTemp ! derivative in net ground flux w.r.t. canopy air temperature (W m-2 K-1) - real(summa_prec),intent(out) :: dGroundNetFlux_dCanopyTemp ! derivative in net ground flux w.r.t. canopy temperature (W m-2 K-1) - real(summa_prec),intent(out) :: dGroundNetFlux_dGroundTemp ! derivative in net ground flux w.r.t. ground temperature (W m-2 K-1) + real(rk),intent(out) :: dCanairNetFlux_dCanairTemp ! derivative in net canopy air space flux w.r.t. canopy air temperature (W m-2 K-1) + real(rk),intent(out) :: dCanairNetFlux_dCanopyTemp ! derivative in net canopy air space flux w.r.t. canopy temperature (W m-2 K-1) + real(rk),intent(out) :: dCanairNetFlux_dGroundTemp ! derivative in net canopy air space flux w.r.t. ground temperature (W m-2 K-1) + real(rk),intent(out) :: dCanopyNetFlux_dCanairTemp ! derivative in net canopy flux w.r.t. canopy air temperature (W m-2 K-1) + real(rk),intent(out) :: dCanopyNetFlux_dCanopyTemp ! derivative in net canopy flux w.r.t. canopy temperature (W m-2 K-1) + real(rk),intent(out) :: dCanopyNetFlux_dGroundTemp ! derivative in net canopy flux w.r.t. ground temperature (W m-2 K-1) + real(rk),intent(out) :: dGroundNetFlux_dCanairTemp ! derivative in net ground flux w.r.t. canopy air temperature (W m-2 K-1) + real(rk),intent(out) :: dGroundNetFlux_dCanopyTemp ! derivative in net ground flux w.r.t. canopy temperature (W m-2 K-1) + real(rk),intent(out) :: dGroundNetFlux_dGroundTemp ! derivative in net ground flux w.r.t. ground temperature (W m-2 K-1) ! output: liquid flux derivatives (canopy evap) - real(summa_prec),intent(out) :: dCanopyEvaporation_dCanLiq ! derivative in canopy evaporation w.r.t. canopy liquid water content (s-1) - real(summa_prec),intent(out) :: dCanopyEvaporation_dTCanair ! derivative in canopy evaporation w.r.t. canopy air temperature (kg m-2 s-1 K-1) - real(summa_prec),intent(out) :: dCanopyEvaporation_dTCanopy ! derivative in canopy evaporation w.r.t. canopy temperature (kg m-2 s-1 K-1) - real(summa_prec),intent(out) :: dCanopyEvaporation_dTGround ! derivative in canopy evaporation w.r.t. ground temperature (kg m-2 s-1 K-1) + real(rk),intent(out) :: dCanopyEvaporation_dCanLiq ! derivative in canopy evaporation w.r.t. canopy liquid water content (s-1) + real(rk),intent(out) :: dCanopyEvaporation_dTCanair ! derivative in canopy evaporation w.r.t. canopy air temperature (kg m-2 s-1 K-1) + real(rk),intent(out) :: dCanopyEvaporation_dTCanopy ! derivative in canopy evaporation w.r.t. canopy temperature (kg m-2 s-1 K-1) + real(rk),intent(out) :: dCanopyEvaporation_dTGround ! derivative in canopy evaporation w.r.t. ground temperature (kg m-2 s-1 K-1) ! output: liquid flux derivatives (ground evap) - real(summa_prec),intent(out) :: dGroundEvaporation_dCanLiq ! derivative in ground evaporation w.r.t. canopy liquid water content (s-1) - real(summa_prec),intent(out) :: dGroundEvaporation_dTCanair ! derivative in ground evaporation w.r.t. canopy air temperature (kg m-2 s-1 K-1) - real(summa_prec),intent(out) :: dGroundEvaporation_dTCanopy ! derivative in ground evaporation w.r.t. canopy temperature (kg m-2 s-1 K-1) - real(summa_prec),intent(out) :: dGroundEvaporation_dTGround ! derivative in ground evaporation w.r.t. ground temperature (kg m-2 s-1 K-1) + real(rk),intent(out) :: dGroundEvaporation_dCanLiq ! derivative in ground evaporation w.r.t. canopy liquid water content (s-1) + real(rk),intent(out) :: dGroundEvaporation_dTCanair ! derivative in ground evaporation w.r.t. canopy air temperature (kg m-2 s-1 K-1) + real(rk),intent(out) :: dGroundEvaporation_dTCanopy ! derivative in ground evaporation w.r.t. canopy temperature (kg m-2 s-1 K-1) + real(rk),intent(out) :: dGroundEvaporation_dTGround ! derivative in ground evaporation w.r.t. ground temperature (kg m-2 s-1 K-1) ! output: cross derivative terms - real(summa_prec),intent(out) :: dCanopyNetFlux_dCanLiq ! derivative in net canopy fluxes w.r.t. canopy liquid water content (J kg-1 s-1) - real(summa_prec),intent(out) :: dGroundNetFlux_dCanLiq ! derivative in net ground fluxes w.r.t. canopy liquid water content (J kg-1 s-1) + real(rk),intent(out) :: dCanopyNetFlux_dCanLiq ! derivative in net canopy fluxes w.r.t. canopy liquid water content (J kg-1 s-1) + real(rk),intent(out) :: dGroundNetFlux_dCanLiq ! derivative in net ground fluxes w.r.t. canopy liquid water content (J kg-1 s-1) ! output: error control integer(i4b),intent(out) :: err ! error code @@ -280,10 +280,10 @@ subroutine vegNrgFlux(& ! --------------------------------------------------------------------------------------- ! local (general) character(LEN=256) :: cmessage ! error message of downwind routine - real(summa_prec) :: VAI ! vegetation area index (m2 m-2) - real(summa_prec) :: exposedVAI ! exposed vegetation area index (m2 m-2) - real(summa_prec) :: totalCanopyWater ! total water on the vegetation canopy (kg m-2) - real(summa_prec) :: scalarAquiferStorage ! aquifer storage (m) + real(rk) :: VAI ! vegetation area index (m2 m-2) + real(rk) :: exposedVAI ! exposed vegetation area index (m2 m-2) + real(rk) :: totalCanopyWater ! total water on the vegetation canopy (kg m-2) + real(rk) :: scalarAquiferStorage ! aquifer storage (m) ! local (compute numerical derivatives) integer(i4b),parameter :: unperturbed=1 ! named variable to identify the case of unperturbed state variables @@ -293,135 +293,135 @@ subroutine vegNrgFlux(& integer(i4b),parameter :: perturbStateCanLiq=5 ! named variable to identify the case where we perturb the canopy liquid water content integer(i4b) :: itry ! index of flux evaluation integer(i4b) :: nFlux ! number of flux evaluations - real(summa_prec) :: groundTemp ! value of ground temperature used in flux calculations (may be perturbed) - real(summa_prec) :: canopyTemp ! value of canopy temperature used in flux calculations (may be perturbed) - real(summa_prec) :: canairTemp ! value of canopy air temperature used in flux calculations (may be perturbed) - real(summa_prec) :: try0,try1 ! trial values to evaluate specific derivatives (testing only) + real(rk) :: groundTemp ! value of ground temperature used in flux calculations (may be perturbed) + real(rk) :: canopyTemp ! value of canopy temperature used in flux calculations (may be perturbed) + real(rk) :: canairTemp ! value of canopy air temperature used in flux calculations (may be perturbed) + real(rk) :: try0,try1 ! trial values to evaluate specific derivatives (testing only) ! local (saturation vapor pressure of veg) - real(summa_prec) :: TV_celcius ! vegetaion temperature (C) - real(summa_prec) :: TG_celcius ! ground temperature (C) - real(summa_prec) :: dSVPCanopy_dCanopyTemp ! derivative in canopy saturated vapor pressure w.r.t. vegetation temperature (Pa/K) - real(summa_prec) :: dSVPGround_dGroundTemp ! derivative in ground saturated vapor pressure w.r.t. ground temperature (Pa/K) + real(rk) :: TV_celcius ! vegetaion temperature (C) + real(rk) :: TG_celcius ! ground temperature (C) + real(rk) :: dSVPCanopy_dCanopyTemp ! derivative in canopy saturated vapor pressure w.r.t. vegetation temperature (Pa/K) + real(rk) :: dSVPGround_dGroundTemp ! derivative in ground saturated vapor pressure w.r.t. ground temperature (Pa/K) ! local (wetted canopy area) - real(summa_prec) :: fracLiquidCanopy ! fraction of liquid water in the canopy (-) - real(summa_prec) :: canopyWetFraction ! trial value of the canopy wetted fraction (-) - real(summa_prec) :: dCanopyWetFraction_dWat ! derivative in wetted fraction w.r.t. canopy total water (kg-1 m2) - real(summa_prec) :: dCanopyWetFraction_dT ! derivative in wetted fraction w.r.t. canopy temperature (K-1) + real(rk) :: fracLiquidCanopy ! fraction of liquid water in the canopy (-) + real(rk) :: canopyWetFraction ! trial value of the canopy wetted fraction (-) + real(rk) :: dCanopyWetFraction_dWat ! derivative in wetted fraction w.r.t. canopy total water (kg-1 m2) + real(rk) :: dCanopyWetFraction_dT ! derivative in wetted fraction w.r.t. canopy temperature (K-1) ! local (longwave radiation) - real(summa_prec) :: expi ! exponential integral - real(summa_prec) :: scaleLAI ! scaled LAI (computing diffuse transmissivity) - real(summa_prec) :: diffuseTrans ! diffuse transmissivity (-) - real(summa_prec) :: groundEmissivity ! emissivity of the ground surface (-) - real(summa_prec),parameter :: vegEmissivity=0.98_summa_prec ! emissivity of vegetation (0.9665 in JULES) (-) - real(summa_prec),parameter :: soilEmissivity=0.98_summa_prec ! emmisivity of the soil (0.9665 in JULES) (-) - real(summa_prec),parameter :: snowEmissivity=0.99_summa_prec ! emissivity of snow (-) - real(summa_prec) :: dLWNetCanopy_dTCanopy ! derivative in net canopy radiation w.r.t. canopy temperature (W m-2 K-1) - real(summa_prec) :: dLWNetGround_dTGround ! derivative in net ground radiation w.r.t. ground temperature (W m-2 K-1) - real(summa_prec) :: dLWNetCanopy_dTGround ! derivative in net canopy radiation w.r.t. ground temperature (W m-2 K-1) - real(summa_prec) :: dLWNetGround_dTCanopy ! derivative in net ground radiation w.r.t. canopy temperature (W m-2 K-1) + real(rk) :: expi ! exponential integral + real(rk) :: scaleLAI ! scaled LAI (computing diffuse transmissivity) + real(rk) :: diffuseTrans ! diffuse transmissivity (-) + real(rk) :: groundEmissivity ! emissivity of the ground surface (-) + real(rk),parameter :: vegEmissivity=0.98_rk ! emissivity of vegetation (0.9665 in JULES) (-) + real(rk),parameter :: soilEmissivity=0.98_rk ! emmisivity of the soil (0.9665 in JULES) (-) + real(rk),parameter :: snowEmissivity=0.99_rk ! emissivity of snow (-) + real(rk) :: dLWNetCanopy_dTCanopy ! derivative in net canopy radiation w.r.t. canopy temperature (W m-2 K-1) + real(rk) :: dLWNetGround_dTGround ! derivative in net ground radiation w.r.t. ground temperature (W m-2 K-1) + real(rk) :: dLWNetCanopy_dTGround ! derivative in net canopy radiation w.r.t. ground temperature (W m-2 K-1) + real(rk) :: dLWNetGround_dTCanopy ! derivative in net ground radiation w.r.t. canopy temperature (W m-2 K-1) ! local (aerodynamic resistance) - real(summa_prec) :: scalarCanopyStabilityCorrection_old ! stability correction for the canopy (-) - real(summa_prec) :: scalarGroundStabilityCorrection_old ! stability correction for the ground surface (-) + real(rk) :: scalarCanopyStabilityCorrection_old ! stability correction for the canopy (-) + real(rk) :: scalarGroundStabilityCorrection_old ! stability correction for the ground surface (-) ! local (turbulent heat transfer) - real(summa_prec) :: z0Ground ! roughness length of the ground (ground below the canopy or non-vegetated surface) (m) - real(summa_prec) :: soilEvapFactor ! soil water control on evaporation from non-vegetated surfaces - real(summa_prec) :: soilRelHumidity_noSnow ! relative humidity in the soil pores [0-1] - real(summa_prec) :: scalarLeafConductance ! leaf conductance (m s-1) - real(summa_prec) :: scalarCanopyConductance ! canopy conductance (m s-1) - real(summa_prec) :: scalarGroundConductanceSH ! ground conductance for sensible heat (m s-1) - real(summa_prec) :: scalarGroundConductanceLH ! ground conductance for latent heat -- includes soil resistance (m s-1) - real(summa_prec) :: scalarEvapConductance ! conductance for evaporation (m s-1) - real(summa_prec) :: scalarTransConductance ! conductance for transpiration (m s-1) - real(summa_prec) :: scalarTotalConductanceSH ! total conductance for sensible heat (m s-1) - real(summa_prec) :: scalarTotalConductanceLH ! total conductance for latent heat (m s-1) - real(summa_prec) :: dGroundResistance_dTGround ! derivative in ground resistance w.r.t. ground temperature (s m-1 K-1) - real(summa_prec) :: dGroundResistance_dTCanopy ! derivative in ground resistance w.r.t. canopy temperature (s m-1 K-1) - real(summa_prec) :: dGroundResistance_dTCanair ! derivative in ground resistance w.r.t. canopy air temperature (s m-1 K-1) - real(summa_prec) :: dCanopyResistance_dTCanopy ! derivative in canopy resistance w.r.t. canopy temperature (s m-1 K-1) - real(summa_prec) :: dCanopyResistance_dTCanair ! derivative in canopy resistance w.r.t. canopy air temperature (s m-1 K-1) - real(summa_prec) :: turbFluxCanair ! total turbulent heat fluxes exchanged at the canopy air space (W m-2) - real(summa_prec) :: turbFluxCanopy ! total turbulent heat fluxes from the canopy to the canopy air space (W m-2) - real(summa_prec) :: turbFluxGround ! total turbulent heat fluxes from the ground to the canopy air space (W m-2) + real(rk) :: z0Ground ! roughness length of the ground (ground below the canopy or non-vegetated surface) (m) + real(rk) :: soilEvapFactor ! soil water control on evaporation from non-vegetated surfaces + real(rk) :: soilRelHumidity_noSnow ! relative humidity in the soil pores [0-1] + real(rk) :: scalarLeafConductance ! leaf conductance (m s-1) + real(rk) :: scalarCanopyConductance ! canopy conductance (m s-1) + real(rk) :: scalarGroundConductanceSH ! ground conductance for sensible heat (m s-1) + real(rk) :: scalarGroundConductanceLH ! ground conductance for latent heat -- includes soil resistance (m s-1) + real(rk) :: scalarEvapConductance ! conductance for evaporation (m s-1) + real(rk) :: scalarTransConductance ! conductance for transpiration (m s-1) + real(rk) :: scalarTotalConductanceSH ! total conductance for sensible heat (m s-1) + real(rk) :: scalarTotalConductanceLH ! total conductance for latent heat (m s-1) + real(rk) :: dGroundResistance_dTGround ! derivative in ground resistance w.r.t. ground temperature (s m-1 K-1) + real(rk) :: dGroundResistance_dTCanopy ! derivative in ground resistance w.r.t. canopy temperature (s m-1 K-1) + real(rk) :: dGroundResistance_dTCanair ! derivative in ground resistance w.r.t. canopy air temperature (s m-1 K-1) + real(rk) :: dCanopyResistance_dTCanopy ! derivative in canopy resistance w.r.t. canopy temperature (s m-1 K-1) + real(rk) :: dCanopyResistance_dTCanair ! derivative in canopy resistance w.r.t. canopy air temperature (s m-1 K-1) + real(rk) :: turbFluxCanair ! total turbulent heat fluxes exchanged at the canopy air space (W m-2) + real(rk) :: turbFluxCanopy ! total turbulent heat fluxes from the canopy to the canopy air space (W m-2) + real(rk) :: turbFluxGround ! total turbulent heat fluxes from the ground to the canopy air space (W m-2) ! local (turbulent heat transfer -- compute numerical derivatives) ! (temporary scalar resistances when states are perturbed) - real(summa_prec) :: trialLeafResistance ! mean leaf boundary layer resistance per unit leaf area (s m-1) - real(summa_prec) :: trialGroundResistance ! below canopy aerodynamic resistance (s m-1) - real(summa_prec) :: trialCanopyResistance ! above canopy aerodynamic resistance (s m-1) - real(summa_prec) :: notUsed_RiBulkCanopy ! bulk Richardson number for the canopy (-) - real(summa_prec) :: notUsed_RiBulkGround ! bulk Richardson number for the ground surface (-) - real(summa_prec) :: notUsed_z0Canopy ! roughness length of the vegetation canopy (m) - real(summa_prec) :: notUsed_WindReductionFactor ! canopy wind reduction factor (-) - real(summa_prec) :: notUsed_ZeroPlaneDisplacement ! zero plane displacement (m) - real(summa_prec) :: notUsed_scalarCanopyStabilityCorrection ! stability correction for the canopy (-) - real(summa_prec) :: notUsed_scalarGroundStabilityCorrection ! stability correction for the ground surface (-) - real(summa_prec) :: notUsed_EddyDiffusCanopyTop ! eddy diffusivity for heat at the top of the canopy (m2 s-1) - real(summa_prec) :: notUsed_FrictionVelocity ! friction velocity (m s-1) - real(summa_prec) :: notUsed_WindspdCanopyTop ! windspeed at the top of the canopy (m s-1) - real(summa_prec) :: notUsed_WindspdCanopyBottom ! windspeed at the height of the bottom of the canopy (m s-1) - real(summa_prec) :: notUsed_dGroundResistance_dTGround ! derivative in ground resistance w.r.t. ground temperature (s m-1 K-1) - real(summa_prec) :: notUsed_dGroundResistance_dTCanopy ! derivative in ground resistance w.r.t. canopy temperature (s m-1 K-1) - real(summa_prec) :: notUsed_dGroundResistance_dTCanair ! derivative in ground resistance w.r.t. canopy air temperature (s m-1 K-1) - real(summa_prec) :: notUsed_dCanopyResistance_dTCanopy ! derivative in canopy resistance w.r.t. canopy temperature (s m-1 K-1) - real(summa_prec) :: notUsed_dCanopyResistance_dTCanair ! derivative in canopy resistance w.r.t. canopy air temperature (s m-1 K-1) + real(rk) :: trialLeafResistance ! mean leaf boundary layer resistance per unit leaf area (s m-1) + real(rk) :: trialGroundResistance ! below canopy aerodynamic resistance (s m-1) + real(rk) :: trialCanopyResistance ! above canopy aerodynamic resistance (s m-1) + real(rk) :: notUsed_RiBulkCanopy ! bulk Richardson number for the canopy (-) + real(rk) :: notUsed_RiBulkGround ! bulk Richardson number for the ground surface (-) + real(rk) :: notUsed_z0Canopy ! roughness length of the vegetation canopy (m) + real(rk) :: notUsed_WindReductionFactor ! canopy wind reduction factor (-) + real(rk) :: notUsed_ZeroPlaneDisplacement ! zero plane displacement (m) + real(rk) :: notUsed_scalarCanopyStabilityCorrection ! stability correction for the canopy (-) + real(rk) :: notUsed_scalarGroundStabilityCorrection ! stability correction for the ground surface (-) + real(rk) :: notUsed_EddyDiffusCanopyTop ! eddy diffusivity for heat at the top of the canopy (m2 s-1) + real(rk) :: notUsed_FrictionVelocity ! friction velocity (m s-1) + real(rk) :: notUsed_WindspdCanopyTop ! windspeed at the top of the canopy (m s-1) + real(rk) :: notUsed_WindspdCanopyBottom ! windspeed at the height of the bottom of the canopy (m s-1) + real(rk) :: notUsed_dGroundResistance_dTGround ! derivative in ground resistance w.r.t. ground temperature (s m-1 K-1) + real(rk) :: notUsed_dGroundResistance_dTCanopy ! derivative in ground resistance w.r.t. canopy temperature (s m-1 K-1) + real(rk) :: notUsed_dGroundResistance_dTCanair ! derivative in ground resistance w.r.t. canopy air temperature (s m-1 K-1) + real(rk) :: notUsed_dCanopyResistance_dTCanopy ! derivative in canopy resistance w.r.t. canopy temperature (s m-1 K-1) + real(rk) :: notUsed_dCanopyResistance_dTCanair ! derivative in canopy resistance w.r.t. canopy air temperature (s m-1 K-1) ! (fluxes after perturbations in model states -- canopy air space) - real(summa_prec) :: turbFluxCanair_dStateCanair ! turbulent exchange from the canopy air space to the atmosphere, after canopy air temperature is perturbed (W m-2) - real(summa_prec) :: turbFluxCanair_dStateCanopy ! turbulent exchange from the canopy air space to the atmosphere, after canopy temperature is perturbed (W m-2) - real(summa_prec) :: turbFluxCanair_dStateGround ! turbulent exchange from the canopy air space to the atmosphere, after ground temperature is perturbed (W m-2) - real(summa_prec) :: turbFluxCanair_dStateCanliq ! turbulent exchange from the canopy air space to the atmosphere, after canopy liquid water content is perturbed (W m-2) + real(rk) :: turbFluxCanair_dStateCanair ! turbulent exchange from the canopy air space to the atmosphere, after canopy air temperature is perturbed (W m-2) + real(rk) :: turbFluxCanair_dStateCanopy ! turbulent exchange from the canopy air space to the atmosphere, after canopy temperature is perturbed (W m-2) + real(rk) :: turbFluxCanair_dStateGround ! turbulent exchange from the canopy air space to the atmosphere, after ground temperature is perturbed (W m-2) + real(rk) :: turbFluxCanair_dStateCanliq ! turbulent exchange from the canopy air space to the atmosphere, after canopy liquid water content is perturbed (W m-2) ! (fluxes after perturbations in model states -- vegetation canopy) - real(summa_prec) :: turbFluxCanopy_dStateCanair ! total turbulent heat fluxes from the canopy to the canopy air space, after canopy air temperature is perturbed (W m-2) - real(summa_prec) :: turbFluxCanopy_dStateCanopy ! total turbulent heat fluxes from the canopy to the canopy air space, after canopy temperature is perturbed (W m-2) - real(summa_prec) :: turbFluxCanopy_dStateGround ! total turbulent heat fluxes from the canopy to the canopy air space, after ground temperature is perturbed (W m-2) - real(summa_prec) :: turbFluxCanopy_dStateCanLiq ! total turbulent heat fluxes from the canopy to the canopy air space, after canopy liquid water content is perturbed (W m-2) + real(rk) :: turbFluxCanopy_dStateCanair ! total turbulent heat fluxes from the canopy to the canopy air space, after canopy air temperature is perturbed (W m-2) + real(rk) :: turbFluxCanopy_dStateCanopy ! total turbulent heat fluxes from the canopy to the canopy air space, after canopy temperature is perturbed (W m-2) + real(rk) :: turbFluxCanopy_dStateGround ! total turbulent heat fluxes from the canopy to the canopy air space, after ground temperature is perturbed (W m-2) + real(rk) :: turbFluxCanopy_dStateCanLiq ! total turbulent heat fluxes from the canopy to the canopy air space, after canopy liquid water content is perturbed (W m-2) ! (fluxes after perturbations in model states -- ground surface) - real(summa_prec) :: turbFluxGround_dStateCanair ! total turbulent heat fluxes from the ground to the canopy air space, after canopy air temperature is perturbed (W m-2) - real(summa_prec) :: turbFluxGround_dStateCanopy ! total turbulent heat fluxes from the ground to the canopy air space, after canopy temperature is perturbed (W m-2) - real(summa_prec) :: turbFluxGround_dStateGround ! total turbulent heat fluxes from the ground to the canopy air space, after ground temperature is perturbed (W m-2) - real(summa_prec) :: turbFluxGround_dStateCanLiq ! total turbulent heat fluxes from the ground to the canopy air space, after canopy liquid water content is perturbed (W m-2) + real(rk) :: turbFluxGround_dStateCanair ! total turbulent heat fluxes from the ground to the canopy air space, after canopy air temperature is perturbed (W m-2) + real(rk) :: turbFluxGround_dStateCanopy ! total turbulent heat fluxes from the ground to the canopy air space, after canopy temperature is perturbed (W m-2) + real(rk) :: turbFluxGround_dStateGround ! total turbulent heat fluxes from the ground to the canopy air space, after ground temperature is perturbed (W m-2) + real(rk) :: turbFluxGround_dStateCanLiq ! total turbulent heat fluxes from the ground to the canopy air space, after canopy liquid water content is perturbed (W m-2) ! (fluxes after perturbations in model states -- canopy evaporation) - real(summa_prec) :: latHeatCanEvap_dStateCanair ! canopy evaporation after canopy air temperature is perturbed (W m-2) - real(summa_prec) :: latHeatCanEvap_dStateCanopy ! canopy evaporation after canopy temperature is perturbed (W m-2) - real(summa_prec) :: latHeatCanEvap_dStateGround ! canopy evaporation after ground temperature is perturbed (W m-2) - real(summa_prec) :: latHeatCanEvap_dStateCanLiq ! canopy evaporation after canopy liquid water content is perturbed (W m-2) + real(rk) :: latHeatCanEvap_dStateCanair ! canopy evaporation after canopy air temperature is perturbed (W m-2) + real(rk) :: latHeatCanEvap_dStateCanopy ! canopy evaporation after canopy temperature is perturbed (W m-2) + real(rk) :: latHeatCanEvap_dStateGround ! canopy evaporation after ground temperature is perturbed (W m-2) + real(rk) :: latHeatCanEvap_dStateCanLiq ! canopy evaporation after canopy liquid water content is perturbed (W m-2) ! (flux derivatives -- canopy air space) - real(summa_prec) :: dTurbFluxCanair_dTCanair ! derivative in net canopy air space fluxes w.r.t. canopy air temperature (W m-2 K-1) - real(summa_prec) :: dTurbFluxCanair_dTCanopy ! derivative in net canopy air space fluxes w.r.t. canopy temperature (W m-2 K-1) - real(summa_prec) :: dTurbFluxCanair_dTGround ! derivative in net canopy air space fluxes w.r.t. ground temperature (W m-2 K-1) - real(summa_prec) :: dTurbFluxCanair_dCanLiq ! derivative in net canopy air space fluxes w.r.t. canopy liquid water content (J kg-1 s-1) + real(rk) :: dTurbFluxCanair_dTCanair ! derivative in net canopy air space fluxes w.r.t. canopy air temperature (W m-2 K-1) + real(rk) :: dTurbFluxCanair_dTCanopy ! derivative in net canopy air space fluxes w.r.t. canopy temperature (W m-2 K-1) + real(rk) :: dTurbFluxCanair_dTGround ! derivative in net canopy air space fluxes w.r.t. ground temperature (W m-2 K-1) + real(rk) :: dTurbFluxCanair_dCanLiq ! derivative in net canopy air space fluxes w.r.t. canopy liquid water content (J kg-1 s-1) ! (flux derivatives -- vegetation canopy) - real(summa_prec) :: dTurbFluxCanopy_dTCanair ! derivative in net canopy turbulent fluxes w.r.t. canopy air temperature (W m-2 K-1) - real(summa_prec) :: dTurbFluxCanopy_dTCanopy ! derivative in net canopy turbulent fluxes w.r.t. canopy temperature (W m-2 K-1) - real(summa_prec) :: dTurbFluxCanopy_dTGround ! derivative in net canopy turbulent fluxes w.r.t. ground temperature (W m-2 K-1) - real(summa_prec) :: dTurbFluxCanopy_dCanLiq ! derivative in net canopy turbulent fluxes w.r.t. canopy liquid water content (J kg-1 s-1) + real(rk) :: dTurbFluxCanopy_dTCanair ! derivative in net canopy turbulent fluxes w.r.t. canopy air temperature (W m-2 K-1) + real(rk) :: dTurbFluxCanopy_dTCanopy ! derivative in net canopy turbulent fluxes w.r.t. canopy temperature (W m-2 K-1) + real(rk) :: dTurbFluxCanopy_dTGround ! derivative in net canopy turbulent fluxes w.r.t. ground temperature (W m-2 K-1) + real(rk) :: dTurbFluxCanopy_dCanLiq ! derivative in net canopy turbulent fluxes w.r.t. canopy liquid water content (J kg-1 s-1) ! (flux derivatives -- ground surface) - real(summa_prec) :: dTurbFluxGround_dTCanair ! derivative in net ground turbulent fluxes w.r.t. canopy air temperature (W m-2 K-1) - real(summa_prec) :: dTurbFluxGround_dTCanopy ! derivative in net ground turbulent fluxes w.r.t. canopy temperature (W m-2 K-1) - real(summa_prec) :: dTurbFluxGround_dTGround ! derivative in net ground turbulent fluxes w.r.t. ground temperature (W m-2 K-1) - real(summa_prec) :: dTurbFluxGround_dCanLiq ! derivative in net ground turbulent fluxes w.r.t. canopy liquid water content (J kg-1 s-1) + real(rk) :: dTurbFluxGround_dTCanair ! derivative in net ground turbulent fluxes w.r.t. canopy air temperature (W m-2 K-1) + real(rk) :: dTurbFluxGround_dTCanopy ! derivative in net ground turbulent fluxes w.r.t. canopy temperature (W m-2 K-1) + real(rk) :: dTurbFluxGround_dTGround ! derivative in net ground turbulent fluxes w.r.t. ground temperature (W m-2 K-1) + real(rk) :: dTurbFluxGround_dCanLiq ! derivative in net ground turbulent fluxes w.r.t. canopy liquid water content (J kg-1 s-1) ! (liquid water flux derivatives -- canopy evap) - real(summa_prec) :: dLatHeatCanopyEvap_dCanLiq ! derivative in latent heat of canopy evaporation w.r.t. canopy liquid water content (W kg-1) - real(summa_prec) :: dLatHeatCanopyEvap_dTCanair ! derivative in latent heat of canopy evaporation w.r.t. canopy air temperature (W m-2 K-1) - real(summa_prec) :: dLatHeatCanopyEvap_dTCanopy ! derivative in latent heat of canopy evaporation w.r.t. canopy temperature (W m-2 K-1) - real(summa_prec) :: dLatHeatCanopyEvap_dTGround ! derivative in latent heat of canopy evaporation w.r.t. ground temperature (W m-2 K-1) + real(rk) :: dLatHeatCanopyEvap_dCanLiq ! derivative in latent heat of canopy evaporation w.r.t. canopy liquid water content (W kg-1) + real(rk) :: dLatHeatCanopyEvap_dTCanair ! derivative in latent heat of canopy evaporation w.r.t. canopy air temperature (W m-2 K-1) + real(rk) :: dLatHeatCanopyEvap_dTCanopy ! derivative in latent heat of canopy evaporation w.r.t. canopy temperature (W m-2 K-1) + real(rk) :: dLatHeatCanopyEvap_dTGround ! derivative in latent heat of canopy evaporation w.r.t. ground temperature (W m-2 K-1) ! (liquid water flux derivatives -- ground evap) - real(summa_prec) :: dLatHeatGroundEvap_dCanLiq ! derivative in latent heat of ground evaporation w.r.t. canopy liquid water content (J kg-1 s-1) - real(summa_prec) :: dLatHeatGroundEvap_dTCanair ! derivative in latent heat of ground evaporation w.r.t. canopy air temperature (W m-2 K-1) - real(summa_prec) :: dLatHeatGroundEvap_dTCanopy ! derivative in latent heat of ground evaporation w.r.t. canopy temperature (W m-2 K-1) - real(summa_prec) :: dLatHeatGroundEvap_dTGround ! derivative in latent heat of ground evaporation w.r.t. ground temperature (W m-2 K-1) + real(rk) :: dLatHeatGroundEvap_dCanLiq ! derivative in latent heat of ground evaporation w.r.t. canopy liquid water content (J kg-1 s-1) + real(rk) :: dLatHeatGroundEvap_dTCanair ! derivative in latent heat of ground evaporation w.r.t. canopy air temperature (W m-2 K-1) + real(rk) :: dLatHeatGroundEvap_dTCanopy ! derivative in latent heat of ground evaporation w.r.t. canopy temperature (W m-2 K-1) + real(rk) :: dLatHeatGroundEvap_dTGround ! derivative in latent heat of ground evaporation w.r.t. ground temperature (W m-2 K-1) ! --------------------------------------------------------------------------------------- ! point to variables in the data structure @@ -624,47 +624,47 @@ subroutine vegNrgFlux(& case(prescribedTemp,zeroFlux) ! derived fluxes - scalarTotalET = 0._summa_prec ! total ET (kg m-2 s-1) - scalarNetRadiation = 0._summa_prec ! net radiation (W m-2) + scalarTotalET = 0._rk ! total ET (kg m-2 s-1) + scalarNetRadiation = 0._rk ! net radiation (W m-2) ! liquid water fluxes associated with evaporation/transpiration - scalarCanopyTranspiration = 0._summa_prec ! canopy transpiration (kg m-2 s-1) - scalarCanopyEvaporation = 0._summa_prec ! canopy evaporation/condensation (kg m-2 s-1) - scalarGroundEvaporation = 0._summa_prec ! ground evaporation/condensation -- below canopy or non-vegetated (kg m-2 s-1) + scalarCanopyTranspiration = 0._rk ! canopy transpiration (kg m-2 s-1) + scalarCanopyEvaporation = 0._rk ! canopy evaporation/condensation (kg m-2 s-1) + scalarGroundEvaporation = 0._rk ! ground evaporation/condensation -- below canopy or non-vegetated (kg m-2 s-1) ! solid water fluxes associated with sublimation/frost - scalarCanopySublimation = 0._summa_prec ! sublimation from the vegetation canopy ((kg m-2 s-1) - scalarSnowSublimation = 0._summa_prec ! sublimation from the snow surface ((kg m-2 s-1) + scalarCanopySublimation = 0._rk ! sublimation from the vegetation canopy ((kg m-2 s-1) + scalarSnowSublimation = 0._rk ! sublimation from the snow surface ((kg m-2 s-1) ! set canopy fluxes to zero (no canopy) - canairNetFlux = 0._summa_prec ! net energy flux for the canopy air space (W m-2) - canopyNetFlux = 0._summa_prec ! net energy flux for the vegetation canopy (W m-2) + canairNetFlux = 0._rk ! net energy flux for the canopy air space (W m-2) + canopyNetFlux = 0._rk ! net energy flux for the vegetation canopy (W m-2) ! set canopy derivatives to zero - dCanairNetFlux_dCanairTemp = 0._summa_prec ! derivative in net canopy air space flux w.r.t. canopy air temperature (W m-2 K-1) - dCanairNetFlux_dCanopyTemp = 0._summa_prec ! derivative in net canopy air space flux w.r.t. canopy temperature (W m-2 K-1) - dCanairNetFlux_dGroundTemp = 0._summa_prec ! derivative in net canopy air space flux w.r.t. ground temperature (W m-2 K-1) - dCanopyNetFlux_dCanairTemp = 0._summa_prec ! derivative in net canopy flux w.r.t. canopy air temperature (W m-2 K-1) - dCanopyNetFlux_dCanopyTemp = 0._summa_prec ! derivative in net canopy flux w.r.t. canopy temperature (W m-2 K-1) - dCanopyNetFlux_dGroundTemp = 0._summa_prec ! derivative in net canopy flux w.r.t. ground temperature (W m-2 K-1) - dGroundNetFlux_dCanairTemp = 0._summa_prec ! derivative in net ground flux w.r.t. canopy air temperature (W m-2 K-1) - dGroundNetFlux_dCanopyTemp = 0._summa_prec ! derivative in net ground flux w.r.t. canopy temperature (W m-2 K-1) + dCanairNetFlux_dCanairTemp = 0._rk ! derivative in net canopy air space flux w.r.t. canopy air temperature (W m-2 K-1) + dCanairNetFlux_dCanopyTemp = 0._rk ! derivative in net canopy air space flux w.r.t. canopy temperature (W m-2 K-1) + dCanairNetFlux_dGroundTemp = 0._rk ! derivative in net canopy air space flux w.r.t. ground temperature (W m-2 K-1) + dCanopyNetFlux_dCanairTemp = 0._rk ! derivative in net canopy flux w.r.t. canopy air temperature (W m-2 K-1) + dCanopyNetFlux_dCanopyTemp = 0._rk ! derivative in net canopy flux w.r.t. canopy temperature (W m-2 K-1) + dCanopyNetFlux_dGroundTemp = 0._rk ! derivative in net canopy flux w.r.t. ground temperature (W m-2 K-1) + dGroundNetFlux_dCanairTemp = 0._rk ! derivative in net ground flux w.r.t. canopy air temperature (W m-2 K-1) + dGroundNetFlux_dCanopyTemp = 0._rk ! derivative in net ground flux w.r.t. canopy temperature (W m-2 K-1) ! set liquid flux derivatives to zero (canopy evap) - dCanopyEvaporation_dCanLiq = 0._summa_prec ! derivative in canopy evaporation w.r.t. canopy liquid water content (s-1) - dCanopyEvaporation_dTCanair= 0._summa_prec ! derivative in canopy evaporation w.r.t. canopy air temperature (kg m-2 s-1 K-1) - dCanopyEvaporation_dTCanopy= 0._summa_prec ! derivative in canopy evaporation w.r.t. canopy temperature (kg m-2 s-1 K-1) - dCanopyEvaporation_dTGround= 0._summa_prec ! derivative in canopy evaporation w.r.t. ground temperature (kg m-2 s-1 K-1) + dCanopyEvaporation_dCanLiq = 0._rk ! derivative in canopy evaporation w.r.t. canopy liquid water content (s-1) + dCanopyEvaporation_dTCanair= 0._rk ! derivative in canopy evaporation w.r.t. canopy air temperature (kg m-2 s-1 K-1) + dCanopyEvaporation_dTCanopy= 0._rk ! derivative in canopy evaporation w.r.t. canopy temperature (kg m-2 s-1 K-1) + dCanopyEvaporation_dTGround= 0._rk ! derivative in canopy evaporation w.r.t. ground temperature (kg m-2 s-1 K-1) ! set liquid flux derivatives to zero (ground evap) - dGroundEvaporation_dCanLiq = 0._summa_prec ! derivative in ground evaporation w.r.t. canopy liquid water content (s-1) - dGroundEvaporation_dTCanair= 0._summa_prec ! derivative in ground evaporation w.r.t. canopy air temperature (kg m-2 s-1 K-1) - dGroundEvaporation_dTCanopy= 0._summa_prec ! derivative in ground evaporation w.r.t. canopy temperature (kg m-2 s-1 K-1) - dGroundEvaporation_dTGround= 0._summa_prec ! derivative in ground evaporation w.r.t. ground temperature (kg m-2 s-1 K-1) + dGroundEvaporation_dCanLiq = 0._rk ! derivative in ground evaporation w.r.t. canopy liquid water content (s-1) + dGroundEvaporation_dTCanair= 0._rk ! derivative in ground evaporation w.r.t. canopy air temperature (kg m-2 s-1 K-1) + dGroundEvaporation_dTCanopy= 0._rk ! derivative in ground evaporation w.r.t. canopy temperature (kg m-2 s-1 K-1) + dGroundEvaporation_dTGround= 0._rk ! derivative in ground evaporation w.r.t. ground temperature (kg m-2 s-1 K-1) ! compute fluxes and derivatives -- separate approach for prescribed temperature and zero flux if(ix_bcUpprTdyn == prescribedTemp)then ! compute ground net flux (W m-2) - groundNetFlux = -diag_data%var(iLookDIAG%iLayerThermalC)%dat(0)*(groundTempTrial - upperBoundTemp)/(prog_data%var(iLookPROG%mLayerDepth)%dat(1)*0.5_summa_prec) + groundNetFlux = -diag_data%var(iLookDIAG%iLayerThermalC)%dat(0)*(groundTempTrial - upperBoundTemp)/(prog_data%var(iLookPROG%mLayerDepth)%dat(1)*0.5_rk) ! compute derivative in net ground flux w.r.t. ground temperature (W m-2 K-1) - dGroundNetFlux_dGroundTemp = -diag_data%var(iLookDIAG%iLayerThermalC)%dat(0)/(prog_data%var(iLookPROG%mLayerDepth)%dat(1)*0.5_summa_prec) + dGroundNetFlux_dGroundTemp = -diag_data%var(iLookDIAG%iLayerThermalC)%dat(0)/(prog_data%var(iLookPROG%mLayerDepth)%dat(1)*0.5_rk) elseif(model_decisions(iLookDECISIONS%bcUpprTdyn)%iDecision == zeroFlux)then - groundNetFlux = 0._summa_prec - dGroundNetFlux_dGroundTemp = 0._summa_prec + groundNetFlux = 0._rk + dGroundNetFlux_dGroundTemp = 0._rk else err=20; message=trim(message)//'unable to identify upper boundary condition for thermodynamics: expect the case to be prescribedTemp or zeroFlux'; return end if @@ -700,8 +700,8 @@ subroutine vegNrgFlux(& if(firstFluxCall .and. firstSubStep)then ! vapor pressure in the canopy air space initialized as vapor pressure of air above the vegetation canopy ! NOTE: this is needed for the stomatal resistance calculations - if(scalarVP_CanopyAir < 0._summa_prec)then - scalarVP_CanopyAir = scalarVPair - 1._summa_prec ! "small" offset used to assist in checking initial derivative calculations + if(scalarVP_CanopyAir < 0._rk)then + scalarVP_CanopyAir = scalarVPair - 1._rk ! "small" offset used to assist in checking initial derivative calculations end if end if @@ -713,17 +713,17 @@ subroutine vegNrgFlux(& if(nSnow > 0)then if(groundTempTrial > Tfreeze)then; err=20; message=trim(message)//'do not expect ground temperature > 0 when snow is on the ground'; return; end if scalarLatHeatSubVapGround = LH_sub ! sublimation from snow - scalarGroundSnowFraction = 1._summa_prec + scalarGroundSnowFraction = 1._rk ! case when the ground is snow-free else scalarLatHeatSubVapGround = LH_vap ! evaporation of water in the soil pores: this occurs even if frozen because of super-cooled water - scalarGroundSnowFraction = 0._summa_prec + scalarGroundSnowFraction = 0._rk end if ! (if there is snow on the ground) end if ! (if the first flux call) !write(*,'(a,1x,10(f30.10,1x))') 'groundTempTrial, scalarLatHeatSubVapGround = ', groundTempTrial, scalarLatHeatSubVapGround ! compute the roughness length of the ground (ground below the canopy or non-vegetated surface) - z0Ground = z0soil*(1._summa_prec - scalarGroundSnowFraction) + z0Snow*scalarGroundSnowFraction ! roughness length (m) + z0Ground = z0soil*(1._rk - scalarGroundSnowFraction) + z0Snow*scalarGroundSnowFraction ! roughness length (m) ! compute the total vegetation area index (leaf plus stem) VAI = scalarLAI + scalarSAI ! vegetation area index @@ -734,16 +734,16 @@ subroutine vegNrgFlux(& select case(ix_canopyEmis) ! *** simple exponential function case(simplExp) - scalarCanopyEmissivity = 1._summa_prec - exp(-exposedVAI) ! effective emissivity of the canopy (-) + scalarCanopyEmissivity = 1._rk - exp(-exposedVAI) ! effective emissivity of the canopy (-) ! *** canopy emissivity parameterized as a function of diffuse transmissivity case(difTrans) ! compute the exponential integral - scaleLAI = 0.5_summa_prec*exposedVAI + scaleLAI = 0.5_rk*exposedVAI expi = expInt(scaleLAI) ! compute diffuse transmissivity (-) - diffuseTrans = (1._summa_prec - scaleLAI)*exp(-scaleLAI) + (scaleLAI**2._summa_prec)*expi + diffuseTrans = (1._rk - scaleLAI)*exp(-scaleLAI) + (scaleLAI**2._rk)*expi ! compute the canopy emissivity - scalarCanopyEmissivity = (1._summa_prec - diffuseTrans)*vegEmissivity + scalarCanopyEmissivity = (1._rk - diffuseTrans)*vegEmissivity ! *** check we found the correct option case default err=20; message=trim(message)//'unable to identify option for canopy emissivity'; return @@ -751,10 +751,10 @@ subroutine vegNrgFlux(& end if ! ensure canopy longwave fluxes are zero when not computing canopy fluxes - if(.not.computeVegFlux) scalarCanopyEmissivity=0._summa_prec + if(.not.computeVegFlux) scalarCanopyEmissivity=0._rk ! compute emissivity of the ground surface (-) - groundEmissivity = scalarGroundSnowFraction*snowEmissivity + (1._summa_prec - scalarGroundSnowFraction)*soilEmissivity ! emissivity of the ground surface (-) + groundEmissivity = scalarGroundSnowFraction*snowEmissivity + (1._rk - scalarGroundSnowFraction)*soilEmissivity ! emissivity of the ground surface (-) ! compute the fraction of canopy that is wet ! NOTE: we either sublimate or evaporate over the entire substep @@ -762,10 +762,10 @@ subroutine vegNrgFlux(& ! compute the fraction of liquid water in the canopy (-) totalCanopyWater = canopyLiqTrial + canopyIceTrial - if(totalCanopyWater > tiny(1.0_summa_prec))then + if(totalCanopyWater > tiny(1.0_rk))then fracLiquidCanopy = canopyLiqTrial / (canopyLiqTrial + canopyIceTrial) else - fracLiquidCanopy = 0._summa_prec + fracLiquidCanopy = 0._rk end if ! get wetted fraction and derivatives @@ -790,9 +790,9 @@ subroutine vegNrgFlux(& if(err/=0)then; message=trim(message)//trim(cmessage); return; end if else - scalarCanopyWetFraction = 0._summa_prec ! canopy wetted fraction (-) - dCanopyWetFraction_dWat = 0._summa_prec ! derivative in wetted fraction w.r.t. canopy liquid water (kg-1 m2) - dCanopyWetFraction_dT = 0._summa_prec ! derivative in wetted fraction w.r.t. canopy temperature (K-1) + scalarCanopyWetFraction = 0._rk ! canopy wetted fraction (-) + dCanopyWetFraction_dWat = 0._rk ! derivative in wetted fraction w.r.t. canopy liquid water (kg-1 m2) + dCanopyWetFraction_dT = 0._rk ! derivative in wetted fraction w.r.t. canopy temperature (K-1) end if !write(*,'(a,1x,L1,1x,f25.15,1x))') 'computeVegFlux, scalarCanopyWetFraction = ', computeVegFlux, scalarCanopyWetFraction !print*, 'dCanopyWetFraction_dWat = ', dCanopyWetFraction_dWat @@ -1068,7 +1068,7 @@ subroutine vegNrgFlux(& if(err/=0)then; message=trim(message)//trim(cmessage); return; end if else - canopyWetFraction = 0._summa_prec + canopyWetFraction = 0._rk end if !print*, 'wetted fraction derivative = ', (canopyWetFraction - scalarCanopyWetFraction)/dx !pause @@ -1168,15 +1168,15 @@ subroutine vegNrgFlux(& ! (soil water evaporation factor [0-1]) soilEvapFactor = mLayerVolFracLiq(nSnow+1)/(theta_sat - theta_res) ! (resistance from the soil [s m-1]) - scalarSoilResistance = scalarGroundSnowFraction*1._summa_prec + (1._summa_prec - scalarGroundSnowFraction)*EXP(8.25_summa_prec - 4.225_summa_prec*soilEvapFactor) ! Sellers (1992) - !scalarSoilResistance = scalarGroundSnowFraction*0._summa_prec + (1._summa_prec - scalarGroundSnowFraction)*exp(8.25_summa_prec - 6.0_summa_prec*soilEvapFactor) ! Niu adjustment to decrease resitance for wet soil + scalarSoilResistance = scalarGroundSnowFraction*1._rk + (1._rk - scalarGroundSnowFraction)*EXP(8.25_rk - 4.225_rk*soilEvapFactor) ! Sellers (1992) + !scalarSoilResistance = scalarGroundSnowFraction*0._rk + (1._rk - scalarGroundSnowFraction)*exp(8.25_rk - 6.0_rk*soilEvapFactor) ! Niu adjustment to decrease resitance for wet soil ! (relative humidity in the soil pores [0-1]) - if(mLayerMatricHead(1) > -1.e+6_summa_prec)then ! avoid problems with numerical precision when soil is very dry + if(mLayerMatricHead(1) > -1.e+6_rk)then ! avoid problems with numerical precision when soil is very dry soilRelHumidity_noSnow = exp( (mLayerMatricHead(1)*gravity) / (groundTemp*R_wv) ) else - soilRelHumidity_noSnow = 0._summa_prec + soilRelHumidity_noSnow = 0._rk end if ! (if matric head is very low) - scalarSoilRelHumidity = scalarGroundSnowFraction*1._summa_prec + (1._summa_prec - scalarGroundSnowFraction)*soilRelHumidity_noSnow + scalarSoilRelHumidity = scalarGroundSnowFraction*1._rk + (1._rk - scalarGroundSnowFraction)*soilRelHumidity_noSnow !print*, 'mLayerMatricHead(1), scalarSoilRelHumidity = ', mLayerMatricHead(1), scalarSoilRelHumidity end if ! (if the first flux call) @@ -1396,21 +1396,21 @@ subroutine vegNrgFlux(& !print*, 'scalarLatHeatGround = ', scalarLatHeatGround ! (canopy transpiration/sublimation) if(scalarLatHeatSubVapCanopy > LH_vap+verySmall)then ! sublimation - scalarCanopyEvaporation = 0._summa_prec + scalarCanopyEvaporation = 0._rk scalarCanopySublimation = scalarLatHeatCanopyEvap/LH_sub - if(scalarLatHeatCanopyTrans > 0._summa_prec)then ! flux directed towards the veg + if(scalarLatHeatCanopyTrans > 0._rk)then ! flux directed towards the veg scalarCanopySublimation = scalarCanopySublimation + scalarLatHeatCanopyTrans/LH_sub ! frost - scalarCanopyTranspiration = 0._summa_prec + scalarCanopyTranspiration = 0._rk else scalarCanopyTranspiration = scalarLatHeatCanopyTrans/LH_vap ! transpiration is always vapor end if ! (canopy transpiration/evaporation) else ! evaporation scalarCanopyEvaporation = scalarLatHeatCanopyEvap/LH_vap - scalarCanopySublimation = 0._summa_prec - if(scalarLatHeatCanopyTrans > 0._summa_prec)then ! flux directed towards the veg + scalarCanopySublimation = 0._rk + if(scalarLatHeatCanopyTrans > 0._rk)then ! flux directed towards the veg scalarCanopyEvaporation = scalarCanopyEvaporation + scalarLatHeatCanopyTrans/LH_vap - scalarCanopyTranspiration = 0._summa_prec + scalarCanopyTranspiration = 0._rk else scalarCanopyTranspiration = scalarLatHeatCanopyTrans/LH_vap end if @@ -1419,13 +1419,13 @@ subroutine vegNrgFlux(& if(scalarLatHeatSubVapGround > LH_vap+verySmall)then ! sublimation ! NOTE: this should only occur when we have formed snow layers, so check if(nSnow == 0)then; err=20; message=trim(message)//'only expect snow sublimation when we have formed some snow layers'; return; end if - scalarGroundEvaporation = 0._summa_prec ! ground evaporation is zero once the snowpack has formed + scalarGroundEvaporation = 0._rk ! ground evaporation is zero once the snowpack has formed scalarSnowSublimation = scalarLatHeatGround/LH_sub else ! NOTE: this should only occur when we have no snow layers, so check if(nSnow > 0)then; err=20; message=trim(message)//'only expect ground evaporation when there are no snow layers'; return; end if scalarGroundEvaporation = scalarLatHeatGround/LH_vap - scalarSnowSublimation = 0._summa_prec ! no sublimation from snow if no snow layers have formed + scalarSnowSublimation = 0._rk ! no sublimation from snow if no snow layers have formed end if !print*, 'scalarSnowSublimation, scalarLatHeatGround = ', scalarSnowSublimation, scalarLatHeatGround @@ -1472,10 +1472,10 @@ subroutine vegNrgFlux(& ! sublimation else - dCanopyEvaporation_dCanLiq = 0._summa_prec ! (s-1) - dCanopyEvaporation_dTCanair = 0._summa_prec ! (kg m-2 s-1 K-1) - dCanopyEvaporation_dTCanopy = 0._summa_prec ! (kg m-2 s-1 K-1) - dCanopyEvaporation_dTGround = 0._summa_prec ! (kg m-2 s-1 K-1) + dCanopyEvaporation_dCanLiq = 0._rk ! (s-1) + dCanopyEvaporation_dTCanair = 0._rk ! (kg m-2 s-1 K-1) + dCanopyEvaporation_dTCanopy = 0._rk ! (kg m-2 s-1 K-1) + dCanopyEvaporation_dTGround = 0._rk ! (kg m-2 s-1 K-1) end if ! compute the liquid water derivarives (ground evap) @@ -1542,25 +1542,25 @@ subroutine wettedFrac(& logical(lgt),intent(in) :: deriv ! flag to denote if derivative is desired logical(lgt),intent(in) :: derNum ! flag to denote that numerical derivatives are required (otherwise, analytical derivatives are calculated) logical(lgt),intent(in) :: frozen ! flag to denote if the canopy is frozen - real(summa_prec),intent(in) :: dLiq_dT ! derivative in canopy liquid w.r.t. canopy temperature (kg m-2 K-1) - real(summa_prec),intent(in) :: fracLiq ! fraction of liquid water on the canopy (-) - real(summa_prec),intent(in) :: canopyLiq ! canopy liquid water (kg m-2) - real(summa_prec),intent(in) :: canopyIce ! canopy ice (kg m-2) - real(summa_prec),intent(in) :: canopyLiqMax ! maximum canopy liquid water (kg m-2) - real(summa_prec),intent(in) :: canopyIceMax ! maximum canopy ice content (kg m-2) - real(summa_prec),intent(in) :: canopyWettingFactor ! maximum wetted fraction of the canopy (-) - real(summa_prec),intent(in) :: canopyWettingExp ! exponent in canopy wetting function (-) + real(rk),intent(in) :: dLiq_dT ! derivative in canopy liquid w.r.t. canopy temperature (kg m-2 K-1) + real(rk),intent(in) :: fracLiq ! fraction of liquid water on the canopy (-) + real(rk),intent(in) :: canopyLiq ! canopy liquid water (kg m-2) + real(rk),intent(in) :: canopyIce ! canopy ice (kg m-2) + real(rk),intent(in) :: canopyLiqMax ! maximum canopy liquid water (kg m-2) + real(rk),intent(in) :: canopyIceMax ! maximum canopy ice content (kg m-2) + real(rk),intent(in) :: canopyWettingFactor ! maximum wetted fraction of the canopy (-) + real(rk),intent(in) :: canopyWettingExp ! exponent in canopy wetting function (-) ! output - real(summa_prec),intent(out) :: canopyWetFraction ! canopy wetted fraction (-) - real(summa_prec),intent(out) :: dCanopyWetFraction_dWat ! derivative in wetted fraction w.r.t. canopy total water (kg-1 m2) - real(summa_prec),intent(out) :: dCanopyWetFraction_dT ! derivative in wetted fraction w.r.t. canopy temperature (K-1) + real(rk),intent(out) :: canopyWetFraction ! canopy wetted fraction (-) + real(rk),intent(out) :: dCanopyWetFraction_dWat ! derivative in wetted fraction w.r.t. canopy total water (kg-1 m2) + real(rk),intent(out) :: dCanopyWetFraction_dT ! derivative in wetted fraction w.r.t. canopy temperature (K-1) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! local variables logical(lgt),parameter :: smoothing=.true. ! flag to denote that smoothing is required - real(summa_prec) :: canopyWetFractionPert ! canopy wetted fraction after state perturbations (-) - real(summa_prec) :: canopyWetFractionDeriv ! derivative in wetted fraction w.r.t. canopy liquid water (kg-1 m2) + real(rk) :: canopyWetFractionPert ! canopy wetted fraction after state perturbations (-) + real(rk) :: canopyWetFractionDeriv ! derivative in wetted fraction w.r.t. canopy liquid water (kg-1 m2) ! ----------------------------------------------------------------------------------------------------------------------------------------------- ! initialize error control err=0; message='wettedFrac/' @@ -1575,14 +1575,14 @@ subroutine wettedFrac(& canopyWetFractionDeriv = (canopyWetFractionPert - canopyWetFraction)/dx end if ! scale derivative by the fraction of water - ! NOTE: dIce/dWat = (1._summa_prec - fracLiq), hence dWet/dWat = dIce/dWat . dWet/dLiq - dCanopyWetFraction_dWat = canopyWetFractionDeriv*(1._summa_prec - fracLiq) + ! NOTE: dIce/dWat = (1._rk - fracLiq), hence dWet/dWat = dIce/dWat . dWet/dLiq + dCanopyWetFraction_dWat = canopyWetFractionDeriv*(1._rk - fracLiq) dCanopyWetFraction_dT = -canopyWetFractionDeriv*dLiq_dT ! NOTE: dIce/dT = -dLiq/dT return end if ! compute fraction of liquid water on the canopy - ! NOTE: if(.not.deriv) canopyWetFractionDeriv = 0._summa_prec + ! NOTE: if(.not.deriv) canopyWetFractionDeriv = 0._rk call wetFraction((deriv .and. .not.derNum),smoothing,canopyLiq,canopyLiqMax,canopyWettingFactor,canopyWettingExp,canopyWetFraction,canopyWetFractionDeriv) ! compute numerical derivative @@ -1611,20 +1611,20 @@ subroutine wetFraction(derDesire,smoothing,canopyLiq,canopyMax,canopyWettingFact ! dummy variables logical(lgt),intent(in) :: derDesire ! flag to denote if analytical derivatives are desired logical(lgt),intent(in) :: smoothing ! flag to denote if smoothing is required - real(summa_prec),intent(in) :: canopyLiq ! liquid water content (kg m-2) - real(summa_prec),intent(in) :: canopyMax ! liquid water content (kg m-2) - real(summa_prec),intent(in) :: canopyWettingFactor ! maximum wetted fraction of the canopy (-) - real(summa_prec),intent(in) :: canopyWettingExp ! exponent in canopy wetting function (-) + real(rk),intent(in) :: canopyLiq ! liquid water content (kg m-2) + real(rk),intent(in) :: canopyMax ! liquid water content (kg m-2) + real(rk),intent(in) :: canopyWettingFactor ! maximum wetted fraction of the canopy (-) + real(rk),intent(in) :: canopyWettingExp ! exponent in canopy wetting function (-) - real(summa_prec),intent(out) :: canopyWetFraction ! canopy wetted fraction (-) - real(summa_prec),intent(out) :: canopyWetFractionDeriv ! derivative in wetted fraction w.r.t. canopy liquid water (kg-1 m2) + real(rk),intent(out) :: canopyWetFraction ! canopy wetted fraction (-) + real(rk),intent(out) :: canopyWetFractionDeriv ! derivative in wetted fraction w.r.t. canopy liquid water (kg-1 m2) ! local variables - real(summa_prec) :: relativeCanopyWater ! water stored on vegetation canopy, expressed as a fraction of maximum storage (-) - real(summa_prec) :: rawCanopyWetFraction ! initial value of the canopy wet fraction (before smoothing) - real(summa_prec) :: rawWetFractionDeriv ! derivative in canopy wet fraction w.r.t. storage (kg-1 m2) - real(summa_prec) :: smoothFunc ! smoothing function used to improve numerical stability at times with limited water storage (-) - real(summa_prec) :: smoothFuncDeriv ! derivative in the smoothing function w.r.t.canopy storage (kg-1 m2) - real(summa_prec) :: verySmall=epsilon(1._summa_prec) ! a very small number + real(rk) :: relativeCanopyWater ! water stored on vegetation canopy, expressed as a fraction of maximum storage (-) + real(rk) :: rawCanopyWetFraction ! initial value of the canopy wet fraction (before smoothing) + real(rk) :: rawWetFractionDeriv ! derivative in canopy wet fraction w.r.t. storage (kg-1 m2) + real(rk) :: smoothFunc ! smoothing function used to improve numerical stability at times with limited water storage (-) + real(rk) :: smoothFuncDeriv ! derivative in the smoothing function w.r.t.canopy storage (kg-1 m2) + real(rk) :: verySmall=epsilon(1._rk) ! a very small number ! -------------------------------------------------------------------------------------------------------------- ! compute relative canopy water @@ -1633,18 +1633,18 @@ subroutine wetFraction(derDesire,smoothing,canopyLiq,canopyMax,canopyWettingFact ! compute an initial value of the canopy wet fraction ! - canopy below value where canopy is 100% wet - if(relativeCanopyWater < 1._summa_prec)then + if(relativeCanopyWater < 1._rk)then rawCanopyWetFraction = canopyWettingFactor*(relativeCanopyWater**canopyWettingExp) if(derDesire .and. relativeCanopyWater>verySmall)then - rawWetFractionDeriv = (canopyWettingFactor*canopyWettingExp/canopyMax)*relativeCanopyWater**(canopyWettingExp - 1._summa_prec) + rawWetFractionDeriv = (canopyWettingFactor*canopyWettingExp/canopyMax)*relativeCanopyWater**(canopyWettingExp - 1._rk) else - rawWetFractionDeriv = 0._summa_prec + rawWetFractionDeriv = 0._rk end if ! - canopy is at capacity (canopyWettingFactor) else rawCanopyWetFraction = canopyWettingFactor - rawWetFractionDeriv = 0._summa_prec + rawWetFractionDeriv = 0._rk end if ! smooth canopy wetted fraction @@ -1660,7 +1660,7 @@ subroutine wetFraction(derDesire,smoothing,canopyLiq,canopyMax,canopyWettingFact if(derDesire .and. smoothing)then ! NOTE: raw derivative is used if not smoothing canopyWetFractionDeriv = rawWetFractionDeriv*smoothFunc + rawCanopyWetFraction*smoothFuncDeriv else - canopyWetFractionDeriv = 0._summa_prec + canopyWetFractionDeriv = 0._rk end if end subroutine wetFraction @@ -1673,15 +1673,15 @@ subroutine logisticSmoother(derDesire,canopyLiq,smoothFunc,smoothFuncDeriv) implicit none ! dummy variables logical(lgt),intent(in) :: derDesire ! flag to denote if analytical derivatives are desired - real(summa_prec),intent(in) :: canopyLiq ! liquid water content (kg m-2) - real(summa_prec),intent(out) :: smoothFunc ! smoothing function (-) - real(summa_prec),intent(out) :: smoothFuncDeriv ! derivative in smoothing function (kg-1 m-2) + real(rk),intent(in) :: canopyLiq ! liquid water content (kg m-2) + real(rk),intent(out) :: smoothFunc ! smoothing function (-) + real(rk),intent(out) :: smoothFuncDeriv ! derivative in smoothing function (kg-1 m-2) ! local variables - real(summa_prec) :: xArg ! argument used in the smoothing function (-) - real(summa_prec) :: expX ! exp(-xArg) -- used multiple times - real(summa_prec),parameter :: smoothThresh=0.01_summa_prec ! mid-point of the smoothing function (kg m-2) - real(summa_prec),parameter :: smoothScale=0.001_summa_prec ! scaling factor for the smoothing function (kg m-2) - real(summa_prec),parameter :: xLimit=50._summa_prec ! don't compute exponents for > xLimit + real(rk) :: xArg ! argument used in the smoothing function (-) + real(rk) :: expX ! exp(-xArg) -- used multiple times + real(rk),parameter :: smoothThresh=0.01_rk ! mid-point of the smoothing function (kg m-2) + real(rk),parameter :: smoothScale=0.001_rk ! scaling factor for the smoothing function (kg m-2) + real(rk),parameter :: xLimit=50._rk ! don't compute exponents for > xLimit ! -------------------------------------------------------------------------------------------------------------- ! compute argument in the smoothing function xArg = (canopyLiq - smoothThresh)/smoothScale @@ -1689,19 +1689,19 @@ subroutine logisticSmoother(derDesire,canopyLiq,smoothFunc,smoothFuncDeriv) ! only compute smoothing function for small exponents if(xArg > -xLimit .and. xArg < xLimit)then ! avoid huge exponents expX = exp(-xarg) ! (also used in the derivative) - smoothFunc = 1._summa_prec / (1._summa_prec + expX) ! (logistic smoother) + smoothFunc = 1._rk / (1._rk + expX) ! (logistic smoother) if(derDesire)then - smoothFuncDeriv = expX / (smoothScale * (1._summa_prec + expX)**2._summa_prec) ! (derivative in the smoothing function) + smoothFuncDeriv = expX / (smoothScale * (1._rk + expX)**2._rk) ! (derivative in the smoothing function) else - smoothFuncDeriv = 0._summa_prec + smoothFuncDeriv = 0._rk end if ! outside limits: special case of smooth exponents else - if(xArg < 0._summa_prec)then; smoothFunc = 0._summa_prec ! xArg < -xLimit - else; smoothFunc = 1._summa_prec ! xArg > xLimit + if(xArg < 0._rk)then; smoothFunc = 0._rk ! xArg < -xLimit + else; smoothFunc = 1._rk ! xArg > xLimit end if - smoothFuncDeriv = 0._summa_prec + smoothFuncDeriv = 0._rk end if ! check for huge exponents end subroutine logisticSmoother @@ -1752,34 +1752,34 @@ subroutine longwaveBal(& integer(i4b),intent(in) :: ixDerivMethod ! choice of method used to compute derivative (analytical or numerical) logical(lgt),intent(in) :: computeVegFlux ! flag to indicate if computing fluxes over vegetation ! input: canopy and ground temperature - real(summa_prec),intent(in) :: canopyTemp ! canopy temperature (K) - real(summa_prec),intent(in) :: groundTemp ! ground temperature (K) + real(rk),intent(in) :: canopyTemp ! canopy temperature (K) + real(rk),intent(in) :: groundTemp ! ground temperature (K) ! input: canopy and ground emissivity - real(summa_prec),intent(in) :: emc ! canopy emissivity (-) - real(summa_prec),intent(in) :: emg ! ground emissivity (-) + real(rk),intent(in) :: emc ! canopy emissivity (-) + real(rk),intent(in) :: emg ! ground emissivity (-) ! input: forcing - real(summa_prec),intent(in) :: LWRadUbound ! downwelling longwave radiation at the upper boundary (W m-2) + real(rk),intent(in) :: LWRadUbound ! downwelling longwave radiation at the upper boundary (W m-2) ! output: sources - real(summa_prec),intent(out) :: LWRadCanopy ! longwave radiation emitted from the canopy (W m-2) - real(summa_prec),intent(out) :: LWRadGround ! longwave radiation emitted at the ground surface (W m-2) + real(rk),intent(out) :: LWRadCanopy ! longwave radiation emitted from the canopy (W m-2) + real(rk),intent(out) :: LWRadGround ! longwave radiation emitted at the ground surface (W m-2) ! output: individual fluxes - real(summa_prec),intent(out) :: LWRadUbound2Canopy ! downward atmospheric longwave radiation absorbed by the canopy (W m-2) - real(summa_prec),intent(out) :: LWRadUbound2Ground ! downward atmospheric longwave radiation absorbed by the ground (W m-2) - real(summa_prec),intent(out) :: LWRadUbound2Ubound ! atmospheric radiation reflected by the ground and lost thru upper boundary (W m-2) - real(summa_prec),intent(out) :: LWRadCanopy2Ubound ! longwave radiation emitted from canopy lost thru upper boundary (W m-2) - real(summa_prec),intent(out) :: LWRadCanopy2Ground ! longwave radiation emitted from canopy absorbed by the ground (W m-2) - real(summa_prec),intent(out) :: LWRadCanopy2Canopy ! canopy longwave reflected from ground and absorbed by the canopy (W m-2) - real(summa_prec),intent(out) :: LWRadGround2Ubound ! longwave radiation emitted from ground lost thru upper boundary (W m-2) - real(summa_prec),intent(out) :: LWRadGround2Canopy ! longwave radiation emitted from ground and absorbed by the canopy (W m-2) + real(rk),intent(out) :: LWRadUbound2Canopy ! downward atmospheric longwave radiation absorbed by the canopy (W m-2) + real(rk),intent(out) :: LWRadUbound2Ground ! downward atmospheric longwave radiation absorbed by the ground (W m-2) + real(rk),intent(out) :: LWRadUbound2Ubound ! atmospheric radiation reflected by the ground and lost thru upper boundary (W m-2) + real(rk),intent(out) :: LWRadCanopy2Ubound ! longwave radiation emitted from canopy lost thru upper boundary (W m-2) + real(rk),intent(out) :: LWRadCanopy2Ground ! longwave radiation emitted from canopy absorbed by the ground (W m-2) + real(rk),intent(out) :: LWRadCanopy2Canopy ! canopy longwave reflected from ground and absorbed by the canopy (W m-2) + real(rk),intent(out) :: LWRadGround2Ubound ! longwave radiation emitted from ground lost thru upper boundary (W m-2) + real(rk),intent(out) :: LWRadGround2Canopy ! longwave radiation emitted from ground and absorbed by the canopy (W m-2) ! output: net fluxes - real(summa_prec),intent(out) :: LWNetCanopy ! net longwave radiation at the canopy (W m-2) - real(summa_prec),intent(out) :: LWNetGround ! net longwave radiation at the ground surface (W m-2) - real(summa_prec),intent(out) :: LWNetUbound ! net longwave radiation at the upper boundary (W m-2) + real(rk),intent(out) :: LWNetCanopy ! net longwave radiation at the canopy (W m-2) + real(rk),intent(out) :: LWNetGround ! net longwave radiation at the ground surface (W m-2) + real(rk),intent(out) :: LWNetUbound ! net longwave radiation at the upper boundary (W m-2) ! output: flux derivatives - real(summa_prec),intent(out) :: dLWNetCanopy_dTCanopy ! derivative in net canopy radiation w.r.t. canopy temperature (W m-2 K-1) - real(summa_prec),intent(out) :: dLWNetGround_dTGround ! derivative in net ground radiation w.r.t. ground temperature (W m-2 K-1) - real(summa_prec),intent(out) :: dLWNetCanopy_dTGround ! derivative in net canopy radiation w.r.t. ground temperature (W m-2 K-1) - real(summa_prec),intent(out) :: dLWNetGround_dTCanopy ! derivative in net ground radiation w.r.t. canopy temperature (W m-2 K-1) + real(rk),intent(out) :: dLWNetCanopy_dTCanopy ! derivative in net canopy radiation w.r.t. canopy temperature (W m-2 K-1) + real(rk),intent(out) :: dLWNetGround_dTGround ! derivative in net ground radiation w.r.t. ground temperature (W m-2 K-1) + real(rk),intent(out) :: dLWNetCanopy_dTGround ! derivative in net canopy radiation w.r.t. ground temperature (W m-2 K-1) + real(rk),intent(out) :: dLWNetGround_dTCanopy ! derivative in net ground radiation w.r.t. canopy temperature (W m-2 K-1) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message @@ -1790,16 +1790,16 @@ subroutine longwaveBal(& integer(i4b),parameter :: perturbStateGround=3 ! named variable to identify the case where we perturb the ground temperature integer(i4b) :: itry ! index of flux evaluation integer(i4b) :: nFlux ! number of flux evaluations - real(summa_prec) :: TCan ! value of canopy temperature used in flux calculations (may be perturbed) - real(summa_prec) :: TGnd ! value of ground temperature used in flux calculations (may be perturbed) - real(summa_prec) :: fluxBalance ! check energy closure (W m-2) - real(summa_prec),parameter :: fluxTolerance=1.e-10_summa_prec ! tolerance for energy closure (W m-2) - real(summa_prec) :: dLWRadCanopy_dTCanopy ! derivative in emitted radiation at the canopy w.r.t. canopy temperature - real(summa_prec) :: dLWRadGround_dTGround ! derivative in emitted radiation at the ground w.r.t. ground temperature - real(summa_prec) :: LWNetCanopy_dStateCanopy ! net lw canopy flux after perturbation in canopy temperature - real(summa_prec) :: LWNetGround_dStateCanopy ! net lw ground flux after perturbation in canopy temperature - real(summa_prec) :: LWNetCanopy_dStateGround ! net lw canopy flux after perturbation in ground temperature - real(summa_prec) :: LWNetGround_dStateGround ! net lw ground flux after perturbation in ground temperature + real(rk) :: TCan ! value of canopy temperature used in flux calculations (may be perturbed) + real(rk) :: TGnd ! value of ground temperature used in flux calculations (may be perturbed) + real(rk) :: fluxBalance ! check energy closure (W m-2) + real(rk),parameter :: fluxTolerance=1.e-10_rk ! tolerance for energy closure (W m-2) + real(rk) :: dLWRadCanopy_dTCanopy ! derivative in emitted radiation at the canopy w.r.t. canopy temperature + real(rk) :: dLWRadGround_dTGround ! derivative in emitted radiation at the ground w.r.t. ground temperature + real(rk) :: LWNetCanopy_dStateCanopy ! net lw canopy flux after perturbation in canopy temperature + real(rk) :: LWNetGround_dStateCanopy ! net lw ground flux after perturbation in canopy temperature + real(rk) :: LWNetCanopy_dStateGround ! net lw canopy flux after perturbation in ground temperature + real(rk) :: LWNetGround_dStateGround ! net lw ground flux after perturbation in ground temperature ! ----------------------------------------------------------------------------------------------------------------------------------------------- ! initialize error control err=0; message='longwaveBal/' @@ -1851,28 +1851,28 @@ subroutine longwaveBal(& ! compute longwave fluxes from canopy and the ground if(computeVegFlux)then - LWRadCanopy = emc*sb*TCan**4._summa_prec ! longwave radiation emitted from the canopy (W m-2) + LWRadCanopy = emc*sb*TCan**4._rk ! longwave radiation emitted from the canopy (W m-2) else - LWRadCanopy = 0._summa_prec + LWRadCanopy = 0._rk end if - LWRadGround = emg*sb*TGnd**4._summa_prec ! longwave radiation emitted at the ground surface (W m-2) + LWRadGround = emg*sb*TGnd**4._rk ! longwave radiation emitted at the ground surface (W m-2) ! compute fluxes originating from the atmosphere - LWRadUbound2Canopy = (emc + (1._summa_prec - emc)*(1._summa_prec - emg)*emc)*LWRadUbound ! downward atmospheric longwave radiation absorbed by the canopy (W m-2) - LWRadUbound2Ground = (1._summa_prec - emc)*emg*LWRadUbound ! downward atmospheric longwave radiation absorbed by the ground (W m-2) - LWRadUbound2Ubound = (1._summa_prec - emc)*(1._summa_prec - emg)*(1._summa_prec - emc)*LWRadUbound ! atmospheric radiation reflected by the ground and lost thru upper boundary (W m-2) + LWRadUbound2Canopy = (emc + (1._rk - emc)*(1._rk - emg)*emc)*LWRadUbound ! downward atmospheric longwave radiation absorbed by the canopy (W m-2) + LWRadUbound2Ground = (1._rk - emc)*emg*LWRadUbound ! downward atmospheric longwave radiation absorbed by the ground (W m-2) + LWRadUbound2Ubound = (1._rk - emc)*(1._rk - emg)*(1._rk - emc)*LWRadUbound ! atmospheric radiation reflected by the ground and lost thru upper boundary (W m-2) ! compute fluxes originating from the canopy - LWRadCanopy2Ubound = (1._summa_prec + (1._summa_prec - emc)*(1._summa_prec - emg))*LWRadCanopy ! longwave radiation emitted from canopy lost thru upper boundary (W m-2) + LWRadCanopy2Ubound = (1._rk + (1._rk - emc)*(1._rk - emg))*LWRadCanopy ! longwave radiation emitted from canopy lost thru upper boundary (W m-2) LWRadCanopy2Ground = emg*LWRadCanopy ! longwave radiation emitted from canopy absorbed by the ground (W m-2) - LWRadCanopy2Canopy = emc*(1._summa_prec - emg)*LWRadCanopy ! canopy longwave reflected from ground and absorbed by the canopy (W m-2) + LWRadCanopy2Canopy = emc*(1._rk - emg)*LWRadCanopy ! canopy longwave reflected from ground and absorbed by the canopy (W m-2) ! compute fluxes originating from the ground surface - LWRadGround2Ubound = (1._summa_prec - emc)*LWRadGround ! longwave radiation emitted from ground lost thru upper boundary (W m-2) + LWRadGround2Ubound = (1._rk - emc)*LWRadGround ! longwave radiation emitted from ground lost thru upper boundary (W m-2) LWRadGround2Canopy = emc*LWRadGround ! longwave radiation emitted from ground and absorbed by the canopy (W m-2) ! compute net longwave radiation (W m-2) - LWNetCanopy = LWRadUbound2Canopy + LWRadGround2Canopy + LWRadCanopy2Canopy - 2._summa_prec*LWRadCanopy ! canopy + LWNetCanopy = LWRadUbound2Canopy + LWRadGround2Canopy + LWRadCanopy2Canopy - 2._rk*LWRadCanopy ! canopy LWNetGround = LWRadUbound2Ground + LWRadCanopy2Ground - LWRadGround ! ground surface LWNetUbound = LWRadUbound - LWRadUbound2Ubound - LWRadCanopy2Ubound - LWRadGround2Ubound ! upper boundary @@ -1933,10 +1933,10 @@ subroutine longwaveBal(& ! ***** analytical derivatives case(analytical) ! compute initial derivatives - dLWRadCanopy_dTCanopy = 4._summa_prec*emc*sb*TCan**3._summa_prec - dLWRadGround_dTGround = 4._summa_prec*emg*sb*TGnd**3._summa_prec + dLWRadCanopy_dTCanopy = 4._rk*emc*sb*TCan**3._rk + dLWRadGround_dTGround = 4._rk*emg*sb*TGnd**3._rk ! compute analytical derivatives - dLWNetCanopy_dTCanopy = (emc*(1._summa_prec - emg) - 2._summa_prec)*dLWRadCanopy_dTCanopy ! derivative in net canopy radiation w.r.t. canopy temperature (W m-2 K-1) + dLWNetCanopy_dTCanopy = (emc*(1._rk - emg) - 2._rk)*dLWRadCanopy_dTCanopy ! derivative in net canopy radiation w.r.t. canopy temperature (W m-2 K-1) dLWNetGround_dTGround = -dLWRadGround_dTGround ! derivative in net ground radiation w.r.t. ground temperature (W m-2 K-1) dLWNetCanopy_dTGround = emc*dLWRadGround_dTGround ! derivative in net canopy radiation w.r.t. ground temperature (W m-2 K-1) dLWNetGround_dTCanopy = emg*dLWRadCanopy_dTCanopy ! derivative in net ground radiation w.r.t. canopy temperature (W m-2 K-1) @@ -2026,49 +2026,49 @@ subroutine aeroResist(& integer(i4b),intent(in) :: ixWindProfile ! choice of canopy wind profile integer(i4b),intent(in) :: ixStability ! choice of stability function ! input: above-canopy forcing data - real(summa_prec),intent(in) :: mHeight ! measurement height (m) - real(summa_prec),intent(in) :: airtemp ! air temperature at some height above the surface (K) - real(summa_prec),intent(in) :: windspd ! wind speed at some height above the surface (m s-1) + real(rk),intent(in) :: mHeight ! measurement height (m) + real(rk),intent(in) :: airtemp ! air temperature at some height above the surface (K) + real(rk),intent(in) :: windspd ! wind speed at some height above the surface (m s-1) ! input: temperature (canopy, ground, canopy air space) - real(summa_prec),intent(in) :: canairTemp ! temperature of the canopy air space (K) - real(summa_prec),intent(in) :: groundTemp ! ground temperature (K) + real(rk),intent(in) :: canairTemp ! temperature of the canopy air space (K) + real(rk),intent(in) :: groundTemp ! ground temperature (K) ! input: diagnostic variables - real(summa_prec),intent(in) :: exposedVAI ! exposed vegetation area index -- leaf plus stem (m2 m-2) - real(summa_prec),intent(in) :: snowDepth ! snow depth (m) + real(rk),intent(in) :: exposedVAI ! exposed vegetation area index -- leaf plus stem (m2 m-2) + real(rk),intent(in) :: snowDepth ! snow depth (m) ! input: parameters - real(summa_prec),intent(in) :: z0Ground ! roughness length of the ground (below canopy or non-vegetated surface [snow]) (m) - real(summa_prec),intent(in) :: z0CanopyParam ! roughness length of the canopy (m) - real(summa_prec),intent(in) :: zpdFraction ! zero plane displacement / canopy height (-) - real(summa_prec),intent(in) :: critRichNumber ! critical value for the bulk Richardson number where turbulence ceases (-) - real(summa_prec),intent(in) :: Louis79_bparam ! parameter in Louis (1979) stability function - real(summa_prec),intent(in) :: Mahrt87_eScale ! exponential scaling factor in the Mahrt (1987) stability function - real(summa_prec),intent(in) :: windReductionParam ! canopy wind reduction parameter (-) - real(summa_prec),intent(in) :: leafExchangeCoeff ! turbulent exchange coeff between canopy surface and canopy air ( m s-(1/2) ) - real(summa_prec),intent(in) :: leafDimension ! characteristic leaf dimension (m) - real(summa_prec),intent(in) :: heightCanopyTop ! height at the top of the vegetation canopy (m) - real(summa_prec),intent(in) :: heightCanopyBottom ! height at the bottom of the vegetation canopy (m) + real(rk),intent(in) :: z0Ground ! roughness length of the ground (below canopy or non-vegetated surface [snow]) (m) + real(rk),intent(in) :: z0CanopyParam ! roughness length of the canopy (m) + real(rk),intent(in) :: zpdFraction ! zero plane displacement / canopy height (-) + real(rk),intent(in) :: critRichNumber ! critical value for the bulk Richardson number where turbulence ceases (-) + real(rk),intent(in) :: Louis79_bparam ! parameter in Louis (1979) stability function + real(rk),intent(in) :: Mahrt87_eScale ! exponential scaling factor in the Mahrt (1987) stability function + real(rk),intent(in) :: windReductionParam ! canopy wind reduction parameter (-) + real(rk),intent(in) :: leafExchangeCoeff ! turbulent exchange coeff between canopy surface and canopy air ( m s-(1/2) ) + real(rk),intent(in) :: leafDimension ! characteristic leaf dimension (m) + real(rk),intent(in) :: heightCanopyTop ! height at the top of the vegetation canopy (m) + real(rk),intent(in) :: heightCanopyBottom ! height at the bottom of the vegetation canopy (m) ! output: stability corrections - real(summa_prec),intent(out) :: RiBulkCanopy ! bulk Richardson number for the canopy (-) - real(summa_prec),intent(out) :: RiBulkGround ! bulk Richardson number for the ground surface (-) - real(summa_prec),intent(out) :: canopyStabilityCorrection ! stability correction for the canopy (-) - real(summa_prec),intent(out) :: groundStabilityCorrection ! stability correction for the ground surface (-) + real(rk),intent(out) :: RiBulkCanopy ! bulk Richardson number for the canopy (-) + real(rk),intent(out) :: RiBulkGround ! bulk Richardson number for the ground surface (-) + real(rk),intent(out) :: canopyStabilityCorrection ! stability correction for the canopy (-) + real(rk),intent(out) :: groundStabilityCorrection ! stability correction for the ground surface (-) ! output: scalar resistances - real(summa_prec),intent(out) :: z0Canopy ! roughness length of the vegetation canopy (m) - real(summa_prec),intent(out) :: windReductionFactor ! canopy wind reduction factor (-) - real(summa_prec),intent(out) :: zeroPlaneDisplacement ! zero plane displacement (m) - real(summa_prec),intent(out) :: eddyDiffusCanopyTop ! eddy diffusivity for heat at the top of the canopy (m2 s-1) - real(summa_prec),intent(out) :: frictionVelocity ! friction velocity (m s-1) - real(summa_prec),intent(out) :: windspdCanopyTop ! windspeed at the top of the canopy (m s-1) - real(summa_prec),intent(out) :: windspdCanopyBottom ! windspeed at the height of the bottom of the canopy (m s-1) - real(summa_prec),intent(out) :: leafResistance ! mean leaf boundary layer resistance per unit leaf area (s m-1) - real(summa_prec),intent(out) :: groundResistance ! below canopy aerodynamic resistance (s m-1) - real(summa_prec),intent(out) :: canopyResistance ! above canopy aerodynamic resistance (s m-1) + real(rk),intent(out) :: z0Canopy ! roughness length of the vegetation canopy (m) + real(rk),intent(out) :: windReductionFactor ! canopy wind reduction factor (-) + real(rk),intent(out) :: zeroPlaneDisplacement ! zero plane displacement (m) + real(rk),intent(out) :: eddyDiffusCanopyTop ! eddy diffusivity for heat at the top of the canopy (m2 s-1) + real(rk),intent(out) :: frictionVelocity ! friction velocity (m s-1) + real(rk),intent(out) :: windspdCanopyTop ! windspeed at the top of the canopy (m s-1) + real(rk),intent(out) :: windspdCanopyBottom ! windspeed at the height of the bottom of the canopy (m s-1) + real(rk),intent(out) :: leafResistance ! mean leaf boundary layer resistance per unit leaf area (s m-1) + real(rk),intent(out) :: groundResistance ! below canopy aerodynamic resistance (s m-1) + real(rk),intent(out) :: canopyResistance ! above canopy aerodynamic resistance (s m-1) ! output: derivatives in scalar resistances - real(summa_prec),intent(out) :: dGroundResistance_dTGround ! derivative in ground resistance w.r.t. ground temperature (s m-1 K-1) - real(summa_prec),intent(out) :: dGroundResistance_dTCanopy ! derivative in ground resistance w.r.t. canopy temperature (s m-1 K-1) - real(summa_prec),intent(out) :: dGroundResistance_dTCanair ! derivative in ground resistance w.r.t. canopy air temperature (s m-1 K-1) - real(summa_prec),intent(out) :: dCanopyResistance_dTCanopy ! derivative in canopy resistance w.r.t. canopy temperature (s m-1 K-1) - real(summa_prec),intent(out) :: dCanopyResistance_dTCanair ! derivative in canopy resistance w.r.t. canopy air temperature (s m-1 K-1) + real(rk),intent(out) :: dGroundResistance_dTGround ! derivative in ground resistance w.r.t. ground temperature (s m-1 K-1) + real(rk),intent(out) :: dGroundResistance_dTCanopy ! derivative in ground resistance w.r.t. canopy temperature (s m-1 K-1) + real(rk),intent(out) :: dGroundResistance_dTCanair ! derivative in ground resistance w.r.t. canopy air temperature (s m-1 K-1) + real(rk),intent(out) :: dCanopyResistance_dTCanopy ! derivative in canopy resistance w.r.t. canopy temperature (s m-1 K-1) + real(rk),intent(out) :: dCanopyResistance_dTCanair ! derivative in canopy resistance w.r.t. canopy air temperature (s m-1 K-1) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message @@ -2076,45 +2076,45 @@ subroutine aeroResist(& ! local variables: general character(LEN=256) :: cmessage ! error message of downwind routine ! local variables: vegetation roughness and dispalcement height - real(summa_prec),parameter :: oneThird=1._summa_prec/3._summa_prec ! 1/3 - real(summa_prec),parameter :: twoThirds=2._summa_prec/3._summa_prec ! 2/3 - real(summa_prec),parameter :: C_r = 0.3 ! roughness element drag coefficient (-) from Raupach (BLM, 1994) - real(summa_prec),parameter :: C_s = 0.003_summa_prec ! substrate surface drag coefficient (-) from Raupach (BLM, 1994) - real(summa_prec),parameter :: approxDragCoef_max = 0.3_summa_prec ! maximum value of the approximate drag coefficient (-) from Raupach (BLM, 1994) - real(summa_prec),parameter :: psi_h = 0.193_summa_prec ! roughness sub-layer influence function (-) from Raupach (BLM, 1994) - real(summa_prec),parameter :: c_d1 = 7.5_summa_prec ! scaling parameter used to define displacement height (-) from Raupach (BLM, 1994) - real(summa_prec),parameter :: cd_CM = 0.2_summa_prec ! mean drag coefficient for individual leaves (-) from Choudhury and Monteith (QJRMS, 1988) - real(summa_prec) :: funcLAI ! temporary variable to calculate zero plane displacement for the canopy - real(summa_prec) :: fracCanopyHeight ! zero plane displacement expressed as a fraction of canopy height - real(summa_prec) :: approxDragCoef ! approximate drag coefficient used in the computation of canopy roughness length (-) + real(rk),parameter :: oneThird=1._rk/3._rk ! 1/3 + real(rk),parameter :: twoThirds=2._rk/3._rk ! 2/3 + real(rk),parameter :: C_r = 0.3 ! roughness element drag coefficient (-) from Raupach (BLM, 1994) + real(rk),parameter :: C_s = 0.003_rk ! substrate surface drag coefficient (-) from Raupach (BLM, 1994) + real(rk),parameter :: approxDragCoef_max = 0.3_rk ! maximum value of the approximate drag coefficient (-) from Raupach (BLM, 1994) + real(rk),parameter :: psi_h = 0.193_rk ! roughness sub-layer influence function (-) from Raupach (BLM, 1994) + real(rk),parameter :: c_d1 = 7.5_rk ! scaling parameter used to define displacement height (-) from Raupach (BLM, 1994) + real(rk),parameter :: cd_CM = 0.2_rk ! mean drag coefficient for individual leaves (-) from Choudhury and Monteith (QJRMS, 1988) + real(rk) :: funcLAI ! temporary variable to calculate zero plane displacement for the canopy + real(rk) :: fracCanopyHeight ! zero plane displacement expressed as a fraction of canopy height + real(rk) :: approxDragCoef ! approximate drag coefficient used in the computation of canopy roughness length (-) ! local variables: resistance - real(summa_prec) :: canopyExNeut ! surface-atmosphere exchange coefficient under neutral conditions (-) - real(summa_prec) :: groundExNeut ! surface-atmosphere exchange coefficient under neutral conditions (-) - real(summa_prec) :: sfc2AtmExchangeCoeff_canopy ! surface-atmosphere exchange coefficient after stability corrections (-) - real(summa_prec) :: groundResistanceNeutral ! ground resistance under neutral conditions (s m-1) - real(summa_prec) :: windConvFactor_fv ! factor to convert friction velocity to wind speed at top of canopy (-) - real(summa_prec) :: windConvFactor ! factor to convert wind speed at top of canopy to wind speed at a given height in the canopy (-) - real(summa_prec) :: referenceHeight ! z0Canopy+zeroPlaneDisplacement (m) - real(summa_prec) :: windspdRefHeight ! windspeed at the reference height (m/s) - real(summa_prec) :: heightAboveGround ! height above the snow surface (m) - real(summa_prec) :: heightCanopyTopAboveSnow ! height at the top of the vegetation canopy relative to snowpack (m) - real(summa_prec) :: heightCanopyBottomAboveSnow ! height at the bottom of the vegetation canopy relative to snowpack (m) - real(summa_prec),parameter :: xTolerance=0.1_summa_prec ! tolerance to handle the transition from exponential to log-below canopy + real(rk) :: canopyExNeut ! surface-atmosphere exchange coefficient under neutral conditions (-) + real(rk) :: groundExNeut ! surface-atmosphere exchange coefficient under neutral conditions (-) + real(rk) :: sfc2AtmExchangeCoeff_canopy ! surface-atmosphere exchange coefficient after stability corrections (-) + real(rk) :: groundResistanceNeutral ! ground resistance under neutral conditions (s m-1) + real(rk) :: windConvFactor_fv ! factor to convert friction velocity to wind speed at top of canopy (-) + real(rk) :: windConvFactor ! factor to convert wind speed at top of canopy to wind speed at a given height in the canopy (-) + real(rk) :: referenceHeight ! z0Canopy+zeroPlaneDisplacement (m) + real(rk) :: windspdRefHeight ! windspeed at the reference height (m/s) + real(rk) :: heightAboveGround ! height above the snow surface (m) + real(rk) :: heightCanopyTopAboveSnow ! height at the top of the vegetation canopy relative to snowpack (m) + real(rk) :: heightCanopyBottomAboveSnow ! height at the bottom of the vegetation canopy relative to snowpack (m) + real(rk),parameter :: xTolerance=0.1_rk ! tolerance to handle the transition from exponential to log-below canopy ! local variables: derivatives - real(summa_prec) :: dFV_dT ! derivative in friction velocity w.r.t. canopy air temperature - real(summa_prec) :: dED_dT ! derivative in eddy diffusivity at the top of the canopy w.r.t. canopy air temperature - real(summa_prec) :: dGR_dT ! derivative in neutral ground resistance w.r.t. canopy air temperature - real(summa_prec) :: tmp1,tmp2 ! temporary variables used in calculation of ground resistance - real(summa_prec) :: dCanopyStabilityCorrection_dRich ! derivative in stability correction w.r.t. Richardson number for the canopy (-) - real(summa_prec) :: dGroundStabilityCorrection_dRich ! derivative in stability correction w.r.t. Richardson number for the ground surface (-) - real(summa_prec) :: dCanopyStabilityCorrection_dAirTemp ! (not used) derivative in stability correction w.r.t. air temperature (K-1) - real(summa_prec) :: dGroundStabilityCorrection_dAirTemp ! (not used) derivative in stability correction w.r.t. air temperature (K-1) - real(summa_prec) :: dCanopyStabilityCorrection_dCasTemp ! derivative in canopy stability correction w.r.t. canopy air space temperature (K-1) - real(summa_prec) :: dGroundStabilityCorrection_dCasTemp ! derivative in ground stability correction w.r.t. canopy air space temperature (K-1) - real(summa_prec) :: dGroundStabilityCorrection_dSfcTemp ! derivative in ground stability correction w.r.t. surface temperature (K-1) - real(summa_prec) :: singleLeafConductance ! leaf boundary layer conductance (m s-1) - real(summa_prec) :: canopyLeafConductance ! leaf boundary layer conductance -- scaled up to the canopy (m s-1) - real(summa_prec) :: leaf2CanopyScaleFactor ! factor to scale from the leaf to the canopy [m s-(1/2)] + real(rk) :: dFV_dT ! derivative in friction velocity w.r.t. canopy air temperature + real(rk) :: dED_dT ! derivative in eddy diffusivity at the top of the canopy w.r.t. canopy air temperature + real(rk) :: dGR_dT ! derivative in neutral ground resistance w.r.t. canopy air temperature + real(rk) :: tmp1,tmp2 ! temporary variables used in calculation of ground resistance + real(rk) :: dCanopyStabilityCorrection_dRich ! derivative in stability correction w.r.t. Richardson number for the canopy (-) + real(rk) :: dGroundStabilityCorrection_dRich ! derivative in stability correction w.r.t. Richardson number for the ground surface (-) + real(rk) :: dCanopyStabilityCorrection_dAirTemp ! (not used) derivative in stability correction w.r.t. air temperature (K-1) + real(rk) :: dGroundStabilityCorrection_dAirTemp ! (not used) derivative in stability correction w.r.t. air temperature (K-1) + real(rk) :: dCanopyStabilityCorrection_dCasTemp ! derivative in canopy stability correction w.r.t. canopy air space temperature (K-1) + real(rk) :: dGroundStabilityCorrection_dCasTemp ! derivative in ground stability correction w.r.t. canopy air space temperature (K-1) + real(rk) :: dGroundStabilityCorrection_dSfcTemp ! derivative in ground stability correction w.r.t. surface temperature (K-1) + real(rk) :: singleLeafConductance ! leaf boundary layer conductance (m s-1) + real(rk) :: canopyLeafConductance ! leaf boundary layer conductance -- scaled up to the canopy (m s-1) + real(rk) :: leaf2CanopyScaleFactor ! factor to scale from the leaf to the canopy [m s-(1/2)] ! ----------------------------------------------------------------------------------------------------------------------------------------- ! initialize error control err=0; message='aeroResist/' @@ -2132,27 +2132,27 @@ subroutine aeroResist(& ! First, calculate new coordinate system above snow - use these to scale wind profiles and resistances ! NOTE: the new coordinate system makes zeroPlaneDisplacement and z0Canopy consistent heightCanopyTopAboveSnow = heightCanopyTop - snowDepth - heightCanopyBottomAboveSnow = max(heightCanopyBottom - snowDepth, 0.0_summa_prec) + heightCanopyBottomAboveSnow = max(heightCanopyBottom - snowDepth, 0.0_rk) select case(ixVegTraits) ! Raupach (BLM 1994) "Simplified expressions..." case(Raupach_BLM1994) ! (compute zero-plane displacement) funcLAI = sqrt(c_d1*exposedVAI) - fracCanopyHeight = -(1._summa_prec - exp(-funcLAI))/funcLAI + 1._summa_prec + fracCanopyHeight = -(1._rk - exp(-funcLAI))/funcLAI + 1._rk zeroPlaneDisplacement = fracCanopyHeight*(heightCanopyTopAboveSnow-heightCanopyBottomAboveSnow)+heightCanopyBottomAboveSnow ! (coupute roughness length of the veg canopy) - approxDragCoef = min( sqrt(C_s + C_r*exposedVAI/2._summa_prec), approxDragCoef_max) - z0Canopy = (1._summa_prec - fracCanopyHeight) * exp(-vkc*approxDragCoef - psi_h) * (heightCanopyTopAboveSnow-heightCanopyBottomAboveSnow) + approxDragCoef = min( sqrt(C_s + C_r*exposedVAI/2._rk), approxDragCoef_max) + z0Canopy = (1._rk - fracCanopyHeight) * exp(-vkc*approxDragCoef - psi_h) * (heightCanopyTopAboveSnow-heightCanopyBottomAboveSnow) ! Choudhury and Monteith (QJRMS 1988) "A four layer model for the heat budget..." case(CM_QJRMS1988) funcLAI = cd_CM*exposedVAI - zeroPlaneDisplacement = 1.1_summa_prec*heightCanopyTopAboveSnow*log(1._summa_prec + funcLAI**0.25_summa_prec) - if(funcLAI < 0.2_summa_prec)then - z0Canopy = z0Ground + 0.3_summa_prec*heightCanopyTopAboveSnow*funcLAI**0.5_summa_prec + zeroPlaneDisplacement = 1.1_rk*heightCanopyTopAboveSnow*log(1._rk + funcLAI**0.25_rk) + if(funcLAI < 0.2_rk)then + z0Canopy = z0Ground + 0.3_rk*heightCanopyTopAboveSnow*funcLAI**0.5_rk else - z0Canopy = 0.3_summa_prec*heightCanopyTopAboveSnow*(1._summa_prec - zeroPlaneDisplacement/heightCanopyTopAboveSnow) + z0Canopy = 0.3_rk*heightCanopyTopAboveSnow*(1._rk - zeroPlaneDisplacement/heightCanopyTopAboveSnow) end if ! constant parameters dependent on the vegetation type @@ -2205,15 +2205,15 @@ subroutine aeroResist(& if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! compute turbulent exchange coefficient (-) - canopyExNeut = (vkc**2._summa_prec) / ( log((mHeight - zeroPlaneDisplacement)/z0Canopy))**2._summa_prec ! coefficient under conditions of neutral stability + canopyExNeut = (vkc**2._rk) / ( log((mHeight - zeroPlaneDisplacement)/z0Canopy))**2._rk ! coefficient under conditions of neutral stability sfc2AtmExchangeCoeff_canopy = canopyExNeut*canopyStabilityCorrection ! after stability corrections ! compute the friction velocity (m s-1) frictionVelocity = windspd * sqrt(sfc2AtmExchangeCoeff_canopy) ! compute the above-canopy resistance (s m-1) - canopyResistance = 1._summa_prec/(sfc2AtmExchangeCoeff_canopy*windspd) - if(canopyResistance < 0._summa_prec)then; err=20; message=trim(message)//'canopy resistance < 0'; return; end if + canopyResistance = 1._rk/(sfc2AtmExchangeCoeff_canopy*windspd) + if(canopyResistance < 0._rk)then; err=20; message=trim(message)//'canopy resistance < 0'; return; end if ! compute windspeed at the top of the canopy above snow depth (m s-1) ! NOTE: stability corrections cancel out @@ -2226,19 +2226,19 @@ subroutine aeroResist(& ! compute windspeed at the height z0Canopy+zeroPlaneDisplacement (m s-1) referenceHeight = z0Canopy+zeroPlaneDisplacement - windConvFactor = exp(-windReductionFactor*(1._summa_prec - (referenceHeight/heightCanopyTopAboveSnow))) + windConvFactor = exp(-windReductionFactor*(1._rk - (referenceHeight/heightCanopyTopAboveSnow))) windspdRefHeight = windspdCanopyTop*windConvFactor ! compute windspeed at the bottom of the canopy relative to the snow depth (m s-1) - windConvFactor = exp(-windReductionFactor*(1._summa_prec - (heightCanopyBottomAboveSnow/heightCanopyTopAboveSnow))) + windConvFactor = exp(-windReductionFactor*(1._rk - (heightCanopyBottomAboveSnow/heightCanopyTopAboveSnow))) windspdCanopyBottom = windspdCanopyTop*windConvFactor ! compute the leaf boundary layer resistance (s m-1) singleLeafConductance = leafExchangeCoeff*sqrt(windspdCanopyTop/leafDimension) - leaf2CanopyScaleFactor = (2._summa_prec/windReductionFactor) * (1._summa_prec - exp(-windReductionFactor/2._summa_prec)) ! factor to scale from the leaf to the canopy + leaf2CanopyScaleFactor = (2._rk/windReductionFactor) * (1._rk - exp(-windReductionFactor/2._rk)) ! factor to scale from the leaf to the canopy canopyLeafConductance = singleLeafConductance*leaf2CanopyScaleFactor - leafResistance = 1._summa_prec/(canopyLeafConductance) - if(leafResistance < 0._summa_prec)then; err=20; message=trim(message)//'leaf resistance < 0'; return; end if + leafResistance = 1._rk/(canopyLeafConductance) + if(leafResistance < 0._rk)then; err=20; message=trim(message)//'leaf resistance < 0'; return; end if ! compute eddy diffusivity for heat at the top of the canopy (m2 s-1) ! Note: use of friction velocity here includes stability adjustments @@ -2265,7 +2265,7 @@ subroutine aeroResist(& tmp2 = exp(-windReductionFactor*(z0Canopy+zeroPlaneDisplacement)/heightCanopyTopAboveSnow) groundResistanceNeutral = ( heightCanopyTopAboveSnow*exp(windReductionFactor) / (windReductionFactor*eddyDiffusCanopyTop) ) * (tmp1 - tmp2) ! (add log-below-canopy component) - groundResistanceNeutral = groundResistanceNeutral + (1._summa_prec/(max(0.1_summa_prec,windspdCanopyBottom)*vkc**2._summa_prec))*(log(heightCanopyBottomAboveSnow/z0Ground))**2._summa_prec + groundResistanceNeutral = groundResistanceNeutral + (1._rk/(max(0.1_rk,windspdCanopyBottom)*vkc**2._rk))*(log(heightCanopyBottomAboveSnow/z0Ground))**2._rk endif ! switch between exponential profile and log-below-canopy @@ -2279,7 +2279,7 @@ subroutine aeroResist(& referenceHeight, & ! input: height of the canopy air space temperature/wind (m) canairTemp, & ! input: temperature of the canopy air space (K) groundTemp, & ! input: temperature of the ground surface (K) - max(0.1_summa_prec,windspdRefHeight), & ! input: wind speed at height z0Canopy+zeroPlaneDisplacement (m s-1) + max(0.1_rk,windspdRefHeight), & ! input: wind speed at height z0Canopy+zeroPlaneDisplacement (m s-1) ! input: stability parameters critRichNumber, & ! input: critical value for the bulk Richardson number where turbulence ceases (-) Louis79_bparam, & ! input: parameter in Louis (1979) stability function @@ -2295,7 +2295,7 @@ subroutine aeroResist(& ! compute the ground resistance groundResistance = groundResistanceNeutral / groundStabilityCorrection - if(groundResistance < 0._summa_prec)then; err=20; message=trim(message)//'ground resistance < 0 [vegetation is present]'; return; end if + if(groundResistance < 0._rk)then; err=20; message=trim(message)//'ground resistance < 0 [vegetation is present]'; return; end if ! ----------------------------------------------------------------------------------------------------------------------------------------- ! ----------------------------------------------------------------------------------------------------------------------------------------- @@ -2303,15 +2303,15 @@ subroutine aeroResist(& else ! no canopy, so set huge resistances (not used) - canopyResistance = 1.e12_summa_prec ! not used: huge resistance, so conductance is essentially zero - leafResistance = 1.e12_summa_prec ! not used: huge resistance, so conductance is essentially zero + canopyResistance = 1.e12_rk ! not used: huge resistance, so conductance is essentially zero + leafResistance = 1.e12_rk ! not used: huge resistance, so conductance is essentially zero ! check that measurement height above the ground surface is above the roughness length if(mHeight < snowDepth+z0Ground)then; err=20; message=trim(message)//'measurement height < snow depth + roughness length'; return; end if ! compute the resistance between the surface and canopy air UNDER NEUTRAL CONDITIONS (s m-1) - groundExNeut = (vkc**2._summa_prec) / ( log((mHeight - snowDepth)/z0Ground)**2._summa_prec) ! turbulent transfer coefficient under conditions of neutral stability (-) - groundResistanceNeutral = 1._summa_prec / (groundExNeut*windspd) + groundExNeut = (vkc**2._rk) / ( log((mHeight - snowDepth)/z0Ground)**2._rk) ! turbulent transfer coefficient under conditions of neutral stability (-) + groundResistanceNeutral = 1._rk / (groundExNeut*windspd) ! define height above the snow surface heightAboveGround = mHeight - snowDepth @@ -2351,7 +2351,7 @@ subroutine aeroResist(& ! compute the ground resistance (after stability corrections) groundResistance = groundResistanceNeutral/groundStabilityCorrection - if(groundResistance < 0._summa_prec)then; err=20; message=trim(message)//'ground resistance < 0 [no vegetation]'; return; end if + if(groundResistance < 0._rk)then; err=20; message=trim(message)//'ground resistance < 0 [no vegetation]'; return; end if ! set all canopy variables to missing (no canopy!) z0Canopy = missingValue ! roughness length of the vegetation canopy (m) @@ -2378,32 +2378,32 @@ subroutine aeroResist(& ! ***** compute derivatives w.r.t. canopy temperature ! NOTE: derivatives are zero because using canopy air space temperature - dCanopyResistance_dTCanopy = 0._summa_prec ! derivative in canopy resistance w.r.t. canopy temperature (s m-1 K-1) - dGroundResistance_dTCanopy = 0._summa_prec ! derivative in ground resistance w.r.t. canopy temperature (s m-1 K-1) + dCanopyResistance_dTCanopy = 0._rk ! derivative in canopy resistance w.r.t. canopy temperature (s m-1 K-1) + dGroundResistance_dTCanopy = 0._rk ! derivative in ground resistance w.r.t. canopy temperature (s m-1 K-1) ! ***** compute derivatives w.r.t. ground temperature (s m-1 K-1) - dGroundResistance_dTGround = -(groundResistanceNeutral*dGroundStabilityCorrection_dSfcTemp)/(groundStabilityCorrection**2._summa_prec) + dGroundResistance_dTGround = -(groundResistanceNeutral*dGroundStabilityCorrection_dSfcTemp)/(groundStabilityCorrection**2._rk) ! ***** compute derivatives w.r.t. temperature of the canopy air space (s m-1 K-1) ! derivative in canopy resistance w.r.t. canopy air temperature (s m-1 K-1) - dCanopyResistance_dTCanair = -dCanopyStabilityCorrection_dCasTemp/(windspd*canopyExNeut*canopyStabilityCorrection**2._summa_prec) + dCanopyResistance_dTCanair = -dCanopyStabilityCorrection_dCasTemp/(windspd*canopyExNeut*canopyStabilityCorrection**2._rk) ! derivative in ground resistance w.r.t. canopy air temperature (s m-1 K-1) ! (compute derivative in NEUTRAL ground resistance w.r.t. canopy air temperature (s m-1 K-1)) - dFV_dT = windspd*canopyExNeut*dCanopyStabilityCorrection_dCasTemp/(sqrt(sfc2AtmExchangeCoeff_canopy)*2._summa_prec) ! d(frictionVelocity)/d(canopy air temperature) + dFV_dT = windspd*canopyExNeut*dCanopyStabilityCorrection_dCasTemp/(sqrt(sfc2AtmExchangeCoeff_canopy)*2._rk) ! d(frictionVelocity)/d(canopy air temperature) dED_dT = dFV_dT*vkc*(heightCanopyTopAboveSnow - zeroPlaneDisplacement) ! d(eddyDiffusCanopyTop)d(canopy air temperature) - dGR_dT = -dED_dT*(tmp1 - tmp2)*heightCanopyTopAboveSnow*exp(windReductionFactor) / (windReductionFactor*eddyDiffusCanopyTop**2._summa_prec) ! d(groundResistanceNeutral)/d(canopy air temperature) + dGR_dT = -dED_dT*(tmp1 - tmp2)*heightCanopyTopAboveSnow*exp(windReductionFactor) / (windReductionFactor*eddyDiffusCanopyTop**2._rk) ! d(groundResistanceNeutral)/d(canopy air temperature) ! (stitch everything together -- product rule) - dGroundResistance_dTCanair = dGR_dT/groundStabilityCorrection - groundResistanceNeutral*dGroundStabilityCorrection_dCasTemp/(groundStabilityCorrection**2._summa_prec) + dGroundResistance_dTCanair = dGR_dT/groundStabilityCorrection - groundResistanceNeutral*dGroundStabilityCorrection_dCasTemp/(groundStabilityCorrection**2._rk) ! ***** compute resistances for non-vegetated surfaces (e.g., snow) else ! set canopy derivatives to zero (non-vegetated, remember) - dCanopyResistance_dTCanopy = 0._summa_prec - dGroundResistance_dTCanopy = 0._summa_prec + dCanopyResistance_dTCanopy = 0._rk + dGroundResistance_dTCanopy = 0._rk ! compute derivatives for ground resistance - dGroundResistance_dTGround = -dGroundStabilityCorrection_dSfcTemp/(windspd*groundExNeut*groundStabilityCorrection**2._summa_prec) + dGroundResistance_dTGround = -dGroundStabilityCorrection_dSfcTemp/(windspd*groundExNeut*groundStabilityCorrection**2._rk) end if ! (switch between vegetated and non-vegetated surfaces) @@ -2456,33 +2456,33 @@ subroutine soilResist(& integer(i4b),intent(in) :: ixSoilResist ! choice of function for the soil moisture control on stomatal resistance integer(i4b),intent(in) :: ixGroundwater ! choice of groundwater representation ! input (variables) - real(summa_prec),intent(in) :: mLayerMatricHead(:) ! matric head in each layer (m) - real(summa_prec),intent(in) :: mLayerVolFracLiq(:) ! volumetric fraction of liquid water in each layer (-) - real(summa_prec),intent(in) :: scalarAquiferStorage ! aquifer storage (m) + real(rk),intent(in) :: mLayerMatricHead(:) ! matric head in each layer (m) + real(rk),intent(in) :: mLayerVolFracLiq(:) ! volumetric fraction of liquid water in each layer (-) + real(rk),intent(in) :: scalarAquiferStorage ! aquifer storage (m) ! input (diagnostic variables) - real(summa_prec),intent(in) :: mLayerRootDensity(:) ! root density in each layer (-) - real(summa_prec),intent(in) :: scalarAquiferRootFrac ! fraction of roots below the lowest unsaturated layer (-) + real(rk),intent(in) :: mLayerRootDensity(:) ! root density in each layer (-) + real(rk),intent(in) :: scalarAquiferRootFrac ! fraction of roots below the lowest unsaturated layer (-) ! input (parameters) - real(summa_prec),intent(in) :: plantWiltPsi ! matric head at wilting point (m) - real(summa_prec),intent(in) :: soilStressParam ! parameter in the exponential soil stress function (-) - real(summa_prec),intent(in) :: critSoilWilting ! critical vol. liq. water content when plants are wilting (-) - real(summa_prec),intent(in) :: critSoilTranspire ! critical vol. liq. water content when transpiration is limited (-) - real(summa_prec),intent(in) :: critAquiferTranspire ! critical aquifer storage value when transpiration is limited (m) + real(rk),intent(in) :: plantWiltPsi ! matric head at wilting point (m) + real(rk),intent(in) :: soilStressParam ! parameter in the exponential soil stress function (-) + real(rk),intent(in) :: critSoilWilting ! critical vol. liq. water content when plants are wilting (-) + real(rk),intent(in) :: critSoilTranspire ! critical vol. liq. water content when transpiration is limited (-) + real(rk),intent(in) :: critAquiferTranspire ! critical aquifer storage value when transpiration is limited (m) ! output - real(summa_prec),intent(out) :: wAvgTranspireLimitFac ! intent(out): weighted average of the transpiration limiting factor (-) - real(summa_prec),intent(out) :: mLayerTranspireLimitFac(:) ! intent(out): transpiration limiting factor in each layer (-) - real(summa_prec),intent(out) :: aquiferTranspireLimitFac ! intent(out): transpiration limiting factor for the aquifer (-) + real(rk),intent(out) :: wAvgTranspireLimitFac ! intent(out): weighted average of the transpiration limiting factor (-) + real(rk),intent(out) :: mLayerTranspireLimitFac(:) ! intent(out): transpiration limiting factor in each layer (-) + real(rk),intent(out) :: aquiferTranspireLimitFac ! intent(out): transpiration limiting factor for the aquifer (-) integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! local variables - real(summa_prec) :: gx ! stress function for the soil layers - real(summa_prec),parameter :: verySmall=epsilon(gx) ! a very small number + real(rk) :: gx ! stress function for the soil layers + real(rk),parameter :: verySmall=epsilon(gx) ! a very small number integer(i4b) :: iLayer ! index of soil layer ! initialize error control err=0; message='soilResist/' ! ** compute the factor limiting transpiration for each soil layer (-) - wAvgTranspireLimitFac = 0._summa_prec ! (initialize the weighted average) + wAvgTranspireLimitFac = 0._rk ! (initialize the weighted average) do iLayer=1,size(mLayerMatricHead) ! compute the soil stress function select case(ixSoilResist) @@ -2490,21 +2490,21 @@ subroutine soilResist(& gx = (mLayerVolFracLiq(iLayer) - critSoilWilting) / (critSoilTranspire - critSoilWilting) case(CLM_Type) ! thresholded linear function of matric head if(mLayerMatricHead(iLayer) > plantWiltPsi)then - gx = 1._summa_prec - mLayerMatricHead(iLayer)/plantWiltPsi + gx = 1._rk - mLayerMatricHead(iLayer)/plantWiltPsi else - gx = 0._summa_prec + gx = 0._rk end if case(SiB_Type) ! exponential of the log of matric head - if(mLayerMatricHead(iLayer) < 0._summa_prec)then ! (unsaturated) - gx = 1._summa_prec - exp( -soilStressParam * ( log(plantWiltPsi/mLayerMatricHead(iLayer)) ) ) + if(mLayerMatricHead(iLayer) < 0._rk)then ! (unsaturated) + gx = 1._rk - exp( -soilStressParam * ( log(plantWiltPsi/mLayerMatricHead(iLayer)) ) ) else ! (saturated) - gx = 1._summa_prec + gx = 1._rk end if case default ! check identified the option err=20; message=trim(message)//'cannot identify option for soil resistance'; return end select ! save the factor for the given layer (ensure between zero and one) - mLayerTranspireLimitFac(iLayer) = min( max(verySmall,gx), 1._summa_prec) + mLayerTranspireLimitFac(iLayer) = min( max(verySmall,gx), 1._rk) ! compute the weighted average (weighted by root density) wAvgTranspireLimitFac = wAvgTranspireLimitFac + mLayerTranspireLimitFac(iLayer)*mLayerRootDensity(iLayer) end do ! (looping through soil layers) @@ -2517,9 +2517,9 @@ subroutine soilResist(& err=20; return end if ! compute the factor limiting evaporation for the aquifer - aquiferTranspireLimitFac = min(scalarAquiferStorage/critAquiferTranspire, 1._summa_prec) + aquiferTranspireLimitFac = min(scalarAquiferStorage/critAquiferTranspire, 1._rk) else ! (if there are roots in the aquifer) - aquiferTranspireLimitFac = 0._summa_prec + aquiferTranspireLimitFac = 0._rk end if ! compute the weighted average (weighted by root density) @@ -2627,138 +2627,138 @@ subroutine turbFluxes(& logical(lgt),intent(in) :: computeVegFlux ! logical flag to compute vegetation fluxes (.false. if veg buried by snow) integer(i4b),intent(in) :: ixDerivMethod ! choice of method used to compute derivative (analytical or numerical) ! input: above-canopy forcing data - real(summa_prec),intent(in) :: airtemp ! air temperature at some height above the surface (K) - real(summa_prec),intent(in) :: airpres ! air pressure of the air above the vegetation canopy (Pa) - real(summa_prec),intent(in) :: VPair ! vapor pressure of the air above the vegetation canopy (Pa) + real(rk),intent(in) :: airtemp ! air temperature at some height above the surface (K) + real(rk),intent(in) :: airpres ! air pressure of the air above the vegetation canopy (Pa) + real(rk),intent(in) :: VPair ! vapor pressure of the air above the vegetation canopy (Pa) ! input: latent heat of sublimation/vaporization - real(summa_prec),intent(in) :: latHeatSubVapCanopy ! latent heat of sublimation/vaporization for the vegetation canopy (J kg-1) - real(summa_prec),intent(in) :: latHeatSubVapGround ! latent heat of sublimation/vaporization for the ground surface (J kg-1) + real(rk),intent(in) :: latHeatSubVapCanopy ! latent heat of sublimation/vaporization for the vegetation canopy (J kg-1) + real(rk),intent(in) :: latHeatSubVapGround ! latent heat of sublimation/vaporization for the ground surface (J kg-1) ! input: canopy and ground temperature - real(summa_prec),intent(in) :: canairTemp ! temperature of the canopy air space (K) - real(summa_prec),intent(in) :: canopyTemp ! canopy temperature (K) - real(summa_prec),intent(in) :: groundTemp ! ground temperature (K) - real(summa_prec),intent(in) :: satVP_CanopyTemp ! saturation vapor pressure at the temperature of the veg canopy (Pa) - real(summa_prec),intent(in) :: satVP_GroundTemp ! saturation vapor pressure at the temperature of the ground (Pa) - real(summa_prec),intent(in) :: dSVPCanopy_dCanopyTemp ! derivative in canopy saturation vapor pressure w.r.t. canopy temperature (Pa K-1) - real(summa_prec),intent(in) :: dSVPGround_dGroundTemp ! derivative in ground saturation vapor pressure w.r.t. ground temperature (Pa K-1) + real(rk),intent(in) :: canairTemp ! temperature of the canopy air space (K) + real(rk),intent(in) :: canopyTemp ! canopy temperature (K) + real(rk),intent(in) :: groundTemp ! ground temperature (K) + real(rk),intent(in) :: satVP_CanopyTemp ! saturation vapor pressure at the temperature of the veg canopy (Pa) + real(rk),intent(in) :: satVP_GroundTemp ! saturation vapor pressure at the temperature of the ground (Pa) + real(rk),intent(in) :: dSVPCanopy_dCanopyTemp ! derivative in canopy saturation vapor pressure w.r.t. canopy temperature (Pa K-1) + real(rk),intent(in) :: dSVPGround_dGroundTemp ! derivative in ground saturation vapor pressure w.r.t. ground temperature (Pa K-1) ! input: diagnostic variables - real(summa_prec),intent(in) :: exposedVAI ! exposed vegetation area index -- leaf plus stem (m2 m-2) - real(summa_prec),intent(in) :: canopyWetFraction ! fraction of canopy that is wet [0-1] - real(summa_prec),intent(in) :: dCanopyWetFraction_dWat ! derivative in the canopy wetted fraction w.r.t. liquid water content (kg-1 m-2) - real(summa_prec),intent(in) :: dCanopyWetFraction_dT ! derivative in the canopy wetted fraction w.r.t. canopy temperature (K-1) - real(summa_prec),intent(in) :: canopySunlitLAI ! sunlit leaf area (-) - real(summa_prec),intent(in) :: canopyShadedLAI ! shaded leaf area (-) - real(summa_prec),intent(in) :: soilRelHumidity ! relative humidity in the soil pores [0-1] - real(summa_prec),intent(in) :: soilResistance ! resistance from the soil (s m-1) - real(summa_prec),intent(in) :: leafResistance ! mean leaf boundary layer resistance per unit leaf area (s m-1) - real(summa_prec),intent(in) :: groundResistance ! below canopy aerodynamic resistance (s m-1) - real(summa_prec),intent(in) :: canopyResistance ! above canopy aerodynamic resistance (s m-1) - real(summa_prec),intent(in) :: stomResistSunlit ! stomatal resistance for sunlit leaves (s m-1) - real(summa_prec),intent(in) :: stomResistShaded ! stomatal resistance for shaded leaves (s m-1) + real(rk),intent(in) :: exposedVAI ! exposed vegetation area index -- leaf plus stem (m2 m-2) + real(rk),intent(in) :: canopyWetFraction ! fraction of canopy that is wet [0-1] + real(rk),intent(in) :: dCanopyWetFraction_dWat ! derivative in the canopy wetted fraction w.r.t. liquid water content (kg-1 m-2) + real(rk),intent(in) :: dCanopyWetFraction_dT ! derivative in the canopy wetted fraction w.r.t. canopy temperature (K-1) + real(rk),intent(in) :: canopySunlitLAI ! sunlit leaf area (-) + real(rk),intent(in) :: canopyShadedLAI ! shaded leaf area (-) + real(rk),intent(in) :: soilRelHumidity ! relative humidity in the soil pores [0-1] + real(rk),intent(in) :: soilResistance ! resistance from the soil (s m-1) + real(rk),intent(in) :: leafResistance ! mean leaf boundary layer resistance per unit leaf area (s m-1) + real(rk),intent(in) :: groundResistance ! below canopy aerodynamic resistance (s m-1) + real(rk),intent(in) :: canopyResistance ! above canopy aerodynamic resistance (s m-1) + real(rk),intent(in) :: stomResistSunlit ! stomatal resistance for sunlit leaves (s m-1) + real(rk),intent(in) :: stomResistShaded ! stomatal resistance for shaded leaves (s m-1) ! input: derivatives in scalar resistances - real(summa_prec),intent(in) :: dGroundResistance_dTGround ! derivative in ground resistance w.r.t. ground temperature (s m-1 K-1) - real(summa_prec),intent(in) :: dGroundResistance_dTCanopy ! derivative in ground resistance w.r.t. canopy temperature (s m-1 K-1) - real(summa_prec),intent(in) :: dGroundResistance_dTCanair ! derivative in ground resistance w.r.t. canopy air temperature (s m-1 K-1) - real(summa_prec),intent(in) :: dCanopyResistance_dTCanopy ! derivative in canopy resistance w.r.t. canopy temperature (s m-1 K-1) - real(summa_prec),intent(in) :: dCanopyResistance_dTCanair ! derivative in canopy resistance w.r.t. canopy air temperature (s m-1 K-1) + real(rk),intent(in) :: dGroundResistance_dTGround ! derivative in ground resistance w.r.t. ground temperature (s m-1 K-1) + real(rk),intent(in) :: dGroundResistance_dTCanopy ! derivative in ground resistance w.r.t. canopy temperature (s m-1 K-1) + real(rk),intent(in) :: dGroundResistance_dTCanair ! derivative in ground resistance w.r.t. canopy air temperature (s m-1 K-1) + real(rk),intent(in) :: dCanopyResistance_dTCanopy ! derivative in canopy resistance w.r.t. canopy temperature (s m-1 K-1) + real(rk),intent(in) :: dCanopyResistance_dTCanair ! derivative in canopy resistance w.r.t. canopy air temperature (s m-1 K-1) ! --------------------------------------------------------------------------------------------------------------------------------------------------------------- ! output: conductances -- used to test derivatives - real(summa_prec),intent(out) :: leafConductance ! leaf conductance (m s-1) - real(summa_prec),intent(out) :: canopyConductance ! canopy conductance (m s-1) - real(summa_prec),intent(out) :: groundConductanceSH ! ground conductance for sensible heat (m s-1) - real(summa_prec),intent(out) :: groundConductanceLH ! ground conductance for latent heat -- includes soil resistance (m s-1) - real(summa_prec),intent(out) :: evapConductance ! conductance for evaporation (m s-1) - real(summa_prec),intent(out) :: transConductance ! conductance for transpiration (m s-1) - real(summa_prec),intent(out) :: totalConductanceSH ! total conductance for sensible heat (m s-1) - real(summa_prec),intent(out) :: totalConductanceLH ! total conductance for latent heat (m s-1) + real(rk),intent(out) :: leafConductance ! leaf conductance (m s-1) + real(rk),intent(out) :: canopyConductance ! canopy conductance (m s-1) + real(rk),intent(out) :: groundConductanceSH ! ground conductance for sensible heat (m s-1) + real(rk),intent(out) :: groundConductanceLH ! ground conductance for latent heat -- includes soil resistance (m s-1) + real(rk),intent(out) :: evapConductance ! conductance for evaporation (m s-1) + real(rk),intent(out) :: transConductance ! conductance for transpiration (m s-1) + real(rk),intent(out) :: totalConductanceSH ! total conductance for sensible heat (m s-1) + real(rk),intent(out) :: totalConductanceLH ! total conductance for latent heat (m s-1) ! output: canopy air space variables - real(summa_prec),intent(out) :: VP_CanopyAir ! vapor pressure of the canopy air space (Pa) + real(rk),intent(out) :: VP_CanopyAir ! vapor pressure of the canopy air space (Pa) ! output: fluxes from the vegetation canopy - real(summa_prec),intent(out) :: senHeatCanopy ! sensible heat flux from the canopy to the canopy air space (W m-2) - real(summa_prec),intent(out) :: latHeatCanopyEvap ! latent heat flux associated with evaporation from the canopy to the canopy air space (W m-2) - real(summa_prec),intent(out) :: latHeatCanopyTrans ! latent heat flux associated with transpiration from the canopy to the canopy air space (W m-2) + real(rk),intent(out) :: senHeatCanopy ! sensible heat flux from the canopy to the canopy air space (W m-2) + real(rk),intent(out) :: latHeatCanopyEvap ! latent heat flux associated with evaporation from the canopy to the canopy air space (W m-2) + real(rk),intent(out) :: latHeatCanopyTrans ! latent heat flux associated with transpiration from the canopy to the canopy air space (W m-2) ! output: fluxes from non-vegetated surfaces (ground surface below vegetation, bare ground, or snow covered vegetation) - real(summa_prec),intent(out) :: senHeatGround ! sensible heat flux from ground surface below vegetation, bare ground, or snow covered vegetation (W m-2) - real(summa_prec),intent(out) :: latHeatGround ! latent heat flux from ground surface below vegetation, bare ground, or snow covered vegetation (W m-2) + real(rk),intent(out) :: senHeatGround ! sensible heat flux from ground surface below vegetation, bare ground, or snow covered vegetation (W m-2) + real(rk),intent(out) :: latHeatGround ! latent heat flux from ground surface below vegetation, bare ground, or snow covered vegetation (W m-2) ! output: total heat fluxes to the atmosphere - real(summa_prec),intent(out) :: senHeatTotal ! total sensible heat flux to the atmosphere (W m-2) - real(summa_prec),intent(out) :: latHeatTotal ! total latent heat flux to the atmosphere (W m-2) + real(rk),intent(out) :: senHeatTotal ! total sensible heat flux to the atmosphere (W m-2) + real(rk),intent(out) :: latHeatTotal ! total latent heat flux to the atmosphere (W m-2) ! output: net fluxes - real(summa_prec),intent(out) :: turbFluxCanair ! net turbulent heat fluxes at the canopy air space (W m-2) - real(summa_prec),intent(out) :: turbFluxCanopy ! net turbulent heat fluxes at the canopy (W m-2) - real(summa_prec),intent(out) :: turbFluxGround ! net turbulent heat fluxes at the ground surface (W m-2) + real(rk),intent(out) :: turbFluxCanair ! net turbulent heat fluxes at the canopy air space (W m-2) + real(rk),intent(out) :: turbFluxCanopy ! net turbulent heat fluxes at the canopy (W m-2) + real(rk),intent(out) :: turbFluxGround ! net turbulent heat fluxes at the ground surface (W m-2) ! output: energy flux derivatives - real(summa_prec),intent(out) :: dTurbFluxCanair_dTCanair ! derivative in net canopy air space fluxes w.r.t. canopy air temperature (W m-2 K-1) - real(summa_prec),intent(out) :: dTurbFluxCanair_dTCanopy ! derivative in net canopy air space fluxes w.r.t. canopy temperature (W m-2 K-1) - real(summa_prec),intent(out) :: dTurbFluxCanair_dTGround ! derivative in net canopy air space fluxes w.r.t. ground temperature (W m-2 K-1) - real(summa_prec),intent(out) :: dTurbFluxCanopy_dTCanair ! derivative in net canopy turbulent fluxes w.r.t. canopy air temperature (W m-2 K-1) - real(summa_prec),intent(out) :: dTurbFluxCanopy_dTCanopy ! derivative in net canopy turbulent fluxes w.r.t. canopy temperature (W m-2 K-1) - real(summa_prec),intent(out) :: dTurbFluxCanopy_dTGround ! derivative in net canopy turbulent fluxes w.r.t. ground temperature (W m-2 K-1) - real(summa_prec),intent(out) :: dTurbFluxGround_dTCanair ! derivative in net ground turbulent fluxes w.r.t. canopy air temperature (W m-2 K-1) - real(summa_prec),intent(out) :: dTurbFluxGround_dTCanopy ! derivative in net ground turbulent fluxes w.r.t. canopy temperature (W m-2 K-1) - real(summa_prec),intent(out) :: dTurbFluxGround_dTGround ! derivative in net ground turbulent fluxes w.r.t. ground temperature (W m-2 K-1) + real(rk),intent(out) :: dTurbFluxCanair_dTCanair ! derivative in net canopy air space fluxes w.r.t. canopy air temperature (W m-2 K-1) + real(rk),intent(out) :: dTurbFluxCanair_dTCanopy ! derivative in net canopy air space fluxes w.r.t. canopy temperature (W m-2 K-1) + real(rk),intent(out) :: dTurbFluxCanair_dTGround ! derivative in net canopy air space fluxes w.r.t. ground temperature (W m-2 K-1) + real(rk),intent(out) :: dTurbFluxCanopy_dTCanair ! derivative in net canopy turbulent fluxes w.r.t. canopy air temperature (W m-2 K-1) + real(rk),intent(out) :: dTurbFluxCanopy_dTCanopy ! derivative in net canopy turbulent fluxes w.r.t. canopy temperature (W m-2 K-1) + real(rk),intent(out) :: dTurbFluxCanopy_dTGround ! derivative in net canopy turbulent fluxes w.r.t. ground temperature (W m-2 K-1) + real(rk),intent(out) :: dTurbFluxGround_dTCanair ! derivative in net ground turbulent fluxes w.r.t. canopy air temperature (W m-2 K-1) + real(rk),intent(out) :: dTurbFluxGround_dTCanopy ! derivative in net ground turbulent fluxes w.r.t. canopy temperature (W m-2 K-1) + real(rk),intent(out) :: dTurbFluxGround_dTGround ! derivative in net ground turbulent fluxes w.r.t. ground temperature (W m-2 K-1) ! output: liquid flux derivatives (canopy evap) - real(summa_prec),intent(out) :: dLatHeatCanopyEvap_dCanLiq ! derivative in latent heat of canopy evaporation w.r.t. canopy liquid water content (W kg-1) - real(summa_prec),intent(out) :: dLatHeatCanopyEvap_dTCanair ! derivative in latent heat of canopy evaporation w.r.t. canopy air temperature (W m-2 K-1) - real(summa_prec),intent(out) :: dLatHeatCanopyEvap_dTCanopy ! derivative in latent heat of canopy evaporation w.r.t. canopy temperature (W m-2 K-1) - real(summa_prec),intent(out) :: dLatHeatCanopyEvap_dTGround ! derivative in latent heat of canopy evaporation w.r.t. ground temperature (W m-2 K-1) + real(rk),intent(out) :: dLatHeatCanopyEvap_dCanLiq ! derivative in latent heat of canopy evaporation w.r.t. canopy liquid water content (W kg-1) + real(rk),intent(out) :: dLatHeatCanopyEvap_dTCanair ! derivative in latent heat of canopy evaporation w.r.t. canopy air temperature (W m-2 K-1) + real(rk),intent(out) :: dLatHeatCanopyEvap_dTCanopy ! derivative in latent heat of canopy evaporation w.r.t. canopy temperature (W m-2 K-1) + real(rk),intent(out) :: dLatHeatCanopyEvap_dTGround ! derivative in latent heat of canopy evaporation w.r.t. ground temperature (W m-2 K-1) ! output: liquid flux derivatives (ground evap) - real(summa_prec),intent(out) :: dLatHeatGroundEvap_dCanLiq ! derivative in latent heat of ground evaporation w.r.t. canopy liquid water content (J kg-1 s-1) - real(summa_prec),intent(out) :: dLatHeatGroundEvap_dTCanair ! derivative in latent heat of ground evaporation w.r.t. canopy air temperature (W m-2 K-1) - real(summa_prec),intent(out) :: dLatHeatGroundEvap_dTCanopy ! derivative in latent heat of ground evaporation w.r.t. canopy temperature (W m-2 K-1) - real(summa_prec),intent(out) :: dLatHeatGroundEvap_dTGround ! derivative in latent heat of ground evaporation w.r.t. ground temperature (W m-2 K-1) + real(rk),intent(out) :: dLatHeatGroundEvap_dCanLiq ! derivative in latent heat of ground evaporation w.r.t. canopy liquid water content (J kg-1 s-1) + real(rk),intent(out) :: dLatHeatGroundEvap_dTCanair ! derivative in latent heat of ground evaporation w.r.t. canopy air temperature (W m-2 K-1) + real(rk),intent(out) :: dLatHeatGroundEvap_dTCanopy ! derivative in latent heat of ground evaporation w.r.t. canopy temperature (W m-2 K-1) + real(rk),intent(out) :: dLatHeatGroundEvap_dTGround ! derivative in latent heat of ground evaporation w.r.t. ground temperature (W m-2 K-1) ! output: cross derivatives - real(summa_prec),intent(out) :: dTurbFluxCanair_dCanLiq ! derivative in net canopy air space fluxes w.r.t. canopy liquid water content (J kg-1 s-1) - real(summa_prec),intent(out) :: dTurbFluxCanopy_dCanLiq ! derivative in net canopy turbulent fluxes w.r.t. canopy liquid water content (J kg-1 s-1) - real(summa_prec),intent(out) :: dTurbFluxGround_dCanLiq ! derivative in net ground turbulent fluxes w.r.t. canopy liquid water content (J kg-1 s-1) + real(rk),intent(out) :: dTurbFluxCanair_dCanLiq ! derivative in net canopy air space fluxes w.r.t. canopy liquid water content (J kg-1 s-1) + real(rk),intent(out) :: dTurbFluxCanopy_dCanLiq ! derivative in net canopy turbulent fluxes w.r.t. canopy liquid water content (J kg-1 s-1) + real(rk),intent(out) :: dTurbFluxGround_dCanLiq ! derivative in net ground turbulent fluxes w.r.t. canopy liquid water content (J kg-1 s-1) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! ----------------------------------------------------------------------------------------------------------------------------------------- ! local variables -- general - real(summa_prec) :: fpart1,fpart2 ! different parts of a function - real(summa_prec) :: dPart0,dpart1,dpart2 ! derivatives for different parts of a function + real(rk) :: fpart1,fpart2 ! different parts of a function + real(rk) :: dPart0,dpart1,dpart2 ! derivatives for different parts of a function ! local variables -- "constants" - real(summa_prec) :: volHeatCapacityAir ! volumetric heat capacity of air (J m-3) - real(summa_prec) :: latentHeatConstant ! latent heat constant (kg m-3 K-1) + real(rk) :: volHeatCapacityAir ! volumetric heat capacity of air (J m-3) + real(rk) :: latentHeatConstant ! latent heat constant (kg m-3 K-1) ! local variables -- derivatives for energy conductances - real(summa_prec) :: dEvapCond_dCanopyTemp ! derivative in evap conductance w.r.t. canopy temperature - real(summa_prec) :: dTransCond_dCanopyTemp ! derivative in trans conductance w.r.t. canopy temperature - real(summa_prec) :: dCanopyCond_dCanairTemp ! derivative in canopy conductance w.r.t. canopy air temperature - real(summa_prec) :: dCanopyCond_dCanopyTemp ! derivative in canopy conductance w.r.t. canopy temperature - real(summa_prec) :: dGroundCondSH_dCanairTemp ! derivative in ground conductance of sensible heat w.r.t. canopy air temperature - real(summa_prec) :: dGroundCondSH_dCanopyTemp ! derivative in ground conductance of sensible heat w.r.t. canopy temperature - real(summa_prec) :: dGroundCondSH_dGroundTemp ! derivative in ground conductance of sensible heat w.r.t. ground temperature + real(rk) :: dEvapCond_dCanopyTemp ! derivative in evap conductance w.r.t. canopy temperature + real(rk) :: dTransCond_dCanopyTemp ! derivative in trans conductance w.r.t. canopy temperature + real(rk) :: dCanopyCond_dCanairTemp ! derivative in canopy conductance w.r.t. canopy air temperature + real(rk) :: dCanopyCond_dCanopyTemp ! derivative in canopy conductance w.r.t. canopy temperature + real(rk) :: dGroundCondSH_dCanairTemp ! derivative in ground conductance of sensible heat w.r.t. canopy air temperature + real(rk) :: dGroundCondSH_dCanopyTemp ! derivative in ground conductance of sensible heat w.r.t. canopy temperature + real(rk) :: dGroundCondSH_dGroundTemp ! derivative in ground conductance of sensible heat w.r.t. ground temperature ! local variables -- derivatives for mass conductances - real(summa_prec) :: dGroundCondLH_dCanairTemp ! derivative in ground conductance w.r.t. canopy air temperature - real(summa_prec) :: dGroundCondLH_dCanopyTemp ! derivative in ground conductance w.r.t. canopy temperature - real(summa_prec) :: dGroundCondLH_dGroundTemp ! derivative in ground conductance w.r.t. ground temperature + real(rk) :: dGroundCondLH_dCanairTemp ! derivative in ground conductance w.r.t. canopy air temperature + real(rk) :: dGroundCondLH_dCanopyTemp ! derivative in ground conductance w.r.t. canopy temperature + real(rk) :: dGroundCondLH_dGroundTemp ! derivative in ground conductance w.r.t. ground temperature ! local variables -- derivatives for the canopy air space variables - real(summa_prec) :: fPart_VP ! part of the function for vapor pressure of the canopy air space - real(summa_prec) :: leafConductanceTr ! leaf conductance for transpiration (m s-1) - real(summa_prec) :: dVPCanopyAir_dTCanair ! derivative in the vapor pressure of the canopy air space w.r.t. temperature of the canopy air space - real(summa_prec) :: dVPCanopyAir_dTCanopy ! derivative in the vapor pressure of the canopy air space w.r.t. temperature of the canopy - real(summa_prec) :: dVPCanopyAir_dTGround ! derivative in the vapor pressure of the canopy air space w.r.t. temperature of the ground - real(summa_prec) :: dVPCanopyAir_dWetFrac ! derivative of vapor pressure in the canopy air space w.r.t. wetted fraction of the canopy - real(summa_prec) :: dVPCanopyAir_dCanLiq ! derivative of vapor pressure in the canopy air space w.r.t. canopy liquid water content + real(rk) :: fPart_VP ! part of the function for vapor pressure of the canopy air space + real(rk) :: leafConductanceTr ! leaf conductance for transpiration (m s-1) + real(rk) :: dVPCanopyAir_dTCanair ! derivative in the vapor pressure of the canopy air space w.r.t. temperature of the canopy air space + real(rk) :: dVPCanopyAir_dTCanopy ! derivative in the vapor pressure of the canopy air space w.r.t. temperature of the canopy + real(rk) :: dVPCanopyAir_dTGround ! derivative in the vapor pressure of the canopy air space w.r.t. temperature of the ground + real(rk) :: dVPCanopyAir_dWetFrac ! derivative of vapor pressure in the canopy air space w.r.t. wetted fraction of the canopy + real(rk) :: dVPCanopyAir_dCanLiq ! derivative of vapor pressure in the canopy air space w.r.t. canopy liquid water content ! local variables -- sensible heat flux derivatives - real(summa_prec) :: dSenHeatTotal_dTCanair ! derivative in the total sensible heat flux w.r.t. canopy air temperature - real(summa_prec) :: dSenHeatTotal_dTCanopy ! derivative in the total sensible heat flux w.r.t. canopy air temperature - real(summa_prec) :: dSenHeatTotal_dTGround ! derivative in the total sensible heat flux w.r.t. ground temperature - real(summa_prec) :: dSenHeatCanopy_dTCanair ! derivative in the canopy sensible heat flux w.r.t. canopy air temperature - real(summa_prec) :: dSenHeatCanopy_dTCanopy ! derivative in the canopy sensible heat flux w.r.t. canopy temperature - real(summa_prec) :: dSenHeatCanopy_dTGround ! derivative in the canopy sensible heat flux w.r.t. ground temperature - real(summa_prec) :: dSenHeatGround_dTCanair ! derivative in the ground sensible heat flux w.r.t. canopy air temperature - real(summa_prec) :: dSenHeatGround_dTCanopy ! derivative in the ground sensible heat flux w.r.t. canopy temperature - real(summa_prec) :: dSenHeatGround_dTGround ! derivative in the ground sensible heat flux w.r.t. ground temperature + real(rk) :: dSenHeatTotal_dTCanair ! derivative in the total sensible heat flux w.r.t. canopy air temperature + real(rk) :: dSenHeatTotal_dTCanopy ! derivative in the total sensible heat flux w.r.t. canopy air temperature + real(rk) :: dSenHeatTotal_dTGround ! derivative in the total sensible heat flux w.r.t. ground temperature + real(rk) :: dSenHeatCanopy_dTCanair ! derivative in the canopy sensible heat flux w.r.t. canopy air temperature + real(rk) :: dSenHeatCanopy_dTCanopy ! derivative in the canopy sensible heat flux w.r.t. canopy temperature + real(rk) :: dSenHeatCanopy_dTGround ! derivative in the canopy sensible heat flux w.r.t. ground temperature + real(rk) :: dSenHeatGround_dTCanair ! derivative in the ground sensible heat flux w.r.t. canopy air temperature + real(rk) :: dSenHeatGround_dTCanopy ! derivative in the ground sensible heat flux w.r.t. canopy temperature + real(rk) :: dSenHeatGround_dTGround ! derivative in the ground sensible heat flux w.r.t. ground temperature ! local variables -- latent heat flux derivatives - real(summa_prec) :: dLatHeatCanopyTrans_dTCanair ! derivative in the canopy transpiration flux w.r.t. canopy air temperature - real(summa_prec) :: dLatHeatCanopyTrans_dTCanopy ! derivative in the canopy transpiration flux w.r.t. canopy temperature - real(summa_prec) :: dLatHeatCanopyTrans_dTGround ! derivative in the canopy transpiration flux w.r.t. ground temperature + real(rk) :: dLatHeatCanopyTrans_dTCanair ! derivative in the canopy transpiration flux w.r.t. canopy air temperature + real(rk) :: dLatHeatCanopyTrans_dTCanopy ! derivative in the canopy transpiration flux w.r.t. canopy temperature + real(rk) :: dLatHeatCanopyTrans_dTGround ! derivative in the canopy transpiration flux w.r.t. ground temperature ! local variables -- wetted fraction derivatives - real(summa_prec) :: dLatHeatCanopyEvap_dWetFrac ! derivative in the latent heat of canopy evaporation w.r.t. canopy wet fraction (W m-2) - real(summa_prec) :: dLatHeatCanopyTrans_dWetFrac ! derivative in the latent heat of canopy transpiration w.r.t. canopy wet fraction (W m-2) - real(summa_prec) :: dLatHeatCanopyTrans_dCanLiq ! derivative in the latent heat of canopy transpiration w.r.t. canopy liquid water (J kg-1 s-1) + real(rk) :: dLatHeatCanopyEvap_dWetFrac ! derivative in the latent heat of canopy evaporation w.r.t. canopy wet fraction (W m-2) + real(rk) :: dLatHeatCanopyTrans_dWetFrac ! derivative in the latent heat of canopy transpiration w.r.t. canopy wet fraction (W m-2) + real(rk) :: dLatHeatCanopyTrans_dCanLiq ! derivative in the latent heat of canopy transpiration w.r.t. canopy liquid water (J kg-1 s-1) ! ----------------------------------------------------------------------------------------------------------------------------------------- ! initialize error control err=0; message='turbFluxes/' @@ -2775,12 +2775,12 @@ subroutine turbFluxes(& if(computeVegFlux)then leafConductance = exposedVAI/leafResistance leafConductanceTr = canopySunlitLAI/(leafResistance+stomResistSunlit) + canopyShadedLAI/(leafResistance+stomResistShaded) - canopyConductance = 1._summa_prec/canopyResistance + canopyConductance = 1._rk/canopyResistance else - leafConductance = 0._summa_prec - canopyConductance = 0._summa_prec + leafConductance = 0._rk + canopyConductance = 0._rk end if - groundConductanceSH = 1._summa_prec/groundResistance + groundConductanceSH = 1._rk/groundResistance ! compute total conductance for sensible heat totalConductanceSH = leafConductance + groundConductanceSH + canopyConductance @@ -2788,14 +2788,14 @@ subroutine turbFluxes(& ! compute conductances for latent heat (m s-1) if(computeVegFlux)then evapConductance = canopyWetFraction*leafConductance - transConductance = (1._summa_prec - canopyWetFraction) * leafConductanceTr + transConductance = (1._rk - canopyWetFraction) * leafConductanceTr !write(*,'(a,10(f14.8,1x))') 'canopySunlitLAI, canopyShadedLAI, stomResistSunlit, stomResistShaded, leafResistance, canopyWetFraction = ', & ! canopySunlitLAI, canopyShadedLAI, stomResistSunlit, stomResistShaded, leafResistance, canopyWetFraction else - evapConductance = 0._summa_prec - transConductance = 0._summa_prec + evapConductance = 0._rk + transConductance = 0._rk end if - groundConductanceLH = 1._summa_prec/(groundResistance + soilResistance) ! NOTE: soilResistance accounts for fractional snow, and =0 when snow cover is 100% + groundConductanceLH = 1._rk/(groundResistance + soilResistance) ! NOTE: soilResistance accounts for fractional snow, and =0 when snow cover is 100% totalConductanceLH = evapConductance + transConductance + groundConductanceLH + canopyConductance ! check sensible heat conductance @@ -2818,30 +2818,30 @@ subroutine turbFluxes(& if(computeVegFlux)then dEvapCond_dCanopyTemp = dCanopyWetFraction_dT*leafConductance ! derivative in evap conductance w.r.t. canopy temperature dTransCond_dCanopyTemp = -dCanopyWetFraction_dT*leafConductanceTr ! derivative in trans conductance w.r.t. canopy temperature - dCanopyCond_dCanairTemp = -dCanopyResistance_dTCanair/canopyResistance**2._summa_prec ! derivative in canopy conductance w.r.t. canopy air emperature - dCanopyCond_dCanopyTemp = -dCanopyResistance_dTCanopy/canopyResistance**2._summa_prec ! derivative in canopy conductance w.r.t. canopy temperature - dGroundCondSH_dCanairTemp = -dGroundResistance_dTCanair/groundResistance**2._summa_prec ! derivative in ground conductance w.r.t. canopy air temperature - dGroundCondSH_dCanopyTemp = -dGroundResistance_dTCanopy/groundResistance**2._summa_prec ! derivative in ground conductance w.r.t. canopy temperature - dGroundCondSH_dGroundTemp = -dGroundResistance_dTGround/groundResistance**2._summa_prec ! derivative in ground conductance w.r.t. ground temperature + dCanopyCond_dCanairTemp = -dCanopyResistance_dTCanair/canopyResistance**2._rk ! derivative in canopy conductance w.r.t. canopy air emperature + dCanopyCond_dCanopyTemp = -dCanopyResistance_dTCanopy/canopyResistance**2._rk ! derivative in canopy conductance w.r.t. canopy temperature + dGroundCondSH_dCanairTemp = -dGroundResistance_dTCanair/groundResistance**2._rk ! derivative in ground conductance w.r.t. canopy air temperature + dGroundCondSH_dCanopyTemp = -dGroundResistance_dTCanopy/groundResistance**2._rk ! derivative in ground conductance w.r.t. canopy temperature + dGroundCondSH_dGroundTemp = -dGroundResistance_dTGround/groundResistance**2._rk ! derivative in ground conductance w.r.t. ground temperature else - dEvapCond_dCanopyTemp = 0._summa_prec ! derivative in evap conductance w.r.t. canopy temperature - dTransCond_dCanopyTemp = 0._summa_prec ! derivative in trans conductance w.r.t. canopy temperature - dCanopyCond_dCanairTemp = 0._summa_prec ! derivative in canopy conductance w.r.t. canopy air emperature - dCanopyCond_dCanopyTemp = 0._summa_prec ! derivative in canopy conductance w.r.t. canopy temperature - dGroundCondSH_dCanairTemp = 0._summa_prec ! derivative in ground conductance w.r.t. canopy air temperature - dGroundCondSH_dCanopyTemp = 0._summa_prec ! derivative in ground conductance w.r.t. canopy temperature - dGroundCondSH_dGroundTemp = -dGroundResistance_dTGround/groundResistance**2._summa_prec ! derivative in ground conductance w.r.t. ground temperature + dEvapCond_dCanopyTemp = 0._rk ! derivative in evap conductance w.r.t. canopy temperature + dTransCond_dCanopyTemp = 0._rk ! derivative in trans conductance w.r.t. canopy temperature + dCanopyCond_dCanairTemp = 0._rk ! derivative in canopy conductance w.r.t. canopy air emperature + dCanopyCond_dCanopyTemp = 0._rk ! derivative in canopy conductance w.r.t. canopy temperature + dGroundCondSH_dCanairTemp = 0._rk ! derivative in ground conductance w.r.t. canopy air temperature + dGroundCondSH_dCanopyTemp = 0._rk ! derivative in ground conductance w.r.t. canopy temperature + dGroundCondSH_dGroundTemp = -dGroundResistance_dTGround/groundResistance**2._rk ! derivative in ground conductance w.r.t. ground temperature end if ! compute derivatives in individual conductances for latent heat w.r.t. canopy temperature (m s-1 K-1) if(computeVegFlux)then - dGroundCondLH_dCanairTemp = -dGroundResistance_dTCanair/(groundResistance+soilResistance)**2._summa_prec ! derivative in ground conductance w.r.t. canopy air temperature - dGroundCondLH_dCanopyTemp = -dGroundResistance_dTCanopy/(groundResistance+soilResistance)**2._summa_prec ! derivative in ground conductance w.r.t. canopy temperature - dGroundCondLH_dGroundTemp = -dGroundResistance_dTGround/(groundResistance+soilResistance)**2._summa_prec ! derivative in ground conductance w.r.t. ground temperature + dGroundCondLH_dCanairTemp = -dGroundResistance_dTCanair/(groundResistance+soilResistance)**2._rk ! derivative in ground conductance w.r.t. canopy air temperature + dGroundCondLH_dCanopyTemp = -dGroundResistance_dTCanopy/(groundResistance+soilResistance)**2._rk ! derivative in ground conductance w.r.t. canopy temperature + dGroundCondLH_dGroundTemp = -dGroundResistance_dTGround/(groundResistance+soilResistance)**2._rk ! derivative in ground conductance w.r.t. ground temperature else - dGroundCondLH_dCanairTemp = 0._summa_prec ! derivative in ground conductance w.r.t. canopy air temperature - dGroundCondLH_dCanopyTemp = 0._summa_prec ! derivative in ground conductance w.r.t. canopy temperature - dGroundCondLH_dGroundTemp = -dGroundResistance_dTGround/(groundResistance+soilResistance)**2._summa_prec ! derivative in ground conductance w.r.t. ground temperature + dGroundCondLH_dCanairTemp = 0._rk ! derivative in ground conductance w.r.t. canopy air temperature + dGroundCondLH_dCanopyTemp = 0._rk ! derivative in ground conductance w.r.t. canopy temperature + dGroundCondLH_dGroundTemp = -dGroundResistance_dTGround/(groundResistance+soilResistance)**2._rk ! derivative in ground conductance w.r.t. ground temperature end if end if ! (if computing analytical derivatives) @@ -2885,9 +2885,9 @@ subroutine turbFluxes(& ! * no vegetation, so fluxes are zero else - senHeatCanopy = 0._summa_prec - latHeatCanopyEvap = 0._summa_prec - latHeatCanopyTrans = 0._summa_prec + senHeatCanopy = 0._rk + latHeatCanopyEvap = 0._rk + latHeatCanopyTrans = 0._rk end if ! compute sensible and latent heat fluxes from the ground to the canopy air space (W m-2) @@ -2914,20 +2914,20 @@ subroutine turbFluxes(& ! compute derivatives of vapor pressure in the canopy air space w.r.t. all state variables ! (derivative of vapor pressure in the canopy air space w.r.t. temperature of the canopy air space) dPart1 = dCanopyCond_dCanairTemp*VPair + dGroundCondLH_dCanairTemp*satVP_GroundTemp*soilRelHumidity - dPart2 = -(dCanopyCond_dCanairTemp + dGroundCondLH_dCanairTemp)/(totalConductanceLH**2._summa_prec) + dPart2 = -(dCanopyCond_dCanairTemp + dGroundCondLH_dCanairTemp)/(totalConductanceLH**2._rk) dVPCanopyAir_dTCanair = dPart1/totalConductanceLH + fPart_VP*dPart2 ! (derivative of vapor pressure in the canopy air space w.r.t. temperature of the canopy) dPart0 = (evapConductance + transConductance)*dSVPCanopy_dCanopyTemp + (dEvapCond_dCanopyTemp + dTransCond_dCanopyTemp)*satVP_CanopyTemp dPart1 = dCanopyCond_dCanopyTemp*VPair + dPart0 + dGroundCondLH_dCanopyTemp*satVP_GroundTemp*soilRelHumidity - dPart2 = -(dCanopyCond_dCanopyTemp + dEvapCond_dCanopyTemp + dTransCond_dCanopyTemp + dGroundCondLH_dCanopyTemp)/(totalConductanceLH**2._summa_prec) + dPart2 = -(dCanopyCond_dCanopyTemp + dEvapCond_dCanopyTemp + dTransCond_dCanopyTemp + dGroundCondLH_dCanopyTemp)/(totalConductanceLH**2._rk) dVPCanopyAir_dTCanopy = dPart1/totalConductanceLH + fPart_VP*dPart2 ! (derivative of vapor pressure in the canopy air space w.r.t. temperature of the ground) dPart1 = dGroundCondLH_dGroundTemp*satVP_GroundTemp*soilRelHumidity + groundConductanceLH*dSVPGround_dGroundTemp*soilRelHumidity - dPart2 = -dGroundCondLH_dGroundTemp/(totalConductanceLH**2._summa_prec) + dPart2 = -dGroundCondLH_dGroundTemp/(totalConductanceLH**2._rk) dVPCanopyAir_dTGround = dPart1/totalConductanceLH + fPart_VP*dPart2 ! (derivative of vapor pressure in the canopy air space w.r.t. wetted fraction of the canopy) dPart1 = (leafConductance - leafConductanceTr)*satVP_CanopyTemp - dPart2 = -(leafConductance - leafConductanceTr)/(totalConductanceLH**2._summa_prec) + dPart2 = -(leafConductance - leafConductanceTr)/(totalConductanceLH**2._rk) dVPCanopyAir_dWetFrac = dPart1/totalConductanceLH + fPart_VP*dPart2 dVPCanopyAir_dCanLiq = dVPCanopyAir_dWetFrac*dCanopyWetFraction_dWat !write(*,'(a,5(f20.8,1x))') 'dVPCanopyAir_dTCanair, dVPCanopyAir_dTCanopy, dVPCanopyAir_dTGround, dVPCanopyAir_dWetFrac, dVPCanopyAir_dCanLiq = ', & @@ -2936,14 +2936,14 @@ subroutine turbFluxes(& ! sensible heat from the canopy to the atmosphere dSenHeatTotal_dTCanair = -volHeatCapacityAir*canopyConductance - volHeatCapacityAir*dCanopyCond_dCanairTemp*(canairTemp - airtemp) dSenHeatTotal_dTCanopy = -volHeatCapacityAir*dCanopyCond_dCanopyTemp*(canairTemp - airtemp) - dSenHeatTotal_dTGround = 0._summa_prec + dSenHeatTotal_dTGround = 0._rk !write(*,'(a,3(f20.8,1x))') 'dSenHeatTotal_dTCanair, dSenHeatTotal_dTCanopy, dSenHeatTotal_dTGround = ', & ! dSenHeatTotal_dTCanair, dSenHeatTotal_dTCanopy, dSenHeatTotal_dTGround ! sensible heat from the canopy to the canopy air space dSenHeatCanopy_dTCanair = volHeatCapacityAir*leafConductance dSenHeatCanopy_dTCanopy = -volHeatCapacityAir*leafConductance - dSenHeatCanopy_dTGround = 0._summa_prec + dSenHeatCanopy_dTGround = 0._rk !write(*,'(a,3(f20.8,1x))') 'dSenHeatCanopy_dTCanair, dSenHeatCanopy_dTCanopy, dSenHeatCanopy_dTGround = ', & ! dSenHeatCanopy_dTCanair, dSenHeatCanopy_dTCanopy, dSenHeatCanopy_dTGround @@ -2994,7 +2994,7 @@ subroutine turbFluxes(& ! latent heat associated with canopy transpiration w.r.t. wetted fraction of the canopy dPart1 = LH_vap*latentHeatConstant*leafConductanceTr ! NOTE: positive, since (1 - wetFrac) - fPart1 = -dPart1*(1._summa_prec - canopyWetFraction) + fPart1 = -dPart1*(1._rk - canopyWetFraction) dLatHeatCanopyTrans_dWetFrac = dPart1*(satVP_CanopyTemp - VP_CanopyAir) + fPart1*(-dVPCanopyAir_dWetFrac) !print*, 'dLatHeatCanopyTrans_dWetFrac = ', dLatHeatCanopyTrans_dWetFrac @@ -3005,30 +3005,30 @@ subroutine turbFluxes(& else ! canopy is undefined ! set derivatives for canopy fluxes to zero (no canopy, so fluxes are undefined) - dSenHeatTotal_dTCanair = 0._summa_prec - dSenHeatTotal_dTCanopy = 0._summa_prec - dSenHeatTotal_dTGround = 0._summa_prec - dSenHeatCanopy_dTCanair = 0._summa_prec - dSenHeatCanopy_dTCanopy = 0._summa_prec - dSenHeatCanopy_dTGround = 0._summa_prec - dLatHeatCanopyEvap_dTCanair = 0._summa_prec - dLatHeatCanopyEvap_dTCanopy = 0._summa_prec - dLatHeatCanopyEvap_dTGround = 0._summa_prec - dLatHeatCanopyTrans_dTCanair = 0._summa_prec - dLatHeatCanopyTrans_dTCanopy = 0._summa_prec - dLatHeatCanopyTrans_dTGround = 0._summa_prec + dSenHeatTotal_dTCanair = 0._rk + dSenHeatTotal_dTCanopy = 0._rk + dSenHeatTotal_dTGround = 0._rk + dSenHeatCanopy_dTCanair = 0._rk + dSenHeatCanopy_dTCanopy = 0._rk + dSenHeatCanopy_dTGround = 0._rk + dLatHeatCanopyEvap_dTCanair = 0._rk + dLatHeatCanopyEvap_dTCanopy = 0._rk + dLatHeatCanopyEvap_dTGround = 0._rk + dLatHeatCanopyTrans_dTCanair = 0._rk + dLatHeatCanopyTrans_dTCanopy = 0._rk + dLatHeatCanopyTrans_dTGround = 0._rk ! set derivatives for wetted area and canopy transpiration to zero (no canopy, so fluxes are undefined) - dLatHeatCanopyEvap_dWetFrac = 0._summa_prec - dLatHeatCanopyEvap_dCanLiq = 0._summa_prec - dLatHeatCanopyTrans_dCanLiq = 0._summa_prec - dVPCanopyAir_dCanLiq = 0._summa_prec + dLatHeatCanopyEvap_dWetFrac = 0._rk + dLatHeatCanopyEvap_dCanLiq = 0._rk + dLatHeatCanopyTrans_dCanLiq = 0._rk + dVPCanopyAir_dCanLiq = 0._rk ! set derivatives for ground fluxes w.r.t canopy temperature to zero (no canopy, so fluxes are undefined) - dSenHeatGround_dTCanair = 0._summa_prec - dSenHeatGround_dTCanopy = 0._summa_prec - dLatHeatGroundEvap_dTCanair = 0._summa_prec - dLatHeatGroundEvap_dTCanopy = 0._summa_prec + dSenHeatGround_dTCanair = 0._rk + dSenHeatGround_dTCanopy = 0._rk + dLatHeatGroundEvap_dTCanair = 0._rk + dLatHeatGroundEvap_dTCanopy = 0._rk ! compute derivatives for the ground fluxes w.r.t. ground temperature dSenHeatGround_dTGround = (-volHeatCapacityAir*dGroundCondSH_dGroundTemp)*(groundTemp - airtemp) + & ! d(ground sensible heat flux)/d(ground temp) @@ -3069,27 +3069,27 @@ subroutine turbFluxes(& dLatHeatCanopyEvap_dCanLiq = dLatHeatCanopyEvap_dWetFrac*dCanopyWetFraction_dWat ! derivative in latent heat of canopy evaporation w.r.t. canopy liquid water (W kg-1) dLatHeatGroundEvap_dCanLiq = latHeatSubVapGround*latentHeatConstant*groundConductanceLH*dVPCanopyAir_dCanLiq ! derivative in latent heat of ground evaporation w.r.t. canopy liquid water (J kg-1 s-1) ! (cross deriavtives) - dTurbFluxCanair_dCanLiq = 0._summa_prec ! derivative in net canopy air space fluxes w.r.t. canopy liquid water content (J kg-1 s-1) + dTurbFluxCanair_dCanLiq = 0._rk ! derivative in net canopy air space fluxes w.r.t. canopy liquid water content (J kg-1 s-1) dTurbFluxCanopy_dCanLiq = dLatHeatCanopyEvap_dCanLiq + dLatHeatCanopyTrans_dCanLiq ! derivative in net canopy turbulent fluxes w.r.t. canopy liquid water content (J kg-1 s-1) dTurbFluxGround_dCanLiq = dLatHeatGroundEvap_dCanLiq ! derivative in net ground turbulent fluxes w.r.t. canopy liquid water content (J kg-1 s-1) else ! (just make sure we return something) ! (energy derivatives) - dTurbFluxCanair_dTCanair = 0._summa_prec - dTurbFluxCanair_dTCanopy = 0._summa_prec - dTurbFluxCanair_dTGround = 0._summa_prec - dTurbFluxCanopy_dTCanair = 0._summa_prec - dTurbFluxCanopy_dTCanopy = 0._summa_prec - dTurbFluxCanopy_dTGround = 0._summa_prec - dTurbFluxGround_dTCanair = 0._summa_prec - dTurbFluxGround_dTCanopy = 0._summa_prec - dTurbFluxGround_dTGround = 0._summa_prec + dTurbFluxCanair_dTCanair = 0._rk + dTurbFluxCanair_dTCanopy = 0._rk + dTurbFluxCanair_dTGround = 0._rk + dTurbFluxCanopy_dTCanair = 0._rk + dTurbFluxCanopy_dTCanopy = 0._rk + dTurbFluxCanopy_dTGround = 0._rk + dTurbFluxGround_dTCanair = 0._rk + dTurbFluxGround_dTCanopy = 0._rk + dTurbFluxGround_dTGround = 0._rk ! (liquid water derivatives) - dLatHeatCanopyEvap_dCanLiq = 0._summa_prec - dLatHeatGroundEvap_dCanLiq = 0._summa_prec + dLatHeatCanopyEvap_dCanLiq = 0._rk + dLatHeatGroundEvap_dCanLiq = 0._rk ! (cross deriavtives) - dTurbFluxCanair_dCanLiq = 0._summa_prec - dTurbFluxCanopy_dCanLiq = 0._summa_prec - dTurbFluxGround_dCanLiq = 0._summa_prec + dTurbFluxCanair_dCanLiq = 0._rk + dTurbFluxCanopy_dCanLiq = 0._rk + dTurbFluxGround_dCanLiq = 0._rk end if end subroutine turbFluxes @@ -3123,27 +3123,27 @@ subroutine aStability(& logical(lgt),intent(in) :: computeDerivative ! flag to compute the derivative integer(i4b),intent(in) :: ixStability ! choice of stability function ! input: forcing data, diagnostic and state variables - real(summa_prec),intent(in) :: mHeight ! measurement height (m) - real(summa_prec),intent(in) :: airtemp ! air temperature (K) - real(summa_prec),intent(in) :: sfcTemp ! surface temperature (K) - real(summa_prec),intent(in) :: windspd ! wind speed (m s-1) + real(rk),intent(in) :: mHeight ! measurement height (m) + real(rk),intent(in) :: airtemp ! air temperature (K) + real(rk),intent(in) :: sfcTemp ! surface temperature (K) + real(rk),intent(in) :: windspd ! wind speed (m s-1) ! input: stability parameters - real(summa_prec),intent(in) :: critRichNumber ! critical value for the bulk Richardson number where turbulence ceases (-) - real(summa_prec),intent(in) :: Louis79_bparam ! parameter in Louis (1979) stability function - real(summa_prec),intent(in) :: Mahrt87_eScale ! exponential scaling factor in the Mahrt (1987) stability function + real(rk),intent(in) :: critRichNumber ! critical value for the bulk Richardson number where turbulence ceases (-) + real(rk),intent(in) :: Louis79_bparam ! parameter in Louis (1979) stability function + real(rk),intent(in) :: Mahrt87_eScale ! exponential scaling factor in the Mahrt (1987) stability function ! output - real(summa_prec),intent(out) :: RiBulk ! bulk Richardson number (-) - real(summa_prec),intent(out) :: stabilityCorrection ! stability correction for turbulent heat fluxes (-) - real(summa_prec),intent(out) :: dStabilityCorrection_dRich ! derivative in stability correction w.r.t. Richardson number (-) - real(summa_prec),intent(out) :: dStabilityCorrection_dAirTemp ! derivative in stability correction w.r.t. air temperature (K-1) - real(summa_prec),intent(out) :: dStabilityCorrection_dSfcTemp ! derivative in stability correction w.r.t. surface temperature (K-1) + real(rk),intent(out) :: RiBulk ! bulk Richardson number (-) + real(rk),intent(out) :: stabilityCorrection ! stability correction for turbulent heat fluxes (-) + real(rk),intent(out) :: dStabilityCorrection_dRich ! derivative in stability correction w.r.t. Richardson number (-) + real(rk),intent(out) :: dStabilityCorrection_dAirTemp ! derivative in stability correction w.r.t. air temperature (K-1) + real(rk),intent(out) :: dStabilityCorrection_dSfcTemp ! derivative in stability correction w.r.t. surface temperature (K-1) integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! local - real(summa_prec), parameter :: verySmall=1.e-10_summa_prec ! a very small number (avoid stability of zero) - real(summa_prec) :: dRiBulk_dAirTemp ! derivative in the bulk Richardson number w.r.t. air temperature (K-1) - real(summa_prec) :: dRiBulk_dSfcTemp ! derivative in the bulk Richardson number w.r.t. surface temperature (K-1) - real(summa_prec) :: bPrime ! scaled "b" parameter for stability calculations in Louis (1979) + real(rk), parameter :: verySmall=1.e-10_rk ! a very small number (avoid stability of zero) + real(rk) :: dRiBulk_dAirTemp ! derivative in the bulk Richardson number w.r.t. air temperature (K-1) + real(rk) :: dRiBulk_dSfcTemp ! derivative in the bulk Richardson number w.r.t. surface temperature (K-1) + real(rk) :: bPrime ! scaled "b" parameter for stability calculations in Louis (1979) ! ----------------------------------------------------------------------------------------------------------------------------------------- ! initialize error control err=0; message='aStability/' @@ -3164,18 +3164,18 @@ subroutine aStability(& ! set derivative to one if not computing it if(.not.computeDerivative)then - dStabilityCorrection_dRich = 1._summa_prec - dStabilityCorrection_dAirTemp = 1._summa_prec - dStabilityCorrection_dSfcTemp = 1._summa_prec + dStabilityCorrection_dRich = 1._rk + dStabilityCorrection_dAirTemp = 1._rk + dStabilityCorrection_dSfcTemp = 1._rk end if ! ***** process unstable cases - if(RiBulk<0._summa_prec)then + if(RiBulk<0._rk)then ! compute surface-atmosphere exchange coefficient (-) - stabilityCorrection = (1._summa_prec - 16._summa_prec*RiBulk)**0.5_summa_prec + stabilityCorrection = (1._rk - 16._rk*RiBulk)**0.5_rk ! compute derivative in surface-atmosphere exchange coefficient w.r.t. temperature (K-1) if(computeDerivative)then - dStabilityCorrection_dRich = (-16._summa_prec) * 0.5_summa_prec*(1._summa_prec - 16._summa_prec*RiBulk)**(-0.5_summa_prec) + dStabilityCorrection_dRich = (-16._rk) * 0.5_rk*(1._rk - 16._rk*RiBulk)**(-0.5_rk) dStabilityCorrection_dAirTemp = dRiBulk_dAirTemp * dStabilityCorrection_dRich dStabilityCorrection_dSfcTemp = dRiBulk_dSfcTemp * dStabilityCorrection_dRich end if @@ -3188,24 +3188,24 @@ subroutine aStability(& ! ("standard" stability correction, a la Anderson 1976) case(standard) ! compute surface-atmosphere exchange coefficient (-) - if(RiBulk < critRichNumber) stabilityCorrection = (1._summa_prec - 5._summa_prec*RiBulk)**2._summa_prec + if(RiBulk < critRichNumber) stabilityCorrection = (1._rk - 5._rk*RiBulk)**2._rk if(RiBulk >= critRichNumber) stabilityCorrection = verySmall ! compute derivative in surface-atmosphere exchange coefficient w.r.t. temperature (K-1) if(computeDerivative)then - if(RiBulk < critRichNumber) dStabilityCorrection_dRich = (-5._summa_prec) * 2._summa_prec*(1._summa_prec - 5._summa_prec*RiBulk) + if(RiBulk < critRichNumber) dStabilityCorrection_dRich = (-5._rk) * 2._rk*(1._rk - 5._rk*RiBulk) if(RiBulk >= critRichNumber) dStabilityCorrection_dRich = verySmall end if ! (Louis 1979) case(louisInversePower) ! scale the "b" parameter for stable conditions - bprime = Louis79_bparam/2._summa_prec + bprime = Louis79_bparam/2._rk ! compute surface-atmosphere exchange coefficient (-) - stabilityCorrection = 1._summa_prec / ( (1._summa_prec + bprime*RiBulk)**2._summa_prec ) + stabilityCorrection = 1._rk / ( (1._rk + bprime*RiBulk)**2._rk ) if(stabilityCorrection < epsilon(stabilityCorrection)) stabilityCorrection = epsilon(stabilityCorrection) ! compute derivative in surface-atmosphere exchange coefficient w.r.t. temperature (K-1) if(computeDerivative)then - dStabilityCorrection_dRich = bprime * (-2._summa_prec)*(1._summa_prec + bprime*RiBulk)**(-3._summa_prec) + dStabilityCorrection_dRich = bprime * (-2._rk)*(1._rk + bprime*RiBulk)**(-3._rk) end if ! (Mahrt 1987) @@ -3251,36 +3251,36 @@ subroutine bulkRichardson(& err,message) ! output: error control implicit none ! input - real(summa_prec),intent(in) :: airtemp ! air temperature (K) - real(summa_prec),intent(in) :: sfcTemp ! surface temperature (K) - real(summa_prec),intent(in) :: windspd ! wind speed (m s-1) - real(summa_prec),intent(in) :: mHeight ! measurement height (m) + real(rk),intent(in) :: airtemp ! air temperature (K) + real(rk),intent(in) :: sfcTemp ! surface temperature (K) + real(rk),intent(in) :: windspd ! wind speed (m s-1) + real(rk),intent(in) :: mHeight ! measurement height (m) logical(lgt),intent(in) :: computeDerivative ! flag to compute the derivative ! output - real(summa_prec),intent(inout) :: RiBulk ! bulk Richardson number (-) - real(summa_prec),intent(out) :: dRiBulk_dAirTemp ! derivative in the bulk Richardson number w.r.t. air temperature (K-1) - real(summa_prec),intent(out) :: dRiBulk_dSfcTemp ! derivative in the bulk Richardson number w.r.t. surface temperature (K-1) + real(rk),intent(inout) :: RiBulk ! bulk Richardson number (-) + real(rk),intent(out) :: dRiBulk_dAirTemp ! derivative in the bulk Richardson number w.r.t. air temperature (K-1) + real(rk),intent(out) :: dRiBulk_dSfcTemp ! derivative in the bulk Richardson number w.r.t. surface temperature (K-1) integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! local variables - real(summa_prec) :: T_grad ! gradient in temperature between the atmosphere and surface (K) - real(summa_prec) :: T_mean ! mean of the atmosphere and surface temperature (K) - real(summa_prec) :: RiMult ! dimensionless scaling factor (-) + real(rk) :: T_grad ! gradient in temperature between the atmosphere and surface (K) + real(rk) :: T_mean ! mean of the atmosphere and surface temperature (K) + real(rk) :: RiMult ! dimensionless scaling factor (-) ! initialize error control err=0; message='bulkRichardson/' ! compute local variables T_grad = airtemp - sfcTemp - T_mean = 0.5_summa_prec*(airtemp + sfcTemp) + T_mean = 0.5_rk*(airtemp + sfcTemp) RiMult = (gravity*mHeight)/(windspd*windspd) ! compute the Richardson number RiBulk = (T_grad/T_mean) * RiMult ! compute the derivative in the Richardson number if(computeDerivative)then - dRiBulk_dAirTemp = RiMult/T_mean - RiMult*T_grad/(0.5_summa_prec*((airtemp + sfcTemp)**2._summa_prec)) - dRiBulk_dSfcTemp = -RiMult/T_mean - RiMult*T_grad/(0.5_summa_prec*((airtemp + sfcTemp)**2._summa_prec)) + dRiBulk_dAirTemp = RiMult/T_mean - RiMult*T_grad/(0.5_rk*((airtemp + sfcTemp)**2._rk)) + dRiBulk_dSfcTemp = -RiMult/T_mean - RiMult*T_grad/(0.5_rk*((airtemp + sfcTemp)**2._rk)) else - dRiBulk_dAirTemp = 1._summa_prec - dRiBulk_dSfcTemp = 1._summa_prec + dRiBulk_dAirTemp = 1._rk + dRiBulk_dSfcTemp = 1._rk end if end subroutine bulkRichardson diff --git a/build/source/engine/vegPhenlgy.f90 b/build/source/engine/vegPhenlgy.f90 index f46f7fd5e..b830e1a61 100755 --- a/build/source/engine/vegPhenlgy.f90 +++ b/build/source/engine/vegPhenlgy.f90 @@ -58,8 +58,8 @@ module vegPhenlgy_module private public::vegPhenlgy ! algorithmic parameters -real(summa_prec),parameter :: valueMissing=-9999._summa_prec ! missing value, used when diagnostic or state variables are undefined -real(summa_prec),parameter :: verySmall=1.e-6_summa_prec ! used as an additive constant to check if substantial difference among real numbers +real(rk),parameter :: valueMissing=-9999._rk ! missing value, used when diagnostic or state variables are undefined +real(rk),parameter :: verySmall=1.e-6_rk ! used as an additive constant to check if substantial difference among real numbers contains @@ -93,14 +93,14 @@ subroutine vegPhenlgy(& type(var_dlength),intent(inout) :: diag_data ! diagnostic variables for a local HRU ! output logical(lgt),intent(out) :: computeVegFlux ! flag to indicate if we are computing fluxes over vegetation (.false. means veg is buried with snow) - real(summa_prec),intent(out) :: canopyDepth ! canopy depth (m) - real(summa_prec),intent(out) :: exposedVAI ! exposed vegetation area index (LAI + SAI) + real(rk),intent(out) :: canopyDepth ! canopy depth (m) + real(rk),intent(out) :: exposedVAI ! exposed vegetation area index (LAI + SAI) integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! ------------------------------------------------------------------------------------------------- ! local - real(summa_prec) :: notUsed_heightCanopyTop ! height of the top of the canopy layer (m) - real(summa_prec) :: heightAboveSnow ! height top of canopy is above the snow surface (m) + real(rk) :: notUsed_heightCanopyTop ! height of the top of the canopy layer (m) + real(rk) :: heightAboveSnow ! height top of canopy is above the snow surface (m) ! initialize error control err=0; message="vegPhenlgy/" ! ---------------------------------------------------------------------------------------------------------------------------------- @@ -181,7 +181,7 @@ subroutine vegPhenlgy(& heightAboveSnow = heightCanopyTop - scalarSnowDepth ! height top of canopy is above the snow surface (m) ! determine if need to include vegetation in the energy flux routines - computeVegFlux = (exposedVAI > 0.05_summa_prec .and. heightAboveSnow > 0.05_summa_prec) + computeVegFlux = (exposedVAI > 0.05_rk .and. heightAboveSnow > 0.05_rk) !write(*,'(a,1x,i2,1x,L1,1x,10(f12.5,1x))') 'vegTypeIndex, computeVegFlux, heightCanopyTop, heightAboveSnow, scalarSnowDepth = ', & ! vegTypeIndex, computeVegFlux, heightCanopyTop, heightAboveSnow, scalarSnowDepth diff --git a/build/source/engine/vegSWavRad.f90 b/build/source/engine/vegSWavRad.f90 index 72f6c789a..ef6d97f50 100755 --- a/build/source/engine/vegSWavRad.f90 +++ b/build/source/engine/vegSWavRad.f90 @@ -58,10 +58,10 @@ module vegSWavRad_module integer(i4b),parameter :: iLoc = 1 ! i-location integer(i4b),parameter :: jLoc = 1 ! j-location ! algorithmic parameters -real(summa_prec),parameter :: missingValue=-9999._summa_prec ! missing value, used when diagnostic or state variables are undefined -real(summa_prec),parameter :: verySmall=1.e-6_summa_prec ! used as an additive constant to check if substantial difference among real numbers -real(summa_prec),parameter :: mpe=1.e-6_summa_prec ! prevents overflow error if division by zero -real(summa_prec),parameter :: dx=1.e-6_summa_prec ! finite difference increment +real(rk),parameter :: missingValue=-9999._rk ! missing value, used when diagnostic or state variables are undefined +real(rk),parameter :: verySmall=1.e-6_rk ! used as an additive constant to check if substantial difference among real numbers +real(rk),parameter :: mpe=1.e-6_rk ! prevents overflow error if division by zero +real(rk),parameter :: dx=1.e-6_rk ! finite difference increment contains @@ -83,7 +83,7 @@ subroutine vegSWavRad(& USE NOAHMP_ROUTINES,only:radiation ! subroutine to calculate albedo and shortwave radiaiton in the canopy implicit none ! dummy variables - real(summa_prec),intent(in) :: dt ! time step (s) -- only used in Noah-MP radiation, to compute albedo + real(rk),intent(in) :: dt ! time step (s) -- only used in Noah-MP radiation, to compute albedo integer(i4b),intent(in) :: nSnow ! number of snow layers integer(i4b),intent(in) :: nSoil ! number of soil layers integer(i4b),intent(in) :: nLayers ! total number of layers @@ -96,15 +96,15 @@ subroutine vegSWavRad(& character(*),intent(out) :: message ! error message ! local variables character(LEN=256) :: cmessage ! error message of downwind routine - real(summa_prec) :: snowmassPlusNewsnow ! sum of snow mass and new snowfall (kg m-2 [mm]) - real(summa_prec) :: scalarGroundSnowFraction ! snow cover fraction on the ground surface (-) - real(summa_prec),parameter :: scalarVegFraction=1._summa_prec ! vegetation fraction (=1 forces no canopy gaps and open areas in radiation routine) - real(summa_prec) :: scalarTotalReflectedSolar ! total reflected solar radiation (W m-2) - real(summa_prec) :: scalarTotalAbsorbedSolar ! total absorbed solar radiation (W m-2) - real(summa_prec) :: scalarCanopyReflectedSolar ! solar radiation reflected from the canopy (W m-2) - real(summa_prec) :: scalarGroundReflectedSolar ! solar radiation reflected from the ground (W m-2) - real(summa_prec) :: scalarBetweenCanopyGapFraction ! between canopy gap fraction for beam (-) - real(summa_prec) :: scalarWithinCanopyGapFraction ! within canopy gap fraction for beam (-) + real(rk) :: snowmassPlusNewsnow ! sum of snow mass and new snowfall (kg m-2 [mm]) + real(rk) :: scalarGroundSnowFraction ! snow cover fraction on the ground surface (-) + real(rk),parameter :: scalarVegFraction=1._rk ! vegetation fraction (=1 forces no canopy gaps and open areas in radiation routine) + real(rk) :: scalarTotalReflectedSolar ! total reflected solar radiation (W m-2) + real(rk) :: scalarTotalAbsorbedSolar ! total absorbed solar radiation (W m-2) + real(rk) :: scalarCanopyReflectedSolar ! solar radiation reflected from the canopy (W m-2) + real(rk) :: scalarGroundReflectedSolar ! solar radiation reflected from the ground (W m-2) + real(rk) :: scalarBetweenCanopyGapFraction ! between canopy gap fraction for beam (-) + real(rk) :: scalarWithinCanopyGapFraction ! within canopy gap fraction for beam (-) ! ---------------------------------------------------------------------------------------------------------------------------------- ! make association between local variables and the information in the data structures associate(& @@ -160,9 +160,9 @@ subroutine vegSWavRad(& ! compute the ground snow fraction if(nSnow > 0)then - scalarGroundSnowFraction = 1._summa_prec + scalarGroundSnowFraction = 1._rk else - scalarGroundSnowFraction = 0._summa_prec + scalarGroundSnowFraction = 0._rk end if ! (if there is snow on the ground) ! * compute radiation fluxes... @@ -182,7 +182,7 @@ subroutine vegSWavRad(& snowmassPlusNewsnow, & ! intent(in): sum of snow mass and new snowfall (kg m-2 [mm]) dt, & ! intent(in): time step (s) scalarCosZenith, & ! intent(in): cosine of the solar zenith angle (0-1) - scalarSnowDepth*1000._summa_prec, & ! intent(in): snow depth on the ground surface (mm) + scalarSnowDepth*1000._rk, & ! intent(in): snow depth on the ground surface (mm) scalarGroundTemp, & ! intent(in): ground temperature (K) scalarCanopyTemp, & ! intent(in): canopy temperature (K) scalarGroundSnowFraction, & ! intent(in): snow cover fraction (0-1) @@ -311,32 +311,32 @@ subroutine canopy_SW(& integer(i4b),intent(in) :: isc ! soil color index logical(lgt),intent(in) :: computeVegFlux ! logical flag to compute vegetation fluxes (.false. if veg buried by snow) integer(i4b),intent(in) :: ix_canopySrad ! choice of canopy shortwave radiation method - real(summa_prec),intent(in) :: scalarCosZenith ! cosine of the solar zenith angle (0-1) - real(summa_prec),intent(in) :: spectralIncomingDirect(:) ! incoming direct solar radiation in each wave band (w m-2) - real(summa_prec),intent(in) :: spectralIncomingDiffuse(:) ! incoming diffuse solar radiation in each wave band (w m-2) - real(summa_prec),intent(in) :: spectralSnowAlbedoDirect(:) ! direct albedo of snow in each spectral band (-) - real(summa_prec),intent(in) :: spectralSnowAlbedoDiffuse(:) ! diffuse albedo of snow in each spectral band (-) - real(summa_prec),intent(in) :: scalarExposedLAI ! exposed leaf area index after burial by snow (m2 m-2) - real(summa_prec),intent(in) :: scalarExposedSAI ! exposed stem area index after burial by snow (m2 m-2) - real(summa_prec),intent(in) :: scalarVegFraction ! vegetation fraction (=1 forces no canopy gaps and open areas in radiation routine) - real(summa_prec),intent(in) :: scalarCanopyWetFraction ! fraction of canopy that is wet (-) - real(summa_prec),intent(in) :: scalarGroundSnowFraction ! fraction of ground that is snow covered (-) - real(summa_prec),intent(in) :: scalarVolFracLiqUpper ! volumetric liquid water content in the upper-most soil layer (-) - real(summa_prec),intent(in) :: scalarCanopyTempTrial ! trial value of canopy temperature (K) + real(rk),intent(in) :: scalarCosZenith ! cosine of the solar zenith angle (0-1) + real(rk),intent(in) :: spectralIncomingDirect(:) ! incoming direct solar radiation in each wave band (w m-2) + real(rk),intent(in) :: spectralIncomingDiffuse(:) ! incoming diffuse solar radiation in each wave band (w m-2) + real(rk),intent(in) :: spectralSnowAlbedoDirect(:) ! direct albedo of snow in each spectral band (-) + real(rk),intent(in) :: spectralSnowAlbedoDiffuse(:) ! diffuse albedo of snow in each spectral band (-) + real(rk),intent(in) :: scalarExposedLAI ! exposed leaf area index after burial by snow (m2 m-2) + real(rk),intent(in) :: scalarExposedSAI ! exposed stem area index after burial by snow (m2 m-2) + real(rk),intent(in) :: scalarVegFraction ! vegetation fraction (=1 forces no canopy gaps and open areas in radiation routine) + real(rk),intent(in) :: scalarCanopyWetFraction ! fraction of canopy that is wet (-) + real(rk),intent(in) :: scalarGroundSnowFraction ! fraction of ground that is snow covered (-) + real(rk),intent(in) :: scalarVolFracLiqUpper ! volumetric liquid water content in the upper-most soil layer (-) + real(rk),intent(in) :: scalarCanopyTempTrial ! trial value of canopy temperature (K) ! output - real(summa_prec),intent(out) :: spectralBelowCanopyDirect(:) ! downward direct flux below veg layer (W m-2) - real(summa_prec),intent(out) :: spectralBelowCanopyDiffuse(:) ! downward diffuse flux below veg layer (W m-2) - real(summa_prec),intent(out) :: scalarBelowCanopySolar ! radiation transmitted below the canopy (W m-2) - real(summa_prec),intent(out) :: spectralAlbGndDirect(:) ! direct albedo of underlying surface (1:nBands) (-) - real(summa_prec),intent(out) :: spectralAlbGndDiffuse(:) ! diffuse albedo of underlying surface (1:nBands) (-) - real(summa_prec),intent(out) :: scalarGroundAlbedo ! albedo of the ground surface (-) - real(summa_prec),intent(out) :: scalarCanopyAbsorbedSolar ! radiation absorbed by the vegetation canopy (W m-2) - real(summa_prec),intent(out) :: scalarGroundAbsorbedSolar ! radiation absorbed by the ground (W m-2) - real(summa_prec),intent(out) :: scalarCanopySunlitFraction ! sunlit fraction of canopy (-) - real(summa_prec),intent(out) :: scalarCanopySunlitLAI ! sunlit leaf area (-) - real(summa_prec),intent(out) :: scalarCanopyShadedLAI ! shaded leaf area (-) - real(summa_prec),intent(out) :: scalarCanopySunlitPAR ! average absorbed par for sunlit leaves (w m-2) - real(summa_prec),intent(out) :: scalarCanopyShadedPAR ! average absorbed par for shaded leaves (w m-2) + real(rk),intent(out) :: spectralBelowCanopyDirect(:) ! downward direct flux below veg layer (W m-2) + real(rk),intent(out) :: spectralBelowCanopyDiffuse(:) ! downward diffuse flux below veg layer (W m-2) + real(rk),intent(out) :: scalarBelowCanopySolar ! radiation transmitted below the canopy (W m-2) + real(rk),intent(out) :: spectralAlbGndDirect(:) ! direct albedo of underlying surface (1:nBands) (-) + real(rk),intent(out) :: spectralAlbGndDiffuse(:) ! diffuse albedo of underlying surface (1:nBands) (-) + real(rk),intent(out) :: scalarGroundAlbedo ! albedo of the ground surface (-) + real(rk),intent(out) :: scalarCanopyAbsorbedSolar ! radiation absorbed by the vegetation canopy (W m-2) + real(rk),intent(out) :: scalarGroundAbsorbedSolar ! radiation absorbed by the ground (W m-2) + real(rk),intent(out) :: scalarCanopySunlitFraction ! sunlit fraction of canopy (-) + real(rk),intent(out) :: scalarCanopySunlitLAI ! sunlit leaf area (-) + real(rk),intent(out) :: scalarCanopyShadedLAI ! shaded leaf area (-) + real(rk),intent(out) :: scalarCanopySunlitPAR ! average absorbed par for sunlit leaves (w m-2) + real(rk),intent(out) :: scalarCanopyShadedPAR ! average absorbed par for shaded leaves (w m-2) integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! ----------------------------------------------------------------------------------------------------------------------------------------------------------------- @@ -349,72 +349,72 @@ subroutine canopy_SW(& integer(i4b) :: ic ! 0=unit incoming direct; 1=unit incoming diffuse character(LEN=256) :: cmessage ! error message of downwind routine ! variables used in Nijssen-Lettenmaier method - real(summa_prec),parameter :: multScatExp=0.81_summa_prec ! multiple scattering exponent (-) - real(summa_prec),parameter :: bulkCanopyAlbedo=0.25_summa_prec ! bulk canopy albedo (-), smaller than actual canopy albedo because of shading in the canopy - real(summa_prec),dimension(1:nBands) :: spectralIncomingSolar ! total incoming solar radiation in each spectral band (W m-2) - real(summa_prec),dimension(1:nBands) :: spectralGroundAbsorbedDirect ! total direct radiation absorbed at the ground surface (W m-2) - real(summa_prec),dimension(1:nBands) :: spectralGroundAbsorbedDiffuse ! total diffuse radiation absorbed at the ground surface (W m-2) - real(summa_prec) :: Fdirect ! fraction of direct radiation (-) - real(summa_prec) :: tauInitial ! transmission in the absence of scattering and multiple reflections (-) - real(summa_prec) :: tauTotal ! transmission due to scattering and multiple reflections (-) + real(rk),parameter :: multScatExp=0.81_rk ! multiple scattering exponent (-) + real(rk),parameter :: bulkCanopyAlbedo=0.25_rk ! bulk canopy albedo (-), smaller than actual canopy albedo because of shading in the canopy + real(rk),dimension(1:nBands) :: spectralIncomingSolar ! total incoming solar radiation in each spectral band (W m-2) + real(rk),dimension(1:nBands) :: spectralGroundAbsorbedDirect ! total direct radiation absorbed at the ground surface (W m-2) + real(rk),dimension(1:nBands) :: spectralGroundAbsorbedDiffuse ! total diffuse radiation absorbed at the ground surface (W m-2) + real(rk) :: Fdirect ! fraction of direct radiation (-) + real(rk) :: tauInitial ! transmission in the absence of scattering and multiple reflections (-) + real(rk) :: tauTotal ! transmission due to scattering and multiple reflections (-) ! variables used in Mahat-Tarboton method - real(summa_prec),parameter :: Frad_vis=0.5_summa_prec ! fraction of radiation in the visible wave band (-) - real(summa_prec),parameter :: gProjParam=0.5_summa_prec ! projected leaf and stem area in the solar direction (-) - real(summa_prec),parameter :: bScatParam=0.5_summa_prec ! back scatter parameter (-) - real(summa_prec) :: transCoef ! transmission coefficient (-) - real(summa_prec) :: transCoefPrime ! "k-prime" coefficient (-) - real(summa_prec) :: groundAlbedoDirect ! direct ground albedo (-) - real(summa_prec) :: groundAlbedoDiffuse ! diffuse ground albedo (-) - real(summa_prec) :: tauInfinite ! direct transmission for an infinite canopy (-) - real(summa_prec) :: betaInfinite ! direct upward reflection factor for an infinite canopy (-) - real(summa_prec) :: tauFinite ! direct transmission for a finite canopy (-) - real(summa_prec) :: betaFinite ! direct reflectance for a finite canopy (-) - real(summa_prec) :: vFactor ! scaled vegetation area used to compute diffuse radiation (-) - real(summa_prec) :: expi ! exponential integral (-) - real(summa_prec) :: taudInfinite ! diffuse transmission for an infinite canopy (-) - real(summa_prec) :: taudFinite ! diffuse transmission for a finite canopy (-) - real(summa_prec) :: betadFinite ! diffuse reflectance for a finite canopy (-) - real(summa_prec) :: refMult ! multiple reflection factor (-) - real(summa_prec) :: fracRadAbsDown ! fraction of radiation absorbed by vegetation on the way down - real(summa_prec) :: fracRadAbsUp ! fraction of radiation absorbed by vegetation on the way up - real(summa_prec) :: tauDirect ! total transmission of direct radiation (-) - real(summa_prec) :: tauDiffuse ! total transmission of diffuse radiation (-) - real(summa_prec) :: fractionRefDirect ! fraction of direct radiaiton lost to space (-) - real(summa_prec) :: fractionRefDiffuse ! fraction of diffuse radiaiton lost to space (-) - real(summa_prec),dimension(1:nBands) :: spectralBelowCanopySolar ! total below-canopy radiation for each wave band (W m-2) - real(summa_prec),dimension(1:nBands) :: spectralTotalReflectedSolar ! total reflected radiaion for each wave band (W m-2) - real(summa_prec),dimension(1:nBands) :: spectralGroundAbsorbedSolar ! radiation absorbed by the ground in each wave band (W m-2) - real(summa_prec),dimension(1:nBands) :: spectralCanopyAbsorbedSolar ! radiation absorbed by the canopy in each wave band (W m-2) + real(rk),parameter :: Frad_vis=0.5_rk ! fraction of radiation in the visible wave band (-) + real(rk),parameter :: gProjParam=0.5_rk ! projected leaf and stem area in the solar direction (-) + real(rk),parameter :: bScatParam=0.5_rk ! back scatter parameter (-) + real(rk) :: transCoef ! transmission coefficient (-) + real(rk) :: transCoefPrime ! "k-prime" coefficient (-) + real(rk) :: groundAlbedoDirect ! direct ground albedo (-) + real(rk) :: groundAlbedoDiffuse ! diffuse ground albedo (-) + real(rk) :: tauInfinite ! direct transmission for an infinite canopy (-) + real(rk) :: betaInfinite ! direct upward reflection factor for an infinite canopy (-) + real(rk) :: tauFinite ! direct transmission for a finite canopy (-) + real(rk) :: betaFinite ! direct reflectance for a finite canopy (-) + real(rk) :: vFactor ! scaled vegetation area used to compute diffuse radiation (-) + real(rk) :: expi ! exponential integral (-) + real(rk) :: taudInfinite ! diffuse transmission for an infinite canopy (-) + real(rk) :: taudFinite ! diffuse transmission for a finite canopy (-) + real(rk) :: betadFinite ! diffuse reflectance for a finite canopy (-) + real(rk) :: refMult ! multiple reflection factor (-) + real(rk) :: fracRadAbsDown ! fraction of radiation absorbed by vegetation on the way down + real(rk) :: fracRadAbsUp ! fraction of radiation absorbed by vegetation on the way up + real(rk) :: tauDirect ! total transmission of direct radiation (-) + real(rk) :: tauDiffuse ! total transmission of diffuse radiation (-) + real(rk) :: fractionRefDirect ! fraction of direct radiaiton lost to space (-) + real(rk) :: fractionRefDiffuse ! fraction of diffuse radiaiton lost to space (-) + real(rk),dimension(1:nBands) :: spectralBelowCanopySolar ! total below-canopy radiation for each wave band (W m-2) + real(rk),dimension(1:nBands) :: spectralTotalReflectedSolar ! total reflected radiaion for each wave band (W m-2) + real(rk),dimension(1:nBands) :: spectralGroundAbsorbedSolar ! radiation absorbed by the ground in each wave band (W m-2) + real(rk),dimension(1:nBands) :: spectralCanopyAbsorbedSolar ! radiation absorbed by the canopy in each wave band (W m-2) ! vegetation properties used in 2-stream - real(summa_prec) :: scalarExposedVAI ! one-sided leaf+stem area index (m2/m2) - real(summa_prec) :: weightLeaf ! fraction of exposed VAI that is leaf - real(summa_prec) :: weightStem ! fraction of exposed VAI that is stem - real(summa_prec),dimension(1:nBands) :: spectralVegReflc ! leaf+stem reflectance (1:nbands) - real(summa_prec),dimension(1:nBands) :: spectralVegTrans ! leaf+stem transmittance (1:nBands) + real(rk) :: scalarExposedVAI ! one-sided leaf+stem area index (m2/m2) + real(rk) :: weightLeaf ! fraction of exposed VAI that is leaf + real(rk) :: weightStem ! fraction of exposed VAI that is stem + real(rk),dimension(1:nBands) :: spectralVegReflc ! leaf+stem reflectance (1:nbands) + real(rk),dimension(1:nBands) :: spectralVegTrans ! leaf+stem transmittance (1:nBands) ! output from two-stream -- direct-beam - real(summa_prec),dimension(1:nBands) :: spectralCanopyAbsorbedDirect ! flux abs by veg layer (per unit incoming flux), (1:nBands) - real(summa_prec),dimension(1:nBands) :: spectralTotalReflectedDirect ! flux refl above veg layer (per unit incoming flux), (1:nBands) - real(summa_prec),dimension(1:nBands) :: spectralDirectBelowCanopyDirect ! down dir flux below veg layer (per unit in flux), (1:nBands) - real(summa_prec),dimension(1:nBands) :: spectralDiffuseBelowCanopyDirect ! down dif flux below veg layer (per unit in flux), (1:nBands) - real(summa_prec),dimension(1:nBands) :: spectralCanopyReflectedDirect ! flux reflected by veg layer (per unit incoming flux), (1:nBands) - real(summa_prec),dimension(1:nBands) :: spectralGroundReflectedDirect ! flux reflected by ground (per unit incoming flux), (1:nBands) + real(rk),dimension(1:nBands) :: spectralCanopyAbsorbedDirect ! flux abs by veg layer (per unit incoming flux), (1:nBands) + real(rk),dimension(1:nBands) :: spectralTotalReflectedDirect ! flux refl above veg layer (per unit incoming flux), (1:nBands) + real(rk),dimension(1:nBands) :: spectralDirectBelowCanopyDirect ! down dir flux below veg layer (per unit in flux), (1:nBands) + real(rk),dimension(1:nBands) :: spectralDiffuseBelowCanopyDirect ! down dif flux below veg layer (per unit in flux), (1:nBands) + real(rk),dimension(1:nBands) :: spectralCanopyReflectedDirect ! flux reflected by veg layer (per unit incoming flux), (1:nBands) + real(rk),dimension(1:nBands) :: spectralGroundReflectedDirect ! flux reflected by ground (per unit incoming flux), (1:nBands) ! output from two-stream -- diffuse - real(summa_prec),dimension(1:nBands) :: spectralCanopyAbsorbedDiffuse ! flux abs by veg layer (per unit incoming flux), (1:nBands) - real(summa_prec),dimension(1:nBands) :: spectralTotalReflectedDiffuse ! flux refl above veg layer (per unit incoming flux), (1:nBands) - real(summa_prec),dimension(1:nBands) :: spectralDirectBelowCanopyDiffuse ! down dir flux below veg layer (per unit in flux), (1:nBands) - real(summa_prec),dimension(1:nBands) :: spectralDiffuseBelowCanopyDiffuse ! down dif flux below veg layer (per unit in flux), (1:nBands) - real(summa_prec),dimension(1:nBands) :: spectralCanopyReflectedDiffuse ! flux reflected by veg layer (per unit incoming flux), (1:nBands) - real(summa_prec),dimension(1:nBands) :: spectralGroundReflectedDiffuse ! flux reflected by ground (per unit incoming flux), (1:nBands) + real(rk),dimension(1:nBands) :: spectralCanopyAbsorbedDiffuse ! flux abs by veg layer (per unit incoming flux), (1:nBands) + real(rk),dimension(1:nBands) :: spectralTotalReflectedDiffuse ! flux refl above veg layer (per unit incoming flux), (1:nBands) + real(rk),dimension(1:nBands) :: spectralDirectBelowCanopyDiffuse ! down dir flux below veg layer (per unit in flux), (1:nBands) + real(rk),dimension(1:nBands) :: spectralDiffuseBelowCanopyDiffuse ! down dif flux below veg layer (per unit in flux), (1:nBands) + real(rk),dimension(1:nBands) :: spectralCanopyReflectedDiffuse ! flux reflected by veg layer (per unit incoming flux), (1:nBands) + real(rk),dimension(1:nBands) :: spectralGroundReflectedDiffuse ! flux reflected by ground (per unit incoming flux), (1:nBands) ! output from two-stream -- scalar variables - real(summa_prec) :: scalarGproj ! projected leaf+stem area in solar direction - real(summa_prec) :: scalarBetweenCanopyGapFraction ! between canopy gap fraction for beam (-) - real(summa_prec) :: scalarWithinCanopyGapFraction ! within canopy gap fraction for beam (-) + real(rk) :: scalarGproj ! projected leaf+stem area in solar direction + real(rk) :: scalarBetweenCanopyGapFraction ! between canopy gap fraction for beam (-) + real(rk) :: scalarWithinCanopyGapFraction ! within canopy gap fraction for beam (-) ! radiation fluxes - real(summa_prec) :: ext ! optical depth of direct beam per unit leaf + stem area - real(summa_prec) :: scalarCanopyShadedFraction ! shaded fraction of the canopy - real(summa_prec) :: fractionLAI ! fraction of vegetation that is leaves - real(summa_prec) :: visibleAbsDirect ! direct-beam radiation absorbed in the visible part of the spectrum (W m-2) - real(summa_prec) :: visibleAbsDiffuse ! diffuse radiation absorbed in the visible part of the spectrum (W m-2) + real(rk) :: ext ! optical depth of direct beam per unit leaf + stem area + real(rk) :: scalarCanopyShadedFraction ! shaded fraction of the canopy + real(rk) :: fractionLAI ! fraction of vegetation that is leaves + real(rk) :: visibleAbsDirect ! direct-beam radiation absorbed in the visible part of the spectrum (W m-2) + real(rk) :: visibleAbsDiffuse ! diffuse radiation absorbed in the visible part of the spectrum (W m-2) ! ----------------------------------------------------------------------------------------------------------------------------------------------------------------- ! initialize error control err=0; message='canopy_SW/' @@ -434,18 +434,18 @@ subroutine canopy_SW(& if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! initialize accumulated fluxes - scalarBelowCanopySolar = 0._summa_prec ! radiation transmitted below the canopy (W m-2) - scalarCanopyAbsorbedSolar = 0._summa_prec ! radiation absorbed by the vegetation canopy (W m-2) - scalarGroundAbsorbedSolar = 0._summa_prec ! radiation absorbed by the ground (W m-2) + scalarBelowCanopySolar = 0._rk ! radiation transmitted below the canopy (W m-2) + scalarCanopyAbsorbedSolar = 0._rk ! radiation absorbed by the vegetation canopy (W m-2) + scalarGroundAbsorbedSolar = 0._rk ! radiation absorbed by the ground (W m-2) ! check for an early return (no radiation or no exposed canopy) if(.not.computeVegFlux .or. scalarCosZenith < tiny(scalarCosZenith))then ! set canopy radiation to zero - scalarCanopySunlitFraction = 0._summa_prec ! sunlit fraction of canopy (-) - scalarCanopySunlitLAI = 0._summa_prec ! sunlit leaf area (-) + scalarCanopySunlitFraction = 0._rk ! sunlit fraction of canopy (-) + scalarCanopySunlitLAI = 0._rk ! sunlit leaf area (-) scalarCanopyShadedLAI = scalarExposedLAI ! shaded leaf area (-) - scalarCanopySunlitPAR = 0._summa_prec ! average absorbed par for sunlit leaves (w m-2) - scalarCanopyShadedPAR = 0._summa_prec ! average absorbed par for shaded leaves (w m-2) + scalarCanopySunlitPAR = 0._rk ! average absorbed par for sunlit leaves (w m-2) + scalarCanopyShadedPAR = 0._rk ! average absorbed par for shaded leaves (w m-2) ! compute below-canopy radiation do iBand=1,nBands ! (set below-canopy radiation to incoming radiation) @@ -453,16 +453,16 @@ subroutine canopy_SW(& spectralBelowCanopyDirect(iBand) = spectralIncomingDirect(iBand) spectralBelowCanopyDiffuse(iBand) = spectralIncomingDiffuse(iBand) else - spectralBelowCanopyDirect(iBand) = 0._summa_prec - spectralBelowCanopyDiffuse(iBand) = 0._summa_prec + spectralBelowCanopyDirect(iBand) = 0._rk + spectralBelowCanopyDiffuse(iBand) = 0._rk end if ! (accumulate radiation transmitted below the canopy) scalarBelowCanopySolar = scalarBelowCanopySolar + & ! contribution from all previous wave bands spectralBelowCanopyDirect(iBand) + spectralBelowCanopyDiffuse(iBand) ! contribution from current wave band ! (accumulate radiation absorbed by the ground) scalarGroundAbsorbedSolar = scalarGroundAbsorbedSolar + & ! contribution from all previous wave bands - spectralBelowCanopyDirect(iBand)*(1._summa_prec - spectralAlbGndDirect(iBand)) + & ! direct radiation from current wave band - spectralBelowCanopyDiffuse(iBand)*(1._summa_prec - spectralAlbGndDiffuse(iBand)) ! diffuse radiation from current wave band + spectralBelowCanopyDirect(iBand)*(1._rk - spectralAlbGndDirect(iBand)) + & ! direct radiation from current wave band + spectralBelowCanopyDiffuse(iBand)*(1._rk - spectralAlbGndDiffuse(iBand)) ! diffuse radiation from current wave band end do ! looping through wave bands return end if @@ -490,8 +490,8 @@ subroutine canopy_SW(& !print*, 'tauTotal = ', tauTotal ! compute ground albedo (-) - groundAlbedoDirect = Frad_vis*spectralAlbGndDirect(ixVisible) + (1._summa_prec - Frad_vis)*spectralAlbGndDirect(ixNearIR) - groundAlbedoDiffuse = Frad_vis*spectralAlbGndDiffuse(ixVisible) + (1._summa_prec - Frad_vis)*spectralAlbGndDiffuse(ixNearIR) + groundAlbedoDirect = Frad_vis*spectralAlbGndDirect(ixVisible) + (1._rk - Frad_vis)*spectralAlbGndDirect(ixNearIR) + groundAlbedoDiffuse = Frad_vis*spectralAlbGndDiffuse(ixVisible) + (1._rk - Frad_vis)*spectralAlbGndDiffuse(ixNearIR) ! compute radiation in each spectral band (W m-2) do iBand=1,nBands @@ -501,7 +501,7 @@ subroutine canopy_SW(& ! compute fraction of direct radiation Fdirect = spectralIncomingDirect(iBand) / (spectralIncomingSolar(iBand) + verySmall) - if(Fdirect < 0._summa_prec .or. Fdirect > 1._summa_prec)then + if(Fdirect < 0._rk .or. Fdirect > 1._rk)then print*, 'spectralIncomingDirect(iBand) = ', spectralIncomingDirect(iBand) print*, 'spectralIncomingSolar(iBand) = ', spectralIncomingSolar(iBand) print*, 'Fdirect = ', Fdirect @@ -510,8 +510,8 @@ subroutine canopy_SW(& end if ! compute ground albedo (-) - scalarGroundAlbedo = Fdirect*groundAlbedoDirect + (1._summa_prec - Fdirect)*groundAlbedoDiffuse - if(scalarGroundAlbedo < 0._summa_prec .or. scalarGroundAlbedo > 1._summa_prec)then + scalarGroundAlbedo = Fdirect*groundAlbedoDirect + (1._rk - Fdirect)*groundAlbedoDiffuse + if(scalarGroundAlbedo < 0._rk .or. scalarGroundAlbedo > 1._rk)then print*, 'groundAlbedoDirect = ', groundAlbedoDirect print*, 'groundAlbedoDiffuse = ', groundAlbedoDiffuse message=trim(message)//'BeersLaw: albedo is less than zero or greater than one' @@ -524,13 +524,13 @@ subroutine canopy_SW(& spectralBelowCanopySolar(iBand) = spectralBelowCanopyDirect(iBand) + spectralBelowCanopyDiffuse(iBand) ! compute radiation absorbed by the ground in given wave band (W m-2) - spectralGroundAbsorbedDirect(iBand) = (1._summa_prec - scalarGroundAlbedo)*spectralBelowCanopyDirect(iBand) - spectralGroundAbsorbedDiffuse(iBand) = (1._summa_prec - scalarGroundAlbedo)*spectralBelowCanopyDiffuse(iBand) + spectralGroundAbsorbedDirect(iBand) = (1._rk - scalarGroundAlbedo)*spectralBelowCanopyDirect(iBand) + spectralGroundAbsorbedDiffuse(iBand) = (1._rk - scalarGroundAlbedo)*spectralBelowCanopyDiffuse(iBand) spectralGroundAbsorbedSolar(iBand) = spectralGroundAbsorbedDirect(iBand) + spectralGroundAbsorbedDiffuse(iBand) ! compute radiation absorbed by vegetation in current wave band (W m-2) - fracRadAbsDown = (1._summa_prec - tauTotal)*(1._summa_prec - bulkCanopyAlbedo) ! (fraction of radiation absorbed on the way down) - fracRadAbsUp = tauTotal*scalarGroundAlbedo*(1._summa_prec - tauTotal) ! (fraction of radiation absorbed on the way up) + fracRadAbsDown = (1._rk - tauTotal)*(1._rk - bulkCanopyAlbedo) ! (fraction of radiation absorbed on the way down) + fracRadAbsUp = tauTotal*scalarGroundAlbedo*(1._rk - tauTotal) ! (fraction of radiation absorbed on the way up) spectralCanopyAbsorbedDirect(iBand) = spectralIncomingDirect(iBand)*(fracRadAbsDown + fracRadAbsUp) spectralCanopyAbsorbedDiffuse(iBand) = spectralIncomingDiffuse(iBand)*(fracRadAbsDown + fracRadAbsUp) spectralCanopyAbsorbedSolar(iBand) = spectralCanopyAbsorbedDirect(iBand) + spectralCanopyAbsorbedDiffuse(iBand) @@ -547,7 +547,7 @@ subroutine canopy_SW(& spectralTotalReflectedDirect(iBand) = spectralIncomingDirect(iBand) - spectralGroundAbsorbedDirect(iBand) - spectralCanopyAbsorbedDirect(iBand) spectralTotalReflectedDiffuse(iBand) = spectralIncomingDiffuse(iBand) - spectralGroundAbsorbedDiffuse(iBand) - spectralCanopyAbsorbedDiffuse(iBand) spectralTotalReflectedSolar(iBand) = spectralTotalReflectedDirect(iBand) + spectralTotalReflectedDiffuse(iBand) - if(spectralTotalReflectedDirect(iBand) < 0._summa_prec .or. spectralTotalReflectedDiffuse(iBand) < 0._summa_prec)then + if(spectralTotalReflectedDirect(iBand) < 0._rk .or. spectralTotalReflectedDiffuse(iBand) < 0._rk)then print*, 'scalarGroundAlbedo = ', scalarGroundAlbedo print*, 'tauTotal = ', tauTotal print*, 'fracRadAbsDown = ', fracRadAbsDown @@ -587,11 +587,11 @@ subroutine canopy_SW(& ! compute transmission of diffuse radiation (-) vFactor = scalarGproj*scalarExposedVAI expi = expInt(vFactor) - taudFinite = (1._summa_prec - vFactor)*exp(-vFactor) + (vFactor**2._summa_prec)*expi + taudFinite = (1._rk - vFactor)*exp(-vFactor) + (vFactor**2._rk)*expi ! compute ground albedo (-) - groundAlbedoDirect = Frad_vis*spectralAlbGndDirect(ixVisible) + (1._summa_prec - Frad_vis)*spectralAlbGndDirect(ixNearIR) - groundAlbedoDiffuse = Frad_vis*spectralAlbGndDiffuse(ixVisible) + (1._summa_prec - Frad_vis)*spectralAlbGndDiffuse(ixNearIR) + groundAlbedoDirect = Frad_vis*spectralAlbGndDirect(ixVisible) + (1._rk - Frad_vis)*spectralAlbGndDirect(ixNearIR) + groundAlbedoDiffuse = Frad_vis*spectralAlbGndDiffuse(ixVisible) + (1._rk - Frad_vis)*spectralAlbGndDiffuse(ixNearIR) ! compute radiation in each spectral band (W m-2) do iBand=1,nBands @@ -601,7 +601,7 @@ subroutine canopy_SW(& ! compute fraction of direct radiation Fdirect = spectralIncomingDirect(iBand) / (spectralIncomingSolar(iBand) + verySmall) - if(Fdirect < 0._summa_prec .or. Fdirect > 1._summa_prec)then + if(Fdirect < 0._rk .or. Fdirect > 1._rk)then print*, 'spectralIncomingDirect(iBand) = ', spectralIncomingDirect(iBand) print*, 'spectralIncomingSolar(iBand) = ', spectralIncomingSolar(iBand) print*, 'Fdirect = ', Fdirect @@ -610,8 +610,8 @@ subroutine canopy_SW(& end if ! compute ground albedo (-) - scalarGroundAlbedo = Fdirect*groundAlbedoDirect + (1._summa_prec - Fdirect)*groundAlbedoDiffuse - if(scalarGroundAlbedo < 0._summa_prec .or. scalarGroundAlbedo > 1._summa_prec)then + scalarGroundAlbedo = Fdirect*groundAlbedoDirect + (1._rk - Fdirect)*groundAlbedoDiffuse + if(scalarGroundAlbedo < 0._rk .or. scalarGroundAlbedo > 1._rk)then print*, 'groundAlbedoDirect = ', groundAlbedoDirect print*, 'groundAlbedoDiffuse = ', groundAlbedoDiffuse message=trim(message)//'NL_scatter: albedo is less than zero or greater than one' @@ -619,13 +619,13 @@ subroutine canopy_SW(& end if ! compute initial transmission in the absence of scattering and multiple reflections (-) - tauInitial = Fdirect*tauFinite + (1._summa_prec - Fdirect)*taudFinite + tauInitial = Fdirect*tauFinite + (1._rk - Fdirect)*taudFinite ! compute increase in transmission due to scattering (-) tauTotal = (tauInitial**multScatExp) ! compute multiple reflections factor - refMult = 1._summa_prec / (1._summa_prec - scalarGroundAlbedo*bulkCanopyAlbedo*(1._summa_prec - taudFinite**multScatExp) ) + refMult = 1._rk / (1._rk - scalarGroundAlbedo*bulkCanopyAlbedo*(1._rk - taudFinite**multScatExp) ) ! compute below-canopy radiation (W m-2) spectralBelowCanopyDirect(iBand) = spectralIncomingDirect(iBand)*tauTotal*refMult ! direct radiation from current wave band @@ -633,13 +633,13 @@ subroutine canopy_SW(& spectralBelowCanopySolar(iBand) = spectralBelowCanopyDirect(iBand) + spectralBelowCanopyDiffuse(iBand) ! compute radiation absorbed by the ground in given wave band (W m-2) - spectralGroundAbsorbedDirect(iBand) = (1._summa_prec - scalarGroundAlbedo)*spectralBelowCanopyDirect(iBand) - spectralGroundAbsorbedDiffuse(iBand) = (1._summa_prec - scalarGroundAlbedo)*spectralBelowCanopyDiffuse(iBand) + spectralGroundAbsorbedDirect(iBand) = (1._rk - scalarGroundAlbedo)*spectralBelowCanopyDirect(iBand) + spectralGroundAbsorbedDiffuse(iBand) = (1._rk - scalarGroundAlbedo)*spectralBelowCanopyDiffuse(iBand) spectralGroundAbsorbedSolar(iBand) = spectralGroundAbsorbedDirect(iBand) + spectralGroundAbsorbedDiffuse(iBand) ! compute radiation absorbed by vegetation in current wave band (W m-2) - fracRadAbsDown = (1._summa_prec - tauTotal)*(1._summa_prec - bulkCanopyAlbedo) ! (fraction of radiation absorbed on the way down) - fracRadAbsUp = tauTotal*refMult*scalarGroundAlbedo*(1._summa_prec - taudFinite**multScatExp) ! (fraction of radiation absorbed on the way up) + fracRadAbsDown = (1._rk - tauTotal)*(1._rk - bulkCanopyAlbedo) ! (fraction of radiation absorbed on the way down) + fracRadAbsUp = tauTotal*refMult*scalarGroundAlbedo*(1._rk - taudFinite**multScatExp) ! (fraction of radiation absorbed on the way up) spectralCanopyAbsorbedDirect(iBand) = spectralIncomingDirect(iBand)*(fracRadAbsDown + fracRadAbsUp) spectralCanopyAbsorbedDiffuse(iBand) = spectralIncomingDiffuse(iBand)*(fracRadAbsDown + fracRadAbsUp) spectralCanopyAbsorbedSolar(iBand) = spectralCanopyAbsorbedDirect(iBand) + spectralCanopyAbsorbedDiffuse(iBand) @@ -648,7 +648,7 @@ subroutine canopy_SW(& spectralTotalReflectedDirect(iBand) = spectralIncomingDirect(iBand) - spectralGroundAbsorbedDirect(iBand) - spectralCanopyAbsorbedDirect(iBand) spectralTotalReflectedDiffuse(iBand) = spectralIncomingDiffuse(iBand) - spectralGroundAbsorbedDiffuse(iBand) - spectralCanopyAbsorbedDiffuse(iBand) spectralTotalReflectedSolar(iBand) = spectralTotalReflectedDirect(iBand) + spectralTotalReflectedDiffuse(iBand) - if(spectralTotalReflectedDirect(iBand) < 0._summa_prec .or. spectralTotalReflectedDiffuse(iBand) < 0._summa_prec)then + if(spectralTotalReflectedDirect(iBand) < 0._rk .or. spectralTotalReflectedDiffuse(iBand) < 0._rk)then message=trim(message)//'NL-scatter: reflected radiation is less than zero' err=20; return end if @@ -677,43 +677,43 @@ subroutine canopy_SW(& transCoef = scalarGproj/scalarCosZenith ! define "k-prime" coefficient (-) - transCoefPrime = sqrt(1._summa_prec - bScatParam) + transCoefPrime = sqrt(1._rk - bScatParam) ! compute ground albedo (-) - groundAlbedoDirect = Frad_vis*spectralAlbGndDirect(ixVisible) + (1._summa_prec - Frad_vis)*spectralAlbGndDirect(ixNearIR) - groundAlbedoDiffuse = Frad_vis*spectralAlbGndDiffuse(ixVisible) + (1._summa_prec - Frad_vis)*spectralAlbGndDiffuse(ixNearIR) + groundAlbedoDirect = Frad_vis*spectralAlbGndDirect(ixVisible) + (1._rk - Frad_vis)*spectralAlbGndDirect(ixNearIR) + groundAlbedoDiffuse = Frad_vis*spectralAlbGndDiffuse(ixVisible) + (1._rk - Frad_vis)*spectralAlbGndDiffuse(ixNearIR) ! compute transmission for an infinite canopy (-) tauInfinite = exp(-transCoef*transCoefPrime*scalarExposedVAI) ! compute upward reflection factor for an infinite canopy (-) - betaInfinite = (1._summa_prec - transCoefPrime)/(1._summa_prec + transCoefPrime) + betaInfinite = (1._rk - transCoefPrime)/(1._rk + transCoefPrime) ! compute transmission for a finite canopy (-) - tauFinite = tauInfinite*(1._summa_prec - betaInfinite**2._summa_prec)/(1._summa_prec - (betaInfinite**2._summa_prec)*tauInfinite**2._summa_prec) + tauFinite = tauInfinite*(1._rk - betaInfinite**2._rk)/(1._rk - (betaInfinite**2._rk)*tauInfinite**2._rk) ! compute reflectance for a finite canopy (-) - betaFinite = betaInfinite*(1._summa_prec - tauInfinite**2._summa_prec) / (1._summa_prec - (betaInfinite**2._summa_prec)*(tauInfinite**2._summa_prec)) + betaFinite = betaInfinite*(1._rk - tauInfinite**2._rk) / (1._rk - (betaInfinite**2._rk)*(tauInfinite**2._rk)) ! compute transmission of diffuse radiation (-) vFactor = transCoefPrime*scalarGproj*scalarExposedVAI expi = expInt(vFactor) - taudInfinite = (1._summa_prec - vFactor)*exp(-vFactor) + (vFactor**2._summa_prec)*expi - taudFinite = taudInfinite*(1._summa_prec - betaInfinite**2._summa_prec)/(1._summa_prec - (betaInfinite**2._summa_prec)*taudInfinite**2._summa_prec) + taudInfinite = (1._rk - vFactor)*exp(-vFactor) + (vFactor**2._rk)*expi + taudFinite = taudInfinite*(1._rk - betaInfinite**2._rk)/(1._rk - (betaInfinite**2._rk)*taudInfinite**2._rk) ! compute reflectance of diffuse radiation (-) - betadFinite = betaInfinite*(1._summa_prec - taudInfinite**2._summa_prec) / (1._summa_prec - (betaInfinite**2._summa_prec)*(taudInfinite**2._summa_prec)) + betadFinite = betaInfinite*(1._rk - taudInfinite**2._rk) / (1._rk - (betaInfinite**2._rk)*(taudInfinite**2._rk)) ! compute total transmission of direct and diffuse radiation, accounting for multiple reflections (-) - refMult = 1._summa_prec / (1._summa_prec - groundAlbedoDiffuse*betadFinite*(1._summa_prec - taudFinite) ) + refMult = 1._rk / (1._rk - groundAlbedoDiffuse*betadFinite*(1._rk - taudFinite) ) tauDirect = tauFinite*refMult tauDiffuse = taudFinite*refMult ! compute fraction of radiation lost to space (-) - fractionRefDirect = ( (1._summa_prec - groundAlbedoDirect)*betaFinite + groundAlbedoDirect*tauFinite*taudFinite) * refMult - fractionRefDiffuse = ( (1._summa_prec - groundAlbedoDiffuse)*betadFinite + groundAlbedoDiffuse*taudFinite*taudFinite) * refMult + fractionRefDirect = ( (1._rk - groundAlbedoDirect)*betaFinite + groundAlbedoDirect*tauFinite*taudFinite) * refMult + fractionRefDiffuse = ( (1._rk - groundAlbedoDiffuse)*betadFinite + groundAlbedoDiffuse*taudFinite*taudFinite) * refMult ! compute radiation in each spectral band (W m-2) do iBand=1,nBands @@ -724,22 +724,22 @@ subroutine canopy_SW(& spectralBelowCanopySolar(iBand) = spectralBelowCanopyDirect(iBand) + spectralBelowCanopyDiffuse(iBand) ! compute radiation absorbed by the ground in given wave band (W m-2) - spectralGroundAbsorbedDirect(iBand) = (1._summa_prec - groundAlbedoDirect)*spectralBelowCanopyDirect(iBand) - spectralGroundAbsorbedDiffuse(iBand) = (1._summa_prec - groundAlbedoDiffuse)*spectralBelowCanopyDiffuse(iBand) + spectralGroundAbsorbedDirect(iBand) = (1._rk - groundAlbedoDirect)*spectralBelowCanopyDirect(iBand) + spectralGroundAbsorbedDiffuse(iBand) = (1._rk - groundAlbedoDiffuse)*spectralBelowCanopyDiffuse(iBand) spectralGroundAbsorbedSolar(iBand) = spectralGroundAbsorbedDirect(iBand) + spectralGroundAbsorbedDiffuse(iBand) ! compute radiation absorbed by vegetation in current wave band (W m-2) - spectralCanopyAbsorbedDirect(iBand) = spectralIncomingDirect(iBand)*(1._summa_prec - tauFinite)*(1._summa_prec - betaFinite) + & ! (radiation absorbed on the way down) - spectralBelowCanopyDirect(iBand)*groundAlbedoDirect*(1._summa_prec - taudFinite) ! (radiation absorbed on the way up) - spectralCanopyAbsorbedDiffuse(iBand) = spectralIncomingDiffuse(iBand)*(1._summa_prec - taudFinite)*(1._summa_prec - betadFinite) + & ! (radiation absorbed on the way down) - spectralBelowCanopyDiffuse(iBand)*groundAlbedoDiffuse*(1._summa_prec - taudFinite) ! (radiation absorbed on the way up) + spectralCanopyAbsorbedDirect(iBand) = spectralIncomingDirect(iBand)*(1._rk - tauFinite)*(1._rk - betaFinite) + & ! (radiation absorbed on the way down) + spectralBelowCanopyDirect(iBand)*groundAlbedoDirect*(1._rk - taudFinite) ! (radiation absorbed on the way up) + spectralCanopyAbsorbedDiffuse(iBand) = spectralIncomingDiffuse(iBand)*(1._rk - taudFinite)*(1._rk - betadFinite) + & ! (radiation absorbed on the way down) + spectralBelowCanopyDiffuse(iBand)*groundAlbedoDiffuse*(1._rk - taudFinite) ! (radiation absorbed on the way up) spectralCanopyAbsorbedSolar(iBand) = spectralCanopyAbsorbedDirect(iBand) + spectralCanopyAbsorbedDiffuse(iBand) ! compute solar radiation lost to space in given wave band (W m-2) spectralTotalReflectedDirect(iBand) = spectralIncomingDirect(iBand) - spectralGroundAbsorbedDirect(iBand) - spectralCanopyAbsorbedDirect(iBand) spectralTotalReflectedDiffuse(iBand) = spectralIncomingDiffuse(iBand) - spectralGroundAbsorbedDiffuse(iBand) - spectralCanopyAbsorbedDiffuse(iBand) spectralTotalReflectedSolar(iBand) = spectralTotalReflectedDirect(iBand) + spectralTotalReflectedDiffuse(iBand) - if(spectralTotalReflectedDirect(iBand) < 0._summa_prec .or. spectralTotalReflectedDiffuse(iBand) < 0._summa_prec)then + if(spectralTotalReflectedDirect(iBand) < 0._rk .or. spectralTotalReflectedDiffuse(iBand) < 0._rk)then message=trim(message)//'UEB_2stream: reflected radiation is less than zero' err=20; return end if @@ -851,8 +851,8 @@ subroutine canopy_SW(& ! accumulate radiation absorbed by the ground (W m-2) scalarGroundAbsorbedSolar = scalarGroundAbsorbedSolar + & ! contribution from all previous wave bands - spectralBelowCanopyDirect(iBand)*(1._summa_prec - spectralAlbGndDirect(iBand)) + & ! direct radiation from current wave band - spectralBelowCanopyDiffuse(iBand)*(1._summa_prec - spectralAlbGndDiffuse(iBand)) ! diffuse radiation from current wave band + spectralBelowCanopyDirect(iBand)*(1._rk - spectralAlbGndDirect(iBand)) + & ! direct radiation from current wave band + spectralBelowCanopyDiffuse(iBand)*(1._rk - spectralAlbGndDiffuse(iBand)) ! diffuse radiation from current wave band ! save canopy radiation absorbed in visible wavelengths ! NOTE: here flux is per unit incoming flux @@ -876,11 +876,11 @@ subroutine canopy_SW(& ! compute sunlit fraction of canopy (from CLM/Noah-MP) ext = scalarGproj/scalarCosZenith ! optical depth of direct beam per unit leaf + stem area - scalarCanopySunlitFraction = (1._summa_prec - exp(-ext*scalarExposedVAI)) / max(ext*scalarExposedVAI,mpe) - if(scalarCanopySunlitFraction < 0.01_summa_prec) scalarCanopySunlitFraction = 0._summa_prec + scalarCanopySunlitFraction = (1._rk - exp(-ext*scalarExposedVAI)) / max(ext*scalarExposedVAI,mpe) + if(scalarCanopySunlitFraction < 0.01_rk) scalarCanopySunlitFraction = 0._rk ! compute sunlit and shaded LAI - scalarCanopyShadedFraction = 1._summa_prec - scalarCanopySunlitFraction + scalarCanopyShadedFraction = 1._rk - scalarCanopySunlitFraction scalarCanopySunlitLAI = scalarExposedLAI*scalarCanopySunlitFraction scalarCanopyShadedLAI = scalarExposedLAI*scalarCanopyShadedFraction @@ -890,7 +890,7 @@ subroutine canopy_SW(& scalarCanopySunlitPAR = (visibleAbsDirect + scalarCanopySunlitFraction*visibleAbsDiffuse) * fractionLAI / max(scalarCanopySunlitLAI, mpe) scalarCanopyShadedPAR = ( scalarCanopyShadedFraction*visibleAbsDiffuse) * fractionLAI / max(scalarCanopyShadedLAI, mpe) else - scalarCanopySunlitPAR = 0._summa_prec + scalarCanopySunlitPAR = 0._rk scalarCanopyShadedPAR = (visibleAbsDirect + visibleAbsDiffuse) * fractionLAI / max(scalarCanopyShadedLAI, mpe) end if !print*, 'scalarCanopySunlitLAI, fractionLAI, visibleAbsDirect, visibleAbsDiffuse, scalarCanopySunlitPAR = ', & @@ -921,32 +921,32 @@ subroutine gndAlbedo(& ! -------------------------------------------------------------------------------------------------------------------------------------- ! input: model control integer(i4b),intent(in) :: isc ! index of soil color - real(summa_prec),intent(in) :: scalarGroundSnowFraction ! fraction of ground that is snow covered (-) - real(summa_prec),intent(in) :: scalarVolFracLiqUpper ! volumetric liquid water content in upper-most soil layer (-) - real(summa_prec),intent(in) :: spectralSnowAlbedoDirect(:) ! direct albedo of snow in each spectral band (-) - real(summa_prec),intent(in) :: spectralSnowAlbedoDiffuse(:) ! diffuse albedo of snow in each spectral band (-) + real(rk),intent(in) :: scalarGroundSnowFraction ! fraction of ground that is snow covered (-) + real(rk),intent(in) :: scalarVolFracLiqUpper ! volumetric liquid water content in upper-most soil layer (-) + real(rk),intent(in) :: spectralSnowAlbedoDirect(:) ! direct albedo of snow in each spectral band (-) + real(rk),intent(in) :: spectralSnowAlbedoDiffuse(:) ! diffuse albedo of snow in each spectral band (-) ! output - real(summa_prec),intent(out) :: spectralAlbGndDirect(:) ! direct albedo of underlying surface (-) - real(summa_prec),intent(out) :: spectralAlbGndDiffuse(:) ! diffuse albedo of underlying surface (-) + real(rk),intent(out) :: spectralAlbGndDirect(:) ! direct albedo of underlying surface (-) + real(rk),intent(out) :: spectralAlbGndDiffuse(:) ! diffuse albedo of underlying surface (-) integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! local variables integer(i4b) :: iBand ! index of spectral band - real(summa_prec) :: xInc ! soil water correction factor for soil albedo - real(summa_prec),dimension(1:nBands) :: spectralSoilAlbedo ! soil albedo in each spectral band + real(rk) :: xInc ! soil water correction factor for soil albedo + real(rk),dimension(1:nBands) :: spectralSoilAlbedo ! soil albedo in each spectral band ! initialize error control err=0; message='gndAlbedo/' ! compute soil albedo do iBand=1,nBands ! loop through spectral bands - xInc = max(0.11_summa_prec - 0.40_summa_prec*scalarVolFracLiqUpper, 0._summa_prec) + xInc = max(0.11_rk - 0.40_rk*scalarVolFracLiqUpper, 0._rk) spectralSoilAlbedo(iBand) = min(ALBSAT(isc,iBand)+xInc,ALBDRY(isc,iBand)) end do ! (looping through spectral bands) ! compute surface albedo (weighted combination of snow and soil) do iBand=1,nBands - spectralAlbGndDirect(iBand) = (1._summa_prec - scalarGroundSnowFraction)*spectralSoilAlbedo(iBand) + scalarGroundSnowFraction*spectralSnowAlbedoDirect(iBand) - spectralAlbGndDiffuse(iBand) = (1._summa_prec - scalarGroundSnowFraction)*spectralSoilAlbedo(iBand) + scalarGroundSnowFraction*spectralSnowAlbedoDiffuse(iBand) + spectralAlbGndDirect(iBand) = (1._rk - scalarGroundSnowFraction)*spectralSoilAlbedo(iBand) + scalarGroundSnowFraction*spectralSnowAlbedoDirect(iBand) + spectralAlbGndDiffuse(iBand) = (1._rk - scalarGroundSnowFraction)*spectralSoilAlbedo(iBand) + scalarGroundSnowFraction*spectralSnowAlbedoDiffuse(iBand) end do ! (looping through spectral bands) end subroutine gndAlbedo diff --git a/build/source/engine/volicePack.f90 b/build/source/engine/volicePack.f90 index ea086961d..a3b5d49d8 100755 --- a/build/source/engine/volicePack.f90 +++ b/build/source/engine/volicePack.f90 @@ -164,37 +164,37 @@ subroutine newsnwfall(& ! add new snowfall to the system implicit none ! input: model control - real(summa_prec),intent(in) :: dt ! time step (seconds) + real(rk),intent(in) :: dt ! time step (seconds) logical(lgt),intent(in) :: snowLayers ! logical flag if snow layers exist - real(summa_prec),intent(in) :: fc_param ! freeezing curve parameter for snow (K-1) + real(rk),intent(in) :: fc_param ! freeezing curve parameter for snow (K-1) ! input: diagnostic scalar variables - real(summa_prec),intent(in) :: scalarSnowfallTemp ! computed temperature of fresh snow (K) - real(summa_prec),intent(in) :: scalarNewSnowDensity ! computed density of new snow (kg m-3) - real(summa_prec),intent(in) :: scalarThroughfallSnow ! throughfall of snow through the canopy (kg m-2 s-1) - real(summa_prec),intent(in) :: scalarCanopySnowUnloading ! unloading of snow from the canopy (kg m-2 s-1) + real(rk),intent(in) :: scalarSnowfallTemp ! computed temperature of fresh snow (K) + real(rk),intent(in) :: scalarNewSnowDensity ! computed density of new snow (kg m-3) + real(rk),intent(in) :: scalarThroughfallSnow ! throughfall of snow through the canopy (kg m-2 s-1) + real(rk),intent(in) :: scalarCanopySnowUnloading ! unloading of snow from the canopy (kg m-2 s-1) ! input/output: state variables - real(summa_prec),intent(inout) :: scalarSWE ! SWE (kg m-2) - real(summa_prec),intent(inout) :: scalarSnowDepth ! total snow depth (m) - real(summa_prec),intent(inout) :: surfaceLayerTemp ! temperature of each layer (K) - real(summa_prec),intent(inout) :: surfaceLayerDepth ! depth of each layer (m) - real(summa_prec),intent(inout) :: surfaceLayerVolFracIce ! volumetric fraction of ice in each layer (-) - real(summa_prec),intent(inout) :: surfaceLayerVolFracLiq ! volumetric fraction of liquid water in each layer (-) + real(rk),intent(inout) :: scalarSWE ! SWE (kg m-2) + real(rk),intent(inout) :: scalarSnowDepth ! total snow depth (m) + real(rk),intent(inout) :: surfaceLayerTemp ! temperature of each layer (K) + real(rk),intent(inout) :: surfaceLayerDepth ! depth of each layer (m) + real(rk),intent(inout) :: surfaceLayerVolFracIce ! volumetric fraction of ice in each layer (-) + real(rk),intent(inout) :: surfaceLayerVolFracLiq ! volumetric fraction of liquid water in each layer (-) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! define local variables - real(summa_prec) :: newSnowfall ! new snowfall -- throughfall and unloading (kg m-2 s-1) - real(summa_prec) :: newSnowDepth ! new snow depth (m) - real(summa_prec),parameter :: densityCanopySnow=200._summa_prec ! density of snow on the vegetation canopy (kg m-3) - real(summa_prec) :: totalMassIceSurfLayer ! total mass of ice in the surface layer (kg m-2) - real(summa_prec) :: totalDepthSurfLayer ! total depth of the surface layer (m) - real(summa_prec) :: volFracWater ! volumetric fraction of total water, liquid and ice (-) - real(summa_prec) :: fracLiq ! fraction of liquid water (-) - real(summa_prec) :: SWE ! snow water equivalent after snowfall (kg m-2) - real(summa_prec) :: tempSWE0 ! temporary SWE before snowfall, used to check mass balance (kg m-2) - real(summa_prec) :: tempSWE1 ! temporary SWE after snowfall, used to check mass balance (kg m-2) - real(summa_prec) :: xMassBalance ! mass balance check (kg m-2) - real(summa_prec),parameter :: verySmall=1.e-8_summa_prec ! a very small number -- used to check mass balance + real(rk) :: newSnowfall ! new snowfall -- throughfall and unloading (kg m-2 s-1) + real(rk) :: newSnowDepth ! new snow depth (m) + real(rk),parameter :: densityCanopySnow=200._rk ! density of snow on the vegetation canopy (kg m-3) + real(rk) :: totalMassIceSurfLayer ! total mass of ice in the surface layer (kg m-2) + real(rk) :: totalDepthSurfLayer ! total depth of the surface layer (m) + real(rk) :: volFracWater ! volumetric fraction of total water, liquid and ice (-) + real(rk) :: fracLiq ! fraction of liquid water (-) + real(rk) :: SWE ! snow water equivalent after snowfall (kg m-2) + real(rk) :: tempSWE0 ! temporary SWE before snowfall, used to check mass balance (kg m-2) + real(rk) :: tempSWE1 ! temporary SWE after snowfall, used to check mass balance (kg m-2) + real(rk) :: xMassBalance ! mass balance check (kg m-2) + real(rk),parameter :: verySmall=1.e-8_rk ! a very small number -- used to check mass balance ! initialize error control err=0; message="newsnwfall/" @@ -233,7 +233,7 @@ subroutine newsnwfall(& ! compute new volumetric fraction of liquid water and ice (-) volFracWater = (SWE/totalDepthSurfLayer)/iden_water fracLiq = fracliquid(surfaceLayerTemp,fc_param) ! fraction of liquid water - surfaceLayerVolFracIce = (1._summa_prec - fracLiq)*volFracWater*(iden_water/iden_ice) ! volumetric fraction of ice (-) + surfaceLayerVolFracIce = (1._rk - fracLiq)*volFracWater*(iden_water/iden_ice) ! volumetric fraction of ice (-) surfaceLayerVolFracLiq = fracLiq *volFracWater ! volumetric fraction of liquid water (-) ! update new layer depth (m) surfaceLayerDepth = totalDepthSurfLayer diff --git a/build/source/netcdf/modelwrite.f90 b/build/source/netcdf/modelwrite.f90 index 8ea0d7316..5089f52b0 100755 --- a/build/source/netcdf/modelwrite.f90 +++ b/build/source/netcdf/modelwrite.f90 @@ -176,8 +176,8 @@ subroutine writeData(finalizeStats,outputTimestep,nHRUrun,maxLayers,meta,stat,da ! output arrays integer(i4b) :: datLength ! length of each data vector integer(i4b) :: maxLength ! maximum length of each data vector - real(summa_prec) :: realVec(nHRUrun) ! real vector for all HRUs in the run domain - real(summa_prec) :: realArray(nHRUrun,maxLayers+1) ! real array for all HRUs in the run domain + real(rk) :: realVec(nHRUrun) ! real vector for all HRUs in the run domain + real(rk) :: realArray(nHRUrun,maxLayers+1) ! real array for all HRUs in the run domain integer(i4b) :: intArray(nHRUrun,maxLayers+1) ! integer array for all HRUs in the run domain integer(i4b) :: dataType ! type of data integer(i4b),parameter :: ixInteger=1001 ! named variable for integer diff --git a/build/source/netcdf/read_icond.f90 b/build/source/netcdf/read_icond.f90 index 126ee6c7d..13ba5a288 100644 --- a/build/source/netcdf/read_icond.f90 +++ b/build/source/netcdf/read_icond.f90 @@ -201,7 +201,7 @@ subroutine read_icond(iconFile, & ! intent(in): name of integer(i4b) :: ixFile ! index in file integer(i4b) :: iHRU_local ! index of HRU in the data subset integer(i4b) :: iHRU_global ! index of HRU in the netcdf file - real(summa_prec),allocatable :: varData(:,:) ! variable data storage + real(rk),allocatable :: varData(:,:) ! variable data storage integer(i4b) :: nSoil, nSnow, nToto ! # layers integer(i4b) :: nTDH ! number of points in time-delay histogram integer(i4b) :: iLayer,jLayer ! layer indices @@ -319,7 +319,7 @@ subroutine read_icond(iconFile, & ! intent(in): name of if(err==20)then; message=trim(message)//"data set to the fill value (name='"//trim(prog_meta(iVar)%varName)//"')"; return; endif ! fix the snow albedo - if(progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%scalarSnowAlbedo)%dat(1) < 0._summa_prec)then + if(progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%scalarSnowAlbedo)%dat(1) < 0._rk)then progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%scalarSnowAlbedo)%dat(1) = mparData%gru(iGRU)%hru(iHRU)%var(iLookPARAM%albedoMax)%dat(1) endif @@ -376,7 +376,7 @@ subroutine read_icond(iconFile, & ! intent(in): name of mparData%gru(iGRU)%hru(iHRU)%var(iLookPARAM%vGn_n )%dat(iLayer),& ! intent(in): van Genutchen "n" parameter mparData%gru(iGRU)%hru(iHRU)%var(iLookPARAM%theta_sat )%dat(iLayer),& ! intent(in): soil porosity (-) mparData%gru(iGRU)%hru(iHRU)%var(iLookPARAM%theta_res )%dat(iLayer),& ! intent(in): soil residual volumetric water content (-) - 1._summa_prec - 1._summa_prec/mparData%gru(iGRU)%hru(iHRU)%var(iLookPARAM%vGn_n)%dat(iLayer),& ! intent(in): van Genutchen "m" parameter (-) + 1._rk - 1._rk/mparData%gru(iGRU)%hru(iHRU)%var(iLookPARAM%vGn_n)%dat(iLayer),& ! intent(in): van Genutchen "m" parameter (-) ! output progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%mLayerVolFracWat )%dat(jLayer),& ! intent(out): volumetric fraction of total water (-) progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%mLayerVolFracLiq )%dat(jLayer),& ! intent(out): volumetric fraction of liquid water (-) diff --git a/build/source/noah-mp/module_model_constants.F b/build/source/noah-mp/module_model_constants.F index d954ea0d9..a982c7ca7 100755 --- a/build/source/noah-mp/module_model_constants.F +++ b/build/source/noah-mp/module_model_constants.F @@ -8,133 +8,133 @@ MODULE module_model_constants ! A really small number. - REAL(SUMMA_PREC) , PARAMETER :: epsilon = 1.E-15 + REAL(rk) , PARAMETER :: epsilon = 1.E-15 ! 4. Following is information related to the physical constants. ! These are the physical constants used within the model. ! JM NOTE -- can we name this grav instead? - REAL(SUMMA_PREC) , PARAMETER :: g = 9.81 ! acceleration due to gravity (m {s}^-2) + REAL(rk) , PARAMETER :: g = 9.81 ! acceleration due to gravity (m {s}^-2) #if ( NMM_CORE == 1 ) - REAL(SUMMA_PREC) , PARAMETER :: r_d = 287.04 - REAL(SUMMA_PREC) , PARAMETER :: cp = 1004.6 + REAL(rk) , PARAMETER :: r_d = 287.04 + REAL(rk) , PARAMETER :: cp = 1004.6 #else - REAL(SUMMA_PREC) , PARAMETER :: r_d = 287. - REAL(SUMMA_PREC) , PARAMETER :: cp = 7.*r_d/2. + REAL(rk) , PARAMETER :: r_d = 287. + REAL(rk) , PARAMETER :: cp = 7.*r_d/2. #endif - REAL(SUMMA_PREC) , PARAMETER :: r_v = 461.6 - REAL(SUMMA_PREC) , PARAMETER :: cv = cp-r_d - REAL(SUMMA_PREC) , PARAMETER :: cpv = 4.*r_v - REAL(SUMMA_PREC) , PARAMETER :: cvv = cpv-r_v - REAL(SUMMA_PREC) , PARAMETER :: cvpm = -cv/cp - REAL(SUMMA_PREC) , PARAMETER :: cliq = 4190. - REAL(SUMMA_PREC) , PARAMETER :: cice = 2106. - REAL(SUMMA_PREC) , PARAMETER :: psat = 610.78 - REAL(SUMMA_PREC) , PARAMETER :: rcv = r_d/cv - REAL(SUMMA_PREC) , PARAMETER :: rcp = r_d/cp - REAL(SUMMA_PREC) , PARAMETER :: rovg = r_d/g - REAL(SUMMA_PREC) , PARAMETER :: c2 = cp * rcv + REAL(rk) , PARAMETER :: r_v = 461.6 + REAL(rk) , PARAMETER :: cv = cp-r_d + REAL(rk) , PARAMETER :: cpv = 4.*r_v + REAL(rk) , PARAMETER :: cvv = cpv-r_v + REAL(rk) , PARAMETER :: cvpm = -cv/cp + REAL(rk) , PARAMETER :: cliq = 4190. + REAL(rk) , PARAMETER :: cice = 2106. + REAL(rk) , PARAMETER :: psat = 610.78 + REAL(rk) , PARAMETER :: rcv = r_d/cv + REAL(rk) , PARAMETER :: rcp = r_d/cp + REAL(rk) , PARAMETER :: rovg = r_d/g + REAL(rk) , PARAMETER :: c2 = cp * rcv real , parameter :: mwdry = 28.966 ! molecular weight of dry air (g/mole) - REAL(SUMMA_PREC) , PARAMETER :: p1000mb = 100000. - REAL(SUMMA_PREC) , PARAMETER :: t0 = 300. - REAL(SUMMA_PREC) , PARAMETER :: p0 = p1000mb - REAL(SUMMA_PREC) , PARAMETER :: cpovcv = cp/(cp-r_d) - REAL(SUMMA_PREC) , PARAMETER :: cvovcp = 1./cpovcv - REAL(SUMMA_PREC) , PARAMETER :: rvovrd = r_v/r_d + REAL(rk) , PARAMETER :: p1000mb = 100000. + REAL(rk) , PARAMETER :: t0 = 300. + REAL(rk) , PARAMETER :: p0 = p1000mb + REAL(rk) , PARAMETER :: cpovcv = cp/(cp-r_d) + REAL(rk) , PARAMETER :: cvovcp = 1./cpovcv + REAL(rk) , PARAMETER :: rvovrd = r_v/r_d - REAL(SUMMA_PREC) , PARAMETER :: reradius = 1./6370.0e03 + REAL(rk) , PARAMETER :: reradius = 1./6370.0e03 - REAL(SUMMA_PREC) , PARAMETER :: asselin = .025 -! REAL(SUMMA_PREC) , PARAMETER :: asselin = .0 - REAL(SUMMA_PREC) , PARAMETER :: cb = 25. + REAL(rk) , PARAMETER :: asselin = .025 +! REAL(rk) , PARAMETER :: asselin = .0 + REAL(rk) , PARAMETER :: cb = 25. - REAL(SUMMA_PREC) , PARAMETER :: XLV0 = 3.15E6 - REAL(SUMMA_PREC) , PARAMETER :: XLV1 = 2370. - REAL(SUMMA_PREC) , PARAMETER :: XLS0 = 2.905E6 - REAL(SUMMA_PREC) , PARAMETER :: XLS1 = 259.532 + REAL(rk) , PARAMETER :: XLV0 = 3.15E6 + REAL(rk) , PARAMETER :: XLV1 = 2370. + REAL(rk) , PARAMETER :: XLS0 = 2.905E6 + REAL(rk) , PARAMETER :: XLS1 = 259.532 - REAL(SUMMA_PREC) , PARAMETER :: XLS = 2.85E6 - REAL(SUMMA_PREC) , PARAMETER :: XLV = 2.5E6 - REAL(SUMMA_PREC) , PARAMETER :: XLF = 3.50E5 + REAL(rk) , PARAMETER :: XLS = 2.85E6 + REAL(rk) , PARAMETER :: XLV = 2.5E6 + REAL(rk) , PARAMETER :: XLF = 3.50E5 - REAL(SUMMA_PREC) , PARAMETER :: rhowater = 1000. - REAL(SUMMA_PREC) , PARAMETER :: rhosnow = 100. - REAL(SUMMA_PREC) , PARAMETER :: rhoair0 = 1.28 + REAL(rk) , PARAMETER :: rhowater = 1000. + REAL(rk) , PARAMETER :: rhosnow = 100. + REAL(rk) , PARAMETER :: rhoair0 = 1.28 ! - REAL(SUMMA_PREC) , PARAMETER :: n_ccn0 = 1.0E8 + REAL(rk) , PARAMETER :: n_ccn0 = 1.0E8 ! - REAL(SUMMA_PREC) , PARAMETER :: DEGRAD = 3.1415926/180. - REAL(SUMMA_PREC) , PARAMETER :: DPD = 360./365. - - REAL(SUMMA_PREC) , PARAMETER :: SVP1=0.6112 - REAL(SUMMA_PREC) , PARAMETER :: SVP2=17.67 - REAL(SUMMA_PREC) , PARAMETER :: SVP3=29.65 - REAL(SUMMA_PREC) , PARAMETER :: SVPT0=273.15 - REAL(SUMMA_PREC) , PARAMETER :: EP_1=R_v/R_d-1. - REAL(SUMMA_PREC) , PARAMETER :: EP_2=R_d/R_v - REAL(SUMMA_PREC) , PARAMETER :: KARMAN=0.4 - REAL(SUMMA_PREC) , PARAMETER :: EOMEG=7.2921E-5 - REAL(SUMMA_PREC) , PARAMETER :: STBOLT=5.67051E-8 - - REAL(SUMMA_PREC) , PARAMETER :: prandtl = 1./3.0 + REAL(rk) , PARAMETER :: DEGRAD = 3.1415926/180. + REAL(rk) , PARAMETER :: DPD = 360./365. + + REAL(rk) , PARAMETER :: SVP1=0.6112 + REAL(rk) , PARAMETER :: SVP2=17.67 + REAL(rk) , PARAMETER :: SVP3=29.65 + REAL(rk) , PARAMETER :: SVPT0=273.15 + REAL(rk) , PARAMETER :: EP_1=R_v/R_d-1. + REAL(rk) , PARAMETER :: EP_2=R_d/R_v + REAL(rk) , PARAMETER :: KARMAN=0.4 + REAL(rk) , PARAMETER :: EOMEG=7.2921E-5 + REAL(rk) , PARAMETER :: STBOLT=5.67051E-8 + + REAL(rk) , PARAMETER :: prandtl = 1./3.0 ! constants for w-damping option - REAL(SUMMA_PREC) , PARAMETER :: w_alpha = 0.3 ! strength m/s/s - REAL(SUMMA_PREC) , PARAMETER :: w_beta = 1.0 ! activation cfl number - - REAL(SUMMA_PREC) , PARAMETER :: pq0=379.90516 - REAL(SUMMA_PREC) , PARAMETER :: epsq2=0.2 - REAL(SUMMA_PREC) , PARAMETER :: a2=17.2693882 - REAL(SUMMA_PREC) , PARAMETER :: a3=273.16 - REAL(SUMMA_PREC) , PARAMETER :: a4=35.86 - REAL(SUMMA_PREC) , PARAMETER :: epsq=1.e-12 - REAL(SUMMA_PREC) , PARAMETER :: p608=rvovrd-1. + REAL(rk) , PARAMETER :: w_alpha = 0.3 ! strength m/s/s + REAL(rk) , PARAMETER :: w_beta = 1.0 ! activation cfl number + + REAL(rk) , PARAMETER :: pq0=379.90516 + REAL(rk) , PARAMETER :: epsq2=0.2 + REAL(rk) , PARAMETER :: a2=17.2693882 + REAL(rk) , PARAMETER :: a3=273.16 + REAL(rk) , PARAMETER :: a4=35.86 + REAL(rk) , PARAMETER :: epsq=1.e-12 + REAL(rk) , PARAMETER :: p608=rvovrd-1. !#if ( NMM_CORE == 1 ) - REAL(SUMMA_PREC) , PARAMETER :: climit=1.e-20 - REAL(SUMMA_PREC) , PARAMETER :: cm1=2937.4 - REAL(SUMMA_PREC) , PARAMETER :: cm2=4.9283 - REAL(SUMMA_PREC) , PARAMETER :: cm3=23.5518 -! REAL(SUMMA_PREC) , PARAMETER :: defc=8.0 -! REAL(SUMMA_PREC) , PARAMETER :: defm=32.0 - REAL(SUMMA_PREC) , PARAMETER :: defc=0.0 - REAL(SUMMA_PREC) , PARAMETER :: defm=99999.0 - REAL(SUMMA_PREC) , PARAMETER :: epsfc=1./1.05 - REAL(SUMMA_PREC) , PARAMETER :: epswet=0.0 - REAL(SUMMA_PREC) , PARAMETER :: fcdif=1./3. + REAL(rk) , PARAMETER :: climit=1.e-20 + REAL(rk) , PARAMETER :: cm1=2937.4 + REAL(rk) , PARAMETER :: cm2=4.9283 + REAL(rk) , PARAMETER :: cm3=23.5518 +! REAL(rk) , PARAMETER :: defc=8.0 +! REAL(rk) , PARAMETER :: defm=32.0 + REAL(rk) , PARAMETER :: defc=0.0 + REAL(rk) , PARAMETER :: defm=99999.0 + REAL(rk) , PARAMETER :: epsfc=1./1.05 + REAL(rk) , PARAMETER :: epswet=0.0 + REAL(rk) , PARAMETER :: fcdif=1./3. #ifdef HWRF - REAL(SUMMA_PREC) , PARAMETER :: fcm=0.0 + REAL(rk) , PARAMETER :: fcm=0.0 #else - REAL(SUMMA_PREC) , PARAMETER :: fcm=0.00003 + REAL(rk) , PARAMETER :: fcm=0.00003 #endif - REAL(SUMMA_PREC) , PARAMETER :: gma=-r_d*(1.-rcp)*0.5 - REAL(SUMMA_PREC) , PARAMETER :: p400=40000.0 - REAL(SUMMA_PREC) , PARAMETER :: phitp=15000.0 - REAL(SUMMA_PREC) , PARAMETER :: pi2=2.*3.1415926 - REAL(SUMMA_PREC) , PARAMETER :: plbtm=105000.0 - REAL(SUMMA_PREC) , PARAMETER :: plomd=64200.0 - REAL(SUMMA_PREC) , PARAMETER :: pmdhi=35000.0 - REAL(SUMMA_PREC) , PARAMETER :: q2ini=0.50 - REAL(SUMMA_PREC) , PARAMETER :: rfcp=0.25/cp - REAL(SUMMA_PREC) , PARAMETER :: rhcrit_land=0.75 - REAL(SUMMA_PREC) , PARAMETER :: rhcrit_sea=0.80 - REAL(SUMMA_PREC) , PARAMETER :: rlag=14.8125 - REAL(SUMMA_PREC) , PARAMETER :: rlx=0.90 - REAL(SUMMA_PREC) , PARAMETER :: scq2=50.0 - REAL(SUMMA_PREC) , PARAMETER :: slopht=0.001 - REAL(SUMMA_PREC) , PARAMETER :: tlc=2.*0.703972477 - REAL(SUMMA_PREC) , PARAMETER :: wa=0.15 - REAL(SUMMA_PREC) , PARAMETER :: wght=0.35 - REAL(SUMMA_PREC) , PARAMETER :: wpc=0.075 - REAL(SUMMA_PREC) , PARAMETER :: z0land=0.10 + REAL(rk) , PARAMETER :: gma=-r_d*(1.-rcp)*0.5 + REAL(rk) , PARAMETER :: p400=40000.0 + REAL(rk) , PARAMETER :: phitp=15000.0 + REAL(rk) , PARAMETER :: pi2=2.*3.1415926 + REAL(rk) , PARAMETER :: plbtm=105000.0 + REAL(rk) , PARAMETER :: plomd=64200.0 + REAL(rk) , PARAMETER :: pmdhi=35000.0 + REAL(rk) , PARAMETER :: q2ini=0.50 + REAL(rk) , PARAMETER :: rfcp=0.25/cp + REAL(rk) , PARAMETER :: rhcrit_land=0.75 + REAL(rk) , PARAMETER :: rhcrit_sea=0.80 + REAL(rk) , PARAMETER :: rlag=14.8125 + REAL(rk) , PARAMETER :: rlx=0.90 + REAL(rk) , PARAMETER :: scq2=50.0 + REAL(rk) , PARAMETER :: slopht=0.001 + REAL(rk) , PARAMETER :: tlc=2.*0.703972477 + REAL(rk) , PARAMETER :: wa=0.15 + REAL(rk) , PARAMETER :: wght=0.35 + REAL(rk) , PARAMETER :: wpc=0.075 + REAL(rk) , PARAMETER :: z0land=0.10 #ifdef HWRF - REAL(SUMMA_PREC) , PARAMETER :: z0max=0.01 + REAL(rk) , PARAMETER :: z0max=0.01 #else - REAL(SUMMA_PREC) , PARAMETER :: z0max=0.008 + REAL(rk) , PARAMETER :: z0max=0.008 #endif - REAL(SUMMA_PREC) , PARAMETER :: z0sea=0.001 + REAL(rk) , PARAMETER :: z0sea=0.001 !#endif @@ -142,19 +142,19 @@ MODULE module_model_constants ! The value for P2SI *must* be set to 1.0 for Earth ! Although, now we may not need this declaration here (see above) - !REAL(SUMMA_PREC) , PARAMETER :: P2SI = 1.0 + !REAL(rk) , PARAMETER :: P2SI = 1.0 ! Orbital constants: INTEGER , PARAMETER :: PLANET_YEAR = 365 - REAL(SUMMA_PREC) , PARAMETER :: OBLIQUITY = 23.5 - REAL(SUMMA_PREC) , PARAMETER :: ECCENTRICITY = 0.014 - REAL(SUMMA_PREC) , PARAMETER :: SEMIMAJORAXIS = 1.0 ! In AU + REAL(rk) , PARAMETER :: OBLIQUITY = 23.5 + REAL(rk) , PARAMETER :: ECCENTRICITY = 0.014 + REAL(rk) , PARAMETER :: SEMIMAJORAXIS = 1.0 ! In AU ! Don't know the following values, so we'll fake them for now - REAL(SUMMA_PREC) , PARAMETER :: zero_date = 0.0 ! Time of perihelion passage + REAL(rk) , PARAMETER :: zero_date = 0.0 ! Time of perihelion passage ! Fraction into the year (from perhelion) of the ! occurrence of the Northern Spring Equinox - REAL(SUMMA_PREC) , PARAMETER :: EQUINOX_FRACTION= 0.0 + REAL(rk) , PARAMETER :: EQUINOX_FRACTION= 0.0 CONTAINS SUBROUTINE init_module_model_constants diff --git a/build/source/noah-mp/module_sf_noahlsm.F b/build/source/noah-mp/module_sf_noahlsm.F index d033784f8..9434678ea 100755 --- a/build/source/noah-mp/module_sf_noahlsm.F +++ b/build/source/noah-mp/module_sf_noahlsm.F @@ -2,8 +2,8 @@ MODULE module_sf_noahlsm USE nrtype USE module_model_constants -! REAL(SUMMA_PREC), PARAMETER :: CP = 1004.5 - REAL(SUMMA_PREC), PARAMETER :: RD = 287.04, SIGMA = 5.67E-8, & +! REAL(rk), PARAMETER :: CP = 1004.5 + REAL(rk), PARAMETER :: RD = 287.04, SIGMA = 5.67E-8, & CPH2O = 4.218E+3,CPICE = 2.106E+3, & LSUBF = 3.335E+5, & EMISSI_S = 0.95 @@ -20,26 +20,26 @@ MODULE module_sf_noahlsm LAIMINTBL, LAIMAXTBL, & Z0MINTBL, Z0MAXTBL, & ALBEDOMINTBL, ALBEDOMAXTBL - REAL(SUMMA_PREC) :: TOPT_DATA,CMCMAX_DATA,CFACTR_DATA,RSMAX_DATA + REAL(rk) :: TOPT_DATA,CMCMAX_DATA,CFACTR_DATA,RSMAX_DATA ! SOIL PARAMETERS INTEGER :: SLCATS INTEGER, PARAMETER :: NSLTYPE=30 CHARACTER(LEN=256) SLTYPE - REAL(SUMMA_PREC), DIMENSION (1:NSLTYPE) :: BB,DRYSMC,F11, & + REAL(rk), DIMENSION (1:NSLTYPE) :: BB,DRYSMC,F11, & MAXSMC, REFSMC,SATPSI,SATDK,SATDW, WLTSMC,QTZ ! MPC add van Genutchen parameters - REAL(SUMMA_PREC), DIMENSION (1:NSLTYPE) :: theta_res, theta_sat, & + REAL(rk), DIMENSION (1:NSLTYPE) :: theta_res, theta_sat, & vGn_alpha, vGn_n, k_soil ! LSM GENERAL PARAMETERS INTEGER :: SLPCATS INTEGER, PARAMETER :: NSLOPE=30 - REAL(SUMMA_PREC), DIMENSION (1:NSLOPE) :: SLOPE_DATA - REAL(SUMMA_PREC) :: SBETA_DATA,FXEXP_DATA,CSOIL_DATA,SALP_DATA,REFDK_DATA, & + REAL(rk), DIMENSION (1:NSLOPE) :: SLOPE_DATA + REAL(rk) :: SBETA_DATA,FXEXP_DATA,CSOIL_DATA,SALP_DATA,REFDK_DATA, & REFKDT_DATA,FRZK_DATA,ZBOT_DATA, SMLOW_DATA,SMHIGH_DATA, & CZIL_DATA - REAL(SUMMA_PREC) :: LVCOEF_DATA + REAL(rk) :: LVCOEF_DATA CHARACTER*256 :: err_message integer, private :: iloc, jloc diff --git a/build/source/noah-mp/module_sf_noahmplsm.F b/build/source/noah-mp/module_sf_noahmplsm.F index 898efbac7..cfd09494a 100755 --- a/build/source/noah-mp/module_sf_noahmplsm.F +++ b/build/source/noah-mp/module_sf_noahmplsm.F @@ -37,33 +37,33 @@ module noahmp_globals ! Physical Constants: ! !------------------------------------------------------------------------------------------! - REAL(SUMMA_PREC), PARAMETER :: GRAV = 9.80616 !acceleration due to gravity (m/s2) - REAL(SUMMA_PREC), PARAMETER :: SB = 5.67E-08 !Stefan-Boltzmann constant (w/m2/k4) - REAL(SUMMA_PREC), PARAMETER :: VKC = 0.40 !von Karman constant - REAL(SUMMA_PREC), PARAMETER :: TFRZ = 273.16 !freezing/melting point (k) - REAL(SUMMA_PREC), PARAMETER :: HSUB = 2.8440E06 !latent heat of sublimation (j/kg) - REAL(SUMMA_PREC), PARAMETER :: HVAP = 2.5104E06 !latent heat of vaporization (j/kg) - REAL(SUMMA_PREC), PARAMETER :: HFUS = 0.3336E06 !latent heat of fusion (j/kg) - REAL(SUMMA_PREC), PARAMETER :: CWAT = 4.188E06 !specific heat capacity of water (j/m3/k) - REAL(SUMMA_PREC), PARAMETER :: CICE = 2.094E06 !specific heat capacity of ice (j/m3/k) - REAL(SUMMA_PREC), PARAMETER :: CPAIR = 1004.64 !heat capacity dry air at const pres (j/kg/k) - REAL(SUMMA_PREC), PARAMETER :: TKWAT = 0.6 !thermal conductivity of water (w/m/k) - REAL(SUMMA_PREC), PARAMETER :: TKICE = 2.2 !thermal conductivity of ice (w/m/k) - REAL(SUMMA_PREC), PARAMETER :: TKAIR = 0.023 !thermal conductivity of air (w/m/k) - REAL(SUMMA_PREC), PARAMETER :: RAIR = 287.04 !gas constant for dry air (j/kg/k) - REAL(SUMMA_PREC), PARAMETER :: RW = 461.269 !gas constant for water vapor (j/kg/k) - REAL(SUMMA_PREC), PARAMETER :: DENH2O = 1000. !density of water (kg/m3) - REAL(SUMMA_PREC), PARAMETER :: DENICE = 917. !density of ice (kg/m3) + REAL(rk), PARAMETER :: GRAV = 9.80616 !acceleration due to gravity (m/s2) + REAL(rk), PARAMETER :: SB = 5.67E-08 !Stefan-Boltzmann constant (w/m2/k4) + REAL(rk), PARAMETER :: VKC = 0.40 !von Karman constant + REAL(rk), PARAMETER :: TFRZ = 273.16 !freezing/melting point (k) + REAL(rk), PARAMETER :: HSUB = 2.8440E06 !latent heat of sublimation (j/kg) + REAL(rk), PARAMETER :: HVAP = 2.5104E06 !latent heat of vaporization (j/kg) + REAL(rk), PARAMETER :: HFUS = 0.3336E06 !latent heat of fusion (j/kg) + REAL(rk), PARAMETER :: CWAT = 4.188E06 !specific heat capacity of water (j/m3/k) + REAL(rk), PARAMETER :: CICE = 2.094E06 !specific heat capacity of ice (j/m3/k) + REAL(rk), PARAMETER :: CPAIR = 1004.64 !heat capacity dry air at const pres (j/kg/k) + REAL(rk), PARAMETER :: TKWAT = 0.6 !thermal conductivity of water (w/m/k) + REAL(rk), PARAMETER :: TKICE = 2.2 !thermal conductivity of ice (w/m/k) + REAL(rk), PARAMETER :: TKAIR = 0.023 !thermal conductivity of air (w/m/k) + REAL(rk), PARAMETER :: RAIR = 287.04 !gas constant for dry air (j/kg/k) + REAL(rk), PARAMETER :: RW = 461.269 !gas constant for water vapor (j/kg/k) + REAL(rk), PARAMETER :: DENH2O = 1000. !density of water (kg/m3) + REAL(rk), PARAMETER :: DENICE = 917. !density of ice (kg/m3) !------------------------------------------------------------------------------------------! ! From the VEGPARM.TBL tables, as functions of vegetation category. !------------------------------------------------------------------------------------------! INTEGER :: NROOT !rooting depth [as the number of layers] ( Assigned in REDPRM ) - REAL(SUMMA_PREC) :: RGL !parameter used in radiation stress function ( Assigned in REDPRM ) - REAL(SUMMA_PREC) :: RSMIN !minimum Canopy Resistance [s/m] ( Assigned in REDPRM ) - REAL(SUMMA_PREC) :: HS !parameter used in vapor pressure deficit function ( Assigned in REDPRM ) - REAL(SUMMA_PREC) :: RSMAX !maximum stomatal resistance ( Assigned in REDPRM ) - REAL(SUMMA_PREC) :: TOPT !optimum transpiration air temperature. + REAL(rk) :: RGL !parameter used in radiation stress function ( Assigned in REDPRM ) + REAL(rk) :: RSMIN !minimum Canopy Resistance [s/m] ( Assigned in REDPRM ) + REAL(rk) :: HS !parameter used in vapor pressure deficit function ( Assigned in REDPRM ) + REAL(rk) :: RSMAX !maximum stomatal resistance ( Assigned in REDPRM ) + REAL(rk) :: TOPT !optimum transpiration air temperature. ! MPC change: make variables private for a given thread !$omp threadprivate(NROOT, RGL, RSMIN, HS, RSMAX, TOPT) @@ -71,17 +71,17 @@ module noahmp_globals !------------------------------------------------------------------------------------------! ! From the SOILPARM.TBL tables, as functions of soil category. !------------------------------------------------------------------------------------------! - REAL(SUMMA_PREC) :: BEXP !B parameter ( Assigned in REDPRM ) - REAL(SUMMA_PREC) :: SMCDRY !dry soil moisture threshold where direct evap from top + REAL(rk) :: BEXP !B parameter ( Assigned in REDPRM ) + REAL(rk) :: SMCDRY !dry soil moisture threshold where direct evap from top !layer ends (volumetric) ( Assigned in REDPRM ) - REAL(SUMMA_PREC) :: F1 !soil thermal diffusivity/conductivity coef ( Assigned in REDPRM ) - REAL(SUMMA_PREC) :: SMCMAX !porosity, saturated value of soil moisture (volumetric) - REAL(SUMMA_PREC) :: SMCREF !reference soil moisture (field capacity) (volumetric) ( Assigned in REDPRM ) - REAL(SUMMA_PREC) :: PSISAT !saturated soil matric potential ( Assigned in REDPRM ) - REAL(SUMMA_PREC) :: DKSAT !saturated soil hydraulic conductivity ( Assigned in REDPRM ) - REAL(SUMMA_PREC) :: DWSAT !saturated soil hydraulic diffusivity ( Assigned in REDPRM ) - REAL(SUMMA_PREC) :: SMCWLT !wilting point soil moisture (volumetric) ( Assigned in REDPRM ) - REAL(SUMMA_PREC) :: QUARTZ !soil quartz content ( Assigned in REDPRM ) + REAL(rk) :: F1 !soil thermal diffusivity/conductivity coef ( Assigned in REDPRM ) + REAL(rk) :: SMCMAX !porosity, saturated value of soil moisture (volumetric) + REAL(rk) :: SMCREF !reference soil moisture (field capacity) (volumetric) ( Assigned in REDPRM ) + REAL(rk) :: PSISAT !saturated soil matric potential ( Assigned in REDPRM ) + REAL(rk) :: DKSAT !saturated soil hydraulic conductivity ( Assigned in REDPRM ) + REAL(rk) :: DWSAT !saturated soil hydraulic diffusivity ( Assigned in REDPRM ) + REAL(rk) :: SMCWLT !wilting point soil moisture (volumetric) ( Assigned in REDPRM ) + REAL(rk) :: QUARTZ !soil quartz content ( Assigned in REDPRM ) ! MPC change: make variables private for a given thread !$omp threadprivate(BEXP, SMCDRY, F1, SMCMAX, SMCREF, PSISAT, DKSAT, DWSAT, SMCWLT, QUARTZ) @@ -89,16 +89,16 @@ module noahmp_globals !------------------------------------------------------------------------------------------! ! From the GENPARM.TBL file !------------------------------------------------------------------------------------------! - REAL(SUMMA_PREC) :: SLOPE !slope index (0 - 1) ( Assigned in REDPRM ) - REAL(SUMMA_PREC) :: CSOIL !vol. soil heat capacity [j/m3/K] ( Assigned in REDPRM ) - REAL(SUMMA_PREC) :: ZBOT !Depth (m) of lower boundary soil temperature ( Assigned in REDPRM ) - REAL(SUMMA_PREC) :: CZIL !Calculate roughness length of heat ( Assigned in REDPRM ) + REAL(rk) :: SLOPE !slope index (0 - 1) ( Assigned in REDPRM ) + REAL(rk) :: CSOIL !vol. soil heat capacity [j/m3/K] ( Assigned in REDPRM ) + REAL(rk) :: ZBOT !Depth (m) of lower boundary soil temperature ( Assigned in REDPRM ) + REAL(rk) :: CZIL !Calculate roughness length of heat ( Assigned in REDPRM ) ! MPC note: FRZK_DATA, REFDK_DATA, and REFKDT_DATA are used in REDPRM to compute KDT and FRZX ! (FRZK, REFDK, and REFKDT are local variables within REDPRM and do not need to be thread private) - REAL(SUMMA_PREC) :: KDT !used in compute maximum infiltration rate (in INFIL) ( Assigned in REDPRM ) - REAL(SUMMA_PREC) :: FRZX !used in compute maximum infiltration rate (in INFIL) ( Assigned in REDPRM ) + REAL(rk) :: KDT !used in compute maximum infiltration rate (in INFIL) ( Assigned in REDPRM ) + REAL(rk) :: FRZX !used in compute maximum infiltration rate (in INFIL) ( Assigned in REDPRM ) ! MPC change: make variables private for a given thread !$omp threadprivate(SLOPE, CSOIL, ZBOT, CZIL, KDT, FRZX) @@ -179,15 +179,15 @@ module noahmp_globals INTEGER :: OPT_STC != 1 !(suggested 1) ! ================================================================================================== ! runoff parameters used for SIMTOP and SIMGM: - REAL(SUMMA_PREC), PARAMETER :: TIMEAN = 10.5 !gridcell mean topgraphic index (global mean) - REAL(SUMMA_PREC), PARAMETER :: FSATMX = 0.38 !maximum surface saturated fraction (global mean) + REAL(rk), PARAMETER :: TIMEAN = 10.5 !gridcell mean topgraphic index (global mean) + REAL(rk), PARAMETER :: FSATMX = 0.38 !maximum surface saturated fraction (global mean) ! adjustable parameters for snow processes - REAL(SUMMA_PREC), PARAMETER :: M = 1.0 ! 2.50 !melting factor (-) - REAL(SUMMA_PREC), PARAMETER :: Z0SNO = 0.002 !snow surface roughness length (m) (0.002) - REAL(SUMMA_PREC), PARAMETER :: SSI = 0.03 !liquid water holding capacity for snowpack (m3/m3) (0.03) - REAL(SUMMA_PREC), PARAMETER :: SWEMX = 1.00 !new snow mass to fully cover old snow (mm) + REAL(rk), PARAMETER :: M = 1.0 ! 2.50 !melting factor (-) + REAL(rk), PARAMETER :: Z0SNO = 0.002 !snow surface roughness length (m) (0.002) + REAL(rk), PARAMETER :: SSI = 0.03 !liquid water holding capacity for snowpack (m3/m3) (0.03) + REAL(rk), PARAMETER :: SWEMX = 1.00 !new snow mass to fully cover old snow (mm) !equivalent to 10mm depth (density = 100 kg/m3) ! NOTES: things to add or improve @@ -214,63 +214,63 @@ MODULE NOAHMP_VEG_PARAMETERS INTEGER :: ISSNOW INTEGER :: EBLFOREST - REAL(SUMMA_PREC) :: CH2OP(MVT) !maximum intercepted h2o per unit lai+sai (mm) - REAL(SUMMA_PREC) :: DLEAF(MVT) !characteristic leaf dimension (m) - REAL(SUMMA_PREC) :: Z0MVT(MVT) !momentum roughness length (m) - REAL(SUMMA_PREC) :: HVT(MVT) !top of canopy (m) - REAL(SUMMA_PREC) :: HVB(MVT) !bottom of canopy (m) - REAL(SUMMA_PREC) :: DEN(MVT) !tree density (no. of trunks per m2) - REAL(SUMMA_PREC) :: RC(MVT) !tree crown radius (m) - REAL(SUMMA_PREC) :: SAIM(MVT,12) !monthly stem area index, one-sided - REAL(SUMMA_PREC) :: LAIM(MVT,12) !monthly leaf area index, one-sided - REAL(SUMMA_PREC) :: SLA(MVT) !single-side leaf area per Kg [m2/kg] - REAL(SUMMA_PREC) :: DILEFC(MVT) !coeficient for leaf stress death [1/s] - REAL(SUMMA_PREC) :: DILEFW(MVT) !coeficient for leaf stress death [1/s] - REAL(SUMMA_PREC) :: FRAGR(MVT) !fraction of growth respiration !original was 0.3 - REAL(SUMMA_PREC) :: LTOVRC(MVT) !leaf turnover [1/s] - - REAL(SUMMA_PREC) :: C3PSN(MVT) !photosynthetic pathway: 0. = c4, 1. = c3 - REAL(SUMMA_PREC) :: KC25(MVT) !co2 michaelis-menten constant at 25c (pa) - REAL(SUMMA_PREC) :: AKC(MVT) !q10 for kc25 - REAL(SUMMA_PREC) :: KO25(MVT) !o2 michaelis-menten constant at 25c (pa) - REAL(SUMMA_PREC) :: AKO(MVT) !q10 for ko25 - REAL(SUMMA_PREC) :: VCMX25(MVT) !maximum rate of carboxylation at 25c (umol co2/m**2/s) - REAL(SUMMA_PREC) :: AVCMX(MVT) !q10 for vcmx25 - REAL(SUMMA_PREC) :: BP(MVT) !minimum leaf conductance (umol/m**2/s) - REAL(SUMMA_PREC) :: MP(MVT) !slope of conductance-to-photosynthesis relationship - REAL(SUMMA_PREC) :: QE25(MVT) !quantum efficiency at 25c (umol co2 / umol photon) - REAL(SUMMA_PREC) :: AQE(MVT) !q10 for qe25 - REAL(SUMMA_PREC) :: RMF25(MVT) !leaf maintenance respiration at 25c (umol co2/m**2/s) - REAL(SUMMA_PREC) :: RMS25(MVT) !stem maintenance respiration at 25c (umol co2/kg bio/s) - REAL(SUMMA_PREC) :: RMR25(MVT) !root maintenance respiration at 25c (umol co2/kg bio/s) - REAL(SUMMA_PREC) :: ARM(MVT) !q10 for maintenance respiration - REAL(SUMMA_PREC) :: FOLNMX(MVT) !foliage nitrogen concentration when f(n)=1 (%) - REAL(SUMMA_PREC) :: TMIN(MVT) !minimum temperature for photosynthesis (k) - - REAL(SUMMA_PREC) :: XL(MVT) !leaf/stem orientation index - REAL(SUMMA_PREC) :: RHOL(MVT,MBAND) !leaf reflectance: 1=vis, 2=nir - REAL(SUMMA_PREC) :: RHOS(MVT,MBAND) !stem reflectance: 1=vis, 2=nir - REAL(SUMMA_PREC) :: TAUL(MVT,MBAND) !leaf transmittance: 1=vis, 2=nir - REAL(SUMMA_PREC) :: TAUS(MVT,MBAND) !stem transmittance: 1=vis, 2=nir - - REAL(SUMMA_PREC) :: MRP(MVT) !microbial respiration parameter (umol co2 /kg c/ s) - REAL(SUMMA_PREC) :: CWPVT(MVT) !empirical canopy wind parameter - - REAL(SUMMA_PREC) :: WRRAT(MVT) !wood to non-wood ratio - REAL(SUMMA_PREC) :: WDPOOL(MVT) !wood pool (switch 1 or 0) depending on woody or not [-] - REAL(SUMMA_PREC) :: TDLEF(MVT) !characteristic T for leaf freezing [K] + REAL(rk) :: CH2OP(MVT) !maximum intercepted h2o per unit lai+sai (mm) + REAL(rk) :: DLEAF(MVT) !characteristic leaf dimension (m) + REAL(rk) :: Z0MVT(MVT) !momentum roughness length (m) + REAL(rk) :: HVT(MVT) !top of canopy (m) + REAL(rk) :: HVB(MVT) !bottom of canopy (m) + REAL(rk) :: DEN(MVT) !tree density (no. of trunks per m2) + REAL(rk) :: RC(MVT) !tree crown radius (m) + REAL(rk) :: SAIM(MVT,12) !monthly stem area index, one-sided + REAL(rk) :: LAIM(MVT,12) !monthly leaf area index, one-sided + REAL(rk) :: SLA(MVT) !single-side leaf area per Kg [m2/kg] + REAL(rk) :: DILEFC(MVT) !coeficient for leaf stress death [1/s] + REAL(rk) :: DILEFW(MVT) !coeficient for leaf stress death [1/s] + REAL(rk) :: FRAGR(MVT) !fraction of growth respiration !original was 0.3 + REAL(rk) :: LTOVRC(MVT) !leaf turnover [1/s] + + REAL(rk) :: C3PSN(MVT) !photosynthetic pathway: 0. = c4, 1. = c3 + REAL(rk) :: KC25(MVT) !co2 michaelis-menten constant at 25c (pa) + REAL(rk) :: AKC(MVT) !q10 for kc25 + REAL(rk) :: KO25(MVT) !o2 michaelis-menten constant at 25c (pa) + REAL(rk) :: AKO(MVT) !q10 for ko25 + REAL(rk) :: VCMX25(MVT) !maximum rate of carboxylation at 25c (umol co2/m**2/s) + REAL(rk) :: AVCMX(MVT) !q10 for vcmx25 + REAL(rk) :: BP(MVT) !minimum leaf conductance (umol/m**2/s) + REAL(rk) :: MP(MVT) !slope of conductance-to-photosynthesis relationship + REAL(rk) :: QE25(MVT) !quantum efficiency at 25c (umol co2 / umol photon) + REAL(rk) :: AQE(MVT) !q10 for qe25 + REAL(rk) :: RMF25(MVT) !leaf maintenance respiration at 25c (umol co2/m**2/s) + REAL(rk) :: RMS25(MVT) !stem maintenance respiration at 25c (umol co2/kg bio/s) + REAL(rk) :: RMR25(MVT) !root maintenance respiration at 25c (umol co2/kg bio/s) + REAL(rk) :: ARM(MVT) !q10 for maintenance respiration + REAL(rk) :: FOLNMX(MVT) !foliage nitrogen concentration when f(n)=1 (%) + REAL(rk) :: TMIN(MVT) !minimum temperature for photosynthesis (k) + + REAL(rk) :: XL(MVT) !leaf/stem orientation index + REAL(rk) :: RHOL(MVT,MBAND) !leaf reflectance: 1=vis, 2=nir + REAL(rk) :: RHOS(MVT,MBAND) !stem reflectance: 1=vis, 2=nir + REAL(rk) :: TAUL(MVT,MBAND) !leaf transmittance: 1=vis, 2=nir + REAL(rk) :: TAUS(MVT,MBAND) !stem transmittance: 1=vis, 2=nir + + REAL(rk) :: MRP(MVT) !microbial respiration parameter (umol co2 /kg c/ s) + REAL(rk) :: CWPVT(MVT) !empirical canopy wind parameter + + REAL(rk) :: WRRAT(MVT) !wood to non-wood ratio + REAL(rk) :: WDPOOL(MVT) !wood pool (switch 1 or 0) depending on woody or not [-] + REAL(rk) :: TDLEF(MVT) !characteristic T for leaf freezing [K] INTEGER :: IK,IM - REAL(SUMMA_PREC) :: TMP10(MVT*MBAND) - REAL(SUMMA_PREC) :: TMP11(MVT*MBAND) - REAL(SUMMA_PREC) :: TMP12(MVT*MBAND) - REAL(SUMMA_PREC) :: TMP13(MVT*MBAND) - REAL(SUMMA_PREC) :: TMP14(MVT*12) - REAL(SUMMA_PREC) :: TMP15(MVT*12) - REAL(SUMMA_PREC) :: TMP16(MVT*5) + REAL(rk) :: TMP10(MVT*MBAND) + REAL(rk) :: TMP11(MVT*MBAND) + REAL(rk) :: TMP12(MVT*MBAND) + REAL(rk) :: TMP13(MVT*MBAND) + REAL(rk) :: TMP14(MVT*12) + REAL(rk) :: TMP15(MVT*12) + REAL(rk) :: TMP16(MVT*5) - real(summa_prec) slarea(MVT) - real(summa_prec) eps(MVT,5) + real(rk) slarea(MVT) + real(rk) eps(MVT,5) CONTAINS subroutine read_mp_veg_parameters(FILENAME_VEGTABLE,DATASET_IDENTIFIER) @@ -280,13 +280,13 @@ subroutine read_mp_veg_parameters(FILENAME_VEGTABLE,DATASET_IDENTIFIER) integer :: ierr ! Temporary arrays used in reshaping namelist arrays - REAL(SUMMA_PREC) :: TMP10(MVT*MBAND) - REAL(SUMMA_PREC) :: TMP11(MVT*MBAND) - REAL(SUMMA_PREC) :: TMP12(MVT*MBAND) - REAL(SUMMA_PREC) :: TMP13(MVT*MBAND) - REAL(SUMMA_PREC) :: TMP14(MVT*12) - REAL(SUMMA_PREC) :: TMP15(MVT*12) - REAL(SUMMA_PREC) :: TMP16(MVT*5) + REAL(rk) :: TMP10(MVT*MBAND) + REAL(rk) :: TMP11(MVT*MBAND) + REAL(rk) :: TMP12(MVT*MBAND) + REAL(rk) :: TMP13(MVT*MBAND) + REAL(rk) :: TMP14(MVT*12) + REAL(rk) :: TMP15(MVT*12) + REAL(rk) :: TMP16(MVT*5) integer :: NVEG character(len=256) :: VEG_DATASET_DESCRIPTION @@ -448,14 +448,14 @@ MODULE NOAHMP_RAD_PARAMETERS INTEGER, PARAMETER :: MSC = 9 INTEGER, PARAMETER :: MBAND = 2 - REAL(SUMMA_PREC) :: ALBSAT(MSC,MBAND) !saturated soil albedos: 1=vis, 2=nir - REAL(SUMMA_PREC) :: ALBDRY(MSC,MBAND) !dry soil albedos: 1=vis, 2=nir - REAL(SUMMA_PREC) :: ALBICE(MBAND) !albedo land ice: 1=vis, 2=nir - REAL(SUMMA_PREC) :: ALBLAK(MBAND) !albedo frozen lakes: 1=vis, 2=nir - REAL(SUMMA_PREC) :: OMEGAS(MBAND) !two-stream parameter omega for snow - REAL(SUMMA_PREC) :: BETADS !two-stream parameter betad for snow - REAL(SUMMA_PREC) :: BETAIS !two-stream parameter betad for snow - REAL(SUMMA_PREC) :: EG(2) !emissivity + REAL(rk) :: ALBSAT(MSC,MBAND) !saturated soil albedos: 1=vis, 2=nir + REAL(rk) :: ALBDRY(MSC,MBAND) !dry soil albedos: 1=vis, 2=nir + REAL(rk) :: ALBICE(MBAND) !albedo land ice: 1=vis, 2=nir + REAL(rk) :: ALBLAK(MBAND) !albedo frozen lakes: 1=vis, 2=nir + REAL(rk) :: OMEGAS(MBAND) !two-stream parameter omega for snow + REAL(rk) :: BETADS !two-stream parameter betad for snow + REAL(rk) :: BETAIS !two-stream parameter betad for snow + REAL(rk) :: EG(2) !emissivity ! saturated soil albedos: 1=vis, 2=nir DATA(ALBSAT(I,1),I=1,8)/0.15,0.11,0.10,0.09,0.08,0.07,0.06,0.05/ @@ -518,33 +518,33 @@ SUBROUTINE PHENOLOGY (VEGTYP , ISURBAN, SNOWH , TV , LAT , YEARLEN , JULI ! inputs INTEGER , INTENT(IN ) :: VEGTYP !vegetation type INTEGER , INTENT(IN ) :: ISURBAN!urban category - REAL(SUMMA_PREC) , INTENT(IN ) :: SNOWH !snow height [m] - REAL(SUMMA_PREC) , INTENT(IN ) :: TV !vegetation temperature (k) - REAL(SUMMA_PREC) , INTENT(IN ) :: LAT !latitude (radians) + REAL(rk) , INTENT(IN ) :: SNOWH !snow height [m] + REAL(rk) , INTENT(IN ) :: TV !vegetation temperature (k) + REAL(rk) , INTENT(IN ) :: LAT !latitude (radians) INTEGER , INTENT(IN ) :: YEARLEN!Number of days in the particular year - REAL(SUMMA_PREC) , INTENT(IN ) :: JULIAN !Julian day of year (fractional) ( 0 <= JULIAN < YEARLEN ) - real(summa_prec) , INTENT(IN ) :: TROOT !root-zone averaged temperature (k) - REAL(SUMMA_PREC) , INTENT(INOUT) :: LAI !LAI, unadjusted for burying by snow - REAL(SUMMA_PREC) , INTENT(INOUT) :: SAI !SAI, unadjusted for burying by snow + REAL(rk) , INTENT(IN ) :: JULIAN !Julian day of year (fractional) ( 0 <= JULIAN < YEARLEN ) + real(rk) , INTENT(IN ) :: TROOT !root-zone averaged temperature (k) + REAL(rk) , INTENT(INOUT) :: LAI !LAI, unadjusted for burying by snow + REAL(rk) , INTENT(INOUT) :: SAI !SAI, unadjusted for burying by snow ! outputs - REAL(SUMMA_PREC) , INTENT(OUT ) :: HTOP !top of canopy layer (m) - REAL(SUMMA_PREC) , INTENT(OUT ) :: ELAI !leaf area index, after burying by snow - REAL(SUMMA_PREC) , INTENT(OUT ) :: ESAI !stem area index, after burying by snow - REAL(SUMMA_PREC) , INTENT(OUT ) :: IGS !growing season index (0=off, 1=on) + REAL(rk) , INTENT(OUT ) :: HTOP !top of canopy layer (m) + REAL(rk) , INTENT(OUT ) :: ELAI !leaf area index, after burying by snow + REAL(rk) , INTENT(OUT ) :: ESAI !stem area index, after burying by snow + REAL(rk) , INTENT(OUT ) :: IGS !growing season index (0=off, 1=on) ! locals - REAL(SUMMA_PREC) :: DB !thickness of canopy buried by snow (m) - REAL(SUMMA_PREC) :: FB !fraction of canopy buried by snow - REAL(SUMMA_PREC) :: SNOWHC !critical snow depth at which short vege + REAL(rk) :: DB !thickness of canopy buried by snow (m) + REAL(rk) :: FB !fraction of canopy buried by snow + REAL(rk) :: SNOWHC !critical snow depth at which short vege !is fully covered by snow INTEGER :: K !index INTEGER :: IT1,IT2 !interpolation months - REAL(SUMMA_PREC) :: DAY !current day of year ( 0 <= DAY < YEARLEN ) - REAL(SUMMA_PREC) :: WT1,WT2 !interpolation weights - REAL(SUMMA_PREC) :: T !current month (1.00, ..., 12.00) + REAL(rk) :: DAY !current day of year ( 0 <= DAY < YEARLEN ) + REAL(rk) :: WT1,WT2 !interpolation weights + REAL(rk) :: T !current month (1.00, ..., 12.00) ! -------------------------------------------------------------------------------------------------- IF ( DVEG == 1 .or. DVEG == 3 .or. DVEG == 4 ) THEN @@ -629,67 +629,67 @@ SUBROUTINE RADIATION (VEGTYP ,IST ,ISC ,ICE ,NSOIL , & !in INTEGER, INTENT(IN) :: ICE !ice (ice = 1) INTEGER, INTENT(IN) :: NSOIL !number of soil layers - REAL(SUMMA_PREC), INTENT(IN) :: DT !time step [s] - REAL(SUMMA_PREC), INTENT(IN) :: QSNOW !snowfall (mm/s) - REAL(SUMMA_PREC), INTENT(IN) :: SNEQVO !snow mass at last time step(mm) - REAL(SUMMA_PREC), INTENT(IN) :: SNEQV !snow mass (mm) - REAL(SUMMA_PREC), INTENT(IN) :: SNOWH !snow height (mm) - REAL(SUMMA_PREC), INTENT(IN) :: COSZ !cosine solar zenith angle (0-1) - REAL(SUMMA_PREC), INTENT(IN) :: TG !ground temperature (k) - REAL(SUMMA_PREC), INTENT(IN) :: TV !vegetation temperature (k) - REAL(SUMMA_PREC), INTENT(IN) :: ELAI !LAI, one-sided, adjusted for burying by snow - REAL(SUMMA_PREC), INTENT(IN) :: ESAI !SAI, one-sided, adjusted for burying by snow - REAL(SUMMA_PREC), INTENT(IN) :: FWET !fraction of canopy that is wet - REAL(SUMMA_PREC), DIMENSION(1:NSOIL), INTENT(IN) :: SMC !volumetric soil water [m3/m3] - REAL(SUMMA_PREC), DIMENSION(1:2) , INTENT(IN) :: SOLAD !incoming direct solar radiation (w/m2) - REAL(SUMMA_PREC), DIMENSION(1:2) , INTENT(IN) :: SOLAI !incoming diffuse solar radiation (w/m2) - REAL(SUMMA_PREC), INTENT(IN) :: FSNO !snow cover fraction (-) - REAL(SUMMA_PREC), INTENT(IN) :: FVEG !green vegetation fraction [0.0-1.0] + REAL(rk), INTENT(IN) :: DT !time step [s] + REAL(rk), INTENT(IN) :: QSNOW !snowfall (mm/s) + REAL(rk), INTENT(IN) :: SNEQVO !snow mass at last time step(mm) + REAL(rk), INTENT(IN) :: SNEQV !snow mass (mm) + REAL(rk), INTENT(IN) :: SNOWH !snow height (mm) + REAL(rk), INTENT(IN) :: COSZ !cosine solar zenith angle (0-1) + REAL(rk), INTENT(IN) :: TG !ground temperature (k) + REAL(rk), INTENT(IN) :: TV !vegetation temperature (k) + REAL(rk), INTENT(IN) :: ELAI !LAI, one-sided, adjusted for burying by snow + REAL(rk), INTENT(IN) :: ESAI !SAI, one-sided, adjusted for burying by snow + REAL(rk), INTENT(IN) :: FWET !fraction of canopy that is wet + REAL(rk), DIMENSION(1:NSOIL), INTENT(IN) :: SMC !volumetric soil water [m3/m3] + REAL(rk), DIMENSION(1:2) , INTENT(IN) :: SOLAD !incoming direct solar radiation (w/m2) + REAL(rk), DIMENSION(1:2) , INTENT(IN) :: SOLAI !incoming diffuse solar radiation (w/m2) + REAL(rk), INTENT(IN) :: FSNO !snow cover fraction (-) + REAL(rk), INTENT(IN) :: FVEG !green vegetation fraction [0.0-1.0] ! inout - REAL(SUMMA_PREC), INTENT(INOUT) :: ALBOLD !snow albedo at last time step (CLASS type) - REAL(SUMMA_PREC), INTENT(INOUT) :: TAUSS !non-dimensional snow age. + REAL(rk), INTENT(INOUT) :: ALBOLD !snow albedo at last time step (CLASS type) + REAL(rk), INTENT(INOUT) :: TAUSS !non-dimensional snow age. ! output - REAL(SUMMA_PREC), INTENT(OUT) :: FSUN !sunlit fraction of canopy (-) - REAL(SUMMA_PREC), INTENT(OUT) :: LAISUN !sunlit leaf area (-) - REAL(SUMMA_PREC), INTENT(OUT) :: LAISHA !shaded leaf area (-) - REAL(SUMMA_PREC), INTENT(OUT) :: PARSUN !average absorbed par for sunlit leaves (w/m2) - REAL(SUMMA_PREC), INTENT(OUT) :: PARSHA !average absorbed par for shaded leaves (w/m2) - REAL(SUMMA_PREC), INTENT(OUT) :: SAV !solar radiation absorbed by vegetation (w/m2) - REAL(SUMMA_PREC), INTENT(OUT) :: SAG !solar radiation absorbed by ground (w/m2) - REAL(SUMMA_PREC), INTENT(OUT) :: FSA !total absorbed solar radiation (w/m2) - REAL(SUMMA_PREC), INTENT(OUT) :: FSR !total reflected solar radiation (w/m2) + REAL(rk), INTENT(OUT) :: FSUN !sunlit fraction of canopy (-) + REAL(rk), INTENT(OUT) :: LAISUN !sunlit leaf area (-) + REAL(rk), INTENT(OUT) :: LAISHA !shaded leaf area (-) + REAL(rk), INTENT(OUT) :: PARSUN !average absorbed par for sunlit leaves (w/m2) + REAL(rk), INTENT(OUT) :: PARSHA !average absorbed par for shaded leaves (w/m2) + REAL(rk), INTENT(OUT) :: SAV !solar radiation absorbed by vegetation (w/m2) + REAL(rk), INTENT(OUT) :: SAG !solar radiation absorbed by ground (w/m2) + REAL(rk), INTENT(OUT) :: FSA !total absorbed solar radiation (w/m2) + REAL(rk), INTENT(OUT) :: FSR !total reflected solar radiation (w/m2) !jref:start - REAL(SUMMA_PREC), INTENT(OUT) :: FSRV !veg. reflected solar radiation (w/m2) - REAL(SUMMA_PREC), INTENT(OUT) :: FSRG !ground reflected solar radiation (w/m2) - REAL(SUMMA_PREC), INTENT(OUT) :: BGAP - REAL(SUMMA_PREC), INTENT(OUT) :: WGAP + REAL(rk), INTENT(OUT) :: FSRV !veg. reflected solar radiation (w/m2) + REAL(rk), INTENT(OUT) :: FSRG !ground reflected solar radiation (w/m2) + REAL(rk), INTENT(OUT) :: BGAP + REAL(rk), INTENT(OUT) :: WGAP !jref:end ! local - REAL(SUMMA_PREC) :: FAGE !snow age function (0 - new snow) - REAL(SUMMA_PREC), DIMENSION(1:2) :: ALBGRD !ground albedo (direct) - REAL(SUMMA_PREC), DIMENSION(1:2) :: ALBGRI !ground albedo (diffuse) - REAL(SUMMA_PREC), DIMENSION(1:2) :: ALBD !surface albedo (direct) - REAL(SUMMA_PREC), DIMENSION(1:2) :: ALBI !surface albedo (diffuse) - REAL(SUMMA_PREC), DIMENSION(1:2) :: FABD !flux abs by veg (per unit direct flux) - REAL(SUMMA_PREC), DIMENSION(1:2) :: FABI !flux abs by veg (per unit diffuse flux) - REAL(SUMMA_PREC), DIMENSION(1:2) :: FTDD !down direct flux below veg (per unit dir flux) - REAL(SUMMA_PREC), DIMENSION(1:2) :: FTID !down diffuse flux below veg (per unit dir flux) - REAL(SUMMA_PREC), DIMENSION(1:2) :: FTII !down diffuse flux below veg (per unit dif flux) + REAL(rk) :: FAGE !snow age function (0 - new snow) + REAL(rk), DIMENSION(1:2) :: ALBGRD !ground albedo (direct) + REAL(rk), DIMENSION(1:2) :: ALBGRI !ground albedo (diffuse) + REAL(rk), DIMENSION(1:2) :: ALBD !surface albedo (direct) + REAL(rk), DIMENSION(1:2) :: ALBI !surface albedo (diffuse) + REAL(rk), DIMENSION(1:2) :: FABD !flux abs by veg (per unit direct flux) + REAL(rk), DIMENSION(1:2) :: FABI !flux abs by veg (per unit diffuse flux) + REAL(rk), DIMENSION(1:2) :: FTDD !down direct flux below veg (per unit dir flux) + REAL(rk), DIMENSION(1:2) :: FTID !down diffuse flux below veg (per unit dir flux) + REAL(rk), DIMENSION(1:2) :: FTII !down diffuse flux below veg (per unit dif flux) !jref:start - REAL(SUMMA_PREC), DIMENSION(1:2) :: FREVI - REAL(SUMMA_PREC), DIMENSION(1:2) :: FREVD - REAL(SUMMA_PREC), DIMENSION(1:2) :: FREGI - REAL(SUMMA_PREC), DIMENSION(1:2) :: FREGD + REAL(rk), DIMENSION(1:2) :: FREVI + REAL(rk), DIMENSION(1:2) :: FREVD + REAL(rk), DIMENSION(1:2) :: FREGI + REAL(rk), DIMENSION(1:2) :: FREGD !jref:end - REAL(SUMMA_PREC) :: FSHA !shaded fraction of canopy - REAL(SUMMA_PREC) :: VAI !total LAI + stem area index, one sided + REAL(rk) :: FSHA !shaded fraction of canopy + REAL(rk) :: VAI !total LAI + stem area index, one sided - REAL(SUMMA_PREC),PARAMETER :: MPE = 1.E-6 + REAL(rk),PARAMETER :: MPE = 1.E-6 LOGICAL VEG !true: vegetated for surface temperature calculation ! -------------------------------------------------------------------------------------------------- @@ -760,67 +760,67 @@ SUBROUTINE ALBEDO (VEGTYP ,IST ,ISC ,ICE ,NSOIL , & !in INTEGER, INTENT(IN) :: ISC !soil color type (1-lighest; 8-darkest) INTEGER, INTENT(IN) :: ICE !ice (ice = 1) - REAL(SUMMA_PREC), INTENT(IN) :: DT !time step [sec] - REAL(SUMMA_PREC), INTENT(IN) :: QSNOW !snowfall - REAL(SUMMA_PREC), INTENT(IN) :: COSZ !cosine solar zenith angle for next time step - REAL(SUMMA_PREC), INTENT(IN) :: SNOWH !snow height (mm) - REAL(SUMMA_PREC), INTENT(IN) :: TG !ground temperature (k) - REAL(SUMMA_PREC), INTENT(IN) :: TV !vegetation temperature (k) - REAL(SUMMA_PREC), INTENT(IN) :: ELAI !LAI, one-sided, adjusted for burying by snow - REAL(SUMMA_PREC), INTENT(IN) :: ESAI !SAI, one-sided, adjusted for burying by snow - REAL(SUMMA_PREC), INTENT(IN) :: FSNO !fraction of grid covered by snow - REAL(SUMMA_PREC), INTENT(IN) :: FWET !fraction of canopy that is wet - REAL(SUMMA_PREC), INTENT(IN) :: SNEQVO !snow mass at last time step(mm) - REAL(SUMMA_PREC), INTENT(IN) :: SNEQV !snow mass (mm) - REAL(SUMMA_PREC), INTENT(IN) :: FVEG !green vegetation fraction [0.0-1.0] - REAL(SUMMA_PREC), DIMENSION(1:NSOIL), INTENT(IN) :: SMC !volumetric soil water (m3/m3) + REAL(rk), INTENT(IN) :: DT !time step [sec] + REAL(rk), INTENT(IN) :: QSNOW !snowfall + REAL(rk), INTENT(IN) :: COSZ !cosine solar zenith angle for next time step + REAL(rk), INTENT(IN) :: SNOWH !snow height (mm) + REAL(rk), INTENT(IN) :: TG !ground temperature (k) + REAL(rk), INTENT(IN) :: TV !vegetation temperature (k) + REAL(rk), INTENT(IN) :: ELAI !LAI, one-sided, adjusted for burying by snow + REAL(rk), INTENT(IN) :: ESAI !SAI, one-sided, adjusted for burying by snow + REAL(rk), INTENT(IN) :: FSNO !fraction of grid covered by snow + REAL(rk), INTENT(IN) :: FWET !fraction of canopy that is wet + REAL(rk), INTENT(IN) :: SNEQVO !snow mass at last time step(mm) + REAL(rk), INTENT(IN) :: SNEQV !snow mass (mm) + REAL(rk), INTENT(IN) :: FVEG !green vegetation fraction [0.0-1.0] + REAL(rk), DIMENSION(1:NSOIL), INTENT(IN) :: SMC !volumetric soil water (m3/m3) ! inout - REAL(SUMMA_PREC), INTENT(INOUT) :: ALBOLD !snow albedo at last time step (CLASS type) - REAL(SUMMA_PREC), INTENT(INOUT) :: TAUSS !non-dimensional snow age + REAL(rk), INTENT(INOUT) :: ALBOLD !snow albedo at last time step (CLASS type) + REAL(rk), INTENT(INOUT) :: TAUSS !non-dimensional snow age ! output - REAL(SUMMA_PREC), DIMENSION(1: 2), INTENT(OUT) :: ALBGRD !ground albedo (direct) - REAL(SUMMA_PREC), DIMENSION(1: 2), INTENT(OUT) :: ALBGRI !ground albedo (diffuse) - REAL(SUMMA_PREC), DIMENSION(1: 2), INTENT(OUT) :: ALBD !surface albedo (direct) - REAL(SUMMA_PREC), DIMENSION(1: 2), INTENT(OUT) :: ALBI !surface albedo (diffuse) - REAL(SUMMA_PREC), DIMENSION(1: 2), INTENT(OUT) :: FABD !flux abs by veg (per unit direct flux) - REAL(SUMMA_PREC), DIMENSION(1: 2), INTENT(OUT) :: FABI !flux abs by veg (per unit diffuse flux) - REAL(SUMMA_PREC), DIMENSION(1: 2), INTENT(OUT) :: FTDD !down direct flux below veg (per unit dir flux) - REAL(SUMMA_PREC), DIMENSION(1: 2), INTENT(OUT) :: FTID !down diffuse flux below veg (per unit dir flux) - REAL(SUMMA_PREC), DIMENSION(1: 2), INTENT(OUT) :: FTII !down diffuse flux below veg (per unit dif flux) - REAL(SUMMA_PREC), INTENT(OUT) :: FSUN !sunlit fraction of canopy (-) + REAL(rk), DIMENSION(1: 2), INTENT(OUT) :: ALBGRD !ground albedo (direct) + REAL(rk), DIMENSION(1: 2), INTENT(OUT) :: ALBGRI !ground albedo (diffuse) + REAL(rk), DIMENSION(1: 2), INTENT(OUT) :: ALBD !surface albedo (direct) + REAL(rk), DIMENSION(1: 2), INTENT(OUT) :: ALBI !surface albedo (diffuse) + REAL(rk), DIMENSION(1: 2), INTENT(OUT) :: FABD !flux abs by veg (per unit direct flux) + REAL(rk), DIMENSION(1: 2), INTENT(OUT) :: FABI !flux abs by veg (per unit diffuse flux) + REAL(rk), DIMENSION(1: 2), INTENT(OUT) :: FTDD !down direct flux below veg (per unit dir flux) + REAL(rk), DIMENSION(1: 2), INTENT(OUT) :: FTID !down diffuse flux below veg (per unit dir flux) + REAL(rk), DIMENSION(1: 2), INTENT(OUT) :: FTII !down diffuse flux below veg (per unit dif flux) + REAL(rk), INTENT(OUT) :: FSUN !sunlit fraction of canopy (-) !jref:start - REAL(SUMMA_PREC), DIMENSION(1: 2), INTENT(OUT) :: FREVD - REAL(SUMMA_PREC), DIMENSION(1: 2), INTENT(OUT) :: FREVI - REAL(SUMMA_PREC), DIMENSION(1: 2), INTENT(OUT) :: FREGD - REAL(SUMMA_PREC), DIMENSION(1: 2), INTENT(OUT) :: FREGI - REAL(SUMMA_PREC), INTENT(OUT) :: BGAP - REAL(SUMMA_PREC), INTENT(OUT) :: WGAP + REAL(rk), DIMENSION(1: 2), INTENT(OUT) :: FREVD + REAL(rk), DIMENSION(1: 2), INTENT(OUT) :: FREVI + REAL(rk), DIMENSION(1: 2), INTENT(OUT) :: FREGD + REAL(rk), DIMENSION(1: 2), INTENT(OUT) :: FREGI + REAL(rk), INTENT(OUT) :: BGAP + REAL(rk), INTENT(OUT) :: WGAP !jref:end ! ------------------------------------------------------------------------ ! ------------------------ local variables ------------------------------- ! local - REAL(SUMMA_PREC) :: FAGE !snow age function - REAL(SUMMA_PREC) :: ALB + REAL(rk) :: FAGE !snow age function + REAL(rk) :: ALB INTEGER :: IB !indices INTEGER :: NBAND !number of solar radiation wave bands INTEGER :: IC !direct beam: ic=0; diffuse: ic=1 - REAL(SUMMA_PREC) :: WL !fraction of LAI+SAI that is LAI - REAL(SUMMA_PREC) :: WS !fraction of LAI+SAI that is SAI - REAL(SUMMA_PREC) :: MPE !prevents overflow for division by zero + REAL(rk) :: WL !fraction of LAI+SAI that is LAI + REAL(rk) :: WS !fraction of LAI+SAI that is SAI + REAL(rk) :: MPE !prevents overflow for division by zero - REAL(SUMMA_PREC), DIMENSION(1:2) :: RHO !leaf/stem reflectance weighted by fraction LAI and SAI - REAL(SUMMA_PREC), DIMENSION(1:2) :: TAU !leaf/stem transmittance weighted by fraction LAI and SAI - REAL(SUMMA_PREC), DIMENSION(1:2) :: FTDI !down direct flux below veg per unit dif flux = 0 - REAL(SUMMA_PREC), DIMENSION(1:2) :: ALBSND !snow albedo (direct) - REAL(SUMMA_PREC), DIMENSION(1:2) :: ALBSNI !snow albedo (diffuse) + REAL(rk), DIMENSION(1:2) :: RHO !leaf/stem reflectance weighted by fraction LAI and SAI + REAL(rk), DIMENSION(1:2) :: TAU !leaf/stem transmittance weighted by fraction LAI and SAI + REAL(rk), DIMENSION(1:2) :: FTDI !down direct flux below veg per unit dif flux = 0 + REAL(rk), DIMENSION(1:2) :: ALBSND !snow albedo (direct) + REAL(rk), DIMENSION(1:2) :: ALBSNI !snow albedo (diffuse) - REAL(SUMMA_PREC) :: VAI !ELAI+ESAI - REAL(SUMMA_PREC) :: GDIR !average projected leaf/stem area in solar direction - REAL(SUMMA_PREC) :: EXT !optical depth direct beam per unit leaf + stem area + REAL(rk) :: VAI !ELAI+ESAI + REAL(rk) :: GDIR !average projected leaf/stem area in solar direction + REAL(rk) :: EXT !optical depth direct beam per unit leaf + stem area ! -------------------------------------------------------------------------------------------------- @@ -931,55 +931,55 @@ SUBROUTINE SURRAD (MPE ,FSUN ,FSHA ,ELAI ,VAI , & !in INTEGER, INTENT(IN) :: ILOC INTEGER, INTENT(IN) :: JLOC - REAL(SUMMA_PREC), INTENT(IN) :: MPE !prevents underflow errors if division by zero - - REAL(SUMMA_PREC), INTENT(IN) :: FSUN !sunlit fraction of canopy - REAL(SUMMA_PREC), INTENT(IN) :: FSHA !shaded fraction of canopy - REAL(SUMMA_PREC), INTENT(IN) :: ELAI !leaf area, one-sided - REAL(SUMMA_PREC), INTENT(IN) :: VAI !leaf + stem area, one-sided - REAL(SUMMA_PREC), INTENT(IN) :: LAISUN !sunlit leaf area index, one-sided - REAL(SUMMA_PREC), INTENT(IN) :: LAISHA !shaded leaf area index, one-sided - - REAL(SUMMA_PREC), DIMENSION(1:2), INTENT(IN) :: SOLAD !incoming direct solar radiation (w/m2) - REAL(SUMMA_PREC), DIMENSION(1:2), INTENT(IN) :: SOLAI !incoming diffuse solar radiation (w/m2) - REAL(SUMMA_PREC), DIMENSION(1:2), INTENT(IN) :: FABD !flux abs by veg (per unit incoming direct flux) - REAL(SUMMA_PREC), DIMENSION(1:2), INTENT(IN) :: FABI !flux abs by veg (per unit incoming diffuse flux) - REAL(SUMMA_PREC), DIMENSION(1:2), INTENT(IN) :: FTDD !down dir flux below veg (per incoming dir flux) - REAL(SUMMA_PREC), DIMENSION(1:2), INTENT(IN) :: FTID !down dif flux below veg (per incoming dir flux) - REAL(SUMMA_PREC), DIMENSION(1:2), INTENT(IN) :: FTII !down dif flux below veg (per incoming dif flux) - REAL(SUMMA_PREC), DIMENSION(1:2), INTENT(IN) :: ALBGRD !ground albedo (direct) - REAL(SUMMA_PREC), DIMENSION(1:2), INTENT(IN) :: ALBGRI !ground albedo (diffuse) - REAL(SUMMA_PREC), DIMENSION(1:2), INTENT(IN) :: ALBD !overall surface albedo (direct) - REAL(SUMMA_PREC), DIMENSION(1:2), INTENT(IN) :: ALBI !overall surface albedo (diffuse) - - REAL(SUMMA_PREC), DIMENSION(1:2), INTENT(IN) :: FREVD !overall surface albedo veg (direct) - REAL(SUMMA_PREC), DIMENSION(1:2), INTENT(IN) :: FREVI !overall surface albedo veg (diffuse) - REAL(SUMMA_PREC), DIMENSION(1:2), INTENT(IN) :: FREGD !overall surface albedo grd (direct) - REAL(SUMMA_PREC), DIMENSION(1:2), INTENT(IN) :: FREGI !overall surface albedo grd (diffuse) + REAL(rk), INTENT(IN) :: MPE !prevents underflow errors if division by zero + + REAL(rk), INTENT(IN) :: FSUN !sunlit fraction of canopy + REAL(rk), INTENT(IN) :: FSHA !shaded fraction of canopy + REAL(rk), INTENT(IN) :: ELAI !leaf area, one-sided + REAL(rk), INTENT(IN) :: VAI !leaf + stem area, one-sided + REAL(rk), INTENT(IN) :: LAISUN !sunlit leaf area index, one-sided + REAL(rk), INTENT(IN) :: LAISHA !shaded leaf area index, one-sided + + REAL(rk), DIMENSION(1:2), INTENT(IN) :: SOLAD !incoming direct solar radiation (w/m2) + REAL(rk), DIMENSION(1:2), INTENT(IN) :: SOLAI !incoming diffuse solar radiation (w/m2) + REAL(rk), DIMENSION(1:2), INTENT(IN) :: FABD !flux abs by veg (per unit incoming direct flux) + REAL(rk), DIMENSION(1:2), INTENT(IN) :: FABI !flux abs by veg (per unit incoming diffuse flux) + REAL(rk), DIMENSION(1:2), INTENT(IN) :: FTDD !down dir flux below veg (per incoming dir flux) + REAL(rk), DIMENSION(1:2), INTENT(IN) :: FTID !down dif flux below veg (per incoming dir flux) + REAL(rk), DIMENSION(1:2), INTENT(IN) :: FTII !down dif flux below veg (per incoming dif flux) + REAL(rk), DIMENSION(1:2), INTENT(IN) :: ALBGRD !ground albedo (direct) + REAL(rk), DIMENSION(1:2), INTENT(IN) :: ALBGRI !ground albedo (diffuse) + REAL(rk), DIMENSION(1:2), INTENT(IN) :: ALBD !overall surface albedo (direct) + REAL(rk), DIMENSION(1:2), INTENT(IN) :: ALBI !overall surface albedo (diffuse) + + REAL(rk), DIMENSION(1:2), INTENT(IN) :: FREVD !overall surface albedo veg (direct) + REAL(rk), DIMENSION(1:2), INTENT(IN) :: FREVI !overall surface albedo veg (diffuse) + REAL(rk), DIMENSION(1:2), INTENT(IN) :: FREGD !overall surface albedo grd (direct) + REAL(rk), DIMENSION(1:2), INTENT(IN) :: FREGI !overall surface albedo grd (diffuse) ! output - REAL(SUMMA_PREC), INTENT(OUT) :: PARSUN !average absorbed par for sunlit leaves (w/m2) - REAL(SUMMA_PREC), INTENT(OUT) :: PARSHA !average absorbed par for shaded leaves (w/m2) - REAL(SUMMA_PREC), INTENT(OUT) :: SAV !solar radiation absorbed by vegetation (w/m2) - REAL(SUMMA_PREC), INTENT(OUT) :: SAG !solar radiation absorbed by ground (w/m2) - REAL(SUMMA_PREC), INTENT(OUT) :: FSA !total absorbed solar radiation (w/m2) - REAL(SUMMA_PREC), INTENT(OUT) :: FSR !total reflected solar radiation (w/m2) - REAL(SUMMA_PREC), INTENT(OUT) :: FSRV !reflected solar radiation by vegetation - REAL(SUMMA_PREC), INTENT(OUT) :: FSRG !reflected solar radiation by ground + REAL(rk), INTENT(OUT) :: PARSUN !average absorbed par for sunlit leaves (w/m2) + REAL(rk), INTENT(OUT) :: PARSHA !average absorbed par for shaded leaves (w/m2) + REAL(rk), INTENT(OUT) :: SAV !solar radiation absorbed by vegetation (w/m2) + REAL(rk), INTENT(OUT) :: SAG !solar radiation absorbed by ground (w/m2) + REAL(rk), INTENT(OUT) :: FSA !total absorbed solar radiation (w/m2) + REAL(rk), INTENT(OUT) :: FSR !total reflected solar radiation (w/m2) + REAL(rk), INTENT(OUT) :: FSRV !reflected solar radiation by vegetation + REAL(rk), INTENT(OUT) :: FSRG !reflected solar radiation by ground ! ------------------------ local variables ---------------------------------------------------- INTEGER :: IB !waveband number (1=vis, 2=nir) INTEGER :: NBAND !number of solar radiation waveband classes - REAL(SUMMA_PREC) :: ABS !absorbed solar radiation (w/m2) - REAL(SUMMA_PREC) :: RNIR !reflected solar radiation [nir] (w/m2) - REAL(SUMMA_PREC) :: RVIS !reflected solar radiation [vis] (w/m2) - REAL(SUMMA_PREC) :: LAIFRA !leaf area fraction of canopy - REAL(SUMMA_PREC) :: TRD !transmitted solar radiation: direct (w/m2) - REAL(SUMMA_PREC) :: TRI !transmitted solar radiation: diffuse (w/m2) - REAL(SUMMA_PREC), DIMENSION(1:2) :: CAD !direct beam absorbed by canopy (w/m2) - REAL(SUMMA_PREC), DIMENSION(1:2) :: CAI !diffuse radiation absorbed by canopy (w/m2) + REAL(rk) :: ABS !absorbed solar radiation (w/m2) + REAL(rk) :: RNIR !reflected solar radiation [nir] (w/m2) + REAL(rk) :: RVIS !reflected solar radiation [vis] (w/m2) + REAL(rk) :: LAIFRA !leaf area fraction of canopy + REAL(rk) :: TRD !transmitted solar radiation: direct (w/m2) + REAL(rk) :: TRI !transmitted solar radiation: diffuse (w/m2) + REAL(rk), DIMENSION(1:2) :: CAD !direct beam absorbed by canopy (w/m2) + REAL(rk), DIMENSION(1:2) :: CAI !diffuse radiation absorbed by canopy (w/m2) ! --------------------------------------------------------------------------------------------- NBAND = 2 @@ -1044,26 +1044,26 @@ SUBROUTINE SNOW_AGE (DT,TG,SNEQVO,SNEQV,TAUSS,FAGE) ! from BATS ! ------------------------ input/output variables -------------------------------------------------- !input - REAL(SUMMA_PREC), INTENT(IN) :: DT !main time step (s) - REAL(SUMMA_PREC), INTENT(IN) :: TG !ground temperature (k) - REAL(SUMMA_PREC), INTENT(IN) :: SNEQVO !snow mass at last time step(mm) - REAL(SUMMA_PREC), INTENT(IN) :: SNEQV !snow water per unit ground area (mm) + REAL(rk), INTENT(IN) :: DT !main time step (s) + REAL(rk), INTENT(IN) :: TG !ground temperature (k) + REAL(rk), INTENT(IN) :: SNEQVO !snow mass at last time step(mm) + REAL(rk), INTENT(IN) :: SNEQV !snow water per unit ground area (mm) !output - REAL(SUMMA_PREC), INTENT(OUT) :: FAGE !snow age + REAL(rk), INTENT(OUT) :: FAGE !snow age !input/output - REAL(SUMMA_PREC), INTENT(INOUT) :: TAUSS !non-dimensional snow age + REAL(rk), INTENT(INOUT) :: TAUSS !non-dimensional snow age !local - REAL(SUMMA_PREC) :: TAGE !total aging effects - REAL(SUMMA_PREC) :: AGE1 !effects of grain growth due to vapor diffusion - REAL(SUMMA_PREC) :: AGE2 !effects of grain growth at freezing of melt water - REAL(SUMMA_PREC) :: AGE3 !effects of soot - REAL(SUMMA_PREC) :: DELA !temporary variable - REAL(SUMMA_PREC) :: SGE !temporary variable - REAL(SUMMA_PREC) :: DELS !temporary variable - REAL(SUMMA_PREC) :: DELA0 !temporary variable - REAL(SUMMA_PREC) :: ARG !temporary variable + REAL(rk) :: TAGE !total aging effects + REAL(rk) :: AGE1 !effects of grain growth due to vapor diffusion + REAL(rk) :: AGE2 !effects of grain growth at freezing of melt water + REAL(rk) :: AGE3 !effects of soot + REAL(rk) :: DELA !temporary variable + REAL(rk) :: SGE !temporary variable + REAL(rk) :: DELS !temporary variable + REAL(rk) :: DELA0 !temporary variable + REAL(rk) :: ARG !temporary variable ! See Yang et al. (1997) J.of Climate for detail. !--------------------------------------------------------------------------------------------------- @@ -1098,28 +1098,28 @@ SUBROUTINE SNOWALB_BATS (NBAND,FSNO,COSZ,FAGE,ALBSND,ALBSNI) INTEGER,INTENT(IN) :: NBAND !number of waveband classes - REAL(SUMMA_PREC),INTENT(IN) :: COSZ !cosine solar zenith angle - REAL(SUMMA_PREC),INTENT(IN) :: FSNO !snow cover fraction (-) - REAL(SUMMA_PREC),INTENT(IN) :: FAGE !snow age correction + REAL(rk),INTENT(IN) :: COSZ !cosine solar zenith angle + REAL(rk),INTENT(IN) :: FSNO !snow cover fraction (-) + REAL(rk),INTENT(IN) :: FAGE !snow age correction ! output - REAL(SUMMA_PREC), DIMENSION(1:2),INTENT(OUT) :: ALBSND !snow albedo for direct(1=vis, 2=nir) - REAL(SUMMA_PREC), DIMENSION(1:2),INTENT(OUT) :: ALBSNI !snow albedo for diffuse + REAL(rk), DIMENSION(1:2),INTENT(OUT) :: ALBSND !snow albedo for direct(1=vis, 2=nir) + REAL(rk), DIMENSION(1:2),INTENT(OUT) :: ALBSNI !snow albedo for diffuse ! --------------------------------------------------------------------------------------------- ! ------------------------ local variables ---------------------------------------------------- INTEGER :: IB !waveband class - REAL(SUMMA_PREC) :: FZEN !zenith angle correction - REAL(SUMMA_PREC) :: CF1 !temperary variable - REAL(SUMMA_PREC) :: SL2 !2.*SL - REAL(SUMMA_PREC) :: SL1 !1/SL - REAL(SUMMA_PREC) :: SL !adjustable parameter - REAL(SUMMA_PREC), PARAMETER :: C1 = 0.2 !default in BATS - REAL(SUMMA_PREC), PARAMETER :: C2 = 0.5 !default in BATS -! REAL(SUMMA_PREC), PARAMETER :: C1 = 0.2 * 2. ! double the default to match Sleepers River's -! REAL(SUMMA_PREC), PARAMETER :: C2 = 0.5 * 2. ! snow surface albedo (double aging effects) + REAL(rk) :: FZEN !zenith angle correction + REAL(rk) :: CF1 !temperary variable + REAL(rk) :: SL2 !2.*SL + REAL(rk) :: SL1 !1/SL + REAL(rk) :: SL !adjustable parameter + REAL(rk), PARAMETER :: C1 = 0.2 !default in BATS + REAL(rk), PARAMETER :: C2 = 0.5 !default in BATS +! REAL(rk), PARAMETER :: C1 = 0.2 * 2. ! double the default to match Sleepers River's +! REAL(rk), PARAMETER :: C2 = 0.5 * 2. ! snow surface albedo (double aging effects) ! --------------------------------------------------------------------------------------------- ! zero albedos for all points @@ -1153,17 +1153,17 @@ SUBROUTINE SNOWALB_CLASS (NBAND,QSNOW,DT,ALB,ALBOLD,ALBSND,ALBSNI,ILOC,JLOC) INTEGER,INTENT(IN) :: JLOC !grid index INTEGER,INTENT(IN) :: NBAND !number of waveband classes - REAL(SUMMA_PREC),INTENT(IN) :: QSNOW !snowfall (mm/s) - REAL(SUMMA_PREC),INTENT(IN) :: DT !time step (sec) - REAL(SUMMA_PREC),INTENT(IN) :: ALBOLD !snow albedo at last time step + REAL(rk),INTENT(IN) :: QSNOW !snowfall (mm/s) + REAL(rk),INTENT(IN) :: DT !time step (sec) + REAL(rk),INTENT(IN) :: ALBOLD !snow albedo at last time step ! in & out - REAL(SUMMA_PREC), INTENT(INOUT) :: ALB ! + REAL(rk), INTENT(INOUT) :: ALB ! ! output - REAL(SUMMA_PREC), DIMENSION(1:2),INTENT(OUT) :: ALBSND !snow albedo for direct(1=vis, 2=nir) - REAL(SUMMA_PREC), DIMENSION(1:2),INTENT(OUT) :: ALBSNI !snow albedo for diffuse + REAL(rk), DIMENSION(1:2),INTENT(OUT) :: ALBSND !snow albedo for direct(1=vis, 2=nir) + REAL(rk), DIMENSION(1:2),INTENT(OUT) :: ALBSNI !snow albedo for diffuse ! --------------------------------------------------------------------------------------------- ! ------------------------ local variables ---------------------------------------------------- @@ -1213,24 +1213,24 @@ SUBROUTINE GROUNDALB (NSOIL ,NBAND ,ICE ,IST ,ISC , & !in INTEGER, INTENT(IN) :: ICE !value of ist for land ice INTEGER, INTENT(IN) :: IST !surface type INTEGER, INTENT(IN) :: ISC !soil color class (1-lighest; 8-darkest) - REAL(SUMMA_PREC), INTENT(IN) :: FSNO !fraction of surface covered with snow (-) - REAL(SUMMA_PREC), INTENT(IN) :: TG !ground temperature (k) - REAL(SUMMA_PREC), INTENT(IN) :: COSZ !cosine solar zenith angle (0-1) - REAL(SUMMA_PREC), DIMENSION(1:NSOIL), INTENT(IN) :: SMC !volumetric soil water content (m3/m3) - REAL(SUMMA_PREC), DIMENSION(1: 2), INTENT(IN) :: ALBSND !direct beam snow albedo (vis, nir) - REAL(SUMMA_PREC), DIMENSION(1: 2), INTENT(IN) :: ALBSNI !diffuse snow albedo (vis, nir) + REAL(rk), INTENT(IN) :: FSNO !fraction of surface covered with snow (-) + REAL(rk), INTENT(IN) :: TG !ground temperature (k) + REAL(rk), INTENT(IN) :: COSZ !cosine solar zenith angle (0-1) + REAL(rk), DIMENSION(1:NSOIL), INTENT(IN) :: SMC !volumetric soil water content (m3/m3) + REAL(rk), DIMENSION(1: 2), INTENT(IN) :: ALBSND !direct beam snow albedo (vis, nir) + REAL(rk), DIMENSION(1: 2), INTENT(IN) :: ALBSNI !diffuse snow albedo (vis, nir) !output - REAL(SUMMA_PREC), DIMENSION(1: 2), INTENT(OUT) :: ALBGRD !ground albedo (direct beam: vis, nir) - REAL(SUMMA_PREC), DIMENSION(1: 2), INTENT(OUT) :: ALBGRI !ground albedo (diffuse: vis, nir) + REAL(rk), DIMENSION(1: 2), INTENT(OUT) :: ALBGRD !ground albedo (direct beam: vis, nir) + REAL(rk), DIMENSION(1: 2), INTENT(OUT) :: ALBGRI !ground albedo (diffuse: vis, nir) !local INTEGER :: IB !waveband number (1=vis, 2=nir) - REAL(SUMMA_PREC) :: INC !soil water correction factor for soil albedo - REAL(SUMMA_PREC) :: ALBSOD !soil albedo (direct) - REAL(SUMMA_PREC) :: ALBSOI !soil albedo (diffuse) + REAL(rk) :: INC !soil water correction factor for soil albedo + REAL(rk) :: ALBSOD !soil albedo (direct) + REAL(rk) :: ALBSOI !soil albedo (diffuse) ! -------------------------------------------------------------------------------------------------- DO IB = 1, NBAND @@ -1287,68 +1287,68 @@ SUBROUTINE TWOSTREAM (IB ,IC ,VEGTYP ,COSZ ,VAI , & !in INTEGER, INTENT(IN) :: IC !0=unit incoming direct; 1=unit incoming diffuse INTEGER, INTENT(IN) :: VEGTYP !vegetation type - REAL(SUMMA_PREC), INTENT(IN) :: COSZ !cosine of direct zenith angle (0-1) - REAL(SUMMA_PREC), INTENT(IN) :: VAI !one-sided leaf+stem area index (m2/m2) - REAL(SUMMA_PREC), INTENT(IN) :: FWET !fraction of lai, sai that is wetted (-) - REAL(SUMMA_PREC), INTENT(IN) :: T !surface temperature (k) + REAL(rk), INTENT(IN) :: COSZ !cosine of direct zenith angle (0-1) + REAL(rk), INTENT(IN) :: VAI !one-sided leaf+stem area index (m2/m2) + REAL(rk), INTENT(IN) :: FWET !fraction of lai, sai that is wetted (-) + REAL(rk), INTENT(IN) :: T !surface temperature (k) - REAL(SUMMA_PREC), DIMENSION(1:2), INTENT(IN) :: ALBGRD !direct albedo of underlying surface (-) - REAL(SUMMA_PREC), DIMENSION(1:2), INTENT(IN) :: ALBGRI !diffuse albedo of underlying surface (-) - REAL(SUMMA_PREC), DIMENSION(1:2), INTENT(IN) :: RHO !leaf+stem reflectance - REAL(SUMMA_PREC), DIMENSION(1:2), INTENT(IN) :: TAU !leaf+stem transmittance - REAL(SUMMA_PREC), INTENT(IN) :: FVEG !green vegetation fraction [0.0-1.0] + REAL(rk), DIMENSION(1:2), INTENT(IN) :: ALBGRD !direct albedo of underlying surface (-) + REAL(rk), DIMENSION(1:2), INTENT(IN) :: ALBGRI !diffuse albedo of underlying surface (-) + REAL(rk), DIMENSION(1:2), INTENT(IN) :: RHO !leaf+stem reflectance + REAL(rk), DIMENSION(1:2), INTENT(IN) :: TAU !leaf+stem transmittance + REAL(rk), INTENT(IN) :: FVEG !green vegetation fraction [0.0-1.0] ! output - REAL(SUMMA_PREC), DIMENSION(1:2), INTENT(OUT) :: FAB !flux abs by veg layer (per unit incoming flux) - REAL(SUMMA_PREC), DIMENSION(1:2), INTENT(OUT) :: FRE !flux refl above veg layer (per unit incoming flux) - REAL(SUMMA_PREC), DIMENSION(1:2), INTENT(OUT) :: FTD !down dir flux below veg layer (per unit in flux) - REAL(SUMMA_PREC), DIMENSION(1:2), INTENT(OUT) :: FTI !down dif flux below veg layer (per unit in flux) - REAL(SUMMA_PREC), INTENT(OUT) :: GDIR !projected leaf+stem area in solar direction - REAL(SUMMA_PREC), DIMENSION(1:2), INTENT(OUT) :: FREV !flux reflected by veg layer (per unit incoming flux) - REAL(SUMMA_PREC), DIMENSION(1:2), INTENT(OUT) :: FREG !flux reflected by ground (per unit incoming flux) + REAL(rk), DIMENSION(1:2), INTENT(OUT) :: FAB !flux abs by veg layer (per unit incoming flux) + REAL(rk), DIMENSION(1:2), INTENT(OUT) :: FRE !flux refl above veg layer (per unit incoming flux) + REAL(rk), DIMENSION(1:2), INTENT(OUT) :: FTD !down dir flux below veg layer (per unit in flux) + REAL(rk), DIMENSION(1:2), INTENT(OUT) :: FTI !down dif flux below veg layer (per unit in flux) + REAL(rk), INTENT(OUT) :: GDIR !projected leaf+stem area in solar direction + REAL(rk), DIMENSION(1:2), INTENT(OUT) :: FREV !flux reflected by veg layer (per unit incoming flux) + REAL(rk), DIMENSION(1:2), INTENT(OUT) :: FREG !flux reflected by ground (per unit incoming flux) ! local - REAL(SUMMA_PREC) :: OMEGA !fraction of intercepted radiation that is scattered - REAL(SUMMA_PREC) :: OMEGAL !omega for leaves - REAL(SUMMA_PREC) :: BETAI !upscatter parameter for diffuse radiation - REAL(SUMMA_PREC) :: BETAIL !betai for leaves - REAL(SUMMA_PREC) :: BETAD !upscatter parameter for direct beam radiation - REAL(SUMMA_PREC) :: BETADL !betad for leaves - REAL(SUMMA_PREC) :: EXT !optical depth of direct beam per unit leaf area - REAL(SUMMA_PREC) :: AVMU !average diffuse optical depth - - REAL(SUMMA_PREC) :: COSZI !0.001 <= cosz <= 1.000 - REAL(SUMMA_PREC) :: ASU !single scattering albedo - REAL(SUMMA_PREC) :: CHIL ! -0.4 <= xl <= 0.6 - - REAL(SUMMA_PREC) :: TMP0,TMP1,TMP2,TMP3,TMP4,TMP5,TMP6,TMP7,TMP8,TMP9 - REAL(SUMMA_PREC) :: P1,P2,P3,P4,S1,S2,U1,U2,U3 - REAL(SUMMA_PREC) :: B,C,D,D1,D2,F,H,H1,H2,H3,H4,H5,H6,H7,H8,H9,H10 - REAL(SUMMA_PREC) :: PHI1,PHI2,SIGMA - REAL(SUMMA_PREC) :: FTDS,FTIS,FRES - REAL(SUMMA_PREC) :: DENFVEG - REAL(SUMMA_PREC) :: VAI_SPREAD + REAL(rk) :: OMEGA !fraction of intercepted radiation that is scattered + REAL(rk) :: OMEGAL !omega for leaves + REAL(rk) :: BETAI !upscatter parameter for diffuse radiation + REAL(rk) :: BETAIL !betai for leaves + REAL(rk) :: BETAD !upscatter parameter for direct beam radiation + REAL(rk) :: BETADL !betad for leaves + REAL(rk) :: EXT !optical depth of direct beam per unit leaf area + REAL(rk) :: AVMU !average diffuse optical depth + + REAL(rk) :: COSZI !0.001 <= cosz <= 1.000 + REAL(rk) :: ASU !single scattering albedo + REAL(rk) :: CHIL ! -0.4 <= xl <= 0.6 + + REAL(rk) :: TMP0,TMP1,TMP2,TMP3,TMP4,TMP5,TMP6,TMP7,TMP8,TMP9 + REAL(rk) :: P1,P2,P3,P4,S1,S2,U1,U2,U3 + REAL(rk) :: B,C,D,D1,D2,F,H,H1,H2,H3,H4,H5,H6,H7,H8,H9,H10 + REAL(rk) :: PHI1,PHI2,SIGMA + REAL(rk) :: FTDS,FTIS,FRES + REAL(rk) :: DENFVEG + REAL(rk) :: VAI_SPREAD !jref:start - REAL(SUMMA_PREC) :: FREVEG,FREBAR,FTDVEG,FTIVEG,FTDBAR,FTIBAR - REAL(SUMMA_PREC) :: THETAZ + REAL(rk) :: FREVEG,FREBAR,FTDVEG,FTIVEG,FTDBAR,FTIBAR + REAL(rk) :: THETAZ !jref:end ! variables for the modified two-stream scheme ! Niu and Yang (2004), JGR - REAL(SUMMA_PREC), PARAMETER :: PAI = 3.14159265 - REAL(SUMMA_PREC) :: HD !crown depth (m) - REAL(SUMMA_PREC) :: BB !vertical crown radius (m) - REAL(SUMMA_PREC) :: THETAP !angle conversion from SZA - REAL(SUMMA_PREC) :: FA !foliage volume density (m-1) - REAL(SUMMA_PREC) :: NEWVAI !effective LSAI (-) + REAL(rk), PARAMETER :: PAI = 3.14159265 + REAL(rk) :: HD !crown depth (m) + REAL(rk) :: BB !vertical crown radius (m) + REAL(rk) :: THETAP !angle conversion from SZA + REAL(rk) :: FA !foliage volume density (m-1) + REAL(rk) :: NEWVAI !effective LSAI (-) - REAL(SUMMA_PREC),INTENT(INOUT) :: BGAP !between canopy gap fraction for beam (-) - REAL(SUMMA_PREC),INTENT(INOUT) :: WGAP !within canopy gap fraction for beam (-) + REAL(rk),INTENT(INOUT) :: BGAP !between canopy gap fraction for beam (-) + REAL(rk),INTENT(INOUT) :: WGAP !within canopy gap fraction for beam (-) - REAL(SUMMA_PREC) :: KOPEN !gap fraction for diffue light (-) - REAL(SUMMA_PREC) :: GAP !total gap fraction for beam ( <=1-shafac ) + REAL(rk) :: KOPEN !gap fraction for diffue light (-) + REAL(rk) :: GAP !total gap fraction for beam ( <=1-shafac ) ! ----------------------------------------------------------------- ! compute within and between gaps @@ -1527,27 +1527,27 @@ SUBROUTINE STOMATA (VEGTYP ,MPE ,APAR ,FOLN ,ILOC , JLOC, & !in INTEGER,INTENT(IN) :: JLOC !grid index INTEGER,INTENT(IN) :: VEGTYP !vegetation physiology type - REAL(SUMMA_PREC), INTENT(IN) :: IGS !growing season index (0=off, 1=on) - REAL(SUMMA_PREC), INTENT(IN) :: MPE !prevents division by zero errors - - REAL(SUMMA_PREC), INTENT(IN) :: TV !foliage temperature (k) - REAL(SUMMA_PREC), INTENT(IN) :: EI !vapor pressure inside leaf (sat vapor press at tv) (pa) - REAL(SUMMA_PREC), INTENT(IN) :: EA !vapor pressure of canopy air (pa) - REAL(SUMMA_PREC), INTENT(IN) :: APAR !par absorbed per unit lai (w/m2) - REAL(SUMMA_PREC), INTENT(IN) :: O2 !atmospheric o2 concentration (pa) - REAL(SUMMA_PREC), INTENT(IN) :: CO2 !atmospheric co2 concentration (pa) - REAL(SUMMA_PREC), INTENT(IN) :: SFCPRS !air pressure at reference height (pa) - REAL(SUMMA_PREC), INTENT(IN) :: SFCTMP !air temperature at reference height (k) - REAL(SUMMA_PREC), INTENT(IN) :: BTRAN !soil water transpiration factor (0 to 1) - REAL(SUMMA_PREC), INTENT(IN) :: FOLN !foliage nitrogen concentration (%) - REAL(SUMMA_PREC), INTENT(IN) :: RB !boundary layer resistance (s/m) + REAL(rk), INTENT(IN) :: IGS !growing season index (0=off, 1=on) + REAL(rk), INTENT(IN) :: MPE !prevents division by zero errors + + REAL(rk), INTENT(IN) :: TV !foliage temperature (k) + REAL(rk), INTENT(IN) :: EI !vapor pressure inside leaf (sat vapor press at tv) (pa) + REAL(rk), INTENT(IN) :: EA !vapor pressure of canopy air (pa) + REAL(rk), INTENT(IN) :: APAR !par absorbed per unit lai (w/m2) + REAL(rk), INTENT(IN) :: O2 !atmospheric o2 concentration (pa) + REAL(rk), INTENT(IN) :: CO2 !atmospheric co2 concentration (pa) + REAL(rk), INTENT(IN) :: SFCPRS !air pressure at reference height (pa) + REAL(rk), INTENT(IN) :: SFCTMP !air temperature at reference height (k) + REAL(rk), INTENT(IN) :: BTRAN !soil water transpiration factor (0 to 1) + REAL(rk), INTENT(IN) :: FOLN !foliage nitrogen concentration (%) + REAL(rk), INTENT(IN) :: RB !boundary layer resistance (s/m) ! output - REAL(SUMMA_PREC), INTENT(OUT) :: RS !leaf stomatal resistance (s/m) - REAL(SUMMA_PREC), INTENT(OUT) :: PSN !foliage photosynthesis (umol co2 /m2/ s) [always +] + REAL(rk), INTENT(OUT) :: RS !leaf stomatal resistance (s/m) + REAL(rk), INTENT(OUT) :: PSN !foliage photosynthesis (umol co2 /m2/ s) [always +] ! in&out - REAL(SUMMA_PREC) :: RLB !boundary layer resistance (s m2 / umol) + REAL(rk) :: RLB !boundary layer resistance (s m2 / umol) ! --------------------------------------------------------------------------------------------- ! ------------------------ local variables ---------------------------------------------------- @@ -1557,32 +1557,32 @@ SUBROUTINE STOMATA (VEGTYP ,MPE ,APAR ,FOLN ,ILOC , JLOC, & !in DATA NITER /3/ SAVE NITER - REAL(SUMMA_PREC) :: AB !used in statement functions - REAL(SUMMA_PREC) :: BC !used in statement functions - REAL(SUMMA_PREC) :: F1 !generic temperature response (statement function) - REAL(SUMMA_PREC) :: F2 !generic temperature inhibition (statement function) - REAL(SUMMA_PREC) :: TC !foliage temperature (degree Celsius) - REAL(SUMMA_PREC) :: CS !co2 concentration at leaf surface (pa) - REAL(SUMMA_PREC) :: KC !co2 Michaelis-Menten constant (pa) - REAL(SUMMA_PREC) :: KO !o2 Michaelis-Menten constant (pa) - REAL(SUMMA_PREC) :: A,B,C,Q !intermediate calculations for RS - REAL(SUMMA_PREC) :: R1,R2 !roots for RS - REAL(SUMMA_PREC) :: FNF !foliage nitrogen adjustment factor (0 to 1) - REAL(SUMMA_PREC) :: PPF !absorb photosynthetic photon flux (umol photons/m2/s) - REAL(SUMMA_PREC) :: WC !Rubisco limited photosynthesis (umol co2/m2/s) - REAL(SUMMA_PREC) :: WJ !light limited photosynthesis (umol co2/m2/s) - REAL(SUMMA_PREC) :: WE !export limited photosynthesis (umol co2/m2/s) - REAL(SUMMA_PREC) :: CP !co2 compensation point (pa) - REAL(SUMMA_PREC) :: CI !internal co2 (pa) - REAL(SUMMA_PREC) :: AWC !intermediate calculation for wc - REAL(SUMMA_PREC) :: VCMX !maximum rate of carbonylation (umol co2/m2/s) - REAL(SUMMA_PREC) :: J !electron transport (umol co2/m2/s) - REAL(SUMMA_PREC) :: CEA !constrain ea or else model blows up - REAL(SUMMA_PREC) :: CF !s m2/umol -> s/m + REAL(rk) :: AB !used in statement functions + REAL(rk) :: BC !used in statement functions + REAL(rk) :: F1 !generic temperature response (statement function) + REAL(rk) :: F2 !generic temperature inhibition (statement function) + REAL(rk) :: TC !foliage temperature (degree Celsius) + REAL(rk) :: CS !co2 concentration at leaf surface (pa) + REAL(rk) :: KC !co2 Michaelis-Menten constant (pa) + REAL(rk) :: KO !o2 Michaelis-Menten constant (pa) + REAL(rk) :: A,B,C,Q !intermediate calculations for RS + REAL(rk) :: R1,R2 !roots for RS + REAL(rk) :: FNF !foliage nitrogen adjustment factor (0 to 1) + REAL(rk) :: PPF !absorb photosynthetic photon flux (umol photons/m2/s) + REAL(rk) :: WC !Rubisco limited photosynthesis (umol co2/m2/s) + REAL(rk) :: WJ !light limited photosynthesis (umol co2/m2/s) + REAL(rk) :: WE !export limited photosynthesis (umol co2/m2/s) + REAL(rk) :: CP !co2 compensation point (pa) + REAL(rk) :: CI !internal co2 (pa) + REAL(rk) :: AWC !intermediate calculation for wc + REAL(rk) :: VCMX !maximum rate of carbonylation (umol co2/m2/s) + REAL(rk) :: J !electron transport (umol co2/m2/s) + REAL(rk) :: CEA !constrain ea or else model blows up + REAL(rk) :: CF !s m2/umol -> s/m F1(AB,BC) = AB**((BC-25.)/10.) F2(AB) = 1. + EXP((-2.2E05+710.*(AB+273.16))/(8.314*(AB+273.16))) - REAL(SUMMA_PREC) :: T + REAL(rk) :: T ! --------------------------------------------------------------------------------------------- ! MPC change @@ -1689,26 +1689,26 @@ SUBROUTINE CANRES (PAR ,SFCTMP,RCSOIL ,EAH ,SFCPRS , & !in INTEGER, INTENT(IN) :: ILOC !grid index INTEGER, INTENT(IN) :: JLOC !grid index - REAL(SUMMA_PREC), INTENT(IN) :: PAR !par absorbed per unit sunlit lai (w/m2) - REAL(SUMMA_PREC), INTENT(IN) :: SFCTMP !canopy air temperature - REAL(SUMMA_PREC), INTENT(IN) :: SFCPRS !surface pressure (pa) - REAL(SUMMA_PREC), INTENT(IN) :: EAH !water vapor pressure (pa) - REAL(SUMMA_PREC), INTENT(IN) :: RCSOIL !soil moisture stress factor + REAL(rk), INTENT(IN) :: PAR !par absorbed per unit sunlit lai (w/m2) + REAL(rk), INTENT(IN) :: SFCTMP !canopy air temperature + REAL(rk), INTENT(IN) :: SFCPRS !surface pressure (pa) + REAL(rk), INTENT(IN) :: EAH !water vapor pressure (pa) + REAL(rk), INTENT(IN) :: RCSOIL !soil moisture stress factor !outputs - REAL(SUMMA_PREC), INTENT(OUT) :: RC !canopy resistance per unit LAI - REAL(SUMMA_PREC), INTENT(OUT) :: PSN !foliage photosynthesis (umolco2/m2/s) + REAL(rk), INTENT(OUT) :: RC !canopy resistance per unit LAI + REAL(rk), INTENT(OUT) :: PSN !foliage photosynthesis (umolco2/m2/s) !local - REAL(SUMMA_PREC) :: RCQ - REAL(SUMMA_PREC) :: RCS - REAL(SUMMA_PREC) :: RCT - REAL(SUMMA_PREC) :: FF - REAL(SUMMA_PREC) :: Q2 !water vapor mixing ratio (kg/kg) - REAL(SUMMA_PREC) :: Q2SAT !saturation Q2 - REAL(SUMMA_PREC) :: DQSDT2 !d(Q2SAT)/d(T) + REAL(rk) :: RCQ + REAL(rk) :: RCS + REAL(rk) :: RCT + REAL(rk) :: FF + REAL(rk) :: Q2 !water vapor mixing ratio (kg/kg) + REAL(rk) :: Q2SAT !saturation Q2 + REAL(rk) :: DQSDT2 !d(Q2SAT)/d(T) ! RSMIN, RSMAX, TOPT, RGL, HS are canopy stress parameters set in REDPRM ! ---------------------------------------------------------------------- @@ -1751,12 +1751,12 @@ END SUBROUTINE CANRES ! ================================================================================================== SUBROUTINE CALHUM(SFCTMP, SFCPRS, Q2SAT, DQSDT2) IMPLICIT NONE - REAL(SUMMA_PREC), INTENT(IN) :: SFCTMP, SFCPRS - REAL(SUMMA_PREC), INTENT(OUT) :: Q2SAT, DQSDT2 - REAL(SUMMA_PREC), PARAMETER :: A2=17.67,A3=273.15,A4=29.65, ELWV=2.501E6, & + REAL(rk), INTENT(IN) :: SFCTMP, SFCPRS + REAL(rk), INTENT(OUT) :: Q2SAT, DQSDT2 + REAL(rk), PARAMETER :: A2=17.67,A3=273.15,A4=29.65, ELWV=2.501E6, & A23M4=A2*(A3-A4), E0=0.611, RV=461.0, & EPSILON=0.622 - REAL(SUMMA_PREC) :: ES, SFCPRSX + REAL(rk) :: ES, SFCPRSX ! Q2SAT: saturated mixing ratio ES = E0 * EXP ( ELWV/RV*(1./A3 - 1./SFCTMP) ) ! convert SFCPRS from Pa to KPa @@ -1826,13 +1826,13 @@ SUBROUTINE REDPRM (VEGTYP,SOILTYP,SLOPETYP,ZSOIL,NSOIL,ISURBAN) ! General parameters INTEGER, INTENT(IN) :: NSOIL ! Layer parameters - REAL(SUMMA_PREC),DIMENSION(NSOIL),INTENT(IN) :: ZSOIL + REAL(rk),DIMENSION(NSOIL),INTENT(IN) :: ZSOIL ! Locals - REAL(SUMMA_PREC) :: REFDK - REAL(SUMMA_PREC) :: REFKDT - REAL(SUMMA_PREC) :: FRZK - REAL(SUMMA_PREC) :: FRZFACT + REAL(rk) :: REFDK + REAL(rk) :: REFKDT + REAL(rk) :: FRZK + REAL(rk) :: FRZFACT INTEGER :: I CHARACTER(len=256) :: message ! ---------------------------------------------------------------------- diff --git a/build/source/noah-mp/module_sf_noahutl.F b/build/source/noah-mp/module_sf_noahutl.F index 562db4578..a757ebed5 100755 --- a/build/source/noah-mp/module_sf_noahutl.F +++ b/build/source/noah-mp/module_sf_noahutl.F @@ -1,7 +1,7 @@ MODULE module_sf_noahutl USE nrtype - REAL(SUMMA_PREC), PARAMETER :: CP = 1004.5, RD = 287.04, SIGMA = 5.67E-8, & + REAL(rk), PARAMETER :: CP = 1004.5, RD = 287.04, SIGMA = 5.67E-8, & CPH2O = 4.218E+3,CPICE = 2.106E+3, & LSUBF = 3.335E+5 @@ -12,20 +12,20 @@ SUBROUTINE CALTMP(T1, SFCTMP, SFCPRS, ZLVL, Q2, TH2, T1V, TH2V, RHO ) IMPLICIT NONE ! Input: - REAL(SUMMA_PREC), INTENT(IN) :: T1 ! Skin temperature (K) - REAL(SUMMA_PREC), INTENT(IN) :: SFCTMP ! Air temperature (K) at level ZLVL - REAL(SUMMA_PREC), INTENT(IN) :: Q2 ! Specific Humidity (kg/kg) at level ZLVL - REAL(SUMMA_PREC), INTENT(IN) :: SFCPRS ! Atmospheric pressure (Pa) at level ZLVL - REAL(SUMMA_PREC), INTENT(IN) :: ZLVL ! Height (m AGL) where atmospheric fields are valid + REAL(rk), INTENT(IN) :: T1 ! Skin temperature (K) + REAL(rk), INTENT(IN) :: SFCTMP ! Air temperature (K) at level ZLVL + REAL(rk), INTENT(IN) :: Q2 ! Specific Humidity (kg/kg) at level ZLVL + REAL(rk), INTENT(IN) :: SFCPRS ! Atmospheric pressure (Pa) at level ZLVL + REAL(rk), INTENT(IN) :: ZLVL ! Height (m AGL) where atmospheric fields are valid ! Output: - REAL(SUMMA_PREC), INTENT(OUT) :: TH2 ! Potential temperature (considering the reference pressure to be at the surface) - REAL(SUMMA_PREC), INTENT(OUT) :: T1V ! Virtual skin temperature (K) - REAL(SUMMA_PREC), INTENT(OUT) :: TH2V ! Virtual potential temperature at ZLVL - REAL(SUMMA_PREC), INTENT(OUT) :: RHO ! Density + REAL(rk), INTENT(OUT) :: TH2 ! Potential temperature (considering the reference pressure to be at the surface) + REAL(rk), INTENT(OUT) :: T1V ! Virtual skin temperature (K) + REAL(rk), INTENT(OUT) :: TH2V ! Virtual potential temperature at ZLVL + REAL(rk), INTENT(OUT) :: RHO ! Density ! Local: - REAL(SUMMA_PREC) :: T2V + REAL(rk) :: T2V TH2 = SFCTMP + ( 0.0098 * ZLVL) T1V= T1 * (1.0+ 0.61 * Q2) @@ -40,18 +40,18 @@ SUBROUTINE CALHUM(SFCTMP, SFCPRS, Q2SAT, DQSDT2) IMPLICIT NONE ! Input: - REAL(SUMMA_PREC), INTENT(IN) :: SFCTMP - REAL(SUMMA_PREC), INTENT(IN) :: SFCPRS + REAL(rk), INTENT(IN) :: SFCTMP + REAL(rk), INTENT(IN) :: SFCPRS ! Output: - REAL(SUMMA_PREC), INTENT(OUT) :: Q2SAT ! Saturated specific humidity - REAL(SUMMA_PREC), INTENT(OUT) :: DQSDT2 + REAL(rk), INTENT(OUT) :: Q2SAT ! Saturated specific humidity + REAL(rk), INTENT(OUT) :: DQSDT2 ! Local - REAL(SUMMA_PREC), PARAMETER :: A2=17.67,A3=273.15,A4=29.65, ELWV=2.501E6, & + REAL(rk), PARAMETER :: A2=17.67,A3=273.15,A4=29.65, ELWV=2.501E6, & A23M4=A2*(A3-A4), E0=611.0, RV=461.0, & EPSILON=0.622 - REAL(SUMMA_PREC) :: ES + REAL(rk) :: ES ! ES: e.g. Dutton chapter 8, eq 11 ES = E0 * EXP ( ELWV/RV*(1./A3 - 1./SFCTMP) ) From 61299348b0a1aa2c761229043ecf327e3a2c643e Mon Sep 17 00:00:00 2001 From: arbennett Date: Wed, 12 May 2021 14:39:39 -0700 Subject: [PATCH 18/24] Update whatsnew --- docs/whats-new.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/docs/whats-new.md b/docs/whats-new.md index 88934fa03..247f380f3 100644 --- a/docs/whats-new.md +++ b/docs/whats-new.md @@ -11,3 +11,5 @@ This page provides simple, high-level documentation about what has changed in ea - Fixes a water balance error w.r.t transpiration - Fixes the output message to report the correct solution type - Adds tolerance to balance check in updatState.f90 +- Changes all float data types to `rk`, for "real kind", which is intended to + make it easier to switch from double to single precision. From c7e5eef7eff7eb67052dfb91bda014e27726e4da Mon Sep 17 00:00:00 2001 From: arbennett Date: Wed, 12 May 2021 16:54:14 -0700 Subject: [PATCH 19/24] Fix merge conflicts --- build/source/driver/summa_globalData.f90 | 2 +- build/source/driver/summa_init.f90 | 6 +- build/source/driver/summa_modelRun.f90 | 14 +- build/source/driver/summa_restart.f90 | 8 +- build/source/driver/summa_setup.f90 | 6 +- build/source/driver/summa_type.f90 | 4 +- build/source/driver/summa_util.f90 | 8 +- build/source/dshare/data_types.f90 | 16 +- build/source/dshare/globalData.f90 | 40 +- build/source/dshare/multiconst.f90 | 58 +- build/source/dshare/outpt_stat.f90 | 20 +- build/source/engine/allocspace.f90 | 20 +- build/source/engine/bigAquifer.f90 | 20 +- build/source/engine/canopySnow.f90 | 58 +- build/source/engine/check_icond.f90 | 36 +- build/source/engine/computFlux.f90 | 70 +- build/source/engine/computJacob.f90 | 38 +- build/source/engine/computResid.f90 | 32 +- build/source/engine/convE2Temp.f90 | 72 +- build/source/engine/conv_funcs.f90 | 138 +- build/source/engine/coupled_em.f90 | 156 +- build/source/engine/derivforce.f90 | 92 +- build/source/engine/diagn_evar.f90 | 74 +- build/source/engine/eval8summa.f90 | 62 +- build/source/engine/expIntegral.f90 | 38 +- build/source/engine/f2008funcs.f90 | 6 +- build/source/engine/ffile_info.f90 | 2 +- build/source/engine/getVectorz.f90 | 86 +- build/source/engine/groundwatr.f90 | 114 +- build/source/engine/layerDivide.f90 | 42 +- build/source/engine/layerMerge.f90 | 42 +- build/source/engine/mDecisions.f90 | 8 +- build/source/engine/matrixOper.f90 | 26 +- build/source/engine/nr_utility.f90 | 36 +- build/source/engine/nrtype.f90 | 11 +- build/source/engine/opSplittin.f90 | 34 +- build/source/engine/pOverwrite.f90 | 2 +- build/source/engine/paramCheck.f90 | 10 +- build/source/engine/qTimeDelay.f90 | 14 +- build/source/engine/read_attrb.f90 | 2 +- build/source/engine/read_force.f90 | 48 +- build/source/engine/read_param.f90 | 2 +- build/source/engine/read_pinit.f90 | 8 +- build/source/engine/run_oneGRU.f90 | 36 +- build/source/engine/run_oneHRU.f90 | 6 +- build/source/engine/snowAlbedo.f90 | 52 +- build/source/engine/snowLiqFlx.f90 | 36 +- build/source/engine/snow_utils.f90 | 38 +- build/source/engine/snwCompact.f90 | 80 +- build/source/engine/soilLiqFlx.f90 | 510 +++---- build/source/engine/soil_utils.f90 | 448 +++--- build/source/engine/spline_int.f90 | 48 +- build/source/engine/ssdNrgFlux.f90 | 34 +- build/source/engine/stomResist.f90 | 370 ++--- build/source/engine/summaSolve.f90 | 276 ++-- build/source/engine/sunGeomtry.f90 | 52 +- build/source/engine/systemSolv.f90 | 58 +- build/source/engine/tempAdjust.f90 | 62 +- build/source/engine/time_utils.f90 | 46 +- build/source/engine/updatState.f90 | 47 +- build/source/engine/updateVars.f90 | 96 +- build/source/engine/varSubstep.f90 | 142 +- build/source/engine/var_derive.f90 | 96 +- build/source/engine/vegLiqFlux.f90 | 30 +- build/source/engine/vegNrgFlux.f90 | 1290 ++++++++--------- build/source/engine/vegPhenlgy.f90 | 14 +- build/source/engine/vegSWavRad.f90 | 344 ++--- build/source/engine/volicePack.f90 | 50 +- build/source/netcdf/modelwrite.f90 | 4 +- build/source/netcdf/read_icond.f90 | 6 +- build/source/noah-mp/module_model_constants.F | 211 +-- build/source/noah-mp/module_sf_noahlsm.F | 17 +- build/source/noah-mp/module_sf_noahmplsm.F | 850 +++++------ build/source/noah-mp/module_sf_noahutl.F | 35 +- docs/whats-new.md | 2 + 75 files changed, 3488 insertions(+), 3479 deletions(-) diff --git a/build/source/driver/summa_globalData.f90 b/build/source/driver/summa_globalData.f90 index d2acf3992..b3f5cfd9a 100755 --- a/build/source/driver/summa_globalData.f90 +++ b/build/source/driver/summa_globalData.f90 @@ -107,7 +107,7 @@ subroutine summa_defineGlobalData(err, message) doJacobian=.false. ! initialize the Jacobian flag ! define double precision NaNs (shared in globalData) - dNaN = ieee_value(1._dp, ieee_quiet_nan) + dNaN = ieee_value(1._rkind, ieee_quiet_nan) ! populate metadata for all model variables call popMetadat(err,cmessage) diff --git a/build/source/driver/summa_init.f90 b/build/source/driver/summa_init.f90 index 1f65af736..63c68763e 100755 --- a/build/source/driver/summa_init.f90 +++ b/build/source/driver/summa_init.f90 @@ -175,9 +175,9 @@ subroutine summa_initialize(summa1_struc, err, message) ncid(:) = integerMissing ! initialize the elapsed time for cumulative quantities - elapsedRead=0._dp - elapsedWrite=0._dp - elapsedPhysics=0._dp + elapsedRead=0._rkind + elapsedWrite=0._rkind + elapsedPhysics=0._rkind ! get the command line arguments call getCommandArguments(summa1_struc,err,cmessage) diff --git a/build/source/driver/summa_modelRun.f90 b/build/source/driver/summa_modelRun.f90 index 5080921c4..ea9eb8df6 100755 --- a/build/source/driver/summa_modelRun.f90 +++ b/build/source/driver/summa_modelRun.f90 @@ -72,16 +72,16 @@ subroutine summa_runPhysics(modelTimeStep, summa1_struc, err, message) integer(i4b) :: iGRU,jGRU,kGRU ! GRU indices ! local variables: veg phenology logical(lgt) :: computeVegFluxFlag ! flag to indicate if we are computing fluxes over vegetation (.false. means veg is buried with snow) - real(dp) :: notUsed_canopyDepth ! NOT USED: canopy depth (m) - real(dp) :: notUsed_exposedVAI ! NOT USED: exposed vegetation area index (m2 m-2) + real(rkind) :: notUsed_canopyDepth ! NOT USED: canopy depth (m) + real(rkind) :: notUsed_exposedVAI ! NOT USED: exposed vegetation area index (m2 m-2) ! local variables: parallelize the model run integer(i4b), allocatable :: ixExpense(:) ! ranked index GRU w.r.t. computational expense integer(i4b), allocatable :: totalFluxCalls(:) ! total number of flux calls for each GRU ! local variables: timing information integer*8 :: openMPstart,openMPend ! time for the start of the parallelization section integer*8, allocatable :: timeGRUstart(:) ! time GRUs start - real(dp), allocatable :: timeGRUcompleted(:) ! time required to complete each GRU - real(dp), allocatable :: timeGRU(:) ! time spent on each GRU + real(rkind), allocatable :: timeGRUcompleted(:) ! time required to complete each GRU + real(rkind), allocatable :: timeGRU(:) ! time spent on each GRU ! --------------------------------------------------------------------------------------- ! associate to elements in the data structure summaVars: associate(& @@ -171,7 +171,7 @@ subroutine summa_runPhysics(modelTimeStep, summa1_struc, err, message) ! compute the total number of flux calls from the previous time step do jGRU=1,nGRU - totalFluxCalls(jGRU) = 0._dp + totalFluxCalls(jGRU) = 0._rkind do iHRU=1,gru_struc(jGRU)%hruCount totalFluxCalls(jGRU) = totalFluxCalls(jGRU) + indxStruct%gru(jGRU)%hru(iHRU)%var(iLookINDEX%numberFluxCalc)%dat(1) end do @@ -268,8 +268,8 @@ subroutine summa_runPhysics(modelTimeStep, summa1_struc, err, message) !$omp critical(saveTiming) ! save timing information call system_clock(openMPend) - timeGRU(iGRU) = real(openMPend - timeGRUstart(iGRU), kind(dp)) - timeGRUcompleted(iGRU) = real(openMPend - openMPstart , kind(dp)) + timeGRU(iGRU) = real(openMPend - timeGRUstart(iGRU), kind(rkind)) + timeGRUcompleted(iGRU) = real(openMPend - openMPstart , kind(rkind)) !$omp end critical(saveTiming) end do ! (looping through GRUs) diff --git a/build/source/driver/summa_restart.f90 b/build/source/driver/summa_restart.f90 index 61b80816e..1bef46d47 100755 --- a/build/source/driver/summa_restart.f90 +++ b/build/source/driver/summa_restart.f90 @@ -178,7 +178,7 @@ subroutine summa_readRestart(summa1_struc, err, message) ! initialize canopy drip ! NOTE: canopy drip from the previous time step is used to compute throughfall for the current time step - fluxStruct%gru(iGRU)%hru(iHRU)%var(iLookFLUX%scalarCanopyLiqDrainage)%dat(1) = 0._dp ! not used + fluxStruct%gru(iGRU)%hru(iHRU)%var(iLookFLUX%scalarCanopyLiqDrainage)%dat(1) = 0._rkind ! not used end do ! end looping through HRUs @@ -201,14 +201,14 @@ subroutine summa_readRestart(summa1_struc, err, message) ! the basin-average aquifer storage is not used if the groundwater is included in the local column case(localColumn) - bvarStruct%gru(iGRU)%var(iLookBVAR%basin__AquiferStorage)%dat(1) = 0._dp ! set to zero to be clear that there is no basin-average aquifer storage in this configuration + bvarStruct%gru(iGRU)%var(iLookBVAR%basin__AquiferStorage)%dat(1) = 0._rkind ! set to zero to be clear that there is no basin-average aquifer storage in this configuration ! the local column aquifer storage is not used if the groundwater is basin-average ! (i.e., where multiple HRUs drain to a basin-average aquifer) case(singleBasin) - bvarStruct%gru(iGRU)%var(iLookBVAR%basin__AquiferStorage)%dat(1) = 1._dp + bvarStruct%gru(iGRU)%var(iLookBVAR%basin__AquiferStorage)%dat(1) = 1._rkind do iHRU=1,gru_struc(iGRU)%hruCount - progStruct%gru(iGRU)%hru(iHRU)%var(iLookPROG%scalarAquiferStorage)%dat(1) = 0._dp ! set to zero to be clear that there is no local aquifer storage in this configuration + progStruct%gru(iGRU)%hru(iHRU)%var(iLookPROG%scalarAquiferStorage)%dat(1) = 0._rkind ! set to zero to be clear that there is no local aquifer storage in this configuration end do ! error check diff --git a/build/source/driver/summa_setup.f90 b/build/source/driver/summa_setup.f90 index 14aa86b27..e406dfd4b 100755 --- a/build/source/driver/summa_setup.f90 +++ b/build/source/driver/summa_setup.f90 @@ -191,7 +191,7 @@ subroutine summa_paramSetup(summa1_struc, err, message) ! ***************************************************************************** ! define monthly fraction of green vegetation - greenVegFrac_monthly = (/0.01_dp, 0.02_dp, 0.03_dp, 0.07_dp, 0.50_dp, 0.90_dp, 0.95_dp, 0.96_dp, 0.65_dp, 0.24_dp, 0.11_dp, 0.02_dp/) + greenVegFrac_monthly = (/0.01_rkind, 0.02_rkind, 0.03_rkind, 0.07_rkind, 0.50_rkind, 0.90_rkind, 0.95_rkind, 0.96_rkind, 0.65_rkind, 0.24_rkind, 0.11_rkind, 0.02_rkind/) ! read Noah soil and vegetation tables call soil_veg_gen_parm(trim(SETTINGS_PATH)//trim(VEGPARM), & ! filename for vegetation table @@ -298,7 +298,7 @@ subroutine summa_paramSetup(summa1_struc, err, message) ! compute total area of the upstream HRUS that flow into each HRU do iHRU=1,gru_struc(iGRU)%hruCount - upArea%gru(iGRU)%hru(iHRU) = 0._dp + upArea%gru(iGRU)%hru(iHRU) = 0._rkind do jHRU=1,gru_struc(iGRU)%hruCount ! check if jHRU flows into iHRU; assume no exchange between GRUs if(typeStruct%gru(iGRU)%hru(jHRU)%var(iLookTYPE%downHRUindex)==typeStruct%gru(iGRU)%hru(iHRU)%var(iLookID%hruId))then @@ -309,7 +309,7 @@ subroutine summa_paramSetup(summa1_struc, err, message) ! identify the total basin area for a GRU (m2) associate(totalArea => bvarStruct%gru(iGRU)%var(iLookBVAR%basin__totalArea)%dat(1) ) - totalArea = 0._dp + totalArea = 0._rkind do iHRU=1,gru_struc(iGRU)%hruCount totalArea = totalArea + attrStruct%gru(iGRU)%hru(iHRU)%var(iLookATTR%HRUarea) end do diff --git a/build/source/driver/summa_type.f90 b/build/source/driver/summa_type.f90 index e44418816..3cc715e7f 100755 --- a/build/source/driver/summa_type.f90 +++ b/build/source/driver/summa_type.f90 @@ -91,11 +91,11 @@ MODULE summa_type ! define miscellaneous variables integer(i4b) :: summa1open ! flag to define if the summa file is open?? integer(i4b) :: numout ! number of output variables?? - real(dp) :: ts ! model time step ?? + real(rkind) :: ts ! model time step ?? integer(i4b) :: nGRU ! number of grouped response units integer(i4b) :: nHRU ! number of global hydrologic response units integer(i4b) :: hruCount ! number of local hydrologic response units - real(dp),dimension(12) :: greenVegFrac_monthly ! fraction of green vegetation in each month (0-1) + real(rkind),dimension(12) :: greenVegFrac_monthly ! fraction of green vegetation in each month (0-1) character(len=256) :: summaFileManagerFile ! path/name of file defining directories and files end type summa1_type_dec diff --git a/build/source/driver/summa_util.f90 b/build/source/driver/summa_util.f90 index 5f1256647..f310e3997 100755 --- a/build/source/driver/summa_util.f90 +++ b/build/source/driver/summa_util.f90 @@ -350,7 +350,7 @@ subroutine stop_program(err,message) integer(i4b) :: endModelRun(8) ! final time integer(i4b) :: localErr ! local error code integer(i4b) :: iFreq ! loop through output frequencies - real(dp) :: elpSec ! elapsed seconds + real(rkind) :: elpSec ! elapsed seconds ! close any remaining output files ! NOTE: use the direct NetCDF call with no error checking since the file may already be closed @@ -392,9 +392,9 @@ subroutine stop_program(err,message) ! print total elapsed time write(outunit,"(/,A,1PG15.7,A)") ' elapsed time = ', elpSec, ' s' - write(outunit,"(A,1PG15.7,A)") ' or ', elpSec/60_dp, ' m' - write(outunit,"(A,1PG15.7,A)") ' or ', elpSec/3600_dp, ' h' - write(outunit,"(A,1PG15.7,A/)") ' or ', elpSec/86400_dp, ' d' + write(outunit,"(A,1PG15.7,A)") ' or ', elpSec/60_rkind, ' m' + write(outunit,"(A,1PG15.7,A)") ' or ', elpSec/3600_rkind, ' h' + write(outunit,"(A,1PG15.7,A/)") ' or ', elpSec/86400_rkind, ' d' ! print the number of threads write(outunit,"(A,i10,/)") ' number threads = ', nThreads diff --git a/build/source/dshare/data_types.f90 b/build/source/dshare/data_types.f90 index cf20b1e89..8785af5d3 100755 --- a/build/source/dshare/data_types.f90 +++ b/build/source/dshare/data_types.f90 @@ -48,8 +48,8 @@ MODULE data_types integer(i4b),allocatable :: var_ix(:) ! index of each forcing data variable in the data structure integer(i4b),allocatable :: data_id(:) ! netcdf variable id for each forcing data variable character(len=256),allocatable :: varName(:) ! netcdf variable name for each forcing data variable - real(dp) :: firstJulDay ! first julian day in forcing file - real(dp) :: convTime2Days ! factor to convert time to days + real(rkind) :: firstJulDay ! first julian day in forcing file + real(rkind) :: convTime2Days ! factor to convert time to days end type file_info ! *********************************************************************************************************** @@ -57,9 +57,9 @@ MODULE data_types ! *********************************************************************************************************** ! define a data type to store model parameter information type,public :: par_info - real(dp) :: default_val ! default parameter value - real(dp) :: lower_limit ! lower bound - real(dp) :: upper_limit ! upper bound + real(rkind) :: default_val ! default parameter value + real(rkind) :: lower_limit ! lower bound + real(rkind) :: upper_limit ! upper bound endtype par_info ! *********************************************************************************************************** @@ -131,7 +131,7 @@ MODULE data_types ! NOTE: use derived types here to facilitate adding the "variable" dimension ! ** double precision type type, public :: dlength - real(dp),allocatable :: dat(:) ! dat(:) + real(rkind),allocatable :: dat(:) ! dat(:) endtype dlength ! ** integer type (4 byte) type, public :: ilength @@ -168,7 +168,7 @@ MODULE data_types ! ** double precision type of fixed length type, public :: var_d - real(dp),allocatable :: var(:) ! var(:) + real(rkind),allocatable :: var(:) ! var(:) endtype var_d ! ** integer type of fixed length (4 byte) type, public :: var_i @@ -181,7 +181,7 @@ MODULE data_types ! ** double precision type of fixed length type, public :: hru_d - real(dp),allocatable :: hru(:) ! hru(:) + real(rkind),allocatable :: hru(:) ! hru(:) endtype hru_d ! ** integer type of fixed length (4 byte) type, public :: hru_i diff --git a/build/source/dshare/globalData.f90 b/build/source/dshare/globalData.f90 index e41f2f160..44b5063b7 100755 --- a/build/source/dshare/globalData.f90 +++ b/build/source/dshare/globalData.f90 @@ -61,8 +61,8 @@ MODULE globalData ! ---------------------------------------------------------------------------------------------------------------- ! define missing values - real(qp),parameter,public :: quadMissing = nr_quadMissing ! (from nrtype) missing quadruple precision number - real(dp),parameter,public :: realMissing = nr_realMissing ! (from nrtype) missing double precision number + real(rkind),parameter,public :: quadMissing = nr_quadMissing ! (from nrtype) missing quadruple precision number + real(rkind),parameter,public :: realMissing = nr_realMissing ! (from nrtype) missing double precision number integer(i4b),parameter,public :: integerMissing = nr_integerMissing ! (from nrtype) missing integer ! define run modes @@ -166,11 +166,11 @@ MODULE globalData integer(i4b),parameter,public :: iJac2=20 ! last layer of the Jacobian to print ! define limit checks - real(dp),parameter,public :: verySmall=tiny(1.0_dp) ! a very small number - real(dp),parameter,public :: veryBig=1.e+20_dp ! a very big number + real(rkind),parameter,public :: verySmall=tiny(1.0_rkind) ! a very small number + real(rkind),parameter,public :: veryBig=1.e+20_rkind ! a very big number ! define algorithmic control parameters - real(dp),parameter,public :: dx = 1.e-8_dp ! finite difference increment + real(rkind),parameter,public :: dx = 1.e-8_rkind ! finite difference increment ! define summary information on all data structures integer(i4b),parameter :: nStruct=13 ! number of data structures @@ -198,7 +198,7 @@ MODULE globalData ! ---------------------------------------------------------------------------------------------------------------- ! define Indian bread (NaN) - real(dp),save,public :: dNaN + real(rkind),save,public :: dNaN ! define default parameter values and parameter bounds type(par_info),save,public :: localParFallback(maxvarMpar) ! local column default parameters @@ -264,7 +264,7 @@ MODULE globalData type(hru2gru_map),allocatable,save,public :: index_map(:) ! hru2gru map ! define variables used for the vegetation phenology - real(dp),dimension(12), save , public :: greenVegFrac_monthly ! fraction of green vegetation in each month (0-1) + real(rkind),dimension(12), save , public :: greenVegFrac_monthly ! fraction of green vegetation in each month (0-1) ! define the model output file character(len=256),save,public :: fileout='' ! output filename @@ -291,13 +291,13 @@ MODULE globalData integer(i4b),save,public :: numtim ! number of time steps integer(i4b),save,public :: nHRUrun ! number of HRUs in the run domain integer(i4b),save,public :: nGRUrun ! number of GRUs in the run domain - real(dp),save,public :: data_step ! time step of the data - real(dp),save,public :: refJulday ! reference time in fractional julian days - real(dp),save,public :: refJulday_data ! reference time in fractional julian days (data files) - real(dp),save,public :: fracJulday ! fractional julian days since the start of year - real(dp),save,public :: dJulianStart ! julian day of start time of simulation - real(dp),save,public :: dJulianFinsh ! julian day of end time of simulation - real(dp),save,public :: tmZoneOffsetFracDay ! time zone offset in fractional days + real(rkind),save,public :: data_step ! time step of the data + real(rkind),save,public :: refJulday ! reference time in fractional julian days + real(rkind),save,public :: refJulday_data ! reference time in fractional julian days (data files) + real(rkind),save,public :: fracJulday ! fractional julian days since the start of year + real(rkind),save,public :: dJulianStart ! julian day of start time of simulation + real(rkind),save,public :: dJulianFinsh ! julian day of end time of simulation + real(rkind),save,public :: tmZoneOffsetFracDay ! time zone offset in fractional days integer(i4b),save,public :: nHRUfile ! number of HRUs in the file integer(i4b),save,public :: yearLength ! number of days in the current year integer(i4b),save,public :: urbanVegCategory ! vegetation category for urban areas @@ -315,12 +315,12 @@ MODULE globalData integer(i4b),dimension(8),save,public :: startPhysics,endPhysics ! date/time for the start and end of the physics ! define elapsed time - real(dp),save,public :: elapsedInit ! elapsed time for the initialization - real(dp),save,public :: elapsedSetup ! elapsed time for the parameter setup - real(dp),save,public :: elapsedRestart ! elapsed time to read restart data - real(dp),save,public :: elapsedRead ! elapsed time for the data read - real(dp),save,public :: elapsedWrite ! elapsed time for the stats/write - real(dp),save,public :: elapsedPhysics ! elapsed time for the physics + real(rkind),save,public :: elapsedInit ! elapsed time for the initialization + real(rkind),save,public :: elapsedSetup ! elapsed time for the parameter setup + real(rkind),save,public :: elapsedRestart ! elapsed time to read restart data + real(rkind),save,public :: elapsedRead ! elapsed time for the data read + real(rkind),save,public :: elapsedWrite ! elapsed time for the stats/write + real(rkind),save,public :: elapsedPhysics ! elapsed time for the physics ! define ancillary data structures type(var_i),save,public :: startTime ! start time for the model simulation diff --git a/build/source/dshare/multiconst.f90 b/build/source/dshare/multiconst.f90 index 764816fc6..b1f007a1a 100755 --- a/build/source/dshare/multiconst.f90 +++ b/build/source/dshare/multiconst.f90 @@ -21,33 +21,33 @@ MODULE multiconst USE nrtype ! define physical constants - REAL(DP), PARAMETER :: ave_slp = 101325.0_dp ! mean sea level pressure (Pa) - REAL(DP), PARAMETER :: vkc = 0.4_dp ! von Karman constant (-) - REAL(DP), PARAMETER :: satvpfrz = 610.8_dp ! sat vapour pressure at 273.16K (Pa) - REAL(DP), PARAMETER :: w_ratio = 0.622_dp ! molecular ratio water to dry air (-) - REAL(DP), PARAMETER :: R_da = 287.053_dp ! gas constant for dry air (Pa K-1 m3 kg-1; J kg-1 K-1) - REAL(DP), PARAMETER :: R_wv = 461.285_dp ! gas constant for water vapor (Pa K-1 m3 kg-1; J kg-1 K-1) - REAL(DP), PARAMETER :: Rgas = 8.314_dp ! universal gas constant (J mol-1 K-1) - REAL(DP), PARAMETER :: gravity = 9.80616_dp ! acceleration of gravity (m s-2) - REAL(DP), PARAMETER :: Cp_air = 1005._dp ! specific heat of air (J kg-1 K-1) - REAL(DP), PARAMETER :: Cp_ice = 2114._dp ! specific heat of ice (J kg-1 K-1) - REAL(DP), PARAMETER :: Cp_soil = 850._dp ! specific heat of soil (J kg-1 K-1) - REAL(DP), PARAMETER :: Cp_water = 4181._dp ! specific heat of liquid water (J kg-1 K-1) - REAL(DP), PARAMETER :: Tfreeze = 273.16_dp ! temperature at freezing (K) - REAL(DP), PARAMETER :: TriplPt = 273.16_dp ! triple point of water (K) - REAL(DP), PARAMETER :: LH_fus = 333700.0_dp ! latent heat of fusion (J kg-1) - REAL(DP), PARAMETER :: LH_vap = 2501000.0_dp ! latent heat of vaporization (J kg-1) - REAL(DP), PARAMETER :: LH_sub = 2834700.0_dp ! latent heat of sublimation (J kg-1) - REAL(DP), PARAMETER :: sb = 5.6705d-8 ! Stefan Boltzman constant (W m-2 K-4) - REAL(DP), PARAMETER :: em_sno = 0.99_dp ! emissivity of snow (-) - REAL(DP), PARAMETER :: lambda_air = 0.026_dp ! thermal conductivity of air (W m-1 K-1) - REAL(DP), PARAMETER :: lambda_ice = 2.50_dp ! thermal conductivity of ice (W m-1 K-1) - REAL(DP), PARAMETER :: lambda_water = 0.60_dp ! thermal conductivity of liquid water (W m-1 K-1) - REAL(DP), PARAMETER :: iden_air = 1.293_dp ! intrinsic density of air (kg m-3) - REAL(DP), PARAMETER :: iden_ice = 917.0_dp ! intrinsic density of ice (kg m-3) - REAL(DP), PARAMETER :: iden_water = 1000.0_dp ! intrinsic density of liquid water (kg m-3) - REAL(DP), PARAMETER :: secprday = 86400._dp ! number of seconds in a day - REAL(DP), PARAMETER :: secprhour = 3600._dp ! number of seconds in an hour - REAL(DP), PARAMETER :: secprmin = 60._dp ! number of seconds in a minute - REAL(DP), PARAMETER :: minprhour = 60._dp ! number of minutes in an hour + real(rkind), PARAMETER :: ave_slp = 101325.0_rkind ! mean sea level pressure (Pa) + real(rkind), PARAMETER :: vkc = 0.4_rkind ! von Karman constant (-) + real(rkind), PARAMETER :: satvpfrz = 610.8_rkind ! sat vapour pressure at 273.16K (Pa) + real(rkind), PARAMETER :: w_ratio = 0.622_rkind ! molecular ratio water to dry air (-) + real(rkind), PARAMETER :: R_da = 287.053_rkind ! gas constant for dry air (Pa K-1 m3 kg-1; J kg-1 K-1) + real(rkind), PARAMETER :: R_wv = 461.285_rkind ! gas constant for water vapor (Pa K-1 m3 kg-1; J kg-1 K-1) + real(rkind), PARAMETER :: Rgas = 8.314_rkind ! universal gas constant (J mol-1 K-1) + real(rkind), PARAMETER :: gravity = 9.80616_rkind ! acceleration of gravity (m s-2) + real(rkind), PARAMETER :: Cp_air = 1005._rkind ! specific heat of air (J kg-1 K-1) + real(rkind), PARAMETER :: Cp_ice = 2114._rkind ! specific heat of ice (J kg-1 K-1) + real(rkind), PARAMETER :: Cp_soil = 850._rkind ! specific heat of soil (J kg-1 K-1) + real(rkind), PARAMETER :: Cp_water = 4181._rkind ! specific heat of liquid water (J kg-1 K-1) + real(rkind), PARAMETER :: Tfreeze = 273.16_rkind ! temperature at freezing (K) + real(rkind), PARAMETER :: TriplPt = 273.16_rkind ! triple point of water (K) + real(rkind), PARAMETER :: LH_fus = 333700.0_rkind ! latent heat of fusion (J kg-1) + real(rkind), PARAMETER :: LH_vap = 2501000.0_rkind ! latent heat of vaporization (J kg-1) + real(rkind), PARAMETER :: LH_sub = 2834700.0_rkind ! latent heat of sublimation (J kg-1) + real(rkind), PARAMETER :: sb = 5.6705d-8 ! Stefan Boltzman constant (W m-2 K-4) + real(rkind), PARAMETER :: em_sno = 0.99_rkind ! emissivity of snow (-) + real(rkind), PARAMETER :: lambda_air = 0.026_rkind ! thermal conductivity of air (W m-1 K-1) + real(rkind), PARAMETER :: lambda_ice = 2.50_rkind ! thermal conductivity of ice (W m-1 K-1) + real(rkind), PARAMETER :: lambda_water = 0.60_rkind ! thermal conductivity of liquid water (W m-1 K-1) + real(rkind), PARAMETER :: iden_air = 1.293_rkind ! intrinsic density of air (kg m-3) + real(rkind), PARAMETER :: iden_ice = 917.0_rkind ! intrinsic density of ice (kg m-3) + real(rkind), PARAMETER :: iden_water = 1000.0_rkind ! intrinsic density of liquid water (kg m-3) + real(rkind), PARAMETER :: secprday = 86400._rkind ! number of seconds in a day + real(rkind), PARAMETER :: secprhour = 3600._rkind ! number of seconds in an hour + real(rkind), PARAMETER :: secprmin = 60._rkind ! number of seconds in a minute + real(rkind), PARAMETER :: minprhour = 60._rkind ! number of minutes in an hour END MODULE multiconst diff --git a/build/source/dshare/outpt_stat.f90 b/build/source/dshare/outpt_stat.f90 index dbb7c3953..9bae9b83b 100755 --- a/build/source/dshare/outpt_stat.f90 +++ b/build/source/dshare/outpt_stat.f90 @@ -54,7 +54,7 @@ subroutine calcStats(stat,dat,meta,resetStats,finalizeStats,statCounter,err,mess character(256) :: cmessage ! error message integer(i4b) :: iVar ! index for varaiable loop integer(i4b) :: pVar ! index into parent structure - real(dp) :: tdata ! dummy for pulling info from dat structure + real(rkind) :: tdata ! dummy for pulling info from dat structure ! initialize error control err=0; message='calcStats/' @@ -73,9 +73,9 @@ subroutine calcStats(stat,dat,meta,resetStats,finalizeStats,statCounter,err,mess ! extract data from the structures select type (dat) - type is (real(dp)); tdata = dat(pVar) + type is (real(rkind)); tdata = dat(pVar) class is (dlength) ; tdata = dat(pVar)%dat(1) - class is (ilength) ; tdata = real(dat(pVar)%dat(1), kind(dp)) + class is (ilength) ; tdata = real(dat(pVar)%dat(1), kind(rkind)) class default;err=20;message=trim(message)//'dat type not found';return end select @@ -114,7 +114,7 @@ subroutine calc_stats(meta,stat,tdata,resetStats,finalizeStats,statCounter,err,m ! input variables class(var_info),intent(in) :: meta ! meta data structure class(*) ,intent(inout) :: stat ! statistics structure - real(dp) ,intent(in) :: tdata ! data value + real(rkind) ,intent(in) :: tdata ! data value logical(lgt) ,intent(in) :: resetStats(:) ! vector of flags to reset statistics logical(lgt) ,intent(in) :: finalizeStats(:) ! vector of flags to reset statistics integer(i4b) ,intent(in) :: statCounter(:) ! number of time steps in each output frequency @@ -122,7 +122,7 @@ subroutine calc_stats(meta,stat,tdata,resetStats,finalizeStats,statCounter,err,m integer(i4b) ,intent(out) :: err ! error code character(*) ,intent(out) :: message ! error message ! internals - real(dp),dimension(maxvarFreq*2) :: tstat ! temporary stats vector + real(rkind),dimension(maxvarFreq*2) :: tstat ! temporary stats vector integer(i4b) :: iFreq ! index of output frequency ! initialize error control err=0; message='calc_stats/' @@ -144,12 +144,12 @@ subroutine calc_stats(meta,stat,tdata,resetStats,finalizeStats,statCounter,err,m select case(meta%statIndex(iFreq)) ! act depending on the statistic ! ------------------------------------------------------------------------------------- case (iLookStat%totl) ! * summation over period - tstat(iFreq) = 0._dp ! - resets stat at beginning of period + tstat(iFreq) = 0._rkind ! - resets stat at beginning of period case (iLookStat%mean) ! * mean over period - tstat(iFreq) = 0._dp ! - resets stat at beginning of period + tstat(iFreq) = 0._rkind ! - resets stat at beginning of period case (iLookStat%vari) ! * variance over period - tstat(iFreq) = 0._dp ! - resets E[X^2] term in var calc - tstat(maxVarFreq+iFreq) = 0._dp ! - resets E[X]^2 term + tstat(iFreq) = 0._rkind ! - resets E[X^2] term in var calc + tstat(maxVarFreq+iFreq) = 0._rkind ! - resets E[X]^2 term case (iLookStat%mini) ! * minimum over period tstat(iFreq) = huge(tstat(iFreq)) ! - resets stat at beginning of period case (iLookStat%maxi) ! * maximum over period @@ -186,7 +186,7 @@ subroutine calc_stats(meta,stat,tdata,resetStats,finalizeStats,statCounter,err,m if (tdatatstat(iFreq)) tstat(iFreq) = tdata ! - check value - case (iLookStat%mode) ! * mode over period (does not work) + case (iLookStat%mode) ! * mode over period (does not workind) tstat(iFreq) = realMissing case default message=trim(message)//'unable to identify type of statistic [calculating stats]' diff --git a/build/source/engine/allocspace.f90 b/build/source/engine/allocspace.f90 index 27e73300a..720067187 100755 --- a/build/source/engine/allocspace.f90 +++ b/build/source/engine/allocspace.f90 @@ -262,7 +262,7 @@ subroutine allocLocal(metaStruct,dataStruct,nSnow,nSoil,err,message) select type(dataStruct) class is (var_flagVec); call allocateDat_flag(metaStruct,nSnow,nSoil,nLayers,dataStruct,err,cmessage) class is (var_ilength); call allocateDat_int( metaStruct,nSnow,nSoil,nLayers,dataStruct,err,cmessage) - class is (var_dlength); call allocateDat_dp( metaStruct,nSnow,nSoil,nLayers,dataStruct,err,cmessage) + class is (var_dlength); call allocateDat_rkind( metaStruct,nSnow,nSoil,nLayers,dataStruct,err,cmessage) class default; err=20; message=trim(message)//'unable to identify derived data type for the data dimension'; return end select @@ -328,7 +328,7 @@ subroutine resizeData(metaStruct,dataStructOrig,dataStructNew,copy,err,message) ! double precision class is (var_dlength) select type(dataStructNew) - class is (var_dlength); call copyStruct_dp( dataStructOrig%var(iVar),dataStructNew%var(iVar),isCopy,err,cmessage) + class is (var_dlength); call copyStruct_rkind( dataStructOrig%var(iVar),dataStructNew%var(iVar),isCopy,err,cmessage) class default; err=20; message=trim(message)//'mismatch data structure for variable'//trim(metaStruct(iVar)%varname); return end select @@ -349,9 +349,9 @@ subroutine resizeData(metaStruct,dataStructOrig,dataStructNew,copy,err,message) end subroutine resizeData ! ************************************************************************************************ - ! private subroutine copyStruct_dp: copy a given data structure + ! private subroutine copyStruct_rkind: copy a given data structure ! ************************************************************************************************ - subroutine copyStruct_dp(varOrig,varNew,copy,err,message) + subroutine copyStruct_rkind(varOrig,varNew,copy,err,message) ! dummy variables type(dlength),intent(in) :: varOrig ! original data structure type(dlength),intent(inout) :: varNew ! new data structure @@ -366,7 +366,7 @@ subroutine copyStruct_dp(varOrig,varNew,copy,err,message) integer(i4b) :: lowerBoundNew ! lower bound of a given variable in the new data structure integer(i4b) :: upperBoundNew ! upper bound of a given variable in the new data structure ! initialize error control - err=0; message='copyStruct_dp/' + err=0; message='copyStruct_rkind/' ! get the information from the data structures call getVarInfo(varOrig,allocatedOrig,lowerBoundOrig,upperBoundOrig) @@ -433,7 +433,7 @@ subroutine getVarInfo(var,isAllocated,lowerBound,upperBound) end subroutine getVarInfo - end subroutine copyStruct_dp + end subroutine copyStruct_rkind ! ************************************************************************************************ ! private subroutine copyStruct_i4b: copy a given data structure @@ -524,9 +524,9 @@ end subroutine copyStruct_i4b ! ************************************************************************************************ - ! private subroutine allocateDat_dp: initialize data dimension of the data structures + ! private subroutine allocateDat_rkind: initialize data dimension of the data structures ! ************************************************************************************************ - subroutine allocateDat_dp(metadata,nSnow,nSoil,nLayers, & ! input + subroutine allocateDat_rkind(metadata,nSnow,nSoil,nLayers, & ! input varData,err,message) ! output ! access subroutines USE get_ixName_module,only:get_varTypeName ! to access type strings for error messages @@ -546,7 +546,7 @@ subroutine allocateDat_dp(metadata,nSnow,nSoil,nLayers, & ! input integer(i4b) :: nVars ! number of variables in the metadata structure ! initialize error control - err=0; message='allocateDat_dp/' + err=0; message='allocateDat_rkind/' ! get the number of variables in the metadata structure nVars = size(metadata) @@ -589,7 +589,7 @@ subroutine allocateDat_dp(metadata,nSnow,nSoil,nLayers, & ! input end do ! looping through variables - end subroutine allocateDat_dp + end subroutine allocateDat_rkind ! ************************************************************************************************ ! private subroutine allocateDat_int: initialize data dimension of the data structures diff --git a/build/source/engine/bigAquifer.f90 b/build/source/engine/bigAquifer.f90 index e9312789d..5b5ed0190 100755 --- a/build/source/engine/bigAquifer.f90 +++ b/build/source/engine/bigAquifer.f90 @@ -66,24 +66,24 @@ subroutine bigAquifer(& ! ------------------------------------------------------------------------------------------------------------------------------------------------- implicit none ! input: state variables, fluxes, and parameters - real(dp),intent(in) :: scalarAquiferStorageTrial ! trial value of aquifer storage (m) - real(dp),intent(in) :: scalarCanopyTranspiration ! canopy transpiration (kg m-2 s-1) - real(dp),intent(in) :: scalarSoilDrainage ! soil drainage (m s-1) + real(rkind),intent(in) :: scalarAquiferStorageTrial ! trial value of aquifer storage (m) + real(rkind),intent(in) :: scalarCanopyTranspiration ! canopy transpiration (kg m-2 s-1) + real(rkind),intent(in) :: scalarSoilDrainage ! soil drainage (m s-1) ! input: diagnostic variables and parameters type(var_dlength),intent(in) :: mpar_data ! model parameters type(var_dlength),intent(in) :: diag_data ! diagnostic variables for a local HRU ! output: fluxes - real(dp),intent(out) :: scalarAquiferTranspire ! transpiration loss from the aquifer (m s-1) - real(dp),intent(out) :: scalarAquiferRecharge ! recharge to the aquifer (m s-1) - real(dp),intent(out) :: scalarAquiferBaseflow ! total baseflow from the aquifer (m s-1) - real(dp),intent(out) :: dBaseflow_dAquifer ! change in baseflow flux w.r.t. aquifer storage (s-1) + real(rkind),intent(out) :: scalarAquiferTranspire ! transpiration loss from the aquifer (m s-1) + real(rkind),intent(out) :: scalarAquiferRecharge ! recharge to the aquifer (m s-1) + real(rkind),intent(out) :: scalarAquiferBaseflow ! total baseflow from the aquifer (m s-1) + real(rkind),intent(out) :: dBaseflow_dAquifer ! change in baseflow flux w.r.t. aquifer storage (s-1) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! ----------------------------------------------------------------------------------------------------------------------------------------------------- ! local variables - real(dp) :: aquiferTranspireFrac ! fraction of total transpiration that comes from the aquifer (-) - real(dp) :: xTemp ! temporary variable (-) + real(rkind) :: aquiferTranspireFrac ! fraction of total transpiration that comes from the aquifer (-) + real(rkind) :: xTemp ! temporary variable (-) ! ------------------------------------------------------------------------------------------------------------------------------------------------- ! initialize error control err=0; message='bigAquifer/' @@ -112,7 +112,7 @@ subroutine bigAquifer(& scalarAquiferBaseflow = aquiferBaseflowRate*(xTemp**aquiferBaseflowExp) ! compute the derivative in the net aquifer flux - dBaseflow_dAquifer = -(aquiferBaseflowExp*aquiferBaseflowRate*(xTemp**(aquiferBaseflowExp - 1._dp)))/aquiferScaleFactor + dBaseflow_dAquifer = -(aquiferBaseflowExp*aquiferBaseflowRate*(xTemp**(aquiferBaseflowExp - 1._rkind)))/aquiferScaleFactor ! end association to data in structures end associate diff --git a/build/source/engine/canopySnow.f90 b/build/source/engine/canopySnow.f90 index cde7e0b15..930227c9c 100755 --- a/build/source/engine/canopySnow.f90 +++ b/build/source/engine/canopySnow.f90 @@ -73,8 +73,8 @@ subroutine canopySnow(& implicit none ! ------------------------------------------------------------------------------------------------ ! input: model control - real(dp),intent(in) :: dt ! time step (seconds) - real(dp),intent(in) :: exposedVAI ! exposed vegetation area index -- leaf + stem -- after burial by snow (m2 m-2) + real(rkind),intent(in) :: dt ! time step (seconds) + real(rkind),intent(in) :: exposedVAI ! exposed vegetation area index -- leaf + stem -- after burial by snow (m2 m-2) logical(lgt),intent(in) :: computeVegFlux ! flag to indicate if we are computing fluxes over vegetation (.false. means veg is buried with snow) ! input/output: data structures type(model_options),intent(in) :: model_decisions(:) ! model decisions @@ -87,23 +87,23 @@ subroutine canopySnow(& integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! local variables - real(dp),parameter :: valueMissing=-9999._dp ! missing value + real(rkind),parameter :: valueMissing=-9999._rkind ! missing value integer(i4b) :: iter ! iteration index integer(i4b),parameter :: maxiter=50 ! maximum number of iterations - real(dp) :: unloading_melt ! unloading associated with canopy drip (kg m-2 s-1) - real(dp) :: airtemp_degC ! value of air temperature in degrees Celcius - real(dp) :: leafScaleFactor ! scaling factor for interception based on temperature (-) - real(dp) :: leafInterceptCapSnow ! storage capacity for snow per unit leaf area (kg m-2) - real(dp) :: canopyIceScaleFactor ! capacity scaling factor for throughfall (kg m-2) - real(dp) :: throughfallDeriv ! derivative in throughfall flux w.r.t. canopy storage (s-1) - real(dp) :: unloadingDeriv ! derivative in unloading flux w.r.t. canopy storage (s-1) - real(dp) :: scalarCanopyIceIter ! trial value for mass of ice on the vegetation canopy (kg m-2) (kg m-2) - real(dp) :: flux ! net flux (kg m-2 s-1) - real(dp) :: delS ! change in storage (kg m-2) - real(dp) :: resMass ! residual in mass equation (kg m-2) - real(dp) :: tempUnloadingFun ! temperature unloading functions, Eq. 14 in Roesch et al. 2001 - real(dp) :: windUnloadingFun ! temperature unloading functions, Eq. 15 in Roesch et al. 2001 - real(dp),parameter :: convTolerMass=0.0001_dp ! convergence tolerance for mass (kg m-2) + real(rkind) :: unloading_melt ! unloading associated with canopy drip (kg m-2 s-1) + real(rkind) :: airtemp_degC ! value of air temperature in degrees Celcius + real(rkind) :: leafScaleFactor ! scaling factor for interception based on temperature (-) + real(rkind) :: leafInterceptCapSnow ! storage capacity for snow per unit leaf area (kg m-2) + real(rkind) :: canopyIceScaleFactor ! capacity scaling factor for throughfall (kg m-2) + real(rkind) :: throughfallDeriv ! derivative in throughfall flux w.r.t. canopy storage (s-1) + real(rkind) :: unloadingDeriv ! derivative in unloading flux w.r.t. canopy storage (s-1) + real(rkind) :: scalarCanopyIceIter ! trial value for mass of ice on the vegetation canopy (kg m-2) (kg m-2) + real(rkind) :: flux ! net flux (kg m-2 s-1) + real(rkind) :: delS ! change in storage (kg m-2) + real(rkind) :: resMass ! residual in mass equation (kg m-2) + real(rkind) :: tempUnloadingFun ! temperature unloading functions, Eq. 14 in Roesch et al. 2001 + real(rkind) :: windUnloadingFun ! temperature unloading functions, Eq. 15 in Roesch et al. 2001 + real(rkind),parameter :: convTolerMass=0.0001_rkind ! convergence tolerance for mass (kg m-2) ! ------------------------------------------------------------------------------------------------------------------------------- ! initialize error control err=0; message='canopySnow/' @@ -151,7 +151,7 @@ subroutine canopySnow(& if(computeVegFlux)then unloading_melt = min(ratioDrip2Unloading*scalarCanopyLiqDrainage, scalarCanopyIce/dt) ! kg m-2 s-1 else - unloading_melt = 0._dp + unloading_melt = 0._rkind end if scalarCanopyIce = scalarCanopyIce - unloading_melt*dt @@ -173,11 +173,11 @@ subroutine canopySnow(& scalarCanopySnowUnloading = snowUnloadingCoeff*scalarCanopyIceIter unloadingDeriv = snowUnloadingCoeff else if (ixSnowUnload==windUnload) then - tempUnloadingFun = max(scalarCanairTemp - minTempUnloading, 0._dp) / rateTempUnloading ! (s-1) + tempUnloadingFun = max(scalarCanairTemp - minTempUnloading, 0._rkind) / rateTempUnloading ! (s-1) if (scalarWindspdCanopyTop >= minWindUnloading) then windUnloadingFun = abs(scalarWindspdCanopyTop) / rateWindUnloading ! (s-1) else - windUnloadingFun = 0._dp ! (s-1) + windUnloadingFun = 0._rkind ! (s-1) end if ! implement the "windySnow" Roesch et al. 2001 parameterization, Eq. 13 in Roesch et al. 2001 scalarCanopySnowUnloading = scalarCanopyIceIter * (tempUnloadingFun + windUnloadingFun) @@ -187,24 +187,24 @@ subroutine canopySnow(& if(scalarSnowfall -1._dp) then - leafScaleFactor = 4.0_dp - elseif(airtemp_degC > -3._dp) then - leafScaleFactor = 1.5_dp*airtemp_degC + 5.5_dp + if (airtemp_degC > -1._rkind) then + leafScaleFactor = 4.0_rkind + elseif(airtemp_degC > -3._rkind) then + leafScaleFactor = 1.5_rkind*airtemp_degC + 5.5_rkind else - leafScaleFactor = 1.0_dp + leafScaleFactor = 1.0_rkind end if leafInterceptCapSnow = refInterceptCapSnow*leafScaleFactor case default @@ -219,7 +219,7 @@ subroutine canopySnow(& end if ! (if snow is falling) ! ** compute iteration increment flux = scalarSnowfall - scalarThroughfallSnow - scalarCanopySnowUnloading ! net flux (kg m-2 s-1) - delS = (flux*dt - (scalarCanopyIceIter - scalarCanopyIce))/(1._dp + (throughfallDeriv + unloadingDeriv)*dt) + delS = (flux*dt - (scalarCanopyIceIter - scalarCanopyIce))/(1._rkind + (throughfallDeriv + unloadingDeriv)*dt) ! ** check for convergence resMass = scalarCanopyIceIter - (scalarCanopyIce + flux*dt) if(abs(resMass) < convTolerMass)exit diff --git a/build/source/engine/check_icond.f90 b/build/source/engine/check_icond.f90 index 9a1e9a779..3210932be 100755 --- a/build/source/engine/check_icond.f90 +++ b/build/source/engine/check_icond.f90 @@ -82,15 +82,15 @@ subroutine check_icond(nGRU, & ! number of GRUs and HRU ! temporary variables for realism checks integer(i4b) :: iLayer ! index of model layer integer(i4b) :: iSoil ! index of soil layer - real(dp) :: fLiq ! fraction of liquid water on the vegetation canopy (-) - real(dp) :: vGn_m ! van Genutchen "m" parameter (-) - real(dp) :: tWat ! total water on the vegetation canopy (kg m-2) - real(dp) :: scalarTheta ! liquid water equivalent of total water [liquid water + ice] (-) - real(dp) :: h1,h2 ! used to check depth and height are consistent + real(rkind) :: fLiq ! fraction of liquid water on the vegetation canopy (-) + real(rkind) :: vGn_m ! van Genutchen "m" parameter (-) + real(rkind) :: tWat ! total water on the vegetation canopy (kg m-2) + real(rkind) :: scalarTheta ! liquid water equivalent of total water [liquid water + ice] (-) + real(rkind) :: h1,h2 ! used to check depth and height are consistent integer(i4b) :: nLayers ! total number of layers - real(dp) :: kappa ! constant in the freezing curve function (m K-1) + real(rkind) :: kappa ! constant in the freezing curve function (m K-1) integer(i4b) :: nSnow ! number of snow layers - real(dp),parameter :: xTol=1.e-10_dp ! small tolerance to address precision issues + real(rkind),parameter :: xTol=1.e-10_rkind ! small tolerance to address precision issues ! -------------------------------------------------------------------------------------------------------- ! Start procedure here @@ -149,14 +149,14 @@ subroutine check_icond(nGRU, & ! number of GRUs and HRU kappa = (iden_ice/iden_water)*(LH_fus/(gravity*Tfreeze)) ! NOTE: J = kg m2 s-2 ! modify the liquid water and ice in the canopy - if(scalarCanopyIce > 0._dp .and. scalarCanopyTemp > Tfreeze)then + if(scalarCanopyIce > 0._rkind .and. scalarCanopyTemp > Tfreeze)then message=trim(message)//'canopy ice > 0 when canopy temperature > Tfreeze' err=20; return end if fLiq = fracliquid(scalarCanopyTemp,snowfrz_scale) ! fraction of liquid water (-) tWat = scalarCanopyLiq + scalarCanopyIce ! total water (kg m-2) scalarCanopyLiq = fLiq*tWat ! mass of liquid water on the canopy (kg m-2) - scalarCanopyIce = (1._dp - fLiq)*tWat ! mass of ice on the canopy (kg m-2) + scalarCanopyIce = (1._rkind - fLiq)*tWat ! mass of ice on the canopy (kg m-2) ! number of layers nLayers = gru_struc(iGRU)%hruInfo(iHRU)%nSnow + gru_struc(iGRU)%hruInfo(iHRU)%nSoil @@ -168,7 +168,7 @@ subroutine check_icond(nGRU, & ! number of GRUs and HRU ! compute liquid water equivalent of total water (liquid plus ice) if (iLayer>nSnow) then ! soil layer = no volume expansion iSoil = iLayer - nSnow - vGn_m = 1._dp - 1._dp/vGn_n(iSoil) + vGn_m = 1._rkind - 1._rkind/vGn_n(iSoil) scalarTheta = mLayerVolFracIce(iLayer) + mLayerVolFracLiq(iLayer) else ! snow layer = volume expansion allowed iSoil = integerMissing @@ -184,14 +184,14 @@ subroutine check_icond(nGRU, & ! number of GRUs and HRU ! ***** snow case(iname_snow) ! (check liquid water) - if(mLayerVolFracLiq(iLayer) < 0._dp)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with volumetric fraction of liquid water < 0: layer = ',iLayer; err=20; return; end if - if(mLayerVolFracLiq(iLayer) > 1._dp)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with volumetric fraction of liquid water > 1: layer = ',iLayer; err=20; return; end if + if(mLayerVolFracLiq(iLayer) < 0._rkind)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with volumetric fraction of liquid water < 0: layer = ',iLayer; err=20; return; end if + if(mLayerVolFracLiq(iLayer) > 1._rkind)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with volumetric fraction of liquid water > 1: layer = ',iLayer; err=20; return; end if ! (check ice) - if(mLayerVolFracIce(iLayer) > 0.80_dp)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with volumetric fraction of ice > 0.80: layer = ',iLayer; err=20; return; end if - if(mLayerVolFracIce(iLayer) < 0.05_dp)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with volumetric fraction of ice < 0.05: layer = ',iLayer; err=20; return; end if + if(mLayerVolFracIce(iLayer) > 0.80_rkind)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with volumetric fraction of ice > 0.80: layer = ',iLayer; err=20; return; end if + if(mLayerVolFracIce(iLayer) < 0.05_rkind)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with volumetric fraction of ice < 0.05: layer = ',iLayer; err=20; return; end if ! check total water - if(scalarTheta > 0.80_dp)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with total water fraction [liquid + ice] > 0.80: layer = ',iLayer; err=20; return; end if - if(scalarTheta < 0.05_dp)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with total water fraction [liquid + ice] < 0.05: layer = ',iLayer; err=20; return; end if + if(scalarTheta > 0.80_rkind)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with total water fraction [liquid + ice] > 0.80: layer = ',iLayer; err=20; return; end if + if(scalarTheta < 0.05_rkind)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with total water fraction [liquid + ice] < 0.05: layer = ',iLayer; err=20; return; end if ! ***** soil case(iname_soil) @@ -200,7 +200,7 @@ subroutine check_icond(nGRU, & ! number of GRUs and HRU if(mLayerVolFracLiq(iLayer) < theta_res(iSoil)-xTol)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with volumetric fraction of liquid water < theta_res: layer = ',iLayer; err=20; return; end if if(mLayerVolFracLiq(iLayer) > theta_sat(iSoil)+xTol)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with volumetric fraction of liquid water > theta_sat: layer = ',iLayer; err=20; return; end if ! (check ice) - if(mLayerVolFracIce(iLayer) < 0._dp )then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with volumetric fraction of ice < 0: layer = ' ,iLayer; err=20; return; end if + if(mLayerVolFracIce(iLayer) < 0._rkind )then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with volumetric fraction of ice < 0: layer = ' ,iLayer; err=20; return; end if if(mLayerVolFracIce(iLayer) > theta_sat(iSoil)+xTol)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with volumetric fraction of ice > theta_sat: layer = ',iLayer; err=20; return; end if ! check total water if(scalarTheta < theta_res(iSoil)-xTol)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with total water fraction [liquid + ice] < theta_res: layer = ',iLayer; err=20; return; end if @@ -273,7 +273,7 @@ subroutine check_icond(nGRU, & ! number of GRUs and HRU do iLayer=1,nLayers h1 = sum(progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%mLayerDepth)%dat(1:iLayer)) ! sum of the depths up to the current layer h2 = progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%iLayerHeight)%dat(iLayer) - progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%iLayerHeight)%dat(0) ! difference between snow-atm interface and bottom of layer - if(abs(h1 - h2) > 1.e-6_dp)then + if(abs(h1 - h2) > 1.e-6_rkind)then write(message,'(a,1x,i0)') trim(message)//'mis-match between layer depth and layer height; layer = ', iLayer, '; sum depths = ',h1,'; height = ',h2 err=20; return end if diff --git a/build/source/engine/computFlux.f90 b/build/source/engine/computFlux.f90 index 7a900c96f..bf683a2ee 100755 --- a/build/source/engine/computFlux.f90 +++ b/build/source/engine/computFlux.f90 @@ -164,18 +164,18 @@ subroutine computFlux(& logical(lgt),intent(in) :: firstSplitOper ! flag to indicate if we are processing the first flux call in a splitting operation logical(lgt),intent(in) :: computeVegFlux ! flag to indicate if computing fluxes over vegetation logical(lgt),intent(in) :: scalarSolution ! flag to denote if implementing the scalar solution - real(dp),intent(in) :: drainageMeltPond ! drainage from the surface melt pond (kg m-2 s-1) + real(rkind),intent(in) :: drainageMeltPond ! drainage from the surface melt pond (kg m-2 s-1) ! input: state variables - real(dp),intent(in) :: scalarCanairTempTrial ! trial value for temperature of the canopy air space (K) - real(dp),intent(in) :: scalarCanopyTempTrial ! trial value for temperature of the vegetation canopy (K) - real(dp),intent(in) :: mLayerTempTrial(:) ! trial value for temperature of each snow/soil layer (K) - real(dp),intent(in) :: mLayerMatricHeadLiqTrial(:) ! trial value for the liquid water matric potential (m) - real(dp),intent(in) :: scalarAquiferStorageTrial ! trial value of aquifer storage (m) + real(rkind),intent(in) :: scalarCanairTempTrial ! trial value for temperature of the canopy air space (K) + real(rkind),intent(in) :: scalarCanopyTempTrial ! trial value for temperature of the vegetation canopy (K) + real(rkind),intent(in) :: mLayerTempTrial(:) ! trial value for temperature of each snow/soil layer (K) + real(rkind),intent(in) :: mLayerMatricHeadLiqTrial(:) ! trial value for the liquid water matric potential (m) + real(rkind),intent(in) :: scalarAquiferStorageTrial ! trial value of aquifer storage (m) ! input: diagnostic variables - real(dp),intent(in) :: scalarCanopyLiqTrial ! trial value for mass of liquid water on the vegetation canopy (kg m-2) - real(dp),intent(in) :: scalarCanopyIceTrial ! trial value for mass of ice on the vegetation canopy (kg m-2) - real(dp),intent(in) :: mLayerVolFracLiqTrial(:) ! trial value for volumetric fraction of liquid water (-) - real(dp),intent(in) :: mLayerVolFracIceTrial(:) ! trial value for volumetric fraction of ice (-) + real(rkind),intent(in) :: scalarCanopyLiqTrial ! trial value for mass of liquid water on the vegetation canopy (kg m-2) + real(rkind),intent(in) :: scalarCanopyIceTrial ! trial value for mass of ice on the vegetation canopy (kg m-2) + real(rkind),intent(in) :: mLayerVolFracLiqTrial(:) ! trial value for volumetric fraction of liquid water (-) + real(rkind),intent(in) :: mLayerVolFracIceTrial(:) ! trial value for volumetric fraction of ice (-) ! input: data structures type(model_options),intent(in) :: model_decisions(:) ! model decisions type(var_i), intent(in) :: type_data ! type of vegetation and soil @@ -191,8 +191,8 @@ subroutine computFlux(& type(var_dlength),intent(inout) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables ! input-output: flux vector and baseflow derivatives integer(i4b),intent(inout) :: ixSaturation ! index of the lowest saturated layer (NOTE: only computed on the first iteration) - real(dp),intent(out) :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) - real(dp),intent(out) :: fluxVec(:) ! model flux vector (mixed units) + real(rkind),intent(out) :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) + real(rkind),intent(out) :: fluxVec(:) ! model flux vector (mixed units) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message @@ -202,7 +202,7 @@ subroutine computFlux(& integer(i4b) :: local_ixGroundwater ! local index for groundwater representation integer(i4b) :: iLayer ! index of model layers logical(lgt) :: doVegNrgFlux ! flag to compute the energy flux over vegetation - real(dp),dimension(nSoil) :: dHydCond_dMatric ! derivative in hydraulic conductivity w.r.t matric head (s-1) + real(rkind),dimension(nSoil) :: dHydCond_dMatric ! derivative in hydraulic conductivity w.r.t matric head (s-1) character(LEN=256) :: cmessage ! error message of downwind routine ! -------------------------------------------------------------- ! initialize error control @@ -385,8 +385,8 @@ subroutine computFlux(& ! initialize liquid water fluxes throughout the snow and soil domains ! NOTE: used in the energy routines, which is called before the hydrology routines if(firstFluxCall)then - if(nSnow > 0) iLayerLiqFluxSnow(0:nSnow) = 0._dp - iLayerLiqFluxSoil(0:nSoil) = 0._dp + if(nSnow > 0) iLayerLiqFluxSnow(0:nSnow) = 0._rkind + iLayerLiqFluxSoil(0:nSoil) = 0._rkind end if ! ***** @@ -686,13 +686,13 @@ subroutine computFlux(& if(nSnow==0) then ! * case of infiltration into soil if(scalarMaxInfilRate > scalarRainPlusMelt)then ! infiltration is not rate-limited - scalarSoilControl = (1._dp - scalarFrozenArea)*scalarInfilArea + scalarSoilControl = (1._rkind - scalarFrozenArea)*scalarInfilArea else - scalarSoilControl = 0._dp ! (scalarRainPlusMelt exceeds maximum infiltration rate + scalarSoilControl = 0._rkind ! (scalarRainPlusMelt exceeds maximum infiltration rate endif else ! * case of infiltration into snow - scalarSoilControl = 1._dp + scalarSoilControl = 1._rkind endif ! compute drainage from the soil zone (needed for mass balance checks) @@ -716,10 +716,10 @@ subroutine computFlux(& ! set baseflow fluxes to zero if the topmodel baseflow routine is not used if(local_ixGroundwater/=qbaseTopmodel)then ! (diagnostic variables in the data structures) - scalarExfiltration = 0._dp ! exfiltration from the soil profile (m s-1) - mLayerColumnOutflow(:) = 0._dp ! column outflow from each soil layer (m3 s-1) + scalarExfiltration = 0._rkind ! exfiltration from the soil profile (m s-1) + mLayerColumnOutflow(:) = 0._rkind ! column outflow from each soil layer (m3 s-1) ! (variables needed for the numerical solution) - mLayerBaseflow(:) = 0._dp ! baseflow from each soil layer (m s-1) + mLayerBaseflow(:) = 0._rkind ! baseflow from each soil layer (m s-1) ! topmodel-ish shallow groundwater else ! local_ixGroundwater==qbaseTopmodel @@ -801,10 +801,10 @@ subroutine computFlux(& ! if no aquifer, then fluxes are zero else - scalarAquiferTranspire = 0._dp ! transpiration loss from the aquifer (m s-1) - scalarAquiferRecharge = 0._dp ! recharge to the aquifer (m s-1) - scalarAquiferBaseflow = 0._dp ! total baseflow from the aquifer (m s-1) - dBaseflow_dAquifer = 0._dp ! change in baseflow flux w.r.t. aquifer storage (s-1) + scalarAquiferTranspire = 0._rkind ! transpiration loss from the aquifer (m s-1) + scalarAquiferRecharge = 0._rkind ! recharge to the aquifer (m s-1) + scalarAquiferBaseflow = 0._rkind ! total baseflow from the aquifer (m s-1) + dBaseflow_dAquifer = 0._rkind ! change in baseflow flux w.r.t. aquifer storage (s-1) end if ! no aquifer endif ! if computing aquifer fluxes @@ -872,15 +872,15 @@ subroutine soilCmpres(& ! input: integer(i4b),intent(in) :: ixRichards ! choice of option for Richards' equation integer(i4b),intent(in) :: ixBeg,ixEnd ! start and end indices defining desired layers - real(dp),intent(in) :: mLayerMatricHead(:) ! matric head at the start of the time step (m) - real(dp),intent(in) :: mLayerMatricHeadTrial(:) ! trial value for matric head (m) - real(dp),intent(in) :: mLayerVolFracLiqTrial(:) ! trial value for volumetric fraction of liquid water (-) - real(dp),intent(in) :: mLayerVolFracIceTrial(:) ! trial value for volumetric fraction of ice (-) - real(dp),intent(in) :: specificStorage ! specific storage coefficient (m-1) - real(dp),intent(in) :: theta_sat(:) ! soil porosity (-) + real(rkind),intent(in) :: mLayerMatricHead(:) ! matric head at the start of the time step (m) + real(rkind),intent(in) :: mLayerMatricHeadTrial(:) ! trial value for matric head (m) + real(rkind),intent(in) :: mLayerVolFracLiqTrial(:) ! trial value for volumetric fraction of liquid water (-) + real(rkind),intent(in) :: mLayerVolFracIceTrial(:) ! trial value for volumetric fraction of ice (-) + real(rkind),intent(in) :: specificStorage ! specific storage coefficient (m-1) + real(rkind),intent(in) :: theta_sat(:) ! soil porosity (-) ! output: - real(dp),intent(inout) :: compress(:) ! soil compressibility (-) - real(dp),intent(inout) :: dCompress_dPsi(:) ! derivative in soil compressibility w.r.t. matric head (m-1) + real(rkind),intent(inout) :: compress(:) ! soil compressibility (-) + real(rkind),intent(inout) :: dCompress_dPsi(:) ! derivative in soil compressibility w.r.t. matric head (m-1) integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! local variables @@ -899,8 +899,8 @@ subroutine soilCmpres(& endif end do else - compress(:) = 0._dp - dCompress_dPsi(:) = 0._dp + compress(:) = 0._rkind + dCompress_dPsi(:) = 0._rkind end if end subroutine soilCmpres diff --git a/build/source/engine/computJacob.f90 b/build/source/engine/computJacob.f90 index 147f320c1..017a77a96 100755 --- a/build/source/engine/computJacob.f90 +++ b/build/source/engine/computJacob.f90 @@ -74,7 +74,7 @@ module computJacob_module implicit none ! define constants -real(dp),parameter :: verySmall=tiny(1.0_dp) ! a very small number +real(rkind),parameter :: verySmall=tiny(1.0_rkind) ! a very small number integer(i4b),parameter :: ixBandOffset=kl+ku+1 ! offset in the band Jacobian matrix private @@ -107,7 +107,7 @@ subroutine computJacob(& ! ----------------------------------------------------------------------------------------------------------------- implicit none ! input: model control - real(dp),intent(in) :: dt ! length of the time step (seconds) + real(rkind),intent(in) :: dt ! length of the time step (seconds) integer(i4b),intent(in) :: nSnow ! number of snow layers integer(i4b),intent(in) :: nSoil ! number of soil layers integer(i4b),intent(in) :: nLayers ! total number of layers in the snow+soil domain @@ -119,10 +119,10 @@ subroutine computJacob(& type(var_dlength),intent(in) :: prog_data ! prognostic variables for a local HRU type(var_dlength),intent(in) :: diag_data ! diagnostic variables for a local HRU type(var_dlength),intent(in) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables - real(dp),intent(in) :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) + real(rkind),intent(in) :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) ! input-output: Jacobian and its diagonal - real(dp),intent(inout) :: dMat(:) ! diagonal of the Jacobian matrix - real(dp),intent(out) :: aJac(:,:) ! Jacobian matrix + real(rkind),intent(inout) :: dMat(:) ! diagonal of the Jacobian matrix + real(rkind),intent(out) :: aJac(:,:) ! Jacobian matrix ! output variables integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message @@ -140,7 +140,7 @@ subroutine computJacob(& integer(i4b) :: jLayer ! index of model layer within the full state vector (hydrology) integer(i4b) :: pLayer ! indices of soil layers (used for the baseflow derivatives) ! conversion factors - real(dp) :: convLiq2tot ! factor to convert liquid water derivative to total water derivative + real(rkind) :: convLiq2tot ! factor to convert liquid water derivative to total water derivative ! -------------------------------------------------------------- ! associate variables from data structures associate(& @@ -244,7 +244,7 @@ subroutine computJacob(& ! initialize the Jacobian ! NOTE: this needs to be done every time, since Jacobian matrix is modified in the solver - aJac(:,:) = 0._dp ! analytical Jacobian matrix + aJac(:,:) = 0._rkind ! analytical Jacobian matrix ! compute terms in the Jacobian for vegetation (excluding fluxes) ! NOTE: energy for vegetation is computed *within* the iteration loop as it includes phase change @@ -285,7 +285,7 @@ subroutine computJacob(& ! * diagonal elements for the vegetation canopy (-) if(ixCasNrg/=integerMissing) aJac(ixDiag,ixCasNrg) = (dt/canopyDepth)*(-dCanairNetFlux_dCanairTemp) + dMat(ixCasNrg) if(ixVegNrg/=integerMissing) aJac(ixDiag,ixVegNrg) = (dt/canopyDepth)*(-dCanopyNetFlux_dCanopyTemp) + dMat(ixVegNrg) - if(ixVegHyd/=integerMissing) aJac(ixDiag,ixVegHyd) = -scalarFracLiqVeg*(dCanopyEvaporation_dCanLiq - scalarCanopyLiqDeriv)*dt + 1._dp ! ixVegHyd: CORRECT + if(ixVegHyd/=integerMissing) aJac(ixDiag,ixVegHyd) = -scalarFracLiqVeg*(dCanopyEvaporation_dCanLiq - scalarCanopyLiqDeriv)*dt + 1._rkind ! ixVegHyd: CORRECT ! * cross-derivative terms w.r.t. canopy water if(ixVegHyd/=integerMissing)then @@ -297,7 +297,7 @@ subroutine computJacob(& if(ixTopHyd/=integerMissing) aJac(ixOffDiag(ixTopHyd,ixVegHyd),ixVegHyd) = (dt/mLayerDepth(1))*(-scalarSoilControl*scalarFracLiqVeg*scalarCanopyLiqDeriv)/iden_water ! cross-derivative terms w.r.t. canopy liquid water (J m-1 kg-1) ! NOTE: dIce/dLiq = (1 - scalarFracLiqVeg); dIce*LH_fus/canopyDepth = J m-3; dLiq = kg m-2 - if(ixVegNrg/=integerMissing) aJac(ixOffDiag(ixVegNrg,ixVegHyd),ixVegHyd) = (dt/canopyDepth) *(-dCanopyNetFlux_dCanLiq) - (1._dp - scalarFracLiqVeg)*LH_fus/canopyDepth ! dF/dLiq + if(ixVegNrg/=integerMissing) aJac(ixOffDiag(ixVegNrg,ixVegHyd),ixVegHyd) = (dt/canopyDepth) *(-dCanopyNetFlux_dCanLiq) - (1._rkind - scalarFracLiqVeg)*LH_fus/canopyDepth ! dF/dLiq if(ixTopNrg/=integerMissing) aJac(ixOffDiag(ixTopNrg,ixVegHyd),ixVegHyd) = (dt/mLayerDepth(1))*(-dGroundNetFlux_dCanLiq) endif @@ -369,7 +369,7 @@ subroutine computJacob(& ! compute factor to convert liquid water derivative to total water derivative select case( ixHydType(iLayer) ) case(iname_watLayer); convLiq2tot = mLayerFracLiqSnow(iLayer) - case default; convLiq2tot = 1._dp + case default; convLiq2tot = 1._rkind end select ! - diagonal elements @@ -377,7 +377,7 @@ subroutine computJacob(& ! - lower-diagonal elements if(iLayer > 1)then - if(ixSnowOnlyHyd(iLayer-1)/=integerMissing) aJac(ixOffDiag(ixSnowOnlyHyd(iLayer-1),watState),watState) = 0._dp ! sub-diagonal: no dependence on other layers + if(ixSnowOnlyHyd(iLayer-1)/=integerMissing) aJac(ixOffDiag(ixSnowOnlyHyd(iLayer-1),watState),watState) = 0._rkind ! sub-diagonal: no dependence on other layers endif ! - upper diagonal elements @@ -394,7 +394,7 @@ subroutine computJacob(& if(nrgstate/=integerMissing)then ! (energy state for the current layer is within the state subset) ! (cross-derivative terms for the current layer) - aJac(ixOffDiag(nrgState,watState),watState) = -(1._dp - mLayerFracLiqSnow(iLayer))*LH_fus*iden_water ! (dF/dLiq) + aJac(ixOffDiag(nrgState,watState),watState) = -(1._rkind - mLayerFracLiqSnow(iLayer))*LH_fus*iden_water ! (dF/dLiq) aJac(ixOffDiag(watState,nrgState),nrgState) = (dt/mLayerDepth(iLayer))*iLayerLiqFluxSnowDeriv(iLayer)*mLayerdTheta_dTk(iLayer) ! (dVol/dT) ! (cross-derivative terms for the layer below) @@ -483,7 +483,7 @@ subroutine computJacob(& if(mLayerdTheta_dTk(jLayer) > verySmall)then ! ice is present aJac(ixOffDiag(nrgState,watState),watState) = -dVolTot_dPsi0(iLayer)*LH_fus*iden_water ! dNrg/dMat (J m-3 m-1) -- dMat changes volumetric water, and hence ice content else - aJac(ixOffDiag(nrgState,watState),watState) = 0._dp + aJac(ixOffDiag(nrgState,watState),watState) = 0._rkind endif ! - compute lower diagonal elements @@ -529,7 +529,7 @@ subroutine computJacob(& if(computeVegFlux)then ! (derivatives only defined when vegetation protrudes over the surface) ! * liquid water fluxes for vegetation canopy (-) - if(ixVegHyd/=integerMissing) aJac(ixVegHyd,ixVegHyd) = -scalarFracLiqVeg*(dCanopyEvaporation_dCanLiq - scalarCanopyLiqDeriv)*dt + 1._dp + if(ixVegHyd/=integerMissing) aJac(ixVegHyd,ixVegHyd) = -scalarFracLiqVeg*(dCanopyEvaporation_dCanLiq - scalarCanopyLiqDeriv)*dt + 1._rkind ! * cross-derivative terms for canopy water if(ixVegHyd/=integerMissing)then @@ -541,7 +541,7 @@ subroutine computJacob(& if(ixTopHyd/=integerMissing) aJac(ixTopHyd,ixVegHyd) = (dt/mLayerDepth(1))*(-scalarSoilControl*scalarFracLiqVeg*scalarCanopyLiqDeriv)/iden_water ! cross-derivative terms w.r.t. canopy liquid water (J m-1 kg-1) ! NOTE: dIce/dLiq = (1 - scalarFracLiqVeg); dIce*LH_fus/canopyDepth = J m-3; dLiq = kg m-2 - if(ixVegNrg/=integerMissing) aJac(ixVegNrg,ixVegHyd) = (dt/canopyDepth) *(-dCanopyNetFlux_dCanLiq) - (1._dp - scalarFracLiqVeg)*LH_fus/canopyDepth ! dF/dLiq + if(ixVegNrg/=integerMissing) aJac(ixVegNrg,ixVegHyd) = (dt/canopyDepth) *(-dCanopyNetFlux_dCanLiq) - (1._rkind - scalarFracLiqVeg)*LH_fus/canopyDepth ! dF/dLiq if(ixTopNrg/=integerMissing) aJac(ixTopNrg,ixVegHyd) = (dt/mLayerDepth(1))*(-dGroundNetFlux_dCanLiq) endif @@ -615,7 +615,7 @@ subroutine computJacob(& ! compute factor to convert liquid water derivative to total water derivative select case( ixHydType(iLayer) ) case(iname_watLayer); convLiq2tot = mLayerFracLiqSnow(iLayer) - case default; convLiq2tot = 1._dp + case default; convLiq2tot = 1._rkind end select ! - diagonal elements @@ -623,7 +623,7 @@ subroutine computJacob(& ! - lower-diagonal elements if(iLayer > 1)then - if(ixSnowOnlyHyd(iLayer-1)/=integerMissing) aJac(ixSnowOnlyHyd(iLayer-1),watState) = 0._dp ! sub-diagonal: no dependence on other layers + if(ixSnowOnlyHyd(iLayer-1)/=integerMissing) aJac(ixSnowOnlyHyd(iLayer-1),watState) = 0._rkind ! sub-diagonal: no dependence on other layers endif ! - upper diagonal elements @@ -640,7 +640,7 @@ subroutine computJacob(& if(nrgstate/=integerMissing)then ! (energy state for the current layer is within the state subset) ! (cross-derivative terms for the current layer) - aJac(nrgState,watState) = -(1._dp - mLayerFracLiqSnow(iLayer))*LH_fus*iden_water ! (dF/dLiq) + aJac(nrgState,watState) = -(1._rkind - mLayerFracLiqSnow(iLayer))*LH_fus*iden_water ! (dF/dLiq) aJac(watState,nrgState) = (dt/mLayerDepth(iLayer))*iLayerLiqFluxSnowDeriv(iLayer)*mLayerdTheta_dTk(iLayer) ! (dVol/dT) ! (cross-derivative terms for the layer below) @@ -738,7 +738,7 @@ subroutine computJacob(& if(mLayerdTheta_dTk(jLayer) > verySmall)then ! ice is present aJac(nrgState,watState) = -dVolTot_dPsi0(iLayer)*LH_fus*iden_water ! dNrg/dMat (J m-3 m-1) -- dMat changes volumetric water, and hence ice content else - aJac(nrgState,watState) = 0._dp + aJac(nrgState,watState) = 0._rkind endif ! - compute lower diagonal elements diff --git a/build/source/engine/computResid.f90 b/build/source/engine/computResid.f90 index a7d04bce8..a5860f932 100755 --- a/build/source/engine/computResid.f90 +++ b/build/source/engine/computResid.f90 @@ -105,31 +105,31 @@ subroutine computResid(& ! -------------------------------------------------------------------------------------------------------------------------------- implicit none ! input: model control - real(dp),intent(in) :: dt ! length of the time step (seconds) + real(rkind),intent(in) :: dt ! length of the time step (seconds) integer(i4b),intent(in) :: nSnow ! number of snow layers integer(i4b),intent(in) :: nSoil ! number of soil layers integer(i4b),intent(in) :: nLayers ! total number of layers in the snow+soil domain ! input: flux vectors - real(qp),intent(in) :: sMul(:) ! NOTE: qp ! state vector multiplier (used in the residual calculations) - real(dp),intent(in) :: fVec(:) ! flux vector + real(rkind),intent(in) :: sMul(:) ! NOTE: qp ! state vector multiplier (used in the residual calculations) + real(rkind),intent(in) :: fVec(:) ! flux vector ! input: state variables (already disaggregated into scalars and vectors) - real(dp),intent(in) :: scalarCanairTempTrial ! trial value for temperature of the canopy air space (K) - real(dp),intent(in) :: scalarCanopyTempTrial ! trial value for temperature of the vegetation canopy (K) - real(dp),intent(in) :: scalarCanopyHydTrial ! trial value for canopy water (kg m-2), either liquid water content or total water content - real(dp),intent(in) :: mLayerTempTrial(:) ! trial value for temperature of each snow/soil layer (K) - real(dp),intent(in) :: mLayerVolFracHydTrial(:) ! trial vector of volumetric water content (-), either liquid water content or total water content - real(dp),intent(in) :: scalarAquiferStorageTrial ! trial value of aquifer storage (m) + real(rkind),intent(in) :: scalarCanairTempTrial ! trial value for temperature of the canopy air space (K) + real(rkind),intent(in) :: scalarCanopyTempTrial ! trial value for temperature of the vegetation canopy (K) + real(rkind),intent(in) :: scalarCanopyHydTrial ! trial value for canopy water (kg m-2), either liquid water content or total water content + real(rkind),intent(in) :: mLayerTempTrial(:) ! trial value for temperature of each snow/soil layer (K) + real(rkind),intent(in) :: mLayerVolFracHydTrial(:) ! trial vector of volumetric water content (-), either liquid water content or total water content + real(rkind),intent(in) :: scalarAquiferStorageTrial ! trial value of aquifer storage (m) ! input: diagnostic variables defining the liquid water and ice content (function of state variables) - real(dp),intent(in) :: scalarCanopyIceTrial ! trial value for mass of ice on the vegetation canopy (kg m-2) - real(dp),intent(in) :: mLayerVolFracIceTrial(:) ! trial value for volumetric fraction of ice (-) + real(rkind),intent(in) :: scalarCanopyIceTrial ! trial value for mass of ice on the vegetation canopy (kg m-2) + real(rkind),intent(in) :: mLayerVolFracIceTrial(:) ! trial value for volumetric fraction of ice (-) ! input: data structures type(var_dlength),intent(in) :: prog_data ! prognostic variables for a local HRU type(var_dlength),intent(in) :: diag_data ! diagnostic variables for a local HRU type(var_dlength),intent(in) :: flux_data ! model fluxes for a local HRU type(var_ilength),intent(in) :: indx_data ! indices defining model states and layers ! output - real(dp),intent(out) :: rAdd(:) ! additional (sink) terms on the RHS of the state equation - real(qp),intent(out) :: rVec(:) ! NOTE: qp ! residual vector + real(rkind),intent(out) :: rAdd(:) ! additional (sink) terms on the RHS of the state equation + real(rkind),intent(out) :: rVec(:) ! NOTE: qp ! residual vector integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! -------------------------------------------------------------------------------------------------------------------------------- @@ -137,8 +137,8 @@ subroutine computResid(& ! -------------------------------------------------------------------------------------------------------------------------------- integer(i4b) :: iLayer ! index of layer within the snow+soil domain integer(i4b),parameter :: ixVegVolume=1 ! index of the desired vegetation control volumne (currently only one veg layer) - real(dp) :: scalarCanopyHyd ! canopy water content (kg m-2), either liquid water content or total water content - real(dp),dimension(nLayers) :: mLayerVolFracHyd ! vector of volumetric water content (-), either liquid water content or total water content + real(rkind) :: scalarCanopyHyd ! canopy water content (kg m-2), either liquid water content or total water content + real(rkind),dimension(nLayers) :: mLayerVolFracHyd ! vector of volumetric water content (-), either liquid water content or total water content ! -------------------------------------------------------------------------------------------------------------------------------- ! -------------------------------------------------------------------------------------------------------------------------------- ! link to the necessary variables for the residual computations @@ -189,7 +189,7 @@ subroutine computResid(& ! ----------------------- ! intialize additional terms on the RHS as zero - rAdd(:) = 0._dp + rAdd(:) = 0._rkind ! compute energy associated with melt freeze for the vegetation canopy if(ixVegNrg/=integerMissing) rAdd(ixVegNrg) = rAdd(ixVegNrg) + LH_fus*(scalarCanopyIceTrial - scalarCanopyIce)/canopyDepth ! energy associated with melt/freeze (J m-3) diff --git a/build/source/engine/convE2Temp.f90 b/build/source/engine/convE2Temp.f90 index 81d07e77b..0408c3fca 100755 --- a/build/source/engine/convE2Temp.f90 +++ b/build/source/engine/convE2Temp.f90 @@ -41,8 +41,8 @@ module convE2Temp_module ! define the look-up table used to compute temperature based on enthalpy integer(i4b),parameter :: nlook=10001 ! number of elements in the lookup table -real(dp),dimension(nlook),public :: E_lookup ! enthalpy values (J kg-1) -real(dp),dimension(nlook),public :: T_lookup ! temperature values (K) +real(rkind),dimension(nlook),public :: E_lookup ! enthalpy values (J kg-1) +real(rkind),dimension(nlook),public :: T_lookup ! temperature values (K) contains @@ -59,29 +59,29 @@ subroutine E2T_lookup(mpar_data,err,message) character(*),intent(out) :: message ! error message ! declare local variables character(len=128) :: cmessage ! error message in downwind routine - real(dp),parameter :: T_start=260.0_dp ! start temperature value where all liquid water is assumed frozen (K) - real(dp) :: T_incr,E_incr ! temperature/enthalpy increments - real(dp),dimension(nlook) :: Tk ! initial temperature vector - real(dp),dimension(nlook) :: Ey ! initial enthalpy vector - real(dp),parameter :: waterWght=1._dp ! weight applied to total water (kg m-3) --- cancels out - real(dp),dimension(nlook) :: T2deriv ! 2nd derivatives of the interpolating function at tabulated points + real(rkind),parameter :: T_start=260.0_rkind ! start temperature value where all liquid water is assumed frozen (K) + real(rkind) :: T_incr,E_incr ! temperature/enthalpy increments + real(rkind),dimension(nlook) :: Tk ! initial temperature vector + real(rkind),dimension(nlook) :: Ey ! initial enthalpy vector + real(rkind),parameter :: waterWght=1._rkind ! weight applied to total water (kg m-3) --- cancels out + real(rkind),dimension(nlook) :: T2deriv ! 2nd derivatives of the interpolating function at tabulated points integer(i4b) :: ilook ! loop through lookup table ! initialize error control err=0; message="E2T_lookup/" ! associate associate( snowfrz_scale => mpar_data%var(iLookPARAM%snowfrz_scale)%dat(1) ) ! define initial temperature vector - T_incr = (Tfreeze - T_start) / real(nlook-1, kind(dp)) ! temperature increment + T_incr = (Tfreeze - T_start) / real(nlook-1, kind(rkind)) ! temperature increment Tk = arth(T_start,T_incr,nlook) ! ***** compute specific enthalpy (NOTE: J m-3 --> J kg-1) ***** do ilook=1,nlook Ey(ilook) = temp2ethpy(Tk(ilook),waterWght,snowfrz_scale)/waterWght ! (J m-3 --> J kg-1) end do ! define the final enthalpy vector - E_incr = (-Ey(1)) / real(nlook-1, kind(dp)) ! enthalpy increment + E_incr = (-Ey(1)) / real(nlook-1, kind(rkind)) ! enthalpy increment E_lookup = arth(Ey(1),E_incr,nlook) ! use cubic spline interpolation to obtain temperature values at the desired values of enthalpy - call spline(Ey,Tk,1.e30_dp,1.e30_dp,T2deriv,err,cmessage) ! get the second derivatives + call spline(Ey,Tk,1.e30_rkind,1.e30_rkind,T2deriv,err,cmessage) ! get the second derivatives if(err/=0) then; message=trim(message)//trim(cmessage); return; end if do ilook=1,nlook call splint(Ey,Tk,T2deriv,E_lookup(ilook),T_lookup(ilook),err,cmessage) @@ -99,25 +99,25 @@ subroutine E2T_nosoil(Ey,BulkDenWater,fc_param,Tk,err,message) ! compute temperature based on enthalpy -- appropriate when no dry mass, as in snow implicit none ! declare dummy variables - real(dp),intent(in) :: Ey ! total enthalpy (J m-3) - real(dp),intent(in) :: BulkDenWater ! bulk density of water (kg m-3) - real(dp),intent(in) :: fc_param ! freezing curve parameter (K-1) - real(dp),intent(out) :: Tk ! initial temperature guess / final temperature value (K) + real(rkind),intent(in) :: Ey ! total enthalpy (J m-3) + real(rkind),intent(in) :: BulkDenWater ! bulk density of water (kg m-3) + real(rkind),intent(in) :: fc_param ! freezing curve parameter (K-1) + real(rkind),intent(out) :: Tk ! initial temperature guess / final temperature value (K) integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! declare local variables - real(dp),parameter :: dx=1.d-8 ! finite difference increment (J kg-1) - real(dp),parameter :: atol=1.d-12 ! convergence criteria (J kg-1) - real(dp) :: E_spec ! specific enthalpy (J kg-1) - real(dp) :: E_incr ! enthalpy increment + real(rkind),parameter :: dx=1.d-8 ! finite difference increment (J kg-1) + real(rkind),parameter :: atol=1.d-12 ! convergence criteria (J kg-1) + real(rkind) :: E_spec ! specific enthalpy (J kg-1) + real(rkind) :: E_incr ! enthalpy increment integer(i4b) :: niter=15 ! maximum number of iterations integer(i4b) :: iter ! iteration index integer(i4b) :: i0 ! position in lookup table - real(dp) :: Tg0,Tg1 ! trial temperatures (K) - real(dp) :: Ht0,Ht1 ! specific enthalpy, based on the trial temperatures (J kg-1) - real(dp) :: f0,f1 ! function evaluations (difference between enthalpy guesses) - real(dp) :: dh ! enthalpy derivative - real(dp) :: dT ! temperature increment + real(rkind) :: Tg0,Tg1 ! trial temperatures (K) + real(rkind) :: Ht0,Ht1 ! specific enthalpy, based on the trial temperatures (J kg-1) + real(rkind) :: f0,f1 ! function evaluations (difference between enthalpy guesses) + real(rkind) :: dh ! enthalpy derivative + real(rkind) :: dT ! temperature increment ! initialize error control err=0; message="E2T_nosoil/" ! convert input of total enthalpy (J m-3) to total specific enthalpy (J kg-1) @@ -130,8 +130,8 @@ subroutine E2T_nosoil(Ey,BulkDenWater,fc_param,Tk,err,message) Tg0 = (E_spec - E_lookup(1))/Cp_ice + T_lookup(1) Tg1 = Tg0+dx ! compute enthalpy - Ht0 = temp2ethpy(Tg0,1._dp,fc_param) - Ht1 = temp2ethpy(Tg1,1._dp,fc_param) + Ht0 = temp2ethpy(Tg0,1._rkind,fc_param) + Ht1 = temp2ethpy(Tg1,1._rkind,fc_param) ! compute function evaluations f0 = Ht0 - E_spec f1 = Ht1 - E_spec @@ -171,7 +171,7 @@ subroutine E2T_nosoil(Ey,BulkDenWater,fc_param,Tk,err,message) ! comute new value of Tg Tg1 = Tg0+dT ! get new function evaluation - Ht1 = temp2ethpy(Tg1,1._dp,fc_param) + Ht1 = temp2ethpy(Tg1,1._rkind,fc_param) f1 = Ht1 - E_spec ! compute derivative if dT dh = (f1 - f0)/dT @@ -201,17 +201,17 @@ function temp2ethpy(Tk,BulkDenWater,fc_param) ! NOTE: enthalpy is a relative value, defined as zero at Tfreeze where all water is liquid implicit none ! declare dummy variables - real(dp),intent(in) :: Tk ! layer temperature (K) - real(dp),intent(in) :: BulkDenWater ! bulk density of water (kg m-3) - real(dp),intent(in) :: fc_param ! freezing curve parameter (K-1) - real(dp) :: temp2ethpy ! return value of the function, total specific enthalpy (J m-3) + real(rkind),intent(in) :: Tk ! layer temperature (K) + real(rkind),intent(in) :: BulkDenWater ! bulk density of water (kg m-3) + real(rkind),intent(in) :: fc_param ! freezing curve parameter (K-1) + real(rkind) :: temp2ethpy ! return value of the function, total specific enthalpy (J m-3) ! declare local variables - real(dp) :: frac_liq ! fraction of liquid water - real(dp) :: enthTempWater ! temperature component of specific enthalpy for total water (liquid and ice) (J kg-1) - real(dp) :: enthMass ! mass component of specific enthalpy (J kg-1) + real(rkind) :: frac_liq ! fraction of liquid water + real(rkind) :: enthTempWater ! temperature component of specific enthalpy for total water (liquid and ice) (J kg-1) + real(rkind) :: enthMass ! mass component of specific enthalpy (J kg-1) ! NOTE: this function assumes the freezing curve for snow ... it needs modification to use vanGenuchten functions for soil ! compute the fraction of liquid water in the given layer - frac_liq = 1._dp / ( 1._dp + ( fc_param*( Tfreeze - min(Tk,Tfreeze) ) )**2._dp ) + frac_liq = 1._rkind / ( 1._rkind + ( fc_param*( Tfreeze - min(Tk,Tfreeze) ) )**2._rkind ) ! compute the temperature component of enthalpy for the soil constituent (J kg-1) !enthTempSoil = Cp_soil*(Tk - Tfreeze) ! compute the temperature component of enthalpy for total water (J kg-1) @@ -220,7 +220,7 @@ function temp2ethpy(Tk,BulkDenWater,fc_param) if(Tk>=Tfreeze) enthTempWater = Cp_water*(Tk - Tfreeze) ! compute the mass component of enthalpy -- energy required to melt ice (J kg-1) ! NOTE: negative enthalpy means require energy to bring to Tfreeze - enthMass = -LH_fus*(1._dp - frac_liq) + enthMass = -LH_fus*(1._rkind - frac_liq) ! finally, compute the total enthalpy (J m-3) ! NOTE: this is the case for snow (no soil).. function needs modification to use vanGenuchten functions for soil temp2ethpy = BulkDenWater*(enthTempWater + enthMass) !+ BulkDenSoil*enthTempSoil diff --git a/build/source/engine/conv_funcs.f90 b/build/source/engine/conv_funcs.f90 index 291938630..71b8d73ce 100755 --- a/build/source/engine/conv_funcs.f90 +++ b/build/source/engine/conv_funcs.f90 @@ -36,8 +36,8 @@ module conv_funcs_module ! *************************************************************************************************************** function getLatentHeatValue(T) implicit none -real(dp),intent(in) :: T ! temperature (K) -real(dp) :: getLatentHeatValue ! latent heat of sublimation/vaporization (J kg-1) +real(rkind),intent(in) :: T ! temperature (K) +real(rkind) :: getLatentHeatValue ! latent heat of sublimation/vaporization (J kg-1) if(T > Tfreeze)then getLatentHeatValue = LH_vap ! latent heat of vaporization (J kg-1) else @@ -52,14 +52,14 @@ end function getLatentHeatValue function vapPress(q,p) implicit none ! input -real(dp),intent(in) :: q ! specific humidity (g g-1) -real(dp),intent(in) :: p ! pressure (Pa) +real(rkind),intent(in) :: q ! specific humidity (g g-1) +real(rkind),intent(in) :: p ! pressure (Pa) ! output -real(dp) :: vapPress ! vapor pressure (Pa) +real(rkind) :: vapPress ! vapor pressure (Pa) ! local -real(dp) :: w ! mixing ratio -!real(dp),parameter :: w_ratio = 0.622_dp ! molecular weight ratio of water to dry air (-) -w = q / (1._dp - q) ! mixing ratio (-) +real(rkind) :: w ! mixing ratio +!real(rkind),parameter :: w_ratio = 0.622_rkind ! molecular weight ratio of water to dry air (-) +w = q / (1._rkind - q) ! mixing ratio (-) vapPress = (w/(w + w_ratio))*p ! vapor pressure (Pa) end function vapPress @@ -72,22 +72,22 @@ end function vapPress subroutine satVapPress(TC, SVP, dSVP_dT) IMPLICIT NONE ! input -real(dp), intent(in) :: TC ! temperature (C) +real(rkind), intent(in) :: TC ! temperature (C) ! output -real(dp), intent(out) :: SVP ! saturation vapor pressure (Pa) -real(dp), intent(out) :: dSVP_dT ! d(SVP)/dT +real(rkind), intent(out) :: SVP ! saturation vapor pressure (Pa) +real(rkind), intent(out) :: dSVP_dT ! d(SVP)/dT ! local -real(dp), parameter :: X1 = 17.27_dp -real(dp), parameter :: X2 = 237.30_dp +real(rkind), parameter :: X1 = 17.27_rkind +real(rkind), parameter :: X2 = 237.30_rkind ! local (use to test derivative calculations) -real(dp),parameter :: dx = 1.e-8_dp ! finite difference increment +real(rkind),parameter :: dx = 1.e-8_rkind ! finite difference increment logical(lgt),parameter :: testDeriv=.false. ! flag to test the derivative !--------------------------------------------------------------------------------------------------- ! Units note : Pa = N m-2 = kg m-1 s-2 ! SATVPFRZ= 610.8 ! Saturation water vapour pressure at 273.16K (Pa) SVP = SATVPFRZ * EXP( (X1*TC)/(X2 + TC) ) ! Saturated Vapour Press (Pa) -dSVP_dT = SVP * (X1/(X2 + TC) - X1*TC/(X2 + TC)**2._dp) +dSVP_dT = SVP * (X1/(X2 + TC) - X1*TC/(X2 + TC)**2._rkind) if(testDeriv) print*, 'dSVP_dT check... ', SVP, dSVP_dT, (SATVPRESS(TC+dx) - SVP)/dx END SUBROUTINE satVapPress @@ -104,10 +104,10 @@ END SUBROUTINE satVapPress FUNCTION MSLP2AIRP(MSLP, ELEV) IMPLICIT NONE -REAL(DP), INTENT(IN) :: MSLP ! base pressure (Pa) -REAL(DP), INTENT(IN) :: ELEV ! elevation difference from base (m) +real(rkind), INTENT(IN) :: MSLP ! base pressure (Pa) +real(rkind), INTENT(IN) :: ELEV ! elevation difference from base (m) -REAL(DP) :: MSLP2AIRP ! Air pressure (Pa) +real(rkind) :: MSLP2AIRP ! Air pressure (Pa) MSLP2AIRP = MSLP * ( (293.-0.0065*ELEV) / 293. )**5.256 @@ -126,14 +126,14 @@ FUNCTION RLHUM2DEWPT(T, RLHUM) ! Compute Dewpoint temperature from Relative Humidity IMPLICIT NONE -REAL(DP), INTENT(IN) :: T ! Temperature (K) -REAL(DP), INTENT(IN) :: RLHUM ! Relative Humidity (%) +real(rkind), INTENT(IN) :: T ! Temperature (K) +real(rkind), INTENT(IN) :: RLHUM ! Relative Humidity (%) -REAL(DP) :: RLHUM2DEWPT ! Dewpoint Temp (K) +real(rkind) :: RLHUM2DEWPT ! Dewpoint Temp (K) -REAL(DP) :: VPSAT ! Sat. vapour pressure at T (Pa) -REAL(DP) :: TDCEL ! Dewpoint temp Celcius (C) +real(rkind) :: VPSAT ! Sat. vapour pressure at T (Pa) +real(rkind) :: TDCEL ! Dewpoint temp Celcius (C) ! Units note : Pa = N m-2 = kg m-1 s-2 ! SATVPFRZ= 610.8 ! Saturation water vapour pressure at 273.16K (Pa) @@ -158,13 +158,13 @@ END FUNCTION RLHUM2DEWPT FUNCTION DEWPT2RLHUM(T, DEWPT) IMPLICIT NONE -REAL(DP), INTENT(IN) :: T ! Temperature (K) -REAL(DP), INTENT(IN) :: DEWPT ! Dewpoint temp (K) +real(rkind), INTENT(IN) :: T ! Temperature (K) +real(rkind), INTENT(IN) :: DEWPT ! Dewpoint temp (K) -REAL(DP) :: DEWPT2RLHUM ! Relative Humidity (%) +real(rkind) :: DEWPT2RLHUM ! Relative Humidity (%) -REAL(DP) :: VPSAT ! Sat. vapour pressure at T (Pa) -REAL(DP) :: TDCEL ! Dewpt in celcius (C) +real(rkind) :: VPSAT ! Sat. vapour pressure at T (Pa) +real(rkind) :: TDCEL ! Dewpt in celcius (C) ! Units note : Pa = N m-2 = kg m-1 s-2 ! SATVPFRZ= 610.8 ! Saturation water vapour pressure at 273.16K (Pa) @@ -188,13 +188,13 @@ END FUNCTION DEWPT2RLHUM FUNCTION DEWPT2SPHM(DEWPT, PRESS) IMPLICIT NONE -REAL(DP), INTENT(IN) :: DEWPT ! Dewpoint temp (K) -REAL(DP), INTENT(IN) :: PRESS ! Pressure (Pa) +real(rkind), INTENT(IN) :: DEWPT ! Dewpoint temp (K) +real(rkind), INTENT(IN) :: PRESS ! Pressure (Pa) -REAL(DP) :: DEWPT2SPHM ! Specific Humidity (g/g) +real(rkind) :: DEWPT2SPHM ! Specific Humidity (g/g) -REAL(DP) :: VPAIR ! vapour pressure at T (Pa) -REAL(DP) :: TDCEL ! Dewpt in celcius (C) +real(rkind) :: VPAIR ! vapour pressure at T (Pa) +real(rkind) :: TDCEL ! Dewpt in celcius (C) ! Units note : Pa = N m-2 = kg m-1 s-2 ! SATVPFRZ= 610.8 ! Saturation water vapour pressure at 273.16K (Pa) @@ -218,10 +218,10 @@ END FUNCTION DEWPT2SPHM FUNCTION DEWPT2VPAIR(DEWPT) IMPLICIT NONE -REAL(DP), INTENT(IN) :: DEWPT ! Dewpoint temp (K) -REAL(DP) :: TDCEL ! Dewpt in celcius (C) +real(rkind), INTENT(IN) :: DEWPT ! Dewpoint temp (K) +real(rkind) :: TDCEL ! Dewpt in celcius (C) -REAL(DP) :: DEWPT2VPAIR ! Vapour Press (Pa) +real(rkind) :: DEWPT2VPAIR ! Vapour Press (Pa) ! Units note : Pa = N m-2 = kg m-1 s-2 ! SATVPFRZ= 610.8 ! Saturation water vapour pressure at 273.16K (Pa) @@ -243,15 +243,15 @@ END FUNCTION DEWPT2VPAIR FUNCTION SPHM2RELHM(SPHM, PRESS, TAIR) IMPLICIT NONE -REAL(DP), INTENT(IN) :: SPHM ! Specific Humidity (g/g) -REAL(DP), INTENT(IN) :: PRESS ! Pressure (Pa) -REAL(DP), INTENT(IN) :: TAIR ! Air temp +real(rkind), INTENT(IN) :: SPHM ! Specific Humidity (g/g) +real(rkind), INTENT(IN) :: PRESS ! Pressure (Pa) +real(rkind), INTENT(IN) :: TAIR ! Air temp -REAL(DP) :: SPHM2RELHM ! Dewpoint Temp (K) +real(rkind) :: SPHM2RELHM ! Dewpoint Temp (K) -REAL(DP) :: VPSAT ! vapour pressure at T (Pa) -REAL(DP) :: TDCEL ! Dewpt in celcius (C) -!REAL(DP) :: DUM ! Intermediate +real(rkind) :: VPSAT ! vapour pressure at T (Pa) +real(rkind) :: TDCEL ! Dewpt in celcius (C) +!real(rkind) :: DUM ! Intermediate ! Units note : Pa = N m-2 = kg m-1 s-2 ! SATVPFRZ= 610.8 ! Saturation water vapour pressure at 273.16K (Pa) @@ -274,15 +274,15 @@ END FUNCTION SPHM2RELHM FUNCTION RELHM2SPHM(RELHM, PRESS, TAIR) IMPLICIT NONE -REAL(DP), INTENT(IN) :: RELHM ! Relative Humidity (%) -REAL(DP), INTENT(IN) :: PRESS ! Pressure (Pa) -REAL(DP), INTENT(IN) :: TAIR ! Air temp +real(rkind), INTENT(IN) :: RELHM ! Relative Humidity (%) +real(rkind), INTENT(IN) :: PRESS ! Pressure (Pa) +real(rkind), INTENT(IN) :: TAIR ! Air temp -REAL(DP) :: RELHM2SPHM ! Specific Humidity (g/g) +real(rkind) :: RELHM2SPHM ! Specific Humidity (g/g) -REAL(DP) :: PVP ! Partial vapour pressure at T (Pa) -REAL(DP) :: TDCEL ! Dewpt in celcius (C) -!REAL(DP) :: DUM ! Intermediate +real(rkind) :: PVP ! Partial vapour pressure at T (Pa) +real(rkind) :: TDCEL ! Dewpt in celcius (C) +!real(rkind) :: DUM ! Intermediate ! Units note : Pa = N m-2 = kg m-1 s-2 ! SATVPFRZ= 610.8 ! Saturation water vapour pressure at 273.16K (Pa) @@ -300,31 +300,31 @@ END FUNCTION RELHM2SPHM FUNCTION WETBULBTMP(TAIR, RELHM, PRESS) IMPLICIT NONE ! input -REAL(DP), INTENT(IN) :: TAIR ! Air temp (K) -REAL(DP), INTENT(IN) :: RELHM ! Relative Humidity (-) -REAL(DP), INTENT(IN) :: PRESS ! Pressure (Pa) +real(rkind), INTENT(IN) :: TAIR ! Air temp (K) +real(rkind), INTENT(IN) :: RELHM ! Relative Humidity (-) +real(rkind), INTENT(IN) :: PRESS ! Pressure (Pa) ! output -REAL(DP) :: WETBULBTMP ! Wet bulb temperature (K) +real(rkind) :: WETBULBTMP ! Wet bulb temperature (K) ! locals -REAL(DP) :: Tcel ! Temperature in celcius (C) -REAL(DP) :: PVP ! Partial vapor pressure (Pa) -REAL(DP) :: TWcel ! Wet bulb temperature in celcius (C) -REAL(DP),PARAMETER :: k=6.54E-4_DP ! normalizing factor in wet bulb estimate (C-1) -REAL(DP) :: Twet_trial0 ! trial value for wet bulb temperature (C) -REAL(DP) :: Twet_trial1 ! trial value for wet bulb temperature (C) -REAL(DP) :: f0,f1 ! function evaluations (C) -REAL(DP) :: df_dT ! derivative (-) -REAL(DP) :: TWinc ! wet bulb temperature increment (C) +real(rkind) :: Tcel ! Temperature in celcius (C) +real(rkind) :: PVP ! Partial vapor pressure (Pa) +real(rkind) :: TWcel ! Wet bulb temperature in celcius (C) +real(rkind),PARAMETER :: k=6.54E-4_DP ! normalizing factor in wet bulb estimate (C-1) +real(rkind) :: Twet_trial0 ! trial value for wet bulb temperature (C) +real(rkind) :: Twet_trial1 ! trial value for wet bulb temperature (C) +real(rkind) :: f0,f1 ! function evaluations (C) +real(rkind) :: df_dT ! derivative (-) +real(rkind) :: TWinc ! wet bulb temperature increment (C) INTEGER(I4B) :: iter ! iterattion index -REAL(DP),PARAMETER :: Xoff=1.E-5_DP ! finite difference increment (C) -REAL(DP),PARAMETER :: Xtol=1.E-8_DP ! convergence tolerance (C) +real(rkind),PARAMETER :: Xoff=1.E-5_DP ! finite difference increment (C) +real(rkind),PARAMETER :: Xtol=1.E-8_DP ! convergence tolerance (C) INTEGER(I4B) :: maxiter=15 ! maximum number of iterations ! convert temperature to Celcius Tcel = TAIR-TFREEZE ! compute partial vapor pressure based on temperature (Pa) PVP = RELHM * SATVPRESS(Tcel) ! define an initial trial value for wetbulb temperature -TWcel = Tcel - 5._dp +TWcel = Tcel - 5._rkind ! iterate until convergence do iter=1,maxiter ! compute Twet estimates @@ -358,9 +358,9 @@ END FUNCTION WETBULBTMP ! *************************************************************************************************************** FUNCTION SATVPRESS(TCEL) IMPLICIT NONE -REAL(DP),INTENT(IN) :: TCEL ! Temperature (C) -REAL(DP) :: SATVPRESS ! Saturated vapor pressure (Pa) -SATVPRESS = SATVPFRZ * EXP( (17.27_dp*TCEL)/(237.30_dp + TCEL) ) ! Saturated Vapour Press (Pa) +real(rkind),INTENT(IN) :: TCEL ! Temperature (C) +real(rkind) :: SATVPRESS ! Saturated vapor pressure (Pa) +SATVPRESS = SATVPFRZ * EXP( (17.27_rkind*TCEL)/(237.30_rkind + TCEL) ) ! Saturated Vapour Press (Pa) END FUNCTION SATVPRESS diff --git a/build/source/engine/coupled_em.f90 b/build/source/engine/coupled_em.f90 index 88fd044da..1a45db4b9 100755 --- a/build/source/engine/coupled_em.f90 +++ b/build/source/engine/coupled_em.f90 @@ -89,10 +89,10 @@ module coupled_em_module private public::coupled_em ! algorithmic parameters -real(dp),parameter :: valueMissing=-9999._dp ! missing value, used when diagnostic or state variables are undefined -real(dp),parameter :: verySmall=1.e-6_dp ! used as an additive constant to check if substantial difference among real numbers -real(dp),parameter :: mpe=1.e-6_dp ! prevents overflow error if division by zero -real(dp),parameter :: dx=1.e-6_dp ! finite difference increment +real(rkind),parameter :: valueMissing=-9999._rkind ! missing value, used when diagnostic or state variables are undefined +real(rkind),parameter :: verySmall=1.e-6_rkind ! used as an additive constant to check if substantial difference among real numbers +real(rkind),parameter :: mpe=1.e-6_rkind ! prevents overflow error if division by zero +real(rkind),parameter :: dx=1.e-6_rkind ! finite difference increment contains @@ -148,7 +148,7 @@ subroutine coupled_em(& implicit none ! model control integer(8),intent(in) :: hruId ! hruId - real(dp),intent(inout) :: dt_init ! used to initialize the size of the sub-step + real(rkind),intent(inout) :: dt_init ! used to initialize the size of the sub-step logical(lgt),intent(inout) :: computeVegFlux ! flag to indicate if we are computing fluxes over vegetation (.false. means veg is buried with snow) ! data structures (input) type(var_i),intent(in) :: type_data ! type of vegetation and soil @@ -172,12 +172,12 @@ subroutine coupled_em(& integer(i4b) :: nSoil ! number of soil layers integer(i4b) :: nLayers ! total number of layers integer(i4b) :: nState ! total number of state variables - real(dp) :: dtSave ! length of last input model sub-step (seconds) - real(dp) :: dt_sub ! length of model sub-step (seconds) - real(dp) :: dt_wght ! weight applied to model sub-step (dt_sub/data_step) - real(dp) :: dt_solv ! seconds in the data step that have been completed - real(dp) :: dtMultiplier ! time step multiplier (-) based on what happenned in "opSplittin" - real(dp) :: minstep,maxstep ! minimum and maximum time step length (seconds) + real(rkind) :: dtSave ! length of last input model sub-step (seconds) + real(rkind) :: dt_sub ! length of model sub-step (seconds) + real(rkind) :: dt_wght ! weight applied to model sub-step (dt_sub/data_step) + real(rkind) :: dt_solv ! seconds in the data step that have been completed + real(rkind) :: dtMultiplier ! time step multiplier (-) based on what happenned in "opSplittin" + real(rkind) :: minstep,maxstep ! minimum and maximum time step length (seconds) integer(i4b) :: nsub ! number of substeps logical(lgt) :: computeVegFluxOld ! flag to indicate if we are computing fluxes over vegetation on the previous sub step logical(lgt) :: includeAquifer ! flag to denote that an aquifer is included @@ -185,16 +185,16 @@ subroutine coupled_em(& logical(lgt) :: modifiedVegState ! flag to denote that vegetation states were modified type(var_dlength) :: flux_mean ! timestep-average model fluxes for a local HRU integer(i4b) :: nLayersRoots ! number of soil layers that contain roots - real(dp) :: exposedVAI ! exposed vegetation area index - real(dp) :: dCanopyWetFraction_dWat ! derivative in wetted fraction w.r.t. canopy total water (kg-1 m2) - real(dp) :: dCanopyWetFraction_dT ! derivative in wetted fraction w.r.t. canopy temperature (K-1) - real(dp),parameter :: varNotUsed1=-9999._dp ! variables used to calculate derivatives (not needed here) - real(dp),parameter :: varNotUsed2=-9999._dp ! variables used to calculate derivatives (not needed here) + real(rkind) :: exposedVAI ! exposed vegetation area index + real(rkind) :: dCanopyWetFraction_dWat ! derivative in wetted fraction w.r.t. canopy total water (kg-1 m2) + real(rkind) :: dCanopyWetFraction_dT ! derivative in wetted fraction w.r.t. canopy temperature (K-1) + real(rkind),parameter :: varNotUsed1=-9999._rkind ! variables used to calculate derivatives (not needed here) + real(rkind),parameter :: varNotUsed2=-9999._rkind ! variables used to calculate derivatives (not needed here) integer(i4b) :: iSnow ! index of snow layers integer(i4b) :: iLayer ! index of model layers - real(dp) :: massLiquid ! mass liquid water (kg m-2) - real(dp) :: superflousSub ! superflous sublimation (kg m-2 s-1) - real(dp) :: superflousNrg ! superflous energy that cannot be used for sublimation (W m-2 [J m-2 s-1]) + real(rkind) :: massLiquid ! mass liquid water (kg m-2) + real(rkind) :: superflousSub ! superflous sublimation (kg m-2 s-1) + real(rkind) :: superflousNrg ! superflous energy that cannot be used for sublimation (W m-2 [J m-2 s-1]) integer(i4b) :: ixSolution ! solution method used by opSplitting logical(lgt) :: firstSubStep ! flag to denote if the first time step logical(lgt) :: stepFailure ! flag to denote the need to reduce length of the coupled step and try again @@ -206,34 +206,34 @@ subroutine coupled_em(& type(var_dlength) :: prog_temp ! temporary model prognostic variables type(var_dlength) :: diag_temp ! temporary model diagnostic variables ! check SWE - real(dp) :: oldSWE ! SWE at the start of the substep - real(dp) :: newSWE ! SWE at the end of the substep - real(dp) :: delSWE ! change in SWE over the subtep - real(dp) :: effRainfall ! effective rainfall (kg m-2 s-1) - real(dp) :: effSnowfall ! effective snowfall (kg m-2 s-1) - real(dp) :: sfcMeltPond ! surface melt pond (kg m-2) - real(dp) :: massBalance ! mass balance error (kg m-2) + real(rkind) :: oldSWE ! SWE at the start of the substep + real(rkind) :: newSWE ! SWE at the end of the substep + real(rkind) :: delSWE ! change in SWE over the subtep + real(rkind) :: effRainfall ! effective rainfall (kg m-2 s-1) + real(rkind) :: effSnowfall ! effective snowfall (kg m-2 s-1) + real(rkind) :: sfcMeltPond ! surface melt pond (kg m-2) + real(rkind) :: massBalance ! mass balance error (kg m-2) ! balance checks integer(i4b) :: iVar ! loop through model variables - real(dp) :: totalSoilCompress ! total soil compression (kg m-2) - real(dp) :: scalarCanopyWatBalError ! water balance error for the vegetation canopy (kg m-2) - real(dp) :: scalarSoilWatBalError ! water balance error (kg m-2) - real(dp) :: scalarInitCanopyLiq ! initial liquid water on the vegetation canopy (kg m-2) - real(dp) :: scalarInitCanopyIce ! initial ice on the vegetation canopy (kg m-2) - real(dp) :: balanceCanopyWater0 ! total water stored in the vegetation canopy at the start of the step (kg m-2) - real(dp) :: balanceCanopyWater1 ! total water stored in the vegetation canopy at the end of the step (kg m-2) - real(dp) :: balanceSoilWater0 ! total soil storage at the start of the step (kg m-2) - real(dp) :: balanceSoilWater1 ! total soil storage at the end of the step (kg m-2) - real(dp) :: balanceSoilInflux ! input to the soil zone - real(dp) :: balanceSoilBaseflow ! output from the soil zone - real(dp) :: balanceSoilDrainage ! output from the soil zone - real(dp) :: balanceSoilET ! output from the soil zone - real(dp) :: balanceAquifer0 ! total aquifer storage at the start of the step (kg m-2) - real(dp) :: balanceAquifer1 ! total aquifer storage at the end of the step (kg m-2) + real(rkind) :: totalSoilCompress ! total soil compression (kg m-2) + real(rkind) :: scalarCanopyWatBalError ! water balance error for the vegetation canopy (kg m-2) + real(rkind) :: scalarSoilWatBalError ! water balance error (kg m-2) + real(rkind) :: scalarInitCanopyLiq ! initial liquid water on the vegetation canopy (kg m-2) + real(rkind) :: scalarInitCanopyIce ! initial ice on the vegetation canopy (kg m-2) + real(rkind) :: balanceCanopyWater0 ! total water stored in the vegetation canopy at the start of the step (kg m-2) + real(rkind) :: balanceCanopyWater1 ! total water stored in the vegetation canopy at the end of the step (kg m-2) + real(rkind) :: balanceSoilWater0 ! total soil storage at the start of the step (kg m-2) + real(rkind) :: balanceSoilWater1 ! total soil storage at the end of the step (kg m-2) + real(rkind) :: balanceSoilInflux ! input to the soil zone + real(rkind) :: balanceSoilBaseflow ! output from the soil zone + real(rkind) :: balanceSoilDrainage ! output from the soil zone + real(rkind) :: balanceSoilET ! output from the soil zone + real(rkind) :: balanceAquifer0 ! total aquifer storage at the start of the step (kg m-2) + real(rkind) :: balanceAquifer1 ! total aquifer storage at the end of the step (kg m-2) ! test balance checks logical(lgt), parameter :: printBalance=.false. ! flag to print the balance checks - real(dp), allocatable :: liqSnowInit(:) ! volumetric liquid water conetnt of snow at the start of the time step - real(dp), allocatable :: liqSoilInit(:) ! soil moisture at the start of the time step + real(rkind), allocatable :: liqSnowInit(:) ! volumetric liquid water conetnt of snow at the start of the time step + real(rkind), allocatable :: liqSoilInit(:) ! soil moisture at the start of the time step ! ---------------------------------------------------------------------------------------------------------------------------------------------- ! initialize error control err=0; message="coupled_em/" @@ -300,12 +300,12 @@ subroutine coupled_em(& if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; end if ! initialize compression and surface melt pond - sfcMeltPond = 0._dp ! change in storage associated with the surface melt pond (kg m-2) - totalSoilCompress = 0._dp ! change in soil storage associated with compression of the matrix (kg m-2) + sfcMeltPond = 0._rkind ! change in storage associated with the surface melt pond (kg m-2) + totalSoilCompress = 0._rkind ! change in soil storage associated with compression of the matrix (kg m-2) ! initialize mean fluxes do iVar=1,size(averageFlux_meta) - flux_mean%var(iVar)%dat(:) = 0._dp + flux_mean%var(iVar)%dat(:) = 0._rkind end do ! associate local variables with information in the data structures @@ -354,7 +354,7 @@ subroutine coupled_em(& ! short-cut to the algorithmic control parameters ! NOTE - temporary assignment of minstep to foce something reasonable - minstep = 10._dp ! mpar_data%var(iLookPARAM%minstep)%dat(1) ! minimum time step (s) + minstep = 10._rkind ! mpar_data%var(iLookPARAM%minstep)%dat(1) ! minimum time step (s) maxstep = mpar_data%var(iLookPARAM%maxstep)%dat(1) ! maximum time step (s) !print*, 'minstep, maxstep = ', minstep, maxstep @@ -366,7 +366,7 @@ subroutine coupled_em(& end if ! define the foliage nitrogen factor - diag_data%var(iLookDIAG%scalarFoliageNitrogenFactor)%dat(1) = 1._dp ! foliage nitrogen concentration (1.0 = saturated) + diag_data%var(iLookDIAG%scalarFoliageNitrogenFactor)%dat(1) = 1._rkind ! foliage nitrogen concentration (1.0 = saturated) ! save SWE oldSWE = prog_data%var(iLookPROG%scalarSWE)%dat(1) @@ -377,7 +377,7 @@ subroutine coupled_em(& ! ------------------------ ! compute the temperature of the root zone: used in vegetation phenology - diag_data%var(iLookDIAG%scalarRootZoneTemp)%dat(1) = sum(prog_data%var(iLookPROG%mLayerTemp)%dat(nSnow+1:nSnow+nLayersRoots)) / real(nLayersRoots, kind(dp)) + diag_data%var(iLookDIAG%scalarRootZoneTemp)%dat(1) = sum(prog_data%var(iLookPROG%mLayerTemp)%dat(nSnow+1:nSnow+nLayersRoots)) / real(nLayersRoots, kind(rkind)) ! remember if we compute the vegetation flux on the previous sub-step computeVegFluxOld = computeVegFlux @@ -421,7 +421,7 @@ subroutine coupled_em(& ! NOTE 3: use maximum per unit leaf area storage capacity for snow (kg m-2) select case(model_decisions(iLookDECISIONS%snowIncept)%iDecision) case(lightSnow); diag_data%var(iLookDIAG%scalarCanopyIceMax)%dat(1) = exposedVAI*mpar_data%var(iLookPARAM%refInterceptCapSnow)%dat(1) - case(stickySnow); diag_data%var(iLookDIAG%scalarCanopyIceMax)%dat(1) = exposedVAI*mpar_data%var(iLookPARAM%refInterceptCapSnow)%dat(1)*4._dp + case(stickySnow); diag_data%var(iLookDIAG%scalarCanopyIceMax)%dat(1) = exposedVAI*mpar_data%var(iLookPARAM%refInterceptCapSnow)%dat(1)*4._rkind case default; message=trim(message)//'unable to identify option for maximum branch interception capacity'; err=20; return end select ! identifying option for maximum branch interception capacity !print*, 'diag_data%var(iLookDIAG%scalarCanopyLiqMax)%dat(1) = ', diag_data%var(iLookDIAG%scalarCanopyLiqMax)%dat(1) @@ -454,9 +454,9 @@ subroutine coupled_em(& ! vegetation is completely buried by snow (or no veg exists at all) else - diag_data%var(iLookDIAG%scalarCanopyWetFraction)%dat(1) = 0._dp - dCanopyWetFraction_dWat = 0._dp - dCanopyWetFraction_dT = 0._dp + diag_data%var(iLookDIAG%scalarCanopyWetFraction)%dat(1) = 0._rkind + dCanopyWetFraction_dWat = 0._rkind + dCanopyWetFraction_dT = 0._rkind end if ! *** compute snow albedo... @@ -533,10 +533,10 @@ subroutine coupled_em(& ! NOTE 2: this initialization needs to be done AFTER the call to canopySnow, since canopySnow uses canopy drip drom the previous time step if(.not.computeVegFlux)then flux_data%var(iLookFLUX%scalarThroughfallRain)%dat(1) = flux_data%var(iLookFLUX%scalarRainfall)%dat(1) - flux_data%var(iLookFLUX%scalarCanopyLiqDrainage)%dat(1) = 0._dp + flux_data%var(iLookFLUX%scalarCanopyLiqDrainage)%dat(1) = 0._rkind else - flux_data%var(iLookFLUX%scalarThroughfallRain)%dat(1) = 0._dp - flux_data%var(iLookFLUX%scalarCanopyLiqDrainage)%dat(1) = 0._dp + flux_data%var(iLookFLUX%scalarThroughfallRain)%dat(1) = 0._rkind + flux_data%var(iLookFLUX%scalarCanopyLiqDrainage)%dat(1) = 0._rkind end if ! **************************************************************************************************** @@ -544,7 +544,7 @@ subroutine coupled_em(& ! **************************************************************************************************** ! initialize the length of the sub-step - dt_solv = 0._dp ! length of time step that has been completed (s) + dt_solv = 0._rkind ! length of time step that has been completed (s) dt_init = min(data_step,maxstep) ! initial substep length (s) dt_sub = dt_init ! length of substep dtSave = dt_init ! length of substep @@ -762,7 +762,7 @@ subroutine coupled_em(& if(stepFailure)then ! halve step - dt_sub = dtSave/2._dp + dt_sub = dtSave/2._rkind ! check that the step is not tiny if(dt_sub < minstep)then @@ -804,13 +804,13 @@ subroutine coupled_em(& scalarCanopyIce = scalarCanopyIce + scalarCanopySublimation*dt_sub ! if removed all ice, take the remaining sublimation from water - if(scalarCanopyIce < 0._dp)then + if(scalarCanopyIce < 0._rkind)then scalarCanopyLiq = scalarCanopyLiq + scalarCanopyIce - scalarCanopyIce = 0._dp + scalarCanopyIce = 0._rkind endif ! modify fluxes if there is insufficient canopy water to support the converged sublimation rate over the time step dt_sub - if(scalarCanopyLiq < 0._dp)then + if(scalarCanopyLiq < 0._rkind)then ! --> superfluous sublimation flux superflousSub = -scalarCanopyLiq/dt_sub ! kg m-2 s-1 superflousNrg = superflousSub*LH_sub ! W m-2 (J m-2 s-1) @@ -818,7 +818,7 @@ subroutine coupled_em(& scalarCanopySublimation = scalarCanopySublimation + superflousSub scalarLatHeatCanopyEvap = scalarLatHeatCanopyEvap + superflousNrg scalarSenHeatCanopy = scalarSenHeatCanopy - superflousNrg - scalarCanopyLiq = 0._dp + scalarCanopyLiq = 0._rkind endif end if ! (if computing the vegetation flux) @@ -842,7 +842,7 @@ subroutine coupled_em(& if(mLayerDepth(iSnow) < verySmall)then stepFailure = .true. doLayerMerge = .true. - dt_sub = max(dtSave/2._dp, minstep) + dt_sub = max(dtSave/2._rkind, minstep) cycle substeps else stepFailure = .false. @@ -1060,7 +1060,7 @@ subroutine coupled_em(& ! NOTE: need to put the balance checks in the sub-step loop so that we can re-compute if necessary scalarCanopyWatBalError = balanceCanopyWater1 - (balanceCanopyWater0 + (scalarSnowfall - averageThroughfallSnow)*data_step + (scalarRainfall - averageThroughfallRain)*data_step & - averageCanopySnowUnloading*data_step - averageCanopyLiqDrainage*data_step + averageCanopySublimation*data_step + averageCanopyEvaporation*data_step) - if(abs(scalarCanopyWatBalError) > absConvTol_liquid*iden_water*10._dp)then + if(abs(scalarCanopyWatBalError) > absConvTol_liquid*iden_water*10._rkind)then print*, '** canopy water balance error:' write(*,'(a,1x,f20.10)') 'data_step = ', data_step write(*,'(a,1x,f20.10)') 'balanceCanopyWater0 = ', balanceCanopyWater0 @@ -1167,7 +1167,7 @@ subroutine coupled_em(& ! check the soil water balance scalarSoilWatBalError = balanceSoilWater1 - (balanceSoilWater0 + (balanceSoilInflux + balanceSoilET - balanceSoilBaseflow - balanceSoilDrainage - totalSoilCompress) ) - if(abs(scalarSoilWatBalError) > absConvTol_liquid*iden_water*10._dp)then ! NOTE: kg m-2, so need coarse tolerance to account for precision issues + if(abs(scalarSoilWatBalError) > absConvTol_liquid*iden_water*10._rkind)then ! NOTE: kg m-2, so need coarse tolerance to account for precision issues write(*,*) 'solution method = ', ixSolution write(*,'(a,1x,f20.10)') 'data_step = ', data_step write(*,'(a,1x,f20.10)') 'totalSoilCompress = ', totalSoilCompress @@ -1232,24 +1232,24 @@ subroutine implctMelt(& err,message ) ! intent(out): error control implicit none ! input/output: integrated snowpack properties - real(dp),intent(inout) :: scalarSWE ! snow water equivalent (kg m-2) - real(dp),intent(inout) :: scalarSnowDepth ! snow depth (m) - real(dp),intent(inout) :: scalarSfcMeltPond ! surface melt pond (kg m-2) + real(rkind),intent(inout) :: scalarSWE ! snow water equivalent (kg m-2) + real(rkind),intent(inout) :: scalarSnowDepth ! snow depth (m) + real(rkind),intent(inout) :: scalarSfcMeltPond ! surface melt pond (kg m-2) ! input/output: properties of the upper-most soil layer - real(dp),intent(inout) :: soilTemp ! surface layer temperature (K) - real(dp),intent(inout) :: soilDepth ! surface layer depth (m) - real(dp),intent(inout) :: soilHeatcap ! surface layer volumetric heat capacity (J m-3 K-1) + real(rkind),intent(inout) :: soilTemp ! surface layer temperature (K) + real(rkind),intent(inout) :: soilDepth ! surface layer depth (m) + real(rkind),intent(inout) :: soilHeatcap ! surface layer volumetric heat capacity (J m-3 K-1) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! local variables - real(dp) :: nrgRequired ! energy required to melt all the snow (J m-2) - real(dp) :: nrgAvailable ! energy available to melt the snow (J m-2) - real(dp) :: snwDensity ! snow density (kg m-3) + real(rkind) :: nrgRequired ! energy required to melt all the snow (J m-2) + real(rkind) :: nrgAvailable ! energy available to melt the snow (J m-2) + real(rkind) :: snwDensity ! snow density (kg m-3) ! initialize error control err=0; message='implctMelt/' - if(scalarSWE > 0._dp)then + if(scalarSWE > 0._rkind)then ! only melt if temperature of the top soil layer is greater than Tfreeze if(soilTemp > Tfreeze)then ! compute the energy required to melt all the snow (J m-2) @@ -1261,7 +1261,7 @@ subroutine implctMelt(& ! compute the amount of melt, and update SWE (kg m-2) if(nrgAvailable > nrgRequired)then scalarSfcMeltPond = scalarSWE - scalarSWE = 0._dp + scalarSWE = 0._rkind else scalarSfcMeltPond = nrgAvailable/LH_fus scalarSWE = scalarSWE - scalarSfcMeltPond @@ -1271,10 +1271,10 @@ subroutine implctMelt(& ! update temperature of the top soil layer (K) soilTemp = soilTemp - (LH_fus*scalarSfcMeltPond/soilDepth)/soilHeatcap else ! melt is zero if the temperature of the top soil layer is less than Tfreeze - scalarSfcMeltPond = 0._dp ! kg m-2 + scalarSfcMeltPond = 0._rkind ! kg m-2 end if ! (if the temperature of the top soil layer is greater than Tfreeze) else ! melt is zero if the "snow without a layer" does not exist - scalarSfcMeltPond = 0._dp ! kg m-2 + scalarSfcMeltPond = 0._rkind ! kg m-2 end if ! (if the "snow without a layer" exists) end subroutine implctMelt diff --git a/build/source/engine/derivforce.f90 b/build/source/engine/derivforce.f90 index fbf6d7dba..caa7e617d 100644 --- a/build/source/engine/derivforce.f90 +++ b/build/source/engine/derivforce.f90 @@ -74,8 +74,8 @@ subroutine derivforce(time_data,forc_data,attr_data,mpar_data,prog_data,diag_dat implicit none ! input variables integer(i4b), intent(in) :: time_data(:) ! vector of time data for a given time step - real(dp), intent(inout) :: forc_data(:) ! vector of forcing data for a given time step - real(dp), intent(in) :: attr_data(:) ! vector of model attributes + real(rkind), intent(inout) :: forc_data(:) ! vector of forcing data for a given time step + real(rkind), intent(in) :: attr_data(:) ! vector of model attributes type(var_dlength),intent(in) :: mpar_data ! vector of model parameters type(var_dlength),intent(in) :: prog_data ! data structure of model prognostic variables for a local HRU ! output variables @@ -86,33 +86,33 @@ subroutine derivforce(time_data,forc_data,attr_data,mpar_data,prog_data,diag_dat ! local time integer(i4b) :: jyyy,jm,jd ! year, month, day integer(i4b) :: jh,jmin ! hour, minute - real(dp) :: dsec ! double precision seconds (not used) - real(dp) :: timeOffset ! time offset from Grenwich (days) - real(dp) :: julianTime ! local julian time + real(rkind) :: dsec ! double precision seconds (not used) + real(rkind) :: timeOffset ! time offset from Grenwich (days) + real(rkind) :: julianTime ! local julian time ! cosine of the solar zenith angle - real(dp) :: ahour ! hour at start of time step - real(dp) :: dataStep ! data step (hours) - real(dp) :: slope ! HRU terrain slope (degrees) - real(dp) :: azimuth ! HRU terrain azimuth (degrees) - real(dp) :: hri ! average radiation index over time step DT + real(rkind) :: ahour ! hour at start of time step + real(rkind) :: dataStep ! data step (hours) + real(rkind) :: slope ! HRU terrain slope (degrees) + real(rkind) :: azimuth ! HRU terrain azimuth (degrees) + real(rkind) :: hri ! average radiation index over time step DT ! general local variables character(len=256) :: cmessage ! error message for downwind routine integer(i4b),parameter :: nBands=2 ! number of spectral bands - real(dp),parameter :: valueMissing=-9999._dp ! missing value - real(dp),parameter :: co2Factor=355.e-6_dp ! empirical factor to obtain partial pressure of co2 - real(dp),parameter :: o2Factor=0.209_dp ! empirical factor to obtain partial pressure of o2 - real(dp),parameter :: minMeasHeight=1._dp ! minimum measurement height (m) - real(dp) :: relhum ! relative humidity (-) - real(dp) :: fracrain ! fraction of precipitation that falls as rain - real(dp) :: maxFrozenSnowTemp ! maximum temperature of snow when the snow is predominantely frozen (K) - real(dp),parameter :: unfrozenLiq=0.01_dp ! unfrozen liquid water used to compute maxFrozenSnowTemp (-) - real(dp),parameter :: eps=epsilon(fracrain) ! a number that is almost negligible - real(dp) :: Tmin,Tmax ! minimum and maximum wet bulb temperature in the time step (K) - real(dp),parameter :: pomNewSnowDenMax=150._dp ! Upper limit for new snow density limit in Hedstrom and Pomeroy 1998. 150 was used because at was the highest observed density at air temperatures used in this study. See Figure 4 of Hedstrom and Pomeroy (1998). - real(dp),parameter :: andersonWarmDenLimit=2._dp ! Upper air temperature limit in Anderson (1976) new snow density (C) - real(dp),parameter :: andersonColdDenLimit=15._dp! Lower air temperature limit in Anderson (1976) new snow density (C) - real(dp),parameter :: andersonDenScal=1.5_dp ! Scalar parameter in Anderson (1976) new snow density function (-) - real(dp),parameter :: pahautDenWindScal=0.5_dp ! Scalar parameter for wind impacts on density using Pahaut (1976) function (-) + real(rkind),parameter :: valueMissing=-9999._rkind ! missing value + real(rkind),parameter :: co2Factor=355.e-6_rkind ! empirical factor to obtain partial pressure of co2 + real(rkind),parameter :: o2Factor=0.209_rkind ! empirical factor to obtain partial pressure of o2 + real(rkind),parameter :: minMeasHeight=1._rkind ! minimum measurement height (m) + real(rkind) :: relhum ! relative humidity (-) + real(rkind) :: fracrain ! fraction of precipitation that falls as rain + real(rkind) :: maxFrozenSnowTemp ! maximum temperature of snow when the snow is predominantely frozen (K) + real(rkind),parameter :: unfrozenLiq=0.01_rkind ! unfrozen liquid water used to compute maxFrozenSnowTemp (-) + real(rkind),parameter :: eps=epsilon(fracrain) ! a number that is almost negligible + real(rkind) :: Tmin,Tmax ! minimum and maximum wet bulb temperature in the time step (K) + real(rkind),parameter :: pomNewSnowDenMax=150._rkind ! Upper limit for new snow density limit in Hedstrom and Pomeroy 1998. 150 was used because at was the highest observed density at air temperatures used in this study. See Figure 4 of Hedstrom and Pomeroy (1998). + real(rkind),parameter :: andersonWarmDenLimit=2._rkind ! Upper air temperature limit in Anderson (1976) new snow density (C) + real(rkind),parameter :: andersonColdDenLimit=15._rkind! Lower air temperature limit in Anderson (1976) new snow density (C) + real(rkind),parameter :: andersonDenScal=1.5_rkind ! Scalar parameter in Anderson (1976) new snow density function (-) + real(rkind),parameter :: pahautDenWindScal=0.5_rkind ! Scalar parameter for wind impacts on density using Pahaut (1976) function (-) ! ************************************************************************************************ ! associate local variables with the information in the data structures associate(& @@ -206,13 +206,13 @@ subroutine derivforce(time_data,forc_data,attr_data,mpar_data,prog_data,diag_dat select case(trim(NC_TIME_ZONE)) ! Time zone information from NetCDF file case('ncTime') - timeOffset = longitude/360._dp - tmZoneOffsetFracDay ! time offset in days + timeOffset = longitude/360._rkind - tmZoneOffsetFracDay ! time offset in days ! All times in UTC case('utcTime') - timeOffset = longitude/360._dp ! time offset in days + timeOffset = longitude/360._rkind ! time offset in days ! All times local case('localTime') - timeOffset = 0._dp ! time offset in days + timeOffset = 0._rkind ! time offset in days case default; message=trim(message)//'unable to identify option for tmZoneInfo'; err=20; return end select ! identifying option tmZoneInfo @@ -234,7 +234,7 @@ subroutine derivforce(time_data,forc_data,attr_data,mpar_data,prog_data,diag_dat ! compute the decimal hour at the start of the time step dataStep = data_step/secprhour ! time step (hours) - ahour = real(jh,kind(dp)) + real(jmin,kind(dp))/minprhour - data_step/secprhour ! decimal hour (start of the step) + ahour = real(jh,kind(rkind)) + real(jmin,kind(rkind))/minprhour - data_step/secprhour ! decimal hour (start of the step) ! check slope/aspect intent for radiation calculation if(aspect == nr_realMissing)then @@ -253,19 +253,19 @@ subroutine derivforce(time_data,forc_data,attr_data,mpar_data,prog_data,diag_dat ! im,id,ih,imin,ahour,dataStep,azimuth,slope,cosZenith ! ensure solar radiation is non-negative - if(SWRadAtm < 0._dp) SWRadAtm = 0._dp + if(SWRadAtm < 0._rkind) SWRadAtm = 0._rkind ! compute the fraction of direct radiation using the parameterization of Nijssen and Lettenmaier (1999) - if(cosZenith > 0._dp)then + if(cosZenith > 0._rkind)then scalarFractionDirect = Frad_direct*cosZenith/(cosZenith + directScale) else - scalarFractionDirect = 0._dp + scalarFractionDirect = 0._rkind end if ! compute direct shortwave radiation, in the visible and near-infra-red part of the spectrum spectralIncomingDirect(1) = SWRadAtm*scalarFractionDirect*Frad_vis ! (direct vis) - spectralIncomingDirect(2) = SWRadAtm*scalarFractionDirect*(1._dp - Frad_vis) ! (direct nir) + spectralIncomingDirect(2) = SWRadAtm*scalarFractionDirect*(1._rkind - Frad_vis) ! (direct nir) ! compute diffuse shortwave radiation, in the visible and near-infra-red part of the spectrum - spectralIncomingDiffuse(1) = SWRadAtm*(1._dp - scalarFractionDirect)*Frad_vis ! (diffuse vis) - spectralIncomingDiffuse(2) = SWRadAtm*(1._dp - scalarFractionDirect)*(1._dp - Frad_vis) ! (diffuse nir) + spectralIncomingDiffuse(1) = SWRadAtm*(1._rkind - scalarFractionDirect)*Frad_vis ! (diffuse vis) + spectralIncomingDiffuse(2) = SWRadAtm*(1._rkind - scalarFractionDirect)*(1._rkind - Frad_vis) ! (diffuse nir) !print*,'Frad_direct,scalarFractionDirect,directScale,SWRadAtm,Frad_vis,spectralIncomingDirect: ', & ! frad_direct,scalarFractionDirect,directScale,SWRadAtm,Frad_vis,spectralIncomingDirect @@ -276,8 +276,8 @@ subroutine derivforce(time_data,forc_data,attr_data,mpar_data,prog_data,diag_dat ! compute relative humidity (-) relhum = SPHM2RELHM(spechum, airpres, airtemp) ! if relative humidity exceeds saturation, then set relative and specific humidity to saturation - if(relhum > 1._dp)then - relhum = 1._dp + if(relhum > 1._rkind)then + relhum = 1._rkind spechum = RELHM2SPHM(relhum, airpres, airtemp) end if @@ -292,17 +292,17 @@ subroutine derivforce(time_data,forc_data,attr_data,mpar_data,prog_data,diag_dat maxFrozenSnowTemp = templiquid(unfrozenLiq,fc_param) ! compute fraction of rain and temperature of fresh snow - Tmin = twetbulb - tempRangeTimestep/2._dp - Tmax = twetbulb + tempRangeTimestep/2._dp + Tmin = twetbulb - tempRangeTimestep/2._rkind + Tmax = twetbulb + tempRangeTimestep/2._rkind if(Tmax < tempCritRain)then - fracrain = 0._dp + fracrain = 0._rkind snowfallTemp = twetbulb elseif(Tmin > tempCritRain)then - fracrain = 1._dp + fracrain = 1._rkind snowfallTemp = maxFrozenSnowTemp else fracrain = (Tmax - tempCritRain)/(Tmax - Tmin) - snowfallTemp = 0.5_dp*(Tmin + maxFrozenSnowTemp) + snowfallTemp = 0.5_rkind*(Tmin + maxFrozenSnowTemp) end if ! ensure that snowfall temperature creates predominantely solid precipitation @@ -311,12 +311,12 @@ subroutine derivforce(time_data,forc_data,attr_data,mpar_data,prog_data,diag_dat ! ensure precipitation rate can be resolved by the data model if(pptrate 0.1_dp)then ! log10(0.1) = -1 - kerstenNum = log10(relativeSat) + 1._dp + if(relativeSat > 0.1_rkind)then ! log10(0.1) = -1 + kerstenNum = log10(relativeSat) + 1._rkind else - kerstenNum = 0._dp ! dry thermal conductivity + kerstenNum = 0._rkind ! dry thermal conductivity endif ! ...and, compute the thermal conductivity - mLayerThermalC(iLayer) = kerstenNum*lambda_wet + (1._dp - kerstenNum)*lambda_drysoil + mLayerThermalC(iLayer) = kerstenNum*lambda_wet + (1._rkind - kerstenNum)*lambda_drysoil ! ** mixture of constituents case(mixConstit) - mLayerThermalC(iLayer) = thCond_soil(iSoil) * ( 1._dp - theta_sat(iSoil) ) + & ! soil component + mLayerThermalC(iLayer) = thCond_soil(iSoil) * ( 1._rkind - theta_sat(iSoil) ) + & ! soil component lambda_ice * mLayerVolFracIce(iLayer) + & ! ice component lambda_water * mLayerVolFracLiq(iLayer) + & ! liquid water component lambda_air * mLayerVolFracAir(iLayer) ! air component ! ** test case for the mizoguchi lab experiment, Hansson et al. VZJ 2004 case(hanssonVZJ) - fArg = 1._dp + f1*mLayerVolFracIce(iLayer)**f2 + fArg = 1._rkind + f1*mLayerVolFracIce(iLayer)**f2 xArg = mLayerVolFracLiq(iLayer) + fArg*mLayerVolFracIce(iLayer) mLayerThermalC(iLayer) = c1 + c2*xArg + (c1 - c4)*exp(-(c3*xArg)**c5) @@ -315,7 +315,7 @@ subroutine diagn_evar(& ! special case of hansson if(ixThCondSoil==hanssonVZJ)then - iLayerThermalC(0) = 28._dp*(0.5_dp*(iLayerHeight(1) - iLayerHeight(0))) + iLayerThermalC(0) = 28._rkind*(0.5_rkind*(iLayerHeight(1) - iLayerHeight(0))) else iLayerThermalC(0) = mLayerThermalC(1) end if diff --git a/build/source/engine/eval8summa.f90 b/build/source/engine/eval8summa.f90 index bd13c2435..286cf5bdb 100755 --- a/build/source/engine/eval8summa.f90 +++ b/build/source/engine/eval8summa.f90 @@ -153,7 +153,7 @@ subroutine eval8summa(& ! -------------------------------------------------------------------------------------------------------------------------------- ! -------------------------------------------------------------------------------------------------------------------------------- ! input: model control - real(dp),intent(in) :: dt ! length of the time step (seconds) + real(rkind),intent(in) :: dt ! length of the time step (seconds) integer(i4b),intent(in) :: nSnow ! number of snow layers integer(i4b),intent(in) :: nSoil ! number of soil layers integer(i4b),intent(in) :: nLayers ! total number of layers @@ -164,9 +164,9 @@ subroutine eval8summa(& logical(lgt),intent(in) :: computeVegFlux ! flag to indicate if computing fluxes over vegetation logical(lgt),intent(in) :: scalarSolution ! flag to denote if implementing the scalar solution ! input: state vectors - real(dp),intent(in) :: stateVecTrial(:) ! model state vector - real(dp),intent(in) :: fScale(:) ! function scaling vector - real(qp),intent(in) :: sMul(:) ! NOTE: qp ! state vector multiplier (used in the residual calculations) + real(rkind),intent(in) :: stateVecTrial(:) ! model state vector + real(rkind),intent(in) :: fScale(:) ! function scaling vector + real(rkind),intent(in) :: sMul(:) ! NOTE: qp ! state vector multiplier (used in the residual calculations) ! input: data structures type(model_options),intent(in) :: model_decisions(:) ! model decisions type(var_i), intent(in) :: type_data ! type of vegetation and soil @@ -182,13 +182,13 @@ subroutine eval8summa(& type(var_dlength),intent(inout) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables ! input-output: baseflow integer(i4b),intent(inout) :: ixSaturation ! index of the lowest saturated layer (NOTE: only computed on the first iteration) - real(dp),intent(out) :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) + real(rkind),intent(out) :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) ! output: flux and residual vectors logical(lgt),intent(out) :: feasible ! flag to denote the feasibility of the solution - real(dp),intent(out) :: fluxVec(:) ! flux vector - real(dp),intent(out) :: resSink(:) ! sink terms on the RHS of the flux equation - real(qp),intent(out) :: resVec(:) ! NOTE: qp ! residual vector - real(dp),intent(out) :: fEval ! function evaluation + real(rkind),intent(out) :: fluxVec(:) ! flux vector + real(rkind),intent(out) :: resSink(:) ! sink terms on the RHS of the flux equation + real(rkind),intent(out) :: resVec(:) ! NOTE: qp ! residual vector + real(rkind),intent(out) :: fEval ! function evaluation ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message @@ -196,29 +196,29 @@ subroutine eval8summa(& ! local variables ! -------------------------------------------------------------------------------------------------------------------------------- ! state variables - real(dp) :: scalarCanairTempTrial ! trial value for temperature of the canopy air space (K) - real(dp) :: scalarCanopyTempTrial ! trial value for temperature of the vegetation canopy (K) - real(dp) :: scalarCanopyWatTrial ! trial value for liquid water storage in the canopy (kg m-2) - real(dp),dimension(nLayers) :: mLayerTempTrial ! trial value for temperature of layers in the snow and soil domains (K) - real(dp),dimension(nLayers) :: mLayerVolFracWatTrial ! trial value for volumetric fraction of total water (-) - real(dp),dimension(nSoil) :: mLayerMatricHeadTrial ! trial value for total water matric potential (m) - real(dp),dimension(nSoil) :: mLayerMatricHeadLiqTrial ! trial value for liquid water matric potential (m) - real(dp) :: scalarAquiferStorageTrial ! trial value of storage of water in the aquifer (m) + real(rkind) :: scalarCanairTempTrial ! trial value for temperature of the canopy air space (K) + real(rkind) :: scalarCanopyTempTrial ! trial value for temperature of the vegetation canopy (K) + real(rkind) :: scalarCanopyWatTrial ! trial value for liquid water storage in the canopy (kg m-2) + real(rkind),dimension(nLayers) :: mLayerTempTrial ! trial value for temperature of layers in the snow and soil domains (K) + real(rkind),dimension(nLayers) :: mLayerVolFracWatTrial ! trial value for volumetric fraction of total water (-) + real(rkind),dimension(nSoil) :: mLayerMatricHeadTrial ! trial value for total water matric potential (m) + real(rkind),dimension(nSoil) :: mLayerMatricHeadLiqTrial ! trial value for liquid water matric potential (m) + real(rkind) :: scalarAquiferStorageTrial ! trial value of storage of water in the aquifer (m) ! diagnostic variables - real(dp) :: scalarCanopyLiqTrial ! trial value for mass of liquid water on the vegetation canopy (kg m-2) - real(dp) :: scalarCanopyIceTrial ! trial value for mass of ice on the vegetation canopy (kg m-2) - real(dp),dimension(nLayers) :: mLayerVolFracLiqTrial ! trial value for volumetric fraction of liquid water (-) - real(dp),dimension(nLayers) :: mLayerVolFracIceTrial ! trial value for volumetric fraction of ice (-) + real(rkind) :: scalarCanopyLiqTrial ! trial value for mass of liquid water on the vegetation canopy (kg m-2) + real(rkind) :: scalarCanopyIceTrial ! trial value for mass of ice on the vegetation canopy (kg m-2) + real(rkind),dimension(nLayers) :: mLayerVolFracLiqTrial ! trial value for volumetric fraction of liquid water (-) + real(rkind),dimension(nLayers) :: mLayerVolFracIceTrial ! trial value for volumetric fraction of ice (-) ! other local variables integer(i4b) :: iLayer ! index of model layer in the snow+soil domain integer(i4b) :: jState(1) ! index of model state for the scalar solution within the soil domain integer(i4b) :: ixBeg,ixEnd ! index of indices for the soil compression routine integer(i4b),parameter :: ixVegVolume=1 ! index of the desired vegetation control volumne (currently only one veg layer) - real(dp) :: xMin,xMax ! minimum and maximum values for water content - real(dp) :: scalarCanopyHydTrial ! trial value for mass of water on the vegetation canopy (kg m-2) - real(dp),parameter :: canopyTempMax=500._dp ! expected maximum value for the canopy temperature (K) - real(dp),dimension(nLayers) :: mLayerVolFracHydTrial ! trial value for volumetric fraction of water (-), general vector merged from Wat and Liq - real(dp),dimension(nState) :: rVecScaled ! scaled residual vector + real(rkind) :: xMin,xMax ! minimum and maximum values for water content + real(rkind) :: scalarCanopyHydTrial ! trial value for mass of water on the vegetation canopy (kg m-2) + real(rkind),parameter :: canopyTempMax=500._rkind ! expected maximum value for the canopy temperature (K) + real(rkind),dimension(nLayers) :: mLayerVolFracHydTrial ! trial value for volumetric fraction of water (-), general vector merged from Wat and Liq + real(rkind),dimension(nState) :: rVecScaled ! scaled residual vector character(LEN=256) :: cmessage ! error message of downwind routine ! -------------------------------------------------------------------------------------------------------------------------------- ! association to variables in the data structures @@ -281,7 +281,7 @@ subroutine eval8summa(& ! check canopy liquid water is not negative if(ixVegHyd/=integerMissing)then - if(stateVecTrial(ixVegHyd) < 0._dp) feasible=.false. + if(stateVecTrial(ixVegHyd) < 0._rkind) feasible=.false. end if ! check snow temperature is below freezing @@ -299,12 +299,12 @@ subroutine eval8summa(& if (layerType(iLayer) == iname_soil) then xMin = theta_sat(iLayer-nSnow) else - xMin = 0._dp + xMin = 0._rkind endif ! --> maximum select case( layerType(iLayer) ) - case(iname_snow); xMax = merge(iden_ice, 1._dp - mLayerVolFracIce(iLayer), ixHydType(iLayer)==iname_watLayer) + case(iname_snow); xMax = merge(iden_ice, 1._rkind - mLayerVolFracIce(iLayer), ixHydType(iLayer)==iname_watLayer) case(iname_soil); xMax = merge(theta_sat(iLayer-nSnow), theta_sat(iLayer-nSnow) - mLayerVolFracIce(iLayer), ixHydType(iLayer)==iname_watLayer) end select @@ -517,8 +517,8 @@ subroutine eval8summa(& if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! (check for errors) ! compute the function evaluation - rVecScaled = fScale(:)*real(resVec(:), dp) ! scale the residual vector (NOTE: residual vector is in quadruple precision) - fEval = 0.5_dp*dot_product(rVecScaled,rVecScaled) + rVecScaled = fScale(:)*real(resVec(:), rkind) ! scale the residual vector (NOTE: residual vector is in quadruple precision) + fEval = 0.5_rkind*dot_product(rVecScaled,rVecScaled) ! end association with the information in the data structures end associate diff --git a/build/source/engine/expIntegral.f90 b/build/source/engine/expIntegral.f90 index 8045e0f04..6061643b9 100755 --- a/build/source/engine/expIntegral.f90 +++ b/build/source/engine/expIntegral.f90 @@ -11,32 +11,32 @@ module expIntegral_module ! From UEB-Veg ! Computes the exponential integral function for the given value FUNCTION EXPINT (LAI) - REAL(DP) LAI - REAL(DP) EXPINT - REAL(DP) a0,a1,a2,a3,a4,a5,b1,b2,b3,b4 - real(dp),parameter :: verySmall=tiny(1.0_dp) ! a very small number + real(rkind) LAI + real(rkind) EXPINT + real(rkind) a0,a1,a2,a3,a4,a5,b1,b2,b3,b4 + real(rkind),parameter :: verySmall=tiny(1.0_rkind) ! a very small number IF (LAI < verySmall)THEN - EXPINT=1._dp + EXPINT=1._rkind ELSEIF (LAI.LE.1.0) THEN - a0=-.57721566_dp - a1=.99999193_dp - a2=-.24991055_dp - a3=.05519968_dp - a4=-.00976004_dp - a5=.00107857_dp + a0=-.57721566_rkind + a1=.99999193_rkind + a2=-.24991055_rkind + a3=.05519968_rkind + a4=-.00976004_rkind + a5=.00107857_rkind EXPINT = a0+a1*LAI+a2*LAI**2+a3*LAI**3+a4*LAI**4+a5*LAI**5 - log(LAI) ELSE - a1=8.5733287401_dp - a2=18.0590169730_dp - a3=8.6347637343_dp - a4=.2677737343_dp - b1=9.5733223454_dp - b2=25.6329561486_dp - b3=21.0996530827_dp - b4=3.9584969228_dp + a1=8.5733287401_rkind + a2=18.0590169730_rkind + a3=8.6347637343_rkind + a4=.2677737343_rkind + b1=9.5733223454_rkind + b2=25.6329561486_rkind + b3=21.0996530827_rkind + b4=3.9584969228_rkind EXPINT=(LAI**4+a1*LAI**3+a2*LAI**2+a3*LAI+a4)/ & ((LAI**4+b1*LAI**3+b2*LAI**2+b3*LAI+b4)*LAI*exp(LAI)) diff --git a/build/source/engine/f2008funcs.f90 b/build/source/engine/f2008funcs.f90 index 3dfd1eeb8..dda228a13 100755 --- a/build/source/engine/f2008funcs.f90 +++ b/build/source/engine/f2008funcs.f90 @@ -75,11 +75,11 @@ end function findIndex subroutine cloneStruc_rv(dataVec,lowerBound,source,mold,err,message) implicit none ! input-output: data vector for allocation/population - real(dp),intent(inout),allocatable :: dataVec(:) ! data vector + real(rkind),intent(inout),allocatable :: dataVec(:) ! data vector ! input integer(i4b),intent(in) :: lowerBound ! lower bound - real(dp),intent(in),optional :: source(lowerBound:) ! dataVec = shape of source + elements of source - real(dp),intent(in),optional :: mold(lowerBound:) ! dataVec = shape of mold + real(rkind),intent(in),optional :: source(lowerBound:) ! dataVec = shape of source + elements of source + real(rkind),intent(in),optional :: mold(lowerBound:) ! dataVec = shape of mold ! error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message diff --git a/build/source/engine/ffile_info.f90 b/build/source/engine/ffile_info.f90 index d7f3b8eb5..eb1938f92 100755 --- a/build/source/engine/ffile_info.f90 +++ b/build/source/engine/ffile_info.f90 @@ -74,7 +74,7 @@ subroutine ffile_info(nGRU,err,message) integer(i4b) :: nForcing ! number of forcing variables integer(i4b) :: iGRU,localHRU_ix ! index of GRU and HRU integer(8) :: ncHruId(1) ! hruID from the forcing files - real(dp) :: dataStep_iFile ! data step for a given forcing data file + real(rkind) :: dataStep_iFile ! data step for a given forcing data file logical(lgt) :: xist ! .TRUE. if the file exists ! Start procedure here diff --git a/build/source/engine/getVectorz.f90 b/build/source/engine/getVectorz.f90 index ba31b4bfa..a25d5090a 100755 --- a/build/source/engine/getVectorz.f90 +++ b/build/source/engine/getVectorz.f90 @@ -97,7 +97,7 @@ module getVectorz_module public::varExtract ! common variables -real(dp),parameter :: valueMissing=-9999._dp ! missing value +real(rkind),parameter :: valueMissing=-9999._rkind ! missing value contains @@ -120,7 +120,7 @@ subroutine popStateVec(& type(var_dlength),intent(in) :: diag_data ! diagnostic variables for a local HRU type(var_ilength),intent(in) :: indx_data ! indices defining model states and layers ! output - real(dp),intent(out) :: stateVec(:) ! model state vector (mixed units) + real(rkind),intent(out) :: stateVec(:) ! model state vector (mixed units) integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! -------------------------------------------------------------------------------------------------------------------------------- @@ -266,10 +266,10 @@ subroutine getScaling(& type(var_dlength),intent(in) :: diag_data ! diagnostic variables for a local HRU type(var_ilength),intent(in) :: indx_data ! indices defining model states and layers ! output: state vectors - real(dp),intent(out) :: fScale(:) ! function scaling vector (mixed units) - real(dp),intent(out) :: xScale(:) ! variable scaling vector (mixed units) - real(qp),intent(out) :: sMul(:) ! NOTE: qp ! multiplier for state vector (used in the residual calculations) - real(dp),intent(out) :: dMat(:) ! diagonal of the Jacobian matrix (excludes fluxes) + real(rkind),intent(out) :: fScale(:) ! function scaling vector (mixed units) + real(rkind),intent(out) :: xScale(:) ! variable scaling vector (mixed units) + real(rkind),intent(out) :: sMul(:) ! NOTE: qp ! multiplier for state vector (used in the residual calculations) + real(rkind),intent(out) :: dMat(:) ! diagonal of the Jacobian matrix (excludes fluxes) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message @@ -277,12 +277,12 @@ subroutine getScaling(& ! local variables ! -------------------------------------------------------------------------------------------------------------------------------- ! scaling parameters - real(dp),parameter :: fScaleLiq=0.01_dp ! func eval: characteristic scale for volumetric liquid water content (-) - real(dp),parameter :: fScaleMat=10._dp ! func eval: characteristic scale for matric head (m) - real(dp),parameter :: fScaleNrg=1000000._dp ! func eval: characteristic scale for energy (J m-3) - real(dp),parameter :: xScaleLiq=0.1_dp ! state var: characteristic scale for volumetric liquid water content (-) - real(dp),parameter :: xScaleMat=10._dp ! state var: characteristic scale for matric head (m) - real(dp),parameter :: xScaleTemp=1._dp ! state var: characteristic scale for temperature (K) + real(rkind),parameter :: fScaleLiq=0.01_rkind ! func eval: characteristic scale for volumetric liquid water content (-) + real(rkind),parameter :: fScaleMat=10._rkind ! func eval: characteristic scale for matric head (m) + real(rkind),parameter :: fScaleNrg=1000000._rkind ! func eval: characteristic scale for energy (J m-3) + real(rkind),parameter :: xScaleLiq=0.1_rkind ! state var: characteristic scale for volumetric liquid water content (-) + real(rkind),parameter :: xScaleMat=10._rkind ! state var: characteristic scale for matric head (m) + real(rkind),parameter :: xScaleTemp=1._rkind ! state var: characteristic scale for temperature (K) ! state subsets integer(i4b) :: iLayer ! index of layer within the snow+soil domain integer(i4b) :: ixStateSubset ! index within the state subset @@ -320,32 +320,32 @@ subroutine getScaling(& ! define the function and variable scaling factors for energy where(ixStateType_subset==iname_nrgCanair .or. ixStateType_subset==iname_nrgCanopy .or. ixStateType_subset==iname_nrgLayer) - fScale = 1._dp / fScaleNrg ! 1/(J m-3) - xScale = 1._dp ! K + fScale = 1._rkind / fScaleNrg ! 1/(J m-3) + xScale = 1._rkind ! K endwhere ! define the function and variable scaling factors for water on the vegetation canopy where(ixStateType_subset==iname_watCanopy .or. ixStateType_subset==iname_liqCanopy) - fScale = 1._dp / (fScaleLiq*canopyDepth*iden_water) ! 1/(kg m-2) - xScale = 1._dp ! (kg m-2) + fScale = 1._rkind / (fScaleLiq*canopyDepth*iden_water) ! 1/(kg m-2) + xScale = 1._rkind ! (kg m-2) endwhere ! define the function and variable scaling factors for water in the snow+soil domain where(ixStateType_subset==iname_watLayer .or. ixStateType_subset==iname_liqLayer) - fScale = 1._dp / fScaleLiq ! (-) - xScale = 1._dp ! (-) + fScale = 1._rkind / fScaleLiq ! (-) + xScale = 1._rkind ! (-) end where ! define the function and variable scaling factors for water in the snow+soil domain where(ixStateType_subset==iname_matLayer .or. ixStateType_subset==iname_lmpLayer) - fScale = 1._dp / fScaleLiq ! (-) - xScale = 1._dp ! (m) + fScale = 1._rkind / fScaleLiq ! (-) + xScale = 1._rkind ! (m) end where ! define the function and variable scaling factors for water storage in the aquifer where(ixStateType_subset==iname_watAquifer) - fScale = 1._dp - xScale = 1._dp + fScale = 1._rkind + xScale = 1._rkind endwhere ! ----- @@ -357,8 +357,8 @@ subroutine getScaling(& where(ixStateType_subset==iname_nrgCanair) sMul = Cp_air*iden_air ! volumetric heat capacity of air (J m-3 K-1) where(ixStateType_subset==iname_nrgCanopy) sMul = volHeatCapVeg ! volumetric heat capacity of the vegetation (J m-3 K-1) - where(ixStateType_subset==iname_watCanopy) sMul = 1._dp ! nothing else on the left hand side - where(ixStateType_subset==iname_liqCanopy) sMul = 1._dp ! nothing else on the left hand side + where(ixStateType_subset==iname_watCanopy) sMul = 1._rkind ! nothing else on the left hand side + where(ixStateType_subset==iname_liqCanopy) sMul = 1._rkind ! nothing else on the left hand side ! compute terms in the Jacobian for vegetation (excluding fluxes) ! NOTE: This is computed outside the iteration loop because it does not depend on state variables @@ -366,8 +366,8 @@ subroutine getScaling(& ! NOTE: Use the "where" statement to generalize to multiple canopy layers (currently one canopy layer) where(ixStateType_subset==iname_nrgCanair) dMat = Cp_air*iden_air ! volumetric heat capacity of air (J m-3 K-1) where(ixStateType_subset==iname_nrgCanopy) dMat = realMissing ! populated within the iteration loop - where(ixStateType_subset==iname_watCanopy) dMat = 1._dp ! nothing else on the left hand side - where(ixStateType_subset==iname_liqCanopy) dMat = 1._dp ! nothing else on the left hand side + where(ixStateType_subset==iname_watCanopy) dMat = 1._rkind ! nothing else on the left hand side + where(ixStateType_subset==iname_liqCanopy) dMat = 1._rkind ! nothing else on the left hand side ! define the energy multiplier and diagonal elements for the state vector for residual calculations (snow-soil domain) if(nSnowSoilNrg>0)then @@ -382,15 +382,15 @@ subroutine getScaling(& if(nSnowSoilHyd>0)then do concurrent (iLayer=1:nLayers,ixSnowSoilHyd(iLayer)/=integerMissing) ! (loop through non-missing energy state variables in the snow+soil domain) ixStateSubset = ixSnowSoilHyd(iLayer) ! index within the state vector - sMul(ixStateSubset) = 1._dp ! state multiplier = 1 (nothing else on the left-hand-side) - dMat(ixStateSubset) = 1._dp ! diagonal element = 1 (nothing else on the left-hand-side) + sMul(ixStateSubset) = 1._rkind ! state multiplier = 1 (nothing else on the left-hand-side) + dMat(ixStateSubset) = 1._rkind ! diagonal element = 1 (nothing else on the left-hand-side) end do ! looping through non-missing energy state variables in the snow+soil domain endif ! define the scaling factor and diagonal elements for the aquifer where(ixStateType_subset==iname_watAquifer) - sMul = 1._dp - dMat = 1._dp + sMul = 1._rkind + dMat = 1._rkind endwhere ! ------------------------------------------------------------------------------------------ @@ -431,25 +431,25 @@ subroutine varExtract(& ! -------------------------------------------------------------------------------------------------------------------------------- implicit none ! input - real(dp),intent(in) :: stateVec(:) ! model state vector (mixed units) + real(rkind),intent(in) :: stateVec(:) ! model state vector (mixed units) type(var_dlength),intent(in) :: diag_data ! diagnostic variables for a local HRU type(var_dlength),intent(in) :: prog_data ! prognostic variables for a local HRU type(var_ilength),intent(in) :: indx_data ! indices defining model states and layers ! output: variables for the vegetation canopy - real(dp),intent(out) :: scalarCanairTempTrial ! trial value of canopy air temperature (K) - real(dp),intent(out) :: scalarCanopyTempTrial ! trial value of canopy temperature (K) - real(dp),intent(out) :: scalarCanopyWatTrial ! trial value of canopy total water (kg m-2) - real(dp),intent(out) :: scalarCanopyLiqTrial ! trial value of canopy liquid water (kg m-2) - real(dp),intent(out) :: scalarCanopyIceTrial ! trial value of canopy ice content (kg m-2) + real(rkind),intent(out) :: scalarCanairTempTrial ! trial value of canopy air temperature (K) + real(rkind),intent(out) :: scalarCanopyTempTrial ! trial value of canopy temperature (K) + real(rkind),intent(out) :: scalarCanopyWatTrial ! trial value of canopy total water (kg m-2) + real(rkind),intent(out) :: scalarCanopyLiqTrial ! trial value of canopy liquid water (kg m-2) + real(rkind),intent(out) :: scalarCanopyIceTrial ! trial value of canopy ice content (kg m-2) ! output: variables for the snow-soil domain - real(dp),intent(out) :: mLayerTempTrial(:) ! trial vector of layer temperature (K) - real(dp),intent(out) :: mLayerVolFracWatTrial(:) ! trial vector of volumetric total water content (-) - real(dp),intent(out) :: mLayerVolFracLiqTrial(:) ! trial vector of volumetric liquid water content (-) - real(dp),intent(out) :: mLayerVolFracIceTrial(:) ! trial vector of volumetric ice water content (-) - real(dp),intent(out) :: mLayerMatricHeadTrial(:) ! trial vector of total water matric potential (m) - real(dp),intent(out) :: mLayerMatricHeadLiqTrial(:) ! trial vector of liquid water matric potential (m) + real(rkind),intent(out) :: mLayerTempTrial(:) ! trial vector of layer temperature (K) + real(rkind),intent(out) :: mLayerVolFracWatTrial(:) ! trial vector of volumetric total water content (-) + real(rkind),intent(out) :: mLayerVolFracLiqTrial(:) ! trial vector of volumetric liquid water content (-) + real(rkind),intent(out) :: mLayerVolFracIceTrial(:) ! trial vector of volumetric ice water content (-) + real(rkind),intent(out) :: mLayerMatricHeadTrial(:) ! trial vector of total water matric potential (m) + real(rkind),intent(out) :: mLayerMatricHeadLiqTrial(:) ! trial vector of liquid water matric potential (m) ! output: variables for the aquifer - real(dp),intent(out) :: scalarAquiferStorageTrial ! trial value of storage of water in the aquifer (m) + real(rkind),intent(out) :: scalarAquiferStorageTrial ! trial value of storage of water in the aquifer (m) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message diff --git a/build/source/engine/groundwatr.f90 b/build/source/engine/groundwatr.f90 index 0e16b27ae..d4b5a12a1 100755 --- a/build/source/engine/groundwatr.f90 +++ b/build/source/engine/groundwatr.f90 @@ -47,9 +47,9 @@ module groundwatr_module ! privacy implicit none ! constant parameters -real(dp),parameter :: valueMissing=-9999._dp ! missing value parameter -real(dp),parameter :: verySmall=epsilon(1.0_dp) ! a very small number (used to avoid divide by zero) -real(dp),parameter :: dx=1.e-8_dp ! finite difference increment +real(rkind),parameter :: valueMissing=-9999._rkind ! missing value parameter +real(rkind),parameter :: verySmall=epsilon(1.0_rkind) ! a very small number (used to avoid divide by zero) +real(rkind),parameter :: dx=1.e-8_rkind ! finite difference increment private public::groundwatr contains @@ -120,10 +120,10 @@ subroutine groundwatr(& integer(i4b),intent(in) :: nLayers ! total number of layers logical(lgt),intent(in) :: getSatDepth ! logical flag to compute index of the lowest saturated layer ! input: state and diagnostic variables - real(dp),intent(in) :: mLayerdTheta_dPsi(:) ! derivative in the soil water characteristic w.r.t. matric head in each layer (m-1) - real(dp),intent(in) :: mLayerMatricHeadLiq(:) ! matric head in each layer at the current iteration (m) - real(dp),intent(in) :: mLayerVolFracLiq(:) ! volumetric fraction of liquid water (-) - real(dp),intent(in) :: mLayerVolFracIce(:) ! volumetric fraction of ice (-) + real(rkind),intent(in) :: mLayerdTheta_dPsi(:) ! derivative in the soil water characteristic w.r.t. matric head in each layer (m-1) + real(rkind),intent(in) :: mLayerMatricHeadLiq(:) ! matric head in each layer at the current iteration (m) + real(rkind),intent(in) :: mLayerVolFracLiq(:) ! volumetric fraction of liquid water (-) + real(rkind),intent(in) :: mLayerVolFracIce(:) ! volumetric fraction of ice (-) ! input/output: data structures type(var_d),intent(in) :: attr_data ! spatial attributes type(var_dlength),intent(in) :: mpar_data ! model parameters @@ -132,8 +132,8 @@ subroutine groundwatr(& type(var_dlength),intent(inout) :: flux_data ! model fluxes for a local HRU ! output: baseflow integer(i4b),intent(inout) :: ixSaturation ! index of lowest saturated layer (NOTE: only computed on the first iteration) - real(dp),intent(out) :: mLayerBaseflow(:) ! baseflow from each soil layer (m s-1) - real(dp),intent(out) :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) + real(rkind),intent(out) :: mLayerBaseflow(:) ! baseflow from each soil layer (m s-1) + real(rkind),intent(out) :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message @@ -142,13 +142,13 @@ subroutine groundwatr(& ! --------------------------------------------------------------------------------------- ! general local variables integer(i4b) :: iLayer ! index of soil layer - real(dp),dimension(nSoil,nSoil) :: dBaseflow_dVolLiq ! derivative in the baseflow flux w.r.t. volumetric liquid water content (m s-1) + real(rkind),dimension(nSoil,nSoil) :: dBaseflow_dVolLiq ! derivative in the baseflow flux w.r.t. volumetric liquid water content (m s-1) ! local variables to compute the numerical Jacobian logical(lgt),parameter :: doNumericalJacobian=.false. ! flag to compute the numerical Jacobian - real(dp),dimension(nSoil) :: mLayerMatricHeadPerturbed ! perturbed matric head (m) - real(dp),dimension(nSoil) :: mLayerVolFracLiqPerturbed ! perturbed volumetric fraction of liquid water (-) - real(dp),dimension(nSoil) :: mLayerBaseflowPerturbed ! perturbed baseflow (m s-1) - real(dp),dimension(nSoil,nSoil) :: nJac ! numerical Jacobian (s-1) + real(rkind),dimension(nSoil) :: mLayerMatricHeadPerturbed ! perturbed matric head (m) + real(rkind),dimension(nSoil) :: mLayerVolFracLiqPerturbed ! perturbed volumetric fraction of liquid water (-) + real(rkind),dimension(nSoil) :: mLayerBaseflowPerturbed ! perturbed baseflow (m s-1) + real(rkind),dimension(nSoil,nSoil) :: nJac ! numerical Jacobian (s-1) ! *************************************************************************************** ! *************************************************************************************** ! initialize error control @@ -189,10 +189,10 @@ subroutine groundwatr(& ! check for an early return (no layers are "active") if(ixSaturation > nSoil)then - scalarExfiltration = 0._dp ! exfiltration from the soil profile (m s-1) - mLayerColumnOutflow(:) = 0._dp ! column outflow from each soil layer (m3 s-1) - mLayerBaseflow(:) = 0._dp ! baseflow from each soil layer (m s-1) - dBaseflow_dMatric(:,:) = 0._dp ! derivative in baseflow w.r.t. matric head (s-1) + scalarExfiltration = 0._rkind ! exfiltration from the soil profile (m s-1) + mLayerColumnOutflow(:) = 0._rkind ! column outflow from each soil layer (m3 s-1) + mLayerBaseflow(:) = 0._rkind ! baseflow from each soil layer (m s-1) + dBaseflow_dMatric(:,:) = 0._rkind ! derivative in baseflow w.r.t. matric head (s-1) return end if ! if some layers are saturated @@ -222,7 +222,7 @@ subroutine groundwatr(& ! use the chain rule to compute the baseflow derivative w.r.t. matric head (s-1) do iLayer=1,nSoil dBaseflow_dMatric(1:iLayer,iLayer) = dBaseflow_dVolLiq(1:iLayer,iLayer)*mLayerdTheta_dPsi(iLayer) - if(iLayer1)then - zActive(1:ixSaturation-1) = 0._dp - trTotal(1:ixSaturation-1) = 0._dp - trSoil(1:ixSaturation-1) = 0._dp + zActive(1:ixSaturation-1) = 0._rkind + trTotal(1:ixSaturation-1) = 0._rkind + trSoil(1:ixSaturation-1) = 0._rkind end if ! compute the outflow from each layer (m3 s-1) @@ -444,26 +444,26 @@ subroutine computeBaseflow(& if(availStorage < xMinEval)then ! (compute the logistic function) expF = exp((availStorage - xCenter)/xWidth) - logF = 1._dp / (1._dp + expF) + logF = 1._rkind / (1._rkind + expF) ! (compute the derivative in the logistic function w.r.t. volumetric liquid water content in each soil layer) - dLogFunc_dLiq(1:nSoil) = mLayerDepth(1:nSoil)*(expF/xWidth)/(1._dp + expF)**2._dp + dLogFunc_dLiq(1:nSoil) = mLayerDepth(1:nSoil)*(expF/xWidth)/(1._rkind + expF)**2._rkind else - logF = 0._dp - dLogFunc_dLiq(:) = 0._dp + logF = 0._rkind + dLogFunc_dLiq(:) = 0._rkind end if ! compute the exfiltartion (m s-1) - if(totalColumnInflow > totalColumnOutflow .and. logF > tiny(1._dp))then + if(totalColumnInflow > totalColumnOutflow .and. logF > tiny(1._rkind))then scalarExfiltration = logF*(totalColumnInflow - totalColumnOutflow) ! m s-1 !write(*,'(a,1x,10(f30.20,1x))') 'scalarExfiltration = ', scalarExfiltration else - scalarExfiltration = 0._dp + scalarExfiltration = 0._rkind end if ! check !write(*,'(a,1x,10(f30.20,1x))') 'zActive(1), soilDepth, availStorage, logF, scalarExfiltration = ', & ! zActive(1), soilDepth, availStorage, logF, scalarExfiltration - !if(scalarExfiltration > tiny(1.0_dp)) pause 'exfiltrating' + !if(scalarExfiltration > tiny(1.0_rkind)) pause 'exfiltrating' ! compute the baseflow in each layer (m s-1) mLayerBaseflow(1:nSoil) = (mLayerColumnOutflow(1:nSoil) - mLayerColumnInflow(1:nSoil))/HRUarea @@ -494,7 +494,7 @@ subroutine computeBaseflow(& ! *********************************************************************************************************************** ! initialize the derivative matrix - dBaseflow_dVolLiq(:,:) = 0._dp + dBaseflow_dVolLiq(:,:) = 0._rkind ! check if derivatives are actually required if(.not.derivDesired) return @@ -506,7 +506,7 @@ subroutine computeBaseflow(& depth2capacity(1:nSoil) = mLayerDepth(1:nSoil)/sum( (theta_sat(1:nSoil) - fieldCapacity)*mLayerDepth(1:nSoil) ) ! compute the change in dimensionless flux w.r.t. change in dimensionless storage (-) - dXdS(1:nSoil) = zScale_TOPMODEL*(zActive(1:nSoil)/SoilDepth)**(zScale_TOPMODEL - 1._dp) + dXdS(1:nSoil) = zScale_TOPMODEL*(zActive(1:nSoil)/SoilDepth)**(zScale_TOPMODEL - 1._rkind) ! loop through soil layers do iLayer=1,nSoil @@ -519,7 +519,7 @@ subroutine computeBaseflow(& end do ! looping through soil layers ! compute the derivative in the exfiltration flux w.r.t. volumetric liquid water content (m s-1) - if(qbTotal < 0._dp)then + if(qbTotal < 0._rkind)then do iLayer=1,nSoil dExfiltrate_dVolLiq(iLayer) = dBaseflow_dVolLiq(iLayer,iLayer)*logF + dLogFunc_dLiq(iLayer)*qbTotal end do ! looping through soil layers diff --git a/build/source/engine/layerDivide.f90 b/build/source/engine/layerDivide.f90 index 6127fbf1e..23d4f0165 100755 --- a/build/source/engine/layerDivide.f90 +++ b/build/source/engine/layerDivide.f90 @@ -117,21 +117,21 @@ subroutine layerDivide(& integer(i4b) :: nLayers ! total number of layers integer(i4b) :: iLayer ! layer index integer(i4b) :: jLayer ! layer index - real(dp),dimension(4) :: zmax_lower ! lower value of maximum layer depth - real(dp),dimension(4) :: zmax_upper ! upper value of maximum layer depth - real(dp) :: zmaxCheck ! value of zmax for a given snow layer + real(rkind),dimension(4) :: zmax_lower ! lower value of maximum layer depth + real(rkind),dimension(4) :: zmax_upper ! upper value of maximum layer depth + real(rkind) :: zmaxCheck ! value of zmax for a given snow layer integer(i4b) :: nCheck ! number of layers to check to divide logical(lgt) :: createLayer ! flag to indicate we are creating a new snow layer - real(dp) :: depthOriginal ! original layer depth before sub-division (m) - real(dp),parameter :: fracTop=0.5_dp ! fraction of old layer used for the top layer - real(dp) :: surfaceLayerSoilTemp ! temperature of the top soil layer (K) - real(dp) :: maxFrozenSnowTemp ! maximum temperature when effectively all water is frozen (K) - real(dp),parameter :: unfrozenLiq=0.01_dp ! unfrozen liquid water used to compute maxFrozenSnowTemp (-) - real(dp) :: volFracWater ! volumetric fraction of total water, liquid and ice (-) - real(dp) :: fracLiq ! fraction of liquid water (-) + real(rkind) :: depthOriginal ! original layer depth before sub-division (m) + real(rkind),parameter :: fracTop=0.5_rkind ! fraction of old layer used for the top layer + real(rkind) :: surfaceLayerSoilTemp ! temperature of the top soil layer (K) + real(rkind) :: maxFrozenSnowTemp ! maximum temperature when effectively all water is frozen (K) + real(rkind),parameter :: unfrozenLiq=0.01_rkind ! unfrozen liquid water used to compute maxFrozenSnowTemp (-) + real(rkind) :: volFracWater ! volumetric fraction of total water, liquid and ice (-) + real(rkind) :: fracLiq ! fraction of liquid water (-) integer(i4b),parameter :: ixVisible=1 ! named variable to define index in array of visible part of the spectrum integer(i4b),parameter :: ixNearIR=2 ! named variable to define index in array of near IR part of the spectrum - real(dp),parameter :: verySmall=1.e-10_dp ! a very small number (used for error checking) + real(rkind),parameter :: verySmall=1.e-10_rkind ! a very small number (used for error checking) ! -------------------------------------------------------------------------------------------------------- ! initialize error control err=0; message="layerDivide/" @@ -224,7 +224,7 @@ subroutine layerDivide(& ! compute volumeteric fraction of liquid water and ice volFracWater = (scalarSWE/scalarSnowDepth)/iden_water ! volumetric fraction of total water (liquid and ice) - mLayerVolFracIce(1) = (1._dp - fracLiq)*volFracWater*(iden_water/iden_ice) ! volumetric fraction of ice (-) + mLayerVolFracIce(1) = (1._rkind - fracLiq)*volFracWater*(iden_water/iden_ice) ! volumetric fraction of ice (-) mLayerVolFracLiq(1) = fracLiq *volFracWater ! volumetric fraction of liquid water (-) ! end association with local variables to the information in the data structures) @@ -243,7 +243,7 @@ subroutine layerDivide(& prog_data%var(iLookPROG%spectralSnowAlbedoDiffuse)%dat(ixVisible) = mpar_data%var(iLookPARAM%albedoMaxVisible)%dat(1) prog_data%var(iLookPROG%spectralSnowAlbedoDiffuse)%dat(ixNearIR) = mpar_data%var(iLookPARAM%albedoMaxNearIR)%dat(1) prog_data%var(iLookPROG%scalarSnowAlbedo)%dat(1) = ( mpar_data%var(iLookPARAM%Frad_vis)%dat(1))*mpar_data%var(iLookPARAM%albedoMaxVisible)%dat(1) + & - (1._dp - mpar_data%var(iLookPARAM%Frad_vis)%dat(1))*mpar_data%var(iLookPARAM%albedoMaxNearIR)%dat(1) + (1._rkind - mpar_data%var(iLookPARAM%Frad_vis)%dat(1))*mpar_data%var(iLookPARAM%albedoMaxNearIR)%dat(1) case default; err=20; message=trim(message)//'unable to identify option for snow albedo'; return end select ! identify option for snow albedo ! set direct albedo to diffuse albedo @@ -299,7 +299,7 @@ subroutine layerDivide(& layerSplit: associate(mLayerDepth => prog_data%var(iLookPROG%mLayerDepth)%dat) depthOriginal = mLayerDepth(iLayer) mLayerDepth(iLayer) = fracTop*depthOriginal - mLayerDepth(iLayer+1) = (1._dp - fracTop)*depthOriginal + mLayerDepth(iLayer+1) = (1._rkind - fracTop)*depthOriginal end associate layerSplit exit ! NOTE: only sub-divide one layer per substep @@ -337,7 +337,7 @@ subroutine layerDivide(& iLayerHeight(0) = -scalarSnowDepth do jLayer=1,nLayers iLayerHeight(jLayer) = iLayerHeight(jLayer-1) + mLayerDepth(jLayer) - mLayerHeight(jLayer) = (iLayerHeight(jLayer-1) + iLayerHeight(jLayer))/2._dp + mLayerHeight(jLayer) = (iLayerHeight(jLayer-1) + iLayerHeight(jLayer))/2._rkind end do ! check @@ -387,7 +387,7 @@ subroutine addModelLayer(dataStruct,metaStruct,ix_divide,nSnow,nLayers,err,messa integer(i4b) :: ix_lower ! lower bound of the vector integer(i4b) :: ix_upper ! upper bound of the vector logical(lgt) :: stateVariable ! .true. if variable is a state variable - real(dp),allocatable :: tempVec_dp(:) ! temporary vector (double precision) + real(rkind),allocatable :: tempVec_rkind(:) ! temporary vector (double precision) integer(i4b),allocatable :: tempVec_i4b(:) ! temporary vector (integer) character(LEN=256) :: cmessage ! error message of downwind routine ! --------------------------------------------------------------------------------------------- @@ -420,7 +420,7 @@ subroutine addModelLayer(dataStruct,metaStruct,ix_divide,nSnow,nLayers,err,messa ! check allocated if(.not.allocated(dataStruct%var(ivar)%dat))then; err=20; message='data vector is not allocated'; return; end if ! assign the data vector to the temporary vector - call cloneStruc(tempVec_dp, ix_lower, source=dataStruct%var(ivar)%dat, err=err, message=cmessage) + call cloneStruc(tempVec_rkind, ix_lower, source=dataStruct%var(ivar)%dat, err=err, message=cmessage) if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! reallocate space for the new vector deallocate(dataStruct%var(ivar)%dat,stat=err) @@ -431,18 +431,18 @@ subroutine addModelLayer(dataStruct,metaStruct,ix_divide,nSnow,nLayers,err,messa if(stateVariable)then if(ix_upper > 0)then ! (only copy data if the vector exists -- can be a variable for snow, with no layers) if(ix_divide > 0)then - dataStruct%var(ivar)%dat(1:ix_divide) = tempVec_dp(1:ix_divide) ! copy data - dataStruct%var(ivar)%dat(ix_divide+1) = tempVec_dp(ix_divide) ! repeat data for the sub-divided layer + dataStruct%var(ivar)%dat(1:ix_divide) = tempVec_rkind(1:ix_divide) ! copy data + dataStruct%var(ivar)%dat(ix_divide+1) = tempVec_rkind(ix_divide) ! repeat data for the sub-divided layer end if if(ix_upper > ix_divide) & - dataStruct%var(ivar)%dat(ix_divide+2:ix_upper+1) = tempVec_dp(ix_divide+1:ix_upper) ! copy data + dataStruct%var(ivar)%dat(ix_divide+2:ix_upper+1) = tempVec_rkind(ix_divide+1:ix_upper) ! copy data end if ! if the vector exists ! not a state variable else dataStruct%var(ivar)%dat(:) = realMissing end if ! deallocate the temporary vector: strictly not necessary, but include to be safe - deallocate(tempVec_dp,stat=err) + deallocate(tempVec_rkind,stat=err) if(err/=0)then; err=20; message='problem deallocating temporary data vector'; return; end if ! ** integer diff --git a/build/source/engine/layerMerge.f90 b/build/source/engine/layerMerge.f90 index 6169755dd..085b970b9 100755 --- a/build/source/engine/layerMerge.f90 +++ b/build/source/engine/layerMerge.f90 @@ -100,7 +100,7 @@ subroutine layerMerge(& ! -------------------------------------------------------------------------------------------------------- ! define local variables character(LEN=256) :: cmessage ! error message of downwind routine - real(dp),dimension(5) :: zminLayer ! minimum layer depth in each layer (m) + real(rkind),dimension(5) :: zminLayer ! minimum layer depth in each layer (m) logical(lgt) :: removeLayer ! flag to indicate need to remove a layer integer(i4b) :: nCheck ! number of layers to check for combination integer(i4b) :: iSnow ! index of snow layers (looping) @@ -316,18 +316,18 @@ subroutine layer_combine(mpar_data,prog_data,diag_data,flux_data,indx_data,iSnow ! ------------------------------------------------------------------------------------------------------------ ! local variables character(len=256) :: cmessage ! error message for downwind routine - real(dp) :: massIce(2) ! mass of ice in the two layers identified for combination (kg m-2) - real(dp) :: massLiq(2) ! mass of liquid water in the two layers identified for combination (kg m-2) - real(dp) :: bulkDenWat(2) ! bulk density if total water (liquid water plus ice) in the two layers identified for combination (kg m-3) - real(dp) :: cBulkDenWat ! combined bulk density of total water (liquid water plus ice) in the two layers identified for combination (kg m-3) - real(dp) :: cTemp ! combined layer temperature - real(dp) :: cDepth ! combined layer depth - real(dp) :: cVolFracIce ! combined layer volumetric fraction of ice - real(dp) :: cVolFracLiq ! combined layer volumetric fraction of liquid water - real(dp) :: l1Enthalpy,l2Enthalpy ! enthalpy in the two layers identified for combination (J m-3) - real(dp) :: cEnthalpy ! combined layer enthalpy (J m-3) - real(dp) :: fLiq ! fraction of liquid water at the combined temperature cTemp - real(dp),parameter :: eTol=1.e-1_dp ! tolerance for the enthalpy-->temperature conversion (J m-3) + real(rkind) :: massIce(2) ! mass of ice in the two layers identified for combination (kg m-2) + real(rkind) :: massLiq(2) ! mass of liquid water in the two layers identified for combination (kg m-2) + real(rkind) :: bulkDenWat(2) ! bulk density if total water (liquid water plus ice) in the two layers identified for combination (kg m-3) + real(rkind) :: cBulkDenWat ! combined bulk density of total water (liquid water plus ice) in the two layers identified for combination (kg m-3) + real(rkind) :: cTemp ! combined layer temperature + real(rkind) :: cDepth ! combined layer depth + real(rkind) :: cVolFracIce ! combined layer volumetric fraction of ice + real(rkind) :: cVolFracLiq ! combined layer volumetric fraction of liquid water + real(rkind) :: l1Enthalpy,l2Enthalpy ! enthalpy in the two layers identified for combination (J m-3) + real(rkind) :: cEnthalpy ! combined layer enthalpy (J m-3) + real(rkind) :: fLiq ! fraction of liquid water at the combined temperature cTemp + real(rkind),parameter :: eTol=1.e-1_rkind ! tolerance for the enthalpy-->temperature conversion (J m-3) integer(i4b) :: nSnow ! number of snow layers integer(i4b) :: nSoil ! number of soil layers integer(i4b) :: nLayers ! total number of layers @@ -390,7 +390,7 @@ subroutine layer_combine(mpar_data,prog_data,diag_data,flux_data,indx_data,iSnow ! compute volumetric fraction of ice and liquid water cVolFracLiq = fLiq *cBulkDenWat/iden_water - cVolFracIce = (1._dp - fLiq)*cBulkDenWat/iden_ice + cVolFracIce = (1._rkind - fLiq)*cBulkDenWat/iden_ice ! end association of local variables with information in the data structures end associate @@ -459,7 +459,7 @@ subroutine rmLyAllVars(dataStruct,metaStruct,iSnow,nSnow,nLayers,err,message) integer(i4b) :: ivar ! variable index integer(i4b) :: ix_lower ! lower bound of the vector integer(i4b) :: ix_upper ! upper bound of the vector - real(dp),allocatable :: tempVec_dp(:) ! temporary vector (double precision) + real(rkind),allocatable :: tempVec_rkind(:) ! temporary vector (double precision) integer(i4b),allocatable :: tempVec_i4b(:) ! temporary vector (integer) character(LEN=256) :: cmessage ! error message of downwind routine ! initialize error control @@ -493,20 +493,20 @@ subroutine rmLyAllVars(dataStruct,metaStruct,iSnow,nSnow,nLayers,err,message) ! check allocated if(.not.allocated(dataStruct%var(ivar)%dat))then; err=20; message='data vector is not allocated'; return; end if ! allocate the temporary vector - allocate(tempVec_dp(ix_lower:ix_upper-1), stat=err) + allocate(tempVec_rkind(ix_lower:ix_upper-1), stat=err) if(err/=0)then; err=20; message=trim(message)//'unable to allocate temporary vector'; return; end if ! copy elements across to the temporary vector - if(iSnow>=ix_lower) tempVec_dp(iSnow) = realMissing ! set merged layer to missing (fill in later) - if(iSnow>ix_lower) tempVec_dp(ix_lower:iSnow-1) = dataStruct%var(ivar)%dat(ix_lower:iSnow-1) - if(iSnow+1=ix_lower) tempVec_rkind(iSnow) = realMissing ! set merged layer to missing (fill in later) + if(iSnow>ix_lower) tempVec_rkind(ix_lower:iSnow-1) = dataStruct%var(ivar)%dat(ix_lower:iSnow-1) + if(iSnow+11)then - do k=2,n - arth_r(k) = arth_r(k-1) + increment - end do - end if - END FUNCTION arth_r + !FUNCTION arth_r(first,increment,n) + !implicit none + !REAL(SP), INTENT(IN) :: first,increment + !INTEGER(I4B), INTENT(IN) :: n + !REAL(SP), DIMENSION(n) :: arth_r + !INTEGER(I4B) :: k + !arth_r(1)=first + !if(n>1)then + ! do k=2,n + ! arth_r(k) = arth_r(k-1) + increment + ! end do + !end if + !END FUNCTION arth_r ! ------------------------------------------------------------------------------------------------ FUNCTION arth_d(first,increment,n) implicit none - REAL(DP), INTENT(IN) :: first,increment + real(rkind), INTENT(IN) :: first,increment INTEGER(I4B), INTENT(IN) :: n - REAL(DP), DIMENSION(n) :: arth_d + real(rkind), DIMENSION(n) :: arth_d INTEGER(I4B) :: k arth_d(1)=first if(n>1)then @@ -62,11 +62,11 @@ END FUNCTION arth_i SUBROUTINE indexx(arr,index) IMPLICIT NONE !INTEGER(I4B), DIMENSION(:), INTENT(IN) :: arr - REAL(DP), DIMENSION(:), INTENT(IN) :: arr + real(rkind), DIMENSION(:), INTENT(IN) :: arr INTEGER(I4B), DIMENSION(:), INTENT(OUT) :: index INTEGER(I4B), PARAMETER :: NN=15, NSTACK=50 !INTEGER(I4B) :: a - REAL(DP) :: a + real(rkind) :: a INTEGER(I4B) :: n,k,i,j,indext,jstack,l,r INTEGER(I4B), DIMENSION(NSTACK) :: istack n=size(arr) diff --git a/build/source/engine/nrtype.f90 b/build/source/engine/nrtype.f90 index 3e1c3de34..c6ea58b9d 100755 --- a/build/source/engine/nrtype.f90 +++ b/build/source/engine/nrtype.f90 @@ -8,6 +8,7 @@ MODULE nrtype INTEGER, PARAMETER :: SP = KIND(1.0) INTEGER, PARAMETER :: DP = KIND(1.0D0) INTEGER, PARAMETER :: QP = KIND(1.0D0) + INTEGER, PARAMETER :: rkind = DP !INTEGER, PARAMETER :: QP = SELECTED_REAL_KIND(32) INTEGER, PARAMETER :: SPC = KIND((1.0,1.0)) INTEGER, PARAMETER :: DPC = KIND((1.0D0,1.0D0)) @@ -18,11 +19,11 @@ MODULE nrtype REAL(SP), PARAMETER :: TWOPI=6.283185307179586476925286766559005768394_sp REAL(SP), PARAMETER :: SQRT2=1.41421356237309504880168872420969807856967_sp REAL(SP), PARAMETER :: EULER=0.5772156649015328606065120900824024310422_sp - REAL(DP), PARAMETER :: PI_D=3.141592653589793238462643383279502884197_dp - REAL(DP), PARAMETER :: PIO2_D=1.57079632679489661923132169163975144209858_dp - REAL(DP), PARAMETER :: TWOPI_D=6.283185307179586476925286766559005768394_dp + real(rkind), PARAMETER :: PI_D=3.141592653589793238462643383279502884197_rkind + real(rkind), PARAMETER :: PIO2_D=1.57079632679489661923132169163975144209858_rkind + real(rkind), PARAMETER :: TWOPI_D=6.283185307179586476925286766559005768394_rkind ! missing values - real(qp), parameter :: nr_quadMissing=-9999._qp ! missing quadruple precision number - real(dp), parameter :: nr_realMissing=-9999._dp ! missing double precision number + real(rkind), parameter :: nr_quadMissing=-9999._qp ! missing quadruple precision number + real(rkind), parameter :: nr_realMissing=-9999._rkind ! missing double precision number integer(i4b), parameter :: nr_integerMissing=-9999 ! missing integer END MODULE nrtype diff --git a/build/source/engine/opSplittin.f90 b/build/source/engine/opSplittin.f90 index 3020ae20f..c1ba5b2df 100755 --- a/build/source/engine/opSplittin.f90 +++ b/build/source/engine/opSplittin.f90 @@ -147,10 +147,10 @@ module opSplittin_module integer(i4b),parameter :: nDomains=4 ! number of domains (vegetation, snow, soil, and aquifer) ! control parameters -real(dp),parameter :: valueMissing=-9999._dp ! missing value -real(dp),parameter :: verySmall=1.e-12_dp ! a very small number (used to check consistency) -real(dp),parameter :: veryBig=1.e+20_dp ! a very big number -real(dp),parameter :: dx = 1.e-8_dp ! finite difference increment +real(rkind),parameter :: valueMissing=-9999._rkind ! missing value +real(rkind),parameter :: verySmall=1.e-12_rkind ! a very small number (used to check consistency) +real(rkind),parameter :: veryBig=1.e+20_rkind ! a very big number +real(rkind),parameter :: dx = 1.e-8_rkind ! finite difference increment contains @@ -210,7 +210,7 @@ subroutine opSplittin(& integer(i4b),intent(in) :: nSoil ! number of soil layers integer(i4b),intent(in) :: nLayers ! total number of layers integer(i4b),intent(in) :: nState ! total number of state variables - real(dp),intent(inout) :: dt ! time step (seconds) + real(rkind),intent(inout) :: dt ! time step (seconds) logical(lgt),intent(in) :: firstSubStep ! flag to indicate if we are processing the first sub-step logical(lgt),intent(in) :: computeVegFlux ! flag to indicate if we are computing fluxes over vegetation (.false. means veg is buried with snow) ! input/output: data structures @@ -225,7 +225,7 @@ subroutine opSplittin(& type(var_dlength),intent(in) :: bvar_data ! model variables for the local basin type(model_options),intent(in) :: model_decisions(:) ! model decisions ! output: model control - real(dp),intent(out) :: dtMultiplier ! substep multiplier (-) + real(rkind),intent(out) :: dtMultiplier ! substep multiplier (-) logical(lgt),intent(out) :: tooMuchMelt ! flag to denote that ice is insufficient to support melt logical(lgt),intent(out) :: stepFailure ! flag to denote step failure integer(i4b),intent(out) :: err ! error code @@ -249,19 +249,19 @@ subroutine opSplittin(& type(var_dlength) :: diag_temp ! temporary model diagnostic variables type(var_dlength) :: flux_temp ! temporary model fluxes type(var_dlength) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables - real(dp),dimension(nLayers) :: mLayerVolFracIceInit ! initial vector for volumetric fraction of ice (-) + real(rkind),dimension(nLayers) :: mLayerVolFracIceInit ! initial vector for volumetric fraction of ice (-) ! ------------------------------------------------------------------------------------------------------ ! * operator splitting ! ------------------------------------------------------------------------------------------------------ ! minimum timestep - real(dp),parameter :: dtmin_coupled=1800._dp ! minimum time step for the fully coupled solution (seconds) - real(dp),parameter :: dtmin_split=60._dp ! minimum time step for the fully split solution (seconds) - real(dp),parameter :: dtmin_scalar=10._dp ! minimum time step for the scalar solution (seconds) - real(dp) :: dt_min ! minimum time step (seconds) - real(dp) :: dtInit ! initial time step (seconds) + real(rkind),parameter :: dtmin_coupled=1800._rkind ! minimum time step for the fully coupled solution (seconds) + real(rkind),parameter :: dtmin_split=60._rkind ! minimum time step for the fully split solution (seconds) + real(rkind),parameter :: dtmin_scalar=10._rkind ! minimum time step for the scalar solution (seconds) + real(rkind) :: dt_min ! minimum time step (seconds) + real(rkind) :: dtInit ! initial time step (seconds) ! explicit error tolerance (depends on state type split, so defined here) - real(dp),parameter :: errorTolLiqFlux=0.01_dp ! error tolerance in the explicit solution (liquid flux) - real(dp),parameter :: errorTolNrgFlux=10._dp ! error tolerance in the explicit solution (energy flux) + real(rkind),parameter :: errorTolLiqFlux=0.01_rkind ! error tolerance in the explicit solution (liquid flux) + real(rkind),parameter :: errorTolNrgFlux=10._rkind ! error tolerance in the explicit solution (energy flux) ! number of substeps taken for a given split integer(i4b) :: nSubsteps ! number of substeps taken for a given split ! named variables defining the coupling and solution method @@ -443,12 +443,12 @@ subroutine opSplittin(& do iVar=1,size(flux_meta) ! loop through fluxes if(flux2state_orig(iVar)%state1==integerMissing .and. flux2state_orig(iVar)%state2==integerMissing) cycle ! flux does not depend on state (e.g., input) if(flux2state_orig(iVar)%state1==iname_watCanopy .and. .not.computeVegFlux) cycle ! use input fluxes in cases where there is no canopy - flux_data%var(iVar)%dat(:) = 0._dp + flux_data%var(iVar)%dat(:) = 0._rkind end do ! initialize derivatives do iVar=1,size(deriv_meta) - deriv_data%var(iVar)%dat(:) = 0._dp + deriv_data%var(iVar)%dat(:) = 0._rkind end do ! ========================================================================================================================================== @@ -978,7 +978,7 @@ subroutine opSplittin(& end do ! use step halving if unable to complete the fully coupled solution in one substep - if(ixCoupling/=fullyCoupled .or. nSubsteps>1) dtMultiplier=0.5_dp + if(ixCoupling/=fullyCoupled .or. nSubsteps>1) dtMultiplier=0.5_rkind ! compute the melt in each snow and soil layer if(nSnow>0) mLayerMeltFreeze( 1:nSnow ) = -(mLayerVolFracIce( 1:nSnow ) - mLayerVolFracIceInit( 1:nSnow ))*iden_ice diff --git a/build/source/engine/pOverwrite.f90 b/build/source/engine/pOverwrite.f90 index d90b5bdd5..34648eccd 100755 --- a/build/source/engine/pOverwrite.f90 +++ b/build/source/engine/pOverwrite.f90 @@ -51,7 +51,7 @@ subroutine pOverwrite(ixVeg,ixSoil,defaultParam,err,message) integer(i4b),intent(in) :: ixVeg ! vegetation category integer(i4b),intent(in) :: ixSoil ! soil category ! define output - real(dp),intent(inout) :: defaultParam(:) ! default model parameters + real(rkind),intent(inout) :: defaultParam(:) ! default model parameters integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! Start procedure here diff --git a/build/source/engine/paramCheck.f90 b/build/source/engine/paramCheck.f90 index 8ca2fecef..0be4f5aca 100755 --- a/build/source/engine/paramCheck.f90 +++ b/build/source/engine/paramCheck.f90 @@ -49,9 +49,9 @@ subroutine paramCheck(mpar_data,err,message) character(*),intent(out) :: message ! error message ! local variables integer(i4b) :: iLayer ! index of model layers - real(dp),dimension(5) :: zminLayer ! minimum layer depth in each layer (m) - real(dp),dimension(4) :: zmaxLayer_lower ! lower value of maximum layer depth - real(dp),dimension(4) :: zmaxLayer_upper ! upper value of maximum layer depth + real(rkind),dimension(5) :: zminLayer ! minimum layer depth in each layer (m) + real(rkind),dimension(4) :: zmaxLayer_lower ! lower value of maximum layer depth + real(rkind),dimension(4) :: zmaxLayer_upper ! upper value of maximum layer depth ! Start procedure here err=0; message="paramCheck/" @@ -63,7 +63,7 @@ subroutine paramCheck(mpar_data,err,message) select case(model_decisions(iLookDECISIONS%snowLayers)%iDecision) ! SNTHERM option case(sameRulesAllLayers) - if(mpar_data%var(iLookPARAM%zmax)%dat(1)/mpar_data%var(iLookPARAM%zmin)%dat(1) < 2.5_dp)then + if(mpar_data%var(iLookPARAM%zmax)%dat(1)/mpar_data%var(iLookPARAM%zmin)%dat(1) < 2.5_rkind)then message=trim(message)//'zmax must be at least 2.5 times larger than zmin: this avoids merging layers that have just been divided' err=20; return end if @@ -93,7 +93,7 @@ subroutine paramCheck(mpar_data,err,message) err=20; return end if ! ensure that the maximum thickness is 3 times greater than the minimum thickness - if(zmaxLayer_upper(iLayer)/zminLayer(iLayer) < 2.5_dp .or. zmaxLayer_upper(iLayer)/zminLayer(iLayer+1) < 2.5_dp)then + if(zmaxLayer_upper(iLayer)/zminLayer(iLayer) < 2.5_rkind .or. zmaxLayer_upper(iLayer)/zminLayer(iLayer+1) < 2.5_rkind)then write(*,'(a,1x,3(f20.10,1x))') 'zmaxLayer_upper(iLayer), zminLayer(iLayer), zminLayer(iLayer+1) = ', & zmaxLayer_upper(iLayer), zminLayer(iLayer), zminLayer(iLayer+1) write(message,'(a,3(i0,a))') trim(message)//'zmaxLayer_upper for layer ',iLayer,' must be 2.5 times larger than zminLayer for layers ',& diff --git a/build/source/engine/qTimeDelay.f90 b/build/source/engine/qTimeDelay.f90 index 4997b4577..ba5a5aa16 100755 --- a/build/source/engine/qTimeDelay.f90 +++ b/build/source/engine/qTimeDelay.f90 @@ -40,7 +40,7 @@ module qTimeDelay_module subroutine qOverland(& ! input ixRouting, & ! index for routing method - averageTotalRunoff, & ! total runoff to the channel from all active components (m s-1) + averageTotalRunoff, & ! total runoff to the channel from all active components (m s-1) fracFuture, & ! fraction of runoff in future time steps (m s-1) qFuture, & ! runoff in future time steps (m s-1) ! output @@ -50,12 +50,12 @@ subroutine qOverland(& implicit none ! input integer(i4b),intent(in) :: ixRouting ! index for routing method - real(dp),intent(in) :: averageTotalRunoff ! total runoff to the channel from all active components (m s-1) - real(dp),intent(in) :: fracFuture(:) ! fraction of runoff in future time steps (m s-1) - real(dp),intent(inout) :: qFuture(:) ! runoff in future time steps (m s-1) + real(rkind),intent(in) :: averageTotalRunoff ! total runoff to the channel from all active components (m s-1) + real(rkind),intent(in) :: fracFuture(:) ! fraction of runoff in future time steps (m s-1) + real(rkind),intent(inout) :: qFuture(:) ! runoff in future time steps (m s-1) ! output - real(dp),intent(out) :: averageInstantRunoff ! instantaneous runoff (m s-1) - real(dp),intent(out) :: averageRoutedRunoff ! routed runoff (m s-1) + real(rkind),intent(out) :: averageInstantRunoff ! instantaneous runoff (m s-1) + real(rkind),intent(out) :: averageRoutedRunoff ! routed runoff (m s-1) integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! internal @@ -85,7 +85,7 @@ subroutine qOverland(& do iFuture=2,nTDH qFuture(iFuture-1) = qFuture(iFuture) end do - qFuture(nTDH) = 0._dp + qFuture(nTDH) = 0._rkind ! ** error checking case default; err=20; message=trim(message)//'cannot find option for sub-grid routing'; return diff --git a/build/source/engine/read_attrb.f90 b/build/source/engine/read_attrb.f90 index 652f1f249..8f13ac0f9 100755 --- a/build/source/engine/read_attrb.f90 +++ b/build/source/engine/read_attrb.f90 @@ -239,7 +239,7 @@ subroutine read_attrb(attrFile,nGRU,attrStruct,typeStruct,idStruct,err,message) integer(i4b),parameter :: numerical=102 ! named variable to denote numerical data integer(i4b),parameter :: idrelated=103 ! named variable to denote ID related data integer(i4b) :: categorical_var(1) ! temporary categorical variable from local attributes netcdf file - real(dp) :: numeric_var(1) ! temporary numeric variable from local attributes netcdf file + real(rkind) :: numeric_var(1) ! temporary numeric variable from local attributes netcdf file integer(8) :: idrelated_var(1) ! temporary ID related variable from local attributes netcdf file ! define mapping variables diff --git a/build/source/engine/read_force.f90 b/build/source/engine/read_force.f90 index bf3435a60..fbfa51baa 100755 --- a/build/source/engine/read_force.f90 +++ b/build/source/engine/read_force.f90 @@ -63,8 +63,8 @@ module read_force_module public::read_force ! global parameters -real(dp),parameter :: verySmall=1e-3_dp ! tiny number -real(dp),parameter :: smallOffset=1.e-8_dp ! small offset (units=days) to force ih=0 at the start of the day +real(rkind),parameter :: verySmall=1e-3_rkind ! tiny number +real(rkind),parameter :: smallOffset=1.e-8_rkind ! small offset (units=days) to force ih=0 at the start of the day contains @@ -95,8 +95,8 @@ subroutine read_force(istep,iFile,iRead,ncid,time_data,forcStruct,err,message) integer(i4b) :: iGRU,iHRU ! index of GRU and HRU character(len=256),save :: infile ! filename character(len=256) :: cmessage ! error message for downwind routine - real(dp) :: startJulDay ! julian day at the start of the year - real(dp) :: currentJulday ! Julian day of current time step + real(rkind) :: startJulDay ! julian day at the start of the year + real(rkind) :: currentJulday ! Julian day of current time step logical(lgt),parameter :: checkTime=.false. ! flag to check the time ! Start procedure here err=0; message="read_force/" @@ -173,7 +173,7 @@ subroutine read_force(istep,iFile,iRead,ncid,time_data,forcStruct,err,message) ! compute the julian day at the start of the year call compjulday(time_data(iLookTIME%iyyy), & ! input = year - 1, 1, 1, 1, 0._dp, & ! input = month, day, hour, minute, second + 1, 1, 1, 1, 0._rkind, & ! input = month, day, hour, minute, second startJulDay,err,cmessage) ! output = julian day (fraction of day) + error control if(err/=0)then; message=trim(message)//trim(cmessage); return; end if @@ -182,7 +182,7 @@ subroutine read_force(istep,iFile,iRead,ncid,time_data,forcStruct,err,message) time_data(iLookTIME%im), & ! input = month time_data(iLookTIME%id), & ! input = day time_data(iLookTIME%ih), & ! input = hour - time_data(iLookTIME%imin),0._dp, & ! input = minute/second + time_data(iLookTIME%imin),0._rkind, & ! input = minute/second currentJulday,err,cmessage) ! output = julian day (fraction of day) + error control if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! compute the time since the start of the year (in fractional days) @@ -235,7 +235,7 @@ subroutine getFirstTimestep(currentJulday,iFile,iRead,ncid,err,message) USE nr_utility_module,only:arth ! get a sequence of numbers implicit none ! define input - real(dp),intent(in) :: currentJulday ! Julian day of current time step + real(rkind),intent(in) :: currentJulday ! Julian day of current time step ! define input-output variables integer(i4b),intent(inout) :: iFile ! index of current forcing file in forcing file list integer(i4b),intent(inout) :: iRead ! index of read position in time dimension in current netcdf file @@ -252,9 +252,9 @@ subroutine getFirstTimestep(currentJulday,iFile,iRead,ncid,err,message) character(len=256),save :: infile ! filename character(len=256) :: cmessage ! error message for downwind routine integer(i4b) :: nFiles ! number of forcing files - real(dp) :: timeVal(1) ! single time value (restrict time read) - real(dp),allocatable :: fileTime(:) ! array of time from netcdf file - real(dp),allocatable :: diffTime(:) ! array of time differences + real(rkind) :: timeVal(1) ! single time value (restrict time read) + real(rkind),allocatable :: fileTime(:) ! array of time from netcdf file + real(rkind),allocatable :: diffTime(:) ! array of time differences ! Start procedure here err=0; message="getFirstTimestep/" @@ -348,7 +348,7 @@ subroutine openForcingFile(iFile,infile,ncId,err,message) character(len=256) :: cmessage ! error message for downwind routine integer(i4b) :: iyyy,im,id,ih,imin ! date integer(i4b) :: ih_tz,imin_tz ! time zone information - real(dp) :: dsec,dsec_tz ! seconds + real(rkind) :: dsec,dsec_tz ! seconds integer(i4b) :: varId ! variable identifier integer(i4b) :: mode ! netcdf file mode integer(i4b) :: attLen ! attribute length @@ -378,8 +378,8 @@ subroutine openForcingFile(iFile,infile,ncId,err,message) case('ncTime'); tmZoneOffsetFracDay = sign(1, ih_tz) * fracDay(ih_tz, & ! time zone hour imin_tz, & ! time zone minute dsec_tz) ! time zone second - case('utcTime'); tmZoneOffsetFracDay = 0._dp - case('localTime'); tmZoneOffsetFracDay = 0._dp + case('utcTime'); tmZoneOffsetFracDay = 0._rkind + case('localTime'); tmZoneOffsetFracDay = 0._rkind case default; err=20; message=trim(message)//'unable to identify time zone info option'; return end select ! (option time zone option) @@ -391,10 +391,10 @@ subroutine openForcingFile(iFile,infile,ncId,err,message) ! get the time multiplier needed to convert time to units of days select case( trim( refTimeString(1:index(refTimeString,' ')) ) ) - case('seconds'); forcFileInfo(iFile)%convTime2Days=86400._dp - case('minutes'); forcFileInfo(iFile)%convTime2Days=1440._dp - case('hours'); forcFileInfo(iFile)%convTime2Days=24._dp - case('days'); forcFileInfo(iFile)%convTime2Days=1._dp + case('seconds'); forcFileInfo(iFile)%convTime2Days=86400._rkind + case('minutes'); forcFileInfo(iFile)%convTime2Days=1440._rkind + case('hours'); forcFileInfo(iFile)%convTime2Days=24._rkind + case('days'); forcFileInfo(iFile)%convTime2Days=1._rkind case default; message=trim(message)//'unable to identify time units'; err=20; return end select @@ -409,7 +409,7 @@ subroutine readForcingData(currentJulday,ncId,iFile,iRead,nHRUlocal,time_data,fo USE time_utils_module,only:compJulday ! convert calendar date to julian day USE get_ixname_module,only:get_ixforce ! identify index of named variable ! dummy variables - real(dp),intent(in) :: currentJulday ! Julian day of current time step + real(rkind),intent(in) :: currentJulday ! Julian day of current time step integer(i4b) ,intent(in) :: ncId ! NetCDF ID integer(i4b) ,intent(in) :: iFile ! index of forcing file integer(i4b) ,intent(in) :: iRead ! index in data file @@ -422,7 +422,7 @@ subroutine readForcingData(currentJulday,ncId,iFile,iRead,nHRUlocal,time_data,fo character(len=256) :: cmessage ! error message for downwind routine integer(i4b) :: varId ! variable identifier character(len = nf90_max_name) :: varName ! dimenison name - real(dp) :: varTime(1) ! time variable of current forcing data step being read + real(rkind) :: varTime(1) ! time variable of current forcing data step being read ! other local variables integer(i4b) :: iGRU,iHRU ! index of GRU and HRU integer(i4b) :: iHRU_global ! index of HRU in the NetCDF file @@ -431,11 +431,11 @@ subroutine readForcingData(currentJulday,ncId,iFile,iRead,nHRUlocal,time_data,fo integer(i4b) :: iNC ! loop through variables in forcing file integer(i4b) :: iVar ! index of forcing variable in forcing data vector logical(lgt),parameter :: checkTime=.false. ! flag to check the time - real(dp) :: dsec ! double precision seconds (not used) - real(dp) :: dataJulDay ! julian day of current forcing data step being read - real(dp),dimension(nHRUlocal) :: dataVec ! vector of data - real(dp),dimension(1) :: dataVal ! single data value - real(dp),parameter :: dataMin=-1._dp ! minimum allowable data value (all forcing variables should be positive) + real(rkind) :: dsec ! double precision seconds (not used) + real(rkind) :: dataJulDay ! julian day of current forcing data step being read + real(rkind),dimension(nHRUlocal) :: dataVec ! vector of data + real(rkind),dimension(1) :: dataVal ! single data value + real(rkind),parameter :: dataMin=-1._rkind ! minimum allowable data value (all forcing variables should be positive) logical(lgt),dimension(size(forc_meta)) :: checkForce ! flags to check forcing data variables exist logical(lgt),parameter :: simultaneousRead=.true. ! flag to denote reading all HRUs at once ! Start procedure here diff --git a/build/source/engine/read_param.f90 b/build/source/engine/read_param.f90 index 05119d36f..7a9cbb273 100755 --- a/build/source/engine/read_param.f90 +++ b/build/source/engine/read_param.f90 @@ -90,7 +90,7 @@ subroutine read_param(iRunMode,checkHRU,startGRU,nHRU,nGRU,idStruct,mparStruct,b ! data in the netcdf file integer(i4b) :: parLength ! length of the parameter data integer(8),allocatable :: hruId(:) ! HRU identifier in the file - real(dp),allocatable :: parVector(:) ! model parameter vector + real(rkind),allocatable :: parVector(:) ! model parameter vector logical :: fexist ! inquire whether the parmTrial file exists integer(i4b) :: fHRU ! index of HRU in input file diff --git a/build/source/engine/read_pinit.f90 b/build/source/engine/read_pinit.f90 index 2a0b350b1..d0103d615 100755 --- a/build/source/engine/read_pinit.f90 +++ b/build/source/engine/read_pinit.f90 @@ -132,9 +132,9 @@ subroutine read_pinit(filenm,isLocal,mpar_meta,parFallback,err,message) ! check we have populated all variables ! NOTE: ultimately need a need a parameter dictionary to ensure that the parameters used are populated if(.not.backwardsCompatible)then ! if we add new variables in future versions of the code, then some may be missing in the input file - if(any(parFallback(:)%default_val < 0.99_dp*realMissing))then + if(any(parFallback(:)%default_val < 0.99_rkind*realMissing))then do ivar=1,size(parFallback) - if(parFallback(ivar)%default_val < 0.99_dp*realMissing)then + if(parFallback(ivar)%default_val < 0.99_rkind*realMissing)then err=40; message=trim(message)//"variableNonexistent[var="//trim(mpar_meta(ivar)%varname)//"]"; return end if end do @@ -143,8 +143,8 @@ subroutine read_pinit(filenm,isLocal,mpar_meta,parFallback,err,message) else ! (need backwards compatibility) if(isLocal)then if(model_decisions(iLookDECISIONS%cIntercept)%iDecision == unDefined)then - parFallback(iLookPARAM%canopyWettingFactor)%default_val = 1._dp ! maximum wetted fraction of the canopy (-) - parFallback(iLookPARAM%canopyWettingExp)%default_val = 0.666666667_dp ! exponent in canopy wetting function (-) + parFallback(iLookPARAM%canopyWettingFactor)%default_val = 1._rkind ! maximum wetted fraction of the canopy (-) + parFallback(iLookPARAM%canopyWettingExp)%default_val = 0.666666667_rkind ! exponent in canopy wetting function (-) end if end if end if diff --git a/build/source/engine/run_oneGRU.f90 b/build/source/engine/run_oneGRU.f90 index 1925774e6..149e9fc02 100755 --- a/build/source/engine/run_oneGRU.f90 +++ b/build/source/engine/run_oneGRU.f90 @@ -74,7 +74,7 @@ module run_oneGRU_module ! simulation for a single GRU subroutine run_oneGRU(& ! model control - gruInfo, & ! intent(inout): HRU information for given GRU (# HRUs, #snow+soil layers) + gruInfo, & ! intent(inout): HRU information for given GRU (# HRUs, #snow+soil layers) dt_init, & ! intent(inout): used to initialize the length of the sub-step for each HRU ixComputeVegFlux, & ! intent(inout): flag to indicate if we are computing fluxes over vegetation (false=no, true=yes) ! data structures (input) @@ -99,12 +99,12 @@ subroutine run_oneGRU(& USE qTimeDelay_module,only:qOverland ! module to route water through an "unresolved" river network ! ----- define dummy variables ------------------------------------------------------------------------------------------ - + implicit none ! model control - type(gru2hru_map) , intent(inout) :: gruInfo ! HRU information for given GRU (# HRUs, #snow+soil layers) - real(dp) , intent(inout) :: dt_init(:) ! used to initialize the length of the sub-step for each HRU + type(gru2hru_map) , intent(inout) :: gruInfo ! HRU information for given GRU (# HRUs, #snow+soil layers) + real(rkind) , intent(inout) :: dt_init(:) ! used to initialize the length of the sub-step for each HRU integer(i4b) , intent(inout) :: ixComputeVegFlux(:) ! flag to indicate if we are computing fluxes over vegetation (false=no, true=yes) ! data structures (input) integer(i4b) , intent(in) :: timeVec(:) ! integer vector -- model time data @@ -128,11 +128,11 @@ subroutine run_oneGRU(& ! general local variables character(len=256) :: cmessage ! error message integer(i4b) :: iHRU ! HRU index - integer(i4b) :: jHRU,kHRU ! index of the hydrologic response unit + integer(i4b) :: jHRU,kHRU ! index of the hydrologic response unit integer(i4b) :: nSnow ! number of snow layers integer(i4b) :: nSoil ! number of soil layers integer(i4b) :: nLayers ! total number of layers - real(dp) :: fracHRU ! fractional area of a given HRU (-) + real(rkind) :: fracHRU ! fractional area of a given HRU (-) logical(lgt) :: computeVegFluxFlag ! flag to indicate if we are computing fluxes over vegetation (.false. means veg is buried with snow) ! initialize error control @@ -141,19 +141,19 @@ subroutine run_oneGRU(& ! ----- basin initialization -------------------------------------------------------------------------------------------- ! initialize runoff variables - bvarData%var(iLookBVAR%basin__SurfaceRunoff)%dat(1) = 0._dp ! surface runoff (m s-1) - bvarData%var(iLookBVAR%basin__SoilDrainage)%dat(1) = 0._dp ! soil drainage (m s-1) - bvarData%var(iLookBVAR%basin__ColumnOutflow)%dat(1) = 0._dp ! outflow from all "outlet" HRUs (those with no downstream HRU) - bvarData%var(iLookBVAR%basin__TotalRunoff)%dat(1) = 0._dp ! total runoff to the channel from all active components (m s-1) + bvarData%var(iLookBVAR%basin__SurfaceRunoff)%dat(1) = 0._rkind ! surface runoff (m s-1) + bvarData%var(iLookBVAR%basin__SoilDrainage)%dat(1) = 0._rkind ! soil drainage (m s-1) + bvarData%var(iLookBVAR%basin__ColumnOutflow)%dat(1) = 0._rkind ! outflow from all "outlet" HRUs (those with no downstream HRU) + bvarData%var(iLookBVAR%basin__TotalRunoff)%dat(1) = 0._rkind ! total runoff to the channel from all active components (m s-1) ! initialize baseflow variables - bvarData%var(iLookBVAR%basin__AquiferRecharge)%dat(1) = 0._dp ! recharge to the aquifer (m s-1) - bvarData%var(iLookBVAR%basin__AquiferBaseflow)%dat(1) = 0._dp ! baseflow from the aquifer (m s-1) - bvarData%var(iLookBVAR%basin__AquiferTranspire)%dat(1) = 0._dp ! transpiration loss from the aquifer (m s-1) + bvarData%var(iLookBVAR%basin__AquiferRecharge)%dat(1) = 0._rkind ! recharge to the aquifer (m s-1) + bvarData%var(iLookBVAR%basin__AquiferBaseflow)%dat(1) = 0._rkind ! baseflow from the aquifer (m s-1) + bvarData%var(iLookBVAR%basin__AquiferTranspire)%dat(1) = 0._rkind ! transpiration loss from the aquifer (m s-1) ! initialize total inflow for each layer in a soil column do iHRU=1,gruInfo%hruCount - fluxHRU%hru(iHRU)%var(iLookFLUX%mLayerColumnInflow)%dat(:) = 0._dp + fluxHRU%hru(iHRU)%var(iLookFLUX%mLayerColumnInflow)%dat(:) = 0._rkind end do ! *********************************************************************************************************************** @@ -197,7 +197,7 @@ subroutine run_oneGRU(& ! error control err,cmessage) ! intent(out): error control if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; endif - + ! update layer numbers that could be changed in run_oneHRU -- needed for model output gruInfo%hruInfo(iHRU)%nSnow = nSnow gruInfo%hruInfo(iHRU)%nSoil = nSoil @@ -235,7 +235,7 @@ subroutine run_oneGRU(& end if ! ----- calculate weighted basin (GRU) fluxes -------------------------------------------------------------------------------------- - + ! increment basin surface runoff (m s-1) bvarData%var(iLookBVAR%basin__SurfaceRunoff)%dat(1) = bvarData%var(iLookBVAR%basin__SurfaceRunoff)%dat(1) + fluxHRU%hru(iHRU)%var(iLookFLUX%scalarSurfaceRunoff)%dat(1) * fracHRU @@ -245,7 +245,7 @@ subroutine run_oneGRU(& ! increment aquifer variables -- ONLY if aquifer baseflow is computed individually for each HRU and aquifer is run ! NOTE: groundwater computed later for singleBasin if(model_decisions(iLookDECISIONS%spatial_gw)%iDecision == localColumn .and. model_decisions(iLookDECISIONS%groundwatr)%iDecision == bigBucket) then - + bvarData%var(iLookBVAR%basin__AquiferRecharge)%dat(1) = bvarData%var(iLookBVAR%basin__AquiferRecharge)%dat(1) + fluxHRU%hru(iHRU)%var(iLookFLUX%scalarSoilDrainage)%dat(1) * fracHRU bvarData%var(iLookBVAR%basin__AquiferTranspire)%dat(1) = bvarData%var(iLookBVAR%basin__AquiferTranspire)%dat(1) + fluxHRU%hru(iHRU)%var(iLookFLUX%scalarAquiferTranspire)%dat(1) * fracHRU bvarData%var(iLookBVAR%basin__AquiferBaseflow)%dat(1) = bvarData%var(iLookBVAR%basin__AquiferBaseflow)%dat(1) & @@ -273,7 +273,7 @@ subroutine run_oneGRU(& else ! no aquifer bvarData%var(iLookBVAR%basin__TotalRunoff)%dat(1) = bvarData%var(iLookBVAR%basin__SurfaceRunoff)%dat(1) + bvarData%var(iLookBVAR%basin__ColumnOutflow)%dat(1)/totalArea + bvarData%var(iLookBVAR%basin__SoilDrainage)%dat(1) - endif + endif ! perform the routing associate(totalArea => bvarData%var(iLookBVAR%basin__totalArea)%dat(1) ) diff --git a/build/source/engine/run_oneHRU.f90 b/build/source/engine/run_oneHRU.f90 index 1632e1f77..ea882d375 100755 --- a/build/source/engine/run_oneHRU.f90 +++ b/build/source/engine/run_oneHRU.f90 @@ -114,7 +114,7 @@ subroutine run_oneHRU(& ! model control integer(8) , intent(in) :: hruId ! hruId - real(dp) , intent(inout) :: dt_init ! used to initialize the length of the sub-step for each HRU + real(rkind) , intent(inout) :: dt_init ! used to initialize the length of the sub-step for each HRU logical(lgt) , intent(inout) :: computeVegFlux ! flag to indicate if we are computing fluxes over vegetation (false=no, true=yes) integer(i4b) , intent(inout) :: nSnow,nSoil,nLayers ! number of snow and soil layers ! data structures (input) @@ -137,7 +137,7 @@ subroutine run_oneHRU(& ! local variables character(len=256) :: cmessage ! error message - real(dp) , allocatable :: zSoilReverseSign(:) ! height at bottom of each soil layer, negative downwards (m) + real(rkind) , allocatable :: zSoilReverseSign(:) ! height at bottom of each soil layer, negative downwards (m) ! initialize error control err=0; write(message, '(A20,I0,A2)' ) 'run_oneHRU (hruId = ',hruId,')/' @@ -201,7 +201,7 @@ subroutine run_oneHRU(& ! ----- run the model -------------------------------------------------------------------------------------------------- ! initialize the number of flux calls - diagData%var(iLookDIAG%numFluxCalls)%dat(1) = 0._dp + diagData%var(iLookDIAG%numFluxCalls)%dat(1) = 0._rkind ! run the model for a single HRU call coupled_em(& diff --git a/build/source/engine/snowAlbedo.f90 b/build/source/engine/snowAlbedo.f90 index c536a437f..c1329f36b 100755 --- a/build/source/engine/snowAlbedo.f90 +++ b/build/source/engine/snowAlbedo.f90 @@ -81,7 +81,7 @@ subroutine snowAlbedo(& USE snow_utils_module,only:fracliquid ! compute fraction of liquid water at a given temperature ! -------------------------------------------------------------------------------------------------------------------------------------- ! input: model control - real(dp),intent(in) :: dt ! model time step + real(rkind),intent(in) :: dt ! model time step logical(lgt),intent(in) :: snowPresence ! logical flag to denote if snow is present ! input/output: data structures type(model_options),intent(in) :: model_decisions(:) ! model decisions @@ -95,16 +95,16 @@ subroutine snowAlbedo(& ! local variables integer(i4b),parameter :: ixVisible=1 ! named variable to define index in array of visible part of the spectrum integer(i4b),parameter :: ixNearIR=2 ! named variable to define index in array of near IR part of the spectrum - real(dp),parameter :: valueMissing=-9999._dp ! missing value -- will cause problems if snow albedo is ever used for the non-snow case - real(dp),parameter :: slushExp=10._dp ! "slush" exponent, to increase decay when snow is near Tfreeze - real(dp),parameter :: fractionLiqThresh=0.001_dp ! threshold for the fraction of liquid water to switch to spring albedo minimum - real(dp) :: fractionLiq ! fraction of liquid water (-) - real(dp) :: age1,age2,age3 ! aging factors (-) - real(dp) :: decayFactor ! albedo decay factor (-) - real(dp) :: refreshFactor ! albedo refreshment factor, representing albedo increase due to snowfall (-) - real(dp) :: albedoMin ! minimum albedo -- depends if in winter or spring conditions (-) - real(dp) :: fZen ! factor to modify albedo at low zenith angles (-) - real(dp),parameter :: bPar=2._dp ! empirical parameter in fZen + real(rkind),parameter :: valueMissing=-9999._rkind ! missing value -- will cause problems if snow albedo is ever used for the non-snow case + real(rkind),parameter :: slushExp=10._rkind ! "slush" exponent, to increase decay when snow is near Tfreeze + real(rkind),parameter :: fractionLiqThresh=0.001_rkind ! threshold for the fraction of liquid water to switch to spring albedo minimum + real(rkind) :: fractionLiq ! fraction of liquid water (-) + real(rkind) :: age1,age2,age3 ! aging factors (-) + real(rkind) :: decayFactor ! albedo decay factor (-) + real(rkind) :: refreshFactor ! albedo refreshment factor, representing albedo increase due to snowfall (-) + real(rkind) :: albedoMin ! minimum albedo -- depends if in winter or spring conditions (-) + real(rkind) :: fZen ! factor to modify albedo at low zenith angles (-) + real(rkind),parameter :: bPar=2._rkind ! empirical parameter in fZen ! initialize error control err=0; message='snowAlbedo/' ! -------------------------------------------------------------------------------------------------------------------------------------- @@ -188,18 +188,18 @@ subroutine snowAlbedo(& call computeAlbedo(spectralSnowAlbedoDiffuse(ixVisible),refreshFactor,decayFactor,albedoMaxVisible,albedoMinVisible) call computeAlbedo(spectralSnowAlbedoDiffuse(ixNearIR), refreshFactor,decayFactor,albedoMaxNearIR, albedoMinNearIR) ! compute factor to modify direct albedo at low zenith angles - if(cosZenith < 0.5_dp)then - fZen = (1._dp/bPar)*( ((1._dp + bPar)/(1._dp + 2._dp*bPar*cosZenith)) - 1._dp) + if(cosZenith < 0.5_rkind)then + fZen = (1._rkind/bPar)*( ((1._rkind + bPar)/(1._rkind + 2._rkind*bPar*cosZenith)) - 1._rkind) else - fZen = 0._dp + fZen = 0._rkind end if ! compute direct albedo - spectralSnowAlbedoDirect(ixVisible) = spectralSnowAlbedoDiffuse(ixVisible) + 0.4_dp*fZen*(1._dp - spectralSnowAlbedoDiffuse(ixVisible)) - spectralSnowAlbedoDirect(ixNearIR) = spectralSnowAlbedoDiffuse(ixNearIR) + 0.4_dp*fZen*(1._dp - spectralSnowAlbedoDiffuse(ixNearIR)) + spectralSnowAlbedoDirect(ixVisible) = spectralSnowAlbedoDiffuse(ixVisible) + 0.4_rkind*fZen*(1._rkind - spectralSnowAlbedoDiffuse(ixVisible)) + spectralSnowAlbedoDirect(ixNearIR) = spectralSnowAlbedoDiffuse(ixNearIR) + 0.4_rkind*fZen*(1._rkind - spectralSnowAlbedoDiffuse(ixNearIR)) ! compute average albedo - scalarSnowAlbedo = ( Frad_direct)*(Frad_vis*spectralSnowAlbedoDirect(ixVisible) + (1._dp - Frad_vis)*spectralSnowAlbedoDirect(ixNearIR) ) + & - (1._dp - Frad_direct)*(Frad_vis*spectralSnowAlbedoDirect(ixVisible) + (1._dp - Frad_vis)*spectralSnowAlbedoDirect(ixNearIR) ) + scalarSnowAlbedo = ( Frad_direct)*(Frad_vis*spectralSnowAlbedoDirect(ixVisible) + (1._rkind - Frad_vis)*spectralSnowAlbedoDirect(ixNearIR) ) + & + (1._rkind - Frad_direct)*(Frad_vis*spectralSnowAlbedoDirect(ixVisible) + (1._rkind - Frad_vis)*spectralSnowAlbedoDirect(ixNearIR) ) ! check that we identified the albedo option case default; err=20; message=trim(message)//'unable to identify option for snow albedo'; return @@ -207,7 +207,7 @@ subroutine snowAlbedo(& end select ! identify option for snow albedo ! check - if(scalarSnowAlbedo < 0._dp)then; err=20; message=trim(message)//'unable to identify option for snow albedo'; return; end if + if(scalarSnowAlbedo < 0._rkind)then; err=20; message=trim(message)//'unable to identify option for snow albedo'; return; end if ! end association to data structures end associate @@ -221,15 +221,15 @@ end subroutine snowAlbedo subroutine computeAlbedo(snowAlbedo,refreshFactor,decayFactor,albedoMax,albedoMin) implicit none ! dummy variables - real(dp),intent(inout) :: snowAlbedo ! snow albedo (-) - real(dp),intent(in) :: refreshFactor ! albedo refreshment factor (-) - real(dp),intent(in) :: decayFactor ! albedo decay factor (-) - real(dp),intent(in) :: albedoMax ! maximum albedo (-) - real(dp),intent(in) :: albedoMin ! minimum albedo (-) + real(rkind),intent(inout) :: snowAlbedo ! snow albedo (-) + real(rkind),intent(in) :: refreshFactor ! albedo refreshment factor (-) + real(rkind),intent(in) :: decayFactor ! albedo decay factor (-) + real(rkind),intent(in) :: albedoMax ! maximum albedo (-) + real(rkind),intent(in) :: albedoMin ! minimum albedo (-) ! local variables - real(dp) :: albedoChange ! change in albedo over the time step (-) + real(rkind) :: albedoChange ! change in albedo over the time step (-) ! compute change in albedo - albedoChange = refreshFactor*(albedoMax - snowAlbedo) - (decayFactor*(snowAlbedo - albedoMin)) / (1._dp + decayFactor) + albedoChange = refreshFactor*(albedoMax - snowAlbedo) - (decayFactor*(snowAlbedo - albedoMin)) / (1._rkind + decayFactor) snowAlbedo = snowAlbedo + albedoChange if(snowAlbedo > albedoMax) snowAlbedo = albedoMax end subroutine computeAlbedo diff --git a/build/source/engine/snowLiqFlx.f90 b/build/source/engine/snowLiqFlx.f90 index 53b4fb29a..48b67f590 100755 --- a/build/source/engine/snowLiqFlx.f90 +++ b/build/source/engine/snowLiqFlx.f90 @@ -75,18 +75,18 @@ subroutine snowLiqFlx(& logical(lgt),intent(in) :: firstFluxCall ! the first flux call logical(lgt),intent(in) :: scalarSolution ! flag to denote if implementing the scalar solution ! input: forcing for the snow domain - real(dp),intent(in) :: scalarThroughfallRain ! computed throughfall rate (kg m-2 s-1) - real(dp),intent(in) :: scalarCanopyLiqDrainage ! computed drainage of liquid water (kg m-2 s-1) + real(rkind),intent(in) :: scalarThroughfallRain ! computed throughfall rate (kg m-2 s-1) + real(rkind),intent(in) :: scalarCanopyLiqDrainage ! computed drainage of liquid water (kg m-2 s-1) ! input: model state vector - real(dp),intent(in) :: mLayerVolFracLiqTrial(:) ! trial value of volumetric fraction of liquid water at the current iteration (-) + real(rkind),intent(in) :: mLayerVolFracLiqTrial(:) ! trial value of volumetric fraction of liquid water at the current iteration (-) ! input-output: data structures type(var_ilength),intent(in) :: indx_data ! model indices type(var_dlength),intent(in) :: mpar_data ! model parameters type(var_dlength),intent(in) :: prog_data ! prognostic variables for a local HRU type(var_dlength),intent(inout) :: diag_data ! diagnostic variables for a local HRU ! output: fluxes and derivatives - real(dp),intent(inout) :: iLayerLiqFluxSnow(0:) ! vertical liquid water flux at layer interfaces (m s-1) - real(dp),intent(inout) :: iLayerLiqFluxSnowDeriv(0:) ! derivative in vertical liquid water flux at layer interfaces (m s-1) + real(rkind),intent(inout) :: iLayerLiqFluxSnow(0:) ! vertical liquid water flux at layer interfaces (m s-1) + real(rkind),intent(inout) :: iLayerLiqFluxSnowDeriv(0:) ! derivative in vertical liquid water flux at layer interfaces (m s-1) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message @@ -96,12 +96,12 @@ subroutine snowLiqFlx(& integer(i4b) :: iLayer ! layer index integer(i4b) :: ixTop ! top layer in subroutine call integer(i4b) :: ixBot ! bottom layer in subroutine call - real(dp) :: multResid ! multiplier for the residual water content (-) - real(dp),parameter :: residThrs=550._dp ! ice density threshold to reduce residual liquid water content (kg m-3) - real(dp),parameter :: residScal=10._dp ! scaling factor for residual liquid water content reduction factor (kg m-3) - real(dp),parameter :: maxVolIceContent=0.7_dp ! maximum volumetric ice content to store water (-) - real(dp) :: availCap ! available storage capacity [0,1] (-) - real(dp) :: relSaturn ! relative saturation [0,1] (-) + real(rkind) :: multResid ! multiplier for the residual water content (-) + real(rkind),parameter :: residThrs=550._rkind ! ice density threshold to reduce residual liquid water content (kg m-3) + real(rkind),parameter :: residScal=10._rkind ! scaling factor for residual liquid water content reduction factor (kg m-3) + real(rkind),parameter :: maxVolIceContent=0.7_rkind ! maximum volumetric ice content to store water (-) + real(rkind) :: availCap ! available storage capacity [0,1] (-) + real(rkind) :: relSaturn ! relative saturation [0,1] (-) ! ------------------------------------------------------------------------------------------------------------------------------------------ ! make association of local variables with information in the data structures associate(& @@ -128,7 +128,7 @@ subroutine snowLiqFlx(& end if ! check the meltwater exponent is >=1 - if(mw_exp<1._dp)then; err=20; message=trim(message)//'meltwater exponent < 1'; return; end if + if(mw_exp<1._rkind)then; err=20; message=trim(message)//'meltwater exponent < 1'; return; end if ! get the indices for the snow+soil layers ixTop = integerMissing @@ -159,16 +159,16 @@ subroutine snowLiqFlx(& ! define the liquid flux at the upper boundary (m s-1) iLayerLiqFluxSnow(0) = (scalarThroughfallRain + scalarCanopyLiqDrainage)/iden_water - iLayerLiqFluxSnowDeriv(0) = 0._dp + iLayerLiqFluxSnowDeriv(0) = 0._rkind ! compute properties fixed over the time step if(firstFluxCall)then ! loop through snow layers do iLayer=1,nSnow ! compute the reduction in liquid water holding capacity at high snow density (-) - multResid = 1._dp / ( 1._dp + exp( (mLayerVolFracIce(iLayer)*iden_ice - residThrs) / residScal) ) + multResid = 1._rkind / ( 1._rkind + exp( (mLayerVolFracIce(iLayer)*iden_ice - residThrs) / residScal) ) ! compute the pore space (-) - mLayerPoreSpace(iLayer) = 1._dp - mLayerVolFracIce(iLayer) + mLayerPoreSpace(iLayer) = 1._rkind - mLayerVolFracIce(iLayer) ! compute the residual volumetric liquid water content (-) mLayerThetaResid(iLayer) = Fcapil*mLayerPoreSpace(iLayer) * multResid end do ! (looping through snow layers) @@ -182,14 +182,14 @@ subroutine snowLiqFlx(& availCap = mLayerPoreSpace(iLayer) - mLayerThetaResid(iLayer) ! available capacity relSaturn = (mLayerVolFracLiqTrial(iLayer) - mLayerThetaResid(iLayer)) / availCap ! relative saturation iLayerLiqFluxSnow(iLayer) = k_snow*relSaturn**mw_exp - iLayerLiqFluxSnowDeriv(iLayer) = ( (k_snow*mw_exp)/availCap ) * relSaturn**(mw_exp - 1._dp) + iLayerLiqFluxSnowDeriv(iLayer) = ( (k_snow*mw_exp)/availCap ) * relSaturn**(mw_exp - 1._rkind) if(mLayerVolFracIce(iLayer) > maxVolIceContent)then ! NOTE: use start-of-step ice content, to avoid convergence problems ! ** allow liquid water to pass through under very high ice density iLayerLiqFluxSnow(iLayer) = iLayerLiqFluxSnow(iLayer) + iLayerLiqFluxSnow(iLayer-1) !NOTE: derivative may need to be updated in future. end if else ! flow does not occur - iLayerLiqFluxSnow(iLayer) = 0._dp - iLayerLiqFluxSnowDeriv(iLayer) = 0._dp + iLayerLiqFluxSnow(iLayer) = 0._rkind + iLayerLiqFluxSnowDeriv(iLayer) = 0._rkind endif ! storage above residual content end do ! loop through snow layers diff --git a/build/source/engine/snow_utils.f90 b/build/source/engine/snow_utils.f90 index 496ecfce5..8ad277d30 100755 --- a/build/source/engine/snow_utils.f90 +++ b/build/source/engine/snow_utils.f90 @@ -47,11 +47,11 @@ module snow_utils_module ! *********************************************************************************************************** function fracliquid(Tk,fc_param) implicit none - real(dp),intent(in) :: Tk ! temperature (K) - real(dp),intent(in) :: fc_param ! freezing curve parameter (K-1) - real(dp) :: fracliquid ! fraction of liquid water (-) + real(rkind),intent(in) :: Tk ! temperature (K) + real(rkind),intent(in) :: fc_param ! freezing curve parameter (K-1) + real(rkind) :: fracliquid ! fraction of liquid water (-) ! compute fraction of liquid water (-) - fracliquid = 1._dp / ( 1._dp + (fc_param*( Tfreeze - min(Tk,Tfreeze) ))**2._dp ) + fracliquid = 1._rkind / ( 1._rkind + (fc_param*( Tfreeze - min(Tk,Tfreeze) ))**2._rkind ) end function fracliquid @@ -60,11 +60,11 @@ end function fracliquid ! *********************************************************************************************************** function templiquid(fracliquid,fc_param) implicit none - real(dp),intent(in) :: fracliquid ! fraction of liquid water (-) - real(dp),intent(in) :: fc_param ! freezing curve parameter (K-1) - real(dp) :: templiquid ! temperature (K) + real(rkind),intent(in) :: fracliquid ! fraction of liquid water (-) + real(rkind),intent(in) :: fc_param ! freezing curve parameter (K-1) + real(rkind) :: templiquid ! temperature (K) ! compute temperature based on the fraction of liquid water (K) - templiquid = Tfreeze - ((1._dp/fracliquid - 1._dp)/fc_param**2._dp)**(0.5_dp) + templiquid = Tfreeze - ((1._rkind/fracliquid - 1._rkind)/fc_param**2._rkind)**(0.5_rkind) end function templiquid @@ -74,17 +74,17 @@ end function templiquid function dFracLiq_dTk(Tk,fc_param) implicit none ! dummies - real(dp),intent(in) :: Tk ! temperature (K) - real(dp),intent(in) :: fc_param ! freezing curve parameter (K-1) - real(dp) :: dFracLiq_dTk ! differentiate the freezing curve (K-1) + real(rkind),intent(in) :: Tk ! temperature (K) + real(rkind),intent(in) :: fc_param ! freezing curve parameter (K-1) + real(rkind) :: dFracLiq_dTk ! differentiate the freezing curve (K-1) ! locals - real(dp) :: Tdep ! temperature depression (K) - real(dp) :: Tdim ! dimensionless temperature (-) + real(rkind) :: Tdep ! temperature depression (K) + real(rkind) :: Tdim ! dimensionless temperature (-) ! compute local variables (just to make things more efficient) Tdep = Tfreeze - min(Tk,Tfreeze) Tdim = fc_param*Tdep ! differentiate the freezing curve w.r.t temperature - dFracLiq_dTk = (fc_param*2._dp*Tdim) / ( ( 1._dp + Tdim**2._dp)**2._dp ) + dFracLiq_dTk = (fc_param*2._rkind*Tdim) / ( ( 1._rkind + Tdim**2._rkind)**2._rkind ) end function dFracLiq_dTk @@ -93,17 +93,17 @@ end function dFracLiq_dTk ! *********************************************************************************************************** subroutine tcond_snow(BulkDenIce,thermlcond,err,message) implicit none - real(dp),intent(in) :: BulkDenIce ! bulk density of ice (kg m-3) - real(dp),intent(out) :: thermlcond ! thermal conductivity of snow (W m-1 K-1) + real(rkind),intent(in) :: BulkDenIce ! bulk density of ice (kg m-3) + real(rkind),intent(out) :: thermlcond ! thermal conductivity of snow (W m-1 K-1) integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! initialize error control err=0; message="tcond_snow/" ! compute thermal conductivity of snow select case(model_decisions(iLookDECISIONS%thCondSnow)%iDecision) - case(Yen1965); thermlcond = 3.217d-6 * BulkDenIce**2._dp ! Yen (1965) - case(Mellor1977); thermlcond = 2.576d-6 * BulkDenIce**2._dp + 7.4d-2 ! Mellor (1977) - case(Jordan1991); thermlcond = lambda_air + (7.75d-5*BulkDenIce + 1.105d-6*(BulkDenIce**2._dp)) & + case(Yen1965); thermlcond = 3.217d-6 * BulkDenIce**2._rkind ! Yen (1965) + case(Mellor1977); thermlcond = 2.576d-6 * BulkDenIce**2._rkind + 7.4d-2 ! Mellor (1977) + case(Jordan1991); thermlcond = lambda_air + (7.75d-5*BulkDenIce + 1.105d-6*(BulkDenIce**2._rkind)) & * (lambda_ice-lambda_air) ! Jordan (1991) case default err=10; message=trim(message)//"unknownOption"; return diff --git a/build/source/engine/snwCompact.f90 b/build/source/engine/snwCompact.f90 index 8f3441bce..06d897bf6 100755 --- a/build/source/engine/snwCompact.f90 +++ b/build/source/engine/snwCompact.f90 @@ -65,43 +65,43 @@ subroutine snwDensify(& ! compute change in snow density over the time step implicit none ! intent(in): variables - real(dp),intent(in) :: dt ! time step (seconds) + real(rkind),intent(in) :: dt ! time step (seconds) integer(i4b),intent(in) :: nSnow ! number of snow layers - real(dp),intent(in) :: mLayerTemp(:) ! temperature of each snow layer after iterations (K) - real(dp),intent(in) :: mLayerMeltFreeze(:) ! volumetric melt in each layer (kg m-3) + real(rkind),intent(in) :: mLayerTemp(:) ! temperature of each snow layer after iterations (K) + real(rkind),intent(in) :: mLayerMeltFreeze(:) ! volumetric melt in each layer (kg m-3) ! intent(in): parameters - real(dp),intent(in) :: densScalGrowth ! density scaling factor for grain growth (kg-1 m3) - real(dp),intent(in) :: tempScalGrowth ! temperature scaling factor for grain growth (K-1) - real(dp),intent(in) :: grainGrowthRate ! rate of grain growth (s-1) - real(dp),intent(in) :: densScalOvrbdn ! density scaling factor for overburden pressure (kg-1 m3) - real(dp),intent(in) :: tempScalOvrbdn ! temperature scaling factor for overburden pressure (K-1) - real(dp),intent(in) :: baseViscosity ! viscosity coefficient at T=T_frz and snow density=0 (kg m-2 s) + real(rkind),intent(in) :: densScalGrowth ! density scaling factor for grain growth (kg-1 m3) + real(rkind),intent(in) :: tempScalGrowth ! temperature scaling factor for grain growth (K-1) + real(rkind),intent(in) :: grainGrowthRate ! rate of grain growth (s-1) + real(rkind),intent(in) :: densScalOvrbdn ! density scaling factor for overburden pressure (kg-1 m3) + real(rkind),intent(in) :: tempScalOvrbdn ! temperature scaling factor for overburden pressure (K-1) + real(rkind),intent(in) :: baseViscosity ! viscosity coefficient at T=T_frz and snow density=0 (kg m-2 s) ! intent(inout): state variables - real(dp),intent(inout) :: mLayerDepth(:) ! depth of each layer (m) - real(dp),intent(inout) :: mLayerVolFracLiqNew(:) ! volumetric fraction of liquid water in each snow layer after iterations (-) - real(dp),intent(inout) :: mLayerVolFracIceNew(:) ! volumetric fraction of ice in each snow layer after iterations (-) + real(rkind),intent(inout) :: mLayerDepth(:) ! depth of each layer (m) + real(rkind),intent(inout) :: mLayerVolFracLiqNew(:) ! volumetric fraction of liquid water in each snow layer after iterations (-) + real(rkind),intent(inout) :: mLayerVolFracIceNew(:) ! volumetric fraction of ice in each snow layer after iterations (-) ! intent(out): error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! ----------------------------------------------------------------------------------------------------------------------------------------- ! define local variables integer(i4b) :: iSnow ! index of snow layers - real(dp) :: chi1,chi2,chi3,chi4,chi5 ! multipliers in the densification algorithm (-) - real(dp) :: halfWeight ! half of the weight of the current snow layer (kg m-2) - real(dp) :: weightSnow ! total weight of snow above the current snow layer (kg m-2) - real(dp) :: CR_grainGrowth ! compaction rate for grain growth (s-1) - real(dp) :: CR_ovrvdnPress ! compaction rate associated with over-burden pressure (s-1) - real(dp) :: CR_metamorph ! compaction rate for metamorphism (s-1) - real(dp) :: massIceOld ! mass of ice in the snow layer (kg m-2) - real(dp) :: massLiqOld ! mass of liquid water in the snow layer (kg m-2) - real(dp) :: scalarDepthNew ! updated layer depth (m) - real(dp) :: scalarDepthMin ! minimum layer depth (m) - real(dp) :: volFracIceLoss ! volumetric fraction of ice lost due to melt and sublimation (-) - real(dp), dimension(nSnow) :: mLayerVolFracAirNew ! volumetric fraction of air in each layer after compaction (-) - real(dp),parameter :: snwden_min=100._dp ! minimum snow density for reducing metamorphism rate (kg m-3) - real(dp),parameter :: snwDensityMax=550._dp ! maximum snow density for collapse under melt (kg m-3) - real(dp),parameter :: wetSnowThresh=0.01_dp ! threshold to discriminate between "wet" and "dry" snow - real(dp),parameter :: minLayerDensity=40._dp ! minimum snow density allowed for any layer (kg m-3) + real(rkind) :: chi1,chi2,chi3,chi4,chi5 ! multipliers in the densification algorithm (-) + real(rkind) :: halfWeight ! half of the weight of the current snow layer (kg m-2) + real(rkind) :: weightSnow ! total weight of snow above the current snow layer (kg m-2) + real(rkind) :: CR_grainGrowth ! compaction rate for grain growth (s-1) + real(rkind) :: CR_ovrvdnPress ! compaction rate associated with over-burden pressure (s-1) + real(rkind) :: CR_metamorph ! compaction rate for metamorphism (s-1) + real(rkind) :: massIceOld ! mass of ice in the snow layer (kg m-2) + real(rkind) :: massLiqOld ! mass of liquid water in the snow layer (kg m-2) + real(rkind) :: scalarDepthNew ! updated layer depth (m) + real(rkind) :: scalarDepthMin ! minimum layer depth (m) + real(rkind) :: volFracIceLoss ! volumetric fraction of ice lost due to melt and sublimation (-) + real(rkind), dimension(nSnow) :: mLayerVolFracAirNew ! volumetric fraction of air in each layer after compaction (-) + real(rkind),parameter :: snwden_min=100._rkind ! minimum snow density for reducing metamorphism rate (kg m-3) + real(rkind),parameter :: snwDensityMax=550._rkind ! maximum snow density for collapse under melt (kg m-3) + real(rkind),parameter :: wetSnowThresh=0.01_rkind ! threshold to discriminate between "wet" and "dry" snow + real(rkind),parameter :: minLayerDensity=40._rkind ! minimum snow density allowed for any layer (kg m-3) ! ----------------------------------------------------------------------------------------------------------------------------------------- ! initialize error control err=0; message="snwDensify/" @@ -110,7 +110,7 @@ subroutine snwDensify(& if(nSnow==0)return ! initialize the weight of snow above each layer (kg m-2) - weightSnow = 0._dp + weightSnow = 0._rkind ! loop through snow layers do iSnow=1,nSnow @@ -124,19 +124,19 @@ subroutine snwDensify(& ! *** compute the compaction associated with grain growth (s-1) ! compute the base rate of grain growth (-) - if(mLayerVolFracIceNew(iSnow)*iden_ice =snwden_min) chi1=exp(-densScalGrowth*(mLayerVolFracIceNew(iSnow)*iden_ice - snwden_min)) ! compute the reduction of grain growth under colder snow temperatures (-) chi2 = exp(-tempScalGrowth*(Tfreeze - mLayerTemp(iSnow))) ! compute the acceleration of grain growth in the presence of liquid water (-) - if(mLayerVolFracLiqNew(iSnow) > wetSnowThresh)then; chi3=2._dp ! snow is "wet" - else; chi3=1._dp; end if ! snow is "dry" + if(mLayerVolFracLiqNew(iSnow) > wetSnowThresh)then; chi3=2._rkind ! snow is "wet" + else; chi3=1._rkind; end if ! snow is "dry" ! compute the compaction associated with grain growth (s-1) CR_grainGrowth = grainGrowthRate*chi1*chi2*chi3 ! **** compute the compaction associated with over-burden pressure (s-1) ! compute the weight imposed on the current layer (kg m-2) - halfWeight = (massIceOld + massLiqOld)/2._dp ! there is some over-burden pressure from the layer itself + halfWeight = (massIceOld + massLiqOld)/2._rkind ! there is some over-burden pressure from the layer itself weightSnow = weightSnow + halfweight ! add half of the weight from the current layer ! compute the increase in compaction under colder snow temperatures (-) chi4 = exp(-tempScalOvrbdn*(Tfreeze - mLayerTemp(iSnow))) @@ -151,7 +151,7 @@ subroutine snwDensify(& ! NOTE: loss of ice due to snowmelt is implicit, so can be updated directly if(iden_ice*mLayerVolFracIceNew(iSnow) < snwDensityMax)then ! only collapse layers if below a critical density ! (compute volumetric losses of ice due to melt and sublimation) - volFracIceLoss = max(0._dp,mLayerMeltFreeze(iSnow)/iden_ice) ! volumetric fraction of ice lost due to melt (-) + volFracIceLoss = max(0._rkind,mLayerMeltFreeze(iSnow)/iden_ice) ! volumetric fraction of ice lost due to melt (-) ! (adjust snow depth to account for cavitation) scalarDepthNew = mLayerDepth(iSnow) * mLayerVolFracIceNew(iSnow)/(mLayerVolFracIceNew(iSnow) + volFracIceLoss) !print*, 'volFracIceLoss = ', volFracIceLoss @@ -163,12 +163,12 @@ subroutine snwDensify(& ! update depth due to metamorphism (implicit solution) ! Ensure that the new depth is in line with the maximum amount of compaction that ! can occur given the masses of ice and liquid in the layer - scalarDepthNew = scalarDepthNew/(1._dp + CR_metamorph*dt) + scalarDepthNew = scalarDepthNew/(1._rkind + CR_metamorph*dt) scalarDepthMin = (massIceOld / iden_ice) + (massLiqOld / iden_water) mLayerDepth(iSnow) = max(scalarDepthMin, scalarDepthNew) ! check that depth is reasonable - if(mLayerDepth(iSnow) < 0._dp)then + if(mLayerDepth(iSnow) < 0._rkind)then write(*,'(a,1x,i4,1x,10(f12.5,1x))') 'iSnow, dt, density,massIceOld, massLiqOld = ', iSnow, dt, mLayerVolFracIceNew(iSnow)*iden_ice, massIceOld, massLiqOld write(*,'(a,1x,i4,1x,10(f12.5,1x))') 'iSnow, mLayerDepth(iSnow), scalarDepthNew, mLayerVolFracIceNew(iSnow), mLayerMeltFreeze(iSnow), CR_grainGrowth*dt, CR_ovrvdnPress*dt = ', & iSnow, mLayerDepth(iSnow), scalarDepthNew, mLayerVolFracIceNew(iSnow), mLayerMeltFreeze(iSnow), CR_grainGrowth*dt, CR_ovrvdnPress*dt @@ -177,14 +177,14 @@ subroutine snwDensify(& ! update volumetric ice and liquid water content mLayerVolFracIceNew(iSnow) = massIceOld/(mLayerDepth(iSnow)*iden_ice) mLayerVolFracLiqNew(iSnow) = massLiqOld/(mLayerDepth(iSnow)*iden_water) - mLayerVolFracAirNew(iSnow) = 1.0_dp - mLayerVolFracIceNew(iSnow) - mLayerVolFracLiqNew(iSnow) + mLayerVolFracAirNew(iSnow) = 1.0_rkind - mLayerVolFracIceNew(iSnow) - mLayerVolFracLiqNew(iSnow) !write(*,'(a,1x,i4,1x,f9.3)') 'after compact: iSnow, density = ', iSnow, mLayerVolFracIceNew(iSnow)*iden_ice - !if(mLayerMeltFreeze(iSnow) > 20._dp) pause 'meaningful melt' + !if(mLayerMeltFreeze(iSnow) > 20._rkind) pause 'meaningful melt' end do ! looping through snow layers ! check depth - if(any(mLayerDepth(1:nSnow) < 0._dp))then + if(any(mLayerDepth(1:nSnow) < 0._rkind))then do iSnow=1,nSnow write(*,'(a,1x,i4,1x,4(f12.5,1x))') 'iSnow, mLayerDepth(iSnow)', iSnow, mLayerDepth(iSnow) end do @@ -194,7 +194,7 @@ subroutine snwDensify(& ! check for low/high snow density if(any(mLayerVolFracIceNew(1:nSnow)*iden_ice + mLayerVolFracLiqNew(1:nSnow)*iden_water + mLayerVolFracAirNew(1:nSnow)*iden_air < minLayerDensity) .or. & - any(mLayerVolFracIceNew(1:nSnow) + mLayerVolFracLiqNew(1:nSnow) + mLayerVolFracAirNew(1:nSnow) > 1._dp))then + any(mLayerVolFracIceNew(1:nSnow) + mLayerVolFracLiqNew(1:nSnow) + mLayerVolFracAirNew(1:nSnow) > 1._rkind))then do iSnow=1,nSnow write(*,*) 'iSnow, volFracIce, density = ', iSnow, mLayerVolFracIceNew(iSnow), mLayerVolFracIceNew(iSnow)*iden_ice end do diff --git a/build/source/engine/soilLiqFlx.f90 b/build/source/engine/soilLiqFlx.f90 index 52eb06ce6..30a5cda2b 100755 --- a/build/source/engine/soilLiqFlx.f90 +++ b/build/source/engine/soilLiqFlx.f90 @@ -80,8 +80,8 @@ module soilLiqFlx_module private public::soilLiqFlx ! constant parameters -real(dp),parameter :: verySmall=1.e-12_dp ! a very small number (used to avoid divide by zero) -real(dp),parameter :: dx=1.e-8_dp ! finite difference increment +real(rkind),parameter :: verySmall=1.e-12_rkind ! a very small number (used to avoid divide by zero) +real(rkind),parameter :: dx=1.e-8_rkind ! finite difference increment contains @@ -150,17 +150,17 @@ subroutine soilLiqFlx(& logical(lgt),intent(in) :: scalarSolution ! flag to denote if implementing the scalar solution logical(lgt),intent(in) :: deriv_desired ! flag indicating if derivatives are desired ! input: trial model state variables - real(dp),intent(in) :: mLayerTempTrial(:) ! temperature in each layer at the current iteration (m) - real(dp),intent(in) :: mLayerMatricHeadTrial(:) ! matric head in each layer at the current iteration (m) - real(dp),intent(in) :: mLayerVolFracLiqTrial(:) ! volumetric fraction of liquid water at the current iteration (-) - real(dp),intent(in) :: mLayerVolFracIceTrial(:) ! volumetric fraction of ice at the current iteration (-) + real(rkind),intent(in) :: mLayerTempTrial(:) ! temperature in each layer at the current iteration (m) + real(rkind),intent(in) :: mLayerMatricHeadTrial(:) ! matric head in each layer at the current iteration (m) + real(rkind),intent(in) :: mLayerVolFracLiqTrial(:) ! volumetric fraction of liquid water at the current iteration (-) + real(rkind),intent(in) :: mLayerVolFracIceTrial(:) ! volumetric fraction of ice at the current iteration (-) ! input: pre-computed derivatves - real(dp),intent(in) :: mLayerdTheta_dTk(:) ! derivative in volumetric liquid water content w.r.t. temperature (K-1) - real(dp),intent(in) :: dPsiLiq_dTemp(:) ! derivative in liquid water matric potential w.r.t. temperature (m K-1) + real(rkind),intent(in) :: mLayerdTheta_dTk(:) ! derivative in volumetric liquid water content w.r.t. temperature (K-1) + real(rkind),intent(in) :: dPsiLiq_dTemp(:) ! derivative in liquid water matric potential w.r.t. temperature (m K-1) ! input: model fluxes - real(dp),intent(in) :: scalarCanopyTranspiration ! canopy transpiration (kg m-2 s-1) - real(dp),intent(in) :: scalarGroundEvaporation ! ground evaporation (kg m-2 s-1) - real(dp),intent(in) :: scalarRainPlusMelt ! rain plus melt (m s-1) + real(rkind),intent(in) :: scalarCanopyTranspiration ! canopy transpiration (kg m-2 s-1) + real(rkind),intent(in) :: scalarGroundEvaporation ! ground evaporation (kg m-2 s-1) + real(rkind),intent(in) :: scalarRainPlusMelt ! rain plus melt (m s-1) ! input-output: data structures type(var_dlength),intent(in) :: mpar_data ! model parameters type(var_ilength),intent(in) :: indx_data ! state vector geometry @@ -168,25 +168,25 @@ subroutine soilLiqFlx(& type(var_dlength),intent(inout) :: diag_data ! diagnostic variables for a local HRU type(var_dlength),intent(inout) :: flux_data ! model fluxes for a local HRU ! output: diagnostic variables for surface runoff - real(dp),intent(inout) :: xMaxInfilRate ! maximum infiltration rate (m s-1) - real(dp),intent(inout) :: scalarInfilArea ! fraction of unfrozen area where water can infiltrate (-) - real(dp),intent(inout) :: scalarFrozenArea ! fraction of area that is considered impermeable due to soil ice (-) - real(dp),intent(inout) :: scalarSurfaceRunoff ! surface runoff (m s-1) + real(rkind),intent(inout) :: xMaxInfilRate ! maximum infiltration rate (m s-1) + real(rkind),intent(inout) :: scalarInfilArea ! fraction of unfrozen area where water can infiltrate (-) + real(rkind),intent(inout) :: scalarFrozenArea ! fraction of area that is considered impermeable due to soil ice (-) + real(rkind),intent(inout) :: scalarSurfaceRunoff ! surface runoff (m s-1) ! output: diagnostic variables for each layer - real(dp),intent(inout) :: mLayerdTheta_dPsi(:) ! derivative in the soil water characteristic w.r.t. psi (m-1) - real(dp),intent(inout) :: mLayerdPsi_dTheta(:) ! derivative in the soil water characteristic w.r.t. theta (m) - real(dp),intent(inout) :: dHydCond_dMatric(:) ! derivative in hydraulic conductivity w.r.t matric head (s-1) + real(rkind),intent(inout) :: mLayerdTheta_dPsi(:) ! derivative in the soil water characteristic w.r.t. psi (m-1) + real(rkind),intent(inout) :: mLayerdPsi_dTheta(:) ! derivative in the soil water characteristic w.r.t. theta (m) + real(rkind),intent(inout) :: dHydCond_dMatric(:) ! derivative in hydraulic conductivity w.r.t matric head (s-1) ! output: liquid fluxes - real(dp),intent(inout) :: scalarSurfaceInfiltration ! surface infiltration rate (m s-1) - real(dp),intent(inout) :: iLayerLiqFluxSoil(0:) ! liquid flux at soil layer interfaces (m s-1) - real(dp),intent(inout) :: mLayerTranspire(:) ! transpiration loss from each soil layer (m s-1) - real(dp),intent(inout) :: mLayerHydCond(:) ! hydraulic conductivity in each soil layer (m s-1) + real(rkind),intent(inout) :: scalarSurfaceInfiltration ! surface infiltration rate (m s-1) + real(rkind),intent(inout) :: iLayerLiqFluxSoil(0:) ! liquid flux at soil layer interfaces (m s-1) + real(rkind),intent(inout) :: mLayerTranspire(:) ! transpiration loss from each soil layer (m s-1) + real(rkind),intent(inout) :: mLayerHydCond(:) ! hydraulic conductivity in each soil layer (m s-1) ! output: derivatives in fluxes w.r.t. state variables in the layer above and layer below (m s-1) - real(dp),intent(inout) :: dq_dHydStateAbove(0:) ! derivative in the flux in layer interfaces w.r.t. state variables in the layer above - real(dp),intent(inout) :: dq_dHydStateBelow(0:) ! derivative in the flux in layer interfaces w.r.t. state variables in the layer below + real(rkind),intent(inout) :: dq_dHydStateAbove(0:) ! derivative in the flux in layer interfaces w.r.t. state variables in the layer above + real(rkind),intent(inout) :: dq_dHydStateBelow(0:) ! derivative in the flux in layer interfaces w.r.t. state variables in the layer below ! output: derivatives in fluxes w.r.t. energy state variables -- now just temperature -- in the layer above and layer below (m s-1 K-1) - real(dp),intent(inout) :: dq_dNrgStateAbove(0:) ! derivatives in the flux w.r.t. temperature in the layer above (m s-1 K-1) - real(dp),intent(inout) :: dq_dNrgStateBelow(0:) ! derivatives in the flux w.r.t. temperature in the layer below (m s-1 K-1) + real(rkind),intent(inout) :: dq_dNrgStateAbove(0:) ! derivatives in the flux w.r.t. temperature in the layer above (m s-1 K-1) + real(rkind),intent(inout) :: dq_dNrgStateBelow(0:) ! derivatives in the flux w.r.t. temperature in the layer below (m s-1 K-1) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message @@ -208,34 +208,34 @@ subroutine soilLiqFlx(& integer(i4b),parameter :: perturbStateBelow=3 ! named variable to identify the case where we perturb the state layer below integer(i4b) :: ixPerturb ! index of element in 2-element vector to perturb integer(i4b) :: ixOriginal ! index of perturbed element in the original vector - real(dp) :: scalarVolFracLiqTrial ! trial value of volumetric liquid water content (-) - real(dp) :: scalarMatricHeadTrial ! trial value of matric head (m) - real(dp) :: scalarHydCondTrial ! trial value of hydraulic conductivity (m s-1) - real(dp) :: scalarHydCondMicro ! trial value of hydraulic conductivity of micropores (m s-1) - real(dp) :: scalarHydCondMacro ! trial value of hydraulic conductivity of macropores (m s-1) - real(dp) :: scalarFlux ! vertical flux (m s-1) - real(dp) :: scalarFlux_dStateAbove ! vertical flux with perturbation to the state above (m s-1) - real(dp) :: scalarFlux_dStateBelow ! vertical flux with perturbation to the state below (m s-1) + real(rkind) :: scalarVolFracLiqTrial ! trial value of volumetric liquid water content (-) + real(rkind) :: scalarMatricHeadTrial ! trial value of matric head (m) + real(rkind) :: scalarHydCondTrial ! trial value of hydraulic conductivity (m s-1) + real(rkind) :: scalarHydCondMicro ! trial value of hydraulic conductivity of micropores (m s-1) + real(rkind) :: scalarHydCondMacro ! trial value of hydraulic conductivity of macropores (m s-1) + real(rkind) :: scalarFlux ! vertical flux (m s-1) + real(rkind) :: scalarFlux_dStateAbove ! vertical flux with perturbation to the state above (m s-1) + real(rkind) :: scalarFlux_dStateBelow ! vertical flux with perturbation to the state below (m s-1) ! transpiration sink term - real(dp),dimension(nSoil) :: mLayerTranspireFrac ! fraction of transpiration allocated to each soil layer (-) + real(rkind),dimension(nSoil) :: mLayerTranspireFrac ! fraction of transpiration allocated to each soil layer (-) ! diagnostic variables - real(dp),dimension(nSoil) :: iceImpedeFac ! ice impedence factor at layer mid-points (-) - real(dp),dimension(nSoil) :: mLayerDiffuse ! diffusivity at layer mid-point (m2 s-1) - real(dp),dimension(nSoil) :: dHydCond_dVolLiq ! derivative in hydraulic conductivity w.r.t volumetric liquid water content (m s-1) - real(dp),dimension(nSoil) :: dDiffuse_dVolLiq ! derivative in hydraulic diffusivity w.r.t volumetric liquid water content (m2 s-1) - real(dp),dimension(nSoil) :: dHydCond_dTemp ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) - real(dp),dimension(0:nSoil) :: iLayerHydCond ! hydraulic conductivity at layer interface (m s-1) - real(dp),dimension(0:nSoil) :: iLayerDiffuse ! diffusivity at layer interface (m2 s-1) + real(rkind),dimension(nSoil) :: iceImpedeFac ! ice impedence factor at layer mid-points (-) + real(rkind),dimension(nSoil) :: mLayerDiffuse ! diffusivity at layer mid-point (m2 s-1) + real(rkind),dimension(nSoil) :: dHydCond_dVolLiq ! derivative in hydraulic conductivity w.r.t volumetric liquid water content (m s-1) + real(rkind),dimension(nSoil) :: dDiffuse_dVolLiq ! derivative in hydraulic diffusivity w.r.t volumetric liquid water content (m2 s-1) + real(rkind),dimension(nSoil) :: dHydCond_dTemp ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) + real(rkind),dimension(0:nSoil) :: iLayerHydCond ! hydraulic conductivity at layer interface (m s-1) + real(rkind),dimension(0:nSoil) :: iLayerDiffuse ! diffusivity at layer interface (m2 s-1) ! compute surface flux integer(i4b) :: nRoots ! number of soil layers with roots integer(i4b) :: ixIce ! index of the lowest soil layer that contains ice - real(dp),dimension(0:nSoil) :: iLayerHeight ! height of the layer interfaces (m) + real(rkind),dimension(0:nSoil) :: iLayerHeight ! height of the layer interfaces (m) ! compute fluxes and derivatives at layer interfaces - real(dp),dimension(2) :: vectorVolFracLiqTrial ! trial value of volumetric liquid water content (-) - real(dp),dimension(2) :: vectorMatricHeadTrial ! trial value of matric head (m) - real(dp),dimension(2) :: vectorHydCondTrial ! trial value of hydraulic conductivity (m s-1) - real(dp),dimension(2) :: vectorDiffuseTrial ! trial value of hydraulic diffusivity (m2 s-1) - real(dp) :: scalardPsi_dTheta ! derivative in soil water characteristix, used for perturbations when computing numerical derivatives + real(rkind),dimension(2) :: vectorVolFracLiqTrial ! trial value of volumetric liquid water content (-) + real(rkind),dimension(2) :: vectorMatricHeadTrial ! trial value of matric head (m) + real(rkind),dimension(2) :: vectorHydCondTrial ! trial value of hydraulic conductivity (m s-1) + real(rkind),dimension(2) :: vectorDiffuseTrial ! trial value of hydraulic diffusivity (m2 s-1) + real(rkind) :: scalardPsi_dTheta ! derivative in soil water characteristix, used for perturbations when computing numerical derivatives ! ------------------------------------------------------------------------------------------------------------------------------------------------- ! initialize error control err=0; message='soilLiqFlx/' @@ -364,7 +364,7 @@ subroutine soilLiqFlx(& end if ! check fractions sum to one - if(abs(sum(mLayerTranspireFrac) - 1._dp) > verySmall)then + if(abs(sum(mLayerTranspireFrac) - 1._rkind) > verySmall)then message=trim(message)//'fraction transpiration in soil layers does not sum to one' err=20; return endif @@ -373,7 +373,7 @@ subroutine soilLiqFlx(& mLayerTranspire = mLayerTranspireFrac(:)*scalarCanopyTranspiration/iden_water ! special case of prescribed head -- no transpiration - if(ixBcUpperSoilHydrology==prescribedHead) mLayerTranspire(:) = 0._dp + if(ixBcUpperSoilHydrology==prescribedHead) mLayerTranspire(:) = 0._rkind endif ! if need to compute transpiration @@ -435,8 +435,8 @@ subroutine soilLiqFlx(& ! ------------------------------------------------------------------------------------------------------------------------------------------------- ! set derivative w.r.t. state above to zero (does not exist) - dq_dHydStateAbove(0) = 0._dp - dq_dNrgStateAbove(0) = 0._dp + dq_dHydStateAbove(0) = 0._rkind + dq_dNrgStateAbove(0) = 0._rkind ! either one or multiple flux calls, depending on if using analytical or numerical derivatives do itry=nFlux,0,-1 ! (work backwards to ensure all computed fluxes come from the un-perturbed case) @@ -821,8 +821,8 @@ subroutine soilLiqFlx(& end if ! no dependence on the aquifer for drainage - dq_dHydStateBelow(nSoil) = 0._dp ! keep this here in case we want to couple some day.... - dq_dNrgStateBelow(nSoil) = 0._dp ! keep this here in case we want to couple some day.... + dq_dHydStateBelow(nSoil) = 0._rkind ! keep this here in case we want to couple some day.... + dq_dNrgStateBelow(nSoil) = 0._rkind ! keep this here in case we want to couple some day.... ! print drainage !print*, 'iLayerLiqFluxSoil(nSoil) = ', iLayerLiqFluxSoil(nSoil) @@ -897,66 +897,66 @@ subroutine diagv_node(& logical(lgt),intent(in) :: deriv_desired ! flag indicating if derivatives are desired integer(i4b),intent(in) :: ixRichards ! index defining the option for Richards' equation (moisture or mixdform) ! input: state and diagnostic variables - real(dp),intent(in) :: scalarTempTrial ! temperature in each layer (K) - real(dp),intent(in) :: scalarMatricHeadTrial ! matric head in each layer (m) - real(dp),intent(in) :: scalarVolFracLiqTrial ! volumetric fraction of liquid water in a given layer (-) - real(dp),intent(in) :: scalarVolFracIceTrial ! volumetric fraction of ice in a given layer (-) + real(rkind),intent(in) :: scalarTempTrial ! temperature in each layer (K) + real(rkind),intent(in) :: scalarMatricHeadTrial ! matric head in each layer (m) + real(rkind),intent(in) :: scalarVolFracLiqTrial ! volumetric fraction of liquid water in a given layer (-) + real(rkind),intent(in) :: scalarVolFracIceTrial ! volumetric fraction of ice in a given layer (-) ! input: pre-computed deriavatives - real(dp),intent(in) :: dTheta_dTk ! derivative in volumetric liquid water content w.r.t. temperature (K-1) - real(dp),intent(in) :: dPsiLiq_dTemp ! derivative in liquid water matric potential w.r.t. temperature (m K-1) + real(rkind),intent(in) :: dTheta_dTk ! derivative in volumetric liquid water content w.r.t. temperature (K-1) + real(rkind),intent(in) :: dPsiLiq_dTemp ! derivative in liquid water matric potential w.r.t. temperature (m K-1) ! input: soil parameters - real(dp),intent(in) :: vGn_alpha ! van Genutchen "alpha" parameter (m-1) - real(dp),intent(in) :: vGn_n ! van Genutchen "n" parameter (-) - real(dp),intent(in) :: vGn_m ! van Genutchen "m" parameter (-) - real(dp),intent(in) :: mpExp ! empirical exponent in macropore flow equation (-) - real(dp),intent(in) :: theta_sat ! soil porosity (-) - real(dp),intent(in) :: theta_res ! soil residual volumetric water content (-) - real(dp),intent(in) :: theta_mp ! volumetric liquid water content when macropore flow begins (-) - real(dp),intent(in) :: f_impede ! ice impedence factor (-) + real(rkind),intent(in) :: vGn_alpha ! van Genutchen "alpha" parameter (m-1) + real(rkind),intent(in) :: vGn_n ! van Genutchen "n" parameter (-) + real(rkind),intent(in) :: vGn_m ! van Genutchen "m" parameter (-) + real(rkind),intent(in) :: mpExp ! empirical exponent in macropore flow equation (-) + real(rkind),intent(in) :: theta_sat ! soil porosity (-) + real(rkind),intent(in) :: theta_res ! soil residual volumetric water content (-) + real(rkind),intent(in) :: theta_mp ! volumetric liquid water content when macropore flow begins (-) + real(rkind),intent(in) :: f_impede ! ice impedence factor (-) ! input: saturated hydraulic conductivity - real(dp),intent(in) :: scalarSatHydCond ! saturated hydraulic conductivity at the mid-point of a given layer (m s-1) - real(dp),intent(in) :: scalarSatHydCondMP ! saturated hydraulic conductivity of macropores at the mid-point of a given layer (m s-1) + real(rkind),intent(in) :: scalarSatHydCond ! saturated hydraulic conductivity at the mid-point of a given layer (m s-1) + real(rkind),intent(in) :: scalarSatHydCondMP ! saturated hydraulic conductivity of macropores at the mid-point of a given layer (m s-1) ! output: derivative in the soil water characteristic - real(dp),intent(out) :: scalardPsi_dTheta ! derivative in the soil water characteristic - real(dp),intent(out) :: scalardTheta_dPsi ! derivative in the soil water characteristic + real(rkind),intent(out) :: scalardPsi_dTheta ! derivative in the soil water characteristic + real(rkind),intent(out) :: scalardTheta_dPsi ! derivative in the soil water characteristic ! output: transmittance - real(dp),intent(out) :: scalarHydCond ! hydraulic conductivity at layer mid-points (m s-1) - real(dp),intent(out) :: scalarDiffuse ! diffusivity at layer mid-points (m2 s-1) - real(dp),intent(out) :: iceImpedeFac ! ice impedence factor in each layer (-) + real(rkind),intent(out) :: scalarHydCond ! hydraulic conductivity at layer mid-points (m s-1) + real(rkind),intent(out) :: scalarDiffuse ! diffusivity at layer mid-points (m2 s-1) + real(rkind),intent(out) :: iceImpedeFac ! ice impedence factor in each layer (-) ! output: transmittance derivatives - real(dp),intent(out) :: dHydCond_dVolLiq ! derivative in hydraulic conductivity w.r.t volumetric liquid water content (m s-1) - real(dp),intent(out) :: dDiffuse_dVolLiq ! derivative in hydraulic diffusivity w.r.t volumetric liquid water content (m2 s-1) - real(dp),intent(out) :: dHydCond_dMatric ! derivative in hydraulic conductivity w.r.t matric head (s-1) - real(dp),intent(out) :: dHydCond_dTemp ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) + real(rkind),intent(out) :: dHydCond_dVolLiq ! derivative in hydraulic conductivity w.r.t volumetric liquid water content (m s-1) + real(rkind),intent(out) :: dDiffuse_dVolLiq ! derivative in hydraulic diffusivity w.r.t volumetric liquid water content (m2 s-1) + real(rkind),intent(out) :: dHydCond_dMatric ! derivative in hydraulic conductivity w.r.t matric head (s-1) + real(rkind),intent(out) :: dHydCond_dTemp ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! local variables - real(dp) :: localVolFracLiq ! local volumetric fraction of liquid water - real(dp) :: scalarHydCondMP ! hydraulic conductivity of macropores at layer mid-points (m s-1) - real(dp) :: dIceImpede_dT ! derivative in ice impedance factor w.r.t. temperature (K-1) - real(dp) :: dHydCondMacro_dVolLiq ! derivative in hydraulic conductivity of macropores w.r.t volumetric liquid water content (m s-1) - real(dp) :: dHydCondMacro_dMatric ! derivative in hydraulic conductivity of macropores w.r.t matric head (s-1) - real(dp) :: dHydCondMicro_dMatric ! derivative in hydraulic conductivity of micropores w.r.t matric head (s-1) - real(dp) :: dHydCondMicro_dTemp ! derivative in hydraulic conductivity of micropores w.r.t temperature (m s-1 K-1) - real(dp) :: dPsi_dTheta2a ! derivative in dPsi_dTheta (analytical) - real(dp) :: dIceImpede_dLiq ! derivative in ice impedence factor w.r.t. volumetric liquid water content (-) - real(dp) :: hydCond_noIce ! hydraulic conductivity in the absence of ice (m s-1) - real(dp) :: dK_dLiq__noIce ! derivative in hydraulic conductivity w.r.t volumetric liquid water content, in the absence of ice (m s-1) - real(dp) :: dK_dPsi__noIce ! derivative in hydraulic conductivity w.r.t matric head, in the absence of ice (s-1) - real(dp) :: relSatMP ! relative saturation of macropores (-) + real(rkind) :: localVolFracLiq ! local volumetric fraction of liquid water + real(rkind) :: scalarHydCondMP ! hydraulic conductivity of macropores at layer mid-points (m s-1) + real(rkind) :: dIceImpede_dT ! derivative in ice impedance factor w.r.t. temperature (K-1) + real(rkind) :: dHydCondMacro_dVolLiq ! derivative in hydraulic conductivity of macropores w.r.t volumetric liquid water content (m s-1) + real(rkind) :: dHydCondMacro_dMatric ! derivative in hydraulic conductivity of macropores w.r.t matric head (s-1) + real(rkind) :: dHydCondMicro_dMatric ! derivative in hydraulic conductivity of micropores w.r.t matric head (s-1) + real(rkind) :: dHydCondMicro_dTemp ! derivative in hydraulic conductivity of micropores w.r.t temperature (m s-1 K-1) + real(rkind) :: dPsi_dTheta2a ! derivative in dPsi_dTheta (analytical) + real(rkind) :: dIceImpede_dLiq ! derivative in ice impedence factor w.r.t. volumetric liquid water content (-) + real(rkind) :: hydCond_noIce ! hydraulic conductivity in the absence of ice (m s-1) + real(rkind) :: dK_dLiq__noIce ! derivative in hydraulic conductivity w.r.t volumetric liquid water content, in the absence of ice (m s-1) + real(rkind) :: dK_dPsi__noIce ! derivative in hydraulic conductivity w.r.t matric head, in the absence of ice (s-1) + real(rkind) :: relSatMP ! relative saturation of macropores (-) ! local variables to test the derivative logical(lgt),parameter :: testDeriv=.false. ! local flag to test the derivative - real(dp) :: xConst ! LH_fus/(gravity*Tfreeze), used in freezing point depression equation (m K-1) - real(dp) :: vTheta ! volumetric fraction of total water (-) - real(dp) :: volLiq ! volumetric fraction of liquid water (-) - real(dp) :: volIce ! volumetric fraction of ice (-) - real(dp) :: volFracLiq1,volFracLiq2 ! different trial values of volumetric liquid water content (-) - real(dp) :: effSat ! effective saturation (-) - real(dp) :: psiLiq ! liquid water matric potential (m) - real(dp) :: hydCon ! hydraulic conductivity (m s-1) - real(dp) :: hydIce ! hydraulic conductivity after accounting for ice impedance (-) - real(dp),parameter :: dx = 1.e-8_dp ! finite difference increment (m) + real(rkind) :: xConst ! LH_fus/(gravity*Tfreeze), used in freezing point depression equation (m K-1) + real(rkind) :: vTheta ! volumetric fraction of total water (-) + real(rkind) :: volLiq ! volumetric fraction of liquid water (-) + real(rkind) :: volIce ! volumetric fraction of ice (-) + real(rkind) :: volFracLiq1,volFracLiq2 ! different trial values of volumetric liquid water content (-) + real(rkind) :: effSat ! effective saturation (-) + real(rkind) :: psiLiq ! liquid water matric potential (m) + real(rkind) :: hydCon ! hydraulic conductivity (m s-1) + real(rkind) :: hydIce ! hydraulic conductivity after accounting for ice impedance (-) + real(rkind),parameter :: dx = 1.e-8_rkind ! finite difference increment (m) ! initialize error control err=0; message="diagv_node/" @@ -1020,11 +1020,11 @@ subroutine diagv_node(& ! (compute derivative for macropores) if(localVolFracLiq > theta_mp)then relSatMP = (localVolFracLiq - theta_mp)/(theta_sat - theta_mp) - dHydCondMacro_dVolLiq = ((scalarSatHydCondMP - scalarSatHydCond)/(theta_sat - theta_mp))*mpExp*(relSatMP**(mpExp - 1._dp)) + dHydCondMacro_dVolLiq = ((scalarSatHydCondMP - scalarSatHydCond)/(theta_sat - theta_mp))*mpExp*(relSatMP**(mpExp - 1._rkind)) dHydCondMacro_dMatric = scalardTheta_dPsi*dHydCondMacro_dVolLiq else - dHydCondMacro_dVolLiq = 0._dp - dHydCondMacro_dMatric = 0._dp + dHydCondMacro_dVolLiq = 0._rkind + dHydCondMacro_dMatric = 0._rkind end if ! (compute derivatives for micropores) if(scalarVolFracIceTrial > verySmall)then @@ -1032,7 +1032,7 @@ subroutine diagv_node(& dHydCondMicro_dTemp = dPsiLiq_dTemp*dK_dPsi__noIce ! m s-1 K-1 dHydCondMicro_dMatric = hydCond_noIce*dIceImpede_dLiq*scalardTheta_dPsi + dK_dPsi__noIce*iceImpedeFac else - dHydCondMicro_dTemp = 0._dp + dHydCondMicro_dTemp = 0._rkind dHydCondMicro_dMatric = dHydCond_dPsi(scalarMatricHeadTrial,scalarSatHydCond,vGn_alpha,vGn_n,vGn_m,.true.) end if ! (combine derivatives) @@ -1052,7 +1052,7 @@ subroutine diagv_node(& volLiq = volFracLiq(xConst*(scalarTempTrial+dx - Tfreeze),vGn_alpha,theta_res,theta_sat,vGn_n,vGn_m) volIce = vTheta - volLiq effSat = (volLiq - theta_res)/(theta_sat - volIce - theta_res) - psiLiq = matricHead(effSat,vGn_alpha,0._dp,1._dp,vGn_n,vGn_m) ! use effective saturation, so theta_res=0 and theta_sat=1 + psiLiq = matricHead(effSat,vGn_alpha,0._rkind,1._rkind,vGn_n,vGn_m) ! use effective saturation, so theta_res=0 and theta_sat=1 hydCon = hydCond_psi(psiLiq,scalarSatHydCond,vGn_alpha,vGn_n,vGn_m) call iceImpede(volIce,f_impede,iceImpedeFac,dIceImpede_dLiq) hydIce = hydCon*iceImpedeFac @@ -1150,48 +1150,48 @@ subroutine surfaceFlx(& integer(i4b),intent(in) :: nRoots ! number of layers that contain roots integer(i4b),intent(in) :: ixIce ! index of lowest ice layer ! input: state and diagnostic variables - real(dp),intent(in) :: scalarMatricHead ! matric head in the upper-most soil layer (m) - real(dp),intent(in) :: scalarVolFracLiq ! volumetric liquid water content in the upper-most soil layer (-) - real(dp),intent(in) :: mLayerVolFracLiq(:) ! volumetric liquid water content in each soil layer (-) - real(dp),intent(in) :: mLayerVolFracIce(:) ! volumetric ice content in each soil layer (-) + real(rkind),intent(in) :: scalarMatricHead ! matric head in the upper-most soil layer (m) + real(rkind),intent(in) :: scalarVolFracLiq ! volumetric liquid water content in the upper-most soil layer (-) + real(rkind),intent(in) :: mLayerVolFracLiq(:) ! volumetric liquid water content in each soil layer (-) + real(rkind),intent(in) :: mLayerVolFracIce(:) ! volumetric ice content in each soil layer (-) ! input: depth of upper-most soil layer (m) - real(dp),intent(in) :: mLayerDepth(:) ! depth of upper-most soil layer (m) - real(dp),intent(in) :: iLayerHeight(0:) ! height at the interface of each layer (m) + real(rkind),intent(in) :: mLayerDepth(:) ! depth of upper-most soil layer (m) + real(rkind),intent(in) :: iLayerHeight(0:) ! height at the interface of each layer (m) ! input: diriclet boundary conditions - real(dp),intent(in) :: upperBoundHead ! upper boundary condition for matric head (m) - real(dp),intent(in) :: upperBoundTheta ! upper boundary condition for volumetric liquid water content (-) + real(rkind),intent(in) :: upperBoundHead ! upper boundary condition for matric head (m) + real(rkind),intent(in) :: upperBoundTheta ! upper boundary condition for volumetric liquid water content (-) ! input: flux at the upper boundary - real(dp),intent(in) :: scalarRainPlusMelt ! rain plus melt, used as input to the soil zone before computing surface runoff (m s-1) + real(rkind),intent(in) :: scalarRainPlusMelt ! rain plus melt, used as input to the soil zone before computing surface runoff (m s-1) ! input: transmittance - real(dp),intent(in) :: surfaceSatHydCond ! saturated hydraulic conductivity at the surface (m s-1) - real(dp),intent(in) :: dHydCond_dTemp ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) - real(dp),intent(in) :: iceImpedeFac ! ice impedence factor in the upper-most soil layer (-) + real(rkind),intent(in) :: surfaceSatHydCond ! saturated hydraulic conductivity at the surface (m s-1) + real(rkind),intent(in) :: dHydCond_dTemp ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) + real(rkind),intent(in) :: iceImpedeFac ! ice impedence factor in the upper-most soil layer (-) ! input: soil parameters - real(dp),intent(in) :: vGn_alpha ! van Genutchen "alpha" parameter (m-1) - real(dp),intent(in) :: vGn_n ! van Genutchen "n" parameter (-) - real(dp),intent(in) :: vGn_m ! van Genutchen "m" parameter (-) - real(dp),intent(in) :: theta_sat ! soil porosity (-) - real(dp),intent(in) :: theta_res ! soil residual volumetric water content (-) - real(dp),intent(in) :: qSurfScale ! scaling factor in the surface runoff parameterization (-) - real(dp),intent(in) :: zScale_TOPMODEL ! scaling factor used to describe decrease in hydraulic conductivity with depth (m) - real(dp),intent(in) :: rootingDepth ! rooting depth (m) - real(dp),intent(in) :: wettingFrontSuction ! Green-Ampt wetting front suction (m) - real(dp),intent(in) :: soilIceScale ! soil ice scaling factor in Gamma distribution used to define frozen area (m) - real(dp),intent(in) :: soilIceCV ! soil ice CV in Gamma distribution used to define frozen area (-) + real(rkind),intent(in) :: vGn_alpha ! van Genutchen "alpha" parameter (m-1) + real(rkind),intent(in) :: vGn_n ! van Genutchen "n" parameter (-) + real(rkind),intent(in) :: vGn_m ! van Genutchen "m" parameter (-) + real(rkind),intent(in) :: theta_sat ! soil porosity (-) + real(rkind),intent(in) :: theta_res ! soil residual volumetric water content (-) + real(rkind),intent(in) :: qSurfScale ! scaling factor in the surface runoff parameterization (-) + real(rkind),intent(in) :: zScale_TOPMODEL ! scaling factor used to describe decrease in hydraulic conductivity with depth (m) + real(rkind),intent(in) :: rootingDepth ! rooting depth (m) + real(rkind),intent(in) :: wettingFrontSuction ! Green-Ampt wetting front suction (m) + real(rkind),intent(in) :: soilIceScale ! soil ice scaling factor in Gamma distribution used to define frozen area (m) + real(rkind),intent(in) :: soilIceCV ! soil ice CV in Gamma distribution used to define frozen area (-) ! ----------------------------------------------------------------------------------------------------------------------------- ! input-output: hydraulic conductivity and diffusivity at the surface ! NOTE: intent(inout) because infiltration may only be computed for the first iteration - real(dp),intent(inout) :: surfaceHydCond ! hydraulic conductivity (m s-1) - real(dp),intent(inout) :: surfaceDiffuse ! hydraulic diffusivity at the surface (m + real(rkind),intent(inout) :: surfaceHydCond ! hydraulic conductivity (m s-1) + real(rkind),intent(inout) :: surfaceDiffuse ! hydraulic diffusivity at the surface (m ! output: surface runoff and infiltration flux (m s-1) - real(dp),intent(inout) :: xMaxInfilRate ! maximum infiltration rate (m s-1) - real(dp),intent(inout) :: scalarInfilArea ! fraction of unfrozen area where water can infiltrate (-) - real(dp),intent(inout) :: scalarFrozenArea ! fraction of area that is considered impermeable due to soil ice (-) - real(dp),intent(out) :: scalarSurfaceRunoff ! surface runoff (m s-1) - real(dp),intent(out) :: scalarSurfaceInfiltration ! surface infiltration (m s-1) + real(rkind),intent(inout) :: xMaxInfilRate ! maximum infiltration rate (m s-1) + real(rkind),intent(inout) :: scalarInfilArea ! fraction of unfrozen area where water can infiltrate (-) + real(rkind),intent(inout) :: scalarFrozenArea ! fraction of area that is considered impermeable due to soil ice (-) + real(rkind),intent(out) :: scalarSurfaceRunoff ! surface runoff (m s-1) + real(rkind),intent(out) :: scalarSurfaceInfiltration ! surface infiltration (m s-1) ! output: deriavtives in surface infiltration w.r.t. volumetric liquid water (m s-1) and matric head (s-1) in the upper-most soil layer - real(dp),intent(out) :: dq_dHydState ! derivative in surface infiltration w.r.t. state variable in the upper-most soil layer (m s-1 or s-1) - real(dp),intent(out) :: dq_dNrgState ! derivative in surface infiltration w.r.t. energy state variable in the upper-most soil layer (m s-1 K-1) + real(rkind),intent(out) :: dq_dHydState ! derivative in surface infiltration w.r.t. state variable in the upper-most soil layer (m s-1 or s-1) + real(rkind),intent(out) :: dq_dNrgState ! derivative in surface infiltration w.r.t. energy state variable in the upper-most soil layer (m s-1 K-1) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message @@ -1200,29 +1200,29 @@ subroutine surfaceFlx(& ! (general) integer(i4b) :: iLayer ! index of soil layer ! (head boundary condition) - real(dp) :: cFlux ! capillary flux (m s-1) - real(dp) :: dNum ! numerical derivative + real(rkind) :: cFlux ! capillary flux (m s-1) + real(rkind) :: dNum ! numerical derivative ! (simplified Green-Ampt infiltration) - real(dp) :: rootZoneLiq ! depth of liquid water in the root zone (m) - real(dp) :: rootZoneIce ! depth of ice in the root zone (m) - real(dp) :: availCapacity ! available storage capacity in the root zone (m) - real(dp) :: depthWettingFront ! depth to the wetting front (m) - real(dp) :: hydCondWettingFront ! hydraulic conductivity at the wetting front (m s-1) + real(rkind) :: rootZoneLiq ! depth of liquid water in the root zone (m) + real(rkind) :: rootZoneIce ! depth of ice in the root zone (m) + real(rkind) :: availCapacity ! available storage capacity in the root zone (m) + real(rkind) :: depthWettingFront ! depth to the wetting front (m) + real(rkind) :: hydCondWettingFront ! hydraulic conductivity at the wetting front (m s-1) ! (saturated area associated with variable storage capacity) - real(dp) :: fracCap ! fraction of pore space filled with liquid water and ice (-) - real(dp) :: fInfRaw ! infiltrating area before imposing solution constraints (-) - real(dp),parameter :: maxFracCap=0.995_dp ! maximum fraction capacity -- used to avoid numerical problems associated with an enormous derivative - real(dp),parameter :: scaleFactor=0.000001_dp ! scale factor for the smoothing function (-) - real(dp),parameter :: qSurfScaleMax=1000._dp ! maximum surface runoff scaling factor (-) + real(rkind) :: fracCap ! fraction of pore space filled with liquid water and ice (-) + real(rkind) :: fInfRaw ! infiltrating area before imposing solution constraints (-) + real(rkind),parameter :: maxFracCap=0.995_rkind ! maximum fraction capacity -- used to avoid numerical problems associated with an enormous derivative + real(rkind),parameter :: scaleFactor=0.000001_rkind ! scale factor for the smoothing function (-) + real(rkind),parameter :: qSurfScaleMax=1000._rkind ! maximum surface runoff scaling factor (-) ! (fraction of impermeable area associated with frozen ground) - real(dp) :: alpha ! shape parameter in the Gamma distribution - real(dp) :: xLimg ! upper limit of the integral + real(rkind) :: alpha ! shape parameter in the Gamma distribution + real(rkind) :: xLimg ! upper limit of the integral ! initialize error control err=0; message="surfaceFlx/" ! compute derivative in the energy state ! NOTE: revisit the need to do this - dq_dNrgState = 0._dp + dq_dNrgState = 0._rkind ! ***** ! compute the surface flux and its derivative @@ -1233,7 +1233,7 @@ subroutine surfaceFlx(& case(prescribedHead) ! surface runoff iz zero for the head condition - scalarSurfaceRunoff = 0._dp + scalarSurfaceRunoff = 0._rkind ! compute transmission and the capillary flux select case(ixRichards) ! (form of Richards' equation) @@ -1242,13 +1242,13 @@ subroutine surfaceFlx(& surfaceHydCond = hydCond_liq(upperBoundTheta,surfaceSatHydCond,theta_res,theta_sat,vGn_m) * iceImpedeFac surfaceDiffuse = dPsi_dTheta(upperBoundTheta,vGn_alpha,theta_res,theta_sat,vGn_n,vGn_m) * surfaceHydCond ! compute the capillary flux - cflux = -surfaceDiffuse*(scalarVolFracLiq - upperBoundTheta) / (mLayerDepth(1)*0.5_dp) + cflux = -surfaceDiffuse*(scalarVolFracLiq - upperBoundTheta) / (mLayerDepth(1)*0.5_rkind) case(mixdform) ! compute the hydraulic conductivity and diffusivity at the boundary surfaceHydCond = hydCond_psi(upperBoundHead,surfaceSatHydCond,vGn_alpha,vGn_n,vGn_m) * iceImpedeFac surfaceDiffuse = realMissing ! compute the capillary flux - cflux = -surfaceHydCond*(scalarMatricHead - upperBoundHead) / (mLayerDepth(1)*0.5_dp) + cflux = -surfaceHydCond*(scalarMatricHead - upperBoundHead) / (mLayerDepth(1)*0.5_rkind) case default; err=10; message=trim(message)//"unknown form of Richards' equation"; return end select ! (form of Richards' eqn) ! compute the total flux @@ -1257,19 +1257,19 @@ subroutine surfaceFlx(& if(deriv_desired)then ! compute the hydrology derivative select case(ixRichards) ! (form of Richards' equation) - case(moisture); dq_dHydState = -surfaceDiffuse/(mLayerDepth(1)/2._dp) - case(mixdform); dq_dHydState = -surfaceHydCond/(mLayerDepth(1)/2._dp) + case(moisture); dq_dHydState = -surfaceDiffuse/(mLayerDepth(1)/2._rkind) + case(mixdform); dq_dHydState = -surfaceHydCond/(mLayerDepth(1)/2._rkind) case default; err=10; message=trim(message)//"unknown form of Richards' equation"; return end select ! compute the energy derivative - dq_dNrgState = -(dHydCond_dTemp/2._dp)*(scalarMatricHead - upperBoundHead)/(mLayerDepth(1)*0.5_dp) + dHydCond_dTemp/2._dp + dq_dNrgState = -(dHydCond_dTemp/2._rkind)*(scalarMatricHead - upperBoundHead)/(mLayerDepth(1)*0.5_rkind) + dHydCond_dTemp/2._rkind ! compute the numerical derivative - !cflux = -surfaceHydCond*((scalarMatricHead+dx) - upperBoundHead) / (mLayerDepth(1)*0.5_dp) + !cflux = -surfaceHydCond*((scalarMatricHead+dx) - upperBoundHead) / (mLayerDepth(1)*0.5_rkind) !surfaceInfiltration1 = cflux + surfaceHydCond !dNum = (surfaceInfiltration1 - scalarSurfaceInfiltration)/dx else - dq_dHydState = 0._dp - dNum = 0._dp + dq_dHydState = 0._rkind + dNum = 0._rkind end if !write(*,'(a,1x,10(e30.20,1x))') 'scalarMatricHead, scalarSurfaceInfiltration, dq_dHydState, dNum = ', & ! scalarMatricHead, scalarSurfaceInfiltration, dq_dHydState, dNum @@ -1282,8 +1282,8 @@ subroutine surfaceFlx(& if(doInfiltration)then ! define the storage in the root zone (m) - rootZoneLiq = 0._dp - rootZoneIce = 0._dp + rootZoneLiq = 0._rkind + rootZoneIce = 0._rkind ! (process layers where the roots extend to the bottom of the layer) if(nRoots > 1)then do iLayer=1,nRoots-1 @@ -1306,7 +1306,7 @@ subroutine surfaceFlx(& depthWettingFront = (rootZoneLiq/availCapacity)*rootingDepth ! define the hydraulic conductivity at depth=depthWettingFront (m s-1) - hydCondWettingFront = surfaceSatHydCond * ( (1._dp - depthWettingFront/sum(mLayerDepth))**(zScale_TOPMODEL - 1._dp) ) + hydCondWettingFront = surfaceSatHydCond * ( (1._rkind - depthWettingFront/sum(mLayerDepth))**(zScale_TOPMODEL - 1._rkind) ) ! define the maximum infiltration rate (m s-1) xMaxInfilRate = hydCondWettingFront*( (wettingFrontSuction + depthWettingFront)/depthWettingFront ) ! maximum infiltration rate (m s-1) @@ -1315,15 +1315,15 @@ subroutine surfaceFlx(& ! define the infiltrating area for the non-frozen part of the cell/basin if(qSurfScale < qSurfScaleMax)then fracCap = rootZoneLiq/(maxFracCap*availCapacity) ! fraction of available root zone filled with water - fInfRaw = 1._dp - exp(-qSurfScale*(1._dp - fracCap)) ! infiltrating area -- allowed to violate solution constraints - scalarInfilArea = min(0.5_dp*(fInfRaw + sqrt(fInfRaw**2._dp + scaleFactor)), 1._dp) ! infiltrating area -- constrained + fInfRaw = 1._rkind - exp(-qSurfScale*(1._rkind - fracCap)) ! infiltrating area -- allowed to violate solution constraints + scalarInfilArea = min(0.5_rkind*(fInfRaw + sqrt(fInfRaw**2._rkind + scaleFactor)), 1._rkind) ! infiltrating area -- constrained else - scalarInfilArea = 1._dp + scalarInfilArea = 1._rkind endif ! check to ensure we are not infiltrating into a fully saturated column if(ixIce 0.9999_dp*theta_sat*sum(mLayerDepth(ixIce+1:nRoots))) scalarInfilArea=0._dp + if(sum(mLayerVolFracLiq(ixIce+1:nRoots)*mLayerDepth(ixIce+1:nRoots)) > 0.9999_rkind*theta_sat*sum(mLayerDepth(ixIce+1:nRoots))) scalarInfilArea=0._rkind !print*, 'ixIce, nRoots, scalarInfilArea = ', ixIce, nRoots, scalarInfilArea !print*, 'sum(mLayerVolFracLiq(ixIce+1:nRoots)*mLayerDepth(ixIce+1:nRoots)) = ', sum(mLayerVolFracLiq(ixIce+1:nRoots)*mLayerDepth(ixIce+1:nRoots)) !print*, 'theta_sat*sum(mLayerDepth(ixIce+1:nRoots)) = ', theta_sat*sum(mLayerDepth(ixIce+1:nRoots)) @@ -1331,25 +1331,25 @@ subroutine surfaceFlx(& ! define the impermeable area due to frozen ground if(rootZoneIce > tiny(rootZoneIce))then ! (avoid divide by zero) - alpha = 1._dp/(soilIceCV**2._dp) ! shape parameter in the Gamma distribution + alpha = 1._rkind/(soilIceCV**2._rkind) ! shape parameter in the Gamma distribution xLimg = alpha*soilIceScale/rootZoneIce ! upper limit of the integral - !scalarFrozenArea = 1._dp - gammp(alpha,xLimg) ! fraction of frozen area - scalarFrozenArea = 0._dp + !scalarFrozenArea = 1._rkind - gammp(alpha,xLimg) ! fraction of frozen area + scalarFrozenArea = 0._rkind else - scalarFrozenArea = 0._dp + scalarFrozenArea = 0._rkind end if !print*, 'scalarFrozenArea, rootZoneIce = ', scalarFrozenArea, rootZoneIce end if ! (if desire to compute infiltration) ! compute infiltration (m s-1) - scalarSurfaceInfiltration = (1._dp - scalarFrozenArea)*scalarInfilArea*min(scalarRainPlusMelt,xMaxInfilRate) + scalarSurfaceInfiltration = (1._rkind - scalarFrozenArea)*scalarInfilArea*min(scalarRainPlusMelt,xMaxInfilRate) ! compute surface runoff (m s-1) scalarSurfaceRunoff = scalarRainPlusMelt - scalarSurfaceInfiltration !print*, 'scalarRainPlusMelt, xMaxInfilRate = ', scalarRainPlusMelt, xMaxInfilRate !print*, 'scalarSurfaceInfiltration, scalarSurfaceRunoff = ', scalarSurfaceInfiltration, scalarSurfaceRunoff - !print*, '(1._dp - scalarFrozenArea), (1._dp - scalarFrozenArea)*scalarInfilArea = ', (1._dp - scalarFrozenArea), (1._dp - scalarFrozenArea)*scalarInfilArea + !print*, '(1._rkind - scalarFrozenArea), (1._rkind - scalarFrozenArea)*scalarInfilArea = ', (1._rkind - scalarFrozenArea), (1._rkind - scalarFrozenArea)*scalarInfilArea ! set surface hydraulic conductivity and diffusivity to missing (not used for flux condition) surfaceHydCond = realMissing @@ -1358,8 +1358,8 @@ subroutine surfaceFlx(& ! set numerical derivative to zero ! NOTE 1: Depends on multiple soil layers and does not jive with the current tridiagonal matrix ! NOTE 2: Need to define the derivative at every call, because intent(out) - dq_dHydState = 0._dp - dq_dNrgState = 0._dp + dq_dHydState = 0._rkind + dq_dNrgState = 0._rkind ! ***** error check case default; err=20; message=trim(message)//'unknown upper boundary condition for soil hydrology'; return @@ -1409,31 +1409,31 @@ subroutine iLayerFlux(& logical(lgt),intent(in) :: deriv_desired ! flag indicating if derivatives are desired integer(i4b),intent(in) :: ixRichards ! index defining the option for Richards' equation (moisture or mixdform) ! input: state variables - real(dp),intent(in) :: nodeMatricHeadTrial(:) ! matric head at the soil nodes (m) - real(dp),intent(in) :: nodeVolFracLiqTrial(:) ! volumetric fraction of liquid water at the soil nodes (-) + real(rkind),intent(in) :: nodeMatricHeadTrial(:) ! matric head at the soil nodes (m) + real(rkind),intent(in) :: nodeVolFracLiqTrial(:) ! volumetric fraction of liquid water at the soil nodes (-) ! input: model coordinate variables - real(dp),intent(in) :: nodeHeight(:) ! height at the mid-point of the lower layer (m) + real(rkind),intent(in) :: nodeHeight(:) ! height at the mid-point of the lower layer (m) ! input: temperature derivatives - real(dp),intent(in) :: dPsiLiq_dTemp(:) ! derivative in liquid water matric potential w.r.t. temperature (m K-1) - real(dp),intent(in) :: dHydCond_dTemp(:) ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) + real(rkind),intent(in) :: dPsiLiq_dTemp(:) ! derivative in liquid water matric potential w.r.t. temperature (m K-1) + real(rkind),intent(in) :: dHydCond_dTemp(:) ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) ! input: transmittance - real(dp),intent(in) :: nodeHydCondTrial(:) ! hydraulic conductivity at layer mid-points (m s-1) - real(dp),intent(in) :: nodeDiffuseTrial(:) ! diffusivity at layer mid-points (m2 s-1) + real(rkind),intent(in) :: nodeHydCondTrial(:) ! hydraulic conductivity at layer mid-points (m s-1) + real(rkind),intent(in) :: nodeDiffuseTrial(:) ! diffusivity at layer mid-points (m2 s-1) ! input: transmittance derivatives - real(dp),intent(in) :: dHydCond_dVolLiq(:) ! derivative in hydraulic conductivity w.r.t volumetric liquid water content (m s-1) - real(dp),intent(in) :: dDiffuse_dVolLiq(:) ! derivative in hydraulic diffusivity w.r.t volumetric liquid water content (m2 s-1) - real(dp),intent(in) :: dHydCond_dMatric(:) ! derivative in hydraulic conductivity w.r.t matric head (m s-1) + real(rkind),intent(in) :: dHydCond_dVolLiq(:) ! derivative in hydraulic conductivity w.r.t volumetric liquid water content (m s-1) + real(rkind),intent(in) :: dDiffuse_dVolLiq(:) ! derivative in hydraulic diffusivity w.r.t volumetric liquid water content (m2 s-1) + real(rkind),intent(in) :: dHydCond_dMatric(:) ! derivative in hydraulic conductivity w.r.t matric head (m s-1) ! output: tranmsmittance at the layer interface (scalars) - real(dp),intent(out) :: iLayerHydCond ! hydraulic conductivity at the interface between layers (m s-1) - real(dp),intent(out) :: iLayerDiffuse ! hydraulic diffusivity at the interface between layers (m2 s-1) + real(rkind),intent(out) :: iLayerHydCond ! hydraulic conductivity at the interface between layers (m s-1) + real(rkind),intent(out) :: iLayerDiffuse ! hydraulic diffusivity at the interface between layers (m2 s-1) ! output: vertical flux at the layer interface (scalars) - real(dp),intent(out) :: iLayerLiqFluxSoil ! vertical flux of liquid water at the layer interface (m s-1) + real(rkind),intent(out) :: iLayerLiqFluxSoil ! vertical flux of liquid water at the layer interface (m s-1) ! output: derivatives in fluxes w.r.t. state variables -- matric head or volumetric lquid water -- in the layer above and layer below (m s-1 or s-1) - real(dp),intent(out) :: dq_dHydStateAbove ! derivatives in the flux w.r.t. matric head or volumetric lquid water in the layer above (m s-1 or s-1) - real(dp),intent(out) :: dq_dHydStateBelow ! derivatives in the flux w.r.t. matric head or volumetric lquid water in the layer below (m s-1 or s-1) + real(rkind),intent(out) :: dq_dHydStateAbove ! derivatives in the flux w.r.t. matric head or volumetric lquid water in the layer above (m s-1 or s-1) + real(rkind),intent(out) :: dq_dHydStateBelow ! derivatives in the flux w.r.t. matric head or volumetric lquid water in the layer below (m s-1 or s-1) ! output: derivatives in fluxes w.r.t. energy state variables -- now just temperature -- in the layer above and layer below (m s-1 K-1) - real(dp),intent(out) :: dq_dNrgStateAbove ! derivatives in the flux w.r.t. temperature in the layer above (m s-1 K-1) - real(dp),intent(out) :: dq_dNrgStateBelow ! derivatives in the flux w.r.t. temperature in the layer below (m s-1 K-1) + real(rkind),intent(out) :: dq_dNrgStateAbove ! derivatives in the flux w.r.t. temperature in the layer above (m s-1 K-1) + real(rkind),intent(out) :: dq_dNrgStateBelow ! derivatives in the flux w.r.t. temperature in the layer below (m s-1 K-1) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message @@ -1443,17 +1443,17 @@ subroutine iLayerFlux(& integer(i4b),parameter :: ixLower=2 ! index of lower node in the 2-element vectors logical(lgt),parameter :: useGeometric=.false. ! switch between the arithmetic and geometric mean ! local variables (Darcy flux) - real(dp) :: dPsi ! spatial difference in matric head (m) - real(dp) :: dLiq ! spatial difference in volumetric liquid water (-) - real(dp) :: dz ! spatial difference in layer mid-points (m) - real(dp) :: cflux ! capillary flux (m s-1) + real(rkind) :: dPsi ! spatial difference in matric head (m) + real(rkind) :: dLiq ! spatial difference in volumetric liquid water (-) + real(rkind) :: dz ! spatial difference in layer mid-points (m) + real(rkind) :: cflux ! capillary flux (m s-1) ! local variables (derivative in Darcy's flux) - real(dp) :: dHydCondIface_dVolLiqAbove ! derivative in hydraulic conductivity at layer interface w.r.t. volumetric liquid water content in layer above - real(dp) :: dHydCondIface_dVolLiqBelow ! derivative in hydraulic conductivity at layer interface w.r.t. volumetric liquid water content in layer below - real(dp) :: dDiffuseIface_dVolLiqAbove ! derivative in hydraulic diffusivity at layer interface w.r.t. volumetric liquid water content in layer above - real(dp) :: dDiffuseIface_dVolLiqBelow ! derivative in hydraulic diffusivity at layer interface w.r.t. volumetric liquid water content in layer below - real(dp) :: dHydCondIface_dMatricAbove ! derivative in hydraulic conductivity at layer interface w.r.t. matric head in layer above - real(dp) :: dHydCondIface_dMatricBelow ! derivative in hydraulic conductivity at layer interface w.r.t. matric head in layer below + real(rkind) :: dHydCondIface_dVolLiqAbove ! derivative in hydraulic conductivity at layer interface w.r.t. volumetric liquid water content in layer above + real(rkind) :: dHydCondIface_dVolLiqBelow ! derivative in hydraulic conductivity at layer interface w.r.t. volumetric liquid water content in layer below + real(rkind) :: dDiffuseIface_dVolLiqAbove ! derivative in hydraulic diffusivity at layer interface w.r.t. volumetric liquid water content in layer above + real(rkind) :: dDiffuseIface_dVolLiqBelow ! derivative in hydraulic diffusivity at layer interface w.r.t. volumetric liquid water content in layer below + real(rkind) :: dHydCondIface_dMatricAbove ! derivative in hydraulic conductivity at layer interface w.r.t. matric head in layer above + real(rkind) :: dHydCondIface_dMatricBelow ! derivative in hydraulic conductivity at layer interface w.r.t. matric head in layer below ! ------------------------------------------------------------------------------------------------------------------------------------------------------------------------ ! initialize error control err=0; message="iLayerFlux/" @@ -1462,9 +1462,9 @@ subroutine iLayerFlux(& ! compute the vertical flux of liquid water ! compute the hydraulic conductivity at the interface if(useGeometric)then - iLayerHydCond = (nodeHydCondTrial(ixLower) * nodeHydCondTrial(ixUpper))**0.5_dp + iLayerHydCond = (nodeHydCondTrial(ixLower) * nodeHydCondTrial(ixUpper))**0.5_rkind else - iLayerHydCond = (nodeHydCondTrial(ixLower) + nodeHydCondTrial(ixUpper))*0.5_dp + iLayerHydCond = (nodeHydCondTrial(ixLower) + nodeHydCondTrial(ixUpper))*0.5_rkind end if !write(*,'(a,1x,5(e20.10,1x))') 'in iLayerFlux: iLayerHydCond, iLayerHydCondMP = ', iLayerHydCond, iLayerHydCondMP ! compute the height difference between nodes @@ -1472,7 +1472,7 @@ subroutine iLayerFlux(& ! compute the capillary flux select case(ixRichards) ! (form of Richards' equation) case(moisture) - iLayerDiffuse = (nodeDiffuseTrial(ixLower) * nodeDiffuseTrial(ixUpper))**0.5_dp + iLayerDiffuse = (nodeDiffuseTrial(ixLower) * nodeDiffuseTrial(ixUpper))**0.5_rkind dLiq = nodeVolFracLiqTrial(ixLower) - nodeVolFracLiqTrial(ixUpper) cflux = -iLayerDiffuse * dLiq/dz case(mixdform) @@ -1496,29 +1496,29 @@ subroutine iLayerFlux(& err=20; return end if ! derivatives in hydraulic conductivity at the layer interface (m s-1) - dHydCondIface_dVolLiqAbove = dHydCond_dVolLiq(ixUpper)*nodeHydCondTrial(ixLower) * 0.5_dp/max(iLayerHydCond,verySmall) - dHydCondIface_dVolLiqBelow = dHydCond_dVolLiq(ixLower)*nodeHydCondTrial(ixUpper) * 0.5_dp/max(iLayerHydCond,verySmall) + dHydCondIface_dVolLiqAbove = dHydCond_dVolLiq(ixUpper)*nodeHydCondTrial(ixLower) * 0.5_rkind/max(iLayerHydCond,verySmall) + dHydCondIface_dVolLiqBelow = dHydCond_dVolLiq(ixLower)*nodeHydCondTrial(ixUpper) * 0.5_rkind/max(iLayerHydCond,verySmall) ! derivatives in hydraulic diffusivity at the layer interface (m2 s-1) - dDiffuseIface_dVolLiqAbove = dDiffuse_dVolLiq(ixUpper)*nodeDiffuseTrial(ixLower) * 0.5_dp/max(iLayerDiffuse,verySmall) - dDiffuseIface_dVolLiqBelow = dDiffuse_dVolLiq(ixLower)*nodeDiffuseTrial(ixUpper) * 0.5_dp/max(iLayerDiffuse,verySmall) + dDiffuseIface_dVolLiqAbove = dDiffuse_dVolLiq(ixUpper)*nodeDiffuseTrial(ixLower) * 0.5_rkind/max(iLayerDiffuse,verySmall) + dDiffuseIface_dVolLiqBelow = dDiffuse_dVolLiq(ixLower)*nodeDiffuseTrial(ixUpper) * 0.5_rkind/max(iLayerDiffuse,verySmall) ! derivatives in the flux w.r.t. volumetric liquid water content dq_dHydStateAbove = -dDiffuseIface_dVolLiqAbove*dLiq/dz + iLayerDiffuse/dz + dHydCondIface_dVolLiqAbove dq_dHydStateBelow = -dDiffuseIface_dVolLiqBelow*dLiq/dz - iLayerDiffuse/dz + dHydCondIface_dVolLiqBelow case(mixdform) ! derivatives in hydraulic conductivity if(useGeometric)then - dHydCondIface_dMatricAbove = dHydCond_dMatric(ixUpper)*nodeHydCondTrial(ixLower) * 0.5_dp/max(iLayerHydCond,verySmall) - dHydCondIface_dMatricBelow = dHydCond_dMatric(ixLower)*nodeHydCondTrial(ixUpper) * 0.5_dp/max(iLayerHydCond,verySmall) + dHydCondIface_dMatricAbove = dHydCond_dMatric(ixUpper)*nodeHydCondTrial(ixLower) * 0.5_rkind/max(iLayerHydCond,verySmall) + dHydCondIface_dMatricBelow = dHydCond_dMatric(ixLower)*nodeHydCondTrial(ixUpper) * 0.5_rkind/max(iLayerHydCond,verySmall) else - dHydCondIface_dMatricAbove = dHydCond_dMatric(ixUpper)/2._dp - dHydCondIface_dMatricBelow = dHydCond_dMatric(ixLower)/2._dp + dHydCondIface_dMatricAbove = dHydCond_dMatric(ixUpper)/2._rkind + dHydCondIface_dMatricBelow = dHydCond_dMatric(ixLower)/2._rkind end if ! derivatives in the flux w.r.t. matric head dq_dHydStateAbove = -dHydCondIface_dMatricAbove*dPsi/dz + iLayerHydCond/dz + dHydCondIface_dMatricAbove dq_dHydStateBelow = -dHydCondIface_dMatricBelow*dPsi/dz - iLayerHydCond/dz + dHydCondIface_dMatricBelow ! derivative in the flux w.r.t. temperature - dq_dNrgStateAbove = -(dHydCond_dTemp(ixUpper)/2._dp)*dPsi/dz + iLayerHydCond*dPsiLiq_dTemp(ixUpper)/dz + dHydCond_dTemp(ixUpper)/2._dp - dq_dNrgStateBelow = -(dHydCond_dTemp(ixLower)/2._dp)*dPsi/dz - iLayerHydCond*dPsiLiq_dTemp(ixLower)/dz + dHydCond_dTemp(ixLower)/2._dp + dq_dNrgStateAbove = -(dHydCond_dTemp(ixUpper)/2._rkind)*dPsi/dz + iLayerHydCond*dPsiLiq_dTemp(ixUpper)/dz + dHydCond_dTemp(ixUpper)/2._rkind + dq_dNrgStateBelow = -(dHydCond_dTemp(ixLower)/2._rkind)*dPsi/dz - iLayerHydCond*dPsiLiq_dTemp(ixLower)/dz + dHydCond_dTemp(ixLower)/2._rkind case default; err=10; message=trim(message)//"unknown form of Richards' equation"; return end select else @@ -1588,50 +1588,50 @@ subroutine qDrainFlux(& integer(i4b),intent(in) :: ixRichards ! index defining the option for Richards' equation (moisture or mixdform) integer(i4b),intent(in) :: bc_lower ! index defining the type of boundary conditions ! input: state and diagnostic variables - real(dp),intent(in) :: nodeMatricHead ! matric head in the lowest unsaturated node (m) - real(dp),intent(in) :: nodeVolFracLiq ! volumetric liquid water content in the lowest unsaturated node (-) + real(rkind),intent(in) :: nodeMatricHead ! matric head in the lowest unsaturated node (m) + real(rkind),intent(in) :: nodeVolFracLiq ! volumetric liquid water content in the lowest unsaturated node (-) ! input: model coordinate variables - real(dp),intent(in) :: nodeDepth ! depth of the lowest unsaturated soil layer (m) - real(dp),intent(in) :: nodeHeight ! height of the lowest unsaturated soil node (m) + real(rkind),intent(in) :: nodeDepth ! depth of the lowest unsaturated soil layer (m) + real(rkind),intent(in) :: nodeHeight ! height of the lowest unsaturated soil node (m) ! input: diriclet boundary conditions - real(dp),intent(in) :: lowerBoundHead ! lower boundary condition for matric head (m) - real(dp),intent(in) :: lowerBoundTheta ! lower boundary condition for volumetric liquid water content (-) + real(rkind),intent(in) :: lowerBoundHead ! lower boundary condition for matric head (m) + real(rkind),intent(in) :: lowerBoundTheta ! lower boundary condition for volumetric liquid water content (-) ! input: derivative in soil water characteristix - real(dp),intent(in) :: node__dPsi_dTheta ! derivative of the soil moisture characteristic w.r.t. theta (m) + real(rkind),intent(in) :: node__dPsi_dTheta ! derivative of the soil moisture characteristic w.r.t. theta (m) ! input: transmittance - real(dp),intent(in) :: surfaceSatHydCond ! saturated hydraulic conductivity at the surface (m s-1) - real(dp),intent(in) :: bottomSatHydCond ! saturated hydraulic conductivity at the bottom of the unsaturated zone (m s-1) - real(dp),intent(in) :: nodeHydCond ! hydraulic conductivity at the node itself (m s-1) - real(dp),intent(in) :: iceImpedeFac ! ice impedence factor in the upper-most soil layer (-) + real(rkind),intent(in) :: surfaceSatHydCond ! saturated hydraulic conductivity at the surface (m s-1) + real(rkind),intent(in) :: bottomSatHydCond ! saturated hydraulic conductivity at the bottom of the unsaturated zone (m s-1) + real(rkind),intent(in) :: nodeHydCond ! hydraulic conductivity at the node itself (m s-1) + real(rkind),intent(in) :: iceImpedeFac ! ice impedence factor in the upper-most soil layer (-) ! input: transmittance derivatives - real(dp),intent(in) :: dHydCond_dVolLiq ! derivative in hydraulic conductivity w.r.t. volumetric liquid water content (m s-1) - real(dp),intent(in) :: dHydCond_dMatric ! derivative in hydraulic conductivity w.r.t. matric head (s-1) - real(dp),intent(in) :: dHydCond_dTemp ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) + real(rkind),intent(in) :: dHydCond_dVolLiq ! derivative in hydraulic conductivity w.r.t. volumetric liquid water content (m s-1) + real(rkind),intent(in) :: dHydCond_dMatric ! derivative in hydraulic conductivity w.r.t. matric head (s-1) + real(rkind),intent(in) :: dHydCond_dTemp ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) ! input: soil parameters - real(dp),intent(in) :: vGn_alpha ! van Genutchen "alpha" parameter (m-1) - real(dp),intent(in) :: vGn_n ! van Genutchen "n" parameter (-) - real(dp),intent(in) :: vGn_m ! van Genutchen "m" parameter (-) - real(dp),intent(in) :: theta_sat ! soil porosity (-) - real(dp),intent(in) :: theta_res ! soil residual volumetric water content (-) - real(dp),intent(in) :: kAnisotropic ! anisotropy factor for lateral hydraulic conductivity (-) - real(dp),intent(in) :: zScale_TOPMODEL ! scale factor for TOPMODEL-ish baseflow parameterization (m) + real(rkind),intent(in) :: vGn_alpha ! van Genutchen "alpha" parameter (m-1) + real(rkind),intent(in) :: vGn_n ! van Genutchen "n" parameter (-) + real(rkind),intent(in) :: vGn_m ! van Genutchen "m" parameter (-) + real(rkind),intent(in) :: theta_sat ! soil porosity (-) + real(rkind),intent(in) :: theta_res ! soil residual volumetric water content (-) + real(rkind),intent(in) :: kAnisotropic ! anisotropy factor for lateral hydraulic conductivity (-) + real(rkind),intent(in) :: zScale_TOPMODEL ! scale factor for TOPMODEL-ish baseflow parameterization (m) ! ----------------------------------------------------------------------------------------------------------------------------- ! output: hydraulic conductivity at the bottom of the unsaturated zone - real(dp),intent(out) :: bottomHydCond ! hydraulic conductivity at the bottom of the unsaturated zone (m s-1) - real(dp),intent(out) :: bottomDiffuse ! hydraulic diffusivity at the bottom of the unsatuarted zone (m2 s-1) + real(rkind),intent(out) :: bottomHydCond ! hydraulic conductivity at the bottom of the unsaturated zone (m s-1) + real(rkind),intent(out) :: bottomDiffuse ! hydraulic diffusivity at the bottom of the unsatuarted zone (m2 s-1) ! output: drainage flux from the bottom of the soil profile - real(dp),intent(out) :: scalarDrainage ! drainage flux from the bottom of the soil profile (m s-1) + real(rkind),intent(out) :: scalarDrainage ! drainage flux from the bottom of the soil profile (m s-1) ! output: derivatives in drainage flux - real(dp),intent(out) :: dq_dHydStateUnsat ! change in drainage flux w.r.t. change in state variable in lowest unsaturated node (m s-1 or s-1) - real(dp),intent(out) :: dq_dNrgStateUnsat ! change in drainage flux w.r.t. change in energy state variable in lowest unsaturated node (m s-1 K-1) + real(rkind),intent(out) :: dq_dHydStateUnsat ! change in drainage flux w.r.t. change in state variable in lowest unsaturated node (m s-1 or s-1) + real(rkind),intent(out) :: dq_dNrgStateUnsat ! change in drainage flux w.r.t. change in energy state variable in lowest unsaturated node (m s-1 K-1) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! ----------------------------------------------------------------------------------------------------------------------------- ! local variables - real(dp) :: zWater ! effective water table depth (m) - real(dp) :: nodePsi ! matric head in the lowest unsaturated node (m) - real(dp) :: cflux ! capillary flux (m s-1) + real(rkind) :: zWater ! effective water table depth (m) + real(rkind) :: nodePsi ! matric head in the lowest unsaturated node (m) + real(rkind) :: cflux ! capillary flux (m s-1) ! ----------------------------------------------------------------------------------------------------------------------------- ! initialize error control err=0; message="qDrainFlux/" @@ -1651,13 +1651,13 @@ subroutine qDrainFlux(& bottomHydCond = hydCond_liq(lowerBoundTheta,bottomSatHydCond,theta_res,theta_sat,vGn_m) * iceImpedeFac bottomDiffuse = dPsi_dTheta(lowerBoundTheta,vGn_alpha,theta_res,theta_sat,vGn_n,vGn_m) * bottomHydCond ! compute the capillary flux - cflux = -bottomDiffuse*(lowerBoundTheta - nodeVolFracLiq) / (nodeDepth*0.5_dp) + cflux = -bottomDiffuse*(lowerBoundTheta - nodeVolFracLiq) / (nodeDepth*0.5_rkind) case(mixdform) ! compute the hydraulic conductivity and diffusivity at the boundary bottomHydCond = hydCond_psi(lowerBoundHead,bottomSatHydCond,vGn_alpha,vGn_n,vGn_m) * iceImpedeFac bottomDiffuse = realMissing ! compute the capillary flux - cflux = -bottomHydCond*(lowerBoundHead - nodeMatricHead) / (nodeDepth*0.5_dp) + cflux = -bottomHydCond*(lowerBoundHead - nodeMatricHead) / (nodeDepth*0.5_rkind) case default; err=10; message=trim(message)//"unknown form of Richards' equation"; return end select ! (form of Richards' eqn) scalarDrainage = cflux + bottomHydCond @@ -1666,12 +1666,12 @@ subroutine qDrainFlux(& if(deriv_desired)then ! hydrology derivatives select case(ixRichards) ! (form of Richards' equation) - case(moisture); dq_dHydStateUnsat = bottomDiffuse/(nodeDepth/2._dp) - case(mixdform); dq_dHydStateUnsat = bottomHydCond/(nodeDepth/2._dp) + case(moisture); dq_dHydStateUnsat = bottomDiffuse/(nodeDepth/2._rkind) + case(mixdform); dq_dHydStateUnsat = bottomHydCond/(nodeDepth/2._rkind) case default; err=10; message=trim(message)//"unknown form of Richards' equation"; return end select ! energy derivatives - dq_dNrgStateUnsat = -(dHydCond_dTemp/2._dp)*(lowerBoundHead - nodeMatricHead)/(nodeDepth*0.5_dp) + dHydCond_dTemp/2._dp + dq_dNrgStateUnsat = -(dHydCond_dTemp/2._rkind)*(lowerBoundHead - nodeMatricHead)/(nodeDepth*0.5_rkind) + dHydCond_dTemp/2._rkind else ! (do not desire derivatives) dq_dHydStateUnsat = realMissing dq_dNrgStateUnsat = realMissing @@ -1733,10 +1733,10 @@ subroutine qDrainFlux(& ! * zero flux ! --------------------------------------------------------------------------------------------- case(zeroFlux) - scalarDrainage = 0._dp + scalarDrainage = 0._rkind if(deriv_desired)then - dq_dHydStateUnsat = 0._dp - dq_dNrgStateUnsat = 0._dp + dq_dHydStateUnsat = 0._rkind + dq_dNrgStateUnsat = 0._rkind else dq_dHydStateUnsat = realMissing dq_dNrgStateUnsat = realMissing diff --git a/build/source/engine/soil_utils.f90 b/build/source/engine/soil_utils.f90 index 747618ed4..4a854f6d6 100755 --- a/build/source/engine/soil_utils.f90 +++ b/build/source/engine/soil_utils.f90 @@ -52,9 +52,9 @@ module soil_utils_module public::gammp ! constant parameters -real(dp),parameter :: valueMissing=-9999._dp ! missing value parameter -real(dp),parameter :: verySmall=epsilon(1.0_dp) ! a very small number (used to avoid divide by zero) -real(dp),parameter :: dx=-1.e-12_dp ! finite difference increment +real(rkind),parameter :: valueMissing=-9999._rkind ! missing value parameter +real(rkind),parameter :: verySmall=epsilon(1.0_rkind) ! a very small number (used to avoid divide by zero) +real(rkind),parameter :: dx=-1.e-12_rkind ! finite difference increment contains @@ -66,14 +66,14 @@ subroutine iceImpede(volFracIce,f_impede, & ! input ! computes the ice impedence factor (separate function, as used multiple times) implicit none ! input variables - real(dp),intent(in) :: volFracIce ! volumetric fraction of ice (-) - real(dp),intent(in) :: f_impede ! ice impedence parameter (-) + real(rkind),intent(in) :: volFracIce ! volumetric fraction of ice (-) + real(rkind),intent(in) :: f_impede ! ice impedence parameter (-) ! output variables - real(dp) :: iceImpedeFactor ! ice impedence factor (-) - real(dp) :: dIceImpede_dLiq ! derivative in ice impedence factor w.r.t. volumetric liquid water content (-) + real(rkind) :: iceImpedeFactor ! ice impedence factor (-) + real(rkind) :: dIceImpede_dLiq ! derivative in ice impedence factor w.r.t. volumetric liquid water content (-) ! compute ice impedance factor as a function of volumetric ice content - iceImpedeFactor = 10._dp**(-f_impede*volFracIce) - dIceImpede_dLiq = 0._dp + iceImpedeFactor = 10._rkind**(-f_impede*volFracIce) + dIceImpede_dLiq = 0._rkind end subroutine iceImpede @@ -85,13 +85,13 @@ subroutine dIceImpede_dTemp(volFracIce,dTheta_dT,f_impede,dIceImpede_dT) ! computes the derivative in the ice impedance factor w.r.t. temperature implicit none ! input variables - real(dp),intent(in) :: volFracIce ! volumetric fraction of ice (-) - real(dp),intent(in) :: dTheta_dT ! derivative in volumetric liquid water content w.r.t temperature (K-1) - real(dp),intent(in) :: f_impede ! ice impedence parameter (-) + real(rkind),intent(in) :: volFracIce ! volumetric fraction of ice (-) + real(rkind),intent(in) :: dTheta_dT ! derivative in volumetric liquid water content w.r.t temperature (K-1) + real(rkind),intent(in) :: f_impede ! ice impedence parameter (-) ! output variables - real(dp) :: dIceImpede_dT ! derivative in the ice impedance factor w.r.t. temperature (K-1) + real(rkind) :: dIceImpede_dT ! derivative in the ice impedance factor w.r.t. temperature (K-1) ! -- - dIceImpede_dT = log(10._dp)*f_impede*(10._dp**(-f_impede*volFracIce))*dTheta_dT + dIceImpede_dT = log(10._rkind)*f_impede*(10._rkind**(-f_impede*volFracIce))*dTheta_dT end subroutine dIceImpede_dTemp @@ -114,30 +114,30 @@ subroutine liquidHead(& ! computes the liquid water matric potential (and the derivatives w.r.t. total matric potential and temperature) implicit none ! input - real(dp),intent(in) :: matricHeadTotal ! total water matric potential (m) - real(dp),intent(in) :: volFracLiq ! volumetric fraction of liquid water (-) - real(dp),intent(in) :: volFracIce ! volumetric fraction of ice (-) - real(dp),intent(in) :: vGn_alpha,vGn_n,theta_sat,theta_res,vGn_m ! soil parameters - real(dp),intent(in) ,optional :: dVolTot_dPsi0 ! derivative in the soil water characteristic (m-1) - real(dp),intent(in) ,optional :: dTheta_dT ! derivative in volumetric total water w.r.t. temperature (K-1) + real(rkind),intent(in) :: matricHeadTotal ! total water matric potential (m) + real(rkind),intent(in) :: volFracLiq ! volumetric fraction of liquid water (-) + real(rkind),intent(in) :: volFracIce ! volumetric fraction of ice (-) + real(rkind),intent(in) :: vGn_alpha,vGn_n,theta_sat,theta_res,vGn_m ! soil parameters + real(rkind),intent(in) ,optional :: dVolTot_dPsi0 ! derivative in the soil water characteristic (m-1) + real(rkind),intent(in) ,optional :: dTheta_dT ! derivative in volumetric total water w.r.t. temperature (K-1) ! output - real(dp),intent(out) :: matricHeadLiq ! liquid water matric potential (m) - real(dp),intent(out) ,optional :: dPsiLiq_dPsi0 ! derivative in the liquid water matric potential w.r.t. the total water matric potential (-) - real(dp),intent(out) ,optional :: dPsiLiq_dTemp ! derivative in the liquid water matric potential w.r.t. temperature (m K-1) + real(rkind),intent(out) :: matricHeadLiq ! liquid water matric potential (m) + real(rkind),intent(out) ,optional :: dPsiLiq_dPsi0 ! derivative in the liquid water matric potential w.r.t. the total water matric potential (-) + real(rkind),intent(out) ,optional :: dPsiLiq_dTemp ! derivative in the liquid water matric potential w.r.t. temperature (m K-1) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! local - real(dp) :: xNum,xDen ! temporary variables (numeratir, denominator) - real(dp) :: effSat ! effective saturation (-) - real(dp) :: dPsiLiq_dEffSat ! derivative in liquid water matric potential w.r.t. effective saturation (m) - real(dp) :: dEffSat_dTemp ! derivative in effective saturation w.r.t. temperature (K-1) + real(rkind) :: xNum,xDen ! temporary variables (numeratir, denominator) + real(rkind) :: effSat ! effective saturation (-) + real(rkind) :: dPsiLiq_dEffSat ! derivative in liquid water matric potential w.r.t. effective saturation (m) + real(rkind) :: dEffSat_dTemp ! derivative in effective saturation w.r.t. temperature (K-1) ! ------------------------------------------------------------------------------------------------------------------------------ ! initialize error control err=0; message='liquidHead/' ! ** partially frozen soil - if(volFracIce > verySmall .and. matricHeadTotal < 0._dp)then ! check that ice exists and that the soil is unsaturated + if(volFracIce > verySmall .and. matricHeadTotal < 0._rkind)then ! check that ice exists and that the soil is unsaturated ! ----- ! - compute liquid water matric potential... @@ -151,11 +151,11 @@ subroutine liquidHead(& effSat = xNum/xDen ! effective saturation ! - matric head associated with liquid water - matricHeadLiq = matricHead(effSat,vGn_alpha,0._dp,1._dp,vGn_n,vGn_m) ! argument is effective saturation, so theta_res=0 and theta_sat=1 + matricHeadLiq = matricHead(effSat,vGn_alpha,0._rkind,1._rkind,vGn_n,vGn_m) ! argument is effective saturation, so theta_res=0 and theta_sat=1 ! compute derivative in liquid water matric potential w.r.t. effective saturation (m) if(present(dPsiLiq_dPsi0).or.present(dPsiLiq_dTemp))then - dPsiLiq_dEffSat = dPsi_dTheta(effSat,vGn_alpha,0._dp,1._dp,vGn_n,vGn_m) + dPsiLiq_dEffSat = dPsi_dTheta(effSat,vGn_alpha,0._rkind,1._rkind,vGn_n,vGn_m) endif ! ----- @@ -172,7 +172,7 @@ subroutine liquidHead(& endif ! (compute derivative in the liquid water matric potential w.r.t. the total water matric potential) - dPsiLiq_dPsi0 = dVolTot_dPsi0*dPsiLiq_dEffSat*xNum/(xDen**2._dp) + dPsiLiq_dPsi0 = dVolTot_dPsi0*dPsiLiq_dEffSat*xNum/(xDen**2._rkind) endif ! if dPsiLiq_dTemp is desired @@ -190,7 +190,7 @@ subroutine liquidHead(& endif ! (compute the derivative in the liquid water matric potential w.r.t. temperature) - dEffSat_dTemp = -dTheta_dT*xNum/(xDen**2._dp) + dTheta_dT/xDen + dEffSat_dTemp = -dTheta_dT*xNum/(xDen**2._rkind) + dTheta_dT/xDen dPsiLiq_dTemp = dPsiLiq_dEffSat*dEffSat_dTemp endif ! if dPsiLiq_dTemp is desired @@ -198,8 +198,8 @@ subroutine liquidHead(& ! ** unfrozen soil else ! (no ice) matricHeadLiq = matricHeadTotal - if(present(dPsiLiq_dTemp)) dPsiLiq_dPsi0 = 1._dp ! derivative=1 because values are identical - if(present(dPsiLiq_dTemp)) dPsiLiq_dTemp = 0._dp ! derivative=0 because no impact of temperature for unfrozen conditions + if(present(dPsiLiq_dTemp)) dPsiLiq_dPsi0 = 1._rkind ! derivative=1 because values are identical + if(present(dPsiLiq_dTemp)) dPsiLiq_dTemp = 0._rkind ! derivative=0 because no impact of temperature for unfrozen conditions end if ! (if ice exists) end subroutine liquidHead @@ -212,20 +212,20 @@ function hydCondMP_liq(volFracLiq,theta_sat,theta_mp,mpExp,satHydCond_ma,satHydC ! theta_sat, theta_mp, mpExp, satHydCond_ma, and satHydCond_mi implicit none ! dummies - real(dp),intent(in) :: volFracLiq ! volumetric liquid water content (-) - real(dp),intent(in) :: theta_sat ! soil porosity (-) - real(dp),intent(in) :: theta_mp ! minimum volumetric liquid water content for macropore flow (-) - real(dp),intent(in) :: mpExp ! empirical exponent in macropore flow equation (-) - real(dp),intent(in) :: satHydCond_ma ! saturated hydraulic conductivity for macropores (m s-1) - real(dp),intent(in) :: satHydCond_mi ! saturated hydraulic conductivity for micropores (m s-1) - real(dp) :: hydCondMP_liq ! hydraulic conductivity (m s-1) + real(rkind),intent(in) :: volFracLiq ! volumetric liquid water content (-) + real(rkind),intent(in) :: theta_sat ! soil porosity (-) + real(rkind),intent(in) :: theta_mp ! minimum volumetric liquid water content for macropore flow (-) + real(rkind),intent(in) :: mpExp ! empirical exponent in macropore flow equation (-) + real(rkind),intent(in) :: satHydCond_ma ! saturated hydraulic conductivity for macropores (m s-1) + real(rkind),intent(in) :: satHydCond_mi ! saturated hydraulic conductivity for micropores (m s-1) + real(rkind) :: hydCondMP_liq ! hydraulic conductivity (m s-1) ! locals - real(dp) :: theta_e ! effective soil moisture + real(rkind) :: theta_e ! effective soil moisture if(volFracLiq > theta_mp)then theta_e = (volFracLiq - theta_mp) / (theta_sat - theta_mp) hydCondMP_liq = (satHydCond_ma - satHydCond_mi) * (theta_e**mpExp) else - hydCondMP_liq = 0._dp + hydCondMP_liq = 0._rkind end if !write(*,'(a,4(f9.3,1x),2(e20.10))') 'in soil_utils: theta_mp, theta_sat, volFracLiq, hydCondMP_liq, satHydCond_ma, satHydCond_mi = ', & ! theta_mp, theta_sat, volFracLiq, hydCondMP_liq, satHydCond_ma, satHydCond_mi @@ -239,16 +239,16 @@ function hydCond_psi(psi,k_sat,alpha,n,m) ! computes hydraulic conductivity given psi and soil hydraulic parameters k_sat, alpha, n, and m implicit none ! dummies - real(dp),intent(in) :: psi ! soil water suction (m) - real(dp),intent(in) :: k_sat ! saturated hydraulic conductivity (m s-1) - real(dp),intent(in) :: alpha ! scaling parameter (m-1) - real(dp),intent(in) :: n ! vGn "n" parameter (-) - real(dp),intent(in) :: m ! vGn "m" parameter (-) - real(dp) :: hydCond_psi ! hydraulic conductivity (m s-1) - if(psi<0._dp)then + real(rkind),intent(in) :: psi ! soil water suction (m) + real(rkind),intent(in) :: k_sat ! saturated hydraulic conductivity (m s-1) + real(rkind),intent(in) :: alpha ! scaling parameter (m-1) + real(rkind),intent(in) :: n ! vGn "n" parameter (-) + real(rkind),intent(in) :: m ! vGn "m" parameter (-) + real(rkind) :: hydCond_psi ! hydraulic conductivity (m s-1) + if(psi<0._rkind)then hydCond_psi = k_sat * & - ( ( (1._dp - (psi*alpha)**(n-1._dp) * (1._dp + (psi*alpha)**n)**(-m))**2._dp ) & - / ( (1._dp + (psi*alpha)**n)**(m/2._dp) ) ) + ( ( (1._rkind - (psi*alpha)**(n-1._rkind) * (1._rkind + (psi*alpha)**n)**(-m))**2._rkind ) & + / ( (1._rkind + (psi*alpha)**n)**(m/2._rkind) ) ) else hydCond_psi = k_sat end if @@ -262,17 +262,17 @@ function hydCond_liq(volFracLiq,k_sat,theta_res,theta_sat,m) ! computes hydraulic conductivity given volFracLiq and soil hydraulic parameters k_sat, theta_sat, theta_res, and m implicit none ! dummies - real(dp),intent(in) :: volFracLiq ! volumetric liquid water content (-) - real(dp),intent(in) :: k_sat ! saturated hydraulic conductivity (m s-1) - real(dp),intent(in) :: theta_res ! residual volumetric liquid water content (-) - real(dp),intent(in) :: theta_sat ! soil porosity (-) - real(dp),intent(in) :: m ! vGn "m" parameter (-) - real(dp) :: hydCond_liq ! hydraulic conductivity (m s-1) + real(rkind),intent(in) :: volFracLiq ! volumetric liquid water content (-) + real(rkind),intent(in) :: k_sat ! saturated hydraulic conductivity (m s-1) + real(rkind),intent(in) :: theta_res ! residual volumetric liquid water content (-) + real(rkind),intent(in) :: theta_sat ! soil porosity (-) + real(rkind),intent(in) :: m ! vGn "m" parameter (-) + real(rkind) :: hydCond_liq ! hydraulic conductivity (m s-1) ! locals - real(dp) :: theta_e ! effective soil moisture + real(rkind) :: theta_e ! effective soil moisture if(volFracLiq < theta_sat)then theta_e = (volFracLiq - theta_res) / (theta_sat - theta_res) - hydCond_liq = k_sat*theta_e**(1._dp/2._dp) * (1._dp - (1._dp - theta_e**(1._dp/m) )**m)**2._dp + hydCond_liq = k_sat*theta_e**(1._rkind/2._rkind) * (1._rkind - (1._rkind - theta_e**(1._rkind/m) )**m)**2._rkind else hydCond_liq = k_sat end if @@ -285,15 +285,15 @@ end function hydCond_liq function volFracLiq(psi,alpha,theta_res,theta_sat,n,m) ! computes the volumetric liquid water content given psi and soil hydraulic parameters theta_res, theta_sat, alpha, n, and m implicit none - real(dp),intent(in) :: psi ! soil water suction (m) - real(dp),intent(in) :: alpha ! scaling parameter (m-1) - real(dp),intent(in) :: theta_res ! residual volumetric water content (-) - real(dp),intent(in) :: theta_sat ! porosity (-) - real(dp),intent(in) :: n ! vGn "n" parameter (-) - real(dp),intent(in) :: m ! vGn "m" parameter (-) - real(dp) :: volFracLiq ! volumetric liquid water content (-) - if(psi<0._dp)then - volFracLiq = theta_res + (theta_sat - theta_res)*(1._dp + (alpha*psi)**n)**(-m) + real(rkind),intent(in) :: psi ! soil water suction (m) + real(rkind),intent(in) :: alpha ! scaling parameter (m-1) + real(rkind),intent(in) :: theta_res ! residual volumetric water content (-) + real(rkind),intent(in) :: theta_sat ! porosity (-) + real(rkind),intent(in) :: n ! vGn "n" parameter (-) + real(rkind),intent(in) :: m ! vGn "m" parameter (-) + real(rkind) :: volFracLiq ! volumetric liquid water content (-) + if(psi<0._rkind)then + volFracLiq = theta_res + (theta_sat - theta_res)*(1._rkind + (alpha*psi)**n)**(-m) else volFracLiq = theta_sat end if @@ -307,23 +307,23 @@ function matricHead(theta,alpha,theta_res,theta_sat,n,m) ! computes the volumetric liquid water content given psi and soil hydraulic parameters theta_res, theta_sat, alpha, n, and m implicit none ! dummy variables - real(dp),intent(in) :: theta ! volumetric liquid water content (-) - real(dp),intent(in) :: alpha ! scaling parameter (m-1) - real(dp),intent(in) :: theta_res ! residual volumetric water content (-) - real(dp),intent(in) :: theta_sat ! porosity (-) - real(dp),intent(in) :: n ! vGn "n" parameter (-) - real(dp),intent(in) :: m ! vGn "m" parameter (-) - real(dp) :: matricHead ! matric head (m) + real(rkind),intent(in) :: theta ! volumetric liquid water content (-) + real(rkind),intent(in) :: alpha ! scaling parameter (m-1) + real(rkind),intent(in) :: theta_res ! residual volumetric water content (-) + real(rkind),intent(in) :: theta_sat ! porosity (-) + real(rkind),intent(in) :: n ! vGn "n" parameter (-) + real(rkind),intent(in) :: m ! vGn "m" parameter (-) + real(rkind) :: matricHead ! matric head (m) ! local variables - real(dp) :: effSat ! effective saturation (-) - real(dp),parameter :: verySmall=epsilon(1._dp) ! a very small number (avoid effective saturation of zero) + real(rkind) :: effSat ! effective saturation (-) + real(rkind),parameter :: verySmall=epsilon(1._rkind) ! a very small number (avoid effective saturation of zero) ! compute effective saturation effSat = max(verySmall, (theta - theta_res) / (theta_sat - theta_res)) ! compute matric head - if (effSat < 1._dp .and. effSat > 0._dp)then - matricHead = (1._dp/alpha)*( effSat**(-1._dp/m) - 1._dp)**(1._dp/n) + if (effSat < 1._rkind .and. effSat > 0._rkind)then + matricHead = (1._rkind/alpha)*( effSat**(-1._rkind/m) - 1._rkind)**(1._rkind/n) else - matricHead = 0._dp + matricHead = 0._rkind end if end function matricHead @@ -333,16 +333,16 @@ end function matricHead ! ****************************************************************************************************************************** function dTheta_dPsi(psi,alpha,theta_res,theta_sat,n,m) implicit none - real(dp),intent(in) :: psi ! soil water suction (m) - real(dp),intent(in) :: alpha ! scaling parameter (m-1) - real(dp),intent(in) :: theta_res ! residual volumetric water content (-) - real(dp),intent(in) :: theta_sat ! porosity (-) - real(dp),intent(in) :: n ! vGn "n" parameter (-) - real(dp),intent(in) :: m ! vGn "m" parameter (-) - real(dp) :: dTheta_dPsi ! derivative of the soil water characteristic (m-1) - if(psi<=0._dp)then + real(rkind),intent(in) :: psi ! soil water suction (m) + real(rkind),intent(in) :: alpha ! scaling parameter (m-1) + real(rkind),intent(in) :: theta_res ! residual volumetric water content (-) + real(rkind),intent(in) :: theta_sat ! porosity (-) + real(rkind),intent(in) :: n ! vGn "n" parameter (-) + real(rkind),intent(in) :: m ! vGn "m" parameter (-) + real(rkind) :: dTheta_dPsi ! derivative of the soil water characteristic (m-1) + if(psi<=0._rkind)then dTheta_dPsi = (theta_sat-theta_res) * & - (-m*(1._dp + (psi*alpha)**n)**(-m-1._dp)) * n*(psi*alpha)**(n-1._dp) * alpha + (-m*(1._rkind + (psi*alpha)**n)**(-m-1._rkind)) * n*(psi*alpha)**(n-1._rkind) * alpha if(abs(dTheta_dPsi) < epsilon(psi)) dTheta_dPsi = epsilon(psi) else dTheta_dPsi = epsilon(psi) @@ -356,31 +356,31 @@ end function dTheta_dPsi function dPsi_dTheta(volFracLiq,alpha,theta_res,theta_sat,n,m) implicit none ! dummies - real(dp),intent(in) :: volFracLiq ! volumetric liquid water content (-) - real(dp),intent(in) :: alpha ! scaling parameter (m-1) - real(dp),intent(in) :: theta_res ! residual volumetric water content (-) - real(dp),intent(in) :: theta_sat ! porosity (-) - real(dp),intent(in) :: n ! vGn "n" parameter (-) - real(dp),intent(in) :: m ! vGn "m" parameter (-) - real(dp) :: dPsi_dTheta ! derivative of the soil water characteristic (m) + real(rkind),intent(in) :: volFracLiq ! volumetric liquid water content (-) + real(rkind),intent(in) :: alpha ! scaling parameter (m-1) + real(rkind),intent(in) :: theta_res ! residual volumetric water content (-) + real(rkind),intent(in) :: theta_sat ! porosity (-) + real(rkind),intent(in) :: n ! vGn "n" parameter (-) + real(rkind),intent(in) :: m ! vGn "m" parameter (-) + real(rkind) :: dPsi_dTheta ! derivative of the soil water characteristic (m) ! locals - real(dp) :: y1,d1 ! 1st function and derivative - real(dp) :: y2,d2 ! 2nd function and derivative - real(dp) :: theta_e ! effective soil moisture + real(rkind) :: y1,d1 ! 1st function and derivative + real(rkind) :: y2,d2 ! 2nd function and derivative + real(rkind) :: theta_e ! effective soil moisture ! check if less than saturation if(volFracLiq < theta_sat)then ! compute effective water content theta_e = max(0.001,(volFracLiq - theta_res) / (theta_sat - theta_res)) ! compute the 1st function and derivative - y1 = theta_e**(-1._dp/m) - 1._dp - d1 = (-1._dp/m)*theta_e**(-1._dp/m - 1._dp) / (theta_sat - theta_res) + y1 = theta_e**(-1._rkind/m) - 1._rkind + d1 = (-1._rkind/m)*theta_e**(-1._rkind/m - 1._rkind) / (theta_sat - theta_res) ! compute the 2nd function and derivative - y2 = y1**(1._dp/n) - d2 = (1._dp/n)*y1**(1._dp/n - 1._dp) + y2 = y1**(1._rkind/n) + d2 = (1._rkind/n)*y1**(1._rkind/n - 1._rkind) ! compute the final function value dPsi_dTheta = d1*d2/alpha else - dPsi_dTheta = 0._dp + dPsi_dTheta = 0._rkind end if end function dPsi_dTheta @@ -391,21 +391,21 @@ end function dPsi_dTheta function dPsi_dTheta2(volFracLiq,alpha,theta_res,theta_sat,n,m,lTangent) implicit none ! dummies - real(dp),intent(in) :: volFracLiq ! volumetric liquid water content (-) - real(dp),intent(in) :: alpha ! scaling parameter (m-1) - real(dp),intent(in) :: theta_res ! residual volumetric water content (-) - real(dp),intent(in) :: theta_sat ! porosity (-) - real(dp),intent(in) :: n ! vGn "n" parameter (-) - real(dp),intent(in) :: m ! vGn "m" parameter (-) + real(rkind),intent(in) :: volFracLiq ! volumetric liquid water content (-) + real(rkind),intent(in) :: alpha ! scaling parameter (m-1) + real(rkind),intent(in) :: theta_res ! residual volumetric water content (-) + real(rkind),intent(in) :: theta_sat ! porosity (-) + real(rkind),intent(in) :: n ! vGn "n" parameter (-) + real(rkind),intent(in) :: m ! vGn "m" parameter (-) logical(lgt),intent(in) :: lTangent ! method used to compute derivative (.true. = analytical) - real(dp) :: dPsi_dTheta2 ! derivative of the soil water characteristic (m) + real(rkind) :: dPsi_dTheta2 ! derivative of the soil water characteristic (m) ! locals for analytical derivatives - real(dp) :: xx ! temporary variable - real(dp) :: y1,d1 ! 1st function and derivative - real(dp) :: y2,d2 ! 2nd function and derivative - real(dp) :: theta_e ! effective soil moisture + real(rkind) :: xx ! temporary variable + real(rkind) :: y1,d1 ! 1st function and derivative + real(rkind) :: y2,d2 ! 2nd function and derivative + real(rkind) :: theta_e ! effective soil moisture ! locals for numerical derivative - real(dp) :: func0,func1 ! function evaluations + real(rkind) :: func0,func1 ! function evaluations ! check if less than saturation if(volFracLiq < theta_sat)then ! ***** compute analytical derivatives @@ -413,12 +413,12 @@ function dPsi_dTheta2(volFracLiq,alpha,theta_res,theta_sat,n,m,lTangent) ! compute the effective saturation theta_e = (volFracLiq - theta_res) / (theta_sat - theta_res) ! get the first function and derivative - y1 = (-1._dp/m)*theta_e**(-1._dp/m - 1._dp) / (theta_sat - theta_res) - d1 = ( (m + 1._dp) / (m**2._dp * (theta_sat - theta_res)**2._dp) ) * theta_e**(-1._dp/m - 2._dp) + y1 = (-1._rkind/m)*theta_e**(-1._rkind/m - 1._rkind) / (theta_sat - theta_res) + d1 = ( (m + 1._rkind) / (m**2._rkind * (theta_sat - theta_res)**2._rkind) ) * theta_e**(-1._rkind/m - 2._rkind) ! get the second function and derivative - xx = theta_e**(-1._dp/m) - 1._dp - y2 = (1._dp/n)*xx**(1._dp/n - 1._dp) - d2 = ( -(1._dp - n)/((theta_sat - theta_res)*m*n**2._dp) ) * xx**(1._dp/n - 2._dp) * theta_e**(-1._dp/m - 1._dp) + xx = theta_e**(-1._rkind/m) - 1._rkind + y2 = (1._rkind/n)*xx**(1._rkind/n - 1._rkind) + d2 = ( -(1._rkind - n)/((theta_sat - theta_res)*m*n**2._rkind) ) * xx**(1._rkind/n - 2._rkind) * theta_e**(-1._rkind/m - 1._rkind) ! return the derivative dPsi_dTheta2 = (d1*y2 + y1*d2)/alpha ! ***** compute numerical derivatives @@ -429,7 +429,7 @@ function dPsi_dTheta2(volFracLiq,alpha,theta_res,theta_sat,n,m,lTangent) end if ! (case where volumetric liquid water content exceeds porosity) else - dPsi_dTheta2 = 0._dp + dPsi_dTheta2 = 0._rkind end if end function dPsi_dTheta2 @@ -442,41 +442,41 @@ function dHydCond_dPsi(psi,k_sat,alpha,n,m,lTangent) ! given psi and soil hydraulic parameters k_sat, alpha, n, and m implicit none ! dummies - real(dp),intent(in) :: psi ! soil water suction (m) - real(dp),intent(in) :: k_sat ! saturated hydraulic conductivity (m s-1) - real(dp),intent(in) :: alpha ! scaling parameter (m-1) - real(dp),intent(in) :: n ! vGn "n" parameter (-) - real(dp),intent(in) :: m ! vGn "m" parameter (-) + real(rkind),intent(in) :: psi ! soil water suction (m) + real(rkind),intent(in) :: k_sat ! saturated hydraulic conductivity (m s-1) + real(rkind),intent(in) :: alpha ! scaling parameter (m-1) + real(rkind),intent(in) :: n ! vGn "n" parameter (-) + real(rkind),intent(in) :: m ! vGn "m" parameter (-) logical(lgt),intent(in) :: lTangent ! method used to compute derivative (.true. = analytical) - real(dp) :: dHydCond_dPsi ! derivative in hydraulic conductivity w.r.t. matric head (s-1) + real(rkind) :: dHydCond_dPsi ! derivative in hydraulic conductivity w.r.t. matric head (s-1) ! locals for analytical derivatives - real(dp) :: f_x1 ! f(x) for part of the numerator - real(dp) :: f_x2 ! f(x) for part of the numerator - real(dp) :: f_nm ! f(x) for the numerator - real(dp) :: f_dm ! f(x) for the denominator - real(dp) :: d_x1 ! df(x)/dpsi for part of the numerator - real(dp) :: d_x2 ! df(x)/dpsi for part of the numerator - real(dp) :: d_nm ! df(x)/dpsi for the numerator - real(dp) :: d_dm ! df(x)/dpsi for the denominator + real(rkind) :: f_x1 ! f(x) for part of the numerator + real(rkind) :: f_x2 ! f(x) for part of the numerator + real(rkind) :: f_nm ! f(x) for the numerator + real(rkind) :: f_dm ! f(x) for the denominator + real(rkind) :: d_x1 ! df(x)/dpsi for part of the numerator + real(rkind) :: d_x2 ! df(x)/dpsi for part of the numerator + real(rkind) :: d_nm ! df(x)/dpsi for the numerator + real(rkind) :: d_dm ! df(x)/dpsi for the denominator ! locals for numerical derivatives - real(dp) :: hydCond0 ! hydraulic condictivity value for base case - real(dp) :: hydCond1 ! hydraulic condictivity value for perturbed case + real(rkind) :: hydCond0 ! hydraulic condictivity value for base case + real(rkind) :: hydCond1 ! hydraulic condictivity value for perturbed case ! derivative is zero if saturated - if(psi<0._dp)then + if(psi<0._rkind)then ! ***** compute analytical derivatives if(lTangent)then ! compute the derivative for the numerator - f_x1 = (psi*alpha)**(n - 1._dp) - f_x2 = (1._dp + (psi*alpha)**n)**(-m) - d_x1 = alpha * (n - 1._dp)*(psi*alpha)**(n - 2._dp) - d_x2 = alpha * n*(psi*alpha)**(n - 1._dp) * (-m)*(1._dp + (psi*alpha)**n)**(-m - 1._dp) - f_nm = (1._dp - f_x1*f_x2)**2._dp - d_nm = (-d_x1*f_x2 - f_x1*d_x2) * 2._dp*(1._dp - f_x1*f_x2) + f_x1 = (psi*alpha)**(n - 1._rkind) + f_x2 = (1._rkind + (psi*alpha)**n)**(-m) + d_x1 = alpha * (n - 1._rkind)*(psi*alpha)**(n - 2._rkind) + d_x2 = alpha * n*(psi*alpha)**(n - 1._rkind) * (-m)*(1._rkind + (psi*alpha)**n)**(-m - 1._rkind) + f_nm = (1._rkind - f_x1*f_x2)**2._rkind + d_nm = (-d_x1*f_x2 - f_x1*d_x2) * 2._rkind*(1._rkind - f_x1*f_x2) ! compute the derivative for the denominator - f_dm = (1._dp + (psi*alpha)**n)**(m/2._dp) - d_dm = alpha * n*(psi*alpha)**(n - 1._dp) * (m/2._dp)*(1._dp + (psi*alpha)**n)**(m/2._dp - 1._dp) + f_dm = (1._rkind + (psi*alpha)**n)**(m/2._rkind) + d_dm = alpha * n*(psi*alpha)**(n - 1._rkind) * (m/2._rkind)*(1._rkind + (psi*alpha)**n)**(m/2._rkind - 1._rkind) ! and combine - dHydCond_dPsi = k_sat*(d_nm*f_dm - d_dm*f_nm) / (f_dm**2._dp) + dHydCond_dPsi = k_sat*(d_nm*f_dm - d_dm*f_nm) / (f_dm**2._rkind) else ! ***** compute numerical derivatives hydcond0 = hydCond_psi(psi, k_sat,alpha,n,m) @@ -484,7 +484,7 @@ function dHydCond_dPsi(psi,k_sat,alpha,n,m,lTangent) dHydCond_dPsi = (hydcond1 - hydcond0)/dx end if else - dHydCond_dPsi = 0._dp + dHydCond_dPsi = 0._rkind end if end function dHydCond_dPsi @@ -498,24 +498,24 @@ end function dHydCond_dPsi function dHydCond_dLiq(volFracLiq,k_sat,theta_res,theta_sat,m,lTangent) implicit none ! dummies - real(dp),intent(in) :: volFracLiq ! volumetric fraction of liquid water (-) - real(dp),intent(in) :: k_sat ! saturated hydraulic conductivity (m s-1) - real(dp),intent(in) :: theta_res ! soil residual volumetric water content (-) - real(dp),intent(in) :: theta_sat ! soil porosity (-) - real(dp),intent(in) :: m ! vGn "m" parameter (-) + real(rkind),intent(in) :: volFracLiq ! volumetric fraction of liquid water (-) + real(rkind),intent(in) :: k_sat ! saturated hydraulic conductivity (m s-1) + real(rkind),intent(in) :: theta_res ! soil residual volumetric water content (-) + real(rkind),intent(in) :: theta_sat ! soil porosity (-) + real(rkind),intent(in) :: m ! vGn "m" parameter (-) logical(lgt),intent(in) :: lTangent ! method used to compute derivative (.true. = analytical) - real(dp) :: dHydCond_dLiq ! derivative in hydraulic conductivity w.r.t. matric head (s-1) + real(rkind) :: dHydCond_dLiq ! derivative in hydraulic conductivity w.r.t. matric head (s-1) ! locals for analytical derivatives - real(dp) :: theta_e ! effective soil moisture - real(dp) :: f1 ! f(x) for the first function - real(dp) :: d1 ! df(x)/dLiq for the first function - real(dp) :: x1,x2 ! f(x) for different parts of the second function - real(dp) :: p1,p2,p3 ! df(x)/dLiq for different parts of the second function - real(dp) :: f2 ! f(x) for the second function - real(dp) :: d2 ! df(x)/dLiq for the second function + real(rkind) :: theta_e ! effective soil moisture + real(rkind) :: f1 ! f(x) for the first function + real(rkind) :: d1 ! df(x)/dLiq for the first function + real(rkind) :: x1,x2 ! f(x) for different parts of the second function + real(rkind) :: p1,p2,p3 ! df(x)/dLiq for different parts of the second function + real(rkind) :: f2 ! f(x) for the second function + real(rkind) :: d2 ! df(x)/dLiq for the second function ! locals for numerical derivatives - real(dp) :: hydCond0 ! hydraulic condictivity value for base case - real(dp) :: hydCond1 ! hydraulic condictivity value for perturbed case + real(rkind) :: hydCond0 ! hydraulic condictivity value for base case + real(rkind) :: hydCond1 ! hydraulic condictivity value for perturbed case ! derivative is zero if super-saturated if(volFracLiq < theta_sat)then ! ***** compute analytical derivatives @@ -523,18 +523,18 @@ function dHydCond_dLiq(volFracLiq,k_sat,theta_res,theta_sat,m,lTangent) ! compute the effective saturation theta_e = (volFracLiq - theta_res) / (theta_sat - theta_res) ! compute the function and derivative of the first fuction - f1 = k_sat*theta_e**0.5_dp - d1 = k_sat*0.5_dp*theta_e**(-0.5_dp) / (theta_sat - theta_res) + f1 = k_sat*theta_e**0.5_rkind + d1 = k_sat*0.5_rkind*theta_e**(-0.5_rkind) / (theta_sat - theta_res) ! compute the function and derivative of the second function ! (first part) - x1 = 1._dp - theta_e**(1._dp/m) - p1 = (-1._dp/m)*theta_e**(1._dp/m - 1._dp) / (theta_sat - theta_res) ! differentiate (1.d - theta_e**(1.d/m) + x1 = 1._rkind - theta_e**(1._rkind/m) + p1 = (-1._rkind/m)*theta_e**(1._rkind/m - 1._rkind) / (theta_sat - theta_res) ! differentiate (1.d - theta_e**(1.d/m) ! (second part) x2 = x1**m - p2 = m*x1**(m - 1._dp) + p2 = m*x1**(m - 1._rkind) ! (final) - f2 = (1._dp - x2)**2._dp - p3 = -2._dp*(1._dp - x2) + f2 = (1._rkind - x2)**2._rkind + p3 = -2._rkind*(1._rkind - x2) ! (combine) d2 = p1*p2*p3 ! pull it all together @@ -546,7 +546,7 @@ function dHydCond_dLiq(volFracLiq,k_sat,theta_res,theta_sat,m,lTangent) dHydCond_dLiq = (hydcond1 - hydcond0)/dx end if else - dHydCond_dLiq = 0._dp + dHydCond_dLiq = 0._rkind end if end function dHydCond_dLiq @@ -556,9 +556,9 @@ end function dHydCond_dLiq ! ****************************************************************************************************************************** function RH_soilair(matpot,Tk) implicit none - real(dp),intent(in) :: matpot ! soil water suction -- matric potential (m) - real(dp),intent(in) :: Tk ! temperature (K) - real(dp) :: RH_soilair ! relative humidity of air in soil pore space + real(rkind),intent(in) :: matpot ! soil water suction -- matric potential (m) + real(rkind),intent(in) :: Tk ! temperature (K) + real(rkind) :: RH_soilair ! relative humidity of air in soil pore space ! compute relative humidity (UNITS NOTE: Pa = kg m-1 s-2, so R_wv units = m2 s-2 K-1) RH_soilair = exp( (gravity*matpot) / (R_wv*Tk) ) end function RH_soilair @@ -569,9 +569,9 @@ end function RH_soilair ! ****************************************************************************************************************************** function crit_soilT(psi) implicit none - real(dp),intent(in) :: psi ! matric head (m) - real(dp) :: crit_soilT ! critical soil temperature (K) - crit_soilT = Tfreeze + min(psi,0._dp)*gravity*Tfreeze/LH_fus + real(rkind),intent(in) :: psi ! matric head (m) + real(rkind) :: crit_soilT ! critical soil temperature (K) + crit_soilT = Tfreeze + min(psi,0._rkind)*gravity*Tfreeze/LH_fus end function crit_soilT @@ -580,22 +580,22 @@ end function crit_soilT ! ****************************************************************************************************************************** function dTheta_dTk(Tk,theta_res,theta_sat,alpha,n,m) implicit none - real(dp),intent(in) :: Tk ! temperature (K) - real(dp),intent(in) :: theta_res ! residual liquid water content (-) - real(dp),intent(in) :: theta_sat ! porosity (-) - real(dp),intent(in) :: alpha ! vGn scaling parameter (m-1) - real(dp),intent(in) :: n ! vGn "n" parameter (-) - real(dp),intent(in) :: m ! vGn "m" parameter (-) - real(dp) :: dTheta_dTk ! derivative of the freezing curve w.r.t. temperature (K-1) + real(rkind),intent(in) :: Tk ! temperature (K) + real(rkind),intent(in) :: theta_res ! residual liquid water content (-) + real(rkind),intent(in) :: theta_sat ! porosity (-) + real(rkind),intent(in) :: alpha ! vGn scaling parameter (m-1) + real(rkind),intent(in) :: n ! vGn "n" parameter (-) + real(rkind),intent(in) :: m ! vGn "m" parameter (-) + real(rkind) :: dTheta_dTk ! derivative of the freezing curve w.r.t. temperature (K-1) ! local variables - real(dp) :: kappa ! constant (m K-1) - real(dp) :: xtemp ! alpha*kappa*(Tk-Tfreeze) -- dimensionless variable (used more than once) + real(rkind) :: kappa ! constant (m K-1) + real(rkind) :: xtemp ! alpha*kappa*(Tk-Tfreeze) -- dimensionless variable (used more than once) ! compute kappa (m K-1) kappa = LH_fus/(gravity*Tfreeze) ! NOTE: J = kg m2 s-2 ! define a tempory variable that is used more than once (-) xtemp = alpha*kappa*(Tk-Tfreeze) ! differentiate the freezing curve w.r.t. temperature -- making use of the chain rule - dTheta_dTk = (alpha*kappa) * n*xtemp**(n - 1._dp) * (-m)*(1._dp + xtemp**n)**(-m - 1._dp) * (theta_sat - theta_res) + dTheta_dTk = (alpha*kappa) * n*xtemp**(n - 1._rkind) * (-m)*(1._rkind + xtemp**n)**(-m - 1._rkind) * (theta_sat - theta_res) end function dTheta_dTk @@ -604,12 +604,12 @@ end function dTheta_dTk ! ****************************************************************************************************************************** FUNCTION gammp(a,x) IMPLICIT NONE - REAL(DP), INTENT(IN) :: a,x - REAL(DP) :: gammp - if (x ITMAX) stop 'a too large, ITMAX too small in gcf' if (present(gln)) then @@ -661,22 +661,22 @@ END FUNCTION gcf ! ****************************************************************************************************************************** FUNCTION gser(a,x,gln) IMPLICIT NONE - REAL(DP), INTENT(IN) :: a,x - REAL(DP), OPTIONAL, INTENT(OUT) :: gln - REAL(DP) :: gser + real(rkind), INTENT(IN) :: a,x + real(rkind), OPTIONAL, INTENT(OUT) :: gln + real(rkind) :: gser INTEGER(I4B), PARAMETER :: ITMAX=100 - REAL(DP), PARAMETER :: EPS=epsilon(x) + real(rkind), PARAMETER :: EPS=epsilon(x) INTEGER(I4B) :: n - REAL(DP) :: ap,del,summ + real(rkind) :: ap,del,summ if (x == 0.0) then gser=0.0 RETURN end if ap=a - summ=1.0_dp/a + summ=1.0_rkind/a del=summ do n=1,ITMAX - ap=ap+1.0_dp + ap=ap+1.0_rkind del=del*x/ap summ=summ+del if (abs(del) < abs(summ)*EPS) exit @@ -697,20 +697,20 @@ END FUNCTION gser FUNCTION gammln(xx) USE nr_utility_module,only:arth ! use to build vectors with regular increments IMPLICIT NONE - REAL(DP), INTENT(IN) :: xx - REAL(DP) :: gammln - REAL(DP) :: tmp,x - REAL(DP) :: stp = 2.5066282746310005_dp - REAL(DP), DIMENSION(6) :: coef = (/76.18009172947146_dp,& - -86.50532032941677_dp,24.01409824083091_dp,& - -1.231739572450155_dp,0.1208650973866179e-2_dp,& - -0.5395239384953e-5_dp/) - if(xx <= 0._dp) stop 'xx > 0 in gammln' + real(rkind), INTENT(IN) :: xx + real(rkind) :: gammln + real(rkind) :: tmp,x + real(rkind) :: stp = 2.5066282746310005_rkind + real(rkind), DIMENSION(6) :: coef = (/76.18009172947146_rkind,& + -86.50532032941677_rkind,24.01409824083091_rkind,& + -1.231739572450155_rkind,0.1208650973866179e-2_rkind,& + -0.5395239384953e-5_rkind/) + if(xx <= 0._rkind) stop 'xx > 0 in gammln' x=xx - tmp=x+5.5_dp - tmp=(x+0.5_dp)*log(tmp)-tmp - gammln=tmp+log(stp*(1.000000000190015_dp+& - sum(coef(:)/arth(x+1.0_dp,1.0_dp,size(coef))))/x) + tmp=x+5.5_rkind + tmp=(x+0.5_rkind)*log(tmp)-tmp + gammln=tmp+log(stp*(1.000000000190015_rkind+& + sum(coef(:)/arth(x+1.0_rkind,1.0_rkind,size(coef))))/x) END FUNCTION gammln diff --git a/build/source/engine/spline_int.f90 b/build/source/engine/spline_int.f90 index 08be079a2..28efd3bf2 100755 --- a/build/source/engine/spline_int.f90 +++ b/build/source/engine/spline_int.f90 @@ -13,15 +13,15 @@ SUBROUTINE spline(x,y,yp1,ypn,y2,err,message) ! computes 2nd derivatives of the interpolating function at tabulated points IMPLICIT NONE ! dummy variables - REAL(DP), DIMENSION(:), INTENT(IN) :: x,y - REAL(DP), INTENT(IN) :: yp1,ypn - REAL(DP), DIMENSION(:), INTENT(OUT) :: y2 + real(rkind), DIMENSION(:), INTENT(IN) :: x,y + real(rkind), INTENT(IN) :: yp1,ypn + real(rkind), DIMENSION(:), INTENT(OUT) :: y2 integer(i4b),intent(out) :: err character(*),intent(out) :: message ! local variables character(len=128) :: cmessage INTEGER(I4B) :: n - REAL(DP), DIMENSION(size(x)) :: a,b,c,r + real(rkind), DIMENSION(size(x)) :: a,b,c,r ! initialize error control err=0; message="f-spline/" ! check that the size of the vectors match @@ -32,24 +32,24 @@ SUBROUTINE spline(x,y,yp1,ypn,y2,err,message) end if ! start procedure c(1:n-1)=x(2:n)-x(1:n-1) - r(1:n-1)=6.0_dp*((y(2:n)-y(1:n-1))/c(1:n-1)) + r(1:n-1)=6.0_rkind*((y(2:n)-y(1:n-1))/c(1:n-1)) r(2:n-1)=r(2:n-1)-r(1:n-2) a(2:n-1)=c(1:n-2) - b(2:n-1)=2.0_dp*(c(2:n-1)+a(2:n-1)) + b(2:n-1)=2.0_rkind*(c(2:n-1)+a(2:n-1)) b(1)=1.0 b(n)=1.0 - if (yp1 > 0.99e30_dp) then + if (yp1 > 0.99e30_rkind) then r(1)=0.0 c(1)=0.0 else - r(1)=(3.0_dp/(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-yp1) + r(1)=(3.0_rkind/(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-yp1) c(1)=0.5 end if - if (ypn > 0.99e30_dp) then + if (ypn > 0.99e30_rkind) then r(n)=0.0 a(n)=0.0 else - r(n)=(-3.0_dp/(x(n)-x(n-1)))*((y(n)-y(n-1))/(x(n)-x(n-1))-ypn) + r(n)=(-3.0_rkind/(x(n)-x(n-1)))*((y(n)-y(n-1))/(x(n)-x(n-1))-ypn) a(n)=0.5 end if call tridag(a(2:n),b(1:n),c(1:n-1),r(1:n),y2(1:n),err,cmessage) @@ -62,14 +62,14 @@ END SUBROUTINE spline SUBROUTINE splint(xa,ya,y2a,x,y,err,message) IMPLICIT NONE ! declare dummy variables - REAL(DP), DIMENSION(:), INTENT(IN) :: xa,ya,y2a - REAL(DP), INTENT(IN) :: x - REAL(DP), INTENT(OUT) :: y + real(rkind), DIMENSION(:), INTENT(IN) :: xa,ya,y2a + real(rkind), INTENT(IN) :: x + real(rkind), INTENT(OUT) :: y integer(i4b),intent(out) :: err character(*),intent(out) :: message ! declare local variables INTEGER(I4B) :: khi,klo,n - REAL(DP) :: a,b,h + real(rkind) :: a,b,h ! check size of input vectors if (size(xa)==size(ya) .and. size(ya)==size(y2a)) then n=size(xa) @@ -80,10 +80,10 @@ SUBROUTINE splint(xa,ya,y2a,x,y,err,message) klo=max(min(locate(xa,x),n-1),1) khi=klo+1 h=xa(khi)-xa(klo) - if (h == 0.0_dp) then; err=20; message="f-splint/badXinput"; return; end if + if (h == 0.0_rkind) then; err=20; message="f-splint/badXinput"; return; end if a=(xa(khi)-x)/h b=(x-xa(klo))/h - y=a*ya(klo)+b*ya(khi)+((a**3-a)*y2a(klo)+(b**3-b)*y2a(khi))*(h**2)/6.0_dp + y=a*ya(klo)+b*ya(khi)+((a**3-a)*y2a(klo)+(b**3-b)*y2a(khi))*(h**2)/6.0_rkind END SUBROUTINE splint ! ************************************************************* @@ -91,8 +91,8 @@ END SUBROUTINE splint ! ************************************************************* FUNCTION locate(xx,x) IMPLICIT NONE - REAL(DP), DIMENSION(:), INTENT(IN) :: xx - REAL(DP), INTENT(IN) :: x + real(rkind), DIMENSION(:), INTENT(IN) :: xx + real(rkind), INTENT(IN) :: x INTEGER(I4B) :: locate INTEGER(I4B) :: n,jl,jm,ju LOGICAL :: ascnd @@ -124,14 +124,14 @@ END FUNCTION locate SUBROUTINE tridag(a,b,c,r,u,err,message) IMPLICIT NONE ! dummy variables - REAL(DP), DIMENSION(:), INTENT(IN) :: a,b,c,r - REAL(DP), DIMENSION(:), INTENT(OUT) :: u + real(rkind), DIMENSION(:), INTENT(IN) :: a,b,c,r + real(rkind), DIMENSION(:), INTENT(OUT) :: u integer(i4b),intent(out) :: err character(*),intent(out) :: message ! local variables - REAL(DP), DIMENSION(size(b)) :: gam + real(rkind), DIMENSION(size(b)) :: gam INTEGER(I4B) :: n,j - REAL(DP) :: bet + real(rkind) :: bet ! initialize error control err=0; message="f-spline/OK" ! check that the size of the vectors match @@ -142,12 +142,12 @@ SUBROUTINE tridag(a,b,c,r,u,err,message) end if ! start procedure bet=b(1) - if (bet == 0.0_dp) then; err=20; message="f-tridag/errorAtCodeStage-1"; return; end if + if (bet == 0.0_rkind) then; err=20; message="f-tridag/errorAtCodeStage-1"; return; end if u(1)=r(1)/bet do j=2,n gam(j)=c(j-1)/bet bet=b(j)-a(j-1)*gam(j) - if (bet == 0.0_dp) then; err=20; message="f-tridag/errorAtCodeStage-2"; return; end if + if (bet == 0.0_rkind) then; err=20; message="f-tridag/errorAtCodeStage-2"; return; end if u(j)=(r(j)-a(j-1)*u(j-1))/bet end do do j=n-1,1,-1 diff --git a/build/source/engine/ssdNrgFlux.f90 b/build/source/engine/ssdNrgFlux.f90 index cd4f371e2..8ecb188d7 100755 --- a/build/source/engine/ssdNrgFlux.f90 +++ b/build/source/engine/ssdNrgFlux.f90 @@ -83,8 +83,8 @@ module ssdNrgFlux_module private public::ssdNrgFlux ! global parameters -real(dp),parameter :: dx=1.e-10_dp ! finite difference increment (K) -real(dp),parameter :: valueMissing=-9999._dp ! missing value parameter +real(rkind),parameter :: dx=1.e-10_rkind ! finite difference increment (K) +real(rkind),parameter :: valueMissing=-9999._rkind ! missing value parameter contains ! ************************************************************************************************ @@ -117,13 +117,13 @@ subroutine ssdNrgFlux(& ! input: model control logical(lgt),intent(in) :: scalarSolution ! flag to denote if implementing the scalar solution ! input: fluxes and derivatives at the upper boundary - real(dp),intent(in) :: groundNetFlux ! net energy flux for the ground surface (W m-2) - real(dp),intent(in) :: dGroundNetFlux_dGroundTemp ! derivative in net ground flux w.r.t. ground temperature (W m-2 K-1) + real(rkind),intent(in) :: groundNetFlux ! net energy flux for the ground surface (W m-2) + real(rkind),intent(in) :: dGroundNetFlux_dGroundTemp ! derivative in net ground flux w.r.t. ground temperature (W m-2 K-1) ! input: liquid water fluxes - real(dp),intent(in) :: iLayerLiqFluxSnow(0:) ! intent(in): liquid flux at the interface of each snow layer (m s-1) - real(dp),intent(in) :: iLayerLiqFluxSoil(0:) ! intent(in): liquid flux at the interface of each soil layer (m s-1) + real(rkind),intent(in) :: iLayerLiqFluxSnow(0:) ! intent(in): liquid flux at the interface of each snow layer (m s-1) + real(rkind),intent(in) :: iLayerLiqFluxSoil(0:) ! intent(in): liquid flux at the interface of each soil layer (m s-1) ! input: trial value of model state variables - real(dp),intent(in) :: mLayerTempTrial(:) ! trial temperature of each snow/soil layer at the current iteration (K) + real(rkind),intent(in) :: mLayerTempTrial(:) ! trial temperature of each snow/soil layer at the current iteration (K) ! input-output: data structures type(var_dlength),intent(in) :: mpar_data ! model parameters type(var_ilength),intent(in) :: indx_data ! state vector geometry @@ -131,9 +131,9 @@ subroutine ssdNrgFlux(& type(var_dlength),intent(in) :: diag_data ! diagnostic variables for a local HRU type(var_dlength),intent(inout) :: flux_data ! model fluxes for a local HRU ! output: fluxes and derivatives at all layer interfaces - real(dp),intent(out) :: iLayerNrgFlux(0:) ! energy flux at the layer interfaces (W m-2) - real(dp),intent(out) :: dFlux_dTempAbove(0:) ! derivatives in the flux w.r.t. temperature in the layer above (J m-2 s-1 K-1) - real(dp),intent(out) :: dFlux_dTempBelow(0:) ! derivatives in the flux w.r.t. temperature in the layer below (J m-2 s-1 K-1) + real(rkind),intent(out) :: iLayerNrgFlux(0:) ! energy flux at the layer interfaces (W m-2) + real(rkind),intent(out) :: dFlux_dTempAbove(0:) ! derivatives in the flux w.r.t. temperature in the layer above (J m-2 s-1 K-1) + real(rkind),intent(out) :: dFlux_dTempBelow(0:) ! derivatives in the flux w.r.t. temperature in the layer below (J m-2 s-1 K-1) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message @@ -143,9 +143,9 @@ subroutine ssdNrgFlux(& integer(i4b) :: ixLayerDesired(1) ! layer desired (scalar solution) integer(i4b) :: ixTop ! top layer in subroutine call integer(i4b) :: ixBot ! bottom layer in subroutine call - real(dp) :: qFlux ! liquid flux at layer interfaces (m s-1) - real(dp) :: dz ! height difference (m) - real(dp) :: flux0,flux1,flux2 ! fluxes used to calculate derivatives (W m-2) + real(rkind) :: qFlux ! liquid flux at layer interfaces (m s-1) + real(rkind) :: dz ! height difference (m) + real(rkind) :: flux0,flux1,flux2 ! fluxes used to calculate derivatives (W m-2) ! ------------------------------------------------------------------------------------------------------------------------------------------------------ ! make association of local variables with information in the data structures associate(& @@ -194,8 +194,8 @@ subroutine ssdNrgFlux(& if(iLayer==nLayers)then ! flux depends on the type of lower boundary condition select case(ix_bcLowrTdyn) ! (identify the lower boundary condition for thermodynamics - case(prescribedTemp); iLayerConductiveFlux(nLayers) = -iLayerThermalC(iLayer)*(lowerBoundTemp - mLayerTempTrial(iLayer))/(mLayerDepth(iLayer)*0.5_dp) - case(zeroFlux); iLayerConductiveFlux(nLayers) = 0._dp + case(prescribedTemp); iLayerConductiveFlux(nLayers) = -iLayerThermalC(iLayer)*(lowerBoundTemp - mLayerTempTrial(iLayer))/(mLayerDepth(iLayer)*0.5_rkind) + case(zeroFlux); iLayerConductiveFlux(nLayers) = 0._rkind case default; err=20; message=trim(message)//'unable to identify lower boundary condition for thermodynamics'; return end select ! (identifying the lower boundary condition for thermodynamics) @@ -257,7 +257,7 @@ subroutine ssdNrgFlux(& ! * prescribed temperature at the lower boundary case(prescribedTemp) - dz = mLayerDepth(iLayer)*0.5_dp + dz = mLayerDepth(iLayer)*0.5_rkind if(ix_fDerivMeth==analytical)then ! ** analytical derivatives dFlux_dTempAbove(iLayer) = iLayerThermalC(iLayer)/dz else ! ** numerical derivatives @@ -268,7 +268,7 @@ subroutine ssdNrgFlux(& ! * zero flux at the lower boundary case(zeroFlux) - dFlux_dTempAbove(iLayer) = 0._dp + dFlux_dTempAbove(iLayer) = 0._rkind case default; err=20; message=trim(message)//'unable to identify lower boundary condition for thermodynamics'; return diff --git a/build/source/engine/stomResist.f90 b/build/source/engine/stomResist.f90 index 00cee9975..cf852679d 100755 --- a/build/source/engine/stomResist.f90 +++ b/build/source/engine/stomResist.f90 @@ -94,11 +94,11 @@ module stomResist_module integer(i4b),parameter :: iLoc = 1 ! i-location integer(i4b),parameter :: jLoc = 1 ! j-location ! conversion factors -real(dp),parameter :: joule2umolConv=4.6_dp ! conversion factor from joules to umol photons (umol J-1) +real(rkind),parameter :: joule2umolConv=4.6_rkind ! conversion factor from joules to umol photons (umol J-1) ! algorithmic parameters -real(dp),parameter :: missingValue=-9999._dp ! missing value, used when diagnostic or state variables are undefined -real(dp),parameter :: mpe=1.e-6_dp ! prevents overflow error if division by zero -real(dp),parameter :: dx=1.e-6_dp ! finite difference increment +real(rkind),parameter :: missingValue=-9999._rkind ! missing value, used when diagnostic or state variables are undefined +real(rkind),parameter :: mpe=1.e-6_rkind ! prevents overflow error if division by zero +real(rkind),parameter :: dx=1.e-6_rkind ! finite difference increment contains @@ -127,9 +127,9 @@ subroutine stomResist(& USE conv_funcs_module,only:satVapPress ! function to compute the saturated vapor pressure (Pa) ! ------------------------------------------------------------------------------------------------------------------------------------------------------ ! input: state and diagnostic variables - real(dp),intent(in) :: scalarVegetationTemp ! vegetation temperature (K) - real(dp),intent(in) :: scalarSatVP_VegTemp ! saturation vapor pressure at vegetation temperature (Pa) - real(dp),intent(in) :: scalarVP_CanopyAir ! canopy air vapor pressure (Pa) + real(rkind),intent(in) :: scalarVegetationTemp ! vegetation temperature (K) + real(rkind),intent(in) :: scalarSatVP_VegTemp ! saturation vapor pressure at vegetation temperature (Pa) + real(rkind),intent(in) :: scalarVP_CanopyAir ! canopy air vapor pressure (Pa) ! input: data structures type(var_i),intent(in) :: type_data ! type of vegetation and soil type(var_d),intent(in) :: forc_data ! model forcing data @@ -147,10 +147,10 @@ subroutine stomResist(& integer(i4b),parameter :: ixSunlit=1 ! named variable for sunlit leaves integer(i4b),parameter :: ixShaded=2 ! named variable for shaded leaves integer(i4b) :: iSunShade ! index defining sunlit or shaded leaves - real(dp) :: absorbedPAR ! absorbed PAR (W m-2) - real(dp) :: scalarStomResist ! stomatal resistance (s m-1) - real(dp) :: scalarPhotosynthesis ! photosynthesis (umol CO2 m-2 s-1) - real(dp) :: ci ! intercellular co2 partial pressure (Pa) + real(rkind) :: absorbedPAR ! absorbed PAR (W m-2) + real(rkind) :: scalarStomResist ! stomatal resistance (s m-1) + real(rkind) :: scalarPhotosynthesis ! photosynthesis (umol CO2 m-2 s-1) + real(rkind) :: ci ! intercellular co2 partial pressure (Pa) ! ------------------------------------------------------------------------------------------------------------------------------------------------------ ! associate variables in the data structure @@ -356,10 +356,10 @@ subroutine stomResist_flex(& ! ------------------------------------------------------------------------------------------------------------------------------------------------------ ! ------------------------------------------------------------------------------------------------------------------------------------------------------ ! input: state and diagnostic variables - real(dp),intent(in) :: scalarVegetationTemp ! vegetation temperature (K) - real(dp),intent(in) :: scalarSatVP_VegTemp ! saturation vapor pressure at vegetation temperature (Pa) - real(dp),intent(in) :: scalarVP_CanopyAir ! canopy air vapor pressure (Pa) - real(dp),intent(in) :: absorbedPAR ! absorbed PAR (W m-2) + real(rkind),intent(in) :: scalarVegetationTemp ! vegetation temperature (K) + real(rkind),intent(in) :: scalarSatVP_VegTemp ! saturation vapor pressure at vegetation temperature (Pa) + real(rkind),intent(in) :: scalarVP_CanopyAir ! canopy air vapor pressure (Pa) + real(rkind),intent(in) :: absorbedPAR ! absorbed PAR (W m-2) ! input: data structures type(var_d),intent(in) :: forc_data ! model forcing data type(var_dlength),intent(in) :: mpar_data ! model parameters @@ -367,69 +367,69 @@ subroutine stomResist_flex(& type(var_dlength),intent(in) :: flux_data ! model fluxes for a local HRU type(model_options),intent(in) :: model_decisions(:) ! model decisions ! output: stomatal resistance and photosynthesis - real(dp),intent(inout) :: ci ! intercellular co2 partial pressure (Pa) - real(dp),intent(out) :: scalarStomResist ! stomatal resistance (s m-1) - real(dp),intent(out) :: scalarPhotosynthesis ! photosynthesis (umol CO2 m-2 s-1) + real(rkind),intent(inout) :: ci ! intercellular co2 partial pressure (Pa) + real(rkind),intent(out) :: scalarStomResist ! stomatal resistance (s m-1) + real(rkind),intent(out) :: scalarPhotosynthesis ! photosynthesis (umol CO2 m-2 s-1) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! ------------------------------------------------------------------------------------------------------------------------------------------------------ ! general local variables logical(lgt),parameter :: testDerivs=.false. ! flag to test the derivatives - real(dp) :: unitConv ! unit conversion factor (mol m-3, convert m s-1 --> mol H20 m-2 s-1) - real(dp) :: rlb ! leaf boundary layer rersistance (umol-1 m2 s) - real(dp) :: x0,x1,x2 ! temporary variables - real(dp) :: co2compPt ! co2 compensation point (Pa) - real(dp) :: fHum ! humidity function, fraction [0,1] + real(rkind) :: unitConv ! unit conversion factor (mol m-3, convert m s-1 --> mol H20 m-2 s-1) + real(rkind) :: rlb ! leaf boundary layer rersistance (umol-1 m2 s) + real(rkind) :: x0,x1,x2 ! temporary variables + real(rkind) :: co2compPt ! co2 compensation point (Pa) + real(rkind) :: fHum ! humidity function, fraction [0,1] ! ------------------------------------------------------------------------------------------------------------------------------------------------------ ! fixed parameters integer(i4b),parameter :: maxiter=20 ! maximum number of iterations integer(i4b),parameter :: maxiter_noahMP=3 ! maximum number of iterations for Noah-MP - real(dp),parameter :: convToler=0.0001_dp ! convergence tolerance (Pa) - real(dp),parameter :: umol_per_mol=1.e+6_dp ! factor to relate umol to mol - real(dp),parameter :: o2scaleFactor=0.105_dp ! scaling factor used to compute co2 compesation point (0.21/2) - real(dp),parameter :: h2o_co2__leafbl=1.37_dp ! factor to represent the different diffusivities of h2o and co2 in the leaf boundary layer (-) - real(dp),parameter :: h2o_co2__stomPores=1.65_dp ! factor to represent the different diffusivities of h2o and co2 in the stomatal pores (-) - real(dp),parameter :: Tref=298.16_dp ! reference temperature (25 deg C) - real(dp),parameter :: Tscale=10._dp ! scaling factor in q10 function (K) - real(dp),parameter :: c_ps2=0.7_dp ! curvature factor for electron transport (-) - real(dp),parameter :: fnf=0.6666666667_dp ! foliage nitrogen factor (-) + real(rkind),parameter :: convToler=0.0001_rkind ! convergence tolerance (Pa) + real(rkind),parameter :: umol_per_mol=1.e+6_rkind ! factor to relate umol to mol + real(rkind),parameter :: o2scaleFactor=0.105_rkind ! scaling factor used to compute co2 compesation point (0.21/2) + real(rkind),parameter :: h2o_co2__leafbl=1.37_rkind ! factor to represent the different diffusivities of h2o and co2 in the leaf boundary layer (-) + real(rkind),parameter :: h2o_co2__stomPores=1.65_rkind ! factor to represent the different diffusivities of h2o and co2 in the stomatal pores (-) + real(rkind),parameter :: Tref=298.16_rkind ! reference temperature (25 deg C) + real(rkind),parameter :: Tscale=10._rkind ! scaling factor in q10 function (K) + real(rkind),parameter :: c_ps2=0.7_rkind ! curvature factor for electron transport (-) + real(rkind),parameter :: fnf=0.6666666667_rkind ! foliage nitrogen factor (-) ! ------------------------------------------------------------------------------------------------------------------------------------------------------ ! photosynthesis - real(dp) :: Kc,Ko ! Michaelis-Menten constants for co2 and o2 (Pa) - real(dp) :: vcmax25 ! maximum Rubisco carboxylation rate at 25 deg C (umol m-2 s-1) - real(dp) :: jmax25 ! maximum electron transport rate at 25 deg C (umol m-2 s-1) - real(dp) :: vcmax ! maximum Rubisco carboxylation rate (umol m-2 s-1) - real(dp) :: jmax ! maximum electron transport rate (umol m-2 s-1) - real(dp) :: aQuad ! the quadratic coefficient in the quadratic equation - real(dp) :: bQuad ! the linear coefficient in the quadratic equation - real(dp) :: cQuad ! the constant in the quadratic equation - real(dp) :: bSign ! sign of the linear coeffcient - real(dp) :: xTemp ! temporary variable in the quadratic equation - real(dp) :: qQuad ! the "q" term in the quadratic equation - real(dp) :: root1,root2 ! roots of the quadratic function - real(dp) :: Js ! scaled electron transport rate (umol co2 m-2 s-1) - real(dp) :: I_ps2 ! PAR absorbed by PS2 (umol photon m-2 s-1) - real(dp) :: awb ! Michaelis-Menten control (Pa) - real(dp) :: cp2 ! additional controls in light-limited assimilation (Pa) - real(dp) :: psn ! leaf gross photosynthesis rate (umol co2 m-2 s-1) - real(dp) :: dA_dc ! derivative in photosynthesis w.r.t. intercellular co2 concentration + real(rkind) :: Kc,Ko ! Michaelis-Menten constants for co2 and o2 (Pa) + real(rkind) :: vcmax25 ! maximum Rubisco carboxylation rate at 25 deg C (umol m-2 s-1) + real(rkind) :: jmax25 ! maximum electron transport rate at 25 deg C (umol m-2 s-1) + real(rkind) :: vcmax ! maximum Rubisco carboxylation rate (umol m-2 s-1) + real(rkind) :: jmax ! maximum electron transport rate (umol m-2 s-1) + real(rkind) :: aQuad ! the quadratic coefficient in the quadratic equation + real(rkind) :: bQuad ! the linear coefficient in the quadratic equation + real(rkind) :: cQuad ! the constant in the quadratic equation + real(rkind) :: bSign ! sign of the linear coeffcient + real(rkind) :: xTemp ! temporary variable in the quadratic equation + real(rkind) :: qQuad ! the "q" term in the quadratic equation + real(rkind) :: root1,root2 ! roots of the quadratic function + real(rkind) :: Js ! scaled electron transport rate (umol co2 m-2 s-1) + real(rkind) :: I_ps2 ! PAR absorbed by PS2 (umol photon m-2 s-1) + real(rkind) :: awb ! Michaelis-Menten control (Pa) + real(rkind) :: cp2 ! additional controls in light-limited assimilation (Pa) + real(rkind) :: psn ! leaf gross photosynthesis rate (umol co2 m-2 s-1) + real(rkind) :: dA_dc ! derivative in photosynthesis w.r.t. intercellular co2 concentration ! ------------------------------------------------------------------------------------------------------------------------------------------------------ ! stomatal resistance - real(dp) :: gMin ! scaled minimum conductance (umol m-2 s-1) - real(dp) :: cs ! co2 partial pressure at leaf surface (Pa) - real(dp) :: csx ! control of co2 partial pressure at leaf surface on stomatal conductance (Pa) - real(dp) :: g0 ! stomatal conductance in the absence of humidity controls (umol m-2 s-1) - real(dp) :: ci_old ! intercellular co2 partial pressure (Pa) - real(dp) :: rs ! stomatal resistance (umol-1 m2 s) - real(dp) :: dg0_dc ! derivative in g0 w.r.t intercellular co2 concentration (umol m-2 s-1 Pa-1) - real(dp) :: drs_dc ! derivative in stomatal resistance w.r.t. intercellular co2 concentration - real(dp) :: dci_dc ! final derivative (-) + real(rkind) :: gMin ! scaled minimum conductance (umol m-2 s-1) + real(rkind) :: cs ! co2 partial pressure at leaf surface (Pa) + real(rkind) :: csx ! control of co2 partial pressure at leaf surface on stomatal conductance (Pa) + real(rkind) :: g0 ! stomatal conductance in the absence of humidity controls (umol m-2 s-1) + real(rkind) :: ci_old ! intercellular co2 partial pressure (Pa) + real(rkind) :: rs ! stomatal resistance (umol-1 m2 s) + real(rkind) :: dg0_dc ! derivative in g0 w.r.t intercellular co2 concentration (umol m-2 s-1 Pa-1) + real(rkind) :: drs_dc ! derivative in stomatal resistance w.r.t. intercellular co2 concentration + real(rkind) :: dci_dc ! final derivative (-) ! ------------------------------------------------------------------------------------------------------------------------------------------------------ ! iterative solution - real(dp) :: func1,func2 ! functions for numerical derivative calculation - real(dp) :: cMin,cMax ! solution brackets - real(dp) :: xInc ! iteration increment (Pa) + real(rkind) :: func1,func2 ! functions for numerical derivative calculation + real(rkind) :: cMin,cMax ! solution brackets + real(rkind) :: xInc ! iteration increment (Pa) integer(i4b) :: iter ! iteration index ! ------------------------------------------------------------------------------------------------------------------------------------------------------ ! associate variables in the data structure @@ -498,8 +498,8 @@ subroutine stomResist_flex(& ! check there is light available for photosynthesis if(absorbedPAR < tiny(absorbedPAR) .or. scalarGrowingSeasonIndex < tiny(absorbedPAR))then scalarStomResist = unitConv*umol_per_mol/(scalarTranspireLim*minStomatalConductance) - scalarPhotosynthesis = 0._dp - ci = 0._dp + scalarPhotosynthesis = 0._rkind + ci = 0._rkind return end if @@ -572,27 +572,27 @@ subroutine stomResist_flex(& ! linear function of qmax, as used in Cable [Wang et al., Ag Forest Met 1998, eq D5] case(linearJmax) x0 = quantamYield*joule2umolConv*absorbedPAR - x1 = x0*jmax / (x0 + 2.1_dp*jmax) - Js = x1/4._dp ! scaled electron transport + x1 = x0*jmax / (x0 + 2.1_rkind*jmax) + Js = x1/4._rkind ! scaled electron transport ! quadraric function of jmax, as used in CLM5 (Bonan et al., JGR 2011, Table B2) case(quadraticJmax) ! PAR absorbed by PS2 (umol photon m-2 s-1) - I_ps2 = 0.5_dp*(1._dp - fractionJ) * joule2umolConv*absorbedPAR ! Farquar (1980), eq 8: PAR absorbed by PS2 (umol photon m-2 s-1) + I_ps2 = 0.5_rkind*(1._rkind - fractionJ) * joule2umolConv*absorbedPAR ! Farquar (1980), eq 8: PAR absorbed by PS2 (umol photon m-2 s-1) ! define coefficients in the quadratic equation aQuad = c_ps2 ! quadratic coefficient = cuurvature factor for electron transport bQuad = -(I_ps2 + jmax) ! linear coefficient cQuad = I_ps2 * jmax ! free term ! compute the q term (NOTE: bQuad is always positive) bSign = abs(bQuad)/bQuad - xTemp = bQuad*bQuad - 4._dp *aQuad*cQuad - qQuad = -0.5_dp * (bQuad + bSign*sqrt(xTemp)) + xTemp = bQuad*bQuad - 4._rkind *aQuad*cQuad + qQuad = -0.5_rkind * (bQuad + bSign*sqrt(xTemp)) ! compute roots root1 = qQuad / aQuad root2 = cQuad / qQuad ! select minimum root, required to ensure J=0 when par=0 ! NOTE: Wittig et al. select the first root, which is the max in all cases I tried - Js = min(root1,root2) / 4._dp ! scaled J + Js = min(root1,root2) / 4._rkind ! scaled J ! check found an appropriate option case default; err=20; message=trim(message)//'unable to find option for electron transport controls on stomatal conductance'; return @@ -605,7 +605,7 @@ subroutine stomResist_flex(& ! define the humidity function select case(ix_bbHumdFunc) - case(humidLeafSurface); fHum = min( max(0.25_dp, scalarVP_CanopyAir/scalarSatVP_VegTemp), 1._dp) + case(humidLeafSurface); fHum = min( max(0.25_rkind, scalarVP_CanopyAir/scalarSatVP_VegTemp), 1._rkind) case(scaledHyperbolic); fHum = (scalarSatVP_VegTemp - scalarVP_CanopyAir)/vpScaleFactor case default; err=20; message=trim(message)//'unable to identify humidity control on stomatal conductance'; return end select @@ -614,23 +614,23 @@ subroutine stomResist_flex(& co2compPt = (Kc/Ko)*scalarO2air*o2scaleFactor ! compute the Michaelis-Menten controls (Pa) - awb = Kc*(1._dp + scalarO2air/Ko) + awb = Kc*(1._rkind + scalarO2air/Ko) ! compute the additional controls in light-limited assimilation - cp2 = co2compPt*2._dp + cp2 = co2compPt*2._rkind ! define trial value of intercellular co2 (Pa) ! NOTE: only initialize if less than the co2 compensation point; otherwise, initialize with previous value if(ix_bbNumerics==newtonRaphson)then - if(ci < co2compPt) ci = 0.7_dp*scalarCO2air + if(ci < co2compPt) ci = 0.7_rkind*scalarCO2air else - ci = 0.7_dp*scalarCO2air ! always initialize if not NR + ci = 0.7_rkind*scalarCO2air ! always initialize if not NR end if !write(*,'(a,1x,10(f20.10,1x))') 'Kc25, Kc_qFac, Ko25, Ko_qFac = ', Kc25, Kc_qFac, Ko25, Ko_qFac !write(*,'(a,1x,10(f20.10,1x))') 'scalarCO2air, ci, co2compPt, Kc, Ko = ', scalarCO2air, ci, co2compPt, Kc, Ko ! initialize brackets for the solution - cMin = 0._dp + cMin = 0._rkind cMax = scalarCO2air ! ********************************************************************************************************************************* @@ -670,14 +670,14 @@ subroutine stomResist_flex(& ! compute conductance in the absence of humidity g0 = cond2photo_slope*airpres*psn/csx - dg0_dc = cond2photo_slope*airpres*dA_dc*(x1*psn/cs + 1._dp)/csx + dg0_dc = cond2photo_slope*airpres*dA_dc*(x1*psn/cs + 1._rkind)/csx ! use quadratic function to compute stomatal resistance call quadResist(.true.,ix_bbHumdFunc,rlb,fHum,gMin,g0,dg0_dc,rs,drs_dc) ! compute intercellular co2 partial pressues (Pa) x2 = h2o_co2__stomPores * airpres ! Pa - ci = max(cs - x2*psn*rs, 0._dp) ! Pa + ci = max(cs - x2*psn*rs, 0._rkind) ! Pa ! print progress !if(ix_bbNumerics==NoahMPsolution)then @@ -689,7 +689,7 @@ subroutine stomResist_flex(& if(ci > tiny(ci))then dci_dc = -x1*dA_dc - x2*(psn*drs_dc + rs*dA_dc) else - dci_dc = 0._dp + dci_dc = 0._rkind end if ! test derivatives @@ -721,14 +721,14 @@ subroutine stomResist_flex(& end if ! compute iteration increment (Pa) - xInc = (ci - ci_old)/(1._dp - dci_dc) + xInc = (ci - ci_old)/(1._rkind - dci_dc) ! update - ci = max(ci_old + xInc, 0._dp) + ci = max(ci_old + xInc, 0._rkind) ! ensure that we stay within brackets if(ci > cMax .or. ci < cMin)then - ci = 0.5_dp * (cMin + cMax) + ci = 0.5_rkind * (cMin + cMax) end if ! print progress @@ -758,11 +758,11 @@ subroutine stomResist_flex(& ! internal function used to test derivatives function testFunc(ci, cond2photo_slope, airpres, scalarCO2air, ix_bbHumdFunc, ix_bbCO2point, ix_bbAssimFnc) - real(dp),intent(in) :: ci, cond2photo_slope, airpres, scalarCO2air + real(rkind),intent(in) :: ci, cond2photo_slope, airpres, scalarCO2air integer(i4b),intent(in) :: ix_bbHumdFunc, ix_bbCO2point, ix_bbAssimFnc - real(dp) :: testFunc - real(dp),parameter :: unUsedInput=0._dp - real(dp) :: unUsedOutput + real(rkind) :: testFunc + real(rkind),parameter :: unUsedInput=0._rkind + real(rkind) :: unUsedOutput ! compute gross photosynthesis [follow Farquar (Planta, 1980), as implemented in CLM4 and Noah-MP] call photosynthesis(.false., ix_bbAssimFnc, ci, co2compPt, awb, cp2, vcmax, Js, psn, unUsedOutput) @@ -786,7 +786,7 @@ function testFunc(ci, cond2photo_slope, airpres, scalarCO2air, ix_bbHumdFunc, ix ! compute intercellular co2 partial pressues (Pa) x2 = h2o_co2__stomPores * airpres ! Pa - testFunc = max(cs - x2*psn*rs, 0._dp) ! Pa + testFunc = max(cs - x2*psn*rs, 0._rkind) ! Pa end function testFunc @@ -800,37 +800,37 @@ subroutine photosynthesis(desireDeriv, ix_bbAssimFnc, ci, co2compPt, awb, cp2, v ! dummy variables logical(lgt),intent(in) :: desireDeriv ! .true. if the derivative is desired integer(i4b),intent(in) :: ix_bbAssimFnc ! model option for the function used for co2 assimilation (min func, or colimtation) - real(dp),intent(in) :: ci ! intercellular co2 concentration (Pa) - real(dp),intent(in) :: co2compPt ! co2 compensation point (Pa) - real(dp),intent(in) :: awb ! Michaelis-Menten control (Pa) - real(dp),intent(in) :: cp2 ! additional controls in light-limited assimilation (Pa) - real(dp),intent(in) :: vcmax ! maximum Rubisco carboxylation rate (umol co2 m-2 s-1) - real(dp),intent(in) :: Js ! scaled electron transport rate (umol co2 m-2 s-1) - real(dp),intent(out) :: psn ! leaf gross photosynthesis rate (umol co2 m-2 s-1) - real(dp),intent(out) :: dA_dc ! derivative in photosynthesis w.r.t. intercellular co2 concentration (umol co2 m-2 s-1 Pa-1) + real(rkind),intent(in) :: ci ! intercellular co2 concentration (Pa) + real(rkind),intent(in) :: co2compPt ! co2 compensation point (Pa) + real(rkind),intent(in) :: awb ! Michaelis-Menten control (Pa) + real(rkind),intent(in) :: cp2 ! additional controls in light-limited assimilation (Pa) + real(rkind),intent(in) :: vcmax ! maximum Rubisco carboxylation rate (umol co2 m-2 s-1) + real(rkind),intent(in) :: Js ! scaled electron transport rate (umol co2 m-2 s-1) + real(rkind),intent(out) :: psn ! leaf gross photosynthesis rate (umol co2 m-2 s-1) + real(rkind),intent(out) :: dA_dc ! derivative in photosynthesis w.r.t. intercellular co2 concentration (umol co2 m-2 s-1 Pa-1) ! local variables integer(i4b),parameter :: nFactors=3 ! number of limiting factors for assimilation (light, Rubisco, and export) integer(i4b),parameter :: ixRubi=1 ! named variable for Rubisco-limited assimilation integer(i4b),parameter :: ixLight=2 ! named variable for light-limited assimilation integer(i4b),parameter :: ixExport=3 ! named variable for export-limited assimilation integer(i4b) :: ixLimitVec(1),ixLimit ! index of factor limiting assimilation - real(dp) :: xFac(nFactors) ! temporary variable used to compute assimilation rate - real(dp) :: xPSN(nFactors) ! assimilation rate for different factors (light, Rubisco, and export) - real(dp) :: ciDiff ! difference between intercellular co2 and the co2 compensation point - real(dp) :: ciDer ! factor to account for constainted intercellular co2 in calculating derivatives - real(dp) :: x0 ! temporary variable - real(dp) :: xsPSN ! intermediate smoothed photosynthesis - real(dp) :: dAc_dc,dAj_dc,dAe_dc,dAi_dc ! derivatives in assimilation w.r.t. intercellular co2 concentration - real(dp),parameter :: theta_cj=0.98_dp ! coupling coefficient (see Sellers et al., 1996 [eq C6]; Bonan et al., 2011 [Table B1]) - real(dp),parameter :: theta_ie=0.95_dp ! coupling coefficient (see Sellers et al., 1996 [eq C6]; Bonan et al., 2011 [Table B1]) + real(rkind) :: xFac(nFactors) ! temporary variable used to compute assimilation rate + real(rkind) :: xPSN(nFactors) ! assimilation rate for different factors (light, Rubisco, and export) + real(rkind) :: ciDiff ! difference between intercellular co2 and the co2 compensation point + real(rkind) :: ciDer ! factor to account for constainted intercellular co2 in calculating derivatives + real(rkind) :: x0 ! temporary variable + real(rkind) :: xsPSN ! intermediate smoothed photosynthesis + real(rkind) :: dAc_dc,dAj_dc,dAe_dc,dAi_dc ! derivatives in assimilation w.r.t. intercellular co2 concentration + real(rkind),parameter :: theta_cj=0.98_rkind ! coupling coefficient (see Sellers et al., 1996 [eq C6]; Bonan et al., 2011 [Table B1]) + real(rkind),parameter :: theta_ie=0.95_rkind ! coupling coefficient (see Sellers et al., 1996 [eq C6]; Bonan et al., 2011 [Table B1]) ! ------------------------------------------------------------ ! this method follows Farquar (Planta, 1980), as implemented in CLM4 and Noah-MP ! compute the difference between intercellular co2 concentraion and the compensation point - ciDiff = max(0._dp, ci - co2compPt) + ciDiff = max(0._rkind, ci - co2compPt) ! impose constraints (NOTE: derivative is zero if constraints are imposed) - if(ci < co2compPt)then; ciDer = 0._dp; else; ciDer = 1._dp; end if + if(ci < co2compPt)then; ciDer = 0._rkind; else; ciDer = 1._rkind; end if ! compute Rubisco-limited assimilation xFac(ixRubi) = vcmax/(ci + awb) ! umol co2 m-2 s-1 Pa-1 @@ -841,7 +841,7 @@ subroutine photosynthesis(desireDeriv, ix_bbAssimFnc, ci, co2compPt, awb, cp2, v xPSN(ixLight) = xFac(ixLight)*ciDiff ! umol co2 m-2 s-1 ! compute export limited assimilation - xFac(ixExport) = 0.5_dp + xFac(ixExport) = 0.5_rkind xPSN(ixExport) = xFac(ixExport)*vcmax ! umol co2 m-2 s-1 ! print progress @@ -868,12 +868,12 @@ subroutine photosynthesis(desireDeriv, ix_bbAssimFnc, ci, co2compPt, awb, cp2, v select case(ixLimit) case(ixRubi); dA_dc = x0*ciDer - ciDiff*x0*x0/vcmax ! Rubisco-limited assimilation case(ixLight); dA_dc = x0*ciDer - ciDiff*x0*x0/Js ! light-limited assimilation - case(ixExport); dA_dc = 0._dp ! export-limited assimilation + case(ixExport); dA_dc = 0._rkind ! export-limited assimilation end select ! derivatives are not desired else - dA_dc = 0._dp + dA_dc = 0._rkind end if ! colimitation (Collatz et al., 1991; Sellers et al., 1996; Bonan et al., 2011) @@ -883,19 +883,19 @@ subroutine photosynthesis(desireDeriv, ix_bbAssimFnc, ci, co2compPt, awb, cp2, v if(desireDeriv)then dAc_dc = xFac(ixRubi)*ciDer - ciDiff*xFac(ixRubi)*xFac(ixRubi)/vcmax dAj_dc = xFac(ixLight)*ciDer - ciDiff*xFac(ixLight)*xFac(ixLight)/Js - dAe_dc = 0._dp + dAe_dc = 0._rkind else - dAc_dc = 0._dp - dAj_dc = 0._dp - dAe_dc = 0._dp + dAc_dc = 0._rkind + dAj_dc = 0._rkind + dAe_dc = 0._rkind end if ! smooth Rubisco-limitation and light limitation if(ciDiff > tiny(ciDiff))then call quadSmooth(desireDeriv, xPSN(ixRubi), xPSN(ixLight), theta_cj, dAc_dc, dAj_dc, xsPSN, dAi_dc) else - xsPSN = 0._dp - dAi_dc = 0._dp + xsPSN = 0._rkind + dAi_dc = 0._rkind end if ! smooth intermediate-limitation and export limitation @@ -942,18 +942,18 @@ subroutine quadResist(desireDeriv,ix_bbHumdFunc,rlb,fHum,gMin,g0,dg0_dc,rs,drs_d ! dummy variables logical(lgt),intent(in) :: desireDeriv ! flag to denote if the derivative is desired integer(i4b),intent(in) :: ix_bbHumdFunc ! option for humidity control on stomatal resistance - real(dp),intent(in) :: rlb ! leaf boundary layer resistance (umol-1 m2 s) - real(dp),intent(in) :: fHum ! scaled humidity function (-) - real(dp),intent(in) :: gMin ! scaled minimum stomatal consuctance (umol m-2 s-1) - real(dp),intent(in) :: g0 ! stomatal conductance in the absence of humidity controls (umol m-2 s-1) - real(dp),intent(in) :: dg0_dc ! derivative in g0 w.r.t intercellular co2 concentration (umol m-2 s-1 Pa-1) - real(dp),intent(out) :: rs ! stomatal resistance ((umol-1 m2 s) - real(dp),intent(out) :: drs_dc ! derivaive in rs w.r.t intercellular co2 concentration (umol-1 m2 s Pa-1) + real(rkind),intent(in) :: rlb ! leaf boundary layer resistance (umol-1 m2 s) + real(rkind),intent(in) :: fHum ! scaled humidity function (-) + real(rkind),intent(in) :: gMin ! scaled minimum stomatal consuctance (umol m-2 s-1) + real(rkind),intent(in) :: g0 ! stomatal conductance in the absence of humidity controls (umol m-2 s-1) + real(rkind),intent(in) :: dg0_dc ! derivative in g0 w.r.t intercellular co2 concentration (umol m-2 s-1 Pa-1) + real(rkind),intent(out) :: rs ! stomatal resistance ((umol-1 m2 s) + real(rkind),intent(out) :: drs_dc ! derivaive in rs w.r.t intercellular co2 concentration (umol-1 m2 s Pa-1) ! local variables - real(dp) :: aQuad,bQuad,cQuad ! coefficients in the quadratic function - real(dp) :: bSign,xTemp,qQuad ! q term in the quadratic - real(dp) :: root1,root2 ! roots of the quadratic - real(dp) :: dxT_dc,dqq_dc ! derivatives in the q term + real(rkind) :: aQuad,bQuad,cQuad ! coefficients in the quadratic function + real(rkind) :: bSign,xTemp,qQuad ! q term in the quadratic + real(rkind) :: root1,root2 ! roots of the quadratic + real(rkind) :: dxT_dc,dqq_dc ! derivatives in the q term ! define terms for the quadratic function select case(ix_bbHumdFunc) @@ -961,21 +961,21 @@ subroutine quadResist(desireDeriv,ix_bbHumdFunc,rlb,fHum,gMin,g0,dg0_dc,rs,drs_d ! original Ball-Berry case(humidLeafSurface) aQuad = g0*fHum + gMin - bQuad = (g0 + gMin)*rlb - 1._dp + bQuad = (g0 + gMin)*rlb - 1._rkind cQuad = -rlb ! Leuning 1995 case(scaledHyperbolic) - aQuad = g0 + gMin*(1._dp + fHum) - bQuad = (g0 + gMin)*rlb - fHum - 1._dp + aQuad = g0 + gMin*(1._rkind + fHum) + bQuad = (g0 + gMin)*rlb - fHum - 1._rkind cQuad = -rlb end select ! compute the q term in the quadratic bSign = abs(bQuad)/bQuad - xTemp = bQuad*bQuad - 4._dp *aQuad*cQuad - qquad = -0.5_dp * (bQuad + bSign*sqrt(xTemp)) + xTemp = bQuad*bQuad - 4._rkind *aQuad*cQuad + qquad = -0.5_rkind * (bQuad + bSign*sqrt(xTemp)) ! compute roots root1 = qQuad / aQuad @@ -992,10 +992,10 @@ subroutine quadResist(desireDeriv,ix_bbHumdFunc,rlb,fHum,gMin,g0,dg0_dc,rs,drs_d ! compute derivatives in qquad w.r.t. ci select case(ix_bbHumdFunc) - case(humidLeafSurface); dXt_dc = dg0_dc*(rlb*bQuad*2._dp - fHum*cQuad*4._dp) - case(scaledHyperbolic); dXt_dc = dg0_dc*(rlb*bQuad*2._dp - cQuad*4._dp) + case(humidLeafSurface); dXt_dc = dg0_dc*(rlb*bQuad*2._rkind - fHum*cQuad*4._rkind) + case(scaledHyperbolic); dXt_dc = dg0_dc*(rlb*bQuad*2._rkind - cQuad*4._rkind) end select - dqq_dc = -0.5_dp * (rlb*dg0_dc + bSign*dXt_dc*0.5_dp / sqrt(xTemp) ) + dqq_dc = -0.5_rkind * (rlb*dg0_dc + bSign*dXt_dc*0.5_rkind / sqrt(xTemp) ) ! compute derivatives in rs if(root1 > root2)then @@ -1009,7 +1009,7 @@ subroutine quadResist(desireDeriv,ix_bbHumdFunc,rlb,fHum,gMin,g0,dg0_dc,rs,drs_d ! derivatives not desired else - drs_dc = 0._dp + drs_dc = 0._rkind end if end subroutine quadResist @@ -1022,17 +1022,17 @@ subroutine quadSmooth(desireDeriv, x1, x2, xsFac, dx1_dc, dx2_dc, xs, dxs_dc) implicit none ! dummy variables logical(lgt),intent(in) :: desireDeriv ! flag to denote if a derivative is desired - real(dp),intent(in) :: x1,x2 ! variables to be smoothed - real(dp),intent(in) :: xsFac ! smoothing factor - real(dp),intent(in) :: dx1_dc,dx2_dc ! derivatives in variables w.r.t. something important - real(dp),intent(out) :: xs ! smoothed variable - real(dp),intent(out) :: dxs_dc ! derivative w.r.t. something important + real(rkind),intent(in) :: x1,x2 ! variables to be smoothed + real(rkind),intent(in) :: xsFac ! smoothing factor + real(rkind),intent(in) :: dx1_dc,dx2_dc ! derivatives in variables w.r.t. something important + real(rkind),intent(out) :: xs ! smoothed variable + real(rkind),intent(out) :: dxs_dc ! derivative w.r.t. something important ! local variables - real(dp) :: aQuad,bQuad,cQuad ! coefficients in the quadratic function - real(dp) :: bSign,xTemp,qQuad ! q term in the quadratic - real(dp) :: root1,root2 ! roots of the quadratic - real(dp) :: dbq_dc,dcq_dc ! derivatives in quadratic coefficients - real(dp) :: dxT_dc,dqq_dc ! derivatives in the q term + real(rkind) :: aQuad,bQuad,cQuad ! coefficients in the quadratic function + real(rkind) :: bSign,xTemp,qQuad ! q term in the quadratic + real(rkind) :: root1,root2 ! roots of the quadratic + real(rkind) :: dbq_dc,dcq_dc ! derivatives in quadratic coefficients + real(rkind) :: dxT_dc,dqq_dc ! derivatives in the q term ! uses the quadratic of the form ! xsFac*xs^2 - (x1 + x2)*xs + x1*x2 = 0 @@ -1045,8 +1045,8 @@ subroutine quadSmooth(desireDeriv, x1, x2, xsFac, dx1_dc, dx2_dc, xs, dxs_dc) ! compute the q term in the quadratic bSign = abs(bQuad)/bQuad - xTemp = bQuad*bQuad - 4._dp *aQuad*cQuad - qquad = -0.5_dp * (bQuad + bSign*sqrt(xTemp)) + xTemp = bQuad*bQuad - 4._rkind *aQuad*cQuad + qquad = -0.5_rkind * (bQuad + bSign*sqrt(xTemp)) ! compute roots root1 = qQuad / aQuad @@ -1061,8 +1061,8 @@ subroutine quadSmooth(desireDeriv, x1, x2, xsFac, dx1_dc, dx2_dc, xs, dxs_dc) dcq_dc = x1*dx2_dc + x2*dx1_dc ! compute derivatives for xTemp - dxT_dc = 2._dp*(bQuad*dbq_dc) - 4._dp*aQuad*dcq_dc - dqq_dc = -0.5_dp * (dbq_dc + bsign*dxT_dc/(2._dp*sqrt(xTemp))) + dxT_dc = 2._rkind*(bQuad*dbq_dc) - 4._rkind*aQuad*dcq_dc + dqq_dc = -0.5_rkind * (dbq_dc + bsign*dxT_dc/(2._rkind*sqrt(xTemp))) ! compute derivatives in the desired root if(root1 < root2)then @@ -1073,7 +1073,7 @@ subroutine quadSmooth(desireDeriv, x1, x2, xsFac, dx1_dc, dx2_dc, xs, dxs_dc) ! derivatives not required else - dxs_dc = 0._dp + dxs_dc = 0._rkind end if end subroutine quadSmooth @@ -1086,32 +1086,32 @@ end subroutine quadSmooth ! q10 function for temperature dependence function q10(a,T,Tmid,Tscale) implicit none - real(dp),intent(in) :: a ! scale factor - real(dp),intent(in) :: T ! temperature (K) - real(dp),intent(in) :: Tmid ! point where function is one (25 deg C) - real(dp),intent(in) :: Tscale ! scaling factor (K) - real(dp) :: q10 ! temperature dependence (-) + real(rkind),intent(in) :: a ! scale factor + real(rkind),intent(in) :: T ! temperature (K) + real(rkind),intent(in) :: Tmid ! point where function is one (25 deg C) + real(rkind),intent(in) :: Tscale ! scaling factor (K) + real(rkind) :: q10 ! temperature dependence (-) q10 = a**((T - Tmid)/Tscale) end function q10 ! Arrhenius function for temperature dependence function fT(delH,T,Tref) implicit none - real(dp),intent(in) :: delH ! activation energy in temperature function (J mol-1) - real(dp),intent(in) :: T ! temperature (K) - real(dp),intent(in) :: Tref ! reference temperature (K) - real(dp) :: fT ! temperature dependence (-) - fT = exp((delH/(Tref*Rgas))*(1._dp - Tref/T)) ! NOTE: Rgas = J K-1 mol-1 + real(rkind),intent(in) :: delH ! activation energy in temperature function (J mol-1) + real(rkind),intent(in) :: T ! temperature (K) + real(rkind),intent(in) :: Tref ! reference temperature (K) + real(rkind) :: fT ! temperature dependence (-) + fT = exp((delH/(Tref*Rgas))*(1._rkind - Tref/T)) ! NOTE: Rgas = J K-1 mol-1 end function fT ! function for high temperature inhibition function fHigh(delH,delS,T) implicit none - real(dp),intent(in) :: delH ! deactivation energy in high temp inhibition function (J mol-1) - real(dp),intent(in) :: delS ! entropy term in high temp inhibition function (J K-1 mol-1) - real(dp),intent(in) :: T ! temperature (K) - real(dp) :: fHigh ! high temperature inhibition (-) - fHigh = 1._dp + exp( (delS*T - delH)/(Rgas*T) ) ! NOTE: Rgas = J K-1 mol-1 + real(rkind),intent(in) :: delH ! deactivation energy in high temp inhibition function (J mol-1) + real(rkind),intent(in) :: delS ! entropy term in high temp inhibition function (J K-1 mol-1) + real(rkind),intent(in) :: T ! temperature (K) + real(rkind) :: fHigh ! high temperature inhibition (-) + fHigh = 1._rkind + exp( (delS*T - delH)/(Rgas*T) ) ! NOTE: Rgas = J K-1 mol-1 end function fHigh @@ -1161,34 +1161,34 @@ subroutine stomResist_NoahMP(& integer(i4b),intent(in) :: vegTypeIndex ! vegetation type index integer(i4b),intent(in) :: iLoc, jLoc ! spatial location indices ! input (forcing) - real(dp),intent(in) :: airtemp ! measured air temperature at some height above the surface (K) - real(dp),intent(in) :: airpres ! measured air pressure at some height above the surface (Pa) - real(dp),intent(in) :: scalarO2air ! atmospheric o2 concentration (Pa) - real(dp),intent(in) :: scalarCO2air ! atmospheric co2 concentration (Pa) - real(dp),intent(in),target :: scalarCanopySunlitPAR ! average absorbed par for sunlit leaves (w m-2) - real(dp),intent(in),target :: scalarCanopyShadedPAR ! average absorbed par for shaded leaves (w m-2) + real(rkind),intent(in) :: airtemp ! measured air temperature at some height above the surface (K) + real(rkind),intent(in) :: airpres ! measured air pressure at some height above the surface (Pa) + real(rkind),intent(in) :: scalarO2air ! atmospheric o2 concentration (Pa) + real(rkind),intent(in) :: scalarCO2air ! atmospheric co2 concentration (Pa) + real(rkind),intent(in),target :: scalarCanopySunlitPAR ! average absorbed par for sunlit leaves (w m-2) + real(rkind),intent(in),target :: scalarCanopyShadedPAR ! average absorbed par for shaded leaves (w m-2) ! input (state and diagnostic variables) - real(dp),intent(in) :: scalarGrowingSeasonIndex ! growing season index (0=off, 1=on) - real(dp),intent(in) :: scalarFoliageNitrogenFactor ! foliage nitrogen concentration (1=saturated) - real(dp),intent(in) :: scalarTranspireLim ! weighted average of the soil moiture factor controlling stomatal resistance (-) - real(dp),intent(in) :: scalarLeafResistance ! leaf boundary layer resistance (s m-1) - real(dp),intent(in) :: scalarVegetationTemp ! vegetation temperature (K) - real(dp),intent(in) :: scalarSatVP_VegTemp ! saturation vapor pressure at vegetation temperature (Pa) - real(dp),intent(in) :: scalarVP_CanopyAir ! canopy air vapor pressure (Pa) + real(rkind),intent(in) :: scalarGrowingSeasonIndex ! growing season index (0=off, 1=on) + real(rkind),intent(in) :: scalarFoliageNitrogenFactor ! foliage nitrogen concentration (1=saturated) + real(rkind),intent(in) :: scalarTranspireLim ! weighted average of the soil moiture factor controlling stomatal resistance (-) + real(rkind),intent(in) :: scalarLeafResistance ! leaf boundary layer resistance (s m-1) + real(rkind),intent(in) :: scalarVegetationTemp ! vegetation temperature (K) + real(rkind),intent(in) :: scalarSatVP_VegTemp ! saturation vapor pressure at vegetation temperature (Pa) + real(rkind),intent(in) :: scalarVP_CanopyAir ! canopy air vapor pressure (Pa) ! output - real(dp),intent(out) :: scalarStomResistSunlit ! stomatal resistance for sunlit leaves (s m-1) - real(dp),intent(out) :: scalarStomResistShaded ! stomatal resistance for shaded leaves (s m-1) - real(dp),intent(out) :: scalarPhotosynthesisSunlit ! sunlit photosynthesis (umolco2 m-2 s-1) - real(dp),intent(out) :: scalarPhotosynthesisShaded ! sunlit photosynthesis (umolco2 m-2 s-1) + real(rkind),intent(out) :: scalarStomResistSunlit ! stomatal resistance for sunlit leaves (s m-1) + real(rkind),intent(out) :: scalarStomResistShaded ! stomatal resistance for shaded leaves (s m-1) + real(rkind),intent(out) :: scalarPhotosynthesisSunlit ! sunlit photosynthesis (umolco2 m-2 s-1) + real(rkind),intent(out) :: scalarPhotosynthesisShaded ! sunlit photosynthesis (umolco2 m-2 s-1) integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! local variables integer(i4b),parameter :: ixSunlit=1 ! named variable for sunlit leaves integer(i4b),parameter :: ixShaded=2 ! named variable for shaded leaves integer(i4b) :: iSunShade ! index for sunlit/shaded leaves - real(dp),pointer :: PAR ! average absorbed PAR for sunlit/shaded leaves (w m-2) - real(dp) :: scalarStomResist ! stomatal resistance for sunlit/shaded leaves (s m-1) - real(dp) :: scalarPhotosynthesis ! photosynthesis for sunlit/shaded leaves (umolco2 m-2 s-1) + real(rkind),pointer :: PAR ! average absorbed PAR for sunlit/shaded leaves (w m-2) + real(rkind) :: scalarStomResist ! stomatal resistance for sunlit/shaded leaves (s m-1) + real(rkind) :: scalarPhotosynthesis ! photosynthesis for sunlit/shaded leaves (umolco2 m-2 s-1) ! initialize error control err=0; message='stomResist_NoahMP/' diff --git a/build/source/engine/summaSolve.f90 b/build/source/engine/summaSolve.f90 index ee4dfc886..c2d3944b3 100755 --- a/build/source/engine/summaSolve.f90 +++ b/build/source/engine/summaSolve.f90 @@ -136,7 +136,7 @@ subroutine summaSolve(& implicit none ! -------------------------------------------------------------------------------------------------------------------------------- ! input: model control - real(dp),intent(in) :: dt ! length of the time step (seconds) + real(rkind),intent(in) :: dt ! length of the time step (seconds) integer(i4b),intent(in) :: iter ! interation index integer(i4b),intent(in) :: nSnow ! number of snow layers integer(i4b),intent(in) :: nSoil ! number of soil layers @@ -149,14 +149,14 @@ subroutine summaSolve(& logical(lgt),intent(in) :: computeVegFlux ! flag to indicate if computing fluxes over vegetation logical(lgt),intent(in) :: scalarSolution ! flag to denote if implementing the scalar solution ! input: state vectors - real(dp),intent(in) :: stateVecTrial(:) ! trial state vector - real(dp),intent(inout) :: xMin,xMax ! brackets of the root - real(dp),intent(in) :: fScale(:) ! function scaling vector - real(dp),intent(in) :: xScale(:) ! "variable" scaling vector, i.e., for state variables - real(qp),intent(in) :: rVec(:) ! NOTE: qp ! residual vector - real(qp),intent(in) :: sMul(:) ! NOTE: qp ! state vector multiplier (used in the residual calculations) - real(dp),intent(inout) :: dMat(:) ! diagonal matrix (excludes flux derivatives) - real(dp),intent(in) :: fOld ! old function evaluation + real(rkind),intent(in) :: stateVecTrial(:) ! trial state vector + real(rkind),intent(inout) :: xMin,xMax ! brackets of the root + real(rkind),intent(in) :: fScale(:) ! function scaling vector + real(rkind),intent(in) :: xScale(:) ! "variable" scaling vector, i.e., for state variables + real(rkind),intent(in) :: rVec(:) ! NOTE: qp ! residual vector + real(rkind),intent(in) :: sMul(:) ! NOTE: qp ! state vector multiplier (used in the residual calculations) + real(rkind),intent(inout) :: dMat(:) ! diagonal matrix (excludes flux derivatives) + real(rkind),intent(in) :: fOld ! old function evaluation ! input: data structures type(model_options),intent(in) :: model_decisions(:) ! model decisions type(var_i), intent(in) :: type_data ! type of vegetation and soil @@ -172,13 +172,13 @@ subroutine summaSolve(& type(var_dlength),intent(inout) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables ! input-output: baseflow integer(i4b),intent(inout) :: ixSaturation ! index of the lowest saturated layer (NOTE: only computed on the first iteration) - real(dp),intent(inout) :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) + real(rkind),intent(inout) :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) ! output: flux and residual vectors - real(dp),intent(out) :: stateVecNew(:) ! new state vector - real(dp),intent(out) :: fluxVecNew(:) ! new flux vector - real(dp),intent(out) :: resSinkNew(:) ! sink terms on the RHS of the flux equation - real(qp),intent(out) :: resVecNew(:) ! NOTE: qp ! new residual vector - real(dp),intent(out) :: fNew ! new function evaluation + real(rkind),intent(out) :: stateVecNew(:) ! new state vector + real(rkind),intent(out) :: fluxVecNew(:) ! new flux vector + real(rkind),intent(out) :: resSinkNew(:) ! sink terms on the RHS of the flux equation + real(rkind),intent(out) :: resVecNew(:) ! NOTE: qp ! new residual vector + real(rkind),intent(out) :: fNew ! new function evaluation logical(lgt),intent(out) :: converged ! convergence flag ! output: error control integer(i4b),intent(out) :: err ! error code @@ -189,13 +189,13 @@ subroutine summaSolve(& ! Jacobian matrix logical(lgt),parameter :: doNumJacobian=.false. ! flag to compute the numerical Jacobian matrix logical(lgt),parameter :: testBandDiagonal=.false. ! flag to test the band diagonal Jacobian matrix - real(dp) :: nJac(nState,nState) ! numerical Jacobian matrix - real(dp) :: aJac(nLeadDim,nState) ! Jacobian matrix - real(dp) :: aJacScaled(nLeadDim,nState) ! Jacobian matrix (scaled) - real(dp) :: aJacScaledTemp(nLeadDim,nState) ! Jacobian matrix (scaled) -- temporary copy since decomposed in lapack + real(rkind) :: nJac(nState,nState) ! numerical Jacobian matrix + real(rkind) :: aJac(nLeadDim,nState) ! Jacobian matrix + real(rkind) :: aJacScaled(nLeadDim,nState) ! Jacobian matrix (scaled) + real(rkind) :: aJacScaledTemp(nLeadDim,nState) ! Jacobian matrix (scaled) -- temporary copy since decomposed in lapack ! solution/step vectors - real(dp),dimension(nState) :: rVecScaled ! residual vector (scaled) - real(dp),dimension(nState) :: newtStepScaled ! full newton step (scaled) + real(rkind),dimension(nState) :: rVecScaled ! residual vector (scaled) + real(rkind),dimension(nState) :: newtStepScaled ! full newton step (scaled) ! step size refinement logical(lgt) :: doRefine ! flag for step refinement integer(i4b),parameter :: ixLineSearch=1001 ! step refinement = line search @@ -269,7 +269,7 @@ subroutine summaSolve(& ! ------------------------ ! scale the residual vector - rVecScaled(1:nState) = fScale(:)*real(rVec(:), dp) ! NOTE: residual vector is in quadruple precision + rVecScaled(1:nState) = fScale(:)*real(rVec(:), rkind) ! NOTE: residual vector is in quadruple precision ! scale matrices call scaleMatrices(ixMatrix,nState,aJac,fScale,xScale,aJacScaled,err,cmessage) @@ -342,36 +342,36 @@ subroutine lineSearchRefinement(doLineSearch,stateVecTrial,newtStepScaled,aJacSc implicit none ! input logical(lgt),intent(in) :: doLineSearch ! flag to do the line search - real(dp),intent(in) :: stateVecTrial(:) ! trial state vector - real(dp),intent(in) :: newtStepScaled(:) ! scaled newton step - real(dp),intent(in) :: aJacScaled(:,:) ! scaled jacobian matrix - real(dp),intent(in) :: rVecScaled(:) ! scaled residual vector - real(dp),intent(in) :: fOld ! old function value + real(rkind),intent(in) :: stateVecTrial(:) ! trial state vector + real(rkind),intent(in) :: newtStepScaled(:) ! scaled newton step + real(rkind),intent(in) :: aJacScaled(:,:) ! scaled jacobian matrix + real(rkind),intent(in) :: rVecScaled(:) ! scaled residual vector + real(rkind),intent(in) :: fOld ! old function value ! output - real(dp),intent(out) :: stateVecNew(:) ! new state vector - real(dp),intent(out) :: fluxVecNew(:) ! new flux vector - real(qp),intent(out) :: resVecNew(:) ! NOTE: qp ! new residual vector - real(dp),intent(out) :: fNew ! new function evaluation + real(rkind),intent(out) :: stateVecNew(:) ! new state vector + real(rkind),intent(out) :: fluxVecNew(:) ! new flux vector + real(rkind),intent(out) :: resVecNew(:) ! NOTE: qp ! new residual vector + real(rkind),intent(out) :: fNew ! new function evaluation logical(lgt),intent(out) :: converged ! convergence flag integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! -------------------------------------------------------------------------------------------------------- ! local character(len=256) :: cmessage ! error message of downwind routine - real(dp) :: gradScaled(nState) ! scaled gradient - real(dp) :: xInc(nState) ! iteration increment (re-scaled to original units of the state vector) + real(rkind) :: gradScaled(nState) ! scaled gradient + real(rkind) :: xInc(nState) ! iteration increment (re-scaled to original units of the state vector) logical(lgt) :: feasible ! flag to denote the feasibility of the solution integer(i4b) :: iLine ! line search index integer(i4b),parameter :: maxLineSearch=5 ! maximum number of backtracks - real(dp),parameter :: alpha=1.e-4_dp ! check on gradient - real(dp) :: xLambda ! backtrack magnitude - real(dp) :: xLambdaTemp ! temporary backtrack magnitude - real(dp) :: slopeInit ! initial slope - real(dp) :: rhs1,rhs2 ! rhs used to compute the cubic - real(dp) :: aCoef,bCoef ! coefficients in the cubic - real(dp) :: disc ! temporary variable used in cubic - real(dp) :: xLambdaPrev ! previous lambda value (used in the cubic) - real(dp) :: fPrev ! previous function evaluation (used in the cubic) + real(rkind),parameter :: alpha=1.e-4_rkind ! check on gradient + real(rkind) :: xLambda ! backtrack magnitude + real(rkind) :: xLambdaTemp ! temporary backtrack magnitude + real(rkind) :: slopeInit ! initial slope + real(rkind) :: rhs1,rhs2 ! rhs used to compute the cubic + real(rkind) :: aCoef,bCoef ! coefficients in the cubic + real(rkind) :: disc ! temporary variable used in cubic + real(rkind) :: xLambdaPrev ! previous lambda value (used in the cubic) + real(rkind) :: fPrev ! previous function evaluation (used in the cubic) ! -------------------------------------------------------------------------------------------------------- ! initialize error control err=0; message='lineSearchRefinement/' @@ -389,7 +389,7 @@ subroutine lineSearchRefinement(doLineSearch,stateVecTrial,newtStepScaled,aJacSc end if ! if computing the line search ! initialize lambda - xLambda=1._dp + xLambda=1._rkind ! ***** LINE SEARCH LOOP... lineSearch: do iLine=1,maxLineSearch ! try to refine the function by shrinking the step size @@ -449,8 +449,8 @@ subroutine lineSearchRefinement(doLineSearch,stateVecTrial,newtStepScaled,aJacSc ! first backtrack: use quadratic if(iLine==1)then - xLambdaTemp = -slopeInit / (2._dp*(fNew - fOld - slopeInit) ) - if(xLambdaTemp > 0.5_dp*xLambda) xLambdaTemp = 0.5_dp*xLambda + xLambdaTemp = -slopeInit / (2._rkind*(fNew - fOld - slopeInit) ) + if(xLambdaTemp > 0.5_rkind*xLambda) xLambdaTemp = 0.5_rkind*xLambda ! subsequent backtracks: use cubic else @@ -470,21 +470,21 @@ subroutine lineSearchRefinement(doLineSearch,stateVecTrial,newtStepScaled,aJacSc bCoef = (-xLambdaPrev*rhs1/(xLambda*xLambda) + xLambda*rhs2/(xLambdaPrev*xLambdaPrev)) / (xLambda - xLambdaPrev) ! check if a quadratic - if(aCoef==0._dp)then - xLambdaTemp = -slopeInit/(2._dp*bCoef) + if(aCoef==0._rkind)then + xLambdaTemp = -slopeInit/(2._rkind*bCoef) ! calculate cubic else - disc = bCoef*bCoef - 3._dp*aCoef*slopeInit - if(disc < 0._dp)then - xLambdaTemp = 0.5_dp*xLambda + disc = bCoef*bCoef - 3._rkind*aCoef*slopeInit + if(disc < 0._rkind)then + xLambdaTemp = 0.5_rkind*xLambda else - xLambdaTemp = (-bCoef + sqrt(disc))/(3._dp*aCoef) + xLambdaTemp = (-bCoef + sqrt(disc))/(3._rkind*aCoef) end if end if ! calculating cubic ! constrain to <= 0.5*xLambda - if(xLambdaTemp > 0.5_dp*xLambda) xLambdaTemp=0.5_dp*xLambda + if(xLambdaTemp > 0.5_rkind*xLambda) xLambdaTemp=0.5_rkind*xLambda end if ! subsequent backtracks @@ -493,7 +493,7 @@ subroutine lineSearchRefinement(doLineSearch,stateVecTrial,newtStepScaled,aJacSc fPrev = fNew ! constrain lambda - xLambda = max(xLambdaTemp, 0.1_dp*xLambda) + xLambda = max(xLambdaTemp, 0.1_rkind*xLambda) end do lineSearch ! backtrack loop @@ -510,16 +510,16 @@ subroutine trustRegionRefinement(doTrustRefinement,stateVecTrial,newtStepScaled, implicit none ! input logical(lgt),intent(in) :: doTrustRefinement ! flag to refine using trust regions - real(dp),intent(in) :: stateVecTrial(:) ! trial state vector - real(dp),intent(in) :: newtStepScaled(:) ! scaled newton step - real(dp),intent(in) :: aJacScaled(:,:) ! scaled jacobian matrix - real(dp),intent(in) :: rVecScaled(:) ! scaled residual vector - real(dp),intent(in) :: fOld ! old function value + real(rkind),intent(in) :: stateVecTrial(:) ! trial state vector + real(rkind),intent(in) :: newtStepScaled(:) ! scaled newton step + real(rkind),intent(in) :: aJacScaled(:,:) ! scaled jacobian matrix + real(rkind),intent(in) :: rVecScaled(:) ! scaled residual vector + real(rkind),intent(in) :: fOld ! old function value ! output - real(dp),intent(out) :: stateVecNew(:) ! new state vector - real(dp),intent(out) :: fluxVecNew(:) ! new flux vector - real(qp),intent(out) :: resVecNew(:) ! NOTE: qp ! new residual vector - real(dp),intent(out) :: fNew ! new function evaluation + real(rkind),intent(out) :: stateVecNew(:) ! new state vector + real(rkind),intent(out) :: fluxVecNew(:) ! new flux vector + real(rkind),intent(out) :: resVecNew(:) ! NOTE: qp ! new residual vector + real(rkind),intent(out) :: fNew ! new function evaluation logical(lgt),intent(out) :: converged ! convergence flag integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message @@ -576,31 +576,31 @@ subroutine safeRootfinder(stateVecTrial,rVecscaled,newtStepScaled,stateVecNew,fl USE globalData,only:dNaN ! double precision NaN implicit none ! input - real(dp),intent(in) :: stateVecTrial(:) ! trial state vector - real(dp),intent(in) :: rVecScaled(:) ! scaled residual vector - real(dp),intent(in) :: newtStepScaled(:) ! scaled newton step + real(rkind),intent(in) :: stateVecTrial(:) ! trial state vector + real(rkind),intent(in) :: rVecScaled(:) ! scaled residual vector + real(rkind),intent(in) :: newtStepScaled(:) ! scaled newton step ! output - real(dp),intent(out) :: stateVecNew(:) ! new state vector - real(dp),intent(out) :: fluxVecNew(:) ! new flux vector - real(qp),intent(out) :: resVecNew(:) ! NOTE: qp ! new residual vector - real(dp),intent(out) :: fNew ! new function evaluation + real(rkind),intent(out) :: stateVecNew(:) ! new state vector + real(rkind),intent(out) :: fluxVecNew(:) ! new flux vector + real(rkind),intent(out) :: resVecNew(:) ! NOTE: qp ! new residual vector + real(rkind),intent(out) :: fNew ! new function evaluation logical(lgt),intent(out) :: converged ! convergence flag integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! -------------------------------------------------------------------------------------------------------- ! local variables character(len=256) :: cmessage ! error message of downwind routine - real(dp),parameter :: relTolerance=0.005_dp ! force bi-section if trial is slightly larger than (smaller than) xmin (xmax) - real(dp) :: xTolerance ! relTolerance*(xmax-xmin) - real(dp) :: xInc(nState) ! iteration increment (re-scaled to original units of the state vector) - real(dp) :: rVec(nState) ! residual vector (re-scaled to original units of the state equation) + real(rkind),parameter :: relTolerance=0.005_rkind ! force bi-section if trial is slightly larger than (smaller than) xmin (xmax) + real(rkind) :: xTolerance ! relTolerance*(xmax-xmin) + real(rkind) :: xInc(nState) ! iteration increment (re-scaled to original units of the state vector) + real(rkind) :: rVec(nState) ! residual vector (re-scaled to original units of the state equation) logical(lgt) :: feasible ! feasibility of the solution logical(lgt) :: doBisection ! flag to do the bi-section logical(lgt) :: bracketsDefined ! flag to define if the brackets are defined !integer(i4b) :: iCheck ! check the model state variables (not used) integer(i4b),parameter :: nCheck=100 ! number of times to check the model state variables - real(dp),parameter :: delX=1._dp ! trial increment - !real(dp) :: xIncrement(nState) ! trial increment (not used) + real(rkind),parameter :: delX=1._rkind ! trial increment + !real(rkind) :: xIncrement(nState) ! trial increment (not used) ! -------------------------------------------------------------------------------------------------------- err=0; message='safeRootfinder/' @@ -617,10 +617,10 @@ subroutine safeRootfinder(stateVecTrial,rVecscaled,newtStepScaled,stateVecNew,fl endif ! get the residual vector - rVec = real(rVecScaled, dp)*fScale + rVec = real(rVecScaled, rkind)*real(fScale, rkind) ! update brackets - if(rVec(1)<0._dp)then + if(rVec(1)<0._rkind)then xMin = stateVecTrial(1) else xMax = stateVecTrial(1) @@ -631,7 +631,7 @@ subroutine safeRootfinder(stateVecTrial,rVecscaled,newtStepScaled,stateVecNew,fl ! ***** ! * case 1: the iteration increment is the same sign as the residual vector - if(xInc(1)*rVec(1) > 0._dp)then + if(xInc(1)*rVec(1) > 0._rkind)then ! get brackets if they do not exist if( ieee_is_nan(xMin) .or. ieee_is_nan(xMax) )then @@ -640,7 +640,7 @@ subroutine safeRootfinder(stateVecTrial,rVecscaled,newtStepScaled,stateVecNew,fl endif ! use bi-section - stateVecNew(1) = 0.5_dp*(xMin + xMax) + stateVecNew(1) = 0.5_rkind*(xMin + xMax) ! ***** ! * case 2: the iteration increment is the correct sign @@ -660,7 +660,7 @@ subroutine safeRootfinder(stateVecTrial,rVecscaled,newtStepScaled,stateVecNew,fl if(bracketsDefined)then xTolerance = relTolerance*(xMax-xMin) doBisection = (stateVecNew(1)xMax-xTolerance) - if(doBisection) stateVecNew(1) = 0.5_dp*(xMin+xMax) + if(doBisection) stateVecNew(1) = 0.5_rkind*(xMin+xMax) endif ! evaluate summa @@ -686,17 +686,17 @@ subroutine getBrackets(stateVecTrial,stateVecNew,xMin,xMax,err,message) USE,intrinsic :: ieee_arithmetic,only:ieee_is_nan ! IEEE arithmetic (check NaN) implicit none ! dummies - real(dp),intent(in) :: stateVecTrial(:) ! trial state vector - real(dp),intent(out) :: stateVecNew(:) ! new state vector - real(dp),intent(out) :: xMin,xMax ! constraints + real(rkind),intent(in) :: stateVecTrial(:) ! trial state vector + real(rkind),intent(out) :: stateVecNew(:) ! new state vector + real(rkind),intent(out) :: xMin,xMax ! constraints integer(i4b),intent(inout) :: err ! error code character(*),intent(out) :: message ! error message ! locals integer(i4b) :: iCheck ! check the model state variables integer(i4b),parameter :: nCheck=100 ! number of times to check the model state variables logical(lgt) :: feasible ! feasibility of the solution - real(dp),parameter :: delX=1._dp ! trial increment - real(dp) :: xIncrement(nState) ! trial increment + real(rkind),parameter :: delX=1._rkind ! trial increment + real(rkind) :: xIncrement(nState) ! trial increment ! initialize err=0; message='getBrackets/' @@ -724,7 +724,7 @@ subroutine getBrackets(stateVecTrial,stateVecNew,xMin,xMax,err,message) if(.not.feasible)then; message=trim(message)//'state vector is not feasible'; err=20; return; endif ! update brackets - if(real(resVecNew(1), dp)<0._dp)then + if(real(resVecNew(1), rkind)<0._rkind)then xMin = stateVecNew(1) else xMax = stateVecNew(1) @@ -754,20 +754,20 @@ end subroutine getBrackets subroutine numJacobian(stateVec,dMat,nJac,err,message) implicit none ! dummies - real(dp),intent(in) :: stateVec(:) ! trial state vector - real(dp),intent(in) :: dMat(:) ! diagonal matrix + real(rkind),intent(in) :: stateVec(:) ! trial state vector + real(rkind),intent(in) :: dMat(:) ! diagonal matrix ! output - real(dp),intent(out) :: nJac(:,:) ! numerical Jacobian + real(rkind),intent(out) :: nJac(:,:) ! numerical Jacobian integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! ---------------------------------------------------------------------------------------------------------- ! local character(len=256) :: cmessage ! error message of downwind routine - real(dp),parameter :: dx=1.e-8_dp ! finite difference increment - real(dp),dimension(nState) :: stateVecPerturbed ! perturbed state vector - real(dp),dimension(nState) :: fluxVecInit,fluxVecJac ! flux vector (mized units) - real(qp),dimension(nState) :: resVecInit,resVecJac ! qp ! residual vector (mixed units) - real(dp) :: func ! function value + real(rkind),parameter :: dx=1.e-8_rkind ! finite difference increment + real(rkind),dimension(nState) :: stateVecPerturbed ! perturbed state vector + real(rkind),dimension(nState) :: fluxVecInit,fluxVecJac ! flux vector (mized units) + real(rkind),dimension(nState) :: resVecInit,resVecJac ! qp ! residual vector (mixed units) + real(rkind) :: func ! function value logical(lgt) :: feasible ! flag to denote the feasibility of the solution integer(i4b) :: iJac ! index of row of the Jacobian matrix integer(i4b),parameter :: ixNumFlux=1001 ! named variable for the flux-based form of the numerical Jacobian @@ -802,7 +802,7 @@ subroutine numJacobian(stateVec,dMat,nJac,err,message) ! compute the row of the Jacobian matrix select case(ixNumType) - case(ixNumRes); nJac(:,iJac) = real(resVecJac - resVecInit, kind(dp) )/dx ! Jacobian based on residuals + case(ixNumRes); nJac(:,iJac) = real(resVecJac - resVecInit, kind(rkind) )/dx ! Jacobian based on residuals case(ixNumFlux); nJac(:,iJac) = -dt*(fluxVecJac(:) - fluxVecInit(:))/dx ! Jacobian based on fluxes case default; err=20; message=trim(message)//'Jacobian option not found'; return end select @@ -835,8 +835,8 @@ subroutine testBandMat(check,err,message) integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! local variables - real(dp) :: fullJac(nState,nState) ! full Jacobian matrix - real(dp) :: bandJac(nLeadDim,nState) ! band Jacobian matrix + real(rkind) :: fullJac(nState,nState) ! full Jacobian matrix + real(rkind) :: bandJac(nLeadDim,nState) ! band Jacobian matrix integer(i4b) :: iState,jState ! indices of the state vector character(LEN=256) :: cmessage ! error message of downwind routine ! initialize error control @@ -873,7 +873,7 @@ subroutine testBandMat(check,err,message) if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! (check for errors) ! initialize band matrix - bandJac(:,:) = 0._dp + bandJac(:,:) = 0._rkind ! transfer into the lapack band diagonal structure do iState=1,nState @@ -906,11 +906,11 @@ subroutine eval8summa_wrapper(stateVecNew,fluxVecNew,resVecNew,fNew,feasible,err USE eval8summa_module,only:eval8summa ! simulation of fluxes and residuals given a trial state vector implicit none ! input - real(dp),intent(in) :: stateVecNew(:) ! updated state vector + real(rkind),intent(in) :: stateVecNew(:) ! updated state vector ! output - real(dp),intent(out) :: fluxVecNew(:) ! updated flux vector - real(qp),intent(out) :: resVecNew(:) ! NOTE: qp ! updated residual vector - real(dp),intent(out) :: fNew ! new function value + real(rkind),intent(out) :: fluxVecNew(:) ! updated flux vector + real(rkind),intent(out) :: resVecNew(:) ! NOTE: qp ! updated residual vector + real(rkind),intent(out) :: fNew ! new function value logical(lgt),intent(out) :: feasible ! flag to denote the feasibility of the solution integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message @@ -972,20 +972,20 @@ end subroutine eval8summa_wrapper function checkConv(rVec,xInc,xVec) implicit none ! dummies - real(qp),intent(in) :: rVec(:) ! residual vector (mixed units) - real(dp),intent(in) :: xInc(:) ! iteration increment (mixed units) - real(dp),intent(in) :: xVec(:) ! state vector (mixed units) + real(rkind),intent(in) :: rVec(:) ! residual vector (mixed units) + real(rkind),intent(in) :: xInc(:) ! iteration increment (mixed units) + real(rkind),intent(in) :: xVec(:) ! state vector (mixed units) logical(lgt) :: checkConv ! flag to denote convergence ! locals - real(dp),dimension(mSoil) :: psiScale ! scaling factor for matric head - real(dp),parameter :: xSmall=1.e-0_dp ! a small offset - real(dp),parameter :: scalarTighten=0.1_dp ! scaling factor for the scalar solution - real(dp) :: soilWatbalErr ! error in the soil water balance - real(dp) :: canopy_max ! absolute value of the residual in canopy water (kg m-2) - real(dp),dimension(1) :: energy_max ! maximum absolute value of the energy residual (J m-3) - real(dp),dimension(1) :: liquid_max ! maximum absolute value of the volumetric liquid water content residual (-) - real(dp),dimension(1) :: matric_max ! maximum absolute value of the matric head iteration increment (m) - real(dp) :: aquifer_max ! absolute value of the residual in aquifer water (m) + real(rkind),dimension(mSoil) :: psiScale ! scaling factor for matric head + real(rkind),parameter :: xSmall=1.e-0_rkind ! a small offset + real(rkind),parameter :: scalarTighten=0.1_rkind ! scaling factor for the scalar solution + real(rkind) :: soilWatbalErr ! error in the soil water balance + real(rkind) :: canopy_max ! absolute value of the residual in canopy water (kg m-2) + real(rkind),dimension(1) :: energy_max ! maximum absolute value of the energy residual (J m-3) + real(rkind),dimension(1) :: liquid_max ! maximum absolute value of the volumetric liquid water content residual (-) + real(rkind),dimension(1) :: matric_max ! maximum absolute value of the matric head iteration increment (m) + real(rkind) :: aquifer_max ! absolute value of the residual in aquifer water (m) logical(lgt) :: canopyConv ! flag for canopy water balance convergence logical(lgt) :: watbalConv ! flag for soil water balance convergence logical(lgt) :: liquidConv ! flag for residual convergence @@ -1016,7 +1016,7 @@ function checkConv(rVec,xInc,xVec) ! check convergence based on the canopy water balance if(ixVegHyd/=integerMissing)then - canopy_max = real(abs(rVec(ixVegHyd)), dp)*iden_water + canopy_max = real(abs(rVec(ixVegHyd)), rkind)*iden_water canopyConv = (canopy_max < absConvTol_liquid) ! absolute error in canopy water balance (mm) else canopy_max = realMissing @@ -1025,7 +1025,7 @@ function checkConv(rVec,xInc,xVec) ! check convergence based on the residuals for energy (J m-3) if(size(ixNrgOnly)>0)then - energy_max = real(maxval(abs( rVec(ixNrgOnly) )), dp) + energy_max = real(maxval(abs( rVec(ixNrgOnly) )), rkind) energyConv = (energy_max(1) < absConvTol_energy) ! (based on the residual) else energy_max = realMissing @@ -1034,7 +1034,7 @@ function checkConv(rVec,xInc,xVec) ! check convergence based on the residuals for volumetric liquid water content (-) if(size(ixHydOnly)>0)then - liquid_max = real(maxval(abs( rVec(ixHydOnly) ) ), dp) + liquid_max = real(maxval(abs( rVec(ixHydOnly) ) ), rkind) ! (tighter convergence for the scalar solution) if(scalarSolution)then liquidConv = (liquid_max(1) < absConvTol_liquid*scalarTighten) ! (based on the residual) @@ -1059,7 +1059,7 @@ function checkConv(rVec,xInc,xVec) ! check convergence based on the soil water balance error (m) if(size(ixMatOnly)>0)then - soilWatBalErr = sum( real(rVec(ixMatOnly), dp)*mLayerDepth(nSnow+ixMatricHead) ) + soilWatBalErr = sum( real(rVec(ixMatOnly), rkind)*mLayerDepth(nSnow+ixMatricHead) ) watbalConv = (abs(soilWatbalErr) < absConvTol_liquid) ! absolute error in total soil water balance (m) else soilWatbalErr = realMissing @@ -1068,7 +1068,7 @@ function checkConv(rVec,xInc,xVec) ! check convergence based on the aquifer storage if(ixAqWat/=integerMissing)then - aquifer_max = real(abs(rVec(ixAqWat)), dp)*iden_water + aquifer_max = real(abs(rVec(ixAqWat)), rkind)*iden_water aquiferConv = (aquifer_max < absConvTol_liquid) ! absolute error in aquifer water balance (mm) else aquifer_max = realMissing @@ -1099,25 +1099,25 @@ subroutine imposeConstraints(stateVecTrial,xInc,err,message) USE soil_utils_module,only:crit_soilT ! compute the critical temperature below which ice exists implicit none ! dummies - real(dp),intent(in) :: stateVecTrial(:) ! trial state vector - real(dp),intent(inout) :: xInc(:) ! iteration increment + real(rkind),intent(in) :: stateVecTrial(:) ! trial state vector + real(rkind),intent(inout) :: xInc(:) ! iteration increment integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! ----------------------------------------------------------------------------------------------------- ! temporary variables for model constraints - real(dp) :: cInc ! constrained temperature increment (K) -- simplified bi-section - real(dp) :: xIncFactor ! scaling factor for the iteration increment (-) + real(rkind) :: cInc ! constrained temperature increment (K) -- simplified bi-section + real(rkind) :: xIncFactor ! scaling factor for the iteration increment (-) integer(i4b) :: iMax(1) ! index of maximum temperature - real(dp) :: scalarTemp ! temperature of an individual snow layer (K) - real(dp) :: volFracLiq ! volumetric liquid water content of an individual snow layer (-) + real(rkind) :: scalarTemp ! temperature of an individual snow layer (K) + real(rkind) :: volFracLiq ! volumetric liquid water content of an individual snow layer (-) logical(lgt),dimension(nSnow) :: drainFlag ! flag to denote when drainage exceeds available capacity logical(lgt),dimension(nSoil) :: crosFlag ! flag to denote temperature crossing from unfrozen to frozen (or vice-versa) logical(lgt) :: crosTempVeg ! flag to denoote where temperature crosses the freezing point - real(dp) :: xPsi00 ! matric head after applying the iteration increment (m) - real(dp) :: TcSoil ! critical point when soil begins to freeze (K) - real(dp) :: critDiff ! temperature difference from critical (K) - real(dp),parameter :: epsT=1.e-7_dp ! small interval above/below critical (K) - real(dp),parameter :: zMaxTempIncrement=1._dp ! maximum temperature increment (K) + real(rkind) :: xPsi00 ! matric head after applying the iteration increment (m) + real(rkind) :: TcSoil ! critical point when soil begins to freeze (K) + real(rkind) :: critDiff ! temperature difference from critical (K) + real(rkind),parameter :: epsT=1.e-7_rkind ! small interval above/below critical (K) + real(rkind),parameter :: zMaxTempIncrement=1._rkind ! maximum temperature increment (K) ! indices of model state variables integer(i4b) :: iState ! index of state within a specific variable type integer(i4b) :: ixNrg,ixLiq ! index of energy and mass state variables in full state vector @@ -1180,7 +1180,7 @@ subroutine imposeConstraints(stateVecTrial,xInc,err,message) crosTempVeg = .false. ! initially frozen (T < Tfreeze) - if(critDiff > 0._dp)then + if(critDiff > 0._rkind)then if(xInc(ixVegNrg) > critDiff)then crosTempVeg = .true. cInc = critDiff + epsT ! constrained temperature increment (K) @@ -1209,9 +1209,9 @@ subroutine imposeConstraints(stateVecTrial,xInc,err,message) if(ixVegHyd/=integerMissing)then ! check if new value of storage will be negative - if(stateVecTrial(ixVegHyd)+xInc(ixVegHyd) < 0._dp)then + if(stateVecTrial(ixVegHyd)+xInc(ixVegHyd) < 0._rkind)then ! scale iteration increment - cInc = -0.5_dp*stateVecTrial(ixVegHyd) ! constrained iteration increment (K) -- simplified bi-section + cInc = -0.5_rkind*stateVecTrial(ixVegHyd) ! constrained iteration increment (K) -- simplified bi-section xIncFactor = cInc/xInc(ixVegHyd) ! scaling factor for the iteration increment (-) xInc = xIncFactor*xInc ! new iteration increment end if @@ -1232,7 +1232,7 @@ subroutine imposeConstraints(stateVecTrial,xInc,err,message) iState = ixSnowOnlyNrg(iLayer) if(stateVecTrial(iState) + xInc(iState) > Tfreeze)then ! scale iteration increment - cInc = 0.5_dp*(Tfreeze - stateVecTrial(iState) ) ! constrained temperature increment (K) -- simplified bi-section + cInc = 0.5_rkind*(Tfreeze - stateVecTrial(iState) ) ! constrained temperature increment (K) -- simplified bi-section xIncFactor = cInc/xInc(iState) ! scaling factor for the iteration increment (-) xInc = xIncFactor*xInc end if ! if snow temperature > freezing @@ -1271,7 +1271,7 @@ subroutine imposeConstraints(stateVecTrial,xInc,err,message) ! * check that the iteration increment does not exceed volumetric liquid water content if(-xInc(ixSnowOnlyHyd(iLayer)) > volFracLiq)then drainFlag(iLayer) = .true. - xInc(ixSnowOnlyHyd(iLayer)) = -0.5_dp*volFracLiq + xInc(ixSnowOnlyHyd(iLayer)) = -0.5_rkind*volFracLiq endif end do ! looping through snow layers @@ -1304,7 +1304,7 @@ subroutine imposeConstraints(stateVecTrial,xInc,err,message) critDiff = TcSoil - stateVecTrial(ixNrg) ! * initially frozen (T < TcSoil) - if(critDiff > 0._dp)then + if(critDiff > 0._rkind)then ! (check crossing above zero) if(xInc(ixNrg) > critDiff)then @@ -1334,8 +1334,8 @@ subroutine imposeConstraints(stateVecTrial,xInc,err,message) ixLiq = ixMatOnly(iState) ! - place constraint for matric head - if(xInc(ixLiq) > 1._dp .and. stateVecTrial(ixLiq) > 0._dp)then - xInc(ixLiq) = 1._dp + if(xInc(ixLiq) > 1._rkind .and. stateVecTrial(ixLiq) > 0._rkind)then + xInc(ixLiq) = 1._rkind endif ! if constraining matric head end do ! (loop through soil layers) diff --git a/build/source/engine/sunGeomtry.f90 b/build/source/engine/sunGeomtry.f90 index 28703ad40..b53c605b8 100755 --- a/build/source/engine/sunGeomtry.f90 +++ b/build/source/engine/sunGeomtry.f90 @@ -48,32 +48,32 @@ SUBROUTINE CLRSKY_RAD(MONTH,DAY,HOUR,DT,SLOPE,AZI,LAT,HRI,COSZEN) ! Input variables INTEGER(I4B), INTENT(IN) :: MONTH ! month as mm integer INTEGER(I4B), INTENT(IN) :: DAY ! day of month as dd integer - REAL(DP), INTENT(IN) :: HOUR ! hour of day as real - REAL(DP), INTENT(IN) :: DT ! time step in units of hours - REAL(DP), INTENT(IN) :: SLOPE ! slope of ground surface in degrees - REAL(DP), INTENT(IN) :: AZI ! aspect (azimuth) of ground surface in degrees - REAL(DP), INTENT(IN) :: LAT ! latitude in degrees (negative for southern hemisphere) + real(rkind), INTENT(IN) :: HOUR ! hour of day as real + real(rkind), INTENT(IN) :: DT ! time step in units of hours + real(rkind), INTENT(IN) :: SLOPE ! slope of ground surface in degrees + real(rkind), INTENT(IN) :: AZI ! aspect (azimuth) of ground surface in degrees + real(rkind), INTENT(IN) :: LAT ! latitude in degrees (negative for southern hemisphere) ! Outputs - REAL(DP), INTENT(OUT) :: HRI ! average radiation index over time step DT - REAL(DP), INTENT(OUT) :: COSZEN ! average cosine of the zenith angle over time step DT + real(rkind), INTENT(OUT) :: HRI ! average radiation index over time step DT + real(rkind), INTENT(OUT) :: COSZEN ! average cosine of the zenith angle over time step DT ! Internal - REAL(DP) :: CRAD ! conversion from degrees to radians - REAL(DP) :: YRAD ! conversion from year to radians - REAL(DP) :: T ! time from noon in radians - REAL(DP) :: DELT1 ! time step in radians - REAL(DP) :: SLOPE1 ! slope of ground surface in radians - REAL(DP) :: AZI1 ! aspect (azimuth) of ground surface in radians - REAL(DP) :: LAT1 ! latitude in radians - REAL(DP) :: FJULIAN ! julian date as real - REAL(DP) :: D ! solar declination - REAL(DP) :: LP ! latitude adjusted for non-level surface (= LAT1 for level surface) - REAL(DP) :: TD ! used to calculate sunrise/set - REAL(DP) :: TPI ! used to calculate sunrise/set - REAL(DP) :: TP ! used to calculate sunrise/set - REAL(DP) :: DDT ! used to calculate sunrise/set(= 0 for level surface) - REAL(DP) :: T1 ! first time in time step or sunrise - REAL(DP) :: T2 ! last time in time step or sunset - REAL(DP) :: AUX ! Auxiliary variable used to check whether the sunset/sunrise time calculation can succeed + real(rkind) :: CRAD ! conversion from degrees to radians + real(rkind) :: YRAD ! conversion from year to radians + real(rkind) :: T ! time from noon in radians + real(rkind) :: DELT1 ! time step in radians + real(rkind) :: SLOPE1 ! slope of ground surface in radians + real(rkind) :: AZI1 ! aspect (azimuth) of ground surface in radians + real(rkind) :: LAT1 ! latitude in radians + real(rkind) :: FJULIAN ! julian date as real + real(rkind) :: D ! solar declination + real(rkind) :: LP ! latitude adjusted for non-level surface (= LAT1 for level surface) + real(rkind) :: TD ! used to calculate sunrise/set + real(rkind) :: TPI ! used to calculate sunrise/set + real(rkind) :: TP ! used to calculate sunrise/set + real(rkind) :: DDT ! used to calculate sunrise/set(= 0 for level surface) + real(rkind) :: T1 ! first time in time step or sunrise + real(rkind) :: T2 ! last time in time step or sunset + real(rkind) :: AUX ! Auxiliary variable used to check whether the sunset/sunrise time calculation can succeed ! ---------------------------------------------------------------------------------------- ! CONVERSION FACTORS ! degrees to radians @@ -99,7 +99,7 @@ SUBROUTINE CLRSKY_RAD(MONTH,DAY,HOUR,DT,SLOPE,AZI,LAT,HRI,COSZEN) ! In such cases AUX > 1 or AUX < -1. Fix AUX at (-)1 in those cases, to fix sunrise at 00.00 or 24.00 of the current day (instead of some time before/after the current day) AUX=-TAN(LAT1)*TAN(D) IF(abs(AUX) > 1.) THEN - TD=ACOS(SIGN(1._dp, AUX)) + TD=ACOS(SIGN(1._rkind, AUX)) ELSE TD=ACOS(AUX) END IF @@ -140,7 +140,7 @@ SUBROUTINE CLRSKY_RAD(MONTH,DAY,HOUR,DT,SLOPE,AZI,LAT,HRI,COSZEN) ! In such cases AUX > 1 or AUX < -1. Fix AUX at (-)1 in those cases AUX=-TAN(LAT1)*TAN(D) IF(abs(AUX) > 1.) THEN - TD=ACOS(SIGN(1._dp, AUX)) + TD=ACOS(SIGN(1._rkind, AUX)) ELSE TD=ACOS(AUX) END IF diff --git a/build/source/engine/systemSolv.f90 b/build/source/engine/systemSolv.f90 index aed91981e..616b49a58 100755 --- a/build/source/engine/systemSolv.f90 +++ b/build/source/engine/systemSolv.f90 @@ -98,10 +98,10 @@ module systemSolv_module public::systemSolv ! control parameters -real(dp),parameter :: valueMissing=-9999._dp ! missing value -real(dp),parameter :: verySmall=1.e-12_dp ! a very small number (used to check consistency) -real(dp),parameter :: veryBig=1.e+20_dp ! a very big number -real(dp),parameter :: dx = 1.e-8_dp ! finite difference increment +real(rkind),parameter :: valueMissing=-9999._rkind ! missing value +real(rkind),parameter :: verySmall=1.e-12_rkind ! a very small number (used to check consistency) +real(rkind),parameter :: veryBig=1.e+20_rkind ! a very big number +real(rkind),parameter :: dx = 1.e-8_rkind ! finite difference increment contains @@ -152,7 +152,7 @@ subroutine systemSolv(& ! * dummy variables ! --------------------------------------------------------------------------------------- ! input: model control - real(dp),intent(in) :: dt ! time step (seconds) + real(rkind),intent(in) :: dt ! time step (seconds) integer(i4b),intent(in) :: nState ! total number of state variables logical(lgt),intent(in) :: firstSubStep ! flag to indicate if we are processing the first sub-step logical(lgt),intent(inout) :: firstFluxCall ! flag to define the first flux call @@ -170,12 +170,12 @@ subroutine systemSolv(& type(var_dlength),intent(inout) :: flux_temp ! model fluxes for a local HRU type(var_dlength),intent(in) :: bvar_data ! model variables for the local basin type(model_options),intent(in) :: model_decisions(:) ! model decisions - real(dp),intent(in) :: stateVecInit(:) ! initial state vector (mixed units) + real(rkind),intent(in) :: stateVecInit(:) ! initial state vector (mixed units) ! output: model control type(var_dlength),intent(inout) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables integer(i4b),intent(inout) :: ixSaturation ! index of the lowest saturated layer (NOTE: only computed on the first iteration) - real(dp),intent(out) :: untappedMelt(:) ! un-tapped melt energy (J m-3 s-1) - real(dp),intent(out) :: stateVecTrial(:) ! trial state vector (mixed units) + real(rkind),intent(out) :: untappedMelt(:) ! un-tapped melt energy (J m-3 s-1) + real(rkind),intent(out) :: stateVecTrial(:) ! trial state vector (mixed units) logical(lgt),intent(out) :: reduceCoupledStep ! flag to reduce the length of the coupled step logical(lgt),intent(out) :: tooMuchMelt ! flag to denote that there was too much melt integer(i4b),intent(out) :: niter ! number of iterations taken @@ -193,11 +193,11 @@ subroutine systemSolv(& integer(i4b) :: iState ! index of model state integer(i4b) :: nLeadDim ! length of the leading dimension of the Jacobian matrix (nBands or nState) integer(i4b) :: local_ixGroundwater ! local index for groundwater representation - real(dp) :: bulkDensity ! bulk density of a given layer (kg m-3) - real(dp) :: volEnthalpy ! volumetric enthalpy of a given layer (J m-3) - real(dp),parameter :: tempAccelerate=0.00_dp ! factor to force initial canopy temperatures to be close to air temperature - real(dp),parameter :: xMinCanopyWater=0.0001_dp ! minimum value to initialize canopy water (kg m-2) - real(dp),parameter :: tinyStep=0.000001_dp ! stupidly small time step (s) + real(rkind) :: bulkDensity ! bulk density of a given layer (kg m-3) + real(rkind) :: volEnthalpy ! volumetric enthalpy of a given layer (J m-3) + real(rkind),parameter :: tempAccelerate=0.00_rkind ! factor to force initial canopy temperatures to be close to air temperature + real(rkind),parameter :: xMinCanopyWater=0.0001_rkind ! minimum value to initialize canopy water (kg m-2) + real(rkind),parameter :: tinyStep=0.000001_rkind ! stupidly small time step (s) ! ------------------------------------------------------------------------------------------------------ ! * model solver ! ------------------------------------------------------------------------------------------------------ @@ -207,22 +207,22 @@ subroutine systemSolv(& integer(i4b) :: localMaxIter ! maximum number of iterations (depends on solution type) integer(i4b), parameter :: scalarMaxIter=100 ! maximum number of iterations for the scalar solution type(var_dlength) :: flux_init ! model fluxes at the start of the time step - real(dp),allocatable :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) ! NOTE: allocatable, since not always needed - real(dp) :: stateVecNew(nState) ! new state vector (mixed units) - real(dp) :: fluxVec0(nState) ! flux vector (mixed units) - real(dp) :: fScale(nState) ! characteristic scale of the function evaluations (mixed units) - real(dp) :: xScale(nState) ! characteristic scale of the state vector (mixed units) - real(dp) :: dMat(nState) ! diagonal matrix (excludes flux derivatives) - real(qp) :: sMul(nState) ! NOTE: qp ! multiplier for state vector for the residual calculations - real(qp) :: rVec(nState) ! NOTE: qp ! residual vector - real(dp) :: rAdd(nState) ! additional terms in the residual vector - real(dp) :: fOld,fNew ! function values (-); NOTE: dimensionless because scaled - real(dp) :: xMin,xMax ! state minimum and maximum (mixed units) + real(rkind),allocatable :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) ! NOTE: allocatable, since not always needed + real(rkind) :: stateVecNew(nState) ! new state vector (mixed units) + real(rkind) :: fluxVec0(nState) ! flux vector (mixed units) + real(rkind) :: fScale(nState) ! characteristic scale of the function evaluations (mixed units) + real(rkind) :: xScale(nState) ! characteristic scale of the state vector (mixed units) + real(rkind) :: dMat(nState) ! diagonal matrix (excludes flux derivatives) + real(rkind) :: sMul(nState) ! NOTE: qp ! multiplier for state vector for the residual calculations + real(rkind) :: rVec(nState) ! NOTE: qp ! residual vector + real(rkind) :: rAdd(nState) ! additional terms in the residual vector + real(rkind) :: fOld,fNew ! function values (-); NOTE: dimensionless because scaled + real(rkind) :: xMin,xMax ! state minimum and maximum (mixed units) logical(lgt) :: converged ! convergence flag logical(lgt) :: feasible ! feasibility flag - real(dp) :: resSinkNew(nState) ! additional terms in the residual vector - real(dp) :: fluxVecNew(nState) ! new flux vector - real(qp) :: resVecNew(nState) ! NOTE: qp ! new residual vector + real(rkind) :: resSinkNew(nState) ! additional terms in the residual vector + real(rkind) :: fluxVecNew(nState) ! new flux vector + real(rkind) :: resVecNew(nState) ! NOTE: qp ! new residual vector ! --------------------------------------------------------------------------------------- ! point to variables in the data structures ! --------------------------------------------------------------------------------------- @@ -533,13 +533,13 @@ subroutine systemSolv(& ! ------------------ ! set untapped melt energy to zero - untappedMelt(:) = 0._dp + untappedMelt(:) = 0._rkind ! update temperatures (ensure new temperature is consistent with the fluxes) if(nSnowSoilNrg>0)then do concurrent (iLayer=1:nLayers,ixSnowSoilNrg(iLayer)/=integerMissing) ! (loop through non-missing energy state variables in the snow+soil domain) iState = ixSnowSoilNrg(iLayer) - stateVecTrial(iState) = stateVecInit(iState) + (fluxVecNew(iState)*dt + resSinkNew(iState))/real(sMul(iState), dp) + stateVecTrial(iState) = stateVecInit(iState) + (fluxVecNew(iState)*dt + resSinkNew(iState))/real(sMul(iState), rkind) end do ! looping through non-missing energy state variables in the snow+soil domain endif diff --git a/build/source/engine/tempAdjust.f90 b/build/source/engine/tempAdjust.f90 index d9dc6dd6c..cbc69963e 100755 --- a/build/source/engine/tempAdjust.f90 +++ b/build/source/engine/tempAdjust.f90 @@ -65,7 +65,7 @@ subroutine tempAdjust(& implicit none ! ------------------------------------------------------------------------------------------------ ! input: derived parameters - real(dp),intent(in) :: canopyDepth ! depth of the vegetation canopy (m) + real(rkind),intent(in) :: canopyDepth ! depth of the vegetation canopy (m) ! input/output: data structures type(var_dlength),intent(in) :: mpar_data ! model parameters type(var_dlength),intent(inout) :: prog_data ! model prognostic variables for a local HRU @@ -78,13 +78,13 @@ subroutine tempAdjust(& integer(i4b) :: iTry ! trial index integer(i4b) :: iter ! iteration index integer(i4b),parameter :: maxiter=100 ! maximum number of iterations - real(dp) :: fLiq ! fraction of liquid water (-) - real(dp) :: tempMin,tempMax ! solution constraints for temperature (K) - real(dp) :: nrgMeltFreeze ! energy required to melt-freeze the water to the current canopy temperature (J m-3) - real(dp) :: scalarCanopyWat ! total canopy water (kg m-2) - real(dp) :: scalarCanopyIceOld ! canopy ice content after melt-freeze to the initial temperature (kg m-2) - real(dp),parameter :: resNrgToler=0.1_dp ! tolerance for the energy residual (J m-3) - real(dp) :: f1,f2,x1,x2,fTry,xTry,fDer,xInc ! iteration variables + real(rkind) :: fLiq ! fraction of liquid water (-) + real(rkind) :: tempMin,tempMax ! solution constraints for temperature (K) + real(rkind) :: nrgMeltFreeze ! energy required to melt-freeze the water to the current canopy temperature (J m-3) + real(rkind) :: scalarCanopyWat ! total canopy water (kg m-2) + real(rkind) :: scalarCanopyIceOld ! canopy ice content after melt-freeze to the initial temperature (kg m-2) + real(rkind),parameter :: resNrgToler=0.1_rkind ! tolerance for the energy residual (J m-3) + real(rkind) :: f1,f2,x1,x2,fTry,xTry,fDer,xInc ! iteration variables logical(lgt) :: fBis ! .true. if bisection ! ------------------------------------------------------------------------------------------------------------------------------- ! initialize error control @@ -120,7 +120,7 @@ subroutine tempAdjust(& ! compute the new volumetric ice content ! NOTE: new value; iterations will adjust this value for consistency with temperature - scalarCanopyIceOld = (1._dp - fLiq)*scalarCanopyWat + scalarCanopyIceOld = (1._rkind - fLiq)*scalarCanopyWat ! compute volumetric heat capacity of vegetation (J m-3 K-1) scalarBulkVolHeatCapVeg = specificHeatVeg*maxMassVegetation/canopyDepth + & ! vegetation component @@ -146,14 +146,14 @@ subroutine tempAdjust(& !print*, 'f1, f2 = ', f1, f2 ! ensure that we bracket the root - if(f1*f2 > 0._dp)then + if(f1*f2 > 0._rkind)then xInc = f1 / fDer - x2 = 1._dp + x2 = 1._rkind do iter=1,maxiter ! successively expand limit in order to bracket the root - x2 = x1 + sign(x2,xInc)*2._dp + x2 = x1 + sign(x2,xInc)*2._rkind f2 = resNrgFunc(x2,scalarCanopyTemp,scalarBulkVolHeatCapVeg,snowfrz_scale) - if(f1*f2 < 0._dp)exit + if(f1*f2 < 0._rkind)exit ! check that we bracketed the root ! (should get here in just a couple of expansions) if(iter==maxiter)then @@ -176,8 +176,8 @@ subroutine tempAdjust(& !print*, 'tempMin, tempMax = ', tempMin, tempMax ! get starting trial - xInc = huge(1._dp) - xTry = 0.5_dp*(x1 + x2) + xInc = huge(1._rkind) + xTry = 0.5_rkind*(x1 + x2) fTry = resNrgFunc(xTry,scalarCanopyTemp,scalarBulkVolHeatCapVeg,snowfrz_scale) fDer = resNrgDer(xTry,scalarBulkVolHeatCapVeg,snowfrz_scale) !print*, 'xTry = ', xTry @@ -194,7 +194,7 @@ subroutine tempAdjust(& ! bisect if out of range if(xTry <= tempMin .or. xTry >= tempMax)then - xTry = 0.5_dp*(tempMin + tempMax) ! new value + xTry = 0.5_rkind*(tempMin + tempMax) ! new value fBis = .true. ! value in range; use the newton step @@ -211,7 +211,7 @@ subroutine tempAdjust(& !print*, 'tempMin, tempMax = ', tempMin, tempMax ! update limits - if(fTry < 0._dp)then + if(fTry < 0._rkind)then tempMax = min(xTry,tempMax) else tempMin = max(tempMin,xTry) @@ -232,7 +232,7 @@ subroutine tempAdjust(& if(iter==maxiter)then ! (print out a 1-d x-section) do iTry=1,maxiter - xTry = 1.0_dp*real(iTry,kind(1._dp))/real(maxiter,kind(1._dp)) + 272.5_dp + xTry = 1.0_rkind*real(iTry,kind(1._rkind))/real(maxiter,kind(1._rkind)) + 272.5_rkind fTry = resNrgFunc(xTry,scalarCanopyTemp,scalarBulkVolHeatCapVeg,snowfrz_scale) write(*,'(a,1x,i4,1x,e20.10,1x,4(f20.10,1x))') 'iTry, fTry, xTry = ', iTry, fTry, xTry end do @@ -246,7 +246,7 @@ subroutine tempAdjust(& ! update state variables scalarCanopyTemp = xTry - scalarCanopyIce = (1._dp - fracliquid(xTry,snowfrz_scale))*scalarCanopyWat + scalarCanopyIce = (1._rkind - fracliquid(xTry,snowfrz_scale))*scalarCanopyWat scalarCanopyLiq = scalarCanopyWat - scalarCanopyIce ! end association to variables in the data structure @@ -261,13 +261,13 @@ subroutine tempAdjust(& function resNrgFunc(xTemp,xTemp0,bulkVolHeatCapVeg,snowfrz_scale) ! implicit none - real(dp),intent(in) :: xTemp ! temperature (K) - real(dp),intent(in) :: xTemp0 ! initial temperature (K) - real(dp),intent(in) :: bulkVolHeatCapVeg ! volumetric heat capacity of veg (J m-3 K-1) - real(dp),intent(in) :: snowfrz_scale ! scaling factor in freezing curve (K-1) - real(dp) :: xIce ! canopy ice content (kg m-2) - real(dp) :: resNrgFunc ! residual in energy (J m-3) - xIce = (1._dp - fracliquid(xTemp,snowfrz_scale))*scalarCanopyWat + real(rkind),intent(in) :: xTemp ! temperature (K) + real(rkind),intent(in) :: xTemp0 ! initial temperature (K) + real(rkind),intent(in) :: bulkVolHeatCapVeg ! volumetric heat capacity of veg (J m-3 K-1) + real(rkind),intent(in) :: snowfrz_scale ! scaling factor in freezing curve (K-1) + real(rkind) :: xIce ! canopy ice content (kg m-2) + real(rkind) :: resNrgFunc ! residual in energy (J m-3) + xIce = (1._rkind - fracliquid(xTemp,snowfrz_scale))*scalarCanopyWat resNrgFunc = -bulkVolHeatCapVeg*(xTemp - xTemp0) + LH_fus*(xIce - scalarCanopyIceOld)/canopyDepth + nrgMeltFreeze return end function resNrgFunc @@ -278,11 +278,11 @@ end function resNrgFunc ! ************************************************************************************************ function resNrgDer(xTemp,bulkVolHeatCapVeg,snowfrz_scale) implicit none - real(dp),intent(in) :: xTemp ! temperature (K) - real(dp),intent(in) :: bulkVolHeatCapVeg ! volumetric heat capacity of veg (J m-3 K-1) - real(dp),intent(in) :: snowfrz_scale ! scaling factor in freezing curve (K-1) - real(dp) :: dW_dT ! derivative in canopy ice content w.r.t. temperature (kg m-2 K-1) - real(dp) :: resNrgDer ! derivative (J m-3 K-1) + real(rkind),intent(in) :: xTemp ! temperature (K) + real(rkind),intent(in) :: bulkVolHeatCapVeg ! volumetric heat capacity of veg (J m-3 K-1) + real(rkind),intent(in) :: snowfrz_scale ! scaling factor in freezing curve (K-1) + real(rkind) :: dW_dT ! derivative in canopy ice content w.r.t. temperature (kg m-2 K-1) + real(rkind) :: resNrgDer ! derivative (J m-3 K-1) dW_dT = -scalarCanopyWat*dFracLiq_dTk(xTemp,snowfrz_scale) resNrgDer = bulkVolHeatCapVeg - dW_dT*LH_fus/canopyDepth return diff --git a/build/source/engine/time_utils.f90 b/build/source/engine/time_utils.f90 index f3a7e2656..451dc037f 100755 --- a/build/source/engine/time_utils.f90 +++ b/build/source/engine/time_utils.f90 @@ -46,9 +46,9 @@ subroutine extractTime(refdate,iyyy,im,id,ih,imin,dsec,ih_tz,imin_tz,dsec_tz,err ! dummy variables character(*),intent(in) :: refdate ! units string (time since...) integer(i4b),intent(out) :: iyyy,im,id,ih,imin ! time (year/month/day/hour/minute) - real(dp),intent(out) :: dsec ! seconds + real(rkind),intent(out) :: dsec ! seconds integer(i4b),intent(out) :: ih_tz,imin_tz ! time zone information (hour/minute) - real(dp),intent(out) :: dsec_tz ! time zone information (seconds) + real(rkind),intent(out) :: dsec_tz ! time zone information (seconds) integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! local variables @@ -61,7 +61,7 @@ subroutine extractTime(refdate,iyyy,im,id,ih,imin,dsec,ih_tz,imin_tz,dsec_tz,err ! we'll parse each of these in order. ! Missing ih, imin, dsec, ih_tz, imin_tz and dsec_tz fields will be set to zero without causing an error. - ih=0; imin=0; dsec=0._dp; ih_tz=0; imin_tz=0; dsec_tz=0._dp; + ih=0; imin=0; dsec=0._rkind; ih_tz=0; imin_tz=0; dsec_tz=0._rkind; ! get the length of the string n = len_trim(refdate) @@ -121,8 +121,8 @@ subroutine extractTime(refdate,iyyy,im,id,ih,imin,dsec,ih_tz,imin_tz,dsec_tz,err if(ih > 24) then; err=20; message=trim(message)//'hour > 24'; return; end if if(imin < 0) then; err=20; message=trim(message)//'minute < 0'; return; end if if(imin > 60) then; err=20; message=trim(message)//'minute > 60'; return; end if - if(dsec < 0._dp)then; err=20; message=trim(message)//'second < 0'; return; end if - if(dsec > 60._dp)then; err=20; message=trim(message)//'second > 60'; return; end if + if(dsec < 0._rkind)then; err=20; message=trim(message)//'second < 0'; return; end if + if(dsec > 60._rkind)then; err=20; message=trim(message)//'second > 60'; return; end if ! FIELD 3: Advance to the ih_tz:imin_tz string istart=nsub+1 @@ -149,8 +149,8 @@ subroutine extractTime(refdate,iyyy,im,id,ih,imin,dsec,ih_tz,imin_tz,dsec_tz,err if(ih_tz > 12) then; err=20; message=trim(message)//'time zone hour > 12'; return; end if if(imin_tz < 0) then; err=20; message=trim(message)//'time zone minute < 0'; return; end if if(imin_tz > 60) then; err=20; message=trim(message)//'time zone minute > 60'; return; end if - if(dsec_tz < 0._dp)then; err=20; message=trim(message)//'time zone second < 0'; return; end if - if(dsec_tz > 60._dp)then; err=20; message=trim(message)//'time zone second > 60'; return; end if + if(dsec_tz < 0._rkind)then; err=20; message=trim(message)//'time zone second < 0'; return; end if + if(dsec_tz > 60._rkind)then; err=20; message=trim(message)//'time zone second > 60'; return; end if contains @@ -231,7 +231,7 @@ subroutine extract_hms(substring,cdelim,hh,mm,ss,err,message) ! output integer(i4b),intent(out) :: hh ! hour integer(i4b),intent(out) :: mm ! minute - real(dp) ,intent(out) :: ss ! sec + real(rkind) ,intent(out) :: ss ! sec integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! local variables @@ -272,16 +272,16 @@ subroutine compjulday(iyyy,mm,id,ih,imin,dsec,& ! input ! input variables integer(i4b),intent(in) :: iyyy,mm,id ! year, month, day integer(i4b),intent(in) :: ih,imin ! hour, minute - real(dp),intent(in) :: dsec ! seconds + real(rkind),intent(in) :: dsec ! seconds ! output - real(dp),intent(out) :: juldayss + real(rkind),intent(out) :: juldayss integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! local variables integer(i4b) :: julday ! julian day integer(i4b),parameter :: igreg=15+31*(10+12*1582) !IGREG = 588829 integer(i4b) :: ja,jm,jy - real(dp) :: jfrac ! fraction of julian day + real(rkind) :: jfrac ! fraction of julian day ! initialize errors err=0; message="juldayss" @@ -306,7 +306,7 @@ subroutine compjulday(iyyy,mm,id,ih,imin,dsec,& ! input jfrac = fracDay(ih, imin, dsec) ! and return the julian day, expressed in fraction of a day - juldayss = real(julday,kind(dp)) + jfrac + juldayss = real(julday,kind(rkind)) + jfrac end subroutine compjulday @@ -320,7 +320,7 @@ subroutine compcalday(julday, & !input implicit none ! input variables - real(dp), intent(in) :: julday ! julian day + real(rkind), intent(in) :: julday ! julian day ! output varibles integer(i4b), intent(out) :: iyyy ! year @@ -328,7 +328,7 @@ subroutine compcalday(julday, & !input integer(i4b), intent(out) :: id ! day integer(i4b), intent(out) :: ih ! hour integer(i4b), intent(out) :: imin ! minute - real(dp), intent(out) :: dsec ! seconds + real(rkind), intent(out) :: dsec ! seconds integer(i4b), intent(out) :: err ! error code character(*), intent(out) :: message ! error message @@ -345,14 +345,14 @@ subroutine compcalday(julday, & !input integer(i4b),parameter :: w = 2 integer(i4b),parameter :: b = 274277 integer(i4b),parameter :: c = -38 - real(dp),parameter :: hr_per_day = 24.0_dp - real(dp),parameter :: min_per_hour = 60.0_dp + real(rkind),parameter :: hr_per_day = 24.0_rkind + real(rkind),parameter :: min_per_hour = 60.0_rkind ! local variables integer(i4b) :: f,e,g,h ! various step variables from wikipedia integer(i4b) :: step_1a,step_1b,step_1c,step_1d ! temporary variables for calendar calculations - real(dp) :: frac_day ! fractional day - real(dp) :: remainder ! remainder of modulus operation + real(rkind) :: frac_day ! fractional day + real(rkind) :: remainder ! remainder of modulus operation ! initialize errors err=0; message="compcalday" @@ -402,7 +402,7 @@ end subroutine compcalday ! *************************************************************************************** function elapsedSec(startTime, endTime) integer(i4b),intent(in) :: startTime(8),endTime(8) ! state time and end time - real(dp) :: elapsedSec ! elapsed time in seconds + real(rkind) :: elapsedSec ! elapsed time in seconds ! local variables integer(i4b) :: elapsedDay ! elapsed full days integer(i4b) :: yy ! index of year @@ -411,7 +411,7 @@ function elapsedSec(startTime, endTime) integer(i4b) :: days2(12) = (/31,28,31,30,31,30,31,31,30,31,30,31/) ! calculate the elapsed time smaller than a day - elapsedSec = (endTime(8)-startTime(8))*.001_dp + (endTime(7)-startTime(7)) + (endTime(6)-startTime(6))*secprmin + (endTime(5)-startTime(5))*secprhour + elapsedSec = (endTime(8)-startTime(8))*.001_rkind + (endTime(7)-startTime(7)) + (endTime(6)-startTime(6))*secprmin + (endTime(5)-startTime(5))*secprhour ! check if the run is within the same day otherwise calculate how many days if (endTime(1) > startTime(1) .or. endTime(2) > startTime(2) .or. endTime(3) > startTime(3)) then @@ -440,11 +440,11 @@ end function elapsedSec ! *************************************************************************************** function fracDay(ih, imin, dsec) integer(i4b),intent(in) :: ih,imin ! hour, minute - real(dp),intent(in) :: dsec ! seconds - real(dp) :: fracDay ! fraction of a day + real(rkind),intent(in) :: dsec ! seconds + real(rkind) :: fracDay ! fraction of a day ! local variable - fracDay = (real(ih,kind(dp))*secprhour + real(imin,kind(dp))*secprmin + dsec) / secprday + fracDay = (real(ih,kind(rkind))*secprhour + real(imin,kind(rkind))*secprmin + dsec) / secprday if(ih < 0) fracDay=-fracDay return end function fracDay diff --git a/build/source/engine/updatState.f90 b/build/source/engine/updatState.f90 index d69128152..88bd826df 100755 --- a/build/source/engine/updatState.f90 +++ b/build/source/engine/updatState.f90 @@ -52,13 +52,13 @@ subroutine updateSnow(& USE snow_utils_module,only:fracliquid ! compute volumetric fraction of liquid water implicit none ! input variables - real(dp),intent(in) :: mLayerTemp ! temperature (K) - real(dp),intent(in) :: mLayerTheta ! volume fraction of total water (-) - real(dp),intent(in) :: snowfrz_scale ! scaling parameter for the snow freezing curve (K-1) + real(rkind),intent(in) :: mLayerTemp ! temperature (K) + real(rkind),intent(in) :: mLayerTheta ! volume fraction of total water (-) + real(rkind),intent(in) :: snowfrz_scale ! scaling parameter for the snow freezing curve (K-1) ! output variables - real(dp),intent(out) :: mLayerVolFracLiq ! volumetric fraction of liquid water (-) - real(dp),intent(out) :: mLayerVolFracIce ! volumetric fraction of ice (-) - real(dp),intent(out) :: fLiq ! fraction of liquid water (-) + real(rkind),intent(out) :: mLayerVolFracLiq ! volumetric fraction of liquid water (-) + real(rkind),intent(out) :: mLayerVolFracIce ! volumetric fraction of ice (-) + real(rkind),intent(out) :: fLiq ! fraction of liquid water (-) ! error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message @@ -69,7 +69,7 @@ subroutine updateSnow(& ! compute the volumetric fraction of liquid water and ice (-) fLiq = fracliquid(mLayerTemp,snowfrz_scale) mLayerVolFracLiq = fLiq*mLayerTheta - mLayerVolFracIce = (1._dp - fLiq)*mLayerTheta*(iden_water/iden_ice) + mLayerVolFracIce = (1._rkind - fLiq)*mLayerTheta*(iden_water/iden_ice) !print*, 'mLayerTheta - (mLayerVolFracIce*(iden_ice/iden_water) + mLayerVolFracLiq) = ', mLayerTheta - (mLayerVolFracIce*(iden_ice/iden_water) + mLayerVolFracLiq) !write(*,'(a,1x,4(f20.10,1x))') 'in updateSnow: fLiq, mLayerTheta, mLayerVolFracIce = ', & ! fLiq, mLayerTheta, mLayerVolFracIce @@ -99,25 +99,24 @@ subroutine updateSoil(& USE soil_utils_module,only:matricHead ! compute the matric head based on volumetric liquid water content implicit none ! input variables - real(dp),intent(in) :: mLayerTemp ! estimate of temperature (K) - real(dp),intent(in) :: mLayerMatricHead ! matric head (m) - real(dp),intent(in) :: vGn_alpha ! van Genutchen "alpha" parameter - real(dp),intent(in) :: vGn_n ! van Genutchen "n" parameter - real(dp),intent(in) :: theta_sat ! soil porosity (-) - real(dp),intent(in) :: theta_res ! soil residual volumetric water content (-) - real(dp),intent(in) :: vGn_m ! van Genutchen "m" parameter (-) + real(rkind),intent(in) :: mLayerTemp ! estimate of temperature (K) + real(rkind),intent(in) :: mLayerMatricHead ! matric head (m) + real(rkind),intent(in) :: vGn_alpha ! van Genutchen "alpha" parameter + real(rkind),intent(in) :: vGn_n ! van Genutchen "n" parameter + real(rkind),intent(in) :: theta_sat ! soil porosity (-) + real(rkind),intent(in) :: theta_res ! soil residual volumetric water content (-) + real(rkind),intent(in) :: vGn_m ! van Genutchen "m" parameter (-) ! output variables - real(dp),intent(out) :: mLayerVolFracWat ! fractional volume of total water (-) - real(dp),intent(out) :: mLayerVolFracLiq ! volumetric fraction of liquid water (-) - real(dp),intent(out) :: mLayerVolFracIce ! volumetric fraction of ice (-) + real(rkind),intent(out) :: mLayerVolFracWat ! fractional volume of total water (-) + real(rkind),intent(out) :: mLayerVolFracLiq ! volumetric fraction of liquid water (-) + real(rkind),intent(out) :: mLayerVolFracIce ! volumetric fraction of ice (-) integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! define local variables - real(dp) :: TcSoil ! critical soil temperature when all water is unfrozen (K) - real(dp) :: xConst ! constant in the freezing curve function (m K-1) - real(dp) :: mLayerPsiLiq ! liquid water matric potential (m) - real(dp),parameter :: tinyVal=epsilon(1._dp) ! used in balance check - + real(rkind) :: TcSoil ! critical soil temperature when all water is unfrozen (K) + real(rkind) :: xConst ! constant in the freezing curve function (m K-1) + real(rkind) :: mLayerPsiLiq ! liquid water matric potential (m) + real(rkind),parameter :: tinyVal=epsilon(1._rkind) ! used in balance check ! initialize error control err=0; message="updateSoil/" @@ -138,7 +137,7 @@ subroutine updateSoil(& ! compute the critical soil temperature where all water is unfrozen (K) ! (eq 17 in Dall'Amico 2011) - TcSoil = Tfreeze + min(mLayerMatricHead,0._dp)*gravity*Tfreeze/LH_fus ! (NOTE: J = kg m2 s-2, so LH_fus is in units of m2 s-2) + TcSoil = Tfreeze + min(mLayerMatricHead,0._rkind)*gravity*Tfreeze/LH_fus ! (NOTE: J = kg m2 s-2, so LH_fus is in units of m2 s-2) ! *** compute volumetric fraction of liquid water and ice for partially frozen soil if(mLayerTemp < TcSoil)then ! (check if soil temperature is less than the critical temperature) @@ -159,7 +158,7 @@ subroutine updateSoil(& ! all water is unfrozen mLayerPsiLiq = mLayerMatricHead mLayerVolFracLiq = mLayerVolFracWat - mLayerVolFracIce = 0._dp + mLayerVolFracIce = 0._rkind end if ! (check if soil is partially frozen) diff --git a/build/source/engine/updateVars.f90 b/build/source/engine/updateVars.f90 index c024f1cd2..63f20627f 100755 --- a/build/source/engine/updateVars.f90 +++ b/build/source/engine/updateVars.f90 @@ -135,17 +135,17 @@ subroutine updateVars(& type(var_dlength),intent(inout) :: diag_data ! diagnostic variables for a local HRU type(var_dlength),intent(inout) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables ! output: variables for the vegetation canopy - real(dp),intent(inout) :: scalarCanopyTempTrial ! trial value of canopy temperature (K) - real(dp),intent(inout) :: scalarCanopyWatTrial ! trial value of canopy total water (kg m-2) - real(dp),intent(inout) :: scalarCanopyLiqTrial ! trial value of canopy liquid water (kg m-2) - real(dp),intent(inout) :: scalarCanopyIceTrial ! trial value of canopy ice content (kg m-2) + real(rkind),intent(inout) :: scalarCanopyTempTrial ! trial value of canopy temperature (K) + real(rkind),intent(inout) :: scalarCanopyWatTrial ! trial value of canopy total water (kg m-2) + real(rkind),intent(inout) :: scalarCanopyLiqTrial ! trial value of canopy liquid water (kg m-2) + real(rkind),intent(inout) :: scalarCanopyIceTrial ! trial value of canopy ice content (kg m-2) ! output: variables for the snow-soil domain - real(dp),intent(inout) :: mLayerTempTrial(:) ! trial vector of layer temperature (K) - real(dp),intent(inout) :: mLayerVolFracWatTrial(:) ! trial vector of volumetric total water content (-) - real(dp),intent(inout) :: mLayerVolFracLiqTrial(:) ! trial vector of volumetric liquid water content (-) - real(dp),intent(inout) :: mLayerVolFracIceTrial(:) ! trial vector of volumetric ice water content (-) - real(dp),intent(inout) :: mLayerMatricHeadTrial(:) ! trial vector of total water matric potential (m) - real(dp),intent(inout) :: mLayerMatricHeadLiqTrial(:) ! trial vector of liquid water matric potential (m) + real(rkind),intent(inout) :: mLayerTempTrial(:) ! trial vector of layer temperature (K) + real(rkind),intent(inout) :: mLayerVolFracWatTrial(:) ! trial vector of volumetric total water content (-) + real(rkind),intent(inout) :: mLayerVolFracLiqTrial(:) ! trial vector of volumetric liquid water content (-) + real(rkind),intent(inout) :: mLayerVolFracIceTrial(:) ! trial vector of volumetric ice water content (-) + real(rkind),intent(inout) :: mLayerMatricHeadTrial(:) ! trial vector of total water matric potential (m) + real(rkind),intent(inout) :: mLayerMatricHeadLiqTrial(:) ! trial vector of liquid water matric potential (m) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message @@ -160,29 +160,29 @@ subroutine updateVars(& logical(lgt) :: isCoupled ! .true. if a given variable shared another state variable in the same control volume logical(lgt) :: isNrgState ! .true. if a given variable is an energy state logical(lgt),allocatable :: computedCoupling(:) ! .true. if computed the coupling for a given state variable - real(dp) :: scalarVolFracLiq ! volumetric fraction of liquid water (-) - real(dp) :: scalarVolFracIce ! volumetric fraction of ice (-) - real(dp) :: Tcrit ! critical soil temperature below which ice exists (K) - real(dp) :: xTemp ! temporary temperature (K) - real(dp) :: effSat ! effective saturation (-) - real(dp) :: avPore ! available pore space (-) + real(rkind) :: scalarVolFracLiq ! volumetric fraction of liquid water (-) + real(rkind) :: scalarVolFracIce ! volumetric fraction of ice (-) + real(rkind) :: Tcrit ! critical soil temperature below which ice exists (K) + real(rkind) :: xTemp ! temporary temperature (K) + real(rkind) :: effSat ! effective saturation (-) + real(rkind) :: avPore ! available pore space (-) character(len=256) :: cMessage ! error message of downwind routine logical(lgt),parameter :: printFlag=.false. ! flag to turn on printing ! iterative solution for temperature - real(dp) :: meltNrg ! energy for melt+freeze (J m-3) - real(dp) :: residual ! residual in the energy equation (J m-3) - real(dp) :: derivative ! derivative in the energy equation (J m-3 K-1) - real(dp) :: tempInc ! iteration increment (K) + real(rkind) :: meltNrg ! energy for melt+freeze (J m-3) + real(rkind) :: residual ! residual in the energy equation (J m-3) + real(rkind) :: derivative ! derivative in the energy equation (J m-3 K-1) + real(rkind) :: tempInc ! iteration increment (K) integer(i4b) :: iter ! iteration index integer(i4b) :: niter ! number of iterations integer(i4b),parameter :: maxiter=100 ! maximum number of iterations - real(dp),parameter :: nrgConvTol=1.e-4_dp ! convergence tolerance for energy (J m-3) - real(dp),parameter :: tempConvTol=1.e-6_dp ! convergence tolerance for temperature (K) - real(dp) :: critDiff ! temperature difference from critical (K) - real(dp) :: tempMin ! minimum bracket for temperature (K) - real(dp) :: tempMax ! maximum bracket for temperature (K) + real(rkind),parameter :: nrgConvTol=1.e-4_rkind ! convergence tolerance for energy (J m-3) + real(rkind),parameter :: tempConvTol=1.e-6_rkind ! convergence tolerance for temperature (K) + real(rkind) :: critDiff ! temperature difference from critical (K) + real(rkind) :: tempMin ! minimum bracket for temperature (K) + real(rkind) :: tempMax ! maximum bracket for temperature (K) logical(lgt) :: bFlag ! flag to denote that iteration increment was constrained using bi-section - real(dp),parameter :: epsT=1.e-7_dp ! small interval above/below critical temperature (K) + real(rkind),parameter :: epsT=1.e-7_rkind ! small interval above/below critical temperature (K) ! -------------------------------------------------------------------------------------------------------------------------------- ! make association with variables in the data structures associate(& @@ -334,7 +334,7 @@ subroutine updateVars(& select case( ixStateType(ixFullVector) ) ! --> update the total water from the liquid water matric potential case(iname_lmpLayer) - effSat = volFracLiq(mLayerMatricHeadLiqTrial(ixControlIndex),vGn_alpha(ixControlIndex),0._dp,1._dp,vGn_n(ixControlIndex),vGn_m(ixControlIndex)) ! effective saturation + effSat = volFracLiq(mLayerMatricHeadLiqTrial(ixControlIndex),vGn_alpha(ixControlIndex),0._rkind,1._rkind,vGn_n(ixControlIndex),vGn_m(ixControlIndex)) ! effective saturation avPore = theta_sat(ixControlIndex) - mLayerVolFracIceTrial(iLayer) - theta_res(ixControlIndex) ! available pore space mLayerVolFracLiqTrial(iLayer) = effSat*avPore + theta_res(ixControlIndex) mLayerVolFracWatTrial(iLayer) = mLayerVolFracLiqTrial(iLayer) + mLayerVolFracIceTrial(iLayer) ! no volume expansion @@ -368,8 +368,8 @@ subroutine updateVars(& ! define brackets for the root ! NOTE: start with an enormous range; updated quickly in the iterations - tempMin = xTemp - 10._dp - tempMax = xTemp + 10._dp + tempMin = xTemp - 10._rkind + tempMax = xTemp + 10._rkind ! get iterations (set to maximum iterations if adjusting the temperature) niter = merge(maxiter, 1, do_adjustTemp) @@ -379,7 +379,7 @@ subroutine updateVars(& ! restrict temperature if(xTemp <= tempMin .or. xTemp >= tempMax)then - xTemp = 0.5_dp*(tempMin + tempMax) ! new value + xTemp = 0.5_rkind*(tempMin + tempMax) ! new value bFlag = .true. else bFlag = .false. @@ -394,7 +394,7 @@ subroutine updateVars(& ! NOTE 2: for case "iname_lmpLayer", dVolTot_dPsi0 = dVolLiq_dPsi if(ixDomainType==iname_soil)then select case( ixStateType(ixFullVector) ) - case(iname_lmpLayer); dVolTot_dPsi0(ixControlIndex) = dTheta_dPsi(mLayerMatricHeadLiqTrial(ixControlIndex),vGn_alpha(ixControlIndex),0._dp,1._dp,vGn_n(ixControlIndex),vGn_m(ixControlIndex))*avPore + case(iname_lmpLayer); dVolTot_dPsi0(ixControlIndex) = dTheta_dPsi(mLayerMatricHeadLiqTrial(ixControlIndex),vGn_alpha(ixControlIndex),0._rkind,1._rkind,vGn_n(ixControlIndex),vGn_m(ixControlIndex))*avPore case default; dVolTot_dPsi0(ixControlIndex) = dTheta_dPsi(mLayerMatricHeadTrial(ixControlIndex),vGn_alpha(ixControlIndex),theta_res(ixControlIndex),theta_sat(ixControlIndex),vGn_n(ixControlIndex),vGn_m(ixControlIndex)) end select endif @@ -412,8 +412,8 @@ subroutine updateVars(& ! --> unfrozen: no dependence of liquid water on temperature else select case(ixDomainType) - case(iname_veg); dTheta_dTkCanopy = 0._dp - case(iname_snow, iname_soil); mLayerdTheta_dTk(iLayer) = 0._dp + case(iname_veg); dTheta_dTkCanopy = 0._rkind + case(iname_snow, iname_soil); mLayerdTheta_dTk(iLayer) = 0._rkind case default; err=20; message=trim(message)//'expect case to be iname_veg, iname_snow, iname_soil'; return end select ! domain type endif @@ -461,7 +461,7 @@ subroutine updateVars(& ! compute mass of water on the canopy ! NOTE: possibilities for speed-up here scalarCanopyLiqTrial = scalarFracLiqVeg *scalarCanopyWatTrial - scalarCanopyIceTrial = (1._dp - scalarFracLiqVeg)*scalarCanopyWatTrial + scalarCanopyIceTrial = (1._rkind - scalarFracLiqVeg)*scalarCanopyWatTrial ! *** snow layers case(iname_snow) @@ -565,7 +565,7 @@ subroutine updateVars(& endif ! update bracket - if(residual < 0._dp)then + if(residual < 0._rkind)then tempMax = min(xTemp,tempMax) else tempMin = max(tempMin,xTemp) @@ -583,7 +583,7 @@ subroutine updateVars(& ! add constraints for snow temperature if(ixDomainType==iname_veg .or. ixDomainType==iname_snow)then - if(tempInc > Tcrit - xTemp) tempInc=(Tcrit - xTemp)*0.5_dp ! simple bi-section method + if(tempInc > Tcrit - xTemp) tempInc=(Tcrit - xTemp)*0.5_rkind ! simple bi-section method endif ! if the domain is vegetation or snow ! deal with the discontinuity between partially frozen and unfrozen soil @@ -591,7 +591,7 @@ subroutine updateVars(& ! difference from the temperature below which ice exists critDiff = Tcrit - xTemp ! --> initially frozen (T < Tcrit) - if(critDiff > 0._dp)then + if(critDiff > 0._rkind)then if(tempInc > critDiff) tempInc = critDiff + epsT ! set iteration increment to slightly above critical temperature ! --> initially unfrozen (T > Tcrit) else @@ -643,8 +643,8 @@ subroutine updateVars(& if(.not.isNrgState .and. .not.isCoupled)then ! derivatives relating liquid water matric potential to total water matric potential and temperature - dPsiLiq_dPsi0(ixControlIndex) = 1._dp ! exact correspondence (psiLiq=psi0) - dPsiLiq_dTemp(ixControlIndex) = 0._dp ! no relationship between liquid water matric potential and temperature + dPsiLiq_dPsi0(ixControlIndex) = 1._rkind ! exact correspondence (psiLiq=psi0) + dPsiLiq_dTemp(ixControlIndex) = 0._rkind ! no relationship between liquid water matric potential and temperature ! case of energy state or coupled solution else @@ -699,17 +699,17 @@ subroutine xTempSolve(& derivative ) ! intent(out) : derivative (J m-3 K-1) implicit none ! input: constant over iterations - real(dp),intent(in) :: meltNrg ! energy for melt+freeze (J m-3) - real(dp),intent(in) :: heatCap ! volumetric heat capacity (J m-3 K-1) - real(dp),intent(in) :: tempInit ! initial temperature (K) - real(dp),intent(in) :: volFracIceInit ! initial volumetric fraction of ice (-) + real(rkind),intent(in) :: meltNrg ! energy for melt+freeze (J m-3) + real(rkind),intent(in) :: heatCap ! volumetric heat capacity (J m-3 K-1) + real(rkind),intent(in) :: tempInit ! initial temperature (K) + real(rkind),intent(in) :: volFracIceInit ! initial volumetric fraction of ice (-) ! input-output: trial values - real(dp),intent(inout) :: xTemp ! trial value for temperature - real(dp),intent(in) :: dLiq_dT ! derivative in liquid water content w.r.t. temperature (K-1) - real(dp),intent(in) :: volFracIceTrial ! trial value for the volumetric fraction of ice (-) + real(rkind),intent(inout) :: xTemp ! trial value for temperature + real(rkind),intent(in) :: dLiq_dT ! derivative in liquid water content w.r.t. temperature (K-1) + real(rkind),intent(in) :: volFracIceTrial ! trial value for the volumetric fraction of ice (-) ! output: residual and derivative - real(dp),intent(out) :: residual ! residual (J m-3) - real(dp),intent(out) :: derivative ! derivative (J m-3 K-1) + real(rkind),intent(out) :: residual ! residual (J m-3) + real(rkind),intent(out) :: derivative ! derivative (J m-3 K-1) ! subroutine starts here residual = -heatCap*(xTemp - tempInit) + meltNrg*(volFracIceTrial - volFracIceInit) ! J m-3 derivative = heatCap + LH_fus*iden_water*dLiq_dT ! J m-3 K-1 diff --git a/build/source/engine/varSubstep.f90 b/build/source/engine/varSubstep.f90 index f82882d94..c5f5cea08 100755 --- a/build/source/engine/varSubstep.f90 +++ b/build/source/engine/varSubstep.f90 @@ -73,7 +73,7 @@ module varSubstep_module public::varSubstep ! algorithmic parameters -real(dp),parameter :: verySmall=1.e-6_dp ! used as an additive constant to check if substantial difference among real numbers +real(rkind),parameter :: verySmall=1.e-6_rkind ! used as an additive constant to check if substantial difference among real numbers contains @@ -130,9 +130,9 @@ subroutine varSubstep(& ! * dummy variables ! --------------------------------------------------------------------------------------- ! input: model control - real(dp),intent(in) :: dt ! time step (seconds) - real(dp),intent(in) :: dtInit ! initial time step (seconds) - real(dp),intent(in) :: dt_min ! minimum time step (seconds) + real(rkind),intent(in) :: dt ! time step (seconds) + real(rkind),intent(in) :: dtInit ! initial time step (seconds) + real(rkind),intent(in) :: dt_min ! minimum time step (seconds) integer(i4b),intent(in) :: nState ! total number of state variables logical(lgt),intent(in) :: doAdjustTemp ! flag to indicate if we adjust the temperature logical(lgt),intent(in) :: firstSubStep ! flag to indicate if we are processing the first sub-step @@ -156,7 +156,7 @@ subroutine varSubstep(& type(var_dlength),intent(in) :: bvar_data ! model variables for the local basin ! output: model control integer(i4b),intent(inout) :: ixSaturation ! index of the lowest saturated layer (NOTE: only computed on the first iteration) - real(dp),intent(out) :: dtMultiplier ! substep multiplier (-) + real(rkind),intent(out) :: dtMultiplier ! substep multiplier (-) integer(i4b),intent(out) :: nSubsteps ! number of substeps taken for a given split logical(lgt),intent(out) :: failedMinimumStep ! flag to denote success of substepping for a given split logical(lgt),intent(out) :: reduceCoupledStep ! flag to denote need to reduce the length of the coupled step @@ -174,24 +174,24 @@ subroutine varSubstep(& integer(i4b) :: ixLayer ! index in a given domain integer(i4b), dimension(1) :: ixMin,ixMax ! bounds of a given flux vector ! time stepping - real(dp) :: dtSum ! sum of time from successful steps (seconds) - real(dp) :: dt_wght ! weight given to a given flux calculation - real(dp) :: dtSubstep ! length of a substep (s) + real(rkind) :: dtSum ! sum of time from successful steps (seconds) + real(rkind) :: dt_wght ! weight given to a given flux calculation + real(rkind) :: dtSubstep ! length of a substep (s) ! adaptive sub-stepping for the explicit solution logical(lgt) :: failedSubstep ! flag to denote success of substepping for a given split - real(dp),parameter :: safety=0.85_dp ! safety factor in adaptive sub-stepping - real(dp),parameter :: reduceMin=0.1_dp ! mimimum factor that time step is reduced - real(dp),parameter :: increaseMax=4.0_dp ! maximum factor that time step is increased + real(rkind),parameter :: safety=0.85_rkind ! safety factor in adaptive sub-stepping + real(rkind),parameter :: reduceMin=0.1_rkind ! mimimum factor that time step is reduced + real(rkind),parameter :: increaseMax=4.0_rkind ! maximum factor that time step is increased ! adaptive sub-stepping for the implicit solution integer(i4b) :: niter ! number of iterations taken integer(i4b),parameter :: n_inc=5 ! minimum number of iterations to increase time step integer(i4b),parameter :: n_dec=15 ! maximum number of iterations to decrease time step - real(dp),parameter :: F_inc = 1.25_dp ! factor used to increase time step - real(dp),parameter :: F_dec = 0.90_dp ! factor used to decrease time step + real(rkind),parameter :: F_inc = 1.25_rkind ! factor used to increase time step + real(rkind),parameter :: F_dec = 0.90_rkind ! factor used to decrease time step ! state and flux vectors - real(dp) :: untappedMelt(nState) ! un-tapped melt energy (J m-3 s-1) - real(dp) :: stateVecInit(nState) ! initial state vector (mixed units) - real(dp) :: stateVecTrial(nState) ! trial state vector (mixed units) + real(rkind) :: untappedMelt(nState) ! un-tapped melt energy (J m-3 s-1) + real(rkind) :: stateVecInit(nState) ! initial state vector (mixed units) + real(rkind) :: stateVecTrial(nState) ! trial state vector (mixed units) type(var_dlength) :: flux_temp ! temporary model fluxes ! flags logical(lgt) :: firstSplitOper ! flag to indicate if we are processing the first flux call in a splitting operation @@ -199,11 +199,11 @@ subroutine varSubstep(& logical(lgt) :: waterBalanceError ! flag to denote that there is a water balance error logical(lgt) :: nrgFluxModified ! flag to denote that the energy fluxes were modified ! energy fluxes - real(dp) :: sumCanopyEvaporation ! sum of canopy evaporation/condensation (kg m-2 s-1) - real(dp) :: sumLatHeatCanopyEvap ! sum of latent heat flux for evaporation from the canopy to the canopy air space (W m-2) - real(dp) :: sumSenHeatCanopy ! sum of sensible heat flux from the canopy to the canopy air space (W m-2) - real(dp) :: sumSoilCompress - real(dp),allocatable :: sumLayerCompress(:) + real(rkind) :: sumCanopyEvaporation ! sum of canopy evaporation/condensation (kg m-2 s-1) + real(rkind) :: sumLatHeatCanopyEvap ! sum of latent heat flux for evaporation from the canopy to the canopy air space (W m-2) + real(rkind) :: sumSenHeatCanopy ! sum of sensible heat flux from the canopy to the canopy air space (W m-2) + real(rkind) :: sumSoilCompress + real(rkind),allocatable :: sumLayerCompress(:) ! --------------------------------------------------------------------------------------- ! point to variables in the data structures ! --------------------------------------------------------------------------------------- @@ -255,17 +255,17 @@ subroutine varSubstep(& end do ! initialize the total energy fluxes (modified in updateProg) - sumCanopyEvaporation = 0._dp ! canopy evaporation/condensation (kg m-2 s-1) - sumLatHeatCanopyEvap = 0._dp ! latent heat flux for evaporation from the canopy to the canopy air space (W m-2) - sumSenHeatCanopy = 0._dp ! sensible heat flux from the canopy to the canopy air space (W m-2) - sumSoilCompress = 0._dp ! total soil compression - allocate(sumLayerCompress(nSoil)); sumLayerCompress = 0._dp ! soil compression by layer + sumCanopyEvaporation = 0._rkind ! canopy evaporation/condensation (kg m-2 s-1) + sumLatHeatCanopyEvap = 0._rkind ! latent heat flux for evaporation from the canopy to the canopy air space (W m-2) + sumSenHeatCanopy = 0._rkind ! sensible heat flux from the canopy to the canopy air space (W m-2) + sumSoilCompress = 0._rkind ! total soil compression + allocate(sumLayerCompress(nSoil)); sumLayerCompress = 0._rkind ! soil compression by layer ! define the first flux call in a splitting operation firstSplitOper = (.not.scalarSolution .or. iStateSplit==1) ! initialize subStep - dtSum = 0._dp ! keep track of the portion of the time step that is completed + dtSum = 0._rkind ! keep track of the portion of the time step that is completed nSubsteps = 0 ! loop through substeps @@ -351,7 +351,7 @@ subroutine varSubstep(& ! reduce step based on failure if(failedSubstep)then err=0; message='varSubstep/' ! recover from failed convergence - dtMultiplier = 0.5_dp ! system failure: step halving + dtMultiplier = 0.5_rkind ! system failure: step halving else ! ** implicit Euler: adjust step length based on iteration count @@ -360,7 +360,7 @@ subroutine varSubstep(& elseif(niter>n_dec)then dtMultiplier = F_dec else - dtMultiplier = 1._dp + dtMultiplier = 1._rkind endif endif ! switch between failure and success @@ -420,7 +420,7 @@ subroutine varSubstep(& ! modify step err=0 ! error recovery - dtSubstep = dtSubstep/2._dp + dtSubstep = dtSubstep/2._rkind ! check minimum: fail minimum step if there is an error in the update if(dtSubstep next, remove canopy evaporation -- put the unsatisfied evap into sensible heat canopyBalance1 = canopyBalance1 + scalarCanopyEvaporation*dt - if(canopyBalance1 < 0._dp)then + if(canopyBalance1 < 0._rkind)then ! * get superfluous water and energy superflousWat = -canopyBalance1/dt ! kg m-2 s-1 superflousNrg = superflousWat*LH_vap ! W m-2 (J m-2 s-1) ! * update fluxes and states - canopyBalance1 = 0._dp + canopyBalance1 = 0._rkind scalarCanopyEvaporation = scalarCanopyEvaporation + superflousWat scalarLatHeatCanopyEvap = scalarLatHeatCanopyEvap + superflousNrg scalarSenHeatCanopy = scalarSenHeatCanopy - superflousNrg @@ -766,9 +766,9 @@ subroutine updateProg(dt,nSnow,nSoil,nLayers,doAdjustTemp,computeVegFlux,untappe ! --> next, remove canopy drainage canopyBalance1 = canopyBalance1 - scalarCanopyLiqDrainage*dt - if(canopyBalance1 < 0._dp)then + if(canopyBalance1 < 0._rkind)then superflousWat = -canopyBalance1/dt ! kg m-2 s-1 - canopyBalance1 = 0._dp + canopyBalance1 = 0._rkind scalarCanopyLiqDrainage = scalarCanopyLiqDrainage + superflousWat endif @@ -795,7 +795,7 @@ subroutine updateProg(dt,nSnow,nSoil,nLayers,doAdjustTemp,computeVegFlux,untappe !write(*,'(a,1x,f20.10)') 'scalarCanopyEvaporation*dt = ', scalarCanopyEvaporation*dt !write(*,'(a,1x,f20.10)') 'scalarThroughfallRain*dt = ', scalarThroughfallRain*dt !write(*,'(a,1x,f20.10)') 'liqError = ', liqError - if(abs(liqError) > absConvTol_liquid*10._dp)then ! *10 because of precision issues + if(abs(liqError) > absConvTol_liquid*10._rkind)then ! *10 because of precision issues waterBalanceError = .true. return endif ! if there is a water balance error @@ -810,7 +810,7 @@ subroutine updateProg(dt,nSnow,nSoil,nLayers,doAdjustTemp,computeVegFlux,untappe baseSink = sum(mLayerBaseflow)*dt ! m s-1 --> m compSink = sum(mLayerCompress(1:nSoil) * mLayerDepth(nSnow+1:nLayers) ) ! dimensionless --> m liqError = soilBalance1 - (soilBalance0 + vertFlux + tranSink - baseSink - compSink) - if(abs(liqError) > absConvTol_liquid*10._dp)then ! *10 because of precision issues + if(abs(liqError) > absConvTol_liquid*10._rkind)then ! *10 because of precision issues !write(*,'(a,1x,f20.10)') 'dt = ', dt !write(*,'(a,1x,f20.10)') 'soilBalance0 = ', soilBalance0 !write(*,'(a,1x,f20.10)') 'soilBalance1 = ', soilBalance1 @@ -870,15 +870,15 @@ subroutine updateProg(dt,nSnow,nSoil,nLayers,doAdjustTemp,computeVegFlux,untappe ! *** ice ! --> check if we removed too much water - if(scalarCanopyIceTrial < 0._dp .or. any(mLayerVolFracIceTrial < 0._dp) )then + if(scalarCanopyIceTrial < 0._rkind .or. any(mLayerVolFracIceTrial < 0._rkind) )then ! ** ! canopy within numerical precision - if(scalarCanopyIceTrial < 0._dp)then + if(scalarCanopyIceTrial < 0._rkind)then if(scalarCanopyIceTrial > -verySmall)then scalarCanopyLiqTrial = scalarCanopyLiqTrial - scalarCanopyIceTrial - scalarCanopyIceTrial = 0._dp + scalarCanopyIceTrial = 0._rkind ! encountered an inconsistency: spit the dummy else @@ -897,11 +897,11 @@ subroutine updateProg(dt,nSnow,nSoil,nLayers,doAdjustTemp,computeVegFlux,untappe do iState=1,size(mLayerVolFracIceTrial) ! snow layer within numerical precision - if(mLayerVolFracIceTrial(iState) < 0._dp)then + if(mLayerVolFracIceTrial(iState) < 0._rkind)then if(mLayerVolFracIceTrial(iState) > -verySmall)then mLayerVolFracLiqTrial(iState) = mLayerVolFracLiqTrial(iState) - mLayerVolFracIceTrial(iState) - mLayerVolFracIceTrial(iState) = 0._dp + mLayerVolFracIceTrial(iState) = 0._rkind ! encountered an inconsistency: spit the dummy else @@ -924,15 +924,15 @@ subroutine updateProg(dt,nSnow,nSoil,nLayers,doAdjustTemp,computeVegFlux,untappe ! *** liquid water ! --> check if we removed too much water - if(scalarCanopyLiqTrial < 0._dp .or. any(mLayerVolFracLiqTrial < 0._dp) )then + if(scalarCanopyLiqTrial < 0._rkind .or. any(mLayerVolFracLiqTrial < 0._rkind) )then ! ** ! canopy within numerical precision - if(scalarCanopyLiqTrial < 0._dp)then + if(scalarCanopyLiqTrial < 0._rkind)then if(scalarCanopyLiqTrial > -verySmall)then scalarCanopyIceTrial = scalarCanopyIceTrial - scalarCanopyLiqTrial - scalarCanopyLiqTrial = 0._dp + scalarCanopyLiqTrial = 0._rkind ! encountered an inconsistency: spit the dummy else @@ -951,11 +951,11 @@ subroutine updateProg(dt,nSnow,nSoil,nLayers,doAdjustTemp,computeVegFlux,untappe do iState=1,size(mLayerVolFracLiqTrial) ! snow layer within numerical precision - if(mLayerVolFracLiqTrial(iState) < 0._dp)then + if(mLayerVolFracLiqTrial(iState) < 0._rkind)then if(mLayerVolFracLiqTrial(iState) > -verySmall)then mLayerVolFracIceTrial(iState) = mLayerVolFracIceTrial(iState) - mLayerVolFracLiqTrial(iState) - mLayerVolFracLiqTrial(iState) = 0._dp + mLayerVolFracLiqTrial(iState) = 0._rkind ! encountered an inconsistency: spit the dummy else diff --git a/build/source/engine/var_derive.f90 b/build/source/engine/var_derive.f90 index 8227b0407..c60898870 100755 --- a/build/source/engine/var_derive.f90 +++ b/build/source/engine/var_derive.f90 @@ -117,7 +117,7 @@ subroutine calcHeight(& ! loop through layers do iLayer=1,nLayers ! compute the height at the layer midpoint - mLayerHeight(iLayer) = iLayerHeight(iLayer-1) + mLayerDepth(iLayer)/2._dp + mLayerHeight(iLayer) = iLayerHeight(iLayer-1) + mLayerDepth(iLayer)/2._rkind ! compute the height at layer interfaces iLayerHeight(iLayer) = iLayerHeight(iLayer-1) + mLayerDepth(iLayer) end do ! (looping through layers) @@ -149,10 +149,10 @@ subroutine rootDensty(mpar_data,indx_data,prog_data,diag_data,err,message) character(*),intent(out) :: message ! error message ! declare local variables integer(i4b) :: iLayer ! loop through layers - real(dp) :: fracRootLower ! fraction of the rooting depth at the lower interface - real(dp) :: fracRootUpper ! fraction of the rooting depth at the upper interface - real(dp), parameter :: rootTolerance = 0.05_dp ! tolerance for error in doubleExp rooting option - real(dp) :: error ! machine precision error in rooting distribution + real(rkind) :: fracRootLower ! fraction of the rooting depth at the lower interface + real(rkind) :: fracRootUpper ! fraction of the rooting depth at the upper interface + real(rkind), parameter :: rootTolerance = 0.05_rkind ! tolerance for error in doubleExp rooting option + real(rkind) :: error ! machine precision error in rooting distribution ! initialize error control err=0; message='rootDensty/' @@ -192,16 +192,16 @@ subroutine rootDensty(mpar_data,indx_data,prog_data,diag_data,err,message) if(iLayerHeight(iLayer-1)1._dp) fracRootUpper=1._dp + if(fracRootUpper>1._rkind) fracRootUpper=1._rkind ! compute the root density mLayerRootDensity(iLayer-nSnow) = fracRootUpper**rootDistExp - fracRootLower**rootDistExp else - mLayerRootDensity(iLayer-nSnow) = 0._dp + mLayerRootDensity(iLayer-nSnow) = 0._rkind end if !write(*,'(a,10(f11.5,1x))') 'mLayerRootDensity(iLayer-nSnow), fracRootUpper, fracRootLower = ', & ! mLayerRootDensity(iLayer-nSnow), fracRootUpper, fracRootLower @@ -209,8 +209,8 @@ subroutine rootDensty(mpar_data,indx_data,prog_data,diag_data,err,message) ! ** option 2: double expoential profile of Zeng et al. (JHM 2001) case(doubleExp) ! compute the cumulative fraction of roots at the top and bottom of the layer - fracRootLower = 1._dp - 0.5_dp*(exp(-iLayerHeight(iLayer-1)*rootScaleFactor1) + exp(-iLayerHeight(iLayer-1)*rootScaleFactor2) ) - fracRootUpper = 1._dp - 0.5_dp*(exp(-iLayerHeight(iLayer )*rootScaleFactor1) + exp(-iLayerHeight(iLayer )*rootScaleFactor2) ) + fracRootLower = 1._rkind - 0.5_rkind*(exp(-iLayerHeight(iLayer-1)*rootScaleFactor1) + exp(-iLayerHeight(iLayer-1)*rootScaleFactor2) ) + fracRootUpper = 1._rkind - 0.5_rkind*(exp(-iLayerHeight(iLayer )*rootScaleFactor1) + exp(-iLayerHeight(iLayer )*rootScaleFactor2) ) ! compute the root density mLayerRootDensity(iLayer-nSnow) = fracRootUpper - fracRootLower !write(*,'(a,10(f11.5,1x))') 'mLayerRootDensity(iLayer-nSnow), fracRootUpper, fracRootLower = ', & @@ -225,26 +225,26 @@ subroutine rootDensty(mpar_data,indx_data,prog_data,diag_data,err,message) ! check that root density is within some reaosnable version of machine tolerance ! This is the case when root density is greater than 1. Can only happen with powerLaw option. - error = sum(mLayerRootDensity) - 1._dp - if (error > 2._dp*epsilon(rootingDepth)) then + error = sum(mLayerRootDensity) - 1._rkind + if (error > 2._rkind*epsilon(rootingDepth)) then message=trim(message)//'problem with the root density calaculation' err=20; return else - mLayerRootDensity = mLayerRootDensity - error/real(nSoil,kind(dp)) + mLayerRootDensity = mLayerRootDensity - error/real(nSoil,kind(rkind)) end if ! compute fraction of roots in the aquifer - if(sum(mLayerRootDensity) < 1._dp)then - scalarAquiferRootFrac = 1._dp - sum(mLayerRootDensity) + if(sum(mLayerRootDensity) < 1._rkind)then + scalarAquiferRootFrac = 1._rkind - sum(mLayerRootDensity) else - scalarAquiferRootFrac = 0._dp + scalarAquiferRootFrac = 0._rkind end if ! check that roots in the aquifer are appropriate - if ((ixGroundwater /= bigBucket).and.(scalarAquiferRootFrac > 2._dp*epsilon(rootingDepth)))then + if ((ixGroundwater /= bigBucket).and.(scalarAquiferRootFrac > 2._rkind*epsilon(rootingDepth)))then if(scalarAquiferRootFrac < rootTolerance) then - mLayerRootDensity = mLayerRootDensity + scalarAquiferRootFrac/real(nSoil, kind(dp)) - scalarAquiferRootFrac = 0._dp + mLayerRootDensity = mLayerRootDensity + scalarAquiferRootFrac/real(nSoil, kind(rkind)) + scalarAquiferRootFrac = 0._rkind else select case(ixRootProfile) case(powerLaw); message=trim(message)//'roots in the aquifer only allowed for the big bucket gw parameterization: check that rooting depth < soil depth' @@ -274,8 +274,8 @@ subroutine satHydCond(mpar_data,indx_data,prog_data,flux_data,err,message) character(*),intent(out) :: message ! error message ! declare local variables integer(i4b) :: iLayer ! loop through layers - real(dp) :: ifcDepthScaleFactor ! depth scaling factor (layer interfaces) - real(dp) :: midDepthScaleFactor ! depth scaling factor (layer midpoints) + real(rkind) :: ifcDepthScaleFactor ! depth scaling factor (layer interfaces) + real(rkind) :: midDepthScaleFactor ! depth scaling factor (layer midpoints) ! initialize error control err=0; message='satHydCond/' ! ---------------------------------------------------------------------------------- @@ -315,7 +315,7 @@ subroutine satHydCond(mpar_data,indx_data,prog_data,flux_data,err,message) if(iLayer==nLayers)then iLayerSatHydCond(iLayer-nSnow) = k_soil(nSoil) else - iLayerSatHydCond(iLayer-nSnow) = 0.5_dp * (k_soil(iLayer-nSnow) + k_soil(iLayer+1-nSnow) ) + iLayerSatHydCond(iLayer-nSnow) = 0.5_rkind * (k_soil(iLayer-nSnow) + k_soil(iLayer+1-nSnow) ) endif ! - conductivity at layer midpoints mLayerSatHydCond(iLayer-nSnow) = k_soil(iLayer-nSnow) @@ -327,11 +327,11 @@ subroutine satHydCond(mpar_data,indx_data,prog_data,flux_data,err,message) ! - conductivity at layer interfaces ! --> NOTE: Do we need a weighted average based on layer depth for interior layers? - if(compactedDepth/iLayerHeight(nLayers) /= 1._dp) then ! avoid divide by zero - ifcDepthScaleFactor = ( (1._dp - iLayerHeight(iLayer)/iLayerHeight(nLayers))**(zScale_TOPMODEL - 1._dp) ) / & - ( (1._dp - compactedDepth/iLayerHeight(nLayers))**(zScale_TOPMODEL - 1._dp) ) + if(compactedDepth/iLayerHeight(nLayers) /= 1._rkind) then ! avoid divide by zero + ifcDepthScaleFactor = ( (1._rkind - iLayerHeight(iLayer)/iLayerHeight(nLayers))**(zScale_TOPMODEL - 1._rkind) ) / & + ( (1._rkind - compactedDepth/iLayerHeight(nLayers))**(zScale_TOPMODEL - 1._rkind) ) else - ifcDepthScaleFactor = 1.0_dp + ifcDepthScaleFactor = 1.0_rkind endif if(iLayer==nSnow)then iLayerSatHydCond(iLayer-nSnow) = k_soil(1) * ifcDepthScaleFactor @@ -339,14 +339,14 @@ subroutine satHydCond(mpar_data,indx_data,prog_data,flux_data,err,message) if(iLayer==nLayers)then iLayerSatHydCond(iLayer-nSnow) = k_soil(nSoil) * ifcDepthScaleFactor else - iLayerSatHydCond(iLayer-nSnow) = 0.5_dp * (k_soil(iLayer-nSnow) + k_soil(iLayer+1-nSnow) ) * ifcDepthScaleFactor + iLayerSatHydCond(iLayer-nSnow) = 0.5_rkind * (k_soil(iLayer-nSnow) + k_soil(iLayer+1-nSnow) ) * ifcDepthScaleFactor endif ! - conductivity at layer midpoints - if(compactedDepth/iLayerHeight(nLayers) /= 1._dp) then ! avoid divide by zero - midDepthScaleFactor = ( (1._dp - mLayerHeight(iLayer)/iLayerHeight(nLayers))**(zScale_TOPMODEL - 1._dp) ) / & - ( (1._dp - compactedDepth/iLayerHeight(nLayers))**(zScale_TOPMODEL - 1._dp) ) + if(compactedDepth/iLayerHeight(nLayers) /= 1._rkind) then ! avoid divide by zero + midDepthScaleFactor = ( (1._rkind - mLayerHeight(iLayer)/iLayerHeight(nLayers))**(zScale_TOPMODEL - 1._rkind) ) / & + ( (1._rkind - compactedDepth/iLayerHeight(nLayers))**(zScale_TOPMODEL - 1._rkind) ) else - midDepthScaleFactor = 1.0_dp + midDepthScaleFactor = 1.0_rkind endif mLayerSatHydCond(iLayer-nSnow) = k_soil(iLayer-nSnow) * midDepthScaleFactor mLayerSatHydCondMP(iLayer-nSnow) = k_macropore(iLayer-nSnow) * midDepthScaleFactor @@ -384,21 +384,21 @@ subroutine fracFuture(bpar_data,bvar_data,err,message) implicit none ! input variables - real(dp),intent(in) :: bpar_data(:) ! vector of basin-average model parameters + real(rkind),intent(in) :: bpar_data(:) ! vector of basin-average model parameters ! output variables type(var_dlength),intent(inout) :: bvar_data ! data structure of basin-average model variables integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! internal - real(dp) :: dt ! data time step (s) + real(rkind) :: dt ! data time step (s) integer(i4b) :: nTDH ! number of points in the time-delay histogram integer(i4b) :: iFuture ! index in time delay histogram - real(dp) :: aLambda ! scale parameter in the Gamma distribution - real(dp) :: tFuture ! future time (end of step) - real(dp) :: pSave ! cumulative probability at the start of the step - real(dp) :: cumProb ! cumulative probability at the end of the step - real(dp) :: sumFrac ! sum of runoff fractions in all steps - real(dp),parameter :: tolerFrac=0.01_dp ! tolerance for missing fractional runoff by truncating histogram + real(rkind) :: aLambda ! scale parameter in the Gamma distribution + real(rkind) :: tFuture ! future time (end of step) + real(rkind) :: pSave ! cumulative probability at the start of the step + real(rkind) :: cumProb ! cumulative probability at the end of the step + real(rkind) :: sumFrac ! sum of runoff fractions in all steps + real(rkind),parameter :: tolerFrac=0.01_rkind ! tolerance for missing fractional runoff by truncating histogram ! initialize error control err=0; message='fracFuture/' ! ---------------------------------------------------------------------------------- @@ -419,22 +419,22 @@ subroutine fracFuture(bpar_data,bvar_data,err,message) nTDH = size(runoffFuture) ! initialize runoffFuture (will be overwritten by initial conditions file values if present) - runoffFuture(1:nTDH) = 0._dp + runoffFuture(1:nTDH) = 0._rkind ! select option for sub-grid routing select case(ixRouting) ! ** instantaneous routing case(qInstant) - fractionFuture(1) = 1._dp - fractionFuture(2:nTDH) = 0._dp + fractionFuture(1) = 1._rkind + fractionFuture(2:nTDH) = 0._rkind ! ** time delay histogram case(timeDelay) ! initialize - pSave = 0._dp ! cumulative probability at the start of the step + pSave = 0._rkind ! cumulative probability at the start of the step aLambda = routingGammaShape / routingGammaScale - if(routingGammaShape <= 0._dp .or. aLambda < 0._dp)then + if(routingGammaShape <= 0._rkind .or. aLambda < 0._rkind)then message=trim(message)//'bad arguments for the Gamma distribution' err=20; return end if @@ -443,19 +443,19 @@ subroutine fracFuture(bpar_data,bvar_data,err,message) ! get weight for a given bin tFuture = real(iFuture, kind(dt))*dt ! future time (end of step) cumProb = gammp(routingGammaShape,aLambda*tFuture) ! cumulative probability at the end of the step - fractionFuture(iFuture) = max(0._dp, cumProb - pSave) ! fraction of runoff in the current step + fractionFuture(iFuture) = max(0._rkind, cumProb - pSave) ! fraction of runoff in the current step pSave = cumProb ! save the cumulative probability for use in the next step !write(*,'(a,1x,i4,1x,3(f20.10,1x))') trim(message), iFuture, tFuture, cumProb, fractionFuture(iFuture) ! set remaining bins to zero if(fractionFuture(iFuture) < tiny(dt))then - fractionFuture(iFuture:nTDH) = 0._dp + fractionFuture(iFuture:nTDH) = 0._rkind exit end if end do ! (looping through future time steps) ! check that we have enough bins sumFrac = sum(fractionFuture) - if(abs(1._dp - sumFrac) > tolerFrac)then + if(abs(1._rkind - sumFrac) > tolerFrac)then write(*,*) 'fraction of basin runoff histogram being accounted for by time delay vector is ', sumFrac write(*,*) 'this is less than allowed by tolerFrac = ', tolerFrac message=trim(message)//'not enough bins for the time delay histogram -- fix hard-coded parameter in globalData.f90' @@ -497,7 +497,7 @@ subroutine v_shortcut(mpar_data,diag_data,err,message) ! ---------------------------------------------------------------------------------- ! compute the van Genutchen "m" parameter - vGn_m = 1._dp - 1._dp/vGn_n + vGn_m = 1._rkind - 1._rkind/vGn_n end associate end subroutine v_shortcut diff --git a/build/source/engine/vegLiqFlux.f90 b/build/source/engine/vegLiqFlux.f90 index 44fe6f695..59e1151b2 100755 --- a/build/source/engine/vegLiqFlux.f90 +++ b/build/source/engine/vegLiqFlux.f90 @@ -67,16 +67,16 @@ subroutine vegLiqFlux(& implicit none ! input logical(lgt),intent(in) :: computeVegFlux ! flag to indicate if we are computing fluxes over vegetation (.false. means veg is buried with snow) - real(dp),intent(in) :: scalarCanopyLiqTrial ! trial mass of liquid water on the vegetation canopy at the current iteration (kg m-2) - real(dp),intent(in) :: scalarRainfall ! rainfall (kg m-2 s-1) + real(rkind),intent(in) :: scalarCanopyLiqTrial ! trial mass of liquid water on the vegetation canopy at the current iteration (kg m-2) + real(rkind),intent(in) :: scalarRainfall ! rainfall (kg m-2 s-1) ! input-output: data structures type(var_dlength),intent(in) :: mpar_data ! model parameters type(var_dlength),intent(inout) :: diag_data ! model diagnostic variables for the local basin ! output - real(dp),intent(out) :: scalarThroughfallRain ! rain that reaches the ground without ever touching the canopy (kg m-2 s-1) - real(dp),intent(out) :: scalarCanopyLiqDrainage ! drainage of liquid water from the vegetation canopy (kg m-2 s-1) - real(dp),intent(out) :: scalarThroughfallRainDeriv ! derivative in throughfall w.r.t. canopy liquid water (s-1) - real(dp),intent(out) :: scalarCanopyLiqDrainageDeriv ! derivative in canopy drainage w.r.t. canopy liquid water (s-1) + real(rkind),intent(out) :: scalarThroughfallRain ! rain that reaches the ground without ever touching the canopy (kg m-2 s-1) + real(rkind),intent(out) :: scalarCanopyLiqDrainage ! drainage of liquid water from the vegetation canopy (kg m-2 s-1) + real(rkind),intent(out) :: scalarThroughfallRainDeriv ! derivative in throughfall w.r.t. canopy liquid water (s-1) + real(rkind),intent(out) :: scalarCanopyLiqDrainageDeriv ! derivative in canopy drainage w.r.t. canopy liquid water (s-1) integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! ------------------------------------------------------------------------------------------------------------------------------------------------------ @@ -94,9 +94,9 @@ subroutine vegLiqFlux(& ! set throughfall to inputs if vegetation is completely buried with snow if(.not.computeVegFlux)then scalarThroughfallRain = scalarRainfall - scalarCanopyLiqDrainage = 0._dp - scalarThroughfallRainDeriv = 0._dp - scalarCanopyLiqDrainageDeriv = 0._dp + scalarCanopyLiqDrainage = 0._rkind + scalarThroughfallRainDeriv = 0._rkind + scalarCanopyLiqDrainageDeriv = 0._rkind return end if @@ -106,13 +106,13 @@ subroutine vegLiqFlux(& ! original model (no flexibility in canopy interception): 100% of rainfall is intercepted by the vegetation canopy ! NOTE: this could be done with scalarThroughfallScaleRain=0, though requires setting scalarThroughfallScaleRain in all test cases case(unDefined) - scalarThroughfallRain = 0._dp - scalarThroughfallRainDeriv = 0._dp + scalarThroughfallRain = 0._rkind + scalarThroughfallRainDeriv = 0._rkind ! fraction of rainfall hits the ground without ever touching the canopy case(sparseCanopy) scalarThroughfallRain = scalarThroughfallScaleRain*scalarRainfall - scalarThroughfallRainDeriv = 0._dp + scalarThroughfallRainDeriv = 0._rkind ! throughfall a function of canopy storage case(storageFunc) @@ -125,7 +125,7 @@ subroutine vegLiqFlux(& ! all rain falls through the canopy when the canopy is at capacity else scalarThroughfallRain = scalarRainfall - scalarThroughfallRainDeriv = 0._dp + scalarThroughfallRainDeriv = 0._rkind end if case default; err=20; message=trim(message)//'unable to identify option for canopy interception'; return @@ -137,8 +137,8 @@ subroutine vegLiqFlux(& scalarCanopyLiqDrainage = scalarCanopyDrainageCoeff*(scalarCanopyLiqTrial - scalarCanopyLiqMax) scalarCanopyLiqDrainageDeriv = scalarCanopyDrainageCoeff else - scalarCanopyLiqDrainage = 0._dp - scalarCanopyLiqDrainageDeriv = 0._dp + scalarCanopyLiqDrainage = 0._rkind + scalarCanopyLiqDrainageDeriv = 0._rkind end if !write(*,'(a,1x,f25.15)') 'scalarCanopyLiqDrainage = ', scalarCanopyLiqDrainage diff --git a/build/source/engine/vegNrgFlux.f90 b/build/source/engine/vegNrgFlux.f90 index 47bfba9a9..905732644 100755 --- a/build/source/engine/vegNrgFlux.f90 +++ b/build/source/engine/vegNrgFlux.f90 @@ -114,11 +114,11 @@ module vegNrgFlux_module integer(i4b),parameter :: iLoc = 1 ! i-location integer(i4b),parameter :: jLoc = 1 ! j-location ! algorithmic parameters -real(dp),parameter :: missingValue=-9999._dp ! missing value, used when diagnostic or state variables are undefined -real(dp),parameter :: verySmall=1.e-6_dp ! used as an additive constant to check if substantial difference among real numbers -real(dp),parameter :: tinyVal=epsilon(1._dp) ! used as an additive constant to check if substantial difference among real numbers -real(dp),parameter :: mpe=1.e-6_dp ! prevents overflow error if division by zero -real(dp),parameter :: dx=1.e-11_dp ! finite difference increment +real(rkind),parameter :: missingValue=-9999._rkind ! missing value, used when diagnostic or state variables are undefined +real(rkind),parameter :: verySmall=1.e-6_rkind ! used as an additive constant to check if substantial difference among real numbers +real(rkind),parameter :: tinyVal=epsilon(1._rkind) ! used as an additive constant to check if substantial difference among real numbers +real(rkind),parameter :: mpe=1.e-6_rkind ! prevents overflow error if division by zero +real(rkind),parameter :: dx=1.e-11_rkind ! finite difference increment ! control logical(lgt) :: printflag ! flag to turn on printing contains @@ -213,15 +213,15 @@ subroutine vegNrgFlux(& logical(lgt),intent(in) :: computeVegFlux ! flag to indicate if computing fluxes over vegetation ! input: model state variables - real(dp),intent(in) :: upperBoundTemp ! temperature of the upper boundary (K) --> NOTE: use air temperature - real(dp),intent(in) :: canairTempTrial ! trial value of canopy air space temperature (K) - real(dp),intent(in) :: canopyTempTrial ! trial value of canopy temperature (K) - real(dp),intent(in) :: groundTempTrial ! trial value of ground temperature (K) - real(dp),intent(in) :: canopyIceTrial ! trial value of mass of ice on the vegetation canopy (kg m-2) - real(dp),intent(in) :: canopyLiqTrial ! trial value of mass of liquid water on the vegetation canopy (kg m-2) + real(rkind),intent(in) :: upperBoundTemp ! temperature of the upper boundary (K) --> NOTE: use air temperature + real(rkind),intent(in) :: canairTempTrial ! trial value of canopy air space temperature (K) + real(rkind),intent(in) :: canopyTempTrial ! trial value of canopy temperature (K) + real(rkind),intent(in) :: groundTempTrial ! trial value of ground temperature (K) + real(rkind),intent(in) :: canopyIceTrial ! trial value of mass of ice on the vegetation canopy (kg m-2) + real(rkind),intent(in) :: canopyLiqTrial ! trial value of mass of liquid water on the vegetation canopy (kg m-2) ! input: model derivatives - real(dp),intent(in) :: dCanLiq_dTcanopy ! intent(in): derivative in canopy liquid w.r.t. canopy temperature (kg m-2 K-1) + real(rkind),intent(in) :: dCanLiq_dTcanopy ! intent(in): derivative in canopy liquid w.r.t. canopy temperature (kg m-2 K-1) ! input/output: data structures type(var_i),intent(in) :: type_data ! type of vegetation and soil @@ -235,41 +235,41 @@ subroutine vegNrgFlux(& type(model_options),intent(in) :: model_decisions(:) ! model decisions ! output: liquid water fluxes associated with evaporation/transpiration (needed for coupling) - real(dp),intent(out) :: returnCanopyTranspiration ! canopy transpiration (kg m-2 s-1) - real(dp),intent(out) :: returnCanopyEvaporation ! canopy evaporation/condensation (kg m-2 s-1) - real(dp),intent(out) :: returnGroundEvaporation ! ground evaporation/condensation -- below canopy or non-vegetated (kg m-2 s-1) + real(rkind),intent(out) :: returnCanopyTranspiration ! canopy transpiration (kg m-2 s-1) + real(rkind),intent(out) :: returnCanopyEvaporation ! canopy evaporation/condensation (kg m-2 s-1) + real(rkind),intent(out) :: returnGroundEvaporation ! ground evaporation/condensation -- below canopy or non-vegetated (kg m-2 s-1) ! output: fluxes - real(dp),intent(out) :: canairNetFlux ! net energy flux for the canopy air space (W m-2) - real(dp),intent(out) :: canopyNetFlux ! net energy flux for the vegetation canopy (W m-2) - real(dp),intent(out) :: groundNetFlux ! net energy flux for the ground surface (W m-2) + real(rkind),intent(out) :: canairNetFlux ! net energy flux for the canopy air space (W m-2) + real(rkind),intent(out) :: canopyNetFlux ! net energy flux for the vegetation canopy (W m-2) + real(rkind),intent(out) :: groundNetFlux ! net energy flux for the ground surface (W m-2) ! output: energy flux derivatives - real(dp),intent(out) :: dCanairNetFlux_dCanairTemp ! derivative in net canopy air space flux w.r.t. canopy air temperature (W m-2 K-1) - real(dp),intent(out) :: dCanairNetFlux_dCanopyTemp ! derivative in net canopy air space flux w.r.t. canopy temperature (W m-2 K-1) - real(dp),intent(out) :: dCanairNetFlux_dGroundTemp ! derivative in net canopy air space flux w.r.t. ground temperature (W m-2 K-1) - real(dp),intent(out) :: dCanopyNetFlux_dCanairTemp ! derivative in net canopy flux w.r.t. canopy air temperature (W m-2 K-1) - real(dp),intent(out) :: dCanopyNetFlux_dCanopyTemp ! derivative in net canopy flux w.r.t. canopy temperature (W m-2 K-1) - real(dp),intent(out) :: dCanopyNetFlux_dGroundTemp ! derivative in net canopy flux w.r.t. ground temperature (W m-2 K-1) - real(dp),intent(out) :: dGroundNetFlux_dCanairTemp ! derivative in net ground flux w.r.t. canopy air temperature (W m-2 K-1) - real(dp),intent(out) :: dGroundNetFlux_dCanopyTemp ! derivative in net ground flux w.r.t. canopy temperature (W m-2 K-1) - real(dp),intent(out) :: dGroundNetFlux_dGroundTemp ! derivative in net ground flux w.r.t. ground temperature (W m-2 K-1) + real(rkind),intent(out) :: dCanairNetFlux_dCanairTemp ! derivative in net canopy air space flux w.r.t. canopy air temperature (W m-2 K-1) + real(rkind),intent(out) :: dCanairNetFlux_dCanopyTemp ! derivative in net canopy air space flux w.r.t. canopy temperature (W m-2 K-1) + real(rkind),intent(out) :: dCanairNetFlux_dGroundTemp ! derivative in net canopy air space flux w.r.t. ground temperature (W m-2 K-1) + real(rkind),intent(out) :: dCanopyNetFlux_dCanairTemp ! derivative in net canopy flux w.r.t. canopy air temperature (W m-2 K-1) + real(rkind),intent(out) :: dCanopyNetFlux_dCanopyTemp ! derivative in net canopy flux w.r.t. canopy temperature (W m-2 K-1) + real(rkind),intent(out) :: dCanopyNetFlux_dGroundTemp ! derivative in net canopy flux w.r.t. ground temperature (W m-2 K-1) + real(rkind),intent(out) :: dGroundNetFlux_dCanairTemp ! derivative in net ground flux w.r.t. canopy air temperature (W m-2 K-1) + real(rkind),intent(out) :: dGroundNetFlux_dCanopyTemp ! derivative in net ground flux w.r.t. canopy temperature (W m-2 K-1) + real(rkind),intent(out) :: dGroundNetFlux_dGroundTemp ! derivative in net ground flux w.r.t. ground temperature (W m-2 K-1) ! output: liquid flux derivatives (canopy evap) - real(dp),intent(out) :: dCanopyEvaporation_dCanLiq ! derivative in canopy evaporation w.r.t. canopy liquid water content (s-1) - real(dp),intent(out) :: dCanopyEvaporation_dTCanair ! derivative in canopy evaporation w.r.t. canopy air temperature (kg m-2 s-1 K-1) - real(dp),intent(out) :: dCanopyEvaporation_dTCanopy ! derivative in canopy evaporation w.r.t. canopy temperature (kg m-2 s-1 K-1) - real(dp),intent(out) :: dCanopyEvaporation_dTGround ! derivative in canopy evaporation w.r.t. ground temperature (kg m-2 s-1 K-1) + real(rkind),intent(out) :: dCanopyEvaporation_dCanLiq ! derivative in canopy evaporation w.r.t. canopy liquid water content (s-1) + real(rkind),intent(out) :: dCanopyEvaporation_dTCanair ! derivative in canopy evaporation w.r.t. canopy air temperature (kg m-2 s-1 K-1) + real(rkind),intent(out) :: dCanopyEvaporation_dTCanopy ! derivative in canopy evaporation w.r.t. canopy temperature (kg m-2 s-1 K-1) + real(rkind),intent(out) :: dCanopyEvaporation_dTGround ! derivative in canopy evaporation w.r.t. ground temperature (kg m-2 s-1 K-1) ! output: liquid flux derivatives (ground evap) - real(dp),intent(out) :: dGroundEvaporation_dCanLiq ! derivative in ground evaporation w.r.t. canopy liquid water content (s-1) - real(dp),intent(out) :: dGroundEvaporation_dTCanair ! derivative in ground evaporation w.r.t. canopy air temperature (kg m-2 s-1 K-1) - real(dp),intent(out) :: dGroundEvaporation_dTCanopy ! derivative in ground evaporation w.r.t. canopy temperature (kg m-2 s-1 K-1) - real(dp),intent(out) :: dGroundEvaporation_dTGround ! derivative in ground evaporation w.r.t. ground temperature (kg m-2 s-1 K-1) + real(rkind),intent(out) :: dGroundEvaporation_dCanLiq ! derivative in ground evaporation w.r.t. canopy liquid water content (s-1) + real(rkind),intent(out) :: dGroundEvaporation_dTCanair ! derivative in ground evaporation w.r.t. canopy air temperature (kg m-2 s-1 K-1) + real(rkind),intent(out) :: dGroundEvaporation_dTCanopy ! derivative in ground evaporation w.r.t. canopy temperature (kg m-2 s-1 K-1) + real(rkind),intent(out) :: dGroundEvaporation_dTGround ! derivative in ground evaporation w.r.t. ground temperature (kg m-2 s-1 K-1) ! output: cross derivative terms - real(dp),intent(out) :: dCanopyNetFlux_dCanLiq ! derivative in net canopy fluxes w.r.t. canopy liquid water content (J kg-1 s-1) - real(dp),intent(out) :: dGroundNetFlux_dCanLiq ! derivative in net ground fluxes w.r.t. canopy liquid water content (J kg-1 s-1) + real(rkind),intent(out) :: dCanopyNetFlux_dCanLiq ! derivative in net canopy fluxes w.r.t. canopy liquid water content (J kg-1 s-1) + real(rkind),intent(out) :: dGroundNetFlux_dCanLiq ! derivative in net ground fluxes w.r.t. canopy liquid water content (J kg-1 s-1) ! output: error control integer(i4b),intent(out) :: err ! error code @@ -280,10 +280,10 @@ subroutine vegNrgFlux(& ! --------------------------------------------------------------------------------------- ! local (general) character(LEN=256) :: cmessage ! error message of downwind routine - real(dp) :: VAI ! vegetation area index (m2 m-2) - real(dp) :: exposedVAI ! exposed vegetation area index (m2 m-2) - real(dp) :: totalCanopyWater ! total water on the vegetation canopy (kg m-2) - real(dp) :: scalarAquiferStorage ! aquifer storage (m) + real(rkind) :: VAI ! vegetation area index (m2 m-2) + real(rkind) :: exposedVAI ! exposed vegetation area index (m2 m-2) + real(rkind) :: totalCanopyWater ! total water on the vegetation canopy (kg m-2) + real(rkind) :: scalarAquiferStorage ! aquifer storage (m) ! local (compute numerical derivatives) integer(i4b),parameter :: unperturbed=1 ! named variable to identify the case of unperturbed state variables @@ -293,135 +293,135 @@ subroutine vegNrgFlux(& integer(i4b),parameter :: perturbStateCanLiq=5 ! named variable to identify the case where we perturb the canopy liquid water content integer(i4b) :: itry ! index of flux evaluation integer(i4b) :: nFlux ! number of flux evaluations - real(dp) :: groundTemp ! value of ground temperature used in flux calculations (may be perturbed) - real(dp) :: canopyTemp ! value of canopy temperature used in flux calculations (may be perturbed) - real(dp) :: canairTemp ! value of canopy air temperature used in flux calculations (may be perturbed) - real(dp) :: try0,try1 ! trial values to evaluate specific derivatives (testing only) + real(rkind) :: groundTemp ! value of ground temperature used in flux calculations (may be perturbed) + real(rkind) :: canopyTemp ! value of canopy temperature used in flux calculations (may be perturbed) + real(rkind) :: canairTemp ! value of canopy air temperature used in flux calculations (may be perturbed) + real(rkind) :: try0,try1 ! trial values to evaluate specific derivatives (testing only) ! local (saturation vapor pressure of veg) - real(dp) :: TV_celcius ! vegetaion temperature (C) - real(dp) :: TG_celcius ! ground temperature (C) - real(dp) :: dSVPCanopy_dCanopyTemp ! derivative in canopy saturated vapor pressure w.r.t. vegetation temperature (Pa/K) - real(dp) :: dSVPGround_dGroundTemp ! derivative in ground saturated vapor pressure w.r.t. ground temperature (Pa/K) + real(rkind) :: TV_celcius ! vegetaion temperature (C) + real(rkind) :: TG_celcius ! ground temperature (C) + real(rkind) :: dSVPCanopy_dCanopyTemp ! derivative in canopy saturated vapor pressure w.r.t. vegetation temperature (Pa/K) + real(rkind) :: dSVPGround_dGroundTemp ! derivative in ground saturated vapor pressure w.r.t. ground temperature (Pa/K) ! local (wetted canopy area) - real(dp) :: fracLiquidCanopy ! fraction of liquid water in the canopy (-) - real(dp) :: canopyWetFraction ! trial value of the canopy wetted fraction (-) - real(dp) :: dCanopyWetFraction_dWat ! derivative in wetted fraction w.r.t. canopy total water (kg-1 m2) - real(dp) :: dCanopyWetFraction_dT ! derivative in wetted fraction w.r.t. canopy temperature (K-1) + real(rkind) :: fracLiquidCanopy ! fraction of liquid water in the canopy (-) + real(rkind) :: canopyWetFraction ! trial value of the canopy wetted fraction (-) + real(rkind) :: dCanopyWetFraction_dWat ! derivative in wetted fraction w.r.t. canopy total water (kg-1 m2) + real(rkind) :: dCanopyWetFraction_dT ! derivative in wetted fraction w.r.t. canopy temperature (K-1) ! local (longwave radiation) - real(dp) :: expi ! exponential integral - real(dp) :: scaleLAI ! scaled LAI (computing diffuse transmissivity) - real(dp) :: diffuseTrans ! diffuse transmissivity (-) - real(dp) :: groundEmissivity ! emissivity of the ground surface (-) - real(dp),parameter :: vegEmissivity=0.98_dp ! emissivity of vegetation (0.9665 in JULES) (-) - real(dp),parameter :: soilEmissivity=0.98_dp ! emmisivity of the soil (0.9665 in JULES) (-) - real(dp),parameter :: snowEmissivity=0.99_dp ! emissivity of snow (-) - real(dp) :: dLWNetCanopy_dTCanopy ! derivative in net canopy radiation w.r.t. canopy temperature (W m-2 K-1) - real(dp) :: dLWNetGround_dTGround ! derivative in net ground radiation w.r.t. ground temperature (W m-2 K-1) - real(dp) :: dLWNetCanopy_dTGround ! derivative in net canopy radiation w.r.t. ground temperature (W m-2 K-1) - real(dp) :: dLWNetGround_dTCanopy ! derivative in net ground radiation w.r.t. canopy temperature (W m-2 K-1) + real(rkind) :: expi ! exponential integral + real(rkind) :: scaleLAI ! scaled LAI (computing diffuse transmissivity) + real(rkind) :: diffuseTrans ! diffuse transmissivity (-) + real(rkind) :: groundEmissivity ! emissivity of the ground surface (-) + real(rkind),parameter :: vegEmissivity=0.98_rkind ! emissivity of vegetation (0.9665 in JULES) (-) + real(rkind),parameter :: soilEmissivity=0.98_rkind ! emmisivity of the soil (0.9665 in JULES) (-) + real(rkind),parameter :: snowEmissivity=0.99_rkind ! emissivity of snow (-) + real(rkind) :: dLWNetCanopy_dTCanopy ! derivative in net canopy radiation w.r.t. canopy temperature (W m-2 K-1) + real(rkind) :: dLWNetGround_dTGround ! derivative in net ground radiation w.r.t. ground temperature (W m-2 K-1) + real(rkind) :: dLWNetCanopy_dTGround ! derivative in net canopy radiation w.r.t. ground temperature (W m-2 K-1) + real(rkind) :: dLWNetGround_dTCanopy ! derivative in net ground radiation w.r.t. canopy temperature (W m-2 K-1) ! local (aerodynamic resistance) - real(dp) :: scalarCanopyStabilityCorrection_old ! stability correction for the canopy (-) - real(dp) :: scalarGroundStabilityCorrection_old ! stability correction for the ground surface (-) + real(rkind) :: scalarCanopyStabilityCorrection_old ! stability correction for the canopy (-) + real(rkind) :: scalarGroundStabilityCorrection_old ! stability correction for the ground surface (-) ! local (turbulent heat transfer) - real(dp) :: z0Ground ! roughness length of the ground (ground below the canopy or non-vegetated surface) (m) - real(dp) :: soilEvapFactor ! soil water control on evaporation from non-vegetated surfaces - real(dp) :: soilRelHumidity_noSnow ! relative humidity in the soil pores [0-1] - real(dp) :: scalarLeafConductance ! leaf conductance (m s-1) - real(dp) :: scalarCanopyConductance ! canopy conductance (m s-1) - real(dp) :: scalarGroundConductanceSH ! ground conductance for sensible heat (m s-1) - real(dp) :: scalarGroundConductanceLH ! ground conductance for latent heat -- includes soil resistance (m s-1) - real(dp) :: scalarEvapConductance ! conductance for evaporation (m s-1) - real(dp) :: scalarTransConductance ! conductance for transpiration (m s-1) - real(dp) :: scalarTotalConductanceSH ! total conductance for sensible heat (m s-1) - real(dp) :: scalarTotalConductanceLH ! total conductance for latent heat (m s-1) - real(dp) :: dGroundResistance_dTGround ! derivative in ground resistance w.r.t. ground temperature (s m-1 K-1) - real(dp) :: dGroundResistance_dTCanopy ! derivative in ground resistance w.r.t. canopy temperature (s m-1 K-1) - real(dp) :: dGroundResistance_dTCanair ! derivative in ground resistance w.r.t. canopy air temperature (s m-1 K-1) - real(dp) :: dCanopyResistance_dTCanopy ! derivative in canopy resistance w.r.t. canopy temperature (s m-1 K-1) - real(dp) :: dCanopyResistance_dTCanair ! derivative in canopy resistance w.r.t. canopy air temperature (s m-1 K-1) - real(dp) :: turbFluxCanair ! total turbulent heat fluxes exchanged at the canopy air space (W m-2) - real(dp) :: turbFluxCanopy ! total turbulent heat fluxes from the canopy to the canopy air space (W m-2) - real(dp) :: turbFluxGround ! total turbulent heat fluxes from the ground to the canopy air space (W m-2) + real(rkind) :: z0Ground ! roughness length of the ground (ground below the canopy or non-vegetated surface) (m) + real(rkind) :: soilEvapFactor ! soil water control on evaporation from non-vegetated surfaces + real(rkind) :: soilRelHumidity_noSnow ! relative humidity in the soil pores [0-1] + real(rkind) :: scalarLeafConductance ! leaf conductance (m s-1) + real(rkind) :: scalarCanopyConductance ! canopy conductance (m s-1) + real(rkind) :: scalarGroundConductanceSH ! ground conductance for sensible heat (m s-1) + real(rkind) :: scalarGroundConductanceLH ! ground conductance for latent heat -- includes soil resistance (m s-1) + real(rkind) :: scalarEvapConductance ! conductance for evaporation (m s-1) + real(rkind) :: scalarTransConductance ! conductance for transpiration (m s-1) + real(rkind) :: scalarTotalConductanceSH ! total conductance for sensible heat (m s-1) + real(rkind) :: scalarTotalConductanceLH ! total conductance for latent heat (m s-1) + real(rkind) :: dGroundResistance_dTGround ! derivative in ground resistance w.r.t. ground temperature (s m-1 K-1) + real(rkind) :: dGroundResistance_dTCanopy ! derivative in ground resistance w.r.t. canopy temperature (s m-1 K-1) + real(rkind) :: dGroundResistance_dTCanair ! derivative in ground resistance w.r.t. canopy air temperature (s m-1 K-1) + real(rkind) :: dCanopyResistance_dTCanopy ! derivative in canopy resistance w.r.t. canopy temperature (s m-1 K-1) + real(rkind) :: dCanopyResistance_dTCanair ! derivative in canopy resistance w.r.t. canopy air temperature (s m-1 K-1) + real(rkind) :: turbFluxCanair ! total turbulent heat fluxes exchanged at the canopy air space (W m-2) + real(rkind) :: turbFluxCanopy ! total turbulent heat fluxes from the canopy to the canopy air space (W m-2) + real(rkind) :: turbFluxGround ! total turbulent heat fluxes from the ground to the canopy air space (W m-2) ! local (turbulent heat transfer -- compute numerical derivatives) ! (temporary scalar resistances when states are perturbed) - real(dp) :: trialLeafResistance ! mean leaf boundary layer resistance per unit leaf area (s m-1) - real(dp) :: trialGroundResistance ! below canopy aerodynamic resistance (s m-1) - real(dp) :: trialCanopyResistance ! above canopy aerodynamic resistance (s m-1) - real(dp) :: notUsed_RiBulkCanopy ! bulk Richardson number for the canopy (-) - real(dp) :: notUsed_RiBulkGround ! bulk Richardson number for the ground surface (-) - real(dp) :: notUsed_z0Canopy ! roughness length of the vegetation canopy (m) - real(dp) :: notUsed_WindReductionFactor ! canopy wind reduction factor (-) - real(dp) :: notUsed_ZeroPlaneDisplacement ! zero plane displacement (m) - real(dp) :: notUsed_scalarCanopyStabilityCorrection ! stability correction for the canopy (-) - real(dp) :: notUsed_scalarGroundStabilityCorrection ! stability correction for the ground surface (-) - real(dp) :: notUsed_EddyDiffusCanopyTop ! eddy diffusivity for heat at the top of the canopy (m2 s-1) - real(dp) :: notUsed_FrictionVelocity ! friction velocity (m s-1) - real(dp) :: notUsed_WindspdCanopyTop ! windspeed at the top of the canopy (m s-1) - real(dp) :: notUsed_WindspdCanopyBottom ! windspeed at the height of the bottom of the canopy (m s-1) - real(dp) :: notUsed_dGroundResistance_dTGround ! derivative in ground resistance w.r.t. ground temperature (s m-1 K-1) - real(dp) :: notUsed_dGroundResistance_dTCanopy ! derivative in ground resistance w.r.t. canopy temperature (s m-1 K-1) - real(dp) :: notUsed_dGroundResistance_dTCanair ! derivative in ground resistance w.r.t. canopy air temperature (s m-1 K-1) - real(dp) :: notUsed_dCanopyResistance_dTCanopy ! derivative in canopy resistance w.r.t. canopy temperature (s m-1 K-1) - real(dp) :: notUsed_dCanopyResistance_dTCanair ! derivative in canopy resistance w.r.t. canopy air temperature (s m-1 K-1) + real(rkind) :: trialLeafResistance ! mean leaf boundary layer resistance per unit leaf area (s m-1) + real(rkind) :: trialGroundResistance ! below canopy aerodynamic resistance (s m-1) + real(rkind) :: trialCanopyResistance ! above canopy aerodynamic resistance (s m-1) + real(rkind) :: notUsed_RiBulkCanopy ! bulk Richardson number for the canopy (-) + real(rkind) :: notUsed_RiBulkGround ! bulk Richardson number for the ground surface (-) + real(rkind) :: notUsed_z0Canopy ! roughness length of the vegetation canopy (m) + real(rkind) :: notUsed_WindReductionFactor ! canopy wind reduction factor (-) + real(rkind) :: notUsed_ZeroPlaneDisplacement ! zero plane displacement (m) + real(rkind) :: notUsed_scalarCanopyStabilityCorrection ! stability correction for the canopy (-) + real(rkind) :: notUsed_scalarGroundStabilityCorrection ! stability correction for the ground surface (-) + real(rkind) :: notUsed_EddyDiffusCanopyTop ! eddy diffusivity for heat at the top of the canopy (m2 s-1) + real(rkind) :: notUsed_FrictionVelocity ! friction velocity (m s-1) + real(rkind) :: notUsed_WindspdCanopyTop ! windspeed at the top of the canopy (m s-1) + real(rkind) :: notUsed_WindspdCanopyBottom ! windspeed at the height of the bottom of the canopy (m s-1) + real(rkind) :: notUsed_dGroundResistance_dTGround ! derivative in ground resistance w.r.t. ground temperature (s m-1 K-1) + real(rkind) :: notUsed_dGroundResistance_dTCanopy ! derivative in ground resistance w.r.t. canopy temperature (s m-1 K-1) + real(rkind) :: notUsed_dGroundResistance_dTCanair ! derivative in ground resistance w.r.t. canopy air temperature (s m-1 K-1) + real(rkind) :: notUsed_dCanopyResistance_dTCanopy ! derivative in canopy resistance w.r.t. canopy temperature (s m-1 K-1) + real(rkind) :: notUsed_dCanopyResistance_dTCanair ! derivative in canopy resistance w.r.t. canopy air temperature (s m-1 K-1) ! (fluxes after perturbations in model states -- canopy air space) - real(dp) :: turbFluxCanair_dStateCanair ! turbulent exchange from the canopy air space to the atmosphere, after canopy air temperature is perturbed (W m-2) - real(dp) :: turbFluxCanair_dStateCanopy ! turbulent exchange from the canopy air space to the atmosphere, after canopy temperature is perturbed (W m-2) - real(dp) :: turbFluxCanair_dStateGround ! turbulent exchange from the canopy air space to the atmosphere, after ground temperature is perturbed (W m-2) - real(dp) :: turbFluxCanair_dStateCanliq ! turbulent exchange from the canopy air space to the atmosphere, after canopy liquid water content is perturbed (W m-2) + real(rkind) :: turbFluxCanair_dStateCanair ! turbulent exchange from the canopy air space to the atmosphere, after canopy air temperature is perturbed (W m-2) + real(rkind) :: turbFluxCanair_dStateCanopy ! turbulent exchange from the canopy air space to the atmosphere, after canopy temperature is perturbed (W m-2) + real(rkind) :: turbFluxCanair_dStateGround ! turbulent exchange from the canopy air space to the atmosphere, after ground temperature is perturbed (W m-2) + real(rkind) :: turbFluxCanair_dStateCanliq ! turbulent exchange from the canopy air space to the atmosphere, after canopy liquid water content is perturbed (W m-2) ! (fluxes after perturbations in model states -- vegetation canopy) - real(dp) :: turbFluxCanopy_dStateCanair ! total turbulent heat fluxes from the canopy to the canopy air space, after canopy air temperature is perturbed (W m-2) - real(dp) :: turbFluxCanopy_dStateCanopy ! total turbulent heat fluxes from the canopy to the canopy air space, after canopy temperature is perturbed (W m-2) - real(dp) :: turbFluxCanopy_dStateGround ! total turbulent heat fluxes from the canopy to the canopy air space, after ground temperature is perturbed (W m-2) - real(dp) :: turbFluxCanopy_dStateCanLiq ! total turbulent heat fluxes from the canopy to the canopy air space, after canopy liquid water content is perturbed (W m-2) + real(rkind) :: turbFluxCanopy_dStateCanair ! total turbulent heat fluxes from the canopy to the canopy air space, after canopy air temperature is perturbed (W m-2) + real(rkind) :: turbFluxCanopy_dStateCanopy ! total turbulent heat fluxes from the canopy to the canopy air space, after canopy temperature is perturbed (W m-2) + real(rkind) :: turbFluxCanopy_dStateGround ! total turbulent heat fluxes from the canopy to the canopy air space, after ground temperature is perturbed (W m-2) + real(rkind) :: turbFluxCanopy_dStateCanLiq ! total turbulent heat fluxes from the canopy to the canopy air space, after canopy liquid water content is perturbed (W m-2) ! (fluxes after perturbations in model states -- ground surface) - real(dp) :: turbFluxGround_dStateCanair ! total turbulent heat fluxes from the ground to the canopy air space, after canopy air temperature is perturbed (W m-2) - real(dp) :: turbFluxGround_dStateCanopy ! total turbulent heat fluxes from the ground to the canopy air space, after canopy temperature is perturbed (W m-2) - real(dp) :: turbFluxGround_dStateGround ! total turbulent heat fluxes from the ground to the canopy air space, after ground temperature is perturbed (W m-2) - real(dp) :: turbFluxGround_dStateCanLiq ! total turbulent heat fluxes from the ground to the canopy air space, after canopy liquid water content is perturbed (W m-2) + real(rkind) :: turbFluxGround_dStateCanair ! total turbulent heat fluxes from the ground to the canopy air space, after canopy air temperature is perturbed (W m-2) + real(rkind) :: turbFluxGround_dStateCanopy ! total turbulent heat fluxes from the ground to the canopy air space, after canopy temperature is perturbed (W m-2) + real(rkind) :: turbFluxGround_dStateGround ! total turbulent heat fluxes from the ground to the canopy air space, after ground temperature is perturbed (W m-2) + real(rkind) :: turbFluxGround_dStateCanLiq ! total turbulent heat fluxes from the ground to the canopy air space, after canopy liquid water content is perturbed (W m-2) ! (fluxes after perturbations in model states -- canopy evaporation) - real(dp) :: latHeatCanEvap_dStateCanair ! canopy evaporation after canopy air temperature is perturbed (W m-2) - real(dp) :: latHeatCanEvap_dStateCanopy ! canopy evaporation after canopy temperature is perturbed (W m-2) - real(dp) :: latHeatCanEvap_dStateGround ! canopy evaporation after ground temperature is perturbed (W m-2) - real(dp) :: latHeatCanEvap_dStateCanLiq ! canopy evaporation after canopy liquid water content is perturbed (W m-2) + real(rkind) :: latHeatCanEvap_dStateCanair ! canopy evaporation after canopy air temperature is perturbed (W m-2) + real(rkind) :: latHeatCanEvap_dStateCanopy ! canopy evaporation after canopy temperature is perturbed (W m-2) + real(rkind) :: latHeatCanEvap_dStateGround ! canopy evaporation after ground temperature is perturbed (W m-2) + real(rkind) :: latHeatCanEvap_dStateCanLiq ! canopy evaporation after canopy liquid water content is perturbed (W m-2) ! (flux derivatives -- canopy air space) - real(dp) :: dTurbFluxCanair_dTCanair ! derivative in net canopy air space fluxes w.r.t. canopy air temperature (W m-2 K-1) - real(dp) :: dTurbFluxCanair_dTCanopy ! derivative in net canopy air space fluxes w.r.t. canopy temperature (W m-2 K-1) - real(dp) :: dTurbFluxCanair_dTGround ! derivative in net canopy air space fluxes w.r.t. ground temperature (W m-2 K-1) - real(dp) :: dTurbFluxCanair_dCanLiq ! derivative in net canopy air space fluxes w.r.t. canopy liquid water content (J kg-1 s-1) + real(rkind) :: dTurbFluxCanair_dTCanair ! derivative in net canopy air space fluxes w.r.t. canopy air temperature (W m-2 K-1) + real(rkind) :: dTurbFluxCanair_dTCanopy ! derivative in net canopy air space fluxes w.r.t. canopy temperature (W m-2 K-1) + real(rkind) :: dTurbFluxCanair_dTGround ! derivative in net canopy air space fluxes w.r.t. ground temperature (W m-2 K-1) + real(rkind) :: dTurbFluxCanair_dCanLiq ! derivative in net canopy air space fluxes w.r.t. canopy liquid water content (J kg-1 s-1) ! (flux derivatives -- vegetation canopy) - real(dp) :: dTurbFluxCanopy_dTCanair ! derivative in net canopy turbulent fluxes w.r.t. canopy air temperature (W m-2 K-1) - real(dp) :: dTurbFluxCanopy_dTCanopy ! derivative in net canopy turbulent fluxes w.r.t. canopy temperature (W m-2 K-1) - real(dp) :: dTurbFluxCanopy_dTGround ! derivative in net canopy turbulent fluxes w.r.t. ground temperature (W m-2 K-1) - real(dp) :: dTurbFluxCanopy_dCanLiq ! derivative in net canopy turbulent fluxes w.r.t. canopy liquid water content (J kg-1 s-1) + real(rkind) :: dTurbFluxCanopy_dTCanair ! derivative in net canopy turbulent fluxes w.r.t. canopy air temperature (W m-2 K-1) + real(rkind) :: dTurbFluxCanopy_dTCanopy ! derivative in net canopy turbulent fluxes w.r.t. canopy temperature (W m-2 K-1) + real(rkind) :: dTurbFluxCanopy_dTGround ! derivative in net canopy turbulent fluxes w.r.t. ground temperature (W m-2 K-1) + real(rkind) :: dTurbFluxCanopy_dCanLiq ! derivative in net canopy turbulent fluxes w.r.t. canopy liquid water content (J kg-1 s-1) ! (flux derivatives -- ground surface) - real(dp) :: dTurbFluxGround_dTCanair ! derivative in net ground turbulent fluxes w.r.t. canopy air temperature (W m-2 K-1) - real(dp) :: dTurbFluxGround_dTCanopy ! derivative in net ground turbulent fluxes w.r.t. canopy temperature (W m-2 K-1) - real(dp) :: dTurbFluxGround_dTGround ! derivative in net ground turbulent fluxes w.r.t. ground temperature (W m-2 K-1) - real(dp) :: dTurbFluxGround_dCanLiq ! derivative in net ground turbulent fluxes w.r.t. canopy liquid water content (J kg-1 s-1) + real(rkind) :: dTurbFluxGround_dTCanair ! derivative in net ground turbulent fluxes w.r.t. canopy air temperature (W m-2 K-1) + real(rkind) :: dTurbFluxGround_dTCanopy ! derivative in net ground turbulent fluxes w.r.t. canopy temperature (W m-2 K-1) + real(rkind) :: dTurbFluxGround_dTGround ! derivative in net ground turbulent fluxes w.r.t. ground temperature (W m-2 K-1) + real(rkind) :: dTurbFluxGround_dCanLiq ! derivative in net ground turbulent fluxes w.r.t. canopy liquid water content (J kg-1 s-1) ! (liquid water flux derivatives -- canopy evap) - real(dp) :: dLatHeatCanopyEvap_dCanLiq ! derivative in latent heat of canopy evaporation w.r.t. canopy liquid water content (W kg-1) - real(dp) :: dLatHeatCanopyEvap_dTCanair ! derivative in latent heat of canopy evaporation w.r.t. canopy air temperature (W m-2 K-1) - real(dp) :: dLatHeatCanopyEvap_dTCanopy ! derivative in latent heat of canopy evaporation w.r.t. canopy temperature (W m-2 K-1) - real(dp) :: dLatHeatCanopyEvap_dTGround ! derivative in latent heat of canopy evaporation w.r.t. ground temperature (W m-2 K-1) + real(rkind) :: dLatHeatCanopyEvap_dCanLiq ! derivative in latent heat of canopy evaporation w.r.t. canopy liquid water content (W kg-1) + real(rkind) :: dLatHeatCanopyEvap_dTCanair ! derivative in latent heat of canopy evaporation w.r.t. canopy air temperature (W m-2 K-1) + real(rkind) :: dLatHeatCanopyEvap_dTCanopy ! derivative in latent heat of canopy evaporation w.r.t. canopy temperature (W m-2 K-1) + real(rkind) :: dLatHeatCanopyEvap_dTGround ! derivative in latent heat of canopy evaporation w.r.t. ground temperature (W m-2 K-1) ! (liquid water flux derivatives -- ground evap) - real(dp) :: dLatHeatGroundEvap_dCanLiq ! derivative in latent heat of ground evaporation w.r.t. canopy liquid water content (J kg-1 s-1) - real(dp) :: dLatHeatGroundEvap_dTCanair ! derivative in latent heat of ground evaporation w.r.t. canopy air temperature (W m-2 K-1) - real(dp) :: dLatHeatGroundEvap_dTCanopy ! derivative in latent heat of ground evaporation w.r.t. canopy temperature (W m-2 K-1) - real(dp) :: dLatHeatGroundEvap_dTGround ! derivative in latent heat of ground evaporation w.r.t. ground temperature (W m-2 K-1) + real(rkind) :: dLatHeatGroundEvap_dCanLiq ! derivative in latent heat of ground evaporation w.r.t. canopy liquid water content (J kg-1 s-1) + real(rkind) :: dLatHeatGroundEvap_dTCanair ! derivative in latent heat of ground evaporation w.r.t. canopy air temperature (W m-2 K-1) + real(rkind) :: dLatHeatGroundEvap_dTCanopy ! derivative in latent heat of ground evaporation w.r.t. canopy temperature (W m-2 K-1) + real(rkind) :: dLatHeatGroundEvap_dTGround ! derivative in latent heat of ground evaporation w.r.t. ground temperature (W m-2 K-1) ! --------------------------------------------------------------------------------------- ! point to variables in the data structure @@ -624,47 +624,47 @@ subroutine vegNrgFlux(& case(prescribedTemp,zeroFlux) ! derived fluxes - scalarTotalET = 0._dp ! total ET (kg m-2 s-1) - scalarNetRadiation = 0._dp ! net radiation (W m-2) + scalarTotalET = 0._rkind ! total ET (kg m-2 s-1) + scalarNetRadiation = 0._rkind ! net radiation (W m-2) ! liquid water fluxes associated with evaporation/transpiration - scalarCanopyTranspiration = 0._dp ! canopy transpiration (kg m-2 s-1) - scalarCanopyEvaporation = 0._dp ! canopy evaporation/condensation (kg m-2 s-1) - scalarGroundEvaporation = 0._dp ! ground evaporation/condensation -- below canopy or non-vegetated (kg m-2 s-1) + scalarCanopyTranspiration = 0._rkind ! canopy transpiration (kg m-2 s-1) + scalarCanopyEvaporation = 0._rkind ! canopy evaporation/condensation (kg m-2 s-1) + scalarGroundEvaporation = 0._rkind ! ground evaporation/condensation -- below canopy or non-vegetated (kg m-2 s-1) ! solid water fluxes associated with sublimation/frost - scalarCanopySublimation = 0._dp ! sublimation from the vegetation canopy ((kg m-2 s-1) - scalarSnowSublimation = 0._dp ! sublimation from the snow surface ((kg m-2 s-1) + scalarCanopySublimation = 0._rkind ! sublimation from the vegetation canopy ((kg m-2 s-1) + scalarSnowSublimation = 0._rkind ! sublimation from the snow surface ((kg m-2 s-1) ! set canopy fluxes to zero (no canopy) - canairNetFlux = 0._dp ! net energy flux for the canopy air space (W m-2) - canopyNetFlux = 0._dp ! net energy flux for the vegetation canopy (W m-2) + canairNetFlux = 0._rkind ! net energy flux for the canopy air space (W m-2) + canopyNetFlux = 0._rkind ! net energy flux for the vegetation canopy (W m-2) ! set canopy derivatives to zero - dCanairNetFlux_dCanairTemp = 0._dp ! derivative in net canopy air space flux w.r.t. canopy air temperature (W m-2 K-1) - dCanairNetFlux_dCanopyTemp = 0._dp ! derivative in net canopy air space flux w.r.t. canopy temperature (W m-2 K-1) - dCanairNetFlux_dGroundTemp = 0._dp ! derivative in net canopy air space flux w.r.t. ground temperature (W m-2 K-1) - dCanopyNetFlux_dCanairTemp = 0._dp ! derivative in net canopy flux w.r.t. canopy air temperature (W m-2 K-1) - dCanopyNetFlux_dCanopyTemp = 0._dp ! derivative in net canopy flux w.r.t. canopy temperature (W m-2 K-1) - dCanopyNetFlux_dGroundTemp = 0._dp ! derivative in net canopy flux w.r.t. ground temperature (W m-2 K-1) - dGroundNetFlux_dCanairTemp = 0._dp ! derivative in net ground flux w.r.t. canopy air temperature (W m-2 K-1) - dGroundNetFlux_dCanopyTemp = 0._dp ! derivative in net ground flux w.r.t. canopy temperature (W m-2 K-1) + dCanairNetFlux_dCanairTemp = 0._rkind ! derivative in net canopy air space flux w.r.t. canopy air temperature (W m-2 K-1) + dCanairNetFlux_dCanopyTemp = 0._rkind ! derivative in net canopy air space flux w.r.t. canopy temperature (W m-2 K-1) + dCanairNetFlux_dGroundTemp = 0._rkind ! derivative in net canopy air space flux w.r.t. ground temperature (W m-2 K-1) + dCanopyNetFlux_dCanairTemp = 0._rkind ! derivative in net canopy flux w.r.t. canopy air temperature (W m-2 K-1) + dCanopyNetFlux_dCanopyTemp = 0._rkind ! derivative in net canopy flux w.r.t. canopy temperature (W m-2 K-1) + dCanopyNetFlux_dGroundTemp = 0._rkind ! derivative in net canopy flux w.r.t. ground temperature (W m-2 K-1) + dGroundNetFlux_dCanairTemp = 0._rkind ! derivative in net ground flux w.r.t. canopy air temperature (W m-2 K-1) + dGroundNetFlux_dCanopyTemp = 0._rkind ! derivative in net ground flux w.r.t. canopy temperature (W m-2 K-1) ! set liquid flux derivatives to zero (canopy evap) - dCanopyEvaporation_dCanLiq = 0._dp ! derivative in canopy evaporation w.r.t. canopy liquid water content (s-1) - dCanopyEvaporation_dTCanair= 0._dp ! derivative in canopy evaporation w.r.t. canopy air temperature (kg m-2 s-1 K-1) - dCanopyEvaporation_dTCanopy= 0._dp ! derivative in canopy evaporation w.r.t. canopy temperature (kg m-2 s-1 K-1) - dCanopyEvaporation_dTGround= 0._dp ! derivative in canopy evaporation w.r.t. ground temperature (kg m-2 s-1 K-1) + dCanopyEvaporation_dCanLiq = 0._rkind ! derivative in canopy evaporation w.r.t. canopy liquid water content (s-1) + dCanopyEvaporation_dTCanair= 0._rkind ! derivative in canopy evaporation w.r.t. canopy air temperature (kg m-2 s-1 K-1) + dCanopyEvaporation_dTCanopy= 0._rkind ! derivative in canopy evaporation w.r.t. canopy temperature (kg m-2 s-1 K-1) + dCanopyEvaporation_dTGround= 0._rkind ! derivative in canopy evaporation w.r.t. ground temperature (kg m-2 s-1 K-1) ! set liquid flux derivatives to zero (ground evap) - dGroundEvaporation_dCanLiq = 0._dp ! derivative in ground evaporation w.r.t. canopy liquid water content (s-1) - dGroundEvaporation_dTCanair= 0._dp ! derivative in ground evaporation w.r.t. canopy air temperature (kg m-2 s-1 K-1) - dGroundEvaporation_dTCanopy= 0._dp ! derivative in ground evaporation w.r.t. canopy temperature (kg m-2 s-1 K-1) - dGroundEvaporation_dTGround= 0._dp ! derivative in ground evaporation w.r.t. ground temperature (kg m-2 s-1 K-1) + dGroundEvaporation_dCanLiq = 0._rkind ! derivative in ground evaporation w.r.t. canopy liquid water content (s-1) + dGroundEvaporation_dTCanair= 0._rkind ! derivative in ground evaporation w.r.t. canopy air temperature (kg m-2 s-1 K-1) + dGroundEvaporation_dTCanopy= 0._rkind ! derivative in ground evaporation w.r.t. canopy temperature (kg m-2 s-1 K-1) + dGroundEvaporation_dTGround= 0._rkind ! derivative in ground evaporation w.r.t. ground temperature (kg m-2 s-1 K-1) ! compute fluxes and derivatives -- separate approach for prescribed temperature and zero flux if(ix_bcUpprTdyn == prescribedTemp)then ! compute ground net flux (W m-2) - groundNetFlux = -diag_data%var(iLookDIAG%iLayerThermalC)%dat(0)*(groundTempTrial - upperBoundTemp)/(prog_data%var(iLookPROG%mLayerDepth)%dat(1)*0.5_dp) + groundNetFlux = -diag_data%var(iLookDIAG%iLayerThermalC)%dat(0)*(groundTempTrial - upperBoundTemp)/(prog_data%var(iLookPROG%mLayerDepth)%dat(1)*0.5_rkind) ! compute derivative in net ground flux w.r.t. ground temperature (W m-2 K-1) - dGroundNetFlux_dGroundTemp = -diag_data%var(iLookDIAG%iLayerThermalC)%dat(0)/(prog_data%var(iLookPROG%mLayerDepth)%dat(1)*0.5_dp) + dGroundNetFlux_dGroundTemp = -diag_data%var(iLookDIAG%iLayerThermalC)%dat(0)/(prog_data%var(iLookPROG%mLayerDepth)%dat(1)*0.5_rkind) elseif(model_decisions(iLookDECISIONS%bcUpprTdyn)%iDecision == zeroFlux)then - groundNetFlux = 0._dp - dGroundNetFlux_dGroundTemp = 0._dp + groundNetFlux = 0._rkind + dGroundNetFlux_dGroundTemp = 0._rkind else err=20; message=trim(message)//'unable to identify upper boundary condition for thermodynamics: expect the case to be prescribedTemp or zeroFlux'; return end if @@ -700,8 +700,8 @@ subroutine vegNrgFlux(& if(firstFluxCall .and. firstSubStep)then ! vapor pressure in the canopy air space initialized as vapor pressure of air above the vegetation canopy ! NOTE: this is needed for the stomatal resistance calculations - if(scalarVP_CanopyAir < 0._dp)then - scalarVP_CanopyAir = scalarVPair - 1._dp ! "small" offset used to assist in checking initial derivative calculations + if(scalarVP_CanopyAir < 0._rkind)then + scalarVP_CanopyAir = scalarVPair - 1._rkind ! "small" offset used to assist in checking initial derivative calculations end if end if @@ -713,17 +713,17 @@ subroutine vegNrgFlux(& if(nSnow > 0)then if(groundTempTrial > Tfreeze)then; err=20; message=trim(message)//'do not expect ground temperature > 0 when snow is on the ground'; return; end if scalarLatHeatSubVapGround = LH_sub ! sublimation from snow - scalarGroundSnowFraction = 1._dp + scalarGroundSnowFraction = 1._rkind ! case when the ground is snow-free else scalarLatHeatSubVapGround = LH_vap ! evaporation of water in the soil pores: this occurs even if frozen because of super-cooled water - scalarGroundSnowFraction = 0._dp + scalarGroundSnowFraction = 0._rkind end if ! (if there is snow on the ground) end if ! (if the first flux call) !write(*,'(a,1x,10(f30.10,1x))') 'groundTempTrial, scalarLatHeatSubVapGround = ', groundTempTrial, scalarLatHeatSubVapGround ! compute the roughness length of the ground (ground below the canopy or non-vegetated surface) - z0Ground = z0soil*(1._dp - scalarGroundSnowFraction) + z0Snow*scalarGroundSnowFraction ! roughness length (m) + z0Ground = z0soil*(1._rkind - scalarGroundSnowFraction) + z0Snow*scalarGroundSnowFraction ! roughness length (m) ! compute the total vegetation area index (leaf plus stem) VAI = scalarLAI + scalarSAI ! vegetation area index @@ -734,16 +734,16 @@ subroutine vegNrgFlux(& select case(ix_canopyEmis) ! *** simple exponential function case(simplExp) - scalarCanopyEmissivity = 1._dp - exp(-exposedVAI) ! effective emissivity of the canopy (-) + scalarCanopyEmissivity = 1._rkind - exp(-exposedVAI) ! effective emissivity of the canopy (-) ! *** canopy emissivity parameterized as a function of diffuse transmissivity case(difTrans) ! compute the exponential integral - scaleLAI = 0.5_dp*exposedVAI + scaleLAI = 0.5_rkind*exposedVAI expi = expInt(scaleLAI) ! compute diffuse transmissivity (-) - diffuseTrans = (1._dp - scaleLAI)*exp(-scaleLAI) + (scaleLAI**2._dp)*expi + diffuseTrans = (1._rkind - scaleLAI)*exp(-scaleLAI) + (scaleLAI**2._rkind)*expi ! compute the canopy emissivity - scalarCanopyEmissivity = (1._dp - diffuseTrans)*vegEmissivity + scalarCanopyEmissivity = (1._rkind - diffuseTrans)*vegEmissivity ! *** check we found the correct option case default err=20; message=trim(message)//'unable to identify option for canopy emissivity'; return @@ -751,10 +751,10 @@ subroutine vegNrgFlux(& end if ! ensure canopy longwave fluxes are zero when not computing canopy fluxes - if(.not.computeVegFlux) scalarCanopyEmissivity=0._dp + if(.not.computeVegFlux) scalarCanopyEmissivity=0._rkind ! compute emissivity of the ground surface (-) - groundEmissivity = scalarGroundSnowFraction*snowEmissivity + (1._dp - scalarGroundSnowFraction)*soilEmissivity ! emissivity of the ground surface (-) + groundEmissivity = scalarGroundSnowFraction*snowEmissivity + (1._rkind - scalarGroundSnowFraction)*soilEmissivity ! emissivity of the ground surface (-) ! compute the fraction of canopy that is wet ! NOTE: we either sublimate or evaporate over the entire substep @@ -762,10 +762,10 @@ subroutine vegNrgFlux(& ! compute the fraction of liquid water in the canopy (-) totalCanopyWater = canopyLiqTrial + canopyIceTrial - if(totalCanopyWater > tiny(1.0_dp))then + if(totalCanopyWater > tiny(1.0_rkind))then fracLiquidCanopy = canopyLiqTrial / (canopyLiqTrial + canopyIceTrial) else - fracLiquidCanopy = 0._dp + fracLiquidCanopy = 0._rkind end if ! get wetted fraction and derivatives @@ -790,9 +790,9 @@ subroutine vegNrgFlux(& if(err/=0)then; message=trim(message)//trim(cmessage); return; end if else - scalarCanopyWetFraction = 0._dp ! canopy wetted fraction (-) - dCanopyWetFraction_dWat = 0._dp ! derivative in wetted fraction w.r.t. canopy liquid water (kg-1 m2) - dCanopyWetFraction_dT = 0._dp ! derivative in wetted fraction w.r.t. canopy temperature (K-1) + scalarCanopyWetFraction = 0._rkind ! canopy wetted fraction (-) + dCanopyWetFraction_dWat = 0._rkind ! derivative in wetted fraction w.r.t. canopy liquid water (kg-1 m2) + dCanopyWetFraction_dT = 0._rkind ! derivative in wetted fraction w.r.t. canopy temperature (K-1) end if !write(*,'(a,1x,L1,1x,f25.15,1x))') 'computeVegFlux, scalarCanopyWetFraction = ', computeVegFlux, scalarCanopyWetFraction !print*, 'dCanopyWetFraction_dWat = ', dCanopyWetFraction_dWat @@ -1068,7 +1068,7 @@ subroutine vegNrgFlux(& if(err/=0)then; message=trim(message)//trim(cmessage); return; end if else - canopyWetFraction = 0._dp + canopyWetFraction = 0._rkind end if !print*, 'wetted fraction derivative = ', (canopyWetFraction - scalarCanopyWetFraction)/dx !pause @@ -1168,15 +1168,15 @@ subroutine vegNrgFlux(& ! (soil water evaporation factor [0-1]) soilEvapFactor = mLayerVolFracLiq(nSnow+1)/(theta_sat - theta_res) ! (resistance from the soil [s m-1]) - scalarSoilResistance = scalarGroundSnowFraction*1._dp + (1._dp - scalarGroundSnowFraction)*EXP(8.25_dp - 4.225_dp*soilEvapFactor) ! Sellers (1992) - !scalarSoilResistance = scalarGroundSnowFraction*0._dp + (1._dp - scalarGroundSnowFraction)*exp(8.25_dp - 6.0_dp*soilEvapFactor) ! Niu adjustment to decrease resitance for wet soil + scalarSoilResistance = scalarGroundSnowFraction*1._rkind + (1._rkind - scalarGroundSnowFraction)*EXP(8.25_rkind - 4.225_rkind*soilEvapFactor) ! Sellers (1992) + !scalarSoilResistance = scalarGroundSnowFraction*0._rkind + (1._rkind - scalarGroundSnowFraction)*exp(8.25_rkind - 6.0_rkind*soilEvapFactor) ! Niu adjustment to decrease resitance for wet soil ! (relative humidity in the soil pores [0-1]) - if(mLayerMatricHead(1) > -1.e+6_dp)then ! avoid problems with numerical precision when soil is very dry + if(mLayerMatricHead(1) > -1.e+6_rkind)then ! avoid problems with numerical precision when soil is very dry soilRelHumidity_noSnow = exp( (mLayerMatricHead(1)*gravity) / (groundTemp*R_wv) ) else - soilRelHumidity_noSnow = 0._dp + soilRelHumidity_noSnow = 0._rkind end if ! (if matric head is very low) - scalarSoilRelHumidity = scalarGroundSnowFraction*1._dp + (1._dp - scalarGroundSnowFraction)*soilRelHumidity_noSnow + scalarSoilRelHumidity = scalarGroundSnowFraction*1._rkind + (1._rkind - scalarGroundSnowFraction)*soilRelHumidity_noSnow !print*, 'mLayerMatricHead(1), scalarSoilRelHumidity = ', mLayerMatricHead(1), scalarSoilRelHumidity end if ! (if the first flux call) @@ -1396,21 +1396,21 @@ subroutine vegNrgFlux(& !print*, 'scalarLatHeatGround = ', scalarLatHeatGround ! (canopy transpiration/sublimation) if(scalarLatHeatSubVapCanopy > LH_vap+verySmall)then ! sublimation - scalarCanopyEvaporation = 0._dp + scalarCanopyEvaporation = 0._rkind scalarCanopySublimation = scalarLatHeatCanopyEvap/LH_sub - if(scalarLatHeatCanopyTrans > 0._dp)then ! flux directed towards the veg + if(scalarLatHeatCanopyTrans > 0._rkind)then ! flux directed towards the veg scalarCanopySublimation = scalarCanopySublimation + scalarLatHeatCanopyTrans/LH_sub ! frost - scalarCanopyTranspiration = 0._dp + scalarCanopyTranspiration = 0._rkind else scalarCanopyTranspiration = scalarLatHeatCanopyTrans/LH_vap ! transpiration is always vapor end if ! (canopy transpiration/evaporation) else ! evaporation scalarCanopyEvaporation = scalarLatHeatCanopyEvap/LH_vap - scalarCanopySublimation = 0._dp - if(scalarLatHeatCanopyTrans > 0._dp)then ! flux directed towards the veg + scalarCanopySublimation = 0._rkind + if(scalarLatHeatCanopyTrans > 0._rkind)then ! flux directed towards the veg scalarCanopyEvaporation = scalarCanopyEvaporation + scalarLatHeatCanopyTrans/LH_vap - scalarCanopyTranspiration = 0._dp + scalarCanopyTranspiration = 0._rkind else scalarCanopyTranspiration = scalarLatHeatCanopyTrans/LH_vap end if @@ -1419,13 +1419,13 @@ subroutine vegNrgFlux(& if(scalarLatHeatSubVapGround > LH_vap+verySmall)then ! sublimation ! NOTE: this should only occur when we have formed snow layers, so check if(nSnow == 0)then; err=20; message=trim(message)//'only expect snow sublimation when we have formed some snow layers'; return; end if - scalarGroundEvaporation = 0._dp ! ground evaporation is zero once the snowpack has formed + scalarGroundEvaporation = 0._rkind ! ground evaporation is zero once the snowpack has formed scalarSnowSublimation = scalarLatHeatGround/LH_sub else ! NOTE: this should only occur when we have no snow layers, so check if(nSnow > 0)then; err=20; message=trim(message)//'only expect ground evaporation when there are no snow layers'; return; end if scalarGroundEvaporation = scalarLatHeatGround/LH_vap - scalarSnowSublimation = 0._dp ! no sublimation from snow if no snow layers have formed + scalarSnowSublimation = 0._rkind ! no sublimation from snow if no snow layers have formed end if !print*, 'scalarSnowSublimation, scalarLatHeatGround = ', scalarSnowSublimation, scalarLatHeatGround @@ -1472,10 +1472,10 @@ subroutine vegNrgFlux(& ! sublimation else - dCanopyEvaporation_dCanLiq = 0._dp ! (s-1) - dCanopyEvaporation_dTCanair = 0._dp ! (kg m-2 s-1 K-1) - dCanopyEvaporation_dTCanopy = 0._dp ! (kg m-2 s-1 K-1) - dCanopyEvaporation_dTGround = 0._dp ! (kg m-2 s-1 K-1) + dCanopyEvaporation_dCanLiq = 0._rkind ! (s-1) + dCanopyEvaporation_dTCanair = 0._rkind ! (kg m-2 s-1 K-1) + dCanopyEvaporation_dTCanopy = 0._rkind ! (kg m-2 s-1 K-1) + dCanopyEvaporation_dTGround = 0._rkind ! (kg m-2 s-1 K-1) end if ! compute the liquid water derivarives (ground evap) @@ -1542,25 +1542,25 @@ subroutine wettedFrac(& logical(lgt),intent(in) :: deriv ! flag to denote if derivative is desired logical(lgt),intent(in) :: derNum ! flag to denote that numerical derivatives are required (otherwise, analytical derivatives are calculated) logical(lgt),intent(in) :: frozen ! flag to denote if the canopy is frozen - real(dp),intent(in) :: dLiq_dT ! derivative in canopy liquid w.r.t. canopy temperature (kg m-2 K-1) - real(dp),intent(in) :: fracLiq ! fraction of liquid water on the canopy (-) - real(dp),intent(in) :: canopyLiq ! canopy liquid water (kg m-2) - real(dp),intent(in) :: canopyIce ! canopy ice (kg m-2) - real(dp),intent(in) :: canopyLiqMax ! maximum canopy liquid water (kg m-2) - real(dp),intent(in) :: canopyIceMax ! maximum canopy ice content (kg m-2) - real(dp),intent(in) :: canopyWettingFactor ! maximum wetted fraction of the canopy (-) - real(dp),intent(in) :: canopyWettingExp ! exponent in canopy wetting function (-) + real(rkind),intent(in) :: dLiq_dT ! derivative in canopy liquid w.r.t. canopy temperature (kg m-2 K-1) + real(rkind),intent(in) :: fracLiq ! fraction of liquid water on the canopy (-) + real(rkind),intent(in) :: canopyLiq ! canopy liquid water (kg m-2) + real(rkind),intent(in) :: canopyIce ! canopy ice (kg m-2) + real(rkind),intent(in) :: canopyLiqMax ! maximum canopy liquid water (kg m-2) + real(rkind),intent(in) :: canopyIceMax ! maximum canopy ice content (kg m-2) + real(rkind),intent(in) :: canopyWettingFactor ! maximum wetted fraction of the canopy (-) + real(rkind),intent(in) :: canopyWettingExp ! exponent in canopy wetting function (-) ! output - real(dp),intent(out) :: canopyWetFraction ! canopy wetted fraction (-) - real(dp),intent(out) :: dCanopyWetFraction_dWat ! derivative in wetted fraction w.r.t. canopy total water (kg-1 m2) - real(dp),intent(out) :: dCanopyWetFraction_dT ! derivative in wetted fraction w.r.t. canopy temperature (K-1) + real(rkind),intent(out) :: canopyWetFraction ! canopy wetted fraction (-) + real(rkind),intent(out) :: dCanopyWetFraction_dWat ! derivative in wetted fraction w.r.t. canopy total water (kg-1 m2) + real(rkind),intent(out) :: dCanopyWetFraction_dT ! derivative in wetted fraction w.r.t. canopy temperature (K-1) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! local variables logical(lgt),parameter :: smoothing=.true. ! flag to denote that smoothing is required - real(dp) :: canopyWetFractionPert ! canopy wetted fraction after state perturbations (-) - real(dp) :: canopyWetFractionDeriv ! derivative in wetted fraction w.r.t. canopy liquid water (kg-1 m2) + real(rkind) :: canopyWetFractionPert ! canopy wetted fraction after state perturbations (-) + real(rkind) :: canopyWetFractionDeriv ! derivative in wetted fraction w.r.t. canopy liquid water (kg-1 m2) ! ----------------------------------------------------------------------------------------------------------------------------------------------- ! initialize error control err=0; message='wettedFrac/' @@ -1575,14 +1575,14 @@ subroutine wettedFrac(& canopyWetFractionDeriv = (canopyWetFractionPert - canopyWetFraction)/dx end if ! scale derivative by the fraction of water - ! NOTE: dIce/dWat = (1._dp - fracLiq), hence dWet/dWat = dIce/dWat . dWet/dLiq - dCanopyWetFraction_dWat = canopyWetFractionDeriv*(1._dp - fracLiq) + ! NOTE: dIce/dWat = (1._rkind - fracLiq), hence dWet/dWat = dIce/dWat . dWet/dLiq + dCanopyWetFraction_dWat = canopyWetFractionDeriv*(1._rkind - fracLiq) dCanopyWetFraction_dT = -canopyWetFractionDeriv*dLiq_dT ! NOTE: dIce/dT = -dLiq/dT return end if ! compute fraction of liquid water on the canopy - ! NOTE: if(.not.deriv) canopyWetFractionDeriv = 0._dp + ! NOTE: if(.not.deriv) canopyWetFractionDeriv = 0._rkind call wetFraction((deriv .and. .not.derNum),smoothing,canopyLiq,canopyLiqMax,canopyWettingFactor,canopyWettingExp,canopyWetFraction,canopyWetFractionDeriv) ! compute numerical derivative @@ -1611,20 +1611,20 @@ subroutine wetFraction(derDesire,smoothing,canopyLiq,canopyMax,canopyWettingFact ! dummy variables logical(lgt),intent(in) :: derDesire ! flag to denote if analytical derivatives are desired logical(lgt),intent(in) :: smoothing ! flag to denote if smoothing is required - real(dp),intent(in) :: canopyLiq ! liquid water content (kg m-2) - real(dp),intent(in) :: canopyMax ! liquid water content (kg m-2) - real(dp),intent(in) :: canopyWettingFactor ! maximum wetted fraction of the canopy (-) - real(dp),intent(in) :: canopyWettingExp ! exponent in canopy wetting function (-) + real(rkind),intent(in) :: canopyLiq ! liquid water content (kg m-2) + real(rkind),intent(in) :: canopyMax ! liquid water content (kg m-2) + real(rkind),intent(in) :: canopyWettingFactor ! maximum wetted fraction of the canopy (-) + real(rkind),intent(in) :: canopyWettingExp ! exponent in canopy wetting function (-) - real(dp),intent(out) :: canopyWetFraction ! canopy wetted fraction (-) - real(dp),intent(out) :: canopyWetFractionDeriv ! derivative in wetted fraction w.r.t. canopy liquid water (kg-1 m2) + real(rkind),intent(out) :: canopyWetFraction ! canopy wetted fraction (-) + real(rkind),intent(out) :: canopyWetFractionDeriv ! derivative in wetted fraction w.r.t. canopy liquid water (kg-1 m2) ! local variables - real(dp) :: relativeCanopyWater ! water stored on vegetation canopy, expressed as a fraction of maximum storage (-) - real(dp) :: rawCanopyWetFraction ! initial value of the canopy wet fraction (before smoothing) - real(dp) :: rawWetFractionDeriv ! derivative in canopy wet fraction w.r.t. storage (kg-1 m2) - real(dp) :: smoothFunc ! smoothing function used to improve numerical stability at times with limited water storage (-) - real(dp) :: smoothFuncDeriv ! derivative in the smoothing function w.r.t.canopy storage (kg-1 m2) - real(dp) :: verySmall=epsilon(1._dp) ! a very small number + real(rkind) :: relativeCanopyWater ! water stored on vegetation canopy, expressed as a fraction of maximum storage (-) + real(rkind) :: rawCanopyWetFraction ! initial value of the canopy wet fraction (before smoothing) + real(rkind) :: rawWetFractionDeriv ! derivative in canopy wet fraction w.r.t. storage (kg-1 m2) + real(rkind) :: smoothFunc ! smoothing function used to improve numerical stability at times with limited water storage (-) + real(rkind) :: smoothFuncDeriv ! derivative in the smoothing function w.r.t.canopy storage (kg-1 m2) + real(rkind) :: verySmall=epsilon(1._rkind) ! a very small number ! -------------------------------------------------------------------------------------------------------------- ! compute relative canopy water @@ -1633,18 +1633,18 @@ subroutine wetFraction(derDesire,smoothing,canopyLiq,canopyMax,canopyWettingFact ! compute an initial value of the canopy wet fraction ! - canopy below value where canopy is 100% wet - if(relativeCanopyWater < 1._dp)then + if(relativeCanopyWater < 1._rkind)then rawCanopyWetFraction = canopyWettingFactor*(relativeCanopyWater**canopyWettingExp) if(derDesire .and. relativeCanopyWater>verySmall)then - rawWetFractionDeriv = (canopyWettingFactor*canopyWettingExp/canopyMax)*relativeCanopyWater**(canopyWettingExp - 1._dp) + rawWetFractionDeriv = (canopyWettingFactor*canopyWettingExp/canopyMax)*relativeCanopyWater**(canopyWettingExp - 1._rkind) else - rawWetFractionDeriv = 0._dp + rawWetFractionDeriv = 0._rkind end if ! - canopy is at capacity (canopyWettingFactor) else rawCanopyWetFraction = canopyWettingFactor - rawWetFractionDeriv = 0._dp + rawWetFractionDeriv = 0._rkind end if ! smooth canopy wetted fraction @@ -1660,7 +1660,7 @@ subroutine wetFraction(derDesire,smoothing,canopyLiq,canopyMax,canopyWettingFact if(derDesire .and. smoothing)then ! NOTE: raw derivative is used if not smoothing canopyWetFractionDeriv = rawWetFractionDeriv*smoothFunc + rawCanopyWetFraction*smoothFuncDeriv else - canopyWetFractionDeriv = 0._dp + canopyWetFractionDeriv = 0._rkind end if end subroutine wetFraction @@ -1673,15 +1673,15 @@ subroutine logisticSmoother(derDesire,canopyLiq,smoothFunc,smoothFuncDeriv) implicit none ! dummy variables logical(lgt),intent(in) :: derDesire ! flag to denote if analytical derivatives are desired - real(dp),intent(in) :: canopyLiq ! liquid water content (kg m-2) - real(dp),intent(out) :: smoothFunc ! smoothing function (-) - real(dp),intent(out) :: smoothFuncDeriv ! derivative in smoothing function (kg-1 m-2) + real(rkind),intent(in) :: canopyLiq ! liquid water content (kg m-2) + real(rkind),intent(out) :: smoothFunc ! smoothing function (-) + real(rkind),intent(out) :: smoothFuncDeriv ! derivative in smoothing function (kg-1 m-2) ! local variables - real(dp) :: xArg ! argument used in the smoothing function (-) - real(dp) :: expX ! exp(-xArg) -- used multiple times - real(dp),parameter :: smoothThresh=0.01_dp ! mid-point of the smoothing function (kg m-2) - real(dp),parameter :: smoothScale=0.001_dp ! scaling factor for the smoothing function (kg m-2) - real(dp),parameter :: xLimit=50._dp ! don't compute exponents for > xLimit + real(rkind) :: xArg ! argument used in the smoothing function (-) + real(rkind) :: expX ! exp(-xArg) -- used multiple times + real(rkind),parameter :: smoothThresh=0.01_rkind ! mid-point of the smoothing function (kg m-2) + real(rkind),parameter :: smoothScale=0.001_rkind ! scaling factor for the smoothing function (kg m-2) + real(rkind),parameter :: xLimit=50._rkind ! don't compute exponents for > xLimit ! -------------------------------------------------------------------------------------------------------------- ! compute argument in the smoothing function xArg = (canopyLiq - smoothThresh)/smoothScale @@ -1689,19 +1689,19 @@ subroutine logisticSmoother(derDesire,canopyLiq,smoothFunc,smoothFuncDeriv) ! only compute smoothing function for small exponents if(xArg > -xLimit .and. xArg < xLimit)then ! avoid huge exponents expX = exp(-xarg) ! (also used in the derivative) - smoothFunc = 1._dp / (1._dp + expX) ! (logistic smoother) + smoothFunc = 1._rkind / (1._rkind + expX) ! (logistic smoother) if(derDesire)then - smoothFuncDeriv = expX / (smoothScale * (1._dp + expX)**2._dp) ! (derivative in the smoothing function) + smoothFuncDeriv = expX / (smoothScale * (1._rkind + expX)**2._rkind) ! (derivative in the smoothing function) else - smoothFuncDeriv = 0._dp + smoothFuncDeriv = 0._rkind end if ! outside limits: special case of smooth exponents else - if(xArg < 0._dp)then; smoothFunc = 0._dp ! xArg < -xLimit - else; smoothFunc = 1._dp ! xArg > xLimit + if(xArg < 0._rkind)then; smoothFunc = 0._rkind ! xArg < -xLimit + else; smoothFunc = 1._rkind ! xArg > xLimit end if - smoothFuncDeriv = 0._dp + smoothFuncDeriv = 0._rkind end if ! check for huge exponents end subroutine logisticSmoother @@ -1752,34 +1752,34 @@ subroutine longwaveBal(& integer(i4b),intent(in) :: ixDerivMethod ! choice of method used to compute derivative (analytical or numerical) logical(lgt),intent(in) :: computeVegFlux ! flag to indicate if computing fluxes over vegetation ! input: canopy and ground temperature - real(dp),intent(in) :: canopyTemp ! canopy temperature (K) - real(dp),intent(in) :: groundTemp ! ground temperature (K) + real(rkind),intent(in) :: canopyTemp ! canopy temperature (K) + real(rkind),intent(in) :: groundTemp ! ground temperature (K) ! input: canopy and ground emissivity - real(dp),intent(in) :: emc ! canopy emissivity (-) - real(dp),intent(in) :: emg ! ground emissivity (-) + real(rkind),intent(in) :: emc ! canopy emissivity (-) + real(rkind),intent(in) :: emg ! ground emissivity (-) ! input: forcing - real(dp),intent(in) :: LWRadUbound ! downwelling longwave radiation at the upper boundary (W m-2) + real(rkind),intent(in) :: LWRadUbound ! downwelling longwave radiation at the upper boundary (W m-2) ! output: sources - real(dp),intent(out) :: LWRadCanopy ! longwave radiation emitted from the canopy (W m-2) - real(dp),intent(out) :: LWRadGround ! longwave radiation emitted at the ground surface (W m-2) + real(rkind),intent(out) :: LWRadCanopy ! longwave radiation emitted from the canopy (W m-2) + real(rkind),intent(out) :: LWRadGround ! longwave radiation emitted at the ground surface (W m-2) ! output: individual fluxes - real(dp),intent(out) :: LWRadUbound2Canopy ! downward atmospheric longwave radiation absorbed by the canopy (W m-2) - real(dp),intent(out) :: LWRadUbound2Ground ! downward atmospheric longwave radiation absorbed by the ground (W m-2) - real(dp),intent(out) :: LWRadUbound2Ubound ! atmospheric radiation reflected by the ground and lost thru upper boundary (W m-2) - real(dp),intent(out) :: LWRadCanopy2Ubound ! longwave radiation emitted from canopy lost thru upper boundary (W m-2) - real(dp),intent(out) :: LWRadCanopy2Ground ! longwave radiation emitted from canopy absorbed by the ground (W m-2) - real(dp),intent(out) :: LWRadCanopy2Canopy ! canopy longwave reflected from ground and absorbed by the canopy (W m-2) - real(dp),intent(out) :: LWRadGround2Ubound ! longwave radiation emitted from ground lost thru upper boundary (W m-2) - real(dp),intent(out) :: LWRadGround2Canopy ! longwave radiation emitted from ground and absorbed by the canopy (W m-2) + real(rkind),intent(out) :: LWRadUbound2Canopy ! downward atmospheric longwave radiation absorbed by the canopy (W m-2) + real(rkind),intent(out) :: LWRadUbound2Ground ! downward atmospheric longwave radiation absorbed by the ground (W m-2) + real(rkind),intent(out) :: LWRadUbound2Ubound ! atmospheric radiation reflected by the ground and lost thru upper boundary (W m-2) + real(rkind),intent(out) :: LWRadCanopy2Ubound ! longwave radiation emitted from canopy lost thru upper boundary (W m-2) + real(rkind),intent(out) :: LWRadCanopy2Ground ! longwave radiation emitted from canopy absorbed by the ground (W m-2) + real(rkind),intent(out) :: LWRadCanopy2Canopy ! canopy longwave reflected from ground and absorbed by the canopy (W m-2) + real(rkind),intent(out) :: LWRadGround2Ubound ! longwave radiation emitted from ground lost thru upper boundary (W m-2) + real(rkind),intent(out) :: LWRadGround2Canopy ! longwave radiation emitted from ground and absorbed by the canopy (W m-2) ! output: net fluxes - real(dp),intent(out) :: LWNetCanopy ! net longwave radiation at the canopy (W m-2) - real(dp),intent(out) :: LWNetGround ! net longwave radiation at the ground surface (W m-2) - real(dp),intent(out) :: LWNetUbound ! net longwave radiation at the upper boundary (W m-2) + real(rkind),intent(out) :: LWNetCanopy ! net longwave radiation at the canopy (W m-2) + real(rkind),intent(out) :: LWNetGround ! net longwave radiation at the ground surface (W m-2) + real(rkind),intent(out) :: LWNetUbound ! net longwave radiation at the upper boundary (W m-2) ! output: flux derivatives - real(dp),intent(out) :: dLWNetCanopy_dTCanopy ! derivative in net canopy radiation w.r.t. canopy temperature (W m-2 K-1) - real(dp),intent(out) :: dLWNetGround_dTGround ! derivative in net ground radiation w.r.t. ground temperature (W m-2 K-1) - real(dp),intent(out) :: dLWNetCanopy_dTGround ! derivative in net canopy radiation w.r.t. ground temperature (W m-2 K-1) - real(dp),intent(out) :: dLWNetGround_dTCanopy ! derivative in net ground radiation w.r.t. canopy temperature (W m-2 K-1) + real(rkind),intent(out) :: dLWNetCanopy_dTCanopy ! derivative in net canopy radiation w.r.t. canopy temperature (W m-2 K-1) + real(rkind),intent(out) :: dLWNetGround_dTGround ! derivative in net ground radiation w.r.t. ground temperature (W m-2 K-1) + real(rkind),intent(out) :: dLWNetCanopy_dTGround ! derivative in net canopy radiation w.r.t. ground temperature (W m-2 K-1) + real(rkind),intent(out) :: dLWNetGround_dTCanopy ! derivative in net ground radiation w.r.t. canopy temperature (W m-2 K-1) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message @@ -1790,16 +1790,16 @@ subroutine longwaveBal(& integer(i4b),parameter :: perturbStateGround=3 ! named variable to identify the case where we perturb the ground temperature integer(i4b) :: itry ! index of flux evaluation integer(i4b) :: nFlux ! number of flux evaluations - real(dp) :: TCan ! value of canopy temperature used in flux calculations (may be perturbed) - real(dp) :: TGnd ! value of ground temperature used in flux calculations (may be perturbed) - real(dp) :: fluxBalance ! check energy closure (W m-2) - real(dp),parameter :: fluxTolerance=1.e-10_dp ! tolerance for energy closure (W m-2) - real(dp) :: dLWRadCanopy_dTCanopy ! derivative in emitted radiation at the canopy w.r.t. canopy temperature - real(dp) :: dLWRadGround_dTGround ! derivative in emitted radiation at the ground w.r.t. ground temperature - real(dp) :: LWNetCanopy_dStateCanopy ! net lw canopy flux after perturbation in canopy temperature - real(dp) :: LWNetGround_dStateCanopy ! net lw ground flux after perturbation in canopy temperature - real(dp) :: LWNetCanopy_dStateGround ! net lw canopy flux after perturbation in ground temperature - real(dp) :: LWNetGround_dStateGround ! net lw ground flux after perturbation in ground temperature + real(rkind) :: TCan ! value of canopy temperature used in flux calculations (may be perturbed) + real(rkind) :: TGnd ! value of ground temperature used in flux calculations (may be perturbed) + real(rkind) :: fluxBalance ! check energy closure (W m-2) + real(rkind),parameter :: fluxTolerance=1.e-10_rkind ! tolerance for energy closure (W m-2) + real(rkind) :: dLWRadCanopy_dTCanopy ! derivative in emitted radiation at the canopy w.r.t. canopy temperature + real(rkind) :: dLWRadGround_dTGround ! derivative in emitted radiation at the ground w.r.t. ground temperature + real(rkind) :: LWNetCanopy_dStateCanopy ! net lw canopy flux after perturbation in canopy temperature + real(rkind) :: LWNetGround_dStateCanopy ! net lw ground flux after perturbation in canopy temperature + real(rkind) :: LWNetCanopy_dStateGround ! net lw canopy flux after perturbation in ground temperature + real(rkind) :: LWNetGround_dStateGround ! net lw ground flux after perturbation in ground temperature ! ----------------------------------------------------------------------------------------------------------------------------------------------- ! initialize error control err=0; message='longwaveBal/' @@ -1851,28 +1851,28 @@ subroutine longwaveBal(& ! compute longwave fluxes from canopy and the ground if(computeVegFlux)then - LWRadCanopy = emc*sb*TCan**4._dp ! longwave radiation emitted from the canopy (W m-2) + LWRadCanopy = emc*sb*TCan**4._rkind ! longwave radiation emitted from the canopy (W m-2) else - LWRadCanopy = 0._dp + LWRadCanopy = 0._rkind end if - LWRadGround = emg*sb*TGnd**4._dp ! longwave radiation emitted at the ground surface (W m-2) + LWRadGround = emg*sb*TGnd**4._rkind ! longwave radiation emitted at the ground surface (W m-2) ! compute fluxes originating from the atmosphere - LWRadUbound2Canopy = (emc + (1._dp - emc)*(1._dp - emg)*emc)*LWRadUbound ! downward atmospheric longwave radiation absorbed by the canopy (W m-2) - LWRadUbound2Ground = (1._dp - emc)*emg*LWRadUbound ! downward atmospheric longwave radiation absorbed by the ground (W m-2) - LWRadUbound2Ubound = (1._dp - emc)*(1._dp - emg)*(1._dp - emc)*LWRadUbound ! atmospheric radiation reflected by the ground and lost thru upper boundary (W m-2) + LWRadUbound2Canopy = (emc + (1._rkind - emc)*(1._rkind - emg)*emc)*LWRadUbound ! downward atmospheric longwave radiation absorbed by the canopy (W m-2) + LWRadUbound2Ground = (1._rkind - emc)*emg*LWRadUbound ! downward atmospheric longwave radiation absorbed by the ground (W m-2) + LWRadUbound2Ubound = (1._rkind - emc)*(1._rkind - emg)*(1._rkind - emc)*LWRadUbound ! atmospheric radiation reflected by the ground and lost thru upper boundary (W m-2) ! compute fluxes originating from the canopy - LWRadCanopy2Ubound = (1._dp + (1._dp - emc)*(1._dp - emg))*LWRadCanopy ! longwave radiation emitted from canopy lost thru upper boundary (W m-2) + LWRadCanopy2Ubound = (1._rkind + (1._rkind - emc)*(1._rkind - emg))*LWRadCanopy ! longwave radiation emitted from canopy lost thru upper boundary (W m-2) LWRadCanopy2Ground = emg*LWRadCanopy ! longwave radiation emitted from canopy absorbed by the ground (W m-2) - LWRadCanopy2Canopy = emc*(1._dp - emg)*LWRadCanopy ! canopy longwave reflected from ground and absorbed by the canopy (W m-2) + LWRadCanopy2Canopy = emc*(1._rkind - emg)*LWRadCanopy ! canopy longwave reflected from ground and absorbed by the canopy (W m-2) ! compute fluxes originating from the ground surface - LWRadGround2Ubound = (1._dp - emc)*LWRadGround ! longwave radiation emitted from ground lost thru upper boundary (W m-2) + LWRadGround2Ubound = (1._rkind - emc)*LWRadGround ! longwave radiation emitted from ground lost thru upper boundary (W m-2) LWRadGround2Canopy = emc*LWRadGround ! longwave radiation emitted from ground and absorbed by the canopy (W m-2) ! compute net longwave radiation (W m-2) - LWNetCanopy = LWRadUbound2Canopy + LWRadGround2Canopy + LWRadCanopy2Canopy - 2._dp*LWRadCanopy ! canopy + LWNetCanopy = LWRadUbound2Canopy + LWRadGround2Canopy + LWRadCanopy2Canopy - 2._rkind*LWRadCanopy ! canopy LWNetGround = LWRadUbound2Ground + LWRadCanopy2Ground - LWRadGround ! ground surface LWNetUbound = LWRadUbound - LWRadUbound2Ubound - LWRadCanopy2Ubound - LWRadGround2Ubound ! upper boundary @@ -1933,10 +1933,10 @@ subroutine longwaveBal(& ! ***** analytical derivatives case(analytical) ! compute initial derivatives - dLWRadCanopy_dTCanopy = 4._dp*emc*sb*TCan**3._dp - dLWRadGround_dTGround = 4._dp*emg*sb*TGnd**3._dp + dLWRadCanopy_dTCanopy = 4._rkind*emc*sb*TCan**3._rkind + dLWRadGround_dTGround = 4._rkind*emg*sb*TGnd**3._rkind ! compute analytical derivatives - dLWNetCanopy_dTCanopy = (emc*(1._dp - emg) - 2._dp)*dLWRadCanopy_dTCanopy ! derivative in net canopy radiation w.r.t. canopy temperature (W m-2 K-1) + dLWNetCanopy_dTCanopy = (emc*(1._rkind - emg) - 2._rkind)*dLWRadCanopy_dTCanopy ! derivative in net canopy radiation w.r.t. canopy temperature (W m-2 K-1) dLWNetGround_dTGround = -dLWRadGround_dTGround ! derivative in net ground radiation w.r.t. ground temperature (W m-2 K-1) dLWNetCanopy_dTGround = emc*dLWRadGround_dTGround ! derivative in net canopy radiation w.r.t. ground temperature (W m-2 K-1) dLWNetGround_dTCanopy = emg*dLWRadCanopy_dTCanopy ! derivative in net ground radiation w.r.t. canopy temperature (W m-2 K-1) @@ -2026,49 +2026,49 @@ subroutine aeroResist(& integer(i4b),intent(in) :: ixWindProfile ! choice of canopy wind profile integer(i4b),intent(in) :: ixStability ! choice of stability function ! input: above-canopy forcing data - real(dp),intent(in) :: mHeight ! measurement height (m) - real(dp),intent(in) :: airtemp ! air temperature at some height above the surface (K) - real(dp),intent(in) :: windspd ! wind speed at some height above the surface (m s-1) + real(rkind),intent(in) :: mHeight ! measurement height (m) + real(rkind),intent(in) :: airtemp ! air temperature at some height above the surface (K) + real(rkind),intent(in) :: windspd ! wind speed at some height above the surface (m s-1) ! input: temperature (canopy, ground, canopy air space) - real(dp),intent(in) :: canairTemp ! temperature of the canopy air space (K) - real(dp),intent(in) :: groundTemp ! ground temperature (K) + real(rkind),intent(in) :: canairTemp ! temperature of the canopy air space (K) + real(rkind),intent(in) :: groundTemp ! ground temperature (K) ! input: diagnostic variables - real(dp),intent(in) :: exposedVAI ! exposed vegetation area index -- leaf plus stem (m2 m-2) - real(dp),intent(in) :: snowDepth ! snow depth (m) + real(rkind),intent(in) :: exposedVAI ! exposed vegetation area index -- leaf plus stem (m2 m-2) + real(rkind),intent(in) :: snowDepth ! snow depth (m) ! input: parameters - real(dp),intent(in) :: z0Ground ! roughness length of the ground (below canopy or non-vegetated surface [snow]) (m) - real(dp),intent(in) :: z0CanopyParam ! roughness length of the canopy (m) - real(dp),intent(in) :: zpdFraction ! zero plane displacement / canopy height (-) - real(dp),intent(in) :: critRichNumber ! critical value for the bulk Richardson number where turbulence ceases (-) - real(dp),intent(in) :: Louis79_bparam ! parameter in Louis (1979) stability function - real(dp),intent(in) :: Mahrt87_eScale ! exponential scaling factor in the Mahrt (1987) stability function - real(dp),intent(in) :: windReductionParam ! canopy wind reduction parameter (-) - real(dp),intent(in) :: leafExchangeCoeff ! turbulent exchange coeff between canopy surface and canopy air ( m s-(1/2) ) - real(dp),intent(in) :: leafDimension ! characteristic leaf dimension (m) - real(dp),intent(in) :: heightCanopyTop ! height at the top of the vegetation canopy (m) - real(dp),intent(in) :: heightCanopyBottom ! height at the bottom of the vegetation canopy (m) + real(rkind),intent(in) :: z0Ground ! roughness length of the ground (below canopy or non-vegetated surface [snow]) (m) + real(rkind),intent(in) :: z0CanopyParam ! roughness length of the canopy (m) + real(rkind),intent(in) :: zpdFraction ! zero plane displacement / canopy height (-) + real(rkind),intent(in) :: critRichNumber ! critical value for the bulk Richardson number where turbulence ceases (-) + real(rkind),intent(in) :: Louis79_bparam ! parameter in Louis (1979) stability function + real(rkind),intent(in) :: Mahrt87_eScale ! exponential scaling factor in the Mahrt (1987) stability function + real(rkind),intent(in) :: windReductionParam ! canopy wind reduction parameter (-) + real(rkind),intent(in) :: leafExchangeCoeff ! turbulent exchange coeff between canopy surface and canopy air ( m s-(1/2) ) + real(rkind),intent(in) :: leafDimension ! characteristic leaf dimension (m) + real(rkind),intent(in) :: heightCanopyTop ! height at the top of the vegetation canopy (m) + real(rkind),intent(in) :: heightCanopyBottom ! height at the bottom of the vegetation canopy (m) ! output: stability corrections - real(dp),intent(out) :: RiBulkCanopy ! bulk Richardson number for the canopy (-) - real(dp),intent(out) :: RiBulkGround ! bulk Richardson number for the ground surface (-) - real(dp),intent(out) :: canopyStabilityCorrection ! stability correction for the canopy (-) - real(dp),intent(out) :: groundStabilityCorrection ! stability correction for the ground surface (-) + real(rkind),intent(out) :: RiBulkCanopy ! bulk Richardson number for the canopy (-) + real(rkind),intent(out) :: RiBulkGround ! bulk Richardson number for the ground surface (-) + real(rkind),intent(out) :: canopyStabilityCorrection ! stability correction for the canopy (-) + real(rkind),intent(out) :: groundStabilityCorrection ! stability correction for the ground surface (-) ! output: scalar resistances - real(dp),intent(out) :: z0Canopy ! roughness length of the vegetation canopy (m) - real(dp),intent(out) :: windReductionFactor ! canopy wind reduction factor (-) - real(dp),intent(out) :: zeroPlaneDisplacement ! zero plane displacement (m) - real(dp),intent(out) :: eddyDiffusCanopyTop ! eddy diffusivity for heat at the top of the canopy (m2 s-1) - real(dp),intent(out) :: frictionVelocity ! friction velocity (m s-1) - real(dp),intent(out) :: windspdCanopyTop ! windspeed at the top of the canopy (m s-1) - real(dp),intent(out) :: windspdCanopyBottom ! windspeed at the height of the bottom of the canopy (m s-1) - real(dp),intent(out) :: leafResistance ! mean leaf boundary layer resistance per unit leaf area (s m-1) - real(dp),intent(out) :: groundResistance ! below canopy aerodynamic resistance (s m-1) - real(dp),intent(out) :: canopyResistance ! above canopy aerodynamic resistance (s m-1) + real(rkind),intent(out) :: z0Canopy ! roughness length of the vegetation canopy (m) + real(rkind),intent(out) :: windReductionFactor ! canopy wind reduction factor (-) + real(rkind),intent(out) :: zeroPlaneDisplacement ! zero plane displacement (m) + real(rkind),intent(out) :: eddyDiffusCanopyTop ! eddy diffusivity for heat at the top of the canopy (m2 s-1) + real(rkind),intent(out) :: frictionVelocity ! friction velocity (m s-1) + real(rkind),intent(out) :: windspdCanopyTop ! windspeed at the top of the canopy (m s-1) + real(rkind),intent(out) :: windspdCanopyBottom ! windspeed at the height of the bottom of the canopy (m s-1) + real(rkind),intent(out) :: leafResistance ! mean leaf boundary layer resistance per unit leaf area (s m-1) + real(rkind),intent(out) :: groundResistance ! below canopy aerodynamic resistance (s m-1) + real(rkind),intent(out) :: canopyResistance ! above canopy aerodynamic resistance (s m-1) ! output: derivatives in scalar resistances - real(dp),intent(out) :: dGroundResistance_dTGround ! derivative in ground resistance w.r.t. ground temperature (s m-1 K-1) - real(dp),intent(out) :: dGroundResistance_dTCanopy ! derivative in ground resistance w.r.t. canopy temperature (s m-1 K-1) - real(dp),intent(out) :: dGroundResistance_dTCanair ! derivative in ground resistance w.r.t. canopy air temperature (s m-1 K-1) - real(dp),intent(out) :: dCanopyResistance_dTCanopy ! derivative in canopy resistance w.r.t. canopy temperature (s m-1 K-1) - real(dp),intent(out) :: dCanopyResistance_dTCanair ! derivative in canopy resistance w.r.t. canopy air temperature (s m-1 K-1) + real(rkind),intent(out) :: dGroundResistance_dTGround ! derivative in ground resistance w.r.t. ground temperature (s m-1 K-1) + real(rkind),intent(out) :: dGroundResistance_dTCanopy ! derivative in ground resistance w.r.t. canopy temperature (s m-1 K-1) + real(rkind),intent(out) :: dGroundResistance_dTCanair ! derivative in ground resistance w.r.t. canopy air temperature (s m-1 K-1) + real(rkind),intent(out) :: dCanopyResistance_dTCanopy ! derivative in canopy resistance w.r.t. canopy temperature (s m-1 K-1) + real(rkind),intent(out) :: dCanopyResistance_dTCanair ! derivative in canopy resistance w.r.t. canopy air temperature (s m-1 K-1) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message @@ -2076,45 +2076,45 @@ subroutine aeroResist(& ! local variables: general character(LEN=256) :: cmessage ! error message of downwind routine ! local variables: vegetation roughness and dispalcement height - real(dp),parameter :: oneThird=1._dp/3._dp ! 1/3 - real(dp),parameter :: twoThirds=2._dp/3._dp ! 2/3 - real(dp),parameter :: C_r = 0.3 ! roughness element drag coefficient (-) from Raupach (BLM, 1994) - real(dp),parameter :: C_s = 0.003_dp ! substrate surface drag coefficient (-) from Raupach (BLM, 1994) - real(dp),parameter :: approxDragCoef_max = 0.3_dp ! maximum value of the approximate drag coefficient (-) from Raupach (BLM, 1994) - real(dp),parameter :: psi_h = 0.193_dp ! roughness sub-layer influence function (-) from Raupach (BLM, 1994) - real(dp),parameter :: c_d1 = 7.5_dp ! scaling parameter used to define displacement height (-) from Raupach (BLM, 1994) - real(dp),parameter :: cd_CM = 0.2_dp ! mean drag coefficient for individual leaves (-) from Choudhury and Monteith (QJRMS, 1988) - real(dp) :: funcLAI ! temporary variable to calculate zero plane displacement for the canopy - real(dp) :: fracCanopyHeight ! zero plane displacement expressed as a fraction of canopy height - real(dp) :: approxDragCoef ! approximate drag coefficient used in the computation of canopy roughness length (-) + real(rkind),parameter :: oneThird=1._rkind/3._rkind ! 1/3 + real(rkind),parameter :: twoThirds=2._rkind/3._rkind ! 2/3 + real(rkind),parameter :: C_r = 0.3 ! roughness element drag coefficient (-) from Raupach (BLM, 1994) + real(rkind),parameter :: C_s = 0.003_rkind ! substrate surface drag coefficient (-) from Raupach (BLM, 1994) + real(rkind),parameter :: approxDragCoef_max = 0.3_rkind ! maximum value of the approximate drag coefficient (-) from Raupach (BLM, 1994) + real(rkind),parameter :: psi_h = 0.193_rkind ! roughness sub-layer influence function (-) from Raupach (BLM, 1994) + real(rkind),parameter :: c_d1 = 7.5_rkind ! scaling parameter used to define displacement height (-) from Raupach (BLM, 1994) + real(rkind),parameter :: cd_CM = 0.2_rkind ! mean drag coefficient for individual leaves (-) from Choudhury and Monteith (QJRMS, 1988) + real(rkind) :: funcLAI ! temporary variable to calculate zero plane displacement for the canopy + real(rkind) :: fracCanopyHeight ! zero plane displacement expressed as a fraction of canopy height + real(rkind) :: approxDragCoef ! approximate drag coefficient used in the computation of canopy roughness length (-) ! local variables: resistance - real(dp) :: canopyExNeut ! surface-atmosphere exchange coefficient under neutral conditions (-) - real(dp) :: groundExNeut ! surface-atmosphere exchange coefficient under neutral conditions (-) - real(dp) :: sfc2AtmExchangeCoeff_canopy ! surface-atmosphere exchange coefficient after stability corrections (-) - real(dp) :: groundResistanceNeutral ! ground resistance under neutral conditions (s m-1) - real(dp) :: windConvFactor_fv ! factor to convert friction velocity to wind speed at top of canopy (-) - real(dp) :: windConvFactor ! factor to convert wind speed at top of canopy to wind speed at a given height in the canopy (-) - real(dp) :: referenceHeight ! z0Canopy+zeroPlaneDisplacement (m) - real(dp) :: windspdRefHeight ! windspeed at the reference height (m/s) - real(dp) :: heightAboveGround ! height above the snow surface (m) - real(dp) :: heightCanopyTopAboveSnow ! height at the top of the vegetation canopy relative to snowpack (m) - real(dp) :: heightCanopyBottomAboveSnow ! height at the bottom of the vegetation canopy relative to snowpack (m) - real(dp),parameter :: xTolerance=0.1_dp ! tolerance to handle the transition from exponential to log-below canopy + real(rkind) :: canopyExNeut ! surface-atmosphere exchange coefficient under neutral conditions (-) + real(rkind) :: groundExNeut ! surface-atmosphere exchange coefficient under neutral conditions (-) + real(rkind) :: sfc2AtmExchangeCoeff_canopy ! surface-atmosphere exchange coefficient after stability corrections (-) + real(rkind) :: groundResistanceNeutral ! ground resistance under neutral conditions (s m-1) + real(rkind) :: windConvFactor_fv ! factor to convert friction velocity to wind speed at top of canopy (-) + real(rkind) :: windConvFactor ! factor to convert wind speed at top of canopy to wind speed at a given height in the canopy (-) + real(rkind) :: referenceHeight ! z0Canopy+zeroPlaneDisplacement (m) + real(rkind) :: windspdRefHeight ! windspeed at the reference height (m/s) + real(rkind) :: heightAboveGround ! height above the snow surface (m) + real(rkind) :: heightCanopyTopAboveSnow ! height at the top of the vegetation canopy relative to snowpack (m) + real(rkind) :: heightCanopyBottomAboveSnow ! height at the bottom of the vegetation canopy relative to snowpack (m) + real(rkind),parameter :: xTolerance=0.1_rkind ! tolerance to handle the transition from exponential to log-below canopy ! local variables: derivatives - real(dp) :: dFV_dT ! derivative in friction velocity w.r.t. canopy air temperature - real(dp) :: dED_dT ! derivative in eddy diffusivity at the top of the canopy w.r.t. canopy air temperature - real(dp) :: dGR_dT ! derivative in neutral ground resistance w.r.t. canopy air temperature - real(dp) :: tmp1,tmp2 ! temporary variables used in calculation of ground resistance - real(dp) :: dCanopyStabilityCorrection_dRich ! derivative in stability correction w.r.t. Richardson number for the canopy (-) - real(dp) :: dGroundStabilityCorrection_dRich ! derivative in stability correction w.r.t. Richardson number for the ground surface (-) - real(dp) :: dCanopyStabilityCorrection_dAirTemp ! (not used) derivative in stability correction w.r.t. air temperature (K-1) - real(dp) :: dGroundStabilityCorrection_dAirTemp ! (not used) derivative in stability correction w.r.t. air temperature (K-1) - real(dp) :: dCanopyStabilityCorrection_dCasTemp ! derivative in canopy stability correction w.r.t. canopy air space temperature (K-1) - real(dp) :: dGroundStabilityCorrection_dCasTemp ! derivative in ground stability correction w.r.t. canopy air space temperature (K-1) - real(dp) :: dGroundStabilityCorrection_dSfcTemp ! derivative in ground stability correction w.r.t. surface temperature (K-1) - real(dp) :: singleLeafConductance ! leaf boundary layer conductance (m s-1) - real(dp) :: canopyLeafConductance ! leaf boundary layer conductance -- scaled up to the canopy (m s-1) - real(dp) :: leaf2CanopyScaleFactor ! factor to scale from the leaf to the canopy [m s-(1/2)] + real(rkind) :: dFV_dT ! derivative in friction velocity w.r.t. canopy air temperature + real(rkind) :: dED_dT ! derivative in eddy diffusivity at the top of the canopy w.r.t. canopy air temperature + real(rkind) :: dGR_dT ! derivative in neutral ground resistance w.r.t. canopy air temperature + real(rkind) :: tmp1,tmp2 ! temporary variables used in calculation of ground resistance + real(rkind) :: dCanopyStabilityCorrection_dRich ! derivative in stability correction w.r.t. Richardson number for the canopy (-) + real(rkind) :: dGroundStabilityCorrection_dRich ! derivative in stability correction w.r.t. Richardson number for the ground surface (-) + real(rkind) :: dCanopyStabilityCorrection_dAirTemp ! (not used) derivative in stability correction w.r.t. air temperature (K-1) + real(rkind) :: dGroundStabilityCorrection_dAirTemp ! (not used) derivative in stability correction w.r.t. air temperature (K-1) + real(rkind) :: dCanopyStabilityCorrection_dCasTemp ! derivative in canopy stability correction w.r.t. canopy air space temperature (K-1) + real(rkind) :: dGroundStabilityCorrection_dCasTemp ! derivative in ground stability correction w.r.t. canopy air space temperature (K-1) + real(rkind) :: dGroundStabilityCorrection_dSfcTemp ! derivative in ground stability correction w.r.t. surface temperature (K-1) + real(rkind) :: singleLeafConductance ! leaf boundary layer conductance (m s-1) + real(rkind) :: canopyLeafConductance ! leaf boundary layer conductance -- scaled up to the canopy (m s-1) + real(rkind) :: leaf2CanopyScaleFactor ! factor to scale from the leaf to the canopy [m s-(1/2)] ! ----------------------------------------------------------------------------------------------------------------------------------------- ! initialize error control err=0; message='aeroResist/' @@ -2132,27 +2132,27 @@ subroutine aeroResist(& ! First, calculate new coordinate system above snow - use these to scale wind profiles and resistances ! NOTE: the new coordinate system makes zeroPlaneDisplacement and z0Canopy consistent heightCanopyTopAboveSnow = heightCanopyTop - snowDepth - heightCanopyBottomAboveSnow = max(heightCanopyBottom - snowDepth, 0.0_dp) + heightCanopyBottomAboveSnow = max(heightCanopyBottom - snowDepth, 0.0_rkind) select case(ixVegTraits) ! Raupach (BLM 1994) "Simplified expressions..." case(Raupach_BLM1994) ! (compute zero-plane displacement) funcLAI = sqrt(c_d1*exposedVAI) - fracCanopyHeight = -(1._dp - exp(-funcLAI))/funcLAI + 1._dp + fracCanopyHeight = -(1._rkind - exp(-funcLAI))/funcLAI + 1._rkind zeroPlaneDisplacement = fracCanopyHeight*(heightCanopyTopAboveSnow-heightCanopyBottomAboveSnow)+heightCanopyBottomAboveSnow ! (coupute roughness length of the veg canopy) - approxDragCoef = min( sqrt(C_s + C_r*exposedVAI/2._dp), approxDragCoef_max) - z0Canopy = (1._dp - fracCanopyHeight) * exp(-vkc*approxDragCoef - psi_h) * (heightCanopyTopAboveSnow-heightCanopyBottomAboveSnow) + approxDragCoef = min( sqrt(C_s + C_r*exposedVAI/2._rkind), approxDragCoef_max) + z0Canopy = (1._rkind - fracCanopyHeight) * exp(-vkc*approxDragCoef - psi_h) * (heightCanopyTopAboveSnow-heightCanopyBottomAboveSnow) ! Choudhury and Monteith (QJRMS 1988) "A four layer model for the heat budget..." case(CM_QJRMS1988) funcLAI = cd_CM*exposedVAI - zeroPlaneDisplacement = 1.1_dp*heightCanopyTopAboveSnow*log(1._dp + funcLAI**0.25_dp) - if(funcLAI < 0.2_dp)then - z0Canopy = z0Ground + 0.3_dp*heightCanopyTopAboveSnow*funcLAI**0.5_dp + zeroPlaneDisplacement = 1.1_rkind*heightCanopyTopAboveSnow*log(1._rkind + funcLAI**0.25_rkind) + if(funcLAI < 0.2_rkind)then + z0Canopy = z0Ground + 0.3_rkind*heightCanopyTopAboveSnow*funcLAI**0.5_rkind else - z0Canopy = 0.3_dp*heightCanopyTopAboveSnow*(1._dp - zeroPlaneDisplacement/heightCanopyTopAboveSnow) + z0Canopy = 0.3_rkind*heightCanopyTopAboveSnow*(1._rkind - zeroPlaneDisplacement/heightCanopyTopAboveSnow) end if ! constant parameters dependent on the vegetation type @@ -2205,15 +2205,15 @@ subroutine aeroResist(& if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! compute turbulent exchange coefficient (-) - canopyExNeut = (vkc**2._dp) / ( log((mHeight - zeroPlaneDisplacement)/z0Canopy))**2._dp ! coefficient under conditions of neutral stability + canopyExNeut = (vkc**2._rkind) / ( log((mHeight - zeroPlaneDisplacement)/z0Canopy))**2._rkind ! coefficient under conditions of neutral stability sfc2AtmExchangeCoeff_canopy = canopyExNeut*canopyStabilityCorrection ! after stability corrections ! compute the friction velocity (m s-1) frictionVelocity = windspd * sqrt(sfc2AtmExchangeCoeff_canopy) ! compute the above-canopy resistance (s m-1) - canopyResistance = 1._dp/(sfc2AtmExchangeCoeff_canopy*windspd) - if(canopyResistance < 0._dp)then; err=20; message=trim(message)//'canopy resistance < 0'; return; end if + canopyResistance = 1._rkind/(sfc2AtmExchangeCoeff_canopy*windspd) + if(canopyResistance < 0._rkind)then; err=20; message=trim(message)//'canopy resistance < 0'; return; end if ! compute windspeed at the top of the canopy above snow depth (m s-1) ! NOTE: stability corrections cancel out @@ -2226,19 +2226,19 @@ subroutine aeroResist(& ! compute windspeed at the height z0Canopy+zeroPlaneDisplacement (m s-1) referenceHeight = z0Canopy+zeroPlaneDisplacement - windConvFactor = exp(-windReductionFactor*(1._dp - (referenceHeight/heightCanopyTopAboveSnow))) + windConvFactor = exp(-windReductionFactor*(1._rkind - (referenceHeight/heightCanopyTopAboveSnow))) windspdRefHeight = windspdCanopyTop*windConvFactor ! compute windspeed at the bottom of the canopy relative to the snow depth (m s-1) - windConvFactor = exp(-windReductionFactor*(1._dp - (heightCanopyBottomAboveSnow/heightCanopyTopAboveSnow))) + windConvFactor = exp(-windReductionFactor*(1._rkind - (heightCanopyBottomAboveSnow/heightCanopyTopAboveSnow))) windspdCanopyBottom = windspdCanopyTop*windConvFactor ! compute the leaf boundary layer resistance (s m-1) singleLeafConductance = leafExchangeCoeff*sqrt(windspdCanopyTop/leafDimension) - leaf2CanopyScaleFactor = (2._dp/windReductionFactor) * (1._dp - exp(-windReductionFactor/2._dp)) ! factor to scale from the leaf to the canopy + leaf2CanopyScaleFactor = (2._rkind/windReductionFactor) * (1._rkind - exp(-windReductionFactor/2._rkind)) ! factor to scale from the leaf to the canopy canopyLeafConductance = singleLeafConductance*leaf2CanopyScaleFactor - leafResistance = 1._dp/(canopyLeafConductance) - if(leafResistance < 0._dp)then; err=20; message=trim(message)//'leaf resistance < 0'; return; end if + leafResistance = 1._rkind/(canopyLeafConductance) + if(leafResistance < 0._rkind)then; err=20; message=trim(message)//'leaf resistance < 0'; return; end if ! compute eddy diffusivity for heat at the top of the canopy (m2 s-1) ! Note: use of friction velocity here includes stability adjustments @@ -2265,7 +2265,7 @@ subroutine aeroResist(& tmp2 = exp(-windReductionFactor*(z0Canopy+zeroPlaneDisplacement)/heightCanopyTopAboveSnow) groundResistanceNeutral = ( heightCanopyTopAboveSnow*exp(windReductionFactor) / (windReductionFactor*eddyDiffusCanopyTop) ) * (tmp1 - tmp2) ! (add log-below-canopy component) - groundResistanceNeutral = groundResistanceNeutral + (1._dp/(max(0.1_dp,windspdCanopyBottom)*vkc**2._dp))*(log(heightCanopyBottomAboveSnow/z0Ground))**2._dp + groundResistanceNeutral = groundResistanceNeutral + (1._rkind/(max(0.1_rkind,windspdCanopyBottom)*vkc**2._rkind))*(log(heightCanopyBottomAboveSnow/z0Ground))**2._rkind endif ! switch between exponential profile and log-below-canopy @@ -2279,7 +2279,7 @@ subroutine aeroResist(& referenceHeight, & ! input: height of the canopy air space temperature/wind (m) canairTemp, & ! input: temperature of the canopy air space (K) groundTemp, & ! input: temperature of the ground surface (K) - max(0.1_dp,windspdRefHeight), & ! input: wind speed at height z0Canopy+zeroPlaneDisplacement (m s-1) + max(0.1_rkind,windspdRefHeight), & ! input: wind speed at height z0Canopy+zeroPlaneDisplacement (m s-1) ! input: stability parameters critRichNumber, & ! input: critical value for the bulk Richardson number where turbulence ceases (-) Louis79_bparam, & ! input: parameter in Louis (1979) stability function @@ -2295,7 +2295,7 @@ subroutine aeroResist(& ! compute the ground resistance groundResistance = groundResistanceNeutral / groundStabilityCorrection - if(groundResistance < 0._dp)then; err=20; message=trim(message)//'ground resistance < 0 [vegetation is present]'; return; end if + if(groundResistance < 0._rkind)then; err=20; message=trim(message)//'ground resistance < 0 [vegetation is present]'; return; end if ! ----------------------------------------------------------------------------------------------------------------------------------------- ! ----------------------------------------------------------------------------------------------------------------------------------------- @@ -2303,15 +2303,15 @@ subroutine aeroResist(& else ! no canopy, so set huge resistances (not used) - canopyResistance = 1.e12_dp ! not used: huge resistance, so conductance is essentially zero - leafResistance = 1.e12_dp ! not used: huge resistance, so conductance is essentially zero + canopyResistance = 1.e12_rkind ! not used: huge resistance, so conductance is essentially zero + leafResistance = 1.e12_rkind ! not used: huge resistance, so conductance is essentially zero ! check that measurement height above the ground surface is above the roughness length if(mHeight < snowDepth+z0Ground)then; err=20; message=trim(message)//'measurement height < snow depth + roughness length'; return; end if ! compute the resistance between the surface and canopy air UNDER NEUTRAL CONDITIONS (s m-1) - groundExNeut = (vkc**2._dp) / ( log((mHeight - snowDepth)/z0Ground)**2._dp) ! turbulent transfer coefficient under conditions of neutral stability (-) - groundResistanceNeutral = 1._dp / (groundExNeut*windspd) + groundExNeut = (vkc**2._rkind) / ( log((mHeight - snowDepth)/z0Ground)**2._rkind) ! turbulent transfer coefficient under conditions of neutral stability (-) + groundResistanceNeutral = 1._rkind / (groundExNeut*windspd) ! define height above the snow surface heightAboveGround = mHeight - snowDepth @@ -2351,7 +2351,7 @@ subroutine aeroResist(& ! compute the ground resistance (after stability corrections) groundResistance = groundResistanceNeutral/groundStabilityCorrection - if(groundResistance < 0._dp)then; err=20; message=trim(message)//'ground resistance < 0 [no vegetation]'; return; end if + if(groundResistance < 0._rkind)then; err=20; message=trim(message)//'ground resistance < 0 [no vegetation]'; return; end if ! set all canopy variables to missing (no canopy!) z0Canopy = missingValue ! roughness length of the vegetation canopy (m) @@ -2378,32 +2378,32 @@ subroutine aeroResist(& ! ***** compute derivatives w.r.t. canopy temperature ! NOTE: derivatives are zero because using canopy air space temperature - dCanopyResistance_dTCanopy = 0._dp ! derivative in canopy resistance w.r.t. canopy temperature (s m-1 K-1) - dGroundResistance_dTCanopy = 0._dp ! derivative in ground resistance w.r.t. canopy temperature (s m-1 K-1) + dCanopyResistance_dTCanopy = 0._rkind ! derivative in canopy resistance w.r.t. canopy temperature (s m-1 K-1) + dGroundResistance_dTCanopy = 0._rkind ! derivative in ground resistance w.r.t. canopy temperature (s m-1 K-1) ! ***** compute derivatives w.r.t. ground temperature (s m-1 K-1) - dGroundResistance_dTGround = -(groundResistanceNeutral*dGroundStabilityCorrection_dSfcTemp)/(groundStabilityCorrection**2._dp) + dGroundResistance_dTGround = -(groundResistanceNeutral*dGroundStabilityCorrection_dSfcTemp)/(groundStabilityCorrection**2._rkind) ! ***** compute derivatives w.r.t. temperature of the canopy air space (s m-1 K-1) ! derivative in canopy resistance w.r.t. canopy air temperature (s m-1 K-1) - dCanopyResistance_dTCanair = -dCanopyStabilityCorrection_dCasTemp/(windspd*canopyExNeut*canopyStabilityCorrection**2._dp) + dCanopyResistance_dTCanair = -dCanopyStabilityCorrection_dCasTemp/(windspd*canopyExNeut*canopyStabilityCorrection**2._rkind) ! derivative in ground resistance w.r.t. canopy air temperature (s m-1 K-1) ! (compute derivative in NEUTRAL ground resistance w.r.t. canopy air temperature (s m-1 K-1)) - dFV_dT = windspd*canopyExNeut*dCanopyStabilityCorrection_dCasTemp/(sqrt(sfc2AtmExchangeCoeff_canopy)*2._dp) ! d(frictionVelocity)/d(canopy air temperature) + dFV_dT = windspd*canopyExNeut*dCanopyStabilityCorrection_dCasTemp/(sqrt(sfc2AtmExchangeCoeff_canopy)*2._rkind) ! d(frictionVelocity)/d(canopy air temperature) dED_dT = dFV_dT*vkc*(heightCanopyTopAboveSnow - zeroPlaneDisplacement) ! d(eddyDiffusCanopyTop)d(canopy air temperature) - dGR_dT = -dED_dT*(tmp1 - tmp2)*heightCanopyTopAboveSnow*exp(windReductionFactor) / (windReductionFactor*eddyDiffusCanopyTop**2._dp) ! d(groundResistanceNeutral)/d(canopy air temperature) + dGR_dT = -dED_dT*(tmp1 - tmp2)*heightCanopyTopAboveSnow*exp(windReductionFactor) / (windReductionFactor*eddyDiffusCanopyTop**2._rkind) ! d(groundResistanceNeutral)/d(canopy air temperature) ! (stitch everything together -- product rule) - dGroundResistance_dTCanair = dGR_dT/groundStabilityCorrection - groundResistanceNeutral*dGroundStabilityCorrection_dCasTemp/(groundStabilityCorrection**2._dp) + dGroundResistance_dTCanair = dGR_dT/groundStabilityCorrection - groundResistanceNeutral*dGroundStabilityCorrection_dCasTemp/(groundStabilityCorrection**2._rkind) ! ***** compute resistances for non-vegetated surfaces (e.g., snow) else ! set canopy derivatives to zero (non-vegetated, remember) - dCanopyResistance_dTCanopy = 0._dp - dGroundResistance_dTCanopy = 0._dp + dCanopyResistance_dTCanopy = 0._rkind + dGroundResistance_dTCanopy = 0._rkind ! compute derivatives for ground resistance - dGroundResistance_dTGround = -dGroundStabilityCorrection_dSfcTemp/(windspd*groundExNeut*groundStabilityCorrection**2._dp) + dGroundResistance_dTGround = -dGroundStabilityCorrection_dSfcTemp/(windspd*groundExNeut*groundStabilityCorrection**2._rkind) end if ! (switch between vegetated and non-vegetated surfaces) @@ -2456,33 +2456,33 @@ subroutine soilResist(& integer(i4b),intent(in) :: ixSoilResist ! choice of function for the soil moisture control on stomatal resistance integer(i4b),intent(in) :: ixGroundwater ! choice of groundwater representation ! input (variables) - real(dp),intent(in) :: mLayerMatricHead(:) ! matric head in each layer (m) - real(dp),intent(in) :: mLayerVolFracLiq(:) ! volumetric fraction of liquid water in each layer (-) - real(dp),intent(in) :: scalarAquiferStorage ! aquifer storage (m) + real(rkind),intent(in) :: mLayerMatricHead(:) ! matric head in each layer (m) + real(rkind),intent(in) :: mLayerVolFracLiq(:) ! volumetric fraction of liquid water in each layer (-) + real(rkind),intent(in) :: scalarAquiferStorage ! aquifer storage (m) ! input (diagnostic variables) - real(dp),intent(in) :: mLayerRootDensity(:) ! root density in each layer (-) - real(dp),intent(in) :: scalarAquiferRootFrac ! fraction of roots below the lowest unsaturated layer (-) + real(rkind),intent(in) :: mLayerRootDensity(:) ! root density in each layer (-) + real(rkind),intent(in) :: scalarAquiferRootFrac ! fraction of roots below the lowest unsaturated layer (-) ! input (parameters) - real(dp),intent(in) :: plantWiltPsi ! matric head at wilting point (m) - real(dp),intent(in) :: soilStressParam ! parameter in the exponential soil stress function (-) - real(dp),intent(in) :: critSoilWilting ! critical vol. liq. water content when plants are wilting (-) - real(dp),intent(in) :: critSoilTranspire ! critical vol. liq. water content when transpiration is limited (-) - real(dp),intent(in) :: critAquiferTranspire ! critical aquifer storage value when transpiration is limited (m) + real(rkind),intent(in) :: plantWiltPsi ! matric head at wilting point (m) + real(rkind),intent(in) :: soilStressParam ! parameter in the exponential soil stress function (-) + real(rkind),intent(in) :: critSoilWilting ! critical vol. liq. water content when plants are wilting (-) + real(rkind),intent(in) :: critSoilTranspire ! critical vol. liq. water content when transpiration is limited (-) + real(rkind),intent(in) :: critAquiferTranspire ! critical aquifer storage value when transpiration is limited (m) ! output - real(dp),intent(out) :: wAvgTranspireLimitFac ! intent(out): weighted average of the transpiration limiting factor (-) - real(dp),intent(out) :: mLayerTranspireLimitFac(:) ! intent(out): transpiration limiting factor in each layer (-) - real(dp),intent(out) :: aquiferTranspireLimitFac ! intent(out): transpiration limiting factor for the aquifer (-) + real(rkind),intent(out) :: wAvgTranspireLimitFac ! intent(out): weighted average of the transpiration limiting factor (-) + real(rkind),intent(out) :: mLayerTranspireLimitFac(:) ! intent(out): transpiration limiting factor in each layer (-) + real(rkind),intent(out) :: aquiferTranspireLimitFac ! intent(out): transpiration limiting factor for the aquifer (-) integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! local variables - real(dp) :: gx ! stress function for the soil layers - real(dp),parameter :: verySmall=epsilon(gx) ! a very small number + real(rkind) :: gx ! stress function for the soil layers + real(rkind),parameter :: verySmall=epsilon(gx) ! a very small number integer(i4b) :: iLayer ! index of soil layer ! initialize error control err=0; message='soilResist/' ! ** compute the factor limiting transpiration for each soil layer (-) - wAvgTranspireLimitFac = 0._dp ! (initialize the weighted average) + wAvgTranspireLimitFac = 0._rkind ! (initialize the weighted average) do iLayer=1,size(mLayerMatricHead) ! compute the soil stress function select case(ixSoilResist) @@ -2490,21 +2490,21 @@ subroutine soilResist(& gx = (mLayerVolFracLiq(iLayer) - critSoilWilting) / (critSoilTranspire - critSoilWilting) case(CLM_Type) ! thresholded linear function of matric head if(mLayerMatricHead(iLayer) > plantWiltPsi)then - gx = 1._dp - mLayerMatricHead(iLayer)/plantWiltPsi + gx = 1._rkind - mLayerMatricHead(iLayer)/plantWiltPsi else - gx = 0._dp + gx = 0._rkind end if case(SiB_Type) ! exponential of the log of matric head - if(mLayerMatricHead(iLayer) < 0._dp)then ! (unsaturated) - gx = 1._dp - exp( -soilStressParam * ( log(plantWiltPsi/mLayerMatricHead(iLayer)) ) ) + if(mLayerMatricHead(iLayer) < 0._rkind)then ! (unsaturated) + gx = 1._rkind - exp( -soilStressParam * ( log(plantWiltPsi/mLayerMatricHead(iLayer)) ) ) else ! (saturated) - gx = 1._dp + gx = 1._rkind end if case default ! check identified the option err=20; message=trim(message)//'cannot identify option for soil resistance'; return end select ! save the factor for the given layer (ensure between zero and one) - mLayerTranspireLimitFac(iLayer) = min( max(verySmall,gx), 1._dp) + mLayerTranspireLimitFac(iLayer) = min( max(verySmall,gx), 1._rkind) ! compute the weighted average (weighted by root density) wAvgTranspireLimitFac = wAvgTranspireLimitFac + mLayerTranspireLimitFac(iLayer)*mLayerRootDensity(iLayer) end do ! (looping through soil layers) @@ -2517,9 +2517,9 @@ subroutine soilResist(& err=20; return end if ! compute the factor limiting evaporation for the aquifer - aquiferTranspireLimitFac = min(scalarAquiferStorage/critAquiferTranspire, 1._dp) + aquiferTranspireLimitFac = min(scalarAquiferStorage/critAquiferTranspire, 1._rkind) else ! (if there are roots in the aquifer) - aquiferTranspireLimitFac = 0._dp + aquiferTranspireLimitFac = 0._rkind end if ! compute the weighted average (weighted by root density) @@ -2627,138 +2627,138 @@ subroutine turbFluxes(& logical(lgt),intent(in) :: computeVegFlux ! logical flag to compute vegetation fluxes (.false. if veg buried by snow) integer(i4b),intent(in) :: ixDerivMethod ! choice of method used to compute derivative (analytical or numerical) ! input: above-canopy forcing data - real(dp),intent(in) :: airtemp ! air temperature at some height above the surface (K) - real(dp),intent(in) :: airpres ! air pressure of the air above the vegetation canopy (Pa) - real(dp),intent(in) :: VPair ! vapor pressure of the air above the vegetation canopy (Pa) + real(rkind),intent(in) :: airtemp ! air temperature at some height above the surface (K) + real(rkind),intent(in) :: airpres ! air pressure of the air above the vegetation canopy (Pa) + real(rkind),intent(in) :: VPair ! vapor pressure of the air above the vegetation canopy (Pa) ! input: latent heat of sublimation/vaporization - real(dp),intent(in) :: latHeatSubVapCanopy ! latent heat of sublimation/vaporization for the vegetation canopy (J kg-1) - real(dp),intent(in) :: latHeatSubVapGround ! latent heat of sublimation/vaporization for the ground surface (J kg-1) + real(rkind),intent(in) :: latHeatSubVapCanopy ! latent heat of sublimation/vaporization for the vegetation canopy (J kg-1) + real(rkind),intent(in) :: latHeatSubVapGround ! latent heat of sublimation/vaporization for the ground surface (J kg-1) ! input: canopy and ground temperature - real(dp),intent(in) :: canairTemp ! temperature of the canopy air space (K) - real(dp),intent(in) :: canopyTemp ! canopy temperature (K) - real(dp),intent(in) :: groundTemp ! ground temperature (K) - real(dp),intent(in) :: satVP_CanopyTemp ! saturation vapor pressure at the temperature of the veg canopy (Pa) - real(dp),intent(in) :: satVP_GroundTemp ! saturation vapor pressure at the temperature of the ground (Pa) - real(dp),intent(in) :: dSVPCanopy_dCanopyTemp ! derivative in canopy saturation vapor pressure w.r.t. canopy temperature (Pa K-1) - real(dp),intent(in) :: dSVPGround_dGroundTemp ! derivative in ground saturation vapor pressure w.r.t. ground temperature (Pa K-1) + real(rkind),intent(in) :: canairTemp ! temperature of the canopy air space (K) + real(rkind),intent(in) :: canopyTemp ! canopy temperature (K) + real(rkind),intent(in) :: groundTemp ! ground temperature (K) + real(rkind),intent(in) :: satVP_CanopyTemp ! saturation vapor pressure at the temperature of the veg canopy (Pa) + real(rkind),intent(in) :: satVP_GroundTemp ! saturation vapor pressure at the temperature of the ground (Pa) + real(rkind),intent(in) :: dSVPCanopy_dCanopyTemp ! derivative in canopy saturation vapor pressure w.r.t. canopy temperature (Pa K-1) + real(rkind),intent(in) :: dSVPGround_dGroundTemp ! derivative in ground saturation vapor pressure w.r.t. ground temperature (Pa K-1) ! input: diagnostic variables - real(dp),intent(in) :: exposedVAI ! exposed vegetation area index -- leaf plus stem (m2 m-2) - real(dp),intent(in) :: canopyWetFraction ! fraction of canopy that is wet [0-1] - real(dp),intent(in) :: dCanopyWetFraction_dWat ! derivative in the canopy wetted fraction w.r.t. liquid water content (kg-1 m-2) - real(dp),intent(in) :: dCanopyWetFraction_dT ! derivative in the canopy wetted fraction w.r.t. canopy temperature (K-1) - real(dp),intent(in) :: canopySunlitLAI ! sunlit leaf area (-) - real(dp),intent(in) :: canopyShadedLAI ! shaded leaf area (-) - real(dp),intent(in) :: soilRelHumidity ! relative humidity in the soil pores [0-1] - real(dp),intent(in) :: soilResistance ! resistance from the soil (s m-1) - real(dp),intent(in) :: leafResistance ! mean leaf boundary layer resistance per unit leaf area (s m-1) - real(dp),intent(in) :: groundResistance ! below canopy aerodynamic resistance (s m-1) - real(dp),intent(in) :: canopyResistance ! above canopy aerodynamic resistance (s m-1) - real(dp),intent(in) :: stomResistSunlit ! stomatal resistance for sunlit leaves (s m-1) - real(dp),intent(in) :: stomResistShaded ! stomatal resistance for shaded leaves (s m-1) + real(rkind),intent(in) :: exposedVAI ! exposed vegetation area index -- leaf plus stem (m2 m-2) + real(rkind),intent(in) :: canopyWetFraction ! fraction of canopy that is wet [0-1] + real(rkind),intent(in) :: dCanopyWetFraction_dWat ! derivative in the canopy wetted fraction w.r.t. liquid water content (kg-1 m-2) + real(rkind),intent(in) :: dCanopyWetFraction_dT ! derivative in the canopy wetted fraction w.r.t. canopy temperature (K-1) + real(rkind),intent(in) :: canopySunlitLAI ! sunlit leaf area (-) + real(rkind),intent(in) :: canopyShadedLAI ! shaded leaf area (-) + real(rkind),intent(in) :: soilRelHumidity ! relative humidity in the soil pores [0-1] + real(rkind),intent(in) :: soilResistance ! resistance from the soil (s m-1) + real(rkind),intent(in) :: leafResistance ! mean leaf boundary layer resistance per unit leaf area (s m-1) + real(rkind),intent(in) :: groundResistance ! below canopy aerodynamic resistance (s m-1) + real(rkind),intent(in) :: canopyResistance ! above canopy aerodynamic resistance (s m-1) + real(rkind),intent(in) :: stomResistSunlit ! stomatal resistance for sunlit leaves (s m-1) + real(rkind),intent(in) :: stomResistShaded ! stomatal resistance for shaded leaves (s m-1) ! input: derivatives in scalar resistances - real(dp),intent(in) :: dGroundResistance_dTGround ! derivative in ground resistance w.r.t. ground temperature (s m-1 K-1) - real(dp),intent(in) :: dGroundResistance_dTCanopy ! derivative in ground resistance w.r.t. canopy temperature (s m-1 K-1) - real(dp),intent(in) :: dGroundResistance_dTCanair ! derivative in ground resistance w.r.t. canopy air temperature (s m-1 K-1) - real(dp),intent(in) :: dCanopyResistance_dTCanopy ! derivative in canopy resistance w.r.t. canopy temperature (s m-1 K-1) - real(dp),intent(in) :: dCanopyResistance_dTCanair ! derivative in canopy resistance w.r.t. canopy air temperature (s m-1 K-1) + real(rkind),intent(in) :: dGroundResistance_dTGround ! derivative in ground resistance w.r.t. ground temperature (s m-1 K-1) + real(rkind),intent(in) :: dGroundResistance_dTCanopy ! derivative in ground resistance w.r.t. canopy temperature (s m-1 K-1) + real(rkind),intent(in) :: dGroundResistance_dTCanair ! derivative in ground resistance w.r.t. canopy air temperature (s m-1 K-1) + real(rkind),intent(in) :: dCanopyResistance_dTCanopy ! derivative in canopy resistance w.r.t. canopy temperature (s m-1 K-1) + real(rkind),intent(in) :: dCanopyResistance_dTCanair ! derivative in canopy resistance w.r.t. canopy air temperature (s m-1 K-1) ! --------------------------------------------------------------------------------------------------------------------------------------------------------------- ! output: conductances -- used to test derivatives - real(dp),intent(out) :: leafConductance ! leaf conductance (m s-1) - real(dp),intent(out) :: canopyConductance ! canopy conductance (m s-1) - real(dp),intent(out) :: groundConductanceSH ! ground conductance for sensible heat (m s-1) - real(dp),intent(out) :: groundConductanceLH ! ground conductance for latent heat -- includes soil resistance (m s-1) - real(dp),intent(out) :: evapConductance ! conductance for evaporation (m s-1) - real(dp),intent(out) :: transConductance ! conductance for transpiration (m s-1) - real(dp),intent(out) :: totalConductanceSH ! total conductance for sensible heat (m s-1) - real(dp),intent(out) :: totalConductanceLH ! total conductance for latent heat (m s-1) + real(rkind),intent(out) :: leafConductance ! leaf conductance (m s-1) + real(rkind),intent(out) :: canopyConductance ! canopy conductance (m s-1) + real(rkind),intent(out) :: groundConductanceSH ! ground conductance for sensible heat (m s-1) + real(rkind),intent(out) :: groundConductanceLH ! ground conductance for latent heat -- includes soil resistance (m s-1) + real(rkind),intent(out) :: evapConductance ! conductance for evaporation (m s-1) + real(rkind),intent(out) :: transConductance ! conductance for transpiration (m s-1) + real(rkind),intent(out) :: totalConductanceSH ! total conductance for sensible heat (m s-1) + real(rkind),intent(out) :: totalConductanceLH ! total conductance for latent heat (m s-1) ! output: canopy air space variables - real(dp),intent(out) :: VP_CanopyAir ! vapor pressure of the canopy air space (Pa) + real(rkind),intent(out) :: VP_CanopyAir ! vapor pressure of the canopy air space (Pa) ! output: fluxes from the vegetation canopy - real(dp),intent(out) :: senHeatCanopy ! sensible heat flux from the canopy to the canopy air space (W m-2) - real(dp),intent(out) :: latHeatCanopyEvap ! latent heat flux associated with evaporation from the canopy to the canopy air space (W m-2) - real(dp),intent(out) :: latHeatCanopyTrans ! latent heat flux associated with transpiration from the canopy to the canopy air space (W m-2) + real(rkind),intent(out) :: senHeatCanopy ! sensible heat flux from the canopy to the canopy air space (W m-2) + real(rkind),intent(out) :: latHeatCanopyEvap ! latent heat flux associated with evaporation from the canopy to the canopy air space (W m-2) + real(rkind),intent(out) :: latHeatCanopyTrans ! latent heat flux associated with transpiration from the canopy to the canopy air space (W m-2) ! output: fluxes from non-vegetated surfaces (ground surface below vegetation, bare ground, or snow covered vegetation) - real(dp),intent(out) :: senHeatGround ! sensible heat flux from ground surface below vegetation, bare ground, or snow covered vegetation (W m-2) - real(dp),intent(out) :: latHeatGround ! latent heat flux from ground surface below vegetation, bare ground, or snow covered vegetation (W m-2) + real(rkind),intent(out) :: senHeatGround ! sensible heat flux from ground surface below vegetation, bare ground, or snow covered vegetation (W m-2) + real(rkind),intent(out) :: latHeatGround ! latent heat flux from ground surface below vegetation, bare ground, or snow covered vegetation (W m-2) ! output: total heat fluxes to the atmosphere - real(dp),intent(out) :: senHeatTotal ! total sensible heat flux to the atmosphere (W m-2) - real(dp),intent(out) :: latHeatTotal ! total latent heat flux to the atmosphere (W m-2) + real(rkind),intent(out) :: senHeatTotal ! total sensible heat flux to the atmosphere (W m-2) + real(rkind),intent(out) :: latHeatTotal ! total latent heat flux to the atmosphere (W m-2) ! output: net fluxes - real(dp),intent(out) :: turbFluxCanair ! net turbulent heat fluxes at the canopy air space (W m-2) - real(dp),intent(out) :: turbFluxCanopy ! net turbulent heat fluxes at the canopy (W m-2) - real(dp),intent(out) :: turbFluxGround ! net turbulent heat fluxes at the ground surface (W m-2) + real(rkind),intent(out) :: turbFluxCanair ! net turbulent heat fluxes at the canopy air space (W m-2) + real(rkind),intent(out) :: turbFluxCanopy ! net turbulent heat fluxes at the canopy (W m-2) + real(rkind),intent(out) :: turbFluxGround ! net turbulent heat fluxes at the ground surface (W m-2) ! output: energy flux derivatives - real(dp),intent(out) :: dTurbFluxCanair_dTCanair ! derivative in net canopy air space fluxes w.r.t. canopy air temperature (W m-2 K-1) - real(dp),intent(out) :: dTurbFluxCanair_dTCanopy ! derivative in net canopy air space fluxes w.r.t. canopy temperature (W m-2 K-1) - real(dp),intent(out) :: dTurbFluxCanair_dTGround ! derivative in net canopy air space fluxes w.r.t. ground temperature (W m-2 K-1) - real(dp),intent(out) :: dTurbFluxCanopy_dTCanair ! derivative in net canopy turbulent fluxes w.r.t. canopy air temperature (W m-2 K-1) - real(dp),intent(out) :: dTurbFluxCanopy_dTCanopy ! derivative in net canopy turbulent fluxes w.r.t. canopy temperature (W m-2 K-1) - real(dp),intent(out) :: dTurbFluxCanopy_dTGround ! derivative in net canopy turbulent fluxes w.r.t. ground temperature (W m-2 K-1) - real(dp),intent(out) :: dTurbFluxGround_dTCanair ! derivative in net ground turbulent fluxes w.r.t. canopy air temperature (W m-2 K-1) - real(dp),intent(out) :: dTurbFluxGround_dTCanopy ! derivative in net ground turbulent fluxes w.r.t. canopy temperature (W m-2 K-1) - real(dp),intent(out) :: dTurbFluxGround_dTGround ! derivative in net ground turbulent fluxes w.r.t. ground temperature (W m-2 K-1) + real(rkind),intent(out) :: dTurbFluxCanair_dTCanair ! derivative in net canopy air space fluxes w.r.t. canopy air temperature (W m-2 K-1) + real(rkind),intent(out) :: dTurbFluxCanair_dTCanopy ! derivative in net canopy air space fluxes w.r.t. canopy temperature (W m-2 K-1) + real(rkind),intent(out) :: dTurbFluxCanair_dTGround ! derivative in net canopy air space fluxes w.r.t. ground temperature (W m-2 K-1) + real(rkind),intent(out) :: dTurbFluxCanopy_dTCanair ! derivative in net canopy turbulent fluxes w.r.t. canopy air temperature (W m-2 K-1) + real(rkind),intent(out) :: dTurbFluxCanopy_dTCanopy ! derivative in net canopy turbulent fluxes w.r.t. canopy temperature (W m-2 K-1) + real(rkind),intent(out) :: dTurbFluxCanopy_dTGround ! derivative in net canopy turbulent fluxes w.r.t. ground temperature (W m-2 K-1) + real(rkind),intent(out) :: dTurbFluxGround_dTCanair ! derivative in net ground turbulent fluxes w.r.t. canopy air temperature (W m-2 K-1) + real(rkind),intent(out) :: dTurbFluxGround_dTCanopy ! derivative in net ground turbulent fluxes w.r.t. canopy temperature (W m-2 K-1) + real(rkind),intent(out) :: dTurbFluxGround_dTGround ! derivative in net ground turbulent fluxes w.r.t. ground temperature (W m-2 K-1) ! output: liquid flux derivatives (canopy evap) - real(dp),intent(out) :: dLatHeatCanopyEvap_dCanLiq ! derivative in latent heat of canopy evaporation w.r.t. canopy liquid water content (W kg-1) - real(dp),intent(out) :: dLatHeatCanopyEvap_dTCanair ! derivative in latent heat of canopy evaporation w.r.t. canopy air temperature (W m-2 K-1) - real(dp),intent(out) :: dLatHeatCanopyEvap_dTCanopy ! derivative in latent heat of canopy evaporation w.r.t. canopy temperature (W m-2 K-1) - real(dp),intent(out) :: dLatHeatCanopyEvap_dTGround ! derivative in latent heat of canopy evaporation w.r.t. ground temperature (W m-2 K-1) + real(rkind),intent(out) :: dLatHeatCanopyEvap_dCanLiq ! derivative in latent heat of canopy evaporation w.r.t. canopy liquid water content (W kg-1) + real(rkind),intent(out) :: dLatHeatCanopyEvap_dTCanair ! derivative in latent heat of canopy evaporation w.r.t. canopy air temperature (W m-2 K-1) + real(rkind),intent(out) :: dLatHeatCanopyEvap_dTCanopy ! derivative in latent heat of canopy evaporation w.r.t. canopy temperature (W m-2 K-1) + real(rkind),intent(out) :: dLatHeatCanopyEvap_dTGround ! derivative in latent heat of canopy evaporation w.r.t. ground temperature (W m-2 K-1) ! output: liquid flux derivatives (ground evap) - real(dp),intent(out) :: dLatHeatGroundEvap_dCanLiq ! derivative in latent heat of ground evaporation w.r.t. canopy liquid water content (J kg-1 s-1) - real(dp),intent(out) :: dLatHeatGroundEvap_dTCanair ! derivative in latent heat of ground evaporation w.r.t. canopy air temperature (W m-2 K-1) - real(dp),intent(out) :: dLatHeatGroundEvap_dTCanopy ! derivative in latent heat of ground evaporation w.r.t. canopy temperature (W m-2 K-1) - real(dp),intent(out) :: dLatHeatGroundEvap_dTGround ! derivative in latent heat of ground evaporation w.r.t. ground temperature (W m-2 K-1) + real(rkind),intent(out) :: dLatHeatGroundEvap_dCanLiq ! derivative in latent heat of ground evaporation w.r.t. canopy liquid water content (J kg-1 s-1) + real(rkind),intent(out) :: dLatHeatGroundEvap_dTCanair ! derivative in latent heat of ground evaporation w.r.t. canopy air temperature (W m-2 K-1) + real(rkind),intent(out) :: dLatHeatGroundEvap_dTCanopy ! derivative in latent heat of ground evaporation w.r.t. canopy temperature (W m-2 K-1) + real(rkind),intent(out) :: dLatHeatGroundEvap_dTGround ! derivative in latent heat of ground evaporation w.r.t. ground temperature (W m-2 K-1) ! output: cross derivatives - real(dp),intent(out) :: dTurbFluxCanair_dCanLiq ! derivative in net canopy air space fluxes w.r.t. canopy liquid water content (J kg-1 s-1) - real(dp),intent(out) :: dTurbFluxCanopy_dCanLiq ! derivative in net canopy turbulent fluxes w.r.t. canopy liquid water content (J kg-1 s-1) - real(dp),intent(out) :: dTurbFluxGround_dCanLiq ! derivative in net ground turbulent fluxes w.r.t. canopy liquid water content (J kg-1 s-1) + real(rkind),intent(out) :: dTurbFluxCanair_dCanLiq ! derivative in net canopy air space fluxes w.r.t. canopy liquid water content (J kg-1 s-1) + real(rkind),intent(out) :: dTurbFluxCanopy_dCanLiq ! derivative in net canopy turbulent fluxes w.r.t. canopy liquid water content (J kg-1 s-1) + real(rkind),intent(out) :: dTurbFluxGround_dCanLiq ! derivative in net ground turbulent fluxes w.r.t. canopy liquid water content (J kg-1 s-1) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! ----------------------------------------------------------------------------------------------------------------------------------------- ! local variables -- general - real(dp) :: fpart1,fpart2 ! different parts of a function - real(dp) :: dPart0,dpart1,dpart2 ! derivatives for different parts of a function + real(rkind) :: fpart1,fpart2 ! different parts of a function + real(rkind) :: dPart0,dpart1,dpart2 ! derivatives for different parts of a function ! local variables -- "constants" - real(dp) :: volHeatCapacityAir ! volumetric heat capacity of air (J m-3) - real(dp) :: latentHeatConstant ! latent heat constant (kg m-3 K-1) + real(rkind) :: volHeatCapacityAir ! volumetric heat capacity of air (J m-3) + real(rkind) :: latentHeatConstant ! latent heat constant (kg m-3 K-1) ! local variables -- derivatives for energy conductances - real(dp) :: dEvapCond_dCanopyTemp ! derivative in evap conductance w.r.t. canopy temperature - real(dp) :: dTransCond_dCanopyTemp ! derivative in trans conductance w.r.t. canopy temperature - real(dp) :: dCanopyCond_dCanairTemp ! derivative in canopy conductance w.r.t. canopy air temperature - real(dp) :: dCanopyCond_dCanopyTemp ! derivative in canopy conductance w.r.t. canopy temperature - real(dp) :: dGroundCondSH_dCanairTemp ! derivative in ground conductance of sensible heat w.r.t. canopy air temperature - real(dp) :: dGroundCondSH_dCanopyTemp ! derivative in ground conductance of sensible heat w.r.t. canopy temperature - real(dp) :: dGroundCondSH_dGroundTemp ! derivative in ground conductance of sensible heat w.r.t. ground temperature + real(rkind) :: dEvapCond_dCanopyTemp ! derivative in evap conductance w.r.t. canopy temperature + real(rkind) :: dTransCond_dCanopyTemp ! derivative in trans conductance w.r.t. canopy temperature + real(rkind) :: dCanopyCond_dCanairTemp ! derivative in canopy conductance w.r.t. canopy air temperature + real(rkind) :: dCanopyCond_dCanopyTemp ! derivative in canopy conductance w.r.t. canopy temperature + real(rkind) :: dGroundCondSH_dCanairTemp ! derivative in ground conductance of sensible heat w.r.t. canopy air temperature + real(rkind) :: dGroundCondSH_dCanopyTemp ! derivative in ground conductance of sensible heat w.r.t. canopy temperature + real(rkind) :: dGroundCondSH_dGroundTemp ! derivative in ground conductance of sensible heat w.r.t. ground temperature ! local variables -- derivatives for mass conductances - real(dp) :: dGroundCondLH_dCanairTemp ! derivative in ground conductance w.r.t. canopy air temperature - real(dp) :: dGroundCondLH_dCanopyTemp ! derivative in ground conductance w.r.t. canopy temperature - real(dp) :: dGroundCondLH_dGroundTemp ! derivative in ground conductance w.r.t. ground temperature + real(rkind) :: dGroundCondLH_dCanairTemp ! derivative in ground conductance w.r.t. canopy air temperature + real(rkind) :: dGroundCondLH_dCanopyTemp ! derivative in ground conductance w.r.t. canopy temperature + real(rkind) :: dGroundCondLH_dGroundTemp ! derivative in ground conductance w.r.t. ground temperature ! local variables -- derivatives for the canopy air space variables - real(dp) :: fPart_VP ! part of the function for vapor pressure of the canopy air space - real(dp) :: leafConductanceTr ! leaf conductance for transpiration (m s-1) - real(dp) :: dVPCanopyAir_dTCanair ! derivative in the vapor pressure of the canopy air space w.r.t. temperature of the canopy air space - real(dp) :: dVPCanopyAir_dTCanopy ! derivative in the vapor pressure of the canopy air space w.r.t. temperature of the canopy - real(dp) :: dVPCanopyAir_dTGround ! derivative in the vapor pressure of the canopy air space w.r.t. temperature of the ground - real(dp) :: dVPCanopyAir_dWetFrac ! derivative of vapor pressure in the canopy air space w.r.t. wetted fraction of the canopy - real(dp) :: dVPCanopyAir_dCanLiq ! derivative of vapor pressure in the canopy air space w.r.t. canopy liquid water content + real(rkind) :: fPart_VP ! part of the function for vapor pressure of the canopy air space + real(rkind) :: leafConductanceTr ! leaf conductance for transpiration (m s-1) + real(rkind) :: dVPCanopyAir_dTCanair ! derivative in the vapor pressure of the canopy air space w.r.t. temperature of the canopy air space + real(rkind) :: dVPCanopyAir_dTCanopy ! derivative in the vapor pressure of the canopy air space w.r.t. temperature of the canopy + real(rkind) :: dVPCanopyAir_dTGround ! derivative in the vapor pressure of the canopy air space w.r.t. temperature of the ground + real(rkind) :: dVPCanopyAir_dWetFrac ! derivative of vapor pressure in the canopy air space w.r.t. wetted fraction of the canopy + real(rkind) :: dVPCanopyAir_dCanLiq ! derivative of vapor pressure in the canopy air space w.r.t. canopy liquid water content ! local variables -- sensible heat flux derivatives - real(dp) :: dSenHeatTotal_dTCanair ! derivative in the total sensible heat flux w.r.t. canopy air temperature - real(dp) :: dSenHeatTotal_dTCanopy ! derivative in the total sensible heat flux w.r.t. canopy air temperature - real(dp) :: dSenHeatTotal_dTGround ! derivative in the total sensible heat flux w.r.t. ground temperature - real(dp) :: dSenHeatCanopy_dTCanair ! derivative in the canopy sensible heat flux w.r.t. canopy air temperature - real(dp) :: dSenHeatCanopy_dTCanopy ! derivative in the canopy sensible heat flux w.r.t. canopy temperature - real(dp) :: dSenHeatCanopy_dTGround ! derivative in the canopy sensible heat flux w.r.t. ground temperature - real(dp) :: dSenHeatGround_dTCanair ! derivative in the ground sensible heat flux w.r.t. canopy air temperature - real(dp) :: dSenHeatGround_dTCanopy ! derivative in the ground sensible heat flux w.r.t. canopy temperature - real(dp) :: dSenHeatGround_dTGround ! derivative in the ground sensible heat flux w.r.t. ground temperature + real(rkind) :: dSenHeatTotal_dTCanair ! derivative in the total sensible heat flux w.r.t. canopy air temperature + real(rkind) :: dSenHeatTotal_dTCanopy ! derivative in the total sensible heat flux w.r.t. canopy air temperature + real(rkind) :: dSenHeatTotal_dTGround ! derivative in the total sensible heat flux w.r.t. ground temperature + real(rkind) :: dSenHeatCanopy_dTCanair ! derivative in the canopy sensible heat flux w.r.t. canopy air temperature + real(rkind) :: dSenHeatCanopy_dTCanopy ! derivative in the canopy sensible heat flux w.r.t. canopy temperature + real(rkind) :: dSenHeatCanopy_dTGround ! derivative in the canopy sensible heat flux w.r.t. ground temperature + real(rkind) :: dSenHeatGround_dTCanair ! derivative in the ground sensible heat flux w.r.t. canopy air temperature + real(rkind) :: dSenHeatGround_dTCanopy ! derivative in the ground sensible heat flux w.r.t. canopy temperature + real(rkind) :: dSenHeatGround_dTGround ! derivative in the ground sensible heat flux w.r.t. ground temperature ! local variables -- latent heat flux derivatives - real(dp) :: dLatHeatCanopyTrans_dTCanair ! derivative in the canopy transpiration flux w.r.t. canopy air temperature - real(dp) :: dLatHeatCanopyTrans_dTCanopy ! derivative in the canopy transpiration flux w.r.t. canopy temperature - real(dp) :: dLatHeatCanopyTrans_dTGround ! derivative in the canopy transpiration flux w.r.t. ground temperature + real(rkind) :: dLatHeatCanopyTrans_dTCanair ! derivative in the canopy transpiration flux w.r.t. canopy air temperature + real(rkind) :: dLatHeatCanopyTrans_dTCanopy ! derivative in the canopy transpiration flux w.r.t. canopy temperature + real(rkind) :: dLatHeatCanopyTrans_dTGround ! derivative in the canopy transpiration flux w.r.t. ground temperature ! local variables -- wetted fraction derivatives - real(dp) :: dLatHeatCanopyEvap_dWetFrac ! derivative in the latent heat of canopy evaporation w.r.t. canopy wet fraction (W m-2) - real(dp) :: dLatHeatCanopyTrans_dWetFrac ! derivative in the latent heat of canopy transpiration w.r.t. canopy wet fraction (W m-2) - real(dp) :: dLatHeatCanopyTrans_dCanLiq ! derivative in the latent heat of canopy transpiration w.r.t. canopy liquid water (J kg-1 s-1) + real(rkind) :: dLatHeatCanopyEvap_dWetFrac ! derivative in the latent heat of canopy evaporation w.r.t. canopy wet fraction (W m-2) + real(rkind) :: dLatHeatCanopyTrans_dWetFrac ! derivative in the latent heat of canopy transpiration w.r.t. canopy wet fraction (W m-2) + real(rkind) :: dLatHeatCanopyTrans_dCanLiq ! derivative in the latent heat of canopy transpiration w.r.t. canopy liquid water (J kg-1 s-1) ! ----------------------------------------------------------------------------------------------------------------------------------------- ! initialize error control err=0; message='turbFluxes/' @@ -2775,12 +2775,12 @@ subroutine turbFluxes(& if(computeVegFlux)then leafConductance = exposedVAI/leafResistance leafConductanceTr = canopySunlitLAI/(leafResistance+stomResistSunlit) + canopyShadedLAI/(leafResistance+stomResistShaded) - canopyConductance = 1._dp/canopyResistance + canopyConductance = 1._rkind/canopyResistance else - leafConductance = 0._dp - canopyConductance = 0._dp + leafConductance = 0._rkind + canopyConductance = 0._rkind end if - groundConductanceSH = 1._dp/groundResistance + groundConductanceSH = 1._rkind/groundResistance ! compute total conductance for sensible heat totalConductanceSH = leafConductance + groundConductanceSH + canopyConductance @@ -2788,14 +2788,14 @@ subroutine turbFluxes(& ! compute conductances for latent heat (m s-1) if(computeVegFlux)then evapConductance = canopyWetFraction*leafConductance - transConductance = (1._dp - canopyWetFraction) * leafConductanceTr + transConductance = (1._rkind - canopyWetFraction) * leafConductanceTr !write(*,'(a,10(f14.8,1x))') 'canopySunlitLAI, canopyShadedLAI, stomResistSunlit, stomResistShaded, leafResistance, canopyWetFraction = ', & ! canopySunlitLAI, canopyShadedLAI, stomResistSunlit, stomResistShaded, leafResistance, canopyWetFraction else - evapConductance = 0._dp - transConductance = 0._dp + evapConductance = 0._rkind + transConductance = 0._rkind end if - groundConductanceLH = 1._dp/(groundResistance + soilResistance) ! NOTE: soilResistance accounts for fractional snow, and =0 when snow cover is 100% + groundConductanceLH = 1._rkind/(groundResistance + soilResistance) ! NOTE: soilResistance accounts for fractional snow, and =0 when snow cover is 100% totalConductanceLH = evapConductance + transConductance + groundConductanceLH + canopyConductance ! check sensible heat conductance @@ -2818,30 +2818,30 @@ subroutine turbFluxes(& if(computeVegFlux)then dEvapCond_dCanopyTemp = dCanopyWetFraction_dT*leafConductance ! derivative in evap conductance w.r.t. canopy temperature dTransCond_dCanopyTemp = -dCanopyWetFraction_dT*leafConductanceTr ! derivative in trans conductance w.r.t. canopy temperature - dCanopyCond_dCanairTemp = -dCanopyResistance_dTCanair/canopyResistance**2._dp ! derivative in canopy conductance w.r.t. canopy air emperature - dCanopyCond_dCanopyTemp = -dCanopyResistance_dTCanopy/canopyResistance**2._dp ! derivative in canopy conductance w.r.t. canopy temperature - dGroundCondSH_dCanairTemp = -dGroundResistance_dTCanair/groundResistance**2._dp ! derivative in ground conductance w.r.t. canopy air temperature - dGroundCondSH_dCanopyTemp = -dGroundResistance_dTCanopy/groundResistance**2._dp ! derivative in ground conductance w.r.t. canopy temperature - dGroundCondSH_dGroundTemp = -dGroundResistance_dTGround/groundResistance**2._dp ! derivative in ground conductance w.r.t. ground temperature + dCanopyCond_dCanairTemp = -dCanopyResistance_dTCanair/canopyResistance**2._rkind ! derivative in canopy conductance w.r.t. canopy air emperature + dCanopyCond_dCanopyTemp = -dCanopyResistance_dTCanopy/canopyResistance**2._rkind ! derivative in canopy conductance w.r.t. canopy temperature + dGroundCondSH_dCanairTemp = -dGroundResistance_dTCanair/groundResistance**2._rkind ! derivative in ground conductance w.r.t. canopy air temperature + dGroundCondSH_dCanopyTemp = -dGroundResistance_dTCanopy/groundResistance**2._rkind ! derivative in ground conductance w.r.t. canopy temperature + dGroundCondSH_dGroundTemp = -dGroundResistance_dTGround/groundResistance**2._rkind ! derivative in ground conductance w.r.t. ground temperature else - dEvapCond_dCanopyTemp = 0._dp ! derivative in evap conductance w.r.t. canopy temperature - dTransCond_dCanopyTemp = 0._dp ! derivative in trans conductance w.r.t. canopy temperature - dCanopyCond_dCanairTemp = 0._dp ! derivative in canopy conductance w.r.t. canopy air emperature - dCanopyCond_dCanopyTemp = 0._dp ! derivative in canopy conductance w.r.t. canopy temperature - dGroundCondSH_dCanairTemp = 0._dp ! derivative in ground conductance w.r.t. canopy air temperature - dGroundCondSH_dCanopyTemp = 0._dp ! derivative in ground conductance w.r.t. canopy temperature - dGroundCondSH_dGroundTemp = -dGroundResistance_dTGround/groundResistance**2._dp ! derivative in ground conductance w.r.t. ground temperature + dEvapCond_dCanopyTemp = 0._rkind ! derivative in evap conductance w.r.t. canopy temperature + dTransCond_dCanopyTemp = 0._rkind ! derivative in trans conductance w.r.t. canopy temperature + dCanopyCond_dCanairTemp = 0._rkind ! derivative in canopy conductance w.r.t. canopy air emperature + dCanopyCond_dCanopyTemp = 0._rkind ! derivative in canopy conductance w.r.t. canopy temperature + dGroundCondSH_dCanairTemp = 0._rkind ! derivative in ground conductance w.r.t. canopy air temperature + dGroundCondSH_dCanopyTemp = 0._rkind ! derivative in ground conductance w.r.t. canopy temperature + dGroundCondSH_dGroundTemp = -dGroundResistance_dTGround/groundResistance**2._rkind ! derivative in ground conductance w.r.t. ground temperature end if ! compute derivatives in individual conductances for latent heat w.r.t. canopy temperature (m s-1 K-1) if(computeVegFlux)then - dGroundCondLH_dCanairTemp = -dGroundResistance_dTCanair/(groundResistance+soilResistance)**2._dp ! derivative in ground conductance w.r.t. canopy air temperature - dGroundCondLH_dCanopyTemp = -dGroundResistance_dTCanopy/(groundResistance+soilResistance)**2._dp ! derivative in ground conductance w.r.t. canopy temperature - dGroundCondLH_dGroundTemp = -dGroundResistance_dTGround/(groundResistance+soilResistance)**2._dp ! derivative in ground conductance w.r.t. ground temperature + dGroundCondLH_dCanairTemp = -dGroundResistance_dTCanair/(groundResistance+soilResistance)**2._rkind ! derivative in ground conductance w.r.t. canopy air temperature + dGroundCondLH_dCanopyTemp = -dGroundResistance_dTCanopy/(groundResistance+soilResistance)**2._rkind ! derivative in ground conductance w.r.t. canopy temperature + dGroundCondLH_dGroundTemp = -dGroundResistance_dTGround/(groundResistance+soilResistance)**2._rkind ! derivative in ground conductance w.r.t. ground temperature else - dGroundCondLH_dCanairTemp = 0._dp ! derivative in ground conductance w.r.t. canopy air temperature - dGroundCondLH_dCanopyTemp = 0._dp ! derivative in ground conductance w.r.t. canopy temperature - dGroundCondLH_dGroundTemp = -dGroundResistance_dTGround/(groundResistance+soilResistance)**2._dp ! derivative in ground conductance w.r.t. ground temperature + dGroundCondLH_dCanairTemp = 0._rkind ! derivative in ground conductance w.r.t. canopy air temperature + dGroundCondLH_dCanopyTemp = 0._rkind ! derivative in ground conductance w.r.t. canopy temperature + dGroundCondLH_dGroundTemp = -dGroundResistance_dTGround/(groundResistance+soilResistance)**2._rkind ! derivative in ground conductance w.r.t. ground temperature end if end if ! (if computing analytical derivatives) @@ -2885,9 +2885,9 @@ subroutine turbFluxes(& ! * no vegetation, so fluxes are zero else - senHeatCanopy = 0._dp - latHeatCanopyEvap = 0._dp - latHeatCanopyTrans = 0._dp + senHeatCanopy = 0._rkind + latHeatCanopyEvap = 0._rkind + latHeatCanopyTrans = 0._rkind end if ! compute sensible and latent heat fluxes from the ground to the canopy air space (W m-2) @@ -2914,20 +2914,20 @@ subroutine turbFluxes(& ! compute derivatives of vapor pressure in the canopy air space w.r.t. all state variables ! (derivative of vapor pressure in the canopy air space w.r.t. temperature of the canopy air space) dPart1 = dCanopyCond_dCanairTemp*VPair + dGroundCondLH_dCanairTemp*satVP_GroundTemp*soilRelHumidity - dPart2 = -(dCanopyCond_dCanairTemp + dGroundCondLH_dCanairTemp)/(totalConductanceLH**2._dp) + dPart2 = -(dCanopyCond_dCanairTemp + dGroundCondLH_dCanairTemp)/(totalConductanceLH**2._rkind) dVPCanopyAir_dTCanair = dPart1/totalConductanceLH + fPart_VP*dPart2 ! (derivative of vapor pressure in the canopy air space w.r.t. temperature of the canopy) dPart0 = (evapConductance + transConductance)*dSVPCanopy_dCanopyTemp + (dEvapCond_dCanopyTemp + dTransCond_dCanopyTemp)*satVP_CanopyTemp dPart1 = dCanopyCond_dCanopyTemp*VPair + dPart0 + dGroundCondLH_dCanopyTemp*satVP_GroundTemp*soilRelHumidity - dPart2 = -(dCanopyCond_dCanopyTemp + dEvapCond_dCanopyTemp + dTransCond_dCanopyTemp + dGroundCondLH_dCanopyTemp)/(totalConductanceLH**2._dp) + dPart2 = -(dCanopyCond_dCanopyTemp + dEvapCond_dCanopyTemp + dTransCond_dCanopyTemp + dGroundCondLH_dCanopyTemp)/(totalConductanceLH**2._rkind) dVPCanopyAir_dTCanopy = dPart1/totalConductanceLH + fPart_VP*dPart2 ! (derivative of vapor pressure in the canopy air space w.r.t. temperature of the ground) dPart1 = dGroundCondLH_dGroundTemp*satVP_GroundTemp*soilRelHumidity + groundConductanceLH*dSVPGround_dGroundTemp*soilRelHumidity - dPart2 = -dGroundCondLH_dGroundTemp/(totalConductanceLH**2._dp) + dPart2 = -dGroundCondLH_dGroundTemp/(totalConductanceLH**2._rkind) dVPCanopyAir_dTGround = dPart1/totalConductanceLH + fPart_VP*dPart2 ! (derivative of vapor pressure in the canopy air space w.r.t. wetted fraction of the canopy) dPart1 = (leafConductance - leafConductanceTr)*satVP_CanopyTemp - dPart2 = -(leafConductance - leafConductanceTr)/(totalConductanceLH**2._dp) + dPart2 = -(leafConductance - leafConductanceTr)/(totalConductanceLH**2._rkind) dVPCanopyAir_dWetFrac = dPart1/totalConductanceLH + fPart_VP*dPart2 dVPCanopyAir_dCanLiq = dVPCanopyAir_dWetFrac*dCanopyWetFraction_dWat !write(*,'(a,5(f20.8,1x))') 'dVPCanopyAir_dTCanair, dVPCanopyAir_dTCanopy, dVPCanopyAir_dTGround, dVPCanopyAir_dWetFrac, dVPCanopyAir_dCanLiq = ', & @@ -2936,14 +2936,14 @@ subroutine turbFluxes(& ! sensible heat from the canopy to the atmosphere dSenHeatTotal_dTCanair = -volHeatCapacityAir*canopyConductance - volHeatCapacityAir*dCanopyCond_dCanairTemp*(canairTemp - airtemp) dSenHeatTotal_dTCanopy = -volHeatCapacityAir*dCanopyCond_dCanopyTemp*(canairTemp - airtemp) - dSenHeatTotal_dTGround = 0._dp + dSenHeatTotal_dTGround = 0._rkind !write(*,'(a,3(f20.8,1x))') 'dSenHeatTotal_dTCanair, dSenHeatTotal_dTCanopy, dSenHeatTotal_dTGround = ', & ! dSenHeatTotal_dTCanair, dSenHeatTotal_dTCanopy, dSenHeatTotal_dTGround ! sensible heat from the canopy to the canopy air space dSenHeatCanopy_dTCanair = volHeatCapacityAir*leafConductance dSenHeatCanopy_dTCanopy = -volHeatCapacityAir*leafConductance - dSenHeatCanopy_dTGround = 0._dp + dSenHeatCanopy_dTGround = 0._rkind !write(*,'(a,3(f20.8,1x))') 'dSenHeatCanopy_dTCanair, dSenHeatCanopy_dTCanopy, dSenHeatCanopy_dTGround = ', & ! dSenHeatCanopy_dTCanair, dSenHeatCanopy_dTCanopy, dSenHeatCanopy_dTGround @@ -2994,7 +2994,7 @@ subroutine turbFluxes(& ! latent heat associated with canopy transpiration w.r.t. wetted fraction of the canopy dPart1 = LH_vap*latentHeatConstant*leafConductanceTr ! NOTE: positive, since (1 - wetFrac) - fPart1 = -dPart1*(1._dp - canopyWetFraction) + fPart1 = -dPart1*(1._rkind - canopyWetFraction) dLatHeatCanopyTrans_dWetFrac = dPart1*(satVP_CanopyTemp - VP_CanopyAir) + fPart1*(-dVPCanopyAir_dWetFrac) !print*, 'dLatHeatCanopyTrans_dWetFrac = ', dLatHeatCanopyTrans_dWetFrac @@ -3005,30 +3005,30 @@ subroutine turbFluxes(& else ! canopy is undefined ! set derivatives for canopy fluxes to zero (no canopy, so fluxes are undefined) - dSenHeatTotal_dTCanair = 0._dp - dSenHeatTotal_dTCanopy = 0._dp - dSenHeatTotal_dTGround = 0._dp - dSenHeatCanopy_dTCanair = 0._dp - dSenHeatCanopy_dTCanopy = 0._dp - dSenHeatCanopy_dTGround = 0._dp - dLatHeatCanopyEvap_dTCanair = 0._dp - dLatHeatCanopyEvap_dTCanopy = 0._dp - dLatHeatCanopyEvap_dTGround = 0._dp - dLatHeatCanopyTrans_dTCanair = 0._dp - dLatHeatCanopyTrans_dTCanopy = 0._dp - dLatHeatCanopyTrans_dTGround = 0._dp + dSenHeatTotal_dTCanair = 0._rkind + dSenHeatTotal_dTCanopy = 0._rkind + dSenHeatTotal_dTGround = 0._rkind + dSenHeatCanopy_dTCanair = 0._rkind + dSenHeatCanopy_dTCanopy = 0._rkind + dSenHeatCanopy_dTGround = 0._rkind + dLatHeatCanopyEvap_dTCanair = 0._rkind + dLatHeatCanopyEvap_dTCanopy = 0._rkind + dLatHeatCanopyEvap_dTGround = 0._rkind + dLatHeatCanopyTrans_dTCanair = 0._rkind + dLatHeatCanopyTrans_dTCanopy = 0._rkind + dLatHeatCanopyTrans_dTGround = 0._rkind ! set derivatives for wetted area and canopy transpiration to zero (no canopy, so fluxes are undefined) - dLatHeatCanopyEvap_dWetFrac = 0._dp - dLatHeatCanopyEvap_dCanLiq = 0._dp - dLatHeatCanopyTrans_dCanLiq = 0._dp - dVPCanopyAir_dCanLiq = 0._dp + dLatHeatCanopyEvap_dWetFrac = 0._rkind + dLatHeatCanopyEvap_dCanLiq = 0._rkind + dLatHeatCanopyTrans_dCanLiq = 0._rkind + dVPCanopyAir_dCanLiq = 0._rkind ! set derivatives for ground fluxes w.r.t canopy temperature to zero (no canopy, so fluxes are undefined) - dSenHeatGround_dTCanair = 0._dp - dSenHeatGround_dTCanopy = 0._dp - dLatHeatGroundEvap_dTCanair = 0._dp - dLatHeatGroundEvap_dTCanopy = 0._dp + dSenHeatGround_dTCanair = 0._rkind + dSenHeatGround_dTCanopy = 0._rkind + dLatHeatGroundEvap_dTCanair = 0._rkind + dLatHeatGroundEvap_dTCanopy = 0._rkind ! compute derivatives for the ground fluxes w.r.t. ground temperature dSenHeatGround_dTGround = (-volHeatCapacityAir*dGroundCondSH_dGroundTemp)*(groundTemp - airtemp) + & ! d(ground sensible heat flux)/d(ground temp) @@ -3069,27 +3069,27 @@ subroutine turbFluxes(& dLatHeatCanopyEvap_dCanLiq = dLatHeatCanopyEvap_dWetFrac*dCanopyWetFraction_dWat ! derivative in latent heat of canopy evaporation w.r.t. canopy liquid water (W kg-1) dLatHeatGroundEvap_dCanLiq = latHeatSubVapGround*latentHeatConstant*groundConductanceLH*dVPCanopyAir_dCanLiq ! derivative in latent heat of ground evaporation w.r.t. canopy liquid water (J kg-1 s-1) ! (cross deriavtives) - dTurbFluxCanair_dCanLiq = 0._dp ! derivative in net canopy air space fluxes w.r.t. canopy liquid water content (J kg-1 s-1) + dTurbFluxCanair_dCanLiq = 0._rkind ! derivative in net canopy air space fluxes w.r.t. canopy liquid water content (J kg-1 s-1) dTurbFluxCanopy_dCanLiq = dLatHeatCanopyEvap_dCanLiq + dLatHeatCanopyTrans_dCanLiq ! derivative in net canopy turbulent fluxes w.r.t. canopy liquid water content (J kg-1 s-1) dTurbFluxGround_dCanLiq = dLatHeatGroundEvap_dCanLiq ! derivative in net ground turbulent fluxes w.r.t. canopy liquid water content (J kg-1 s-1) else ! (just make sure we return something) ! (energy derivatives) - dTurbFluxCanair_dTCanair = 0._dp - dTurbFluxCanair_dTCanopy = 0._dp - dTurbFluxCanair_dTGround = 0._dp - dTurbFluxCanopy_dTCanair = 0._dp - dTurbFluxCanopy_dTCanopy = 0._dp - dTurbFluxCanopy_dTGround = 0._dp - dTurbFluxGround_dTCanair = 0._dp - dTurbFluxGround_dTCanopy = 0._dp - dTurbFluxGround_dTGround = 0._dp + dTurbFluxCanair_dTCanair = 0._rkind + dTurbFluxCanair_dTCanopy = 0._rkind + dTurbFluxCanair_dTGround = 0._rkind + dTurbFluxCanopy_dTCanair = 0._rkind + dTurbFluxCanopy_dTCanopy = 0._rkind + dTurbFluxCanopy_dTGround = 0._rkind + dTurbFluxGround_dTCanair = 0._rkind + dTurbFluxGround_dTCanopy = 0._rkind + dTurbFluxGround_dTGround = 0._rkind ! (liquid water derivatives) - dLatHeatCanopyEvap_dCanLiq = 0._dp - dLatHeatGroundEvap_dCanLiq = 0._dp + dLatHeatCanopyEvap_dCanLiq = 0._rkind + dLatHeatGroundEvap_dCanLiq = 0._rkind ! (cross deriavtives) - dTurbFluxCanair_dCanLiq = 0._dp - dTurbFluxCanopy_dCanLiq = 0._dp - dTurbFluxGround_dCanLiq = 0._dp + dTurbFluxCanair_dCanLiq = 0._rkind + dTurbFluxCanopy_dCanLiq = 0._rkind + dTurbFluxGround_dCanLiq = 0._rkind end if end subroutine turbFluxes @@ -3123,27 +3123,27 @@ subroutine aStability(& logical(lgt),intent(in) :: computeDerivative ! flag to compute the derivative integer(i4b),intent(in) :: ixStability ! choice of stability function ! input: forcing data, diagnostic and state variables - real(dp),intent(in) :: mHeight ! measurement height (m) - real(dp),intent(in) :: airtemp ! air temperature (K) - real(dp),intent(in) :: sfcTemp ! surface temperature (K) - real(dp),intent(in) :: windspd ! wind speed (m s-1) + real(rkind),intent(in) :: mHeight ! measurement height (m) + real(rkind),intent(in) :: airtemp ! air temperature (K) + real(rkind),intent(in) :: sfcTemp ! surface temperature (K) + real(rkind),intent(in) :: windspd ! wind speed (m s-1) ! input: stability parameters - real(dp),intent(in) :: critRichNumber ! critical value for the bulk Richardson number where turbulence ceases (-) - real(dp),intent(in) :: Louis79_bparam ! parameter in Louis (1979) stability function - real(dp),intent(in) :: Mahrt87_eScale ! exponential scaling factor in the Mahrt (1987) stability function + real(rkind),intent(in) :: critRichNumber ! critical value for the bulk Richardson number where turbulence ceases (-) + real(rkind),intent(in) :: Louis79_bparam ! parameter in Louis (1979) stability function + real(rkind),intent(in) :: Mahrt87_eScale ! exponential scaling factor in the Mahrt (1987) stability function ! output - real(dp),intent(out) :: RiBulk ! bulk Richardson number (-) - real(dp),intent(out) :: stabilityCorrection ! stability correction for turbulent heat fluxes (-) - real(dp),intent(out) :: dStabilityCorrection_dRich ! derivative in stability correction w.r.t. Richardson number (-) - real(dp),intent(out) :: dStabilityCorrection_dAirTemp ! derivative in stability correction w.r.t. air temperature (K-1) - real(dp),intent(out) :: dStabilityCorrection_dSfcTemp ! derivative in stability correction w.r.t. surface temperature (K-1) + real(rkind),intent(out) :: RiBulk ! bulk Richardson number (-) + real(rkind),intent(out) :: stabilityCorrection ! stability correction for turbulent heat fluxes (-) + real(rkind),intent(out) :: dStabilityCorrection_dRich ! derivative in stability correction w.r.t. Richardson number (-) + real(rkind),intent(out) :: dStabilityCorrection_dAirTemp ! derivative in stability correction w.r.t. air temperature (K-1) + real(rkind),intent(out) :: dStabilityCorrection_dSfcTemp ! derivative in stability correction w.r.t. surface temperature (K-1) integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! local - real(dp), parameter :: verySmall=1.e-10_dp ! a very small number (avoid stability of zero) - real(dp) :: dRiBulk_dAirTemp ! derivative in the bulk Richardson number w.r.t. air temperature (K-1) - real(dp) :: dRiBulk_dSfcTemp ! derivative in the bulk Richardson number w.r.t. surface temperature (K-1) - real(dp) :: bPrime ! scaled "b" parameter for stability calculations in Louis (1979) + real(rkind), parameter :: verySmall=1.e-10_rkind ! a very small number (avoid stability of zero) + real(rkind) :: dRiBulk_dAirTemp ! derivative in the bulk Richardson number w.r.t. air temperature (K-1) + real(rkind) :: dRiBulk_dSfcTemp ! derivative in the bulk Richardson number w.r.t. surface temperature (K-1) + real(rkind) :: bPrime ! scaled "b" parameter for stability calculations in Louis (1979) ! ----------------------------------------------------------------------------------------------------------------------------------------- ! initialize error control err=0; message='aStability/' @@ -3164,18 +3164,18 @@ subroutine aStability(& ! set derivative to one if not computing it if(.not.computeDerivative)then - dStabilityCorrection_dRich = 1._dp - dStabilityCorrection_dAirTemp = 1._dp - dStabilityCorrection_dSfcTemp = 1._dp + dStabilityCorrection_dRich = 1._rkind + dStabilityCorrection_dAirTemp = 1._rkind + dStabilityCorrection_dSfcTemp = 1._rkind end if ! ***** process unstable cases - if(RiBulk<0._dp)then + if(RiBulk<0._rkind)then ! compute surface-atmosphere exchange coefficient (-) - stabilityCorrection = (1._dp - 16._dp*RiBulk)**0.5_dp + stabilityCorrection = (1._rkind - 16._rkind*RiBulk)**0.5_rkind ! compute derivative in surface-atmosphere exchange coefficient w.r.t. temperature (K-1) if(computeDerivative)then - dStabilityCorrection_dRich = (-16._dp) * 0.5_dp*(1._dp - 16._dp*RiBulk)**(-0.5_dp) + dStabilityCorrection_dRich = (-16._rkind) * 0.5_rkind*(1._rkind - 16._rkind*RiBulk)**(-0.5_rkind) dStabilityCorrection_dAirTemp = dRiBulk_dAirTemp * dStabilityCorrection_dRich dStabilityCorrection_dSfcTemp = dRiBulk_dSfcTemp * dStabilityCorrection_dRich end if @@ -3188,24 +3188,24 @@ subroutine aStability(& ! ("standard" stability correction, a la Anderson 1976) case(standard) ! compute surface-atmosphere exchange coefficient (-) - if(RiBulk < critRichNumber) stabilityCorrection = (1._dp - 5._dp*RiBulk)**2._dp + if(RiBulk < critRichNumber) stabilityCorrection = (1._rkind - 5._rkind*RiBulk)**2._rkind if(RiBulk >= critRichNumber) stabilityCorrection = verySmall ! compute derivative in surface-atmosphere exchange coefficient w.r.t. temperature (K-1) if(computeDerivative)then - if(RiBulk < critRichNumber) dStabilityCorrection_dRich = (-5._dp) * 2._dp*(1._dp - 5._dp*RiBulk) + if(RiBulk < critRichNumber) dStabilityCorrection_dRich = (-5._rkind) * 2._rkind*(1._rkind - 5._rkind*RiBulk) if(RiBulk >= critRichNumber) dStabilityCorrection_dRich = verySmall end if ! (Louis 1979) case(louisInversePower) ! scale the "b" parameter for stable conditions - bprime = Louis79_bparam/2._dp + bprime = Louis79_bparam/2._rkind ! compute surface-atmosphere exchange coefficient (-) - stabilityCorrection = 1._dp / ( (1._dp + bprime*RiBulk)**2._dp ) + stabilityCorrection = 1._rkind / ( (1._rkind + bprime*RiBulk)**2._rkind ) if(stabilityCorrection < epsilon(stabilityCorrection)) stabilityCorrection = epsilon(stabilityCorrection) ! compute derivative in surface-atmosphere exchange coefficient w.r.t. temperature (K-1) if(computeDerivative)then - dStabilityCorrection_dRich = bprime * (-2._dp)*(1._dp + bprime*RiBulk)**(-3._dp) + dStabilityCorrection_dRich = bprime * (-2._rkind)*(1._rkind + bprime*RiBulk)**(-3._rkind) end if ! (Mahrt 1987) @@ -3251,36 +3251,36 @@ subroutine bulkRichardson(& err,message) ! output: error control implicit none ! input - real(dp),intent(in) :: airtemp ! air temperature (K) - real(dp),intent(in) :: sfcTemp ! surface temperature (K) - real(dp),intent(in) :: windspd ! wind speed (m s-1) - real(dp),intent(in) :: mHeight ! measurement height (m) + real(rkind),intent(in) :: airtemp ! air temperature (K) + real(rkind),intent(in) :: sfcTemp ! surface temperature (K) + real(rkind),intent(in) :: windspd ! wind speed (m s-1) + real(rkind),intent(in) :: mHeight ! measurement height (m) logical(lgt),intent(in) :: computeDerivative ! flag to compute the derivative ! output - real(dp),intent(inout) :: RiBulk ! bulk Richardson number (-) - real(dp),intent(out) :: dRiBulk_dAirTemp ! derivative in the bulk Richardson number w.r.t. air temperature (K-1) - real(dp),intent(out) :: dRiBulk_dSfcTemp ! derivative in the bulk Richardson number w.r.t. surface temperature (K-1) + real(rkind),intent(inout) :: RiBulk ! bulk Richardson number (-) + real(rkind),intent(out) :: dRiBulk_dAirTemp ! derivative in the bulk Richardson number w.r.t. air temperature (K-1) + real(rkind),intent(out) :: dRiBulk_dSfcTemp ! derivative in the bulk Richardson number w.r.t. surface temperature (K-1) integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! local variables - real(dp) :: T_grad ! gradient in temperature between the atmosphere and surface (K) - real(dp) :: T_mean ! mean of the atmosphere and surface temperature (K) - real(dp) :: RiMult ! dimensionless scaling factor (-) + real(rkind) :: T_grad ! gradient in temperature between the atmosphere and surface (K) + real(rkind) :: T_mean ! mean of the atmosphere and surface temperature (K) + real(rkind) :: RiMult ! dimensionless scaling factor (-) ! initialize error control err=0; message='bulkRichardson/' ! compute local variables T_grad = airtemp - sfcTemp - T_mean = 0.5_dp*(airtemp + sfcTemp) + T_mean = 0.5_rkind*(airtemp + sfcTemp) RiMult = (gravity*mHeight)/(windspd*windspd) ! compute the Richardson number RiBulk = (T_grad/T_mean) * RiMult ! compute the derivative in the Richardson number if(computeDerivative)then - dRiBulk_dAirTemp = RiMult/T_mean - RiMult*T_grad/(0.5_dp*((airtemp + sfcTemp)**2._dp)) - dRiBulk_dSfcTemp = -RiMult/T_mean - RiMult*T_grad/(0.5_dp*((airtemp + sfcTemp)**2._dp)) + dRiBulk_dAirTemp = RiMult/T_mean - RiMult*T_grad/(0.5_rkind*((airtemp + sfcTemp)**2._rkind)) + dRiBulk_dSfcTemp = -RiMult/T_mean - RiMult*T_grad/(0.5_rkind*((airtemp + sfcTemp)**2._rkind)) else - dRiBulk_dAirTemp = 1._dp - dRiBulk_dSfcTemp = 1._dp + dRiBulk_dAirTemp = 1._rkind + dRiBulk_dSfcTemp = 1._rkind end if end subroutine bulkRichardson diff --git a/build/source/engine/vegPhenlgy.f90 b/build/source/engine/vegPhenlgy.f90 index cf92d886e..194463a78 100755 --- a/build/source/engine/vegPhenlgy.f90 +++ b/build/source/engine/vegPhenlgy.f90 @@ -58,8 +58,8 @@ module vegPhenlgy_module private public::vegPhenlgy ! algorithmic parameters -real(dp),parameter :: valueMissing=-9999._dp ! missing value, used when diagnostic or state variables are undefined -real(dp),parameter :: verySmall=1.e-6_dp ! used as an additive constant to check if substantial difference among real numbers +real(rkind),parameter :: valueMissing=-9999._rkind ! missing value, used when diagnostic or state variables are undefined +real(rkind),parameter :: verySmall=1.e-6_rkind ! used as an additive constant to check if substantial difference among real numbers contains @@ -93,14 +93,14 @@ subroutine vegPhenlgy(& type(var_dlength),intent(inout) :: diag_data ! diagnostic variables for a local HRU ! output logical(lgt),intent(out) :: computeVegFlux ! flag to indicate if we are computing fluxes over vegetation (.false. means veg is buried with snow) - real(dp),intent(out) :: canopyDepth ! canopy depth (m) - real(dp),intent(out) :: exposedVAI ! exposed vegetation area index (LAI + SAI) + real(rkind),intent(out) :: canopyDepth ! canopy depth (m) + real(rkind),intent(out) :: exposedVAI ! exposed vegetation area index (LAI + SAI) integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! ------------------------------------------------------------------------------------------------- ! local - real(dp) :: notUsed_heightCanopyTop ! height of the top of the canopy layer (m) - real(dp) :: heightAboveSnow ! height top of canopy is above the snow surface (m) + real(rkind) :: notUsed_heightCanopyTop ! height of the top of the canopy layer (m) + real(rkind) :: heightAboveSnow ! height top of canopy is above the snow surface (m) ! initialize error control err=0; message="vegPhenlgy/" ! ---------------------------------------------------------------------------------------------------------------------------------- @@ -181,7 +181,7 @@ subroutine vegPhenlgy(& heightAboveSnow = heightCanopyTop - scalarSnowDepth ! height top of canopy is above the snow surface (m) ! determine if need to include vegetation in the energy flux routines - computeVegFlux = (exposedVAI > 0.05_dp .and. heightAboveSnow > 0.05_dp) + computeVegFlux = (exposedVAI > 0.05_rkind .and. heightAboveSnow > 0.05_rkind) !write(*,'(a,1x,i2,1x,L1,1x,10(f12.5,1x))') 'vegTypeIndex, computeVegFlux, heightCanopyTop, heightAboveSnow, scalarSnowDepth = ', & ! vegTypeIndex, computeVegFlux, heightCanopyTop, heightAboveSnow, scalarSnowDepth diff --git a/build/source/engine/vegSWavRad.f90 b/build/source/engine/vegSWavRad.f90 index c9f72b9b4..45357f36b 100755 --- a/build/source/engine/vegSWavRad.f90 +++ b/build/source/engine/vegSWavRad.f90 @@ -58,10 +58,10 @@ module vegSWavRad_module integer(i4b),parameter :: iLoc = 1 ! i-location integer(i4b),parameter :: jLoc = 1 ! j-location ! algorithmic parameters -real(dp),parameter :: missingValue=-9999._dp ! missing value, used when diagnostic or state variables are undefined -real(dp),parameter :: verySmall=1.e-6_dp ! used as an additive constant to check if substantial difference among real numbers -real(dp),parameter :: mpe=1.e-6_dp ! prevents overflow error if division by zero -real(dp),parameter :: dx=1.e-6_dp ! finite difference increment +real(rkind),parameter :: missingValue=-9999._rkind ! missing value, used when diagnostic or state variables are undefined +real(rkind),parameter :: verySmall=1.e-6_rkind ! used as an additive constant to check if substantial difference among real numbers +real(rkind),parameter :: mpe=1.e-6_rkind ! prevents overflow error if division by zero +real(rkind),parameter :: dx=1.e-6_rkind ! finite difference increment contains @@ -83,7 +83,7 @@ subroutine vegSWavRad(& USE NOAHMP_ROUTINES,only:radiation ! subroutine to calculate albedo and shortwave radiaiton in the canopy implicit none ! dummy variables - real(dp),intent(in) :: dt ! time step (s) -- only used in Noah-MP radiation, to compute albedo + real(rkind),intent(in) :: dt ! time step (s) -- only used in Noah-MP radiation, to compute albedo integer(i4b),intent(in) :: nSnow ! number of snow layers integer(i4b),intent(in) :: nSoil ! number of soil layers integer(i4b),intent(in) :: nLayers ! total number of layers @@ -96,15 +96,15 @@ subroutine vegSWavRad(& character(*),intent(out) :: message ! error message ! local variables character(LEN=256) :: cmessage ! error message of downwind routine - real(dp) :: snowmassPlusNewsnow ! sum of snow mass and new snowfall (kg m-2 [mm]) - real(dp) :: scalarGroundSnowFraction ! snow cover fraction on the ground surface (-) - real(dp),parameter :: scalarVegFraction=1._dp ! vegetation fraction (=1 forces no canopy gaps and open areas in radiation routine) - real(dp) :: scalarTotalReflectedSolar ! total reflected solar radiation (W m-2) - real(dp) :: scalarTotalAbsorbedSolar ! total absorbed solar radiation (W m-2) - real(dp) :: scalarCanopyReflectedSolar ! solar radiation reflected from the canopy (W m-2) - real(dp) :: scalarGroundReflectedSolar ! solar radiation reflected from the ground (W m-2) - real(dp) :: scalarBetweenCanopyGapFraction ! between canopy gap fraction for beam (-) - real(dp) :: scalarWithinCanopyGapFraction ! within canopy gap fraction for beam (-) + real(rkind) :: snowmassPlusNewsnow ! sum of snow mass and new snowfall (kg m-2 [mm]) + real(rkind) :: scalarGroundSnowFraction ! snow cover fraction on the ground surface (-) + real(rkind),parameter :: scalarVegFraction=1._rkind ! vegetation fraction (=1 forces no canopy gaps and open areas in radiation routine) + real(rkind) :: scalarTotalReflectedSolar ! total reflected solar radiation (W m-2) + real(rkind) :: scalarTotalAbsorbedSolar ! total absorbed solar radiation (W m-2) + real(rkind) :: scalarCanopyReflectedSolar ! solar radiation reflected from the canopy (W m-2) + real(rkind) :: scalarGroundReflectedSolar ! solar radiation reflected from the ground (W m-2) + real(rkind) :: scalarBetweenCanopyGapFraction ! between canopy gap fraction for beam (-) + real(rkind) :: scalarWithinCanopyGapFraction ! within canopy gap fraction for beam (-) ! ---------------------------------------------------------------------------------------------------------------------------------- ! make association between local variables and the information in the data structures associate(& @@ -160,9 +160,9 @@ subroutine vegSWavRad(& ! compute the ground snow fraction if(nSnow > 0)then - scalarGroundSnowFraction = 1._dp + scalarGroundSnowFraction = 1._rkind else - scalarGroundSnowFraction = 0._dp + scalarGroundSnowFraction = 0._rkind end if ! (if there is snow on the ground) ! * compute radiation fluxes... @@ -182,7 +182,7 @@ subroutine vegSWavRad(& snowmassPlusNewsnow, & ! intent(in): sum of snow mass and new snowfall (kg m-2 [mm]) dt, & ! intent(in): time step (s) scalarCosZenith, & ! intent(in): cosine of the solar zenith angle (0-1) - scalarSnowDepth*1000._dp, & ! intent(in): snow depth on the ground surface (mm) + scalarSnowDepth*1000._rkind, & ! intent(in): snow depth on the ground surface (mm) scalarGroundTemp, & ! intent(in): ground temperature (K) scalarCanopyTemp, & ! intent(in): canopy temperature (K) scalarGroundSnowFraction, & ! intent(in): snow cover fraction (0-1) @@ -311,32 +311,32 @@ subroutine canopy_SW(& integer(i4b),intent(in) :: isc ! soil color index logical(lgt),intent(in) :: computeVegFlux ! logical flag to compute vegetation fluxes (.false. if veg buried by snow) integer(i4b),intent(in) :: ix_canopySrad ! choice of canopy shortwave radiation method - real(dp),intent(in) :: scalarCosZenith ! cosine of the solar zenith angle (0-1) - real(dp),intent(in) :: spectralIncomingDirect(:) ! incoming direct solar radiation in each wave band (w m-2) - real(dp),intent(in) :: spectralIncomingDiffuse(:) ! incoming diffuse solar radiation in each wave band (w m-2) - real(dp),intent(in) :: spectralSnowAlbedoDirect(:) ! direct albedo of snow in each spectral band (-) - real(dp),intent(in) :: spectralSnowAlbedoDiffuse(:) ! diffuse albedo of snow in each spectral band (-) - real(dp),intent(in) :: scalarExposedLAI ! exposed leaf area index after burial by snow (m2 m-2) - real(dp),intent(in) :: scalarExposedSAI ! exposed stem area index after burial by snow (m2 m-2) - real(dp),intent(in) :: scalarVegFraction ! vegetation fraction (=1 forces no canopy gaps and open areas in radiation routine) - real(dp),intent(in) :: scalarCanopyWetFraction ! fraction of canopy that is wet (-) - real(dp),intent(in) :: scalarGroundSnowFraction ! fraction of ground that is snow covered (-) - real(dp),intent(in) :: scalarVolFracLiqUpper ! volumetric liquid water content in the upper-most soil layer (-) - real(dp),intent(in) :: scalarCanopyTempTrial ! trial value of canopy temperature (K) + real(rkind),intent(in) :: scalarCosZenith ! cosine of the solar zenith angle (0-1) + real(rkind),intent(in) :: spectralIncomingDirect(:) ! incoming direct solar radiation in each wave band (w m-2) + real(rkind),intent(in) :: spectralIncomingDiffuse(:) ! incoming diffuse solar radiation in each wave band (w m-2) + real(rkind),intent(in) :: spectralSnowAlbedoDirect(:) ! direct albedo of snow in each spectral band (-) + real(rkind),intent(in) :: spectralSnowAlbedoDiffuse(:) ! diffuse albedo of snow in each spectral band (-) + real(rkind),intent(in) :: scalarExposedLAI ! exposed leaf area index after burial by snow (m2 m-2) + real(rkind),intent(in) :: scalarExposedSAI ! exposed stem area index after burial by snow (m2 m-2) + real(rkind),intent(in) :: scalarVegFraction ! vegetation fraction (=1 forces no canopy gaps and open areas in radiation routine) + real(rkind),intent(in) :: scalarCanopyWetFraction ! fraction of canopy that is wet (-) + real(rkind),intent(in) :: scalarGroundSnowFraction ! fraction of ground that is snow covered (-) + real(rkind),intent(in) :: scalarVolFracLiqUpper ! volumetric liquid water content in the upper-most soil layer (-) + real(rkind),intent(in) :: scalarCanopyTempTrial ! trial value of canopy temperature (K) ! output - real(dp),intent(out) :: spectralBelowCanopyDirect(:) ! downward direct flux below veg layer (W m-2) - real(dp),intent(out) :: spectralBelowCanopyDiffuse(:) ! downward diffuse flux below veg layer (W m-2) - real(dp),intent(out) :: scalarBelowCanopySolar ! radiation transmitted below the canopy (W m-2) - real(dp),intent(out) :: spectralAlbGndDirect(:) ! direct albedo of underlying surface (1:nBands) (-) - real(dp),intent(out) :: spectralAlbGndDiffuse(:) ! diffuse albedo of underlying surface (1:nBands) (-) - real(dp),intent(out) :: scalarGroundAlbedo ! albedo of the ground surface (-) - real(dp),intent(out) :: scalarCanopyAbsorbedSolar ! radiation absorbed by the vegetation canopy (W m-2) - real(dp),intent(out) :: scalarGroundAbsorbedSolar ! radiation absorbed by the ground (W m-2) - real(dp),intent(out) :: scalarCanopySunlitFraction ! sunlit fraction of canopy (-) - real(dp),intent(out) :: scalarCanopySunlitLAI ! sunlit leaf area (-) - real(dp),intent(out) :: scalarCanopyShadedLAI ! shaded leaf area (-) - real(dp),intent(out) :: scalarCanopySunlitPAR ! average absorbed par for sunlit leaves (w m-2) - real(dp),intent(out) :: scalarCanopyShadedPAR ! average absorbed par for shaded leaves (w m-2) + real(rkind),intent(out) :: spectralBelowCanopyDirect(:) ! downward direct flux below veg layer (W m-2) + real(rkind),intent(out) :: spectralBelowCanopyDiffuse(:) ! downward diffuse flux below veg layer (W m-2) + real(rkind),intent(out) :: scalarBelowCanopySolar ! radiation transmitted below the canopy (W m-2) + real(rkind),intent(out) :: spectralAlbGndDirect(:) ! direct albedo of underlying surface (1:nBands) (-) + real(rkind),intent(out) :: spectralAlbGndDiffuse(:) ! diffuse albedo of underlying surface (1:nBands) (-) + real(rkind),intent(out) :: scalarGroundAlbedo ! albedo of the ground surface (-) + real(rkind),intent(out) :: scalarCanopyAbsorbedSolar ! radiation absorbed by the vegetation canopy (W m-2) + real(rkind),intent(out) :: scalarGroundAbsorbedSolar ! radiation absorbed by the ground (W m-2) + real(rkind),intent(out) :: scalarCanopySunlitFraction ! sunlit fraction of canopy (-) + real(rkind),intent(out) :: scalarCanopySunlitLAI ! sunlit leaf area (-) + real(rkind),intent(out) :: scalarCanopyShadedLAI ! shaded leaf area (-) + real(rkind),intent(out) :: scalarCanopySunlitPAR ! average absorbed par for sunlit leaves (w m-2) + real(rkind),intent(out) :: scalarCanopyShadedPAR ! average absorbed par for shaded leaves (w m-2) integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! ----------------------------------------------------------------------------------------------------------------------------------------------------------------- @@ -349,72 +349,72 @@ subroutine canopy_SW(& integer(i4b) :: ic ! 0=unit incoming direct; 1=unit incoming diffuse character(LEN=256) :: cmessage ! error message of downwind routine ! variables used in Nijssen-Lettenmaier method - real(dp),parameter :: multScatExp=0.81_dp ! multiple scattering exponent (-) - real(dp),parameter :: bulkCanopyAlbedo=0.25_dp ! bulk canopy albedo (-), smaller than actual canopy albedo because of shading in the canopy - real(dp),dimension(1:nBands) :: spectralIncomingSolar ! total incoming solar radiation in each spectral band (W m-2) - real(dp),dimension(1:nBands) :: spectralGroundAbsorbedDirect ! total direct radiation absorbed at the ground surface (W m-2) - real(dp),dimension(1:nBands) :: spectralGroundAbsorbedDiffuse ! total diffuse radiation absorbed at the ground surface (W m-2) - real(dp) :: Fdirect ! fraction of direct radiation (-) - real(dp) :: tauInitial ! transmission in the absence of scattering and multiple reflections (-) - real(dp) :: tauTotal ! transmission due to scattering and multiple reflections (-) + real(rkind),parameter :: multScatExp=0.81_rkind ! multiple scattering exponent (-) + real(rkind),parameter :: bulkCanopyAlbedo=0.25_rkind ! bulk canopy albedo (-), smaller than actual canopy albedo because of shading in the canopy + real(rkind),dimension(1:nBands) :: spectralIncomingSolar ! total incoming solar radiation in each spectral band (W m-2) + real(rkind),dimension(1:nBands) :: spectralGroundAbsorbedDirect ! total direct radiation absorbed at the ground surface (W m-2) + real(rkind),dimension(1:nBands) :: spectralGroundAbsorbedDiffuse ! total diffuse radiation absorbed at the ground surface (W m-2) + real(rkind) :: Fdirect ! fraction of direct radiation (-) + real(rkind) :: tauInitial ! transmission in the absence of scattering and multiple reflections (-) + real(rkind) :: tauTotal ! transmission due to scattering and multiple reflections (-) ! variables used in Mahat-Tarboton method - real(dp),parameter :: Frad_vis=0.5_dp ! fraction of radiation in the visible wave band (-) - real(dp),parameter :: gProjParam=0.5_dp ! projected leaf and stem area in the solar direction (-) - real(dp),parameter :: bScatParam=0.5_dp ! back scatter parameter (-) - real(dp) :: transCoef ! transmission coefficient (-) - real(dp) :: transCoefPrime ! "k-prime" coefficient (-) - real(dp) :: groundAlbedoDirect ! direct ground albedo (-) - real(dp) :: groundAlbedoDiffuse ! diffuse ground albedo (-) - real(dp) :: tauInfinite ! direct transmission for an infinite canopy (-) - real(dp) :: betaInfinite ! direct upward reflection factor for an infinite canopy (-) - real(dp) :: tauFinite ! direct transmission for a finite canopy (-) - real(dp) :: betaFinite ! direct reflectance for a finite canopy (-) - real(dp) :: vFactor ! scaled vegetation area used to compute diffuse radiation (-) - real(dp) :: expi ! exponential integral (-) - real(dp) :: taudInfinite ! diffuse transmission for an infinite canopy (-) - real(dp) :: taudFinite ! diffuse transmission for a finite canopy (-) - real(dp) :: betadFinite ! diffuse reflectance for a finite canopy (-) - real(dp) :: refMult ! multiple reflection factor (-) - real(dp) :: fracRadAbsDown ! fraction of radiation absorbed by vegetation on the way down - real(dp) :: fracRadAbsUp ! fraction of radiation absorbed by vegetation on the way up - real(dp) :: tauDirect ! total transmission of direct radiation (-) - real(dp) :: tauDiffuse ! total transmission of diffuse radiation (-) - real(dp) :: fractionRefDirect ! fraction of direct radiaiton lost to space (-) - real(dp) :: fractionRefDiffuse ! fraction of diffuse radiaiton lost to space (-) - real(dp),dimension(1:nBands) :: spectralBelowCanopySolar ! total below-canopy radiation for each wave band (W m-2) - real(dp),dimension(1:nBands) :: spectralTotalReflectedSolar ! total reflected radiaion for each wave band (W m-2) - real(dp),dimension(1:nBands) :: spectralGroundAbsorbedSolar ! radiation absorbed by the ground in each wave band (W m-2) - real(dp),dimension(1:nBands) :: spectralCanopyAbsorbedSolar ! radiation absorbed by the canopy in each wave band (W m-2) + real(rkind),parameter :: Frad_vis=0.5_rkind ! fraction of radiation in the visible wave band (-) + real(rkind),parameter :: gProjParam=0.5_rkind ! projected leaf and stem area in the solar direction (-) + real(rkind),parameter :: bScatParam=0.5_rkind ! back scatter parameter (-) + real(rkind) :: transCoef ! transmission coefficient (-) + real(rkind) :: transCoefPrime ! "k-prime" coefficient (-) + real(rkind) :: groundAlbedoDirect ! direct ground albedo (-) + real(rkind) :: groundAlbedoDiffuse ! diffuse ground albedo (-) + real(rkind) :: tauInfinite ! direct transmission for an infinite canopy (-) + real(rkind) :: betaInfinite ! direct upward reflection factor for an infinite canopy (-) + real(rkind) :: tauFinite ! direct transmission for a finite canopy (-) + real(rkind) :: betaFinite ! direct reflectance for a finite canopy (-) + real(rkind) :: vFactor ! scaled vegetation area used to compute diffuse radiation (-) + real(rkind) :: expi ! exponential integral (-) + real(rkind) :: taudInfinite ! diffuse transmission for an infinite canopy (-) + real(rkind) :: taudFinite ! diffuse transmission for a finite canopy (-) + real(rkind) :: betadFinite ! diffuse reflectance for a finite canopy (-) + real(rkind) :: refMult ! multiple reflection factor (-) + real(rkind) :: fracRadAbsDown ! fraction of radiation absorbed by vegetation on the way down + real(rkind) :: fracRadAbsUp ! fraction of radiation absorbed by vegetation on the way up + real(rkind) :: tauDirect ! total transmission of direct radiation (-) + real(rkind) :: tauDiffuse ! total transmission of diffuse radiation (-) + real(rkind) :: fractionRefDirect ! fraction of direct radiaiton lost to space (-) + real(rkind) :: fractionRefDiffuse ! fraction of diffuse radiaiton lost to space (-) + real(rkind),dimension(1:nBands) :: spectralBelowCanopySolar ! total below-canopy radiation for each wave band (W m-2) + real(rkind),dimension(1:nBands) :: spectralTotalReflectedSolar ! total reflected radiaion for each wave band (W m-2) + real(rkind),dimension(1:nBands) :: spectralGroundAbsorbedSolar ! radiation absorbed by the ground in each wave band (W m-2) + real(rkind),dimension(1:nBands) :: spectralCanopyAbsorbedSolar ! radiation absorbed by the canopy in each wave band (W m-2) ! vegetation properties used in 2-stream - real(dp) :: scalarExposedVAI ! one-sided leaf+stem area index (m2/m2) - real(dp) :: weightLeaf ! fraction of exposed VAI that is leaf - real(dp) :: weightStem ! fraction of exposed VAI that is stem - real(dp),dimension(1:nBands) :: spectralVegReflc ! leaf+stem reflectance (1:nbands) - real(dp),dimension(1:nBands) :: spectralVegTrans ! leaf+stem transmittance (1:nBands) + real(rkind) :: scalarExposedVAI ! one-sided leaf+stem area index (m2/m2) + real(rkind) :: weightLeaf ! fraction of exposed VAI that is leaf + real(rkind) :: weightStem ! fraction of exposed VAI that is stem + real(rkind),dimension(1:nBands) :: spectralVegReflc ! leaf+stem reflectance (1:nbands) + real(rkind),dimension(1:nBands) :: spectralVegTrans ! leaf+stem transmittance (1:nBands) ! output from two-stream -- direct-beam - real(dp),dimension(1:nBands) :: spectralCanopyAbsorbedDirect ! flux abs by veg layer (per unit incoming flux), (1:nBands) - real(dp),dimension(1:nBands) :: spectralTotalReflectedDirect ! flux refl above veg layer (per unit incoming flux), (1:nBands) - real(dp),dimension(1:nBands) :: spectralDirectBelowCanopyDirect ! down dir flux below veg layer (per unit in flux), (1:nBands) - real(dp),dimension(1:nBands) :: spectralDiffuseBelowCanopyDirect ! down dif flux below veg layer (per unit in flux), (1:nBands) - real(dp),dimension(1:nBands) :: spectralCanopyReflectedDirect ! flux reflected by veg layer (per unit incoming flux), (1:nBands) - real(dp),dimension(1:nBands) :: spectralGroundReflectedDirect ! flux reflected by ground (per unit incoming flux), (1:nBands) + real(rkind),dimension(1:nBands) :: spectralCanopyAbsorbedDirect ! flux abs by veg layer (per unit incoming flux), (1:nBands) + real(rkind),dimension(1:nBands) :: spectralTotalReflectedDirect ! flux refl above veg layer (per unit incoming flux), (1:nBands) + real(rkind),dimension(1:nBands) :: spectralDirectBelowCanopyDirect ! down dir flux below veg layer (per unit in flux), (1:nBands) + real(rkind),dimension(1:nBands) :: spectralDiffuseBelowCanopyDirect ! down dif flux below veg layer (per unit in flux), (1:nBands) + real(rkind),dimension(1:nBands) :: spectralCanopyReflectedDirect ! flux reflected by veg layer (per unit incoming flux), (1:nBands) + real(rkind),dimension(1:nBands) :: spectralGroundReflectedDirect ! flux reflected by ground (per unit incoming flux), (1:nBands) ! output from two-stream -- diffuse - real(dp),dimension(1:nBands) :: spectralCanopyAbsorbedDiffuse ! flux abs by veg layer (per unit incoming flux), (1:nBands) - real(dp),dimension(1:nBands) :: spectralTotalReflectedDiffuse ! flux refl above veg layer (per unit incoming flux), (1:nBands) - real(dp),dimension(1:nBands) :: spectralDirectBelowCanopyDiffuse ! down dir flux below veg layer (per unit in flux), (1:nBands) - real(dp),dimension(1:nBands) :: spectralDiffuseBelowCanopyDiffuse ! down dif flux below veg layer (per unit in flux), (1:nBands) - real(dp),dimension(1:nBands) :: spectralCanopyReflectedDiffuse ! flux reflected by veg layer (per unit incoming flux), (1:nBands) - real(dp),dimension(1:nBands) :: spectralGroundReflectedDiffuse ! flux reflected by ground (per unit incoming flux), (1:nBands) + real(rkind),dimension(1:nBands) :: spectralCanopyAbsorbedDiffuse ! flux abs by veg layer (per unit incoming flux), (1:nBands) + real(rkind),dimension(1:nBands) :: spectralTotalReflectedDiffuse ! flux refl above veg layer (per unit incoming flux), (1:nBands) + real(rkind),dimension(1:nBands) :: spectralDirectBelowCanopyDiffuse ! down dir flux below veg layer (per unit in flux), (1:nBands) + real(rkind),dimension(1:nBands) :: spectralDiffuseBelowCanopyDiffuse ! down dif flux below veg layer (per unit in flux), (1:nBands) + real(rkind),dimension(1:nBands) :: spectralCanopyReflectedDiffuse ! flux reflected by veg layer (per unit incoming flux), (1:nBands) + real(rkind),dimension(1:nBands) :: spectralGroundReflectedDiffuse ! flux reflected by ground (per unit incoming flux), (1:nBands) ! output from two-stream -- scalar variables - real(dp) :: scalarGproj ! projected leaf+stem area in solar direction - real(dp) :: scalarBetweenCanopyGapFraction ! between canopy gap fraction for beam (-) - real(dp) :: scalarWithinCanopyGapFraction ! within canopy gap fraction for beam (-) + real(rkind) :: scalarGproj ! projected leaf+stem area in solar direction + real(rkind) :: scalarBetweenCanopyGapFraction ! between canopy gap fraction for beam (-) + real(rkind) :: scalarWithinCanopyGapFraction ! within canopy gap fraction for beam (-) ! radiation fluxes - real(dp) :: ext ! optical depth of direct beam per unit leaf + stem area - real(dp) :: scalarCanopyShadedFraction ! shaded fraction of the canopy - real(dp) :: fractionLAI ! fraction of vegetation that is leaves - real(dp) :: visibleAbsDirect ! direct-beam radiation absorbed in the visible part of the spectrum (W m-2) - real(dp) :: visibleAbsDiffuse ! diffuse radiation absorbed in the visible part of the spectrum (W m-2) + real(rkind) :: ext ! optical depth of direct beam per unit leaf + stem area + real(rkind) :: scalarCanopyShadedFraction ! shaded fraction of the canopy + real(rkind) :: fractionLAI ! fraction of vegetation that is leaves + real(rkind) :: visibleAbsDirect ! direct-beam radiation absorbed in the visible part of the spectrum (W m-2) + real(rkind) :: visibleAbsDiffuse ! diffuse radiation absorbed in the visible part of the spectrum (W m-2) ! ----------------------------------------------------------------------------------------------------------------------------------------------------------------- ! initialize error control err=0; message='canopy_SW/' @@ -434,18 +434,18 @@ subroutine canopy_SW(& if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! initialize accumulated fluxes - scalarBelowCanopySolar = 0._dp ! radiation transmitted below the canopy (W m-2) - scalarCanopyAbsorbedSolar = 0._dp ! radiation absorbed by the vegetation canopy (W m-2) - scalarGroundAbsorbedSolar = 0._dp ! radiation absorbed by the ground (W m-2) + scalarBelowCanopySolar = 0._rkind ! radiation transmitted below the canopy (W m-2) + scalarCanopyAbsorbedSolar = 0._rkind ! radiation absorbed by the vegetation canopy (W m-2) + scalarGroundAbsorbedSolar = 0._rkind ! radiation absorbed by the ground (W m-2) ! check for an early return (no radiation or no exposed canopy) if(.not.computeVegFlux .or. scalarCosZenith < tiny(scalarCosZenith))then ! set canopy radiation to zero - scalarCanopySunlitFraction = 0._dp ! sunlit fraction of canopy (-) - scalarCanopySunlitLAI = 0._dp ! sunlit leaf area (-) + scalarCanopySunlitFraction = 0._rkind ! sunlit fraction of canopy (-) + scalarCanopySunlitLAI = 0._rkind ! sunlit leaf area (-) scalarCanopyShadedLAI = scalarExposedLAI ! shaded leaf area (-) - scalarCanopySunlitPAR = 0._dp ! average absorbed par for sunlit leaves (w m-2) - scalarCanopyShadedPAR = 0._dp ! average absorbed par for shaded leaves (w m-2) + scalarCanopySunlitPAR = 0._rkind ! average absorbed par for sunlit leaves (w m-2) + scalarCanopyShadedPAR = 0._rkind ! average absorbed par for shaded leaves (w m-2) ! compute below-canopy radiation do iBand=1,nBands ! (set below-canopy radiation to incoming radiation) @@ -453,16 +453,16 @@ subroutine canopy_SW(& spectralBelowCanopyDirect(iBand) = spectralIncomingDirect(iBand) spectralBelowCanopyDiffuse(iBand) = spectralIncomingDiffuse(iBand) else - spectralBelowCanopyDirect(iBand) = 0._dp - spectralBelowCanopyDiffuse(iBand) = 0._dp + spectralBelowCanopyDirect(iBand) = 0._rkind + spectralBelowCanopyDiffuse(iBand) = 0._rkind end if ! (accumulate radiation transmitted below the canopy) scalarBelowCanopySolar = scalarBelowCanopySolar + & ! contribution from all previous wave bands spectralBelowCanopyDirect(iBand) + spectralBelowCanopyDiffuse(iBand) ! contribution from current wave band ! (accumulate radiation absorbed by the ground) scalarGroundAbsorbedSolar = scalarGroundAbsorbedSolar + & ! contribution from all previous wave bands - spectralBelowCanopyDirect(iBand)*(1._dp - spectralAlbGndDirect(iBand)) + & ! direct radiation from current wave band - spectralBelowCanopyDiffuse(iBand)*(1._dp - spectralAlbGndDiffuse(iBand)) ! diffuse radiation from current wave band + spectralBelowCanopyDirect(iBand)*(1._rkind - spectralAlbGndDirect(iBand)) + & ! direct radiation from current wave band + spectralBelowCanopyDiffuse(iBand)*(1._rkind - spectralAlbGndDiffuse(iBand)) ! diffuse radiation from current wave band end do ! looping through wave bands return end if @@ -490,8 +490,8 @@ subroutine canopy_SW(& !print*, 'tauTotal = ', tauTotal ! compute ground albedo (-) - groundAlbedoDirect = Frad_vis*spectralAlbGndDirect(ixVisible) + (1._dp - Frad_vis)*spectralAlbGndDirect(ixNearIR) - groundAlbedoDiffuse = Frad_vis*spectralAlbGndDiffuse(ixVisible) + (1._dp - Frad_vis)*spectralAlbGndDiffuse(ixNearIR) + groundAlbedoDirect = Frad_vis*spectralAlbGndDirect(ixVisible) + (1._rkind - Frad_vis)*spectralAlbGndDirect(ixNearIR) + groundAlbedoDiffuse = Frad_vis*spectralAlbGndDiffuse(ixVisible) + (1._rkind - Frad_vis)*spectralAlbGndDiffuse(ixNearIR) ! compute radiation in each spectral band (W m-2) do iBand=1,nBands @@ -501,7 +501,7 @@ subroutine canopy_SW(& ! compute fraction of direct radiation Fdirect = spectralIncomingDirect(iBand) / (spectralIncomingSolar(iBand) + verySmall) - if(Fdirect < 0._dp .or. Fdirect > 1._dp)then + if(Fdirect < 0._rkind .or. Fdirect > 1._rkind)then print*, 'spectralIncomingDirect(iBand) = ', spectralIncomingDirect(iBand) print*, 'spectralIncomingSolar(iBand) = ', spectralIncomingSolar(iBand) print*, 'Fdirect = ', Fdirect @@ -510,8 +510,8 @@ subroutine canopy_SW(& end if ! compute ground albedo (-) - scalarGroundAlbedo = Fdirect*groundAlbedoDirect + (1._dp - Fdirect)*groundAlbedoDiffuse - if(scalarGroundAlbedo < 0._dp .or. scalarGroundAlbedo > 1._dp)then + scalarGroundAlbedo = Fdirect*groundAlbedoDirect + (1._rkind - Fdirect)*groundAlbedoDiffuse + if(scalarGroundAlbedo < 0._rkind .or. scalarGroundAlbedo > 1._rkind)then print*, 'groundAlbedoDirect = ', groundAlbedoDirect print*, 'groundAlbedoDiffuse = ', groundAlbedoDiffuse message=trim(message)//'BeersLaw: albedo is less than zero or greater than one' @@ -524,13 +524,13 @@ subroutine canopy_SW(& spectralBelowCanopySolar(iBand) = spectralBelowCanopyDirect(iBand) + spectralBelowCanopyDiffuse(iBand) ! compute radiation absorbed by the ground in given wave band (W m-2) - spectralGroundAbsorbedDirect(iBand) = (1._dp - scalarGroundAlbedo)*spectralBelowCanopyDirect(iBand) - spectralGroundAbsorbedDiffuse(iBand) = (1._dp - scalarGroundAlbedo)*spectralBelowCanopyDiffuse(iBand) + spectralGroundAbsorbedDirect(iBand) = (1._rkind - scalarGroundAlbedo)*spectralBelowCanopyDirect(iBand) + spectralGroundAbsorbedDiffuse(iBand) = (1._rkind - scalarGroundAlbedo)*spectralBelowCanopyDiffuse(iBand) spectralGroundAbsorbedSolar(iBand) = spectralGroundAbsorbedDirect(iBand) + spectralGroundAbsorbedDiffuse(iBand) ! compute radiation absorbed by vegetation in current wave band (W m-2) - fracRadAbsDown = (1._dp - tauTotal)*(1._dp - bulkCanopyAlbedo) ! (fraction of radiation absorbed on the way down) - fracRadAbsUp = tauTotal*scalarGroundAlbedo*(1._dp - tauTotal) ! (fraction of radiation absorbed on the way up) + fracRadAbsDown = (1._rkind - tauTotal)*(1._rkind - bulkCanopyAlbedo) ! (fraction of radiation absorbed on the way down) + fracRadAbsUp = tauTotal*scalarGroundAlbedo*(1._rkind - tauTotal) ! (fraction of radiation absorbed on the way up) spectralCanopyAbsorbedDirect(iBand) = spectralIncomingDirect(iBand)*(fracRadAbsDown + fracRadAbsUp) spectralCanopyAbsorbedDiffuse(iBand) = spectralIncomingDiffuse(iBand)*(fracRadAbsDown + fracRadAbsUp) spectralCanopyAbsorbedSolar(iBand) = spectralCanopyAbsorbedDirect(iBand) + spectralCanopyAbsorbedDiffuse(iBand) @@ -547,7 +547,7 @@ subroutine canopy_SW(& spectralTotalReflectedDirect(iBand) = spectralIncomingDirect(iBand) - spectralGroundAbsorbedDirect(iBand) - spectralCanopyAbsorbedDirect(iBand) spectralTotalReflectedDiffuse(iBand) = spectralIncomingDiffuse(iBand) - spectralGroundAbsorbedDiffuse(iBand) - spectralCanopyAbsorbedDiffuse(iBand) spectralTotalReflectedSolar(iBand) = spectralTotalReflectedDirect(iBand) + spectralTotalReflectedDiffuse(iBand) - if(spectralTotalReflectedDirect(iBand) < 0._dp .or. spectralTotalReflectedDiffuse(iBand) < 0._dp)then + if(spectralTotalReflectedDirect(iBand) < 0._rkind .or. spectralTotalReflectedDiffuse(iBand) < 0._rkind)then print*, 'scalarGroundAlbedo = ', scalarGroundAlbedo print*, 'tauTotal = ', tauTotal print*, 'fracRadAbsDown = ', fracRadAbsDown @@ -587,11 +587,11 @@ subroutine canopy_SW(& ! compute transmission of diffuse radiation (-) vFactor = scalarGproj*scalarExposedVAI expi = expInt(vFactor) - taudFinite = (1._dp - vFactor)*exp(-vFactor) + (vFactor**2._dp)*expi + taudFinite = (1._rkind - vFactor)*exp(-vFactor) + (vFactor**2._rkind)*expi ! compute ground albedo (-) - groundAlbedoDirect = Frad_vis*spectralAlbGndDirect(ixVisible) + (1._dp - Frad_vis)*spectralAlbGndDirect(ixNearIR) - groundAlbedoDiffuse = Frad_vis*spectralAlbGndDiffuse(ixVisible) + (1._dp - Frad_vis)*spectralAlbGndDiffuse(ixNearIR) + groundAlbedoDirect = Frad_vis*spectralAlbGndDirect(ixVisible) + (1._rkind - Frad_vis)*spectralAlbGndDirect(ixNearIR) + groundAlbedoDiffuse = Frad_vis*spectralAlbGndDiffuse(ixVisible) + (1._rkind - Frad_vis)*spectralAlbGndDiffuse(ixNearIR) ! compute radiation in each spectral band (W m-2) do iBand=1,nBands @@ -601,7 +601,7 @@ subroutine canopy_SW(& ! compute fraction of direct radiation Fdirect = spectralIncomingDirect(iBand) / (spectralIncomingSolar(iBand) + verySmall) - if(Fdirect < 0._dp .or. Fdirect > 1._dp)then + if(Fdirect < 0._rkind .or. Fdirect > 1._rkind)then print*, 'spectralIncomingDirect(iBand) = ', spectralIncomingDirect(iBand) print*, 'spectralIncomingSolar(iBand) = ', spectralIncomingSolar(iBand) print*, 'Fdirect = ', Fdirect @@ -610,8 +610,8 @@ subroutine canopy_SW(& end if ! compute ground albedo (-) - scalarGroundAlbedo = Fdirect*groundAlbedoDirect + (1._dp - Fdirect)*groundAlbedoDiffuse - if(scalarGroundAlbedo < 0._dp .or. scalarGroundAlbedo > 1._dp)then + scalarGroundAlbedo = Fdirect*groundAlbedoDirect + (1._rkind - Fdirect)*groundAlbedoDiffuse + if(scalarGroundAlbedo < 0._rkind .or. scalarGroundAlbedo > 1._rkind)then print*, 'groundAlbedoDirect = ', groundAlbedoDirect print*, 'groundAlbedoDiffuse = ', groundAlbedoDiffuse message=trim(message)//'NL_scatter: albedo is less than zero or greater than one' @@ -619,13 +619,13 @@ subroutine canopy_SW(& end if ! compute initial transmission in the absence of scattering and multiple reflections (-) - tauInitial = Fdirect*tauFinite + (1._dp - Fdirect)*taudFinite + tauInitial = Fdirect*tauFinite + (1._rkind - Fdirect)*taudFinite ! compute increase in transmission due to scattering (-) tauTotal = (tauInitial**multScatExp) ! compute multiple reflections factor - refMult = 1._dp / (1._dp - scalarGroundAlbedo*bulkCanopyAlbedo*(1._dp - taudFinite**multScatExp) ) + refMult = 1._rkind / (1._rkind - scalarGroundAlbedo*bulkCanopyAlbedo*(1._rkind - taudFinite**multScatExp) ) ! compute below-canopy radiation (W m-2) spectralBelowCanopyDirect(iBand) = spectralIncomingDirect(iBand)*tauTotal*refMult ! direct radiation from current wave band @@ -633,13 +633,13 @@ subroutine canopy_SW(& spectralBelowCanopySolar(iBand) = spectralBelowCanopyDirect(iBand) + spectralBelowCanopyDiffuse(iBand) ! compute radiation absorbed by the ground in given wave band (W m-2) - spectralGroundAbsorbedDirect(iBand) = (1._dp - scalarGroundAlbedo)*spectralBelowCanopyDirect(iBand) - spectralGroundAbsorbedDiffuse(iBand) = (1._dp - scalarGroundAlbedo)*spectralBelowCanopyDiffuse(iBand) + spectralGroundAbsorbedDirect(iBand) = (1._rkind - scalarGroundAlbedo)*spectralBelowCanopyDirect(iBand) + spectralGroundAbsorbedDiffuse(iBand) = (1._rkind - scalarGroundAlbedo)*spectralBelowCanopyDiffuse(iBand) spectralGroundAbsorbedSolar(iBand) = spectralGroundAbsorbedDirect(iBand) + spectralGroundAbsorbedDiffuse(iBand) ! compute radiation absorbed by vegetation in current wave band (W m-2) - fracRadAbsDown = (1._dp - tauTotal)*(1._dp - bulkCanopyAlbedo) ! (fraction of radiation absorbed on the way down) - fracRadAbsUp = tauTotal*refMult*scalarGroundAlbedo*(1._dp - taudFinite**multScatExp) ! (fraction of radiation absorbed on the way up) + fracRadAbsDown = (1._rkind - tauTotal)*(1._rkind - bulkCanopyAlbedo) ! (fraction of radiation absorbed on the way down) + fracRadAbsUp = tauTotal*refMult*scalarGroundAlbedo*(1._rkind - taudFinite**multScatExp) ! (fraction of radiation absorbed on the way up) spectralCanopyAbsorbedDirect(iBand) = spectralIncomingDirect(iBand)*(fracRadAbsDown + fracRadAbsUp) spectralCanopyAbsorbedDiffuse(iBand) = spectralIncomingDiffuse(iBand)*(fracRadAbsDown + fracRadAbsUp) spectralCanopyAbsorbedSolar(iBand) = spectralCanopyAbsorbedDirect(iBand) + spectralCanopyAbsorbedDiffuse(iBand) @@ -648,7 +648,7 @@ subroutine canopy_SW(& spectralTotalReflectedDirect(iBand) = spectralIncomingDirect(iBand) - spectralGroundAbsorbedDirect(iBand) - spectralCanopyAbsorbedDirect(iBand) spectralTotalReflectedDiffuse(iBand) = spectralIncomingDiffuse(iBand) - spectralGroundAbsorbedDiffuse(iBand) - spectralCanopyAbsorbedDiffuse(iBand) spectralTotalReflectedSolar(iBand) = spectralTotalReflectedDirect(iBand) + spectralTotalReflectedDiffuse(iBand) - if(spectralTotalReflectedDirect(iBand) < 0._dp .or. spectralTotalReflectedDiffuse(iBand) < 0._dp)then + if(spectralTotalReflectedDirect(iBand) < 0._rkind .or. spectralTotalReflectedDiffuse(iBand) < 0._rkind)then message=trim(message)//'NL-scatter: reflected radiation is less than zero' err=20; return end if @@ -677,43 +677,43 @@ subroutine canopy_SW(& transCoef = scalarGproj/scalarCosZenith ! define "k-prime" coefficient (-) - transCoefPrime = sqrt(1._dp - bScatParam) + transCoefPrime = sqrt(1._rkind - bScatParam) ! compute ground albedo (-) - groundAlbedoDirect = Frad_vis*spectralAlbGndDirect(ixVisible) + (1._dp - Frad_vis)*spectralAlbGndDirect(ixNearIR) - groundAlbedoDiffuse = Frad_vis*spectralAlbGndDiffuse(ixVisible) + (1._dp - Frad_vis)*spectralAlbGndDiffuse(ixNearIR) + groundAlbedoDirect = Frad_vis*spectralAlbGndDirect(ixVisible) + (1._rkind - Frad_vis)*spectralAlbGndDirect(ixNearIR) + groundAlbedoDiffuse = Frad_vis*spectralAlbGndDiffuse(ixVisible) + (1._rkind - Frad_vis)*spectralAlbGndDiffuse(ixNearIR) ! compute transmission for an infinite canopy (-) tauInfinite = exp(-transCoef*transCoefPrime*scalarExposedVAI) ! compute upward reflection factor for an infinite canopy (-) - betaInfinite = (1._dp - transCoefPrime)/(1._dp + transCoefPrime) + betaInfinite = (1._rkind - transCoefPrime)/(1._rkind + transCoefPrime) ! compute transmission for a finite canopy (-) - tauFinite = tauInfinite*(1._dp - betaInfinite**2._dp)/(1._dp - (betaInfinite**2._dp)*tauInfinite**2._dp) + tauFinite = tauInfinite*(1._rkind - betaInfinite**2._rkind)/(1._rkind - (betaInfinite**2._rkind)*tauInfinite**2._rkind) ! compute reflectance for a finite canopy (-) - betaFinite = betaInfinite*(1._dp - tauInfinite**2._dp) / (1._dp - (betaInfinite**2._dp)*(tauInfinite**2._dp)) + betaFinite = betaInfinite*(1._rkind - tauInfinite**2._rkind) / (1._rkind - (betaInfinite**2._rkind)*(tauInfinite**2._rkind)) ! compute transmission of diffuse radiation (-) vFactor = transCoefPrime*scalarGproj*scalarExposedVAI expi = expInt(vFactor) - taudInfinite = (1._dp - vFactor)*exp(-vFactor) + (vFactor**2._dp)*expi - taudFinite = taudInfinite*(1._dp - betaInfinite**2._dp)/(1._dp - (betaInfinite**2._dp)*taudInfinite**2._dp) + taudInfinite = (1._rkind - vFactor)*exp(-vFactor) + (vFactor**2._rkind)*expi + taudFinite = taudInfinite*(1._rkind - betaInfinite**2._rkind)/(1._rkind - (betaInfinite**2._rkind)*taudInfinite**2._rkind) ! compute reflectance of diffuse radiation (-) - betadFinite = betaInfinite*(1._dp - taudInfinite**2._dp) / (1._dp - (betaInfinite**2._dp)*(taudInfinite**2._dp)) + betadFinite = betaInfinite*(1._rkind - taudInfinite**2._rkind) / (1._rkind - (betaInfinite**2._rkind)*(taudInfinite**2._rkind)) ! compute total transmission of direct and diffuse radiation, accounting for multiple reflections (-) - refMult = 1._dp / (1._dp - groundAlbedoDiffuse*betadFinite*(1._dp - taudFinite) ) + refMult = 1._rkind / (1._rkind - groundAlbedoDiffuse*betadFinite*(1._rkind - taudFinite) ) tauDirect = tauFinite*refMult tauDiffuse = taudFinite*refMult ! compute fraction of radiation lost to space (-) - fractionRefDirect = ( (1._dp - groundAlbedoDirect)*betaFinite + groundAlbedoDirect*tauFinite*taudFinite) * refMult - fractionRefDiffuse = ( (1._dp - groundAlbedoDiffuse)*betadFinite + groundAlbedoDiffuse*taudFinite*taudFinite) * refMult + fractionRefDirect = ( (1._rkind - groundAlbedoDirect)*betaFinite + groundAlbedoDirect*tauFinite*taudFinite) * refMult + fractionRefDiffuse = ( (1._rkind - groundAlbedoDiffuse)*betadFinite + groundAlbedoDiffuse*taudFinite*taudFinite) * refMult ! compute radiation in each spectral band (W m-2) do iBand=1,nBands @@ -724,22 +724,22 @@ subroutine canopy_SW(& spectralBelowCanopySolar(iBand) = spectralBelowCanopyDirect(iBand) + spectralBelowCanopyDiffuse(iBand) ! compute radiation absorbed by the ground in given wave band (W m-2) - spectralGroundAbsorbedDirect(iBand) = (1._dp - groundAlbedoDirect)*spectralBelowCanopyDirect(iBand) - spectralGroundAbsorbedDiffuse(iBand) = (1._dp - groundAlbedoDiffuse)*spectralBelowCanopyDiffuse(iBand) + spectralGroundAbsorbedDirect(iBand) = (1._rkind - groundAlbedoDirect)*spectralBelowCanopyDirect(iBand) + spectralGroundAbsorbedDiffuse(iBand) = (1._rkind - groundAlbedoDiffuse)*spectralBelowCanopyDiffuse(iBand) spectralGroundAbsorbedSolar(iBand) = spectralGroundAbsorbedDirect(iBand) + spectralGroundAbsorbedDiffuse(iBand) ! compute radiation absorbed by vegetation in current wave band (W m-2) - spectralCanopyAbsorbedDirect(iBand) = spectralIncomingDirect(iBand)*(1._dp - tauFinite)*(1._dp - betaFinite) + & ! (radiation absorbed on the way down) - spectralBelowCanopyDirect(iBand)*groundAlbedoDirect*(1._dp - taudFinite) ! (radiation absorbed on the way up) - spectralCanopyAbsorbedDiffuse(iBand) = spectralIncomingDiffuse(iBand)*(1._dp - taudFinite)*(1._dp - betadFinite) + & ! (radiation absorbed on the way down) - spectralBelowCanopyDiffuse(iBand)*groundAlbedoDiffuse*(1._dp - taudFinite) ! (radiation absorbed on the way up) + spectralCanopyAbsorbedDirect(iBand) = spectralIncomingDirect(iBand)*(1._rkind - tauFinite)*(1._rkind - betaFinite) + & ! (radiation absorbed on the way down) + spectralBelowCanopyDirect(iBand)*groundAlbedoDirect*(1._rkind - taudFinite) ! (radiation absorbed on the way up) + spectralCanopyAbsorbedDiffuse(iBand) = spectralIncomingDiffuse(iBand)*(1._rkind - taudFinite)*(1._rkind - betadFinite) + & ! (radiation absorbed on the way down) + spectralBelowCanopyDiffuse(iBand)*groundAlbedoDiffuse*(1._rkind - taudFinite) ! (radiation absorbed on the way up) spectralCanopyAbsorbedSolar(iBand) = spectralCanopyAbsorbedDirect(iBand) + spectralCanopyAbsorbedDiffuse(iBand) ! compute solar radiation lost to space in given wave band (W m-2) spectralTotalReflectedDirect(iBand) = spectralIncomingDirect(iBand) - spectralGroundAbsorbedDirect(iBand) - spectralCanopyAbsorbedDirect(iBand) spectralTotalReflectedDiffuse(iBand) = spectralIncomingDiffuse(iBand) - spectralGroundAbsorbedDiffuse(iBand) - spectralCanopyAbsorbedDiffuse(iBand) spectralTotalReflectedSolar(iBand) = spectralTotalReflectedDirect(iBand) + spectralTotalReflectedDiffuse(iBand) - if(spectralTotalReflectedDirect(iBand) < 0._dp .or. spectralTotalReflectedDiffuse(iBand) < 0._dp)then + if(spectralTotalReflectedDirect(iBand) < 0._rkind .or. spectralTotalReflectedDiffuse(iBand) < 0._rkind)then message=trim(message)//'UEB_2stream: reflected radiation is less than zero' err=20; return end if @@ -851,8 +851,8 @@ subroutine canopy_SW(& ! accumulate radiation absorbed by the ground (W m-2) scalarGroundAbsorbedSolar = scalarGroundAbsorbedSolar + & ! contribution from all previous wave bands - spectralBelowCanopyDirect(iBand)*(1._dp - spectralAlbGndDirect(iBand)) + & ! direct radiation from current wave band - spectralBelowCanopyDiffuse(iBand)*(1._dp - spectralAlbGndDiffuse(iBand)) ! diffuse radiation from current wave band + spectralBelowCanopyDirect(iBand)*(1._rkind - spectralAlbGndDirect(iBand)) + & ! direct radiation from current wave band + spectralBelowCanopyDiffuse(iBand)*(1._rkind - spectralAlbGndDiffuse(iBand)) ! diffuse radiation from current wave band ! save canopy radiation absorbed in visible wavelengths ! NOTE: here flux is per unit incoming flux @@ -876,11 +876,11 @@ subroutine canopy_SW(& ! compute sunlit fraction of canopy (from CLM/Noah-MP) ext = scalarGproj/scalarCosZenith ! optical depth of direct beam per unit leaf + stem area - scalarCanopySunlitFraction = (1._dp - exp(-ext*scalarExposedVAI)) / max(ext*scalarExposedVAI,mpe) - if(scalarCanopySunlitFraction < 0.01_dp) scalarCanopySunlitFraction = 0._dp + scalarCanopySunlitFraction = (1._rkind - exp(-ext*scalarExposedVAI)) / max(ext*scalarExposedVAI,mpe) + if(scalarCanopySunlitFraction < 0.01_rkind) scalarCanopySunlitFraction = 0._rkind ! compute sunlit and shaded LAI - scalarCanopyShadedFraction = 1._dp - scalarCanopySunlitFraction + scalarCanopyShadedFraction = 1._rkind - scalarCanopySunlitFraction scalarCanopySunlitLAI = scalarExposedLAI*scalarCanopySunlitFraction scalarCanopyShadedLAI = scalarExposedLAI*scalarCanopyShadedFraction @@ -890,7 +890,7 @@ subroutine canopy_SW(& scalarCanopySunlitPAR = (visibleAbsDirect + scalarCanopySunlitFraction*visibleAbsDiffuse) * fractionLAI / max(scalarCanopySunlitLAI, mpe) scalarCanopyShadedPAR = ( scalarCanopyShadedFraction*visibleAbsDiffuse) * fractionLAI / max(scalarCanopyShadedLAI, mpe) else - scalarCanopySunlitPAR = 0._dp + scalarCanopySunlitPAR = 0._rkind scalarCanopyShadedPAR = (visibleAbsDirect + visibleAbsDiffuse) * fractionLAI / max(scalarCanopyShadedLAI, mpe) end if !print*, 'scalarCanopySunlitLAI, fractionLAI, visibleAbsDirect, visibleAbsDiffuse, scalarCanopySunlitPAR = ', & @@ -921,32 +921,32 @@ subroutine gndAlbedo(& ! -------------------------------------------------------------------------------------------------------------------------------------- ! input: model control integer(i4b),intent(in) :: isc ! index of soil color - real(dp),intent(in) :: scalarGroundSnowFraction ! fraction of ground that is snow covered (-) - real(dp),intent(in) :: scalarVolFracLiqUpper ! volumetric liquid water content in upper-most soil layer (-) - real(dp),intent(in) :: spectralSnowAlbedoDirect(:) ! direct albedo of snow in each spectral band (-) - real(dp),intent(in) :: spectralSnowAlbedoDiffuse(:) ! diffuse albedo of snow in each spectral band (-) + real(rkind),intent(in) :: scalarGroundSnowFraction ! fraction of ground that is snow covered (-) + real(rkind),intent(in) :: scalarVolFracLiqUpper ! volumetric liquid water content in upper-most soil layer (-) + real(rkind),intent(in) :: spectralSnowAlbedoDirect(:) ! direct albedo of snow in each spectral band (-) + real(rkind),intent(in) :: spectralSnowAlbedoDiffuse(:) ! diffuse albedo of snow in each spectral band (-) ! output - real(dp),intent(out) :: spectralAlbGndDirect(:) ! direct albedo of underlying surface (-) - real(dp),intent(out) :: spectralAlbGndDiffuse(:) ! diffuse albedo of underlying surface (-) + real(rkind),intent(out) :: spectralAlbGndDirect(:) ! direct albedo of underlying surface (-) + real(rkind),intent(out) :: spectralAlbGndDiffuse(:) ! diffuse albedo of underlying surface (-) integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! local variables integer(i4b) :: iBand ! index of spectral band - real(dp) :: xInc ! soil water correction factor for soil albedo - real(dp),dimension(1:nBands) :: spectralSoilAlbedo ! soil albedo in each spectral band + real(rkind) :: xInc ! soil water correction factor for soil albedo + real(rkind),dimension(1:nBands) :: spectralSoilAlbedo ! soil albedo in each spectral band ! initialize error control err=0; message='gndAlbedo/' ! compute soil albedo do iBand=1,nBands ! loop through spectral bands - xInc = max(0.11_dp - 0.40_dp*scalarVolFracLiqUpper, 0._dp) + xInc = max(0.11_rkind - 0.40_rkind*scalarVolFracLiqUpper, 0._rkind) spectralSoilAlbedo(iBand) = min(ALBSAT(isc,iBand)+xInc,ALBDRY(isc,iBand)) end do ! (looping through spectral bands) ! compute surface albedo (weighted combination of snow and soil) do iBand=1,nBands - spectralAlbGndDirect(iBand) = (1._dp - scalarGroundSnowFraction)*spectralSoilAlbedo(iBand) + scalarGroundSnowFraction*spectralSnowAlbedoDirect(iBand) - spectralAlbGndDiffuse(iBand) = (1._dp - scalarGroundSnowFraction)*spectralSoilAlbedo(iBand) + scalarGroundSnowFraction*spectralSnowAlbedoDiffuse(iBand) + spectralAlbGndDirect(iBand) = (1._rkind - scalarGroundSnowFraction)*spectralSoilAlbedo(iBand) + scalarGroundSnowFraction*spectralSnowAlbedoDirect(iBand) + spectralAlbGndDiffuse(iBand) = (1._rkind - scalarGroundSnowFraction)*spectralSoilAlbedo(iBand) + scalarGroundSnowFraction*spectralSnowAlbedoDiffuse(iBand) end do ! (looping through spectral bands) end subroutine gndAlbedo diff --git a/build/source/engine/volicePack.f90 b/build/source/engine/volicePack.f90 index 8267f4770..71adf8ede 100755 --- a/build/source/engine/volicePack.f90 +++ b/build/source/engine/volicePack.f90 @@ -164,37 +164,37 @@ subroutine newsnwfall(& ! add new snowfall to the system implicit none ! input: model control - real(dp),intent(in) :: dt ! time step (seconds) + real(rkind),intent(in) :: dt ! time step (seconds) logical(lgt),intent(in) :: snowLayers ! logical flag if snow layers exist - real(dp),intent(in) :: fc_param ! freeezing curve parameter for snow (K-1) + real(rkind),intent(in) :: fc_param ! freeezing curve parameter for snow (K-1) ! input: diagnostic scalar variables - real(dp),intent(in) :: scalarSnowfallTemp ! computed temperature of fresh snow (K) - real(dp),intent(in) :: scalarNewSnowDensity ! computed density of new snow (kg m-3) - real(dp),intent(in) :: scalarThroughfallSnow ! throughfall of snow through the canopy (kg m-2 s-1) - real(dp),intent(in) :: scalarCanopySnowUnloading ! unloading of snow from the canopy (kg m-2 s-1) + real(rkind),intent(in) :: scalarSnowfallTemp ! computed temperature of fresh snow (K) + real(rkind),intent(in) :: scalarNewSnowDensity ! computed density of new snow (kg m-3) + real(rkind),intent(in) :: scalarThroughfallSnow ! throughfall of snow through the canopy (kg m-2 s-1) + real(rkind),intent(in) :: scalarCanopySnowUnloading ! unloading of snow from the canopy (kg m-2 s-1) ! input/output: state variables - real(dp),intent(inout) :: scalarSWE ! SWE (kg m-2) - real(dp),intent(inout) :: scalarSnowDepth ! total snow depth (m) - real(dp),intent(inout) :: surfaceLayerTemp ! temperature of each layer (K) - real(dp),intent(inout) :: surfaceLayerDepth ! depth of each layer (m) - real(dp),intent(inout) :: surfaceLayerVolFracIce ! volumetric fraction of ice in each layer (-) - real(dp),intent(inout) :: surfaceLayerVolFracLiq ! volumetric fraction of liquid water in each layer (-) + real(rkind),intent(inout) :: scalarSWE ! SWE (kg m-2) + real(rkind),intent(inout) :: scalarSnowDepth ! total snow depth (m) + real(rkind),intent(inout) :: surfaceLayerTemp ! temperature of each layer (K) + real(rkind),intent(inout) :: surfaceLayerDepth ! depth of each layer (m) + real(rkind),intent(inout) :: surfaceLayerVolFracIce ! volumetric fraction of ice in each layer (-) + real(rkind),intent(inout) :: surfaceLayerVolFracLiq ! volumetric fraction of liquid water in each layer (-) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! define local variables - real(dp) :: newSnowfall ! new snowfall -- throughfall and unloading (kg m-2 s-1) - real(dp) :: newSnowDepth ! new snow depth (m) - real(dp),parameter :: densityCanopySnow=200._dp ! density of snow on the vegetation canopy (kg m-3) - real(dp) :: totalMassIceSurfLayer ! total mass of ice in the surface layer (kg m-2) - real(dp) :: totalDepthSurfLayer ! total depth of the surface layer (m) - real(dp) :: volFracWater ! volumetric fraction of total water, liquid and ice (-) - real(dp) :: fracLiq ! fraction of liquid water (-) - real(dp) :: SWE ! snow water equivalent after snowfall (kg m-2) - real(dp) :: tempSWE0 ! temporary SWE before snowfall, used to check mass balance (kg m-2) - real(dp) :: tempSWE1 ! temporary SWE after snowfall, used to check mass balance (kg m-2) - real(dp) :: xMassBalance ! mass balance check (kg m-2) - real(dp),parameter :: verySmall=1.e-8_dp ! a very small number -- used to check mass balance + real(rkind) :: newSnowfall ! new snowfall -- throughfall and unloading (kg m-2 s-1) + real(rkind) :: newSnowDepth ! new snow depth (m) + real(rkind),parameter :: densityCanopySnow=200._rkind ! density of snow on the vegetation canopy (kg m-3) + real(rkind) :: totalMassIceSurfLayer ! total mass of ice in the surface layer (kg m-2) + real(rkind) :: totalDepthSurfLayer ! total depth of the surface layer (m) + real(rkind) :: volFracWater ! volumetric fraction of total water, liquid and ice (-) + real(rkind) :: fracLiq ! fraction of liquid water (-) + real(rkind) :: SWE ! snow water equivalent after snowfall (kg m-2) + real(rkind) :: tempSWE0 ! temporary SWE before snowfall, used to check mass balance (kg m-2) + real(rkind) :: tempSWE1 ! temporary SWE after snowfall, used to check mass balance (kg m-2) + real(rkind) :: xMassBalance ! mass balance check (kg m-2) + real(rkind),parameter :: verySmall=1.e-8_rkind ! a very small number -- used to check mass balance ! initialize error control err=0; message="newsnwfall/" @@ -233,7 +233,7 @@ subroutine newsnwfall(& ! compute new volumetric fraction of liquid water and ice (-) volFracWater = (SWE/totalDepthSurfLayer)/iden_water fracLiq = fracliquid(surfaceLayerTemp,fc_param) ! fraction of liquid water - surfaceLayerVolFracIce = (1._dp - fracLiq)*volFracWater*(iden_water/iden_ice) ! volumetric fraction of ice (-) + surfaceLayerVolFracIce = (1._rkind - fracLiq)*volFracWater*(iden_water/iden_ice) ! volumetric fraction of ice (-) surfaceLayerVolFracLiq = fracLiq *volFracWater ! volumetric fraction of liquid water (-) ! update new layer depth (m) surfaceLayerDepth = totalDepthSurfLayer diff --git a/build/source/netcdf/modelwrite.f90 b/build/source/netcdf/modelwrite.f90 index ee27a52af..bda626dba 100755 --- a/build/source/netcdf/modelwrite.f90 +++ b/build/source/netcdf/modelwrite.f90 @@ -176,8 +176,8 @@ subroutine writeData(finalizeStats,outputTimestep,nHRUrun,maxLayers,meta,stat,da ! output arrays integer(i4b) :: datLength ! length of each data vector integer(i4b) :: maxLength ! maximum length of each data vector - real(dp) :: realVec(nHRUrun) ! real vector for all HRUs in the run domain - real(dp) :: realArray(nHRUrun,maxLayers+1) ! real array for all HRUs in the run domain + real(rkind) :: realVec(nHRUrun) ! real vector for all HRUs in the run domain + real(rkind) :: realArray(nHRUrun,maxLayers+1) ! real array for all HRUs in the run domain integer(i4b) :: intArray(nHRUrun,maxLayers+1) ! integer array for all HRUs in the run domain integer(i4b) :: dataType ! type of data integer(i4b),parameter :: ixInteger=1001 ! named variable for integer diff --git a/build/source/netcdf/read_icond.f90 b/build/source/netcdf/read_icond.f90 index c5bdd929e..f31f74c32 100644 --- a/build/source/netcdf/read_icond.f90 +++ b/build/source/netcdf/read_icond.f90 @@ -201,7 +201,7 @@ subroutine read_icond(iconFile, & ! intent(in): name of integer(i4b) :: ixFile ! index in file integer(i4b) :: iHRU_local ! index of HRU in the data subset integer(i4b) :: iHRU_global ! index of HRU in the netcdf file - real(dp),allocatable :: varData(:,:) ! variable data storage + real(rkind),allocatable :: varData(:,:) ! variable data storage integer(i4b) :: nSoil, nSnow, nToto ! # layers integer(i4b) :: nTDH ! number of points in time-delay histogram integer(i4b) :: iLayer,jLayer ! layer indices @@ -319,7 +319,7 @@ subroutine read_icond(iconFile, & ! intent(in): name of if(err==20)then; message=trim(message)//"data set to the fill value (name='"//trim(prog_meta(iVar)%varName)//"')"; return; endif ! fix the snow albedo - if(progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%scalarSnowAlbedo)%dat(1) < 0._dp)then + if(progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%scalarSnowAlbedo)%dat(1) < 0._rkind)then progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%scalarSnowAlbedo)%dat(1) = mparData%gru(iGRU)%hru(iHRU)%var(iLookPARAM%albedoMax)%dat(1) endif @@ -376,7 +376,7 @@ subroutine read_icond(iconFile, & ! intent(in): name of mparData%gru(iGRU)%hru(iHRU)%var(iLookPARAM%vGn_n )%dat(iLayer),& ! intent(in): van Genutchen "n" parameter mparData%gru(iGRU)%hru(iHRU)%var(iLookPARAM%theta_sat )%dat(iLayer),& ! intent(in): soil porosity (-) mparData%gru(iGRU)%hru(iHRU)%var(iLookPARAM%theta_res )%dat(iLayer),& ! intent(in): soil residual volumetric water content (-) - 1._dp - 1._dp/mparData%gru(iGRU)%hru(iHRU)%var(iLookPARAM%vGn_n)%dat(iLayer),& ! intent(in): van Genutchen "m" parameter (-) + 1._rkind - 1._rkind/mparData%gru(iGRU)%hru(iHRU)%var(iLookPARAM%vGn_n)%dat(iLayer),& ! intent(in): van Genutchen "m" parameter (-) ! output progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%mLayerVolFracWat )%dat(jLayer),& ! intent(out): volumetric fraction of total water (-) progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%mLayerVolFracLiq )%dat(jLayer),& ! intent(out): volumetric fraction of liquid water (-) diff --git a/build/source/noah-mp/module_model_constants.F b/build/source/noah-mp/module_model_constants.F index 9539d4482..a1380871f 100755 --- a/build/source/noah-mp/module_model_constants.F +++ b/build/source/noah-mp/module_model_constants.F @@ -2,138 +2,139 @@ ! MODULE module_model_constants + USE nrtype ! 2. Following are constants for use in defining real number bounds. ! A really small number. - REAL , PARAMETER :: epsilon = 1.E-15 + REAL(rkind) , PARAMETER :: epsilon = 1.E-15 ! 4. Following is information related to the physical constants. ! These are the physical constants used within the model. ! JM NOTE -- can we name this grav instead? - REAL , PARAMETER :: g = 9.81 ! acceleration due to gravity (m {s}^-2) + REAL(rkind) , PARAMETER :: g = 9.81 ! acceleration due to gravity (m {s}^-2) #if ( NMM_CORE == 1 ) - REAL , PARAMETER :: r_d = 287.04 - REAL , PARAMETER :: cp = 1004.6 + REAL(rkind) , PARAMETER :: r_d = 287.04 + REAL(rkind) , PARAMETER :: cp = 1004.6 #else - REAL , PARAMETER :: r_d = 287. - REAL , PARAMETER :: cp = 7.*r_d/2. + REAL(rkind) , PARAMETER :: r_d = 287. + REAL(rkind) , PARAMETER :: cp = 7.*r_d/2. #endif - REAL , PARAMETER :: r_v = 461.6 - REAL , PARAMETER :: cv = cp-r_d - REAL , PARAMETER :: cpv = 4.*r_v - REAL , PARAMETER :: cvv = cpv-r_v - REAL , PARAMETER :: cvpm = -cv/cp - REAL , PARAMETER :: cliq = 4190. - REAL , PARAMETER :: cice = 2106. - REAL , PARAMETER :: psat = 610.78 - REAL , PARAMETER :: rcv = r_d/cv - REAL , PARAMETER :: rcp = r_d/cp - REAL , PARAMETER :: rovg = r_d/g - REAL , PARAMETER :: c2 = cp * rcv + REAL(rkind) , PARAMETER :: r_v = 461.6 + REAL(rkind) , PARAMETER :: cv = cp-r_d + REAL(rkind) , PARAMETER :: cpv = 4.*r_v + REAL(rkind) , PARAMETER :: cvv = cpv-r_v + REAL(rkind) , PARAMETER :: cvpm = -cv/cp + REAL(rkind) , PARAMETER :: cliq = 4190. + REAL(rkind) , PARAMETER :: cice = 2106. + REAL(rkind) , PARAMETER :: psat = 610.78 + REAL(rkind) , PARAMETER :: rcv = r_d/cv + REAL(rkind) , PARAMETER :: rcp = r_d/cp + REAL(rkind) , PARAMETER :: rovg = r_d/g + REAL(rkind) , PARAMETER :: c2 = cp * rcv real , parameter :: mwdry = 28.966 ! molecular weight of dry air (g/mole) - REAL , PARAMETER :: p1000mb = 100000. - REAL , PARAMETER :: t0 = 300. - REAL , PARAMETER :: p0 = p1000mb - REAL , PARAMETER :: cpovcv = cp/(cp-r_d) - REAL , PARAMETER :: cvovcp = 1./cpovcv - REAL , PARAMETER :: rvovrd = r_v/r_d + REAL(rkind) , PARAMETER :: p1000mb = 100000. + REAL(rkind) , PARAMETER :: t0 = 300. + REAL(rkind) , PARAMETER :: p0 = p1000mb + REAL(rkind) , PARAMETER :: cpovcv = cp/(cp-r_d) + REAL(rkind) , PARAMETER :: cvovcp = 1./cpovcv + REAL(rkind) , PARAMETER :: rvovrd = r_v/r_d - REAL , PARAMETER :: reradius = 1./6370.0e03 + REAL(rkind) , PARAMETER :: reradius = 1./6370.0e03 - REAL , PARAMETER :: asselin = .025 -! REAL , PARAMETER :: asselin = .0 - REAL , PARAMETER :: cb = 25. + REAL(rkind) , PARAMETER :: asselin = .025 +! REAL(rkind) , PARAMETER :: asselin = .0 + REAL(rkind) , PARAMETER :: cb = 25. - REAL , PARAMETER :: XLV0 = 3.15E6 - REAL , PARAMETER :: XLV1 = 2370. - REAL , PARAMETER :: XLS0 = 2.905E6 - REAL , PARAMETER :: XLS1 = 259.532 + REAL(rkind) , PARAMETER :: XLV0 = 3.15E6 + REAL(rkind) , PARAMETER :: XLV1 = 2370. + REAL(rkind) , PARAMETER :: XLS0 = 2.905E6 + REAL(rkind) , PARAMETER :: XLS1 = 259.532 - REAL , PARAMETER :: XLS = 2.85E6 - REAL , PARAMETER :: XLV = 2.5E6 - REAL , PARAMETER :: XLF = 3.50E5 + REAL(rkind) , PARAMETER :: XLS = 2.85E6 + REAL(rkind) , PARAMETER :: XLV = 2.5E6 + REAL(rkind) , PARAMETER :: XLF = 3.50E5 - REAL , PARAMETER :: rhowater = 1000. - REAL , PARAMETER :: rhosnow = 100. - REAL , PARAMETER :: rhoair0 = 1.28 + REAL(rkind) , PARAMETER :: rhowater = 1000. + REAL(rkind) , PARAMETER :: rhosnow = 100. + REAL(rkind) , PARAMETER :: rhoair0 = 1.28 ! - REAL , PARAMETER :: n_ccn0 = 1.0E8 + REAL(rkind) , PARAMETER :: n_ccn0 = 1.0E8 ! - REAL , PARAMETER :: DEGRAD = 3.1415926/180. - REAL , PARAMETER :: DPD = 360./365. - - REAL , PARAMETER :: SVP1=0.6112 - REAL , PARAMETER :: SVP2=17.67 - REAL , PARAMETER :: SVP3=29.65 - REAL , PARAMETER :: SVPT0=273.15 - REAL , PARAMETER :: EP_1=R_v/R_d-1. - REAL , PARAMETER :: EP_2=R_d/R_v - REAL , PARAMETER :: KARMAN=0.4 - REAL , PARAMETER :: EOMEG=7.2921E-5 - REAL , PARAMETER :: STBOLT=5.67051E-8 - - REAL , PARAMETER :: prandtl = 1./3.0 + REAL(rkind) , PARAMETER :: DEGRAD = 3.1415926/180. + REAL(rkind) , PARAMETER :: DPD = 360./365. + + REAL(rkind) , PARAMETER :: SVP1=0.6112 + REAL(rkind) , PARAMETER :: SVP2=17.67 + REAL(rkind) , PARAMETER :: SVP3=29.65 + REAL(rkind) , PARAMETER :: SVPT0=273.15 + REAL(rkind) , PARAMETER :: EP_1=R_v/R_d-1. + REAL(rkind) , PARAMETER :: EP_2=R_d/R_v + REAL(rkind) , PARAMETER :: KARMAN=0.4 + REAL(rkind) , PARAMETER :: EOMEG=7.2921E-5 + REAL(rkind) , PARAMETER :: STBOLT=5.67051E-8 + + REAL(rkind) , PARAMETER :: prandtl = 1./3.0 ! constants for w-damping option - REAL , PARAMETER :: w_alpha = 0.3 ! strength m/s/s - REAL , PARAMETER :: w_beta = 1.0 ! activation cfl number - - REAL , PARAMETER :: pq0=379.90516 - REAL , PARAMETER :: epsq2=0.2 - REAL , PARAMETER :: a2=17.2693882 - REAL , PARAMETER :: a3=273.16 - REAL , PARAMETER :: a4=35.86 - REAL , PARAMETER :: epsq=1.e-12 - REAL , PARAMETER :: p608=rvovrd-1. + REAL(rkind) , PARAMETER :: w_alpha = 0.3 ! strength m/s/s + REAL(rkind) , PARAMETER :: w_beta = 1.0 ! activation cfl number + + REAL(rkind) , PARAMETER :: pq0=379.90516 + REAL(rkind) , PARAMETER :: epsq2=0.2 + REAL(rkind) , PARAMETER :: a2=17.2693882 + REAL(rkind) , PARAMETER :: a3=273.16 + REAL(rkind) , PARAMETER :: a4=35.86 + REAL(rkind) , PARAMETER :: epsq=1.e-12 + REAL(rkind) , PARAMETER :: p608=rvovrd-1. !#if ( NMM_CORE == 1 ) - REAL , PARAMETER :: climit=1.e-20 - REAL , PARAMETER :: cm1=2937.4 - REAL , PARAMETER :: cm2=4.9283 - REAL , PARAMETER :: cm3=23.5518 -! REAL , PARAMETER :: defc=8.0 -! REAL , PARAMETER :: defm=32.0 - REAL , PARAMETER :: defc=0.0 - REAL , PARAMETER :: defm=99999.0 - REAL , PARAMETER :: epsfc=1./1.05 - REAL , PARAMETER :: epswet=0.0 - REAL , PARAMETER :: fcdif=1./3. + REAL(rkind) , PARAMETER :: climit=1.e-20 + REAL(rkind) , PARAMETER :: cm1=2937.4 + REAL(rkind) , PARAMETER :: cm2=4.9283 + REAL(rkind) , PARAMETER :: cm3=23.5518 +! REAL(rkind) , PARAMETER :: defc=8.0 +! REAL(rkind) , PARAMETER :: defm=32.0 + REAL(rkind) , PARAMETER :: defc=0.0 + REAL(rkind) , PARAMETER :: defm=99999.0 + REAL(rkind) , PARAMETER :: epsfc=1./1.05 + REAL(rkind) , PARAMETER :: epswet=0.0 + REAL(rkind) , PARAMETER :: fcdif=1./3. #ifdef HWRF - REAL , PARAMETER :: fcm=0.0 + REAL(rkind) , PARAMETER :: fcm=0.0 #else - REAL , PARAMETER :: fcm=0.00003 + REAL(rkind) , PARAMETER :: fcm=0.00003 #endif - REAL , PARAMETER :: gma=-r_d*(1.-rcp)*0.5 - REAL , PARAMETER :: p400=40000.0 - REAL , PARAMETER :: phitp=15000.0 - REAL , PARAMETER :: pi2=2.*3.1415926 - REAL , PARAMETER :: plbtm=105000.0 - REAL , PARAMETER :: plomd=64200.0 - REAL , PARAMETER :: pmdhi=35000.0 - REAL , PARAMETER :: q2ini=0.50 - REAL , PARAMETER :: rfcp=0.25/cp - REAL , PARAMETER :: rhcrit_land=0.75 - REAL , PARAMETER :: rhcrit_sea=0.80 - REAL , PARAMETER :: rlag=14.8125 - REAL , PARAMETER :: rlx=0.90 - REAL , PARAMETER :: scq2=50.0 - REAL , PARAMETER :: slopht=0.001 - REAL , PARAMETER :: tlc=2.*0.703972477 - REAL , PARAMETER :: wa=0.15 - REAL , PARAMETER :: wght=0.35 - REAL , PARAMETER :: wpc=0.075 - REAL , PARAMETER :: z0land=0.10 + REAL(rkind) , PARAMETER :: gma=-r_d*(1.-rcp)*0.5 + REAL(rkind) , PARAMETER :: p400=40000.0 + REAL(rkind) , PARAMETER :: phitp=15000.0 + REAL(rkind) , PARAMETER :: pi2=2.*3.1415926 + REAL(rkind) , PARAMETER :: plbtm=105000.0 + REAL(rkind) , PARAMETER :: plomd=64200.0 + REAL(rkind) , PARAMETER :: pmdhi=35000.0 + REAL(rkind) , PARAMETER :: q2ini=0.50 + REAL(rkind) , PARAMETER :: rfcp=0.25/cp + REAL(rkind) , PARAMETER :: rhcrit_land=0.75 + REAL(rkind) , PARAMETER :: rhcrit_sea=0.80 + REAL(rkind) , PARAMETER :: rlag=14.8125 + REAL(rkind) , PARAMETER :: rlx=0.90 + REAL(rkind) , PARAMETER :: scq2=50.0 + REAL(rkind) , PARAMETER :: slopht=0.001 + REAL(rkind) , PARAMETER :: tlc=2.*0.703972477 + REAL(rkind) , PARAMETER :: wa=0.15 + REAL(rkind) , PARAMETER :: wght=0.35 + REAL(rkind) , PARAMETER :: wpc=0.075 + REAL(rkind) , PARAMETER :: z0land=0.10 #ifdef HWRF - REAL , PARAMETER :: z0max=0.01 + REAL(rkind) , PARAMETER :: z0max=0.01 #else - REAL , PARAMETER :: z0max=0.008 + REAL(rkind) , PARAMETER :: z0max=0.008 #endif - REAL , PARAMETER :: z0sea=0.001 + REAL(rkind) , PARAMETER :: z0sea=0.001 !#endif @@ -141,19 +142,19 @@ MODULE module_model_constants ! The value for P2SI *must* be set to 1.0 for Earth ! Although, now we may not need this declaration here (see above) - !REAL , PARAMETER :: P2SI = 1.0 + !REAL(rkind) , PARAMETER :: P2SI = 1.0 ! Orbital constants: INTEGER , PARAMETER :: PLANET_YEAR = 365 - REAL , PARAMETER :: OBLIQUITY = 23.5 - REAL , PARAMETER :: ECCENTRICITY = 0.014 - REAL , PARAMETER :: SEMIMAJORAXIS = 1.0 ! In AU + REAL(rkind) , PARAMETER :: OBLIQUITY = 23.5 + REAL(rkind) , PARAMETER :: ECCENTRICITY = 0.014 + REAL(rkind) , PARAMETER :: SEMIMAJORAXIS = 1.0 ! In AU ! Don't know the following values, so we'll fake them for now - REAL , PARAMETER :: zero_date = 0.0 ! Time of perihelion passage + REAL(rkind) , PARAMETER :: zero_date = 0.0 ! Time of perihelion passage ! Fraction into the year (from perhelion) of the ! occurrence of the Northern Spring Equinox - REAL , PARAMETER :: EQUINOX_FRACTION= 0.0 + REAL(rkind) , PARAMETER :: EQUINOX_FRACTION= 0.0 CONTAINS SUBROUTINE init_module_model_constants diff --git a/build/source/noah-mp/module_sf_noahlsm.F b/build/source/noah-mp/module_sf_noahlsm.F index 6d38415c0..e3fc5166b 100755 --- a/build/source/noah-mp/module_sf_noahlsm.F +++ b/build/source/noah-mp/module_sf_noahlsm.F @@ -1,8 +1,9 @@ MODULE module_sf_noahlsm + USE nrtype USE module_model_constants -! REAL, PARAMETER :: CP = 1004.5 - REAL, PARAMETER :: RD = 287.04, SIGMA = 5.67E-8, & +! REAL(rkind), PARAMETER :: CP = 1004.5 + REAL(rkind), PARAMETER :: RD = 287.04, SIGMA = 5.67E-8, & CPH2O = 4.218E+3,CPICE = 2.106E+3, & LSUBF = 3.335E+5, & EMISSI_S = 0.95 @@ -19,26 +20,26 @@ MODULE module_sf_noahlsm LAIMINTBL, LAIMAXTBL, & Z0MINTBL, Z0MAXTBL, & ALBEDOMINTBL, ALBEDOMAXTBL - REAL :: TOPT_DATA,CMCMAX_DATA,CFACTR_DATA,RSMAX_DATA + REAL(rkind) :: TOPT_DATA,CMCMAX_DATA,CFACTR_DATA,RSMAX_DATA ! SOIL PARAMETERS INTEGER :: SLCATS INTEGER, PARAMETER :: NSLTYPE=30 CHARACTER(LEN=256) SLTYPE - REAL, DIMENSION (1:NSLTYPE) :: BB,DRYSMC,F11, & + REAL(rkind), DIMENSION (1:NSLTYPE) :: BB,DRYSMC,F11, & MAXSMC, REFSMC,SATPSI,SATDK,SATDW, WLTSMC,QTZ ! MPC add van Genutchen parameters - REAL, DIMENSION (1:NSLTYPE) :: theta_res, theta_sat, & + REAL(rkind), DIMENSION (1:NSLTYPE) :: theta_res, theta_sat, & vGn_alpha, vGn_n, k_soil ! LSM GENERAL PARAMETERS INTEGER :: SLPCATS INTEGER, PARAMETER :: NSLOPE=30 - REAL, DIMENSION (1:NSLOPE) :: SLOPE_DATA - REAL :: SBETA_DATA,FXEXP_DATA,CSOIL_DATA,SALP_DATA,REFDK_DATA, & + REAL(rkind), DIMENSION (1:NSLOPE) :: SLOPE_DATA + REAL(rkind) :: SBETA_DATA,FXEXP_DATA,CSOIL_DATA,SALP_DATA,REFDK_DATA, & REFKDT_DATA,FRZK_DATA,ZBOT_DATA, SMLOW_DATA,SMHIGH_DATA, & CZIL_DATA - REAL :: LVCOEF_DATA + REAL(rkind) :: LVCOEF_DATA CHARACTER*256 :: err_message integer, private :: iloc, jloc diff --git a/build/source/noah-mp/module_sf_noahmplsm.F b/build/source/noah-mp/module_sf_noahmplsm.F index 8ddfedbde..3a649ea96 100755 --- a/build/source/noah-mp/module_sf_noahmplsm.F +++ b/build/source/noah-mp/module_sf_noahmplsm.F @@ -1,4 +1,5 @@ module noahmp_globals + USE nrtype ! Maybe most of these can be moved to a REDPRM use statement? ! MPC -- yes, all of these variables can be local to REDPRM (see additional comments) @@ -36,33 +37,33 @@ module noahmp_globals ! Physical Constants: ! !------------------------------------------------------------------------------------------! - REAL, PARAMETER :: GRAV = 9.80616 !acceleration due to gravity (m/s2) - REAL, PARAMETER :: SB = 5.67E-08 !Stefan-Boltzmann constant (w/m2/k4) - REAL, PARAMETER :: VKC = 0.40 !von Karman constant - REAL, PARAMETER :: TFRZ = 273.16 !freezing/melting point (k) - REAL, PARAMETER :: HSUB = 2.8440E06 !latent heat of sublimation (j/kg) - REAL, PARAMETER :: HVAP = 2.5104E06 !latent heat of vaporization (j/kg) - REAL, PARAMETER :: HFUS = 0.3336E06 !latent heat of fusion (j/kg) - REAL, PARAMETER :: CWAT = 4.188E06 !specific heat capacity of water (j/m3/k) - REAL, PARAMETER :: CICE = 2.094E06 !specific heat capacity of ice (j/m3/k) - REAL, PARAMETER :: CPAIR = 1004.64 !heat capacity dry air at const pres (j/kg/k) - REAL, PARAMETER :: TKWAT = 0.6 !thermal conductivity of water (w/m/k) - REAL, PARAMETER :: TKICE = 2.2 !thermal conductivity of ice (w/m/k) - REAL, PARAMETER :: TKAIR = 0.023 !thermal conductivity of air (w/m/k) - REAL, PARAMETER :: RAIR = 287.04 !gas constant for dry air (j/kg/k) - REAL, PARAMETER :: RW = 461.269 !gas constant for water vapor (j/kg/k) - REAL, PARAMETER :: DENH2O = 1000. !density of water (kg/m3) - REAL, PARAMETER :: DENICE = 917. !density of ice (kg/m3) + REAL(rkind), PARAMETER :: GRAV = 9.80616 !acceleration due to gravity (m/s2) + REAL(rkind), PARAMETER :: SB = 5.67E-08 !Stefan-Boltzmann constant (w/m2/k4) + REAL(rkind), PARAMETER :: VKC = 0.40 !von Karman constant + REAL(rkind), PARAMETER :: TFRZ = 273.16 !freezing/melting point (k) + REAL(rkind), PARAMETER :: HSUB = 2.8440E06 !latent heat of sublimation (j/kg) + REAL(rkind), PARAMETER :: HVAP = 2.5104E06 !latent heat of vaporization (j/kg) + REAL(rkind), PARAMETER :: HFUS = 0.3336E06 !latent heat of fusion (j/kg) + REAL(rkind), PARAMETER :: CWAT = 4.188E06 !specific heat capacity of water (j/m3/k) + REAL(rkind), PARAMETER :: CICE = 2.094E06 !specific heat capacity of ice (j/m3/k) + REAL(rkind), PARAMETER :: CPAIR = 1004.64 !heat capacity dry air at const pres (j/kg/k) + REAL(rkind), PARAMETER :: TKWAT = 0.6 !thermal conductivity of water (w/m/k) + REAL(rkind), PARAMETER :: TKICE = 2.2 !thermal conductivity of ice (w/m/k) + REAL(rkind), PARAMETER :: TKAIR = 0.023 !thermal conductivity of air (w/m/k) + REAL(rkind), PARAMETER :: RAIR = 287.04 !gas constant for dry air (j/kg/k) + REAL(rkind), PARAMETER :: RW = 461.269 !gas constant for water vapor (j/kg/k) + REAL(rkind), PARAMETER :: DENH2O = 1000. !density of water (kg/m3) + REAL(rkind), PARAMETER :: DENICE = 917. !density of ice (kg/m3) !------------------------------------------------------------------------------------------! ! From the VEGPARM.TBL tables, as functions of vegetation category. !------------------------------------------------------------------------------------------! INTEGER :: NROOT !rooting depth [as the number of layers] ( Assigned in REDPRM ) - REAL :: RGL !parameter used in radiation stress function ( Assigned in REDPRM ) - REAL :: RSMIN !minimum Canopy Resistance [s/m] ( Assigned in REDPRM ) - REAL :: HS !parameter used in vapor pressure deficit function ( Assigned in REDPRM ) - REAL :: RSMAX !maximum stomatal resistance ( Assigned in REDPRM ) - REAL :: TOPT !optimum transpiration air temperature. + REAL(rkind) :: RGL !parameter used in radiation stress function ( Assigned in REDPRM ) + REAL(rkind) :: RSMIN !minimum Canopy Resistance [s/m] ( Assigned in REDPRM ) + REAL(rkind) :: HS !parameter used in vapor pressure deficit function ( Assigned in REDPRM ) + REAL(rkind) :: RSMAX !maximum stomatal resistance ( Assigned in REDPRM ) + REAL(rkind) :: TOPT !optimum transpiration air temperature. ! MPC change: make variables private for a given thread !$omp threadprivate(NROOT, RGL, RSMIN, HS, RSMAX, TOPT) @@ -70,17 +71,17 @@ module noahmp_globals !------------------------------------------------------------------------------------------! ! From the SOILPARM.TBL tables, as functions of soil category. !------------------------------------------------------------------------------------------! - REAL :: BEXP !B parameter ( Assigned in REDPRM ) - REAL :: SMCDRY !dry soil moisture threshold where direct evap from top + REAL(rkind) :: BEXP !B parameter ( Assigned in REDPRM ) + REAL(rkind) :: SMCDRY !dry soil moisture threshold where direct evap from top !layer ends (volumetric) ( Assigned in REDPRM ) - REAL :: F1 !soil thermal diffusivity/conductivity coef ( Assigned in REDPRM ) - REAL :: SMCMAX !porosity, saturated value of soil moisture (volumetric) - REAL :: SMCREF !reference soil moisture (field capacity) (volumetric) ( Assigned in REDPRM ) - REAL :: PSISAT !saturated soil matric potential ( Assigned in REDPRM ) - REAL :: DKSAT !saturated soil hydraulic conductivity ( Assigned in REDPRM ) - REAL :: DWSAT !saturated soil hydraulic diffusivity ( Assigned in REDPRM ) - REAL :: SMCWLT !wilting point soil moisture (volumetric) ( Assigned in REDPRM ) - REAL :: QUARTZ !soil quartz content ( Assigned in REDPRM ) + REAL(rkind) :: F1 !soil thermal diffusivity/conductivity coef ( Assigned in REDPRM ) + REAL(rkind) :: SMCMAX !porosity, saturated value of soil moisture (volumetric) + REAL(rkind) :: SMCREF !reference soil moisture (field capacity) (volumetric) ( Assigned in REDPRM ) + REAL(rkind) :: PSISAT !saturated soil matric potential ( Assigned in REDPRM ) + REAL(rkind) :: DKSAT !saturated soil hydraulic conductivity ( Assigned in REDPRM ) + REAL(rkind) :: DWSAT !saturated soil hydraulic diffusivity ( Assigned in REDPRM ) + REAL(rkind) :: SMCWLT !wilting point soil moisture (volumetric) ( Assigned in REDPRM ) + REAL(rkind) :: QUARTZ !soil quartz content ( Assigned in REDPRM ) ! MPC change: make variables private for a given thread !$omp threadprivate(BEXP, SMCDRY, F1, SMCMAX, SMCREF, PSISAT, DKSAT, DWSAT, SMCWLT, QUARTZ) @@ -88,16 +89,16 @@ module noahmp_globals !------------------------------------------------------------------------------------------! ! From the GENPARM.TBL file !------------------------------------------------------------------------------------------! - REAL :: SLOPE !slope index (0 - 1) ( Assigned in REDPRM ) - REAL :: CSOIL !vol. soil heat capacity [j/m3/K] ( Assigned in REDPRM ) - REAL :: ZBOT !Depth (m) of lower boundary soil temperature ( Assigned in REDPRM ) - REAL :: CZIL !Calculate roughness length of heat ( Assigned in REDPRM ) + REAL(rkind) :: SLOPE !slope index (0 - 1) ( Assigned in REDPRM ) + REAL(rkind) :: CSOIL !vol. soil heat capacity [j/m3/K] ( Assigned in REDPRM ) + REAL(rkind) :: ZBOT !Depth (m) of lower boundary soil temperature ( Assigned in REDPRM ) + REAL(rkind) :: CZIL !Calculate roughness length of heat ( Assigned in REDPRM ) ! MPC note: FRZK_DATA, REFDK_DATA, and REFKDT_DATA are used in REDPRM to compute KDT and FRZX ! (FRZK, REFDK, and REFKDT are local variables within REDPRM and do not need to be thread private) - REAL :: KDT !used in compute maximum infiltration rate (in INFIL) ( Assigned in REDPRM ) - REAL :: FRZX !used in compute maximum infiltration rate (in INFIL) ( Assigned in REDPRM ) + REAL(rkind) :: KDT !used in compute maximum infiltration rate (in INFIL) ( Assigned in REDPRM ) + REAL(rkind) :: FRZX !used in compute maximum infiltration rate (in INFIL) ( Assigned in REDPRM ) ! MPC change: make variables private for a given thread !$omp threadprivate(SLOPE, CSOIL, ZBOT, CZIL, KDT, FRZX) @@ -178,15 +179,15 @@ module noahmp_globals INTEGER :: OPT_STC != 1 !(suggested 1) ! ================================================================================================== ! runoff parameters used for SIMTOP and SIMGM: - REAL, PARAMETER :: TIMEAN = 10.5 !gridcell mean topgraphic index (global mean) - REAL, PARAMETER :: FSATMX = 0.38 !maximum surface saturated fraction (global mean) + REAL(rkind), PARAMETER :: TIMEAN = 10.5 !gridcell mean topgraphic index (global mean) + REAL(rkind), PARAMETER :: FSATMX = 0.38 !maximum surface saturated fraction (global mean) ! adjustable parameters for snow processes - REAL, PARAMETER :: M = 1.0 ! 2.50 !melting factor (-) - REAL, PARAMETER :: Z0SNO = 0.002 !snow surface roughness length (m) (0.002) - REAL, PARAMETER :: SSI = 0.03 !liquid water holding capacity for snowpack (m3/m3) (0.03) - REAL, PARAMETER :: SWEMX = 1.00 !new snow mass to fully cover old snow (mm) + REAL(rkind), PARAMETER :: M = 1.0 ! 2.50 !melting factor (-) + REAL(rkind), PARAMETER :: Z0SNO = 0.002 !snow surface roughness length (m) (0.002) + REAL(rkind), PARAMETER :: SSI = 0.03 !liquid water holding capacity for snowpack (m3/m3) (0.03) + REAL(rkind), PARAMETER :: SWEMX = 1.00 !new snow mass to fully cover old snow (mm) !equivalent to 10mm depth (density = 100 kg/m3) ! NOTES: things to add or improve @@ -200,7 +201,7 @@ END MODULE NOAHMP_GLOBALS !------------------------------------------------------------------------------------------! !------------------------------------------------------------------------------------------! MODULE NOAHMP_VEG_PARAMETERS - + use nrtype IMPLICIT NONE INTEGER, PARAMETER :: MAX_VEG_PARAMS = 33 @@ -213,63 +214,63 @@ MODULE NOAHMP_VEG_PARAMETERS INTEGER :: ISSNOW INTEGER :: EBLFOREST - REAL :: CH2OP(MVT) !maximum intercepted h2o per unit lai+sai (mm) - REAL :: DLEAF(MVT) !characteristic leaf dimension (m) - REAL :: Z0MVT(MVT) !momentum roughness length (m) - REAL :: HVT(MVT) !top of canopy (m) - REAL :: HVB(MVT) !bottom of canopy (m) - REAL :: DEN(MVT) !tree density (no. of trunks per m2) - REAL :: RC(MVT) !tree crown radius (m) - REAL :: SAIM(MVT,12) !monthly stem area index, one-sided - REAL :: LAIM(MVT,12) !monthly leaf area index, one-sided - REAL :: SLA(MVT) !single-side leaf area per Kg [m2/kg] - REAL :: DILEFC(MVT) !coeficient for leaf stress death [1/s] - REAL :: DILEFW(MVT) !coeficient for leaf stress death [1/s] - REAL :: FRAGR(MVT) !fraction of growth respiration !original was 0.3 - REAL :: LTOVRC(MVT) !leaf turnover [1/s] - - REAL :: C3PSN(MVT) !photosynthetic pathway: 0. = c4, 1. = c3 - REAL :: KC25(MVT) !co2 michaelis-menten constant at 25c (pa) - REAL :: AKC(MVT) !q10 for kc25 - REAL :: KO25(MVT) !o2 michaelis-menten constant at 25c (pa) - REAL :: AKO(MVT) !q10 for ko25 - REAL :: VCMX25(MVT) !maximum rate of carboxylation at 25c (umol co2/m**2/s) - REAL :: AVCMX(MVT) !q10 for vcmx25 - REAL :: BP(MVT) !minimum leaf conductance (umol/m**2/s) - REAL :: MP(MVT) !slope of conductance-to-photosynthesis relationship - REAL :: QE25(MVT) !quantum efficiency at 25c (umol co2 / umol photon) - REAL :: AQE(MVT) !q10 for qe25 - REAL :: RMF25(MVT) !leaf maintenance respiration at 25c (umol co2/m**2/s) - REAL :: RMS25(MVT) !stem maintenance respiration at 25c (umol co2/kg bio/s) - REAL :: RMR25(MVT) !root maintenance respiration at 25c (umol co2/kg bio/s) - REAL :: ARM(MVT) !q10 for maintenance respiration - REAL :: FOLNMX(MVT) !foliage nitrogen concentration when f(n)=1 (%) - REAL :: TMIN(MVT) !minimum temperature for photosynthesis (k) - - REAL :: XL(MVT) !leaf/stem orientation index - REAL :: RHOL(MVT,MBAND) !leaf reflectance: 1=vis, 2=nir - REAL :: RHOS(MVT,MBAND) !stem reflectance: 1=vis, 2=nir - REAL :: TAUL(MVT,MBAND) !leaf transmittance: 1=vis, 2=nir - REAL :: TAUS(MVT,MBAND) !stem transmittance: 1=vis, 2=nir - - REAL :: MRP(MVT) !microbial respiration parameter (umol co2 /kg c/ s) - REAL :: CWPVT(MVT) !empirical canopy wind parameter - - REAL :: WRRAT(MVT) !wood to non-wood ratio - REAL :: WDPOOL(MVT) !wood pool (switch 1 or 0) depending on woody or not [-] - REAL :: TDLEF(MVT) !characteristic T for leaf freezing [K] + REAL(rkind) :: CH2OP(MVT) !maximum intercepted h2o per unit lai+sai (mm) + REAL(rkind) :: DLEAF(MVT) !characteristic leaf dimension (m) + REAL(rkind) :: Z0MVT(MVT) !momentum roughness length (m) + REAL(rkind) :: HVT(MVT) !top of canopy (m) + REAL(rkind) :: HVB(MVT) !bottom of canopy (m) + REAL(rkind) :: DEN(MVT) !tree density (no. of trunks per m2) + REAL(rkind) :: RC(MVT) !tree crown radius (m) + REAL(rkind) :: SAIM(MVT,12) !monthly stem area index, one-sided + REAL(rkind) :: LAIM(MVT,12) !monthly leaf area index, one-sided + REAL(rkind) :: SLA(MVT) !single-side leaf area per Kg [m2/kg] + REAL(rkind) :: DILEFC(MVT) !coeficient for leaf stress death [1/s] + REAL(rkind) :: DILEFW(MVT) !coeficient for leaf stress death [1/s] + REAL(rkind) :: FRAGR(MVT) !fraction of growth respiration !original was 0.3 + REAL(rkind) :: LTOVRC(MVT) !leaf turnover [1/s] + + REAL(rkind) :: C3PSN(MVT) !photosynthetic pathway: 0. = c4, 1. = c3 + REAL(rkind) :: KC25(MVT) !co2 michaelis-menten constant at 25c (pa) + REAL(rkind) :: AKC(MVT) !q10 for kc25 + REAL(rkind) :: KO25(MVT) !o2 michaelis-menten constant at 25c (pa) + REAL(rkind) :: AKO(MVT) !q10 for ko25 + REAL(rkind) :: VCMX25(MVT) !maximum rate of carboxylation at 25c (umol co2/m**2/s) + REAL(rkind) :: AVCMX(MVT) !q10 for vcmx25 + REAL(rkind) :: BP(MVT) !minimum leaf conductance (umol/m**2/s) + REAL(rkind) :: MP(MVT) !slope of conductance-to-photosynthesis relationship + REAL(rkind) :: QE25(MVT) !quantum efficiency at 25c (umol co2 / umol photon) + REAL(rkind) :: AQE(MVT) !q10 for qe25 + REAL(rkind) :: RMF25(MVT) !leaf maintenance respiration at 25c (umol co2/m**2/s) + REAL(rkind) :: RMS25(MVT) !stem maintenance respiration at 25c (umol co2/kg bio/s) + REAL(rkind) :: RMR25(MVT) !root maintenance respiration at 25c (umol co2/kg bio/s) + REAL(rkind) :: ARM(MVT) !q10 for maintenance respiration + REAL(rkind) :: FOLNMX(MVT) !foliage nitrogen concentration when f(n)=1 (%) + REAL(rkind) :: TMIN(MVT) !minimum temperature for photosynthesis (k) + + REAL(rkind) :: XL(MVT) !leaf/stem orientation index + REAL(rkind) :: RHOL(MVT,MBAND) !leaf reflectance: 1=vis, 2=nir + REAL(rkind) :: RHOS(MVT,MBAND) !stem reflectance: 1=vis, 2=nir + REAL(rkind) :: TAUL(MVT,MBAND) !leaf transmittance: 1=vis, 2=nir + REAL(rkind) :: TAUS(MVT,MBAND) !stem transmittance: 1=vis, 2=nir + + REAL(rkind) :: MRP(MVT) !microbial respiration parameter (umol co2 /kg c/ s) + REAL(rkind) :: CWPVT(MVT) !empirical canopy wind parameter + + REAL(rkind) :: WRRAT(MVT) !wood to non-wood ratio + REAL(rkind) :: WDPOOL(MVT) !wood pool (switch 1 or 0) depending on woody or not [-] + REAL(rkind) :: TDLEF(MVT) !characteristic T for leaf freezing [K] INTEGER :: IK,IM - REAL :: TMP10(MVT*MBAND) - REAL :: TMP11(MVT*MBAND) - REAL :: TMP12(MVT*MBAND) - REAL :: TMP13(MVT*MBAND) - REAL :: TMP14(MVT*12) - REAL :: TMP15(MVT*12) - REAL :: TMP16(MVT*5) + REAL(rkind) :: TMP10(MVT*MBAND) + REAL(rkind) :: TMP11(MVT*MBAND) + REAL(rkind) :: TMP12(MVT*MBAND) + REAL(rkind) :: TMP13(MVT*MBAND) + REAL(rkind) :: TMP14(MVT*12) + REAL(rkind) :: TMP15(MVT*12) + REAL(rkind) :: TMP16(MVT*5) - real slarea(MVT) - real eps(MVT,5) + real(rkind) slarea(MVT) + real(rkind) eps(MVT,5) CONTAINS subroutine read_mp_veg_parameters(FILENAME_VEGTABLE,DATASET_IDENTIFIER) @@ -279,13 +280,13 @@ subroutine read_mp_veg_parameters(FILENAME_VEGTABLE,DATASET_IDENTIFIER) integer :: ierr ! Temporary arrays used in reshaping namelist arrays - REAL :: TMP10(MVT*MBAND) - REAL :: TMP11(MVT*MBAND) - REAL :: TMP12(MVT*MBAND) - REAL :: TMP13(MVT*MBAND) - REAL :: TMP14(MVT*12) - REAL :: TMP15(MVT*12) - REAL :: TMP16(MVT*5) + REAL(rkind) :: TMP10(MVT*MBAND) + REAL(rkind) :: TMP11(MVT*MBAND) + REAL(rkind) :: TMP12(MVT*MBAND) + REAL(rkind) :: TMP13(MVT*MBAND) + REAL(rkind) :: TMP14(MVT*12) + REAL(rkind) :: TMP15(MVT*12) + REAL(rkind) :: TMP16(MVT*5) integer :: NVEG character(len=256) :: VEG_DATASET_DESCRIPTION @@ -439,6 +440,7 @@ END MODULE NOAHMP_VEG_PARAMETERS ! ================================================================================================== ! ================================================================================================== MODULE NOAHMP_RAD_PARAMETERS + use nrtype IMPLICIT NONE @@ -446,14 +448,14 @@ MODULE NOAHMP_RAD_PARAMETERS INTEGER, PARAMETER :: MSC = 9 INTEGER, PARAMETER :: MBAND = 2 - REAL :: ALBSAT(MSC,MBAND) !saturated soil albedos: 1=vis, 2=nir - REAL :: ALBDRY(MSC,MBAND) !dry soil albedos: 1=vis, 2=nir - REAL :: ALBICE(MBAND) !albedo land ice: 1=vis, 2=nir - REAL :: ALBLAK(MBAND) !albedo frozen lakes: 1=vis, 2=nir - REAL :: OMEGAS(MBAND) !two-stream parameter omega for snow - REAL :: BETADS !two-stream parameter betad for snow - REAL :: BETAIS !two-stream parameter betad for snow - REAL :: EG(2) !emissivity + REAL(rkind) :: ALBSAT(MSC,MBAND) !saturated soil albedos: 1=vis, 2=nir + REAL(rkind) :: ALBDRY(MSC,MBAND) !dry soil albedos: 1=vis, 2=nir + REAL(rkind) :: ALBICE(MBAND) !albedo land ice: 1=vis, 2=nir + REAL(rkind) :: ALBLAK(MBAND) !albedo frozen lakes: 1=vis, 2=nir + REAL(rkind) :: OMEGAS(MBAND) !two-stream parameter omega for snow + REAL(rkind) :: BETADS !two-stream parameter betad for snow + REAL(rkind) :: BETAIS !two-stream parameter betad for snow + REAL(rkind) :: EG(2) !emissivity ! saturated soil albedos: 1=vis, 2=nir DATA(ALBSAT(I,1),I=1,8)/0.15,0.11,0.10,0.09,0.08,0.07,0.06,0.05/ @@ -480,6 +482,7 @@ END MODULE NOAHMP_RAD_PARAMETERS ! ================================================================================================== MODULE NOAHMP_ROUTINES + use nrtype USE NOAHMP_GLOBALS IMPLICIT NONE @@ -515,33 +518,33 @@ SUBROUTINE PHENOLOGY (VEGTYP , ISURBAN, SNOWH , TV , LAT , YEARLEN , JULI ! inputs INTEGER , INTENT(IN ) :: VEGTYP !vegetation type INTEGER , INTENT(IN ) :: ISURBAN!urban category - REAL , INTENT(IN ) :: SNOWH !snow height [m] - REAL , INTENT(IN ) :: TV !vegetation temperature (k) - REAL , INTENT(IN ) :: LAT !latitude (radians) + REAL(rkind) , INTENT(IN ) :: SNOWH !snow height [m] + REAL(rkind) , INTENT(IN ) :: TV !vegetation temperature (k) + REAL(rkind) , INTENT(IN ) :: LAT !latitude (radians) INTEGER , INTENT(IN ) :: YEARLEN!Number of days in the particular year - REAL , INTENT(IN ) :: JULIAN !Julian day of year (fractional) ( 0 <= JULIAN < YEARLEN ) - real , INTENT(IN ) :: TROOT !root-zone averaged temperature (k) - REAL , INTENT(INOUT) :: LAI !LAI, unadjusted for burying by snow - REAL , INTENT(INOUT) :: SAI !SAI, unadjusted for burying by snow + REAL(rkind) , INTENT(IN ) :: JULIAN !Julian day of year (fractional) ( 0 <= JULIAN < YEARLEN ) + real(rkind) , INTENT(IN ) :: TROOT !root-zone averaged temperature (k) + REAL(rkind) , INTENT(INOUT) :: LAI !LAI, unadjusted for burying by snow + REAL(rkind) , INTENT(INOUT) :: SAI !SAI, unadjusted for burying by snow ! outputs - REAL , INTENT(OUT ) :: HTOP !top of canopy layer (m) - REAL , INTENT(OUT ) :: ELAI !leaf area index, after burying by snow - REAL , INTENT(OUT ) :: ESAI !stem area index, after burying by snow - REAL , INTENT(OUT ) :: IGS !growing season index (0=off, 1=on) + REAL(rkind) , INTENT(OUT ) :: HTOP !top of canopy layer (m) + REAL(rkind) , INTENT(OUT ) :: ELAI !leaf area index, after burying by snow + REAL(rkind) , INTENT(OUT ) :: ESAI !stem area index, after burying by snow + REAL(rkind) , INTENT(OUT ) :: IGS !growing season index (0=off, 1=on) ! locals - REAL :: DB !thickness of canopy buried by snow (m) - REAL :: FB !fraction of canopy buried by snow - REAL :: SNOWHC !critical snow depth at which short vege + REAL(rkind) :: DB !thickness of canopy buried by snow (m) + REAL(rkind) :: FB !fraction of canopy buried by snow + REAL(rkind) :: SNOWHC !critical snow depth at which short vege !is fully covered by snow INTEGER :: K !index INTEGER :: IT1,IT2 !interpolation months - REAL :: DAY !current day of year ( 0 <= DAY < YEARLEN ) - REAL :: WT1,WT2 !interpolation weights - REAL :: T !current month (1.00, ..., 12.00) + REAL(rkind) :: DAY !current day of year ( 0 <= DAY < YEARLEN ) + REAL(rkind) :: WT1,WT2 !interpolation weights + REAL(rkind) :: T !current month (1.00, ..., 12.00) ! -------------------------------------------------------------------------------------------------- IF ( DVEG == 1 .or. DVEG == 3 .or. DVEG == 4 ) THEN @@ -626,67 +629,67 @@ SUBROUTINE RADIATION (VEGTYP ,IST ,ISC ,ICE ,NSOIL , & !in INTEGER, INTENT(IN) :: ICE !ice (ice = 1) INTEGER, INTENT(IN) :: NSOIL !number of soil layers - REAL, INTENT(IN) :: DT !time step [s] - REAL, INTENT(IN) :: QSNOW !snowfall (mm/s) - REAL, INTENT(IN) :: SNEQVO !snow mass at last time step(mm) - REAL, INTENT(IN) :: SNEQV !snow mass (mm) - REAL, INTENT(IN) :: SNOWH !snow height (mm) - REAL, INTENT(IN) :: COSZ !cosine solar zenith angle (0-1) - REAL, INTENT(IN) :: TG !ground temperature (k) - REAL, INTENT(IN) :: TV !vegetation temperature (k) - REAL, INTENT(IN) :: ELAI !LAI, one-sided, adjusted for burying by snow - REAL, INTENT(IN) :: ESAI !SAI, one-sided, adjusted for burying by snow - REAL, INTENT(IN) :: FWET !fraction of canopy that is wet - REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SMC !volumetric soil water [m3/m3] - REAL, DIMENSION(1:2) , INTENT(IN) :: SOLAD !incoming direct solar radiation (w/m2) - REAL, DIMENSION(1:2) , INTENT(IN) :: SOLAI !incoming diffuse solar radiation (w/m2) - REAL, INTENT(IN) :: FSNO !snow cover fraction (-) - REAL, INTENT(IN) :: FVEG !green vegetation fraction [0.0-1.0] + REAL(rkind), INTENT(IN) :: DT !time step [s] + REAL(rkind), INTENT(IN) :: QSNOW !snowfall (mm/s) + REAL(rkind), INTENT(IN) :: SNEQVO !snow mass at last time step(mm) + REAL(rkind), INTENT(IN) :: SNEQV !snow mass (mm) + REAL(rkind), INTENT(IN) :: SNOWH !snow height (mm) + REAL(rkind), INTENT(IN) :: COSZ !cosine solar zenith angle (0-1) + REAL(rkind), INTENT(IN) :: TG !ground temperature (k) + REAL(rkind), INTENT(IN) :: TV !vegetation temperature (k) + REAL(rkind), INTENT(IN) :: ELAI !LAI, one-sided, adjusted for burying by snow + REAL(rkind), INTENT(IN) :: ESAI !SAI, one-sided, adjusted for burying by snow + REAL(rkind), INTENT(IN) :: FWET !fraction of canopy that is wet + REAL(rkind), DIMENSION(1:NSOIL), INTENT(IN) :: SMC !volumetric soil water [m3/m3] + REAL(rkind), DIMENSION(1:2) , INTENT(IN) :: SOLAD !incoming direct solar radiation (w/m2) + REAL(rkind), DIMENSION(1:2) , INTENT(IN) :: SOLAI !incoming diffuse solar radiation (w/m2) + REAL(rkind), INTENT(IN) :: FSNO !snow cover fraction (-) + REAL(rkind), INTENT(IN) :: FVEG !green vegetation fraction [0.0-1.0] ! inout - REAL, INTENT(INOUT) :: ALBOLD !snow albedo at last time step (CLASS type) - REAL, INTENT(INOUT) :: TAUSS !non-dimensional snow age. + REAL(rkind), INTENT(INOUT) :: ALBOLD !snow albedo at last time step (CLASS type) + REAL(rkind), INTENT(INOUT) :: TAUSS !non-dimensional snow age. ! output - REAL, INTENT(OUT) :: FSUN !sunlit fraction of canopy (-) - REAL, INTENT(OUT) :: LAISUN !sunlit leaf area (-) - REAL, INTENT(OUT) :: LAISHA !shaded leaf area (-) - REAL, INTENT(OUT) :: PARSUN !average absorbed par for sunlit leaves (w/m2) - REAL, INTENT(OUT) :: PARSHA !average absorbed par for shaded leaves (w/m2) - REAL, INTENT(OUT) :: SAV !solar radiation absorbed by vegetation (w/m2) - REAL, INTENT(OUT) :: SAG !solar radiation absorbed by ground (w/m2) - REAL, INTENT(OUT) :: FSA !total absorbed solar radiation (w/m2) - REAL, INTENT(OUT) :: FSR !total reflected solar radiation (w/m2) + REAL(rkind), INTENT(OUT) :: FSUN !sunlit fraction of canopy (-) + REAL(rkind), INTENT(OUT) :: LAISUN !sunlit leaf area (-) + REAL(rkind), INTENT(OUT) :: LAISHA !shaded leaf area (-) + REAL(rkind), INTENT(OUT) :: PARSUN !average absorbed par for sunlit leaves (w/m2) + REAL(rkind), INTENT(OUT) :: PARSHA !average absorbed par for shaded leaves (w/m2) + REAL(rkind), INTENT(OUT) :: SAV !solar radiation absorbed by vegetation (w/m2) + REAL(rkind), INTENT(OUT) :: SAG !solar radiation absorbed by ground (w/m2) + REAL(rkind), INTENT(OUT) :: FSA !total absorbed solar radiation (w/m2) + REAL(rkind), INTENT(OUT) :: FSR !total reflected solar radiation (w/m2) !jref:start - REAL, INTENT(OUT) :: FSRV !veg. reflected solar radiation (w/m2) - REAL, INTENT(OUT) :: FSRG !ground reflected solar radiation (w/m2) - REAL, INTENT(OUT) :: BGAP - REAL, INTENT(OUT) :: WGAP + REAL(rkind), INTENT(OUT) :: FSRV !veg. reflected solar radiation (w/m2) + REAL(rkind), INTENT(OUT) :: FSRG !ground reflected solar radiation (w/m2) + REAL(rkind), INTENT(OUT) :: BGAP + REAL(rkind), INTENT(OUT) :: WGAP !jref:end ! local - REAL :: FAGE !snow age function (0 - new snow) - REAL, DIMENSION(1:2) :: ALBGRD !ground albedo (direct) - REAL, DIMENSION(1:2) :: ALBGRI !ground albedo (diffuse) - REAL, DIMENSION(1:2) :: ALBD !surface albedo (direct) - REAL, DIMENSION(1:2) :: ALBI !surface albedo (diffuse) - REAL, DIMENSION(1:2) :: FABD !flux abs by veg (per unit direct flux) - REAL, DIMENSION(1:2) :: FABI !flux abs by veg (per unit diffuse flux) - REAL, DIMENSION(1:2) :: FTDD !down direct flux below veg (per unit dir flux) - REAL, DIMENSION(1:2) :: FTID !down diffuse flux below veg (per unit dir flux) - REAL, DIMENSION(1:2) :: FTII !down diffuse flux below veg (per unit dif flux) + REAL(rkind) :: FAGE !snow age function (0 - new snow) + REAL(rkind), DIMENSION(1:2) :: ALBGRD !ground albedo (direct) + REAL(rkind), DIMENSION(1:2) :: ALBGRI !ground albedo (diffuse) + REAL(rkind), DIMENSION(1:2) :: ALBD !surface albedo (direct) + REAL(rkind), DIMENSION(1:2) :: ALBI !surface albedo (diffuse) + REAL(rkind), DIMENSION(1:2) :: FABD !flux abs by veg (per unit direct flux) + REAL(rkind), DIMENSION(1:2) :: FABI !flux abs by veg (per unit diffuse flux) + REAL(rkind), DIMENSION(1:2) :: FTDD !down direct flux below veg (per unit dir flux) + REAL(rkind), DIMENSION(1:2) :: FTID !down diffuse flux below veg (per unit dir flux) + REAL(rkind), DIMENSION(1:2) :: FTII !down diffuse flux below veg (per unit dif flux) !jref:start - REAL, DIMENSION(1:2) :: FREVI - REAL, DIMENSION(1:2) :: FREVD - REAL, DIMENSION(1:2) :: FREGI - REAL, DIMENSION(1:2) :: FREGD + REAL(rkind), DIMENSION(1:2) :: FREVI + REAL(rkind), DIMENSION(1:2) :: FREVD + REAL(rkind), DIMENSION(1:2) :: FREGI + REAL(rkind), DIMENSION(1:2) :: FREGD !jref:end - REAL :: FSHA !shaded fraction of canopy - REAL :: VAI !total LAI + stem area index, one sided + REAL(rkind) :: FSHA !shaded fraction of canopy + REAL(rkind) :: VAI !total LAI + stem area index, one sided - REAL,PARAMETER :: MPE = 1.E-6 + REAL(rkind),PARAMETER :: MPE = 1.E-6 LOGICAL VEG !true: vegetated for surface temperature calculation ! -------------------------------------------------------------------------------------------------- @@ -757,67 +760,67 @@ SUBROUTINE ALBEDO (VEGTYP ,IST ,ISC ,ICE ,NSOIL , & !in INTEGER, INTENT(IN) :: ISC !soil color type (1-lighest; 8-darkest) INTEGER, INTENT(IN) :: ICE !ice (ice = 1) - REAL, INTENT(IN) :: DT !time step [sec] - REAL, INTENT(IN) :: QSNOW !snowfall - REAL, INTENT(IN) :: COSZ !cosine solar zenith angle for next time step - REAL, INTENT(IN) :: SNOWH !snow height (mm) - REAL, INTENT(IN) :: TG !ground temperature (k) - REAL, INTENT(IN) :: TV !vegetation temperature (k) - REAL, INTENT(IN) :: ELAI !LAI, one-sided, adjusted for burying by snow - REAL, INTENT(IN) :: ESAI !SAI, one-sided, adjusted for burying by snow - REAL, INTENT(IN) :: FSNO !fraction of grid covered by snow - REAL, INTENT(IN) :: FWET !fraction of canopy that is wet - REAL, INTENT(IN) :: SNEQVO !snow mass at last time step(mm) - REAL, INTENT(IN) :: SNEQV !snow mass (mm) - REAL, INTENT(IN) :: FVEG !green vegetation fraction [0.0-1.0] - REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SMC !volumetric soil water (m3/m3) + REAL(rkind), INTENT(IN) :: DT !time step [sec] + REAL(rkind), INTENT(IN) :: QSNOW !snowfall + REAL(rkind), INTENT(IN) :: COSZ !cosine solar zenith angle for next time step + REAL(rkind), INTENT(IN) :: SNOWH !snow height (mm) + REAL(rkind), INTENT(IN) :: TG !ground temperature (k) + REAL(rkind), INTENT(IN) :: TV !vegetation temperature (k) + REAL(rkind), INTENT(IN) :: ELAI !LAI, one-sided, adjusted for burying by snow + REAL(rkind), INTENT(IN) :: ESAI !SAI, one-sided, adjusted for burying by snow + REAL(rkind), INTENT(IN) :: FSNO !fraction of grid covered by snow + REAL(rkind), INTENT(IN) :: FWET !fraction of canopy that is wet + REAL(rkind), INTENT(IN) :: SNEQVO !snow mass at last time step(mm) + REAL(rkind), INTENT(IN) :: SNEQV !snow mass (mm) + REAL(rkind), INTENT(IN) :: FVEG !green vegetation fraction [0.0-1.0] + REAL(rkind), DIMENSION(1:NSOIL), INTENT(IN) :: SMC !volumetric soil water (m3/m3) ! inout - REAL, INTENT(INOUT) :: ALBOLD !snow albedo at last time step (CLASS type) - REAL, INTENT(INOUT) :: TAUSS !non-dimensional snow age + REAL(rkind), INTENT(INOUT) :: ALBOLD !snow albedo at last time step (CLASS type) + REAL(rkind), INTENT(INOUT) :: TAUSS !non-dimensional snow age ! output - REAL, DIMENSION(1: 2), INTENT(OUT) :: ALBGRD !ground albedo (direct) - REAL, DIMENSION(1: 2), INTENT(OUT) :: ALBGRI !ground albedo (diffuse) - REAL, DIMENSION(1: 2), INTENT(OUT) :: ALBD !surface albedo (direct) - REAL, DIMENSION(1: 2), INTENT(OUT) :: ALBI !surface albedo (diffuse) - REAL, DIMENSION(1: 2), INTENT(OUT) :: FABD !flux abs by veg (per unit direct flux) - REAL, DIMENSION(1: 2), INTENT(OUT) :: FABI !flux abs by veg (per unit diffuse flux) - REAL, DIMENSION(1: 2), INTENT(OUT) :: FTDD !down direct flux below veg (per unit dir flux) - REAL, DIMENSION(1: 2), INTENT(OUT) :: FTID !down diffuse flux below veg (per unit dir flux) - REAL, DIMENSION(1: 2), INTENT(OUT) :: FTII !down diffuse flux below veg (per unit dif flux) - REAL, INTENT(OUT) :: FSUN !sunlit fraction of canopy (-) + REAL(rkind), DIMENSION(1: 2), INTENT(OUT) :: ALBGRD !ground albedo (direct) + REAL(rkind), DIMENSION(1: 2), INTENT(OUT) :: ALBGRI !ground albedo (diffuse) + REAL(rkind), DIMENSION(1: 2), INTENT(OUT) :: ALBD !surface albedo (direct) + REAL(rkind), DIMENSION(1: 2), INTENT(OUT) :: ALBI !surface albedo (diffuse) + REAL(rkind), DIMENSION(1: 2), INTENT(OUT) :: FABD !flux abs by veg (per unit direct flux) + REAL(rkind), DIMENSION(1: 2), INTENT(OUT) :: FABI !flux abs by veg (per unit diffuse flux) + REAL(rkind), DIMENSION(1: 2), INTENT(OUT) :: FTDD !down direct flux below veg (per unit dir flux) + REAL(rkind), DIMENSION(1: 2), INTENT(OUT) :: FTID !down diffuse flux below veg (per unit dir flux) + REAL(rkind), DIMENSION(1: 2), INTENT(OUT) :: FTII !down diffuse flux below veg (per unit dif flux) + REAL(rkind), INTENT(OUT) :: FSUN !sunlit fraction of canopy (-) !jref:start - REAL, DIMENSION(1: 2), INTENT(OUT) :: FREVD - REAL, DIMENSION(1: 2), INTENT(OUT) :: FREVI - REAL, DIMENSION(1: 2), INTENT(OUT) :: FREGD - REAL, DIMENSION(1: 2), INTENT(OUT) :: FREGI - REAL, INTENT(OUT) :: BGAP - REAL, INTENT(OUT) :: WGAP + REAL(rkind), DIMENSION(1: 2), INTENT(OUT) :: FREVD + REAL(rkind), DIMENSION(1: 2), INTENT(OUT) :: FREVI + REAL(rkind), DIMENSION(1: 2), INTENT(OUT) :: FREGD + REAL(rkind), DIMENSION(1: 2), INTENT(OUT) :: FREGI + REAL(rkind), INTENT(OUT) :: BGAP + REAL(rkind), INTENT(OUT) :: WGAP !jref:end ! ------------------------------------------------------------------------ ! ------------------------ local variables ------------------------------- ! local - REAL :: FAGE !snow age function - REAL :: ALB + REAL(rkind) :: FAGE !snow age function + REAL(rkind) :: ALB INTEGER :: IB !indices INTEGER :: NBAND !number of solar radiation wave bands INTEGER :: IC !direct beam: ic=0; diffuse: ic=1 - REAL :: WL !fraction of LAI+SAI that is LAI - REAL :: WS !fraction of LAI+SAI that is SAI - REAL :: MPE !prevents overflow for division by zero + REAL(rkind) :: WL !fraction of LAI+SAI that is LAI + REAL(rkind) :: WS !fraction of LAI+SAI that is SAI + REAL(rkind) :: MPE !prevents overflow for division by zero - REAL, DIMENSION(1:2) :: RHO !leaf/stem reflectance weighted by fraction LAI and SAI - REAL, DIMENSION(1:2) :: TAU !leaf/stem transmittance weighted by fraction LAI and SAI - REAL, DIMENSION(1:2) :: FTDI !down direct flux below veg per unit dif flux = 0 - REAL, DIMENSION(1:2) :: ALBSND !snow albedo (direct) - REAL, DIMENSION(1:2) :: ALBSNI !snow albedo (diffuse) + REAL(rkind), DIMENSION(1:2) :: RHO !leaf/stem reflectance weighted by fraction LAI and SAI + REAL(rkind), DIMENSION(1:2) :: TAU !leaf/stem transmittance weighted by fraction LAI and SAI + REAL(rkind), DIMENSION(1:2) :: FTDI !down direct flux below veg per unit dif flux = 0 + REAL(rkind), DIMENSION(1:2) :: ALBSND !snow albedo (direct) + REAL(rkind), DIMENSION(1:2) :: ALBSNI !snow albedo (diffuse) - REAL :: VAI !ELAI+ESAI - REAL :: GDIR !average projected leaf/stem area in solar direction - REAL :: EXT !optical depth direct beam per unit leaf + stem area + REAL(rkind) :: VAI !ELAI+ESAI + REAL(rkind) :: GDIR !average projected leaf/stem area in solar direction + REAL(rkind) :: EXT !optical depth direct beam per unit leaf + stem area ! -------------------------------------------------------------------------------------------------- @@ -928,55 +931,55 @@ SUBROUTINE SURRAD (MPE ,FSUN ,FSHA ,ELAI ,VAI , & !in INTEGER, INTENT(IN) :: ILOC INTEGER, INTENT(IN) :: JLOC - REAL, INTENT(IN) :: MPE !prevents underflow errors if division by zero - - REAL, INTENT(IN) :: FSUN !sunlit fraction of canopy - REAL, INTENT(IN) :: FSHA !shaded fraction of canopy - REAL, INTENT(IN) :: ELAI !leaf area, one-sided - REAL, INTENT(IN) :: VAI !leaf + stem area, one-sided - REAL, INTENT(IN) :: LAISUN !sunlit leaf area index, one-sided - REAL, INTENT(IN) :: LAISHA !shaded leaf area index, one-sided - - REAL, DIMENSION(1:2), INTENT(IN) :: SOLAD !incoming direct solar radiation (w/m2) - REAL, DIMENSION(1:2), INTENT(IN) :: SOLAI !incoming diffuse solar radiation (w/m2) - REAL, DIMENSION(1:2), INTENT(IN) :: FABD !flux abs by veg (per unit incoming direct flux) - REAL, DIMENSION(1:2), INTENT(IN) :: FABI !flux abs by veg (per unit incoming diffuse flux) - REAL, DIMENSION(1:2), INTENT(IN) :: FTDD !down dir flux below veg (per incoming dir flux) - REAL, DIMENSION(1:2), INTENT(IN) :: FTID !down dif flux below veg (per incoming dir flux) - REAL, DIMENSION(1:2), INTENT(IN) :: FTII !down dif flux below veg (per incoming dif flux) - REAL, DIMENSION(1:2), INTENT(IN) :: ALBGRD !ground albedo (direct) - REAL, DIMENSION(1:2), INTENT(IN) :: ALBGRI !ground albedo (diffuse) - REAL, DIMENSION(1:2), INTENT(IN) :: ALBD !overall surface albedo (direct) - REAL, DIMENSION(1:2), INTENT(IN) :: ALBI !overall surface albedo (diffuse) - - REAL, DIMENSION(1:2), INTENT(IN) :: FREVD !overall surface albedo veg (direct) - REAL, DIMENSION(1:2), INTENT(IN) :: FREVI !overall surface albedo veg (diffuse) - REAL, DIMENSION(1:2), INTENT(IN) :: FREGD !overall surface albedo grd (direct) - REAL, DIMENSION(1:2), INTENT(IN) :: FREGI !overall surface albedo grd (diffuse) + REAL(rkind), INTENT(IN) :: MPE !prevents underflow errors if division by zero + + REAL(rkind), INTENT(IN) :: FSUN !sunlit fraction of canopy + REAL(rkind), INTENT(IN) :: FSHA !shaded fraction of canopy + REAL(rkind), INTENT(IN) :: ELAI !leaf area, one-sided + REAL(rkind), INTENT(IN) :: VAI !leaf + stem area, one-sided + REAL(rkind), INTENT(IN) :: LAISUN !sunlit leaf area index, one-sided + REAL(rkind), INTENT(IN) :: LAISHA !shaded leaf area index, one-sided + + REAL(rkind), DIMENSION(1:2), INTENT(IN) :: SOLAD !incoming direct solar radiation (w/m2) + REAL(rkind), DIMENSION(1:2), INTENT(IN) :: SOLAI !incoming diffuse solar radiation (w/m2) + REAL(rkind), DIMENSION(1:2), INTENT(IN) :: FABD !flux abs by veg (per unit incoming direct flux) + REAL(rkind), DIMENSION(1:2), INTENT(IN) :: FABI !flux abs by veg (per unit incoming diffuse flux) + REAL(rkind), DIMENSION(1:2), INTENT(IN) :: FTDD !down dir flux below veg (per incoming dir flux) + REAL(rkind), DIMENSION(1:2), INTENT(IN) :: FTID !down dif flux below veg (per incoming dir flux) + REAL(rkind), DIMENSION(1:2), INTENT(IN) :: FTII !down dif flux below veg (per incoming dif flux) + REAL(rkind), DIMENSION(1:2), INTENT(IN) :: ALBGRD !ground albedo (direct) + REAL(rkind), DIMENSION(1:2), INTENT(IN) :: ALBGRI !ground albedo (diffuse) + REAL(rkind), DIMENSION(1:2), INTENT(IN) :: ALBD !overall surface albedo (direct) + REAL(rkind), DIMENSION(1:2), INTENT(IN) :: ALBI !overall surface albedo (diffuse) + + REAL(rkind), DIMENSION(1:2), INTENT(IN) :: FREVD !overall surface albedo veg (direct) + REAL(rkind), DIMENSION(1:2), INTENT(IN) :: FREVI !overall surface albedo veg (diffuse) + REAL(rkind), DIMENSION(1:2), INTENT(IN) :: FREGD !overall surface albedo grd (direct) + REAL(rkind), DIMENSION(1:2), INTENT(IN) :: FREGI !overall surface albedo grd (diffuse) ! output - REAL, INTENT(OUT) :: PARSUN !average absorbed par for sunlit leaves (w/m2) - REAL, INTENT(OUT) :: PARSHA !average absorbed par for shaded leaves (w/m2) - REAL, INTENT(OUT) :: SAV !solar radiation absorbed by vegetation (w/m2) - REAL, INTENT(OUT) :: SAG !solar radiation absorbed by ground (w/m2) - REAL, INTENT(OUT) :: FSA !total absorbed solar radiation (w/m2) - REAL, INTENT(OUT) :: FSR !total reflected solar radiation (w/m2) - REAL, INTENT(OUT) :: FSRV !reflected solar radiation by vegetation - REAL, INTENT(OUT) :: FSRG !reflected solar radiation by ground + REAL(rkind), INTENT(OUT) :: PARSUN !average absorbed par for sunlit leaves (w/m2) + REAL(rkind), INTENT(OUT) :: PARSHA !average absorbed par for shaded leaves (w/m2) + REAL(rkind), INTENT(OUT) :: SAV !solar radiation absorbed by vegetation (w/m2) + REAL(rkind), INTENT(OUT) :: SAG !solar radiation absorbed by ground (w/m2) + REAL(rkind), INTENT(OUT) :: FSA !total absorbed solar radiation (w/m2) + REAL(rkind), INTENT(OUT) :: FSR !total reflected solar radiation (w/m2) + REAL(rkind), INTENT(OUT) :: FSRV !reflected solar radiation by vegetation + REAL(rkind), INTENT(OUT) :: FSRG !reflected solar radiation by ground ! ------------------------ local variables ---------------------------------------------------- INTEGER :: IB !waveband number (1=vis, 2=nir) INTEGER :: NBAND !number of solar radiation waveband classes - REAL :: ABS !absorbed solar radiation (w/m2) - REAL :: RNIR !reflected solar radiation [nir] (w/m2) - REAL :: RVIS !reflected solar radiation [vis] (w/m2) - REAL :: LAIFRA !leaf area fraction of canopy - REAL :: TRD !transmitted solar radiation: direct (w/m2) - REAL :: TRI !transmitted solar radiation: diffuse (w/m2) - REAL, DIMENSION(1:2) :: CAD !direct beam absorbed by canopy (w/m2) - REAL, DIMENSION(1:2) :: CAI !diffuse radiation absorbed by canopy (w/m2) + REAL(rkind) :: ABS !absorbed solar radiation (w/m2) + REAL(rkind) :: RNIR !reflected solar radiation [nir] (w/m2) + REAL(rkind) :: RVIS !reflected solar radiation [vis] (w/m2) + REAL(rkind) :: LAIFRA !leaf area fraction of canopy + REAL(rkind) :: TRD !transmitted solar radiation: direct (w/m2) + REAL(rkind) :: TRI !transmitted solar radiation: diffuse (w/m2) + REAL(rkind), DIMENSION(1:2) :: CAD !direct beam absorbed by canopy (w/m2) + REAL(rkind), DIMENSION(1:2) :: CAI !diffuse radiation absorbed by canopy (w/m2) ! --------------------------------------------------------------------------------------------- NBAND = 2 @@ -1041,26 +1044,26 @@ SUBROUTINE SNOW_AGE (DT,TG,SNEQVO,SNEQV,TAUSS,FAGE) ! from BATS ! ------------------------ input/output variables -------------------------------------------------- !input - REAL, INTENT(IN) :: DT !main time step (s) - REAL, INTENT(IN) :: TG !ground temperature (k) - REAL, INTENT(IN) :: SNEQVO !snow mass at last time step(mm) - REAL, INTENT(IN) :: SNEQV !snow water per unit ground area (mm) + REAL(rkind), INTENT(IN) :: DT !main time step (s) + REAL(rkind), INTENT(IN) :: TG !ground temperature (k) + REAL(rkind), INTENT(IN) :: SNEQVO !snow mass at last time step(mm) + REAL(rkind), INTENT(IN) :: SNEQV !snow water per unit ground area (mm) !output - REAL, INTENT(OUT) :: FAGE !snow age + REAL(rkind), INTENT(OUT) :: FAGE !snow age !input/output - REAL, INTENT(INOUT) :: TAUSS !non-dimensional snow age + REAL(rkind), INTENT(INOUT) :: TAUSS !non-dimensional snow age !local - REAL :: TAGE !total aging effects - REAL :: AGE1 !effects of grain growth due to vapor diffusion - REAL :: AGE2 !effects of grain growth at freezing of melt water - REAL :: AGE3 !effects of soot - REAL :: DELA !temporary variable - REAL :: SGE !temporary variable - REAL :: DELS !temporary variable - REAL :: DELA0 !temporary variable - REAL :: ARG !temporary variable + REAL(rkind) :: TAGE !total aging effects + REAL(rkind) :: AGE1 !effects of grain growth due to vapor diffusion + REAL(rkind) :: AGE2 !effects of grain growth at freezing of melt water + REAL(rkind) :: AGE3 !effects of soot + REAL(rkind) :: DELA !temporary variable + REAL(rkind) :: SGE !temporary variable + REAL(rkind) :: DELS !temporary variable + REAL(rkind) :: DELA0 !temporary variable + REAL(rkind) :: ARG !temporary variable ! See Yang et al. (1997) J.of Climate for detail. !--------------------------------------------------------------------------------------------------- @@ -1095,28 +1098,28 @@ SUBROUTINE SNOWALB_BATS (NBAND,FSNO,COSZ,FAGE,ALBSND,ALBSNI) INTEGER,INTENT(IN) :: NBAND !number of waveband classes - REAL,INTENT(IN) :: COSZ !cosine solar zenith angle - REAL,INTENT(IN) :: FSNO !snow cover fraction (-) - REAL,INTENT(IN) :: FAGE !snow age correction + REAL(rkind),INTENT(IN) :: COSZ !cosine solar zenith angle + REAL(rkind),INTENT(IN) :: FSNO !snow cover fraction (-) + REAL(rkind),INTENT(IN) :: FAGE !snow age correction ! output - REAL, DIMENSION(1:2),INTENT(OUT) :: ALBSND !snow albedo for direct(1=vis, 2=nir) - REAL, DIMENSION(1:2),INTENT(OUT) :: ALBSNI !snow albedo for diffuse + REAL(rkind), DIMENSION(1:2),INTENT(OUT) :: ALBSND !snow albedo for direct(1=vis, 2=nir) + REAL(rkind), DIMENSION(1:2),INTENT(OUT) :: ALBSNI !snow albedo for diffuse ! --------------------------------------------------------------------------------------------- ! ------------------------ local variables ---------------------------------------------------- INTEGER :: IB !waveband class - REAL :: FZEN !zenith angle correction - REAL :: CF1 !temperary variable - REAL :: SL2 !2.*SL - REAL :: SL1 !1/SL - REAL :: SL !adjustable parameter - REAL, PARAMETER :: C1 = 0.2 !default in BATS - REAL, PARAMETER :: C2 = 0.5 !default in BATS -! REAL, PARAMETER :: C1 = 0.2 * 2. ! double the default to match Sleepers River's -! REAL, PARAMETER :: C2 = 0.5 * 2. ! snow surface albedo (double aging effects) + REAL(rkind) :: FZEN !zenith angle correction + REAL(rkind) :: CF1 !temperary variable + REAL(rkind) :: SL2 !2.*SL + REAL(rkind) :: SL1 !1/SL + REAL(rkind) :: SL !adjustable parameter + REAL(rkind), PARAMETER :: C1 = 0.2 !default in BATS + REAL(rkind), PARAMETER :: C2 = 0.5 !default in BATS +! REAL(rkind), PARAMETER :: C1 = 0.2 * 2. ! double the default to match Sleepers River's +! REAL(rkind), PARAMETER :: C2 = 0.5 * 2. ! snow surface albedo (double aging effects) ! --------------------------------------------------------------------------------------------- ! zero albedos for all points @@ -1150,17 +1153,17 @@ SUBROUTINE SNOWALB_CLASS (NBAND,QSNOW,DT,ALB,ALBOLD,ALBSND,ALBSNI,ILOC,JLOC) INTEGER,INTENT(IN) :: JLOC !grid index INTEGER,INTENT(IN) :: NBAND !number of waveband classes - REAL,INTENT(IN) :: QSNOW !snowfall (mm/s) - REAL,INTENT(IN) :: DT !time step (sec) - REAL,INTENT(IN) :: ALBOLD !snow albedo at last time step + REAL(rkind),INTENT(IN) :: QSNOW !snowfall (mm/s) + REAL(rkind),INTENT(IN) :: DT !time step (sec) + REAL(rkind),INTENT(IN) :: ALBOLD !snow albedo at last time step ! in & out - REAL, INTENT(INOUT) :: ALB ! + REAL(rkind), INTENT(INOUT) :: ALB ! ! output - REAL, DIMENSION(1:2),INTENT(OUT) :: ALBSND !snow albedo for direct(1=vis, 2=nir) - REAL, DIMENSION(1:2),INTENT(OUT) :: ALBSNI !snow albedo for diffuse + REAL(rkind), DIMENSION(1:2),INTENT(OUT) :: ALBSND !snow albedo for direct(1=vis, 2=nir) + REAL(rkind), DIMENSION(1:2),INTENT(OUT) :: ALBSNI !snow albedo for diffuse ! --------------------------------------------------------------------------------------------- ! ------------------------ local variables ---------------------------------------------------- @@ -1210,24 +1213,24 @@ SUBROUTINE GROUNDALB (NSOIL ,NBAND ,ICE ,IST ,ISC , & !in INTEGER, INTENT(IN) :: ICE !value of ist for land ice INTEGER, INTENT(IN) :: IST !surface type INTEGER, INTENT(IN) :: ISC !soil color class (1-lighest; 8-darkest) - REAL, INTENT(IN) :: FSNO !fraction of surface covered with snow (-) - REAL, INTENT(IN) :: TG !ground temperature (k) - REAL, INTENT(IN) :: COSZ !cosine solar zenith angle (0-1) - REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SMC !volumetric soil water content (m3/m3) - REAL, DIMENSION(1: 2), INTENT(IN) :: ALBSND !direct beam snow albedo (vis, nir) - REAL, DIMENSION(1: 2), INTENT(IN) :: ALBSNI !diffuse snow albedo (vis, nir) + REAL(rkind), INTENT(IN) :: FSNO !fraction of surface covered with snow (-) + REAL(rkind), INTENT(IN) :: TG !ground temperature (k) + REAL(rkind), INTENT(IN) :: COSZ !cosine solar zenith angle (0-1) + REAL(rkind), DIMENSION(1:NSOIL), INTENT(IN) :: SMC !volumetric soil water content (m3/m3) + REAL(rkind), DIMENSION(1: 2), INTENT(IN) :: ALBSND !direct beam snow albedo (vis, nir) + REAL(rkind), DIMENSION(1: 2), INTENT(IN) :: ALBSNI !diffuse snow albedo (vis, nir) !output - REAL, DIMENSION(1: 2), INTENT(OUT) :: ALBGRD !ground albedo (direct beam: vis, nir) - REAL, DIMENSION(1: 2), INTENT(OUT) :: ALBGRI !ground albedo (diffuse: vis, nir) + REAL(rkind), DIMENSION(1: 2), INTENT(OUT) :: ALBGRD !ground albedo (direct beam: vis, nir) + REAL(rkind), DIMENSION(1: 2), INTENT(OUT) :: ALBGRI !ground albedo (diffuse: vis, nir) !local INTEGER :: IB !waveband number (1=vis, 2=nir) - REAL :: INC !soil water correction factor for soil albedo - REAL :: ALBSOD !soil albedo (direct) - REAL :: ALBSOI !soil albedo (diffuse) + REAL(rkind) :: INC !soil water correction factor for soil albedo + REAL(rkind) :: ALBSOD !soil albedo (direct) + REAL(rkind) :: ALBSOI !soil albedo (diffuse) ! -------------------------------------------------------------------------------------------------- DO IB = 1, NBAND @@ -1284,68 +1287,68 @@ SUBROUTINE TWOSTREAM (IB ,IC ,VEGTYP ,COSZ ,VAI , & !in INTEGER, INTENT(IN) :: IC !0=unit incoming direct; 1=unit incoming diffuse INTEGER, INTENT(IN) :: VEGTYP !vegetation type - REAL, INTENT(IN) :: COSZ !cosine of direct zenith angle (0-1) - REAL, INTENT(IN) :: VAI !one-sided leaf+stem area index (m2/m2) - REAL, INTENT(IN) :: FWET !fraction of lai, sai that is wetted (-) - REAL, INTENT(IN) :: T !surface temperature (k) + REAL(rkind), INTENT(IN) :: COSZ !cosine of direct zenith angle (0-1) + REAL(rkind), INTENT(IN) :: VAI !one-sided leaf+stem area index (m2/m2) + REAL(rkind), INTENT(IN) :: FWET !fraction of lai, sai that is wetted (-) + REAL(rkind), INTENT(IN) :: T !surface temperature (k) - REAL, DIMENSION(1:2), INTENT(IN) :: ALBGRD !direct albedo of underlying surface (-) - REAL, DIMENSION(1:2), INTENT(IN) :: ALBGRI !diffuse albedo of underlying surface (-) - REAL, DIMENSION(1:2), INTENT(IN) :: RHO !leaf+stem reflectance - REAL, DIMENSION(1:2), INTENT(IN) :: TAU !leaf+stem transmittance - REAL, INTENT(IN) :: FVEG !green vegetation fraction [0.0-1.0] + REAL(rkind), DIMENSION(1:2), INTENT(IN) :: ALBGRD !direct albedo of underlying surface (-) + REAL(rkind), DIMENSION(1:2), INTENT(IN) :: ALBGRI !diffuse albedo of underlying surface (-) + REAL(rkind), DIMENSION(1:2), INTENT(IN) :: RHO !leaf+stem reflectance + REAL(rkind), DIMENSION(1:2), INTENT(IN) :: TAU !leaf+stem transmittance + REAL(rkind), INTENT(IN) :: FVEG !green vegetation fraction [0.0-1.0] ! output - REAL, DIMENSION(1:2), INTENT(OUT) :: FAB !flux abs by veg layer (per unit incoming flux) - REAL, DIMENSION(1:2), INTENT(OUT) :: FRE !flux refl above veg layer (per unit incoming flux) - REAL, DIMENSION(1:2), INTENT(OUT) :: FTD !down dir flux below veg layer (per unit in flux) - REAL, DIMENSION(1:2), INTENT(OUT) :: FTI !down dif flux below veg layer (per unit in flux) - REAL, INTENT(OUT) :: GDIR !projected leaf+stem area in solar direction - REAL, DIMENSION(1:2), INTENT(OUT) :: FREV !flux reflected by veg layer (per unit incoming flux) - REAL, DIMENSION(1:2), INTENT(OUT) :: FREG !flux reflected by ground (per unit incoming flux) + REAL(rkind), DIMENSION(1:2), INTENT(OUT) :: FAB !flux abs by veg layer (per unit incoming flux) + REAL(rkind), DIMENSION(1:2), INTENT(OUT) :: FRE !flux refl above veg layer (per unit incoming flux) + REAL(rkind), DIMENSION(1:2), INTENT(OUT) :: FTD !down dir flux below veg layer (per unit in flux) + REAL(rkind), DIMENSION(1:2), INTENT(OUT) :: FTI !down dif flux below veg layer (per unit in flux) + REAL(rkind), INTENT(OUT) :: GDIR !projected leaf+stem area in solar direction + REAL(rkind), DIMENSION(1:2), INTENT(OUT) :: FREV !flux reflected by veg layer (per unit incoming flux) + REAL(rkind), DIMENSION(1:2), INTENT(OUT) :: FREG !flux reflected by ground (per unit incoming flux) ! local - REAL :: OMEGA !fraction of intercepted radiation that is scattered - REAL :: OMEGAL !omega for leaves - REAL :: BETAI !upscatter parameter for diffuse radiation - REAL :: BETAIL !betai for leaves - REAL :: BETAD !upscatter parameter for direct beam radiation - REAL :: BETADL !betad for leaves - REAL :: EXT !optical depth of direct beam per unit leaf area - REAL :: AVMU !average diffuse optical depth - - REAL :: COSZI !0.001 <= cosz <= 1.000 - REAL :: ASU !single scattering albedo - REAL :: CHIL ! -0.4 <= xl <= 0.6 - - REAL :: TMP0,TMP1,TMP2,TMP3,TMP4,TMP5,TMP6,TMP7,TMP8,TMP9 - REAL :: P1,P2,P3,P4,S1,S2,U1,U2,U3 - REAL :: B,C,D,D1,D2,F,H,H1,H2,H3,H4,H5,H6,H7,H8,H9,H10 - REAL :: PHI1,PHI2,SIGMA - REAL :: FTDS,FTIS,FRES - REAL :: DENFVEG - REAL :: VAI_SPREAD + REAL(rkind) :: OMEGA !fraction of intercepted radiation that is scattered + REAL(rkind) :: OMEGAL !omega for leaves + REAL(rkind) :: BETAI !upscatter parameter for diffuse radiation + REAL(rkind) :: BETAIL !betai for leaves + REAL(rkind) :: BETAD !upscatter parameter for direct beam radiation + REAL(rkind) :: BETADL !betad for leaves + REAL(rkind) :: EXT !optical depth of direct beam per unit leaf area + REAL(rkind) :: AVMU !average diffuse optical depth + + REAL(rkind) :: COSZI !0.001 <= cosz <= 1.000 + REAL(rkind) :: ASU !single scattering albedo + REAL(rkind) :: CHIL ! -0.4 <= xl <= 0.6 + + REAL(rkind) :: TMP0,TMP1,TMP2,TMP3,TMP4,TMP5,TMP6,TMP7,TMP8,TMP9 + REAL(rkind) :: P1,P2,P3,P4,S1,S2,U1,U2,U3 + REAL(rkind) :: B,C,D,D1,D2,F,H,H1,H2,H3,H4,H5,H6,H7,H8,H9,H10 + REAL(rkind) :: PHI1,PHI2,SIGMA + REAL(rkind) :: FTDS,FTIS,FRES + REAL(rkind) :: DENFVEG + REAL(rkind) :: VAI_SPREAD !jref:start - REAL :: FREVEG,FREBAR,FTDVEG,FTIVEG,FTDBAR,FTIBAR - REAL :: THETAZ + REAL(rkind) :: FREVEG,FREBAR,FTDVEG,FTIVEG,FTDBAR,FTIBAR + REAL(rkind) :: THETAZ !jref:end ! variables for the modified two-stream scheme ! Niu and Yang (2004), JGR - REAL, PARAMETER :: PAI = 3.14159265 - REAL :: HD !crown depth (m) - REAL :: BB !vertical crown radius (m) - REAL :: THETAP !angle conversion from SZA - REAL :: FA !foliage volume density (m-1) - REAL :: NEWVAI !effective LSAI (-) + REAL(rkind), PARAMETER :: PAI = 3.14159265 + REAL(rkind) :: HD !crown depth (m) + REAL(rkind) :: BB !vertical crown radius (m) + REAL(rkind) :: THETAP !angle conversion from SZA + REAL(rkind) :: FA !foliage volume density (m-1) + REAL(rkind) :: NEWVAI !effective LSAI (-) - REAL,INTENT(INOUT) :: BGAP !between canopy gap fraction for beam (-) - REAL,INTENT(INOUT) :: WGAP !within canopy gap fraction for beam (-) + REAL(rkind),INTENT(INOUT) :: BGAP !between canopy gap fraction for beam (-) + REAL(rkind),INTENT(INOUT) :: WGAP !within canopy gap fraction for beam (-) - REAL :: KOPEN !gap fraction for diffue light (-) - REAL :: GAP !total gap fraction for beam ( <=1-shafac ) + REAL(rkind) :: KOPEN !gap fraction for diffue light (-) + REAL(rkind) :: GAP !total gap fraction for beam ( <=1-shafac ) ! ----------------------------------------------------------------- ! compute within and between gaps @@ -1429,7 +1432,7 @@ SUBROUTINE TWOSTREAM (IB ,IC ,VEGTYP ,COSZ ,VAI , & !in TMP1 = B*B - C*C H = SQRT(TMP1) / AVMU SIGMA = TMP0*TMP0 - TMP1 - if ( ABS (SIGMA) < 1.e-6 ) SIGMA = SIGN(1.e-6,SIGMA) + if ( ABS (SIGMA) < 1.e-6 ) SIGMA = SIGN(1.e-6,REAL(SIGMA)) P1 = B + AVMU*H P2 = B - AVMU*H P3 = B + TMP0 @@ -1524,27 +1527,27 @@ SUBROUTINE STOMATA (VEGTYP ,MPE ,APAR ,FOLN ,ILOC , JLOC, & !in INTEGER,INTENT(IN) :: JLOC !grid index INTEGER,INTENT(IN) :: VEGTYP !vegetation physiology type - REAL, INTENT(IN) :: IGS !growing season index (0=off, 1=on) - REAL, INTENT(IN) :: MPE !prevents division by zero errors - - REAL, INTENT(IN) :: TV !foliage temperature (k) - REAL, INTENT(IN) :: EI !vapor pressure inside leaf (sat vapor press at tv) (pa) - REAL, INTENT(IN) :: EA !vapor pressure of canopy air (pa) - REAL, INTENT(IN) :: APAR !par absorbed per unit lai (w/m2) - REAL, INTENT(IN) :: O2 !atmospheric o2 concentration (pa) - REAL, INTENT(IN) :: CO2 !atmospheric co2 concentration (pa) - REAL, INTENT(IN) :: SFCPRS !air pressure at reference height (pa) - REAL, INTENT(IN) :: SFCTMP !air temperature at reference height (k) - REAL, INTENT(IN) :: BTRAN !soil water transpiration factor (0 to 1) - REAL, INTENT(IN) :: FOLN !foliage nitrogen concentration (%) - REAL, INTENT(IN) :: RB !boundary layer resistance (s/m) + REAL(rkind), INTENT(IN) :: IGS !growing season index (0=off, 1=on) + REAL(rkind), INTENT(IN) :: MPE !prevents division by zero errors + + REAL(rkind), INTENT(IN) :: TV !foliage temperature (k) + REAL(rkind), INTENT(IN) :: EI !vapor pressure inside leaf (sat vapor press at tv) (pa) + REAL(rkind), INTENT(IN) :: EA !vapor pressure of canopy air (pa) + REAL(rkind), INTENT(IN) :: APAR !par absorbed per unit lai (w/m2) + REAL(rkind), INTENT(IN) :: O2 !atmospheric o2 concentration (pa) + REAL(rkind), INTENT(IN) :: CO2 !atmospheric co2 concentration (pa) + REAL(rkind), INTENT(IN) :: SFCPRS !air pressure at reference height (pa) + REAL(rkind), INTENT(IN) :: SFCTMP !air temperature at reference height (k) + REAL(rkind), INTENT(IN) :: BTRAN !soil water transpiration factor (0 to 1) + REAL(rkind), INTENT(IN) :: FOLN !foliage nitrogen concentration (%) + REAL(rkind), INTENT(IN) :: RB !boundary layer resistance (s/m) ! output - REAL, INTENT(OUT) :: RS !leaf stomatal resistance (s/m) - REAL, INTENT(OUT) :: PSN !foliage photosynthesis (umol co2 /m2/ s) [always +] + REAL(rkind), INTENT(OUT) :: RS !leaf stomatal resistance (s/m) + REAL(rkind), INTENT(OUT) :: PSN !foliage photosynthesis (umol co2 /m2/ s) [always +] ! in&out - REAL :: RLB !boundary layer resistance (s m2 / umol) + REAL(rkind) :: RLB !boundary layer resistance (s m2 / umol) ! --------------------------------------------------------------------------------------------- ! ------------------------ local variables ---------------------------------------------------- @@ -1554,32 +1557,32 @@ SUBROUTINE STOMATA (VEGTYP ,MPE ,APAR ,FOLN ,ILOC , JLOC, & !in DATA NITER /3/ SAVE NITER - REAL :: AB !used in statement functions - REAL :: BC !used in statement functions - REAL :: F1 !generic temperature response (statement function) - REAL :: F2 !generic temperature inhibition (statement function) - REAL :: TC !foliage temperature (degree Celsius) - REAL :: CS !co2 concentration at leaf surface (pa) - REAL :: KC !co2 Michaelis-Menten constant (pa) - REAL :: KO !o2 Michaelis-Menten constant (pa) - REAL :: A,B,C,Q !intermediate calculations for RS - REAL :: R1,R2 !roots for RS - REAL :: FNF !foliage nitrogen adjustment factor (0 to 1) - REAL :: PPF !absorb photosynthetic photon flux (umol photons/m2/s) - REAL :: WC !Rubisco limited photosynthesis (umol co2/m2/s) - REAL :: WJ !light limited photosynthesis (umol co2/m2/s) - REAL :: WE !export limited photosynthesis (umol co2/m2/s) - REAL :: CP !co2 compensation point (pa) - REAL :: CI !internal co2 (pa) - REAL :: AWC !intermediate calculation for wc - REAL :: VCMX !maximum rate of carbonylation (umol co2/m2/s) - REAL :: J !electron transport (umol co2/m2/s) - REAL :: CEA !constrain ea or else model blows up - REAL :: CF !s m2/umol -> s/m + REAL(rkind) :: AB !used in statement functions + REAL(rkind) :: BC !used in statement functions + REAL(rkind) :: F1 !generic temperature response (statement function) + REAL(rkind) :: F2 !generic temperature inhibition (statement function) + REAL(rkind) :: TC !foliage temperature (degree Celsius) + REAL(rkind) :: CS !co2 concentration at leaf surface (pa) + REAL(rkind) :: KC !co2 Michaelis-Menten constant (pa) + REAL(rkind) :: KO !o2 Michaelis-Menten constant (pa) + REAL(rkind) :: A,B,C,Q !intermediate calculations for RS + REAL(rkind) :: R1,R2 !roots for RS + REAL(rkind) :: FNF !foliage nitrogen adjustment factor (0 to 1) + REAL(rkind) :: PPF !absorb photosynthetic photon flux (umol photons/m2/s) + REAL(rkind) :: WC !Rubisco limited photosynthesis (umol co2/m2/s) + REAL(rkind) :: WJ !light limited photosynthesis (umol co2/m2/s) + REAL(rkind) :: WE !export limited photosynthesis (umol co2/m2/s) + REAL(rkind) :: CP !co2 compensation point (pa) + REAL(rkind) :: CI !internal co2 (pa) + REAL(rkind) :: AWC !intermediate calculation for wc + REAL(rkind) :: VCMX !maximum rate of carbonylation (umol co2/m2/s) + REAL(rkind) :: J !electron transport (umol co2/m2/s) + REAL(rkind) :: CEA !constrain ea or else model blows up + REAL(rkind) :: CF !s m2/umol -> s/m F1(AB,BC) = AB**((BC-25.)/10.) F2(AB) = 1. + EXP((-2.2E05+710.*(AB+273.16))/(8.314*(AB+273.16))) - REAL :: T + REAL(rkind) :: T ! --------------------------------------------------------------------------------------------- ! MPC change @@ -1686,26 +1689,26 @@ SUBROUTINE CANRES (PAR ,SFCTMP,RCSOIL ,EAH ,SFCPRS , & !in INTEGER, INTENT(IN) :: ILOC !grid index INTEGER, INTENT(IN) :: JLOC !grid index - REAL, INTENT(IN) :: PAR !par absorbed per unit sunlit lai (w/m2) - REAL, INTENT(IN) :: SFCTMP !canopy air temperature - REAL, INTENT(IN) :: SFCPRS !surface pressure (pa) - REAL, INTENT(IN) :: EAH !water vapor pressure (pa) - REAL, INTENT(IN) :: RCSOIL !soil moisture stress factor + REAL(rkind), INTENT(IN) :: PAR !par absorbed per unit sunlit lai (w/m2) + REAL(rkind), INTENT(IN) :: SFCTMP !canopy air temperature + REAL(rkind), INTENT(IN) :: SFCPRS !surface pressure (pa) + REAL(rkind), INTENT(IN) :: EAH !water vapor pressure (pa) + REAL(rkind), INTENT(IN) :: RCSOIL !soil moisture stress factor !outputs - REAL, INTENT(OUT) :: RC !canopy resistance per unit LAI - REAL, INTENT(OUT) :: PSN !foliage photosynthesis (umolco2/m2/s) + REAL(rkind), INTENT(OUT) :: RC !canopy resistance per unit LAI + REAL(rkind), INTENT(OUT) :: PSN !foliage photosynthesis (umolco2/m2/s) !local - REAL :: RCQ - REAL :: RCS - REAL :: RCT - REAL :: FF - REAL :: Q2 !water vapor mixing ratio (kg/kg) - REAL :: Q2SAT !saturation Q2 - REAL :: DQSDT2 !d(Q2SAT)/d(T) + REAL(rkind) :: RCQ + REAL(rkind) :: RCS + REAL(rkind) :: RCT + REAL(rkind) :: FF + REAL(rkind) :: Q2 !water vapor mixing ratio (kg/kg) + REAL(rkind) :: Q2SAT !saturation Q2 + REAL(rkind) :: DQSDT2 !d(Q2SAT)/d(T) ! RSMIN, RSMAX, TOPT, RGL, HS are canopy stress parameters set in REDPRM ! ---------------------------------------------------------------------- @@ -1748,12 +1751,12 @@ END SUBROUTINE CANRES ! ================================================================================================== SUBROUTINE CALHUM(SFCTMP, SFCPRS, Q2SAT, DQSDT2) IMPLICIT NONE - REAL, INTENT(IN) :: SFCTMP, SFCPRS - REAL, INTENT(OUT) :: Q2SAT, DQSDT2 - REAL, PARAMETER :: A2=17.67,A3=273.15,A4=29.65, ELWV=2.501E6, & + REAL(rkind), INTENT(IN) :: SFCTMP, SFCPRS + REAL(rkind), INTENT(OUT) :: Q2SAT, DQSDT2 + REAL(rkind), PARAMETER :: A2=17.67,A3=273.15,A4=29.65, ELWV=2.501E6, & A23M4=A2*(A3-A4), E0=0.611, RV=461.0, & EPSILON=0.622 - REAL :: ES, SFCPRSX + REAL(rkind) :: ES, SFCPRSX ! Q2SAT: saturated mixing ratio ES = E0 * EXP ( ELWV/RV*(1./A3 - 1./SFCTMP) ) ! convert SFCPRS from Pa to KPa @@ -1823,13 +1826,13 @@ SUBROUTINE REDPRM (VEGTYP,SOILTYP,SLOPETYP,ZSOIL,NSOIL,ISURBAN) ! General parameters INTEGER, INTENT(IN) :: NSOIL ! Layer parameters - REAL,DIMENSION(NSOIL),INTENT(IN) :: ZSOIL + REAL(rkind),DIMENSION(NSOIL),INTENT(IN) :: ZSOIL ! Locals - REAL :: REFDK - REAL :: REFKDT - REAL :: FRZK - REAL :: FRZFACT + REAL(rkind) :: REFDK + REAL(rkind) :: REFKDT + REAL(rkind) :: FRZK + REAL(rkind) :: FRZFACT INTEGER :: I CHARACTER(len=256) :: message ! ---------------------------------------------------------------------- @@ -1962,6 +1965,7 @@ END MODULE NOAHMP_ROUTINES ! ================================================================================================== MODULE MODULE_SF_NOAHMPLSM + use nrtype USE NOAHMP_ROUTINES USE NOAHMP_GLOBALS diff --git a/build/source/noah-mp/module_sf_noahutl.F b/build/source/noah-mp/module_sf_noahutl.F index 007961bd3..47c6d7dc1 100755 --- a/build/source/noah-mp/module_sf_noahutl.F +++ b/build/source/noah-mp/module_sf_noahutl.F @@ -1,6 +1,7 @@ MODULE module_sf_noahutl + USE nrtype - REAL, PARAMETER :: CP = 1004.5, RD = 287.04, SIGMA = 5.67E-8, & + REAL(rkind), PARAMETER :: CP = 1004.5, RD = 287.04, SIGMA = 5.67E-8, & CPH2O = 4.218E+3,CPICE = 2.106E+3, & LSUBF = 3.335E+5 @@ -11,20 +12,20 @@ SUBROUTINE CALTMP(T1, SFCTMP, SFCPRS, ZLVL, Q2, TH2, T1V, TH2V, RHO ) IMPLICIT NONE ! Input: - REAL, INTENT(IN) :: T1 ! Skin temperature (K) - REAL, INTENT(IN) :: SFCTMP ! Air temperature (K) at level ZLVL - REAL, INTENT(IN) :: Q2 ! Specific Humidity (kg/kg) at level ZLVL - REAL, INTENT(IN) :: SFCPRS ! Atmospheric pressure (Pa) at level ZLVL - REAL, INTENT(IN) :: ZLVL ! Height (m AGL) where atmospheric fields are valid + REAL(rkind), INTENT(IN) :: T1 ! Skin temperature (K) + REAL(rkind), INTENT(IN) :: SFCTMP ! Air temperature (K) at level ZLVL + REAL(rkind), INTENT(IN) :: Q2 ! Specific Humidity (kg/kg) at level ZLVL + REAL(rkind), INTENT(IN) :: SFCPRS ! Atmospheric pressure (Pa) at level ZLVL + REAL(rkind), INTENT(IN) :: ZLVL ! Height (m AGL) where atmospheric fields are valid ! Output: - REAL, INTENT(OUT) :: TH2 ! Potential temperature (considering the reference pressure to be at the surface) - REAL, INTENT(OUT) :: T1V ! Virtual skin temperature (K) - REAL, INTENT(OUT) :: TH2V ! Virtual potential temperature at ZLVL - REAL, INTENT(OUT) :: RHO ! Density + REAL(rkind), INTENT(OUT) :: TH2 ! Potential temperature (considering the reference pressure to be at the surface) + REAL(rkind), INTENT(OUT) :: T1V ! Virtual skin temperature (K) + REAL(rkind), INTENT(OUT) :: TH2V ! Virtual potential temperature at ZLVL + REAL(rkind), INTENT(OUT) :: RHO ! Density ! Local: - REAL :: T2V + REAL(rkind) :: T2V TH2 = SFCTMP + ( 0.0098 * ZLVL) T1V= T1 * (1.0+ 0.61 * Q2) @@ -39,18 +40,18 @@ SUBROUTINE CALHUM(SFCTMP, SFCPRS, Q2SAT, DQSDT2) IMPLICIT NONE ! Input: - REAL, INTENT(IN) :: SFCTMP - REAL, INTENT(IN) :: SFCPRS + REAL(rkind), INTENT(IN) :: SFCTMP + REAL(rkind), INTENT(IN) :: SFCPRS ! Output: - REAL, INTENT(OUT) :: Q2SAT ! Saturated specific humidity - REAL, INTENT(OUT) :: DQSDT2 + REAL(rkind), INTENT(OUT) :: Q2SAT ! Saturated specific humidity + REAL(rkind), INTENT(OUT) :: DQSDT2 ! Local - REAL, PARAMETER :: A2=17.67,A3=273.15,A4=29.65, ELWV=2.501E6, & + REAL(rkind), PARAMETER :: A2=17.67,A3=273.15,A4=29.65, ELWV=2.501E6, & A23M4=A2*(A3-A4), E0=611.0, RV=461.0, & EPSILON=0.622 - REAL :: ES + REAL(rkind) :: ES ! ES: e.g. Dutton chapter 8, eq 11 ES = E0 * EXP ( ELWV/RV*(1./A3 - 1./SFCTMP) ) diff --git a/docs/whats-new.md b/docs/whats-new.md index 88934fa03..247f380f3 100644 --- a/docs/whats-new.md +++ b/docs/whats-new.md @@ -11,3 +11,5 @@ This page provides simple, high-level documentation about what has changed in ea - Fixes a water balance error w.r.t transpiration - Fixes the output message to report the correct solution type - Adds tolerance to balance check in updatState.f90 +- Changes all float data types to `rk`, for "real kind", which is intended to + make it easier to switch from double to single precision. From 6d42d13507523d118db6fae74aa75a3dec555ee6 Mon Sep 17 00:00:00 2001 From: martynpclark Date: Wed, 26 May 2021 11:08:07 -0600 Subject: [PATCH 20/24] update Makefile --- build/Makefile | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/build/Makefile b/build/Makefile index c425d0104..61dd6757c 100644 --- a/build/Makefile +++ b/build/Makefile @@ -91,12 +91,12 @@ ifeq "$(FC)" "gfortran" endif # Production runs -FLAGS_NOAH = -O3 -ffree-form -fdefault-real-8 -ffree-line-length-none -fmax-errors=0 $(FLAGS_OMP) +FLAGS_NOAH = -O3 -ffree-form -ffree-line-length-none -fmax-errors=0 $(FLAGS_OMP) FLAGS_COMM = -O3 -ffree-line-length-none -fmax-errors=0 $(FLAGS_OMP) FLAGS_SUMMA = -O3 -ffree-line-length-none -fmax-errors=0 $(FLAGS_OMP) # Debug runs -#FLAGS_NOAH = -p -g -ffree-form -fdefault-real-8 -ffree-line-length-none -fmax-errors=0 -fbacktrace -Wno-unused -Wno-unused-dummy-argument +#FLAGS_NOAH = -p -g -ffree-form -ffree-line-length-none -fmax-errors=0 -fbacktrace -Wno-unused -Wno-unused-dummy-argument #FLAGS_COMM = -p -g -Wall -ffree-line-length-none -fmax-errors=0 -fbacktrace -fcheck=bounds #FLAGS_SUMMA = -p -g -Wall -ffree-line-length-none -fmax-errors=0 -fbacktrace -fcheck=bounds @@ -110,12 +110,12 @@ ifeq "$(FC)" "ifort" endif # Production runs -FLAGS_NOAH = -O3 -autodouble -noerror_limit -FR -auto -fltconsistency $(FLAGS_OMP) +FLAGS_NOAH = -O3 -noerror_limit -FR -auto -fltconsistency $(FLAGS_OMP) FLAGS_COMM = -O3 -FR -auto -fltconsistency -fpe0 $(FLAGS_OMP) FLAGS_SUMMA = -O3 -FR -auto -fltconsistency -fpe0 $(FLAGS_OMP) # Debug runs -#FLAGS_NOAH = -O0 -p -g -warn nounused -autodouble -noerror_limit -FR -auto -WB -traceback -fltconsistency +#FLAGS_NOAH = -O0 -p -g -warn nounused -noerror_limit -FR -auto -WB -traceback -fltconsistency #FLAGS_COMM = -O0 -p -g -debug -warn all -check all -FR -auto -WB -traceback -fltconsistency -fpe0 #FLAGS_SUMMA = -O0 -p -g -debug -warn all -check all -FR -auto -WB -traceback -fltconsistency -fpe0 endif @@ -357,7 +357,7 @@ update_version: # compile Noah-MP routines compile_noah: - $(FC_EXE) $(FLAGS_NOAH) -c $(NOAHMP) + $(FC_EXE) $(FLAGS_NOAH) -c $(NRUTIL) $(NOAHMP) # compile common routines compile_comm: From 34f07e726d13b599f5fa80d630a93bcc93bdabb1 Mon Sep 17 00:00:00 2001 From: martynpclark Date: Wed, 26 May 2021 11:56:46 -0600 Subject: [PATCH 21/24] enable writing parameters for the GRUs --- build/source/netcdf/def_output.f90 | 1 + 1 file changed, 1 insertion(+) diff --git a/build/source/netcdf/def_output.f90 b/build/source/netcdf/def_output.f90 index 996eef1c1..58e24833a 100755 --- a/build/source/netcdf/def_output.f90 +++ b/build/source/netcdf/def_output.f90 @@ -327,6 +327,7 @@ subroutine def_variab(ncid,iFreq,spatialDesire,timeDesire,metaData,ivtype,err,me ! (scalar variable -- many different types) case(iLookvarType%scalarv) if(spatialDesire==needGRU .and. timeDesire==needTime) then; call cloneStruc(dimensionIDs, lowerBound=1, source=(/ gru_DimID,Timestep_DimID/), err=err, message=cmessage); writechunk=(/ gruChunk, int(timeChunk/gruChunk)+1 /); endif + if(spatialDesire==needGRU .and. timeDesire== noTime) then; call cloneStruc(dimensionIDs, lowerBound=1, source=(/ gru_DimID/), err=err, message=cmessage); writechunk=(/ gruChunk /); endif if(spatialDesire==needHRU .and. timeDesire==needTime) then; call cloneStruc(dimensionIDs, lowerBound=1, source=(/ hru_DimID,Timestep_DimID/), err=err, message=cmessage); writechunk=(/ hruChunk, int(timeChunk/hruChunk)+1 /); endif if(spatialDesire==needHRU .and. timeDesire== noTime) then; call cloneStruc(dimensionIDs, lowerBound=1, source=(/ hru_DimID/) , err=err, message=cmessage); writechunk=(/ hruChunk /); endif if(spatialDesire== noHRU .and. timeDesire==needTime) then; call cloneStruc(dimensionIDs, lowerBound=1, source=(/Timestep_DimID/) , err=err, message=cmessage); writechunk=(/ gruChunk /); endif From bda78e91ed225e5b44e19c7db7f7affd5bdc9657 Mon Sep 17 00:00:00 2001 From: Andrew Bennett Date: Wed, 26 May 2021 16:22:50 -0700 Subject: [PATCH 22/24] Revert "Create new unified real kind datatype" --- build/source/driver/summa_globalData.f90 | 2 +- build/source/driver/summa_init.f90 | 6 +- build/source/driver/summa_modelRun.f90 | 14 +- build/source/driver/summa_restart.f90 | 8 +- build/source/driver/summa_setup.f90 | 6 +- build/source/driver/summa_type.f90 | 4 +- build/source/driver/summa_util.f90 | 8 +- build/source/dshare/data_types.f90 | 16 +- build/source/dshare/globalData.f90 | 40 +- build/source/dshare/multiconst.f90 | 58 +- build/source/dshare/outpt_stat.f90 | 18 +- build/source/engine/allocspace.f90 | 20 +- build/source/engine/bigAquifer.f90 | 20 +- build/source/engine/canopySnow.f90 | 58 +- build/source/engine/check_icond.f90 | 36 +- build/source/engine/computFlux.f90 | 70 +- build/source/engine/computJacob.f90 | 38 +- build/source/engine/computResid.f90 | 32 +- build/source/engine/convE2Temp.f90 | 72 +- build/source/engine/conv_funcs.f90 | 138 +- build/source/engine/coupled_em.f90 | 156 +- build/source/engine/derivforce.f90 | 92 +- build/source/engine/diagn_evar.f90 | 74 +- build/source/engine/eval8summa.f90 | 62 +- build/source/engine/expIntegral.f90 | 38 +- build/source/engine/f2008funcs.f90 | 6 +- build/source/engine/ffile_info.f90 | 2 +- build/source/engine/getVectorz.f90 | 86 +- build/source/engine/groundwatr.f90 | 114 +- build/source/engine/layerDivide.f90 | 42 +- build/source/engine/layerMerge.f90 | 42 +- build/source/engine/mDecisions.f90 | 8 +- build/source/engine/matrixOper.f90 | 26 +- build/source/engine/nr_utility.f90 | 36 +- build/source/engine/nrtype.f90 | 11 +- build/source/engine/opSplittin.f90 | 34 +- build/source/engine/pOverwrite.f90 | 2 +- build/source/engine/paramCheck.f90 | 10 +- build/source/engine/qTimeDelay.f90 | 16 +- build/source/engine/read_attrb.f90 | 2 +- build/source/engine/read_force.f90 | 48 +- build/source/engine/read_param.f90 | 2 +- build/source/engine/read_pinit.f90 | 8 +- build/source/engine/run_oneGRU.f90 | 16 +- build/source/engine/run_oneHRU.f90 | 6 +- build/source/engine/snowAlbedo.f90 | 52 +- build/source/engine/snowLiqFlx.f90 | 36 +- build/source/engine/snow_utils.f90 | 38 +- build/source/engine/snwCompact.f90 | 80 +- build/source/engine/soilLiqFlx.f90 | 510 +++---- build/source/engine/soil_utils.f90 | 448 +++--- build/source/engine/spline_int.f90 | 48 +- build/source/engine/ssdNrgFlux.f90 | 34 +- build/source/engine/stomResist.f90 | 370 ++--- build/source/engine/summaSolve.f90 | 276 ++-- build/source/engine/sunGeomtry.f90 | 52 +- build/source/engine/systemSolv.f90 | 58 +- build/source/engine/tempAdjust.f90 | 62 +- build/source/engine/time_utils.f90 | 46 +- build/source/engine/updatState.f90 | 47 +- build/source/engine/updateVars.f90 | 96 +- build/source/engine/varSubstep.f90 | 142 +- build/source/engine/var_derive.f90 | 96 +- build/source/engine/vegLiqFlux.f90 | 30 +- build/source/engine/vegNrgFlux.f90 | 1290 ++++++++--------- build/source/engine/vegPhenlgy.f90 | 14 +- build/source/engine/vegSWavRad.f90 | 344 ++--- build/source/engine/volicePack.f90 | 50 +- build/source/netcdf/modelwrite.f90 | 4 +- build/source/netcdf/read_icond.f90 | 6 +- build/source/noah-mp/module_model_constants.F | 211 ++- build/source/noah-mp/module_sf_noahlsm.F | 17 +- build/source/noah-mp/module_sf_noahmplsm.F | 850 ++++++----- build/source/noah-mp/module_sf_noahutl.F | 35 +- docs/whats-new.md | 2 - 75 files changed, 3469 insertions(+), 3478 deletions(-) diff --git a/build/source/driver/summa_globalData.f90 b/build/source/driver/summa_globalData.f90 index c9168d0f8..d2acf3992 100755 --- a/build/source/driver/summa_globalData.f90 +++ b/build/source/driver/summa_globalData.f90 @@ -107,7 +107,7 @@ subroutine summa_defineGlobalData(err, message) doJacobian=.false. ! initialize the Jacobian flag ! define double precision NaNs (shared in globalData) - dNaN = ieee_value(1._rk, ieee_quiet_nan) + dNaN = ieee_value(1._dp, ieee_quiet_nan) ! populate metadata for all model variables call popMetadat(err,cmessage) diff --git a/build/source/driver/summa_init.f90 b/build/source/driver/summa_init.f90 index 7a3305552..1f65af736 100755 --- a/build/source/driver/summa_init.f90 +++ b/build/source/driver/summa_init.f90 @@ -175,9 +175,9 @@ subroutine summa_initialize(summa1_struc, err, message) ncid(:) = integerMissing ! initialize the elapsed time for cumulative quantities - elapsedRead=0._rk - elapsedWrite=0._rk - elapsedPhysics=0._rk + elapsedRead=0._dp + elapsedWrite=0._dp + elapsedPhysics=0._dp ! get the command line arguments call getCommandArguments(summa1_struc,err,cmessage) diff --git a/build/source/driver/summa_modelRun.f90 b/build/source/driver/summa_modelRun.f90 index 77984285b..5080921c4 100755 --- a/build/source/driver/summa_modelRun.f90 +++ b/build/source/driver/summa_modelRun.f90 @@ -72,16 +72,16 @@ subroutine summa_runPhysics(modelTimeStep, summa1_struc, err, message) integer(i4b) :: iGRU,jGRU,kGRU ! GRU indices ! local variables: veg phenology logical(lgt) :: computeVegFluxFlag ! flag to indicate if we are computing fluxes over vegetation (.false. means veg is buried with snow) - real(rk) :: notUsed_canopyDepth ! NOT USED: canopy depth (m) - real(rk) :: notUsed_exposedVAI ! NOT USED: exposed vegetation area index (m2 m-2) + real(dp) :: notUsed_canopyDepth ! NOT USED: canopy depth (m) + real(dp) :: notUsed_exposedVAI ! NOT USED: exposed vegetation area index (m2 m-2) ! local variables: parallelize the model run integer(i4b), allocatable :: ixExpense(:) ! ranked index GRU w.r.t. computational expense integer(i4b), allocatable :: totalFluxCalls(:) ! total number of flux calls for each GRU ! local variables: timing information integer*8 :: openMPstart,openMPend ! time for the start of the parallelization section integer*8, allocatable :: timeGRUstart(:) ! time GRUs start - real(rk), allocatable :: timeGRUcompleted(:) ! time required to complete each GRU - real(rk), allocatable :: timeGRU(:) ! time spent on each GRU + real(dp), allocatable :: timeGRUcompleted(:) ! time required to complete each GRU + real(dp), allocatable :: timeGRU(:) ! time spent on each GRU ! --------------------------------------------------------------------------------------- ! associate to elements in the data structure summaVars: associate(& @@ -171,7 +171,7 @@ subroutine summa_runPhysics(modelTimeStep, summa1_struc, err, message) ! compute the total number of flux calls from the previous time step do jGRU=1,nGRU - totalFluxCalls(jGRU) = 0._rk + totalFluxCalls(jGRU) = 0._dp do iHRU=1,gru_struc(jGRU)%hruCount totalFluxCalls(jGRU) = totalFluxCalls(jGRU) + indxStruct%gru(jGRU)%hru(iHRU)%var(iLookINDEX%numberFluxCalc)%dat(1) end do @@ -268,8 +268,8 @@ subroutine summa_runPhysics(modelTimeStep, summa1_struc, err, message) !$omp critical(saveTiming) ! save timing information call system_clock(openMPend) - timeGRU(iGRU) = real(openMPend - timeGRUstart(iGRU), kind(rk)) - timeGRUcompleted(iGRU) = real(openMPend - openMPstart , kind(rk)) + timeGRU(iGRU) = real(openMPend - timeGRUstart(iGRU), kind(dp)) + timeGRUcompleted(iGRU) = real(openMPend - openMPstart , kind(dp)) !$omp end critical(saveTiming) end do ! (looping through GRUs) diff --git a/build/source/driver/summa_restart.f90 b/build/source/driver/summa_restart.f90 index d4a73c643..61b80816e 100755 --- a/build/source/driver/summa_restart.f90 +++ b/build/source/driver/summa_restart.f90 @@ -178,7 +178,7 @@ subroutine summa_readRestart(summa1_struc, err, message) ! initialize canopy drip ! NOTE: canopy drip from the previous time step is used to compute throughfall for the current time step - fluxStruct%gru(iGRU)%hru(iHRU)%var(iLookFLUX%scalarCanopyLiqDrainage)%dat(1) = 0._rk ! not used + fluxStruct%gru(iGRU)%hru(iHRU)%var(iLookFLUX%scalarCanopyLiqDrainage)%dat(1) = 0._dp ! not used end do ! end looping through HRUs @@ -201,14 +201,14 @@ subroutine summa_readRestart(summa1_struc, err, message) ! the basin-average aquifer storage is not used if the groundwater is included in the local column case(localColumn) - bvarStruct%gru(iGRU)%var(iLookBVAR%basin__AquiferStorage)%dat(1) = 0._rk ! set to zero to be clear that there is no basin-average aquifer storage in this configuration + bvarStruct%gru(iGRU)%var(iLookBVAR%basin__AquiferStorage)%dat(1) = 0._dp ! set to zero to be clear that there is no basin-average aquifer storage in this configuration ! the local column aquifer storage is not used if the groundwater is basin-average ! (i.e., where multiple HRUs drain to a basin-average aquifer) case(singleBasin) - bvarStruct%gru(iGRU)%var(iLookBVAR%basin__AquiferStorage)%dat(1) = 1._rk + bvarStruct%gru(iGRU)%var(iLookBVAR%basin__AquiferStorage)%dat(1) = 1._dp do iHRU=1,gru_struc(iGRU)%hruCount - progStruct%gru(iGRU)%hru(iHRU)%var(iLookPROG%scalarAquiferStorage)%dat(1) = 0._rk ! set to zero to be clear that there is no local aquifer storage in this configuration + progStruct%gru(iGRU)%hru(iHRU)%var(iLookPROG%scalarAquiferStorage)%dat(1) = 0._dp ! set to zero to be clear that there is no local aquifer storage in this configuration end do ! error check diff --git a/build/source/driver/summa_setup.f90 b/build/source/driver/summa_setup.f90 index 1b48a59dd..14aa86b27 100755 --- a/build/source/driver/summa_setup.f90 +++ b/build/source/driver/summa_setup.f90 @@ -191,7 +191,7 @@ subroutine summa_paramSetup(summa1_struc, err, message) ! ***************************************************************************** ! define monthly fraction of green vegetation - greenVegFrac_monthly = (/0.01_rk, 0.02_rk, 0.03_rk, 0.07_rk, 0.50_rk, 0.90_rk, 0.95_rk, 0.96_rk, 0.65_rk, 0.24_rk, 0.11_rk, 0.02_rk/) + greenVegFrac_monthly = (/0.01_dp, 0.02_dp, 0.03_dp, 0.07_dp, 0.50_dp, 0.90_dp, 0.95_dp, 0.96_dp, 0.65_dp, 0.24_dp, 0.11_dp, 0.02_dp/) ! read Noah soil and vegetation tables call soil_veg_gen_parm(trim(SETTINGS_PATH)//trim(VEGPARM), & ! filename for vegetation table @@ -298,7 +298,7 @@ subroutine summa_paramSetup(summa1_struc, err, message) ! compute total area of the upstream HRUS that flow into each HRU do iHRU=1,gru_struc(iGRU)%hruCount - upArea%gru(iGRU)%hru(iHRU) = 0._rk + upArea%gru(iGRU)%hru(iHRU) = 0._dp do jHRU=1,gru_struc(iGRU)%hruCount ! check if jHRU flows into iHRU; assume no exchange between GRUs if(typeStruct%gru(iGRU)%hru(jHRU)%var(iLookTYPE%downHRUindex)==typeStruct%gru(iGRU)%hru(iHRU)%var(iLookID%hruId))then @@ -309,7 +309,7 @@ subroutine summa_paramSetup(summa1_struc, err, message) ! identify the total basin area for a GRU (m2) associate(totalArea => bvarStruct%gru(iGRU)%var(iLookBVAR%basin__totalArea)%dat(1) ) - totalArea = 0._rk + totalArea = 0._dp do iHRU=1,gru_struc(iGRU)%hruCount totalArea = totalArea + attrStruct%gru(iGRU)%hru(iHRU)%var(iLookATTR%HRUarea) end do diff --git a/build/source/driver/summa_type.f90 b/build/source/driver/summa_type.f90 index f39ed8443..e44418816 100755 --- a/build/source/driver/summa_type.f90 +++ b/build/source/driver/summa_type.f90 @@ -91,11 +91,11 @@ MODULE summa_type ! define miscellaneous variables integer(i4b) :: summa1open ! flag to define if the summa file is open?? integer(i4b) :: numout ! number of output variables?? - real(rk) :: ts ! model time step ?? + real(dp) :: ts ! model time step ?? integer(i4b) :: nGRU ! number of grouped response units integer(i4b) :: nHRU ! number of global hydrologic response units integer(i4b) :: hruCount ! number of local hydrologic response units - real(rk),dimension(12) :: greenVegFrac_monthly ! fraction of green vegetation in each month (0-1) + real(dp),dimension(12) :: greenVegFrac_monthly ! fraction of green vegetation in each month (0-1) character(len=256) :: summaFileManagerFile ! path/name of file defining directories and files end type summa1_type_dec diff --git a/build/source/driver/summa_util.f90 b/build/source/driver/summa_util.f90 index 3bee86a07..5f1256647 100755 --- a/build/source/driver/summa_util.f90 +++ b/build/source/driver/summa_util.f90 @@ -350,7 +350,7 @@ subroutine stop_program(err,message) integer(i4b) :: endModelRun(8) ! final time integer(i4b) :: localErr ! local error code integer(i4b) :: iFreq ! loop through output frequencies - real(rk) :: elpSec ! elapsed seconds + real(dp) :: elpSec ! elapsed seconds ! close any remaining output files ! NOTE: use the direct NetCDF call with no error checking since the file may already be closed @@ -392,9 +392,9 @@ subroutine stop_program(err,message) ! print total elapsed time write(outunit,"(/,A,1PG15.7,A)") ' elapsed time = ', elpSec, ' s' - write(outunit,"(A,1PG15.7,A)") ' or ', elpSec/60_rk, ' m' - write(outunit,"(A,1PG15.7,A)") ' or ', elpSec/3600_rk, ' h' - write(outunit,"(A,1PG15.7,A/)") ' or ', elpSec/86400_rk, ' d' + write(outunit,"(A,1PG15.7,A)") ' or ', elpSec/60_dp, ' m' + write(outunit,"(A,1PG15.7,A)") ' or ', elpSec/3600_dp, ' h' + write(outunit,"(A,1PG15.7,A/)") ' or ', elpSec/86400_dp, ' d' ! print the number of threads write(outunit,"(A,i10,/)") ' number threads = ', nThreads diff --git a/build/source/dshare/data_types.f90 b/build/source/dshare/data_types.f90 index a513c5ef9..cf20b1e89 100755 --- a/build/source/dshare/data_types.f90 +++ b/build/source/dshare/data_types.f90 @@ -48,8 +48,8 @@ MODULE data_types integer(i4b),allocatable :: var_ix(:) ! index of each forcing data variable in the data structure integer(i4b),allocatable :: data_id(:) ! netcdf variable id for each forcing data variable character(len=256),allocatable :: varName(:) ! netcdf variable name for each forcing data variable - real(rk) :: firstJulDay ! first julian day in forcing file - real(rk) :: convTime2Days ! factor to convert time to days + real(dp) :: firstJulDay ! first julian day in forcing file + real(dp) :: convTime2Days ! factor to convert time to days end type file_info ! *********************************************************************************************************** @@ -57,9 +57,9 @@ MODULE data_types ! *********************************************************************************************************** ! define a data type to store model parameter information type,public :: par_info - real(rk) :: default_val ! default parameter value - real(rk) :: lower_limit ! lower bound - real(rk) :: upper_limit ! upper bound + real(dp) :: default_val ! default parameter value + real(dp) :: lower_limit ! lower bound + real(dp) :: upper_limit ! upper bound endtype par_info ! *********************************************************************************************************** @@ -131,7 +131,7 @@ MODULE data_types ! NOTE: use derived types here to facilitate adding the "variable" dimension ! ** double precision type type, public :: dlength - real(rk),allocatable :: dat(:) ! dat(:) + real(dp),allocatable :: dat(:) ! dat(:) endtype dlength ! ** integer type (4 byte) type, public :: ilength @@ -168,7 +168,7 @@ MODULE data_types ! ** double precision type of fixed length type, public :: var_d - real(rk),allocatable :: var(:) ! var(:) + real(dp),allocatable :: var(:) ! var(:) endtype var_d ! ** integer type of fixed length (4 byte) type, public :: var_i @@ -181,7 +181,7 @@ MODULE data_types ! ** double precision type of fixed length type, public :: hru_d - real(rk),allocatable :: hru(:) ! hru(:) + real(dp),allocatable :: hru(:) ! hru(:) endtype hru_d ! ** integer type of fixed length (4 byte) type, public :: hru_i diff --git a/build/source/dshare/globalData.f90 b/build/source/dshare/globalData.f90 index ec1ea83af..68300c427 100755 --- a/build/source/dshare/globalData.f90 +++ b/build/source/dshare/globalData.f90 @@ -61,8 +61,8 @@ MODULE globalData ! ---------------------------------------------------------------------------------------------------------------- ! define missing values - real(rk),parameter,public :: quadMissing = nr_quadMissing ! (from nrtype) missing quadruple precision number - real(rk),parameter,public :: realMissing = nr_realMissing ! (from nrtype) missing double precision number + real(qp),parameter,public :: quadMissing = nr_quadMissing ! (from nrtype) missing quadruple precision number + real(dp),parameter,public :: realMissing = nr_realMissing ! (from nrtype) missing double precision number integer(i4b),parameter,public :: integerMissing = nr_integerMissing ! (from nrtype) missing integer ! define run modes @@ -166,11 +166,11 @@ MODULE globalData integer(i4b),parameter,public :: iJac2=20 ! last layer of the Jacobian to print ! define limit checks - real(rk),parameter,public :: verySmall=tiny(1.0_rk) ! a very small number - real(rk),parameter,public :: veryBig=1.e+20_rk ! a very big number + real(dp),parameter,public :: verySmall=tiny(1.0_dp) ! a very small number + real(dp),parameter,public :: veryBig=1.e+20_dp ! a very big number ! define algorithmic control parameters - real(rk),parameter,public :: dx = 1.e-8_rk ! finite difference increment + real(dp),parameter,public :: dx = 1.e-8_dp ! finite difference increment ! define summary information on all data structures integer(i4b),parameter :: nStruct=13 ! number of data structures @@ -198,7 +198,7 @@ MODULE globalData ! ---------------------------------------------------------------------------------------------------------------- ! define Indian bread (NaN) - real(rk),save,public :: dNaN + real(dp),save,public :: dNaN ! define default parameter values and parameter bounds type(par_info),save,public :: localParFallback(maxvarMpar) ! local column default parameters @@ -264,7 +264,7 @@ MODULE globalData type(hru2gru_map),allocatable,save,public :: index_map(:) ! hru2gru map ! define variables used for the vegetation phenology - real(rk),dimension(12), save , public :: greenVegFrac_monthly ! fraction of green vegetation in each month (0-1) + real(dp),dimension(12), save , public :: greenVegFrac_monthly ! fraction of green vegetation in each month (0-1) ! define the model output file character(len=256),save,public :: fileout='' ! output filename @@ -291,13 +291,13 @@ MODULE globalData integer(i4b),save,public :: numtim ! number of time steps integer(i4b),save,public :: nHRUrun ! number of HRUs in the run domain integer(i4b),save,public :: nGRUrun ! number of GRUs in the run domain - real(rk),save,public :: data_step ! time step of the data - real(rk),save,public :: refJulday ! reference time in fractional julian days - real(rk),save,public :: refJulday_data ! reference time in fractional julian days (data files) - real(rk),save,public :: fracJulday ! fractional julian days since the start of year - real(rk),save,public :: dJulianStart ! julian day of start time of simulation - real(rk),save,public :: dJulianFinsh ! julian day of end time of simulation - real(rk),save,public :: tmZoneOffsetFracDay ! time zone offset in fractional days + real(dp),save,public :: data_step ! time step of the data + real(dp),save,public :: refJulday ! reference time in fractional julian days + real(dp),save,public :: refJulday_data ! reference time in fractional julian days (data files) + real(dp),save,public :: fracJulday ! fractional julian days since the start of year + real(dp),save,public :: dJulianStart ! julian day of start time of simulation + real(dp),save,public :: dJulianFinsh ! julian day of end time of simulation + real(dp),save,public :: tmZoneOffsetFracDay ! time zone offset in fractional days integer(i4b),save,public :: nHRUfile ! number of HRUs in the file integer(i4b),save,public :: yearLength ! number of days in the current year integer(i4b),save,public :: urbanVegCategory ! vegetation category for urban areas @@ -315,12 +315,12 @@ MODULE globalData integer(i4b),dimension(8),save,public :: startPhysics,endPhysics ! date/time for the start and end of the physics ! define elapsed time - real(rk),save,public :: elapsedInit ! elapsed time for the initialization - real(rk),save,public :: elapsedSetup ! elapsed time for the parameter setup - real(rk),save,public :: elapsedRestart ! elapsed time to read restart data - real(rk),save,public :: elapsedRead ! elapsed time for the data read - real(rk),save,public :: elapsedWrite ! elapsed time for the stats/write - real(rk),save,public :: elapsedPhysics ! elapsed time for the physics + real(dp),save,public :: elapsedInit ! elapsed time for the initialization + real(dp),save,public :: elapsedSetup ! elapsed time for the parameter setup + real(dp),save,public :: elapsedRestart ! elapsed time to read restart data + real(dp),save,public :: elapsedRead ! elapsed time for the data read + real(dp),save,public :: elapsedWrite ! elapsed time for the stats/write + real(dp),save,public :: elapsedPhysics ! elapsed time for the physics ! define ancillary data structures type(var_i),save,public :: startTime ! start time for the model simulation diff --git a/build/source/dshare/multiconst.f90 b/build/source/dshare/multiconst.f90 index 9d27a299b..764816fc6 100755 --- a/build/source/dshare/multiconst.f90 +++ b/build/source/dshare/multiconst.f90 @@ -21,33 +21,33 @@ MODULE multiconst USE nrtype ! define physical constants - real(rk), PARAMETER :: ave_slp = 101325.0_rk ! mean sea level pressure (Pa) - real(rk), PARAMETER :: vkc = 0.4_rk ! von Karman constant (-) - real(rk), PARAMETER :: satvpfrz = 610.8_rk ! sat vapour pressure at 273.16K (Pa) - real(rk), PARAMETER :: w_ratio = 0.622_rk ! molecular ratio water to dry air (-) - real(rk), PARAMETER :: R_da = 287.053_rk ! gas constant for dry air (Pa K-1 m3 kg-1; J kg-1 K-1) - real(rk), PARAMETER :: R_wv = 461.285_rk ! gas constant for water vapor (Pa K-1 m3 kg-1; J kg-1 K-1) - real(rk), PARAMETER :: Rgas = 8.314_rk ! universal gas constant (J mol-1 K-1) - real(rk), PARAMETER :: gravity = 9.80616_rk ! acceleration of gravity (m s-2) - real(rk), PARAMETER :: Cp_air = 1005._rk ! specific heat of air (J kg-1 K-1) - real(rk), PARAMETER :: Cp_ice = 2114._rk ! specific heat of ice (J kg-1 K-1) - real(rk), PARAMETER :: Cp_soil = 850._rk ! specific heat of soil (J kg-1 K-1) - real(rk), PARAMETER :: Cp_water = 4181._rk ! specific heat of liquid water (J kg-1 K-1) - real(rk), PARAMETER :: Tfreeze = 273.16_rk ! temperature at freezing (K) - real(rk), PARAMETER :: TriplPt = 273.16_rk ! triple point of water (K) - real(rk), PARAMETER :: LH_fus = 333700.0_rk ! latent heat of fusion (J kg-1) - real(rk), PARAMETER :: LH_vap = 2501000.0_rk ! latent heat of vaporization (J kg-1) - real(rk), PARAMETER :: LH_sub = 2834700.0_rk ! latent heat of sublimation (J kg-1) - real(rk), PARAMETER :: sb = 5.6705d-8 ! Stefan Boltzman constant (W m-2 K-4) - real(rk), PARAMETER :: em_sno = 0.99_rk ! emissivity of snow (-) - real(rk), PARAMETER :: lambda_air = 0.026_rk ! thermal conductivity of air (W m-1 K-1) - real(rk), PARAMETER :: lambda_ice = 2.50_rk ! thermal conductivity of ice (W m-1 K-1) - real(rk), PARAMETER :: lambda_water = 0.60_rk ! thermal conductivity of liquid water (W m-1 K-1) - real(rk), PARAMETER :: iden_air = 1.293_rk ! intrinsic density of air (kg m-3) - real(rk), PARAMETER :: iden_ice = 917.0_rk ! intrinsic density of ice (kg m-3) - real(rk), PARAMETER :: iden_water = 1000.0_rk ! intrinsic density of liquid water (kg m-3) - real(rk), PARAMETER :: secprday = 86400._rk ! number of seconds in a day - real(rk), PARAMETER :: secprhour = 3600._rk ! number of seconds in an hour - real(rk), PARAMETER :: secprmin = 60._rk ! number of seconds in a minute - real(rk), PARAMETER :: minprhour = 60._rk ! number of minutes in an hour + REAL(DP), PARAMETER :: ave_slp = 101325.0_dp ! mean sea level pressure (Pa) + REAL(DP), PARAMETER :: vkc = 0.4_dp ! von Karman constant (-) + REAL(DP), PARAMETER :: satvpfrz = 610.8_dp ! sat vapour pressure at 273.16K (Pa) + REAL(DP), PARAMETER :: w_ratio = 0.622_dp ! molecular ratio water to dry air (-) + REAL(DP), PARAMETER :: R_da = 287.053_dp ! gas constant for dry air (Pa K-1 m3 kg-1; J kg-1 K-1) + REAL(DP), PARAMETER :: R_wv = 461.285_dp ! gas constant for water vapor (Pa K-1 m3 kg-1; J kg-1 K-1) + REAL(DP), PARAMETER :: Rgas = 8.314_dp ! universal gas constant (J mol-1 K-1) + REAL(DP), PARAMETER :: gravity = 9.80616_dp ! acceleration of gravity (m s-2) + REAL(DP), PARAMETER :: Cp_air = 1005._dp ! specific heat of air (J kg-1 K-1) + REAL(DP), PARAMETER :: Cp_ice = 2114._dp ! specific heat of ice (J kg-1 K-1) + REAL(DP), PARAMETER :: Cp_soil = 850._dp ! specific heat of soil (J kg-1 K-1) + REAL(DP), PARAMETER :: Cp_water = 4181._dp ! specific heat of liquid water (J kg-1 K-1) + REAL(DP), PARAMETER :: Tfreeze = 273.16_dp ! temperature at freezing (K) + REAL(DP), PARAMETER :: TriplPt = 273.16_dp ! triple point of water (K) + REAL(DP), PARAMETER :: LH_fus = 333700.0_dp ! latent heat of fusion (J kg-1) + REAL(DP), PARAMETER :: LH_vap = 2501000.0_dp ! latent heat of vaporization (J kg-1) + REAL(DP), PARAMETER :: LH_sub = 2834700.0_dp ! latent heat of sublimation (J kg-1) + REAL(DP), PARAMETER :: sb = 5.6705d-8 ! Stefan Boltzman constant (W m-2 K-4) + REAL(DP), PARAMETER :: em_sno = 0.99_dp ! emissivity of snow (-) + REAL(DP), PARAMETER :: lambda_air = 0.026_dp ! thermal conductivity of air (W m-1 K-1) + REAL(DP), PARAMETER :: lambda_ice = 2.50_dp ! thermal conductivity of ice (W m-1 K-1) + REAL(DP), PARAMETER :: lambda_water = 0.60_dp ! thermal conductivity of liquid water (W m-1 K-1) + REAL(DP), PARAMETER :: iden_air = 1.293_dp ! intrinsic density of air (kg m-3) + REAL(DP), PARAMETER :: iden_ice = 917.0_dp ! intrinsic density of ice (kg m-3) + REAL(DP), PARAMETER :: iden_water = 1000.0_dp ! intrinsic density of liquid water (kg m-3) + REAL(DP), PARAMETER :: secprday = 86400._dp ! number of seconds in a day + REAL(DP), PARAMETER :: secprhour = 3600._dp ! number of seconds in an hour + REAL(DP), PARAMETER :: secprmin = 60._dp ! number of seconds in a minute + REAL(DP), PARAMETER :: minprhour = 60._dp ! number of minutes in an hour END MODULE multiconst diff --git a/build/source/dshare/outpt_stat.f90 b/build/source/dshare/outpt_stat.f90 index f51a6db6f..dbb7c3953 100755 --- a/build/source/dshare/outpt_stat.f90 +++ b/build/source/dshare/outpt_stat.f90 @@ -54,7 +54,7 @@ subroutine calcStats(stat,dat,meta,resetStats,finalizeStats,statCounter,err,mess character(256) :: cmessage ! error message integer(i4b) :: iVar ! index for varaiable loop integer(i4b) :: pVar ! index into parent structure - real(rk) :: tdata ! dummy for pulling info from dat structure + real(dp) :: tdata ! dummy for pulling info from dat structure ! initialize error control err=0; message='calcStats/' @@ -73,9 +73,9 @@ subroutine calcStats(stat,dat,meta,resetStats,finalizeStats,statCounter,err,mess ! extract data from the structures select type (dat) - type is (real(rk)); tdata = dat(pVar) + type is (real(dp)); tdata = dat(pVar) class is (dlength) ; tdata = dat(pVar)%dat(1) - class is (ilength) ; tdata = real(dat(pVar)%dat(1), kind(rk)) + class is (ilength) ; tdata = real(dat(pVar)%dat(1), kind(dp)) class default;err=20;message=trim(message)//'dat type not found';return end select @@ -114,7 +114,7 @@ subroutine calc_stats(meta,stat,tdata,resetStats,finalizeStats,statCounter,err,m ! input variables class(var_info),intent(in) :: meta ! meta data structure class(*) ,intent(inout) :: stat ! statistics structure - real(rk) ,intent(in) :: tdata ! data value + real(dp) ,intent(in) :: tdata ! data value logical(lgt) ,intent(in) :: resetStats(:) ! vector of flags to reset statistics logical(lgt) ,intent(in) :: finalizeStats(:) ! vector of flags to reset statistics integer(i4b) ,intent(in) :: statCounter(:) ! number of time steps in each output frequency @@ -122,7 +122,7 @@ subroutine calc_stats(meta,stat,tdata,resetStats,finalizeStats,statCounter,err,m integer(i4b) ,intent(out) :: err ! error code character(*) ,intent(out) :: message ! error message ! internals - real(rk),dimension(maxvarFreq*2) :: tstat ! temporary stats vector + real(dp),dimension(maxvarFreq*2) :: tstat ! temporary stats vector integer(i4b) :: iFreq ! index of output frequency ! initialize error control err=0; message='calc_stats/' @@ -144,12 +144,12 @@ subroutine calc_stats(meta,stat,tdata,resetStats,finalizeStats,statCounter,err,m select case(meta%statIndex(iFreq)) ! act depending on the statistic ! ------------------------------------------------------------------------------------- case (iLookStat%totl) ! * summation over period - tstat(iFreq) = 0._rk ! - resets stat at beginning of period + tstat(iFreq) = 0._dp ! - resets stat at beginning of period case (iLookStat%mean) ! * mean over period - tstat(iFreq) = 0._rk ! - resets stat at beginning of period + tstat(iFreq) = 0._dp ! - resets stat at beginning of period case (iLookStat%vari) ! * variance over period - tstat(iFreq) = 0._rk ! - resets E[X^2] term in var calc - tstat(maxVarFreq+iFreq) = 0._rk ! - resets E[X]^2 term + tstat(iFreq) = 0._dp ! - resets E[X^2] term in var calc + tstat(maxVarFreq+iFreq) = 0._dp ! - resets E[X]^2 term case (iLookStat%mini) ! * minimum over period tstat(iFreq) = huge(tstat(iFreq)) ! - resets stat at beginning of period case (iLookStat%maxi) ! * maximum over period diff --git a/build/source/engine/allocspace.f90 b/build/source/engine/allocspace.f90 index 9ddeefc93..27e73300a 100755 --- a/build/source/engine/allocspace.f90 +++ b/build/source/engine/allocspace.f90 @@ -262,7 +262,7 @@ subroutine allocLocal(metaStruct,dataStruct,nSnow,nSoil,err,message) select type(dataStruct) class is (var_flagVec); call allocateDat_flag(metaStruct,nSnow,nSoil,nLayers,dataStruct,err,cmessage) class is (var_ilength); call allocateDat_int( metaStruct,nSnow,nSoil,nLayers,dataStruct,err,cmessage) - class is (var_dlength); call allocateDat_rk( metaStruct,nSnow,nSoil,nLayers,dataStruct,err,cmessage) + class is (var_dlength); call allocateDat_dp( metaStruct,nSnow,nSoil,nLayers,dataStruct,err,cmessage) class default; err=20; message=trim(message)//'unable to identify derived data type for the data dimension'; return end select @@ -328,7 +328,7 @@ subroutine resizeData(metaStruct,dataStructOrig,dataStructNew,copy,err,message) ! double precision class is (var_dlength) select type(dataStructNew) - class is (var_dlength); call copyStruct_rk( dataStructOrig%var(iVar),dataStructNew%var(iVar),isCopy,err,cmessage) + class is (var_dlength); call copyStruct_dp( dataStructOrig%var(iVar),dataStructNew%var(iVar),isCopy,err,cmessage) class default; err=20; message=trim(message)//'mismatch data structure for variable'//trim(metaStruct(iVar)%varname); return end select @@ -349,9 +349,9 @@ subroutine resizeData(metaStruct,dataStructOrig,dataStructNew,copy,err,message) end subroutine resizeData ! ************************************************************************************************ - ! private subroutine copyStruct_rk: copy a given data structure + ! private subroutine copyStruct_dp: copy a given data structure ! ************************************************************************************************ - subroutine copyStruct_rk(varOrig,varNew,copy,err,message) + subroutine copyStruct_dp(varOrig,varNew,copy,err,message) ! dummy variables type(dlength),intent(in) :: varOrig ! original data structure type(dlength),intent(inout) :: varNew ! new data structure @@ -366,7 +366,7 @@ subroutine copyStruct_rk(varOrig,varNew,copy,err,message) integer(i4b) :: lowerBoundNew ! lower bound of a given variable in the new data structure integer(i4b) :: upperBoundNew ! upper bound of a given variable in the new data structure ! initialize error control - err=0; message='copyStruct_rk/' + err=0; message='copyStruct_dp/' ! get the information from the data structures call getVarInfo(varOrig,allocatedOrig,lowerBoundOrig,upperBoundOrig) @@ -433,7 +433,7 @@ subroutine getVarInfo(var,isAllocated,lowerBound,upperBound) end subroutine getVarInfo - end subroutine copyStruct_rk + end subroutine copyStruct_dp ! ************************************************************************************************ ! private subroutine copyStruct_i4b: copy a given data structure @@ -524,9 +524,9 @@ end subroutine copyStruct_i4b ! ************************************************************************************************ - ! private subroutine allocateDat_rk: initialize data dimension of the data structures + ! private subroutine allocateDat_dp: initialize data dimension of the data structures ! ************************************************************************************************ - subroutine allocateDat_rk(metadata,nSnow,nSoil,nLayers, & ! input + subroutine allocateDat_dp(metadata,nSnow,nSoil,nLayers, & ! input varData,err,message) ! output ! access subroutines USE get_ixName_module,only:get_varTypeName ! to access type strings for error messages @@ -546,7 +546,7 @@ subroutine allocateDat_rk(metadata,nSnow,nSoil,nLayers, & ! input integer(i4b) :: nVars ! number of variables in the metadata structure ! initialize error control - err=0; message='allocateDat_rk/' + err=0; message='allocateDat_dp/' ! get the number of variables in the metadata structure nVars = size(metadata) @@ -589,7 +589,7 @@ subroutine allocateDat_rk(metadata,nSnow,nSoil,nLayers, & ! input end do ! looping through variables - end subroutine allocateDat_rk + end subroutine allocateDat_dp ! ************************************************************************************************ ! private subroutine allocateDat_int: initialize data dimension of the data structures diff --git a/build/source/engine/bigAquifer.f90 b/build/source/engine/bigAquifer.f90 index a51b0f393..e9312789d 100755 --- a/build/source/engine/bigAquifer.f90 +++ b/build/source/engine/bigAquifer.f90 @@ -66,24 +66,24 @@ subroutine bigAquifer(& ! ------------------------------------------------------------------------------------------------------------------------------------------------- implicit none ! input: state variables, fluxes, and parameters - real(rk),intent(in) :: scalarAquiferStorageTrial ! trial value of aquifer storage (m) - real(rk),intent(in) :: scalarCanopyTranspiration ! canopy transpiration (kg m-2 s-1) - real(rk),intent(in) :: scalarSoilDrainage ! soil drainage (m s-1) + real(dp),intent(in) :: scalarAquiferStorageTrial ! trial value of aquifer storage (m) + real(dp),intent(in) :: scalarCanopyTranspiration ! canopy transpiration (kg m-2 s-1) + real(dp),intent(in) :: scalarSoilDrainage ! soil drainage (m s-1) ! input: diagnostic variables and parameters type(var_dlength),intent(in) :: mpar_data ! model parameters type(var_dlength),intent(in) :: diag_data ! diagnostic variables for a local HRU ! output: fluxes - real(rk),intent(out) :: scalarAquiferTranspire ! transpiration loss from the aquifer (m s-1) - real(rk),intent(out) :: scalarAquiferRecharge ! recharge to the aquifer (m s-1) - real(rk),intent(out) :: scalarAquiferBaseflow ! total baseflow from the aquifer (m s-1) - real(rk),intent(out) :: dBaseflow_dAquifer ! change in baseflow flux w.r.t. aquifer storage (s-1) + real(dp),intent(out) :: scalarAquiferTranspire ! transpiration loss from the aquifer (m s-1) + real(dp),intent(out) :: scalarAquiferRecharge ! recharge to the aquifer (m s-1) + real(dp),intent(out) :: scalarAquiferBaseflow ! total baseflow from the aquifer (m s-1) + real(dp),intent(out) :: dBaseflow_dAquifer ! change in baseflow flux w.r.t. aquifer storage (s-1) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! ----------------------------------------------------------------------------------------------------------------------------------------------------- ! local variables - real(rk) :: aquiferTranspireFrac ! fraction of total transpiration that comes from the aquifer (-) - real(rk) :: xTemp ! temporary variable (-) + real(dp) :: aquiferTranspireFrac ! fraction of total transpiration that comes from the aquifer (-) + real(dp) :: xTemp ! temporary variable (-) ! ------------------------------------------------------------------------------------------------------------------------------------------------- ! initialize error control err=0; message='bigAquifer/' @@ -112,7 +112,7 @@ subroutine bigAquifer(& scalarAquiferBaseflow = aquiferBaseflowRate*(xTemp**aquiferBaseflowExp) ! compute the derivative in the net aquifer flux - dBaseflow_dAquifer = -(aquiferBaseflowExp*aquiferBaseflowRate*(xTemp**(aquiferBaseflowExp - 1._rk)))/aquiferScaleFactor + dBaseflow_dAquifer = -(aquiferBaseflowExp*aquiferBaseflowRate*(xTemp**(aquiferBaseflowExp - 1._dp)))/aquiferScaleFactor ! end association to data in structures end associate diff --git a/build/source/engine/canopySnow.f90 b/build/source/engine/canopySnow.f90 index 20aeebef9..cde7e0b15 100755 --- a/build/source/engine/canopySnow.f90 +++ b/build/source/engine/canopySnow.f90 @@ -73,8 +73,8 @@ subroutine canopySnow(& implicit none ! ------------------------------------------------------------------------------------------------ ! input: model control - real(rk),intent(in) :: dt ! time step (seconds) - real(rk),intent(in) :: exposedVAI ! exposed vegetation area index -- leaf + stem -- after burial by snow (m2 m-2) + real(dp),intent(in) :: dt ! time step (seconds) + real(dp),intent(in) :: exposedVAI ! exposed vegetation area index -- leaf + stem -- after burial by snow (m2 m-2) logical(lgt),intent(in) :: computeVegFlux ! flag to indicate if we are computing fluxes over vegetation (.false. means veg is buried with snow) ! input/output: data structures type(model_options),intent(in) :: model_decisions(:) ! model decisions @@ -87,23 +87,23 @@ subroutine canopySnow(& integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! local variables - real(rk),parameter :: valueMissing=-9999._rk ! missing value + real(dp),parameter :: valueMissing=-9999._dp ! missing value integer(i4b) :: iter ! iteration index integer(i4b),parameter :: maxiter=50 ! maximum number of iterations - real(rk) :: unloading_melt ! unloading associated with canopy drip (kg m-2 s-1) - real(rk) :: airtemp_degC ! value of air temperature in degrees Celcius - real(rk) :: leafScaleFactor ! scaling factor for interception based on temperature (-) - real(rk) :: leafInterceptCapSnow ! storage capacity for snow per unit leaf area (kg m-2) - real(rk) :: canopyIceScaleFactor ! capacity scaling factor for throughfall (kg m-2) - real(rk) :: throughfallDeriv ! derivative in throughfall flux w.r.t. canopy storage (s-1) - real(rk) :: unloadingDeriv ! derivative in unloading flux w.r.t. canopy storage (s-1) - real(rk) :: scalarCanopyIceIter ! trial value for mass of ice on the vegetation canopy (kg m-2) (kg m-2) - real(rk) :: flux ! net flux (kg m-2 s-1) - real(rk) :: delS ! change in storage (kg m-2) - real(rk) :: resMass ! residual in mass equation (kg m-2) - real(rk) :: tempUnloadingFun ! temperature unloading functions, Eq. 14 in Roesch et al. 2001 - real(rk) :: windUnloadingFun ! temperature unloading functions, Eq. 15 in Roesch et al. 2001 - real(rk),parameter :: convTolerMass=0.0001_rk ! convergence tolerance for mass (kg m-2) + real(dp) :: unloading_melt ! unloading associated with canopy drip (kg m-2 s-1) + real(dp) :: airtemp_degC ! value of air temperature in degrees Celcius + real(dp) :: leafScaleFactor ! scaling factor for interception based on temperature (-) + real(dp) :: leafInterceptCapSnow ! storage capacity for snow per unit leaf area (kg m-2) + real(dp) :: canopyIceScaleFactor ! capacity scaling factor for throughfall (kg m-2) + real(dp) :: throughfallDeriv ! derivative in throughfall flux w.r.t. canopy storage (s-1) + real(dp) :: unloadingDeriv ! derivative in unloading flux w.r.t. canopy storage (s-1) + real(dp) :: scalarCanopyIceIter ! trial value for mass of ice on the vegetation canopy (kg m-2) (kg m-2) + real(dp) :: flux ! net flux (kg m-2 s-1) + real(dp) :: delS ! change in storage (kg m-2) + real(dp) :: resMass ! residual in mass equation (kg m-2) + real(dp) :: tempUnloadingFun ! temperature unloading functions, Eq. 14 in Roesch et al. 2001 + real(dp) :: windUnloadingFun ! temperature unloading functions, Eq. 15 in Roesch et al. 2001 + real(dp),parameter :: convTolerMass=0.0001_dp ! convergence tolerance for mass (kg m-2) ! ------------------------------------------------------------------------------------------------------------------------------- ! initialize error control err=0; message='canopySnow/' @@ -151,7 +151,7 @@ subroutine canopySnow(& if(computeVegFlux)then unloading_melt = min(ratioDrip2Unloading*scalarCanopyLiqDrainage, scalarCanopyIce/dt) ! kg m-2 s-1 else - unloading_melt = 0._rk + unloading_melt = 0._dp end if scalarCanopyIce = scalarCanopyIce - unloading_melt*dt @@ -173,11 +173,11 @@ subroutine canopySnow(& scalarCanopySnowUnloading = snowUnloadingCoeff*scalarCanopyIceIter unloadingDeriv = snowUnloadingCoeff else if (ixSnowUnload==windUnload) then - tempUnloadingFun = max(scalarCanairTemp - minTempUnloading, 0._rk) / rateTempUnloading ! (s-1) + tempUnloadingFun = max(scalarCanairTemp - minTempUnloading, 0._dp) / rateTempUnloading ! (s-1) if (scalarWindspdCanopyTop >= minWindUnloading) then windUnloadingFun = abs(scalarWindspdCanopyTop) / rateWindUnloading ! (s-1) else - windUnloadingFun = 0._rk ! (s-1) + windUnloadingFun = 0._dp ! (s-1) end if ! implement the "windySnow" Roesch et al. 2001 parameterization, Eq. 13 in Roesch et al. 2001 scalarCanopySnowUnloading = scalarCanopyIceIter * (tempUnloadingFun + windUnloadingFun) @@ -187,24 +187,24 @@ subroutine canopySnow(& if(scalarSnowfall -1._rk) then - leafScaleFactor = 4.0_rk - elseif(airtemp_degC > -3._rk) then - leafScaleFactor = 1.5_rk*airtemp_degC + 5.5_rk + if (airtemp_degC > -1._dp) then + leafScaleFactor = 4.0_dp + elseif(airtemp_degC > -3._dp) then + leafScaleFactor = 1.5_dp*airtemp_degC + 5.5_dp else - leafScaleFactor = 1.0_rk + leafScaleFactor = 1.0_dp end if leafInterceptCapSnow = refInterceptCapSnow*leafScaleFactor case default @@ -219,7 +219,7 @@ subroutine canopySnow(& end if ! (if snow is falling) ! ** compute iteration increment flux = scalarSnowfall - scalarThroughfallSnow - scalarCanopySnowUnloading ! net flux (kg m-2 s-1) - delS = (flux*dt - (scalarCanopyIceIter - scalarCanopyIce))/(1._rk + (throughfallDeriv + unloadingDeriv)*dt) + delS = (flux*dt - (scalarCanopyIceIter - scalarCanopyIce))/(1._dp + (throughfallDeriv + unloadingDeriv)*dt) ! ** check for convergence resMass = scalarCanopyIceIter - (scalarCanopyIce + flux*dt) if(abs(resMass) < convTolerMass)exit diff --git a/build/source/engine/check_icond.f90 b/build/source/engine/check_icond.f90 index 31d4c360c..9a1e9a779 100755 --- a/build/source/engine/check_icond.f90 +++ b/build/source/engine/check_icond.f90 @@ -82,15 +82,15 @@ subroutine check_icond(nGRU, & ! number of GRUs and HRU ! temporary variables for realism checks integer(i4b) :: iLayer ! index of model layer integer(i4b) :: iSoil ! index of soil layer - real(rk) :: fLiq ! fraction of liquid water on the vegetation canopy (-) - real(rk) :: vGn_m ! van Genutchen "m" parameter (-) - real(rk) :: tWat ! total water on the vegetation canopy (kg m-2) - real(rk) :: scalarTheta ! liquid water equivalent of total water [liquid water + ice] (-) - real(rk) :: h1,h2 ! used to check depth and height are consistent + real(dp) :: fLiq ! fraction of liquid water on the vegetation canopy (-) + real(dp) :: vGn_m ! van Genutchen "m" parameter (-) + real(dp) :: tWat ! total water on the vegetation canopy (kg m-2) + real(dp) :: scalarTheta ! liquid water equivalent of total water [liquid water + ice] (-) + real(dp) :: h1,h2 ! used to check depth and height are consistent integer(i4b) :: nLayers ! total number of layers - real(rk) :: kappa ! constant in the freezing curve function (m K-1) + real(dp) :: kappa ! constant in the freezing curve function (m K-1) integer(i4b) :: nSnow ! number of snow layers - real(rk),parameter :: xTol=1.e-10_rk ! small tolerance to address precision issues + real(dp),parameter :: xTol=1.e-10_dp ! small tolerance to address precision issues ! -------------------------------------------------------------------------------------------------------- ! Start procedure here @@ -149,14 +149,14 @@ subroutine check_icond(nGRU, & ! number of GRUs and HRU kappa = (iden_ice/iden_water)*(LH_fus/(gravity*Tfreeze)) ! NOTE: J = kg m2 s-2 ! modify the liquid water and ice in the canopy - if(scalarCanopyIce > 0._rk .and. scalarCanopyTemp > Tfreeze)then + if(scalarCanopyIce > 0._dp .and. scalarCanopyTemp > Tfreeze)then message=trim(message)//'canopy ice > 0 when canopy temperature > Tfreeze' err=20; return end if fLiq = fracliquid(scalarCanopyTemp,snowfrz_scale) ! fraction of liquid water (-) tWat = scalarCanopyLiq + scalarCanopyIce ! total water (kg m-2) scalarCanopyLiq = fLiq*tWat ! mass of liquid water on the canopy (kg m-2) - scalarCanopyIce = (1._rk - fLiq)*tWat ! mass of ice on the canopy (kg m-2) + scalarCanopyIce = (1._dp - fLiq)*tWat ! mass of ice on the canopy (kg m-2) ! number of layers nLayers = gru_struc(iGRU)%hruInfo(iHRU)%nSnow + gru_struc(iGRU)%hruInfo(iHRU)%nSoil @@ -168,7 +168,7 @@ subroutine check_icond(nGRU, & ! number of GRUs and HRU ! compute liquid water equivalent of total water (liquid plus ice) if (iLayer>nSnow) then ! soil layer = no volume expansion iSoil = iLayer - nSnow - vGn_m = 1._rk - 1._rk/vGn_n(iSoil) + vGn_m = 1._dp - 1._dp/vGn_n(iSoil) scalarTheta = mLayerVolFracIce(iLayer) + mLayerVolFracLiq(iLayer) else ! snow layer = volume expansion allowed iSoil = integerMissing @@ -184,14 +184,14 @@ subroutine check_icond(nGRU, & ! number of GRUs and HRU ! ***** snow case(iname_snow) ! (check liquid water) - if(mLayerVolFracLiq(iLayer) < 0._rk)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with volumetric fraction of liquid water < 0: layer = ',iLayer; err=20; return; end if - if(mLayerVolFracLiq(iLayer) > 1._rk)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with volumetric fraction of liquid water > 1: layer = ',iLayer; err=20; return; end if + if(mLayerVolFracLiq(iLayer) < 0._dp)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with volumetric fraction of liquid water < 0: layer = ',iLayer; err=20; return; end if + if(mLayerVolFracLiq(iLayer) > 1._dp)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with volumetric fraction of liquid water > 1: layer = ',iLayer; err=20; return; end if ! (check ice) - if(mLayerVolFracIce(iLayer) > 0.80_rk)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with volumetric fraction of ice > 0.80: layer = ',iLayer; err=20; return; end if - if(mLayerVolFracIce(iLayer) < 0.05_rk)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with volumetric fraction of ice < 0.05: layer = ',iLayer; err=20; return; end if + if(mLayerVolFracIce(iLayer) > 0.80_dp)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with volumetric fraction of ice > 0.80: layer = ',iLayer; err=20; return; end if + if(mLayerVolFracIce(iLayer) < 0.05_dp)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with volumetric fraction of ice < 0.05: layer = ',iLayer; err=20; return; end if ! check total water - if(scalarTheta > 0.80_rk)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with total water fraction [liquid + ice] > 0.80: layer = ',iLayer; err=20; return; end if - if(scalarTheta < 0.05_rk)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with total water fraction [liquid + ice] < 0.05: layer = ',iLayer; err=20; return; end if + if(scalarTheta > 0.80_dp)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with total water fraction [liquid + ice] > 0.80: layer = ',iLayer; err=20; return; end if + if(scalarTheta < 0.05_dp)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with total water fraction [liquid + ice] < 0.05: layer = ',iLayer; err=20; return; end if ! ***** soil case(iname_soil) @@ -200,7 +200,7 @@ subroutine check_icond(nGRU, & ! number of GRUs and HRU if(mLayerVolFracLiq(iLayer) < theta_res(iSoil)-xTol)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with volumetric fraction of liquid water < theta_res: layer = ',iLayer; err=20; return; end if if(mLayerVolFracLiq(iLayer) > theta_sat(iSoil)+xTol)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with volumetric fraction of liquid water > theta_sat: layer = ',iLayer; err=20; return; end if ! (check ice) - if(mLayerVolFracIce(iLayer) < 0._rk )then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with volumetric fraction of ice < 0: layer = ' ,iLayer; err=20; return; end if + if(mLayerVolFracIce(iLayer) < 0._dp )then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with volumetric fraction of ice < 0: layer = ' ,iLayer; err=20; return; end if if(mLayerVolFracIce(iLayer) > theta_sat(iSoil)+xTol)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with volumetric fraction of ice > theta_sat: layer = ',iLayer; err=20; return; end if ! check total water if(scalarTheta < theta_res(iSoil)-xTol)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with total water fraction [liquid + ice] < theta_res: layer = ',iLayer; err=20; return; end if @@ -273,7 +273,7 @@ subroutine check_icond(nGRU, & ! number of GRUs and HRU do iLayer=1,nLayers h1 = sum(progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%mLayerDepth)%dat(1:iLayer)) ! sum of the depths up to the current layer h2 = progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%iLayerHeight)%dat(iLayer) - progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%iLayerHeight)%dat(0) ! difference between snow-atm interface and bottom of layer - if(abs(h1 - h2) > 1.e-6_rk)then + if(abs(h1 - h2) > 1.e-6_dp)then write(message,'(a,1x,i0)') trim(message)//'mis-match between layer depth and layer height; layer = ', iLayer, '; sum depths = ',h1,'; height = ',h2 err=20; return end if diff --git a/build/source/engine/computFlux.f90 b/build/source/engine/computFlux.f90 index eabc02e9a..75b8fc486 100755 --- a/build/source/engine/computFlux.f90 +++ b/build/source/engine/computFlux.f90 @@ -164,18 +164,18 @@ subroutine computFlux(& logical(lgt),intent(in) :: firstSplitOper ! flag to indicate if we are processing the first flux call in a splitting operation logical(lgt),intent(in) :: computeVegFlux ! flag to indicate if computing fluxes over vegetation logical(lgt),intent(in) :: scalarSolution ! flag to denote if implementing the scalar solution - real(rk),intent(in) :: drainageMeltPond ! drainage from the surface melt pond (kg m-2 s-1) + real(dp),intent(in) :: drainageMeltPond ! drainage from the surface melt pond (kg m-2 s-1) ! input: state variables - real(rk),intent(in) :: scalarCanairTempTrial ! trial value for temperature of the canopy air space (K) - real(rk),intent(in) :: scalarCanopyTempTrial ! trial value for temperature of the vegetation canopy (K) - real(rk),intent(in) :: mLayerTempTrial(:) ! trial value for temperature of each snow/soil layer (K) - real(rk),intent(in) :: mLayerMatricHeadLiqTrial(:) ! trial value for the liquid water matric potential (m) - real(rk),intent(in) :: scalarAquiferStorageTrial ! trial value of aquifer storage (m) + real(dp),intent(in) :: scalarCanairTempTrial ! trial value for temperature of the canopy air space (K) + real(dp),intent(in) :: scalarCanopyTempTrial ! trial value for temperature of the vegetation canopy (K) + real(dp),intent(in) :: mLayerTempTrial(:) ! trial value for temperature of each snow/soil layer (K) + real(dp),intent(in) :: mLayerMatricHeadLiqTrial(:) ! trial value for the liquid water matric potential (m) + real(dp),intent(in) :: scalarAquiferStorageTrial ! trial value of aquifer storage (m) ! input: diagnostic variables - real(rk),intent(in) :: scalarCanopyLiqTrial ! trial value for mass of liquid water on the vegetation canopy (kg m-2) - real(rk),intent(in) :: scalarCanopyIceTrial ! trial value for mass of ice on the vegetation canopy (kg m-2) - real(rk),intent(in) :: mLayerVolFracLiqTrial(:) ! trial value for volumetric fraction of liquid water (-) - real(rk),intent(in) :: mLayerVolFracIceTrial(:) ! trial value for volumetric fraction of ice (-) + real(dp),intent(in) :: scalarCanopyLiqTrial ! trial value for mass of liquid water on the vegetation canopy (kg m-2) + real(dp),intent(in) :: scalarCanopyIceTrial ! trial value for mass of ice on the vegetation canopy (kg m-2) + real(dp),intent(in) :: mLayerVolFracLiqTrial(:) ! trial value for volumetric fraction of liquid water (-) + real(dp),intent(in) :: mLayerVolFracIceTrial(:) ! trial value for volumetric fraction of ice (-) ! input: data structures type(model_options),intent(in) :: model_decisions(:) ! model decisions type(var_i), intent(in) :: type_data ! type of vegetation and soil @@ -191,8 +191,8 @@ subroutine computFlux(& type(var_dlength),intent(inout) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables ! input-output: flux vector and baseflow derivatives integer(i4b),intent(inout) :: ixSaturation ! index of the lowest saturated layer (NOTE: only computed on the first iteration) - real(rk),intent(out) :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) - real(rk),intent(out) :: fluxVec(:) ! model flux vector (mixed units) + real(dp),intent(out) :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) + real(dp),intent(out) :: fluxVec(:) ! model flux vector (mixed units) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message @@ -202,7 +202,7 @@ subroutine computFlux(& integer(i4b) :: local_ixGroundwater ! local index for groundwater representation integer(i4b) :: iLayer ! index of model layers logical(lgt) :: doVegNrgFlux ! flag to compute the energy flux over vegetation - real(rk),dimension(nSoil) :: dHydCond_dMatric ! derivative in hydraulic conductivity w.r.t matric head (s-1) + real(dp),dimension(nSoil) :: dHydCond_dMatric ! derivative in hydraulic conductivity w.r.t matric head (s-1) character(LEN=256) :: cmessage ! error message of downwind routine ! -------------------------------------------------------------- ! initialize error control @@ -385,8 +385,8 @@ subroutine computFlux(& ! initialize liquid water fluxes throughout the snow and soil domains ! NOTE: used in the energy routines, which is called before the hydrology routines if(firstFluxCall)then - if(nSnow > 0) iLayerLiqFluxSnow(0:nSnow) = 0._rk - iLayerLiqFluxSoil(0:nSoil) = 0._rk + if(nSnow > 0) iLayerLiqFluxSnow(0:nSnow) = 0._dp + iLayerLiqFluxSoil(0:nSoil) = 0._dp end if ! ***** @@ -686,13 +686,13 @@ subroutine computFlux(& if(nSnow==0) then ! * case of infiltration into soil if(scalarMaxInfilRate > scalarRainPlusMelt)then ! infiltration is not rate-limited - scalarSoilControl = (1._rk - scalarFrozenArea)*scalarInfilArea + scalarSoilControl = (1._dp - scalarFrozenArea)*scalarInfilArea else - scalarSoilControl = 0._rk ! (scalarRainPlusMelt exceeds maximum infiltration rate + scalarSoilControl = 0._dp ! (scalarRainPlusMelt exceeds maximum infiltration rate endif else ! * case of infiltration into snow - scalarSoilControl = 1._rk + scalarSoilControl = 1._dp endif ! compute drainage from the soil zone (needed for mass balance checks) @@ -716,10 +716,10 @@ subroutine computFlux(& ! set baseflow fluxes to zero if the baseflow routine is not used if(local_ixGroundwater/=qbaseTopmodel)then ! (diagnostic variables in the data structures) - scalarExfiltration = 0._rk ! exfiltration from the soil profile (m s-1) - mLayerColumnOutflow(:) = 0._rk ! column outflow from each soil layer (m3 s-1) + scalarExfiltration = 0._dp ! exfiltration from the soil profile (m s-1) + mLayerColumnOutflow(:) = 0._dp ! column outflow from each soil layer (m3 s-1) ! (variables needed for the numerical solution) - mLayerBaseflow(:) = 0._rk ! baseflow from each soil layer (m s-1) + mLayerBaseflow(:) = 0._dp ! baseflow from each soil layer (m s-1) ! topmodel-ish shallow groundwater else ! local_ixGroundwater==qbaseTopmodel @@ -798,10 +798,10 @@ subroutine computFlux(& ! if no aquifer, then fluxes are zero else - scalarAquiferTranspire = 0._rk ! transpiration loss from the aquifer (m s-1) - scalarAquiferRecharge = 0._rk ! recharge to the aquifer (m s-1) - scalarAquiferBaseflow = 0._rk ! total baseflow from the aquifer (m s-1) - dBaseflow_dAquifer = 0._rk ! change in baseflow flux w.r.t. aquifer storage (s-1) + scalarAquiferTranspire = 0._dp ! transpiration loss from the aquifer (m s-1) + scalarAquiferRecharge = 0._dp ! recharge to the aquifer (m s-1) + scalarAquiferBaseflow = 0._dp ! total baseflow from the aquifer (m s-1) + dBaseflow_dAquifer = 0._dp ! change in baseflow flux w.r.t. aquifer storage (s-1) end if ! no aquifer endif ! if computing aquifer fluxes @@ -869,15 +869,15 @@ subroutine soilCmpres(& ! input: integer(i4b),intent(in) :: ixRichards ! choice of option for Richards' equation integer(i4b),intent(in) :: ixBeg,ixEnd ! start and end indices defining desired layers - real(rk),intent(in) :: mLayerMatricHead(:) ! matric head at the start of the time step (m) - real(rk),intent(in) :: mLayerMatricHeadTrial(:) ! trial value for matric head (m) - real(rk),intent(in) :: mLayerVolFracLiqTrial(:) ! trial value for volumetric fraction of liquid water (-) - real(rk),intent(in) :: mLayerVolFracIceTrial(:) ! trial value for volumetric fraction of ice (-) - real(rk),intent(in) :: specificStorage ! specific storage coefficient (m-1) - real(rk),intent(in) :: theta_sat(:) ! soil porosity (-) + real(dp),intent(in) :: mLayerMatricHead(:) ! matric head at the start of the time step (m) + real(dp),intent(in) :: mLayerMatricHeadTrial(:) ! trial value for matric head (m) + real(dp),intent(in) :: mLayerVolFracLiqTrial(:) ! trial value for volumetric fraction of liquid water (-) + real(dp),intent(in) :: mLayerVolFracIceTrial(:) ! trial value for volumetric fraction of ice (-) + real(dp),intent(in) :: specificStorage ! specific storage coefficient (m-1) + real(dp),intent(in) :: theta_sat(:) ! soil porosity (-) ! output: - real(rk),intent(inout) :: compress(:) ! soil compressibility (-) - real(rk),intent(inout) :: dCompress_dPsi(:) ! derivative in soil compressibility w.r.t. matric head (m-1) + real(dp),intent(inout) :: compress(:) ! soil compressibility (-) + real(dp),intent(inout) :: dCompress_dPsi(:) ! derivative in soil compressibility w.r.t. matric head (m-1) integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! local variables @@ -896,8 +896,8 @@ subroutine soilCmpres(& endif end do else - compress(:) = 0._rk - dCompress_dPsi(:) = 0._rk + compress(:) = 0._dp + dCompress_dPsi(:) = 0._dp end if end subroutine soilCmpres diff --git a/build/source/engine/computJacob.f90 b/build/source/engine/computJacob.f90 index c09d2fbae..147f320c1 100755 --- a/build/source/engine/computJacob.f90 +++ b/build/source/engine/computJacob.f90 @@ -74,7 +74,7 @@ module computJacob_module implicit none ! define constants -real(rk),parameter :: verySmall=tiny(1.0_rk) ! a very small number +real(dp),parameter :: verySmall=tiny(1.0_dp) ! a very small number integer(i4b),parameter :: ixBandOffset=kl+ku+1 ! offset in the band Jacobian matrix private @@ -107,7 +107,7 @@ subroutine computJacob(& ! ----------------------------------------------------------------------------------------------------------------- implicit none ! input: model control - real(rk),intent(in) :: dt ! length of the time step (seconds) + real(dp),intent(in) :: dt ! length of the time step (seconds) integer(i4b),intent(in) :: nSnow ! number of snow layers integer(i4b),intent(in) :: nSoil ! number of soil layers integer(i4b),intent(in) :: nLayers ! total number of layers in the snow+soil domain @@ -119,10 +119,10 @@ subroutine computJacob(& type(var_dlength),intent(in) :: prog_data ! prognostic variables for a local HRU type(var_dlength),intent(in) :: diag_data ! diagnostic variables for a local HRU type(var_dlength),intent(in) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables - real(rk),intent(in) :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) + real(dp),intent(in) :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) ! input-output: Jacobian and its diagonal - real(rk),intent(inout) :: dMat(:) ! diagonal of the Jacobian matrix - real(rk),intent(out) :: aJac(:,:) ! Jacobian matrix + real(dp),intent(inout) :: dMat(:) ! diagonal of the Jacobian matrix + real(dp),intent(out) :: aJac(:,:) ! Jacobian matrix ! output variables integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message @@ -140,7 +140,7 @@ subroutine computJacob(& integer(i4b) :: jLayer ! index of model layer within the full state vector (hydrology) integer(i4b) :: pLayer ! indices of soil layers (used for the baseflow derivatives) ! conversion factors - real(rk) :: convLiq2tot ! factor to convert liquid water derivative to total water derivative + real(dp) :: convLiq2tot ! factor to convert liquid water derivative to total water derivative ! -------------------------------------------------------------- ! associate variables from data structures associate(& @@ -244,7 +244,7 @@ subroutine computJacob(& ! initialize the Jacobian ! NOTE: this needs to be done every time, since Jacobian matrix is modified in the solver - aJac(:,:) = 0._rk ! analytical Jacobian matrix + aJac(:,:) = 0._dp ! analytical Jacobian matrix ! compute terms in the Jacobian for vegetation (excluding fluxes) ! NOTE: energy for vegetation is computed *within* the iteration loop as it includes phase change @@ -285,7 +285,7 @@ subroutine computJacob(& ! * diagonal elements for the vegetation canopy (-) if(ixCasNrg/=integerMissing) aJac(ixDiag,ixCasNrg) = (dt/canopyDepth)*(-dCanairNetFlux_dCanairTemp) + dMat(ixCasNrg) if(ixVegNrg/=integerMissing) aJac(ixDiag,ixVegNrg) = (dt/canopyDepth)*(-dCanopyNetFlux_dCanopyTemp) + dMat(ixVegNrg) - if(ixVegHyd/=integerMissing) aJac(ixDiag,ixVegHyd) = -scalarFracLiqVeg*(dCanopyEvaporation_dCanLiq - scalarCanopyLiqDeriv)*dt + 1._rk ! ixVegHyd: CORRECT + if(ixVegHyd/=integerMissing) aJac(ixDiag,ixVegHyd) = -scalarFracLiqVeg*(dCanopyEvaporation_dCanLiq - scalarCanopyLiqDeriv)*dt + 1._dp ! ixVegHyd: CORRECT ! * cross-derivative terms w.r.t. canopy water if(ixVegHyd/=integerMissing)then @@ -297,7 +297,7 @@ subroutine computJacob(& if(ixTopHyd/=integerMissing) aJac(ixOffDiag(ixTopHyd,ixVegHyd),ixVegHyd) = (dt/mLayerDepth(1))*(-scalarSoilControl*scalarFracLiqVeg*scalarCanopyLiqDeriv)/iden_water ! cross-derivative terms w.r.t. canopy liquid water (J m-1 kg-1) ! NOTE: dIce/dLiq = (1 - scalarFracLiqVeg); dIce*LH_fus/canopyDepth = J m-3; dLiq = kg m-2 - if(ixVegNrg/=integerMissing) aJac(ixOffDiag(ixVegNrg,ixVegHyd),ixVegHyd) = (dt/canopyDepth) *(-dCanopyNetFlux_dCanLiq) - (1._rk - scalarFracLiqVeg)*LH_fus/canopyDepth ! dF/dLiq + if(ixVegNrg/=integerMissing) aJac(ixOffDiag(ixVegNrg,ixVegHyd),ixVegHyd) = (dt/canopyDepth) *(-dCanopyNetFlux_dCanLiq) - (1._dp - scalarFracLiqVeg)*LH_fus/canopyDepth ! dF/dLiq if(ixTopNrg/=integerMissing) aJac(ixOffDiag(ixTopNrg,ixVegHyd),ixVegHyd) = (dt/mLayerDepth(1))*(-dGroundNetFlux_dCanLiq) endif @@ -369,7 +369,7 @@ subroutine computJacob(& ! compute factor to convert liquid water derivative to total water derivative select case( ixHydType(iLayer) ) case(iname_watLayer); convLiq2tot = mLayerFracLiqSnow(iLayer) - case default; convLiq2tot = 1._rk + case default; convLiq2tot = 1._dp end select ! - diagonal elements @@ -377,7 +377,7 @@ subroutine computJacob(& ! - lower-diagonal elements if(iLayer > 1)then - if(ixSnowOnlyHyd(iLayer-1)/=integerMissing) aJac(ixOffDiag(ixSnowOnlyHyd(iLayer-1),watState),watState) = 0._rk ! sub-diagonal: no dependence on other layers + if(ixSnowOnlyHyd(iLayer-1)/=integerMissing) aJac(ixOffDiag(ixSnowOnlyHyd(iLayer-1),watState),watState) = 0._dp ! sub-diagonal: no dependence on other layers endif ! - upper diagonal elements @@ -394,7 +394,7 @@ subroutine computJacob(& if(nrgstate/=integerMissing)then ! (energy state for the current layer is within the state subset) ! (cross-derivative terms for the current layer) - aJac(ixOffDiag(nrgState,watState),watState) = -(1._rk - mLayerFracLiqSnow(iLayer))*LH_fus*iden_water ! (dF/dLiq) + aJac(ixOffDiag(nrgState,watState),watState) = -(1._dp - mLayerFracLiqSnow(iLayer))*LH_fus*iden_water ! (dF/dLiq) aJac(ixOffDiag(watState,nrgState),nrgState) = (dt/mLayerDepth(iLayer))*iLayerLiqFluxSnowDeriv(iLayer)*mLayerdTheta_dTk(iLayer) ! (dVol/dT) ! (cross-derivative terms for the layer below) @@ -483,7 +483,7 @@ subroutine computJacob(& if(mLayerdTheta_dTk(jLayer) > verySmall)then ! ice is present aJac(ixOffDiag(nrgState,watState),watState) = -dVolTot_dPsi0(iLayer)*LH_fus*iden_water ! dNrg/dMat (J m-3 m-1) -- dMat changes volumetric water, and hence ice content else - aJac(ixOffDiag(nrgState,watState),watState) = 0._rk + aJac(ixOffDiag(nrgState,watState),watState) = 0._dp endif ! - compute lower diagonal elements @@ -529,7 +529,7 @@ subroutine computJacob(& if(computeVegFlux)then ! (derivatives only defined when vegetation protrudes over the surface) ! * liquid water fluxes for vegetation canopy (-) - if(ixVegHyd/=integerMissing) aJac(ixVegHyd,ixVegHyd) = -scalarFracLiqVeg*(dCanopyEvaporation_dCanLiq - scalarCanopyLiqDeriv)*dt + 1._rk + if(ixVegHyd/=integerMissing) aJac(ixVegHyd,ixVegHyd) = -scalarFracLiqVeg*(dCanopyEvaporation_dCanLiq - scalarCanopyLiqDeriv)*dt + 1._dp ! * cross-derivative terms for canopy water if(ixVegHyd/=integerMissing)then @@ -541,7 +541,7 @@ subroutine computJacob(& if(ixTopHyd/=integerMissing) aJac(ixTopHyd,ixVegHyd) = (dt/mLayerDepth(1))*(-scalarSoilControl*scalarFracLiqVeg*scalarCanopyLiqDeriv)/iden_water ! cross-derivative terms w.r.t. canopy liquid water (J m-1 kg-1) ! NOTE: dIce/dLiq = (1 - scalarFracLiqVeg); dIce*LH_fus/canopyDepth = J m-3; dLiq = kg m-2 - if(ixVegNrg/=integerMissing) aJac(ixVegNrg,ixVegHyd) = (dt/canopyDepth) *(-dCanopyNetFlux_dCanLiq) - (1._rk - scalarFracLiqVeg)*LH_fus/canopyDepth ! dF/dLiq + if(ixVegNrg/=integerMissing) aJac(ixVegNrg,ixVegHyd) = (dt/canopyDepth) *(-dCanopyNetFlux_dCanLiq) - (1._dp - scalarFracLiqVeg)*LH_fus/canopyDepth ! dF/dLiq if(ixTopNrg/=integerMissing) aJac(ixTopNrg,ixVegHyd) = (dt/mLayerDepth(1))*(-dGroundNetFlux_dCanLiq) endif @@ -615,7 +615,7 @@ subroutine computJacob(& ! compute factor to convert liquid water derivative to total water derivative select case( ixHydType(iLayer) ) case(iname_watLayer); convLiq2tot = mLayerFracLiqSnow(iLayer) - case default; convLiq2tot = 1._rk + case default; convLiq2tot = 1._dp end select ! - diagonal elements @@ -623,7 +623,7 @@ subroutine computJacob(& ! - lower-diagonal elements if(iLayer > 1)then - if(ixSnowOnlyHyd(iLayer-1)/=integerMissing) aJac(ixSnowOnlyHyd(iLayer-1),watState) = 0._rk ! sub-diagonal: no dependence on other layers + if(ixSnowOnlyHyd(iLayer-1)/=integerMissing) aJac(ixSnowOnlyHyd(iLayer-1),watState) = 0._dp ! sub-diagonal: no dependence on other layers endif ! - upper diagonal elements @@ -640,7 +640,7 @@ subroutine computJacob(& if(nrgstate/=integerMissing)then ! (energy state for the current layer is within the state subset) ! (cross-derivative terms for the current layer) - aJac(nrgState,watState) = -(1._rk - mLayerFracLiqSnow(iLayer))*LH_fus*iden_water ! (dF/dLiq) + aJac(nrgState,watState) = -(1._dp - mLayerFracLiqSnow(iLayer))*LH_fus*iden_water ! (dF/dLiq) aJac(watState,nrgState) = (dt/mLayerDepth(iLayer))*iLayerLiqFluxSnowDeriv(iLayer)*mLayerdTheta_dTk(iLayer) ! (dVol/dT) ! (cross-derivative terms for the layer below) @@ -738,7 +738,7 @@ subroutine computJacob(& if(mLayerdTheta_dTk(jLayer) > verySmall)then ! ice is present aJac(nrgState,watState) = -dVolTot_dPsi0(iLayer)*LH_fus*iden_water ! dNrg/dMat (J m-3 m-1) -- dMat changes volumetric water, and hence ice content else - aJac(nrgState,watState) = 0._rk + aJac(nrgState,watState) = 0._dp endif ! - compute lower diagonal elements diff --git a/build/source/engine/computResid.f90 b/build/source/engine/computResid.f90 index a9744b3ea..a7d04bce8 100755 --- a/build/source/engine/computResid.f90 +++ b/build/source/engine/computResid.f90 @@ -105,31 +105,31 @@ subroutine computResid(& ! -------------------------------------------------------------------------------------------------------------------------------- implicit none ! input: model control - real(rk),intent(in) :: dt ! length of the time step (seconds) + real(dp),intent(in) :: dt ! length of the time step (seconds) integer(i4b),intent(in) :: nSnow ! number of snow layers integer(i4b),intent(in) :: nSoil ! number of soil layers integer(i4b),intent(in) :: nLayers ! total number of layers in the snow+soil domain ! input: flux vectors - real(rk),intent(in) :: sMul(:) ! NOTE: qp ! state vector multiplier (used in the residual calculations) - real(rk),intent(in) :: fVec(:) ! flux vector + real(qp),intent(in) :: sMul(:) ! NOTE: qp ! state vector multiplier (used in the residual calculations) + real(dp),intent(in) :: fVec(:) ! flux vector ! input: state variables (already disaggregated into scalars and vectors) - real(rk),intent(in) :: scalarCanairTempTrial ! trial value for temperature of the canopy air space (K) - real(rk),intent(in) :: scalarCanopyTempTrial ! trial value for temperature of the vegetation canopy (K) - real(rk),intent(in) :: scalarCanopyHydTrial ! trial value for canopy water (kg m-2), either liquid water content or total water content - real(rk),intent(in) :: mLayerTempTrial(:) ! trial value for temperature of each snow/soil layer (K) - real(rk),intent(in) :: mLayerVolFracHydTrial(:) ! trial vector of volumetric water content (-), either liquid water content or total water content - real(rk),intent(in) :: scalarAquiferStorageTrial ! trial value of aquifer storage (m) + real(dp),intent(in) :: scalarCanairTempTrial ! trial value for temperature of the canopy air space (K) + real(dp),intent(in) :: scalarCanopyTempTrial ! trial value for temperature of the vegetation canopy (K) + real(dp),intent(in) :: scalarCanopyHydTrial ! trial value for canopy water (kg m-2), either liquid water content or total water content + real(dp),intent(in) :: mLayerTempTrial(:) ! trial value for temperature of each snow/soil layer (K) + real(dp),intent(in) :: mLayerVolFracHydTrial(:) ! trial vector of volumetric water content (-), either liquid water content or total water content + real(dp),intent(in) :: scalarAquiferStorageTrial ! trial value of aquifer storage (m) ! input: diagnostic variables defining the liquid water and ice content (function of state variables) - real(rk),intent(in) :: scalarCanopyIceTrial ! trial value for mass of ice on the vegetation canopy (kg m-2) - real(rk),intent(in) :: mLayerVolFracIceTrial(:) ! trial value for volumetric fraction of ice (-) + real(dp),intent(in) :: scalarCanopyIceTrial ! trial value for mass of ice on the vegetation canopy (kg m-2) + real(dp),intent(in) :: mLayerVolFracIceTrial(:) ! trial value for volumetric fraction of ice (-) ! input: data structures type(var_dlength),intent(in) :: prog_data ! prognostic variables for a local HRU type(var_dlength),intent(in) :: diag_data ! diagnostic variables for a local HRU type(var_dlength),intent(in) :: flux_data ! model fluxes for a local HRU type(var_ilength),intent(in) :: indx_data ! indices defining model states and layers ! output - real(rk),intent(out) :: rAdd(:) ! additional (sink) terms on the RHS of the state equation - real(rk),intent(out) :: rVec(:) ! NOTE: qp ! residual vector + real(dp),intent(out) :: rAdd(:) ! additional (sink) terms on the RHS of the state equation + real(qp),intent(out) :: rVec(:) ! NOTE: qp ! residual vector integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! -------------------------------------------------------------------------------------------------------------------------------- @@ -137,8 +137,8 @@ subroutine computResid(& ! -------------------------------------------------------------------------------------------------------------------------------- integer(i4b) :: iLayer ! index of layer within the snow+soil domain integer(i4b),parameter :: ixVegVolume=1 ! index of the desired vegetation control volumne (currently only one veg layer) - real(rk) :: scalarCanopyHyd ! canopy water content (kg m-2), either liquid water content or total water content - real(rk),dimension(nLayers) :: mLayerVolFracHyd ! vector of volumetric water content (-), either liquid water content or total water content + real(dp) :: scalarCanopyHyd ! canopy water content (kg m-2), either liquid water content or total water content + real(dp),dimension(nLayers) :: mLayerVolFracHyd ! vector of volumetric water content (-), either liquid water content or total water content ! -------------------------------------------------------------------------------------------------------------------------------- ! -------------------------------------------------------------------------------------------------------------------------------- ! link to the necessary variables for the residual computations @@ -189,7 +189,7 @@ subroutine computResid(& ! ----------------------- ! intialize additional terms on the RHS as zero - rAdd(:) = 0._rk + rAdd(:) = 0._dp ! compute energy associated with melt freeze for the vegetation canopy if(ixVegNrg/=integerMissing) rAdd(ixVegNrg) = rAdd(ixVegNrg) + LH_fus*(scalarCanopyIceTrial - scalarCanopyIce)/canopyDepth ! energy associated with melt/freeze (J m-3) diff --git a/build/source/engine/convE2Temp.f90 b/build/source/engine/convE2Temp.f90 index 973e2e019..81d07e77b 100755 --- a/build/source/engine/convE2Temp.f90 +++ b/build/source/engine/convE2Temp.f90 @@ -41,8 +41,8 @@ module convE2Temp_module ! define the look-up table used to compute temperature based on enthalpy integer(i4b),parameter :: nlook=10001 ! number of elements in the lookup table -real(rk),dimension(nlook),public :: E_lookup ! enthalpy values (J kg-1) -real(rk),dimension(nlook),public :: T_lookup ! temperature values (K) +real(dp),dimension(nlook),public :: E_lookup ! enthalpy values (J kg-1) +real(dp),dimension(nlook),public :: T_lookup ! temperature values (K) contains @@ -59,29 +59,29 @@ subroutine E2T_lookup(mpar_data,err,message) character(*),intent(out) :: message ! error message ! declare local variables character(len=128) :: cmessage ! error message in downwind routine - real(rk),parameter :: T_start=260.0_rk ! start temperature value where all liquid water is assumed frozen (K) - real(rk) :: T_incr,E_incr ! temperature/enthalpy increments - real(rk),dimension(nlook) :: Tk ! initial temperature vector - real(rk),dimension(nlook) :: Ey ! initial enthalpy vector - real(rk),parameter :: waterWght=1._rk ! weight applied to total water (kg m-3) --- cancels out - real(rk),dimension(nlook) :: T2deriv ! 2nd derivatives of the interpolating function at tabulated points + real(dp),parameter :: T_start=260.0_dp ! start temperature value where all liquid water is assumed frozen (K) + real(dp) :: T_incr,E_incr ! temperature/enthalpy increments + real(dp),dimension(nlook) :: Tk ! initial temperature vector + real(dp),dimension(nlook) :: Ey ! initial enthalpy vector + real(dp),parameter :: waterWght=1._dp ! weight applied to total water (kg m-3) --- cancels out + real(dp),dimension(nlook) :: T2deriv ! 2nd derivatives of the interpolating function at tabulated points integer(i4b) :: ilook ! loop through lookup table ! initialize error control err=0; message="E2T_lookup/" ! associate associate( snowfrz_scale => mpar_data%var(iLookPARAM%snowfrz_scale)%dat(1) ) ! define initial temperature vector - T_incr = (Tfreeze - T_start) / real(nlook-1, kind(rk)) ! temperature increment + T_incr = (Tfreeze - T_start) / real(nlook-1, kind(dp)) ! temperature increment Tk = arth(T_start,T_incr,nlook) ! ***** compute specific enthalpy (NOTE: J m-3 --> J kg-1) ***** do ilook=1,nlook Ey(ilook) = temp2ethpy(Tk(ilook),waterWght,snowfrz_scale)/waterWght ! (J m-3 --> J kg-1) end do ! define the final enthalpy vector - E_incr = (-Ey(1)) / real(nlook-1, kind(rk)) ! enthalpy increment + E_incr = (-Ey(1)) / real(nlook-1, kind(dp)) ! enthalpy increment E_lookup = arth(Ey(1),E_incr,nlook) ! use cubic spline interpolation to obtain temperature values at the desired values of enthalpy - call spline(Ey,Tk,1.e30_rk,1.e30_rk,T2deriv,err,cmessage) ! get the second derivatives + call spline(Ey,Tk,1.e30_dp,1.e30_dp,T2deriv,err,cmessage) ! get the second derivatives if(err/=0) then; message=trim(message)//trim(cmessage); return; end if do ilook=1,nlook call splint(Ey,Tk,T2deriv,E_lookup(ilook),T_lookup(ilook),err,cmessage) @@ -99,25 +99,25 @@ subroutine E2T_nosoil(Ey,BulkDenWater,fc_param,Tk,err,message) ! compute temperature based on enthalpy -- appropriate when no dry mass, as in snow implicit none ! declare dummy variables - real(rk),intent(in) :: Ey ! total enthalpy (J m-3) - real(rk),intent(in) :: BulkDenWater ! bulk density of water (kg m-3) - real(rk),intent(in) :: fc_param ! freezing curve parameter (K-1) - real(rk),intent(out) :: Tk ! initial temperature guess / final temperature value (K) + real(dp),intent(in) :: Ey ! total enthalpy (J m-3) + real(dp),intent(in) :: BulkDenWater ! bulk density of water (kg m-3) + real(dp),intent(in) :: fc_param ! freezing curve parameter (K-1) + real(dp),intent(out) :: Tk ! initial temperature guess / final temperature value (K) integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! declare local variables - real(rk),parameter :: dx=1.d-8 ! finite difference increment (J kg-1) - real(rk),parameter :: atol=1.d-12 ! convergence criteria (J kg-1) - real(rk) :: E_spec ! specific enthalpy (J kg-1) - real(rk) :: E_incr ! enthalpy increment + real(dp),parameter :: dx=1.d-8 ! finite difference increment (J kg-1) + real(dp),parameter :: atol=1.d-12 ! convergence criteria (J kg-1) + real(dp) :: E_spec ! specific enthalpy (J kg-1) + real(dp) :: E_incr ! enthalpy increment integer(i4b) :: niter=15 ! maximum number of iterations integer(i4b) :: iter ! iteration index integer(i4b) :: i0 ! position in lookup table - real(rk) :: Tg0,Tg1 ! trial temperatures (K) - real(rk) :: Ht0,Ht1 ! specific enthalpy, based on the trial temperatures (J kg-1) - real(rk) :: f0,f1 ! function evaluations (difference between enthalpy guesses) - real(rk) :: dh ! enthalpy derivative - real(rk) :: dT ! temperature increment + real(dp) :: Tg0,Tg1 ! trial temperatures (K) + real(dp) :: Ht0,Ht1 ! specific enthalpy, based on the trial temperatures (J kg-1) + real(dp) :: f0,f1 ! function evaluations (difference between enthalpy guesses) + real(dp) :: dh ! enthalpy derivative + real(dp) :: dT ! temperature increment ! initialize error control err=0; message="E2T_nosoil/" ! convert input of total enthalpy (J m-3) to total specific enthalpy (J kg-1) @@ -130,8 +130,8 @@ subroutine E2T_nosoil(Ey,BulkDenWater,fc_param,Tk,err,message) Tg0 = (E_spec - E_lookup(1))/Cp_ice + T_lookup(1) Tg1 = Tg0+dx ! compute enthalpy - Ht0 = temp2ethpy(Tg0,1._rk,fc_param) - Ht1 = temp2ethpy(Tg1,1._rk,fc_param) + Ht0 = temp2ethpy(Tg0,1._dp,fc_param) + Ht1 = temp2ethpy(Tg1,1._dp,fc_param) ! compute function evaluations f0 = Ht0 - E_spec f1 = Ht1 - E_spec @@ -171,7 +171,7 @@ subroutine E2T_nosoil(Ey,BulkDenWater,fc_param,Tk,err,message) ! comute new value of Tg Tg1 = Tg0+dT ! get new function evaluation - Ht1 = temp2ethpy(Tg1,1._rk,fc_param) + Ht1 = temp2ethpy(Tg1,1._dp,fc_param) f1 = Ht1 - E_spec ! compute derivative if dT dh = (f1 - f0)/dT @@ -201,17 +201,17 @@ function temp2ethpy(Tk,BulkDenWater,fc_param) ! NOTE: enthalpy is a relative value, defined as zero at Tfreeze where all water is liquid implicit none ! declare dummy variables - real(rk),intent(in) :: Tk ! layer temperature (K) - real(rk),intent(in) :: BulkDenWater ! bulk density of water (kg m-3) - real(rk),intent(in) :: fc_param ! freezing curve parameter (K-1) - real(rk) :: temp2ethpy ! return value of the function, total specific enthalpy (J m-3) + real(dp),intent(in) :: Tk ! layer temperature (K) + real(dp),intent(in) :: BulkDenWater ! bulk density of water (kg m-3) + real(dp),intent(in) :: fc_param ! freezing curve parameter (K-1) + real(dp) :: temp2ethpy ! return value of the function, total specific enthalpy (J m-3) ! declare local variables - real(rk) :: frac_liq ! fraction of liquid water - real(rk) :: enthTempWater ! temperature component of specific enthalpy for total water (liquid and ice) (J kg-1) - real(rk) :: enthMass ! mass component of specific enthalpy (J kg-1) + real(dp) :: frac_liq ! fraction of liquid water + real(dp) :: enthTempWater ! temperature component of specific enthalpy for total water (liquid and ice) (J kg-1) + real(dp) :: enthMass ! mass component of specific enthalpy (J kg-1) ! NOTE: this function assumes the freezing curve for snow ... it needs modification to use vanGenuchten functions for soil ! compute the fraction of liquid water in the given layer - frac_liq = 1._rk / ( 1._rk + ( fc_param*( Tfreeze - min(Tk,Tfreeze) ) )**2._rk ) + frac_liq = 1._dp / ( 1._dp + ( fc_param*( Tfreeze - min(Tk,Tfreeze) ) )**2._dp ) ! compute the temperature component of enthalpy for the soil constituent (J kg-1) !enthTempSoil = Cp_soil*(Tk - Tfreeze) ! compute the temperature component of enthalpy for total water (J kg-1) @@ -220,7 +220,7 @@ function temp2ethpy(Tk,BulkDenWater,fc_param) if(Tk>=Tfreeze) enthTempWater = Cp_water*(Tk - Tfreeze) ! compute the mass component of enthalpy -- energy required to melt ice (J kg-1) ! NOTE: negative enthalpy means require energy to bring to Tfreeze - enthMass = -LH_fus*(1._rk - frac_liq) + enthMass = -LH_fus*(1._dp - frac_liq) ! finally, compute the total enthalpy (J m-3) ! NOTE: this is the case for snow (no soil).. function needs modification to use vanGenuchten functions for soil temp2ethpy = BulkDenWater*(enthTempWater + enthMass) !+ BulkDenSoil*enthTempSoil diff --git a/build/source/engine/conv_funcs.f90 b/build/source/engine/conv_funcs.f90 index d31e229cb..291938630 100755 --- a/build/source/engine/conv_funcs.f90 +++ b/build/source/engine/conv_funcs.f90 @@ -36,8 +36,8 @@ module conv_funcs_module ! *************************************************************************************************************** function getLatentHeatValue(T) implicit none -real(rk),intent(in) :: T ! temperature (K) -real(rk) :: getLatentHeatValue ! latent heat of sublimation/vaporization (J kg-1) +real(dp),intent(in) :: T ! temperature (K) +real(dp) :: getLatentHeatValue ! latent heat of sublimation/vaporization (J kg-1) if(T > Tfreeze)then getLatentHeatValue = LH_vap ! latent heat of vaporization (J kg-1) else @@ -52,14 +52,14 @@ end function getLatentHeatValue function vapPress(q,p) implicit none ! input -real(rk),intent(in) :: q ! specific humidity (g g-1) -real(rk),intent(in) :: p ! pressure (Pa) +real(dp),intent(in) :: q ! specific humidity (g g-1) +real(dp),intent(in) :: p ! pressure (Pa) ! output -real(rk) :: vapPress ! vapor pressure (Pa) +real(dp) :: vapPress ! vapor pressure (Pa) ! local -real(rk) :: w ! mixing ratio -!real(rk),parameter :: w_ratio = 0.622_rk ! molecular weight ratio of water to dry air (-) -w = q / (1._rk - q) ! mixing ratio (-) +real(dp) :: w ! mixing ratio +!real(dp),parameter :: w_ratio = 0.622_dp ! molecular weight ratio of water to dry air (-) +w = q / (1._dp - q) ! mixing ratio (-) vapPress = (w/(w + w_ratio))*p ! vapor pressure (Pa) end function vapPress @@ -72,22 +72,22 @@ end function vapPress subroutine satVapPress(TC, SVP, dSVP_dT) IMPLICIT NONE ! input -real(rk), intent(in) :: TC ! temperature (C) +real(dp), intent(in) :: TC ! temperature (C) ! output -real(rk), intent(out) :: SVP ! saturation vapor pressure (Pa) -real(rk), intent(out) :: dSVP_dT ! d(SVP)/dT +real(dp), intent(out) :: SVP ! saturation vapor pressure (Pa) +real(dp), intent(out) :: dSVP_dT ! d(SVP)/dT ! local -real(rk), parameter :: X1 = 17.27_rk -real(rk), parameter :: X2 = 237.30_rk +real(dp), parameter :: X1 = 17.27_dp +real(dp), parameter :: X2 = 237.30_dp ! local (use to test derivative calculations) -real(rk),parameter :: dx = 1.e-8_rk ! finite difference increment +real(dp),parameter :: dx = 1.e-8_dp ! finite difference increment logical(lgt),parameter :: testDeriv=.false. ! flag to test the derivative !--------------------------------------------------------------------------------------------------- ! Units note : Pa = N m-2 = kg m-1 s-2 ! SATVPFRZ= 610.8 ! Saturation water vapour pressure at 273.16K (Pa) SVP = SATVPFRZ * EXP( (X1*TC)/(X2 + TC) ) ! Saturated Vapour Press (Pa) -dSVP_dT = SVP * (X1/(X2 + TC) - X1*TC/(X2 + TC)**2._rk) +dSVP_dT = SVP * (X1/(X2 + TC) - X1*TC/(X2 + TC)**2._dp) if(testDeriv) print*, 'dSVP_dT check... ', SVP, dSVP_dT, (SATVPRESS(TC+dx) - SVP)/dx END SUBROUTINE satVapPress @@ -104,10 +104,10 @@ END SUBROUTINE satVapPress FUNCTION MSLP2AIRP(MSLP, ELEV) IMPLICIT NONE -real(rk), INTENT(IN) :: MSLP ! base pressure (Pa) -real(rk), INTENT(IN) :: ELEV ! elevation difference from base (m) +REAL(DP), INTENT(IN) :: MSLP ! base pressure (Pa) +REAL(DP), INTENT(IN) :: ELEV ! elevation difference from base (m) -real(rk) :: MSLP2AIRP ! Air pressure (Pa) +REAL(DP) :: MSLP2AIRP ! Air pressure (Pa) MSLP2AIRP = MSLP * ( (293.-0.0065*ELEV) / 293. )**5.256 @@ -126,14 +126,14 @@ FUNCTION RLHUM2DEWPT(T, RLHUM) ! Compute Dewpoint temperature from Relative Humidity IMPLICIT NONE -real(rk), INTENT(IN) :: T ! Temperature (K) -real(rk), INTENT(IN) :: RLHUM ! Relative Humidity (%) +REAL(DP), INTENT(IN) :: T ! Temperature (K) +REAL(DP), INTENT(IN) :: RLHUM ! Relative Humidity (%) -real(rk) :: RLHUM2DEWPT ! Dewpoint Temp (K) +REAL(DP) :: RLHUM2DEWPT ! Dewpoint Temp (K) -real(rk) :: VPSAT ! Sat. vapour pressure at T (Pa) -real(rk) :: TDCEL ! Dewpoint temp Celcius (C) +REAL(DP) :: VPSAT ! Sat. vapour pressure at T (Pa) +REAL(DP) :: TDCEL ! Dewpoint temp Celcius (C) ! Units note : Pa = N m-2 = kg m-1 s-2 ! SATVPFRZ= 610.8 ! Saturation water vapour pressure at 273.16K (Pa) @@ -158,13 +158,13 @@ END FUNCTION RLHUM2DEWPT FUNCTION DEWPT2RLHUM(T, DEWPT) IMPLICIT NONE -real(rk), INTENT(IN) :: T ! Temperature (K) -real(rk), INTENT(IN) :: DEWPT ! Dewpoint temp (K) +REAL(DP), INTENT(IN) :: T ! Temperature (K) +REAL(DP), INTENT(IN) :: DEWPT ! Dewpoint temp (K) -real(rk) :: DEWPT2RLHUM ! Relative Humidity (%) +REAL(DP) :: DEWPT2RLHUM ! Relative Humidity (%) -real(rk) :: VPSAT ! Sat. vapour pressure at T (Pa) -real(rk) :: TDCEL ! Dewpt in celcius (C) +REAL(DP) :: VPSAT ! Sat. vapour pressure at T (Pa) +REAL(DP) :: TDCEL ! Dewpt in celcius (C) ! Units note : Pa = N m-2 = kg m-1 s-2 ! SATVPFRZ= 610.8 ! Saturation water vapour pressure at 273.16K (Pa) @@ -188,13 +188,13 @@ END FUNCTION DEWPT2RLHUM FUNCTION DEWPT2SPHM(DEWPT, PRESS) IMPLICIT NONE -real(rk), INTENT(IN) :: DEWPT ! Dewpoint temp (K) -real(rk), INTENT(IN) :: PRESS ! Pressure (Pa) +REAL(DP), INTENT(IN) :: DEWPT ! Dewpoint temp (K) +REAL(DP), INTENT(IN) :: PRESS ! Pressure (Pa) -real(rk) :: DEWPT2SPHM ! Specific Humidity (g/g) +REAL(DP) :: DEWPT2SPHM ! Specific Humidity (g/g) -real(rk) :: VPAIR ! vapour pressure at T (Pa) -real(rk) :: TDCEL ! Dewpt in celcius (C) +REAL(DP) :: VPAIR ! vapour pressure at T (Pa) +REAL(DP) :: TDCEL ! Dewpt in celcius (C) ! Units note : Pa = N m-2 = kg m-1 s-2 ! SATVPFRZ= 610.8 ! Saturation water vapour pressure at 273.16K (Pa) @@ -218,10 +218,10 @@ END FUNCTION DEWPT2SPHM FUNCTION DEWPT2VPAIR(DEWPT) IMPLICIT NONE -real(rk), INTENT(IN) :: DEWPT ! Dewpoint temp (K) -real(rk) :: TDCEL ! Dewpt in celcius (C) +REAL(DP), INTENT(IN) :: DEWPT ! Dewpoint temp (K) +REAL(DP) :: TDCEL ! Dewpt in celcius (C) -real(rk) :: DEWPT2VPAIR ! Vapour Press (Pa) +REAL(DP) :: DEWPT2VPAIR ! Vapour Press (Pa) ! Units note : Pa = N m-2 = kg m-1 s-2 ! SATVPFRZ= 610.8 ! Saturation water vapour pressure at 273.16K (Pa) @@ -243,15 +243,15 @@ END FUNCTION DEWPT2VPAIR FUNCTION SPHM2RELHM(SPHM, PRESS, TAIR) IMPLICIT NONE -real(rk), INTENT(IN) :: SPHM ! Specific Humidity (g/g) -real(rk), INTENT(IN) :: PRESS ! Pressure (Pa) -real(rk), INTENT(IN) :: TAIR ! Air temp +REAL(DP), INTENT(IN) :: SPHM ! Specific Humidity (g/g) +REAL(DP), INTENT(IN) :: PRESS ! Pressure (Pa) +REAL(DP), INTENT(IN) :: TAIR ! Air temp -real(rk) :: SPHM2RELHM ! Dewpoint Temp (K) +REAL(DP) :: SPHM2RELHM ! Dewpoint Temp (K) -real(rk) :: VPSAT ! vapour pressure at T (Pa) -real(rk) :: TDCEL ! Dewpt in celcius (C) -!real(rk) :: DUM ! Intermediate +REAL(DP) :: VPSAT ! vapour pressure at T (Pa) +REAL(DP) :: TDCEL ! Dewpt in celcius (C) +!REAL(DP) :: DUM ! Intermediate ! Units note : Pa = N m-2 = kg m-1 s-2 ! SATVPFRZ= 610.8 ! Saturation water vapour pressure at 273.16K (Pa) @@ -274,15 +274,15 @@ END FUNCTION SPHM2RELHM FUNCTION RELHM2SPHM(RELHM, PRESS, TAIR) IMPLICIT NONE -real(rk), INTENT(IN) :: RELHM ! Relative Humidity (%) -real(rk), INTENT(IN) :: PRESS ! Pressure (Pa) -real(rk), INTENT(IN) :: TAIR ! Air temp +REAL(DP), INTENT(IN) :: RELHM ! Relative Humidity (%) +REAL(DP), INTENT(IN) :: PRESS ! Pressure (Pa) +REAL(DP), INTENT(IN) :: TAIR ! Air temp -real(rk) :: RELHM2SPHM ! Specific Humidity (g/g) +REAL(DP) :: RELHM2SPHM ! Specific Humidity (g/g) -real(rk) :: PVP ! Partial vapour pressure at T (Pa) -real(rk) :: TDCEL ! Dewpt in celcius (C) -!real(rk) :: DUM ! Intermediate +REAL(DP) :: PVP ! Partial vapour pressure at T (Pa) +REAL(DP) :: TDCEL ! Dewpt in celcius (C) +!REAL(DP) :: DUM ! Intermediate ! Units note : Pa = N m-2 = kg m-1 s-2 ! SATVPFRZ= 610.8 ! Saturation water vapour pressure at 273.16K (Pa) @@ -300,31 +300,31 @@ END FUNCTION RELHM2SPHM FUNCTION WETBULBTMP(TAIR, RELHM, PRESS) IMPLICIT NONE ! input -real(rk), INTENT(IN) :: TAIR ! Air temp (K) -real(rk), INTENT(IN) :: RELHM ! Relative Humidity (-) -real(rk), INTENT(IN) :: PRESS ! Pressure (Pa) +REAL(DP), INTENT(IN) :: TAIR ! Air temp (K) +REAL(DP), INTENT(IN) :: RELHM ! Relative Humidity (-) +REAL(DP), INTENT(IN) :: PRESS ! Pressure (Pa) ! output -real(rk) :: WETBULBTMP ! Wet bulb temperature (K) +REAL(DP) :: WETBULBTMP ! Wet bulb temperature (K) ! locals -real(rk) :: Tcel ! Temperature in celcius (C) -real(rk) :: PVP ! Partial vapor pressure (Pa) -real(rk) :: TWcel ! Wet bulb temperature in celcius (C) -real(rk),PARAMETER :: k=6.54E-4_DP ! normalizing factor in wet bulb estimate (C-1) -real(rk) :: Twet_trial0 ! trial value for wet bulb temperature (C) -real(rk) :: Twet_trial1 ! trial value for wet bulb temperature (C) -real(rk) :: f0,f1 ! function evaluations (C) -real(rk) :: df_dT ! derivative (-) -real(rk) :: TWinc ! wet bulb temperature increment (C) +REAL(DP) :: Tcel ! Temperature in celcius (C) +REAL(DP) :: PVP ! Partial vapor pressure (Pa) +REAL(DP) :: TWcel ! Wet bulb temperature in celcius (C) +REAL(DP),PARAMETER :: k=6.54E-4_DP ! normalizing factor in wet bulb estimate (C-1) +REAL(DP) :: Twet_trial0 ! trial value for wet bulb temperature (C) +REAL(DP) :: Twet_trial1 ! trial value for wet bulb temperature (C) +REAL(DP) :: f0,f1 ! function evaluations (C) +REAL(DP) :: df_dT ! derivative (-) +REAL(DP) :: TWinc ! wet bulb temperature increment (C) INTEGER(I4B) :: iter ! iterattion index -real(rk),PARAMETER :: Xoff=1.E-5_DP ! finite difference increment (C) -real(rk),PARAMETER :: Xtol=1.E-8_DP ! convergence tolerance (C) +REAL(DP),PARAMETER :: Xoff=1.E-5_DP ! finite difference increment (C) +REAL(DP),PARAMETER :: Xtol=1.E-8_DP ! convergence tolerance (C) INTEGER(I4B) :: maxiter=15 ! maximum number of iterations ! convert temperature to Celcius Tcel = TAIR-TFREEZE ! compute partial vapor pressure based on temperature (Pa) PVP = RELHM * SATVPRESS(Tcel) ! define an initial trial value for wetbulb temperature -TWcel = Tcel - 5._rk +TWcel = Tcel - 5._dp ! iterate until convergence do iter=1,maxiter ! compute Twet estimates @@ -358,9 +358,9 @@ END FUNCTION WETBULBTMP ! *************************************************************************************************************** FUNCTION SATVPRESS(TCEL) IMPLICIT NONE -real(rk),INTENT(IN) :: TCEL ! Temperature (C) -real(rk) :: SATVPRESS ! Saturated vapor pressure (Pa) -SATVPRESS = SATVPFRZ * EXP( (17.27_rk*TCEL)/(237.30_rk + TCEL) ) ! Saturated Vapour Press (Pa) +REAL(DP),INTENT(IN) :: TCEL ! Temperature (C) +REAL(DP) :: SATVPRESS ! Saturated vapor pressure (Pa) +SATVPRESS = SATVPFRZ * EXP( (17.27_dp*TCEL)/(237.30_dp + TCEL) ) ! Saturated Vapour Press (Pa) END FUNCTION SATVPRESS diff --git a/build/source/engine/coupled_em.f90 b/build/source/engine/coupled_em.f90 index 7e14de0d9..88fd044da 100755 --- a/build/source/engine/coupled_em.f90 +++ b/build/source/engine/coupled_em.f90 @@ -89,10 +89,10 @@ module coupled_em_module private public::coupled_em ! algorithmic parameters -real(rk),parameter :: valueMissing=-9999._rk ! missing value, used when diagnostic or state variables are undefined -real(rk),parameter :: verySmall=1.e-6_rk ! used as an additive constant to check if substantial difference among real numbers -real(rk),parameter :: mpe=1.e-6_rk ! prevents overflow error if division by zero -real(rk),parameter :: dx=1.e-6_rk ! finite difference increment +real(dp),parameter :: valueMissing=-9999._dp ! missing value, used when diagnostic or state variables are undefined +real(dp),parameter :: verySmall=1.e-6_dp ! used as an additive constant to check if substantial difference among real numbers +real(dp),parameter :: mpe=1.e-6_dp ! prevents overflow error if division by zero +real(dp),parameter :: dx=1.e-6_dp ! finite difference increment contains @@ -148,7 +148,7 @@ subroutine coupled_em(& implicit none ! model control integer(8),intent(in) :: hruId ! hruId - real(rk),intent(inout) :: dt_init ! used to initialize the size of the sub-step + real(dp),intent(inout) :: dt_init ! used to initialize the size of the sub-step logical(lgt),intent(inout) :: computeVegFlux ! flag to indicate if we are computing fluxes over vegetation (.false. means veg is buried with snow) ! data structures (input) type(var_i),intent(in) :: type_data ! type of vegetation and soil @@ -172,12 +172,12 @@ subroutine coupled_em(& integer(i4b) :: nSoil ! number of soil layers integer(i4b) :: nLayers ! total number of layers integer(i4b) :: nState ! total number of state variables - real(rk) :: dtSave ! length of last input model sub-step (seconds) - real(rk) :: dt_sub ! length of model sub-step (seconds) - real(rk) :: dt_wght ! weight applied to model sub-step (dt_sub/data_step) - real(rk) :: dt_solv ! seconds in the data step that have been completed - real(rk) :: dtMultiplier ! time step multiplier (-) based on what happenned in "opSplittin" - real(rk) :: minstep,maxstep ! minimum and maximum time step length (seconds) + real(dp) :: dtSave ! length of last input model sub-step (seconds) + real(dp) :: dt_sub ! length of model sub-step (seconds) + real(dp) :: dt_wght ! weight applied to model sub-step (dt_sub/data_step) + real(dp) :: dt_solv ! seconds in the data step that have been completed + real(dp) :: dtMultiplier ! time step multiplier (-) based on what happenned in "opSplittin" + real(dp) :: minstep,maxstep ! minimum and maximum time step length (seconds) integer(i4b) :: nsub ! number of substeps logical(lgt) :: computeVegFluxOld ! flag to indicate if we are computing fluxes over vegetation on the previous sub step logical(lgt) :: includeAquifer ! flag to denote that an aquifer is included @@ -185,16 +185,16 @@ subroutine coupled_em(& logical(lgt) :: modifiedVegState ! flag to denote that vegetation states were modified type(var_dlength) :: flux_mean ! timestep-average model fluxes for a local HRU integer(i4b) :: nLayersRoots ! number of soil layers that contain roots - real(rk) :: exposedVAI ! exposed vegetation area index - real(rk) :: dCanopyWetFraction_dWat ! derivative in wetted fraction w.r.t. canopy total water (kg-1 m2) - real(rk) :: dCanopyWetFraction_dT ! derivative in wetted fraction w.r.t. canopy temperature (K-1) - real(rk),parameter :: varNotUsed1=-9999._rk ! variables used to calculate derivatives (not needed here) - real(rk),parameter :: varNotUsed2=-9999._rk ! variables used to calculate derivatives (not needed here) + real(dp) :: exposedVAI ! exposed vegetation area index + real(dp) :: dCanopyWetFraction_dWat ! derivative in wetted fraction w.r.t. canopy total water (kg-1 m2) + real(dp) :: dCanopyWetFraction_dT ! derivative in wetted fraction w.r.t. canopy temperature (K-1) + real(dp),parameter :: varNotUsed1=-9999._dp ! variables used to calculate derivatives (not needed here) + real(dp),parameter :: varNotUsed2=-9999._dp ! variables used to calculate derivatives (not needed here) integer(i4b) :: iSnow ! index of snow layers integer(i4b) :: iLayer ! index of model layers - real(rk) :: massLiquid ! mass liquid water (kg m-2) - real(rk) :: superflousSub ! superflous sublimation (kg m-2 s-1) - real(rk) :: superflousNrg ! superflous energy that cannot be used for sublimation (W m-2 [J m-2 s-1]) + real(dp) :: massLiquid ! mass liquid water (kg m-2) + real(dp) :: superflousSub ! superflous sublimation (kg m-2 s-1) + real(dp) :: superflousNrg ! superflous energy that cannot be used for sublimation (W m-2 [J m-2 s-1]) integer(i4b) :: ixSolution ! solution method used by opSplitting logical(lgt) :: firstSubStep ! flag to denote if the first time step logical(lgt) :: stepFailure ! flag to denote the need to reduce length of the coupled step and try again @@ -206,34 +206,34 @@ subroutine coupled_em(& type(var_dlength) :: prog_temp ! temporary model prognostic variables type(var_dlength) :: diag_temp ! temporary model diagnostic variables ! check SWE - real(rk) :: oldSWE ! SWE at the start of the substep - real(rk) :: newSWE ! SWE at the end of the substep - real(rk) :: delSWE ! change in SWE over the subtep - real(rk) :: effRainfall ! effective rainfall (kg m-2 s-1) - real(rk) :: effSnowfall ! effective snowfall (kg m-2 s-1) - real(rk) :: sfcMeltPond ! surface melt pond (kg m-2) - real(rk) :: massBalance ! mass balance error (kg m-2) + real(dp) :: oldSWE ! SWE at the start of the substep + real(dp) :: newSWE ! SWE at the end of the substep + real(dp) :: delSWE ! change in SWE over the subtep + real(dp) :: effRainfall ! effective rainfall (kg m-2 s-1) + real(dp) :: effSnowfall ! effective snowfall (kg m-2 s-1) + real(dp) :: sfcMeltPond ! surface melt pond (kg m-2) + real(dp) :: massBalance ! mass balance error (kg m-2) ! balance checks integer(i4b) :: iVar ! loop through model variables - real(rk) :: totalSoilCompress ! total soil compression (kg m-2) - real(rk) :: scalarCanopyWatBalError ! water balance error for the vegetation canopy (kg m-2) - real(rk) :: scalarSoilWatBalError ! water balance error (kg m-2) - real(rk) :: scalarInitCanopyLiq ! initial liquid water on the vegetation canopy (kg m-2) - real(rk) :: scalarInitCanopyIce ! initial ice on the vegetation canopy (kg m-2) - real(rk) :: balanceCanopyWater0 ! total water stored in the vegetation canopy at the start of the step (kg m-2) - real(rk) :: balanceCanopyWater1 ! total water stored in the vegetation canopy at the end of the step (kg m-2) - real(rk) :: balanceSoilWater0 ! total soil storage at the start of the step (kg m-2) - real(rk) :: balanceSoilWater1 ! total soil storage at the end of the step (kg m-2) - real(rk) :: balanceSoilInflux ! input to the soil zone - real(rk) :: balanceSoilBaseflow ! output from the soil zone - real(rk) :: balanceSoilDrainage ! output from the soil zone - real(rk) :: balanceSoilET ! output from the soil zone - real(rk) :: balanceAquifer0 ! total aquifer storage at the start of the step (kg m-2) - real(rk) :: balanceAquifer1 ! total aquifer storage at the end of the step (kg m-2) + real(dp) :: totalSoilCompress ! total soil compression (kg m-2) + real(dp) :: scalarCanopyWatBalError ! water balance error for the vegetation canopy (kg m-2) + real(dp) :: scalarSoilWatBalError ! water balance error (kg m-2) + real(dp) :: scalarInitCanopyLiq ! initial liquid water on the vegetation canopy (kg m-2) + real(dp) :: scalarInitCanopyIce ! initial ice on the vegetation canopy (kg m-2) + real(dp) :: balanceCanopyWater0 ! total water stored in the vegetation canopy at the start of the step (kg m-2) + real(dp) :: balanceCanopyWater1 ! total water stored in the vegetation canopy at the end of the step (kg m-2) + real(dp) :: balanceSoilWater0 ! total soil storage at the start of the step (kg m-2) + real(dp) :: balanceSoilWater1 ! total soil storage at the end of the step (kg m-2) + real(dp) :: balanceSoilInflux ! input to the soil zone + real(dp) :: balanceSoilBaseflow ! output from the soil zone + real(dp) :: balanceSoilDrainage ! output from the soil zone + real(dp) :: balanceSoilET ! output from the soil zone + real(dp) :: balanceAquifer0 ! total aquifer storage at the start of the step (kg m-2) + real(dp) :: balanceAquifer1 ! total aquifer storage at the end of the step (kg m-2) ! test balance checks logical(lgt), parameter :: printBalance=.false. ! flag to print the balance checks - real(rk), allocatable :: liqSnowInit(:) ! volumetric liquid water conetnt of snow at the start of the time step - real(rk), allocatable :: liqSoilInit(:) ! soil moisture at the start of the time step + real(dp), allocatable :: liqSnowInit(:) ! volumetric liquid water conetnt of snow at the start of the time step + real(dp), allocatable :: liqSoilInit(:) ! soil moisture at the start of the time step ! ---------------------------------------------------------------------------------------------------------------------------------------------- ! initialize error control err=0; message="coupled_em/" @@ -300,12 +300,12 @@ subroutine coupled_em(& if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; end if ! initialize compression and surface melt pond - sfcMeltPond = 0._rk ! change in storage associated with the surface melt pond (kg m-2) - totalSoilCompress = 0._rk ! change in soil storage associated with compression of the matrix (kg m-2) + sfcMeltPond = 0._dp ! change in storage associated with the surface melt pond (kg m-2) + totalSoilCompress = 0._dp ! change in soil storage associated with compression of the matrix (kg m-2) ! initialize mean fluxes do iVar=1,size(averageFlux_meta) - flux_mean%var(iVar)%dat(:) = 0._rk + flux_mean%var(iVar)%dat(:) = 0._dp end do ! associate local variables with information in the data structures @@ -354,7 +354,7 @@ subroutine coupled_em(& ! short-cut to the algorithmic control parameters ! NOTE - temporary assignment of minstep to foce something reasonable - minstep = 10._rk ! mpar_data%var(iLookPARAM%minstep)%dat(1) ! minimum time step (s) + minstep = 10._dp ! mpar_data%var(iLookPARAM%minstep)%dat(1) ! minimum time step (s) maxstep = mpar_data%var(iLookPARAM%maxstep)%dat(1) ! maximum time step (s) !print*, 'minstep, maxstep = ', minstep, maxstep @@ -366,7 +366,7 @@ subroutine coupled_em(& end if ! define the foliage nitrogen factor - diag_data%var(iLookDIAG%scalarFoliageNitrogenFactor)%dat(1) = 1._rk ! foliage nitrogen concentration (1.0 = saturated) + diag_data%var(iLookDIAG%scalarFoliageNitrogenFactor)%dat(1) = 1._dp ! foliage nitrogen concentration (1.0 = saturated) ! save SWE oldSWE = prog_data%var(iLookPROG%scalarSWE)%dat(1) @@ -377,7 +377,7 @@ subroutine coupled_em(& ! ------------------------ ! compute the temperature of the root zone: used in vegetation phenology - diag_data%var(iLookDIAG%scalarRootZoneTemp)%dat(1) = sum(prog_data%var(iLookPROG%mLayerTemp)%dat(nSnow+1:nSnow+nLayersRoots)) / real(nLayersRoots, kind(rk)) + diag_data%var(iLookDIAG%scalarRootZoneTemp)%dat(1) = sum(prog_data%var(iLookPROG%mLayerTemp)%dat(nSnow+1:nSnow+nLayersRoots)) / real(nLayersRoots, kind(dp)) ! remember if we compute the vegetation flux on the previous sub-step computeVegFluxOld = computeVegFlux @@ -421,7 +421,7 @@ subroutine coupled_em(& ! NOTE 3: use maximum per unit leaf area storage capacity for snow (kg m-2) select case(model_decisions(iLookDECISIONS%snowIncept)%iDecision) case(lightSnow); diag_data%var(iLookDIAG%scalarCanopyIceMax)%dat(1) = exposedVAI*mpar_data%var(iLookPARAM%refInterceptCapSnow)%dat(1) - case(stickySnow); diag_data%var(iLookDIAG%scalarCanopyIceMax)%dat(1) = exposedVAI*mpar_data%var(iLookPARAM%refInterceptCapSnow)%dat(1)*4._rk + case(stickySnow); diag_data%var(iLookDIAG%scalarCanopyIceMax)%dat(1) = exposedVAI*mpar_data%var(iLookPARAM%refInterceptCapSnow)%dat(1)*4._dp case default; message=trim(message)//'unable to identify option for maximum branch interception capacity'; err=20; return end select ! identifying option for maximum branch interception capacity !print*, 'diag_data%var(iLookDIAG%scalarCanopyLiqMax)%dat(1) = ', diag_data%var(iLookDIAG%scalarCanopyLiqMax)%dat(1) @@ -454,9 +454,9 @@ subroutine coupled_em(& ! vegetation is completely buried by snow (or no veg exists at all) else - diag_data%var(iLookDIAG%scalarCanopyWetFraction)%dat(1) = 0._rk - dCanopyWetFraction_dWat = 0._rk - dCanopyWetFraction_dT = 0._rk + diag_data%var(iLookDIAG%scalarCanopyWetFraction)%dat(1) = 0._dp + dCanopyWetFraction_dWat = 0._dp + dCanopyWetFraction_dT = 0._dp end if ! *** compute snow albedo... @@ -533,10 +533,10 @@ subroutine coupled_em(& ! NOTE 2: this initialization needs to be done AFTER the call to canopySnow, since canopySnow uses canopy drip drom the previous time step if(.not.computeVegFlux)then flux_data%var(iLookFLUX%scalarThroughfallRain)%dat(1) = flux_data%var(iLookFLUX%scalarRainfall)%dat(1) - flux_data%var(iLookFLUX%scalarCanopyLiqDrainage)%dat(1) = 0._rk + flux_data%var(iLookFLUX%scalarCanopyLiqDrainage)%dat(1) = 0._dp else - flux_data%var(iLookFLUX%scalarThroughfallRain)%dat(1) = 0._rk - flux_data%var(iLookFLUX%scalarCanopyLiqDrainage)%dat(1) = 0._rk + flux_data%var(iLookFLUX%scalarThroughfallRain)%dat(1) = 0._dp + flux_data%var(iLookFLUX%scalarCanopyLiqDrainage)%dat(1) = 0._dp end if ! **************************************************************************************************** @@ -544,7 +544,7 @@ subroutine coupled_em(& ! **************************************************************************************************** ! initialize the length of the sub-step - dt_solv = 0._rk ! length of time step that has been completed (s) + dt_solv = 0._dp ! length of time step that has been completed (s) dt_init = min(data_step,maxstep) ! initial substep length (s) dt_sub = dt_init ! length of substep dtSave = dt_init ! length of substep @@ -762,7 +762,7 @@ subroutine coupled_em(& if(stepFailure)then ! halve step - dt_sub = dtSave/2._rk + dt_sub = dtSave/2._dp ! check that the step is not tiny if(dt_sub < minstep)then @@ -804,13 +804,13 @@ subroutine coupled_em(& scalarCanopyIce = scalarCanopyIce + scalarCanopySublimation*dt_sub ! if removed all ice, take the remaining sublimation from water - if(scalarCanopyIce < 0._rk)then + if(scalarCanopyIce < 0._dp)then scalarCanopyLiq = scalarCanopyLiq + scalarCanopyIce - scalarCanopyIce = 0._rk + scalarCanopyIce = 0._dp endif ! modify fluxes if there is insufficient canopy water to support the converged sublimation rate over the time step dt_sub - if(scalarCanopyLiq < 0._rk)then + if(scalarCanopyLiq < 0._dp)then ! --> superfluous sublimation flux superflousSub = -scalarCanopyLiq/dt_sub ! kg m-2 s-1 superflousNrg = superflousSub*LH_sub ! W m-2 (J m-2 s-1) @@ -818,7 +818,7 @@ subroutine coupled_em(& scalarCanopySublimation = scalarCanopySublimation + superflousSub scalarLatHeatCanopyEvap = scalarLatHeatCanopyEvap + superflousNrg scalarSenHeatCanopy = scalarSenHeatCanopy - superflousNrg - scalarCanopyLiq = 0._rk + scalarCanopyLiq = 0._dp endif end if ! (if computing the vegetation flux) @@ -842,7 +842,7 @@ subroutine coupled_em(& if(mLayerDepth(iSnow) < verySmall)then stepFailure = .true. doLayerMerge = .true. - dt_sub = max(dtSave/2._rk, minstep) + dt_sub = max(dtSave/2._dp, minstep) cycle substeps else stepFailure = .false. @@ -1060,7 +1060,7 @@ subroutine coupled_em(& ! NOTE: need to put the balance checks in the sub-step loop so that we can re-compute if necessary scalarCanopyWatBalError = balanceCanopyWater1 - (balanceCanopyWater0 + (scalarSnowfall - averageThroughfallSnow)*data_step + (scalarRainfall - averageThroughfallRain)*data_step & - averageCanopySnowUnloading*data_step - averageCanopyLiqDrainage*data_step + averageCanopySublimation*data_step + averageCanopyEvaporation*data_step) - if(abs(scalarCanopyWatBalError) > absConvTol_liquid*iden_water*10._rk)then + if(abs(scalarCanopyWatBalError) > absConvTol_liquid*iden_water*10._dp)then print*, '** canopy water balance error:' write(*,'(a,1x,f20.10)') 'data_step = ', data_step write(*,'(a,1x,f20.10)') 'balanceCanopyWater0 = ', balanceCanopyWater0 @@ -1167,7 +1167,7 @@ subroutine coupled_em(& ! check the soil water balance scalarSoilWatBalError = balanceSoilWater1 - (balanceSoilWater0 + (balanceSoilInflux + balanceSoilET - balanceSoilBaseflow - balanceSoilDrainage - totalSoilCompress) ) - if(abs(scalarSoilWatBalError) > absConvTol_liquid*iden_water*10._rk)then ! NOTE: kg m-2, so need coarse tolerance to account for precision issues + if(abs(scalarSoilWatBalError) > absConvTol_liquid*iden_water*10._dp)then ! NOTE: kg m-2, so need coarse tolerance to account for precision issues write(*,*) 'solution method = ', ixSolution write(*,'(a,1x,f20.10)') 'data_step = ', data_step write(*,'(a,1x,f20.10)') 'totalSoilCompress = ', totalSoilCompress @@ -1232,24 +1232,24 @@ subroutine implctMelt(& err,message ) ! intent(out): error control implicit none ! input/output: integrated snowpack properties - real(rk),intent(inout) :: scalarSWE ! snow water equivalent (kg m-2) - real(rk),intent(inout) :: scalarSnowDepth ! snow depth (m) - real(rk),intent(inout) :: scalarSfcMeltPond ! surface melt pond (kg m-2) + real(dp),intent(inout) :: scalarSWE ! snow water equivalent (kg m-2) + real(dp),intent(inout) :: scalarSnowDepth ! snow depth (m) + real(dp),intent(inout) :: scalarSfcMeltPond ! surface melt pond (kg m-2) ! input/output: properties of the upper-most soil layer - real(rk),intent(inout) :: soilTemp ! surface layer temperature (K) - real(rk),intent(inout) :: soilDepth ! surface layer depth (m) - real(rk),intent(inout) :: soilHeatcap ! surface layer volumetric heat capacity (J m-3 K-1) + real(dp),intent(inout) :: soilTemp ! surface layer temperature (K) + real(dp),intent(inout) :: soilDepth ! surface layer depth (m) + real(dp),intent(inout) :: soilHeatcap ! surface layer volumetric heat capacity (J m-3 K-1) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! local variables - real(rk) :: nrgRequired ! energy required to melt all the snow (J m-2) - real(rk) :: nrgAvailable ! energy available to melt the snow (J m-2) - real(rk) :: snwDensity ! snow density (kg m-3) + real(dp) :: nrgRequired ! energy required to melt all the snow (J m-2) + real(dp) :: nrgAvailable ! energy available to melt the snow (J m-2) + real(dp) :: snwDensity ! snow density (kg m-3) ! initialize error control err=0; message='implctMelt/' - if(scalarSWE > 0._rk)then + if(scalarSWE > 0._dp)then ! only melt if temperature of the top soil layer is greater than Tfreeze if(soilTemp > Tfreeze)then ! compute the energy required to melt all the snow (J m-2) @@ -1261,7 +1261,7 @@ subroutine implctMelt(& ! compute the amount of melt, and update SWE (kg m-2) if(nrgAvailable > nrgRequired)then scalarSfcMeltPond = scalarSWE - scalarSWE = 0._rk + scalarSWE = 0._dp else scalarSfcMeltPond = nrgAvailable/LH_fus scalarSWE = scalarSWE - scalarSfcMeltPond @@ -1271,10 +1271,10 @@ subroutine implctMelt(& ! update temperature of the top soil layer (K) soilTemp = soilTemp - (LH_fus*scalarSfcMeltPond/soilDepth)/soilHeatcap else ! melt is zero if the temperature of the top soil layer is less than Tfreeze - scalarSfcMeltPond = 0._rk ! kg m-2 + scalarSfcMeltPond = 0._dp ! kg m-2 end if ! (if the temperature of the top soil layer is greater than Tfreeze) else ! melt is zero if the "snow without a layer" does not exist - scalarSfcMeltPond = 0._rk ! kg m-2 + scalarSfcMeltPond = 0._dp ! kg m-2 end if ! (if the "snow without a layer" exists) end subroutine implctMelt diff --git a/build/source/engine/derivforce.f90 b/build/source/engine/derivforce.f90 index 8b0033632..563d9f1f0 100755 --- a/build/source/engine/derivforce.f90 +++ b/build/source/engine/derivforce.f90 @@ -74,8 +74,8 @@ subroutine derivforce(time_data,forc_data,attr_data,mpar_data,prog_data,diag_dat implicit none ! input variables integer(i4b), intent(in) :: time_data(:) ! vector of time data for a given time step - real(rk), intent(inout) :: forc_data(:) ! vector of forcing data for a given time step - real(rk), intent(in) :: attr_data(:) ! vector of model attributes + real(dp), intent(inout) :: forc_data(:) ! vector of forcing data for a given time step + real(dp), intent(in) :: attr_data(:) ! vector of model attributes type(var_dlength),intent(in) :: mpar_data ! vector of model parameters type(var_dlength),intent(in) :: prog_data ! data structure of model prognostic variables for a local HRU ! output variables @@ -86,33 +86,33 @@ subroutine derivforce(time_data,forc_data,attr_data,mpar_data,prog_data,diag_dat ! local time integer(i4b) :: jyyy,jm,jd ! year, month, day integer(i4b) :: jh,jmin ! hour, minute - real(rk) :: dsec ! double precision seconds (not used) - real(rk) :: timeOffset ! time offset from Grenwich (days) - real(rk) :: julianTime ! local julian time + real(dp) :: dsec ! double precision seconds (not used) + real(dp) :: timeOffset ! time offset from Grenwich (days) + real(dp) :: julianTime ! local julian time ! cosine of the solar zenith angle - real(rk) :: ahour ! hour at start of time step - real(rk) :: dataStep ! data step (hours) - real(rk),parameter :: slope=0._rk ! terrain slope (assume flat) - real(rk),parameter :: azimuth=0._rk ! terrain azimuth (assume zero) - real(rk) :: hri ! average radiation index over time step DT + real(dp) :: ahour ! hour at start of time step + real(dp) :: dataStep ! data step (hours) + real(dp),parameter :: slope=0._dp ! terrain slope (assume flat) + real(dp),parameter :: azimuth=0._dp ! terrain azimuth (assume zero) + real(dp) :: hri ! average radiation index over time step DT ! general local variables character(len=256) :: cmessage ! error message for downwind routine integer(i4b),parameter :: nBands=2 ! number of spectral bands - real(rk),parameter :: valueMissing=-9999._rk ! missing value - real(rk),parameter :: co2Factor=355.e-6_rk ! empirical factor to obtain partial pressure of co2 - real(rk),parameter :: o2Factor=0.209_rk ! empirical factor to obtain partial pressure of o2 - real(rk),parameter :: minMeasHeight=1._rk ! minimum measurement height (m) - real(rk) :: relhum ! relative humidity (-) - real(rk) :: fracrain ! fraction of precipitation that falls as rain - real(rk) :: maxFrozenSnowTemp ! maximum temperature of snow when the snow is predominantely frozen (K) - real(rk),parameter :: unfrozenLiq=0.01_rk ! unfrozen liquid water used to compute maxFrozenSnowTemp (-) - real(rk),parameter :: eps=epsilon(fracrain) ! a number that is almost negligible - real(rk) :: Tmin,Tmax ! minimum and maximum wet bulb temperature in the time step (K) - real(rk),parameter :: pomNewSnowDenMax=150._rk ! Upper limit for new snow density limit in Hedstrom and Pomeroy 1998. 150 was used because at was the highest observed density at air temperatures used in this study. See Figure 4 of Hedstrom and Pomeroy (1998). - real(rk),parameter :: andersonWarmDenLimit=2._rk ! Upper air temperature limit in Anderson (1976) new snow density (C) - real(rk),parameter :: andersonColdDenLimit=15._rk! Lower air temperature limit in Anderson (1976) new snow density (C) - real(rk),parameter :: andersonDenScal=1.5_rk ! Scalar parameter in Anderson (1976) new snow density function (-) - real(rk),parameter :: pahautDenWindScal=0.5_rk ! Scalar parameter for wind impacts on density using Pahaut (1976) function (-) + real(dp),parameter :: valueMissing=-9999._dp ! missing value + real(dp),parameter :: co2Factor=355.e-6_dp ! empirical factor to obtain partial pressure of co2 + real(dp),parameter :: o2Factor=0.209_dp ! empirical factor to obtain partial pressure of o2 + real(dp),parameter :: minMeasHeight=1._dp ! minimum measurement height (m) + real(dp) :: relhum ! relative humidity (-) + real(dp) :: fracrain ! fraction of precipitation that falls as rain + real(dp) :: maxFrozenSnowTemp ! maximum temperature of snow when the snow is predominantely frozen (K) + real(dp),parameter :: unfrozenLiq=0.01_dp ! unfrozen liquid water used to compute maxFrozenSnowTemp (-) + real(dp),parameter :: eps=epsilon(fracrain) ! a number that is almost negligible + real(dp) :: Tmin,Tmax ! minimum and maximum wet bulb temperature in the time step (K) + real(dp),parameter :: pomNewSnowDenMax=150._dp ! Upper limit for new snow density limit in Hedstrom and Pomeroy 1998. 150 was used because at was the highest observed density at air temperatures used in this study. See Figure 4 of Hedstrom and Pomeroy (1998). + real(dp),parameter :: andersonWarmDenLimit=2._dp ! Upper air temperature limit in Anderson (1976) new snow density (C) + real(dp),parameter :: andersonColdDenLimit=15._dp! Lower air temperature limit in Anderson (1976) new snow density (C) + real(dp),parameter :: andersonDenScal=1.5_dp ! Scalar parameter in Anderson (1976) new snow density function (-) + real(dp),parameter :: pahautDenWindScal=0.5_dp ! Scalar parameter for wind impacts on density using Pahaut (1976) function (-) ! ************************************************************************************************ ! associate local variables with the information in the data structures associate(& @@ -204,13 +204,13 @@ subroutine derivforce(time_data,forc_data,attr_data,mpar_data,prog_data,diag_dat select case(trim(NC_TIME_ZONE)) ! Time zone information from NetCDF file case('ncTime') - timeOffset = longitude/360._rk - tmZoneOffsetFracDay ! time offset in days + timeOffset = longitude/360._dp - tmZoneOffsetFracDay ! time offset in days ! All times in UTC case('utcTime') - timeOffset = longitude/360._rk ! time offset in days + timeOffset = longitude/360._dp ! time offset in days ! All times local case('localTime') - timeOffset = 0._rk ! time offset in days + timeOffset = 0._dp ! time offset in days case default; message=trim(message)//'unable to identify option for tmZoneInfo'; err=20; return end select ! identifying option tmZoneInfo @@ -232,7 +232,7 @@ subroutine derivforce(time_data,forc_data,attr_data,mpar_data,prog_data,diag_dat ! compute the decimal hour at the start of the time step dataStep = data_step/secprhour ! time step (hours) - ahour = real(jh,kind(rk)) + real(jmin,kind(rk))/minprhour - data_step/secprhour ! decimal hour (start of the step) + ahour = real(jh,kind(dp)) + real(jmin,kind(dp))/minprhour - data_step/secprhour ! decimal hour (start of the step) ! compute the cosine of the solar zenith angle call clrsky_rad(jm,jd,ahour,dataStep, & ! intent(in): time variables @@ -241,19 +241,19 @@ subroutine derivforce(time_data,forc_data,attr_data,mpar_data,prog_data,diag_dat !write(*,'(a,1x,4(i2,1x),3(f9.3,1x))') 'im,id,ih,imin,ahour,dataStep,cosZenith = ', & ! ensure solar radiation is non-negative - if(SWRadAtm < 0._rk) SWRadAtm = 0._rk + if(SWRadAtm < 0._dp) SWRadAtm = 0._dp ! compute the fraction of direct radiation using the parameterization of Nijssen and Lettenmaier (1999) - if(cosZenith > 0._rk)then + if(cosZenith > 0._dp)then scalarFractionDirect = Frad_direct*cosZenith/(cosZenith + directScale) else - scalarFractionDirect = 0._rk + scalarFractionDirect = 0._dp end if ! compute direct shortwave radiation, in the visible and near-infra-red part of the spectrum spectralIncomingDirect(1) = SWRadAtm*scalarFractionDirect*Frad_vis ! (direct vis) - spectralIncomingDirect(2) = SWRadAtm*scalarFractionDirect*(1._rk - Frad_vis) ! (direct nir) + spectralIncomingDirect(2) = SWRadAtm*scalarFractionDirect*(1._dp - Frad_vis) ! (direct nir) ! compute diffuse shortwave radiation, in the visible and near-infra-red part of the spectrum - spectralIncomingDiffuse(1) = SWRadAtm*(1._rk - scalarFractionDirect)*Frad_vis ! (diffuse vis) - spectralIncomingDiffuse(2) = SWRadAtm*(1._rk - scalarFractionDirect)*(1._rk - Frad_vis) ! (diffuse nir) + spectralIncomingDiffuse(1) = SWRadAtm*(1._dp - scalarFractionDirect)*Frad_vis ! (diffuse vis) + spectralIncomingDiffuse(2) = SWRadAtm*(1._dp - scalarFractionDirect)*(1._dp - Frad_vis) ! (diffuse nir) ! ensure wind speed is above a prescribed minimum value if(windspd < minwind) windspd=minwind @@ -261,8 +261,8 @@ subroutine derivforce(time_data,forc_data,attr_data,mpar_data,prog_data,diag_dat ! compute relative humidity (-) relhum = SPHM2RELHM(spechum, airpres, airtemp) ! if relative humidity exceeds saturation, then set relative and specific humidity to saturation - if(relhum > 1._rk)then - relhum = 1._rk + if(relhum > 1._dp)then + relhum = 1._dp spechum = RELHM2SPHM(relhum, airpres, airtemp) end if @@ -277,17 +277,17 @@ subroutine derivforce(time_data,forc_data,attr_data,mpar_data,prog_data,diag_dat maxFrozenSnowTemp = templiquid(unfrozenLiq,fc_param) ! compute fraction of rain and temperature of fresh snow - Tmin = twetbulb - tempRangeTimestep/2._rk - Tmax = twetbulb + tempRangeTimestep/2._rk + Tmin = twetbulb - tempRangeTimestep/2._dp + Tmax = twetbulb + tempRangeTimestep/2._dp if(Tmax < tempCritRain)then - fracrain = 0._rk + fracrain = 0._dp snowfallTemp = twetbulb elseif(Tmin > tempCritRain)then - fracrain = 1._rk + fracrain = 1._dp snowfallTemp = maxFrozenSnowTemp else fracrain = (Tmax - tempCritRain)/(Tmax - Tmin) - snowfallTemp = 0.5_rk*(Tmin + maxFrozenSnowTemp) + snowfallTemp = 0.5_dp*(Tmin + maxFrozenSnowTemp) end if !write(*,'(a,1x,10(f20.10,1x))') 'Tmin, twetbulb, tempRangeTimestep, tempCritRain = ', & ! Tmin, twetbulb, tempRangeTimestep, tempCritRain @@ -298,12 +298,12 @@ subroutine derivforce(time_data,forc_data,attr_data,mpar_data,prog_data,diag_dat ! ensure precipitation rate can be resolved by the data model if(pptrate 0.1_rk)then ! log10(0.1) = -1 - kerstenNum = log10(relativeSat) + 1._rk + if(relativeSat > 0.1_dp)then ! log10(0.1) = -1 + kerstenNum = log10(relativeSat) + 1._dp else - kerstenNum = 0._rk ! dry thermal conductivity + kerstenNum = 0._dp ! dry thermal conductivity endif ! ...and, compute the thermal conductivity - mLayerThermalC(iLayer) = kerstenNum*lambda_wet + (1._rk - kerstenNum)*lambda_drysoil + mLayerThermalC(iLayer) = kerstenNum*lambda_wet + (1._dp - kerstenNum)*lambda_drysoil ! ** mixture of constituents case(mixConstit) - mLayerThermalC(iLayer) = thCond_soil(iSoil) * ( 1._rk - theta_sat(iSoil) ) + & ! soil component + mLayerThermalC(iLayer) = thCond_soil(iSoil) * ( 1._dp - theta_sat(iSoil) ) + & ! soil component lambda_ice * mLayerVolFracIce(iLayer) + & ! ice component lambda_water * mLayerVolFracLiq(iLayer) + & ! liquid water component lambda_air * mLayerVolFracAir(iLayer) ! air component ! ** test case for the mizoguchi lab experiment, Hansson et al. VZJ 2004 case(hanssonVZJ) - fArg = 1._rk + f1*mLayerVolFracIce(iLayer)**f2 + fArg = 1._dp + f1*mLayerVolFracIce(iLayer)**f2 xArg = mLayerVolFracLiq(iLayer) + fArg*mLayerVolFracIce(iLayer) mLayerThermalC(iLayer) = c1 + c2*xArg + (c1 - c4)*exp(-(c3*xArg)**c5) @@ -315,7 +315,7 @@ subroutine diagn_evar(& ! special case of hansson if(ixThCondSoil==hanssonVZJ)then - iLayerThermalC(0) = 28._rk*(0.5_rk*(iLayerHeight(1) - iLayerHeight(0))) + iLayerThermalC(0) = 28._dp*(0.5_dp*(iLayerHeight(1) - iLayerHeight(0))) else iLayerThermalC(0) = mLayerThermalC(1) end if diff --git a/build/source/engine/eval8summa.f90 b/build/source/engine/eval8summa.f90 index 7c0d55f17..bd13c2435 100755 --- a/build/source/engine/eval8summa.f90 +++ b/build/source/engine/eval8summa.f90 @@ -153,7 +153,7 @@ subroutine eval8summa(& ! -------------------------------------------------------------------------------------------------------------------------------- ! -------------------------------------------------------------------------------------------------------------------------------- ! input: model control - real(rk),intent(in) :: dt ! length of the time step (seconds) + real(dp),intent(in) :: dt ! length of the time step (seconds) integer(i4b),intent(in) :: nSnow ! number of snow layers integer(i4b),intent(in) :: nSoil ! number of soil layers integer(i4b),intent(in) :: nLayers ! total number of layers @@ -164,9 +164,9 @@ subroutine eval8summa(& logical(lgt),intent(in) :: computeVegFlux ! flag to indicate if computing fluxes over vegetation logical(lgt),intent(in) :: scalarSolution ! flag to denote if implementing the scalar solution ! input: state vectors - real(rk),intent(in) :: stateVecTrial(:) ! model state vector - real(rk),intent(in) :: fScale(:) ! function scaling vector - real(rk),intent(in) :: sMul(:) ! NOTE: qp ! state vector multiplier (used in the residual calculations) + real(dp),intent(in) :: stateVecTrial(:) ! model state vector + real(dp),intent(in) :: fScale(:) ! function scaling vector + real(qp),intent(in) :: sMul(:) ! NOTE: qp ! state vector multiplier (used in the residual calculations) ! input: data structures type(model_options),intent(in) :: model_decisions(:) ! model decisions type(var_i), intent(in) :: type_data ! type of vegetation and soil @@ -182,13 +182,13 @@ subroutine eval8summa(& type(var_dlength),intent(inout) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables ! input-output: baseflow integer(i4b),intent(inout) :: ixSaturation ! index of the lowest saturated layer (NOTE: only computed on the first iteration) - real(rk),intent(out) :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) + real(dp),intent(out) :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) ! output: flux and residual vectors logical(lgt),intent(out) :: feasible ! flag to denote the feasibility of the solution - real(rk),intent(out) :: fluxVec(:) ! flux vector - real(rk),intent(out) :: resSink(:) ! sink terms on the RHS of the flux equation - real(rk),intent(out) :: resVec(:) ! NOTE: qp ! residual vector - real(rk),intent(out) :: fEval ! function evaluation + real(dp),intent(out) :: fluxVec(:) ! flux vector + real(dp),intent(out) :: resSink(:) ! sink terms on the RHS of the flux equation + real(qp),intent(out) :: resVec(:) ! NOTE: qp ! residual vector + real(dp),intent(out) :: fEval ! function evaluation ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message @@ -196,29 +196,29 @@ subroutine eval8summa(& ! local variables ! -------------------------------------------------------------------------------------------------------------------------------- ! state variables - real(rk) :: scalarCanairTempTrial ! trial value for temperature of the canopy air space (K) - real(rk) :: scalarCanopyTempTrial ! trial value for temperature of the vegetation canopy (K) - real(rk) :: scalarCanopyWatTrial ! trial value for liquid water storage in the canopy (kg m-2) - real(rk),dimension(nLayers) :: mLayerTempTrial ! trial value for temperature of layers in the snow and soil domains (K) - real(rk),dimension(nLayers) :: mLayerVolFracWatTrial ! trial value for volumetric fraction of total water (-) - real(rk),dimension(nSoil) :: mLayerMatricHeadTrial ! trial value for total water matric potential (m) - real(rk),dimension(nSoil) :: mLayerMatricHeadLiqTrial ! trial value for liquid water matric potential (m) - real(rk) :: scalarAquiferStorageTrial ! trial value of storage of water in the aquifer (m) + real(dp) :: scalarCanairTempTrial ! trial value for temperature of the canopy air space (K) + real(dp) :: scalarCanopyTempTrial ! trial value for temperature of the vegetation canopy (K) + real(dp) :: scalarCanopyWatTrial ! trial value for liquid water storage in the canopy (kg m-2) + real(dp),dimension(nLayers) :: mLayerTempTrial ! trial value for temperature of layers in the snow and soil domains (K) + real(dp),dimension(nLayers) :: mLayerVolFracWatTrial ! trial value for volumetric fraction of total water (-) + real(dp),dimension(nSoil) :: mLayerMatricHeadTrial ! trial value for total water matric potential (m) + real(dp),dimension(nSoil) :: mLayerMatricHeadLiqTrial ! trial value for liquid water matric potential (m) + real(dp) :: scalarAquiferStorageTrial ! trial value of storage of water in the aquifer (m) ! diagnostic variables - real(rk) :: scalarCanopyLiqTrial ! trial value for mass of liquid water on the vegetation canopy (kg m-2) - real(rk) :: scalarCanopyIceTrial ! trial value for mass of ice on the vegetation canopy (kg m-2) - real(rk),dimension(nLayers) :: mLayerVolFracLiqTrial ! trial value for volumetric fraction of liquid water (-) - real(rk),dimension(nLayers) :: mLayerVolFracIceTrial ! trial value for volumetric fraction of ice (-) + real(dp) :: scalarCanopyLiqTrial ! trial value for mass of liquid water on the vegetation canopy (kg m-2) + real(dp) :: scalarCanopyIceTrial ! trial value for mass of ice on the vegetation canopy (kg m-2) + real(dp),dimension(nLayers) :: mLayerVolFracLiqTrial ! trial value for volumetric fraction of liquid water (-) + real(dp),dimension(nLayers) :: mLayerVolFracIceTrial ! trial value for volumetric fraction of ice (-) ! other local variables integer(i4b) :: iLayer ! index of model layer in the snow+soil domain integer(i4b) :: jState(1) ! index of model state for the scalar solution within the soil domain integer(i4b) :: ixBeg,ixEnd ! index of indices for the soil compression routine integer(i4b),parameter :: ixVegVolume=1 ! index of the desired vegetation control volumne (currently only one veg layer) - real(rk) :: xMin,xMax ! minimum and maximum values for water content - real(rk) :: scalarCanopyHydTrial ! trial value for mass of water on the vegetation canopy (kg m-2) - real(rk),parameter :: canopyTempMax=500._rk ! expected maximum value for the canopy temperature (K) - real(rk),dimension(nLayers) :: mLayerVolFracHydTrial ! trial value for volumetric fraction of water (-), general vector merged from Wat and Liq - real(rk),dimension(nState) :: rVecScaled ! scaled residual vector + real(dp) :: xMin,xMax ! minimum and maximum values for water content + real(dp) :: scalarCanopyHydTrial ! trial value for mass of water on the vegetation canopy (kg m-2) + real(dp),parameter :: canopyTempMax=500._dp ! expected maximum value for the canopy temperature (K) + real(dp),dimension(nLayers) :: mLayerVolFracHydTrial ! trial value for volumetric fraction of water (-), general vector merged from Wat and Liq + real(dp),dimension(nState) :: rVecScaled ! scaled residual vector character(LEN=256) :: cmessage ! error message of downwind routine ! -------------------------------------------------------------------------------------------------------------------------------- ! association to variables in the data structures @@ -281,7 +281,7 @@ subroutine eval8summa(& ! check canopy liquid water is not negative if(ixVegHyd/=integerMissing)then - if(stateVecTrial(ixVegHyd) < 0._rk) feasible=.false. + if(stateVecTrial(ixVegHyd) < 0._dp) feasible=.false. end if ! check snow temperature is below freezing @@ -299,12 +299,12 @@ subroutine eval8summa(& if (layerType(iLayer) == iname_soil) then xMin = theta_sat(iLayer-nSnow) else - xMin = 0._rk + xMin = 0._dp endif ! --> maximum select case( layerType(iLayer) ) - case(iname_snow); xMax = merge(iden_ice, 1._rk - mLayerVolFracIce(iLayer), ixHydType(iLayer)==iname_watLayer) + case(iname_snow); xMax = merge(iden_ice, 1._dp - mLayerVolFracIce(iLayer), ixHydType(iLayer)==iname_watLayer) case(iname_soil); xMax = merge(theta_sat(iLayer-nSnow), theta_sat(iLayer-nSnow) - mLayerVolFracIce(iLayer), ixHydType(iLayer)==iname_watLayer) end select @@ -517,8 +517,8 @@ subroutine eval8summa(& if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! (check for errors) ! compute the function evaluation - rVecScaled = fScale(:)*real(resVec(:), rk) ! scale the residual vector (NOTE: residual vector is in quadruple precision) - fEval = 0.5_rk*dot_product(rVecScaled,rVecScaled) + rVecScaled = fScale(:)*real(resVec(:), dp) ! scale the residual vector (NOTE: residual vector is in quadruple precision) + fEval = 0.5_dp*dot_product(rVecScaled,rVecScaled) ! end association with the information in the data structures end associate diff --git a/build/source/engine/expIntegral.f90 b/build/source/engine/expIntegral.f90 index 645ef5a29..8045e0f04 100755 --- a/build/source/engine/expIntegral.f90 +++ b/build/source/engine/expIntegral.f90 @@ -11,32 +11,32 @@ module expIntegral_module ! From UEB-Veg ! Computes the exponential integral function for the given value FUNCTION EXPINT (LAI) - real(rk) LAI - real(rk) EXPINT - real(rk) a0,a1,a2,a3,a4,a5,b1,b2,b3,b4 - real(rk),parameter :: verySmall=tiny(1.0_rk) ! a very small number + REAL(DP) LAI + REAL(DP) EXPINT + REAL(DP) a0,a1,a2,a3,a4,a5,b1,b2,b3,b4 + real(dp),parameter :: verySmall=tiny(1.0_dp) ! a very small number IF (LAI < verySmall)THEN - EXPINT=1._rk + EXPINT=1._dp ELSEIF (LAI.LE.1.0) THEN - a0=-.57721566_rk - a1=.99999193_rk - a2=-.24991055_rk - a3=.05519968_rk - a4=-.00976004_rk - a5=.00107857_rk + a0=-.57721566_dp + a1=.99999193_dp + a2=-.24991055_dp + a3=.05519968_dp + a4=-.00976004_dp + a5=.00107857_dp EXPINT = a0+a1*LAI+a2*LAI**2+a3*LAI**3+a4*LAI**4+a5*LAI**5 - log(LAI) ELSE - a1=8.5733287401_rk - a2=18.0590169730_rk - a3=8.6347637343_rk - a4=.2677737343_rk - b1=9.5733223454_rk - b2=25.6329561486_rk - b3=21.0996530827_rk - b4=3.9584969228_rk + a1=8.5733287401_dp + a2=18.0590169730_dp + a3=8.6347637343_dp + a4=.2677737343_dp + b1=9.5733223454_dp + b2=25.6329561486_dp + b3=21.0996530827_dp + b4=3.9584969228_dp EXPINT=(LAI**4+a1*LAI**3+a2*LAI**2+a3*LAI+a4)/ & ((LAI**4+b1*LAI**3+b2*LAI**2+b3*LAI+b4)*LAI*exp(LAI)) diff --git a/build/source/engine/f2008funcs.f90 b/build/source/engine/f2008funcs.f90 index 52ae947e5..3dfd1eeb8 100755 --- a/build/source/engine/f2008funcs.f90 +++ b/build/source/engine/f2008funcs.f90 @@ -75,11 +75,11 @@ end function findIndex subroutine cloneStruc_rv(dataVec,lowerBound,source,mold,err,message) implicit none ! input-output: data vector for allocation/population - real(rk),intent(inout),allocatable :: dataVec(:) ! data vector + real(dp),intent(inout),allocatable :: dataVec(:) ! data vector ! input integer(i4b),intent(in) :: lowerBound ! lower bound - real(rk),intent(in),optional :: source(lowerBound:) ! dataVec = shape of source + elements of source - real(rk),intent(in),optional :: mold(lowerBound:) ! dataVec = shape of mold + real(dp),intent(in),optional :: source(lowerBound:) ! dataVec = shape of source + elements of source + real(dp),intent(in),optional :: mold(lowerBound:) ! dataVec = shape of mold ! error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message diff --git a/build/source/engine/ffile_info.f90 b/build/source/engine/ffile_info.f90 index 0a19efbff..d7f3b8eb5 100755 --- a/build/source/engine/ffile_info.f90 +++ b/build/source/engine/ffile_info.f90 @@ -74,7 +74,7 @@ subroutine ffile_info(nGRU,err,message) integer(i4b) :: nForcing ! number of forcing variables integer(i4b) :: iGRU,localHRU_ix ! index of GRU and HRU integer(8) :: ncHruId(1) ! hruID from the forcing files - real(rk) :: dataStep_iFile ! data step for a given forcing data file + real(dp) :: dataStep_iFile ! data step for a given forcing data file logical(lgt) :: xist ! .TRUE. if the file exists ! Start procedure here diff --git a/build/source/engine/getVectorz.f90 b/build/source/engine/getVectorz.f90 index 5711d4342..ba31b4bfa 100755 --- a/build/source/engine/getVectorz.f90 +++ b/build/source/engine/getVectorz.f90 @@ -97,7 +97,7 @@ module getVectorz_module public::varExtract ! common variables -real(rk),parameter :: valueMissing=-9999._rk ! missing value +real(dp),parameter :: valueMissing=-9999._dp ! missing value contains @@ -120,7 +120,7 @@ subroutine popStateVec(& type(var_dlength),intent(in) :: diag_data ! diagnostic variables for a local HRU type(var_ilength),intent(in) :: indx_data ! indices defining model states and layers ! output - real(rk),intent(out) :: stateVec(:) ! model state vector (mixed units) + real(dp),intent(out) :: stateVec(:) ! model state vector (mixed units) integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! -------------------------------------------------------------------------------------------------------------------------------- @@ -266,10 +266,10 @@ subroutine getScaling(& type(var_dlength),intent(in) :: diag_data ! diagnostic variables for a local HRU type(var_ilength),intent(in) :: indx_data ! indices defining model states and layers ! output: state vectors - real(rk),intent(out) :: fScale(:) ! function scaling vector (mixed units) - real(rk),intent(out) :: xScale(:) ! variable scaling vector (mixed units) - real(rk),intent(out) :: sMul(:) ! NOTE: qp ! multiplier for state vector (used in the residual calculations) - real(rk),intent(out) :: dMat(:) ! diagonal of the Jacobian matrix (excludes fluxes) + real(dp),intent(out) :: fScale(:) ! function scaling vector (mixed units) + real(dp),intent(out) :: xScale(:) ! variable scaling vector (mixed units) + real(qp),intent(out) :: sMul(:) ! NOTE: qp ! multiplier for state vector (used in the residual calculations) + real(dp),intent(out) :: dMat(:) ! diagonal of the Jacobian matrix (excludes fluxes) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message @@ -277,12 +277,12 @@ subroutine getScaling(& ! local variables ! -------------------------------------------------------------------------------------------------------------------------------- ! scaling parameters - real(rk),parameter :: fScaleLiq=0.01_rk ! func eval: characteristic scale for volumetric liquid water content (-) - real(rk),parameter :: fScaleMat=10._rk ! func eval: characteristic scale for matric head (m) - real(rk),parameter :: fScaleNrg=1000000._rk ! func eval: characteristic scale for energy (J m-3) - real(rk),parameter :: xScaleLiq=0.1_rk ! state var: characteristic scale for volumetric liquid water content (-) - real(rk),parameter :: xScaleMat=10._rk ! state var: characteristic scale for matric head (m) - real(rk),parameter :: xScaleTemp=1._rk ! state var: characteristic scale for temperature (K) + real(dp),parameter :: fScaleLiq=0.01_dp ! func eval: characteristic scale for volumetric liquid water content (-) + real(dp),parameter :: fScaleMat=10._dp ! func eval: characteristic scale for matric head (m) + real(dp),parameter :: fScaleNrg=1000000._dp ! func eval: characteristic scale for energy (J m-3) + real(dp),parameter :: xScaleLiq=0.1_dp ! state var: characteristic scale for volumetric liquid water content (-) + real(dp),parameter :: xScaleMat=10._dp ! state var: characteristic scale for matric head (m) + real(dp),parameter :: xScaleTemp=1._dp ! state var: characteristic scale for temperature (K) ! state subsets integer(i4b) :: iLayer ! index of layer within the snow+soil domain integer(i4b) :: ixStateSubset ! index within the state subset @@ -320,32 +320,32 @@ subroutine getScaling(& ! define the function and variable scaling factors for energy where(ixStateType_subset==iname_nrgCanair .or. ixStateType_subset==iname_nrgCanopy .or. ixStateType_subset==iname_nrgLayer) - fScale = 1._rk / fScaleNrg ! 1/(J m-3) - xScale = 1._rk ! K + fScale = 1._dp / fScaleNrg ! 1/(J m-3) + xScale = 1._dp ! K endwhere ! define the function and variable scaling factors for water on the vegetation canopy where(ixStateType_subset==iname_watCanopy .or. ixStateType_subset==iname_liqCanopy) - fScale = 1._rk / (fScaleLiq*canopyDepth*iden_water) ! 1/(kg m-2) - xScale = 1._rk ! (kg m-2) + fScale = 1._dp / (fScaleLiq*canopyDepth*iden_water) ! 1/(kg m-2) + xScale = 1._dp ! (kg m-2) endwhere ! define the function and variable scaling factors for water in the snow+soil domain where(ixStateType_subset==iname_watLayer .or. ixStateType_subset==iname_liqLayer) - fScale = 1._rk / fScaleLiq ! (-) - xScale = 1._rk ! (-) + fScale = 1._dp / fScaleLiq ! (-) + xScale = 1._dp ! (-) end where ! define the function and variable scaling factors for water in the snow+soil domain where(ixStateType_subset==iname_matLayer .or. ixStateType_subset==iname_lmpLayer) - fScale = 1._rk / fScaleLiq ! (-) - xScale = 1._rk ! (m) + fScale = 1._dp / fScaleLiq ! (-) + xScale = 1._dp ! (m) end where ! define the function and variable scaling factors for water storage in the aquifer where(ixStateType_subset==iname_watAquifer) - fScale = 1._rk - xScale = 1._rk + fScale = 1._dp + xScale = 1._dp endwhere ! ----- @@ -357,8 +357,8 @@ subroutine getScaling(& where(ixStateType_subset==iname_nrgCanair) sMul = Cp_air*iden_air ! volumetric heat capacity of air (J m-3 K-1) where(ixStateType_subset==iname_nrgCanopy) sMul = volHeatCapVeg ! volumetric heat capacity of the vegetation (J m-3 K-1) - where(ixStateType_subset==iname_watCanopy) sMul = 1._rk ! nothing else on the left hand side - where(ixStateType_subset==iname_liqCanopy) sMul = 1._rk ! nothing else on the left hand side + where(ixStateType_subset==iname_watCanopy) sMul = 1._dp ! nothing else on the left hand side + where(ixStateType_subset==iname_liqCanopy) sMul = 1._dp ! nothing else on the left hand side ! compute terms in the Jacobian for vegetation (excluding fluxes) ! NOTE: This is computed outside the iteration loop because it does not depend on state variables @@ -366,8 +366,8 @@ subroutine getScaling(& ! NOTE: Use the "where" statement to generalize to multiple canopy layers (currently one canopy layer) where(ixStateType_subset==iname_nrgCanair) dMat = Cp_air*iden_air ! volumetric heat capacity of air (J m-3 K-1) where(ixStateType_subset==iname_nrgCanopy) dMat = realMissing ! populated within the iteration loop - where(ixStateType_subset==iname_watCanopy) dMat = 1._rk ! nothing else on the left hand side - where(ixStateType_subset==iname_liqCanopy) dMat = 1._rk ! nothing else on the left hand side + where(ixStateType_subset==iname_watCanopy) dMat = 1._dp ! nothing else on the left hand side + where(ixStateType_subset==iname_liqCanopy) dMat = 1._dp ! nothing else on the left hand side ! define the energy multiplier and diagonal elements for the state vector for residual calculations (snow-soil domain) if(nSnowSoilNrg>0)then @@ -382,15 +382,15 @@ subroutine getScaling(& if(nSnowSoilHyd>0)then do concurrent (iLayer=1:nLayers,ixSnowSoilHyd(iLayer)/=integerMissing) ! (loop through non-missing energy state variables in the snow+soil domain) ixStateSubset = ixSnowSoilHyd(iLayer) ! index within the state vector - sMul(ixStateSubset) = 1._rk ! state multiplier = 1 (nothing else on the left-hand-side) - dMat(ixStateSubset) = 1._rk ! diagonal element = 1 (nothing else on the left-hand-side) + sMul(ixStateSubset) = 1._dp ! state multiplier = 1 (nothing else on the left-hand-side) + dMat(ixStateSubset) = 1._dp ! diagonal element = 1 (nothing else on the left-hand-side) end do ! looping through non-missing energy state variables in the snow+soil domain endif ! define the scaling factor and diagonal elements for the aquifer where(ixStateType_subset==iname_watAquifer) - sMul = 1._rk - dMat = 1._rk + sMul = 1._dp + dMat = 1._dp endwhere ! ------------------------------------------------------------------------------------------ @@ -431,25 +431,25 @@ subroutine varExtract(& ! -------------------------------------------------------------------------------------------------------------------------------- implicit none ! input - real(rk),intent(in) :: stateVec(:) ! model state vector (mixed units) + real(dp),intent(in) :: stateVec(:) ! model state vector (mixed units) type(var_dlength),intent(in) :: diag_data ! diagnostic variables for a local HRU type(var_dlength),intent(in) :: prog_data ! prognostic variables for a local HRU type(var_ilength),intent(in) :: indx_data ! indices defining model states and layers ! output: variables for the vegetation canopy - real(rk),intent(out) :: scalarCanairTempTrial ! trial value of canopy air temperature (K) - real(rk),intent(out) :: scalarCanopyTempTrial ! trial value of canopy temperature (K) - real(rk),intent(out) :: scalarCanopyWatTrial ! trial value of canopy total water (kg m-2) - real(rk),intent(out) :: scalarCanopyLiqTrial ! trial value of canopy liquid water (kg m-2) - real(rk),intent(out) :: scalarCanopyIceTrial ! trial value of canopy ice content (kg m-2) + real(dp),intent(out) :: scalarCanairTempTrial ! trial value of canopy air temperature (K) + real(dp),intent(out) :: scalarCanopyTempTrial ! trial value of canopy temperature (K) + real(dp),intent(out) :: scalarCanopyWatTrial ! trial value of canopy total water (kg m-2) + real(dp),intent(out) :: scalarCanopyLiqTrial ! trial value of canopy liquid water (kg m-2) + real(dp),intent(out) :: scalarCanopyIceTrial ! trial value of canopy ice content (kg m-2) ! output: variables for the snow-soil domain - real(rk),intent(out) :: mLayerTempTrial(:) ! trial vector of layer temperature (K) - real(rk),intent(out) :: mLayerVolFracWatTrial(:) ! trial vector of volumetric total water content (-) - real(rk),intent(out) :: mLayerVolFracLiqTrial(:) ! trial vector of volumetric liquid water content (-) - real(rk),intent(out) :: mLayerVolFracIceTrial(:) ! trial vector of volumetric ice water content (-) - real(rk),intent(out) :: mLayerMatricHeadTrial(:) ! trial vector of total water matric potential (m) - real(rk),intent(out) :: mLayerMatricHeadLiqTrial(:) ! trial vector of liquid water matric potential (m) + real(dp),intent(out) :: mLayerTempTrial(:) ! trial vector of layer temperature (K) + real(dp),intent(out) :: mLayerVolFracWatTrial(:) ! trial vector of volumetric total water content (-) + real(dp),intent(out) :: mLayerVolFracLiqTrial(:) ! trial vector of volumetric liquid water content (-) + real(dp),intent(out) :: mLayerVolFracIceTrial(:) ! trial vector of volumetric ice water content (-) + real(dp),intent(out) :: mLayerMatricHeadTrial(:) ! trial vector of total water matric potential (m) + real(dp),intent(out) :: mLayerMatricHeadLiqTrial(:) ! trial vector of liquid water matric potential (m) ! output: variables for the aquifer - real(rk),intent(out) :: scalarAquiferStorageTrial ! trial value of storage of water in the aquifer (m) + real(dp),intent(out) :: scalarAquiferStorageTrial ! trial value of storage of water in the aquifer (m) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message diff --git a/build/source/engine/groundwatr.f90 b/build/source/engine/groundwatr.f90 index 92a402ba2..0e16b27ae 100755 --- a/build/source/engine/groundwatr.f90 +++ b/build/source/engine/groundwatr.f90 @@ -47,9 +47,9 @@ module groundwatr_module ! privacy implicit none ! constant parameters -real(rk),parameter :: valueMissing=-9999._rk ! missing value parameter -real(rk),parameter :: verySmall=epsilon(1.0_rk) ! a very small number (used to avoid divide by zero) -real(rk),parameter :: dx=1.e-8_rk ! finite difference increment +real(dp),parameter :: valueMissing=-9999._dp ! missing value parameter +real(dp),parameter :: verySmall=epsilon(1.0_dp) ! a very small number (used to avoid divide by zero) +real(dp),parameter :: dx=1.e-8_dp ! finite difference increment private public::groundwatr contains @@ -120,10 +120,10 @@ subroutine groundwatr(& integer(i4b),intent(in) :: nLayers ! total number of layers logical(lgt),intent(in) :: getSatDepth ! logical flag to compute index of the lowest saturated layer ! input: state and diagnostic variables - real(rk),intent(in) :: mLayerdTheta_dPsi(:) ! derivative in the soil water characteristic w.r.t. matric head in each layer (m-1) - real(rk),intent(in) :: mLayerMatricHeadLiq(:) ! matric head in each layer at the current iteration (m) - real(rk),intent(in) :: mLayerVolFracLiq(:) ! volumetric fraction of liquid water (-) - real(rk),intent(in) :: mLayerVolFracIce(:) ! volumetric fraction of ice (-) + real(dp),intent(in) :: mLayerdTheta_dPsi(:) ! derivative in the soil water characteristic w.r.t. matric head in each layer (m-1) + real(dp),intent(in) :: mLayerMatricHeadLiq(:) ! matric head in each layer at the current iteration (m) + real(dp),intent(in) :: mLayerVolFracLiq(:) ! volumetric fraction of liquid water (-) + real(dp),intent(in) :: mLayerVolFracIce(:) ! volumetric fraction of ice (-) ! input/output: data structures type(var_d),intent(in) :: attr_data ! spatial attributes type(var_dlength),intent(in) :: mpar_data ! model parameters @@ -132,8 +132,8 @@ subroutine groundwatr(& type(var_dlength),intent(inout) :: flux_data ! model fluxes for a local HRU ! output: baseflow integer(i4b),intent(inout) :: ixSaturation ! index of lowest saturated layer (NOTE: only computed on the first iteration) - real(rk),intent(out) :: mLayerBaseflow(:) ! baseflow from each soil layer (m s-1) - real(rk),intent(out) :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) + real(dp),intent(out) :: mLayerBaseflow(:) ! baseflow from each soil layer (m s-1) + real(dp),intent(out) :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message @@ -142,13 +142,13 @@ subroutine groundwatr(& ! --------------------------------------------------------------------------------------- ! general local variables integer(i4b) :: iLayer ! index of soil layer - real(rk),dimension(nSoil,nSoil) :: dBaseflow_dVolLiq ! derivative in the baseflow flux w.r.t. volumetric liquid water content (m s-1) + real(dp),dimension(nSoil,nSoil) :: dBaseflow_dVolLiq ! derivative in the baseflow flux w.r.t. volumetric liquid water content (m s-1) ! local variables to compute the numerical Jacobian logical(lgt),parameter :: doNumericalJacobian=.false. ! flag to compute the numerical Jacobian - real(rk),dimension(nSoil) :: mLayerMatricHeadPerturbed ! perturbed matric head (m) - real(rk),dimension(nSoil) :: mLayerVolFracLiqPerturbed ! perturbed volumetric fraction of liquid water (-) - real(rk),dimension(nSoil) :: mLayerBaseflowPerturbed ! perturbed baseflow (m s-1) - real(rk),dimension(nSoil,nSoil) :: nJac ! numerical Jacobian (s-1) + real(dp),dimension(nSoil) :: mLayerMatricHeadPerturbed ! perturbed matric head (m) + real(dp),dimension(nSoil) :: mLayerVolFracLiqPerturbed ! perturbed volumetric fraction of liquid water (-) + real(dp),dimension(nSoil) :: mLayerBaseflowPerturbed ! perturbed baseflow (m s-1) + real(dp),dimension(nSoil,nSoil) :: nJac ! numerical Jacobian (s-1) ! *************************************************************************************** ! *************************************************************************************** ! initialize error control @@ -189,10 +189,10 @@ subroutine groundwatr(& ! check for an early return (no layers are "active") if(ixSaturation > nSoil)then - scalarExfiltration = 0._rk ! exfiltration from the soil profile (m s-1) - mLayerColumnOutflow(:) = 0._rk ! column outflow from each soil layer (m3 s-1) - mLayerBaseflow(:) = 0._rk ! baseflow from each soil layer (m s-1) - dBaseflow_dMatric(:,:) = 0._rk ! derivative in baseflow w.r.t. matric head (s-1) + scalarExfiltration = 0._dp ! exfiltration from the soil profile (m s-1) + mLayerColumnOutflow(:) = 0._dp ! column outflow from each soil layer (m3 s-1) + mLayerBaseflow(:) = 0._dp ! baseflow from each soil layer (m s-1) + dBaseflow_dMatric(:,:) = 0._dp ! derivative in baseflow w.r.t. matric head (s-1) return end if ! if some layers are saturated @@ -222,7 +222,7 @@ subroutine groundwatr(& ! use the chain rule to compute the baseflow derivative w.r.t. matric head (s-1) do iLayer=1,nSoil dBaseflow_dMatric(1:iLayer,iLayer) = dBaseflow_dVolLiq(1:iLayer,iLayer)*mLayerdTheta_dPsi(iLayer) - if(iLayer1)then - zActive(1:ixSaturation-1) = 0._rk - trTotal(1:ixSaturation-1) = 0._rk - trSoil(1:ixSaturation-1) = 0._rk + zActive(1:ixSaturation-1) = 0._dp + trTotal(1:ixSaturation-1) = 0._dp + trSoil(1:ixSaturation-1) = 0._dp end if ! compute the outflow from each layer (m3 s-1) @@ -444,26 +444,26 @@ subroutine computeBaseflow(& if(availStorage < xMinEval)then ! (compute the logistic function) expF = exp((availStorage - xCenter)/xWidth) - logF = 1._rk / (1._rk + expF) + logF = 1._dp / (1._dp + expF) ! (compute the derivative in the logistic function w.r.t. volumetric liquid water content in each soil layer) - dLogFunc_dLiq(1:nSoil) = mLayerDepth(1:nSoil)*(expF/xWidth)/(1._rk + expF)**2._rk + dLogFunc_dLiq(1:nSoil) = mLayerDepth(1:nSoil)*(expF/xWidth)/(1._dp + expF)**2._dp else - logF = 0._rk - dLogFunc_dLiq(:) = 0._rk + logF = 0._dp + dLogFunc_dLiq(:) = 0._dp end if ! compute the exfiltartion (m s-1) - if(totalColumnInflow > totalColumnOutflow .and. logF > tiny(1._rk))then + if(totalColumnInflow > totalColumnOutflow .and. logF > tiny(1._dp))then scalarExfiltration = logF*(totalColumnInflow - totalColumnOutflow) ! m s-1 !write(*,'(a,1x,10(f30.20,1x))') 'scalarExfiltration = ', scalarExfiltration else - scalarExfiltration = 0._rk + scalarExfiltration = 0._dp end if ! check !write(*,'(a,1x,10(f30.20,1x))') 'zActive(1), soilDepth, availStorage, logF, scalarExfiltration = ', & ! zActive(1), soilDepth, availStorage, logF, scalarExfiltration - !if(scalarExfiltration > tiny(1.0_rk)) pause 'exfiltrating' + !if(scalarExfiltration > tiny(1.0_dp)) pause 'exfiltrating' ! compute the baseflow in each layer (m s-1) mLayerBaseflow(1:nSoil) = (mLayerColumnOutflow(1:nSoil) - mLayerColumnInflow(1:nSoil))/HRUarea @@ -494,7 +494,7 @@ subroutine computeBaseflow(& ! *********************************************************************************************************************** ! initialize the derivative matrix - dBaseflow_dVolLiq(:,:) = 0._rk + dBaseflow_dVolLiq(:,:) = 0._dp ! check if derivatives are actually required if(.not.derivDesired) return @@ -506,7 +506,7 @@ subroutine computeBaseflow(& depth2capacity(1:nSoil) = mLayerDepth(1:nSoil)/sum( (theta_sat(1:nSoil) - fieldCapacity)*mLayerDepth(1:nSoil) ) ! compute the change in dimensionless flux w.r.t. change in dimensionless storage (-) - dXdS(1:nSoil) = zScale_TOPMODEL*(zActive(1:nSoil)/SoilDepth)**(zScale_TOPMODEL - 1._rk) + dXdS(1:nSoil) = zScale_TOPMODEL*(zActive(1:nSoil)/SoilDepth)**(zScale_TOPMODEL - 1._dp) ! loop through soil layers do iLayer=1,nSoil @@ -519,7 +519,7 @@ subroutine computeBaseflow(& end do ! looping through soil layers ! compute the derivative in the exfiltration flux w.r.t. volumetric liquid water content (m s-1) - if(qbTotal < 0._rk)then + if(qbTotal < 0._dp)then do iLayer=1,nSoil dExfiltrate_dVolLiq(iLayer) = dBaseflow_dVolLiq(iLayer,iLayer)*logF + dLogFunc_dLiq(iLayer)*qbTotal end do ! looping through soil layers diff --git a/build/source/engine/layerDivide.f90 b/build/source/engine/layerDivide.f90 index 24b94e2ed..6127fbf1e 100755 --- a/build/source/engine/layerDivide.f90 +++ b/build/source/engine/layerDivide.f90 @@ -117,21 +117,21 @@ subroutine layerDivide(& integer(i4b) :: nLayers ! total number of layers integer(i4b) :: iLayer ! layer index integer(i4b) :: jLayer ! layer index - real(rk),dimension(4) :: zmax_lower ! lower value of maximum layer depth - real(rk),dimension(4) :: zmax_upper ! upper value of maximum layer depth - real(rk) :: zmaxCheck ! value of zmax for a given snow layer + real(dp),dimension(4) :: zmax_lower ! lower value of maximum layer depth + real(dp),dimension(4) :: zmax_upper ! upper value of maximum layer depth + real(dp) :: zmaxCheck ! value of zmax for a given snow layer integer(i4b) :: nCheck ! number of layers to check to divide logical(lgt) :: createLayer ! flag to indicate we are creating a new snow layer - real(rk) :: depthOriginal ! original layer depth before sub-division (m) - real(rk),parameter :: fracTop=0.5_rk ! fraction of old layer used for the top layer - real(rk) :: surfaceLayerSoilTemp ! temperature of the top soil layer (K) - real(rk) :: maxFrozenSnowTemp ! maximum temperature when effectively all water is frozen (K) - real(rk),parameter :: unfrozenLiq=0.01_rk ! unfrozen liquid water used to compute maxFrozenSnowTemp (-) - real(rk) :: volFracWater ! volumetric fraction of total water, liquid and ice (-) - real(rk) :: fracLiq ! fraction of liquid water (-) + real(dp) :: depthOriginal ! original layer depth before sub-division (m) + real(dp),parameter :: fracTop=0.5_dp ! fraction of old layer used for the top layer + real(dp) :: surfaceLayerSoilTemp ! temperature of the top soil layer (K) + real(dp) :: maxFrozenSnowTemp ! maximum temperature when effectively all water is frozen (K) + real(dp),parameter :: unfrozenLiq=0.01_dp ! unfrozen liquid water used to compute maxFrozenSnowTemp (-) + real(dp) :: volFracWater ! volumetric fraction of total water, liquid and ice (-) + real(dp) :: fracLiq ! fraction of liquid water (-) integer(i4b),parameter :: ixVisible=1 ! named variable to define index in array of visible part of the spectrum integer(i4b),parameter :: ixNearIR=2 ! named variable to define index in array of near IR part of the spectrum - real(rk),parameter :: verySmall=1.e-10_rk ! a very small number (used for error checking) + real(dp),parameter :: verySmall=1.e-10_dp ! a very small number (used for error checking) ! -------------------------------------------------------------------------------------------------------- ! initialize error control err=0; message="layerDivide/" @@ -224,7 +224,7 @@ subroutine layerDivide(& ! compute volumeteric fraction of liquid water and ice volFracWater = (scalarSWE/scalarSnowDepth)/iden_water ! volumetric fraction of total water (liquid and ice) - mLayerVolFracIce(1) = (1._rk - fracLiq)*volFracWater*(iden_water/iden_ice) ! volumetric fraction of ice (-) + mLayerVolFracIce(1) = (1._dp - fracLiq)*volFracWater*(iden_water/iden_ice) ! volumetric fraction of ice (-) mLayerVolFracLiq(1) = fracLiq *volFracWater ! volumetric fraction of liquid water (-) ! end association with local variables to the information in the data structures) @@ -243,7 +243,7 @@ subroutine layerDivide(& prog_data%var(iLookPROG%spectralSnowAlbedoDiffuse)%dat(ixVisible) = mpar_data%var(iLookPARAM%albedoMaxVisible)%dat(1) prog_data%var(iLookPROG%spectralSnowAlbedoDiffuse)%dat(ixNearIR) = mpar_data%var(iLookPARAM%albedoMaxNearIR)%dat(1) prog_data%var(iLookPROG%scalarSnowAlbedo)%dat(1) = ( mpar_data%var(iLookPARAM%Frad_vis)%dat(1))*mpar_data%var(iLookPARAM%albedoMaxVisible)%dat(1) + & - (1._rk - mpar_data%var(iLookPARAM%Frad_vis)%dat(1))*mpar_data%var(iLookPARAM%albedoMaxNearIR)%dat(1) + (1._dp - mpar_data%var(iLookPARAM%Frad_vis)%dat(1))*mpar_data%var(iLookPARAM%albedoMaxNearIR)%dat(1) case default; err=20; message=trim(message)//'unable to identify option for snow albedo'; return end select ! identify option for snow albedo ! set direct albedo to diffuse albedo @@ -299,7 +299,7 @@ subroutine layerDivide(& layerSplit: associate(mLayerDepth => prog_data%var(iLookPROG%mLayerDepth)%dat) depthOriginal = mLayerDepth(iLayer) mLayerDepth(iLayer) = fracTop*depthOriginal - mLayerDepth(iLayer+1) = (1._rk - fracTop)*depthOriginal + mLayerDepth(iLayer+1) = (1._dp - fracTop)*depthOriginal end associate layerSplit exit ! NOTE: only sub-divide one layer per substep @@ -337,7 +337,7 @@ subroutine layerDivide(& iLayerHeight(0) = -scalarSnowDepth do jLayer=1,nLayers iLayerHeight(jLayer) = iLayerHeight(jLayer-1) + mLayerDepth(jLayer) - mLayerHeight(jLayer) = (iLayerHeight(jLayer-1) + iLayerHeight(jLayer))/2._rk + mLayerHeight(jLayer) = (iLayerHeight(jLayer-1) + iLayerHeight(jLayer))/2._dp end do ! check @@ -387,7 +387,7 @@ subroutine addModelLayer(dataStruct,metaStruct,ix_divide,nSnow,nLayers,err,messa integer(i4b) :: ix_lower ! lower bound of the vector integer(i4b) :: ix_upper ! upper bound of the vector logical(lgt) :: stateVariable ! .true. if variable is a state variable - real(rk),allocatable :: tempVec_rk(:) ! temporary vector (double precision) + real(dp),allocatable :: tempVec_dp(:) ! temporary vector (double precision) integer(i4b),allocatable :: tempVec_i4b(:) ! temporary vector (integer) character(LEN=256) :: cmessage ! error message of downwind routine ! --------------------------------------------------------------------------------------------- @@ -420,7 +420,7 @@ subroutine addModelLayer(dataStruct,metaStruct,ix_divide,nSnow,nLayers,err,messa ! check allocated if(.not.allocated(dataStruct%var(ivar)%dat))then; err=20; message='data vector is not allocated'; return; end if ! assign the data vector to the temporary vector - call cloneStruc(tempVec_rk, ix_lower, source=dataStruct%var(ivar)%dat, err=err, message=cmessage) + call cloneStruc(tempVec_dp, ix_lower, source=dataStruct%var(ivar)%dat, err=err, message=cmessage) if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! reallocate space for the new vector deallocate(dataStruct%var(ivar)%dat,stat=err) @@ -431,18 +431,18 @@ subroutine addModelLayer(dataStruct,metaStruct,ix_divide,nSnow,nLayers,err,messa if(stateVariable)then if(ix_upper > 0)then ! (only copy data if the vector exists -- can be a variable for snow, with no layers) if(ix_divide > 0)then - dataStruct%var(ivar)%dat(1:ix_divide) = tempVec_rk(1:ix_divide) ! copy data - dataStruct%var(ivar)%dat(ix_divide+1) = tempVec_rk(ix_divide) ! repeat data for the sub-divided layer + dataStruct%var(ivar)%dat(1:ix_divide) = tempVec_dp(1:ix_divide) ! copy data + dataStruct%var(ivar)%dat(ix_divide+1) = tempVec_dp(ix_divide) ! repeat data for the sub-divided layer end if if(ix_upper > ix_divide) & - dataStruct%var(ivar)%dat(ix_divide+2:ix_upper+1) = tempVec_rk(ix_divide+1:ix_upper) ! copy data + dataStruct%var(ivar)%dat(ix_divide+2:ix_upper+1) = tempVec_dp(ix_divide+1:ix_upper) ! copy data end if ! if the vector exists ! not a state variable else dataStruct%var(ivar)%dat(:) = realMissing end if ! deallocate the temporary vector: strictly not necessary, but include to be safe - deallocate(tempVec_rk,stat=err) + deallocate(tempVec_dp,stat=err) if(err/=0)then; err=20; message='problem deallocating temporary data vector'; return; end if ! ** integer diff --git a/build/source/engine/layerMerge.f90 b/build/source/engine/layerMerge.f90 index 37a4b12f6..6169755dd 100755 --- a/build/source/engine/layerMerge.f90 +++ b/build/source/engine/layerMerge.f90 @@ -100,7 +100,7 @@ subroutine layerMerge(& ! -------------------------------------------------------------------------------------------------------- ! define local variables character(LEN=256) :: cmessage ! error message of downwind routine - real(rk),dimension(5) :: zminLayer ! minimum layer depth in each layer (m) + real(dp),dimension(5) :: zminLayer ! minimum layer depth in each layer (m) logical(lgt) :: removeLayer ! flag to indicate need to remove a layer integer(i4b) :: nCheck ! number of layers to check for combination integer(i4b) :: iSnow ! index of snow layers (looping) @@ -316,18 +316,18 @@ subroutine layer_combine(mpar_data,prog_data,diag_data,flux_data,indx_data,iSnow ! ------------------------------------------------------------------------------------------------------------ ! local variables character(len=256) :: cmessage ! error message for downwind routine - real(rk) :: massIce(2) ! mass of ice in the two layers identified for combination (kg m-2) - real(rk) :: massLiq(2) ! mass of liquid water in the two layers identified for combination (kg m-2) - real(rk) :: bulkDenWat(2) ! bulk density if total water (liquid water plus ice) in the two layers identified for combination (kg m-3) - real(rk) :: cBulkDenWat ! combined bulk density of total water (liquid water plus ice) in the two layers identified for combination (kg m-3) - real(rk) :: cTemp ! combined layer temperature - real(rk) :: cDepth ! combined layer depth - real(rk) :: cVolFracIce ! combined layer volumetric fraction of ice - real(rk) :: cVolFracLiq ! combined layer volumetric fraction of liquid water - real(rk) :: l1Enthalpy,l2Enthalpy ! enthalpy in the two layers identified for combination (J m-3) - real(rk) :: cEnthalpy ! combined layer enthalpy (J m-3) - real(rk) :: fLiq ! fraction of liquid water at the combined temperature cTemp - real(rk),parameter :: eTol=1.e-1_rk ! tolerance for the enthalpy-->temperature conversion (J m-3) + real(dp) :: massIce(2) ! mass of ice in the two layers identified for combination (kg m-2) + real(dp) :: massLiq(2) ! mass of liquid water in the two layers identified for combination (kg m-2) + real(dp) :: bulkDenWat(2) ! bulk density if total water (liquid water plus ice) in the two layers identified for combination (kg m-3) + real(dp) :: cBulkDenWat ! combined bulk density of total water (liquid water plus ice) in the two layers identified for combination (kg m-3) + real(dp) :: cTemp ! combined layer temperature + real(dp) :: cDepth ! combined layer depth + real(dp) :: cVolFracIce ! combined layer volumetric fraction of ice + real(dp) :: cVolFracLiq ! combined layer volumetric fraction of liquid water + real(dp) :: l1Enthalpy,l2Enthalpy ! enthalpy in the two layers identified for combination (J m-3) + real(dp) :: cEnthalpy ! combined layer enthalpy (J m-3) + real(dp) :: fLiq ! fraction of liquid water at the combined temperature cTemp + real(dp),parameter :: eTol=1.e-1_dp ! tolerance for the enthalpy-->temperature conversion (J m-3) integer(i4b) :: nSnow ! number of snow layers integer(i4b) :: nSoil ! number of soil layers integer(i4b) :: nLayers ! total number of layers @@ -390,7 +390,7 @@ subroutine layer_combine(mpar_data,prog_data,diag_data,flux_data,indx_data,iSnow ! compute volumetric fraction of ice and liquid water cVolFracLiq = fLiq *cBulkDenWat/iden_water - cVolFracIce = (1._rk - fLiq)*cBulkDenWat/iden_ice + cVolFracIce = (1._dp - fLiq)*cBulkDenWat/iden_ice ! end association of local variables with information in the data structures end associate @@ -459,7 +459,7 @@ subroutine rmLyAllVars(dataStruct,metaStruct,iSnow,nSnow,nLayers,err,message) integer(i4b) :: ivar ! variable index integer(i4b) :: ix_lower ! lower bound of the vector integer(i4b) :: ix_upper ! upper bound of the vector - real(rk),allocatable :: tempVec_rk(:) ! temporary vector (double precision) + real(dp),allocatable :: tempVec_dp(:) ! temporary vector (double precision) integer(i4b),allocatable :: tempVec_i4b(:) ! temporary vector (integer) character(LEN=256) :: cmessage ! error message of downwind routine ! initialize error control @@ -493,20 +493,20 @@ subroutine rmLyAllVars(dataStruct,metaStruct,iSnow,nSnow,nLayers,err,message) ! check allocated if(.not.allocated(dataStruct%var(ivar)%dat))then; err=20; message='data vector is not allocated'; return; end if ! allocate the temporary vector - allocate(tempVec_rk(ix_lower:ix_upper-1), stat=err) + allocate(tempVec_dp(ix_lower:ix_upper-1), stat=err) if(err/=0)then; err=20; message=trim(message)//'unable to allocate temporary vector'; return; end if ! copy elements across to the temporary vector - if(iSnow>=ix_lower) tempVec_rk(iSnow) = realMissing ! set merged layer to missing (fill in later) - if(iSnow>ix_lower) tempVec_rk(ix_lower:iSnow-1) = dataStruct%var(ivar)%dat(ix_lower:iSnow-1) - if(iSnow+1=ix_lower) tempVec_dp(iSnow) = realMissing ! set merged layer to missing (fill in later) + if(iSnow>ix_lower) tempVec_dp(ix_lower:iSnow-1) = dataStruct%var(ivar)%dat(ix_lower:iSnow-1) + if(iSnow+11)then - ! do k=2,n - ! arth_r(k) = arth_r(k-1) + increment - ! end do - !end if - !END FUNCTION arth_r + FUNCTION arth_r(first,increment,n) + implicit none + REAL(SP), INTENT(IN) :: first,increment + INTEGER(I4B), INTENT(IN) :: n + REAL(SP), DIMENSION(n) :: arth_r + INTEGER(I4B) :: k + arth_r(1)=first + if(n>1)then + do k=2,n + arth_r(k) = arth_r(k-1) + increment + end do + end if + END FUNCTION arth_r ! ------------------------------------------------------------------------------------------------ FUNCTION arth_d(first,increment,n) implicit none - real(rk), INTENT(IN) :: first,increment + REAL(DP), INTENT(IN) :: first,increment INTEGER(I4B), INTENT(IN) :: n - real(rk), DIMENSION(n) :: arth_d + REAL(DP), DIMENSION(n) :: arth_d INTEGER(I4B) :: k arth_d(1)=first if(n>1)then @@ -62,11 +62,11 @@ END FUNCTION arth_i SUBROUTINE indexx(arr,index) IMPLICIT NONE !INTEGER(I4B), DIMENSION(:), INTENT(IN) :: arr - real(rk), DIMENSION(:), INTENT(IN) :: arr + REAL(DP), DIMENSION(:), INTENT(IN) :: arr INTEGER(I4B), DIMENSION(:), INTENT(OUT) :: index INTEGER(I4B), PARAMETER :: NN=15, NSTACK=50 !INTEGER(I4B) :: a - real(rk) :: a + REAL(DP) :: a INTEGER(I4B) :: n,k,i,j,indext,jstack,l,r INTEGER(I4B), DIMENSION(NSTACK) :: istack n=size(arr) diff --git a/build/source/engine/nrtype.f90 b/build/source/engine/nrtype.f90 index 9e82f8609..3e1c3de34 100755 --- a/build/source/engine/nrtype.f90 +++ b/build/source/engine/nrtype.f90 @@ -8,7 +8,6 @@ MODULE nrtype INTEGER, PARAMETER :: SP = KIND(1.0) INTEGER, PARAMETER :: DP = KIND(1.0D0) INTEGER, PARAMETER :: QP = KIND(1.0D0) - INTEGER, PARAMETER :: rk = DP !INTEGER, PARAMETER :: QP = SELECTED_REAL_KIND(32) INTEGER, PARAMETER :: SPC = KIND((1.0,1.0)) INTEGER, PARAMETER :: DPC = KIND((1.0D0,1.0D0)) @@ -19,11 +18,11 @@ MODULE nrtype REAL(SP), PARAMETER :: TWOPI=6.283185307179586476925286766559005768394_sp REAL(SP), PARAMETER :: SQRT2=1.41421356237309504880168872420969807856967_sp REAL(SP), PARAMETER :: EULER=0.5772156649015328606065120900824024310422_sp - real(rk), PARAMETER :: PI_D=3.141592653589793238462643383279502884197_rk - real(rk), PARAMETER :: PIO2_D=1.57079632679489661923132169163975144209858_rk - real(rk), PARAMETER :: TWOPI_D=6.283185307179586476925286766559005768394_rk + REAL(DP), PARAMETER :: PI_D=3.141592653589793238462643383279502884197_dp + REAL(DP), PARAMETER :: PIO2_D=1.57079632679489661923132169163975144209858_dp + REAL(DP), PARAMETER :: TWOPI_D=6.283185307179586476925286766559005768394_dp ! missing values - real(rk), parameter :: nr_quadMissing=-9999._qp ! missing quadruple precision number - real(rk), parameter :: nr_realMissing=-9999._rk ! missing double precision number + real(qp), parameter :: nr_quadMissing=-9999._qp ! missing quadruple precision number + real(dp), parameter :: nr_realMissing=-9999._dp ! missing double precision number integer(i4b), parameter :: nr_integerMissing=-9999 ! missing integer END MODULE nrtype diff --git a/build/source/engine/opSplittin.f90 b/build/source/engine/opSplittin.f90 index e9abc2125..3020ae20f 100755 --- a/build/source/engine/opSplittin.f90 +++ b/build/source/engine/opSplittin.f90 @@ -147,10 +147,10 @@ module opSplittin_module integer(i4b),parameter :: nDomains=4 ! number of domains (vegetation, snow, soil, and aquifer) ! control parameters -real(rk),parameter :: valueMissing=-9999._rk ! missing value -real(rk),parameter :: verySmall=1.e-12_rk ! a very small number (used to check consistency) -real(rk),parameter :: veryBig=1.e+20_rk ! a very big number -real(rk),parameter :: dx = 1.e-8_rk ! finite difference increment +real(dp),parameter :: valueMissing=-9999._dp ! missing value +real(dp),parameter :: verySmall=1.e-12_dp ! a very small number (used to check consistency) +real(dp),parameter :: veryBig=1.e+20_dp ! a very big number +real(dp),parameter :: dx = 1.e-8_dp ! finite difference increment contains @@ -210,7 +210,7 @@ subroutine opSplittin(& integer(i4b),intent(in) :: nSoil ! number of soil layers integer(i4b),intent(in) :: nLayers ! total number of layers integer(i4b),intent(in) :: nState ! total number of state variables - real(rk),intent(inout) :: dt ! time step (seconds) + real(dp),intent(inout) :: dt ! time step (seconds) logical(lgt),intent(in) :: firstSubStep ! flag to indicate if we are processing the first sub-step logical(lgt),intent(in) :: computeVegFlux ! flag to indicate if we are computing fluxes over vegetation (.false. means veg is buried with snow) ! input/output: data structures @@ -225,7 +225,7 @@ subroutine opSplittin(& type(var_dlength),intent(in) :: bvar_data ! model variables for the local basin type(model_options),intent(in) :: model_decisions(:) ! model decisions ! output: model control - real(rk),intent(out) :: dtMultiplier ! substep multiplier (-) + real(dp),intent(out) :: dtMultiplier ! substep multiplier (-) logical(lgt),intent(out) :: tooMuchMelt ! flag to denote that ice is insufficient to support melt logical(lgt),intent(out) :: stepFailure ! flag to denote step failure integer(i4b),intent(out) :: err ! error code @@ -249,19 +249,19 @@ subroutine opSplittin(& type(var_dlength) :: diag_temp ! temporary model diagnostic variables type(var_dlength) :: flux_temp ! temporary model fluxes type(var_dlength) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables - real(rk),dimension(nLayers) :: mLayerVolFracIceInit ! initial vector for volumetric fraction of ice (-) + real(dp),dimension(nLayers) :: mLayerVolFracIceInit ! initial vector for volumetric fraction of ice (-) ! ------------------------------------------------------------------------------------------------------ ! * operator splitting ! ------------------------------------------------------------------------------------------------------ ! minimum timestep - real(rk),parameter :: dtmin_coupled=1800._rk ! minimum time step for the fully coupled solution (seconds) - real(rk),parameter :: dtmin_split=60._rk ! minimum time step for the fully split solution (seconds) - real(rk),parameter :: dtmin_scalar=10._rk ! minimum time step for the scalar solution (seconds) - real(rk) :: dt_min ! minimum time step (seconds) - real(rk) :: dtInit ! initial time step (seconds) + real(dp),parameter :: dtmin_coupled=1800._dp ! minimum time step for the fully coupled solution (seconds) + real(dp),parameter :: dtmin_split=60._dp ! minimum time step for the fully split solution (seconds) + real(dp),parameter :: dtmin_scalar=10._dp ! minimum time step for the scalar solution (seconds) + real(dp) :: dt_min ! minimum time step (seconds) + real(dp) :: dtInit ! initial time step (seconds) ! explicit error tolerance (depends on state type split, so defined here) - real(rk),parameter :: errorTolLiqFlux=0.01_rk ! error tolerance in the explicit solution (liquid flux) - real(rk),parameter :: errorTolNrgFlux=10._rk ! error tolerance in the explicit solution (energy flux) + real(dp),parameter :: errorTolLiqFlux=0.01_dp ! error tolerance in the explicit solution (liquid flux) + real(dp),parameter :: errorTolNrgFlux=10._dp ! error tolerance in the explicit solution (energy flux) ! number of substeps taken for a given split integer(i4b) :: nSubsteps ! number of substeps taken for a given split ! named variables defining the coupling and solution method @@ -443,12 +443,12 @@ subroutine opSplittin(& do iVar=1,size(flux_meta) ! loop through fluxes if(flux2state_orig(iVar)%state1==integerMissing .and. flux2state_orig(iVar)%state2==integerMissing) cycle ! flux does not depend on state (e.g., input) if(flux2state_orig(iVar)%state1==iname_watCanopy .and. .not.computeVegFlux) cycle ! use input fluxes in cases where there is no canopy - flux_data%var(iVar)%dat(:) = 0._rk + flux_data%var(iVar)%dat(:) = 0._dp end do ! initialize derivatives do iVar=1,size(deriv_meta) - deriv_data%var(iVar)%dat(:) = 0._rk + deriv_data%var(iVar)%dat(:) = 0._dp end do ! ========================================================================================================================================== @@ -978,7 +978,7 @@ subroutine opSplittin(& end do ! use step halving if unable to complete the fully coupled solution in one substep - if(ixCoupling/=fullyCoupled .or. nSubsteps>1) dtMultiplier=0.5_rk + if(ixCoupling/=fullyCoupled .or. nSubsteps>1) dtMultiplier=0.5_dp ! compute the melt in each snow and soil layer if(nSnow>0) mLayerMeltFreeze( 1:nSnow ) = -(mLayerVolFracIce( 1:nSnow ) - mLayerVolFracIceInit( 1:nSnow ))*iden_ice diff --git a/build/source/engine/pOverwrite.f90 b/build/source/engine/pOverwrite.f90 index 4bb19ff77..d90b5bdd5 100755 --- a/build/source/engine/pOverwrite.f90 +++ b/build/source/engine/pOverwrite.f90 @@ -51,7 +51,7 @@ subroutine pOverwrite(ixVeg,ixSoil,defaultParam,err,message) integer(i4b),intent(in) :: ixVeg ! vegetation category integer(i4b),intent(in) :: ixSoil ! soil category ! define output - real(rk),intent(inout) :: defaultParam(:) ! default model parameters + real(dp),intent(inout) :: defaultParam(:) ! default model parameters integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! Start procedure here diff --git a/build/source/engine/paramCheck.f90 b/build/source/engine/paramCheck.f90 index ae5991075..8ca2fecef 100755 --- a/build/source/engine/paramCheck.f90 +++ b/build/source/engine/paramCheck.f90 @@ -49,9 +49,9 @@ subroutine paramCheck(mpar_data,err,message) character(*),intent(out) :: message ! error message ! local variables integer(i4b) :: iLayer ! index of model layers - real(rk),dimension(5) :: zminLayer ! minimum layer depth in each layer (m) - real(rk),dimension(4) :: zmaxLayer_lower ! lower value of maximum layer depth - real(rk),dimension(4) :: zmaxLayer_upper ! upper value of maximum layer depth + real(dp),dimension(5) :: zminLayer ! minimum layer depth in each layer (m) + real(dp),dimension(4) :: zmaxLayer_lower ! lower value of maximum layer depth + real(dp),dimension(4) :: zmaxLayer_upper ! upper value of maximum layer depth ! Start procedure here err=0; message="paramCheck/" @@ -63,7 +63,7 @@ subroutine paramCheck(mpar_data,err,message) select case(model_decisions(iLookDECISIONS%snowLayers)%iDecision) ! SNTHERM option case(sameRulesAllLayers) - if(mpar_data%var(iLookPARAM%zmax)%dat(1)/mpar_data%var(iLookPARAM%zmin)%dat(1) < 2.5_rk)then + if(mpar_data%var(iLookPARAM%zmax)%dat(1)/mpar_data%var(iLookPARAM%zmin)%dat(1) < 2.5_dp)then message=trim(message)//'zmax must be at least 2.5 times larger than zmin: this avoids merging layers that have just been divided' err=20; return end if @@ -93,7 +93,7 @@ subroutine paramCheck(mpar_data,err,message) err=20; return end if ! ensure that the maximum thickness is 3 times greater than the minimum thickness - if(zmaxLayer_upper(iLayer)/zminLayer(iLayer) < 2.5_rk .or. zmaxLayer_upper(iLayer)/zminLayer(iLayer+1) < 2.5_rk)then + if(zmaxLayer_upper(iLayer)/zminLayer(iLayer) < 2.5_dp .or. zmaxLayer_upper(iLayer)/zminLayer(iLayer+1) < 2.5_dp)then write(*,'(a,1x,3(f20.10,1x))') 'zmaxLayer_upper(iLayer), zminLayer(iLayer), zminLayer(iLayer+1) = ', & zmaxLayer_upper(iLayer), zminLayer(iLayer), zminLayer(iLayer+1) write(message,'(a,3(i0,a))') trim(message)//'zmaxLayer_upper for layer ',iLayer,' must be 2.5 times larger than zminLayer for layers ',& diff --git a/build/source/engine/qTimeDelay.f90 b/build/source/engine/qTimeDelay.f90 index 810c48639..75cb75c0a 100755 --- a/build/source/engine/qTimeDelay.f90 +++ b/build/source/engine/qTimeDelay.f90 @@ -52,14 +52,14 @@ subroutine qOverland(& implicit none ! input integer(i4b),intent(in) :: ixRouting ! index for routing method - real(rk),intent(in) :: averageSurfaceRunoff ! surface runoff (m s-1) - real(rk),intent(in) :: averageSoilBaseflow ! baseflow from the soil profile (m s-1) - real(rk),intent(in) :: averageAquiferBaseflow ! baseflow from the aquifer (m s-1) - real(rk),intent(in) :: fracFuture(:) ! fraction of runoff in future time steps (m s-1) - real(rk),intent(inout) :: qFuture(:) ! runoff in future time steps (m s-1) + real(dp),intent(in) :: averageSurfaceRunoff ! surface runoff (m s-1) + real(dp),intent(in) :: averageSoilBaseflow ! baseflow from the soil profile (m s-1) + real(dp),intent(in) :: averageAquiferBaseflow ! baseflow from the aquifer (m s-1) + real(dp),intent(in) :: fracFuture(:) ! fraction of runoff in future time steps (m s-1) + real(dp),intent(inout) :: qFuture(:) ! runoff in future time steps (m s-1) ! output - real(rk),intent(out) :: averageInstantRunoff ! instantaneous runoff (m s-1) - real(rk),intent(out) :: averageRoutedRunoff ! routed runoff (m s-1) + real(dp),intent(out) :: averageInstantRunoff ! instantaneous runoff (m s-1) + real(dp),intent(out) :: averageRoutedRunoff ! routed runoff (m s-1) integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! internal @@ -89,7 +89,7 @@ subroutine qOverland(& do iFuture=2,nTDH qFuture(iFuture-1) = qFuture(iFuture) end do - qFuture(nTDH) = 0._rk + qFuture(nTDH) = 0._dp !print*, 'averageInstantRunoff, averageRoutedRunoff = ', averageInstantRunoff, averageRoutedRunoff !print*, 'qFuture(1:100) = ', qFuture(1:100) diff --git a/build/source/engine/read_attrb.f90 b/build/source/engine/read_attrb.f90 index 4728a0731..e07fff1a1 100755 --- a/build/source/engine/read_attrb.f90 +++ b/build/source/engine/read_attrb.f90 @@ -239,7 +239,7 @@ subroutine read_attrb(attrFile,nGRU,attrStruct,typeStruct,idStruct,err,message) integer(i4b),parameter :: numerical=102 ! named variable to denote numerical data integer(i4b),parameter :: idrelated=103 ! named variable to denote ID related data integer(i4b) :: categorical_var(1) ! temporary categorical variable from local attributes netcdf file - real(rk) :: numeric_var(1) ! temporary numeric variable from local attributes netcdf file + real(dp) :: numeric_var(1) ! temporary numeric variable from local attributes netcdf file integer(8) :: idrelated_var(1) ! temporary ID related variable from local attributes netcdf file ! define mapping variables diff --git a/build/source/engine/read_force.f90 b/build/source/engine/read_force.f90 index e9e94bbda..bf3435a60 100755 --- a/build/source/engine/read_force.f90 +++ b/build/source/engine/read_force.f90 @@ -63,8 +63,8 @@ module read_force_module public::read_force ! global parameters -real(rk),parameter :: verySmall=1e-3_rk ! tiny number -real(rk),parameter :: smallOffset=1.e-8_rk ! small offset (units=days) to force ih=0 at the start of the day +real(dp),parameter :: verySmall=1e-3_dp ! tiny number +real(dp),parameter :: smallOffset=1.e-8_dp ! small offset (units=days) to force ih=0 at the start of the day contains @@ -95,8 +95,8 @@ subroutine read_force(istep,iFile,iRead,ncid,time_data,forcStruct,err,message) integer(i4b) :: iGRU,iHRU ! index of GRU and HRU character(len=256),save :: infile ! filename character(len=256) :: cmessage ! error message for downwind routine - real(rk) :: startJulDay ! julian day at the start of the year - real(rk) :: currentJulday ! Julian day of current time step + real(dp) :: startJulDay ! julian day at the start of the year + real(dp) :: currentJulday ! Julian day of current time step logical(lgt),parameter :: checkTime=.false. ! flag to check the time ! Start procedure here err=0; message="read_force/" @@ -173,7 +173,7 @@ subroutine read_force(istep,iFile,iRead,ncid,time_data,forcStruct,err,message) ! compute the julian day at the start of the year call compjulday(time_data(iLookTIME%iyyy), & ! input = year - 1, 1, 1, 1, 0._rk, & ! input = month, day, hour, minute, second + 1, 1, 1, 1, 0._dp, & ! input = month, day, hour, minute, second startJulDay,err,cmessage) ! output = julian day (fraction of day) + error control if(err/=0)then; message=trim(message)//trim(cmessage); return; end if @@ -182,7 +182,7 @@ subroutine read_force(istep,iFile,iRead,ncid,time_data,forcStruct,err,message) time_data(iLookTIME%im), & ! input = month time_data(iLookTIME%id), & ! input = day time_data(iLookTIME%ih), & ! input = hour - time_data(iLookTIME%imin),0._rk, & ! input = minute/second + time_data(iLookTIME%imin),0._dp, & ! input = minute/second currentJulday,err,cmessage) ! output = julian day (fraction of day) + error control if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! compute the time since the start of the year (in fractional days) @@ -235,7 +235,7 @@ subroutine getFirstTimestep(currentJulday,iFile,iRead,ncid,err,message) USE nr_utility_module,only:arth ! get a sequence of numbers implicit none ! define input - real(rk),intent(in) :: currentJulday ! Julian day of current time step + real(dp),intent(in) :: currentJulday ! Julian day of current time step ! define input-output variables integer(i4b),intent(inout) :: iFile ! index of current forcing file in forcing file list integer(i4b),intent(inout) :: iRead ! index of read position in time dimension in current netcdf file @@ -252,9 +252,9 @@ subroutine getFirstTimestep(currentJulday,iFile,iRead,ncid,err,message) character(len=256),save :: infile ! filename character(len=256) :: cmessage ! error message for downwind routine integer(i4b) :: nFiles ! number of forcing files - real(rk) :: timeVal(1) ! single time value (restrict time read) - real(rk),allocatable :: fileTime(:) ! array of time from netcdf file - real(rk),allocatable :: diffTime(:) ! array of time differences + real(dp) :: timeVal(1) ! single time value (restrict time read) + real(dp),allocatable :: fileTime(:) ! array of time from netcdf file + real(dp),allocatable :: diffTime(:) ! array of time differences ! Start procedure here err=0; message="getFirstTimestep/" @@ -348,7 +348,7 @@ subroutine openForcingFile(iFile,infile,ncId,err,message) character(len=256) :: cmessage ! error message for downwind routine integer(i4b) :: iyyy,im,id,ih,imin ! date integer(i4b) :: ih_tz,imin_tz ! time zone information - real(rk) :: dsec,dsec_tz ! seconds + real(dp) :: dsec,dsec_tz ! seconds integer(i4b) :: varId ! variable identifier integer(i4b) :: mode ! netcdf file mode integer(i4b) :: attLen ! attribute length @@ -378,8 +378,8 @@ subroutine openForcingFile(iFile,infile,ncId,err,message) case('ncTime'); tmZoneOffsetFracDay = sign(1, ih_tz) * fracDay(ih_tz, & ! time zone hour imin_tz, & ! time zone minute dsec_tz) ! time zone second - case('utcTime'); tmZoneOffsetFracDay = 0._rk - case('localTime'); tmZoneOffsetFracDay = 0._rk + case('utcTime'); tmZoneOffsetFracDay = 0._dp + case('localTime'); tmZoneOffsetFracDay = 0._dp case default; err=20; message=trim(message)//'unable to identify time zone info option'; return end select ! (option time zone option) @@ -391,10 +391,10 @@ subroutine openForcingFile(iFile,infile,ncId,err,message) ! get the time multiplier needed to convert time to units of days select case( trim( refTimeString(1:index(refTimeString,' ')) ) ) - case('seconds'); forcFileInfo(iFile)%convTime2Days=86400._rk - case('minutes'); forcFileInfo(iFile)%convTime2Days=1440._rk - case('hours'); forcFileInfo(iFile)%convTime2Days=24._rk - case('days'); forcFileInfo(iFile)%convTime2Days=1._rk + case('seconds'); forcFileInfo(iFile)%convTime2Days=86400._dp + case('minutes'); forcFileInfo(iFile)%convTime2Days=1440._dp + case('hours'); forcFileInfo(iFile)%convTime2Days=24._dp + case('days'); forcFileInfo(iFile)%convTime2Days=1._dp case default; message=trim(message)//'unable to identify time units'; err=20; return end select @@ -409,7 +409,7 @@ subroutine readForcingData(currentJulday,ncId,iFile,iRead,nHRUlocal,time_data,fo USE time_utils_module,only:compJulday ! convert calendar date to julian day USE get_ixname_module,only:get_ixforce ! identify index of named variable ! dummy variables - real(rk),intent(in) :: currentJulday ! Julian day of current time step + real(dp),intent(in) :: currentJulday ! Julian day of current time step integer(i4b) ,intent(in) :: ncId ! NetCDF ID integer(i4b) ,intent(in) :: iFile ! index of forcing file integer(i4b) ,intent(in) :: iRead ! index in data file @@ -422,7 +422,7 @@ subroutine readForcingData(currentJulday,ncId,iFile,iRead,nHRUlocal,time_data,fo character(len=256) :: cmessage ! error message for downwind routine integer(i4b) :: varId ! variable identifier character(len = nf90_max_name) :: varName ! dimenison name - real(rk) :: varTime(1) ! time variable of current forcing data step being read + real(dp) :: varTime(1) ! time variable of current forcing data step being read ! other local variables integer(i4b) :: iGRU,iHRU ! index of GRU and HRU integer(i4b) :: iHRU_global ! index of HRU in the NetCDF file @@ -431,11 +431,11 @@ subroutine readForcingData(currentJulday,ncId,iFile,iRead,nHRUlocal,time_data,fo integer(i4b) :: iNC ! loop through variables in forcing file integer(i4b) :: iVar ! index of forcing variable in forcing data vector logical(lgt),parameter :: checkTime=.false. ! flag to check the time - real(rk) :: dsec ! double precision seconds (not used) - real(rk) :: dataJulDay ! julian day of current forcing data step being read - real(rk),dimension(nHRUlocal) :: dataVec ! vector of data - real(rk),dimension(1) :: dataVal ! single data value - real(rk),parameter :: dataMin=-1._rk ! minimum allowable data value (all forcing variables should be positive) + real(dp) :: dsec ! double precision seconds (not used) + real(dp) :: dataJulDay ! julian day of current forcing data step being read + real(dp),dimension(nHRUlocal) :: dataVec ! vector of data + real(dp),dimension(1) :: dataVal ! single data value + real(dp),parameter :: dataMin=-1._dp ! minimum allowable data value (all forcing variables should be positive) logical(lgt),dimension(size(forc_meta)) :: checkForce ! flags to check forcing data variables exist logical(lgt),parameter :: simultaneousRead=.true. ! flag to denote reading all HRUs at once ! Start procedure here diff --git a/build/source/engine/read_param.f90 b/build/source/engine/read_param.f90 index 0422727db..05119d36f 100755 --- a/build/source/engine/read_param.f90 +++ b/build/source/engine/read_param.f90 @@ -90,7 +90,7 @@ subroutine read_param(iRunMode,checkHRU,startGRU,nHRU,nGRU,idStruct,mparStruct,b ! data in the netcdf file integer(i4b) :: parLength ! length of the parameter data integer(8),allocatable :: hruId(:) ! HRU identifier in the file - real(rk),allocatable :: parVector(:) ! model parameter vector + real(dp),allocatable :: parVector(:) ! model parameter vector logical :: fexist ! inquire whether the parmTrial file exists integer(i4b) :: fHRU ! index of HRU in input file diff --git a/build/source/engine/read_pinit.f90 b/build/source/engine/read_pinit.f90 index 9017b4448..2a0b350b1 100755 --- a/build/source/engine/read_pinit.f90 +++ b/build/source/engine/read_pinit.f90 @@ -132,9 +132,9 @@ subroutine read_pinit(filenm,isLocal,mpar_meta,parFallback,err,message) ! check we have populated all variables ! NOTE: ultimately need a need a parameter dictionary to ensure that the parameters used are populated if(.not.backwardsCompatible)then ! if we add new variables in future versions of the code, then some may be missing in the input file - if(any(parFallback(:)%default_val < 0.99_rk*realMissing))then + if(any(parFallback(:)%default_val < 0.99_dp*realMissing))then do ivar=1,size(parFallback) - if(parFallback(ivar)%default_val < 0.99_rk*realMissing)then + if(parFallback(ivar)%default_val < 0.99_dp*realMissing)then err=40; message=trim(message)//"variableNonexistent[var="//trim(mpar_meta(ivar)%varname)//"]"; return end if end do @@ -143,8 +143,8 @@ subroutine read_pinit(filenm,isLocal,mpar_meta,parFallback,err,message) else ! (need backwards compatibility) if(isLocal)then if(model_decisions(iLookDECISIONS%cIntercept)%iDecision == unDefined)then - parFallback(iLookPARAM%canopyWettingFactor)%default_val = 1._rk ! maximum wetted fraction of the canopy (-) - parFallback(iLookPARAM%canopyWettingExp)%default_val = 0.666666667_rk ! exponent in canopy wetting function (-) + parFallback(iLookPARAM%canopyWettingFactor)%default_val = 1._dp ! maximum wetted fraction of the canopy (-) + parFallback(iLookPARAM%canopyWettingExp)%default_val = 0.666666667_dp ! exponent in canopy wetting function (-) end if end if end if diff --git a/build/source/engine/run_oneGRU.f90 b/build/source/engine/run_oneGRU.f90 index 3dbcfb1e1..653585ac7 100755 --- a/build/source/engine/run_oneGRU.f90 +++ b/build/source/engine/run_oneGRU.f90 @@ -103,7 +103,7 @@ subroutine run_oneGRU(& ! model control type(gru2hru_map) , intent(inout) :: gruInfo ! HRU information for given GRU (# HRUs, #snow+soil layers) - real(rk) , intent(inout) :: dt_init(:) ! used to initialize the length of the sub-step for each HRU + real(dp) , intent(inout) :: dt_init(:) ! used to initialize the length of the sub-step for each HRU integer(i4b) , intent(inout) :: ixComputeVegFlux(:) ! flag to indicate if we are computing fluxes over vegetation (false=no, true=yes) ! data structures (input) integer(i4b) , intent(in) :: timeVec(:) ! integer vector -- model time data @@ -131,7 +131,7 @@ subroutine run_oneGRU(& integer(i4b) :: nSnow ! number of snow layers integer(i4b) :: nSoil ! number of soil layers integer(i4b) :: nLayers ! total number of layers - real(rk) :: fracHRU ! fractional area of a given HRU (-) + real(dp) :: fracHRU ! fractional area of a given HRU (-) logical(lgt) :: computeVegFluxFlag ! flag to indicate if we are computing fluxes over vegetation (.false. means veg is buried with snow) ! initialize error control @@ -140,17 +140,17 @@ subroutine run_oneGRU(& ! ----- basin initialization -------------------------------------------------------------------------------------------- ! initialize runoff variables - bvarData%var(iLookBVAR%basin__SurfaceRunoff)%dat(1) = 0._rk ! surface runoff (m s-1) - bvarData%var(iLookBVAR%basin__ColumnOutflow)%dat(1) = 0._rk ! outflow from all "outlet" HRUs (those with no downstream HRU) + bvarData%var(iLookBVAR%basin__SurfaceRunoff)%dat(1) = 0._dp ! surface runoff (m s-1) + bvarData%var(iLookBVAR%basin__ColumnOutflow)%dat(1) = 0._dp ! outflow from all "outlet" HRUs (those with no downstream HRU) ! initialize baseflow variables - bvarData%var(iLookBVAR%basin__AquiferRecharge)%dat(1) = 0._rk ! recharge to the aquifer (m s-1) - bvarData%var(iLookBVAR%basin__AquiferBaseflow)%dat(1) = 0._rk ! baseflow from the aquifer (m s-1) - bvarData%var(iLookBVAR%basin__AquiferTranspire)%dat(1) = 0._rk ! transpiration loss from the aquifer (m s-1) + bvarData%var(iLookBVAR%basin__AquiferRecharge)%dat(1) = 0._dp ! recharge to the aquifer (m s-1) + bvarData%var(iLookBVAR%basin__AquiferBaseflow)%dat(1) = 0._dp ! baseflow from the aquifer (m s-1) + bvarData%var(iLookBVAR%basin__AquiferTranspire)%dat(1) = 0._dp ! transpiration loss from the aquifer (m s-1) ! initialize total inflow for each layer in a soil column do iHRU=1,gruInfo%hruCount - fluxHRU%hru(iHRU)%var(iLookFLUX%mLayerColumnInflow)%dat(:) = 0._rk + fluxHRU%hru(iHRU)%var(iLookFLUX%mLayerColumnInflow)%dat(:) = 0._dp end do ! *********************************************************************************************************************** diff --git a/build/source/engine/run_oneHRU.f90 b/build/source/engine/run_oneHRU.f90 index 8f92a9af8..1632e1f77 100755 --- a/build/source/engine/run_oneHRU.f90 +++ b/build/source/engine/run_oneHRU.f90 @@ -114,7 +114,7 @@ subroutine run_oneHRU(& ! model control integer(8) , intent(in) :: hruId ! hruId - real(rk) , intent(inout) :: dt_init ! used to initialize the length of the sub-step for each HRU + real(dp) , intent(inout) :: dt_init ! used to initialize the length of the sub-step for each HRU logical(lgt) , intent(inout) :: computeVegFlux ! flag to indicate if we are computing fluxes over vegetation (false=no, true=yes) integer(i4b) , intent(inout) :: nSnow,nSoil,nLayers ! number of snow and soil layers ! data structures (input) @@ -137,7 +137,7 @@ subroutine run_oneHRU(& ! local variables character(len=256) :: cmessage ! error message - real(rk) , allocatable :: zSoilReverseSign(:) ! height at bottom of each soil layer, negative downwards (m) + real(dp) , allocatable :: zSoilReverseSign(:) ! height at bottom of each soil layer, negative downwards (m) ! initialize error control err=0; write(message, '(A20,I0,A2)' ) 'run_oneHRU (hruId = ',hruId,')/' @@ -201,7 +201,7 @@ subroutine run_oneHRU(& ! ----- run the model -------------------------------------------------------------------------------------------------- ! initialize the number of flux calls - diagData%var(iLookDIAG%numFluxCalls)%dat(1) = 0._rk + diagData%var(iLookDIAG%numFluxCalls)%dat(1) = 0._dp ! run the model for a single HRU call coupled_em(& diff --git a/build/source/engine/snowAlbedo.f90 b/build/source/engine/snowAlbedo.f90 index d9555f5a8..c536a437f 100755 --- a/build/source/engine/snowAlbedo.f90 +++ b/build/source/engine/snowAlbedo.f90 @@ -81,7 +81,7 @@ subroutine snowAlbedo(& USE snow_utils_module,only:fracliquid ! compute fraction of liquid water at a given temperature ! -------------------------------------------------------------------------------------------------------------------------------------- ! input: model control - real(rk),intent(in) :: dt ! model time step + real(dp),intent(in) :: dt ! model time step logical(lgt),intent(in) :: snowPresence ! logical flag to denote if snow is present ! input/output: data structures type(model_options),intent(in) :: model_decisions(:) ! model decisions @@ -95,16 +95,16 @@ subroutine snowAlbedo(& ! local variables integer(i4b),parameter :: ixVisible=1 ! named variable to define index in array of visible part of the spectrum integer(i4b),parameter :: ixNearIR=2 ! named variable to define index in array of near IR part of the spectrum - real(rk),parameter :: valueMissing=-9999._rk ! missing value -- will cause problems if snow albedo is ever used for the non-snow case - real(rk),parameter :: slushExp=10._rk ! "slush" exponent, to increase decay when snow is near Tfreeze - real(rk),parameter :: fractionLiqThresh=0.001_rk ! threshold for the fraction of liquid water to switch to spring albedo minimum - real(rk) :: fractionLiq ! fraction of liquid water (-) - real(rk) :: age1,age2,age3 ! aging factors (-) - real(rk) :: decayFactor ! albedo decay factor (-) - real(rk) :: refreshFactor ! albedo refreshment factor, representing albedo increase due to snowfall (-) - real(rk) :: albedoMin ! minimum albedo -- depends if in winter or spring conditions (-) - real(rk) :: fZen ! factor to modify albedo at low zenith angles (-) - real(rk),parameter :: bPar=2._rk ! empirical parameter in fZen + real(dp),parameter :: valueMissing=-9999._dp ! missing value -- will cause problems if snow albedo is ever used for the non-snow case + real(dp),parameter :: slushExp=10._dp ! "slush" exponent, to increase decay when snow is near Tfreeze + real(dp),parameter :: fractionLiqThresh=0.001_dp ! threshold for the fraction of liquid water to switch to spring albedo minimum + real(dp) :: fractionLiq ! fraction of liquid water (-) + real(dp) :: age1,age2,age3 ! aging factors (-) + real(dp) :: decayFactor ! albedo decay factor (-) + real(dp) :: refreshFactor ! albedo refreshment factor, representing albedo increase due to snowfall (-) + real(dp) :: albedoMin ! minimum albedo -- depends if in winter or spring conditions (-) + real(dp) :: fZen ! factor to modify albedo at low zenith angles (-) + real(dp),parameter :: bPar=2._dp ! empirical parameter in fZen ! initialize error control err=0; message='snowAlbedo/' ! -------------------------------------------------------------------------------------------------------------------------------------- @@ -188,18 +188,18 @@ subroutine snowAlbedo(& call computeAlbedo(spectralSnowAlbedoDiffuse(ixVisible),refreshFactor,decayFactor,albedoMaxVisible,albedoMinVisible) call computeAlbedo(spectralSnowAlbedoDiffuse(ixNearIR), refreshFactor,decayFactor,albedoMaxNearIR, albedoMinNearIR) ! compute factor to modify direct albedo at low zenith angles - if(cosZenith < 0.5_rk)then - fZen = (1._rk/bPar)*( ((1._rk + bPar)/(1._rk + 2._rk*bPar*cosZenith)) - 1._rk) + if(cosZenith < 0.5_dp)then + fZen = (1._dp/bPar)*( ((1._dp + bPar)/(1._dp + 2._dp*bPar*cosZenith)) - 1._dp) else - fZen = 0._rk + fZen = 0._dp end if ! compute direct albedo - spectralSnowAlbedoDirect(ixVisible) = spectralSnowAlbedoDiffuse(ixVisible) + 0.4_rk*fZen*(1._rk - spectralSnowAlbedoDiffuse(ixVisible)) - spectralSnowAlbedoDirect(ixNearIR) = spectralSnowAlbedoDiffuse(ixNearIR) + 0.4_rk*fZen*(1._rk - spectralSnowAlbedoDiffuse(ixNearIR)) + spectralSnowAlbedoDirect(ixVisible) = spectralSnowAlbedoDiffuse(ixVisible) + 0.4_dp*fZen*(1._dp - spectralSnowAlbedoDiffuse(ixVisible)) + spectralSnowAlbedoDirect(ixNearIR) = spectralSnowAlbedoDiffuse(ixNearIR) + 0.4_dp*fZen*(1._dp - spectralSnowAlbedoDiffuse(ixNearIR)) ! compute average albedo - scalarSnowAlbedo = ( Frad_direct)*(Frad_vis*spectralSnowAlbedoDirect(ixVisible) + (1._rk - Frad_vis)*spectralSnowAlbedoDirect(ixNearIR) ) + & - (1._rk - Frad_direct)*(Frad_vis*spectralSnowAlbedoDirect(ixVisible) + (1._rk - Frad_vis)*spectralSnowAlbedoDirect(ixNearIR) ) + scalarSnowAlbedo = ( Frad_direct)*(Frad_vis*spectralSnowAlbedoDirect(ixVisible) + (1._dp - Frad_vis)*spectralSnowAlbedoDirect(ixNearIR) ) + & + (1._dp - Frad_direct)*(Frad_vis*spectralSnowAlbedoDirect(ixVisible) + (1._dp - Frad_vis)*spectralSnowAlbedoDirect(ixNearIR) ) ! check that we identified the albedo option case default; err=20; message=trim(message)//'unable to identify option for snow albedo'; return @@ -207,7 +207,7 @@ subroutine snowAlbedo(& end select ! identify option for snow albedo ! check - if(scalarSnowAlbedo < 0._rk)then; err=20; message=trim(message)//'unable to identify option for snow albedo'; return; end if + if(scalarSnowAlbedo < 0._dp)then; err=20; message=trim(message)//'unable to identify option for snow albedo'; return; end if ! end association to data structures end associate @@ -221,15 +221,15 @@ end subroutine snowAlbedo subroutine computeAlbedo(snowAlbedo,refreshFactor,decayFactor,albedoMax,albedoMin) implicit none ! dummy variables - real(rk),intent(inout) :: snowAlbedo ! snow albedo (-) - real(rk),intent(in) :: refreshFactor ! albedo refreshment factor (-) - real(rk),intent(in) :: decayFactor ! albedo decay factor (-) - real(rk),intent(in) :: albedoMax ! maximum albedo (-) - real(rk),intent(in) :: albedoMin ! minimum albedo (-) + real(dp),intent(inout) :: snowAlbedo ! snow albedo (-) + real(dp),intent(in) :: refreshFactor ! albedo refreshment factor (-) + real(dp),intent(in) :: decayFactor ! albedo decay factor (-) + real(dp),intent(in) :: albedoMax ! maximum albedo (-) + real(dp),intent(in) :: albedoMin ! minimum albedo (-) ! local variables - real(rk) :: albedoChange ! change in albedo over the time step (-) + real(dp) :: albedoChange ! change in albedo over the time step (-) ! compute change in albedo - albedoChange = refreshFactor*(albedoMax - snowAlbedo) - (decayFactor*(snowAlbedo - albedoMin)) / (1._rk + decayFactor) + albedoChange = refreshFactor*(albedoMax - snowAlbedo) - (decayFactor*(snowAlbedo - albedoMin)) / (1._dp + decayFactor) snowAlbedo = snowAlbedo + albedoChange if(snowAlbedo > albedoMax) snowAlbedo = albedoMax end subroutine computeAlbedo diff --git a/build/source/engine/snowLiqFlx.f90 b/build/source/engine/snowLiqFlx.f90 index f0330d235..53b4fb29a 100755 --- a/build/source/engine/snowLiqFlx.f90 +++ b/build/source/engine/snowLiqFlx.f90 @@ -75,18 +75,18 @@ subroutine snowLiqFlx(& logical(lgt),intent(in) :: firstFluxCall ! the first flux call logical(lgt),intent(in) :: scalarSolution ! flag to denote if implementing the scalar solution ! input: forcing for the snow domain - real(rk),intent(in) :: scalarThroughfallRain ! computed throughfall rate (kg m-2 s-1) - real(rk),intent(in) :: scalarCanopyLiqDrainage ! computed drainage of liquid water (kg m-2 s-1) + real(dp),intent(in) :: scalarThroughfallRain ! computed throughfall rate (kg m-2 s-1) + real(dp),intent(in) :: scalarCanopyLiqDrainage ! computed drainage of liquid water (kg m-2 s-1) ! input: model state vector - real(rk),intent(in) :: mLayerVolFracLiqTrial(:) ! trial value of volumetric fraction of liquid water at the current iteration (-) + real(dp),intent(in) :: mLayerVolFracLiqTrial(:) ! trial value of volumetric fraction of liquid water at the current iteration (-) ! input-output: data structures type(var_ilength),intent(in) :: indx_data ! model indices type(var_dlength),intent(in) :: mpar_data ! model parameters type(var_dlength),intent(in) :: prog_data ! prognostic variables for a local HRU type(var_dlength),intent(inout) :: diag_data ! diagnostic variables for a local HRU ! output: fluxes and derivatives - real(rk),intent(inout) :: iLayerLiqFluxSnow(0:) ! vertical liquid water flux at layer interfaces (m s-1) - real(rk),intent(inout) :: iLayerLiqFluxSnowDeriv(0:) ! derivative in vertical liquid water flux at layer interfaces (m s-1) + real(dp),intent(inout) :: iLayerLiqFluxSnow(0:) ! vertical liquid water flux at layer interfaces (m s-1) + real(dp),intent(inout) :: iLayerLiqFluxSnowDeriv(0:) ! derivative in vertical liquid water flux at layer interfaces (m s-1) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message @@ -96,12 +96,12 @@ subroutine snowLiqFlx(& integer(i4b) :: iLayer ! layer index integer(i4b) :: ixTop ! top layer in subroutine call integer(i4b) :: ixBot ! bottom layer in subroutine call - real(rk) :: multResid ! multiplier for the residual water content (-) - real(rk),parameter :: residThrs=550._rk ! ice density threshold to reduce residual liquid water content (kg m-3) - real(rk),parameter :: residScal=10._rk ! scaling factor for residual liquid water content reduction factor (kg m-3) - real(rk),parameter :: maxVolIceContent=0.7_rk ! maximum volumetric ice content to store water (-) - real(rk) :: availCap ! available storage capacity [0,1] (-) - real(rk) :: relSaturn ! relative saturation [0,1] (-) + real(dp) :: multResid ! multiplier for the residual water content (-) + real(dp),parameter :: residThrs=550._dp ! ice density threshold to reduce residual liquid water content (kg m-3) + real(dp),parameter :: residScal=10._dp ! scaling factor for residual liquid water content reduction factor (kg m-3) + real(dp),parameter :: maxVolIceContent=0.7_dp ! maximum volumetric ice content to store water (-) + real(dp) :: availCap ! available storage capacity [0,1] (-) + real(dp) :: relSaturn ! relative saturation [0,1] (-) ! ------------------------------------------------------------------------------------------------------------------------------------------ ! make association of local variables with information in the data structures associate(& @@ -128,7 +128,7 @@ subroutine snowLiqFlx(& end if ! check the meltwater exponent is >=1 - if(mw_exp<1._rk)then; err=20; message=trim(message)//'meltwater exponent < 1'; return; end if + if(mw_exp<1._dp)then; err=20; message=trim(message)//'meltwater exponent < 1'; return; end if ! get the indices for the snow+soil layers ixTop = integerMissing @@ -159,16 +159,16 @@ subroutine snowLiqFlx(& ! define the liquid flux at the upper boundary (m s-1) iLayerLiqFluxSnow(0) = (scalarThroughfallRain + scalarCanopyLiqDrainage)/iden_water - iLayerLiqFluxSnowDeriv(0) = 0._rk + iLayerLiqFluxSnowDeriv(0) = 0._dp ! compute properties fixed over the time step if(firstFluxCall)then ! loop through snow layers do iLayer=1,nSnow ! compute the reduction in liquid water holding capacity at high snow density (-) - multResid = 1._rk / ( 1._rk + exp( (mLayerVolFracIce(iLayer)*iden_ice - residThrs) / residScal) ) + multResid = 1._dp / ( 1._dp + exp( (mLayerVolFracIce(iLayer)*iden_ice - residThrs) / residScal) ) ! compute the pore space (-) - mLayerPoreSpace(iLayer) = 1._rk - mLayerVolFracIce(iLayer) + mLayerPoreSpace(iLayer) = 1._dp - mLayerVolFracIce(iLayer) ! compute the residual volumetric liquid water content (-) mLayerThetaResid(iLayer) = Fcapil*mLayerPoreSpace(iLayer) * multResid end do ! (looping through snow layers) @@ -182,14 +182,14 @@ subroutine snowLiqFlx(& availCap = mLayerPoreSpace(iLayer) - mLayerThetaResid(iLayer) ! available capacity relSaturn = (mLayerVolFracLiqTrial(iLayer) - mLayerThetaResid(iLayer)) / availCap ! relative saturation iLayerLiqFluxSnow(iLayer) = k_snow*relSaturn**mw_exp - iLayerLiqFluxSnowDeriv(iLayer) = ( (k_snow*mw_exp)/availCap ) * relSaturn**(mw_exp - 1._rk) + iLayerLiqFluxSnowDeriv(iLayer) = ( (k_snow*mw_exp)/availCap ) * relSaturn**(mw_exp - 1._dp) if(mLayerVolFracIce(iLayer) > maxVolIceContent)then ! NOTE: use start-of-step ice content, to avoid convergence problems ! ** allow liquid water to pass through under very high ice density iLayerLiqFluxSnow(iLayer) = iLayerLiqFluxSnow(iLayer) + iLayerLiqFluxSnow(iLayer-1) !NOTE: derivative may need to be updated in future. end if else ! flow does not occur - iLayerLiqFluxSnow(iLayer) = 0._rk - iLayerLiqFluxSnowDeriv(iLayer) = 0._rk + iLayerLiqFluxSnow(iLayer) = 0._dp + iLayerLiqFluxSnowDeriv(iLayer) = 0._dp endif ! storage above residual content end do ! loop through snow layers diff --git a/build/source/engine/snow_utils.f90 b/build/source/engine/snow_utils.f90 index 5ceeab63e..496ecfce5 100755 --- a/build/source/engine/snow_utils.f90 +++ b/build/source/engine/snow_utils.f90 @@ -47,11 +47,11 @@ module snow_utils_module ! *********************************************************************************************************** function fracliquid(Tk,fc_param) implicit none - real(rk),intent(in) :: Tk ! temperature (K) - real(rk),intent(in) :: fc_param ! freezing curve parameter (K-1) - real(rk) :: fracliquid ! fraction of liquid water (-) + real(dp),intent(in) :: Tk ! temperature (K) + real(dp),intent(in) :: fc_param ! freezing curve parameter (K-1) + real(dp) :: fracliquid ! fraction of liquid water (-) ! compute fraction of liquid water (-) - fracliquid = 1._rk / ( 1._rk + (fc_param*( Tfreeze - min(Tk,Tfreeze) ))**2._rk ) + fracliquid = 1._dp / ( 1._dp + (fc_param*( Tfreeze - min(Tk,Tfreeze) ))**2._dp ) end function fracliquid @@ -60,11 +60,11 @@ end function fracliquid ! *********************************************************************************************************** function templiquid(fracliquid,fc_param) implicit none - real(rk),intent(in) :: fracliquid ! fraction of liquid water (-) - real(rk),intent(in) :: fc_param ! freezing curve parameter (K-1) - real(rk) :: templiquid ! temperature (K) + real(dp),intent(in) :: fracliquid ! fraction of liquid water (-) + real(dp),intent(in) :: fc_param ! freezing curve parameter (K-1) + real(dp) :: templiquid ! temperature (K) ! compute temperature based on the fraction of liquid water (K) - templiquid = Tfreeze - ((1._rk/fracliquid - 1._rk)/fc_param**2._rk)**(0.5_rk) + templiquid = Tfreeze - ((1._dp/fracliquid - 1._dp)/fc_param**2._dp)**(0.5_dp) end function templiquid @@ -74,17 +74,17 @@ end function templiquid function dFracLiq_dTk(Tk,fc_param) implicit none ! dummies - real(rk),intent(in) :: Tk ! temperature (K) - real(rk),intent(in) :: fc_param ! freezing curve parameter (K-1) - real(rk) :: dFracLiq_dTk ! differentiate the freezing curve (K-1) + real(dp),intent(in) :: Tk ! temperature (K) + real(dp),intent(in) :: fc_param ! freezing curve parameter (K-1) + real(dp) :: dFracLiq_dTk ! differentiate the freezing curve (K-1) ! locals - real(rk) :: Tdep ! temperature depression (K) - real(rk) :: Tdim ! dimensionless temperature (-) + real(dp) :: Tdep ! temperature depression (K) + real(dp) :: Tdim ! dimensionless temperature (-) ! compute local variables (just to make things more efficient) Tdep = Tfreeze - min(Tk,Tfreeze) Tdim = fc_param*Tdep ! differentiate the freezing curve w.r.t temperature - dFracLiq_dTk = (fc_param*2._rk*Tdim) / ( ( 1._rk + Tdim**2._rk)**2._rk ) + dFracLiq_dTk = (fc_param*2._dp*Tdim) / ( ( 1._dp + Tdim**2._dp)**2._dp ) end function dFracLiq_dTk @@ -93,17 +93,17 @@ end function dFracLiq_dTk ! *********************************************************************************************************** subroutine tcond_snow(BulkDenIce,thermlcond,err,message) implicit none - real(rk),intent(in) :: BulkDenIce ! bulk density of ice (kg m-3) - real(rk),intent(out) :: thermlcond ! thermal conductivity of snow (W m-1 K-1) + real(dp),intent(in) :: BulkDenIce ! bulk density of ice (kg m-3) + real(dp),intent(out) :: thermlcond ! thermal conductivity of snow (W m-1 K-1) integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! initialize error control err=0; message="tcond_snow/" ! compute thermal conductivity of snow select case(model_decisions(iLookDECISIONS%thCondSnow)%iDecision) - case(Yen1965); thermlcond = 3.217d-6 * BulkDenIce**2._rk ! Yen (1965) - case(Mellor1977); thermlcond = 2.576d-6 * BulkDenIce**2._rk + 7.4d-2 ! Mellor (1977) - case(Jordan1991); thermlcond = lambda_air + (7.75d-5*BulkDenIce + 1.105d-6*(BulkDenIce**2._rk)) & + case(Yen1965); thermlcond = 3.217d-6 * BulkDenIce**2._dp ! Yen (1965) + case(Mellor1977); thermlcond = 2.576d-6 * BulkDenIce**2._dp + 7.4d-2 ! Mellor (1977) + case(Jordan1991); thermlcond = lambda_air + (7.75d-5*BulkDenIce + 1.105d-6*(BulkDenIce**2._dp)) & * (lambda_ice-lambda_air) ! Jordan (1991) case default err=10; message=trim(message)//"unknownOption"; return diff --git a/build/source/engine/snwCompact.f90 b/build/source/engine/snwCompact.f90 index e15ea8637..8f3441bce 100755 --- a/build/source/engine/snwCompact.f90 +++ b/build/source/engine/snwCompact.f90 @@ -65,43 +65,43 @@ subroutine snwDensify(& ! compute change in snow density over the time step implicit none ! intent(in): variables - real(rk),intent(in) :: dt ! time step (seconds) + real(dp),intent(in) :: dt ! time step (seconds) integer(i4b),intent(in) :: nSnow ! number of snow layers - real(rk),intent(in) :: mLayerTemp(:) ! temperature of each snow layer after iterations (K) - real(rk),intent(in) :: mLayerMeltFreeze(:) ! volumetric melt in each layer (kg m-3) + real(dp),intent(in) :: mLayerTemp(:) ! temperature of each snow layer after iterations (K) + real(dp),intent(in) :: mLayerMeltFreeze(:) ! volumetric melt in each layer (kg m-3) ! intent(in): parameters - real(rk),intent(in) :: densScalGrowth ! density scaling factor for grain growth (kg-1 m3) - real(rk),intent(in) :: tempScalGrowth ! temperature scaling factor for grain growth (K-1) - real(rk),intent(in) :: grainGrowthRate ! rate of grain growth (s-1) - real(rk),intent(in) :: densScalOvrbdn ! density scaling factor for overburden pressure (kg-1 m3) - real(rk),intent(in) :: tempScalOvrbdn ! temperature scaling factor for overburden pressure (K-1) - real(rk),intent(in) :: baseViscosity ! viscosity coefficient at T=T_frz and snow density=0 (kg m-2 s) + real(dp),intent(in) :: densScalGrowth ! density scaling factor for grain growth (kg-1 m3) + real(dp),intent(in) :: tempScalGrowth ! temperature scaling factor for grain growth (K-1) + real(dp),intent(in) :: grainGrowthRate ! rate of grain growth (s-1) + real(dp),intent(in) :: densScalOvrbdn ! density scaling factor for overburden pressure (kg-1 m3) + real(dp),intent(in) :: tempScalOvrbdn ! temperature scaling factor for overburden pressure (K-1) + real(dp),intent(in) :: baseViscosity ! viscosity coefficient at T=T_frz and snow density=0 (kg m-2 s) ! intent(inout): state variables - real(rk),intent(inout) :: mLayerDepth(:) ! depth of each layer (m) - real(rk),intent(inout) :: mLayerVolFracLiqNew(:) ! volumetric fraction of liquid water in each snow layer after iterations (-) - real(rk),intent(inout) :: mLayerVolFracIceNew(:) ! volumetric fraction of ice in each snow layer after iterations (-) + real(dp),intent(inout) :: mLayerDepth(:) ! depth of each layer (m) + real(dp),intent(inout) :: mLayerVolFracLiqNew(:) ! volumetric fraction of liquid water in each snow layer after iterations (-) + real(dp),intent(inout) :: mLayerVolFracIceNew(:) ! volumetric fraction of ice in each snow layer after iterations (-) ! intent(out): error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! ----------------------------------------------------------------------------------------------------------------------------------------- ! define local variables integer(i4b) :: iSnow ! index of snow layers - real(rk) :: chi1,chi2,chi3,chi4,chi5 ! multipliers in the densification algorithm (-) - real(rk) :: halfWeight ! half of the weight of the current snow layer (kg m-2) - real(rk) :: weightSnow ! total weight of snow above the current snow layer (kg m-2) - real(rk) :: CR_grainGrowth ! compaction rate for grain growth (s-1) - real(rk) :: CR_ovrvdnPress ! compaction rate associated with over-burden pressure (s-1) - real(rk) :: CR_metamorph ! compaction rate for metamorphism (s-1) - real(rk) :: massIceOld ! mass of ice in the snow layer (kg m-2) - real(rk) :: massLiqOld ! mass of liquid water in the snow layer (kg m-2) - real(rk) :: scalarDepthNew ! updated layer depth (m) - real(rk) :: scalarDepthMin ! minimum layer depth (m) - real(rk) :: volFracIceLoss ! volumetric fraction of ice lost due to melt and sublimation (-) - real(rk), dimension(nSnow) :: mLayerVolFracAirNew ! volumetric fraction of air in each layer after compaction (-) - real(rk),parameter :: snwden_min=100._rk ! minimum snow density for reducing metamorphism rate (kg m-3) - real(rk),parameter :: snwDensityMax=550._rk ! maximum snow density for collapse under melt (kg m-3) - real(rk),parameter :: wetSnowThresh=0.01_rk ! threshold to discriminate between "wet" and "dry" snow - real(rk),parameter :: minLayerDensity=40._rk ! minimum snow density allowed for any layer (kg m-3) + real(dp) :: chi1,chi2,chi3,chi4,chi5 ! multipliers in the densification algorithm (-) + real(dp) :: halfWeight ! half of the weight of the current snow layer (kg m-2) + real(dp) :: weightSnow ! total weight of snow above the current snow layer (kg m-2) + real(dp) :: CR_grainGrowth ! compaction rate for grain growth (s-1) + real(dp) :: CR_ovrvdnPress ! compaction rate associated with over-burden pressure (s-1) + real(dp) :: CR_metamorph ! compaction rate for metamorphism (s-1) + real(dp) :: massIceOld ! mass of ice in the snow layer (kg m-2) + real(dp) :: massLiqOld ! mass of liquid water in the snow layer (kg m-2) + real(dp) :: scalarDepthNew ! updated layer depth (m) + real(dp) :: scalarDepthMin ! minimum layer depth (m) + real(dp) :: volFracIceLoss ! volumetric fraction of ice lost due to melt and sublimation (-) + real(dp), dimension(nSnow) :: mLayerVolFracAirNew ! volumetric fraction of air in each layer after compaction (-) + real(dp),parameter :: snwden_min=100._dp ! minimum snow density for reducing metamorphism rate (kg m-3) + real(dp),parameter :: snwDensityMax=550._dp ! maximum snow density for collapse under melt (kg m-3) + real(dp),parameter :: wetSnowThresh=0.01_dp ! threshold to discriminate between "wet" and "dry" snow + real(dp),parameter :: minLayerDensity=40._dp ! minimum snow density allowed for any layer (kg m-3) ! ----------------------------------------------------------------------------------------------------------------------------------------- ! initialize error control err=0; message="snwDensify/" @@ -110,7 +110,7 @@ subroutine snwDensify(& if(nSnow==0)return ! initialize the weight of snow above each layer (kg m-2) - weightSnow = 0._rk + weightSnow = 0._dp ! loop through snow layers do iSnow=1,nSnow @@ -124,19 +124,19 @@ subroutine snwDensify(& ! *** compute the compaction associated with grain growth (s-1) ! compute the base rate of grain growth (-) - if(mLayerVolFracIceNew(iSnow)*iden_ice =snwden_min) chi1=exp(-densScalGrowth*(mLayerVolFracIceNew(iSnow)*iden_ice - snwden_min)) ! compute the reduction of grain growth under colder snow temperatures (-) chi2 = exp(-tempScalGrowth*(Tfreeze - mLayerTemp(iSnow))) ! compute the acceleration of grain growth in the presence of liquid water (-) - if(mLayerVolFracLiqNew(iSnow) > wetSnowThresh)then; chi3=2._rk ! snow is "wet" - else; chi3=1._rk; end if ! snow is "dry" + if(mLayerVolFracLiqNew(iSnow) > wetSnowThresh)then; chi3=2._dp ! snow is "wet" + else; chi3=1._dp; end if ! snow is "dry" ! compute the compaction associated with grain growth (s-1) CR_grainGrowth = grainGrowthRate*chi1*chi2*chi3 ! **** compute the compaction associated with over-burden pressure (s-1) ! compute the weight imposed on the current layer (kg m-2) - halfWeight = (massIceOld + massLiqOld)/2._rk ! there is some over-burden pressure from the layer itself + halfWeight = (massIceOld + massLiqOld)/2._dp ! there is some over-burden pressure from the layer itself weightSnow = weightSnow + halfweight ! add half of the weight from the current layer ! compute the increase in compaction under colder snow temperatures (-) chi4 = exp(-tempScalOvrbdn*(Tfreeze - mLayerTemp(iSnow))) @@ -151,7 +151,7 @@ subroutine snwDensify(& ! NOTE: loss of ice due to snowmelt is implicit, so can be updated directly if(iden_ice*mLayerVolFracIceNew(iSnow) < snwDensityMax)then ! only collapse layers if below a critical density ! (compute volumetric losses of ice due to melt and sublimation) - volFracIceLoss = max(0._rk,mLayerMeltFreeze(iSnow)/iden_ice) ! volumetric fraction of ice lost due to melt (-) + volFracIceLoss = max(0._dp,mLayerMeltFreeze(iSnow)/iden_ice) ! volumetric fraction of ice lost due to melt (-) ! (adjust snow depth to account for cavitation) scalarDepthNew = mLayerDepth(iSnow) * mLayerVolFracIceNew(iSnow)/(mLayerVolFracIceNew(iSnow) + volFracIceLoss) !print*, 'volFracIceLoss = ', volFracIceLoss @@ -163,12 +163,12 @@ subroutine snwDensify(& ! update depth due to metamorphism (implicit solution) ! Ensure that the new depth is in line with the maximum amount of compaction that ! can occur given the masses of ice and liquid in the layer - scalarDepthNew = scalarDepthNew/(1._rk + CR_metamorph*dt) + scalarDepthNew = scalarDepthNew/(1._dp + CR_metamorph*dt) scalarDepthMin = (massIceOld / iden_ice) + (massLiqOld / iden_water) mLayerDepth(iSnow) = max(scalarDepthMin, scalarDepthNew) ! check that depth is reasonable - if(mLayerDepth(iSnow) < 0._rk)then + if(mLayerDepth(iSnow) < 0._dp)then write(*,'(a,1x,i4,1x,10(f12.5,1x))') 'iSnow, dt, density,massIceOld, massLiqOld = ', iSnow, dt, mLayerVolFracIceNew(iSnow)*iden_ice, massIceOld, massLiqOld write(*,'(a,1x,i4,1x,10(f12.5,1x))') 'iSnow, mLayerDepth(iSnow), scalarDepthNew, mLayerVolFracIceNew(iSnow), mLayerMeltFreeze(iSnow), CR_grainGrowth*dt, CR_ovrvdnPress*dt = ', & iSnow, mLayerDepth(iSnow), scalarDepthNew, mLayerVolFracIceNew(iSnow), mLayerMeltFreeze(iSnow), CR_grainGrowth*dt, CR_ovrvdnPress*dt @@ -177,14 +177,14 @@ subroutine snwDensify(& ! update volumetric ice and liquid water content mLayerVolFracIceNew(iSnow) = massIceOld/(mLayerDepth(iSnow)*iden_ice) mLayerVolFracLiqNew(iSnow) = massLiqOld/(mLayerDepth(iSnow)*iden_water) - mLayerVolFracAirNew(iSnow) = 1.0_rk - mLayerVolFracIceNew(iSnow) - mLayerVolFracLiqNew(iSnow) + mLayerVolFracAirNew(iSnow) = 1.0_dp - mLayerVolFracIceNew(iSnow) - mLayerVolFracLiqNew(iSnow) !write(*,'(a,1x,i4,1x,f9.3)') 'after compact: iSnow, density = ', iSnow, mLayerVolFracIceNew(iSnow)*iden_ice - !if(mLayerMeltFreeze(iSnow) > 20._rk) pause 'meaningful melt' + !if(mLayerMeltFreeze(iSnow) > 20._dp) pause 'meaningful melt' end do ! looping through snow layers ! check depth - if(any(mLayerDepth(1:nSnow) < 0._rk))then + if(any(mLayerDepth(1:nSnow) < 0._dp))then do iSnow=1,nSnow write(*,'(a,1x,i4,1x,4(f12.5,1x))') 'iSnow, mLayerDepth(iSnow)', iSnow, mLayerDepth(iSnow) end do @@ -194,7 +194,7 @@ subroutine snwDensify(& ! check for low/high snow density if(any(mLayerVolFracIceNew(1:nSnow)*iden_ice + mLayerVolFracLiqNew(1:nSnow)*iden_water + mLayerVolFracAirNew(1:nSnow)*iden_air < minLayerDensity) .or. & - any(mLayerVolFracIceNew(1:nSnow) + mLayerVolFracLiqNew(1:nSnow) + mLayerVolFracAirNew(1:nSnow) > 1._rk))then + any(mLayerVolFracIceNew(1:nSnow) + mLayerVolFracLiqNew(1:nSnow) + mLayerVolFracAirNew(1:nSnow) > 1._dp))then do iSnow=1,nSnow write(*,*) 'iSnow, volFracIce, density = ', iSnow, mLayerVolFracIceNew(iSnow), mLayerVolFracIceNew(iSnow)*iden_ice end do diff --git a/build/source/engine/soilLiqFlx.f90 b/build/source/engine/soilLiqFlx.f90 index 5837b300d..52eb06ce6 100755 --- a/build/source/engine/soilLiqFlx.f90 +++ b/build/source/engine/soilLiqFlx.f90 @@ -80,8 +80,8 @@ module soilLiqFlx_module private public::soilLiqFlx ! constant parameters -real(rk),parameter :: verySmall=1.e-12_rk ! a very small number (used to avoid divide by zero) -real(rk),parameter :: dx=1.e-8_rk ! finite difference increment +real(dp),parameter :: verySmall=1.e-12_dp ! a very small number (used to avoid divide by zero) +real(dp),parameter :: dx=1.e-8_dp ! finite difference increment contains @@ -150,17 +150,17 @@ subroutine soilLiqFlx(& logical(lgt),intent(in) :: scalarSolution ! flag to denote if implementing the scalar solution logical(lgt),intent(in) :: deriv_desired ! flag indicating if derivatives are desired ! input: trial model state variables - real(rk),intent(in) :: mLayerTempTrial(:) ! temperature in each layer at the current iteration (m) - real(rk),intent(in) :: mLayerMatricHeadTrial(:) ! matric head in each layer at the current iteration (m) - real(rk),intent(in) :: mLayerVolFracLiqTrial(:) ! volumetric fraction of liquid water at the current iteration (-) - real(rk),intent(in) :: mLayerVolFracIceTrial(:) ! volumetric fraction of ice at the current iteration (-) + real(dp),intent(in) :: mLayerTempTrial(:) ! temperature in each layer at the current iteration (m) + real(dp),intent(in) :: mLayerMatricHeadTrial(:) ! matric head in each layer at the current iteration (m) + real(dp),intent(in) :: mLayerVolFracLiqTrial(:) ! volumetric fraction of liquid water at the current iteration (-) + real(dp),intent(in) :: mLayerVolFracIceTrial(:) ! volumetric fraction of ice at the current iteration (-) ! input: pre-computed derivatves - real(rk),intent(in) :: mLayerdTheta_dTk(:) ! derivative in volumetric liquid water content w.r.t. temperature (K-1) - real(rk),intent(in) :: dPsiLiq_dTemp(:) ! derivative in liquid water matric potential w.r.t. temperature (m K-1) + real(dp),intent(in) :: mLayerdTheta_dTk(:) ! derivative in volumetric liquid water content w.r.t. temperature (K-1) + real(dp),intent(in) :: dPsiLiq_dTemp(:) ! derivative in liquid water matric potential w.r.t. temperature (m K-1) ! input: model fluxes - real(rk),intent(in) :: scalarCanopyTranspiration ! canopy transpiration (kg m-2 s-1) - real(rk),intent(in) :: scalarGroundEvaporation ! ground evaporation (kg m-2 s-1) - real(rk),intent(in) :: scalarRainPlusMelt ! rain plus melt (m s-1) + real(dp),intent(in) :: scalarCanopyTranspiration ! canopy transpiration (kg m-2 s-1) + real(dp),intent(in) :: scalarGroundEvaporation ! ground evaporation (kg m-2 s-1) + real(dp),intent(in) :: scalarRainPlusMelt ! rain plus melt (m s-1) ! input-output: data structures type(var_dlength),intent(in) :: mpar_data ! model parameters type(var_ilength),intent(in) :: indx_data ! state vector geometry @@ -168,25 +168,25 @@ subroutine soilLiqFlx(& type(var_dlength),intent(inout) :: diag_data ! diagnostic variables for a local HRU type(var_dlength),intent(inout) :: flux_data ! model fluxes for a local HRU ! output: diagnostic variables for surface runoff - real(rk),intent(inout) :: xMaxInfilRate ! maximum infiltration rate (m s-1) - real(rk),intent(inout) :: scalarInfilArea ! fraction of unfrozen area where water can infiltrate (-) - real(rk),intent(inout) :: scalarFrozenArea ! fraction of area that is considered impermeable due to soil ice (-) - real(rk),intent(inout) :: scalarSurfaceRunoff ! surface runoff (m s-1) + real(dp),intent(inout) :: xMaxInfilRate ! maximum infiltration rate (m s-1) + real(dp),intent(inout) :: scalarInfilArea ! fraction of unfrozen area where water can infiltrate (-) + real(dp),intent(inout) :: scalarFrozenArea ! fraction of area that is considered impermeable due to soil ice (-) + real(dp),intent(inout) :: scalarSurfaceRunoff ! surface runoff (m s-1) ! output: diagnostic variables for each layer - real(rk),intent(inout) :: mLayerdTheta_dPsi(:) ! derivative in the soil water characteristic w.r.t. psi (m-1) - real(rk),intent(inout) :: mLayerdPsi_dTheta(:) ! derivative in the soil water characteristic w.r.t. theta (m) - real(rk),intent(inout) :: dHydCond_dMatric(:) ! derivative in hydraulic conductivity w.r.t matric head (s-1) + real(dp),intent(inout) :: mLayerdTheta_dPsi(:) ! derivative in the soil water characteristic w.r.t. psi (m-1) + real(dp),intent(inout) :: mLayerdPsi_dTheta(:) ! derivative in the soil water characteristic w.r.t. theta (m) + real(dp),intent(inout) :: dHydCond_dMatric(:) ! derivative in hydraulic conductivity w.r.t matric head (s-1) ! output: liquid fluxes - real(rk),intent(inout) :: scalarSurfaceInfiltration ! surface infiltration rate (m s-1) - real(rk),intent(inout) :: iLayerLiqFluxSoil(0:) ! liquid flux at soil layer interfaces (m s-1) - real(rk),intent(inout) :: mLayerTranspire(:) ! transpiration loss from each soil layer (m s-1) - real(rk),intent(inout) :: mLayerHydCond(:) ! hydraulic conductivity in each soil layer (m s-1) + real(dp),intent(inout) :: scalarSurfaceInfiltration ! surface infiltration rate (m s-1) + real(dp),intent(inout) :: iLayerLiqFluxSoil(0:) ! liquid flux at soil layer interfaces (m s-1) + real(dp),intent(inout) :: mLayerTranspire(:) ! transpiration loss from each soil layer (m s-1) + real(dp),intent(inout) :: mLayerHydCond(:) ! hydraulic conductivity in each soil layer (m s-1) ! output: derivatives in fluxes w.r.t. state variables in the layer above and layer below (m s-1) - real(rk),intent(inout) :: dq_dHydStateAbove(0:) ! derivative in the flux in layer interfaces w.r.t. state variables in the layer above - real(rk),intent(inout) :: dq_dHydStateBelow(0:) ! derivative in the flux in layer interfaces w.r.t. state variables in the layer below + real(dp),intent(inout) :: dq_dHydStateAbove(0:) ! derivative in the flux in layer interfaces w.r.t. state variables in the layer above + real(dp),intent(inout) :: dq_dHydStateBelow(0:) ! derivative in the flux in layer interfaces w.r.t. state variables in the layer below ! output: derivatives in fluxes w.r.t. energy state variables -- now just temperature -- in the layer above and layer below (m s-1 K-1) - real(rk),intent(inout) :: dq_dNrgStateAbove(0:) ! derivatives in the flux w.r.t. temperature in the layer above (m s-1 K-1) - real(rk),intent(inout) :: dq_dNrgStateBelow(0:) ! derivatives in the flux w.r.t. temperature in the layer below (m s-1 K-1) + real(dp),intent(inout) :: dq_dNrgStateAbove(0:) ! derivatives in the flux w.r.t. temperature in the layer above (m s-1 K-1) + real(dp),intent(inout) :: dq_dNrgStateBelow(0:) ! derivatives in the flux w.r.t. temperature in the layer below (m s-1 K-1) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message @@ -208,34 +208,34 @@ subroutine soilLiqFlx(& integer(i4b),parameter :: perturbStateBelow=3 ! named variable to identify the case where we perturb the state layer below integer(i4b) :: ixPerturb ! index of element in 2-element vector to perturb integer(i4b) :: ixOriginal ! index of perturbed element in the original vector - real(rk) :: scalarVolFracLiqTrial ! trial value of volumetric liquid water content (-) - real(rk) :: scalarMatricHeadTrial ! trial value of matric head (m) - real(rk) :: scalarHydCondTrial ! trial value of hydraulic conductivity (m s-1) - real(rk) :: scalarHydCondMicro ! trial value of hydraulic conductivity of micropores (m s-1) - real(rk) :: scalarHydCondMacro ! trial value of hydraulic conductivity of macropores (m s-1) - real(rk) :: scalarFlux ! vertical flux (m s-1) - real(rk) :: scalarFlux_dStateAbove ! vertical flux with perturbation to the state above (m s-1) - real(rk) :: scalarFlux_dStateBelow ! vertical flux with perturbation to the state below (m s-1) + real(dp) :: scalarVolFracLiqTrial ! trial value of volumetric liquid water content (-) + real(dp) :: scalarMatricHeadTrial ! trial value of matric head (m) + real(dp) :: scalarHydCondTrial ! trial value of hydraulic conductivity (m s-1) + real(dp) :: scalarHydCondMicro ! trial value of hydraulic conductivity of micropores (m s-1) + real(dp) :: scalarHydCondMacro ! trial value of hydraulic conductivity of macropores (m s-1) + real(dp) :: scalarFlux ! vertical flux (m s-1) + real(dp) :: scalarFlux_dStateAbove ! vertical flux with perturbation to the state above (m s-1) + real(dp) :: scalarFlux_dStateBelow ! vertical flux with perturbation to the state below (m s-1) ! transpiration sink term - real(rk),dimension(nSoil) :: mLayerTranspireFrac ! fraction of transpiration allocated to each soil layer (-) + real(dp),dimension(nSoil) :: mLayerTranspireFrac ! fraction of transpiration allocated to each soil layer (-) ! diagnostic variables - real(rk),dimension(nSoil) :: iceImpedeFac ! ice impedence factor at layer mid-points (-) - real(rk),dimension(nSoil) :: mLayerDiffuse ! diffusivity at layer mid-point (m2 s-1) - real(rk),dimension(nSoil) :: dHydCond_dVolLiq ! derivative in hydraulic conductivity w.r.t volumetric liquid water content (m s-1) - real(rk),dimension(nSoil) :: dDiffuse_dVolLiq ! derivative in hydraulic diffusivity w.r.t volumetric liquid water content (m2 s-1) - real(rk),dimension(nSoil) :: dHydCond_dTemp ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) - real(rk),dimension(0:nSoil) :: iLayerHydCond ! hydraulic conductivity at layer interface (m s-1) - real(rk),dimension(0:nSoil) :: iLayerDiffuse ! diffusivity at layer interface (m2 s-1) + real(dp),dimension(nSoil) :: iceImpedeFac ! ice impedence factor at layer mid-points (-) + real(dp),dimension(nSoil) :: mLayerDiffuse ! diffusivity at layer mid-point (m2 s-1) + real(dp),dimension(nSoil) :: dHydCond_dVolLiq ! derivative in hydraulic conductivity w.r.t volumetric liquid water content (m s-1) + real(dp),dimension(nSoil) :: dDiffuse_dVolLiq ! derivative in hydraulic diffusivity w.r.t volumetric liquid water content (m2 s-1) + real(dp),dimension(nSoil) :: dHydCond_dTemp ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) + real(dp),dimension(0:nSoil) :: iLayerHydCond ! hydraulic conductivity at layer interface (m s-1) + real(dp),dimension(0:nSoil) :: iLayerDiffuse ! diffusivity at layer interface (m2 s-1) ! compute surface flux integer(i4b) :: nRoots ! number of soil layers with roots integer(i4b) :: ixIce ! index of the lowest soil layer that contains ice - real(rk),dimension(0:nSoil) :: iLayerHeight ! height of the layer interfaces (m) + real(dp),dimension(0:nSoil) :: iLayerHeight ! height of the layer interfaces (m) ! compute fluxes and derivatives at layer interfaces - real(rk),dimension(2) :: vectorVolFracLiqTrial ! trial value of volumetric liquid water content (-) - real(rk),dimension(2) :: vectorMatricHeadTrial ! trial value of matric head (m) - real(rk),dimension(2) :: vectorHydCondTrial ! trial value of hydraulic conductivity (m s-1) - real(rk),dimension(2) :: vectorDiffuseTrial ! trial value of hydraulic diffusivity (m2 s-1) - real(rk) :: scalardPsi_dTheta ! derivative in soil water characteristix, used for perturbations when computing numerical derivatives + real(dp),dimension(2) :: vectorVolFracLiqTrial ! trial value of volumetric liquid water content (-) + real(dp),dimension(2) :: vectorMatricHeadTrial ! trial value of matric head (m) + real(dp),dimension(2) :: vectorHydCondTrial ! trial value of hydraulic conductivity (m s-1) + real(dp),dimension(2) :: vectorDiffuseTrial ! trial value of hydraulic diffusivity (m2 s-1) + real(dp) :: scalardPsi_dTheta ! derivative in soil water characteristix, used for perturbations when computing numerical derivatives ! ------------------------------------------------------------------------------------------------------------------------------------------------- ! initialize error control err=0; message='soilLiqFlx/' @@ -364,7 +364,7 @@ subroutine soilLiqFlx(& end if ! check fractions sum to one - if(abs(sum(mLayerTranspireFrac) - 1._rk) > verySmall)then + if(abs(sum(mLayerTranspireFrac) - 1._dp) > verySmall)then message=trim(message)//'fraction transpiration in soil layers does not sum to one' err=20; return endif @@ -373,7 +373,7 @@ subroutine soilLiqFlx(& mLayerTranspire = mLayerTranspireFrac(:)*scalarCanopyTranspiration/iden_water ! special case of prescribed head -- no transpiration - if(ixBcUpperSoilHydrology==prescribedHead) mLayerTranspire(:) = 0._rk + if(ixBcUpperSoilHydrology==prescribedHead) mLayerTranspire(:) = 0._dp endif ! if need to compute transpiration @@ -435,8 +435,8 @@ subroutine soilLiqFlx(& ! ------------------------------------------------------------------------------------------------------------------------------------------------- ! set derivative w.r.t. state above to zero (does not exist) - dq_dHydStateAbove(0) = 0._rk - dq_dNrgStateAbove(0) = 0._rk + dq_dHydStateAbove(0) = 0._dp + dq_dNrgStateAbove(0) = 0._dp ! either one or multiple flux calls, depending on if using analytical or numerical derivatives do itry=nFlux,0,-1 ! (work backwards to ensure all computed fluxes come from the un-perturbed case) @@ -821,8 +821,8 @@ subroutine soilLiqFlx(& end if ! no dependence on the aquifer for drainage - dq_dHydStateBelow(nSoil) = 0._rk ! keep this here in case we want to couple some day.... - dq_dNrgStateBelow(nSoil) = 0._rk ! keep this here in case we want to couple some day.... + dq_dHydStateBelow(nSoil) = 0._dp ! keep this here in case we want to couple some day.... + dq_dNrgStateBelow(nSoil) = 0._dp ! keep this here in case we want to couple some day.... ! print drainage !print*, 'iLayerLiqFluxSoil(nSoil) = ', iLayerLiqFluxSoil(nSoil) @@ -897,66 +897,66 @@ subroutine diagv_node(& logical(lgt),intent(in) :: deriv_desired ! flag indicating if derivatives are desired integer(i4b),intent(in) :: ixRichards ! index defining the option for Richards' equation (moisture or mixdform) ! input: state and diagnostic variables - real(rk),intent(in) :: scalarTempTrial ! temperature in each layer (K) - real(rk),intent(in) :: scalarMatricHeadTrial ! matric head in each layer (m) - real(rk),intent(in) :: scalarVolFracLiqTrial ! volumetric fraction of liquid water in a given layer (-) - real(rk),intent(in) :: scalarVolFracIceTrial ! volumetric fraction of ice in a given layer (-) + real(dp),intent(in) :: scalarTempTrial ! temperature in each layer (K) + real(dp),intent(in) :: scalarMatricHeadTrial ! matric head in each layer (m) + real(dp),intent(in) :: scalarVolFracLiqTrial ! volumetric fraction of liquid water in a given layer (-) + real(dp),intent(in) :: scalarVolFracIceTrial ! volumetric fraction of ice in a given layer (-) ! input: pre-computed deriavatives - real(rk),intent(in) :: dTheta_dTk ! derivative in volumetric liquid water content w.r.t. temperature (K-1) - real(rk),intent(in) :: dPsiLiq_dTemp ! derivative in liquid water matric potential w.r.t. temperature (m K-1) + real(dp),intent(in) :: dTheta_dTk ! derivative in volumetric liquid water content w.r.t. temperature (K-1) + real(dp),intent(in) :: dPsiLiq_dTemp ! derivative in liquid water matric potential w.r.t. temperature (m K-1) ! input: soil parameters - real(rk),intent(in) :: vGn_alpha ! van Genutchen "alpha" parameter (m-1) - real(rk),intent(in) :: vGn_n ! van Genutchen "n" parameter (-) - real(rk),intent(in) :: vGn_m ! van Genutchen "m" parameter (-) - real(rk),intent(in) :: mpExp ! empirical exponent in macropore flow equation (-) - real(rk),intent(in) :: theta_sat ! soil porosity (-) - real(rk),intent(in) :: theta_res ! soil residual volumetric water content (-) - real(rk),intent(in) :: theta_mp ! volumetric liquid water content when macropore flow begins (-) - real(rk),intent(in) :: f_impede ! ice impedence factor (-) + real(dp),intent(in) :: vGn_alpha ! van Genutchen "alpha" parameter (m-1) + real(dp),intent(in) :: vGn_n ! van Genutchen "n" parameter (-) + real(dp),intent(in) :: vGn_m ! van Genutchen "m" parameter (-) + real(dp),intent(in) :: mpExp ! empirical exponent in macropore flow equation (-) + real(dp),intent(in) :: theta_sat ! soil porosity (-) + real(dp),intent(in) :: theta_res ! soil residual volumetric water content (-) + real(dp),intent(in) :: theta_mp ! volumetric liquid water content when macropore flow begins (-) + real(dp),intent(in) :: f_impede ! ice impedence factor (-) ! input: saturated hydraulic conductivity - real(rk),intent(in) :: scalarSatHydCond ! saturated hydraulic conductivity at the mid-point of a given layer (m s-1) - real(rk),intent(in) :: scalarSatHydCondMP ! saturated hydraulic conductivity of macropores at the mid-point of a given layer (m s-1) + real(dp),intent(in) :: scalarSatHydCond ! saturated hydraulic conductivity at the mid-point of a given layer (m s-1) + real(dp),intent(in) :: scalarSatHydCondMP ! saturated hydraulic conductivity of macropores at the mid-point of a given layer (m s-1) ! output: derivative in the soil water characteristic - real(rk),intent(out) :: scalardPsi_dTheta ! derivative in the soil water characteristic - real(rk),intent(out) :: scalardTheta_dPsi ! derivative in the soil water characteristic + real(dp),intent(out) :: scalardPsi_dTheta ! derivative in the soil water characteristic + real(dp),intent(out) :: scalardTheta_dPsi ! derivative in the soil water characteristic ! output: transmittance - real(rk),intent(out) :: scalarHydCond ! hydraulic conductivity at layer mid-points (m s-1) - real(rk),intent(out) :: scalarDiffuse ! diffusivity at layer mid-points (m2 s-1) - real(rk),intent(out) :: iceImpedeFac ! ice impedence factor in each layer (-) + real(dp),intent(out) :: scalarHydCond ! hydraulic conductivity at layer mid-points (m s-1) + real(dp),intent(out) :: scalarDiffuse ! diffusivity at layer mid-points (m2 s-1) + real(dp),intent(out) :: iceImpedeFac ! ice impedence factor in each layer (-) ! output: transmittance derivatives - real(rk),intent(out) :: dHydCond_dVolLiq ! derivative in hydraulic conductivity w.r.t volumetric liquid water content (m s-1) - real(rk),intent(out) :: dDiffuse_dVolLiq ! derivative in hydraulic diffusivity w.r.t volumetric liquid water content (m2 s-1) - real(rk),intent(out) :: dHydCond_dMatric ! derivative in hydraulic conductivity w.r.t matric head (s-1) - real(rk),intent(out) :: dHydCond_dTemp ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) + real(dp),intent(out) :: dHydCond_dVolLiq ! derivative in hydraulic conductivity w.r.t volumetric liquid water content (m s-1) + real(dp),intent(out) :: dDiffuse_dVolLiq ! derivative in hydraulic diffusivity w.r.t volumetric liquid water content (m2 s-1) + real(dp),intent(out) :: dHydCond_dMatric ! derivative in hydraulic conductivity w.r.t matric head (s-1) + real(dp),intent(out) :: dHydCond_dTemp ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! local variables - real(rk) :: localVolFracLiq ! local volumetric fraction of liquid water - real(rk) :: scalarHydCondMP ! hydraulic conductivity of macropores at layer mid-points (m s-1) - real(rk) :: dIceImpede_dT ! derivative in ice impedance factor w.r.t. temperature (K-1) - real(rk) :: dHydCondMacro_dVolLiq ! derivative in hydraulic conductivity of macropores w.r.t volumetric liquid water content (m s-1) - real(rk) :: dHydCondMacro_dMatric ! derivative in hydraulic conductivity of macropores w.r.t matric head (s-1) - real(rk) :: dHydCondMicro_dMatric ! derivative in hydraulic conductivity of micropores w.r.t matric head (s-1) - real(rk) :: dHydCondMicro_dTemp ! derivative in hydraulic conductivity of micropores w.r.t temperature (m s-1 K-1) - real(rk) :: dPsi_dTheta2a ! derivative in dPsi_dTheta (analytical) - real(rk) :: dIceImpede_dLiq ! derivative in ice impedence factor w.r.t. volumetric liquid water content (-) - real(rk) :: hydCond_noIce ! hydraulic conductivity in the absence of ice (m s-1) - real(rk) :: dK_dLiq__noIce ! derivative in hydraulic conductivity w.r.t volumetric liquid water content, in the absence of ice (m s-1) - real(rk) :: dK_dPsi__noIce ! derivative in hydraulic conductivity w.r.t matric head, in the absence of ice (s-1) - real(rk) :: relSatMP ! relative saturation of macropores (-) + real(dp) :: localVolFracLiq ! local volumetric fraction of liquid water + real(dp) :: scalarHydCondMP ! hydraulic conductivity of macropores at layer mid-points (m s-1) + real(dp) :: dIceImpede_dT ! derivative in ice impedance factor w.r.t. temperature (K-1) + real(dp) :: dHydCondMacro_dVolLiq ! derivative in hydraulic conductivity of macropores w.r.t volumetric liquid water content (m s-1) + real(dp) :: dHydCondMacro_dMatric ! derivative in hydraulic conductivity of macropores w.r.t matric head (s-1) + real(dp) :: dHydCondMicro_dMatric ! derivative in hydraulic conductivity of micropores w.r.t matric head (s-1) + real(dp) :: dHydCondMicro_dTemp ! derivative in hydraulic conductivity of micropores w.r.t temperature (m s-1 K-1) + real(dp) :: dPsi_dTheta2a ! derivative in dPsi_dTheta (analytical) + real(dp) :: dIceImpede_dLiq ! derivative in ice impedence factor w.r.t. volumetric liquid water content (-) + real(dp) :: hydCond_noIce ! hydraulic conductivity in the absence of ice (m s-1) + real(dp) :: dK_dLiq__noIce ! derivative in hydraulic conductivity w.r.t volumetric liquid water content, in the absence of ice (m s-1) + real(dp) :: dK_dPsi__noIce ! derivative in hydraulic conductivity w.r.t matric head, in the absence of ice (s-1) + real(dp) :: relSatMP ! relative saturation of macropores (-) ! local variables to test the derivative logical(lgt),parameter :: testDeriv=.false. ! local flag to test the derivative - real(rk) :: xConst ! LH_fus/(gravity*Tfreeze), used in freezing point depression equation (m K-1) - real(rk) :: vTheta ! volumetric fraction of total water (-) - real(rk) :: volLiq ! volumetric fraction of liquid water (-) - real(rk) :: volIce ! volumetric fraction of ice (-) - real(rk) :: volFracLiq1,volFracLiq2 ! different trial values of volumetric liquid water content (-) - real(rk) :: effSat ! effective saturation (-) - real(rk) :: psiLiq ! liquid water matric potential (m) - real(rk) :: hydCon ! hydraulic conductivity (m s-1) - real(rk) :: hydIce ! hydraulic conductivity after accounting for ice impedance (-) - real(rk),parameter :: dx = 1.e-8_rk ! finite difference increment (m) + real(dp) :: xConst ! LH_fus/(gravity*Tfreeze), used in freezing point depression equation (m K-1) + real(dp) :: vTheta ! volumetric fraction of total water (-) + real(dp) :: volLiq ! volumetric fraction of liquid water (-) + real(dp) :: volIce ! volumetric fraction of ice (-) + real(dp) :: volFracLiq1,volFracLiq2 ! different trial values of volumetric liquid water content (-) + real(dp) :: effSat ! effective saturation (-) + real(dp) :: psiLiq ! liquid water matric potential (m) + real(dp) :: hydCon ! hydraulic conductivity (m s-1) + real(dp) :: hydIce ! hydraulic conductivity after accounting for ice impedance (-) + real(dp),parameter :: dx = 1.e-8_dp ! finite difference increment (m) ! initialize error control err=0; message="diagv_node/" @@ -1020,11 +1020,11 @@ subroutine diagv_node(& ! (compute derivative for macropores) if(localVolFracLiq > theta_mp)then relSatMP = (localVolFracLiq - theta_mp)/(theta_sat - theta_mp) - dHydCondMacro_dVolLiq = ((scalarSatHydCondMP - scalarSatHydCond)/(theta_sat - theta_mp))*mpExp*(relSatMP**(mpExp - 1._rk)) + dHydCondMacro_dVolLiq = ((scalarSatHydCondMP - scalarSatHydCond)/(theta_sat - theta_mp))*mpExp*(relSatMP**(mpExp - 1._dp)) dHydCondMacro_dMatric = scalardTheta_dPsi*dHydCondMacro_dVolLiq else - dHydCondMacro_dVolLiq = 0._rk - dHydCondMacro_dMatric = 0._rk + dHydCondMacro_dVolLiq = 0._dp + dHydCondMacro_dMatric = 0._dp end if ! (compute derivatives for micropores) if(scalarVolFracIceTrial > verySmall)then @@ -1032,7 +1032,7 @@ subroutine diagv_node(& dHydCondMicro_dTemp = dPsiLiq_dTemp*dK_dPsi__noIce ! m s-1 K-1 dHydCondMicro_dMatric = hydCond_noIce*dIceImpede_dLiq*scalardTheta_dPsi + dK_dPsi__noIce*iceImpedeFac else - dHydCondMicro_dTemp = 0._rk + dHydCondMicro_dTemp = 0._dp dHydCondMicro_dMatric = dHydCond_dPsi(scalarMatricHeadTrial,scalarSatHydCond,vGn_alpha,vGn_n,vGn_m,.true.) end if ! (combine derivatives) @@ -1052,7 +1052,7 @@ subroutine diagv_node(& volLiq = volFracLiq(xConst*(scalarTempTrial+dx - Tfreeze),vGn_alpha,theta_res,theta_sat,vGn_n,vGn_m) volIce = vTheta - volLiq effSat = (volLiq - theta_res)/(theta_sat - volIce - theta_res) - psiLiq = matricHead(effSat,vGn_alpha,0._rk,1._rk,vGn_n,vGn_m) ! use effective saturation, so theta_res=0 and theta_sat=1 + psiLiq = matricHead(effSat,vGn_alpha,0._dp,1._dp,vGn_n,vGn_m) ! use effective saturation, so theta_res=0 and theta_sat=1 hydCon = hydCond_psi(psiLiq,scalarSatHydCond,vGn_alpha,vGn_n,vGn_m) call iceImpede(volIce,f_impede,iceImpedeFac,dIceImpede_dLiq) hydIce = hydCon*iceImpedeFac @@ -1150,48 +1150,48 @@ subroutine surfaceFlx(& integer(i4b),intent(in) :: nRoots ! number of layers that contain roots integer(i4b),intent(in) :: ixIce ! index of lowest ice layer ! input: state and diagnostic variables - real(rk),intent(in) :: scalarMatricHead ! matric head in the upper-most soil layer (m) - real(rk),intent(in) :: scalarVolFracLiq ! volumetric liquid water content in the upper-most soil layer (-) - real(rk),intent(in) :: mLayerVolFracLiq(:) ! volumetric liquid water content in each soil layer (-) - real(rk),intent(in) :: mLayerVolFracIce(:) ! volumetric ice content in each soil layer (-) + real(dp),intent(in) :: scalarMatricHead ! matric head in the upper-most soil layer (m) + real(dp),intent(in) :: scalarVolFracLiq ! volumetric liquid water content in the upper-most soil layer (-) + real(dp),intent(in) :: mLayerVolFracLiq(:) ! volumetric liquid water content in each soil layer (-) + real(dp),intent(in) :: mLayerVolFracIce(:) ! volumetric ice content in each soil layer (-) ! input: depth of upper-most soil layer (m) - real(rk),intent(in) :: mLayerDepth(:) ! depth of upper-most soil layer (m) - real(rk),intent(in) :: iLayerHeight(0:) ! height at the interface of each layer (m) + real(dp),intent(in) :: mLayerDepth(:) ! depth of upper-most soil layer (m) + real(dp),intent(in) :: iLayerHeight(0:) ! height at the interface of each layer (m) ! input: diriclet boundary conditions - real(rk),intent(in) :: upperBoundHead ! upper boundary condition for matric head (m) - real(rk),intent(in) :: upperBoundTheta ! upper boundary condition for volumetric liquid water content (-) + real(dp),intent(in) :: upperBoundHead ! upper boundary condition for matric head (m) + real(dp),intent(in) :: upperBoundTheta ! upper boundary condition for volumetric liquid water content (-) ! input: flux at the upper boundary - real(rk),intent(in) :: scalarRainPlusMelt ! rain plus melt, used as input to the soil zone before computing surface runoff (m s-1) + real(dp),intent(in) :: scalarRainPlusMelt ! rain plus melt, used as input to the soil zone before computing surface runoff (m s-1) ! input: transmittance - real(rk),intent(in) :: surfaceSatHydCond ! saturated hydraulic conductivity at the surface (m s-1) - real(rk),intent(in) :: dHydCond_dTemp ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) - real(rk),intent(in) :: iceImpedeFac ! ice impedence factor in the upper-most soil layer (-) + real(dp),intent(in) :: surfaceSatHydCond ! saturated hydraulic conductivity at the surface (m s-1) + real(dp),intent(in) :: dHydCond_dTemp ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) + real(dp),intent(in) :: iceImpedeFac ! ice impedence factor in the upper-most soil layer (-) ! input: soil parameters - real(rk),intent(in) :: vGn_alpha ! van Genutchen "alpha" parameter (m-1) - real(rk),intent(in) :: vGn_n ! van Genutchen "n" parameter (-) - real(rk),intent(in) :: vGn_m ! van Genutchen "m" parameter (-) - real(rk),intent(in) :: theta_sat ! soil porosity (-) - real(rk),intent(in) :: theta_res ! soil residual volumetric water content (-) - real(rk),intent(in) :: qSurfScale ! scaling factor in the surface runoff parameterization (-) - real(rk),intent(in) :: zScale_TOPMODEL ! scaling factor used to describe decrease in hydraulic conductivity with depth (m) - real(rk),intent(in) :: rootingDepth ! rooting depth (m) - real(rk),intent(in) :: wettingFrontSuction ! Green-Ampt wetting front suction (m) - real(rk),intent(in) :: soilIceScale ! soil ice scaling factor in Gamma distribution used to define frozen area (m) - real(rk),intent(in) :: soilIceCV ! soil ice CV in Gamma distribution used to define frozen area (-) + real(dp),intent(in) :: vGn_alpha ! van Genutchen "alpha" parameter (m-1) + real(dp),intent(in) :: vGn_n ! van Genutchen "n" parameter (-) + real(dp),intent(in) :: vGn_m ! van Genutchen "m" parameter (-) + real(dp),intent(in) :: theta_sat ! soil porosity (-) + real(dp),intent(in) :: theta_res ! soil residual volumetric water content (-) + real(dp),intent(in) :: qSurfScale ! scaling factor in the surface runoff parameterization (-) + real(dp),intent(in) :: zScale_TOPMODEL ! scaling factor used to describe decrease in hydraulic conductivity with depth (m) + real(dp),intent(in) :: rootingDepth ! rooting depth (m) + real(dp),intent(in) :: wettingFrontSuction ! Green-Ampt wetting front suction (m) + real(dp),intent(in) :: soilIceScale ! soil ice scaling factor in Gamma distribution used to define frozen area (m) + real(dp),intent(in) :: soilIceCV ! soil ice CV in Gamma distribution used to define frozen area (-) ! ----------------------------------------------------------------------------------------------------------------------------- ! input-output: hydraulic conductivity and diffusivity at the surface ! NOTE: intent(inout) because infiltration may only be computed for the first iteration - real(rk),intent(inout) :: surfaceHydCond ! hydraulic conductivity (m s-1) - real(rk),intent(inout) :: surfaceDiffuse ! hydraulic diffusivity at the surface (m + real(dp),intent(inout) :: surfaceHydCond ! hydraulic conductivity (m s-1) + real(dp),intent(inout) :: surfaceDiffuse ! hydraulic diffusivity at the surface (m ! output: surface runoff and infiltration flux (m s-1) - real(rk),intent(inout) :: xMaxInfilRate ! maximum infiltration rate (m s-1) - real(rk),intent(inout) :: scalarInfilArea ! fraction of unfrozen area where water can infiltrate (-) - real(rk),intent(inout) :: scalarFrozenArea ! fraction of area that is considered impermeable due to soil ice (-) - real(rk),intent(out) :: scalarSurfaceRunoff ! surface runoff (m s-1) - real(rk),intent(out) :: scalarSurfaceInfiltration ! surface infiltration (m s-1) + real(dp),intent(inout) :: xMaxInfilRate ! maximum infiltration rate (m s-1) + real(dp),intent(inout) :: scalarInfilArea ! fraction of unfrozen area where water can infiltrate (-) + real(dp),intent(inout) :: scalarFrozenArea ! fraction of area that is considered impermeable due to soil ice (-) + real(dp),intent(out) :: scalarSurfaceRunoff ! surface runoff (m s-1) + real(dp),intent(out) :: scalarSurfaceInfiltration ! surface infiltration (m s-1) ! output: deriavtives in surface infiltration w.r.t. volumetric liquid water (m s-1) and matric head (s-1) in the upper-most soil layer - real(rk),intent(out) :: dq_dHydState ! derivative in surface infiltration w.r.t. state variable in the upper-most soil layer (m s-1 or s-1) - real(rk),intent(out) :: dq_dNrgState ! derivative in surface infiltration w.r.t. energy state variable in the upper-most soil layer (m s-1 K-1) + real(dp),intent(out) :: dq_dHydState ! derivative in surface infiltration w.r.t. state variable in the upper-most soil layer (m s-1 or s-1) + real(dp),intent(out) :: dq_dNrgState ! derivative in surface infiltration w.r.t. energy state variable in the upper-most soil layer (m s-1 K-1) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message @@ -1200,29 +1200,29 @@ subroutine surfaceFlx(& ! (general) integer(i4b) :: iLayer ! index of soil layer ! (head boundary condition) - real(rk) :: cFlux ! capillary flux (m s-1) - real(rk) :: dNum ! numerical derivative + real(dp) :: cFlux ! capillary flux (m s-1) + real(dp) :: dNum ! numerical derivative ! (simplified Green-Ampt infiltration) - real(rk) :: rootZoneLiq ! depth of liquid water in the root zone (m) - real(rk) :: rootZoneIce ! depth of ice in the root zone (m) - real(rk) :: availCapacity ! available storage capacity in the root zone (m) - real(rk) :: depthWettingFront ! depth to the wetting front (m) - real(rk) :: hydCondWettingFront ! hydraulic conductivity at the wetting front (m s-1) + real(dp) :: rootZoneLiq ! depth of liquid water in the root zone (m) + real(dp) :: rootZoneIce ! depth of ice in the root zone (m) + real(dp) :: availCapacity ! available storage capacity in the root zone (m) + real(dp) :: depthWettingFront ! depth to the wetting front (m) + real(dp) :: hydCondWettingFront ! hydraulic conductivity at the wetting front (m s-1) ! (saturated area associated with variable storage capacity) - real(rk) :: fracCap ! fraction of pore space filled with liquid water and ice (-) - real(rk) :: fInfRaw ! infiltrating area before imposing solution constraints (-) - real(rk),parameter :: maxFracCap=0.995_rk ! maximum fraction capacity -- used to avoid numerical problems associated with an enormous derivative - real(rk),parameter :: scaleFactor=0.000001_rk ! scale factor for the smoothing function (-) - real(rk),parameter :: qSurfScaleMax=1000._rk ! maximum surface runoff scaling factor (-) + real(dp) :: fracCap ! fraction of pore space filled with liquid water and ice (-) + real(dp) :: fInfRaw ! infiltrating area before imposing solution constraints (-) + real(dp),parameter :: maxFracCap=0.995_dp ! maximum fraction capacity -- used to avoid numerical problems associated with an enormous derivative + real(dp),parameter :: scaleFactor=0.000001_dp ! scale factor for the smoothing function (-) + real(dp),parameter :: qSurfScaleMax=1000._dp ! maximum surface runoff scaling factor (-) ! (fraction of impermeable area associated with frozen ground) - real(rk) :: alpha ! shape parameter in the Gamma distribution - real(rk) :: xLimg ! upper limit of the integral + real(dp) :: alpha ! shape parameter in the Gamma distribution + real(dp) :: xLimg ! upper limit of the integral ! initialize error control err=0; message="surfaceFlx/" ! compute derivative in the energy state ! NOTE: revisit the need to do this - dq_dNrgState = 0._rk + dq_dNrgState = 0._dp ! ***** ! compute the surface flux and its derivative @@ -1233,7 +1233,7 @@ subroutine surfaceFlx(& case(prescribedHead) ! surface runoff iz zero for the head condition - scalarSurfaceRunoff = 0._rk + scalarSurfaceRunoff = 0._dp ! compute transmission and the capillary flux select case(ixRichards) ! (form of Richards' equation) @@ -1242,13 +1242,13 @@ subroutine surfaceFlx(& surfaceHydCond = hydCond_liq(upperBoundTheta,surfaceSatHydCond,theta_res,theta_sat,vGn_m) * iceImpedeFac surfaceDiffuse = dPsi_dTheta(upperBoundTheta,vGn_alpha,theta_res,theta_sat,vGn_n,vGn_m) * surfaceHydCond ! compute the capillary flux - cflux = -surfaceDiffuse*(scalarVolFracLiq - upperBoundTheta) / (mLayerDepth(1)*0.5_rk) + cflux = -surfaceDiffuse*(scalarVolFracLiq - upperBoundTheta) / (mLayerDepth(1)*0.5_dp) case(mixdform) ! compute the hydraulic conductivity and diffusivity at the boundary surfaceHydCond = hydCond_psi(upperBoundHead,surfaceSatHydCond,vGn_alpha,vGn_n,vGn_m) * iceImpedeFac surfaceDiffuse = realMissing ! compute the capillary flux - cflux = -surfaceHydCond*(scalarMatricHead - upperBoundHead) / (mLayerDepth(1)*0.5_rk) + cflux = -surfaceHydCond*(scalarMatricHead - upperBoundHead) / (mLayerDepth(1)*0.5_dp) case default; err=10; message=trim(message)//"unknown form of Richards' equation"; return end select ! (form of Richards' eqn) ! compute the total flux @@ -1257,19 +1257,19 @@ subroutine surfaceFlx(& if(deriv_desired)then ! compute the hydrology derivative select case(ixRichards) ! (form of Richards' equation) - case(moisture); dq_dHydState = -surfaceDiffuse/(mLayerDepth(1)/2._rk) - case(mixdform); dq_dHydState = -surfaceHydCond/(mLayerDepth(1)/2._rk) + case(moisture); dq_dHydState = -surfaceDiffuse/(mLayerDepth(1)/2._dp) + case(mixdform); dq_dHydState = -surfaceHydCond/(mLayerDepth(1)/2._dp) case default; err=10; message=trim(message)//"unknown form of Richards' equation"; return end select ! compute the energy derivative - dq_dNrgState = -(dHydCond_dTemp/2._rk)*(scalarMatricHead - upperBoundHead)/(mLayerDepth(1)*0.5_rk) + dHydCond_dTemp/2._rk + dq_dNrgState = -(dHydCond_dTemp/2._dp)*(scalarMatricHead - upperBoundHead)/(mLayerDepth(1)*0.5_dp) + dHydCond_dTemp/2._dp ! compute the numerical derivative - !cflux = -surfaceHydCond*((scalarMatricHead+dx) - upperBoundHead) / (mLayerDepth(1)*0.5_rk) + !cflux = -surfaceHydCond*((scalarMatricHead+dx) - upperBoundHead) / (mLayerDepth(1)*0.5_dp) !surfaceInfiltration1 = cflux + surfaceHydCond !dNum = (surfaceInfiltration1 - scalarSurfaceInfiltration)/dx else - dq_dHydState = 0._rk - dNum = 0._rk + dq_dHydState = 0._dp + dNum = 0._dp end if !write(*,'(a,1x,10(e30.20,1x))') 'scalarMatricHead, scalarSurfaceInfiltration, dq_dHydState, dNum = ', & ! scalarMatricHead, scalarSurfaceInfiltration, dq_dHydState, dNum @@ -1282,8 +1282,8 @@ subroutine surfaceFlx(& if(doInfiltration)then ! define the storage in the root zone (m) - rootZoneLiq = 0._rk - rootZoneIce = 0._rk + rootZoneLiq = 0._dp + rootZoneIce = 0._dp ! (process layers where the roots extend to the bottom of the layer) if(nRoots > 1)then do iLayer=1,nRoots-1 @@ -1306,7 +1306,7 @@ subroutine surfaceFlx(& depthWettingFront = (rootZoneLiq/availCapacity)*rootingDepth ! define the hydraulic conductivity at depth=depthWettingFront (m s-1) - hydCondWettingFront = surfaceSatHydCond * ( (1._rk - depthWettingFront/sum(mLayerDepth))**(zScale_TOPMODEL - 1._rk) ) + hydCondWettingFront = surfaceSatHydCond * ( (1._dp - depthWettingFront/sum(mLayerDepth))**(zScale_TOPMODEL - 1._dp) ) ! define the maximum infiltration rate (m s-1) xMaxInfilRate = hydCondWettingFront*( (wettingFrontSuction + depthWettingFront)/depthWettingFront ) ! maximum infiltration rate (m s-1) @@ -1315,15 +1315,15 @@ subroutine surfaceFlx(& ! define the infiltrating area for the non-frozen part of the cell/basin if(qSurfScale < qSurfScaleMax)then fracCap = rootZoneLiq/(maxFracCap*availCapacity) ! fraction of available root zone filled with water - fInfRaw = 1._rk - exp(-qSurfScale*(1._rk - fracCap)) ! infiltrating area -- allowed to violate solution constraints - scalarInfilArea = min(0.5_rk*(fInfRaw + sqrt(fInfRaw**2._rk + scaleFactor)), 1._rk) ! infiltrating area -- constrained + fInfRaw = 1._dp - exp(-qSurfScale*(1._dp - fracCap)) ! infiltrating area -- allowed to violate solution constraints + scalarInfilArea = min(0.5_dp*(fInfRaw + sqrt(fInfRaw**2._dp + scaleFactor)), 1._dp) ! infiltrating area -- constrained else - scalarInfilArea = 1._rk + scalarInfilArea = 1._dp endif ! check to ensure we are not infiltrating into a fully saturated column if(ixIce 0.9999_rk*theta_sat*sum(mLayerDepth(ixIce+1:nRoots))) scalarInfilArea=0._rk + if(sum(mLayerVolFracLiq(ixIce+1:nRoots)*mLayerDepth(ixIce+1:nRoots)) > 0.9999_dp*theta_sat*sum(mLayerDepth(ixIce+1:nRoots))) scalarInfilArea=0._dp !print*, 'ixIce, nRoots, scalarInfilArea = ', ixIce, nRoots, scalarInfilArea !print*, 'sum(mLayerVolFracLiq(ixIce+1:nRoots)*mLayerDepth(ixIce+1:nRoots)) = ', sum(mLayerVolFracLiq(ixIce+1:nRoots)*mLayerDepth(ixIce+1:nRoots)) !print*, 'theta_sat*sum(mLayerDepth(ixIce+1:nRoots)) = ', theta_sat*sum(mLayerDepth(ixIce+1:nRoots)) @@ -1331,25 +1331,25 @@ subroutine surfaceFlx(& ! define the impermeable area due to frozen ground if(rootZoneIce > tiny(rootZoneIce))then ! (avoid divide by zero) - alpha = 1._rk/(soilIceCV**2._rk) ! shape parameter in the Gamma distribution + alpha = 1._dp/(soilIceCV**2._dp) ! shape parameter in the Gamma distribution xLimg = alpha*soilIceScale/rootZoneIce ! upper limit of the integral - !scalarFrozenArea = 1._rk - gammp(alpha,xLimg) ! fraction of frozen area - scalarFrozenArea = 0._rk + !scalarFrozenArea = 1._dp - gammp(alpha,xLimg) ! fraction of frozen area + scalarFrozenArea = 0._dp else - scalarFrozenArea = 0._rk + scalarFrozenArea = 0._dp end if !print*, 'scalarFrozenArea, rootZoneIce = ', scalarFrozenArea, rootZoneIce end if ! (if desire to compute infiltration) ! compute infiltration (m s-1) - scalarSurfaceInfiltration = (1._rk - scalarFrozenArea)*scalarInfilArea*min(scalarRainPlusMelt,xMaxInfilRate) + scalarSurfaceInfiltration = (1._dp - scalarFrozenArea)*scalarInfilArea*min(scalarRainPlusMelt,xMaxInfilRate) ! compute surface runoff (m s-1) scalarSurfaceRunoff = scalarRainPlusMelt - scalarSurfaceInfiltration !print*, 'scalarRainPlusMelt, xMaxInfilRate = ', scalarRainPlusMelt, xMaxInfilRate !print*, 'scalarSurfaceInfiltration, scalarSurfaceRunoff = ', scalarSurfaceInfiltration, scalarSurfaceRunoff - !print*, '(1._rk - scalarFrozenArea), (1._rk - scalarFrozenArea)*scalarInfilArea = ', (1._rk - scalarFrozenArea), (1._rk - scalarFrozenArea)*scalarInfilArea + !print*, '(1._dp - scalarFrozenArea), (1._dp - scalarFrozenArea)*scalarInfilArea = ', (1._dp - scalarFrozenArea), (1._dp - scalarFrozenArea)*scalarInfilArea ! set surface hydraulic conductivity and diffusivity to missing (not used for flux condition) surfaceHydCond = realMissing @@ -1358,8 +1358,8 @@ subroutine surfaceFlx(& ! set numerical derivative to zero ! NOTE 1: Depends on multiple soil layers and does not jive with the current tridiagonal matrix ! NOTE 2: Need to define the derivative at every call, because intent(out) - dq_dHydState = 0._rk - dq_dNrgState = 0._rk + dq_dHydState = 0._dp + dq_dNrgState = 0._dp ! ***** error check case default; err=20; message=trim(message)//'unknown upper boundary condition for soil hydrology'; return @@ -1409,31 +1409,31 @@ subroutine iLayerFlux(& logical(lgt),intent(in) :: deriv_desired ! flag indicating if derivatives are desired integer(i4b),intent(in) :: ixRichards ! index defining the option for Richards' equation (moisture or mixdform) ! input: state variables - real(rk),intent(in) :: nodeMatricHeadTrial(:) ! matric head at the soil nodes (m) - real(rk),intent(in) :: nodeVolFracLiqTrial(:) ! volumetric fraction of liquid water at the soil nodes (-) + real(dp),intent(in) :: nodeMatricHeadTrial(:) ! matric head at the soil nodes (m) + real(dp),intent(in) :: nodeVolFracLiqTrial(:) ! volumetric fraction of liquid water at the soil nodes (-) ! input: model coordinate variables - real(rk),intent(in) :: nodeHeight(:) ! height at the mid-point of the lower layer (m) + real(dp),intent(in) :: nodeHeight(:) ! height at the mid-point of the lower layer (m) ! input: temperature derivatives - real(rk),intent(in) :: dPsiLiq_dTemp(:) ! derivative in liquid water matric potential w.r.t. temperature (m K-1) - real(rk),intent(in) :: dHydCond_dTemp(:) ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) + real(dp),intent(in) :: dPsiLiq_dTemp(:) ! derivative in liquid water matric potential w.r.t. temperature (m K-1) + real(dp),intent(in) :: dHydCond_dTemp(:) ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) ! input: transmittance - real(rk),intent(in) :: nodeHydCondTrial(:) ! hydraulic conductivity at layer mid-points (m s-1) - real(rk),intent(in) :: nodeDiffuseTrial(:) ! diffusivity at layer mid-points (m2 s-1) + real(dp),intent(in) :: nodeHydCondTrial(:) ! hydraulic conductivity at layer mid-points (m s-1) + real(dp),intent(in) :: nodeDiffuseTrial(:) ! diffusivity at layer mid-points (m2 s-1) ! input: transmittance derivatives - real(rk),intent(in) :: dHydCond_dVolLiq(:) ! derivative in hydraulic conductivity w.r.t volumetric liquid water content (m s-1) - real(rk),intent(in) :: dDiffuse_dVolLiq(:) ! derivative in hydraulic diffusivity w.r.t volumetric liquid water content (m2 s-1) - real(rk),intent(in) :: dHydCond_dMatric(:) ! derivative in hydraulic conductivity w.r.t matric head (m s-1) + real(dp),intent(in) :: dHydCond_dVolLiq(:) ! derivative in hydraulic conductivity w.r.t volumetric liquid water content (m s-1) + real(dp),intent(in) :: dDiffuse_dVolLiq(:) ! derivative in hydraulic diffusivity w.r.t volumetric liquid water content (m2 s-1) + real(dp),intent(in) :: dHydCond_dMatric(:) ! derivative in hydraulic conductivity w.r.t matric head (m s-1) ! output: tranmsmittance at the layer interface (scalars) - real(rk),intent(out) :: iLayerHydCond ! hydraulic conductivity at the interface between layers (m s-1) - real(rk),intent(out) :: iLayerDiffuse ! hydraulic diffusivity at the interface between layers (m2 s-1) + real(dp),intent(out) :: iLayerHydCond ! hydraulic conductivity at the interface between layers (m s-1) + real(dp),intent(out) :: iLayerDiffuse ! hydraulic diffusivity at the interface between layers (m2 s-1) ! output: vertical flux at the layer interface (scalars) - real(rk),intent(out) :: iLayerLiqFluxSoil ! vertical flux of liquid water at the layer interface (m s-1) + real(dp),intent(out) :: iLayerLiqFluxSoil ! vertical flux of liquid water at the layer interface (m s-1) ! output: derivatives in fluxes w.r.t. state variables -- matric head or volumetric lquid water -- in the layer above and layer below (m s-1 or s-1) - real(rk),intent(out) :: dq_dHydStateAbove ! derivatives in the flux w.r.t. matric head or volumetric lquid water in the layer above (m s-1 or s-1) - real(rk),intent(out) :: dq_dHydStateBelow ! derivatives in the flux w.r.t. matric head or volumetric lquid water in the layer below (m s-1 or s-1) + real(dp),intent(out) :: dq_dHydStateAbove ! derivatives in the flux w.r.t. matric head or volumetric lquid water in the layer above (m s-1 or s-1) + real(dp),intent(out) :: dq_dHydStateBelow ! derivatives in the flux w.r.t. matric head or volumetric lquid water in the layer below (m s-1 or s-1) ! output: derivatives in fluxes w.r.t. energy state variables -- now just temperature -- in the layer above and layer below (m s-1 K-1) - real(rk),intent(out) :: dq_dNrgStateAbove ! derivatives in the flux w.r.t. temperature in the layer above (m s-1 K-1) - real(rk),intent(out) :: dq_dNrgStateBelow ! derivatives in the flux w.r.t. temperature in the layer below (m s-1 K-1) + real(dp),intent(out) :: dq_dNrgStateAbove ! derivatives in the flux w.r.t. temperature in the layer above (m s-1 K-1) + real(dp),intent(out) :: dq_dNrgStateBelow ! derivatives in the flux w.r.t. temperature in the layer below (m s-1 K-1) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message @@ -1443,17 +1443,17 @@ subroutine iLayerFlux(& integer(i4b),parameter :: ixLower=2 ! index of lower node in the 2-element vectors logical(lgt),parameter :: useGeometric=.false. ! switch between the arithmetic and geometric mean ! local variables (Darcy flux) - real(rk) :: dPsi ! spatial difference in matric head (m) - real(rk) :: dLiq ! spatial difference in volumetric liquid water (-) - real(rk) :: dz ! spatial difference in layer mid-points (m) - real(rk) :: cflux ! capillary flux (m s-1) + real(dp) :: dPsi ! spatial difference in matric head (m) + real(dp) :: dLiq ! spatial difference in volumetric liquid water (-) + real(dp) :: dz ! spatial difference in layer mid-points (m) + real(dp) :: cflux ! capillary flux (m s-1) ! local variables (derivative in Darcy's flux) - real(rk) :: dHydCondIface_dVolLiqAbove ! derivative in hydraulic conductivity at layer interface w.r.t. volumetric liquid water content in layer above - real(rk) :: dHydCondIface_dVolLiqBelow ! derivative in hydraulic conductivity at layer interface w.r.t. volumetric liquid water content in layer below - real(rk) :: dDiffuseIface_dVolLiqAbove ! derivative in hydraulic diffusivity at layer interface w.r.t. volumetric liquid water content in layer above - real(rk) :: dDiffuseIface_dVolLiqBelow ! derivative in hydraulic diffusivity at layer interface w.r.t. volumetric liquid water content in layer below - real(rk) :: dHydCondIface_dMatricAbove ! derivative in hydraulic conductivity at layer interface w.r.t. matric head in layer above - real(rk) :: dHydCondIface_dMatricBelow ! derivative in hydraulic conductivity at layer interface w.r.t. matric head in layer below + real(dp) :: dHydCondIface_dVolLiqAbove ! derivative in hydraulic conductivity at layer interface w.r.t. volumetric liquid water content in layer above + real(dp) :: dHydCondIface_dVolLiqBelow ! derivative in hydraulic conductivity at layer interface w.r.t. volumetric liquid water content in layer below + real(dp) :: dDiffuseIface_dVolLiqAbove ! derivative in hydraulic diffusivity at layer interface w.r.t. volumetric liquid water content in layer above + real(dp) :: dDiffuseIface_dVolLiqBelow ! derivative in hydraulic diffusivity at layer interface w.r.t. volumetric liquid water content in layer below + real(dp) :: dHydCondIface_dMatricAbove ! derivative in hydraulic conductivity at layer interface w.r.t. matric head in layer above + real(dp) :: dHydCondIface_dMatricBelow ! derivative in hydraulic conductivity at layer interface w.r.t. matric head in layer below ! ------------------------------------------------------------------------------------------------------------------------------------------------------------------------ ! initialize error control err=0; message="iLayerFlux/" @@ -1462,9 +1462,9 @@ subroutine iLayerFlux(& ! compute the vertical flux of liquid water ! compute the hydraulic conductivity at the interface if(useGeometric)then - iLayerHydCond = (nodeHydCondTrial(ixLower) * nodeHydCondTrial(ixUpper))**0.5_rk + iLayerHydCond = (nodeHydCondTrial(ixLower) * nodeHydCondTrial(ixUpper))**0.5_dp else - iLayerHydCond = (nodeHydCondTrial(ixLower) + nodeHydCondTrial(ixUpper))*0.5_rk + iLayerHydCond = (nodeHydCondTrial(ixLower) + nodeHydCondTrial(ixUpper))*0.5_dp end if !write(*,'(a,1x,5(e20.10,1x))') 'in iLayerFlux: iLayerHydCond, iLayerHydCondMP = ', iLayerHydCond, iLayerHydCondMP ! compute the height difference between nodes @@ -1472,7 +1472,7 @@ subroutine iLayerFlux(& ! compute the capillary flux select case(ixRichards) ! (form of Richards' equation) case(moisture) - iLayerDiffuse = (nodeDiffuseTrial(ixLower) * nodeDiffuseTrial(ixUpper))**0.5_rk + iLayerDiffuse = (nodeDiffuseTrial(ixLower) * nodeDiffuseTrial(ixUpper))**0.5_dp dLiq = nodeVolFracLiqTrial(ixLower) - nodeVolFracLiqTrial(ixUpper) cflux = -iLayerDiffuse * dLiq/dz case(mixdform) @@ -1496,29 +1496,29 @@ subroutine iLayerFlux(& err=20; return end if ! derivatives in hydraulic conductivity at the layer interface (m s-1) - dHydCondIface_dVolLiqAbove = dHydCond_dVolLiq(ixUpper)*nodeHydCondTrial(ixLower) * 0.5_rk/max(iLayerHydCond,verySmall) - dHydCondIface_dVolLiqBelow = dHydCond_dVolLiq(ixLower)*nodeHydCondTrial(ixUpper) * 0.5_rk/max(iLayerHydCond,verySmall) + dHydCondIface_dVolLiqAbove = dHydCond_dVolLiq(ixUpper)*nodeHydCondTrial(ixLower) * 0.5_dp/max(iLayerHydCond,verySmall) + dHydCondIface_dVolLiqBelow = dHydCond_dVolLiq(ixLower)*nodeHydCondTrial(ixUpper) * 0.5_dp/max(iLayerHydCond,verySmall) ! derivatives in hydraulic diffusivity at the layer interface (m2 s-1) - dDiffuseIface_dVolLiqAbove = dDiffuse_dVolLiq(ixUpper)*nodeDiffuseTrial(ixLower) * 0.5_rk/max(iLayerDiffuse,verySmall) - dDiffuseIface_dVolLiqBelow = dDiffuse_dVolLiq(ixLower)*nodeDiffuseTrial(ixUpper) * 0.5_rk/max(iLayerDiffuse,verySmall) + dDiffuseIface_dVolLiqAbove = dDiffuse_dVolLiq(ixUpper)*nodeDiffuseTrial(ixLower) * 0.5_dp/max(iLayerDiffuse,verySmall) + dDiffuseIface_dVolLiqBelow = dDiffuse_dVolLiq(ixLower)*nodeDiffuseTrial(ixUpper) * 0.5_dp/max(iLayerDiffuse,verySmall) ! derivatives in the flux w.r.t. volumetric liquid water content dq_dHydStateAbove = -dDiffuseIface_dVolLiqAbove*dLiq/dz + iLayerDiffuse/dz + dHydCondIface_dVolLiqAbove dq_dHydStateBelow = -dDiffuseIface_dVolLiqBelow*dLiq/dz - iLayerDiffuse/dz + dHydCondIface_dVolLiqBelow case(mixdform) ! derivatives in hydraulic conductivity if(useGeometric)then - dHydCondIface_dMatricAbove = dHydCond_dMatric(ixUpper)*nodeHydCondTrial(ixLower) * 0.5_rk/max(iLayerHydCond,verySmall) - dHydCondIface_dMatricBelow = dHydCond_dMatric(ixLower)*nodeHydCondTrial(ixUpper) * 0.5_rk/max(iLayerHydCond,verySmall) + dHydCondIface_dMatricAbove = dHydCond_dMatric(ixUpper)*nodeHydCondTrial(ixLower) * 0.5_dp/max(iLayerHydCond,verySmall) + dHydCondIface_dMatricBelow = dHydCond_dMatric(ixLower)*nodeHydCondTrial(ixUpper) * 0.5_dp/max(iLayerHydCond,verySmall) else - dHydCondIface_dMatricAbove = dHydCond_dMatric(ixUpper)/2._rk - dHydCondIface_dMatricBelow = dHydCond_dMatric(ixLower)/2._rk + dHydCondIface_dMatricAbove = dHydCond_dMatric(ixUpper)/2._dp + dHydCondIface_dMatricBelow = dHydCond_dMatric(ixLower)/2._dp end if ! derivatives in the flux w.r.t. matric head dq_dHydStateAbove = -dHydCondIface_dMatricAbove*dPsi/dz + iLayerHydCond/dz + dHydCondIface_dMatricAbove dq_dHydStateBelow = -dHydCondIface_dMatricBelow*dPsi/dz - iLayerHydCond/dz + dHydCondIface_dMatricBelow ! derivative in the flux w.r.t. temperature - dq_dNrgStateAbove = -(dHydCond_dTemp(ixUpper)/2._rk)*dPsi/dz + iLayerHydCond*dPsiLiq_dTemp(ixUpper)/dz + dHydCond_dTemp(ixUpper)/2._rk - dq_dNrgStateBelow = -(dHydCond_dTemp(ixLower)/2._rk)*dPsi/dz - iLayerHydCond*dPsiLiq_dTemp(ixLower)/dz + dHydCond_dTemp(ixLower)/2._rk + dq_dNrgStateAbove = -(dHydCond_dTemp(ixUpper)/2._dp)*dPsi/dz + iLayerHydCond*dPsiLiq_dTemp(ixUpper)/dz + dHydCond_dTemp(ixUpper)/2._dp + dq_dNrgStateBelow = -(dHydCond_dTemp(ixLower)/2._dp)*dPsi/dz - iLayerHydCond*dPsiLiq_dTemp(ixLower)/dz + dHydCond_dTemp(ixLower)/2._dp case default; err=10; message=trim(message)//"unknown form of Richards' equation"; return end select else @@ -1588,50 +1588,50 @@ subroutine qDrainFlux(& integer(i4b),intent(in) :: ixRichards ! index defining the option for Richards' equation (moisture or mixdform) integer(i4b),intent(in) :: bc_lower ! index defining the type of boundary conditions ! input: state and diagnostic variables - real(rk),intent(in) :: nodeMatricHead ! matric head in the lowest unsaturated node (m) - real(rk),intent(in) :: nodeVolFracLiq ! volumetric liquid water content in the lowest unsaturated node (-) + real(dp),intent(in) :: nodeMatricHead ! matric head in the lowest unsaturated node (m) + real(dp),intent(in) :: nodeVolFracLiq ! volumetric liquid water content in the lowest unsaturated node (-) ! input: model coordinate variables - real(rk),intent(in) :: nodeDepth ! depth of the lowest unsaturated soil layer (m) - real(rk),intent(in) :: nodeHeight ! height of the lowest unsaturated soil node (m) + real(dp),intent(in) :: nodeDepth ! depth of the lowest unsaturated soil layer (m) + real(dp),intent(in) :: nodeHeight ! height of the lowest unsaturated soil node (m) ! input: diriclet boundary conditions - real(rk),intent(in) :: lowerBoundHead ! lower boundary condition for matric head (m) - real(rk),intent(in) :: lowerBoundTheta ! lower boundary condition for volumetric liquid water content (-) + real(dp),intent(in) :: lowerBoundHead ! lower boundary condition for matric head (m) + real(dp),intent(in) :: lowerBoundTheta ! lower boundary condition for volumetric liquid water content (-) ! input: derivative in soil water characteristix - real(rk),intent(in) :: node__dPsi_dTheta ! derivative of the soil moisture characteristic w.r.t. theta (m) + real(dp),intent(in) :: node__dPsi_dTheta ! derivative of the soil moisture characteristic w.r.t. theta (m) ! input: transmittance - real(rk),intent(in) :: surfaceSatHydCond ! saturated hydraulic conductivity at the surface (m s-1) - real(rk),intent(in) :: bottomSatHydCond ! saturated hydraulic conductivity at the bottom of the unsaturated zone (m s-1) - real(rk),intent(in) :: nodeHydCond ! hydraulic conductivity at the node itself (m s-1) - real(rk),intent(in) :: iceImpedeFac ! ice impedence factor in the upper-most soil layer (-) + real(dp),intent(in) :: surfaceSatHydCond ! saturated hydraulic conductivity at the surface (m s-1) + real(dp),intent(in) :: bottomSatHydCond ! saturated hydraulic conductivity at the bottom of the unsaturated zone (m s-1) + real(dp),intent(in) :: nodeHydCond ! hydraulic conductivity at the node itself (m s-1) + real(dp),intent(in) :: iceImpedeFac ! ice impedence factor in the upper-most soil layer (-) ! input: transmittance derivatives - real(rk),intent(in) :: dHydCond_dVolLiq ! derivative in hydraulic conductivity w.r.t. volumetric liquid water content (m s-1) - real(rk),intent(in) :: dHydCond_dMatric ! derivative in hydraulic conductivity w.r.t. matric head (s-1) - real(rk),intent(in) :: dHydCond_dTemp ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) + real(dp),intent(in) :: dHydCond_dVolLiq ! derivative in hydraulic conductivity w.r.t. volumetric liquid water content (m s-1) + real(dp),intent(in) :: dHydCond_dMatric ! derivative in hydraulic conductivity w.r.t. matric head (s-1) + real(dp),intent(in) :: dHydCond_dTemp ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) ! input: soil parameters - real(rk),intent(in) :: vGn_alpha ! van Genutchen "alpha" parameter (m-1) - real(rk),intent(in) :: vGn_n ! van Genutchen "n" parameter (-) - real(rk),intent(in) :: vGn_m ! van Genutchen "m" parameter (-) - real(rk),intent(in) :: theta_sat ! soil porosity (-) - real(rk),intent(in) :: theta_res ! soil residual volumetric water content (-) - real(rk),intent(in) :: kAnisotropic ! anisotropy factor for lateral hydraulic conductivity (-) - real(rk),intent(in) :: zScale_TOPMODEL ! scale factor for TOPMODEL-ish baseflow parameterization (m) + real(dp),intent(in) :: vGn_alpha ! van Genutchen "alpha" parameter (m-1) + real(dp),intent(in) :: vGn_n ! van Genutchen "n" parameter (-) + real(dp),intent(in) :: vGn_m ! van Genutchen "m" parameter (-) + real(dp),intent(in) :: theta_sat ! soil porosity (-) + real(dp),intent(in) :: theta_res ! soil residual volumetric water content (-) + real(dp),intent(in) :: kAnisotropic ! anisotropy factor for lateral hydraulic conductivity (-) + real(dp),intent(in) :: zScale_TOPMODEL ! scale factor for TOPMODEL-ish baseflow parameterization (m) ! ----------------------------------------------------------------------------------------------------------------------------- ! output: hydraulic conductivity at the bottom of the unsaturated zone - real(rk),intent(out) :: bottomHydCond ! hydraulic conductivity at the bottom of the unsaturated zone (m s-1) - real(rk),intent(out) :: bottomDiffuse ! hydraulic diffusivity at the bottom of the unsatuarted zone (m2 s-1) + real(dp),intent(out) :: bottomHydCond ! hydraulic conductivity at the bottom of the unsaturated zone (m s-1) + real(dp),intent(out) :: bottomDiffuse ! hydraulic diffusivity at the bottom of the unsatuarted zone (m2 s-1) ! output: drainage flux from the bottom of the soil profile - real(rk),intent(out) :: scalarDrainage ! drainage flux from the bottom of the soil profile (m s-1) + real(dp),intent(out) :: scalarDrainage ! drainage flux from the bottom of the soil profile (m s-1) ! output: derivatives in drainage flux - real(rk),intent(out) :: dq_dHydStateUnsat ! change in drainage flux w.r.t. change in state variable in lowest unsaturated node (m s-1 or s-1) - real(rk),intent(out) :: dq_dNrgStateUnsat ! change in drainage flux w.r.t. change in energy state variable in lowest unsaturated node (m s-1 K-1) + real(dp),intent(out) :: dq_dHydStateUnsat ! change in drainage flux w.r.t. change in state variable in lowest unsaturated node (m s-1 or s-1) + real(dp),intent(out) :: dq_dNrgStateUnsat ! change in drainage flux w.r.t. change in energy state variable in lowest unsaturated node (m s-1 K-1) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! ----------------------------------------------------------------------------------------------------------------------------- ! local variables - real(rk) :: zWater ! effective water table depth (m) - real(rk) :: nodePsi ! matric head in the lowest unsaturated node (m) - real(rk) :: cflux ! capillary flux (m s-1) + real(dp) :: zWater ! effective water table depth (m) + real(dp) :: nodePsi ! matric head in the lowest unsaturated node (m) + real(dp) :: cflux ! capillary flux (m s-1) ! ----------------------------------------------------------------------------------------------------------------------------- ! initialize error control err=0; message="qDrainFlux/" @@ -1651,13 +1651,13 @@ subroutine qDrainFlux(& bottomHydCond = hydCond_liq(lowerBoundTheta,bottomSatHydCond,theta_res,theta_sat,vGn_m) * iceImpedeFac bottomDiffuse = dPsi_dTheta(lowerBoundTheta,vGn_alpha,theta_res,theta_sat,vGn_n,vGn_m) * bottomHydCond ! compute the capillary flux - cflux = -bottomDiffuse*(lowerBoundTheta - nodeVolFracLiq) / (nodeDepth*0.5_rk) + cflux = -bottomDiffuse*(lowerBoundTheta - nodeVolFracLiq) / (nodeDepth*0.5_dp) case(mixdform) ! compute the hydraulic conductivity and diffusivity at the boundary bottomHydCond = hydCond_psi(lowerBoundHead,bottomSatHydCond,vGn_alpha,vGn_n,vGn_m) * iceImpedeFac bottomDiffuse = realMissing ! compute the capillary flux - cflux = -bottomHydCond*(lowerBoundHead - nodeMatricHead) / (nodeDepth*0.5_rk) + cflux = -bottomHydCond*(lowerBoundHead - nodeMatricHead) / (nodeDepth*0.5_dp) case default; err=10; message=trim(message)//"unknown form of Richards' equation"; return end select ! (form of Richards' eqn) scalarDrainage = cflux + bottomHydCond @@ -1666,12 +1666,12 @@ subroutine qDrainFlux(& if(deriv_desired)then ! hydrology derivatives select case(ixRichards) ! (form of Richards' equation) - case(moisture); dq_dHydStateUnsat = bottomDiffuse/(nodeDepth/2._rk) - case(mixdform); dq_dHydStateUnsat = bottomHydCond/(nodeDepth/2._rk) + case(moisture); dq_dHydStateUnsat = bottomDiffuse/(nodeDepth/2._dp) + case(mixdform); dq_dHydStateUnsat = bottomHydCond/(nodeDepth/2._dp) case default; err=10; message=trim(message)//"unknown form of Richards' equation"; return end select ! energy derivatives - dq_dNrgStateUnsat = -(dHydCond_dTemp/2._rk)*(lowerBoundHead - nodeMatricHead)/(nodeDepth*0.5_rk) + dHydCond_dTemp/2._rk + dq_dNrgStateUnsat = -(dHydCond_dTemp/2._dp)*(lowerBoundHead - nodeMatricHead)/(nodeDepth*0.5_dp) + dHydCond_dTemp/2._dp else ! (do not desire derivatives) dq_dHydStateUnsat = realMissing dq_dNrgStateUnsat = realMissing @@ -1733,10 +1733,10 @@ subroutine qDrainFlux(& ! * zero flux ! --------------------------------------------------------------------------------------------- case(zeroFlux) - scalarDrainage = 0._rk + scalarDrainage = 0._dp if(deriv_desired)then - dq_dHydStateUnsat = 0._rk - dq_dNrgStateUnsat = 0._rk + dq_dHydStateUnsat = 0._dp + dq_dNrgStateUnsat = 0._dp else dq_dHydStateUnsat = realMissing dq_dNrgStateUnsat = realMissing diff --git a/build/source/engine/soil_utils.f90 b/build/source/engine/soil_utils.f90 index 99daf1ce8..747618ed4 100755 --- a/build/source/engine/soil_utils.f90 +++ b/build/source/engine/soil_utils.f90 @@ -52,9 +52,9 @@ module soil_utils_module public::gammp ! constant parameters -real(rk),parameter :: valueMissing=-9999._rk ! missing value parameter -real(rk),parameter :: verySmall=epsilon(1.0_rk) ! a very small number (used to avoid divide by zero) -real(rk),parameter :: dx=-1.e-12_rk ! finite difference increment +real(dp),parameter :: valueMissing=-9999._dp ! missing value parameter +real(dp),parameter :: verySmall=epsilon(1.0_dp) ! a very small number (used to avoid divide by zero) +real(dp),parameter :: dx=-1.e-12_dp ! finite difference increment contains @@ -66,14 +66,14 @@ subroutine iceImpede(volFracIce,f_impede, & ! input ! computes the ice impedence factor (separate function, as used multiple times) implicit none ! input variables - real(rk),intent(in) :: volFracIce ! volumetric fraction of ice (-) - real(rk),intent(in) :: f_impede ! ice impedence parameter (-) + real(dp),intent(in) :: volFracIce ! volumetric fraction of ice (-) + real(dp),intent(in) :: f_impede ! ice impedence parameter (-) ! output variables - real(rk) :: iceImpedeFactor ! ice impedence factor (-) - real(rk) :: dIceImpede_dLiq ! derivative in ice impedence factor w.r.t. volumetric liquid water content (-) + real(dp) :: iceImpedeFactor ! ice impedence factor (-) + real(dp) :: dIceImpede_dLiq ! derivative in ice impedence factor w.r.t. volumetric liquid water content (-) ! compute ice impedance factor as a function of volumetric ice content - iceImpedeFactor = 10._rk**(-f_impede*volFracIce) - dIceImpede_dLiq = 0._rk + iceImpedeFactor = 10._dp**(-f_impede*volFracIce) + dIceImpede_dLiq = 0._dp end subroutine iceImpede @@ -85,13 +85,13 @@ subroutine dIceImpede_dTemp(volFracIce,dTheta_dT,f_impede,dIceImpede_dT) ! computes the derivative in the ice impedance factor w.r.t. temperature implicit none ! input variables - real(rk),intent(in) :: volFracIce ! volumetric fraction of ice (-) - real(rk),intent(in) :: dTheta_dT ! derivative in volumetric liquid water content w.r.t temperature (K-1) - real(rk),intent(in) :: f_impede ! ice impedence parameter (-) + real(dp),intent(in) :: volFracIce ! volumetric fraction of ice (-) + real(dp),intent(in) :: dTheta_dT ! derivative in volumetric liquid water content w.r.t temperature (K-1) + real(dp),intent(in) :: f_impede ! ice impedence parameter (-) ! output variables - real(rk) :: dIceImpede_dT ! derivative in the ice impedance factor w.r.t. temperature (K-1) + real(dp) :: dIceImpede_dT ! derivative in the ice impedance factor w.r.t. temperature (K-1) ! -- - dIceImpede_dT = log(10._rk)*f_impede*(10._rk**(-f_impede*volFracIce))*dTheta_dT + dIceImpede_dT = log(10._dp)*f_impede*(10._dp**(-f_impede*volFracIce))*dTheta_dT end subroutine dIceImpede_dTemp @@ -114,30 +114,30 @@ subroutine liquidHead(& ! computes the liquid water matric potential (and the derivatives w.r.t. total matric potential and temperature) implicit none ! input - real(rk),intent(in) :: matricHeadTotal ! total water matric potential (m) - real(rk),intent(in) :: volFracLiq ! volumetric fraction of liquid water (-) - real(rk),intent(in) :: volFracIce ! volumetric fraction of ice (-) - real(rk),intent(in) :: vGn_alpha,vGn_n,theta_sat,theta_res,vGn_m ! soil parameters - real(rk),intent(in) ,optional :: dVolTot_dPsi0 ! derivative in the soil water characteristic (m-1) - real(rk),intent(in) ,optional :: dTheta_dT ! derivative in volumetric total water w.r.t. temperature (K-1) + real(dp),intent(in) :: matricHeadTotal ! total water matric potential (m) + real(dp),intent(in) :: volFracLiq ! volumetric fraction of liquid water (-) + real(dp),intent(in) :: volFracIce ! volumetric fraction of ice (-) + real(dp),intent(in) :: vGn_alpha,vGn_n,theta_sat,theta_res,vGn_m ! soil parameters + real(dp),intent(in) ,optional :: dVolTot_dPsi0 ! derivative in the soil water characteristic (m-1) + real(dp),intent(in) ,optional :: dTheta_dT ! derivative in volumetric total water w.r.t. temperature (K-1) ! output - real(rk),intent(out) :: matricHeadLiq ! liquid water matric potential (m) - real(rk),intent(out) ,optional :: dPsiLiq_dPsi0 ! derivative in the liquid water matric potential w.r.t. the total water matric potential (-) - real(rk),intent(out) ,optional :: dPsiLiq_dTemp ! derivative in the liquid water matric potential w.r.t. temperature (m K-1) + real(dp),intent(out) :: matricHeadLiq ! liquid water matric potential (m) + real(dp),intent(out) ,optional :: dPsiLiq_dPsi0 ! derivative in the liquid water matric potential w.r.t. the total water matric potential (-) + real(dp),intent(out) ,optional :: dPsiLiq_dTemp ! derivative in the liquid water matric potential w.r.t. temperature (m K-1) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! local - real(rk) :: xNum,xDen ! temporary variables (numeratir, denominator) - real(rk) :: effSat ! effective saturation (-) - real(rk) :: dPsiLiq_dEffSat ! derivative in liquid water matric potential w.r.t. effective saturation (m) - real(rk) :: dEffSat_dTemp ! derivative in effective saturation w.r.t. temperature (K-1) + real(dp) :: xNum,xDen ! temporary variables (numeratir, denominator) + real(dp) :: effSat ! effective saturation (-) + real(dp) :: dPsiLiq_dEffSat ! derivative in liquid water matric potential w.r.t. effective saturation (m) + real(dp) :: dEffSat_dTemp ! derivative in effective saturation w.r.t. temperature (K-1) ! ------------------------------------------------------------------------------------------------------------------------------ ! initialize error control err=0; message='liquidHead/' ! ** partially frozen soil - if(volFracIce > verySmall .and. matricHeadTotal < 0._rk)then ! check that ice exists and that the soil is unsaturated + if(volFracIce > verySmall .and. matricHeadTotal < 0._dp)then ! check that ice exists and that the soil is unsaturated ! ----- ! - compute liquid water matric potential... @@ -151,11 +151,11 @@ subroutine liquidHead(& effSat = xNum/xDen ! effective saturation ! - matric head associated with liquid water - matricHeadLiq = matricHead(effSat,vGn_alpha,0._rk,1._rk,vGn_n,vGn_m) ! argument is effective saturation, so theta_res=0 and theta_sat=1 + matricHeadLiq = matricHead(effSat,vGn_alpha,0._dp,1._dp,vGn_n,vGn_m) ! argument is effective saturation, so theta_res=0 and theta_sat=1 ! compute derivative in liquid water matric potential w.r.t. effective saturation (m) if(present(dPsiLiq_dPsi0).or.present(dPsiLiq_dTemp))then - dPsiLiq_dEffSat = dPsi_dTheta(effSat,vGn_alpha,0._rk,1._rk,vGn_n,vGn_m) + dPsiLiq_dEffSat = dPsi_dTheta(effSat,vGn_alpha,0._dp,1._dp,vGn_n,vGn_m) endif ! ----- @@ -172,7 +172,7 @@ subroutine liquidHead(& endif ! (compute derivative in the liquid water matric potential w.r.t. the total water matric potential) - dPsiLiq_dPsi0 = dVolTot_dPsi0*dPsiLiq_dEffSat*xNum/(xDen**2._rk) + dPsiLiq_dPsi0 = dVolTot_dPsi0*dPsiLiq_dEffSat*xNum/(xDen**2._dp) endif ! if dPsiLiq_dTemp is desired @@ -190,7 +190,7 @@ subroutine liquidHead(& endif ! (compute the derivative in the liquid water matric potential w.r.t. temperature) - dEffSat_dTemp = -dTheta_dT*xNum/(xDen**2._rk) + dTheta_dT/xDen + dEffSat_dTemp = -dTheta_dT*xNum/(xDen**2._dp) + dTheta_dT/xDen dPsiLiq_dTemp = dPsiLiq_dEffSat*dEffSat_dTemp endif ! if dPsiLiq_dTemp is desired @@ -198,8 +198,8 @@ subroutine liquidHead(& ! ** unfrozen soil else ! (no ice) matricHeadLiq = matricHeadTotal - if(present(dPsiLiq_dTemp)) dPsiLiq_dPsi0 = 1._rk ! derivative=1 because values are identical - if(present(dPsiLiq_dTemp)) dPsiLiq_dTemp = 0._rk ! derivative=0 because no impact of temperature for unfrozen conditions + if(present(dPsiLiq_dTemp)) dPsiLiq_dPsi0 = 1._dp ! derivative=1 because values are identical + if(present(dPsiLiq_dTemp)) dPsiLiq_dTemp = 0._dp ! derivative=0 because no impact of temperature for unfrozen conditions end if ! (if ice exists) end subroutine liquidHead @@ -212,20 +212,20 @@ function hydCondMP_liq(volFracLiq,theta_sat,theta_mp,mpExp,satHydCond_ma,satHydC ! theta_sat, theta_mp, mpExp, satHydCond_ma, and satHydCond_mi implicit none ! dummies - real(rk),intent(in) :: volFracLiq ! volumetric liquid water content (-) - real(rk),intent(in) :: theta_sat ! soil porosity (-) - real(rk),intent(in) :: theta_mp ! minimum volumetric liquid water content for macropore flow (-) - real(rk),intent(in) :: mpExp ! empirical exponent in macropore flow equation (-) - real(rk),intent(in) :: satHydCond_ma ! saturated hydraulic conductivity for macropores (m s-1) - real(rk),intent(in) :: satHydCond_mi ! saturated hydraulic conductivity for micropores (m s-1) - real(rk) :: hydCondMP_liq ! hydraulic conductivity (m s-1) + real(dp),intent(in) :: volFracLiq ! volumetric liquid water content (-) + real(dp),intent(in) :: theta_sat ! soil porosity (-) + real(dp),intent(in) :: theta_mp ! minimum volumetric liquid water content for macropore flow (-) + real(dp),intent(in) :: mpExp ! empirical exponent in macropore flow equation (-) + real(dp),intent(in) :: satHydCond_ma ! saturated hydraulic conductivity for macropores (m s-1) + real(dp),intent(in) :: satHydCond_mi ! saturated hydraulic conductivity for micropores (m s-1) + real(dp) :: hydCondMP_liq ! hydraulic conductivity (m s-1) ! locals - real(rk) :: theta_e ! effective soil moisture + real(dp) :: theta_e ! effective soil moisture if(volFracLiq > theta_mp)then theta_e = (volFracLiq - theta_mp) / (theta_sat - theta_mp) hydCondMP_liq = (satHydCond_ma - satHydCond_mi) * (theta_e**mpExp) else - hydCondMP_liq = 0._rk + hydCondMP_liq = 0._dp end if !write(*,'(a,4(f9.3,1x),2(e20.10))') 'in soil_utils: theta_mp, theta_sat, volFracLiq, hydCondMP_liq, satHydCond_ma, satHydCond_mi = ', & ! theta_mp, theta_sat, volFracLiq, hydCondMP_liq, satHydCond_ma, satHydCond_mi @@ -239,16 +239,16 @@ function hydCond_psi(psi,k_sat,alpha,n,m) ! computes hydraulic conductivity given psi and soil hydraulic parameters k_sat, alpha, n, and m implicit none ! dummies - real(rk),intent(in) :: psi ! soil water suction (m) - real(rk),intent(in) :: k_sat ! saturated hydraulic conductivity (m s-1) - real(rk),intent(in) :: alpha ! scaling parameter (m-1) - real(rk),intent(in) :: n ! vGn "n" parameter (-) - real(rk),intent(in) :: m ! vGn "m" parameter (-) - real(rk) :: hydCond_psi ! hydraulic conductivity (m s-1) - if(psi<0._rk)then + real(dp),intent(in) :: psi ! soil water suction (m) + real(dp),intent(in) :: k_sat ! saturated hydraulic conductivity (m s-1) + real(dp),intent(in) :: alpha ! scaling parameter (m-1) + real(dp),intent(in) :: n ! vGn "n" parameter (-) + real(dp),intent(in) :: m ! vGn "m" parameter (-) + real(dp) :: hydCond_psi ! hydraulic conductivity (m s-1) + if(psi<0._dp)then hydCond_psi = k_sat * & - ( ( (1._rk - (psi*alpha)**(n-1._rk) * (1._rk + (psi*alpha)**n)**(-m))**2._rk ) & - / ( (1._rk + (psi*alpha)**n)**(m/2._rk) ) ) + ( ( (1._dp - (psi*alpha)**(n-1._dp) * (1._dp + (psi*alpha)**n)**(-m))**2._dp ) & + / ( (1._dp + (psi*alpha)**n)**(m/2._dp) ) ) else hydCond_psi = k_sat end if @@ -262,17 +262,17 @@ function hydCond_liq(volFracLiq,k_sat,theta_res,theta_sat,m) ! computes hydraulic conductivity given volFracLiq and soil hydraulic parameters k_sat, theta_sat, theta_res, and m implicit none ! dummies - real(rk),intent(in) :: volFracLiq ! volumetric liquid water content (-) - real(rk),intent(in) :: k_sat ! saturated hydraulic conductivity (m s-1) - real(rk),intent(in) :: theta_res ! residual volumetric liquid water content (-) - real(rk),intent(in) :: theta_sat ! soil porosity (-) - real(rk),intent(in) :: m ! vGn "m" parameter (-) - real(rk) :: hydCond_liq ! hydraulic conductivity (m s-1) + real(dp),intent(in) :: volFracLiq ! volumetric liquid water content (-) + real(dp),intent(in) :: k_sat ! saturated hydraulic conductivity (m s-1) + real(dp),intent(in) :: theta_res ! residual volumetric liquid water content (-) + real(dp),intent(in) :: theta_sat ! soil porosity (-) + real(dp),intent(in) :: m ! vGn "m" parameter (-) + real(dp) :: hydCond_liq ! hydraulic conductivity (m s-1) ! locals - real(rk) :: theta_e ! effective soil moisture + real(dp) :: theta_e ! effective soil moisture if(volFracLiq < theta_sat)then theta_e = (volFracLiq - theta_res) / (theta_sat - theta_res) - hydCond_liq = k_sat*theta_e**(1._rk/2._rk) * (1._rk - (1._rk - theta_e**(1._rk/m) )**m)**2._rk + hydCond_liq = k_sat*theta_e**(1._dp/2._dp) * (1._dp - (1._dp - theta_e**(1._dp/m) )**m)**2._dp else hydCond_liq = k_sat end if @@ -285,15 +285,15 @@ end function hydCond_liq function volFracLiq(psi,alpha,theta_res,theta_sat,n,m) ! computes the volumetric liquid water content given psi and soil hydraulic parameters theta_res, theta_sat, alpha, n, and m implicit none - real(rk),intent(in) :: psi ! soil water suction (m) - real(rk),intent(in) :: alpha ! scaling parameter (m-1) - real(rk),intent(in) :: theta_res ! residual volumetric water content (-) - real(rk),intent(in) :: theta_sat ! porosity (-) - real(rk),intent(in) :: n ! vGn "n" parameter (-) - real(rk),intent(in) :: m ! vGn "m" parameter (-) - real(rk) :: volFracLiq ! volumetric liquid water content (-) - if(psi<0._rk)then - volFracLiq = theta_res + (theta_sat - theta_res)*(1._rk + (alpha*psi)**n)**(-m) + real(dp),intent(in) :: psi ! soil water suction (m) + real(dp),intent(in) :: alpha ! scaling parameter (m-1) + real(dp),intent(in) :: theta_res ! residual volumetric water content (-) + real(dp),intent(in) :: theta_sat ! porosity (-) + real(dp),intent(in) :: n ! vGn "n" parameter (-) + real(dp),intent(in) :: m ! vGn "m" parameter (-) + real(dp) :: volFracLiq ! volumetric liquid water content (-) + if(psi<0._dp)then + volFracLiq = theta_res + (theta_sat - theta_res)*(1._dp + (alpha*psi)**n)**(-m) else volFracLiq = theta_sat end if @@ -307,23 +307,23 @@ function matricHead(theta,alpha,theta_res,theta_sat,n,m) ! computes the volumetric liquid water content given psi and soil hydraulic parameters theta_res, theta_sat, alpha, n, and m implicit none ! dummy variables - real(rk),intent(in) :: theta ! volumetric liquid water content (-) - real(rk),intent(in) :: alpha ! scaling parameter (m-1) - real(rk),intent(in) :: theta_res ! residual volumetric water content (-) - real(rk),intent(in) :: theta_sat ! porosity (-) - real(rk),intent(in) :: n ! vGn "n" parameter (-) - real(rk),intent(in) :: m ! vGn "m" parameter (-) - real(rk) :: matricHead ! matric head (m) + real(dp),intent(in) :: theta ! volumetric liquid water content (-) + real(dp),intent(in) :: alpha ! scaling parameter (m-1) + real(dp),intent(in) :: theta_res ! residual volumetric water content (-) + real(dp),intent(in) :: theta_sat ! porosity (-) + real(dp),intent(in) :: n ! vGn "n" parameter (-) + real(dp),intent(in) :: m ! vGn "m" parameter (-) + real(dp) :: matricHead ! matric head (m) ! local variables - real(rk) :: effSat ! effective saturation (-) - real(rk),parameter :: verySmall=epsilon(1._rk) ! a very small number (avoid effective saturation of zero) + real(dp) :: effSat ! effective saturation (-) + real(dp),parameter :: verySmall=epsilon(1._dp) ! a very small number (avoid effective saturation of zero) ! compute effective saturation effSat = max(verySmall, (theta - theta_res) / (theta_sat - theta_res)) ! compute matric head - if (effSat < 1._rk .and. effSat > 0._rk)then - matricHead = (1._rk/alpha)*( effSat**(-1._rk/m) - 1._rk)**(1._rk/n) + if (effSat < 1._dp .and. effSat > 0._dp)then + matricHead = (1._dp/alpha)*( effSat**(-1._dp/m) - 1._dp)**(1._dp/n) else - matricHead = 0._rk + matricHead = 0._dp end if end function matricHead @@ -333,16 +333,16 @@ end function matricHead ! ****************************************************************************************************************************** function dTheta_dPsi(psi,alpha,theta_res,theta_sat,n,m) implicit none - real(rk),intent(in) :: psi ! soil water suction (m) - real(rk),intent(in) :: alpha ! scaling parameter (m-1) - real(rk),intent(in) :: theta_res ! residual volumetric water content (-) - real(rk),intent(in) :: theta_sat ! porosity (-) - real(rk),intent(in) :: n ! vGn "n" parameter (-) - real(rk),intent(in) :: m ! vGn "m" parameter (-) - real(rk) :: dTheta_dPsi ! derivative of the soil water characteristic (m-1) - if(psi<=0._rk)then + real(dp),intent(in) :: psi ! soil water suction (m) + real(dp),intent(in) :: alpha ! scaling parameter (m-1) + real(dp),intent(in) :: theta_res ! residual volumetric water content (-) + real(dp),intent(in) :: theta_sat ! porosity (-) + real(dp),intent(in) :: n ! vGn "n" parameter (-) + real(dp),intent(in) :: m ! vGn "m" parameter (-) + real(dp) :: dTheta_dPsi ! derivative of the soil water characteristic (m-1) + if(psi<=0._dp)then dTheta_dPsi = (theta_sat-theta_res) * & - (-m*(1._rk + (psi*alpha)**n)**(-m-1._rk)) * n*(psi*alpha)**(n-1._rk) * alpha + (-m*(1._dp + (psi*alpha)**n)**(-m-1._dp)) * n*(psi*alpha)**(n-1._dp) * alpha if(abs(dTheta_dPsi) < epsilon(psi)) dTheta_dPsi = epsilon(psi) else dTheta_dPsi = epsilon(psi) @@ -356,31 +356,31 @@ end function dTheta_dPsi function dPsi_dTheta(volFracLiq,alpha,theta_res,theta_sat,n,m) implicit none ! dummies - real(rk),intent(in) :: volFracLiq ! volumetric liquid water content (-) - real(rk),intent(in) :: alpha ! scaling parameter (m-1) - real(rk),intent(in) :: theta_res ! residual volumetric water content (-) - real(rk),intent(in) :: theta_sat ! porosity (-) - real(rk),intent(in) :: n ! vGn "n" parameter (-) - real(rk),intent(in) :: m ! vGn "m" parameter (-) - real(rk) :: dPsi_dTheta ! derivative of the soil water characteristic (m) + real(dp),intent(in) :: volFracLiq ! volumetric liquid water content (-) + real(dp),intent(in) :: alpha ! scaling parameter (m-1) + real(dp),intent(in) :: theta_res ! residual volumetric water content (-) + real(dp),intent(in) :: theta_sat ! porosity (-) + real(dp),intent(in) :: n ! vGn "n" parameter (-) + real(dp),intent(in) :: m ! vGn "m" parameter (-) + real(dp) :: dPsi_dTheta ! derivative of the soil water characteristic (m) ! locals - real(rk) :: y1,d1 ! 1st function and derivative - real(rk) :: y2,d2 ! 2nd function and derivative - real(rk) :: theta_e ! effective soil moisture + real(dp) :: y1,d1 ! 1st function and derivative + real(dp) :: y2,d2 ! 2nd function and derivative + real(dp) :: theta_e ! effective soil moisture ! check if less than saturation if(volFracLiq < theta_sat)then ! compute effective water content theta_e = max(0.001,(volFracLiq - theta_res) / (theta_sat - theta_res)) ! compute the 1st function and derivative - y1 = theta_e**(-1._rk/m) - 1._rk - d1 = (-1._rk/m)*theta_e**(-1._rk/m - 1._rk) / (theta_sat - theta_res) + y1 = theta_e**(-1._dp/m) - 1._dp + d1 = (-1._dp/m)*theta_e**(-1._dp/m - 1._dp) / (theta_sat - theta_res) ! compute the 2nd function and derivative - y2 = y1**(1._rk/n) - d2 = (1._rk/n)*y1**(1._rk/n - 1._rk) + y2 = y1**(1._dp/n) + d2 = (1._dp/n)*y1**(1._dp/n - 1._dp) ! compute the final function value dPsi_dTheta = d1*d2/alpha else - dPsi_dTheta = 0._rk + dPsi_dTheta = 0._dp end if end function dPsi_dTheta @@ -391,21 +391,21 @@ end function dPsi_dTheta function dPsi_dTheta2(volFracLiq,alpha,theta_res,theta_sat,n,m,lTangent) implicit none ! dummies - real(rk),intent(in) :: volFracLiq ! volumetric liquid water content (-) - real(rk),intent(in) :: alpha ! scaling parameter (m-1) - real(rk),intent(in) :: theta_res ! residual volumetric water content (-) - real(rk),intent(in) :: theta_sat ! porosity (-) - real(rk),intent(in) :: n ! vGn "n" parameter (-) - real(rk),intent(in) :: m ! vGn "m" parameter (-) + real(dp),intent(in) :: volFracLiq ! volumetric liquid water content (-) + real(dp),intent(in) :: alpha ! scaling parameter (m-1) + real(dp),intent(in) :: theta_res ! residual volumetric water content (-) + real(dp),intent(in) :: theta_sat ! porosity (-) + real(dp),intent(in) :: n ! vGn "n" parameter (-) + real(dp),intent(in) :: m ! vGn "m" parameter (-) logical(lgt),intent(in) :: lTangent ! method used to compute derivative (.true. = analytical) - real(rk) :: dPsi_dTheta2 ! derivative of the soil water characteristic (m) + real(dp) :: dPsi_dTheta2 ! derivative of the soil water characteristic (m) ! locals for analytical derivatives - real(rk) :: xx ! temporary variable - real(rk) :: y1,d1 ! 1st function and derivative - real(rk) :: y2,d2 ! 2nd function and derivative - real(rk) :: theta_e ! effective soil moisture + real(dp) :: xx ! temporary variable + real(dp) :: y1,d1 ! 1st function and derivative + real(dp) :: y2,d2 ! 2nd function and derivative + real(dp) :: theta_e ! effective soil moisture ! locals for numerical derivative - real(rk) :: func0,func1 ! function evaluations + real(dp) :: func0,func1 ! function evaluations ! check if less than saturation if(volFracLiq < theta_sat)then ! ***** compute analytical derivatives @@ -413,12 +413,12 @@ function dPsi_dTheta2(volFracLiq,alpha,theta_res,theta_sat,n,m,lTangent) ! compute the effective saturation theta_e = (volFracLiq - theta_res) / (theta_sat - theta_res) ! get the first function and derivative - y1 = (-1._rk/m)*theta_e**(-1._rk/m - 1._rk) / (theta_sat - theta_res) - d1 = ( (m + 1._rk) / (m**2._rk * (theta_sat - theta_res)**2._rk) ) * theta_e**(-1._rk/m - 2._rk) + y1 = (-1._dp/m)*theta_e**(-1._dp/m - 1._dp) / (theta_sat - theta_res) + d1 = ( (m + 1._dp) / (m**2._dp * (theta_sat - theta_res)**2._dp) ) * theta_e**(-1._dp/m - 2._dp) ! get the second function and derivative - xx = theta_e**(-1._rk/m) - 1._rk - y2 = (1._rk/n)*xx**(1._rk/n - 1._rk) - d2 = ( -(1._rk - n)/((theta_sat - theta_res)*m*n**2._rk) ) * xx**(1._rk/n - 2._rk) * theta_e**(-1._rk/m - 1._rk) + xx = theta_e**(-1._dp/m) - 1._dp + y2 = (1._dp/n)*xx**(1._dp/n - 1._dp) + d2 = ( -(1._dp - n)/((theta_sat - theta_res)*m*n**2._dp) ) * xx**(1._dp/n - 2._dp) * theta_e**(-1._dp/m - 1._dp) ! return the derivative dPsi_dTheta2 = (d1*y2 + y1*d2)/alpha ! ***** compute numerical derivatives @@ -429,7 +429,7 @@ function dPsi_dTheta2(volFracLiq,alpha,theta_res,theta_sat,n,m,lTangent) end if ! (case where volumetric liquid water content exceeds porosity) else - dPsi_dTheta2 = 0._rk + dPsi_dTheta2 = 0._dp end if end function dPsi_dTheta2 @@ -442,41 +442,41 @@ function dHydCond_dPsi(psi,k_sat,alpha,n,m,lTangent) ! given psi and soil hydraulic parameters k_sat, alpha, n, and m implicit none ! dummies - real(rk),intent(in) :: psi ! soil water suction (m) - real(rk),intent(in) :: k_sat ! saturated hydraulic conductivity (m s-1) - real(rk),intent(in) :: alpha ! scaling parameter (m-1) - real(rk),intent(in) :: n ! vGn "n" parameter (-) - real(rk),intent(in) :: m ! vGn "m" parameter (-) + real(dp),intent(in) :: psi ! soil water suction (m) + real(dp),intent(in) :: k_sat ! saturated hydraulic conductivity (m s-1) + real(dp),intent(in) :: alpha ! scaling parameter (m-1) + real(dp),intent(in) :: n ! vGn "n" parameter (-) + real(dp),intent(in) :: m ! vGn "m" parameter (-) logical(lgt),intent(in) :: lTangent ! method used to compute derivative (.true. = analytical) - real(rk) :: dHydCond_dPsi ! derivative in hydraulic conductivity w.r.t. matric head (s-1) + real(dp) :: dHydCond_dPsi ! derivative in hydraulic conductivity w.r.t. matric head (s-1) ! locals for analytical derivatives - real(rk) :: f_x1 ! f(x) for part of the numerator - real(rk) :: f_x2 ! f(x) for part of the numerator - real(rk) :: f_nm ! f(x) for the numerator - real(rk) :: f_dm ! f(x) for the denominator - real(rk) :: d_x1 ! df(x)/dpsi for part of the numerator - real(rk) :: d_x2 ! df(x)/dpsi for part of the numerator - real(rk) :: d_nm ! df(x)/dpsi for the numerator - real(rk) :: d_dm ! df(x)/dpsi for the denominator + real(dp) :: f_x1 ! f(x) for part of the numerator + real(dp) :: f_x2 ! f(x) for part of the numerator + real(dp) :: f_nm ! f(x) for the numerator + real(dp) :: f_dm ! f(x) for the denominator + real(dp) :: d_x1 ! df(x)/dpsi for part of the numerator + real(dp) :: d_x2 ! df(x)/dpsi for part of the numerator + real(dp) :: d_nm ! df(x)/dpsi for the numerator + real(dp) :: d_dm ! df(x)/dpsi for the denominator ! locals for numerical derivatives - real(rk) :: hydCond0 ! hydraulic condictivity value for base case - real(rk) :: hydCond1 ! hydraulic condictivity value for perturbed case + real(dp) :: hydCond0 ! hydraulic condictivity value for base case + real(dp) :: hydCond1 ! hydraulic condictivity value for perturbed case ! derivative is zero if saturated - if(psi<0._rk)then + if(psi<0._dp)then ! ***** compute analytical derivatives if(lTangent)then ! compute the derivative for the numerator - f_x1 = (psi*alpha)**(n - 1._rk) - f_x2 = (1._rk + (psi*alpha)**n)**(-m) - d_x1 = alpha * (n - 1._rk)*(psi*alpha)**(n - 2._rk) - d_x2 = alpha * n*(psi*alpha)**(n - 1._rk) * (-m)*(1._rk + (psi*alpha)**n)**(-m - 1._rk) - f_nm = (1._rk - f_x1*f_x2)**2._rk - d_nm = (-d_x1*f_x2 - f_x1*d_x2) * 2._rk*(1._rk - f_x1*f_x2) + f_x1 = (psi*alpha)**(n - 1._dp) + f_x2 = (1._dp + (psi*alpha)**n)**(-m) + d_x1 = alpha * (n - 1._dp)*(psi*alpha)**(n - 2._dp) + d_x2 = alpha * n*(psi*alpha)**(n - 1._dp) * (-m)*(1._dp + (psi*alpha)**n)**(-m - 1._dp) + f_nm = (1._dp - f_x1*f_x2)**2._dp + d_nm = (-d_x1*f_x2 - f_x1*d_x2) * 2._dp*(1._dp - f_x1*f_x2) ! compute the derivative for the denominator - f_dm = (1._rk + (psi*alpha)**n)**(m/2._rk) - d_dm = alpha * n*(psi*alpha)**(n - 1._rk) * (m/2._rk)*(1._rk + (psi*alpha)**n)**(m/2._rk - 1._rk) + f_dm = (1._dp + (psi*alpha)**n)**(m/2._dp) + d_dm = alpha * n*(psi*alpha)**(n - 1._dp) * (m/2._dp)*(1._dp + (psi*alpha)**n)**(m/2._dp - 1._dp) ! and combine - dHydCond_dPsi = k_sat*(d_nm*f_dm - d_dm*f_nm) / (f_dm**2._rk) + dHydCond_dPsi = k_sat*(d_nm*f_dm - d_dm*f_nm) / (f_dm**2._dp) else ! ***** compute numerical derivatives hydcond0 = hydCond_psi(psi, k_sat,alpha,n,m) @@ -484,7 +484,7 @@ function dHydCond_dPsi(psi,k_sat,alpha,n,m,lTangent) dHydCond_dPsi = (hydcond1 - hydcond0)/dx end if else - dHydCond_dPsi = 0._rk + dHydCond_dPsi = 0._dp end if end function dHydCond_dPsi @@ -498,24 +498,24 @@ end function dHydCond_dPsi function dHydCond_dLiq(volFracLiq,k_sat,theta_res,theta_sat,m,lTangent) implicit none ! dummies - real(rk),intent(in) :: volFracLiq ! volumetric fraction of liquid water (-) - real(rk),intent(in) :: k_sat ! saturated hydraulic conductivity (m s-1) - real(rk),intent(in) :: theta_res ! soil residual volumetric water content (-) - real(rk),intent(in) :: theta_sat ! soil porosity (-) - real(rk),intent(in) :: m ! vGn "m" parameter (-) + real(dp),intent(in) :: volFracLiq ! volumetric fraction of liquid water (-) + real(dp),intent(in) :: k_sat ! saturated hydraulic conductivity (m s-1) + real(dp),intent(in) :: theta_res ! soil residual volumetric water content (-) + real(dp),intent(in) :: theta_sat ! soil porosity (-) + real(dp),intent(in) :: m ! vGn "m" parameter (-) logical(lgt),intent(in) :: lTangent ! method used to compute derivative (.true. = analytical) - real(rk) :: dHydCond_dLiq ! derivative in hydraulic conductivity w.r.t. matric head (s-1) + real(dp) :: dHydCond_dLiq ! derivative in hydraulic conductivity w.r.t. matric head (s-1) ! locals for analytical derivatives - real(rk) :: theta_e ! effective soil moisture - real(rk) :: f1 ! f(x) for the first function - real(rk) :: d1 ! df(x)/dLiq for the first function - real(rk) :: x1,x2 ! f(x) for different parts of the second function - real(rk) :: p1,p2,p3 ! df(x)/dLiq for different parts of the second function - real(rk) :: f2 ! f(x) for the second function - real(rk) :: d2 ! df(x)/dLiq for the second function + real(dp) :: theta_e ! effective soil moisture + real(dp) :: f1 ! f(x) for the first function + real(dp) :: d1 ! df(x)/dLiq for the first function + real(dp) :: x1,x2 ! f(x) for different parts of the second function + real(dp) :: p1,p2,p3 ! df(x)/dLiq for different parts of the second function + real(dp) :: f2 ! f(x) for the second function + real(dp) :: d2 ! df(x)/dLiq for the second function ! locals for numerical derivatives - real(rk) :: hydCond0 ! hydraulic condictivity value for base case - real(rk) :: hydCond1 ! hydraulic condictivity value for perturbed case + real(dp) :: hydCond0 ! hydraulic condictivity value for base case + real(dp) :: hydCond1 ! hydraulic condictivity value for perturbed case ! derivative is zero if super-saturated if(volFracLiq < theta_sat)then ! ***** compute analytical derivatives @@ -523,18 +523,18 @@ function dHydCond_dLiq(volFracLiq,k_sat,theta_res,theta_sat,m,lTangent) ! compute the effective saturation theta_e = (volFracLiq - theta_res) / (theta_sat - theta_res) ! compute the function and derivative of the first fuction - f1 = k_sat*theta_e**0.5_rk - d1 = k_sat*0.5_rk*theta_e**(-0.5_rk) / (theta_sat - theta_res) + f1 = k_sat*theta_e**0.5_dp + d1 = k_sat*0.5_dp*theta_e**(-0.5_dp) / (theta_sat - theta_res) ! compute the function and derivative of the second function ! (first part) - x1 = 1._rk - theta_e**(1._rk/m) - p1 = (-1._rk/m)*theta_e**(1._rk/m - 1._rk) / (theta_sat - theta_res) ! differentiate (1.d - theta_e**(1.d/m) + x1 = 1._dp - theta_e**(1._dp/m) + p1 = (-1._dp/m)*theta_e**(1._dp/m - 1._dp) / (theta_sat - theta_res) ! differentiate (1.d - theta_e**(1.d/m) ! (second part) x2 = x1**m - p2 = m*x1**(m - 1._rk) + p2 = m*x1**(m - 1._dp) ! (final) - f2 = (1._rk - x2)**2._rk - p3 = -2._rk*(1._rk - x2) + f2 = (1._dp - x2)**2._dp + p3 = -2._dp*(1._dp - x2) ! (combine) d2 = p1*p2*p3 ! pull it all together @@ -546,7 +546,7 @@ function dHydCond_dLiq(volFracLiq,k_sat,theta_res,theta_sat,m,lTangent) dHydCond_dLiq = (hydcond1 - hydcond0)/dx end if else - dHydCond_dLiq = 0._rk + dHydCond_dLiq = 0._dp end if end function dHydCond_dLiq @@ -556,9 +556,9 @@ end function dHydCond_dLiq ! ****************************************************************************************************************************** function RH_soilair(matpot,Tk) implicit none - real(rk),intent(in) :: matpot ! soil water suction -- matric potential (m) - real(rk),intent(in) :: Tk ! temperature (K) - real(rk) :: RH_soilair ! relative humidity of air in soil pore space + real(dp),intent(in) :: matpot ! soil water suction -- matric potential (m) + real(dp),intent(in) :: Tk ! temperature (K) + real(dp) :: RH_soilair ! relative humidity of air in soil pore space ! compute relative humidity (UNITS NOTE: Pa = kg m-1 s-2, so R_wv units = m2 s-2 K-1) RH_soilair = exp( (gravity*matpot) / (R_wv*Tk) ) end function RH_soilair @@ -569,9 +569,9 @@ end function RH_soilair ! ****************************************************************************************************************************** function crit_soilT(psi) implicit none - real(rk),intent(in) :: psi ! matric head (m) - real(rk) :: crit_soilT ! critical soil temperature (K) - crit_soilT = Tfreeze + min(psi,0._rk)*gravity*Tfreeze/LH_fus + real(dp),intent(in) :: psi ! matric head (m) + real(dp) :: crit_soilT ! critical soil temperature (K) + crit_soilT = Tfreeze + min(psi,0._dp)*gravity*Tfreeze/LH_fus end function crit_soilT @@ -580,22 +580,22 @@ end function crit_soilT ! ****************************************************************************************************************************** function dTheta_dTk(Tk,theta_res,theta_sat,alpha,n,m) implicit none - real(rk),intent(in) :: Tk ! temperature (K) - real(rk),intent(in) :: theta_res ! residual liquid water content (-) - real(rk),intent(in) :: theta_sat ! porosity (-) - real(rk),intent(in) :: alpha ! vGn scaling parameter (m-1) - real(rk),intent(in) :: n ! vGn "n" parameter (-) - real(rk),intent(in) :: m ! vGn "m" parameter (-) - real(rk) :: dTheta_dTk ! derivative of the freezing curve w.r.t. temperature (K-1) + real(dp),intent(in) :: Tk ! temperature (K) + real(dp),intent(in) :: theta_res ! residual liquid water content (-) + real(dp),intent(in) :: theta_sat ! porosity (-) + real(dp),intent(in) :: alpha ! vGn scaling parameter (m-1) + real(dp),intent(in) :: n ! vGn "n" parameter (-) + real(dp),intent(in) :: m ! vGn "m" parameter (-) + real(dp) :: dTheta_dTk ! derivative of the freezing curve w.r.t. temperature (K-1) ! local variables - real(rk) :: kappa ! constant (m K-1) - real(rk) :: xtemp ! alpha*kappa*(Tk-Tfreeze) -- dimensionless variable (used more than once) + real(dp) :: kappa ! constant (m K-1) + real(dp) :: xtemp ! alpha*kappa*(Tk-Tfreeze) -- dimensionless variable (used more than once) ! compute kappa (m K-1) kappa = LH_fus/(gravity*Tfreeze) ! NOTE: J = kg m2 s-2 ! define a tempory variable that is used more than once (-) xtemp = alpha*kappa*(Tk-Tfreeze) ! differentiate the freezing curve w.r.t. temperature -- making use of the chain rule - dTheta_dTk = (alpha*kappa) * n*xtemp**(n - 1._rk) * (-m)*(1._rk + xtemp**n)**(-m - 1._rk) * (theta_sat - theta_res) + dTheta_dTk = (alpha*kappa) * n*xtemp**(n - 1._dp) * (-m)*(1._dp + xtemp**n)**(-m - 1._dp) * (theta_sat - theta_res) end function dTheta_dTk @@ -604,12 +604,12 @@ end function dTheta_dTk ! ****************************************************************************************************************************** FUNCTION gammp(a,x) IMPLICIT NONE - real(rk), INTENT(IN) :: a,x - real(rk) :: gammp - if (x ITMAX) stop 'a too large, ITMAX too small in gcf' if (present(gln)) then @@ -661,22 +661,22 @@ END FUNCTION gcf ! ****************************************************************************************************************************** FUNCTION gser(a,x,gln) IMPLICIT NONE - real(rk), INTENT(IN) :: a,x - real(rk), OPTIONAL, INTENT(OUT) :: gln - real(rk) :: gser + REAL(DP), INTENT(IN) :: a,x + REAL(DP), OPTIONAL, INTENT(OUT) :: gln + REAL(DP) :: gser INTEGER(I4B), PARAMETER :: ITMAX=100 - real(rk), PARAMETER :: EPS=epsilon(x) + REAL(DP), PARAMETER :: EPS=epsilon(x) INTEGER(I4B) :: n - real(rk) :: ap,del,summ + REAL(DP) :: ap,del,summ if (x == 0.0) then gser=0.0 RETURN end if ap=a - summ=1.0_rk/a + summ=1.0_dp/a del=summ do n=1,ITMAX - ap=ap+1.0_rk + ap=ap+1.0_dp del=del*x/ap summ=summ+del if (abs(del) < abs(summ)*EPS) exit @@ -697,20 +697,20 @@ END FUNCTION gser FUNCTION gammln(xx) USE nr_utility_module,only:arth ! use to build vectors with regular increments IMPLICIT NONE - real(rk), INTENT(IN) :: xx - real(rk) :: gammln - real(rk) :: tmp,x - real(rk) :: stp = 2.5066282746310005_rk - real(rk), DIMENSION(6) :: coef = (/76.18009172947146_rk,& - -86.50532032941677_rk,24.01409824083091_rk,& - -1.231739572450155_rk,0.1208650973866179e-2_rk,& - -0.5395239384953e-5_rk/) - if(xx <= 0._rk) stop 'xx > 0 in gammln' + REAL(DP), INTENT(IN) :: xx + REAL(DP) :: gammln + REAL(DP) :: tmp,x + REAL(DP) :: stp = 2.5066282746310005_dp + REAL(DP), DIMENSION(6) :: coef = (/76.18009172947146_dp,& + -86.50532032941677_dp,24.01409824083091_dp,& + -1.231739572450155_dp,0.1208650973866179e-2_dp,& + -0.5395239384953e-5_dp/) + if(xx <= 0._dp) stop 'xx > 0 in gammln' x=xx - tmp=x+5.5_rk - tmp=(x+0.5_rk)*log(tmp)-tmp - gammln=tmp+log(stp*(1.000000000190015_rk+& - sum(coef(:)/arth(x+1.0_rk,1.0_rk,size(coef))))/x) + tmp=x+5.5_dp + tmp=(x+0.5_dp)*log(tmp)-tmp + gammln=tmp+log(stp*(1.000000000190015_dp+& + sum(coef(:)/arth(x+1.0_dp,1.0_dp,size(coef))))/x) END FUNCTION gammln diff --git a/build/source/engine/spline_int.f90 b/build/source/engine/spline_int.f90 index ceab9c9cf..08be079a2 100755 --- a/build/source/engine/spline_int.f90 +++ b/build/source/engine/spline_int.f90 @@ -13,15 +13,15 @@ SUBROUTINE spline(x,y,yp1,ypn,y2,err,message) ! computes 2nd derivatives of the interpolating function at tabulated points IMPLICIT NONE ! dummy variables - real(rk), DIMENSION(:), INTENT(IN) :: x,y - real(rk), INTENT(IN) :: yp1,ypn - real(rk), DIMENSION(:), INTENT(OUT) :: y2 + REAL(DP), DIMENSION(:), INTENT(IN) :: x,y + REAL(DP), INTENT(IN) :: yp1,ypn + REAL(DP), DIMENSION(:), INTENT(OUT) :: y2 integer(i4b),intent(out) :: err character(*),intent(out) :: message ! local variables character(len=128) :: cmessage INTEGER(I4B) :: n - real(rk), DIMENSION(size(x)) :: a,b,c,r + REAL(DP), DIMENSION(size(x)) :: a,b,c,r ! initialize error control err=0; message="f-spline/" ! check that the size of the vectors match @@ -32,24 +32,24 @@ SUBROUTINE spline(x,y,yp1,ypn,y2,err,message) end if ! start procedure c(1:n-1)=x(2:n)-x(1:n-1) - r(1:n-1)=6.0_rk*((y(2:n)-y(1:n-1))/c(1:n-1)) + r(1:n-1)=6.0_dp*((y(2:n)-y(1:n-1))/c(1:n-1)) r(2:n-1)=r(2:n-1)-r(1:n-2) a(2:n-1)=c(1:n-2) - b(2:n-1)=2.0_rk*(c(2:n-1)+a(2:n-1)) + b(2:n-1)=2.0_dp*(c(2:n-1)+a(2:n-1)) b(1)=1.0 b(n)=1.0 - if (yp1 > 0.99e30_rk) then + if (yp1 > 0.99e30_dp) then r(1)=0.0 c(1)=0.0 else - r(1)=(3.0_rk/(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-yp1) + r(1)=(3.0_dp/(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-yp1) c(1)=0.5 end if - if (ypn > 0.99e30_rk) then + if (ypn > 0.99e30_dp) then r(n)=0.0 a(n)=0.0 else - r(n)=(-3.0_rk/(x(n)-x(n-1)))*((y(n)-y(n-1))/(x(n)-x(n-1))-ypn) + r(n)=(-3.0_dp/(x(n)-x(n-1)))*((y(n)-y(n-1))/(x(n)-x(n-1))-ypn) a(n)=0.5 end if call tridag(a(2:n),b(1:n),c(1:n-1),r(1:n),y2(1:n),err,cmessage) @@ -62,14 +62,14 @@ END SUBROUTINE spline SUBROUTINE splint(xa,ya,y2a,x,y,err,message) IMPLICIT NONE ! declare dummy variables - real(rk), DIMENSION(:), INTENT(IN) :: xa,ya,y2a - real(rk), INTENT(IN) :: x - real(rk), INTENT(OUT) :: y + REAL(DP), DIMENSION(:), INTENT(IN) :: xa,ya,y2a + REAL(DP), INTENT(IN) :: x + REAL(DP), INTENT(OUT) :: y integer(i4b),intent(out) :: err character(*),intent(out) :: message ! declare local variables INTEGER(I4B) :: khi,klo,n - real(rk) :: a,b,h + REAL(DP) :: a,b,h ! check size of input vectors if (size(xa)==size(ya) .and. size(ya)==size(y2a)) then n=size(xa) @@ -80,10 +80,10 @@ SUBROUTINE splint(xa,ya,y2a,x,y,err,message) klo=max(min(locate(xa,x),n-1),1) khi=klo+1 h=xa(khi)-xa(klo) - if (h == 0.0_rk) then; err=20; message="f-splint/badXinput"; return; end if + if (h == 0.0_dp) then; err=20; message="f-splint/badXinput"; return; end if a=(xa(khi)-x)/h b=(x-xa(klo))/h - y=a*ya(klo)+b*ya(khi)+((a**3-a)*y2a(klo)+(b**3-b)*y2a(khi))*(h**2)/6.0_rk + y=a*ya(klo)+b*ya(khi)+((a**3-a)*y2a(klo)+(b**3-b)*y2a(khi))*(h**2)/6.0_dp END SUBROUTINE splint ! ************************************************************* @@ -91,8 +91,8 @@ END SUBROUTINE splint ! ************************************************************* FUNCTION locate(xx,x) IMPLICIT NONE - real(rk), DIMENSION(:), INTENT(IN) :: xx - real(rk), INTENT(IN) :: x + REAL(DP), DIMENSION(:), INTENT(IN) :: xx + REAL(DP), INTENT(IN) :: x INTEGER(I4B) :: locate INTEGER(I4B) :: n,jl,jm,ju LOGICAL :: ascnd @@ -124,14 +124,14 @@ END FUNCTION locate SUBROUTINE tridag(a,b,c,r,u,err,message) IMPLICIT NONE ! dummy variables - real(rk), DIMENSION(:), INTENT(IN) :: a,b,c,r - real(rk), DIMENSION(:), INTENT(OUT) :: u + REAL(DP), DIMENSION(:), INTENT(IN) :: a,b,c,r + REAL(DP), DIMENSION(:), INTENT(OUT) :: u integer(i4b),intent(out) :: err character(*),intent(out) :: message ! local variables - real(rk), DIMENSION(size(b)) :: gam + REAL(DP), DIMENSION(size(b)) :: gam INTEGER(I4B) :: n,j - real(rk) :: bet + REAL(DP) :: bet ! initialize error control err=0; message="f-spline/OK" ! check that the size of the vectors match @@ -142,12 +142,12 @@ SUBROUTINE tridag(a,b,c,r,u,err,message) end if ! start procedure bet=b(1) - if (bet == 0.0_rk) then; err=20; message="f-tridag/errorAtCodeStage-1"; return; end if + if (bet == 0.0_dp) then; err=20; message="f-tridag/errorAtCodeStage-1"; return; end if u(1)=r(1)/bet do j=2,n gam(j)=c(j-1)/bet bet=b(j)-a(j-1)*gam(j) - if (bet == 0.0_rk) then; err=20; message="f-tridag/errorAtCodeStage-2"; return; end if + if (bet == 0.0_dp) then; err=20; message="f-tridag/errorAtCodeStage-2"; return; end if u(j)=(r(j)-a(j-1)*u(j-1))/bet end do do j=n-1,1,-1 diff --git a/build/source/engine/ssdNrgFlux.f90 b/build/source/engine/ssdNrgFlux.f90 index ecc4295f8..cd4f371e2 100755 --- a/build/source/engine/ssdNrgFlux.f90 +++ b/build/source/engine/ssdNrgFlux.f90 @@ -83,8 +83,8 @@ module ssdNrgFlux_module private public::ssdNrgFlux ! global parameters -real(rk),parameter :: dx=1.e-10_rk ! finite difference increment (K) -real(rk),parameter :: valueMissing=-9999._rk ! missing value parameter +real(dp),parameter :: dx=1.e-10_dp ! finite difference increment (K) +real(dp),parameter :: valueMissing=-9999._dp ! missing value parameter contains ! ************************************************************************************************ @@ -117,13 +117,13 @@ subroutine ssdNrgFlux(& ! input: model control logical(lgt),intent(in) :: scalarSolution ! flag to denote if implementing the scalar solution ! input: fluxes and derivatives at the upper boundary - real(rk),intent(in) :: groundNetFlux ! net energy flux for the ground surface (W m-2) - real(rk),intent(in) :: dGroundNetFlux_dGroundTemp ! derivative in net ground flux w.r.t. ground temperature (W m-2 K-1) + real(dp),intent(in) :: groundNetFlux ! net energy flux for the ground surface (W m-2) + real(dp),intent(in) :: dGroundNetFlux_dGroundTemp ! derivative in net ground flux w.r.t. ground temperature (W m-2 K-1) ! input: liquid water fluxes - real(rk),intent(in) :: iLayerLiqFluxSnow(0:) ! intent(in): liquid flux at the interface of each snow layer (m s-1) - real(rk),intent(in) :: iLayerLiqFluxSoil(0:) ! intent(in): liquid flux at the interface of each soil layer (m s-1) + real(dp),intent(in) :: iLayerLiqFluxSnow(0:) ! intent(in): liquid flux at the interface of each snow layer (m s-1) + real(dp),intent(in) :: iLayerLiqFluxSoil(0:) ! intent(in): liquid flux at the interface of each soil layer (m s-1) ! input: trial value of model state variables - real(rk),intent(in) :: mLayerTempTrial(:) ! trial temperature of each snow/soil layer at the current iteration (K) + real(dp),intent(in) :: mLayerTempTrial(:) ! trial temperature of each snow/soil layer at the current iteration (K) ! input-output: data structures type(var_dlength),intent(in) :: mpar_data ! model parameters type(var_ilength),intent(in) :: indx_data ! state vector geometry @@ -131,9 +131,9 @@ subroutine ssdNrgFlux(& type(var_dlength),intent(in) :: diag_data ! diagnostic variables for a local HRU type(var_dlength),intent(inout) :: flux_data ! model fluxes for a local HRU ! output: fluxes and derivatives at all layer interfaces - real(rk),intent(out) :: iLayerNrgFlux(0:) ! energy flux at the layer interfaces (W m-2) - real(rk),intent(out) :: dFlux_dTempAbove(0:) ! derivatives in the flux w.r.t. temperature in the layer above (J m-2 s-1 K-1) - real(rk),intent(out) :: dFlux_dTempBelow(0:) ! derivatives in the flux w.r.t. temperature in the layer below (J m-2 s-1 K-1) + real(dp),intent(out) :: iLayerNrgFlux(0:) ! energy flux at the layer interfaces (W m-2) + real(dp),intent(out) :: dFlux_dTempAbove(0:) ! derivatives in the flux w.r.t. temperature in the layer above (J m-2 s-1 K-1) + real(dp),intent(out) :: dFlux_dTempBelow(0:) ! derivatives in the flux w.r.t. temperature in the layer below (J m-2 s-1 K-1) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message @@ -143,9 +143,9 @@ subroutine ssdNrgFlux(& integer(i4b) :: ixLayerDesired(1) ! layer desired (scalar solution) integer(i4b) :: ixTop ! top layer in subroutine call integer(i4b) :: ixBot ! bottom layer in subroutine call - real(rk) :: qFlux ! liquid flux at layer interfaces (m s-1) - real(rk) :: dz ! height difference (m) - real(rk) :: flux0,flux1,flux2 ! fluxes used to calculate derivatives (W m-2) + real(dp) :: qFlux ! liquid flux at layer interfaces (m s-1) + real(dp) :: dz ! height difference (m) + real(dp) :: flux0,flux1,flux2 ! fluxes used to calculate derivatives (W m-2) ! ------------------------------------------------------------------------------------------------------------------------------------------------------ ! make association of local variables with information in the data structures associate(& @@ -194,8 +194,8 @@ subroutine ssdNrgFlux(& if(iLayer==nLayers)then ! flux depends on the type of lower boundary condition select case(ix_bcLowrTdyn) ! (identify the lower boundary condition for thermodynamics - case(prescribedTemp); iLayerConductiveFlux(nLayers) = -iLayerThermalC(iLayer)*(lowerBoundTemp - mLayerTempTrial(iLayer))/(mLayerDepth(iLayer)*0.5_rk) - case(zeroFlux); iLayerConductiveFlux(nLayers) = 0._rk + case(prescribedTemp); iLayerConductiveFlux(nLayers) = -iLayerThermalC(iLayer)*(lowerBoundTemp - mLayerTempTrial(iLayer))/(mLayerDepth(iLayer)*0.5_dp) + case(zeroFlux); iLayerConductiveFlux(nLayers) = 0._dp case default; err=20; message=trim(message)//'unable to identify lower boundary condition for thermodynamics'; return end select ! (identifying the lower boundary condition for thermodynamics) @@ -257,7 +257,7 @@ subroutine ssdNrgFlux(& ! * prescribed temperature at the lower boundary case(prescribedTemp) - dz = mLayerDepth(iLayer)*0.5_rk + dz = mLayerDepth(iLayer)*0.5_dp if(ix_fDerivMeth==analytical)then ! ** analytical derivatives dFlux_dTempAbove(iLayer) = iLayerThermalC(iLayer)/dz else ! ** numerical derivatives @@ -268,7 +268,7 @@ subroutine ssdNrgFlux(& ! * zero flux at the lower boundary case(zeroFlux) - dFlux_dTempAbove(iLayer) = 0._rk + dFlux_dTempAbove(iLayer) = 0._dp case default; err=20; message=trim(message)//'unable to identify lower boundary condition for thermodynamics'; return diff --git a/build/source/engine/stomResist.f90 b/build/source/engine/stomResist.f90 index 70897fd1f..00cee9975 100755 --- a/build/source/engine/stomResist.f90 +++ b/build/source/engine/stomResist.f90 @@ -94,11 +94,11 @@ module stomResist_module integer(i4b),parameter :: iLoc = 1 ! i-location integer(i4b),parameter :: jLoc = 1 ! j-location ! conversion factors -real(rk),parameter :: joule2umolConv=4.6_rk ! conversion factor from joules to umol photons (umol J-1) +real(dp),parameter :: joule2umolConv=4.6_dp ! conversion factor from joules to umol photons (umol J-1) ! algorithmic parameters -real(rk),parameter :: missingValue=-9999._rk ! missing value, used when diagnostic or state variables are undefined -real(rk),parameter :: mpe=1.e-6_rk ! prevents overflow error if division by zero -real(rk),parameter :: dx=1.e-6_rk ! finite difference increment +real(dp),parameter :: missingValue=-9999._dp ! missing value, used when diagnostic or state variables are undefined +real(dp),parameter :: mpe=1.e-6_dp ! prevents overflow error if division by zero +real(dp),parameter :: dx=1.e-6_dp ! finite difference increment contains @@ -127,9 +127,9 @@ subroutine stomResist(& USE conv_funcs_module,only:satVapPress ! function to compute the saturated vapor pressure (Pa) ! ------------------------------------------------------------------------------------------------------------------------------------------------------ ! input: state and diagnostic variables - real(rk),intent(in) :: scalarVegetationTemp ! vegetation temperature (K) - real(rk),intent(in) :: scalarSatVP_VegTemp ! saturation vapor pressure at vegetation temperature (Pa) - real(rk),intent(in) :: scalarVP_CanopyAir ! canopy air vapor pressure (Pa) + real(dp),intent(in) :: scalarVegetationTemp ! vegetation temperature (K) + real(dp),intent(in) :: scalarSatVP_VegTemp ! saturation vapor pressure at vegetation temperature (Pa) + real(dp),intent(in) :: scalarVP_CanopyAir ! canopy air vapor pressure (Pa) ! input: data structures type(var_i),intent(in) :: type_data ! type of vegetation and soil type(var_d),intent(in) :: forc_data ! model forcing data @@ -147,10 +147,10 @@ subroutine stomResist(& integer(i4b),parameter :: ixSunlit=1 ! named variable for sunlit leaves integer(i4b),parameter :: ixShaded=2 ! named variable for shaded leaves integer(i4b) :: iSunShade ! index defining sunlit or shaded leaves - real(rk) :: absorbedPAR ! absorbed PAR (W m-2) - real(rk) :: scalarStomResist ! stomatal resistance (s m-1) - real(rk) :: scalarPhotosynthesis ! photosynthesis (umol CO2 m-2 s-1) - real(rk) :: ci ! intercellular co2 partial pressure (Pa) + real(dp) :: absorbedPAR ! absorbed PAR (W m-2) + real(dp) :: scalarStomResist ! stomatal resistance (s m-1) + real(dp) :: scalarPhotosynthesis ! photosynthesis (umol CO2 m-2 s-1) + real(dp) :: ci ! intercellular co2 partial pressure (Pa) ! ------------------------------------------------------------------------------------------------------------------------------------------------------ ! associate variables in the data structure @@ -356,10 +356,10 @@ subroutine stomResist_flex(& ! ------------------------------------------------------------------------------------------------------------------------------------------------------ ! ------------------------------------------------------------------------------------------------------------------------------------------------------ ! input: state and diagnostic variables - real(rk),intent(in) :: scalarVegetationTemp ! vegetation temperature (K) - real(rk),intent(in) :: scalarSatVP_VegTemp ! saturation vapor pressure at vegetation temperature (Pa) - real(rk),intent(in) :: scalarVP_CanopyAir ! canopy air vapor pressure (Pa) - real(rk),intent(in) :: absorbedPAR ! absorbed PAR (W m-2) + real(dp),intent(in) :: scalarVegetationTemp ! vegetation temperature (K) + real(dp),intent(in) :: scalarSatVP_VegTemp ! saturation vapor pressure at vegetation temperature (Pa) + real(dp),intent(in) :: scalarVP_CanopyAir ! canopy air vapor pressure (Pa) + real(dp),intent(in) :: absorbedPAR ! absorbed PAR (W m-2) ! input: data structures type(var_d),intent(in) :: forc_data ! model forcing data type(var_dlength),intent(in) :: mpar_data ! model parameters @@ -367,69 +367,69 @@ subroutine stomResist_flex(& type(var_dlength),intent(in) :: flux_data ! model fluxes for a local HRU type(model_options),intent(in) :: model_decisions(:) ! model decisions ! output: stomatal resistance and photosynthesis - real(rk),intent(inout) :: ci ! intercellular co2 partial pressure (Pa) - real(rk),intent(out) :: scalarStomResist ! stomatal resistance (s m-1) - real(rk),intent(out) :: scalarPhotosynthesis ! photosynthesis (umol CO2 m-2 s-1) + real(dp),intent(inout) :: ci ! intercellular co2 partial pressure (Pa) + real(dp),intent(out) :: scalarStomResist ! stomatal resistance (s m-1) + real(dp),intent(out) :: scalarPhotosynthesis ! photosynthesis (umol CO2 m-2 s-1) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! ------------------------------------------------------------------------------------------------------------------------------------------------------ ! general local variables logical(lgt),parameter :: testDerivs=.false. ! flag to test the derivatives - real(rk) :: unitConv ! unit conversion factor (mol m-3, convert m s-1 --> mol H20 m-2 s-1) - real(rk) :: rlb ! leaf boundary layer rersistance (umol-1 m2 s) - real(rk) :: x0,x1,x2 ! temporary variables - real(rk) :: co2compPt ! co2 compensation point (Pa) - real(rk) :: fHum ! humidity function, fraction [0,1] + real(dp) :: unitConv ! unit conversion factor (mol m-3, convert m s-1 --> mol H20 m-2 s-1) + real(dp) :: rlb ! leaf boundary layer rersistance (umol-1 m2 s) + real(dp) :: x0,x1,x2 ! temporary variables + real(dp) :: co2compPt ! co2 compensation point (Pa) + real(dp) :: fHum ! humidity function, fraction [0,1] ! ------------------------------------------------------------------------------------------------------------------------------------------------------ ! fixed parameters integer(i4b),parameter :: maxiter=20 ! maximum number of iterations integer(i4b),parameter :: maxiter_noahMP=3 ! maximum number of iterations for Noah-MP - real(rk),parameter :: convToler=0.0001_rk ! convergence tolerance (Pa) - real(rk),parameter :: umol_per_mol=1.e+6_rk ! factor to relate umol to mol - real(rk),parameter :: o2scaleFactor=0.105_rk ! scaling factor used to compute co2 compesation point (0.21/2) - real(rk),parameter :: h2o_co2__leafbl=1.37_rk ! factor to represent the different diffusivities of h2o and co2 in the leaf boundary layer (-) - real(rk),parameter :: h2o_co2__stomPores=1.65_rk ! factor to represent the different diffusivities of h2o and co2 in the stomatal pores (-) - real(rk),parameter :: Tref=298.16_rk ! reference temperature (25 deg C) - real(rk),parameter :: Tscale=10._rk ! scaling factor in q10 function (K) - real(rk),parameter :: c_ps2=0.7_rk ! curvature factor for electron transport (-) - real(rk),parameter :: fnf=0.6666666667_rk ! foliage nitrogen factor (-) + real(dp),parameter :: convToler=0.0001_dp ! convergence tolerance (Pa) + real(dp),parameter :: umol_per_mol=1.e+6_dp ! factor to relate umol to mol + real(dp),parameter :: o2scaleFactor=0.105_dp ! scaling factor used to compute co2 compesation point (0.21/2) + real(dp),parameter :: h2o_co2__leafbl=1.37_dp ! factor to represent the different diffusivities of h2o and co2 in the leaf boundary layer (-) + real(dp),parameter :: h2o_co2__stomPores=1.65_dp ! factor to represent the different diffusivities of h2o and co2 in the stomatal pores (-) + real(dp),parameter :: Tref=298.16_dp ! reference temperature (25 deg C) + real(dp),parameter :: Tscale=10._dp ! scaling factor in q10 function (K) + real(dp),parameter :: c_ps2=0.7_dp ! curvature factor for electron transport (-) + real(dp),parameter :: fnf=0.6666666667_dp ! foliage nitrogen factor (-) ! ------------------------------------------------------------------------------------------------------------------------------------------------------ ! photosynthesis - real(rk) :: Kc,Ko ! Michaelis-Menten constants for co2 and o2 (Pa) - real(rk) :: vcmax25 ! maximum Rubisco carboxylation rate at 25 deg C (umol m-2 s-1) - real(rk) :: jmax25 ! maximum electron transport rate at 25 deg C (umol m-2 s-1) - real(rk) :: vcmax ! maximum Rubisco carboxylation rate (umol m-2 s-1) - real(rk) :: jmax ! maximum electron transport rate (umol m-2 s-1) - real(rk) :: aQuad ! the quadratic coefficient in the quadratic equation - real(rk) :: bQuad ! the linear coefficient in the quadratic equation - real(rk) :: cQuad ! the constant in the quadratic equation - real(rk) :: bSign ! sign of the linear coeffcient - real(rk) :: xTemp ! temporary variable in the quadratic equation - real(rk) :: qQuad ! the "q" term in the quadratic equation - real(rk) :: root1,root2 ! roots of the quadratic function - real(rk) :: Js ! scaled electron transport rate (umol co2 m-2 s-1) - real(rk) :: I_ps2 ! PAR absorbed by PS2 (umol photon m-2 s-1) - real(rk) :: awb ! Michaelis-Menten control (Pa) - real(rk) :: cp2 ! additional controls in light-limited assimilation (Pa) - real(rk) :: psn ! leaf gross photosynthesis rate (umol co2 m-2 s-1) - real(rk) :: dA_dc ! derivative in photosynthesis w.r.t. intercellular co2 concentration + real(dp) :: Kc,Ko ! Michaelis-Menten constants for co2 and o2 (Pa) + real(dp) :: vcmax25 ! maximum Rubisco carboxylation rate at 25 deg C (umol m-2 s-1) + real(dp) :: jmax25 ! maximum electron transport rate at 25 deg C (umol m-2 s-1) + real(dp) :: vcmax ! maximum Rubisco carboxylation rate (umol m-2 s-1) + real(dp) :: jmax ! maximum electron transport rate (umol m-2 s-1) + real(dp) :: aQuad ! the quadratic coefficient in the quadratic equation + real(dp) :: bQuad ! the linear coefficient in the quadratic equation + real(dp) :: cQuad ! the constant in the quadratic equation + real(dp) :: bSign ! sign of the linear coeffcient + real(dp) :: xTemp ! temporary variable in the quadratic equation + real(dp) :: qQuad ! the "q" term in the quadratic equation + real(dp) :: root1,root2 ! roots of the quadratic function + real(dp) :: Js ! scaled electron transport rate (umol co2 m-2 s-1) + real(dp) :: I_ps2 ! PAR absorbed by PS2 (umol photon m-2 s-1) + real(dp) :: awb ! Michaelis-Menten control (Pa) + real(dp) :: cp2 ! additional controls in light-limited assimilation (Pa) + real(dp) :: psn ! leaf gross photosynthesis rate (umol co2 m-2 s-1) + real(dp) :: dA_dc ! derivative in photosynthesis w.r.t. intercellular co2 concentration ! ------------------------------------------------------------------------------------------------------------------------------------------------------ ! stomatal resistance - real(rk) :: gMin ! scaled minimum conductance (umol m-2 s-1) - real(rk) :: cs ! co2 partial pressure at leaf surface (Pa) - real(rk) :: csx ! control of co2 partial pressure at leaf surface on stomatal conductance (Pa) - real(rk) :: g0 ! stomatal conductance in the absence of humidity controls (umol m-2 s-1) - real(rk) :: ci_old ! intercellular co2 partial pressure (Pa) - real(rk) :: rs ! stomatal resistance (umol-1 m2 s) - real(rk) :: dg0_dc ! derivative in g0 w.r.t intercellular co2 concentration (umol m-2 s-1 Pa-1) - real(rk) :: drs_dc ! derivative in stomatal resistance w.r.t. intercellular co2 concentration - real(rk) :: dci_dc ! final derivative (-) + real(dp) :: gMin ! scaled minimum conductance (umol m-2 s-1) + real(dp) :: cs ! co2 partial pressure at leaf surface (Pa) + real(dp) :: csx ! control of co2 partial pressure at leaf surface on stomatal conductance (Pa) + real(dp) :: g0 ! stomatal conductance in the absence of humidity controls (umol m-2 s-1) + real(dp) :: ci_old ! intercellular co2 partial pressure (Pa) + real(dp) :: rs ! stomatal resistance (umol-1 m2 s) + real(dp) :: dg0_dc ! derivative in g0 w.r.t intercellular co2 concentration (umol m-2 s-1 Pa-1) + real(dp) :: drs_dc ! derivative in stomatal resistance w.r.t. intercellular co2 concentration + real(dp) :: dci_dc ! final derivative (-) ! ------------------------------------------------------------------------------------------------------------------------------------------------------ ! iterative solution - real(rk) :: func1,func2 ! functions for numerical derivative calculation - real(rk) :: cMin,cMax ! solution brackets - real(rk) :: xInc ! iteration increment (Pa) + real(dp) :: func1,func2 ! functions for numerical derivative calculation + real(dp) :: cMin,cMax ! solution brackets + real(dp) :: xInc ! iteration increment (Pa) integer(i4b) :: iter ! iteration index ! ------------------------------------------------------------------------------------------------------------------------------------------------------ ! associate variables in the data structure @@ -498,8 +498,8 @@ subroutine stomResist_flex(& ! check there is light available for photosynthesis if(absorbedPAR < tiny(absorbedPAR) .or. scalarGrowingSeasonIndex < tiny(absorbedPAR))then scalarStomResist = unitConv*umol_per_mol/(scalarTranspireLim*minStomatalConductance) - scalarPhotosynthesis = 0._rk - ci = 0._rk + scalarPhotosynthesis = 0._dp + ci = 0._dp return end if @@ -572,27 +572,27 @@ subroutine stomResist_flex(& ! linear function of qmax, as used in Cable [Wang et al., Ag Forest Met 1998, eq D5] case(linearJmax) x0 = quantamYield*joule2umolConv*absorbedPAR - x1 = x0*jmax / (x0 + 2.1_rk*jmax) - Js = x1/4._rk ! scaled electron transport + x1 = x0*jmax / (x0 + 2.1_dp*jmax) + Js = x1/4._dp ! scaled electron transport ! quadraric function of jmax, as used in CLM5 (Bonan et al., JGR 2011, Table B2) case(quadraticJmax) ! PAR absorbed by PS2 (umol photon m-2 s-1) - I_ps2 = 0.5_rk*(1._rk - fractionJ) * joule2umolConv*absorbedPAR ! Farquar (1980), eq 8: PAR absorbed by PS2 (umol photon m-2 s-1) + I_ps2 = 0.5_dp*(1._dp - fractionJ) * joule2umolConv*absorbedPAR ! Farquar (1980), eq 8: PAR absorbed by PS2 (umol photon m-2 s-1) ! define coefficients in the quadratic equation aQuad = c_ps2 ! quadratic coefficient = cuurvature factor for electron transport bQuad = -(I_ps2 + jmax) ! linear coefficient cQuad = I_ps2 * jmax ! free term ! compute the q term (NOTE: bQuad is always positive) bSign = abs(bQuad)/bQuad - xTemp = bQuad*bQuad - 4._rk *aQuad*cQuad - qQuad = -0.5_rk * (bQuad + bSign*sqrt(xTemp)) + xTemp = bQuad*bQuad - 4._dp *aQuad*cQuad + qQuad = -0.5_dp * (bQuad + bSign*sqrt(xTemp)) ! compute roots root1 = qQuad / aQuad root2 = cQuad / qQuad ! select minimum root, required to ensure J=0 when par=0 ! NOTE: Wittig et al. select the first root, which is the max in all cases I tried - Js = min(root1,root2) / 4._rk ! scaled J + Js = min(root1,root2) / 4._dp ! scaled J ! check found an appropriate option case default; err=20; message=trim(message)//'unable to find option for electron transport controls on stomatal conductance'; return @@ -605,7 +605,7 @@ subroutine stomResist_flex(& ! define the humidity function select case(ix_bbHumdFunc) - case(humidLeafSurface); fHum = min( max(0.25_rk, scalarVP_CanopyAir/scalarSatVP_VegTemp), 1._rk) + case(humidLeafSurface); fHum = min( max(0.25_dp, scalarVP_CanopyAir/scalarSatVP_VegTemp), 1._dp) case(scaledHyperbolic); fHum = (scalarSatVP_VegTemp - scalarVP_CanopyAir)/vpScaleFactor case default; err=20; message=trim(message)//'unable to identify humidity control on stomatal conductance'; return end select @@ -614,23 +614,23 @@ subroutine stomResist_flex(& co2compPt = (Kc/Ko)*scalarO2air*o2scaleFactor ! compute the Michaelis-Menten controls (Pa) - awb = Kc*(1._rk + scalarO2air/Ko) + awb = Kc*(1._dp + scalarO2air/Ko) ! compute the additional controls in light-limited assimilation - cp2 = co2compPt*2._rk + cp2 = co2compPt*2._dp ! define trial value of intercellular co2 (Pa) ! NOTE: only initialize if less than the co2 compensation point; otherwise, initialize with previous value if(ix_bbNumerics==newtonRaphson)then - if(ci < co2compPt) ci = 0.7_rk*scalarCO2air + if(ci < co2compPt) ci = 0.7_dp*scalarCO2air else - ci = 0.7_rk*scalarCO2air ! always initialize if not NR + ci = 0.7_dp*scalarCO2air ! always initialize if not NR end if !write(*,'(a,1x,10(f20.10,1x))') 'Kc25, Kc_qFac, Ko25, Ko_qFac = ', Kc25, Kc_qFac, Ko25, Ko_qFac !write(*,'(a,1x,10(f20.10,1x))') 'scalarCO2air, ci, co2compPt, Kc, Ko = ', scalarCO2air, ci, co2compPt, Kc, Ko ! initialize brackets for the solution - cMin = 0._rk + cMin = 0._dp cMax = scalarCO2air ! ********************************************************************************************************************************* @@ -670,14 +670,14 @@ subroutine stomResist_flex(& ! compute conductance in the absence of humidity g0 = cond2photo_slope*airpres*psn/csx - dg0_dc = cond2photo_slope*airpres*dA_dc*(x1*psn/cs + 1._rk)/csx + dg0_dc = cond2photo_slope*airpres*dA_dc*(x1*psn/cs + 1._dp)/csx ! use quadratic function to compute stomatal resistance call quadResist(.true.,ix_bbHumdFunc,rlb,fHum,gMin,g0,dg0_dc,rs,drs_dc) ! compute intercellular co2 partial pressues (Pa) x2 = h2o_co2__stomPores * airpres ! Pa - ci = max(cs - x2*psn*rs, 0._rk) ! Pa + ci = max(cs - x2*psn*rs, 0._dp) ! Pa ! print progress !if(ix_bbNumerics==NoahMPsolution)then @@ -689,7 +689,7 @@ subroutine stomResist_flex(& if(ci > tiny(ci))then dci_dc = -x1*dA_dc - x2*(psn*drs_dc + rs*dA_dc) else - dci_dc = 0._rk + dci_dc = 0._dp end if ! test derivatives @@ -721,14 +721,14 @@ subroutine stomResist_flex(& end if ! compute iteration increment (Pa) - xInc = (ci - ci_old)/(1._rk - dci_dc) + xInc = (ci - ci_old)/(1._dp - dci_dc) ! update - ci = max(ci_old + xInc, 0._rk) + ci = max(ci_old + xInc, 0._dp) ! ensure that we stay within brackets if(ci > cMax .or. ci < cMin)then - ci = 0.5_rk * (cMin + cMax) + ci = 0.5_dp * (cMin + cMax) end if ! print progress @@ -758,11 +758,11 @@ subroutine stomResist_flex(& ! internal function used to test derivatives function testFunc(ci, cond2photo_slope, airpres, scalarCO2air, ix_bbHumdFunc, ix_bbCO2point, ix_bbAssimFnc) - real(rk),intent(in) :: ci, cond2photo_slope, airpres, scalarCO2air + real(dp),intent(in) :: ci, cond2photo_slope, airpres, scalarCO2air integer(i4b),intent(in) :: ix_bbHumdFunc, ix_bbCO2point, ix_bbAssimFnc - real(rk) :: testFunc - real(rk),parameter :: unUsedInput=0._rk - real(rk) :: unUsedOutput + real(dp) :: testFunc + real(dp),parameter :: unUsedInput=0._dp + real(dp) :: unUsedOutput ! compute gross photosynthesis [follow Farquar (Planta, 1980), as implemented in CLM4 and Noah-MP] call photosynthesis(.false., ix_bbAssimFnc, ci, co2compPt, awb, cp2, vcmax, Js, psn, unUsedOutput) @@ -786,7 +786,7 @@ function testFunc(ci, cond2photo_slope, airpres, scalarCO2air, ix_bbHumdFunc, ix ! compute intercellular co2 partial pressues (Pa) x2 = h2o_co2__stomPores * airpres ! Pa - testFunc = max(cs - x2*psn*rs, 0._rk) ! Pa + testFunc = max(cs - x2*psn*rs, 0._dp) ! Pa end function testFunc @@ -800,37 +800,37 @@ subroutine photosynthesis(desireDeriv, ix_bbAssimFnc, ci, co2compPt, awb, cp2, v ! dummy variables logical(lgt),intent(in) :: desireDeriv ! .true. if the derivative is desired integer(i4b),intent(in) :: ix_bbAssimFnc ! model option for the function used for co2 assimilation (min func, or colimtation) - real(rk),intent(in) :: ci ! intercellular co2 concentration (Pa) - real(rk),intent(in) :: co2compPt ! co2 compensation point (Pa) - real(rk),intent(in) :: awb ! Michaelis-Menten control (Pa) - real(rk),intent(in) :: cp2 ! additional controls in light-limited assimilation (Pa) - real(rk),intent(in) :: vcmax ! maximum Rubisco carboxylation rate (umol co2 m-2 s-1) - real(rk),intent(in) :: Js ! scaled electron transport rate (umol co2 m-2 s-1) - real(rk),intent(out) :: psn ! leaf gross photosynthesis rate (umol co2 m-2 s-1) - real(rk),intent(out) :: dA_dc ! derivative in photosynthesis w.r.t. intercellular co2 concentration (umol co2 m-2 s-1 Pa-1) + real(dp),intent(in) :: ci ! intercellular co2 concentration (Pa) + real(dp),intent(in) :: co2compPt ! co2 compensation point (Pa) + real(dp),intent(in) :: awb ! Michaelis-Menten control (Pa) + real(dp),intent(in) :: cp2 ! additional controls in light-limited assimilation (Pa) + real(dp),intent(in) :: vcmax ! maximum Rubisco carboxylation rate (umol co2 m-2 s-1) + real(dp),intent(in) :: Js ! scaled electron transport rate (umol co2 m-2 s-1) + real(dp),intent(out) :: psn ! leaf gross photosynthesis rate (umol co2 m-2 s-1) + real(dp),intent(out) :: dA_dc ! derivative in photosynthesis w.r.t. intercellular co2 concentration (umol co2 m-2 s-1 Pa-1) ! local variables integer(i4b),parameter :: nFactors=3 ! number of limiting factors for assimilation (light, Rubisco, and export) integer(i4b),parameter :: ixRubi=1 ! named variable for Rubisco-limited assimilation integer(i4b),parameter :: ixLight=2 ! named variable for light-limited assimilation integer(i4b),parameter :: ixExport=3 ! named variable for export-limited assimilation integer(i4b) :: ixLimitVec(1),ixLimit ! index of factor limiting assimilation - real(rk) :: xFac(nFactors) ! temporary variable used to compute assimilation rate - real(rk) :: xPSN(nFactors) ! assimilation rate for different factors (light, Rubisco, and export) - real(rk) :: ciDiff ! difference between intercellular co2 and the co2 compensation point - real(rk) :: ciDer ! factor to account for constainted intercellular co2 in calculating derivatives - real(rk) :: x0 ! temporary variable - real(rk) :: xsPSN ! intermediate smoothed photosynthesis - real(rk) :: dAc_dc,dAj_dc,dAe_dc,dAi_dc ! derivatives in assimilation w.r.t. intercellular co2 concentration - real(rk),parameter :: theta_cj=0.98_rk ! coupling coefficient (see Sellers et al., 1996 [eq C6]; Bonan et al., 2011 [Table B1]) - real(rk),parameter :: theta_ie=0.95_rk ! coupling coefficient (see Sellers et al., 1996 [eq C6]; Bonan et al., 2011 [Table B1]) + real(dp) :: xFac(nFactors) ! temporary variable used to compute assimilation rate + real(dp) :: xPSN(nFactors) ! assimilation rate for different factors (light, Rubisco, and export) + real(dp) :: ciDiff ! difference between intercellular co2 and the co2 compensation point + real(dp) :: ciDer ! factor to account for constainted intercellular co2 in calculating derivatives + real(dp) :: x0 ! temporary variable + real(dp) :: xsPSN ! intermediate smoothed photosynthesis + real(dp) :: dAc_dc,dAj_dc,dAe_dc,dAi_dc ! derivatives in assimilation w.r.t. intercellular co2 concentration + real(dp),parameter :: theta_cj=0.98_dp ! coupling coefficient (see Sellers et al., 1996 [eq C6]; Bonan et al., 2011 [Table B1]) + real(dp),parameter :: theta_ie=0.95_dp ! coupling coefficient (see Sellers et al., 1996 [eq C6]; Bonan et al., 2011 [Table B1]) ! ------------------------------------------------------------ ! this method follows Farquar (Planta, 1980), as implemented in CLM4 and Noah-MP ! compute the difference between intercellular co2 concentraion and the compensation point - ciDiff = max(0._rk, ci - co2compPt) + ciDiff = max(0._dp, ci - co2compPt) ! impose constraints (NOTE: derivative is zero if constraints are imposed) - if(ci < co2compPt)then; ciDer = 0._rk; else; ciDer = 1._rk; end if + if(ci < co2compPt)then; ciDer = 0._dp; else; ciDer = 1._dp; end if ! compute Rubisco-limited assimilation xFac(ixRubi) = vcmax/(ci + awb) ! umol co2 m-2 s-1 Pa-1 @@ -841,7 +841,7 @@ subroutine photosynthesis(desireDeriv, ix_bbAssimFnc, ci, co2compPt, awb, cp2, v xPSN(ixLight) = xFac(ixLight)*ciDiff ! umol co2 m-2 s-1 ! compute export limited assimilation - xFac(ixExport) = 0.5_rk + xFac(ixExport) = 0.5_dp xPSN(ixExport) = xFac(ixExport)*vcmax ! umol co2 m-2 s-1 ! print progress @@ -868,12 +868,12 @@ subroutine photosynthesis(desireDeriv, ix_bbAssimFnc, ci, co2compPt, awb, cp2, v select case(ixLimit) case(ixRubi); dA_dc = x0*ciDer - ciDiff*x0*x0/vcmax ! Rubisco-limited assimilation case(ixLight); dA_dc = x0*ciDer - ciDiff*x0*x0/Js ! light-limited assimilation - case(ixExport); dA_dc = 0._rk ! export-limited assimilation + case(ixExport); dA_dc = 0._dp ! export-limited assimilation end select ! derivatives are not desired else - dA_dc = 0._rk + dA_dc = 0._dp end if ! colimitation (Collatz et al., 1991; Sellers et al., 1996; Bonan et al., 2011) @@ -883,19 +883,19 @@ subroutine photosynthesis(desireDeriv, ix_bbAssimFnc, ci, co2compPt, awb, cp2, v if(desireDeriv)then dAc_dc = xFac(ixRubi)*ciDer - ciDiff*xFac(ixRubi)*xFac(ixRubi)/vcmax dAj_dc = xFac(ixLight)*ciDer - ciDiff*xFac(ixLight)*xFac(ixLight)/Js - dAe_dc = 0._rk + dAe_dc = 0._dp else - dAc_dc = 0._rk - dAj_dc = 0._rk - dAe_dc = 0._rk + dAc_dc = 0._dp + dAj_dc = 0._dp + dAe_dc = 0._dp end if ! smooth Rubisco-limitation and light limitation if(ciDiff > tiny(ciDiff))then call quadSmooth(desireDeriv, xPSN(ixRubi), xPSN(ixLight), theta_cj, dAc_dc, dAj_dc, xsPSN, dAi_dc) else - xsPSN = 0._rk - dAi_dc = 0._rk + xsPSN = 0._dp + dAi_dc = 0._dp end if ! smooth intermediate-limitation and export limitation @@ -942,18 +942,18 @@ subroutine quadResist(desireDeriv,ix_bbHumdFunc,rlb,fHum,gMin,g0,dg0_dc,rs,drs_d ! dummy variables logical(lgt),intent(in) :: desireDeriv ! flag to denote if the derivative is desired integer(i4b),intent(in) :: ix_bbHumdFunc ! option for humidity control on stomatal resistance - real(rk),intent(in) :: rlb ! leaf boundary layer resistance (umol-1 m2 s) - real(rk),intent(in) :: fHum ! scaled humidity function (-) - real(rk),intent(in) :: gMin ! scaled minimum stomatal consuctance (umol m-2 s-1) - real(rk),intent(in) :: g0 ! stomatal conductance in the absence of humidity controls (umol m-2 s-1) - real(rk),intent(in) :: dg0_dc ! derivative in g0 w.r.t intercellular co2 concentration (umol m-2 s-1 Pa-1) - real(rk),intent(out) :: rs ! stomatal resistance ((umol-1 m2 s) - real(rk),intent(out) :: drs_dc ! derivaive in rs w.r.t intercellular co2 concentration (umol-1 m2 s Pa-1) + real(dp),intent(in) :: rlb ! leaf boundary layer resistance (umol-1 m2 s) + real(dp),intent(in) :: fHum ! scaled humidity function (-) + real(dp),intent(in) :: gMin ! scaled minimum stomatal consuctance (umol m-2 s-1) + real(dp),intent(in) :: g0 ! stomatal conductance in the absence of humidity controls (umol m-2 s-1) + real(dp),intent(in) :: dg0_dc ! derivative in g0 w.r.t intercellular co2 concentration (umol m-2 s-1 Pa-1) + real(dp),intent(out) :: rs ! stomatal resistance ((umol-1 m2 s) + real(dp),intent(out) :: drs_dc ! derivaive in rs w.r.t intercellular co2 concentration (umol-1 m2 s Pa-1) ! local variables - real(rk) :: aQuad,bQuad,cQuad ! coefficients in the quadratic function - real(rk) :: bSign,xTemp,qQuad ! q term in the quadratic - real(rk) :: root1,root2 ! roots of the quadratic - real(rk) :: dxT_dc,dqq_dc ! derivatives in the q term + real(dp) :: aQuad,bQuad,cQuad ! coefficients in the quadratic function + real(dp) :: bSign,xTemp,qQuad ! q term in the quadratic + real(dp) :: root1,root2 ! roots of the quadratic + real(dp) :: dxT_dc,dqq_dc ! derivatives in the q term ! define terms for the quadratic function select case(ix_bbHumdFunc) @@ -961,21 +961,21 @@ subroutine quadResist(desireDeriv,ix_bbHumdFunc,rlb,fHum,gMin,g0,dg0_dc,rs,drs_d ! original Ball-Berry case(humidLeafSurface) aQuad = g0*fHum + gMin - bQuad = (g0 + gMin)*rlb - 1._rk + bQuad = (g0 + gMin)*rlb - 1._dp cQuad = -rlb ! Leuning 1995 case(scaledHyperbolic) - aQuad = g0 + gMin*(1._rk + fHum) - bQuad = (g0 + gMin)*rlb - fHum - 1._rk + aQuad = g0 + gMin*(1._dp + fHum) + bQuad = (g0 + gMin)*rlb - fHum - 1._dp cQuad = -rlb end select ! compute the q term in the quadratic bSign = abs(bQuad)/bQuad - xTemp = bQuad*bQuad - 4._rk *aQuad*cQuad - qquad = -0.5_rk * (bQuad + bSign*sqrt(xTemp)) + xTemp = bQuad*bQuad - 4._dp *aQuad*cQuad + qquad = -0.5_dp * (bQuad + bSign*sqrt(xTemp)) ! compute roots root1 = qQuad / aQuad @@ -992,10 +992,10 @@ subroutine quadResist(desireDeriv,ix_bbHumdFunc,rlb,fHum,gMin,g0,dg0_dc,rs,drs_d ! compute derivatives in qquad w.r.t. ci select case(ix_bbHumdFunc) - case(humidLeafSurface); dXt_dc = dg0_dc*(rlb*bQuad*2._rk - fHum*cQuad*4._rk) - case(scaledHyperbolic); dXt_dc = dg0_dc*(rlb*bQuad*2._rk - cQuad*4._rk) + case(humidLeafSurface); dXt_dc = dg0_dc*(rlb*bQuad*2._dp - fHum*cQuad*4._dp) + case(scaledHyperbolic); dXt_dc = dg0_dc*(rlb*bQuad*2._dp - cQuad*4._dp) end select - dqq_dc = -0.5_rk * (rlb*dg0_dc + bSign*dXt_dc*0.5_rk / sqrt(xTemp) ) + dqq_dc = -0.5_dp * (rlb*dg0_dc + bSign*dXt_dc*0.5_dp / sqrt(xTemp) ) ! compute derivatives in rs if(root1 > root2)then @@ -1009,7 +1009,7 @@ subroutine quadResist(desireDeriv,ix_bbHumdFunc,rlb,fHum,gMin,g0,dg0_dc,rs,drs_d ! derivatives not desired else - drs_dc = 0._rk + drs_dc = 0._dp end if end subroutine quadResist @@ -1022,17 +1022,17 @@ subroutine quadSmooth(desireDeriv, x1, x2, xsFac, dx1_dc, dx2_dc, xs, dxs_dc) implicit none ! dummy variables logical(lgt),intent(in) :: desireDeriv ! flag to denote if a derivative is desired - real(rk),intent(in) :: x1,x2 ! variables to be smoothed - real(rk),intent(in) :: xsFac ! smoothing factor - real(rk),intent(in) :: dx1_dc,dx2_dc ! derivatives in variables w.r.t. something important - real(rk),intent(out) :: xs ! smoothed variable - real(rk),intent(out) :: dxs_dc ! derivative w.r.t. something important + real(dp),intent(in) :: x1,x2 ! variables to be smoothed + real(dp),intent(in) :: xsFac ! smoothing factor + real(dp),intent(in) :: dx1_dc,dx2_dc ! derivatives in variables w.r.t. something important + real(dp),intent(out) :: xs ! smoothed variable + real(dp),intent(out) :: dxs_dc ! derivative w.r.t. something important ! local variables - real(rk) :: aQuad,bQuad,cQuad ! coefficients in the quadratic function - real(rk) :: bSign,xTemp,qQuad ! q term in the quadratic - real(rk) :: root1,root2 ! roots of the quadratic - real(rk) :: dbq_dc,dcq_dc ! derivatives in quadratic coefficients - real(rk) :: dxT_dc,dqq_dc ! derivatives in the q term + real(dp) :: aQuad,bQuad,cQuad ! coefficients in the quadratic function + real(dp) :: bSign,xTemp,qQuad ! q term in the quadratic + real(dp) :: root1,root2 ! roots of the quadratic + real(dp) :: dbq_dc,dcq_dc ! derivatives in quadratic coefficients + real(dp) :: dxT_dc,dqq_dc ! derivatives in the q term ! uses the quadratic of the form ! xsFac*xs^2 - (x1 + x2)*xs + x1*x2 = 0 @@ -1045,8 +1045,8 @@ subroutine quadSmooth(desireDeriv, x1, x2, xsFac, dx1_dc, dx2_dc, xs, dxs_dc) ! compute the q term in the quadratic bSign = abs(bQuad)/bQuad - xTemp = bQuad*bQuad - 4._rk *aQuad*cQuad - qquad = -0.5_rk * (bQuad + bSign*sqrt(xTemp)) + xTemp = bQuad*bQuad - 4._dp *aQuad*cQuad + qquad = -0.5_dp * (bQuad + bSign*sqrt(xTemp)) ! compute roots root1 = qQuad / aQuad @@ -1061,8 +1061,8 @@ subroutine quadSmooth(desireDeriv, x1, x2, xsFac, dx1_dc, dx2_dc, xs, dxs_dc) dcq_dc = x1*dx2_dc + x2*dx1_dc ! compute derivatives for xTemp - dxT_dc = 2._rk*(bQuad*dbq_dc) - 4._rk*aQuad*dcq_dc - dqq_dc = -0.5_rk * (dbq_dc + bsign*dxT_dc/(2._rk*sqrt(xTemp))) + dxT_dc = 2._dp*(bQuad*dbq_dc) - 4._dp*aQuad*dcq_dc + dqq_dc = -0.5_dp * (dbq_dc + bsign*dxT_dc/(2._dp*sqrt(xTemp))) ! compute derivatives in the desired root if(root1 < root2)then @@ -1073,7 +1073,7 @@ subroutine quadSmooth(desireDeriv, x1, x2, xsFac, dx1_dc, dx2_dc, xs, dxs_dc) ! derivatives not required else - dxs_dc = 0._rk + dxs_dc = 0._dp end if end subroutine quadSmooth @@ -1086,32 +1086,32 @@ end subroutine quadSmooth ! q10 function for temperature dependence function q10(a,T,Tmid,Tscale) implicit none - real(rk),intent(in) :: a ! scale factor - real(rk),intent(in) :: T ! temperature (K) - real(rk),intent(in) :: Tmid ! point where function is one (25 deg C) - real(rk),intent(in) :: Tscale ! scaling factor (K) - real(rk) :: q10 ! temperature dependence (-) + real(dp),intent(in) :: a ! scale factor + real(dp),intent(in) :: T ! temperature (K) + real(dp),intent(in) :: Tmid ! point where function is one (25 deg C) + real(dp),intent(in) :: Tscale ! scaling factor (K) + real(dp) :: q10 ! temperature dependence (-) q10 = a**((T - Tmid)/Tscale) end function q10 ! Arrhenius function for temperature dependence function fT(delH,T,Tref) implicit none - real(rk),intent(in) :: delH ! activation energy in temperature function (J mol-1) - real(rk),intent(in) :: T ! temperature (K) - real(rk),intent(in) :: Tref ! reference temperature (K) - real(rk) :: fT ! temperature dependence (-) - fT = exp((delH/(Tref*Rgas))*(1._rk - Tref/T)) ! NOTE: Rgas = J K-1 mol-1 + real(dp),intent(in) :: delH ! activation energy in temperature function (J mol-1) + real(dp),intent(in) :: T ! temperature (K) + real(dp),intent(in) :: Tref ! reference temperature (K) + real(dp) :: fT ! temperature dependence (-) + fT = exp((delH/(Tref*Rgas))*(1._dp - Tref/T)) ! NOTE: Rgas = J K-1 mol-1 end function fT ! function for high temperature inhibition function fHigh(delH,delS,T) implicit none - real(rk),intent(in) :: delH ! deactivation energy in high temp inhibition function (J mol-1) - real(rk),intent(in) :: delS ! entropy term in high temp inhibition function (J K-1 mol-1) - real(rk),intent(in) :: T ! temperature (K) - real(rk) :: fHigh ! high temperature inhibition (-) - fHigh = 1._rk + exp( (delS*T - delH)/(Rgas*T) ) ! NOTE: Rgas = J K-1 mol-1 + real(dp),intent(in) :: delH ! deactivation energy in high temp inhibition function (J mol-1) + real(dp),intent(in) :: delS ! entropy term in high temp inhibition function (J K-1 mol-1) + real(dp),intent(in) :: T ! temperature (K) + real(dp) :: fHigh ! high temperature inhibition (-) + fHigh = 1._dp + exp( (delS*T - delH)/(Rgas*T) ) ! NOTE: Rgas = J K-1 mol-1 end function fHigh @@ -1161,34 +1161,34 @@ subroutine stomResist_NoahMP(& integer(i4b),intent(in) :: vegTypeIndex ! vegetation type index integer(i4b),intent(in) :: iLoc, jLoc ! spatial location indices ! input (forcing) - real(rk),intent(in) :: airtemp ! measured air temperature at some height above the surface (K) - real(rk),intent(in) :: airpres ! measured air pressure at some height above the surface (Pa) - real(rk),intent(in) :: scalarO2air ! atmospheric o2 concentration (Pa) - real(rk),intent(in) :: scalarCO2air ! atmospheric co2 concentration (Pa) - real(rk),intent(in),target :: scalarCanopySunlitPAR ! average absorbed par for sunlit leaves (w m-2) - real(rk),intent(in),target :: scalarCanopyShadedPAR ! average absorbed par for shaded leaves (w m-2) + real(dp),intent(in) :: airtemp ! measured air temperature at some height above the surface (K) + real(dp),intent(in) :: airpres ! measured air pressure at some height above the surface (Pa) + real(dp),intent(in) :: scalarO2air ! atmospheric o2 concentration (Pa) + real(dp),intent(in) :: scalarCO2air ! atmospheric co2 concentration (Pa) + real(dp),intent(in),target :: scalarCanopySunlitPAR ! average absorbed par for sunlit leaves (w m-2) + real(dp),intent(in),target :: scalarCanopyShadedPAR ! average absorbed par for shaded leaves (w m-2) ! input (state and diagnostic variables) - real(rk),intent(in) :: scalarGrowingSeasonIndex ! growing season index (0=off, 1=on) - real(rk),intent(in) :: scalarFoliageNitrogenFactor ! foliage nitrogen concentration (1=saturated) - real(rk),intent(in) :: scalarTranspireLim ! weighted average of the soil moiture factor controlling stomatal resistance (-) - real(rk),intent(in) :: scalarLeafResistance ! leaf boundary layer resistance (s m-1) - real(rk),intent(in) :: scalarVegetationTemp ! vegetation temperature (K) - real(rk),intent(in) :: scalarSatVP_VegTemp ! saturation vapor pressure at vegetation temperature (Pa) - real(rk),intent(in) :: scalarVP_CanopyAir ! canopy air vapor pressure (Pa) + real(dp),intent(in) :: scalarGrowingSeasonIndex ! growing season index (0=off, 1=on) + real(dp),intent(in) :: scalarFoliageNitrogenFactor ! foliage nitrogen concentration (1=saturated) + real(dp),intent(in) :: scalarTranspireLim ! weighted average of the soil moiture factor controlling stomatal resistance (-) + real(dp),intent(in) :: scalarLeafResistance ! leaf boundary layer resistance (s m-1) + real(dp),intent(in) :: scalarVegetationTemp ! vegetation temperature (K) + real(dp),intent(in) :: scalarSatVP_VegTemp ! saturation vapor pressure at vegetation temperature (Pa) + real(dp),intent(in) :: scalarVP_CanopyAir ! canopy air vapor pressure (Pa) ! output - real(rk),intent(out) :: scalarStomResistSunlit ! stomatal resistance for sunlit leaves (s m-1) - real(rk),intent(out) :: scalarStomResistShaded ! stomatal resistance for shaded leaves (s m-1) - real(rk),intent(out) :: scalarPhotosynthesisSunlit ! sunlit photosynthesis (umolco2 m-2 s-1) - real(rk),intent(out) :: scalarPhotosynthesisShaded ! sunlit photosynthesis (umolco2 m-2 s-1) + real(dp),intent(out) :: scalarStomResistSunlit ! stomatal resistance for sunlit leaves (s m-1) + real(dp),intent(out) :: scalarStomResistShaded ! stomatal resistance for shaded leaves (s m-1) + real(dp),intent(out) :: scalarPhotosynthesisSunlit ! sunlit photosynthesis (umolco2 m-2 s-1) + real(dp),intent(out) :: scalarPhotosynthesisShaded ! sunlit photosynthesis (umolco2 m-2 s-1) integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! local variables integer(i4b),parameter :: ixSunlit=1 ! named variable for sunlit leaves integer(i4b),parameter :: ixShaded=2 ! named variable for shaded leaves integer(i4b) :: iSunShade ! index for sunlit/shaded leaves - real(rk),pointer :: PAR ! average absorbed PAR for sunlit/shaded leaves (w m-2) - real(rk) :: scalarStomResist ! stomatal resistance for sunlit/shaded leaves (s m-1) - real(rk) :: scalarPhotosynthesis ! photosynthesis for sunlit/shaded leaves (umolco2 m-2 s-1) + real(dp),pointer :: PAR ! average absorbed PAR for sunlit/shaded leaves (w m-2) + real(dp) :: scalarStomResist ! stomatal resistance for sunlit/shaded leaves (s m-1) + real(dp) :: scalarPhotosynthesis ! photosynthesis for sunlit/shaded leaves (umolco2 m-2 s-1) ! initialize error control err=0; message='stomResist_NoahMP/' diff --git a/build/source/engine/summaSolve.f90 b/build/source/engine/summaSolve.f90 index 5b6d23e82..ee4dfc886 100755 --- a/build/source/engine/summaSolve.f90 +++ b/build/source/engine/summaSolve.f90 @@ -136,7 +136,7 @@ subroutine summaSolve(& implicit none ! -------------------------------------------------------------------------------------------------------------------------------- ! input: model control - real(rk),intent(in) :: dt ! length of the time step (seconds) + real(dp),intent(in) :: dt ! length of the time step (seconds) integer(i4b),intent(in) :: iter ! interation index integer(i4b),intent(in) :: nSnow ! number of snow layers integer(i4b),intent(in) :: nSoil ! number of soil layers @@ -149,14 +149,14 @@ subroutine summaSolve(& logical(lgt),intent(in) :: computeVegFlux ! flag to indicate if computing fluxes over vegetation logical(lgt),intent(in) :: scalarSolution ! flag to denote if implementing the scalar solution ! input: state vectors - real(rk),intent(in) :: stateVecTrial(:) ! trial state vector - real(rk),intent(inout) :: xMin,xMax ! brackets of the root - real(rk),intent(in) :: fScale(:) ! function scaling vector - real(rk),intent(in) :: xScale(:) ! "variable" scaling vector, i.e., for state variables - real(rk),intent(in) :: rVec(:) ! NOTE: qp ! residual vector - real(rk),intent(in) :: sMul(:) ! NOTE: qp ! state vector multiplier (used in the residual calculations) - real(rk),intent(inout) :: dMat(:) ! diagonal matrix (excludes flux derivatives) - real(rk),intent(in) :: fOld ! old function evaluation + real(dp),intent(in) :: stateVecTrial(:) ! trial state vector + real(dp),intent(inout) :: xMin,xMax ! brackets of the root + real(dp),intent(in) :: fScale(:) ! function scaling vector + real(dp),intent(in) :: xScale(:) ! "variable" scaling vector, i.e., for state variables + real(qp),intent(in) :: rVec(:) ! NOTE: qp ! residual vector + real(qp),intent(in) :: sMul(:) ! NOTE: qp ! state vector multiplier (used in the residual calculations) + real(dp),intent(inout) :: dMat(:) ! diagonal matrix (excludes flux derivatives) + real(dp),intent(in) :: fOld ! old function evaluation ! input: data structures type(model_options),intent(in) :: model_decisions(:) ! model decisions type(var_i), intent(in) :: type_data ! type of vegetation and soil @@ -172,13 +172,13 @@ subroutine summaSolve(& type(var_dlength),intent(inout) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables ! input-output: baseflow integer(i4b),intent(inout) :: ixSaturation ! index of the lowest saturated layer (NOTE: only computed on the first iteration) - real(rk),intent(inout) :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) + real(dp),intent(inout) :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) ! output: flux and residual vectors - real(rk),intent(out) :: stateVecNew(:) ! new state vector - real(rk),intent(out) :: fluxVecNew(:) ! new flux vector - real(rk),intent(out) :: resSinkNew(:) ! sink terms on the RHS of the flux equation - real(rk),intent(out) :: resVecNew(:) ! NOTE: qp ! new residual vector - real(rk),intent(out) :: fNew ! new function evaluation + real(dp),intent(out) :: stateVecNew(:) ! new state vector + real(dp),intent(out) :: fluxVecNew(:) ! new flux vector + real(dp),intent(out) :: resSinkNew(:) ! sink terms on the RHS of the flux equation + real(qp),intent(out) :: resVecNew(:) ! NOTE: qp ! new residual vector + real(dp),intent(out) :: fNew ! new function evaluation logical(lgt),intent(out) :: converged ! convergence flag ! output: error control integer(i4b),intent(out) :: err ! error code @@ -189,13 +189,13 @@ subroutine summaSolve(& ! Jacobian matrix logical(lgt),parameter :: doNumJacobian=.false. ! flag to compute the numerical Jacobian matrix logical(lgt),parameter :: testBandDiagonal=.false. ! flag to test the band diagonal Jacobian matrix - real(rk) :: nJac(nState,nState) ! numerical Jacobian matrix - real(rk) :: aJac(nLeadDim,nState) ! Jacobian matrix - real(rk) :: aJacScaled(nLeadDim,nState) ! Jacobian matrix (scaled) - real(rk) :: aJacScaledTemp(nLeadDim,nState) ! Jacobian matrix (scaled) -- temporary copy since decomposed in lapack + real(dp) :: nJac(nState,nState) ! numerical Jacobian matrix + real(dp) :: aJac(nLeadDim,nState) ! Jacobian matrix + real(dp) :: aJacScaled(nLeadDim,nState) ! Jacobian matrix (scaled) + real(dp) :: aJacScaledTemp(nLeadDim,nState) ! Jacobian matrix (scaled) -- temporary copy since decomposed in lapack ! solution/step vectors - real(rk),dimension(nState) :: rVecScaled ! residual vector (scaled) - real(rk),dimension(nState) :: newtStepScaled ! full newton step (scaled) + real(dp),dimension(nState) :: rVecScaled ! residual vector (scaled) + real(dp),dimension(nState) :: newtStepScaled ! full newton step (scaled) ! step size refinement logical(lgt) :: doRefine ! flag for step refinement integer(i4b),parameter :: ixLineSearch=1001 ! step refinement = line search @@ -269,7 +269,7 @@ subroutine summaSolve(& ! ------------------------ ! scale the residual vector - rVecScaled(1:nState) = fScale(:)*real(rVec(:), rk) ! NOTE: residual vector is in quadruple precision + rVecScaled(1:nState) = fScale(:)*real(rVec(:), dp) ! NOTE: residual vector is in quadruple precision ! scale matrices call scaleMatrices(ixMatrix,nState,aJac,fScale,xScale,aJacScaled,err,cmessage) @@ -342,36 +342,36 @@ subroutine lineSearchRefinement(doLineSearch,stateVecTrial,newtStepScaled,aJacSc implicit none ! input logical(lgt),intent(in) :: doLineSearch ! flag to do the line search - real(rk),intent(in) :: stateVecTrial(:) ! trial state vector - real(rk),intent(in) :: newtStepScaled(:) ! scaled newton step - real(rk),intent(in) :: aJacScaled(:,:) ! scaled jacobian matrix - real(rk),intent(in) :: rVecScaled(:) ! scaled residual vector - real(rk),intent(in) :: fOld ! old function value + real(dp),intent(in) :: stateVecTrial(:) ! trial state vector + real(dp),intent(in) :: newtStepScaled(:) ! scaled newton step + real(dp),intent(in) :: aJacScaled(:,:) ! scaled jacobian matrix + real(dp),intent(in) :: rVecScaled(:) ! scaled residual vector + real(dp),intent(in) :: fOld ! old function value ! output - real(rk),intent(out) :: stateVecNew(:) ! new state vector - real(rk),intent(out) :: fluxVecNew(:) ! new flux vector - real(rk),intent(out) :: resVecNew(:) ! NOTE: qp ! new residual vector - real(rk),intent(out) :: fNew ! new function evaluation + real(dp),intent(out) :: stateVecNew(:) ! new state vector + real(dp),intent(out) :: fluxVecNew(:) ! new flux vector + real(qp),intent(out) :: resVecNew(:) ! NOTE: qp ! new residual vector + real(dp),intent(out) :: fNew ! new function evaluation logical(lgt),intent(out) :: converged ! convergence flag integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! -------------------------------------------------------------------------------------------------------- ! local character(len=256) :: cmessage ! error message of downwind routine - real(rk) :: gradScaled(nState) ! scaled gradient - real(rk) :: xInc(nState) ! iteration increment (re-scaled to original units of the state vector) + real(dp) :: gradScaled(nState) ! scaled gradient + real(dp) :: xInc(nState) ! iteration increment (re-scaled to original units of the state vector) logical(lgt) :: feasible ! flag to denote the feasibility of the solution integer(i4b) :: iLine ! line search index integer(i4b),parameter :: maxLineSearch=5 ! maximum number of backtracks - real(rk),parameter :: alpha=1.e-4_rk ! check on gradient - real(rk) :: xLambda ! backtrack magnitude - real(rk) :: xLambdaTemp ! temporary backtrack magnitude - real(rk) :: slopeInit ! initial slope - real(rk) :: rhs1,rhs2 ! rhs used to compute the cubic - real(rk) :: aCoef,bCoef ! coefficients in the cubic - real(rk) :: disc ! temporary variable used in cubic - real(rk) :: xLambdaPrev ! previous lambda value (used in the cubic) - real(rk) :: fPrev ! previous function evaluation (used in the cubic) + real(dp),parameter :: alpha=1.e-4_dp ! check on gradient + real(dp) :: xLambda ! backtrack magnitude + real(dp) :: xLambdaTemp ! temporary backtrack magnitude + real(dp) :: slopeInit ! initial slope + real(dp) :: rhs1,rhs2 ! rhs used to compute the cubic + real(dp) :: aCoef,bCoef ! coefficients in the cubic + real(dp) :: disc ! temporary variable used in cubic + real(dp) :: xLambdaPrev ! previous lambda value (used in the cubic) + real(dp) :: fPrev ! previous function evaluation (used in the cubic) ! -------------------------------------------------------------------------------------------------------- ! initialize error control err=0; message='lineSearchRefinement/' @@ -389,7 +389,7 @@ subroutine lineSearchRefinement(doLineSearch,stateVecTrial,newtStepScaled,aJacSc end if ! if computing the line search ! initialize lambda - xLambda=1._rk + xLambda=1._dp ! ***** LINE SEARCH LOOP... lineSearch: do iLine=1,maxLineSearch ! try to refine the function by shrinking the step size @@ -449,8 +449,8 @@ subroutine lineSearchRefinement(doLineSearch,stateVecTrial,newtStepScaled,aJacSc ! first backtrack: use quadratic if(iLine==1)then - xLambdaTemp = -slopeInit / (2._rk*(fNew - fOld - slopeInit) ) - if(xLambdaTemp > 0.5_rk*xLambda) xLambdaTemp = 0.5_rk*xLambda + xLambdaTemp = -slopeInit / (2._dp*(fNew - fOld - slopeInit) ) + if(xLambdaTemp > 0.5_dp*xLambda) xLambdaTemp = 0.5_dp*xLambda ! subsequent backtracks: use cubic else @@ -470,21 +470,21 @@ subroutine lineSearchRefinement(doLineSearch,stateVecTrial,newtStepScaled,aJacSc bCoef = (-xLambdaPrev*rhs1/(xLambda*xLambda) + xLambda*rhs2/(xLambdaPrev*xLambdaPrev)) / (xLambda - xLambdaPrev) ! check if a quadratic - if(aCoef==0._rk)then - xLambdaTemp = -slopeInit/(2._rk*bCoef) + if(aCoef==0._dp)then + xLambdaTemp = -slopeInit/(2._dp*bCoef) ! calculate cubic else - disc = bCoef*bCoef - 3._rk*aCoef*slopeInit - if(disc < 0._rk)then - xLambdaTemp = 0.5_rk*xLambda + disc = bCoef*bCoef - 3._dp*aCoef*slopeInit + if(disc < 0._dp)then + xLambdaTemp = 0.5_dp*xLambda else - xLambdaTemp = (-bCoef + sqrt(disc))/(3._rk*aCoef) + xLambdaTemp = (-bCoef + sqrt(disc))/(3._dp*aCoef) end if end if ! calculating cubic ! constrain to <= 0.5*xLambda - if(xLambdaTemp > 0.5_rk*xLambda) xLambdaTemp=0.5_rk*xLambda + if(xLambdaTemp > 0.5_dp*xLambda) xLambdaTemp=0.5_dp*xLambda end if ! subsequent backtracks @@ -493,7 +493,7 @@ subroutine lineSearchRefinement(doLineSearch,stateVecTrial,newtStepScaled,aJacSc fPrev = fNew ! constrain lambda - xLambda = max(xLambdaTemp, 0.1_rk*xLambda) + xLambda = max(xLambdaTemp, 0.1_dp*xLambda) end do lineSearch ! backtrack loop @@ -510,16 +510,16 @@ subroutine trustRegionRefinement(doTrustRefinement,stateVecTrial,newtStepScaled, implicit none ! input logical(lgt),intent(in) :: doTrustRefinement ! flag to refine using trust regions - real(rk),intent(in) :: stateVecTrial(:) ! trial state vector - real(rk),intent(in) :: newtStepScaled(:) ! scaled newton step - real(rk),intent(in) :: aJacScaled(:,:) ! scaled jacobian matrix - real(rk),intent(in) :: rVecScaled(:) ! scaled residual vector - real(rk),intent(in) :: fOld ! old function value + real(dp),intent(in) :: stateVecTrial(:) ! trial state vector + real(dp),intent(in) :: newtStepScaled(:) ! scaled newton step + real(dp),intent(in) :: aJacScaled(:,:) ! scaled jacobian matrix + real(dp),intent(in) :: rVecScaled(:) ! scaled residual vector + real(dp),intent(in) :: fOld ! old function value ! output - real(rk),intent(out) :: stateVecNew(:) ! new state vector - real(rk),intent(out) :: fluxVecNew(:) ! new flux vector - real(rk),intent(out) :: resVecNew(:) ! NOTE: qp ! new residual vector - real(rk),intent(out) :: fNew ! new function evaluation + real(dp),intent(out) :: stateVecNew(:) ! new state vector + real(dp),intent(out) :: fluxVecNew(:) ! new flux vector + real(qp),intent(out) :: resVecNew(:) ! NOTE: qp ! new residual vector + real(dp),intent(out) :: fNew ! new function evaluation logical(lgt),intent(out) :: converged ! convergence flag integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message @@ -576,31 +576,31 @@ subroutine safeRootfinder(stateVecTrial,rVecscaled,newtStepScaled,stateVecNew,fl USE globalData,only:dNaN ! double precision NaN implicit none ! input - real(rk),intent(in) :: stateVecTrial(:) ! trial state vector - real(rk),intent(in) :: rVecScaled(:) ! scaled residual vector - real(rk),intent(in) :: newtStepScaled(:) ! scaled newton step + real(dp),intent(in) :: stateVecTrial(:) ! trial state vector + real(dp),intent(in) :: rVecScaled(:) ! scaled residual vector + real(dp),intent(in) :: newtStepScaled(:) ! scaled newton step ! output - real(rk),intent(out) :: stateVecNew(:) ! new state vector - real(rk),intent(out) :: fluxVecNew(:) ! new flux vector - real(rk),intent(out) :: resVecNew(:) ! NOTE: qp ! new residual vector - real(rk),intent(out) :: fNew ! new function evaluation + real(dp),intent(out) :: stateVecNew(:) ! new state vector + real(dp),intent(out) :: fluxVecNew(:) ! new flux vector + real(qp),intent(out) :: resVecNew(:) ! NOTE: qp ! new residual vector + real(dp),intent(out) :: fNew ! new function evaluation logical(lgt),intent(out) :: converged ! convergence flag integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! -------------------------------------------------------------------------------------------------------- ! local variables character(len=256) :: cmessage ! error message of downwind routine - real(rk),parameter :: relTolerance=0.005_rk ! force bi-section if trial is slightly larger than (smaller than) xmin (xmax) - real(rk) :: xTolerance ! relTolerance*(xmax-xmin) - real(rk) :: xInc(nState) ! iteration increment (re-scaled to original units of the state vector) - real(rk) :: rVec(nState) ! residual vector (re-scaled to original units of the state equation) + real(dp),parameter :: relTolerance=0.005_dp ! force bi-section if trial is slightly larger than (smaller than) xmin (xmax) + real(dp) :: xTolerance ! relTolerance*(xmax-xmin) + real(dp) :: xInc(nState) ! iteration increment (re-scaled to original units of the state vector) + real(dp) :: rVec(nState) ! residual vector (re-scaled to original units of the state equation) logical(lgt) :: feasible ! feasibility of the solution logical(lgt) :: doBisection ! flag to do the bi-section logical(lgt) :: bracketsDefined ! flag to define if the brackets are defined !integer(i4b) :: iCheck ! check the model state variables (not used) integer(i4b),parameter :: nCheck=100 ! number of times to check the model state variables - real(rk),parameter :: delX=1._rk ! trial increment - !real(rk) :: xIncrement(nState) ! trial increment (not used) + real(dp),parameter :: delX=1._dp ! trial increment + !real(dp) :: xIncrement(nState) ! trial increment (not used) ! -------------------------------------------------------------------------------------------------------- err=0; message='safeRootfinder/' @@ -617,10 +617,10 @@ subroutine safeRootfinder(stateVecTrial,rVecscaled,newtStepScaled,stateVecNew,fl endif ! get the residual vector - rVec = real(rVecScaled, rk)*real(fScale, rk) + rVec = real(rVecScaled, dp)*fScale ! update brackets - if(rVec(1)<0._rk)then + if(rVec(1)<0._dp)then xMin = stateVecTrial(1) else xMax = stateVecTrial(1) @@ -631,7 +631,7 @@ subroutine safeRootfinder(stateVecTrial,rVecscaled,newtStepScaled,stateVecNew,fl ! ***** ! * case 1: the iteration increment is the same sign as the residual vector - if(xInc(1)*rVec(1) > 0._rk)then + if(xInc(1)*rVec(1) > 0._dp)then ! get brackets if they do not exist if( ieee_is_nan(xMin) .or. ieee_is_nan(xMax) )then @@ -640,7 +640,7 @@ subroutine safeRootfinder(stateVecTrial,rVecscaled,newtStepScaled,stateVecNew,fl endif ! use bi-section - stateVecNew(1) = 0.5_rk*(xMin + xMax) + stateVecNew(1) = 0.5_dp*(xMin + xMax) ! ***** ! * case 2: the iteration increment is the correct sign @@ -660,7 +660,7 @@ subroutine safeRootfinder(stateVecTrial,rVecscaled,newtStepScaled,stateVecNew,fl if(bracketsDefined)then xTolerance = relTolerance*(xMax-xMin) doBisection = (stateVecNew(1)xMax-xTolerance) - if(doBisection) stateVecNew(1) = 0.5_rk*(xMin+xMax) + if(doBisection) stateVecNew(1) = 0.5_dp*(xMin+xMax) endif ! evaluate summa @@ -686,17 +686,17 @@ subroutine getBrackets(stateVecTrial,stateVecNew,xMin,xMax,err,message) USE,intrinsic :: ieee_arithmetic,only:ieee_is_nan ! IEEE arithmetic (check NaN) implicit none ! dummies - real(rk),intent(in) :: stateVecTrial(:) ! trial state vector - real(rk),intent(out) :: stateVecNew(:) ! new state vector - real(rk),intent(out) :: xMin,xMax ! constraints + real(dp),intent(in) :: stateVecTrial(:) ! trial state vector + real(dp),intent(out) :: stateVecNew(:) ! new state vector + real(dp),intent(out) :: xMin,xMax ! constraints integer(i4b),intent(inout) :: err ! error code character(*),intent(out) :: message ! error message ! locals integer(i4b) :: iCheck ! check the model state variables integer(i4b),parameter :: nCheck=100 ! number of times to check the model state variables logical(lgt) :: feasible ! feasibility of the solution - real(rk),parameter :: delX=1._rk ! trial increment - real(rk) :: xIncrement(nState) ! trial increment + real(dp),parameter :: delX=1._dp ! trial increment + real(dp) :: xIncrement(nState) ! trial increment ! initialize err=0; message='getBrackets/' @@ -724,7 +724,7 @@ subroutine getBrackets(stateVecTrial,stateVecNew,xMin,xMax,err,message) if(.not.feasible)then; message=trim(message)//'state vector is not feasible'; err=20; return; endif ! update brackets - if(real(resVecNew(1), rk)<0._rk)then + if(real(resVecNew(1), dp)<0._dp)then xMin = stateVecNew(1) else xMax = stateVecNew(1) @@ -754,20 +754,20 @@ end subroutine getBrackets subroutine numJacobian(stateVec,dMat,nJac,err,message) implicit none ! dummies - real(rk),intent(in) :: stateVec(:) ! trial state vector - real(rk),intent(in) :: dMat(:) ! diagonal matrix + real(dp),intent(in) :: stateVec(:) ! trial state vector + real(dp),intent(in) :: dMat(:) ! diagonal matrix ! output - real(rk),intent(out) :: nJac(:,:) ! numerical Jacobian + real(dp),intent(out) :: nJac(:,:) ! numerical Jacobian integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! ---------------------------------------------------------------------------------------------------------- ! local character(len=256) :: cmessage ! error message of downwind routine - real(rk),parameter :: dx=1.e-8_rk ! finite difference increment - real(rk),dimension(nState) :: stateVecPerturbed ! perturbed state vector - real(rk),dimension(nState) :: fluxVecInit,fluxVecJac ! flux vector (mized units) - real(rk),dimension(nState) :: resVecInit,resVecJac ! qp ! residual vector (mixed units) - real(rk) :: func ! function value + real(dp),parameter :: dx=1.e-8_dp ! finite difference increment + real(dp),dimension(nState) :: stateVecPerturbed ! perturbed state vector + real(dp),dimension(nState) :: fluxVecInit,fluxVecJac ! flux vector (mized units) + real(qp),dimension(nState) :: resVecInit,resVecJac ! qp ! residual vector (mixed units) + real(dp) :: func ! function value logical(lgt) :: feasible ! flag to denote the feasibility of the solution integer(i4b) :: iJac ! index of row of the Jacobian matrix integer(i4b),parameter :: ixNumFlux=1001 ! named variable for the flux-based form of the numerical Jacobian @@ -802,7 +802,7 @@ subroutine numJacobian(stateVec,dMat,nJac,err,message) ! compute the row of the Jacobian matrix select case(ixNumType) - case(ixNumRes); nJac(:,iJac) = real(resVecJac - resVecInit, kind(rk) )/dx ! Jacobian based on residuals + case(ixNumRes); nJac(:,iJac) = real(resVecJac - resVecInit, kind(dp) )/dx ! Jacobian based on residuals case(ixNumFlux); nJac(:,iJac) = -dt*(fluxVecJac(:) - fluxVecInit(:))/dx ! Jacobian based on fluxes case default; err=20; message=trim(message)//'Jacobian option not found'; return end select @@ -835,8 +835,8 @@ subroutine testBandMat(check,err,message) integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! local variables - real(rk) :: fullJac(nState,nState) ! full Jacobian matrix - real(rk) :: bandJac(nLeadDim,nState) ! band Jacobian matrix + real(dp) :: fullJac(nState,nState) ! full Jacobian matrix + real(dp) :: bandJac(nLeadDim,nState) ! band Jacobian matrix integer(i4b) :: iState,jState ! indices of the state vector character(LEN=256) :: cmessage ! error message of downwind routine ! initialize error control @@ -873,7 +873,7 @@ subroutine testBandMat(check,err,message) if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! (check for errors) ! initialize band matrix - bandJac(:,:) = 0._rk + bandJac(:,:) = 0._dp ! transfer into the lapack band diagonal structure do iState=1,nState @@ -906,11 +906,11 @@ subroutine eval8summa_wrapper(stateVecNew,fluxVecNew,resVecNew,fNew,feasible,err USE eval8summa_module,only:eval8summa ! simulation of fluxes and residuals given a trial state vector implicit none ! input - real(rk),intent(in) :: stateVecNew(:) ! updated state vector + real(dp),intent(in) :: stateVecNew(:) ! updated state vector ! output - real(rk),intent(out) :: fluxVecNew(:) ! updated flux vector - real(rk),intent(out) :: resVecNew(:) ! NOTE: qp ! updated residual vector - real(rk),intent(out) :: fNew ! new function value + real(dp),intent(out) :: fluxVecNew(:) ! updated flux vector + real(qp),intent(out) :: resVecNew(:) ! NOTE: qp ! updated residual vector + real(dp),intent(out) :: fNew ! new function value logical(lgt),intent(out) :: feasible ! flag to denote the feasibility of the solution integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message @@ -972,20 +972,20 @@ end subroutine eval8summa_wrapper function checkConv(rVec,xInc,xVec) implicit none ! dummies - real(rk),intent(in) :: rVec(:) ! residual vector (mixed units) - real(rk),intent(in) :: xInc(:) ! iteration increment (mixed units) - real(rk),intent(in) :: xVec(:) ! state vector (mixed units) + real(qp),intent(in) :: rVec(:) ! residual vector (mixed units) + real(dp),intent(in) :: xInc(:) ! iteration increment (mixed units) + real(dp),intent(in) :: xVec(:) ! state vector (mixed units) logical(lgt) :: checkConv ! flag to denote convergence ! locals - real(rk),dimension(mSoil) :: psiScale ! scaling factor for matric head - real(rk),parameter :: xSmall=1.e-0_rk ! a small offset - real(rk),parameter :: scalarTighten=0.1_rk ! scaling factor for the scalar solution - real(rk) :: soilWatbalErr ! error in the soil water balance - real(rk) :: canopy_max ! absolute value of the residual in canopy water (kg m-2) - real(rk),dimension(1) :: energy_max ! maximum absolute value of the energy residual (J m-3) - real(rk),dimension(1) :: liquid_max ! maximum absolute value of the volumetric liquid water content residual (-) - real(rk),dimension(1) :: matric_max ! maximum absolute value of the matric head iteration increment (m) - real(rk) :: aquifer_max ! absolute value of the residual in aquifer water (m) + real(dp),dimension(mSoil) :: psiScale ! scaling factor for matric head + real(dp),parameter :: xSmall=1.e-0_dp ! a small offset + real(dp),parameter :: scalarTighten=0.1_dp ! scaling factor for the scalar solution + real(dp) :: soilWatbalErr ! error in the soil water balance + real(dp) :: canopy_max ! absolute value of the residual in canopy water (kg m-2) + real(dp),dimension(1) :: energy_max ! maximum absolute value of the energy residual (J m-3) + real(dp),dimension(1) :: liquid_max ! maximum absolute value of the volumetric liquid water content residual (-) + real(dp),dimension(1) :: matric_max ! maximum absolute value of the matric head iteration increment (m) + real(dp) :: aquifer_max ! absolute value of the residual in aquifer water (m) logical(lgt) :: canopyConv ! flag for canopy water balance convergence logical(lgt) :: watbalConv ! flag for soil water balance convergence logical(lgt) :: liquidConv ! flag for residual convergence @@ -1016,7 +1016,7 @@ function checkConv(rVec,xInc,xVec) ! check convergence based on the canopy water balance if(ixVegHyd/=integerMissing)then - canopy_max = real(abs(rVec(ixVegHyd)), rk)*iden_water + canopy_max = real(abs(rVec(ixVegHyd)), dp)*iden_water canopyConv = (canopy_max < absConvTol_liquid) ! absolute error in canopy water balance (mm) else canopy_max = realMissing @@ -1025,7 +1025,7 @@ function checkConv(rVec,xInc,xVec) ! check convergence based on the residuals for energy (J m-3) if(size(ixNrgOnly)>0)then - energy_max = real(maxval(abs( rVec(ixNrgOnly) )), rk) + energy_max = real(maxval(abs( rVec(ixNrgOnly) )), dp) energyConv = (energy_max(1) < absConvTol_energy) ! (based on the residual) else energy_max = realMissing @@ -1034,7 +1034,7 @@ function checkConv(rVec,xInc,xVec) ! check convergence based on the residuals for volumetric liquid water content (-) if(size(ixHydOnly)>0)then - liquid_max = real(maxval(abs( rVec(ixHydOnly) ) ), rk) + liquid_max = real(maxval(abs( rVec(ixHydOnly) ) ), dp) ! (tighter convergence for the scalar solution) if(scalarSolution)then liquidConv = (liquid_max(1) < absConvTol_liquid*scalarTighten) ! (based on the residual) @@ -1059,7 +1059,7 @@ function checkConv(rVec,xInc,xVec) ! check convergence based on the soil water balance error (m) if(size(ixMatOnly)>0)then - soilWatBalErr = sum( real(rVec(ixMatOnly), rk)*mLayerDepth(nSnow+ixMatricHead) ) + soilWatBalErr = sum( real(rVec(ixMatOnly), dp)*mLayerDepth(nSnow+ixMatricHead) ) watbalConv = (abs(soilWatbalErr) < absConvTol_liquid) ! absolute error in total soil water balance (m) else soilWatbalErr = realMissing @@ -1068,7 +1068,7 @@ function checkConv(rVec,xInc,xVec) ! check convergence based on the aquifer storage if(ixAqWat/=integerMissing)then - aquifer_max = real(abs(rVec(ixAqWat)), rk)*iden_water + aquifer_max = real(abs(rVec(ixAqWat)), dp)*iden_water aquiferConv = (aquifer_max < absConvTol_liquid) ! absolute error in aquifer water balance (mm) else aquifer_max = realMissing @@ -1099,25 +1099,25 @@ subroutine imposeConstraints(stateVecTrial,xInc,err,message) USE soil_utils_module,only:crit_soilT ! compute the critical temperature below which ice exists implicit none ! dummies - real(rk),intent(in) :: stateVecTrial(:) ! trial state vector - real(rk),intent(inout) :: xInc(:) ! iteration increment + real(dp),intent(in) :: stateVecTrial(:) ! trial state vector + real(dp),intent(inout) :: xInc(:) ! iteration increment integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! ----------------------------------------------------------------------------------------------------- ! temporary variables for model constraints - real(rk) :: cInc ! constrained temperature increment (K) -- simplified bi-section - real(rk) :: xIncFactor ! scaling factor for the iteration increment (-) + real(dp) :: cInc ! constrained temperature increment (K) -- simplified bi-section + real(dp) :: xIncFactor ! scaling factor for the iteration increment (-) integer(i4b) :: iMax(1) ! index of maximum temperature - real(rk) :: scalarTemp ! temperature of an individual snow layer (K) - real(rk) :: volFracLiq ! volumetric liquid water content of an individual snow layer (-) + real(dp) :: scalarTemp ! temperature of an individual snow layer (K) + real(dp) :: volFracLiq ! volumetric liquid water content of an individual snow layer (-) logical(lgt),dimension(nSnow) :: drainFlag ! flag to denote when drainage exceeds available capacity logical(lgt),dimension(nSoil) :: crosFlag ! flag to denote temperature crossing from unfrozen to frozen (or vice-versa) logical(lgt) :: crosTempVeg ! flag to denoote where temperature crosses the freezing point - real(rk) :: xPsi00 ! matric head after applying the iteration increment (m) - real(rk) :: TcSoil ! critical point when soil begins to freeze (K) - real(rk) :: critDiff ! temperature difference from critical (K) - real(rk),parameter :: epsT=1.e-7_rk ! small interval above/below critical (K) - real(rk),parameter :: zMaxTempIncrement=1._rk ! maximum temperature increment (K) + real(dp) :: xPsi00 ! matric head after applying the iteration increment (m) + real(dp) :: TcSoil ! critical point when soil begins to freeze (K) + real(dp) :: critDiff ! temperature difference from critical (K) + real(dp),parameter :: epsT=1.e-7_dp ! small interval above/below critical (K) + real(dp),parameter :: zMaxTempIncrement=1._dp ! maximum temperature increment (K) ! indices of model state variables integer(i4b) :: iState ! index of state within a specific variable type integer(i4b) :: ixNrg,ixLiq ! index of energy and mass state variables in full state vector @@ -1180,7 +1180,7 @@ subroutine imposeConstraints(stateVecTrial,xInc,err,message) crosTempVeg = .false. ! initially frozen (T < Tfreeze) - if(critDiff > 0._rk)then + if(critDiff > 0._dp)then if(xInc(ixVegNrg) > critDiff)then crosTempVeg = .true. cInc = critDiff + epsT ! constrained temperature increment (K) @@ -1209,9 +1209,9 @@ subroutine imposeConstraints(stateVecTrial,xInc,err,message) if(ixVegHyd/=integerMissing)then ! check if new value of storage will be negative - if(stateVecTrial(ixVegHyd)+xInc(ixVegHyd) < 0._rk)then + if(stateVecTrial(ixVegHyd)+xInc(ixVegHyd) < 0._dp)then ! scale iteration increment - cInc = -0.5_rk*stateVecTrial(ixVegHyd) ! constrained iteration increment (K) -- simplified bi-section + cInc = -0.5_dp*stateVecTrial(ixVegHyd) ! constrained iteration increment (K) -- simplified bi-section xIncFactor = cInc/xInc(ixVegHyd) ! scaling factor for the iteration increment (-) xInc = xIncFactor*xInc ! new iteration increment end if @@ -1232,7 +1232,7 @@ subroutine imposeConstraints(stateVecTrial,xInc,err,message) iState = ixSnowOnlyNrg(iLayer) if(stateVecTrial(iState) + xInc(iState) > Tfreeze)then ! scale iteration increment - cInc = 0.5_rk*(Tfreeze - stateVecTrial(iState) ) ! constrained temperature increment (K) -- simplified bi-section + cInc = 0.5_dp*(Tfreeze - stateVecTrial(iState) ) ! constrained temperature increment (K) -- simplified bi-section xIncFactor = cInc/xInc(iState) ! scaling factor for the iteration increment (-) xInc = xIncFactor*xInc end if ! if snow temperature > freezing @@ -1271,7 +1271,7 @@ subroutine imposeConstraints(stateVecTrial,xInc,err,message) ! * check that the iteration increment does not exceed volumetric liquid water content if(-xInc(ixSnowOnlyHyd(iLayer)) > volFracLiq)then drainFlag(iLayer) = .true. - xInc(ixSnowOnlyHyd(iLayer)) = -0.5_rk*volFracLiq + xInc(ixSnowOnlyHyd(iLayer)) = -0.5_dp*volFracLiq endif end do ! looping through snow layers @@ -1304,7 +1304,7 @@ subroutine imposeConstraints(stateVecTrial,xInc,err,message) critDiff = TcSoil - stateVecTrial(ixNrg) ! * initially frozen (T < TcSoil) - if(critDiff > 0._rk)then + if(critDiff > 0._dp)then ! (check crossing above zero) if(xInc(ixNrg) > critDiff)then @@ -1334,8 +1334,8 @@ subroutine imposeConstraints(stateVecTrial,xInc,err,message) ixLiq = ixMatOnly(iState) ! - place constraint for matric head - if(xInc(ixLiq) > 1._rk .and. stateVecTrial(ixLiq) > 0._rk)then - xInc(ixLiq) = 1._rk + if(xInc(ixLiq) > 1._dp .and. stateVecTrial(ixLiq) > 0._dp)then + xInc(ixLiq) = 1._dp endif ! if constraining matric head end do ! (loop through soil layers) diff --git a/build/source/engine/sunGeomtry.f90 b/build/source/engine/sunGeomtry.f90 index 0c897dc10..28703ad40 100755 --- a/build/source/engine/sunGeomtry.f90 +++ b/build/source/engine/sunGeomtry.f90 @@ -48,32 +48,32 @@ SUBROUTINE CLRSKY_RAD(MONTH,DAY,HOUR,DT,SLOPE,AZI,LAT,HRI,COSZEN) ! Input variables INTEGER(I4B), INTENT(IN) :: MONTH ! month as mm integer INTEGER(I4B), INTENT(IN) :: DAY ! day of month as dd integer - real(rk), INTENT(IN) :: HOUR ! hour of day as real - real(rk), INTENT(IN) :: DT ! time step in units of hours - real(rk), INTENT(IN) :: SLOPE ! slope of ground surface in degrees - real(rk), INTENT(IN) :: AZI ! aspect (azimuth) of ground surface in degrees - real(rk), INTENT(IN) :: LAT ! latitude in degrees (negative for southern hemisphere) + REAL(DP), INTENT(IN) :: HOUR ! hour of day as real + REAL(DP), INTENT(IN) :: DT ! time step in units of hours + REAL(DP), INTENT(IN) :: SLOPE ! slope of ground surface in degrees + REAL(DP), INTENT(IN) :: AZI ! aspect (azimuth) of ground surface in degrees + REAL(DP), INTENT(IN) :: LAT ! latitude in degrees (negative for southern hemisphere) ! Outputs - real(rk), INTENT(OUT) :: HRI ! average radiation index over time step DT - real(rk), INTENT(OUT) :: COSZEN ! average cosine of the zenith angle over time step DT + REAL(DP), INTENT(OUT) :: HRI ! average radiation index over time step DT + REAL(DP), INTENT(OUT) :: COSZEN ! average cosine of the zenith angle over time step DT ! Internal - real(rk) :: CRAD ! conversion from degrees to radians - real(rk) :: YRAD ! conversion from year to radians - real(rk) :: T ! time from noon in radians - real(rk) :: DELT1 ! time step in radians - real(rk) :: SLOPE1 ! slope of ground surface in radians - real(rk) :: AZI1 ! aspect (azimuth) of ground surface in radians - real(rk) :: LAT1 ! latitude in radians - real(rk) :: FJULIAN ! julian date as real - real(rk) :: D ! solar declination - real(rk) :: LP ! latitude adjusted for non-level surface (= LAT1 for level surface) - real(rk) :: TD ! used to calculate sunrise/set - real(rk) :: TPI ! used to calculate sunrise/set - real(rk) :: TP ! used to calculate sunrise/set - real(rk) :: DDT ! used to calculate sunrise/set(= 0 for level surface) - real(rk) :: T1 ! first time in time step or sunrise - real(rk) :: T2 ! last time in time step or sunset - real(rk) :: AUX ! Auxiliary variable used to check whether the sunset/sunrise time calculation can succeed + REAL(DP) :: CRAD ! conversion from degrees to radians + REAL(DP) :: YRAD ! conversion from year to radians + REAL(DP) :: T ! time from noon in radians + REAL(DP) :: DELT1 ! time step in radians + REAL(DP) :: SLOPE1 ! slope of ground surface in radians + REAL(DP) :: AZI1 ! aspect (azimuth) of ground surface in radians + REAL(DP) :: LAT1 ! latitude in radians + REAL(DP) :: FJULIAN ! julian date as real + REAL(DP) :: D ! solar declination + REAL(DP) :: LP ! latitude adjusted for non-level surface (= LAT1 for level surface) + REAL(DP) :: TD ! used to calculate sunrise/set + REAL(DP) :: TPI ! used to calculate sunrise/set + REAL(DP) :: TP ! used to calculate sunrise/set + REAL(DP) :: DDT ! used to calculate sunrise/set(= 0 for level surface) + REAL(DP) :: T1 ! first time in time step or sunrise + REAL(DP) :: T2 ! last time in time step or sunset + REAL(DP) :: AUX ! Auxiliary variable used to check whether the sunset/sunrise time calculation can succeed ! ---------------------------------------------------------------------------------------- ! CONVERSION FACTORS ! degrees to radians @@ -99,7 +99,7 @@ SUBROUTINE CLRSKY_RAD(MONTH,DAY,HOUR,DT,SLOPE,AZI,LAT,HRI,COSZEN) ! In such cases AUX > 1 or AUX < -1. Fix AUX at (-)1 in those cases, to fix sunrise at 00.00 or 24.00 of the current day (instead of some time before/after the current day) AUX=-TAN(LAT1)*TAN(D) IF(abs(AUX) > 1.) THEN - TD=ACOS(SIGN(1._rk, AUX)) + TD=ACOS(SIGN(1._dp, AUX)) ELSE TD=ACOS(AUX) END IF @@ -140,7 +140,7 @@ SUBROUTINE CLRSKY_RAD(MONTH,DAY,HOUR,DT,SLOPE,AZI,LAT,HRI,COSZEN) ! In such cases AUX > 1 or AUX < -1. Fix AUX at (-)1 in those cases AUX=-TAN(LAT1)*TAN(D) IF(abs(AUX) > 1.) THEN - TD=ACOS(SIGN(1._rk, AUX)) + TD=ACOS(SIGN(1._dp, AUX)) ELSE TD=ACOS(AUX) END IF diff --git a/build/source/engine/systemSolv.f90 b/build/source/engine/systemSolv.f90 index b4a34edf2..aed91981e 100755 --- a/build/source/engine/systemSolv.f90 +++ b/build/source/engine/systemSolv.f90 @@ -98,10 +98,10 @@ module systemSolv_module public::systemSolv ! control parameters -real(rk),parameter :: valueMissing=-9999._rk ! missing value -real(rk),parameter :: verySmall=1.e-12_rk ! a very small number (used to check consistency) -real(rk),parameter :: veryBig=1.e+20_rk ! a very big number -real(rk),parameter :: dx = 1.e-8_rk ! finite difference increment +real(dp),parameter :: valueMissing=-9999._dp ! missing value +real(dp),parameter :: verySmall=1.e-12_dp ! a very small number (used to check consistency) +real(dp),parameter :: veryBig=1.e+20_dp ! a very big number +real(dp),parameter :: dx = 1.e-8_dp ! finite difference increment contains @@ -152,7 +152,7 @@ subroutine systemSolv(& ! * dummy variables ! --------------------------------------------------------------------------------------- ! input: model control - real(rk),intent(in) :: dt ! time step (seconds) + real(dp),intent(in) :: dt ! time step (seconds) integer(i4b),intent(in) :: nState ! total number of state variables logical(lgt),intent(in) :: firstSubStep ! flag to indicate if we are processing the first sub-step logical(lgt),intent(inout) :: firstFluxCall ! flag to define the first flux call @@ -170,12 +170,12 @@ subroutine systemSolv(& type(var_dlength),intent(inout) :: flux_temp ! model fluxes for a local HRU type(var_dlength),intent(in) :: bvar_data ! model variables for the local basin type(model_options),intent(in) :: model_decisions(:) ! model decisions - real(rk),intent(in) :: stateVecInit(:) ! initial state vector (mixed units) + real(dp),intent(in) :: stateVecInit(:) ! initial state vector (mixed units) ! output: model control type(var_dlength),intent(inout) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables integer(i4b),intent(inout) :: ixSaturation ! index of the lowest saturated layer (NOTE: only computed on the first iteration) - real(rk),intent(out) :: untappedMelt(:) ! un-tapped melt energy (J m-3 s-1) - real(rk),intent(out) :: stateVecTrial(:) ! trial state vector (mixed units) + real(dp),intent(out) :: untappedMelt(:) ! un-tapped melt energy (J m-3 s-1) + real(dp),intent(out) :: stateVecTrial(:) ! trial state vector (mixed units) logical(lgt),intent(out) :: reduceCoupledStep ! flag to reduce the length of the coupled step logical(lgt),intent(out) :: tooMuchMelt ! flag to denote that there was too much melt integer(i4b),intent(out) :: niter ! number of iterations taken @@ -193,11 +193,11 @@ subroutine systemSolv(& integer(i4b) :: iState ! index of model state integer(i4b) :: nLeadDim ! length of the leading dimension of the Jacobian matrix (nBands or nState) integer(i4b) :: local_ixGroundwater ! local index for groundwater representation - real(rk) :: bulkDensity ! bulk density of a given layer (kg m-3) - real(rk) :: volEnthalpy ! volumetric enthalpy of a given layer (J m-3) - real(rk),parameter :: tempAccelerate=0.00_rk ! factor to force initial canopy temperatures to be close to air temperature - real(rk),parameter :: xMinCanopyWater=0.0001_rk ! minimum value to initialize canopy water (kg m-2) - real(rk),parameter :: tinyStep=0.000001_rk ! stupidly small time step (s) + real(dp) :: bulkDensity ! bulk density of a given layer (kg m-3) + real(dp) :: volEnthalpy ! volumetric enthalpy of a given layer (J m-3) + real(dp),parameter :: tempAccelerate=0.00_dp ! factor to force initial canopy temperatures to be close to air temperature + real(dp),parameter :: xMinCanopyWater=0.0001_dp ! minimum value to initialize canopy water (kg m-2) + real(dp),parameter :: tinyStep=0.000001_dp ! stupidly small time step (s) ! ------------------------------------------------------------------------------------------------------ ! * model solver ! ------------------------------------------------------------------------------------------------------ @@ -207,22 +207,22 @@ subroutine systemSolv(& integer(i4b) :: localMaxIter ! maximum number of iterations (depends on solution type) integer(i4b), parameter :: scalarMaxIter=100 ! maximum number of iterations for the scalar solution type(var_dlength) :: flux_init ! model fluxes at the start of the time step - real(rk),allocatable :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) ! NOTE: allocatable, since not always needed - real(rk) :: stateVecNew(nState) ! new state vector (mixed units) - real(rk) :: fluxVec0(nState) ! flux vector (mixed units) - real(rk) :: fScale(nState) ! characteristic scale of the function evaluations (mixed units) - real(rk) :: xScale(nState) ! characteristic scale of the state vector (mixed units) - real(rk) :: dMat(nState) ! diagonal matrix (excludes flux derivatives) - real(rk) :: sMul(nState) ! NOTE: qp ! multiplier for state vector for the residual calculations - real(rk) :: rVec(nState) ! NOTE: qp ! residual vector - real(rk) :: rAdd(nState) ! additional terms in the residual vector - real(rk) :: fOld,fNew ! function values (-); NOTE: dimensionless because scaled - real(rk) :: xMin,xMax ! state minimum and maximum (mixed units) + real(dp),allocatable :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) ! NOTE: allocatable, since not always needed + real(dp) :: stateVecNew(nState) ! new state vector (mixed units) + real(dp) :: fluxVec0(nState) ! flux vector (mixed units) + real(dp) :: fScale(nState) ! characteristic scale of the function evaluations (mixed units) + real(dp) :: xScale(nState) ! characteristic scale of the state vector (mixed units) + real(dp) :: dMat(nState) ! diagonal matrix (excludes flux derivatives) + real(qp) :: sMul(nState) ! NOTE: qp ! multiplier for state vector for the residual calculations + real(qp) :: rVec(nState) ! NOTE: qp ! residual vector + real(dp) :: rAdd(nState) ! additional terms in the residual vector + real(dp) :: fOld,fNew ! function values (-); NOTE: dimensionless because scaled + real(dp) :: xMin,xMax ! state minimum and maximum (mixed units) logical(lgt) :: converged ! convergence flag logical(lgt) :: feasible ! feasibility flag - real(rk) :: resSinkNew(nState) ! additional terms in the residual vector - real(rk) :: fluxVecNew(nState) ! new flux vector - real(rk) :: resVecNew(nState) ! NOTE: qp ! new residual vector + real(dp) :: resSinkNew(nState) ! additional terms in the residual vector + real(dp) :: fluxVecNew(nState) ! new flux vector + real(qp) :: resVecNew(nState) ! NOTE: qp ! new residual vector ! --------------------------------------------------------------------------------------- ! point to variables in the data structures ! --------------------------------------------------------------------------------------- @@ -533,13 +533,13 @@ subroutine systemSolv(& ! ------------------ ! set untapped melt energy to zero - untappedMelt(:) = 0._rk + untappedMelt(:) = 0._dp ! update temperatures (ensure new temperature is consistent with the fluxes) if(nSnowSoilNrg>0)then do concurrent (iLayer=1:nLayers,ixSnowSoilNrg(iLayer)/=integerMissing) ! (loop through non-missing energy state variables in the snow+soil domain) iState = ixSnowSoilNrg(iLayer) - stateVecTrial(iState) = stateVecInit(iState) + (fluxVecNew(iState)*dt + resSinkNew(iState))/real(sMul(iState), rk) + stateVecTrial(iState) = stateVecInit(iState) + (fluxVecNew(iState)*dt + resSinkNew(iState))/real(sMul(iState), dp) end do ! looping through non-missing energy state variables in the snow+soil domain endif diff --git a/build/source/engine/tempAdjust.f90 b/build/source/engine/tempAdjust.f90 index 21874d98d..d9dc6dd6c 100755 --- a/build/source/engine/tempAdjust.f90 +++ b/build/source/engine/tempAdjust.f90 @@ -65,7 +65,7 @@ subroutine tempAdjust(& implicit none ! ------------------------------------------------------------------------------------------------ ! input: derived parameters - real(rk),intent(in) :: canopyDepth ! depth of the vegetation canopy (m) + real(dp),intent(in) :: canopyDepth ! depth of the vegetation canopy (m) ! input/output: data structures type(var_dlength),intent(in) :: mpar_data ! model parameters type(var_dlength),intent(inout) :: prog_data ! model prognostic variables for a local HRU @@ -78,13 +78,13 @@ subroutine tempAdjust(& integer(i4b) :: iTry ! trial index integer(i4b) :: iter ! iteration index integer(i4b),parameter :: maxiter=100 ! maximum number of iterations - real(rk) :: fLiq ! fraction of liquid water (-) - real(rk) :: tempMin,tempMax ! solution constraints for temperature (K) - real(rk) :: nrgMeltFreeze ! energy required to melt-freeze the water to the current canopy temperature (J m-3) - real(rk) :: scalarCanopyWat ! total canopy water (kg m-2) - real(rk) :: scalarCanopyIceOld ! canopy ice content after melt-freeze to the initial temperature (kg m-2) - real(rk),parameter :: resNrgToler=0.1_rk ! tolerance for the energy residual (J m-3) - real(rk) :: f1,f2,x1,x2,fTry,xTry,fDer,xInc ! iteration variables + real(dp) :: fLiq ! fraction of liquid water (-) + real(dp) :: tempMin,tempMax ! solution constraints for temperature (K) + real(dp) :: nrgMeltFreeze ! energy required to melt-freeze the water to the current canopy temperature (J m-3) + real(dp) :: scalarCanopyWat ! total canopy water (kg m-2) + real(dp) :: scalarCanopyIceOld ! canopy ice content after melt-freeze to the initial temperature (kg m-2) + real(dp),parameter :: resNrgToler=0.1_dp ! tolerance for the energy residual (J m-3) + real(dp) :: f1,f2,x1,x2,fTry,xTry,fDer,xInc ! iteration variables logical(lgt) :: fBis ! .true. if bisection ! ------------------------------------------------------------------------------------------------------------------------------- ! initialize error control @@ -120,7 +120,7 @@ subroutine tempAdjust(& ! compute the new volumetric ice content ! NOTE: new value; iterations will adjust this value for consistency with temperature - scalarCanopyIceOld = (1._rk - fLiq)*scalarCanopyWat + scalarCanopyIceOld = (1._dp - fLiq)*scalarCanopyWat ! compute volumetric heat capacity of vegetation (J m-3 K-1) scalarBulkVolHeatCapVeg = specificHeatVeg*maxMassVegetation/canopyDepth + & ! vegetation component @@ -146,14 +146,14 @@ subroutine tempAdjust(& !print*, 'f1, f2 = ', f1, f2 ! ensure that we bracket the root - if(f1*f2 > 0._rk)then + if(f1*f2 > 0._dp)then xInc = f1 / fDer - x2 = 1._rk + x2 = 1._dp do iter=1,maxiter ! successively expand limit in order to bracket the root - x2 = x1 + sign(x2,xInc)*2._rk + x2 = x1 + sign(x2,xInc)*2._dp f2 = resNrgFunc(x2,scalarCanopyTemp,scalarBulkVolHeatCapVeg,snowfrz_scale) - if(f1*f2 < 0._rk)exit + if(f1*f2 < 0._dp)exit ! check that we bracketed the root ! (should get here in just a couple of expansions) if(iter==maxiter)then @@ -176,8 +176,8 @@ subroutine tempAdjust(& !print*, 'tempMin, tempMax = ', tempMin, tempMax ! get starting trial - xInc = huge(1._rk) - xTry = 0.5_rk*(x1 + x2) + xInc = huge(1._dp) + xTry = 0.5_dp*(x1 + x2) fTry = resNrgFunc(xTry,scalarCanopyTemp,scalarBulkVolHeatCapVeg,snowfrz_scale) fDer = resNrgDer(xTry,scalarBulkVolHeatCapVeg,snowfrz_scale) !print*, 'xTry = ', xTry @@ -194,7 +194,7 @@ subroutine tempAdjust(& ! bisect if out of range if(xTry <= tempMin .or. xTry >= tempMax)then - xTry = 0.5_rk*(tempMin + tempMax) ! new value + xTry = 0.5_dp*(tempMin + tempMax) ! new value fBis = .true. ! value in range; use the newton step @@ -211,7 +211,7 @@ subroutine tempAdjust(& !print*, 'tempMin, tempMax = ', tempMin, tempMax ! update limits - if(fTry < 0._rk)then + if(fTry < 0._dp)then tempMax = min(xTry,tempMax) else tempMin = max(tempMin,xTry) @@ -232,7 +232,7 @@ subroutine tempAdjust(& if(iter==maxiter)then ! (print out a 1-d x-section) do iTry=1,maxiter - xTry = 1.0_rk*real(iTry,kind(1._rk))/real(maxiter,kind(1._rk)) + 272.5_rk + xTry = 1.0_dp*real(iTry,kind(1._dp))/real(maxiter,kind(1._dp)) + 272.5_dp fTry = resNrgFunc(xTry,scalarCanopyTemp,scalarBulkVolHeatCapVeg,snowfrz_scale) write(*,'(a,1x,i4,1x,e20.10,1x,4(f20.10,1x))') 'iTry, fTry, xTry = ', iTry, fTry, xTry end do @@ -246,7 +246,7 @@ subroutine tempAdjust(& ! update state variables scalarCanopyTemp = xTry - scalarCanopyIce = (1._rk - fracliquid(xTry,snowfrz_scale))*scalarCanopyWat + scalarCanopyIce = (1._dp - fracliquid(xTry,snowfrz_scale))*scalarCanopyWat scalarCanopyLiq = scalarCanopyWat - scalarCanopyIce ! end association to variables in the data structure @@ -261,13 +261,13 @@ subroutine tempAdjust(& function resNrgFunc(xTemp,xTemp0,bulkVolHeatCapVeg,snowfrz_scale) ! implicit none - real(rk),intent(in) :: xTemp ! temperature (K) - real(rk),intent(in) :: xTemp0 ! initial temperature (K) - real(rk),intent(in) :: bulkVolHeatCapVeg ! volumetric heat capacity of veg (J m-3 K-1) - real(rk),intent(in) :: snowfrz_scale ! scaling factor in freezing curve (K-1) - real(rk) :: xIce ! canopy ice content (kg m-2) - real(rk) :: resNrgFunc ! residual in energy (J m-3) - xIce = (1._rk - fracliquid(xTemp,snowfrz_scale))*scalarCanopyWat + real(dp),intent(in) :: xTemp ! temperature (K) + real(dp),intent(in) :: xTemp0 ! initial temperature (K) + real(dp),intent(in) :: bulkVolHeatCapVeg ! volumetric heat capacity of veg (J m-3 K-1) + real(dp),intent(in) :: snowfrz_scale ! scaling factor in freezing curve (K-1) + real(dp) :: xIce ! canopy ice content (kg m-2) + real(dp) :: resNrgFunc ! residual in energy (J m-3) + xIce = (1._dp - fracliquid(xTemp,snowfrz_scale))*scalarCanopyWat resNrgFunc = -bulkVolHeatCapVeg*(xTemp - xTemp0) + LH_fus*(xIce - scalarCanopyIceOld)/canopyDepth + nrgMeltFreeze return end function resNrgFunc @@ -278,11 +278,11 @@ end function resNrgFunc ! ************************************************************************************************ function resNrgDer(xTemp,bulkVolHeatCapVeg,snowfrz_scale) implicit none - real(rk),intent(in) :: xTemp ! temperature (K) - real(rk),intent(in) :: bulkVolHeatCapVeg ! volumetric heat capacity of veg (J m-3 K-1) - real(rk),intent(in) :: snowfrz_scale ! scaling factor in freezing curve (K-1) - real(rk) :: dW_dT ! derivative in canopy ice content w.r.t. temperature (kg m-2 K-1) - real(rk) :: resNrgDer ! derivative (J m-3 K-1) + real(dp),intent(in) :: xTemp ! temperature (K) + real(dp),intent(in) :: bulkVolHeatCapVeg ! volumetric heat capacity of veg (J m-3 K-1) + real(dp),intent(in) :: snowfrz_scale ! scaling factor in freezing curve (K-1) + real(dp) :: dW_dT ! derivative in canopy ice content w.r.t. temperature (kg m-2 K-1) + real(dp) :: resNrgDer ! derivative (J m-3 K-1) dW_dT = -scalarCanopyWat*dFracLiq_dTk(xTemp,snowfrz_scale) resNrgDer = bulkVolHeatCapVeg - dW_dT*LH_fus/canopyDepth return diff --git a/build/source/engine/time_utils.f90 b/build/source/engine/time_utils.f90 index 08bfcccdc..f3a7e2656 100755 --- a/build/source/engine/time_utils.f90 +++ b/build/source/engine/time_utils.f90 @@ -46,9 +46,9 @@ subroutine extractTime(refdate,iyyy,im,id,ih,imin,dsec,ih_tz,imin_tz,dsec_tz,err ! dummy variables character(*),intent(in) :: refdate ! units string (time since...) integer(i4b),intent(out) :: iyyy,im,id,ih,imin ! time (year/month/day/hour/minute) - real(rk),intent(out) :: dsec ! seconds + real(dp),intent(out) :: dsec ! seconds integer(i4b),intent(out) :: ih_tz,imin_tz ! time zone information (hour/minute) - real(rk),intent(out) :: dsec_tz ! time zone information (seconds) + real(dp),intent(out) :: dsec_tz ! time zone information (seconds) integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! local variables @@ -61,7 +61,7 @@ subroutine extractTime(refdate,iyyy,im,id,ih,imin,dsec,ih_tz,imin_tz,dsec_tz,err ! we'll parse each of these in order. ! Missing ih, imin, dsec, ih_tz, imin_tz and dsec_tz fields will be set to zero without causing an error. - ih=0; imin=0; dsec=0._rk; ih_tz=0; imin_tz=0; dsec_tz=0._rk; + ih=0; imin=0; dsec=0._dp; ih_tz=0; imin_tz=0; dsec_tz=0._dp; ! get the length of the string n = len_trim(refdate) @@ -121,8 +121,8 @@ subroutine extractTime(refdate,iyyy,im,id,ih,imin,dsec,ih_tz,imin_tz,dsec_tz,err if(ih > 24) then; err=20; message=trim(message)//'hour > 24'; return; end if if(imin < 0) then; err=20; message=trim(message)//'minute < 0'; return; end if if(imin > 60) then; err=20; message=trim(message)//'minute > 60'; return; end if - if(dsec < 0._rk)then; err=20; message=trim(message)//'second < 0'; return; end if - if(dsec > 60._rk)then; err=20; message=trim(message)//'second > 60'; return; end if + if(dsec < 0._dp)then; err=20; message=trim(message)//'second < 0'; return; end if + if(dsec > 60._dp)then; err=20; message=trim(message)//'second > 60'; return; end if ! FIELD 3: Advance to the ih_tz:imin_tz string istart=nsub+1 @@ -149,8 +149,8 @@ subroutine extractTime(refdate,iyyy,im,id,ih,imin,dsec,ih_tz,imin_tz,dsec_tz,err if(ih_tz > 12) then; err=20; message=trim(message)//'time zone hour > 12'; return; end if if(imin_tz < 0) then; err=20; message=trim(message)//'time zone minute < 0'; return; end if if(imin_tz > 60) then; err=20; message=trim(message)//'time zone minute > 60'; return; end if - if(dsec_tz < 0._rk)then; err=20; message=trim(message)//'time zone second < 0'; return; end if - if(dsec_tz > 60._rk)then; err=20; message=trim(message)//'time zone second > 60'; return; end if + if(dsec_tz < 0._dp)then; err=20; message=trim(message)//'time zone second < 0'; return; end if + if(dsec_tz > 60._dp)then; err=20; message=trim(message)//'time zone second > 60'; return; end if contains @@ -231,7 +231,7 @@ subroutine extract_hms(substring,cdelim,hh,mm,ss,err,message) ! output integer(i4b),intent(out) :: hh ! hour integer(i4b),intent(out) :: mm ! minute - real(rk) ,intent(out) :: ss ! sec + real(dp) ,intent(out) :: ss ! sec integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! local variables @@ -272,16 +272,16 @@ subroutine compjulday(iyyy,mm,id,ih,imin,dsec,& ! input ! input variables integer(i4b),intent(in) :: iyyy,mm,id ! year, month, day integer(i4b),intent(in) :: ih,imin ! hour, minute - real(rk),intent(in) :: dsec ! seconds + real(dp),intent(in) :: dsec ! seconds ! output - real(rk),intent(out) :: juldayss + real(dp),intent(out) :: juldayss integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! local variables integer(i4b) :: julday ! julian day integer(i4b),parameter :: igreg=15+31*(10+12*1582) !IGREG = 588829 integer(i4b) :: ja,jm,jy - real(rk) :: jfrac ! fraction of julian day + real(dp) :: jfrac ! fraction of julian day ! initialize errors err=0; message="juldayss" @@ -306,7 +306,7 @@ subroutine compjulday(iyyy,mm,id,ih,imin,dsec,& ! input jfrac = fracDay(ih, imin, dsec) ! and return the julian day, expressed in fraction of a day - juldayss = real(julday,kind(rk)) + jfrac + juldayss = real(julday,kind(dp)) + jfrac end subroutine compjulday @@ -320,7 +320,7 @@ subroutine compcalday(julday, & !input implicit none ! input variables - real(rk), intent(in) :: julday ! julian day + real(dp), intent(in) :: julday ! julian day ! output varibles integer(i4b), intent(out) :: iyyy ! year @@ -328,7 +328,7 @@ subroutine compcalday(julday, & !input integer(i4b), intent(out) :: id ! day integer(i4b), intent(out) :: ih ! hour integer(i4b), intent(out) :: imin ! minute - real(rk), intent(out) :: dsec ! seconds + real(dp), intent(out) :: dsec ! seconds integer(i4b), intent(out) :: err ! error code character(*), intent(out) :: message ! error message @@ -345,14 +345,14 @@ subroutine compcalday(julday, & !input integer(i4b),parameter :: w = 2 integer(i4b),parameter :: b = 274277 integer(i4b),parameter :: c = -38 - real(rk),parameter :: hr_per_day = 24.0_rk - real(rk),parameter :: min_per_hour = 60.0_rk + real(dp),parameter :: hr_per_day = 24.0_dp + real(dp),parameter :: min_per_hour = 60.0_dp ! local variables integer(i4b) :: f,e,g,h ! various step variables from wikipedia integer(i4b) :: step_1a,step_1b,step_1c,step_1d ! temporary variables for calendar calculations - real(rk) :: frac_day ! fractional day - real(rk) :: remainder ! remainder of modulus operation + real(dp) :: frac_day ! fractional day + real(dp) :: remainder ! remainder of modulus operation ! initialize errors err=0; message="compcalday" @@ -402,7 +402,7 @@ end subroutine compcalday ! *************************************************************************************** function elapsedSec(startTime, endTime) integer(i4b),intent(in) :: startTime(8),endTime(8) ! state time and end time - real(rk) :: elapsedSec ! elapsed time in seconds + real(dp) :: elapsedSec ! elapsed time in seconds ! local variables integer(i4b) :: elapsedDay ! elapsed full days integer(i4b) :: yy ! index of year @@ -411,7 +411,7 @@ function elapsedSec(startTime, endTime) integer(i4b) :: days2(12) = (/31,28,31,30,31,30,31,31,30,31,30,31/) ! calculate the elapsed time smaller than a day - elapsedSec = (endTime(8)-startTime(8))*.001_rk + (endTime(7)-startTime(7)) + (endTime(6)-startTime(6))*secprmin + (endTime(5)-startTime(5))*secprhour + elapsedSec = (endTime(8)-startTime(8))*.001_dp + (endTime(7)-startTime(7)) + (endTime(6)-startTime(6))*secprmin + (endTime(5)-startTime(5))*secprhour ! check if the run is within the same day otherwise calculate how many days if (endTime(1) > startTime(1) .or. endTime(2) > startTime(2) .or. endTime(3) > startTime(3)) then @@ -440,11 +440,11 @@ end function elapsedSec ! *************************************************************************************** function fracDay(ih, imin, dsec) integer(i4b),intent(in) :: ih,imin ! hour, minute - real(rk),intent(in) :: dsec ! seconds - real(rk) :: fracDay ! fraction of a day + real(dp),intent(in) :: dsec ! seconds + real(dp) :: fracDay ! fraction of a day ! local variable - fracDay = (real(ih,kind(rk))*secprhour + real(imin,kind(rk))*secprmin + dsec) / secprday + fracDay = (real(ih,kind(dp))*secprhour + real(imin,kind(dp))*secprmin + dsec) / secprday if(ih < 0) fracDay=-fracDay return end function fracDay diff --git a/build/source/engine/updatState.f90 b/build/source/engine/updatState.f90 index 2a4510d98..d69128152 100755 --- a/build/source/engine/updatState.f90 +++ b/build/source/engine/updatState.f90 @@ -52,13 +52,13 @@ subroutine updateSnow(& USE snow_utils_module,only:fracliquid ! compute volumetric fraction of liquid water implicit none ! input variables - real(rk),intent(in) :: mLayerTemp ! temperature (K) - real(rk),intent(in) :: mLayerTheta ! volume fraction of total water (-) - real(rk),intent(in) :: snowfrz_scale ! scaling parameter for the snow freezing curve (K-1) + real(dp),intent(in) :: mLayerTemp ! temperature (K) + real(dp),intent(in) :: mLayerTheta ! volume fraction of total water (-) + real(dp),intent(in) :: snowfrz_scale ! scaling parameter for the snow freezing curve (K-1) ! output variables - real(rk),intent(out) :: mLayerVolFracLiq ! volumetric fraction of liquid water (-) - real(rk),intent(out) :: mLayerVolFracIce ! volumetric fraction of ice (-) - real(rk),intent(out) :: fLiq ! fraction of liquid water (-) + real(dp),intent(out) :: mLayerVolFracLiq ! volumetric fraction of liquid water (-) + real(dp),intent(out) :: mLayerVolFracIce ! volumetric fraction of ice (-) + real(dp),intent(out) :: fLiq ! fraction of liquid water (-) ! error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message @@ -69,7 +69,7 @@ subroutine updateSnow(& ! compute the volumetric fraction of liquid water and ice (-) fLiq = fracliquid(mLayerTemp,snowfrz_scale) mLayerVolFracLiq = fLiq*mLayerTheta - mLayerVolFracIce = (1._rk - fLiq)*mLayerTheta*(iden_water/iden_ice) + mLayerVolFracIce = (1._dp - fLiq)*mLayerTheta*(iden_water/iden_ice) !print*, 'mLayerTheta - (mLayerVolFracIce*(iden_ice/iden_water) + mLayerVolFracLiq) = ', mLayerTheta - (mLayerVolFracIce*(iden_ice/iden_water) + mLayerVolFracLiq) !write(*,'(a,1x,4(f20.10,1x))') 'in updateSnow: fLiq, mLayerTheta, mLayerVolFracIce = ', & ! fLiq, mLayerTheta, mLayerVolFracIce @@ -99,24 +99,25 @@ subroutine updateSoil(& USE soil_utils_module,only:matricHead ! compute the matric head based on volumetric liquid water content implicit none ! input variables - real(rk),intent(in) :: mLayerTemp ! estimate of temperature (K) - real(rk),intent(in) :: mLayerMatricHead ! matric head (m) - real(rk),intent(in) :: vGn_alpha ! van Genutchen "alpha" parameter - real(rk),intent(in) :: vGn_n ! van Genutchen "n" parameter - real(rk),intent(in) :: theta_sat ! soil porosity (-) - real(rk),intent(in) :: theta_res ! soil residual volumetric water content (-) - real(rk),intent(in) :: vGn_m ! van Genutchen "m" parameter (-) + real(dp),intent(in) :: mLayerTemp ! estimate of temperature (K) + real(dp),intent(in) :: mLayerMatricHead ! matric head (m) + real(dp),intent(in) :: vGn_alpha ! van Genutchen "alpha" parameter + real(dp),intent(in) :: vGn_n ! van Genutchen "n" parameter + real(dp),intent(in) :: theta_sat ! soil porosity (-) + real(dp),intent(in) :: theta_res ! soil residual volumetric water content (-) + real(dp),intent(in) :: vGn_m ! van Genutchen "m" parameter (-) ! output variables - real(rk),intent(out) :: mLayerVolFracWat ! fractional volume of total water (-) - real(rk),intent(out) :: mLayerVolFracLiq ! volumetric fraction of liquid water (-) - real(rk),intent(out) :: mLayerVolFracIce ! volumetric fraction of ice (-) + real(dp),intent(out) :: mLayerVolFracWat ! fractional volume of total water (-) + real(dp),intent(out) :: mLayerVolFracLiq ! volumetric fraction of liquid water (-) + real(dp),intent(out) :: mLayerVolFracIce ! volumetric fraction of ice (-) integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! define local variables - real(rk) :: TcSoil ! critical soil temperature when all water is unfrozen (K) - real(rk) :: xConst ! constant in the freezing curve function (m K-1) - real(rk) :: mLayerPsiLiq ! liquid water matric potential (m) - real(rk),parameter :: tinyVal=epsilon(1._rk) ! used in balance check + real(dp) :: TcSoil ! critical soil temperature when all water is unfrozen (K) + real(dp) :: xConst ! constant in the freezing curve function (m K-1) + real(dp) :: mLayerPsiLiq ! liquid water matric potential (m) + real(dp),parameter :: tinyVal=epsilon(1._dp) ! used in balance check + ! initialize error control err=0; message="updateSoil/" @@ -137,7 +138,7 @@ subroutine updateSoil(& ! compute the critical soil temperature where all water is unfrozen (K) ! (eq 17 in Dall'Amico 2011) - TcSoil = Tfreeze + min(mLayerMatricHead,0._rk)*gravity*Tfreeze/LH_fus ! (NOTE: J = kg m2 s-2, so LH_fus is in units of m2 s-2) + TcSoil = Tfreeze + min(mLayerMatricHead,0._dp)*gravity*Tfreeze/LH_fus ! (NOTE: J = kg m2 s-2, so LH_fus is in units of m2 s-2) ! *** compute volumetric fraction of liquid water and ice for partially frozen soil if(mLayerTemp < TcSoil)then ! (check if soil temperature is less than the critical temperature) @@ -158,7 +159,7 @@ subroutine updateSoil(& ! all water is unfrozen mLayerPsiLiq = mLayerMatricHead mLayerVolFracLiq = mLayerVolFracWat - mLayerVolFracIce = 0._rk + mLayerVolFracIce = 0._dp end if ! (check if soil is partially frozen) diff --git a/build/source/engine/updateVars.f90 b/build/source/engine/updateVars.f90 index 3e1a70c2e..c024f1cd2 100755 --- a/build/source/engine/updateVars.f90 +++ b/build/source/engine/updateVars.f90 @@ -135,17 +135,17 @@ subroutine updateVars(& type(var_dlength),intent(inout) :: diag_data ! diagnostic variables for a local HRU type(var_dlength),intent(inout) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables ! output: variables for the vegetation canopy - real(rk),intent(inout) :: scalarCanopyTempTrial ! trial value of canopy temperature (K) - real(rk),intent(inout) :: scalarCanopyWatTrial ! trial value of canopy total water (kg m-2) - real(rk),intent(inout) :: scalarCanopyLiqTrial ! trial value of canopy liquid water (kg m-2) - real(rk),intent(inout) :: scalarCanopyIceTrial ! trial value of canopy ice content (kg m-2) + real(dp),intent(inout) :: scalarCanopyTempTrial ! trial value of canopy temperature (K) + real(dp),intent(inout) :: scalarCanopyWatTrial ! trial value of canopy total water (kg m-2) + real(dp),intent(inout) :: scalarCanopyLiqTrial ! trial value of canopy liquid water (kg m-2) + real(dp),intent(inout) :: scalarCanopyIceTrial ! trial value of canopy ice content (kg m-2) ! output: variables for the snow-soil domain - real(rk),intent(inout) :: mLayerTempTrial(:) ! trial vector of layer temperature (K) - real(rk),intent(inout) :: mLayerVolFracWatTrial(:) ! trial vector of volumetric total water content (-) - real(rk),intent(inout) :: mLayerVolFracLiqTrial(:) ! trial vector of volumetric liquid water content (-) - real(rk),intent(inout) :: mLayerVolFracIceTrial(:) ! trial vector of volumetric ice water content (-) - real(rk),intent(inout) :: mLayerMatricHeadTrial(:) ! trial vector of total water matric potential (m) - real(rk),intent(inout) :: mLayerMatricHeadLiqTrial(:) ! trial vector of liquid water matric potential (m) + real(dp),intent(inout) :: mLayerTempTrial(:) ! trial vector of layer temperature (K) + real(dp),intent(inout) :: mLayerVolFracWatTrial(:) ! trial vector of volumetric total water content (-) + real(dp),intent(inout) :: mLayerVolFracLiqTrial(:) ! trial vector of volumetric liquid water content (-) + real(dp),intent(inout) :: mLayerVolFracIceTrial(:) ! trial vector of volumetric ice water content (-) + real(dp),intent(inout) :: mLayerMatricHeadTrial(:) ! trial vector of total water matric potential (m) + real(dp),intent(inout) :: mLayerMatricHeadLiqTrial(:) ! trial vector of liquid water matric potential (m) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message @@ -160,29 +160,29 @@ subroutine updateVars(& logical(lgt) :: isCoupled ! .true. if a given variable shared another state variable in the same control volume logical(lgt) :: isNrgState ! .true. if a given variable is an energy state logical(lgt),allocatable :: computedCoupling(:) ! .true. if computed the coupling for a given state variable - real(rk) :: scalarVolFracLiq ! volumetric fraction of liquid water (-) - real(rk) :: scalarVolFracIce ! volumetric fraction of ice (-) - real(rk) :: Tcrit ! critical soil temperature below which ice exists (K) - real(rk) :: xTemp ! temporary temperature (K) - real(rk) :: effSat ! effective saturation (-) - real(rk) :: avPore ! available pore space (-) + real(dp) :: scalarVolFracLiq ! volumetric fraction of liquid water (-) + real(dp) :: scalarVolFracIce ! volumetric fraction of ice (-) + real(dp) :: Tcrit ! critical soil temperature below which ice exists (K) + real(dp) :: xTemp ! temporary temperature (K) + real(dp) :: effSat ! effective saturation (-) + real(dp) :: avPore ! available pore space (-) character(len=256) :: cMessage ! error message of downwind routine logical(lgt),parameter :: printFlag=.false. ! flag to turn on printing ! iterative solution for temperature - real(rk) :: meltNrg ! energy for melt+freeze (J m-3) - real(rk) :: residual ! residual in the energy equation (J m-3) - real(rk) :: derivative ! derivative in the energy equation (J m-3 K-1) - real(rk) :: tempInc ! iteration increment (K) + real(dp) :: meltNrg ! energy for melt+freeze (J m-3) + real(dp) :: residual ! residual in the energy equation (J m-3) + real(dp) :: derivative ! derivative in the energy equation (J m-3 K-1) + real(dp) :: tempInc ! iteration increment (K) integer(i4b) :: iter ! iteration index integer(i4b) :: niter ! number of iterations integer(i4b),parameter :: maxiter=100 ! maximum number of iterations - real(rk),parameter :: nrgConvTol=1.e-4_rk ! convergence tolerance for energy (J m-3) - real(rk),parameter :: tempConvTol=1.e-6_rk ! convergence tolerance for temperature (K) - real(rk) :: critDiff ! temperature difference from critical (K) - real(rk) :: tempMin ! minimum bracket for temperature (K) - real(rk) :: tempMax ! maximum bracket for temperature (K) + real(dp),parameter :: nrgConvTol=1.e-4_dp ! convergence tolerance for energy (J m-3) + real(dp),parameter :: tempConvTol=1.e-6_dp ! convergence tolerance for temperature (K) + real(dp) :: critDiff ! temperature difference from critical (K) + real(dp) :: tempMin ! minimum bracket for temperature (K) + real(dp) :: tempMax ! maximum bracket for temperature (K) logical(lgt) :: bFlag ! flag to denote that iteration increment was constrained using bi-section - real(rk),parameter :: epsT=1.e-7_rk ! small interval above/below critical temperature (K) + real(dp),parameter :: epsT=1.e-7_dp ! small interval above/below critical temperature (K) ! -------------------------------------------------------------------------------------------------------------------------------- ! make association with variables in the data structures associate(& @@ -334,7 +334,7 @@ subroutine updateVars(& select case( ixStateType(ixFullVector) ) ! --> update the total water from the liquid water matric potential case(iname_lmpLayer) - effSat = volFracLiq(mLayerMatricHeadLiqTrial(ixControlIndex),vGn_alpha(ixControlIndex),0._rk,1._rk,vGn_n(ixControlIndex),vGn_m(ixControlIndex)) ! effective saturation + effSat = volFracLiq(mLayerMatricHeadLiqTrial(ixControlIndex),vGn_alpha(ixControlIndex),0._dp,1._dp,vGn_n(ixControlIndex),vGn_m(ixControlIndex)) ! effective saturation avPore = theta_sat(ixControlIndex) - mLayerVolFracIceTrial(iLayer) - theta_res(ixControlIndex) ! available pore space mLayerVolFracLiqTrial(iLayer) = effSat*avPore + theta_res(ixControlIndex) mLayerVolFracWatTrial(iLayer) = mLayerVolFracLiqTrial(iLayer) + mLayerVolFracIceTrial(iLayer) ! no volume expansion @@ -368,8 +368,8 @@ subroutine updateVars(& ! define brackets for the root ! NOTE: start with an enormous range; updated quickly in the iterations - tempMin = xTemp - 10._rk - tempMax = xTemp + 10._rk + tempMin = xTemp - 10._dp + tempMax = xTemp + 10._dp ! get iterations (set to maximum iterations if adjusting the temperature) niter = merge(maxiter, 1, do_adjustTemp) @@ -379,7 +379,7 @@ subroutine updateVars(& ! restrict temperature if(xTemp <= tempMin .or. xTemp >= tempMax)then - xTemp = 0.5_rk*(tempMin + tempMax) ! new value + xTemp = 0.5_dp*(tempMin + tempMax) ! new value bFlag = .true. else bFlag = .false. @@ -394,7 +394,7 @@ subroutine updateVars(& ! NOTE 2: for case "iname_lmpLayer", dVolTot_dPsi0 = dVolLiq_dPsi if(ixDomainType==iname_soil)then select case( ixStateType(ixFullVector) ) - case(iname_lmpLayer); dVolTot_dPsi0(ixControlIndex) = dTheta_dPsi(mLayerMatricHeadLiqTrial(ixControlIndex),vGn_alpha(ixControlIndex),0._rk,1._rk,vGn_n(ixControlIndex),vGn_m(ixControlIndex))*avPore + case(iname_lmpLayer); dVolTot_dPsi0(ixControlIndex) = dTheta_dPsi(mLayerMatricHeadLiqTrial(ixControlIndex),vGn_alpha(ixControlIndex),0._dp,1._dp,vGn_n(ixControlIndex),vGn_m(ixControlIndex))*avPore case default; dVolTot_dPsi0(ixControlIndex) = dTheta_dPsi(mLayerMatricHeadTrial(ixControlIndex),vGn_alpha(ixControlIndex),theta_res(ixControlIndex),theta_sat(ixControlIndex),vGn_n(ixControlIndex),vGn_m(ixControlIndex)) end select endif @@ -412,8 +412,8 @@ subroutine updateVars(& ! --> unfrozen: no dependence of liquid water on temperature else select case(ixDomainType) - case(iname_veg); dTheta_dTkCanopy = 0._rk - case(iname_snow, iname_soil); mLayerdTheta_dTk(iLayer) = 0._rk + case(iname_veg); dTheta_dTkCanopy = 0._dp + case(iname_snow, iname_soil); mLayerdTheta_dTk(iLayer) = 0._dp case default; err=20; message=trim(message)//'expect case to be iname_veg, iname_snow, iname_soil'; return end select ! domain type endif @@ -461,7 +461,7 @@ subroutine updateVars(& ! compute mass of water on the canopy ! NOTE: possibilities for speed-up here scalarCanopyLiqTrial = scalarFracLiqVeg *scalarCanopyWatTrial - scalarCanopyIceTrial = (1._rk - scalarFracLiqVeg)*scalarCanopyWatTrial + scalarCanopyIceTrial = (1._dp - scalarFracLiqVeg)*scalarCanopyWatTrial ! *** snow layers case(iname_snow) @@ -565,7 +565,7 @@ subroutine updateVars(& endif ! update bracket - if(residual < 0._rk)then + if(residual < 0._dp)then tempMax = min(xTemp,tempMax) else tempMin = max(tempMin,xTemp) @@ -583,7 +583,7 @@ subroutine updateVars(& ! add constraints for snow temperature if(ixDomainType==iname_veg .or. ixDomainType==iname_snow)then - if(tempInc > Tcrit - xTemp) tempInc=(Tcrit - xTemp)*0.5_rk ! simple bi-section method + if(tempInc > Tcrit - xTemp) tempInc=(Tcrit - xTemp)*0.5_dp ! simple bi-section method endif ! if the domain is vegetation or snow ! deal with the discontinuity between partially frozen and unfrozen soil @@ -591,7 +591,7 @@ subroutine updateVars(& ! difference from the temperature below which ice exists critDiff = Tcrit - xTemp ! --> initially frozen (T < Tcrit) - if(critDiff > 0._rk)then + if(critDiff > 0._dp)then if(tempInc > critDiff) tempInc = critDiff + epsT ! set iteration increment to slightly above critical temperature ! --> initially unfrozen (T > Tcrit) else @@ -643,8 +643,8 @@ subroutine updateVars(& if(.not.isNrgState .and. .not.isCoupled)then ! derivatives relating liquid water matric potential to total water matric potential and temperature - dPsiLiq_dPsi0(ixControlIndex) = 1._rk ! exact correspondence (psiLiq=psi0) - dPsiLiq_dTemp(ixControlIndex) = 0._rk ! no relationship between liquid water matric potential and temperature + dPsiLiq_dPsi0(ixControlIndex) = 1._dp ! exact correspondence (psiLiq=psi0) + dPsiLiq_dTemp(ixControlIndex) = 0._dp ! no relationship between liquid water matric potential and temperature ! case of energy state or coupled solution else @@ -699,17 +699,17 @@ subroutine xTempSolve(& derivative ) ! intent(out) : derivative (J m-3 K-1) implicit none ! input: constant over iterations - real(rk),intent(in) :: meltNrg ! energy for melt+freeze (J m-3) - real(rk),intent(in) :: heatCap ! volumetric heat capacity (J m-3 K-1) - real(rk),intent(in) :: tempInit ! initial temperature (K) - real(rk),intent(in) :: volFracIceInit ! initial volumetric fraction of ice (-) + real(dp),intent(in) :: meltNrg ! energy for melt+freeze (J m-3) + real(dp),intent(in) :: heatCap ! volumetric heat capacity (J m-3 K-1) + real(dp),intent(in) :: tempInit ! initial temperature (K) + real(dp),intent(in) :: volFracIceInit ! initial volumetric fraction of ice (-) ! input-output: trial values - real(rk),intent(inout) :: xTemp ! trial value for temperature - real(rk),intent(in) :: dLiq_dT ! derivative in liquid water content w.r.t. temperature (K-1) - real(rk),intent(in) :: volFracIceTrial ! trial value for the volumetric fraction of ice (-) + real(dp),intent(inout) :: xTemp ! trial value for temperature + real(dp),intent(in) :: dLiq_dT ! derivative in liquid water content w.r.t. temperature (K-1) + real(dp),intent(in) :: volFracIceTrial ! trial value for the volumetric fraction of ice (-) ! output: residual and derivative - real(rk),intent(out) :: residual ! residual (J m-3) - real(rk),intent(out) :: derivative ! derivative (J m-3 K-1) + real(dp),intent(out) :: residual ! residual (J m-3) + real(dp),intent(out) :: derivative ! derivative (J m-3 K-1) ! subroutine starts here residual = -heatCap*(xTemp - tempInit) + meltNrg*(volFracIceTrial - volFracIceInit) ! J m-3 derivative = heatCap + LH_fus*iden_water*dLiq_dT ! J m-3 K-1 diff --git a/build/source/engine/varSubstep.f90 b/build/source/engine/varSubstep.f90 index 1fa8eb971..f82882d94 100755 --- a/build/source/engine/varSubstep.f90 +++ b/build/source/engine/varSubstep.f90 @@ -73,7 +73,7 @@ module varSubstep_module public::varSubstep ! algorithmic parameters -real(rk),parameter :: verySmall=1.e-6_rk ! used as an additive constant to check if substantial difference among real numbers +real(dp),parameter :: verySmall=1.e-6_dp ! used as an additive constant to check if substantial difference among real numbers contains @@ -130,9 +130,9 @@ subroutine varSubstep(& ! * dummy variables ! --------------------------------------------------------------------------------------- ! input: model control - real(rk),intent(in) :: dt ! time step (seconds) - real(rk),intent(in) :: dtInit ! initial time step (seconds) - real(rk),intent(in) :: dt_min ! minimum time step (seconds) + real(dp),intent(in) :: dt ! time step (seconds) + real(dp),intent(in) :: dtInit ! initial time step (seconds) + real(dp),intent(in) :: dt_min ! minimum time step (seconds) integer(i4b),intent(in) :: nState ! total number of state variables logical(lgt),intent(in) :: doAdjustTemp ! flag to indicate if we adjust the temperature logical(lgt),intent(in) :: firstSubStep ! flag to indicate if we are processing the first sub-step @@ -156,7 +156,7 @@ subroutine varSubstep(& type(var_dlength),intent(in) :: bvar_data ! model variables for the local basin ! output: model control integer(i4b),intent(inout) :: ixSaturation ! index of the lowest saturated layer (NOTE: only computed on the first iteration) - real(rk),intent(out) :: dtMultiplier ! substep multiplier (-) + real(dp),intent(out) :: dtMultiplier ! substep multiplier (-) integer(i4b),intent(out) :: nSubsteps ! number of substeps taken for a given split logical(lgt),intent(out) :: failedMinimumStep ! flag to denote success of substepping for a given split logical(lgt),intent(out) :: reduceCoupledStep ! flag to denote need to reduce the length of the coupled step @@ -174,24 +174,24 @@ subroutine varSubstep(& integer(i4b) :: ixLayer ! index in a given domain integer(i4b), dimension(1) :: ixMin,ixMax ! bounds of a given flux vector ! time stepping - real(rk) :: dtSum ! sum of time from successful steps (seconds) - real(rk) :: dt_wght ! weight given to a given flux calculation - real(rk) :: dtSubstep ! length of a substep (s) + real(dp) :: dtSum ! sum of time from successful steps (seconds) + real(dp) :: dt_wght ! weight given to a given flux calculation + real(dp) :: dtSubstep ! length of a substep (s) ! adaptive sub-stepping for the explicit solution logical(lgt) :: failedSubstep ! flag to denote success of substepping for a given split - real(rk),parameter :: safety=0.85_rk ! safety factor in adaptive sub-stepping - real(rk),parameter :: reduceMin=0.1_rk ! mimimum factor that time step is reduced - real(rk),parameter :: increaseMax=4.0_rk ! maximum factor that time step is increased + real(dp),parameter :: safety=0.85_dp ! safety factor in adaptive sub-stepping + real(dp),parameter :: reduceMin=0.1_dp ! mimimum factor that time step is reduced + real(dp),parameter :: increaseMax=4.0_dp ! maximum factor that time step is increased ! adaptive sub-stepping for the implicit solution integer(i4b) :: niter ! number of iterations taken integer(i4b),parameter :: n_inc=5 ! minimum number of iterations to increase time step integer(i4b),parameter :: n_dec=15 ! maximum number of iterations to decrease time step - real(rk),parameter :: F_inc = 1.25_rk ! factor used to increase time step - real(rk),parameter :: F_dec = 0.90_rk ! factor used to decrease time step + real(dp),parameter :: F_inc = 1.25_dp ! factor used to increase time step + real(dp),parameter :: F_dec = 0.90_dp ! factor used to decrease time step ! state and flux vectors - real(rk) :: untappedMelt(nState) ! un-tapped melt energy (J m-3 s-1) - real(rk) :: stateVecInit(nState) ! initial state vector (mixed units) - real(rk) :: stateVecTrial(nState) ! trial state vector (mixed units) + real(dp) :: untappedMelt(nState) ! un-tapped melt energy (J m-3 s-1) + real(dp) :: stateVecInit(nState) ! initial state vector (mixed units) + real(dp) :: stateVecTrial(nState) ! trial state vector (mixed units) type(var_dlength) :: flux_temp ! temporary model fluxes ! flags logical(lgt) :: firstSplitOper ! flag to indicate if we are processing the first flux call in a splitting operation @@ -199,11 +199,11 @@ subroutine varSubstep(& logical(lgt) :: waterBalanceError ! flag to denote that there is a water balance error logical(lgt) :: nrgFluxModified ! flag to denote that the energy fluxes were modified ! energy fluxes - real(rk) :: sumCanopyEvaporation ! sum of canopy evaporation/condensation (kg m-2 s-1) - real(rk) :: sumLatHeatCanopyEvap ! sum of latent heat flux for evaporation from the canopy to the canopy air space (W m-2) - real(rk) :: sumSenHeatCanopy ! sum of sensible heat flux from the canopy to the canopy air space (W m-2) - real(rk) :: sumSoilCompress - real(rk),allocatable :: sumLayerCompress(:) + real(dp) :: sumCanopyEvaporation ! sum of canopy evaporation/condensation (kg m-2 s-1) + real(dp) :: sumLatHeatCanopyEvap ! sum of latent heat flux for evaporation from the canopy to the canopy air space (W m-2) + real(dp) :: sumSenHeatCanopy ! sum of sensible heat flux from the canopy to the canopy air space (W m-2) + real(dp) :: sumSoilCompress + real(dp),allocatable :: sumLayerCompress(:) ! --------------------------------------------------------------------------------------- ! point to variables in the data structures ! --------------------------------------------------------------------------------------- @@ -255,17 +255,17 @@ subroutine varSubstep(& end do ! initialize the total energy fluxes (modified in updateProg) - sumCanopyEvaporation = 0._rk ! canopy evaporation/condensation (kg m-2 s-1) - sumLatHeatCanopyEvap = 0._rk ! latent heat flux for evaporation from the canopy to the canopy air space (W m-2) - sumSenHeatCanopy = 0._rk ! sensible heat flux from the canopy to the canopy air space (W m-2) - sumSoilCompress = 0._rk ! total soil compression - allocate(sumLayerCompress(nSoil)); sumLayerCompress = 0._rk ! soil compression by layer + sumCanopyEvaporation = 0._dp ! canopy evaporation/condensation (kg m-2 s-1) + sumLatHeatCanopyEvap = 0._dp ! latent heat flux for evaporation from the canopy to the canopy air space (W m-2) + sumSenHeatCanopy = 0._dp ! sensible heat flux from the canopy to the canopy air space (W m-2) + sumSoilCompress = 0._dp ! total soil compression + allocate(sumLayerCompress(nSoil)); sumLayerCompress = 0._dp ! soil compression by layer ! define the first flux call in a splitting operation firstSplitOper = (.not.scalarSolution .or. iStateSplit==1) ! initialize subStep - dtSum = 0._rk ! keep track of the portion of the time step that is completed + dtSum = 0._dp ! keep track of the portion of the time step that is completed nSubsteps = 0 ! loop through substeps @@ -351,7 +351,7 @@ subroutine varSubstep(& ! reduce step based on failure if(failedSubstep)then err=0; message='varSubstep/' ! recover from failed convergence - dtMultiplier = 0.5_rk ! system failure: step halving + dtMultiplier = 0.5_dp ! system failure: step halving else ! ** implicit Euler: adjust step length based on iteration count @@ -360,7 +360,7 @@ subroutine varSubstep(& elseif(niter>n_dec)then dtMultiplier = F_dec else - dtMultiplier = 1._rk + dtMultiplier = 1._dp endif endif ! switch between failure and success @@ -420,7 +420,7 @@ subroutine varSubstep(& ! modify step err=0 ! error recovery - dtSubstep = dtSubstep/2._rk + dtSubstep = dtSubstep/2._dp ! check minimum: fail minimum step if there is an error in the update if(dtSubstep next, remove canopy evaporation -- put the unsatisfied evap into sensible heat canopyBalance1 = canopyBalance1 + scalarCanopyEvaporation*dt - if(canopyBalance1 < 0._rk)then + if(canopyBalance1 < 0._dp)then ! * get superfluous water and energy superflousWat = -canopyBalance1/dt ! kg m-2 s-1 superflousNrg = superflousWat*LH_vap ! W m-2 (J m-2 s-1) ! * update fluxes and states - canopyBalance1 = 0._rk + canopyBalance1 = 0._dp scalarCanopyEvaporation = scalarCanopyEvaporation + superflousWat scalarLatHeatCanopyEvap = scalarLatHeatCanopyEvap + superflousNrg scalarSenHeatCanopy = scalarSenHeatCanopy - superflousNrg @@ -766,9 +766,9 @@ subroutine updateProg(dt,nSnow,nSoil,nLayers,doAdjustTemp,computeVegFlux,untappe ! --> next, remove canopy drainage canopyBalance1 = canopyBalance1 - scalarCanopyLiqDrainage*dt - if(canopyBalance1 < 0._rk)then + if(canopyBalance1 < 0._dp)then superflousWat = -canopyBalance1/dt ! kg m-2 s-1 - canopyBalance1 = 0._rk + canopyBalance1 = 0._dp scalarCanopyLiqDrainage = scalarCanopyLiqDrainage + superflousWat endif @@ -795,7 +795,7 @@ subroutine updateProg(dt,nSnow,nSoil,nLayers,doAdjustTemp,computeVegFlux,untappe !write(*,'(a,1x,f20.10)') 'scalarCanopyEvaporation*dt = ', scalarCanopyEvaporation*dt !write(*,'(a,1x,f20.10)') 'scalarThroughfallRain*dt = ', scalarThroughfallRain*dt !write(*,'(a,1x,f20.10)') 'liqError = ', liqError - if(abs(liqError) > absConvTol_liquid*10._rk)then ! *10 because of precision issues + if(abs(liqError) > absConvTol_liquid*10._dp)then ! *10 because of precision issues waterBalanceError = .true. return endif ! if there is a water balance error @@ -810,7 +810,7 @@ subroutine updateProg(dt,nSnow,nSoil,nLayers,doAdjustTemp,computeVegFlux,untappe baseSink = sum(mLayerBaseflow)*dt ! m s-1 --> m compSink = sum(mLayerCompress(1:nSoil) * mLayerDepth(nSnow+1:nLayers) ) ! dimensionless --> m liqError = soilBalance1 - (soilBalance0 + vertFlux + tranSink - baseSink - compSink) - if(abs(liqError) > absConvTol_liquid*10._rk)then ! *10 because of precision issues + if(abs(liqError) > absConvTol_liquid*10._dp)then ! *10 because of precision issues !write(*,'(a,1x,f20.10)') 'dt = ', dt !write(*,'(a,1x,f20.10)') 'soilBalance0 = ', soilBalance0 !write(*,'(a,1x,f20.10)') 'soilBalance1 = ', soilBalance1 @@ -870,15 +870,15 @@ subroutine updateProg(dt,nSnow,nSoil,nLayers,doAdjustTemp,computeVegFlux,untappe ! *** ice ! --> check if we removed too much water - if(scalarCanopyIceTrial < 0._rk .or. any(mLayerVolFracIceTrial < 0._rk) )then + if(scalarCanopyIceTrial < 0._dp .or. any(mLayerVolFracIceTrial < 0._dp) )then ! ** ! canopy within numerical precision - if(scalarCanopyIceTrial < 0._rk)then + if(scalarCanopyIceTrial < 0._dp)then if(scalarCanopyIceTrial > -verySmall)then scalarCanopyLiqTrial = scalarCanopyLiqTrial - scalarCanopyIceTrial - scalarCanopyIceTrial = 0._rk + scalarCanopyIceTrial = 0._dp ! encountered an inconsistency: spit the dummy else @@ -897,11 +897,11 @@ subroutine updateProg(dt,nSnow,nSoil,nLayers,doAdjustTemp,computeVegFlux,untappe do iState=1,size(mLayerVolFracIceTrial) ! snow layer within numerical precision - if(mLayerVolFracIceTrial(iState) < 0._rk)then + if(mLayerVolFracIceTrial(iState) < 0._dp)then if(mLayerVolFracIceTrial(iState) > -verySmall)then mLayerVolFracLiqTrial(iState) = mLayerVolFracLiqTrial(iState) - mLayerVolFracIceTrial(iState) - mLayerVolFracIceTrial(iState) = 0._rk + mLayerVolFracIceTrial(iState) = 0._dp ! encountered an inconsistency: spit the dummy else @@ -924,15 +924,15 @@ subroutine updateProg(dt,nSnow,nSoil,nLayers,doAdjustTemp,computeVegFlux,untappe ! *** liquid water ! --> check if we removed too much water - if(scalarCanopyLiqTrial < 0._rk .or. any(mLayerVolFracLiqTrial < 0._rk) )then + if(scalarCanopyLiqTrial < 0._dp .or. any(mLayerVolFracLiqTrial < 0._dp) )then ! ** ! canopy within numerical precision - if(scalarCanopyLiqTrial < 0._rk)then + if(scalarCanopyLiqTrial < 0._dp)then if(scalarCanopyLiqTrial > -verySmall)then scalarCanopyIceTrial = scalarCanopyIceTrial - scalarCanopyLiqTrial - scalarCanopyLiqTrial = 0._rk + scalarCanopyLiqTrial = 0._dp ! encountered an inconsistency: spit the dummy else @@ -951,11 +951,11 @@ subroutine updateProg(dt,nSnow,nSoil,nLayers,doAdjustTemp,computeVegFlux,untappe do iState=1,size(mLayerVolFracLiqTrial) ! snow layer within numerical precision - if(mLayerVolFracLiqTrial(iState) < 0._rk)then + if(mLayerVolFracLiqTrial(iState) < 0._dp)then if(mLayerVolFracLiqTrial(iState) > -verySmall)then mLayerVolFracIceTrial(iState) = mLayerVolFracIceTrial(iState) - mLayerVolFracLiqTrial(iState) - mLayerVolFracLiqTrial(iState) = 0._rk + mLayerVolFracLiqTrial(iState) = 0._dp ! encountered an inconsistency: spit the dummy else diff --git a/build/source/engine/var_derive.f90 b/build/source/engine/var_derive.f90 index 921dec335..8227b0407 100755 --- a/build/source/engine/var_derive.f90 +++ b/build/source/engine/var_derive.f90 @@ -117,7 +117,7 @@ subroutine calcHeight(& ! loop through layers do iLayer=1,nLayers ! compute the height at the layer midpoint - mLayerHeight(iLayer) = iLayerHeight(iLayer-1) + mLayerDepth(iLayer)/2._rk + mLayerHeight(iLayer) = iLayerHeight(iLayer-1) + mLayerDepth(iLayer)/2._dp ! compute the height at layer interfaces iLayerHeight(iLayer) = iLayerHeight(iLayer-1) + mLayerDepth(iLayer) end do ! (looping through layers) @@ -149,10 +149,10 @@ subroutine rootDensty(mpar_data,indx_data,prog_data,diag_data,err,message) character(*),intent(out) :: message ! error message ! declare local variables integer(i4b) :: iLayer ! loop through layers - real(rk) :: fracRootLower ! fraction of the rooting depth at the lower interface - real(rk) :: fracRootUpper ! fraction of the rooting depth at the upper interface - real(rk), parameter :: rootTolerance = 0.05_rk ! tolerance for error in doubleExp rooting option - real(rk) :: error ! machine precision error in rooting distribution + real(dp) :: fracRootLower ! fraction of the rooting depth at the lower interface + real(dp) :: fracRootUpper ! fraction of the rooting depth at the upper interface + real(dp), parameter :: rootTolerance = 0.05_dp ! tolerance for error in doubleExp rooting option + real(dp) :: error ! machine precision error in rooting distribution ! initialize error control err=0; message='rootDensty/' @@ -192,16 +192,16 @@ subroutine rootDensty(mpar_data,indx_data,prog_data,diag_data,err,message) if(iLayerHeight(iLayer-1)1._rk) fracRootUpper=1._rk + if(fracRootUpper>1._dp) fracRootUpper=1._dp ! compute the root density mLayerRootDensity(iLayer-nSnow) = fracRootUpper**rootDistExp - fracRootLower**rootDistExp else - mLayerRootDensity(iLayer-nSnow) = 0._rk + mLayerRootDensity(iLayer-nSnow) = 0._dp end if !write(*,'(a,10(f11.5,1x))') 'mLayerRootDensity(iLayer-nSnow), fracRootUpper, fracRootLower = ', & ! mLayerRootDensity(iLayer-nSnow), fracRootUpper, fracRootLower @@ -209,8 +209,8 @@ subroutine rootDensty(mpar_data,indx_data,prog_data,diag_data,err,message) ! ** option 2: double expoential profile of Zeng et al. (JHM 2001) case(doubleExp) ! compute the cumulative fraction of roots at the top and bottom of the layer - fracRootLower = 1._rk - 0.5_rk*(exp(-iLayerHeight(iLayer-1)*rootScaleFactor1) + exp(-iLayerHeight(iLayer-1)*rootScaleFactor2) ) - fracRootUpper = 1._rk - 0.5_rk*(exp(-iLayerHeight(iLayer )*rootScaleFactor1) + exp(-iLayerHeight(iLayer )*rootScaleFactor2) ) + fracRootLower = 1._dp - 0.5_dp*(exp(-iLayerHeight(iLayer-1)*rootScaleFactor1) + exp(-iLayerHeight(iLayer-1)*rootScaleFactor2) ) + fracRootUpper = 1._dp - 0.5_dp*(exp(-iLayerHeight(iLayer )*rootScaleFactor1) + exp(-iLayerHeight(iLayer )*rootScaleFactor2) ) ! compute the root density mLayerRootDensity(iLayer-nSnow) = fracRootUpper - fracRootLower !write(*,'(a,10(f11.5,1x))') 'mLayerRootDensity(iLayer-nSnow), fracRootUpper, fracRootLower = ', & @@ -225,26 +225,26 @@ subroutine rootDensty(mpar_data,indx_data,prog_data,diag_data,err,message) ! check that root density is within some reaosnable version of machine tolerance ! This is the case when root density is greater than 1. Can only happen with powerLaw option. - error = sum(mLayerRootDensity) - 1._rk - if (error > 2._rk*epsilon(rootingDepth)) then + error = sum(mLayerRootDensity) - 1._dp + if (error > 2._dp*epsilon(rootingDepth)) then message=trim(message)//'problem with the root density calaculation' err=20; return else - mLayerRootDensity = mLayerRootDensity - error/real(nSoil,kind(rk)) + mLayerRootDensity = mLayerRootDensity - error/real(nSoil,kind(dp)) end if ! compute fraction of roots in the aquifer - if(sum(mLayerRootDensity) < 1._rk)then - scalarAquiferRootFrac = 1._rk - sum(mLayerRootDensity) + if(sum(mLayerRootDensity) < 1._dp)then + scalarAquiferRootFrac = 1._dp - sum(mLayerRootDensity) else - scalarAquiferRootFrac = 0._rk + scalarAquiferRootFrac = 0._dp end if ! check that roots in the aquifer are appropriate - if ((ixGroundwater /= bigBucket).and.(scalarAquiferRootFrac > 2._rk*epsilon(rootingDepth)))then + if ((ixGroundwater /= bigBucket).and.(scalarAquiferRootFrac > 2._dp*epsilon(rootingDepth)))then if(scalarAquiferRootFrac < rootTolerance) then - mLayerRootDensity = mLayerRootDensity + scalarAquiferRootFrac/real(nSoil, kind(rk)) - scalarAquiferRootFrac = 0._rk + mLayerRootDensity = mLayerRootDensity + scalarAquiferRootFrac/real(nSoil, kind(dp)) + scalarAquiferRootFrac = 0._dp else select case(ixRootProfile) case(powerLaw); message=trim(message)//'roots in the aquifer only allowed for the big bucket gw parameterization: check that rooting depth < soil depth' @@ -274,8 +274,8 @@ subroutine satHydCond(mpar_data,indx_data,prog_data,flux_data,err,message) character(*),intent(out) :: message ! error message ! declare local variables integer(i4b) :: iLayer ! loop through layers - real(rk) :: ifcDepthScaleFactor ! depth scaling factor (layer interfaces) - real(rk) :: midDepthScaleFactor ! depth scaling factor (layer midpoints) + real(dp) :: ifcDepthScaleFactor ! depth scaling factor (layer interfaces) + real(dp) :: midDepthScaleFactor ! depth scaling factor (layer midpoints) ! initialize error control err=0; message='satHydCond/' ! ---------------------------------------------------------------------------------- @@ -315,7 +315,7 @@ subroutine satHydCond(mpar_data,indx_data,prog_data,flux_data,err,message) if(iLayer==nLayers)then iLayerSatHydCond(iLayer-nSnow) = k_soil(nSoil) else - iLayerSatHydCond(iLayer-nSnow) = 0.5_rk * (k_soil(iLayer-nSnow) + k_soil(iLayer+1-nSnow) ) + iLayerSatHydCond(iLayer-nSnow) = 0.5_dp * (k_soil(iLayer-nSnow) + k_soil(iLayer+1-nSnow) ) endif ! - conductivity at layer midpoints mLayerSatHydCond(iLayer-nSnow) = k_soil(iLayer-nSnow) @@ -327,11 +327,11 @@ subroutine satHydCond(mpar_data,indx_data,prog_data,flux_data,err,message) ! - conductivity at layer interfaces ! --> NOTE: Do we need a weighted average based on layer depth for interior layers? - if(compactedDepth/iLayerHeight(nLayers) /= 1._rk) then ! avoid divide by zero - ifcDepthScaleFactor = ( (1._rk - iLayerHeight(iLayer)/iLayerHeight(nLayers))**(zScale_TOPMODEL - 1._rk) ) / & - ( (1._rk - compactedDepth/iLayerHeight(nLayers))**(zScale_TOPMODEL - 1._rk) ) + if(compactedDepth/iLayerHeight(nLayers) /= 1._dp) then ! avoid divide by zero + ifcDepthScaleFactor = ( (1._dp - iLayerHeight(iLayer)/iLayerHeight(nLayers))**(zScale_TOPMODEL - 1._dp) ) / & + ( (1._dp - compactedDepth/iLayerHeight(nLayers))**(zScale_TOPMODEL - 1._dp) ) else - ifcDepthScaleFactor = 1.0_rk + ifcDepthScaleFactor = 1.0_dp endif if(iLayer==nSnow)then iLayerSatHydCond(iLayer-nSnow) = k_soil(1) * ifcDepthScaleFactor @@ -339,14 +339,14 @@ subroutine satHydCond(mpar_data,indx_data,prog_data,flux_data,err,message) if(iLayer==nLayers)then iLayerSatHydCond(iLayer-nSnow) = k_soil(nSoil) * ifcDepthScaleFactor else - iLayerSatHydCond(iLayer-nSnow) = 0.5_rk * (k_soil(iLayer-nSnow) + k_soil(iLayer+1-nSnow) ) * ifcDepthScaleFactor + iLayerSatHydCond(iLayer-nSnow) = 0.5_dp * (k_soil(iLayer-nSnow) + k_soil(iLayer+1-nSnow) ) * ifcDepthScaleFactor endif ! - conductivity at layer midpoints - if(compactedDepth/iLayerHeight(nLayers) /= 1._rk) then ! avoid divide by zero - midDepthScaleFactor = ( (1._rk - mLayerHeight(iLayer)/iLayerHeight(nLayers))**(zScale_TOPMODEL - 1._rk) ) / & - ( (1._rk - compactedDepth/iLayerHeight(nLayers))**(zScale_TOPMODEL - 1._rk) ) + if(compactedDepth/iLayerHeight(nLayers) /= 1._dp) then ! avoid divide by zero + midDepthScaleFactor = ( (1._dp - mLayerHeight(iLayer)/iLayerHeight(nLayers))**(zScale_TOPMODEL - 1._dp) ) / & + ( (1._dp - compactedDepth/iLayerHeight(nLayers))**(zScale_TOPMODEL - 1._dp) ) else - midDepthScaleFactor = 1.0_rk + midDepthScaleFactor = 1.0_dp endif mLayerSatHydCond(iLayer-nSnow) = k_soil(iLayer-nSnow) * midDepthScaleFactor mLayerSatHydCondMP(iLayer-nSnow) = k_macropore(iLayer-nSnow) * midDepthScaleFactor @@ -384,21 +384,21 @@ subroutine fracFuture(bpar_data,bvar_data,err,message) implicit none ! input variables - real(rk),intent(in) :: bpar_data(:) ! vector of basin-average model parameters + real(dp),intent(in) :: bpar_data(:) ! vector of basin-average model parameters ! output variables type(var_dlength),intent(inout) :: bvar_data ! data structure of basin-average model variables integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! internal - real(rk) :: dt ! data time step (s) + real(dp) :: dt ! data time step (s) integer(i4b) :: nTDH ! number of points in the time-delay histogram integer(i4b) :: iFuture ! index in time delay histogram - real(rk) :: aLambda ! scale parameter in the Gamma distribution - real(rk) :: tFuture ! future time (end of step) - real(rk) :: pSave ! cumulative probability at the start of the step - real(rk) :: cumProb ! cumulative probability at the end of the step - real(rk) :: sumFrac ! sum of runoff fractions in all steps - real(rk),parameter :: tolerFrac=0.01_rk ! tolerance for missing fractional runoff by truncating histogram + real(dp) :: aLambda ! scale parameter in the Gamma distribution + real(dp) :: tFuture ! future time (end of step) + real(dp) :: pSave ! cumulative probability at the start of the step + real(dp) :: cumProb ! cumulative probability at the end of the step + real(dp) :: sumFrac ! sum of runoff fractions in all steps + real(dp),parameter :: tolerFrac=0.01_dp ! tolerance for missing fractional runoff by truncating histogram ! initialize error control err=0; message='fracFuture/' ! ---------------------------------------------------------------------------------- @@ -419,22 +419,22 @@ subroutine fracFuture(bpar_data,bvar_data,err,message) nTDH = size(runoffFuture) ! initialize runoffFuture (will be overwritten by initial conditions file values if present) - runoffFuture(1:nTDH) = 0._rk + runoffFuture(1:nTDH) = 0._dp ! select option for sub-grid routing select case(ixRouting) ! ** instantaneous routing case(qInstant) - fractionFuture(1) = 1._rk - fractionFuture(2:nTDH) = 0._rk + fractionFuture(1) = 1._dp + fractionFuture(2:nTDH) = 0._dp ! ** time delay histogram case(timeDelay) ! initialize - pSave = 0._rk ! cumulative probability at the start of the step + pSave = 0._dp ! cumulative probability at the start of the step aLambda = routingGammaShape / routingGammaScale - if(routingGammaShape <= 0._rk .or. aLambda < 0._rk)then + if(routingGammaShape <= 0._dp .or. aLambda < 0._dp)then message=trim(message)//'bad arguments for the Gamma distribution' err=20; return end if @@ -443,19 +443,19 @@ subroutine fracFuture(bpar_data,bvar_data,err,message) ! get weight for a given bin tFuture = real(iFuture, kind(dt))*dt ! future time (end of step) cumProb = gammp(routingGammaShape,aLambda*tFuture) ! cumulative probability at the end of the step - fractionFuture(iFuture) = max(0._rk, cumProb - pSave) ! fraction of runoff in the current step + fractionFuture(iFuture) = max(0._dp, cumProb - pSave) ! fraction of runoff in the current step pSave = cumProb ! save the cumulative probability for use in the next step !write(*,'(a,1x,i4,1x,3(f20.10,1x))') trim(message), iFuture, tFuture, cumProb, fractionFuture(iFuture) ! set remaining bins to zero if(fractionFuture(iFuture) < tiny(dt))then - fractionFuture(iFuture:nTDH) = 0._rk + fractionFuture(iFuture:nTDH) = 0._dp exit end if end do ! (looping through future time steps) ! check that we have enough bins sumFrac = sum(fractionFuture) - if(abs(1._rk - sumFrac) > tolerFrac)then + if(abs(1._dp - sumFrac) > tolerFrac)then write(*,*) 'fraction of basin runoff histogram being accounted for by time delay vector is ', sumFrac write(*,*) 'this is less than allowed by tolerFrac = ', tolerFrac message=trim(message)//'not enough bins for the time delay histogram -- fix hard-coded parameter in globalData.f90' @@ -497,7 +497,7 @@ subroutine v_shortcut(mpar_data,diag_data,err,message) ! ---------------------------------------------------------------------------------- ! compute the van Genutchen "m" parameter - vGn_m = 1._rk - 1._rk/vGn_n + vGn_m = 1._dp - 1._dp/vGn_n end associate end subroutine v_shortcut diff --git a/build/source/engine/vegLiqFlux.f90 b/build/source/engine/vegLiqFlux.f90 index 854f4526c..44fe6f695 100755 --- a/build/source/engine/vegLiqFlux.f90 +++ b/build/source/engine/vegLiqFlux.f90 @@ -67,16 +67,16 @@ subroutine vegLiqFlux(& implicit none ! input logical(lgt),intent(in) :: computeVegFlux ! flag to indicate if we are computing fluxes over vegetation (.false. means veg is buried with snow) - real(rk),intent(in) :: scalarCanopyLiqTrial ! trial mass of liquid water on the vegetation canopy at the current iteration (kg m-2) - real(rk),intent(in) :: scalarRainfall ! rainfall (kg m-2 s-1) + real(dp),intent(in) :: scalarCanopyLiqTrial ! trial mass of liquid water on the vegetation canopy at the current iteration (kg m-2) + real(dp),intent(in) :: scalarRainfall ! rainfall (kg m-2 s-1) ! input-output: data structures type(var_dlength),intent(in) :: mpar_data ! model parameters type(var_dlength),intent(inout) :: diag_data ! model diagnostic variables for the local basin ! output - real(rk),intent(out) :: scalarThroughfallRain ! rain that reaches the ground without ever touching the canopy (kg m-2 s-1) - real(rk),intent(out) :: scalarCanopyLiqDrainage ! drainage of liquid water from the vegetation canopy (kg m-2 s-1) - real(rk),intent(out) :: scalarThroughfallRainDeriv ! derivative in throughfall w.r.t. canopy liquid water (s-1) - real(rk),intent(out) :: scalarCanopyLiqDrainageDeriv ! derivative in canopy drainage w.r.t. canopy liquid water (s-1) + real(dp),intent(out) :: scalarThroughfallRain ! rain that reaches the ground without ever touching the canopy (kg m-2 s-1) + real(dp),intent(out) :: scalarCanopyLiqDrainage ! drainage of liquid water from the vegetation canopy (kg m-2 s-1) + real(dp),intent(out) :: scalarThroughfallRainDeriv ! derivative in throughfall w.r.t. canopy liquid water (s-1) + real(dp),intent(out) :: scalarCanopyLiqDrainageDeriv ! derivative in canopy drainage w.r.t. canopy liquid water (s-1) integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! ------------------------------------------------------------------------------------------------------------------------------------------------------ @@ -94,9 +94,9 @@ subroutine vegLiqFlux(& ! set throughfall to inputs if vegetation is completely buried with snow if(.not.computeVegFlux)then scalarThroughfallRain = scalarRainfall - scalarCanopyLiqDrainage = 0._rk - scalarThroughfallRainDeriv = 0._rk - scalarCanopyLiqDrainageDeriv = 0._rk + scalarCanopyLiqDrainage = 0._dp + scalarThroughfallRainDeriv = 0._dp + scalarCanopyLiqDrainageDeriv = 0._dp return end if @@ -106,13 +106,13 @@ subroutine vegLiqFlux(& ! original model (no flexibility in canopy interception): 100% of rainfall is intercepted by the vegetation canopy ! NOTE: this could be done with scalarThroughfallScaleRain=0, though requires setting scalarThroughfallScaleRain in all test cases case(unDefined) - scalarThroughfallRain = 0._rk - scalarThroughfallRainDeriv = 0._rk + scalarThroughfallRain = 0._dp + scalarThroughfallRainDeriv = 0._dp ! fraction of rainfall hits the ground without ever touching the canopy case(sparseCanopy) scalarThroughfallRain = scalarThroughfallScaleRain*scalarRainfall - scalarThroughfallRainDeriv = 0._rk + scalarThroughfallRainDeriv = 0._dp ! throughfall a function of canopy storage case(storageFunc) @@ -125,7 +125,7 @@ subroutine vegLiqFlux(& ! all rain falls through the canopy when the canopy is at capacity else scalarThroughfallRain = scalarRainfall - scalarThroughfallRainDeriv = 0._rk + scalarThroughfallRainDeriv = 0._dp end if case default; err=20; message=trim(message)//'unable to identify option for canopy interception'; return @@ -137,8 +137,8 @@ subroutine vegLiqFlux(& scalarCanopyLiqDrainage = scalarCanopyDrainageCoeff*(scalarCanopyLiqTrial - scalarCanopyLiqMax) scalarCanopyLiqDrainageDeriv = scalarCanopyDrainageCoeff else - scalarCanopyLiqDrainage = 0._rk - scalarCanopyLiqDrainageDeriv = 0._rk + scalarCanopyLiqDrainage = 0._dp + scalarCanopyLiqDrainageDeriv = 0._dp end if !write(*,'(a,1x,f25.15)') 'scalarCanopyLiqDrainage = ', scalarCanopyLiqDrainage diff --git a/build/source/engine/vegNrgFlux.f90 b/build/source/engine/vegNrgFlux.f90 index 933429c8f..47bfba9a9 100755 --- a/build/source/engine/vegNrgFlux.f90 +++ b/build/source/engine/vegNrgFlux.f90 @@ -114,11 +114,11 @@ module vegNrgFlux_module integer(i4b),parameter :: iLoc = 1 ! i-location integer(i4b),parameter :: jLoc = 1 ! j-location ! algorithmic parameters -real(rk),parameter :: missingValue=-9999._rk ! missing value, used when diagnostic or state variables are undefined -real(rk),parameter :: verySmall=1.e-6_rk ! used as an additive constant to check if substantial difference among real numbers -real(rk),parameter :: tinyVal=epsilon(1._rk) ! used as an additive constant to check if substantial difference among real numbers -real(rk),parameter :: mpe=1.e-6_rk ! prevents overflow error if division by zero -real(rk),parameter :: dx=1.e-11_rk ! finite difference increment +real(dp),parameter :: missingValue=-9999._dp ! missing value, used when diagnostic or state variables are undefined +real(dp),parameter :: verySmall=1.e-6_dp ! used as an additive constant to check if substantial difference among real numbers +real(dp),parameter :: tinyVal=epsilon(1._dp) ! used as an additive constant to check if substantial difference among real numbers +real(dp),parameter :: mpe=1.e-6_dp ! prevents overflow error if division by zero +real(dp),parameter :: dx=1.e-11_dp ! finite difference increment ! control logical(lgt) :: printflag ! flag to turn on printing contains @@ -213,15 +213,15 @@ subroutine vegNrgFlux(& logical(lgt),intent(in) :: computeVegFlux ! flag to indicate if computing fluxes over vegetation ! input: model state variables - real(rk),intent(in) :: upperBoundTemp ! temperature of the upper boundary (K) --> NOTE: use air temperature - real(rk),intent(in) :: canairTempTrial ! trial value of canopy air space temperature (K) - real(rk),intent(in) :: canopyTempTrial ! trial value of canopy temperature (K) - real(rk),intent(in) :: groundTempTrial ! trial value of ground temperature (K) - real(rk),intent(in) :: canopyIceTrial ! trial value of mass of ice on the vegetation canopy (kg m-2) - real(rk),intent(in) :: canopyLiqTrial ! trial value of mass of liquid water on the vegetation canopy (kg m-2) + real(dp),intent(in) :: upperBoundTemp ! temperature of the upper boundary (K) --> NOTE: use air temperature + real(dp),intent(in) :: canairTempTrial ! trial value of canopy air space temperature (K) + real(dp),intent(in) :: canopyTempTrial ! trial value of canopy temperature (K) + real(dp),intent(in) :: groundTempTrial ! trial value of ground temperature (K) + real(dp),intent(in) :: canopyIceTrial ! trial value of mass of ice on the vegetation canopy (kg m-2) + real(dp),intent(in) :: canopyLiqTrial ! trial value of mass of liquid water on the vegetation canopy (kg m-2) ! input: model derivatives - real(rk),intent(in) :: dCanLiq_dTcanopy ! intent(in): derivative in canopy liquid w.r.t. canopy temperature (kg m-2 K-1) + real(dp),intent(in) :: dCanLiq_dTcanopy ! intent(in): derivative in canopy liquid w.r.t. canopy temperature (kg m-2 K-1) ! input/output: data structures type(var_i),intent(in) :: type_data ! type of vegetation and soil @@ -235,41 +235,41 @@ subroutine vegNrgFlux(& type(model_options),intent(in) :: model_decisions(:) ! model decisions ! output: liquid water fluxes associated with evaporation/transpiration (needed for coupling) - real(rk),intent(out) :: returnCanopyTranspiration ! canopy transpiration (kg m-2 s-1) - real(rk),intent(out) :: returnCanopyEvaporation ! canopy evaporation/condensation (kg m-2 s-1) - real(rk),intent(out) :: returnGroundEvaporation ! ground evaporation/condensation -- below canopy or non-vegetated (kg m-2 s-1) + real(dp),intent(out) :: returnCanopyTranspiration ! canopy transpiration (kg m-2 s-1) + real(dp),intent(out) :: returnCanopyEvaporation ! canopy evaporation/condensation (kg m-2 s-1) + real(dp),intent(out) :: returnGroundEvaporation ! ground evaporation/condensation -- below canopy or non-vegetated (kg m-2 s-1) ! output: fluxes - real(rk),intent(out) :: canairNetFlux ! net energy flux for the canopy air space (W m-2) - real(rk),intent(out) :: canopyNetFlux ! net energy flux for the vegetation canopy (W m-2) - real(rk),intent(out) :: groundNetFlux ! net energy flux for the ground surface (W m-2) + real(dp),intent(out) :: canairNetFlux ! net energy flux for the canopy air space (W m-2) + real(dp),intent(out) :: canopyNetFlux ! net energy flux for the vegetation canopy (W m-2) + real(dp),intent(out) :: groundNetFlux ! net energy flux for the ground surface (W m-2) ! output: energy flux derivatives - real(rk),intent(out) :: dCanairNetFlux_dCanairTemp ! derivative in net canopy air space flux w.r.t. canopy air temperature (W m-2 K-1) - real(rk),intent(out) :: dCanairNetFlux_dCanopyTemp ! derivative in net canopy air space flux w.r.t. canopy temperature (W m-2 K-1) - real(rk),intent(out) :: dCanairNetFlux_dGroundTemp ! derivative in net canopy air space flux w.r.t. ground temperature (W m-2 K-1) - real(rk),intent(out) :: dCanopyNetFlux_dCanairTemp ! derivative in net canopy flux w.r.t. canopy air temperature (W m-2 K-1) - real(rk),intent(out) :: dCanopyNetFlux_dCanopyTemp ! derivative in net canopy flux w.r.t. canopy temperature (W m-2 K-1) - real(rk),intent(out) :: dCanopyNetFlux_dGroundTemp ! derivative in net canopy flux w.r.t. ground temperature (W m-2 K-1) - real(rk),intent(out) :: dGroundNetFlux_dCanairTemp ! derivative in net ground flux w.r.t. canopy air temperature (W m-2 K-1) - real(rk),intent(out) :: dGroundNetFlux_dCanopyTemp ! derivative in net ground flux w.r.t. canopy temperature (W m-2 K-1) - real(rk),intent(out) :: dGroundNetFlux_dGroundTemp ! derivative in net ground flux w.r.t. ground temperature (W m-2 K-1) + real(dp),intent(out) :: dCanairNetFlux_dCanairTemp ! derivative in net canopy air space flux w.r.t. canopy air temperature (W m-2 K-1) + real(dp),intent(out) :: dCanairNetFlux_dCanopyTemp ! derivative in net canopy air space flux w.r.t. canopy temperature (W m-2 K-1) + real(dp),intent(out) :: dCanairNetFlux_dGroundTemp ! derivative in net canopy air space flux w.r.t. ground temperature (W m-2 K-1) + real(dp),intent(out) :: dCanopyNetFlux_dCanairTemp ! derivative in net canopy flux w.r.t. canopy air temperature (W m-2 K-1) + real(dp),intent(out) :: dCanopyNetFlux_dCanopyTemp ! derivative in net canopy flux w.r.t. canopy temperature (W m-2 K-1) + real(dp),intent(out) :: dCanopyNetFlux_dGroundTemp ! derivative in net canopy flux w.r.t. ground temperature (W m-2 K-1) + real(dp),intent(out) :: dGroundNetFlux_dCanairTemp ! derivative in net ground flux w.r.t. canopy air temperature (W m-2 K-1) + real(dp),intent(out) :: dGroundNetFlux_dCanopyTemp ! derivative in net ground flux w.r.t. canopy temperature (W m-2 K-1) + real(dp),intent(out) :: dGroundNetFlux_dGroundTemp ! derivative in net ground flux w.r.t. ground temperature (W m-2 K-1) ! output: liquid flux derivatives (canopy evap) - real(rk),intent(out) :: dCanopyEvaporation_dCanLiq ! derivative in canopy evaporation w.r.t. canopy liquid water content (s-1) - real(rk),intent(out) :: dCanopyEvaporation_dTCanair ! derivative in canopy evaporation w.r.t. canopy air temperature (kg m-2 s-1 K-1) - real(rk),intent(out) :: dCanopyEvaporation_dTCanopy ! derivative in canopy evaporation w.r.t. canopy temperature (kg m-2 s-1 K-1) - real(rk),intent(out) :: dCanopyEvaporation_dTGround ! derivative in canopy evaporation w.r.t. ground temperature (kg m-2 s-1 K-1) + real(dp),intent(out) :: dCanopyEvaporation_dCanLiq ! derivative in canopy evaporation w.r.t. canopy liquid water content (s-1) + real(dp),intent(out) :: dCanopyEvaporation_dTCanair ! derivative in canopy evaporation w.r.t. canopy air temperature (kg m-2 s-1 K-1) + real(dp),intent(out) :: dCanopyEvaporation_dTCanopy ! derivative in canopy evaporation w.r.t. canopy temperature (kg m-2 s-1 K-1) + real(dp),intent(out) :: dCanopyEvaporation_dTGround ! derivative in canopy evaporation w.r.t. ground temperature (kg m-2 s-1 K-1) ! output: liquid flux derivatives (ground evap) - real(rk),intent(out) :: dGroundEvaporation_dCanLiq ! derivative in ground evaporation w.r.t. canopy liquid water content (s-1) - real(rk),intent(out) :: dGroundEvaporation_dTCanair ! derivative in ground evaporation w.r.t. canopy air temperature (kg m-2 s-1 K-1) - real(rk),intent(out) :: dGroundEvaporation_dTCanopy ! derivative in ground evaporation w.r.t. canopy temperature (kg m-2 s-1 K-1) - real(rk),intent(out) :: dGroundEvaporation_dTGround ! derivative in ground evaporation w.r.t. ground temperature (kg m-2 s-1 K-1) + real(dp),intent(out) :: dGroundEvaporation_dCanLiq ! derivative in ground evaporation w.r.t. canopy liquid water content (s-1) + real(dp),intent(out) :: dGroundEvaporation_dTCanair ! derivative in ground evaporation w.r.t. canopy air temperature (kg m-2 s-1 K-1) + real(dp),intent(out) :: dGroundEvaporation_dTCanopy ! derivative in ground evaporation w.r.t. canopy temperature (kg m-2 s-1 K-1) + real(dp),intent(out) :: dGroundEvaporation_dTGround ! derivative in ground evaporation w.r.t. ground temperature (kg m-2 s-1 K-1) ! output: cross derivative terms - real(rk),intent(out) :: dCanopyNetFlux_dCanLiq ! derivative in net canopy fluxes w.r.t. canopy liquid water content (J kg-1 s-1) - real(rk),intent(out) :: dGroundNetFlux_dCanLiq ! derivative in net ground fluxes w.r.t. canopy liquid water content (J kg-1 s-1) + real(dp),intent(out) :: dCanopyNetFlux_dCanLiq ! derivative in net canopy fluxes w.r.t. canopy liquid water content (J kg-1 s-1) + real(dp),intent(out) :: dGroundNetFlux_dCanLiq ! derivative in net ground fluxes w.r.t. canopy liquid water content (J kg-1 s-1) ! output: error control integer(i4b),intent(out) :: err ! error code @@ -280,10 +280,10 @@ subroutine vegNrgFlux(& ! --------------------------------------------------------------------------------------- ! local (general) character(LEN=256) :: cmessage ! error message of downwind routine - real(rk) :: VAI ! vegetation area index (m2 m-2) - real(rk) :: exposedVAI ! exposed vegetation area index (m2 m-2) - real(rk) :: totalCanopyWater ! total water on the vegetation canopy (kg m-2) - real(rk) :: scalarAquiferStorage ! aquifer storage (m) + real(dp) :: VAI ! vegetation area index (m2 m-2) + real(dp) :: exposedVAI ! exposed vegetation area index (m2 m-2) + real(dp) :: totalCanopyWater ! total water on the vegetation canopy (kg m-2) + real(dp) :: scalarAquiferStorage ! aquifer storage (m) ! local (compute numerical derivatives) integer(i4b),parameter :: unperturbed=1 ! named variable to identify the case of unperturbed state variables @@ -293,135 +293,135 @@ subroutine vegNrgFlux(& integer(i4b),parameter :: perturbStateCanLiq=5 ! named variable to identify the case where we perturb the canopy liquid water content integer(i4b) :: itry ! index of flux evaluation integer(i4b) :: nFlux ! number of flux evaluations - real(rk) :: groundTemp ! value of ground temperature used in flux calculations (may be perturbed) - real(rk) :: canopyTemp ! value of canopy temperature used in flux calculations (may be perturbed) - real(rk) :: canairTemp ! value of canopy air temperature used in flux calculations (may be perturbed) - real(rk) :: try0,try1 ! trial values to evaluate specific derivatives (testing only) + real(dp) :: groundTemp ! value of ground temperature used in flux calculations (may be perturbed) + real(dp) :: canopyTemp ! value of canopy temperature used in flux calculations (may be perturbed) + real(dp) :: canairTemp ! value of canopy air temperature used in flux calculations (may be perturbed) + real(dp) :: try0,try1 ! trial values to evaluate specific derivatives (testing only) ! local (saturation vapor pressure of veg) - real(rk) :: TV_celcius ! vegetaion temperature (C) - real(rk) :: TG_celcius ! ground temperature (C) - real(rk) :: dSVPCanopy_dCanopyTemp ! derivative in canopy saturated vapor pressure w.r.t. vegetation temperature (Pa/K) - real(rk) :: dSVPGround_dGroundTemp ! derivative in ground saturated vapor pressure w.r.t. ground temperature (Pa/K) + real(dp) :: TV_celcius ! vegetaion temperature (C) + real(dp) :: TG_celcius ! ground temperature (C) + real(dp) :: dSVPCanopy_dCanopyTemp ! derivative in canopy saturated vapor pressure w.r.t. vegetation temperature (Pa/K) + real(dp) :: dSVPGround_dGroundTemp ! derivative in ground saturated vapor pressure w.r.t. ground temperature (Pa/K) ! local (wetted canopy area) - real(rk) :: fracLiquidCanopy ! fraction of liquid water in the canopy (-) - real(rk) :: canopyWetFraction ! trial value of the canopy wetted fraction (-) - real(rk) :: dCanopyWetFraction_dWat ! derivative in wetted fraction w.r.t. canopy total water (kg-1 m2) - real(rk) :: dCanopyWetFraction_dT ! derivative in wetted fraction w.r.t. canopy temperature (K-1) + real(dp) :: fracLiquidCanopy ! fraction of liquid water in the canopy (-) + real(dp) :: canopyWetFraction ! trial value of the canopy wetted fraction (-) + real(dp) :: dCanopyWetFraction_dWat ! derivative in wetted fraction w.r.t. canopy total water (kg-1 m2) + real(dp) :: dCanopyWetFraction_dT ! derivative in wetted fraction w.r.t. canopy temperature (K-1) ! local (longwave radiation) - real(rk) :: expi ! exponential integral - real(rk) :: scaleLAI ! scaled LAI (computing diffuse transmissivity) - real(rk) :: diffuseTrans ! diffuse transmissivity (-) - real(rk) :: groundEmissivity ! emissivity of the ground surface (-) - real(rk),parameter :: vegEmissivity=0.98_rk ! emissivity of vegetation (0.9665 in JULES) (-) - real(rk),parameter :: soilEmissivity=0.98_rk ! emmisivity of the soil (0.9665 in JULES) (-) - real(rk),parameter :: snowEmissivity=0.99_rk ! emissivity of snow (-) - real(rk) :: dLWNetCanopy_dTCanopy ! derivative in net canopy radiation w.r.t. canopy temperature (W m-2 K-1) - real(rk) :: dLWNetGround_dTGround ! derivative in net ground radiation w.r.t. ground temperature (W m-2 K-1) - real(rk) :: dLWNetCanopy_dTGround ! derivative in net canopy radiation w.r.t. ground temperature (W m-2 K-1) - real(rk) :: dLWNetGround_dTCanopy ! derivative in net ground radiation w.r.t. canopy temperature (W m-2 K-1) + real(dp) :: expi ! exponential integral + real(dp) :: scaleLAI ! scaled LAI (computing diffuse transmissivity) + real(dp) :: diffuseTrans ! diffuse transmissivity (-) + real(dp) :: groundEmissivity ! emissivity of the ground surface (-) + real(dp),parameter :: vegEmissivity=0.98_dp ! emissivity of vegetation (0.9665 in JULES) (-) + real(dp),parameter :: soilEmissivity=0.98_dp ! emmisivity of the soil (0.9665 in JULES) (-) + real(dp),parameter :: snowEmissivity=0.99_dp ! emissivity of snow (-) + real(dp) :: dLWNetCanopy_dTCanopy ! derivative in net canopy radiation w.r.t. canopy temperature (W m-2 K-1) + real(dp) :: dLWNetGround_dTGround ! derivative in net ground radiation w.r.t. ground temperature (W m-2 K-1) + real(dp) :: dLWNetCanopy_dTGround ! derivative in net canopy radiation w.r.t. ground temperature (W m-2 K-1) + real(dp) :: dLWNetGround_dTCanopy ! derivative in net ground radiation w.r.t. canopy temperature (W m-2 K-1) ! local (aerodynamic resistance) - real(rk) :: scalarCanopyStabilityCorrection_old ! stability correction for the canopy (-) - real(rk) :: scalarGroundStabilityCorrection_old ! stability correction for the ground surface (-) + real(dp) :: scalarCanopyStabilityCorrection_old ! stability correction for the canopy (-) + real(dp) :: scalarGroundStabilityCorrection_old ! stability correction for the ground surface (-) ! local (turbulent heat transfer) - real(rk) :: z0Ground ! roughness length of the ground (ground below the canopy or non-vegetated surface) (m) - real(rk) :: soilEvapFactor ! soil water control on evaporation from non-vegetated surfaces - real(rk) :: soilRelHumidity_noSnow ! relative humidity in the soil pores [0-1] - real(rk) :: scalarLeafConductance ! leaf conductance (m s-1) - real(rk) :: scalarCanopyConductance ! canopy conductance (m s-1) - real(rk) :: scalarGroundConductanceSH ! ground conductance for sensible heat (m s-1) - real(rk) :: scalarGroundConductanceLH ! ground conductance for latent heat -- includes soil resistance (m s-1) - real(rk) :: scalarEvapConductance ! conductance for evaporation (m s-1) - real(rk) :: scalarTransConductance ! conductance for transpiration (m s-1) - real(rk) :: scalarTotalConductanceSH ! total conductance for sensible heat (m s-1) - real(rk) :: scalarTotalConductanceLH ! total conductance for latent heat (m s-1) - real(rk) :: dGroundResistance_dTGround ! derivative in ground resistance w.r.t. ground temperature (s m-1 K-1) - real(rk) :: dGroundResistance_dTCanopy ! derivative in ground resistance w.r.t. canopy temperature (s m-1 K-1) - real(rk) :: dGroundResistance_dTCanair ! derivative in ground resistance w.r.t. canopy air temperature (s m-1 K-1) - real(rk) :: dCanopyResistance_dTCanopy ! derivative in canopy resistance w.r.t. canopy temperature (s m-1 K-1) - real(rk) :: dCanopyResistance_dTCanair ! derivative in canopy resistance w.r.t. canopy air temperature (s m-1 K-1) - real(rk) :: turbFluxCanair ! total turbulent heat fluxes exchanged at the canopy air space (W m-2) - real(rk) :: turbFluxCanopy ! total turbulent heat fluxes from the canopy to the canopy air space (W m-2) - real(rk) :: turbFluxGround ! total turbulent heat fluxes from the ground to the canopy air space (W m-2) + real(dp) :: z0Ground ! roughness length of the ground (ground below the canopy or non-vegetated surface) (m) + real(dp) :: soilEvapFactor ! soil water control on evaporation from non-vegetated surfaces + real(dp) :: soilRelHumidity_noSnow ! relative humidity in the soil pores [0-1] + real(dp) :: scalarLeafConductance ! leaf conductance (m s-1) + real(dp) :: scalarCanopyConductance ! canopy conductance (m s-1) + real(dp) :: scalarGroundConductanceSH ! ground conductance for sensible heat (m s-1) + real(dp) :: scalarGroundConductanceLH ! ground conductance for latent heat -- includes soil resistance (m s-1) + real(dp) :: scalarEvapConductance ! conductance for evaporation (m s-1) + real(dp) :: scalarTransConductance ! conductance for transpiration (m s-1) + real(dp) :: scalarTotalConductanceSH ! total conductance for sensible heat (m s-1) + real(dp) :: scalarTotalConductanceLH ! total conductance for latent heat (m s-1) + real(dp) :: dGroundResistance_dTGround ! derivative in ground resistance w.r.t. ground temperature (s m-1 K-1) + real(dp) :: dGroundResistance_dTCanopy ! derivative in ground resistance w.r.t. canopy temperature (s m-1 K-1) + real(dp) :: dGroundResistance_dTCanair ! derivative in ground resistance w.r.t. canopy air temperature (s m-1 K-1) + real(dp) :: dCanopyResistance_dTCanopy ! derivative in canopy resistance w.r.t. canopy temperature (s m-1 K-1) + real(dp) :: dCanopyResistance_dTCanair ! derivative in canopy resistance w.r.t. canopy air temperature (s m-1 K-1) + real(dp) :: turbFluxCanair ! total turbulent heat fluxes exchanged at the canopy air space (W m-2) + real(dp) :: turbFluxCanopy ! total turbulent heat fluxes from the canopy to the canopy air space (W m-2) + real(dp) :: turbFluxGround ! total turbulent heat fluxes from the ground to the canopy air space (W m-2) ! local (turbulent heat transfer -- compute numerical derivatives) ! (temporary scalar resistances when states are perturbed) - real(rk) :: trialLeafResistance ! mean leaf boundary layer resistance per unit leaf area (s m-1) - real(rk) :: trialGroundResistance ! below canopy aerodynamic resistance (s m-1) - real(rk) :: trialCanopyResistance ! above canopy aerodynamic resistance (s m-1) - real(rk) :: notUsed_RiBulkCanopy ! bulk Richardson number for the canopy (-) - real(rk) :: notUsed_RiBulkGround ! bulk Richardson number for the ground surface (-) - real(rk) :: notUsed_z0Canopy ! roughness length of the vegetation canopy (m) - real(rk) :: notUsed_WindReductionFactor ! canopy wind reduction factor (-) - real(rk) :: notUsed_ZeroPlaneDisplacement ! zero plane displacement (m) - real(rk) :: notUsed_scalarCanopyStabilityCorrection ! stability correction for the canopy (-) - real(rk) :: notUsed_scalarGroundStabilityCorrection ! stability correction for the ground surface (-) - real(rk) :: notUsed_EddyDiffusCanopyTop ! eddy diffusivity for heat at the top of the canopy (m2 s-1) - real(rk) :: notUsed_FrictionVelocity ! friction velocity (m s-1) - real(rk) :: notUsed_WindspdCanopyTop ! windspeed at the top of the canopy (m s-1) - real(rk) :: notUsed_WindspdCanopyBottom ! windspeed at the height of the bottom of the canopy (m s-1) - real(rk) :: notUsed_dGroundResistance_dTGround ! derivative in ground resistance w.r.t. ground temperature (s m-1 K-1) - real(rk) :: notUsed_dGroundResistance_dTCanopy ! derivative in ground resistance w.r.t. canopy temperature (s m-1 K-1) - real(rk) :: notUsed_dGroundResistance_dTCanair ! derivative in ground resistance w.r.t. canopy air temperature (s m-1 K-1) - real(rk) :: notUsed_dCanopyResistance_dTCanopy ! derivative in canopy resistance w.r.t. canopy temperature (s m-1 K-1) - real(rk) :: notUsed_dCanopyResistance_dTCanair ! derivative in canopy resistance w.r.t. canopy air temperature (s m-1 K-1) + real(dp) :: trialLeafResistance ! mean leaf boundary layer resistance per unit leaf area (s m-1) + real(dp) :: trialGroundResistance ! below canopy aerodynamic resistance (s m-1) + real(dp) :: trialCanopyResistance ! above canopy aerodynamic resistance (s m-1) + real(dp) :: notUsed_RiBulkCanopy ! bulk Richardson number for the canopy (-) + real(dp) :: notUsed_RiBulkGround ! bulk Richardson number for the ground surface (-) + real(dp) :: notUsed_z0Canopy ! roughness length of the vegetation canopy (m) + real(dp) :: notUsed_WindReductionFactor ! canopy wind reduction factor (-) + real(dp) :: notUsed_ZeroPlaneDisplacement ! zero plane displacement (m) + real(dp) :: notUsed_scalarCanopyStabilityCorrection ! stability correction for the canopy (-) + real(dp) :: notUsed_scalarGroundStabilityCorrection ! stability correction for the ground surface (-) + real(dp) :: notUsed_EddyDiffusCanopyTop ! eddy diffusivity for heat at the top of the canopy (m2 s-1) + real(dp) :: notUsed_FrictionVelocity ! friction velocity (m s-1) + real(dp) :: notUsed_WindspdCanopyTop ! windspeed at the top of the canopy (m s-1) + real(dp) :: notUsed_WindspdCanopyBottom ! windspeed at the height of the bottom of the canopy (m s-1) + real(dp) :: notUsed_dGroundResistance_dTGround ! derivative in ground resistance w.r.t. ground temperature (s m-1 K-1) + real(dp) :: notUsed_dGroundResistance_dTCanopy ! derivative in ground resistance w.r.t. canopy temperature (s m-1 K-1) + real(dp) :: notUsed_dGroundResistance_dTCanair ! derivative in ground resistance w.r.t. canopy air temperature (s m-1 K-1) + real(dp) :: notUsed_dCanopyResistance_dTCanopy ! derivative in canopy resistance w.r.t. canopy temperature (s m-1 K-1) + real(dp) :: notUsed_dCanopyResistance_dTCanair ! derivative in canopy resistance w.r.t. canopy air temperature (s m-1 K-1) ! (fluxes after perturbations in model states -- canopy air space) - real(rk) :: turbFluxCanair_dStateCanair ! turbulent exchange from the canopy air space to the atmosphere, after canopy air temperature is perturbed (W m-2) - real(rk) :: turbFluxCanair_dStateCanopy ! turbulent exchange from the canopy air space to the atmosphere, after canopy temperature is perturbed (W m-2) - real(rk) :: turbFluxCanair_dStateGround ! turbulent exchange from the canopy air space to the atmosphere, after ground temperature is perturbed (W m-2) - real(rk) :: turbFluxCanair_dStateCanliq ! turbulent exchange from the canopy air space to the atmosphere, after canopy liquid water content is perturbed (W m-2) + real(dp) :: turbFluxCanair_dStateCanair ! turbulent exchange from the canopy air space to the atmosphere, after canopy air temperature is perturbed (W m-2) + real(dp) :: turbFluxCanair_dStateCanopy ! turbulent exchange from the canopy air space to the atmosphere, after canopy temperature is perturbed (W m-2) + real(dp) :: turbFluxCanair_dStateGround ! turbulent exchange from the canopy air space to the atmosphere, after ground temperature is perturbed (W m-2) + real(dp) :: turbFluxCanair_dStateCanliq ! turbulent exchange from the canopy air space to the atmosphere, after canopy liquid water content is perturbed (W m-2) ! (fluxes after perturbations in model states -- vegetation canopy) - real(rk) :: turbFluxCanopy_dStateCanair ! total turbulent heat fluxes from the canopy to the canopy air space, after canopy air temperature is perturbed (W m-2) - real(rk) :: turbFluxCanopy_dStateCanopy ! total turbulent heat fluxes from the canopy to the canopy air space, after canopy temperature is perturbed (W m-2) - real(rk) :: turbFluxCanopy_dStateGround ! total turbulent heat fluxes from the canopy to the canopy air space, after ground temperature is perturbed (W m-2) - real(rk) :: turbFluxCanopy_dStateCanLiq ! total turbulent heat fluxes from the canopy to the canopy air space, after canopy liquid water content is perturbed (W m-2) + real(dp) :: turbFluxCanopy_dStateCanair ! total turbulent heat fluxes from the canopy to the canopy air space, after canopy air temperature is perturbed (W m-2) + real(dp) :: turbFluxCanopy_dStateCanopy ! total turbulent heat fluxes from the canopy to the canopy air space, after canopy temperature is perturbed (W m-2) + real(dp) :: turbFluxCanopy_dStateGround ! total turbulent heat fluxes from the canopy to the canopy air space, after ground temperature is perturbed (W m-2) + real(dp) :: turbFluxCanopy_dStateCanLiq ! total turbulent heat fluxes from the canopy to the canopy air space, after canopy liquid water content is perturbed (W m-2) ! (fluxes after perturbations in model states -- ground surface) - real(rk) :: turbFluxGround_dStateCanair ! total turbulent heat fluxes from the ground to the canopy air space, after canopy air temperature is perturbed (W m-2) - real(rk) :: turbFluxGround_dStateCanopy ! total turbulent heat fluxes from the ground to the canopy air space, after canopy temperature is perturbed (W m-2) - real(rk) :: turbFluxGround_dStateGround ! total turbulent heat fluxes from the ground to the canopy air space, after ground temperature is perturbed (W m-2) - real(rk) :: turbFluxGround_dStateCanLiq ! total turbulent heat fluxes from the ground to the canopy air space, after canopy liquid water content is perturbed (W m-2) + real(dp) :: turbFluxGround_dStateCanair ! total turbulent heat fluxes from the ground to the canopy air space, after canopy air temperature is perturbed (W m-2) + real(dp) :: turbFluxGround_dStateCanopy ! total turbulent heat fluxes from the ground to the canopy air space, after canopy temperature is perturbed (W m-2) + real(dp) :: turbFluxGround_dStateGround ! total turbulent heat fluxes from the ground to the canopy air space, after ground temperature is perturbed (W m-2) + real(dp) :: turbFluxGround_dStateCanLiq ! total turbulent heat fluxes from the ground to the canopy air space, after canopy liquid water content is perturbed (W m-2) ! (fluxes after perturbations in model states -- canopy evaporation) - real(rk) :: latHeatCanEvap_dStateCanair ! canopy evaporation after canopy air temperature is perturbed (W m-2) - real(rk) :: latHeatCanEvap_dStateCanopy ! canopy evaporation after canopy temperature is perturbed (W m-2) - real(rk) :: latHeatCanEvap_dStateGround ! canopy evaporation after ground temperature is perturbed (W m-2) - real(rk) :: latHeatCanEvap_dStateCanLiq ! canopy evaporation after canopy liquid water content is perturbed (W m-2) + real(dp) :: latHeatCanEvap_dStateCanair ! canopy evaporation after canopy air temperature is perturbed (W m-2) + real(dp) :: latHeatCanEvap_dStateCanopy ! canopy evaporation after canopy temperature is perturbed (W m-2) + real(dp) :: latHeatCanEvap_dStateGround ! canopy evaporation after ground temperature is perturbed (W m-2) + real(dp) :: latHeatCanEvap_dStateCanLiq ! canopy evaporation after canopy liquid water content is perturbed (W m-2) ! (flux derivatives -- canopy air space) - real(rk) :: dTurbFluxCanair_dTCanair ! derivative in net canopy air space fluxes w.r.t. canopy air temperature (W m-2 K-1) - real(rk) :: dTurbFluxCanair_dTCanopy ! derivative in net canopy air space fluxes w.r.t. canopy temperature (W m-2 K-1) - real(rk) :: dTurbFluxCanair_dTGround ! derivative in net canopy air space fluxes w.r.t. ground temperature (W m-2 K-1) - real(rk) :: dTurbFluxCanair_dCanLiq ! derivative in net canopy air space fluxes w.r.t. canopy liquid water content (J kg-1 s-1) + real(dp) :: dTurbFluxCanair_dTCanair ! derivative in net canopy air space fluxes w.r.t. canopy air temperature (W m-2 K-1) + real(dp) :: dTurbFluxCanair_dTCanopy ! derivative in net canopy air space fluxes w.r.t. canopy temperature (W m-2 K-1) + real(dp) :: dTurbFluxCanair_dTGround ! derivative in net canopy air space fluxes w.r.t. ground temperature (W m-2 K-1) + real(dp) :: dTurbFluxCanair_dCanLiq ! derivative in net canopy air space fluxes w.r.t. canopy liquid water content (J kg-1 s-1) ! (flux derivatives -- vegetation canopy) - real(rk) :: dTurbFluxCanopy_dTCanair ! derivative in net canopy turbulent fluxes w.r.t. canopy air temperature (W m-2 K-1) - real(rk) :: dTurbFluxCanopy_dTCanopy ! derivative in net canopy turbulent fluxes w.r.t. canopy temperature (W m-2 K-1) - real(rk) :: dTurbFluxCanopy_dTGround ! derivative in net canopy turbulent fluxes w.r.t. ground temperature (W m-2 K-1) - real(rk) :: dTurbFluxCanopy_dCanLiq ! derivative in net canopy turbulent fluxes w.r.t. canopy liquid water content (J kg-1 s-1) + real(dp) :: dTurbFluxCanopy_dTCanair ! derivative in net canopy turbulent fluxes w.r.t. canopy air temperature (W m-2 K-1) + real(dp) :: dTurbFluxCanopy_dTCanopy ! derivative in net canopy turbulent fluxes w.r.t. canopy temperature (W m-2 K-1) + real(dp) :: dTurbFluxCanopy_dTGround ! derivative in net canopy turbulent fluxes w.r.t. ground temperature (W m-2 K-1) + real(dp) :: dTurbFluxCanopy_dCanLiq ! derivative in net canopy turbulent fluxes w.r.t. canopy liquid water content (J kg-1 s-1) ! (flux derivatives -- ground surface) - real(rk) :: dTurbFluxGround_dTCanair ! derivative in net ground turbulent fluxes w.r.t. canopy air temperature (W m-2 K-1) - real(rk) :: dTurbFluxGround_dTCanopy ! derivative in net ground turbulent fluxes w.r.t. canopy temperature (W m-2 K-1) - real(rk) :: dTurbFluxGround_dTGround ! derivative in net ground turbulent fluxes w.r.t. ground temperature (W m-2 K-1) - real(rk) :: dTurbFluxGround_dCanLiq ! derivative in net ground turbulent fluxes w.r.t. canopy liquid water content (J kg-1 s-1) + real(dp) :: dTurbFluxGround_dTCanair ! derivative in net ground turbulent fluxes w.r.t. canopy air temperature (W m-2 K-1) + real(dp) :: dTurbFluxGround_dTCanopy ! derivative in net ground turbulent fluxes w.r.t. canopy temperature (W m-2 K-1) + real(dp) :: dTurbFluxGround_dTGround ! derivative in net ground turbulent fluxes w.r.t. ground temperature (W m-2 K-1) + real(dp) :: dTurbFluxGround_dCanLiq ! derivative in net ground turbulent fluxes w.r.t. canopy liquid water content (J kg-1 s-1) ! (liquid water flux derivatives -- canopy evap) - real(rk) :: dLatHeatCanopyEvap_dCanLiq ! derivative in latent heat of canopy evaporation w.r.t. canopy liquid water content (W kg-1) - real(rk) :: dLatHeatCanopyEvap_dTCanair ! derivative in latent heat of canopy evaporation w.r.t. canopy air temperature (W m-2 K-1) - real(rk) :: dLatHeatCanopyEvap_dTCanopy ! derivative in latent heat of canopy evaporation w.r.t. canopy temperature (W m-2 K-1) - real(rk) :: dLatHeatCanopyEvap_dTGround ! derivative in latent heat of canopy evaporation w.r.t. ground temperature (W m-2 K-1) + real(dp) :: dLatHeatCanopyEvap_dCanLiq ! derivative in latent heat of canopy evaporation w.r.t. canopy liquid water content (W kg-1) + real(dp) :: dLatHeatCanopyEvap_dTCanair ! derivative in latent heat of canopy evaporation w.r.t. canopy air temperature (W m-2 K-1) + real(dp) :: dLatHeatCanopyEvap_dTCanopy ! derivative in latent heat of canopy evaporation w.r.t. canopy temperature (W m-2 K-1) + real(dp) :: dLatHeatCanopyEvap_dTGround ! derivative in latent heat of canopy evaporation w.r.t. ground temperature (W m-2 K-1) ! (liquid water flux derivatives -- ground evap) - real(rk) :: dLatHeatGroundEvap_dCanLiq ! derivative in latent heat of ground evaporation w.r.t. canopy liquid water content (J kg-1 s-1) - real(rk) :: dLatHeatGroundEvap_dTCanair ! derivative in latent heat of ground evaporation w.r.t. canopy air temperature (W m-2 K-1) - real(rk) :: dLatHeatGroundEvap_dTCanopy ! derivative in latent heat of ground evaporation w.r.t. canopy temperature (W m-2 K-1) - real(rk) :: dLatHeatGroundEvap_dTGround ! derivative in latent heat of ground evaporation w.r.t. ground temperature (W m-2 K-1) + real(dp) :: dLatHeatGroundEvap_dCanLiq ! derivative in latent heat of ground evaporation w.r.t. canopy liquid water content (J kg-1 s-1) + real(dp) :: dLatHeatGroundEvap_dTCanair ! derivative in latent heat of ground evaporation w.r.t. canopy air temperature (W m-2 K-1) + real(dp) :: dLatHeatGroundEvap_dTCanopy ! derivative in latent heat of ground evaporation w.r.t. canopy temperature (W m-2 K-1) + real(dp) :: dLatHeatGroundEvap_dTGround ! derivative in latent heat of ground evaporation w.r.t. ground temperature (W m-2 K-1) ! --------------------------------------------------------------------------------------- ! point to variables in the data structure @@ -624,47 +624,47 @@ subroutine vegNrgFlux(& case(prescribedTemp,zeroFlux) ! derived fluxes - scalarTotalET = 0._rk ! total ET (kg m-2 s-1) - scalarNetRadiation = 0._rk ! net radiation (W m-2) + scalarTotalET = 0._dp ! total ET (kg m-2 s-1) + scalarNetRadiation = 0._dp ! net radiation (W m-2) ! liquid water fluxes associated with evaporation/transpiration - scalarCanopyTranspiration = 0._rk ! canopy transpiration (kg m-2 s-1) - scalarCanopyEvaporation = 0._rk ! canopy evaporation/condensation (kg m-2 s-1) - scalarGroundEvaporation = 0._rk ! ground evaporation/condensation -- below canopy or non-vegetated (kg m-2 s-1) + scalarCanopyTranspiration = 0._dp ! canopy transpiration (kg m-2 s-1) + scalarCanopyEvaporation = 0._dp ! canopy evaporation/condensation (kg m-2 s-1) + scalarGroundEvaporation = 0._dp ! ground evaporation/condensation -- below canopy or non-vegetated (kg m-2 s-1) ! solid water fluxes associated with sublimation/frost - scalarCanopySublimation = 0._rk ! sublimation from the vegetation canopy ((kg m-2 s-1) - scalarSnowSublimation = 0._rk ! sublimation from the snow surface ((kg m-2 s-1) + scalarCanopySublimation = 0._dp ! sublimation from the vegetation canopy ((kg m-2 s-1) + scalarSnowSublimation = 0._dp ! sublimation from the snow surface ((kg m-2 s-1) ! set canopy fluxes to zero (no canopy) - canairNetFlux = 0._rk ! net energy flux for the canopy air space (W m-2) - canopyNetFlux = 0._rk ! net energy flux for the vegetation canopy (W m-2) + canairNetFlux = 0._dp ! net energy flux for the canopy air space (W m-2) + canopyNetFlux = 0._dp ! net energy flux for the vegetation canopy (W m-2) ! set canopy derivatives to zero - dCanairNetFlux_dCanairTemp = 0._rk ! derivative in net canopy air space flux w.r.t. canopy air temperature (W m-2 K-1) - dCanairNetFlux_dCanopyTemp = 0._rk ! derivative in net canopy air space flux w.r.t. canopy temperature (W m-2 K-1) - dCanairNetFlux_dGroundTemp = 0._rk ! derivative in net canopy air space flux w.r.t. ground temperature (W m-2 K-1) - dCanopyNetFlux_dCanairTemp = 0._rk ! derivative in net canopy flux w.r.t. canopy air temperature (W m-2 K-1) - dCanopyNetFlux_dCanopyTemp = 0._rk ! derivative in net canopy flux w.r.t. canopy temperature (W m-2 K-1) - dCanopyNetFlux_dGroundTemp = 0._rk ! derivative in net canopy flux w.r.t. ground temperature (W m-2 K-1) - dGroundNetFlux_dCanairTemp = 0._rk ! derivative in net ground flux w.r.t. canopy air temperature (W m-2 K-1) - dGroundNetFlux_dCanopyTemp = 0._rk ! derivative in net ground flux w.r.t. canopy temperature (W m-2 K-1) + dCanairNetFlux_dCanairTemp = 0._dp ! derivative in net canopy air space flux w.r.t. canopy air temperature (W m-2 K-1) + dCanairNetFlux_dCanopyTemp = 0._dp ! derivative in net canopy air space flux w.r.t. canopy temperature (W m-2 K-1) + dCanairNetFlux_dGroundTemp = 0._dp ! derivative in net canopy air space flux w.r.t. ground temperature (W m-2 K-1) + dCanopyNetFlux_dCanairTemp = 0._dp ! derivative in net canopy flux w.r.t. canopy air temperature (W m-2 K-1) + dCanopyNetFlux_dCanopyTemp = 0._dp ! derivative in net canopy flux w.r.t. canopy temperature (W m-2 K-1) + dCanopyNetFlux_dGroundTemp = 0._dp ! derivative in net canopy flux w.r.t. ground temperature (W m-2 K-1) + dGroundNetFlux_dCanairTemp = 0._dp ! derivative in net ground flux w.r.t. canopy air temperature (W m-2 K-1) + dGroundNetFlux_dCanopyTemp = 0._dp ! derivative in net ground flux w.r.t. canopy temperature (W m-2 K-1) ! set liquid flux derivatives to zero (canopy evap) - dCanopyEvaporation_dCanLiq = 0._rk ! derivative in canopy evaporation w.r.t. canopy liquid water content (s-1) - dCanopyEvaporation_dTCanair= 0._rk ! derivative in canopy evaporation w.r.t. canopy air temperature (kg m-2 s-1 K-1) - dCanopyEvaporation_dTCanopy= 0._rk ! derivative in canopy evaporation w.r.t. canopy temperature (kg m-2 s-1 K-1) - dCanopyEvaporation_dTGround= 0._rk ! derivative in canopy evaporation w.r.t. ground temperature (kg m-2 s-1 K-1) + dCanopyEvaporation_dCanLiq = 0._dp ! derivative in canopy evaporation w.r.t. canopy liquid water content (s-1) + dCanopyEvaporation_dTCanair= 0._dp ! derivative in canopy evaporation w.r.t. canopy air temperature (kg m-2 s-1 K-1) + dCanopyEvaporation_dTCanopy= 0._dp ! derivative in canopy evaporation w.r.t. canopy temperature (kg m-2 s-1 K-1) + dCanopyEvaporation_dTGround= 0._dp ! derivative in canopy evaporation w.r.t. ground temperature (kg m-2 s-1 K-1) ! set liquid flux derivatives to zero (ground evap) - dGroundEvaporation_dCanLiq = 0._rk ! derivative in ground evaporation w.r.t. canopy liquid water content (s-1) - dGroundEvaporation_dTCanair= 0._rk ! derivative in ground evaporation w.r.t. canopy air temperature (kg m-2 s-1 K-1) - dGroundEvaporation_dTCanopy= 0._rk ! derivative in ground evaporation w.r.t. canopy temperature (kg m-2 s-1 K-1) - dGroundEvaporation_dTGround= 0._rk ! derivative in ground evaporation w.r.t. ground temperature (kg m-2 s-1 K-1) + dGroundEvaporation_dCanLiq = 0._dp ! derivative in ground evaporation w.r.t. canopy liquid water content (s-1) + dGroundEvaporation_dTCanair= 0._dp ! derivative in ground evaporation w.r.t. canopy air temperature (kg m-2 s-1 K-1) + dGroundEvaporation_dTCanopy= 0._dp ! derivative in ground evaporation w.r.t. canopy temperature (kg m-2 s-1 K-1) + dGroundEvaporation_dTGround= 0._dp ! derivative in ground evaporation w.r.t. ground temperature (kg m-2 s-1 K-1) ! compute fluxes and derivatives -- separate approach for prescribed temperature and zero flux if(ix_bcUpprTdyn == prescribedTemp)then ! compute ground net flux (W m-2) - groundNetFlux = -diag_data%var(iLookDIAG%iLayerThermalC)%dat(0)*(groundTempTrial - upperBoundTemp)/(prog_data%var(iLookPROG%mLayerDepth)%dat(1)*0.5_rk) + groundNetFlux = -diag_data%var(iLookDIAG%iLayerThermalC)%dat(0)*(groundTempTrial - upperBoundTemp)/(prog_data%var(iLookPROG%mLayerDepth)%dat(1)*0.5_dp) ! compute derivative in net ground flux w.r.t. ground temperature (W m-2 K-1) - dGroundNetFlux_dGroundTemp = -diag_data%var(iLookDIAG%iLayerThermalC)%dat(0)/(prog_data%var(iLookPROG%mLayerDepth)%dat(1)*0.5_rk) + dGroundNetFlux_dGroundTemp = -diag_data%var(iLookDIAG%iLayerThermalC)%dat(0)/(prog_data%var(iLookPROG%mLayerDepth)%dat(1)*0.5_dp) elseif(model_decisions(iLookDECISIONS%bcUpprTdyn)%iDecision == zeroFlux)then - groundNetFlux = 0._rk - dGroundNetFlux_dGroundTemp = 0._rk + groundNetFlux = 0._dp + dGroundNetFlux_dGroundTemp = 0._dp else err=20; message=trim(message)//'unable to identify upper boundary condition for thermodynamics: expect the case to be prescribedTemp or zeroFlux'; return end if @@ -700,8 +700,8 @@ subroutine vegNrgFlux(& if(firstFluxCall .and. firstSubStep)then ! vapor pressure in the canopy air space initialized as vapor pressure of air above the vegetation canopy ! NOTE: this is needed for the stomatal resistance calculations - if(scalarVP_CanopyAir < 0._rk)then - scalarVP_CanopyAir = scalarVPair - 1._rk ! "small" offset used to assist in checking initial derivative calculations + if(scalarVP_CanopyAir < 0._dp)then + scalarVP_CanopyAir = scalarVPair - 1._dp ! "small" offset used to assist in checking initial derivative calculations end if end if @@ -713,17 +713,17 @@ subroutine vegNrgFlux(& if(nSnow > 0)then if(groundTempTrial > Tfreeze)then; err=20; message=trim(message)//'do not expect ground temperature > 0 when snow is on the ground'; return; end if scalarLatHeatSubVapGround = LH_sub ! sublimation from snow - scalarGroundSnowFraction = 1._rk + scalarGroundSnowFraction = 1._dp ! case when the ground is snow-free else scalarLatHeatSubVapGround = LH_vap ! evaporation of water in the soil pores: this occurs even if frozen because of super-cooled water - scalarGroundSnowFraction = 0._rk + scalarGroundSnowFraction = 0._dp end if ! (if there is snow on the ground) end if ! (if the first flux call) !write(*,'(a,1x,10(f30.10,1x))') 'groundTempTrial, scalarLatHeatSubVapGround = ', groundTempTrial, scalarLatHeatSubVapGround ! compute the roughness length of the ground (ground below the canopy or non-vegetated surface) - z0Ground = z0soil*(1._rk - scalarGroundSnowFraction) + z0Snow*scalarGroundSnowFraction ! roughness length (m) + z0Ground = z0soil*(1._dp - scalarGroundSnowFraction) + z0Snow*scalarGroundSnowFraction ! roughness length (m) ! compute the total vegetation area index (leaf plus stem) VAI = scalarLAI + scalarSAI ! vegetation area index @@ -734,16 +734,16 @@ subroutine vegNrgFlux(& select case(ix_canopyEmis) ! *** simple exponential function case(simplExp) - scalarCanopyEmissivity = 1._rk - exp(-exposedVAI) ! effective emissivity of the canopy (-) + scalarCanopyEmissivity = 1._dp - exp(-exposedVAI) ! effective emissivity of the canopy (-) ! *** canopy emissivity parameterized as a function of diffuse transmissivity case(difTrans) ! compute the exponential integral - scaleLAI = 0.5_rk*exposedVAI + scaleLAI = 0.5_dp*exposedVAI expi = expInt(scaleLAI) ! compute diffuse transmissivity (-) - diffuseTrans = (1._rk - scaleLAI)*exp(-scaleLAI) + (scaleLAI**2._rk)*expi + diffuseTrans = (1._dp - scaleLAI)*exp(-scaleLAI) + (scaleLAI**2._dp)*expi ! compute the canopy emissivity - scalarCanopyEmissivity = (1._rk - diffuseTrans)*vegEmissivity + scalarCanopyEmissivity = (1._dp - diffuseTrans)*vegEmissivity ! *** check we found the correct option case default err=20; message=trim(message)//'unable to identify option for canopy emissivity'; return @@ -751,10 +751,10 @@ subroutine vegNrgFlux(& end if ! ensure canopy longwave fluxes are zero when not computing canopy fluxes - if(.not.computeVegFlux) scalarCanopyEmissivity=0._rk + if(.not.computeVegFlux) scalarCanopyEmissivity=0._dp ! compute emissivity of the ground surface (-) - groundEmissivity = scalarGroundSnowFraction*snowEmissivity + (1._rk - scalarGroundSnowFraction)*soilEmissivity ! emissivity of the ground surface (-) + groundEmissivity = scalarGroundSnowFraction*snowEmissivity + (1._dp - scalarGroundSnowFraction)*soilEmissivity ! emissivity of the ground surface (-) ! compute the fraction of canopy that is wet ! NOTE: we either sublimate or evaporate over the entire substep @@ -762,10 +762,10 @@ subroutine vegNrgFlux(& ! compute the fraction of liquid water in the canopy (-) totalCanopyWater = canopyLiqTrial + canopyIceTrial - if(totalCanopyWater > tiny(1.0_rk))then + if(totalCanopyWater > tiny(1.0_dp))then fracLiquidCanopy = canopyLiqTrial / (canopyLiqTrial + canopyIceTrial) else - fracLiquidCanopy = 0._rk + fracLiquidCanopy = 0._dp end if ! get wetted fraction and derivatives @@ -790,9 +790,9 @@ subroutine vegNrgFlux(& if(err/=0)then; message=trim(message)//trim(cmessage); return; end if else - scalarCanopyWetFraction = 0._rk ! canopy wetted fraction (-) - dCanopyWetFraction_dWat = 0._rk ! derivative in wetted fraction w.r.t. canopy liquid water (kg-1 m2) - dCanopyWetFraction_dT = 0._rk ! derivative in wetted fraction w.r.t. canopy temperature (K-1) + scalarCanopyWetFraction = 0._dp ! canopy wetted fraction (-) + dCanopyWetFraction_dWat = 0._dp ! derivative in wetted fraction w.r.t. canopy liquid water (kg-1 m2) + dCanopyWetFraction_dT = 0._dp ! derivative in wetted fraction w.r.t. canopy temperature (K-1) end if !write(*,'(a,1x,L1,1x,f25.15,1x))') 'computeVegFlux, scalarCanopyWetFraction = ', computeVegFlux, scalarCanopyWetFraction !print*, 'dCanopyWetFraction_dWat = ', dCanopyWetFraction_dWat @@ -1068,7 +1068,7 @@ subroutine vegNrgFlux(& if(err/=0)then; message=trim(message)//trim(cmessage); return; end if else - canopyWetFraction = 0._rk + canopyWetFraction = 0._dp end if !print*, 'wetted fraction derivative = ', (canopyWetFraction - scalarCanopyWetFraction)/dx !pause @@ -1168,15 +1168,15 @@ subroutine vegNrgFlux(& ! (soil water evaporation factor [0-1]) soilEvapFactor = mLayerVolFracLiq(nSnow+1)/(theta_sat - theta_res) ! (resistance from the soil [s m-1]) - scalarSoilResistance = scalarGroundSnowFraction*1._rk + (1._rk - scalarGroundSnowFraction)*EXP(8.25_rk - 4.225_rk*soilEvapFactor) ! Sellers (1992) - !scalarSoilResistance = scalarGroundSnowFraction*0._rk + (1._rk - scalarGroundSnowFraction)*exp(8.25_rk - 6.0_rk*soilEvapFactor) ! Niu adjustment to decrease resitance for wet soil + scalarSoilResistance = scalarGroundSnowFraction*1._dp + (1._dp - scalarGroundSnowFraction)*EXP(8.25_dp - 4.225_dp*soilEvapFactor) ! Sellers (1992) + !scalarSoilResistance = scalarGroundSnowFraction*0._dp + (1._dp - scalarGroundSnowFraction)*exp(8.25_dp - 6.0_dp*soilEvapFactor) ! Niu adjustment to decrease resitance for wet soil ! (relative humidity in the soil pores [0-1]) - if(mLayerMatricHead(1) > -1.e+6_rk)then ! avoid problems with numerical precision when soil is very dry + if(mLayerMatricHead(1) > -1.e+6_dp)then ! avoid problems with numerical precision when soil is very dry soilRelHumidity_noSnow = exp( (mLayerMatricHead(1)*gravity) / (groundTemp*R_wv) ) else - soilRelHumidity_noSnow = 0._rk + soilRelHumidity_noSnow = 0._dp end if ! (if matric head is very low) - scalarSoilRelHumidity = scalarGroundSnowFraction*1._rk + (1._rk - scalarGroundSnowFraction)*soilRelHumidity_noSnow + scalarSoilRelHumidity = scalarGroundSnowFraction*1._dp + (1._dp - scalarGroundSnowFraction)*soilRelHumidity_noSnow !print*, 'mLayerMatricHead(1), scalarSoilRelHumidity = ', mLayerMatricHead(1), scalarSoilRelHumidity end if ! (if the first flux call) @@ -1396,21 +1396,21 @@ subroutine vegNrgFlux(& !print*, 'scalarLatHeatGround = ', scalarLatHeatGround ! (canopy transpiration/sublimation) if(scalarLatHeatSubVapCanopy > LH_vap+verySmall)then ! sublimation - scalarCanopyEvaporation = 0._rk + scalarCanopyEvaporation = 0._dp scalarCanopySublimation = scalarLatHeatCanopyEvap/LH_sub - if(scalarLatHeatCanopyTrans > 0._rk)then ! flux directed towards the veg + if(scalarLatHeatCanopyTrans > 0._dp)then ! flux directed towards the veg scalarCanopySublimation = scalarCanopySublimation + scalarLatHeatCanopyTrans/LH_sub ! frost - scalarCanopyTranspiration = 0._rk + scalarCanopyTranspiration = 0._dp else scalarCanopyTranspiration = scalarLatHeatCanopyTrans/LH_vap ! transpiration is always vapor end if ! (canopy transpiration/evaporation) else ! evaporation scalarCanopyEvaporation = scalarLatHeatCanopyEvap/LH_vap - scalarCanopySublimation = 0._rk - if(scalarLatHeatCanopyTrans > 0._rk)then ! flux directed towards the veg + scalarCanopySublimation = 0._dp + if(scalarLatHeatCanopyTrans > 0._dp)then ! flux directed towards the veg scalarCanopyEvaporation = scalarCanopyEvaporation + scalarLatHeatCanopyTrans/LH_vap - scalarCanopyTranspiration = 0._rk + scalarCanopyTranspiration = 0._dp else scalarCanopyTranspiration = scalarLatHeatCanopyTrans/LH_vap end if @@ -1419,13 +1419,13 @@ subroutine vegNrgFlux(& if(scalarLatHeatSubVapGround > LH_vap+verySmall)then ! sublimation ! NOTE: this should only occur when we have formed snow layers, so check if(nSnow == 0)then; err=20; message=trim(message)//'only expect snow sublimation when we have formed some snow layers'; return; end if - scalarGroundEvaporation = 0._rk ! ground evaporation is zero once the snowpack has formed + scalarGroundEvaporation = 0._dp ! ground evaporation is zero once the snowpack has formed scalarSnowSublimation = scalarLatHeatGround/LH_sub else ! NOTE: this should only occur when we have no snow layers, so check if(nSnow > 0)then; err=20; message=trim(message)//'only expect ground evaporation when there are no snow layers'; return; end if scalarGroundEvaporation = scalarLatHeatGround/LH_vap - scalarSnowSublimation = 0._rk ! no sublimation from snow if no snow layers have formed + scalarSnowSublimation = 0._dp ! no sublimation from snow if no snow layers have formed end if !print*, 'scalarSnowSublimation, scalarLatHeatGround = ', scalarSnowSublimation, scalarLatHeatGround @@ -1472,10 +1472,10 @@ subroutine vegNrgFlux(& ! sublimation else - dCanopyEvaporation_dCanLiq = 0._rk ! (s-1) - dCanopyEvaporation_dTCanair = 0._rk ! (kg m-2 s-1 K-1) - dCanopyEvaporation_dTCanopy = 0._rk ! (kg m-2 s-1 K-1) - dCanopyEvaporation_dTGround = 0._rk ! (kg m-2 s-1 K-1) + dCanopyEvaporation_dCanLiq = 0._dp ! (s-1) + dCanopyEvaporation_dTCanair = 0._dp ! (kg m-2 s-1 K-1) + dCanopyEvaporation_dTCanopy = 0._dp ! (kg m-2 s-1 K-1) + dCanopyEvaporation_dTGround = 0._dp ! (kg m-2 s-1 K-1) end if ! compute the liquid water derivarives (ground evap) @@ -1542,25 +1542,25 @@ subroutine wettedFrac(& logical(lgt),intent(in) :: deriv ! flag to denote if derivative is desired logical(lgt),intent(in) :: derNum ! flag to denote that numerical derivatives are required (otherwise, analytical derivatives are calculated) logical(lgt),intent(in) :: frozen ! flag to denote if the canopy is frozen - real(rk),intent(in) :: dLiq_dT ! derivative in canopy liquid w.r.t. canopy temperature (kg m-2 K-1) - real(rk),intent(in) :: fracLiq ! fraction of liquid water on the canopy (-) - real(rk),intent(in) :: canopyLiq ! canopy liquid water (kg m-2) - real(rk),intent(in) :: canopyIce ! canopy ice (kg m-2) - real(rk),intent(in) :: canopyLiqMax ! maximum canopy liquid water (kg m-2) - real(rk),intent(in) :: canopyIceMax ! maximum canopy ice content (kg m-2) - real(rk),intent(in) :: canopyWettingFactor ! maximum wetted fraction of the canopy (-) - real(rk),intent(in) :: canopyWettingExp ! exponent in canopy wetting function (-) + real(dp),intent(in) :: dLiq_dT ! derivative in canopy liquid w.r.t. canopy temperature (kg m-2 K-1) + real(dp),intent(in) :: fracLiq ! fraction of liquid water on the canopy (-) + real(dp),intent(in) :: canopyLiq ! canopy liquid water (kg m-2) + real(dp),intent(in) :: canopyIce ! canopy ice (kg m-2) + real(dp),intent(in) :: canopyLiqMax ! maximum canopy liquid water (kg m-2) + real(dp),intent(in) :: canopyIceMax ! maximum canopy ice content (kg m-2) + real(dp),intent(in) :: canopyWettingFactor ! maximum wetted fraction of the canopy (-) + real(dp),intent(in) :: canopyWettingExp ! exponent in canopy wetting function (-) ! output - real(rk),intent(out) :: canopyWetFraction ! canopy wetted fraction (-) - real(rk),intent(out) :: dCanopyWetFraction_dWat ! derivative in wetted fraction w.r.t. canopy total water (kg-1 m2) - real(rk),intent(out) :: dCanopyWetFraction_dT ! derivative in wetted fraction w.r.t. canopy temperature (K-1) + real(dp),intent(out) :: canopyWetFraction ! canopy wetted fraction (-) + real(dp),intent(out) :: dCanopyWetFraction_dWat ! derivative in wetted fraction w.r.t. canopy total water (kg-1 m2) + real(dp),intent(out) :: dCanopyWetFraction_dT ! derivative in wetted fraction w.r.t. canopy temperature (K-1) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! local variables logical(lgt),parameter :: smoothing=.true. ! flag to denote that smoothing is required - real(rk) :: canopyWetFractionPert ! canopy wetted fraction after state perturbations (-) - real(rk) :: canopyWetFractionDeriv ! derivative in wetted fraction w.r.t. canopy liquid water (kg-1 m2) + real(dp) :: canopyWetFractionPert ! canopy wetted fraction after state perturbations (-) + real(dp) :: canopyWetFractionDeriv ! derivative in wetted fraction w.r.t. canopy liquid water (kg-1 m2) ! ----------------------------------------------------------------------------------------------------------------------------------------------- ! initialize error control err=0; message='wettedFrac/' @@ -1575,14 +1575,14 @@ subroutine wettedFrac(& canopyWetFractionDeriv = (canopyWetFractionPert - canopyWetFraction)/dx end if ! scale derivative by the fraction of water - ! NOTE: dIce/dWat = (1._rk - fracLiq), hence dWet/dWat = dIce/dWat . dWet/dLiq - dCanopyWetFraction_dWat = canopyWetFractionDeriv*(1._rk - fracLiq) + ! NOTE: dIce/dWat = (1._dp - fracLiq), hence dWet/dWat = dIce/dWat . dWet/dLiq + dCanopyWetFraction_dWat = canopyWetFractionDeriv*(1._dp - fracLiq) dCanopyWetFraction_dT = -canopyWetFractionDeriv*dLiq_dT ! NOTE: dIce/dT = -dLiq/dT return end if ! compute fraction of liquid water on the canopy - ! NOTE: if(.not.deriv) canopyWetFractionDeriv = 0._rk + ! NOTE: if(.not.deriv) canopyWetFractionDeriv = 0._dp call wetFraction((deriv .and. .not.derNum),smoothing,canopyLiq,canopyLiqMax,canopyWettingFactor,canopyWettingExp,canopyWetFraction,canopyWetFractionDeriv) ! compute numerical derivative @@ -1611,20 +1611,20 @@ subroutine wetFraction(derDesire,smoothing,canopyLiq,canopyMax,canopyWettingFact ! dummy variables logical(lgt),intent(in) :: derDesire ! flag to denote if analytical derivatives are desired logical(lgt),intent(in) :: smoothing ! flag to denote if smoothing is required - real(rk),intent(in) :: canopyLiq ! liquid water content (kg m-2) - real(rk),intent(in) :: canopyMax ! liquid water content (kg m-2) - real(rk),intent(in) :: canopyWettingFactor ! maximum wetted fraction of the canopy (-) - real(rk),intent(in) :: canopyWettingExp ! exponent in canopy wetting function (-) + real(dp),intent(in) :: canopyLiq ! liquid water content (kg m-2) + real(dp),intent(in) :: canopyMax ! liquid water content (kg m-2) + real(dp),intent(in) :: canopyWettingFactor ! maximum wetted fraction of the canopy (-) + real(dp),intent(in) :: canopyWettingExp ! exponent in canopy wetting function (-) - real(rk),intent(out) :: canopyWetFraction ! canopy wetted fraction (-) - real(rk),intent(out) :: canopyWetFractionDeriv ! derivative in wetted fraction w.r.t. canopy liquid water (kg-1 m2) + real(dp),intent(out) :: canopyWetFraction ! canopy wetted fraction (-) + real(dp),intent(out) :: canopyWetFractionDeriv ! derivative in wetted fraction w.r.t. canopy liquid water (kg-1 m2) ! local variables - real(rk) :: relativeCanopyWater ! water stored on vegetation canopy, expressed as a fraction of maximum storage (-) - real(rk) :: rawCanopyWetFraction ! initial value of the canopy wet fraction (before smoothing) - real(rk) :: rawWetFractionDeriv ! derivative in canopy wet fraction w.r.t. storage (kg-1 m2) - real(rk) :: smoothFunc ! smoothing function used to improve numerical stability at times with limited water storage (-) - real(rk) :: smoothFuncDeriv ! derivative in the smoothing function w.r.t.canopy storage (kg-1 m2) - real(rk) :: verySmall=epsilon(1._rk) ! a very small number + real(dp) :: relativeCanopyWater ! water stored on vegetation canopy, expressed as a fraction of maximum storage (-) + real(dp) :: rawCanopyWetFraction ! initial value of the canopy wet fraction (before smoothing) + real(dp) :: rawWetFractionDeriv ! derivative in canopy wet fraction w.r.t. storage (kg-1 m2) + real(dp) :: smoothFunc ! smoothing function used to improve numerical stability at times with limited water storage (-) + real(dp) :: smoothFuncDeriv ! derivative in the smoothing function w.r.t.canopy storage (kg-1 m2) + real(dp) :: verySmall=epsilon(1._dp) ! a very small number ! -------------------------------------------------------------------------------------------------------------- ! compute relative canopy water @@ -1633,18 +1633,18 @@ subroutine wetFraction(derDesire,smoothing,canopyLiq,canopyMax,canopyWettingFact ! compute an initial value of the canopy wet fraction ! - canopy below value where canopy is 100% wet - if(relativeCanopyWater < 1._rk)then + if(relativeCanopyWater < 1._dp)then rawCanopyWetFraction = canopyWettingFactor*(relativeCanopyWater**canopyWettingExp) if(derDesire .and. relativeCanopyWater>verySmall)then - rawWetFractionDeriv = (canopyWettingFactor*canopyWettingExp/canopyMax)*relativeCanopyWater**(canopyWettingExp - 1._rk) + rawWetFractionDeriv = (canopyWettingFactor*canopyWettingExp/canopyMax)*relativeCanopyWater**(canopyWettingExp - 1._dp) else - rawWetFractionDeriv = 0._rk + rawWetFractionDeriv = 0._dp end if ! - canopy is at capacity (canopyWettingFactor) else rawCanopyWetFraction = canopyWettingFactor - rawWetFractionDeriv = 0._rk + rawWetFractionDeriv = 0._dp end if ! smooth canopy wetted fraction @@ -1660,7 +1660,7 @@ subroutine wetFraction(derDesire,smoothing,canopyLiq,canopyMax,canopyWettingFact if(derDesire .and. smoothing)then ! NOTE: raw derivative is used if not smoothing canopyWetFractionDeriv = rawWetFractionDeriv*smoothFunc + rawCanopyWetFraction*smoothFuncDeriv else - canopyWetFractionDeriv = 0._rk + canopyWetFractionDeriv = 0._dp end if end subroutine wetFraction @@ -1673,15 +1673,15 @@ subroutine logisticSmoother(derDesire,canopyLiq,smoothFunc,smoothFuncDeriv) implicit none ! dummy variables logical(lgt),intent(in) :: derDesire ! flag to denote if analytical derivatives are desired - real(rk),intent(in) :: canopyLiq ! liquid water content (kg m-2) - real(rk),intent(out) :: smoothFunc ! smoothing function (-) - real(rk),intent(out) :: smoothFuncDeriv ! derivative in smoothing function (kg-1 m-2) + real(dp),intent(in) :: canopyLiq ! liquid water content (kg m-2) + real(dp),intent(out) :: smoothFunc ! smoothing function (-) + real(dp),intent(out) :: smoothFuncDeriv ! derivative in smoothing function (kg-1 m-2) ! local variables - real(rk) :: xArg ! argument used in the smoothing function (-) - real(rk) :: expX ! exp(-xArg) -- used multiple times - real(rk),parameter :: smoothThresh=0.01_rk ! mid-point of the smoothing function (kg m-2) - real(rk),parameter :: smoothScale=0.001_rk ! scaling factor for the smoothing function (kg m-2) - real(rk),parameter :: xLimit=50._rk ! don't compute exponents for > xLimit + real(dp) :: xArg ! argument used in the smoothing function (-) + real(dp) :: expX ! exp(-xArg) -- used multiple times + real(dp),parameter :: smoothThresh=0.01_dp ! mid-point of the smoothing function (kg m-2) + real(dp),parameter :: smoothScale=0.001_dp ! scaling factor for the smoothing function (kg m-2) + real(dp),parameter :: xLimit=50._dp ! don't compute exponents for > xLimit ! -------------------------------------------------------------------------------------------------------------- ! compute argument in the smoothing function xArg = (canopyLiq - smoothThresh)/smoothScale @@ -1689,19 +1689,19 @@ subroutine logisticSmoother(derDesire,canopyLiq,smoothFunc,smoothFuncDeriv) ! only compute smoothing function for small exponents if(xArg > -xLimit .and. xArg < xLimit)then ! avoid huge exponents expX = exp(-xarg) ! (also used in the derivative) - smoothFunc = 1._rk / (1._rk + expX) ! (logistic smoother) + smoothFunc = 1._dp / (1._dp + expX) ! (logistic smoother) if(derDesire)then - smoothFuncDeriv = expX / (smoothScale * (1._rk + expX)**2._rk) ! (derivative in the smoothing function) + smoothFuncDeriv = expX / (smoothScale * (1._dp + expX)**2._dp) ! (derivative in the smoothing function) else - smoothFuncDeriv = 0._rk + smoothFuncDeriv = 0._dp end if ! outside limits: special case of smooth exponents else - if(xArg < 0._rk)then; smoothFunc = 0._rk ! xArg < -xLimit - else; smoothFunc = 1._rk ! xArg > xLimit + if(xArg < 0._dp)then; smoothFunc = 0._dp ! xArg < -xLimit + else; smoothFunc = 1._dp ! xArg > xLimit end if - smoothFuncDeriv = 0._rk + smoothFuncDeriv = 0._dp end if ! check for huge exponents end subroutine logisticSmoother @@ -1752,34 +1752,34 @@ subroutine longwaveBal(& integer(i4b),intent(in) :: ixDerivMethod ! choice of method used to compute derivative (analytical or numerical) logical(lgt),intent(in) :: computeVegFlux ! flag to indicate if computing fluxes over vegetation ! input: canopy and ground temperature - real(rk),intent(in) :: canopyTemp ! canopy temperature (K) - real(rk),intent(in) :: groundTemp ! ground temperature (K) + real(dp),intent(in) :: canopyTemp ! canopy temperature (K) + real(dp),intent(in) :: groundTemp ! ground temperature (K) ! input: canopy and ground emissivity - real(rk),intent(in) :: emc ! canopy emissivity (-) - real(rk),intent(in) :: emg ! ground emissivity (-) + real(dp),intent(in) :: emc ! canopy emissivity (-) + real(dp),intent(in) :: emg ! ground emissivity (-) ! input: forcing - real(rk),intent(in) :: LWRadUbound ! downwelling longwave radiation at the upper boundary (W m-2) + real(dp),intent(in) :: LWRadUbound ! downwelling longwave radiation at the upper boundary (W m-2) ! output: sources - real(rk),intent(out) :: LWRadCanopy ! longwave radiation emitted from the canopy (W m-2) - real(rk),intent(out) :: LWRadGround ! longwave radiation emitted at the ground surface (W m-2) + real(dp),intent(out) :: LWRadCanopy ! longwave radiation emitted from the canopy (W m-2) + real(dp),intent(out) :: LWRadGround ! longwave radiation emitted at the ground surface (W m-2) ! output: individual fluxes - real(rk),intent(out) :: LWRadUbound2Canopy ! downward atmospheric longwave radiation absorbed by the canopy (W m-2) - real(rk),intent(out) :: LWRadUbound2Ground ! downward atmospheric longwave radiation absorbed by the ground (W m-2) - real(rk),intent(out) :: LWRadUbound2Ubound ! atmospheric radiation reflected by the ground and lost thru upper boundary (W m-2) - real(rk),intent(out) :: LWRadCanopy2Ubound ! longwave radiation emitted from canopy lost thru upper boundary (W m-2) - real(rk),intent(out) :: LWRadCanopy2Ground ! longwave radiation emitted from canopy absorbed by the ground (W m-2) - real(rk),intent(out) :: LWRadCanopy2Canopy ! canopy longwave reflected from ground and absorbed by the canopy (W m-2) - real(rk),intent(out) :: LWRadGround2Ubound ! longwave radiation emitted from ground lost thru upper boundary (W m-2) - real(rk),intent(out) :: LWRadGround2Canopy ! longwave radiation emitted from ground and absorbed by the canopy (W m-2) + real(dp),intent(out) :: LWRadUbound2Canopy ! downward atmospheric longwave radiation absorbed by the canopy (W m-2) + real(dp),intent(out) :: LWRadUbound2Ground ! downward atmospheric longwave radiation absorbed by the ground (W m-2) + real(dp),intent(out) :: LWRadUbound2Ubound ! atmospheric radiation reflected by the ground and lost thru upper boundary (W m-2) + real(dp),intent(out) :: LWRadCanopy2Ubound ! longwave radiation emitted from canopy lost thru upper boundary (W m-2) + real(dp),intent(out) :: LWRadCanopy2Ground ! longwave radiation emitted from canopy absorbed by the ground (W m-2) + real(dp),intent(out) :: LWRadCanopy2Canopy ! canopy longwave reflected from ground and absorbed by the canopy (W m-2) + real(dp),intent(out) :: LWRadGround2Ubound ! longwave radiation emitted from ground lost thru upper boundary (W m-2) + real(dp),intent(out) :: LWRadGround2Canopy ! longwave radiation emitted from ground and absorbed by the canopy (W m-2) ! output: net fluxes - real(rk),intent(out) :: LWNetCanopy ! net longwave radiation at the canopy (W m-2) - real(rk),intent(out) :: LWNetGround ! net longwave radiation at the ground surface (W m-2) - real(rk),intent(out) :: LWNetUbound ! net longwave radiation at the upper boundary (W m-2) + real(dp),intent(out) :: LWNetCanopy ! net longwave radiation at the canopy (W m-2) + real(dp),intent(out) :: LWNetGround ! net longwave radiation at the ground surface (W m-2) + real(dp),intent(out) :: LWNetUbound ! net longwave radiation at the upper boundary (W m-2) ! output: flux derivatives - real(rk),intent(out) :: dLWNetCanopy_dTCanopy ! derivative in net canopy radiation w.r.t. canopy temperature (W m-2 K-1) - real(rk),intent(out) :: dLWNetGround_dTGround ! derivative in net ground radiation w.r.t. ground temperature (W m-2 K-1) - real(rk),intent(out) :: dLWNetCanopy_dTGround ! derivative in net canopy radiation w.r.t. ground temperature (W m-2 K-1) - real(rk),intent(out) :: dLWNetGround_dTCanopy ! derivative in net ground radiation w.r.t. canopy temperature (W m-2 K-1) + real(dp),intent(out) :: dLWNetCanopy_dTCanopy ! derivative in net canopy radiation w.r.t. canopy temperature (W m-2 K-1) + real(dp),intent(out) :: dLWNetGround_dTGround ! derivative in net ground radiation w.r.t. ground temperature (W m-2 K-1) + real(dp),intent(out) :: dLWNetCanopy_dTGround ! derivative in net canopy radiation w.r.t. ground temperature (W m-2 K-1) + real(dp),intent(out) :: dLWNetGround_dTCanopy ! derivative in net ground radiation w.r.t. canopy temperature (W m-2 K-1) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message @@ -1790,16 +1790,16 @@ subroutine longwaveBal(& integer(i4b),parameter :: perturbStateGround=3 ! named variable to identify the case where we perturb the ground temperature integer(i4b) :: itry ! index of flux evaluation integer(i4b) :: nFlux ! number of flux evaluations - real(rk) :: TCan ! value of canopy temperature used in flux calculations (may be perturbed) - real(rk) :: TGnd ! value of ground temperature used in flux calculations (may be perturbed) - real(rk) :: fluxBalance ! check energy closure (W m-2) - real(rk),parameter :: fluxTolerance=1.e-10_rk ! tolerance for energy closure (W m-2) - real(rk) :: dLWRadCanopy_dTCanopy ! derivative in emitted radiation at the canopy w.r.t. canopy temperature - real(rk) :: dLWRadGround_dTGround ! derivative in emitted radiation at the ground w.r.t. ground temperature - real(rk) :: LWNetCanopy_dStateCanopy ! net lw canopy flux after perturbation in canopy temperature - real(rk) :: LWNetGround_dStateCanopy ! net lw ground flux after perturbation in canopy temperature - real(rk) :: LWNetCanopy_dStateGround ! net lw canopy flux after perturbation in ground temperature - real(rk) :: LWNetGround_dStateGround ! net lw ground flux after perturbation in ground temperature + real(dp) :: TCan ! value of canopy temperature used in flux calculations (may be perturbed) + real(dp) :: TGnd ! value of ground temperature used in flux calculations (may be perturbed) + real(dp) :: fluxBalance ! check energy closure (W m-2) + real(dp),parameter :: fluxTolerance=1.e-10_dp ! tolerance for energy closure (W m-2) + real(dp) :: dLWRadCanopy_dTCanopy ! derivative in emitted radiation at the canopy w.r.t. canopy temperature + real(dp) :: dLWRadGround_dTGround ! derivative in emitted radiation at the ground w.r.t. ground temperature + real(dp) :: LWNetCanopy_dStateCanopy ! net lw canopy flux after perturbation in canopy temperature + real(dp) :: LWNetGround_dStateCanopy ! net lw ground flux after perturbation in canopy temperature + real(dp) :: LWNetCanopy_dStateGround ! net lw canopy flux after perturbation in ground temperature + real(dp) :: LWNetGround_dStateGround ! net lw ground flux after perturbation in ground temperature ! ----------------------------------------------------------------------------------------------------------------------------------------------- ! initialize error control err=0; message='longwaveBal/' @@ -1851,28 +1851,28 @@ subroutine longwaveBal(& ! compute longwave fluxes from canopy and the ground if(computeVegFlux)then - LWRadCanopy = emc*sb*TCan**4._rk ! longwave radiation emitted from the canopy (W m-2) + LWRadCanopy = emc*sb*TCan**4._dp ! longwave radiation emitted from the canopy (W m-2) else - LWRadCanopy = 0._rk + LWRadCanopy = 0._dp end if - LWRadGround = emg*sb*TGnd**4._rk ! longwave radiation emitted at the ground surface (W m-2) + LWRadGround = emg*sb*TGnd**4._dp ! longwave radiation emitted at the ground surface (W m-2) ! compute fluxes originating from the atmosphere - LWRadUbound2Canopy = (emc + (1._rk - emc)*(1._rk - emg)*emc)*LWRadUbound ! downward atmospheric longwave radiation absorbed by the canopy (W m-2) - LWRadUbound2Ground = (1._rk - emc)*emg*LWRadUbound ! downward atmospheric longwave radiation absorbed by the ground (W m-2) - LWRadUbound2Ubound = (1._rk - emc)*(1._rk - emg)*(1._rk - emc)*LWRadUbound ! atmospheric radiation reflected by the ground and lost thru upper boundary (W m-2) + LWRadUbound2Canopy = (emc + (1._dp - emc)*(1._dp - emg)*emc)*LWRadUbound ! downward atmospheric longwave radiation absorbed by the canopy (W m-2) + LWRadUbound2Ground = (1._dp - emc)*emg*LWRadUbound ! downward atmospheric longwave radiation absorbed by the ground (W m-2) + LWRadUbound2Ubound = (1._dp - emc)*(1._dp - emg)*(1._dp - emc)*LWRadUbound ! atmospheric radiation reflected by the ground and lost thru upper boundary (W m-2) ! compute fluxes originating from the canopy - LWRadCanopy2Ubound = (1._rk + (1._rk - emc)*(1._rk - emg))*LWRadCanopy ! longwave radiation emitted from canopy lost thru upper boundary (W m-2) + LWRadCanopy2Ubound = (1._dp + (1._dp - emc)*(1._dp - emg))*LWRadCanopy ! longwave radiation emitted from canopy lost thru upper boundary (W m-2) LWRadCanopy2Ground = emg*LWRadCanopy ! longwave radiation emitted from canopy absorbed by the ground (W m-2) - LWRadCanopy2Canopy = emc*(1._rk - emg)*LWRadCanopy ! canopy longwave reflected from ground and absorbed by the canopy (W m-2) + LWRadCanopy2Canopy = emc*(1._dp - emg)*LWRadCanopy ! canopy longwave reflected from ground and absorbed by the canopy (W m-2) ! compute fluxes originating from the ground surface - LWRadGround2Ubound = (1._rk - emc)*LWRadGround ! longwave radiation emitted from ground lost thru upper boundary (W m-2) + LWRadGround2Ubound = (1._dp - emc)*LWRadGround ! longwave radiation emitted from ground lost thru upper boundary (W m-2) LWRadGround2Canopy = emc*LWRadGround ! longwave radiation emitted from ground and absorbed by the canopy (W m-2) ! compute net longwave radiation (W m-2) - LWNetCanopy = LWRadUbound2Canopy + LWRadGround2Canopy + LWRadCanopy2Canopy - 2._rk*LWRadCanopy ! canopy + LWNetCanopy = LWRadUbound2Canopy + LWRadGround2Canopy + LWRadCanopy2Canopy - 2._dp*LWRadCanopy ! canopy LWNetGround = LWRadUbound2Ground + LWRadCanopy2Ground - LWRadGround ! ground surface LWNetUbound = LWRadUbound - LWRadUbound2Ubound - LWRadCanopy2Ubound - LWRadGround2Ubound ! upper boundary @@ -1933,10 +1933,10 @@ subroutine longwaveBal(& ! ***** analytical derivatives case(analytical) ! compute initial derivatives - dLWRadCanopy_dTCanopy = 4._rk*emc*sb*TCan**3._rk - dLWRadGround_dTGround = 4._rk*emg*sb*TGnd**3._rk + dLWRadCanopy_dTCanopy = 4._dp*emc*sb*TCan**3._dp + dLWRadGround_dTGround = 4._dp*emg*sb*TGnd**3._dp ! compute analytical derivatives - dLWNetCanopy_dTCanopy = (emc*(1._rk - emg) - 2._rk)*dLWRadCanopy_dTCanopy ! derivative in net canopy radiation w.r.t. canopy temperature (W m-2 K-1) + dLWNetCanopy_dTCanopy = (emc*(1._dp - emg) - 2._dp)*dLWRadCanopy_dTCanopy ! derivative in net canopy radiation w.r.t. canopy temperature (W m-2 K-1) dLWNetGround_dTGround = -dLWRadGround_dTGround ! derivative in net ground radiation w.r.t. ground temperature (W m-2 K-1) dLWNetCanopy_dTGround = emc*dLWRadGround_dTGround ! derivative in net canopy radiation w.r.t. ground temperature (W m-2 K-1) dLWNetGround_dTCanopy = emg*dLWRadCanopy_dTCanopy ! derivative in net ground radiation w.r.t. canopy temperature (W m-2 K-1) @@ -2026,49 +2026,49 @@ subroutine aeroResist(& integer(i4b),intent(in) :: ixWindProfile ! choice of canopy wind profile integer(i4b),intent(in) :: ixStability ! choice of stability function ! input: above-canopy forcing data - real(rk),intent(in) :: mHeight ! measurement height (m) - real(rk),intent(in) :: airtemp ! air temperature at some height above the surface (K) - real(rk),intent(in) :: windspd ! wind speed at some height above the surface (m s-1) + real(dp),intent(in) :: mHeight ! measurement height (m) + real(dp),intent(in) :: airtemp ! air temperature at some height above the surface (K) + real(dp),intent(in) :: windspd ! wind speed at some height above the surface (m s-1) ! input: temperature (canopy, ground, canopy air space) - real(rk),intent(in) :: canairTemp ! temperature of the canopy air space (K) - real(rk),intent(in) :: groundTemp ! ground temperature (K) + real(dp),intent(in) :: canairTemp ! temperature of the canopy air space (K) + real(dp),intent(in) :: groundTemp ! ground temperature (K) ! input: diagnostic variables - real(rk),intent(in) :: exposedVAI ! exposed vegetation area index -- leaf plus stem (m2 m-2) - real(rk),intent(in) :: snowDepth ! snow depth (m) + real(dp),intent(in) :: exposedVAI ! exposed vegetation area index -- leaf plus stem (m2 m-2) + real(dp),intent(in) :: snowDepth ! snow depth (m) ! input: parameters - real(rk),intent(in) :: z0Ground ! roughness length of the ground (below canopy or non-vegetated surface [snow]) (m) - real(rk),intent(in) :: z0CanopyParam ! roughness length of the canopy (m) - real(rk),intent(in) :: zpdFraction ! zero plane displacement / canopy height (-) - real(rk),intent(in) :: critRichNumber ! critical value for the bulk Richardson number where turbulence ceases (-) - real(rk),intent(in) :: Louis79_bparam ! parameter in Louis (1979) stability function - real(rk),intent(in) :: Mahrt87_eScale ! exponential scaling factor in the Mahrt (1987) stability function - real(rk),intent(in) :: windReductionParam ! canopy wind reduction parameter (-) - real(rk),intent(in) :: leafExchangeCoeff ! turbulent exchange coeff between canopy surface and canopy air ( m s-(1/2) ) - real(rk),intent(in) :: leafDimension ! characteristic leaf dimension (m) - real(rk),intent(in) :: heightCanopyTop ! height at the top of the vegetation canopy (m) - real(rk),intent(in) :: heightCanopyBottom ! height at the bottom of the vegetation canopy (m) + real(dp),intent(in) :: z0Ground ! roughness length of the ground (below canopy or non-vegetated surface [snow]) (m) + real(dp),intent(in) :: z0CanopyParam ! roughness length of the canopy (m) + real(dp),intent(in) :: zpdFraction ! zero plane displacement / canopy height (-) + real(dp),intent(in) :: critRichNumber ! critical value for the bulk Richardson number where turbulence ceases (-) + real(dp),intent(in) :: Louis79_bparam ! parameter in Louis (1979) stability function + real(dp),intent(in) :: Mahrt87_eScale ! exponential scaling factor in the Mahrt (1987) stability function + real(dp),intent(in) :: windReductionParam ! canopy wind reduction parameter (-) + real(dp),intent(in) :: leafExchangeCoeff ! turbulent exchange coeff between canopy surface and canopy air ( m s-(1/2) ) + real(dp),intent(in) :: leafDimension ! characteristic leaf dimension (m) + real(dp),intent(in) :: heightCanopyTop ! height at the top of the vegetation canopy (m) + real(dp),intent(in) :: heightCanopyBottom ! height at the bottom of the vegetation canopy (m) ! output: stability corrections - real(rk),intent(out) :: RiBulkCanopy ! bulk Richardson number for the canopy (-) - real(rk),intent(out) :: RiBulkGround ! bulk Richardson number for the ground surface (-) - real(rk),intent(out) :: canopyStabilityCorrection ! stability correction for the canopy (-) - real(rk),intent(out) :: groundStabilityCorrection ! stability correction for the ground surface (-) + real(dp),intent(out) :: RiBulkCanopy ! bulk Richardson number for the canopy (-) + real(dp),intent(out) :: RiBulkGround ! bulk Richardson number for the ground surface (-) + real(dp),intent(out) :: canopyStabilityCorrection ! stability correction for the canopy (-) + real(dp),intent(out) :: groundStabilityCorrection ! stability correction for the ground surface (-) ! output: scalar resistances - real(rk),intent(out) :: z0Canopy ! roughness length of the vegetation canopy (m) - real(rk),intent(out) :: windReductionFactor ! canopy wind reduction factor (-) - real(rk),intent(out) :: zeroPlaneDisplacement ! zero plane displacement (m) - real(rk),intent(out) :: eddyDiffusCanopyTop ! eddy diffusivity for heat at the top of the canopy (m2 s-1) - real(rk),intent(out) :: frictionVelocity ! friction velocity (m s-1) - real(rk),intent(out) :: windspdCanopyTop ! windspeed at the top of the canopy (m s-1) - real(rk),intent(out) :: windspdCanopyBottom ! windspeed at the height of the bottom of the canopy (m s-1) - real(rk),intent(out) :: leafResistance ! mean leaf boundary layer resistance per unit leaf area (s m-1) - real(rk),intent(out) :: groundResistance ! below canopy aerodynamic resistance (s m-1) - real(rk),intent(out) :: canopyResistance ! above canopy aerodynamic resistance (s m-1) + real(dp),intent(out) :: z0Canopy ! roughness length of the vegetation canopy (m) + real(dp),intent(out) :: windReductionFactor ! canopy wind reduction factor (-) + real(dp),intent(out) :: zeroPlaneDisplacement ! zero plane displacement (m) + real(dp),intent(out) :: eddyDiffusCanopyTop ! eddy diffusivity for heat at the top of the canopy (m2 s-1) + real(dp),intent(out) :: frictionVelocity ! friction velocity (m s-1) + real(dp),intent(out) :: windspdCanopyTop ! windspeed at the top of the canopy (m s-1) + real(dp),intent(out) :: windspdCanopyBottom ! windspeed at the height of the bottom of the canopy (m s-1) + real(dp),intent(out) :: leafResistance ! mean leaf boundary layer resistance per unit leaf area (s m-1) + real(dp),intent(out) :: groundResistance ! below canopy aerodynamic resistance (s m-1) + real(dp),intent(out) :: canopyResistance ! above canopy aerodynamic resistance (s m-1) ! output: derivatives in scalar resistances - real(rk),intent(out) :: dGroundResistance_dTGround ! derivative in ground resistance w.r.t. ground temperature (s m-1 K-1) - real(rk),intent(out) :: dGroundResistance_dTCanopy ! derivative in ground resistance w.r.t. canopy temperature (s m-1 K-1) - real(rk),intent(out) :: dGroundResistance_dTCanair ! derivative in ground resistance w.r.t. canopy air temperature (s m-1 K-1) - real(rk),intent(out) :: dCanopyResistance_dTCanopy ! derivative in canopy resistance w.r.t. canopy temperature (s m-1 K-1) - real(rk),intent(out) :: dCanopyResistance_dTCanair ! derivative in canopy resistance w.r.t. canopy air temperature (s m-1 K-1) + real(dp),intent(out) :: dGroundResistance_dTGround ! derivative in ground resistance w.r.t. ground temperature (s m-1 K-1) + real(dp),intent(out) :: dGroundResistance_dTCanopy ! derivative in ground resistance w.r.t. canopy temperature (s m-1 K-1) + real(dp),intent(out) :: dGroundResistance_dTCanair ! derivative in ground resistance w.r.t. canopy air temperature (s m-1 K-1) + real(dp),intent(out) :: dCanopyResistance_dTCanopy ! derivative in canopy resistance w.r.t. canopy temperature (s m-1 K-1) + real(dp),intent(out) :: dCanopyResistance_dTCanair ! derivative in canopy resistance w.r.t. canopy air temperature (s m-1 K-1) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message @@ -2076,45 +2076,45 @@ subroutine aeroResist(& ! local variables: general character(LEN=256) :: cmessage ! error message of downwind routine ! local variables: vegetation roughness and dispalcement height - real(rk),parameter :: oneThird=1._rk/3._rk ! 1/3 - real(rk),parameter :: twoThirds=2._rk/3._rk ! 2/3 - real(rk),parameter :: C_r = 0.3 ! roughness element drag coefficient (-) from Raupach (BLM, 1994) - real(rk),parameter :: C_s = 0.003_rk ! substrate surface drag coefficient (-) from Raupach (BLM, 1994) - real(rk),parameter :: approxDragCoef_max = 0.3_rk ! maximum value of the approximate drag coefficient (-) from Raupach (BLM, 1994) - real(rk),parameter :: psi_h = 0.193_rk ! roughness sub-layer influence function (-) from Raupach (BLM, 1994) - real(rk),parameter :: c_d1 = 7.5_rk ! scaling parameter used to define displacement height (-) from Raupach (BLM, 1994) - real(rk),parameter :: cd_CM = 0.2_rk ! mean drag coefficient for individual leaves (-) from Choudhury and Monteith (QJRMS, 1988) - real(rk) :: funcLAI ! temporary variable to calculate zero plane displacement for the canopy - real(rk) :: fracCanopyHeight ! zero plane displacement expressed as a fraction of canopy height - real(rk) :: approxDragCoef ! approximate drag coefficient used in the computation of canopy roughness length (-) + real(dp),parameter :: oneThird=1._dp/3._dp ! 1/3 + real(dp),parameter :: twoThirds=2._dp/3._dp ! 2/3 + real(dp),parameter :: C_r = 0.3 ! roughness element drag coefficient (-) from Raupach (BLM, 1994) + real(dp),parameter :: C_s = 0.003_dp ! substrate surface drag coefficient (-) from Raupach (BLM, 1994) + real(dp),parameter :: approxDragCoef_max = 0.3_dp ! maximum value of the approximate drag coefficient (-) from Raupach (BLM, 1994) + real(dp),parameter :: psi_h = 0.193_dp ! roughness sub-layer influence function (-) from Raupach (BLM, 1994) + real(dp),parameter :: c_d1 = 7.5_dp ! scaling parameter used to define displacement height (-) from Raupach (BLM, 1994) + real(dp),parameter :: cd_CM = 0.2_dp ! mean drag coefficient for individual leaves (-) from Choudhury and Monteith (QJRMS, 1988) + real(dp) :: funcLAI ! temporary variable to calculate zero plane displacement for the canopy + real(dp) :: fracCanopyHeight ! zero plane displacement expressed as a fraction of canopy height + real(dp) :: approxDragCoef ! approximate drag coefficient used in the computation of canopy roughness length (-) ! local variables: resistance - real(rk) :: canopyExNeut ! surface-atmosphere exchange coefficient under neutral conditions (-) - real(rk) :: groundExNeut ! surface-atmosphere exchange coefficient under neutral conditions (-) - real(rk) :: sfc2AtmExchangeCoeff_canopy ! surface-atmosphere exchange coefficient after stability corrections (-) - real(rk) :: groundResistanceNeutral ! ground resistance under neutral conditions (s m-1) - real(rk) :: windConvFactor_fv ! factor to convert friction velocity to wind speed at top of canopy (-) - real(rk) :: windConvFactor ! factor to convert wind speed at top of canopy to wind speed at a given height in the canopy (-) - real(rk) :: referenceHeight ! z0Canopy+zeroPlaneDisplacement (m) - real(rk) :: windspdRefHeight ! windspeed at the reference height (m/s) - real(rk) :: heightAboveGround ! height above the snow surface (m) - real(rk) :: heightCanopyTopAboveSnow ! height at the top of the vegetation canopy relative to snowpack (m) - real(rk) :: heightCanopyBottomAboveSnow ! height at the bottom of the vegetation canopy relative to snowpack (m) - real(rk),parameter :: xTolerance=0.1_rk ! tolerance to handle the transition from exponential to log-below canopy + real(dp) :: canopyExNeut ! surface-atmosphere exchange coefficient under neutral conditions (-) + real(dp) :: groundExNeut ! surface-atmosphere exchange coefficient under neutral conditions (-) + real(dp) :: sfc2AtmExchangeCoeff_canopy ! surface-atmosphere exchange coefficient after stability corrections (-) + real(dp) :: groundResistanceNeutral ! ground resistance under neutral conditions (s m-1) + real(dp) :: windConvFactor_fv ! factor to convert friction velocity to wind speed at top of canopy (-) + real(dp) :: windConvFactor ! factor to convert wind speed at top of canopy to wind speed at a given height in the canopy (-) + real(dp) :: referenceHeight ! z0Canopy+zeroPlaneDisplacement (m) + real(dp) :: windspdRefHeight ! windspeed at the reference height (m/s) + real(dp) :: heightAboveGround ! height above the snow surface (m) + real(dp) :: heightCanopyTopAboveSnow ! height at the top of the vegetation canopy relative to snowpack (m) + real(dp) :: heightCanopyBottomAboveSnow ! height at the bottom of the vegetation canopy relative to snowpack (m) + real(dp),parameter :: xTolerance=0.1_dp ! tolerance to handle the transition from exponential to log-below canopy ! local variables: derivatives - real(rk) :: dFV_dT ! derivative in friction velocity w.r.t. canopy air temperature - real(rk) :: dED_dT ! derivative in eddy diffusivity at the top of the canopy w.r.t. canopy air temperature - real(rk) :: dGR_dT ! derivative in neutral ground resistance w.r.t. canopy air temperature - real(rk) :: tmp1,tmp2 ! temporary variables used in calculation of ground resistance - real(rk) :: dCanopyStabilityCorrection_dRich ! derivative in stability correction w.r.t. Richardson number for the canopy (-) - real(rk) :: dGroundStabilityCorrection_dRich ! derivative in stability correction w.r.t. Richardson number for the ground surface (-) - real(rk) :: dCanopyStabilityCorrection_dAirTemp ! (not used) derivative in stability correction w.r.t. air temperature (K-1) - real(rk) :: dGroundStabilityCorrection_dAirTemp ! (not used) derivative in stability correction w.r.t. air temperature (K-1) - real(rk) :: dCanopyStabilityCorrection_dCasTemp ! derivative in canopy stability correction w.r.t. canopy air space temperature (K-1) - real(rk) :: dGroundStabilityCorrection_dCasTemp ! derivative in ground stability correction w.r.t. canopy air space temperature (K-1) - real(rk) :: dGroundStabilityCorrection_dSfcTemp ! derivative in ground stability correction w.r.t. surface temperature (K-1) - real(rk) :: singleLeafConductance ! leaf boundary layer conductance (m s-1) - real(rk) :: canopyLeafConductance ! leaf boundary layer conductance -- scaled up to the canopy (m s-1) - real(rk) :: leaf2CanopyScaleFactor ! factor to scale from the leaf to the canopy [m s-(1/2)] + real(dp) :: dFV_dT ! derivative in friction velocity w.r.t. canopy air temperature + real(dp) :: dED_dT ! derivative in eddy diffusivity at the top of the canopy w.r.t. canopy air temperature + real(dp) :: dGR_dT ! derivative in neutral ground resistance w.r.t. canopy air temperature + real(dp) :: tmp1,tmp2 ! temporary variables used in calculation of ground resistance + real(dp) :: dCanopyStabilityCorrection_dRich ! derivative in stability correction w.r.t. Richardson number for the canopy (-) + real(dp) :: dGroundStabilityCorrection_dRich ! derivative in stability correction w.r.t. Richardson number for the ground surface (-) + real(dp) :: dCanopyStabilityCorrection_dAirTemp ! (not used) derivative in stability correction w.r.t. air temperature (K-1) + real(dp) :: dGroundStabilityCorrection_dAirTemp ! (not used) derivative in stability correction w.r.t. air temperature (K-1) + real(dp) :: dCanopyStabilityCorrection_dCasTemp ! derivative in canopy stability correction w.r.t. canopy air space temperature (K-1) + real(dp) :: dGroundStabilityCorrection_dCasTemp ! derivative in ground stability correction w.r.t. canopy air space temperature (K-1) + real(dp) :: dGroundStabilityCorrection_dSfcTemp ! derivative in ground stability correction w.r.t. surface temperature (K-1) + real(dp) :: singleLeafConductance ! leaf boundary layer conductance (m s-1) + real(dp) :: canopyLeafConductance ! leaf boundary layer conductance -- scaled up to the canopy (m s-1) + real(dp) :: leaf2CanopyScaleFactor ! factor to scale from the leaf to the canopy [m s-(1/2)] ! ----------------------------------------------------------------------------------------------------------------------------------------- ! initialize error control err=0; message='aeroResist/' @@ -2132,27 +2132,27 @@ subroutine aeroResist(& ! First, calculate new coordinate system above snow - use these to scale wind profiles and resistances ! NOTE: the new coordinate system makes zeroPlaneDisplacement and z0Canopy consistent heightCanopyTopAboveSnow = heightCanopyTop - snowDepth - heightCanopyBottomAboveSnow = max(heightCanopyBottom - snowDepth, 0.0_rk) + heightCanopyBottomAboveSnow = max(heightCanopyBottom - snowDepth, 0.0_dp) select case(ixVegTraits) ! Raupach (BLM 1994) "Simplified expressions..." case(Raupach_BLM1994) ! (compute zero-plane displacement) funcLAI = sqrt(c_d1*exposedVAI) - fracCanopyHeight = -(1._rk - exp(-funcLAI))/funcLAI + 1._rk + fracCanopyHeight = -(1._dp - exp(-funcLAI))/funcLAI + 1._dp zeroPlaneDisplacement = fracCanopyHeight*(heightCanopyTopAboveSnow-heightCanopyBottomAboveSnow)+heightCanopyBottomAboveSnow ! (coupute roughness length of the veg canopy) - approxDragCoef = min( sqrt(C_s + C_r*exposedVAI/2._rk), approxDragCoef_max) - z0Canopy = (1._rk - fracCanopyHeight) * exp(-vkc*approxDragCoef - psi_h) * (heightCanopyTopAboveSnow-heightCanopyBottomAboveSnow) + approxDragCoef = min( sqrt(C_s + C_r*exposedVAI/2._dp), approxDragCoef_max) + z0Canopy = (1._dp - fracCanopyHeight) * exp(-vkc*approxDragCoef - psi_h) * (heightCanopyTopAboveSnow-heightCanopyBottomAboveSnow) ! Choudhury and Monteith (QJRMS 1988) "A four layer model for the heat budget..." case(CM_QJRMS1988) funcLAI = cd_CM*exposedVAI - zeroPlaneDisplacement = 1.1_rk*heightCanopyTopAboveSnow*log(1._rk + funcLAI**0.25_rk) - if(funcLAI < 0.2_rk)then - z0Canopy = z0Ground + 0.3_rk*heightCanopyTopAboveSnow*funcLAI**0.5_rk + zeroPlaneDisplacement = 1.1_dp*heightCanopyTopAboveSnow*log(1._dp + funcLAI**0.25_dp) + if(funcLAI < 0.2_dp)then + z0Canopy = z0Ground + 0.3_dp*heightCanopyTopAboveSnow*funcLAI**0.5_dp else - z0Canopy = 0.3_rk*heightCanopyTopAboveSnow*(1._rk - zeroPlaneDisplacement/heightCanopyTopAboveSnow) + z0Canopy = 0.3_dp*heightCanopyTopAboveSnow*(1._dp - zeroPlaneDisplacement/heightCanopyTopAboveSnow) end if ! constant parameters dependent on the vegetation type @@ -2205,15 +2205,15 @@ subroutine aeroResist(& if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! compute turbulent exchange coefficient (-) - canopyExNeut = (vkc**2._rk) / ( log((mHeight - zeroPlaneDisplacement)/z0Canopy))**2._rk ! coefficient under conditions of neutral stability + canopyExNeut = (vkc**2._dp) / ( log((mHeight - zeroPlaneDisplacement)/z0Canopy))**2._dp ! coefficient under conditions of neutral stability sfc2AtmExchangeCoeff_canopy = canopyExNeut*canopyStabilityCorrection ! after stability corrections ! compute the friction velocity (m s-1) frictionVelocity = windspd * sqrt(sfc2AtmExchangeCoeff_canopy) ! compute the above-canopy resistance (s m-1) - canopyResistance = 1._rk/(sfc2AtmExchangeCoeff_canopy*windspd) - if(canopyResistance < 0._rk)then; err=20; message=trim(message)//'canopy resistance < 0'; return; end if + canopyResistance = 1._dp/(sfc2AtmExchangeCoeff_canopy*windspd) + if(canopyResistance < 0._dp)then; err=20; message=trim(message)//'canopy resistance < 0'; return; end if ! compute windspeed at the top of the canopy above snow depth (m s-1) ! NOTE: stability corrections cancel out @@ -2226,19 +2226,19 @@ subroutine aeroResist(& ! compute windspeed at the height z0Canopy+zeroPlaneDisplacement (m s-1) referenceHeight = z0Canopy+zeroPlaneDisplacement - windConvFactor = exp(-windReductionFactor*(1._rk - (referenceHeight/heightCanopyTopAboveSnow))) + windConvFactor = exp(-windReductionFactor*(1._dp - (referenceHeight/heightCanopyTopAboveSnow))) windspdRefHeight = windspdCanopyTop*windConvFactor ! compute windspeed at the bottom of the canopy relative to the snow depth (m s-1) - windConvFactor = exp(-windReductionFactor*(1._rk - (heightCanopyBottomAboveSnow/heightCanopyTopAboveSnow))) + windConvFactor = exp(-windReductionFactor*(1._dp - (heightCanopyBottomAboveSnow/heightCanopyTopAboveSnow))) windspdCanopyBottom = windspdCanopyTop*windConvFactor ! compute the leaf boundary layer resistance (s m-1) singleLeafConductance = leafExchangeCoeff*sqrt(windspdCanopyTop/leafDimension) - leaf2CanopyScaleFactor = (2._rk/windReductionFactor) * (1._rk - exp(-windReductionFactor/2._rk)) ! factor to scale from the leaf to the canopy + leaf2CanopyScaleFactor = (2._dp/windReductionFactor) * (1._dp - exp(-windReductionFactor/2._dp)) ! factor to scale from the leaf to the canopy canopyLeafConductance = singleLeafConductance*leaf2CanopyScaleFactor - leafResistance = 1._rk/(canopyLeafConductance) - if(leafResistance < 0._rk)then; err=20; message=trim(message)//'leaf resistance < 0'; return; end if + leafResistance = 1._dp/(canopyLeafConductance) + if(leafResistance < 0._dp)then; err=20; message=trim(message)//'leaf resistance < 0'; return; end if ! compute eddy diffusivity for heat at the top of the canopy (m2 s-1) ! Note: use of friction velocity here includes stability adjustments @@ -2265,7 +2265,7 @@ subroutine aeroResist(& tmp2 = exp(-windReductionFactor*(z0Canopy+zeroPlaneDisplacement)/heightCanopyTopAboveSnow) groundResistanceNeutral = ( heightCanopyTopAboveSnow*exp(windReductionFactor) / (windReductionFactor*eddyDiffusCanopyTop) ) * (tmp1 - tmp2) ! (add log-below-canopy component) - groundResistanceNeutral = groundResistanceNeutral + (1._rk/(max(0.1_rk,windspdCanopyBottom)*vkc**2._rk))*(log(heightCanopyBottomAboveSnow/z0Ground))**2._rk + groundResistanceNeutral = groundResistanceNeutral + (1._dp/(max(0.1_dp,windspdCanopyBottom)*vkc**2._dp))*(log(heightCanopyBottomAboveSnow/z0Ground))**2._dp endif ! switch between exponential profile and log-below-canopy @@ -2279,7 +2279,7 @@ subroutine aeroResist(& referenceHeight, & ! input: height of the canopy air space temperature/wind (m) canairTemp, & ! input: temperature of the canopy air space (K) groundTemp, & ! input: temperature of the ground surface (K) - max(0.1_rk,windspdRefHeight), & ! input: wind speed at height z0Canopy+zeroPlaneDisplacement (m s-1) + max(0.1_dp,windspdRefHeight), & ! input: wind speed at height z0Canopy+zeroPlaneDisplacement (m s-1) ! input: stability parameters critRichNumber, & ! input: critical value for the bulk Richardson number where turbulence ceases (-) Louis79_bparam, & ! input: parameter in Louis (1979) stability function @@ -2295,7 +2295,7 @@ subroutine aeroResist(& ! compute the ground resistance groundResistance = groundResistanceNeutral / groundStabilityCorrection - if(groundResistance < 0._rk)then; err=20; message=trim(message)//'ground resistance < 0 [vegetation is present]'; return; end if + if(groundResistance < 0._dp)then; err=20; message=trim(message)//'ground resistance < 0 [vegetation is present]'; return; end if ! ----------------------------------------------------------------------------------------------------------------------------------------- ! ----------------------------------------------------------------------------------------------------------------------------------------- @@ -2303,15 +2303,15 @@ subroutine aeroResist(& else ! no canopy, so set huge resistances (not used) - canopyResistance = 1.e12_rk ! not used: huge resistance, so conductance is essentially zero - leafResistance = 1.e12_rk ! not used: huge resistance, so conductance is essentially zero + canopyResistance = 1.e12_dp ! not used: huge resistance, so conductance is essentially zero + leafResistance = 1.e12_dp ! not used: huge resistance, so conductance is essentially zero ! check that measurement height above the ground surface is above the roughness length if(mHeight < snowDepth+z0Ground)then; err=20; message=trim(message)//'measurement height < snow depth + roughness length'; return; end if ! compute the resistance between the surface and canopy air UNDER NEUTRAL CONDITIONS (s m-1) - groundExNeut = (vkc**2._rk) / ( log((mHeight - snowDepth)/z0Ground)**2._rk) ! turbulent transfer coefficient under conditions of neutral stability (-) - groundResistanceNeutral = 1._rk / (groundExNeut*windspd) + groundExNeut = (vkc**2._dp) / ( log((mHeight - snowDepth)/z0Ground)**2._dp) ! turbulent transfer coefficient under conditions of neutral stability (-) + groundResistanceNeutral = 1._dp / (groundExNeut*windspd) ! define height above the snow surface heightAboveGround = mHeight - snowDepth @@ -2351,7 +2351,7 @@ subroutine aeroResist(& ! compute the ground resistance (after stability corrections) groundResistance = groundResistanceNeutral/groundStabilityCorrection - if(groundResistance < 0._rk)then; err=20; message=trim(message)//'ground resistance < 0 [no vegetation]'; return; end if + if(groundResistance < 0._dp)then; err=20; message=trim(message)//'ground resistance < 0 [no vegetation]'; return; end if ! set all canopy variables to missing (no canopy!) z0Canopy = missingValue ! roughness length of the vegetation canopy (m) @@ -2378,32 +2378,32 @@ subroutine aeroResist(& ! ***** compute derivatives w.r.t. canopy temperature ! NOTE: derivatives are zero because using canopy air space temperature - dCanopyResistance_dTCanopy = 0._rk ! derivative in canopy resistance w.r.t. canopy temperature (s m-1 K-1) - dGroundResistance_dTCanopy = 0._rk ! derivative in ground resistance w.r.t. canopy temperature (s m-1 K-1) + dCanopyResistance_dTCanopy = 0._dp ! derivative in canopy resistance w.r.t. canopy temperature (s m-1 K-1) + dGroundResistance_dTCanopy = 0._dp ! derivative in ground resistance w.r.t. canopy temperature (s m-1 K-1) ! ***** compute derivatives w.r.t. ground temperature (s m-1 K-1) - dGroundResistance_dTGround = -(groundResistanceNeutral*dGroundStabilityCorrection_dSfcTemp)/(groundStabilityCorrection**2._rk) + dGroundResistance_dTGround = -(groundResistanceNeutral*dGroundStabilityCorrection_dSfcTemp)/(groundStabilityCorrection**2._dp) ! ***** compute derivatives w.r.t. temperature of the canopy air space (s m-1 K-1) ! derivative in canopy resistance w.r.t. canopy air temperature (s m-1 K-1) - dCanopyResistance_dTCanair = -dCanopyStabilityCorrection_dCasTemp/(windspd*canopyExNeut*canopyStabilityCorrection**2._rk) + dCanopyResistance_dTCanair = -dCanopyStabilityCorrection_dCasTemp/(windspd*canopyExNeut*canopyStabilityCorrection**2._dp) ! derivative in ground resistance w.r.t. canopy air temperature (s m-1 K-1) ! (compute derivative in NEUTRAL ground resistance w.r.t. canopy air temperature (s m-1 K-1)) - dFV_dT = windspd*canopyExNeut*dCanopyStabilityCorrection_dCasTemp/(sqrt(sfc2AtmExchangeCoeff_canopy)*2._rk) ! d(frictionVelocity)/d(canopy air temperature) + dFV_dT = windspd*canopyExNeut*dCanopyStabilityCorrection_dCasTemp/(sqrt(sfc2AtmExchangeCoeff_canopy)*2._dp) ! d(frictionVelocity)/d(canopy air temperature) dED_dT = dFV_dT*vkc*(heightCanopyTopAboveSnow - zeroPlaneDisplacement) ! d(eddyDiffusCanopyTop)d(canopy air temperature) - dGR_dT = -dED_dT*(tmp1 - tmp2)*heightCanopyTopAboveSnow*exp(windReductionFactor) / (windReductionFactor*eddyDiffusCanopyTop**2._rk) ! d(groundResistanceNeutral)/d(canopy air temperature) + dGR_dT = -dED_dT*(tmp1 - tmp2)*heightCanopyTopAboveSnow*exp(windReductionFactor) / (windReductionFactor*eddyDiffusCanopyTop**2._dp) ! d(groundResistanceNeutral)/d(canopy air temperature) ! (stitch everything together -- product rule) - dGroundResistance_dTCanair = dGR_dT/groundStabilityCorrection - groundResistanceNeutral*dGroundStabilityCorrection_dCasTemp/(groundStabilityCorrection**2._rk) + dGroundResistance_dTCanair = dGR_dT/groundStabilityCorrection - groundResistanceNeutral*dGroundStabilityCorrection_dCasTemp/(groundStabilityCorrection**2._dp) ! ***** compute resistances for non-vegetated surfaces (e.g., snow) else ! set canopy derivatives to zero (non-vegetated, remember) - dCanopyResistance_dTCanopy = 0._rk - dGroundResistance_dTCanopy = 0._rk + dCanopyResistance_dTCanopy = 0._dp + dGroundResistance_dTCanopy = 0._dp ! compute derivatives for ground resistance - dGroundResistance_dTGround = -dGroundStabilityCorrection_dSfcTemp/(windspd*groundExNeut*groundStabilityCorrection**2._rk) + dGroundResistance_dTGround = -dGroundStabilityCorrection_dSfcTemp/(windspd*groundExNeut*groundStabilityCorrection**2._dp) end if ! (switch between vegetated and non-vegetated surfaces) @@ -2456,33 +2456,33 @@ subroutine soilResist(& integer(i4b),intent(in) :: ixSoilResist ! choice of function for the soil moisture control on stomatal resistance integer(i4b),intent(in) :: ixGroundwater ! choice of groundwater representation ! input (variables) - real(rk),intent(in) :: mLayerMatricHead(:) ! matric head in each layer (m) - real(rk),intent(in) :: mLayerVolFracLiq(:) ! volumetric fraction of liquid water in each layer (-) - real(rk),intent(in) :: scalarAquiferStorage ! aquifer storage (m) + real(dp),intent(in) :: mLayerMatricHead(:) ! matric head in each layer (m) + real(dp),intent(in) :: mLayerVolFracLiq(:) ! volumetric fraction of liquid water in each layer (-) + real(dp),intent(in) :: scalarAquiferStorage ! aquifer storage (m) ! input (diagnostic variables) - real(rk),intent(in) :: mLayerRootDensity(:) ! root density in each layer (-) - real(rk),intent(in) :: scalarAquiferRootFrac ! fraction of roots below the lowest unsaturated layer (-) + real(dp),intent(in) :: mLayerRootDensity(:) ! root density in each layer (-) + real(dp),intent(in) :: scalarAquiferRootFrac ! fraction of roots below the lowest unsaturated layer (-) ! input (parameters) - real(rk),intent(in) :: plantWiltPsi ! matric head at wilting point (m) - real(rk),intent(in) :: soilStressParam ! parameter in the exponential soil stress function (-) - real(rk),intent(in) :: critSoilWilting ! critical vol. liq. water content when plants are wilting (-) - real(rk),intent(in) :: critSoilTranspire ! critical vol. liq. water content when transpiration is limited (-) - real(rk),intent(in) :: critAquiferTranspire ! critical aquifer storage value when transpiration is limited (m) + real(dp),intent(in) :: plantWiltPsi ! matric head at wilting point (m) + real(dp),intent(in) :: soilStressParam ! parameter in the exponential soil stress function (-) + real(dp),intent(in) :: critSoilWilting ! critical vol. liq. water content when plants are wilting (-) + real(dp),intent(in) :: critSoilTranspire ! critical vol. liq. water content when transpiration is limited (-) + real(dp),intent(in) :: critAquiferTranspire ! critical aquifer storage value when transpiration is limited (m) ! output - real(rk),intent(out) :: wAvgTranspireLimitFac ! intent(out): weighted average of the transpiration limiting factor (-) - real(rk),intent(out) :: mLayerTranspireLimitFac(:) ! intent(out): transpiration limiting factor in each layer (-) - real(rk),intent(out) :: aquiferTranspireLimitFac ! intent(out): transpiration limiting factor for the aquifer (-) + real(dp),intent(out) :: wAvgTranspireLimitFac ! intent(out): weighted average of the transpiration limiting factor (-) + real(dp),intent(out) :: mLayerTranspireLimitFac(:) ! intent(out): transpiration limiting factor in each layer (-) + real(dp),intent(out) :: aquiferTranspireLimitFac ! intent(out): transpiration limiting factor for the aquifer (-) integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! local variables - real(rk) :: gx ! stress function for the soil layers - real(rk),parameter :: verySmall=epsilon(gx) ! a very small number + real(dp) :: gx ! stress function for the soil layers + real(dp),parameter :: verySmall=epsilon(gx) ! a very small number integer(i4b) :: iLayer ! index of soil layer ! initialize error control err=0; message='soilResist/' ! ** compute the factor limiting transpiration for each soil layer (-) - wAvgTranspireLimitFac = 0._rk ! (initialize the weighted average) + wAvgTranspireLimitFac = 0._dp ! (initialize the weighted average) do iLayer=1,size(mLayerMatricHead) ! compute the soil stress function select case(ixSoilResist) @@ -2490,21 +2490,21 @@ subroutine soilResist(& gx = (mLayerVolFracLiq(iLayer) - critSoilWilting) / (critSoilTranspire - critSoilWilting) case(CLM_Type) ! thresholded linear function of matric head if(mLayerMatricHead(iLayer) > plantWiltPsi)then - gx = 1._rk - mLayerMatricHead(iLayer)/plantWiltPsi + gx = 1._dp - mLayerMatricHead(iLayer)/plantWiltPsi else - gx = 0._rk + gx = 0._dp end if case(SiB_Type) ! exponential of the log of matric head - if(mLayerMatricHead(iLayer) < 0._rk)then ! (unsaturated) - gx = 1._rk - exp( -soilStressParam * ( log(plantWiltPsi/mLayerMatricHead(iLayer)) ) ) + if(mLayerMatricHead(iLayer) < 0._dp)then ! (unsaturated) + gx = 1._dp - exp( -soilStressParam * ( log(plantWiltPsi/mLayerMatricHead(iLayer)) ) ) else ! (saturated) - gx = 1._rk + gx = 1._dp end if case default ! check identified the option err=20; message=trim(message)//'cannot identify option for soil resistance'; return end select ! save the factor for the given layer (ensure between zero and one) - mLayerTranspireLimitFac(iLayer) = min( max(verySmall,gx), 1._rk) + mLayerTranspireLimitFac(iLayer) = min( max(verySmall,gx), 1._dp) ! compute the weighted average (weighted by root density) wAvgTranspireLimitFac = wAvgTranspireLimitFac + mLayerTranspireLimitFac(iLayer)*mLayerRootDensity(iLayer) end do ! (looping through soil layers) @@ -2517,9 +2517,9 @@ subroutine soilResist(& err=20; return end if ! compute the factor limiting evaporation for the aquifer - aquiferTranspireLimitFac = min(scalarAquiferStorage/critAquiferTranspire, 1._rk) + aquiferTranspireLimitFac = min(scalarAquiferStorage/critAquiferTranspire, 1._dp) else ! (if there are roots in the aquifer) - aquiferTranspireLimitFac = 0._rk + aquiferTranspireLimitFac = 0._dp end if ! compute the weighted average (weighted by root density) @@ -2627,138 +2627,138 @@ subroutine turbFluxes(& logical(lgt),intent(in) :: computeVegFlux ! logical flag to compute vegetation fluxes (.false. if veg buried by snow) integer(i4b),intent(in) :: ixDerivMethod ! choice of method used to compute derivative (analytical or numerical) ! input: above-canopy forcing data - real(rk),intent(in) :: airtemp ! air temperature at some height above the surface (K) - real(rk),intent(in) :: airpres ! air pressure of the air above the vegetation canopy (Pa) - real(rk),intent(in) :: VPair ! vapor pressure of the air above the vegetation canopy (Pa) + real(dp),intent(in) :: airtemp ! air temperature at some height above the surface (K) + real(dp),intent(in) :: airpres ! air pressure of the air above the vegetation canopy (Pa) + real(dp),intent(in) :: VPair ! vapor pressure of the air above the vegetation canopy (Pa) ! input: latent heat of sublimation/vaporization - real(rk),intent(in) :: latHeatSubVapCanopy ! latent heat of sublimation/vaporization for the vegetation canopy (J kg-1) - real(rk),intent(in) :: latHeatSubVapGround ! latent heat of sublimation/vaporization for the ground surface (J kg-1) + real(dp),intent(in) :: latHeatSubVapCanopy ! latent heat of sublimation/vaporization for the vegetation canopy (J kg-1) + real(dp),intent(in) :: latHeatSubVapGround ! latent heat of sublimation/vaporization for the ground surface (J kg-1) ! input: canopy and ground temperature - real(rk),intent(in) :: canairTemp ! temperature of the canopy air space (K) - real(rk),intent(in) :: canopyTemp ! canopy temperature (K) - real(rk),intent(in) :: groundTemp ! ground temperature (K) - real(rk),intent(in) :: satVP_CanopyTemp ! saturation vapor pressure at the temperature of the veg canopy (Pa) - real(rk),intent(in) :: satVP_GroundTemp ! saturation vapor pressure at the temperature of the ground (Pa) - real(rk),intent(in) :: dSVPCanopy_dCanopyTemp ! derivative in canopy saturation vapor pressure w.r.t. canopy temperature (Pa K-1) - real(rk),intent(in) :: dSVPGround_dGroundTemp ! derivative in ground saturation vapor pressure w.r.t. ground temperature (Pa K-1) + real(dp),intent(in) :: canairTemp ! temperature of the canopy air space (K) + real(dp),intent(in) :: canopyTemp ! canopy temperature (K) + real(dp),intent(in) :: groundTemp ! ground temperature (K) + real(dp),intent(in) :: satVP_CanopyTemp ! saturation vapor pressure at the temperature of the veg canopy (Pa) + real(dp),intent(in) :: satVP_GroundTemp ! saturation vapor pressure at the temperature of the ground (Pa) + real(dp),intent(in) :: dSVPCanopy_dCanopyTemp ! derivative in canopy saturation vapor pressure w.r.t. canopy temperature (Pa K-1) + real(dp),intent(in) :: dSVPGround_dGroundTemp ! derivative in ground saturation vapor pressure w.r.t. ground temperature (Pa K-1) ! input: diagnostic variables - real(rk),intent(in) :: exposedVAI ! exposed vegetation area index -- leaf plus stem (m2 m-2) - real(rk),intent(in) :: canopyWetFraction ! fraction of canopy that is wet [0-1] - real(rk),intent(in) :: dCanopyWetFraction_dWat ! derivative in the canopy wetted fraction w.r.t. liquid water content (kg-1 m-2) - real(rk),intent(in) :: dCanopyWetFraction_dT ! derivative in the canopy wetted fraction w.r.t. canopy temperature (K-1) - real(rk),intent(in) :: canopySunlitLAI ! sunlit leaf area (-) - real(rk),intent(in) :: canopyShadedLAI ! shaded leaf area (-) - real(rk),intent(in) :: soilRelHumidity ! relative humidity in the soil pores [0-1] - real(rk),intent(in) :: soilResistance ! resistance from the soil (s m-1) - real(rk),intent(in) :: leafResistance ! mean leaf boundary layer resistance per unit leaf area (s m-1) - real(rk),intent(in) :: groundResistance ! below canopy aerodynamic resistance (s m-1) - real(rk),intent(in) :: canopyResistance ! above canopy aerodynamic resistance (s m-1) - real(rk),intent(in) :: stomResistSunlit ! stomatal resistance for sunlit leaves (s m-1) - real(rk),intent(in) :: stomResistShaded ! stomatal resistance for shaded leaves (s m-1) + real(dp),intent(in) :: exposedVAI ! exposed vegetation area index -- leaf plus stem (m2 m-2) + real(dp),intent(in) :: canopyWetFraction ! fraction of canopy that is wet [0-1] + real(dp),intent(in) :: dCanopyWetFraction_dWat ! derivative in the canopy wetted fraction w.r.t. liquid water content (kg-1 m-2) + real(dp),intent(in) :: dCanopyWetFraction_dT ! derivative in the canopy wetted fraction w.r.t. canopy temperature (K-1) + real(dp),intent(in) :: canopySunlitLAI ! sunlit leaf area (-) + real(dp),intent(in) :: canopyShadedLAI ! shaded leaf area (-) + real(dp),intent(in) :: soilRelHumidity ! relative humidity in the soil pores [0-1] + real(dp),intent(in) :: soilResistance ! resistance from the soil (s m-1) + real(dp),intent(in) :: leafResistance ! mean leaf boundary layer resistance per unit leaf area (s m-1) + real(dp),intent(in) :: groundResistance ! below canopy aerodynamic resistance (s m-1) + real(dp),intent(in) :: canopyResistance ! above canopy aerodynamic resistance (s m-1) + real(dp),intent(in) :: stomResistSunlit ! stomatal resistance for sunlit leaves (s m-1) + real(dp),intent(in) :: stomResistShaded ! stomatal resistance for shaded leaves (s m-1) ! input: derivatives in scalar resistances - real(rk),intent(in) :: dGroundResistance_dTGround ! derivative in ground resistance w.r.t. ground temperature (s m-1 K-1) - real(rk),intent(in) :: dGroundResistance_dTCanopy ! derivative in ground resistance w.r.t. canopy temperature (s m-1 K-1) - real(rk),intent(in) :: dGroundResistance_dTCanair ! derivative in ground resistance w.r.t. canopy air temperature (s m-1 K-1) - real(rk),intent(in) :: dCanopyResistance_dTCanopy ! derivative in canopy resistance w.r.t. canopy temperature (s m-1 K-1) - real(rk),intent(in) :: dCanopyResistance_dTCanair ! derivative in canopy resistance w.r.t. canopy air temperature (s m-1 K-1) + real(dp),intent(in) :: dGroundResistance_dTGround ! derivative in ground resistance w.r.t. ground temperature (s m-1 K-1) + real(dp),intent(in) :: dGroundResistance_dTCanopy ! derivative in ground resistance w.r.t. canopy temperature (s m-1 K-1) + real(dp),intent(in) :: dGroundResistance_dTCanair ! derivative in ground resistance w.r.t. canopy air temperature (s m-1 K-1) + real(dp),intent(in) :: dCanopyResistance_dTCanopy ! derivative in canopy resistance w.r.t. canopy temperature (s m-1 K-1) + real(dp),intent(in) :: dCanopyResistance_dTCanair ! derivative in canopy resistance w.r.t. canopy air temperature (s m-1 K-1) ! --------------------------------------------------------------------------------------------------------------------------------------------------------------- ! output: conductances -- used to test derivatives - real(rk),intent(out) :: leafConductance ! leaf conductance (m s-1) - real(rk),intent(out) :: canopyConductance ! canopy conductance (m s-1) - real(rk),intent(out) :: groundConductanceSH ! ground conductance for sensible heat (m s-1) - real(rk),intent(out) :: groundConductanceLH ! ground conductance for latent heat -- includes soil resistance (m s-1) - real(rk),intent(out) :: evapConductance ! conductance for evaporation (m s-1) - real(rk),intent(out) :: transConductance ! conductance for transpiration (m s-1) - real(rk),intent(out) :: totalConductanceSH ! total conductance for sensible heat (m s-1) - real(rk),intent(out) :: totalConductanceLH ! total conductance for latent heat (m s-1) + real(dp),intent(out) :: leafConductance ! leaf conductance (m s-1) + real(dp),intent(out) :: canopyConductance ! canopy conductance (m s-1) + real(dp),intent(out) :: groundConductanceSH ! ground conductance for sensible heat (m s-1) + real(dp),intent(out) :: groundConductanceLH ! ground conductance for latent heat -- includes soil resistance (m s-1) + real(dp),intent(out) :: evapConductance ! conductance for evaporation (m s-1) + real(dp),intent(out) :: transConductance ! conductance for transpiration (m s-1) + real(dp),intent(out) :: totalConductanceSH ! total conductance for sensible heat (m s-1) + real(dp),intent(out) :: totalConductanceLH ! total conductance for latent heat (m s-1) ! output: canopy air space variables - real(rk),intent(out) :: VP_CanopyAir ! vapor pressure of the canopy air space (Pa) + real(dp),intent(out) :: VP_CanopyAir ! vapor pressure of the canopy air space (Pa) ! output: fluxes from the vegetation canopy - real(rk),intent(out) :: senHeatCanopy ! sensible heat flux from the canopy to the canopy air space (W m-2) - real(rk),intent(out) :: latHeatCanopyEvap ! latent heat flux associated with evaporation from the canopy to the canopy air space (W m-2) - real(rk),intent(out) :: latHeatCanopyTrans ! latent heat flux associated with transpiration from the canopy to the canopy air space (W m-2) + real(dp),intent(out) :: senHeatCanopy ! sensible heat flux from the canopy to the canopy air space (W m-2) + real(dp),intent(out) :: latHeatCanopyEvap ! latent heat flux associated with evaporation from the canopy to the canopy air space (W m-2) + real(dp),intent(out) :: latHeatCanopyTrans ! latent heat flux associated with transpiration from the canopy to the canopy air space (W m-2) ! output: fluxes from non-vegetated surfaces (ground surface below vegetation, bare ground, or snow covered vegetation) - real(rk),intent(out) :: senHeatGround ! sensible heat flux from ground surface below vegetation, bare ground, or snow covered vegetation (W m-2) - real(rk),intent(out) :: latHeatGround ! latent heat flux from ground surface below vegetation, bare ground, or snow covered vegetation (W m-2) + real(dp),intent(out) :: senHeatGround ! sensible heat flux from ground surface below vegetation, bare ground, or snow covered vegetation (W m-2) + real(dp),intent(out) :: latHeatGround ! latent heat flux from ground surface below vegetation, bare ground, or snow covered vegetation (W m-2) ! output: total heat fluxes to the atmosphere - real(rk),intent(out) :: senHeatTotal ! total sensible heat flux to the atmosphere (W m-2) - real(rk),intent(out) :: latHeatTotal ! total latent heat flux to the atmosphere (W m-2) + real(dp),intent(out) :: senHeatTotal ! total sensible heat flux to the atmosphere (W m-2) + real(dp),intent(out) :: latHeatTotal ! total latent heat flux to the atmosphere (W m-2) ! output: net fluxes - real(rk),intent(out) :: turbFluxCanair ! net turbulent heat fluxes at the canopy air space (W m-2) - real(rk),intent(out) :: turbFluxCanopy ! net turbulent heat fluxes at the canopy (W m-2) - real(rk),intent(out) :: turbFluxGround ! net turbulent heat fluxes at the ground surface (W m-2) + real(dp),intent(out) :: turbFluxCanair ! net turbulent heat fluxes at the canopy air space (W m-2) + real(dp),intent(out) :: turbFluxCanopy ! net turbulent heat fluxes at the canopy (W m-2) + real(dp),intent(out) :: turbFluxGround ! net turbulent heat fluxes at the ground surface (W m-2) ! output: energy flux derivatives - real(rk),intent(out) :: dTurbFluxCanair_dTCanair ! derivative in net canopy air space fluxes w.r.t. canopy air temperature (W m-2 K-1) - real(rk),intent(out) :: dTurbFluxCanair_dTCanopy ! derivative in net canopy air space fluxes w.r.t. canopy temperature (W m-2 K-1) - real(rk),intent(out) :: dTurbFluxCanair_dTGround ! derivative in net canopy air space fluxes w.r.t. ground temperature (W m-2 K-1) - real(rk),intent(out) :: dTurbFluxCanopy_dTCanair ! derivative in net canopy turbulent fluxes w.r.t. canopy air temperature (W m-2 K-1) - real(rk),intent(out) :: dTurbFluxCanopy_dTCanopy ! derivative in net canopy turbulent fluxes w.r.t. canopy temperature (W m-2 K-1) - real(rk),intent(out) :: dTurbFluxCanopy_dTGround ! derivative in net canopy turbulent fluxes w.r.t. ground temperature (W m-2 K-1) - real(rk),intent(out) :: dTurbFluxGround_dTCanair ! derivative in net ground turbulent fluxes w.r.t. canopy air temperature (W m-2 K-1) - real(rk),intent(out) :: dTurbFluxGround_dTCanopy ! derivative in net ground turbulent fluxes w.r.t. canopy temperature (W m-2 K-1) - real(rk),intent(out) :: dTurbFluxGround_dTGround ! derivative in net ground turbulent fluxes w.r.t. ground temperature (W m-2 K-1) + real(dp),intent(out) :: dTurbFluxCanair_dTCanair ! derivative in net canopy air space fluxes w.r.t. canopy air temperature (W m-2 K-1) + real(dp),intent(out) :: dTurbFluxCanair_dTCanopy ! derivative in net canopy air space fluxes w.r.t. canopy temperature (W m-2 K-1) + real(dp),intent(out) :: dTurbFluxCanair_dTGround ! derivative in net canopy air space fluxes w.r.t. ground temperature (W m-2 K-1) + real(dp),intent(out) :: dTurbFluxCanopy_dTCanair ! derivative in net canopy turbulent fluxes w.r.t. canopy air temperature (W m-2 K-1) + real(dp),intent(out) :: dTurbFluxCanopy_dTCanopy ! derivative in net canopy turbulent fluxes w.r.t. canopy temperature (W m-2 K-1) + real(dp),intent(out) :: dTurbFluxCanopy_dTGround ! derivative in net canopy turbulent fluxes w.r.t. ground temperature (W m-2 K-1) + real(dp),intent(out) :: dTurbFluxGround_dTCanair ! derivative in net ground turbulent fluxes w.r.t. canopy air temperature (W m-2 K-1) + real(dp),intent(out) :: dTurbFluxGround_dTCanopy ! derivative in net ground turbulent fluxes w.r.t. canopy temperature (W m-2 K-1) + real(dp),intent(out) :: dTurbFluxGround_dTGround ! derivative in net ground turbulent fluxes w.r.t. ground temperature (W m-2 K-1) ! output: liquid flux derivatives (canopy evap) - real(rk),intent(out) :: dLatHeatCanopyEvap_dCanLiq ! derivative in latent heat of canopy evaporation w.r.t. canopy liquid water content (W kg-1) - real(rk),intent(out) :: dLatHeatCanopyEvap_dTCanair ! derivative in latent heat of canopy evaporation w.r.t. canopy air temperature (W m-2 K-1) - real(rk),intent(out) :: dLatHeatCanopyEvap_dTCanopy ! derivative in latent heat of canopy evaporation w.r.t. canopy temperature (W m-2 K-1) - real(rk),intent(out) :: dLatHeatCanopyEvap_dTGround ! derivative in latent heat of canopy evaporation w.r.t. ground temperature (W m-2 K-1) + real(dp),intent(out) :: dLatHeatCanopyEvap_dCanLiq ! derivative in latent heat of canopy evaporation w.r.t. canopy liquid water content (W kg-1) + real(dp),intent(out) :: dLatHeatCanopyEvap_dTCanair ! derivative in latent heat of canopy evaporation w.r.t. canopy air temperature (W m-2 K-1) + real(dp),intent(out) :: dLatHeatCanopyEvap_dTCanopy ! derivative in latent heat of canopy evaporation w.r.t. canopy temperature (W m-2 K-1) + real(dp),intent(out) :: dLatHeatCanopyEvap_dTGround ! derivative in latent heat of canopy evaporation w.r.t. ground temperature (W m-2 K-1) ! output: liquid flux derivatives (ground evap) - real(rk),intent(out) :: dLatHeatGroundEvap_dCanLiq ! derivative in latent heat of ground evaporation w.r.t. canopy liquid water content (J kg-1 s-1) - real(rk),intent(out) :: dLatHeatGroundEvap_dTCanair ! derivative in latent heat of ground evaporation w.r.t. canopy air temperature (W m-2 K-1) - real(rk),intent(out) :: dLatHeatGroundEvap_dTCanopy ! derivative in latent heat of ground evaporation w.r.t. canopy temperature (W m-2 K-1) - real(rk),intent(out) :: dLatHeatGroundEvap_dTGround ! derivative in latent heat of ground evaporation w.r.t. ground temperature (W m-2 K-1) + real(dp),intent(out) :: dLatHeatGroundEvap_dCanLiq ! derivative in latent heat of ground evaporation w.r.t. canopy liquid water content (J kg-1 s-1) + real(dp),intent(out) :: dLatHeatGroundEvap_dTCanair ! derivative in latent heat of ground evaporation w.r.t. canopy air temperature (W m-2 K-1) + real(dp),intent(out) :: dLatHeatGroundEvap_dTCanopy ! derivative in latent heat of ground evaporation w.r.t. canopy temperature (W m-2 K-1) + real(dp),intent(out) :: dLatHeatGroundEvap_dTGround ! derivative in latent heat of ground evaporation w.r.t. ground temperature (W m-2 K-1) ! output: cross derivatives - real(rk),intent(out) :: dTurbFluxCanair_dCanLiq ! derivative in net canopy air space fluxes w.r.t. canopy liquid water content (J kg-1 s-1) - real(rk),intent(out) :: dTurbFluxCanopy_dCanLiq ! derivative in net canopy turbulent fluxes w.r.t. canopy liquid water content (J kg-1 s-1) - real(rk),intent(out) :: dTurbFluxGround_dCanLiq ! derivative in net ground turbulent fluxes w.r.t. canopy liquid water content (J kg-1 s-1) + real(dp),intent(out) :: dTurbFluxCanair_dCanLiq ! derivative in net canopy air space fluxes w.r.t. canopy liquid water content (J kg-1 s-1) + real(dp),intent(out) :: dTurbFluxCanopy_dCanLiq ! derivative in net canopy turbulent fluxes w.r.t. canopy liquid water content (J kg-1 s-1) + real(dp),intent(out) :: dTurbFluxGround_dCanLiq ! derivative in net ground turbulent fluxes w.r.t. canopy liquid water content (J kg-1 s-1) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! ----------------------------------------------------------------------------------------------------------------------------------------- ! local variables -- general - real(rk) :: fpart1,fpart2 ! different parts of a function - real(rk) :: dPart0,dpart1,dpart2 ! derivatives for different parts of a function + real(dp) :: fpart1,fpart2 ! different parts of a function + real(dp) :: dPart0,dpart1,dpart2 ! derivatives for different parts of a function ! local variables -- "constants" - real(rk) :: volHeatCapacityAir ! volumetric heat capacity of air (J m-3) - real(rk) :: latentHeatConstant ! latent heat constant (kg m-3 K-1) + real(dp) :: volHeatCapacityAir ! volumetric heat capacity of air (J m-3) + real(dp) :: latentHeatConstant ! latent heat constant (kg m-3 K-1) ! local variables -- derivatives for energy conductances - real(rk) :: dEvapCond_dCanopyTemp ! derivative in evap conductance w.r.t. canopy temperature - real(rk) :: dTransCond_dCanopyTemp ! derivative in trans conductance w.r.t. canopy temperature - real(rk) :: dCanopyCond_dCanairTemp ! derivative in canopy conductance w.r.t. canopy air temperature - real(rk) :: dCanopyCond_dCanopyTemp ! derivative in canopy conductance w.r.t. canopy temperature - real(rk) :: dGroundCondSH_dCanairTemp ! derivative in ground conductance of sensible heat w.r.t. canopy air temperature - real(rk) :: dGroundCondSH_dCanopyTemp ! derivative in ground conductance of sensible heat w.r.t. canopy temperature - real(rk) :: dGroundCondSH_dGroundTemp ! derivative in ground conductance of sensible heat w.r.t. ground temperature + real(dp) :: dEvapCond_dCanopyTemp ! derivative in evap conductance w.r.t. canopy temperature + real(dp) :: dTransCond_dCanopyTemp ! derivative in trans conductance w.r.t. canopy temperature + real(dp) :: dCanopyCond_dCanairTemp ! derivative in canopy conductance w.r.t. canopy air temperature + real(dp) :: dCanopyCond_dCanopyTemp ! derivative in canopy conductance w.r.t. canopy temperature + real(dp) :: dGroundCondSH_dCanairTemp ! derivative in ground conductance of sensible heat w.r.t. canopy air temperature + real(dp) :: dGroundCondSH_dCanopyTemp ! derivative in ground conductance of sensible heat w.r.t. canopy temperature + real(dp) :: dGroundCondSH_dGroundTemp ! derivative in ground conductance of sensible heat w.r.t. ground temperature ! local variables -- derivatives for mass conductances - real(rk) :: dGroundCondLH_dCanairTemp ! derivative in ground conductance w.r.t. canopy air temperature - real(rk) :: dGroundCondLH_dCanopyTemp ! derivative in ground conductance w.r.t. canopy temperature - real(rk) :: dGroundCondLH_dGroundTemp ! derivative in ground conductance w.r.t. ground temperature + real(dp) :: dGroundCondLH_dCanairTemp ! derivative in ground conductance w.r.t. canopy air temperature + real(dp) :: dGroundCondLH_dCanopyTemp ! derivative in ground conductance w.r.t. canopy temperature + real(dp) :: dGroundCondLH_dGroundTemp ! derivative in ground conductance w.r.t. ground temperature ! local variables -- derivatives for the canopy air space variables - real(rk) :: fPart_VP ! part of the function for vapor pressure of the canopy air space - real(rk) :: leafConductanceTr ! leaf conductance for transpiration (m s-1) - real(rk) :: dVPCanopyAir_dTCanair ! derivative in the vapor pressure of the canopy air space w.r.t. temperature of the canopy air space - real(rk) :: dVPCanopyAir_dTCanopy ! derivative in the vapor pressure of the canopy air space w.r.t. temperature of the canopy - real(rk) :: dVPCanopyAir_dTGround ! derivative in the vapor pressure of the canopy air space w.r.t. temperature of the ground - real(rk) :: dVPCanopyAir_dWetFrac ! derivative of vapor pressure in the canopy air space w.r.t. wetted fraction of the canopy - real(rk) :: dVPCanopyAir_dCanLiq ! derivative of vapor pressure in the canopy air space w.r.t. canopy liquid water content + real(dp) :: fPart_VP ! part of the function for vapor pressure of the canopy air space + real(dp) :: leafConductanceTr ! leaf conductance for transpiration (m s-1) + real(dp) :: dVPCanopyAir_dTCanair ! derivative in the vapor pressure of the canopy air space w.r.t. temperature of the canopy air space + real(dp) :: dVPCanopyAir_dTCanopy ! derivative in the vapor pressure of the canopy air space w.r.t. temperature of the canopy + real(dp) :: dVPCanopyAir_dTGround ! derivative in the vapor pressure of the canopy air space w.r.t. temperature of the ground + real(dp) :: dVPCanopyAir_dWetFrac ! derivative of vapor pressure in the canopy air space w.r.t. wetted fraction of the canopy + real(dp) :: dVPCanopyAir_dCanLiq ! derivative of vapor pressure in the canopy air space w.r.t. canopy liquid water content ! local variables -- sensible heat flux derivatives - real(rk) :: dSenHeatTotal_dTCanair ! derivative in the total sensible heat flux w.r.t. canopy air temperature - real(rk) :: dSenHeatTotal_dTCanopy ! derivative in the total sensible heat flux w.r.t. canopy air temperature - real(rk) :: dSenHeatTotal_dTGround ! derivative in the total sensible heat flux w.r.t. ground temperature - real(rk) :: dSenHeatCanopy_dTCanair ! derivative in the canopy sensible heat flux w.r.t. canopy air temperature - real(rk) :: dSenHeatCanopy_dTCanopy ! derivative in the canopy sensible heat flux w.r.t. canopy temperature - real(rk) :: dSenHeatCanopy_dTGround ! derivative in the canopy sensible heat flux w.r.t. ground temperature - real(rk) :: dSenHeatGround_dTCanair ! derivative in the ground sensible heat flux w.r.t. canopy air temperature - real(rk) :: dSenHeatGround_dTCanopy ! derivative in the ground sensible heat flux w.r.t. canopy temperature - real(rk) :: dSenHeatGround_dTGround ! derivative in the ground sensible heat flux w.r.t. ground temperature + real(dp) :: dSenHeatTotal_dTCanair ! derivative in the total sensible heat flux w.r.t. canopy air temperature + real(dp) :: dSenHeatTotal_dTCanopy ! derivative in the total sensible heat flux w.r.t. canopy air temperature + real(dp) :: dSenHeatTotal_dTGround ! derivative in the total sensible heat flux w.r.t. ground temperature + real(dp) :: dSenHeatCanopy_dTCanair ! derivative in the canopy sensible heat flux w.r.t. canopy air temperature + real(dp) :: dSenHeatCanopy_dTCanopy ! derivative in the canopy sensible heat flux w.r.t. canopy temperature + real(dp) :: dSenHeatCanopy_dTGround ! derivative in the canopy sensible heat flux w.r.t. ground temperature + real(dp) :: dSenHeatGround_dTCanair ! derivative in the ground sensible heat flux w.r.t. canopy air temperature + real(dp) :: dSenHeatGround_dTCanopy ! derivative in the ground sensible heat flux w.r.t. canopy temperature + real(dp) :: dSenHeatGround_dTGround ! derivative in the ground sensible heat flux w.r.t. ground temperature ! local variables -- latent heat flux derivatives - real(rk) :: dLatHeatCanopyTrans_dTCanair ! derivative in the canopy transpiration flux w.r.t. canopy air temperature - real(rk) :: dLatHeatCanopyTrans_dTCanopy ! derivative in the canopy transpiration flux w.r.t. canopy temperature - real(rk) :: dLatHeatCanopyTrans_dTGround ! derivative in the canopy transpiration flux w.r.t. ground temperature + real(dp) :: dLatHeatCanopyTrans_dTCanair ! derivative in the canopy transpiration flux w.r.t. canopy air temperature + real(dp) :: dLatHeatCanopyTrans_dTCanopy ! derivative in the canopy transpiration flux w.r.t. canopy temperature + real(dp) :: dLatHeatCanopyTrans_dTGround ! derivative in the canopy transpiration flux w.r.t. ground temperature ! local variables -- wetted fraction derivatives - real(rk) :: dLatHeatCanopyEvap_dWetFrac ! derivative in the latent heat of canopy evaporation w.r.t. canopy wet fraction (W m-2) - real(rk) :: dLatHeatCanopyTrans_dWetFrac ! derivative in the latent heat of canopy transpiration w.r.t. canopy wet fraction (W m-2) - real(rk) :: dLatHeatCanopyTrans_dCanLiq ! derivative in the latent heat of canopy transpiration w.r.t. canopy liquid water (J kg-1 s-1) + real(dp) :: dLatHeatCanopyEvap_dWetFrac ! derivative in the latent heat of canopy evaporation w.r.t. canopy wet fraction (W m-2) + real(dp) :: dLatHeatCanopyTrans_dWetFrac ! derivative in the latent heat of canopy transpiration w.r.t. canopy wet fraction (W m-2) + real(dp) :: dLatHeatCanopyTrans_dCanLiq ! derivative in the latent heat of canopy transpiration w.r.t. canopy liquid water (J kg-1 s-1) ! ----------------------------------------------------------------------------------------------------------------------------------------- ! initialize error control err=0; message='turbFluxes/' @@ -2775,12 +2775,12 @@ subroutine turbFluxes(& if(computeVegFlux)then leafConductance = exposedVAI/leafResistance leafConductanceTr = canopySunlitLAI/(leafResistance+stomResistSunlit) + canopyShadedLAI/(leafResistance+stomResistShaded) - canopyConductance = 1._rk/canopyResistance + canopyConductance = 1._dp/canopyResistance else - leafConductance = 0._rk - canopyConductance = 0._rk + leafConductance = 0._dp + canopyConductance = 0._dp end if - groundConductanceSH = 1._rk/groundResistance + groundConductanceSH = 1._dp/groundResistance ! compute total conductance for sensible heat totalConductanceSH = leafConductance + groundConductanceSH + canopyConductance @@ -2788,14 +2788,14 @@ subroutine turbFluxes(& ! compute conductances for latent heat (m s-1) if(computeVegFlux)then evapConductance = canopyWetFraction*leafConductance - transConductance = (1._rk - canopyWetFraction) * leafConductanceTr + transConductance = (1._dp - canopyWetFraction) * leafConductanceTr !write(*,'(a,10(f14.8,1x))') 'canopySunlitLAI, canopyShadedLAI, stomResistSunlit, stomResistShaded, leafResistance, canopyWetFraction = ', & ! canopySunlitLAI, canopyShadedLAI, stomResistSunlit, stomResistShaded, leafResistance, canopyWetFraction else - evapConductance = 0._rk - transConductance = 0._rk + evapConductance = 0._dp + transConductance = 0._dp end if - groundConductanceLH = 1._rk/(groundResistance + soilResistance) ! NOTE: soilResistance accounts for fractional snow, and =0 when snow cover is 100% + groundConductanceLH = 1._dp/(groundResistance + soilResistance) ! NOTE: soilResistance accounts for fractional snow, and =0 when snow cover is 100% totalConductanceLH = evapConductance + transConductance + groundConductanceLH + canopyConductance ! check sensible heat conductance @@ -2818,30 +2818,30 @@ subroutine turbFluxes(& if(computeVegFlux)then dEvapCond_dCanopyTemp = dCanopyWetFraction_dT*leafConductance ! derivative in evap conductance w.r.t. canopy temperature dTransCond_dCanopyTemp = -dCanopyWetFraction_dT*leafConductanceTr ! derivative in trans conductance w.r.t. canopy temperature - dCanopyCond_dCanairTemp = -dCanopyResistance_dTCanair/canopyResistance**2._rk ! derivative in canopy conductance w.r.t. canopy air emperature - dCanopyCond_dCanopyTemp = -dCanopyResistance_dTCanopy/canopyResistance**2._rk ! derivative in canopy conductance w.r.t. canopy temperature - dGroundCondSH_dCanairTemp = -dGroundResistance_dTCanair/groundResistance**2._rk ! derivative in ground conductance w.r.t. canopy air temperature - dGroundCondSH_dCanopyTemp = -dGroundResistance_dTCanopy/groundResistance**2._rk ! derivative in ground conductance w.r.t. canopy temperature - dGroundCondSH_dGroundTemp = -dGroundResistance_dTGround/groundResistance**2._rk ! derivative in ground conductance w.r.t. ground temperature + dCanopyCond_dCanairTemp = -dCanopyResistance_dTCanair/canopyResistance**2._dp ! derivative in canopy conductance w.r.t. canopy air emperature + dCanopyCond_dCanopyTemp = -dCanopyResistance_dTCanopy/canopyResistance**2._dp ! derivative in canopy conductance w.r.t. canopy temperature + dGroundCondSH_dCanairTemp = -dGroundResistance_dTCanair/groundResistance**2._dp ! derivative in ground conductance w.r.t. canopy air temperature + dGroundCondSH_dCanopyTemp = -dGroundResistance_dTCanopy/groundResistance**2._dp ! derivative in ground conductance w.r.t. canopy temperature + dGroundCondSH_dGroundTemp = -dGroundResistance_dTGround/groundResistance**2._dp ! derivative in ground conductance w.r.t. ground temperature else - dEvapCond_dCanopyTemp = 0._rk ! derivative in evap conductance w.r.t. canopy temperature - dTransCond_dCanopyTemp = 0._rk ! derivative in trans conductance w.r.t. canopy temperature - dCanopyCond_dCanairTemp = 0._rk ! derivative in canopy conductance w.r.t. canopy air emperature - dCanopyCond_dCanopyTemp = 0._rk ! derivative in canopy conductance w.r.t. canopy temperature - dGroundCondSH_dCanairTemp = 0._rk ! derivative in ground conductance w.r.t. canopy air temperature - dGroundCondSH_dCanopyTemp = 0._rk ! derivative in ground conductance w.r.t. canopy temperature - dGroundCondSH_dGroundTemp = -dGroundResistance_dTGround/groundResistance**2._rk ! derivative in ground conductance w.r.t. ground temperature + dEvapCond_dCanopyTemp = 0._dp ! derivative in evap conductance w.r.t. canopy temperature + dTransCond_dCanopyTemp = 0._dp ! derivative in trans conductance w.r.t. canopy temperature + dCanopyCond_dCanairTemp = 0._dp ! derivative in canopy conductance w.r.t. canopy air emperature + dCanopyCond_dCanopyTemp = 0._dp ! derivative in canopy conductance w.r.t. canopy temperature + dGroundCondSH_dCanairTemp = 0._dp ! derivative in ground conductance w.r.t. canopy air temperature + dGroundCondSH_dCanopyTemp = 0._dp ! derivative in ground conductance w.r.t. canopy temperature + dGroundCondSH_dGroundTemp = -dGroundResistance_dTGround/groundResistance**2._dp ! derivative in ground conductance w.r.t. ground temperature end if ! compute derivatives in individual conductances for latent heat w.r.t. canopy temperature (m s-1 K-1) if(computeVegFlux)then - dGroundCondLH_dCanairTemp = -dGroundResistance_dTCanair/(groundResistance+soilResistance)**2._rk ! derivative in ground conductance w.r.t. canopy air temperature - dGroundCondLH_dCanopyTemp = -dGroundResistance_dTCanopy/(groundResistance+soilResistance)**2._rk ! derivative in ground conductance w.r.t. canopy temperature - dGroundCondLH_dGroundTemp = -dGroundResistance_dTGround/(groundResistance+soilResistance)**2._rk ! derivative in ground conductance w.r.t. ground temperature + dGroundCondLH_dCanairTemp = -dGroundResistance_dTCanair/(groundResistance+soilResistance)**2._dp ! derivative in ground conductance w.r.t. canopy air temperature + dGroundCondLH_dCanopyTemp = -dGroundResistance_dTCanopy/(groundResistance+soilResistance)**2._dp ! derivative in ground conductance w.r.t. canopy temperature + dGroundCondLH_dGroundTemp = -dGroundResistance_dTGround/(groundResistance+soilResistance)**2._dp ! derivative in ground conductance w.r.t. ground temperature else - dGroundCondLH_dCanairTemp = 0._rk ! derivative in ground conductance w.r.t. canopy air temperature - dGroundCondLH_dCanopyTemp = 0._rk ! derivative in ground conductance w.r.t. canopy temperature - dGroundCondLH_dGroundTemp = -dGroundResistance_dTGround/(groundResistance+soilResistance)**2._rk ! derivative in ground conductance w.r.t. ground temperature + dGroundCondLH_dCanairTemp = 0._dp ! derivative in ground conductance w.r.t. canopy air temperature + dGroundCondLH_dCanopyTemp = 0._dp ! derivative in ground conductance w.r.t. canopy temperature + dGroundCondLH_dGroundTemp = -dGroundResistance_dTGround/(groundResistance+soilResistance)**2._dp ! derivative in ground conductance w.r.t. ground temperature end if end if ! (if computing analytical derivatives) @@ -2885,9 +2885,9 @@ subroutine turbFluxes(& ! * no vegetation, so fluxes are zero else - senHeatCanopy = 0._rk - latHeatCanopyEvap = 0._rk - latHeatCanopyTrans = 0._rk + senHeatCanopy = 0._dp + latHeatCanopyEvap = 0._dp + latHeatCanopyTrans = 0._dp end if ! compute sensible and latent heat fluxes from the ground to the canopy air space (W m-2) @@ -2914,20 +2914,20 @@ subroutine turbFluxes(& ! compute derivatives of vapor pressure in the canopy air space w.r.t. all state variables ! (derivative of vapor pressure in the canopy air space w.r.t. temperature of the canopy air space) dPart1 = dCanopyCond_dCanairTemp*VPair + dGroundCondLH_dCanairTemp*satVP_GroundTemp*soilRelHumidity - dPart2 = -(dCanopyCond_dCanairTemp + dGroundCondLH_dCanairTemp)/(totalConductanceLH**2._rk) + dPart2 = -(dCanopyCond_dCanairTemp + dGroundCondLH_dCanairTemp)/(totalConductanceLH**2._dp) dVPCanopyAir_dTCanair = dPart1/totalConductanceLH + fPart_VP*dPart2 ! (derivative of vapor pressure in the canopy air space w.r.t. temperature of the canopy) dPart0 = (evapConductance + transConductance)*dSVPCanopy_dCanopyTemp + (dEvapCond_dCanopyTemp + dTransCond_dCanopyTemp)*satVP_CanopyTemp dPart1 = dCanopyCond_dCanopyTemp*VPair + dPart0 + dGroundCondLH_dCanopyTemp*satVP_GroundTemp*soilRelHumidity - dPart2 = -(dCanopyCond_dCanopyTemp + dEvapCond_dCanopyTemp + dTransCond_dCanopyTemp + dGroundCondLH_dCanopyTemp)/(totalConductanceLH**2._rk) + dPart2 = -(dCanopyCond_dCanopyTemp + dEvapCond_dCanopyTemp + dTransCond_dCanopyTemp + dGroundCondLH_dCanopyTemp)/(totalConductanceLH**2._dp) dVPCanopyAir_dTCanopy = dPart1/totalConductanceLH + fPart_VP*dPart2 ! (derivative of vapor pressure in the canopy air space w.r.t. temperature of the ground) dPart1 = dGroundCondLH_dGroundTemp*satVP_GroundTemp*soilRelHumidity + groundConductanceLH*dSVPGround_dGroundTemp*soilRelHumidity - dPart2 = -dGroundCondLH_dGroundTemp/(totalConductanceLH**2._rk) + dPart2 = -dGroundCondLH_dGroundTemp/(totalConductanceLH**2._dp) dVPCanopyAir_dTGround = dPart1/totalConductanceLH + fPart_VP*dPart2 ! (derivative of vapor pressure in the canopy air space w.r.t. wetted fraction of the canopy) dPart1 = (leafConductance - leafConductanceTr)*satVP_CanopyTemp - dPart2 = -(leafConductance - leafConductanceTr)/(totalConductanceLH**2._rk) + dPart2 = -(leafConductance - leafConductanceTr)/(totalConductanceLH**2._dp) dVPCanopyAir_dWetFrac = dPart1/totalConductanceLH + fPart_VP*dPart2 dVPCanopyAir_dCanLiq = dVPCanopyAir_dWetFrac*dCanopyWetFraction_dWat !write(*,'(a,5(f20.8,1x))') 'dVPCanopyAir_dTCanair, dVPCanopyAir_dTCanopy, dVPCanopyAir_dTGround, dVPCanopyAir_dWetFrac, dVPCanopyAir_dCanLiq = ', & @@ -2936,14 +2936,14 @@ subroutine turbFluxes(& ! sensible heat from the canopy to the atmosphere dSenHeatTotal_dTCanair = -volHeatCapacityAir*canopyConductance - volHeatCapacityAir*dCanopyCond_dCanairTemp*(canairTemp - airtemp) dSenHeatTotal_dTCanopy = -volHeatCapacityAir*dCanopyCond_dCanopyTemp*(canairTemp - airtemp) - dSenHeatTotal_dTGround = 0._rk + dSenHeatTotal_dTGround = 0._dp !write(*,'(a,3(f20.8,1x))') 'dSenHeatTotal_dTCanair, dSenHeatTotal_dTCanopy, dSenHeatTotal_dTGround = ', & ! dSenHeatTotal_dTCanair, dSenHeatTotal_dTCanopy, dSenHeatTotal_dTGround ! sensible heat from the canopy to the canopy air space dSenHeatCanopy_dTCanair = volHeatCapacityAir*leafConductance dSenHeatCanopy_dTCanopy = -volHeatCapacityAir*leafConductance - dSenHeatCanopy_dTGround = 0._rk + dSenHeatCanopy_dTGround = 0._dp !write(*,'(a,3(f20.8,1x))') 'dSenHeatCanopy_dTCanair, dSenHeatCanopy_dTCanopy, dSenHeatCanopy_dTGround = ', & ! dSenHeatCanopy_dTCanair, dSenHeatCanopy_dTCanopy, dSenHeatCanopy_dTGround @@ -2994,7 +2994,7 @@ subroutine turbFluxes(& ! latent heat associated with canopy transpiration w.r.t. wetted fraction of the canopy dPart1 = LH_vap*latentHeatConstant*leafConductanceTr ! NOTE: positive, since (1 - wetFrac) - fPart1 = -dPart1*(1._rk - canopyWetFraction) + fPart1 = -dPart1*(1._dp - canopyWetFraction) dLatHeatCanopyTrans_dWetFrac = dPart1*(satVP_CanopyTemp - VP_CanopyAir) + fPart1*(-dVPCanopyAir_dWetFrac) !print*, 'dLatHeatCanopyTrans_dWetFrac = ', dLatHeatCanopyTrans_dWetFrac @@ -3005,30 +3005,30 @@ subroutine turbFluxes(& else ! canopy is undefined ! set derivatives for canopy fluxes to zero (no canopy, so fluxes are undefined) - dSenHeatTotal_dTCanair = 0._rk - dSenHeatTotal_dTCanopy = 0._rk - dSenHeatTotal_dTGround = 0._rk - dSenHeatCanopy_dTCanair = 0._rk - dSenHeatCanopy_dTCanopy = 0._rk - dSenHeatCanopy_dTGround = 0._rk - dLatHeatCanopyEvap_dTCanair = 0._rk - dLatHeatCanopyEvap_dTCanopy = 0._rk - dLatHeatCanopyEvap_dTGround = 0._rk - dLatHeatCanopyTrans_dTCanair = 0._rk - dLatHeatCanopyTrans_dTCanopy = 0._rk - dLatHeatCanopyTrans_dTGround = 0._rk + dSenHeatTotal_dTCanair = 0._dp + dSenHeatTotal_dTCanopy = 0._dp + dSenHeatTotal_dTGround = 0._dp + dSenHeatCanopy_dTCanair = 0._dp + dSenHeatCanopy_dTCanopy = 0._dp + dSenHeatCanopy_dTGround = 0._dp + dLatHeatCanopyEvap_dTCanair = 0._dp + dLatHeatCanopyEvap_dTCanopy = 0._dp + dLatHeatCanopyEvap_dTGround = 0._dp + dLatHeatCanopyTrans_dTCanair = 0._dp + dLatHeatCanopyTrans_dTCanopy = 0._dp + dLatHeatCanopyTrans_dTGround = 0._dp ! set derivatives for wetted area and canopy transpiration to zero (no canopy, so fluxes are undefined) - dLatHeatCanopyEvap_dWetFrac = 0._rk - dLatHeatCanopyEvap_dCanLiq = 0._rk - dLatHeatCanopyTrans_dCanLiq = 0._rk - dVPCanopyAir_dCanLiq = 0._rk + dLatHeatCanopyEvap_dWetFrac = 0._dp + dLatHeatCanopyEvap_dCanLiq = 0._dp + dLatHeatCanopyTrans_dCanLiq = 0._dp + dVPCanopyAir_dCanLiq = 0._dp ! set derivatives for ground fluxes w.r.t canopy temperature to zero (no canopy, so fluxes are undefined) - dSenHeatGround_dTCanair = 0._rk - dSenHeatGround_dTCanopy = 0._rk - dLatHeatGroundEvap_dTCanair = 0._rk - dLatHeatGroundEvap_dTCanopy = 0._rk + dSenHeatGround_dTCanair = 0._dp + dSenHeatGround_dTCanopy = 0._dp + dLatHeatGroundEvap_dTCanair = 0._dp + dLatHeatGroundEvap_dTCanopy = 0._dp ! compute derivatives for the ground fluxes w.r.t. ground temperature dSenHeatGround_dTGround = (-volHeatCapacityAir*dGroundCondSH_dGroundTemp)*(groundTemp - airtemp) + & ! d(ground sensible heat flux)/d(ground temp) @@ -3069,27 +3069,27 @@ subroutine turbFluxes(& dLatHeatCanopyEvap_dCanLiq = dLatHeatCanopyEvap_dWetFrac*dCanopyWetFraction_dWat ! derivative in latent heat of canopy evaporation w.r.t. canopy liquid water (W kg-1) dLatHeatGroundEvap_dCanLiq = latHeatSubVapGround*latentHeatConstant*groundConductanceLH*dVPCanopyAir_dCanLiq ! derivative in latent heat of ground evaporation w.r.t. canopy liquid water (J kg-1 s-1) ! (cross deriavtives) - dTurbFluxCanair_dCanLiq = 0._rk ! derivative in net canopy air space fluxes w.r.t. canopy liquid water content (J kg-1 s-1) + dTurbFluxCanair_dCanLiq = 0._dp ! derivative in net canopy air space fluxes w.r.t. canopy liquid water content (J kg-1 s-1) dTurbFluxCanopy_dCanLiq = dLatHeatCanopyEvap_dCanLiq + dLatHeatCanopyTrans_dCanLiq ! derivative in net canopy turbulent fluxes w.r.t. canopy liquid water content (J kg-1 s-1) dTurbFluxGround_dCanLiq = dLatHeatGroundEvap_dCanLiq ! derivative in net ground turbulent fluxes w.r.t. canopy liquid water content (J kg-1 s-1) else ! (just make sure we return something) ! (energy derivatives) - dTurbFluxCanair_dTCanair = 0._rk - dTurbFluxCanair_dTCanopy = 0._rk - dTurbFluxCanair_dTGround = 0._rk - dTurbFluxCanopy_dTCanair = 0._rk - dTurbFluxCanopy_dTCanopy = 0._rk - dTurbFluxCanopy_dTGround = 0._rk - dTurbFluxGround_dTCanair = 0._rk - dTurbFluxGround_dTCanopy = 0._rk - dTurbFluxGround_dTGround = 0._rk + dTurbFluxCanair_dTCanair = 0._dp + dTurbFluxCanair_dTCanopy = 0._dp + dTurbFluxCanair_dTGround = 0._dp + dTurbFluxCanopy_dTCanair = 0._dp + dTurbFluxCanopy_dTCanopy = 0._dp + dTurbFluxCanopy_dTGround = 0._dp + dTurbFluxGround_dTCanair = 0._dp + dTurbFluxGround_dTCanopy = 0._dp + dTurbFluxGround_dTGround = 0._dp ! (liquid water derivatives) - dLatHeatCanopyEvap_dCanLiq = 0._rk - dLatHeatGroundEvap_dCanLiq = 0._rk + dLatHeatCanopyEvap_dCanLiq = 0._dp + dLatHeatGroundEvap_dCanLiq = 0._dp ! (cross deriavtives) - dTurbFluxCanair_dCanLiq = 0._rk - dTurbFluxCanopy_dCanLiq = 0._rk - dTurbFluxGround_dCanLiq = 0._rk + dTurbFluxCanair_dCanLiq = 0._dp + dTurbFluxCanopy_dCanLiq = 0._dp + dTurbFluxGround_dCanLiq = 0._dp end if end subroutine turbFluxes @@ -3123,27 +3123,27 @@ subroutine aStability(& logical(lgt),intent(in) :: computeDerivative ! flag to compute the derivative integer(i4b),intent(in) :: ixStability ! choice of stability function ! input: forcing data, diagnostic and state variables - real(rk),intent(in) :: mHeight ! measurement height (m) - real(rk),intent(in) :: airtemp ! air temperature (K) - real(rk),intent(in) :: sfcTemp ! surface temperature (K) - real(rk),intent(in) :: windspd ! wind speed (m s-1) + real(dp),intent(in) :: mHeight ! measurement height (m) + real(dp),intent(in) :: airtemp ! air temperature (K) + real(dp),intent(in) :: sfcTemp ! surface temperature (K) + real(dp),intent(in) :: windspd ! wind speed (m s-1) ! input: stability parameters - real(rk),intent(in) :: critRichNumber ! critical value for the bulk Richardson number where turbulence ceases (-) - real(rk),intent(in) :: Louis79_bparam ! parameter in Louis (1979) stability function - real(rk),intent(in) :: Mahrt87_eScale ! exponential scaling factor in the Mahrt (1987) stability function + real(dp),intent(in) :: critRichNumber ! critical value for the bulk Richardson number where turbulence ceases (-) + real(dp),intent(in) :: Louis79_bparam ! parameter in Louis (1979) stability function + real(dp),intent(in) :: Mahrt87_eScale ! exponential scaling factor in the Mahrt (1987) stability function ! output - real(rk),intent(out) :: RiBulk ! bulk Richardson number (-) - real(rk),intent(out) :: stabilityCorrection ! stability correction for turbulent heat fluxes (-) - real(rk),intent(out) :: dStabilityCorrection_dRich ! derivative in stability correction w.r.t. Richardson number (-) - real(rk),intent(out) :: dStabilityCorrection_dAirTemp ! derivative in stability correction w.r.t. air temperature (K-1) - real(rk),intent(out) :: dStabilityCorrection_dSfcTemp ! derivative in stability correction w.r.t. surface temperature (K-1) + real(dp),intent(out) :: RiBulk ! bulk Richardson number (-) + real(dp),intent(out) :: stabilityCorrection ! stability correction for turbulent heat fluxes (-) + real(dp),intent(out) :: dStabilityCorrection_dRich ! derivative in stability correction w.r.t. Richardson number (-) + real(dp),intent(out) :: dStabilityCorrection_dAirTemp ! derivative in stability correction w.r.t. air temperature (K-1) + real(dp),intent(out) :: dStabilityCorrection_dSfcTemp ! derivative in stability correction w.r.t. surface temperature (K-1) integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! local - real(rk), parameter :: verySmall=1.e-10_rk ! a very small number (avoid stability of zero) - real(rk) :: dRiBulk_dAirTemp ! derivative in the bulk Richardson number w.r.t. air temperature (K-1) - real(rk) :: dRiBulk_dSfcTemp ! derivative in the bulk Richardson number w.r.t. surface temperature (K-1) - real(rk) :: bPrime ! scaled "b" parameter for stability calculations in Louis (1979) + real(dp), parameter :: verySmall=1.e-10_dp ! a very small number (avoid stability of zero) + real(dp) :: dRiBulk_dAirTemp ! derivative in the bulk Richardson number w.r.t. air temperature (K-1) + real(dp) :: dRiBulk_dSfcTemp ! derivative in the bulk Richardson number w.r.t. surface temperature (K-1) + real(dp) :: bPrime ! scaled "b" parameter for stability calculations in Louis (1979) ! ----------------------------------------------------------------------------------------------------------------------------------------- ! initialize error control err=0; message='aStability/' @@ -3164,18 +3164,18 @@ subroutine aStability(& ! set derivative to one if not computing it if(.not.computeDerivative)then - dStabilityCorrection_dRich = 1._rk - dStabilityCorrection_dAirTemp = 1._rk - dStabilityCorrection_dSfcTemp = 1._rk + dStabilityCorrection_dRich = 1._dp + dStabilityCorrection_dAirTemp = 1._dp + dStabilityCorrection_dSfcTemp = 1._dp end if ! ***** process unstable cases - if(RiBulk<0._rk)then + if(RiBulk<0._dp)then ! compute surface-atmosphere exchange coefficient (-) - stabilityCorrection = (1._rk - 16._rk*RiBulk)**0.5_rk + stabilityCorrection = (1._dp - 16._dp*RiBulk)**0.5_dp ! compute derivative in surface-atmosphere exchange coefficient w.r.t. temperature (K-1) if(computeDerivative)then - dStabilityCorrection_dRich = (-16._rk) * 0.5_rk*(1._rk - 16._rk*RiBulk)**(-0.5_rk) + dStabilityCorrection_dRich = (-16._dp) * 0.5_dp*(1._dp - 16._dp*RiBulk)**(-0.5_dp) dStabilityCorrection_dAirTemp = dRiBulk_dAirTemp * dStabilityCorrection_dRich dStabilityCorrection_dSfcTemp = dRiBulk_dSfcTemp * dStabilityCorrection_dRich end if @@ -3188,24 +3188,24 @@ subroutine aStability(& ! ("standard" stability correction, a la Anderson 1976) case(standard) ! compute surface-atmosphere exchange coefficient (-) - if(RiBulk < critRichNumber) stabilityCorrection = (1._rk - 5._rk*RiBulk)**2._rk + if(RiBulk < critRichNumber) stabilityCorrection = (1._dp - 5._dp*RiBulk)**2._dp if(RiBulk >= critRichNumber) stabilityCorrection = verySmall ! compute derivative in surface-atmosphere exchange coefficient w.r.t. temperature (K-1) if(computeDerivative)then - if(RiBulk < critRichNumber) dStabilityCorrection_dRich = (-5._rk) * 2._rk*(1._rk - 5._rk*RiBulk) + if(RiBulk < critRichNumber) dStabilityCorrection_dRich = (-5._dp) * 2._dp*(1._dp - 5._dp*RiBulk) if(RiBulk >= critRichNumber) dStabilityCorrection_dRich = verySmall end if ! (Louis 1979) case(louisInversePower) ! scale the "b" parameter for stable conditions - bprime = Louis79_bparam/2._rk + bprime = Louis79_bparam/2._dp ! compute surface-atmosphere exchange coefficient (-) - stabilityCorrection = 1._rk / ( (1._rk + bprime*RiBulk)**2._rk ) + stabilityCorrection = 1._dp / ( (1._dp + bprime*RiBulk)**2._dp ) if(stabilityCorrection < epsilon(stabilityCorrection)) stabilityCorrection = epsilon(stabilityCorrection) ! compute derivative in surface-atmosphere exchange coefficient w.r.t. temperature (K-1) if(computeDerivative)then - dStabilityCorrection_dRich = bprime * (-2._rk)*(1._rk + bprime*RiBulk)**(-3._rk) + dStabilityCorrection_dRich = bprime * (-2._dp)*(1._dp + bprime*RiBulk)**(-3._dp) end if ! (Mahrt 1987) @@ -3251,36 +3251,36 @@ subroutine bulkRichardson(& err,message) ! output: error control implicit none ! input - real(rk),intent(in) :: airtemp ! air temperature (K) - real(rk),intent(in) :: sfcTemp ! surface temperature (K) - real(rk),intent(in) :: windspd ! wind speed (m s-1) - real(rk),intent(in) :: mHeight ! measurement height (m) + real(dp),intent(in) :: airtemp ! air temperature (K) + real(dp),intent(in) :: sfcTemp ! surface temperature (K) + real(dp),intent(in) :: windspd ! wind speed (m s-1) + real(dp),intent(in) :: mHeight ! measurement height (m) logical(lgt),intent(in) :: computeDerivative ! flag to compute the derivative ! output - real(rk),intent(inout) :: RiBulk ! bulk Richardson number (-) - real(rk),intent(out) :: dRiBulk_dAirTemp ! derivative in the bulk Richardson number w.r.t. air temperature (K-1) - real(rk),intent(out) :: dRiBulk_dSfcTemp ! derivative in the bulk Richardson number w.r.t. surface temperature (K-1) + real(dp),intent(inout) :: RiBulk ! bulk Richardson number (-) + real(dp),intent(out) :: dRiBulk_dAirTemp ! derivative in the bulk Richardson number w.r.t. air temperature (K-1) + real(dp),intent(out) :: dRiBulk_dSfcTemp ! derivative in the bulk Richardson number w.r.t. surface temperature (K-1) integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! local variables - real(rk) :: T_grad ! gradient in temperature between the atmosphere and surface (K) - real(rk) :: T_mean ! mean of the atmosphere and surface temperature (K) - real(rk) :: RiMult ! dimensionless scaling factor (-) + real(dp) :: T_grad ! gradient in temperature between the atmosphere and surface (K) + real(dp) :: T_mean ! mean of the atmosphere and surface temperature (K) + real(dp) :: RiMult ! dimensionless scaling factor (-) ! initialize error control err=0; message='bulkRichardson/' ! compute local variables T_grad = airtemp - sfcTemp - T_mean = 0.5_rk*(airtemp + sfcTemp) + T_mean = 0.5_dp*(airtemp + sfcTemp) RiMult = (gravity*mHeight)/(windspd*windspd) ! compute the Richardson number RiBulk = (T_grad/T_mean) * RiMult ! compute the derivative in the Richardson number if(computeDerivative)then - dRiBulk_dAirTemp = RiMult/T_mean - RiMult*T_grad/(0.5_rk*((airtemp + sfcTemp)**2._rk)) - dRiBulk_dSfcTemp = -RiMult/T_mean - RiMult*T_grad/(0.5_rk*((airtemp + sfcTemp)**2._rk)) + dRiBulk_dAirTemp = RiMult/T_mean - RiMult*T_grad/(0.5_dp*((airtemp + sfcTemp)**2._dp)) + dRiBulk_dSfcTemp = -RiMult/T_mean - RiMult*T_grad/(0.5_dp*((airtemp + sfcTemp)**2._dp)) else - dRiBulk_dAirTemp = 1._rk - dRiBulk_dSfcTemp = 1._rk + dRiBulk_dAirTemp = 1._dp + dRiBulk_dSfcTemp = 1._dp end if end subroutine bulkRichardson diff --git a/build/source/engine/vegPhenlgy.f90 b/build/source/engine/vegPhenlgy.f90 index b830e1a61..cf92d886e 100755 --- a/build/source/engine/vegPhenlgy.f90 +++ b/build/source/engine/vegPhenlgy.f90 @@ -58,8 +58,8 @@ module vegPhenlgy_module private public::vegPhenlgy ! algorithmic parameters -real(rk),parameter :: valueMissing=-9999._rk ! missing value, used when diagnostic or state variables are undefined -real(rk),parameter :: verySmall=1.e-6_rk ! used as an additive constant to check if substantial difference among real numbers +real(dp),parameter :: valueMissing=-9999._dp ! missing value, used when diagnostic or state variables are undefined +real(dp),parameter :: verySmall=1.e-6_dp ! used as an additive constant to check if substantial difference among real numbers contains @@ -93,14 +93,14 @@ subroutine vegPhenlgy(& type(var_dlength),intent(inout) :: diag_data ! diagnostic variables for a local HRU ! output logical(lgt),intent(out) :: computeVegFlux ! flag to indicate if we are computing fluxes over vegetation (.false. means veg is buried with snow) - real(rk),intent(out) :: canopyDepth ! canopy depth (m) - real(rk),intent(out) :: exposedVAI ! exposed vegetation area index (LAI + SAI) + real(dp),intent(out) :: canopyDepth ! canopy depth (m) + real(dp),intent(out) :: exposedVAI ! exposed vegetation area index (LAI + SAI) integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! ------------------------------------------------------------------------------------------------- ! local - real(rk) :: notUsed_heightCanopyTop ! height of the top of the canopy layer (m) - real(rk) :: heightAboveSnow ! height top of canopy is above the snow surface (m) + real(dp) :: notUsed_heightCanopyTop ! height of the top of the canopy layer (m) + real(dp) :: heightAboveSnow ! height top of canopy is above the snow surface (m) ! initialize error control err=0; message="vegPhenlgy/" ! ---------------------------------------------------------------------------------------------------------------------------------- @@ -181,7 +181,7 @@ subroutine vegPhenlgy(& heightAboveSnow = heightCanopyTop - scalarSnowDepth ! height top of canopy is above the snow surface (m) ! determine if need to include vegetation in the energy flux routines - computeVegFlux = (exposedVAI > 0.05_rk .and. heightAboveSnow > 0.05_rk) + computeVegFlux = (exposedVAI > 0.05_dp .and. heightAboveSnow > 0.05_dp) !write(*,'(a,1x,i2,1x,L1,1x,10(f12.5,1x))') 'vegTypeIndex, computeVegFlux, heightCanopyTop, heightAboveSnow, scalarSnowDepth = ', & ! vegTypeIndex, computeVegFlux, heightCanopyTop, heightAboveSnow, scalarSnowDepth diff --git a/build/source/engine/vegSWavRad.f90 b/build/source/engine/vegSWavRad.f90 index ef6d97f50..c9f72b9b4 100755 --- a/build/source/engine/vegSWavRad.f90 +++ b/build/source/engine/vegSWavRad.f90 @@ -58,10 +58,10 @@ module vegSWavRad_module integer(i4b),parameter :: iLoc = 1 ! i-location integer(i4b),parameter :: jLoc = 1 ! j-location ! algorithmic parameters -real(rk),parameter :: missingValue=-9999._rk ! missing value, used when diagnostic or state variables are undefined -real(rk),parameter :: verySmall=1.e-6_rk ! used as an additive constant to check if substantial difference among real numbers -real(rk),parameter :: mpe=1.e-6_rk ! prevents overflow error if division by zero -real(rk),parameter :: dx=1.e-6_rk ! finite difference increment +real(dp),parameter :: missingValue=-9999._dp ! missing value, used when diagnostic or state variables are undefined +real(dp),parameter :: verySmall=1.e-6_dp ! used as an additive constant to check if substantial difference among real numbers +real(dp),parameter :: mpe=1.e-6_dp ! prevents overflow error if division by zero +real(dp),parameter :: dx=1.e-6_dp ! finite difference increment contains @@ -83,7 +83,7 @@ subroutine vegSWavRad(& USE NOAHMP_ROUTINES,only:radiation ! subroutine to calculate albedo and shortwave radiaiton in the canopy implicit none ! dummy variables - real(rk),intent(in) :: dt ! time step (s) -- only used in Noah-MP radiation, to compute albedo + real(dp),intent(in) :: dt ! time step (s) -- only used in Noah-MP radiation, to compute albedo integer(i4b),intent(in) :: nSnow ! number of snow layers integer(i4b),intent(in) :: nSoil ! number of soil layers integer(i4b),intent(in) :: nLayers ! total number of layers @@ -96,15 +96,15 @@ subroutine vegSWavRad(& character(*),intent(out) :: message ! error message ! local variables character(LEN=256) :: cmessage ! error message of downwind routine - real(rk) :: snowmassPlusNewsnow ! sum of snow mass and new snowfall (kg m-2 [mm]) - real(rk) :: scalarGroundSnowFraction ! snow cover fraction on the ground surface (-) - real(rk),parameter :: scalarVegFraction=1._rk ! vegetation fraction (=1 forces no canopy gaps and open areas in radiation routine) - real(rk) :: scalarTotalReflectedSolar ! total reflected solar radiation (W m-2) - real(rk) :: scalarTotalAbsorbedSolar ! total absorbed solar radiation (W m-2) - real(rk) :: scalarCanopyReflectedSolar ! solar radiation reflected from the canopy (W m-2) - real(rk) :: scalarGroundReflectedSolar ! solar radiation reflected from the ground (W m-2) - real(rk) :: scalarBetweenCanopyGapFraction ! between canopy gap fraction for beam (-) - real(rk) :: scalarWithinCanopyGapFraction ! within canopy gap fraction for beam (-) + real(dp) :: snowmassPlusNewsnow ! sum of snow mass and new snowfall (kg m-2 [mm]) + real(dp) :: scalarGroundSnowFraction ! snow cover fraction on the ground surface (-) + real(dp),parameter :: scalarVegFraction=1._dp ! vegetation fraction (=1 forces no canopy gaps and open areas in radiation routine) + real(dp) :: scalarTotalReflectedSolar ! total reflected solar radiation (W m-2) + real(dp) :: scalarTotalAbsorbedSolar ! total absorbed solar radiation (W m-2) + real(dp) :: scalarCanopyReflectedSolar ! solar radiation reflected from the canopy (W m-2) + real(dp) :: scalarGroundReflectedSolar ! solar radiation reflected from the ground (W m-2) + real(dp) :: scalarBetweenCanopyGapFraction ! between canopy gap fraction for beam (-) + real(dp) :: scalarWithinCanopyGapFraction ! within canopy gap fraction for beam (-) ! ---------------------------------------------------------------------------------------------------------------------------------- ! make association between local variables and the information in the data structures associate(& @@ -160,9 +160,9 @@ subroutine vegSWavRad(& ! compute the ground snow fraction if(nSnow > 0)then - scalarGroundSnowFraction = 1._rk + scalarGroundSnowFraction = 1._dp else - scalarGroundSnowFraction = 0._rk + scalarGroundSnowFraction = 0._dp end if ! (if there is snow on the ground) ! * compute radiation fluxes... @@ -182,7 +182,7 @@ subroutine vegSWavRad(& snowmassPlusNewsnow, & ! intent(in): sum of snow mass and new snowfall (kg m-2 [mm]) dt, & ! intent(in): time step (s) scalarCosZenith, & ! intent(in): cosine of the solar zenith angle (0-1) - scalarSnowDepth*1000._rk, & ! intent(in): snow depth on the ground surface (mm) + scalarSnowDepth*1000._dp, & ! intent(in): snow depth on the ground surface (mm) scalarGroundTemp, & ! intent(in): ground temperature (K) scalarCanopyTemp, & ! intent(in): canopy temperature (K) scalarGroundSnowFraction, & ! intent(in): snow cover fraction (0-1) @@ -311,32 +311,32 @@ subroutine canopy_SW(& integer(i4b),intent(in) :: isc ! soil color index logical(lgt),intent(in) :: computeVegFlux ! logical flag to compute vegetation fluxes (.false. if veg buried by snow) integer(i4b),intent(in) :: ix_canopySrad ! choice of canopy shortwave radiation method - real(rk),intent(in) :: scalarCosZenith ! cosine of the solar zenith angle (0-1) - real(rk),intent(in) :: spectralIncomingDirect(:) ! incoming direct solar radiation in each wave band (w m-2) - real(rk),intent(in) :: spectralIncomingDiffuse(:) ! incoming diffuse solar radiation in each wave band (w m-2) - real(rk),intent(in) :: spectralSnowAlbedoDirect(:) ! direct albedo of snow in each spectral band (-) - real(rk),intent(in) :: spectralSnowAlbedoDiffuse(:) ! diffuse albedo of snow in each spectral band (-) - real(rk),intent(in) :: scalarExposedLAI ! exposed leaf area index after burial by snow (m2 m-2) - real(rk),intent(in) :: scalarExposedSAI ! exposed stem area index after burial by snow (m2 m-2) - real(rk),intent(in) :: scalarVegFraction ! vegetation fraction (=1 forces no canopy gaps and open areas in radiation routine) - real(rk),intent(in) :: scalarCanopyWetFraction ! fraction of canopy that is wet (-) - real(rk),intent(in) :: scalarGroundSnowFraction ! fraction of ground that is snow covered (-) - real(rk),intent(in) :: scalarVolFracLiqUpper ! volumetric liquid water content in the upper-most soil layer (-) - real(rk),intent(in) :: scalarCanopyTempTrial ! trial value of canopy temperature (K) + real(dp),intent(in) :: scalarCosZenith ! cosine of the solar zenith angle (0-1) + real(dp),intent(in) :: spectralIncomingDirect(:) ! incoming direct solar radiation in each wave band (w m-2) + real(dp),intent(in) :: spectralIncomingDiffuse(:) ! incoming diffuse solar radiation in each wave band (w m-2) + real(dp),intent(in) :: spectralSnowAlbedoDirect(:) ! direct albedo of snow in each spectral band (-) + real(dp),intent(in) :: spectralSnowAlbedoDiffuse(:) ! diffuse albedo of snow in each spectral band (-) + real(dp),intent(in) :: scalarExposedLAI ! exposed leaf area index after burial by snow (m2 m-2) + real(dp),intent(in) :: scalarExposedSAI ! exposed stem area index after burial by snow (m2 m-2) + real(dp),intent(in) :: scalarVegFraction ! vegetation fraction (=1 forces no canopy gaps and open areas in radiation routine) + real(dp),intent(in) :: scalarCanopyWetFraction ! fraction of canopy that is wet (-) + real(dp),intent(in) :: scalarGroundSnowFraction ! fraction of ground that is snow covered (-) + real(dp),intent(in) :: scalarVolFracLiqUpper ! volumetric liquid water content in the upper-most soil layer (-) + real(dp),intent(in) :: scalarCanopyTempTrial ! trial value of canopy temperature (K) ! output - real(rk),intent(out) :: spectralBelowCanopyDirect(:) ! downward direct flux below veg layer (W m-2) - real(rk),intent(out) :: spectralBelowCanopyDiffuse(:) ! downward diffuse flux below veg layer (W m-2) - real(rk),intent(out) :: scalarBelowCanopySolar ! radiation transmitted below the canopy (W m-2) - real(rk),intent(out) :: spectralAlbGndDirect(:) ! direct albedo of underlying surface (1:nBands) (-) - real(rk),intent(out) :: spectralAlbGndDiffuse(:) ! diffuse albedo of underlying surface (1:nBands) (-) - real(rk),intent(out) :: scalarGroundAlbedo ! albedo of the ground surface (-) - real(rk),intent(out) :: scalarCanopyAbsorbedSolar ! radiation absorbed by the vegetation canopy (W m-2) - real(rk),intent(out) :: scalarGroundAbsorbedSolar ! radiation absorbed by the ground (W m-2) - real(rk),intent(out) :: scalarCanopySunlitFraction ! sunlit fraction of canopy (-) - real(rk),intent(out) :: scalarCanopySunlitLAI ! sunlit leaf area (-) - real(rk),intent(out) :: scalarCanopyShadedLAI ! shaded leaf area (-) - real(rk),intent(out) :: scalarCanopySunlitPAR ! average absorbed par for sunlit leaves (w m-2) - real(rk),intent(out) :: scalarCanopyShadedPAR ! average absorbed par for shaded leaves (w m-2) + real(dp),intent(out) :: spectralBelowCanopyDirect(:) ! downward direct flux below veg layer (W m-2) + real(dp),intent(out) :: spectralBelowCanopyDiffuse(:) ! downward diffuse flux below veg layer (W m-2) + real(dp),intent(out) :: scalarBelowCanopySolar ! radiation transmitted below the canopy (W m-2) + real(dp),intent(out) :: spectralAlbGndDirect(:) ! direct albedo of underlying surface (1:nBands) (-) + real(dp),intent(out) :: spectralAlbGndDiffuse(:) ! diffuse albedo of underlying surface (1:nBands) (-) + real(dp),intent(out) :: scalarGroundAlbedo ! albedo of the ground surface (-) + real(dp),intent(out) :: scalarCanopyAbsorbedSolar ! radiation absorbed by the vegetation canopy (W m-2) + real(dp),intent(out) :: scalarGroundAbsorbedSolar ! radiation absorbed by the ground (W m-2) + real(dp),intent(out) :: scalarCanopySunlitFraction ! sunlit fraction of canopy (-) + real(dp),intent(out) :: scalarCanopySunlitLAI ! sunlit leaf area (-) + real(dp),intent(out) :: scalarCanopyShadedLAI ! shaded leaf area (-) + real(dp),intent(out) :: scalarCanopySunlitPAR ! average absorbed par for sunlit leaves (w m-2) + real(dp),intent(out) :: scalarCanopyShadedPAR ! average absorbed par for shaded leaves (w m-2) integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! ----------------------------------------------------------------------------------------------------------------------------------------------------------------- @@ -349,72 +349,72 @@ subroutine canopy_SW(& integer(i4b) :: ic ! 0=unit incoming direct; 1=unit incoming diffuse character(LEN=256) :: cmessage ! error message of downwind routine ! variables used in Nijssen-Lettenmaier method - real(rk),parameter :: multScatExp=0.81_rk ! multiple scattering exponent (-) - real(rk),parameter :: bulkCanopyAlbedo=0.25_rk ! bulk canopy albedo (-), smaller than actual canopy albedo because of shading in the canopy - real(rk),dimension(1:nBands) :: spectralIncomingSolar ! total incoming solar radiation in each spectral band (W m-2) - real(rk),dimension(1:nBands) :: spectralGroundAbsorbedDirect ! total direct radiation absorbed at the ground surface (W m-2) - real(rk),dimension(1:nBands) :: spectralGroundAbsorbedDiffuse ! total diffuse radiation absorbed at the ground surface (W m-2) - real(rk) :: Fdirect ! fraction of direct radiation (-) - real(rk) :: tauInitial ! transmission in the absence of scattering and multiple reflections (-) - real(rk) :: tauTotal ! transmission due to scattering and multiple reflections (-) + real(dp),parameter :: multScatExp=0.81_dp ! multiple scattering exponent (-) + real(dp),parameter :: bulkCanopyAlbedo=0.25_dp ! bulk canopy albedo (-), smaller than actual canopy albedo because of shading in the canopy + real(dp),dimension(1:nBands) :: spectralIncomingSolar ! total incoming solar radiation in each spectral band (W m-2) + real(dp),dimension(1:nBands) :: spectralGroundAbsorbedDirect ! total direct radiation absorbed at the ground surface (W m-2) + real(dp),dimension(1:nBands) :: spectralGroundAbsorbedDiffuse ! total diffuse radiation absorbed at the ground surface (W m-2) + real(dp) :: Fdirect ! fraction of direct radiation (-) + real(dp) :: tauInitial ! transmission in the absence of scattering and multiple reflections (-) + real(dp) :: tauTotal ! transmission due to scattering and multiple reflections (-) ! variables used in Mahat-Tarboton method - real(rk),parameter :: Frad_vis=0.5_rk ! fraction of radiation in the visible wave band (-) - real(rk),parameter :: gProjParam=0.5_rk ! projected leaf and stem area in the solar direction (-) - real(rk),parameter :: bScatParam=0.5_rk ! back scatter parameter (-) - real(rk) :: transCoef ! transmission coefficient (-) - real(rk) :: transCoefPrime ! "k-prime" coefficient (-) - real(rk) :: groundAlbedoDirect ! direct ground albedo (-) - real(rk) :: groundAlbedoDiffuse ! diffuse ground albedo (-) - real(rk) :: tauInfinite ! direct transmission for an infinite canopy (-) - real(rk) :: betaInfinite ! direct upward reflection factor for an infinite canopy (-) - real(rk) :: tauFinite ! direct transmission for a finite canopy (-) - real(rk) :: betaFinite ! direct reflectance for a finite canopy (-) - real(rk) :: vFactor ! scaled vegetation area used to compute diffuse radiation (-) - real(rk) :: expi ! exponential integral (-) - real(rk) :: taudInfinite ! diffuse transmission for an infinite canopy (-) - real(rk) :: taudFinite ! diffuse transmission for a finite canopy (-) - real(rk) :: betadFinite ! diffuse reflectance for a finite canopy (-) - real(rk) :: refMult ! multiple reflection factor (-) - real(rk) :: fracRadAbsDown ! fraction of radiation absorbed by vegetation on the way down - real(rk) :: fracRadAbsUp ! fraction of radiation absorbed by vegetation on the way up - real(rk) :: tauDirect ! total transmission of direct radiation (-) - real(rk) :: tauDiffuse ! total transmission of diffuse radiation (-) - real(rk) :: fractionRefDirect ! fraction of direct radiaiton lost to space (-) - real(rk) :: fractionRefDiffuse ! fraction of diffuse radiaiton lost to space (-) - real(rk),dimension(1:nBands) :: spectralBelowCanopySolar ! total below-canopy radiation for each wave band (W m-2) - real(rk),dimension(1:nBands) :: spectralTotalReflectedSolar ! total reflected radiaion for each wave band (W m-2) - real(rk),dimension(1:nBands) :: spectralGroundAbsorbedSolar ! radiation absorbed by the ground in each wave band (W m-2) - real(rk),dimension(1:nBands) :: spectralCanopyAbsorbedSolar ! radiation absorbed by the canopy in each wave band (W m-2) + real(dp),parameter :: Frad_vis=0.5_dp ! fraction of radiation in the visible wave band (-) + real(dp),parameter :: gProjParam=0.5_dp ! projected leaf and stem area in the solar direction (-) + real(dp),parameter :: bScatParam=0.5_dp ! back scatter parameter (-) + real(dp) :: transCoef ! transmission coefficient (-) + real(dp) :: transCoefPrime ! "k-prime" coefficient (-) + real(dp) :: groundAlbedoDirect ! direct ground albedo (-) + real(dp) :: groundAlbedoDiffuse ! diffuse ground albedo (-) + real(dp) :: tauInfinite ! direct transmission for an infinite canopy (-) + real(dp) :: betaInfinite ! direct upward reflection factor for an infinite canopy (-) + real(dp) :: tauFinite ! direct transmission for a finite canopy (-) + real(dp) :: betaFinite ! direct reflectance for a finite canopy (-) + real(dp) :: vFactor ! scaled vegetation area used to compute diffuse radiation (-) + real(dp) :: expi ! exponential integral (-) + real(dp) :: taudInfinite ! diffuse transmission for an infinite canopy (-) + real(dp) :: taudFinite ! diffuse transmission for a finite canopy (-) + real(dp) :: betadFinite ! diffuse reflectance for a finite canopy (-) + real(dp) :: refMult ! multiple reflection factor (-) + real(dp) :: fracRadAbsDown ! fraction of radiation absorbed by vegetation on the way down + real(dp) :: fracRadAbsUp ! fraction of radiation absorbed by vegetation on the way up + real(dp) :: tauDirect ! total transmission of direct radiation (-) + real(dp) :: tauDiffuse ! total transmission of diffuse radiation (-) + real(dp) :: fractionRefDirect ! fraction of direct radiaiton lost to space (-) + real(dp) :: fractionRefDiffuse ! fraction of diffuse radiaiton lost to space (-) + real(dp),dimension(1:nBands) :: spectralBelowCanopySolar ! total below-canopy radiation for each wave band (W m-2) + real(dp),dimension(1:nBands) :: spectralTotalReflectedSolar ! total reflected radiaion for each wave band (W m-2) + real(dp),dimension(1:nBands) :: spectralGroundAbsorbedSolar ! radiation absorbed by the ground in each wave band (W m-2) + real(dp),dimension(1:nBands) :: spectralCanopyAbsorbedSolar ! radiation absorbed by the canopy in each wave band (W m-2) ! vegetation properties used in 2-stream - real(rk) :: scalarExposedVAI ! one-sided leaf+stem area index (m2/m2) - real(rk) :: weightLeaf ! fraction of exposed VAI that is leaf - real(rk) :: weightStem ! fraction of exposed VAI that is stem - real(rk),dimension(1:nBands) :: spectralVegReflc ! leaf+stem reflectance (1:nbands) - real(rk),dimension(1:nBands) :: spectralVegTrans ! leaf+stem transmittance (1:nBands) + real(dp) :: scalarExposedVAI ! one-sided leaf+stem area index (m2/m2) + real(dp) :: weightLeaf ! fraction of exposed VAI that is leaf + real(dp) :: weightStem ! fraction of exposed VAI that is stem + real(dp),dimension(1:nBands) :: spectralVegReflc ! leaf+stem reflectance (1:nbands) + real(dp),dimension(1:nBands) :: spectralVegTrans ! leaf+stem transmittance (1:nBands) ! output from two-stream -- direct-beam - real(rk),dimension(1:nBands) :: spectralCanopyAbsorbedDirect ! flux abs by veg layer (per unit incoming flux), (1:nBands) - real(rk),dimension(1:nBands) :: spectralTotalReflectedDirect ! flux refl above veg layer (per unit incoming flux), (1:nBands) - real(rk),dimension(1:nBands) :: spectralDirectBelowCanopyDirect ! down dir flux below veg layer (per unit in flux), (1:nBands) - real(rk),dimension(1:nBands) :: spectralDiffuseBelowCanopyDirect ! down dif flux below veg layer (per unit in flux), (1:nBands) - real(rk),dimension(1:nBands) :: spectralCanopyReflectedDirect ! flux reflected by veg layer (per unit incoming flux), (1:nBands) - real(rk),dimension(1:nBands) :: spectralGroundReflectedDirect ! flux reflected by ground (per unit incoming flux), (1:nBands) + real(dp),dimension(1:nBands) :: spectralCanopyAbsorbedDirect ! flux abs by veg layer (per unit incoming flux), (1:nBands) + real(dp),dimension(1:nBands) :: spectralTotalReflectedDirect ! flux refl above veg layer (per unit incoming flux), (1:nBands) + real(dp),dimension(1:nBands) :: spectralDirectBelowCanopyDirect ! down dir flux below veg layer (per unit in flux), (1:nBands) + real(dp),dimension(1:nBands) :: spectralDiffuseBelowCanopyDirect ! down dif flux below veg layer (per unit in flux), (1:nBands) + real(dp),dimension(1:nBands) :: spectralCanopyReflectedDirect ! flux reflected by veg layer (per unit incoming flux), (1:nBands) + real(dp),dimension(1:nBands) :: spectralGroundReflectedDirect ! flux reflected by ground (per unit incoming flux), (1:nBands) ! output from two-stream -- diffuse - real(rk),dimension(1:nBands) :: spectralCanopyAbsorbedDiffuse ! flux abs by veg layer (per unit incoming flux), (1:nBands) - real(rk),dimension(1:nBands) :: spectralTotalReflectedDiffuse ! flux refl above veg layer (per unit incoming flux), (1:nBands) - real(rk),dimension(1:nBands) :: spectralDirectBelowCanopyDiffuse ! down dir flux below veg layer (per unit in flux), (1:nBands) - real(rk),dimension(1:nBands) :: spectralDiffuseBelowCanopyDiffuse ! down dif flux below veg layer (per unit in flux), (1:nBands) - real(rk),dimension(1:nBands) :: spectralCanopyReflectedDiffuse ! flux reflected by veg layer (per unit incoming flux), (1:nBands) - real(rk),dimension(1:nBands) :: spectralGroundReflectedDiffuse ! flux reflected by ground (per unit incoming flux), (1:nBands) + real(dp),dimension(1:nBands) :: spectralCanopyAbsorbedDiffuse ! flux abs by veg layer (per unit incoming flux), (1:nBands) + real(dp),dimension(1:nBands) :: spectralTotalReflectedDiffuse ! flux refl above veg layer (per unit incoming flux), (1:nBands) + real(dp),dimension(1:nBands) :: spectralDirectBelowCanopyDiffuse ! down dir flux below veg layer (per unit in flux), (1:nBands) + real(dp),dimension(1:nBands) :: spectralDiffuseBelowCanopyDiffuse ! down dif flux below veg layer (per unit in flux), (1:nBands) + real(dp),dimension(1:nBands) :: spectralCanopyReflectedDiffuse ! flux reflected by veg layer (per unit incoming flux), (1:nBands) + real(dp),dimension(1:nBands) :: spectralGroundReflectedDiffuse ! flux reflected by ground (per unit incoming flux), (1:nBands) ! output from two-stream -- scalar variables - real(rk) :: scalarGproj ! projected leaf+stem area in solar direction - real(rk) :: scalarBetweenCanopyGapFraction ! between canopy gap fraction for beam (-) - real(rk) :: scalarWithinCanopyGapFraction ! within canopy gap fraction for beam (-) + real(dp) :: scalarGproj ! projected leaf+stem area in solar direction + real(dp) :: scalarBetweenCanopyGapFraction ! between canopy gap fraction for beam (-) + real(dp) :: scalarWithinCanopyGapFraction ! within canopy gap fraction for beam (-) ! radiation fluxes - real(rk) :: ext ! optical depth of direct beam per unit leaf + stem area - real(rk) :: scalarCanopyShadedFraction ! shaded fraction of the canopy - real(rk) :: fractionLAI ! fraction of vegetation that is leaves - real(rk) :: visibleAbsDirect ! direct-beam radiation absorbed in the visible part of the spectrum (W m-2) - real(rk) :: visibleAbsDiffuse ! diffuse radiation absorbed in the visible part of the spectrum (W m-2) + real(dp) :: ext ! optical depth of direct beam per unit leaf + stem area + real(dp) :: scalarCanopyShadedFraction ! shaded fraction of the canopy + real(dp) :: fractionLAI ! fraction of vegetation that is leaves + real(dp) :: visibleAbsDirect ! direct-beam radiation absorbed in the visible part of the spectrum (W m-2) + real(dp) :: visibleAbsDiffuse ! diffuse radiation absorbed in the visible part of the spectrum (W m-2) ! ----------------------------------------------------------------------------------------------------------------------------------------------------------------- ! initialize error control err=0; message='canopy_SW/' @@ -434,18 +434,18 @@ subroutine canopy_SW(& if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! initialize accumulated fluxes - scalarBelowCanopySolar = 0._rk ! radiation transmitted below the canopy (W m-2) - scalarCanopyAbsorbedSolar = 0._rk ! radiation absorbed by the vegetation canopy (W m-2) - scalarGroundAbsorbedSolar = 0._rk ! radiation absorbed by the ground (W m-2) + scalarBelowCanopySolar = 0._dp ! radiation transmitted below the canopy (W m-2) + scalarCanopyAbsorbedSolar = 0._dp ! radiation absorbed by the vegetation canopy (W m-2) + scalarGroundAbsorbedSolar = 0._dp ! radiation absorbed by the ground (W m-2) ! check for an early return (no radiation or no exposed canopy) if(.not.computeVegFlux .or. scalarCosZenith < tiny(scalarCosZenith))then ! set canopy radiation to zero - scalarCanopySunlitFraction = 0._rk ! sunlit fraction of canopy (-) - scalarCanopySunlitLAI = 0._rk ! sunlit leaf area (-) + scalarCanopySunlitFraction = 0._dp ! sunlit fraction of canopy (-) + scalarCanopySunlitLAI = 0._dp ! sunlit leaf area (-) scalarCanopyShadedLAI = scalarExposedLAI ! shaded leaf area (-) - scalarCanopySunlitPAR = 0._rk ! average absorbed par for sunlit leaves (w m-2) - scalarCanopyShadedPAR = 0._rk ! average absorbed par for shaded leaves (w m-2) + scalarCanopySunlitPAR = 0._dp ! average absorbed par for sunlit leaves (w m-2) + scalarCanopyShadedPAR = 0._dp ! average absorbed par for shaded leaves (w m-2) ! compute below-canopy radiation do iBand=1,nBands ! (set below-canopy radiation to incoming radiation) @@ -453,16 +453,16 @@ subroutine canopy_SW(& spectralBelowCanopyDirect(iBand) = spectralIncomingDirect(iBand) spectralBelowCanopyDiffuse(iBand) = spectralIncomingDiffuse(iBand) else - spectralBelowCanopyDirect(iBand) = 0._rk - spectralBelowCanopyDiffuse(iBand) = 0._rk + spectralBelowCanopyDirect(iBand) = 0._dp + spectralBelowCanopyDiffuse(iBand) = 0._dp end if ! (accumulate radiation transmitted below the canopy) scalarBelowCanopySolar = scalarBelowCanopySolar + & ! contribution from all previous wave bands spectralBelowCanopyDirect(iBand) + spectralBelowCanopyDiffuse(iBand) ! contribution from current wave band ! (accumulate radiation absorbed by the ground) scalarGroundAbsorbedSolar = scalarGroundAbsorbedSolar + & ! contribution from all previous wave bands - spectralBelowCanopyDirect(iBand)*(1._rk - spectralAlbGndDirect(iBand)) + & ! direct radiation from current wave band - spectralBelowCanopyDiffuse(iBand)*(1._rk - spectralAlbGndDiffuse(iBand)) ! diffuse radiation from current wave band + spectralBelowCanopyDirect(iBand)*(1._dp - spectralAlbGndDirect(iBand)) + & ! direct radiation from current wave band + spectralBelowCanopyDiffuse(iBand)*(1._dp - spectralAlbGndDiffuse(iBand)) ! diffuse radiation from current wave band end do ! looping through wave bands return end if @@ -490,8 +490,8 @@ subroutine canopy_SW(& !print*, 'tauTotal = ', tauTotal ! compute ground albedo (-) - groundAlbedoDirect = Frad_vis*spectralAlbGndDirect(ixVisible) + (1._rk - Frad_vis)*spectralAlbGndDirect(ixNearIR) - groundAlbedoDiffuse = Frad_vis*spectralAlbGndDiffuse(ixVisible) + (1._rk - Frad_vis)*spectralAlbGndDiffuse(ixNearIR) + groundAlbedoDirect = Frad_vis*spectralAlbGndDirect(ixVisible) + (1._dp - Frad_vis)*spectralAlbGndDirect(ixNearIR) + groundAlbedoDiffuse = Frad_vis*spectralAlbGndDiffuse(ixVisible) + (1._dp - Frad_vis)*spectralAlbGndDiffuse(ixNearIR) ! compute radiation in each spectral band (W m-2) do iBand=1,nBands @@ -501,7 +501,7 @@ subroutine canopy_SW(& ! compute fraction of direct radiation Fdirect = spectralIncomingDirect(iBand) / (spectralIncomingSolar(iBand) + verySmall) - if(Fdirect < 0._rk .or. Fdirect > 1._rk)then + if(Fdirect < 0._dp .or. Fdirect > 1._dp)then print*, 'spectralIncomingDirect(iBand) = ', spectralIncomingDirect(iBand) print*, 'spectralIncomingSolar(iBand) = ', spectralIncomingSolar(iBand) print*, 'Fdirect = ', Fdirect @@ -510,8 +510,8 @@ subroutine canopy_SW(& end if ! compute ground albedo (-) - scalarGroundAlbedo = Fdirect*groundAlbedoDirect + (1._rk - Fdirect)*groundAlbedoDiffuse - if(scalarGroundAlbedo < 0._rk .or. scalarGroundAlbedo > 1._rk)then + scalarGroundAlbedo = Fdirect*groundAlbedoDirect + (1._dp - Fdirect)*groundAlbedoDiffuse + if(scalarGroundAlbedo < 0._dp .or. scalarGroundAlbedo > 1._dp)then print*, 'groundAlbedoDirect = ', groundAlbedoDirect print*, 'groundAlbedoDiffuse = ', groundAlbedoDiffuse message=trim(message)//'BeersLaw: albedo is less than zero or greater than one' @@ -524,13 +524,13 @@ subroutine canopy_SW(& spectralBelowCanopySolar(iBand) = spectralBelowCanopyDirect(iBand) + spectralBelowCanopyDiffuse(iBand) ! compute radiation absorbed by the ground in given wave band (W m-2) - spectralGroundAbsorbedDirect(iBand) = (1._rk - scalarGroundAlbedo)*spectralBelowCanopyDirect(iBand) - spectralGroundAbsorbedDiffuse(iBand) = (1._rk - scalarGroundAlbedo)*spectralBelowCanopyDiffuse(iBand) + spectralGroundAbsorbedDirect(iBand) = (1._dp - scalarGroundAlbedo)*spectralBelowCanopyDirect(iBand) + spectralGroundAbsorbedDiffuse(iBand) = (1._dp - scalarGroundAlbedo)*spectralBelowCanopyDiffuse(iBand) spectralGroundAbsorbedSolar(iBand) = spectralGroundAbsorbedDirect(iBand) + spectralGroundAbsorbedDiffuse(iBand) ! compute radiation absorbed by vegetation in current wave band (W m-2) - fracRadAbsDown = (1._rk - tauTotal)*(1._rk - bulkCanopyAlbedo) ! (fraction of radiation absorbed on the way down) - fracRadAbsUp = tauTotal*scalarGroundAlbedo*(1._rk - tauTotal) ! (fraction of radiation absorbed on the way up) + fracRadAbsDown = (1._dp - tauTotal)*(1._dp - bulkCanopyAlbedo) ! (fraction of radiation absorbed on the way down) + fracRadAbsUp = tauTotal*scalarGroundAlbedo*(1._dp - tauTotal) ! (fraction of radiation absorbed on the way up) spectralCanopyAbsorbedDirect(iBand) = spectralIncomingDirect(iBand)*(fracRadAbsDown + fracRadAbsUp) spectralCanopyAbsorbedDiffuse(iBand) = spectralIncomingDiffuse(iBand)*(fracRadAbsDown + fracRadAbsUp) spectralCanopyAbsorbedSolar(iBand) = spectralCanopyAbsorbedDirect(iBand) + spectralCanopyAbsorbedDiffuse(iBand) @@ -547,7 +547,7 @@ subroutine canopy_SW(& spectralTotalReflectedDirect(iBand) = spectralIncomingDirect(iBand) - spectralGroundAbsorbedDirect(iBand) - spectralCanopyAbsorbedDirect(iBand) spectralTotalReflectedDiffuse(iBand) = spectralIncomingDiffuse(iBand) - spectralGroundAbsorbedDiffuse(iBand) - spectralCanopyAbsorbedDiffuse(iBand) spectralTotalReflectedSolar(iBand) = spectralTotalReflectedDirect(iBand) + spectralTotalReflectedDiffuse(iBand) - if(spectralTotalReflectedDirect(iBand) < 0._rk .or. spectralTotalReflectedDiffuse(iBand) < 0._rk)then + if(spectralTotalReflectedDirect(iBand) < 0._dp .or. spectralTotalReflectedDiffuse(iBand) < 0._dp)then print*, 'scalarGroundAlbedo = ', scalarGroundAlbedo print*, 'tauTotal = ', tauTotal print*, 'fracRadAbsDown = ', fracRadAbsDown @@ -587,11 +587,11 @@ subroutine canopy_SW(& ! compute transmission of diffuse radiation (-) vFactor = scalarGproj*scalarExposedVAI expi = expInt(vFactor) - taudFinite = (1._rk - vFactor)*exp(-vFactor) + (vFactor**2._rk)*expi + taudFinite = (1._dp - vFactor)*exp(-vFactor) + (vFactor**2._dp)*expi ! compute ground albedo (-) - groundAlbedoDirect = Frad_vis*spectralAlbGndDirect(ixVisible) + (1._rk - Frad_vis)*spectralAlbGndDirect(ixNearIR) - groundAlbedoDiffuse = Frad_vis*spectralAlbGndDiffuse(ixVisible) + (1._rk - Frad_vis)*spectralAlbGndDiffuse(ixNearIR) + groundAlbedoDirect = Frad_vis*spectralAlbGndDirect(ixVisible) + (1._dp - Frad_vis)*spectralAlbGndDirect(ixNearIR) + groundAlbedoDiffuse = Frad_vis*spectralAlbGndDiffuse(ixVisible) + (1._dp - Frad_vis)*spectralAlbGndDiffuse(ixNearIR) ! compute radiation in each spectral band (W m-2) do iBand=1,nBands @@ -601,7 +601,7 @@ subroutine canopy_SW(& ! compute fraction of direct radiation Fdirect = spectralIncomingDirect(iBand) / (spectralIncomingSolar(iBand) + verySmall) - if(Fdirect < 0._rk .or. Fdirect > 1._rk)then + if(Fdirect < 0._dp .or. Fdirect > 1._dp)then print*, 'spectralIncomingDirect(iBand) = ', spectralIncomingDirect(iBand) print*, 'spectralIncomingSolar(iBand) = ', spectralIncomingSolar(iBand) print*, 'Fdirect = ', Fdirect @@ -610,8 +610,8 @@ subroutine canopy_SW(& end if ! compute ground albedo (-) - scalarGroundAlbedo = Fdirect*groundAlbedoDirect + (1._rk - Fdirect)*groundAlbedoDiffuse - if(scalarGroundAlbedo < 0._rk .or. scalarGroundAlbedo > 1._rk)then + scalarGroundAlbedo = Fdirect*groundAlbedoDirect + (1._dp - Fdirect)*groundAlbedoDiffuse + if(scalarGroundAlbedo < 0._dp .or. scalarGroundAlbedo > 1._dp)then print*, 'groundAlbedoDirect = ', groundAlbedoDirect print*, 'groundAlbedoDiffuse = ', groundAlbedoDiffuse message=trim(message)//'NL_scatter: albedo is less than zero or greater than one' @@ -619,13 +619,13 @@ subroutine canopy_SW(& end if ! compute initial transmission in the absence of scattering and multiple reflections (-) - tauInitial = Fdirect*tauFinite + (1._rk - Fdirect)*taudFinite + tauInitial = Fdirect*tauFinite + (1._dp - Fdirect)*taudFinite ! compute increase in transmission due to scattering (-) tauTotal = (tauInitial**multScatExp) ! compute multiple reflections factor - refMult = 1._rk / (1._rk - scalarGroundAlbedo*bulkCanopyAlbedo*(1._rk - taudFinite**multScatExp) ) + refMult = 1._dp / (1._dp - scalarGroundAlbedo*bulkCanopyAlbedo*(1._dp - taudFinite**multScatExp) ) ! compute below-canopy radiation (W m-2) spectralBelowCanopyDirect(iBand) = spectralIncomingDirect(iBand)*tauTotal*refMult ! direct radiation from current wave band @@ -633,13 +633,13 @@ subroutine canopy_SW(& spectralBelowCanopySolar(iBand) = spectralBelowCanopyDirect(iBand) + spectralBelowCanopyDiffuse(iBand) ! compute radiation absorbed by the ground in given wave band (W m-2) - spectralGroundAbsorbedDirect(iBand) = (1._rk - scalarGroundAlbedo)*spectralBelowCanopyDirect(iBand) - spectralGroundAbsorbedDiffuse(iBand) = (1._rk - scalarGroundAlbedo)*spectralBelowCanopyDiffuse(iBand) + spectralGroundAbsorbedDirect(iBand) = (1._dp - scalarGroundAlbedo)*spectralBelowCanopyDirect(iBand) + spectralGroundAbsorbedDiffuse(iBand) = (1._dp - scalarGroundAlbedo)*spectralBelowCanopyDiffuse(iBand) spectralGroundAbsorbedSolar(iBand) = spectralGroundAbsorbedDirect(iBand) + spectralGroundAbsorbedDiffuse(iBand) ! compute radiation absorbed by vegetation in current wave band (W m-2) - fracRadAbsDown = (1._rk - tauTotal)*(1._rk - bulkCanopyAlbedo) ! (fraction of radiation absorbed on the way down) - fracRadAbsUp = tauTotal*refMult*scalarGroundAlbedo*(1._rk - taudFinite**multScatExp) ! (fraction of radiation absorbed on the way up) + fracRadAbsDown = (1._dp - tauTotal)*(1._dp - bulkCanopyAlbedo) ! (fraction of radiation absorbed on the way down) + fracRadAbsUp = tauTotal*refMult*scalarGroundAlbedo*(1._dp - taudFinite**multScatExp) ! (fraction of radiation absorbed on the way up) spectralCanopyAbsorbedDirect(iBand) = spectralIncomingDirect(iBand)*(fracRadAbsDown + fracRadAbsUp) spectralCanopyAbsorbedDiffuse(iBand) = spectralIncomingDiffuse(iBand)*(fracRadAbsDown + fracRadAbsUp) spectralCanopyAbsorbedSolar(iBand) = spectralCanopyAbsorbedDirect(iBand) + spectralCanopyAbsorbedDiffuse(iBand) @@ -648,7 +648,7 @@ subroutine canopy_SW(& spectralTotalReflectedDirect(iBand) = spectralIncomingDirect(iBand) - spectralGroundAbsorbedDirect(iBand) - spectralCanopyAbsorbedDirect(iBand) spectralTotalReflectedDiffuse(iBand) = spectralIncomingDiffuse(iBand) - spectralGroundAbsorbedDiffuse(iBand) - spectralCanopyAbsorbedDiffuse(iBand) spectralTotalReflectedSolar(iBand) = spectralTotalReflectedDirect(iBand) + spectralTotalReflectedDiffuse(iBand) - if(spectralTotalReflectedDirect(iBand) < 0._rk .or. spectralTotalReflectedDiffuse(iBand) < 0._rk)then + if(spectralTotalReflectedDirect(iBand) < 0._dp .or. spectralTotalReflectedDiffuse(iBand) < 0._dp)then message=trim(message)//'NL-scatter: reflected radiation is less than zero' err=20; return end if @@ -677,43 +677,43 @@ subroutine canopy_SW(& transCoef = scalarGproj/scalarCosZenith ! define "k-prime" coefficient (-) - transCoefPrime = sqrt(1._rk - bScatParam) + transCoefPrime = sqrt(1._dp - bScatParam) ! compute ground albedo (-) - groundAlbedoDirect = Frad_vis*spectralAlbGndDirect(ixVisible) + (1._rk - Frad_vis)*spectralAlbGndDirect(ixNearIR) - groundAlbedoDiffuse = Frad_vis*spectralAlbGndDiffuse(ixVisible) + (1._rk - Frad_vis)*spectralAlbGndDiffuse(ixNearIR) + groundAlbedoDirect = Frad_vis*spectralAlbGndDirect(ixVisible) + (1._dp - Frad_vis)*spectralAlbGndDirect(ixNearIR) + groundAlbedoDiffuse = Frad_vis*spectralAlbGndDiffuse(ixVisible) + (1._dp - Frad_vis)*spectralAlbGndDiffuse(ixNearIR) ! compute transmission for an infinite canopy (-) tauInfinite = exp(-transCoef*transCoefPrime*scalarExposedVAI) ! compute upward reflection factor for an infinite canopy (-) - betaInfinite = (1._rk - transCoefPrime)/(1._rk + transCoefPrime) + betaInfinite = (1._dp - transCoefPrime)/(1._dp + transCoefPrime) ! compute transmission for a finite canopy (-) - tauFinite = tauInfinite*(1._rk - betaInfinite**2._rk)/(1._rk - (betaInfinite**2._rk)*tauInfinite**2._rk) + tauFinite = tauInfinite*(1._dp - betaInfinite**2._dp)/(1._dp - (betaInfinite**2._dp)*tauInfinite**2._dp) ! compute reflectance for a finite canopy (-) - betaFinite = betaInfinite*(1._rk - tauInfinite**2._rk) / (1._rk - (betaInfinite**2._rk)*(tauInfinite**2._rk)) + betaFinite = betaInfinite*(1._dp - tauInfinite**2._dp) / (1._dp - (betaInfinite**2._dp)*(tauInfinite**2._dp)) ! compute transmission of diffuse radiation (-) vFactor = transCoefPrime*scalarGproj*scalarExposedVAI expi = expInt(vFactor) - taudInfinite = (1._rk - vFactor)*exp(-vFactor) + (vFactor**2._rk)*expi - taudFinite = taudInfinite*(1._rk - betaInfinite**2._rk)/(1._rk - (betaInfinite**2._rk)*taudInfinite**2._rk) + taudInfinite = (1._dp - vFactor)*exp(-vFactor) + (vFactor**2._dp)*expi + taudFinite = taudInfinite*(1._dp - betaInfinite**2._dp)/(1._dp - (betaInfinite**2._dp)*taudInfinite**2._dp) ! compute reflectance of diffuse radiation (-) - betadFinite = betaInfinite*(1._rk - taudInfinite**2._rk) / (1._rk - (betaInfinite**2._rk)*(taudInfinite**2._rk)) + betadFinite = betaInfinite*(1._dp - taudInfinite**2._dp) / (1._dp - (betaInfinite**2._dp)*(taudInfinite**2._dp)) ! compute total transmission of direct and diffuse radiation, accounting for multiple reflections (-) - refMult = 1._rk / (1._rk - groundAlbedoDiffuse*betadFinite*(1._rk - taudFinite) ) + refMult = 1._dp / (1._dp - groundAlbedoDiffuse*betadFinite*(1._dp - taudFinite) ) tauDirect = tauFinite*refMult tauDiffuse = taudFinite*refMult ! compute fraction of radiation lost to space (-) - fractionRefDirect = ( (1._rk - groundAlbedoDirect)*betaFinite + groundAlbedoDirect*tauFinite*taudFinite) * refMult - fractionRefDiffuse = ( (1._rk - groundAlbedoDiffuse)*betadFinite + groundAlbedoDiffuse*taudFinite*taudFinite) * refMult + fractionRefDirect = ( (1._dp - groundAlbedoDirect)*betaFinite + groundAlbedoDirect*tauFinite*taudFinite) * refMult + fractionRefDiffuse = ( (1._dp - groundAlbedoDiffuse)*betadFinite + groundAlbedoDiffuse*taudFinite*taudFinite) * refMult ! compute radiation in each spectral band (W m-2) do iBand=1,nBands @@ -724,22 +724,22 @@ subroutine canopy_SW(& spectralBelowCanopySolar(iBand) = spectralBelowCanopyDirect(iBand) + spectralBelowCanopyDiffuse(iBand) ! compute radiation absorbed by the ground in given wave band (W m-2) - spectralGroundAbsorbedDirect(iBand) = (1._rk - groundAlbedoDirect)*spectralBelowCanopyDirect(iBand) - spectralGroundAbsorbedDiffuse(iBand) = (1._rk - groundAlbedoDiffuse)*spectralBelowCanopyDiffuse(iBand) + spectralGroundAbsorbedDirect(iBand) = (1._dp - groundAlbedoDirect)*spectralBelowCanopyDirect(iBand) + spectralGroundAbsorbedDiffuse(iBand) = (1._dp - groundAlbedoDiffuse)*spectralBelowCanopyDiffuse(iBand) spectralGroundAbsorbedSolar(iBand) = spectralGroundAbsorbedDirect(iBand) + spectralGroundAbsorbedDiffuse(iBand) ! compute radiation absorbed by vegetation in current wave band (W m-2) - spectralCanopyAbsorbedDirect(iBand) = spectralIncomingDirect(iBand)*(1._rk - tauFinite)*(1._rk - betaFinite) + & ! (radiation absorbed on the way down) - spectralBelowCanopyDirect(iBand)*groundAlbedoDirect*(1._rk - taudFinite) ! (radiation absorbed on the way up) - spectralCanopyAbsorbedDiffuse(iBand) = spectralIncomingDiffuse(iBand)*(1._rk - taudFinite)*(1._rk - betadFinite) + & ! (radiation absorbed on the way down) - spectralBelowCanopyDiffuse(iBand)*groundAlbedoDiffuse*(1._rk - taudFinite) ! (radiation absorbed on the way up) + spectralCanopyAbsorbedDirect(iBand) = spectralIncomingDirect(iBand)*(1._dp - tauFinite)*(1._dp - betaFinite) + & ! (radiation absorbed on the way down) + spectralBelowCanopyDirect(iBand)*groundAlbedoDirect*(1._dp - taudFinite) ! (radiation absorbed on the way up) + spectralCanopyAbsorbedDiffuse(iBand) = spectralIncomingDiffuse(iBand)*(1._dp - taudFinite)*(1._dp - betadFinite) + & ! (radiation absorbed on the way down) + spectralBelowCanopyDiffuse(iBand)*groundAlbedoDiffuse*(1._dp - taudFinite) ! (radiation absorbed on the way up) spectralCanopyAbsorbedSolar(iBand) = spectralCanopyAbsorbedDirect(iBand) + spectralCanopyAbsorbedDiffuse(iBand) ! compute solar radiation lost to space in given wave band (W m-2) spectralTotalReflectedDirect(iBand) = spectralIncomingDirect(iBand) - spectralGroundAbsorbedDirect(iBand) - spectralCanopyAbsorbedDirect(iBand) spectralTotalReflectedDiffuse(iBand) = spectralIncomingDiffuse(iBand) - spectralGroundAbsorbedDiffuse(iBand) - spectralCanopyAbsorbedDiffuse(iBand) spectralTotalReflectedSolar(iBand) = spectralTotalReflectedDirect(iBand) + spectralTotalReflectedDiffuse(iBand) - if(spectralTotalReflectedDirect(iBand) < 0._rk .or. spectralTotalReflectedDiffuse(iBand) < 0._rk)then + if(spectralTotalReflectedDirect(iBand) < 0._dp .or. spectralTotalReflectedDiffuse(iBand) < 0._dp)then message=trim(message)//'UEB_2stream: reflected radiation is less than zero' err=20; return end if @@ -851,8 +851,8 @@ subroutine canopy_SW(& ! accumulate radiation absorbed by the ground (W m-2) scalarGroundAbsorbedSolar = scalarGroundAbsorbedSolar + & ! contribution from all previous wave bands - spectralBelowCanopyDirect(iBand)*(1._rk - spectralAlbGndDirect(iBand)) + & ! direct radiation from current wave band - spectralBelowCanopyDiffuse(iBand)*(1._rk - spectralAlbGndDiffuse(iBand)) ! diffuse radiation from current wave band + spectralBelowCanopyDirect(iBand)*(1._dp - spectralAlbGndDirect(iBand)) + & ! direct radiation from current wave band + spectralBelowCanopyDiffuse(iBand)*(1._dp - spectralAlbGndDiffuse(iBand)) ! diffuse radiation from current wave band ! save canopy radiation absorbed in visible wavelengths ! NOTE: here flux is per unit incoming flux @@ -876,11 +876,11 @@ subroutine canopy_SW(& ! compute sunlit fraction of canopy (from CLM/Noah-MP) ext = scalarGproj/scalarCosZenith ! optical depth of direct beam per unit leaf + stem area - scalarCanopySunlitFraction = (1._rk - exp(-ext*scalarExposedVAI)) / max(ext*scalarExposedVAI,mpe) - if(scalarCanopySunlitFraction < 0.01_rk) scalarCanopySunlitFraction = 0._rk + scalarCanopySunlitFraction = (1._dp - exp(-ext*scalarExposedVAI)) / max(ext*scalarExposedVAI,mpe) + if(scalarCanopySunlitFraction < 0.01_dp) scalarCanopySunlitFraction = 0._dp ! compute sunlit and shaded LAI - scalarCanopyShadedFraction = 1._rk - scalarCanopySunlitFraction + scalarCanopyShadedFraction = 1._dp - scalarCanopySunlitFraction scalarCanopySunlitLAI = scalarExposedLAI*scalarCanopySunlitFraction scalarCanopyShadedLAI = scalarExposedLAI*scalarCanopyShadedFraction @@ -890,7 +890,7 @@ subroutine canopy_SW(& scalarCanopySunlitPAR = (visibleAbsDirect + scalarCanopySunlitFraction*visibleAbsDiffuse) * fractionLAI / max(scalarCanopySunlitLAI, mpe) scalarCanopyShadedPAR = ( scalarCanopyShadedFraction*visibleAbsDiffuse) * fractionLAI / max(scalarCanopyShadedLAI, mpe) else - scalarCanopySunlitPAR = 0._rk + scalarCanopySunlitPAR = 0._dp scalarCanopyShadedPAR = (visibleAbsDirect + visibleAbsDiffuse) * fractionLAI / max(scalarCanopyShadedLAI, mpe) end if !print*, 'scalarCanopySunlitLAI, fractionLAI, visibleAbsDirect, visibleAbsDiffuse, scalarCanopySunlitPAR = ', & @@ -921,32 +921,32 @@ subroutine gndAlbedo(& ! -------------------------------------------------------------------------------------------------------------------------------------- ! input: model control integer(i4b),intent(in) :: isc ! index of soil color - real(rk),intent(in) :: scalarGroundSnowFraction ! fraction of ground that is snow covered (-) - real(rk),intent(in) :: scalarVolFracLiqUpper ! volumetric liquid water content in upper-most soil layer (-) - real(rk),intent(in) :: spectralSnowAlbedoDirect(:) ! direct albedo of snow in each spectral band (-) - real(rk),intent(in) :: spectralSnowAlbedoDiffuse(:) ! diffuse albedo of snow in each spectral band (-) + real(dp),intent(in) :: scalarGroundSnowFraction ! fraction of ground that is snow covered (-) + real(dp),intent(in) :: scalarVolFracLiqUpper ! volumetric liquid water content in upper-most soil layer (-) + real(dp),intent(in) :: spectralSnowAlbedoDirect(:) ! direct albedo of snow in each spectral band (-) + real(dp),intent(in) :: spectralSnowAlbedoDiffuse(:) ! diffuse albedo of snow in each spectral band (-) ! output - real(rk),intent(out) :: spectralAlbGndDirect(:) ! direct albedo of underlying surface (-) - real(rk),intent(out) :: spectralAlbGndDiffuse(:) ! diffuse albedo of underlying surface (-) + real(dp),intent(out) :: spectralAlbGndDirect(:) ! direct albedo of underlying surface (-) + real(dp),intent(out) :: spectralAlbGndDiffuse(:) ! diffuse albedo of underlying surface (-) integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! local variables integer(i4b) :: iBand ! index of spectral band - real(rk) :: xInc ! soil water correction factor for soil albedo - real(rk),dimension(1:nBands) :: spectralSoilAlbedo ! soil albedo in each spectral band + real(dp) :: xInc ! soil water correction factor for soil albedo + real(dp),dimension(1:nBands) :: spectralSoilAlbedo ! soil albedo in each spectral band ! initialize error control err=0; message='gndAlbedo/' ! compute soil albedo do iBand=1,nBands ! loop through spectral bands - xInc = max(0.11_rk - 0.40_rk*scalarVolFracLiqUpper, 0._rk) + xInc = max(0.11_dp - 0.40_dp*scalarVolFracLiqUpper, 0._dp) spectralSoilAlbedo(iBand) = min(ALBSAT(isc,iBand)+xInc,ALBDRY(isc,iBand)) end do ! (looping through spectral bands) ! compute surface albedo (weighted combination of snow and soil) do iBand=1,nBands - spectralAlbGndDirect(iBand) = (1._rk - scalarGroundSnowFraction)*spectralSoilAlbedo(iBand) + scalarGroundSnowFraction*spectralSnowAlbedoDirect(iBand) - spectralAlbGndDiffuse(iBand) = (1._rk - scalarGroundSnowFraction)*spectralSoilAlbedo(iBand) + scalarGroundSnowFraction*spectralSnowAlbedoDiffuse(iBand) + spectralAlbGndDirect(iBand) = (1._dp - scalarGroundSnowFraction)*spectralSoilAlbedo(iBand) + scalarGroundSnowFraction*spectralSnowAlbedoDirect(iBand) + spectralAlbGndDiffuse(iBand) = (1._dp - scalarGroundSnowFraction)*spectralSoilAlbedo(iBand) + scalarGroundSnowFraction*spectralSnowAlbedoDiffuse(iBand) end do ! (looping through spectral bands) end subroutine gndAlbedo diff --git a/build/source/engine/volicePack.f90 b/build/source/engine/volicePack.f90 index a3b5d49d8..8267f4770 100755 --- a/build/source/engine/volicePack.f90 +++ b/build/source/engine/volicePack.f90 @@ -164,37 +164,37 @@ subroutine newsnwfall(& ! add new snowfall to the system implicit none ! input: model control - real(rk),intent(in) :: dt ! time step (seconds) + real(dp),intent(in) :: dt ! time step (seconds) logical(lgt),intent(in) :: snowLayers ! logical flag if snow layers exist - real(rk),intent(in) :: fc_param ! freeezing curve parameter for snow (K-1) + real(dp),intent(in) :: fc_param ! freeezing curve parameter for snow (K-1) ! input: diagnostic scalar variables - real(rk),intent(in) :: scalarSnowfallTemp ! computed temperature of fresh snow (K) - real(rk),intent(in) :: scalarNewSnowDensity ! computed density of new snow (kg m-3) - real(rk),intent(in) :: scalarThroughfallSnow ! throughfall of snow through the canopy (kg m-2 s-1) - real(rk),intent(in) :: scalarCanopySnowUnloading ! unloading of snow from the canopy (kg m-2 s-1) + real(dp),intent(in) :: scalarSnowfallTemp ! computed temperature of fresh snow (K) + real(dp),intent(in) :: scalarNewSnowDensity ! computed density of new snow (kg m-3) + real(dp),intent(in) :: scalarThroughfallSnow ! throughfall of snow through the canopy (kg m-2 s-1) + real(dp),intent(in) :: scalarCanopySnowUnloading ! unloading of snow from the canopy (kg m-2 s-1) ! input/output: state variables - real(rk),intent(inout) :: scalarSWE ! SWE (kg m-2) - real(rk),intent(inout) :: scalarSnowDepth ! total snow depth (m) - real(rk),intent(inout) :: surfaceLayerTemp ! temperature of each layer (K) - real(rk),intent(inout) :: surfaceLayerDepth ! depth of each layer (m) - real(rk),intent(inout) :: surfaceLayerVolFracIce ! volumetric fraction of ice in each layer (-) - real(rk),intent(inout) :: surfaceLayerVolFracLiq ! volumetric fraction of liquid water in each layer (-) + real(dp),intent(inout) :: scalarSWE ! SWE (kg m-2) + real(dp),intent(inout) :: scalarSnowDepth ! total snow depth (m) + real(dp),intent(inout) :: surfaceLayerTemp ! temperature of each layer (K) + real(dp),intent(inout) :: surfaceLayerDepth ! depth of each layer (m) + real(dp),intent(inout) :: surfaceLayerVolFracIce ! volumetric fraction of ice in each layer (-) + real(dp),intent(inout) :: surfaceLayerVolFracLiq ! volumetric fraction of liquid water in each layer (-) ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! define local variables - real(rk) :: newSnowfall ! new snowfall -- throughfall and unloading (kg m-2 s-1) - real(rk) :: newSnowDepth ! new snow depth (m) - real(rk),parameter :: densityCanopySnow=200._rk ! density of snow on the vegetation canopy (kg m-3) - real(rk) :: totalMassIceSurfLayer ! total mass of ice in the surface layer (kg m-2) - real(rk) :: totalDepthSurfLayer ! total depth of the surface layer (m) - real(rk) :: volFracWater ! volumetric fraction of total water, liquid and ice (-) - real(rk) :: fracLiq ! fraction of liquid water (-) - real(rk) :: SWE ! snow water equivalent after snowfall (kg m-2) - real(rk) :: tempSWE0 ! temporary SWE before snowfall, used to check mass balance (kg m-2) - real(rk) :: tempSWE1 ! temporary SWE after snowfall, used to check mass balance (kg m-2) - real(rk) :: xMassBalance ! mass balance check (kg m-2) - real(rk),parameter :: verySmall=1.e-8_rk ! a very small number -- used to check mass balance + real(dp) :: newSnowfall ! new snowfall -- throughfall and unloading (kg m-2 s-1) + real(dp) :: newSnowDepth ! new snow depth (m) + real(dp),parameter :: densityCanopySnow=200._dp ! density of snow on the vegetation canopy (kg m-3) + real(dp) :: totalMassIceSurfLayer ! total mass of ice in the surface layer (kg m-2) + real(dp) :: totalDepthSurfLayer ! total depth of the surface layer (m) + real(dp) :: volFracWater ! volumetric fraction of total water, liquid and ice (-) + real(dp) :: fracLiq ! fraction of liquid water (-) + real(dp) :: SWE ! snow water equivalent after snowfall (kg m-2) + real(dp) :: tempSWE0 ! temporary SWE before snowfall, used to check mass balance (kg m-2) + real(dp) :: tempSWE1 ! temporary SWE after snowfall, used to check mass balance (kg m-2) + real(dp) :: xMassBalance ! mass balance check (kg m-2) + real(dp),parameter :: verySmall=1.e-8_dp ! a very small number -- used to check mass balance ! initialize error control err=0; message="newsnwfall/" @@ -233,7 +233,7 @@ subroutine newsnwfall(& ! compute new volumetric fraction of liquid water and ice (-) volFracWater = (SWE/totalDepthSurfLayer)/iden_water fracLiq = fracliquid(surfaceLayerTemp,fc_param) ! fraction of liquid water - surfaceLayerVolFracIce = (1._rk - fracLiq)*volFracWater*(iden_water/iden_ice) ! volumetric fraction of ice (-) + surfaceLayerVolFracIce = (1._dp - fracLiq)*volFracWater*(iden_water/iden_ice) ! volumetric fraction of ice (-) surfaceLayerVolFracLiq = fracLiq *volFracWater ! volumetric fraction of liquid water (-) ! update new layer depth (m) surfaceLayerDepth = totalDepthSurfLayer diff --git a/build/source/netcdf/modelwrite.f90 b/build/source/netcdf/modelwrite.f90 index 5089f52b0..ee27a52af 100755 --- a/build/source/netcdf/modelwrite.f90 +++ b/build/source/netcdf/modelwrite.f90 @@ -176,8 +176,8 @@ subroutine writeData(finalizeStats,outputTimestep,nHRUrun,maxLayers,meta,stat,da ! output arrays integer(i4b) :: datLength ! length of each data vector integer(i4b) :: maxLength ! maximum length of each data vector - real(rk) :: realVec(nHRUrun) ! real vector for all HRUs in the run domain - real(rk) :: realArray(nHRUrun,maxLayers+1) ! real array for all HRUs in the run domain + real(dp) :: realVec(nHRUrun) ! real vector for all HRUs in the run domain + real(dp) :: realArray(nHRUrun,maxLayers+1) ! real array for all HRUs in the run domain integer(i4b) :: intArray(nHRUrun,maxLayers+1) ! integer array for all HRUs in the run domain integer(i4b) :: dataType ! type of data integer(i4b),parameter :: ixInteger=1001 ! named variable for integer diff --git a/build/source/netcdf/read_icond.f90 b/build/source/netcdf/read_icond.f90 index 13ba5a288..c5bdd929e 100644 --- a/build/source/netcdf/read_icond.f90 +++ b/build/source/netcdf/read_icond.f90 @@ -201,7 +201,7 @@ subroutine read_icond(iconFile, & ! intent(in): name of integer(i4b) :: ixFile ! index in file integer(i4b) :: iHRU_local ! index of HRU in the data subset integer(i4b) :: iHRU_global ! index of HRU in the netcdf file - real(rk),allocatable :: varData(:,:) ! variable data storage + real(dp),allocatable :: varData(:,:) ! variable data storage integer(i4b) :: nSoil, nSnow, nToto ! # layers integer(i4b) :: nTDH ! number of points in time-delay histogram integer(i4b) :: iLayer,jLayer ! layer indices @@ -319,7 +319,7 @@ subroutine read_icond(iconFile, & ! intent(in): name of if(err==20)then; message=trim(message)//"data set to the fill value (name='"//trim(prog_meta(iVar)%varName)//"')"; return; endif ! fix the snow albedo - if(progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%scalarSnowAlbedo)%dat(1) < 0._rk)then + if(progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%scalarSnowAlbedo)%dat(1) < 0._dp)then progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%scalarSnowAlbedo)%dat(1) = mparData%gru(iGRU)%hru(iHRU)%var(iLookPARAM%albedoMax)%dat(1) endif @@ -376,7 +376,7 @@ subroutine read_icond(iconFile, & ! intent(in): name of mparData%gru(iGRU)%hru(iHRU)%var(iLookPARAM%vGn_n )%dat(iLayer),& ! intent(in): van Genutchen "n" parameter mparData%gru(iGRU)%hru(iHRU)%var(iLookPARAM%theta_sat )%dat(iLayer),& ! intent(in): soil porosity (-) mparData%gru(iGRU)%hru(iHRU)%var(iLookPARAM%theta_res )%dat(iLayer),& ! intent(in): soil residual volumetric water content (-) - 1._rk - 1._rk/mparData%gru(iGRU)%hru(iHRU)%var(iLookPARAM%vGn_n)%dat(iLayer),& ! intent(in): van Genutchen "m" parameter (-) + 1._dp - 1._dp/mparData%gru(iGRU)%hru(iHRU)%var(iLookPARAM%vGn_n)%dat(iLayer),& ! intent(in): van Genutchen "m" parameter (-) ! output progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%mLayerVolFracWat )%dat(jLayer),& ! intent(out): volumetric fraction of total water (-) progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%mLayerVolFracLiq )%dat(jLayer),& ! intent(out): volumetric fraction of liquid water (-) diff --git a/build/source/noah-mp/module_model_constants.F b/build/source/noah-mp/module_model_constants.F index a982c7ca7..9539d4482 100755 --- a/build/source/noah-mp/module_model_constants.F +++ b/build/source/noah-mp/module_model_constants.F @@ -2,139 +2,138 @@ ! MODULE module_model_constants - USE nrtype ! 2. Following are constants for use in defining real number bounds. ! A really small number. - REAL(rk) , PARAMETER :: epsilon = 1.E-15 + REAL , PARAMETER :: epsilon = 1.E-15 ! 4. Following is information related to the physical constants. ! These are the physical constants used within the model. ! JM NOTE -- can we name this grav instead? - REAL(rk) , PARAMETER :: g = 9.81 ! acceleration due to gravity (m {s}^-2) + REAL , PARAMETER :: g = 9.81 ! acceleration due to gravity (m {s}^-2) #if ( NMM_CORE == 1 ) - REAL(rk) , PARAMETER :: r_d = 287.04 - REAL(rk) , PARAMETER :: cp = 1004.6 + REAL , PARAMETER :: r_d = 287.04 + REAL , PARAMETER :: cp = 1004.6 #else - REAL(rk) , PARAMETER :: r_d = 287. - REAL(rk) , PARAMETER :: cp = 7.*r_d/2. + REAL , PARAMETER :: r_d = 287. + REAL , PARAMETER :: cp = 7.*r_d/2. #endif - REAL(rk) , PARAMETER :: r_v = 461.6 - REAL(rk) , PARAMETER :: cv = cp-r_d - REAL(rk) , PARAMETER :: cpv = 4.*r_v - REAL(rk) , PARAMETER :: cvv = cpv-r_v - REAL(rk) , PARAMETER :: cvpm = -cv/cp - REAL(rk) , PARAMETER :: cliq = 4190. - REAL(rk) , PARAMETER :: cice = 2106. - REAL(rk) , PARAMETER :: psat = 610.78 - REAL(rk) , PARAMETER :: rcv = r_d/cv - REAL(rk) , PARAMETER :: rcp = r_d/cp - REAL(rk) , PARAMETER :: rovg = r_d/g - REAL(rk) , PARAMETER :: c2 = cp * rcv + REAL , PARAMETER :: r_v = 461.6 + REAL , PARAMETER :: cv = cp-r_d + REAL , PARAMETER :: cpv = 4.*r_v + REAL , PARAMETER :: cvv = cpv-r_v + REAL , PARAMETER :: cvpm = -cv/cp + REAL , PARAMETER :: cliq = 4190. + REAL , PARAMETER :: cice = 2106. + REAL , PARAMETER :: psat = 610.78 + REAL , PARAMETER :: rcv = r_d/cv + REAL , PARAMETER :: rcp = r_d/cp + REAL , PARAMETER :: rovg = r_d/g + REAL , PARAMETER :: c2 = cp * rcv real , parameter :: mwdry = 28.966 ! molecular weight of dry air (g/mole) - REAL(rk) , PARAMETER :: p1000mb = 100000. - REAL(rk) , PARAMETER :: t0 = 300. - REAL(rk) , PARAMETER :: p0 = p1000mb - REAL(rk) , PARAMETER :: cpovcv = cp/(cp-r_d) - REAL(rk) , PARAMETER :: cvovcp = 1./cpovcv - REAL(rk) , PARAMETER :: rvovrd = r_v/r_d + REAL , PARAMETER :: p1000mb = 100000. + REAL , PARAMETER :: t0 = 300. + REAL , PARAMETER :: p0 = p1000mb + REAL , PARAMETER :: cpovcv = cp/(cp-r_d) + REAL , PARAMETER :: cvovcp = 1./cpovcv + REAL , PARAMETER :: rvovrd = r_v/r_d - REAL(rk) , PARAMETER :: reradius = 1./6370.0e03 + REAL , PARAMETER :: reradius = 1./6370.0e03 - REAL(rk) , PARAMETER :: asselin = .025 -! REAL(rk) , PARAMETER :: asselin = .0 - REAL(rk) , PARAMETER :: cb = 25. + REAL , PARAMETER :: asselin = .025 +! REAL , PARAMETER :: asselin = .0 + REAL , PARAMETER :: cb = 25. - REAL(rk) , PARAMETER :: XLV0 = 3.15E6 - REAL(rk) , PARAMETER :: XLV1 = 2370. - REAL(rk) , PARAMETER :: XLS0 = 2.905E6 - REAL(rk) , PARAMETER :: XLS1 = 259.532 + REAL , PARAMETER :: XLV0 = 3.15E6 + REAL , PARAMETER :: XLV1 = 2370. + REAL , PARAMETER :: XLS0 = 2.905E6 + REAL , PARAMETER :: XLS1 = 259.532 - REAL(rk) , PARAMETER :: XLS = 2.85E6 - REAL(rk) , PARAMETER :: XLV = 2.5E6 - REAL(rk) , PARAMETER :: XLF = 3.50E5 + REAL , PARAMETER :: XLS = 2.85E6 + REAL , PARAMETER :: XLV = 2.5E6 + REAL , PARAMETER :: XLF = 3.50E5 - REAL(rk) , PARAMETER :: rhowater = 1000. - REAL(rk) , PARAMETER :: rhosnow = 100. - REAL(rk) , PARAMETER :: rhoair0 = 1.28 + REAL , PARAMETER :: rhowater = 1000. + REAL , PARAMETER :: rhosnow = 100. + REAL , PARAMETER :: rhoair0 = 1.28 ! - REAL(rk) , PARAMETER :: n_ccn0 = 1.0E8 + REAL , PARAMETER :: n_ccn0 = 1.0E8 ! - REAL(rk) , PARAMETER :: DEGRAD = 3.1415926/180. - REAL(rk) , PARAMETER :: DPD = 360./365. - - REAL(rk) , PARAMETER :: SVP1=0.6112 - REAL(rk) , PARAMETER :: SVP2=17.67 - REAL(rk) , PARAMETER :: SVP3=29.65 - REAL(rk) , PARAMETER :: SVPT0=273.15 - REAL(rk) , PARAMETER :: EP_1=R_v/R_d-1. - REAL(rk) , PARAMETER :: EP_2=R_d/R_v - REAL(rk) , PARAMETER :: KARMAN=0.4 - REAL(rk) , PARAMETER :: EOMEG=7.2921E-5 - REAL(rk) , PARAMETER :: STBOLT=5.67051E-8 - - REAL(rk) , PARAMETER :: prandtl = 1./3.0 + REAL , PARAMETER :: DEGRAD = 3.1415926/180. + REAL , PARAMETER :: DPD = 360./365. + + REAL , PARAMETER :: SVP1=0.6112 + REAL , PARAMETER :: SVP2=17.67 + REAL , PARAMETER :: SVP3=29.65 + REAL , PARAMETER :: SVPT0=273.15 + REAL , PARAMETER :: EP_1=R_v/R_d-1. + REAL , PARAMETER :: EP_2=R_d/R_v + REAL , PARAMETER :: KARMAN=0.4 + REAL , PARAMETER :: EOMEG=7.2921E-5 + REAL , PARAMETER :: STBOLT=5.67051E-8 + + REAL , PARAMETER :: prandtl = 1./3.0 ! constants for w-damping option - REAL(rk) , PARAMETER :: w_alpha = 0.3 ! strength m/s/s - REAL(rk) , PARAMETER :: w_beta = 1.0 ! activation cfl number - - REAL(rk) , PARAMETER :: pq0=379.90516 - REAL(rk) , PARAMETER :: epsq2=0.2 - REAL(rk) , PARAMETER :: a2=17.2693882 - REAL(rk) , PARAMETER :: a3=273.16 - REAL(rk) , PARAMETER :: a4=35.86 - REAL(rk) , PARAMETER :: epsq=1.e-12 - REAL(rk) , PARAMETER :: p608=rvovrd-1. + REAL , PARAMETER :: w_alpha = 0.3 ! strength m/s/s + REAL , PARAMETER :: w_beta = 1.0 ! activation cfl number + + REAL , PARAMETER :: pq0=379.90516 + REAL , PARAMETER :: epsq2=0.2 + REAL , PARAMETER :: a2=17.2693882 + REAL , PARAMETER :: a3=273.16 + REAL , PARAMETER :: a4=35.86 + REAL , PARAMETER :: epsq=1.e-12 + REAL , PARAMETER :: p608=rvovrd-1. !#if ( NMM_CORE == 1 ) - REAL(rk) , PARAMETER :: climit=1.e-20 - REAL(rk) , PARAMETER :: cm1=2937.4 - REAL(rk) , PARAMETER :: cm2=4.9283 - REAL(rk) , PARAMETER :: cm3=23.5518 -! REAL(rk) , PARAMETER :: defc=8.0 -! REAL(rk) , PARAMETER :: defm=32.0 - REAL(rk) , PARAMETER :: defc=0.0 - REAL(rk) , PARAMETER :: defm=99999.0 - REAL(rk) , PARAMETER :: epsfc=1./1.05 - REAL(rk) , PARAMETER :: epswet=0.0 - REAL(rk) , PARAMETER :: fcdif=1./3. + REAL , PARAMETER :: climit=1.e-20 + REAL , PARAMETER :: cm1=2937.4 + REAL , PARAMETER :: cm2=4.9283 + REAL , PARAMETER :: cm3=23.5518 +! REAL , PARAMETER :: defc=8.0 +! REAL , PARAMETER :: defm=32.0 + REAL , PARAMETER :: defc=0.0 + REAL , PARAMETER :: defm=99999.0 + REAL , PARAMETER :: epsfc=1./1.05 + REAL , PARAMETER :: epswet=0.0 + REAL , PARAMETER :: fcdif=1./3. #ifdef HWRF - REAL(rk) , PARAMETER :: fcm=0.0 + REAL , PARAMETER :: fcm=0.0 #else - REAL(rk) , PARAMETER :: fcm=0.00003 + REAL , PARAMETER :: fcm=0.00003 #endif - REAL(rk) , PARAMETER :: gma=-r_d*(1.-rcp)*0.5 - REAL(rk) , PARAMETER :: p400=40000.0 - REAL(rk) , PARAMETER :: phitp=15000.0 - REAL(rk) , PARAMETER :: pi2=2.*3.1415926 - REAL(rk) , PARAMETER :: plbtm=105000.0 - REAL(rk) , PARAMETER :: plomd=64200.0 - REAL(rk) , PARAMETER :: pmdhi=35000.0 - REAL(rk) , PARAMETER :: q2ini=0.50 - REAL(rk) , PARAMETER :: rfcp=0.25/cp - REAL(rk) , PARAMETER :: rhcrit_land=0.75 - REAL(rk) , PARAMETER :: rhcrit_sea=0.80 - REAL(rk) , PARAMETER :: rlag=14.8125 - REAL(rk) , PARAMETER :: rlx=0.90 - REAL(rk) , PARAMETER :: scq2=50.0 - REAL(rk) , PARAMETER :: slopht=0.001 - REAL(rk) , PARAMETER :: tlc=2.*0.703972477 - REAL(rk) , PARAMETER :: wa=0.15 - REAL(rk) , PARAMETER :: wght=0.35 - REAL(rk) , PARAMETER :: wpc=0.075 - REAL(rk) , PARAMETER :: z0land=0.10 + REAL , PARAMETER :: gma=-r_d*(1.-rcp)*0.5 + REAL , PARAMETER :: p400=40000.0 + REAL , PARAMETER :: phitp=15000.0 + REAL , PARAMETER :: pi2=2.*3.1415926 + REAL , PARAMETER :: plbtm=105000.0 + REAL , PARAMETER :: plomd=64200.0 + REAL , PARAMETER :: pmdhi=35000.0 + REAL , PARAMETER :: q2ini=0.50 + REAL , PARAMETER :: rfcp=0.25/cp + REAL , PARAMETER :: rhcrit_land=0.75 + REAL , PARAMETER :: rhcrit_sea=0.80 + REAL , PARAMETER :: rlag=14.8125 + REAL , PARAMETER :: rlx=0.90 + REAL , PARAMETER :: scq2=50.0 + REAL , PARAMETER :: slopht=0.001 + REAL , PARAMETER :: tlc=2.*0.703972477 + REAL , PARAMETER :: wa=0.15 + REAL , PARAMETER :: wght=0.35 + REAL , PARAMETER :: wpc=0.075 + REAL , PARAMETER :: z0land=0.10 #ifdef HWRF - REAL(rk) , PARAMETER :: z0max=0.01 + REAL , PARAMETER :: z0max=0.01 #else - REAL(rk) , PARAMETER :: z0max=0.008 + REAL , PARAMETER :: z0max=0.008 #endif - REAL(rk) , PARAMETER :: z0sea=0.001 + REAL , PARAMETER :: z0sea=0.001 !#endif @@ -142,19 +141,19 @@ MODULE module_model_constants ! The value for P2SI *must* be set to 1.0 for Earth ! Although, now we may not need this declaration here (see above) - !REAL(rk) , PARAMETER :: P2SI = 1.0 + !REAL , PARAMETER :: P2SI = 1.0 ! Orbital constants: INTEGER , PARAMETER :: PLANET_YEAR = 365 - REAL(rk) , PARAMETER :: OBLIQUITY = 23.5 - REAL(rk) , PARAMETER :: ECCENTRICITY = 0.014 - REAL(rk) , PARAMETER :: SEMIMAJORAXIS = 1.0 ! In AU + REAL , PARAMETER :: OBLIQUITY = 23.5 + REAL , PARAMETER :: ECCENTRICITY = 0.014 + REAL , PARAMETER :: SEMIMAJORAXIS = 1.0 ! In AU ! Don't know the following values, so we'll fake them for now - REAL(rk) , PARAMETER :: zero_date = 0.0 ! Time of perihelion passage + REAL , PARAMETER :: zero_date = 0.0 ! Time of perihelion passage ! Fraction into the year (from perhelion) of the ! occurrence of the Northern Spring Equinox - REAL(rk) , PARAMETER :: EQUINOX_FRACTION= 0.0 + REAL , PARAMETER :: EQUINOX_FRACTION= 0.0 CONTAINS SUBROUTINE init_module_model_constants diff --git a/build/source/noah-mp/module_sf_noahlsm.F b/build/source/noah-mp/module_sf_noahlsm.F index 9434678ea..6d38415c0 100755 --- a/build/source/noah-mp/module_sf_noahlsm.F +++ b/build/source/noah-mp/module_sf_noahlsm.F @@ -1,9 +1,8 @@ MODULE module_sf_noahlsm - USE nrtype USE module_model_constants -! REAL(rk), PARAMETER :: CP = 1004.5 - REAL(rk), PARAMETER :: RD = 287.04, SIGMA = 5.67E-8, & +! REAL, PARAMETER :: CP = 1004.5 + REAL, PARAMETER :: RD = 287.04, SIGMA = 5.67E-8, & CPH2O = 4.218E+3,CPICE = 2.106E+3, & LSUBF = 3.335E+5, & EMISSI_S = 0.95 @@ -20,26 +19,26 @@ MODULE module_sf_noahlsm LAIMINTBL, LAIMAXTBL, & Z0MINTBL, Z0MAXTBL, & ALBEDOMINTBL, ALBEDOMAXTBL - REAL(rk) :: TOPT_DATA,CMCMAX_DATA,CFACTR_DATA,RSMAX_DATA + REAL :: TOPT_DATA,CMCMAX_DATA,CFACTR_DATA,RSMAX_DATA ! SOIL PARAMETERS INTEGER :: SLCATS INTEGER, PARAMETER :: NSLTYPE=30 CHARACTER(LEN=256) SLTYPE - REAL(rk), DIMENSION (1:NSLTYPE) :: BB,DRYSMC,F11, & + REAL, DIMENSION (1:NSLTYPE) :: BB,DRYSMC,F11, & MAXSMC, REFSMC,SATPSI,SATDK,SATDW, WLTSMC,QTZ ! MPC add van Genutchen parameters - REAL(rk), DIMENSION (1:NSLTYPE) :: theta_res, theta_sat, & + REAL, DIMENSION (1:NSLTYPE) :: theta_res, theta_sat, & vGn_alpha, vGn_n, k_soil ! LSM GENERAL PARAMETERS INTEGER :: SLPCATS INTEGER, PARAMETER :: NSLOPE=30 - REAL(rk), DIMENSION (1:NSLOPE) :: SLOPE_DATA - REAL(rk) :: SBETA_DATA,FXEXP_DATA,CSOIL_DATA,SALP_DATA,REFDK_DATA, & + REAL, DIMENSION (1:NSLOPE) :: SLOPE_DATA + REAL :: SBETA_DATA,FXEXP_DATA,CSOIL_DATA,SALP_DATA,REFDK_DATA, & REFKDT_DATA,FRZK_DATA,ZBOT_DATA, SMLOW_DATA,SMHIGH_DATA, & CZIL_DATA - REAL(rk) :: LVCOEF_DATA + REAL :: LVCOEF_DATA CHARACTER*256 :: err_message integer, private :: iloc, jloc diff --git a/build/source/noah-mp/module_sf_noahmplsm.F b/build/source/noah-mp/module_sf_noahmplsm.F index cfd09494a..8ddfedbde 100755 --- a/build/source/noah-mp/module_sf_noahmplsm.F +++ b/build/source/noah-mp/module_sf_noahmplsm.F @@ -1,5 +1,4 @@ module noahmp_globals - USE nrtype ! Maybe most of these can be moved to a REDPRM use statement? ! MPC -- yes, all of these variables can be local to REDPRM (see additional comments) @@ -37,33 +36,33 @@ module noahmp_globals ! Physical Constants: ! !------------------------------------------------------------------------------------------! - REAL(rk), PARAMETER :: GRAV = 9.80616 !acceleration due to gravity (m/s2) - REAL(rk), PARAMETER :: SB = 5.67E-08 !Stefan-Boltzmann constant (w/m2/k4) - REAL(rk), PARAMETER :: VKC = 0.40 !von Karman constant - REAL(rk), PARAMETER :: TFRZ = 273.16 !freezing/melting point (k) - REAL(rk), PARAMETER :: HSUB = 2.8440E06 !latent heat of sublimation (j/kg) - REAL(rk), PARAMETER :: HVAP = 2.5104E06 !latent heat of vaporization (j/kg) - REAL(rk), PARAMETER :: HFUS = 0.3336E06 !latent heat of fusion (j/kg) - REAL(rk), PARAMETER :: CWAT = 4.188E06 !specific heat capacity of water (j/m3/k) - REAL(rk), PARAMETER :: CICE = 2.094E06 !specific heat capacity of ice (j/m3/k) - REAL(rk), PARAMETER :: CPAIR = 1004.64 !heat capacity dry air at const pres (j/kg/k) - REAL(rk), PARAMETER :: TKWAT = 0.6 !thermal conductivity of water (w/m/k) - REAL(rk), PARAMETER :: TKICE = 2.2 !thermal conductivity of ice (w/m/k) - REAL(rk), PARAMETER :: TKAIR = 0.023 !thermal conductivity of air (w/m/k) - REAL(rk), PARAMETER :: RAIR = 287.04 !gas constant for dry air (j/kg/k) - REAL(rk), PARAMETER :: RW = 461.269 !gas constant for water vapor (j/kg/k) - REAL(rk), PARAMETER :: DENH2O = 1000. !density of water (kg/m3) - REAL(rk), PARAMETER :: DENICE = 917. !density of ice (kg/m3) + REAL, PARAMETER :: GRAV = 9.80616 !acceleration due to gravity (m/s2) + REAL, PARAMETER :: SB = 5.67E-08 !Stefan-Boltzmann constant (w/m2/k4) + REAL, PARAMETER :: VKC = 0.40 !von Karman constant + REAL, PARAMETER :: TFRZ = 273.16 !freezing/melting point (k) + REAL, PARAMETER :: HSUB = 2.8440E06 !latent heat of sublimation (j/kg) + REAL, PARAMETER :: HVAP = 2.5104E06 !latent heat of vaporization (j/kg) + REAL, PARAMETER :: HFUS = 0.3336E06 !latent heat of fusion (j/kg) + REAL, PARAMETER :: CWAT = 4.188E06 !specific heat capacity of water (j/m3/k) + REAL, PARAMETER :: CICE = 2.094E06 !specific heat capacity of ice (j/m3/k) + REAL, PARAMETER :: CPAIR = 1004.64 !heat capacity dry air at const pres (j/kg/k) + REAL, PARAMETER :: TKWAT = 0.6 !thermal conductivity of water (w/m/k) + REAL, PARAMETER :: TKICE = 2.2 !thermal conductivity of ice (w/m/k) + REAL, PARAMETER :: TKAIR = 0.023 !thermal conductivity of air (w/m/k) + REAL, PARAMETER :: RAIR = 287.04 !gas constant for dry air (j/kg/k) + REAL, PARAMETER :: RW = 461.269 !gas constant for water vapor (j/kg/k) + REAL, PARAMETER :: DENH2O = 1000. !density of water (kg/m3) + REAL, PARAMETER :: DENICE = 917. !density of ice (kg/m3) !------------------------------------------------------------------------------------------! ! From the VEGPARM.TBL tables, as functions of vegetation category. !------------------------------------------------------------------------------------------! INTEGER :: NROOT !rooting depth [as the number of layers] ( Assigned in REDPRM ) - REAL(rk) :: RGL !parameter used in radiation stress function ( Assigned in REDPRM ) - REAL(rk) :: RSMIN !minimum Canopy Resistance [s/m] ( Assigned in REDPRM ) - REAL(rk) :: HS !parameter used in vapor pressure deficit function ( Assigned in REDPRM ) - REAL(rk) :: RSMAX !maximum stomatal resistance ( Assigned in REDPRM ) - REAL(rk) :: TOPT !optimum transpiration air temperature. + REAL :: RGL !parameter used in radiation stress function ( Assigned in REDPRM ) + REAL :: RSMIN !minimum Canopy Resistance [s/m] ( Assigned in REDPRM ) + REAL :: HS !parameter used in vapor pressure deficit function ( Assigned in REDPRM ) + REAL :: RSMAX !maximum stomatal resistance ( Assigned in REDPRM ) + REAL :: TOPT !optimum transpiration air temperature. ! MPC change: make variables private for a given thread !$omp threadprivate(NROOT, RGL, RSMIN, HS, RSMAX, TOPT) @@ -71,17 +70,17 @@ module noahmp_globals !------------------------------------------------------------------------------------------! ! From the SOILPARM.TBL tables, as functions of soil category. !------------------------------------------------------------------------------------------! - REAL(rk) :: BEXP !B parameter ( Assigned in REDPRM ) - REAL(rk) :: SMCDRY !dry soil moisture threshold where direct evap from top + REAL :: BEXP !B parameter ( Assigned in REDPRM ) + REAL :: SMCDRY !dry soil moisture threshold where direct evap from top !layer ends (volumetric) ( Assigned in REDPRM ) - REAL(rk) :: F1 !soil thermal diffusivity/conductivity coef ( Assigned in REDPRM ) - REAL(rk) :: SMCMAX !porosity, saturated value of soil moisture (volumetric) - REAL(rk) :: SMCREF !reference soil moisture (field capacity) (volumetric) ( Assigned in REDPRM ) - REAL(rk) :: PSISAT !saturated soil matric potential ( Assigned in REDPRM ) - REAL(rk) :: DKSAT !saturated soil hydraulic conductivity ( Assigned in REDPRM ) - REAL(rk) :: DWSAT !saturated soil hydraulic diffusivity ( Assigned in REDPRM ) - REAL(rk) :: SMCWLT !wilting point soil moisture (volumetric) ( Assigned in REDPRM ) - REAL(rk) :: QUARTZ !soil quartz content ( Assigned in REDPRM ) + REAL :: F1 !soil thermal diffusivity/conductivity coef ( Assigned in REDPRM ) + REAL :: SMCMAX !porosity, saturated value of soil moisture (volumetric) + REAL :: SMCREF !reference soil moisture (field capacity) (volumetric) ( Assigned in REDPRM ) + REAL :: PSISAT !saturated soil matric potential ( Assigned in REDPRM ) + REAL :: DKSAT !saturated soil hydraulic conductivity ( Assigned in REDPRM ) + REAL :: DWSAT !saturated soil hydraulic diffusivity ( Assigned in REDPRM ) + REAL :: SMCWLT !wilting point soil moisture (volumetric) ( Assigned in REDPRM ) + REAL :: QUARTZ !soil quartz content ( Assigned in REDPRM ) ! MPC change: make variables private for a given thread !$omp threadprivate(BEXP, SMCDRY, F1, SMCMAX, SMCREF, PSISAT, DKSAT, DWSAT, SMCWLT, QUARTZ) @@ -89,16 +88,16 @@ module noahmp_globals !------------------------------------------------------------------------------------------! ! From the GENPARM.TBL file !------------------------------------------------------------------------------------------! - REAL(rk) :: SLOPE !slope index (0 - 1) ( Assigned in REDPRM ) - REAL(rk) :: CSOIL !vol. soil heat capacity [j/m3/K] ( Assigned in REDPRM ) - REAL(rk) :: ZBOT !Depth (m) of lower boundary soil temperature ( Assigned in REDPRM ) - REAL(rk) :: CZIL !Calculate roughness length of heat ( Assigned in REDPRM ) + REAL :: SLOPE !slope index (0 - 1) ( Assigned in REDPRM ) + REAL :: CSOIL !vol. soil heat capacity [j/m3/K] ( Assigned in REDPRM ) + REAL :: ZBOT !Depth (m) of lower boundary soil temperature ( Assigned in REDPRM ) + REAL :: CZIL !Calculate roughness length of heat ( Assigned in REDPRM ) ! MPC note: FRZK_DATA, REFDK_DATA, and REFKDT_DATA are used in REDPRM to compute KDT and FRZX ! (FRZK, REFDK, and REFKDT are local variables within REDPRM and do not need to be thread private) - REAL(rk) :: KDT !used in compute maximum infiltration rate (in INFIL) ( Assigned in REDPRM ) - REAL(rk) :: FRZX !used in compute maximum infiltration rate (in INFIL) ( Assigned in REDPRM ) + REAL :: KDT !used in compute maximum infiltration rate (in INFIL) ( Assigned in REDPRM ) + REAL :: FRZX !used in compute maximum infiltration rate (in INFIL) ( Assigned in REDPRM ) ! MPC change: make variables private for a given thread !$omp threadprivate(SLOPE, CSOIL, ZBOT, CZIL, KDT, FRZX) @@ -179,15 +178,15 @@ module noahmp_globals INTEGER :: OPT_STC != 1 !(suggested 1) ! ================================================================================================== ! runoff parameters used for SIMTOP and SIMGM: - REAL(rk), PARAMETER :: TIMEAN = 10.5 !gridcell mean topgraphic index (global mean) - REAL(rk), PARAMETER :: FSATMX = 0.38 !maximum surface saturated fraction (global mean) + REAL, PARAMETER :: TIMEAN = 10.5 !gridcell mean topgraphic index (global mean) + REAL, PARAMETER :: FSATMX = 0.38 !maximum surface saturated fraction (global mean) ! adjustable parameters for snow processes - REAL(rk), PARAMETER :: M = 1.0 ! 2.50 !melting factor (-) - REAL(rk), PARAMETER :: Z0SNO = 0.002 !snow surface roughness length (m) (0.002) - REAL(rk), PARAMETER :: SSI = 0.03 !liquid water holding capacity for snowpack (m3/m3) (0.03) - REAL(rk), PARAMETER :: SWEMX = 1.00 !new snow mass to fully cover old snow (mm) + REAL, PARAMETER :: M = 1.0 ! 2.50 !melting factor (-) + REAL, PARAMETER :: Z0SNO = 0.002 !snow surface roughness length (m) (0.002) + REAL, PARAMETER :: SSI = 0.03 !liquid water holding capacity for snowpack (m3/m3) (0.03) + REAL, PARAMETER :: SWEMX = 1.00 !new snow mass to fully cover old snow (mm) !equivalent to 10mm depth (density = 100 kg/m3) ! NOTES: things to add or improve @@ -201,7 +200,7 @@ END MODULE NOAHMP_GLOBALS !------------------------------------------------------------------------------------------! !------------------------------------------------------------------------------------------! MODULE NOAHMP_VEG_PARAMETERS - use nrtype + IMPLICIT NONE INTEGER, PARAMETER :: MAX_VEG_PARAMS = 33 @@ -214,63 +213,63 @@ MODULE NOAHMP_VEG_PARAMETERS INTEGER :: ISSNOW INTEGER :: EBLFOREST - REAL(rk) :: CH2OP(MVT) !maximum intercepted h2o per unit lai+sai (mm) - REAL(rk) :: DLEAF(MVT) !characteristic leaf dimension (m) - REAL(rk) :: Z0MVT(MVT) !momentum roughness length (m) - REAL(rk) :: HVT(MVT) !top of canopy (m) - REAL(rk) :: HVB(MVT) !bottom of canopy (m) - REAL(rk) :: DEN(MVT) !tree density (no. of trunks per m2) - REAL(rk) :: RC(MVT) !tree crown radius (m) - REAL(rk) :: SAIM(MVT,12) !monthly stem area index, one-sided - REAL(rk) :: LAIM(MVT,12) !monthly leaf area index, one-sided - REAL(rk) :: SLA(MVT) !single-side leaf area per Kg [m2/kg] - REAL(rk) :: DILEFC(MVT) !coeficient for leaf stress death [1/s] - REAL(rk) :: DILEFW(MVT) !coeficient for leaf stress death [1/s] - REAL(rk) :: FRAGR(MVT) !fraction of growth respiration !original was 0.3 - REAL(rk) :: LTOVRC(MVT) !leaf turnover [1/s] - - REAL(rk) :: C3PSN(MVT) !photosynthetic pathway: 0. = c4, 1. = c3 - REAL(rk) :: KC25(MVT) !co2 michaelis-menten constant at 25c (pa) - REAL(rk) :: AKC(MVT) !q10 for kc25 - REAL(rk) :: KO25(MVT) !o2 michaelis-menten constant at 25c (pa) - REAL(rk) :: AKO(MVT) !q10 for ko25 - REAL(rk) :: VCMX25(MVT) !maximum rate of carboxylation at 25c (umol co2/m**2/s) - REAL(rk) :: AVCMX(MVT) !q10 for vcmx25 - REAL(rk) :: BP(MVT) !minimum leaf conductance (umol/m**2/s) - REAL(rk) :: MP(MVT) !slope of conductance-to-photosynthesis relationship - REAL(rk) :: QE25(MVT) !quantum efficiency at 25c (umol co2 / umol photon) - REAL(rk) :: AQE(MVT) !q10 for qe25 - REAL(rk) :: RMF25(MVT) !leaf maintenance respiration at 25c (umol co2/m**2/s) - REAL(rk) :: RMS25(MVT) !stem maintenance respiration at 25c (umol co2/kg bio/s) - REAL(rk) :: RMR25(MVT) !root maintenance respiration at 25c (umol co2/kg bio/s) - REAL(rk) :: ARM(MVT) !q10 for maintenance respiration - REAL(rk) :: FOLNMX(MVT) !foliage nitrogen concentration when f(n)=1 (%) - REAL(rk) :: TMIN(MVT) !minimum temperature for photosynthesis (k) - - REAL(rk) :: XL(MVT) !leaf/stem orientation index - REAL(rk) :: RHOL(MVT,MBAND) !leaf reflectance: 1=vis, 2=nir - REAL(rk) :: RHOS(MVT,MBAND) !stem reflectance: 1=vis, 2=nir - REAL(rk) :: TAUL(MVT,MBAND) !leaf transmittance: 1=vis, 2=nir - REAL(rk) :: TAUS(MVT,MBAND) !stem transmittance: 1=vis, 2=nir - - REAL(rk) :: MRP(MVT) !microbial respiration parameter (umol co2 /kg c/ s) - REAL(rk) :: CWPVT(MVT) !empirical canopy wind parameter - - REAL(rk) :: WRRAT(MVT) !wood to non-wood ratio - REAL(rk) :: WDPOOL(MVT) !wood pool (switch 1 or 0) depending on woody or not [-] - REAL(rk) :: TDLEF(MVT) !characteristic T for leaf freezing [K] + REAL :: CH2OP(MVT) !maximum intercepted h2o per unit lai+sai (mm) + REAL :: DLEAF(MVT) !characteristic leaf dimension (m) + REAL :: Z0MVT(MVT) !momentum roughness length (m) + REAL :: HVT(MVT) !top of canopy (m) + REAL :: HVB(MVT) !bottom of canopy (m) + REAL :: DEN(MVT) !tree density (no. of trunks per m2) + REAL :: RC(MVT) !tree crown radius (m) + REAL :: SAIM(MVT,12) !monthly stem area index, one-sided + REAL :: LAIM(MVT,12) !monthly leaf area index, one-sided + REAL :: SLA(MVT) !single-side leaf area per Kg [m2/kg] + REAL :: DILEFC(MVT) !coeficient for leaf stress death [1/s] + REAL :: DILEFW(MVT) !coeficient for leaf stress death [1/s] + REAL :: FRAGR(MVT) !fraction of growth respiration !original was 0.3 + REAL :: LTOVRC(MVT) !leaf turnover [1/s] + + REAL :: C3PSN(MVT) !photosynthetic pathway: 0. = c4, 1. = c3 + REAL :: KC25(MVT) !co2 michaelis-menten constant at 25c (pa) + REAL :: AKC(MVT) !q10 for kc25 + REAL :: KO25(MVT) !o2 michaelis-menten constant at 25c (pa) + REAL :: AKO(MVT) !q10 for ko25 + REAL :: VCMX25(MVT) !maximum rate of carboxylation at 25c (umol co2/m**2/s) + REAL :: AVCMX(MVT) !q10 for vcmx25 + REAL :: BP(MVT) !minimum leaf conductance (umol/m**2/s) + REAL :: MP(MVT) !slope of conductance-to-photosynthesis relationship + REAL :: QE25(MVT) !quantum efficiency at 25c (umol co2 / umol photon) + REAL :: AQE(MVT) !q10 for qe25 + REAL :: RMF25(MVT) !leaf maintenance respiration at 25c (umol co2/m**2/s) + REAL :: RMS25(MVT) !stem maintenance respiration at 25c (umol co2/kg bio/s) + REAL :: RMR25(MVT) !root maintenance respiration at 25c (umol co2/kg bio/s) + REAL :: ARM(MVT) !q10 for maintenance respiration + REAL :: FOLNMX(MVT) !foliage nitrogen concentration when f(n)=1 (%) + REAL :: TMIN(MVT) !minimum temperature for photosynthesis (k) + + REAL :: XL(MVT) !leaf/stem orientation index + REAL :: RHOL(MVT,MBAND) !leaf reflectance: 1=vis, 2=nir + REAL :: RHOS(MVT,MBAND) !stem reflectance: 1=vis, 2=nir + REAL :: TAUL(MVT,MBAND) !leaf transmittance: 1=vis, 2=nir + REAL :: TAUS(MVT,MBAND) !stem transmittance: 1=vis, 2=nir + + REAL :: MRP(MVT) !microbial respiration parameter (umol co2 /kg c/ s) + REAL :: CWPVT(MVT) !empirical canopy wind parameter + + REAL :: WRRAT(MVT) !wood to non-wood ratio + REAL :: WDPOOL(MVT) !wood pool (switch 1 or 0) depending on woody or not [-] + REAL :: TDLEF(MVT) !characteristic T for leaf freezing [K] INTEGER :: IK,IM - REAL(rk) :: TMP10(MVT*MBAND) - REAL(rk) :: TMP11(MVT*MBAND) - REAL(rk) :: TMP12(MVT*MBAND) - REAL(rk) :: TMP13(MVT*MBAND) - REAL(rk) :: TMP14(MVT*12) - REAL(rk) :: TMP15(MVT*12) - REAL(rk) :: TMP16(MVT*5) + REAL :: TMP10(MVT*MBAND) + REAL :: TMP11(MVT*MBAND) + REAL :: TMP12(MVT*MBAND) + REAL :: TMP13(MVT*MBAND) + REAL :: TMP14(MVT*12) + REAL :: TMP15(MVT*12) + REAL :: TMP16(MVT*5) - real(rk) slarea(MVT) - real(rk) eps(MVT,5) + real slarea(MVT) + real eps(MVT,5) CONTAINS subroutine read_mp_veg_parameters(FILENAME_VEGTABLE,DATASET_IDENTIFIER) @@ -280,13 +279,13 @@ subroutine read_mp_veg_parameters(FILENAME_VEGTABLE,DATASET_IDENTIFIER) integer :: ierr ! Temporary arrays used in reshaping namelist arrays - REAL(rk) :: TMP10(MVT*MBAND) - REAL(rk) :: TMP11(MVT*MBAND) - REAL(rk) :: TMP12(MVT*MBAND) - REAL(rk) :: TMP13(MVT*MBAND) - REAL(rk) :: TMP14(MVT*12) - REAL(rk) :: TMP15(MVT*12) - REAL(rk) :: TMP16(MVT*5) + REAL :: TMP10(MVT*MBAND) + REAL :: TMP11(MVT*MBAND) + REAL :: TMP12(MVT*MBAND) + REAL :: TMP13(MVT*MBAND) + REAL :: TMP14(MVT*12) + REAL :: TMP15(MVT*12) + REAL :: TMP16(MVT*5) integer :: NVEG character(len=256) :: VEG_DATASET_DESCRIPTION @@ -440,7 +439,6 @@ END MODULE NOAHMP_VEG_PARAMETERS ! ================================================================================================== ! ================================================================================================== MODULE NOAHMP_RAD_PARAMETERS - use nrtype IMPLICIT NONE @@ -448,14 +446,14 @@ MODULE NOAHMP_RAD_PARAMETERS INTEGER, PARAMETER :: MSC = 9 INTEGER, PARAMETER :: MBAND = 2 - REAL(rk) :: ALBSAT(MSC,MBAND) !saturated soil albedos: 1=vis, 2=nir - REAL(rk) :: ALBDRY(MSC,MBAND) !dry soil albedos: 1=vis, 2=nir - REAL(rk) :: ALBICE(MBAND) !albedo land ice: 1=vis, 2=nir - REAL(rk) :: ALBLAK(MBAND) !albedo frozen lakes: 1=vis, 2=nir - REAL(rk) :: OMEGAS(MBAND) !two-stream parameter omega for snow - REAL(rk) :: BETADS !two-stream parameter betad for snow - REAL(rk) :: BETAIS !two-stream parameter betad for snow - REAL(rk) :: EG(2) !emissivity + REAL :: ALBSAT(MSC,MBAND) !saturated soil albedos: 1=vis, 2=nir + REAL :: ALBDRY(MSC,MBAND) !dry soil albedos: 1=vis, 2=nir + REAL :: ALBICE(MBAND) !albedo land ice: 1=vis, 2=nir + REAL :: ALBLAK(MBAND) !albedo frozen lakes: 1=vis, 2=nir + REAL :: OMEGAS(MBAND) !two-stream parameter omega for snow + REAL :: BETADS !two-stream parameter betad for snow + REAL :: BETAIS !two-stream parameter betad for snow + REAL :: EG(2) !emissivity ! saturated soil albedos: 1=vis, 2=nir DATA(ALBSAT(I,1),I=1,8)/0.15,0.11,0.10,0.09,0.08,0.07,0.06,0.05/ @@ -482,7 +480,6 @@ END MODULE NOAHMP_RAD_PARAMETERS ! ================================================================================================== MODULE NOAHMP_ROUTINES - use nrtype USE NOAHMP_GLOBALS IMPLICIT NONE @@ -518,33 +515,33 @@ SUBROUTINE PHENOLOGY (VEGTYP , ISURBAN, SNOWH , TV , LAT , YEARLEN , JULI ! inputs INTEGER , INTENT(IN ) :: VEGTYP !vegetation type INTEGER , INTENT(IN ) :: ISURBAN!urban category - REAL(rk) , INTENT(IN ) :: SNOWH !snow height [m] - REAL(rk) , INTENT(IN ) :: TV !vegetation temperature (k) - REAL(rk) , INTENT(IN ) :: LAT !latitude (radians) + REAL , INTENT(IN ) :: SNOWH !snow height [m] + REAL , INTENT(IN ) :: TV !vegetation temperature (k) + REAL , INTENT(IN ) :: LAT !latitude (radians) INTEGER , INTENT(IN ) :: YEARLEN!Number of days in the particular year - REAL(rk) , INTENT(IN ) :: JULIAN !Julian day of year (fractional) ( 0 <= JULIAN < YEARLEN ) - real(rk) , INTENT(IN ) :: TROOT !root-zone averaged temperature (k) - REAL(rk) , INTENT(INOUT) :: LAI !LAI, unadjusted for burying by snow - REAL(rk) , INTENT(INOUT) :: SAI !SAI, unadjusted for burying by snow + REAL , INTENT(IN ) :: JULIAN !Julian day of year (fractional) ( 0 <= JULIAN < YEARLEN ) + real , INTENT(IN ) :: TROOT !root-zone averaged temperature (k) + REAL , INTENT(INOUT) :: LAI !LAI, unadjusted for burying by snow + REAL , INTENT(INOUT) :: SAI !SAI, unadjusted for burying by snow ! outputs - REAL(rk) , INTENT(OUT ) :: HTOP !top of canopy layer (m) - REAL(rk) , INTENT(OUT ) :: ELAI !leaf area index, after burying by snow - REAL(rk) , INTENT(OUT ) :: ESAI !stem area index, after burying by snow - REAL(rk) , INTENT(OUT ) :: IGS !growing season index (0=off, 1=on) + REAL , INTENT(OUT ) :: HTOP !top of canopy layer (m) + REAL , INTENT(OUT ) :: ELAI !leaf area index, after burying by snow + REAL , INTENT(OUT ) :: ESAI !stem area index, after burying by snow + REAL , INTENT(OUT ) :: IGS !growing season index (0=off, 1=on) ! locals - REAL(rk) :: DB !thickness of canopy buried by snow (m) - REAL(rk) :: FB !fraction of canopy buried by snow - REAL(rk) :: SNOWHC !critical snow depth at which short vege + REAL :: DB !thickness of canopy buried by snow (m) + REAL :: FB !fraction of canopy buried by snow + REAL :: SNOWHC !critical snow depth at which short vege !is fully covered by snow INTEGER :: K !index INTEGER :: IT1,IT2 !interpolation months - REAL(rk) :: DAY !current day of year ( 0 <= DAY < YEARLEN ) - REAL(rk) :: WT1,WT2 !interpolation weights - REAL(rk) :: T !current month (1.00, ..., 12.00) + REAL :: DAY !current day of year ( 0 <= DAY < YEARLEN ) + REAL :: WT1,WT2 !interpolation weights + REAL :: T !current month (1.00, ..., 12.00) ! -------------------------------------------------------------------------------------------------- IF ( DVEG == 1 .or. DVEG == 3 .or. DVEG == 4 ) THEN @@ -629,67 +626,67 @@ SUBROUTINE RADIATION (VEGTYP ,IST ,ISC ,ICE ,NSOIL , & !in INTEGER, INTENT(IN) :: ICE !ice (ice = 1) INTEGER, INTENT(IN) :: NSOIL !number of soil layers - REAL(rk), INTENT(IN) :: DT !time step [s] - REAL(rk), INTENT(IN) :: QSNOW !snowfall (mm/s) - REAL(rk), INTENT(IN) :: SNEQVO !snow mass at last time step(mm) - REAL(rk), INTENT(IN) :: SNEQV !snow mass (mm) - REAL(rk), INTENT(IN) :: SNOWH !snow height (mm) - REAL(rk), INTENT(IN) :: COSZ !cosine solar zenith angle (0-1) - REAL(rk), INTENT(IN) :: TG !ground temperature (k) - REAL(rk), INTENT(IN) :: TV !vegetation temperature (k) - REAL(rk), INTENT(IN) :: ELAI !LAI, one-sided, adjusted for burying by snow - REAL(rk), INTENT(IN) :: ESAI !SAI, one-sided, adjusted for burying by snow - REAL(rk), INTENT(IN) :: FWET !fraction of canopy that is wet - REAL(rk), DIMENSION(1:NSOIL), INTENT(IN) :: SMC !volumetric soil water [m3/m3] - REAL(rk), DIMENSION(1:2) , INTENT(IN) :: SOLAD !incoming direct solar radiation (w/m2) - REAL(rk), DIMENSION(1:2) , INTENT(IN) :: SOLAI !incoming diffuse solar radiation (w/m2) - REAL(rk), INTENT(IN) :: FSNO !snow cover fraction (-) - REAL(rk), INTENT(IN) :: FVEG !green vegetation fraction [0.0-1.0] + REAL, INTENT(IN) :: DT !time step [s] + REAL, INTENT(IN) :: QSNOW !snowfall (mm/s) + REAL, INTENT(IN) :: SNEQVO !snow mass at last time step(mm) + REAL, INTENT(IN) :: SNEQV !snow mass (mm) + REAL, INTENT(IN) :: SNOWH !snow height (mm) + REAL, INTENT(IN) :: COSZ !cosine solar zenith angle (0-1) + REAL, INTENT(IN) :: TG !ground temperature (k) + REAL, INTENT(IN) :: TV !vegetation temperature (k) + REAL, INTENT(IN) :: ELAI !LAI, one-sided, adjusted for burying by snow + REAL, INTENT(IN) :: ESAI !SAI, one-sided, adjusted for burying by snow + REAL, INTENT(IN) :: FWET !fraction of canopy that is wet + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SMC !volumetric soil water [m3/m3] + REAL, DIMENSION(1:2) , INTENT(IN) :: SOLAD !incoming direct solar radiation (w/m2) + REAL, DIMENSION(1:2) , INTENT(IN) :: SOLAI !incoming diffuse solar radiation (w/m2) + REAL, INTENT(IN) :: FSNO !snow cover fraction (-) + REAL, INTENT(IN) :: FVEG !green vegetation fraction [0.0-1.0] ! inout - REAL(rk), INTENT(INOUT) :: ALBOLD !snow albedo at last time step (CLASS type) - REAL(rk), INTENT(INOUT) :: TAUSS !non-dimensional snow age. + REAL, INTENT(INOUT) :: ALBOLD !snow albedo at last time step (CLASS type) + REAL, INTENT(INOUT) :: TAUSS !non-dimensional snow age. ! output - REAL(rk), INTENT(OUT) :: FSUN !sunlit fraction of canopy (-) - REAL(rk), INTENT(OUT) :: LAISUN !sunlit leaf area (-) - REAL(rk), INTENT(OUT) :: LAISHA !shaded leaf area (-) - REAL(rk), INTENT(OUT) :: PARSUN !average absorbed par for sunlit leaves (w/m2) - REAL(rk), INTENT(OUT) :: PARSHA !average absorbed par for shaded leaves (w/m2) - REAL(rk), INTENT(OUT) :: SAV !solar radiation absorbed by vegetation (w/m2) - REAL(rk), INTENT(OUT) :: SAG !solar radiation absorbed by ground (w/m2) - REAL(rk), INTENT(OUT) :: FSA !total absorbed solar radiation (w/m2) - REAL(rk), INTENT(OUT) :: FSR !total reflected solar radiation (w/m2) + REAL, INTENT(OUT) :: FSUN !sunlit fraction of canopy (-) + REAL, INTENT(OUT) :: LAISUN !sunlit leaf area (-) + REAL, INTENT(OUT) :: LAISHA !shaded leaf area (-) + REAL, INTENT(OUT) :: PARSUN !average absorbed par for sunlit leaves (w/m2) + REAL, INTENT(OUT) :: PARSHA !average absorbed par for shaded leaves (w/m2) + REAL, INTENT(OUT) :: SAV !solar radiation absorbed by vegetation (w/m2) + REAL, INTENT(OUT) :: SAG !solar radiation absorbed by ground (w/m2) + REAL, INTENT(OUT) :: FSA !total absorbed solar radiation (w/m2) + REAL, INTENT(OUT) :: FSR !total reflected solar radiation (w/m2) !jref:start - REAL(rk), INTENT(OUT) :: FSRV !veg. reflected solar radiation (w/m2) - REAL(rk), INTENT(OUT) :: FSRG !ground reflected solar radiation (w/m2) - REAL(rk), INTENT(OUT) :: BGAP - REAL(rk), INTENT(OUT) :: WGAP + REAL, INTENT(OUT) :: FSRV !veg. reflected solar radiation (w/m2) + REAL, INTENT(OUT) :: FSRG !ground reflected solar radiation (w/m2) + REAL, INTENT(OUT) :: BGAP + REAL, INTENT(OUT) :: WGAP !jref:end ! local - REAL(rk) :: FAGE !snow age function (0 - new snow) - REAL(rk), DIMENSION(1:2) :: ALBGRD !ground albedo (direct) - REAL(rk), DIMENSION(1:2) :: ALBGRI !ground albedo (diffuse) - REAL(rk), DIMENSION(1:2) :: ALBD !surface albedo (direct) - REAL(rk), DIMENSION(1:2) :: ALBI !surface albedo (diffuse) - REAL(rk), DIMENSION(1:2) :: FABD !flux abs by veg (per unit direct flux) - REAL(rk), DIMENSION(1:2) :: FABI !flux abs by veg (per unit diffuse flux) - REAL(rk), DIMENSION(1:2) :: FTDD !down direct flux below veg (per unit dir flux) - REAL(rk), DIMENSION(1:2) :: FTID !down diffuse flux below veg (per unit dir flux) - REAL(rk), DIMENSION(1:2) :: FTII !down diffuse flux below veg (per unit dif flux) + REAL :: FAGE !snow age function (0 - new snow) + REAL, DIMENSION(1:2) :: ALBGRD !ground albedo (direct) + REAL, DIMENSION(1:2) :: ALBGRI !ground albedo (diffuse) + REAL, DIMENSION(1:2) :: ALBD !surface albedo (direct) + REAL, DIMENSION(1:2) :: ALBI !surface albedo (diffuse) + REAL, DIMENSION(1:2) :: FABD !flux abs by veg (per unit direct flux) + REAL, DIMENSION(1:2) :: FABI !flux abs by veg (per unit diffuse flux) + REAL, DIMENSION(1:2) :: FTDD !down direct flux below veg (per unit dir flux) + REAL, DIMENSION(1:2) :: FTID !down diffuse flux below veg (per unit dir flux) + REAL, DIMENSION(1:2) :: FTII !down diffuse flux below veg (per unit dif flux) !jref:start - REAL(rk), DIMENSION(1:2) :: FREVI - REAL(rk), DIMENSION(1:2) :: FREVD - REAL(rk), DIMENSION(1:2) :: FREGI - REAL(rk), DIMENSION(1:2) :: FREGD + REAL, DIMENSION(1:2) :: FREVI + REAL, DIMENSION(1:2) :: FREVD + REAL, DIMENSION(1:2) :: FREGI + REAL, DIMENSION(1:2) :: FREGD !jref:end - REAL(rk) :: FSHA !shaded fraction of canopy - REAL(rk) :: VAI !total LAI + stem area index, one sided + REAL :: FSHA !shaded fraction of canopy + REAL :: VAI !total LAI + stem area index, one sided - REAL(rk),PARAMETER :: MPE = 1.E-6 + REAL,PARAMETER :: MPE = 1.E-6 LOGICAL VEG !true: vegetated for surface temperature calculation ! -------------------------------------------------------------------------------------------------- @@ -760,67 +757,67 @@ SUBROUTINE ALBEDO (VEGTYP ,IST ,ISC ,ICE ,NSOIL , & !in INTEGER, INTENT(IN) :: ISC !soil color type (1-lighest; 8-darkest) INTEGER, INTENT(IN) :: ICE !ice (ice = 1) - REAL(rk), INTENT(IN) :: DT !time step [sec] - REAL(rk), INTENT(IN) :: QSNOW !snowfall - REAL(rk), INTENT(IN) :: COSZ !cosine solar zenith angle for next time step - REAL(rk), INTENT(IN) :: SNOWH !snow height (mm) - REAL(rk), INTENT(IN) :: TG !ground temperature (k) - REAL(rk), INTENT(IN) :: TV !vegetation temperature (k) - REAL(rk), INTENT(IN) :: ELAI !LAI, one-sided, adjusted for burying by snow - REAL(rk), INTENT(IN) :: ESAI !SAI, one-sided, adjusted for burying by snow - REAL(rk), INTENT(IN) :: FSNO !fraction of grid covered by snow - REAL(rk), INTENT(IN) :: FWET !fraction of canopy that is wet - REAL(rk), INTENT(IN) :: SNEQVO !snow mass at last time step(mm) - REAL(rk), INTENT(IN) :: SNEQV !snow mass (mm) - REAL(rk), INTENT(IN) :: FVEG !green vegetation fraction [0.0-1.0] - REAL(rk), DIMENSION(1:NSOIL), INTENT(IN) :: SMC !volumetric soil water (m3/m3) + REAL, INTENT(IN) :: DT !time step [sec] + REAL, INTENT(IN) :: QSNOW !snowfall + REAL, INTENT(IN) :: COSZ !cosine solar zenith angle for next time step + REAL, INTENT(IN) :: SNOWH !snow height (mm) + REAL, INTENT(IN) :: TG !ground temperature (k) + REAL, INTENT(IN) :: TV !vegetation temperature (k) + REAL, INTENT(IN) :: ELAI !LAI, one-sided, adjusted for burying by snow + REAL, INTENT(IN) :: ESAI !SAI, one-sided, adjusted for burying by snow + REAL, INTENT(IN) :: FSNO !fraction of grid covered by snow + REAL, INTENT(IN) :: FWET !fraction of canopy that is wet + REAL, INTENT(IN) :: SNEQVO !snow mass at last time step(mm) + REAL, INTENT(IN) :: SNEQV !snow mass (mm) + REAL, INTENT(IN) :: FVEG !green vegetation fraction [0.0-1.0] + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SMC !volumetric soil water (m3/m3) ! inout - REAL(rk), INTENT(INOUT) :: ALBOLD !snow albedo at last time step (CLASS type) - REAL(rk), INTENT(INOUT) :: TAUSS !non-dimensional snow age + REAL, INTENT(INOUT) :: ALBOLD !snow albedo at last time step (CLASS type) + REAL, INTENT(INOUT) :: TAUSS !non-dimensional snow age ! output - REAL(rk), DIMENSION(1: 2), INTENT(OUT) :: ALBGRD !ground albedo (direct) - REAL(rk), DIMENSION(1: 2), INTENT(OUT) :: ALBGRI !ground albedo (diffuse) - REAL(rk), DIMENSION(1: 2), INTENT(OUT) :: ALBD !surface albedo (direct) - REAL(rk), DIMENSION(1: 2), INTENT(OUT) :: ALBI !surface albedo (diffuse) - REAL(rk), DIMENSION(1: 2), INTENT(OUT) :: FABD !flux abs by veg (per unit direct flux) - REAL(rk), DIMENSION(1: 2), INTENT(OUT) :: FABI !flux abs by veg (per unit diffuse flux) - REAL(rk), DIMENSION(1: 2), INTENT(OUT) :: FTDD !down direct flux below veg (per unit dir flux) - REAL(rk), DIMENSION(1: 2), INTENT(OUT) :: FTID !down diffuse flux below veg (per unit dir flux) - REAL(rk), DIMENSION(1: 2), INTENT(OUT) :: FTII !down diffuse flux below veg (per unit dif flux) - REAL(rk), INTENT(OUT) :: FSUN !sunlit fraction of canopy (-) + REAL, DIMENSION(1: 2), INTENT(OUT) :: ALBGRD !ground albedo (direct) + REAL, DIMENSION(1: 2), INTENT(OUT) :: ALBGRI !ground albedo (diffuse) + REAL, DIMENSION(1: 2), INTENT(OUT) :: ALBD !surface albedo (direct) + REAL, DIMENSION(1: 2), INTENT(OUT) :: ALBI !surface albedo (diffuse) + REAL, DIMENSION(1: 2), INTENT(OUT) :: FABD !flux abs by veg (per unit direct flux) + REAL, DIMENSION(1: 2), INTENT(OUT) :: FABI !flux abs by veg (per unit diffuse flux) + REAL, DIMENSION(1: 2), INTENT(OUT) :: FTDD !down direct flux below veg (per unit dir flux) + REAL, DIMENSION(1: 2), INTENT(OUT) :: FTID !down diffuse flux below veg (per unit dir flux) + REAL, DIMENSION(1: 2), INTENT(OUT) :: FTII !down diffuse flux below veg (per unit dif flux) + REAL, INTENT(OUT) :: FSUN !sunlit fraction of canopy (-) !jref:start - REAL(rk), DIMENSION(1: 2), INTENT(OUT) :: FREVD - REAL(rk), DIMENSION(1: 2), INTENT(OUT) :: FREVI - REAL(rk), DIMENSION(1: 2), INTENT(OUT) :: FREGD - REAL(rk), DIMENSION(1: 2), INTENT(OUT) :: FREGI - REAL(rk), INTENT(OUT) :: BGAP - REAL(rk), INTENT(OUT) :: WGAP + REAL, DIMENSION(1: 2), INTENT(OUT) :: FREVD + REAL, DIMENSION(1: 2), INTENT(OUT) :: FREVI + REAL, DIMENSION(1: 2), INTENT(OUT) :: FREGD + REAL, DIMENSION(1: 2), INTENT(OUT) :: FREGI + REAL, INTENT(OUT) :: BGAP + REAL, INTENT(OUT) :: WGAP !jref:end ! ------------------------------------------------------------------------ ! ------------------------ local variables ------------------------------- ! local - REAL(rk) :: FAGE !snow age function - REAL(rk) :: ALB + REAL :: FAGE !snow age function + REAL :: ALB INTEGER :: IB !indices INTEGER :: NBAND !number of solar radiation wave bands INTEGER :: IC !direct beam: ic=0; diffuse: ic=1 - REAL(rk) :: WL !fraction of LAI+SAI that is LAI - REAL(rk) :: WS !fraction of LAI+SAI that is SAI - REAL(rk) :: MPE !prevents overflow for division by zero + REAL :: WL !fraction of LAI+SAI that is LAI + REAL :: WS !fraction of LAI+SAI that is SAI + REAL :: MPE !prevents overflow for division by zero - REAL(rk), DIMENSION(1:2) :: RHO !leaf/stem reflectance weighted by fraction LAI and SAI - REAL(rk), DIMENSION(1:2) :: TAU !leaf/stem transmittance weighted by fraction LAI and SAI - REAL(rk), DIMENSION(1:2) :: FTDI !down direct flux below veg per unit dif flux = 0 - REAL(rk), DIMENSION(1:2) :: ALBSND !snow albedo (direct) - REAL(rk), DIMENSION(1:2) :: ALBSNI !snow albedo (diffuse) + REAL, DIMENSION(1:2) :: RHO !leaf/stem reflectance weighted by fraction LAI and SAI + REAL, DIMENSION(1:2) :: TAU !leaf/stem transmittance weighted by fraction LAI and SAI + REAL, DIMENSION(1:2) :: FTDI !down direct flux below veg per unit dif flux = 0 + REAL, DIMENSION(1:2) :: ALBSND !snow albedo (direct) + REAL, DIMENSION(1:2) :: ALBSNI !snow albedo (diffuse) - REAL(rk) :: VAI !ELAI+ESAI - REAL(rk) :: GDIR !average projected leaf/stem area in solar direction - REAL(rk) :: EXT !optical depth direct beam per unit leaf + stem area + REAL :: VAI !ELAI+ESAI + REAL :: GDIR !average projected leaf/stem area in solar direction + REAL :: EXT !optical depth direct beam per unit leaf + stem area ! -------------------------------------------------------------------------------------------------- @@ -931,55 +928,55 @@ SUBROUTINE SURRAD (MPE ,FSUN ,FSHA ,ELAI ,VAI , & !in INTEGER, INTENT(IN) :: ILOC INTEGER, INTENT(IN) :: JLOC - REAL(rk), INTENT(IN) :: MPE !prevents underflow errors if division by zero - - REAL(rk), INTENT(IN) :: FSUN !sunlit fraction of canopy - REAL(rk), INTENT(IN) :: FSHA !shaded fraction of canopy - REAL(rk), INTENT(IN) :: ELAI !leaf area, one-sided - REAL(rk), INTENT(IN) :: VAI !leaf + stem area, one-sided - REAL(rk), INTENT(IN) :: LAISUN !sunlit leaf area index, one-sided - REAL(rk), INTENT(IN) :: LAISHA !shaded leaf area index, one-sided - - REAL(rk), DIMENSION(1:2), INTENT(IN) :: SOLAD !incoming direct solar radiation (w/m2) - REAL(rk), DIMENSION(1:2), INTENT(IN) :: SOLAI !incoming diffuse solar radiation (w/m2) - REAL(rk), DIMENSION(1:2), INTENT(IN) :: FABD !flux abs by veg (per unit incoming direct flux) - REAL(rk), DIMENSION(1:2), INTENT(IN) :: FABI !flux abs by veg (per unit incoming diffuse flux) - REAL(rk), DIMENSION(1:2), INTENT(IN) :: FTDD !down dir flux below veg (per incoming dir flux) - REAL(rk), DIMENSION(1:2), INTENT(IN) :: FTID !down dif flux below veg (per incoming dir flux) - REAL(rk), DIMENSION(1:2), INTENT(IN) :: FTII !down dif flux below veg (per incoming dif flux) - REAL(rk), DIMENSION(1:2), INTENT(IN) :: ALBGRD !ground albedo (direct) - REAL(rk), DIMENSION(1:2), INTENT(IN) :: ALBGRI !ground albedo (diffuse) - REAL(rk), DIMENSION(1:2), INTENT(IN) :: ALBD !overall surface albedo (direct) - REAL(rk), DIMENSION(1:2), INTENT(IN) :: ALBI !overall surface albedo (diffuse) - - REAL(rk), DIMENSION(1:2), INTENT(IN) :: FREVD !overall surface albedo veg (direct) - REAL(rk), DIMENSION(1:2), INTENT(IN) :: FREVI !overall surface albedo veg (diffuse) - REAL(rk), DIMENSION(1:2), INTENT(IN) :: FREGD !overall surface albedo grd (direct) - REAL(rk), DIMENSION(1:2), INTENT(IN) :: FREGI !overall surface albedo grd (diffuse) + REAL, INTENT(IN) :: MPE !prevents underflow errors if division by zero + + REAL, INTENT(IN) :: FSUN !sunlit fraction of canopy + REAL, INTENT(IN) :: FSHA !shaded fraction of canopy + REAL, INTENT(IN) :: ELAI !leaf area, one-sided + REAL, INTENT(IN) :: VAI !leaf + stem area, one-sided + REAL, INTENT(IN) :: LAISUN !sunlit leaf area index, one-sided + REAL, INTENT(IN) :: LAISHA !shaded leaf area index, one-sided + + REAL, DIMENSION(1:2), INTENT(IN) :: SOLAD !incoming direct solar radiation (w/m2) + REAL, DIMENSION(1:2), INTENT(IN) :: SOLAI !incoming diffuse solar radiation (w/m2) + REAL, DIMENSION(1:2), INTENT(IN) :: FABD !flux abs by veg (per unit incoming direct flux) + REAL, DIMENSION(1:2), INTENT(IN) :: FABI !flux abs by veg (per unit incoming diffuse flux) + REAL, DIMENSION(1:2), INTENT(IN) :: FTDD !down dir flux below veg (per incoming dir flux) + REAL, DIMENSION(1:2), INTENT(IN) :: FTID !down dif flux below veg (per incoming dir flux) + REAL, DIMENSION(1:2), INTENT(IN) :: FTII !down dif flux below veg (per incoming dif flux) + REAL, DIMENSION(1:2), INTENT(IN) :: ALBGRD !ground albedo (direct) + REAL, DIMENSION(1:2), INTENT(IN) :: ALBGRI !ground albedo (diffuse) + REAL, DIMENSION(1:2), INTENT(IN) :: ALBD !overall surface albedo (direct) + REAL, DIMENSION(1:2), INTENT(IN) :: ALBI !overall surface albedo (diffuse) + + REAL, DIMENSION(1:2), INTENT(IN) :: FREVD !overall surface albedo veg (direct) + REAL, DIMENSION(1:2), INTENT(IN) :: FREVI !overall surface albedo veg (diffuse) + REAL, DIMENSION(1:2), INTENT(IN) :: FREGD !overall surface albedo grd (direct) + REAL, DIMENSION(1:2), INTENT(IN) :: FREGI !overall surface albedo grd (diffuse) ! output - REAL(rk), INTENT(OUT) :: PARSUN !average absorbed par for sunlit leaves (w/m2) - REAL(rk), INTENT(OUT) :: PARSHA !average absorbed par for shaded leaves (w/m2) - REAL(rk), INTENT(OUT) :: SAV !solar radiation absorbed by vegetation (w/m2) - REAL(rk), INTENT(OUT) :: SAG !solar radiation absorbed by ground (w/m2) - REAL(rk), INTENT(OUT) :: FSA !total absorbed solar radiation (w/m2) - REAL(rk), INTENT(OUT) :: FSR !total reflected solar radiation (w/m2) - REAL(rk), INTENT(OUT) :: FSRV !reflected solar radiation by vegetation - REAL(rk), INTENT(OUT) :: FSRG !reflected solar radiation by ground + REAL, INTENT(OUT) :: PARSUN !average absorbed par for sunlit leaves (w/m2) + REAL, INTENT(OUT) :: PARSHA !average absorbed par for shaded leaves (w/m2) + REAL, INTENT(OUT) :: SAV !solar radiation absorbed by vegetation (w/m2) + REAL, INTENT(OUT) :: SAG !solar radiation absorbed by ground (w/m2) + REAL, INTENT(OUT) :: FSA !total absorbed solar radiation (w/m2) + REAL, INTENT(OUT) :: FSR !total reflected solar radiation (w/m2) + REAL, INTENT(OUT) :: FSRV !reflected solar radiation by vegetation + REAL, INTENT(OUT) :: FSRG !reflected solar radiation by ground ! ------------------------ local variables ---------------------------------------------------- INTEGER :: IB !waveband number (1=vis, 2=nir) INTEGER :: NBAND !number of solar radiation waveband classes - REAL(rk) :: ABS !absorbed solar radiation (w/m2) - REAL(rk) :: RNIR !reflected solar radiation [nir] (w/m2) - REAL(rk) :: RVIS !reflected solar radiation [vis] (w/m2) - REAL(rk) :: LAIFRA !leaf area fraction of canopy - REAL(rk) :: TRD !transmitted solar radiation: direct (w/m2) - REAL(rk) :: TRI !transmitted solar radiation: diffuse (w/m2) - REAL(rk), DIMENSION(1:2) :: CAD !direct beam absorbed by canopy (w/m2) - REAL(rk), DIMENSION(1:2) :: CAI !diffuse radiation absorbed by canopy (w/m2) + REAL :: ABS !absorbed solar radiation (w/m2) + REAL :: RNIR !reflected solar radiation [nir] (w/m2) + REAL :: RVIS !reflected solar radiation [vis] (w/m2) + REAL :: LAIFRA !leaf area fraction of canopy + REAL :: TRD !transmitted solar radiation: direct (w/m2) + REAL :: TRI !transmitted solar radiation: diffuse (w/m2) + REAL, DIMENSION(1:2) :: CAD !direct beam absorbed by canopy (w/m2) + REAL, DIMENSION(1:2) :: CAI !diffuse radiation absorbed by canopy (w/m2) ! --------------------------------------------------------------------------------------------- NBAND = 2 @@ -1044,26 +1041,26 @@ SUBROUTINE SNOW_AGE (DT,TG,SNEQVO,SNEQV,TAUSS,FAGE) ! from BATS ! ------------------------ input/output variables -------------------------------------------------- !input - REAL(rk), INTENT(IN) :: DT !main time step (s) - REAL(rk), INTENT(IN) :: TG !ground temperature (k) - REAL(rk), INTENT(IN) :: SNEQVO !snow mass at last time step(mm) - REAL(rk), INTENT(IN) :: SNEQV !snow water per unit ground area (mm) + REAL, INTENT(IN) :: DT !main time step (s) + REAL, INTENT(IN) :: TG !ground temperature (k) + REAL, INTENT(IN) :: SNEQVO !snow mass at last time step(mm) + REAL, INTENT(IN) :: SNEQV !snow water per unit ground area (mm) !output - REAL(rk), INTENT(OUT) :: FAGE !snow age + REAL, INTENT(OUT) :: FAGE !snow age !input/output - REAL(rk), INTENT(INOUT) :: TAUSS !non-dimensional snow age + REAL, INTENT(INOUT) :: TAUSS !non-dimensional snow age !local - REAL(rk) :: TAGE !total aging effects - REAL(rk) :: AGE1 !effects of grain growth due to vapor diffusion - REAL(rk) :: AGE2 !effects of grain growth at freezing of melt water - REAL(rk) :: AGE3 !effects of soot - REAL(rk) :: DELA !temporary variable - REAL(rk) :: SGE !temporary variable - REAL(rk) :: DELS !temporary variable - REAL(rk) :: DELA0 !temporary variable - REAL(rk) :: ARG !temporary variable + REAL :: TAGE !total aging effects + REAL :: AGE1 !effects of grain growth due to vapor diffusion + REAL :: AGE2 !effects of grain growth at freezing of melt water + REAL :: AGE3 !effects of soot + REAL :: DELA !temporary variable + REAL :: SGE !temporary variable + REAL :: DELS !temporary variable + REAL :: DELA0 !temporary variable + REAL :: ARG !temporary variable ! See Yang et al. (1997) J.of Climate for detail. !--------------------------------------------------------------------------------------------------- @@ -1098,28 +1095,28 @@ SUBROUTINE SNOWALB_BATS (NBAND,FSNO,COSZ,FAGE,ALBSND,ALBSNI) INTEGER,INTENT(IN) :: NBAND !number of waveband classes - REAL(rk),INTENT(IN) :: COSZ !cosine solar zenith angle - REAL(rk),INTENT(IN) :: FSNO !snow cover fraction (-) - REAL(rk),INTENT(IN) :: FAGE !snow age correction + REAL,INTENT(IN) :: COSZ !cosine solar zenith angle + REAL,INTENT(IN) :: FSNO !snow cover fraction (-) + REAL,INTENT(IN) :: FAGE !snow age correction ! output - REAL(rk), DIMENSION(1:2),INTENT(OUT) :: ALBSND !snow albedo for direct(1=vis, 2=nir) - REAL(rk), DIMENSION(1:2),INTENT(OUT) :: ALBSNI !snow albedo for diffuse + REAL, DIMENSION(1:2),INTENT(OUT) :: ALBSND !snow albedo for direct(1=vis, 2=nir) + REAL, DIMENSION(1:2),INTENT(OUT) :: ALBSNI !snow albedo for diffuse ! --------------------------------------------------------------------------------------------- ! ------------------------ local variables ---------------------------------------------------- INTEGER :: IB !waveband class - REAL(rk) :: FZEN !zenith angle correction - REAL(rk) :: CF1 !temperary variable - REAL(rk) :: SL2 !2.*SL - REAL(rk) :: SL1 !1/SL - REAL(rk) :: SL !adjustable parameter - REAL(rk), PARAMETER :: C1 = 0.2 !default in BATS - REAL(rk), PARAMETER :: C2 = 0.5 !default in BATS -! REAL(rk), PARAMETER :: C1 = 0.2 * 2. ! double the default to match Sleepers River's -! REAL(rk), PARAMETER :: C2 = 0.5 * 2. ! snow surface albedo (double aging effects) + REAL :: FZEN !zenith angle correction + REAL :: CF1 !temperary variable + REAL :: SL2 !2.*SL + REAL :: SL1 !1/SL + REAL :: SL !adjustable parameter + REAL, PARAMETER :: C1 = 0.2 !default in BATS + REAL, PARAMETER :: C2 = 0.5 !default in BATS +! REAL, PARAMETER :: C1 = 0.2 * 2. ! double the default to match Sleepers River's +! REAL, PARAMETER :: C2 = 0.5 * 2. ! snow surface albedo (double aging effects) ! --------------------------------------------------------------------------------------------- ! zero albedos for all points @@ -1153,17 +1150,17 @@ SUBROUTINE SNOWALB_CLASS (NBAND,QSNOW,DT,ALB,ALBOLD,ALBSND,ALBSNI,ILOC,JLOC) INTEGER,INTENT(IN) :: JLOC !grid index INTEGER,INTENT(IN) :: NBAND !number of waveband classes - REAL(rk),INTENT(IN) :: QSNOW !snowfall (mm/s) - REAL(rk),INTENT(IN) :: DT !time step (sec) - REAL(rk),INTENT(IN) :: ALBOLD !snow albedo at last time step + REAL,INTENT(IN) :: QSNOW !snowfall (mm/s) + REAL,INTENT(IN) :: DT !time step (sec) + REAL,INTENT(IN) :: ALBOLD !snow albedo at last time step ! in & out - REAL(rk), INTENT(INOUT) :: ALB ! + REAL, INTENT(INOUT) :: ALB ! ! output - REAL(rk), DIMENSION(1:2),INTENT(OUT) :: ALBSND !snow albedo for direct(1=vis, 2=nir) - REAL(rk), DIMENSION(1:2),INTENT(OUT) :: ALBSNI !snow albedo for diffuse + REAL, DIMENSION(1:2),INTENT(OUT) :: ALBSND !snow albedo for direct(1=vis, 2=nir) + REAL, DIMENSION(1:2),INTENT(OUT) :: ALBSNI !snow albedo for diffuse ! --------------------------------------------------------------------------------------------- ! ------------------------ local variables ---------------------------------------------------- @@ -1213,24 +1210,24 @@ SUBROUTINE GROUNDALB (NSOIL ,NBAND ,ICE ,IST ,ISC , & !in INTEGER, INTENT(IN) :: ICE !value of ist for land ice INTEGER, INTENT(IN) :: IST !surface type INTEGER, INTENT(IN) :: ISC !soil color class (1-lighest; 8-darkest) - REAL(rk), INTENT(IN) :: FSNO !fraction of surface covered with snow (-) - REAL(rk), INTENT(IN) :: TG !ground temperature (k) - REAL(rk), INTENT(IN) :: COSZ !cosine solar zenith angle (0-1) - REAL(rk), DIMENSION(1:NSOIL), INTENT(IN) :: SMC !volumetric soil water content (m3/m3) - REAL(rk), DIMENSION(1: 2), INTENT(IN) :: ALBSND !direct beam snow albedo (vis, nir) - REAL(rk), DIMENSION(1: 2), INTENT(IN) :: ALBSNI !diffuse snow albedo (vis, nir) + REAL, INTENT(IN) :: FSNO !fraction of surface covered with snow (-) + REAL, INTENT(IN) :: TG !ground temperature (k) + REAL, INTENT(IN) :: COSZ !cosine solar zenith angle (0-1) + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SMC !volumetric soil water content (m3/m3) + REAL, DIMENSION(1: 2), INTENT(IN) :: ALBSND !direct beam snow albedo (vis, nir) + REAL, DIMENSION(1: 2), INTENT(IN) :: ALBSNI !diffuse snow albedo (vis, nir) !output - REAL(rk), DIMENSION(1: 2), INTENT(OUT) :: ALBGRD !ground albedo (direct beam: vis, nir) - REAL(rk), DIMENSION(1: 2), INTENT(OUT) :: ALBGRI !ground albedo (diffuse: vis, nir) + REAL, DIMENSION(1: 2), INTENT(OUT) :: ALBGRD !ground albedo (direct beam: vis, nir) + REAL, DIMENSION(1: 2), INTENT(OUT) :: ALBGRI !ground albedo (diffuse: vis, nir) !local INTEGER :: IB !waveband number (1=vis, 2=nir) - REAL(rk) :: INC !soil water correction factor for soil albedo - REAL(rk) :: ALBSOD !soil albedo (direct) - REAL(rk) :: ALBSOI !soil albedo (diffuse) + REAL :: INC !soil water correction factor for soil albedo + REAL :: ALBSOD !soil albedo (direct) + REAL :: ALBSOI !soil albedo (diffuse) ! -------------------------------------------------------------------------------------------------- DO IB = 1, NBAND @@ -1287,68 +1284,68 @@ SUBROUTINE TWOSTREAM (IB ,IC ,VEGTYP ,COSZ ,VAI , & !in INTEGER, INTENT(IN) :: IC !0=unit incoming direct; 1=unit incoming diffuse INTEGER, INTENT(IN) :: VEGTYP !vegetation type - REAL(rk), INTENT(IN) :: COSZ !cosine of direct zenith angle (0-1) - REAL(rk), INTENT(IN) :: VAI !one-sided leaf+stem area index (m2/m2) - REAL(rk), INTENT(IN) :: FWET !fraction of lai, sai that is wetted (-) - REAL(rk), INTENT(IN) :: T !surface temperature (k) + REAL, INTENT(IN) :: COSZ !cosine of direct zenith angle (0-1) + REAL, INTENT(IN) :: VAI !one-sided leaf+stem area index (m2/m2) + REAL, INTENT(IN) :: FWET !fraction of lai, sai that is wetted (-) + REAL, INTENT(IN) :: T !surface temperature (k) - REAL(rk), DIMENSION(1:2), INTENT(IN) :: ALBGRD !direct albedo of underlying surface (-) - REAL(rk), DIMENSION(1:2), INTENT(IN) :: ALBGRI !diffuse albedo of underlying surface (-) - REAL(rk), DIMENSION(1:2), INTENT(IN) :: RHO !leaf+stem reflectance - REAL(rk), DIMENSION(1:2), INTENT(IN) :: TAU !leaf+stem transmittance - REAL(rk), INTENT(IN) :: FVEG !green vegetation fraction [0.0-1.0] + REAL, DIMENSION(1:2), INTENT(IN) :: ALBGRD !direct albedo of underlying surface (-) + REAL, DIMENSION(1:2), INTENT(IN) :: ALBGRI !diffuse albedo of underlying surface (-) + REAL, DIMENSION(1:2), INTENT(IN) :: RHO !leaf+stem reflectance + REAL, DIMENSION(1:2), INTENT(IN) :: TAU !leaf+stem transmittance + REAL, INTENT(IN) :: FVEG !green vegetation fraction [0.0-1.0] ! output - REAL(rk), DIMENSION(1:2), INTENT(OUT) :: FAB !flux abs by veg layer (per unit incoming flux) - REAL(rk), DIMENSION(1:2), INTENT(OUT) :: FRE !flux refl above veg layer (per unit incoming flux) - REAL(rk), DIMENSION(1:2), INTENT(OUT) :: FTD !down dir flux below veg layer (per unit in flux) - REAL(rk), DIMENSION(1:2), INTENT(OUT) :: FTI !down dif flux below veg layer (per unit in flux) - REAL(rk), INTENT(OUT) :: GDIR !projected leaf+stem area in solar direction - REAL(rk), DIMENSION(1:2), INTENT(OUT) :: FREV !flux reflected by veg layer (per unit incoming flux) - REAL(rk), DIMENSION(1:2), INTENT(OUT) :: FREG !flux reflected by ground (per unit incoming flux) + REAL, DIMENSION(1:2), INTENT(OUT) :: FAB !flux abs by veg layer (per unit incoming flux) + REAL, DIMENSION(1:2), INTENT(OUT) :: FRE !flux refl above veg layer (per unit incoming flux) + REAL, DIMENSION(1:2), INTENT(OUT) :: FTD !down dir flux below veg layer (per unit in flux) + REAL, DIMENSION(1:2), INTENT(OUT) :: FTI !down dif flux below veg layer (per unit in flux) + REAL, INTENT(OUT) :: GDIR !projected leaf+stem area in solar direction + REAL, DIMENSION(1:2), INTENT(OUT) :: FREV !flux reflected by veg layer (per unit incoming flux) + REAL, DIMENSION(1:2), INTENT(OUT) :: FREG !flux reflected by ground (per unit incoming flux) ! local - REAL(rk) :: OMEGA !fraction of intercepted radiation that is scattered - REAL(rk) :: OMEGAL !omega for leaves - REAL(rk) :: BETAI !upscatter parameter for diffuse radiation - REAL(rk) :: BETAIL !betai for leaves - REAL(rk) :: BETAD !upscatter parameter for direct beam radiation - REAL(rk) :: BETADL !betad for leaves - REAL(rk) :: EXT !optical depth of direct beam per unit leaf area - REAL(rk) :: AVMU !average diffuse optical depth - - REAL(rk) :: COSZI !0.001 <= cosz <= 1.000 - REAL(rk) :: ASU !single scattering albedo - REAL(rk) :: CHIL ! -0.4 <= xl <= 0.6 - - REAL(rk) :: TMP0,TMP1,TMP2,TMP3,TMP4,TMP5,TMP6,TMP7,TMP8,TMP9 - REAL(rk) :: P1,P2,P3,P4,S1,S2,U1,U2,U3 - REAL(rk) :: B,C,D,D1,D2,F,H,H1,H2,H3,H4,H5,H6,H7,H8,H9,H10 - REAL(rk) :: PHI1,PHI2,SIGMA - REAL(rk) :: FTDS,FTIS,FRES - REAL(rk) :: DENFVEG - REAL(rk) :: VAI_SPREAD + REAL :: OMEGA !fraction of intercepted radiation that is scattered + REAL :: OMEGAL !omega for leaves + REAL :: BETAI !upscatter parameter for diffuse radiation + REAL :: BETAIL !betai for leaves + REAL :: BETAD !upscatter parameter for direct beam radiation + REAL :: BETADL !betad for leaves + REAL :: EXT !optical depth of direct beam per unit leaf area + REAL :: AVMU !average diffuse optical depth + + REAL :: COSZI !0.001 <= cosz <= 1.000 + REAL :: ASU !single scattering albedo + REAL :: CHIL ! -0.4 <= xl <= 0.6 + + REAL :: TMP0,TMP1,TMP2,TMP3,TMP4,TMP5,TMP6,TMP7,TMP8,TMP9 + REAL :: P1,P2,P3,P4,S1,S2,U1,U2,U3 + REAL :: B,C,D,D1,D2,F,H,H1,H2,H3,H4,H5,H6,H7,H8,H9,H10 + REAL :: PHI1,PHI2,SIGMA + REAL :: FTDS,FTIS,FRES + REAL :: DENFVEG + REAL :: VAI_SPREAD !jref:start - REAL(rk) :: FREVEG,FREBAR,FTDVEG,FTIVEG,FTDBAR,FTIBAR - REAL(rk) :: THETAZ + REAL :: FREVEG,FREBAR,FTDVEG,FTIVEG,FTDBAR,FTIBAR + REAL :: THETAZ !jref:end ! variables for the modified two-stream scheme ! Niu and Yang (2004), JGR - REAL(rk), PARAMETER :: PAI = 3.14159265 - REAL(rk) :: HD !crown depth (m) - REAL(rk) :: BB !vertical crown radius (m) - REAL(rk) :: THETAP !angle conversion from SZA - REAL(rk) :: FA !foliage volume density (m-1) - REAL(rk) :: NEWVAI !effective LSAI (-) + REAL, PARAMETER :: PAI = 3.14159265 + REAL :: HD !crown depth (m) + REAL :: BB !vertical crown radius (m) + REAL :: THETAP !angle conversion from SZA + REAL :: FA !foliage volume density (m-1) + REAL :: NEWVAI !effective LSAI (-) - REAL(rk),INTENT(INOUT) :: BGAP !between canopy gap fraction for beam (-) - REAL(rk),INTENT(INOUT) :: WGAP !within canopy gap fraction for beam (-) + REAL,INTENT(INOUT) :: BGAP !between canopy gap fraction for beam (-) + REAL,INTENT(INOUT) :: WGAP !within canopy gap fraction for beam (-) - REAL(rk) :: KOPEN !gap fraction for diffue light (-) - REAL(rk) :: GAP !total gap fraction for beam ( <=1-shafac ) + REAL :: KOPEN !gap fraction for diffue light (-) + REAL :: GAP !total gap fraction for beam ( <=1-shafac ) ! ----------------------------------------------------------------- ! compute within and between gaps @@ -1432,7 +1429,7 @@ SUBROUTINE TWOSTREAM (IB ,IC ,VEGTYP ,COSZ ,VAI , & !in TMP1 = B*B - C*C H = SQRT(TMP1) / AVMU SIGMA = TMP0*TMP0 - TMP1 - if ( ABS (SIGMA) < 1.e-6 ) SIGMA = SIGN(1.e-6,REAL(SIGMA)) + if ( ABS (SIGMA) < 1.e-6 ) SIGMA = SIGN(1.e-6,SIGMA) P1 = B + AVMU*H P2 = B - AVMU*H P3 = B + TMP0 @@ -1527,27 +1524,27 @@ SUBROUTINE STOMATA (VEGTYP ,MPE ,APAR ,FOLN ,ILOC , JLOC, & !in INTEGER,INTENT(IN) :: JLOC !grid index INTEGER,INTENT(IN) :: VEGTYP !vegetation physiology type - REAL(rk), INTENT(IN) :: IGS !growing season index (0=off, 1=on) - REAL(rk), INTENT(IN) :: MPE !prevents division by zero errors - - REAL(rk), INTENT(IN) :: TV !foliage temperature (k) - REAL(rk), INTENT(IN) :: EI !vapor pressure inside leaf (sat vapor press at tv) (pa) - REAL(rk), INTENT(IN) :: EA !vapor pressure of canopy air (pa) - REAL(rk), INTENT(IN) :: APAR !par absorbed per unit lai (w/m2) - REAL(rk), INTENT(IN) :: O2 !atmospheric o2 concentration (pa) - REAL(rk), INTENT(IN) :: CO2 !atmospheric co2 concentration (pa) - REAL(rk), INTENT(IN) :: SFCPRS !air pressure at reference height (pa) - REAL(rk), INTENT(IN) :: SFCTMP !air temperature at reference height (k) - REAL(rk), INTENT(IN) :: BTRAN !soil water transpiration factor (0 to 1) - REAL(rk), INTENT(IN) :: FOLN !foliage nitrogen concentration (%) - REAL(rk), INTENT(IN) :: RB !boundary layer resistance (s/m) + REAL, INTENT(IN) :: IGS !growing season index (0=off, 1=on) + REAL, INTENT(IN) :: MPE !prevents division by zero errors + + REAL, INTENT(IN) :: TV !foliage temperature (k) + REAL, INTENT(IN) :: EI !vapor pressure inside leaf (sat vapor press at tv) (pa) + REAL, INTENT(IN) :: EA !vapor pressure of canopy air (pa) + REAL, INTENT(IN) :: APAR !par absorbed per unit lai (w/m2) + REAL, INTENT(IN) :: O2 !atmospheric o2 concentration (pa) + REAL, INTENT(IN) :: CO2 !atmospheric co2 concentration (pa) + REAL, INTENT(IN) :: SFCPRS !air pressure at reference height (pa) + REAL, INTENT(IN) :: SFCTMP !air temperature at reference height (k) + REAL, INTENT(IN) :: BTRAN !soil water transpiration factor (0 to 1) + REAL, INTENT(IN) :: FOLN !foliage nitrogen concentration (%) + REAL, INTENT(IN) :: RB !boundary layer resistance (s/m) ! output - REAL(rk), INTENT(OUT) :: RS !leaf stomatal resistance (s/m) - REAL(rk), INTENT(OUT) :: PSN !foliage photosynthesis (umol co2 /m2/ s) [always +] + REAL, INTENT(OUT) :: RS !leaf stomatal resistance (s/m) + REAL, INTENT(OUT) :: PSN !foliage photosynthesis (umol co2 /m2/ s) [always +] ! in&out - REAL(rk) :: RLB !boundary layer resistance (s m2 / umol) + REAL :: RLB !boundary layer resistance (s m2 / umol) ! --------------------------------------------------------------------------------------------- ! ------------------------ local variables ---------------------------------------------------- @@ -1557,32 +1554,32 @@ SUBROUTINE STOMATA (VEGTYP ,MPE ,APAR ,FOLN ,ILOC , JLOC, & !in DATA NITER /3/ SAVE NITER - REAL(rk) :: AB !used in statement functions - REAL(rk) :: BC !used in statement functions - REAL(rk) :: F1 !generic temperature response (statement function) - REAL(rk) :: F2 !generic temperature inhibition (statement function) - REAL(rk) :: TC !foliage temperature (degree Celsius) - REAL(rk) :: CS !co2 concentration at leaf surface (pa) - REAL(rk) :: KC !co2 Michaelis-Menten constant (pa) - REAL(rk) :: KO !o2 Michaelis-Menten constant (pa) - REAL(rk) :: A,B,C,Q !intermediate calculations for RS - REAL(rk) :: R1,R2 !roots for RS - REAL(rk) :: FNF !foliage nitrogen adjustment factor (0 to 1) - REAL(rk) :: PPF !absorb photosynthetic photon flux (umol photons/m2/s) - REAL(rk) :: WC !Rubisco limited photosynthesis (umol co2/m2/s) - REAL(rk) :: WJ !light limited photosynthesis (umol co2/m2/s) - REAL(rk) :: WE !export limited photosynthesis (umol co2/m2/s) - REAL(rk) :: CP !co2 compensation point (pa) - REAL(rk) :: CI !internal co2 (pa) - REAL(rk) :: AWC !intermediate calculation for wc - REAL(rk) :: VCMX !maximum rate of carbonylation (umol co2/m2/s) - REAL(rk) :: J !electron transport (umol co2/m2/s) - REAL(rk) :: CEA !constrain ea or else model blows up - REAL(rk) :: CF !s m2/umol -> s/m + REAL :: AB !used in statement functions + REAL :: BC !used in statement functions + REAL :: F1 !generic temperature response (statement function) + REAL :: F2 !generic temperature inhibition (statement function) + REAL :: TC !foliage temperature (degree Celsius) + REAL :: CS !co2 concentration at leaf surface (pa) + REAL :: KC !co2 Michaelis-Menten constant (pa) + REAL :: KO !o2 Michaelis-Menten constant (pa) + REAL :: A,B,C,Q !intermediate calculations for RS + REAL :: R1,R2 !roots for RS + REAL :: FNF !foliage nitrogen adjustment factor (0 to 1) + REAL :: PPF !absorb photosynthetic photon flux (umol photons/m2/s) + REAL :: WC !Rubisco limited photosynthesis (umol co2/m2/s) + REAL :: WJ !light limited photosynthesis (umol co2/m2/s) + REAL :: WE !export limited photosynthesis (umol co2/m2/s) + REAL :: CP !co2 compensation point (pa) + REAL :: CI !internal co2 (pa) + REAL :: AWC !intermediate calculation for wc + REAL :: VCMX !maximum rate of carbonylation (umol co2/m2/s) + REAL :: J !electron transport (umol co2/m2/s) + REAL :: CEA !constrain ea or else model blows up + REAL :: CF !s m2/umol -> s/m F1(AB,BC) = AB**((BC-25.)/10.) F2(AB) = 1. + EXP((-2.2E05+710.*(AB+273.16))/(8.314*(AB+273.16))) - REAL(rk) :: T + REAL :: T ! --------------------------------------------------------------------------------------------- ! MPC change @@ -1689,26 +1686,26 @@ SUBROUTINE CANRES (PAR ,SFCTMP,RCSOIL ,EAH ,SFCPRS , & !in INTEGER, INTENT(IN) :: ILOC !grid index INTEGER, INTENT(IN) :: JLOC !grid index - REAL(rk), INTENT(IN) :: PAR !par absorbed per unit sunlit lai (w/m2) - REAL(rk), INTENT(IN) :: SFCTMP !canopy air temperature - REAL(rk), INTENT(IN) :: SFCPRS !surface pressure (pa) - REAL(rk), INTENT(IN) :: EAH !water vapor pressure (pa) - REAL(rk), INTENT(IN) :: RCSOIL !soil moisture stress factor + REAL, INTENT(IN) :: PAR !par absorbed per unit sunlit lai (w/m2) + REAL, INTENT(IN) :: SFCTMP !canopy air temperature + REAL, INTENT(IN) :: SFCPRS !surface pressure (pa) + REAL, INTENT(IN) :: EAH !water vapor pressure (pa) + REAL, INTENT(IN) :: RCSOIL !soil moisture stress factor !outputs - REAL(rk), INTENT(OUT) :: RC !canopy resistance per unit LAI - REAL(rk), INTENT(OUT) :: PSN !foliage photosynthesis (umolco2/m2/s) + REAL, INTENT(OUT) :: RC !canopy resistance per unit LAI + REAL, INTENT(OUT) :: PSN !foliage photosynthesis (umolco2/m2/s) !local - REAL(rk) :: RCQ - REAL(rk) :: RCS - REAL(rk) :: RCT - REAL(rk) :: FF - REAL(rk) :: Q2 !water vapor mixing ratio (kg/kg) - REAL(rk) :: Q2SAT !saturation Q2 - REAL(rk) :: DQSDT2 !d(Q2SAT)/d(T) + REAL :: RCQ + REAL :: RCS + REAL :: RCT + REAL :: FF + REAL :: Q2 !water vapor mixing ratio (kg/kg) + REAL :: Q2SAT !saturation Q2 + REAL :: DQSDT2 !d(Q2SAT)/d(T) ! RSMIN, RSMAX, TOPT, RGL, HS are canopy stress parameters set in REDPRM ! ---------------------------------------------------------------------- @@ -1751,12 +1748,12 @@ END SUBROUTINE CANRES ! ================================================================================================== SUBROUTINE CALHUM(SFCTMP, SFCPRS, Q2SAT, DQSDT2) IMPLICIT NONE - REAL(rk), INTENT(IN) :: SFCTMP, SFCPRS - REAL(rk), INTENT(OUT) :: Q2SAT, DQSDT2 - REAL(rk), PARAMETER :: A2=17.67,A3=273.15,A4=29.65, ELWV=2.501E6, & + REAL, INTENT(IN) :: SFCTMP, SFCPRS + REAL, INTENT(OUT) :: Q2SAT, DQSDT2 + REAL, PARAMETER :: A2=17.67,A3=273.15,A4=29.65, ELWV=2.501E6, & A23M4=A2*(A3-A4), E0=0.611, RV=461.0, & EPSILON=0.622 - REAL(rk) :: ES, SFCPRSX + REAL :: ES, SFCPRSX ! Q2SAT: saturated mixing ratio ES = E0 * EXP ( ELWV/RV*(1./A3 - 1./SFCTMP) ) ! convert SFCPRS from Pa to KPa @@ -1826,13 +1823,13 @@ SUBROUTINE REDPRM (VEGTYP,SOILTYP,SLOPETYP,ZSOIL,NSOIL,ISURBAN) ! General parameters INTEGER, INTENT(IN) :: NSOIL ! Layer parameters - REAL(rk),DIMENSION(NSOIL),INTENT(IN) :: ZSOIL + REAL,DIMENSION(NSOIL),INTENT(IN) :: ZSOIL ! Locals - REAL(rk) :: REFDK - REAL(rk) :: REFKDT - REAL(rk) :: FRZK - REAL(rk) :: FRZFACT + REAL :: REFDK + REAL :: REFKDT + REAL :: FRZK + REAL :: FRZFACT INTEGER :: I CHARACTER(len=256) :: message ! ---------------------------------------------------------------------- @@ -1965,7 +1962,6 @@ END MODULE NOAHMP_ROUTINES ! ================================================================================================== MODULE MODULE_SF_NOAHMPLSM - use nrtype USE NOAHMP_ROUTINES USE NOAHMP_GLOBALS diff --git a/build/source/noah-mp/module_sf_noahutl.F b/build/source/noah-mp/module_sf_noahutl.F index a757ebed5..007961bd3 100755 --- a/build/source/noah-mp/module_sf_noahutl.F +++ b/build/source/noah-mp/module_sf_noahutl.F @@ -1,7 +1,6 @@ MODULE module_sf_noahutl - USE nrtype - REAL(rk), PARAMETER :: CP = 1004.5, RD = 287.04, SIGMA = 5.67E-8, & + REAL, PARAMETER :: CP = 1004.5, RD = 287.04, SIGMA = 5.67E-8, & CPH2O = 4.218E+3,CPICE = 2.106E+3, & LSUBF = 3.335E+5 @@ -12,20 +11,20 @@ SUBROUTINE CALTMP(T1, SFCTMP, SFCPRS, ZLVL, Q2, TH2, T1V, TH2V, RHO ) IMPLICIT NONE ! Input: - REAL(rk), INTENT(IN) :: T1 ! Skin temperature (K) - REAL(rk), INTENT(IN) :: SFCTMP ! Air temperature (K) at level ZLVL - REAL(rk), INTENT(IN) :: Q2 ! Specific Humidity (kg/kg) at level ZLVL - REAL(rk), INTENT(IN) :: SFCPRS ! Atmospheric pressure (Pa) at level ZLVL - REAL(rk), INTENT(IN) :: ZLVL ! Height (m AGL) where atmospheric fields are valid + REAL, INTENT(IN) :: T1 ! Skin temperature (K) + REAL, INTENT(IN) :: SFCTMP ! Air temperature (K) at level ZLVL + REAL, INTENT(IN) :: Q2 ! Specific Humidity (kg/kg) at level ZLVL + REAL, INTENT(IN) :: SFCPRS ! Atmospheric pressure (Pa) at level ZLVL + REAL, INTENT(IN) :: ZLVL ! Height (m AGL) where atmospheric fields are valid ! Output: - REAL(rk), INTENT(OUT) :: TH2 ! Potential temperature (considering the reference pressure to be at the surface) - REAL(rk), INTENT(OUT) :: T1V ! Virtual skin temperature (K) - REAL(rk), INTENT(OUT) :: TH2V ! Virtual potential temperature at ZLVL - REAL(rk), INTENT(OUT) :: RHO ! Density + REAL, INTENT(OUT) :: TH2 ! Potential temperature (considering the reference pressure to be at the surface) + REAL, INTENT(OUT) :: T1V ! Virtual skin temperature (K) + REAL, INTENT(OUT) :: TH2V ! Virtual potential temperature at ZLVL + REAL, INTENT(OUT) :: RHO ! Density ! Local: - REAL(rk) :: T2V + REAL :: T2V TH2 = SFCTMP + ( 0.0098 * ZLVL) T1V= T1 * (1.0+ 0.61 * Q2) @@ -40,18 +39,18 @@ SUBROUTINE CALHUM(SFCTMP, SFCPRS, Q2SAT, DQSDT2) IMPLICIT NONE ! Input: - REAL(rk), INTENT(IN) :: SFCTMP - REAL(rk), INTENT(IN) :: SFCPRS + REAL, INTENT(IN) :: SFCTMP + REAL, INTENT(IN) :: SFCPRS ! Output: - REAL(rk), INTENT(OUT) :: Q2SAT ! Saturated specific humidity - REAL(rk), INTENT(OUT) :: DQSDT2 + REAL, INTENT(OUT) :: Q2SAT ! Saturated specific humidity + REAL, INTENT(OUT) :: DQSDT2 ! Local - REAL(rk), PARAMETER :: A2=17.67,A3=273.15,A4=29.65, ELWV=2.501E6, & + REAL, PARAMETER :: A2=17.67,A3=273.15,A4=29.65, ELWV=2.501E6, & A23M4=A2*(A3-A4), E0=611.0, RV=461.0, & EPSILON=0.622 - REAL(rk) :: ES + REAL :: ES ! ES: e.g. Dutton chapter 8, eq 11 ES = E0 * EXP ( ELWV/RV*(1./A3 - 1./SFCTMP) ) diff --git a/docs/whats-new.md b/docs/whats-new.md index 247f380f3..88934fa03 100644 --- a/docs/whats-new.md +++ b/docs/whats-new.md @@ -11,5 +11,3 @@ This page provides simple, high-level documentation about what has changed in ea - Fixes a water balance error w.r.t transpiration - Fixes the output message to report the correct solution type - Adds tolerance to balance check in updatState.f90 -- Changes all float data types to `rk`, for "real kind", which is intended to - make it easier to switch from double to single precision. From 90df88dfba1cef1b0dc6041fddd0ff13a47f79f2 Mon Sep 17 00:00:00 2001 From: arbennett Date: Wed, 26 May 2021 16:27:47 -0700 Subject: [PATCH 23/24] Fix basin variable reference/initialization --- build/source/dshare/get_ixname.f90 | 1 + build/source/dshare/popMetadat.f90 | 1 + build/source/dshare/var_lookup.f90 | 3 ++- build/source/engine/run_oneGRU.f90 | 4 ++-- 4 files changed, 6 insertions(+), 3 deletions(-) diff --git a/build/source/dshare/get_ixname.f90 b/build/source/dshare/get_ixname.f90 index cf4480218..3efe30f92 100755 --- a/build/source/dshare/get_ixname.f90 +++ b/build/source/dshare/get_ixname.f90 @@ -888,6 +888,7 @@ function get_ixbvar(varName) case('basin__AquiferBaseflow' ); get_ixbvar = iLookBVAR%basin__AquiferBaseflow ! baseflow from the aquifer (m s-1) case('basin__AquiferTranspire' ); get_ixbvar = iLookBVAR%basin__AquiferTranspire ! transpiration from the aquifer (m s-1) case('basin__TotalRunoff' ); get_ixbvar = iLookBVAR%basin__TotalRunoff ! total runoff to channel from all active components (m s-1) + case('basin__SoilDrainage' ); get_ixbvar = iLookBVAR%basin__SoilDrainage ! soil drainage (m s-1) ! variables to compute runoff case('routingRunoffFuture' ); get_ixbvar = iLookBVAR%routingRunoffFuture ! runoff in future time steps (m s-1) case('routingFractionFuture' ); get_ixbvar = iLookBVAR%routingFractionFuture ! fraction of runoff in future time steps (-) diff --git a/build/source/dshare/popMetadat.f90 b/build/source/dshare/popMetadat.f90 index 0a1b32add..afd925d0e 100755 --- a/build/source/dshare/popMetadat.f90 +++ b/build/source/dshare/popMetadat.f90 @@ -590,6 +590,7 @@ subroutine popMetadat(err,message) bvar_meta(iLookBVAR%basin__AquiferBaseflow) = var_info('basin__AquiferBaseflow' , 'baseflow from the aquifer' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) bvar_meta(iLookBVAR%basin__AquiferTranspire) = var_info('basin__AquiferTranspire', 'transpiration loss from the aquifer' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) bvar_meta(iLookBVAR%basin__TotalRunoff) = var_info('basin__TotalRunoff' , 'total runoff to channel from all active components' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + bvar_meta(iLookBVAR%basin__SoilDrainage) = var_info('basin__SoilDrainage' , 'soil drainage' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) bvar_meta(iLookBVAR%routingRunoffFuture) = var_info('routingRunoffFuture' , 'runoff in future time steps' , 'm s-1' , get_ixVarType('routing'), iMissVec, iMissVec, .false.) bvar_meta(iLookBVAR%routingFractionFuture) = var_info('routingFractionFuture' , 'fraction of runoff in future time steps' , '-' , get_ixVarType('routing'), iMissVec, iMissVec, .false.) bvar_meta(iLookBVAR%averageInstantRunoff) = var_info('averageInstantRunoff' , 'instantaneous runoff' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) diff --git a/build/source/dshare/var_lookup.f90 b/build/source/dshare/var_lookup.f90 index 1d7744c8a..ffc18c32b 100755 --- a/build/source/dshare/var_lookup.f90 +++ b/build/source/dshare/var_lookup.f90 @@ -705,6 +705,7 @@ MODULE var_lookup integer(i4b) :: basin__AquiferBaseflow = integerMissing ! baseflow from the aquifer (m s-1) integer(i4b) :: basin__AquiferTranspire = integerMissing ! transpiration from the aquifer (m s-1) integer(i4b) :: basin__TotalRunoff = integerMissing ! total runoff to channel from all active components (m s-1) + integer(i4b) :: basin__SoilDrainage = integerMissing ! soil drainage (m s-1) ! define variables for runoff integer(i4b) :: routingRunoffFuture = integerMissing ! runoff in future time steps (m s-1) integer(i4b) :: routingFractionFuture = integerMissing ! fraction of runoff in future time steps (-) @@ -841,7 +842,7 @@ MODULE var_lookup ! named variables: basin-average variables type(iLook_bvar), public,parameter :: iLookBVAR =ilook_bvar ( 1, 2, 3, 4, 5, 6, 7, 8, 9, 10,& - 11, 12) + 11, 12, 13) ! named variables in varibale type structure type(iLook_varType), public,parameter :: iLookVarType =ilook_varType ( 1, 2, 3, 4, 5, 6, 7, 8, 9, 10,& diff --git a/build/source/engine/run_oneGRU.f90 b/build/source/engine/run_oneGRU.f90 index 149e9fc02..17fca209f 100755 --- a/build/source/engine/run_oneGRU.f90 +++ b/build/source/engine/run_oneGRU.f90 @@ -259,6 +259,8 @@ subroutine run_oneGRU(& ! *********************************************************************************************************************** ! ********** END LOOP THROUGH HRUS ************************************************************************************** ! *********************************************************************************************************************** + ! perform the routing + associate(totalArea => bvarData%var(iLookBVAR%basin__totalArea)%dat(1) ) ! compute water balance for the basin aquifer if(model_decisions(iLookDECISIONS%spatial_gw)%iDecision == singleBasin)then @@ -275,8 +277,6 @@ subroutine run_oneGRU(& bvarData%var(iLookBVAR%basin__TotalRunoff)%dat(1) = bvarData%var(iLookBVAR%basin__SurfaceRunoff)%dat(1) + bvarData%var(iLookBVAR%basin__ColumnOutflow)%dat(1)/totalArea + bvarData%var(iLookBVAR%basin__SoilDrainage)%dat(1) endif - ! perform the routing - associate(totalArea => bvarData%var(iLookBVAR%basin__totalArea)%dat(1) ) call qOverland(& ! input model_decisions(iLookDECISIONS%subRouting)%iDecision, & ! intent(in): index for routing method From 89f760abedcc35218ef3a980384bcd68624b3247 Mon Sep 17 00:00:00 2001 From: martynpclark Date: Fri, 28 May 2021 12:20:35 -0600 Subject: [PATCH 24/24] ensure write full GRU vector --- build/source/driver/summa_defineOutput.f90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/build/source/driver/summa_defineOutput.f90 b/build/source/driver/summa_defineOutput.f90 index d63cf0b21..27092834c 100755 --- a/build/source/driver/summa_defineOutput.f90 +++ b/build/source/driver/summa_defineOutput.f90 @@ -100,11 +100,11 @@ subroutine summa_defineOutputFiles(modelTimeStep, summa1_struc, err, message) ! *** define the name of the model output file ! ***************************************************************************** - ! define full name of output file + ! define full name of output file if(modelTimeStep==1)then select case(newOutputFile) case(noNewFiles); ! do nothing, just ensure validity of outputfile option - case(newFileEveryOct1); + case(newFileEveryOct1); case default; err=20; message=trim(message)//'unable to identify the option to define new output files'; return end select @@ -141,7 +141,7 @@ subroutine summa_defineOutputFiles(modelTimeStep, summa1_struc, err, message) end do ! (looping through HRUs) ! write GRU parameters - call writeParm(integerMissing,bparStruct%gru(iGRU),bpar_meta,err,cmessage) + call writeParm(iGRU,bparStruct%gru(iGRU),bpar_meta,err,cmessage) if(err/=0)then; message=trim(message)//trim(cmessage); return; endif end do ! (looping through GRUs)