diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/GEOS_CatchCNCLM40GridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/GEOS_CatchCNCLM40GridComp.F90 index e10549d73..c05e39388 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/GEOS_CatchCNCLM40GridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/GEOS_CatchCNCLM40GridComp.F90 @@ -36,8 +36,11 @@ module GEOS_CatchCNCLM40GridCompMod use CATCHMENT_CN_MODEL use compute_rc_mod use CN_DriverMod - USE STIEGLITZSNOW, ONLY : & - snow_albedo, StieglitzSnow_calc_tpsnow, N_CONSTIT, & + + USE STIEGLITZSNOW, ONLY : & + StieglitzSnow_snow_albedo, & + StieglitzSnow_calc_tpsnow, & + N_CONSTIT, & NUM_DUDP, NUM_DUSV, NUM_DUWT, NUM_DUSD, & NUM_BCDP, NUM_BCSV, NUM_BCWT, NUM_BCSD, & NUM_OCDP, NUM_OCSV, NUM_OCWT, NUM_OCSD, & @@ -48,10 +51,10 @@ module GEOS_CatchCNCLM40GridCompMod USE CATCH_CONSTANTS, ONLY : & N_GT => CATCH_N_GT, & N_SNOW => CATCH_N_SNOW, & - RHOFS => CATCH_SNWALB_RHOFS, & - SNWALB_VISMAX => CATCH_SNWALB_VISMAX, & - SNWALB_NIRMAX => CATCH_SNWALB_NIRMAX, & - SLOPE => CATCH_SNWALB_SLOPE, & + RHOFS => CATCH_SNOW_RHOFS, & + SNWALB_VISMAX => CATCH_SNOW_VISMAX, & + SNWALB_NIRMAX => CATCH_SNOW_NIRMAX, & + SLOPE => CATCH_SNOW_SLOPE, & PEATCLSM_POROS_THRESHOLD USE clm_varpar, ONLY : & @@ -2276,6 +2279,33 @@ subroutine SetServices ( GC, RC ) RC=STATUS ) VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'snow_frozen_fraction_layer_1' ,& + UNITS = '1' ,& + SHORT_NAME = 'FICE1' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'snow_frozen_fraction_layer_2' ,& + UNITS = '1' ,& + SHORT_NAME = 'FICE2' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'snow_frozen_fraction_layer_3' ,& + UNITS = '1' ,& + SHORT_NAME = 'FICE3' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & LONG_NAME = 'surface_emitted_longwave_flux',& UNITS = 'W m-2' ,& @@ -4700,6 +4730,9 @@ subroutine Driver ( RC ) real, dimension(:), pointer :: bflow real, dimension(:), pointer :: runsurf real, dimension(:), pointer :: smelt + real, dimension(:), pointer :: fice1 + real, dimension(:), pointer :: fice2 + real, dimension(:), pointer :: fice3 real, dimension(:), pointer :: accum real, dimension(:), pointer :: hlwup real, dimension(:), pointer :: swndsrf @@ -4876,7 +4909,7 @@ subroutine Driver ( RC ) real,pointer,dimension(:) :: ALWX, BLWX real,pointer,dimension(:) :: LHACC, SUMEV real,pointer,dimension(:) :: fveg1, fveg2 - real,pointer,dimension(:) :: FICE1 + real,pointer,dimension(:) :: FICE1TMP real,pointer,dimension(:) :: SLDTOT ! real*8,pointer,dimension(:) :: fsum @@ -4885,6 +4918,7 @@ subroutine Driver ( RC ) real,pointer,dimension(:,:) :: wesnn real,pointer,dimension(:,:) :: htsnnn real,pointer,dimension(:,:) :: sndzn + real,pointer,dimension(:,:) :: ficesout real,pointer,dimension(:,:) :: shsbt real,pointer,dimension(:,:) :: dshsbt real,pointer,dimension(:,:) :: evsbt @@ -5347,6 +5381,9 @@ subroutine Driver ( RC ) call MAPL_GetPointer(EXPORT,BFLOW, 'BASEFLOW',ALLOC=.true.,RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT,RUNSURF,'RUNSURF',ALLOC=.true.,RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT,SMELT, 'SMELT' ,ALLOC=.true.,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,FICE1, 'FICE1' ,ALLOC=.true.,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,FICE2, 'FICE2' ,ALLOC=.true.,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,FICE3, 'FICE3' ,ALLOC=.true.,RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT,HLWUP, 'HLWUP' ,ALLOC=.true.,RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT,SWNDSRF,'SWNDSRF',ALLOC=.true.,RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT,LWNDSRF,'LWNDSRF',ALLOC=.true.,RC=STATUS); VERIFY_(STATUS) @@ -5629,10 +5666,12 @@ subroutine Driver ( RC ) ! ALLOCATE LOCAL POINTERS ! -------------------------------------------------------------------------- - allocate(GHTCNT (6,NTILES)) - allocate(WESNN (3,NTILES)) - allocate(HTSNNN (3,NTILES)) - allocate(SNDZN (3,NTILES)) + allocate(GHTCNT (N_GT, NTILES)) + allocate(WESNN (N_SNOW,NTILES)) + allocate(HTSNNN (N_SNOW,NTILES)) + allocate(SNDZN (N_SNOW,NTILES)) + allocate(FICESOUT(N_SNOW,NTILES)) + allocate(TILEZERO (NTILES)) allocate(DZSF (NTILES)) allocate(SWNETFREE(NTILES)) @@ -5697,8 +5736,8 @@ subroutine Driver ( RC ) allocate(SUMEV (NTILES)) allocate(fveg1 (NTILES)) allocate(fveg2 (NTILES)) - allocate(FICE1 (NTILES)) - allocate(SLDTOT (NTILES)) + allocate(FICE1TMP (NTILES)) + allocate(SLDTOT (NTILES)) ! total solid precip allocate(FSW_CHANGE(NTILES)) allocate(SHSBT (NTILES,NUM_SUBTILES)) @@ -6644,10 +6683,10 @@ subroutine Driver ( RC ) ALBVR, ALBNR, ALBVF, ALBNF, MODIS_SCALE=.TRUE. ) ! instantaneous snow-free albedos on tiles - call STIEGLITZSNOW_CALC_TPSNOW(NTILES, HTSNNN(1,:), WESNN(1,:), TPSN1OUT1, FICE1) + call STIEGLITZSNOW_CALC_TPSNOW(NTILES, HTSNNN(1,:), WESNN(1,:), TPSN1OUT1, FICE1TMP ) TPSN1OUT1 = TPSN1OUT1 + Tzero - call SNOW_ALBEDO(NTILES,N_snow, catchcn_internal%N_CONST_LAND4SNWALB, VEG1, LAI1, ZTH, & + call StieglitzSnow_snow_albedo(NTILES,N_snow, catchcn_internal%N_CONST_LAND4SNWALB, VEG1, LAI1, ZTH, & RHOFS, & SNWALB_VISMAX, SNWALB_NIRMAX, SLOPE, & WESNN, HTSNNN, SNDZN, & @@ -6660,7 +6699,7 @@ subroutine Driver ( RC ) ALBVR_tmp, ALBNR_tmp, ALBVF_tmp, ALBNF_tmp, MODIS_SCALE=.TRUE. ) ! instantaneous snow-free albedos on tiles - call SNOW_ALBEDO(NTILES,N_snow, catchcn_internal%N_CONST_LAND4SNWALB, VEG2, LAI2, ZTH, & + call StieglitzSnow_snow_albedo(NTILES,N_snow, catchcn_internal%N_CONST_LAND4SNWALB, VEG2, LAI2, ZTH, & RHOFS, & SNWALB_VISMAX, SNWALB_NIRMAX, SLOPE, & WESNN, HTSNNN, SNDZN, & @@ -7264,7 +7303,7 @@ subroutine Driver ( RC ) TSURF ,& SHSNOW1, AVETSNOW1, WAT10CM1, WATSOI1, ICESOI1 ,& LHSNOW1, LWUPSNOW1, LWDNSNOW1, NETSWSNOW ,& - TCSORIG1, TPSN1IN1, TPSN1OUT1, FSW_CHANGE ,& + TCSORIG1, TPSN1IN1, TPSN1OUT1, FSW_CHANGE, FICESOUT ,& TC1_0=TC1_0, TC2_0=TC2_0, TC4_0=TC4_0 ,& QA1_0=QA1_0, QA2_0=QA2_0, QA4_0=QA4_0 ,& RCONSTIT=RCONSTIT, RMELT=RMELT, TOTDEPOS=TOTDEPOS, LHACC=LHACC) @@ -7326,10 +7365,10 @@ subroutine Driver ( RC ) ALBVR, ALBNR, ALBVF, ALBNF, MODIS_SCALE=.TRUE. ) ! instantaneous snow-free albedos on tiles - call STIEGLITZSNOW_CALC_TPSNOW(NTILES, HTSNNN(1,:), WESNN(1,:), TPSN1OUT1, FICE1) + call STIEGLITZSNOW_CALC_TPSNOW(NTILES, HTSNNN(1,:), WESNN(1,:), TPSN1OUT1, FICE1TMP ) TPSN1OUT1 = TPSN1OUT1 + Tzero - call SNOW_ALBEDO(NTILES,N_snow, catchcn_internal%N_CONST_LAND4SNWALB, VEG1, LAI1, ZTH, & + call StieglitzSnow_snow_albedo(NTILES,N_snow, catchcn_internal%N_CONST_LAND4SNWALB, VEG1, LAI1, ZTH, & RHOFS, & SNWALB_VISMAX, SNWALB_NIRMAX, SLOPE, & WESNN, HTSNNN, SNDZN, & @@ -7342,7 +7381,7 @@ subroutine Driver ( RC ) ALBVR_tmp, ALBNR_tmp, ALBVF_tmp, ALBNF_tmp, MODIS_SCALE=.TRUE. ) ! instantaneous snow-free albedos on tiles - call SNOW_ALBEDO(NTILES,N_snow, catchcn_internal%N_CONST_LAND4SNWALB, VEG2, LAI2, ZTH, & + call StieglitzSnow_snow_albedo(NTILES,N_snow, catchcn_internal%N_CONST_LAND4SNWALB, VEG2, LAI2, ZTH, & RHOFS, & SNWALB_VISMAX, SNWALB_NIRMAX, SLOPE, & WESNN, HTSNNN, SNDZN, & @@ -7476,6 +7515,10 @@ subroutine Driver ( RC ) if(associated(SNOMAS)) SNOMAS = WESNN (1,:) + WESNN (2,:) + WESNN (3,:) if(associated(SNOWDP)) SNOWDP = SNDZN (1,:) + SNDZN (2,:) + SNDZN (3,:) + if(associated(FICE1 )) FICE1 = max( min( FICESOUT(1,:),1.0 ), 0.0 ) + if(associated(FICE2 )) FICE2 = max( min( FICESOUT(2,:),1.0 ), 0.0 ) + if(associated(FICE3 )) FICE3 = max( min( FICESOUT(3,:),1.0 ), 0.0 ) + if(associated(RMELTDU001)) RMELTDU001 = RMELT(:,1) if(associated(RMELTDU002)) RMELTDU002 = RMELT(:,2) if(associated(RMELTDU003)) RMELTDU003 = RMELT(:,3) @@ -7591,6 +7634,7 @@ subroutine Driver ( RC ) deallocate(WESNN ) deallocate(HTSNNN ) deallocate(SNDZN ) + deallocate(FICESOUT ) deallocate(TILEZERO ) deallocate(DZSF ) deallocate(SWNETFREE) @@ -7679,7 +7723,7 @@ subroutine Driver ( RC ) deallocate(RCONSTIT ) deallocate(TOTDEPOS ) deallocate(RMELT ) - deallocate(FICE1 ) + deallocate(FICE1TMP ) deallocate(SLDTOT ) deallocate(FSW_CHANGE) deallocate( btran ) @@ -8147,7 +8191,7 @@ subroutine RUN0(gc, import, export, clock, rc) wesnn(1,:) = wesnn1 wesnn(2,:) = wesnn2 wesnn(3,:) = wesnn3 - call StieglitzSnow_calc_asnow(3, ntiles, wesnn, asnow) + call StieglitzSnow_calc_asnow(N_snow, ntiles, wesnn, asnow) EMIS = fveg1*(EMSVEG(NINT(VEG1)) + (EMSBARESOIL - EMSVEG(NINT(VEG1)))*exp(-LAI1)) + & fveg2*(EMSVEG(NINT(VEG2)) + (EMSBARESOIL - EMSVEG(NINT(VEG2)))*exp(-LAI2)) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/GEOS_CatchCNCLM45GridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/GEOS_CatchCNCLM45GridComp.F90 index 5d7b65223..ed3924a33 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/GEOS_CatchCNCLM45GridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/GEOS_CatchCNCLM45GridComp.F90 @@ -36,8 +36,10 @@ module GEOS_CatchCNCLM45GridCompMod use CATCHMENT_CN_MODEL use compute_rc_mod use CN_DriverMod - USE STIEGLITZSNOW, ONLY : & - snow_albedo, StieglitzSnow_calc_tpsnow, N_CONSTIT, & + USE STIEGLITZSNOW, ONLY : & + StieglitzSnow_snow_albedo, & + StieglitzSnow_calc_tpsnow, & + N_CONSTIT, & NUM_DUDP, NUM_DUSV, NUM_DUWT, NUM_DUSD, & NUM_BCDP, NUM_BCSV, NUM_BCWT, NUM_BCSD, & NUM_OCDP, NUM_OCSV, NUM_OCWT, NUM_OCSD, & @@ -48,10 +50,10 @@ module GEOS_CatchCNCLM45GridCompMod USE CATCH_CONSTANTS, ONLY : & N_GT => CATCH_N_GT, & N_SNOW => CATCH_N_SNOW, & - RHOFS => CATCH_SNWALB_RHOFS, & - SNWALB_VISMAX => CATCH_SNWALB_VISMAX, & - SNWALB_NIRMAX => CATCH_SNWALB_NIRMAX, & - SLOPE => CATCH_SNWALB_SLOPE, & + RHOFS => CATCH_SNOW_RHOFS, & + SNWALB_VISMAX => CATCH_SNOW_VISMAX, & + SNWALB_NIRMAX => CATCH_SNOW_NIRMAX, & + SLOPE => CATCH_SNOW_SLOPE, & PEATCLSM_POROS_THRESHOLD USE clm_varpar, ONLY : & @@ -2212,6 +2214,33 @@ subroutine SetServices ( GC, RC ) RC=STATUS ) VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'snow_frozen_fraction_layer_1' ,& + UNITS = '1' ,& + SHORT_NAME = 'FICE1' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'snow_frozen_fraction_layer_2' ,& + UNITS = '1' ,& + SHORT_NAME = 'FICE2' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'snow_frozen_fraction_layer_3' ,& + UNITS = '1' ,& + SHORT_NAME = 'FICE3' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & LONG_NAME = 'surface_emitted_longwave_flux',& UNITS = 'W m-2' ,& @@ -4681,6 +4710,9 @@ subroutine Driver ( RC ) real, dimension(:), pointer :: bflow real, dimension(:), pointer :: runsurf real, dimension(:), pointer :: smelt + real, dimension(:), pointer :: fice1 + real, dimension(:), pointer :: fice2 + real, dimension(:), pointer :: fice3 real, dimension(:), pointer :: accum real, dimension(:), pointer :: hlwup real, dimension(:), pointer :: swndsrf @@ -4860,7 +4892,7 @@ subroutine Driver ( RC ) real,pointer,dimension(:) :: ALWX, BLWX real,pointer,dimension(:) :: LHACC, SUMEV real,pointer,dimension(:) :: fveg1, fveg2 - real,pointer,dimension(:) :: FICE1 + real,pointer,dimension(:) :: FICE1TMP real,pointer,dimension(:) :: SLDTOT ! real*8,pointer,dimension(:) :: fsum @@ -4869,6 +4901,7 @@ subroutine Driver ( RC ) real,pointer,dimension(:,:) :: wesnn real,pointer,dimension(:,:) :: htsnnn real,pointer,dimension(:,:) :: sndzn + real,pointer,dimension(:,:) :: ficesout real,pointer,dimension(:,:) :: shsbt real,pointer,dimension(:,:) :: dshsbt real,pointer,dimension(:,:) :: evsbt @@ -5383,6 +5416,9 @@ subroutine Driver ( RC ) call MAPL_GetPointer(EXPORT,EVPSNO , 'EVPSNO' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT,BFLOW , 'BASEFLOW',ALLOC=.true., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT,SMELT , 'SMELT' ,ALLOC=.true., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,FICE1 , 'FICE1' ,ALLOC=.true., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,FICE2 , 'FICE2' ,ALLOC=.true., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,FICE3 , 'FICE3' ,ALLOC=.true., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT,HLWUP , 'HLWUP' ,ALLOC=.true., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT,SWNDSRF , 'SWNDSRF',ALLOC=.true., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT,LWNDSRF , 'LWNDSRF',ALLOC=.true., RC=STATUS); VERIFY_(STATUS) @@ -5659,10 +5695,12 @@ subroutine Driver ( RC ) ! ALLOCATE LOCAL POINTERS ! -------------------------------------------------------------------------- - allocate(GHTCNT (6,NTILES)) - allocate(WESNN (3,NTILES)) - allocate(HTSNNN (3,NTILES)) - allocate(SNDZN (3,NTILES)) + allocate(GHTCNT (N_GT, NTILES)) + allocate(WESNN (N_SNOW,NTILES)) + allocate(HTSNNN (N_SNOW,NTILES)) + allocate(SNDZN (N_SNOW,NTILES)) + allocate(FICESOUT(N_SNOW,NTILES)) + allocate(TILEZERO (NTILES)) allocate(DZSF (NTILES)) allocate(SWNETFREE(NTILES)) @@ -5727,8 +5765,8 @@ subroutine Driver ( RC ) allocate(SUMEV (NTILES)) allocate(fveg1 (NTILES)) allocate(fveg2 (NTILES)) - allocate(FICE1 (NTILES)) - allocate(SLDTOT (NTILES)) + allocate(FICE1TMP (NTILES)) + allocate(SLDTOT (NTILES)) ! total solid precip allocate(FSW_CHANGE(NTILES)) allocate(SHSBT (NTILES,NUM_SUBTILES)) @@ -6749,7 +6787,7 @@ subroutine Driver ( RC ) BGALBVR, BGALBVF, BGALBNR, BGALBNF, & ! gkw: MODIS soil background albedo ALBVR, ALBNR, ALBVF, ALBNF, MODIS_SCALE=.TRUE. ) ! instantaneous snow-free albedos on tiles - call SNOW_ALBEDO(ntiles, N_snow, catchcn_internal%N_CONST_LAND4SNWALB, ityp_tmp, & + call StieglitzSnow_snow_albedo(ntiles, N_snow, catchcn_internal%N_CONST_LAND4SNWALB, ityp_tmp, & elaz(:,nv), ZTH, & RHOFS, & SNWALB_VISMAX, SNWALB_NIRMAX, SLOPE, & @@ -6827,10 +6865,10 @@ subroutine Driver ( RC ) ALBVR, ALBNR, ALBVF, ALBNF, MODIS_SCALE=.TRUE. ) ! instantaneous snow-free albedos on tiles - call STIEGLITZSNOW_CALC_TPSNOW(NTILES, HTSNNN(1,:), WESNN(1,:), TPSN1OUT1, FICE1) + call STIEGLITZSNOW_CALC_TPSNOW(NTILES, HTSNNN(1,:), WESNN(1,:), TPSN1OUT1, FICE1TMP ) TPSN1OUT1 = TPSN1OUT1 + Tzero - call SNOW_ALBEDO(NTILES,N_snow, catchcn_internal%N_CONST_LAND4SNWALB, VEG1, LAI1, ZTH, & + call StieglitzSnow_snow_albedo(NTILES,N_snow, catchcn_internal%N_CONST_LAND4SNWALB, VEG1, LAI1, ZTH, & RHOFS, & SNWALB_VISMAX, SNWALB_NIRMAX, SLOPE, & WESNN, HTSNNN, SNDZN, & @@ -6843,7 +6881,7 @@ subroutine Driver ( RC ) ALBVR_tmp, ALBNR_tmp, ALBVF_tmp, ALBNF_tmp, MODIS_SCALE=.TRUE. ) ! instantaneous snow-free albedos on tiles - call SNOW_ALBEDO(NTILES,N_snow, catchcn_internal%N_CONST_LAND4SNWALB, VEG2, LAI2, ZTH, & + call StieglitzSnow_snow_albedo(NTILES,N_snow, catchcn_internal%N_CONST_LAND4SNWALB, VEG2, LAI2, ZTH, & RHOFS, & SNWALB_VISMAX, SNWALB_NIRMAX, SLOPE, & WESNN, HTSNNN, SNDZN, & @@ -7545,7 +7583,7 @@ subroutine Driver ( RC ) TSURF ,& SHSNOW1, AVETSNOW1, WAT10CM1, WATSOI1, ICESOI1 ,& LHSNOW1, LWUPSNOW1, LWDNSNOW1, NETSWSNOW ,& - TCSORIG1, TPSN1IN1, TPSN1OUT1, FSW_CHANGE ,& + TCSORIG1, TPSN1IN1, TPSN1OUT1, FSW_CHANGE, FICESOUT ,& TC1_0=TC1_0, TC2_0=TC2_0, TC4_0=TC4_0 ,& QA1_0=QA1_0, QA2_0=QA2_0, QA4_0=QA4_0 ,& RCONSTIT=RCONSTIT, RMELT=RMELT, TOTDEPOS=TOTDEPOS, LHACC=LHACC) @@ -7607,10 +7645,10 @@ subroutine Driver ( RC ) ALBVR, ALBNR, ALBVF, ALBNF, MODIS_SCALE=.TRUE. ) ! instantaneous snow-free albedos on tiles - call STIEGLITZSNOW_CALC_TPSNOW(NTILES, HTSNNN(1,:), WESNN(1,:), TPSN1OUT1, FICE1) + call STIEGLITZSNOW_CALC_TPSNOW(NTILES, HTSNNN(1,:), WESNN(1,:), TPSN1OUT1, FICE1TMP ) TPSN1OUT1 = TPSN1OUT1 + Tzero - call SNOW_ALBEDO(NTILES,N_snow, catchcn_internal%N_CONST_LAND4SNWALB, VEG1, LAI1, ZTH, & + call StieglitzSnow_snow_albedo(NTILES,N_snow, catchcn_internal%N_CONST_LAND4SNWALB, VEG1, LAI1, ZTH, & RHOFS, & SNWALB_VISMAX, SNWALB_NIRMAX, SLOPE, & WESNN, HTSNNN, SNDZN, & @@ -7623,7 +7661,7 @@ subroutine Driver ( RC ) ALBVR_tmp, ALBNR_tmp, ALBVF_tmp, ALBNF_tmp, MODIS_SCALE=.TRUE. ) ! instantaneous snow-free albedos on tiles - call SNOW_ALBEDO(NTILES,N_snow, catchcn_internal%N_CONST_LAND4SNWALB, VEG2, LAI2, ZTH, & + call StieglitzSnow_snow_albedo(NTILES,N_snow, catchcn_internal%N_CONST_LAND4SNWALB, VEG2, LAI2, ZTH, & RHOFS, & SNWALB_VISMAX, SNWALB_NIRMAX, SLOPE, & WESNN, HTSNNN, SNDZN, & @@ -7758,6 +7796,10 @@ subroutine Driver ( RC ) if(associated(SNOMAS)) SNOMAS = WESNN (1,:) + WESNN (2,:) + WESNN (3,:) if(associated(SNOWDP)) SNOWDP = SNDZN (1,:) + SNDZN (2,:) + SNDZN (3,:) + if(associated(FICE1 )) FICE1 = max( min( FICESOUT(1,:),1.0 ), 0.0 ) + if(associated(FICE2 )) FICE2 = max( min( FICESOUT(2,:),1.0 ), 0.0 ) + if(associated(FICE3 )) FICE3 = max( min( FICESOUT(3,:),1.0 ), 0.0 ) + if(associated(RMELTDU001)) RMELTDU001 = RMELT(:,1) if(associated(RMELTDU002)) RMELTDU002 = RMELT(:,2) if(associated(RMELTDU003)) RMELTDU003 = RMELT(:,3) @@ -7873,6 +7915,7 @@ subroutine Driver ( RC ) deallocate(WESNN ) deallocate(HTSNNN ) deallocate(SNDZN ) + deallocate(FICESOUT ) deallocate(TILEZERO ) deallocate(DZSF ) deallocate(SWNETFREE) @@ -7961,7 +8004,7 @@ subroutine Driver ( RC ) deallocate(RCONSTIT ) deallocate(TOTDEPOS ) deallocate(RMELT ) - deallocate(FICE1 ) + deallocate(FICE1TMP ) deallocate(SLDTOT ) deallocate(FSW_CHANGE) deallocate( btran ) @@ -8473,7 +8516,7 @@ subroutine RUN0(gc, import, export, clock, rc) wesnn(1,:) = wesnn1 wesnn(2,:) = wesnn2 wesnn(3,:) = wesnn3 - call StieglitzSnow_calc_asnow(3, ntiles, wesnn, asnow) + call StieglitzSnow_calc_asnow(N_snow, ntiles, wesnn, asnow) EMIS = fveg1*(EMSVEG(NINT(VEG1)) + (EMSBARESOIL - EMSVEG(NINT(VEG1)))*exp(-LAI1)) + & fveg2*(EMSVEG(NINT(VEG2)) + (EMSBARESOIL - EMSVEG(NINT(VEG2)))*exp(-LAI2)) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/Shared/catchmentCN.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/Shared/catchmentCN.F90 index c82dc50a8..eea40eb69 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/Shared/catchmentCN.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/Shared/catchmentCN.F90 @@ -79,13 +79,9 @@ MODULE CATCHMENT_CN_MODEL USE CATCH_CONSTANTS, ONLY: & N_SNOW => CATCH_N_SNOW, & N_GT => CATCH_N_GT, & - RHOFS => CATCH_SNWALB_RHOFS, & - SNWALB_VISMAX => CATCH_SNWALB_VISMAX, & - SNWALB_NIRMAX => CATCH_SNWALB_NIRMAX, & - SLOPE => CATCH_SNWALB_SLOPE, & - MAXSNDEPTH => CATCH_MAXSNDEPTH, & - DZ1MAX => CATCH_DZ1MAX, & - SCONST => CATCH_SCONST, & + CATCH_SNOW_RHOFS, & + CATCH_SNOW_MAXDEPTH, & + CATCH_SNOW_DZPARAM, & C_CANOP => CATCH_C_CANOP, & N_sm => CATCH_N_ZONES, & SATCAPFR => CATCH_SATCAPFR, & @@ -109,16 +105,17 @@ MODULE CATCHMENT_CN_MODEL USE SIBALB_COEFF, ONLY: coeffsib USE STIEGLITZSNOW, ONLY: & - snowrt, StieglitzSnow_calc_asnow, StieglitzSnow_calc_tpsnow, get_tf0d, N_constit + StieglitzSnow_snowrt, & + StieglitzSnow_calc_asnow, & + StieglitzSnow_calc_tpsnow, & + N_constit + IMPLICIT NONE private public :: catchcn - public :: catchcn_calc_tsurf - public :: catchcn_calc_tsurf_excl_snow - public :: catchcn_calc_etotl ! ----------------------------------------------------------------------------- @@ -169,9 +166,9 @@ SUBROUTINE CATCHCN ( & EVACC, SHACC, TSURF, & SH_SNOW, AVET_SNOW, WAT_10CM, TOTWAT_SOIL, TOTICE_SOIL, & LH_SNOW, LWUP_SNOW, LWDOWN_SNOW, NETSW_SNOW, & - TCSORIG, TPSN1IN, TPSN1OUT,FSW_CHANGE, & - TC1_0, TC2_0, TC4_0, QA1_0, QA2_0, QA4_0, EACC_0, & - RCONSTIT, RMELT, TOTDEPOS, LHACC & + TCSORIG, TPSN1IN, TPSN1OUT, FSW_CHANGE, FICESOUT, & + TC1_0, TC2_0, TC4_0, QA1_0, QA2_0, QA4_0, EACC_0, & ! OPTIONAL + RCONSTIT, RMELT, TOTDEPOS, LHACC & ! OPTIONAL ) IMPLICIT NONE @@ -238,6 +235,7 @@ SUBROUTINE CATCHCN ( & REAL, INTENT(OUT), DIMENSION(:) :: TCSORIG, TPSN1IN, TPSN1OUT, & FSW_CHANGE + REAL, INTENT(OUT), DIMENSION(:, :) :: FICESOUT REAL, INTENT(OUT), DIMENSION(:), OPTIONAL :: LHACC @@ -251,30 +249,30 @@ SUBROUTINE CATCHCN ( & INTEGER I,K,N,LAYER - REAL, DIMENSION(NCH) :: CSOIL, CCANOP, ASNOW, traincx, trainlx, & - RC, SATCAP, SNWFRC, POTFRC, ESNFRC, EVSNOW, SHFLUXS, HLWUPS, & - HFTDS1, HFTDS2, HFTDS4, DHFT1, DHFT2, DHFT4, TPSNB, & - QSATTC, DQSDTC, SWSRF1, SWSRF2, SWSRF4, AR4, & - FCAN, THRUL_VOL, THRUC_VOL, RZEQOL, frice, srfmx, & - srfmn, RCST1, RCST2, EVAPFR, RDCX, EVAP1, EVAP2, & - EVAP4, SHFLUX1, SHFLUX2, SHFLUX4, HLWUP1, HLWUP2, HLWUP4, & - GHFLUX1, GHFLUX2, GHFLUX4, RZI, TC1SF, TC2SF, TC4SF, ar1old, & - ar2old, ar4old, GHFLUXS, DEDQA1X, DEDTC1X, & - DHSDQA1X, DHSDTC1X, DEDQA2X, DEDTC2X, DHSDQA2X, DHSDTC2X, & - DEDQA4X, DEDTC4X, DHSDQA4X, DHSDTC4X, werror, sfmcun, rzmcun, & - prmcun,WTOT_ORIG,ENTOT_ORIG, & - TC1_00, TC2_00, TC4_00, EACC_00, & - qa1_orig,qa2_orig,qa4_orig,tc1_orig,tc2_orig,tc4_orig, & - tgs_orig,TG1SF,TG2SF,TG4SF,RCUN1,RCUN2, & - tg1_orig,tg2_orig,tg4_orig, & - EVROOT1, EVROOT2, EVROOT4, EVSURF1, EVSURF2, EVSURF4, & - EVINT1, EVINT2, EVINT4, ESATFR, ECORR, DRCST1DT, DRCST1DQ, & + REAL, DIMENSION(NCH) :: CSOIL, CCANOP, ASNOW, traincx, trainlx, & + RC, SATCAP, SNWFRC, POTFRC, ESNFRC, EVSNOW, SHFLUXS, HLWUPS, & + HFTDS1, HFTDS2, HFTDS4, DHFT1, DHFT2, DHFT4, TPSNB, & + QSATTC, DQSDTC, SWSRF1, SWSRF2, SWSRF4, AR4, & + FCAN, THRUL_VOL, THRUC_VOL, RZEQOL, frice, srfmx, & + srfmn, RCST1, RCST2, EVAPFR, RDCX, EVAP1, EVAP2, & + EVAP4, SHFLUX1, SHFLUX2, SHFLUX4, HLWUP1, HLWUP2, HLWUP4, & + GHFLUX1, GHFLUX2, GHFLUX4, RZI, TC1SF, TC2SF, TC4SF, ar1old, & + ar2old, ar4old, GHFLUXS, DEDQA1X, DEDTC1X, & + DHSDQA1X, DHSDTC1X, DEDQA2X, DEDTC2X, DHSDQA2X, DHSDTC2X, & + DEDQA4X, DEDTC4X, DHSDQA4X, DHSDTC4X, werror, sfmcun, rzmcun, & + prmcun,WTOT_ORIG,ENTOT_ORIG, & + TC1_00, TC2_00, TC4_00, EACC_00, & + qa1_orig,qa2_orig,qa4_orig,tc1_orig,tc2_orig,tc4_orig, & + tgs_orig,TG1SF,TG2SF,TG4SF,RCUN1,RCUN2, & + tg1_orig,tg2_orig,tg4_orig, & + EVROOT1, EVROOT2, EVROOT4, EVSURF1, EVSURF2, EVSURF4, & + EVINT1, EVINT2, EVINT4, ESATFR, ECORR, DRCST1DT, DRCST1DQ, & DRCST2DT, DRCST2DQ, FVEG, RD, RCST, DRCSTDT, DRCSTDQ, RSURF REAL, DIMENSION(N_gt) :: HT, TP, soilice - REAL, DIMENSION(N_SNOW) :: TPSN, WESN, HTSNN, SNDZ, fices, targetthick, & + REAL, DIMENSION(N_SNOW) :: TPSN, WESN, HTSNN, SNDZ, fices, & wesnperc,wesndens,wesnrepar,excs,drho0,tksno, tmpvec_Nsnow REAL, DIMENSION(N_SNOW, N_Constit) :: RCONSTIT1 @@ -293,7 +291,7 @@ SUBROUTINE CATCHCN ( & QA1X, QA2X, QA4X, TC1X, TC2X, TC4X, TCSX, & EVAPX1,EVAPX2,EVAPX4,SHFLUXX1,SHFLUXX2,SHFLUXX4,EVEGFRC, & EVAPXS,SHFLUXXS,DTC1SN,DTC2SN,DTC4SN,TCANOP, & - ZLAI0, phi,rho_fs,WSS,sumdepth, & + ZLAI0, phi,rho_fs,sumdepth, & sndzsc, wesnprec, sndzprec, sndz1perc, & mltwtr, wesnbot, dtss @@ -577,36 +575,36 @@ SUBROUTINE CATCHCN ( & RUNSRF(N)=0. -!**** RESET LAND ICE VARIABLES, MAINTAINING TEMPS. AT EACH LAYER - IF(ITYP1(N) .EQ. 9) THEN - - ! This block of the code should no longer be used. - ! If it is, Randy wants to know about it. - ! reichle+koster, 12 Aug 2014 - write (*,*) 'catchment() encountered ityp==9. STOPPING.' - stop - - if(sum(htsnnn(:,n)+wesnn(:,n))==0.) then - TSN1=tc1(n)-TF - TSN2=tc1(n)-TF - TSN3=tc1(n)-TF - else - TSN1=(HTSNNN(1,N)+WESNN(1,N)*ALHM)/(SCONST*WESNN(1,N)+1.e-5) - TSN2=(HTSNNN(2,N)+WESNN(2,N)*ALHM)/(SCONST*WESNN(2,N)+1.e-5) - TSN3=(HTSNNN(3,N)+WESNN(3,N)*ALHM)/(SCONST*WESNN(3,N)+1.e-5) - endif - WESNN(1,N)=.1 - WESNN(2,N)=.2 - WESNN(3,N)=.1 - HTSNNN(1,N)=-ALHM*WESNN(1,N)+TSN1*SCONST*WESNN(1,N) - HTSNNN(2,N)=-ALHM*WESNN(2,N)+TSN1*SCONST*WESNN(2,N) - HTSNNN(3,N)=-ALHM*WESNN(3,N)+TSN1*SCONST*WESNN(3,N) - SNDZN(1,N)=WESNN(1,N)/.9 - SNDZN(2,N)=WESNN(2,N)/.9 - SNDZN(3,N)=WESNN(3,N)/.9 - POTFRC(N)=1. - - ENDIF +!! !**** RESET LAND ICE VARIABLES, MAINTAINING TEMPS. AT EACH LAYER +!! IF(ITYP1(N) .EQ. 9) THEN +!! +!! ! This block of the code should no longer be used. +!! ! If it is, Randy wants to know about it. +!! ! reichle+koster, 12 Aug 2014 +!! write (*,*) 'catchment() encountered ityp==9. STOPPING.' +!! stop +!! +!! if(sum(htsnnn(:,n)+wesnn(:,n))==0.) then +!! TSN1=tc1(n)-TF +!! TSN2=tc1(n)-TF +!! TSN3=tc1(n)-TF +!! else +!! TSN1=(HTSNNN(1,N)+WESNN(1,N)*ALHM)/(SCONST*WESNN(1,N)+1.e-5) +!! TSN2=(HTSNNN(2,N)+WESNN(2,N)*ALHM)/(SCONST*WESNN(2,N)+1.e-5) +!! TSN3=(HTSNNN(3,N)+WESNN(3,N)*ALHM)/(SCONST*WESNN(3,N)+1.e-5) +!! endif +!! WESNN(1,N)=.1 +!! WESNN(2,N)=.2 +!! WESNN(3,N)=.1 +!! HTSNNN(1,N)=-ALHM*WESNN(1,N)+TSN1*SCONST*WESNN(1,N) +!! HTSNNN(2,N)=-ALHM*WESNN(2,N)+TSN1*SCONST*WESNN(2,N) +!! HTSNNN(3,N)=-ALHM*WESNN(3,N)+TSN1*SCONST*WESNN(3,N) +!! SNDZN(1,N)=WESNN(1,N)/.9 +!! SNDZN(2,N)=WESNN(2,N)/.9 +!! SNDZN(3,N)=WESNN(3,N)/.9 +!! POTFRC(N)=1. +!! +!! ENDIF !**** RESET LAKE VARIABLES IF(ITYP1(N) .EQ. 10) THEN @@ -794,7 +792,6 @@ SUBROUTINE CATCHCN ( & DO N=1,NCH - WSS = UM(N) TS = TM(N) T1(1) = TG1(N)-TF T1(2) = TG2(N)-TF @@ -853,7 +850,7 @@ SUBROUTINE CATCHCN ( & ! in process ! reichle, 29 May 03 - call get_tf0d(htsnn(1),wesn(1),tsnowsrf,dum,ldum,ldum) + call StieglitzSnow_calc_tpsnow(htsnn(1),wesn(1),tsnowsrf,dum,ldum,ldum,.true.) tgs_orig(n)=tsnowsrf+tf if(wesn(1)+wesn(2)+wesn(3) .eq. 0.) tgs_orig(n)= & amin1( tf, tg1_orig(n)*ar1(n)+tg2_orig(n)*ar2(n)+ & @@ -873,30 +870,29 @@ SUBROUTINE CATCHCN ( & tpsn1in(n) = tpsn1(n) ! tpsn1 is "intent(out)", should NOT be used here, use catch_calc_tpsnow instead? shouldn't this be the same as tgs_orig? - reichle, 8/8/2014 sumdepth=sum(sndz) - targetthick(1)=dz1max - - do i=2,N_snow - targetthick(i)=1./(N_snow-1.) - enddo - - CALL SNOWRT( & - N_sm, N_snow, MAPL_Land, & - t1,area,tkgnd,pr,snowf,ts,DTSTEP, & - eturbs(n),dedtc0,hsturb,dhsdtc0,hlwtc,dhlwtc, & - desdtc,hups,raddn,zc1, totdep1, wss, & - wesn,htsnn,sndz, fices,tpsn,RCONSTIT1, RMELT1, & - areasc,areasc0,pre,fhgnd, & - EVSN,SHFLS,alhfsn,hcorr, ghfluxsno(n), & - sndzsc, wesnprec, sndzprec, sndz1perc, & - wesnperc, wesndens, wesnrepar, mltwtr, & - excs, drho0, wesnbot, tksno, dtss, & - maxsndepth, rhofs, targetthick ) - - LH_SNOW(N)=areasc*EVSN*ALHS - SH_SNOW(N)=areasc*SHFLS - LWUP_SNOW(N)=areasc*HUPS - LWDOWN_SNOW(N)=areasc*HLWDWN(N) - NETSW_SNOW(N)=areasc*SWNETS(N) + + CALL StieglitzSnow_snowrt( & + N_sm, N_snow, MAPL_Land, & ! in + CATCH_SNOW_MAXDEPTH, CATCH_SNOW_RHOFS, CATCH_SNOW_DZPARAM, & ! in + t1, area, tkgnd, pr, snowf, ts, DTSTEP, & ! in + eturbs(n), dedtc0, hsturb, dhsdtc0, hlwtc, dhlwtc, & ! in + raddn, zc1, totdep1, & ! in + wesn, htsnn, sndz, RCONSTIT1, & ! inout + hups, fices, tpsn, RMELT1, & ! out + areasc, areasc0, pre, fhgnd, & ! out + EVSN, SHFLS, alhfsn, hcorr, ghfluxsno(n), & ! out + sndzsc, wesnprec, sndzprec, sndz1perc, & ! out + wesnperc, wesndens, wesnrepar, mltwtr, & ! out + excs, drho0, wesnbot, tksno, dtss ) ! out + + + FICESOUT(:,N) = fices + + LH_SNOW(N) = areasc*EVSN*ALHS + SH_SNOW(N) = areasc*SHFLS + LWUP_SNOW(N) = areasc*HUPS + LWDOWN_SNOW(N) = areasc*HLWDWN(N) + NETSW_SNOW(N) = areasc*SWNETS(N) TPSN1(N) = TPSN(1)+TF @@ -1465,19 +1461,19 @@ SUBROUTINE CATCHCN ( & SHACC(N)=SHFLUX(N)-SHACC(N) - - - ! **** SPECIAL DIAGNOSTICS FOR AR5 DECADAL RUNS - CALL STIEGLITZSNOW_CALC_TPSNOW(N_SNOW, HTSNNN(:,N), WESNN(:,N), TPSN, FICES) - - !AVET_SNOW(N)=(TPSN(1)+TF)*WESNN(1,N) + (TPSN(2)+TF)*WESNN(2,N) + & - ! (TPSN(3)+TF)*WESNN(3,N) + ! the following assumes that fices is unchanged, otherwise may need to update FICESOUT + ! - reichle, 4 Oct 2023 - tmpvec_Nsnow = (tpsn(1:N_snow)+tf)*wesnn(1:N_snow,N) - - AVET_SNOW(N) = sum(tmpvec_Nsnow(1:N_snow)) + CALL STIEGLITZSNOW_CALC_TPSNOW(N_SNOW, HTSNNN(:,N), WESNN(:,N), TPSN, FICES) + + !AVET_SNOW(N)=(TPSN(1)+TF)*WESNN(1,N) + (TPSN(2)+TF)*WESNN(2,N) + & + ! (TPSN(3)+TF)*WESNN(3,N) + + tmpvec_Nsnow = (tpsn(1:N_snow)+tf)*wesnn(1:N_snow,N) + + AVET_SNOW(N) = sum(tmpvec_Nsnow(1:N_snow)) WAT_10CM(N)=0.1*(RZEQ(N)+RZEXC(N))+SRFEXC(N) @@ -1486,7 +1482,7 @@ SUBROUTINE CATCHCN ( & TOTICE_SOIL(N)=TOTWAT_SOIL(N)*FRICE(N) - ENDDO + ENDDO ! N=1,NCH (PROCESS DATA AS NECESSARY PRIOR TO RETURN) if(numout.ne.0) then do i = 1,numout @@ -2323,186 +2319,7 @@ SUBROUTINE RSURFP2 ( & RETURN END SUBROUTINE RSURFP2 -!**** -!**** [ END RSURFP2 ] -!**** - -!**** ----------------------------------------------------------------- -!**** ///////////////////////////////////////////////////////////////// -!**** ----------------------------------------------------------------- - - subroutine catchcn_calc_tsurf( NTILES, tc1, tc2, tc4, wesnn, htsnn, & - ar1, ar2, ar4, tsurf ) - - ! Calculate diagnostic surface temperature "tsurf" from prognostics - ! - ! reichle, Aug 31, 2004 - ! reichle, Jan 4, 2012 - optionally "ignore_snow" - ! reichle, Apr 2, 2012 - revised for use without catch_types structures and - ! to avoid duplicate calls to rzequil() and partition() - ! reichle, Oct 20, 2014 - removed option to "ignore_snow"; - ! use subroutine catch_calc_tsurf_excl_snow() instead - ! - ! ---------------------------------------------------------------- - - implicit none - - integer, intent(in) :: NTILES - real, dimension( NTILES), intent(in) :: tc1, tc2, tc4 - real, dimension(N_snow,NTILES), intent(in) :: wesnn, htsnn - real, dimension( NTILES), intent(in) :: ar1, ar2, ar4 - real, dimension( NTILES), intent(out) :: tsurf - - ! ---------------------------- - ! - ! local variables - - integer :: n - - real, dimension(NTILES) :: asnow - - real, dimension(1) :: tpsn1, real_dummy - - ! ------------------------------------------------------------------ - - ! Compute tsurf excluding snow - - call catchcn_calc_tsurf_excl_snow( NTILES, tc1, tc2, tc4, ar1, ar2, ar4, tsurf ) - - ! Compute snow covered area - - call StieglitzSnow_calc_asnow( N_snow, NTILES, wesnn, asnow ) - - ! Add contribution of snow temperature - - do n=1,NTILES - - if (asnow(n)>0.) then - - ! StieglitzSnow_calc_tpsnow() returns snow temperature in deg Celsius - - call StieglitzSnow_calc_tpsnow( 1, htsnn(1,n), wesnn(1,n), tpsn1, real_dummy ) - - tsurf(n) = (1. - asnow(n))*tsurf(n) + asnow(n)*(tpsn1(1) + TF) - - end if - - end do - - end subroutine catchcn_calc_tsurf - - ! ******************************************************************* - - subroutine catchcn_calc_tsurf_excl_snow( NTILES, tc1, tc2, tc4, ar1, ar2, ar4, & - tsurf_excl_snow ) - - ! Calculate diagnostic surface temperature "tsurf" ignoring snow - ! - ! reichle, 20 Oct 2014 - ! - ! ---------------------------------------------------------------- - - implicit none - - integer, intent(in) :: NTILES - real, dimension( NTILES), intent(in) :: tc1, tc2, tc4 - real, dimension( NTILES), intent(in) :: ar1, ar2, ar4 - real, dimension( NTILES), intent(out) :: tsurf_excl_snow - - ! ------------------------------------------------------------------ - - tsurf_excl_snow = ar1*tc1 + ar2*tc2 + ar4*tc4 - - end subroutine catchcn_calc_tsurf_excl_snow - - - ! ******************************************************************* - - subroutine catchcn_calc_etotl( NTILES, dzsf, vgwmax, cdcr1, cdcr2, & - psis, bee, poros, wpwet,bf1, bf2, & - ars1, ars2, ars3, ara1, ara2, ara3, ara4, arw1, arw2, arw3, arw4, & - srfexc, rzexc, catdef, tc1, tc2, tc4, tg1, tg2, tg4, & - wesnn, htsnn, ghtcnt, & - etotl ) - - ! compute total energy stored in land tiles - ! - ! reichle, 4 Jan 2012 - ! reichle, 2 Apr 2012 - revised for use without catch_types structures - ! - ! ---------------------------------------------------------------- - - implicit none - - integer, intent(in) :: NTILES - - real, dimension( NTILES), intent(in) :: dzsf - real, dimension( NTILES), intent(in) :: vgwmax - real, dimension( NTILES), intent(in) :: cdcr1, cdcr2, bf1, bf2 - real, dimension( NTILES), intent(in) :: psis, bee, poros, wpwet - real, dimension( NTILES), intent(in) :: ars1, ars2, ars3 - real, dimension( NTILES), intent(in) :: ara1, ara2, ara3, ara4 - real, dimension( NTILES), intent(in) :: arw1, arw2, arw3, arw4 - real, dimension( NTILES), intent(in) :: srfexc, rzexc, catdef - real, dimension( NTILES), intent(in) :: tc1, tc2, tc4 - real, dimension( NTILES), intent(in) :: tg1, tg2, tg4 - real, dimension(N_snow,NTILES), intent(in) :: wesnn, htsnn - real, dimension(N_gt ,NTILES), intent(in) :: ghtcnt - - real, dimension( NTILES), intent(out) :: etotl - - ! ---------------------------- - ! - ! local variables - - integer :: n - - real :: tot_htsn, tot_ght, csoil - - real, dimension(NTILES) :: srfexc_tmp, rzexc_tmp, catdef_tmp - - real, dimension(NTILES) :: ar1, ar2, ar4, avg_tc, avg_tg - - ! ---------------------------------------------------------------- - ! - ! diagnose ar1, ar2, ar4 prior to catchcn_calc_tsurf() - - srfexc_tmp = srfexc ! srfexc is "inout" in catch_calc_soil_moist() - rzexc_tmp = rzexc ! rzexc is "inout" in catch_calc_soil_moist() - catdef_tmp = catdef ! catdef is "inout" in catch_calc_soil_moist() - - call catch_calc_soil_moist( & - NTILES, dzsf, vgwmax, cdcr1, cdcr2, psis, bee, poros, wpwet, & - ars1, ars2, ars3, ara1, ara2, ara3, ara4, arw1, arw2, arw3, arw4,bf1, bf2,& - srfexc_tmp, rzexc_tmp, catdef_tmp, ar1, ar2, ar4 ) - - ! compute snow-free tsurf - - call catchcn_calc_tsurf_excl_snow( & - NTILES, tc1, tc2, tc4, ar1, ar2, ar4, avg_tc ) - - ! compute snow-free tg - - call catchcn_calc_tsurf_excl_snow( & - NTILES, tg1, tg2, tg4, ar1, ar2, ar4, avg_tg ) - - do n=1,NTILES - - ! total snow heat content - - tot_htsn = sum( htsnn(1:N_snow,n) ) - - ! total ground heat content - - tot_ght = sum( ghtcnt(1:N_gt,n)) - - ! total energy - - etotl(n) = C_CANOP*avg_tc(n) + CSOIL_2*avg_tg(n) + tot_htsn + tot_ght - - end do - - end subroutine catchcn_calc_etotl - END MODULE CATCHMENT_CN_MODEL + +! ================================== EOF ============================================ diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/GEOS_CatchGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/GEOS_CatchGridComp.F90 index ffb5991eb..1c6a8f66b 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/GEOS_CatchGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/GEOS_CatchGridComp.F90 @@ -27,10 +27,14 @@ module GEOS_CatchGridCompMod use GEOS_Mod use GEOS_UtilsMod use DragCoefficientsMod - use CATCHMENT_MODEL, ONLY : & + + use CATCHMENT_MODEL, ONLY : & catchment - USE STIEGLITZSNOW, ONLY : & - snow_albedo, StieglitzSnow_calc_tpsnow, N_CONSTIT, & + + USE STIEGLITZSNOW, ONLY : & + StieglitzSnow_snow_albedo, & + StieglitzSnow_calc_tpsnow, & + N_CONSTIT, & NUM_DUDP, NUM_DUSV, NUM_DUWT, NUM_DUSD, & NUM_BCDP, NUM_BCSV, NUM_BCWT, NUM_BCSD, & NUM_OCDP, NUM_OCSV, NUM_OCWT, NUM_OCSD, & @@ -38,12 +42,13 @@ module GEOS_CatchGridCompMod NUM_SSDP, NUM_SSSV, NUM_SSWT, NUM_SSSD, & StieglitzSnow_calc_asnow - USE CATCH_CONSTANTS, ONLY : & - N_SNOW => CATCH_N_SNOW, & - RHOFS => CATCH_SNWALB_RHOFS, & - SNWALB_VISMAX => CATCH_SNWALB_VISMAX, & - SNWALB_NIRMAX => CATCH_SNWALB_NIRMAX, & - SLOPE => CATCH_SNWALB_SLOPE, & + USE CATCH_CONSTANTS, ONLY : & + N_SNOW => CATCH_N_SNOW, & + N_GT => CATCH_N_GT, & + RHOFS => CATCH_SNOW_RHOFS, & + SNWALB_VISMAX => CATCH_SNOW_VISMAX, & + SNWALB_NIRMAX => CATCH_SNOW_NIRMAX, & + SLOPE => CATCH_SNOW_SLOPE, & PEATCLSM_POROS_THRESHOLD @@ -1324,8 +1329,8 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) if (CATCH_INTERNAL_STATE%SNOW_ALBEDO_INFO == 1) then - call MAPL_AddInternalSpec(GC ,& - LONG_NAME = 'effective_snow_albedo' ,& + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'effective_snow_albedo' ,& UNITS = '1' ,& SHORT_NAME = 'SNOWALB' ,& FRIENDLYTO = trim(COMP_NAME) ,& @@ -1664,6 +1669,33 @@ subroutine SetServices ( GC, RC ) RC=STATUS ) VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'snow_frozen_fraction_layer_1' ,& + UNITS = '1' ,& + SHORT_NAME = 'FICE1' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'snow_frozen_fraction_layer_2' ,& + UNITS = '1' ,& + SHORT_NAME = 'FICE2' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'snow_frozen_fraction_layer_3' ,& + UNITS = '1' ,& + SHORT_NAME = 'FICE3' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & LONG_NAME = 'surface_emitted_longwave_flux',& UNITS = 'W m-2' ,& @@ -1691,7 +1723,6 @@ subroutine SetServices ( GC, RC ) RC=STATUS ) VERIFY_(STATUS) - call MAPL_AddExportSpec(GC, & LONG_NAME = 'total_latent_energy_flux' ,& UNITS = 'W m-2' ,& @@ -2936,7 +2967,7 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) ! Locals - type(MAPL_MetaComp),pointer :: MAPL + type(MAPL_MetaComp), pointer :: MAPL type(ESMF_State) :: INTERNAL type(ESMF_Alarm) :: ALARM type(ESMF_Config) :: CF @@ -2946,19 +2977,19 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) ! IMPORT Pointers ! ---------------------------------------------------- - - real, dimension(:), pointer :: ITY - real, dimension(:), pointer :: PS - real, dimension(:), pointer :: TA - real, dimension(:), pointer :: QA - real, dimension(:), pointer :: UU - real, pointer, dimension(:) :: UWINDLMTILE - real, pointer, dimension(:) :: VWINDLMTILE - real, dimension(:), pointer :: DZ - real, dimension(:), pointer :: LAI - real, dimension(:), pointer :: Z2CH - real, dimension(:), pointer :: PCU - real, dimension(:), pointer :: ASCATZ0 - real, dimension(:), pointer :: NDVI + real, dimension(:), pointer :: ITY + real, dimension(:), pointer :: PS + real, dimension(:), pointer :: TA + real, dimension(:), pointer :: QA + real, dimension(:), pointer :: UU + real, dimension(:), pointer :: UWINDLMTILE + real, dimension(:), pointer :: VWINDLMTILE + real, dimension(:), pointer :: DZ + real, dimension(:), pointer :: LAI + real, dimension(:), pointer :: Z2CH + real, dimension(:), pointer :: PCU + real, dimension(:), pointer :: ASCATZ0 + real, dimension(:), pointer :: NDVI ! ----------------------------------------------------- ! INTERNAL Pointers @@ -3024,37 +3055,37 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) real, allocatable :: ZQ(:) integer,allocatable :: VEG(:) real, allocatable :: Z0T(:,:) - real, allocatable :: U50M (:) - real, allocatable :: V50M (:) - real, allocatable :: T10M (:) - real, allocatable :: Q10M (:) - real, allocatable :: U10M (:) - real, allocatable :: V10M (:) - real, allocatable :: T2M (:) - real, allocatable :: Q2M (:) - real, allocatable :: U2M (:) - real, allocatable :: V2M (:) - real, allocatable :: RHOH(:) - real, allocatable :: VKH(:) - real, allocatable :: VKM(:) - real, allocatable :: USTAR(:) - real, allocatable :: XX(:) - real, allocatable :: YY(:) - real, allocatable :: CU(:) - real, allocatable :: CT(:) - real, allocatable :: RIB(:) - real, allocatable :: ZETA(:) - real, allocatable :: WS(:) - integer, allocatable :: IWATER(:) - real, allocatable :: PSMB(:) - real, allocatable :: PSL(:) - integer :: niter - - integer :: CHOOSEZ0 - real :: SCALE4Z0 - real :: SCALE4ZVG - real :: SCALE4Z0_u - real :: MIN_VEG_HEIGHT + real, allocatable :: U50M (:) + real, allocatable :: V50M (:) + real, allocatable :: T10M (:) + real, allocatable :: Q10M (:) + real, allocatable :: U10M (:) + real, allocatable :: V10M (:) + real, allocatable :: T2M (:) + real, allocatable :: Q2M (:) + real, allocatable :: U2M (:) + real, allocatable :: V2M (:) + real, allocatable :: RHOH(:) + real, allocatable :: VKH(:) + real, allocatable :: VKM(:) + real, allocatable :: USTAR(:) + real, allocatable :: XX(:) + real, allocatable :: YY(:) + real, allocatable :: CU(:) + real, allocatable :: CT(:) + real, allocatable :: RIB(:) + real, allocatable :: ZETA(:) + real, allocatable :: WS(:) + integer,allocatable :: IWATER(:) + real, allocatable :: PSMB(:) + real, allocatable :: PSL(:) + integer :: niter + + integer :: CHOOSEZ0 + real :: SCALE4Z0 + real :: SCALE4ZVG + real :: SCALE4Z0_u + real :: MIN_VEG_HEIGHT type(CATCH_WRAP) :: wrap type (T_CATCH_STATE), pointer :: CATCH_INTERNAL_STATE @@ -3097,17 +3128,17 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) ! Get parameters from generic state ! --------------------------------- - - call MAPL_Get ( MAPL ,& - INTERNAL_ESMF_STATE=INTERNAL ,& - RC=STATUS ) + + call MAPL_Get ( MAPL , & + INTERNAL_ESMF_STATE=INTERNAL , & + RC=STATUS ) VERIFY_(STATUS) - + call MAPL_GetResource ( MAPL, CHOOSEZ0, Label="CHOOSEZ0:", DEFAULT=3, RC=STATUS) VERIFY_(STATUS) call ESMF_VMGetCurrent(VM, rc=STATUS) VERIFY_(STATUS) - + ! Pointers to inputs !------------------- @@ -3396,7 +3427,7 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) elseif (CATCH_INTERNAL_STATE%CHOOSEMOSFC.eq.1)then - niter = 6 ! number of internal iterations in the helfand MO surface layer routine + niter = 6 ! number of internal iterations in the helfand MO surface layer routine IWATER = 3 PSMB = PS * 0.01 ! convert to MB @@ -3795,6 +3826,9 @@ subroutine Driver ( RC ) real, dimension(:), pointer :: bflow real, dimension(:), pointer :: runsurf real, dimension(:), pointer :: smelt + real, dimension(:), pointer :: fice1 + real, dimension(:), pointer :: fice2 + real, dimension(:), pointer :: fice3 real, dimension(:), pointer :: accum real, dimension(:), pointer :: hlwup real, dimension(:), pointer :: swndsrf @@ -3922,7 +3956,7 @@ subroutine Driver ( RC ) real,pointer,dimension(:) :: VSUVR, VSUVF real,pointer,dimension(:) :: ALWX, BLWX real,pointer,dimension(:) :: LHACC, SUMEV - real,pointer,dimension(:) :: FICE1 + real,pointer,dimension(:) :: FICE1TMP real,pointer,dimension(:) :: SLDTOT ! real*8,pointer,dimension(:) :: fsum @@ -3931,6 +3965,7 @@ subroutine Driver ( RC ) real,pointer,dimension(:,:) :: wesnn real,pointer,dimension(:,:) :: htsnnn real,pointer,dimension(:,:) :: sndzn + real,pointer,dimension(:,:) :: ficesout real,pointer,dimension(:,:) :: shsbt real,pointer,dimension(:,:) :: dshsbt real,pointer,dimension(:,:) :: evsbt @@ -4336,6 +4371,9 @@ subroutine Driver ( RC ) call MAPL_GetPointer(EXPORT,BFLOW, 'BASEFLOW',ALLOC=.true.,RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT,RUNSURF,'RUNSURF',ALLOC=.true.,RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT,SMELT, 'SMELT' ,ALLOC=.true.,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,FICE1, 'FICE1' ,ALLOC=.true.,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,FICE2, 'FICE2' ,ALLOC=.true.,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,FICE3, 'FICE3' ,ALLOC=.true.,RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT,HLWUP, 'HLWUP' ,ALLOC=.true.,RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT,SWNDSRF,'SWNDSRF',ALLOC=.true.,RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT,LWNDSRF,'LWNDSRF',ALLOC=.true.,RC=STATUS); VERIFY_(STATUS) @@ -4428,10 +4466,12 @@ subroutine Driver ( RC ) ! ALLOCATE LOCAL POINTERS ! -------------------------------------------------------------------------- - allocate(GHTCNT (6,NTILES)) - allocate(WESNN (3,NTILES)) - allocate(HTSNNN (3,NTILES)) - allocate(SNDZN (3,NTILES)) + allocate(GHTCNT (N_GT, NTILES)) + allocate(WESNN (N_SNOW,NTILES)) + allocate(HTSNNN (N_SNOW,NTILES)) + allocate(SNDZN (N_SNOW,NTILES)) + allocate(FICESOUT(N_SNOW,NTILES)) + allocate(TILEZERO (NTILES)) allocate(DZSF (NTILES)) allocate(SWNETFREE(NTILES)) @@ -4487,7 +4527,7 @@ subroutine Driver ( RC ) allocate(TPSN1OUT1 (NTILES)) allocate(LHACC (NTILES)) allocate(SUMEV (NTILES)) - allocate(FICE1 (NTILES)) + allocate(FICE1TMP (NTILES)) allocate(SLDTOT (NTILES)) ! total solid precip allocate(FSW_CHANGE(NTILES)) @@ -4849,10 +4889,12 @@ subroutine Driver ( RC ) ! Get TPSN1OUT1 for SNOW_ALBEDO parameterization - call STIEGLITZSNOW_CALC_TPSNOW(NTILES, HTSNNN(1,:), WESNN(1,:), TPSN1OUT1, FICE1) + call STIEGLITZSNOW_CALC_TPSNOW(NTILES, HTSNNN(1,:), WESNN(1,:), TPSN1OUT1, FICE1TMP ) TPSN1OUT1 = TPSN1OUT1 + MAPL_TICE - call SNOW_ALBEDO(NTILES, N_snow, CATCH_INTERNAL_STATE%N_CONST_LAND4SNWALB, VEG, LAI, ZTH, & + call StieglitzSnow_snow_albedo(NTILES, N_snow, & + CATCH_INTERNAL_STATE%N_CONST_LAND4SNWALB, & + VEG, LAI, ZTH, & RHOFS, & SNWALB_VISMAX, SNWALB_NIRMAX, SLOPE, & WESNN, HTSNNN, SNDZN, & @@ -5358,10 +5400,10 @@ subroutine Driver ( RC ) DEALLOC_(mask) ! consolidate increment arrays - allocate(ghtcnt_incr(6,NTILES)) - allocate(wesnn_incr( 3,NTILES)) - allocate(htsnnn_incr(3,NTILES)) - allocate(sndzn_incr( 3,NTILES)) + allocate(ghtcnt_incr(N_GT, NTILES)) + allocate(wesnn_incr( N_SNOW,NTILES)) + allocate(htsnnn_incr(N_SNOW,NTILES)) + allocate(sndzn_incr( N_SNOW,NTILES)) GHTCNT_INCR(1,:) = GHTCNT1_INCR GHTCNT_INCR(2,:) = GHTCNT2_INCR @@ -5392,6 +5434,17 @@ subroutine Driver ( RC ) CAPAC, CATDEF, RZEXC, SRFEXC, & GHTCNT, WESNN, HTSNNN, SNDZN ) + ! @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ + ! + ! Should not need to re-compute diagnostics (e.g., TSURF, TPSN1) here because + ! the immediate next step is to run catchment(), which should only depend + ! on Catchment prognostic variables. + ! However, TURBULENCE (and RADIATION?) presumably have seen the Catchment forecast + ! (incl. surface temperature TC0 and might now be out of sync with the Catchment + ! analysis. Move apply_catch_incr() into Run1() ??? + ! + ! @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ + deallocate(ghtcnt_incr,wesnn_incr,htsnnn_incr,sndzn_incr) call WRITE_PARALLEL('LDAS_coupling: Done loading and applying LDAS increments.') @@ -5479,7 +5532,7 @@ subroutine Driver ( RC ) ENTOT,WTOT, WCHANGE, ECHANGE, HSNACC, EVACC, SHACC ,& SHSNOW1, AVETSNOW1, WAT10CM1, WATSOI1, ICESOI1 ,& LHSNOW1, LWUPSNOW1, LWDNSNOW1, NETSWSNOW ,& - TCSORIG1, TPSN1IN1, TPSN1OUT1,FSW_CHANGE ,& + TCSORIG1, TPSN1IN1, TPSN1OUT1, FSW_CHANGE, FICESOUT ,& lonbeg,lonend,latbeg,latend ,& TC1_0=TC1_0, TC2_0=TC2_0, TC4_0=TC4_0 ,& QA1_0=QA1_0, QA2_0=QA2_0, QA4_0=QA4_0 ,& @@ -5542,10 +5595,10 @@ subroutine Driver ( RC ) VISDF, VISDF, NIRDF, NIRDF, & ! MODIS albedo scale parameters on tiles USE ONLY DIFFUSE ALBVR, ALBNR, ALBVF, ALBNF ) ! instantaneous snow-free albedos on tiles - call STIEGLITZSNOW_CALC_TPSNOW(NTILES, HTSNNN(1,:), WESNN(1,:), TPSN1OUT1, FICE1) + call STIEGLITZSNOW_CALC_TPSNOW(NTILES, HTSNNN(1,:), WESNN(1,:), TPSN1OUT1, FICE1TMP ) TPSN1OUT1 = TPSN1OUT1 + MAPL_TICE - call SNOW_ALBEDO(NTILES, N_snow, CATCH_INTERNAL_STATE%N_CONST_LAND4SNWALB, VEG, LAI, ZTH, & + call StieglitzSnow_snow_albedo(NTILES, N_snow, CATCH_INTERNAL_STATE%N_CONST_LAND4SNWALB, VEG, LAI, ZTH, & RHOFS, & SNWALB_VISMAX, SNWALB_NIRMAX, SLOPE, & WESNN, HTSNNN, SNDZN, & @@ -5655,7 +5708,7 @@ subroutine Driver ( RC ) if(associated(SMLAND)) SMLAND = SMELT if(associated(TWLAND)) TWLAND = WTOT if(associated(TELAND)) TELAND = ENTOT - if(associated(TSLAND)) TSLAND = WESNN (1,:) + WESNN (2,:) + WESNN (3,:) + if(associated(TSLAND)) TSLAND = WESNN(1,:) + WESNN(2,:) + WESNN(3,:) if(associated(DWLAND)) DWLAND = WCHANGE if(associated(DHLAND)) DHLAND = ECHANGE if(associated(SPLAND)) SPLAND = SHACC @@ -5666,8 +5719,12 @@ subroutine Driver ( RC ) if(associated(FRUST )) FRUST = max( min( FR(:,FTRN),1.0 ), 0.0 ) if(associated(FRWLT )) FRWLT = max( min( FR(:,FWLT),1.0 ), 0.0 ) - if(associated(SNOMAS)) SNOMAS = WESNN (1,:) + WESNN (2,:) + WESNN (3,:) - if(associated(SNOWDP)) SNOWDP = SNDZN (1,:) + SNDZN (2,:) + SNDZN (3,:) + if(associated(SNOMAS)) SNOMAS = WESNN(1,:) + WESNN(2,:) + WESNN(3,:) + if(associated(SNOWDP)) SNOWDP = SNDZN(1,:) + SNDZN(2,:) + SNDZN(3,:) + + if(associated(FICE1 )) FICE1 = max( min( FICESOUT(1,:),1.0 ), 0.0 ) + if(associated(FICE2 )) FICE2 = max( min( FICESOUT(2,:),1.0 ), 0.0 ) + if(associated(FICE3 )) FICE3 = max( min( FICESOUT(3,:),1.0 ), 0.0 ) if(associated(RMELTDU001)) RMELTDU001 = RMELT(:,1) if(associated(RMELTDU002)) RMELTDU002 = RMELT(:,2) @@ -5771,6 +5828,7 @@ subroutine Driver ( RC ) deallocate(WESNN ) deallocate(HTSNNN ) deallocate(SNDZN ) + deallocate(FICESOUT ) deallocate(TILEZERO ) deallocate(DZSF ) deallocate(SWNETFREE) @@ -5849,9 +5907,9 @@ subroutine Driver ( RC ) deallocate(QA4_0 ) deallocate(RCONSTIT ) deallocate(TOTDEPOS ) - deallocate(RMELT ) - deallocate(FICE1 ) - deallocate(SLDTOT ) + deallocate(RMELT ) + deallocate(FICE1TMP ) + deallocate(SLDTOT ) deallocate(FSW_CHANGE) RETURN_(ESMF_SUCCESS) @@ -5969,7 +6027,7 @@ subroutine RUN0(gc, import, export, clock, rc) call MAPL_GetPointer(import, ps, 'PS', rc=status) VERIFY_(status) - ! Pointers to EXPOERTs + ! Pointers to EXPORTs call MAPL_GetPointer(export, asnow, 'ASNOW', rc=status) VERIFY_(status) call MAPL_GetPointer(export, emis, 'EMIS', rc=status) @@ -6052,12 +6110,12 @@ subroutine RUN0(gc, import, export, clock, rc) WW = 0. ! Compute ASNOW and EMIS - allocate(wesnn(3,ntiles), stat=status) + allocate(wesnn(N_SNOW,ntiles), stat=status) VERIFY_(status) wesnn(1,:) = wesnn1 wesnn(2,:) = wesnn2 wesnn(3,:) = wesnn3 - call StieglitzSnow_calc_asnow(3, ntiles, wesnn, asnow) + call StieglitzSnow_calc_asnow(N_snow, ntiles, wesnn, asnow) emis = EMSVEG(nint(ity)) + (EMSBARESOIL - EMSVEG(nint(ity)))*exp(-lai) emis = emis*(1.-asnow) + EMSSNO*asnow diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/catch_incr.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/catch_incr.F90 index e53013cf7..9ef7e3055 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/catch_incr.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/catch_incr.F90 @@ -3,13 +3,26 @@ module catch_incr ! module for "incremental analysis update" of Catchment in tile-space - ! reichle+csdraper, 3 Apr 2012 + ! reichle+csdraper, 3 Apr 2012 + ! reichle, 29 Sep 2023 - added snow checks + + use MAPL_BaseMod, ONLY: & + MAPL_Land + use catch_constants, ONLY: & N_SNOW => CATCH_N_SNOW, & - N_GT => CATCH_N_GT + N_GT => CATCH_N_GT, & + CATCH_SNOW_DZPARAM, & + CATCH_SNOW_RHOFS - use lsm_routines, ONLY: catch_calc_soil_moist + use lsm_routines, ONLY: catch_calc_soil_moist + + use StieglitzSnow, ONLY: & + N_constit, & + StieglitzSnow_RHOMA, & + StieglitzSnow_relayer, & + StieglitzSnow_calc_asnow implicit none @@ -105,11 +118,16 @@ subroutine check_catch_progn( NTILES, & bf1,bf2, & TC1, TC2, TC4, QC1, QC2, QC4, & CAPAC, CATDEF, RZEXC, SRFEXC, & - GHTCNT, WESNN, HTSNNN, SNDZN ) + GHTCNT, WESNN, HTSNNN, SNDZN, & + check_soil_moisture, check_snow ) ! check Catchment prognostic variables for physical constraints, re-set ! if constraints are violated ! + ! optional input arguments can be used to turn off checks of soil + ! moisture and/or snow states (added to maintain 0-diff for + ! LDAS SMAP Tb assimilation test cases) + ! ! reichle, 2 Aug 2005 ! reichle, 5 Feb 2008 - moved from clsm_ensdrv_pert_routines.F90 and ! added workaround "catdef>1." @@ -141,84 +159,154 @@ subroutine check_catch_progn( NTILES, & real, dimension(N_GT, NTILES), intent(inout) :: GHTCNT real, dimension(N_SNOW,NTILES), intent(inout) :: WESNN, HTSNNN, SNDZN + logical, optional, intent(in) :: check_soil_moisture, check_snow + ! ---------------------------------------------------------------- ! local variables - integer :: i, k + integer :: ii, kk - real, dimension(NTILES) :: ar1, ar2, ar4 + real, dimension(NTILES) :: ar1, ar2, ar4 + + real :: asnow_tmp, snow_dens + + real, dimension(N_snow) :: tpsn, fices ! for snow model relayer + real, dimension(N_snow,N_constit) :: rconstit + logical :: check_sm, check_sno + ! ---------------------------------------------------------------- + ! process optional inputs; by default, check everything + + check_sm = .true. + check_sno = .true. + + if (present(check_soil_moisture)) check_sm = check_soil_moisture + if (present(check_snow )) check_sno = check_snow + + ! ------------------------------------------------------------ + ! check for violations of physical constraints and correct accordingly - do i=1,NTILES + ! legacy checks (not currently related to analysis updates) + + do ii=1,NTILES ! tc1,tc2,tc4 - no checks implemented ! enforce qc>=0, maybe qc <= some number ? - qc1(i) = max( qc1(i), 0.) - qc2(i) = max( qc2(i), 0.) - qc4(i) = max( qc4(i), 0.) + qc1(ii) = max( qc1(ii), 0.) + qc2(ii) = max( qc2(ii), 0.) + qc4(ii) = max( qc4(ii), 0.) ! enforce capac>=0, maybe capac <= satcap ? - capac(i) = max( capac(i), 0.) + capac(ii) = max( capac(ii), 0.) ! checks on soil moisture states see below!! (call to calc_soil_moist()) ! no checks on ground heat content implemented ! - ! ghtcnt(1:N_gt,i) + ! ghtcnt(1:N_gt,ii) - do k=1,N_snow - - ! snow water equivalent >= 0 - - wesnn(k,i) = max(wesnn(k,i), 0.) - - ! snow heat content <= 0 ??? - - !! htsnn(k,i) = min(htsnn(k,i), 0.) + end do + + ! -------------------------------------------------------------------- + + if (check_sno) then ! check snow states + + do ii=1,NTILES - ! snow depth >= 0 + call StieglitzSnow_calc_asnow( N_snow, wesnn(1:N_snow,ii), asnow_tmp ) - sndzn(k,i) = max(sndzn(k,i), 0.) + if (asnow_tmp>0.) then + + do kk=1,N_snow + + ! snow water equivalent >= 0 + + wesnn( kk,ii) = max(wesnn( kk,ii), 0.) + + ! snow heat content <= 0 + + htsnnn(kk,ii) = min(htsnnn(kk,ii), 0.) + + ! snow depth >= 0 + + sndzn( kk,ii) = max(sndzn( kk,ii), 0.) + + ! adjust snow depth to ensure min <= density <= max + + snow_dens = (wesnn(kk,ii)/asnow_tmp)/sndzn(kk,ii) + + snow_dens = min( snow_dens, StieglitzSnow_RHOMA ) + snow_dens = max( snow_dens, CATCH_SNOW_RHOFS ) + + sndzn(kk,ii) = (wesnn(kk,ii)/asnow_tmp)/snow_dens + + end do + + ! relayer snow + + call StieglitzSnow_relayer( & + N_snow, N_constit, MAPL_LAND, & + CATCH_SNOW_DZPARAM, & + htsnnn(1:N_snow,ii), & + wesnn( 1:N_snow,ii), & + sndzn( 1:N_snow,ii), & + rconstit, tpsn, fices ) + + else + + ! zero snow mass, make sure snow depth and snow heat content are also zero + + wesnn( 1:N_snow,ii) = 0. ! protect against sum(wesn)<0. + htsnnn(1:N_snow,ii) = 0. + sndzn( 1:N_snow,ii) = 0. + + end if ! (asnow_tmp>0.) end do - end do + end if ! (check_sno) + + ! ---------------------------------------------------------------- + + if (check_sm) then + + ! check soil moisture states (done as part of calculation of + ! soil moisture content) + ! reichle, 6 Feb 2004 + + ! NOTE: calc_soil_moist() was moved into catchment.F90 (when GEOS5 + ! went from catchment.f to catchment.F90). The constraint + ! in calc_soil_moist() was originally catdef>0., but this + ! proved insufficient when the code was compiled on discover + ! with "-openmp" because of unprotected divisions by zero + ! in partition(). (See comment dated 26 March 2007 in the old + ! catchment.f) + ! Here, preface the call to calc_soil_moist() with the appropriate + ! lower bound so that the off-line driver can be used with older + ! versions of catchment.F90 (at least version 1.37 and earlier). + ! IMPORTANT: This *will* mess up the optional diagnostic + ! "werror", which is not used here but may be in the future. + ! reichle - 5 Feb 2008 + + ! call to revised subroutine catch_calc_soil_moist() -- which includes the + ! lower bound on catdef, - reichle, 3 Apr 2012 + + call catch_calc_soil_moist( & + NTILES,dzsf,vgwmax,cdcr1,cdcr2,psis,bee,poros,wpwet, & + ars1,ars2,ars3,ara1,ara2, & + ara3,ara4,arw1,arw2,arw3,arw4,bf1,bf2, & + srfexc,rzexc,catdef, & + ar1, ar2, ar4 ) + + end if ! (check_sm) - ! check soil moisture states (done as part of calculation of - ! soil moisture content) - ! reichle, 6 Feb 2004 - - ! NOTE: calc_soil_moist() was moved into catchment.F90 (when GEOS5 - ! went from catchment.f to catchment.F90). The constraint - ! in calc_soil_moist() was originally catdef>0., but this - ! proved insufficient when the code was compiled on discover - ! with "-openmp" because of unprotected divisions by zero - ! in partition(). (See comment dated 26 March 2007 in the old - ! catchment.f) - ! Here, preface the call to calc_soil_moist() with the appropriate - ! lower bound so that the off-line driver can be used with older - ! versions of catchment.F90 (at least version 1.37 and earlier). - ! IMPORTANT: This *will* mess up the optional diagnostic - ! "werror", which is not used here but may be in the future. - ! reichle - 5 Feb 2008 - - ! call to revised subroutine catch_calc_soil_moist() -- which includes the - ! lower bound on catdef, - reichle, 3 Apr 2012 - - call catch_calc_soil_moist( & - NTILES,dzsf,vgwmax,cdcr1,cdcr2,psis,bee,poros,wpwet, & - ars1,ars2,ars3,ara1,ara2, & - ara3,ara4,arw1,arw2,arw3,arw4,bf1,bf2, & - srfexc,rzexc,catdef, & - ar1, ar2, ar4 ) - end subroutine check_catch_progn end module catch_incr diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/catchment.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/catchment.F90 index 9bb53dd6f..407e35984 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/catchment.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/catchment.F90 @@ -81,13 +81,9 @@ MODULE CATCHMENT_MODEL USE CATCH_CONSTANTS, ONLY: & N_SNOW => CATCH_N_SNOW, & N_GT => CATCH_N_GT, & - RHOFS => CATCH_SNWALB_RHOFS, & - SNWALB_VISMAX => CATCH_SNWALB_VISMAX, & - SNWALB_NIRMAX => CATCH_SNWALB_NIRMAX, & - SLOPE => CATCH_SNWALB_SLOPE, & - MAXSNDEPTH => CATCH_MAXSNDEPTH, & - DZ1MAX => CATCH_DZ1MAX, & - SCONST => CATCH_SCONST, & + CATCH_SNOW_RHOFS, & + CATCH_SNOW_MAXDEPTH, & + CATCH_SNOW_DZPARAM, & CSOIL_1 => CATCH_CSOIL_1, & N_sm => CATCH_N_ZONES, & SATCAPFR => CATCH_SATCAPFR, & @@ -108,10 +104,13 @@ MODULE CATCHMENT_MODEL SRUNOFF USE SIBALB_COEFF, ONLY: coeffsib - - USE STIEGLITZSNOW, ONLY: & - snowrt, StieglitzSnow_calc_asnow, StieglitzSnow_calc_tpsnow, get_tf0d, N_constit - + + USE STIEGLITZSNOW, ONLY: & + StieglitzSnow_snowrt, & + StieglitzSnow_calc_asnow, & + StieglitzSnow_calc_tpsnow, & + N_constit + IMPLICIT NONE private @@ -159,22 +158,23 @@ SUBROUTINE CATCHMENT ( & EVACC, SHACC, & SH_SNOW, AVET_SNOW, WAT_10CM, TOTWAT_SOIL, TOTICE_SOIL, & LH_SNOW, LWUP_SNOW, LWDOWN_SNOW, NETSW_SNOW, & - TCSORIG, TPSN1IN, TPSN1OUT,FSW_CHANGE , & + TCSORIG, TPSN1IN, TPSN1OUT, FSW_CHANGE, FICESOUT, & lonbeg,lonend,latbeg,latend, & - TC1_0, TC2_0, TC4_0, QA1_0, QA2_0, QA4_0, EACC_0, & - RCONSTIT, RMELT, TOTDEPOS, LHACC) + TC1_0, TC2_0, TC4_0, QA1_0, QA2_0, QA4_0, EACC_0, & ! OPTIONAL + RCONSTIT, RMELT, TOTDEPOS, LHACC ) ! OPTIONAL IMPLICIT NONE ! ----------------------------------------------------------- ! INPUTS - INTEGER, INTENT(IN) :: NCH + INTEGER, INTENT(IN) :: NCH INTEGER, INTENT(IN), DIMENSION(NCH) :: ITYP, cat_id - REAL, INTENT(IN) :: DTSTEP, FWETC, FWETL - LOGICAL, INTENT(IN) :: UFW4RO - REAL, INTENT(IN), DIMENSION(NCH) :: DZSF, TRAINC, TRAINL, & + REAL, INTENT(IN) :: DTSTEP, FWETC, FWETL + LOGICAL, INTENT(IN) :: UFW4RO + + REAL, INTENT(IN), DIMENSION(NCH) :: DZSF, TRAINC, TRAINL, & TSNOW, TICE, TFRZR, UM, & ETURB1, DEDQA1, DEDTC1, HSTURB1,DHSDQA1, DHSDTC1, & ETURB2, DEDQA2, DEDTC2, HSTURB2,DHSDQA2, DHSDTC2, & @@ -189,13 +189,15 @@ SUBROUTINE CATCHMENT ( & CDCR1,CDCR2, psis, bee, poros, wpwet, cond, gnu, & ARS1,ARS2,ARS3,ARA1,ARA2,ARA3,ARA4,ARW1,ARW2,ARW3,ARW4, & tsa1,tsa2,tsb1,tsb2,atau,btau - REAL, INTENT(IN), DIMENSION(NCH) :: LONS, LATS + + REAL, INTENT(IN), DIMENSION(NCH) :: LONS, LATS - REAL, INTENT(IN), DIMENSION(NCH, N_Constit), OPTIONAL :: TOTDEPOS + REAL, INTENT(IN), DIMENSION(NCH, N_Constit), OPTIONAL :: TOTDEPOS LOGICAL, INTENT(IN) :: BUG - REAL, INTENT(IN) :: lonbeg,lonend,latbeg,latend + REAL, INTENT(IN) :: lonbeg, lonend, latbeg, latend + ! ----------------------------------------------------------- ! PROGNOSTIC VARIABLES @@ -228,6 +230,7 @@ SUBROUTINE CATCHMENT ( & REAL, INTENT(OUT), DIMENSION(NCH) :: TCSORIG, TPSN1IN, TPSN1OUT, & FSW_CHANGE + REAL, INTENT(OUT), DIMENSION(N_SNOW, NCH) :: FICESOUT REAL, INTENT(OUT), DIMENSION(NCH), OPTIONAL :: LHACC @@ -262,7 +265,7 @@ SUBROUTINE CATCHMENT ( & REAL, DIMENSION(N_GT) :: HT, TP, soilice - REAL, DIMENSION(N_SNOW) :: TPSN, WESN, HTSNN, SNDZ, fices, targetthick, & + REAL, DIMENSION(N_SNOW) :: TPSN, WESN, HTSNN, SNDZ, fices, & wesnperc,wesndens,wesnrepar,excs,drho0,tksno, tmpvec_Nsnow REAL, DIMENSION(N_SNOW, N_Constit) :: RCONSTIT1 @@ -282,7 +285,7 @@ SUBROUTINE CATCHMENT ( & dhsdtc0, alhfsn, ADJ, raddn, zc1, tsnowsrf, dum, tsoil, & QA1X, QA2X, QA4X, TC1X, TC2X, TC4X, TCSX, & EVAPX1,EVAPX2,EVAPX4,SHFLUXX1,SHFLUXX2,SHFLUXX4,EVEGFRC, & - EVAPXS,SHFLUXXS,phi,rho_fs,WSS,sumdepth, & + EVAPXS,SHFLUXXS,phi,rho_fs,sumdepth, & sndzsc, wesnprec, sndzprec, sndz1perc, & mltwtr, wesnbot, dtss @@ -568,36 +571,36 @@ SUBROUTINE CATCHMENT ( & RUNSRF(N)=0. -!**** RESET LAND ICE VARIABLES, MAINTAINING TEMPS. AT EACH LAYER - IF(ITYP(N) .EQ. 9) THEN - - ! This block of the code should no longer be used. - ! If it is, Randy wants to know about it. - ! reichle+koster, 12 Aug 2014 - write (*,*) 'catchment() encountered ityp==9. STOPPING.' - stop - - if(sum(htsnnn(:,n)+wesnn(:,n))==0.) then - TSN1=tc1(n)-TF - TSN2=tc1(n)-TF - TSN3=tc1(n)-TF - else - TSN1=(HTSNNN(1,N)+WESNN(1,N)*ALHM)/(SCONST*WESNN(1,N)+1.e-5) - TSN2=(HTSNNN(2,N)+WESNN(2,N)*ALHM)/(SCONST*WESNN(2,N)+1.e-5) - TSN3=(HTSNNN(3,N)+WESNN(3,N)*ALHM)/(SCONST*WESNN(3,N)+1.e-5) - endif - WESNN(1,N)=.1 - WESNN(2,N)=.2 - WESNN(3,N)=.1 - HTSNNN(1,N)=-ALHM*WESNN(1,N)+TSN1*SCONST*WESNN(1,N) - HTSNNN(2,N)=-ALHM*WESNN(2,N)+TSN1*SCONST*WESNN(2,N) - HTSNNN(3,N)=-ALHM*WESNN(3,N)+TSN1*SCONST*WESNN(3,N) - SNDZN(1,N)=WESNN(1,N)/.9 - SNDZN(2,N)=WESNN(2,N)/.9 - SNDZN(3,N)=WESNN(3,N)/.9 - POTFRC(N)=1. - - ENDIF +!! !**** RESET LAND ICE VARIABLES, MAINTAINING TEMPS. AT EACH LAYER +!! IF(ITYP(N) .EQ. 9) THEN +!! +!! ! This block of the code should no longer be used. +!! ! If it is, Randy wants to know about it. +!! ! reichle+koster, 12 Aug 2014 +!! write (*,*) 'catchment() encountered ityp==9. STOPPING.' +!! stop +!! +!! if(sum(htsnnn(:,n)+wesnn(:,n))==0.) then +!! TSN1=tc1(n)-TF +!! TSN2=tc1(n)-TF +!! TSN3=tc1(n)-TF +!! else +!! TSN1=(HTSNNN(1,N)+WESNN(1,N)*ALHM)/(SCONST*WESNN(1,N)+1.e-5) +!! TSN2=(HTSNNN(2,N)+WESNN(2,N)*ALHM)/(SCONST*WESNN(2,N)+1.e-5) +!! TSN3=(HTSNNN(3,N)+WESNN(3,N)*ALHM)/(SCONST*WESNN(3,N)+1.e-5) +!! endif +!! WESNN(1,N)=.1 +!! WESNN(2,N)=.2 +!! WESNN(3,N)=.1 +!! HTSNNN(1,N)=-ALHM*WESNN(1,N)+TSN1*SCONST*WESNN(1,N) +!! HTSNNN(2,N)=-ALHM*WESNN(2,N)+TSN1*SCONST*WESNN(2,N) +!! HTSNNN(3,N)=-ALHM*WESNN(3,N)+TSN1*SCONST*WESNN(3,N) +!! SNDZN(1,N)=WESNN(1,N)/.9 +!! SNDZN(2,N)=WESNN(2,N)/.9 +!! SNDZN(3,N)=WESNN(3,N)/.9 +!! POTFRC(N)=1. +!! +!! ENDIF !**** RESET LAKE VARIABLES IF(ITYP(N) .EQ. 10) THEN @@ -832,7 +835,6 @@ SUBROUTINE CATCHMENT ( & DO N=1,NCH - WSS = UM(N) TS = TM(N) T1(1) = TC1(N)-TF T1(2) = TC2(N)-TF @@ -891,7 +893,7 @@ SUBROUTINE CATCHMENT ( & ! in process ! reichle, 29 May 03 - call get_tf0d(htsnn(1),wesn(1),tsnowsrf,dum,ldum,ldum) + call StieglitzSnow_calc_tpsnow(htsnn(1),wesn(1),tsnowsrf,dum,ldum,ldum,.true.) tcs_orig(n)=tsnowsrf+tf if(wesn(1)+wesn(2)+wesn(3) .eq. 0.) tcs_orig(n)= & amin1( tf, tc1_orig(n)*ar1(n)+tc2_orig(n)*ar2(n)+ & @@ -911,30 +913,29 @@ SUBROUTINE CATCHMENT ( & tpsn1in(n) = tpsn1(n) ! tpsn1 is "intent(out)", should NOT be used here, use catch_calc_tpsnow instead? shouldn't this be the same as tcs_orig? - reichle, 8/8/2014 sumdepth=sum(sndz) - targetthick(1)=dz1max - - do i=2,N_snow - targetthick(i)=1./(N_snow-1.) - enddo - - CALL SNOWRT( & - N_sm, N_snow, MAPL_Land, & - t1,area,tkgnd,pr,snowf,ts,DTSTEP, & - eturbs(n),dedtc0,hsturb,dhsdtc0,hlwtc,dhlwtc, & - desdtc,hups,raddn,zc1, totdep1, wss, & - wesn,htsnn,sndz, fices,tpsn,RCONSTIT1, RMELT1, & - areasc,areasc0,pre,fhgnd, & - EVSN,SHFLS,alhfsn,hcorr, ghfluxsno(n), & - sndzsc, wesnprec, sndzprec, sndz1perc, & - wesnperc, wesndens, wesnrepar, mltwtr, & - excs, drho0, wesnbot, tksno, dtss, & - maxsndepth, rhofs, targetthick ) - - LH_SNOW(N)=areasc*EVSN*ALHS - SH_SNOW(N)=areasc*SHFLS - LWUP_SNOW(N)=areasc*HUPS - LWDOWN_SNOW(N)=areasc*HLWDWN(N) - NETSW_SNOW(N)=areasc*SWNETS(N) + + CALL StieglitzSnow_snowrt( & + N_sm, N_snow, MAPL_Land, & ! in + CATCH_SNOW_MAXDEPTH, CATCH_SNOW_RHOFS, CATCH_SNOW_DZPARAM, & ! in + t1, area, tkgnd, pr, snowf, ts, DTSTEP, & ! in + eturbs(n), dedtc0, hsturb, dhsdtc0, hlwtc, dhlwtc, & ! in + raddn, zc1, totdep1, & ! in + wesn, htsnn, sndz, RCONSTIT1, & ! inout + hups, fices, tpsn, RMELT1, & ! out + areasc, areasc0, pre, fhgnd, & ! out + EVSN, SHFLS, alhfsn, hcorr, ghfluxsno(n), & ! out + sndzsc, wesnprec, sndzprec, sndz1perc, & ! out + wesnperc, wesndens, wesnrepar, mltwtr, & ! out + excs, drho0, wesnbot, tksno, dtss ) ! out + + + FICESOUT(:,N) = fices + + LH_SNOW(N) = areasc*EVSN*ALHS + SH_SNOW(N) = areasc*SHFLS + LWUP_SNOW(N) = areasc*HUPS + LWDOWN_SNOW(N) = areasc*HLWDWN(N) + NETSW_SNOW(N) = areasc*SWNETS(N) TPSN1(N) = TPSN(1)+TF @@ -1489,19 +1490,19 @@ SUBROUTINE CATCHMENT ( & SHACC(N)=SHFLUX(N)-SHACC(N) - - - ! **** SPECIAL DIAGNOSTICS FOR AR5 DECADAL RUNS - CALL STIEGLITZSNOW_CALC_TPSNOW(N_SNOW, HTSNNN(:,N), WESNN(:,N), TPSN, FICES) + ! the following assumes that fices is unchanged, otherwise may need to update FICESOUT + ! - reichle, 4 Oct 2023 + + CALL STIEGLITZSNOW_CALC_TPSNOW(N_SNOW, HTSNNN(:,N), WESNN(:,N), TPSN, FICES) - !AVET_SNOW(N)=(TPSN(1)+TF)*WESNN(1,N) + (TPSN(2)+TF)*WESNN(2,N) + & - ! (TPSN(3)+TF)*WESNN(3,N) + !AVET_SNOW(N)=(TPSN(1)+TF)*WESNN(1,N) + (TPSN(2)+TF)*WESNN(2,N) + & + ! (TPSN(3)+TF)*WESNN(3,N) - tmpvec_Nsnow = (tpsn(1:N_snow)+tf)*wesnn(1:N_snow,N) + tmpvec_Nsnow = (tpsn(1:N_snow)+tf)*wesnn(1:N_snow,N) - AVET_SNOW(N) = sum(tmpvec_Nsnow(1:N_snow)) + AVET_SNOW(N) = sum(tmpvec_Nsnow(1:N_snow)) WAT_10CM(N)=0.1*(RZEQ(N)+RZEXC(N))+SRFEXC(N) @@ -1510,7 +1511,7 @@ SUBROUTINE CATCHMENT ( & TOTICE_SOIL(N)=TOTWAT_SOIL(N)*FRICE(N) - ENDDO + ENDDO ! N=1,NCH (PROCESS DATA AS NECESSARY PRIOR TO RETURN) if(numout.ne.0) then do i = 1,numout @@ -2901,6 +2902,7 @@ END SUBROUTINE RCANOP !**** ! ******************************************************************* + subroutine catch_calc_tsurf( NTILES, tc1, tc2, tc4, wesnn, htsnn, & ar1, ar2, ar4, tsurf ) @@ -2926,30 +2928,26 @@ subroutine catch_calc_tsurf( NTILES, tc1, tc2, tc4, wesnn, htsnn, & real, dimension( NTILES), intent(out) :: tsurf - - ! ---------------------------- ! ! local variables - integer :: n + integer :: n - real, dimension(NTILES) :: asnow + real, dimension(NTILES) :: asnow - real, dimension(1) :: tpsn1, real_dummy + real :: tpsn1, real_dummy + logical :: ice1, tzero + logical, parameter :: use_threshold_fac = .false. ! ------------------------------------------------------------------ ! Compute tsurf excluding snow - - call catch_calc_tsurf_excl_snow( NTILES, tc1, tc2, tc4, ar1, ar2, ar4, tsurf ) - - ! Compute snow covered area call StieglitzSnow_calc_asnow( N_snow, NTILES, wesnn, asnow ) @@ -2959,14 +2957,13 @@ subroutine catch_calc_tsurf( NTILES, tc1, tc2, tc4, wesnn, htsnn, & do n=1,NTILES if (asnow(n)>0.) then - - - + ! StieglitzSnow_calc_tpsnow() returns snow temperature in deg Celsius - call StieglitzSnow_calc_tpsnow( 1, htsnn(1,n), wesnn(1,n), tpsn1, real_dummy ) + call StieglitzSnow_calc_tpsnow( htsnn(1,n), wesnn(1,n), tpsn1, real_dummy, & + ice1, tzero, use_threshold_fac ) - tsurf(n) = (1. - asnow(n))*tsurf(n) + asnow(n)*(tpsn1(1) + TF) + tsurf(n) = (1. - asnow(n))*tsurf(n) + asnow(n)*(tpsn1 + TF) end if diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/Shared/catch_constants.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/Shared/catch_constants.f90 index 92d07809f..2f4d7d1e7 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/Shared/catch_constants.f90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/Shared/catch_constants.f90 @@ -26,13 +26,11 @@ module catch_constants ! - added routing model constants N_Pfafs_LandCatchs and N_Pfaf_Catchs ! Justin, 12 Apr 2018 - removed ifdef LAND_UPD, moved CSOIL_2 to SurfParams ! reichle, 27 Jan 2022 - cleanup: moved "public" constants from lsm_routines to here; added "CATCH_" prefix - - ! --------------------------------------------------------------------------- ! - - USE MAPL_ConstantsMod, ONLY: & - MAPL_ALHF + ! --------------------------------------------------------------------------- + USE MAPL_ConstantsMod, ONLY: & + MAPL_ALHF ! use constants from SURFPARAMS in echo_catch_contants() @@ -61,12 +59,17 @@ module catch_constants ! ! constants for use with snowrt() and snow_albedo() of module StieglitzSnow - REAL, PARAMETER, PUBLIC :: CATCH_SNWALB_RHOFS = 150. ! kg/m^3 - REAL, PARAMETER, PUBLIC :: CATCH_SNWALB_VISMAX = 0.7 ! - REAL, PARAMETER, PUBLIC :: CATCH_SNWALB_NIRMAX = 0.5 ! - REAL, PARAMETER, PUBLIC :: CATCH_SNWALB_SLOPE = -0.0006 ! - REAL, PARAMETER, PUBLIC :: CATCH_MAXSNDEPTH = 1.e20 ! - REAL, PARAMETER, PUBLIC :: CATCH_DZ1MAX = 0.08 ! m + REAL, PARAMETER, PUBLIC :: CATCH_SNOW_RHOFS = 150. ! kg/m^3 + REAL, PARAMETER, PUBLIC :: CATCH_SNOW_VISMAX = 0.7 ! + REAL, PARAMETER, PUBLIC :: CATCH_SNOW_NIRMAX = 0.5 ! + REAL, PARAMETER, PUBLIC :: CATCH_SNOW_SLOPE = -0.0006 ! + REAL, PARAMETER, PUBLIC :: CATCH_SNOW_MAXDEPTH = 1.e20 ! + + REAL, PARAMETER, PUBLIC, DIMENSION(CATCH_N_SNOW) :: CATCH_SNOW_DZPARAM & + = (/ & + 0.08, & ! m top-layer target thickness + 1./(CATCH_N_SNOW-1.), 1./(CATCH_N_SNOW-1.) & ! - "sigma" distribution + /) ! --------------------------------------------------------------------------- ! @@ -95,13 +98,13 @@ module catch_constants ! Catchment: tc1, tc2, tc4 (CSOIL also includes veg canopy) ! CatchmentCN: tg1, tg2, tg4 (tc[X] are separate canopy temperatures) - REAL, PARAMETER, PUBLIC :: CATCH_DZTSURF = 0.05 ! m layer depth for tc[X] or tg[X] + REAL, PARAMETER, PUBLIC :: CATCH_DZTSURF = 0.05 ! m layer depth for tc[X] or tg[X] ! --------------------------------------------------------------------------- ! ! layer depths and other associated with ground heat diffusion model (gndtp0() and gndtmp()) - REAL, PARAMETER, DIMENSION(CATCH_N_GT), PUBLIC :: CATCH_DZGT = & ! m layer depths + REAL, PARAMETER, DIMENSION(CATCH_N_GT), PUBLIC :: CATCH_DZGT = & ! m layer depths (/ 0.0988, 0.1952, 0.3859, 0.7626, 1.5071, 10.0 /) ! PHIGT and ALHMGT are needed for backward compatibility with @@ -118,22 +121,20 @@ module catch_constants REAL, PARAMETER, PUBLIC :: CATCH_PHIGT = -9999. REAL, PARAMETER, PUBLIC :: CATCH_ALHMGT = MAPL_ALHF - REAL, PARAMETER, PUBLIC :: CATCH_FSN = 1.e3*CATCH_ALHMGT ! unit change J/kg/K -> J/m/K + REAL, PARAMETER, PUBLIC :: CATCH_FSN = 1.e3*CATCH_ALHMGT ! unit change J/kg/K -> J/m/K ! miscellaneous Catchment model constants - REAL, PARAMETER, PUBLIC :: CATCH_SHR = 2400. ! J/kg/K spec heat of rock - ! [where "per kg" is something like - ! "per kg of water equiv. density"] - - REAL, PARAMETER, PUBLIC :: CATCH_SCONST = 1.9E6/920. ! some snow constant + REAL, PARAMETER, PUBLIC :: CATCH_SHR = 2400. ! J/kg/K spec heat of rock + ! [where "per kg" is something like + ! "per kg of water equiv. density"] REAL, PARAMETER, PUBLIC :: CATCH_CSOIL_1 = 70000. ! J/K - heat capacity associated w/ tsurf - + REAL, PARAMETER, PUBLIC :: CATCH_C_CANOP = 200. ! J/K - heat capacity associated w/ tc (CatchCN) - + REAL, PARAMETER, PUBLIC :: CATCH_SATCAPFR = 0.2 ! SATCAP = SATCAPFR * LAI - + ! peatCLSM implementation smahanam 3-16-2021 ! @@ -147,11 +148,11 @@ module catch_constants ! ! - reichle, 26 Jan 2022 - REAL, PARAMETER, PUBLIC :: PEATCLSM_POROS_THRESHOLD = 0.90 ! [m3/m3] + REAL, PARAMETER, PUBLIC :: PEATCLSM_POROS_THRESHOLD = 0.90 ! [m3/m3] ! max zbar for specific yield calc in PEATCLSM - REAL, PARAMETER, PUBLIC :: PEATCLSM_ZBARMAX_4_SYSOIL = 0.45 ! [m] + REAL, PARAMETER, PUBLIC :: PEATCLSM_ZBARMAX_4_SYSOIL = 0.45 ! [m] contains @@ -173,19 +174,18 @@ subroutine echo_catch_constants(logunit) write (logunit,*) 'CATCH_N_SNOW = ', CATCH_N_SNOW write (logunit,*) 'CATCH_N_GT = ', CATCH_N_GT write (logunit,*) 'CATCH_N_ZONES = ', CATCH_N_ZONES - write (logunit,*) 'CATCH_SNWALB_RHOFS = ', CATCH_SNWALB_RHOFS - write (logunit,*) 'CATCH_SNWALB_VISMAX = ', CATCH_SNWALB_VISMAX - write (logunit,*) 'CATCH_SNWALB_NIRMAX = ', CATCH_SNWALB_NIRMAX - write (logunit,*) 'CATCH_SNWALB_SLOPE = ', CATCH_SNWALB_SLOPE - write (logunit,*) 'CATCH_MAXSNDEPTH = ', CATCH_MAXSNDEPTH - write (logunit,*) 'CATCH_DZ1MAX = ', CATCH_DZ1MAX + write (logunit,*) 'CATCH_SNOW_RHOFS = ', CATCH_SNOW_RHOFS + write (logunit,*) 'CATCH_SNOW_VISMAX = ', CATCH_SNOW_VISMAX + write (logunit,*) 'CATCH_SNOW_NIRMAX = ', CATCH_SNOW_NIRMAX + write (logunit,*) 'CATCH_SNOW_SLOPE = ', CATCH_SNOW_SLOPE + write (logunit,*) 'CATCH_SNOW_MAXDEPTH = ', CATCH_SNOW_MAXDEPTH write (logunit,*) 'CATCH_DZTSURF = ', CATCH_DZTSURF - write (logunit,*) 'CATCH_DZGT = ', CATCH_DZGT + write (logunit,*) 'CATCH_DZGT = ', CATCH_DZGT + write (logunit,*) 'CATCH_SNOW_DZPARAM = ', CATCH_SNOW_DZPARAM write (logunit,*) 'CATCH_PHIGT = ', CATCH_PHIGT write (logunit,*) 'CATCH_ALHMGT = ', CATCH_ALHMGT write (logunit,*) 'CATCH_FSN = ', CATCH_FSN write (logunit,*) 'CATCH_SHR = ', CATCH_SHR - write (logunit,*) 'CATCH_SCONST = ', CATCH_SCONST write (logunit,*) 'CATCH_CSOIL_1 = ', CATCH_CSOIL_1 write (logunit,*) 'CATCH_C_CANOP = ', CATCH_C_CANOP write (logunit,*) 'CATCH_SATCAPFR = ', CATCH_SATCAPFR diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/Shared/lsm_routines.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/Shared/lsm_routines.F90 index 91e9377d0..6a409e71d 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/Shared/lsm_routines.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/Shared/lsm_routines.F90 @@ -33,7 +33,6 @@ MODULE lsm_routines USE CATCH_CONSTANTS, ONLY: & N_SNOW => CATCH_N_SNOW, & N_GT => CATCH_N_GT, & - RHOFS => CATCH_SNWALB_RHOFS, & DZTSURF => CATCH_DZTSURF, & DZGT => CATCH_DZGT, & PHIGT => CATCH_PHIGT, & @@ -44,15 +43,11 @@ MODULE lsm_routines PEATCLSM_ZBARMAX_4_SYSOIL USE SURFPARAMS, ONLY: & - LAND_FIX, CSOIL_2, WEMIN, AICEV, AICEN, & - FLWALPHA, ASTRFR, STEXP, RSWILT + LAND_FIX, FLWALPHA USE SIBALB_COEFF, ONLY: & coeffsib - USE STIEGLITZSNOW, ONLY: & - snowrt, StieglitzSnow_calc_asnow, StieglitzSnow_calc_tpsnow, get_tf0d - IMPLICIT NONE PRIVATE @@ -1303,9 +1298,6 @@ SUBROUTINE SIBALB (NCH, ITYP, VLAI, VGRN, ZTH, & REAL, PARAMETER :: ALVDRI = 0.700 REAL, PARAMETER :: ALIDRI = 0.700 - -! REAL, PARAMETER :: WEMIN = 13.0 ! [KG/M2] - ! ALVDRS: Albedo of soil for visible direct solar radiation. ! ALIDRS: Albedo of soil for infra-red direct solar radiation. ! ALVDFS: Albedo of soil for visible diffuse solar radiation. diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSlandice_GridComp/GEOS_LandIceGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSlandice_GridComp/GEOS_LandIceGridComp.F90 index de4b54d61..8bd9b0183 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSlandice_GridComp/GEOS_LandIceGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSlandice_GridComp/GEOS_LandIceGridComp.F90 @@ -27,11 +27,17 @@ module GEOS_LandiceGridCompMod ! !USES: use sfclayer ! use module that contains surface layer routines - use StieglitzSnow, only: snowrt, SNOW_ALBEDO, TRID, N_CONSTIT, & - NUM_DUDP, NUM_DUSV, NUM_DUWT, NUM_DUSD, & - NUM_BCDP, NUM_BCSV, NUM_BCWT, NUM_BCSD, & - NUM_OCDP, NUM_OCSV, NUM_OCWT, NUM_OCSD, & - NUM_SUDP, NUM_SUSV, NUM_SUWT, NUM_SUSD, & + use StieglitzSnow, only: & + snowrt => StieglitzSnow_snowrt, & + SNOW_ALBEDO => StieglitzSnow_snow_albedo, & + TRID => StieglitzSnow_trid, & + MINSWE => StieglitzSnow_MINSWE, & + cpw => StieglitzSnow_CPW, & + N_CONSTIT, & + NUM_DUDP, NUM_DUSV, NUM_DUWT, NUM_DUSD, & + NUM_BCDP, NUM_BCSV, NUM_BCWT, NUM_BCSD, & + NUM_OCDP, NUM_OCSV, NUM_OCWT, NUM_OCSD, & + NUM_SUDP, NUM_SUSV, NUM_SUWT, NUM_SUSD, & NUM_SSDP, NUM_SSSV, NUM_SSWT, NUM_SSSD use ESMF use MAPL @@ -56,20 +62,20 @@ module GEOS_LandiceGridCompMod real, parameter :: ALHM = MAPL_ALHF ! J/kg real, parameter :: TF = MAPL_TICE ! K real, parameter :: RHOW = MAPL_RHOWTR ! kg/m^3 + real, parameter :: RHOFRESH = 300. ! kg/m^3 density of fresh snow - !real, parameter :: RHOMA = 500. ! kg/m^3 maximum snow density real, parameter :: RHOICE = 917. ! kg/m^3 pure ice density - real, parameter :: MINSWE = 0.013 ! kg/m^2 min SWE to avoid immediate melt real, parameter :: MAXSNDZ = 15.0 ! m - real, parameter :: ZERO = 0. - real, parameter :: ONE = 1. real, parameter :: BIG = 1.e10 - real, parameter :: cpw = 2065.22 ! @ 0 C [J/kg/K] - real, parameter :: condice = 2.25 ! @ 0 C [W/m/K] - real, parameter :: MINFRACSNO = 1.e-20 ! mininum sno/ice fraction for - ! heat diffusion of ice layers to take effect - real, parameter :: LWCTOP = 1. ! top thickness to compute LWC. 1m taken from - ! Fettweis et al 2011 + real, parameter :: condice = 2.25 ! @ 0 C [W/m/K] + real, parameter :: MINFRACSNO = 1.e-20 ! mininum sno/ice fraction for + ! heat diffusion of ice layers to take effect + real, parameter :: LWCTOP = 1. ! top thickness to compute LWC. 1m taken from + ! Fettweis et al 2011 + real, parameter :: VISMAX = 0.96 ! parameter for snow_albedo + real, parameter :: NIRMAX = 0.68 ! parameter for snow_albedo + real, parameter :: SLOPE = 1.0 ! parameter for snow_albedo + ! taken from CICE real, parameter :: & ! currently used only AWTVDR = 0.00318, &! visible, direct ! for history and @@ -2145,7 +2151,7 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) real, pointer :: LATS(:) real, pointer :: LONS(:) - integer, pointer :: TILETYPES(:) + !integer, pointer :: TILETYPES(:) type(MAPL_SunOrbit) :: ORBIT !============================================================================= @@ -2180,7 +2186,7 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) ORBIT = ORBIT, & TILELATS = LATS, & TILELONS = LONS, & - TILETYPES = TILETYPES, & + !TILETYPES = TILETYPES, & RUNALARM = ALARM, & RC=STATUS ) VERIFY_(STATUS) @@ -2374,11 +2380,8 @@ subroutine LANDICECORE(RC) real, dimension(1) :: ZONEAREA real :: ZC1, ZDEP, ALPHA, ZKL real, dimension(1) :: TKGND - real :: DUM real, dimension(NUM_SNOW_LAYERS) :: TKSNO - real :: WSS - real, allocatable :: PRECIP (:) real, allocatable :: RAIN (:) real, allocatable :: RAINRF (:) @@ -2901,8 +2904,6 @@ subroutine LANDICECORE(RC) LHFO = 0.0 DTS = 0.0 - DUM = 0.0 - ! just to be safe DRHO0 = 0.0 EXCS = 0.0 @@ -2920,7 +2921,6 @@ subroutine LANDICECORE(RC) LNDNR = 0.0 LNDVF = 0.0 LNDNF = 0.0 - WSS = 0.0 debugzth = .false. @@ -3027,7 +3027,7 @@ subroutine LANDICECORE(RC) !*** call new/shared routine to compute albedo call SNOW_ALBEDO(NT, NUM_SNOW_LAYERS, N_CONST_LANDICE4SNWALB, ITYPE, LAI, ZTH, & - RHOFRESH, 0.96, 0.68, 1.0, & ! + RHOFRESH, VISMAX, NIRMAX, SLOPE, & !0.96, 0.68, 1.0, & ! WESNN, HTSNN, SNDZN, & ! snow stuff LNDVR, LNDNR, LNDVF, LNDNF, & ! instantaneous snow-free albedos on tiles SNOVR, SNONR, SNOVF, SNONF, & ! instantaneous snow albedos on tiles @@ -3086,18 +3086,19 @@ subroutine LANDICECORE(RC) #endif TKSNO = condice - call SNOWRT(1,NUM_SNOW_LAYERS,TILETYPES(k), & - LANDICELT(k),ZONEAREA,TKGND,PRECIP(k),SNO(k),TA(k),DT, & - EVAPI(k),DEVAPDT(k),SHF(k),SHD(k),ULW(k),BLW(k), & - DUM,HLWO(k),RADDN(k),ZC1,TOTDEPOS(k,:),WSS, & - WESN(k,:),HTSN(k,:),SNDZ(k,:), & - FROZFRAC(k,:),TPSN(k,:), RCONSTIT(k,:,:), RMELT(k,:), & - AREASC(k),FR(K,N),PERC(k),FHGND(k), & - EVAPO(k),SHFO(k),LHFO(k),HCORR(k),ghflxsno(k), & - SNDZSC(k), WESNPREC(k), SNDZPREC(k),SNDZ1PERC(k), & - WESNPERC(k,:), WESNDENS(k,:), WESNREPAR(k,:), MLT(k), & - EXCS(k,:), DRHO0(k,:), WESNBOT(k), TKSNO, DTS(k), & - MAXSNDZ, RHOFRESH, DZMAX) + call SNOWRT(1,NUM_SNOW_LAYERS,MAPL_LANDICE, & ! in + MAXSNDZ, RHOFRESH, DZMAX, & ! in + LANDICELT(k),ZONEAREA,TKGND,PRECIP(k),SNO(k),TA(k),DT, & ! in + EVAPI(k),DEVAPDT(k),SHF(k),SHD(k),ULW(k),BLW(k), & ! in + RADDN(k),ZC1,TOTDEPOS(k,:), & ! in + WESN(k,:),HTSN(k,:),SNDZ(k,:), RCONSTIT(k,:,:), & ! inout + HLWO(k), FROZFRAC(k,:),TPSN(k,:), RMELT(k,:), & ! out + AREASC(k),FR(K,N),PERC(k),FHGND(k), & ! out + EVAPO(k),SHFO(k),LHFO(k),HCORR(k),ghflxsno(k), & ! out + SNDZSC(k), WESNPREC(k), SNDZPREC(k),SNDZ1PERC(k), & ! out + WESNPERC(k,:), WESNDENS(k,:), WESNREPAR(k,:), MLT(k), & ! out + EXCS(k,:), DRHO0(k,:), WESNBOT(k), TKSNO, DTS(k) ) ! out + ! Snow impurities update if (N_CONST_LANDICE4SNWALB /= 0) then @@ -3229,7 +3230,7 @@ subroutine LANDICECORE(RC) ITYPE = 9 call SNOW_ALBEDO(NT, NUM_SNOW_LAYERS, N_CONST_LANDICE4SNWALB, ITYPE, LAI, ZTH, & - RHOFRESH, 0.96, 0.68, 1.0, & ! + RHOFRESH, VISMAX, NIRMAX, SLOPE, & ! 0.96, 0.68, 1.0, & ! WESNN, HTSNN, SNDZN, & ! snow stuff LNDVR, LNDNR, LNDVF, LNDNF, & ! instantaneous snow-free albedos on tiles SNOVR, SNONR, SNOVF, SNONF, & ! instantaneous snow albedos on tiles @@ -3587,1838 +3588,6 @@ subroutine SOLVEICELAYER(NICE, dts, TICE, ICEDZ, UPPER_BND, & end subroutine SOLVEICELAYER -#if 0 - subroutine snowrt(N_sm, N_snow, & - t1,area,tkgnd,precip,snowf,ts,dts, eturb,dedtc,hsturb,dhsdtc, & - hlwtc,dhlwtc,desdtc,hlwout,raddn,zc1, & - wesn,htsnn,sndz,fices,tpsn, & - areasc,areasc0,pre,fhgnd,evap,shflux,lhflux,hcorr & - !, wesnsc, sndzsc, wesnprec, sndzprec, sndz1perc & - , sndzsc, wesnprec, sndzprec, sndz1perc & - , wesnperc, wesndens, wesnrepar, mltwtr & - , excs, drho0, wesnbot, tksno, dtss, maxsndepth, rhofs, & - pid, ktile) - -!********************************************************************* -! AUTHORS: M. Stieglitz, M. Suarez, R. Koster & S. Dery. -! VERSION: 2003b - This version last updated: 05/30/03. -!********* -! INPUTS: -!********* -! t1 : Temperature of catchment zones [C] -! ts : Air temperature [K] -! area : Fraction of snow-free area in each catchment zone [0-1] -! precip : Precipitation (Rain+snowfall) [kg/m^2/s == mm/s] -! snowf : Snowfall per unit area of catchment [kg/m^2/s == mm/s] -! dts : Time step [s] -! eturb : Evaporation per unit area of snow [kg/m^2/s == mm/s] -! dedtc : d(eturb)/d(ts) [kg/m^2/s/K] -! hsturb : Sensible heat flux per unit area of snow [W/m^2] -! dhsdtc : d(hsturb)/d(ts) [W/m^2/K] -! hlwtc : Emitted IR per unit area of snow [W/m^2] -! dhlwtc : d(hlwtc)/d(ts) [W/m^2/K] -! raddn : Net solar + incident terrestrial per unit area of snow [W/m^2] -! tkgnd : Thermal diffusivity of soil in catchment zones [W/m/K] -! zc1 : Half-thickness of top soil layer [m] -!*** Bin Zhao added ************************************************* -! maxsndepth : Maximum snow depth beyond which snow gets thrown away -!********* -! UPDATES: -!********* -! wesn : Layer water contents per unit area of catchment [kg/m^2] -! htsnn : Layer heat contents relative to liquid water at 0 C [J/m^2] -! sndz : Layer depths [m] -!********* -! OUTPUTS: -!********* -! tpsn : Layer temperatures [C] -! fices : Layer frozen fraction [0-1] -! areasc : Areal snow coverage at beginning of step [0-1] -! areasc0: Areal snow coverage at end of step [0-1] -! pre : Liquid water flow from snow base [kg/m^2/s] -! fhgnd : Heat flux at snow base at catchment zones [W/m^2] -! hlwout : Final emitted IR flux per unit area of snow [W/m^2] -! lhflux : Final latent heat flux per unit area of snow [W/m^2] -! shflux : Final sensible heat flux per unit area of snow [W/m^2] -! evap : Final evaporation per unit area of snow [kg/m^2/s] -!*** Bin Zhao added ************************************************* -! sndzsc : top layer thickness change due to sublimation/condensation -! wesnprec : top layer water content change due to precip (different from precip itself) -! sndzprec : top layer thickness change due to precip -! sndz1perc : top layer thickness change due to percolation -! wesnperc : layer water content change due to percolation -! wesndens : layer water content change due to densification -! wesnrepar : layer water content change due to relayer -! mltwtr : total melt water production rate -! excs : frozen part of water content from densification excess -! drho0 : layer density change due to densification -! wesnbot : excessive water content due to thickness exceeding maximum depth -! tksno : layer conductivity -! dtss : top layer temperature change -!********************************************************************* -! NOTA: By convention, wesn is representative for a catchment area -! equal to 1 whereas sndz is relative to the area covered by snow only. -!********************************************************************* - - - implicit none - -! real, parameter :: lhv = 2.4548E6 ! 2.5008e6 ! @ 0 C [J/kg] -! real, parameter :: lhs = 2.8368E6 ! 2.8434e6 ! @ 0 C [J/kg] -! real, parameter :: lhf = (lhs-lhv) ! @ 0 C [J/kg] - -!rr real, parameter :: cpw_liquid = 4185. ! [J/kg/K] - -! real, parameter :: tfrz = 273.16 ! @ 0 C [K] -! real, parameter :: rhofs = 150. ! [kg/m^3] -! real, parameter :: rhoma = 500. ! [kg/m^3] -! real, parameter :: rhow = 1000. ! [kg/m^3] -! real, parameter :: wemin = 13. ! [kg/m^2] - real, parameter :: snfr = 0.01 ! holding capacity - real, parameter :: small = 1.e-6 ! small number -! integer, parameter :: nlay = 3 ! number of layers -! integer, parameter :: N_sm = 3 ! number of zones -! real , parameter :: MIN_SNOW_MASS = .013 ! kg/M**2 equiv to 0.1% area - integer, parameter :: N_constit = 1 - - - integer, intent(in) :: N_sm, N_snow - - real, intent(in ) :: t1(N_sm),area(N_sm),tkgnd(N_sm) - real, intent(in ) :: ts,precip,snowf,dts,dedtc,raddn,hlwtc - real, intent(in ) :: dhsdtc,desdtc,dhlwtc,eturb,hsturb,zc1 - real, intent(inout):: wesn(N_snow),htsnn(N_snow),sndz(N_snow) - real, intent(out) :: tpsn(N_snow),fices(N_snow),fhgnd(N_sm) - real, intent(out) :: hlwout,lhflux,shflux,areasc0,evap,areasc,pre - - real, intent(out) :: wesnprec - !real, intent(out) :: wesnsc, wesnprec - real, intent(out) :: sndzsc, sndzprec - real, intent(out) :: sndz1perc - real, intent(out) :: wesnperc(N_snow) - real, intent(out) :: wesndens(N_snow) - real, intent(out) :: wesnrepar(N_snow) - real, intent(out) :: mltwtr - real, intent(out) :: excs(N_snow) - real, intent(out) :: drho0(N_snow) - real, intent(out) :: wesnbot - real, intent(out) :: tksno(N_snow) - real, intent(out) :: dtss - real, intent(in) :: maxsndepth - real, intent(in) :: rhofs - integer, intent(in) :: pid, ktile - -!Locals - real :: tsx, mass,snowd,rainf,denom,alhv,lhturb,dlhdtc,hcorr, & - enew,eold,tdum,fnew,tnew,icedens,densfac,hnew,scale,t1ave, & - flxnet,fdum,dw,waterin,waterout,snowin,snowout, mtwt, & - waterbal,precision,flow,term,dz,w(0:N_snow),HTSPRIME - real :: excsdz, excswe, sndzsum, melti - real, dimension(size(wesn) ) :: cmpc,dens - real, dimension(size(wesn) ) :: tksn - real, dimension(size(wesn) ) :: dtc,q,cl,cd,cr - real, dimension(size(wesn)+1) :: fhsn,df - real, dimension(size(wesn) ) :: htest,ttest,ftest - - logical, dimension(size(wesn) ) :: ice1,tzero, ice10,tzero0 - real :: topthick - real, dimension(size(wesn)-1) :: thickdist - real, dimension(size(wesn), N_constit):: rconstit - integer :: i,izone - logical :: logdum,kflag - - snowd = sum(wesn) - snowin = snowd - -!rr correction for "cold" snow - tsx = min(ts-tf,0.)*cpw - -!rr correction for heat content of rain -!rr tsx_rain = max(ts-tf,0.)*cpw_liquid - - df = 0. - dtc = 0. - tpsn = 0. - fices = 0. - areasc = 0. - areasc0= 0. - pre = 0. - fhgnd = 0. - hlwout = 0. - shflux = 0. - lhflux = 0. - evap = 0. - excs = 0. - hcorr = 0. - dens = rhofs - rainf = precip - snowf ! [kg/m^2/s] - - !wesnsc = 0. - sndzsc = 0. - wesnprec = 0. - sndzprec = 0. - sndz1perc = 0. - wesnperc = 0. - wesndens = 0. - wesnrepar = 0. - wesnbot = 0. - tksno = condice - dtss = 0. - excswe = 0. - - - rconstit = 0.0 - - if(snowd <= MINSWE) then ! no snow -! Assume initial (very small) snow water melts; new area is based -! on new snowfall - - areasc = min(snowd/wemin,1.) - areasc0 = 0. - pre = snowd/dts + areasc*rainf - wesn = 0. - hcorr = hcorr + raddn*areasc + sum(htsnn)/dts - htsnn = 0. - sndz = 0. - mltwtr = snowd/dts - - if(snowf > 0.) then ! only initialize with non-liquid part of precip - ! liquid part runs off (above) - - wesn = snowf*dts/float(N_snow) - htsnn = (tsx-alhm)*wesn - areasc0 = min((snowf*dts)/wemin,1.) - sndz = wesn/rhofs -! hcorr = hcorr - (tsx-alhm)*snowf ! randy - hcorr = hcorr - tsx*snowf ! randy - call FindTargetThickDist(N_snow, sndz, topthick, thickdist) - !call relayer(N_snow, htsnn, wesn, sndz) - call relayer2(N_snow, N_constit, topthick, thickdist, & - htsnn, wesn, sndz, rconstit, pid, ktile) - call get_tf_nd(N_snow, htsnn, wesn, tpsn, fices) - endif - - return ! if there was no snow at start of time step - - endif - - - call get_tf_nd(N_snow, htsnn, wesn, tpsn, fices) - mtwt = sum(wesn*(1.-fices)) - -!**** Determine the fractional snow coverage - - areasc = min(snowd/wemin,1.) - -!**** Set the mean density & diffusivity of the layers - - do i=1,N_snow - if(sndz(i) > 0) dens(i) = max(wesn(i)/(areasc*sndz(i)),rhofs) - enddo - tksn = 3.2217e-06*dens**2 - tksno = tksn - -!**** Determine temperature & frozen fraction of snow layers - - call get_tf_nd(N_snow, htsnn, wesn, tpsn, fices) - -!**** Calculate the ground-snow energy flux at 3 zones - - denom = 1./(sndz(N_snow)*0.5-zc1) - fhgnd = -sqrt(tkgnd*tksn(N_snow))*area*denom*(tpsn(N_snow)-t1) - fhsn(N_snow+1) = sum(fhgnd) - do i=1,N_sm - df(N_snow+1)=df(N_snow+1)-sqrt(tkgnd(i)*tksn(N_snow))*area(i)*denom - enddo - - -!**** Ensure against excessive heat flux between ground and snow: -!**** if heat flux found to cause the lowest snow layer temperature -!**** to "overshoot" (e.g. to become higher than the ground temperature -!**** when it had been lower), reduce the heat flux. If the lowest -!**** snow layer starts off at zero and the new temperature is greater -!**** than zero, reduce the heat flux to melt only half of the lowest -!**** layer snow. -!**** - t1ave=sum(t1*area)/sum(area) - htest=htsnn - htest(N_snow)=htest(N_snow)+fhsn(N_snow+1)*dts*areasc - - call get_tf_nd(N_snow, htest, wesn, ttest, ftest) - - scale=1. - if((t1ave-tpsn(N_snow))*(t1ave-ttest(N_snow)) .lt. 0.) then - scale=0.5*(tpsn(N_snow)-t1ave)/(tpsn(N_snow)-ttest(N_snow)) - endif - if(tpsn(N_snow) .eq. 0. .and. ttest(N_snow) .gt. 0. .and. & - abs(fhsn(N_snow+1)) .gt. 1.e-10) then - scale=(-0.5*htsnn(N_snow)/(dts*areasc))/fhsn(N_snow+1) - endif - - fhsn(N_snow+1)=fhsn(N_snow+1)*scale - df(N_snow+1)=df(N_snow+1)*scale - fhgnd=fhgnd*scale - - -!**** Calculate heat fluxes between snow layers. - - do i=2,N_snow - df(i) = -sqrt(tksn(i-1)*tksn(i))/((sndz(i-1)+sndz(i))*0.5) - fhsn(i)= df(i)*(tpsn(i-1)-tpsn(i)) - enddo - - -!**** Effective heat of vaporization includes bringing snow to 0 C - - alhv = alhe + alhm !randy -! alhv = alhe + fices(1)*alhm + tpsn(1)*cpw !randy - -!**** Initial estimate of latent heat flux change with Tc - - lhturb = alhv*eturb - dlhdtc = alhv*dedtc - -!**** Initial estimate of net surface flux & its change with Tc - - fhsn(1) = lhturb + hsturb + hlwtc - raddn - df(1) = -(dlhdtc + dhsdtc + dhlwtc) - -!**** Prepare array elements for solution & coefficient matrices. -!**** Terms are as follows: left (cl), central (cd) & right (cr) -!**** diagonal terms in coefficient matrix & solution (q) terms. - - do i=1,N_snow - - call get_tf0d(htsnn(i),wesn(i),tdum,fdum, ice1(i),tzero(i)) - - if(ice1(i)) then - cl(i) = df(i) - cd(i) = cpw*wesn(i)/dts - df(i) - df(i+1) - cr(i) = df(i+1) - q(i) = fhsn(i+1)-fhsn(i) - else - cl(i) = 0. - cd(i) = 1. - cr(i) = 0. - q(i) = 0. - endif - - enddo - - cl(1) = 0. - cr(N_snow) = 0. - - do i=1,N_snow-1 - if(.not.ice1(i)) cl(i+1) = 0. - enddo - - do i=2,N_snow - if(.not.ice1(i)) cr(i-1) = 0. - enddo - - -!**** Solve the tri-diagonal matrix for implicit change in Tc. - - call TRID(dtc,cl,cd,cr,q,N_snow) - -!**** Check temperature changes for passages across critical points,i.e. -!**** If implicit change has taken layer past melting/freezing, correct. - - do i=1,N_snow - if(tpsn(i)+dtc(i) > 0. .or. htsnn(i)+wesn(i)*cpw*dtc(i) > 0.) then - dtc(i)=-tpsn(i) - endif - if(.not.ice1(i)) dtc(i)=0. - enddo - -!**** Further adjustments; compute new values of h associated with -!**** all adjustments. - - eold=sum(htsnn) - - do i=1,N_snow - -!**** Quick check for "impossible" condition: - - if(.not.tzero(i) .and. .not.ice1(i)) then - write(*,*) 'bad snow condition: fice,tpsn =',fices(i),tpsn(i) - stop - endif - -!**** Condition 1: layer starts fully frozen (temp < 0.) - - if(.not.tzero(i)) then - tnew=tpsn(i)+dtc(i) - fnew=1. - - endif - -!**** Condition 2: layer starts with temp = 0, fices < 1. -! Corrections for flxnet calculation: Koster, March 18, 2003. - - if(.not.ice1(i)) then - tnew=0. - if(i==1) flxnet= fhsn(i+1)+df(i+1)*(dtc(i)-dtc(i+1)) & - -fhsn(i)-df(i)*dtc(i) - if(i > 1 .and. i < N_snow) flxnet= & - fhsn(i+1)+df(i+1)*(dtc(i)-dtc(i+1)) & - -fhsn(i)-df(i)*(dtc(i-1)-dtc(i)) - if(i==N_snow) flxnet=fhsn(i+1)+df(i+1)*dtc(i) & - -fhsn(i)-df(i)*(dtc(i-1)-dtc(i)) - HTSPRIME=HTSNN(I)+AREASC*FLXNET*DTS - call get_tf0d(HTSPRIME,wesn(i), tdum,fnew,logdum,logdum) - fnew=amax1(0., amin1(1., fnew)) - - endif - -!**** Condition 3: layer starts with temp = 0, fices = 1. -! Corrections for flxnet calculation: Koster, March 18, 2003. - - if(ice1(i) .and. tzero(i)) then - if(dtc(i) < 0.) then - tnew=tpsn(i)+dtc(i) - fnew=1. - endif - if(dtc(i) >= 0.) then - tnew=0. - if(i==1) flxnet=fhsn(i+1)+df(i+1)*(dtc(i)-dtc(i+1)) & - -fhsn(i)-df(i)*dtc(i) - if(i > 1 .and. i < N_snow) flxnet= & - fhsn(i+1)+df(i+1)*(dtc(i)-dtc(i+1)) & - -fhsn(i)-df(i)*(dtc(i-1)-dtc(i)) - if(i==N_snow) flxnet=fhsn(i+1)+df(i+1)*dtc(i) & - -fhsn(i)-df(i)*(dtc(i-1)-dtc(i)) - - HTSPRIME=HTSNN(I)+AREASC*FLXNET*DTS - call get_tf0d(HTSPRIME,wesn(i), tdum,fnew,logdum,logdum) - fnew=amax1(0., amin1(1., fnew)) - endif - endif - -!**** Now update heat fluxes & compute sublimation or deposition. - - if(i == 1) then - dtss = dtc(1) - lhflux = lhturb + dlhdtc*dtc(1) - shflux = hsturb + dhsdtc*dtc(1) - hlwout = hlwtc + dhlwtc*dtc(1) - evap = lhflux/alhv - dw = -evap*dts*areasc - if(-dw > wesn(1) ) then - dw = -wesn(1) - evap = -dw/(dts*areasc) -! shflux=shflux+(lhflux-evap*alhv) - hcorr=hcorr+(lhflux-evap*alhv)*areasc - lhflux=evap*alhv - endif - wesn(1) = wesn(1) + dw - denom = 1./dens(1) - if(dw > 0.) denom = 1./rhoma - sndz(1) = sndz(1) + dw*denom - !wesnsc = dw - sndzsc = dw*denom - endif - - if(i == N_snow) then - do izone=1,N_sm - fhgnd(izone)=fhgnd(izone)+area(izone)*df(N_snow+1)*dtc(N_snow) - enddo - endif - -!**** Now update thermodynamic quantities. - - htsnn(i)=(cpw*tnew-fnew*alhm)*wesn(i) - tpsn(i) = tnew - fices(i)= fnew - enddo - -!**** Store excess heat in hcorr. - - enew=sum(htsnn) - hcorr=hcorr-((enew-eold)/dts+areasc*(lhflux+shflux+hlwout-raddn) & - -areasc*(fhsn(N_snow+1)+df(N_snow+1)*dtc(N_snow)) & - ) - - call get_tf_nd(N_snow, htsnn, wesn, tpsn, fices) - - mltwtr = max(0., sum(wesn*(1.-fices)) - mtwt) - mltwtr = mltwtr / dts - -!rr!**** Add rainwater and snow at ts., bal. budget with shflux. -!rr (tried and failed 19 Jun 2003, reichle) -!rr -!rr wesn (1) = wesn (1) + (rainf*areasc+snowf)*dts -!rr htsnn(1) = htsnn(1) + (tsx -alhm)*(snowf*dts) + tsx_rain*rainf*dts -!rr sndz (1) = sndz (1) + (snowf/rhofs)*dts -!rr ! shflux = shflux + tsx*snowf ! randy -!rr hcorr = hcorr - (tsx-alhm)*snowf - tsx_rain*rainf ! randy - - -!**** Add rainwater at 0 C, snow at ts., bal. budget with shflux. - - wesn (1) = wesn (1) + (rainf*areasc+snowf)*dts - htsnn(1) = htsnn(1) + (tsx -alhm)*(snowf*dts) - sndz (1) = sndz (1) + (snowf/rhofs)*dts - wesnprec = (rainf*areasc+snowf)*dts - sndzprec = (snowf/rhofs)*dts -! shflux = shflux + tsx*snowf ! randy -! hcorr = hcorr - (tsx-alhm)*snowf ! randy - hcorr = hcorr - tsx*snowf ! randy - - snowd=sum(wesn) - - call get_tf_nd(N_snow, htsnn, wesn, tpsn, fices) - -!**** Move meltwater through the pack. -!**** Updated by Koster, August 27, 2002. - - pre = 0. - flow = 0. - - wesnperc = wesn - - do i=1,N_snow - - if(flow > 0.) then - wesn (i) = wesn(i) + flow - call get_tf_nd(N_snow, htsnn, wesn, tpsn, fices) - endif - - pre = max((1.-fices(i))*wesn(i), 0.) - flow = 0. - - if(snowd > wemin) then - - icedens=wesn(i)*fices(i)/(sndz(i)+1.e-20) - densfac=amax1(0., amin1(1., icedens/rhofs)) - term=densfac*snfr*(sndz(i)*rhow-wesn(i)*fices(i)) - - if(pre > term) then - pre = min(pre - term, wesn(i)) - wesn(i) = wesn(i) - pre - flow = pre - endif - else - wesn(i) = wesn(i) - pre - flow = pre - endif - -!**** Adjust top layer snow depth to get proper density values -!**** But limit this change for large throughflow (STEPH 06/19/03) - - if(i==1)then - dz=min(flow/dens(i),0.5*sndz(i)) - sndz(i)=sndz(i)-dz - sndz1perc = -dz - endif - enddo - - wesnperc = wesn - wesnperc - - pre = flow/dts - snowd=sum(wesn) - -!**** Update snow density by compaction (Pitman et al. 1991) - - excs = 0. - mass = 0. - w = 0. - drho0 = 0. - - wesndens = wesn - - if(snowd > wemin) then ! Compaction only after full coverage. - - do i=1,N_snow - dens(i) = rhofs - if(sndz(i)>0.) dens(i) = max(wesn(i)/(sndz(i)),rhofs) - enddo - - drho0 = dens - - cmpc = exp(14.643 - (4000./min(tpsn+tf,tf))-.02*dens) - - do i=1,N_snow - w(i) = wesn(i) - mass = mass + 0.5*(w(i)+w(i-1)) - dens(i) = dens(i)*(1. + (dts*0.5e-7*9.81)*mass*cmpc(i)) - -!**** Clip densities below maximum value, adjust quantities accordingly -!**** while conserving heat & mass (STEPH 06/21/03). - - if(dens(i) > rhoma) then - excs(i) = (dens(i)-rhoma)*sndz(i) - wesn(i) = wesn(i) - excs(i) - hnew = (cpw*tpsn(i)-fices(i)*alhm)*wesn(i) - hcorr= hcorr+(htsnn(i)-hnew)/dts - htsnn(i)= hnew - dens(i) = rhoma - endif - enddo - drho0 = dens - drho0 - endif - - wesndens = wesn - wesndens - - !pre = pre + sum(excs)/dts - pre = pre + sum(excs*(1.-fices))/dts - excs = excs * fices - sndz = wesn/dens - - sndzsum = sum(sndz) - if(sndzsum > maxsndepth) then - excsdz = sndzsum - maxsndepth - excswe = dens(N_snow) * excsdz - wesn(N_snow) = wesn(N_snow) - excswe - hnew = (cpw*tpsn(N_snow)-fices(N_snow)*alhm)*wesn(N_snow) - htsnn(N_snow)= hnew - sndz(N_snow) = sndz(N_snow) - excsdz - wesnbot = excswe - endif - -#if 0 - if(pid == TAR_PE .and. ktile == TAR_TILE)then - write(*,*) 'BEFORE RELAYER *********************' - write(*,*) (wesn(i), i=1,N_snow) - write(*,*) 'total swe = ', sum(wesn) - endif -#endif - -!**** Restore layers to sigma values. - - wesnrepar = wesn - - do i=1,N_snow - call get_tf0d(htsnn(i),wesn(i),tdum,fdum,ice10(i),tzero0(i)) - enddo - - call FindTargetThickDist(N_snow, sndz, topthick, thickdist) - - !call relayer(N_snow, htsnn, wesn, sndz) - call relayer2(N_snow, N_constit, topthick, thickdist, & - htsnn, wesn, sndz, rconstit, pid, ktile) - - wesnrepar = wesn - wesnrepar - -#if 0 - if(pid == TAR_PE .and. ktile == TAR_TILE)then - write(*,*) 'AFTER RELAYER *********************' - write(*,*) (wesn(i), i=1,N_snow) - write(*,*) 'total swe = ', sum(wesn) - endif -#endif - - call get_tf_nd(N_snow, htsnn, wesn, tpsn, fices) - -!**** Check that (ice10,tzero) conditions are conserved through -!**** relayering process (or at least that (fices,tpsn) conditions don't -!**** go through the (1,0) point); excess goes to hcorr. - - do i=1,N_snow - kflag=.false. - if(ice10(i).and.tzero0(i) .and. & - (fices(i) .ne. 1. .or. tpsn(i) .ne. 0.) ) kflag=.true. - if(.not.ice10(i).and.tzero0(i) .and. & - (fices(i) .eq. 1. .and. tpsn(i) .lt. 0.) ) kflag=.true. - if(ice10(i).and. .not.tzero0(i) .and. & - (fices(i) .ne. 1. .and. tpsn(i) .eq. 0.) ) kflag=.true. - - if(kflag) then - hnew=-alhm*wesn(i) - hcorr=hcorr+(htsnn(i)-hnew)/dts - htsnn(i)=hnew - tpsn(i)=0. - fices(i)=1. - endif - - enddo - - -!**** Reset fractional area coverage. - - areasc0 = min(sum(wesn)/wemin,1.) - -!**** Final check for water balance. - - waterin = (rainf*areasc+snowf)*dts + max(dw,0.) - waterout = pre*dts - min(dw,0.) - snowout = sum(wesn) + sum(excs) + excswe - waterbal = snowin + waterin - waterout - snowout - precision = snowout*small - if((waterbal > precision).and.(waterbal > small)) then -#if 0 - write(*,*) 'Warning: Imbalance in snow water budget!', waterbal - write(*,*) 'waterin = ', waterin - write(*,*) 'snowin = ', snowin - write(*,*) 'waterout = ', waterout - write(*,*) 'snowout = ', snowout - write(*,*) 'dw = ', dw - write(*,*) 'excswe = ', excswe - write(*,*) 'sum(excs) = ', sum(excs) - write(*,*) 'snowf*dts = ', snowf*dts - write(*,*) 'sum(wesn) = ', sum(wesn) - write(*,*) (wesn(i), i=1,N_snow) - write(*,*) 'pid = ', pid - write(*,*) 'ktile = ', ktile -#endif - stop - endif - - return ! end snow - - end subroutine snowrt - -! ********************************************************************** - - subroutine relayer(N_snow, htsnn, wesn, sndz) - - implicit none - integer, intent(in) :: N_snow - real, intent(inout) :: htsnn(N_snow),wesn(N_snow),sndz(N_snow) - - real, dimension(size(sndz),2) :: ds - real, dimension(size(sndz)) :: dovp - real, dimension(size(sndz)+1) :: sdold, sdnew - real, dimension(size(sndz)+1) :: sdoldr, sdnewr - real, dimension(size(sndz)+1,2) :: h, s - - integer :: i, j, n - integer :: kmax - real :: dzdiff, restthick, dzold - integer, dimension(size(sndz)) :: mark - - logical :: lth_satisfy - -! real, parameter :: dz1max = 0.08 ! [m] -! real, parameter :: wemin = 13.0 ! [kg/m2] - real, parameter :: small = 1.e-20 - real :: areasc,dz - -!**** Initialize some variables. - - h = 0. - s = 0. - ds = 0. - dz = 0. - - areasc = min(sum(wesn)/wemin,1.) - -!**** Compute specific heat & water contents of old layers. - - do i=1,N_snow - if (sndz(i) > 0.) then - h(i,1) = htsnn(i)/sndz(i) - h(i,2) = wesn(i)/sndz(i) - endif - enddo - -!**** Obtain old & new layer thicknesses & boundaries. - - sdold = 0. - sdnew = 0. - sdoldr = 0. - sdnewr = 0. - - do i=N_snow,1,-1 - sdold(i) = sdold(i+1) + sndz(i) - enddo - - do i=1,N_snow - sdoldr(i+1) = sdoldr(i) + sndz(i) - enddo - - sndz = sdold(1)/float(N_snow) - !sndz = sdold(N_snow+1)/float(N_snow) - - mark = 0 - do - lth_satisfy = .true. - do i=1,N_snow - if(mark(i) == 0 .and. sndz(i) > dzmax(i)) then - sndz(i) = dzmax(i) - mark(i) = 1 - lth_satisfy = .false. - endif - enddo - if(lth_satisfy) exit - dzdiff = 0.0 - do i=1,N_snow - if(mark(i) == 1) then - dzdiff = dzdiff + sndz(i) - endif - enddo - restthick = (sdold(1)-dzdiff)/float(N_snow-sum(mark)) - !restthick = (sdold(N_snow+1)-dzdiff)/float(N_snow-sum(mark)) - do i=1,N_snow - if(mark(i) == 0) then - sndz(i) = restthick - endif - enddo - enddo - - !kmax = 0 - !dzdiff = 0.0 - !do i=1,N_snow - ! if(sndz(i) > dzmax(i)) then - ! dzdiff = dzdiff + sndz(i) - dzmax(i) - ! sndz(i) = dzmax(i) - ! kmax = kmax + 1 - ! endif - !enddo - - !sndz(kmax+1:) = (sdold(1)-sum(sndz(1:kmax)))/float(N_snow-kmax) - - do i=N_snow,1,-1 - sdnew(i) = sdnew(i+1) + sndz(i) - enddo - do i=1,N_snow - sdnewr(i+1) = sdnewr(i) + sndz(i) - enddo - -!**** Since the snow boundary has moved, redistribute heat -! contents & water equivalents of old to new snow layers. - - dzold = 0.0 - - do i=1,N_snow - - j = i - dz=sdnew(i+1)-sdold(i+1) - !dz=sdold(i+1)-sdnew(i+1) - if(dz < 0.) j = i + 1 - if(dzold > sndz(i)) then - call FindOverlap(N_snow, i, sdoldr, sdnewr, dz, dovp) - do n=1,N_snow - s(i+1,:) = s(i+1,:) + h(n,:) * dovp(n) - enddo - else - s(i+1,:) = h(j,:)*dz - endif - dzold = dz - ds(i,:) = s(i,:) - s(i+1,:) - enddo - - htsnn = htsnn + ds(:,1) - wesn = wesn + ds(:,2) - - if(sum(wesn) < wemin) sndz = sndz /(areasc + small) - return - - end subroutine relayer - -! ********************************************************************** - - subroutine FindOverlap(N, m, sdoldr, sdnewr, dz, dovp) - - implicit none - real, parameter :: epsil = 1.e-6 - integer, intent(in) :: N, m - real, intent(in), dimension(N+1) :: sdoldr, sdnewr - real, intent(in) :: dz - real, intent(out), dimension(N) :: dovp - - real y1, y2 - integer i, j, k, ks, ke - - - dovp = 0.0 - - y1 = sdnewr(m+1) - y2 = y1 + dz - - do k=1,N - if((y1-sdoldr(k))>epsil) ks = k - if((y2-sdoldr(k))>epsil) ke = k - enddo - - dovp(ks) = sdoldr(ks+1) - y1 - y2 = y1 - do k=ks+1, ke - y2 = y2+dovp(k-1) - dovp(k) = sdoldr(k+1) - y2 - enddo - !if(m==2) then - ! write(*,*) (dovp(k), k=1,N) - !endif - end subroutine FindOverlap - - -! ********************************************************************** - - subroutine FindTargetThickDist(N_snow, sndz, topthick, thickdist) - - integer, intent(in) :: N_snow - real, intent(in) :: sndz(N_snow) - real, intent(out) :: topthick - real, intent(out), dimension(N_snow-1) :: thickdist - - - real, dimension(N_snow) :: sndzt - real :: totald, dzdiff, restthick - integer :: i - integer, dimension(N_snow) :: mark - logical :: lth_satisfy - - totald = sum(sndz) - sndzt = totald/float(N_snow) - - mark = 0 - do - lth_satisfy = .true. - do i=1,N_snow - if(mark(i) == 0 .and. sndzt(i) > dzmax(i)) then - sndzt(i) = dzmax(i) - mark(i) = 1 - lth_satisfy = .false. - endif - enddo - if(lth_satisfy) exit - dzdiff = 0.0 - do i=1,N_snow - if(mark(i) == 1) then - dzdiff = dzdiff + sndzt(i) - endif - enddo - restthick = (totald-dzdiff)/float(N_snow-sum(mark)) - do i=1,N_snow - if(mark(i) == 0) then - sndzt(i) = restthick - endif - enddo - enddo - - topthick = sndzt(1) - totald = totald - topthick - do i=2,N_snow - thickdist(i-1) = sndzt(i)/totald - enddo - - return - - end subroutine FindTargetThickDist - - -! ********************************************************************** - - subroutine relayer2(N_snow, N_constit, thick_toplayer, thickdist, & - htsnn, wesn, sndz, rconstit, pid, ktile) - - implicit none - integer, intent(in) :: N_snow, N_constit - real, intent(in) :: thick_toplayer - real, intent(in), dimension(N_snow-1) :: thickdist - real, intent(inout) :: htsnn(N_snow),wesn(N_snow),sndz(N_snow) - real, intent(inout) :: rconstit(N_snow,N_constit) - integer, intent(in) :: pid, ktile - - real, dimension(size(sndz),2+N_Constit) :: h, s - - integer :: i, j, k, ilow, ihigh - -! real, parameter :: dz1max = 0.08 ! [m] -! real, parameter :: wemin = 13.0 ! [kg/m2] - real, parameter :: small = 1.e-20 - real :: areasc,dz - - real :: totalthick - real, dimension(size(sndz)) :: thickness, tol_old, bol_old, tol_new, & - bol_new - -!**** thick_toplayer: the assigned (final) thickness of the topmost layer (m) -!**** thickdist: the assigned (final) distribution of thickness in layers -!**** 2 through N_snow, in terms of fraction -!**** h: array holding specific heat, water, and constituent contents -!**** s: array holding the total and final heat, water, and constit. contents -!**** ilow: first layer used in a particular relayering calculation -!**** ihigh: final layer used in a particular relayering calculation -!**** totalthick: total thickness of layers 2 through N_snow -!**** thickness: array holding final thicknesses (m) of the snow layers -!**** tol_old(i): depth (from surface) of the top of layer i, before & -!**** relayering -!**** bol_old(i): depth (from surface) of the bottom of layer i, before & -!**** relayering -!**** tol_old(i): depth (from surface) of the top of layer i, after & -!**** relayering -!**** bol_old(i): depth (from surface) of the bottom of layer i, after & -!**** relayering - - - thickness(1)=thick_toplayer - - totalthick=sum(sndz)-thick_toplayer - do i=1,N_snow-1 - thickness(i+1)=thickdist(i)*totalthick - enddo - -#if 0 - if(pid == TAR_PE .and. ktile == TAR_TILE)then - write(*,*) 'RELAYER2 A. *********************' - write(*,*) (sndz(i), i=1,N_snow) - write(*,*) 'total sndz = ', sum(sndz) - write(*,*) (thickness(i), i=1,N_snow) - write(*,*) 'total thickness = ', sum(thickness) - endif -#endif - -!**** Initialize some variables. - - h = 0. - s = 0. - dz = 0. - - areasc = min(sum(wesn)/wemin,1.) - -!**** Compute specific heat & water contents of old layers. - - do i=1,N_snow - if (sndz(i) > 0.) then - h(i,1) = htsnn(i)/sndz(i) - h(i,2) = wesn(i)/sndz(i) - do k=1,N_Constit - h(i,2+k)=rconstit(i,k)/sndz(i) - enddo - endif - enddo - -!**** Determine old and new boundary depths (cumulative from top) -!**** (tol refers to "top of layer", bol refers to "bottom of layer" - - tol_old(1)=0. - bol_old(1)=sndz(1) - tol_new(1)=0. - bol_new(1)=thickness(1) - - do i=2,N_snow - tol_old(i)=bol_old(i-1) - bol_old(i)=bol_old(i-1)+sndz(i) - tol_new(i)=bol_new(i-1) - bol_new(i)=bol_new(i-1)+thickness(i) - enddo - -!**** Redistribute quantities - -!**** Step 1: Do top layer - ihigh=1 - do k=1,N_snow - if(bol_old(k) .lt. bol_new(1)) ihigh=k+1 - enddo - - do k=1,ihigh - if(k .lt. ihigh) dz=sndz(k) - if(k .eq. ihigh) dz=bol_new(1)-tol_old(k) - !s(1,:)=s(1,:)+h(1,:)*dz - s(1,:)=s(1,:)+h(k,:)*dz -#if 0 - if(pid == TAR_PE .and. ktile == TAR_TILE)then - write(*,*) 'RELAYER2 B. *********************' - write(*,*) 'k = ', k, ' dz = ',dz, h(k,2) - endif -#endif - enddo -#if 0 - if(pid == TAR_PE .and. ktile == TAR_TILE)then - write(*,*) 'RELAYER2 C. *********************' - write(*,*) 'ihigh = ', ihigh - endif -#endif - - -!**** Step 2: Do remaining layers - do i=2,N_snow - - ilow=ihigh -#if 0 - if(pid == TAR_PE .and. ktile == TAR_TILE)then - write(*,*) 'i = ', i, 'ihigh = ', ihigh, ' ilow = ', ilow - endif -#endif - do k=ilow,N_snow - if(bol_old(k) .lt. bol_new(i)) ihigh=k+1 -#if 0 - if(pid == TAR_PE .and. ktile == TAR_TILE)then - write(*,*) 'i = ', i, ' k = ', k, 'ihigh = ', ihigh - write(*,*) 'i = ', i, ' k = ', k, bol_old(k), bol_new(i) - endif -#endif - enddo - - !if(ihigh .gt. N_snow) then - ! print*, i, ihigh, ilow - ! do k=1,N_snow - ! print*, 'k = ', k, sndz(k), thickness(k), bol_old(k), bol_new(k) - ! enddo - ! do k=1,N_snow-1 - ! print*, 'k = ', k, thickdist(k) - ! enddo - ! stop - ! print*, 'pid = ', pid, ' ktile = ',ktile - !endif -#if 0 - if(pid == TAR_PE .and. ktile == TAR_TILE)then - write(*,*) 'i = ', i, 'ihigh = ', ihigh, ' ilow = ', ilow - endif -#endif - if(ihigh .eq. N_snow+1) ihigh=N_snow ! Account for potential truncation problem - - do k=ilow,ihigh - if(k .eq. ilow .and. k .lt. ihigh) dz=bol_old(k)-tol_new(i) - if(k .eq. ilow .and. k .eq. ihigh) dz=bol_new(i)-tol_new(i) - if(k .gt. ilow .and. k .lt. ihigh) dz=bol_old(k)-tol_old(k) - if(k .gt. ilow .and. k .eq. ihigh) dz=bol_new(i)-tol_old(k) - s(i,:)=s(i,:)+h(k,:)*dz -#if 0 - if(pid == TAR_PE .and. ktile == TAR_TILE)then - write(*,*) 'i = ', i, ' k = ', k, ' dz = ',dz, h(k,2) - endif -#endif - enddo - - enddo - - - htsnn = s(:,1) - wesn = s(:,2) - do k=1,N_Constit - rconstit(:,k)=s(:,2+k) - enddo - sndz=thickness - - if(sum(wesn) < wemin) sndz = sndz /(areasc + small) - return - - end subroutine relayer2 - - -! ********************************************************************** - - subroutine get_tf0d(h,w,t,f,ice1,tzero) - - implicit none - - real, parameter :: cpw = 2065.22 ! @ 0 C [J/kg/K] -! real, parameter :: lhv = 2.4548E6 ! 2.5008e6 ! @ 0 C [J/kg] -! real, parameter :: lhs = 2.8368E6 ! 2.8434e6 ! @ 0 C [J/kg] -!rr real, parameter :: lhv = 2.5008e6 ! @ 0 C [J/kg] -!rr real, parameter :: lhs = 2.8434e6 ! @ 0 C [J/kg] -! real, parameter :: lhf = (lhs-lhv) ! @ 0 C [J/kg] - real, parameter :: tfac=1./cpw - real, parameter :: ffac=1./alhm - - real, intent(in ) :: w, h - real, intent(out) :: t, f - - logical, intent(out) :: ice1,tzero - - real :: hbw - - hbw=0. - if(w > 0.) hbw = h/w - - if(hbw < -1.00001*alhm) then - t = (hbw+alhm)*tfac - f = 1. - ice1=.true. - tzero=.false. - elseif(hbw > -0.99999*alhm) then - t = 0. - f =-hbw*ffac - ice1=.false. - tzero=.true. - else - t = 0. - f = 1. - ice1=.true. - tzero=.true. - endif - - if(f < 0.) then - t = hbw*tfac - f = 0. - endif - - if(w == 0.) then - t = 0. - f = 0. - endif - - return - - end subroutine get_tf0d - -! ********************************************************************** - - subroutine get_tf_nd(N,h,w,t,f) - -! n-dimensional version of get_tf -! -! avoid slow "where" statements -! -! can be called for any number of layers or catchments, for example - -! 1.) call get_tf_nd( ncatm, htsnn1(1:ncatm), wesn1(1:ncatm), -! tpsn(1:ncatm),f(1:ncatm) ) -! -! 2.) call get_tf_nd(N_snow, h, w, t, f) - -! reichle, 22 Aug 2002 -! reichle, 29 Apr 2003 (updated parameter values) - - integer, intent(in) :: N - - real, dimension(n), intent(in) :: h, w - real, dimension(n), intent(out) :: t, f - -! local variables - - real, parameter :: cpw = 2065.22 ! @ 0 C [J/kg/K] -! real, parameter :: lhv = 2.4548E6 ! 2.5008e6 ! @ 0 C [J/kg] -! real, parameter :: lhs = 2.8368E6 ! 2.8434e6 ! @ 0 C [J/kg] -!rr real, parameter :: lhv = 2.5008e6 ! @ 0 C [J/kg] -!rr real, parameter :: lhs = 2.8434e6 ! @ 0 C [J/kg] -! real, parameter :: lhf = (lhs-lhv) ! @ 0 C [J/kg] - real, parameter :: tfac=1./cpw - real, parameter :: ffac=1./alhm - - integer :: i - - real :: hbw - - do i=1,N - - if(w(i) .gt. 0.0) then - hbw = h(i)/w(i) - else - hbw = 0. - endif - - if(hbw .lt. -alhm) then - t(i) = (hbw+alhm)*tfac - f(i) = 1. - elseif(hbw .gt. -alhm) then - t(i) = 0. - f(i) = -hbw*ffac - else - t(i) = 0. - f(i) = 1. - endif - - if(f(i) .lt. 0.) then - t(i) = hbw*tfac - f(i) = 0. - endif - - if(w(i) .eq. 0.) then - t(i) = 0. - f(i) = 0. - endif - - end do - - return - - end subroutine get_tf_nd - -! ********************************************************************** - - SUBROUTINE TRID(X,DD,D,RD,B,N) - IMPLICIT NONE - - INTEGER,INTENT(IN) :: N - REAL*4, INTENT(IN), DIMENSION(N) :: DD, RD - REAL*4, INTENT(INOUT), DIMENSION(N) :: D, B - REAL*4, INTENT(OUT),DIMENSION(N) :: X - - integer I,J - real*4 RSF - RSF=0. - DO 10 I=2,N - J=N+1-I - if(D(J+1).ne.0.) RSF=RD(J)/D(J+1) - D(J)=D(J)-DD(J+1)*RSF - 10 B(J)=B(J)- B(J+1)*RSF - if(D(1).ne.0.) X(1)=B(1)/D(1) - DO 20 J=2,N - 20 if(D(J).ne.0.) X(J)=(B(J)-DD(J)*X(J-1))/D(J) - RETURN - END SUBROUTINE TRID - - SUBROUTINE SIBALB ( & - NCH, ITYP, VLAI, VGRN, ZTH, & - SCALVDR,SCALVDF,SCALIDR,SCALIDF, & - WESN,SNDZ, & - AVISDR, ANIRDR, AVISDF, ANIRDF, & - ASNVDR, ASNNDR, ASNVDF, ASNNDF & - ) - - IMPLICIT NONE - -! OUTPUTS: -! AVISDR: visible, direct albedo. -! ANIRDR: near infra-red, direct albedo. -! AVISDF: visible, diffuse albedo. -! ANIRDF: near infra-red, diffuse albedo. - -! INPUTS: -! SCALVDR: MODIS scale factor for visible, direct. -! SCALVDF: MODIS scale factor for visible, diffuse. -! SCALIDR: MODIS scale factor for NIR, direct. -! SCALIDF: MODIS scale factor for NIR, diffuse. -! VLAI: the leaf area index. -!VGRN: the greenness index. -! ZTH: The cosine of the solar zenith angle. -! SNW: Snow cover in meters water equivalent. - - - INTEGER, INTENT(IN) :: NCH - INTEGER, INTENT(IN), DIMENSION(NCH) :: ITYP - REAL, INTENT(IN), DIMENSION(NCH) :: SCALVDR,SCALVDF,SCALIDR,SCALIDF, & - VLAI, VGRN, ZTH - REAL, INTENT(IN), DIMENSION(:,:) :: WESN, SNDZ - REAL, INTENT(OUT), DIMENSION(NCH) :: AVISDR, ANIRDR, AVISDF, & - ANIRDF, ASNVDR, ASNNDR, ASNVDF, ASNNDF - - - REAL, PARAMETER :: ALVDRS = 0.100 - REAL, PARAMETER :: ALIDRS = 0.200 - REAL, PARAMETER :: ALVDRD = 0.300 - REAL, PARAMETER :: ALIDRD = 0.350 - REAL, PARAMETER :: ALVDRI = 0.700 - REAL, PARAMETER :: ALIDRI = 0.700 - - -! REAL, PARAMETER :: WEMIN = 13.0 ! [KG/M2] - -! ALVDRS: Albedo of soil for visible direct solar radiation. -! ALIDRS: Albedo of soil for infra-red direct solar radiation. -! ALVDFS: Albedo of soil for visible diffuse solar radiation. -! ALIDFS: Albedo of soil for infra-red diffuse solar radiation. - - INTEGER, PARAMETER :: NLAI = 14 - - REAL, PARAMETER :: EPSLN = 1.E-6 - REAL, PARAMETER :: BLAI = 0.5 - REAL, PARAMETER :: DLAI = 0.5 - - REAL, PARAMETER :: ALATRM = BLAI + (NLAI - 1) * DLAI - EPSLN - - INTEGER, PARAMETER :: NTYPS_SIB=9 - - REAL :: SWE, TOTDEP, AREASC, DENSITY, DENS_EXC, FRACV, SNWMASK, & - AMASK, ASNVDR_VEG, ASNNDR_VEG, ASNVDF_VEG, ASNNDF_VEG - REAL GK_B - - - - - -! ITYP: Vegetation type as follows: -! 1: BROADLEAF EVERGREEN TREES -! 2: BROADLEAF DECIDUOUS TREES -! 3: NEEDLELEAF TREES -! 4: GROUND COVER -! 5: BROADLEAF SHRUBS -! 6: DWARF TREES (TUNDRA) -! 7: BARE SOIL -! 8: DESERT -! 9: ICE -! NCH: Chip index -! - - INTEGER I, LAI - REAL FAC, GAMMA, BETA, ALPHA, DX, DY, ALA, FVEG - REAL, DIMENSION(2) :: GRN - REAL, DIMENSION(4,NTYPS_SIB) :: SNWALB (4, NTYPS_SIB) - REAL, DIMENSION(NTYPS_SIB) :: SNWMSK - - - DATA GRN /0.33, 0.67/ - !REAL, PARAMETER :: SNWALB_VISMAX = 1.0 - REAL, PARAMETER :: SNWALB_VISMAX = 0.921 ! matches GK94 - REAL, PARAMETER :: SNWALB_VISMIN = 0.5 - !REAL, PARAMETER :: SNWALB_NIRMAX = 0.8 - REAL, PARAMETER :: SNWALB_NIRMAX = 0.725 ! matches GK94 - REAL, PARAMETER :: SNWALB_NIRMIN = 0.3 -! REAL, PARAMETER :: RHOFS = 150. ! DENSITY OF FRESH SNOW - REAL, DIMENSION(NTYPS_SIB) :: SNWMID - -! DATA SNWALB/.85, .50, .85, .50, & -! .85, .50, .85, .50, & -! .85, .50, .85, .50, & -! .85, .50, .85, .50, & -! .85, .50, .85, .50, & -! .85, .50, .85, .50, & -! .85, .50, .85, .50, & -! .85, .50, .85, .50, & -! .85, .50, .85, .50 & -! / - -! DATA SNWMSK/25., 5., 10., 0.2, 0.5, 0.2, 0.1, 0.1, 0.1/ - -!*** grassland and tundra values arbitrarily increased. - DATA SNWMID /50.,30.,45.,20.,30.,20.,2.,2.,2./ - - - - -! [ Definition of Functions: ] -! -! REAL COEFFSIB - -! -------------------------------------------------- - - - -! Constants used in albedo calculations: - - REAL ALVDR (NLAI, 2, NTYPS_SIB) - REAL BTVDR (NLAI, 2, NTYPS_SIB) - REAL GMVDR (NLAI, 2, NTYPS_SIB) - REAL ALIDR (NLAI, 2, NTYPS_SIB) - REAL BTIDR (NLAI, 2, NTYPS_SIB) - REAL GMIDR (NLAI, 2, NTYPS_SIB) - -! (Data statements for ALVDR described in full; data statements for -! other constants follow same framework.) - - -! BROADLEAF EVERGREEN (ITYP=4); GREEN=0.33; LAI: .5-7 - DATA (ALVDR (I, 1, 1), I = 1, 14) & - /0.0808, 0.0796, 0.0792, 0.0790, 10*0.0789/ - -! BROADLEAF EVERGREEN (ITYP=4); GREEN=0.67; LAI: .5-7 - DATA (ALVDR (I, 2, 1), I = 1, 14) & - /0.0788, 0.0775, 0.0771, 0.0769, 10*0.0768/ - -! BROADLEAF DECIDUOUS (ITYP=1); GREEN=0.33; LAI: .5-7 - DATA (ALVDR (I, 1, 2), I = 1, 14) & - /0.0803, 0.0790, 0.0785, 0.0784, 3*0.0783, 7*0.0782/ - -! BROADLEAF DECIDUOUS (ITYP=1); GREEN=0.67; LAI: .5-7 - DATA (ALVDR (I, 2, 2), I = 1, 14) & - /0.0782, 0.0770, 0.0765, 0.0763, 10*0.0762/ - -! NEEDLELEAF (ITYP=3); GREEN=0.33; LAI=.5-7 - DATA (ALVDR (I, 1, 3), I = 1, 14) & - /0.0758, 0.0746, 0.0742, 0.0740, 10*0.0739/ - -! NEEDLELEAF (ITYP=3); GREEN=0.67; LAI=.5-7 - DATA (ALVDR (I, 2, 3), I = 1, 14) & - /0.0683, 0.0672, 0.0667, 2*0.0665, 9*0.0664/ - -! GROUNDCOVER (ITYP=2); GREEN=0.33; LAI=.5-7 - DATA (ALVDR (I, 1, 4), I = 1, 14) & - /0.2436, 0.2470, 0.2486, 0.2494, 0.2498, 0.2500, 2*0.2501, & - 6*0.2502 / - -! GROUNDCOVER (ITYP=2); GREEN=0.67; LAI=.5-7 - DATA (ALVDR (I, 2, 4), I = 1, 14) /14*0.1637/ - -! BROADLEAF SHRUBS (ITYP=5); GREEN=0.33,LAI=.5-7 - DATA (ALVDR (I, 1, 5), I = 1, 14) & - /0.0807, 0.0798, 0.0794, 0.0792, 0.0792, 9*0.0791/ - -! BROADLEAF SHRUBS (ITYP=5); GREEN=0.67,LAI=.5-7 - DATA (ALVDR (I, 2, 5), I = 1, 14) & - /0.0787, 0.0777, 0.0772, 0.0771, 10*0.0770/ - -! DWARF TREES, OR TUNDRA (ITYP=6); GREEN=0.33,LAI=.5-7 - DATA (ALVDR (I, 1, 6), I = 1, 14) & - /0.0802, 0.0791, 0.0787, 0.0786, 10*0.0785/ - -! DWARF TREES, OR TUNDRA (ITYP=6); GREEN=0.67,LAI=.5-7 - DATA (ALVDR (I, 2, 6), I = 1, 14) & - /0.0781, 0.0771, 0.0767, 0.0765, 0.0765, 9*0.0764/ - - -! BARE SOIL - DATA (ALVDR (I, 1, 7), I = 1, 14) /14*ALVDRS/ - DATA (ALVDR (I, 2, 7), I = 1, 14) /14*ALVDRS/ - -! DESERT - DATA (ALVDR (I, 1, 8), I = 1, 14) /14*ALVDRD/ - DATA (ALVDR (I, 2, 8), I = 1, 14) /14*ALVDRD/ - -! ICE - DATA (ALVDR (I, 1, 9), I = 1, 14) /14*ALVDRI/ - DATA (ALVDR (I, 2, 9), I = 1, 14) /14*ALVDRI/ -!**** -!**** ------------------------------------------------- - DATA (BTVDR (I, 1, 1), I = 1, 14) & - /0.0153, 0.0372, 0.0506, 0.0587, 0.0630, 0.0652, 0.0663, & - 0.0668, 0.0671, 0.0672, 4*0.0673 / - DATA (BTVDR (I, 2, 1), I = 1, 14) & - /0.0135, 0.0354, 0.0487, 0.0568, 0.0611, 0.0633, 0.0644, & - 0.0650, 0.0652, 0.0654, 0.0654, 3*0.0655 / - DATA (BTVDR (I, 1, 2), I = 1, 14) & - /0.0148, 0.0357, 0.0462, 0.0524, 0.0554, 0.0569, 0.0576, & - 0.0579, 0.0580, 0.0581, 0.0581, 3*0.0582 / - DATA (BTVDR (I, 2, 2), I = 1, 14) & - /0.0131, 0.0342, 0.0446, 0.0508, 0.0539, 0.0554, 0.0560, & - 0.0564, 0.0565, 5*0.0566 / - DATA (BTVDR (I, 1, 3), I = 1, 14) & - /0.0108, 0.0334, 0.0478, 0.0571, 0.0624, 0.0652, 0.0666, & - 0.0673, 0.0677, 0.0679, 4*0.0680 / - DATA (BTVDR (I, 2, 3), I = 1, 14) & - /0.0034, 0.0272, 0.0408, 0.0501, 0.0554, 0.0582, 0.0597, & - 0.0604, 0.0608, 0.0610, 4*0.0611 / - DATA (BTVDR (I, 1, 4), I = 1, 14) & - /0.2050, 0.2524, 0.2799, 0.2947, 0.3022, 0.3059, 0.3076, & - 0.3085, 0.3088, 0.3090, 4*0.3091 / - DATA (BTVDR (I, 2, 4), I = 1, 14) & - /0.1084, 0.1404, 0.1617, 0.1754, 0.1837, 0.1887, 0.1915, & - 0.1931, 0.1940, 0.1946, 0.1948, 0.1950, 2*0.1951 / - DATA (BTVDR (I, 1, 5), I = 1, 14) & - /0.0203, 0.0406, 0.0548, 0.0632, 0.0679, 0.0703, 0.0716, & - 0.0722, 0.0726, 0.0727, 0.0728, 0.0728, 0.0728, 0.0729 / - DATA (BTVDR (I, 2, 5), I = 1, 14) & - /0.0184, 0.0385, 0.0526, 0.0611, 0.0658, 0.0683, 0.0696, & - 0.0702, 0.0705, 0.0707, 4*0.0708 / - DATA (BTVDR (I, 1, 6), I = 1, 14) & - /0.0199, 0.0388, 0.0494, 0.0554, 0.0584, 0.0599, 0.0606, & - 0.0609, 0.0611, 5*0.0612 / - DATA (BTVDR (I, 2, 6), I = 1, 14) & - /0.0181, 0.0371, 0.0476, 0.0537, 0.0568, 0.0583, 0.0590, & - 0.0593, 0.0595, 0.0595, 4*0.0596 / - DATA (BTVDR (I, 1, 7), I = 1, 14) /14*0./ - DATA (BTVDR (I, 2, 7), I = 1, 14) /14*0./ - DATA (BTVDR (I, 1, 8), I = 1, 14) /14*0./ - DATA (BTVDR (I, 2, 8), I = 1, 14) /14*0./ - DATA (BTVDR (I, 1, 9), I = 1, 14) /14*0./ - DATA (BTVDR (I, 2, 9), I = 1, 14) /14*0./ - -!**** -!**** ----------------------------------------------------------- - DATA (GMVDR (I, 1, 1), I = 1, 14) & - /0.0814, 0.1361, 0.2078, 0.2650, 0.2986, 0.3169, 0.3265, & - 0.3313, 0.3337, 0.3348, 0.3354, 0.3357, 2*0.3358 / - DATA (GMVDR (I, 2, 1), I = 1, 14) & - /0.0760, 0.1336, 0.2034, 0.2622, 0.2969, 0.3159, 0.3259, & - 0.3309, 0.3333, 0.3346, 0.3352, 0.3354, 2*0.3356 / - DATA (GMVDR (I, 1, 2), I = 1, 14) & - /0.0834, 0.1252, 0.1558, 0.1927, 0.2131, 0.2237, 0.2290, & - 0.2315, 0.2327, 0.2332, 0.2335, 2*0.2336, 0.2337 / - DATA (GMVDR (I, 2, 2), I = 1, 14) & - /0.0789, 0.1235, 0.1531, 0.1912, 0.2122, 0.2232, 0.2286, & - 0.2312, 0.2324, 0.2330, 0.2333, 0.2334, 2*0.2335 / - DATA (GMVDR (I, 1, 3), I = 1, 14) & - /0.0647, 0.1342, 0.2215, 0.2968, 0.3432, 0.3696, 0.3838, & - 0.3912, 0.3950, 0.3968, 0.3978, 0.3982, 0.3984, 0.3985 / - DATA (GMVDR (I, 2, 3), I = 1, 14) & - /0.0258, 0.1227, 0.1999, 0.2825, 0.3339, 0.3634, 0.3794, & - 0.3877, 0.3919, 0.3940, 0.3950, 0.3956, 0.3958, 0.3959 / - DATA (GMVDR (I, 1, 4), I = 1, 14) & - /0.3371, 0.5762, 0.7159, 0.7927, 0.8324, 0.8526, 0.8624, & - 0.8671, 0.8693, 0.8704, 0.8709, 0.8710, 2*0.8712 / - DATA (GMVDR (I, 2, 4), I = 1, 14) & - /0.2634, 0.4375, 0.5532, 0.6291, 0.6763, 0.7048, 0.7213, & - 0.7310, 0.7363, 0.7395, 0.7411, 0.7420, 0.7426, 0.7428 / - DATA (GMVDR (I, 1, 5), I = 1, 14) & - /0.0971, 0.1544, 0.2511, 0.3157, 0.3548, 0.3768, 0.3886, & - 0.3948, 0.3978, 0.3994, 0.4001, 0.4006, 0.4007, 0.4008 / - DATA (GMVDR (I, 2, 5), I = 1, 14) & - /0.0924, 0.1470, 0.2458, 0.3123, 0.3527, 0.3756, 0.3877, & - 0.3942, 0.3974, 0.3990, 0.3998, 0.4002, 0.4004, 0.4005 / - DATA (GMVDR (I, 1, 6), I = 1, 14) & - /0.0970, 0.1355, 0.1841, 0.2230, 0.2447, 0.2561, 0.2617, & - 0.2645, 0.2658, 0.2664, 0.2667, 3*0.2669 / - DATA (GMVDR (I, 2, 6), I = 1, 14) & - /0.0934, 0.1337, 0.1812, 0.2213, 0.2437, 0.2554, 0.2613, & - 0.2642, 0.2656, 0.2662, 0.2665, 0.2667, 0.2667, 0.2668 / - DATA (GMVDR (I, 1, 7), I = 1, 14) /14*1./ - DATA (GMVDR (I, 2, 7), I = 1, 14) /14*1./ - DATA (GMVDR (I, 1, 8), I = 1, 14) /14*1./ - DATA (GMVDR (I, 2, 8), I = 1, 14) /14*1./ - DATA (GMVDR (I, 1, 9), I = 1, 14) /14*1./ - DATA (GMVDR (I, 2, 9), I = 1, 14) /14*1./ - -!**** -!**** ----------------------------------------------------------- - - DATA (ALIDR (I, 1, 1), I = 1, 14) & - /0.2867, 0.2840, 0.2828, 0.2822, 0.2819, 0.2818, 2*0.2817, & - 6*0.2816 / - DATA (ALIDR (I, 2, 1), I = 1, 14) & - /0.3564, 0.3573, 0.3577, 0.3580, 2*0.3581, 8*0.3582 / - DATA (ALIDR (I, 1, 2), I = 1, 14) & - /0.2848, 0.2819, 0.2804, 0.2798, 0.2795, 2*0.2793, 7*0.2792 / - DATA (ALIDR (I, 2, 2), I = 1, 14) & - /0.3544, 0.3550, 0.3553, 2*0.3555, 9*0.3556 / - DATA (ALIDR (I, 1, 3), I = 1, 14) & - /0.2350, 0.2311, 0.2293, 0.2285, 0.2281, 0.2280, 8*0.2279 / - DATA (ALIDR (I, 2, 3), I = 1, 14) & - /0.2474, 0.2436, 0.2418, 0.2410, 0.2406, 0.2405, 3*0.2404, & - 5*0.2403 / - DATA (ALIDR (I, 1, 4), I = 1, 14) & - /0.5816, 0.6157, 0.6391, 0.6556, 0.6673, 0.6758, 0.6820, & - 0.6866, 0.6899, 0.6924, 0.6943, 0.6956, 0.6966, 0.6974 / - DATA (ALIDR (I, 2, 4), I = 1, 14) & - /0.5489, 0.5770, 0.5955, 0.6079, 0.6163, 0.6221, 0.6261, & - 0.6288, 0.6308, 0.6321, 0.6330, 0.6337, 0.6341, 0.6344 / - DATA (ALIDR (I, 1, 5), I = 1, 14) & - /0.2845, 0.2837, 0.2832, 0.2831, 0.2830, 9*0.2829 / - DATA (ALIDR (I, 2, 5), I = 1, 14) & - /0.3532, 0.3562, 0.3578, 0.3586, 0.3590, 0.3592, 0.3594, & - 0.3594, 0.3594, 5*0.3595 / - DATA (ALIDR (I, 1, 6), I = 1, 14) & - /0.2825, 0.2812, 0.2806, 0.2803, 0.2802, 9*0.2801 / - DATA (ALIDR (I, 2, 6), I = 1, 14) & - /0.3512, 0.3538, 0.3552, 0.3559, 0.3562, 0.3564, 0.3565, & - 0.3565, 6*0.3566 / - DATA (ALIDR (I, 1, 7), I = 1, 14) /14*ALIDRS/ - DATA (ALIDR (I, 2, 7), I = 1, 14) /14*ALIDRS/ - DATA (ALIDR (I, 1, 8), I = 1, 14) /14*ALIDRD/ - DATA (ALIDR (I, 2, 8), I = 1, 14) /14*ALIDRD/ - DATA (ALIDR (I, 1, 9), I = 1, 14) /14*ALIDRI/ - DATA (ALIDR (I, 2, 9), I = 1, 14) /14*ALIDRI/ - -!**** -!**** ----------------------------------------------------------- - DATA (BTIDR (I, 1, 1), I = 1, 14) & - /0.1291, 0.1707, 0.1969, 0.2125, 0.2216, 0.2267, 0.2295, & - 0.2311, 0.2319, 0.2323, 0.2326, 2*0.2327, 0.2328 / - DATA (BTIDR (I, 2, 1), I = 1, 14) & - /0.1939, 0.2357, 0.2598, 0.2735, 0.2810, 0.2851, 0.2874, & - 0.2885, 0.2892, 0.2895, 0.2897, 3*0.2898 / - DATA (BTIDR (I, 1, 2), I = 1, 14) & - /0.1217, 0.1522, 0.1713, 0.1820, 0.1879, 0.1910, 0.1926, & - 0.1935, 0.1939, 0.1942, 2*0.1943, 2*0.1944 / - DATA (BTIDR (I, 2, 2), I = 1, 14) & - /0.1781, 0.2067, 0.2221, 0.2301, 0.2342, 0.2363, 0.2374, & - 0.2379, 0.2382, 0.2383, 2*0.2384, 2*0.2385 / - DATA (BTIDR (I, 1, 3), I = 1, 14) & - /0.0846, 0.1299, 0.1614, 0.1814, 0.1935, 0.2004, 0.2043, & - 0.2064, 0.2076, 0.2082, 0.2085, 2*0.2087, 0.2088 / - DATA (BTIDR (I, 2, 3), I = 1, 14) & - /0.0950, 0.1410, 0.1722, 0.1921, 0.2042, 0.2111, 0.2151, & - 0.2172, 0.2184, 0.2191, 0.2194, 0.2196, 2*0.2197 / - DATA (BTIDR (I, 1, 4), I = 1, 14) & - /0.5256, 0.7444, 0.9908, 1.2700, 1.5680, 1.8505, 2.0767, & - 2.2211, 2.2808, 2.2774, 2.2362, 2.1779, 2.1160, 2.0564 / - DATA (BTIDR (I, 2, 4), I = 1, 14) & - /0.4843, 0.6714, 0.8577, 1.0335, 1.1812, 1.2858, 1.3458, & - 1.3688, 1.3685, 1.3546, 1.3360, 1.3168, 1.2989, 1.2838 / - DATA (BTIDR (I, 1, 5), I = 1, 14) & - /0.1498, 0.1930, 0.2201, 0.2364, 0.2460, 0.2514, 0.2544, & - 0.2560, 0.2569, 0.2574, 0.2577, 0.2578, 0.2579, 0.2579 / - DATA (BTIDR (I, 2, 5), I = 1, 14) & - /0.2184, 0.2656, 0.2927, 0.3078, 0.3159, 0.3202, 0.3224, & - 0.3235, 0.3241, 0.3244, 0.3245, 3*0.3246 / - DATA (BTIDR (I, 1, 6), I = 1, 14) & - /0.1369, 0.1681, 0.1860, 0.1958, 0.2010, 0.2038, 0.2053, & - 0.2060, 0.2064, 0.2066, 0.2067, 3*0.2068 / - DATA (BTIDR (I, 2, 6), I = 1, 14) & - /0.1969, 0.2268, 0.2416, 0.2488, 0.2521, 0.2537, 0.2544, & - 0.2547, 0.2548, 5*0.2549 / - DATA (BTIDR (I, 1, 7), I = 1, 14) /14*0./ - DATA (BTIDR (I, 2, 7), I = 1, 14) /14*0./ - DATA (BTIDR (I, 1, 8), I = 1, 14) /14*0./ - DATA (BTIDR (I, 2, 8), I = 1, 14) /14*0./ - DATA (BTIDR (I, 1, 9), I = 1, 14) /14*0./ - DATA (BTIDR (I, 2, 9), I = 1, 14) /14*0./ - -!**** -!**** -------------------------------------------------------------- - DATA (GMIDR (I, 1, 1), I = 1, 14) & - /0.1582, 0.2581, 0.3227, 0.3635, 0.3882, 0.4026, 0.4108, & - 0.4154, 0.4179, 0.4193, 0.4200, 0.4204, 0.4206, 0.4207 / - DATA (GMIDR (I, 2, 1), I = 1, 14) & - /0.1934, 0.3141, 0.3818, 0.4200, 0.4415, 0.4533, 0.4598, & - 0.4633, 0.4651, 0.4662, 0.4667, 0.4671, 2*0.4672 / - DATA (GMIDR (I, 1, 2), I = 1, 14) & - /0.1347, 0.1871, 0.2277, 0.2515, 0.2651, 0.2727, 0.2768, & - 0.2790, 0.2801, 0.2808, 0.2811, 0.2812, 0.2813, 0.2814 / - DATA (GMIDR (I, 2, 2), I = 1, 14) & - /0.1440, 0.2217, 0.2629, 0.2839, 0.2947, 0.3003, 0.3031, & - 0.3046, 0.3054, 0.3058, 0.3060, 2*0.3061, 0.3062 / - DATA (GMIDR (I, 1, 3), I = 1, 14) & - /0.1372, 0.2368, 0.3235, 0.3839, 0.4229, 0.4465, 0.4602, & - 0.4679, 0.4722, 0.4745, 0.4758, 0.4764, 0.4768, 0.4770 / - DATA (GMIDR (I, 2, 3), I = 1, 14) & - /0.1435, 0.2524, 0.3370, 0.3955, 0.4332, 0.4563, 0.4697, & - 0.4773, 0.4815, 0.4839, 0.4851, 0.4858, 0.4861, 0.4863 / - DATA (GMIDR (I, 1, 4), I = 1, 14) & - /0.4298, 0.9651, 1.6189, 2.4084, 3.2992, 4.1928, 4.9611, & - 5.5095, 5.8085, 5.9069, 5.8726, 5.7674, 5.6346, 5.4944 / - DATA (GMIDR (I, 2, 4), I = 1, 14) & - /0.4167, 0.8974, 1.4160, 1.9414, 2.4147, 2.7803, 3.0202, & - 3.1468, 3.1954, 3.1932, 3.1676, 3.1328, 3.0958, 3.0625 / - DATA (GMIDR (I, 1, 5), I = 1, 14) & - /0.1959, 0.3203, 0.3985, 0.4472, 0.4766, 0.4937, 0.5034, & - 0.5088, 0.5117, 0.5134, 0.5143, 0.5147, 0.5150, 0.5152 / - DATA (GMIDR (I, 2, 5), I = 1, 14) & - /0.2328, 0.3859, 0.4734, 0.5227, 0.5498, 0.5644, 0.5720, & - 0.5761, 0.5781, 0.5792, 0.5797, 0.5800, 0.5802, 0.5802 / - DATA (GMIDR (I, 1, 6), I = 1, 14) & - /0.1447, 0.2244, 0.2698, 0.2953, 0.3094, 0.3170, 0.3211, & - 0.3233, 0.3244, 0.3250, 0.3253, 0.3255, 0.3256, 0.3256 / - DATA (GMIDR (I, 2, 6), I = 1, 14) & - /0.1643, 0.2624, 0.3110, 0.3347, 0.3461, 0.3517, 0.3543, & - 0.3556, 0.3562, 0.3564, 0.3565, 0.3566, 0.3566, 0.3566 / - DATA (GMIDR (I, 1, 7), I = 1, 14) /14*1./ - DATA (GMIDR (I, 2, 7), I = 1, 14) /14*1./ - DATA (GMIDR (I, 1, 8), I = 1, 14) /14*1./ - DATA (GMIDR (I, 2, 8), I = 1, 14) /14*1./ - DATA (GMIDR (I, 1, 9), I = 1, 14) /14*1./ - DATA (GMIDR (I, 2, 9), I = 1, 14) /14*1./ - -!**** ----------------------------------------------------------- - - -!FPP$ EXPAND (COEFFSIB) - - DO I=1,NCH - ALA = AMIN1 (AMAX1 (ZERO, VLAI(I)), ALATRM) - LAI = 1 + MAX(0, INT((ALA-BLAI)/DLAI) ) - DX = (ALA - (BLAI+(LAI-1)*DLAI)) * (ONE/DLAI) - DY = (VGRN(I)- GRN(1)) * (ONE/(GRN(2) - GRN(1))) - - ALPHA = COEFFSIB (ALVDR (1, 1, ITYP (I)), NLAI, LAI ,DX, DY) - BETA = COEFFSIB (BTVDR (1, 1, ITYP (I)), NLAI, LAI ,DX, DY) - GAMMA = COEFFSIB (GMVDR (1, 1, ITYP (I)), NLAI, LAI ,DX, DY) - - GAMMA = MAX(GAMMA,0.01) - - AVISDR(I) = ALPHA - ZTH(I)*BETA / (GAMMA+ZTH(I)) - AVISDF(I) = ALPHA-BETA & - + 2.*BETA*GAMMA*(1.-GAMMA*ALOG((1.+GAMMA)/GAMMA)) - - ALPHA = COEFFSIB (ALIDR (1, 1, ITYP (I)), NLAI, LAI ,DX, DY) - BETA = COEFFSIB (BTIDR (1, 1, ITYP (I)), NLAI, LAI ,DX, DY) - GAMMA = COEFFSIB (GMIDR (1, 1, ITYP (I)), NLAI, LAI ,DX, DY) - - GAMMA = MAX(GAMMA,0.01) - - ANIRDR(I) = ALPHA - ZTH(I)*BETA / (GAMMA+ZTH(I)) - ANIRDF(I) = ALPHA-BETA & - + 2.*BETA*GAMMA*(1.-GAMMA*ALOG((1.+GAMMA)/GAMMA)) - -! SCALE TO MODIS VALUES (SNOW-FREE) - - AVISDR(I) = AVISDR(I) * SCALVDR(I) - ANIRDR(I) = ANIRDR(I) * SCALIDR(I) - AVISDF(I) = AVISDF(I) * SCALVDF(I) - ANIRDF(I) = ANIRDF(I) * SCALIDF(I) - -! PROTECT AGAINST BAD SCALING - - AVISDR(I) = AMIN1( 1., AMAX1( 0., AVISDR(I) ) ) - ANIRDR(I) = AMIN1( 1., AMAX1( 0., ANIRDR(I) ) ) - AVISDF(I) = AMIN1( 1., AMAX1( 0., AVISDF(I) ) ) - ANIRDF(I) = AMIN1( 1., AMAX1( 0., ANIRDF(I) ) ) - -! SNOW ALBEDOES - - SWE=sum(WESN(I,:)) - !TOTDEP=sum(SNDZ(I,:)) - TOTDEP=SNDZ(I,1) - AREASC = MIN(SWE/WEMIN,1.) - !DENSITY=(SWE/(AREASC+1.e-20)) / (TOTDEP+1.e-20) - !*** only use top layer density to dentermine albedo - DENSITY=(WESN(I,1)/(AREASC+1.e-20)) / (TOTDEP+1.e-20) - DENS_EXC=MAX(0., DENSITY-RHOFRESH) - - !ASNVDR(I) = MAX(SNWALB_VISMIN, SNWALB_VISMAX - DENS_EXC*.0006) - !ASNNDR(I) = MAX(SNWALB_NIRMIN, SNWALB_NIRMAX - DENS_EXC*.0006) - !ASNVDF(I) = MAX(SNWALB_VISMIN, SNWALB_VISMAX - DENS_EXC*.0006) - !ASNNDF(I) = MAX(SNWALB_NIRMIN, SNWALB_NIRMAX - DENS_EXC*.0006) - - !*** Greuell & Konzelmann 94 - !*** features a higher albedo at high densities - GK_B = (0.85-0.58)/(RHOFRESH-RHOMA) - ASNVDR(I) = MAX(SNWALB_VISMIN, SNWALB_VISMAX + GK_B*DENS_EXC) - ASNNDR(I) = MAX(SNWALB_NIRMIN, SNWALB_NIRMAX + GK_B*DENS_EXC) - ASNVDF(I) = MAX(SNWALB_VISMIN, SNWALB_VISMAX + GK_B*DENS_EXC) - ASNNDF(I) = MAX(SNWALB_NIRMIN, SNWALB_NIRMAX + GK_B*DENS_EXC) - - -! ACCOUNT FOR VEGETATION MASKING, FOR EACH COMPONENT - -! A) FIRST DO MASKING IN VEGETATED FRACTION: - FAC = SWE / (SWE + SNWMID(ITYP(I))) - ASNVDR_VEG=AVISDR(I) + (ASNVDR(I)-AVISDR(I))*FAC - ASNNDR_VEG=ANIRDR(I) + (ASNNDR(I)-ANIRDR(I))*FAC - ASNVDF_VEG=AVISDF(I) + (ASNVDF(I)-AVISDF(I))*FAC - ASNNDF_VEG=ANIRDF(I) + (ASNNDF(I)-ANIRDF(I))*FAC - -! B) NOW ACCOUNT FOR SUBGRID VEGETATION FRACTION - FVEG=AMIN1( 1., VLAI(I)/2. ) - ASNVDR(I)=ASNVDR(I)*(1.-FVEG)+ASNVDR_VEG*FVEG - ASNNDR(I)=ASNNDR(I)*(1.-FVEG)+ASNNDR_VEG*FVEG - ASNVDF(I)=ASNVDF(I)*(1.-FVEG)+ASNVDF_VEG*FVEG - ASNNDF(I)=ASNNDF(I)*(1.-FVEG)+ASNNDF_VEG*FVEG - - -! AMASK=FVEG*EXP(-TOTDEP/SNWMSK(ITYP(I))) - -! -! AVISDR(I) = AVISDR(I) + (SNWALB(1,ITYP(I)) - AVISDR(I)) * FAC -! ANIRDR(I) = ANIRDR(I) + (SNWALB(2,ITYP(I)) - ANIRDR(I)) * FAC -! AVISDF(I) = AVISDF(I) + (SNWALB(3,ITYP(I)) - AVISDF(I)) * FAC -! ANIRDF(I) = ANIRDF(I) + (SNWALB(4,ITYP(I)) - ANIRDF(I)) * FAC -! ENDIF - -! (ORIGINAL NOTES FROM STIEGLITZ:) - -! ALBSNW = 0.913 - .0006*DENSITY -! ALBSNW = AMIN1(1., AMAX1(ALBSNW,0.5)) - -! a) formulation -! While 3 basic land covers are allowed (bare soil, snow, and vegetation), -! the grid cell is divided into 2 fractions: a vegetated fraction (A_v), -! and a non-vegetated fraction (A_u). In the absence of snow cover -! A_v = m A_v0 -! A_u = 1 - A_v -! where A_v0 is defined to be the grid cell specified value for the -! vegetated fraction, A_u is the resultant bare soil fraction, and m, the -! snow masking fraction, is unity. In the absence of snow A_u is simply -! the unvegetated portion of the grid cell. In the presence of snow, the -! green vegetation masked by snow is -! m = exp( - d_s / d_m) -! where d_s is the snow depth(not water equivalent) and d_m is the -! vegetation specific masking depth. A_u now becomes that portion of the -! grid cell where vegetation is not visible -! b) masking depths -! DATA SMK/0.1,0.2,0.2,0.5,2.0,5.0,10.0,25.0/ -! SMK array types - desert, tundra, grass, shrub, woodland, -! deciduous, evergreen, rain forest - - -! FRACV=0.5 -! AMASK=FRACV*EXP(-TOTDEP/SNWMSK) -! ALBSNW=ALBSNW*(1.-AMASK)+ALBAVE*AMASK - -! IF (SNW (I) .GT. ZERO) THEN -! FAC = SNW(I) / (SNW(I) + SNWMID(ITYP(I))) -! -! AVISDR(I) = AVISDR(I) + (SNWALB(1,ITYP(I)) - AVISDR(I)) * FAC -! ANIRDR(I) = ANIRDR(I) + (SNWALB(2,ITYP(I)) - ANIRDR(I)) * FAC -! AVISDF(I) = AVISDF(I) + (SNWALB(3,ITYP(I)) - AVISDF(I)) * FAC -! ANIRDF(I) = ANIRDF(I) + (SNWALB(4,ITYP(I)) - ANIRDF(I)) * FAC -! ENDIF - - ENDDO - - RETURN - END SUBROUTINE SIBALB - - FUNCTION COEFFSIB(TABLE, NTABL, LAI ,DX, DY) - - IMPLICIT NONE - INTEGER, INTENT(IN) :: NTABL, LAI - - REAL, INTENT(IN) :: DX, DY - REAL, INTENT(IN), DIMENSION(NTABL,2) :: TABLE - REAL COEFFSIB - - COEFFSIB = (TABLE(LAI, 1) & - + (TABLE(LAI ,2) - TABLE(LAI ,1)) * DY ) * (1.0-DX) & - + (TABLE(LAI+1,1) & - + (TABLE(LAI+1,2) - TABLE(LAI+1,1)) * DY ) * DX - - RETURN - END FUNCTION COEFFSIB -#endif - end subroutine RUN2 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/GEOS_SurfaceGridComp.rc b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/GEOS_SurfaceGridComp.rc old mode 100755 new mode 100644 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/StieglitzSnow.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/StieglitzSnow.F90 index f5727278b..748feecb9 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/StieglitzSnow.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/StieglitzSnow.F90 @@ -1,8 +1,8 @@ module StieglitzSnow - + ! This is a merge of Teppei's snow tracer code with the Heracles (H52) version - + ! reichle, 12 Aug 2014 - moved "*_calc_asnow()" to here from catchment.F90 ! - renamed "get_tf_nd()" to "StieglitzSnow_calc_tpsnow()" ! - removed "relayer()" (obsolete) @@ -14,7 +14,7 @@ module StieglitzSnow ! Sarith, 4/21/2016 - WEMIN made public, sibalb uses it ! Justin, 4/16/2018 - moved WEMIN, AICEV, AICEN to SurfParams, ! removed LAND_UPD ifdef's - + USE MAPL_ConstantsMod, ONLY: & PIE => MAPL_PI, & ! - ALHE => MAPL_ALHL, & ! J/kg @15C @@ -24,1334 +24,1451 @@ module StieglitzSnow USE MAPL_BaseMod, ONLY: MAPL_LANDICE - USE SurfParams, ONLY: WEMIN, AICEV, AICEN + USE SurfParams, ONLY: WEMIN, AICEV, AICEN + + implicit none - public :: snowrt ! used by LandIce, Catchment - public :: TRID ! used by LandIce - public :: SNOW_ALBEDO ! used by LandIce, Catchment, and LDAS - public :: StieglitzSnow_calc_asnow ! used by Catchment, and LDAS - public :: StieglitzSnow_calc_tpsnow ! used by Catchment, and LDAS - public :: StieglitzSnow_echo_constants ! used by LDAS + public :: StieglitzSnow_snowrt ! used by LandIce, Catchment[CN] + public :: StieglitzSnow_trid ! used by LandIce + public :: StieglitzSnow_snow_albedo ! used by LandIce, Catchment[CN], LDAS + public :: StieglitzSnow_calc_asnow ! used by Catchment[CN], LDAS + public :: StieglitzSnow_calc_tpsnow ! used by Catchment[CN], LDAS + public :: StieglitzSnow_echo_constants ! used by LDAS + public :: StieglitzSnow_relayer ! used by LDAS, land-atm DAS - public :: get_tf0d ! for now, to be unified w/ StieglitzSnow_calc_tpsnow, reichle, 12 Aug 2014 + public :: StieglitzSnow_RHOMA ! used by LDAS, land-atm DAS + public :: StieglitzSnow_MINSWE ! used by LandIce + public :: StieglitzSnow_CPW ! used by LandIce - ! constants specific to StieglitzSnow + interface StieglitzSnow_calc_asnow - real, private, parameter :: MINSWE = 0.013 ! kg/m^2 min SWE to avoid immediate melt -! #ifdef LAND_UPD -! real, public, parameter :: WEMIN = 13. ! kg/m^2 minimum SWE in areal fraction -! #else -! real, public, parameter :: WEMIN = 26. ! kg/m^2 minimum SWE in areal fraction -! #endif - real, private, parameter :: cpw = 2065.22 ! @ 0 C [J/kg/K] - real, private, parameter :: DZ1MAX = 0.08 ! m - real, private, parameter :: RHOMA = 500. ! kg/m^3 maximum snow density - real, private, parameter :: SNWALB_VISMIN = 0.5 - real, private, parameter :: SNWALB_NIRMIN = 0.3 - -!================================ Added by Teppei Yasunari ================================== -!-------------------------------------------------------------------------------------------- -! Teppei J. Yasunari produced this file, 23 May 2014 -! Teppei, 23 May 2014 - Moved the constants from StieglitzSnow.F90 to here and revised comments. -! Teppei, 19 August 2014 - no longer considered goswim_constants.F90 -! and put all the GOSWIM-related constants here -! Teppei, 27 August 2014 - if condition was revised for ALB_WITH_IMPURITY -! - ABVIS and ABNIR are not needed in the subroutine because spcified below -! -!-------------------------------------------------------------------------------------------- -! snow albedo related constants -!-------------------------------------------------------------------------------------------- -! See details in: -! Yasunari, T. J., K.-M. Lau, S. P. P. Mahanama, P. R. Colarco, A. M. da Silva, -! T. Aoki, K. Aoki, N. Murao, S. Yamagata, and Y. Kodama, 2014: -! GOddard SnoW Impurity Module (GOSWIM) for the NASA GEOS-5 Earth System Model: -! Preliminary comparisons with observations in Sapporo, Japan. SOLA, 10, 50-56, -! doi:10.2151/sola.2014-011. -! The URL of the paper: https://www.jstage.jst.go.jp/article/sola/10/0/10_2014-011/_article -!-------------------------------------------------------------------------------------------- - -! **************** IMPORTANT IMPORTANT IMPORTANT IMPORTANT *********************** -! Below number of constituents in each group must be consistent with the AERO_DP (expChem) bundle -! in GEOSchem_GridComp/GOCART_GridComp/GOCART_GridCompMod.F90 - + module procedure StieglitzSnow_calc_asnow_1 + module procedure StieglitzSnow_calc_asnow_2 + module procedure StieglitzSnow_calc_asnow_3 + + end interface StieglitzSnow_calc_asnow + + interface StieglitzSnow_calc_tpsnow + + module procedure StieglitzSnow_calc_tpsnow_scalar ! replicates original get_tf0d() + module procedure StieglitzSnow_calc_tpsnow_vector ! replicates original get_tf_nd() + + end interface StieglitzSnow_calc_tpsnow + + ! constants specific to StieglitzSnow + + real, parameter :: StieglitzSnow_RHOMA = 500. ! kg/m^3 maximum snow density + real, parameter :: StieglitzSnow_MINSWE = 0.013 ! kg/m^2 min SWE to avoid immediate melt + real, parameter :: StieglitzSnow_CPW = 2065.22 ! J/kg/K specific heat of ice at 0 deg C (??) [=MAPL_CAPICE??] + + real, private, parameter :: SNWALB_VISMIN = 0.5 + real, private, parameter :: SNWALB_NIRMIN = 0.3 + + !================================ Added by Teppei Yasunari ================================== + !-------------------------------------------------------------------------------------------- + ! Teppei J. Yasunari produced this file, 23 May 2014 + ! Teppei, 23 May 2014 - Moved the constants from StieglitzSnow.F90 to here and revised comments. + ! Teppei, 19 August 2014 - no longer considered goswim_constants.F90 + ! and put all the GOSWIM-related constants here + ! Teppei, 27 August 2014 - if condition was revised for ALB_WITH_IMPURITY + ! - ABVIS and ABNIR are not needed in the subroutine because spcified below + ! + !-------------------------------------------------------------------------------------------- + ! snow albedo related constants + !-------------------------------------------------------------------------------------------- + ! See details in: + ! Yasunari, T. J., K.-M. Lau, S. P. P. Mahanama, P. R. Colarco, A. M. da Silva, + ! T. Aoki, K. Aoki, N. Murao, S. Yamagata, and Y. Kodama, 2014: + ! GOddard SnoW Impurity Module (GOSWIM) for the NASA GEOS-5 Earth System Model: + ! Preliminary comparisons with observations in Sapporo, Japan. SOLA, 10, 50-56, + ! doi:10.2151/sola.2014-011. + ! The URL of the paper: https://www.jstage.jst.go.jp/article/sola/10/0/10_2014-011/_article + !-------------------------------------------------------------------------------------------- + + ! **************** IMPORTANT IMPORTANT IMPORTANT IMPORTANT *********************** + ! Below number of constituents in each group must be consistent with the AERO_DP (expChem) bundle + ! in GEOSchem_GridComp/GOCART_GridComp/GOCART_GridCompMod.F90 + integer, parameter, public :: NUM_DUDP = 5, NUM_DUSV = 5, NUM_DUWT = 5, NUM_DUSD = 5 integer, parameter, public :: NUM_BCDP = 2, NUM_BCSV = 2, NUM_BCWT = 2, NUM_BCSD = 2 integer, parameter, public :: NUM_OCDP = 2, NUM_OCSV = 2, NUM_OCWT = 2, NUM_OCSD = 2 integer, parameter, public :: NUM_SUDP = 1, NUM_SUSV = 1, NUM_SUWT = 1, NUM_SUSD = 1 integer, parameter, public :: NUM_SSDP = 5, NUM_SSSV = 5, NUM_SSWT = 5, NUM_SSSD = 5 - + integer, public, parameter :: N_constit = 9 ! Number of constituents in snow - -! (for riv, rin,aicev, aicen, and denice, instead use Teppei-defined -! values below) -!-------------------------------------------------------------------------------------------- -! Spectrally integrated values for VIS and NIR using -! the updated ice refractive indices by Warren and Brandt, (JGR, 2008). -! were used. -! VIS: 300-690 nm; NIR: 690-3847 nm + + ! (for riv, rin,aicev, aicen, and denice, instead use Teppei-defined + ! values below) + !-------------------------------------------------------------------------------------------- + ! Spectrally integrated values for VIS and NIR using + ! the updated ice refractive indices by Warren and Brandt, (JGR, 2008). + ! were used. + ! VIS: 300-690 nm; NIR: 690-3847 nm real, private, parameter :: RIV=0.018, RIN=0.017 - -!-------------------------------------------------------------------------------------------- -! So as to explain Abs. Co. for ice of 10 [m-1] by Kondo et al. (1988) -! the spectrally integrated Abs. Co. in VIS was used to get the one in NIR -! as a tuning parameter (see Yasunari et al., JGR, 2011). - -! #ifdef LAND_UPD -! real, private, parameter :: AICEV=0.107, AICEN=19.893 -! #else -! real, private, parameter :: AICEV=0.149, AICEN=19.851 -! #endif + + !-------------------------------------------------------------------------------------------- + ! So as to explain Abs. Co. for ice of 10 [m-1] by Kondo et al. (1988) + ! the spectrally integrated Abs. Co. in VIS was used to get the one in NIR + ! as a tuning parameter (see Yasunari et al., JGR, 2011). + real, private, parameter :: DENICE=917. - -!-------------------------------------------------------------------------------------------- - -! Mass Absorption Coefficient or Mass Absorption Cross-section (MAC) [m2 g-1] -! Then the representative MACs for VIS & NIR was estimated from -! the GOCART/GEOS-5 optical properties. -! VIS: 300-690 nm; NIR: 690-3850 nm -! (Spectrally integrated with the standard surface radiation: -! ASTM G173-03 Tables; http://rredc.nrel.gov/solar/spectra/am1.5/) -! Updated on May 10, 2012 -! --------------------------------------------------------------------------- -! -! constants for snow constituents (dust, carbon, etc.) - -! MAC, visible (VIS) - real, private, parameter, dimension(N_constit) :: ABVIS = & - (/ 0.148, & ! Dust1 - 0.106, & ! Dust2 - 0.076, & ! Dust3 - 0.051, & ! Dust4 - 0.032, & ! Dust5 - 7.747, & ! Black carbon hydrophobic - 11.227, & ! Black carbon hydrophilic - 0.103, & ! Organic carbon hydrophobic - 0.114/) ! Organic carbon hydrophic - -! MAC, near-infrared (NIR) - real, private, parameter, dimension(N_constit) :: ABNIR = & - (/ 0.095, & ! Dust1 - 0.080, & ! Dust2 - 0.062, & ! Dust3 - 0.043, & ! Dust4 - 0.029, & ! Dust5 - 4.621, & ! Black carbon hydrophobic - 6.528, & ! Black carbon hydrophilic - 0.092, & ! Organic carbon hydrophobic - 0.127 /) ! Organic carbon hydrophic - -!-------------------------------------------------------------------------------------------- - -! Scavenging coefficients for flushing effect in snow for constituents: -! Based on GOCART/GEOS-5 particle size; -! Tuning parameters so as to satisfy NCAR/CLM based scavenging efficiencies; -! See more in Yasunari et al. (SOLA, 2014) - - real, private, parameter, dimension(N_constit) :: SCAV = & - (/ 0.065442, & ! Dust 1 - 0.077829, & ! Dust 2 - 0.306841, & ! Dust 3 - 0. , & ! Dust 4 - 0. , & ! Dust 5 - 0.074361, & ! Black carbon hydrophobic - 0.502814, & ! Black carbon hydrophilic - 0.075855, & ! Organic carbon hydrophobic - 0.535225 /) ! Organic carbon hydrophic - -! Representative particle size in diameter -! based on effective radius GOCART/GEOS-5 (dust 1-5 bins, BC, and OC) [um] - real, private, parameter, dimension(N_constit) :: PSIZE = & - (/ 1.272, & ! Dust 1 - 2.649, & ! Dust 2 - 4.602, & ! Dust 3 - 8.334, & ! Dust 4 - 15.341, & ! Dust 5 - 0.078, & ! Black carbon hydrophobic - 0.148, & ! Black carbon hydrophilic - 0.175, & ! Organic carbon hydrophobic - 0.441 /) ! Organic carbon hydrophic - -!============================================================================================ - - - - + !-------------------------------------------------------------------------------------------- + + ! Mass Absorption Coefficient or Mass Absorption Cross-section (MAC) [m2 g-1] + ! Then the representative MACs for VIS & NIR was estimated from + ! the GOCART/GEOS-5 optical properties. + ! VIS: 300-690 nm; NIR: 690-3850 nm + ! (Spectrally integrated with the standard surface radiation: + ! ASTM G173-03 Tables; http://rredc.nrel.gov/solar/spectra/am1.5/) + ! Updated on May 10, 2012 + + ! --------------------------------------------------------------------------- + ! + ! constants for snow constituents (dust, carbon, etc.) + + ! MAC, visible (VIS) + real, private, parameter, dimension(N_constit) :: ABVIS = (/ & + 0.148, & ! Dust1 + 0.106, & ! Dust2 + 0.076, & ! Dust3 + 0.051, & ! Dust4 + 0.032, & ! Dust5 + 7.747, & ! Black carbon hydrophobic + 11.227, & ! Black carbon hydrophilic + 0.103, & ! Organic carbon hydrophobic + 0.114 /) ! Organic carbon hydrophic + + ! MAC, near-infrared (NIR) + real, private, parameter, dimension(N_constit) :: ABNIR = (/ & + 0.095, & ! Dust1 + 0.080, & ! Dust2 + 0.062, & ! Dust3 + 0.043, & ! Dust4 + 0.029, & ! Dust5 + 4.621, & ! Black carbon hydrophobic + 6.528, & ! Black carbon hydrophilic + 0.092, & ! Organic carbon hydrophobic + 0.127 /) ! Organic carbon hydrophic + + !-------------------------------------------------------------------------------------------- + + ! Scavenging coefficients for flushing effect in snow for constituents: + ! Based on GOCART/GEOS-5 particle size; + ! Tuning parameters so as to satisfy NCAR/CLM based scavenging efficiencies; + ! See more in Yasunari et al. (SOLA, 2014) + + real, private, parameter, dimension(N_constit) :: SCAV = (/ & + 0.065442, & ! Dust 1 + 0.077829, & ! Dust 2 + 0.306841, & ! Dust 3 + 0. , & ! Dust 4 + 0. , & ! Dust 5 + 0.074361, & ! Black carbon hydrophobic + 0.502814, & ! Black carbon hydrophilic + 0.075855, & ! Organic carbon hydrophobic + 0.535225 /) ! Organic carbon hydrophic + + ! Representative particle size in diameter + ! based on effective radius GOCART/GEOS-5 (dust 1-5 bins, BC, and OC) [um] + + real, private, parameter, dimension(N_constit) :: PSIZE = (/ & + 1.272, & ! Dust 1 + 2.649, & ! Dust 2 + 4.602, & ! Dust 3 + 8.334, & ! Dust 4 + 15.341, & ! Dust 5 + 0.078, & ! Black carbon hydrophobic + 0.148, & ! Black carbon hydrophilic + 0.175, & ! Organic carbon hydrophobic + 0.441 /) ! Organic carbon hydrophic + + !============================================================================================ + contains + + subroutine StieglitzSnow_snowrt(N_zones, N_snow, tileType, & ! in + maxsndepth, rhofs, targetthick, & ! in + t1, area, tkgnd, precip, snowf, ts, dts, eturb, dedtc, hsturb, dhsdtc, & ! in + hlwtc, dhlwtc, raddn, zc1, totdepos, & ! in + wesn, htsnn, sndz, rconstit, & ! inout + hlwout, fices, tpsn, rmelt, & ! out + areasc, areasc0, pre, fhgnd, evap, shflux, lhflux, hcorr, ghfluxsno, & ! out + sndzsc, wesnprec, sndzprec, sndz1perc, & ! out + wesnperc, wesndens, wesnrepar, mltwtr, & ! out + excs, drho0, wesnbot, tksno, dtss ) ! out + + !********************************************************************* + ! AUTHORS: M. Stieglitz, M. Suarez, R. Koster & S. Dery. + ! VERSION: 2003b - This version last updated: 05/30/03. + !********* + ! INPUTS: + !********* + ! N_zones : number of zones in the horizontal dimension (eg, 3 for Catchment, 1 for LandIce) + ! N_snow : number of snow layers + ! N_constit : Number of constituent tracers in snow + ! tileType : surface type of the tile + ! t1 : Temperature of catchment zones [C] + ! ts : Air temperature [K] + ! area : Fraction of snow-free area in each catchment zone [0-1] + ! precip : Precipitation (Rain+snowfall) [kg/m^2/s == mm/s] + ! snowf : Snowfall per unit area of catchment [kg/m^2/s == mm/s] + ! dts : Time step [s] + ! eturb : Evaporation per unit area of snow [kg/m^2/s == mm/s] + ! dedtc : d(eturb)/d(ts) [kg/m^2/s/K] + ! hsturb : Sensible heat flux per unit area of snow [W/m^2] + ! dhsdtc : d(hsturb)/d(ts) [W/m^2/K] + ! hlwtc : Emitted IR per unit area of snow [W/m^2] + ! dhlwtc : d(hlwtc)/d(ts) [W/m^2/K] + ! raddn : Net solar + incident terrestrial per unit area of snow [W/m^2] + ! tkgnd : Thermal diffusivity of soil in catchment zones [W/m/K] + ! zc1 : Half-thickness (mid-point) of top soil layer [m] + !*** Bin Zhao added ************************************************* + ! maxsndepth : Maximum snow depth beyond which snow gets thrown away + ! rhofs : fresh snow density + ! targetthick : the target thickness distribution relayer redistribute mass + ! and energy to; currently its value is surface type dependent + ! for catchment, the 1st array element the target thickness + ! the rest define a sigma distribution; + ! for landice, it is an array with specified thicknesses + !********* + ! UPDATES: + !********* + ! wesn : Layer water contents per unit area of catchment [kg/m^2] + ! htsnn : Layer heat contents relative to liquid water at 0 C [J/m^2] + ! sndz : Layer depths [m] + ! rconstit : Mass of constituents in snow layer [kg] (i.e., [kg m-2]) + ! rmelt : Flushed mass amount of constituents from the bottom snow layer [kg m-2 s-1 (kg/m^2/s)] + !********* + ! OUTPUTS: + !********* + ! tpsn : Layer temperatures [C] + ! fices : Layer frozen fraction [0-1] + ! areasc : Areal snow coverage at beginning of step [0-1] + ! areasc0 : Areal snow coverage at end of step [0-1] + ! pre : Liquid water outflow from snow base [kg/m^2/s] + ! fhgnd : Heat flux at snow base at catchment zones [W/m^2] + ! hlwout : Final emitted IR flux per unit area of snow [W/m^2] + ! lhflux : Final latent heat flux per unit area of snow [W/m^2] + ! shflux : Final sensible heat flux per unit area of snow [W/m^2] + ! evap : Final evaporation per unit area of snow [kg/m^2/s] + !*** Bin Zhao added ************************************************* + ! sndzsc : top layer thickness change due to sublimation/condensation + ! wesnprec : top layer water content change due to precip (different from precip itself) + ! sndzprec : top layer thickness change due to precip + ! sndz1perc : top layer thickness change due to percolation + ! wesnperc : layer water content change due to percolation + ! wesndens : layer water content change due to densification + ! wesnrepar : layer water content change due to relayer + ! mltwtr : total melt water production rate + ! excs : frozen part of water content from densification excess + ! drho0 : layer density change due to densification + ! wesnbot : excessive water content due to thickness exceeding maximum depth + ! tksno : layer conductivity + ! dtss : top layer temperature change + ! + !****************************************************************************** + ! NOTA: By convention, wesn is representative for a catchment area + ! equal to 1 whereas sndz is relative to the area covered by snow only. + !****************************************************************************** + + implicit none + + ! real, parameter :: lhv = 2.4548E6 ! 2.5008e6 ! @ 0 C [J/kg] + ! real, parameter :: lhs = 2.8368E6 ! 2.8434e6 ! @ 0 C [J/kg] + ! real, parameter :: lhf = (lhs-lhv) ! @ 0 C [J/kg] + + !rr real, parameter :: cpw_liquid = 4185. ! [J/kg/K] + + ! real, parameter :: tfrz = 273.16 ! @ 0 C [K] + ! real, parameter :: rhofs = 150. ! [kg/m^3] + ! real, parameter :: rhoma = 500. ! [kg/m^3] + ! real, parameter :: rhow = 1000. ! [kg/m^3] + ! real, parameter :: wemin = 13. ! [kg/m^2] + + real, parameter :: snfr = 0.01 ! holding capacity + real, parameter :: small = 1.e-6 ! small number - subroutine snowrt(N_zones, N_snow, tileType, & - t1,area,tkgnd,precip,snowf,ts,dts, eturb,dedtc,hsturb,dhsdtc, & - hlwtc,dhlwtc,desdtc,hlwout,raddn,zc1,totdepos,wss, & - wesn,htsnn,sndz,fices,tpsn, rconstit,rmelt, & - areasc,areasc0,pre,fhgnd,evap,shflux,lhflux,hcorr,ghfluxsno & - , sndzsc, wesnprec, sndzprec, sndz1perc & - , wesnperc, wesndens, wesnrepar, mltwtr & - , excs, drho0, wesnbot, tksno, dtss, maxsndepth, rhofs, & - targetthick) - -!********************************************************************* -! AUTHORS: M. Stieglitz, M. Suarez, R. Koster & S. Dery. -! VERSION: 2003b - This version last updated: 05/30/03. -!********* -! INPUTS: -!********* -! N_zones : number of zones in the horizontal dimension (eg, 3 for Catchment, 1 for LandIce) -! N_snow : number of snow layers -! N_constit : Number of constituent tracers in snow -! tileType : surface type of the tile -! t1 : Temperature of catchment zones [C] -! ts : Air temperature [K] -! area : Fraction of snow-free area in each catchment zone [0-1] -! precip : Precipitation (Rain+snowfall) [kg/m^2/s == mm/s] -! snowf : Snowfall per unit area of catchment [kg/m^2/s == mm/s] -! dts : Time step [s] -! eturb : Evaporation per unit area of snow [kg/m^2/s == mm/s] -! dedtc : d(eturb)/d(ts) [kg/m^2/s/K] -! hsturb : Sensible heat flux per unit area of snow [W/m^2] -! dhsdtc : d(hsturb)/d(ts) [W/m^2/K] -! hlwtc : Emitted IR per unit area of snow [W/m^2] -! dhlwtc : d(hlwtc)/d(ts) [W/m^2/K] -! raddn : Net solar + incident terrestrial per unit area of snow [W/m^2] -! tkgnd : Thermal diffusivity of soil in catchment zones [W/m/K] -! zc1 : Half-thickness of top soil layer [m] -!*** Bin Zhao added ************************************************* -! maxsndepth : Maximum snow depth beyond which snow gets thrown away -! rhofs : fresh snow density -! targetthick : the target thickness distribution relayer redistribute mass -! and energy to; currently its value is surface type dependent -! for catchment, the 1st array element the target thickness -! the rest define a sigma distribution; -! for landice, it is an array with specified thicknesses -!********* -! UPDATES: -!********* -! wesn : Layer water contents per unit area of catchment [kg/m^2] -! htsnn : Layer heat contents relative to liquid water at 0 C [J/m^2] -! sndz : Layer depths [m] -! rconstit : Mass of constituents in snow layer [kg] (i.e., [kg m-2]) -! rmelt : Flushed mass amount of constituents from the bottom snow layer [kg m-2 s-1 (kg/m^2/s)] -!********* -! OUTPUTS: -!********* -! tpsn : Layer temperatures [C] -! fices : Layer frozen fraction [0-1] -! areasc : Areal snow coverage at beginning of step [0-1] -! areasc0: Areal snow coverage at end of step [0-1] -! pre : Liquid water flow from snow base [kg/m^2/s] -! fhgnd : Heat flux at snow base at catchment zones [W/m^2] -! hlwout : Final emitted IR flux per unit area of snow [W/m^2] -! lhflux : Final latent heat flux per unit area of snow [W/m^2] -! shflux : Final sensible heat flux per unit area of snow [W/m^2] -! evap : Final evaporation per unit area of snow [kg/m^2/s] -!*** Bin Zhao added ************************************************* -! sndzsc : top layer thickness change due to sublimation/condensation -! wesnprec : top layer water content change due to precip (different from precip itself) -! sndzprec : top layer thickness change due to precip -! sndz1perc : top layer thickness change due to percolation -! wesnperc : layer water content change due to percolation -! wesndens : layer water content change due to densification -! wesnrepar : layer water content change due to relayer -! mltwtr : total melt water production rate -! excs : frozen part of water content from densification excess -! drho0 : layer density change due to densification -! wesnbot : excessive water content due to thickness exceeding maximum depth -! tksno : layer conductivity -! dtss : top layer temperature change -!********************************************************************* -! NOTA: By convention, wesn is representative for a catchment area -! equal to 1 whereas sndz is relative to the area covered by snow only. -!********************************************************************* - - - implicit none - -! real, parameter :: lhv = 2.4548E6 ! 2.5008e6 ! @ 0 C [J/kg] -! real, parameter :: lhs = 2.8368E6 ! 2.8434e6 ! @ 0 C [J/kg] -! real, parameter :: lhf = (lhs-lhv) ! @ 0 C [J/kg] - -!rr real, parameter :: cpw_liquid = 4185. ! [J/kg/K] - -! real, parameter :: tfrz = 273.16 ! @ 0 C [K] -! real, parameter :: rhofs = 150. ! [kg/m^3] -! real, parameter :: rhoma = 500. ! [kg/m^3] -! real, parameter :: rhow = 1000. ! [kg/m^3] -! real, parameter :: wemin = 13. ! [kg/m^2] - real, parameter :: snfr = 0.01 ! holding capacity - real, parameter :: small = 1.e-6 ! small number -! integer, parameter :: nlay = 3 ! number of layers -! integer, parameter :: N_zones = 3 ! number of zones -! real , parameter :: MIN_SNOW_MASS = .013 ! kg/M**2 equiv to 0.1% area - - - integer, intent(in) :: N_zones, N_snow, tileType - real, intent(in ) :: t1(N_zones),area(N_zones),tkgnd(N_zones) - real, intent(in) :: totdepos(N_constit) - real, intent(in ) :: ts,precip,snowf,dts,dedtc,raddn,hlwtc - real, intent(in ) :: dhsdtc,desdtc,dhlwtc,eturb,hsturb,zc1,wss - real, intent(inout):: wesn(N_snow),htsnn(N_snow),sndz(N_snow) - real, intent(inout):: rconstit(N_snow,N_constit) - real, intent(out) :: tpsn(N_snow),fices(N_snow),fhgnd(N_zones) - real, intent(out) :: hlwout,lhflux,shflux,areasc0,evap,areasc,pre - real, intent(out) :: rmelt(N_constit) - real, intent(out) :: ghfluxsno - - real, intent(out) :: wesnprec - !real, intent(out) :: wesnsc, wesnprec - real, intent(out) :: sndzsc, sndzprec - real, intent(out) :: sndz1perc - real, intent(out) :: wesnperc(N_snow) - real, intent(out) :: wesndens(N_snow) - real, intent(out) :: wesnrepar(N_snow) - real, intent(out) :: mltwtr - real, intent(out) :: excs(N_snow) - real, intent(out) :: drho0(N_snow) - real, intent(out) :: wesnbot - real, intent(out) :: tksno(N_snow) - real, intent(out) :: dtss - real, intent(in) :: maxsndepth - real, intent(in) :: rhofs - real, intent(in) :: targetthick(N_snow) - -!Locals - real :: tsx, mass,snowd,rainf,denom,alhv,lhturb,dlhdtc,hcorr, & - enew,eold,tdum,fnew,tnew,icedens,densfac,hnew,scale,t1ave, & - flxnet,fdum,dw,waterin,waterout,snowin,snowout, mtwt, & - waterbal,precision,flow,term,dz,w(0:N_snow),HTSPRIME, & - wlossfrac,rho_fs - real :: excsdz, excswe, sndzsum, melti, mtwt0, mtwt1 - - real, dimension(size(wesn) ) :: cmpc,dens - real, dimension(size(wesn) ) :: tksn - real, dimension(size(wesn) ) :: dtc,q,cl,cd,cr - real, dimension(size(wesn)+1) :: fhsn,df - real, dimension(size(wesn) ) :: htest,ttest,ftest - - -! by Teppei --- GOSWIM related variables -!============================================================================================ - - real, dimension(size(wesn) ) :: denblk !bulk snow density - real, dimension(size(wesn) ) :: po !snow porosity - -!============================================================================================ - - - - logical, dimension(size(wesn) ) :: ice1,tzero, ice10,tzero0 - real :: topthick - real, dimension(size(wesn)-1) :: thickdist - !real, dimension(size(wesn) ) :: wesn0, wesn1, wesn2 - !real, dimension(size(wesn) ) :: sndz0, sndz1, sndz2 - real, dimension(size(wesn) ) :: dens0 - real, dimension(N_constit) :: flow_r,rconc - - integer :: i,izone,k - logical :: logdum,kflag - - snowd = sum(wesn) - snowin = snowd - ghfluxsno = 0. - -!rr correction for "cold" snow - tsx = min(ts-tf,0.)*cpw - -!rr correction for heat content of rain -!rr tsx_rain = max(ts-tf,0.)*cpw_liquid - - df = 0. - dtc = 0. - tpsn = 0. - fices = 0. - areasc = 0. - areasc0= 0. - pre = 0. - fhgnd = 0. - hlwout = 0. - shflux = 0. - lhflux = 0. - evap = 0. - excs = 0. - hcorr = 0. - dens = rhofs - rainf = precip - snowf ! [kg/m^2/s] - - !wesnsc = 0. - sndzsc = 0. - wesnprec = 0. - sndzprec = 0. - sndz1perc = 0. - wesnperc = 0. - wesndens = 0. - wesnrepar = 0. - wesnbot = 0. - !tksno = condice - dtss = 0. - excswe = 0. - - rmelt = 0.0 - mltwtr = 0.0 - drho0 = 0.0 - tksno = 0.0 - - !wesn0 = wesn - !sndz0 = sndz - - if(snowd <= MINSWE) then ! no snow -! Assume initial (very small) snow water melts; new area is based -! on new snowfall - - areasc = min(snowd/wemin,1.) - areasc0 = 0. - pre = snowd/dts + areasc*rainf - wesn = 0. - hcorr = hcorr + raddn*areasc + sum(htsnn)/dts - htsnn = 0. - sndz = 0. - mltwtr = snowd/dts - do k=1,N_constit - rmelt(k)=sum(rconstit(:,k))/dts - enddo - rconstit(:,:) = 0. - - if(snowf > 0.) then ! only initialize with non-liquid part of precip - ! liquid part runs off (above) - - wesn = snowf*dts/float(N_snow) - htsnn = (tsx-alhm)*wesn - areasc0 = min((snowf*dts)/wemin,1.) - !sndz = wesn/rhofs - !*** should have fractional snow cover taken into account - sndz = wesn/(max(areasc0,small)*rhofs) -! hcorr = hcorr - (tsx-alhm)*snowf ! randy - hcorr = hcorr - tsx*snowf ! randy - !call relayer(N_snow, htsnn, wesn, sndz) - select case (tileType) - case (MAPL_LANDICE) - call FindTargetThickDist(N_snow, sndz, targetthick, topthick, thickdist) - case default - topthick = targetthick(1) - thickdist = targetthick(2:N_snow) - end select - -! Add constituent to top snow layer, in area covered by snow. - do k=1,N_constit - rconstit(1,k)=rconstit(1,k)+areasc0*totdepos(k)*dts - enddo - - call relayer2(N_snow, N_constit, topthick, thickdist, & - htsnn, wesn, sndz, rconstit) - call StieglitzSnow_calc_tpsnow(N_snow, htsnn, wesn, tpsn, fices) - endif - - return ! if there was no snow at start of time step - - endif - - -!**** Determine the fractional snow coverage - - areasc = min(snowd/wemin,1.) - -!**** Set the mean density & diffusivity of the layers - - do i=1,N_snow - if(sndz(i) > 0) dens(i) = max(wesn(i)/(areasc*sndz(i)),rhofs) - enddo - tksn = 3.2217e-06*dens**2 - tksno = tksn - dens0 = dens - -!**** Determine temperature & frozen fraction of snow layers - - call StieglitzSnow_calc_tpsnow(N_snow, htsnn, wesn, tpsn, fices) - - mtwt = sum(wesn*(1.-fices)) - -!**** Calculate the ground-snow energy flux at 3 zones - - denom = 1./(sndz(N_snow)*0.5-zc1) - fhgnd = -sqrt(tkgnd*tksn(N_snow))*area*denom*(tpsn(N_snow)-t1) - fhsn(N_snow+1) = sum(fhgnd) - do i=1,N_zones - df(N_snow+1)=df(N_snow+1)-sqrt(tkgnd(i)*tksn(N_snow))*area(i)*denom - enddo - - -!**** Ensure against excessive heat flux between ground and snow: -!**** if heat flux found to cause the lowest snow layer temperature -!**** to "overshoot" (e.g. to become higher than the ground temperature -!**** when it had been lower), reduce the heat flux. If the lowest -!**** snow layer starts off at zero and the new temperature is greater -!**** than zero, reduce the heat flux to melt only half of the lowest -!**** layer snow. -!**** - t1ave=sum(t1*area)/sum(area) - htest=htsnn - htest(N_snow)=htest(N_snow)+fhsn(N_snow+1)*dts*areasc - - call StieglitzSnow_calc_tpsnow(N_snow, htest, wesn, ttest, ftest) + integer, intent(in) :: N_zones, N_snow, tileType - scale=1. - if((t1ave-tpsn(N_snow))*(t1ave-ttest(N_snow)) .lt. 0.) then - scale=0.5*(tpsn(N_snow)-t1ave)/(tpsn(N_snow)-ttest(N_snow)) - endif - if(tpsn(N_snow) .eq. 0. .and. ttest(N_snow) .gt. 0. .and. & - abs(fhsn(N_snow+1)) .gt. 1.e-10) then - scale=(-0.5*htsnn(N_snow)/(dts*areasc))/fhsn(N_snow+1) - endif + real, dimension(N_zones), intent(in) :: t1, area, tkgnd + real, dimension(N_constit), intent(in) :: totdepos + real, intent(in) :: ts, precip, snowf, dts, dedtc, raddn, hlwtc + real, intent(in ) :: dhsdtc, dhlwtc, eturb, hsturb, zc1 - fhsn(N_snow+1)=fhsn(N_snow+1)*scale - df(N_snow+1)=df(N_snow+1)*scale - fhgnd=fhgnd*scale + real, dimension(N_snow), intent(inout) :: wesn, htsnn, sndz + real, dimension(N_snow, N_constit), intent(inout) :: rconstit + real, dimension(N_snow), intent(out) :: tpsn, fices + real, dimension(N_zones), intent(out) :: fhgnd + real, intent(out) :: hlwout, lhflux, shflux, areasc0, evap, areasc, pre + real, intent(out) :: hcorr + real, dimension(N_constit), intent(out) :: rmelt + real, intent(out) :: ghfluxsno + + real, intent(out) :: wesnprec + real, intent(out) :: sndzsc, sndzprec + real, intent(out) :: sndz1perc + real, dimension(N_snow), intent(out) :: wesnperc + real, dimension(N_snow), intent(out) :: wesndens + real, dimension(N_snow), intent(out) :: wesnrepar + real, intent(out) :: mltwtr + real, dimension(N_snow), intent(out) :: excs + real, dimension(N_snow), intent(out) :: drho0 + real, intent(out) :: wesnbot + real, dimension(N_snow), intent(out) :: tksno + real, intent(out) :: dtss + + real, intent(in) :: maxsndepth + real, intent(in) :: rhofs + real, dimension(N_snow), intent(in) :: targetthick + + ! ---------------------------------------- + ! + ! Locals + + real :: tsx, mass,snowd,rainf,denom,alhv,lhturb,dlhdtc, & + enew,eold,tdum,fnew,tnew,icedens,densfac,hnew,scale,t1ave, & + flxnet,fdum,dw,waterin,waterout,snowin,snowout, mtwt, & + waterbal,precision,flow,term,dz,w(0:N_snow),HTSPRIME, & + wlossfrac + real :: excsdz, excswe, sndzsum, mtwt0 + + real, dimension(size(wesn) ) :: cmpc,dens + real, dimension(size(wesn) ) :: tksn + real, dimension(size(wesn) ) :: dtc,q,cl,cd,cr + real, dimension(size(wesn)+1) :: fhsn,df + real, dimension(size(wesn) ) :: htest,ttest,ftest + -!**** Calculate heat fluxes between snow layers. + ! by Teppei --- GOSWIM related variables + !============================================================================================ + + real, dimension(size(wesn) ) :: denblk ! bulk snow density + real, dimension(size(wesn) ) :: po ! snow porosity + + !============================================================================================ - do i=2,N_snow - df(i) = -sqrt(tksn(i-1)*tksn(i))/((sndz(i-1)+sndz(i))*0.5) - fhsn(i)= df(i)*(tpsn(i-1)-tpsn(i)) + logical, dimension(size(wesn) ) :: ice1, tzero + real, dimension(size(wesn) ) :: dens0 + real, dimension(N_constit) :: flow_r,rconc + + integer :: i,izone,k + logical :: logdum + + snowd = sum(wesn) + snowin = snowd + ghfluxsno = 0. + + !rr correction for "cold" snow + tsx = min(ts-tf,0.)*StieglitzSnow_CPW + + !rr correction for heat content of rain + !rr tsx_rain = max(ts-tf,0.)*cpw_liquid + + df = 0. + dtc = 0. + tpsn = 0. + fices = 0. + areasc = 0. + areasc0= 0. + pre = 0. + fhgnd = 0. + hlwout = 0. + shflux = 0. + lhflux = 0. + evap = 0. + excs = 0. + hcorr = 0. + dens = rhofs + rainf = precip - snowf ! [kg/m^2/s] + + sndzsc = 0. + wesnprec = 0. + sndzprec = 0. + sndz1perc = 0. + wesnperc = 0. + wesndens = 0. + wesnrepar = 0. + wesnbot = 0. + dtss = 0. + excswe = 0. + + rmelt = 0.0 + mltwtr = 0.0 + drho0 = 0.0 + tksno = 0.0 + + if(snowd <= StieglitzSnow_MINSWE) then ! initial snow mass is negligible + + ! Melt off initial (very small) snowpack; new snow pack is based + ! on new snowfall only (if any) + + call StieglitzSnow_calc_asnow( snowd, areasc ) + areasc0 = 0. + pre = snowd/dts + areasc*rainf ! pre = melted snowpack plus rainfall + wesn = 0. + hcorr = hcorr + raddn*areasc + sum(htsnn)/dts + htsnn = 0. + sndz = 0. + mltwtr = snowd/dts ! mltwtr = melted snowpack + do k=1,N_constit + rmelt(k)=sum(rconstit(:,k))/dts enddo - - ghfluxsno = fhsn(2) - -!**** Effective heat of vaporization includes bringing snow to 0 C - - alhv = alhe + alhm !randy -! alhv = alhe + fices(1)*alhm + tpsn(1)*cpw !randy - -!**** Initial estimate of latent heat flux change with Tc - - lhturb = alhv*eturb - dlhdtc = alhv*dedtc - -!**** Initial estimate of net surface flux & its change with Tc - - fhsn(1) = lhturb + hsturb + hlwtc - raddn - df(1) = -(dlhdtc + dhsdtc + dhlwtc) - -!**** Prepare array elements for solution & coefficient matrices. -!**** Terms are as follows: left (cl), central (cd) & right (cr) -!**** diagonal terms in coefficient matrix & solution (q) terms. - - do i=1,N_snow - - call get_tf0d(htsnn(i),wesn(i),tdum,fdum, ice1(i),tzero(i)) - - if(ice1(i)) then - cl(i) = df(i) - cd(i) = cpw*wesn(i)/dts - df(i) - df(i+1) - cr(i) = df(i+1) - q(i) = fhsn(i+1)-fhsn(i) - else - cl(i) = 0. - cd(i) = 1. - cr(i) = 0. - q(i) = 0. - endif - - enddo - - cl(1) = 0. - cr(N_snow) = 0. - - do i=1,N_snow-1 - if(.not.ice1(i)) cl(i+1) = 0. - enddo - - do i=2,N_snow - if(.not.ice1(i)) cr(i-1) = 0. - enddo - - -!**** Solve the tri-diagonal matrix for implicit change in Tc. - - call TRID(dtc,cl,cd,cr,q,N_snow) + rconstit(:,:) = 0. + + if(snowf > 0.) then ! only initialize with non-liquid part of precip + ! liquid precip (rainf) is part of outflow from snow base (see "pre" above) + + wesn = snowf*dts/float(N_snow) + htsnn = (tsx-alhm)*wesn + call StieglitzSnow_calc_asnow( snowf*dts, areasc0 ) -!**** Check temperature changes for passages across critical points,i.e. -!**** If implicit change has taken layer past melting/freezing, correct. + !*** should have fractional snow cover taken into account + sndz = wesn/(max(areasc0,small)*rhofs) - do i=1,N_snow - if(tpsn(i)+dtc(i) > 0. .or. htsnn(i)+wesn(i)*cpw*dtc(i) > 0.) then - dtc(i)=-tpsn(i) - endif - if(.not.ice1(i)) dtc(i)=0. + hcorr = hcorr - tsx*snowf ! randy + + ! Add constituent to top snow layer, in area covered by snow. + do k=1,N_constit + rconstit(1,k)=rconstit(1,k)+areasc0*totdepos(k)*dts enddo - -!**** Further adjustments; compute new values of h associated with -!**** all adjustments. - eold=sum(htsnn) - - do i=1,N_snow - -!**** Quick check for "impossible" condition: - - if(.not.tzero(i) .and. .not.ice1(i)) then - write(*,*) 'bad snow condition: fice,tpsn =',fices(i),tpsn(i) - stop - endif + ! call relayer without heat content adjustment -!**** Condition 1: layer starts fully frozen (temp < 0.) + call StieglitzSnow_relayer( N_snow, N_constit, tileType, targetthick, & + htsnn, wesn, sndz, rconstit ) + + call StieglitzSnow_calc_tpsnow(N_snow, htsnn, wesn, tpsn, fices) + + endif ! (snowf > 0.) + + return ! if there was no snow at start of time step + + endif ! (snowd <= StieglitzSnow_MINSWE) + + ! --------------------------------------------------------------- + ! + ! derive new snow pack from existing snow pack and new snowfall: + + !**** Determine the fractional snow coverage + + call StieglitzSnow_calc_asnow( snowd, areasc ) + + !**** Set the mean density & diffusivity of the layers + + do i=1,N_snow + if(sndz(i) > 0) dens(i) = max(wesn(i)/(areasc*sndz(i)),rhofs) + enddo + tksn = 3.2217e-06*dens**2 + tksno = tksn + dens0 = dens + + !**** Determine temperature & frozen fraction of snow layers + + call StieglitzSnow_calc_tpsnow(N_snow, htsnn, wesn, tpsn, fices) + + mtwt = sum(wesn*(1.-fices)) + + !**** Calculate the ground-snow energy flux at 3 zones + + denom = 1./(sndz(N_snow)*0.5-zc1) + fhgnd = -sqrt(tkgnd*tksn(N_snow))*area*denom*(tpsn(N_snow)-t1) + fhsn(N_snow+1) = sum(fhgnd) + do i=1,N_zones + df(N_snow+1)=df(N_snow+1)-sqrt(tkgnd(i)*tksn(N_snow))*area(i)*denom + enddo + + !**** Ensure against excessive heat flux between ground and snow: + !**** if heat flux found to cause the lowest snow layer temperature + !**** to "overshoot" (e.g. to become higher than the ground temperature + !**** when it had been lower), reduce the heat flux. If the lowest + !**** snow layer starts off at zero and the new temperature is greater + !**** than zero, reduce the heat flux to melt only half of the lowest + !**** layer snow. + + t1ave=sum(t1*area)/sum(area) + htest=htsnn + htest(N_snow)=htest(N_snow)+fhsn(N_snow+1)*dts*areasc + + call StieglitzSnow_calc_tpsnow(N_snow, htest, wesn, ttest, ftest) + + scale=1. + if((t1ave-tpsn(N_snow))*(t1ave-ttest(N_snow)) .lt. 0.) then + scale=0.5*(tpsn(N_snow)-t1ave)/(tpsn(N_snow)-ttest(N_snow)) + endif + if(tpsn(N_snow) .eq. 0. .and. ttest(N_snow) .gt. 0. .and. & + abs(fhsn(N_snow+1)) .gt. 1.e-10) then + scale=(-0.5*htsnn(N_snow)/(dts*areasc))/fhsn(N_snow+1) + endif + + fhsn(N_snow+1)=fhsn(N_snow+1)*scale + df(N_snow+1)=df(N_snow+1)*scale + fhgnd=fhgnd*scale + + !**** Calculate heat fluxes between snow layers. + + do i=2,N_snow + df(i) = -sqrt(tksn(i-1)*tksn(i))/((sndz(i-1)+sndz(i))*0.5) + fhsn(i)= df(i)*(tpsn(i-1)-tpsn(i)) + enddo + + ghfluxsno = fhsn(2) + + !**** Effective heat of vaporization includes bringing snow to 0 C + + alhv = alhe + alhm ! randy + + !**** Initial estimate of latent heat flux change with Tc + + lhturb = alhv*eturb + dlhdtc = alhv*dedtc + + !**** Initial estimate of net surface flux & its change with Tc - if(.not.tzero(i)) then + fhsn(1) = lhturb + hsturb + hlwtc - raddn + df(1) = -(dlhdtc + dhsdtc + dhlwtc) + + !**** Prepare array elements for solution & coefficient matrices. + !**** Terms are as follows: left (cl), central (cd) & right (cr) + !**** diagonal terms in coefficient matrix & solution (q) terms. + + do i=1,N_snow + + call StieglitzSnow_calc_tpsnow(htsnn(i),wesn(i),tdum,fdum, ice1(i),tzero(i), .true.) + + if(ice1(i)) then + cl(i) = df(i) + cd(i) = StieglitzSnow_CPW*wesn(i)/dts - df(i) - df(i+1) + cr(i) = df(i+1) + q(i) = fhsn(i+1)-fhsn(i) + else + cl(i) = 0. + cd(i) = 1. + cr(i) = 0. + q(i) = 0. + endif + + enddo + + cl(1) = 0. + cr(N_snow) = 0. + + do i=1,N_snow-1 + if(.not.ice1(i)) cl(i+1) = 0. + enddo + + do i=2,N_snow + if(.not.ice1(i)) cr(i-1) = 0. + enddo + + + !**** Solve the tri-diagonal matrix for implicit change in Tc. + + call STIEGLITZSNOW_TRID(dtc,cl,cd,cr,q,N_snow) + + !**** Check temperature changes for passages across critical points,i.e. + !**** If implicit change has taken layer past melting/freezing, correct. + + do i=1,N_snow + if(tpsn(i)+dtc(i) > 0. .or. htsnn(i)+wesn(i)*StieglitzSnow_CPW*dtc(i) > 0.) then + dtc(i)=-tpsn(i) + endif + if(.not.ice1(i)) dtc(i)=0. + enddo + + !**** Further adjustments; compute new values of h associated with + !**** all adjustments. + + eold=sum(htsnn) + + do i=1,N_snow + + !**** Quick check for "impossible" condition: + + if(.not.tzero(i) .and. .not.ice1(i)) then + write(*,*) 'bad snow condition: fice,tpsn =',fices(i),tpsn(i) + stop + endif + + !**** Condition 1: layer starts fully frozen (temp < 0.) + + if(.not.tzero(i)) then + tnew=tpsn(i)+dtc(i) + fnew=1. + + endif + + !**** Condition 2: layer starts with temp = 0, fices < 1. + ! Corrections for flxnet calculation: Koster, March 18, 2003. + + if(.not.ice1(i)) then + tnew=0. + if(i==1) flxnet= fhsn(i+1)+df(i+1)*(dtc(i)-dtc(i+1)) & + -fhsn(i)-df(i)*dtc(i) + if(i > 1 .and. i < N_snow) flxnet= & + fhsn(i+1)+df(i+1)*(dtc(i)-dtc(i+1)) & + -fhsn(i)-df(i)*(dtc(i-1)-dtc(i)) + if(i==N_snow) flxnet=fhsn(i+1)+df(i+1)*dtc(i) & + -fhsn(i)-df(i)*(dtc(i-1)-dtc(i)) + HTSPRIME=HTSNN(I)+AREASC*FLXNET*DTS + call StieglitzSnow_calc_tpsnow( HTSPRIME, wesn(i), tdum, fnew, logdum, logdum, .true. ) + fnew=amax1(0., amin1(1., fnew)) + + endif + + !**** Condition 3: layer starts with temp = 0, fices = 1. + ! Corrections for flxnet calculation: Koster, March 18, 2003. + + if(ice1(i) .and. tzero(i)) then + if(dtc(i) < 0.) then tnew=tpsn(i)+dtc(i) fnew=1. - - endif - -!**** Condition 2: layer starts with temp = 0, fices < 1. -! Corrections for flxnet calculation: Koster, March 18, 2003. - - if(.not.ice1(i)) then + endif + if(dtc(i) >= 0.) then tnew=0. - if(i==1) flxnet= fhsn(i+1)+df(i+1)*(dtc(i)-dtc(i+1)) & - -fhsn(i)-df(i)*dtc(i) - if(i > 1 .and. i < N_snow) flxnet= & - fhsn(i+1)+df(i+1)*(dtc(i)-dtc(i+1)) & - -fhsn(i)-df(i)*(dtc(i-1)-dtc(i)) - if(i==N_snow) flxnet=fhsn(i+1)+df(i+1)*dtc(i) & - -fhsn(i)-df(i)*(dtc(i-1)-dtc(i)) + if(i==1) flxnet=fhsn(i+1)+df(i+1)*(dtc(i)-dtc(i+1)) & + -fhsn(i)-df(i)*dtc(i) + if(i > 1 .and. i < N_snow) flxnet= & + fhsn(i+1)+df(i+1)*(dtc(i)-dtc(i+1)) & + -fhsn(i)-df(i)*(dtc(i-1)-dtc(i)) + if(i==N_snow) flxnet=fhsn(i+1)+df(i+1)*dtc(i) & + -fhsn(i)-df(i)*(dtc(i-1)-dtc(i)) + HTSPRIME=HTSNN(I)+AREASC*FLXNET*DTS - call get_tf0d(HTSPRIME,wesn(i), tdum,fnew,logdum,logdum) + call StieglitzSnow_calc_tpsnow( HTSPRIME, wesn(i), tdum, fnew, logdum, logdum, .true. ) fnew=amax1(0., amin1(1., fnew)) - - endif - -!**** Condition 3: layer starts with temp = 0, fices = 1. -! Corrections for flxnet calculation: Koster, March 18, 2003. - - if(ice1(i) .and. tzero(i)) then - if(dtc(i) < 0.) then - tnew=tpsn(i)+dtc(i) - fnew=1. - endif - if(dtc(i) >= 0.) then - tnew=0. - if(i==1) flxnet=fhsn(i+1)+df(i+1)*(dtc(i)-dtc(i+1)) & - -fhsn(i)-df(i)*dtc(i) - if(i > 1 .and. i < N_snow) flxnet= & - fhsn(i+1)+df(i+1)*(dtc(i)-dtc(i+1)) & - -fhsn(i)-df(i)*(dtc(i-1)-dtc(i)) - if(i==N_snow) flxnet=fhsn(i+1)+df(i+1)*dtc(i) & - -fhsn(i)-df(i)*(dtc(i-1)-dtc(i)) - - HTSPRIME=HTSNN(I)+AREASC*FLXNET*DTS - call get_tf0d(HTSPRIME,wesn(i), tdum,fnew,logdum,logdum) - fnew=amax1(0., amin1(1., fnew)) - endif - endif - -!**** Now update heat fluxes & compute sublimation or deposition. -!**** Note: constituents (dust, etc.) do not evaporate. - - if(i == 1) then - dtss = dtc(1) - lhflux = lhturb + dlhdtc*dtc(1) - shflux = hsturb + dhsdtc*dtc(1) - hlwout = hlwtc + dhlwtc*dtc(1) - evap = lhflux/alhv - dw = -evap*dts*areasc - if(-dw > wesn(1) ) then - dw = -wesn(1) - evap = -dw/(dts*areasc) -! shflux=shflux+(lhflux-evap*alhv) - hcorr=hcorr+(lhflux-evap*alhv)*areasc - lhflux=evap*alhv - endif - wesn(1) = wesn(1) + dw - denom = 1./dens(1) - if(dw > 0.) denom = 1./rhoma - sndz(1) = sndz(1) + dw*denom - !wesnsc = dw - sndzsc = dw*denom - endif - - if(i == N_snow) then - do izone=1,N_zones - fhgnd(izone)=fhgnd(izone)+area(izone)*df(N_snow+1)*dtc(N_snow) - enddo - endif - -!**** Now update thermodynamic quantities. - - htsnn(i)=(cpw*tnew-fnew*alhm)*wesn(i) - tpsn(i) = tnew - fices(i)= fnew - enddo - -!**** Store excess heat in hcorr. - - enew=sum(htsnn) - hcorr=hcorr-((enew-eold)/dts+areasc*(lhflux+shflux+hlwout-raddn) & - -areasc*(fhsn(N_snow+1)+df(N_snow+1)*dtc(N_snow)) & - ) - - call StieglitzSnow_calc_tpsnow(N_snow, htsnn, wesn, tpsn, fices) - - mltwtr = max(0., sum(wesn*(1.-fices)) - mtwt) - mltwtr = mltwtr / dts - - !mtwt0 = sum(wesn*(1.-fices)) + areasc*rainf*dts - mtwt0 = sum(wesn*fices) - -!rr!**** Add rainwater and snow at ts., bal. budget with shflux. -!rr (tried and failed 19 Jun 2003, reichle) -!rr -!rr wesn (1) = wesn (1) + (rainf*areasc+snowf)*dts -!rr htsnn(1) = htsnn(1) + (tsx -alhm)*(snowf*dts) + tsx_rain*rainf*dts -!rr sndz (1) = sndz (1) + (snowf/rhofs)*dts -!rr ! shflux = shflux + tsx*snowf ! randy -!rr hcorr = hcorr - (tsx-alhm)*snowf - tsx_rain*rainf ! randy - - -!**** Add rainwater at 0 C, snow at ts., bal. budget with shflux. - - wesn (1) = wesn (1) + (rainf*areasc+snowf)*dts - htsnn(1) = htsnn(1) + (tsx -alhm)*(snowf*dts) - sndz (1) = sndz (1) + (snowf/rhofs)*dts - wesnprec = (rainf*areasc+snowf)*dts - sndzprec = (snowf/rhofs)*dts -! shflux = shflux + tsx*snowf ! randy -! hcorr = hcorr - (tsx-alhm)*snowf ! randy - hcorr = hcorr - tsx*snowf ! randy + endif + endif - snowd=sum(wesn) - - call StieglitzSnow_calc_tpsnow(N_snow, htsnn, wesn, tpsn, fices) - - -!**** Constituent deposition: Add to top snow layer, in area covered by snow. - do k=1,N_constit - rconstit(1,k)=rconstit(1,k)+areasc*totdepos(k)*dts - enddo - - -!**** Move meltwater through the pack. -!**** Updated by Koster, August 27, 2002. - - pre = 0. - rmelt(:) = 0. - flow = 0. - flow_r(:) = 0. - - wesnperc = wesn + !**** Now update heat fluxes & compute sublimation or deposition. + !**** Note: constituents (dust, etc.) do not evaporate. + + if(i == 1) then + dtss = dtc(1) + lhflux = lhturb + dlhdtc*dtc(1) + shflux = hsturb + dhsdtc*dtc(1) + hlwout = hlwtc + dhlwtc*dtc(1) + evap = lhflux/alhv + dw = -evap*dts*areasc + if(-dw > wesn(1) ) then + dw = -wesn(1) + evap = -dw/(dts*areasc) + hcorr=hcorr+(lhflux-evap*alhv)*areasc + lhflux=evap*alhv + endif + wesn(1) = wesn(1) + dw + denom = 1./dens(1) + if(dw > 0.) denom = 1./StieglitzSnow_RHOMA + sndz(1) = sndz(1) + dw*denom + sndzsc = dw*denom + endif + + if(i == N_snow) then + do izone=1,N_zones + fhgnd(izone)=fhgnd(izone)+area(izone)*df(N_snow+1)*dtc(N_snow) + enddo + endif + + !**** Now update thermodynamic quantities. + + htsnn(i)=(StieglitzSnow_CPW*tnew-fnew*alhm)*wesn(i) + tpsn(i) = tnew + fices(i)= fnew - do i=1,N_snow + enddo ! (i=1,N_snow) + + ! ----------------------------------------------------------------------------- + ! + !**** Store excess heat in hcorr. + + enew=sum(htsnn) + hcorr=hcorr-((enew-eold)/dts+areasc*(lhflux+shflux+hlwout-raddn) & + -areasc*(fhsn(N_snow+1)+df(N_snow+1)*dtc(N_snow)) & + ) + + call StieglitzSnow_calc_tpsnow(N_snow, htsnn, wesn, tpsn, fices) + + mltwtr = max(0., sum(wesn*(1.-fices)) - mtwt) + mltwtr = mltwtr / dts + + mtwt0 = sum(wesn*fices) + + !rr!**** Add rainwater and snow at ts., bal. budget with shflux. + !rr (tried and failed 19 Jun 2003, reichle) + !rr + !rr wesn (1) = wesn (1) + (rainf*areasc+snowf)*dts + !rr htsnn(1) = htsnn(1) + (tsx -alhm)*(snowf*dts) + tsx_rain*rainf*dts + !rr sndz (1) = sndz (1) + (snowf/rhofs)*dts + !rr ! shflux = shflux + tsx*snowf ! randy + !rr hcorr = hcorr - (tsx-alhm)*snowf - tsx_rain*rainf ! randy + + !**** Add rainwater at 0 C, snow at ts., bal. budget with shflux. + + wesn (1) = wesn (1) + (rainf*areasc+snowf)*dts + htsnn(1) = htsnn(1) + (tsx -alhm)*(snowf*dts) + sndz (1) = sndz (1) + (snowf/rhofs)*dts + wesnprec = (rainf*areasc+snowf)*dts + sndzprec = (snowf/rhofs)*dts + hcorr = hcorr - tsx*snowf ! randy + + snowd=sum(wesn) + + call StieglitzSnow_calc_tpsnow(N_snow, htsnn, wesn, tpsn, fices) + + !**** Constituent deposition: Add to top snow layer, in area covered by snow. + do k=1,N_constit + rconstit(1,k)=rconstit(1,k)+areasc*totdepos(k)*dts + enddo - if(flow > 0.) then - wesn (i) = wesn(i) + flow + !**** Move meltwater through the pack. + !**** Updated by Koster, August 27, 2002. + + pre = 0. + rmelt(:) = 0. + flow = 0. + flow_r(:) = 0. + + wesnperc = wesn + + do i=1,N_snow + + if(flow > 0.) then + wesn (i) = wesn(i) + flow ! add "flow" [kg/m2] from layer i-1 to wesn(i) do k=1,N_constit rconstit(i,k)=rconstit(i,k)+flow_r(k) enddo - call StieglitzSnow_calc_tpsnow(N_snow, htsnn, wesn, tpsn, fices) - endif - - pre = max((1.-fices(i))*wesn(i), 0.) - flow = 0. - flow_r(:) = 0. - rconc(:) = 0. - - if(snowd > wemin) then - - icedens=wesn(i)*fices(i)/(sndz(i)+1.e-20) - densfac=amax1(0., amin1(1., icedens/rhofs)) - term=densfac*snfr*(sndz(i)*rhow-wesn(i)*fices(i)) - + call StieglitzSnow_calc_tpsnow(N_snow, htsnn, wesn, tpsn, fices) + endif + + pre = max((1.-fices(i))*wesn(i), 0.) + flow = 0. + flow_r(:) = 0. + rconc(:) = 0. + + if(snowd > wemin) then + + icedens = wesn(i)*fices(i)/(sndz(i)+1.e-20) + densfac = amax1(0., amin1(1., icedens/rhofs)) + term = densfac*snfr*(sndz(i)*rhow-wesn(i)*fices(i)) + if(pre > term) then - pre = min(pre - term, wesn(i)) + pre = min(pre - term, wesn(i)) ! when asnow=1, retain some liquid water in snow pack do k=1,N_constit rconc(k)=rconstit(i,k)/wesn(i) enddo - wesn(i) = wesn(i) - pre - flow = pre + wesn(i) = wesn(i) - pre + flow = pre endif - else - do k=1,N_constit - rconc(k)=rconstit(i,k)/wesn(i) - enddo - wesn(i) = wesn(i) - pre + else + do k=1,N_constit + rconc(k)=rconstit(i,k)/wesn(i) + enddo + wesn(i) = wesn(i) - pre ! when asnow<1, remove all liquid water from snow pack flow = pre endif - -!------------------------------- by Teppei --------------------------------------- - if(areasc.ge.0.999) then - - do k=1,N_constit - ! mass loss by excess water - ! To calculate bulk snow density in snow layers - denblk(i)=( wesn(i)/(areasc+1.e-20) )/(sndz(i)+1.e-20) + !------------------------------- by Teppei --------------------------------------- - ! porosity of snow layers - po(i)=-7.2E-07*(denblk(i)**2.0)-(0.00063*denblk(i))+0.967073 - if(denblk(i) > 800.) po(i)=0. + if(areasc.ge.0.999) then + + do k=1,N_constit + ! mass loss by excess water + ! To calculate bulk snow density in snow layers + + denblk(i)=( wesn(i)/(areasc+1.e-20) )/(sndz(i)+1.e-20) + + ! porosity of snow layers + po(i)=-7.2E-07*(denblk(i)**2.0)-(0.00063*denblk(i))+0.967073 + if(denblk(i) > 800.) po(i)=0. + + ! constituents flushing + flow_r(k)=(po(i)*(1.0-(min(PSIZE(k),5.0)/5.0))*SCAV(k)) & + *(rconc(k)+1.0e-20)*flow + if ( (flow < 1.0e-20).or.(denblk(i) > 800.) ) flow_r(k)=0. + + rconstit(i,k)=rconstit(i,k)-flow_r(k) + rconstit(i,k)=amax1(0.,rconstit(i,k)) ! guard against truncation error + + enddo + + endif + + if(areasc.lt.0.999) then + + do k=1,N_constit + flow_r(k)=rconc(k)*flow + rconstit(i,k)=rconstit(i,k)-flow_r(k) + rconstit(i,k)=amax1(0.,rconstit(i,k)) ! guard against truncation error + enddo + + endif - ! constituents flushing - flow_r(k)=(po(i)*(1.0-(min(PSIZE(k),5.0)/5.0))*SCAV(k)) & - *(rconc(k)+1.0e-20)*flow - if ( (flow < 1.0e-20).or.(denblk(i) > 800.) ) flow_r(k)=0. + !--------------------------------------------------------------------------------- + + !**** Adjust top layer snow depth to get proper density values + !**** But limit this change for large throughflow (STEPH 06/19/03) + + if (i==1) then + dz=min(flow/dens(i),0.5*sndz(i)) + sndz(i)=sndz(i)-dz + sndz1perc = -dz + endif - rconstit(i,k)=rconstit(i,k)-flow_r(k) - rconstit(i,k)=amax1(0.,rconstit(i,k)) ! guard against truncation error + enddo ! (i=1,N_snow) + + ! ---------------------------------------------------------------------------------------- - enddo + wesnperc = wesn - wesnperc + + pre = flow/dts ! convert outflow to flux units [kg/m2/s] + do k=1,N_constit + rmelt(k)=rmelt(k)+flow_r(k)/dts + enddo + snowd=sum(wesn) + + !**** Update snow density by compaction (Pitman et al. 1991) + + mass = 0. + w = 0. + + wesndens = wesn + + if(snowd > wemin) then ! Compaction only after full coverage. + + do i=1,N_snow + dens(i) = rhofs + if(sndz(i)>0.) dens(i) = max(wesn(i)/(sndz(i)),rhofs) + enddo + + drho0 = dens + + cmpc = exp(14.643 - (4000./min(tpsn+tf,tf))-.02*dens) + + do i=1,N_snow - endif + w(i) = wesn(i) + mass = mass + 0.5*(w(i)+w(i-1)) + dens(i) = dens(i)*(1. + (dts*0.5e-7*9.81)*mass*cmpc(i)) + + !**** Clip densities below maximum value, adjust quantities accordingly + !**** while conserving heat & mass (STEPH 06/21/03). + + if(dens(i) > StieglitzSnow_RHOMA) then - if(areasc.lt.0.999) then + ! excs = SWE in excess of max density given fixed snow depth + excs(i) = (dens(i)-StieglitzSnow_RHOMA)*sndz(i) ! solid + liquid + wlossfrac=excs(i)/wesn(i) + wesn(i) = wesn(i) - excs(i) ! remove EXCS from SWE do k=1,N_constit - flow_r(k)=rconc(k)*flow - rconstit(i,k)=rconstit(i,k)-flow_r(k) - rconstit(i,k)=amax1(0.,rconstit(i,k)) ! guard against truncation error - enddo - - endif -!--------------------------------------------------------------------------------- - -!**** Adjust top layer snow depth to get proper density values -!**** But limit this change for large throughflow (STEPH 06/19/03) - - if(i==1)then - dz=min(flow/dens(i),0.5*sndz(i)) - sndz(i)=sndz(i)-dz - sndz1perc = -dz - endif + rmelt(k)=rmelt(k)+rconstit(i,k)*wlossfrac/dts + rconstit(i,k)=rconstit(i,k)*(1.-wlossfrac) + rconstit(i,k)=amax1(0.,rconstit(i,k)) ! guard against truncation error + enddo + hnew = (StieglitzSnow_CPW*tpsn(i)-fices(i)*alhm)*wesn(i) ! adjust heat content accordingly + hcorr= hcorr+(htsnn(i)-hnew)/dts ! add excess heat content into residual accounting term + htsnn(i)= hnew + dens(i) = StieglitzSnow_RHOMA + endif enddo + drho0 = dens - drho0 + endif + + wesndens = wesn - wesndens - wesnperc = wesn - wesnperc - - pre = flow/dts + pre = pre + sum(excs*max(1.-fices,0.0))/dts + excs = excs * fices / dts + + snowd=sum(wesn) + call StieglitzSnow_calc_asnow( snowd, areasc0 ) + areasc0 = max(small, areasc0 ) + sndz = (wesn/areasc0)/dens + + sndzsum = sum(sndz) + if(sndzsum > maxsndepth) then + excsdz = sndzsum - maxsndepth + excswe = dens(N_snow) * excsdz + wlossfrac=excswe/wesn(N_snow) + wesn(N_snow) = wesn(N_snow) - excswe do k=1,N_constit - rmelt(k)=rmelt(k)+flow_r(k)/dts + rmelt(k)=rmelt(k)+rconstit(N_snow,k)*wlossfrac/dts + rconstit(N_snow,k)=rconstit(N_snow,k)*(1.-wlossfrac) + rconstit(N_snow,k)=amax1(0.,rconstit(N_snow,k)) ! guard against truncation error enddo - snowd=sum(wesn) - -!**** Update snow density by compaction (Pitman et al. 1991) - - mass = 0. - w = 0. - - wesndens = wesn + hnew = (StieglitzSnow_CPW*tpsn(N_snow)-fices(N_snow)*alhm)*wesn(N_snow) + htsnn(N_snow)= hnew + sndz(N_snow) = sndz(N_snow) - excsdz + wesnbot = excswe + endif + + !**** Restore layers to sigma values. + + wesnrepar = wesn + + ! call relayer with adjustment of heat content and hcorr accounting - if(snowd > wemin) then ! Compaction only after full coverage. + call StieglitzSnow_relayer( N_snow, N_constit, tileType, targetthick, & + htsnn, wesn, sndz, rconstit, tpsn, fices, dts, hcorr ) + + wesnrepar = wesn - wesnrepar + + !**** Reset fractional area coverage. + + call StieglitzSnow_calc_asnow( sum(wesn), areasc0 ) + + !**** Final check for water balance. + + waterin = (rainf*areasc+snowf)*dts + max(dw,0.) + waterout = pre*dts - min(dw,0.) + snowout = sum(wesn) + sum(excs) + excswe + waterbal = snowin + waterin - waterout - snowout + precision = snowout*small + +#if 0 + if((waterbal > precision).and.(waterbal > small) .or. pre < -1.e-13 ) then + write(*,*) 'Warning: Imbalance in snow water budget!', waterbal + write(*,*) 'waterin = ', waterin + write(*,*) 'snowin = ', snowin + write(*,*) 'waterout = ', waterout + write(*,*) 'snowout = ', snowout + write(*,*) 'dw = ', dw + write(*,*) 'excswe = ', excswe + write(*,*) 'sum(excs) = ', sum(excs) + write(*,*) 'snowf*dts = ', snowf*dts + write(*,*) 'sum(wesn) = ', sum(wesn) + write(*,*) (wesn(i), i=1,N_snow) + write(*,*) 'sum(sndz) = ', sum(sndz) + write(*,*) (sndz(i), i=1,N_snow) + write(*,*) 'dens0 = ' + write(*,*) (dens0(i), i=1,N_snow) + !write(*,*) 'sum(wesn0) = ', sum(wesn0) + !write(*,*) (wesn0(i), i=1,N_snow) + write(*,*) 'sum(wesn1) = ', sum(wesn1) + write(*,*) (wesn1(i), i=1,N_snow) + write(*,*) 'sum(wesn2) = ', sum(wesn2) + write(*,*) (wesn2(i), i=1,N_snow) + !write(*,*) 'sum(sndz0) = ', sum(sndz0) + !write(*,*) (sndz0(i), i=1,N_snow) + write(*,*) 'sum(sndz1) = ', sum(sndz1) + write(*,*) (sndz1(i), i=1,N_snow) + write(*,*) 'sum(sndz2) = ', sum(sndz2) + write(*,*) (sndz2(i), i=1,N_snow) + !stop + endif +#endif + + return ! end snow + + end subroutine StieglitzSnow_snowrt + + ! ********************************************************************** + + subroutine FindTargetThickDist_Landice(N_snow, sndz, dzmax, topthick, thickdist) + + ! get snow layer target thicknesses to be used with relayer for *landice* + integer, intent(in) :: N_snow + real, intent(in) :: sndz(N_snow) + real, intent(in) :: dzmax(N_snow) + real, intent(out) :: topthick + real, intent(out), dimension(N_snow-1) :: thickdist + + real, dimension(N_snow) :: sndzt + real :: totald, dzdiff, restthick + integer :: i + integer, dimension(N_snow) :: mark + logical :: lth_satisfy + + totald = sum(sndz) + sndzt = totald/float(N_snow) + + if (sndzt(1) < dzmax(1)) then + + topthick = dzmax(1) + do i=2,N_snow + thickdist(i-1) = 1.0/real(N_snow-1,kind=4) + enddo + + else + + mark = 0 + do + lth_satisfy = .true. do i=1,N_snow - dens(i) = rhofs - if(sndz(i)>0.) dens(i) = max(wesn(i)/(sndz(i)),rhofs) + if(mark(i) == 0 .and. sndzt(i) > dzmax(i)) then + sndzt(i) = dzmax(i) + mark(i) = 1 + lth_satisfy = .false. + endif enddo - - drho0 = dens - - cmpc = exp(14.643 - (4000./min(tpsn+tf,tf))-.02*dens) - + if(lth_satisfy) exit + dzdiff = 0.0 do i=1,N_snow - w(i) = wesn(i) - mass = mass + 0.5*(w(i)+w(i-1)) - dens(i) = dens(i)*(1. + (dts*0.5e-7*9.81)*mass*cmpc(i)) - -!**** Clip densities below maximum value, adjust quantities accordingly -!**** while conserving heat & mass (STEPH 06/21/03). - - if(dens(i) > rhoma) then - excs(i) = (dens(i)-rhoma)*sndz(i) - wlossfrac=excs(i)/wesn(i) - wesn(i) = wesn(i) - excs(i) - do k=1,N_constit - rmelt(k)=rmelt(k)+rconstit(i,k)*wlossfrac/dts - rconstit(i,k)=rconstit(i,k)*(1.-wlossfrac) - rconstit(i,k)=amax1(0.,rconstit(i,k)) ! guard against truncation error - enddo - hnew = (cpw*tpsn(i)-fices(i)*alhm)*wesn(i) - hcorr= hcorr+(htsnn(i)-hnew)/dts - htsnn(i)= hnew - dens(i) = rhoma + if(mark(i) == 1) then + dzdiff = dzdiff + sndzt(i) endif enddo - drho0 = dens - drho0 - endif - - wesndens = wesn - wesndens + restthick = (totald-dzdiff)/float(N_snow-sum(mark)) + do i=1,N_snow + if(mark(i) == 0) then + sndzt(i) = restthick + endif + enddo + enddo + + topthick = sndzt(1) + totald = totald - topthick + do i=2,N_snow + thickdist(i-1) = sndzt(i)/totald + enddo + + endif + + return + + end subroutine FindTargetThickDist_Landice + + ! ********************************************************************** + + subroutine StieglitzSnow_relayer(N_snow, N_constit, tileType, targetthick, & + htsnn, wesn, sndz, rconstit, tpsn, fices, dts, hcorr ) + + ! relayer for land and landice tiles - !pre = pre + sum(excs)/dts - pre = pre + sum(excs*max(1.-fices,0.0))/dts - excs = excs * fices / dts - + ! revised to included processing of target thickness parameters and + ! optional snow heat content adjustment + ! + ! optional arguments action + ! ----------------------------------------------------------- + ! none original relayer() (redistribution only) + ! tpsn, fices + adjust heat content (originally done externally) + ! tpsn, fices, dts, hcorr + account for heat content adjustment in correction term - snowd=sum(wesn) - areasc0 = max(small, min(snowd/wemin,1.) ) - sndz = (wesn/areasc0)/dens - - sndzsum = sum(sndz) - if(sndzsum > maxsndepth) then - excsdz = sndzsum - maxsndepth - excswe = dens(N_snow) * excsdz - wlossfrac=excswe/wesn(N_snow) - wesn(N_snow) = wesn(N_snow) - excswe - do k=1,N_constit - rmelt(k)=rmelt(k)+rconstit(N_snow,k)*wlossfrac/dts - rconstit(N_snow,k)=rconstit(N_snow,k)*(1.-wlossfrac) - rconstit(N_snow,k)=amax1(0.,rconstit(N_snow,k)) ! guard against truncation error - enddo - hnew = (cpw*tpsn(N_snow)-fices(N_snow)*alhm)*wesn(N_snow) - htsnn(N_snow)= hnew - sndz(N_snow) = sndz(N_snow) - excsdz - wesnbot = excswe - endif + implicit none + + integer, intent(in) :: N_snow, N_constit, tileType + real, intent(in), dimension(N_snow) :: targetthick - -!**** Restore layers to sigma values. - - wesnrepar = wesn + real, intent(inout), dimension(N_snow) :: htsnn, wesn, sndz + real, intent(inout), dimension(N_snow,N_constit) :: rconstit + + real, intent(out), dimension(N_snow), optional :: tpsn, fices - do i=1,N_snow - call get_tf0d(htsnn(i),wesn(i),tdum,fdum,ice10(i),tzero0(i)) - enddo + real, intent(in), optional :: dts + real, intent(inout), optional :: hcorr - !sndz1 = sndz + ! ---------------------------- + ! + ! local variables: + + character(len=*), parameter :: Iam = 'StieglitzSnow_relayer' - !call relayer(N_snow, htsnn, wesn, sndz) - select case (tileType) - case (MAPL_LANDICE) - call FindTargetThickDist(N_snow, sndz, targetthick, topthick, thickdist) - case default - topthick = targetthick(1) - thickdist = targetthick(2:N_snow) - end select + real :: thick_toplayer + real, dimension(N_snow-1) :: thickdist - !wesn1 = wesn - call relayer2(N_snow, N_constit, topthick, thickdist, & - htsnn, wesn, sndz, rconstit) - !wesn2 = wesn - !sndz2 = sndz + real, dimension(N_snow, 2+N_Constit) :: h, s + + integer :: i, k, ilow, ihigh + + real :: dz, hnew + real :: totalthick, tdum, fdum + real, dimension(N_snow) :: tol_old, bol_old, tol_new, bol_new + real, dimension(N_snow) :: thickness - wesnrepar = wesn - wesnrepar + logical :: adjust_htsnn, update_hcorr, kflag - call StieglitzSnow_calc_tpsnow(N_snow, htsnn, wesn, tpsn, fices) + logical, dimension(N_snow) :: ice10, tzero0 + + !**** thickness(1) : final thickness of topmost snow layer (m) + !**** h : array holding specific heat, water, and constituent contents + !**** s : array holding the total and final heat, water, and constit. contents + !**** ilow : first layer used in a particular relayering calculation + !**** ihigh : final layer used in a particular relayering calculation + !**** totalthick : total thickness of layers 2 through N_snow + !**** thickness : array holding final thicknesses (m) of the snow layers + !**** tol_old(i) : depth (from surface) of the top of layer i, before & + !**** relayering + !**** bol_old(i) : depth (from surface) of the bottom of layer i, before & + !**** relayering + !**** tol_old(i) : depth (from surface) of the top of layer i, after & + !**** relayering + !**** bol_old(i) : depth (from surface) of the bottom of layer i, after & + !**** relayering + + ! --------------------------------------- + ! + ! process optional arguments (required to maintain 0-diff; reichle 13 Oct 2023) + + if ( present(tpsn) .and. present(fices) ) then + + adjust_htsnn = .true. + + elseif ( present(tpsn) .or. present(fices) ) then + + write(*,*) Iam, '(): bad optional arguments (tpsn, fices)' + stop + + else + + adjust_htsnn = .false. + + end if + + if (adjust_htsnn) then + + if ( present(dts) .and. present(hcorr) ) then + + update_hcorr = .true. + + elseif ( present(dts) .or. present(hcorr) ) then + + write(*,*) Iam, '(): bad optional arguments (dts, hcorr)' + stop + + else + + update_hcorr = .false. + + end if + + ! determine frozen fraction and temperature before relayering -!**** Check that (ice10,tzero) conditions are conserved through -!**** relayering process (or at least that (fices,tpsn) conditions don't -!**** go through the (1,0) point); excess goes to hcorr. - do i=1,N_snow - kflag=.false. - if(ice10(i).and.tzero0(i) .and. & - (fices(i) .ne. 1. .or. tpsn(i) .ne. 0.) ) kflag=.true. - if(.not.ice10(i).and.tzero0(i) .and. & - (fices(i) .eq. 1. .and. tpsn(i) .lt. 0.) ) kflag=.true. - if(ice10(i).and. .not.tzero0(i) .and. & - (fices(i) .ne. 1. .and. tpsn(i) .eq. 0.) ) kflag=.true. - - if(kflag) then - hnew=-alhm*wesn(i) - hcorr=hcorr+(htsnn(i)-hnew)/dts - htsnn(i)=hnew - tpsn(i)=0. - fices(i)=1. - endif + call StieglitzSnow_calc_tpsnow(htsnn(i),wesn(i),tdum,fdum,ice10(i),tzero0(i), .true. ) + enddo - enddo + end if + + ! process "targetthick" snow depth parameters: + ! + ! targetthick: contents depend on tileType (Catch[CN] or Landice) + ! + ! thick_toplayer: *target* thickness of top snow layer (m); + ! NOTE: thickness(1) [see below] is final thickness of top layer (m) + ! + ! thickdist: assigned (final) distribution of thickness in layers 2:N_snow, + ! in terms of fraction + + select case (tileType) + case (MAPL_LANDICE) + call FindTargetThickDist_Landice(N_snow, sndz, targetthick, thick_toplayer, thickdist) + case default + thick_toplayer = targetthick(1) + thickdist = targetthick(2:N_snow) + end select + + ! ---------------------------------------------------------------------------------------- + ! + ! start of original relayer() + totalthick = sum(sndz) ! total snow depth -!**** Reset fractional area coverage. + ! make sure thickness of top layer does not exceed total thickness - areasc0 = min(sum(wesn)/wemin,1.) - -!**** Final check for water balance. + thickness(1) = amin1(totalthick*0.9, thick_toplayer) - waterin = (rainf*areasc+snowf)*dts + max(dw,0.) - waterout = pre*dts - min(dw,0.) - snowout = sum(wesn) + sum(excs) + excswe - waterbal = snowin + waterin - waterout - snowout - precision = snowout*small + totalthick = totalthick-thickness(1) -#if 0 - if((waterbal > precision).and.(waterbal > small) .or. pre < -1.e-13 ) then - write(*,*) 'Warning: Imbalance in snow water budget!', waterbal - write(*,*) 'waterin = ', waterin - write(*,*) 'snowin = ', snowin - write(*,*) 'waterout = ', waterout - write(*,*) 'snowout = ', snowout - write(*,*) 'dw = ', dw - write(*,*) 'excswe = ', excswe - write(*,*) 'sum(excs) = ', sum(excs) - write(*,*) 'snowf*dts = ', snowf*dts - write(*,*) 'sum(wesn) = ', sum(wesn) - write(*,*) (wesn(i), i=1,N_snow) - write(*,*) 'sum(sndz) = ', sum(sndz) - write(*,*) (sndz(i), i=1,N_snow) - write(*,*) 'dens0 = ' - write(*,*) (dens0(i), i=1,N_snow) - !write(*,*) 'sum(wesn0) = ', sum(wesn0) - !write(*,*) (wesn0(i), i=1,N_snow) - write(*,*) 'sum(wesn1) = ', sum(wesn1) - write(*,*) (wesn1(i), i=1,N_snow) - write(*,*) 'sum(wesn2) = ', sum(wesn2) - write(*,*) (wesn2(i), i=1,N_snow) - !write(*,*) 'sum(sndz0) = ', sum(sndz0) - !write(*,*) (sndz0(i), i=1,N_snow) - write(*,*) 'sum(sndz1) = ', sum(sndz1) - write(*,*) (sndz1(i), i=1,N_snow) - write(*,*) 'sum(sndz2) = ', sum(sndz2) - write(*,*) (sndz2(i), i=1,N_snow) - !stop + do i=1,N_snow-1 + thickness(i+1)=thickdist(i)*totalthick + enddo + + !**** Initialize some variables. + + h = 0. + s = 0. + dz = 0. + + !**** Compute specific heat & water contents of old layers. + + do i=1,N_snow + if (sndz(i) > 0.) then + h(i,1) = htsnn(i)/sndz(i) + h(i,2) = wesn(i)/sndz(i) + do k=1,N_Constit + h(i,2+k)=rconstit(i,k)/sndz(i) + enddo endif -#endif - - return ! end snow - - end subroutine snowrt - -! ********************************************************************** - - subroutine FindTargetThickDist(N_snow, sndz, dzmax, topthick, thickdist) - - integer, intent(in) :: N_snow - real, intent(in) :: sndz(N_snow) - real, intent(in) :: dzmax(N_snow) - real, intent(out) :: topthick - real, intent(out), dimension(N_snow-1) :: thickdist - - real, dimension(N_snow) :: sndzt - real :: totald, dzdiff, restthick - integer :: i - integer, dimension(N_snow) :: mark - logical :: lth_satisfy - - totald = sum(sndz) - sndzt = totald/float(N_snow) - if(sndzt(1) < dzmax(1)) then - - topthick = dzmax(1) - do i=2,N_snow - thickdist(i-1) = 1.0/real(N_snow-1,kind=4) - enddo + enddo + + !**** Determine old and new boundary depths (cumulative from top) + !**** (tol refers to "top of layer", bol refers to "bottom of layer" + + tol_old(1)=0. + bol_old(1)=sndz(1) + tol_new(1)=0. + bol_new(1)=thickness(1) + + do i=2,N_snow + tol_old(i)=bol_old(i-1) + bol_old(i)=bol_old(i-1)+sndz(i) + tol_new(i)=bol_new(i-1) + bol_new(i)=bol_new(i-1)+thickness(i) + enddo + + !**** Redistribute quantities + + !**** Step 1: Do top layer + ihigh=1 + do k=1,N_snow + if(bol_old(k) .lt. bol_new(1)) ihigh=k+1 + enddo + + do k=1,ihigh + if(k .lt. ihigh) dz=sndz(k) + if(k .eq. ihigh) dz=bol_new(1)-tol_old(k) + s(1,:)=s(1,:)+h(k,:)*dz + enddo + + !**** Step 2: Do remaining layers + do i=2,N_snow + + ilow=ihigh + do k=ilow,N_snow + if(bol_old(k) .lt. bol_new(i)) ihigh=k+1 + enddo + + if(ihigh .eq. N_snow+1) ihigh=N_snow ! Account for potential truncation problem + + do k=ilow,ihigh + if(k .eq. ilow .and. k .lt. ihigh) dz=bol_old(k)-tol_new(i) + if(k .eq. ilow .and. k .eq. ihigh) dz=bol_new(i)-tol_new(i) + if(k .gt. ilow .and. k .lt. ihigh) dz=bol_old(k)-tol_old(k) + if(k .gt. ilow .and. k .eq. ihigh) dz=bol_new(i)-tol_old(k) + s(i,:)=s(i,:)+h(k,:)*dz + enddo + + enddo + + htsnn = s(:,1) + wesn = s(:,2) + do k=1,N_Constit + rconstit(:,k)=s(:,2+k) + enddo + sndz=thickness + + ! end of original relayer() + ! + ! ---------------------------------------------------------------------------------------- + + if (adjust_htsnn) then + + call StieglitzSnow_calc_tpsnow(N_snow, htsnn, wesn, tpsn, fices) + + !**** Check that (ice10,tzero) conditions are conserved through + !**** relayering process (or at least that (fices,tpsn) conditions don't + !**** go through the (1,0) point); excess goes to hcorr. + + ! for each layer, check snow conditions (partially/fully frozen, temp at/below zero) + ! before and after relayer; in select cases, adjust snow heat content and temp + ! + ! NOTE: logicals before relayer were computed with "buffer" (use_threshold_fac=.true. ) + ! reals after relayer were computed without "buffer" (use_threshold_fac=.false.) + + do i=1,N_snow + + kflag = .false. ! default: do nothing + + ! set klfag to .true. under certain conditions: + + if( ice10(i) .and. tzero0(i) .and. & ! if before relayer: fully frozen and at 0 deg + (fices(i) .ne. 1. .or. tpsn(i) .ne. 0.) ) kflag=.true. ! and after relayer: partially frozen or below 0 deg (or above 0 deg?) + + if(.not.ice10(i) .and. tzero0(i) .and. & ! if before relayer: partially frozen and at 0 deg + (fices(i) .eq. 1. .and. tpsn(i) .lt. 0.) ) kflag=.true. ! and after relayer: fully frozen and below 0 deg + + if( ice10(i) .and. .not.tzero0(i) .and. & ! if before relayer: fully frozen and below 0 deg + (fices(i) .ne. 1. .and. tpsn(i) .eq. 0.) ) kflag=.true. ! and after relayer: partially frozen and at 0 deg + + if (kflag) then + + ! make fully frozen and at 0 deg - else + hnew = -alhm*wesn(i) + + ! add "excess" heat content to hcorr + + if (update_hcorr) hcorr = hcorr+(htsnn(i)-hnew)/dts - mark = 0 - do - lth_satisfy = .true. - do i=1,N_snow - if(mark(i) == 0 .and. sndzt(i) > dzmax(i)) then - sndzt(i) = dzmax(i) - mark(i) = 1 - lth_satisfy = .false. + htsnn(i)= hnew + tpsn(i) = 0. + fices(i)= 1. endif - enddo - if(lth_satisfy) exit - dzdiff = 0.0 - do i=1,N_snow - if(mark(i) == 1) then - dzdiff = dzdiff + sndzt(i) - endif - enddo - restthick = (totald-dzdiff)/float(N_snow-sum(mark)) - do i=1,N_snow - if(mark(i) == 0) then - sndzt(i) = restthick - endif - enddo - enddo - - topthick = sndzt(1) - totald = totald - topthick - do i=2,N_snow - thickdist(i-1) = sndzt(i)/totald - enddo - - endif - - return - - end subroutine FindTargetThickDist - - - -! ********************************************************************** - - subroutine relayer2(N_snow, N_constit, thick_toplayer, thickdist, & - htsnn, wesn, sndz, rconstit) - - implicit none - integer, intent(in) :: N_snow, N_constit - real, intent(in) :: thick_toplayer - real, intent(in), dimension(N_snow-1) :: thickdist - real, intent(inout) :: htsnn(N_snow),wesn(N_snow),sndz(N_snow) - real, intent(inout) :: rconstit(N_snow,N_constit) - !integer, intent(in) :: pid, ktile - - real, dimension(size(sndz),2+N_Constit) :: h, s - - integer :: i, j, k, ilow, ihigh - -! real, parameter :: dz1max = 0.08 ! [m] -! real, parameter :: wemin = 13.0 ! [kg/m2] - !real, parameter :: small = 1.e-20 - !real :: areasc,dz - real :: areasc,dz - - real :: totalthick - real, dimension(size(sndz)) :: tol_old, bol_old, tol_new, & - bol_new - real, dimension(size(sndz)) :: thickness - -!**** thick_toplayer: the assigned (final) thickness of the topmost layer (m) -!**** thickdist: the assigned (final) distribution of thickness in layers -!**** 2 through N_snow, in terms of fraction -!**** h: array holding specific heat, water, and constituent contents -!**** s: array holding the total and final heat, water, and constit. contents -!**** ilow: first layer used in a particular relayering calculation -!**** ihigh: final layer used in a particular relayering calculation -!**** totalthick: total thickness of layers 2 through N_snow -!**** thickness: array holding final thicknesses (m) of the snow layers -!**** tol_old(i): depth (from surface) of the top of layer i, before & -!**** relayering -!**** bol_old(i): depth (from surface) of the bottom of layer i, before & -!**** relayering -!**** tol_old(i): depth (from surface) of the top of layer i, after & -!**** relayering -!**** bol_old(i): depth (from surface) of the bottom of layer i, after & -!**** relayering - - - !thickness(1)=thick_toplayer - - !totalthick=sum(sndz)-thick_toplayer - - !if(sum(sndz) .lt. thick_toplayer) & - ! write(*,*) 'Snow layer thickness inconsistency' - totalthick=sum(sndz) - thickness(1)=amin1(totalthick*0.9, thick_toplayer) - totalthick=totalthick-thickness(1) - do i=1,N_snow-1 - thickness(i+1)=thickdist(i)*totalthick - enddo - -!**** Initialize some variables. - - h = 0. - s = 0. - dz = 0. - - !areasc = min(sum(wesn)/wemin,1.) - -!**** Compute specific heat & water contents of old layers. - - do i=1,N_snow - if (sndz(i) > 0.) then - h(i,1) = htsnn(i)/sndz(i) - h(i,2) = wesn(i)/sndz(i) - do k=1,N_Constit - h(i,2+k)=rconstit(i,k)/sndz(i) - enddo - endif - enddo - -!**** Determine old and new boundary depths (cumulative from top) -!**** (tol refers to "top of layer", bol refers to "bottom of layer" - - tol_old(1)=0. - bol_old(1)=sndz(1) - tol_new(1)=0. - bol_new(1)=thickness(1) - - do i=2,N_snow - tol_old(i)=bol_old(i-1) - bol_old(i)=bol_old(i-1)+sndz(i) - tol_new(i)=bol_new(i-1) - bol_new(i)=bol_new(i-1)+thickness(i) - enddo - -!**** Redistribute quantities - -!**** Step 1: Do top layer - ihigh=1 - do k=1,N_snow - if(bol_old(k) .lt. bol_new(1)) ihigh=k+1 - enddo - - do k=1,ihigh - if(k .lt. ihigh) dz=sndz(k) - if(k .eq. ihigh) dz=bol_new(1)-tol_old(k) - !s(1,:)=s(1,:)+h(1,:)*dz - s(1,:)=s(1,:)+h(k,:)*dz - enddo + + enddo + + end if ! (adjust_htsnn) + + return + + end subroutine StieglitzSnow_relayer + + ! ********************************************************************** + + subroutine StieglitzSnow_calc_tpsnow_scalar( h, w, t, f, ice1, tzero, & + use_threshold_fac ) + + ! diagnose snow temperature and frozen fraction from snow mass and snow heat content + ! + ! scalar version of StieglitzSnow_calc_tpsnow() with two differences: + ! 1) contains hardcoded multiplier 1.+eps in "if (hbw < -ALHM)" condition + ! and 1.-eps in "if (hbw > -ALHM)" condition + ! 2) additional logical outputs ice1 and tzero: + ! ice1 = .true. --> frozen fraction (fice) equal to 1. + ! tzero = .true. --> snow temperature at 0 deg C + + ! reichle, 6 Oct 2023: + ! modified to have single subroutine that can maintain the above-mentioned differences + ! (and thus 0-diff test results) and can provide a single interface with the science + ! calculations being in just one place + implicit none + + !RR real, parameter :: cpw = 2065.22 ! @ 0 C [J/kg/K] -- ALREADY DEFINED ABOVE + ! real, parameter :: lhv = 2.4548E6 ! 2.5008e6 ! @ 0 C [J/kg] + ! real, parameter :: lhs = 2.8368E6 ! 2.8434e6 ! @ 0 C [J/kg] + !rr real, parameter :: lhv = 2.5008e6 ! @ 0 C [J/kg] + !rr real, parameter :: lhs = 2.8434e6 ! @ 0 C [J/kg] + ! real, parameter :: lhf = (lhs-lhv) ! @ 0 C [J/kg] + + real, intent(in ) :: w, h ! snow mass (SWE), snow heat content + real, intent(out) :: t, f ! snow temperature, frozen ("ice") fraction + + logical, intent(out) :: ice1, tzero ! frozen fraction==1?, snow temp at 0 deg C? + + logical, intent(in) :: use_threshold_fac + + ! ------------------------------------------------------------ + + real, parameter :: tfac=1./StieglitzSnow_CPW + real, parameter :: ffac=1./alhm + + real :: hbw + + real :: threshold1, threshold2 + + ! ------------------------------------------------------------------------------ + + if (use_threshold_fac) then + + ! replicates original get_tf0d() + + threshold1 = -1.00001*alhm + threshold2 = -0.99999*alhm -!**** Step 2: Do remaining layers - do i=2,N_snow + else - ilow=ihigh - do k=ilow,N_snow - if(bol_old(k) .lt. bol_new(i)) ihigh=k+1 - enddo + ! replicates original get_tf_nd() / StieglitzSnow_calc_tpsnow[_vector]() + + threshold1 = -alhm + threshold2 = -alhm + + end if + + ! ------------------------------------------------------------------- - if(ihigh .eq. N_snow+1) ihigh=N_snow ! Account for potential truncation problem - - do k=ilow,ihigh - if(k .eq. ilow .and. k .lt. ihigh) dz=bol_old(k)-tol_new(i) - if(k .eq. ilow .and. k .eq. ihigh) dz=bol_new(i)-tol_new(i) - if(k .gt. ilow .and. k .lt. ihigh) dz=bol_old(k)-tol_old(k) - if(k .gt. ilow .and. k .eq. ihigh) dz=bol_new(i)-tol_old(k) - s(i,:)=s(i,:)+h(k,:)*dz - enddo - - enddo - - - htsnn = s(:,1) - wesn = s(:,2) - do k=1,N_Constit - rconstit(:,k)=s(:,2+k) - enddo - sndz=thickness - -! if(sum(wesn) < wemin) sndz = sndz /(areasc + small) - return - - end subroutine relayer2 + hbw=0. + + if (w > 0.) hbw = h/w + + if (hbw < threshold1) then ! fully frozen, temp below 0 deg + t = (hbw+alhm)*tfac + f = 1. + ice1 = .true. + tzero = .false. -! ********************************************************************** + elseif (hbw > threshold2) then ! partially frozen, temp at 0 deg - subroutine get_tf0d(h,w,t,f,ice1,tzero) + t = 0. + f = -hbw*ffac + ice1 = .false. + tzero = .true. - implicit none - -!RR real, parameter :: cpw = 2065.22 ! @ 0 C [J/kg/K] -- ALREADY DEFINED ABOVE -! real, parameter :: lhv = 2.4548E6 ! 2.5008e6 ! @ 0 C [J/kg] -! real, parameter :: lhs = 2.8368E6 ! 2.8434e6 ! @ 0 C [J/kg] -!rr real, parameter :: lhv = 2.5008e6 ! @ 0 C [J/kg] -!rr real, parameter :: lhs = 2.8434e6 ! @ 0 C [J/kg] -! real, parameter :: lhf = (lhs-lhv) ! @ 0 C [J/kg] - real, parameter :: tfac=1./cpw - real, parameter :: ffac=1./alhm - - real, intent(in ) :: w, h - real, intent(out) :: t, f + else ! fully frozen, temp at 0 deg + t = 0. + f = 1. + ice1 = .true. + tzero = .true. - logical, intent(out) :: ice1,tzero - - real :: hbw - - hbw=0. - if(w > 0.) hbw = h/w - - if(hbw < -1.00001*alhm) then - t = (hbw+alhm)*tfac - f = 1. - ice1=.true. - tzero=.false. - elseif(hbw > -0.99999*alhm) then - t = 0. - f =-hbw*ffac - ice1=.false. - tzero=.true. - else - t = 0. - f = 1. - ice1=.true. - tzero=.true. - endif - - if(f < 0.) then - t = hbw*tfac - f = 0. - endif - - if(w == 0.) then - t = 0. - f = 0. - endif + endif + + if (f < 0.) then ! (i.e., h>0 and f=-hbw/alhm via "partially frozen, temp at 0 deg") - return + t = hbw*tfac ! t>0. ?????? + f = 0. - end subroutine get_tf0d - -! ********************************************************************** - - subroutine StieglitzSnow_calc_tpsnow(N,h,w,t,f) + endif + + if (w == 0.) then ! no snow -! renamed for clarity: get_tf_nd() --> StieglitzSnow_calc_tpsnow() -! reichle, 12 Aug 2014 - -! n-dimensional version of get_tf -! -! avoid slow "where" statements -! -! can be called for any number of layers or catchments, for example + t = 0. + f = 0. -! 1.) call StieglitzSnow_calc_tpsnow( ncatm, htsnn1(1:ncatm), wesn1(1:ncatm), -! tpsn(1:ncatm),f(1:ncatm) ) -! -! 2.) call StieglitzSnow_calc_tpsnow(N_snow, h, w, t, f) + endif + + return + + end subroutine StieglitzSnow_calc_tpsnow_scalar + + ! ********************************************************************** + + subroutine StieglitzSnow_calc_tpsnow_vector( N, h, w, t, f ) + + ! renamed for clarity: get_tf_nd() --> StieglitzSnow_calc_tpsnow() + ! reichle, 12 Aug 2014 + + ! n-dimensional version of get_tf + ! + ! avoid slow "where" statements + ! + ! can be called for any number of layers or catchments, for example + + ! 1.) call StieglitzSnow_calc_tpsnow( ncatm, htsnn1(1:ncatm), wesn1(1:ncatm), + ! tpsn(1:ncatm),f(1:ncatm) ) + ! + ! 2.) call StieglitzSnow_calc_tpsnow(N_snow, h, w, t, f) + + ! reichle, 22 Aug 2002 + ! reichle, 29 Apr 2003 (updated parameter values) + + ! modified to call StieglitzSnow_calc_tpsnow_scalar() while maintaining 0-diff + ! [avoiding same science equations in two different places] -! reichle, 22 Aug 2002 -! reichle, 29 Apr 2003 (updated parameter values) + integer, intent(in) :: N + + real, dimension(N), intent(in) :: h, w + real, dimension(N), intent(out) :: t, f + + ! ----------------------------------- + + integer :: ii + + logical :: ice1, tzero + + logical, parameter :: use_threshold_fac = .false. - integer, intent(in) :: N - - real, dimension(n), intent(in) :: h, w - real, dimension(n), intent(out) :: t, f - -! local variables - -!RR real, parameter :: cpw = 2065.22 ! @ 0 C [J/kg/K] -- ALREADY DEFINED ABOVE -! real, parameter :: lhv = 2.4548E6 ! 2.5008e6 ! @ 0 C [J/kg] -! real, parameter :: lhs = 2.8368E6 ! 2.8434e6 ! @ 0 C [J/kg] -!rr real, parameter :: lhv = 2.5008e6 ! @ 0 C [J/kg] -!rr real, parameter :: lhs = 2.8434e6 ! @ 0 C [J/kg] -! real, parameter :: lhf = (lhs-lhv) ! @ 0 C [J/kg] - real, parameter :: tfac=1./cpw - real, parameter :: ffac=1./alhm - - integer :: i - - real :: hbw - - do i=1,N - - if(w(i) .gt. 0.0) then - hbw = h(i)/w(i) - else - hbw = 0. - endif - - if(hbw .lt. -alhm) then - t(i) = (hbw+alhm)*tfac - f(i) = 1. - elseif(hbw .gt. -alhm) then - t(i) = 0. - f(i) = -hbw*ffac - else - t(i) = 0. - f(i) = 1. - endif - - if(f(i) .lt. 0.) then - t(i) = hbw*tfac - f(i) = 0. - endif - - if(w(i) .eq. 0.) then - t(i) = 0. - f(i) = 0. - endif - - end do - - return - - end subroutine StieglitzSnow_calc_tpsnow + ! ---------------------------------- + + do ii=1,N + + call StieglitzSnow_calc_tpsnow_scalar( h(ii), w(ii), t(ii), f(ii), ice1, tzero, & + use_threshold_fac ) + + end do + end subroutine StieglitzSnow_calc_tpsnow_vector + ! ******************************************************************** - - subroutine StieglitzSnow_calc_asnow( N_snow, NTILES, wesnn, asnow ) + + subroutine StieglitzSnow_calc_asnow_1( N_snow, NTILES, wesnn, asnow ) ! Calculate diagnostic snow area from prognostic SWE ! + ! *_1(): input SWE for multiple snow layers at multiple tiles + ! ! reichle, Nov 3, 2004 ! reichle, 2 Apr 2012 - revised for use without catch_types structures ! reichle, 12 Aug 2014 - moved to here from catchment.F90 @@ -1361,21 +1478,58 @@ subroutine StieglitzSnow_calc_asnow( N_snow, NTILES, wesnn, asnow ) implicit none - integer, intent(in) :: N_snow, NTILES + integer, intent(in) :: N_snow, NTILES + real, dimension(N_snow,NTILES), intent(in) :: wesnn + real, dimension( NTILES), intent(out) :: asnow - real, dimension(N_snow,NTILES), intent(in) :: wesnn + ! ----------------------------------------------------------- + + asnow = max( min( sum(wesnn,1)/wemin, 1. ), 0. ) + + end subroutine StieglitzSnow_calc_asnow_1 + + ! ************************* + + subroutine StieglitzSnow_calc_asnow_2( N_snow, wesnn, asnow ) + + ! Calculate diagnostic snow area from prognostic SWE + ! + ! *_2(): input SWE for multiple snow layers at single tile + + implicit none + + integer, intent(in) :: N_snow + real, dimension(N_snow), intent(in) :: wesnn + real, intent(out) :: asnow - real, dimension( NTILES), intent(out) :: asnow - ! ----------------------------------------------------------- - asnow = min( sum(wesnn,1)/wemin, 1. ) + asnow = max( min( sum(wesnn)/wemin, 1. ), 0. ) - end subroutine StieglitzSnow_calc_asnow - -! ********************************************************************** + end subroutine StieglitzSnow_calc_asnow_2 + + ! ************************* + + subroutine StieglitzSnow_calc_asnow_3( totswe, asnow ) + + ! Calculate diagnostic snow area from prognostic SWE + ! + ! *_3(): input total SWE at single tile + + implicit none + + real, intent(in) :: totswe + real, intent(out) :: asnow + + ! ----------------------------------------------------------- + + asnow = max( min( totswe/wemin, 1. ), 0. ) + + end subroutine StieglitzSnow_calc_asnow_3 - SUBROUTINE TRID(X,DD,D,RD,B,N) + ! ******************************************************************** + + SUBROUTINE StieglitzSnow_trid(X,DD,D,RD,B,N) IMPLICIT NONE INTEGER,INTENT(IN) :: N @@ -1395,579 +1549,576 @@ SUBROUTINE TRID(X,DD,D,RD,B,N) DO 20 J=2,N 20 if(D(J).ne.0.) X(J)=(B(J)-DD(J)*X(J-1))/D(J) RETURN - END SUBROUTINE TRID - -!======================================================================= -! Version 5.0.2 by Teppei J. Yasuanari on 02/14/2011 - - SUBROUTINE SNOW_ALBEDO (NCH, N_snow, N_constit_type, ITYP, VLAI, ZTH, & - RHOFRESH, & - SNWALB_VISMAX, SNWALB_NIRMAX, SLOPE, & - WESN, HTSNN, SNDZ, & - AVISDR, ANIRDR, AVISDF, ANIRDF, & - ASNVDR, ASNNDR, ASNVDF, ASNNDF, & - RCONSTIT, UM, RTS, PARDIR, PARDIF & - ) - - IMPLICIT NONE - INTEGER, INTENT(IN) :: NCH, N_snow, N_constit_type - - -! -------------------------------------- -! INPUTS: - -! NCH: number of tiles considered -! N_snow: number of snow layers -! N_constit: number of constituents -! ITYP: vegetation type -! VLAI: the leaf area index. -! ZTH: The cosine of the solar zenith angle. -! RHOFRESH: density of fresh snow -! SNWALB_VISMAX: max of visible snow albedo -! SNWALB_NIRMAX: max of NIR snow albedo -! SLOPE: slope the albedo decreases higher density -! SLOPE > 0: it gets recomputed -! SLOPE < 0: it is directly used in the computation; -! for example,to recover the old formulation, -! set SLOPE=-0.0006, SNWALB_VISMAX=0.7, SNWALB_NIRMAX=0.5 -! WESN: snow water equivalent in each layer -! HTSNN: heat content of each layer -! SNDZ: depth of each layer -! UM: wind speed -! RTS: surface temperature -! PARDIR: photosynthetically active radiation, direct -! PARDIF: photosynthetically active radiation, diffuse -! RCONSTIT: array of constituent masses -! ABVIS: const array (not used when there is no constituents) -! ABNIR: const array (not used when there is no constituents) -! AVISDR: visible, direct albedo (snow-free). -! ANIRDR: near infra-red, direct albedo (snow-free). -! AVISDF: visible, diffuse albedo (snow-free). -! ANIRDF: near infra-red, diffuse albedo (snow-free). - - INTEGER, INTENT(IN), DIMENSION(NCH) :: ITYP - REAL, INTENT(IN) :: RHOFRESH - REAL, INTENT(IN) :: SNWALB_VISMAX, SNWALB_NIRMAX, SLOPE - REAL, INTENT(IN), DIMENSION(NCH) :: AVISDR, ANIRDR, AVISDF, & - ANIRDF, VLAI, ZTH - REAL, INTENT(IN), DIMENSION(N_Snow,NCH) :: WESN, HTSNN, SNDZ - REAL, INTENT(IN), DIMENSION(NCH), OPTIONAL :: UM, RTS, PARDIR, PARDIF - - REAL, INTENT(IN),DIMENSION(NCH, N_snow,N_Constit), OPTIONAL :: RCONSTIT - -! -------------------------------------- -! OUTPUTS: - -! ASNVDR: snow albedo, visible direct -! ASNNDR: snow albedo, near-infrared direct -! ASNVDF: snow albedo, visible diffuse -! ASNNDF: snow albedo, near-infrared diffuse - - REAL, INTENT(OUT), DIMENSION(NCH) :: ASNVDR, ASNNDR, ASNVDF, ASNNDF - -! -------------------------------------- -! Other variables as needed. Includes: -! SSA: snow specific surface area -! RHO_FS: fresh snow density -! EFFG: effective ice thickness (m) - - INTEGER :: I,M,J,K,K2 - INTEGER, PARAMETER :: NTYPS_SIB=9 - - REAL :: rho_fs,DEGSZA,SD,SZASIN,COS50,SSALBV,SSALBN,AV,AN, & - WSS, TS, FAC, FVEG, TOTDEP, SWE, DENS_EXC, AREASC, & - DENSITY, ASNVDR_VEG, ASNNDR_VEG, ASNVDF_VEG, & - ASNNDF_VEG, SUM1, SUM2, GK_B - - REAL, DIMENSION(NTYPS_SIB) :: SNWMID - DATA SNWMID /50.,30.,45.,20.,30.,20.,2.,2.,2./ - - - - -! ********************************************************************* + END SUBROUTINE StieglitzSnow_trid - + !======================================================================= + ! Version 5.0.2 by Teppei J. Yasuanari on 02/14/2011 + + SUBROUTINE StieglitzSnow_snow_albedo( & + NCH, N_snow, N_constit_type, ITYP, VLAI, ZTH, & + RHOFRESH, & + SNWALB_VISMAX, SNWALB_NIRMAX, SLOPE, & + WESN, HTSNN, SNDZ, & + AVISDR, ANIRDR, AVISDF, ANIRDF, & + ASNVDR, ASNNDR, ASNVDF, ASNNDF, & + RCONSTIT, UM, RTS, PARDIR, PARDIF & + ) + + IMPLICIT NONE + + INTEGER, INTENT(IN) :: NCH, N_snow, N_constit_type + + ! -------------------------------------- + ! INPUTS: + + ! NCH: number of tiles considered + ! N_snow: number of snow layers + ! N_constit: number of constituents + ! ITYP: vegetation type + ! VLAI: the leaf area index. + ! ZTH: The cosine of the solar zenith angle. + ! RHOFRESH: density of fresh snow + ! SNWALB_VISMAX: max of visible snow albedo + ! SNWALB_NIRMAX: max of NIR snow albedo + ! SLOPE: slope the albedo decreases higher density + ! SLOPE > 0: it gets recomputed + ! SLOPE < 0: it is directly used in the computation; + ! for example,to recover the old formulation, + ! set SLOPE=-0.0006, SNWALB_VISMAX=0.7, SNWALB_NIRMAX=0.5 + ! WESN: snow water equivalent in each layer + ! HTSNN: heat content of each layer + ! SNDZ: depth of each layer + ! UM: wind speed + ! RTS: surface temperature + ! PARDIR: photosynthetically active radiation, direct + ! PARDIF: photosynthetically active radiation, diffuse + ! RCONSTIT: array of constituent masses + ! ABVIS: const array (not used when there is no constituents) + ! ABNIR: const array (not used when there is no constituents) + ! AVISDR: visible, direct albedo (snow-free). + ! ANIRDR: near infra-red, direct albedo (snow-free). + ! AVISDF: visible, diffuse albedo (snow-free). + ! ANIRDF: near infra-red, diffuse albedo (snow-free). + + INTEGER, INTENT(IN), DIMENSION(NCH) :: ITYP + REAL, INTENT(IN) :: RHOFRESH + REAL, INTENT(IN) :: SNWALB_VISMAX, SNWALB_NIRMAX, SLOPE + REAL, INTENT(IN), DIMENSION(NCH) :: AVISDR, ANIRDR, AVISDF + REAL, INTENT(IN), DIMENSION(NCH) :: ANIRDF, VLAI, ZTH + REAL, INTENT(IN), DIMENSION(N_Snow,NCH) :: WESN, HTSNN, SNDZ + + REAL, INTENT(IN), DIMENSION(NCH), OPTIONAL :: UM, RTS, PARDIR, PARDIF + + REAL, INTENT(IN), DIMENSION(NCH,N_snow,N_Constit), OPTIONAL :: RCONSTIT + + ! -------------------------------------- + ! OUTPUTS: + + ! ASNVDR: snow albedo, visible direct + ! ASNNDR: snow albedo, near-infrared direct + ! ASNVDF: snow albedo, visible diffuse + ! ASNNDF: snow albedo, near-infrared diffuse + + REAL, INTENT(OUT), DIMENSION(NCH) :: ASNVDR, ASNNDR, ASNVDF, ASNNDF + + ! -------------------------------------- + ! Other variables as needed. Includes: + ! SSA: snow specific surface area + ! EFFG: effective ice thickness (m) + + INTEGER :: I + INTEGER, PARAMETER :: NTYPS_SIB=9 + + REAL :: & + FAC, FVEG, TOTDEP, SWE, DENS_EXC, AREASC, & + DENSITY, ASNVDR_VEG, ASNNDR_VEG, ASNVDF_VEG, & + ASNNDF_VEG, GK_B + + REAL, DIMENSION(NTYPS_SIB) :: SNWMID + + DATA SNWMID /50.,30.,45.,20.,30.,20.,2.,2.,2./ + + ! ********************************************************************* !FPP$ EXPAND (COEFFSIB) - - if(SLOPE < 0.0) then - GK_B = SLOPE - else - GK_B = (0.85808-0.6)/(RHOFRESH-RHOMA) - endif - - DO I=1,NCH - - SWE=SUM(WESN(:,I)) - - TOTDEP=SNDZ(1,I) - AREASC = MIN(SWE/WEMIN,1.) - !DENSITY=(SWE/(AREASC+1.e-20)) / (TOTDEP+1.e-20) - !*** only use top layer density to dentermine albedo - DENSITY=(WESN(1,I)/(AREASC+1.e-20)) / (TOTDEP+1.e-20) - DENS_EXC=MAX(0., DENSITY-RHOFRESH) - - - !********************************************************************* - - ! Using snow tracer albedo scheme only when N_constit_type > 0 - - if(N_constit_type > 0) then - call ALB_WITH_IMPURITY (N_snow, ZTH(I), SNWALB_VISMAX, SNWALB_NIRMAX, & - WESN(:,I),HTSNN(:,I),SNDZ(:,I), UM(I), RTS(I), PARDIR(I), PARDIF(I), & - ASNVDR(I), ASNNDR(I), ASNVDF(I), ASNNDF(I),RCONSTIT(I,:,:)) - else - - ! Use these when you use the original snow albedo model (comment out for alb) - !ASNVDR(I) = MAX(SNWALB_VISMIN, SNWALB_VISMAX - DENS_EXC*.0006) - !ASNNDR(I) = MAX(SNWALB_NIRMIN, SNWALB_NIRMAX - DENS_EXC*.0006) - !ASNVDF(I) = MAX(SNWALB_VISMIN, SNWALB_VISMAX - DENS_EXC*.0006) - !ASNNDF(I) = MAX(SNWALB_NIRMIN, SNWALB_NIRMAX - DENS_EXC*.0006) - ASNVDR(I) = MAX(SNWALB_VISMIN, SNWALB_VISMAX + GK_B*DENS_EXC) - ASNNDR(I) = MAX(SNWALB_NIRMIN, SNWALB_NIRMAX + GK_B*DENS_EXC) - ASNVDF(I) = MAX(SNWALB_VISMIN, SNWALB_VISMAX + GK_B*DENS_EXC) - ASNNDF(I) = MAX(SNWALB_NIRMIN, SNWALB_NIRMAX + GK_B*DENS_EXC) - - endif - - - - ! ACCOUNT FOR VEGETATION MASKING, FOR EACH COMPONENT - - ! A) FIRST DO MASKING IN VEGETATED FRACTION: - FAC = SWE / (SWE + SNWMID(ITYP(I))) - ASNVDR_VEG=AVISDR(I) + (ASNVDR(I)-AVISDR(I))*FAC - ASNNDR_VEG=ANIRDR(I) + (ASNNDR(I)-ANIRDR(I))*FAC - ASNVDF_VEG=AVISDF(I) + (ASNVDF(I)-AVISDF(I))*FAC - ASNNDF_VEG=ANIRDF(I) + (ASNNDF(I)-ANIRDF(I))*FAC - - ! B) NOW ACCOUNT FOR SUBGRID VEGETATION FRACTION - FVEG=AMIN1( 1., VLAI(I)/2. ) - ASNVDR(I)=ASNVDR(I)*(1.-FVEG)+ASNVDR_VEG*FVEG - ASNNDR(I)=ASNNDR(I)*(1.-FVEG)+ASNNDR_VEG*FVEG - ASNVDF(I)=ASNVDF(I)*(1.-FVEG)+ASNVDF_VEG*FVEG - ASNNDF(I)=ASNNDF(I)*(1.-FVEG)+ASNNDF_VEG*FVEG - - ENDDO - - RETURN - END SUBROUTINE SNOW_ALBEDO - - SUBROUTINE ALB_WITH_IMPURITY (N_snow, ZTH, & - SNWALB_VISMAX, SNWALB_NIRMAX, & - WESN, HTSNN, SNDZ, UM, RTS, PARDIR, PARDIF, & - ASNVDR, ASNNDR, ASNVDF, ASNNDF, & - RCONSTIT & - ) - - IMPLICIT NONE - - INTEGER, INTENT(IN) :: N_snow - - -! -------------------------------------- -! INPUTS: - -! ZTH: The cosine of the solar zenith angle. -! WESN: snow water equivalent in each layer -! HTSNN: heat content of each layer -! SNDZ: depth of each layer -! UM: wind speed -! RTS: surface temperature -! PARDIR: photosynthetically active radiation, direct -! PARDIF: photosynthetically active radiation, diffuse -! RCONSTIT: array of constituent masses -! AVISDR: visible, direct albedo (snow-free). -! ANIRDR: near infra-red, direct albedo (snow-free). -! AVISDF: visible, diffuse albedo (snow-free). -! ANIRDF: near infra-red, diffuse albedo (snow-free). - REAL, INTENT(IN) :: SNWALB_VISMAX, SNWALB_NIRMAX - REAL, INTENT(IN) :: ZTH, UM, RTS, PARDIR, PARDIF - REAL, INTENT(IN), DIMENSION(N_snow,N_Constit), OPTIONAL :: RCONSTIT - REAL, INTENT(IN), DIMENSION(N_Snow) :: WESN, HTSNN, SNDZ - -! -------------------------------------- -! OUTPUTS: - -! ASNVDR: snow albedo, visible direct -! ASNNDR: snow albedo, near-infrared direct -! ASNVDF: snow albedo, visible diffuse -! ASNNDF: snow albedo, near-infrared diffuse - - REAL, INTENT(OUT) :: ASNVDR, ASNNDR, ASNVDF, ASNNDF - -! -------------------------------------- -! Other variables as needed. Includes: -! SSA: snow specific surface area -! RHO_FS: fresh snow density -! EFFG: effective ice thickness (m) - - INTEGER :: I,M,J,K,K2 - INTEGER, PARAMETER :: NTYPS_SIB=9 - - REAL :: rho_fs,DEGSZA,SD,SZASIN,COS50,SSALBV,SSALBN,AV,AN, & - WSS, TS, FAC, FVEG, TOTDEP, SWE, DENS_EXC, AREASC, & - DENSITY, ASNVDR_VEG, ASNNDR_VEG, ASNVDF_VEG, & - ASNNDF_VEG, SUM1, SUM2 - REAL :: SZTH - REAL, DIMENSION(N_snow) :: ABSCOV, ABSCON, EFFG, SSA, DENEL - - REAL, DIMENSION(N_snow,N_Constit) :: CONCENT - - REAL, DIMENSION(N_snow) :: CWESN, CHTSNN, CSNDZ - REAL, DIMENSION(N_snow) :: TPSN, FICES - REAL, DIMENSION(N_snow) :: CTPSN, CFICES - - -! ********************************************************************* + + if(SLOPE < 0.0) then + GK_B = SLOPE + else + GK_B = (0.85808-0.6)/(RHOFRESH-StieglitzSnow_RHOMA) + endif + + DO I=1,NCH + + SWE=SUM(WESN(:,I)) + + TOTDEP=SNDZ(1,I) + call StieglitzSnow_calc_asnow( SWE, AREASC ) + !DENSITY=(SWE/(AREASC+1.e-20)) / (TOTDEP+1.e-20) + !*** only use top layer density to dentermine albedo + DENSITY=(WESN(1,I)/(AREASC+1.e-20)) / (TOTDEP+1.e-20) + DENS_EXC=MAX(0., DENSITY-RHOFRESH) + + !********************************************************************* + + ! Using snow tracer albedo scheme only when N_constit_type > 0 + + if(N_constit_type > 0) then + call ALB_WITH_IMPURITY (N_snow, ZTH(I), SNWALB_VISMAX, SNWALB_NIRMAX, & + WESN(:,I),HTSNN(:,I),SNDZ(:,I), UM(I), RTS(I), PARDIR(I), PARDIF(I), & + ASNVDR(I), ASNNDR(I), ASNVDF(I), ASNNDF(I),RCONSTIT(I,:,:)) + else + + ! Use these when you use the original snow albedo model (comment out for alb) + !ASNVDR(I) = MAX(SNWALB_VISMIN, SNWALB_VISMAX - DENS_EXC*.0006) + !ASNNDR(I) = MAX(SNWALB_NIRMIN, SNWALB_NIRMAX - DENS_EXC*.0006) + !ASNVDF(I) = MAX(SNWALB_VISMIN, SNWALB_VISMAX - DENS_EXC*.0006) + !ASNNDF(I) = MAX(SNWALB_NIRMIN, SNWALB_NIRMAX - DENS_EXC*.0006) + ASNVDR(I) = MAX(SNWALB_VISMIN, SNWALB_VISMAX + GK_B*DENS_EXC) + ASNNDR(I) = MAX(SNWALB_NIRMIN, SNWALB_NIRMAX + GK_B*DENS_EXC) + ASNVDF(I) = MAX(SNWALB_VISMIN, SNWALB_VISMAX + GK_B*DENS_EXC) + ASNNDF(I) = MAX(SNWALB_NIRMIN, SNWALB_NIRMAX + GK_B*DENS_EXC) + + endif + + ! ACCOUNT FOR VEGETATION MASKING, FOR EACH COMPONENT + + ! A) FIRST DO MASKING IN VEGETATED FRACTION: + FAC = SWE / (SWE + SNWMID(ITYP(I))) + ASNVDR_VEG=AVISDR(I) + (ASNVDR(I)-AVISDR(I))*FAC + ASNNDR_VEG=ANIRDR(I) + (ASNNDR(I)-ANIRDR(I))*FAC + ASNVDF_VEG=AVISDF(I) + (ASNVDF(I)-AVISDF(I))*FAC + ASNNDF_VEG=ANIRDF(I) + (ASNNDF(I)-ANIRDF(I))*FAC + + ! B) NOW ACCOUNT FOR SUBGRID VEGETATION FRACTION + FVEG=AMIN1( 1., VLAI(I)/2. ) + ASNVDR(I)=ASNVDR(I)*(1.-FVEG)+ASNVDR_VEG*FVEG + ASNNDR(I)=ASNNDR(I)*(1.-FVEG)+ASNNDR_VEG*FVEG + ASNVDF(I)=ASNVDF(I)*(1.-FVEG)+ASNVDF_VEG*FVEG + ASNNDF(I)=ASNNDF(I)*(1.-FVEG)+ASNNDF_VEG*FVEG + + ENDDO + + RETURN + + END SUBROUTINE StieglitzSnow_Snow_Albedo + + ! **************************************************************************** + + SUBROUTINE ALB_WITH_IMPURITY (N_snow, ZTH, & + SNWALB_VISMAX, SNWALB_NIRMAX, & + WESN, HTSNN, SNDZ, UM, RTS, PARDIR, PARDIF, & + ASNVDR, ASNNDR, ASNVDF, ASNNDF, & + RCONSTIT & + ) + + IMPLICIT NONE + + INTEGER, INTENT(IN) :: N_snow + + + ! -------------------------------------- + ! INPUTS: + + ! ZTH: The cosine of the solar zenith angle. + ! WESN: snow water equivalent in each layer + ! HTSNN: heat content of each layer + ! SNDZ: depth of each layer + ! UM: wind speed + ! RTS: surface temperature + ! PARDIR: photosynthetically active radiation, direct + ! PARDIF: photosynthetically active radiation, diffuse + ! RCONSTIT: array of constituent masses + ! AVISDR: visible, direct albedo (snow-free). + ! ANIRDR: near infra-red, direct albedo (snow-free). + ! AVISDF: visible, diffuse albedo (snow-free). + ! ANIRDF: near infra-red, diffuse albedo (snow-free). + + REAL, INTENT(IN) :: SNWALB_VISMAX, SNWALB_NIRMAX + REAL, INTENT(IN) :: ZTH, UM, RTS, PARDIR, PARDIF + REAL, INTENT(IN), DIMENSION(N_snow,N_Constit), OPTIONAL :: RCONSTIT + REAL, INTENT(IN), DIMENSION(N_Snow) :: WESN, HTSNN, SNDZ + + ! -------------------------------------- + ! OUTPUTS: + + ! ASNVDR: snow albedo, visible direct + ! ASNNDR: snow albedo, near-infrared direct + ! ASNVDF: snow albedo, visible diffuse + ! ASNNDF: snow albedo, near-infrared diffuse + + REAL, INTENT(OUT) :: ASNVDR, ASNNDR, ASNVDF, ASNNDF + + ! -------------------------------------- + ! Other variables as needed. Includes: + ! SSA: snow specific surface area + ! RHO_FS: fresh snow density + ! EFFG: effective ice thickness (m) + + INTEGER :: M,K + INTEGER, PARAMETER :: NTYPS_SIB=9 + + REAL :: rho_fs, DEGSZA, SZASIN, COS50, & + WSS, TS, FAC, TOTDEP, SWE, DENS_EXC, AREASC, & + DENSITY, SUM1, SUM2 + + REAL :: SZTH + + REAL, DIMENSION(N_snow) :: ABSCOV, ABSCON, EFFG, SSA, DENEL + + REAL, DIMENSION(N_snow,N_Constit) :: CONCENT + + REAL, DIMENSION(N_snow) :: CWESN, CHTSNN, CSNDZ + REAL, DIMENSION(N_snow) :: TPSN, FICES + REAL, DIMENSION(N_snow) :: CTPSN, CFICES + + ! ********************************************************************* !FPP$ EXPAND (COEFFSIB) - - SZTH=ZTH - DEGSZA=ACOS(SZTH)*180./PIE - SZASIN=SQRT(1.-(SZTH**2.0)) - COS50=COS(2.*PIE*50./360.) - - ! When it is cloud-covered, SZTA is set to 50 degree. THE VALUE - ! USED HERE (0.1) CAN BE TUNED! - IF(pardir/(pardir+pardif+1.e-20) < 0.1) SZTH=COS50 - - ! CTPSN: LAYER TEMPERATURE [degree C] - DO M=1,N_Snow - CWESN(M)=WESN(M) - CHTSNN(M)=HTSNN(M) - END DO - - CALL StieglitzSnow_calc_tpsnow(N_snow,CHTSNN,CWESN,CTPSN,CFICES) - - DO M=1,N_Snow - TPSN(M)=CTPSN(M) - FICES(M)=CFICES(M) - END DO - - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - ! SNOW ALBEDOES - SWE=SUM(WESN(:)) - TOTDEP=SUM(SNDZ(:)) - AREASC = MIN(SWE/WEMIN,1.) - DENSITY=(SWE/(AREASC+1.e-20)) / (TOTDEP+1.e-20) - - WSS=UM - TS=RTS - - CALL WFSDEN(WSS,TS,RHO_FS) - DENS_EXC=MAX(0., DENSITY-RHO_FS) - - - !********************************************************************* - - IF(SWE > 0.01) THEN - - !========== SNOW CASE ========== - - DO M=1,N_SNOW - - ! Dry snow density in each snow layer [kg m-3] (N_Snow layers) - - DENEL(M)=(FICES(M)*WESN(M)/(AREASC+1.e-20))/(SNDZ(M) + 1.e-20) - DENEL(M)=MIN(RHOMA,DENEL(M)) - - ! Mass concentrations of dust,BC, and OC [kg kg-1] (3 layers) - - IF(PRESENT(RCONSTIT)) THEN - DO K=1,N_Constit - CONCENT(M,K)=RCONSTIT(M,K)/(WESN(M) + 1.e-20) - ENDDO - ELSE - DO K=1,N_Constit - CONCENT(M,K)=0. - ENDDO - ENDIF - - ! Snow specific surface area (SSA) [m2 kg-1] Equation based on Yamazaki et al. [1991,1993] - ! The equation is also based on the observed data by Narita [1971], Teionkagaku - - SSA(M)=10.0**(-15.32*((DENEL(M)/1000.)**3.0) & - +16.65*((DENEL(M)/1000.)**2.0) & - -7.3*(DENEL(M)/1000.)+2.23) - - ! Another Equation for SSA based on the equation (1) in Domine et al., JGR, vol.112, 2007 - ! SSA(M,I)=( -308.2D0*LOG(DENEL(M,I)/1000.D0)-206.D0 )/10.D0 - ! When each snow layer has excess water (snow gets wet) - ! SSA is decreased to 60% values of the original value. - - IF(TPSN(M).GE.-0.001) SSA(M)=0.6*SSA(M) - - ! effective ice thickness comparable to effective snow grain radius - ! if EFFG is multiplied by 3 - - EFFG(M)=2.D0/(DENICE*SSA(M) + 1.e-20) - - ! Calculation of Absorption coefficients [m-1] Equations for mass con. [kg kg-1] - - SUM2=0. - do K=1,N_Constit - SUM2=SUM2+CONCENT(M,K) - ENDDO - - ! VIS range - SUM1=0. - do K=1,N_Constit - SUM1=SUM1+CONCENT(M,K)*1.E03*ABVIS(K) - ENDDO - ABSCOV(M)=DENICE*SUM1+(1.-SUM2)*AICEV - - ! NIR range - SUM1=0. - do K=1,N_Constit - SUM1=SUM1+CONCENT(M,K)*1.E03*ABNIR(K) - ENDDO - ABSCON(M)=DENICE*SUM1+(1.-SUM2)*AICEN - - ENDDO - - ! VIS & NIR CASES BY NEW SNOW ALBEDO MODEL - - ASNVDR=ALB(N_Snow,RIV,ABSCOV(:),EFFG(:),DENEL(:),SNDZ(:),DENICE) - ASNNDR=ALB(N_Snow,RIN,ABSCON(:),EFFG(:),DENEL(:),SNDZ(:),DENICE) - - ! Diffuse components are calculated with the assumed SZTH of 50 degrees - ASNVDF = ASNVDR - ASNNDF = ASNNDR - - !+++++ Taking the effect of solar zenith angle (SZA) into account ++++++ - ! The second terms for VIS and NIR in equations (6) & (7) - ! [Marks and Dozier, Water Resources Research, Vol. 28, 3043-3054] - - ! For VIS [Note: unit for EFFG is um] - ASNVDR = ASNVDR & - -( (SQRT(1.5*(EFFG(1)*1.0E06))*1.375E-03)*(1.-COS50) ) & - +( (SQRT(1.5*(EFFG(1)*1.0E06))*1.375E-03)*(1.-SZTH) ) - - ! For NIR [Note: unit for EFFG is um] - ASNNDR = ASNNDR & - -( (( SQRT(1.5*(EFFG(1)*1.0E06))*2.0E-03)+0.1)*(1.-COS50)) & - +( (( SQRT(1.5*(EFFG(1)*1.0E06))*2.0E-03)+0.1)*(1.-SZTH) ) - - ELSE - - !========== NO SNOW CASE ========== - ! Use these when you use the original snow albedo model - - ASNVDR = MAX(SNWALB_VISMIN, SNWALB_VISMAX - DENS_EXC*.0006) - ASNNDR = MAX(SNWALB_NIRMIN, SNWALB_NIRMAX - DENS_EXC*.0006) - ASNVDF = MAX(SNWALB_VISMIN, SNWALB_VISMAX - DENS_EXC*.0006) - ASNNDF = MAX(SNWALB_NIRMIN, SNWALB_NIRMAX - DENS_EXC*.0006) - - ENDIF + SZTH=ZTH + DEGSZA=ACOS(SZTH)*180./PIE + SZASIN=SQRT(1.-(SZTH**2.0)) + COS50=COS(2.*PIE*50./360.) + + ! When it is cloud-covered, SZTA is set to 50 degree. THE VALUE + ! USED HERE (0.1) CAN BE TUNED! + IF(pardir/(pardir+pardif+1.e-20) < 0.1) SZTH=COS50 + + ! CTPSN: LAYER TEMPERATURE [degree C] + DO M=1,N_Snow + CWESN(M)=WESN(M) + CHTSNN(M)=HTSNN(M) + END DO + + CALL StieglitzSnow_calc_tpsnow(N_snow,CHTSNN,CWESN,CTPSN,CFICES) + + DO M=1,N_Snow + TPSN(M)=CTPSN(M) + FICES(M)=CFICES(M) + END DO + + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! SNOW ALBEDOES + + SWE=SUM(WESN(:)) + TOTDEP=SUM(SNDZ(:)) + call StieglitzSnow_calc_asnow( SWE, AREASC ) + DENSITY=(SWE/(AREASC+1.e-20)) / (TOTDEP+1.e-20) + + WSS=UM + TS=RTS + + CALL WFSDEN(WSS,TS,RHO_FS) + DENS_EXC=MAX(0., DENSITY-RHO_FS) + + !********************************************************************* - RETURN - - END SUBROUTINE ALB_WITH_IMPURITY - -! ********************************************************************** - -!**** ------------------------------------------------------------------ -!**** //////////////// Added by Teppei J. Yasunari ///////////////START1 -!**** ------------------------------------------------------------------ - -!======================================================================= -!= To determine RHOFS = -!======================================================================= -! Version 5.1.0 by Teppei J. Yasuanari on 09/15/2014 - - SUBROUTINE WFSDEN(UM,RTS,RHO_FS) - - - REAL, INTENT(IN) :: UM,RTS -! REAL, INTENT(IN) :: UM,RTS,TSNOW,RPRES,RQST -! REAL, INTENT(IN),DIMENSION(3) :: TPSN - REAL, INTENT(OUT) :: RHO_FS - REAL :: ARHOFS,V1,T2,SR,ESAT,TW,E - INTEGER :: IFG - -!--------------------------------------------------------------! -! YOU CAN CHOOSE ONE OF 10 TYPES OF "RHOFS" ! -!--------------------------------------------------------------! - -! ESAT : Saturated water vapor pressure [hPa] -! E : Water vapor pressure [hPa] -! TW : Wet bulb temperature [degree C] -! -! V1=UM -! T2=RTS-273.15 -! SR=TSNOW*3600. -! -! Saturated water vapor pressure - -!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -! Fresh snow density by Melloh et al. (2002) -! Hydrological Processes, 16, 3571-3584 -! -! RHOFS TYPE 1 -! -! IF(T2.GE.0.) THEN -! TW=T2-((1013.25/(0.667*RPRES))*(ESAT-E)) -! ELSE IF (T2.LT.0.) THEN -! TW=T2-((1013.25/(0.589*RPRES))*(ESAT-E)) -! END IF -! -! TWW=TW -! ARHOFS=(0.05+(0.0017*(((TW+273.15)-258.16)**1.5)))*1000. -! ARHOFS=MAX(ARHOFS,90.) -! -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -! Multiple regression equation for new snow density -! based on Kajikawa et al. (2004), Sepyo, 66, p.561-565. -! -! RHOFS TYPE 2 -! Spatial dendrite (R**2=0.948; 10% confidence limit) -! ARHOFS=13.3+(53.9*SR)+(6.54*V1) -! -! RHOFS TYPE 3 -! Stellar crystal (R**2=0.817; 5% confidence limit) -! ARHOFS=23.4+(37.5*SR)+(7.32*V1)+(0.579*T2) -! -! RHOFS TYPE 4 -! Rimed stellar crystal (R**2=0.442; 5% confidence limit) -! ARHOFS=41.2+(8.26*SR)+(5.16*V1)+(0.422*T2) -! -! RHOFS TYPE 5 -! Rimed spatial dendrites (R**2=0.369; 5% confidence limit) -! ARHOFS=67.5+(23.4*SR)-(1.29*V1)+(3.65*T2) -! -! RHOFS TYPE 6 -! Rimed spatial dendrites 2 (R**2=0.321; 5% confidence limit) -! ARHOFS=43.1*EXP(0.106*V1) -! -!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -! 2001 J. Hydrometeorology (Boone and Etchevers) -! Fresh snow density based on wind speed and air temeperature -! -! RHOFS TYPE 7 -! ARHOFS=109.+(6.*(RTS-273.16))+(26.*(V1**0.5)) -! -!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -! Equation 18 by Yamazaki et al. [1998] -! Seppyo, 60, 131-141. - -! RHOFS TYPE 8 - ARHOFS=67.+(13.*UM) - IFG=2 - IF(RTS-TF >= 0.) ARHOFS=200. - -!+++ USE Constant value of fresh snow density [kg m-3]+++ -! RHOFS TYPE 9 -! ARHOFS=110. ! Used in Yasunari et al. (2010) - -! RHOFS TYPE 10 -! ARHOFS=150. ! Used in original snowpack model - - -! RHOFS does not exceed the maximum of 200. [kg m-3]. - RHO_FS=MIN(ARHOFS,200.) - -! write(*,*) 'FRESH SNOW DENSITY',RHOFS - -! (comment out for den) - rho_fs=150. - - RETURN - END SUBROUTINE WFSDEN - - - -!======================================================================= -!= New snow albedo functions = -!======================================================================= -! Version 5.1.0 by Teppei J. Yasuanari on 09/15/2014 - - FUNCTION ALB(L,RI0,ABSCO0,EFFG0,DENEL0,SNDZ0,DENICE) - - IMPLICIT NONE - - INTEGER :: J,K,L2 - INTEGER, INTENT(IN) :: L - REAL :: ALB - DOUBLE PRECISION :: ALBD,DZ,CDZ - REAL, INTENT(IN) :: RI0,DENICE - REAL, INTENT(IN), DIMENSION(L) :: EFFG0,ABSCO0,SNDZ0,DENEL0 - DOUBLE PRECISION :: RI,DDENICE - DOUBLE PRECISION, DIMENSION(L) :: EFFG,ABSCO,SNDZ,DENEL - DOUBLE PRECISION, DIMENSION(L) :: REF,TRANS,A,B,AMU,TJALPHA,TJBETA,DI - - ! From single to double precision - - RI=DBLE(RI0) - DDENICE=DBLE(DENICE) - EFFG(:)=DBLE(EFFG0(:)) - ABSCO(:)=DBLE(ABSCO0(:)) - SNDZ(:)=DBLE(SNDZ0(:)) - DENEL(:)=DBLE(DENEL0(:)) - - ! Only the top 3m of snow contributes to albedo - - CDZ=0.d0 - - DO J=1,L - CDZ=CDZ+SNDZ(J) - IF(CDZ > 3.d0) EXIT - L2=J - END DO - - DO J=1,L2 - - ! Reflectance in one ice layer - - REF(J)= RI + & - ( ((1.d0-RI)**2.d0)*RI*EXP(-2.d0*ABSCO(J)*EFFG(J))/ & - MAX(1.d-20,(1.d0-( (RI*EXP(-ABSCO(J)*EFFG(J)))**2.d0 )) ) ) + IF(SWE > 0.01) THEN + + !========== SNOW CASE ========== + + DO M=1,N_SNOW - ! Transparency in one ice layer + ! Dry snow density in each snow layer [kg m-3] (N_Snow layers) - TRANS(J)= & - ( ((1.d0-RI)**2.d0)*EXP(-ABSCO(J)*EFFG(J))/ & - MAX(1.d-20,(1.d0-( (RI*EXP(-ABSCO(J)*EFFG(J)))**2.d0 )) ) ) + DENEL(M)=(FICES(M)*WESN(M)/(AREASC+1.e-20))/(SNDZ(M) + 1.e-20) + DENEL(M)=MIN(StieglitzSnow_RHOMA,DENEL(M)) + ! Mass concentrations of dust,BC, and OC [kg kg-1] (3 layers) - A(J)=( (1.d0-TRANS(J))/(EFFG(J)+1.d-20) )*( DENEL(J)/DDENICE ) - B(J)=( REF(J)/(EFFG(J)+1.d-20) )*( DENEL(J)/DDENICE ) + IF(PRESENT(RCONSTIT)) THEN + DO K=1,N_Constit + CONCENT(M,K)=RCONSTIT(M,K)/(WESN(M) + 1.e-20) + ENDDO + ELSE + DO K=1,N_Constit + CONCENT(M,K)=0. + ENDDO + ENDIF - AMU(J)=SQRT( MAX(0.d0,(A(J)**2.d0) - (B(J)**2.d0)) ) - TJALPHA(J)=( A(J)-AMU(J) )/(B(J)+1.d-20) - TJBETA(J)=( A(J)+AMU(J) )/(B(J)+1.d-20) + ! Snow specific surface area (SSA) [m2 kg-1] Equation based on Yamazaki et al. [1991,1993] + ! The equation is also based on the observed data by Narita [1971], Teionkagaku - END DO - - DI(L2)=0.d0 - - DO K=L2-1,1,-1 + SSA(M)=10.0**(-15.32*((DENEL(M)/1000.)**3.0) & + +16.65*((DENEL(M)/1000.)**2.0) & + -7.3*(DENEL(M)/1000.)+2.23) - !----- Revision for multi-layers (Teppei, Sep. 15, 2014) ----- - DZ=SUM(SNDZ(1:K)) - - DI(K)=(TJALPHA(K)-TJBETA(K+1))*DI(K+1)*EXP(2.d0*DZ*AMU(K+1))+TJALPHA(K)-TJALPHA(K+1) - DI(K)=DI(K)/( (TJBETA(K+1)-TJBETA(K))*DI(K+1)*EXP(2.d0*DZ*AMU(K+1))+TJALPHA(K+1)-TJBETA(K) ) - DI(K)=DI(K)*EXP(-2.d0*DZ*AMU(K)) + ! Another Equation for SSA based on the equation (1) in Domine et al., JGR, vol.112, 2007 + ! SSA(M,I)=( -308.2D0*LOG(DENEL(M,I)/1000.D0)-206.D0 )/10.D0 + ! When each snow layer has excess water (snow gets wet) + ! SSA is decreased to 60% values of the original value. + + IF(TPSN(M).GE.-0.001) SSA(M)=0.6*SSA(M) + + ! effective ice thickness comparable to effective snow grain radius + ! if EFFG is multiplied by 3 + + EFFG(M)=2.D0/(DENICE*SSA(M) + 1.e-20) + + ! Calculation of Absorption coefficients [m-1] Equations for mass con. [kg kg-1] + + SUM2=0. + do K=1,N_Constit + SUM2=SUM2+CONCENT(M,K) + ENDDO + + ! VIS range + SUM1=0. + do K=1,N_Constit + SUM1=SUM1+CONCENT(M,K)*1.E03*ABVIS(K) + ENDDO + ABSCOV(M)=DENICE*SUM1+(1.-SUM2)*AICEV + + ! NIR range + SUM1=0. + do K=1,N_Constit + SUM1=SUM1+CONCENT(M,K)*1.E03*ABNIR(K) + ENDDO + ABSCON(M)=DENICE*SUM1+(1.-SUM2)*AICEN + + ENDDO - END DO - - ! Surface Snow Albedo + ! VIS & NIR CASES BY NEW SNOW ALBEDO MODEL + + ASNVDR=ALB(N_Snow,RIV,ABSCOV(:),EFFG(:),DENEL(:),SNDZ(:),DENICE) + ASNNDR=ALB(N_Snow,RIN,ABSCON(:),EFFG(:),DENEL(:),SNDZ(:),DENICE) + + ! Diffuse components are calculated with the assumed SZTH of 50 degrees + ASNVDF = ASNVDR + ASNNDF = ASNNDR + + !+++++ Taking the effect of solar zenith angle (SZA) into account ++++++ + ! The second terms for VIS and NIR in equations (6) & (7) + ! [Marks and Dozier, Water Resources Research, Vol. 28, 3043-3054] + + ! For VIS [Note: unit for EFFG is um] + ASNVDR = ASNVDR & + -( (SQRT(1.5*(EFFG(1)*1.0E06))*1.375E-03)*(1.-COS50) ) & + +( (SQRT(1.5*(EFFG(1)*1.0E06))*1.375E-03)*(1.-SZTH) ) + + ! For NIR [Note: unit for EFFG is um] + ASNNDR = ASNNDR & + -( (( SQRT(1.5*(EFFG(1)*1.0E06))*2.0E-03)+0.1)*(1.-COS50)) & + +( (( SQRT(1.5*(EFFG(1)*1.0E06))*2.0E-03)+0.1)*(1.-SZTH) ) + + ELSE + + !========== NO SNOW CASE ========== + ! Use these when you use the original snow albedo model - ALBD= RI + & - ( ((1.d0-RI)**2.d0)*(TJBETA(1)*DI(1)+TJALPHA(1))/ & - MAX(1.d-20,(1.d0+DI(1)-(RI*(TJBETA(1)*DI(1)+TJALPHA(1))) ) ) ) + ASNVDR = MAX(SNWALB_VISMIN, SNWALB_VISMAX - DENS_EXC*.0006) + ASNNDR = MAX(SNWALB_NIRMIN, SNWALB_NIRMAX - DENS_EXC*.0006) + ASNVDF = MAX(SNWALB_VISMIN, SNWALB_VISMAX - DENS_EXC*.0006) + ASNNDF = MAX(SNWALB_NIRMIN, SNWALB_NIRMAX - DENS_EXC*.0006) - ALB=REAL(ALBD) + ENDIF + + RETURN + + END SUBROUTINE ALB_WITH_IMPURITY + + ! ********************************************************************** - RETURN - END FUNCTION ALB + !**** ------------------------------------------------------------------ + !**** //////////////// Added by Teppei J. Yasunari ///////////////START1 + !**** ------------------------------------------------------------------ + + !======================================================================= + != To determine RHOFS = + !======================================================================= + ! Version 5.1.0 by Teppei J. Yasuanari on 09/15/2014 + + SUBROUTINE WFSDEN(UM,RTS,RHO_FS) + + + REAL, INTENT(IN) :: UM,RTS + REAL, INTENT(OUT) :: RHO_FS + REAL :: ARHOFS + INTEGER :: IFG + + !--------------------------------------------------------------! + ! YOU CAN CHOOSE ONE OF 10 TYPES OF "RHOFS" ! + !--------------------------------------------------------------! + + ! ESAT : Saturated water vapor pressure [hPa] + ! E : Water vapor pressure [hPa] + ! TW : Wet bulb temperature [degree C] + ! + ! V1=UM + ! T2=RTS-273.15 + ! SR=TSNOW*3600. + ! + ! Saturated water vapor pressure -! ********************************************************************** + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! Fresh snow density by Melloh et al. (2002) + ! Hydrological Processes, 16, 3571-3584 + ! + ! RHOFS TYPE 1 + ! + ! IF(T2.GE.0.) THEN + ! TW=T2-((1013.25/(0.667*RPRES))*(ESAT-E)) + ! ELSE IF (T2.LT.0.) THEN + ! TW=T2-((1013.25/(0.589*RPRES))*(ESAT-E)) + ! END IF + ! + ! TWW=TW + ! ARHOFS=(0.05+(0.0017*(((TW+273.15)-258.16)**1.5)))*1000. + ! ARHOFS=MAX(ARHOFS,90.) + ! + !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! Multiple regression equation for new snow density + ! based on Kajikawa et al. (2004), Sepyo, 66, p.561-565. + ! + ! RHOFS TYPE 2 + ! Spatial dendrite (R**2=0.948; 10% confidence limit) + ! ARHOFS=13.3+(53.9*SR)+(6.54*V1) + ! + ! RHOFS TYPE 3 + ! Stellar crystal (R**2=0.817; 5% confidence limit) + ! ARHOFS=23.4+(37.5*SR)+(7.32*V1)+(0.579*T2) + ! + ! RHOFS TYPE 4 + ! Rimed stellar crystal (R**2=0.442; 5% confidence limit) + ! ARHOFS=41.2+(8.26*SR)+(5.16*V1)+(0.422*T2) + ! + ! RHOFS TYPE 5 + ! Rimed spatial dendrites (R**2=0.369; 5% confidence limit) + ! ARHOFS=67.5+(23.4*SR)-(1.29*V1)+(3.65*T2) + ! + ! RHOFS TYPE 6 + ! Rimed spatial dendrites 2 (R**2=0.321; 5% confidence limit) + ! ARHOFS=43.1*EXP(0.106*V1) + ! + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! 2001 J. Hydrometeorology (Boone and Etchevers) + ! Fresh snow density based on wind speed and air temeperature + ! + ! RHOFS TYPE 7 + ! ARHOFS=109.+(6.*(RTS-273.16))+(26.*(V1**0.5)) + ! + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! Equation 18 by Yamazaki et al. [1998] + ! Seppyo, 60, 131-141. + + ! RHOFS TYPE 8 + ARHOFS=67.+(13.*UM) + IFG=2 + IF(RTS-TF >= 0.) ARHOFS=200. + + !+++ USE Constant value of fresh snow density [kg m-3]+++ + ! RHOFS TYPE 9 + ! ARHOFS=110. ! Used in Yasunari et al. (2010) + + ! RHOFS TYPE 10 + ! ARHOFS=150. ! Used in original snowpack model + + + ! RHOFS does not exceed the maximum of 200. [kg m-3]. + RHO_FS=MIN(ARHOFS,200.) + + ! write(*,*) 'FRESH SNOW DENSITY',RHOFS + + ! (comment out for den) + rho_fs=150. + + RETURN + END SUBROUTINE WFSDEN + + ! ************************************************************************************** + + + !======================================================================= + != New snow albedo functions = + !======================================================================= + ! Version 5.1.0 by Teppei J. Yasuanari on 09/15/2014 + + FUNCTION ALB(L,RI0,ABSCO0,EFFG0,DENEL0,SNDZ0,DENICE) + + IMPLICIT NONE + + INTEGER :: J,K,L2 + INTEGER, INTENT(IN) :: L + REAL :: ALB + DOUBLE PRECISION :: ALBD,DZ,CDZ + REAL, INTENT(IN) :: RI0,DENICE + REAL, INTENT(IN), DIMENSION(L) :: EFFG0,ABSCO0,SNDZ0,DENEL0 + DOUBLE PRECISION :: RI,DDENICE + DOUBLE PRECISION, DIMENSION(L) :: EFFG,ABSCO,SNDZ,DENEL + DOUBLE PRECISION, DIMENSION(L) :: REF,TRANS,A,B,AMU,TJALPHA,TJBETA,DI + + ! From single to double precision + + RI=DBLE(RI0) + DDENICE=DBLE(DENICE) + EFFG(:)=DBLE(EFFG0(:)) + ABSCO(:)=DBLE(ABSCO0(:)) + SNDZ(:)=DBLE(SNDZ0(:)) + DENEL(:)=DBLE(DENEL0(:)) + + ! Only the top 3m of snow contributes to albedo + + CDZ=0.d0 + + DO J=1,L + CDZ=CDZ+SNDZ(J) + IF(CDZ > 3.d0) EXIT + L2=J + END DO + + DO J=1,L2 + + ! Reflectance in one ice layer + + REF(J)= RI + & + ( ((1.d0-RI)**2.d0)*RI*EXP(-2.d0*ABSCO(J)*EFFG(J))/ & + MAX(1.d-20,(1.d0-( (RI*EXP(-ABSCO(J)*EFFG(J)))**2.d0 )) ) ) + + ! Transparency in one ice layer + + TRANS(J)= & + ( ((1.d0-RI)**2.d0)*EXP(-ABSCO(J)*EFFG(J))/ & + MAX(1.d-20,(1.d0-( (RI*EXP(-ABSCO(J)*EFFG(J)))**2.d0 )) ) ) + + + A(J)=( (1.d0-TRANS(J))/(EFFG(J)+1.d-20) )*( DENEL(J)/DDENICE ) + B(J)=( REF(J)/(EFFG(J)+1.d-20) )*( DENEL(J)/DDENICE ) + + AMU(J)=SQRT( MAX(0.d0,(A(J)**2.d0) - (B(J)**2.d0)) ) + TJALPHA(J)=( A(J)-AMU(J) )/(B(J)+1.d-20) + TJBETA(J)=( A(J)+AMU(J) )/(B(J)+1.d-20) + + END DO + + DI(L2)=0.d0 + + DO K=L2-1,1,-1 + + !----- Revision for multi-layers (Teppei, Sep. 15, 2014) ----- + DZ=SUM(SNDZ(1:K)) + + DI(K)=(TJALPHA(K)-TJBETA(K+1))*DI(K+1)*EXP(2.d0*DZ*AMU(K+1))+TJALPHA(K)-TJALPHA(K+1) + DI(K)=DI(K)/( (TJBETA(K+1)-TJBETA(K))*DI(K+1)*EXP(2.d0*DZ*AMU(K+1))+TJALPHA(K+1)-TJBETA(K) ) + DI(K)=DI(K)*EXP(-2.d0*DZ*AMU(K)) + + END DO + + ! Surface Snow Albedo + + ALBD= RI + & + ( ((1.d0-RI)**2.d0)*(TJBETA(1)*DI(1)+TJALPHA(1))/ & + MAX(1.d-20,(1.d0+DI(1)-(RI*(TJBETA(1)*DI(1)+TJALPHA(1))) ) ) ) + + ALB=REAL(ALBD) + + RETURN + END FUNCTION ALB + + ! ********************************************************************** + subroutine StieglitzSnow_echo_constants(logunit) ! reichle, 12 Aug 2014 @@ -1981,20 +2132,19 @@ subroutine StieglitzSnow_echo_constants(logunit) write (logunit,*) write (logunit,*) 'StieglitzSnow_echo_constants():' write (logunit,*) - write (logunit,*) 'PIE = ', PIE - write (logunit,*) 'ALHE = ', ALHE - write (logunit,*) 'ALHM = ', ALHM - write (logunit,*) 'TF = ', TF - write (logunit,*) 'RHOW = ', RHOW + write (logunit,*) 'PIE = ', PIE + write (logunit,*) 'ALHE = ', ALHE + write (logunit,*) 'ALHM = ', ALHM + write (logunit,*) 'TF = ', TF + write (logunit,*) 'RHOW = ', RHOW write (logunit,*) - write (logunit,*) 'MINSWE = ', MINSWE - write (logunit,*) 'WEMIN = ', WEMIN - write (logunit,*) 'CPW = ', CPW - write (logunit,*) 'RHOMA = ', RHOMA - write (logunit,*) 'DZ1MAX = ', DZ1MAX + write (logunit,*) 'StieglitzSnow_MINSWE = ', StieglitzSnow_MINSWE + write (logunit,*) 'WEMIN = ', WEMIN + write (logunit,*) 'StieglitzSnow_CPW = ', StieglitzSnow_CPW + write (logunit,*) 'StieglitzSnow_RHOMA = ', StieglitzSnow_RHOMA write (logunit,*) - write (logunit,*) 'SNWALB_VISMIN = ', SNWALB_VISMIN - write (logunit,*) 'SNWALB_NIRMIN = ', SNWALB_NIRMIN + write (logunit,*) 'SNWALB_VISMIN = ', SNWALB_VISMIN + write (logunit,*) 'SNWALB_NIRMIN = ', SNWALB_NIRMIN write (logunit,*) write (logunit,*) 'end StieglitzSnow_echo_constants()' write (logunit,*) @@ -2002,6 +2152,7 @@ subroutine StieglitzSnow_echo_constants(logunit) write (logunit,*) end subroutine StieglitzSnow_echo_constants - + end module StieglitzSnow +! ============================ EOF ========================================================= diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/SurfParams.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/SurfParams.F90 old mode 100755 new mode 100644