diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOS_SurfaceGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOS_SurfaceGridComp.F90 index d04378320..9b111edcf 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOS_SurfaceGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOS_SurfaceGridComp.F90 @@ -2732,9 +2732,9 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'depth_to_water_table_from_surface',& + LONG_NAME = 'depth_to_water_table_from_surface_in_peat',& UNITS = 'm' ,& - SHORT_NAME = 'WATERTABLED' ,& + SHORT_NAME = 'PEATCLSM_WATERLEVEL' ,& DIMS = MAPL_DimsHorzOnly ,& VLOCATION = MAPL_VLocationNone ,& RC=STATUS ) @@ -2743,7 +2743,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC ,& LONG_NAME = 'change_in_free_surface_water_reservoir_on_peat',& UNITS = 'kg m-2 s-1' ,& - SHORT_NAME = 'FSWCHANGE' ,& + SHORT_NAME = 'PEATCLSM_FSWCHANGE' ,& DIMS = MAPL_DimsHorzOnly ,& VLOCATION = MAPL_VLocationNone ,& RC=STATUS ) @@ -5125,8 +5125,8 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) real, pointer, dimension(:,:) :: RMELTBC002 => NULL() real, pointer, dimension(:,:) :: RMELTOC001 => NULL() real, pointer, dimension(:,:) :: RMELTOC002 => NULL() - real, pointer, dimension(:,:) :: WATERTABLED => NULL() - real, pointer, dimension(:,:) :: FSWCHANGE => NULL() + real, pointer, dimension(:,:) :: PEATCLSM_WATERLEVEL => NULL() + real, pointer, dimension(:,:) :: PEATCLSM_FSWCHANGE => NULL() ! CN model real, pointer, dimension(:,:) :: CNLAI => NULL() @@ -5386,8 +5386,8 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) real, pointer, dimension(:) :: RMELTBC002TILE => NULL() real, pointer, dimension(:) :: RMELTOC001TILE => NULL() real, pointer, dimension(:) :: RMELTOC002TILE => NULL() - real, pointer, dimension(:) :: WATERTABLEDTILE => NULL() - real, pointer, dimension(:) :: FSWCHANGETILE => NULL() + real, pointer, dimension(:) :: PEATCLSM_WATERLEVELTILE => NULL() + real, pointer, dimension(:) :: PEATCLSM_FSWCHANGETILE => NULL() real, pointer, dimension(:) :: CNLAITILE => NULL() real, pointer, dimension(:) :: CNTLAITILE => NULL() @@ -6222,8 +6222,8 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetPointer(EXPORT , RMELTBC002 , 'RMELTBC002', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT , RMELTOC001 , 'RMELTOC001', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT , RMELTOC002 , 'RMELTOC002', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT , WATERTABLED, 'WATERTABLED', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT , FSWCHANGE , 'FSWCHANGE', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT , PEATCLSM_WATERLEVEL, 'PEATCLSM_WATERLEVEL', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT , PEATCLSM_FSWCHANGE, 'PEATCLSM_FSWCHANGE', RC=STATUS); VERIFY_(STATUS) IF(LSM_CHOICE > 1) THEN @@ -6798,8 +6798,8 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) call MKTILE(RMELTBC002 ,RMELTBC002TILE ,NT,RC=STATUS); VERIFY_(STATUS) call MKTILE(RMELTOC001 ,RMELTOC001TILE ,NT,RC=STATUS); VERIFY_(STATUS) call MKTILE(RMELTOC002 ,RMELTOC002TILE ,NT,RC=STATUS); VERIFY_(STATUS) - call MKTILE(WATERTABLED,WATERTABLEDTILE,NT,RC=STATUS); VERIFY_(STATUS) - call MKTILE(FSWCHANGE ,FSWCHANGETILE ,NT,RC=STATUS); VERIFY_(STATUS) + call MKTILE(PEATCLSM_WATERLEVEL,PEATCLSM_WATERLEVELTILE,NT,RC=STATUS); VERIFY_(STATUS) + call MKTILE(PEATCLSM_FSWCHANGE ,PEATCLSM_FSWCHANGETILE ,NT,RC=STATUS); VERIFY_(STATUS) IF (LSM_CHOICE > 1) THEN call MKTILE(CNLAI ,CNLAITILE ,NT,RC=STATUS); VERIFY_(STATUS) @@ -7644,8 +7644,8 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) if(associated(RMELTBC002 ))call MAPL_LocStreamTransform(LOCSTREAM,RMELTBC002 ,RMELTBC002TILE, RC=STATUS); VERIFY_(STATUS) if(associated(RMELTOC001 ))call MAPL_LocStreamTransform(LOCSTREAM,RMELTOC001 ,RMELTOC001TILE, RC=STATUS); VERIFY_(STATUS) if(associated(RMELTOC002 ))call MAPL_LocStreamTransform(LOCSTREAM,RMELTOC002 ,RMELTOC002TILE, RC=STATUS); VERIFY_(STATUS) - if(associated(WATERTABLED))call MAPL_LocStreamTransform(LOCSTREAM,WATERTABLED,WATERTABLEDTILE,RC=STATUS); VERIFY_(STATUS) - if(associated(FSWCHANGE ))call MAPL_LocStreamTransform(LOCSTREAM,FSWCHANGE ,FSWCHANGETILE, RC=STATUS); VERIFY_(STATUS) + if(associated(PEATCLSM_WATERLEVEL))call MAPL_LocStreamTransform(LOCSTREAM,PEATCLSM_WATERLEVEL,PEATCLSM_WATERLEVELTILE,RC=STATUS); VERIFY_(STATUS) + if(associated(PEATCLSM_FSWCHANGE ))call MAPL_LocStreamTransform(LOCSTREAM,PEATCLSM_FSWCHANGE ,PEATCLSM_FSWCHANGETILE, RC=STATUS); VERIFY_(STATUS) if(associated(CNLAI)) then call MAPL_LocStreamTransform( LOCSTREAM,CNLAI ,CNLAITILE , RC=STATUS) @@ -8179,8 +8179,8 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) if(associated(RMELTBC002TILE )) deallocate(RMELTBC002TILE ) if(associated(RMELTOC001TILE )) deallocate(RMELTOC001TILE ) if(associated(RMELTOC002TILE )) deallocate(RMELTOC002TILE ) - if(associated(WATERTABLEDTILE)) deallocate(WATERTABLEDTILE) - if(associated(FSWCHANGETILE )) deallocate(FSWCHANGETILE ) + if(associated(PEATCLSM_WATERLEVELTILE)) deallocate(PEATCLSM_WATERLEVELTILE) + if(associated(PEATCLSM_FSWCHANGETILE )) deallocate(PEATCLSM_FSWCHANGETILE ) if(associated(CNLAITILE )) deallocate(CNLAITILE ) if(associated(CNTLAITILE )) deallocate(CNTLAITILE ) if(associated(CNSAITILE )) deallocate(CNSAITILE ) @@ -8516,9 +8516,9 @@ subroutine DOTYPE(type,RC) VERIFY_(STATUS) call MAPL_GetPointer(GEX(type), dum, 'RMELTOC002' , ALLOC=associated(RMELTOC002TILE ), notFoundOK=.true., RC=STATUS) VERIFY_(STATUS) - call MAPL_GetPointer(GEX(type), dum, 'WATERTABLED', ALLOC=associated(WATERTABLEDTILE ),notFoundOK=.true., RC=STATUS) + call MAPL_GetPointer(GEX(type), dum, 'PEATCLSM_WATERLEVEL', ALLOC=associated(PEATCLSM_WATERLEVELTILE), notFoundOK=.true., RC=STATUS) VERIFY_(STATUS) - call MAPL_GetPointer(GEX(type), dum, 'FSWCHANGE' , ALLOC=associated(FSWCHANGETILE ) , notFoundOK=.true., RC=STATUS) + call MAPL_GetPointer(GEX(type), dum, 'PEATCLSM_FSWCHANGE' , ALLOC=associated(PEATCLSM_FSWCHANGETILE ), notFoundOK=.true., RC=STATUS) VERIFY_(STATUS) IF (LSM_CHOICE > 1) THEN @@ -9088,8 +9088,8 @@ subroutine DOTYPE(type,RC) if(associated(RMELTBC002TILE)) call FILLOUT_TILE(GEX(type), 'RMELTBC002' , RMELTBC002TILE , XFORM, RC=STATUS);VERIFY_(STATUS) if(associated(RMELTOC001TILE)) call FILLOUT_TILE(GEX(type), 'RMELTOC001' , RMELTOC001TILE , XFORM, RC=STATUS);VERIFY_(STATUS) if(associated(RMELTOC002TILE)) call FILLOUT_TILE(GEX(type), 'RMELTOC002' , RMELTOC002TILE , XFORM, RC=STATUS);VERIFY_(STATUS) - if(associated(WATERTABLEDTILE))call FILLOUT_TILE(GEX(type), 'WATERTABLED', WATERTABLEDTILE, XFORM, RC=STATUS);VERIFY_(STATUS) - if(associated(FSWCHANGETILE)) call FILLOUT_TILE(GEX(type), 'FSWCHANGE' , FSWCHANGETILE , XFORM, RC=STATUS);VERIFY_(STATUS) + if(associated(PEATCLSM_WATERLEVELTILE)) call FILLOUT_TILE(GEX(type), 'PEATCLSM_WATERLEVEL', PEATCLSM_WATERLEVELTILE, XFORM, RC=STATUS);VERIFY_(STATUS) + if(associated(PEATCLSM_FSWCHANGETILE)) call FILLOUT_TILE(GEX(type), 'PEATCLSM_FSWCHANGE' , PEATCLSM_FSWCHANGETILE , XFORM, RC=STATUS);VERIFY_(STATUS) if(associated(CNLAITILE)) then call FILLOUT_TILE(GEX(type), 'CNLAI' , CNLAITILE , XFORM, RC=STATUS) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOS_LandGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOS_LandGridComp.F90 index bfca66893..e762166db 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOS_LandGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOS_LandGridComp.F90 @@ -920,8 +920,8 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec ( GC, SHORT_NAME = 'RMELTBC002', CHILD_ID = CATCH(1), RC=STATUS) ; VERIFY_(STATUS) call MAPL_AddExportSpec ( GC, SHORT_NAME = 'RMELTOC001', CHILD_ID = CATCH(1), RC=STATUS) ; VERIFY_(STATUS) call MAPL_AddExportSpec ( GC, SHORT_NAME = 'RMELTOC002', CHILD_ID = CATCH(1), RC=STATUS) ; VERIFY_(STATUS) - call MAPL_AddExportSpec ( GC, SHORT_NAME = 'WATERTABLED',CHILD_ID = CATCH(1), RC=STATUS) ; VERIFY_(STATUS) - call MAPL_AddExportSpec ( GC, SHORT_NAME = 'FSWCHANGE', CHILD_ID = CATCH(1), RC=STATUS) ; VERIFY_(STATUS) + call MAPL_AddExportSpec ( GC, SHORT_NAME = 'PEATCLSM_WATERLEVEL',CHILD_ID = CATCH(1), RC=STATUS) ; VERIFY_(STATUS) + call MAPL_AddExportSpec ( GC, SHORT_NAME = 'PEATCLSM_FSWCHANGE', CHILD_ID = CATCH(1), RC=STATUS) ; VERIFY_(STATUS) if (DO_GOSWIM /= 0) then call MAPL_AddExportSpec ( GC, SHORT_NAME = 'RDU001', CHILD_ID = CATCH(1), RC=STATUS) ; VERIFY_(STATUS) @@ -1292,8 +1292,8 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec ( GC, SHORT_NAME = 'RMELTBC002', CHILD_ID = CATCHCN(1), RC=STATUS) ; VERIFY_(STATUS) call MAPL_AddExportSpec ( GC, SHORT_NAME = 'RMELTOC001', CHILD_ID = CATCHCN(1), RC=STATUS) ; VERIFY_(STATUS) call MAPL_AddExportSpec ( GC, SHORT_NAME = 'RMELTOC002', CHILD_ID = CATCHCN(1), RC=STATUS) ; VERIFY_(STATUS) - call MAPL_AddExportSpec ( GC, SHORT_NAME = 'WATERTABLED',CHILD_ID = CATCHCN(1), RC=STATUS) ; VERIFY_(STATUS) - call MAPL_AddExportSpec ( GC, SHORT_NAME = 'FSWCHANGE', CHILD_ID = CATCHCN(1), RC=STATUS) ; VERIFY_(STATUS) + call MAPL_AddExportSpec ( GC, SHORT_NAME = 'PEATCLSM_WATERLEVEL',CHILD_ID = CATCHCN(1), RC=STATUS) ; VERIFY_(STATUS) + call MAPL_AddExportSpec ( GC, SHORT_NAME = 'PEATCLSM_FSWCHANGE', CHILD_ID = CATCHCN(1), RC=STATUS) ; VERIFY_(STATUS) if (DO_GOSWIM /= 0) then call MAPL_AddExportSpec ( GC, SHORT_NAME = 'RDU001', CHILD_ID = CATCHCN(1), RC=STATUS) ; VERIFY_(STATUS) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOS_CatchCNGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOS_CatchCNGridComp.F90 index e790bcd5f..b569ac07c 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOS_CatchCNGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOS_CatchCNGridComp.F90 @@ -984,8 +984,8 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec ( GC, SHORT_NAME = 'RMELTBC002', CHILD_ID = CATCHCN, RC=STATUS) ; VERIFY_(STATUS) call MAPL_AddExportSpec ( GC, SHORT_NAME = 'RMELTOC001', CHILD_ID = CATCHCN, RC=STATUS) ; VERIFY_(STATUS) call MAPL_AddExportSpec ( GC, SHORT_NAME = 'RMELTOC002', CHILD_ID = CATCHCN, RC=STATUS) ; VERIFY_(STATUS) - call MAPL_AddExportSpec ( GC, SHORT_NAME = 'WATERTABLED',CHILD_ID = CATCHCN, RC=STATUS) ; VERIFY_(STATUS) - call MAPL_AddExportSpec ( GC, SHORT_NAME = 'FSWCHANGE' , CHILD_ID = CATCHCN, RC=STATUS) ; VERIFY_(STATUS) + call MAPL_AddExportSpec ( GC, SHORT_NAME = 'PEATCLSM_WATERLEVEL',CHILD_ID = CATCHCN, RC=STATUS) ; VERIFY_(STATUS) + call MAPL_AddExportSpec ( GC, SHORT_NAME = 'PEATCLSM_FSWCHANGE' ,CHILD_ID = CATCHCN, RC=STATUS) ; VERIFY_(STATUS) if (DO_GOSWIM /= 0) then call MAPL_AddExportSpec ( GC, SHORT_NAME = 'RDU001', CHILD_ID = CATCHCN, RC=STATUS) ; VERIFY_(STATUS) 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 32173c29d..2c290094f 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 @@ -51,7 +51,8 @@ module GEOS_CatchCNCLM40GridCompMod RHOFS => CATCH_SNWALB_RHOFS, & SNWALB_VISMAX => CATCH_SNWALB_VISMAX, & SNWALB_NIRMAX => CATCH_SNWALB_NIRMAX, & - SLOPE => CATCH_SNWALB_SLOPE + SLOPE => CATCH_SNWALB_SLOPE, & + PEATCLSM_POROS_THRESHOLD USE clm_varpar, ONLY : & NUM_ZON, NUM_VEG, VAR_COL, VAR_PFT, & @@ -61,8 +62,8 @@ module GEOS_CatchCNCLM40GridCompMod use MAPL_ConstantsMod,only: Tzero => MAPL_TICE, pi => MAPL_PI use clm_time_manager, only: get_days_per_year, get_step_size use pftvarcon, only: noveg - USE lsm_routines, ONLY : sibalb, catch_calc_soil_moist, & - catch_calc_zbar, catch_calc_watertabled, irrigation_rate, & + USE lsm_routines, ONLY : sibalb, catch_calc_soil_moist, & + catch_calc_zbar, catch_calc_peatclsm_waterlevel, irrigation_rate, & gndtmp implicit none @@ -173,7 +174,7 @@ module GEOS_CatchCNCLM40GridCompMod end type OFFLINE_WRAP integer :: RUN_IRRIG, USE_ASCATZ0, Z0_FORMULATION, IRRIG_METHOD, AEROSOL_DEPOSITION, N_CONST_LAND4SNWALB -integer :: ATM_CO2, PRESCRIBE_DVG, SCALE_ALBFPAR,CHOOSEMOSFC +integer :: ATM_CO2, PRESCRIBE_DVG,CHOOSEMOSFC real :: SURFLAY ! Default (Ganymed-3 and earlier) SURFLAY=20.0 for Old Soil Params ! (Ganymed-4 and later ) SURFLAY=50.0 for New Soil Params real :: CO2 @@ -297,13 +298,6 @@ subroutine SetServices ( GC, RC ) ! 3--Estimated LAI/SAI using anomalies at the beginning of the foeecast and climatological LAI/SAI call MAPL_GetResource (SCF, PRESCRIBE_DVG, label='PRESCRIBE_DVG:', DEFAULT=0 , __RC__ ) - ! SCALE_ALBFPAR: Scale CATCHCN ALBEDO and FPAR - ! 0-- NO scaling is performed - ! 1-- Scale albedo to match interannually varying MODIS NIRDF and VISDF anomaly - ! 2-- Scale albedo to match CDFs of model fPAR to MODIS CDFs of fPAR - ! 3-- Pefform above both 1 and 2 scalings - call MAPL_GetResource (SCF, SCALE_ALBFPAR, label='SCALE_ALBFPAR:', DEFAULT=0 , __RC__ ) - ! Global mean CO2 call MAPL_GetResource (SCF, CO2, label='CO2:', DEFAULT=350.e-6, __RC__ ) call MAPL_GetResource (SCF, CO2_YEAR_IN, label='CO2_YEAR:', DEFAULT= -9999, __RC__ ) @@ -3737,9 +3731,9 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'depth_to_water_table_from_surface',& + LONG_NAME = 'depth_to_water_table_from_surface_in_peat',& UNITS = 'm' ,& - SHORT_NAME = 'WATERTABLED' ,& + SHORT_NAME = 'PEATCLSM_WATERLEVEL' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& RC=STATUS ) @@ -3748,7 +3742,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC ,& LONG_NAME = 'change_in_free_surface_water_reservoir_on_peat',& UNITS = 'kg m-2 s-1' ,& - SHORT_NAME = 'FSWCHANGE' ,& + SHORT_NAME = 'PEATCLSM_FSWCHANGE' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& RC=STATUS ) @@ -4911,8 +4905,8 @@ subroutine Driver ( RC ) real, pointer, dimension(:) :: RMELTOC001 real, pointer, dimension(:) :: RMELTOC002 real, pointer, dimension(:) :: IRRIGRATE - real, pointer, dimension(:) :: WATERTABLED - real, pointer, dimension(:) :: FSWCHANGE + real, pointer, dimension(:) :: PEATCLSM_WATERLEVEL + real, pointer, dimension(:) :: PEATCLSM_FSWCHANGE ! -------------------------------------------------------------------------- ! Local pointers for tile variables @@ -5170,24 +5164,9 @@ subroutine Driver ( RC ) real, allocatable, dimension(:) :: ALBVR_tmp, ALBNR_tmp, ALBVF_tmp, ALBNF_tmp real, allocatable, dimension(:) :: SNOVR_tmp, SNONR_tmp, SNOVF_tmp, SNONF_tmp - ! Variables for FPAR scaling - ! -------------------------- - - real, save,allocatable,dimension (:,:,:,:) :: Kappa, Lambda, Mu - real, save,allocatable,dimension (:,:,:) :: MnVal, MxVal - integer, save, allocatable, dimension (:) :: modis_tid, ThisMIndex - integer :: n_modis, NTCurrent, CDFfile, infos, comms - integer, allocatable, dimension (:,:) :: modis_index - integer, allocatable, dimension (:) :: modis2cat - real , allocatable, dimension (:) :: m_lons, m_lats - real , allocatable, dimension (:,:) :: scaled_fpar, parav, parzone, unscaled_fpar - REAL , PARAMETER :: TILEINT = 2. - integer, PARAMETER :: NOCTAD = 46, NSETS = 2 - real :: CLM4_fpar, CLM4_cdf, MODIS_fpar, tmparr(1,1,1,2), & - ThisK, ThisL, ThisM, ThisMin, ThisMax, tmparr2(1,1,1), ThisFPAR, ZFPAR - character (len=ESMF_MAXSTR) :: VISMEANFILE, VISSTDFILE, NIRMEANFILE, NIRSTDFILE, FPARMEANFILE, FPARSTDFILE - real, allocatable, dimension (:) :: MODISVISmean, MODISVISstd, MODISNIRmean, MODISNIRstd, MODELFPARmean, MODELFPARstd - logical, save :: first_fpar = .true. + ! Variables for FPAR + ! -------------------------- + real , allocatable, dimension (:,:) :: parzone IAm=trim(COMP_NAME)//"::RUN2::Driver" @@ -5558,8 +5537,8 @@ subroutine Driver ( RC ) call MAPL_GetPointer(EXPORT,RMELTBC002,'RMELTBC002', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT,RMELTOC001,'RMELTOC001', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT,RMELTOC002,'RMELTOC002', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT,WATERTABLED ,'WATERTABLED', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT,FSWCHANGE , 'FSWCHANGE', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,PEATCLSM_WATERLEVEL,'PEATCLSM_WATERLEVEL',RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,PEATCLSM_FSWCHANGE ,'PEATCLSM_FSWCHANGE', RC=STATUS); VERIFY_(STATUS) IF (RUN_IRRIG /= 0) call MAPL_GetPointer(EXPORT,IRRIGRATE ,'IRRIGRATE' , RC=STATUS); VERIFY_(STATUS) NTILES = size(PS) @@ -5702,123 +5681,6 @@ subroutine Driver ( RC ) ENDIF READ_CT_CO2 ENDIF - ! OPTIONAL FPAR SCALING -! --------------------- - - if (SCALE_ALBFPAR >= 2) then - IF (ntiles > 0) THEN - INTILALIZE_FPAR_PARAM : if(first_fpar) then - - ! Initialize FPAR MODIS scale parameters - ! -------------------------------------- - -! CALL ESMF_VMGet(vm, MPICOMMUNICATOR=comms, rc=status) -! VERIFY_(status) -! call MPI_Info_create(infos, STATUS) -! call MPI_Info_set(infos, "romio_cb_read", "automatic", STATUS) - - STATUS = NF_OPEN ('FPAR_CDF_Params-M09.nc4', NF_NOWRITE, CDFfile) - STATUS = NF_INQ_DIMID (CDFfile, 'tile10D', k); VERIFY_(STATUS) - STATUS = NF_INQ_DIMLEN (CDFfile, K, n_modis) ; VERIFY_(STATUS) - - allocate (m_lons (1 : n_modis)) - allocate (m_lats (1 : n_modis)) - - STATUS = NF_GET_VARA_REAL (CDFfile, VarID(CDFfile,'lon'), (/1/), (/n_modis/), m_lons);VERIFY_(STATUS) - STATUS = NF_GET_VARA_REAL (CDFfile, VarID(CDFfile,'lat'), (/1/), (/n_modis/), m_lats);VERIFY_(STATUS) - - allocate (modis_index (1: 360/nint(TILEINT), 1: 180/nint(TILEINT))) - modis_index = -9999 - - ! vector to grid 10x10 MODIS tiles - - do i = 1, n_modis - - k = NINT (((m_lons(i) + TILEINT/2.) + 180.) / TILEINT) - n = NINT (((m_lats(i) + TILEINT/2.) + 90.) / TILEINT) - modis_index (k, n) = i - - end do - - ! for each catchment-tile overlying MODIS 10x10 tile - - allocate (modis2cat (1: NTILES)) - allocate (modis_tid (1: NTILES)) - - modis_tid = -9999 - modis2cat = 0 - - do i = 1, NTILES - - k = NINT ((CEILING (lons(i)*90./MAPL_PI)*2 + 180.) / TILEINT) - n = NINT ((CEILING (lats(i)*90./MAPL_PI)*2 + 90.) / TILEINT) - if(k <= 3) k = 3 - if(k >= 178) k = 178 - modis2cat (i) = modis_index (k,n) - - end do - - K = count(modis2cat > 0) - - allocate (unq_mask(1:K )) - allocate (loc_int (1:K )) - - loc_int = pack(modis2cat ,mask = (modis2cat > 0)) - call MAPL_Sort (loc_int) - unq_mask = .true. - - do i = 2,K - unq_mask(i) = .not.(loc_int(i) == loc_int(i-1)) - end do - - NUNQ = count(unq_mask) - - allocate (ThisIndex (1:NUNQ)) - ThisIndex = pack(loc_int, mask = unq_mask ) - - allocate (Kappa (1: NUNQ, 1: NUMPFT, 1 : NOCTAD, 1 : 2)) - allocate (Lambda(1: NUNQ, 1: NUMPFT, 1 : NOCTAD, 1 : 2)) - allocate (Mu (1: NUNQ, 1: NUMPFT, 1 : NOCTAD, 1 : 2)) - allocate (MnVal (1: NUNQ, 1: NUMPFT, 1 : NOCTAD)) - allocate (MxVal (1: NUNQ, 1: NUMPFT, 1 : NOCTAD)) - - Kappa = -9999. - Lambda = -9999. - Mu = -9999. - - do i = 1, NUNQ - - where (modis2cat == ThisIndex(i)) modis_tid = i - - end do - - do i = 1, NUNQ - do K = 1,NOCTAD - do n = 1, NUMPFT - IF (ThisIndex(i) >= 1) THEN - STATUS = NF_GET_VARA_REAL(CDFFile, VARID(CDFFile,'Kappa' ),(/ThisIndex(i),N,K,1/), (/1,1,1,2/), tmparr);VERIFY_(STATUS) - Kappa (i,N,K,:) = tmparr (1,1,1,:) - STATUS = NF_GET_VARA_REAL(CDFFile, VARID(CDFFile,'Lambda'),(/ThisIndex(i),N,K,1/), (/1,1,1,2/), tmparr);VERIFY_(STATUS) - Lambda(i,N,K,:) = tmparr (1,1,1,:) - STATUS = NF_GET_VARA_REAL(CDFFile, VARID(CDFFile,'Mu' ),(/ThisIndex(i),N,K,1/), (/1,1,1,2/), tmparr);VERIFY_(STATUS) - Mu (i,N,K,:) = tmparr (1,1,1,:) - STATUS = NF_GET_VARA_REAL(CDFFile, VARID(CDFFile,'MinVal'),(/ThisIndex(i),N,K/), (/1,1,1/), tmparr2);VERIFY_(STATUS) - MnVal(i,N,K) = tmparr2 (1,1,1) - STATUS = NF_GET_VARA_REAL(CDFFile, VARID(CDFFile,'MaxVal'),(/ThisIndex(i),N,K/), (/1,1,1/), tmparr2);VERIFY_(STATUS) - MxVal(i,N,K) = tmparr2 (1,1,1) - ENDIF - end do - end do - end do - status = NF_CLOSE (CDFFile) - - deallocate ( modis2cat, unq_mask, loc_int, modis_index, m_lons, m_lats) - - first_fpar = .false. - - endif INTILALIZE_FPAR_PARAM - endif - end if ! -------------------------------------------------------------------------- ! ALLOCATE LOCAL POINTERS @@ -6352,11 +6214,7 @@ subroutine Driver ( RC ) allocate( car1(ntiles) ) allocate( car2(ntiles) ) allocate( car4(ntiles) ) - allocate( parzone(ntiles,nveg) ) allocate( para(ntiles) ) - allocate( parav(ntiles,nveg) ) - allocate (scaled_fpar (NTILES,NVEG)) - allocate (unscaled_fpar(NTILES,NVEG)) allocate ( totwat(ntiles) ) if(.not. allocated(npp )) allocate( npp(ntiles) ) if(.not. allocated(gpp )) allocate( gpp(ntiles) ) @@ -6382,6 +6240,7 @@ subroutine Driver ( RC ) allocate( psnsunx(ntiles,nveg) ) allocate( psnshax(ntiles,nveg) ) + allocate( parzone(ntiles,nveg) ) allocate( sifsunx(ntiles,nveg) ) allocate( sifshax(ntiles,nveg) ) allocate( laisunx(ntiles,nveg) ) @@ -6657,8 +6516,6 @@ subroutine Driver ( RC ) end do para(:) = 0. ! zero out absorbed PAR summing array - parav(:, :) = 0. ! - scaled_fpar = 1. do nz = 1,nzone @@ -6754,8 +6611,8 @@ subroutine Driver ( RC ) do nv = 1,nveg para(:) = para(:) + parzone(:,nv)*wtzone(:,nz)*fvez(:,nv) - parav(:,nv) = parav (:,nv) + parzone(:,nv)*wtzone(:,nz) end do + if(associated(BTRANT)) btrant(:) = btrant(:) + btran(:)*wtzone(:,nz) if(associated(SIF)) then do nv = 1,nveg @@ -6765,157 +6622,6 @@ subroutine Driver ( RC ) end do - do nv = 1,nveg - unscaled_fpar (:,nv) = parav (:,nv)/ (DRPAR(:) + DFPAR(:) + 1.e-20) - end do - - NTCurrent = CEILING (real (dofyr) / 8.) - - ! FPAR scaling to match MODIS CDF - ! ------------------------------- - - DO_FS1 : if (SCALE_ALBFPAR >= 2) then - - IF (ntiles > 0) THEN - - NT_LOOP1 : do n = 1,NTILES - - NV_LOOP1 : do nv = 1,nveg - - CLM4_fpar = parav (n,nv) / (DRPAR (n) + DFPAR (n) + 1.e-20) - K = -1 - - if(CLM4_fpar > 0.) then - - k = NINT(ITY(N,nv)) - if(minval(Kappa (modis_tid (n), k, NTCurrent, :)) < 0.) then - k = -1 - if(nv == 1) k = NINT(ITY(N,2)) - if(nv == 2) k = NINT(ITY(N,1)) - if(nv == 3) k = NINT(ITY(N,4)) - if(nv == 4) k = NINT(ITY(N,3)) - if(minval(Kappa (modis_tid (n), k, NTCurrent, :)) < 0.) k = -1 - if((K == -1).and.(nv > 2)) then - if(minval(Kappa (modis_tid (n), NINT(ITY(N,2)), NTCurrent, :)) > 0.) k = NINT(ITY(N,2)) - if(minval(Kappa (modis_tid (n), NINT(ITY(N,1)), NTCurrent, :)) > 0.) k = NINT(ITY(N,1)) - endif - endif - - endif - - if((K > 0).and.(CLM4_fpar > 0)) then - - ! Computing probability of CLM4 FPAR - - ThisK = Kappa (modis_tid (n), k, NTCurrent, 2) - ThisL = Lambda (modis_tid (n), k, NTCurrent, 2) - ThisM = Mu (modis_tid (n), k, NTCurrent, 2) - ThisMin = MnVal (modis_tid (n), k, NTCurrent) - ThisMax = MxVal (modis_tid (n), k, NTCurrent) - - if (CLM4_fpar < ThisMin) CLM4_fpar = ThisMin - if (CLM4_fpar > ThisMax) CLM4_fpar = ThisMax - if((ThisL == 0.).or.(ThisM == 0.)) print *,thisK,ThisL, ThisM, CLM4_fpar, ThisMin, ThisMax - if((ThisL == 0.).or.(ThisM == 0.)) print *,n,k,NTCurrent,modis_tid (n) - CLM4_cdf = ThisK * betai (ThisL, ThisM, (CLM4_fpar - ThisMin)/ThisMax) - - ! Computing corresponding MODIS FPAR for the same probability - - ThisK = Kappa (modis_tid (n), k, NTCurrent, 1) - ThisL = Lambda (modis_tid (n), k, NTCurrent, 1) - ThisM = Mu (modis_tid (n), k, NTCurrent, 1) - ThisMin = MnVal (modis_tid (n), k, NTCurrent) - ThisMax = MxVal (modis_tid (n), k, NTCurrent) - - scaled_fpar (n,nv) = cdf2fpar (CLM4_cdf, ThisK, ThisL, ThisM, ThisMin, ThisMax) - if((scaled_fpar (n,nv) > 1.).or.(scaled_fpar (n,nv) < 0.)) then - print *, 'PROB 1', CLM4_cdf, ThisK, ThisL, ThisM, ThisMin, ThisMax, scaled_fpar (n,nv) - endif - - scaled_fpar (n,nv) = scaled_fpar (n,nv) / (CLM4_fpar + 1.e-20) - - endif - end do NV_LOOP1 - - end do NT_LOOP1 - - para (:) = 0. ! zero out absorbed PAR summing array - parav = 0. - - if(associated(BTRANT)) btrant = 0. - if(associated(SIF)) sif = 0. - - do nz = 1,num_zon - - if(nz == 1) then - btran = btran1 - tcx = tx1 - qax = qx1 - endif - - if(nz == 2) then - btran = btran2 - tcx = tx2 - qax = qx2 - endif - - if(nz == 3) then - btran = btran3 - tcx = tx3 - qax = qx3 - endif - - do nv = 1,num_veg - elaz(:,nv) = elai(:,nv,nz) - esaz(:,nv) = esai(:,nv,nz) - ityz(:,nv) = ityp(:,nv,nz) - fvez(:,nv) = fveg(:,nv,nz) - end do - - do n = 1,NTILES - if(tp1(n) < (Tzero-0.01)) btran(n) = 0. ! no photosynthesis if ground fully frozen - end do - - call compute_rc(NTILES,nveg,TCx,QAx, & - TA, PS, ZTH,DRPAR,DFPAR, & - elaz,esaz,ityz,fvez,btran,fwet, & - RCx,RCxDT,RCxDQ,psnsunx,psnshax,laisunx,laishax, & - dayl_fac,co2v,dtc,dea,parzone,sifsunx,sifshax, & - fpar_sf = scaled_fpar ) - - rc00(:,nz) = rcx(:) - rcdt(:,nz) = rcxdt(:) - rcdq(:,nz) = rcxdq(:) - - psnsun(:,:,nz) = psnsunx(:,:) - psnsha(:,:,nz) = psnshax(:,:) - laisun(:,:,nz) = laisunx(:,:) - laisha(:,:,nz) = laishax(:,:) - - do nv = 1,nveg - para(:) = para(:) + parzone(:,nv)*wtzone(:,nz)*fvez(:,nv) - parav(:,nv) = parav (:,nv) + parzone(:,nv)*wtzone(:,nz) - end do - - if(associated(BTRANT)) btrant(:) = btrant(:) + btran(:)*wtzone(:,nz) - if(associated(SIF)) then - do nv = 1,nveg - sif(:) = sif(:) + wtzone(:,nz)*fvez(:,nv)*(sifsunx(:,nv)*laisunx(:,nv) + sifshax(:,nv)*laishax(:,nv)) - end do - endif - - end do - - endif - - endif DO_FS1 - - ! Below we are recycling the scaled_fpar array - from this point, it contains fpar scaled or otherwise - ! ---------------------------------------------------------------------------------------------------- - - do nv = 1,nveg - scaled_fpar (:,nv) = parav (:,nv)/ (DRPAR(:) + DFPAR(:) + 1.e-20) - end do if(associated(CNCO2)) CNCO2 = CO2V * 1e6 deallocate (co2v) @@ -6940,40 +6646,6 @@ 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 - if ((SCALE_ALBFPAR == 1).OR.(SCALE_ALBFPAR == 3)) then - - if(.not.allocated (MODISVISmean )) allocate (MODISVISmean (1:NTILES)) - if(.not.allocated (MODISVISstd )) allocate (MODISVISstd (1:NTILES)) - if(.not.allocated (MODISNIRmean )) allocate (MODISNIRmean (1:NTILES)) - if(.not.allocated (MODISNIRstd )) allocate (MODISNIRstd (1:NTILES)) - if(.not.allocated (MODELFPARmean)) allocate (MODELFPARmean (1:NTILES)) - if(.not.allocated (MODELFPARstd )) allocate (MODELFPARstd (1:NTILES)) - - if(ntiles > 0) then - - call MAPL_GetResource(MAPL,VISMEANFILE , label = 'VISMEAN_FILE:' , default = 'MODISVISmean.dat' , RC=STATUS ) ; VERIFY_(STATUS) - call MAPL_GetResource(MAPL,VISSTDFILE , label = 'VISSTD_FILE:' , default = 'MODISVISstd.dat' , RC=STATUS ) ; VERIFY_(STATUS) - call MAPL_GetResource(MAPL,NIRMEANFILE , label = 'NIRMEAN_FILE:' , default = 'MODISNIRmean.dat' , RC=STATUS ) ; VERIFY_(STATUS) - call MAPL_GetResource(MAPL,NIRSTDFILE , label = 'NIRSTD_FILE:' , default = 'MODISNIRstd.dat' , RC=STATUS ) ; VERIFY_(STATUS) - - call MAPL_GetResource(MAPL,FPARMEANFILE , label = 'MODELFPARMEAN_FILE:', default = 'MODELFPARmean.dat' , RC=STATUS ) ; VERIFY_(STATUS) - call MAPL_GetResource(MAPL,FPARSTDFILE , label = 'MODELFPARSTD_FILE:' , default = 'MODELFPARstd.dat' , RC=STATUS ) ; VERIFY_(STATUS) - - call MAPL_ReadForcing(MAPL,'MODISVISmean' ,VISMEANFILE ,CURRENT_TIME,MODISVISmean ,ON_TILES=.true.,RC=STATUS) ; VERIFY_(STATUS) - call MAPL_ReadForcing(MAPL,'MODISVISstd' ,VISSTDFILE ,CURRENT_TIME,MODISVISstd ,ON_TILES=.true.,RC=STATUS) ; VERIFY_(STATUS) - call MAPL_ReadForcing(MAPL,'MODISNIRmean' ,NIRMEANFILE ,CURRENT_TIME,MODISNIRmean ,ON_TILES=.true.,RC=STATUS) ; VERIFY_(STATUS) - call MAPL_ReadForcing(MAPL,'MODISNIRstd' ,NIRSTDFILE ,CURRENT_TIME,MODISNIRstd ,ON_TILES=.true.,RC=STATUS) ; VERIFY_(STATUS) - call MAPL_ReadForcing(MAPL,'MODELFPARmean',FPARMEANFILE,CURRENT_TIME,MODELFPARmean ,ON_TILES=.true.,RC=STATUS) ; VERIFY_(STATUS) - call MAPL_ReadForcing(MAPL,'MODELFPARstd' ,FPARSTDFILE ,CURRENT_TIME,MODELFPARstd ,ON_TILES=.true.,RC=STATUS) ; VERIFY_(STATUS) - - do n = 1,NTILES - ThisFPAR = (unscaled_fpar(n,1)*FVG(N,1) + unscaled_fpar(n,2)*FVG(N,2))/(FVG(N,1) + FVG(N,2) + 1.e-20) - ZFPAR = (ThisFPAR - MODELFPARmean (n)) / MODELFPARstd (n) - ALBVF(n) = AMIN1 (1., AMAX1(0.001,ZFPAR * MODISVISstd(n) + MODISVISmean (n))) - ALBNF(n) = AMIN1 (1., AMAX1(0.001,ZFPAR * MODISNIRstd(n) + MODISNIRmean (n))) - end do - endif - endif call STIEGLITZSNOW_CALC_TPSNOW(NTILES, HTSNNN(1,:), WESNN(1,:), TPSN1OUT1, FICE1) TPSN1OUT1 = TPSN1OUT1 + Tzero @@ -6990,16 +6662,6 @@ subroutine Driver ( RC ) BGALBVR, BGALBVF, BGALBNR, BGALBNF, & ! gkw: MODIS soil background albedo ALBVR_tmp, ALBNR_tmp, ALBVF_tmp, ALBNF_tmp, MODIS_SCALE=.TRUE. ) ! instantaneous snow-free albedos on tiles - if ((SCALE_ALBFPAR == 1).OR.(SCALE_ALBFPAR == 3)) then - if(ntiles > 0) then - do n = 1,NTILES - ThisFPAR = (unscaled_fpar(n,3)*FVG(N,3) + unscaled_fpar(n,4)*FVG(N,4))/(FVG(N,3) + FVG(N,4) + 1.e-20) - ZFPAR = (ThisFPAR - MODELFPARmean (n)) / MODELFPARstd (n) - ALBVF_tmp(n) = AMIN1 (1., AMAX1(0.001,ZFPAR * MODISVISstd(n) + MODISVISmean (n))) - ALBNF_tmp(n) = AMIN1 (1., AMAX1(0.001,ZFPAR * MODISNIRstd(n) + MODISNIRmean (n))) - end do - endif - endif call SNOW_ALBEDO(NTILES,N_snow, N_CONST_LAND4SNWALB, VEG2, LAI2, ZTH, & RHOFS, & @@ -7643,13 +7305,6 @@ 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 - if ((SCALE_ALBFPAR == 1).OR.(SCALE_ALBFPAR == 3)) then - do n = 1,NTILES - ThisFPAR = (unscaled_fpar(n,1)*FVG(N,1) + unscaled_fpar(n,2)*FVG(N,2))/(FVG(N,1) + FVG(N,2) + 1.e-20) - ZFPAR = (ThisFPAR - MODELFPARmean (n)) / MODELFPARstd (n) - ALBVF(n) = AMIN1 (1., AMAX1(0.001,ZFPAR * MODISVISstd(n) + MODISVISmean (n))) - end do - endif call STIEGLITZSNOW_CALC_TPSNOW(NTILES, HTSNNN(1,:), WESNN(1,:), TPSN1OUT1, FICE1) TPSN1OUT1 = TPSN1OUT1 + Tzero @@ -7666,17 +7321,6 @@ subroutine Driver ( RC ) BGALBVR, BGALBVF, BGALBNR, BGALBNF, & ! gkw: MODIS soil background albedo ALBVR_tmp, ALBNR_tmp, ALBVF_tmp, ALBNF_tmp, MODIS_SCALE=.TRUE. ) ! instantaneous snow-free albedos on tiles - if ((SCALE_ALBFPAR == 1).OR.(SCALE_ALBFPAR == 3)) then - if(ntiles > 0) then - do n = 1,NTILES - ThisFPAR = (unscaled_fpar(n,3)*FVG(N,3) + unscaled_fpar(n,4)*FVG(N,4))/(FVG(N,3) + FVG(N,4) + 1.e-20) - ZFPAR = (ThisFPAR - MODELFPARmean (n)) / MODELFPARstd (n) - ALBVF_tmp(n) = AMIN1 (1., AMAX1(0.001,ZFPAR * MODISVISstd(n) + MODISVISmean (n))) - ALBNF_tmp(n) = AMIN1 (1., AMAX1(0.001,ZFPAR * MODISNIRstd(n) + MODISNIRmean (n))) - end do - endif - if(allocated (MODISVISmean)) deallocate (MODISVISmean, MODISVISstd, MODISNIRmean, MODISNIRstd, MODELFPARmean, MODELFPARstd) - endif call SNOW_ALBEDO(NTILES,N_snow, N_CONST_LAND4SNWALB, VEG2, LAI2, ZTH, & RHOFS, & @@ -7806,9 +7450,16 @@ subroutine Driver ( RC ) if(associated(RMELTBC002)) RMELTBC002 = RMELT(:,7) if(associated(RMELTOC001)) RMELTOC001 = RMELT(:,8) if(associated(RMELTOC002)) RMELTOC002 = RMELT(:,9) - if(associated(FSWCHANGE)) FSWCHANGE = FSW_CHANGE - if(associated(WATERTABLED)) then - WATERTABLED = catch_calc_watertabled( BF1, BF2, CDCR2, POROS, WPWET, CATDEF ) + if(associated(PEATCLSM_FSWCHANGE)) then + where (POROS >= PEATCLSM_POROS_THRESHOLD) + PEATCLSM_FSWCHANGE = FSW_CHANGE + elsewhere + PEATCLSM_FSWCHANGE = MAPL_UNDEF + end where + end if + + if(associated(PEATCLSM_WATERLEVEL)) then + PEATCLSM_WATERLEVEL = catch_calc_peatclsm_waterlevel( BF1, BF2, CDCR2, POROS, WPWET, CATDEF ) endif if(associated(TPSN1OUT)) then @@ -8023,11 +7674,7 @@ subroutine Driver ( RC ) deallocate( car1 ) deallocate( car2 ) deallocate( car4 ) - deallocate( parzone ) deallocate( para ) - deallocate( parav ) - deallocate(scaled_fpar) - deallocate(UNscaled_fpar) deallocate( totwat ) deallocate( dayl ) deallocate(dayl_fac ) @@ -8042,6 +7689,7 @@ subroutine Driver ( RC ) deallocate( psnsunx ) deallocate( psnshax ) deallocate( sifsunx ) + deallocate( parzone ) deallocate( sifshax ) deallocate( laisunx ) deallocate( laishax ) @@ -8070,128 +7718,109 @@ subroutine Driver ( RC ) end subroutine Driver - ! ----------------- routines for CDF scaling ------------------- - - REAL FUNCTION cdf2fpar (cdf, k,l, m, m1, m2) - - REAL, intent (in) :: cdf, k,l,m, m1, m2 - REAL :: x, ThisCDF, ThisFPAR - integer, parameter :: nBINS = 40 - - x = real (nBINS) - ThisCDF = 1. - - do while (ThisCDF >= cdf) - ThisFPAR = 1. - (real(nbins)-x)/real(nbins) - 1./2./real(nbins) - ThisCDF = K * betai (L, M, ThisFPAR) - x = x - 1. - if(x == 0) exit - end do - - cdf2fpar = ThisFPAR * m2 + m1 - if(cdf2fpar > m2) cdf2fpar = m2 - if(cdf2fpar < m1) cdf2fpar = m1 - return - - END FUNCTION cdf2fpar - - ! --------------------------------------------------------- - - FUNCTION betai(a,b,x) - REAL betai,a,b,x - REAL bt - !external gammln - - if (x < 0.0125) x = 0.0125 - if (x > 0.9875) x = 0.9875 - - if(x.lt.0..or.x.gt.1.)print *, 'bad argument x in betai',x - if(x.lt.0..or.x.gt.1.)stop - if(x.eq.0..or.x.eq.1.)then - bt=0. - else - bt=exp(gammln(a+b)-gammln(a)-gammln(b) & - +a*log(x)+b*log(1.-x)) - endif - - if(x.lt.(a+1.)/(a+b+2.))then - betai=bt*betacf(a,b,x)/a - return - else - betai=1.-bt*betacf(b,a,1.-x)/b - return - endif - - END FUNCTION betai - - ! ------------------------------------------------------- - - FUNCTION betacf(a,b,x) - INTEGER MAXIT - REAL betacf,a,b,x,EPS,FPMIN - PARAMETER (MAXIT=100,EPS=3.e-7,FPMIN=1.e-30) - INTEGER m,m2 - REAL aa,c,d,del,h,qab,qam,qap - - qab=a+b - qap=a+1. - qam=a-1. - c=1. - d=1.-qab*x/qap - - if(abs(d).lt.FPMIN)d=FPMIN - d=1./d - h=d - do m=1,MAXIT - m2=2*m - aa=m*(b-m)*x/((qam+m2)*(a+m2)) - d=1.+aa*d - if(abs(d).lt.FPMIN)d=FPMIN - c=1.+aa/c - if(abs(c).lt.FPMIN)c=FPMIN - d=1./d - h=h*d*c - aa=-(a+m)*(qab+m)*x/((a+m2)*(qap+m2)) - d=1.+aa*d - if(abs(d).lt.FPMIN)d=FPMIN - c=1.+aa/c - if(abs(c).lt.FPMIN)c=FPMIN - d=1./d - del=d*c - h=h*del - if(abs(del-1.).lt.EPS)exit - enddo - betacf=h - return - - END FUNCTION betacf - - ! -------------------------------------------------------------- +! Commented out functions betai(), betacf(), and gammln(). +! These functions are not used and were reproduced identically in +! GEOS_CatchCNCLM40GridComp.F90 and in GEOS_CatchCNCLM45GridComp.F90. +! Another copy was in GEOScatchCN_GridComp/utils/math_routines.F90 but +! there function betai() was missing the restriction 0.0125 0.9875) x = 0.9875 +!! +!! if(x.lt.0..or.x.gt.1.)print *, 'bad argument x in betai',x +!! if(x.lt.0..or.x.gt.1.)stop +!! if(x.eq.0..or.x.eq.1.)then +!! bt=0. +!! else +!! bt=exp(gammln(a+b)-gammln(a)-gammln(b) & +!! +a*log(x)+b*log(1.-x)) +!! endif +!! +!! if(x.lt.(a+1.)/(a+b+2.))then +!! betai=bt*betacf(a,b,x)/a +!! return +!! else +!! betai=1.-bt*betacf(b,a,1.-x)/b +!! return +!! endif +!! +!! END FUNCTION betai +!! +!! ! ------------------------------------------------------- +!! +!! FUNCTION betacf(a,b,x) +!! +!! INTEGER MAXIT +!! REAL betacf,a,b,x,EPS,FPMIN +!! PARAMETER (MAXIT=100,EPS=3.e-7,FPMIN=1.e-30) +!! INTEGER m,m2 +!! REAL aa,c,d,del,h,qab,qam,qap +!! +!! qab=a+b +!! qap=a+1. +!! qam=a-1. +!! c=1. +!! d=1.-qab*x/qap +!! +!! if(abs(d).lt.FPMIN)d=FPMIN +!! d=1./d +!! h=d +!! do m=1,MAXIT +!! m2=2*m +!! aa=m*(b-m)*x/((qam+m2)*(a+m2)) +!! d=1.+aa*d +!! if(abs(d).lt.FPMIN)d=FPMIN +!! c=1.+aa/c +!! if(abs(c).lt.FPMIN)c=FPMIN +!! d=1./d +!! h=h*d*c +!! aa=-(a+m)*(qab+m)*x/((a+m2)*(qap+m2)) +!! d=1.+aa*d +!! if(abs(d).lt.FPMIN)d=FPMIN +!! c=1.+aa/c +!! if(abs(c).lt.FPMIN)c=FPMIN +!! d=1./d +!! del=d*c +!! h=h*del +!! if(abs(del-1.).lt.EPS)exit +!! enddo +!! betacf=h +!! return +!! +!! END FUNCTION betacf +!! +!! ! -------------------------------------------------------------- +!! +!! FUNCTION gammln(xx) +!! +!! REAL gammln,xx +!! INTEGER j +!! DOUBLE PRECISION ser,stp,tmp,x,y,cof(6) +!! +!! SAVE cof,stp +!! DATA cof,stp/76.18009172947146d0,-86.50532032941677d0, & +!! 24.01409824083091d0,-1.231739572450155d0,.1208650973866179d-2, & +!! -.5395239384953d-5,2.5066282746310005d0/ +!! x=xx +!! y=x +!! tmp=x+5.5d0 +!! tmp=(x+0.5d0)*log(tmp)-tmp +!! ser=1.000000000190015d0 +!! do j=1,6 +!! y=y+1.d0 +!! ser=ser+cof(j)/y +!! enddo +!! gammln=tmp+log(stp*ser/x) +!! return +!! +!! END FUNCTION gammln ! -------------------------------------------------------------- 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 5caaa0425..b6f73f83b 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 @@ -51,7 +51,8 @@ module GEOS_CatchCNCLM45GridCompMod RHOFS => CATCH_SNWALB_RHOFS, & SNWALB_VISMAX => CATCH_SNWALB_VISMAX, & SNWALB_NIRMAX => CATCH_SNWALB_NIRMAX, & - SLOPE => CATCH_SNWALB_SLOPE + SLOPE => CATCH_SNWALB_SLOPE, & + PEATCLSM_POROS_THRESHOLD USE clm_varpar, ONLY : & NUM_ZON, NUM_VEG, VAR_COL, VAR_PFT, & @@ -61,8 +62,8 @@ module GEOS_CatchCNCLM45GridCompMod use MAPL_ConstantsMod,only: Tzero => MAPL_TICE, pi => MAPL_PI use clm_time_manager, only: get_days_per_year, get_step_size use pftvarcon, only: noveg - USE lsm_routines, ONLY : sibalb, catch_calc_soil_moist, & - catch_calc_zbar, catch_calc_watertabled, irrigation_rate, & + USE lsm_routines, ONLY : sibalb, catch_calc_soil_moist, & + catch_calc_zbar, catch_calc_peatclsm_waterlevel, irrigation_rate, & gndtmp use update_model_para4cn, only : upd_curr_date_time @@ -174,7 +175,7 @@ module GEOS_CatchCNCLM45GridCompMod end type OFFLINE_WRAP integer :: RUN_IRRIG, USE_ASCATZ0, Z0_FORMULATION, IRRIG_METHOD, AEROSOL_DEPOSITION, N_CONST_LAND4SNWALB -integer :: ATM_CO2, SCALE_ALBFPAR,CHOOSEMOSFC +integer :: ATM_CO2, CHOOSEMOSFC real :: SURFLAY ! Default (Ganymed-3 and earlier) SURFLAY=20.0 for Old Soil Params ! (Ganymed-4 and later ) SURFLAY=50.0 for New Soil Params real :: CO2 @@ -291,12 +292,6 @@ subroutine SetServices ( GC, RC ) ! 4: import AGCM model CO2 (AGCM only) call MAPL_GetResource (SCF, ATM_CO2, label='ATM_CO2:', DEFAULT=2 , __RC__ ) - ! SCALE_ALBFPAR: Scale CATCHCN ALBEDO and FPAR - ! 0-- NO scaling is performed - ! 1-- Scale albedo to match interannually varying MODIS NIRDF and VISDF anomaly - ! 2-- Scale albedo to match CDFs of model fPAR to MODIS CDFs of fPAR - ! 3-- Pefform above both 1 and 2 scalings - call MAPL_GetResource (SCF, SCALE_ALBFPAR, label='SCALE_ALBFPAR:', DEFAULT=0 , __RC__ ) ! Global mean CO2 call MAPL_GetResource (SCF, CO2, label='CO2:', DEFAULT=350.e-6, __RC__ ) @@ -3675,9 +3670,9 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'depth_to_water_table_from_surface',& + LONG_NAME = 'depth_to_water_table_from_surface_in_peat',& UNITS = 'm' ,& - SHORT_NAME = 'WATERTABLED' ,& + SHORT_NAME = 'PEATCLSM_WATERLEVEL' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& RC=STATUS ) @@ -3686,7 +3681,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC ,& LONG_NAME = 'change_in_free_surface_water_reservoir_on_peat',& UNITS = 'kg m-2 s-1' ,& - SHORT_NAME = 'FSWCHANGE' ,& + SHORT_NAME = 'PEATCLSM_FSWCHANGE' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& RC=STATUS ) @@ -4453,7 +4448,6 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) type(MAPL_MetaComp),pointer :: MAPL type(ESMF_Alarm) :: ALARM - integer :: IM,JM integer :: incl_Louis_extra_derivs @@ -4859,8 +4853,8 @@ subroutine Driver ( RC ) real, pointer, dimension(:) :: RMELTOC001 real, pointer, dimension(:) :: RMELTOC002 real, pointer, dimension(:) :: IRRIGRATE - real, pointer, dimension(:) :: WATERTABLED - real, pointer, dimension(:) :: FSWCHANGE + real, pointer, dimension(:) :: PEATCLSM_WATERLEVEL + real, pointer, dimension(:) :: PEATCLSM_FSWCHANGE ! -------------------------------------------------------------------------- ! Local pointers for tile variables @@ -5155,24 +5149,9 @@ subroutine Driver ( RC ) real, allocatable, dimension(:) :: ALBVR_tmp, ALBNR_tmp, ALBVF_tmp, ALBNF_tmp real, allocatable, dimension(:) :: SNOVR_tmp, SNONR_tmp, SNOVF_tmp, SNONF_tmp - ! Variables for FPAR scaling - ! -------------------------- - - real, save,allocatable,dimension (:,:,:,:) :: Kappa, Lambda, Mu - real, save,allocatable,dimension (:,:,:) :: MnVal, MxVal - integer, save, allocatable, dimension (:) :: modis_tid, ThisMIndex - integer :: n_modis, NTCurrent, CDFfile, infos, comms - integer, allocatable, dimension (:,:) :: modis_index - integer, allocatable, dimension (:) :: modis2cat - real , allocatable, dimension (:) :: m_lons, m_lats - real , allocatable, dimension (:,:) :: scaled_fpar, parav, parzone, unscaled_fpar - REAL , PARAMETER :: TILEINT = 2. - integer, PARAMETER :: NOCTAD = 46, NSETS = 2 - real :: CLM4_fpar, CLM4_cdf, MODIS_fpar, tmparr(1,1,1,2), & - ThisK, ThisL, ThisM, ThisMin, ThisMax, tmparr2(1,1,1), ThisFPAR, ZFPAR - character (len=ESMF_MAXSTR) :: VISMEANFILE, VISSTDFILE, NIRMEANFILE, NIRSTDFILE, FPARMEANFILE, FPARSTDFILE - real, allocatable, dimension (:) :: MODISVISmean, MODISVISstd, MODISNIRmean, MODISNIRstd, MODELFPARmean, MODELFPARstd - logical, save :: first_fpar = .true. + ! Variables for FPAR + ! -------------------------- + real , allocatable, dimension (:,:) :: parzone IAm=trim(COMP_NAME)//"::RUN2::Driver" @@ -5560,8 +5539,8 @@ subroutine Driver ( RC ) call MAPL_GetPointer(EXPORT,RMELTBC002 ,'RMELTBC002' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT,RMELTOC001 ,'RMELTOC001' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT,RMELTOC002 ,'RMELTOC002' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT,WATERTABLED ,'WATERTABLED' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT,FSWCHANGE ,'FSWCHANGE' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,PEATCLSM_WATERLEVEL,'PEATCLSM_WATERLEVEL' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,PEATCLSM_FSWCHANGE ,'PEATCLSM_FSWCHANGE' , RC=STATUS); VERIFY_(STATUS) IF (RUN_IRRIG /= 0) call MAPL_GetPointer(EXPORT,IRRIGRATE ,'IRRIGRATE' , RC=STATUS); VERIFY_(STATUS) @@ -5699,123 +5678,6 @@ subroutine Driver ( RC ) ENDIF READ_CT_CO2 ENDIF - ! OPTIONAL FPAR SCALING -! --------------------- - - if (SCALE_ALBFPAR >= 2) then - IF (ntiles > 0) THEN - INTILALIZE_FPAR_PARAM : if(first_fpar) then - - ! Initialize FPAR MODIS scale parameters - ! -------------------------------------- - -! CALL ESMF_VMGet(vm, MPICOMMUNICATOR=comms, rc=status) -! VERIFY_(status) -! call MPI_Info_create(infos, STATUS) -! call MPI_Info_set(infos, "romio_cb_read", "automatic", STATUS) - - STATUS = NF_OPEN ('FPAR_CDF_Params-M09.nc4', NF_NOWRITE, CDFfile) - STATUS = NF_INQ_DIMID (CDFfile, 'tile10D', k); VERIFY_(STATUS) - STATUS = NF_INQ_DIMLEN (CDFfile, K, n_modis) ; VERIFY_(STATUS) - - allocate (m_lons (1 : n_modis)) - allocate (m_lats (1 : n_modis)) - - STATUS = NF_GET_VARA_REAL (CDFfile, VarID(CDFfile,'lon'), (/1/), (/n_modis/), m_lons);VERIFY_(STATUS) - STATUS = NF_GET_VARA_REAL (CDFfile, VarID(CDFfile,'lat'), (/1/), (/n_modis/), m_lats);VERIFY_(STATUS) - - allocate (modis_index (1: 360/nint(TILEINT), 1: 180/nint(TILEINT))) - modis_index = -9999 - - ! vector to grid 10x10 MODIS tiles - - do i = 1, n_modis - - k = NINT (((m_lons(i) + TILEINT/2.) + 180.) / TILEINT) - n = NINT (((m_lats(i) + TILEINT/2.) + 90.) / TILEINT) - modis_index (k, n) = i - - end do - - ! for each catchment-tile overlying MODIS 10x10 tile - - allocate (modis2cat (1: NTILES)) - allocate (modis_tid (1: NTILES)) - - modis_tid = -9999 - modis2cat = 0 - - do i = 1, NTILES - - k = NINT ((CEILING (lons(i)*90./MAPL_PI)*2 + 180.) / TILEINT) - n = NINT ((CEILING (lats(i)*90./MAPL_PI)*2 + 90.) / TILEINT) - if(k <= 3) k = 3 - if(k >= 178) k = 178 - modis2cat (i) = modis_index (k,n) - - end do - - K = count(modis2cat > 0) - - allocate (unq_mask(1:K )) - allocate (loc_int (1:K )) - - loc_int = pack(modis2cat ,mask = (modis2cat > 0)) - call MAPL_Sort (loc_int) - unq_mask = .true. - - do i = 2,K - unq_mask(i) = .not.(loc_int(i) == loc_int(i-1)) - end do - - NUNQ = count(unq_mask) - - allocate (ThisIndex (1:NUNQ)) - ThisIndex = pack(loc_int, mask = unq_mask ) - - allocate (Kappa (1: NUNQ, 1: NUMPFT, 1 : NOCTAD, 1 : 2)) - allocate (Lambda(1: NUNQ, 1: NUMPFT, 1 : NOCTAD, 1 : 2)) - allocate (Mu (1: NUNQ, 1: NUMPFT, 1 : NOCTAD, 1 : 2)) - allocate (MnVal (1: NUNQ, 1: NUMPFT, 1 : NOCTAD)) - allocate (MxVal (1: NUNQ, 1: NUMPFT, 1 : NOCTAD)) - - Kappa = -9999. - Lambda = -9999. - Mu = -9999. - - do i = 1, NUNQ - - where (modis2cat == ThisIndex(i)) modis_tid = i - - end do - - do i = 1, NUNQ - do K = 1,NOCTAD - do n = 1, NUMPFT - IF (ThisIndex(i) >= 1) THEN - STATUS = NF_GET_VARA_REAL(CDFFile, VARID(CDFFile,'Kappa' ),(/ThisIndex(i),N,K,1/), (/1,1,1,2/), tmparr);VERIFY_(STATUS) - Kappa (i,N,K,:) = tmparr (1,1,1,:) - STATUS = NF_GET_VARA_REAL(CDFFile, VARID(CDFFile,'Lambda'),(/ThisIndex(i),N,K,1/), (/1,1,1,2/), tmparr);VERIFY_(STATUS) - Lambda(i,N,K,:) = tmparr (1,1,1,:) - STATUS = NF_GET_VARA_REAL(CDFFile, VARID(CDFFile,'Mu' ),(/ThisIndex(i),N,K,1/), (/1,1,1,2/), tmparr);VERIFY_(STATUS) - Mu (i,N,K,:) = tmparr (1,1,1,:) - STATUS = NF_GET_VARA_REAL(CDFFile, VARID(CDFFile,'MinVal'),(/ThisIndex(i),N,K/), (/1,1,1/), tmparr2);VERIFY_(STATUS) - MnVal(i,N,K) = tmparr2 (1,1,1) - STATUS = NF_GET_VARA_REAL(CDFFile, VARID(CDFFile,'MaxVal'),(/ThisIndex(i),N,K/), (/1,1,1/), tmparr2);VERIFY_(STATUS) - MxVal(i,N,K) = tmparr2 (1,1,1) - ENDIF - end do - end do - end do - status = NF_CLOSE (CDFFile) - - deallocate ( modis2cat, unq_mask, loc_int, modis_index, m_lons, m_lats) - - first_fpar = .false. - - endif INTILALIZE_FPAR_PARAM - endif - end if ! -------------------------------------------------------------------------- ! ALLOCATE LOCAL POINTERS @@ -6354,11 +6216,7 @@ subroutine Driver ( RC ) allocate( car1(ntiles) ) allocate( car2(ntiles) ) allocate( car4(ntiles) ) - allocate( parzone(ntiles,nveg) ) allocate( para(ntiles) ) - allocate( parav(ntiles,nveg) ) - allocate (scaled_fpar (NTILES,NVEG)) - allocate (unscaled_fpar(NTILES,NVEG)) allocate ( totwat(ntiles) ) if(.not. allocated(npp )) allocate( npp(ntiles) ) if(.not. allocated(gpp )) allocate( gpp(ntiles) ) @@ -6427,6 +6285,7 @@ subroutine Driver ( RC ) allocate( psnsunx(ntiles,nveg) ) allocate( psnshax(ntiles,nveg) ) allocate( sifsunx(ntiles,nveg) ) + allocate( parzone(ntiles,nveg) ) allocate( sifshax(ntiles,nveg) ) allocate( laisunx(ntiles,nveg) ) allocate( laishax(ntiles,nveg) ) @@ -6767,8 +6626,6 @@ subroutine Driver ( RC ) end do para(:) = 0. ! zero out absorbed PAR summing array - parav(:, :) = 0. ! - scaled_fpar = 1. do nz = 1,nzone @@ -6904,8 +6761,8 @@ subroutine Driver ( RC ) do nv = 1,nveg para(:) = para(:) + parzone(:,nv)*wtzone(:,nz)*fvez(:,nv) - parav(:,nv) = parav (:,nv) + parzone(:,nv)*wtzone(:,nz) end do + if(associated(BTRANT)) btrant(:) = btrant(:) + btran(:)*wtzone(:,nz) ! NOTE: btran here doesn't reflect the modification to btran for soybean (and nbrdlf_dcd_tmp_shrub if CNDV is on) in subroutine Photosynthesis. if(associated(SIF)) then do nv = 1,nveg @@ -6915,159 +6772,6 @@ subroutine Driver ( RC ) end do - do nv = 1,nveg - unscaled_fpar (:,nv) = parav (:,nv)/ (DRPAR(:) + DFPAR(:) + 1.e-20) - end do - - NTCurrent = CEILING (real (dofyr) / 8.) - - ! FPAR scaling to match MODIS CDF - ! ------------------------------- - - DO_FS1 : if (SCALE_ALBFPAR >= 2) then - - IF (ntiles > 0) THEN - - NT_LOOP1 : do n = 1,NTILES - - NV_LOOP1 : do nv = 1,nveg - - CLM4_fpar = parav (n,nv) / (DRPAR (n) + DFPAR (n) + 1.e-20) - K = -1 - - if(CLM4_fpar > 0.) then - - k = NINT(ITY(N,nv)) - if(minval(Kappa (modis_tid (n), k, NTCurrent, :)) < 0.) then - k = -1 - if(nv == 1) k = NINT(ITY(N,2)) - if(nv == 2) k = NINT(ITY(N,1)) - if(nv == 3) k = NINT(ITY(N,4)) - if(nv == 4) k = NINT(ITY(N,3)) - if(minval(Kappa (modis_tid (n), k, NTCurrent, :)) < 0.) k = -1 - if((K == -1).and.(nv > 2)) then - if(minval(Kappa (modis_tid (n), NINT(ITY(N,2)), NTCurrent, :)) > 0.) k = NINT(ITY(N,2)) - if(minval(Kappa (modis_tid (n), NINT(ITY(N,1)), NTCurrent, :)) > 0.) k = NINT(ITY(N,1)) - endif - endif - - endif - - if((K > 0).and.(CLM4_fpar > 0)) then - - ! Computing probability of CLM4 FPAR - - ThisK = Kappa (modis_tid (n), k, NTCurrent, 2) - ThisL = Lambda (modis_tid (n), k, NTCurrent, 2) - ThisM = Mu (modis_tid (n), k, NTCurrent, 2) - ThisMin = MnVal (modis_tid (n), k, NTCurrent) - ThisMax = MxVal (modis_tid (n), k, NTCurrent) - - if (CLM4_fpar < ThisMin) CLM4_fpar = ThisMin - if (CLM4_fpar > ThisMax) CLM4_fpar = ThisMax - if((ThisL == 0.).or.(ThisM == 0.)) print *,thisK,ThisL, ThisM, CLM4_fpar, ThisMin, ThisMax - if((ThisL == 0.).or.(ThisM == 0.)) print *,n,k,NTCurrent,modis_tid (n) - CLM4_cdf = ThisK * betai (ThisL, ThisM, (CLM4_fpar - ThisMin)/ThisMax) - - ! Computing corresponding MODIS FPAR for the same probability - - ThisK = Kappa (modis_tid (n), k, NTCurrent, 1) - ThisL = Lambda (modis_tid (n), k, NTCurrent, 1) - ThisM = Mu (modis_tid (n), k, NTCurrent, 1) - ThisMin = MnVal (modis_tid (n), k, NTCurrent) - ThisMax = MxVal (modis_tid (n), k, NTCurrent) - - scaled_fpar (n,nv) = cdf2fpar (CLM4_cdf, ThisK, ThisL, ThisM, ThisMin, ThisMax) - if((scaled_fpar (n,nv) > 1.).or.(scaled_fpar (n,nv) < 0.)) then - print *, 'PROB 1', CLM4_cdf, ThisK, ThisL, ThisM, ThisMin, ThisMax, scaled_fpar (n,nv) - endif - - scaled_fpar (n,nv) = scaled_fpar (n,nv) / (CLM4_fpar + 1.e-20) - - endif - end do NV_LOOP1 - - end do NT_LOOP1 - - para (:) = 0. ! zero out absorbed PAR summing array - parav = 0. - - if(associated(BTRANT)) btrant = 0. - if(associated(SIF)) sif = 0. - - do nz = 1,num_zon - - if(nz == 1) then - btran = btran1 - tcx = tx1 - qax = qx1 - endif - - if(nz == 2) then - btran = btran2 - tcx = tx2 - qax = qx2 - endif - - if(nz == 3) then - btran = btran3 - tcx = tx3 - qax = qx3 - endif - - do nv = 1,num_veg - elaz(:,nv) = elai(:,nv,nz) - esaz(:,nv) = esai(:,nv,nz) - ityz(:,nv) = ityp(:,nv,nz) - fvez(:,nv) = fveg(:,nv,nz) - end do - - do n = 1,NTILES - if(tp1(n) < (Tzero-0.01)) btran(n) = 0. ! no photosynthesis if ground fully frozen - end do - - call compute_rc(NTILES,nveg,TCx,QAx,T2M10D, & - TA, PS, ZTH,DRPAR,DFPAR,albdir,albdif, & - elaz,esaz,ityz,fvez,btran,fwet, & - RCx,RCxDT,RCxDQ,psnsunx,psnshax,laisunx,laishax, & - dayl_fac,co2v,dtc,dea,parzone,sifsunx,sifshax, & - lmrsunx,lmrshax,fpar_sf = scaled_fpar ) - - rc00(:,nz) = rcx(:) - rcdt(:,nz) = rcxdt(:) - rcdq(:,nz) = rcxdq(:) - - psnsun(:,:,nz) = psnsunx(:,:) - psnsha(:,:,nz) = psnshax(:,:) - laisun(:,:,nz) = laisunx(:,:) - laisha(:,:,nz) = laishax(:,:) - lmrsun(:,:,nz) = lmrsunx(:,:) - lmrsha(:,:,nz) = lmrshax(:,:) - - do nv = 1,nveg - para(:) = para(:) + parzone(:,nv)*wtzone(:,nz)*fvez(:,nv) - parav(:,nv) = parav (:,nv) + parzone(:,nv)*wtzone(:,nz) - end do - - if(associated(BTRANT)) btrant(:) = btrant(:) + btran(:)*wtzone(:,nz) - if(associated(SIF)) then - do nv = 1,nveg - sif(:) = sif(:) + wtzone(:,nz)*fvez(:,nv)*(sifsunx(:,nv)*laisunx(:,nv) + sifshax(:,nv)*laishax(:,nv)) - end do - endif - - end do - - endif - - endif DO_FS1 - - ! Below we are recycling the scaled_fpar array - from this point, it contains fpar scaled or otherwise - ! ---------------------------------------------------------------------------------------------------- - - do nv = 1,nveg - scaled_fpar (:,nv) = parav (:,nv)/ (DRPAR(:) + DFPAR(:) + 1.e-20) - end do if(associated(CNCO2)) CNCO2 = CO2V * 1e6 deallocate (co2v) @@ -7092,40 +6796,6 @@ 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 - if ((SCALE_ALBFPAR == 1).OR.(SCALE_ALBFPAR == 3)) then - - if(.not.allocated (MODISVISmean )) allocate (MODISVISmean (1:NTILES)) - if(.not.allocated (MODISVISstd )) allocate (MODISVISstd (1:NTILES)) - if(.not.allocated (MODISNIRmean )) allocate (MODISNIRmean (1:NTILES)) - if(.not.allocated (MODISNIRstd )) allocate (MODISNIRstd (1:NTILES)) - if(.not.allocated (MODELFPARmean)) allocate (MODELFPARmean (1:NTILES)) - if(.not.allocated (MODELFPARstd )) allocate (MODELFPARstd (1:NTILES)) - - if(ntiles > 0) then - - call MAPL_GetResource(MAPL,VISMEANFILE , label = 'VISMEAN_FILE:' , default = 'MODISVISmean.dat' , RC=STATUS ) ; VERIFY_(STATUS) - call MAPL_GetResource(MAPL,VISSTDFILE , label = 'VISSTD_FILE:' , default = 'MODISVISstd.dat' , RC=STATUS ) ; VERIFY_(STATUS) - call MAPL_GetResource(MAPL,NIRMEANFILE , label = 'NIRMEAN_FILE:' , default = 'MODISNIRmean.dat' , RC=STATUS ) ; VERIFY_(STATUS) - call MAPL_GetResource(MAPL,NIRSTDFILE , label = 'NIRSTD_FILE:' , default = 'MODISNIRstd.dat' , RC=STATUS ) ; VERIFY_(STATUS) - - call MAPL_GetResource(MAPL,FPARMEANFILE , label = 'MODELFPARMEAN_FILE:', default = 'MODELFPARmean.dat' , RC=STATUS ) ; VERIFY_(STATUS) - call MAPL_GetResource(MAPL,FPARSTDFILE , label = 'MODELFPARSTD_FILE:' , default = 'MODELFPARstd.dat' , RC=STATUS ) ; VERIFY_(STATUS) - - call MAPL_ReadForcing(MAPL,'MODISVISmean' ,VISMEANFILE ,CURRENT_TIME,MODISVISmean ,ON_TILES=.true.,RC=STATUS) ; VERIFY_(STATUS) - call MAPL_ReadForcing(MAPL,'MODISVISstd' ,VISSTDFILE ,CURRENT_TIME,MODISVISstd ,ON_TILES=.true.,RC=STATUS) ; VERIFY_(STATUS) - call MAPL_ReadForcing(MAPL,'MODISNIRmean' ,NIRMEANFILE ,CURRENT_TIME,MODISNIRmean ,ON_TILES=.true.,RC=STATUS) ; VERIFY_(STATUS) - call MAPL_ReadForcing(MAPL,'MODISNIRstd' ,NIRSTDFILE ,CURRENT_TIME,MODISNIRstd ,ON_TILES=.true.,RC=STATUS) ; VERIFY_(STATUS) - call MAPL_ReadForcing(MAPL,'MODELFPARmean',FPARMEANFILE,CURRENT_TIME,MODELFPARmean ,ON_TILES=.true.,RC=STATUS) ; VERIFY_(STATUS) - call MAPL_ReadForcing(MAPL,'MODELFPARstd' ,FPARSTDFILE ,CURRENT_TIME,MODELFPARstd ,ON_TILES=.true.,RC=STATUS) ; VERIFY_(STATUS) - - do n = 1,NTILES - ThisFPAR = (unscaled_fpar(n,1)*FVG(N,1) + unscaled_fpar(n,2)*FVG(N,2))/(FVG(N,1) + FVG(N,2) + 1.e-20) - ZFPAR = (ThisFPAR - MODELFPARmean (n)) / MODELFPARstd (n) - ALBVF(n) = AMIN1 (1., AMAX1(0.001,ZFPAR * MODISVISstd(n) + MODISVISmean (n))) - ALBNF(n) = AMIN1 (1., AMAX1(0.001,ZFPAR * MODISNIRstd(n) + MODISNIRmean (n))) - end do - endif - endif call STIEGLITZSNOW_CALC_TPSNOW(NTILES, HTSNNN(1,:), WESNN(1,:), TPSN1OUT1, FICE1) TPSN1OUT1 = TPSN1OUT1 + Tzero @@ -7142,16 +6812,6 @@ subroutine Driver ( RC ) BGALBVR, BGALBVF, BGALBNR, BGALBNF, & ! gkw: MODIS soil background albedo ALBVR_tmp, ALBNR_tmp, ALBVF_tmp, ALBNF_tmp, MODIS_SCALE=.TRUE. ) ! instantaneous snow-free albedos on tiles - if ((SCALE_ALBFPAR == 1).OR.(SCALE_ALBFPAR == 3)) then - if(ntiles > 0) then - do n = 1,NTILES - ThisFPAR = (unscaled_fpar(n,3)*FVG(N,3) + unscaled_fpar(n,4)*FVG(N,4))/(FVG(N,3) + FVG(N,4) + 1.e-20) - ZFPAR = (ThisFPAR - MODELFPARmean (n)) / MODELFPARstd (n) - ALBVF_tmp(n) = AMIN1 (1., AMAX1(0.001,ZFPAR * MODISVISstd(n) + MODISVISmean (n))) - ALBNF_tmp(n) = AMIN1 (1., AMAX1(0.001,ZFPAR * MODISNIRstd(n) + MODISNIRmean (n))) - end do - endif - endif call SNOW_ALBEDO(NTILES,N_snow, N_CONST_LAND4SNWALB, VEG2, LAI2, ZTH, & RHOFS, & @@ -7896,13 +7556,6 @@ 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 - if ((SCALE_ALBFPAR == 1).OR.(SCALE_ALBFPAR == 3)) then - do n = 1,NTILES - ThisFPAR = (unscaled_fpar(n,1)*FVG(N,1) + unscaled_fpar(n,2)*FVG(N,2))/(FVG(N,1) + FVG(N,2) + 1.e-20) - ZFPAR = (ThisFPAR - MODELFPARmean (n)) / MODELFPARstd (n) - ALBVF(n) = AMIN1 (1., AMAX1(0.001,ZFPAR * MODISVISstd(n) + MODISVISmean (n))) - end do - endif call STIEGLITZSNOW_CALC_TPSNOW(NTILES, HTSNNN(1,:), WESNN(1,:), TPSN1OUT1, FICE1) TPSN1OUT1 = TPSN1OUT1 + Tzero @@ -7919,17 +7572,6 @@ subroutine Driver ( RC ) BGALBVR, BGALBVF, BGALBNR, BGALBNF, & ! gkw: MODIS soil background albedo ALBVR_tmp, ALBNR_tmp, ALBVF_tmp, ALBNF_tmp, MODIS_SCALE=.TRUE. ) ! instantaneous snow-free albedos on tiles - if ((SCALE_ALBFPAR == 1).OR.(SCALE_ALBFPAR == 3)) then - - do n = 1,NTILES - ThisFPAR = (unscaled_fpar(n,3)*FVG(N,3) + unscaled_fpar(n,4)*FVG(N,4))/(FVG(N,3) + FVG(N,4) + 1.e-20) - ZFPAR = (ThisFPAR - MODELFPARmean (n)) / MODELFPARstd (n) - ALBVF_tmp(n) = AMIN1 (1., AMAX1(0.001,ZFPAR * MODISVISstd(n) + MODISVISmean (n))) - ALBNF_tmp(n) = AMIN1 (1., AMAX1(0.001,ZFPAR * MODISNIRstd(n) + MODISNIRmean (n))) - end do - - if(allocated (MODISVISmean)) deallocate (MODISVISmean, MODISVISstd, MODISNIRmean, MODISNIRstd, MODELFPARmean, MODELFPARstd) - endif call SNOW_ALBEDO(NTILES,N_snow, N_CONST_LAND4SNWALB, VEG2, LAI2, ZTH, & RHOFS, & @@ -8061,9 +7703,16 @@ subroutine Driver ( RC ) if(associated(RMELTBC002)) RMELTBC002 = RMELT(:,7) if(associated(RMELTOC001)) RMELTOC001 = RMELT(:,8) if(associated(RMELTOC002)) RMELTOC002 = RMELT(:,9) - if(associated(FSWCHANGE)) FSWCHANGE = FSW_CHANGE - if(associated(WATERTABLED)) then - WATERTABLED = catch_calc_watertabled( BF1, BF2, CDCR2, POROS, WPWET, CATDEF ) + if(associated(PEATCLSM_FSWCHANGE )) then + where (POROS >= PEATCLSM_POROS_THRESHOLD) + PEATCLSM_FSWCHANGE = FSW_CHANGE + elsewhere + PEATCLSM_FSWCHANGE = MAPL_UNDEF + end where + end if + + if(associated(PEATCLSM_WATERLEVEL)) then + PEATCLSM_WATERLEVEL = catch_calc_peatclsm_waterlevel( BF1, BF2, CDCR2, POROS, WPWET, CATDEF ) endif if(associated(TPSN1OUT)) then @@ -8281,11 +7930,7 @@ subroutine Driver ( RC ) deallocate( car1 ) deallocate( car2 ) deallocate( car4 ) - deallocate( parzone ) deallocate( para ) - deallocate( parav ) - deallocate (scaled_fpar) - deallocate (UNscaled_fpar) deallocate( totwat ) deallocate( nfire ) deallocate(som_closs) @@ -8342,6 +7987,7 @@ subroutine Driver ( RC ) deallocate( psnsunx ) deallocate( psnshax ) deallocate( sifsunx ) + deallocate( parzone ) deallocate( sifshax ) deallocate( laisunx ) deallocate( laishax ) @@ -8374,128 +8020,109 @@ subroutine Driver ( RC ) end subroutine Driver - ! ----------------- routines for CDF scaling ------------------- - - REAL FUNCTION cdf2fpar (cdf, k,l, m, m1, m2) - - REAL, intent (in) :: cdf, k,l,m, m1, m2 - REAL :: x, ThisCDF, ThisFPAR - integer, parameter :: nBINS = 40 - - x = real (nBINS) - ThisCDF = 1. - - do while (ThisCDF >= cdf) - ThisFPAR = 1. - (real(nbins)-x)/real(nbins) - 1./2./real(nbins) - ThisCDF = K * betai (L, M, ThisFPAR) - x = x - 1. - if(x == 0) exit - end do - - cdf2fpar = ThisFPAR * m2 + m1 - if(cdf2fpar > m2) cdf2fpar = m2 - if(cdf2fpar < m1) cdf2fpar = m1 - return - - END FUNCTION cdf2fpar - - ! --------------------------------------------------------- - - FUNCTION betai(a,b,x) - REAL betai,a,b,x - REAL bt - !external gammln - - if (x < 0.0125) x = 0.0125 - if (x > 0.9875) x = 0.9875 - - if(x.lt.0..or.x.gt.1.)print *, 'bad argument x in betai',x - if(x.lt.0..or.x.gt.1.)stop - if(x.eq.0..or.x.eq.1.)then - bt=0. - else - bt=exp(gammln(a+b)-gammln(a)-gammln(b) & - +a*log(x)+b*log(1.-x)) - endif - - if(x.lt.(a+1.)/(a+b+2.))then - betai=bt*betacf(a,b,x)/a - return - else - betai=1.-bt*betacf(b,a,1.-x)/b - return - endif - - END FUNCTION betai - - ! ------------------------------------------------------- - - FUNCTION betacf(a,b,x) - - INTEGER MAXIT - REAL betacf,a,b,x,EPS,FPMIN - PARAMETER (MAXIT=100,EPS=3.e-7,FPMIN=1.e-30) - INTEGER m,m2 - REAL aa,c,d,del,h,qab,qam,qap - - qab=a+b - qap=a+1. - qam=a-1. - c=1. - d=1.-qab*x/qap - - if(abs(d).lt.FPMIN)d=FPMIN - d=1./d - h=d - do m=1,MAXIT - m2=2*m - aa=m*(b-m)*x/((qam+m2)*(a+m2)) - d=1.+aa*d - if(abs(d).lt.FPMIN)d=FPMIN - c=1.+aa/c - if(abs(c).lt.FPMIN)c=FPMIN - d=1./d - h=h*d*c - aa=-(a+m)*(qab+m)*x/((a+m2)*(qap+m2)) - d=1.+aa*d - if(abs(d).lt.FPMIN)d=FPMIN - c=1.+aa/c - if(abs(c).lt.FPMIN)c=FPMIN - d=1./d - del=d*c - h=h*del - if(abs(del-1.).lt.EPS)exit - enddo - betacf=h - return - - END FUNCTION betacf - ! -------------------------------------------------------------- +! Commented out functions betai(), betacf(), and gammln(). +! These functions are not used and were reproduced identically in +! GEOS_CatchCNCLM40GridComp.F90 and in GEOS_CatchCNCLM45GridComp.F90. +! Another copy was in GEOScatchCN_GridComp/utils/math_routines.F90 but +! there function betai() was missing the restriction 0.0125 0.9875) x = 0.9875 +!! +!! if(x.lt.0..or.x.gt.1.)print *, 'bad argument x in betai',x +!! if(x.lt.0..or.x.gt.1.)stop +!! if(x.eq.0..or.x.eq.1.)then +!! bt=0. +!! else +!! bt=exp(gammln(a+b)-gammln(a)-gammln(b) & +!! +a*log(x)+b*log(1.-x)) +!! endif +!! +!! if(x.lt.(a+1.)/(a+b+2.))then +!! betai=bt*betacf(a,b,x)/a +!! return +!! else +!! betai=1.-bt*betacf(b,a,1.-x)/b +!! return +!! endif +!! +!! END FUNCTION betai +!! +!! ! ------------------------------------------------------- +!! +!! FUNCTION betacf(a,b,x) +!! +!! INTEGER MAXIT +!! REAL betacf,a,b,x,EPS,FPMIN +!! PARAMETER (MAXIT=100,EPS=3.e-7,FPMIN=1.e-30) +!! INTEGER m,m2 +!! REAL aa,c,d,del,h,qab,qam,qap +!! +!! qab=a+b +!! qap=a+1. +!! qam=a-1. +!! c=1. +!! d=1.-qab*x/qap +!! +!! if(abs(d).lt.FPMIN)d=FPMIN +!! d=1./d +!! h=d +!! do m=1,MAXIT +!! m2=2*m +!! aa=m*(b-m)*x/((qam+m2)*(a+m2)) +!! d=1.+aa*d +!! if(abs(d).lt.FPMIN)d=FPMIN +!! c=1.+aa/c +!! if(abs(c).lt.FPMIN)c=FPMIN +!! d=1./d +!! h=h*d*c +!! aa=-(a+m)*(qab+m)*x/((a+m2)*(qap+m2)) +!! d=1.+aa*d +!! if(abs(d).lt.FPMIN)d=FPMIN +!! c=1.+aa/c +!! if(abs(c).lt.FPMIN)c=FPMIN +!! d=1./d +!! del=d*c +!! h=h*del +!! if(abs(del-1.).lt.EPS)exit +!! enddo +!! betacf=h +!! return +!! +!! END FUNCTION betacf +!! +!! ! -------------------------------------------------------------- +!! +!! FUNCTION gammln(xx) +!! +!! REAL gammln,xx +!! INTEGER j +!! DOUBLE PRECISION ser,stp,tmp,x,y,cof(6) +!! +!! SAVE cof,stp +!! DATA cof,stp/76.18009172947146d0,-86.50532032941677d0, & +!! 24.01409824083091d0,-1.231739572450155d0,.1208650973866179d-2, & +!! -.5395239384953d-5,2.5066282746310005d0/ +!! x=xx +!! y=x +!! tmp=x+5.5d0 +!! tmp=(x+0.5d0)*log(tmp)-tmp +!! ser=1.000000000190015d0 +!! do j=1,6 +!! y=y+1.d0 +!! ser=ser+cof(j)/y +!! enddo +!! gammln=tmp+log(stp*ser/x) +!! return +!! +!! END FUNCTION gammln ! -------------------------------------------------------------- diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/utils/compute_FPAR_CDF_M09.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/utils/compute_FPAR_CDF_M09.F90 deleted file mode 100755 index 2e1314a3d..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/utils/compute_FPAR_CDF_M09.F90 +++ /dev/null @@ -1,801 +0,0 @@ -#include "Raster.h" - -PROGRAM comp_FPAR_CDF - - use math_routines - use MAPL_SortMod - use date_time_util, ONLY: & - date_time_type, augment_date_time - use ieee_arithmetic, only: isnan => ieee_is_nan - IMPLICIT NONE - - INCLUDE 'netcdf.inc' - INCLUDE 'mpif.h' - - integer :: comm_rank, comm_size, error, info, DOY,NCInID,NCOutID, NCOutID2, n, iargc, STATUS - integer :: stat(MPI_STATUS_SIZE), NTILES, NCatch, NDATA1, NDATA2,N_VIS_DATA, N_NIR_DATA - character*400 :: arg(2) - REAL, PARAMETER :: TILESIZE = 10., TILEINT = 2. - INTEGER, PARAMETER :: NPFT = 19, NOCTAD = 46, NSETS = 2 ,MXCNT = 500000 - logical, parameter :: onebin = .true. - INTEGER, PARAMETER :: YearB = 2003, YearE = 2016 - character*400, PARAMETER :: & - BCSDIR = 'SMAP_EASEv2_M09/', & - EXPDIR = '/discover/nobackup/fzeng/Catchment/SMAP_EASEv2_M09/e0004s_wet2/output/SMAP_EASEv2_M09_GLOBAL/', & - EXNAME = 'e0004s_wet2', & - OUTFIL = 'global_alb_mu_std/FPAR_CDF_Params-M09', & - LOGFIL = 'global_alb_mu_std/FPAR_CDF_Params-M09_log.', & - GFILE = 'SMAP_EASEv2_M09_3856x1624' - - logical :: file_exists, put_aux = .true. -! real, dimension (4) :: limits = (/20., -130., 60., -60./) - real, dimension (4) :: limits = (/-90., -180., 90., 180./) - real, dimension (NBINS) :: MODIS_BINS, CLM4_BINS - INTEGER :: I_INDEX(10),JM, IM, NC, NT, year, day, maxcat, ThisTile, req - type(date_time_type), dimension (YearE - YearB + 1) :: octad_time - CHARACTER*8 :: YYYYMMDD - CHARACTER*6 :: YYYYMM - CHARACTER*4 :: YYYY - CHARACTER*2 :: MM, DD,MMR, TSLICE - INTEGER :: i, j,k, pf, i1,i2,i3,i4, f1,f2,f3,f4, ND - INTEGER, DIMENSION (:,:), allocatable :: veg_index, catchs_all - integer, allocatable, dimension (:) :: ldas2bcs, Catchs, NCATCH_ALL - real :: yr,mn,dy,dum,yr1,mn1,dy1, lw, up, db, mean, std, skew, & - minv, maxv, minv1, maxv1, minv2, maxv2, VISmean, FPARmean, FPARstd, NIRmean, NIRstd, VISstd, r2, var1, var2 - real, dimension (:,:), allocatable :: modis_fpar, clm4_fpar, modis_visdf, modis_nirdf - real, dimension (:), allocatable :: modis_cdf, clm4_cdf, data_read, data_save, modis_hist, clm4_hist - real, dimension (:), allocatable :: vis_this, nir_this, fpar_this, est_this - real (kind=8), dimension(NBINS) :: dbins,dcdf - real (kind=8), dimension(3) :: modis_param, clm4_param - real , dimension(NBINS*2 + 13 + 6) :: tmp_real - character*300 :: tmpstring - - call MPI_Init(error) - call MPI_COMM_Size(MPI_COMM_WORLD,comm_size,error) - call MPI_COMM_Rank(MPI_COMM_WORLD,comm_rank,error) - - call MPI_Info_create(info, error) - call MPI_Info_set(info, "romio_cb_read", "automatic", error) - - write (TSLICE ,'(i2.2)') comm_rank + 1 - open (99,file=trim(logfil)//TSLICE, form ='formatted', action='write', status= 'unknown') - - ! STEP 1 check/create CDF params files - - inquire(file=trim(OUTFIL)//'.nc4', exist = file_exists) - - if(.not.file_exists) then - if(comm_rank == 0) then - call create_CDF_ParamFile - WRITE (99,*)'CREATED CDF PARAM FILE : ', trim(OUTFIL)//'.nc4' - endif - endif - - call MPI_BARRIER( MPI_COMM_WORLD, error) - - ! READ # OF 10x10 MODIS TILES AND SMAP_TILE_IDs THAT CONTRIBUTE TO EACH MODIS TILE - - STATUS = NF_OPEN (trim(OUTFIL)//'_aux.nc4', NF_NOWRITE,NCInID) ; VERIFY_(STATUS) - STATUS = NF_INQ_DIMID (NCInID, 'tile10D', K); VERIFY_(STATUS) - CALL HANDLE_ERR(STATUS, 'INQ_DIM') - STATUS = NF_INQ_DIMLEN (NCInID, K, NTILES); VERIFY_(STATUS) - CALL HANDLE_ERR(STATUS, 'DIMLEN_NTILES') - WRITE (99,*)'NOF 10D CELLS : ', NTILES - - allocate (NCatch_all (1:NTILES)) - allocate (Catchs_all (1:16000,1:NTILES)) - - STATUS = NF_GET_VARA_INT (NCInID, VarID(NCInID,'nSMAP'), (/1/), (/NTILES/), NCatch_ALL); VERIFY_(STATUS) - STATUS = NF_GET_VARA_INT (NCInID, VarID(NCInID,'SMAPID'), (/1, 1/), (/16000,NTILES/), Catchs_ALL); VERIFY_(STATUS) - status = NF_CLOSE (NCInID) - - call MPI_BARRIER( MPI_COMM_WORLD, error) - - if(comm_rank == 0) then - - ! ROOT PROCESSOR OPENS FILES TO UPDATE CDF PARAMS - - STATUS = NF_OPEN (trim(OUTFIL)//'.nc4' ,NF_WRITE,NCOutID ) - VERIFY_(STATUS) - STATUS = NF_OPEN (trim(OUTFIL)//'_aux.nc4',NF_WRITE,NCOutID2) - VERIFY_(STATUS) - - endif - - ! read maxcat, LDASsa tile order, veg types and define binvals - - open (10,file=trim(BCSDIR)//'clsm/catchment.def', status='old',action='read', & - form='formatted') - - read (10,*) maxcat - - close (10, status ='keep') - - allocate (veg_index (1: NPFT, 1: MAXCAT)) - allocate (ldas2bcs (1: maxcat)) - allocate (data_read (1: maxcat)) - allocate (data_save (1: maxcat)) - allocate (modis_fpar (1: maxcat, yearE - yearB + 1)) - allocate (clm4_fpar (1: maxcat, yearE - yearB + 1)) - allocate (modis_visdf (1: maxcat, yearE - yearB)) - allocate (modis_nirdf (1: maxcat, yearE - yearB)) - - clm4_fpar = 0. - modis_fpar = 0. - data_save = 0. - veg_index = -9999 - - open (10,file =trim(EXPDIR)//'rc_out/'//trim(EXNAME)//'.ldas_tilecoord.bin',status='old',form='unformatted',convert='big_endian') - read (10) i - read (10) LDAS2BCS - close (10, status = 'keep') - - open (10,file=trim(BCSDIR)//'clsm/CLM_veg_typs_fracs', status='old',action='read', & - form='formatted') - - do i = 1, maxcat - - read (10,*) pf, pf, i1,i2,i3,i4, f1,f2,f3,f4 - - if(f1 >= f2) then - veg_index (i1,i) = i - else - veg_index (i2,i) = i - endif - - end do - - close (10, status ='keep') - -! OCTAD_LOOP : DO NT = 1, NOCTAD - - NT = comm_rank + 1 - ND = 8 - - ! BEGIN READING MODIS FPAR - - MODIS_LOOP : DO year = YearB, YearE - - write (YYYY ,'(i4.4)') year - - WRITE (99,*)'FPAR, VISDF and NIRDF FILES : ' - WRITE (99,*) YYYY//'//fpar.dat' - - open (10, file = trim(BCSDIR)//'MODIS6/'//YYYY//'//fpar.dat', form = 'unformatted', action = 'read') - - if(year < yearE) then - open (11, file = trim(BCSDIR)//'MODIS6/'//YYYY//'//visdf.dat', form = 'unformatted', action = 'read') - open (12, file = trim(BCSDIR)//'MODIS6/'//YYYY//'//nirdf.dat', form = 'unformatted', action = 'read') - WRITE (99,*) YYYY//'//visdf.dat' - WRITE (99,*) YYYY//'//nirdf.dat' - WRITE (99,*) ' ' - endif - - do k = 0, nt ! your processor rank - - read (10) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 - read (10) modis_fpar (:, year - yearB + 1) - - if ((k > 0) .and.(year < yearE)) then - read (11) modis_visdf (:, year - yearB + 1) - read (12) modis_nirdf (:, year - yearB + 1) - endif - - IF (k == NT) WRITE (99,*) 'PROCESSING TIME SLICE : ', yr,mn,dy,yr1,mn1,dy1 - - end do - - close (10, status = 'keep') - - if(year < yearE) then - close (11, status = 'keep') - close (12, status = 'keep') - endif - - END DO MODIS_LOOP - - ! END READING MODIS FPAR and BEGIN READING CLM4 FPAR - - WRITE (99,*) ' ' - WRITE (99,*) 'READING CLM4 FPAR: ' - - CLM4_LOOP : DO year = YearB, YearE - - octad_time(year - yearB + 1)%year = year - 1 - octad_time(year - yearB + 1)%month = 12 - octad_time(year - yearB + 1)%day = 31 - octad_time(year - yearB + 1)%hour = 0 - octad_time(year - yearB + 1)%min = 0 - octad_time(year - yearB + 1)%sec = 0 - - do k = 1, nt - - if((K == NT).and.(NT == 46)) ND = 5 - - DO day = 1,ND - call augment_date_time( 86400, octad_time(year - yearB + 1)) - - if(k == nt) then - write (YYYY, '(i4.4)') octad_time(year - yearB + 1)%year - write (MM , '(i2.2)') octad_time(year - yearB + 1)%month - write (DD , '(i2.2)') octad_time(year - yearB + 1)%day - YYYYMMDD = YYYY//MM//DD - WRITE (99,*) trim(EXNAME)//'.ens_avg.ldas_tile_daily_out.'//YYYYMMDD//'.bin' - open (10, file = trim(EXPDIR)//'cat/ens_avg/Y'//YYYY//'/M'//MM//'/'// & - trim(EXNAME)//'.ens_avg.ldas_tile_daily_out.'//YYYYMMDD//'.bin', & - form = 'unformatted', convert='big_endian', action = 'read') - - do n = 1,3 - read (10) data_read - if(n == 2) data_save = data_read - end do - - clm4_fpar (:,year - yearB + 1) = clm4_fpar (:,year - yearB + 1) + data_save / (data_read + 1.e-20)/ real (ND) - - close (10, status = 'keep') - - endif - end do - - ND = 8 - - end do - - ! reoder to the order of BCs - - data_read = clm4_fpar (:,year - yearB + 1) - - do n = 1, maxcat - clm4_fpar (LDAS2BCS(n),year - yearB + 1) = data_read (n) - end do - - END DO CLM4_LOOP - - ! Now compute CDFs - ! ---------------- - - ! loop through tiles - - allocate (modis_hist (1:MXCNT)) - allocate (clm4_hist (1:MXCNT)) - allocate (vis_this (1:MXCNT)) - allocate (nir_this (1:MXCNT)) - allocate (fpar_this (1:MXCNT)) - allocate (est_this (1:MXCNT)) - allocate (modis_cdf (1:NBINS)) - allocate (clm4_cdf (1:NBINS)) - - TILE_LOOP : DO ThisTile = 1,NTILES - - NCATCH = NCATCH_ALL (ThisTile) - - if(NCatch < 1) then - WRITE (99,*) 'nSMAP problem ', NCatch, ThisTile - endif - - allocate (Catchs (1: NCatch)) - ! STATUS = NF_GET_VARA_INT (NCInID, VarID(NCInID,'SMAPID'), (/1, ThisTile/), (/NCatch,1/), Catchs) - Catchs (1: NCatch) = Catchs_ALL (1: NCatch, ThisTile) - - PFT_LOOP: DO k =1, NPFT - - modis_hist = 0. - clm4_hist = 0. - modis_cdf = 0. - clm4_cdf = 0. - NDATA1 = 1 - NDATA2 = 1 - N_VIS_DATA = 1 - N_NIR_DATA = 1 - MODIS_BINS = 0. - CLM4_BINS = 0. - - DO year = YearB, YearE - DO N = 1, NCatch - if((veg_index(k,Catchs(n)) > 0).and.(modis_fpar (veg_index(k,Catchs(n)), year - yearB + 1) > 0. )) then - modis_hist (NDATA1) = modis_fpar (veg_index(k,Catchs(n)), year - yearB + 1) - NDATA1 = NDATA1 + 1 - endif - - if((veg_index(k,Catchs(n)) > 0).and.(clm4_fpar (veg_index(k,Catchs(n)),year - yearB + 1) > 0. )) then - clm4_hist (NDATA2) = clm4_fpar (veg_index(k,Catchs(n)),year - yearB + 1) - NDATA2 = NDATA2 + 1 - endif - - if (year < yearE) then - if((veg_index(k,Catchs(n)) > 0).and.(modis_fpar (veg_index(k,Catchs(n)), year - yearB + 1) >= 0. ).and.( modis_visdf(veg_index(k,Catchs(n)), year - yearB + 1) > 0.) & - .and.( modis_nirdf(veg_index(k,Catchs(n)), year - yearB + 1) > 0.)) then - vis_this (N_VIS_DATA) = modis_visdf (veg_index(k,Catchs(n)), year - yearB + 1) - fpar_this(N_VIS_DATA) = modis_fpar (veg_index(k,Catchs(n)), year - yearB + 1) - nir_this (N_VIS_DATA) = modis_nirdf (veg_index(k,Catchs(n)), year - yearB + 1) - N_VIS_DATA = N_VIS_DATA + 1 - endif - -! if((veg_index(k,Catchs(n)) > 0).and.(modis_fpar (veg_index(k,Catchs(n)), year - yearB + 1) >= 0. ).and.( modis_nirdf(veg_index(k,Catchs(n)), year - yearB + 1) > 0.)) then -! nir_this (N_NIR_DATA) = modis_nirdf (veg_index(k,Catchs(n)), year - yearB + 1) -! N_NIR_DATA = N_NIR_DATA + 1 -! endif - endif - - if((ndata1 > MXCNT).or.(ndata2 > MXCNT).or.(N_VIS_DATA > MXCNT)) then - WRITE (99,*) 'NDATA1 or NDATA2 exceeded ',ndata1, ndata2, N_VIS_DATA, N_NIR_DATA - stop - endif - - END DO - END DO - - NDATA1 = NDATA1 - 1 - NDATA2 = NDATA2 - 1 - N_NIR_DATA = N_NIR_DATA - 1 - N_VIS_DATA = N_VIS_DATA - 1 - - MINV1 = -9999. - MAXV1 = -9999. - MINV2 = -9999. - MAXV2 = -9999. - - ! curve fitting - - modis_param = -9999. - clm4_param = -9999. - FPARmean = -9999. - FPARstd = -9999. - - if((NDATA1 > 10).and.(NDATA2 > 10)) then - - WRITE (99,*) '# of SMAP DATA CELLS ',ThisTile, K, NDATA1,NDATA2, N_NIR_DATA,N_VIS_DATA - - maxv = MAXVAL ((/MAXVAL(modis_hist (1: NDATA1)),MAXVAL(clm4_hist (1: NDATA2))/)) - minv = MINVAL ((/MINVAL(modis_hist (1: NDATA1)),MINVAL(clm4_hist (1: NDATA2))/)) - - if (maxv > minv) then - - modis_hist (1: NDATA1) = (modis_hist (1: NDATA1) - minv)/maxv - call prob_den_func (ndata1, modis_hist (1: NDATA1) , modis_cdf, MODIS_bins, lwval= 0.,upval = 1.) - - dbins = MODIS_bins - dcdf = modis_cdf - modis_param (1) = .5 - modis_param (2) = .5 - modis_param (3) = 0.9 - call optimiz (nbins,dbins,dcdf,modis_param) - - FPARmean = SUM (clm4_hist (1:NDATA2)) / real (NDATA2) - var1 = 0. - - do i = 1,NDATA2 - var1 = var1 + (clm4_hist(i) - FPARmean)*(clm4_hist(i) - FPARmean) - end do - - FPARstd = sqrt (var1/real(NDATA2 - 1)) - - clm4_hist (1: NDATA2) = (clm4_hist (1: NDATA2) - minv)/maxv - call prob_den_func (ndata2, clm4_hist (1: NDATA2) , clm4_cdf, CLM4_bins, lwval= 0.,upval = 1.) - - dbins = CLM4_bins - dcdf = clm4_cdf - clm4_param (1) = .5 - clm4_param (2) = .5 - clm4_param (3) = 0.9 - call optimiz (NBINS,dbins,dcdf,clm4_param) - endif - endif - - ! albedo parameters - - VISmean = -9999. - NIRmean = -9999. - VISstd = -9999. - NIRstd = -9999. - - if (N_VIS_DATA > 12) then - NIRmean = SUM (nir_this (1:N_VIS_DATA)) / real (N_VIS_DATA) - VISmean = SUM (vis_this (1:N_VIS_DATA)) / real (N_VIS_DATA) - - var1 = 0. - var2 = 0. - - do i = 1,N_VIS_DATA - var1 = var1 + (vis_this(i) - VISmean)*(vis_this(i) - VISmean) - var2 = var2 + (nir_this(i) - NIRmean)*(nir_this(i) - NIRmean) - end do - - VISstd = sqrt (var1/real(N_VIS_DATA - 1)) - NIRstd = sqrt (var2/real(N_VIS_DATA - 1)) - - endif - - do i = 1, comm_size - - tmp_real = -9999. - - if((I == 1).and.(comm_rank == 0)) then - - if(put_aux) then - STATUS = NF_PUT_VARA_REAL(NCOutID2,VARID(NCOutID2,'CDF' ),(/1,ThisTile,k,NT,1/), (/NBINS,1,1,1,1/), modis_cdf );VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCOutID2,VARID(NCOutID2,'CDF' ),(/1,ThisTile,k,NT,2/), (/NBINS,1,1,1,1/), clm4_cdf );VERIFY_(STATUS) - endif - - STATUS = NF_PUT_VARA_REAL(NCOutID, VARID(NCOutID ,'Kappa' ),(/ThisTile,k,NT,1/), (/1,1,1,1/), REAL (modis_param(3))); VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCOutID, VARID(NCOutID ,'Lambda'),(/ThisTile,k,NT,1/), (/1,1,1,1/), REAL (modis_param(1))); VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCOutID, VARID(NCOutID ,'Mu' ),(/ThisTile,k,NT,1/), (/1,1,1,1/), REAL (modis_param(2))) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCOutID, VARID(NCOutID ,'Kappa' ),(/ThisTile,k,NT,2/), (/1,1,1,1/), REAL (clm4_param(3))); VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCOutID, VARID(NCOutID ,'Lambda'),(/ThisTile,k,NT,2/), (/1,1,1,1/), REAL (clm4_param(1))); VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCOutID, VARID(NCOutID ,'Mu' ),(/ThisTile,k,NT,2/), (/1,1,1,1/), REAL (clm4_param(2))) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCOutID, VARID(NCOutID ,'MinVal'),(/ThisTile,k,NT/) , (/1,1,1/), MINV); VERIFY_(STATUS);VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCOutID, VARID(NCOutID ,'MaxVal'),(/ThisTile,k,NT/) , (/1,1,1/), MAXV); VERIFY_(STATUS);VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCOutID, VARID(NCOutID ,'MODISVISmean' ),(/ThisTile,k,NT/), (/1,1,1/),VISmean ); VERIFY_(STATUS);VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCOutID, VARID(NCOutID ,'MODISNIRmean' ),(/ThisTile,k,NT/), (/1,1,1/),NIRmean ); VERIFY_(STATUS);VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCOutID, VARID(NCOutID ,'MODISVISstd' ),(/ThisTile,k,NT/), (/1,1,1/),VISstd ); VERIFY_(STATUS);VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCOutID, VARID(NCOutID ,'MODISNIRstd' ),(/ThisTile,k,NT/), (/1,1,1/),NIRstd ); VERIFY_(STATUS);VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCOutID, VARID(NCOutID ,'MODELFPARmean'),(/ThisTile,k,NT/), (/1,1,1/),FPARmean); VERIFY_(STATUS);VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCOutID, VARID(NCOutID ,'MODELFPARstd' ),(/ThisTile,k,NT/), (/1,1,1/),FPARstd ); VERIFY_(STATUS);VERIFY_(STATUS) - WRITE (99,*) 'Writing Out OCTAD', ThisTile,k,NT - - else if (I > 1) then - - if(I-1 == comm_rank) then - ! print *, comm_rank, 'sending', ThisTile, k,nt - tmp_real (1) = real (ThisTile) - tmp_real (2) = real(k) - tmp_real (3) = real(NT) - tmp_real (4) = REAL (modis_param(3)) - tmp_real (5) = REAL (modis_param(1)) - tmp_real (6) = REAL (modis_param(2)) - tmp_real (7) = REAL (clm4_param(3)) - tmp_real (8) = REAL (clm4_param(1)) - tmp_real (9) = REAL (clm4_param(2)) - tmp_real(10) = MINV - tmp_real(11) = MINV - tmp_real(12) = MAXV - tmp_real(13) = MAXV - tmp_real(14) = VISmean - tmp_real(15) = NIRmean - tmp_real(16) = VISstd - tmp_real(17) = NIRstd - tmp_real(18) = FPARmean - tmp_real(19) = FPARstd - - NC = 19 - n = NC + NBINS - tmp_real (NC+1: N) = modis_cdf(:) - NC = n - n = NC + NBINS - tmp_real (NC+1: N) = clm4_cdf(:) - NC = n - - call MPI_ISend(tmp_real ,2*NBINS + 19,MPI_real,0,999,MPI_COMM_WORLD,req,status) - call MPI_WAIT (req,MPI_STATUS_IGNORE,status) - - else if (comm_rank == 0) then - - call MPI_RECV(tmp_real,2*NBINS + 19,MPI_real,I-1,999,MPI_COMM_WORLD,MPI_STATUS_IGNORE,status) - - IM = NINT (tmp_real (1)) - JM = NINT (tmp_real (2)) - I1 = NINT (tmp_real (3)) - - STATUS = NF_PUT_VARA_REAL(NCOutID, VARID(NCOutID,'Kappa' ),(/IM,JM,I1,1/), (/1,1,1,1/), tmp_real (4)); VERIFY_(STATUS);VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCOutID, VARID(NCOutID,'Lambda'),(/IM,JM,I1,1/), (/1,1,1,1/), tmp_real (5)); VERIFY_(STATUS);VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCOutID, VARID(NCOutID,'Mu' ),(/IM,JM,I1,1/), (/1,1,1,1/), tmp_real (6)) ; VERIFY_(STATUS) ;VERIFY_(STATUS) - - STATUS = NF_PUT_VARA_REAL(NCOutID, VARID(NCOutID,'Kappa' ),(/IM,JM,I1,2/), (/1,1,1,1/), tmp_real (7)); VERIFY_(STATUS);VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCOutID, VARID(NCOutID,'Lambda'),(/IM,JM,I1,2/), (/1,1,1,1/), tmp_real (8)); VERIFY_(STATUS);VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCOutID, VARID(NCOutID,'Mu' ),(/IM,JM,I1,2/), (/1,1,1,1/), tmp_real (9)); VERIFY_(STATUS);VERIFY_(STATUS) - - STATUS = NF_PUT_VARA_REAL(NCOutID, VARID(NCOutID,'MinVal'),(/IM,JM,I1/) , (/1,1,1/) , tmp_real(10)) ; VERIFY_(STATUS);VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCOutID, VARID(NCOutID,'MaxVal'),(/IM,JM,I1/) , (/1,1,1/) , tmp_real(12)) ; VERIFY_(STATUS) ;VERIFY_(STATUS) - - STATUS = NF_PUT_VARA_REAL(NCOutID, VARID(NCOutID ,'MODISVISmean' ),(/IM,JM,I1/), (/1,1,1/), tmp_real(14)); VERIFY_(STATUS);VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCOutID, VARID(NCOutID ,'MODISNIRmean' ),(/IM,JM,I1/), (/1,1,1/), tmp_real(15)); VERIFY_(STATUS);VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCOutID, VARID(NCOutID ,'MODISVISstd' ),(/IM,JM,I1/), (/1,1,1/), tmp_real(16)); VERIFY_(STATUS);VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCOutID, VARID(NCOutID ,'MODISNIRstd' ),(/IM,JM,I1/), (/1,1,1/), tmp_real(17)); VERIFY_(STATUS);VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCOutID, VARID(NCOutID ,'MODELFPARmean'),(/IM,JM,I1/), (/1,1,1/), tmp_real(18)); VERIFY_(STATUS);VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCOutID, VARID(NCOutID ,'MODELFPARstd' ),(/IM,JM,I1/), (/1,1,1/), tmp_real(19)); VERIFY_(STATUS);VERIFY_(STATUS) - - NC = 19 - n = NC + NBINS - if(put_aux) STATUS = NF_PUT_VARA_REAL(NCOutID2,VARID(NCOutID2,'CDF' ),(/1,IM,JM,I1,1/), (/NBINS,1,1,1,1/), tmp_real (nc+1: N)); VERIFY_(STATUS) - NC = n - n = NC + NBINS - if(put_aux) STATUS = NF_PUT_VARA_REAL(NCOutID2,VARID(NCOutID2,'CDF' ),(/1,IM,JM,I1,2/), (/NBINS,1,1,1,1/), tmp_real (nc+1: N)); VERIFY_(STATUS) - NC = n -! n = NC + NBINS -! if(put_aux) STATUS = NF_PUT_VARA_REAL(NCOutID2,VARID(NCOutID2,'BINS' ),(/1,IM,JM,I1/) , (/NBINS,1,1,1/) , tmp_real (nc+1: N)); VERIFY_(STATUS) -! NC = n -! n = NC + NBINS -! if(put_aux) STATUS = NF_PUT_VARA_REAL(NCOutID2,VARID(NCOutID2,'BINS' ),(/1,IM,JM,I1,2/), (/NBINS,1,1,1,1/), tmp_real (nc+1: N)); VERIFY_(STATUS) - - WRITE (99,*) ' RECEIVED Writing Out OCTAD', I-1,IM,JM,I1 - endif - endif - end do - - END DO PFT_LOOP - - deallocate (Catchs) - - END DO TILE_LOOP - - ! END DO OCTAD_LOOP - if(comm_rank == 0) then - status = NF_CLOSE (NCOutID ) - status = NF_CLOSE (NCOutID2) - endif - close (99, status = 'keep') - - call MPI_BARRIER( MPI_COMM_WORLD, error) - call MPI_Finalize(STATUS) - -STOP - -CONTAINS - -!________________________________________________________________________ - - -SUBROUTINE create_CDF_ParamFile - - implicit none - - integer :: NCFOutID, NCFOutID2, status, pid, tid, did, lid, bid, vid,CID - integer :: i,j, k, n, maxcat,ii,jj, tile_count, nplus, nb, NB_max - integer :: nc_rst = 43200, nr_rst = 21600, DIJ, MXT = 16000 - integer :: PID2, TID2, DID2, LID2,BID2, CID2 - real :: dxy, lw, up, db - real, allocatable, dimension (:) :: abins - integer, allocatable, target, dimension (:,:) :: tile_id - integer, pointer, dimension (:,:) :: tile_id_box - integer, allocatable, dimension (:) :: tile_id_vec, bcs2ldas - integer, allocatable, dimension (:) :: density, loc_int - integer, allocatable, dimension (:) :: loc_val - logical, allocatable, dimension (:) :: unq_mask - character (22) :: time_stamp - integer, dimension(8) :: date_time_values - - - status = NF_CREATE (trim(OUTFIL)//'.nc4' , NF_NETCDF4, NCFOutID );VERIFY_(STATUS) - status = NF_CREATE (trim(OUTFIL)//'_aux.nc4', NF_NETCDF4, NCFOutID2);VERIFY_(STATUS) - ! Define Dimensions - - status = NF_DEF_DIM(NCFOutID, 'pft' , NPFT , PID);VERIFY_(STATUS) - status = NF_DEF_DIM(NCFOutID, 'octad' , NOCTAD, TID);VERIFY_(STATUS) - status = NF_DEF_DIM(NCFOutID, 'data' , NSETS , DID);VERIFY_(STATUS) - status = NF_DEF_DIM(NCFOutID, 'tile10D',NF_UNLIMITED,LID);VERIFY_(STATUS) - - - status = NF_DEF_DIM(NCFOutID2, 'pft' , NPFT , PID2);VERIFY_(STATUS) - status = NF_DEF_DIM(NCFOutID2, 'octad' , NOCTAD, TID2);VERIFY_(STATUS) - status = NF_DEF_DIM(NCFOutID2, 'data' , NSETS , DID2);VERIFY_(STATUS) - status = NF_DEF_DIM(NCFOutID2, 'tile10D',NF_UNLIMITED,LID2);VERIFY_(STATUS) - status = NF_DEF_DIM(NCFOutID2, 'bin' , nbins, BID2);VERIFY_(STATUS) - status = NF_DEF_DIM(NCFOutID2, 'nCELLS' , MXT, CID2);VERIFY_(STATUS) - - ! Define variables - - status = NF_DEF_VAR(NCFOutID, 'lon' , NF_FLOAT ,1 ,(/LID/), vid);VERIFY_(STATUS) - status = NF_DEF_VAR(NCFOutID, 'lat' , NF_FLOAT ,1 ,(/LID/), vid);VERIFY_(STATUS) - status = NF_DEF_VAR(NCFOutID, 'Kappa' , NF_FLOAT ,4 ,(/LID,PID,TID,DID/), vid);VERIFY_(STATUS) - status = NF_DEF_VAR(NCFOutID, 'Lambda' , NF_FLOAT ,4 ,(/LID,PID,TID,DID/), vid);VERIFY_(STATUS) - status = NF_DEF_VAR(NCFOutID, 'Mu' , NF_FLOAT ,4 ,(/LID,PID,TID,DID/), vid);VERIFY_(STATUS) - status = NF_DEF_VAR(NCFOutID, 'MinVal' , NF_FLOAT ,3 ,(/LID,PID,TID/), vid);VERIFY_(STATUS) - status = NF_DEF_VAR(NCFOutID, 'MaxVal' , NF_FLOAT ,3 ,(/LID,PID,TID/), vid);VERIFY_(STATUS) - status = NF_DEF_VAR(NCFOutID, 'MODISVISmean', NF_FLOAT ,3 ,(/LID,PID,TID/), vid);VERIFY_(STATUS) - status = NF_DEF_VAR(NCFOutID, 'MODISNIRmean', NF_FLOAT ,3 ,(/LID,PID,TID/), vid);VERIFY_(STATUS) - status = NF_DEF_VAR(NCFOutID, 'MODISVISstd' , NF_FLOAT ,3 ,(/LID,PID,TID/), vid);VERIFY_(STATUS) - status = NF_DEF_VAR(NCFOutID, 'MODISNIRstd' , NF_FLOAT ,3 ,(/LID,PID,TID/), vid);VERIFY_(STATUS) - status = NF_DEF_VAR(NCFOutID, 'MODELFPARmean',NF_FLOAT ,3 ,(/LID,PID,TID/), vid);VERIFY_(STATUS) - status = NF_DEF_VAR(NCFOutID, 'MODELFPARstd' ,NF_FLOAT ,3 ,(/LID,PID,TID/), vid);VERIFY_(STATUS) - status = NF_DEF_VAR(NCFOutID2, 'lon' , NF_FLOAT ,1 ,(/LID2/), vid);VERIFY_(STATUS) - status = NF_DEF_VAR(NCFOutID2, 'lat' , NF_FLOAT ,1 ,(/LID2/), vid);VERIFY_(STATUS) - status = NF_DEF_VAR(NCFOutID2, 'nSMAP' , NF_SHORT ,1 ,(/LID2/), vid);VERIFY_(STATUS) - status = NF_DEF_VAR(NCFOutID2, 'BINS' , NF_FLOAT ,1 ,(/BID2/), vid);VERIFY_(STATUS) - status = NF_DEF_VAR(NCFOutID2, 'SMAPID', NF_INT ,2 ,(/CID2, LID/), vid);VERIFY_(STATUS) - status = NF_DEF_VAR(NCFOutID2, 'CDF' , NF_FLOAT ,5 ,(/BID2,LID2,PID2,TID2,DID2/), vid);VERIFY_(STATUS) - -! Global attributes -! - call date_and_time(VALUES=date_time_values) - - write (time_stamp,'(i4.4,a1,i2.2,a1,i2.2,1x,a2,1x,i2.2,a1,i2.2,a1,i2.2)') & - date_time_values(1),'-',date_time_values(2),'-',date_time_values(3),'at', & - date_time_values(5),':',date_time_values(6),':',date_time_values(7) - - status = NF_PUT_ATT_TEXT(NCFOutID, NF_GLOBAL, 'CreatedBy', LEN_TRIM("Sarith Mahanama"), & - trim("Sarith Mahanama")) - status = NF_PUT_ATT_TEXT(NCFOutID, NF_GLOBAL, 'Date' , LEN_TRIM(time_stamp),trim(time_stamp)) - - status = NF_PUT_ATT_TEXT(NCFOutID2, NF_GLOBAL, 'CreatedBy', LEN_TRIM("Sarith Mahanama"), & - trim("Sarith Mahanama")) - status = NF_PUT_ATT_TEXT(NCFOutID2, NF_GLOBAL, 'Date' , LEN_TRIM(time_stamp),trim(time_stamp)) - - status = NF_ENDDEF(NCFOutID ) - status = NF_ENDDEF(NCFOutID2) - - allocate (abins (1:nbins)) - - lw = 0. - up = 1. - db = (up - lw)/real(nbins) - do n = 1, nbins - abins (n) = lw + real(n)*db - db/2. - end do - - STATUS = NF_PUT_VARA_REAL(NCFOutID2,VARID(NCFOutID2, 'BINS'),(/1/) , (/NBINS/) , abins); VERIFY_(STATUS) - - ! create TILESIZE x TILESIZE tiles at TILEINT - - dij = nint (TILESIZE * nc_rst/360) - dxy = 360./nc_rst - - ! read maxcat from catchment.def - - open (10,file=trim(BCSDIR)//'clsm/catchment.def', status='old',action='read', & - form='formatted') - - read (10,*) maxcat - - close (10, status ='keep') - - ! read tilecoord for tile order in LDASsa - - open (10,file =trim(EXPDIR)//'rc_out/'//trim(EXNAME)//'.ldas_tilecoord.bin',status='old',form='unformatted',convert='big_endian') - read (10) i - if (i /= maxcat) then - print *,'NTILES BCs/LDASsa mismatch:', i,maxcat - stop - endif - - allocate (tile_id_vec (1: maxcat)) - allocate (bcs2ldas (1: maxcat)) - read (10) tile_id_vec - close (10, status = 'keep') - - ! indexing to the LDASsa order - - do i = 1, maxcat - BCS2LDAS(tile_id_vec(i)) = i - end do - - ! read tile_id raster and index according to the order of LDASsa - - open (10,file=trim(BCSDIR)//'rst/'//trim(GFILE)//'.rst',status='old',action='read', & - form='unformatted',convert='little_endian') - - ALLOCATE (tile_id (1:nc_rst,1:nr_rst)) - - DO j = 1, nr_rst - read (10) tile_id (:, j) - END DO - - close (10, status ='keep') - - deallocate (tile_id_vec) - - ! find catchment-tiles that contribute to each 10x10 tile - - tile_count = 0 - Nb_max = 0 - - DO J = FLOOR (limits(1) + TILESIZE/2), CEILING (limits (3) - TILESIZE/2), NINT(TILEINT) - DO I = FLOOR (limits(2) + TILESIZE/2), CEILING (limits (4) - TILESIZE/2), NINT(TILEINT) - if (associated (tile_id_box)) NULLIFY (tile_id_box) - jj = (j + 90)*nc_rst/360 - dij/2 - ii = (i + 180)*nc_rst/360 - dij/2 - tile_id_box => tile_id (ii + 1 : ii + dij, jj +1 : jj + dij) - - NPLUS = count(tile_id_box >= 1 .and. tile_id_box <= maxcat) - - if(NPLUS > 0) then - - allocate (loc_int (1:NPLUS)) - allocate (unq_mask(1:NPLUS)) - loc_int = pack(tile_id_box,mask = (tile_id_box >= 1 .and. tile_id_box <= maxcat)) - call MAPL_Sort (loc_int) - unq_mask = .true. - do n = 2,NPLUS - unq_mask(n) = .not.(loc_int(n) == loc_int(n-1)) - end do - NB = count(unq_mask) - tile_count = tile_count + 1 - allocate(loc_val (1:NB)) - loc_val = 1.*pack(loc_int,mask =unq_mask) - - IF(NB_MAX < NB) NB_MAX = NB - - if(NB > MXT) then - print *, 'NB EXCEEDED MXT', NB, tile_count - stop - endif - - STATUS = NF_PUT_VARA_INT (NCFOutID2,VARID(NCFOutID2,'nSMAP' ),(/tile_count/), (/1/), NB);VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCFOutID2,VARID(NCFOutID2,'lat' ),(/tile_count/), (/1/), real(j));VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCFOutID2,VARID(NCFOutID2,'lon' ),(/tile_count/), (/1/), real(i));VERIFY_(STATUS) - STATUS = NF_PUT_VARA_INT (NCFOutID2,VARID(NCFOutID2,'SMAPID'),(/1,tile_count/),(/NB, 1/), loc_val);VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCFOutID ,VARID(NCFOutID, 'lat' ),(/tile_count/), (/1/), real(j));VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCFOutID ,VARID(NCFOutID, 'lon' ),(/tile_count/), (/1/), real(i));VERIFY_(STATUS) - -! do k = 1,NBINS -! print *,k, loc_val(k), BCS2LDAS(loc_val(k)) -! STATUS = NF_PUT_VARA_INT (NCFOutID,VARID(NCFOutID,'SMAPID' ),(/k,tile_count/), (/1, 1/), BCS2LDAS(loc_val(k)));VERIFY_(STATUS) -! print *, k,nbins,BCS2LDAS(loc_val(k)) -! end do - deallocate (loc_val,loc_int,unq_mask) - - endif - END DO - END DO - - PRINT *, 'NB_MAX :', NB_MAX - - status = NF_CLOSE (NCFOutID ) - status = NF_CLOSE (NCFOutID2) - - deallocate (abins) - -END SUBROUTINE create_CDF_ParamFile - -! ---------------------------------------------------------------------- - -integer function VarID (NCFID, VNAME) - - integer, intent (in) :: NCFID - character(*), intent (in) :: VNAME - integer :: status - - STATUS = NF_INQ_VARID (NCFID, trim(VNAME) ,VarID) - IF (STATUS .NE. NF_NOERR) & - CALL HANDLE_ERR(STATUS, trim(VNAME)) - -end function VarID - -! ----------------------------------------------------------------------- - -SUBROUTINE HANDLE_ERR(STATUS, Line) - - INTEGER, INTENT (IN) :: STATUS - CHARACTER(*), INTENT (IN) :: Line - - IF (STATUS .NE. NF_NOERR) THEN - PRINT *, trim(Line),': ',STATUS, NF_STRERROR(STATUS) - STOP 'Stopped' - ENDIF - -END SUBROUTINE HANDLE_ERR - -! ---------------------------------------------------------------------- - -SUBROUTINE HISTOGRAM (NLENS, NBINS, density, loc_val, x, BIN) - - implicit none - - integer, intent (in) :: NBINS, NLENS - real, intent (in) :: x (NLENS) - integer, intent (out):: density (NBINS) - real, intent (inout) :: loc_val (NBINS) - real, intent (in), optional :: bin - real :: xdum(NLENS), xl, xu, min_value - integer :: n - - if(present (bin)) min_value = real(floor(minval(x))) - - DO N = 1, NBINS - if(present (bin)) then - xl = (N - 1)*BIN + min_value - loc_val (n) = xl - xu = xl + bin - XDUM = 0. - where((x >= xl).and.(x < xu))XDUM = 1 - else - XDUM = 0. - where(x == loc_val (n)) XDUM = 1 - endif - density(n) = int(sum(XDUM)) - END DO - -END SUBROUTINE HISTOGRAM - -!---------------------------------------------------------------------- - -END PROGRAM comp_FPAR_CDF diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/utils/math_routines.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/utils/math_routines.F90 deleted file mode 100755 index 88a6ee604..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/utils/math_routines.F90 +++ /dev/null @@ -1,1186 +0,0 @@ -MODULE math_routines - -implicit none -private -public :: gammln, betai, betacf, rsq, prob_den_func, nbins, & - N_RANDOM_YEARS, shuffle, OPTIMIZ, N_PARAMS !,init_MPI -real, save :: U(97), CS, CD, CM -integer, save :: I97, J97 -integer, parameter :: N_PARAMS=3 -integer, parameter :: nbins = 40, N_RANDOM_YEARS = 41 - -! initialize to non-MPI values - include 'mpif.h' -!integer,public :: myid=0, numprocs=1, mpierr, mpistatus(MPI_STATUS_SIZE) -!logical, public :: root_proc=.true. - -contains - -! -! ---------------------------------------------------------------- -! - -subroutine Shuffle(a) - integer, intent(inout) :: a(:) - integer :: i, randpos, temp - real :: r - - call init_random_seed () - - do i = size(a), 2, -1 - call random_number(r) - randpos = int(r * i) + 1 - temp = a(randpos) - a(randpos) = a(i) - a(i) = temp - end do - end subroutine Shuffle - -! -! ------------------------------------------- -! - - SUBROUTINE init_random_seed() - INTEGER :: i, n, clock - INTEGER, DIMENSION(:), ALLOCATABLE :: seed - - CALL RANDOM_SEED(size = n) - ALLOCATE(seed(n)) - - CALL SYSTEM_CLOCK(COUNT=clock) - - seed = clock + 37 * (/ (i - 1, i = 1, n) /) - CALL RANDOM_SEED(PUT = seed) - - DEALLOCATE(seed) - -END SUBROUTINE init_random_seed - -! -! --------------------------------------------------------------------- -! - - SUBROUTINE random_rain(eta) - -!====================================================================== -! NPAC $Id: math_routines.F90,v 1.1 2018/05/10 15:05:29 smahanam Exp $ -!====================================================================== -! _____________________________________________________________________ -! | -! Test program to generate a vector of Gaussian deviates using | -! the Box-Muller method and the system-supplied uniform RNG. | -! K.A.Hawick, 15 July 1994. | -! | -! H W Yau. 23rd of August, 1996. | -! Northeast Parallel Architectures Center. | -! Syracuse University. | -!_____________________________________________________________________| -! | -! Edit record: | -! --/Jul/1996: M.McMahon -- ALIGN statement and EXTRINSIC statements | -! PROCESSORS statement as well. | -! 23/Aug/1996: HWY. Cleaning up. | -! Removed superfluous definition of module. | -! 26/Aug/1996: Added `IMPLICIT NONE'. | -! Fixed HPF directives. Cleaned up interface block to | -! gaussian_vector(). | -! F90 version. | -!_____________________________________________________________________| -! - - IMPLICIT NONE - - INTEGER, PARAMETER :: n = N_RANDOM_YEARS - REAL ti, tf,tcalc,tcom,tend,start - REAL, DIMENSION(1:n) :: a - REAL, DIMENSION(1:N)::ETA -! -! The vector of Guassian deviates - INTEGER, DIMENSION(1:n) :: j -! -! Histograms to check the distribution - INTEGER, DIMENSION(1:nbins) :: bins - INTEGER i,less, more,nb - INTEGER :: nover = 0 -! -! INTERFACE -! SUBROUTINE timer(return_time, initial_time) -! REAL, INTENT(IN) :: initial_time -! REAL, INTENT(OUT) :: return_time -! END SUBROUTINE -! END INTERFACE -! -! INTERFACE -! SUBROUTINE gaussian_vector(x,n,tcalc2,tcomm2) -! REAL, DIMENSION(:) :: x -! REAL,INTENT(INOUT) :: tcalc2,tcomm2 -! INTEGER,INTENT(IN) :: n -! REAL ETA -! END SUBROUTINE gaussian_vector -! END INTERFACE -!______________________________________________________________________ -! -! Executable Code. -!______________________________________________________________________ -! -! start_timer - CALL timer(start,0.0) - tcom = 0.0 - tcalc = 0.0 - CALL timer(ti,0.0) - bins(1:nbins) = 0 - CALL timer(tend,ti) - tcalc = tcalc + tend -! -! Ask for n deviate - CALL gaussian_vector( a, n,tend,tcom ) - tcalc = tcalc + tend - CALL timer(ti,0.0) -!F95 FORALL(i=1:n)j(i) = a(i) * real(nbins/7) + nbins/2 + 1 - DO i=1,n - j(i) = a(i) * real(nbins/7) + nbins/2 + 1 - END DO - CALL timer(tend,ti) - tcalc = tcalc + tend -! - CALL timer(ti,0.0) - DO i=1,n - ETA(I)=(REAL(J(I))-10.-1.)/5. - ENDDO -! write(*,*)eta -! write(*,*)sum(j)/300. - DO nb = 1,nbins - bins(nb) = count(j.EQ.nb,1) -!CCCCCCCC write(6,*) nb, bins(nb) - ENDDO - CALL timer(tend,ti) - tcom = tcom + tend -! -! Stop timer. - CALL timer(tf,start) -! -! Correction for serial execution. - tcalc = tcalc + tcom - tcom = 0.0 -! WRITE(6,6001) 0,n, -! 1 tcom,tcalc,(tf-tcom-tcalc),tf -! -! Write histogram - DO nb=1,nbins -! WRITE(6,*) nb,(REAL(NB)-10.-1.)/5., bins(nb) - ENDDO -! -! STOP - RETURN -! - 6001 FORMAT('Number of Processors = ',I4/ & - 'Problem size = ',I6/ & - 'Communications = ',F9.3/ & - 'Compute = ',F9.3/ & - 'Others = ',F9.3/ & - 'Total time = ',F9.3) -! - END SUBROUTINE random_rain -! -! ------------------------------------------------------ -! - - SUBROUTINE gaussian_vector( x, n, tcalc2,tcomm2 ) - - IMPLICIT NONE - ! - ! Box-Muller Method - ! See Knuth, Vol 2, 2nd Edn, PP 117 - INTEGER,INTENT(IN) :: n - REAL, DIMENSION(:) :: x - REAL,INTENT(INOUT) :: tcalc2,tcomm2 - REAL, DIMENSION(:), ALLOCATABLE :: v1, v2, r, f - REAL ti,cal1,cal2,com1,com2 - LOGICAL, DIMENSION(:), ALLOCATABLE :: mask - ! - ! Accept/reject efficiency is about 1.27 - integer m, i, np - !______________________________________________________________________ - ! - ! Executable code. - !______________________________________________________________________ - ! - CALL timer(ti,0.0) - np = n - ! - ! avoid fluctuation problems - IF( np .lt. 10 ) np = 10 - ALLOCATE( v1(np), v2(np), r(np), f(np), mask(np) ) - ! - ! Generate two deviates: - CALL random_number( v1 ) - CALL random_number( v2 ) - v1 = 2.0 * v1 -1.0 - v2 = 2.0 * v2 -1.0 - r = v1**2 + v2**2 - ! - ! are they in the unit circle? - mask = r < 1.0 - r = merge( r, 0.5, mask ) - f = sqrt( -2.0 * log(r) / r) - v1 = v1 * f - v2 = v2 * f - ! - ! since pack is a new intrinsic, here is serial code to show - ! what is being done. - ! m = 0 - ! do i=1,np - ! if( mask(i) )then - ! m = m + 1 - ! r(m) = v1(i) - ! f(m) = v2(i) - ! endif - ! enddo - CALL timer(cal1,ti) - - CALL timer(ti,0.0) - ! - ! we now have 2 * m deviates - m = count( mask ) - CALL timer(com1,ti) - - CALL timer(ti,0.0) - ! - ! and to save space, we'll store them in r and f - ! r = pack( v1, mask ) - ! f = pack( v2, mask ) - ! - ! We now get performance at the expense of memory. - r = v1 - f = v2 - ! - ! Statistically, this should not happen for large n - IF( 2*m .lt. n )THEN - WRITE(6,*) 'Not enough deviates! Got: ', 2*m, ', Needed: ', n - ! WRITE(6,*) 'Increase accept reject allowance in', - ! ' xgaussian_vector' - STOP - ENDIF - ! - ! use the two result vectors to patch up enough as - IF( m .LT. n )THEN - x(1:m)=r(1:m) - CALL timer(cal2,ti) - CALL timer(ti,0.0) - x(m+1:n) = f(1:n-m) - CALL timer(com2,ti) - ELSE - x(1:n) = r(1:n) - ENDIF - - tcalc2 = cal1 + cal2 - tcomm2 = com1 + com2 - DEALLOCATE( v1, v2, r, f, mask ) - - RETURN - END SUBROUTINE gaussian_vector -! -! ------------------------------------------------------------------- -! - SUBROUTINE timer(return_time, initial_time) - implicit none - REAL, INTENT(IN) :: initial_time - REAL, INTENT(OUT) :: return_time - INTEGER finish,rate - CALL system_clock( COUNT=finish,COUNT_RATE=rate) - return_time = FLOAT(finish) / FLOAT(rate) - initial_time - RETURN - END SUBROUTINE timer -! -! ------------------------------------------------------------------- -! - -subroutine prob_den_func (ndata, datain, cdf, bins, & - mean, std, skew, pdf, lwval, upval) - -implicit none -integer, intent (in) :: ndata -real, dimension(ndata), intent (in) :: datain -real, intent(out), dimension(nbins) :: cdf, bins -real, optional, intent(out), dimension(nbins) :: pdf -real, optional, intent (out) :: mean, std, skew -real, optional :: lwval, upval -real :: lw,up,db,var1,var2, variance -integer :: i,n - -lw = minval (datain) -up = maxval (datain) - -if(present(upval)) then - up = upval - lw = lwval -endif - -db = (up - lw)/real(nbins) -cdf = 0. -if(present(pdf)) pdf =0. - -do n = 1, nbins - bins (n) = lw + real(n)*db - db/2. - do i = 1,ndata - if(datain(i) <= bins (n) + db/2.) cdf(n) = cdf(n) + 1. - if(present(pdf)) then - if(n==1) then - if((datain(i) >= bins (n) - db/2.).and. & - (datain(i) <= bins (n) + db/2.)) & - pdf(n) = pdf(n) + 1. - else - if((datain(i) > bins (n) - db/2.).and. & - (datain(i) <= bins (n) + db/2.)) & - pdf(n) = pdf(n) + 1. - endif - endif - end do -end do - -cdf = cdf/real(ndata) - -if(present(pdf)) pdf = pdf/real(ndata) - -if(present (mean)) mean = sum(datain)/real(ndata) - -if(present (std)) then - - var1 = 0. - mean = sum(datain)/real(ndata) - - do i = 1,ndata - var1 = var1 + (datain(i) - mean)*(datain(i) - mean) - end do - - std = sqrt (var1/real(ndata - 1)) - - if(present (skew)) then - var2 = 0. - do i = 1,ndata - var2 = var2 + ((datain(i) - mean)/std)* & - ((datain(i) - mean)/std)* & - ((datain(i) - mean)/std) - end do - - skew = var2/real(ndata - 1) - - endif - -endif - -END subroutine prob_den_func - -! -! ------------------------------------------------------- -! - -FUNCTION betai(a,b,x) -REAL betai,a,b,x -REAL bt -!external gammln - -if(x.lt.0..or.x.gt.1.)print *, 'bad argument x in betai',x -if(x.lt.0..or.x.gt.1.)stop -if(x.eq.0..or.x.eq.1.)then - bt=0. -else - bt=exp(gammln(a+b)-gammln(a)-gammln(b) & - +a*log(x)+b*log(1.-x)) -endif - -if(x.lt.(a+1.)/(a+b+2.))then - betai=bt*betacf(a,b,x)/a - return -else - betai=1.-bt*betacf(b,a,1.-x)/b - return -endif -END FUNCTION betai -! -! ------------------------------------------------------- -! -FUNCTION betacf(a,b,x) -INTEGER MAXIT -REAL betacf,a,b,x,EPS,FPMIN -PARAMETER (MAXIT=100,EPS=3.e-7,FPMIN=1.e-30) -INTEGER m,m2 -REAL aa,c,d,del,h,qab,qam,qap - -qab=a+b -qap=a+1. -qam=a-1. -c=1. -d=1.-qab*x/qap - -if(abs(d).lt.FPMIN)d=FPMIN -d=1./d -h=d -do m=1,MAXIT - m2=2*m - aa=m*(b-m)*x/((qam+m2)*(a+m2)) - d=1.+aa*d - if(abs(d).lt.FPMIN)d=FPMIN - c=1.+aa/c - if(abs(c).lt.FPMIN)c=FPMIN - d=1./d - h=h*d*c - aa=-(a+m)*(qab+m)*x/((a+m2)*(qap+m2)) - d=1.+aa*d - if(abs(d).lt.FPMIN)d=FPMIN - c=1.+aa/c - if(abs(c).lt.FPMIN)c=FPMIN - d=1./d - del=d*c - h=h*del - if(abs(del-1.).lt.EPS)exit -enddo - betacf=h -return -END FUNCTION betacf -! -! -------------------------------------------------------------- -! -FUNCTION gammln(xx) -REAL gammln,xx -INTEGER j -DOUBLE PRECISION ser,stp,tmp,x,y,cof(6) - -SAVE cof,stp -DATA cof,stp/76.18009172947146d0,-86.50532032941677d0, & - 24.01409824083091d0,-1.231739572450155d0,.1208650973866179d-2, & - -.5395239384953d-5,2.5066282746310005d0/ -x=xx -y=x -tmp=x+5.5d0 -tmp=(x+0.5d0)*log(tmp)-tmp -ser=1.000000000190015d0 -do j=1,6 - y=y+1.d0 - ser=ser+cof(j)/y -enddo -gammln=tmp+log(stp*ser/x) -return -END FUNCTION gammln - -! -! ------------------------------------------------ -! - -SUBROUTINE RSQ (NDATA, X, Y, R2, RMSE, limits, slope, intercept) - -implicit none -integer, intent (in) :: NDATA -real, dimension (ndata), intent(in) :: x,y -real, optional, dimension(4), intent (in) :: limits -real, optional, intent(out) :: slope, intercept, RMSE -real, intent(out) :: r2 - -integer ::n -real :: ic -real :: sumx, sumy,sumxy, sumx2,sumy2,sig2x,sig2y,sig2xy,error - -ic =0. -sumx=0. -sumy=0. -sumxy=0. -sumy2=0. -sumx2=0. -error=0. -do n = 1,ndata - - if(present (limits)) then - if((x(n) > limits(1)).and.(x(n) < limits(2)).and. & - (y(n) > limits(3)).and.(y(n) < limits(4))) then - ic = ic + 1. - sumx = sumx + x(n) - sumy = sumy + y(n) - sumxy= sumxy + x(n)*y(n) - sumy2= sumy2 + y(n)*y(n) - sumx2= sumx2 + x(n)*x(n) - error= error + (y(n) - x(n))*(y(n) - x(n)) - endif - else - ic = ic + 1. - sumx = sumx + x(n) - sumy = sumy + y(n) - sumxy= sumxy + x(n)*y(n) - sumy2= sumy2 + y(n)*y(n) - sumx2= sumx2 + x(n)*x(n) - error= error + (y(n) - x(n))*(y(n) - x(n)) - endif - -end do - -if (present(intercept)) intercept = -9999. -if (present(slope)) slope = -9999. -if (present(rmse)) rmse = -9999. -r2 = -9999. - -if(ic /= 0) then - if(ic*sumx2 /= sumx*sumx) then - - if (present(intercept)) intercept = & - (sumy*sumx2 - sumx*sumxy) / (ic*sumx2 - sumx*sumx) - if (present(slope)) slope = & - (ic*sumxy - sumx*sumy) / (ic*sumx2 - sumx*sumx) - if (present(rmse)) rmse = sqrt(error/real(ic)) - endif - - sumx =sumx/ic - sumy =sumy/ic - sumxy=sumxy/ic - sumy2=sumy2/ic - sumx2=sumx2/ic - sig2x=sumx2-sumx*sumx - sig2y=sumy2-sumy*sumy - sig2xy=(sumxy-sumx*sumy)*(sumxy-sumx*sumy) - - r2 = sig2xy/(sig2x*sig2y + 1.e-20) -endif - -END SUBROUTINE RSQ - -! -! ------------------------------------------ -! - SUBROUTINE OPTIMIZ(NDATA,wet,eff,X) - - implicit none - - integer, PARAMETER :: N = N_PARAMS, NEPS = 4 - integer, intent (in) :: ndata - REAL (kind = 8) :: LB(N), UB(N), X(N), XOPT(N), CON(N), VM(N), & - FSTAR(NEPS), XP(N), T, EPS, RT, FOPT, & - EFF(NDATA),WET(NDATA) - - INTEGER NACP(N), NS, NT, NFCNEV, IER, ISEED1, ISEED2, & - MAXEVL, IPRINT, NACC, NOBDS, I - - LOGICAL MAX - -! Set underflows to zero on IBM mainframes. -! CALL XUFLOW(0) - - MAX = .false. - EPS = 1.0D-6 - RT = .5 - ISEED1 = 1 - ISEED2 = 2 - NS = 20 - NT = 5 - MAXEVL = 100000 - IPRINT = 0 - - DO I=1,N - LB(I)=0.0001 - UB(I)=100. - CON(I) = 2.0 - END DO - UB(3)= 1. - LB(3)= 0.1 -! -! Set input values of the input/output parameters. -! - T = 5.0 - DO I = 1, N - VM(I) = 1.0 - END DO - -! WRITE(*,1000) N, MAX, T, RT, EPS, NS, NT, NEPS, MAXEVL, IPRINT, & -! ISEED1, ISEED2 -! -! CALL PRTVEC(X,N,'STARTING VALUES') -! CALL PRTVEC(VM,N,'INITIAL STEP LENGTH') -! CALL PRTVEC(LB,N,'LOWER BOUND') -! CALL PRTVEC(UB,N,'UPPER BOUND') -! CALL PRTVEC(C,N,'C VECTOR') -! WRITE(*,'(/,'' **** END OF DRIVER ROUTINE OUTPUT ****'' & -! /,'' **** BEFORE CALL TO SA. ****'')') - - CALL SA(X,MAX,RT,EPS,NS,NT,NEPS,MAXEVL,LB,UB,CON,IPRINT,ISEED1, & - ISEED2,T,VM,XOPT,FOPT,NACC,NFCNEV,NOBDS,IER, & - FSTAR,XP,NACP,NDATA,EFF,WET) - -! WRITE(*,'(/,'' **** RESULTS AFTER SA **** '')') -! CALL PRTVEC(XOPT,N,'SOLUTION') -! CALL PRTVEC(VM,N,'FINAL STEP LENGTH') -! WRITE(*,1001) FOPT, NFCNEV, NACC, NOBDS, T, IER - -1000 FORMAT(/,' SIMULATED ANNEALING EXAMPLE',/, & - /,' NUMBER OF PARAMETERS: ',I3,' MAXIMAZATION: ',L5, & - /,' INITIAL TEMP: ', G8.2, ' RT: ',G8.2, ' EPS: ',G8.2, & - /,' NS: ',I3, ' NT: ',I2, ' NEPS: ',I2, & - /,' MAXEVL: ',I10, ' IPRINT: ',I1, ' ISEED1: ',I4, & - ' ISEED2: ',I4) -1001 FORMAT(/,' OPTIMAL FUNCTION VALUE: ',G20.13 & - /,' NUMBER OF FUNCTION EVALUATIONS: ',I10, & - /,' NUMBER OF ACCEPTED EVALUATIONS: ',I10, & - /,' NUMBER OF OUT OF BOUND EVALUATIONS: ',I10, & - /,' FINAL TEMP: ', G20.13,' IER: ', I3) - - RETURN - END SUBROUTINE OPTIMIZ - -! -! --------------------------------------------------------------- -! - - SUBROUTINE SA(X,MAX,RT,EPS,NS,NT,NEPS,MAXEVL,LB,UB,CON,IPRINT, & - ISEED1,ISEED2,T,VM,XOPT,FOPT,NACC,NFCNEV,NOBDS,IER, & - FSTAR,XP,NACP,NDATA,EFF,WET) - -! Type all external variables. - - INTEGER,PARAMETER :: N=N_PARAMS - integer :: ndata - REAL (KIND = 8) X(N), LB(N), UB(N), CON(N), VM(N), FSTAR(N), & - XOPT(N), XP(N), T, EPS, RT, FOPT - REAL (KIND = 8) EFF(NDATA),WET(NDATA) - INTEGER NACP(N), NS, NT, NEPS, NACC, MAXEVL, IPRINT, & - NOBDS, IER, NFCNEV, ISEED1, ISEED2 - LOGICAL MAX - -! Type all internal variables. - REAL (KIND = 8) F, FP, P, PP, RATIO - INTEGER NUP, NDOWN, NREJ, NNEW, LNOBDS, H, I, J, M - LOGICAL QUIT - -! Type all functions. -! REAL (KIND = 8) EXPREP - -! Initialize the random number generator RANMAR. - CALL RMARIN(ISEED1,ISEED2) - -! Set initial values. - NACC = 0 - NOBDS = 0 - NFCNEV = 0 - IER = 99 - - DO I = 1, N - XOPT(I) = X(I) - NACP(I) = 0 - END DO - - DO I = 1, NEPS - FSTAR(I) = 1.0D+20 - END DO - -! If the initial temperature is not positive, notify the user and -! return to the calling routine. - IF (T .LE. 0.0) THEN - WRITE(*,'(/,'' THE INITIAL TEMPERATURE IS NOT POSITIVE. '' & - /,'' RESET THE VARIABLE T. ''/)') - IER = 3 - RETURN - END IF - -! If the initial value is out of bounds, notify the user and return -! to the calling routine. - DO I = 1, N - IF ((X(I) .GT. UB(I)) .OR. (X(I) .LT. LB(I))) THEN - CALL PRT1 - IER = 2 - RETURN - END IF - END DO - -! Evaluate the function with input X and return value as F. - CALL FCN(X,F,NDATA,EFF,WET) - -! If the function is to be minimized, switch the sign of the function. -! Note that all intermediate and final output switches the sign back -! to eliminate any possible confusion for the user. - IF(.NOT. MAX) F = -F - NFCNEV = NFCNEV + 1 - FOPT = F - FSTAR(1) = F - IF(IPRINT .GE. 1) CALL PRT2(MAX,N,X,F) - -! Start the main loop. Note that it terminates if (i) the algorithm -! succesfully optimizes the function or (ii) there are too many -! function evaluations (more than MAXEVL). -100 NUP = 0 - NREJ = 0 - NNEW = 0 - NDOWN = 0 - LNOBDS = 0 - - DO M = 1, NT - DO J = 1, NS - DO H = 1, N - -! Generate XP, the trial value of X. Note use of VM to choose XP. - DO I = 1, N - IF (I .EQ. H) THEN - XP(I) = X(I) + (RANMAR()*2.- 1.) * VM(I) - ELSE - XP(I) = X(I) - END IF - -! If XP is out of bounds, select a point in bounds for the trial. - IF((XP(I) .LT. LB(I)) .OR. (XP(I) .GT. UB(I))) THEN - XP(I) = LB(I) + (UB(I) - LB(I))*RANMAR() - LNOBDS = LNOBDS + 1 - NOBDS = NOBDS + 1 - IF(IPRINT .GE. 3) CALL PRT3(MAX,N,XP,X,FP,F) - END IF - END DO -! Evaluate the function with the trial point XP and return as FP. - CALL FCN(XP,FP,NDATA,EFF,WET) - IF(.NOT. MAX) FP = -FP - NFCNEV = NFCNEV + 1 - IF(IPRINT .GE. 3) CALL PRT4(MAX,N,XP,X,FP,F) - -! If too many function evaluations occur, terminate the algorithm. - IF(NFCNEV .GE. MAXEVL) THEN - CALL PRT5 - IF (.NOT. MAX) FOPT = -FOPT - IER = 1 - RETURN - END IF - -! Accept the new point if the function value increases. - IF(FP .GE. F) THEN - IF(IPRINT .GE. 3) THEN - WRITE(*,'('' POINT ACCEPTED'')') - END IF - DO I = 1, N - X(I) = XP(I) - END DO - F = FP - NACC = NACC + 1 - NACP(H) = NACP(H) + 1 - NUP = NUP + 1 - -! If greater than any other point, record as new optimum. - IF (FP .GT. FOPT) THEN - IF(IPRINT .GE. 3) THEN - WRITE(*,'('' NEW OPTIMUM'')') - END IF - DO I = 1, N - XOPT(I) = XP(I) - END DO - FOPT = FP - NNEW = NNEW + 1 - END IF - - ! If the point is lower, use the Metropolis criteria to decide on - ! acceptance or rejection. - ELSE - P = EXPREP((FP - F)/T) - PP = RANMAR() - IF (PP .LT. P) THEN - IF(IPRINT .GE. 3) CALL PRT6(MAX) - DO I = 1, N - X(I) = XP(I) - END DO - F = FP - NACC = NACC + 1 - NACP(H) = NACP(H) + 1 - NDOWN = NDOWN + 1 - ELSE - NREJ = NREJ + 1 - IF(IPRINT .GE. 3) CALL PRT7(MAX) - END IF - END IF - - END DO - END DO - -! Adjust VM so that approximately half of all evaluations are accepted. - DO I = 1, N - RATIO = DFLOAT(NACP(I)) /DFLOAT(NS) - IF (RATIO .GT. .6) THEN - VM(I) = VM(I)*(1. + CON(I)*(RATIO - .6)/.4) - ELSE IF (RATIO .LT. .4) THEN - VM(I) = VM(I)/(1. + CON(I)*((.4 - RATIO)/.4)) - END IF - IF (VM(I) .GT. (UB(I)-LB(I))) THEN - VM(I) = UB(I) - LB(I) - END IF - END DO - - IF(IPRINT .GE. 2) THEN - CALL PRT8(N,VM,XOPT,X) - END IF - - DO I = 1, N - NACP(I) = 0 - END DO - - END DO - - IF(IPRINT .GE. 1) THEN - CALL PRT9(MAX,N,T,XOPT,VM,FOPT,NUP,NDOWN,NREJ,LNOBDS,NNEW) - END IF - -! Check termination criteria. - QUIT = .FALSE. - FSTAR(1) = F - IF ((FOPT - FSTAR(1)) .LE. EPS) QUIT = .TRUE. - DO I = 1, NEPS - IF (ABS(F - FSTAR(I)) .GT. EPS) QUIT = .FALSE. - END DO - -! Terminate SA if appropriate. - IF (QUIT) THEN - DO I = 1, N - X(I) = XOPT(I) - END DO - IER = 0 - IF (.NOT. MAX) FOPT = -FOPT - IF(IPRINT .GE. 1) CALL PRT10 - RETURN - END IF - -! If termination criteria is not met, prepare for another loop. - T = RT*T - DO I = NEPS, 2, -1 - FSTAR(I) = FSTAR(I-1) - END DO - F = FOPT - DO I = 1, N - X(I) = XOPT(I) - END DO - -! Loop again. - GO TO 100 - - END SUBROUTINE SA -! -! --------------------------------------------------------- -! - - SUBROUTINE FCN(X,F,NDATA,EFF,WET) - implicit none - integer, parameter :: N = N_PARAMS - REAL (KIND = 8) X(n),F - INTEGER, intent (in) :: ndata - INTEGER Nd - REAL (KIND = 8) EFF(NDATA),WET(NDATA) - real :: a,b,xv, r2, rmse - real , dimension(ndata) :: yval, xval - - a = X(1) - b = X(2) - - do nd = 1, ndata - xv = wet(nd) - xval(nd) = eff(nd) - yval(nd) = X(3)*betai(a,b,xv) - end do - -! if(maxval(yval) > 1.) print *,maxval(yval), minval(yval) - - call rsq (ndata, xval, yval, r2, rmse) - F = rmse -! if(maxval(yval) > 1.) F = 1.d10 -! F = r2 -! if(F > 1.) F = -1.d-10 - - RETURN - END SUBROUTINE FCN - -! -! --------------------------------------------------------------- -! - FUNCTION EXPREP(RDUM) - implicit none - REAL (KIND = 8) RDUM, EXPREP - - IF (RDUM .GT. 174.) THEN - EXPREP = 3.69D+75 - ELSE IF (RDUM .LT. -180.) THEN - EXPREP = 0.0 - ELSE - EXPREP = EXP(RDUM) - END IF - - RETURN - END FUNCTION EXPREP -! -! --------------------------------------------- -! - subroutine RMARIN(IJ,KL) - - implicit none - integer, intent (in) :: ij,kl - integer :: i,j,k,l,m, ii,jj - real :: t,s - -! real U(97), C, CD, CM -! integer I97, J97 -! common /raset1/ U, C, CD, CM, I97, J97 - - if( IJ .lt. 0 .or. IJ .gt. 31328 .or. & - KL .lt. 0 .or. KL .gt. 30081 ) then - print '(A)', ' The first random number seed must have a value between 0 and 31328' - print '(A)',' The second seed must have a value between 0 and 30081' - stop - endif - - i = mod(IJ/177, 177) + 2 - j = mod(IJ , 177) + 2 - k = mod(KL/169, 178) + 1 - l = mod(KL, 169) - - do ii = 1, 97 - s = 0.0 - t = 0.5 - do jj = 1, 24 - m = mod(mod(i*j, 179)*k, 179) - i = j - j = k - k = m - l = mod(53*l+1, 169) - if (mod(l*m, 64) .ge. 32) then - s = s + t - endif - t = 0.5 * t - end do - U(ii) = s - end do - - - CS = 362436.0 / 16777216.0 - CD = 7654321.0 / 16777216.0 - CM = 16777213.0 /16777216.0 - I97 = 97 - J97 = 33 - return - end subroutine RMARIN - -! -! --------------------------------------- -! - - real function ranmar() - real :: uni -! real U(97), C, CD, CM -! integer I97, J97 -! common /raset1/ U, C, CD, CM, I97, J97 - uni = U(I97) - U(J97) - if( uni .lt. 0.0 ) uni = uni + 1.0 - U(I97) = uni - I97 = I97 - 1 - if(I97 .eq. 0) I97 = 97 - J97 = J97 - 1 - if(J97 .eq. 0) J97 = 97 - CS = CS - CD - if( CS .lt. 0.0 ) CS = CS + CM - uni = uni - CS - if( uni .lt. 0.0 ) uni = uni + 1.0 - RANMAR = uni - return - END function ranmar - - SUBROUTINE PRT1 - implicit none - WRITE(*,'(/,'' THE STARTING VALUE (X) IS OUTSIDE THE BOUNDS '' & - /,'' (LB AND UB). EXECUTION TERMINATED WITHOUT ANY'' & - /,'' OPTIMIZATION. RESPECIFY X, UB OR LB SO THAT '' & - /,'' LB(I) .LT. X(I) .LT. UB(I), I = 1, N. ''/)') - - RETURN - END SUBROUTINE PRT1 - - SUBROUTINE PRT2(MAX,N,X,F) - implicit none - REAL (KIND = 8) X(N), F - INTEGER N - LOGICAL MAX - - WRITE(*,'('' '')') - CALL PRTVEC(X,N,'INITIAL X') - IF (MAX) THEN - WRITE(*,'('' INITIAL F: '',/, G25.18)') F - ELSE - WRITE(*,'('' INITIAL F: '',/, G25.18)') -F - END IF - - RETURN - END SUBROUTINE PRT2 - - SUBROUTINE PRT3(MAX,N,XP,X,FP,F) - implicit none - REAL (KIND = 8) XP(N), X(N), FP, F - INTEGER N - LOGICAL MAX - - WRITE(*,'('' '')') - CALL PRTVEC(X,N,'CURRENT X') - IF (MAX) THEN - WRITE(*,'('' CURRENT F: '',G25.18)') F - ELSE - WRITE(*,'('' CURRENT F: '',G25.18)') -F - END IF - CALL PRTVEC(XP,N,'TRIAL X') - WRITE(*,'('' POINT REJECTED SINCE OUT OF BOUNDS'')') - - RETURN - END SUBROUTINE PRT3 - - SUBROUTINE PRT4(MAX,N,XP,X,FP,F) - implicit none - REAL (KIND = 8) XP(N), X(N), FP, F - INTEGER N - LOGICAL MAX - - WRITE(*,'('' '')') - CALL PRTVEC(X,N,'CURRENT X') - IF (MAX) THEN - WRITE(*,'('' CURRENT F: '',G25.18)') F - CALL PRTVEC(XP,N,'TRIAL X') - WRITE(*,'('' RESULTING F: '',G25.18)') FP - ELSE - WRITE(*,'('' CURRENT F: '',G25.18)') -F - CALL PRTVEC(XP,N,'TRIAL X') - WRITE(*,'('' RESULTING F: '',G25.18)') -FP - END IF - - RETURN - END SUBROUTINE PRT4 - - SUBROUTINE PRT5 - implicit none - WRITE(*,'(/,'' TOO MANY FUNCTION EVALUATIONS; CONSIDER '' & - /,'' INCREASING MAXEVL OR EPS, OR DECREASING '' & - /,'' NT OR RT. THESE RESULTS ARE LIKELY TO BE '' & - /,'' POOR.'',/)') - - RETURN - END SUBROUTINE PRT5 - - SUBROUTINE PRT6(MAX) - implicit none - LOGICAL MAX - - IF (MAX) THEN - WRITE(*,'('' THOUGH LOWER, POINT ACCEPTED'')') - ELSE - WRITE(*,'('' THOUGH HIGHER, POINT ACCEPTED'')') - END IF - - RETURN - END SUBROUTINE PRT6 - - SUBROUTINE PRT7(MAX) - implicit none - LOGICAL MAX - - IF (MAX) THEN - WRITE(*,'('' LOWER POINT REJECTED'')') - ELSE - WRITE(*,'('' HIGHER POINT REJECTED'')') - END IF - - RETURN - END SUBROUTINE PRT7 - - SUBROUTINE PRT8(N,VM,XOPT,X) - implicit none - REAL (KIND = 8) VM(N), XOPT(N), X(N) - INTEGER N - - WRITE(*,'(/,'' INTERMEDIATE RESULTS AFTER STEP LENGTH ADJUSTMENT'',/)') - CALL PRTVEC(VM,N,'NEW STEP LENGTH (VM)') - CALL PRTVEC(XOPT,N,'CURRENT OPTIMAL X') - CALL PRTVEC(X,N,'CURRENT X') - WRITE(*,'('' '')') - - RETURN - END SUBROUTINE PRT8 - - SUBROUTINE PRT9(MAX,N,T,XOPT,VM,FOPT,NUP,NDOWN,NREJ,LNOBDS,NNEW) - implicit none - REAL (KIND = 8) XOPT(N), VM(N), T, FOPT - INTEGER N, NUP, NDOWN, NREJ, LNOBDS, NNEW, TOTMOV - LOGICAL MAX - - TOTMOV = NUP + NDOWN + NREJ - - WRITE(*,'(/, '' INTERMEDIATE RESULTS BEFORE NEXT TEMPERATURE REDUCTION'',/)') - WRITE(*,'('' CURRENT TEMPERATURE: '',G12.5)') T - IF (MAX) THEN - WRITE(*,'('' MAX FUNCTION VALUE SO FAR: '',G25.18)') FOPT - WRITE(*,'('' TOTAL MOVES: '',I8)') TOTMOV - WRITE(*,'('' UPHILL: '',I8)') NUP - WRITE(*,'('' ACCEPTED DOWNHILL: '',I8)') NDOWN - WRITE(*,'('' REJECTED DOWNHILL: '',I8)') NREJ - WRITE(*,'('' OUT OF BOUNDS TRIALS: '',I8)') LNOBDS - WRITE(*,'('' NEW MAXIMA THIS TEMPERATURE:'',I8)') NNEW - ELSE - WRITE(*,'('' MIN FUNCTION VALUE SO FAR: '',G25.18)') -FOPT - WRITE(*,'('' TOTAL MOVES: '',I8)') TOTMOV - WRITE(*,'('' DOWNHILL: '',I8)') NUP - WRITE(*,'('' ACCEPTED UPHILL: '',I8)') NDOWN - WRITE(*,'('' REJECTED UPHILL: '',I8)') NREJ - WRITE(*,'('' TRIALS OUT OF BOUNDS: '',I8)') LNOBDS - WRITE(*,'('' NEW MINIMA THIS TEMPERATURE:'',I8)') NNEW - END IF - CALL PRTVEC(XOPT,N,'CURRENT OPTIMAL X') - CALL PRTVEC(VM,N,'STEP LENGTH (VM)') - WRITE(*,'('' '')') - - RETURN - END SUBROUTINE PRT9 - - SUBROUTINE PRT10 - implicit none - WRITE(*,'(/,'' SA ACHIEVED TERMINATION CRITERIA. IER = 0. '',/)') - - RETURN - END SUBROUTINE PRT10 - - SUBROUTINE PRTVEC(VECTOR,NCOLS,NAME) - implicit none - INTEGER NCOLS, LL,I,J, LINES - REAL (KIND = 8) VECTOR(NCOLS) - CHARACTER *(*) NAME - - WRITE(*,1001) NAME - - IF (NCOLS .GT. 10) THEN - LINES = INT(NCOLS/10.) - - DO I = 1, LINES - LL = 10*(I - 1) - WRITE(*,1000) (VECTOR(J),J = 1+LL, 10+LL) - END DO - - WRITE(*,1000) (VECTOR(J),J = 11+LL, NCOLS) - ELSE - WRITE(*,1000) (VECTOR(J),J = 1, NCOLS) - END IF - -1000 FORMAT( 10(G12.5,1X)) -1001 FORMAT(/,25X,A) - - RETURN - - END SUBROUTINE PRTVEC - - ! ***************************************************************************** - ! - ! subroutine init_MPI() - ! - ! ! initialize MPI - ! - ! call MPI_INIT(mpierr) - ! - ! call MPI_COMM_RANK( MPI_COMM_WORLD, myid, mpierr ) - ! call MPI_COMM_SIZE( MPI_COMM_WORLD, numprocs, mpierr ) - ! - ! if (myid .ne. 0) root_proc = .false. - ! -!! call init_MPI_types() - ! - ! write (*,*) "MPI process ", myid, " of ", numprocs, " is alive" - ! write (*,*) "MPI process ", myid, ": root_proc=", root_proc -! -! end subroutine init_MPI - - -END MODULE math_routines 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 ebb728495..de12911f0 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 @@ -43,9 +43,11 @@ module GEOS_CatchGridCompMod RHOFS => CATCH_SNWALB_RHOFS, & SNWALB_VISMAX => CATCH_SNWALB_VISMAX, & SNWALB_NIRMAX => CATCH_SNWALB_NIRMAX, & - SLOPE => CATCH_SNWALB_SLOPE + SLOPE => CATCH_SNWALB_SLOPE, & + PEATCLSM_POROS_THRESHOLD - USE lsm_routines, ONLY : sibalb, catch_calc_soil_moist, catch_calc_watertabled + + USE lsm_routines, ONLY : sibalb, catch_calc_soil_moist, catch_calc_peatclsm_waterlevel !#for_ldas_coupling use catch_incr @@ -2679,9 +2681,9 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC ,& - LONG_NAME = 'depth_to_water_table_from_surface',& + LONG_NAME = 'depth_to_water_table_from_surface_in_peat',& UNITS = 'm' ,& - SHORT_NAME = 'WATERTABLED' ,& + SHORT_NAME = 'PEATCLSM_WATERLEVEL' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& RC=STATUS ) @@ -2690,7 +2692,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC ,& LONG_NAME = 'change_in_free_surface_water_reservoir_on_peat',& UNITS = 'kg m-2 s-1' ,& - SHORT_NAME = 'FSWCHANGE' ,& + SHORT_NAME = 'PEATCLSM_FSWCHANGE' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& RC=STATUS ) @@ -3927,8 +3929,8 @@ subroutine Driver ( RC ) real, pointer, dimension(:) :: RMELTBC002 real, pointer, dimension(:) :: RMELTOC001 real, pointer, dimension(:) :: RMELTOC002 - real, pointer, dimension(:) :: WATERTABLED - real, pointer, dimension(:) :: FSWCHANGE + real, pointer, dimension(:) :: PEATCLSM_WATERLEVEL + real, pointer, dimension(:) :: PEATCLSM_FSWCHANGE ! -------------------------------------------------------------------------- ! Local pointers for tile variables @@ -4468,8 +4470,8 @@ subroutine Driver ( RC ) call MAPL_GetPointer(EXPORT,RMELTBC002,'RMELTBC002', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT,RMELTOC001,'RMELTOC001', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT,RMELTOC002,'RMELTOC002', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT,WATERTABLED,'WATERTABLED',RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT,FSWCHANGE, 'FSWCHANGE', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,PEATCLSM_WATERLEVEL,'PEATCLSM_WATERLEVEL',RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,PEATCLSM_FSWCHANGE, 'PEATCLSM_FSWCHANGE', RC=STATUS); VERIFY_(STATUS) NTILES = size(PS) @@ -5644,9 +5646,16 @@ subroutine Driver ( RC ) if(associated(RMELTBC002)) RMELTBC002 = RMELT(:,7) if(associated(RMELTOC001)) RMELTOC001 = RMELT(:,8) if(associated(RMELTOC002)) RMELTOC002 = RMELT(:,9) - if(associated(FSWCHANGE )) FSWCHANGE = FSW_CHANGE - if(associated(WATERTABLED )) then - WATERTABLED = catch_calc_watertabled( BF1, BF2, CDCR2, POROS, WPWET, CATDEF ) + if(associated(PEATCLSM_FSWCHANGE )) then + where (POROS >= PEATCLSM_POROS_THRESHOLD) + PEATCLSM_FSWCHANGE = FSW_CHANGE + elsewhere + PEATCLSM_FSWCHANGE = MAPL_UNDEF + end where + end if + + if(associated(PEATCLSM_WATERLEVEL )) then + PEATCLSM_WATERLEVEL = catch_calc_peatclsm_waterlevel( BF1, BF2, CDCR2, POROS, WPWET, CATDEF ) endif if(associated(TPSN1)) then 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 4f4835c2e..91e9377d0 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 @@ -21,6 +21,9 @@ MODULE lsm_routines ! large-scale throughfalls. FWETC and FWETL are now passed through the resource file. ! reichle, 27 Jan 2022 - moved "public" constants & subroutine echo_catch_constants() to catch_constants.f90 + use MAPL, ONLY: & + MAPL_UNDEF + USE MAPL_ConstantsMod, ONLY: & PIE => MAPL_PI, & ! - TF => MAPL_TICE, & ! K @@ -55,7 +58,7 @@ MODULE lsm_routines PRIVATE PUBLIC :: INTERC, SRUNOFF, RZDRAIN, BASE, PARTITION, RZEQUIL, gndtp0 - PUBLIC :: SIBALB, catch_calc_soil_moist, catch_calc_zbar, catch_calc_watertabled + PUBLIC :: SIBALB, catch_calc_soil_moist, catch_calc_zbar, catch_calc_peatclsm_waterlevel PUBLIC :: catch_calc_subtile2tile PUBLIC :: gndtmp, catch_calc_tp, catch_calc_wtotl, catch_calc_ght, catch_calc_FT PUBLIC :: dampen_tc_oscillations, irrigation_rate @@ -1969,6 +1972,20 @@ end subroutine catch_calc_soil_moist ! Calculate zbar for Catchment[CN] model. ! + ! For mineral tiles, zbar is a fitted function that approximates the + ! water table depth EXCEPT for wet conditions. For low values of + ! catdef, negative values on the order of -1 meter can be encountered, + ! which would imply crazy water tables well above the surface. + ! For this reason, zbar is not suitable for general estimation + ! of water table depth. + ! + ! For PEATCLSM, zbar is a well-fitted function that describes the + ! water table depth for all wetness conditions. At zbar=0, half of + ! the microtopography is flooeded. Slightly negative values of + ! up to -14 cm (-bf2) are theoretically possible but are not realized. + ! Lesser negative values would represent slightly elevated water levels + ! that imply more than half of the microtopography is flooded. + ! ! Convention: zbar positive below ground (downward). ! ! This convention applies to water calculations, incl. subroutines RZDRAIN(), @@ -1979,7 +1996,8 @@ end subroutine catch_calc_soil_moist ! diffusion model, incl. subroutines GNDTP0(), GNDTMP(), GNDTMP_CN(). ! ! - reichle, 29 Jan 2022 - + ! - reichle, 3 Jun 2022 (updated documentation above) + function catch_calc_zbar_scalar( bf1, bf2, catdef ) result(zbar) implicit none @@ -2008,18 +2026,30 @@ end function catch_calc_zbar_vector ! ******************************************************************* - function catch_calc_watertabled( bf1, bf2, cdcr2, poros, wpwet, catdef ) result(wtd) + function catch_calc_peatclsm_waterlevel( bf1, bf2, cdcr2, poros, wpwet, catdef ) result(waterlevel) - ! calculate water table depth [m] + ! calculate water level (a.k.a. water table depth) for PEATCLSM only [m] + ! + ! Convention: water leve positive above ground (opposite of zbar convention!) implicit none real, dimension(:), intent(in) :: bf1, bf2, cdcr2, poros, wpwet, catdef - real, dimension(size(bf1)) :: wtd - - wtd = MIN( catch_calc_zbar(BF1,BF2,CATDEF), CDCR2/(1.-WPWET)/POROS/1000. ) + real, dimension(size(bf1)) :: waterlevel - end function catch_calc_watertabled + WHERE (POROS >= PEATCLSM_POROS_THRESHOLD) + + ! note change of sign from zbar + + waterlevel = -1.*MIN( catch_calc_zbar(BF1,BF2,CATDEF), CDCR2/(1.-WPWET)/POROS/1000. ) + + ELSEWHERE + + waterlevel = MAPL_UNDEF + + ENDWHERE + + end function catch_calc_peatclsm_waterlevel ! ******************************************************************* diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/GEOS_SurfaceGridComp.rc b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/GEOS_SurfaceGridComp.rc index 42d3fe363..98900a487 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/GEOS_SurfaceGridComp.rc +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/GEOS_SurfaceGridComp.rc @@ -234,14 +234,3 @@ # # GEOSagcm=>PRESCRIBE_DVG: 0 # GEOSldas=>PRESCRIBE_DVG: 0 - -# ---- Scale CATCHCN ALBEDO and FPAR -# -# 0 : NO scaling is performed (default) -# 1 : Scale albedo to match interannually varying MODIS NIRDF and VISDF anomaly -# 2 : Scale albedo to match CDFs of model fPAR to MODIS CDFs of fPAR -# 3 : Perform both 1 and 2 above -# -# GEOSagcm=>SCALE_ALBFPAR: 0 -# GEOSldas=>SCALE_ALBFPAR: 0 - diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/CMakeLists.txt index 98956b0cd..21d1777ea 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/CMakeLists.txt +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/CMakeLists.txt @@ -9,7 +9,6 @@ rasterize.F90 read_riveroutlet.F90 CubedSphere_GridMod.F90 rmTinyCatchParaMod.F90 -comp_CATCHCN_AlbScale_parameters.F90 zip.c util.c ) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/clsm_plots.pro b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/clsm_plots.pro index 8111bbacb..a15739012 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/clsm_plots.pro +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/clsm_plots.pro @@ -323,8 +323,7 @@ endfor close,1 clm_file = '../CLM_veg_typs_fracs' -clm45_file = '../CLM4.5_veg_typs_fracs' -if (file_test (clm_file) or file_test (clm45_file)) then begin +if (file_test (clm_file)) then begin endif else begin cti_mean = 0.961*cti_mean - 1.957 endelse @@ -345,21 +344,13 @@ cti_skew = 0. plot_mosaic, ncat, tile_id clm_file = '../CLM_veg_typs_fracs' -clm45_file = '../CLM4.5_veg_typs_fracs' -if (file_test (clm_file) or file_test (clm45_file)) then begin +if (file_test (clm_file)) then begin ;spawn, "/bin/cp /discover/nobackup/smahanam/GEOS5_misc/mask/images/ESA_LandCover_mask.jpg ." -if (file_test (clm_file)) then begin -plot_clm , ncat, tile_id -plot_carbon, ncat, tile_id -endif - -if (file_test (clm45_file)) then begin -plot_clm45 , ncat, tile_id -plot_carbon45, ncat, tile_id -endif + plot_clm , ncat, tile_id + plot_carbon, ncat, tile_id ; Now plot Ndep, T2m and SoilAlb ; ------------------------------ @@ -381,31 +372,31 @@ endif a6 = 0. a7 = 0. -openr,1,filename + openr,1,filename -for i = 0l,ncat -1l do begin - readf,1,a1, a2, a3, a4, a5, a6, a7 - ndep (i) = a1 - visdr(i) = a2 - visdf(i) = a3 - nirdr(i) = a4 - nirdf(i) = a5 - t2mm (i) = a6 - t2mp (i) = a7 + for i = 0l,ncat -1l do begin + readf,1,a1, a2, a3, a4, a5, a6, a7 + ndep (i) = a1 + visdr(i) = a2 + visdf(i) = a3 + nirdr(i) = a4 + nirdf(i) = a5 + t2mm (i) = a6 + t2mp (i) = a7 -endfor + endfor -close,1 -plot_three_vars2, ncat, tile_id, ndep, t2mm, t2mp -plot_soilalb, ncat, tile_id,VISDR, VISDF, NIRDR, NIRDF + close,1 + plot_three_vars2, ncat, tile_id, ndep, t2mm, t2mp + plot_soilalb, ncat, tile_id,VISDR, VISDF, NIRDR, NIRDF -ndep = 0. -visdr = 0. -visdf = 0. -nirdr = 0. -nirdf = 0. -t2mm = 0. -t2mp = 0. + ndep = 0. + visdr = 0. + visdf = 0. + nirdr = 0. + nirdf = 0. + t2mm = 0. + t2mp = 0. endif @@ -629,205 +620,7 @@ make_movies, ncat, vec2grid, 'MODIS-NIR' END ; ============================================================================== -; CLM45-Carbon classes -; ============================================================================== - -PRO plot_carbon45,ncat, tile_id - -im = n_elements(tile_id[*,0]) -jm = n_elements(tile_id[0,*]) - -dx = 360. / im -dy = 180. / jm - -x = indgen(im)*dx -180. + dx/2. -y = indgen(jm)*dy -90. + dy/2. - -clm_type = intarr (ncat,4) -clm_grid = intarr (im,jm,4) - -filename = '../CLM4.5_veg_typs_fracs' -openr,1,filename -k = 0 -v = 0 -fr= 0. -v1= 0 -v2= 0 -v3= 0 -v4 =0 - -for i = 0l,ncat -1l do begin - readf,1,k,k,v1,v2,v3,v4,fr,fr,fr,fr,v,v - clm_type(i,0) = v1 - clm_type(i,1) = v2 - clm_type(i,2) = v3 - clm_type(i,3) = v4 -endfor - -close,1 - -clm_grid (*,*,*) = !VALUES.F_NAN - -for j = 0l, jm -1l do begin - for i = 0l, im -1 do begin - if(tile_id[i,j] gt 0) then begin - clm_grid(i,j,0) = clm_type(tile_id[i,j] -1,0) - clm_grid(i,j,1) = clm_type(tile_id[i,j] -1,1) - clm_grid(i,j,2) = clm_type(tile_id[i,j] -1,2) - clm_grid(i,j,3) = clm_type(tile_id[i,j] -1,3) - endif - endfor -endfor - -clm_type = 0 - -limits = [-60,-180,90,180] -if file_test ('limits.idl') then restore,'limits.idl' - -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[700,1000], Z_Buffer=0 -;types= [ 2, 3, 4, 5, 6, 7, 8, 9, 10, 11,11a, 12, 13, 14,14a, 15,15a, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 25] -r_in = [106,202,251, 0, 29, 77,109,142,233,255,255,255,127,164,164,217,217,234,220,201,185,165,145,125,105, 85, 60, 40] -g_in = [ 91,178,154, 85,115,145,165,185, 23,131,131,191, 39, 53, 53, 72, 72,234,220,201,185,165,145,125,105, 85, 60, 40] -b_in = [154,214,153, 0, 0, 0, 0, 13, 0, 0,200, 0, 4, 3,200, 1,200,234,220,201,185,165,145,125,105, 85, 60, 40] -vtypes= [ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28] - -red = intarr (256) -green= intarr (256) -blue = intarr (256) - -red (255) = 255 -green(255) = 255 -blue (255) = 255 - -for k = 0, n_elements(vtypes) -1 do begin - red (vtypes(k)) = r_in (k) - green(vtypes(k)) = g_in (k) - blue (vtypes(k)) = b_in (k) -endfor - -TVLCT,red,green,blue - -colors = vtypes -levels = vtypes - -clm_name = strarr(27) -clm_name( 0) = 'NLEt' ; 1 needleleaf evergreen temperate tree -clm_name( 1) = 'NLEB' ; 2 needleleaf evergreen boreal tree -clm_name( 2) = 'NLDB' ; 3 needleleaf deciduous boreal tree -clm_name( 3) = 'BLET' ; 4 broadleaf evergreen tropical tree -clm_name( 4) = 'BLEt' ; 5 broadleaf evergreen temperate tree -clm_name( 5) = 'BLDT' ; 6 broadleaf deciduous tropical tree -clm_name( 6) = 'BLDt' ; 7 broadleaf deciduous temperate tree -clm_name( 7) = 'BLDB' ; 8 broadleaf deciduous boreal tree -clm_name( 8) = 'BLEtS' ; 9 broadleaf evergreen temperate shrub -clm_name( 9) = 'BLDtS' ; 10 broadleaf deciduous temperate shrub [moisture + deciduous] -clm_name(10) = 'BLDtSm'; 11 broadleaf deciduous temperate shrub [moisture stress only] -clm_name(11) = 'BLDBS' ; 12 broadleaf deciduous boreal shrub -clm_name(12) = 'AC3G' ; 13 arctic c3 grass -clm_name(13) = 'CC3G' ; 14 cool c3 grass [moisture + deciduous] -clm_name(14) = 'CC3Gm' ; 15 cool c3 grass [moisture stress only] -clm_name(15) = 'WC4G' ; 16 warm c4 grass [moisture + deciduous] -clm_name(16) = 'WC4Gm' ; 17 warm c4 grass [moisture stress only] -clm_name(17) = 'C3CROP'; 18 c3_crop -clm_name(18) = 'C3IRR' ; 19 c3_irrigated -clm_name(19) = 'CORN' ; 20 corn -clm_name(20) = 'ICORN' ; 21 irrigated corn -clm_name(21) = 'STCER' ; 22 spring temperate cereal -clm_name(22) = 'ISTCER'; 23 irrigated spring temperate cereal -clm_name(23) = 'WTCER' ; 24 winter temperate cereal -clm_name(24) = 'IWTCER'; 25 irrigated winter temperate cereal -clm_name(25) = 'SOYB' ; 26 soybean -clm_name(26) = 'ISOYB' ; 27 irrigated soybean - -Erase,255 -!p.background = 255 -!P.position=0 -!P.Multi = [0, 1, 2, 0, 1] - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits -contour, clm_grid[*,*,0],x,y,levels = levels,c_colors=colors,/cell_fill,/overplot -MAP_CONTINENTS,/COASTS,color=0,MLINETHICK=2 - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/advance -contour, clm_grid[*,*,1],x,y,levels = levels,c_colors=colors,/cell_fill,/overplot -MAP_CONTINENTS,/COASTS,color=0,MLINETHICK=2 - -n_levels = n_elements(vtypes) -alpha=fltarr(n_levels,2) -alpha(*,0)=levels (0:n_levels-1) -alpha(*,1)=levels (0:n_levels-1) -h=[0,1] - -!P.position=[0.15, 0.0+0.005, 0.85, 0.015+0.005] -clev = levels -clev (*) = 1 -contour,alpha,levels,h,levels=levels,c_colors=colors,/fill,/xstyle,/ystyle, $ - /noerase,yticks=1,ytickname=[' ',' '] ,xrange=[min(levels),max(levels)], $ - xtitle=' ', color=0,xtickv=levels, $ - C_charsize=1.0, charsize=0.5 ,xtickformat = "(A1)" -contour,alpha,levels,h,levels=levels,color=0,/overplot,c_label=clev - for k = 0,n_elements(clm_name) -1 do xyouts,levels[k]+0.5,1.1,clm_name(k) ,orientation=90,color=0 -snapshot = TVRD() - -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 700, 1000) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_JPEG, 'CLM4.5-Carbon_PRIM_veg_typs.jpg', image24, True=1, Quality=100 - -; now plotting secondary -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[700,1000], Z_Buffer=0 - -Erase,255 -!p.background = 255 -!P.position=0 -!P.Multi = [0, 1, 2, 0, 1] - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits -contour, clm_grid[*,*,2],x,y,levels = levels,c_colors=colors,/cell_fill,/overplot -MAP_CONTINENTS,/COASTS,color=0,MLINETHICK=2 - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/advance -contour, clm_grid[*,*,3],x,y,levels = levels,c_colors=colors,/cell_fill,/overplot -MAP_CONTINENTS,/COASTS,color=0,MLINETHICK=2 - -n_levels = n_elements(vtypes) -alpha=fltarr(n_levels,2) -alpha(*,0)=levels (0:n_levels-1) -alpha(*,1)=levels (0:n_levels-1) -h=[0,1] - -!P.position=[0.15, 0.0+0.005, 0.85, 0.015+0.005] -clev = levels -clev (*) = 1 -contour,alpha,levels,h,levels=levels,c_colors=colors,/fill,/xstyle,/ystyle, $ - /noerase,yticks=1,ytickname=[' ',' '] ,xrange=[min(levels),max(levels)], $ - xtitle=' ', color=0,xtickv=levels, $ - C_charsize=1.0, charsize=0.5 ,xtickformat = "(A1)" -contour,alpha,levels,h,levels=levels,color=0,/overplot,c_label=clev - for k = 0,n_elements(clm_name) -1 do xyouts,levels[k]+0.5,1.1,clm_name(k) ,orientation=90,color=0 -snapshot = TVRD() - -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 700, 1000) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_JPEG, 'CLM4.5-Carbon_SEC_veg_typs.jpg', image24, True=1, Quality=100 - -END - -; ============================================================================== -; CLM-Carbon classes +; Catchment-CN classes ; ============================================================================== PRO plot_carbon,ncat, tile_id @@ -968,7 +761,7 @@ image24 = BytArr(3, 700, 1000) image24[0,*,*] = r[snapshot] image24[1,*,*] = g[snapshot] image24[2,*,*] = b[snapshot] -Write_JPEG, 'CLM-Carbon_PRIM_veg_typs.jpg', image24, True=1, Quality=100 +Write_JPEG, 'CatchmentCN_PRIM_veg_typs.jpg', image24, True=1, Quality=100 ; now plotting secondary thisDevice = !D.Name @@ -1012,189 +805,7 @@ image24 = BytArr(3, 700, 1000) image24[0,*,*] = r[snapshot] image24[1,*,*] = g[snapshot] image24[2,*,*] = b[snapshot] -Write_JPEG, 'CLM-Carbon_SEC_veg_typs.jpg', image24, True=1, Quality=100 - -END - -; ============================================================================== -; CLM4.5 classes -; ============================================================================== - -PRO plot_clm45,ncat, tile_id - -im = n_elements(tile_id[*,0]) -jm = n_elements(tile_id[0,*]) - -dx = 360. / im -dy = 180. / jm - -x = indgen(im)*dx -180. + dx/2. -y = indgen(jm)*dy -90. + dy/2. - -clm_type = intarr (ncat,2) -clm_grid = intarr (im,jm,2) - -filename = '../CLM4.5_veg_typs_fracs' -openr,1,filename -k = 0 -v = 0 -fr= 0. -v1= 0 -v2= 0 - -for i = 0l,ncat -1l do begin - readf,1,k,k,v,v,v,v,fr,fr,fr,fr,v1,v2 - clm_type(i,0) = v1 - clm_type(i,1) = v2 -endfor - -close,1 - -clm_grid (*,*,*) = !VALUES.F_NAN - -for j = 0l, jm -1l do begin - for i = 0l, im -1 do begin - if(tile_id[i,j] gt 0) then begin - clm_grid(i,j,0) = clm_type(tile_id[i,j] -1,0) - clm_grid(i,j,1) = clm_type(tile_id[i,j] -1,1) - endif - endfor -endfor - -clm_type = 0 - -limits = [-60,-180,90,180] -if file_test ('limits.idl') then restore,'limits.idl' - -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[700,500], Z_Buffer=0 - -r_in = [255,106,202,251, 0, 29, 77,109,142,233,255,255,127,164,217,234,220,201,185,165,145,125,105, 85, 60, 40] -g_in = [245, 91,178,154, 85,115,145,165,185, 23,131,191, 39, 53, 72,234,220,201,185,165,145,125,105, 85, 60, 40] -b_in = [215,154,214,153, 0, 0, 0, 0, 13, 0, 0, 0, 4, 3, 1,234,220,201,185,165,145,125,105, 85, 60, 40] -vtypes= [ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26] - -red = intarr (256) -green= intarr (256) -blue = intarr (256) - -red (255) = 255 -green(255) = 255 -blue (255) = 255 - -for k = 0, n_elements(vtypes) -1 do begin - red (vtypes(k)) = r_in (k) - green(vtypes(k)) = g_in (k) - blue (vtypes(k)) = b_in (k) -endfor - -TVLCT,red,green,blue - -colors = vtypes -levels = vtypes - -clm_name = strarr(25) -clm_name( 0) = 'BARE' ; 1 bare -clm_name( 1) = 'NLEt' ; 2 needleleaf evergreen temperate tree -clm_name( 2) = 'NLEB' ; 3 needleleaf evergreen boreal tree -clm_name( 3) = 'NLDB' ; 4 needleleaf deciduous boreal tree -clm_name( 4) = 'BLET' ; 5 broadleaf evergreen tropical tree -clm_name( 5) = 'BLEt' ; 6 broadleaf evergreen temperate tree -clm_name( 6) = 'BLDT' ; 7 broadleaf deciduous tropical tree -clm_name( 7) = 'BLDt' ; 8 broadleaf deciduous temperate tree -clm_name( 8) = 'BLDB' ; 9 broadleaf deciduous boreal tree -clm_name( 9) = 'BLEtS'; 10 broadleaf evergreen temperate shrub -clm_name(10) = 'BLDtS'; 11 broadleaf deciduous temperate shrub -clm_name(11) = 'BLDBS'; 12 broadleaf deciduous boreal shrub -clm_name(12) = 'AC3G' ; 13 arctic c3 grass -clm_name(13) = 'CC3G' ; 14 cool c3 grass -clm_name(14) = 'WC4G' ; 15 warm c4 grass -clm_name(15) = 'C3CROP'; 16 c3_crop -clm_name(16) = 'C3IRR' ; 17 c3_irrigated -clm_name(17) = 'CORN' ; 18 corn -clm_name(18) = 'ICORN' ; 19 irrigated corn -clm_name(19) = 'STCER' ; 20 spring temperate cereal -clm_name(20) = 'ISTCER'; 21 irrigated spring temperate cereal -clm_name(21) = 'WTCER' ; 22 winter temperate cereal -clm_name(22) = 'IWTCER'; 23 irrigated winter temperate cereal -clm_name(23) = 'SOYB' ; 24 soybean -clm_name(24) = 'ISOYB' ; 25 irrigated soybean - -Erase,255 -!p.background = 255 -!P.position=0 -!P.Multi = [0, 1, 1, 0, 1] - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits -contour, clm_grid[*,*,0],x,y,levels = levels,c_colors=colors,/cell_fill,/overplot -MAP_CONTINENTS,/COASTS,color=0,MLINETHICK=2 - -n_levels = n_elements(vtypes) -alpha=fltarr(n_levels,2) -alpha(*,0)=levels (0:n_levels-1) -alpha(*,1)=levels (0:n_levels-1) -h=[0,1] - -!P.position=[0.15, 0.0+0.005, 0.85, 0.015+0.005] -clev = levels -clev (*) = 1 -contour,alpha,levels,h,levels=levels,c_colors=colors,/fill,/xstyle,/ystyle, $ - /noerase,yticks=1,ytickname=[' ',' '] ,xrange=[min(levels),max(levels)], $ - xtitle=' ', color=0,xtickv=levels, $ - C_charsize=1.0, charsize=0.5 ,xtickformat = "(A1)" -contour,alpha,levels,h,levels=levels,color=0,/overplot,c_label=clev - for k = 0,n_elements(clm_name) -1 do xyouts,levels[k]+0.5,1.1,clm_name(k) ,orientation=90,color=0 -snapshot = TVRD() - -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 700, 500) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_JPEG, 'CLM4.5_PRIM_veg_typs.jpg', image24, True=1, Quality=100 - -; now plotting secondary -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[700,500], Z_Buffer=0 - -Erase,255 -!p.background = 255 -!P.position=0 -!P.Multi = [0, 1, 1, 0, 1] - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits -contour, clm_grid[*,*,1],x,y,levels = levels,c_colors=colors,/cell_fill,/overplot -MAP_CONTINENTS,/COASTS,color=0,MLINETHICK=2 - -n_levels = n_elements(vtypes) -alpha=fltarr(n_levels,2) -alpha(*,0)=levels (0:n_levels-1) -alpha(*,1)=levels (0:n_levels-1) -h=[0,1] - -!P.position=[0.15, 0.0+0.005, 0.85, 0.015+0.005] -clev = levels -clev (*) = 1 -contour,alpha,levels,h,levels=levels,c_colors=colors,/fill,/xstyle,/ystyle, $ - /noerase,yticks=1,ytickname=[' ',' '] ,xrange=[min(levels),max(levels)], $ - xtitle=' ', color=0,xtickv=levels, $ - C_charsize=1.0, charsize=0.5 ,xtickformat = "(A1)" -contour,alpha,levels,h,levels=levels,color=0,/overplot,c_label=clev - for k = 0,n_elements(clm_name) -1 do xyouts,levels[k]+0.5,1.1,clm_name(k) ,orientation=90,color=0 -snapshot = TVRD() - -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 700, 500) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_JPEG, 'CLM4.5_SEC_veg_typs.jpg', image24, True=1, Quality=100 +Write_JPEG, 'CatchmentCN_SEC_veg_typs.jpg', image24, True=1, Quality=100 END diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/comp_CATCHCN_AlbScale_parameters.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/comp_CATCHCN_AlbScale_parameters.F90 deleted file mode 100644 index 16bd9f0f2..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/comp_CATCHCN_AlbScale_parameters.F90 +++ /dev/null @@ -1,835 +0,0 @@ -#define VERIFY_(A) IF(A/=0)THEN;PRINT *,'ERROR AT LINE ', __LINE__;STOP;ENDIF -#define ASSERT_(A) if(.not.A)then;print *,'Error:',__FILE__,__LINE__;stop;endif - -MODULE comp_CATCHCN_AlbScale_parameters - - use date_time_util, ONLY: & - date_time_type, augment_date_time - - implicit none - INCLUDE 'netcdf.inc' - - private - - public :: albedo4catchcn - - character*400, PARAMETER :: & - InBCSDIR = '/discover/nobackup/smahanam/MERRA3/FPAR/SMAP_EASEv2_M09/', & - !EXPDIR = '/archive/u/smahanam/FPAR-ALB/e0004s_wet2/output/SMAP_EASEv2_M09_GLOBAL/', & - EXPDIR = '/discover/nobackup/borescan/BCS/add_to_l_land/e0004s_wet2/output/SMAP_EASEv2_M09_GLOBAL/', & - EXNAME = 'e0004s_wet2', & - InGFILE = 'SMAP_EASEv2_M09_3856x1624' - - ! character*400 :: GFILE = 'til/CF0180x6C_TM0720xTM0410-Pfafstetter.til' - real, parameter :: MAPL_PI = 3.14159265358979323846d0 - integer, parameter :: yearB = 2001, yearE = 2015, InNTILES = 1684725, NOCTAD = 46 - integer, parameter :: yearB1= 2002 - contains - - SUBROUTINE albedo4catchcn (gfile) - - implicit none - character (*), intent (in) :: gfile - integer :: NTILES - integer, dimension (:), allocatable :: id_loc - - call preprocess_m09 - open (10, file = 'clsm/catchment.def', form = 'formatted', status= 'old', action = 'read') - read (10, *) NTILES - close (10, status = 'keep') - - allocate (id_loc (1: NTILES)) - - call get_id_loc (NTILES, trim (GFILE)//'.til', id_loc) - call regrid_alb (NTILES, id_loc) - - end SUBROUTINE albedo4catchcn - - ! ------------------------------------------------------------------------------- - - SUBROUTINE get_id_loc (NT, gfile, id_loc) - - implicit none - - integer, intent (in) :: NT - integer, dimension (NT), intent (inout) :: id_loc - character(*), intent (in) :: gfile - integer :: n, i, nplus, t_count - real, dimension (:), allocatable :: lon, lat, m09_lon, m09_lat, tid_m09 - integer, allocatable, dimension (:) :: sub_tid - real , allocatable, dimension (:) :: sub_lon, sub_lat, rev_dist - real :: dw, dx, dy, min_lon, max_lon, min_lat, max_lat - logical :: tile_found - logical, allocatable, dimension(:) :: mask - integer, allocatable :: low_ind(:), upp_ind(:) - -! --------- VARIABLES FOR *OPENMP* PARALLEL ENVIRONMENT ------------ -! -! NOTE: "!$" is for conditional compilation -! -logical :: running_omp = .false. -! -!$ integer :: omp_get_thread_num, omp_get_num_threads -! -integer :: n_threads=1 -! -! -! ----------- OpenMP PARALLEL ENVIRONMENT ---------------------------- -! -! FIND OUT WHETHER -omp FLAG HAS BEEN SET DURING COMPILATION -! -!$ running_omp = .true. ! conditional compilation -! -! ECHO BASIC OMP VARIABLES -! -!$OMP PARALLEL DEFAULT(NONE) SHARED(running_omp,n_threads) -! -!$OMP SINGLE -! -!$ n_threads = omp_get_num_threads() -! -!$ write (*,*) 'running_omp = ', running_omp -!$ write (*,*) -!$ write (*,*) 'parallel OpenMP with ', n_threads, 'threads' -!$ write (*,*) -!$OMP ENDSINGLE -! -!$OMP CRITICAL -!$ write (*,*) 'thread ', omp_get_thread_num(), ' alive' -!$OMP ENDCRITICAL -! -!$OMP BARRIER -! -!$OMP ENDPARALLEL - - allocate (lon (1: NT)) - allocate (lat (1: NT)) - allocate (m09_lon (1: InNTILES)) - allocate (m09_lat (1: InNTILES)) - allocate (tid_m09 (1: InNTILES)) - - call ReadCNTilFile (trim(InBCSDIR)//trim(InGFILE)//'.til', InNTILES, m09_lon, m09_lat) - call ReadCNTilFile (trim(GFILE), NT, lon, lat) - - Id_loc = -9999 - do n = 1, InNTILES - tid_m09(n) = n - end do - - ! Domain decomposition - ! -------------------- - - allocate(low_ind(n_threads)) - allocate(upp_ind(n_threads)) - low_ind(1) = 1 - upp_ind(n_threads) = nt - - if (running_omp) then - do i=1,n_threads-1 - upp_ind(i) = low_ind(i) + (NT/n_threads) - 1 - low_ind(i+1) = upp_ind(i) + 1 - ! print *,i,low_ind(i),upp_ind(i) - end do - ! print *,i,low_ind(i),upp_ind(i) - end if - -!$OMP PARALLELDO DEFAULT(NONE) & -!$OMP SHARED( n_threads, low_ind, upp_ind, Id_loc, & -!$OMP lon, lat, m09_lon, m09_lat, tid_m09) & -!$OMP PRIVATE(n,i,t_count,min_lon, max_lon, min_lat, max_lat, & -!$OMP sub_tid, nplus, sub_lon, sub_lat, rev_dist, dw, & -!$OMP tile_found, mask) - - DO t_count = 1,n_threads - - allocate (mask (1: InNTILES)) - - OUT_TILES : do n = low_ind(t_count),upp_ind(t_count) - if(MOD(n,10000) == 0) print *,'In ID_LOC', t_count,n - dw = 0.25 - - ZOOMOUT : do - - tile_found = .false. - - ! Min/Max lon/lat of the working window - ! ------------------------------------- - - min_lon = MAX(lon (n) - dw, -180.) - max_lon = MIN(lon (n) + dw, 180.) - min_lat = MAX(lat (n) - dw, -90.) - max_lat = MIN(lat (n) + dw, 90.) - - mask = .false. - mask = ((m09_lat >= min_lat .and. m09_lat <= max_lat).and.(m09_lon >= min_lon .and. m09_lon <= max_lon)) - nplus = count(mask = mask) - - if(nplus < 0) then - dw = dw + 0.5 - CYCLE - endif - - allocate (sub_tid (1:nplus)) - allocate (sub_lon (1:nplus)) - allocate (sub_lat (1:nplus)) - allocate (rev_dist(1:nplus)) - - sub_tid = PACK (tid_m09 , mask= mask) - sub_lon = PACK (m09_lon , mask= mask) - sub_lat = PACK (m09_lat , mask= mask) - - ! compute distance from the tile - - sub_lat = sub_lat * MAPL_PI/180. - sub_lon = sub_lon * MAPL_PI/180. - - SEEK : if(Id_loc(n) < 0) then - - rev_dist = 1.e20 - - do i = 1,nplus - - rev_dist(i) = haversine(to_radian(lat(n)), to_radian(lon(n)), & - sub_lat(i), sub_lon(i)) - - end do - - FOUND : if(minval (rev_dist) < 1.e19) then - Id_loc(n) = sub_tid(minloc(rev_dist,1)) - tile_found = .true. - - if(Id_loc(n) ==0) then - print *, rev_dist - print *, sub_tid - print *, minval (rev_dist) - print *, minloc(rev_dist,1) - stop - endif - endif FOUND - - endif SEEK - - deallocate (sub_tid, sub_lon, sub_lat, rev_dist) - - if(tile_found) GO TO 100 - - ! if not increase the window size - dw = dw + 0.25 - - end do ZOOMOUT - -100 continue - - END do OUT_TILES - - deallocate (mask) - - end DO ! PARALLEL - -!$OMP ENDPARALLELDO - - END SUBROUTINE get_id_loc - - ! ***************************************************************************** - - function to_radian(degree) result(rad) - - ! degrees to radians - real,intent(in) :: degree - real :: rad - - rad = degree*MAPL_PI/180. - - end function to_radian - - ! ------------------------------------------------------------------------------------------------- - - SUBROUTINE regrid_alb (NTILES, id_loc) - - implicit none - integer, intent (in) :: NTILES - integer, dimension (NTILES), intent (in) :: id_loc - character*10 :: string - integer :: STATUS, ncid, NCOutID, t, time_slice, time_slice_next, yr, mn, dd, yr1, mn1, dd1, n_tslices - character (len=4), dimension (:), allocatable :: MMDD, MMDD_next - real, allocatable, dimension (:) :: varin, varout - - n_tslices = NOCTAD - - status = NF_OPEN('data/CATCH/MODIS-Albedo2/MCD43GF_wsa_H11V13.nc',NF_NOWRITE, ncid); VERIFY_(STATUS) - status = NF_INQ_DIM (ncid,3,string, n_tslices); VERIFY_(STATUS) - allocate (MMDD (0: n_tslices + 1)) - allocate (MMDD_next (0: n_tslices + 1)) - status = NF_GET_VARA_text(ncid, 3,(/1,1/),(/4,n_tslices/),MMDD(1:n_tslices)); VERIFY_(STATUS) - status = NF_CLOSE(ncid); VERIFY_(STATUS) - - mmdd(0) = mmdd(n_tslices) - mmdd(n_tslices + 1)= mmdd(1) - mmdd_next(0:n_tslices - 1) = mmdd(1:n_tslices) - mmdd_next(n_tslices: n_tslices + 1) = mmdd (1:2) - - allocate (varin (1:InNTILES)) - allocate (varout(1:NTILES)) - - STATUS = NF_OPEN('data/CATCH/CATCHCN_fPAR_Alb_stats2.nc4', NF_NOWRITE,NCOutID) ; VERIFY_(STATUS) - open (10, file = 'clsm/MODISVISmean.dat' ,form='unformatted',status='unknown',convert='little_endian') - open (11, file = 'clsm/MODISNIRmean.dat' ,form='unformatted',status='unknown',convert='little_endian') - open (12, file = 'clsm/MODISVISstd.dat' ,form='unformatted',status='unknown',convert='little_endian') - open (13, file = 'clsm/MODISNIRstd.dat' ,form='unformatted',status='unknown',convert='little_endian') - open (14, file = 'clsm/MODELFPARmean.dat' ,form='unformatted',status='unknown',convert='little_endian') - open (15, file = 'clsm/MODELFPARstd.dat' ,form='unformatted',status='unknown',convert='little_endian') - open (16, file = 'clsm/MODISFPARmean.dat' ,form='unformatted',status='unknown',convert='little_endian') - open (17, file = 'clsm/MODISFPARstd.dat' ,form='unformatted',status='unknown',convert='little_endian') - - do t =0,n_tslices+1 - - time_slice = t - yr = 1 - yr1= 1 - if(t == 0) then - time_slice = n_tslices - yr = 1 - 1 - endif - - if(t >= n_tslices) then - yr1 = 1 + 1 - if(t ==n_tslices + 1) then - time_slice = 1 - yr = 1 + 1 - endif - endif - - read(mmdd(t),'(i2.2,i2.2)') mn,dd - read(mmdd_next(t),'(i2.2,i2.2)') mn1,dd1 - - STATUS = NF_GET_VARA_REAL(NCOutID,VARID(NCOutID,'MODISVISmean' ),(/1,time_slice/), (/InNTILES,1/), varin ) ; VERIFY_(STATUS) - varout = varin (id_loc) - write(10) float((/yr,mn,dd,0,0,0,yr1,mn1,dd1,0,0,0,ntiles,1/)) - write(11) float((/yr,mn,dd,0,0,0,yr1,mn1,dd1,0,0,0,ntiles,1/)) - write(12) float((/yr,mn,dd,0,0,0,yr1,mn1,dd1,0,0,0,ntiles,1/)) - write(13) float((/yr,mn,dd,0,0,0,yr1,mn1,dd1,0,0,0,ntiles,1/)) - write(14) float((/yr,mn,dd,0,0,0,yr1,mn1,dd1,0,0,0,ntiles,1/)) - write(15) float((/yr,mn,dd,0,0,0,yr1,mn1,dd1,0,0,0,ntiles,1/)) - write(16) float((/yr,mn,dd,0,0,0,yr1,mn1,dd1,0,0,0,ntiles,1/)) - write(17) float((/yr,mn,dd,0,0,0,yr1,mn1,dd1,0,0,0,ntiles,1/)) - - STATUS = NF_GET_VARA_REAL(NCOutID,VARID(NCOutID,'MODISVISmean' ),(/1,time_slice/), (/InNTILES,1/), varin ) ; VERIFY_(STATUS) - varout = varin (id_loc) - write (10) varout - - STATUS = NF_GET_VARA_REAL(NCOutID,VARID(NCOutID,'MODISNIRmean' ),(/1,time_slice/), (/InNTILES,1/), varin ) ; VERIFY_(STATUS) - varout = varin (id_loc) - write (11) varout - - STATUS = NF_GET_VARA_REAL(NCOutID,VARID(NCOutID,'MODISVISstd' ),(/1,time_slice/) , (/InNTILES,1/), varin ) ; VERIFY_(STATUS) - varout = varin (id_loc) - write (12) varout - - STATUS = NF_GET_VARA_REAL(NCOutID,VARID(NCOutID,'MODISNIRstd' ),(/1,time_slice/) , (/InNTILES,1/), varin ) ; VERIFY_(STATUS) - varout = varin (id_loc) - write (13) varout - - STATUS = NF_GET_VARA_REAL(NCOutID,VARID(NCOutID,'MODELFPARmean' ),(/1,time_slice/), (/InNTILES,1/), varin ) ; VERIFY_(STATUS) - varout = varin (id_loc) - write (14) varout - - STATUS = NF_GET_VARA_REAL(NCOutID,VARID(NCOutID,'MODELFPARstd' ),(/1,time_slice/) , (/InNTILES,1/), varin ) ; VERIFY_(STATUS) - varout = varin (id_loc) - write (15) varout - - STATUS = NF_GET_VARA_REAL(NCOutID,VARID(NCOutID,'MODISFPARmean' ),(/1,time_slice/), (/InNTILES,1/), varin ) ; VERIFY_(STATUS) - varout = varin (id_loc) - write (16) varout - - STATUS = NF_GET_VARA_REAL(NCOutID,VARID(NCOutID,'MODISFPARstd' ),(/1,time_slice/) , (/InNTILES,1/), varin ) ; VERIFY_(STATUS) - varout = varin (id_loc) - write (17) varout - end do - - deallocate (varin, varout) - - close (10 , status = 'keep') - close (11 , status = 'keep') - close (12 , status = 'keep') - close (13 , status = 'keep') - close (14 , status = 'keep') - close (15 , status = 'keep') - close (16 , status = 'keep') - close (17 , status = 'keep') - - END SUBROUTINE regrid_alb - - ! ------------------------------------------------------------------------------------------------- - - SUBROUTINE preprocess_m09 - - implicit none - logical :: file_exists - INTEGER :: NT, ND, DAY, year, STATUS, NCOutID, k - CHARACTER*8 :: YYYYMMDD - CHARACTER*6 :: YYYYMM - CHARACTER*4 :: YYYY - CHARACTER*2 :: MM, DD - real :: yr,mn,dy,dum,yr1,mn1,dy1 - - real, allocatable, dimension (:,:) :: MODIS_VISDF, MODIS_NIRDF, MODEL_fPAR - real, allocatable, dimension (:) :: data_read, data_save, & - MODISVISmean, MODISNIRmean, MODISVISstd, MODISNIRstd, MODELFPARmean, MODELFPARstd, & - MODISFPARmean, MODISFPARstd - integer, allocatable, dimension (:) :: ldas2bcs - type(date_time_type), dimension (YearE - YearB + 1) :: octad_time - - - inquire(file='data/CATCH/CATCHCN_fPAR_Alb_stats2.nc4', exist=file_exists) - if(.not. file_exists) call create_stat_file - -! open (99,file='clsm/comp_CATCHCN_AlbScale_parameters.log', form ='formatted', action='write', status= 'unknown') - - STATUS = NF_OPEN ('data/CATCH/CATCHCN_fPAR_Alb_stats2.nc4', NF_WRITE,NCOutID) ; VERIFY_(STATUS) - - allocate (MODIS_VISDF (1:InNTILES, yearE - yearB + 1)) - allocate (MODIS_NIRDF (1:InNTILES, yearE - yearB + 1)) - allocate (MODEL_fPAR (1:InNTILES, yearE - yearB + 1)) - allocate (ldas2bcs (1:InNTILES)) - allocate (data_read (1:InNTILES)) - allocate (data_save (1:InNTILES)) - allocate (MODISVISmean (1:InNTILES)) - allocate (MODISNIRmean (1:InNTILES)) - allocate (MODISVISstd (1:InNTILES)) - allocate (MODISNIRstd (1:InNTILES)) - allocate (MODELFPARmean(1:InNTILES)) - allocate (MODELFPARstd (1:InNTILES)) - allocate (MODISFPARmean(1:InNTILES)) - allocate (MODISFPARstd (1:InNTILES)) - - open (10,file =trim(EXPDIR)//'rc_out/'//trim(EXNAME)//'.ldas_tilecoord.bin',status='old',form='unformatted',convert='big_endian') - read (10) k - read (10) LDAS2BCS - close(10, status = 'keep') - - OPEN_FILES1 : DO year = YearB, YearE - - write (YYYY ,'(i4.4)') year - open (10 + year - yearB, file = trim(InBCSDIR)//'MODIS6/'//YYYY//'//visdf.dat', form = 'unformatted', action = 'read') - open (30 + year - yearB, file = trim(InBCSDIR)//'MODIS6/'//YYYY//'//nirdf.dat', form = 'unformatted', action = 'read') -! WRITE (99,*)10 + year - yearB, YYYY//'//visdf.dat' -! WRITE (99,*)30 + year - yearB, YYYY//'//nirdf.dat' -! WRITE (99,*) ' ' - WRITE (*,*)10 + year - yearB, YYYY//'//visdf.dat' - WRITE (*,*)30 + year - yearB, YYYY//'//nirdf.dat' - WRITE (*,*) ' ' - octad_time(year - yearB + 1)%year = year - 1 - octad_time(year - yearB + 1)%month = 12 - octad_time(year - yearB + 1)%day = 31 - octad_time(year - yearB + 1)%hour = 0 - octad_time(year - yearB + 1)%min = 0 - octad_time(year - yearB + 1)%sec = 0 - - END DO OPEN_FILES1 - - ND = 8 - - OCTAD_LOOP : DO NT = 1, NOCTAD - - ! BEGIN READING MODIS VISDF/NIRDF - - MODIS_VISDF = 0. - MODIS_NIRDF = 0. - MODEL_fPAR = 0. - - if(NT == NOCTAD) ND = 5 -! WRITE (99,*) NT, ND, yearB, yearE - print *, NT, ND, yearB, yearE - - READ_YEARS : DO year = YearB, YearE - - read (10 + year - yearB) modis_visdf (:, year - yearB + 1) - read (30 + year - yearB) modis_nirdf (:, year - yearB + 1) - - DAILY_LOOP : DO day = 1,ND - - call augment_date_time(86400, octad_time(year - yearB + 1)) - - write (YYYY, '(i4.4)') octad_time(year - yearB + 1)%year - write (MM , '(i2.2)') octad_time(year - yearB + 1)%month - write (DD , '(i2.2)') octad_time(year - yearB + 1)%day - - YYYYMMDD = YYYY//MM//DD -! WRITE (99,*) trim(EXNAME)//'.ens_avg.ldas_tile_daily_out.'//YYYYMMDD//'.bin' - print *, trim(EXNAME)//'.ens_avg.ldas_tile_daily_out.'//YYYYMMDD//'.bin' - open (60, file = trim(EXPDIR)//'cat/ens_avg/Y'//YYYY//'/M'//MM//'/'// & - trim(EXNAME)//'.ens_avg.ldas_tile_daily_out.'//YYYYMMDD//'.bin', & - form = 'unformatted', convert='big_endian', action = 'read') - - do k = 1,3 - read (60) data_read - if(k == 2) data_save = data_read - end do - - MODEL_fPAR (:,year - yearB + 1) = MODEL_fPAR (:,year - yearB + 1) + data_save / (data_read + 1.e-20)/ real (ND) - close (60, status = 'keep') - - END DO DAILY_LOOP - - ! reoder to the order of BCs - - data_read = MODEL_fPAR (:,year - yearB + 1) - - do k = 1, InNTILES - MODEL_fPAR (LDAS2BCS(k),year - yearB + 1) = data_read (k) - end do - END DO READ_YEARS - - ! COMPUTE STATS - - CALL compute_stats (MODIS_VISDF, MODIS_NIRDF, MODEL_fPAR, & - MODISVISmean, MODISNIRmean, MODISVISstd, MODISNIRstd, MODELFPARmean, MODELFPARstd) - - STATUS = NF_PUT_VARA_REAL(NCOutID,VARID(NCOutID,'MODISVISmean' ),(/1,NT/), (/InNTILES,1/), MODISVISmean ) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCOutID,VARID(NCOutID,'MODISNIRmean' ),(/1,NT/), (/InNTILES,1/), MODISNIRmean ) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCOutID,VARID(NCOutID,'MODISVISstd' ),(/1,NT/), (/InNTILES,1/), MODISVISstd ) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCOutID,VARID(NCOutID,'MODISNIRstd' ),(/1,NT/), (/InNTILES,1/), MODISNIRstd ) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCOutID,VARID(NCOutID,'MODELFPARmean' ),(/1,NT/), (/InNTILES,1/), MODELFPARmean) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCOutID,VARID(NCOutID,'MODELFPARstd' ),(/1,NT/), (/InNTILES,1/), MODELFPARstd ) ; VERIFY_(STATUS) - - END DO OCTAD_LOOP - - CLOSE_FILES1 : DO year = YearB, YearE - - close (10 + year - yearB, status = 'keep') - close (30 + year - yearB, status = 'keep') - - END DO CLOSE_FILES1 - - ! MODIS FPAR - ! ---------- - - deallocate (MODIS_VISDF, MODIS_NIRDF, MODEL_fPAR) - allocate (MODIS_VISDF (1:InNTILES, yearE - yearB1 + 1)) - allocate (MODIS_NIRDF (1:InNTILES, yearE - yearB1 + 1)) - allocate (MODEL_fPAR (1:InNTILES, yearE - yearB1 + 1)) - - OPEN_FILES2 : DO year = YearB1, YearE - - write (YYYY ,'(i4.4)') year - open (10 + year - yearB1, file = trim(InBCSDIR)//'MODIS6/'//YYYY//'//visdf.dat', form = 'unformatted', action = 'read') - open (30 + year - yearB1, file = trim(InBCSDIR)//'MODIS6/'//YYYY//'//nirdf.dat', form = 'unformatted', action = 'read') - open (50 + year - yearB1, file = trim(InBCSDIR)//'MODIS6/'//YYYY//'//fpar.dat', form = 'unformatted', action = 'read') -! WRITE (99,*) " " -! WRITE (99,*) "MODIS FPAR" -! WRITE (99,*) "==========" -! WRITE (99,*) " " - -! WRITE (99,*)10 + year - yearB1, YYYY//'//visdf.dat' -! WRITE (99,*)30 + year - yearB1, YYYY//'//nirdf.dat' -! WRITE (99,*)50 + year - yearB1, YYYY//'//fpar.dat' -! WRITE (99,*) ' ' - WRITE (*,*)10 + year - yearB1, YYYY//'//visdf.dat' - WRITE (*,*)30 + year - yearB1, YYYY//'//nirdf.dat' - WRITE (*,*)50 + year - yearB1, YYYY//'//fpar.dat' - WRITE (*,*) ' ' - read (50 + year - yearB1) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 - WRITE (*,*) yr,mn,dy,yr1,mn1,dy1 - read (50 + year - yearB1) MODEL_FPAR (:, year - yearB1 + 1) - - octad_time(year - yearB1 + 1)%year = year - 1 - octad_time(year - yearB1 + 1)%month = 12 - octad_time(year - yearB1 + 1)%day = 31 - octad_time(year - yearB1 + 1)%hour = 0 - octad_time(year - yearB1 + 1)%min = 0 - octad_time(year - yearB1 + 1)%sec = 0 - - END DO OPEN_FILES2 - - ND = 8 - - OCTAD_LOOP2 : DO NT = 1, NOCTAD - - ! BEGIN READING MODIS VISDF/NIRDF/FPAR - - MODIS_VISDF = 0. - MODIS_NIRDF = 0. - MODEL_fPAR = 0. - - if(NT == NOCTAD) ND = 5 -! WRITE (99,*) NT, ND, yearB1, yearE - print *, NT, ND, yearB1, yearE - READ_YEARS2 : DO year = YearB1, YearE - - read (10 + year - yearB1) modis_visdf (:, year - yearB1 + 1) - read (30 + year - yearB1) modis_nirdf (:, year - yearB1 + 1) - read (50 + year - yearB1) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 - WRITE (*,*) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 - read (50 + year - yearB1) MODEL_FPAR (:, year - yearB1 + 1) - END DO READ_YEARS2 - - ! COMPUTE STATS - - CALL compute_stats (MODIS_VISDF, MODIS_NIRDF, MODEL_fPAR, & - MODISVISmean, MODISNIRmean, MODISVISstd, MODISNIRstd, MODELFPARmean, MODELFPARstd) - - STATUS = NF_PUT_VARA_REAL(NCOutID,VARID(NCOutID,'MODISFPARmean' ),(/1,NT/), (/InNTILES,1/), MODELFPARmean) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCOutID,VARID(NCOutID,'MODISFPARstd' ),(/1,NT/), (/InNTILES,1/), MODELFPARstd ) ; VERIFY_(STATUS) - - END DO OCTAD_LOOP2 - - CLOSE_FILES2 : DO year = YearB1, YearE - - close (10 + year - yearB1, status = 'keep') - close (30 + year - yearB1, status = 'keep') - close (50 + year - yearB1, status = 'keep') - - END DO CLOSE_FILES2 - - STATUS = NF_CLOSE (NCOutID ) - - END SUBROUTINE preprocess_m09 - - ! ----------------------------------------------------------------- - - SUBROUTINE create_stat_file - - implicit none - - integer :: NCFOutID, STATUS, vid, tid, lid, n, k - character (22) :: time_stamp, tmpstr - integer, dimension(8) :: date_time_values - real, dimension (:), allocatable :: lons, lats - - STATUS = NF_CREATE ('data/CATCH/CATCHCN_fPAR_Alb_stats2.nc4', NF_NETCDF4, NCFOutID );VERIFY_(STATUS) - STATUS = NF_DEF_DIM(NCFOutID, 'octad', NOCTAD, TID) ; VERIFY_(STATUS) - STATUS = NF_DEF_DIM(NCFOutID, 'tiles', InNTILES, LID) ; VERIFY_(STATUS) - STATUS = NF_DEF_VAR(NCFOutID, 'lon' , NF_FLOAT ,1 ,(/LID/), vid);VERIFY_(STATUS) - STATUS = NF_DEF_VAR(NCFOutID, 'lat' , NF_FLOAT ,1 ,(/LID/), vid);VERIFY_(STATUS) - status = NF_DEF_VAR(NCFOutID, 'MODISVISmean', NF_FLOAT ,2 ,(/LID,TID/), vid);VERIFY_(STATUS) - status = NF_DEF_VAR(NCFOutID, 'MODISNIRmean', NF_FLOAT ,2 ,(/LID,TID/), vid);VERIFY_(STATUS) - status = NF_DEF_VAR(NCFOutID, 'MODISVISstd' , NF_FLOAT ,2 ,(/LID,TID/), vid);VERIFY_(STATUS) - status = NF_DEF_VAR(NCFOutID, 'MODISNIRstd' , NF_FLOAT ,2 ,(/LID,TID/), vid);VERIFY_(STATUS) - status = NF_DEF_VAR(NCFOutID, 'MODELFPARmean',NF_FLOAT ,2 ,(/LID,TID/), vid);VERIFY_(STATUS) - status = NF_DEF_VAR(NCFOutID, 'MODELFPARstd' ,NF_FLOAT ,2 ,(/LID,TID/), vid);VERIFY_(STATUS) - status = NF_DEF_VAR(NCFOutID, 'MODISFPARmean',NF_FLOAT ,2 ,(/LID,TID/), vid);VERIFY_(STATUS) - status = NF_DEF_VAR(NCFOutID, 'MODISFPARstd' ,NF_FLOAT ,2 ,(/LID,TID/), vid);VERIFY_(STATUS) - ! Global attributes - - call date_and_time(VALUES=date_time_values) - - write (time_stamp,'(i4.4,a1,i2.2,a1,i2.2,1x,a2,1x,i2.2,a1,i2.2,a1,i2.2)') & - date_time_values(1),'-',date_time_values(2),'-',date_time_values(3),'at', & - date_time_values(5),':',date_time_values(6),':',date_time_values(7) - - status = NF_PUT_ATT_TEXT(NCFOutID, NF_GLOBAL, 'CreatedBy', LEN_TRIM("Sarith Mahanama"), & - trim("Sarith Mahanama")) - status = NF_PUT_ATT_TEXT(NCFOutID, NF_GLOBAL, 'Date' , LEN_TRIM(time_stamp),trim(time_stamp)) - - status = NF_ENDDEF(NCFOutID ) - - ! Read and put lat/lon data - - allocate (lons (1:InNTILES)) - allocate (lats (1:InNTILES)) - - open (10, file = trim(InBCSDIR)//trim(InGFILE)//'.til', form = 'formatted', status = 'old') - - do n = 1,8 - read (10,*) tmpstr - end do - - do n = 1, InNTILES - read (10,*) k, k, lons(n), lats(n) - end do - - close (10, status = 'keep') - - STATUS = NF_PUT_VARA_REAL(NCFOutID,VARID(NCFOutID,'lon' ),(/1/), (/InNTILES/), lons) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCFOutID,VARID(NCFOutID,'lat' ),(/1/), (/InNTILES/), lats) ; VERIFY_(STATUS) - - STATUS = NF_CLOSE (NCFOutID ) - - END SUBROUTINE create_stat_file - - ! ---------------------------------------------------------------------- - - SUBROUTINE compute_stats (MODIS_VISDF, MODIS_NIRDF, MODEL_fPAR, & - MODISVISmean, MODISNIRmean, MODISVISstd, MODISNIRstd, MODELFPARmean, MODELFPARstd) - - implicit none - real, dimension (:,:), intent (in) :: MODIS_VISDF, MODIS_NIRDF, MODEL_fPAR - real, dimension (:) , intent (inout) :: MODISVISmean, MODISNIRmean, MODISVISstd, & - MODISNIRstd, MODELFPARmean, MODELFPARstd - integer :: NX, NY, N, t - REAL :: MF, MV, MN, SF, SV, SN, ZV, ZN, CV, CN, CF - - NX = size (MODIS_VISDF,1) - NY = size (MODIS_VISDF,2) - print *,'Entered compute_stats', NX, NY - if (NX /= InNTILES) then - print *, 'NX NTILLES MISMAATCH : ', InNTILES, NX, NY - STOP - ENDIF - - DO N = 1, NX - -! MF = SUM (MODEL_fPAR (N,:)) / REAL (NY) -! MV = SUM (MODIS_VISDF (N,:)) / REAL (NY) -! MN = SUM (MODIS_nirDF (N,:)) / REAL (NY) - MF = 0. - MV = 0. - MN = 0. - CV = 0. - CN = 0. - CF = 0. - - do T = 1, NY - if ((MODEL_fPAR (N,T) >= 0.).AND.(MODEL_fPAR (N,T) <= 1.)) then - MF = MF + MODEL_fPAR (N,T) - CF = CF + 1. - endif - if ((MODIS_VISDF (N,T) >= 0.).AND.(MODIS_VISDF (N,T) <= 1.)) then - MV = MV + MODIS_VISDF (N,T) - CV = CV + 1. - endif - if ((MODIS_NIRDF (N,T) >= 0.).AND.(MODIS_NIRDF (N,T) <= 1.)) then - MN = MN + MODIS_NIRDF (N,T) - CN = CN + 1. - endif - end do - - IF(CF > 0) MF = MF / CF - IF(CV > 0) MV = MV / CV - IF(CN > 0) MN = MN / CN - - ! STANDARD DEVIATION - - SF = 1.e-15 - SV = 1.e-15 - SN = 1.e-15 - - do T = 1, NY - if ((MODEL_fPAR (N,T) >= 0.).AND.(MODEL_fPAR (N,T) <= 1.)) SF = SF + (MODEL_fPAR (N,t) - MF)*(MODEL_fPAR (N,t) - MF) - if ((MODIS_VISDF (N,T) >= 0.).AND.(MODIS_VISDF (N,T) <= 1.)) SV = SV + (MODIS_VISDF (N,t) - MV)*(MODIS_VISDF (N,t) - MV) - if ((MODIS_NIRDF (N,T) >= 0.).AND.(MODIS_NIRDF (N,T) <= 1.)) SN = SN + (MODIS_NIRDF (N,t) - MN)*(MODIS_NIRDF (N,t) - MN) - end do - - IF(CF > 0) SF = SQRT (SF / CF) - IF(CV > 0) SV = SQRT (SV / CV) - IF(CN > 0) SN = SQRT (SN / CN) - - ! CORRELATION - - ZV = 0. - ZN = 0. - - DO T = 1, NY - ZV = ZV + (MODEL_fPAR (N,t) - MF)*(MODIS_VISDF (N,t) - MV)/SF/SV - ZN = ZN + (MODEL_fPAR (N,t) - MF)*(MODIS_NIRDF (N,t) - MN)/SF/SV - END DO - - ZV = ZV / REAL (NY) - ZN = ZN / REAL (NY) - - MODISVISmean (N) = MV - MODISNIRmean (N) = MN - MODISVISstd (N) = SV - MODISNIRstd (N) = SN - MODELFPARmean(N) = MF - MODELFPARstd (N) = SF - - if(ZV < 0.) MODISVISstd (N) = -1. * MODISVISstd (N) - if(Zn < 0.) MODISnirstd (N) = -1. * MODISnirstd (N) - - END DO - - print *,'Leaving compute_stats' - - END SUBROUTINE compute_stats - - ! ---------------------------------------------------------------------- - - integer function VarID (NCFID, VNAME) - - integer, intent (in) :: NCFID - character(*), intent (in) :: VNAME - integer :: status - - STATUS = NF_INQ_VARID (NCFID, trim(VNAME) ,VarID) - IF (STATUS .NE. NF_NOERR) & - CALL HANDLE_ERR(STATUS, trim(VNAME)) - - end function VarID - - ! ----------------------------------------------------------------------- - - SUBROUTINE HANDLE_ERR(STATUS, Line) - - INTEGER, INTENT (IN) :: STATUS - CHARACTER(*), INTENT (IN) :: Line - - IF (STATUS .NE. NF_NOERR) THEN - PRINT *, trim(Line),': ',STATUS, NF_STRERROR(STATUS) - STOP 'Stopped' - ENDIF - - END SUBROUTINE HANDLE_ERR - - ! ***************************************************************************** - - subroutine ReadCNTilFile (InCNTileFile, nt, xlon, xlat) - - implicit none - character(*), intent (in) :: InCNTileFile - integer , intent (in) :: nt - real, dimension (nt), intent(inout) :: xlon, xlat - integer :: n,icnt,ityp - real :: xval,yval, pf - - open(11,file=InCNTileFile, & - form='formatted',action='read',status='old') - - do n = 1,8 ! skip header - read(11,*) - end do - - icnt = 0 - ityp = 100 - - do while (ityp == 100) ! loop over land tiles - read(11,*) ityp,pf,xval,yval - if(ityp == 100) then - icnt = icnt + 1 - xlon(icnt) = xval - xlat(icnt) = yval - endif - end do - - close(11) - - end subroutine ReadCNTilFile - - ! ***************************************************************************** - - real function haversine(deglat1,deglon1,deglat2,deglon2) - ! great circle distance -- adapted from Matlab - real,intent(in) :: deglat1,deglon1,deglat2,deglon2 - real :: a,c, dlat,dlon,lat1,lat2 - real,parameter :: radius = 6371.0E3 - -! dlat = to_radian(deglat2-deglat1) -! dlon = to_radian(deglon2-deglon1) - ! lat1 = to_radian(deglat1) -! lat2 = to_radian(deglat2) - dlat = deglat2-deglat1 - dlon = deglon2-deglon1 - lat1 = deglat1 - lat2 = deglat2 - a = (sin(dlat/2))**2 + cos(lat1)*cos(lat2)*(sin(dlon/2))**2 - if(a>=0. .and. a<=1.) then - c = 2*atan2(sqrt(a),sqrt(1-a)) - haversine = radius*c / 1000. - else - haversine = 1.e20 - endif - end function - - ! ***************************************************************************** - - END MODULE comp_CATCHCN_AlbScale_parameters diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/create_README.csh b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/create_README.csh index 88c5384cb..dda2457bb 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/create_README.csh +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/create_README.csh @@ -75,11 +75,15 @@ set toc_rout="`printf '\\n7. GLOBAL RUNOFF ROUTING MODEL DATA .................. arrays and on latitude (for differentiating certain types, such as Arctic c3 grass). \\n \ Bare soil from the ESA land cover classification is mapped into the broadleaf deciduous \\n \ shrub type, since bare soil is not an allowed type in our implementation.\\n \ +\\n \ + Initially, a separate mapping of the ESA land cover classification to the (17) CLM4.0 PFTs and \\n \ + (25) CLM4.5 PFTs was implemented. However, the decision was made later to use\\n \ + the same 17 (CLM4.0-based) PFTs for both CatchmentCNCLM40 and CatchmentCNCLM45. Any processing \\n \ + specific to CLM4.5 PFTs was removed. \\n \ \\n \ For Catchment-CN, the stress deciduous types (crop and temperate shrubs/grass) utilized \\n \ by CLM4 is replaced by a mix of two sub-types, one that is seasonally deciduous (with a \\n \ - daylight trigger) and one that is not. Crop type has been further classified to 10 \\n \ - different types in CLM4.5, thus they were not sub-divided into further sub-types, however. \\n \ + daylight trigger) and one that is not. \\n \ Both sub-types are subject to moisture stress triggers\\n \ but not to temperature (freezing) stress triggers. The removal of the temperature stress \\n \ trigger eliminated unnatural swings in leaf carbon during brief temperature stress senescence\\n \ @@ -424,7 +428,7 @@ cat << _EOI_ > clsm/intro 3.2 Data files and images 3.2.1 Mosaic vegetation types and fractions 3.2.2 vegdyn input data (mosaic primary type, canopy height, and roughness) for GEOS - 3.2.3 CLM/CLM4.5 and CLM/CLM4.5-carbon vegetation types and fractions + 3.2.3 CLM and Catchment-CN vegetation types and fractions 3.2.4 CLM Nitrogen Deposition, annual mean T2m, soil back ground albedo 3.2.5 CLM4.5 ABM, PEATF, GDP, HDM, and soil field capacity 3.2.6 CLM4.5 lightening frequency climatology @@ -1043,8 +1047,8 @@ _EOV1_ if( $MYMASK == GEOS5_10arcsec_mask | $MYMASK == GEOS5_10arcsec_mask.nc | $MYMASK == GEOS5_10arcsec_mask_freshwater-lakes.nc ) then cat << _EOV2_ > clsm/veg2 - 3.2.3 CLM/CLM4.5, CLM/CLM4.5-carbon, CLM4.5 and CLM4.5-carbon vegetation types and fractions - file names: CLM_veg_typs_fracs and CLM4.5_veg_typs_fracs + 3.2.3 CLM and Catchment-CN vegetation types and fractions + file names: CLM_veg_typs_fracs do n = 1, ${NTILES} read ([UNIT],'(2I10,4I3,4f7.2,2I3,2f7.2)') & tile_index, pfaf_code, & @@ -1056,67 +1060,55 @@ cat << _EOV2_ > clsm/veg2 where for each tile: (1) tile_index [-] number (2) pfaf_code [-] ${pfaf_des} - (3) CLM-C_pt1 [-] CLM-Carbon primary type 1 - [Figure 7a : top panel of "plots/CLM-Carbon_PRIM_veg_typs.jpg and plots/CLM4.5-Carbon_PRIM_veg_typs.jpg"] - (4) CLM-C_pt2 [-] CLM-Carbon primary type 2 (moisture stressed only) - [Figure 7b : bottom panel of "plots/CLM-Carbon_PRIM_veg_typs.jpg and plots/CLM4.5-Carbon_PRIM_veg_typs.jpg"] - (5) CLM-C_st1 [-] CLM-Carbon secondary type 1 - [Figure 8a : top panel of "plots/CLM-Carbon_SEC_veg_typs.jpg and plots/CLM4.5-Carbon_SEC_veg_typs.jpg"] - (6) CLM-C_st2 [-] CLM-Carbon secondary type 2 (moisture stressed only) - [Figure 8b : bottom panel of "plots/CLM-Carbon_SEC_veg_typs.jpg and plots/CLM4.5-Carbon_SEC_veg_typs.jpg"] - (7) CLM-C_pf1 [-] CLM-Carbon fraction of 1st primary type - (8) CLM-C_pf2 [-] CLM-Carbon fraction of 2nd primary type (moisture stressed only) - (9) CLM-C_sf1 [-] CLM-Carbon fraction of 1st secondary type - (10)CLM-C_sf2 [-] CLM-Carbon fraction of 2nd secondary type (moisture stressed only) + (3) CLM-C_pt1 [-] Catchment-CN primary type 1 + [Figure 7a : top panel of "plots/CLM-Carbon_PRIM_veg_typs.jpg"] + (4) CLM-C_pt2 [-] Catchment-CN primary type 2 (moisture stressed only) + [Figure 7b : bottom panel of "plots/CLM-Carbon_PRIM_veg_typs.jpg"] + (5) CLM-C_st1 [-] Catchment-CN secondary type 1 + [Figure 8a : top panel of "plots/CLM-Carbon_SEC_veg_typs.jpg"] + (6) CLM-C_st2 [-] Catchment-CN secondary type 2 (moisture stressed only) + [Figure 8b : bottom panel of "plots/CLM-Carbon_SEC_veg_typs.jpg"] + (7) CLM-C_pf1 [-] Catchment-CN fraction of 1st primary type + (8) CLM-C_pf2 [-] Catchment-CN fraction of 2nd primary type (moisture stressed only) + (9) CLM-C_sf1 [-] Catchment-CN fraction of 1st secondary type + (10)CLM-C_sf2 [-] Catchment-CN fraction of 2nd secondary type (moisture stressed only) (11)CLM_pt [-] CLM primary type - [Figure 9 : "plots/CLM_PRIM_veg_typs.jpg and plots/CLM4.5_PRIM_veg_typs.jpg"] + [Figure 9 : "plots/CLM_PRIM_veg_typs.jpg"] (12)CLM_st [-] CLM secondary type - [Figure 10: "plots/CLM_SEC_veg_typs.jpg and plots/CLM4.5_SEC_veg_typs.jpg"] + [Figure 10: "plots/CLM_SEC_veg_typs.jpg"] (13)CLM_pf [-] CLM fraction of primary type (14)CLM_sf [-] CLM fraction of secondary type - Please see below Table 2 for CLM (CLM4.5) and CLM-Carbon (CLM4.5-Carbon) land cover classification + Please see below Table 2 for CLM and Catchment-CN land cover classification =================================================================================== - Land Cover CLM (CLM4.5) CLM-Carbon Map - (CLM4.5-Carbon) - Class Class Legend + Land Cover CLM Catchment-CN Map + Class Class Legend ----------------------------------------------------------------------------------- - Bare 1 - BARE - Needleleaf evergreen temperate tree 2 1 NLEt - Needleleaf evergreen boreal tree 3 2 NLEB - Needleleaf deciduous boreal tree 4 3 NLDB - Broadleaf evergreen tropical tree 5 4 BLET - Broadleaf evergreen temperate tree 6 5 BLEt - Broadleaf deciduous tropical tree 7 6 BLDT - Broadleaf deciduous temperate tree 8 7 BLDt - Broadleaf deciduous boreal tree 9 8 BLDB - Broadleaf evergreen temperate shrub 10 9 BLEtS - Broadleaf deciduous temperate shrub 11 10 BLDtS - Broadleaf deciduous temperate shrub[moisture stress only] - 11 BLDtSm - Broadleaf deciduous boreal shrub 12 12 BLDBS - Arctic c3 grass 13 13 AC3G - Cool c3 grass 14 14 CC3G - Cool c3 grass [moisture stress only] - 15 CC3Gm - Warm c4 grass 15 16 WC4G - Warm c4 grass [moisture stress only] - 17 WC4Gm - Crop 16 18 CROP (-) - Crop [moisture stress only] - 19 CROPm(-) - (C3_crop) (16) (18) C3CROP - (C3_irrigated) (17) (19) C3IRR - (Corn) (18) (20) CORN - (Irrigated corn) (19) (21) ICORN - (Spring temperate cereal) (20) (22) STCER - (Irrigated spring temperate cereal) (21) (23) ISTCER - (winter temperate cereal) (22) (24) WTCER - (Irrigated winter temperate cereal) (23) (25) IWTCER - (Soybean) (24) (26) SOYB - (Irrigated Soybean) (25) (27) ISOYB + Bare 1 - BARE + Needleleaf evergreen temperate tree 2 1 NLEt + Needleleaf evergreen boreal tree 3 2 NLEB + Needleleaf deciduous boreal tree 4 3 NLDB + Broadleaf evergreen tropical tree 5 4 BLET + Broadleaf evergreen temperate tree 6 5 BLEt + Broadleaf deciduous tropical tree 7 6 BLDT + Broadleaf deciduous temperate tree 8 7 BLDt + Broadleaf deciduous boreal tree 9 8 BLDB + Broadleaf evergreen temperate shrub 10 9 BLEtS + Broadleaf deciduous temperate shrub 11 10 BLDtS + Broadleaf deciduous temperate shrub[moisture stress only] - 11 BLDtSm + Broadleaf deciduous boreal shrub 12 12 BLDBS + Arctic c3 grass 13 13 AC3G + Cool c3 grass 14 14 CC3G + Cool c3 grass [moisture stress only] - 15 CC3Gm + Warm c4 grass 15 16 WC4G + Warm c4 grass [moisture stress only] - 17 WC4Gm + Crop 16 18 CROP (-) + Crop [moisture stress only] - 19 CROPm(-) Water 17 - ----------------------------------------------------------------------------------- - Table 2: CLM and CLM-Carbon land cover classification description. - CLM-4.5 and CLM-4.5-Carbon types are in brackets. + Table 2: CLM and Catchment-CN land cover classification description. 3.2.4 Nitrogen Deposition, annual mean 2m Tair, soil back gorund albedo file name: CLM_Ndep_SoilAlb @@ -1575,18 +1567,26 @@ APPENDIX I - mkCatchParam tag, input options, and log _EOF2_ -cat << _EOF_ > clsm/back - -===================================================================================== -================================ END OF README FILE ================================ -===================================================================================== +# Do NOT append "END OF README FILE" here. This csh script does not know +# the return status of the Fortran executables. If a Fortran executable +# stops prematurely, the README file should not look finished. +# Maybe proper error handling can be added in the future. +# -reichle, 3 May 2022 -_EOF_ +###cat << _EOF_ > clsm/back +### +###===================================================================================== +###================================ END OF README FILE ================================ +###===================================================================================== +### +###_EOF_ sed -e "s/============================================================/ /g" clsm/mkCatchParam.log > clsm/log -cat clsm/intro clsm/soil clsm/veg1 clsm/veg2 clsm/README1 clsm/README2 clsm/README3 clsm/log clsm/back >> clsm/README +###cat clsm/intro clsm/soil clsm/veg1 clsm/veg2 clsm/README1 clsm/README2 clsm/README3 clsm/log clsm/back >> clsm/README +cat clsm/intro clsm/soil clsm/veg1 clsm/veg2 clsm/README1 clsm/README2 clsm/README3 clsm/log >> clsm/README -/bin/rm clsm/intro clsm/soil clsm/veg1 clsm/veg2 clsm/README1 clsm/README2 clsm/README3 clsm/log clsm/back +###/bin/rm clsm/intro clsm/soil clsm/veg1 clsm/veg2 clsm/README1 clsm/README2 clsm/README3 clsm/log clsm/back +/bin/rm clsm/intro clsm/soil clsm/veg1 clsm/veg2 clsm/README1 clsm/README2 clsm/README3 clsm/log ################################################################################# ## Plotting maps of fixed parameters and making movies of seasonal parameters ## diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/make_bcs b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/make_bcs index 20171d2e6..a174aff89 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/make_bcs +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/make_bcs @@ -78,7 +78,7 @@ set BOLD = "\033[1m" ####################################################################### ####################################################################### -set pwd = `pwd` +set bin_dir = `pwd` # make_bcs must be run from install/bin directory set C1 = $RED set C2 = $BLUE @@ -359,9 +359,9 @@ foreach orslv ($orslvs) set HOSTNAME = `hostname | rev | cut -c3- | rev` if ( $HOSTNAME == discover ) then - set l_data = /discover/nobackup/projects/gmao/ssd/land/l_data/LandBCs_files_for_mkCatchParam/V001/ + set input_dir = /discover/nobackup/projects/gmao/ssd/land/l_data/LandBCs_files_for_mkCatchParam/V001/ else - set l_data = /nobackup/gmao_SIteam/ModelData/l_data/LandBCs_files_for_mkCatchParam/V001/ + set input_dir = /nobackup/gmao_SIteam/ModelData/l_data/LandBCs_files_for_mkCatchParam/V001/ endif @@ -372,9 +372,9 @@ if ( $orslv == O1 | $orslv == T2 | $orslv == T3 | $orslv == T4 | \ # ------------------------------------------------------------------------------------------------- if ( $lbcsv == F25 | $lbcsv == GM4 | $lbcsv == ICA ) then - set GLOBAL_CATCH_DATA = ${l_data}/global.cat_id.catch.DL + set GLOBAL_CATCH_DATA = ${input_dir}/global.cat_id.catch.DL else - set GLOBAL_CATCH_DATA = ${l_data}/GEOS5_10arcsec_mask_freshwater-lakes.nc + set GLOBAL_CATCH_DATA = ${input_dir}/GEOS5_10arcsec_mask_freshwater-lakes.nc endif @@ -384,9 +384,9 @@ else if ( $orslv == O2 | $orslv == O3 | $orslv == CS ) then # -------------------------------------------------------------------------------------------------------------- if ( $lbcsv == F25 | $lbcsv == GM4 | $lbcsv == ICA ) then - set GLOBAL_CATCH_DATA = ${l_data}/global.cat_id.catch.GreatLakesCaspian_Updated.DL + set GLOBAL_CATCH_DATA = ${input_dir}/global.cat_id.catch.GreatLakesCaspian_Updated.DL else - set GLOBAL_CATCH_DATA = ${l_data}/GEOS5_10arcsec_mask.nc + set GLOBAL_CATCH_DATA = ${input_dir}/GEOS5_10arcsec_mask.nc endif else @@ -397,7 +397,7 @@ else endif if($HRCODE == m1 | $HRCODE == m3 | $HRCODE == m9 | $HRCODE == m36 | $HRCODE == m25) then - set GLOBAL_CATCH_DATA = ${l_data}/GEOS5_10arcsec_mask.nc + set GLOBAL_CATCH_DATA = ${input_dir}/GEOS5_10arcsec_mask.nc endif set MASKFILE = `echo ${GLOBAL_CATCH_DATA} | rev | cut -d / -f1 | rev ` @@ -713,14 +713,12 @@ cat << _EOF_ > $BCJOB #SBATCH --time=12:00:00 #SBATCH --ntasks=28 #SBATCH --job-name=$BCNAME.j -#SBATCH --chdir=$pwd/$BCDIR #SBATCH --constraint=sky - -cd $pwd cd $BCDIR -/bin/ln -s $pwd +/bin/ln -s $bin_dir +source bin/g5_modules mkdir -p til rst data/MOM5 data/MOM6 clsm/plots ln -s /discover/nobackup/projects/gmao/ssd/aogcm/ocean_bcs/MOM5/360x200 data/MOM5/360x200 ln -s /discover/nobackup/projects/gmao/ssd/aogcm/ocean_bcs/MOM5/720x410 data/MOM5/720x410 @@ -729,7 +727,7 @@ ln -s /discover/nobackup/projects/gmao/ssd/aogcm/ocean_bcs/MOM6/72x36 data/MOM6/ ln -s /discover/nobackup/projects/gmao/ssd/aogcm/ocean_bcs/MOM6/1440x1080 data/MOM6/1440x1080 cd data -ln -s $l_data CATCH +ln -s $input_dir CATCH cd ../ @@ -782,14 +780,6 @@ cd clsm.${IM}x${JM} /bin/mv green.dat green_clim_${RS}_DC.data /bin/mv lnfm.dat lnfm_clim_${RS}_DC.data /bin/mv ndvi.dat ndvi_clim_${RS}_DC.data - /bin/mv MODELFPARmean.dat MODELFPARmean_${RS}_DC.dat - /bin/mv MODELFPARstd.dat MODELFPARstd_${RS}_DC.dat - /bin/mv MODISFPARmean.dat MODISFPARmean_${RS}_DC.dat - /bin/mv MODISFPARstd.dat MODISFPARstd_${RS}_DC.dat - /bin/mv MODISNIRmean.dat MODISNIRmean_${RS}_DC.dat - /bin/mv MODISNIRstd.dat MODISNIRstd_${RS}_DC.dat - /bin/mv MODISVISmean.dat MODISVISmean_${RS}_DC.dat - /bin/mv MODISVISstd.dat MODISVISstd_${RS}_DC.dat /bin/rm -f sedfile cat > sedfile << EOF @@ -821,7 +811,6 @@ cd ../ AlbMap* \ plots \ CLM_veg_typs_fracs \ - CLM4.5_veg_typs_fracs \ mkCatchParam.log \ CLM_NDep_SoilAlb_T2m \ CLM4.5_abm_peatf_gdp_hdm_fc \ @@ -902,14 +891,12 @@ cat << _EOF_ > $BCJOB #SBATCH --time=12:00:00 #SBATCH --ntasks=1 #SBATCH --job-name=$BCNAME.j -#SBATCH --chdir=$pwd/$BCDIR #SBATCH --constraint=sky - -cd $pwd cd $BCDIR -/bin/ln -s $pwd +/bin/ln -s $bin_dir +source bin/g5_modules mkdir -p til rst data/MOM5 data/MOM6 clsm/plots ln -s /discover/nobackup/projects/gmao/ssd/aogcm/ocean_bcs/MOM5/360x200 data/MOM5/360x200 ln -s /discover/nobackup/projects/gmao/ssd/aogcm/ocean_bcs/MOM5/720x410 data/MOM5/720x410 @@ -918,7 +905,7 @@ ln -s /discover/nobackup/projects/gmao/ssd/aogcm/ocean_bcs/MOM6/72x36 data/MOM6/ ln -s /discover/nobackup/projects/gmao/ssd/aogcm/ocean_bcs/MOM6/1440x1080 data/MOM6/1440x1080 cd data -ln -s $l_data CATCH +ln -s $input_dir CATCH cd ../ @@ -970,12 +957,11 @@ cat << _EOF_ > $BCJOB-2 #SBATCH --time=12:00:00 #SBATCH --ntasks=28 #SBATCH --job-name=$BCNAME-2.j -#SBATCH --chdir=$pwd/$BCDIR #SBATCH --constraint=sky - -cd $pwd cd $BCDIR + +source bin/g5_modules setenv MASKFILE $MASKFILE limit stacksize unlimited @@ -1015,14 +1001,6 @@ cd clsm.C${NC} /bin/mv green.dat green_clim_${RC}.data /bin/mv lnfm.dat lnfm_clim_${RC}.data /bin/mv ndvi.dat ndvi_clim_${RC}.data - /bin/mv MODELFPARmean.dat MODELFPARmean_${RC}.dat - /bin/mv MODELFPARstd.dat MODELFPARstd_${RC}.dat - /bin/mv MODISFPARmean.dat MODISFPARmean_${RC}.dat - /bin/mv MODISFPARstd.dat MODISFPARstd_${RC}.dat - /bin/mv MODISNIRmean.dat MODISNIRmean_${RC}.dat - /bin/mv MODISNIRstd.dat MODISNIRstd_${RC}.dat - /bin/mv MODISVISmean.dat MODISVISmean_${RC}.dat - /bin/mv MODISVISstd.dat MODISVISstd_${RC}.dat /bin/rm -f sedfile if( $CUBED_SPHERE_OCEAN == TRUE ) then @@ -1064,7 +1042,6 @@ cd ../ AlbMap* \ plots \ CLM_veg_typs_fracs \ - CLM4.5_veg_typs_fracs \ mkCatchParam.log \ CLM_NDep_SoilAlb_T2m \ CLM4.5_abm_peatf_gdp_hdm_fc \ @@ -1101,14 +1078,12 @@ cat << _EOF_ > $BCJOB #SBATCH --time=12:00:00 #SBATCH --ntasks=28 #SBATCH --job-name=$BCNAME.j -#SBATCH --chdir=$pwd/$BCDIR #SBATCH --constraint=sky - -cd $pwd cd $BCDIR -/bin/ln -s $pwd +/bin/ln -s $bin_dir +source bin/g5_modules mkdir -p til rst data/MOM5 data/MOM6 clsm/plots ln -s /discover/nobackup/projects/gmao/ssd/aogcm/ocean_bcs/MOM5/360x200 data/MOM5/360x200 ln -s /discover/nobackup/projects/gmao/ssd/aogcm/ocean_bcs/MOM5/720x410 data/MOM5/720x410 @@ -1117,7 +1092,7 @@ ln -s /discover/nobackup/projects/gmao/ssd/aogcm/ocean_bcs/MOM6/72x36 data/MOM6/ ln -s /discover/nobackup/projects/gmao/ssd/aogcm/ocean_bcs/MOM6/1440x1080 data/MOM6/1440x1080 cd data -ln -s $l_data CATCH +ln -s $input_dir CATCH cd ../ @@ -1182,14 +1157,6 @@ cd clsm.C${NC} /bin/mv green.dat green_clim_${RC}.data /bin/mv lnfm.dat lnfm_clim_${RC}.data /bin/mv ndvi.dat ndvi_clim_${RC}.data - /bin/mv MODELFPARmean.dat MODELFPARmean_${RC}.dat - /bin/mv MODELFPARstd.dat MODELFPARstd_${RC}.dat - /bin/mv MODISFPARmean.dat MODISFPARmean_${RC}.dat - /bin/mv MODISFPARstd.dat MODISFPARstd_${RC}.dat - /bin/mv MODISNIRmean.dat MODISNIRmean_${RC}.dat - /bin/mv MODISNIRstd.dat MODISNIRstd_${RC}.dat - /bin/mv MODISVISmean.dat MODISVISmean_${RC}.dat - /bin/mv MODISVISstd.dat MODISVISstd_${RC}.dat /bin/rm -f sedfile if( $CUBED_SPHERE_OCEAN == TRUE ) then @@ -1231,7 +1198,6 @@ cd ../ AlbMap* \ plots \ CLM_veg_typs_fracs \ - CLM4.5_veg_typs_fracs \ mkCatchParam.log \ CLM_NDep_SoilAlb_T2m \ CLM4.5_abm_peatf_gdp_hdm_fc \ @@ -1311,16 +1277,15 @@ cat << _EOF_ > $BCJOB #SBATCH --time=12:00:00 #SBATCH --ntasks=28 #SBATCH --job-name=$BCNAME.j -#SBATCH --chdir=$pwd/$BCDIR #SBATCH --constraint=sky -cd $pwd cd $BCDIR -/bin/ln -s $pwd +/bin/ln -s $bin_dir +source bin/g5_modules mkdir -p til rst data/MOM5 data/MOM6 clsm/plots cd data -ln -s $l_data CATCH +ln -s $input_dir CATCH cd ../ limit stacksize unlimited if ( $EVERSION == EASEv2 ) then @@ -1365,14 +1330,6 @@ cd clsm.${IM}x${JM} /bin/mv green.dat green_clim_${RS}_DE.data /bin/mv lnfm.dat lnfm_clim_${RS}_DE.data /bin/mv ndvi.dat ndvi_clim_${RS}_DE.data - /bin/mv MODELFPARmean.dat MODELFPARmean_${RS}_DE.dat - /bin/mv MODELFPARstd.dat MODELFPARstd_${RS}_DE.dat - /bin/mv MODISFPARmean.dat MODISFPARmean_${RS}_DE.dat - /bin/mv MODISFPARstd.dat MODISFPARstd_${RS}_DE.dat - /bin/mv MODISNIRmean.dat MODISNIRmean_${RS}_DE.dat - /bin/mv MODISNIRstd.dat MODISNIRstd_${RS}_DE.dat - /bin/mv MODISVISmean.dat MODISVISmean_${RS}_DE.dat - /bin/mv MODISVISstd.dat MODISVISstd_${RS}_DE.dat cd ../ @@ -1399,7 +1356,6 @@ cd ../ pfaf_fractions.dat \ plots \ CLM_veg_typs_fracs \ - CLM4.5_veg_typs_fracs \ mkCatchParam.log \ Grid2Catch_TransferData.nc \ CLM_NDep_SoilAlb_T2m \ diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/mkCatchParam.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/mkCatchParam.F90 index 3d25d1671..fe035a9e5 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/mkCatchParam.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/mkCatchParam.F90 @@ -23,14 +23,16 @@ PROGRAM mkCatchParam use rmTinyCatchParaMod use process_hres_data - use comp_CATCHCN_AlbScale_parameters, ONLY : albedo4catchcn ! use module_irrig_params, ONLY : create_irrig_params implicit none include 'netcdf.inc' - integer :: NC = i_raster, NR = j_raster + ! The default is NC=i_raster=8640, NR=j_raster=4320 via "use rmTinyCatchParaMod", but + ! NC and NR are typically overwritten through command-line arguments "-x nx -y ny". + + integer :: NC = i_raster, NR = j_raster character*4 :: LBSV = 'DEF' character*128 :: GridName = '' character*128 :: ARG, MaskFile @@ -57,6 +59,7 @@ PROGRAM mkCatchParam type (regrid_map) :: maparc30, mapgeoland2,maparc60 character*200 :: tmpstring, tmpstring1, tmpstring2 character*200 :: fname_tmp, fname_tmp2, fname_tmp3, fname_tmp4 + integer :: N_tile ! --------- VARIABLES FOR *OPENMP* PARALLEL ENVIRONMENT ------------ ! @@ -211,8 +214,14 @@ PROGRAM mkCatchParam write (log_file,'(a)')'Cube-Sphere Grid - assuming dateline-on-edge (DE)' endif - inquire(file='clsm/catch_params.nc4', exist=file_exists) - if (.not.file_exists) CALL open_landparam_nc4_files + ! ****************************************************************************** + ! + ! IMPORTANT: The top-level make_bcs script should not allow this program to + ! run when ./clsm/ exists. Consequently, across "Steps [xx]" below, + ! the "inquire()" statements should be obsolete, and the case + ! "Using existing file" should never happen. + ! + ! ****************************************************************************** ! Creating catchment.def ! ---------------------- @@ -233,7 +242,15 @@ PROGRAM mkCatchParam write (log_file,'(a)')'Skipping step for EASE grid. ' endif write (log_file,'(a)')' ' - + + open (10, file = 'clsm/catchment.def', form = 'formatted', status = 'old', & + action = 'read') + read (10, *) N_tile + close (10, status = 'keep') + + inquire(file='clsm/catch_params.nc4', exist=file_exists) + if (.not.file_exists) CALL open_landparam_nc4_files(N_tile) + ! Creating cti_stats.dat ! ---------------------- @@ -281,19 +298,6 @@ PROGRAM mkCatchParam endif write (log_file,'(a)')' ' - tmpstring = 'Step 05: Vegetation types using ESA land cover (CatchCNCLM45)' - fname_tmp = 'clsm/CLM4.5_veg_typs_fracs' - write (log_file,'(a,a,a,a)') trim(tmpstring), ' (', trim(fname_tmp), ')' - inquire(file=trim(fname_tmp), exist=file_exists) - if (.not.file_exists) then - write (log_file,'(a)')' Creating file...' - call ESA2CLM_45 (nc,nr,gridnamer) - write (log_file,'(a)')' Done.' - else - write (log_file,'(a)')' Using existing file.' - endif - write (log_file,'(a)')' ' - else tmpstring = 'Step 03: Vegetation types using IGBP SiB2 land cover (MOSAIC/Catch)' @@ -333,7 +337,7 @@ PROGRAM mkCatchParam ! creating mapping arrays if necessary - tmpstring = 'Step 06: Vegetation climatologies' + tmpstring = 'Step 05: Vegetation climatologies' write (log_file,'(a,a,a)') trim(tmpstring),' ', trim(LAIBCS) if((trim(LAIBCS) == 'MODGEO').or.(trim(LAIBCS) == 'GEOLAND2')) then @@ -368,7 +372,7 @@ PROGRAM mkCatchParam write (log_file,'(a,a)')' --> ', trim(fname_tmp) inquire(file=trim(fname_tmp), exist=file_exists) if (.not.file_exists) then - write (log_file,'(a)')' Creating file...' + write (log_file,'(a)')' Creating file... (resolution will be added to file name later)' if (trim(LAIBCS) == 'GSWP2') then call process_gswp2_veg (nc,nr,regrid,'grnFrac',gridnamer) else @@ -387,7 +391,7 @@ PROGRAM mkCatchParam write (log_file,'(a,a)')' --> ', trim(fname_tmp) inquire(file=trim(fname_tmp), exist=file_exists) if (.not.file_exists) then - write (log_file,'(a)')' Creating file...' + write (log_file,'(a)')' Creating file... (resolution will be added to file name later)' redo_modis = .true. if (trim(LAIBCS) == 'GSWP2') call process_gswp2_veg (nc,nr,regrid,'LAI',gridnamer) @@ -436,7 +440,7 @@ PROGRAM mkCatchParam write (log_file,'(a,a)')' --> ', trim(fname_tmp) inquire(file=trim(fname_tmp), exist=file_exists) if (.not.file_exists) then - write (log_file,'(a)')' Creating file...' + write (log_file,'(a)')' Creating file... (resolution will be added to file name later)' call gimms_clim_ndvi (nc,nr,gridnamer) write (log_file,'(a)')' Done.' else @@ -454,7 +458,7 @@ PROGRAM mkCatchParam ! MODIS1 data on native grid and produces 8/16-day MODIS Albedo climatology - tmpstring = 'Step 07: Albedo climatologies' + tmpstring = 'Step 06: Albedo climatologies' write (log_file,'(a,a,a)') trim(tmpstring),' ', trim(MODALB) if(MODALB == 'MODIS1') then @@ -479,11 +483,13 @@ PROGRAM mkCatchParam endif if(MODALB == 'MODIS2') then - fname_tmp = 'clsm/AlbMap.WS.8-day.tile.0.7_5.0.dat' - write (log_file,'(a,a)')' --> ', trim(fname_tmp) - inquire(file=trim(fname_tmp), exist=file_exists) - if (.not.file_exists) then - write (log_file,'(a)')' Creating file...' + fname_tmp = 'clsm/AlbMap.WS.8-day.tile.0.3_0.7.dat' + fname_tmp2 = 'clsm/AlbMap.WS.8-day.tile.0.7_5.0.dat' + write (log_file,'(a,a,a,a)')' --> ', trim(fname_tmp), ', ', trim(fname_tmp2) + inquire(file=trim(fname_tmp ), exist=file_exists ) + inquire(file=trim(fname_tmp2), exist=file_exists2) + if ((.not.file_exists).or.(.not.file_exists2)) then + write (log_file,'(a)')' Creating files...' call modis_alb_on_tiles_high (43200,21600,maparc30,MODALB,gridnamer) write (log_file,'(a)')' Done.' else @@ -499,7 +505,7 @@ PROGRAM mkCatchParam ! --------------------------------------------- - tmpstring = 'Step 08: Albedo scale factors' + tmpstring = 'Step 07: Albedo scale factors' write (log_file,'(a,a,a)') trim(tmpstring),' ', trim(MODALB) ! NOTE: There are two files with albedo scale factors: "visdf.dat" and "nirdf.dat". @@ -512,7 +518,7 @@ PROGRAM mkCatchParam inquire(file=trim(fname_tmp2), exist=file_exists2) if ((redo_modis).or.(.not.file_exists).or.(.not.file_exists2)) then ! if(.not.F25Tag) then - write (log_file,'(a)')' Creating files...' + write (log_file,'(a)')' Creating files... (resolution will be added to file name later)' call modis_scale_para_high (ease_grid,MODALB,gridnamet) ! else ! This option is for legacy sets like Fortuna 2.1 @@ -548,7 +554,7 @@ PROGRAM mkCatchParam ! 1) NGDC soil properties, 2) HWSD-STATSGO2 Soil Properties ! --------------------------------------------------------------------- - tmpstring = 'Step 09: Soil parameters ' // trim(SOILBCS) + tmpstring = 'Step 08: Soil parameters ' // trim(SOILBCS) fname_tmp = 'clsm/soil_param.first' write (log_file,'(a,a,a,a)') trim(tmpstring), ' (', trim(fname_tmp), ')' inquire(file=trim(fname_tmp), exist=file_exists) @@ -565,7 +571,7 @@ PROGRAM mkCatchParam endif write (log_file,'(a)')' ' - tmpstring = 'Step 10: CLSM model parameters ' // trim(SOILBCS) + tmpstring = 'Step 09: CLSM model parameters ' // trim(SOILBCS) fname_tmp = 'clsm/ar.new' fname_tmp2 = 'clsm/bf.dat' fname_tmp3 = 'clsm/ts.dat' @@ -594,7 +600,7 @@ PROGRAM mkCatchParam write (log_file,'(a)')' Uncomment associated lines in source to generate 7.5 minute raster file.' write (log_file,'(a)')' ' - tmpstring = 'Step 11: CatchCNCLM40 NDep T2m SoilAlb parameters' + tmpstring = 'Step 10: CatchCNCLM40 NDep T2m SoilAlb parameters' fname_tmp = 'clsm/CLM_NDep_SoilAlb_T2m' write (log_file,'(a,a,a,a)') trim(tmpstring), ' (', trim(fname_tmp), ')' ! create this file only if matching veg types file already exists @@ -608,7 +614,7 @@ PROGRAM mkCatchParam endif write (log_file,'(a)')' ' - tmpstring = 'Step 12: CatchCNCLM45 abm peatf gdp hdm fc parameters' + tmpstring = 'Step 11: CatchCNCLM45 abm peatf gdp hdm fc parameters' fname_tmp = 'clsm/CLM4.5_abm_peatf_gdp_hdm_fc' write (log_file,'(a,a,a,a)') trim(tmpstring), ' (', trim(fname_tmp), ')' inquire(file=trim(fname_tmp), exist=file_exists) @@ -621,12 +627,12 @@ PROGRAM mkCatchParam endif write (log_file,'(a)')' ' - tmpstring = 'Step 13: CatchCNCLM45 lightning frequency' + tmpstring = 'Step 12: CatchCNCLM45 lightning frequency' fname_tmp = 'clsm/lnfm.dat' write (log_file,'(a,a,a,a)') trim(tmpstring), ' (', trim(fname_tmp), ')' inquire(file=trim(fname_tmp), exist=file_exists) if (.not.file_exists) then - write (log_file,'(a)')' Creating file...' + write (log_file,'(a)')' Creating file... (resolution will be added to file name later)' call CLM45_clim_parameters (nc,nr,gridnamer) write (log_file,'(a)')' Done.' else @@ -634,7 +640,7 @@ PROGRAM mkCatchParam endif write (log_file,'(a)')' ' - tmpstring = 'Step 14: Country and state codes' + tmpstring = 'Step 13: Country and state codes' fname_tmp = 'clsm/country_and_state_code.data' write (log_file,'(a,a,a,a)') trim(tmpstring), ' (', trim(fname_tmp), ')' inquire(file=trim(fname_tmp), exist=file_exists) @@ -651,7 +657,6 @@ PROGRAM mkCatchParam ! if (.not.file_exists) call create_irrig_params (nc,nr,gridnamer) ! write (log_file,'(a)')'Done computing irrigation model parameters ...............13' - ! call albedo4catchcn (gridnamet) write (log_file,'(a)')'============================================================' write (log_file,'(a)')'DONE creating CLSM data files...............................' diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/mod_process_hres_data.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/mod_process_hres_data.F90 index 5c776d1f0..a75036635 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/mod_process_hres_data.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/mod_process_hres_data.F90 @@ -6,6 +6,18 @@ ! NGDC-HWSD-STATSGO merged soil data on their native grids 3-23-2012 ! Contact: Sarith Mahanama sarith.p.mahanama@nasa.gov ! Email : sarith.p.mahanama@nasa.gov +! +! CHANGE LOG: +! +! jkolassa, reichle, May 2022: +! The bcs file "CLM4.5_veg_typs_fracs" was not used in CatchmentCNCLM45 and is no longer +! produced by make_bcs. +! Separate mappings from ESA GlobCover to CatchmentCNCLM40 and CatchmentCNCLM45 PFTs +! were initially implemented because the underlying CLM4.0 and CLM4.5 models have different +! plant functional types and distributions. Ultimately, the decision was made to use the same +! (CLM4.0-based) PFT distribution for both CatchmentCNCLM40 and CatchmentCNCLM45, and the +! obsolete mapping of ESA GlobCover data to CLM4.5 PFTs (subroutine ESA2CLM_45) was removed. + MODULE process_hres_data use rmTinyCatchParaMod @@ -27,7 +39,7 @@ MODULE process_hres_data public :: soil_para_hwsd,hres_lai,hres_gswp2, merge_lai_data, grid2tile_modis6 public :: modis_alb_on_tiles_high,modis_scale_para_high,hres_lai_no_gswp -public :: histogram, create_mapping, esa2mosaic , esa2clm, ESA2CLM_45 +public :: histogram, create_mapping, esa2mosaic , esa2clm public :: grid2tile_ndep_t2m_alb, CREATE_ROUT_PARA_FILE, map_country_codes, get_country_codes public :: CLM45_fixed_parameters, CLM45_clim_parameters, gimms_clim_ndvi, grid2tile_glass, open_landparam_nc4_files @@ -38,6 +50,8 @@ MODULE process_hres_data real, parameter :: pi= MAPL_PI,RADIUS=MAPL_RADIUS integer, parameter :: N_GADM = 256 + 1, N_STATES = 50 +real, parameter :: SOILDEPTH_MIN_HWSD = 1334. ! minimum soil depth for HWSD soil parameters + type :: do_regrid integer :: NT integer, dimension (N_tiles_per_cell) :: TID @@ -55,14 +69,14 @@ MODULE process_hres_data ! --------------------------------------------------------------------- ! - SUBROUTINE ESA2CLM_45 (nc, nr, gfile) + SUBROUTINE ESA2CLM (nc, nr, gfile) implicit none integer , intent (in) :: nc, nr character (*) :: gfile - integer , parameter :: N_lon_clm = 7200, N_lat_clm = 3600, lsmpft = 25 + integer , parameter :: N_lon_clm = 1152, N_lat_clm = 768, lsmpft = 17 integer*2, allocatable, target, dimension (:,:) :: esa_veg integer*2, pointer , dimension (:,:) :: subset integer , allocatable, dimension (:) :: tile_id, i_esa2clm, j_esa2clm @@ -73,7 +87,7 @@ SUBROUTINE ESA2CLM_45 (nc, nr, gfile) real :: cpf1, cpf2, csf1, csf2 ! CLM-carbon fractions DOUBLE PRECISION, allocatable, dimension (:) :: lon_esa, lat_esa DOUBLE PRECISION :: EDGEN, EDGEE, EDGES, EDGEW - + DOUBLE PRECISION, ALLOCATABLE, DIMENSION (:,:,:) :: PCT_PFT_DBL REAL, ALLOCATABLE, DIMENSION (:,:,:) :: PCTPFT integer, allocatable, dimension (:) :: density, loc_int real , allocatable, dimension (:) :: loc_val @@ -82,28 +96,35 @@ SUBROUTINE ESA2CLM_45 (nc, nr, gfile) integer, allocatable, dimension (:,:) :: clm_veg integer :: esa_clm_veg (2) real :: esa_clm_frac(2) - - ! These 2 values are assumed as same as they are in surfdata_0.23x0.31_simyr2000_c100406.nc - - EDGEW = -180. - EDGES = -90. + logical :: file_exists + REAL, ALLOCATABLE, DIMENSION (:,:) :: NITYP,NFVEG ! Reading CLM pft data file !-------------------------- ALLOCATE (PCTPFT (1:N_lon_clm, 1:N_lat_clm, 1:lsmpft)) - - status = NF_OPEN ('data/CATCH/CLM45/mksrf_24pftNT_landuse_rc2000_c121207.nc', NF_NOWRITE, ncid) + ALLOCATE (PCT_PFT_DBL (1:N_lon_clm, 1:N_lat_clm, 1:lsmpft)) + status = NF_OPEN ('data/CATCH/surfdata_0.23x0.31_simyr2000_c100406.nc', NF_NOWRITE, ncid) + status = NF_GET_VARA_DOUBLE (ncid,1,(/1/),(/1/),EDGEN) ; VERIFY_(STATUS) + status = NF_GET_VARA_DOUBLE (ncid,2,(/1/),(/1/),EDGEE) ; VERIFY_(STATUS) + status = NF_GET_VARA_DOUBLE (ncid,3,(/1/),(/1/),EDGES) ; VERIFY_(STATUS) + status = NF_GET_VARA_DOUBLE (ncid,4,(/1/),(/1/),EDGEW) ; VERIFY_(STATUS) status = NF_INQ_VARID (ncid,'PCT_PFT',VarID) ; VERIFY_(STATUS) - do k = 1, 25 ! Natural vegetation - status = NF_GET_VARA_REAL (ncid,VarID,(/1,1,k/),(/N_lon_clm, N_lat_clm, 1/),PCTPFT(:,:,k)) ; VERIFY_(STATUS) + do k = 1, lsmpft + status = NF_GET_VARA_DOUBLE (ncid,VarID,(/1,1,k/),(/N_lon_clm, N_lat_clm, 1/),PCT_PFT_DBL(:,:,k)) ; VERIFY_(STATUS) end do status = NF_CLOSE(ncid) - ! CLM 4_5 description (25) CLM45-carbon description (27) - ! ------------------------ ----------------------------- + ! change type 6 to 10 for Australia only gkw: to remove CLM artificial tree line, and stay true to ESA + ! ---------------------------------------------------------------------------------------------------- + + PCT_PFT_DBL(360:494,215:341,11) = PCT_PFT_DBL(360:494,215:341,11) + PCT_PFT_DBL(360:494,215:341, 7) + PCT_PFT_DBL(360:494,215:341, 7) = 0. + + ! CLM description (17) CatchmentCNCLM description (19) + ! -------------------- ------------------------------ ! 'BARE' 1 bare (does not have bare soil) ! 'NLEt' 2 needleleaf evergreen temperate tree 1 @@ -121,39 +142,27 @@ SUBROUTINE ESA2CLM_45 (nc, nr, gfile) ! 'AC3G' 13 arctic c3 grass 13 ! 'CC3G' 14 cool c3 grass 14 cool c3 grass [moisture + deciduous] ! 'CC3Gm' cool c3 grass 15 cool c3 grass [moisture stress only] - ! 'WC4G' 15 warm c4 grass 16 warm c4 grass [moisture + deciduous] - ! 'WC4Gm' warm c4 grass 17 warm c4 grass [moisture stress only] - ! 'C3CROP' 16 c3_crop 18 - ! 'C3IRR' 17 c3_irrigated 19 - ! 'CORN' 18 corn 20 - ! 'ICORN' 19 irrigated corn 21 - ! 'STCER' 20 spring temperate cereal 22 - ! 'ISTCER' 21 irrigated spring temperate cereal 23 - ! 'WTCER' 22 winter temperate cereal 24 - ! 'IWTCER' 23 irrigated winter temperate cereal 25 - ! 'SOYB' 24 soybean 26 - ! 'ISOYB' 25 irrigated soybean 27 - -!** ! 'CROP' 16 crop 18 crop [moisture + deciduous] -!** ! 'CROPm' crop 19 crop [moisture stress only] -!** ! 17 water + ! 'WC4G' 15 warm c4 grass 16 + ! 'WC4Gm' warm c4 grass 17 + ! 'CROP' 16 crop 18 crop [moisture + deciduous] + ! 'CROPm' crop 19 crop [moisture stress only] + ! 17 water dx_clm = 360./N_lon_clm dy_clm = 180./N_lat_clm do i = 1, N_lon_clm - x_min_clm (i) = (i-1)*dx_clm + EDGEW + x_min_clm (i) = (i-1)*dx_clm + EDGEW - 180. end do do i = 1, N_lat_clm y_min_clm (i) = (i-1)*dy_clm + EDGES end do - ! This data set is DE - !PCTPFT (1:N_lon_clm/2 ,:,:) = REAL (PCT_PFT_DBL(N_lon_clm/2 + 1: N_lon_clm,:,:)) - !PCTPFT (N_lon_clm/2 + 1: N_lon_clm,:,:) = REAL (PCT_PFT_DBL(1:N_lon_clm/2 ,:,:)) + PCTPFT (1:N_lon_clm/2 ,:,:) = REAL (PCT_PFT_DBL(N_lon_clm/2 + 1: N_lon_clm,:,:)) + PCTPFT (N_lon_clm/2 + 1: N_lon_clm,:,:) = REAL (PCT_PFT_DBL(1:N_lon_clm/2 ,:,:)) - !DEALLOCATE (PCT_PFT_DBL) + DEALLOCATE (PCT_PFT_DBL) ! Find primary and secondary types in the CLM data file ! ----------------------------------------------------- @@ -288,21 +297,10 @@ SUBROUTINE ESA2CLM_45 (nc, nr, gfile) ! if (esa_type == 10) clm_veg (tile_id(i), 17) = 1.* density(k) ! lakes inland water - if ((esa_type == 11).or. (esa_type == 14).or.(esa_type == 20).or. (esa_type == 190)) then - - ! ESA type 11: Post-flooding or irrigated croplands - ! ESA type 14: Rainfed croplands - ! ESA type 20: Mosaic Cropland (50-70%) / Vegetation (grassland, shrubland, forest) (20-50%) - ! ESA type 190: Artificial surfaces and associated areas (urban areas >50%) - - if(sum(PCTPFT(ii,jj,16:25)) > 0.) then - do n = 16,25 - clm_veg (tile_id(i), n) = clm_veg (tile_id(i), n) + density(k)*(PCTPFT(ii,jj,n))/sum(PCTPFT(ii,jj,16:25)) - end do - else - clm_veg (tile_id(i), 16) = clm_veg (tile_id(i), 16) + 1.* density(k) - endif - endif + if (esa_type == 11) clm_veg (tile_id(i), 16) = clm_veg (tile_id(i), 16) + 1.* density(k) ! ESA type 11: Post-flooding or irrigated croplands + if (esa_type == 14) clm_veg (tile_id(i), 16) = clm_veg (tile_id(i), 16) + 1.* density(k) ! ESA type 14: Rainfed croplands + if (esa_type == 20) clm_veg (tile_id(i), 16) = clm_veg (tile_id(i), 16) + 1.* density(k) ! ESA type 20: Mosaic Cropland (50-70%) / Vegetation (grassland, shrubland, forest) (20-50%) + if (esa_type == 190) clm_veg (tile_id(i), 16) = clm_veg (tile_id(i), 16) + 1.* density(k) ! ESA type 190: Artificial surfaces and associated areas (urban areas >50%) ! if (esa_type == 200) clm_veg (tile_id(i), 11) = clm_veg (tile_id(i), 11) + 1.* density(k) ! ESA type 200: Bare areas ! if (esa_type == 210) clm_veg (tile_id(i), 17) = clm_veg (tile_id(i), 17) + 1.* density(k) ! ocean @@ -312,19 +310,14 @@ SUBROUTINE ESA2CLM_45 (nc, nr, gfile) if (esa_type == 30) then ! ESA type 30: Mosaic Vegetation (grassland, shrubland, forest) (50-70%) / Cropland (20-50%) - - if(sum(PCTPFT(ii,jj,16:25)) > 0.) then - do n = 16,25 - clm_veg (tile_id(i), n) = clm_veg (tile_id(i), n) + 0.5*density(k)*(PCTPFT(ii,jj,n))/sum(PCTPFT(ii,jj,16:25)) - end do - elseif(sum(PCTPFT(ii,jj,2:15)) > 0.) then + clm_veg (tile_id(i), 16) = clm_veg (tile_id(i), 16) + 0.5* density(k) + if(sum(PCTPFT(ii,jj,2:15)) > 0.) then do n = 2, 15 clm_veg (tile_id(i), n) = clm_veg (tile_id(i), n) + 0.5* density(k)*(PCTPFT(ii,jj,n))/sum(PCTPFT(ii,jj,2:15)) enddo - else + else clm_veg (tile_id(i), 16) = clm_veg (tile_id(i), 16) + 1.0* density(k) endif - endif ! ----------------------------------------------------------------------------------------------------------------------------------------- @@ -614,13 +607,20 @@ SUBROUTINE ESA2CLM_45 (nc, nr, gfile) ! Now create CLM-carbon_veg_fracs file ! ------------------------------------ - open (10,file='clsm/CLM4.5_veg_typs_fracs', & + open (10,file='clsm/CLM_veg_typs_fracs', & form='formatted',status='unknown') open (11, file = 'clsm/catchment.def', form = 'formatted', status = 'old', & action = 'read') read (11, *) maxcat - + + inquire(file='clsm/catchcn_params.nc4', exist=file_exists) + if(file_exists) then + status = NF_OPEN ('clsm/catchcn_params.nc4', NF_WRITE, ncid) ; VERIFY_(STATUS) + allocate (NITYP (1:MAXCAT, 1:4)) + allocate (NFVEG (1:MAXCAT, 1:4)) + endif + do k = 1, maxcat read (11,'(i10,i8,5(2x,f9.4))') tid,cid,minlon,maxlon,minlat,maxlat @@ -653,10 +653,10 @@ SUBROUTINE ESA2CLM_45 (nc, nr, gfile) esa_clm_frac(2) = 100. - esa_clm_frac(1) end if -! Now splitting CLM types for CLM-carbon model +! Now splitting CLM types for CNCLM model ! -------------------------------------------- -! CLM types 2- 10,12,13 are not being splitted. +! CLM types 2- 10,12,13 are not being split. ! ............................................. if ((esa_clm_veg (1) >= 2).and.(esa_clm_veg (1) <= 10)) then @@ -689,23 +689,7 @@ SUBROUTINE ESA2CLM_45 (nc, nr, gfile) CSF2 = 0. endif -! CLM4_5 crop types - we don't split - - if ((esa_clm_veg (1) >= 16).and.(esa_clm_veg (1) <= 25)) then - CPT1 = esa_clm_veg (1) + 2 - CPT2 = esa_clm_veg (1) + 2 - CPF1 = esa_clm_frac(1) - CPF2 = 0. - endif - - if ((esa_clm_veg (2) >= 16).and.(esa_clm_veg (2) <= 25)) then - CST1 = esa_clm_veg (2) + 2 - CST2 = esa_clm_veg (2) + 2 - CSF1 = esa_clm_frac(2) - CSF2 = 0. - endif - -! Now splitting (broadleaf deciduous temperate shrub ) +! Now splitting ! ............. if (esa_clm_veg (1) == 11) then @@ -722,7 +706,7 @@ SUBROUTINE ESA2CLM_45 (nc, nr, gfile) CSF2 = esa_clm_frac(2) * (1. - scale) endif -! ............. (cool c3 grass) +! ............. if (esa_clm_veg (1) == 14) then CPT1 = 14 @@ -738,7 +722,7 @@ SUBROUTINE ESA2CLM_45 (nc, nr, gfile) CSF2 = esa_clm_frac(2) * (1. - scale) endif -! ............. warm c4 grass +! ............. if (esa_clm_veg (1) == 15) then CPT1 = 16 @@ -754,20 +738,20 @@ SUBROUTINE ESA2CLM_45 (nc, nr, gfile) CSF2 = esa_clm_frac(2) * (1. - scale) endif ! ............. -! CLM_4.5 : we don't splot crop type anymore 16 has become 16-25 and they are now 18-27 in catchment-CN -! if (esa_clm_veg (1) == 16) then -! CPT1 = 18 -! CPT2 = 19 -! CPF1 = esa_clm_frac(1) * scale -! CPF2 = esa_clm_frac(1) * (1. - scale) -! endif -! -! if (esa_clm_veg (2) == 16) then -! CST1 = 18 -! CST2 = 19 -! CSF1 = esa_clm_frac(2) * scale -! CSF2 = esa_clm_frac(2) * (1. - scale) -! endif + + if (esa_clm_veg (1) == 16) then + CPT1 = 18 + CPT2 = 19 + CPF1 = esa_clm_frac(1) * scale + CPF2 = esa_clm_frac(1) * (1. - scale) + endif + + if (esa_clm_veg (2) == 16) then + CST1 = 18 + CST2 = 19 + CSF1 = esa_clm_frac(2) * scale + CSF2 = esa_clm_frac(2) * (1. - scale) + endif ! fractions must sum to 1 ! ----------------------- @@ -783,140 +767,60 @@ SUBROUTINE ESA2CLM_45 (nc, nr, gfile) write (10,'(2I10,4I3,4f7.2,2I3,2f7.2)') & tid,cid,cpt1, cpt2, cst1, cst2, cpf1, cpf2, csf1, csf2, & esa_clm_veg (1), esa_clm_veg (2), esa_clm_frac(1), esa_clm_frac(2) + + if (allocated (NITYP)) NITYP (k, :) = (/REAL(cpt1), REAL(cpt2), REAL(cst1), REAL(cst2)/) + if (allocated (NFVEG)) NFVEG (k, :) = (/cpf1, cpf2, csf1, csf2/) + end do + if(file_exists) then + + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ITY' ) ,(/1,1/),(/maxcat,1/), NITYP (:, 1)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ITY' ) ,(/1,2/),(/maxcat,1/), NITYP (:, 2)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ITY' ) ,(/1,3/),(/maxcat,1/), NITYP (:, 3)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ITY' ) ,(/1,4/),(/maxcat,1/), NITYP (:, 4)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'FVG' ) ,(/1,1/),(/maxcat,1/), NFVEG (:, 1)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'FVG' ) ,(/1,2/),(/maxcat,1/), NFVEG (:, 2)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'FVG' ) ,(/1,3/),(/maxcat,1/), NFVEG (:, 3)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'FVG' ) ,(/1,4/),(/maxcat,1/), NFVEG (:, 4)) ; VERIFY_(STATUS) + DEALLOCATE (NITYP, NFVEG) + STATUS = NF_CLOSE (NCID) ; VERIFY_(STATUS) + + endif + close (10, status = 'keep') close (11, status = 'keep') - END SUBROUTINE ESA2CLM_45 - + END SUBROUTINE ESA2CLM ! -! ------------------------------------------------------------------------------------------------ +! --------------------------------------------------------------------- ! - - SUBROUTINE ESA2CLM (nc, nr, gfile) - + SUBROUTINE ESA2MOSAIC (nc, nr, gfile) + implicit none integer , intent (in) :: nc, nr character (*) :: gfile - - integer , parameter :: N_lon_clm = 1152, N_lat_clm = 768, lsmpft = 17 + integer , parameter :: nc_esa = 129600, nr_esa = 64800 integer*2, allocatable, target, dimension (:,:) :: esa_veg integer*2, pointer , dimension (:,:) :: subset - integer , allocatable, dimension (:) :: tile_id, i_esa2clm, j_esa2clm - integer :: i,j, k,n, status, ncid, varid, maxcat, dx,dy, esa_type, tid, cid, ii, jj - real :: dx_clm, dy_clm, x_min_clm (N_lon_clm), y_min_clm (N_lat_clm), clm_fracs(lsmpft) - real :: minlon,maxlon,minlat,maxlat,tile_lat, scale, ftot - integer :: cpt1, cpt2, cst1, cst2 ! CLM-carbon types - real :: cpf1, cpf2, csf1, csf2 ! CLM-carbon fractions - DOUBLE PRECISION, allocatable, dimension (:) :: lon_esa, lat_esa - DOUBLE PRECISION :: EDGEN, EDGEE, EDGES, EDGEW - DOUBLE PRECISION, ALLOCATABLE, DIMENSION (:,:,:) :: PCT_PFT_DBL - REAL, ALLOCATABLE, DIMENSION (:,:,:) :: PCTPFT + integer , allocatable, dimension (:) :: tile_id, ityp + integer :: i,j, k, status, ncid, maxcat, dx,dy, esa_type, tid, cid + integer :: mos1, mos2 + real :: mfrac, sfrac, tfrac, tem (6) integer, allocatable, dimension (:) :: density, loc_int real , allocatable, dimension (:) :: loc_val logical, allocatable, dimension (:) :: unq_mask + real , allocatable :: veg (:,:) integer :: NBINS, NPLUS - integer, allocatable, dimension (:,:) :: clm_veg - integer :: esa_clm_veg (2) - real :: esa_clm_frac(2) + real, pointer, dimension (:) :: z2, z0 + real, dimension (6) :: VGZ2 = (/35.0, 20.0, 17.0, 0.6, 0.5, 0.6/) ! Dorman and Sellers (1989) logical :: file_exists - REAL, ALLOCATABLE, DIMENSION (:,:) :: NITYP,NFVEG - - ! Reading CLM pft data file - !-------------------------- - - ALLOCATE (PCTPFT (1:N_lon_clm, 1:N_lat_clm, 1:lsmpft)) - ALLOCATE (PCT_PFT_DBL (1:N_lon_clm, 1:N_lat_clm, 1:lsmpft)) - status = NF_OPEN ('data/CATCH/surfdata_0.23x0.31_simyr2000_c100406.nc', NF_NOWRITE, ncid) - status = NF_GET_VARA_DOUBLE (ncid,1,(/1/),(/1/),EDGEN) ; VERIFY_(STATUS) - status = NF_GET_VARA_DOUBLE (ncid,2,(/1/),(/1/),EDGEE) ; VERIFY_(STATUS) - status = NF_GET_VARA_DOUBLE (ncid,3,(/1/),(/1/),EDGES) ; VERIFY_(STATUS) - status = NF_GET_VARA_DOUBLE (ncid,4,(/1/),(/1/),EDGEW) ; VERIFY_(STATUS) - status = NF_INQ_VARID (ncid,'PCT_PFT',VarID) ; VERIFY_(STATUS) - - do k = 1, lsmpft - status = NF_GET_VARA_DOUBLE (ncid,VarID,(/1,1,k/),(/N_lon_clm, N_lat_clm, 1/),PCT_PFT_DBL(:,:,k)) ; VERIFY_(STATUS) - end do - - status = NF_CLOSE(ncid) - - ! change type 6 to 10 for Australia only gkw: to remove CLM artificial tree line, and stay true to ESA - ! ---------------------------------------------------------------------------------------------------- - - PCT_PFT_DBL(360:494,215:341,11) = PCT_PFT_DBL(360:494,215:341,11) + PCT_PFT_DBL(360:494,215:341, 7) - PCT_PFT_DBL(360:494,215:341, 7) = 0. - - ! CLM description (17) CLM-carbon description (19) - ! -------------------- -------------------------- - - ! 'BARE' 1 bare (does not have bare soil) - ! 'NLEt' 2 needleleaf evergreen temperate tree 1 - ! 'NLEB' 3 needleleaf evergreen boreal tree 2 - ! 'NLDB' 4 needleleaf deciduous boreal tree 3 - ! 'BLET' 5 broadleaf evergreen tropical tree 4 - ! 'BLEt' 6 broadleaf evergreen temperate tree 5 - ! 'BLDT' 7 broadleaf deciduous tropical tree 6 - ! 'BLDt' 8 broadleaf deciduous temperate tree 7 - ! 'BLDB' 9 broadleaf deciduous boreal tree 8 - ! 'BLEtS' 10 broadleaf evergreen temperate shrub 9 - ! 'BLDtS' 11 broadleaf deciduous temperate shrub 10 broadleaf deciduous temperate shrub [moisture + deciduous] - ! 'BLDtSm' broadleaf deciduous temperate shrub 11 broadleaf deciduous temperate shrub [moisture stress only] - ! 'BLDBS' 12 broadleaf deciduous boreal shrub 12 - ! 'AC3G' 13 arctic c3 grass 13 - ! 'CC3G' 14 cool c3 grass 14 cool c3 grass [moisture + deciduous] - ! 'CC3Gm' cool c3 grass 15 cool c3 grass [moisture stress only] - ! 'WC4G' 15 warm c4 grass 16 - ! 'WC4Gm' warm c4 grass 17 - ! 'CROP' 16 crop 18 crop [moisture + deciduous] - ! 'CROPm' crop 19 crop [moisture stress only] - ! 17 water - - dx_clm = 360./N_lon_clm - dy_clm = 180./N_lat_clm - - do i = 1, N_lon_clm - x_min_clm (i) = (i-1)*dx_clm + EDGEW - 180. - end do - - do i = 1, N_lat_clm - y_min_clm (i) = (i-1)*dy_clm + EDGES - end do - - PCTPFT (1:N_lon_clm/2 ,:,:) = REAL (PCT_PFT_DBL(N_lon_clm/2 + 1: N_lon_clm,:,:)) - PCTPFT (N_lon_clm/2 + 1: N_lon_clm,:,:) = REAL (PCT_PFT_DBL(1:N_lon_clm/2 ,:,:)) - - DEALLOCATE (PCT_PFT_DBL) - - ! Find primary and secondary types in the CLM data file - ! ----------------------------------------------------- - ! allocate (clm_veg (1:N_lon_clm,1:N_lat_clm,1:2)) - ! - ! do j = 1, N_lat_clm - ! do i = 1, N_lon_clm - ! if(maxval(PCT_PFT(i,j,:)) > 0.) then - ! clm_fracs = PCT_PFT(i,j,:) - ! if (maxval (clm_fracs) == 100.) then - ! clm_veg(i,j,:) = maxloc (clm_fracs) - ! else - ! clm_veg(i,j,0) = maxloc (clm_fracs) - ! clm_fracs (clm_veg(i,j,0)) = 0. - ! clm_veg(i,j,1) = maxloc (clm_fracs) - ! endif - ! else - ! clm_veg(i,j,:) = 17 - ! endif - ! end do - ! end do - ! Reading ESA vegetation types !----------------------------- allocate (esa_veg (1:nc_esa, 1: nr_esa)) - allocate (lon_esa (1:nc_esa)) - allocate (lat_esa (1:nr_esa)) status = NF_OPEN ('data/CATCH/ESA_GlobalCover.nc', NF_NOWRITE, ncid) @@ -926,9 +830,6 @@ SUBROUTINE ESA2CLM (nc, nr, gfile) stop endif - status = NF_GET_VARA_DOUBLE (ncid,1,(/1/),(/nr_esa/),lat_esa) - status = NF_GET_VARA_DOUBLE (ncid,2,(/1/),(/nc_esa/),lon_esa) - do j = 1,nr_esa status = NF_GET_VARA_INT2 (ncid,3,(/1,j/),(/nc_esa,1/),esa_veg(:,j)) if(status /=0) then @@ -937,637 +838,11 @@ SUBROUTINE ESA2CLM (nc, nr, gfile) stop endif end do - status = NF_CLOSE(ncid) - ! Find I,J of overlying CLM grid cells for each ESA pixel - !-------------------------------------------------------- - allocate (i_esa2clm (1:nc_esa)) - allocate (j_esa2clm (1:nr_esa)) - - do i = 1, N_lon_clm - where ((real(lon_esa) >= x_min_clm(i)).and.(real(lon_esa) < (x_min_clm(i) + dx_clm))) i_esa2clm= i - end do - - i_esa2clm(129545:nc_esa) = 1 - - do j = 1, N_lat_clm - where ((real(lat_esa) >= y_min_clm(j)).and.(real(lat_esa) < (y_min_clm(j) + dy_clm))) j_esa2clm= j - end do - - ! - ! Reading number of tiles - ! ----------------------- - - open (10, file = 'clsm/catchment.def', form = 'formatted', status = 'old', & - action = 'read') - - read (10, *) maxcat - - close (10, status = 'keep') - - ! - ! Loop through tile_id raster - ! ___________________________ - - - allocate (tile_id (1:nc )) - allocate (clm_veg (1:maxcat,1:lsmpft)) - clm_veg = 0. - - dx = nc_esa / nc - dy = nr_esa / nr - - open (10,file=trim(gfile)//'.rst',status='old',action='read', & - form='unformatted',convert='little_endian') - - do j=1,nr - - ! read a row - - read(10)tile_id(:) - - do i = 1,nc - - ii = i_esa2clm ((i-1)*dx + dx/2) - jj = j_esa2clm ((j-1)*dy + dy/2) - - if((tile_id (i) >= 1).and.(tile_id(i) <= maxcat)) then - - if (associated (subset)) NULLIFY (subset) - subset => esa_veg((i-1)*dx +1 :i*dx, (j-1)*dy +1:j*dy) - NPLUS = count(subset >= 1 .and. subset <= 230) - - if(NPLUS > 0) then - allocate (loc_int (1:NPLUS)) - allocate (unq_mask(1:NPLUS)) - loc_int = pack(subset,mask = (subset >= 1 .and. subset <= 230)) - call MAPL_Sort (loc_int) - unq_mask = .true. - do n = 2,NPLUS - unq_mask(n) = .not.(loc_int(n) == loc_int(n-1)) - end do - NBINS = count(unq_mask) - - allocate(loc_val (1:NBINS)) - allocate(density (1:NBINS)) - loc_val = 1.*pack(loc_int,mask =unq_mask) - call histogram (size(subset,1)*size(subset,2), NBINS, density, loc_val, real(subset)) - - do k = 1, nbins - - if (density (k) > 0) then - - esa_type = int (loc_val(k)) - - ! if (esa_type == 10) clm_veg (tile_id(i), 17) = 1.* density(k) ! lakes inland water - - if (esa_type == 11) clm_veg (tile_id(i), 16) = clm_veg (tile_id(i), 16) + 1.* density(k) ! ESA type 11: Post-flooding or irrigated croplands - if (esa_type == 14) clm_veg (tile_id(i), 16) = clm_veg (tile_id(i), 16) + 1.* density(k) ! ESA type 14: Rainfed croplands - if (esa_type == 20) clm_veg (tile_id(i), 16) = clm_veg (tile_id(i), 16) + 1.* density(k) ! ESA type 20: Mosaic Cropland (50-70%) / Vegetation (grassland, shrubland, forest) (20-50%) - if (esa_type == 190) clm_veg (tile_id(i), 16) = clm_veg (tile_id(i), 16) + 1.* density(k) ! ESA type 190: Artificial surfaces and associated areas (urban areas >50%) - - ! if (esa_type == 200) clm_veg (tile_id(i), 11) = clm_veg (tile_id(i), 11) + 1.* density(k) ! ESA type 200: Bare areas - ! if (esa_type == 210) clm_veg (tile_id(i), 17) = clm_veg (tile_id(i), 17) + 1.* density(k) ! ocean - ! if (esa_type == 220) clm_veg (tile_id(i), 17) = clm_veg (tile_id(i), 17) + 1.* density(k) ! ice - ! gkw: bare soil excluded! only considering vegetated land - ! ----------------------------------------------------------------------------------------------------------------------------------------- - - if (esa_type == 30) then - ! ESA type 30: Mosaic Vegetation (grassland, shrubland, forest) (50-70%) / Cropland (20-50%) - clm_veg (tile_id(i), 16) = clm_veg (tile_id(i), 16) + 0.5* density(k) - if(sum(PCTPFT(ii,jj,2:15)) > 0.) then - do n = 2, 15 - clm_veg (tile_id(i), n) = clm_veg (tile_id(i), n) + 0.5* density(k)*(PCTPFT(ii,jj,n))/sum(PCTPFT(ii,jj,2:15)) - enddo - else - clm_veg (tile_id(i), 16) = clm_veg (tile_id(i), 16) + 1.0* density(k) - endif - endif - - ! ----------------------------------------------------------------------------------------------------------------------------------------- - - if (esa_type == 40) then - ! ESA type 40: Closed to open (>15%) broadleaved evergreen and/or semi-deciduous forest (>5m) - - if(sum(PCTPFT(ii,jj,5:6)) > 0.) then - do n = 5, 6 - clm_veg (tile_id(i), n) = clm_veg (tile_id(i), n) + 1.*density(k)*(PCTPFT(ii,jj,n))/sum(PCTPFT(ii,jj,5:6)) - enddo - else - if(abs(y_min_clm(jj) + 0.5*dy_clm) < 23.5) then - clm_veg (tile_id(i), 5) = clm_veg (tile_id(i), 5) + 1.0* density(k) - else - clm_veg (tile_id(i), 6) = clm_veg (tile_id(i), 6) + 1.0* density(k) - endif - endif - endif - - ! ----------------------------------------------------------------------------------------------------------------------------------------- - - if ((esa_type == 50) .or. (esa_type == 60)) then - ! ESA type 50: Closed (>40%) broadleaved deciduous forest (>5m) - ! ESA type 60: Open (15-40%) broadleaved deciduous forest (>5m) - - if(sum(PCTPFT(ii,jj,7:9)) > 0.) then - do n = 7, 9 - clm_veg (tile_id(i), n) = clm_veg (tile_id(i), n) + density(k)*(PCTPFT(ii,jj,n))/sum(PCTPFT(ii,jj,7:9)) - enddo - else - if(abs(y_min_clm(jj) + 0.5*dy_clm) < 23.5) then - clm_veg (tile_id(i), 7) = clm_veg (tile_id(i), 7) + 1.0* density(k) - else - if(abs(y_min_clm(jj) + 0.5*dy_clm) < 60.) clm_veg (tile_id(i), 8) = clm_veg (tile_id(i), 8) + 1.0* density(k) - if(abs(y_min_clm(jj) + 0.5*dy_clm) >= 60.) clm_veg (tile_id(i), 9) = clm_veg (tile_id(i), 9) + 1.0* density(k) - end if - end if - endif - - ! ----------------------------------------------------------------------------------------------------------------------------------------- - - if (esa_type == 70) then - ! ESA type 70: Closed (>40%) needleleaved evergreen forest (>5m) - - if(sum(PCTPFT(ii,jj,2:3)) > 0.) then - do n = 2, 3 - clm_veg (tile_id(i), n) = clm_veg (tile_id(i), n) + density(k)*(PCTPFT(ii,jj,n))/sum(PCTPFT(ii,jj,2:3)) - enddo - else - if(abs(y_min_clm(jj) + 0.5*dy_clm) < 60.) then - clm_veg (tile_id(i), 2) = clm_veg (tile_id(i), 2) + 1.0* density(k) - else - clm_veg (tile_id(i), 3) = clm_veg (tile_id(i), 3) + 1.0* density(k) - end if - end if - endif - - ! ----------------------------------------------------------------------------------------------------------------------------------------- - - if (esa_type == 90) then - !ESA type 90: Open (15-40%) needleleaved deciduous or evergreen forest (>5m) - - if(sum(PCTPFT(ii,jj,2:4)) > 0.) then - do n = 2, 4 - clm_veg (tile_id(i), n) = clm_veg (tile_id(i), n) + 1.*density(k)*(PCTPFT(ii,jj,n))/sum(PCTPFT(ii,jj,2:4)) - enddo - else - if(abs(y_min_clm(jj) + 0.5*dy_clm) < 60.) then - clm_veg (tile_id(i), 2) = clm_veg (tile_id(i), 2) + 1.0* density(k) - else - clm_veg (tile_id(i), 3) = clm_veg (tile_id(i), 3) + 1.0* density(k) - end if - end if - endif - - ! ----------------------------------------------------------------------------------------------------------------------------------------- - - if (esa_type == 100) then - ! ESA type 100: Closed to open (>15%) mixed broadleaved and needleleaved forest (>5m) - - if((sum(PCTPFT(ii,jj,2:4)) + sum(PCTPFT(ii,jj,7:9))) > 0.) then - do n = 2, 9 - if((n /= 5) .and. (n /= 6)) clm_veg (tile_id(i), n) = clm_veg (tile_id(i), n) + density(k)*(PCTPFT(ii,jj,n))/(sum(PCTPFT(ii,jj,2:4)) + sum(PCTPFT(ii,jj,7:9))) - enddo - else - if(abs(y_min_clm(jj) + 0.5*dy_clm) < 23.5) then - clm_veg (tile_id(i), 7) = clm_veg (tile_id(i), 7) + 0.5* density(k) - clm_veg (tile_id(i), 2) = clm_veg (tile_id(i), 2) + 0.5* density(k) - elseif (abs(y_min_clm(jj) + 0.5*dy_clm) < 60.) then - clm_veg (tile_id(i), 8) = clm_veg (tile_id(i), 8) + 0.5* density(k) - clm_veg (tile_id(i), 2) = clm_veg (tile_id(i), 2) + 0.5* density(k) - else - clm_veg (tile_id(i), 9) = clm_veg (tile_id(i), 9) + 0.5* density(k) - clm_veg (tile_id(i), 3) = clm_veg (tile_id(i), 3) + 0.5* density(k) - end if - end if - endif - - ! ----------------------------------------------------------------------------------------------------------------------------------------- - - if (esa_type == 110) then - ! ESA type 110: Mosaic Forest/Shrubland (50-70%) / Grassland (20-50%) - - if(sum(PCTPFT(ii,jj,7:12)) > 0.) then - do n = 7, 12 - clm_veg (tile_id(i), n) = clm_veg (tile_id(i), n) + 0.6*density(k)*(PCTPFT(ii,jj,n))/sum(PCTPFT(ii,jj,7:12)) - enddo - else - if(abs(y_min_clm(jj) + 0.5*dy_clm) < 23.5) then - clm_veg (tile_id(i), 7) = clm_veg (tile_id(i), 7) + 0.3* density(k) - clm_veg (tile_id(i), 11) = clm_veg (tile_id(i), 11) + 0.3* density(k) - else if (abs(y_min_clm(jj) + 0.5*dy_clm) < 60.) then - clm_veg (tile_id(i), 8) = clm_veg (tile_id(i), 8) + 0.3* density(k) - clm_veg (tile_id(i), 11) = clm_veg (tile_id(i), 11) + 0.3* density(k) - else - clm_veg (tile_id(i), 9) = clm_veg (tile_id(i), 9) + 0.3* density(k) - clm_veg (tile_id(i), 12) = clm_veg (tile_id(i), 12) + 0.3* density(k) - end if - end if - - if(sum(PCTPFT(ii,jj,13:15)) > 0.) then - do n =13, 15 - clm_veg (tile_id(i), n) = clm_veg (tile_id(i), n) + 0.4*density(k)*(PCTPFT(ii,jj,n))/sum(PCTPFT(ii,jj,13:15)) - enddo - else - if(abs(y_min_clm(jj) + 0.5*dy_clm) < 30.) then - clm_veg (tile_id(i), 15) = clm_veg (tile_id(i), 15) + 0.4* density(k) - else if (abs(y_min_clm(jj) + 0.5*dy_clm) < 55.) then - clm_veg (tile_id(i), 14) = clm_veg (tile_id(i), 14) + 0.4* density(k) - else - clm_veg (tile_id(i), 13) = clm_veg (tile_id(i), 13) + 0.4* density(k) - end if - end if - endif - - ! ----------------------------------------------------------------------------------------------------------------------------------------- - - if (esa_type == 120) then - ! ESA type 120: Mosaic Grassland (50-70%) / Forest/Shrubland (20-50%) - - if(sum(PCTPFT(ii,jj,7:12)) > 0.) then - do n = 7, 12 - clm_veg (tile_id(i), n) = clm_veg (tile_id(i), n) + 0.4*density(k)*(PCTPFT(ii,jj,n))/sum(PCTPFT(ii,jj,7:12)) - enddo - else - if(abs(y_min_clm(jj) + 0.5*dy_clm) < 23.5) then - clm_veg (tile_id(i), 7) = clm_veg (tile_id(i), 7) + 0.2* density(k) - clm_veg (tile_id(i), 11) = clm_veg (tile_id(i), 11) + 0.2* density(k) - else if (abs(y_min_clm(jj) + 0.5*dy_clm) < 60.) then - clm_veg (tile_id(i), 8) = clm_veg (tile_id(i), 8) + 0.2* density(k) - clm_veg (tile_id(i), 11) = clm_veg (tile_id(i), 11) + 0.2* density(k) - else - clm_veg (tile_id(i), 9) = clm_veg (tile_id(i), 9) + 0.2* density(k) - clm_veg (tile_id(i), 12) = clm_veg (tile_id(i), 12) + 0.2* density(k) - end if - end if - - if(sum(PCTPFT(ii,jj,13:15)) > 0.) then - do n =13, 15 - clm_veg (tile_id(i), n) = clm_veg (tile_id(i), n) + 0.6*density(k)*(PCTPFT(ii,jj,n))/sum(PCTPFT(ii,jj,13:15)) - enddo - else - if(abs(y_min_clm(jj) + 0.5*dy_clm) < 30.) then - clm_veg (tile_id(i), 15) = clm_veg (tile_id(i), 15) + 0.6* density(k) - else if (abs(y_min_clm(jj) + 0.5*dy_clm) < 55.) then - clm_veg (tile_id(i), 14) = clm_veg (tile_id(i), 14) + 0.6* density(k) - else - clm_veg (tile_id(i), 13) = clm_veg (tile_id(i), 13) + 0.6* density(k) - end if - end if - endif - - ! ----------------------------------------------------------------------------------------------------------------------------------------- - - if (esa_type == 130) then - ! Closed to open (>15%) shrubland (<5m) - - if(sum(PCTPFT(ii,jj,10:12)) > 0.) then - do n = 10,12 - clm_veg (tile_id(i), n) = clm_veg (tile_id(i), n) + 1.*density(k)*(PCTPFT(ii,jj,n))/sum(PCTPFT(ii,jj,10:12)) - enddo - else - if(abs(y_min_clm(jj) + 0.5*dy_clm) < 60.) then - clm_veg (tile_id(i), 11) = clm_veg (tile_id(i), 11) + 1.0* density(k) - else - clm_veg (tile_id(i), 12) = clm_veg (tile_id(i), 12) + 1.0* density(k) - end if - end if - endif - - ! ----------------------------------------------------------------------------------------------------------------------------------------- - - if (esa_type == 140) then - ! ESA type 140: Closed to open (>15%) grassland - - if(sum(PCTPFT(ii,jj,13:15)) > 0.) then - do n = 13,15 - clm_veg (tile_id(i), n) = clm_veg (tile_id(i), n) + 1.*density(k)*(PCTPFT(ii,jj,n))/sum(PCTPFT(ii,jj,13:15)) - enddo - else - if(abs(y_min_clm(jj) + 0.5*dy_clm) < 30.) then - clm_veg (tile_id(i), 15) = clm_veg (tile_id(i), 15) + 1.0* density(k) - else if (abs(y_min_clm(jj) + 0.5*dy_clm) < 55.) then - clm_veg (tile_id(i), 14) = clm_veg (tile_id(i), 14) + 1.0* density(k) - else - clm_veg (tile_id(i), 13) = clm_veg (tile_id(i), 13) + 1.0* density(k) - end if - end if - end if - - ! ----------------------------------------------------------------------------------------------------------------------------------------- - - if (esa_type == 150) then - ! ESA type 150: Sparse (<15%) vegetation (woody vegetation, shrubs, grassland) - - if(sum(PCTPFT(ii,jj,10:15)) > 0.) then - do n = 10, 15 - clm_veg (tile_id(i), n) = clm_veg (tile_id(i), n) + 1.0*density(k)*(PCTPFT(ii,jj,n))/sum(PCTPFT(ii,jj,10:15)) - enddo - else - if(abs(y_min_clm(jj) + 0.5*dy_clm) < 30.) then - clm_veg (tile_id(i), 14) = clm_veg (tile_id(i), 14) + 0.5* density(k) - clm_veg (tile_id(i), 11) = clm_veg (tile_id(i), 11) + 0.5* density(k) - else if (abs(y_min_clm(jj) + 0.5*dy_clm) < 55.) then - clm_veg (tile_id(i), 14) = clm_veg (tile_id(i), 14) + 0.5* density(k) - clm_veg (tile_id(i), 11) = clm_veg (tile_id(i), 11) + 0.5* density(k) - else - clm_veg (tile_id(i), 13) = clm_veg (tile_id(i), 13) + 0.5* density(k) - clm_veg (tile_id(i), 12) = clm_veg (tile_id(i), 12) + 0.5* density(k) - end if - end if - endif - - ! ----------------------------------------------------------------------------------------------------------------------------------------- - - if((esa_type == 160) .or. (esa_type == 170)) then - ! ESA type 160: Closed (>40%) broadleaved forest regularly flooded - Fresh water ! ESA type 170: Closed (>40%) broadleaved semi-deciduous and/or evergreen forest regularly flooded - - if(sum(PCTPFT(ii,jj,5:9)) > 0.) then - do n = 5,9 - clm_veg (tile_id(i), n) = clm_veg (tile_id(i), n) + 1.*density(k)*(PCTPFT(ii,jj,n))/sum(PCTPFT(ii,jj,5:9)) - enddo - else - if(abs(y_min_clm(jj) + 0.5*dy_clm) < 23.5) then - clm_veg (tile_id(i), 5) = clm_veg (tile_id(i), 5) + 1.0* density(k) - else if (abs(y_min_clm(jj) + 0.5*dy_clm) < 60.) then - clm_veg (tile_id(i), 8) = clm_veg (tile_id(i), 8) + 1.0* density(k) - else - clm_veg (tile_id(i), 9) = clm_veg (tile_id(i), 9) + 1.0* density(k) - end if - end if - endif - - ! ----------------------------------------------------------------------------------------------------------------------------------------- - - if (esa_type == 180) then - ! ESA type 180: Closed to open (>15%) vegetation (grassland, shrubland, woody vegetation) on regularly flooded or waterlogged soil - Fresh, brackish or saline water - - if(sum(PCTPFT(ii,jj,10:15)) > 0.) then - do n = 10,15 - clm_veg (tile_id(i), n) = clm_veg (tile_id(i), n) + 1.*density(k)*(PCTPFT(ii,jj,n))/sum(PCTPFT(ii,jj,10:15)) - enddo - else - if(abs(y_min_clm(jj) + 0.5*dy_clm) < 30.) then - clm_veg (tile_id(i), 15) = clm_veg (tile_id(i), 15) + 1.0* density(k) - else if (abs(y_min_clm(jj) + 0.5*dy_clm) < 55.) then - clm_veg (tile_id(i), 14) = clm_veg (tile_id(i), 14) + 1.0* density(k) - else - clm_veg (tile_id(i), 13) = clm_veg (tile_id(i), 13) + 1.0* density(k) - end if - end if - endif - endif - enddo - deallocate (loc_int,unq_mask,loc_val,density) - endif - end if - enddo - end do - - - deallocate (tile_id, PCTPFT,esa_veg,lon_esa,lat_esa,i_esa2clm,j_esa2clm) - close (10,status='keep') - - ! - ! Now create CLM-carbon_veg_fracs file - ! ------------------------------------ - - open (10,file='clsm/CLM_veg_typs_fracs', & - form='formatted',status='unknown') - open (11, file = 'clsm/catchment.def', form = 'formatted', status = 'old', & - action = 'read') - - read (11, *) maxcat - - inquire(file='clsm/catchcn_params.nc4', exist=file_exists) - if(file_exists) then - status = NF_OPEN ('clsm/catchcn_params.nc4', NF_WRITE, ncid) ; VERIFY_(STATUS) - allocate (NITYP (1:MAXCAT, 1:4)) - allocate (NFVEG (1:MAXCAT, 1:4)) - endif - - do k = 1, maxcat - - read (11,'(i10,i8,5(2x,f9.4))') tid,cid,minlon,maxlon,minlat,maxlat - tile_lat = (minlat + maxlat)/2. - scale = (ABS (tile_lat) - 32.)/10. - scale = min (max(scale,0.),1.) - - esa_clm_veg = 0 - esa_clm_frac= 0. - - clm_fracs = clm_veg (k,:) - - if (sum (clm_fracs) == 0.) then ! gkw: no vegetated land found; set to BLDtS - esa_clm_veg (1) = 11 ! broadleaf deciduous shrub - esa_clm_frac(1) = 100. - else - esa_clm_veg (1) = maxloc(clm_fracs,1) - esa_clm_frac(1) = maxval(clm_fracs) - endif - - clm_fracs (esa_clm_veg (1)) = 0. - - if (sum (clm_fracs) == 0.) then ! gkw: no vegetated secondary type found, set to primary with zero fraction - esa_clm_veg (2) = esa_clm_veg (1) - esa_clm_frac(1) = 100. - esa_clm_frac(2) = 0. - else - esa_clm_veg (2) = maxloc(clm_fracs,1) - esa_clm_frac(1) = 100.*clm_veg (k,esa_clm_veg (1))/(clm_veg (k,esa_clm_veg (1)) + clm_veg (k,esa_clm_veg (2))) - esa_clm_frac(2) = 100. - esa_clm_frac(1) - end if - -! Now splitting CLM types for CLM-carbon model -! -------------------------------------------- - -! CLM types 2- 10,12,13 are not being splitted. -! ............................................. - - if ((esa_clm_veg (1) >= 2).and.(esa_clm_veg (1) <= 10)) then - CPT1 = esa_clm_veg (1) - 1 - CPT2 = esa_clm_veg (1) - 1 - CPF1 = esa_clm_frac(1) - CPF2 = 0. - endif - - if ((esa_clm_veg (2) >= 2).and.(esa_clm_veg (2) <= 10)) then - CST1 = esa_clm_veg (2) - 1 - CST2 = esa_clm_veg (2) - 1 - CSF1 = esa_clm_frac(2) - CSF2 = 0. - endif - -! ............................................. - - if ((esa_clm_veg (1) >= 12).and.(esa_clm_veg (1) <= 13)) then - CPT1 = esa_clm_veg (1) - CPT2 = esa_clm_veg (1) - CPF1 = esa_clm_frac(1) - CPF2 = 0. - endif - - if ((esa_clm_veg (2) >= 12).and.(esa_clm_veg (2) <= 13)) then - CST1 = esa_clm_veg (2) - CST2 = esa_clm_veg (2) - CSF1 = esa_clm_frac(2) - CSF2 = 0. - endif - -! Now splitting -! ............. - - if (esa_clm_veg (1) == 11) then - CPT1 = 10 - CPT2 = 11 - CPF1 = esa_clm_frac(1) * scale - CPF2 = esa_clm_frac(1) * (1. - scale) - endif - - if (esa_clm_veg (2) == 11) then - CST1 = 10 - CST2 = 11 - CSF1 = esa_clm_frac(2) * scale - CSF2 = esa_clm_frac(2) * (1. - scale) - endif - -! ............. - - if (esa_clm_veg (1) == 14) then - CPT1 = 14 - CPT2 = 15 - CPF1 = esa_clm_frac(1) * scale - CPF2 = esa_clm_frac(1) * (1. - scale) - endif - - if (esa_clm_veg (2) == 14) then - CST1 = 14 - CST2 = 15 - CSF1 = esa_clm_frac(2) * scale - CSF2 = esa_clm_frac(2) * (1. - scale) - endif - -! ............. - - if (esa_clm_veg (1) == 15) then - CPT1 = 16 - CPT2 = 17 - CPF1 = esa_clm_frac(1) * scale - CPF2 = esa_clm_frac(1) * (1. - scale) - endif - - if (esa_clm_veg (2) == 15) then - CST1 = 16 - CST2 = 17 - CSF1 = esa_clm_frac(2) * scale - CSF2 = esa_clm_frac(2) * (1. - scale) - endif -! ............. - - if (esa_clm_veg (1) == 16) then - CPT1 = 18 - CPT2 = 19 - CPF1 = esa_clm_frac(1) * scale - CPF2 = esa_clm_frac(1) * (1. - scale) - endif - - if (esa_clm_veg (2) == 16) then - CST1 = 18 - CST2 = 19 - CSF1 = esa_clm_frac(2) * scale - CSF2 = esa_clm_frac(2) * (1. - scale) - endif - - ! fractions must sum to 1 - ! ----------------------- - ftot = cpf1 + cpf2 + csf1 + csf2 - - if(ftot /= 100.) then - cpf1 = 100. * cpf1 / ftot - cpf2 = 100. * cpf2 / ftot - csf1 = 100. * csf1 / ftot - csf2 = 100. * csf2 / ftot - endif - - write (10,'(2I10,4I3,4f7.2,2I3,2f7.2)') & - tid,cid,cpt1, cpt2, cst1, cst2, cpf1, cpf2, csf1, csf2, & - esa_clm_veg (1), esa_clm_veg (2), esa_clm_frac(1), esa_clm_frac(2) - - if (allocated (NITYP)) NITYP (k, :) = (/REAL(cpt1), REAL(cpt2), REAL(cst1), REAL(cst2)/) - if (allocated (NFVEG)) NFVEG (k, :) = (/cpf1, cpf2, csf1, csf2/) - - end do - - if(file_exists) then - - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ITY' ) ,(/1,1/),(/maxcat,1/), NITYP (:, 1)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ITY' ) ,(/1,2/),(/maxcat,1/), NITYP (:, 2)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ITY' ) ,(/1,3/),(/maxcat,1/), NITYP (:, 3)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ITY' ) ,(/1,4/),(/maxcat,1/), NITYP (:, 4)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'FVG' ) ,(/1,1/),(/maxcat,1/), NFVEG (:, 1)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'FVG' ) ,(/1,2/),(/maxcat,1/), NFVEG (:, 2)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'FVG' ) ,(/1,3/),(/maxcat,1/), NFVEG (:, 3)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'FVG' ) ,(/1,4/),(/maxcat,1/), NFVEG (:, 4)) ; VERIFY_(STATUS) - DEALLOCATE (NITYP, NFVEG) - STATUS = NF_CLOSE (NCID) ; VERIFY_(STATUS) - - endif - - close (10, status = 'keep') - close (11, status = 'keep') - - END SUBROUTINE ESA2CLM -! -! --------------------------------------------------------------------- -! - SUBROUTINE ESA2MOSAIC (nc, nr, gfile) - - implicit none - - integer , intent (in) :: nc, nr - character (*) :: gfile - integer , parameter :: nc_esa = 129600, nr_esa = 64800 - integer*2, allocatable, target, dimension (:,:) :: esa_veg - integer*2, pointer , dimension (:,:) :: subset - integer , allocatable, dimension (:) :: tile_id, ityp - integer :: i,j, k, status, ncid, maxcat, dx,dy, esa_type, tid, cid - integer :: mos1, mos2 - real :: mfrac, sfrac, tfrac, tem (6) - integer, allocatable, dimension (:) :: density, loc_int - real , allocatable, dimension (:) :: loc_val - logical, allocatable, dimension (:) :: unq_mask - real , allocatable :: veg (:,:) - integer :: NBINS, NPLUS - real, pointer, dimension (:) :: z2, z0 - real, dimension (6) :: VGZ2 = (/35.0, 20.0, 17.0, 0.6, 0.5, 0.6/) ! Dorman and Sellers (1989) - logical :: file_exists - - ! Reading ESA vegetation types - !----------------------------- - - allocate (esa_veg (1:nc_esa, 1: nr_esa)) - - status = NF_OPEN ('data/CATCH/ESA_GlobalCover.nc', NF_NOWRITE, ncid) - - if(status /=0) then - PRINT *, NF_STRERROR(STATUS) - print *, 'Problem with NF_OPEN','ESA_GlobalCover.nc' - stop - endif - - do j = 1,nr_esa - status = NF_GET_VARA_INT2 (ncid,3,(/1,j/),(/nc_esa,1/),esa_veg(:,j)) - if(status /=0) then - PRINT *, NF_STRERROR(STATUS) - print *, 'Problem with NF_GET ESA_GlobalCover.nc : ', STATUS - stop - endif - end do - status = NF_CLOSE(ncid) - -! -! Reading number of tiles -! ----------------------- +! +! Reading number of tiles +! ----------------------- open (10, file = 'clsm/catchment.def', form = 'formatted', status = 'old', & action = 'read') @@ -3744,31 +3019,27 @@ SUBROUTINE soil_para_hwsd (nx,ny,gfiler) integer (kind=4), allocatable, dimension (:) :: tileid_vec,arrayA,arrayB integer (kind=2), allocatable, dimension (:) :: & data_vec1, data_vec2,data_vec3, data_vec4,data_vec5, data_vec6 - REAL, ALLOCATABLE, dimension (:) :: soildepth, grav_vec,soc_vec,poc_vec,& - ncells_top,ncells_top_pro,ncells_sub_pro + REAL, ALLOCATABLE, dimension (:) :: soildepth, grav_vec,soc_vec,poc_vec +! ncells_top,ncells_top_pro,ncells_sub_pro ! ncells_* not used integer(kind=2) , allocatable, dimension (:) :: ss_clay, & ss_sand,ss_clay_all,ss_sand_all,ss_oc_all REAL, ALLOCATABLE :: count_soil(:) integer, allocatable, target, dimension (:,:) :: tile_id integer, pointer :: iRaster(:,:) - integer :: tindex, pfafindex,fac,o_cl,o_clp,fac_surf,vtype + integer :: tindex, pfafindex,fac,o_cl,o_clp,fac_surf !,vtype real,dimension(4) :: cFamily real ,dimension(5) :: cF_lim logical :: first_entry = .true. - logical :: regrid,write_file + logical :: regrid,write_debug INTEGER, allocatable, dimension (:) :: soil_class_top,soil_class_com - REAL :: sf,factor,wp_wetness,fac_count + REAL :: sf,factor,wp_wetness,fac_count,this_cond logical :: CatchParamsNC_file_exists REAL, ALLOCATABLE, DIMENSION (:,:) :: parms4file - ! PEAT-clsm modification - ! Below parameters are from Table 2 of: - ! Bechtold, M., G. J. M. De Lannoy, R. D. Koster, R. H. Reichle, S. Mahanama, W. Bleuten, M.A. Bourgault, C. Brümmer, - ! I. Burdun, A. R. Desai, K. Devito, T. Grünwald, M. Grygoruk, E. R. Humphreys, J. Klatt, J. Kurbatova, A. Lohila, - ! T. M. Munir, M.B. Nilsson, J. S. Price, M. Röhl, A. Schneider, and B. Tiemeyer, 2019. PEAT-CLSM: - ! A specific treatment of peatland hydrology in the NASA Catchment Land Surface Model. J. Adv. Model. Earth Sys., 11, - ! 2130-2162. doi: 10.1029/2018MS001574. - - REAL, PARAMETER :: pmap_thresh = 0.5 + + ! PEATCLSM: + REAL, PARAMETER :: PEATMAP_THRESHOLD_1 = 0.5 ! for converting PEATMAP area fraction into peat/non-peat (on raster grid) + REAL, PARAMETER :: PEATMAP_THRESHOLD_2 = 0.5 ! for aggregation from raster grid cells to tiles + REAL, DIMENSION (:), POINTER :: PMAP REAL, ALLOCATABLE, DIMENSION (:,:) :: PMAPR @@ -3817,56 +3088,78 @@ SUBROUTINE soil_para_hwsd (nx,ny,gfiler) if (first_entry) then nullify(iraster) ; first_entry = .false. endif + + ! define orgC content thresholds for orgC classes 1-4 (low, medium, high, peat) + cF_lim(1) = 0. - cF_lim(2) = 0.4 ! 0.365 ! 0.3 - cF_lim(3) = 0.64 ! 0.585 ! 4.0 - cF_lim(4) = 15./1.72 ! 9.885 ! 8.5 + cF_lim(2) = 0.4 ! 0.365 ! 0.3 + cF_lim(3) = 0.64 ! 0.585 ! 4.0 + cF_lim(4) = 15./1.72 ! 15./1.72=8.72 ! 9.885 ! 8.5 cF_lim(5) = 100.0 + ! define number of mineral classes in each orgC class + nsoil_pcarbon(1) = 84 ! 84 nsoil_pcarbon(2) = nsoil_pcarbon(1) + 84 ! 84 nsoil_pcarbon(3) = nsoil_pcarbon(2) + 84 ! 57 + ! Read number of catchment-tiles (maxcat) from catchment.def file + fname='clsm/catchment.def' -! -! Reading number of cathment-tiles from catchment.def file -! + open (10,file=fname,status='old',action='read',form='formatted') read(10,*) maxcat + close (10,status='keep') + + ! Read tile-id raster file + + allocate(tile_id(1:nx,1:ny)) + + fname=trim(gfiler)//'.rst' + + open (10,file=fname,status='old',action='read', & + form='unformatted',convert='little_endian') + + do j=1,ny + read(10)tile_id(:,j) + end do + close (10,status='keep') + ! read soil depth data from GSWP2_soildepth_H[xx]V[yy].nc + ! + ! get info common to all H[xx]V[yy] rectangles: + fname =trim(c_data)//'SOIL-DATA/GSWP2_soildepth_H11V13.nc' status = NF_OPEN(trim(fname),NF_NOWRITE, ncid); VERIFY_(STATUS) - status = NF_GET_att_INT(ncid,NF_GLOBAL,'i_ind_offset_LL',iLL); VERIFY_(STATUS) - status = NF_GET_att_INT(ncid,NF_GLOBAL,'j_ind_offset_LL',jLL); VERIFY_(STATUS) + !status = NF_GET_att_INT(ncid,NF_GLOBAL,'i_ind_offset_LL',iLL); VERIFY_(STATUS) ! cannot be needed here + !status = NF_GET_att_INT(ncid,NF_GLOBAL,'j_ind_offset_LL',jLL); VERIFY_(STATUS) ! cannot be needed here status = NF_GET_att_INT(ncid,NF_GLOBAL,'N_lon_global',i_highd); VERIFY_(STATUS) status = NF_GET_att_INT(ncid,NF_GLOBAL,'N_lat_global',j_highd); VERIFY_(STATUS) status = NF_INQ_DIM (ncid,1,string, nc_10); VERIFY_(STATUS) status = NF_INQ_DIM (ncid,2,string, nr_10); VERIFY_(STATUS) status = NF_CLOSE(ncid); VERIFY_(STATUS) + + ! GSWP2_soildepth_H[xx]V[yy].nc as of 29 Apr 2022: + ! + ! Associated 43200-by-21600 global grid (1/120=0.083333 deg lat/lon): + ! + ! N_lon_global = i_highd = 43200 + ! N_lat_global = j_highd = 21600 + ! + ! i_ind_offset_LL = iLL = 42001 + ! j_ind_offset_LL = jLL = 19201 + ! + ! Each file contains data for one rectangle of size 1200-by-1200, which is + ! assumed to be the same for each H[xx]V[yy] rectangle + ! + ! N_lon = nc_10 = 1200 + ! N_lat = nr_10 = 1200 - allocate(soildepth(1:maxcat)) allocate(soil_high(1:i_highd,1:j_highd)) - allocate(count_soil(1:maxcat)) - allocate(tile_id(1:nx,1:ny)) allocate(net_data1 (1:nc_10,1:nr_10)) - fname=trim(gfiler)//'.rst' -! -! Reading tile-id raster file -! - open (10,file=fname,status='old',action='read', & - form='unformatted',convert='little_endian') - - do j=1,ny - read(10)tile_id(:,j) - end do - - close (10,status='keep') -! -! reading soil depth data -! soil_high = -9999 do jx = 1,18 do ix = 1,36 @@ -3894,7 +3187,12 @@ SUBROUTINE soil_para_hwsd (nx,ny,gfiler) deallocate (net_data1) -! Regridding + ! Regridding + + ! *EASE* grid bcs use mask file GEOS5_10arcsec_mask.nc or GEOS5_10arcsec_mask_freshwater-lakes.nc, + ! and the make_bcs script assigns NX=43200, NY=21600, which are passed into the present subroutine + ! via command-line arguments of mkCatchParam.x. That is, should have regrid=.false. for *EASE* + ! grid tile space. nx_adj = nx ny_adj = ny @@ -3929,17 +3227,20 @@ SUBROUTINE soil_para_hwsd (nx,ny,gfiler) iRaster => tile_id end if -! Interpolation or aggregation on to catchment-tiles - - soildepth =0. - count_soil = 0. + ! Interpolate/aggregate soil depth from raster grid to catchment-tiles + + allocate(soildepth(1:maxcat)) + allocate(count_soil(1:maxcat)) + + soildepth = 0. ! 1-d tile space + count_soil = 0. ! 1-d tile space do j=1,ny_adj do i=1,nx_adj if((iRaster(i,j).gt.0).and.(iRaster(i,j).le.maxcat)) then if ((raster(i,j).gt.0)) then soildepth(iRaster(i,j)) = & - soildepth(iRaster(i,j)) + sf*raster(i,j) + soildepth(iRaster(i,j)) + sf*raster(i,j) ! integer "raster" --> real "soildepth" count_soil(iRaster(i,j)) = & count_soil(iRaster(i,j)) + 1. endif @@ -3949,28 +3250,50 @@ SUBROUTINE soil_para_hwsd (nx,ny,gfiler) DO n =1,maxcat if(count_soil(n)/=0.) soildepth(n)=soildepth(n)/count_soil(n) - soildepth(n) = max(soildepth(n),1334.) + soildepth(n) = max(soildepth(n),SOILDEPTH_MIN_HWSD) ! soildepth(n) = soildepth(n) + 2000. ! soildepth(n) = min(soildepth(n),8000.) END DO deallocate (SOIL_HIGH) - deallocate (count_soil) + !deallocate (count_soil) ! do not deallocate, needed again shortly NULLIFY(Raster) -! -! Reading NGDC-HWSD-STATSGO merged Soil Properties -! + + ! --------------------------------------------------------------------------------- + ! + ! Read NGDC-HWSD-STATSGO merged soil texture from SoilProperties_H[xx]V[yy].nc' + ! + ! get info common to all H[xx]V[yy] rectangles (could in theory differ from that + ! of soildepth data read above but is the same as of 29 Apr 2022). + fname =trim(c_data)//'SOIL-DATA/SoilProperties_H11V13.nc' status = NF_OPEN(trim(fname),NF_NOWRITE, ncid); VERIFY_(STATUS) - status = NF_GET_att_INT(ncid,NF_GLOBAL,'i_ind_offset_LL',iLL); VERIFY_(STATUS) - status = NF_GET_att_INT(ncid,NF_GLOBAL,'j_ind_offset_LL',jLL); VERIFY_(STATUS) + !status = NF_GET_att_INT(ncid,NF_GLOBAL,'i_ind_offset_LL',iLL); VERIFY_(STATUS) ! cannot be needed here + !status = NF_GET_att_INT(ncid,NF_GLOBAL,'j_ind_offset_LL',jLL); VERIFY_(STATUS) ! cannot be needed here status = NF_GET_att_INT(ncid,NF_GLOBAL,'N_lon_global',i_highd); VERIFY_(STATUS) status = NF_GET_att_INT(ncid,NF_GLOBAL,'N_lat_global',j_highd); VERIFY_(STATUS) - status = NF_INQ_DIM (ncid,1,string, nc_10); VERIFY_(STATUS) - status = NF_INQ_DIM (ncid,2,string, nr_10); VERIFY_(STATUS) - status = NF_CLOSE(ncid) + status = NF_INQ_DIM (ncid,1,string, nc_10); VERIFY_(STATUS) + status = NF_INQ_DIM (ncid,2,string, nr_10); VERIFY_(STATUS) + status = NF_CLOSE(ncid) + + ! SoilProperties_H[xx]V[yy].nc as of 29 Apr 2022: + ! + ! Associated 43200-by-21600 global grid (1/120=0.083333 deg lat/lon): + ! + ! N_lon_global = i_highd = 43200 + ! N_lat_global = j_highd = 21600 + ! + ! i_ind_offset_LL = iLL = 42001 + ! j_ind_offset_LL = jLL = 19201 + ! + ! Each file contains soil texture data for one rectangle of size 1200-by-1200, which is + ! assumed to be the same for each H[xx]V[yy] rectangle + ! + ! N_lon = nc_10 = 1200 + ! N_lat = nr_10 = 1200 - regrid = nx/=i_highd .or. ny/=j_highd + !regrid = nx/=i_highd .or. ny/=j_highd ! not needed here, done below + allocate(net_data1 (1:nc_10,1:nr_10)) allocate(net_data2 (1:nc_10,1:nr_10)) allocate(net_data3 (1:nc_10,1:nr_10)) @@ -3987,13 +3310,13 @@ SUBROUTINE soil_para_hwsd (nx,ny,gfiler) allocate(oc_sub (1:i_highd,1:j_highd)) allocate(grav_grid(1:i_highd,1:j_highd)) - sand_top = -9999. - clay_top = -9999. - oc_top = -9999. - sand_sub = -9999. - clay_sub = -9999. - oc_sub = -9999. - grav_grid= -9999. + sand_top = -9999 ! integer*2 + clay_top = -9999 ! integer*2 + oc_top = -9999 ! integer*2 + sand_sub = -9999 ! integer*2 + clay_sub = -9999 ! integer*2 + oc_sub = -9999 ! integer*2 + grav_grid= -9999 ! integer*2 do jx = 1,18 do ix = 1,36 @@ -4004,7 +3327,9 @@ SUBROUTINE soil_para_hwsd (nx,ny,gfiler) if(status == 0) then status = NF_GET_att_INT (ncid, NF_GLOBAL,'i_ind_offset_LL',iLL); VERIFY_(STATUS) status = NF_GET_att_INT (ncid, NF_GLOBAL,'j_ind_offset_LL',jLL); VERIFY_(STATUS) - status = NF_GET_att_INT (ncid, 4,'UNDEF',d_undef); VERIFY_(STATUS) + ! assume UNDEF and ScaleFactor (sf) are the same for *all* variables read below + ! (ok for SoilProperties_H[xx]V[yy].nc as of 29 Apr 2022). + status = NF_GET_att_INT (ncid, 4,'UNDEF',d_undef); VERIFY_(STATUS) status = NF_GET_att_REAL (ncid, 4,'ScaleFactor',sf); VERIFY_(STATUS) status = NF_GET_VARA_INT (ncid, 4,(/1,1/),(/nc_10,nr_10/),net_data1); VERIFY_(STATUS) status = NF_GET_VARA_INT (ncid, 5,(/1,1/),(/nc_10,nr_10/),net_data2); VERIFY_(STATUS) @@ -4035,22 +3360,32 @@ SUBROUTINE soil_para_hwsd (nx,ny,gfiler) endif end do end do + + deallocate (net_data1) + deallocate (net_data2) + deallocate (net_data3) + deallocate (net_data4) + deallocate (net_data5) + deallocate (net_data6) + deallocate (net_data7) + ! ---------------------------------------------------------------------------- + if(use_PEATMAP) then - print *, 'PMAP_THRESH : ', pmap_thresh + print *, 'PEATMAP_THRESHOLD_1 : ', PEATMAP_THRESHOLD_1 allocate(pmapr (1:i_highd,1:j_highd)) status = NF_OPEN ('data/CATCH/PEATMAP_mask.nc4', NF_NOWRITE, ncid) status = NF_GET_VARA_REAL (ncid,NC_VarID(NCID,'PEATMAP'), (/1,1/),(/i_highd, j_highd/), pmapr) ; VERIFY_(STATUS) -! move HWSD sub-surface peat to peat-rich mineral Group 3 because merged surface peat defines sub-surface peat -! ------------------------------------------------------------------------------------------------------------ + ! move HWSD sub-surface peat to peat-rich mineral Group 3 because merged surface peat defines sub-surface peat + where (oc_sub*sf >= cF_lim(4)) oc_sub = NINT(8./sf) endwhere -! Hybridize: add OC 1km PEATMAP pixels to HWSD oc_top -! --------------------------------------------------- - where (pmapr >= pmap_thresh) + ! Hybridize: add OC 1km PEATMAP pixels to HWSD oc_top + + where (pmapr >= PEATMAP_THRESHOLD_1) oc_top = NINT(33.0/sf) endwhere @@ -4058,20 +3393,19 @@ SUBROUTINE soil_para_hwsd (nx,ny,gfiler) status = NF_CLOSE(ncid) endif - deallocate (net_data1) - deallocate (net_data2) - deallocate (net_data3) - deallocate (net_data4) - deallocate (net_data5) - deallocate (net_data6) - deallocate (net_data7) + ! ---------------------------------------------------------------------------- -! now regridding + ! Regridding + + ! *EASE* grid bcs use mask file GEOS5_10arcsec_mask.nc or GEOS5_10arcsec_mask_freshwater-lakes.nc, + ! and the make_bcs script assigns NX=43200, NY=21600, which are passed into the present subroutine + ! via command-line arguments of mkCatchParam.x. That is, should have regrid=.false. for *EASE* + ! grid tile space. nx_adj = nx ny_adj = ny - regrid = nx/=i_highd .or. ny/=j_highd + regrid = nx/=i_highd .or. ny/=j_highd if(regrid) then if(nx > i_highd) then @@ -4133,15 +3467,16 @@ SUBROUTINE soil_para_hwsd (nx,ny,gfiler) raster6 => oc_sub raster => grav_grid end if + + ! ---------------------------------------------------------------------------- - - ! compute peat fraction on tile for CLM45+ + ! compute peat fraction on tile for CLM45+ (for fires?) allocate(pmap (1:maxcat)) - allocate(count_soil(1:maxcat)) + !allocate(count_soil(1:maxcat)) ! already allocated above - pmap = 0. - count_soil = 0. + pmap = 0. ! 1-d tile space; peat fraction in tile based on oc_top + count_soil = 0. ! 1-d tile space do j=1,ny_adj do i=1,nx_adj @@ -4156,14 +3491,19 @@ SUBROUTINE soil_para_hwsd (nx,ny,gfiler) where (count_soil > 0) pmap = pmap /count_soil - deallocate (count_soil) -! Deallocate large arrays + !deallocate (count_soil) ! do not deallocate, needed again shortly + + ! ---------------------------------------------------------------------------- + + ! get number of "land" pixels (i1) on raster grid allocate(land_pixels(1:size(iRaster,1),1:size(iRaster,2))) land_pixels = (iRaster >=1).and.(iRaster<=maxcat) i1 = count(land_pixels) deallocate (land_pixels) + ! allocate 1-d arrays for all "land" pixels on raster grid + allocate (tileid_vec(1:i1)) allocate (data_vec1 (1:i1)) allocate (data_vec2 (1:i1)) @@ -4171,37 +3511,49 @@ SUBROUTINE soil_para_hwsd (nx,ny,gfiler) allocate (data_vec4 (1:i1)) allocate (data_vec5 (1:i1)) allocate (data_vec6 (1:i1)) + + ! allocate 1-d arrays for all "land" tiles + allocate (grav_vec (1:maxcat)) allocate (soc_vec (1:maxcat)) allocate (poc_vec (1:maxcat)) - allocate (ncells_top (1:maxcat)) - allocate (ncells_top_pro (1:maxcat)) - allocate (ncells_sub_pro (1:maxcat)) - allocate(count_soil(1:maxcat)) + !allocate (ncells_top (1:maxcat)) ! ncells_* not used + !allocate (ncells_top_pro (1:maxcat)) ! ncells_* not used + !allocate (ncells_sub_pro (1:maxcat)) ! ncells_* not used + !allocate(count_soil(1:maxcat)) + count_soil = 0. grav_vec = 0. - soc_vec = 0. - poc_vec = 0. - ncells_top = 0. - ncells_top_pro = 0. - ncells_sub_pro = 0. + soc_vec = 0. ! soil orgC (top layer 0-30) + poc_vec = 0. ! soil orgC (profile layer 0-100) + + !ncells_top = 0. ! ncells_* not used + !ncells_top_pro = 0. ! ncells_* not used + !ncells_sub_pro = 0. ! ncells_* not used n =1 do j=1,ny_adj do i=1,nx_adj if((iRaster(i,j).ge.1).and.(iRaster(i,j).le.maxcat)) then - tileid_vec (n) = iRaster(i,j) - data_vec1 (n) = Raster1(i,j) - data_vec2 (n) = Raster2(i,j) - data_vec3 (n) = Raster3(i,j) - data_vec4 (n) = Raster4(i,j) - data_vec5 (n) = Raster5(i,j) - data_vec6 (n) = Raster6(i,j) + ! map from 2-d raster array to 1-d raster vec + + tileid_vec (n) = iRaster(i,j) ! iRaster => tile_id int*4 + data_vec1 (n) = Raster1(i,j) ! raster1 => clay_top int*2 + data_vec2 (n) = Raster2(i,j) ! raster2 => sand_top int*2 + data_vec3 (n) = Raster3(i,j) ! raster3 => oc_top int*2 + data_vec4 (n) = Raster4(i,j) ! raster4 => clay_sub int*2 + data_vec5 (n) = Raster5(i,j) ! raster5 => sand_sub int*2 + data_vec6 (n) = Raster6(i,j) ! raster6 => oc_sub int*2 + + ! BUG??? It is unclear why here grav_vec is filled in the order of "tile_id" + ! while data_vec[x] is filled in the order of the long/lat grid. + ! Not sure if grav_vec is processed correctly below! + ! -reichle, 29 Apr 2022 if ((raster(i,j).gt.0)) then grav_vec(iRaster(i,j)) = & - grav_vec(iRaster(i,j)) + sf*raster(i,j) + grav_vec(iRaster(i,j)) + sf*raster(i,j) ! raster => grav_grid int*2 count_soil(iRaster(i,j)) = & count_soil(iRaster(i,j)) + 1. endif @@ -4214,16 +3566,15 @@ SUBROUTINE soil_para_hwsd (nx,ny,gfiler) if(count_soil(n)/=0.) grav_vec(n)=grav_vec(n)/count_soil(n) END DO - deallocate (grav_grid) deallocate (count_soil) - NULLIFY(Raster) - - NULLIFY(Raster1,Raster2,Raster3,Raster4,Raster5,Raster6) - deallocate (clay_top,sand_top,oc_top,clay_sub,sand_sub,oc_sub) + NULLIFY(Raster,Raster1,Raster2,Raster3,Raster4,Raster5,Raster6) + deallocate (clay_top,sand_top,oc_top,clay_sub,sand_sub,oc_sub,grav_grid) deallocate (tile_id) - allocate (arrayA (1:i1)) - allocate (arrayB (1:i1)) + ! sort 1-d land pixels vectors according to tile_id + + allocate (arrayA (1:i1)) ! 1-d land pixels on raster grid + allocate (arrayB (1:i1)) ! 1-d land pixels on raster grid arrayA = tileid_vec arrayB = data_vec1 @@ -4254,11 +3605,15 @@ SUBROUTINE soil_para_hwsd (nx,ny,gfiler) arrayB = data_vec6 call MAPL_Sort (arrayA, arrayB) data_vec6 = arrayB + tileid_vec= arrayA + deallocate (arrayA, arrayB) -! -! Reading Woesten Soil Parameters and CLSM tau parameters -! + + ! -------------------------------------------------------------------- + ! + ! Read Woesten soil parameters and CLSM tau parameters for soil classes (1:253) + allocate(a_sand (1:n_SoilClasses)) allocate(a_clay (1:n_SoilClasses)) allocate(a_silt (1:n_SoilClasses)) @@ -4274,33 +3629,61 @@ SUBROUTINE soil_para_hwsd (nx,ny,gfiler) allocate(btau_2cm(1:n_SoilClasses)) allocate(a_wpsurf(1:n_SoilClasses)) allocate(a_porosurf(1:n_SoilClasses)) + + ! SoilClasses-SoilHyd-TauParam.dat and SoilClasses-SoilHyd-TauParam.peatmap differ + ! only in the parameters for the peat class #253. The file *.peatmap contains + ! the PEATCLSM parameters from Table 2 of Bechtold et al. 2019 (doi:10.1029/2018MS001574). + ! + ! Note: K_s = COND*exp(-zks*gnu) ==> with zks=2 and gnu=1, K_s = 0.135335*COND + ! + ! K_s COND [m/s] + ! NLv4 7.86e-7 5.81e-6 + ! NLv5 3.79e-6 2.80e-5 <== note *typo* in Table 2 of Bechtold et al. 2019, which erroneously lists K_s=2.8e-5 + if(use_PEATMAP) then fname = trim(c_data)//'SoilClasses-SoilHyd-TauParam.peatmap' else fname = trim(c_data)//'SoilClasses-SoilHyd-TauParam.dat' endif - table_map = 0 + + table_map = 0 ! 100-by-3 look-up table + open (11, file=trim(fname), form='formatted',status='old', & action = 'read') - read (11,'(a)')fout - do n =1,n_SoilClasses + read (11,'(a)')fout ! read header line + + do n =1,n_SoilClasses + read (11,'(4f7.3,4f8.4,e13.5,2f12.7,2f8.4,4f12.7)')a_sand(n),a_clay(n),a_silt(n),a_oc(n),a_bee(n),a_psis(n), & a_poros(n),a_wp(n),a_aksat(n),atau(n),btau(n),a_wpsurf(n),a_porosurf(n),atau_2cm(n),btau_2cm(n) + ! assemble scalar structure that holds mineral percentages of soil class n + min_percs%clay_perc = a_clay(n) min_percs%silt_perc = a_silt(n) min_percs%sand_perc = a_sand(n) - if(n <= nsoil_pcarbon(1)) table_map(soil_class (min_percs),1) = n - if((n > nsoil_pcarbon(1)).and.(n <= nsoil_pcarbon(2))) table_map(soil_class (min_percs),2) = n - if((n > nsoil_pcarbon(2)).and.(n <= nsoil_pcarbon(3))) table_map(soil_class (min_percs),3) = n + + ! "soil_class" is an integer function (see rmTinyCatchParam.F90) that assigns + ! an integer (mineral) soil class [1-100] for a given mineral percentage triplet + + ! "table_map" is a 2-d array (100-by-3) that maps between overall soil class (1:252) and + ! (mineral_class 1:84, orgC_class). "table_map" has no entry for the peat class #253. + + if( n <= nsoil_pcarbon(1)) table_map(soil_class (min_percs),1) = n + if((n > nsoil_pcarbon(1)).and.(n <= nsoil_pcarbon(2))) table_map(soil_class (min_percs),2) = n + if((n > nsoil_pcarbon(2)).and.(n <= nsoil_pcarbon(3))) table_map(soil_class (min_percs),3) = n + + end do ! n=1,n_SoilClasses - end do close (11,status='keep') -! -! When Woesten Soil Parameters are not available for a particular Soil Class -! ,as assumed by tiny triangles in HWSD soil triangle, Woesten Soil -! parameters from the nearest available tiny triangle will be substituted. -! + + ! ------------------------------------------------------------ + ! + ! When Woesten soil parameters are not available for a particular soil class, + ! as defined by "tiny" triangles in HWSD soil triangle, Woesten soil + ! parameters from the nearest available "tiny" triangle will be substituted. + ! For "tiny" triangles, see Fig 1b of De Lannoy et al. 2014 (doi:10.1002/2014MS000330). + do n =1,10 do k=1,n*2 -1 @@ -4374,30 +3757,47 @@ SUBROUTINE soil_para_hwsd (nx,ny,gfiler) !$OMP sf,data_vec1,data_vec2,data_vec3, & !$OMP data_vec4,data_vec5,data_vec6,cF_lim, & !$OMP table_map,soil_class_top,soil_class_com, & -!$OMP soc_vec,poc_vec,ncells_top,ncells_top_pro,& -!$OMP ncells_sub_pro,use_PEATMAP) & +!$OMP soc_vec,poc_vec,use_PEATMAP) & +!ncells_* not used !$OMP soc_vec,poc_vec,ncells_top,ncells_top_pro,& +!ncells_* not used !$OMP ncells_sub_pro,use_PEATMAP) & !$OMP PRIVATE(n,i,j,k,icount,t_count,i1,i2,ss_clay, & !$OMP ss_sand,ss_clay_all,ss_sand_all, & !$OMP ss_oc_all,cFamily,factor,o_cl,o_clp,ktop, & -!$OMP min_percs, fac_count, write_file) +!$OMP min_percs, fac_count, write_debug) + + ! loop through tiles (split into two loops for OpenMP) DO t_count = 1,n_threads DO n = low_ind(t_count),upp_ind(t_count) - write_file = .false. + write_debug = .false. + +! if (n==171010) write_debug = .true. -! if (n==171010) write_file = .true. + ! initialize "icount" when starting loop through n at low_ind(t_count) + ! recall: tileid_vec is a 1-d vector that covers all land pixels on the raster grid that + ! contains the (sorted) tile IDs, with matching parameter vectors data_vec[x] if(n==low_ind(t_count)) then icount = 1 + ! Not sure what the following loops do. Why not check backwards from low_ind(t_count)?? do k=1,low_ind(t_count) - 1 - do while (tileid_vec(icount)== k) + do while (tileid_vec(icount)== k) icount = icount + 1 end do end do endif + + ! ------------------------------------------------------------------ + ! + ! determine the land raster grid cells i1:i2 that make up tile n + + ! NOTE change in meaning of "i1": + ! + ! before: i1 = total no. of land pixels on the raster grid + ! now: i1 = starting index of land raster grid cells (within 1-d vector) that make up tile n (?) - i1 = icount + i1 = icount loop: do while (tileid_vec(icount)== n) if(icount <= size(tileid_vec,1)) icount = icount + 1 @@ -4405,49 +3805,79 @@ SUBROUTINE soil_para_hwsd (nx,ny,gfiler) end do loop i2 = icount -1 - i = i2 - i1 + 1 + i = i2 - i1 + 1 ! number of land raster grid cells that make up tile n (?) - allocate(ss_clay (1:2*i)) - allocate(ss_sand (1:2*i)) - allocate(ss_clay_all(1:2*i)) - allocate(ss_sand_all(1:2*i)) - allocate(ss_oc_all (1:2*i)) + + ! ------------------------------------------------------------------- + ! + ! prep data + + allocate(ss_clay (1:2*i)) ! for top layer (0-30) -- why allocate 1:2*i and not 1:i?? + allocate(ss_sand (1:2*i)) ! for top layer (0-30) -- why allocate 1:2*i and not 1:i?? + + allocate(ss_clay_all(1:2*i)) ! for top (0-30) and sub (30-100) layers + allocate(ss_sand_all(1:2*i)) ! for top (0-30) and sub (30-100) layers + allocate(ss_oc_all (1:2*i)) ! for top (0-30) and sub (30-100) layers - ss_clay = 0 - ss_sand = 0 - ss_clay_all= 0 - ss_sand_all= 0 - ss_oc_all = 0 + ss_clay = 0 ! int*2 -- why only clay and sand for top layer and not orgC ?? + ss_sand = 0 ! int*2 + + ss_clay_all= 0 ! int*2 + ss_sand_all= 0 ! int*2 + ss_oc_all = 0 ! int*2 - ss_clay_all (1:i) = data_vec1(i1:i2) + ss_clay_all (1:i) = data_vec1(i1:i2) ! put top layer info into first i elements (1:i) ss_sand_all (1:i) = data_vec2(i1:i2) ss_oc_all (1:i) = data_vec3(i1:i2) - ss_clay_all (1+i:2*i) = data_vec4(i1:i2) + + ss_clay_all (1+i:2*i) = data_vec4(i1:i2) ! put sub layer info into next i elements (i+1:2*i) ss_sand_all (1+i:2*i) = data_vec5(i1:i2) - ss_oc_all (1+i:2*i) = data_vec6(i1:i2) + ss_oc_all (1+i:2*i) = data_vec6(i1:i2) ! <-- oc_sub + + + ! ----------------------------------------------------------------------- + ! + ! determine aggregate/dominant orgC *top* layer soil class ("o_cl") of tile n cFamily = 0. +!! factor = 1. do j=1,i - if(j <= i) factor = 1. + if(j <= i) factor = 1. if((ss_oc_all(j)*sf >= cF_lim(1)).and. (ss_oc_all(j)*sf < cF_lim(2))) cFamily(1) = cFamily(1) + factor if((ss_oc_all(j)*sf >= cF_lim(2)).and. (ss_oc_all(j)*sf < cF_lim(3))) cFamily(2) = cFamily(2) + factor if((ss_oc_all(j)*sf >= cF_lim(3)).and. (ss_oc_all(j)*sf < cF_lim(4))) cFamily(3) = cFamily(3) + factor if((ss_oc_all(j)*sf >= cF_lim(4) )) cFamily(4) = cFamily(4) + factor end do - if (sum(cFamily) == 0.) o_cl = 1 - if (sum(cFamily) > 0.) o_cl = maxloc(cFamily, dim = 1) + if (sum(cFamily) == 0.) o_cl = 1 ! default is o_cl=1 (if somehow no grid cell has top-layer orgC >=0.) + +!! if (.not. use_PEATMAP) then + + ! assign dominant *top* layer org soil class (even if only a minority of the contributing + ! raster grid cells is peat) + + if (sum(cFamily) > 0.) o_cl = maxloc(cFamily, dim = 1) + +!! else if (use_PEATMAP) then - ! if 50% or more of the tile surface is covered with peat, we assume the tile is peat - if (cFamily(4)/real(i) > 0.5) then + + ! PEATMAP: tile has *top* layer peat class only if more than 50% of the contributing + ! raster grid cells are peat (may loose some peat tiles w.r.t. non-PEATMAP bcs version) + + if (cFamily(4)/real(i) > PEATMAP_THRESHOLD_2) then o_cl = 4 else - if (sum(cFamily(1:3)) > 0.) o_cl = maxloc(cFamily(1:3), dim = 1) + if (sum(cFamily(1:3)) > 0.) o_cl = maxloc(cFamily(1:3), dim = 1) ! o_cl = 1, 2, or 3 endif - endif + endif + + + ! determine aggregate/dominant orgC *profile* (0-100) soil class ("o_clp") of tile n, + ! weight factor=1. for top (0-30) layer and weight factor=2.33 for sub (30-100) layer + cFamily = 0. do j=1,2*i @@ -4458,55 +3888,98 @@ SUBROUTINE soil_para_hwsd (nx,ny,gfiler) if((ss_oc_all(j)*sf >= cF_lim(3)).and. (ss_oc_all(j)*sf < cF_lim(4))) cFamily(3) = cFamily(3) + factor if((ss_oc_all(j)*sf >= cF_lim(4) )) cFamily(4) = cFamily(4) + factor end do + + ! NOTE: For PEATMAP, oc_sub was cut back to 8./sf above: + ! "! move HWSD sub-surface peat to peat-rich mineral Group 3 because merged surface peat defines sub-surface peat" + ! "where (oc_sub*sf >= cF_lim(4)) " + ! " oc_sub = NINT(8./sf) " + ! "endwhere " + ! For PEATMAP, the sub-layer weight of 2.33 should only count towards cFamily(1:3), and in most cases the + ! maxloc statement below should therefore result in o_clp = 1, 2, or 3 only. However, if the top-layer orgC + ! is peat for most contributing raster grid cells and the sub-layer orgC values are relatively evenly spread + ! over orgC classes 1, 2, and 3, then maxloc(cFamily) can result in o_clp=4. if (sum(cFamily) == 0.) o_clp = 1 - if (sum(cFamily) > 0.) o_clp = maxloc(cFamily, dim = 1) + if (sum(cFamily) > 0.) o_clp = maxloc(cFamily, dim = 1) + + ! ---------------------------------------------------------------------------------------- + ! + ! Determine *top* layer mineral/organic soil class of tile n if(o_cl == 4) then + + ! Top-layer soil class of tile n is peat. + ! Compute average top-layer orgC (only across raster grid cells whose top layer is peat). + soil_class_top(n) = n_SoilClasses ktop = 0 do j=1,i - if(ss_oc_all(j)*sf >= cF_lim(4)) then + ! avg only across contributing raster grid cells that are peat + if(ss_oc_all(j)*sf >= cF_lim(4)) then soc_vec (n) = soc_vec(n) + ss_oc_all(j)*sf ktop = ktop + 1 endif end do if(ktop.ne.0) soc_vec (n) = soc_vec(n)/ktop - ncells_top(n) = 100.*float(ktop)/float(i) + !ncells_top(n) = 100.*float(ktop)/float(i) ! ncells_* not used + else - k = 1 - ktop = 1 + + ! Top-layer soil class of tile n is mineral. + ! Compute average top-layer orgC (only across raster grid cells within same orgC class) + ! and collect all clay/sand pairs of raster grid cells within same orgC class. - do j=1,i + !k = 1 !cleanup k counter + !ktop = 1 !cleanup k counter + ktop = 0 !cleanup k counter + + do j=1,i ! loop only through top-layer elements of ss_*_all + + ! avg only across contributing raster grid cells with orgC class as that assigned to tile n if((ss_oc_all(j)*sf >= cF_lim(o_cl)).and.(ss_oc_all(j)*sf < cF_lim(o_cl + 1))) then - if((ss_clay_all(j)*sf >= 0.).and.(ss_sand_all(j)*sf >= 0.)) then - ss_clay (k) = ss_clay_all(j) - ss_sand (k) = ss_sand_all(j) - if((ss_clay (k) + ss_sand (k)) > 9999) then - if(ss_clay (k) >= ss_sand (k)) then - ss_sand (k) = 10000 - ss_clay (k) + + if((ss_clay_all(j)*sf >= 0.).and.(ss_sand_all(j)*sf >= 0.)) then ! avoiding no-data-values + + ktop = ktop + 1 !cleanup k counter + ss_clay (ktop) = ss_clay_all(j) + ss_sand (ktop) = ss_sand_all(j) + + ! adjust clay and sand content if outside joint physical bounds + if((ss_clay (ktop) + ss_sand (ktop)) > 9999) then ! note: 9999 = 99.99% (scale factor = 0.01) + if(ss_clay (ktop) >= ss_sand (ktop)) then + ss_sand (ktop) = 10000 - ss_clay (ktop) else - ss_clay (k) = 10000 - ss_sand (k) + ss_clay (ktop) = 10000 - ss_sand (ktop) endif endif - soc_vec (n) = soc_vec(n) + ss_oc_all(j)*sf - k = k + 1 - ktop = ktop + 1 + soc_vec (n) = soc_vec(n) + ss_oc_all(j)*sf ! sum up top-layer orgC + !k = k + 1 !cleanup k counter + !ktop = ktop + 1 !cleanup k counter endif endif end do - k = k - 1 - ktop = ktop -1 - if(ktop.ne.0) soc_vec (n) = soc_vec(n)/ktop - ncells_top(n) = 100.*float(ktop)/float(i) - if (write_file) write(80+n,*)ktop,o_cl + !k = k - 1 !cleanup k counter + !ktop = ktop -1 !cleanup k counter + + if(ktop.ne.0) soc_vec (n) = soc_vec(n)/ktop ! normalize top-layer orgC + + !ncells_top(n) = 100.*float(ktop)/float(i) ! ncells_* not used + + ! debugging output + if (write_debug) write(80+n,*)ktop,o_cl if(ktop > 0) then - if (write_file) write (80+n,*)ss_clay(1:ktop) - if (write_file) write (80+n,*)ss_sand(1:ktop) + if (write_debug) write (80+n,*)ss_clay(1:ktop) + if (write_debug) write (80+n,*)ss_sand(1:ktop) endif + + ! Determine the raster grid cell j that has (top-layer) clay/sand content closest + ! to the average (top-layer) clay/sand across all raster grid cells within the + ! dominant orgC class. + j = center_pix_int0(sf, ktop,ktop, ss_clay(1:ktop),ss_sand(1:ktop)) - if (write_file) write(80+n,*)j + + ! Assign soil class of raster grid cell j to tile n if(j >=1) then min_percs%clay_perc = ss_clay(j)*sf @@ -4514,142 +3987,220 @@ SUBROUTINE soil_para_hwsd (nx,ny,gfiler) min_percs%silt_perc = 100. - ss_clay(j)*sf - ss_sand(j)*sf soil_class_top (n) = table_map(soil_class (min_percs),o_cl) endif + + ! debugging output + if (write_debug) write(80+n,*)j + endif - if (write_file) write(80+n,*)soil_class_top (n) + + ! debugging output + if (write_debug) write(80+n,*)soil_class_top (n) + + ! ------------------------------------------------------------------------------- + ! + ! determine aggregate sand/clay/orgC for *profile* layer of tile n + if(o_clp == 4) then + + ! Profile-layer soil class of tile n is peat. + ! Compute average profile-layer orgC (only across raster grid cells and layers that are peat) + soil_class_com(n) = n_SoilClasses fac_count = 0. k =0 ktop =0 do j=1,2*i if(ss_oc_all(j)*sf >= cF_lim(4)) then - if(j <= i) factor = 1. - if(j > i) factor = 2.33 - if(j > i) k = k + 1 - if(j <= i) ktop = ktop + 1 - poc_vec (n) = poc_vec(n) + ss_oc_all(j)*sf*factor - fac_count = fac_count + factor + if(j <= i) factor = 1. ! top layer contribution 1 <= j <=i + if(j > i) factor = 2.33 ! sub layer contribution i+1 <= j <=2*i + if(j > i) k = k + 1 ! sub layer counter + if(j <= i) ktop = ktop + 1 ! top layer counter + poc_vec (n) = poc_vec(n) + ss_oc_all(j)*sf*factor ! weighted sum of orgC + fac_count = fac_count + factor ! sum of weights endif end do - if(fac_count.ne.0) poc_vec (n) = poc_vec (n)/fac_count - ncells_sub_pro(n) = 100.*float(k)/float(i) - ncells_top_pro(n) = 100.*float(ktop)/float(i) + if(fac_count.ne.0) poc_vec (n) = poc_vec (n)/fac_count ! normalize + !ncells_sub_pro(n) = 100.*float(k)/float(i) ! ncells_* not used + !ncells_top_pro(n) = 100.*float(ktop)/float(i) ! ncells_* not used else - k = 1 - ktop = 1 + + ! Profile-layer soil class of tile n is mineral. + ! Compute average profile-layer orgC (only across raster grid cells within same orgC class) + ! and collect all clay/sand pairs of raster grid cells within same orgC class. + + !k = 1 !cleanup k counter + !ktop = 1 !cleanup k counter + k = 0 !cleanup k counter + ktop = 0 !cleanup k counter ss_clay=0 ss_sand=0 fac_count = 0. - do j=1,2*i + do j=1,2*i ! loop through both top (1<=j<=i) layer and sub (i+1<=j<=2*i) layer elements + + ! avg only across contributing raster grid cells and layers with orgC class as that assigned to tile n if((ss_oc_all(j)*sf >= cF_lim(o_clp)).and.(ss_oc_all(j)*sf < cF_lim(o_clp + 1))) then - if((ss_clay_all(j)*sf >= 0.).and.(ss_sand_all(j)*sf >= 0.)) then - if(j <= i) factor = 1. - if(j > i) factor = 2.33 - poc_vec (n) = poc_vec(n) + ss_oc_all(j)*sf*factor + + if((ss_clay_all(j)*sf >= 0.).and.(ss_sand_all(j)*sf >= 0.)) then ! avoiding no-data-values + + if(j <= i) factor = 1. ! top layer contribution + if(j > i) factor = 2.33 ! sub layer contribution + + poc_vec (n) = poc_vec(n) + ss_oc_all(j)*sf*factor ! weighted sum of orgC fac_count = fac_count + factor - if(j <= i) then - ss_clay (k) = ss_clay_all(j) - ss_sand (k) = ss_sand_all(j) - if((ss_clay (k) + ss_sand (k)) > 9999) then - if(ss_clay (k) >= ss_sand (k)) then - ss_sand (k) = 10000 - ss_clay (k) - else - ss_clay (k) = 10000 - ss_sand (k) - endif - endif - k = k + 1 - ktop = ktop + 1 - else - ss_clay (k) = ss_clay_all(j) - ss_sand (k) = ss_sand_all(j) - if((ss_clay (k) + ss_sand (k)) > 9999) then - if(ss_clay (k) >= ss_sand (k)) then - ss_sand (k) = 10000 - ss_clay (k) - else - ss_clay (k) = 10000 - ss_sand (k) - endif - endif - k = k + 1 - endif - endif + + k = k + 1 ! counter for top and sub contributions !cleanup k counter + + if (j<=i) ktop = ktop + 1 ! counter for top contributions only !cleanup k counter + + +!obsolete20220502 The code within the if-then and if-else statements below was nearly identical, +!obsolete20220502 except for the omission of the ktop counter from the else block. +!obsolete20220502 +!obsolete20220502 if(j <= i) then + + ss_clay (k) = ss_clay_all(j) + ss_sand (k) = ss_sand_all(j) + + ! adjust clay and sand content if outside joint physical bounds + if((ss_clay (k) + ss_sand (k)) > 9999) then ! note: 9999 = 99.99% (scale factor = 0.01) + if(ss_clay (k) >= ss_sand (k)) then + ss_sand (k) = 10000 - ss_clay (k) + else + ss_clay (k) = 10000 - ss_sand (k) + endif + endif + !k = k + 1 !cleanup k counter + !ktop = ktop + 1 !cleanup k counter + +!obsolete20220502 else +!obsolete20220502 ss_clay (k) = ss_clay_all(j) +!obsolete20220502 ss_sand (k) = ss_sand_all(j) +!obsolete20220502 if((ss_clay (k) + ss_sand (k)) > 9999) then +!obsolete20220502 if(ss_clay (k) >= ss_sand (k)) then +!obsolete20220502 ss_sand (k) = 10000 - ss_clay (k) +!obsolete20220502 else +!obsolete20220502 ss_clay (k) = 10000 - ss_sand (k) +!obsolete20220502 endif +!obsolete20220502 endif +!obsolete20220502 !k = k + 1 !cleanup k counter +!obsolete20220502 endif + endif endif end do - k = k - 1 - ktop = ktop -1 - if(fac_count.ne.0) poc_vec (n) = poc_vec(n)/fac_count - ncells_top_pro(n) = 100.*float(ktop)/float(i) - ncells_sub_pro(n) = 100.*float(k-ktop)/float(i) - - if (write_file) write (80+n,*)ktop,k,o_cl - if (write_file) write (80+n,*)ss_clay(1:k) - if (write_file) write (80+n,*)ss_sand(1:k) + !k = k - 1 !cleanup k counter + !ktop = ktop -1 !cleanup k counter + + if(fac_count.ne.0) poc_vec (n) = poc_vec(n)/fac_count ! normalize profile-layer orgC + + !ncells_top_pro(n) = 100.*float(ktop)/float(i) ! ncells_* not used + !ncells_sub_pro(n) = 100.*float(k-ktop)/float(i) ! ncells_* not used + + ! debugging output + if (write_debug) write (80+n,*)ktop,k,o_cl + if (write_debug) write (80+n,*)ss_clay(1:k) + if (write_debug) write (80+n,*)ss_sand(1:k) + + ! Determine the raster grid cell and layer j that has clay/sand content closest + ! to the average (profile) clay/sand across all raster grid cells within the + ! dominant orgC class. + j = center_pix_int0 (sf, ktop,k, ss_clay(1:k),ss_sand(1:k)) - if (write_file) write(80+n,*) j + + ! Assign soil class of raster grid cell and layer j to tile n + if(j >=1) then min_percs%clay_perc = ss_clay(j)*sf min_percs%sand_perc = ss_sand(j)*sf min_percs%silt_perc = 100. - ss_clay(j)*sf - ss_sand(j)*sf soil_class_com (n) = table_map(soil_class (min_percs),o_clp) endif - if (write_file) write(80+n,*) soil_class_com (n) - if (write_file) close(80+n) + + ! debugging output + if (write_debug) write(80+n,*) j + if (write_debug) write(80+n,*) soil_class_com (n) + if (write_debug) close(80+n) + endif + deallocate (ss_clay,ss_sand,ss_clay_all,ss_sand_all,ss_oc_all) + END DO - END DO + END DO ! loop through tiles !$OMP ENDPARALLELDO ! call process_peatmap (nx, ny, gfiler, pmap) + ! ----------------------------------------------------------------------------- + ! + ! apply final touches and write output files: + ! - soil_param.first + ! - tau_param.dat + ! - catch_params.nc4 [soil hydraulic and srfexc-rzexc time scale parameters ONLY; + ! parameters from ar.new, bf.dat, and ts.dat parameters will be + ! added to catch_params.nc4 by subroutine create_model_para_woesten()] + inquire(file='clsm/catch_params.nc4', exist=CatchParamsNC_file_exists) if(CatchParamsNC_file_exists) then status = NF_OPEN ('clsm/catch_params.nc4', NF_WRITE, ncid) ; VERIFY_(STATUS) allocate (parms4file (1:maxcat, 1:10)) endif - - fname='clsm/catchment.def' - open (10,file=fname,status='old',action='read',form='formatted') - read(10,*) maxcat + fname ='clsm/soil_param.first' open (11,file=trim(fname),form='formatted',status='unknown',action = 'write') fname ='clsm/tau_param.dat' open (12,file=trim(fname),form='formatted',status='unknown',action = 'write') - fname ='clsm/mosaic_veg_typs_fracs' - open (13,file=trim(fname),form='formatted',status='old',action = 'read') + ! open catchment.def for reading tile index and Pfafstetter index + + fname='clsm/catchment.def' + open (10,file=fname,status='old',action='read',form='formatted') + read(10,*) maxcat ! re-read header line + +!obsolete20220502 fname ='clsm/mosaic_veg_typs_fracs' +!obsolete20220502 open (13,file=trim(fname),form='formatted',status='old',action = 'read') do n = 1, maxcat - read (10,*) tindex,pfafindex - read (13,*) tindex,pfafindex,vtype +!obsolete20220502 read (13,*) tindex,pfafindex,vtype + + ! fill gaps from neighbor for rare missing values caused by inconsistent masks - ! fill gaps from neighbor for rare missing values came from inconsistent masks if ((soil_class_top (n) == -9999).or.(soil_class_com (n) == -9999)) then - ! if com-layer has data the issues is only with top-layer - ! ------------------------------------------------------- + ! if com-layer has data, the issue is only with top-layer if(soil_class_com (n) >= 1) soil_class_top (n) = soil_class_com (n) - ! if there is nothing look for the neighbor - ! ----------------------------------------- - + ! if there is nothing, look for the neighbor + ! + ! ^ + ! | + ! | The comment above seems wrong; could have soil_class_top(n)>=1, unless + ! earlier soil_class_com was set equal to soil_class_top whenever + ! soil_class_top was available and soil_class_com was not. + if (soil_class_com (n) == -9999) then + + ! Look for neighbor j (regardless of soil_class_top) and set both + ! soil_class_com(n) and soil_class_top(n) equal to the neighbor's + ! soil_class_com(j). + do k = 1, maxcat j = 0 i1 = n - k i2 = n + k - if((i1 >= 1).and.(soil_class_com (i1) >=1)) j = i1 - if((i2 <=maxcat).and.(soil_class_com (i2) >=1)) j = i2 + if((i1 >= 1).and.(soil_class_com (i1) >=1)) j = i1 ! tentatively use "lower" neighbor unless out of range + if((i2 <=maxcat).and.(soil_class_com (i2) >=1)) j = i2 ! "upper" neighbor prevails unless out of range if (j > 0) then soil_class_com (n) = soil_class_com (j) - soil_class_top (n) = soil_class_com (n) + !soil_class_top (n) = soil_class_com (n) + soil_class_top (n) = soil_class_com (j) ! should be faster/safer than usin gsoil_class_com(n) grav_vec(n) = grav_vec(j) soc_vec(n) = soc_vec (j) poc_vec(n) = poc_vec (j) @@ -4665,28 +4216,40 @@ SUBROUTINE soil_para_hwsd (nx,ny,gfiler) fac = soil_class_com(n) if(use_PEATMAP) then - ! the maximum peat soil depth is set to the value Michel used to derive parameters (1334.) + ! the maximum peat soil depth is set to the value Michel used to derive parameters (5000.) if (fac_surf == 253) soildepth(n) = 5000. ! max(soildepth(n),5000.) - ! reseet subsurface tro peat if surface soil type is peat + ! reset subsurface to peat if surface soil type is peat if (fac_surf == 253) fac = 253 endif wp_wetness = a_wp(fac) /a_poros(fac) + + this_cond = a_aksat(fac)/exp(-1.0*zks*gnu) + + ! read tile index and Pfafstetter index from catchment.def + + read (10,*) tindex,pfafindex + + ! write soil_param.first write (11,'(i10,i8,i4,i4,3f8.4,f12.8,f7.4,f10.4,3f7.3,4f7.3,2f10.4, f8.4)')tindex,pfafindex, & fac_surf, fac, a_bee(fac),a_psis(fac),a_poros(fac),& - a_aksat(fac)/exp(-1.0*zks*gnu),wp_wetness,soildepth(n), & + this_cond,wp_wetness,soildepth(n), & grav_vec(n),soc_vec(n),poc_vec(n), & a_sand(fac_surf),a_clay(fac_surf),a_sand(fac),a_clay(fac), & a_wpsurf(fac_surf)/a_porosurf(fac_surf),a_porosurf(fac_surf), pmap(n) + + ! write tau_param.dat write (12,'(i10,i8,4f10.7)')tindex,pfafindex, & atau_2cm(fac_surf),btau_2cm(fac_surf),atau(fac_surf),btau(fac_surf) + ! write catch_params.nc [soil hydraulic and srfexc-rzexc time scale parameters] + if (allocated (parms4file)) then parms4file (n, 1) = a_bee(fac) - parms4file (n, 2) = a_aksat(fac)/exp(-1.0*zks*gnu) + parms4file (n, 2) = this_cond ! a_aksat(fac)/exp(-1.0*zks*gnu) parms4file (n, 3) = a_poros(fac) parms4file (n, 4) = a_psis(fac) parms4file (n, 5) = wp_wetness @@ -4698,21 +4261,29 @@ SUBROUTINE soil_para_hwsd (nx,ny,gfiler) endif end do + + ! add "header" line to the bottom of soil_param.first + write (11,'(a)')' ' write (11,'(a)')'FMT=i10,i8,i4,i4,3f8.4,f12.8,f7.4,f10.4,3f7.3,4f7.3,2f10.4,f8.4' write (11,'(a)')'TileIndex PfafID SoilClassTop SoilClassProfile BEE PSIS POROS Ks_at_SURF WPWET SoilDepth %Grav %OCTop %OCProf %Sand_top %Clay_top %Sand_prof %Clay_prof WPWET_SURF POROS_SURF PMAP' + close (10, status = 'keep') close (11, status = 'keep') close (12, status = 'keep') - close (13, status = 'keep') + +!obsolete20220502 close (13, status = 'keep') deallocate (data_vec1, data_vec2,data_vec3, data_vec4,data_vec5, data_vec6) deallocate (tileid_vec) deallocate (a_sand,a_clay,a_silt,a_oc,a_bee,a_psis, & a_poros,a_wp,a_aksat,atau,btau,a_wpsurf,a_porosurf, & atau_2cm,btau_2cm) - deallocate (soildepth, grav_vec,soc_vec,poc_vec,& - ncells_top,ncells_top_pro,ncells_sub_pro,soil_class_top,soil_class_com) + deallocate (soildepth, grav_vec,soc_vec,poc_vec,soil_class_top,soil_class_com) + !ncells_top,ncells_top_pro,ncells_sub_pro,soil_class_top,soil_class_com) ! ncells_* not used + + ! write catch_params.nc4 [soil hydraulic and srfexc-rzexc time scale parameters] + if(CatchParamsNC_file_exists) then status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'BEE' ) ,(/1/),(/maxcat/), parms4file (:, 1)) ; VERIFY_(STATUS) status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'COND' ) ,(/1/),(/maxcat/), parms4file (:, 2)) ; VERIFY_(STATUS) @@ -4732,95 +4303,113 @@ END SUBROUTINE soil_para_hwsd ! -------------------------------------------------------------------------------------------------------- - INTEGER FUNCTION center_pix_int (sf,ktop, ktot, x,y,x0,y0,z0,ext_point) - - implicit none - - integer (kind =2), dimension (:), intent (in) :: x,y - integer, intent (in) :: ktop,ktot - real, intent (in) :: sf - real :: xi,xj,yi,yj,xx0,yy0,zz0 - real, allocatable, dimension (:,:) :: length_m - real, allocatable, dimension (:) :: length - real, intent (inout) :: x0,y0,z0 - integer :: i,j,npix - logical, intent(in) :: ext_point - real :: zi, zj - - allocate (length_m (1:ktot,1:ktot)) - allocate (length (1:ktot)) - length_m =0. - length =0. - - center_pix_int = -9999 - if(ktot /= 0) then - do i = 1,ktot - xi = sf*x(i) - yi = sf*y(i) - zi = 100. - xi - yi - if (.not. ext_point) then - x0 = xi - y0 = yi - z0 = zi - endif - - do j = 1,ktot - xj = sf*x(j) - yj = sf*y(j) - zj = 100. - xj - yj - xx0= xj - x0 - yy0= yj - y0 - zz0= zj - z0 - - if(ktot > ktop) then - if(j <= ktop) then - length_m (i,j) = (xx0*xx0 + yy0*yy0 + zz0*zz0)**0.5 - else - length_m (i,j) = 2.33*((xx0*xx0 + yy0*yy0 + zz0*zz0)**0.5) - endif - else - length_m (i,j) = (xx0*xx0 + yy0*yy0 + zz0*zz0)**0.5 - endif - end do - length (i) = sum(length_m (i,:)) - end do - - center_pix_int = minloc(length,dim=1) - endif - - END FUNCTION center_pix_int - - ! +!obsolete20220502 INTEGER FUNCTION center_pix_int (sf,ktop, ktot, x,y,x0,y0,z0,ext_point) +!obsolete20220502 +!obsolete20220502 implicit none +!obsolete20220502 +!obsolete20220502 integer (kind =2), dimension (:), intent (in) :: x,y +!obsolete20220502 integer, intent (in) :: ktop,ktot +!obsolete20220502 real, intent (in) :: sf +!obsolete20220502 real :: xi,xj,yi,yj,xx0,yy0,zz0 +!obsolete20220502 real, allocatable, dimension (:,:) :: length_m +!obsolete20220502 real, allocatable, dimension (:) :: length +!obsolete20220502 real, intent (inout) :: x0,y0,z0 +!obsolete20220502 integer :: i,j,npix +!obsolete20220502 logical, intent(in) :: ext_point +!obsolete20220502 real :: zi, zj +!obsolete20220502 +!obsolete20220502 allocate (length_m (1:ktot,1:ktot)) +!obsolete20220502 allocate (length (1:ktot)) +!obsolete20220502 length_m =0. +!obsolete20220502 length =0. +!obsolete20220502 +!obsolete20220502 center_pix_int = -9999 +!obsolete20220502 if(ktot /= 0) then +!obsolete20220502 do i = 1,ktot +!obsolete20220502 xi = sf*x(i) +!obsolete20220502 yi = sf*y(i) +!obsolete20220502 zi = 100. - xi - yi +!obsolete20220502 if (.not. ext_point) then +!obsolete20220502 x0 = xi +!obsolete20220502 y0 = yi +!obsolete20220502 z0 = zi +!obsolete20220502 endif +!obsolete20220502 +!obsolete20220502 do j = 1,ktot +!obsolete20220502 xj = sf*x(j) +!obsolete20220502 yj = sf*y(j) +!obsolete20220502 zj = 100. - xj - yj +!obsolete20220502 xx0= xj - x0 +!obsolete20220502 yy0= yj - y0 +!obsolete20220502 zz0= zj - z0 +!obsolete20220502 +!obsolete20220502 if(ktot > ktop) then +!obsolete20220502 if(j <= ktop) then +!obsolete20220502 length_m (i,j) = (xx0*xx0 + yy0*yy0 + zz0*zz0)**0.5 +!obsolete20220502 else +!obsolete20220502 length_m (i,j) = 2.33*((xx0*xx0 + yy0*yy0 + zz0*zz0)**0.5) +!obsolete20220502 endif +!obsolete20220502 else +!obsolete20220502 length_m (i,j) = (xx0*xx0 + yy0*yy0 + zz0*zz0)**0.5 +!obsolete20220502 endif +!obsolete20220502 end do +!obsolete20220502 length (i) = sum(length_m (i,:)) +!obsolete20220502 end do +!obsolete20220502 +!obsolete20220502 center_pix_int = minloc(length,dim=1) +!obsolete20220502 endif +!obsolete20220502 +!obsolete20220502 END FUNCTION center_pix_int +!obsolete20220502 +!obsolete20220502 ! +!obsolete20220502 + ! ==================================================================== ! INTEGER FUNCTION center_pix_int0 (sf,ktop, ktot, x,y) implicit none - ! sf = 0.01 (integer to real scale factor), ktop = # of pixels in top layer + + ! In a nutshell, given a list of clay/sand pairs, this function determines + ! the element (pair) in this list that is closest to the average clay/sand + ! across all pairs. + ! + ! The input list of clay/sand can consist of only top (0-30) layer clay/sand + ! pairs, or of pairs of clay/sand pairs for the top (0-30) and sub (30-70) + ! layers. In the latter case, a weighted average is computed. + ! + ! This is to ensure that ultimately the clay/sand values assigned to a tile + ! represent an actual soil class. + ! + ! sf = 0.01 (integer to real scale factor) + ! ktop = # of pixels in top layer ! ktot = total # of pixels, top + subsurface combined - ! x (clay), y (sand_ + ! x (clay), y (sand) integer (kind =2), dimension (:), intent (in) :: x,y - integer, intent (in) :: ktop,ktot - real, intent (in) :: sf + integer, intent (in) :: ktop,ktot + real, intent (in) :: sf + real :: xi,xj,yi,yj real :: length integer :: i,j,npix real :: zi, zj, mindist,xc,yc,zc - length =0. + length = 0. center_pix_int0 = -9999 + ! compute average clay/sand + if(ktot /= 0) then ! There should be some data pixels if(ktot > ktop) then ! Have both layers if(ktop > 0) then ! There are data in top layer - xc = sf*0.3*sum(real(x(1:ktop)))/real(ktop) + sf*0.7*sum(real(x(ktop + 1 : ktot)))/real(ktot - ktop) - yc = sf*0.3*sum(real(y(1:ktop)))/real(ktop) + sf*0.7*sum(real(y(ktop + 1 : ktot)))/real(ktot - ktop) + xc = sf*0.3*sum(real(x(1:ktop)))/real(ktop) + sf*0.7*sum(real(x(ktop+1 : ktot)))/real(ktot - ktop) + yc = sf*0.3*sum(real(y(1:ktop)))/real(ktop) + sf*0.7*sum(real(y(ktop+1 : ktot)))/real(ktot - ktop) else ! There are no data in top layer xc = sf*sum(real(x(1:ktot)))/real(ktot) @@ -4831,7 +4420,7 @@ INTEGER FUNCTION center_pix_int0 (sf,ktop, ktot, x,y) xc = sf*sum(real(x(1:ktot)))/real(ktot) yc = sf*sum(real(y(1:ktot)))/real(ktot) endif - zc = 100. - xc - yc + zc = 100. - xc - yc ! silt [percent] endif mindist=100000.*100000. @@ -6257,11 +5846,12 @@ END SUBROUTINE gimms_clim_ndvi ! -------------------------------------------------------------------------- - SUBROUTINE open_landparam_nc4_files + SUBROUTINE open_landparam_nc4_files(N_tile) implicit none integer :: NCCatOUTID, NCCatCNOUTID, NCVegOUTID integer :: STATUS, CellID1, CellID2, CellID3, SubID + integer, intent (in) :: N_tile integer, dimension(8) :: date_time_values character (22) :: time_stamp character (100) :: MYNAME @@ -6270,9 +5860,9 @@ SUBROUTINE open_landparam_nc4_files status = NF_CREATE ('clsm/catchcn_params.nc4', NF_NETCDF4, NCCatCNOUTID) ; VERIFY_(STATUS) status = NF_CREATE ('clsm/vegdyn.data' , NF_NETCDF4, NCVegOUTID ) ; VERIFY_(STATUS) - status = NF_DEF_DIM(NCCatOUTID , 'tile' , NF_UNLIMITED, CellID1) - status = NF_DEF_DIM(NCCatCNOUTID, 'tile' , NF_UNLIMITED, CellID2) - status = NF_DEF_DIM(NCVegOUTID , 'tile' , NF_UNLIMITED, CellID3) + status = NF_DEF_DIM(NCCatOUTID , 'tile' , N_tile, CellID1) + status = NF_DEF_DIM(NCCatCNOUTID, 'tile' , N_tile, CellID2) + status = NF_DEF_DIM(NCVegOUTID , 'tile' , N_tile, CellID3) status = NF_DEF_DIM(NCCatCNOUTID, 'unknown_dim2' , 4, SubID) call DEF_VAR ( NCCatOUTID, CellID1,'OLD_ITY' ,'vegetation_type.' , '1' ) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/rmTinyCatchParaMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/rmTinyCatchParaMod.F90 index 300ba87e2..fd381b50c 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/rmTinyCatchParaMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/rmTinyCatchParaMod.F90 @@ -37,7 +37,7 @@ module rmTinyCatchParaMod public create_soil_types_files,compute_mosaic_veg_types public cti_stat_file, create_model_para_woesten public create_model_para, modis_lai,regridraster,regridrasterreal - public i_raster, j_raster,regridraster1,regridraster2,n_SoilClasses,gnu,zks + public i_raster, j_raster,regridraster1,regridraster2,n_SoilClasses,zks public mineral_perc, process_gswp2_veg,center_pix, soil_class public tgen, sat_param,REFORMAT_VEGFILES,base_param,ts_param public :: Get_MidTime, Time_Interp_Fac, compute_stats, c_data @@ -48,7 +48,7 @@ module rmTinyCatchParaMod character*8, public, save :: LAIBCS = 'MODGEO' character*4, public, save :: SOILBCS = 'HWSD' character*6, public, save :: MODALB = 'MODIS2' - REAL, save :: GNU = 1.0 + REAL, public, save :: GNU = 1.0 type :: mineral_perc real :: clay_perc @@ -62,7 +62,8 @@ SUBROUTINE init_bcs_config (LBSV) implicit none - character(*), intent (in) :: LBSV + character(*), intent (in) :: LBSV ! LBSV = land BCs version (?) + ! LAIBCS: Choice of LAI data set. DEFAULT : MODGEO ! GLASSA : 8-day AVHRR climatology from the period 1981-2017 on 7200x3600 grid ! GLASSM : 8-day MODIS climatology from the period 2000-2017 on 7200x3600 grid @@ -3503,10 +3504,11 @@ SUBROUTINE create_model_para_woesten (Maskfile) atile_sand,atile_clay, tile_lon, tile_lat, grav_vec, soc_vec,& poc_vec,a_sand_surf,a_clay_surf,wpwet_surf,poros_surf, pmap - real, allocatable, dimension (:,:) :: good_clay, good_sand - integer, allocatable, dimension (:,:) :: tile_add, tile_pick - type (mineral_perc) :: min_percs - integer :: CF1, CF2, CF3, CF4 +!obsolete20220428 real, allocatable, dimension (:,:) :: good_clay, good_sand +!obsolete20220428 integer, allocatable, dimension (:,:) :: tile_add, tile_pick +!obsolete20220428 type (mineral_perc) :: min_percs +!obsolete20220428 integer :: CF1, CF2, CF3, CF4 + integer i,j,n,k, tindex1,pfaf1,nbcatch integer soil_gswp real meanlu,stdev,minlu,maxlu,coesk,rzdep @@ -3584,6 +3586,16 @@ SUBROUTINE create_model_para_woesten (Maskfile) !c------------------------------------------------------------------------- + ! SoilClasses-SoilHyd-TauParam.dat and SoilClasses-SoilHyd-TauParam.peatmap differ + ! only in the parameters for the peat class #253. The file *.peatmap contains + ! the PEATCLSM parameters from Table 2 of Bechtold et al. 2019 (doi:10.1029/2018MS001574). + ! + ! Note: K_s = COND*exp(-zks*gnu) ==> with zks=2 and gnu=1, K_s = 0.135335*COND + ! + ! K_s COND [m/s] + ! NLv4 7.86e-7 5.81e-6 + ! NLv5 3.79e-6 2.80e-5 <== note *typo* in Table 2 of Bechtold et al. 2019, which erroneously lists K_s=2.8e-5 + if(use_PEATMAP) then fname = trim(c_data)//'SoilClasses-SoilHyd-TauParam.peatmap' else @@ -3591,7 +3603,8 @@ SUBROUTINE create_model_para_woesten (Maskfile) endif open (11, file=trim(fname), form='formatted',status='old', & action = 'read') - read (11,'(a)')fout + read (11,'(a)')fout ! read header line + losfile =trim(c_data)//'/Woesten_SoilParam/loss_pd_top/loss_perday_rz1m_' allocate (a_sand (1:n_SoilClasses)) @@ -3604,17 +3617,17 @@ SUBROUTINE create_model_para_woesten (Maskfile) allocate (gfrc (1:nwt,1:nrz,1:n_SoilClasses)) do n =1,n_SoilClasses + + ! read sand/clay/orgC for class n defined in SoilClasses-SoilHyd-TauParam.* + read (11,'(4f7.3)')a_sand(n),a_clay(n),a_silt(n),a_oc(n) write (fout,'(i2.2,i2.2,i4.4)')nint(a_sand(n)),nint(a_clay(n)),nint(100*a_oc(n)) - if(n == n_SoilClasses) then - if(use_PEATMAP) then - open (120,file=trim(losfile)//trim(fout)//'.peat', & - form='formatted',status='old') - else - open (120,file=trim(losfile)//trim(fout), & + ! open and read loss parameter file for class n (defined through sand/clay/orgC) + + if(n == n_SoilClasses .and. use_PEATMAP) then + open (120,file=trim(losfile)//trim(fout)//'.peat', & form='formatted',status='old') - endif else open (120,file=trim(losfile)//trim(fout), & form='formatted',status='old') @@ -3635,6 +3648,8 @@ SUBROUTINE create_model_para_woesten (Maskfile) close (11,status='keep') deallocate (a_sand,a_silt,a_clay,a_oc) + ! open files for *reading* + fname='clsm/soil_param.first' open (10,file=fname,action='read', & form='formatted',status='old') @@ -3647,6 +3662,8 @@ SUBROUTINE create_model_para_woesten (Maskfile) open (12,file=fname,action='read', & form='formatted',status='old') + ! open files for *writing* + fout='clsm/ar.new' open (20,file=fout,action='write', & form='formatted',status='unknown') @@ -3678,8 +3695,8 @@ SUBROUTINE create_model_para_woesten (Maskfile) open (42,file=fout,action='write', & form='formatted',status='unknown') - read (11,*)nbcatch - read (12,*)nbcatch + read (11,*)nbcatch ! read header line (number of tiles) -- cti_stats.dat + read (12,*)nbcatch ! read header line (number of tiles) -- catchment.def allocate (tile_lon(1:nbcatch)) allocate (tile_lat(1:nbcatch)) @@ -3732,19 +3749,30 @@ SUBROUTINE create_model_para_woesten (Maskfile) allocate (wpwet_surf (1:nbcatch)) allocate (poros_surf (1:nbcatch)) allocate (pmap (1:nbcatch)) - allocate (good_clay (1:100,4)) - allocate (good_sand (1:100,4)) - allocate (tile_add (1:100,4)) - allocate (tile_pick (1:100,4)) - tile_add = 0 - tile_pick= 0 - good_clay =0. - good_sand =0. + +!obsolete20220428 allocate (good_clay (1:100,4)) +!obsolete20220428 allocate (good_sand (1:100,4)) +!obsolete20220428 allocate (tile_add (1:100,4)) +!obsolete20220428 allocate (tile_pick (1:100,4)) +!obsolete20220428 tile_add = 0 +!obsolete20220428 tile_pick= 0 +!obsolete20220428 good_clay =0. +!obsolete20220428 good_sand =0. do n=1,nbcatch + + ! read cti_stats.dat + read(11,'(i10,i8,5(1x,f8.4))') tindex1,pfaf1,meanlu,stdev & ,minlu,maxlu,coesk + ! read soil_param.first + ! + ! WARNING: Immediately after the present do loop, BEE, COND, POROS, PSIS, WPWET, and + ! soildepth will be read again (and thus overwritten) with the values from + ! the catch_params.nc4 file. It is unclear if the values in soil_param.first + ! and catch_params.nc4 differ. See comments below. + read(10,'(i10,i8,i4,i4,3f8.4,f12.8,f7.4,f10.4,3f7.3,4f7.3,2f10.4)') & tindex2(n),pfaf2(n),soil_class_top(n),soil_class_com(n), & BEE(n), PSIS(n),POROS(n),COND(n),WPWET(n),soildepth(n), & @@ -3755,6 +3783,8 @@ SUBROUTINE create_model_para_woesten (Maskfile) stop endif + ! read catchment.def + read (12,*) tindex1,pfaf1,minlon,maxlon,minlat,maxlat tile_lon(n) = (minlon + maxlon)/2. tile_lat(n) = (minlat + maxlat)/2. @@ -3787,11 +3817,26 @@ SUBROUTINE create_model_para_woesten (Maskfile) minlu,maxlu stop endif - END DO + END DO ! n=1,nbcatch inquire(file='clsm/catch_params.nc4', exist=file_exists) if(file_exists) then + + ! Read BEE, COND, POROS, PSIS, WPWET, and soildepth from nc4 file. + ! It is unclear if parameters in nc4 file differ from those in soil_param.first, which were read + ! in the do loop just above. + ! Probably, the parameters differ by roundoff because soil_param.first is an ASCII file and + ! catch_params.nc4 is a netcdf file. Consequently, the parameters from the nc4 file are used + ! in the calculation of the ar.new, bf.dat, and ts.dat parameters, which comes next. + ! To maintain consistency between the parameters in soil_param.first and soil_param.dat where + ! no changes are needed, soil_param.first needs to be read again below (so as to overwrite + ! the values from the nc4 file). + ! Why the parameters from the nc4 file are read here in the first place remains a mystery. + ! Removing this read, however, will (almost certainly) result in non-zero-diff changes + ! for existing bcs datasets. + ! - reichle, 28 April 2022 + status = NF_OPEN ('clsm/catch_params.nc4', NF_WRITE, ncid) ; VERIFY_(STATUS) allocate (parms4file (1:nbcatch, 1:25)) status = NF_GET_VARA_REAL(NCID,NC_VarID(NCID,'BEE' ) ,(/1/),(/nbcatch/), BEE (:)) ; VERIFY_(STATUS) @@ -3808,7 +3853,7 @@ SUBROUTINE create_model_para_woesten (Maskfile) parms4file (:,25) = soildepth(:) endif - rewind(10) + rewind(10) ! soil_param.first (so soil_param.first can be read again below...) allocate(low_ind(n_threads)) allocate(upp_ind(n_threads)) @@ -3849,8 +3894,8 @@ SUBROUTINE create_model_para_woesten (Maskfile) TOPMEAN(n),TOPVAR(n),TOPSKEW(n), & ST,AC,COESKEW) -!c Areal fractioning parameters - + ! compute areal fractioning parameters (ar.new) + CALL SAT_PARAM( & BEE(n),PSIS(n),POROS(n),COND(n), & WPWET(n), ST, AC, COESKEW,n, & @@ -3861,6 +3906,8 @@ SUBROUTINE create_model_para_woesten (Maskfile) taberr1(n),taberr2(n),taberr3(n),taberr4(n), & normerr1(n),normerr2(n),normerr3(n),normerr4(n)) + ! compute base flow parameters (bf.dat) + CALL BASE_PARAM( & BEE(n),PSIS(n),POROS(n),COND(n), & ST, AC, & @@ -3874,6 +3921,8 @@ SUBROUTINE create_model_para_woesten (Maskfile) rzexcn (:,:) = grzexcn (:,:,soil_class_com(n)) frc (:,:) = gfrc (:,:,soil_class_com(n)) + ! compute time scale parameters (rzexc-catdef) (ts.dat) + CALL TS_PARAM( & BEE(n),PSIS(n),POROS(n), & ST, AC, & @@ -3881,10 +3930,9 @@ SUBROUTINE create_model_para_woesten (Maskfile) tsa1(n),tsa2(n),tsb1(n),tsb2(n) & ) - if(soil_class_com(n) == 253) then + if(soil_class_com(n) == 253 .and. use_PEATMAP) then ! Michel Bechtold paper - PEATCLSM_fitting_CLSM_params.R produced these data values. - if(use_PEATMAP) then ars1(n) = -7.9514018e-03 ars2(n) = 6.2297356e-02 @@ -3907,182 +3955,350 @@ SUBROUTINE create_model_para_woesten (Maskfile) tsb1(n) = -3.700285e-03 tsb2(n) = -2.392484e-03 - endif endif END DO END DO !$OMP ENDPARALLELDO - CF1 =0 - CF2 =0 - CF3 =0 - CF4 =0 - - DO n=1,nbcatch - - if((ars1(n).ne.9999.).and.(arw1(n).ne.9999.))then - - if ((soil_class_com(n)>=1).and.(soil_class_com(n)<=84)) then - group=1 - else if ((soil_class_com(n) > 84).and.(soil_class_com(n)<=168)) then - group=2 - else if ((soil_class_com(n) >168).and.(soil_class_com(n)< N_SoilClasses)) then - group=3 - else - group=4 - endif - - min_percs%clay_perc = atile_clay(n) - min_percs%sand_perc = atile_sand(n) - min_percs%silt_perc = 100. - min_percs%clay_perc - min_percs%sand_perc - - if(tile_pick(soil_class (min_percs),group) == 0) then - tile_pick(soil_class (min_percs),group) = n - - select case (group) - - case (1) - - CF1 = CF1 + 1 - good_clay (CF1,group) = atile_clay(n) - good_sand (CF1,group) = atile_sand(n) - tile_add (CF1,group) = n - - case (2) - CF2 = CF2 + 1 - good_clay (CF2,group) = atile_clay(n) - good_sand (CF2,group) = atile_sand(n) - tile_add (CF2,group) = n - - case (3) - CF3 = CF3 + 1 - good_clay (CF3,group) = atile_clay(n) - good_sand (CF3,group) = atile_sand(n) - tile_add (CF3,group) = n - - case (4) - CF4 = CF4 + 1 - good_clay (CF4,group) = atile_clay(n) - good_sand (CF4,group) = atile_sand(n) - tile_add (CF4,group) = n - - end select - endif - endif - END DO - +! This code block is obsolete because it was only needed if preserve_soiltype==.true, but +! preserve_soiltype was hardwired to .false. above. +! -reichle, 28 April 2022 +! +!obsolete20220428 CF1 =0 +!obsolete20220428 CF2 =0 +!obsolete20220428 CF3 =0 +!obsolete20220428 CF4 =0 +!obsolete20220428 +!obsolete20220428 DO n=1,nbcatch +!obsolete20220428 +!obsolete20220428 if((ars1(n).ne.9999.).and.(arw1(n).ne.9999.))then +!obsolete20220428 +!obsolete20220428 ! determine organic carbon class ("group") from soil class +!obsolete20220428 +!obsolete20220428 if ((soil_class_com(n)>=1).and.(soil_class_com(n)<=84)) then +!obsolete20220428 group=1 +!obsolete20220428 else if ((soil_class_com(n) > 84).and.(soil_class_com(n)<=168)) then +!obsolete20220428 group=2 +!obsolete20220428 else if ((soil_class_com(n) >168).and.(soil_class_com(n)< N_SoilClasses)) then +!obsolete20220428 group=3 +!obsolete20220428 else +!obsolete20220428 group=4 ! peat +!obsolete20220428 endif +!obsolete20220428 +!obsolete20220428 ! assemble scalar structure that holds mineral percentages of tile n +!obsolete20220428 +!obsolete20220428 min_percs%clay_perc = atile_clay(n) +!obsolete20220428 min_percs%sand_perc = atile_sand(n) +!obsolete20220428 min_percs%silt_perc = 100. - min_percs%clay_perc - min_percs%sand_perc +!obsolete20220428 +!obsolete20220428 ! "soil_class" is an integer function (defined below) that assigns +!obsolete20220428 ! an integer soil class [1-100] for a given mineral percentage triplet +!obsolete20220428 +!obsolete20220428 ! "tile_pick" contains the number (ID) n of a sample tile for each +!obsolete20220428 ! soil class +!obsolete20220428 +!obsolete20220428 if(tile_pick(soil_class (min_percs),group) == 0) then +!obsolete20220428 +!obsolete20220428 ! assign tile n as the sample tile for its soil class in "tile_pick" +!obsolete20220428 +!obsolete20220428 tile_pick(soil_class (min_percs),group) = n +!obsolete20220428 +!obsolete20220428 ! Assign sand/clay from tile n to "good_clay" and "good_sand" for its class???? +!obsolete20220428 ! Why is "good_sand" dimension (100,4) when CF[x] seems to count the +!obsolete20220428 ! number of tiles within each organic carbon subclass ("group")?? +!obsolete20220428 +!obsolete20220428 select case (group) +!obsolete20220428 +!obsolete20220428 case (1) +!obsolete20220428 +!obsolete20220428 CF1 = CF1 + 1 +!obsolete20220428 good_clay (CF1,group) = atile_clay(n) +!obsolete20220428 good_sand (CF1,group) = atile_sand(n) +!obsolete20220428 tile_add (CF1,group) = n +!obsolete20220428 +!obsolete20220428 case (2) +!obsolete20220428 CF2 = CF2 + 1 +!obsolete20220428 good_clay (CF2,group) = atile_clay(n) +!obsolete20220428 good_sand (CF2,group) = atile_sand(n) +!obsolete20220428 tile_add (CF2,group) = n +!obsolete20220428 +!obsolete20220428 case (3) +!obsolete20220428 CF3 = CF3 + 1 +!obsolete20220428 good_clay (CF3,group) = atile_clay(n) +!obsolete20220428 good_sand (CF3,group) = atile_sand(n) +!obsolete20220428 tile_add (CF3,group) = n +!obsolete20220428 +!obsolete20220428 case (4) +!obsolete20220428 CF4 = CF4 + 1 +!obsolete20220428 good_clay (CF4,group) = atile_clay(n) +!obsolete20220428 good_sand (CF4,group) = atile_sand(n) +!obsolete20220428 tile_add (CF4,group) = n +!obsolete20220428 +!obsolete20220428 end select +!obsolete20220428 endif +!obsolete20220428 +!obsolete20220428 endif ! (ars1(n).ne.9999.).and.(arw1(n).ne.9999.) +!obsolete20220428 +!obsolete20220428 END DO ! n=1,nbcatch + + ! ---------------------------------------------------------------------------------------- + ! + ! write ar.new, bf.dat, ts.dat, and soil_param.dat + DO n=1,nbcatch - read(10,'(i10,i8,i4,i4,3f8.4,f12.8,f7.4,f10.4,3f7.3,4f7.3,2f10.4, f8.4)') & + + ! Read soil_param.first again...; this is (almost certainly) needed to maintain consistency + ! between soil_param.first and soil_param.dat, see comments above. + + read(10,'(i10,i8,i4,i4,3f8.4,f12.8,f7.4,f10.4,3f7.3,4f7.3,2f10.4, f8.4)') & tindex2(n),pfaf2(n),soil_class_top(n),soil_class_com(n), & BEE(n), PSIS(n),POROS(n),COND(n),WPWET(n),soildepth(n), & grav_vec(n),soc_vec(n),poc_vec(n), & a_sand_surf(n),a_clay_surf(n),atile_sand(n),atile_clay(n) , & wpwet_surf(n),poros_surf(n), pmap(n) - if((ars1(n).ne.9999.).and.(arw1(n).ne.9999.))then - write(20,'(i10,i8,f5.2,11(2x,e14.7))') & - tindex2(n),pfaf2(n),gnu, & - ars1(n),ars2(n),ars3(n), & - ara1(n),ara2(n),ara3(n),ara4(n), & - arw1(n),arw2(n),arw3(n),arw4(n) - - write(30,'(i10,i8,f5.2,3(2x,e13.7))')tindex2(n),pfaf2(n),gnu,bf1(n),bf2(n),bf3(n) - write(40,'(i10,i8,f5.2,4(2x,e13.7))')tindex2(n),pfaf2(n),gnu, & - tsa1(n),tsa2(n),tsb1(n),tsb2(n) - - write(42,'(i10,i8,i4,i4,3f8.4,f12.8,f7.4,f10.4,3f7.3,4f7.3,2f10.4, f8.4)') & - tindex2(n),pfaf2(n),soil_class_top(n),soil_class_com(n), & - BEE(n), PSIS(n),POROS(n),COND(n),WPWET(n),soildepth(n), & - grav_vec(n),soc_vec(n),poc_vec(n), & - a_sand_surf(n),a_clay_surf(n),atile_sand(n),atile_clay(n), & - wpwet_surf(n),poros_surf(n), pmap(n) - if (allocated (parms4file)) then - parms4file (n, 1) = ara1(n) - parms4file (n, 2) = ara2(n) - parms4file (n, 3) = ara3(n) - parms4file (n, 4) = ara4(n) - parms4file (n, 5) = ars1(n) - parms4file (n, 6) = ars2(n) - parms4file (n, 7) = ars3(n) - parms4file (n, 8) = arw1(n) - parms4file (n, 9) = arw2(n) - parms4file (n,10) = arw3(n) - parms4file (n,11) = arw4(n) - parms4file (n,13) = bf1(n) - parms4file (n,14) = bf2(n) - parms4file (n,15) = bf3(n) - parms4file (n,17) = gnu - parms4file (n,20) = tsa1(n) - parms4file (n,21) = tsa2(n) - parms4file (n,22) = tsb1(n) - parms4file (n,23) = tsb2(n) - endif - else - if(preserve_soiltype) then - if ((soil_class_com(n)>=1).and.(soil_class_com(n)<=84)) then - group=1 - else if ((soil_class_com(n)> 84).and.(soil_class_com(n)<=168)) then - group=2 - else if ((soil_class_com(n)> 168).and.(soil_class_com(n)< N_SoilClasses)) then - group=3 - else - group=4 - endif - - min_percs%clay_perc = atile_clay(n) - min_percs%sand_perc = atile_sand(n) - min_percs%silt_perc = 100. - min_percs%clay_perc - min_percs%sand_perc - if(tile_pick(soil_class (min_percs),group) > 0) then - k = tile_pick(soil_class (min_percs),group) - - else - select case (group) - - case (1) - j = center_pix (good_clay(1:CF1,group),good_sand(1:CF1,group), & - min_percs%clay_perc,min_percs%sand_perc,min_percs%silt_perc,.true.) - k = tile_add (j,group) - case (2) - j = center_pix (good_clay(1:CF2,group),good_sand(1:CF2,group), & - min_percs%clay_perc,min_percs%sand_perc,min_percs%silt_perc,.true.) - k = tile_add (j,group) - case (3) - j = center_pix (good_clay(1:CF3,group),good_sand(1:CF3,group), & - min_percs%clay_perc,min_percs%sand_perc,min_percs%silt_perc,.true.) - k = tile_add (j,group) - case (4) - j = center_pix (good_clay(1:CF4,group),good_sand(1:CF4,group), & - min_percs%clay_perc,min_percs%sand_perc,min_percs%silt_perc,.true.) - k = tile_add (j,group) - end select - print *,'NO Similar SoilClass :',soil_class (min_percs),group,n,k - - endif - if (error_file) then - write (41,*)n,k - ! write (41,*)tindex2(n),pfaf2(n),soil_class_top(n),soil_class_com(n), & - ! BEE(n), PSIS(n),POROS(n),COND(n),WPWET(n),soildepth(n) - ! write (41,*)tindex2(k),pfaf2(k),soil_class_top,soil_class_com(k), & - ! BEE(k), PSIS(k),POROS(k),COND(k),WPWET(k),soildepth(k) - endif - - write(20,'(i10,i8,f5.2,11(2x,e14.7))') & - tindex2(n),pfaf2(n),gnu, & - ars1(k),ars2(k),ars3(k), & - ara1(k),ara2(k),ara3(k),ara4(k), & - arw1(k),arw2(k),arw3(k),arw4(k) - write(30,'(i10,i8,f5.2,3(2x,e13.7))')tindex2(n),pfaf2(n),gnu,bf1(k),bf2(k),bf3(k) - write(40,'(i10,i8,f5.2,4(2x,e13.7))')tindex2(n),pfaf2(n),gnu, & - tsa1(k),tsa2(k),tsb1(k),tsb2(k) +! This code block was obsolete because only one set of write statements is needed/desired. +! Repeating near-verbatim copies of write statements was bad coding practice. +! - reichle, 28 April 2022 +! +!obsolete20220428 if((ars1(n).ne.9999.).and.(arw1(n).ne.9999.))then +!obsolete20220428 +!obsolete20220428 ! nominal case, all parameter values are good +!obsolete20220428 +!obsolete20220428 ! write ar.new +!obsolete20220428 +!obsolete20220428 write(20,'(i10,i8,f5.2,11(2x,e14.7))') & +!obsolete20220428 tindex2(n),pfaf2(n),gnu, & +!obsolete20220428 ars1(n),ars2(n),ars3(n), & +!obsolete20220428 ara1(n),ara2(n),ara3(n),ara4(n), & +!obsolete20220428 arw1(n),arw2(n),arw3(n),arw4(n) +!obsolete20220428 +!obsolete20220428 ! write bf.dat +!obsolete20220428 +!obsolete20220428 write(30,'(i10,i8,f5.2,3(2x,e13.7))')tindex2(n),pfaf2(n),gnu,bf1(n),bf2(n),bf3(n) +!obsolete20220428 +!obsolete20220428 ! write ts.dat +!obsolete20220428 +!obsolete20220428 write(40,'(i10,i8,f5.2,4(2x,e13.7))')tindex2(n),pfaf2(n),gnu, & +!obsolete20220428 tsa1(n),tsa2(n),tsb1(n),tsb2(n) +!obsolete20220428 +!obsolete20220428 ! write soil_param.dat +!obsolete20220428 +!obsolete20220428 write(42,'(i10,i8,i4,i4,3f8.4,f12.8,f7.4,f10.4,3f7.3,4f7.3,2f10.4, f8.4)') & +!obsolete20220428 tindex2(n),pfaf2(n),soil_class_top(n),soil_class_com(n), & +!obsolete20220428 BEE(n), PSIS(n),POROS(n),COND(n),WPWET(n),soildepth(n), & +!obsolete20220428 grav_vec(n),soc_vec(n),poc_vec(n), & +!obsolete20220428 a_sand_surf(n),a_clay_surf(n),atile_sand(n),atile_clay(n), & +!obsolete20220428 wpwet_surf(n),poros_surf(n), pmap(n) +!obsolete20220428 +!obsolete20220428 if (allocated (parms4file)) then +!obsolete20220428 parms4file (n, 1) = ara1(n) +!obsolete20220428 parms4file (n, 2) = ara2(n) +!obsolete20220428 parms4file (n, 3) = ara3(n) +!obsolete20220428 parms4file (n, 4) = ara4(n) +!obsolete20220428 parms4file (n, 5) = ars1(n) +!obsolete20220428 parms4file (n, 6) = ars2(n) +!obsolete20220428 parms4file (n, 7) = ars3(n) +!obsolete20220428 parms4file (n, 8) = arw1(n) +!obsolete20220428 parms4file (n, 9) = arw2(n) +!obsolete20220428 parms4file (n,10) = arw3(n) +!obsolete20220428 parms4file (n,11) = arw4(n) +!obsolete20220428 parms4file (n,13) = bf1(n) +!obsolete20220428 parms4file (n,14) = bf2(n) +!obsolete20220428 parms4file (n,15) = bf3(n) +!obsolete20220428 parms4file (n,17) = gnu +!obsolete20220428 parms4file (n,20) = tsa1(n) +!obsolete20220428 parms4file (n,21) = tsa2(n) +!obsolete20220428 parms4file (n,22) = tsb1(n) +!obsolete20220428 parms4file (n,23) = tsb2(n) +!obsolete20220428 endif + + +! This code block is obsolete because it was only needed if preserve_soiltype==.true, but +! preserve_soiltype was hardwired to .false. above. +! -reichle, 28 April 2022 +! +!obsolete20220428 else ! (ars1(n).ne.9999.) .or. (arw1(n)==9999.) +!obsolete20220428 +!obsolete20220428 ! exception, some parameter values are no-data +!obsolete20220428 +!obsolete20220428 if(preserve_soiltype) then +!obsolete20220428 +!obsolete20220428 ! look for a tile with a similar soil class +!obsolete20220428 +!obsolete20220428 ! NOTE: preserve_soiltype=.false. hardwired as of 28 Apr 2022 +!obsolete20220428 +!obsolete20220428 if ((soil_class_com(n)>=1).and.(soil_class_com(n)<=84)) then +!obsolete20220428 group=1 +!obsolete20220428 else if ((soil_class_com(n)> 84).and.(soil_class_com(n)<=168)) then +!obsolete20220428 group=2 +!obsolete20220428 else if ((soil_class_com(n)> 168).and.(soil_class_com(n)< N_SoilClasses)) then +!obsolete20220428 group=3 +!obsolete20220428 else +!obsolete20220428 group=4 +!obsolete20220428 endif +!obsolete20220428 +!obsolete20220428 min_percs%clay_perc = atile_clay(n) +!obsolete20220428 min_percs%sand_perc = atile_sand(n) +!obsolete20220428 min_percs%silt_perc = 100. - min_percs%clay_perc - min_percs%sand_perc +!obsolete20220428 +!obsolete20220428 if(tile_pick(soil_class (min_percs),group) > 0) then +!obsolete20220428 +!obsolete20220428 k = tile_pick(soil_class (min_percs),group) +!obsolete20220428 +!obsolete20220428 else +!obsolete20220428 +!obsolete20220428 select case (group) +!obsolete20220428 +!obsolete20220428 case (1) +!obsolete20220428 j = center_pix (good_clay(1:CF1,group),good_sand(1:CF1,group), & +!obsolete20220428 min_percs%clay_perc,min_percs%sand_perc,min_percs%silt_perc,.true.) +!obsolete20220428 k = tile_add (j,group) +!obsolete20220428 case (2) +!obsolete20220428 j = center_pix (good_clay(1:CF2,group),good_sand(1:CF2,group), & +!obsolete20220428 min_percs%clay_perc,min_percs%sand_perc,min_percs%silt_perc,.true.) +!obsolete20220428 k = tile_add (j,group) +!obsolete20220428 case (3) +!obsolete20220428 j = center_pix (good_clay(1:CF3,group),good_sand(1:CF3,group), & +!obsolete20220428 min_percs%clay_perc,min_percs%sand_perc,min_percs%silt_perc,.true.) +!obsolete20220428 k = tile_add (j,group) +!obsolete20220428 case (4) +!obsolete20220428 j = center_pix (good_clay(1:CF4,group),good_sand(1:CF4,group), & +!obsolete20220428 min_percs%clay_perc,min_percs%sand_perc,min_percs%silt_perc,.true.) +!obsolete20220428 k = tile_add (j,group) +!obsolete20220428 end select +!obsolete20220428 print *,'NO Similar SoilClass :',soil_class (min_percs),group,n,k +!obsolete20220428 +!obsolete20220428 endif +!obsolete20220428 +!obsolete20220428 if (error_file) then +!obsolete20220428 ! record in file clsm/bad_sat_param.tiles +!obsolete20220428 write (41,*)n,k ! n="bad" tile, k=tile from which parameters are taken +!obsolete20220428 +!obsolete20220428 ! write (41,*)tindex2(n),pfaf2(n),soil_class_top(n),soil_class_com(n), & +!obsolete20220428 ! BEE(n), PSIS(n),POROS(n),COND(n),WPWET(n),soildepth(n) +!obsolete20220428 ! write (41,*)tindex2(k),pfaf2(k),soil_class_top,soil_class_com(k), & +!obsolete20220428 ! BEE(k), PSIS(k),POROS(k),COND(k),WPWET(k),soildepth(k) +!obsolete20220428 endif +!obsolete20220428 +!obsolete20220428 +!obsolete20220428 ! write ar.new, bf.dat, ts.dat, and soil_param.dat +!obsolete20220428 +!obsolete20220428 write(20,'(i10,i8,f5.2,11(2x,e14.7))') & +!obsolete20220428 tindex2(n),pfaf2(n),gnu, & +!obsolete20220428 ars1(k),ars2(k),ars3(k), & +!obsolete20220428 ara1(k),ara2(k),ara3(k),ara4(k), & +!obsolete20220428 arw1(k),arw2(k),arw3(k),arw4(k) +!obsolete20220428 write(30,'(i10,i8,f5.2,3(2x,e13.7))')tindex2(n),pfaf2(n),gnu,bf1(k),bf2(k),bf3(k) +!obsolete20220428 write(40,'(i10,i8,f5.2,4(2x,e13.7))')tindex2(n),pfaf2(n),gnu, & +!obsolete20220428 tsa1(k),tsa2(k),tsb1(k),tsb2(k) +!obsolete20220428 +!obsolete20220428 write(42,'(i10,i8,i4,i4,3f8.4,f12.8,f7.4,f10.4,3f7.3,4f7.3,2f10.4, f8.4)') & +!obsolete20220428 tindex2(n),pfaf2(n),soil_class_top(k),soil_class_com(k), & +!obsolete20220428 BEE(k), PSIS(k),POROS(k),COND(k),WPWET(k),soildepth(k), & +!obsolete20220428 grav_vec(k),soc_vec(k),poc_vec(k), & +!obsolete20220428 a_sand_surf(k),a_clay_surf(k),atile_sand(k),atile_clay(k) , & +!obsolete20220428 wpwet_surf(k),poros_surf(k), pmap (k) +!obsolete20220428 +!obsolete20220428 if (allocated (parms4file)) then +!obsolete20220428 parms4file (n, 1) = ara1(k) +!obsolete20220428 parms4file (n, 2) = ara2(k) +!obsolete20220428 parms4file (n, 3) = ara3(k) +!obsolete20220428 parms4file (n, 4) = ara4(k) +!obsolete20220428 parms4file (n, 5) = ars1(k) +!obsolete20220428 parms4file (n, 6) = ars2(k) +!obsolete20220428 parms4file (n, 7) = ars3(k) +!obsolete20220428 parms4file (n, 8) = arw1(k) +!obsolete20220428 parms4file (n, 9) = arw2(k) +!obsolete20220428 parms4file (n,10) = arw3(k) +!obsolete20220428 parms4file (n,11) = arw4(k) +!obsolete20220428 parms4file (n,12) = BEE(k) +!obsolete20220428 parms4file (n,13) = bf1(k) +!obsolete20220428 parms4file (n,14) = bf2(k) +!obsolete20220428 parms4file (n,15) = bf3(k) +!obsolete20220428 parms4file (n,16) = COND(k) +!obsolete20220428 parms4file (n,17) = gnu +!obsolete20220428 parms4file (n,18) = POROS(k) +!obsolete20220428 parms4file (n,19) = PSIS(k) +!obsolete20220428 parms4file (n,20) = tsa1(k) +!obsolete20220428 parms4file (n,21) = tsa2(k) +!obsolete20220428 parms4file (n,22) = tsb1(k) +!obsolete20220428 parms4file (n,23) = tsb2(k) +!obsolete20220428 parms4file (n,24) = wpwet (k) +!obsolete20220428 parms4file (n,25) = soildepth(k) +!obsolete20220428 endif +!obsolete20220428 +!obsolete20220428 else ! .not. preserve_soiltype + + + ! This revised if block replaces the complex, nested if block commented out above + + if ( (ars1(n)==9999.) .or. (arw1(n)==9999.) ) then + + ! some parameter values are no-data --> find nearest tile k with good parameters + + dist_save = 1000000. + k = 0 + do i = 1,nbcatch + if(i /= n) then + if((ars1(i).ne.9999.).and.(arw1(i).ne.9999.)) then + + tile_distance = (tile_lon(i) - tile_lon(n)) * (tile_lon(i) - tile_lon(n)) + & + (tile_lat(i) - tile_lat(n)) * (tile_lat(i) - tile_lat(n)) + if(tile_distance < dist_save) then + k = i + dist_save = tile_distance + endif + endif + endif + enddo + ! record in file clsm/bad_sat_param.tiles + write (41,*)n,k ! n="bad" tile, k=tile from which parameters are taken - write(42,'(i10,i8,i4,i4,3f8.4,f12.8,f7.4,f10.4,3f7.3,4f7.3,2f10.4, f8.4)') & - tindex2(n),pfaf2(n),soil_class_top(k),soil_class_com(k), & - BEE(k), PSIS(k),POROS(k),COND(k),WPWET(k),soildepth(k), & - grav_vec(k),soc_vec(k),poc_vec(k), & - a_sand_surf(k),a_clay_surf(k),atile_sand(k),atile_clay(k) , & - wpwet_surf(k),poros_surf(k), pmap (k) + ! Overwrite parms4file when filling in parameters from neighboring tile k. + ! For "good" tiles, keep parms4file as read earlier from catch_params.nc4, + ! which is why this must be done within the "then" block of the "if" statement. + ! This is necessary for backward 0-diff compatibility of catch_params.nc4. + parms4file (n,12) = BEE(k) + parms4file (n,16) = COND(k) + parms4file (n,18) = POROS(k) + parms4file (n,19) = PSIS(k) + parms4file (n,24) = wpwet(k) + parms4file (n,25) = soildepth(k) + + else + + ! nominal case, all parameters are good + + k = n + + end if + + ! for current tile n, write parameters of tile k into ar.new (20), bf.dat (30), ts.dat (40), + ! and soil_param.dat (42) + + write(20,'(i10,i8,f5.2,11(2x,e14.7))') & + tindex2(n),pfaf2(n),gnu, & + ars1(k),ars2(k),ars3(k), & + ara1(k),ara2(k),ara3(k),ara4(k), & + arw1(k),arw2(k),arw3(k),arw4(k) + + write(30,'(i10,i8,f5.2,3(2x,e13.7))')tindex2(n),pfaf2(n),gnu,bf1(k),bf2(k),bf3(k) + + write(40,'(i10,i8,f5.2,4(2x,e13.7))')tindex2(n),pfaf2(n),gnu, & + tsa1(k),tsa2(k),tsb1(k),tsb2(k) + + write(42,'(i10,i8,i4,i4,3f8.4,f12.8,f7.4,f10.4,3f7.3,4f7.3,2f10.4, f8.4)') & + tindex2(n),pfaf2(n),soil_class_top(k),soil_class_com(k), & + BEE(k), PSIS(k),POROS(k),COND(k),WPWET(k),soildepth(k), & + grav_vec(k),soc_vec(k),poc_vec(k), & + a_sand_surf(k),a_clay_surf(k),atile_sand(k),atile_clay(k) , & + wpwet_surf(k),poros_surf(k), pmap(k) + + ! record ar.new, bf.dat, and ts.dat parameters for later writing into catch_params.nc4 + if (allocated (parms4file)) then parms4file (n, 1) = ara1(k) parms4file (n, 2) = ara2(k) @@ -4095,93 +4311,28 @@ SUBROUTINE create_model_para_woesten (Maskfile) parms4file (n, 9) = arw2(k) parms4file (n,10) = arw3(k) parms4file (n,11) = arw4(k) - parms4file (n,12) = BEE(k) parms4file (n,13) = bf1(k) parms4file (n,14) = bf2(k) parms4file (n,15) = bf3(k) - parms4file (n,16) = COND(k) parms4file (n,17) = gnu - parms4file (n,18) = POROS(k) - parms4file (n,19) = PSIS(k) parms4file (n,20) = tsa1(k) parms4file (n,21) = tsa2(k) parms4file (n,22) = tsb1(k) parms4file (n,23) = tsb2(k) - parms4file (n,24) = wpwet (k) - parms4file (n,25) = soildepth(k) endif - - else - - dist_save = 1000000. - k = 0 - do i = 1,nbcatch - if(i /= n) then - if((ars1(i).ne.9999.).and.(arw1(i).ne.9999.)) then - - tile_distance = (tile_lon(i) - tile_lon(n)) * (tile_lon(i) - tile_lon(n)) + & - (tile_lat(i) - tile_lat(n)) * (tile_lat(i) - tile_lat(n)) - if(tile_distance < dist_save) then - k = i - dist_save = tile_distance - endif - endif - endif - enddo - write (41,*)n,k - write(20,'(i10,i8,f5.2,11(2x,e14.7))') & - tindex2(n),pfaf2(n),gnu, & - ars1(k),ars2(k),ars3(k), & - ara1(k),ara2(k),ara3(k),ara4(k), & - arw1(k),arw2(k),arw3(k),arw4(k) - write(30,'(i10,i8,f5.2,3(2x,e13.7))')tindex2(n),pfaf2(n),gnu,bf1(k),bf2(k),bf3(k) - write(40,'(i10,i8,f5.2,4(2x,e13.7))')tindex2(n),pfaf2(n),gnu, & - tsa1(k),tsa2(k),tsb1(k),tsb2(k) - write(42,'(i10,i8,i4,i4,3f8.4,f12.8,f7.4,f10.4,3f7.3,4f7.3,2f10.4, f8.4)')& - tindex2(n),pfaf2(n),soil_class_top(k),soil_class_com(k), & - BEE(k), PSIS(k),POROS(k),COND(k),WPWET(k),soildepth(k), & - grav_vec(k),soc_vec(k),poc_vec(k), & - a_sand_surf(k),a_clay_surf(k),atile_sand(k),atile_clay(k) , & - wpwet_surf(k),poros_surf(k), pmap(k) - - if (allocated (parms4file)) then - parms4file (n, 1) = ara1(k) - parms4file (n, 2) = ara2(k) - parms4file (n, 3) = ara3(k) - parms4file (n, 4) = ara4(k) - parms4file (n, 5) = ars1(k) - parms4file (n, 6) = ars2(k) - parms4file (n, 7) = ars3(k) - parms4file (n, 8) = arw1(k) - parms4file (n, 9) = arw2(k) - parms4file (n,10) = arw3(k) - parms4file (n,11) = arw4(k) - parms4file (n,12) = BEE(k) - parms4file (n,13) = bf1(k) - parms4file (n,14) = bf2(k) - parms4file (n,15) = bf3(k) - parms4file (n,16) = COND(k) - parms4file (n,17) = gnu - parms4file (n,18) = POROS(k) - parms4file (n,19) = PSIS(k) - parms4file (n,20) = tsa1(k) - parms4file (n,21) = tsa2(k) - parms4file (n,22) = tsb1(k) - parms4file (n,23) = tsb2(k) - parms4file (n,24) = wpwet (k) - parms4file (n,25) = soildepth(k) - endif - endif - endif - - if (error_file) then - write(21,*)tindex2(n),pfaf2(n),taberr1(n),taberr2(n),taberr3(n),taberr4(n), & + +!obsolete20220428 endif ! if (preserve_soiltype) then +!obsolete20220428 +!obsolete20220428 endif ! if((ars1(n).ne.9999.).and.(arw1(n).ne.9999.))then + + if (error_file) then + write(21,*)tindex2(n),pfaf2(n),taberr1(n),taberr2(n),taberr3(n),taberr4(n), & normerr1(n),normerr2(n),normerr3(n),normerr4(n) - write(31,*)tindex2(n),pfaf2(n),taberr1(n),taberr2(n),normerr1(n),normerr2(n) - endif - - END DO - + write(31,*)tindex2(n),pfaf2(n),taberr1(n),taberr2(n),normerr1(n),normerr2(n) + endif + + END DO ! n=1,nbcatch + ! Write(*,*) 'END COMPUTING MODEL PARA' close(10,status='keep')