diff --git a/build/FUSE_SRC/driver/functn.f90 b/build/FUSE_SRC/driver/functn.f90 index fa5acf7..1ff846b 100644 --- a/build/FUSE_SRC/driver/functn.f90 +++ b/build/FUSE_SRC/driver/functn.f90 @@ -10,7 +10,8 @@ FUNCTION FUNCTN(NOPT,A) ! Wrapper for SCE (used to compute the objective function) ! --------------------------------------------------------------------------------------- USE nrtype ! variable types, etc. -USE fuse_metric_module ! run model and compute the metric chosen as objective function +USE sce_callback_context, only: ctx ! access FUSE data structures +USE fuse_evaluate_module, only: fuse_evaluate ! run model and compute the metric chosen as objective function USE multiforce, only: ncid_forc ! NetCDF forcing file ID USE fuse_fileManager,only:METRIC, TRANSFO ! metric and transformation requested in the filemanager USE globaldata, only: nFUSE_eval ! # fuse evaluations @@ -21,7 +22,7 @@ FUNCTION FUNCTN(NOPT,A) REAL(MSP), DIMENSION(100), INTENT(IN) :: A ! model parameter set - can be bumped up to 100 elements ! internal -REAL(SP), DIMENSION(:), ALLOCATABLE :: SCE_PAR ! sce parameter set +REAL(SP), DIMENSION(NOPT) :: SCE_PAR ! sce parameter set INTEGER(I4B) :: IERR ! error code for allocate/deallocate INTEGER(I4B) :: ERR ! error code for fuse_metric CHARACTER(LEN=256) :: MESSAGE ! error message for fuse_metric @@ -36,25 +37,18 @@ FUNCTION FUNCTN(NOPT,A) nFUSE_eval = nFUSE_eval + 1 ! get SCE parameter set -ALLOCATE(SCE_PAR(NOPT), STAT=IERR); IF (IERR.NE.0) STOP ' problem allocating space ' SCE_PAR(1:NOPT) = A(1:NOPT) ! convert from MSP used in SCE to SP used in FUSE +OUTPUT_FLAG=.FALSE. ! do not produce *runs.nc files only, param.nc files -OUTPUT_FLAG=.FALSE. ! do not produce *runs.nc files only, param.nc files - -CALL FUSE_METRIC(SCE_PAR,.FALSE.,NCID_FORC,METRIC_VAL,OUTPUT_FLAG,1) ! 2nd argument FALSE, always return METRIC value - -! deallocate parameter set -DEALLOCATE(SCE_PAR, STAT=IERR); IF (IERR.NE.0) STOP ' problem deallocating space ' -print *, 'METRIC_VAL [Metric:',METRIC,' / Transfo:',TRANSFO,'] =', METRIC_VAL +CALL FUSE_evaluate(SCE_PAR, ctx%info, ctx%work, ctx%domain, OUTPUT_FLAG, METRIC_VAL) ! save objective function value: SCE is a minimization algorithm -IF (METRIC=="KGE" .OR. METRIC=="KGEP" .OR. METRIC=="NSE") THEN - FUNCTN = -METRIC_VAL -ELSE IF (METRIC=="MAE" .OR. METRIC=="RMSE" ) THEN - FUNCTN = METRIC_VAL -ELSE - STOP 'The requested metric is not available in metrics module' -END IF +select case(metric) + case ("KGE", "KGEP", "NSE"); FUNCTN = -METRIC_VAL + case ("MAE", "RMSE"); FUNCTN = METRIC_VAL + case default + STOP 'The requested metric is not available in metrics module' +end select ! --------------------------------------------------------------------------------------- END FUNCTION FUNCTN diff --git a/build/FUSE_SRC/driver/fuse_driver.f90 b/build/FUSE_SRC/driver/fuse_driver.f90 index 796b6e9..6cda7e7 100644 --- a/build/FUSE_SRC/driver/fuse_driver.f90 +++ b/build/FUSE_SRC/driver/fuse_driver.f90 @@ -5,499 +5,216 @@ PROGRAM DISTRIBUTED_DRIVER ! Modified by Brian Henn to include snow model, 6/2013 ! Modified by Nans Addor to include distributed modeling, 9/2016 ! Modified by Nans Addor to re-enable catchment-scale modeling, 4/2017 -! Modified by Cyril Thébault to allow different metrics as objective function, 2024 +! Modified by Martyn Clark to modularize and simplify CLI, 12/2025 ! --------------------------------------------------------------------------------------- ! Purpose: ! Driver program to run FUSE with a snow module as either at the catchment-scale or ! at the grid-scale ! --------------------------------------------------------------------------------------- +! data types USE nrtype ! variable types, etc. -USE netcdf ! NetCDF library -USE fuse_fileManager,only:fuse_SetDirsUndPhiles,& ! sets directories and filenames - SETNGS_PATH,MBANDS_INFO,MBANDS_NC, & - OUTPUT_PATH,FORCINGINFO,INPUT_PATH,& - FMODEL_ID,& - suffix_forcing,suffix_elev_bands,& - numtim_sub_str,& - KSTOP_str, MAXN_str, PCENTO_str - -! data modules -USE model_defn,nstateFUSE=>nstate ! model definition structures -USE model_defnames ! defines the integer model options -USE globaldata, ONLY: isPrint ! flag for printing progress to screen -USE globaldata, only: nFUSE_eval ! number of fuse evaluations -USE multiforce, ONLY: forcefile,vname_aprecip ! model forcing structures -USE multiforce, ONLY: AFORCE, aValid ! time series of lumped forcing/response data -USE multiforce, ONLY: nspat1, nspat2 ! grid dimensions -USE multiforce, only: GRID_FLAG ! .true. if distributed -USE multiforce, ONLY: GFORCE, GFORCE_3d ! spatial arrays of gridded forcing data -USE multiforce, only: ancilF, ancilF_3d ! ancillary forcing data -USE multiforce, ONLY: valDat ! response data -USE multiforce, only: DELTIM -USE multiforce, only: ISTART ! index for start of inference -USE multiforce, ONLY: timeUnits,time_steps,julian_day_input ! time data -USE multiforce, only: numtim_in, itim_in ! length of input time series and associated index -USE multiforce, only: numtim_sim, itim_sim ! length of simulated time series and associated index -USE multiforce, only: numtim_sub, itim_sub ! length of subperiod time series and associated index -USE multiforce, only: sim_beg,sim_end ! timestep indices -USE multiforce, only: eval_beg,eval_end ! timestep indices -USE multiforce, only: SUB_PERIODS_FLAG ! .true. if subperiods are used to run FUSE -USE multiforce, only: NUMPSET ! number of parameter sets - -USE multiforce, only: ncid_forc ! NetCDF forcing file ID -USE multiforce, only: ncid_var ! NetCDF forcing variable ID -USE multistate, only: ncid_out ! NetCDF output file ID - -USE multibands ! basin band stuctures -USE multiparam, ONLY: LPARAM, PARATT, NUMPAR ! parameter metadata structures -USE multistate, only: gState ! gridded state variables -USE multistate, only: gState_3d ! gridded state variables with a time dimension -USE multiroute, ONLY: AROUTE ! model routing structures -USE multiroute, ONLY: AROUTE_3d ! model routing structures with a time dimension -USE multistats ! model statistics structures - -! informational modules -USE selectmodl_module ! reads model control file -USE getpar_str_module ! extracts parameter metadata -USE par_insert_module ! inserts model parameters -USE force_info_module,only:force_info ! get forcing info for NetCDF files -USE get_gforce_module,only:read_ginfo ! get dimension lengths from the NetCDF file -USE get_gforce_module,only:get_varid ! get netCDF ID for forcing variables -USE get_gforce_module,only:get_gforce_3d ! get forcing -USE get_mbands_module,only:GET_MBANDS_INFO ! get elevation bands for snow modeling -USE get_fparam_module ! get SCE parameters from NetCDF file -USE GET_TIME_INDICES_MODULE ! get time indices -USE time_io - -! model numerix -USE model_numerix ! defines decisions on model numerix - -! access to model simulation modules -USE fuse_metric_module ! run model and compute the metric chosen as objective function +USE info_types, only: cli_options ! command line interface options +USE info_types, only: fuse_info ! info structure (includes "everything") +USE work_types, only: fuse_work ! structures that depend on nState/nPar +USE data_types, only: domain_data ! domain data +USE multistats, only: PCOUNT ! counter + +! data +USE globaldata, only: isPrint +USE globaldata, only: ncid_out +USE multiparam, only: NUMPAR +USE multiforce, only: NUMPSET +USE multiforce, only: SUB_PERIODS_FLAG +USE multiForce, only: AFORCE, gForce, gForce_3d, aValid +USE multiState, only: gState, gState_3d +USE multiRoute, only: aRoute, AROUTE_3d + +! model setup: external subroutines/functions +USE netcdf ! NetCDF library +USE parse_command_args_MODULE, only: parse_command_args ! parse command line arguments +USE setup_domain_module, only: setup_domain ! initialize the model domain +USE setup_model_definition_module, only: setup_model_definition ! setup the FUSE model configuration +USE alloc_scratch_module, only: init_fuse_work ! initialze work structure + +! model run: external subroutines/functions +USE get_fparam_module, only: GET_PRE_PARAM, GET_SCE_PARAM ! read parameters from netcdf file +USE sce_driver_MODULE, only: sce_driver ! SCE optimization + +! model simulation modules +USE fuse_evaluate_module, only: fuse_evaluate ! run model and compute performance metrics #ifdef __MPI__ -use mpi + use mpi #endif + IMPLICIT NONE -! --------------------------------------------------------------------------------------- -! GET COMMAND-LINE ARGUMENTS... -! --------------------------------------------------------------------------------------- -CHARACTER(LEN=256) :: DatString ! file manager -CHARACTER(LEN=256) :: dom_id ! ID of the domain -CHARACTER(LEN=10) :: fuse_mode=' ' ! fuse execution mode (run_def, run_best, run_pre, calib_sce) -CHARACTER(LEN=256) :: file_param ! name of parameter file -CHARACTER(LEN=10) :: index_param ! index of desired parameter set +! error control +integer(i4b) :: err ! error code +character(len=1024) :: message ! error message -! --------------------------------------------------------------------------------------- -! SETUP MODELS FOR SIMULATION -- POPULATE DATA STRUCTURES -! --------------------------------------------------------------------------------------- -! fuse_file_manager -CHARACTER(LEN=1024) :: FFMFILE ! name of fuse_file_manager file -CHARACTER(LEN=1024) :: ELEV_BANDS_NC ! name of NetCDF file for elevation bands -! get model forcing data -INTEGER(I4B) :: NTIM ! number of time steps - still needed ? -INTEGER(I4B) :: INFERN_START ! start of inference period - still needed? -! get model setup -INTEGER(I4B) :: FUSE_ID ! integer defining FUSE model -INTEGER(I4B) :: NMOD ! number of models -INTEGER(I4B) :: ERR ! error code -CHARACTER(LEN=1024) :: MESSAGE ! error message -! get spatial option -CHARACTER(LEN=6) :: SPATIAL_OPTION ! spatial option (catch or grid) -INTEGER(I4B),PARAMETER :: LUMPED=0 ! named variable for lumped simulations -INTEGER(I4B),PARAMETER :: DISTRIBUTED=1 ! named variable for distributed simulations -! define model output -LOGICAL(LGT) :: OUTPUT_FLAG ! .TRUE. = write time series output -INTEGER(I4B) :: ONEMOD=1 ! just specify one model -! timers -INTEGER(I4B) :: T_start_import_forcing ! system clock -INTEGER(I4B) :: T_end_import_forcing ! system clock -! dummies -CHARACTER(LEN=100) :: dummy_string ! used for temporary data storage -integer(i4b) :: file_pass ! used read parameter list +! command line arguments +type(cli_options) :: cli_opts ! command line argument options -! --------------------------------------------------------------------------------------- -! RUN MODEL FOR DIFFERENT PARAMETER SETS -! --------------------------------------------------------------------------------------- -INTEGER(I4B) :: ITIM ! loop thru time steps -INTEGER(I4B) :: IPAR ! loop thru model parameters -INTEGER(I4B) :: IPSET ! index of desired model parameter set -TYPE(PARATT) :: PARAM_META ! parameter metadata (model parameters) +! parameter set; parameter bounds REAL(SP), DIMENSION(:), ALLOCATABLE :: BL ! vector of lower parameter bounds REAL(SP), DIMENSION(:), ALLOCATABLE :: BU ! vector of upper parameter bounds REAL(SP), DIMENSION(:), ALLOCATABLE :: APAR ! model parameter set -INTEGER(KIND=4) :: ISEED ! seed for the random sequence -REAL(KIND=4),DIMENSION(:), ALLOCATABLE :: URAND ! vector of quasi-random numbers U[0,1] -REAL(SP) :: METRIC_VAL ! error from the simulation -! --------------------------------------------------------------------------------------- -! SCE VARIABLES -! --------------------------------------------------------------------------------------- -REAL(MSP) :: AF_MSP ! objective function value -REAL(MSP), DIMENSION(:), ALLOCATABLE :: APAR_MSP ! ! lower bound of model parameters -REAL(MSP), DIMENSION(:), ALLOCATABLE :: BL_MSP ! ! lower bound of model parameters -REAL(MSP), DIMENSION(:), ALLOCATABLE :: BU_MSP ! ! upper bound of model parameters -REAL(MSP), DIMENSION(:), ALLOCATABLE :: URAND_MSP ! vector of quasi-random numbers U[0,1] -INTEGER(I4B) :: NOPT ! number of parameters to be optimized -INTEGER(I4B) :: KSTOP ! number of shuffling loops the value must change by PCENTO -INTEGER(I4B) :: MAXN ! maximum number of trials before optimization is terminated -REAL(MSP) :: PCENTO ! the percentage -CHARACTER(LEN=3) :: CSEED ! starting seed converted to a character -INTEGER(I4B) :: NGS ! # complexes in the initial population -INTEGER(I4B) :: NPG ! # points in each complex -INTEGER(I4B) :: NPS ! # points in a sub-complex -INTEGER(I4B) :: NSPL ! # evolution steps allowed for each complex before shuffling -INTEGER(I4B) :: MINGS ! minimum number of complexes required -INTEGER(I4B) :: INIFLG ! 1 = include initial point in the population -INTEGER(I4B) :: IPRINT ! 0 = supress printing -INTEGER(I4B) :: ISCE ! unit number for SCE write -REAL(MSP) :: FUNCTN ! function name for the model run - -! --------------------------------------------------------------------------------------- -! MPI variables -! --------------------------------------------------------------------------------------- -integer ( kind = 4 ) mpi_error_value -integer ( kind = 4 ) mpi_process -integer ( kind = 4 ) mpi_nprocesses - -! --------------------------------------------------------------------------------------- -! Initialize MPI -! --------------------------------------------------------------------------------------- -#ifdef __MPI__ -call MPI_Init(mpi_error_value) -call MPI_Comm_size(MPI_COMM_WORLD, mpi_nprocesses, mpi_error_value) ! determine the number of processes involved in a communicator (mpi_nproccesses) -call MPI_Comm_rank(MPI_COMM_WORLD, mpi_process, mpi_error_value) ! determine the rank of the process in the particular communicator’s group. -#else -mpi_process = 0 -mpi_nprocesses = 1 -#endif -! --------------------------------------------------------------------------------------- -! READ COMMAND LINE ARGUMENTS -! --------------------------------------------------------------------------------------- -! read command-line arguments -CALL GETARG(1,DatString) ! string defining forcinginfo file -CALL GETARG(2,dom_id) ! ID of the domain -CALL GETARG(3,fuse_mode) ! fuse execution mode (run_def, run_best, calib_sce) -IF(TRIM(fuse_mode).EQ.'run_pre')then - CALL GETARG(4,file_param) ! name of parameter file - CALL GETARG(5,index_param) ! index of desired parameter set - IF(LEN_TRIM(index_param).EQ.0) IPSET = 1 - IF(LEN_TRIM(index_param).GT.0) read(index_param,*) IPSET -ENDIF - -! check command-line arguments -IF (LEN_TRIM(DatString).EQ.0) STOP '1st command-line argument is missing (fileManager)' -IF (LEN_TRIM(dom_id).EQ.0) STOP '2nd command-line argument is missing (dom_id)' -IF (LEN_TRIM(fuse_mode).EQ.0) STOP '3rd command-line argument is missing (fuse_mode)' -IF(TRIM(fuse_mode).EQ.'run_pre')THEN - IF(LEN_TRIM(file_param).EQ.0) STOP '4th command-line argument is missing (file_param) and is required in mode run_pre' -ENDIF - -! print command-line arguments -print*, '1st command-line argument (fileManager) = ', trim(DatString) -print*, '2nd command-line argument (dom_id) = ', trim(dom_id) -print*, '3rd command-line argument (fuse_mode) = ', fuse_mode -IF(TRIM(fuse_mode).EQ.'run_pre')THEN - print*, '4th command-line argument (file_param) = ', file_param - print*, '5th command-line argument (index_param) = ', IPSET -ENDIF +! function evaluation +REAL(SP) :: METRIC_VAL ! sim-obs differences -! --------------------------------------------------------------------------------------- -! SET PATHS AND FILES NAME -! --------------------------------------------------------------------------------------- - -! set path to fuse_file_manager -FFMFILE=DatString ! must be in bin folder and you must be in bin to run FUSE - TODO read argument to FFMFILE directly - -! set directories and filenames for control files -call fuse_SetDirsUndPhiles(fuseFileManagerIn=FFMFILE,err=err,message=message) -if (err.ne.0) write(*,*) trim(message); if (err.gt.0) stop - -! define name of forcing info and elevation band file -forcefile= trim(dom_id)//suffix_forcing -ELEV_BANDS_NC=trim(dom_id)//suffix_elev_bands +! model output +LOGICAL(LGT) :: OUTPUT_FLAG ! .TRUE. = write time series output +INTEGER(I4B) :: ONEMOD=1 ! just specify one model -PRINT *, 'Variables defined based on domain name:' -PRINT *, 'forcefile:', TRIM(forcefile) -PRINT *, 'ELEV_BANDS_NC:', TRIM(ELEV_BANDS_NC) +! global domain data +type(fuse_info) :: info ! includes "everything" +type(fuse_work) :: work ! structures that depend on nState/nPar +type(domain_data) :: domain ! 3d/4d output buffers ! --------------------------------------------------------------------------------------- -! GET MODEL SETUP -- MODEL NUEMERICS, GRID, AND PARAMETER AND VARIABLE INFO FOR ALL MODELS +! ----- model preliminaries (initialize) ------------------------------------------------ ! --------------------------------------------------------------------------------------- -! defines method/parameters used for numerical solution based on numerix file -CALL GETNUMERIX(ERR,MESSAGE) - -! get forcing info from the txt file, ?? including NA_VALUE ?? -call force_info(fuse_mode,err,message) -if(err/=0)then; write(*,*) trim(message); stop; endif - -print *, 'Open forcing file:', trim(INPUT_PATH)//trim(forcefile) - -! open NetCDF forcing file -err = nf90_open(trim(INPUT_PATH)//trim(forcefile), nf90_nowrite, ncid_forc) -if (err.ne.0) write(*,*) trim(message); if (err.gt.0) stop -PRINT *, 'NCID_FORC is', ncid_forc - -! get the grid info (spatial and temporal dimensions) from the NetCDF file -call read_ginfo(ncid_forc,err,message) -if(err/=0)then; write(*,*) trim(message); stop; endif - -! determine period over which to run and evaluate FUSE and their associated indices -CALL GET_TIME_INDICES() - -IF((.NOT.GRID_FLAG).AND.SUB_PERIODS_FLAG)THEN; write(*,*) 'Error: in catchment mode, FUSE must run over entire time series at once, please set numtim_sub to -9999 in the filemanager (', trim(DatString),').'; stop; endif - -! allocate space for the basin/grid-average time series -allocate(aForce(numtim_sub),aRoute(numtim_sub),stat=err) -!allocate(aForce(numtim_sub),aRoute(numtim_sub),aValid(numtim_sub),stat=err) -if(err/=0)then; write(*,*) 'unable to allocate space for basin-average time series [aForce,aRoute]'; stop; endif +! ----- initialize MPI ------------------------------------------------------------------ -! allocate space for the forcing grid and states -allocate(ancilF(nspat1,nspat2), gForce(nspat1,nspat2), gState(nspat1,nspat2), stat=err) -if(err/=0)then; write(*,*) 'unable to allocate space for forcing grid GFORCE'; stop; endif - -! allocate space for the forcing grid and states with a time dimension - only for subperiod -allocate(AROUTE_3d(nspat1,nspat2,numtim_sub), gState_3d(nspat1,nspat2,numtim_sub+1),gForce_3d(nspat1,nspat2,numtim_sub),aValid(nspat1,nspat2,numtim_sub),stat=err) -if(err/=0)then; write(*,*) 'unable to allocate space for 3d structure'; stop; endif - -! get elevation band info, in particular N_BANDS -CALL GET_MBANDS_INFO(ELEV_BANDS_NC,err,message) ! read band data from NetCDF file -if(err/=0)then; write(*,*) trim(message); stop; endif - -! allocate space for elevation bands -allocate(MBANDS_VAR_4d(nspat1,nspat2,N_BANDS,numtim_sub+1),stat=err) -if(err/=0)then; write(*,*) 'unable to allocate space for elevation bands'; stop; endif - -! get variable ID from the NetCDF file -call get_varID(ncid_forc,err,message) -if(err/=0)then; write(*,*) 'unable to get NetCDF variables ID'; stop; endif - -! Define model attributes (valid for all models) -CALL UNIQUEMODL(NMOD) ! get nmod unique models -CALL GETPARMETA(ERR,MESSAGE) ! read parameter metadata (parameter bounds etc.) - -IF (ERR.NE.0) WRITE(*,*) TRIM(MESSAGE); IF (ERR.GT.0) STOP - -! Identify a single model -CALL SELECTMODL(FMODEL_ID,ERR=ERR,MESSAGE=MESSAGE) -IF (ERR.NE.0) WRITE(*,*) TRIM(MESSAGE); IF (ERR.GT.0) STOP - -! Define list of states and parameters for the current model -CALL ASSIGN_STT() ! state definitions are stored in module model_defn -CALL ASSIGN_FLX() ! flux definitions are stored in module model_defn -CALL ASSIGN_PAR() ! parameter definitions are stored in module multiparam - -! Compute derived model parameters (bucket sizes, etc.) -CALL PAR_DERIVE(ERR,MESSAGE) -IF (ERR.NE.0) WRITE(*,*) TRIM(MESSAGE); IF (ERR.GT.0) STOP - -! Define output and parameter files -ONEMOD=1 ! one file per model (i.e., model dimension = 1) -PCOUNT=0 ! counter for parameter sets evaluated (shared in MODULE multistats) - -IF(fuse_mode == 'run_def')THEN ! run FUSE with default parameter values - - ! files to which model run and parameter set will be saved #ifdef __MPI__ - write(FNAME_NETCDF_RUNS, "(A,I0.5,A)") TRIM(OUTPUT_PATH)//TRIM(dom_id)//'_'//TRIM(FMODEL_ID)//'_runs_def_', mpi_process, ".nc" - write(FNAME_NETCDF_PARA, "(A,I0.5,A)") TRIM(OUTPUT_PATH)//TRIM(dom_id)//'_'//TRIM(FMODEL_ID)//'_para_def_', mpi_process, ".nc" + info%mpi%enabled = .true. + call MPI_Init(err); call MPI_check(err, "MPI_Init") + call MPI_Comm_rank(MPI_COMM_WORLD, info%mpi%rank, err); call MPI_check(err, "MPI_Comm_rank") + call MPI_Comm_size(MPI_COMM_WORLD, info%mpi%nproc, err); call MPI_check(err, "MPI_Comm_size") #else - FNAME_NETCDF_RUNS = TRIM(OUTPUT_PATH)//TRIM(dom_id)//'_'//TRIM(FMODEL_ID)//'_runs_def.nc' - FNAME_NETCDF_PARA = TRIM(OUTPUT_PATH)//TRIM(dom_id)//'_'//TRIM(FMODEL_ID)//'_para_def.nc' + info%mpi%enabled = .false. + info%mpi%rank = 0 + info%mpi%nproc = 1 #endif - NUMPSET=1 ! only the default parameter set is run - -ELSE IF(fuse_mode == 'run_pre')THEN ! run FUSE with pre-defined parameter values - - ! files to which model run and parameter set will be saved - FNAME_NETCDF_RUNS = TRIM(OUTPUT_PATH)//TRIM(dom_id)//'_'//TRIM(FMODEL_ID)//'_runs_pre.nc' - FNAME_NETCDF_PARA = TRIM(OUTPUT_PATH)//TRIM(dom_id)//'_'//TRIM(FMODEL_ID)//'_para_pre_out.nc' +! suppress printing for higher ranks +if(info%mpi%rank > 0) isPrint=.false. - NUMPSET=1 ! only the one "desired" parameter set is run +! ----- parse command line arguments ---------------------------------------------------- -ELSE IF(fuse_mode == 'calib_sce')THEN ! calibrate FUSE using SCE +call parse_command_args(cli_opts,err,message) +if(err/=0) stop trim(message) - ! files to which model run and parameter set will be saved - FNAME_NETCDF_RUNS = TRIM(OUTPUT_PATH)//TRIM(dom_id)//'_'//TRIM(FMODEL_ID)//'_runs_sce.nc' - FNAME_NETCDF_PARA = TRIM(OUTPUT_PATH)//TRIM(dom_id)//'_'//TRIM(FMODEL_ID)//'_para_sce.nc' +if(isPrint)then + print*, 'Control file = ', cli_opts%control_file + print*, 'Run mode = ', cli_opts%runmode +endif - ! assign algorithmic control parameters for SCE - ! convert characters to interger/MSP - READ (MAXN_STR,*) MAXN ! maximum number of trials before optimization is terminated - READ (KSTOP_STR,*) KSTOP ! number of shuffling loops the value must change by PCENTO (MAX=9) - READ (PCENTO_STR,*) PCENTO ! the percentage +! ----- initialize the model domain ----------------------------------------------------- - PRINT *, 'SCE parameters read from file manager:' - PRINT *, 'Maximum number of trials before SCE optimization is stopped (MAXN) = ', MAXN_STR - PRINT *, 'Number of shuffling loops the value must change by PCENTO (KSTOP) = ', KSTOP_STR - PRINT *, 'PCENTO = ', PCENTO_STR +! read forcing metadata (space/time/coords), apply MPI decomposition, and allocate domain arrays +call setup_domain(cli_opts, info, domain, err, message) +if(err/=0) stop trim(message) - NOPT = NUMPAR ! number of parameters to be optimized (NUMPAR in module multiparam) - NGS = 10 ! number of complexes in the initial population - NPG = 2*NOPT + 1 ! number of points in each complex - NPS = NOPT + 1 ! number of points in a sub-complex - NSPL = 2*NOPT + 1 ! number of evolution steps allowed for each complex before shuffling - MINGS = NGS ! minimum number of complexes required - INIFLG = 1 ! 1 = include initial point in the population - IPRINT = 1 ! 0 = supress printing +! ----- initialize model configurations ------------------------------------------------- - NUMPSET=1.2*MAXN ! will be used to define the parameter set dimension of the NetCDF files - ! using 1.2MAXN since the final number of parameter sets produced by SCE is unknown +! choose model, load parameter metadata, derive parameters, and define NetCDF output files +call setup_model_definition(cli_opts, info, domain, APAR, BL, BU, err, message) +if(err/=0) stop trim(message) -ELSE IF(fuse_mode == 'run_best')THEN ! run FUSE with "best" parameter set from a previous SCE calibration +! ----- initialize work structures ------------------------------------------------------ - ! file from which SCE parameters will be loaded - same as FNAME_NETCDF_PARA above - FNAME_NETCDF_PARA_SCE = TRIM(OUTPUT_PATH)//TRIM(dom_id)//'_'//TRIM(FMODEL_ID)//'_para_sce.nc' +! allocate space for work structures that depend on number of states and parameters +call init_fuse_work(info, work, err, message) +if(err/=0) stop trim(message) - ! files to which "best" SCE model run and parameter set will be saved - FNAME_NETCDF_RUNS = TRIM(OUTPUT_PATH)//TRIM(dom_id)//'_'//TRIM(FMODEL_ID)//'_runs_best.nc' - FNAME_NETCDF_PARA = TRIM(OUTPUT_PATH)//TRIM(dom_id)//'_'//TRIM(FMODEL_ID)//'_para_best.nc' +! ----- set initial counters ------------------------------------------------------------ - NUMPSET=1 ! only the one "best" parameter set is run - -ELSE - - print *, 'Unexpected fuse_mode!' - -ENDIF - -CALL DEF_PARAMS(NUMPSET) ! define model parameters (initial CREATE) -CALL DEF_SSTATS() ! define summary statistics (REDEF) -CALL DEF_OUTPUT(nSpat1,nSpat2,NUMPSET,numtim_sim) ! define model output time series (REDEF) +! Define output and parameter files +ONEMOD=1 ! one file per model (i.e., model dimension = 1) +PCOUNT=0 ! counter for parameter sets evaluated (shared in MODULE multistats) ! --------------------------------------------------------------------------------------- -! RUN FUSE IN DESIRED MODE +! ----- run different FUSE modes -------------------------------------------------------- ! --------------------------------------------------------------------------------------- -! get parameter bounds and random numbers -ALLOCATE(APAR(NUMPAR),BL(NUMPAR),BU(NUMPAR),URAND(NUMPAR)) - -DO IPAR=1,NUMPAR - CALL GETPAR_STR(LPARAM(IPAR)%PARNAME,PARAM_META) - BL(IPAR) = PARAM_META%PARLOW ! lower boundary - BU(IPAR) = PARAM_META%PARUPP ! upper boundary - APAR(IPAR) = PARAM_META%PARDEF ! using default parameter values - !if(PARAM_META%PARFIT) print*, LPARAM(IPAR)%PARNAME, PARAM_META%PARDEF -END DO - -IF(fuse_mode == 'run_def')THEN ! run FUSE with default parameter values - - OUTPUT_FLAG=.TRUE. - - print *, 'Running FUSE with default parameter values' - CALL FUSE_METRIC(APAR,GRID_FLAG,NCID_FORC,METRIC_VAL,OUTPUT_FLAG,NUMPSET) - print *, 'Done running FUSE with default parameter values' - -ELSE IF(fuse_mode == 'run_pre')THEN ! run FUSE with pre-defined parameter values - - OUTPUT_FLAG=.TRUE. - - FNAME_NETCDF_PARA_PRE=TRIM(OUTPUT_PATH)//file_param - PRINT *, 'Loading parameter set ',IPSET,':' - - ! load specific parameter set - CALL GET_PRE_PARAM(FNAME_NETCDF_PARA_PRE,IPSET,ONEMOD,NUMPAR,APAR) - - print *, 'Running FUSE with pre-defined parameter set' - CALL FUSE_METRIC(APAR,GRID_FLAG,NCID_FORC,METRIC_VAL,OUTPUT_FLAG,1) ! last argument IPSET=1 - print *, 'Done running FUSE with pre-defined parameter set' - -ELSE IF(fuse_mode == 'calib_sce')THEN ! calibrate FUSE using SCE +! select fuse mode +select case(trim(cli_opts%runmode)) - ! Calibrate FUSE with SCE - OUTPUT_FLAG=.FALSE. + ! ----- single parameter set ---------------------------------------------------------- - FNAME_ASCII = TRIM(OUTPUT_PATH)//TRIM(dom_id)//'_'//TRIM(FMODEL_ID)//'_sce_output.txt' + case('def', 'idx', 'opt') - ! printing - isPrint = .false. ! turn off printing to screen - nFUSE_eval = 0 ! number of fuse evaluations + OUTPUT_FLAG=.TRUE. - ! convert from SP used in FUSE to MSP used in SCE - ALLOCATE(APAR_MSP(NUMPAR),BL_MSP(NUMPAR),BU_MSP(NUMPAR),URAND_MSP(NUMPAR)) + ! load specific parameter set given index in vector into APAR + if (cli_opts%runmode=='idx') then + CALL GET_PRE_PARAM(cli_opts%sets_file, cli_opts%indx, ONEMOD, NUMPAR, APAR) + endif - APAR_MSP=APAR - PRINT *, 'BL=',BL - BL_MSP=BL - BU_MSP=BU - URAND_MSP=URAND + ! load best parameter set from NetCDF file into APAR + if (cli_opts%runmode=='opt') then + CALL GET_SCE_PARAM(cli_opts%sets_file, ONEMOD, NUMPAR, APAR) + endif - ! set random seed - ISEED = 1 + ! run FUSE + CALL FUSE_EVALUATE(APAR, info, work, domain, OUTPUT_FLAG, METRIC_VAL) - ! open up ASCII output file - print *, 'Creating SCE output file:', trim(FNAME_ASCII) - ISCE = 96; OPEN(ISCE,FILE=TRIM(FNAME_ASCII)) - ! set random seed - ISEED = 1 + ! ----- SCE calibration run ----------------------------------------------------------- - ! optimize (returns A and AF) - ! note that SCE requires the kind of APAR, BL, BU to be MSP - CALL SCEUA(APAR_MSP,AF_MSP,BL_MSP,BU_MSP,NOPT,MAXN,KSTOP,PCENTO,ISEED,& - NGS,NPG,NPS,NSPL,MINGS,INIFLG,IPRINT,ISCE) + case('sce') - ! close ASCII output file - CLOSE(ISCE) - - PRINT *, 'Done running SCE!' - - ! call the function again with the optimized parameter set (to ensure the last parameter set is the optimum) - !AF_MSP = FUNCTN(NOPT,AF_MSP) - - !PRINT *, 'Done calling the function again with the optimized parameter set!' - -ELSE IF(fuse_mode == 'run_best')THEN ! run FUSE with "best" parameter set from a previous SCE calibration - - OUTPUT_FLAG=.TRUE. - - ! load best SCE parameter set from NetCDF file into APAR - CALL GET_SCE_PARAM(FNAME_NETCDF_PARA_SCE,ONEMOD,NUMPAR,APAR) - - print *, 'Running FUSE with best SCE parameter set' - CALL FUSE_METRIC(APAR,GRID_FLAG,NCID_FORC,METRIC_VAL,OUTPUT_FLAG,NUMPSET) - print *, 'Done running FUSE with best SCE parameter set' - -ELSE - -print *, 'Unexpected fuse_mode!' -stop - -ENDIF + call sce_driver(info, work, domain, APAR, BL, BU) + case default + stop "cannot identify FUSE mode" + +end select ! (FUSE mode) + +! ----- finalize ------------------------------------------------------------------------ + ! deallocate space -DEALLOCATE(APAR,BL,BU,URAND) - -IF(SPATIAL_OPTION == 'CATCH')THEN - DEALLOCATE(aForce,aRoute,aValid) - !if(err/=0)then; write(*,*) 'unable to deallocate space for catchment modeling'; stop; endif +DEALLOCATE(APAR, BL, BU, stat=err) +if(err/=0)then; write(*,*) 'unable to deallocate space for parameter vectors'; stop; endif -ELSE - DEALLOCATE(gForce, gState) - !DEALLOCATE(ancilF_3d, gForce_3d, gState_3d,AROUTE_3d) - DEALLOCATE(gForce_3d, gState_3d,AROUTE_3d) - !if(err/=0)then; write(*,*) 'unable to deallocate space for grid modeling'; stop; endif +DEALLOCATE(aForce, aRoute, aValid, stat=err) +if(err/=0)then; write(*,*) 'unable to deallocate space for catchment modeling'; stop; endif -ENDIF +DEALLOCATE(gForce_3d, gState_3d, AROUTE_3d, stat=err) +if(err/=0)then; write(*,*) 'unable to deallocate space for grid modeling'; stop; endif ! close NetCDF files -IF(GRID_FLAG)THEN - PRINT *, 'Closing forcing file' - err = nf90_close(ncid_forc) - !if (err.ne.0) write(*,*) trim(message); if (err.gt.0) stop -ENDIF +PRINT *, 'Closing forcing file' +err = nf90_close(info%files%ncid_forc) +if(err/=0)then; message=trim(message)//' nf90_close failed: '//trim(nf90_strerror(err)); return; endif PRINT *, 'Closing output file' err = nf90_close(ncid_out) -!if (err.ne.0) write(*,*) trim(message); if (err.gt.0) stop +if(err/=0)then; message=trim(message)//' nf90_close failed: '//trim(nf90_strerror(err)); return; endif + PRINT *, 'Done' +STOP + +! --------------------------------------------------------------------------------------- +! --------------------------------------------------------------------------------------- +! --------------------------------------------------------------------------------------- + +contains +! ----- MPI checker --------------------------------------------------------------------- + +subroutine mpi_check(ierr, callee) #ifdef __MPI__ -call MPI_Finalize(mpi_error_value) + use mpi #endif + implicit none + integer(i4b), intent(in) :: ierr + character(len=*), intent(in) :: callee +#ifdef __MPI__ + integer(i4b) :: slen, ierr2 + character(len=256) :: errstr + if (ierr /= MPI_SUCCESS) then + call MPI_Error_string(ierr, errstr, slen, ierr2) + write(*,*) "MPI error at ", trim(callee), ": ", trim(errstr(1:slen)) + call MPI_Abort(MPI_COMM_WORLD, ierr, ierr2) + end if +#else + ! serial build: do nothing +#endif +end subroutine mpi_check -STOP END PROGRAM DISTRIBUTED_DRIVER diff --git a/build/FUSE_SRC/driver/fuse_evaluate.f90 b/build/FUSE_SRC/driver/fuse_evaluate.f90 new file mode 100644 index 0000000..2cdcd84 --- /dev/null +++ b/build/FUSE_SRC/driver/fuse_evaluate.f90 @@ -0,0 +1,561 @@ +MODULE fuse_evaluate_module + + use nrtype + use multi_flux_types, only: fluxes + use info_types, only: fuse_info + use work_types, only: fuse_work + use data_types, only: domain_data + + IMPLICIT NONE + + CONTAINS + + SUBROUTINE fuse_evaluate(XPAR, info, work, domain, OUTPUT_FLAG, METRIC_VAL) + + ! --------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark, 2009 + ! Modified by Brian Henn to include snow model, 6/2013 + ! Modified by Nans Addor to enable grid-based modeling, 9/2016 + ! Modified by Cyril Thébault to allow different metrics as objective function, 2024 + ! Modified by Martyn Clark to call differentiable modeling routines, 12/2025 + ! Modified by Martyn Clark to simplify/refactor, 02/2026 + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! Calculate the metric chosen as objective function for single FUSE model and single parameter set + ! input: model parameter set + ! output: metric chosen as objective function + ! --------------------------------------------------------------------------------------- + + use nrtype + use globaldata,only: NPAR_SNOW, isPrint, nFUSE_eval + use model_defn,only: NSTATE + use multiparam,only: NUMPAR + use multiforce,only: nspat1, nspat2, numtim_sub + use multibands,only: N_BANDS, n_bands + use multistats,only: MSTATS, PCOUNT + use multi_flux,only: W_FLUX_3d + + IMPLICIT NONE + + ! input + REAL(SP),DIMENSION(:) , intent(in) :: XPAR ! model parameter set + type(fuse_info) , intent(in) :: info ! info structures (runtime settings etc.) + type(fuse_work) , intent(inout) :: work ! work structures that depend on npar/nState + type(domain_data) , intent(inout) :: domain ! the fuse domain structure that stores data arrays + LOGICAL(LGT) , intent(in) :: OUTPUT_FLAG ! .TRUE. if desire time series output + + ! output + REAL(SP),INTENT(OUT) :: METRIC_VAL ! metric + + ! error control + integer(i4b) :: err, ierr + character(len=1024) :: message + + ! timing + real(sp) :: t1, t2 + + ! --------------------------------------------------------------------------------------- + + ! allocate 3d data structure for fluxes + allocate(w_flux_3d(nspat1, nspat2, numtim_sub), stat=ierr) + if (ierr /= 0) stop "problem allocating w_flux_3d in fuse_evaluate" + + ! populate parameter structures and initialize states + call initialize_run(XPAR, work, ierr, message) + if (ierr /= 0) stop trim(message) + + ! initialize timing + CALL CPU_TIME(T1) + + ! run fuse for the entire time series + call run_time_loop(info, work, OUTPUT_FLAG, err, message) + if (err /= 0) stop trim(message) + + ! get timing information + CALL CPU_TIME(T2) + if(isPrint) WRITE(*,*) "TIME ELAPSED = ", t2-t1 + + ! calculate mean summary statistics + ! NOTE: .NOT.GRID_FLAG means catchment mode (lumped or distributed) + if( .not. info%space%grid_flag)then + + if(isPrint) PRINT *, 'Calculating performance metrics...' + CALL MEAN_STATS() + METRIC_VAL = MSTATS%METRIC_VAL + + write(*,'(i6,1x,a6,1x,f12.6,1x,a20,1x,f12.6)') nFUSE_eval, "NSE = ", MSTATS%NASH_SUTT, "; TIME ELAPSED = ", t2-t1 + !if(nFUSE_eval > 10) stop "checking results" + + endif ! if catchment mode (lumped or distributed) + + if(isPrint) PRINT *, 'Writing model statistics...' + CALL PUT_SSTATS(PCOUNT) + + ! deallocate output buffer + DEALLOCATE(W_FLUX_3d); IF (IERR.NE.0) STOP ' problem deallocating W_FLUX_3d in fuse_metric ' + + END SUBROUTINE fuse_evaluate + + ! ------------------------------------------------------------------------------------------------------------------- + ! ------------------------------------------------------------------------------------------------------------------- + + ! ------------------------------------------------------------------------------------------------------------------- + ! ----- private subroutine initialize_run: populate param sets and initialize states ------------------------------- + ! ------------------------------------------------------------------------------------------------------------------- + + subroutine initialize_run(xpar, work, err, message) + + use globaldata, only: isPrint, fracstate0 + use model_defn, only: SMODL + use model_defnames + + use multiparam, only: NUMPAR + use multiforce, only: nspat1, nspat2, DELTIM + use multistate, only: FSTATE, gState_3d + use multistats, only: PCOUNT + use multibands + + use par_derive_module, only: par_derive + use par_insert_module + use str_2_xtry_module + use xtry_2_str_module + use put_params_module, only: put_params + implicit none + + real(sp), dimension(:) , intent(in) :: xpar + type(fuse_work) , intent(inout) :: work + + integer(i4b) , intent(out) :: err + character(len=*) , intent(out) :: message + + integer(i4b) :: iSpat1, iSpat2, iBands + + err = 0 + message = "" + + ! increment parameter counter for model output + PCOUNT = PCOUNT + 1 + + ! add parameter set to the data structure + call put_parset(xpar) + if (isPrint) then + print *, 'Parameter set added to data structure:' + print *, xpar + end if + + ! compute derived model parameters (bucket sizes, etc.) + call par_derive(err, message) + if (err /= 0) then + write(*,*) trim(message) + stop + end if + + ! get elevation bands (if catchment) + Z_FORCING = Z_FORCING_grid(1,1) + MBANDS(:)%info = MBANDS_INFO_3d(1,1,:) + + if (isPrint) print *, 'Writing parameter values...' + call put_params(PCOUNT) + + ! initialize model states over the 2D gridded domain (1x1 in catchment mode) + do iSpat2 = 1, nSpat2 + do iSpat1 = 1, nSpat1 + call init_state(fracstate0) + call str_2_xtry(FSTATE, work%num%x0) + call xtry_2_str(work%num%x0, FSTATE) + gState_3d(iSpat1, iSpat2, 1) = FSTATE + end do + end do + if (isPrint) print *, 'Model states initialized over the 2D gridded domain' + + ! initialize elevation bands if snow module is on + if (isPrint) print *, 'N_BANDS =', N_BANDS + if (SMODL%iSNOWM == iopt_temp_index) then + + ! initialize template once + work%snow%sbands(:)%var%SWE = 0._sp + work%snow%sbands(:)%var%SNOWACCMLTN = 0._sp + work%snow%sbands(:)%var%SNOWMELT = 0._sp + work%snow%sbands(:)%var%DSWE_DT = 0._sp + + ! copy to every grid cell (legacy staging) + do iSpat2 = 1, nSpat2 + do iSpat1 = 1, nSpat1 + do iBands = 1, n_bands + MBANDS_VAR_4d(iSpat1, iSpat2, iBands, 1) = work%snow%sbands(iBands)%var%bands_var + end do + end do + end do + + if (isPrint) print *, 'Snow states initialized over the 2D gridded domain' + end if + + ! initialize summary statistics + timer + call init_stats() + + end subroutine initialize_run + + ! ------------------------------------------------------------------------------------------------------------------- + ! ------------------------------------------------------------------------------------------------------------------- + + ! ------------------------------------------------------------------------------------------------------------------- + ! ----- private subroutine run_time_loop: run fuse for the entire time series -------------------------------------- + ! ------------------------------------------------------------------------------------------------------------------- + + subroutine run_time_loop(info, work, output_flag, ierr, message) + + use globaldata, only: isPrint + use multiforce, only: timDat ! NOTE: used in legacy cides + use multiforce, only: nspat1, nspat2, DELTIM, sim_beg, sim_end, numtim_sub + use multistate, only: gState_3d + use multibands, only: MBANDS_VAR_4d + use time_utils, only: caldatss + use getPETgrid_module, only: getPETgrid + use get_gforce_module, only: get_gforce_3d + use put_output_module, only: put_output + + implicit none + + type(fuse_info) , intent(in) :: info ! info structures that include "everything" + type(fuse_work) , intent(inout) :: work ! work structures that depend on npar/nState + logical(lgt) , intent(in) :: output_flag + + integer(i4b) , intent(out) :: ierr + character(len=*) , intent(out) :: message + + ! time management + integer(i4b) :: sim_idx ! index of simulation: 1..numtim_sim + integer(i4b) :: sub_idx ! index of forcing slice: 1..chunk_len + integer(i4b) :: in_idx ! index of input NetCDF time axis: sim_beg..sim_end + integer(i4b) :: remaining ! # remaining data windows in simulation + integer(i4b) :: chunk_len ! # data windows in the sub-period + integer(i4b) :: chunk_start_in ! start-of-chunk index in the input file + integer(i4b) :: chunk_start_sim ! start-of-chunk index in the simulation + + ! locals + logical(lgt), parameter :: computePET = .false. + real(sp) :: dt_sub, dt_full + integer(i4b) :: iSpat1, iSpat2, iBands + + ierr = 0 + message = "run_time_loop/" + + ! This version of FUSE enables the user to load slices of the forcing + ! + ! FUSE1 used to access the input file at each time step, slowing operations + ! down over large domains on systems with slow I/O. The number of timesteps + ! of the slices is defined by the user in the filemanager. The default is + ! that the whole time period needed for the simulation is loaded, but + ! this can exceed memory capacity when large domains are processed. + + ! To overcome this, a subperiod (slice) of the forcing can be loaded in + ! memory and used to run FUSE. Then, the results are saved to the + ! output file, and the next slice of forcing is loaded. This enables FUSE to + ! run quicker than when forcing is loaded at each time step and grid point, + ! while also controlling memory usage. + + ! initialize model time step + dt_sub = DELTIM + dt_full = DELTIM + + ! initialise time indices for whole simulation and subperiod + sub_idx = 1 ! index in data subset + + ! ----- loop through chunks of data --------------------------------------------------------------------------------- + + in_idx = sim_beg + do while (in_idx <= sim_end) + + ! get the simulation index + sim_idx = in_idx - sim_beg + 1 + + ! ----------------------------------------------------------------------------------------------------------------- + ! ----- start of subperiod: load forcing -------------------------------------------------------------------------- + + ! determine length of current subperiod + remaining = sim_end - in_idx + 1 ! # remaining data windows in simulation + chunk_len = min(numtim_sub, remaining) ! # data windows in the sub-period + + ! save the start of the chunks (avoid arithmetic) + chunk_start_sim = in_idx - sim_beg + 1 ! start of chunk in simulation index space + chunk_start_in = in_idx ! start of chunk in input index space + + ! load forcing for desired period into gForce_3d + if(isPrint) PRINT *, 'New subperiod: loading forcing for ',chunk_len,' time steps' + call get_gforce_3d(info, chunk_start_in, chunk_len, ierr, message) + IF(ierr/=0) stop 'Error while extracting 3d forcing: '//trim(message) + if(isPrint) PRINT *, 'Forcing loaded. Running FUSE...' + + ! ----------------------------------------------------------------------------------------------------------------- + + ! ----------------------------------------------------------------------------------------------------------------- + ! ----- loop through data chunk (sub-period) ---------------------------------------------------------------------- + + do sub_idx = 1, chunk_len + + ! get indices in the input file (in_idx) and the simulation period (sim_idx) + in_idx = chunk_start_in + sub_idx - 1 + sim_idx = chunk_start_sim + sub_idx - 1 + + ! get the model time + call caldatss(info%time%jdate(in_idx), work%step%time%iy, work%step%time%im, work%step%time%id, & + work%step%time%ih, work%step%time%imin, work%step%time%dsec) + timDat = work%step%time ! NOTE: used in the legacy data structures + + ! compute potential ET + IF(computePET) CALL getPETgrid(ierr,message) + IF(ierr/=0) stop TRIM(message) + + ! loop through grid points and run the model for one time step + DO iSpat2=1,nSpat2 + DO iSpat1=1,nSpat1 + + ! run fuse for one grid cell + call advance_one_cell(work, sub_idx, iSpat1, iSpat2, dt_sub, dt_full, ierr, message) + if (ierr /= 0) stop trim(message) + + !if(sub_idx > 100) stop "check" + + END DO ! (looping thru 2nd spatial dimension) + END DO ! (looping thru 1st spatial dimension) + + end do ! looping through subperiod + + !stop "looping through time period" + + ! ----------------------------------------------------------------------------------------------------------------- + + ! ----------------------------------------------------------------------------------------------------------------- + ! ----- end of subperiod: write to output file and save states ---------------------------------------------------- + + if(isPrint) PRINT *, 'End of subperiod reached:' + + ! write model output + IF (OUTPUT_FLAG) THEN + if(isPrint) PRINT *, 'Write output for ',chunk_len,' time steps starting at indices', chunk_start_sim + CALL PUT_OUTPUT(work, chunk_start_sim, chunk_start_in, chunk_len) + if(isPrint) PRINT *, 'Done writing output' + ELSE + if(isPrint) PRINT *, 'OUTPUT_FLAG is set on FALSE, no output written' + END IF + + ! TODO: set gState_3d and MBANDS_VAR_4d to NA + + ! reinitialize states for next subperiod using last time step + gState_3d(:,:,1) = gState_3d(:,:,chunk_len+1) + MBANDS_VAR_4d(:,:,:,1) = MBANDS_VAR_4d(:,:,:,chunk_len+1) + + ! ----------------------------------------------------------------------------------------------------------------- + + ! update the index in the input file + in_idx = chunk_start_in + chunk_len + + END DO ! (loop through timesteps) + + end subroutine run_time_loop + + ! ------------------------------------------------------------------------------------------------------------------- + ! ------------------------------------------------------------------------------------------------------------------- + + ! ------------------------------------------------------------------------------------------------------------------- + ! ----- private subroutine advance_one_cell: run fuse for one grid cell --------------------------------------------- + ! ------------------------------------------------------------------------------------------------------------------- + + subroutine advance_one_cell(work, sub_idx, iSpat1, iSpat2, dt_sub, dt_full, err, message) + + ! switches / options + use globaldata, only: NA_VALUE_SP + use model_defn, only: SMODL, NSTATE + use model_defnames + use multiforce, only: DELTIM, gForce_3d, aForce, MFORCE, nspat1, nspat2 + use multistate, only: gState_3d, FSTATE, MSTATE + use multiroute, only: MROUTE, AROUTE_3d + use multibands + use multi_flux, only: W_FLUX, W_FLUX_3d + use set_all_module, only: SET_STATE, SET_FLUXES, SET_ROUTE + + ! state vector conversions + use str_2_xtry_module + use xtry_2_str_module + + ! differentiable + use get_bundle_module, only: get_bundle + use implicit_solve_module, only: implicit_solve + use update_swe_diff_module, only: update_swe_diff ! (only if you actually call it here) + use update_swe_diff_module, only: update_swe_diff ! ok to remove if unused + + ! original solver interface + use interfaceb, only: ode_int, fuse_solve + + ! diff-mode flags (make sure these names really live here in your tree) + use model_numerix, only: diff_mode, original, differentiable + + implicit none + + type(fuse_work) , intent(inout) :: work ! work structures that depend on npar/nState + integer(i4b) , intent(in) :: sub_idx, iSpat1, iSpat2 + real(sp) , intent(inout) :: dt_sub, dt_full + integer(i4b) , intent(out) :: err + character(len=*) , intent(out) :: message + + ! locals + integer(i4b) :: ierr + character(len=1024) :: cmessage + + err = 0 + message = "advance_one_cell/" + ierr = 0 + cmessage = "" + + ! --------------------------------------------------------------------------- + ! only run FUSE for grid points within domain defined by elev_mask + ! NOTE: you currently run when elev_mask is FALSE (keep as-is for BFB) + ! --------------------------------------------------------------------------- + if (.not. elev_mask(iSpat1,iSpat2)) then + + ! extract forcing for this grid cell and time step + MFORCE = gForce_3d(iSpat1,iSpat2,sub_idx) + + ! forcing sanity checks (keep behavior; convert STOP -> error return) + if (MFORCE%PPT < 0.0_sp) then + err=1; message='Negative precipitation in input file'; return + end if + if (MFORCE%PPT > 5000.0_sp) then + err=1; message='Precipitation greater than 5000 in input file'; return + end if + if (MFORCE%PET < 0.0_sp) then + err=1; message='Negative PET in input file'; return + end if + if (MFORCE%PET > 100.0_sp) then + err=1; message='PET greater than 100 in input file'; return + end if + if (MFORCE%TEMP < -100.0_sp) then + err=1; message='Temperature lower than -100 in input file'; return + end if + if (MFORCE%TEMP > 100.0_sp) then + err=1; message='Temperature greater than 100 in input file'; return + end if + + ! extract model states for this grid cell and time step + FSTATE = gState_3d(iSpat1,iSpat2,sub_idx) + MSTATE = FSTATE + call STR_2_XTRY(FSTATE, work%num%x0) + + ! initialize model fluxes + ! If INITFLUXES lives somewhere else in your tree, swap this line accordingly. + call INITFLUXES() + + ! populate fuse work structure (diff path only) + if (diff_mode == differentiable) call get_bundle(work) + + ! ------------------------- + ! snow module + ! ------------------------- + select case(SMODL%iSNOWM) + + case(iopt_temp_index) + + Z_FORCING = Z_FORCING_grid(iSpat1,iSpat2) + MBANDS(:)%info = MBANDS_INFO_3d(iSpat1,iSpat2,:) + MBANDS(:)%var = MBANDS_VAR_4d(iSpat1,iSpat2,:,sub_idx) + + if (diff_mode == differentiable) then + work%snow%z_forcing = Z_FORCING + work%snow%sbands(:)%info = MBANDS(:)%info + work%snow%sbands(:)%var%bands_var = MBANDS(:)%var + end if + + select case(diff_mode) + case(original) + call UPDATE_SWE(DELTIM) + case(differentiable) + call UPDATE_SWE_DIFF(work, DELTIM) + case default + err=1; message='advance_one_cell: cannot identify diff_mode (snow)'; return + end select + + case(iopt_no_snowmod) + call QRAINERROR() + + case default + err=1; message='advance_one_cell: unknown SMODL%iSNOWM option'; return + + end select + + ! ------------------------- + ! soil physics + ! ------------------------- + select case(diff_mode) + + case(original) + call ODE_INT(FUSE_SOLVE, work%num%x0, work%num%x1, dt_sub, dt_full, ierr, cmessage) + if (ierr /= 0) then + err=1; message=trim(cmessage); return + end if + !print*, 'original = ', mstate%watr_1, mstate%watr_2, w_flux%QSURF, w_flux%QBASE_2 + + case(differentiable) + call implicit_solve(work, work%num%x0, work%num%x1, nState, ierr, cmessage) + if (ierr /= 0) then + err=1; message=trim(cmessage); return + end if + W_FLUX = work%step%flux + + case default + err=1; message='advance_one_cell: cannot identify diff_mode (soil)'; return + + end select + + ! routing + call Q_OVERLAND() + if (MROUTE%Q_ROUTED < 0._sp) then + err=1; message='Q_ROUTED is less than zero'; return + end if + if (MROUTE%Q_ROUTED > 1000._sp) then + err=1; message='Q_ROUTED is enormous'; return + end if + + ! write back to 3D buffers + call XTRY_2_STR(work%num%x1, FSTATE) + gState_3d(iSpat1,iSpat2,sub_idx+1) = FSTATE + W_FLUX_3d(iSpat1,iSpat2,sub_idx) = W_FLUX + AROUTE_3d(iSpat1,iSpat2,sub_idx) = MROUTE + + if (SMODL%iSNOWM == iopt_temp_index) then + + if (diff_mode == differentiable) then + Z_FORCING = work%snow%z_forcing + MBANDS(:)%info = work%snow%sbands(:)%info + MBANDS(:)%var = work%snow%sbands(:)%var%bands_var + end if + + gState_3d(iSpat1,iSpat2,sub_idx+1)%SWE_TOT = sum(MBANDS(:)%var%SWE * MBANDS(:)%info%AF) + MBANDS_VAR_4d(iSpat1,iSpat2,:,sub_idx+1) = MBANDS(:)%var + + end if + + ! forcing diagnostics + aForce(sub_idx)%ppt = sum(gForce_3d(:,:,sub_idx)%ppt) / real(size(gForce_3d(:,:,sub_idx)), kind=sp) + aForce(sub_idx)%pet = sum(gForce_3d(:,:,sub_idx)%pet) / real(size(gForce_3d(:,:,sub_idx)), kind=sp) + + ! stats + call COMP_STATS() + + else + ! outside mask: NA fill + call SET_STATE(NA_VALUE_SP) + gState_3d(iSpat1,iSpat2,sub_idx) = FSTATE + + call SET_FLUXES(NA_VALUE_SP) + W_FLUX_3d(iSpat1,iSpat2,sub_idx) = W_FLUX + + call SET_ROUTE(NA_VALUE_SP) + AROUTE_3d(iSpat1,iSpat2,sub_idx) = MROUTE + end if + + end subroutine advance_one_cell + +END MODULE fuse_evaluate_module diff --git a/build/FUSE_SRC/driver/fuse_metric.f90 b/build/FUSE_SRC/driver/fuse_metric.f90 deleted file mode 100644 index fe1fdd1..0000000 --- a/build/FUSE_SRC/driver/fuse_metric.f90 +++ /dev/null @@ -1,376 +0,0 @@ -MODULE FUSE_METRIC_MODULE - IMPLICIT NONE - CONTAINS - SUBROUTINE FUSE_METRIC(XPAR,GRID_FLAG,NCID_FORC,METRIC_VAL,OUTPUT_FLAG,IPSET,MPARAM_FLAG) - - ! --------------------------------------------------------------------------------------- - ! Creator: - ! -------- - ! Martyn Clark, 2009 - ! Modified by Brian Henn to include snow model, 6/2013 - ! Modified by Nans Addor to enable grid-based modeling, 9/2016 - ! Modified by Cyril Thébault to allow different metrics as objective function, 2024 - ! --------------------------------------------------------------------------------------- - ! Purpose: - ! -------- - ! Calculate the metric chosen as objective function for single FUSE model and single parameter set - ! input: model parameter set - ! output: metric chosen as objective function - ! --------------------------------------------------------------------------------------- - - USE nrtype ! variable types, etc. - - ! data modules - USE model_defn, ONLY:NSTATE,SMODL ! number of state variables - USE model_defnames ! integer model definitions - USE globaldata, ONLY: isPrint ! flag for printing progress to screen - USE globaldata, only: nFUSE_eval ! number of fuse evaluations - USE multiparam, ONLY: LPARAM,NUMPAR,MPARAM ! list of model parameters - USE multiforce, ONLY: MFORCE,AFORCE,DELTIM,ISTART ! model forcing data - USE multiforce, ONLY: numtim_in, itim_in ! length of input time series and associated index - USE multiforce, ONLY: numtim_sim, itim_sim ! length of simulated time series and associated index - USE multiforce, ONLY: numtim_sub, itim_sub ! length of subperiod time series and associated index - USE multiforce, ONLY: numtim_sub_cur ! length of current subperiod - USE multiforce, ONLY: sim_beg,sim_end ! timestep indices - USE multiforce, ONLY: eval_beg,eval_end ! timestep indices - - USE multiforce, ONLY:nspat1,nspat2 ! spatial dimensions - USE multiforce, ONLY:ncid_var ! NetCDF ID for forcing variables - USE multiforce, ONLY:gForce,gForce_3d ! gridded forcing data - USE multistate, ONLY:fracstate0,TSTATE,MSTATE,FSTATE,& ! model states - HSTATE ! model states (continued) - USE multiforce, ONLY:NA_VALUE, NA_VALUE_SP ! NA_VALUE for the forcing - USE multistate, ONLY:gState,gState_3d ! gridded state variables - USE multiroute, ONLY:MROUTE,AROUTE,AROUTE_3d ! routed runoff - USE multistats, ONLY:MSTATS,PCOUNT,MOD_IX ! access model statistics; counter for param set - USE multi_flux ! model fluxes - USE multibands ! elevation bands for snow modeling - USE set_all_module - - ! code modules - USE time_io, ONLY:get_modtim ! get model time for a given time step - USE get_gforce_module, ONLY:get_gforce_3d ! get gridded forcing data for a range of time steps - USE getPETgrid_module, ONLY:getPETgrid ! get gridded PET - USE par_insert_module ! insert parameters into data structures - USE str_2_xtry_module ! provide access to the routine str_2_xtry - USE xtry_2_str_module ! provide access to the routine xtry_2_str - - ! interface blocks - USE interfaceb, ONLY:ode_int,fuse_solve ! provide access to FUSE_SOLVE through ODE_INT - - ! model numerix structures - USE model_numerix - USE fuse_deriv_module - USE fdjac_ode_module - IMPLICIT NONE - - ! input - REAL(SP),DIMENSION(:),INTENT(IN) :: XPAR ! model parameter set - LOGICAL(LGT), INTENT(IN) :: GRID_FLAG ! .TRUE. if running FUSE on a grid - INTEGER(I4B), INTENT(IN) :: NCID_FORC ! NetCDF ID for the forcing file - LOGICAL(LGT), INTENT(IN) :: OUTPUT_FLAG ! .TRUE. if desire time series output - INTEGER(I4B), INTENT(IN) :: IPSET ! index parameter set - LOGICAL(LGT), INTENT(IN), OPTIONAL :: MPARAM_FLAG ! .FALSE. (used to turn off writing statistics) - - ! output - REAL(SP),INTENT(OUT) :: METRIC_VAL ! value of the metric chosen as objective function - - ! internal - LOGICAL(lgt),PARAMETER :: computePET=.FALSE. ! flag to compute PET - REAL(SP) :: T1,T2 ! CPU time - INTEGER(I4B) :: iSpat1,iSpat2 ! loop through spatial dimensions - INTEGER(I4B) :: ibands ! loop through elevation bands - INTEGER(I4B) :: IPAR ! loop through model parameters - REAL(SP) :: DT_SUB ! length of sub-step - REAL(SP) :: DT_FULL ! length of time step - REAL(SP), DIMENSION(:), ALLOCATABLE :: STATE0 ! vector of model states at the start of the time step - REAL(SP), DIMENSION(:), ALLOCATABLE :: STATE1 ! vector of model states at the end of the time step - REAL(SP), DIMENSION(:,:), ALLOCATABLE :: J ! used to compute the Jacobian (just as a test) - REAL(SP), DIMENSION(:), ALLOCATABLE :: DSDT ! used to compute the ODE (just as a test) - INTEGER(I4B) :: ITEST,JTEST ! used to compute a grid of residuals - REAL(SP) :: TEST_A,TEST_B ! used to compute a grid of residuals - INTEGER(I4B) :: IERR ! error code - INTEGER(I4B), PARAMETER :: CLEN=1024 ! length of character string - INTEGER(I4B) :: ERR ! error code - CHARACTER(LEN=CLEN) :: MESSAGE ! error message - CHARACTER(LEN=CLEN) :: CMESSAGE ! error message of downwind routine - INTEGER(I4B),PARAMETER::UNT=6 !1701 ! 6 - - ! --------------------------------------------------------------------------------------- - ! allocate state vectors - ALLOCATE(STATE0(NSTATE),STATE1(NSTATE),STAT=IERR) - IF (IERR.NE.0) STOP ' problem allocating space for state vectors in fuse_metric ' - - ! increment parameter counter for model output - IF (.NOT.PRESENT(MPARAM_FLAG)) THEN - PCOUNT = PCOUNT + 1 - ELSE - IF (MPARAM_FLAG) PCOUNT = PCOUNT + 1 - ENDIF - - ! add parameter set to the data structure - CALL PUT_PARSET(XPAR) - PRINT *, 'Parameter set added to data structure:' - PRINT *, XPAR - - ! compute derived model parameters (bucket sizes, etc.) - CALL PAR_DERIVE(ERR,MESSAGE) - IF (ERR.NE.0) WRITE(*,*) TRIM(MESSAGE); IF (ERR.GT.0) STOP - - ! initialize model states over the 2D gridded domain (1x1 domain in catchment mode) - DO iSpat2=1,nSpat2 - DO iSpat1=1,nSpat1 - CALL INIT_STATE(fracState0) ! define FSTATE using fracState0 - gState_3d(iSpat1,iSpat2,1) = FSTATE ! put the state into first time step of 3D structure - END DO - END DO - PRINT *, 'Model states initialized over the 2D gridded domain' - - ! initialize elevations bands if snow module is on - PRINT *, 'N_BANDS =', N_BANDS - - IF (SMODL%iSNOWM.EQ.iopt_temp_index) THEN - DO iSpat2=1,nSpat2 - DO iSpat1=1,nSpat1 - DO IBANDS=1,N_BANDS - MBANDS_VAR_4d(iSpat1,iSpat2,IBANDS,1)%SWE=0.0_sp ! band snowpack water equivalent (mm) - MBANDS_VAR_4d(iSpat1,iSpat2,IBANDS,1)%SNOWACCMLTN=0.0_sp ! new snow accumulation in band (mm day-1) - MBANDS_VAR_4d(iSpat1,iSpat2,IBANDS,1)%SNOWMELT=0.0_sp ! snowmelt in band (mm day-1) - MBANDS_VAR_4d(iSpat1,iSpat2,IBANDS,1)%DSWE_DT=0.0_sp ! rate of change of band SWE (mm day-1) - END DO - END DO - END DO - PRINT *, 'Snow states initiatlized over the 2D gridded domain ' - ENDIF - - ! allocate 3d data structure for fluxes - ALLOCATE(W_FLUX_3d(nspat1,nspat2,numtim_sub)) - - ! initialize model time step - DT_SUB = DELTIM ! init stepsize to full step - DT_FULL = DELTIM ! init stepsize to full step - - ! initialize summary statistics - CALL INIT_STATS() - CALL CPU_TIME(T1) - - ! This version of FUSE enables the user to load slices of the forcing - ! - FUSE1 used to access the input file at each time step, slowing operations - ! down over large domains on systems with slow I/O. The number of timesteps - ! of the slices is defined by the user in the filemanager. The default is - ! that the whole time period needed for the simulation is loaded, but - ! this can exceed memory capacity when large domains are processed. - ! To overcome this, a subperiod (slice) of the forcing can be loaded in - ! memory and used to run FUSE. Then, the results are saved to the - ! output file, and the next slice of forcing is loaded. This enables FUSE to - ! run quicker than when forcing is loaded at each time step and grid point, - ! while also controlling memory usage. - - ! initialise time indices for whole simulation and subperiod - itim_sub = 1 - itim_sim = 1 - - ! loop through time steps of the input file (ITIM_IN) - DO ITIM_IN=sim_beg,sim_end - - ! if start of subperiod: load forcing - IF(itim_sub.EQ.1)THEN - - ! determine length of current subperiod - numtim_sub_cur=MIN(numtim_sub,numtim_sim-itim_sim+1) - - ! load forcing for desired period into gForce_3d - PRINT *, 'New subperiod: loading forcing for ',numtim_sub_cur,' time steps' - CALL get_gforce_3d(itim_in,numtim_sub_cur,ncid_forc,err,message) - IF(err/=0)THEN; WRITE(*,*) 'Error while extracting 3d forcing'; STOP; ENDIF - PRINT *, 'Forcing loaded. Running FUSE...' - - ENDIF - - ! get the model time - CALL get_modtim(itim_in,ncid_forc,ierr,message) - IF(ierr/=0)THEN; PRINT*, TRIM(cmessage); STOP; ENDIF - - ! compute potential ET - IF(computePET) CALL getPETgrid(ierr,cmessage) - IF(ierr/=0)THEN; PRINT*, TRIM(cmessage); STOP; ENDIF - - ! loop through grid points and run the model for one time step - DO iSpat2=1,nSpat2 - DO iSpat1=1,nSpat1 - - ! only run FUSE for grid points within domain defined by elev_mask - IF(.NOT.elev_mask(iSpat1,iSpat2))THEN - - ! FUSE works with MFORCE, MSTATE, MBANDS, W_FLUX, MROUTE, which are all scalars. - ! Here we transfer forcing, state, flux variables from the 3D structures to these - ! variables, run FUSE and then transfer the new values back to the 3D structures. - - ! extract forcing for this grid cell and time step - MFORCE = gForce_3d(iSpat1,iSpat2,itim_sub) - - ! forcing sanity checks - if(MFORCE%PPT.lt.0.0) then; PRINT *, 'Negative precipitation in input file:',iSpat1,iSpat2,MFORCE%PPT; stop; endif - if(MFORCE%PPT.gt.5000.0) then; PRINT *, 'Precipitation greater than 5000 in input file:',iSpat1,iSpat2,MFORCE%PPT; stop; endif - if(MFORCE%PET.lt.0.0) then; PRINT *, 'Negative PET in input file'; stop; endif - if(MFORCE%PET.gt.100.0) then; PRINT *, 'PET greater than 100 in input file'; stop; endif - if(MFORCE%TEMP.lt.-100.0) then; PRINT *, 'Temperature lower than -100 in input file'; stop; endif - if(MFORCE%TEMP.gt.100.0) then; PRINT *, 'Temperature greater than 100 in input file'; stop; endif - - ! extract model states for this grid cell and time step - FSTATE = gState_3d(iSpat1,iSpat2,itim_sub) - MSTATE = FSTATE ! refresh model states - CALL STR_2_XTRY(FSTATE,STATE0) ! set state at the start of the time step (STATE0) using FSTATE - - ! initialize model fluxes - CALL INITFLUXES() ! set weighted sum of fluxes to zero - - ! if snow model is on, call UPDATE_SWE to calculate snow fluxes and update snow bands - ! using explicit Euler approach; if not, call QRAINERROR - SELECT CASE(SMODL%iSNOWM) - CASE(iopt_temp_index) - - ! load data from multidimensional arrays - Z_FORCING = Z_FORCING_grid(iSpat1,iSpat2) ! elevation of forcing data (m) - MBANDS%Z_MID = MBANDS_INFO_3d(iSpat1,iSpat2,:)%Z_MID ! band mid-point elevation (m) - MBANDS%AF = MBANDS_INFO_3d(iSpat1,iSpat2,:)%AF ! fraction of basin area in band (-) - MBANDS%SWE = MBANDS_VAR_4d(iSpat1,iSpat2,:,itim_sub)%SWE ! band snowpack water equivalent (mm) - MBANDS%SNOWACCMLTN = MBANDS_VAR_4d(iSpat1,iSpat2,:,itim_sub)%SNOWACCMLTN ! new snow accumulation in band (mm day-1) - MBANDS%SNOWMELT = MBANDS_VAR_4d(iSpat1,iSpat2,:,itim_sub)%SNOWMELT ! snowmelt in band (mm day-1) - MBANDS%DSWE_DT = MBANDS_VAR_4d(iSpat1,iSpat2,:,itim_sub)%DSWE_DT ! rate of change of band SWE (mm day-1) - - CALL UPDATE_SWE(DELTIM) - - CASE(iopt_no_snowmod) - CALL QRAINERROR() - CASE DEFAULT - message="f-fuse_metric/SMODL%iSNOWM must be either iopt_temp_index or iopt_no_snowmod" - RETURN - END SELECT - - ! temporally integrate the ordinary differential equations - CALL ODE_INT(FUSE_SOLVE,STATE0,STATE1,DT_SUB,DT_FULL,IERR,MESSAGE) - IF (IERR.NE.0) THEN - PRINT *, TRIM(MESSAGE) - !PAUSE - ENDIF - - ! perform overland flow routing - CALL Q_OVERLAND() - - ! runoff sanity check - IF (MROUTE%Q_ROUTED.LT.0._sp) STOP 'Q_ROUTED is less than zero' - IF (MROUTE%Q_ROUTED.GT.1000._sp) STOP 'Q_ROUTED is enormous' - - ! transfer simulations to corresponding 3D structures - ! note that the first time step of gState_3d and MBANDS_VAR_4d is defined by initialisation - ! or simulation over previous subperiod, so saving in itim_sub+1 - and hence, the allocated - ! length of the temporal dimension of gState_3d and MBANDS_VAR_4d is numtim_sub+1, - ! but numtim_sub for W_FLUX_3d and AROUTE_3d - - CALL XTRY_2_STR(STATE1,FSTATE) ! update FSTATE using states at the end of the time step (STATE1) - gState_3d(iSpat1,iSpat2,itim_sub+1) = FSTATE ! transfer FSTATE into the 3-d structure - W_FLUX_3d(iSpat1,iSpat2,itim_sub) = W_FLUX ! fluxes - AROUTE_3d(iSpat1,iSpat2,itim_sub) = MROUTE ! instantaneous and routed runoff - - IF (SMODL%iSNOWM.EQ.iopt_temp_index) THEN - - ! SWE TOT: weighted average of SWE over all the elevation bands - gState_3d(iSpat1,iSpat2,itim_sub+1)%SWE_TOT = SUM(MBANDS%SWE*MBANDS_INFO_3d(iSpat1,iSpat2,:)%AF) - - ! update MBANDS_VAR_4D - MBANDS_VAR_4d(iSpat1,iSpat2,:,itim_sub+1)%SWE = MBANDS%SWE - MBANDS_VAR_4d(iSpat1,iSpat2,:,itim_sub+1)%SNOWACCMLTN = MBANDS%SNOWACCMLTN - MBANDS_VAR_4d(iSpat1,iSpat2,:,itim_sub+1)%SNOWMELT = MBANDS%SNOWMELT - MBANDS_VAR_4d(iSpat1,iSpat2,:,itim_sub+1)%DSWE_DT = MBANDS%DSWE_DT - - END IF - - ! save forcing data to export to output file - IF(GRID_FLAG)THEN - aForce(itim_sub)%ppt = SUM(gForce_3d(:,:,itim_sub)%ppt)/REAL(SIZE(gForce_3d(:,:,itim_sub)), KIND(sp)) - aForce(itim_sub)%pet = SUM(gForce_3d(:,:,itim_sub)%pet)/REAL(SIZE(gForce_3d(:,:,itim_sub)), KIND(sp)) - ENDIF - - ! compute summary statistics - CALL COMP_STATS() - - ELSE ! insert NA values if grid point outside of domain or forcing not available - - CALL SET_STATE(NA_VALUE_SP) ! includes FSTATE%SWE_TOT - gState_3d(iSpat1,iSpat2,itim_sub) = FSTATE - - CALL SET_FLUXES(NA_VALUE_SP) - W_FLUX_3d(iSpat1,iSpat2,itim_sub) = W_FLUX - - CALL SET_ROUTE(NA_VALUE_SP) - AROUTE_3d(iSpat1,iSpat2,itim_sub) = MROUTE - - ENDIF ! (is grid cell in mask_elev?) - END DO ! (looping thru 2nd spatial dimension) - END DO ! (looping thru 1st spatial dimension) - - ! if end of subperiod: write to output file and save states - IF(itim_sub.EQ.numtim_sub_cur)THEN - - PRINT *, 'End of subperiod reached:' - - ! write model output - IF (OUTPUT_FLAG) THEN - PRINT *, 'Write output for ',numtim_sub_cur,' time steps starting at indice', itim_sim-numtim_sub_cur+1 - CALL PUT_GOUTPUT_3D(itim_sim-numtim_sub_cur+1,itim_in-numtim_sub_cur+1,numtim_sub_cur,IPSET) - PRINT *, 'Done writing output' - ELSE - PRINT *, 'OUTPUT_FLAG is set on FALSE, no output written' - END IF - - ! TODO: set gState_3d and MBANDS_VAR_4d to NA - - ! reinitialize states for next subperiod using last time step - gState_3d(:,:,1) = gState_3d(:,:,itim_sub+1) - MBANDS_VAR_4d(:,:,:,1)%SWE = MBANDS_VAR_4d(:,:,:,itim_sub+1)%SWE - MBANDS_VAR_4d(:,:,:,1)%SNOWACCMLTN = MBANDS_VAR_4d(:,:,:,itim_sub+1)%SNOWACCMLTN - MBANDS_VAR_4d(:,:,:,1)%SNOWMELT = MBANDS_VAR_4d(:,:,:,itim_sub+1)%SNOWMELT - MBANDS_VAR_4d(:,:,:,1)%DSWE_DT = MBANDS_VAR_4d(:,:,:,itim_sub+1)%DSWE_DT - - ! reset itim_sub - itim_sub=1 - - ELSE ! not the end of subperiod - - ! increment itim_sub - itim_sub=itim_sub+1 - - END IF - - ! increment itim_sim - itim_sim=itim_sim+1 - - END DO ! (loop through timesteps) - - ! get timing information - CALL CPU_TIME(T2) - WRITE(*,*) "TIME ELAPSED = ", t2-t1 - - ! calculate mean summary statistics - IF(.NOT.GRID_FLAG)THEN - - PRINT *, 'Calculating performance metrics...' - CALL MEAN_STATS() - METRIC_VAL = MSTATS%METRIC_VAL - - write(*,'(i6,1x,a12,1x,f12.6)') nFUSE_eval, "METRIC_VAL =", METRIC_VAL - - ENDIF - - PRINT *, 'Writing parameter values...' - CALL PUT_PARAMS(PCOUNT) - PRINT *, 'Writing model statistics...' - CALL PUT_SSTATS(PCOUNT) - - ! deallocate vectors - DEALLOCATE(W_FLUX_3d); IF (IERR.NE.0) STOP ' problem deallocating W_FLUX_3d in fuse_metric ' - DEALLOCATE(STATE0,STATE1,STAT=IERR); IF (IERR.NE.0) STOP ' problem deallocating state vectors in fuse_metric' - - END SUBROUTINE FUSE_METRIC -END MODULE FUSE_METRIC_MODULE diff --git a/build/FUSE_SRC/driver/sce_callback_context.f90 b/build/FUSE_SRC/driver/sce_callback_context.f90 new file mode 100644 index 0000000..1a74af6 --- /dev/null +++ b/build/FUSE_SRC/driver/sce_callback_context.f90 @@ -0,0 +1,33 @@ +module sce_callback_context + use info_types, only: fuse_info + use data_types, only: domain_data + use work_types, only: fuse_work + implicit none + private + public :: ctx + public :: set_sce_context, clear_sce_context + + type :: sce_context + type(fuse_info), pointer :: info => null() + type(fuse_work), pointer :: work => null() + type(domain_data), pointer :: domain => null() + end type sce_context + + type(sce_context), save :: ctx + +contains + + subroutine set_sce_context(info, work, domain) + type(fuse_info), target, intent(inout) :: info + type(fuse_work), target, intent(inout) :: work + type(domain_data), target, intent(inout) :: domain + ctx%info => info + ctx%work => work + ctx%domain => domain + end subroutine + + subroutine clear_sce_context() + nullify(ctx%info, ctx%work, ctx%domain) + end subroutine + +end module sce_callback_context diff --git a/build/FUSE_SRC/driver/sce_driver.f90 b/build/FUSE_SRC/driver/sce_driver.f90 new file mode 100644 index 0000000..27475e9 --- /dev/null +++ b/build/FUSE_SRC/driver/sce_driver.f90 @@ -0,0 +1,101 @@ +module sce_driver_MODULE + + USE nrtype + use info_types, only: fuse_info + use work_types, only: fuse_work + use data_types, only: domain_data + + use sce_callback_context, only: set_sce_context, clear_sce_context + + implicit none + + private + public :: sce_driver + +contains + + subroutine sce_driver(info, work, domain, APAR, BL, BU) + USE multiparam, only: MAXN ! maximum number of trials before optimization is terminated + USE multiparam, only: KSTOP ! number of shuffling loops the value must change by PCENTO + USE multiparam, only: PCENTO ! the percentage + USE multiparam, only: NUMPAR ! # parameters + USE globaldata, only: isPrint ! used to turn of printing for calibration runs + USE globaldata, only: nFUSE_eval ! # FUSE evaluations + USE model_defn, only: FNAME_TEMPRY, FNAME_ASCII + implicit none + ! input/output + type(fuse_info) , intent(inout) :: info ! info structures (runtime settings etc.) + type(fuse_work) , intent(inout) :: work ! work structures that depend on npar/nState + type(domain_data) , intent(inout) :: domain ! the fuse domain structure that stores data arrays + real(sp) , intent(in) :: APAR(:) ! model parameter set + real(sp) , intent(in) :: BL(:) ! vector of lower parameter bounds + real(sp) , intent(in) :: BU(:) ! vector of upper parameter bounds + ! internal variables + REAL(MSP) :: AF_MSP ! objective function value + REAL(MSP), DIMENSION(:), ALLOCATABLE :: APAR_MSP ! ! lower bound of model parameters + REAL(MSP), DIMENSION(:), ALLOCATABLE :: BL_MSP ! ! lower bound of model parameters + REAL(MSP), DIMENSION(:), ALLOCATABLE :: BU_MSP ! ! upper bound of model parameters + REAL(MSP), DIMENSION(:), ALLOCATABLE :: URAND_MSP ! vector of quasi-random numbers U[0,1] + INTEGER(I4B) :: NOPT ! number of parameters to be optimized + INTEGER(I4B) :: NGS ! # complexes in the initial population + INTEGER(I4B) :: NPG ! # points in each complex + INTEGER(I4B) :: NPS ! # points in a sub-complex + INTEGER(I4B) :: NSPL ! # evolution steps allowed for each complex before shuffling + INTEGER(I4B) :: MINGS ! minimum number of complexes required + INTEGER(I4B) :: INIFLG ! 1 = include initial point in the population + INTEGER(I4B) :: IPRINT ! 0 = supress printing + INTEGER(I4B) :: ISCE ! unit number for SCE write + integer(i4b) :: NUMPSET ! number of parameter sets + REAL(MSP) :: FUNCTN ! function name for the model run + INTEGER(KIND=4) :: ISEED ! seed for the random sequence + + NOPT = NUMPAR ! number of parameters to be optimized (NUMPAR in module multiparam) + NGS = 10 ! number of complexes in the initial population + NPG = 2*NOPT + 1 ! number of points in each complex + NPS = NOPT + 1 ! number of points in a sub-complex + NSPL = 2*NOPT + 1 ! number of evolution steps allowed for each complex before shuffling + MINGS = NGS ! minimum number of complexes required + INIFLG = 1 ! 1 = include initial point in the population + IPRINT = 1 ! 0 = supress printing + + NUMPSET=1.2*MAXN ! will be used to define the parameter set dimension of the NetCDF files + ! using 1.2MAXN since the final number of parameter sets produced by SCE is unknown + + ! convert from SP used in FUSE to MSP used in SCE + ALLOCATE(APAR_MSP(NUMPAR), BL_MSP(NUMPAR), BU_MSP(NUMPAR)) + APAR_MSP=APAR; BL_MSP=BL; BU_MSP=BU + + ! pass the FUSE structures to the context setter + ! NOTE: in sce_context_set, info/work/domain have the target attribute so can point to them + call set_sce_context(info, work, domain) + + ! open up ASCII output file + ISCE = 96 ! (file unit) + FNAME_ASCII = trim(FNAME_TEMPRY)//'_sce_output.txt' + print *, 'Creating SCE output file:', trim(FNAME_ASCII) + OPEN(96, FILE=TRIM(FNAME_ASCII) ) + + ! printing + isPrint = .false. ! turn off printing to screen + nFUSE_eval = 0 ! number of fuse evaluations + + ! set random seed + ISEED = 1 + + ! optimize (returns A and AF) + ! note that SCE requires the kind of APAR, BL, BU to be MSP + CALL SCEUA(APAR_MSP,AF_MSP,BL_MSP,BU_MSP,NOPT,MAXN,KSTOP,PCENTO,ISEED,& + NGS,NPG,NPS,NSPL,MINGS,INIFLG,IPRINT,ISCE) + + ! close ASCII output file + CLOSE(ISCE) + + ! nullify pointers in the context setter + call clear_sce_context() + + ! deallocate space for real32 vectors + DEALLOCATE(APAR_MSP, BL_MSP, BU_MSP) + + end subroutine sce_driver + +end module sce_driver_MODULE diff --git a/build/FUSE_SRC/driver/setup_domain.f90 b/build/FUSE_SRC/driver/setup_domain.f90 new file mode 100644 index 0000000..d1f02da --- /dev/null +++ b/build/FUSE_SRC/driver/setup_domain.f90 @@ -0,0 +1,122 @@ +module setup_domain_module + + USE nrtype + USE info_types, only: cli_options + USE info_types, only: fuse_info + USE data_types, only: domain_data + USE globaldata, only: isPrint + + implicit none + + private + public :: setup_domain + +contains + + subroutine setup_domain(opts, info, domain, ierr, message) + + ! access subroutines + use netcdf, only: nf90_open, nf90_nowrite, nf90_strerror ! NetCDF functions + USE fuse_fileManager, only: read_fuse_control_file ! sets directories and filenames + + USE domain_dims_module, only: get_domain_dims ! get nx, ny, nt, and nbands + USE domain_decomp_module, only: get_domain_decomp_indices ! get MPI domain decomposition indices + + USE time_windows_module, only: get_time_windows ! get info on the rolling time windows + USE time_windows_module, only: export_time_to_multiforce ! populate legacy multiforce modules + + USE get_gforce_module, only: get_forcing_varids ! get name/varid table for forcing variables + USE get_gforce_module, only: read_latlon_2d ! read lat/lon + USE read_elevbands_module, only: read_elevbands ! read elevation bands + + USE alloc_domain_module, only: allocate_domain_data ! allocate space for data arrays in the domain structure + USE alloc_domain_module, only: set_legacy_arrays ! copy arrays in the domain%data structure to legacy arrays + + implicit none + + ! input + type(cli_options) , intent(in) :: opts ! command line interface options + type(fuse_info) , intent(inout) :: info ! domain info + type(domain_data) , intent(inout) :: domain ! domain data + + ! output + integer(i4b) , intent(out) :: ierr ! error code + character(len=1024) , intent(out) :: message ! error message + + ! ----- internal ----------------------------------------------------------------------- + CHARACTER(LEN=1024) :: CMESSAGE ! error message + ! --------------------------------------------------------------------------------------- + ierr=0; message='setup_domain/' + + ! ----- set paths and file names -------------------------------------------------------- + + ! read fuse control file (set paths/filenames etc.) + call read_fuse_control_file(trim(opts%control_file), opts, info, ierr, cmessage) + if (ierr/=0)then; message=trim(message)//trim(cmessage); ierr=20; return; endif + + ! ----- read domain metadata ------------------------------------------------------------ + + ! populate domain structure with dimension lengths + ! -- nx_global, ny_global, nt_global, n_bands + call get_domain_dims(info, ierr, cmessage) + if (ierr/=0)then; message=trim(message)//trim(cmessage); ierr=20; return; endif + + ! get indices for MPI decomposition of the spatial domain: y_start_global, ny_local + ! NOTE: These indices will be used later to read different subsets of forcing data for different ranks + call get_domain_decomp_indices(info) + + ! ----- read grid info and define indices for MPI domain decomposition ------------------ + + ! open NetCDF forcing file + ierr = nf90_open(trim(info%files%fname_netcdf_forc), nf90_nowrite, info%files%ncid_forc) + if (ierr/=0)then; message=trim(message)//' nf90_open failed: '//trim(nf90_strerror(ierr)); return; endif + if(isPrint) print *, 'Open forcing file:', trim(info%files%fname_netcdf_forc) + if(isPrint) PRINT *, 'NCID_FORC is', info%files%ncid_forc + + ! ----- Compute time indices for sim/eval windows and subperiod chunk size -------------- + ! + ! Reads the forcing-file NetCDF time coordinate (and units), and: + ! - builds a Julian-day time axis and timestep in days + ! - maps the user-specified simulation/evaluation date ranges into index windows + ! (and optional subperiod chunks) stored in info%time + call get_time_windows(info%files%ncid_forc, info, ierr, cmessage) + if (ierr/=0)then; message=trim(message)//trim(cmessage); ierr=20; return; endif + + ! ----- Allocate space for domain data -------------------------------------------------- + + ! allocate space for the arrays in the domain%data structure + call allocate_domain_data(info, domain, ierr, cmessage) + if (ierr/=0)then; message=trim(message)//trim(cmessage); ierr=20; return; endif + + ! ----- Read lat/lon, elevation band arrays, and forcing var ids ----------------------- + + ! read lat/lon and store in the domain%data%coords structure + call read_latlon_2d(info%files%ncid_forc, info, domain%coords, ierr, message) + if (ierr/=0)then; message=trim(message)//trim(cmessage); ierr=20; return; endif + + ! read elevation bands information and store in the domain%data structure + call read_elevbands(info, domain, ierr, cmessage) + if (ierr/=0)then; message=trim(message)//trim(cmessage); ierr=20; return; endif + + call get_forcing_varids(info%files%ncid_forc, info, ierr, cmessage) + if (ierr/=0)then; message=trim(message)//trim(cmessage); ierr=20; return; endif + + ! ----- Routines that use the old structures -------------------------------------------- + + ! copy arrays in the domain structure to legacy arrays + call set_legacy_arrays(info, domain, ierr, cmessage) + if (ierr/=0)then; message=trim(message)//trim(cmessage); ierr=20; return; endif + + ! defines method/parameters used for numerical solution based on numerix file + ! NOTE: This routine supports the legacy FUSE v1 numerics experiments + CALL GETNUMERIX(IERR,CMESSAGE) + if (ierr/=0)then; message=trim(message)//trim(cmessage); ierr=20; return; endif + + print*, 'end of setup_domain' + + end subroutine setup_domain + + ! ------------------------------------------------------------------------------------- + ! ------------------------------------------------------------------------------------- + +end module setup_domain_module diff --git a/build/FUSE_SRC/driver/setup_model_definition.f90 b/build/FUSE_SRC/driver/setup_model_definition.f90 new file mode 100644 index 0000000..ce47233 --- /dev/null +++ b/build/FUSE_SRC/driver/setup_model_definition.f90 @@ -0,0 +1,141 @@ +module setup_model_definition_MODULE + + USE nrtype + USE info_types, only: fuse_info + USE info_types, only: cli_options + USE data_types, only: domain_data + USE multiparam_types, only: PARATT + + implicit none + + private + public :: setup_model_definition + +contains + + subroutine setup_model_definition(opts, info, domain, APAR, BL, BU, err, message) + + ! access subroutines + use uniquemodl_module, only: uniquemodl ! Defines unique strings for all FUSE models + use GETPARMETA_module, only: GETPARMETA ! Reads parameter metadata from the parameter constraints file + use selectmodl_module, only: selectmodl ! reads model control file + use ASSIGN_STT_module, only: ASSIGN_STT ! state definitions: data are stored in module model_defn + use ASSIGN_FLX_module, only: ASSIGN_FLX ! flux definitions: data are stored in module model_defn + use ASSIGN_PAR_module, only: ASSIGN_PAR ! parameter definitions: data are stored in module multiparam + use PAR_DERIVE_module, only: PAR_DERIVE ! Compute derived model parameters (bucket sizes, etc.) + USE DEF_SSTATS_MODULE, only: DEF_SSTATS ! define summary statistics + USE DEF_PARAMS_MODULE, only: DEF_PARAMS ! define model parameters + USE DEF_OUTPUT_MODULE, only: DEF_OUTPUT ! define model output + USE getpar_str_module, only: GETPAR_STR ! extracts parameter metadata + + ! data stored in legacy modules + USE model_defn, only: NSTATE ! number of state variables + USE multiparam, only: NUMPAR ! number of paramters for the current model + USE multiparam, only: LPARAM ! list of model parameters + USE multiparam, only: MAXN ! maximum number of function evaluations in SCE -- used for NUMPSET + USE multiforce, only: NUMPSET ! number of model parameter sets + + implicit none + + ! input + type(cli_options) , intent(in) :: opts ! command line interface options + type(fuse_info) , intent(inout) :: info ! the fuse info structure that stores "everything" + type(domain_data) , intent(in) :: domain ! the fuse domain structure that stores data arrays + + ! output + real(sp) , intent(out) , allocatable :: aPar(:) ! parameter vector + real(sp) , intent(out) , allocatable :: BL(:), BU(:) ! parameter bounds + integer(i4b) , intent(out) :: err ! error code + character(len=1024) , intent(out) :: message ! error message + + ! ----- internal ----------------------------------------------------------------------- + INTEGER(I4B) :: IPAR ! parameter index + INTEGER(I4B) :: NMOD ! number of models + TYPE(PARATT) :: PARAM_META ! parameter metadata (model parameters) + CHARACTER(LEN=1024) :: CMESSAGE ! error message + ! ----- output dimensions -------------------------------------------------------------- + integer(i4b) :: nx, ny, nt, nb, nSet, nPar + ! --------------------------------------------------------------------------------------- + associate(fmodel_id => info%config%fmodel_id) ! use info as truth where possible + ! --------------------------------------------------------------------------------------- + err=0; message='setup_model_definition/' + + ! ----- define characteristics of the current model ------------------------------------- + + ! Define model attributes (valid for all models) + CALL UNIQUEMODL(NMOD) ! get nmod unique models: stored in module model_defn; NMOD is intent(out) + CALL GETPARMETA(ERR,CMESSAGE) ! read parameter metadata from constraints txt file (parameter bounds etc.) + if (err/=0)then; message=trim(message)//trim(cmessage); err=20; return; endif + + ! Identify a single model: FMODEL_ID is read from the control file and used to build string for zDecisions + CALL SELECTMODL(FMODEL_ID,ERR=ERR,MESSAGE=CMESSAGE) ! FMODEL_ID is intent(in) + if (err/=0)then; message=trim(message)//trim(cmessage); err=20; return; endif + + ! Define list of states and parameters for the current model + ! NOTE: these definitions are global, so OK to be stored in a shared module + CALL ASSIGN_STT() ! state definitions are stored in module model_defn + CALL ASSIGN_FLX() ! flux definitions are stored in module model_defn + CALL ASSIGN_PAR() ! parameter definitions are stored in module multiparam + + ! save information in global data structures + info%config%nState = NSTATE ! NSTATE is in module model_defn + info%config%nParam = NUMPAR ! NSTATE is in module multiparam + info%config%listParam = LPARAM(1:NUMPAR) ! (performs allocation) LPARAM is in module multiparam + + ! Compute derived model parameters (bucket sizes, etc.) + CALL PAR_DERIVE(ERR,CMESSAGE) + if (err/=0)then; message=trim(message)//trim(cmessage); err=20; return; endif + + ! ----- initialize parameters, statistics, and output ----------------------------------- + + ! get number of parameter sets + ! will be used to define the parameter set dimension of the NetCDF files + select case(trim(opts%runmode)) + + ! options that run with a single parameter set + case('def', 'idx', 'opt'); NUMPSET = 1 + + ! use NUMPSET =1.2MAXN since final number of parameter sets produced by SCE is unknown + case('sce'); NUMPSET = int(1.2_sp * real(MAXN, sp)) + + ! check + case default + message=trim(message)//'opts%runmode is unknown: '//trim(opts%runmode) + err=20; return + + end select + + ! save the number of parameter sets in the global info structure + info%config%nSets = NUMPSET + + ! define NetCDF files + + ! assign dimensions (use info structure for provenance/clarity) + + nx = info%space%nx_local ! NOTE: local to rank (MPI parallelization) + ny = info%space%ny_local + nt = info%time%nt_window + nb = info%snow%n_bands + + nSet = info%config%nSets + nPar = info%config%nParam + + CALL DEF_PARAMS(nSet) ! define model parameters + CALL DEF_OUTPUT(domain%coords,nx,ny,nb,nPar) ! define model output time series (nPar used for parameter derivatives) + CALL DEF_SSTATS() ! define summary statistics (REDEF) + + ! get parameter bounds and random numbers + ALLOCATE(APAR(NUMPAR),BL(NUMPAR),BU(NUMPAR)) + + DO IPAR=1,NUMPAR + CALL GETPAR_STR(LPARAM(IPAR)%PARNAME,PARAM_META) + BL(IPAR) = PARAM_META%PARLOW ! lower boundary + BU(IPAR) = PARAM_META%PARUPP ! upper boundary + APAR(IPAR) = PARAM_META%PARDEF ! using default parameter values + END DO + + end associate + + end subroutine setup_model_definition + +end module setup_model_definition_MODULE diff --git a/build/FUSE_SRC/dshare/model_defn.f90 b/build/FUSE_SRC/dshare/model_defn.f90 deleted file mode 100644 index 9a0c80a..0000000 --- a/build/FUSE_SRC/dshare/model_defn.f90 +++ /dev/null @@ -1,74 +0,0 @@ -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark -! Modified by Brian Henn to include snow model, 6/2013 -! --------------------------------------------------------------------------------------- -MODULE model_defn - USE nrtype - ! FUSE version - character(*),parameter::FUSE_version="FUSE 1.0" - logical,parameter::FUSE_enabled=.true. - ! list of combinations in each model component - INTEGER, PARAMETER :: NDEC = 9 ! number of model decisions - TYPE DESC - CHARACTER(LEN=16) :: MCOMPONENT ! description of model component - END TYPE DESC - TYPE(DESC), DIMENSION(2) :: LIST_RFERR ! rainfall error - TYPE(DESC), DIMENSION(3) :: LIST_ARCH1 ! upper-layer architecture - TYPE(DESC), DIMENSION(4) :: LIST_ARCH2 ! lower-layer architecture - TYPE(DESC), DIMENSION(3) :: LIST_QSURF ! surface runoff - TYPE(DESC), DIMENSION(3) :: LIST_QPERC ! percolation - TYPE(DESC), DIMENSION(2) :: LIST_ESOIL ! evaporation - TYPE(DESC), DIMENSION(2) :: LIST_QINTF ! interflow - TYPE(DESC), DIMENSION(2) :: LIST_Q_TDH ! time delay in runoff - TYPE(DESC), DIMENSION(2) :: LIST_SNOWM ! snow model - ! structure that holds (x) unique combinations - TYPE UMODEL - INTEGER(I4B) :: MODIX ! model index - CHARACTER(LEN=256) :: MNAME ! model name -! CHARACTER(LEN=16) :: RFERR ! rainfall error - INTEGER(I4B) :: iRFERR -! CHARACTER(LEN=16) :: ARCH1 ! upper-layer architecture - INTEGER(I4B) :: iARCH1 -! CHARACTER(LEN=16) :: ARCH2 ! lower-layer architecture - INTEGER(I4B) :: iARCH2 -! CHARACTER(LEN=16) :: QSURF ! surface runoff - INTEGER(I4B) :: iQSURF -! CHARACTER(LEN=16) :: QPERC ! percolation - INTEGER(I4B) :: iQPERC -! CHARACTER(LEN=16) :: ESOIL ! evaporation - INTEGER(I4B) :: iESOIL -! CHARACTER(LEN=16) :: QINTF ! interflow - INTEGER(I4B) :: iQINTF -! CHARACTER(LEN=16) :: Q_TDH ! time delay in runoff - INTEGER(I4B) :: iQ_TDH - INTEGER(I4B) :: iSNOWM ! snow - END TYPE UMODEL - ! structure to hold model state names - TYPE SNAMES -! CHARACTER(LEN=8) :: SNAME ! state name - INTEGER(I4B) :: iSNAME ! integer value of state name - END TYPE SNAMES - ! structure to hold model flux names - TYPE FNAMES - CHARACTER(LEN=16) :: FNAME ! state name - END TYPE FNAMES -! max steps in routing function - INTEGER(I4B),PARAMETER::NTDH_MAX=500 -! model definitions - CHARACTER(LEN=256) :: FNAME_NETCDF_RUNS ! NETCDF output filename for model runs - CHARACTER(LEN=256) :: FNAME_NETCDF_PARA ! NETCDF output filename for model parameters - CHARACTER(LEN=256) :: FNAME_NETCDF_PARA_SCE ! NETCDF output filename for model parameters produced by SCE - CHARACTER(LEN=256) :: FNAME_NETCDF_PARA_PRE ! NETCDF filename for pre-defined model parameters set - CHARACTER(LEN=256) :: FNAME_PREFIX ! prefix for desired output files - CHARACTER(LEN=256) :: FNAME_TEMPRY ! prefix for temporary output files - CHARACTER(LEN=256) :: FNAME_ASCII ! ASCII output filename - TYPE(UMODEL),DIMENSION(5000) :: AMODL ! (model definition -- all) - TYPE(UMODEL) :: SMODL ! (model definition -- single model) - TYPE(SNAMES),DIMENSION(7) :: CSTATE ! (list of model states for SMODL) - INTEGER(I4B) :: NSTATE=0 ! number of model states - TYPE(FNAMES),DIMENSION(50) :: C_FLUX ! (list of model fluxes for SMODL) - INTEGER(I4B) :: N_FLUX=0 ! number of model fluxes - ! -------------------------------------------------------------------------------------- -END MODULE model_defn diff --git a/build/FUSE_SRC/dshare/multibands.f90 b/build/FUSE_SRC/dshare/multibands.f90 deleted file mode 100644 index 101928d..0000000 --- a/build/FUSE_SRC/dshare/multibands.f90 +++ /dev/null @@ -1,39 +0,0 @@ -! Created by Brian Henn to allow multi-band snow modeling, 6/2013 -! Based on module MULTIFORCE by Martyn Clark -MODULE multibands - USE nrtype - TYPE BANDS ! for catchment scale modeling - INTEGER(I4B) :: NUM ! band number (-) - REAL(SP) :: Z_MID ! band mid-point elevation (m) - REAL(SP) :: AF ! fraction of basin area in band (-) - REAL(SP) :: SWE ! band snowpack water equivalent (mm) - REAL(SP) :: SNOWACCMLTN ! new snow accumulation in band (mm day-1) - REAL(SP) :: SNOWMELT ! snowmelt in band (mm day-1) - REAL(SP) :: DSWE_DT ! rate of change of band SWE (mm day-1) - ENDTYPE BANDS - - ! for distributed modeling MBANDS is split between time-independent and time-dependent charactertistics - - TYPE BANDS_INFO ! invariant characteristics - REAL(SP) :: Z_MID ! band mid-point elevation (m) - REAL(SP) :: AF ! fraction of basin area in band (-) - ENDTYPE BANDS_INFO - - TYPE BANDS_VAR ! time-dependent characteristics - REAL(SP) :: SWE ! band snowpack water equivalent (mm) - REAL(SP) :: SNOWACCMLTN ! new snow accumulation in band (mm day-1) - REAL(SP) :: SNOWMELT ! snowmelt in band (mm day-1) - REAL(SP) :: DSWE_DT ! rate of change of band SWE (mm day-1) - ENDTYPE BANDS_VAR - - ! -------------------------------------------------------------------------------------- - TYPE(BANDS),DIMENSION(:),ALLOCATABLE :: MBANDS ! basin band information - type(BANDS_INFO),dimension(:,:,:),ALLOCATABLE :: MBANDS_INFO_3d ! basin band information in space - type(BANDS_VAR),dimension(:,:,:,:),ALLOCATABLE :: MBANDS_VAR_4d ! basin band information in space plus time - - INTEGER(I4B) :: N_BANDS=0 ! number of bands, initialize to zero - REAL(SP) :: Z_FORCING ! elevation of forcing data (m) - REAL(SP),DIMENSION(:,:),ALLOCATABLE :: Z_FORCING_grid ! elevation of forcing data (m) for the 2D domain - LOGICAL(LGT),DIMENSION(:,:),ALLOCATABLE :: elev_mask ! mask domain - TRUE means the cell must be masked, i.e. not run - ! -------------------------------------------------------------------------------------- -END MODULE multibands diff --git a/build/FUSE_SRC/dshare/multiforce.f90 b/build/FUSE_SRC/dshare/multiforce.f90 deleted file mode 100644 index 90d6ec6..0000000 --- a/build/FUSE_SRC/dshare/multiforce.f90 +++ /dev/null @@ -1,160 +0,0 @@ -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark -! Modified by Brian Henn to include snow model, 6/2013 -! Modified by Nans Addor to enable distributed modeling, 9/2016 -! Modified by Cyril Thébault to allow different metrics as objective function, 2024 -! --------------------------------------------------------------------------------------- -MODULE multiforce - USE nrtype - SAVE - ! -------------------------------------------------------------------------------------- - ! the time data structure (will have no spatial dimension) - TYPE TDATA - INTEGER(I4B) :: IY ! year - INTEGER(I4B) :: IM ! month - INTEGER(I4B) :: ID ! day - INTEGER(I4B) :: IH ! hour - INTEGER(I4B) :: IMIN ! minute - REAL(SP) :: DSEC ! second - REAL(SP) :: DTIME ! time in seconds since year dot - ENDTYPE TDATA - ! the response structure (will not have a spatial dimension) - TYPE VDATA - REAL(SP) :: OBSQ ! observed runoff (mm day-1) - END TYPE VDATA - ! ancillary forcing variables used to compute ET (will have a spatial dimension) - TYPE ADATA - REAL(SP) :: AIRTEMP ! air temperature (K) - REAL(SP) :: SPECHUM ! specific humidity (g/g) - REAL(SP) :: AIRPRES ! air pressure (Pa) - REAL(SP) :: SWDOWN ! downward sw radiation (W m-2) - REAL(SP) :: NETRAD ! net radiation (W m-2) - END TYPE ADATA - ! the forcing data structure (will have a spatial dimension) - TYPE FDATA - REAL(SP) :: PPT ! water input: rain + melt (mm day-1) - REAL(SP) :: TEMP ! temperature for snow model (deg.C) - REAL(SP) :: PET ! energy input: potential ET (mm day-1) - ENDTYPE FDATA - ! -------------------------------------------------------------------------------------- - ! general - INTEGER(I4B),PARAMETER :: STRLEN=256 ! length of the character string - ! time data structures - TYPE(tData) :: timDat ! model time structure - ! response data structures - TYPE(vData) :: valDat ! validation structure - TYPE(vData), DIMENSION(:,:,:), POINTER :: aValid ! all model validation data - ! forcing data structures - TYPE(FDATA), DIMENSION(:), POINTER :: CFORCE ! COPY of model forcing data - TYPE(FDATA), DIMENSION(:), POINTER :: AFORCE ! all model forcing data - TYPE(FDATA) :: MFORCE ! model forcing data for a single time step - TYPE(fData), DIMENSION(:,:), POINTER :: gForce ! model forcing data for a 2-d grid - TYPE(aData), DIMENSION(:,:), POINTER :: ancilF ! ancillary forcing data for the 2-d grid - TYPE(fData), DIMENSION(:,:,:), POINTER :: gForce_3d ! model forcing data for a 3-d grid (time as 3rd dimension) - TYPE(aData), DIMENSION(:,:,:), POINTER :: ancilF_3d ! ancillary forcing data for the 3-d grid - - ! timing information - note that numtim_in >= numtim_sim >= numtim_sub - CHARACTER(len=20) :: date_start_input ! date start input time series - CHARACTER(len=20) :: date_end_input ! date end input time series - - INTEGER(i4b) :: numtim_in=-1 ! number of time steps of input (atmospheric forcing) - INTEGER(i4b) :: numtim_sim=-1 ! number of time steps of FUSE simulations (including spin-up) - INTEGER(i4b) :: numtim_sub=-1 ! number of time steps of subperiod (will be kept in memory) - INTEGER(i4b) :: numtim_sub_cur=-1 ! number of time steps of current subperiod (allows for the last subperiod to be shorter) - INTEGER(i4b) :: itim_in=-1 ! indice within numtim_in - INTEGER(i4b) :: itim_sim=-1 ! indice within numtim_sim - INTEGER(i4b) :: itim_sub=-1 ! indice within numtim_sub - - INTEGER(i4b) :: sim_beg=-1 ! index for the start of the simulation in fuse_metric - INTEGER(i4b) :: sim_end=-1 ! index for the end of the simulation in fuse_metric - INTEGER(i4b) :: eval_beg=-1 ! index for the start of evaluation period - INTEGER(i4b) :: eval_end=-1 ! index for the end of the inference period - - INTEGER(i4b) :: istart=-1 ! index for start of inference period (in reduced array) - REAL(sp) :: jdayRef ! reference time (days) - REAL(sp) :: deltim=-1._dp ! length of time step (days) - - LOGICAL(LGT) :: SUB_PERIODS_FLAG ! .true. if subperiods are used to run FUSE - - ! dimension information - INTEGER(i4b) :: startSpat2=-1 ! number of points in 1st spatial dimension - INTEGER(i4b) :: nSpat1=-1 ! number of points in 1st spatial dimension - INTEGER(i4b) :: nSpat2=-1 ! number of points in 2nd spatial dimension - LOGICAL(LGT) :: GRID_FLAG ! spatial flag .true. if grid - REAL(sp) :: xlon ! longitude (degrees) for PET computation - REAL(sp) :: ylat ! latitude (degrees) for PET computation - REAL(sp),dimension(:),allocatable :: latitude ! latitude (degrees) - REAL(sp),dimension(:),allocatable :: longitude ! longitude (degrees) - CHARACTER(len=strLen),dimension(:),allocatable :: name_psets ! name of parameter sets - INTEGER(I4B) :: NUMPSET ! number of parameter sets - REAL(sp),dimension(:),allocatable :: time_steps ! time steps (days) - REAL(sp),dimension(:),allocatable :: julian_day_input ! time steps (julian days) - CHARACTER(len=strLen) :: latUnits ! units string for latitude - CHARACTER(len=strLen) :: lonUnits ! units string for longitude - CHARACTER(len=strLen) :: timeUnits ! units string for time - - ! filename - CHARACTER(len=StrLen) :: forcefile='undefined' ! name of forcing file - - ! name of time variables - CHARACTER(len=StrLen) :: vname_iy ='undefined' ! name of variable for year - CHARACTER(len=StrLen) :: vname_im ='undefined' ! name of variable for month - CHARACTER(len=StrLen) :: vname_id ='undefined' ! name of variable for day - CHARACTER(len=StrLen) :: vname_ih ='undefined' ! name of variable for hour - CHARACTER(len=StrLen) :: vname_imin ='undefined' ! name of variable for minute - CHARACTER(len=StrLen) :: vname_dsec ='undefined' ! name of variable for second - CHARACTER(len=StrLen) :: vname_dtime='undefined' ! name of variable for time - - ! number of forcing variables - INTEGER(i4b), PARAMETER :: nForce=7 ! see lines below - INTEGER(i4b) :: nInput=3 ! number of variable to retrieve from input file - - ! forcing variable names - CHARACTER(len=StrLen) :: vname_aprecip='undefined' ! variable name: precipitation - CHARACTER(len=StrLen) :: vname_potevap='undefined' ! variable name: potential ET - CHARACTER(len=StrLen) :: vname_airtemp='undefined' ! variable name: temperature - CHARACTER(len=StrLen) :: vname_q ='undefined' ! variable name: observed runoff - CHARACTER(len=StrLen) :: vname_spechum='undefined' ! variable name: specific humidity - CHARACTER(len=StrLen) :: vname_airpres='undefined' ! variable name: surface pressure - CHARACTER(len=StrLen) :: vname_swdown ='undefined' ! variable name: downward shortwave radiation - - ! indices for forcing variables - INTEGER(i4b),PARAMETER :: ilook_aprecip=1 ! named element in lCheck - INTEGER(i4b),PARAMETER :: ilook_potevap=2 ! named element in lCheck - INTEGER(i4b),PARAMETER :: ilook_airtemp=3 ! named element in lCheck - INTEGER(i4b),PARAMETER :: ilook_q=4 ! named element in lCheck - INTEGER(i4b),PARAMETER :: ilook_spechum=5 ! named element in lCheck - INTEGER(i4b),PARAMETER :: ilook_airpres=6 ! named element in lCheck - INTEGER(i4b),PARAMETER :: ilook_swdown =7 ! named element in lCheck - - ! NetCDF - INTEGER(i4b) :: ncid_forc=-1 ! NetCDF forcing file ID - INTEGER(i4b),DIMENSION(nForce) :: ncid_var ! NetCDF forcing variable ID - - ! indices for time data (only used in ASCII files) - INTEGER(i4b) :: ivarid_iy=-1 ! variable ID for year - INTEGER(i4b) :: ivarid_im=-1 ! variable ID for month - INTEGER(i4b) :: ivarid_id=-1 ! variable ID for day - INTEGER(i4b) :: ivarid_ih=-1 ! variable ID for hour - INTEGER(i4b) :: ivarid_imin=-1 ! variable ID for minute - INTEGER(i4b) :: ivarid_dsec=-1 ! variable ID for second - - ! indices for variables - INTEGER(i4b) :: ivarid_ppt=-1 ! variable ID for precipitation - INTEGER(i4b) :: ivarid_temp=-1 ! variable ID for temperature - INTEGER(i4b) :: ivarid_pet=-1 ! variable ID for potential ET - INTEGER(i4b) :: ivarid_q=-1 ! variable ID for runoff - - ! multipliers for variables to convert fluxes to mm/day - REAL(sp) :: amult_ppt=-1._dp ! convert precipitation to mm/day - REAL(sp) :: amult_pet=-1._dp ! convert potential ET to mm/day - REAL(sp) :: amult_q=-1._dp ! convert runoff to mm/day - - ! missing values - INTEGER(I4B),PARAMETER :: NA_VALUE=-9999 ! integer designating missing values - TODO: retrieve from NetCDF file - REAL(SP),PARAMETER :: NA_VALUE_SP=-9999 ! integer designating missing values - TODO: retrieve from NetCDF file - - ! -------------------------------------------------------------------------------------- -END MODULE multiforce diff --git a/build/FUSE_SRC/dshare/multiroute.f90 b/build/FUSE_SRC/dshare/multiroute.f90 deleted file mode 100644 index f9d046b..0000000 --- a/build/FUSE_SRC/dshare/multiroute.f90 +++ /dev/null @@ -1,13 +0,0 @@ -MODULE multiroute - USE nrtype - USE model_defn,ONLY:NTDH_MAX - TYPE RUNOFF - REAL(SP) :: Q_INSTNT ! instantaneous runoff - REAL(SP) :: Q_ROUTED ! routed runoff - REAL(SP) :: Q_ACCURATE ! "accurate" runoff estimate (mm day-1) - END TYPE RUNOFF - REAL(SP), DIMENSION(NTDH_MAX) :: FUTURE ! runoff placed in future time steps - TYPE(RUNOFF), DIMENSION(:), POINTER :: AROUTE ! runoff for all time steps - TYPE(RUNOFF),dimension(:,:,:), allocatable :: AROUTE_3d ! runoff for all time steps on a grid - TYPE(RUNOFF) :: MROUTE ! runoff for one time step -END MODULE multiroute diff --git a/build/FUSE_SRC/dshare/multistate.f90 b/build/FUSE_SRC/dshare/multistate.f90 deleted file mode 100644 index 51c563c..0000000 --- a/build/FUSE_SRC/dshare/multistate.f90 +++ /dev/null @@ -1,53 +0,0 @@ -MODULE multistate - USE nrtype - ! -------------------------------------------------------------------------------------- - ! model state structure - ! -------------------------------------------------------------------------------------- - TYPE STATEV - ! snow layer - REAL(SP) :: SWE_TOT ! total storage as snow (mm) - ! upper layer - REAL(SP) :: WATR_1 ! total storage in layer1 (mm) - REAL(SP) :: TENS_1 ! tension storage in layer1 (mm) - REAL(SP) :: FREE_1 ! free storage in layer 1 (mm) - REAL(SP) :: TENS_1A ! storage in the recharge zone (mm) - REAL(SP) :: TENS_1B ! storage in the lower zone (mm) - ! lower layer - REAL(SP) :: WATR_2 ! total storage in layer2 (mm) - REAL(SP) :: TENS_2 ! tension storage in layer2 (mm) - REAL(SP) :: FREE_2 ! free storage in layer2 (mm) - REAL(SP) :: FREE_2A ! storage in the primary resvr (mm) - REAL(SP) :: FREE_2B ! storage in the secondary resvr (mm) - END TYPE STATEV - ! -------------------------------------------------------------------------------------- - ! model time structure - ! -------------------------------------------------------------------------------------- - TYPE M_TIME - REAL(SP) :: STEP ! (time interval to advance model states) - END TYPE M_TIME - ! -------------------------------------------------------------------------------------- - ! variable definitions - ! -------------------------------------------------------------------------------------- - type(statev),dimension(:,:),pointer :: gState ! (grid of model states) - type(statev),dimension(:,:,:),pointer :: gState_3d ! (grid of model states with a time dimension) - TYPE(STATEV) :: ASTATE ! (model states at the start of full timestep) - TYPE(STATEV) :: FSTATE ! (model states at start of sub-timestep) - TYPE(STATEV) :: MSTATE ! (model states at start/middle of sub-timestep) - TYPE(STATEV) :: TSTATE ! (temporary copy of model states) - TYPE(STATEV) :: BSTATE ! (temporary copy of model states) - TYPE(STATEV) :: ESTATE ! (temporary copy of model states) - TYPE(STATEV) :: DSTATE ! (default model states) - TYPE(STATEV) :: DYDT_0 ! (derivative of model states at start of sub-step) - TYPE(STATEV) :: DYDT_1 ! (derivative of model states at end of sub-step) - TYPE(STATEV) :: DY_DT ! (derivative of model states) - TYPE(STATEV) :: DYDT_OLD ! (derivative of model states for final solution) - TYPE(M_TIME) :: HSTATE ! (time interval to advance model states) - ! -------------------------------------------------------------------------------------- - - ! NetCDF - integer(i4b) :: ncid_out=-1 ! NetCDF output file ID - - ! initial store fraction (initialization) - real(sp),parameter::fracState0=0.25_sp - -END MODULE multistate diff --git a/build/FUSE_SRC/netcdf/def_output.f90 b/build/FUSE_SRC/netcdf/def_output.f90 index b323020..46e883a 100644 --- a/build/FUSE_SRC/netcdf/def_output.f90 +++ b/build/FUSE_SRC/netcdf/def_output.f90 @@ -1,207 +1,142 @@ -SUBROUTINE DEF_OUTPUT(nSpat1,nSpat2,NPSET,NTIM) - - ! --------------------------------------------------------------------------------------- - ! Creator: - ! -------- - ! Martyn Clark, 2007 - ! --------------------------------------------------------------------------------------- - ! Purpose: - ! -------- - ! Define NetCDF output files -- time-varying model output - ! --------------------------------------------------------------------------------------- - - USE nrtype ! variable types, etc. - USE model_defn, only: FNAME_NETCDF_RUNS ! model definition (includes filename) - USE metaoutput ! metadata for all model variables - USE fuse_fileManager,only: Q_ONLY ! only write streamflow to output file? - USE multiforce, only: GRID_FLAG ! .true. if distributed - USE multiforce, only: latitude,longitude ! dimension arrays - USE multiforce, only: name_psets,time_steps ! dimension arrays - USE multiforce, only: latUnits,lonUnits ! units string - USE multiforce, only: timeUnits ! units string - USE multistate, only: ncid_out ! NetCDF output file ID - USE globaldata, only: FUSE_VERSION, FUSE_BUILDTIME, FUSE_GITBRANCH, FUSE_GITHASH - - - IMPLICIT NONE - - ! input - INTEGER(I4B), INTENT(IN) :: NTIM ! number of time steps - INTEGER(I4B), INTENT(IN) :: nSpat1,nSpat2 ! length of spatial dimensions - INTEGER(I4B), INTENT(IN) :: NPSET ! number of parameter sets - - ! internal - REAL(MSP),DIMENSION(nspat1) :: longitude_msp ! desired variable (SINGLE PRECISION) - REAL(MSP),DIMENSION(nspat2) :: latitude_msp ! desired variable (SINGLE PRECISION) - REAL(SP),parameter :: NA_VALUE_OUT= -9999. ! NA_VALUE for output file - REAL(MSP) :: NA_VALUE_OUT_MSP ! NA_VALUE for output file - - LOGICAL(LGT) :: WRITE_VAR ! used to denote if the variable is written - INTEGER(I4B) :: IERR ! error code - INTEGER(I4B) :: NTIM_DIM ! time - INTEGER(I4B) :: lon_dim ! 1st spatial dimension - INTEGER(I4B) :: lat_dim ! 2nd spatial dimension - INTEGER(I4B) :: param_dim ! parameter set dimension - INTEGER(I4B) :: NMOD_DIM ! number of models - INTEGER(I4B), DIMENSION(:), ALLOCATABLE :: TVAR ! all dimensions - INTEGER(I4B) :: IVAR ! loop through variables - INTEGER(I4B) :: IVAR_ID ! variable ID - - INTEGER(I4B) :: CHID ! char position dimension id - INTEGER(I4B),parameter :: TDIMS=2 ! char position dimension id - INTEGER(I4B) :: TXDIMS(TDIMS) ! variable shape - INTEGER(I4B) :: TSTART(TDIMS), TCOUNT(TDIMS) - - include 'netcdf.inc' ! use netCDF libraries - - ! --------------------------------------------------------------------------------------- - CALL VARDESCRIBE() ! get list of variable descriptions - ! --------------------------------------------------------------------------------------- -! put file in define mode - print *, 'Create NetCDF file for runs:' - PRINT *, FNAME_NETCDF_RUNS - - IERR = NF_CREATE(TRIM(FNAME_NETCDF_RUNS),NF_CLOBBER,ncid_out); CALL HANDLE_ERR(IERR) - !IERR = NF_OPEN(TRIM(FNAME_NETCDF_RUNS),NF_WRITE,ncid_out); CALL HANDLE_ERR(IERR) - !IERR = NF_REDEF(ncid_out); CALL HANDLE_ERR(IERR) - - ! define dimensions - IERR = NF_DEF_DIM(ncid_out,'time',NF_UNLIMITED,NTIM_DIM); CALL HANDLE_ERR(IERR) !record dimension (unlimited length) - IERR = NF_DEF_DIM(ncid_out,'longitude',nSpat1,lon_dim); CALL HANDLE_ERR(IERR) - IERR = NF_DEF_DIM(ncid_out,'latitude',nSpat2,lat_dim); CALL HANDLE_ERR(IERR) - IF(.NOT.GRID_FLAG)THEN - IERR = NF_DEF_DIM(ncid_out,'param_set',NPSET,param_dim); CALL HANDLE_ERR(IERR) - ENDIF - - - ! define character-position dimension for strings of max length 40 - !IERR = NF_DEF_DIM(ncid_out, "chid", 40, CHID); CALL HANDLE_ERR(IERR) - - ! define a character-string variable - ! TXDIMS(1) = CHID ! character-position dimension first - ! TXDIMS(2) = NTIM_DIM ! record dimension ID - ! IERR = NF_DEF_VAR(ncid_out, 'param_set',NF_CHAR, TDIMS, TXDIMS, param_dim); CALL HANDLE_ERR(IERR) - - ! retrieve ID for the model and parameter dimensions - !IERR = NF_INQ_DIMID(ncid_out,'par',NPAR_DIM); CALL HANDLE_ERR(IERR) - !IERR = NF_INQ_DIMID(ncid_out,'mod',NMOD_DIM); CALL HANDLE_ERR(IERR) - - ! assign dimensions to indices: for efficiency reasons, param_dim should be - ! last, because it varies the slowest, but the NetCDF standard imposes - ! the unlimited dimension to be last. - - IF(.NOT.GRID_FLAG)THEN - allocate(TVAR(4)) - TVAR = (/lon_dim,lat_dim,param_dim,NTIM_DIM/) - ELSE - allocate(TVAR(3)) - TVAR = (/lon_dim,lat_dim,NTIM_DIM/) ! no parameter dimension in grid mode - ENDIF - - ! define time-varying output variables - DO IVAR=1,NOUTVAR - - ! check if there is a need to write the variable - see also put_output - ! uncomment variables that should be written to output file - IF (Q_ONLY) THEN - WRITE_VAR=.FALSE. - !IF (TRIM(VNAME(IVAR)).EQ.'ppt') WRITE_VAR=.TRUE. - !IF (TRIM(VNAME(IVAR)).EQ.'pet') WRITE_VAR=.TRUE. - !IF (TRIM(VNAME(IVAR)).EQ.'obsq') WRITE_VAR=.TRUE. - !IF (TRIM(VNAME(IVAR)).EQ.'evap_1') WRITE_VAR=.TRUE. - !IF (TRIM(VNAME(IVAR)).EQ.'evap_2') WRITE_VAR=.TRUE. - !IF (TRIM(VNAME(IVAR)).EQ.'q_instnt') WRITE_VAR=.TRUE. - IF (TRIM(VNAME(IVAR)).EQ.'q_routed') WRITE_VAR=.TRUE. - !IF (TRIM(VNAME(IVAR)).EQ.'watr_1') WRITE_VAR=.TRUE. - !IF (TRIM(VNAME(IVAR)).EQ.'watr_2') WRITE_VAR=.TRUE. - !IF (TRIM(VNAME(IVAR)).EQ.'swe_tot') WRITE_VAR=.TRUE. - !IF (TRIM(VNAME(IVAR)).EQ.'qsurf') WRITE_VAR=.TRUE. - !IF (TRIM(VNAME(IVAR)).EQ.'oflow_1') WRITE_VAR=.TRUE. - !IF (TRIM(VNAME(IVAR)).EQ.'qintf_1') WRITE_VAR=.TRUE. - !IF (TRIM(VNAME(IVAR)).EQ.'oflow_2') WRITE_VAR=.TRUE. - !IF (TRIM(VNAME(IVAR)).EQ.'qbase_2') WRITE_VAR=.TRUE. - IF (.NOT.WRITE_VAR) CYCLE ! start new iteration of do loop, i.e. skip writting variable - ENDIF - - ! write the variable - IF(.NOT.GRID_FLAG)THEN - IERR = NF_DEF_VAR(ncid_out,TRIM(VNAME(IVAR)),NF_REAL,4,TVAR,IVAR_ID); CALL HANDLE_ERR(IERR) - ELSE - IERR = NF_DEF_VAR(ncid_out,TRIM(VNAME(IVAR)),NF_REAL,3,TVAR,IVAR_ID); CALL HANDLE_ERR(IERR) - ENDIF - - - IERR = NF_PUT_ATT_TEXT(ncid_out,IVAR_ID,'long_name',LEN_TRIM(LNAME(IVAR)),TRIM(LNAME(IVAR))) - CALL HANDLE_ERR(IERR) - IERR = NF_PUT_ATT_TEXT(ncid_out,IVAR_ID,'units',LEN_TRIM(VUNIT(IVAR)),TRIM(VUNIT(IVAR))) - CALL HANDLE_ERR(IERR) - !IERR = NF_DEF_VAR_FILL(ncid_out,IVAR_ID,0,NA_VALUE) ! define _FillValue for NetCDF4 files only - NA_VALUE_OUT_MSP=NA_VALUE_OUT - IERR = NF_PUT_ATT_REAL(ncid_out,IVAR_ID,'_FillValue',NF_FLOAT,1,NA_VALUE_OUT_MSP) - CALL HANDLE_ERR(IERR) - - END DO ! ivar - - ! define the time variable - ierr = nf_def_var(ncid_out,'time',nf_real,1,(/ntim_dim/),ivar_id); call handle_err(ierr) - ierr = nf_put_att_text(ncid_out,ivar_id,'units',len_trim(timeUnits),trim(timeUnits)) - call handle_err(ierr) - - ! define the latitude variable - ierr = nf_def_var(ncid_out,'latitude',nf_real,1,(/lat_dim/),ivar_id); call handle_err(ierr) - ierr = nf_put_att_text(ncid_out,ivar_id,'units',8,'degreesN'); call handle_err(ierr) - ierr = nf_put_att_text(ncid_out,ivar_id,'axis',1,'Y'); call handle_err(ierr) - - ! define the longitude variable - ierr = nf_def_var(ncid_out,'longitude',nf_real,1,(/lon_dim/),ivar_id); call handle_err(ierr) - ierr = nf_put_att_text(ncid_out,ivar_id,'units',8,'degreesE'); call handle_err(ierr) - ierr = nf_put_att_text(ncid_out,ivar_id,'axis',1,'X'); call handle_err(ierr) - - IF(.NOT.GRID_FLAG)THEN - ! define the param_set variable - ierr = nf_def_var(ncid_out,'param_set',nf_char,1,(/param_dim/),ivar_id); call handle_err(ierr) - ierr = nf_put_att_text(ncid_out,ivar_id,'units',1,'-'); call handle_err(ierr) - ENDIF - - ! add global attributes - ierr = NF_PUT_ATT_TEXT(ncid_out, NF_GLOBAL, "software", len("FUSE"), "FUSE"); call HANDLE_ERR(ierr) - ierr = NF_PUT_ATT_TEXT(ncid_out, NF_GLOBAL, "fuse_version", len_trim(FUSE_VERSION), trim(FUSE_VERSION)); call HANDLE_ERR(ierr) - ierr = NF_PUT_ATT_TEXT(ncid_out, NF_GLOBAL, "fuse_build_time", len_trim(FUSE_BUILDTIME), trim(FUSE_BUILDTIME)); call HANDLE_ERR(ierr) - ierr = NF_PUT_ATT_TEXT(ncid_out, NF_GLOBAL, "fuse_git_branch", len_trim(FUSE_GITBRANCH), trim(FUSE_GITBRANCH)); call HANDLE_ERR(ierr) - ierr = NF_PUT_ATT_TEXT(ncid_out, NF_GLOBAL, "fuse_git_hash", len_trim(FUSE_GITHASH), trim(FUSE_GITHASH)); call HANDLE_ERR(ierr) - - ! end definitions - IERR = NF_ENDDEF(ncid_out); call handle_err(ierr) - - !IERR = NF_OPEN(TRIM(FNAME_NETCDF),NF_WRITE,ncid_out); CALL HANDLE_ERR(IERR) - latitude_msp=latitude ! convert to actual single precision - IERR = NF_INQ_VARID(ncid_out,'latitude',IVAR_ID); CALL HANDLE_ERR(IERR) ! get variable ID - IERR = NF_PUT_VARA_REAL(ncid_out,IVAR_ID,1,nspat2,latitude_msp); CALL HANDLE_ERR(IERR) ! write data - - longitude_msp=longitude ! convert to actual single precision - IERR = NF_INQ_VARID(ncid_out,'longitude',IVAR_ID); CALL HANDLE_ERR(IERR) ! get variable ID - IERR = NF_PUT_VARA_REAL(ncid_out,IVAR_ID,1,nspat1,longitude_msp); CALL HANDLE_ERR(IERR) ! write data - - !TSTART(1) = 1 ! start at beginning of variable - !TSTART(2) = 1 ! record number to write - !TCOUNT(1) = 20 ! number of chars to write - !TCOUNT(2) = 1 ! only write one record - - !IERR = NF_INQ_VARID(ncid_out,'param_set',IVAR_ID); CALL HANDLE_ERR(IERR) ! get variable ID - !IERR = NF_PUT_VARA_TEXT(ncid_out,IVAR_ID,1,NPSET,name_psets); CALL HANDLE_ERR(IERR) ! write data - !IERR = NF_PUT_VARA_TEXT(ncid_out,IVAR_ID,TSTART,TCOUNT,name_psets); CALL HANDLE_ERR(IERR) ! write data - - IF(.NOT.GRID_FLAG)THEN - PRINT *, 'NetCDF file for model runs defined with dimensions', nSpat1 , nSpat2, NPSET, NTIM - ELSE - PRINT *, 'NetCDF file for model runs defined with dimensions', nSpat1 , nSpat2, NTIM - ENDIF - - - IERR = NF_ENDDEF(ncid_out) - IERR = NF_CLOSE(ncid_out) - - deallocate(TVAR) - -! --------------------------------------------------------------------------------------- -END SUBROUTINE DEF_OUTPUT +MODULE DEF_OUTPUT_MODULE + USE nrtype + USE netcdf + use data_types, only: coord_data + use iso_fortran_env, only: real32 + implicit none + private + public :: DEF_OUTPUT + +contains + + SUBROUTINE DEF_OUTPUT(coords,nSpat1,nSpat2,n_bands,NUMPAR) + + USE metaoutput, only: VARDESCRIBE + USE globaldata, only: FUSE_VERSION, FUSE_BUILDTIME, FUSE_GITBRANCH, FUSE_GITHASH + USE metaoutput, only: NOUTVAR, VNAME, LNAME, VUNIT, isBand, isFlux + USE model_defn, only: FNAME_NETCDF_RUNS + USE fuse_fileManager, only: Q_ONLY + USE multiforce, only: timeUnits + USE globaldata, only: ncid_out + + implicit none + + type(coord_data), intent(in) :: coords + integer(i4b), intent(in) :: nSpat1, nSpat2, n_bands, NUMPAR + + ! locals + integer(i4b) :: ierr, ivar, varid, varid_time, varid_lat, varid_lon, varid_band, varid_param + integer(i4b) :: dim_time, dim_x, dim_y, dim_band, dim_par + integer(i4b), dimension(3) :: dimids_3 + integer(i4b), dimension(4) :: dimids_band + integer(i4b), dimension(4) :: dimids_par + + logical(lgt) :: write_var + + real(real32), dimension(nspat1,nspat2) :: longitude + real(real32), dimension(nspat1,nspat2) :: latitude + real(real32), parameter :: NA_VALUE_OUT = -9999._real32 + + integer(i4b), dimension(n_bands) :: band_i + integer(i4b), dimension(NUMPAR) :: param_i + integer(i4b) :: ib, ip + + call VARDESCRIBE() + + print *, 'Create NetCDF file for runs:' + print *, trim(FNAME_NETCDF_RUNS) + + ! Create NetCDF-4 file (HDF5 container) + ierr = nf90_create(trim(FNAME_NETCDF_RUNS), NF90_CLASSIC_MODEL, ncid_out) + call handle_err(ierr) + + ! Dimensions + ierr = nf90_def_dim(ncid_out, "time", NF90_UNLIMITED, dim_time); call handle_err(ierr) + ierr = nf90_def_dim(ncid_out, "band", n_bands, dim_band); call handle_err(ierr) + ierr = nf90_def_dim(ncid_out, "param", NUMPAR, dim_par); call handle_err(ierr) + ierr = nf90_def_dim(ncid_out, "x", nSpat1, dim_x); call handle_err(ierr) + ierr = nf90_def_dim(ncid_out, "y", nSpat2, dim_y); call handle_err(ierr) + + dimids_3 = (/ dim_y, dim_y, dim_time /) + dimids_band = (/ dim_y, dim_y, dim_band, dim_time /) + dimids_par = (/ dim_y, dim_y, dim_par, dim_time /) + + ! Time-varying output vars + do ivar = 1, NOUTVAR + + if (Q_ONLY) then + write_var = .false. + if (trim(VNAME(ivar)) == "q_instnt") write_var = .true. + if (trim(VNAME(ivar)) == "q_routed") write_var = .true. + if (.not. write_var) cycle + end if + + if (isBand(ivar)) then + ierr = nf90_def_var(ncid_out, trim(VNAME(ivar)), NF90_FLOAT, dimids_band, varid) + else + ierr = nf90_def_var(ncid_out, trim(VNAME(ivar)), NF90_FLOAT, dimids_3, varid) + end if + call handle_err(ierr) + + ! Attributes + ierr = nf90_put_att(ncid_out, varid, "long_name", trim(LNAME(ivar))); call handle_err(ierr) + ierr = nf90_put_att(ncid_out, varid, "units", trim(VUNIT(ivar))); call handle_err(ierr) + ierr = nf90_put_att(ncid_out, varid, "_FillValue", NA_VALUE_OUT); call handle_err(ierr) + + ! Optional: parameter sensitivity var for each flux + if (isFlux(ivar)) then + ierr = nf90_def_var(ncid_out, trim(VNAME(ivar))//"__dFlux_dParam", NF90_FLOAT, dimids_par, varid) + call handle_err(ierr) + ierr = nf90_put_att(ncid_out, varid, "_FillValue", NA_VALUE_OUT); call handle_err(ierr) + end if + + end do ! looping through variables + + ! Coordinate variables + ierr = nf90_def_var(ncid_out, "time", NF90_FLOAT, (/dim_time/), varid_time); call handle_err(ierr) + ierr = nf90_put_att(ncid_out, varid_time, "units", trim(timeUnits)); call handle_err(ierr) + + ierr = nf90_def_var(ncid_out, "latitude", NF90_FLOAT, (/dim_x, dim_y/), varid_lat); call handle_err(ierr) + ierr = nf90_put_att(ncid_out, varid_lat, "standard_name", "latitude"); call handle_err(ierr) + ierr = nf90_put_att(ncid_out, varid_lat, "units", "degrees_north"); call handle_err(ierr) + + ierr = nf90_def_var(ncid_out, "longitude", NF90_FLOAT, (/dim_x, dim_y/), varid_lon); call handle_err(ierr) + ierr = nf90_put_att(ncid_out, varid_lon, "standard_name", "longitude"); call handle_err(ierr) + ierr = nf90_put_att(ncid_out, varid_lon, "units", "degrees_east"); call handle_err(ierr) + + ierr = nf90_def_var(ncid_out, "param", NF90_INT, (/dim_par/), varid_param); call handle_err(ierr) + ierr = nf90_put_att(ncid_out, varid_param, "units", "-"); call handle_err(ierr) + + ierr = nf90_def_var(ncid_out, "band", NF90_INT, (/dim_band/), varid_band); call handle_err(ierr) + ierr = nf90_put_att(ncid_out, varid_band, "units", "-"); call handle_err(ierr) + + ! Global attributes + ierr = nf90_put_att(ncid_out, NF90_GLOBAL, "software", "FUSE"); call handle_err(ierr) + ierr = nf90_put_att(ncid_out, NF90_GLOBAL, "fuse_version", trim(FUSE_VERSION)); call handle_err(ierr) + ierr = nf90_put_att(ncid_out, NF90_GLOBAL, "fuse_build_time", trim(FUSE_BUILDTIME)); call handle_err(ierr) + ierr = nf90_put_att(ncid_out, NF90_GLOBAL, "fuse_git_branch", trim(FUSE_GITBRANCH)); call handle_err(ierr) + ierr = nf90_put_att(ncid_out, NF90_GLOBAL, "fuse_git_hash", trim(FUSE_GITHASH)); call handle_err(ierr) + + ! Leave define mode + ierr = nf90_enddef(ncid_out); call handle_err(ierr) + + ! Write coordinate data + latitude = real(coords%lat_2d, kind(real32)) + longitude = real(coords%lon_2d, kind(real32)) + + ierr = nf90_put_var(ncid_out, varid_lat, latitude); call handle_err(ierr) + ierr = nf90_put_var(ncid_out, varid_lon, longitude); call handle_err(ierr) + + band_i = [(ib, ib=1,n_bands)] + param_i = [(ip, ip=1,NUMPAR)] + + ierr = nf90_put_var(ncid_out, varid_band, band_i); call handle_err(ierr) + ierr = nf90_put_var(ncid_out, varid_param, param_i); call handle_err(ierr) + + ierr = nf90_close(ncid_out); call handle_err(ierr) + + print *, 'NetCDF file for model runs defined with dimensions', nSpat1, nSpat2, n_bands, NUMPAR + + END SUBROUTINE DEF_OUTPUT + +END MODULE DEF_OUTPUT_MODULE diff --git a/build/FUSE_SRC/netcdf/def_params.f90 b/build/FUSE_SRC/netcdf/def_params.f90 index 94c6c88..0e655df 100644 --- a/build/FUSE_SRC/netcdf/def_params.f90 +++ b/build/FUSE_SRC/netcdf/def_params.f90 @@ -1,78 +1,101 @@ -SUBROUTINE DEF_PARAMS(NPAR) -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2007 -! Modified by Nans Addor to include snow routine -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Define NetCDF output files -- parameter variables -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -USE model_defn, only: FNAME_NETCDF_PARA ! model definition (includes filename) -USE metaparams ! metadata for all model parameters -USE multistats, ONLY: MSTATS ! model statistics structure -USE multistate, only: ncid_out ! NetCDF output file ID -USE globaldata, only: FUSE_VERSION, FUSE_BUILDTIME, FUSE_GITBRANCH, FUSE_GITHASH -IMPLICIT NONE -! input -INTEGER(I4B), INTENT(IN) :: NPAR ! number of parameter sets -! internal -INTEGER(I4B) :: IERR ! error code -INTEGER(I4B) :: NPAR_DIM ! number of parameter sets -INTEGER(I4B) :: NMOD_DIM ! number of models -INTEGER(I4B) :: NDIF_DIM ! differences in models -INTEGER(I4B) :: NAME_DIM ! length of string defining models -INTEGER(I4B) :: ERRM_DIM ! length of string defining error message -INTEGER(I4B), DIMENSION(1) :: FVAR ! fixed dimensions -INTEGER(I4B), DIMENSION(3) :: SVAR ! model descriptor dimensions -INTEGER(I4B), DIMENSION(3) :: EVAR ! error message dimensions -INTEGER(I4B) :: IVAR ! loop through variables -INTEGER(I4B) :: IVAR_ID ! variable ID -include 'netcdf.inc' ! use netCDF libraries -! --------------------------------------------------------------------------------------- -CALL PARDESCRIBE() ! get list of parameter descriptions -! --------------------------------------------------------------------------------------- -PRINT *, 'Define NetCDF output files - parameter variables = ', TRIM(FNAME_NETCDF_PARA) -! Create file -IERR = NF_CREATE(TRIM(FNAME_NETCDF_PARA),NF_CLOBBER,ncid_out); CALL HANDLE_ERR(IERR) - ! define dimensions - ! IERR = NF_DEF_DIM(ncid_out,'mod',NMOD,NMOD_DIM); CALL HANDLE_ERR(IERR) -! IERR = NF_DEF_DIM(ncid_out,'par',NF_UNLIMITED,NPAR_DIM); CALL HANDLE_ERR(IERR) - IERR = NF_DEF_DIM(ncid_out,'par',NPAR,NPAR_DIM); CALL HANDLE_ERR(IERR) ! TODO : max number of parameter - should not be hard-coded - !IERR = NF_DEF_DIM(ncid_out,'model_differences',9,NDIF_DIM); CALL HANDLE_ERR(IERR) !TODO: this should not be hard-coded - !IERR = NF_DEF_DIM(ncid_out,'model_name_length',10,NAME_DIM); CALL HANDLE_ERR(IERR) - !IERR = NF_DEF_DIM(ncid_out,'error_message_length',LEN(MSTATS%ERR_MESSAGE),ERRM_DIM) - ! assign dimensions to indices - FVAR = (/NPAR_DIM/) ! dimensions for fixed output (parameters) - !SVAR = (/NAME_DIM,NDIF_DIM,NMOD_DIM/) ! dimensions for model names - !EVAR = (/ERRM_DIM,NMOD_DIM,NPAR_DIM/) ! dimensions for error messages - ! define fixed output variables - DO IVAR=1,NOUTPAR - IERR = NF_DEF_VAR(ncid_out,TRIM(PNAME(IVAR)),NF_REAL,1,FVAR,IVAR_ID); CALL HANDLE_ERR(IERR) - IERR = NF_PUT_ATT_TEXT(ncid_out,IVAR_ID,'long_name',LEN_TRIM(PDESC(IVAR)),TRIM(PDESC(IVAR))) - CALL HANDLE_ERR(IERR) - IERR = NF_PUT_ATT_TEXT(ncid_out,IVAR_ID,'units',LEN_TRIM(PUNIT(IVAR)),TRIM(PUNIT(IVAR))) - CALL HANDLE_ERR(IERR) - IERR = NF_PUT_ATT_REAL(ncid_out,IVAR_ID,'_FillValue',NF_REAL,1,-9999.); CALL HANDLE_ERR(IERR) - END DO ! ivar - ! define model definitions - !IERR = NF_DEF_VAR(ncid_out,'model_description',NF_CHAR,3,SVAR,IVAR_ID); CALL HANDLE_ERR(IERR) - ! define error messages - !IERR = NF_DEF_VAR(ncid_out,'error_message',NF_CHAR,3,EVAR,IVAR_ID); CALL HANDLE_ERR(IERR) -! end definitions and close file +MODULE DEF_PARAMS_MODULE + USE nrtype ! variable types, etc. + + implicit none + + private + public :: DEF_PARAMS + + contains + + SUBROUTINE DEF_PARAMS(NPAR) + ! --------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark, 2007 + ! Modified by Nans Addor to include snow routine + ! Modified by Matyn Clark to include band dimension, 12/2025 + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! Define NetCDF output files -- parameter variables + ! --------------------------------------------------------------------------------------- + + ! subroutines + USE metaparams, only: PARDESCRIBE ! define metadata for model parameters + + ! data modules + USE metaparams, only: NOUTPAR ! number of model parameters + USE metaparams, only: PNAME, PDESC, PUNIT ! metadata for all model parameters + USE metaparams, only: isBand ! logical flag to define vars with elevation dimension + USE model_defn, only: FNAME_NETCDF_PARA ! model definition (includes filename) + USE multistats, ONLY: MSTATS ! model statistics structure + USE multibands, ONLY: N_BANDS ! number of elevation bands + USE globaldata, only: ncid_out ! NetCDF output file ID + USE globaldata, only: FUSE_VERSION, FUSE_BUILDTIME, FUSE_GITBRANCH, FUSE_GITHASH + + IMPLICIT NONE + + ! input + INTEGER(I4B), INTENT(IN) :: NPAR ! number of parameter sets + + ! internal + INTEGER(I4B) :: IERR ! error code + INTEGER(I4B) :: PAR_DIM ! parameter set dimension + INTEGER(I4B) :: BAND_DIM ! elevation band dimension + INTEGER(I4B), DIMENSION(1) :: DIMS1 ! 1-d parameter vector + INTEGER(I4B), DIMENSION(2) :: DIMS2 ! 2-d parameter-bands matrix + INTEGER(I4B) :: IVAR ! loop through variables + INTEGER(I4B) :: IVAR_ID ! variable ID + + include 'netcdf.inc' ! use netCDF libraries + + ! --------------------------------------------------------------------------------------- + CALL PARDESCRIBE() ! get list of parameter descriptions + ! --------------------------------------------------------------------------------------- + + PRINT *, 'Define NetCDF output files - parameter variables = ', TRIM(FNAME_NETCDF_PARA) + + ! Create file + IERR = NF_CREATE(TRIM(FNAME_NETCDF_PARA),NF_CLOBBER,ncid_out); CALL HANDLE_ERR(IERR) + + ! define dimensions + IERR = NF_DEF_DIM(ncid_out, 'par', NPAR, PAR_DIM); CALL HANDLE_ERR(IERR) + IERR = NF_DEF_DIM(ncid_out, 'band', N_BANDS, BAND_DIM); CALL HANDLE_ERR(IERR) + + ! assign dimensions to indices + DIMS1 = (/PAR_DIM/) ! 1-d parameter vector + DIMS2 = (/PAR_DIM, BAND_DIM/) ! 2-d parameter-bands matrix + + ! define fixed output variables + DO IVAR=1,NOUTPAR + + ! define variables + if(isBand(iVar))then + IERR = NF_DEF_VAR(ncid_out, TRIM(PNAME(IVAR)), NF_REAL, 2, DIMS2, IVAR_ID); CALL HANDLE_ERR(IERR) + else + IERR = NF_DEF_VAR(ncid_out, TRIM(PNAME(IVAR)), NF_REAL, 1, DIMS1, IVAR_ID); CALL HANDLE_ERR(IERR) + endif + + ! define metadata + IERR = NF_PUT_ATT_TEXT(ncid_out,IVAR_ID,'long_name',LEN_TRIM(PDESC(IVAR)),TRIM(PDESC(IVAR))); CALL HANDLE_ERR(IERR) + IERR = NF_PUT_ATT_TEXT(ncid_out,IVAR_ID,'units',LEN_TRIM(PUNIT(IVAR)),TRIM(PUNIT(IVAR))); CALL HANDLE_ERR(IERR) + IERR = NF_PUT_ATT_REAL(ncid_out,IVAR_ID,'_FillValue',NF_REAL,1,-9999.); CALL HANDLE_ERR(IERR) + + END DO ! ivar + ! add global attributes ierr = NF_PUT_ATT_TEXT(ncid_out, NF_GLOBAL, "software", len("FUSE"), "FUSE"); call HANDLE_ERR(ierr) ierr = NF_PUT_ATT_TEXT(ncid_out, NF_GLOBAL, "fuse_version", len_trim(FUSE_VERSION), trim(FUSE_VERSION)); call HANDLE_ERR(ierr) ierr = NF_PUT_ATT_TEXT(ncid_out, NF_GLOBAL, "fuse_build_time", len_trim(FUSE_BUILDTIME), trim(FUSE_BUILDTIME)); call HANDLE_ERR(ierr) ierr = NF_PUT_ATT_TEXT(ncid_out, NF_GLOBAL, "fuse_git_branch", len_trim(FUSE_GITBRANCH), trim(FUSE_GITBRANCH)); call HANDLE_ERR(ierr) ierr = NF_PUT_ATT_TEXT(ncid_out, NF_GLOBAL, "fuse_git_hash", len_trim(FUSE_GITHASH), trim(FUSE_GITHASH)); call HANDLE_ERR(ierr) + + ! end definitions and close file + IERR = NF_ENDDEF(ncid_out) + IERR = NF_CLOSE(ncid_out) + ! --------------------------------------------------------------------------------------- + END SUBROUTINE DEF_PARAMS - - -IERR = NF_ENDDEF(ncid_out) -IERR = NF_CLOSE(ncid_out) -! --------------------------------------------------------------------------------------- -END SUBROUTINE DEF_PARAMS +END MODULE DEF_PARAMS_MODULE diff --git a/build/FUSE_SRC/netcdf/def_sstats.f90 b/build/FUSE_SRC/netcdf/def_sstats.f90 index 33436c5..3dd5213 100644 --- a/build/FUSE_SRC/netcdf/def_sstats.f90 +++ b/build/FUSE_SRC/netcdf/def_sstats.f90 @@ -1,74 +1,83 @@ -SUBROUTINE DEF_SSTATS() -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2007 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Define NetCDF output files -- summary statistics -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -USE model_defn ! model definition (includes filename) -USE meta_stats ! metadata for summary statistics -USE model_numerix ! model numerix decisions -USE multistate, only: ncid_out ! NetCDF output file ID -IMPLICIT NONE -! internal -INTEGER(I4B) :: IERR ! error code; NetCDF ID -INTEGER(I4B) :: NPAR_DIM ! number of parameter sets -INTEGER(I4B) :: NMOD_DIM ! number of models -!INTEGER(I4B) :: NORD_DIM ! number of ordinates in prob distn -INTEGER(I4B), DIMENSION(1) :: FVAR ! dimensions for summary statistics -INTEGER(I4B), DIMENSION(2) :: PVAR ! dimensions for probability distributions -INTEGER(I4B) :: IVAR ! loop through variables -INTEGER(I4B) :: IVAR_ID ! variable ID -!INTEGER(I4B) :: IORD_ID ! ordinates ID -!real(MSP), dimension(size(ORD_NSUBS)) :: rORD ! ordinates of the prob dist (real numbers) -include 'netcdf.inc' ! use netCDF libraries -! --------------------------------------------------------------------------------------- -CALL SUMDESCRIBE() ! get list of summary statistics -! --------------------------------------------------------------------------------------- -! open file and put in define mode -IERR = NF_OPEN(TRIM(FNAME_NETCDF_PARA),NF_WRITE,ncid_out); CALL HANDLE_ERR(IERR) -IERR = NF_REDEF(ncid_out); CALL HANDLE_ERR(IERR) - ! retrieve ID for the model and parameter dimensions - IERR = NF_INQ_DIMID(ncid_out,'par',NPAR_DIM); CALL HANDLE_ERR(IERR) - !IERR = NF_INQ_DIMID(ncid_out,'mod',NMOD_DIM); CALL HANDLE_ERR(IERR) +module DEF_SSTATS_module + implicit none + private + public :: DEF_SSTATS - ! define ord dimension - !IERR = NF_DEF_DIM(ncid_out,'ord',SIZE(ORD_NSUBS),NORD_DIM); CALL HANDLE_ERR(IERR) +contains - ! define variables - FVAR = (/NPAR_DIM/) ! dimensions for fixed output (parameters) - DO IVAR=1,NSUMVAR - IERR = NF_DEF_VAR(ncid_out,TRIM(XNAME(IVAR)),NF_REAL,1,FVAR,IVAR_ID); CALL HANDLE_ERR(IERR) - IERR = NF_PUT_ATT_TEXT(ncid_out,IVAR_ID,'long_name',LEN_TRIM(XDESC(IVAR)),TRIM(XDESC(IVAR))) - CALL HANDLE_ERR(IERR) - IERR = NF_PUT_ATT_TEXT(ncid_out,IVAR_ID,'units',LEN_TRIM(XUNIT(IVAR)),TRIM(XUNIT(IVAR))) - CALL HANDLE_ERR(IERR) - IERR = NF_PUT_ATT_REAL(ncid_out,IVAR_ID,'_FillValue',NF_REAL,1,-9999.); CALL HANDLE_ERR(IERR) - END DO ! ivar + SUBROUTINE DEF_SSTATS() + ! --------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark, 2007 + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! Define NetCDF output files -- summary statistics + ! --------------------------------------------------------------------------------------- + USE nrtype ! variable types, etc. + USE model_defn ! model definition (includes filename) + USE meta_stats ! metadata for summary statistics + USE model_numerix ! model numerix decisions + USE globaldata, only: ncid_out ! NetCDF output file ID + IMPLICIT NONE + ! internal + INTEGER(I4B) :: IERR ! error code; NetCDF ID + INTEGER(I4B) :: NPAR_DIM ! number of parameter sets + INTEGER(I4B) :: NMOD_DIM ! number of models + !INTEGER(I4B) :: NORD_DIM ! number of ordinates in prob distn + INTEGER(I4B), DIMENSION(1) :: FVAR ! dimensions for summary statistics + INTEGER(I4B), DIMENSION(2) :: PVAR ! dimensions for probability distributions + INTEGER(I4B) :: IVAR ! loop through variables + INTEGER(I4B) :: IVAR_ID ! variable ID + !INTEGER(I4B) :: IORD_ID ! ordinates ID + !real(MSP), dimension(size(ORD_NSUBS)) :: rORD ! ordinates of the prob dist (real numbers) + include 'netcdf.inc' ! use netCDF libraries + ! --------------------------------------------------------------------------------------- + CALL SUMDESCRIBE() ! get list of summary statistics + ! --------------------------------------------------------------------------------------- + ! open file and put in define mode + IERR = NF_OPEN(TRIM(FNAME_NETCDF_PARA),NF_WRITE,ncid_out); CALL HANDLE_ERR(IERR) + IERR = NF_REDEF(ncid_out); CALL HANDLE_ERR(IERR) + ! retrieve ID for the model and parameter dimensions + IERR = NF_INQ_DIMID(ncid_out,'par',NPAR_DIM); CALL HANDLE_ERR(IERR) + !IERR = NF_INQ_DIMID(ncid_out,'mod',NMOD_DIM); CALL HANDLE_ERR(IERR) + + ! define ord dimension + !IERR = NF_DEF_DIM(ncid_out,'ord',SIZE(ORD_NSUBS),NORD_DIM); CALL HANDLE_ERR(IERR) + + ! define variables + FVAR = (/NPAR_DIM/) ! dimensions for fixed output (parameters) + DO IVAR=1,NSUMVAR + IERR = NF_DEF_VAR(ncid_out,TRIM(XNAME(IVAR)),NF_REAL,1,FVAR,IVAR_ID); CALL HANDLE_ERR(IERR) + IERR = NF_PUT_ATT_TEXT(ncid_out,IVAR_ID,'long_name',LEN_TRIM(XDESC(IVAR)),TRIM(XDESC(IVAR))) + + CALL HANDLE_ERR(IERR) + IERR = NF_PUT_ATT_TEXT(ncid_out,IVAR_ID,'units',LEN_TRIM(XUNIT(IVAR)),TRIM(XUNIT(IVAR))) + CALL HANDLE_ERR(IERR) + END DO ! ivar + + ! define ordinates of probability distributions + ! IERR = NF_DEF_VAR(ncid_out,'ordinates',NF_REAL,1,NORD_DIM,IORD_ID); CALL HANDLE_ERR(IERR) + ! IERR = NF_PUT_ATT_TEXT(ncid_out,IORD_ID,'long_name',37,'ordinates of probability distribution') + ! CALL HANDLE_ERR(IERR) + + ! IERR = NF_PUT_ATT_TEXT(ncid_out,IORD_ID,'units',1,'-'); CALL HANDLE_ERR(IERR) + + ! define probability distributions + ! PVAR = (/NPAR_DIM,NORD_DIM/) ! dimensions for probability distributions + ! IERR = NF_DEF_VAR(ncid_out,'probability',NF_REAL,2,PVAR,IVAR_ID); CALL HANDLE_ERR(IERR) + ! IERR = NF_PUT_ATT_TEXT(ncid_out,IVAR_ID,'long_name',44,'cumulative probability of number of substeps'); CALL HANDLE_ERR(IERR) + ! IERR = NF_PUT_ATT_TEXT(ncid_out,IVAR_ID,'units',1,'-'); CALL HANDLE_ERR(IERR) + + ! end definitions and close file + IERR = NF_ENDDEF(ncid_out) + ! write the ordinates of the probability distribution + !rORD = real(ORD_NSUBS,kind(MSP)) + ! IERR = NF_PUT_VAR_REAL(ncid_out,IORD_ID,rORD); CALL HANDLE_ERR(IERR) ! write data + IERR = NF_CLOSE(ncid_out) + + ! --------------------------------------------------------------------------------------- + END SUBROUTINE DEF_SSTATS - ! define ordinates of probability distributions - ! IERR = NF_DEF_VAR(ncid_out,'ordinates',NF_REAL,1,NORD_DIM,IORD_ID); CALL HANDLE_ERR(IERR) - ! IERR = NF_PUT_ATT_TEXT(ncid_out,IORD_ID,'long_name',37,'ordinates of probability distribution') - ! CALL HANDLE_ERR(IERR) - - ! IERR = NF_PUT_ATT_TEXT(ncid_out,IORD_ID,'units',1,'-'); CALL HANDLE_ERR(IERR) - - ! define probability distributions - ! PVAR = (/NPAR_DIM,NORD_DIM/) ! dimensions for probability distributions - ! IERR = NF_DEF_VAR(ncid_out,'probability',NF_REAL,2,PVAR,IVAR_ID); CALL HANDLE_ERR(IERR) - ! IERR = NF_PUT_ATT_TEXT(ncid_out,IVAR_ID,'long_name',44,'cumulative probability of number of substeps'); CALL HANDLE_ERR(IERR) - ! IERR = NF_PUT_ATT_TEXT(ncid_out,IVAR_ID,'units',1,'-'); CALL HANDLE_ERR(IERR) - -! end definitions and close file -IERR = NF_ENDDEF(ncid_out) -! write the ordinates of the probability distribution -!rORD = real(ORD_NSUBS,kind(MSP)) -! IERR = NF_PUT_VAR_REAL(ncid_out,IORD_ID,rORD); CALL HANDLE_ERR(IERR) ! write data -IERR = NF_CLOSE(ncid_out) - -! --------------------------------------------------------------------------------------- -END SUBROUTINE DEF_SSTATS +end module DEF_SSTATS_module diff --git a/build/FUSE_SRC/netcdf/domain_decomp.f90 b/build/FUSE_SRC/netcdf/domain_decomp.f90 new file mode 100644 index 0000000..27e0a49 --- /dev/null +++ b/build/FUSE_SRC/netcdf/domain_decomp.f90 @@ -0,0 +1,89 @@ +module domain_decomp_module + + use info_types, only: fuse_info + + implicit none + + private + public :: get_domain_decomp_indices + +contains + + ! ------------------------------------------------------------------------------------- + ! ------------------------------------------------------------------------------------- + + ! ----- get indices to decompose the spatial domain ----------------------------------- + ! 1) Determine global run mode (grid vs catchment) + ! 2) Apply MPI decomposition (y dimension) and store local dims + offsets + + subroutine get_domain_decomp_indices(info) + implicit none + type(fuse_info), intent(inout) :: info + + associate(& + nx_global => info%space%nx_global, & + ny_global => info%space%ny_global, & + nx_local => info%space%nx_local, & + ny_local => info%space%ny_local, & + y_start_global => info%space%y_start_global, & + y_end_global => info%space%y_end_global, & + mpi_enabled => info%mpi%enabled, & + nproc => info%mpi%nproc, & + rank => info%mpi%rank ) + + ! Copy globals + nx_local = nx_global + ny_local = ny_global + y_start_global = 1 + + ! Get indices for split dimensions + if(mpi_enabled .and. nproc>1) then + call split_1d(ny_global, rank, nproc, & ! input + y_start_global, ny_local) ! output + endif + y_end_global = y_start_global + ny_local - 1 + + end associate + end subroutine get_domain_decomp_indices + + ! ------------------------------------------------------------------------------------- + ! ------------------------------------------------------------------------------------- + + ! ----- split the dimensions for each MPI rank ---------------------------------------- + ! Purpose: Split domain to allow for MPI. + ! Given rank, nproc, and n_global, provide start and n_local indices + ! Creator: Ethan Gutmann, 2020 + ! Modified by Martyn Clark to simplify code and input/output, 12/2025 + + subroutine split_1d(n_global, rank, nproc, start, n_local, verbose) + use nrtype + implicit none + integer(i4b), intent(in) :: n_global, rank, nproc + logical(lgt), intent(in), optional :: verbose + integer(i4b), intent(out) :: start, n_local + + integer(i4b) :: base, extra + logical(lgt) :: talk + + talk = .false.; if(present(verbose)) talk = verbose + + ! --- sanity checks --- + if(nproc <= 0) stop "split_1d: nproc must be > 0" + if(rank < 0 .or. rank >= nproc) stop "split_1d: rank out of range" + if(n_global < 1) stop "split_1d: n_global must be >= 1" + + base = n_global / nproc ! floor(n_global / nproc) rows per rank + extra = mod(n_global, nproc) ! remainder; first 'extra' ranks get +1 row + + n_local = base + merge(1, 0, rank < extra) ! add 1 row for ranks 0..extra-1 + start = rank*base + min(rank, extra) + 1 ! shift start by #extra rows assigned before this rank + + if(talk) then + write(*,'(a,i0,a,i0)') "split_1d: nproc=", nproc, " rank =", rank + write(*,'(a,i0,a,i0)') "split_1d: base =", base, " extra =", extra + write(*,'(a,i0,a,i0)') "split_1d: start=", start, " nLocal=", n_local + write(*,'(a,i0,a,i0)') "split_1d: global rows=", start, ":", start+n_local-1 + endif + end subroutine split_1d + +end module domain_decomp_module diff --git a/build/FUSE_SRC/netcdf/get_domain_dims.f90 b/build/FUSE_SRC/netcdf/get_domain_dims.f90 new file mode 100644 index 0000000..dcb8388 --- /dev/null +++ b/build/FUSE_SRC/netcdf/get_domain_dims.f90 @@ -0,0 +1,222 @@ +module domain_dims_module + use nrtype + use info_types, only: fuse_info + implicit none + private + public :: get_domain_dims + +contains + + subroutine get_domain_dims(info, ierr, message) + + implicit none + + type(fuse_info), intent(inout) :: info + integer(i4b), intent(out) :: ierr + character(*), intent(out) :: message + + character(len=1024) :: forc_file ! forcing file + character(len=1024) :: elev_file ! elev bands file + + character(len=1024) :: cmessage + integer(i4b) :: dimLen + + ierr = 0 + message = "get_domain_metadata/" + + ! get filenames + forc_file = trim(info%files%input_path)//trim(info%files%forcing_file) + elev_file = trim(info%files%input_path)//trim(info%files%elevbands_file) + + ! read forcing dimensions + call read_forcing_dimensions(forc_file, info, ierr, cmessage) + if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif + + ! read number of elevation bands + call nc_get_dimlen_from_file(elev_file, "elevation_band", dimlen, ierr, cmessage) + if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif + info%snow%n_bands = dimLen + + end subroutine get_domain_dims + + + ! ----- utility routines -------------------------------------------------------------------------------------------- + + ! ----- read forcing dimensions ------------------------------------------------------------------------------------- + + subroutine read_forcing_dimensions(filepath, info, ierr, message) + + use nrtype + use netcdf + use info_types, only: fuse_info + implicit none + + character(*), intent(in) :: filepath + type(fuse_info), intent(inout) :: info + integer(i4b), intent(out) :: ierr + character(*), intent(out) :: message + + integer(i4b) :: ncid + integer(i4b) :: varid + integer(i4b) :: ndims + integer(i4b) :: dimids(NF90_MAX_VAR_DIMS) + character(len=NF90_MAX_NAME) :: dimname + integer(i4b) :: idim,dimlen + integer(i4b) :: time_varid + + associate(precip_name => info%files%precip_name, & + grid_flag => info%space%grid_flag, & + nx_global => info%space%nx_global, & + ny_global => info%space%ny_global, & + nt_global => info%time%nt_global, & + nInput => info%config%nInput) + + ierr=0; message="read_forcing_dimensions/" + + ! --- open NetCDF file for reading (nf90_nowrite) --- + ierr = nf90_open(trim(filepath), nf90_nowrite, ncid) + if(ierr /= nf90_noerr) then + message = trim(message)//"nf90_open failed: "//trim(nf90_strerror(ierr))// & + " [file="//trim(filepath)//"]" + return + endif + + ! --- get dimension lengths from precip variable shape --- + ierr = nf90_inq_varid(ncid, trim(precip_name), varid) + if(ierr /= nf90_noerr) then + message = trim(message)//"cannot find var '"//trim(precip_name)//"': "//trim(nf90_strerror(ierr)) + return + endif + + ierr = nf90_inquire_variable(ncid, varid, ndims=ndims, dimids=dimids) + if(ierr /= nf90_noerr) then + message = trim(message)//"inquire_variable failed: "//trim(nf90_strerror(ierr)) + return + endif + + ! --- get the length of the time dimension (expect it is the last dimension) --- + ierr = nf90_inquire_dimension(ncid, dimids(ndims), name=dimname, len=nt_global) + if(ierr /= nf90_noerr) then + message = trim(message)//"inquire_dimension failed: "//trim(nf90_strerror(ierr)) + return + endif + + ! --- check that the last dimension is time --- + if(trim(dimname) /= "time")then + message=trim(message)//"FUSE expects (…, time) ordering; i.e., time dimension is last" + ierr=20; return + endif + + ! --- require rank 2 or 3 and require time last (already checked earlier) --- + if (ndims /= 2 .and. ndims /= 3) then + message = trim(message)//"expected forcing var rank 2 (spat,time) or 3 (spat,spat,time)" + ierr = 20; return + endif + + ! ndims == 2: enforce (hru,time) in the feature order + ! -> the only non-time dim is the "hru"/feature dimension + if (ndims == 2) then + + ierr = nf90_inquire_dimension(ncid, dimids(1), len=ny_global) + if(ierr /= nf90_noerr) then + message = trim(message)//"inquire_dimension failed: "//trim(nf90_strerror(ierr)) + return + endif + nx_global = 1 + + ! ndims == 3: enforce (x,y,time) in the file order + ! -> can be (y,x,time) also since the spatial dimensions are general + else + + ierr = nf90_inquire_dimension(ncid, dimids(1), len=nx_global) + if(ierr /= nf90_noerr) then + message = trim(message)//"inquire_dimension failed: "//trim(nf90_strerror(ierr)) + return + endif + + ierr = nf90_inquire_dimension(ncid, dimids(2), len=ny_global) + if(ierr /= nf90_noerr) then + message = trim(message)//"inquire_dimension failed: "//trim(nf90_strerror(ierr)) + return + endif + + endif ! (ndims=3) + + ! define grid + ! TODO: includes point list of catchments, but logic not implemented yet + grid_flag = nx_global > 1 + + ! set the number of input variables (3 = ppt, temp, pet; 4 = + obsq) + nInput = merge(3,4,grid_flag) + + ! --- close NetCDF file --- + ierr = nf90_close(ncid) + if(ierr /= nf90_noerr) then + message = trim(message)//"nf90_close failed: "//trim(nf90_strerror(ierr))// & + " [file="//trim(filepath)//"]" + return + endif + + end associate + end subroutine read_forcing_dimensions + + ! ----- get dimension length from file ------------------------------------------------------------------------------ + + + subroutine nc_get_dimlen_from_file(filepath, dimname, dimlen, ierr, message) + + use netcdf, only: nf90_open, nf90_close, nf90_nowrite, & + nf90_inq_dimid, nf90_inquire_dimension, & + nf90_strerror, nf90_noerr + implicit none + + ! inputs + character(*), intent(in) :: filepath + character(*), intent(in) :: dimname + + ! outputs + integer(i4b), intent(out) :: dimlen + integer(i4b), intent(out) :: ierr + character(*), intent(out) :: message + + ! locals + integer(i4b) :: ncid, dimid + + ierr = 0 + dimlen = -1 + message = "nc_get_dimlen_from_file/" + + ! open NetCDF file for reading (nf90_nowrite) + ierr = nf90_open(trim(filepath), nf90_nowrite, ncid) + if(ierr /= nf90_noerr) then + message = trim(message)//"nf90_open failed: "//trim(nf90_strerror(ierr))// & + " [file="//trim(filepath)//"]" + return + endif + + ! get dimension ID + ierr = nf90_inq_dimid(ncid, trim(dimname), dimid) + if(ierr /= nf90_noerr) then + message = trim(message)//"nf90_inq_dimid failed: "//trim(nf90_strerror(ierr))// & + " [dim="//trim(dimname)//"]" + return + endif + + ! get dimension length + ierr = nf90_inquire_dimension(ncid, dimid, len=dimlen) + if(ierr /= nf90_noerr) then + message = trim(message)//"nf90_inquire_dimension failed: "//trim(nf90_strerror(ierr))// & + " [dim="//trim(dimname)//"]" + return + endif + + ! close + ierr = nf90_close(ncid) + if(ierr /= nf90_noerr) then + message = trim(message)//"nf90_close failed: "//trim(nf90_strerror(ierr)) + return + endif + + end subroutine nc_get_dimlen_from_file + +end module domain_dims_module diff --git a/build/FUSE_SRC/netcdf/get_gforce.f90 b/build/FUSE_SRC/netcdf/get_gforce.f90 index f990a04..b95d36b 100644 --- a/build/FUSE_SRC/netcdf/get_gforce.f90 +++ b/build/FUSE_SRC/netcdf/get_gforce.f90 @@ -1,523 +1,362 @@ module get_gforce_module -USE nrtype -USE netcdf -USE time_io + +use nrtype +use info_types, only: fuse_info + +use netcdf + +use globaldata, only: NVAR_FORC +use globaldata, only: iPRECIP, iTEMP, iPET, iQOBS + implicit none + private -public::read_ginfo -public::get_dimIds -public::get_gforce -public::get_gforce_3d -public::get_varid + +public :: get_gforce_3d +public :: read_latlon_2d +public :: get_forcing_varids contains - ! --------------------------------------------------------------------------------------- - ! Creator: - ! -------- - ! Ethan Gutmann, 2020 - ! --------------------------------------------------------------------------------------- - ! Purpose: - ! -------- - ! Split domain to allow for MPI. Given proc and nproc, provide start and update nSpat2 - - subroutine split_dims(nSpat2, proc, nproc, start) - - implicit none - integer(i4b), intent(inout) :: nSpat2, start - integer(i4b), intent(in) :: proc, nproc - - integer(i4b) :: newn, offset, even_multiple, count - - print*, 'Number of cores to be used (nproc)', nproc - - newn = nSpat2 / nproc ! number of rows of the domain to be run by each process - print*, 'Number of rows of domain per core (newn) ', newn - - even_multiple = nproc * newn - print*, 'nproc x newn', even_multiple - - count = nSpat2 - even_multiple - print*, 'Difference to',nSpat2,':', count - - offset = 0 - if (proc < count) offset = 1 - - start = (proc * newn) + min(proc, count) + 1 - - nSpat2 = newn + offset - - print*, "PROCESS (proc, start, start+newn, newn)" - print*, proc, start, start+newn, newn - - end subroutine split_dims - - SUBROUTINE read_ginfo(ncid,ierr,message) - ! --------------------------------------------------------------------------------------- - ! Creator: - ! -------- - ! Martyn Clark, 2012 - ! --------------------------------------------------------------------------------------- - ! Purpose: - ! -------- - ! Read grid info (spatial and temporal dimensions) from the NetCDF file - ! --------------------------------------------------------------------------------------- - ! Modules Modified: - ! ----------------- - ! MODULE multiforce -- populate dimension lengths - ! --------------------------------------------------------------------------------------- - USE fuse_fileManager,only:SETNGS_PATH,FORCINGINFO,& ! defines data directory - INPUT_PATH - USE multiforce,only:forcefile,vname_aprecip ! model forcing structures - USE multiforce,only:nspat1,nspat2,startSpat2,numtim_in! dimension lengths - USE multiforce,only:GRID_FLAG ! .true. if distributed - USE multiforce,only:latitude,longitude ! dimension arrays - USE multiforce,only:time_steps,julian_day_input ! dimension arrays - USE multiforce,only:latUnits,lonUnits,timeUnits ! units string for time - USE multiforce,only:vname_dtime ! variable name: time sice reference time - USE multiforce, only: nForce, nInput ! number of parameter set and their names - USE multiforce, only: NA_VALUE ! NA_VALUE for the forcing - -#ifdef __MPI__ - use mpi -#endif - - IMPLICIT NONE - ! input - integer(i4b),intent(in) :: ncid ! NetCDF file ID -! output - integer(i4b), intent(out) :: ierr ! error code - character(*), intent(out) :: message ! error message - ! internal: general - integer(i4b),parameter::lenPath=1024 ! DK211008: allows longer file paths - INTEGER(I4B) :: I ! looping - CHARACTER(LEN=lenPath) :: cmessage ! message of downwind routine - ! internal: NetCDF read - integer(i4b) :: ivarid ! NetCDF variable ID - integer(i4b),parameter :: ndims=3 ! number of dimensions for precipitation - integer(i4b),dimension(ndims) :: dimids_ppt ! vector of dimension IDs for precipitation - integer(i4b) :: iDimID ! dimension ID - integer(i4b) :: dimLen ! dimension length - - - integer ( kind = 4 ) mpi_error_value - integer ( kind = 4 ) mpi_process - integer ( kind = 4 ) mpi_nprocesses - - - ! --------------------------------------------------------------------------------------- - ! Initialize MPI - ! --------------------------------------------------------------------------------------- -#ifdef __MPI__ - print *,'__MPI__ is defined, getting mpi_nprocesses and mpi_process' - call MPI_Comm_size(MPI_COMM_WORLD, mpi_nprocesses, mpi_error_value) - call MPI_Comm_rank(MPI_COMM_WORLD, mpi_process, mpi_error_value) -#else - print *,'__MPI__ is NOT defined, setting mpi_nprocesses = 1 and mpi_process = 0' - mpi_process = 0 - mpi_nprocesses = 1 -#endif - - - ! --------------------------------------------------------------------------------------- - ! initialize error control - ierr=0; message='read_ginfo/' - ! --------------------------------------------------------------------------------------- - - ! get the variable ID for precipitation - ierr = nf90_inq_varid(ncid, vname_aprecip, ivarid) - if(ierr/=0)then; message=trim(message)//trim(nf90_strerror(ierr)); return; endif - - ! get the dimension IDs for precipitation - call get_dimIds(ncid, ivarid, ndims, dimids_ppt, ierr, cmessage) - if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif - - ! loop through dimensions - do iDimID=1,ndims - - ! get the dimension lengths - ierr = nf90_inquire_dimension(ncid,dimids_ppt(iDimID),len=dimLen) - if(ierr/=0)then; message=trim(message)//trim(nf90_strerror(ierr)); return; endif - ! save the dimension lengths - if(iDimID==1) nspat1 = dimLen ! 1st spatial dimension - if(iDimID==2) nspat2 = dimLen ! 2nd spatial dimension - if(iDimID==3) numtim_in = dimLen ! record dimension (always last) + ! -------------------------------------------------------------------------------------- + ! -------------------------------------------------------------------------------------- + ! -------------------------------------------------------------------------------------- + + subroutine read_latlon_2d(ncid, info, coord, ierr, message) - end do + use netcdf + use nrtype + use info_types, only: fuse_info + use data_types, only: coord_data + implicit none - startSpat2 = 1 + integer(i4b), intent(in) :: ncid + type(fuse_info), intent(in) :: info + type(coord_data),intent(inout) :: coord + integer(i4b), intent(out) :: ierr + character(*), intent(out) :: message + + integer(i4b) :: vid_lat, vid_lon + integer(i4b) :: nd_lat, nd_lon + integer(i4b) :: dimids_lat(NF90_MAX_VAR_DIMS), dimids_lon(NF90_MAX_VAR_DIMS) + integer(i4b) :: nx, ny, ystart + integer(i4b) :: len_lat, len_lon + integer(i4b) :: start2(2), count2(2) + real(sp), allocatable :: lon_1d(:), lat_1d(:) + + ierr = 0 + message = "read_latlon_2d/" + + nx = info%space%nx_local + ny = info%space%ny_local + ystart = info%space%y_start_global + + ! Ensure 2D storage exists + if (.not. allocated(coord%lat_2d)) allocate(coord%lat_2d(nx, ny)) + if (.not. allocated(coord%lon_2d)) allocate(coord%lon_2d(nx, ny)) + + ! --- get varids --- + ierr = nf90_inq_varid(ncid, trim(info%files%latitude_name), vid_lat) + if(ierr /= nf90_noerr) then + message = trim(message)//"missing var '"//trim(info%files%latitude_name)//"': "//trim(nf90_strerror(ierr)) + return + endif - ! define the spatial flag - PRINT *, ' ' - if(nSpat1.GT.1.OR.nSpat2.GT.1) THEN - PRINT *, '### FUSE set to run in grid mode' - GRID_FLAG=.TRUE. - nInput=3 ! number of variables to be retrieved from input file (P, T, PET) + ierr = nf90_inq_varid(ncid, trim(info%files%longitude_name), vid_lon) + if(ierr /= nf90_noerr) then + message = trim(message)//"missing var '"//trim(info%files%longitude_name)//"': "//trim(nf90_strerror(ierr)) + return + endif - call split_dims(nSpat2, mpi_process, mpi_nprocesses, startSpat2) - ELSE + ! --- ranks/dims --- + ierr = nf90_inquire_variable(ncid, vid_lat, ndims=nd_lat, dimids=dimids_lat) + if(ierr /= nf90_noerr) then + message = trim(message)//"inquire latitude failed: "//trim(nf90_strerror(ierr)) + return + endif - PRINT *, '### FUSE set to run in catchment mode' - GRID_FLAG=.FALSE. - nInput=4 ! number of variables to be retrieved from input file (P, T, PET, Q) + ierr = nf90_inquire_variable(ncid, vid_lon, ndims=nd_lon, dimids=dimids_lon) + if(ierr /= nf90_noerr) then + message = trim(message)//"inquire longitude failed: "//trim(nf90_strerror(ierr)) + return + endif + + !---------------------------------------------------------------------------- + ! Case A: Rectilinear OR point-list (lat 1D, lon 1D) + !---------------------------------------------------------------------------- + if (nd_lat == 1 .and. nd_lon == 1) then + + ! Read full 1D vectors (easiest because slice depends on grid shape) + ! NOTE: do MPI slice later + ierr = nf90_inquire_dimension(ncid, dimids_lat(1), len=len_lat) + if(ierr /= nf90_noerr) then + message = trim(message)//"inquire lat dim failed: "//trim(nf90_strerror(ierr)) + return + endif + ierr = nf90_inquire_dimension(ncid, dimids_lon(1), len=len_lon) + if(ierr /= nf90_noerr) then + message = trim(message)//"inquire lon dim failed: "//trim(nf90_strerror(ierr)) + return + endif + + allocate(lat_1d(len_lat)) + allocate(lon_1d(len_lon)) + + ierr = nf90_get_var(ncid, vid_lat, lat_1d) + if(ierr /= nf90_noerr) then + message = trim(message)//"get_var(latitude) failed: "//trim(nf90_strerror(ierr)) + return + endif + + ierr = nf90_get_var(ncid, vid_lon, lon_1d) + if(ierr /= nf90_noerr) then + message = trim(message)//"get_var(longitude) failed: "//trim(nf90_strerror(ierr)) + return + endif + + coord%is_curvilinear = .false. + coord%is_point_list = (info%space%nx_global == 1) ! our convention + + if (coord%is_point_list) then + ! Point-list/HRU: lat(hru), lon(hru) -> store as (1,ny_local) + if (nx /= 1) then + message = trim(message)//"point-list detected but nx_local /= 1" + ierr = 20; return + endif + coord%lat_2d(1,:) = lat_1d(ystart:ystart+ny-1) + coord%lon_2d(1,:) = lon_1d(ystart:ystart+ny-1) + + else + ! Rectilinear grid: lat(ny), lon(nx) -> broadcast to 2D + + ! lon_1d is global length nx_global + coord%lon_2d(:,:) = spread(lon_1d(1:nx), dim=2, ncopies=ny) + + ! lat_1d is global length ny_global; take this rank's slice then replicate across x + coord%lat_2d(:,:) = spread(lat_1d(ystart:ystart+ny-1), dim=1, ncopies=nx) + + endif + + deallocate(lat_1d, lon_1d) + + return + endif - ENDIF + !---------------------------------------------------------------------------- + ! Case B: Curvilinear (lat 2D, lon 2D) + !---------------------------------------------------------------------------- + if (nd_lat == 2 .and. nd_lon == 2) then - print*, 'spatial dimensions of the grid= ', nSpat1, 'x' ,nSpat2 - print*, 'NA_VALUE = ', NA_VALUE - print*, 'GRID_FLAG = ', GRID_FLAG + ! Read local slab in file order: (spat1,spat2) with y split along dim2 - ! allocate arrays - allocate(longitude(nspat1),latitude(nspat2),time_steps(numtim_in),julian_day_input(numtim_in)) + start2 = (/ 1, ystart /) + count2 = (/ nx, ny /) - ! get longitude - ierr = nf90_inq_varid(ncid, 'longitude', iVarID) - if(ierr/=0)then; message=trim(message)//trim(nf90_strerror(ierr))//'[variable=longitude]'; return; endif - ierr = nf90_get_var(ncid, iVarID, longitude, start=(/1/), count=(/nSpat1/)); CALL HANDLE_ERR(IERR) - if(ierr/=0)then; message=trim(message)//trim(nf90_strerror(ierr)); return; endif + ierr = nf90_get_var(ncid, vid_lat, coord%lat_2d, start=start2, count=count2) + if(ierr /= nf90_noerr) then + message = trim(message)//"get_var(latitude 2D) failed: "//trim(nf90_strerror(ierr)) + return + endif - ! get latitude - ierr = nf90_inq_varid(ncid, 'latitude', iVarID) - if(ierr/=0)then; message=trim(message)//trim(nf90_strerror(ierr))//'[variable=latitude]'; return; endif - ierr = nf90_get_var(ncid, iVarID, latitude, start=(/startSpat2/), count=(/nSpat2/)); CALL HANDLE_ERR(IERR) - if(ierr/=0)then; message=trim(message)//trim(nf90_strerror(ierr)); return; endif + ierr = nf90_get_var(ncid, vid_lon, coord%lon_2d, start=start2, count=count2) + if(ierr /= nf90_noerr) then + message = trim(message)//"get_var(longitude 2D) failed: "//trim(nf90_strerror(ierr)) + return + endif + + coord%is_curvilinear = .true. + coord%is_point_list = .false. + + return + endif - ! get time - ierr = nf90_inq_varid(ncid, trim(vname_dtime), iVarID) - if(ierr/=0)then; message=trim(message)//trim(nf90_strerror(ierr))//'[variable='//trim(vname_dtime)//']'; return; endif - ierr = nf90_get_var(ncid, iVarID, time_steps, start=(/1/), count=(/numtim_in/)); CALL HANDLE_ERR(IERR) - if(ierr/=0)then; message=trim(message)//trim(nf90_strerror(ierr)); return; endif - ierr = nf90_get_att(ncid, iVarID, 'units', timeUnits) - if(ierr/=0)then; message=trim(message)//trim(nf90_strerror(ierr))//'[variable='//trim(vname_dtime)//']'; return; endif + !---------------------------------------------------------------------------- + ! Anything else is unsupported under preprocessing + layout rules + !---------------------------------------------------------------------------- + ierr = 20 + write(message,'(a,i0,a,i0,a)') trim(message)// & + "unsupported lat/lon ranks (lat_ndims=", nd_lat, ", lon_ndims=", nd_lon, & + "). If coords include time, preprocess to remove time from latitude/longitude." - end subroutine read_ginfo + end subroutine read_latlon_2d + ! -------------------------------------------------------------------------------------- + ! -------------------------------------------------------------------------------------- ! -------------------------------------------------------------------------------------- subroutine get_dimIds(ncid, varid, nexpect, varDimIDs, ierr, message) ! used to get the vector of dimension ids for a given variable + implicit none + ! input integer(i4b),intent(in) :: ncid ! NetCDF file ID integer(i4b),intent(in) :: varid ! NetCDF variable ID integer(i4b),intent(in) :: nexpect ! number of dimensions expected + ! output integer(i4b),intent(out) :: varDimIDs(nexpect) ! vector of dimension IDs integer(i4b),intent(out) :: ierr ! error code character(*), intent(out) :: message ! error message + ! internal variables integer(i4b) :: nVarDims ! number of dimensions for given variable + ! initialize error control ierr=0; message='get_dimIds/' + ! get number of dimensions ierr = nf90_inquire_variable(ncid, varid, ndims=nVarDims) if(ierr/=0)then; message=trim(message)//trim(nf90_strerror(ierr)); return; endif + ! check number of dimensions if(nVarDims/=nexpect)then; message=trim(message)//'unexpected number of dimensions for variable'; return; endif + ! get vector of dimension IDs ierr = nf90_inquire_variable(ncid, varid, dimids=varDimIDs(:nVarDims)) if(ierr/=0)then; message=trim(message)//trim(nf90_strerror(ierr)); return; endif + end subroutine get_dimIds + ! -------------------------------------------------------------------------------------- - - SUBROUTINE get_varID(ncid,ierr,message) + + subroutine get_forcing_varids(ncid, info, ierr, message) + implicit none + integer(i4b), intent(in) :: ncid + type(fuse_info), intent(inout) :: info + integer(i4b), intent(out) :: ierr + character(*), intent(out) :: message + + integer(i4b) :: ivar + + ierr = 0 + message = "get_forcing_varids/" + + ! get table of name/varid pairs (names set in TOML read) + info%files%forc%name(iPRECIP) = info%files%precip_name + info%files%forc%name(iTEMP) = info%files%temp_name + info%files%forc%name(iPET) = info%files%pet_name + info%files%forc%name(iQOBS) = info%files%qobs_name + + info%files%forc%varid(:) = -1 + + ! get varid for each forcing variable + do ivar = 1, NVAR_FORC + + if(info%space%grid_flag .and. ivar == iQOBS) cycle ! skips qobs if a grid + + call lookup_varid(ncid, trim(info%files%forc%name(ivar)), info%files%forc%varid(ivar), ierr, message) + if(ierr/=0) return + + end do ! ivar + + contains + + subroutine lookup_varid(ncid, vname, vid, ierr, message) + + integer(i4b), intent(in) :: ncid + character(len=*), intent(in) :: vname + integer(i4b), intent(inout) :: vid + integer(i4b), intent(inout) :: ierr + character(*), intent(inout) :: message + + if (len_trim(vname) == 0) then + ierr = 20 + message = trim(message)//"empty variable name" + return + end if + + ierr = nf90_inq_varid(ncid, trim(vname), vid) + if (ierr /= 0) then + message = trim(message)//trim(nf90_strerror(ierr))//" [var="//trim(vname)//"]" + end if + + end subroutine lookup_varid + + end subroutine get_forcing_varids + + + SUBROUTINE get_gforce_3d(info, itim_start, numtim, ierr, message) ! --------------------------------------------------------------------------------------- ! Creator: ! -------- - ! Nans Addor, 2017 + ! Nans Addor, based on Martyn Clark's get_gforce + ! Modified by Martyn Clark to simplify and update to new data structures, 02/2026 ! --------------------------------------------------------------------------------------- ! Purpose: ! -------- - ! Get NetCDF ID for each variable of the forcing file + ! Read NetCDF gridded forcing data for a range of time steps ! --------------------------------------------------------------------------------------- ! Modules Modified: ! ----------------- - ! MODULE multiforce -- populate structure ncid_var%(*) + ! MODULE multiforce -- populate structure GFORCE_3d(*,*)%(*) ! --------------------------------------------------------------------------------------- - USE multiforce, only: nForce, nInput ! number of forcing variables - USE multiforce, only: ncid_var ! NetCDF forcing variable ID - - USE multiforce,only:forcefile ! name of forcing file - USE multiforce,only:vname_aprecip ! variable name: precipitation - USE multiforce,only:vname_airtemp ! variable name: temperature - USE multiforce,only:vname_spechum ! variable name: specific humidity - USE multiforce,only:vname_airpres ! variable name: surface pressure - USE multiforce,only:vname_swdown ! variable name: downward shortwave radiation - USE multiforce,only:vname_potevap ! variable name: potential ET - USE multiforce,only:vname_q ! variable indice: observed discharge - - USE multiforce,only:ilook_aprecip ! variable indice: precipitation - USE multiforce,only:ilook_airtemp ! variable indice: temperature - USE multiforce,only:ilook_spechum ! variable indice: specific humidity - USE multiforce,only:ilook_airpres ! variable indice: surface pressure - USE multiforce,only:ilook_swdown ! variable indice: downward shortwave radiation - USE multiforce,only:ilook_potevap ! variable indice: potential ET - USE multiforce,only:ilook_q ! variable indice: observed discharge - + USE multiforce,only:gForce_3d ! gridded forcing data + USE multiforce,only:aValid ! time series of lumped forcing/response data + IMPLICIT NONE - + ! input - integer(i4b), intent(in) :: ncid ! NetCDF file ID + type(fuse_info), intent(in) :: info ! info data structure that holds spatial indices + integer(i4b), intent(in) :: itim_start ! index of model time step - start of the period to extract + integer(i4b), intent(in) :: numtim ! number of model time steps to extract + ! output - integer(i4b), intent(out) :: ierr ! error code - character(*), intent(out) :: message ! error message + integer(i4b), intent(out) :: ierr ! error code + character(*), intent(out) :: message ! error message + ! internal - integer(i4b),parameter :: strLen=1024 ! length of character string - type names - character(len=strLen) :: vname ! singlecharacter strings - end type names - type(names),dimension(nForce) :: cVec ! names of character strings integer(i4b) :: iVar ! loop through forcing data - - ! --------------------------------------------------------------------------------------- + real(sp),dimension(:,:,:),allocatable :: gTemp ! temporary 3d grid + integer(i4b) :: nx, ny ! grid dimensions + integer(i4b) :: ystart ! start index iin input file (for MPI) + integer(i4b) :: start_3d(3) ! start indices in NetCDF file + integer(i4b) :: count_3d(3) ! count in NetCDF file + ! initialize error control - ierr=0; message='get_varID/' - - ! get the vector of variable names - cVec(ilook_aprecip)%vname = trim(vname_aprecip) ! variable name: precipitation - cVec(ilook_potevap)%vname = trim(vname_potevap) ! variable name: potential ET - cVec(ilook_airtemp)%vname = trim(vname_airtemp) ! variable name: temperature - cVec(ilook_q)%vname = trim(vname_q) ! variable name: observed discharge - cVec(ilook_spechum)%vname = trim(vname_spechum) ! variable name: specific humidity - cVec(ilook_airpres)%vname = trim(vname_airpres) ! variable name: surface pressure - cVec(ilook_swdown)%vname = trim(vname_swdown) ! variable name: downward shortwave radiation - - do ivar=1,nInput - - ! get the variable ID - ierr = nf90_inq_varid(ncid, trim(cVec(iVar)%vname), ncid_var(ivar)) - if(ierr/=0)then; message=trim(message)//trim(nf90_strerror(ierr))//'[variable='//trim(cVec(iVar)%vname)//']'; return; endif - - END DO - - END SUBROUTINE get_varID - - SUBROUTINE get_gforce(itim,ncid_forc,ierr,message) - ! --------------------------------------------------------------------------------------- - ! Creator: - ! -------- - ! Martyn Clark, 2012 - ! --------------------------------------------------------------------------------------- - ! Purpose: - ! -------- - ! Read NetCDF gridded forcing data for a given time step - ! --------------------------------------------------------------------------------------- - ! Modules Modified: - ! ----------------- - ! MODULE multiforce -- populate structure GFORCE(*,*)%(*) - ! --------------------------------------------------------------------------------------- - USE fuse_fileManager,only:INPUT_PATH ! defines data directory - USE multiforce,only:forcefile ! name of forcing file - USE multiforce,only:vname_aprecip ! variable name: precipitation - USE multiforce,only:vname_airtemp ! variable name: temperature - USE multiforce,only:vname_spechum ! variable name: specific humidity - USE multiforce,only:vname_airpres ! variable name: surface pressure - USE multiforce,only:vname_swdown ! variable name: downward shortwave radiation - USE multiforce,only:vname_potevap ! variable name: potential ET - - USE multiforce,only:ilook_aprecip ! variable indice: precipitation - USE multiforce,only:ilook_airtemp ! variable indice: temperature - USE multiforce,only:ilook_spechum ! variable indice: specific humidity - USE multiforce,only:ilook_airpres ! variable indice: surface pressure - USE multiforce,only:ilook_swdown ! variable indice: downward shortwave radiation - USE multiforce,only:ilook_potevap ! variable indice: potential ET - - USE multiforce,only:nspat1,nspat2,startSpat2 ! dimension lengths - USE multiforce,only:ncid_var ! NetCDF ID for forcing variables - USE multiforce,only:amult_ppt,amult_pet ! multipliers o convert to mm/day - USE multiforce,only:gForce ! gridded forcing data - USE multiforce,only:ancilF ! ancillary forcing data - USE multiforce,only:nForce ! number of forcing variables - - IMPLICIT NONE - ! input - integer(i4b), intent(in) :: itim ! index of model time step - integer(i4b), intent(in) :: ncid_forc ! NetCDF ID for the forcing file - - ! output - integer(i4b), intent(out) :: ierr ! error code - character(*), intent(out) :: message ! error message - ! internal - real(sp),parameter :: amiss=-9999._sp ! value for missing data - integer(i4b),parameter :: strLen=1024 ! length of character string - integer(i4b) :: iVar ! loop through forcing data - real(sp),dimension(:,:,:),allocatable :: gTemp ! temporary grid - type names - character(len=strLen) :: vname ! singlecharacter strings - end type names - type(names),dimension(nForce) :: cVec ! names of character strings - logical(lgt),dimension(nForce) :: lCheck ! check the existence of variables - - ! --------------------------------------------------------------------------------------- - ! initialize error control - ierr=0; message='get_gforce/' - ! --------------------------------------------------------------------------------------- - - ! initialize lCheck - lCheck=.false. - - ! allocate space for the temporary grid - allocate(gTemp(nSpat1,nSpat2,1), stat=ierr) - if(ierr/=0)then; message=trim(message)//'problem allocating space for gTemp'; return; endif - - ! get the vector of variable names - cVec(ilook_aprecip)%vname = trim(vname_aprecip) ! variable name: precipitation - cVec(ilook_potevap)%vname = trim(vname_potevap) ! variable name: potential ET - cVec(ilook_airtemp)%vname = trim(vname_airtemp) ! variable name: temperature - cVec(ilook_spechum)%vname = trim(vname_spechum) ! variable name: specific humidity - cVec(ilook_airpres)%vname = trim(vname_airpres) ! variable name: surface pressure - cVec(ilook_swdown)%vname = trim(vname_swdown) ! variable name: downward shortwave radiation - - ! get forcing grids - ! do ivar=1,nForce - do ivar=1,3 - + ierr=0; message='get_gforce_3d/' + ! --------------------------------------------------------------------------------------- + + ! 3-d grid dimensions + nx = info%space%nx_local + ny = info%space%ny_local + ystart = info%space%y_start_global ! start index in input file (for MPI) + + ! indices for NetCDF rea + start_3d = (/ 1, ystart, itim_start/) + count_3d = (/nx, ny, numtim/) + + ! allocate space for the temporary grid + allocate(gTemp(nx,ny,numtim), stat=ierr) + if(ierr/=0)then; message=trim(message)//'problem allocating space for gTemp'; return; endif + + ! get forcing grids + do ivar = 1, NVAR_FORC + + if(info%space%grid_flag .and. ivar == iQOBS) cycle ! skips qobs if a grid + ! get the data - ierr = nf90_get_var(ncid_forc, ncid_var(ivar), gTemp, start=(/1,startSpat2,iTim/), count=(/nSpat1,nSpat2,1/)); CALL HANDLE_ERR(IERR) + ierr = nf90_get_var(info%files%ncid_forc, info%files%forc%varid(ivar), gTemp, start=start_3d, count=count_3d) if(ierr/=0)then; message=trim(message)//trim(nf90_strerror(ierr)); return; endif - ! save the data in the structure -- and convert fluxes to mm/day - if(trim(cVec(iVar)%vname) == trim(vname_aprecip) )then; gForce(:,:)%ppt = gTemp(:,:,1)*amult_ppt; lCheck(ilook_aprecip) = .true.; endif - if(trim(cVec(iVar)%vname) == trim(vname_potevap) )then; gForce(:,:)%pet = gTemp(:,:,1)*amult_pet; lCheck(ilook_potevap) = .true.; endif - if(trim(cVec(iVar)%vname) == trim(vname_airtemp) )then; gForce(:,:)%temp = gTemp(:,:,1); lCheck(ilook_airtemp) = .true.; endif - - ! save the other variables required to compute PET - !if( trim(cVec(iVar)%vname) == trim(vname_airtemp) )then; ancilF(:,:)%airtemp = gTemp(:,:,1); lCheck(ilook_airtemp) = .true.; endif - !if( trim(cVec(iVar)%vname) == trim(vname_spechum) )then; ancilF(:,:)%spechum = gTemp(:,:,1); lCheck(ilook_spechum) = .true.; endif - !if( trim(cVec(iVar)%vname) == trim(vname_airpres) )then; ancilF(:,:)%airpres = gTemp(:,:,1); lCheck(ilook_airpres) = .true.; endif - !if( trim(cVec(iVar)%vname) == trim(vname_swdown) )then; ancilF(:,:)%swdown = gTemp(:,:,1); lCheck(ilook_swdown) = .true.; endif - - end do ! (loop thru forcing variables) - - PRINT *, 'gForce', gForce - - ! deallocate space for gTemp - deallocate(gTemp, stat=ierr) - if(ierr/=0)then; message=trim(message)//'problem deallocating space for gTemp'; return; endif - - end subroutine get_gforce - - SUBROUTINE get_gforce_3d(itim_start,numtim,ncid_forc,ierr,message) - ! --------------------------------------------------------------------------------------- - ! Creator: - ! -------- - ! Nans Addor, based on Martyn Clark's get_gforce - ! --------------------------------------------------------------------------------------- - ! Purpose: - ! -------- - ! Read NetCDF gridded forcing data for a range of time steps - ! --------------------------------------------------------------------------------------- - ! Modules Modified: - ! ----------------- - ! MODULE multiforce -- populate structure GFORCE_3d(*,*)%(*) - ! --------------------------------------------------------------------------------------- - USE fuse_fileManager,only:INPUT_PATH ! defines data directory - USE multiforce,only:forcefile ! name of forcing file - USE multiforce,only:vname_aprecip ! variable name: precipitation - USE multiforce,only:vname_airtemp ! variable name: temperature - USE multiforce,only:vname_spechum ! variable name: specific humidity - USE multiforce,only:vname_airpres ! variable name: surface pressure - USE multiforce,only:vname_swdown ! variable name: downward shortwave radiation - USE multiforce,only:vname_potevap ! variable name: potential ET - USE multiforce,only:vname_q ! variable name: observed discharge - - USE multiforce,only:ilook_aprecip ! variable indice: precipitation - USE multiforce,only:ilook_airtemp ! variable indice: temperature - USE multiforce,only:ilook_spechum ! variable indice: specific humidity - USE multiforce,only:ilook_airpres ! variable indice: surface pressure - USE multiforce,only:ilook_swdown ! variable indice: downward shortwave radiation - USE multiforce,only:ilook_potevap ! variable indice: potential ET - USE multiforce,only:ilook_q ! variable indice: observed discharge - - USE multiforce,only:nspat1,nspat2,startSpat2 ! dimension lengths - USE multiforce,only:ncid_var ! NetCDF ID for forcing variables - USE multiforce,only:amult_ppt,amult_pet ! multipliers o convert to mm/day - USE multiforce,only:gForce_3d ! gridded forcing data - USE multiforce,only:ancilF_3d ! ancillary forcing data - USE multiforce,only:nForce, nInput ! number of forcing variables - USE multiforce,only:aValid ! time series of lumped forcing/response data - - IMPLICIT NONE - ! input - integer(i4b), intent(in) :: itim_start ! index of model time step - start of the period to extract - integer(i4b), intent(in) :: numtim ! number of model time steps to extract - integer(i4b), intent(in) :: ncid_forc ! NetCDF ID for the forcing file - ! output - integer(i4b), intent(out) :: ierr ! error code - character(*), intent(out) :: message ! error message - ! internal - real(sp),parameter :: amiss=-9999._sp ! value for missing data - integer(i4b),parameter :: strLen=1024 ! length of character string - integer(i4b) :: iVar ! loop through forcing data - real(sp),dimension(:,:,:),allocatable :: gTemp ! temporary 3d grid - type names - character(len=strLen) :: vname ! singlecharacter strings - end type names - type(names),dimension(nForce) :: cVec ! names of character strings - logical(lgt),dimension(nForce) :: lCheck ! check the existence of variables - - ! --------------------------------------------------------------------------------------- - ! initialize error control - ierr=0; message='get_gforce_3d/' - ! --------------------------------------------------------------------------------------- - - ! initialize lCheck - lCheck=.false. - - ! allocate space for the temporary grid - allocate(gTemp(nSpat1,nSpat2,numtim), stat=ierr) - if(ierr/=0)then; message=trim(message)//'problem allocating space for gTemp'; return; endif - - ! get the vector of variable names - cVec(ilook_aprecip)%vname = trim(vname_aprecip) ! variable name: precipitation - cVec(ilook_potevap)%vname = trim(vname_potevap) ! variable name: potential ET - cVec(ilook_airtemp)%vname = trim(vname_airtemp) ! variable name: temperature - cVec(ilook_q)%vname = trim(vname_q) ! variable name: observed discharge - cVec(ilook_spechum)%vname = trim(vname_spechum) ! variable name: specific humidity - cVec(ilook_airpres)%vname = trim(vname_airpres) ! variable name: surface pressure - cVec(ilook_swdown)%vname = trim(vname_swdown) ! variable name: downward shortwave radiation - - ! get forcing grids - do ivar=1,nInput - - ! get the data - ierr = nf90_get_var(ncid_forc, ncid_var(ivar), gTemp, start=(/1,startSpat2,itim_start/), count=(/nSpat1,nSpat2,numtim/)); CALL HANDLE_ERR(IERR) - if(ierr/=0)then; message=trim(message)//trim(nf90_strerror(ierr)); return; endif - - ! save the data in the structure -- and convert fluxes to mm/day - if(trim(cVec(iVar)%vname) == trim(vname_aprecip) )then - - gForce_3d(:,:,1:numtim)%ppt = gTemp(:,:,:)*amult_ppt; lCheck(ilook_aprecip) = .true. - - endif - - if(trim(cVec(iVar)%vname) == trim(vname_potevap) )then - gForce_3d(:,:,1:numtim)%pet = gTemp(:,:,:)*amult_pet; lCheck(ilook_potevap) = .true. - endif - - if(trim(cVec(iVar)%vname) == trim(vname_airtemp) )then - gForce_3d(:,:,1:numtim)%temp = gTemp(:,:,:); lCheck(ilook_airtemp) = .true. - endif - - if(trim(cVec(iVar)%vname) == trim(vname_q) )then - aValid(:,:,1:numtim)%obsq = gTemp(:,:,:); lCheck(ilook_q) = .true. - endif - - ! save the other variables required to compute PET - !if( trim(cVec(iVar)%vname) == trim(vname_airtemp) )then; ancilF(:,:)%airtemp = gTemp(:,:,1); lCheck(ilook_airtemp) = .true.; endif - !if( trim(cVec(iVar)%vname) == trim(vname_spechum) )then; ancilF(:,:)%spechum = gTemp(:,:,1); lCheck(ilook_spechum) = .true.; endif - !if( trim(cVec(iVar)%vname) == trim(vname_airpres) )then; ancilF(:,:)%airpres = gTemp(:,:,1); lCheck(ilook_airpres) = .true.; endif - !if( trim(cVec(iVar)%vname) == trim(vname_swdown) )then; ancilF(:,:)%swdown = gTemp(:,:,1); lCheck(ilook_swdown) = .true.; endif - - end do ! (loop thru forcing variables) - - ! deallocate space for gTemp - deallocate(gTemp, stat=ierr) - if(ierr/=0)then; message=trim(message)//'problem deallocating space for gTemp'; return; endif - - !PRINT *, 'PET', gForce_3d(:,:,1:numtim)%pet - !PRINT *, 'PPT', gForce_3d(:,:,1:numtim)%ppt - !PRINT *, 'TEMP', gForce_3d(:,:,1:numtim)%temp - - end subroutine get_gforce_3d + ! save the data in the structure -- and convert fluxes to mm/day + select case(ivar) + + case (iPRECIP); gForce_3d(:,:,1:numtim)%ppt = gTemp(:,:,:) + case (iTEMP) ; gForce_3d(:,:,1:numtim)%temp = gTemp(:,:,:) + case (iPET) ; gForce_3d(:,:,1:numtim)%pet = gTemp(:,:,:) + case (iQOBS) ; aValid( :,:,1:numtim)%obsq = gTemp(:,:,:) ! TODO: check dimensions (works for nx=1, ny=1) + case default + message=trim(message)//'unable to identify forcing variable' + ierr=10; return + + end select ! identify forcing variable + + end do ! (loop thru forcing variables) + + ! deallocate space for gTemp + deallocate(gTemp, stat=ierr) + if(ierr/=0)then; message=trim(message)//'problem deallocating space for gTemp'; return; endif + + end subroutine get_gforce_3d end module get_gforce_module diff --git a/build/FUSE_SRC/netcdf/get_mbands.f90 b/build/FUSE_SRC/netcdf/get_mbands.f90 deleted file mode 100644 index 6a4e4c8..0000000 --- a/build/FUSE_SRC/netcdf/get_mbands.f90 +++ /dev/null @@ -1,276 +0,0 @@ -module get_mbands_module -USE nrtype -USE netcdf -implicit none -private -!public::GET_MBANDS -public::GET_MBANDS_INFO -contains -! -! SUBROUTINE GET_MBANDS(err,message) -! ! --------------------------------------------------------------------------------------- -! ! Creator: -! ! -------- -! ! Created by Brian Henn, 7/2013 -! ! Based on GETFORCING.f90 by Martyn Clark, 2009 -! ! Updated by Dmitri Kavetski, 14 Sept 2014 AD - Chiefleys Newie -! ! --------------------------------------------------------------------------------------- -! ! Purpose: -! ! -------- -! ! Read ASCII basin band data in BATEA format -! ! --------------------------------------------------------------------------------------- -! ! Modules Modified: -! ! ----------------- -! ! MODULE multibands -- populate structure MBANDS(*)%(*) -! ! --------------------------------------------------------------------------------------- -! use nrtype,only:I4B,LGT,SP -! use utilities_dmsl_kit_FUSE,only:getSpareUnit,stripTrailString -! USE fuse_fileManager,only:INPUT_PATH,SETNGS_PATH ! defines data directory -! USE fuse_fileManager,only:MBANDS_NC ! defines elevation bands -! USE multibands,only:N_BANDS,MBANDS,Z_FORCING ! model band structures -! IMPLICIT NONE -! ! dummies -! integer(I4B), intent(out) :: err -! character(*), intent(out) :: message -! ! internal -! integer(i4b),parameter::lenPath=1024 ! DK/2008/10/21: allows longer file paths -! INTEGER(I4B),DIMENSION(2) :: IERR ! error codes -! INTEGER(I4B) :: IUNIT ! input file unit -! CHARACTER(LEN=lenPath) :: CFILE ! name of control file -! CHARACTER(LEN=lenPath) :: BFILE ! name of band file -! LOGICAL(LGT) :: LEXIST ! .TRUE. if control file exists -! CHARACTER(LEN=lenPath) :: FNAME_INPUT ! name of band input file -! INTEGER(I4B) :: NCOLB ! number of band columns -! INTEGER(I4B) :: IX_Z ! column number for band elevation -! INTEGER(I4B) :: IX_AF ! column number for band area fraction -! INTEGER(I4B) :: NHEADB ! number of band header rows -! INTEGER(I4B) :: BAND_START ! index of start of band info -! INTEGER(I4B) :: BAND_END ! index of end of band info -! INTEGER(I4B) :: IHEAD ! header index -! CHARACTER(LEN=lenPath) :: TMPTXT ! descriptive text -! INTEGER(I4B) :: IBANDS ! band index (input data) -! INTEGER(I4B) :: JBAND ! band index (internal data structure) -! REAL(SP),DIMENSION(:),ALLOCATABLE :: TMPDAT ! one line of data -! ! --------------------------------------------------------------------------------------- -! ! read in control file -! err=0 -! CFILE = TRIM(SETNGS_PATH)//MBANDS_NC ! control file info shared in MODULE directory -! print *, 'Elevation bands info file:',TRIM(CFILE) -! -! INQUIRE(FILE=CFILE,EXIST=LEXIST) ! check that elevation band file exists -! IF (.NOT.LEXIST) THEN -! print *, 'f-GET_MBANDS/control file ',TRIM(CFILE),' for band data does not exist ' -! STOP -! ENDIF -! ! read in parameters of the control files -! CALL getSpareUnit(IUNIT,err,message) ! make sure IUNIT is actually available -! IF (err/=0) THEN -! message="f-GET_MBANDS/weird/&"//message -! err=100; return -! ENDIF -! OPEN(IUNIT,FILE=CFILE,STATUS='old') -! READ(IUNIT,'(A)') FNAME_INPUT ! get input filename -! ! number of columns and column numbers -! READ(IUNIT,*) NCOLB,IX_Z,IX_AF ! band data: number of columns, elevation, area fraction -! READ(IUNIT,*) NHEADB,N_BANDS,BAND_START,BAND_END ! number of headers, number of bands, first band line, last band line -! CLOSE(IUNIT) -! ! fill extra characters in filename with white space -! CALL stripTrailString(string=FNAME_INPUT,trailStart='!') -! IF (N_BANDS.NE.(BAND_END-BAND_START+1)) THEN -! message="f-GET_MBANDS/N_BANDS does not match the number of band lines in the band file" -! err=100; return -! ENDIF -! ! --------------------------------------------------------------------------------------- -! ! read band data -! ALLOCATE(MBANDS(N_BANDS),STAT=IERR(1)) ! (shared in module multibands) -! ALLOCATE(TMPDAT(NCOLB),STAT=IERR(2)) ! (only used in this routine -- deallocate later) -! IF (ANY(IERR.NE.0)) THEN -! message="f-GET_MBANDS/problem allocating data structures" -! err=100; return -! ENDIF -! JBAND = 0 -! BFILE = TRIM(INPUT_PATH)//FNAME_INPUT -! INQUIRE(FILE=BFILE,EXIST=LEXIST) ! check that control file exists -! IF (.NOT.LEXIST) THEN -! print *, 'f-GET_MBANDS/band data file '//TRIM(BFILE)//' does not exist ' -! err=100; return -! ENDIF -! CALL getSpareUnit(IUNIT,err,message) ! make sure IUNIT is actually available -! IF (err/=0) THEN -! message="f-GET_MBANDS/weird/&"//message -! err=100; return -! ENDIF -! OPEN(IUNIT,FILE=BFILE,STATUS='old') -! ! read header -! DO IHEAD=1,NHEADB -! IF (IHEAD.EQ.2) THEN -! READ(IUNIT,*) Z_FORCING ! elevation of the forcing data (shared in module multibands) -! ELSE -! READ(IUNIT,*) TMPTXT ! descriptive text -! ENDIF -! END DO -! -! ! read data -! DO IBANDS=1,N_BANDS -! READ(IUNIT,*) TMPDAT -! JBAND = JBAND+1 -! MBANDS(JBAND)%NUM = INT(TMPDAT(1)) -! MBANDS(JBAND)%Z_MID = TMPDAT(IX_Z) -! MBANDS(JBAND)%AF = TMPDAT(IX_AF) -! -! END DO -! CLOSE(IUNIT) -! DEALLOCATE(TMPDAT, STAT=IERR(1)) -! IF (IERR(1).NE.0) THEN -! message='f-GET_MBANDS/problem deallocating TMPDAT' -! err=100; return -! END IF -! ! --------------------------------------------------------------------------------------- -! END SUBROUTINE GET_MBANDS - - -SUBROUTINE GET_MBANDS_INFO(ELEV_BANDS_NC,err,message) -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Created by Nans Addor, 2/2017 -! Based on Brian Henn's GET_MBANDS, 7/2013 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Read band data (elevation and area fraction) from a NetCDF grid -! --------------------------------------------------------------------------------------- -! Modules Modified: -! ----------------- -! MODULE multibands -- populate structure MBANDS_INFO_3d and Z_FORCING_grid -! --------------------------------------------------------------------------------------- -use nrtype,only:I4B,LGT,SP -use utilities_dmsl_kit_FUSE,only:getSpareUnit,stripTrailString -USE fuse_fileManager,only:INPUT_PATH,SETNGS_PATH ! defines data directory -USE fuse_fileManager,only:MBANDS_NC ! defines elevation bands - -USE multibands,only:N_BANDS,MBANDS,MBANDS_INFO_3d,Z_FORCING,& - Z_FORCING_grid,elev_mask ! model band structures -USE multiforce,only:nspat1,nspat2,startSpat2,NA_VALUE_SP ! dimension lengths, na_value - -IMPLICIT NONE -! dummies -CHARACTER(LEN=1024),intent(in) :: ELEV_BANDS_NC -integer(I4B), intent(out) :: err -character(*), intent(out) :: message -! internal -integer(i4b),parameter::lenPath=1024 ! DK/2008/10/21: allows longer file paths -INTEGER(I4B) :: IERR ! error code -INTEGER(I4B) :: IUNIT ! input file unit -CHARACTER(LEN=lenPath) :: CFILE ! name of control file -CHARACTER(LEN=lenPath) :: BFILE ! name of band file -LOGICAL(LGT) :: LEXIST ! .TRUE. if control file exists -CHARACTER(LEN=lenPath) :: FNAME_INPUT ! name of band input file -INTEGER(I4B) :: NCOLB ! number of band columns -INTEGER(I4B) :: IX_Z ! column number for band elevation -INTEGER(I4B) :: IX_AF ! column number for band area fraction -INTEGER(I4B) :: BAND_START ! index of start of band info -INTEGER(I4B) :: BAND_END ! index of end of band info -INTEGER(I4B) :: IBANDS ! band index (input data) -INTEGER(I4B) :: JBAND ! band index (internal data structure) -INTEGER(I4B) :: NCID_EB ! NetCDF ID for elevation bands file -INTEGER(I4B) :: iSpat1,iSpat2 ! loop through spatial dimensions -REAL(SP),dimension(:,:,:),allocatable :: AF_TEMP, ME_TEMP ! Temporary data structures to store area_frac and mean_area - -! internal: NetCDF read -integer(i4b) :: ivarid_af,ivarid_me ! NetCDF variable ID for area_frac and mean_area -integer(i4b),parameter :: ndims=3 ! number of dimensions for frac_area -integer(i4b) :: dimid_eb ! ID elevation bands -integer(i4b) :: iDimID ! dimension ID -integer(i4b) :: dimLen ! dimension length - -! --------------------------------------------------------------------------------------- - -! read in NetCDF file defining the elevation bands -err=0; ierr=0 -CFILE = TRIM(INPUT_PATH)//ELEV_BANDS_NC ! control file info shared in MODULE directory -print *, 'Loading elevation bands from:',TRIM(CFILE) - -INQUIRE(FILE=CFILE,EXIST=LEXIST) ! check that control file exists -IF (.NOT.LEXIST) THEN - print *, 'f-GET_MBANDS_GRID/NetCDF file ',TRIM(CFILE),' for elevation bands does not exist ' - STOP -ENDIF - -!open netcdf file -err = nf90_open(CFILE, nf90_nowrite, NCID_EB) -if (err.ne.0) write(*,*) trim(message); if (err.gt.0) stop - -! get the dimension IDs for elevation_band -err = nf90_inq_dimid(NCID_EB, 'elevation_band', dimid_eb) -if(err/=0)then; message=trim(message)//trim(nf90_strerror(err)); return; endif - -! get dimension length -err = nf90_inquire_dimension(ncid_eb,dimid_eb,len=dimLen) -if(err/=0)then; message=trim(message)//trim(nf90_strerror(err)); return; endif - -! save the dimension lengths -N_BANDS = dimLen ! number of elevation bands -print *, 'N_BANDS = ', N_BANDS - -! get the variable ID for the fraction of the area contained in each elevation band -err = nf90_inq_varid(NCID_EB, 'area_frac', ivarid_af) -if(err/=0)then; message=trim(message)//trim(nf90_strerror(err)); return; endif -err = nf90_inq_varid(NCID_EB, 'mean_elev', ivarid_me) -if(err/=0)then; message=trim(message)//trim(nf90_strerror(err)); return; endif - -! allocate 1 data stucture -ALLOCATE(MBANDS(N_BANDS),STAT=IERR) - -! allocate data structures -ALLOCATE(Z_FORCING_grid(nspat1,nspat2),MBANDS_INFO_3d(nspat1,nspat2,n_bands),& - AF_TEMP(nspat1,nspat2,n_bands),ME_TEMP(nspat1,nspat2,n_bands),& - elev_mask(nspat1,nspat2),STAT=IERR) - -IF (IERR.NE.0) THEN - message="f-GET_MBANDS/problem allocating elevation band data structures" - err=100; return -ENDIF - -! import data into temporary stuctures -err = nf90_get_var(NCID_EB, ivarid_af, AF_TEMP, start=(/1,startSpat2,1/), count=(/nSpat1,nSpat2,n_bands/)); CALL HANDLE_ERR(err) -if(err/=0)then; message=trim(message)//trim(nf90_strerror(err)); return; endif - -! import data into temporary stuctures -err = nf90_get_var(NCID_EB, ivarid_me, me_TEMP, start=(/1,startSpat2,1/), count=(/nSpat1,nSpat2,n_bands/)); CALL HANDLE_ERR(err) -if(err/=0)then; message=trim(message)//trim(nf90_strerror(err)); return; endif - -! populate MBANDS_INFO_3d, Z_FORCING_grid and elev_mask -DO iSpat2=1,nSpat2 - DO iSpat1=1,nSpat1 - - MBANDS_INFO_3d(iSpat1,iSpat2,:)%Z_MID = me_TEMP(iSpat1,iSpat2,:) - MBANDS_INFO_3d(iSpat1,iSpat2,:)%AF = af_TEMP(iSpat1,iSpat2,:) - Z_FORCING_grid(iSpat1,iSpat2) = sum(me_TEMP(iSpat1,iSpat2,:)*af_TEMP(iSpat1,iSpat2,:)) ! estimate mean elevation of forcing using weighted mean of EB elevation - elev_mask(iSpat1,iSpat2) = me_TEMP(iSpat1,iSpat2,1) .EQ. NA_VALUE_SP ! if mean elevation first band is NA_VALUE, mask this grid cell - - if(.NOT.elev_mask(iSpat1,iSpat2)) THEN ! only check area fraction sum to 1 if not NA_VALUE - - if (abs(sum(MBANDS_INFO_3d(iSpat1,iSpat2,:)%AF)-1).GT.1E-2) then ! check that area fraction sum to 1 - - print *, "The area fraction of all the elevation bands do not add up to 1" - !print *, 'Difference with 1 = ', abs(sum(MBANDS_INFO_3d(iSpat1,iSpat2,:)%AF)-1) - print *, 'AF', MBANDS_INFO_3d(iSpat1,iSpat2,:)%AF - stop - - end if - end if - - END DO -END DO - -err = nf90_close(ncid_eb) -if (err.ne.0) write(*,*) trim(message); if (err.gt.0) stop - -DEALLOCATE(AF_TEMP, ME_TEMP) - -print *, 'Done populating data structures for elevation bands' - -END SUBROUTINE GET_MBANDS_INFO - -end module get_mbands_module diff --git a/build/FUSE_SRC/netcdf/handle_err.f90 b/build/FUSE_SRC/netcdf/handle_err.f90 index 5bea0ae..24a09f6 100644 --- a/build/FUSE_SRC/netcdf/handle_err.f90 +++ b/build/FUSE_SRC/netcdf/handle_err.f90 @@ -1,10 +1,17 @@ -SUBROUTINE HANDLE_ERR(IERR) -! Used to print our error statements from NetCDF calls and stop -USE nrtype -INTEGER(I4B) :: IERR ! error code -include 'netcdf.inc' -IF (IERR.NE.NF_NOERR) THEN - PRINT *, NF_STRERROR(IERR) - STOP -ENDIF -END SUBROUTINE HANDLE_ERR +subroutine handle_err(ierr, where) + use nrtype, only: i4b + use netcdf, only: NF90_NOERR, nf90_strerror + implicit none + + integer(i4b), intent(in) :: ierr + character(len=*), intent(in), optional :: where + + if (ierr /= NF90_NOERR) then + if (present(where)) then + write(*,'(a,1x,a)') 'NetCDF error in '//trim(where)//':', trim(nf90_strerror(ierr)) + else + write(*,'(a)') trim(nf90_strerror(ierr)) + end if + stop 1 + end if +end subroutine handle_err diff --git a/build/FUSE_SRC/netcdf/put_output.f90 b/build/FUSE_SRC/netcdf/put_output.f90 index ed8bae8..ccce0cf 100644 --- a/build/FUSE_SRC/netcdf/put_output.f90 +++ b/build/FUSE_SRC/netcdf/put_output.f90 @@ -1,190 +1,147 @@ -SUBROUTINE PUT_OUTPUT(iSpat1,iSpat2,ITIM,IMOD,IPAR) +module put_output_module - ! --------------------------------------------------------------------------------------- - ! Creator: - ! -------- - ! Martyn Clark, 2007 - ! --------------------------------------------------------------------------------------- - ! Purpose: - ! -------- - ! write NetCDF output files - ! --------------------------------------------------------------------------------------- - USE nrtype ! variable types, etc. - USE model_defn ! model definition (includes filename) - USE metaoutput ! metadata for time-varying model output - USE varextract_module ! interface for the function to extract variables - USE fuse_fileManager,only: Q_ONLY ! only write streamflow to output file? - USE multiforce,ONLY: timDat ! time data - USE multistate, only: ncid_out ! NetCDF output file ID - - IMPLICIT NONE - ! input - INTEGER(I4B), INTENT(IN) :: iSpat1 ! index of 1st spatial dimension - INTEGER(I4B), INTENT(IN) :: iSpat2 ! index of 2nd spatial dimension - INTEGER(I4B), INTENT(IN) :: ITIM ! time step index - INTEGER(I4B), INTENT(IN) :: IMOD ! model index - INTEGER(I4B), INTENT(IN) :: IPAR ! parameter set index - ! internal - LOGICAL(LGT) :: WRITE_VAR ! used to denote if the variable is written - INTEGER(I4B) :: IERR ! error code - !INTEGER(I4B), DIMENSION(5) :: INDX ! indices for time series write - INTEGER(I4B), DIMENSION(3) :: INDX ! indices for time series write - INTEGER(I4B) :: IVAR ! loop through variables - REAL(SP) :: XVAR ! desired variable (SP NOT NECESSARILY SP) - REAL(MSP) :: AVAR ! desired variable (SINGLE PRECISION) - REAL(MSP) :: tDat ! time data - INTEGER(I4B) :: IVAR_ID ! variable ID - INCLUDE 'netcdf.inc' ! use netCDF libraries - ! --------------------------------------------------------------------------------------- - ! open file - IERR = NF_OPEN(TRIM(FNAME_NETCDF_RUNS),NF_WRITE,ncid_out); CALL HANDLE_ERR(IERR) - - ! define indices for model output - INDX = (/iSpat1,iSpat2,ITIM/) - - ! loop through time-varying model output - DO IVAR=1,NOUTVAR - - ! check if there is a need to write the variable - see also def_output - IF (Q_ONLY) THEN - WRITE_VAR=.FALSE. - !IF (TRIM(VNAME(IVAR)).EQ.'ppt') WRITE_VAR=.TRUE. - !IF (TRIM(VNAME(IVAR)).EQ.'pet') WRITE_VAR=.TRUE. - !IF (TRIM(VNAME(IVAR)).EQ.'obsq') WRITE_VAR=.TRUE. - !IF (TRIM(VNAME(IVAR)).EQ.'evap_1') WRITE_VAR=.TRUE. - !IF (TRIM(VNAME(IVAR)).EQ.'evap_2') WRITE_VAR=.TRUE. - IF (TRIM(VNAME(IVAR)).EQ.'q_instnt') WRITE_VAR=.TRUE. - !IF (TRIM(VNAME(IVAR)).EQ.'q_routed') WRITE_VAR=.TRUE. - !IF (TRIM(VNAME(IVAR)).EQ.'watr_1') WRITE_VAR=.TRUE. - !IF (TRIM(VNAME(IVAR)).EQ.'watr_2') WRITE_VAR=.TRUE. - !IF (TRIM(VNAME(IVAR)).EQ.'swe_tot') WRITE_VAR=.TRUE. - IF (.NOT.WRITE_VAR) CYCLE - ENDIF - - ! write the variable - XVAR = VAREXTRACT(VNAME(IVAR)); AVAR=XVAR ! get variable ivar - IERR = NF_INQ_VARID(ncid_out,TRIM(VNAME(IVAR)),IVAR_ID); CALL HANDLE_ERR(IERR) ! get variable ID - IERR = NF_PUT_VAR1_REAL(ncid_out,IVAR_ID,INDX,AVAR); CALL HANDLE_ERR(IERR) ! write data - - END DO ! (ivar) - - ! write the time - tDat = timDat%dtime ! convert to actual single precision - ierr = nf_inq_varid(ncid_out,'time',ivar_id); CALL handle_err(ierr) ! get variable ID for time - ierr = nf_put_var1_real(ncid_out,ivar_id,(/itim/),tDat); CALL handle_err(ierr) ! write time variable - - ! close NetCDF file - IERR = NF_CLOSE(ncid_out) - -END SUBROUTINE PUT_OUTPUT - -SUBROUTINE PUT_GOUTPUT_3D(istart_sim,istart_in,numtim,IPSET) - ! --------------------------------------------------------------------------------------- + use nrtype + use work_types, only: fuse_work + use iso_fortran_env, only: real32 + + use netcdf, only: & + NF90_WRITE, NF90_NOERR, & + nf90_open, nf90_close, nf90_inq_varid, nf90_put_var + + implicit none + private + public :: put_output + +contains + + subroutine put_output(fuseStruct, istart_sim, istart_in, numtim) + + ! ------------------------------------------------------------------------------------- ! Creator: ! -------- ! Nans Addor, based on Martyn Clark's 2007 PUT_OUTPUT - ! --------------------------------------------------------------------------------------- + ! Modified by Martyn Clark to use the elevation band dimension and add parameter derivatives, 12/2025 + ! Modified by Martyn Clark to use output buffers in fuseStruct + ! ------------------------------------------------------------------------------------- ! Purpose: ! -------- - ! write a 3D data structure to the NetCDF output file - ! --------------------------------------------------------------------------------------- - USE nrtype ! variable types, etc. - USE model_defn ! model definition (includes filename) - USE metaoutput ! metadata for time-varying model output - USE varextract_module ! interface for the function to extract variables - USE fuse_fileManager,only: Q_ONLY ! only write streamflow to output file? - - USE multiforce, ONLY: timDat,time_steps ! time data - USE multistate, only: ncid_out ! NetCDF output file ID - USE multiforce, ONLY: nspat1,nspat2,startSpat2 ! spatial dimensions - USE multiforce, ONLY: gForce_3d ! test only - USE multiforce, only: GRID_FLAG ! .true. if distributed - - IMPLICIT NONE + ! Write a 3D (or 4D) data structure to the NetCDF output file (chunk write) + ! ------------------------------------------------------------------------------------- + + ! subroutines + use varextract_module, only: varextract_3d + + ! metadata / config + use model_defn, only: fname_netcdf_runs + use metaoutput, only: noutvar, vname, isband + use multiparam, only: numpar + use multibands, only: mbands_var_4d, n_bands + use multiforce, only: time_steps, nspat1, nspat2 + use fuse_filemanager, only: q_only + + ! global + use globaldata, only: ncid_out + + implicit none ! input - INTEGER(I4B), INTENT(IN) :: istart_sim ! index start time step relative to numtim_sim - INTEGER(I4B), INTENT(IN) :: istart_in ! index start time step relative to numtim_in - for time dimension - INTEGER(I4B), INTENT(IN) :: numtim ! number of time steps to write - INTEGER(I4B), INTENT(IN) :: IPSET ! parameter set index - - ! internal - LOGICAL(LGT) :: WRITE_VAR ! used to denote if the variable is written - INTEGER(I4B) :: IERR ! error code - INTEGER(I4B), DIMENSION(:), ALLOCATABLE :: IND_START ! start indices - INTEGER(I4B), DIMENSION(:), ALLOCATABLE :: IND_COUNT ! count indices - INTEGER(I4B) :: IVAR ! loop through variables - REAL(SP) :: XVAR ! desired variable (SP NOT NECESSARILY SP) - REAL(MSP) :: AVAR ! desired variable (SINGLE PRECISION) - REAL(SP), DIMENSION(nspat1,nspat2,numtim) :: XVAR_3d ! desired variable (SINGLE PRECISION) - REAL(MSP), DIMENSION(nspat1,nspat2,numtim) :: AVAR_3d ! desired variable (SINGLE PRECISION) - REAL(MSP), DIMENSION(:), ALLOCATABLE :: tDat ! time data - REAL(SP), DIMENSION(:), ALLOCATABLE :: time_steps_sub ! time data - INTEGER(I4B) :: IVAR_ID ! variable ID - INCLUDE 'netcdf.inc' ! use netCDF libraries - - ! open file - IERR = NF_OPEN(TRIM(FNAME_NETCDF_RUNS),NF_WRITE,ncid_out); CALL HANDLE_ERR(IERR) - - ! define indices for model output - ! if enabling parallel output you need 1,startSpat2 instead of 1,1 below - - IF(.NOT.GRID_FLAG)THEN - allocate(IND_START(4),IND_COUNT(4)) - IND_START = (/1,1,IPSET,istart_sim/) ! the indices start at 1, i.e. first element in (1, 1, ..., 1) - IND_COUNT = (/nspat1,nspat2,1,numtim/) ! third element is 1 because we only write results for one parameter set at a time - ELSE - allocate(IND_START(3),IND_COUNT(3)) - IND_START = (/1,1,istart_sim/) ! no parameter dimension in grid mode - IND_COUNT = (/nspat1,nspat2,numtim/) - ENDIF - - PRINT *, 'IND_START=', IND_START - PRINT *, 'IND_COUNT=', IND_COUNT - - ! loop through time-varying model output - DO IVAR=1,NOUTVAR - - ! check if there is a need to write the variable - see also def_output - IF (Q_ONLY) THEN - WRITE_VAR=.FALSE. - !IF (TRIM(VNAME(IVAR)).EQ.'ppt') WRITE_VAR=.TRUE. - !IF (TRIM(VNAME(IVAR)).EQ.'pet') WRITE_VAR=.TRUE. - !IF (TRIM(VNAME(IVAR)).EQ.'obsq') WRITE_VAR=.TRUE. - !IF (TRIM(VNAME(IVAR)).EQ.'evap_1') WRITE_VAR=.TRUE. - !IF (TRIM(VNAME(IVAR)).EQ.'evap_2') WRITE_VAR=.TRUE. - !IF (TRIM(VNAME(IVAR)).EQ.'q_instnt') WRITE_VAR=.TRUE. - IF (TRIM(VNAME(IVAR)).EQ.'q_routed') WRITE_VAR=.TRUE. - !IF (TRIM(VNAME(IVAR)).EQ.'watr_1') WRITE_VAR=.TRUE. - !IF (TRIM(VNAME(IVAR)).EQ.'watr_2') WRITE_VAR=.TRUE. - !IF (TRIM(VNAME(IVAR)).EQ.'swe_tot') WRITE_VAR=.TRUE. - !IF (TRIM(VNAME(IVAR)).EQ.'qsurf') WRITE_VAR=.TRUE. - !IF (TRIM(VNAME(IVAR)).EQ.'oflow_1') WRITE_VAR=.TRUE. - !IF (TRIM(VNAME(IVAR)).EQ.'qintf_1') WRITE_VAR=.TRUE. - !IF (TRIM(VNAME(IVAR)).EQ.'oflow_2') WRITE_VAR=.TRUE. - !IF (TRIM(VNAME(IVAR)).EQ.'qbase_2') WRITE_VAR=.TRUE. - IF (.NOT.WRITE_VAR) CYCLE ! start new iteration of do loop, i.e. skip writting variable - ENDIF - - ! write the variable - XVAR_3d = VAREXTRACT_3d(VNAME(IVAR),numtim) ! get variable - AVAR_3d = XVAR_3d ! convert format - IERR = NF_INQ_VARID(ncid_out,TRIM(VNAME(IVAR)),IVAR_ID); CALL HANDLE_ERR(IERR) ! get variable ID - IERR = NF_PUT_VARA_REAL(ncid_out,IVAR_ID,IND_START,IND_COUNT,AVAR_3d); CALL HANDLE_ERR(IERR) ! write data - - END DO ! (ivar) - - ! write the time - allocate(tDat(numtim),time_steps_sub(numtim)) - - time_steps_sub = time_steps(istart_in:(istart_in+numtim-1)) ! extract time for subperiod - tDat = time_steps_sub ! convert to actual single precision - ierr = nf_inq_varid(ncid_out,'time',ivar_id); CALL handle_err(ierr) ! get variable ID for time - ierr = nf_put_vara_real(ncid_out,ivar_id,(/istart_sim/),(/numtim/),tDat); CALL handle_err(ierr) ! write time variable - - ! close NetCDF file - IERR = NF_CLOSE(ncid_out) - - deallocate(tDat,time_steps_sub,IND_START,IND_COUNT) - -END SUBROUTINE PUT_GOUTPUT_3D + type(fuse_work), intent(in) :: fuseStruct + integer(i4b), intent(in) :: istart_sim + integer(i4b), intent(in) :: istart_in + integer(i4b), intent(in) :: numtim + + ! locals + logical(lgt) :: write_var + integer(i4b) :: ierr + integer(i4b) :: ivar + integer(i4b) :: ivar_id + + integer(i4b), dimension(3) :: start3, count3 + integer(i4b), dimension(4) :: start4_band, count4_band + integer(i4b), dimension(4) :: start4_param, count4_param + + real(real32), dimension(nspat1, nspat2, numtim) :: avar_3d + + real(real32), dimension(nspat1, nspat2, n_bands, numtim) :: avar_4d_band + ! placeholder for future param-derivative write + real(real32), dimension(nspat1, nspat2, numpar, numtim) :: avar_4d_param + + real(real32), dimension(numtim) :: time_steps_sub + + character(len=32) :: subname + subname="put_output.f90" + + ! ----------------------------------------------------------------------------- + ! dimension lists (Fortran nf90 uses 1-based indices) + start3 = (/1, 1, istart_sim/) + count3 = (/nspat1, nspat2, numtim/) + + start4_band = (/1, 1, 1, istart_sim/) + count4_band = (/nspat1, nspat2, n_bands, numtim/) + + start4_param = (/1, 1, 1, istart_sim/) + count4_param = (/nspat1, nspat2, numpar, numtim/) + + ! open file (already defined elsewhere via DEF_OUTPUT) + ierr = nf90_open(trim(fname_netcdf_runs), NF90_WRITE, ncid_out) + call handle_err(ierr, trim(subname)//":nf90_open") + + ! loop through variables with time-varying model output + do ivar = 1, noutvar + + ! optional "Q_ONLY" filter + if (q_only) then + write_var = .false. + if (trim(vname(ivar)) == 'q_instnt') write_var = .true. + if (trim(vname(ivar)) == 'q_routed') write_var = .true. + if (.not. write_var) cycle + end if + + ! get var id + ierr = nf90_inq_varid(ncid_out, trim(vname(ivar)), ivar_id) + call handle_err(ierr, trim(subname)//":nf90_inq_varid:"//trim(vname(ivar))) + + if (.not. isband(ivar)) then + + ! 3-d variable -- extract from the output buffers in fuseStruct%chunk + call varextract_3d(fuseStruct%chunk, vname(ivar), nspat1, nspat2, numtim, avar_3d) + + ierr = nf90_put_var(ncid_out, ivar_id, avar_3d, start=start3, count=count3) + call handle_err(ierr, trim(subname)//":nf90_put_var(3d):"//trim(vname(ivar))) + + else + + ! 4-d elevation band variable (stored in MBANDS_VAR_4d) + select case (trim(vname(ivar))) + case ('swe_z'); avar_4d_band = mbands_var_4d(:,:,:,1:numtim)%swe + case ('snwacml_z'); avar_4d_band = mbands_var_4d(:,:,:,1:numtim)%snowaccmltn + case ('snwmelt_z'); avar_4d_band = mbands_var_4d(:,:,:,1:numtim)%snowmelt + case default; stop trim(subname)//":unknown band var:"//trim(vname(ivar)) + end select + + ierr = nf90_put_var(ncid_out, ivar_id, avar_4d_band, start=start4_band, count=count4_band) + call handle_err(ierr, trim(subname)//":nf90_put_var(4d band):"//trim(vname(ivar))) + + end if + + ! future: param-derivative writes would go here using count4_param/start4_param + ! e.g. name = trim(vname(ivar))//'__dFlux_dParam' + + end do + + ! write time + time_steps_sub = real(time_steps(istart_in:(istart_in + numtim - 1)), kind(real32)) + + ierr = nf90_inq_varid(ncid_out, 'time', ivar_id) + call handle_err(ierr, trim(subname)//":nf90_inq_varid:time") + + ierr = nf90_put_var(ncid_out, ivar_id, time_steps_sub, start=(/istart_sim/), count=(/numtim/)) + call handle_err(ierr, trim(subname)//":nf90_put_var:time") + + ! close + ierr = nf90_close(ncid_out) + call handle_err(ierr, trim(subname)//":nf90_close") + + end subroutine put_output + +end module put_output_module diff --git a/build/FUSE_SRC/netcdf/put_params.f90 b/build/FUSE_SRC/netcdf/put_params.f90 index 46430b9..2c4401c 100644 --- a/build/FUSE_SRC/netcdf/put_params.f90 +++ b/build/FUSE_SRC/netcdf/put_params.f90 @@ -1,80 +1,95 @@ -SUBROUTINE PUT_PARAMS(IPAR) -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2007 -! Modified by Nans Addor to include snow module -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! write NetCDF output files -- model parameters -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -USE model_defn ! model definition structures (includes filename) -USE model_defnames ! define variable names -USE metaparams ! metadata for model parameters -USE multistats, ONLY:MSTATS ! provide access to error message -USE parextract_module ! extract parameters -IMPLICIT NONE -! input -INTEGER(I4B), INTENT(IN) :: IPAR ! parameter set index -! internal -INTEGER(I4B) :: IERR,NCID ! error code; NetCDF ID -INTEGER(I4B), DIMENSION(1) :: INDX ! indices for parameter write -INTEGER(I4B) :: IVAR ! loop through parameters -REAL(SP) :: XPAR ! desired parameter -REAL(MSP) :: APAR ! convert to SP (need for SP write) -INTEGER(I4B) :: IVAR_ID ! variable ID -INTEGER(I4B), PARAMETER :: NDESC=9 ! number of model descriptors - TODO: THIS SHOULDN'T BE HARD-CODED -INTEGER(I4B), PARAMETER :: NCHAR=10 ! length of model descriptors - TODO: THIS SHOULDN'T BE HARD-CODED -INTEGER(I4B), DIMENSION(3) :: ISTART ! starting position for array write -INTEGER(I4B), DIMENSION(3) :: ICOUNT ! count for array write -CHARACTER(LEN=10) :: TXTVEC ! single model descriptor -include 'netcdf.inc' ! use netCDF libraries -! --------------------------------------------------------------------------------------- +MODULE PUT_PARAMS_MODULE -! open file -IERR = NF_OPEN(TRIM(FNAME_NETCDF_PARA),NF_WRITE,NCID); CALL HANDLE_ERR(IERR) + USE nrtype ! variable types, etc. - ! define indices for model output - INDX = (/IPAR/) + implicit none - ! loop through model parameters - DO IVAR=1,NOUTPAR ! NOUTPAR is stored in module metaparams + private + public :: PUT_PARAMS - XPAR = PAREXTRACT(PNAME(IVAR)); APAR=XPAR ! get parameter PNAME(IVAR) - IERR = NF_INQ_VARID(NCID,TRIM(PNAME(IVAR)),IVAR_ID); CALL HANDLE_ERR(IERR) ! get variable ID - IERR = NF_PUT_VAR1_REAL(NCID,IVAR_ID,INDX,APAR); CALL HANDLE_ERR(IERR) ! write data + contains - END DO ! (ivar) + SUBROUTINE PUT_PARAMS(IPAR) + ! --------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark, 2007 + ! Modified by Nans Addor to include snow module + ! Modified by Martyn Clark to write snow bands as a vector, 12/2025 + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! write NetCDF output files -- model parameters + ! --------------------------------------------------------------------------------------- + USE model_defn, only: FNAME_NETCDF_PARA ! model definition structures (includes filename) + USE metaparams, only: NOUTPAR ! number of model parameters + USE metaparams, only: PNAME, PDESC, PUNIT ! metadata for all model parameters + USE metaparams, only: isBand ! logical flag to define vars with elevation dimension + USE multibands, only: MBANDS, N_BANDS ! information for elevation bands + USE parextract_module ! extract parameters + IMPLICIT NONE + ! input + INTEGER(I4B), INTENT(IN) :: IPAR ! parameter set index + ! internal + INTEGER(I4B) :: IERR,NCID ! error code; NetCDF ID + INTEGER(I4B), DIMENSION(1) :: INDX ! indices for parameter write + integer(i4b), dimension(2) :: start2 ! 2-d start vector + integer(i4b), dimension(2) :: count2 ! 2-d count vector + INTEGER(I4B) :: IVAR ! loop through parameters + REAL(SP) :: XPAR ! desired parameter + REAL(MSP) :: APAR ! convert to SP (need for SP write) + integer(i4b) :: ib ! index of elevation bands + REAL(SP) , DIMENSION(N_BANDS) :: XVEC ! desired vector + REAL(MSP) , DIMENSION(N_BANDS) :: AVEC ! convert to SP (need for SP write) + INTEGER(I4B) :: IVAR_ID ! variable ID + include 'netcdf.inc' ! use netCDF libraries + ! --------------------------------------------------------------------------------------- + + ! open file + IERR = NF_OPEN(TRIM(FNAME_NETCDF_PARA),NF_WRITE,NCID) + CALL HANDLE_ERR(IERR) + + ! define indices for model output + INDX = (/IPAR/) + + ! loop through model parameters + DO IVAR=1,NOUTPAR ! NOUTPAR is stored in module metaparams + + ! get variable ID + IERR = NF_INQ_VARID(NCID,TRIM(PNAME(IVAR)),IVAR_ID) + CALL HANDLE_ERR(IERR) + + ! standard scalar parameters + if(.not.isBand(iVar))then + + ! extract parameter and write data + XPAR = PAREXTRACT(PNAME(IVAR)); APAR=XPAR ! get parameter PNAME(IVAR) + IERR = NF_PUT_VAR1_REAL(NCID, IVAR_ID, INDX, APAR); CALL HANDLE_ERR(IERR) ! write data + + ! elevation band parameters + else + + ! extract vector + select case (trim(PNAME(IVAR))) + case ('AF') ; xVec(1:n_bands) = [ (MBANDS(ib)%info%AF, ib=1,n_bands) ] + case ('Z_MID'); xVec(1:n_bands) = [ (MBANDS(ib)%info%Z_MID, ib=1,n_bands) ] + case default; stop "put_params.f90: cannot identify elevation band variable" + end select + aVec = xVec ! use MSP to write single precision + + ! write row at par=IPAR + start2 = (/ IPAR, 1 /) + count2 = (/ 1, n_bands /) + IERR = NF_PUT_VARA_REAL(NCID, IVAR_ID, start2, count2, aVec(1:n_bands)) + CALL HANDLE_ERR(IERR) + + endif ! elevation band switch + + END DO ! (ivar) + + ! close NetCDF file + IERR = NF_CLOSE(NCID) + ! --------------------------------------------------------------------------------------- + END SUBROUTINE PUT_PARAMS - ! put model description - !IERR = NF_INQ_VARID(NCID,'model_description',IVAR_ID); CALL HANDLE_ERR(IERR) - - ! print *, 'Writing model decisions to this NetCDF file:', TRIM(FNAME_NETCDF) - ! - ! DO IVAR=1,NDESC - ! ! extract text string - ! IF (IVAR.EQ.1) TXTVEC = desc_int2str(SMODL%iRFERR) - ! IF (IVAR.EQ.2) TXTVEC = desc_int2str(SMODL%iARCH1) - ! IF (IVAR.EQ.3) TXTVEC = desc_int2str(SMODL%iARCH2) - ! IF (IVAR.EQ.4) TXTVEC = desc_int2str(SMODL%iQSURF) - ! IF (IVAR.EQ.5) TXTVEC = desc_int2str(SMODL%iQPERC) - ! IF (IVAR.EQ.6) TXTVEC = desc_int2str(SMODL%iESOIL) - ! IF (IVAR.EQ.7) TXTVEC = desc_int2str(SMODL%iQINTF) - ! IF (IVAR.EQ.8) TXTVEC = desc_int2str(SMODL%iQ_TDH) - ! IF (IVAR.EQ.9) TXTVEC = desc_int2str(SMODL%iSNOWM) - ! - ! ISTART = (/ 1,IVAR,IMOD/) ! starting position of array - ! ICOUNT = (/NCHAR, 1, 1/) ! number of array elements (one descriptor, one model) - ! IERR = NF_PUT_VARA_TEXT(NCID,IVAR_ID,ISTART,ICOUNT,TXTVEC); CALL HANDLE_ERR(IERR) - ! END DO - ! put error message - !ISTART = (/ 1,IMOD,IPAR/) ! starting position of array - !ICOUNT = (/LEN(MSTATS%ERR_MESSAGE), 1, 1/) ! number of array elements (one descriptor, one model) - !IERR = NF_INQ_VARID(NCID,'error_message',IVAR_ID); CALL HANDLE_ERR(IERR) - !IERR = NF_PUT_VARA_TEXT(NCID,IVAR_ID,ISTART,ICOUNT,MSTATS%ERR_MESSAGE); CALL HANDLE_ERR(IERR) -! close NetCDF file -IERR = NF_CLOSE(NCID) -! --------------------------------------------------------------------------------------- -END SUBROUTINE PUT_PARAMS +END MODULE PUT_PARAMS_MODULE diff --git a/build/FUSE_SRC/netcdf/read_elevbands.f90 b/build/FUSE_SRC/netcdf/read_elevbands.f90 new file mode 100644 index 0000000..2a6b79b --- /dev/null +++ b/build/FUSE_SRC/netcdf/read_elevbands.f90 @@ -0,0 +1,225 @@ +module read_elevbands_module + !! + !! Read elevation-band information (area fraction + mean elevation) from an elevation-band NetCDF file, + !! supporting either: + !! - rank-3 variables: (spat1, spat2, band) [grid] + !! - rank-2 variables: (spat2, band) [list/HRU], mapped internally to (nx=1, ny=spat2, band) + !! + !! This module reads into REAL arrays (af, zmid) so you can then copy into your derived type + !! MBANDS_INFO_3d(:,:,:)%AF / %Z_MID without baking that type into the reader. + !! + use nrtype + use netcdf + use info_types, only: fuse_info + use info_types, only: space_info + use data_types, only: domain_data + implicit none + private + + public :: read_elevbands + +contains + + subroutine read_elevbands(info, domain, ierr, message) + + use globaldata, only: NA_VALUE_SP + + implicit none + + type(fuse_info) , intent(in) :: info ! domain info + type(domain_data) , intent(inout) :: domain ! domain data + + integer(i4b) , intent(out) :: ierr + character(*) , intent(out) :: message + + character(len=1024) :: eb_file ! elev bands file + + integer(i4b) :: ncid_eb + integer(i4b) :: vid_af, vid_me + integer(i4b) :: nd_af, nd_me + integer(i4b) :: i, j, ib + real(sp) :: afsum + real(sp) :: af(info%space%nx_local, info%space%ny_local, info%snow%n_bands) + real(sp) :: zmid(info%space%nx_local, info%space%ny_local, info%snow%n_bands) + character(len=1024) :: cmessage + + ierr = 0 + message = "read_elevbands_arrays/" + + ! ---- get name of file that holds elevation bands ---- + eb_file = trim(info%files%input_path)//trim(info%files%elevbands_file) + + ! --- open NetCDF file for reading (nf90_nowrite) --- + ierr = nf90_open(trim(eb_file), nf90_nowrite, ncid_eb) + if(ierr /= nf90_noerr) then + message = trim(message)//"nf90_open failed: "//trim(nf90_strerror(ierr))// & + " [file="//trim(eb_file)//"]" + return + endif + + ! ---- lookup varids ---- + ierr = nf90_inq_varid(ncid_eb, "area_frac", vid_af) + if (ierr /= nf90_noerr) then + message = trim(message)//"nf90_inq_varid(area_frac) failed: "//trim(nf90_strerror(ierr)) + return + end if + + ierr = nf90_inq_varid(ncid_eb, "mean_elev", vid_me) + if (ierr /= nf90_noerr) then + message = trim(message)//"nf90_inq_varid(mean_elev) failed: "//trim(nf90_strerror(ierr)) + return + end if + + ! ---- inquire ranks (we support 2D or 3D) ---- + ierr = nf90_inquire_variable(ncid_eb, vid_af, ndims=nd_af) + if (ierr /= nf90_noerr) then + message = trim(message)//"inquire_variable(area_frac) failed: "//trim(nf90_strerror(ierr)) + return + end if + + ierr = nf90_inquire_variable(ncid_eb, vid_me, ndims=nd_me) + if (ierr /= nf90_noerr) then + message = trim(message)//"inquire_variable(mean_elev) failed: "//trim(nf90_strerror(ierr)) + return + end if + + if (nd_af /= nd_me) then + message = trim(message)//"area_frac and mean_elev have different rank; unsupported." + ierr=20; return + end if + if (nd_af /= 2 .and. nd_af /= 3) then + message = trim(message)//"expected rank-2 (spat2,band) or rank-3 (spat1,spat2,band)" + ierr=20; return + end if + + ! ---- read into canonical arrays ---- + + !! Reads either: + !! rank-3 (spat1,spat2,band) into out3d(nx,ny,band) + !! rank-2 (spat2,band) into out3d(1,ny,band) [requires nx_local==1] + + call read_elev_vars_to_canonical(ncid_eb, vid_af, vid_me, nd_af, info%space, info%snow%n_bands, & + af, zmid, ierr, cmessage) + if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif + + ! ---- compute weighted mean elevation + mask + AF sanity check ---- + do j = 1, info%space%ny_local + do i = 1, info%space%nx_local + + domain%z_forcing(i,j) = sum(zmid(i,j,:) * af(i,j,:)) + + ! if mean elevation first band is NA_VALUE, mask this grid cell + domain%elev_mask(i,j) = zmid(i,j,1) == NA_VALUE_SP ! TODO check comparison against real + if(.NOT.domain%elev_mask(i,j)) THEN ! only check area fraction sum to 1 if not NA_VALUE + + do ib=1,info%snow%n_bands + domain%bands_info(i,j,ib)%num = ib + domain%bands_info(i,j,ib)%af = af(i,j,ib) + domain%bands_info(i,j,ib)%z_mid = zmid(i,j,ib) + end do + + afsum = sum(af(i,j,:)) + if (abs(afsum - 1.0_sp) > 1.0e-2_sp) then + write(message,'(a,2(i0,1x),a,f10.6)') trim(message)// & + "AF sum != 1 at (i,j)= ", i, j, " sum=", afsum + ierr=20; return + end if + + endif ! if masked + + end do + end do + + ! --- close NetCDF file --- + ierr = nf90_close(ncid_eb) + if(ierr /= nf90_noerr) then + message = trim(message)//"nf90_close failed: "//trim(nf90_strerror(ierr))// & + " [file="//trim(eb_file)//"]" + return + endif + + end subroutine read_elevbands + + + ! ------------------------------------------------------------------------------------------------------------------- + ! ------------------------------------------------------------------------------------------------------------------- + + ! ----- private subroutine read_elev_vars_to_canonical (read elevation-band variables) ------------------------------ + + subroutine read_elev_vars_to_canonical(ncid, vid_af, vid_me, ndims, space, n_bands, af, zmid, ierr, message) + + !---------------------------------------------------------------------------------------- + ! Read elevation-band variables (area_frac, mean_elev) from the elevation-band NetCDF + ! file and map them into the model’s canonical (nx_local, ny_local, n_bands) layout. + ! Supports both grid layout (spat1,spat2,band) and list layout (spat2,band → nx=1). + ! Computes weighted mean forcing elevation for the local subdomain. + !---------------------------------------------------------------------------------------- + + implicit none + + integer(i4b), intent(in) :: ncid, vid_af, vid_me, ndims + type(space_info), intent(in) :: space + integer(i4b), intent(in) :: n_bands + + real(sp), intent(out) :: af(space%nx_local, space%ny_local, n_bands) + real(sp), intent(out) :: zmid(space%nx_local, space%ny_local, n_bands) + + integer(i4b), intent(out) :: ierr + character(*), intent(out) :: message + + integer(i4b) :: start3(3), count3(3) + integer(i4b) :: start2(2), count2(2) + real(sp) :: tmp2_af(space%ny_local, n_bands) + real(sp) :: tmp2_me(space%ny_local, n_bands) + + ierr = 0 + message = "read_elev_vars_to_canonical/" + + if (ndims == 3) then + + start3 = (/ 1, space%y_start_global, 1 /) + count3 = (/ space%nx_local, space%ny_local, n_bands /) + + ierr = nf90_get_var(ncid, vid_af, af, start=start3, count=count3) + if (ierr /= nf90_noerr) then + message = trim(message)//"nf90_get_var(area_frac) failed: "//trim(nf90_strerror(ierr)) + return + endif + + ierr = nf90_get_var(ncid, vid_me, zmid, start=start3, count=count3) + if (ierr /= nf90_noerr) then + message = trim(message)//"nf90_get_var(mean_elev) failed: "//trim(nf90_strerror(ierr)) + return + endif + + else + + ! rank-2 list case + if (space%nx_local /= 1) then + message = trim(message)//"rank-2 elevband file requires nx_local=1" + ierr = 20; return + endif + + start2 = (/ space%y_start_global, 1 /) + count2 = (/ space%ny_local, n_bands /) + + ierr = nf90_get_var(ncid, vid_af, tmp2_af, start=start2, count=count2) + if (ierr /= nf90_noerr) then + message = trim(message)//"nf90_get_var(area_frac list) failed: "//trim(nf90_strerror(ierr)) + return + endif + + ierr = nf90_get_var(ncid, vid_me, tmp2_me, start=start2, count=count2) + if (ierr /= nf90_noerr) then + message = trim(message)//"nf90_get_var(mean_elev list) failed: "//trim(nf90_strerror(ierr)) + return + endif + + af(1,:,:) = tmp2_af + zmid(1,:,:) = tmp2_me + + endif + + end subroutine + +end module read_elevbands_module diff --git a/build/FUSE_SRC/netcdf/slob b/build/FUSE_SRC/netcdf/slob deleted file mode 100755 index c8b4cbe..0000000 Binary files a/build/FUSE_SRC/netcdf/slob and /dev/null differ diff --git a/build/FUSE_SRC/physics/conserve_clamp.f90 b/build/FUSE_SRC/physics/conserve_clamp.f90 new file mode 100644 index 0000000..374b444 --- /dev/null +++ b/build/FUSE_SRC/physics/conserve_clamp.f90 @@ -0,0 +1,303 @@ +module conserve_clamp_module + + ! data types + use nrtype ! variable types, etc. + use work_types, only: fuse_work ! fuse work structure + USE model_defn ! model definition structure + USE model_defnames + USE model_numerix + + implicit none + + private + public :: conserve_clamp + + contains + + SUBROUTINE conserve_clamp(fuseStruct,DT,ERROR_FLAG) + ! --------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark, 2009 + ! Modified by Martyn Clark to pass fuse work data structure, 12/2025 + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! Ensure states are within bounds, and disaggregate fluxes if necessary + ! - This routine handles the very rare case (less than one-in-a-million) where + ! the implicit Euler solver fails to converge + ! --------------------------------------------------------------------------------------- + IMPLICIT NONE + ! input/output + type(fuse_work) , intent(inout) :: fuseStruct ! fuse work structure + REAL(SP), INTENT(IN) :: DT ! time step + LOGICAL(LGT), INTENT(OUT) :: ERROR_FLAG ! .TRUE. if extrapolation error + ! internal + REAL(SP) :: XMIN ! very small number + INTEGER(I4B) :: ISTT ! loop through model states + REAL(SP) :: ERROR_LOSS ! error (L/T) + REAL(SP) :: TOTAL_LOSS ! total loss (L/T) + ! --------------------------------------------------------------------------------------- + ! associate variables with elements of data structure + associate(& + M_FLUX => fuseStruct%step%flux , & ! fluxes + BSTATE => fuseStruct%step%state0 , & ! state variables (start of step) + ESTATE => fuseStruct%step%state1 , & ! trial state variables (end of step) + MPARAM => fuseStruct%par%param_adjust , & ! adjustable model parameters + DPARAM => fuseStruct%par%param_derive & ! derived model parameters + ) ! (associate) + ! --------------------------------------------------------------------------------------- + ERROR_FLAG=.FALSE. ! initialize with no extrapolation error + ! --------------------------------------------------------------------------------------- + XMIN = FRACSTATE_MIN ! used to avoid zero derivatives + ! --------------------------------------------------------------------------------------- + DO ISTT=1,NSTATE + if (M_FLUX%QSURF.LT.0._sp) print *, 'start ', desc_int2str(cstate(istt)%isname), M_FLUX%QSURF + ERROR_LOSS = 0._SP ! initialize state error + SELECT CASE(CSTATE(ISTT)%iSNAME) + ! --------------------------------------------------------------------------------------- + ! (1) FIX STATES IN THE UPPER LAYER + ! ------------------------------------------------------------------------------------- + CASE (iopt_TENS1A) + IF (ESTATE%TENS_1A.LT.XMIN*DPARAM%MAXTENS_1A) THEN ! too much drainage + ERROR_LOSS = (ESTATE%TENS_1A - XMIN*DPARAM%MAXTENS_1A)/DT ! error (L/T) + TOTAL_LOSS = M_FLUX%QSURF + M_FLUX%EVAP_1A ! total loss (L/T) + M_FLUX%QSURF = M_FLUX%QSURF + (M_FLUX%QSURF /TOTAL_LOSS)*ERROR_LOSS + M_FLUX%EVAP_1A = M_FLUX%EVAP_1A + (M_FLUX%EVAP_1A/TOTAL_LOSS)*ERROR_LOSS + ESTATE%TENS_1A = XMIN*DPARAM%MAXTENS_1A ! (correct state) + ERROR_FLAG = .TRUE. + ENDIF + IF (ESTATE%TENS_1A.GT.DPARAM%MAXTENS_1A) THEN ! too much input + ERROR_LOSS = (ESTATE%TENS_1A - DPARAM%MAXTENS_1A)/DT + M_FLUX%RCHR2EXCS = M_FLUX%RCHR2EXCS + ERROR_LOSS + ESTATE%TENS_1A = DPARAM%MAXTENS_1A ! (correct state) + ESTATE%TENS_1B = BSTATE%TENS_1B + & ! (correct subsequent states) + (M_FLUX%RCHR2EXCS - M_FLUX%EVAP_1B - M_FLUX%TENS2FREE_1)*DT + ERROR_FLAG = .TRUE. + ENDIF + M_FLUX%ERR_TENS_1A = ERROR_LOSS + ! ------------------------------------------------------------------------------------- + CASE (iopt_TENS1B) + IF (ESTATE%TENS_1B.LT.XMIN*DPARAM%MAXTENS_1B) THEN ! too much drainage + ERROR_LOSS = (ESTATE%TENS_1B - XMIN*DPARAM%MAXTENS_1B)/DT + M_FLUX%EVAP_1B = M_FLUX%EVAP_1B + ERROR_LOSS + ESTATE%TENS_1B = XMIN*DPARAM%MAXTENS_1B ! (correct state) + ERROR_FLAG = .TRUE. + ENDIF + IF (ESTATE%TENS_1B.GT.DPARAM%MAXTENS_1B) THEN ! too much input + ERROR_LOSS = (ESTATE%TENS_1B - DPARAM%MAXTENS_1B)/DT + M_FLUX%TENS2FREE_1 = M_FLUX%TENS2FREE_1 + ERROR_LOSS + ESTATE%TENS_1B = DPARAM%MAXTENS_1B ! (correct state) + ESTATE%FREE_1 = BSTATE%FREE_1 + & ! (correct subsequent states) + (M_FLUX%TENS2FREE_1 - M_FLUX%QPERC_12 - M_FLUX%QINTF_1 - M_FLUX%OFLOW_1)*DT + ERROR_FLAG = .TRUE. + ENDIF + M_FLUX%ERR_TENS_1B = ERROR_LOSS + ! ------------------------------------------------------------------------------------- + CASE (iopt_TENS_1) + IF (ESTATE%TENS_1.LT.XMIN*DPARAM%MAXTENS_1) THEN ! too much drainage + ERROR_LOSS = (ESTATE%TENS_1 - XMIN*DPARAM%MAXTENS_1)/DT ! error (L/T) + TOTAL_LOSS = M_FLUX%QSURF + M_FLUX%EVAP_1 ! total loss (L/T) + M_FLUX%QSURF = M_FLUX%QSURF + (M_FLUX%QSURF /TOTAL_LOSS)*ERROR_LOSS + M_FLUX%EVAP_1 = M_FLUX%EVAP_1 + (M_FLUX%EVAP_1/TOTAL_LOSS)*ERROR_LOSS + ESTATE%TENS_1 = XMIN*DPARAM%MAXTENS_1 ! (correct state) + ERROR_FLAG = .TRUE. + ENDIF + IF (ESTATE%TENS_1.GT.DPARAM%MAXTENS_1) THEN ! too much input + ERROR_LOSS = (ESTATE%TENS_1 - DPARAM%MAXTENS_1)/DT + M_FLUX%TENS2FREE_1 = M_FLUX%TENS2FREE_1 + (ESTATE%TENS_1 - DPARAM%MAXTENS_1)/DT + ESTATE%TENS_1 = DPARAM%MAXTENS_1 ! (correct state) + ESTATE%FREE_1 = BSTATE%FREE_1 + & ! (correct subsequent states) + (M_FLUX%TENS2FREE_1 - M_FLUX%QPERC_12 - M_FLUX%QINTF_1 - M_FLUX%OFLOW_1)*DT + ERROR_FLAG = .TRUE. + ENDIF + M_FLUX%ERR_TENS_1 = ERROR_LOSS + ! ------------------------------------------------------------------------------------- + CASE (iopt_FREE_1) + IF (ESTATE%FREE_1.LT.XMIN*DPARAM%MAXFREE_1) THEN ! too much drainage + ERROR_LOSS = (ESTATE%FREE_1 - XMIN*DPARAM%MAXFREE_1)/DT ! error (L/T) + TOTAL_LOSS = M_FLUX%QPERC_12 + M_FLUX%QINTF_1 ! total loss (L/T) + M_FLUX%QPERC_12 = M_FLUX%QPERC_12 + (M_FLUX%QPERC_12/TOTAL_LOSS)*ERROR_LOSS + M_FLUX%QINTF_1 = M_FLUX%QINTF_1 + (M_FLUX%QINTF_1 /TOTAL_LOSS)*ERROR_LOSS + ESTATE%FREE_1 = XMIN*DPARAM%MAXFREE_1 ! (correct state) + ! correct subsequent states (deal appropriately with percolation) + ! NOTE: do this here because only necessary to make corrections if M_FLUX%QPERC_12 changes + SELECT CASE(SMODL%iARCH2) + CASE(iopt_tens2pll_2) ! tension reservoir plus two parallel tanks + ! fix overflow fluxes + M_FLUX%TENS2FREE_2 = MAX(0._SP, M_FLUX%QPERC_12*(1._SP-MPARAM%PERCFRAC) - (DPARAM%MAXTENS_2 - BSTATE%TENS_2 )/DT) + M_FLUX%OFLOW_2A = MAX(0._SP, (M_FLUX%QPERC_12*(MPARAM%PERCFRAC/2._SP) + M_FLUX%TENS2FREE_2/2._SP) & + - (DPARAM%MAXFREE_2A - BSTATE%FREE_2A)/DT) + M_FLUX%OFLOW_2B = MAX(0._SP, (M_FLUX%QPERC_12*(MPARAM%PERCFRAC/2._SP) + M_FLUX%TENS2FREE_2/2._SP) & + - (DPARAM%MAXFREE_2B - BSTATE%FREE_2B)/DT) + M_FLUX%OFLOW_2 = M_FLUX%OFLOW_2A + M_FLUX%OFLOW_2B + ! fix states + ESTATE%TENS_2 = BSTATE%TENS_2 + & + (M_FLUX%QPERC_12*(1._SP-MPARAM%PERCFRAC) - M_FLUX%EVAP_2 - M_FLUX%TENS2FREE_2)*DT + ESTATE%FREE_2A = BSTATE%FREE_2A + & + (M_FLUX%QPERC_12*(MPARAM%PERCFRAC/2._SP) + M_FLUX%TENS2FREE_2/2._SP - M_FLUX%QBASE_2A & + - M_FLUX%OFLOW_2A)*DT + ESTATE%FREE_2B = BSTATE%FREE_2B + & + (M_FLUX%QPERC_12*(MPARAM%PERCFRAC/2._SP) + M_FLUX%TENS2FREE_2/2._SP - M_FLUX%QBASE_2B & + - M_FLUX%OFLOW_2B)*DT + CASE(iopt_unlimfrc_2,iopt_unlimpow_2,iopt_fixedsiz_2) ! single state + ! NOTE: M_FLUX%OFLOW_2 and M_FLUX%EVAP_2 only calculated for 'fixedsiz_2' + ! fix overflow + IF (SMODL%iARCH2.EQ.iopt_fixedsiz_2) & + M_FLUX%OFLOW_2 = MAX(0._SP, M_FLUX%QPERC_12 - (MPARAM%MAXWATR_2 - BSTATE%WATR_2)/DT) + ! fix states + ESTATE%WATR_2 = BSTATE%WATR_2 + & + (M_FLUX%QPERC_12 - M_FLUX%EVAP_2 - M_FLUX%QBASE_2 - M_FLUX%OFLOW_2)*DT + CASE DEFAULT; stop ' SMODL%iARCH2 must be iopt_tens2pll_2, iopt_unlimfrc_2, iopt_unlimpow_2 or iopt_fixedsiz_2 ' + END SELECT ! deal with modified percolation of water to the lower layer + ERROR_FLAG = .TRUE. + ENDIF + IF (ESTATE%FREE_1.GT.DPARAM%MAXFREE_1) THEN ! too much input + ERROR_LOSS = (ESTATE%FREE_1 - DPARAM%MAXFREE_1)/DT + M_FLUX%OFLOW_1 = M_FLUX%OFLOW_1 + ERROR_LOSS + ESTATE%FREE_1 = DPARAM%MAXFREE_1 ! (correct state) + ERROR_FLAG = .TRUE. + ENDIF + M_FLUX%ERR_FREE_1 = ERROR_LOSS + ! ------------------------------------------------------------------------------------- + CASE (iopt_WATR_1) + IF (ESTATE%WATR_1.LT.XMIN*MPARAM%MAXWATR_1) THEN ! too much drainage + ERROR_LOSS = (ESTATE%WATR_1 - XMIN*MPARAM%MAXWATR_1)/DT ! error (L/T) + TOTAL_LOSS = M_FLUX%QSURF + M_FLUX%EVAP_1 + M_FLUX%QPERC_12 + M_FLUX%QINTF_1 + M_FLUX%QSURF = M_FLUX%QSURF + (M_FLUX%QSURF /TOTAL_LOSS)*ERROR_LOSS + M_FLUX%EVAP_1 = M_FLUX%EVAP_1 + (M_FLUX%EVAP_1 /TOTAL_LOSS)*ERROR_LOSS + M_FLUX%QINTF_1 = M_FLUX%QINTF_1 + (M_FLUX%QINTF_1 /TOTAL_LOSS)*ERROR_LOSS + M_FLUX%QPERC_12 = M_FLUX%QPERC_12 + (M_FLUX%QPERC_12/TOTAL_LOSS)*ERROR_LOSS + ESTATE%WATR_1 = XMIN*MPARAM%MAXWATR_1 ! (correct state) + ! correct subsequent states (deal appropriately with percolation) + ! NOTE: do this here because only necessary to make corrections if M_FLUX%QPERC_12 changes + SELECT CASE(SMODL%iARCH2) + CASE(iopt_tens2pll_2) ! tension reservoir plus two parallel tanks + ! fix overflow fluxes + M_FLUX%TENS2FREE_2 = MAX(0._SP, M_FLUX%QPERC_12*(1._SP-MPARAM%PERCFRAC) - (DPARAM%MAXTENS_2 - BSTATE%TENS_2 )/DT) + M_FLUX%OFLOW_2A = MAX(0._SP, (M_FLUX%QPERC_12*(MPARAM%PERCFRAC/2._SP) + M_FLUX%TENS2FREE_2/2._SP) & + - (DPARAM%MAXFREE_2A - BSTATE%FREE_2A)/DT) + M_FLUX%OFLOW_2B = MAX(0._SP, (M_FLUX%QPERC_12*(MPARAM%PERCFRAC/2._SP) + M_FLUX%TENS2FREE_2/2._SP) & + - (DPARAM%MAXFREE_2B - BSTATE%FREE_2B)/DT) + M_FLUX%OFLOW_2 = M_FLUX%OFLOW_2A + M_FLUX%OFLOW_2B + ! fix states + ESTATE%TENS_2 = BSTATE%TENS_2 + & + (M_FLUX%QPERC_12*(1._SP-MPARAM%PERCFRAC) - M_FLUX%EVAP_2 - M_FLUX%TENS2FREE_2)*DT + ESTATE%FREE_2A = BSTATE%FREE_2A + & + (M_FLUX%QPERC_12*(MPARAM%PERCFRAC/2._SP) + M_FLUX%TENS2FREE_2/2._SP - M_FLUX%QBASE_2A & + - M_FLUX%OFLOW_2A)*DT + ESTATE%FREE_2B = BSTATE%FREE_2B + & + (M_FLUX%QPERC_12*(MPARAM%PERCFRAC/2._SP) + M_FLUX%TENS2FREE_2/2._SP - M_FLUX%QBASE_2B & + - M_FLUX%OFLOW_2B)*DT + CASE(iopt_unlimfrc_2,iopt_unlimpow_2,iopt_fixedsiz_2) ! single state + ! NOTE: M_FLUX%OFLOW_2 and M_FLUX%EVAP_2 only calculated for 'fixedsiz_2' + ! fix overflow + IF (SMODL%iARCH2.EQ.iopt_fixedsiz_2) & + M_FLUX%OFLOW_2 = MAX(0._SP, M_FLUX%QPERC_12 - (MPARAM%MAXWATR_2 - BSTATE%WATR_2)/DT) + ! fix states + ESTATE%WATR_2 = BSTATE%WATR_2 + & + (M_FLUX%QPERC_12 - M_FLUX%EVAP_2 - M_FLUX%QBASE_2 - M_FLUX%OFLOW_2)*DT + CASE DEFAULT; stop ' SMODL%iARCH2 must be iopt_tens2pll_2, iopt_unlimfrc_2, iopt_unlimpow_2 or iopt_fixedsiz_2 ' + END SELECT ! deal with modified percolation of water to the lower layer + ERROR_FLAG = .TRUE. + ENDIF + IF (ESTATE%WATR_1.GT.MPARAM%MAXWATR_1) THEN ! too much input + ERROR_LOSS = (ESTATE%WATR_1 - MPARAM%MAXWATR_1)/DT + M_FLUX%OFLOW_1 = M_FLUX%OFLOW_1 + ERROR_LOSS + ESTATE%WATR_1 = MPARAM%MAXWATR_1 ! (correct state) + ERROR_FLAG = .TRUE. + ENDIF + M_FLUX%ERR_WATR_1 = ERROR_LOSS + ! ------------------------------------------------------------------------------------- + ! (2) FIX STATES IN THE LOWER LAYER + ! ------------------------------------------------------------------------------------- + CASE (iopt_TENS_2) + IF (ESTATE%TENS_2.LT.XMIN*DPARAM%MAXTENS_2) THEN ! too much drainage + ERROR_LOSS = (ESTATE%TENS_2 - XMIN*DPARAM%MAXTENS_2)/DT + M_FLUX%EVAP_2 = M_FLUX%EVAP_2 + ERROR_LOSS + ESTATE%TENS_2 = XMIN*DPARAM%MAXTENS_2 ! (correct state) + ERROR_FLAG = .TRUE. + ENDIF + IF (ESTATE%TENS_2.GT.DPARAM%MAXTENS_2) THEN ! too much input + ERROR_LOSS = (ESTATE%TENS_2 - DPARAM%MAXTENS_2)/DT + M_FLUX%TENS2FREE_2 = M_FLUX%TENS2FREE_2 + ERROR_LOSS + ESTATE%TENS_2 = DPARAM%MAXTENS_2 ! (correct state) + ! ** correct subsequent states (NOTE: 2 parallel tanks always coupled with a tension store) + ! fix overflow fluxes + M_FLUX%OFLOW_2A = MAX(0._SP, (M_FLUX%QPERC_12*(MPARAM%PERCFRAC/2._SP) + M_FLUX%TENS2FREE_2/2._SP) & + - (DPARAM%MAXFREE_2A - BSTATE%FREE_2A)/DT) + M_FLUX%OFLOW_2B = MAX(0._SP, (M_FLUX%QPERC_12*(MPARAM%PERCFRAC/2._SP) + M_FLUX%TENS2FREE_2/2._SP) & + - (DPARAM%MAXFREE_2B - BSTATE%FREE_2B)/DT) + M_FLUX%OFLOW_2 = M_FLUX%OFLOW_2A + M_FLUX%OFLOW_2B + ! fix states + ESTATE%FREE_2A = BSTATE%FREE_2A + & + (M_FLUX%QPERC_12*(MPARAM%PERCFRAC/2._SP) + M_FLUX%TENS2FREE_2/2._SP & + - M_FLUX%QBASE_2A - M_FLUX%OFLOW_2A)*DT + ESTATE%FREE_2B = BSTATE%FREE_2B + & + (M_FLUX%QPERC_12*(MPARAM%PERCFRAC/2._SP) + M_FLUX%TENS2FREE_2/2._SP & + - M_FLUX%QBASE_2B - M_FLUX%OFLOW_2B)*DT + ERROR_FLAG = .TRUE. + ENDIF + M_FLUX%ERR_TENS_2 = ERROR_LOSS + ! ------------------------------------------------------------------------------------- + CASE (iopt_FREE2A) + IF (ESTATE%FREE_2A.LT.XMIN*DPARAM%MAXFREE_2A) THEN ! too much drainage + ERROR_LOSS = (ESTATE%FREE_2A - XMIN*DPARAM%MAXFREE_2A)/DT + M_FLUX%QBASE_2A = M_FLUX%QBASE_2A + ERROR_LOSS + ESTATE%FREE_2A = XMIN*DPARAM%MAXFREE_2A ! (correct state) + ERROR_FLAG = .TRUE. + ENDIF + IF (ESTATE%FREE_2A.GT.DPARAM%MAXFREE_2A) THEN ! too much input + ERROR_LOSS = (ESTATE%FREE_2A - DPARAM%MAXFREE_2A)/DT + M_FLUX%OFLOW_2A = M_FLUX%OFLOW_2A + ERROR_LOSS + ESTATE%FREE_2A = DPARAM%MAXFREE_2A ! (correct state) + ERROR_FLAG = .TRUE. + ENDIF + M_FLUX%ERR_FREE_2A = ERROR_LOSS + ! ------------------------------------------------------------------------------------- + CASE (iopt_FREE2B) + IF (ESTATE%FREE_2B.LT.XMIN*DPARAM%MAXFREE_2B) THEN ! too much drainage + ERROR_LOSS = (ESTATE%FREE_2B - XMIN*DPARAM%MAXFREE_2B)/DT + M_FLUX%QBASE_2B = M_FLUX%QBASE_2B + ERROR_LOSS + ESTATE%FREE_2B = XMIN*DPARAM%MAXFREE_2B ! (correct state) + ERROR_FLAG = .TRUE. + ENDIF + IF (ESTATE%FREE_2B.GT.DPARAM%MAXFREE_2B) THEN ! too much input + ERROR_LOSS = (ESTATE%FREE_2B - DPARAM%MAXFREE_2B)/DT + M_FLUX%OFLOW_2B = M_FLUX%OFLOW_2B + ERROR_LOSS + ESTATE%FREE_2B = DPARAM%MAXFREE_2B ! (correct state) + ERROR_FLAG = .TRUE. + ENDIF + M_FLUX%ERR_FREE_2B = ERROR_LOSS + ! ------------------------------------------------------------------------------------- + CASE (iopt_WATR_2) + IF (ESTATE%WATR_2.LT.XMIN*MPARAM%MAXWATR_2) THEN ! too much drainage + ERROR_LOSS = (ESTATE%WATR_2 - XMIN*MPARAM%MAXWATR_2)/DT ! error (L/T) + TOTAL_LOSS = M_FLUX%EVAP_2 + M_FLUX%QBASE_2 + M_FLUX%EVAP_2 = M_FLUX%EVAP_2 + (M_FLUX%EVAP_2 /TOTAL_LOSS)*ERROR_LOSS + M_FLUX%QBASE_2 = M_FLUX%QBASE_2 + (M_FLUX%QBASE_2/TOTAL_LOSS)*ERROR_LOSS + ESTATE%WATR_2 = XMIN*MPARAM%MAXWATR_2 ! (correct state) + ERROR_FLAG = .TRUE. + ENDIF + IF (ESTATE%WATR_2.GT.MPARAM%MAXWATR_2) THEN + ERROR_LOSS = (ESTATE%WATR_2 - MPARAM%MAXWATR_2)/DT + M_FLUX%OFLOW_2 = M_FLUX%OFLOW_2 + ERROR_LOSS + ESTATE%WATR_2 = MPARAM%MAXWATR_2 ! (correct state) + ERROR_FLAG = .TRUE. + ENDIF + M_FLUX%ERR_WATR_2 = ERROR_LOSS + CASE DEFAULT; STOP ' cannot find state in fix_states() ' + END SELECT ! select state variable for processing + if (M_FLUX%QSURF.LT.0._sp) print *, 'end ', desc_int2str(cstate(istt)%isname), M_FLUX%QSURF + END DO ! loop through state variables + ! --------------------------------------------------------------------------------------- + ! compute derived fluxes, if necessary + IF (SMODL%iARCH2.EQ.iopt_tens2pll_2) THEN ! tension reservoir plus two parallel tanks + M_FLUX%QBASE_2 = M_FLUX%QBASE_2A + M_FLUX%QBASE_2B + M_FLUX%OFLOW_2 = M_FLUX%OFLOW_2A + M_FLUX%OFLOW_2B + ENDIF + ! --------------------------------------------------------------------------------------- + end associate ! end association with variables in the data structures + END SUBROUTINE conserve_clamp + +end module conserve_clamp_module diff --git a/build/FUSE_SRC/physics/evap_lower_diff.f90 b/build/FUSE_SRC/physics/evap_lower_diff.f90 new file mode 100644 index 0000000..add3b25 --- /dev/null +++ b/build/FUSE_SRC/physics/evap_lower_diff.f90 @@ -0,0 +1,94 @@ +module EVAP_LOWER_DIFF_MODULE + + implicit none + + private + public :: EVAP_LOWER_DIFF + +contains + + SUBROUTINE EVAP_LOWER_DIFF(fuseStruct, want_dflux) + ! ------------------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark, 2007 + ! Modified by Martyn Clark to create a differentiable model, 12/25 + ! ------------------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! Computes evaporation from the lower soil layer + ! ------------------------------------------------------------------------------------------------- + USE nrtype ! variable types, etc. + USE work_types, only: fuse_work ! fuse work data type + USE model_defn ! model definition structure + USE model_defnames + IMPLICIT NONE + ! input-output + type(fuse_work), intent(inout) :: fuseStruct ! fuse work structure + logical(lgt), intent(in), optional :: want_dflux ! if we want flux derivatives + ! internal + logical(lgt) :: comp_dflux ! flag to compute flux derivatives + ! ------------------------------------------------------------------------------------------------- + ! associate variables with elements of data structure + associate(& + TSTATE => fuseStruct%step%state1 , & ! trial state variables (end of step) + MFORCE => fuseStruct%step%force , & ! model forcing data + M_FLUX => fuseStruct%step%flux , & ! fluxes + MPARAM => fuseStruct%par%param_adjust , & ! adjustable model parameters + DPARAM => fuseStruct%par%param_derive & ! derived model parameters + ) ! (associate) + ! ------------------------------------------------------------------------------------------------- + + ! check the need to compute flux derivatives + comp_dflux = .false.; if(present(want_dflux)) comp_dflux = want_dflux + + ! --------------------------------------------------------------------------------------- + SELECT CASE(SMODL%iARCH2) ! lower layer architecture + CASE(iopt_tens2pll_2,iopt_fixedsiz_2) + + ! ------------------------------------------------------------------------------------- + SELECT CASE(SMODL%iARCH1) + ! ------------------------------------------------------------------------------------ + CASE(iopt_tension1_1,iopt_onestate_1) ! lower-layer evap is valid + + ! ------------------------------------------------------------------------------------ + ! use different evaporation schemes for the lower layer + ! ----------------------------------------------------- + SELECT CASE(SMODL%iESOIL) + CASE(iopt_sequential) + M_FLUX%EVAP_2 = (MFORCE%PET-M_FLUX%EVAP_1) * (TSTATE%TENS_2/DPARAM%MAXTENS_2) + CASE(iopt_rootweight) + M_FLUX%EVAP_2 = MFORCE%PET * DPARAM%RTFRAC2 * (TSTATE%TENS_2/DPARAM%MAXTENS_2) + CASE DEFAULT + print *, "SMODL%iESOIL must be either iopt_sequential or iopt_rootweight" + END SELECT ! (evaporation schemes) + + ! ------------------------------------------------------------------------------------ + CASE(iopt_tension2_1) ! lower-layer evap is zero + M_FLUX%EVAP_2 = 0._sp + + ! ------------------------------------------------------------------------------------ + CASE DEFAULT + print *, "SMODL%iARCH1 must be iopt_tension2_1, iopt_tension1_1, or iopt_onestate_1" + STOP + + ! ------------------------------------------------------------------------------------ + END SELECT ! (upper-layer architechure) + + ! -------------------------------------------------------------------------------------- + CASE(iopt_unlimfrc_2,iopt_unlimpow_2,iopt_topmdexp_2) + M_FLUX%EVAP_2 = 0._sp + + ! -------------------------------------------------------------------------------------- + CASE DEFAULT + print *, "SMODL%iARCH2 must be iopt_tens2pll_2, iopt_unlimfrc_2, iopt_unlimpow_2" + print *, " iopt_topmdexp_2, or iopt_fixedsiz_2" + STOP + + END SELECT + ! --------------------------------------------------------------------------------------- + + end associate ! end association with variables in the data structures + END SUBROUTINE EVAP_LOWER_DIFF + +end module EVAP_LOWER_DIFF_module diff --git a/build/FUSE_SRC/physics/evap_upper_diff.f90 b/build/FUSE_SRC/physics/evap_upper_diff.f90 new file mode 100644 index 0000000..7a3c8b0 --- /dev/null +++ b/build/FUSE_SRC/physics/evap_upper_diff.f90 @@ -0,0 +1,139 @@ +module EVAP_UPPER_DIFF_module + + implicit none + + private + public :: EVAP_UPPER_DIFF + +contains + + SUBROUTINE EVAP_UPPER_DIFF(fuseStruct, want_dflux) + ! ------------------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark, 2007 + ! Modified by Martyn Clark to create a differentiable model, 12/25 + ! ------------------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! Computes evaporation from the upper soil layer + ! ------------------------------------------------------------------------------------------------- + USE nrtype ! variable types, etc. + USE work_types, only: fuse_work ! fuse work type + USE model_defn ! model definition structure + USE model_defnames ! model definition names + use smoothers, only : sfrac, dsfrac ! smoothed fraction, derivative + IMPLICIT NONE + ! input-output + type(fuse_work), intent(inout) :: fuseStruct ! fuse work structure + logical(lgt), intent(in), optional :: want_dflux ! if we want flux derivatives + ! local variables + logical(lgt) :: comp_dflux ! flag to compute flux derivatives + integer(i4b) :: iState ! state index + real(sp) :: phi ! smoothed fraction of total tension storage (0,1] + real(sp) :: phi_1a ! smoothed fraction of primary tension storage (0,1] + real(sp) :: phi_1b ! smoothed fraction of secondary tension storage (0,1] + real(sp) :: maxRate ! maximum forcing + real(sp) :: maxRate_1a ! maximum forcing for the primary tension tank + real(sp) :: maxRate_1b ! maximum forcing for the secondary tension tank + real(sp) :: dphi_dx ! derivative in fraction w.r.t. storage + real(sp) :: devap_dx ! derivative in evaporation w.r.t. storage + real(sp), parameter :: ms=1.e-4_sp ! smoothing in sfrac(smax) function + ! ------------------------------------------------------------------------------------------------- + ! associate variables with elements of data structure + associate(& + TSTATE => fuseStruct%step%state1 , & ! trial state variables (end of step) + MFORCE => fuseStruct%step%force , & ! model forcing data + M_FLUX => fuseStruct%step%flux , & ! fluxes + dfx_dS => fuseStruct%adj%df_dS , & ! deriv in fluxes w.r.t. states + MPARAM => fuseStruct%par%param_adjust , & ! adjustable model parameters + DPARAM => fuseStruct%par%param_derive & ! derived model parameters + ) ! (associate) + ! ------------------------------------------------------------------------------------------------- + + ! check the need to compute flux derivatives + comp_dflux = .false.; if(present(want_dflux)) comp_dflux = want_dflux + + ! --------------------------------------------------------------------------------------- + SELECT CASE(SMODL%iARCH1) ! upper layer architecture + + ! -------------------------------------------------------------------------------------- + CASE(iopt_tension2_1) ! tension storage sub-divided into recharge and excess + ! -------------------------------------------------------------------------------------- + + ! calculate the smoothed fraction of tension storage (NOTE: use WATR_1) + phi_1a = sfrac(TSTATE%TENS_1A, DPARAM%MAXTENS_1A, ms) + phi_1b = sfrac(TSTATE%TENS_1B, DPARAM%MAXTENS_1B, ms) + + ! calculate the maximum evap rate for the storage + SELECT CASE(SMODL%iESOIL) + CASE(iopt_sequential) + maxrate_1a = MFORCE%PET + maxrate_1b = MFORCE%PET - MFORCE%PET*phi_1a + CASE(iopt_rootweight) + maxrate_1a = MFORCE%PET * MPARAM%RTFRAC1 + maxrate_1b = MFORCE%PET * DPARAM%RTFRAC2 + CASE DEFAULT; stop "evap_upper: SMODL%iESOIL must be either iopt_sequential or iopt_rootweight" + END SELECT + + ! ----- compute flux ---------------------------------------------------------------- + M_FLUX%EVAP_1A = maxrate_1a*phi_1a + M_FLUX%EVAP_1B = maxrate_1b*phi_1b + M_FLUX%EVAP_1 = M_FLUX%EVAP_1A + M_FLUX%EVAP_1B + + ! ----- compute derivatives --------------------------------------------------------------------- + if(comp_dflux) stop "evap_upper: derivatives for iopt_tension2_1 not implemented yet" + + ! -------------------------------------------------------------------------------------- + CASE(iopt_tension1_1,iopt_onestate_1) ! single tension store or single state + ! -------------------------------------------------------------------------------------- + + ! zero fluxes not used + M_FLUX%EVAP_1A = 0._sp + M_FLUX%EVAP_1B = 0._sp + + select case(SMODL%iARCH1) + case(iopt_tension1_1); phi = sfrac(TSTATE%TENS_1, DPARAM%MAXTENS_1, ms) + case(iopt_onestate_1); phi = sfrac(TSTATE%WATR_1, DPARAM%MAXTENS_1, ms) ! NOTE: use WATR_1 + end select ! no need for default because checked above + + ! calculate the maximum evap rate for the upper layer + SELECT CASE(SMODL%iESOIL) + CASE(iopt_sequential); maxRate = MFORCE%PET + CASE(iopt_rootweight); maxRate = MFORCE%PET*MPARAM%RTFRAC1 + CASE DEFAULT; stop "evap_upper: SMODL%iESOIL must be either iopt_sequential or iopt_rootweight" + END SELECT ! (evaporation schemes) + + ! ----- compute flux ---------------------------------------------------------------- + M_FLUX%EVAP_1 = maxRate*phi + + ! ----- compute derivatives --------------------------------------------------------- + if(comp_dflux)then + + ! calculate the derivative in the smoothed fraction of tension storage + select case(SMODL%iARCH1) + case(iopt_tension1_1); dphi_dx = dsfrac(TSTATE%TENS_1, DPARAM%MAXTENS_1, ms) + case(iopt_onestate_1); dphi_dx = dsfrac(TSTATE%WATR_1, DPARAM%MAXTENS_1, ms) ! NOTE: use WATR_1 + end select ! no need for default because checked above + + ! calculate the derivative in the maximum rate + devap_dx = maxRate*dphi_dx + + ! populate derivative vector + do iState=1,nState + select case(cState(iState)%iSNAME) + case (iopt_TENS_1); dfx_dS(iState)%EVAP_1 = devap_dx ! exists if one tension tank + case (iopt_WATR_1); dfx_dS(iState)%EVAP_1 = devap_dx ! exists if one state in the upper layer + end select ! no default needed + end do ! looping through states + + endif ! if computing derivatives + + CASE DEFAULT; stop "evap_upper: SMODL%iARCH1 must be iopt_tension2_1, iopt_tension1_1, or iopt_onestate_1" + END SELECT ! (upper-layer architecture) + + + end associate ! end association with variables in the data structures + END SUBROUTINE EVAP_UPPER_DIFF + +end module EVAP_UPPER_DIFF_module diff --git a/build/FUSE_SRC/physics/fix_ovshoot.f90 b/build/FUSE_SRC/physics/fix_ovshoot.f90 new file mode 100644 index 0000000..7a314f6 --- /dev/null +++ b/build/FUSE_SRC/physics/fix_ovshoot.f90 @@ -0,0 +1,161 @@ +module overshoot_module + + USE nrtype ! variable types, etc. + USE work_types, only: fuse_work ! fuse work data type + USE model_defn, only: CSTATE,NSTATE,SMODL ! model definition structures + USE model_defnames + implicit none + + private + public :: get_bounds + public :: fix_ovshoot + public :: sigmoid + +contains + + ! --------------------------------------------------------------------------------------- + ! --------------------------------------------------------------------------------------- + ! Numerically-stable softplus with sharpness alpha + pure real(sp) function softplus(x, alpha) result(y) + implicit none + real(sp), intent(in) :: x, alpha + real(sp) :: ax + ax = alpha * x + if (ax > 0.0_sp) then + y = (ax + log(1.0_sp + exp(-ax))) / alpha + else + y = log(1.0_sp + exp(ax)) / alpha + end if + end function softplus + ! --------------------------------------------------------------------------------------- + ! --------------------------------------------------------------------------------------- + ! Sigmoid + pure real(sp) function sigmoid(z) result(s) + real(sp), intent(in) :: z + if (z >= 0._sp) then + s = 1._sp / (1._sp + exp(-z)) + else + s = exp(z) / (1._sp + exp(z)) + end if + end function sigmoid + ! --------------------------------------------------------------------------------------- + ! --------------------------------------------------------------------------------------- + + ! --------------------------------------------------------------------------------------- + ! --------------------------------------------------------------------------------------- + SUBROUTINE fix_ovshoot(X_TRY, lower, upper, dclamp) + ! --------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark, 2025 + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! Apply soft constraints to model state variables + ! --------------------------------------------------------------------------------------- + ! input/output + REAL(SP), DIMENSION(:), INTENT(INOUT) :: X_TRY ! vector of model states + real(sp), dimension(:), intent(in) :: lower ! lower bound + real(sp), dimension(:), intent(in) :: upper ! upper bound + real(sp), dimension(:), intent(out) :: dclamp ! derivative + ! internal + integer(i4b) :: i ! index of model state variable + real(sp), parameter :: alpha=10_sp ! controls sharpness in smoothing + + do i=1,NSTATE + + ! hard constraints + x_try(i) = max( min(x_try(i), upper(i)), lower(i) ) + dclamp(i) = 1._sp + + ! ! apply soft constraint to model states + ! x_try(i) = lower(i) + softplus(x_try(i)-lower(i), alpha) - softplus(x_try(i)-upper(i), alpha) + ! + ! ! compute derivative in clamp + ! dclamp(i) = sigmoid( (x_try(i) - lower(i)) * alpha ) - sigmoid( (x_try(i) - upper(i)) * alpha ) + + end do ! looping through model state variables + + end subroutine fix_ovshoot + + ! --------------------------------------------------------------------------------------- + ! --------------------------------------------------------------------------------------- + SUBROUTINE get_bounds(fuseStruct, lower, upper) + ! --------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark, 2007 + ! Modified to return lower and upper bounds by Martyn Clark, 12/2025 + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! Identify lower and upper bounds for the vector of model states + ! --------------------------------------------------------------------------------------- + USE model_numerix ! model numerix + IMPLICIT NONE + ! input/output + type(fuse_work), intent(in) :: fuseStruct ! fuse work structure + real(sp), dimension(:), intent(out) :: lower ! lower bound for states + real(sp), dimension(:), intent(out) :: upper ! upper bound for states + ! internal + REAL(SP) :: XMIN ! very small number + INTEGER(I4B) :: ISTT ! loop through model states + ! --------------------------------------------------------------------------------------- + associate(MPARAM => fuseStruct%par%param_adjust, & ! adjuustable model parameters + DPARAM => fuseStruct%par%param_derive) ! derived model parameters + ! --------------------------------------------------------------------------------------- + XMIN=FRACSTATE_MIN ! used to avoid zero derivatives + ! --------------------------------------------------------------------------------------- + ! loop through model states + DO ISTT=1,NSTATE + SELECT CASE(CSTATE(ISTT)%iSNAME) + ! upper tanks + CASE (iopt_TENS1A) + lower(ISTT) = XMIN*DPARAM%MAXTENS_1A + upper(ISTT) = DPARAM%MAXTENS_1A + CASE (iopt_TENS1B) + lower(ISTT) = XMIN*DPARAM%MAXTENS_1B + upper(ISTT) = DPARAM%MAXTENS_1B + CASE (iopt_TENS_1) + lower(ISTT) = XMIN*DPARAM%MAXTENS_1 + upper(ISTT) = DPARAM%MAXTENS_1 + CASE (iopt_FREE_1) + lower(ISTT) = XMIN*DPARAM%MAXFREE_1 + upper(ISTT) = DPARAM%MAXFREE_1 + CASE (iopt_WATR_1) + lower(ISTT) = XMIN*MPARAM%MAXWATR_1 + upper(ISTT) = MPARAM%MAXWATR_1 + ! lower tanks + CASE (iopt_TENS_2) + lower(ISTT) = XMIN*DPARAM%MAXTENS_2 + upper(ISTT) = DPARAM%MAXTENS_2 + CASE (iopt_FREE2A) + lower(ISTT) = XMIN*DPARAM%MAXFREE_2A + upper(ISTT) = DPARAM%MAXFREE_2A + CASE (iopt_FREE2B) + lower(ISTT) = XMIN*DPARAM%MAXFREE_2B + upper(ISTT) = DPARAM%MAXFREE_2B + CASE (iopt_WATR_2) + ! *** SET LOWER LIMITS *** + IF (SMODL%iARCH2.NE.iopt_topmdexp_2) THEN + ! enforce lower limit + lower(ISTT) = XMIN*MPARAM%MAXWATR_2 + ELSE + ! MPARAM%MAXWATR_2 is just a scaling parameter, but don't allow stupid values + lower(ISTT) = -MPARAM%MAXWATR_2*10._sp + ENDIF + ! *** SET UPPER LIMITS *** + IF (SMODL%iARCH2.EQ.iopt_tens2pll_2 .OR. SMODL%iARCH2.EQ.iopt_fixedsiz_2) THEN + ! cannot exceed capacity + upper(ISTT) = MPARAM%MAXWATR_2 + ELSE + ! unlimited storage, but make sure the values are still sensible + upper(ISTT) = MPARAM%MAXWATR_2*1000._sp + ENDIF + END SELECT + END DO ! (loop through states) + end associate ! end association with variables in the data structures + ! --------------------------------------------------------------------------------------- + END SUBROUTINE get_bounds + +END MODULE overshoot_module diff --git a/build/FUSE_SRC/physics/get_bundle.f90 b/build/FUSE_SRC/physics/get_bundle.f90 new file mode 100644 index 0000000..f0e90ce --- /dev/null +++ b/build/FUSE_SRC/physics/get_bundle.f90 @@ -0,0 +1,47 @@ +module get_bundle_module + use nrtype + use work_types, only: fuse_work + USE model_defn, ONLY: NSTATE ! TODO: update to new structures + USE multiparam, ONLY: NUMPAR ! TODO: update to new structures + implicit none + +contains + + subroutine get_bundle(fuseStruct) + + use multiforce, only: timDat + use multiforce, only: mForce + use multistate, only: mState + use multi_flux, only: m_flux + use multiparam, only: parMeta,mParam,dParam + + implicit none + type(fuse_work), intent(inout) :: fuseStruct + integer(i4b) :: iState + integer(i4b) :: iParam + + ! populate fuse work structures + fuseStruct%step%time = timdat + fuseStruct%step%force = mForce + fuseStruct%step%state0 = mState + fuseStruct%step%state1 = mState + fuseStruct%step%flux = m_flux ! initialized at zero + + fuseStruct%par%param_meta = parMeta + fuseStruct%par%param_adjust = mParam + fuseStruct%par%param_derive = dParam + + ! initialize flux derivatives + do iState=1,nState + fuseStruct%adj%df_dS(iState) = m_flux ! initialized at zero + end do + + ! initialize parameter derivatives + do iParam=1,NUMPAR + fuseStruct%adj%df_dPar(iParam) = m_flux ! initialized at zero + end do + + end subroutine get_bundle + + +end module get_bundle_module diff --git a/build/FUSE_SRC/physics/implicit_solve.f90 b/build/FUSE_SRC/physics/implicit_solve.f90 new file mode 100644 index 0000000..0b4b448 --- /dev/null +++ b/build/FUSE_SRC/physics/implicit_solve.f90 @@ -0,0 +1,360 @@ +module implicit_solve_module + + ! data types + use nrtype ! variable types, etc. + use work_types, only: fuse_work ! fuse work structure + + ! modules + use xtry_2_str_module ! puts state vector into FUSE state structure + use str_2_xtry_module ! puts FUSE state structure into state vector + + ! global data + use model_defn, only: nState ! number of state variables + use multiforce, only: dt => deltim ! time step + use globaldata, only: isDebug ! print flag + + use model_numerix, only: NUM_FUNCS ! number of function calls + use model_numerix, only: NUM_JACOBIAN ! number of times Jacobian is calculated + + implicit none + + private + public :: implicit_solve + + contains + + ! ----- calculate dx/dt=g(x) ----------------------------------------------------------- + subroutine dx_dt(fuseStruct, x_try, g_x, J_g) + use MOD_DERIVS_DIFF_module, only: MOD_DERIVS_DIFF ! compute dx/dt + implicit none + ! input + type(fuse_work) , intent(inout) :: fuseStruct ! fuse work structure + real(sp) , intent(in) :: x_try(:) ! trial state vector + ! output + real(sp) , intent(out) :: g_x(:) ! dx/dt=g(x) + real(sp) , intent(out) , optional :: J_g(:,:) ! flux Jacobian matrix + ! internal + logical(lgt) :: comp_dflux ! flag to compute flux derivatives + ! -------------------------------------------------------------------------------------- + + comp_dflux = present(J_g) + + ! put data in structure + call XTRY_2_STR(x_try, fuseStruct%step%state1) + + ! run the fuse physics + if (present(J_g)) then + call mod_derivs_diff(fuseStruct, g_x, J_g) + else + call mod_derivs_diff(fuseStruct, g_x) + end if + + ! track the total number of function calls + NUM_FUNCS = NUM_FUNCS + 1 + + end subroutine dx_dt + + ! ----- calculate the Jacobian of g(x) ------------------------------------------------- + SUBROUTINE jac_flux(fuseStruct, x_try, g_x, lower, upper, Jac) + IMPLICIT NONE + ! input-output + type(fuse_work) , intent(in) :: fuseStruct ! fuse work structure + REAL(SP), DIMENSION(:), INTENT(IN) :: g_x, lower, upper + REAL(SP), DIMENSION(:), INTENT(IN) :: x_try + REAL(SP), DIMENSION(:,:), INTENT(OUT) :: Jac + ! locals + type(fuse_work) :: fuseStruct_local + real(sp), parameter :: eps_rel = 1e-4_sp + real(sp), parameter :: eps_abs = 1e-6_sp ! or smaller, but NOT 1e-9 scale + real(sp), parameter :: h_min = 1e-8_sp + INTEGER(I4B) :: j,n + REAL(SP), DIMENSION(size(x_try)) :: x, xsav, g_ph + real(sp) :: h_try, h_act + + ! preliminaries + n = size(x) + fuseStruct_local = fuseStruct + x = x_try + xsav = x + + ! loop through columns + do j=1,n + + ! propose one-sided step (NOTE: negative) + h_try = -max(eps_rel*abs(xsav(j)), eps_abs) + + ! flip sign if necessary + if(xsav(j) + h_try < lower(j)) h_try = -h_try + + ! compute function from the perturbed vector + x(j) = xsav(j) + h_try + call dx_dt(fuseStruct_local, x, g_ph) + h_act = x(j) - xsav(j) + + ! compute column in the Jacobian + Jac(:,j) = (g_ph - g_x) / h_act + + ! safety: save full vector and data structure + fuseStruct_local = fuseStruct ! restores consistency after finite differencing + x = xsav + + end do ! looping through Jacobian columns + + NUM_JACOBIAN = NUM_JACOBIAN + 1 ! keep track of the number of iterations + end SUBROUTINE jac_flux + + ! ----- simple implicit solve for differentiable model -------------------------- + + subroutine implicit_solve(fuseStruct, x0, x1, nx, ierr, message, isVerbose) + USE nr, ONLY : lubksb,ludcmp + USE overshoot_module, only : get_bounds ! get state bounds + USE overshoot_module, only : fix_ovshoot ! fix overshoot (soft clamp) + USE conserve_clamp_module, only: conserve_clamp ! fix overshoot and disaggregate fluxes to conserve mass + USE model_numerix, only: ERR_ITER_FUNC ! Iteration convergence tolerance for function values + USE model_numerix, only: ERR_ITER_DX ! Iteration convergence tolerance for dx + implicit none + ! input-output + type(fuse_work), intent(inout) :: fuseStruct ! fuse work structure + real(sp) , intent(in) :: x0(:) ! state vector at start of step + real(sp) , intent(out) :: x1(:) ! state vector at end of step + integer(i4b) , intent(in) :: nx ! number of state variables + ! error cont ,ol + integer(i4b) , intent(out) :: ierr ! error code + character(*) , intent(out) :: message ! error message + logical(lgt) , intent(in), optional :: isVerbose ! flag for printing (subroutine argument) + logical(lgt) :: isPrint ! flag for printing (local flag) + ! internal: newton iterations + real(sp) :: x_old(nx) ! old trial state vector + real(sp) :: x_try(nx) ! trial state vector + real(sp) :: g_x(nx) ! dx/dt=g(x) + real(sp) :: res(nx) ! residual vector + real(sp) :: Ja(nx,nx) ! Jacobian matrix (flux) + real(sp) :: Jg(nx,nx) ! Jacobian matrix (flux) + real(sp) :: Jac(nx,nx) ! Jacobian matrix (full) + real(sp) :: dx(nx) ! state update + real(sp) :: phi ! half squared residual norm + real(sp) :: d ! determinant sign tracker + integer(i4b) :: indx(nx) ! LU pivot indices (row-swap bookkeeping) + integer(i4b) :: i ! index of state + integer(i4b) :: it ! index of newton iteration + integer(i4b), parameter :: maxit=100 ! maximum number of iterations + logical(lgt) :: converged ! flag for convergence + ! internal: backtracking line search w/ overshoot reject + real(sp) :: xnorm ! norm used in maximum step + real(sp) :: dxnorm ! norm used to evaluate step size + real(sp) :: stpmax ! the maximum step + real(sp) :: dxScale ! used to scale dx if dxnorm > stpmax + real(sp) :: gpsi(nx) ! function gradient: func = 0.5*sum(res*res) + real(sp) :: slope ! direction of decrease + real(sp) :: lambda ! backtrack length multiplier (lambda*dx) + real(sp) :: alamin ! minimum lambda + real(sp) :: lam_i ! maximum lambda for the i-th state + real(sp) :: lam_max ! maximum lambda + real(sp) :: lower(nx) ! lower bound + real(sp) :: upper(nx) ! lower bound + real(sp) :: dclamp(nx) ! derivative in the clamp + real(sp) :: x_trial(nx) ! state vector for backtrack + real(sp) :: g_trial(nx) ! dx/dt=g(x) for backtrack + real(sp) :: res_trial(nx) ! residual for backtrack + real(sp) :: phi_new ! half squared residual norm + integer(i4b) :: ls_it ! index of line search iteration + logical(lgt) :: ovshoot ! flag for overshoot + logical(lgt) :: accepted ! flag for accepting newton step + real(sp) :: phi_best ! best function evaluation + real(sp) :: x_best(nx) ! best state vector + real(sp) :: g_best(nx) ! dx/dt = g(x_best) + logical(lgt) :: have_best ! check if found a state vector + logical(lgt) :: isClamped ! check if fallback is clamped + ! algorithmic control parameters (most passed through MODULE model_numerix) + REAL(SP), PARAMETER :: TOLMIN=1.0e-10_sp ! check for spurious minima + REAL(SP), PARAMETER :: STPMX=100.0_sp ! maximum step in lnsrch + real(sp), parameter :: shrink = 0.5_sp + real(sp), parameter :: dampen = 0.1_sp + real(sp), parameter :: phi_rel_tol = 1e-5_sp ! 0.001% + real(sp), parameter :: phi_abs_tol = 1e-6_sp + real(sp), parameter :: epsb = 1.e-10_sp ! small safety margin + integer(i4b), parameter :: ls_max = 5 + ! ----- procedure starts here -------------------------------------------------------------------- + ! initialize error control + ierr=0; message='implicit_solve/' + + ! check dimension size + if (nx /= nState) stop "implicit_solve: nx /= nState" + + ! initialize check for best function evaluation + phi_best = huge(1._sp); have_best=.false. + + ! initialize number of calls + NUM_FUNCS = 0 ! number of function calls + NUM_JACOBIAN = 0 ! number of times Jacobian is calculated + + ! get the flag for printing + isPrint = .false.; if (present(isVerbose)) isPrint = isVerbose + + ! get the bounds for the state variables + ! NOTE: This can be done outside of the time and iteration loops (keeping here for now) + call get_bounds(fuseStruct, lower, upper) + + ! put state vector into the fuse data structure + call XTRY_2_STR(x0, fuseStruct%step%state0) + + ! intialize state vector (and soft clamp) + x_try = x0 + x_old = x_try + dclamp = 1._sp + + ! fix overshoot (only if necessary) + if(any(x_try < lower) .or. any(x_try > upper)) & + call fix_ovshoot(x_try, lower, upper, dclamp) + + ! define maximum step + xnorm = sqrt( sum(x_try*x_try) ) + stpmax = STPMX * max( xnorm, real(nx, sp) ) + + ! initialize flags + accepted = .false. + converged = .false. + + ! --- F(x), J(x), and objective phi + call dx_dt(fuseStruct, x_try, g_x, Jg) ! compute analytical Jacobian + res = x_try - (x0 + g_x*dt) + phi = 0.5_sp * dot_product(res, res) + + ! iterate + do it = 1, maxit + + ! save x + x_old = x_try + + ! check convergence + if (phi < ERR_ITER_FUNC) then + converged = .true. + exit ! exit iteration loop + end if + + ! --- compute residual Jacobian J(x) from flux Jacobian Jg(x) ---- + !call jac_flux(fuseStruct, x_try, g_x, lower, upper, Jg) + do i=1,nx + Jac(:,i) = -dt*Jg(:,i) + Jac(i,i) = Jac(i,i) + 1.0_sp + end do + + ! --- function gradient: before Jac is modified in ludcmp + gpsi = matmul(transpose(Jac), res) ! assumes func = 0.5_sp * sum(res*res) + + ! --- Solve J dx = -F (Newton step) + dx = -res + call ludcmp(Jac, indx, d) ! J overwritten with LU + call lubksb(Jac, indx, dx) ! dx becomes solution + + ! --- Modify dx + + ! modify dx if norm > stpmax + dxnorm = sqrt( sum(dx*dx) ) + if (dxnorm > stpmax) then + dxScale = stpmax / dxnorm + dx = dxScale * dx + end if + + ! modify dx if Newton step not descending for psi + slope = dot_product(gpsi, dx) + if (slope >= 0._sp) dx = -gpsi ! fallback + + ! implement active-set methods + do i=1,nx + if (x_try(i) <= lower(i)+epsb .and. dx(i) < 0._sp) dx(i)=0._sp + if (x_try(i) >= upper(i)-epsb .and. dx(i) > 0._sp) dx(i)=0._sp + end do + + ! ---- backtracking line search -------------- + + ! line search control + accepted = .false. ! flag to check if line search is accepted + alamin = ERR_ITER_DX / maxval( abs(dx) / max(abs(x_try), 1.0_sp) ) + + lambda = 1.0_sp + do ls_it = 1, ls_max + + ! update x + x_trial = x_try + lambda*dx + + ! shrink lambda until find a value in the feasible space + if(any(x_trial < lower) .or. any(x_trial > upper))then + lambda = lambda * shrink + cycle + endif + + ! compute function and function eval -- no need for the Jacobian here + call dx_dt(fuseStruct, x_trial, g_trial) + res_trial = x_trial - (x0 + dt*g_trial) + phi_new = 0.5_sp * dot_product(res_trial, res_trial) + + ! save best function evaluation + if (phi_new < phi_best) then + phi_best = phi_new + x_best = x_trial + g_best = g_trial + have_best = .true. + endif + + if (phi_new <= phi + phi_abs_tol) then + accepted = .true.; exit + endif + + ! update lambda + lambda = lambda * shrink + if (lambda < alamin) exit ! give up shrinking + + end do ! line search + + ! ----- fallback: try a small step ----- + if(.not. accepted)then + x_trial = x_try + dampen*dx + if(any(x_trial < lower) .or. any(x_trial > upper)) & + call fix_ovshoot(x_trial, lower, upper, dclamp) + end if ! (if accepted) + + ! recompute dx_dt because we need the Jacobian + x_try = x_trial + call dx_dt(fuseStruct, x_try, g_x, Jg) ! compute analytical Jacobian + res = x_try - (x0 + g_x*dt) + phi = 0.5_sp * dot_product(res, res) + + ! save best function evaluation + if (phi < phi_best) then + phi_best = phi + x_best = x_try + g_best = g_x + have_best = .true. + endif + + ! tiny-step convergence + if (maxval( abs(x_try - x_old) / max(abs(x_try), 1._sp) ) < ERR_ITER_DX) then + converged = .true. + exit ! exit iteration loop + end if + + end do ! loop through iterations + + ! ----- handle the extremely rare case of non-convergence ----- + if( .not. converged)then + + ! use explicit Euler if did not find anything + if( .not. have_best) call dx_dt(fuseStruct, x0, g_best) + + ! use dx/dt = g(x_best) + x_try = x0 + dt*g_best + + ! test bounds violations: if bounds exceeded, then clamp and disaggregate fluxes (conserve mass) + call XTRY_2_STR(x_try, fuseStruct%step%state1) + call conserve_clamp(fuseStruct, dt, isClamped) + print*, 'WARNING: '//trim(message)//"failed to converge: use best function evaluation. Clamp = ", isClamped + + endif ! if not converged + + ! save final state + x1 = x_try + + end subroutine implicit_solve + +end module implicit_solve_module diff --git a/build/FUSE_SRC/physics/mod_derivs_diff.f90 b/build/FUSE_SRC/physics/mod_derivs_diff.f90 new file mode 100644 index 0000000..fd0bb00 --- /dev/null +++ b/build/FUSE_SRC/physics/mod_derivs_diff.f90 @@ -0,0 +1,65 @@ +module MOD_DERIVS_DIFF_module + + USE nrtype + USE work_types, only: fuse_work + USE multistate_types, only: STATEV + USE qsatexcess_diff_module, only: qsatexcess_diff + USE evap_upper_diff_module, only: evap_upper_diff + USE evap_lower_diff_module, only: evap_lower_diff + USE qinterflow_diff_module, only: qinterflow_diff + USE qpercolate_diff_module, only: qpercolate_diff + USE q_baseflow_diff_module, only: q_baseflow_diff + USE q_misscell_diff_module, only: q_misscell_diff + USE mstate_rhs_diff_module, only: mstate_rhs_diff + + implicit none + + private + public :: MOD_DERIVS_DIFF + +contains + + SUBROUTINE MOD_DERIVS_DIFF(fuseStruct, g_x, J_g) + ! --------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark, 2007 + ! Modified to include snow model by Brian Henn, 6/2013 + ! Modified to include analytical derivatives by Martyn Clark, 12/2025 + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! compute the time derivative (dx/dt) of all model states (x) + ! -------------------------------------------------------------------------------------- + implicit none + ! input + type(fuse_work) , intent(inout) :: fuseStruct ! fuse work structure + ! output + real(sp) , intent(out) :: g_x(:) ! dx/dt=g(x) + real(sp) , intent(out) , optional :: J_g(:,:) ! flux Jacobian matrix + ! internal + logical(lgt) :: comp_dflux ! flag to compute flux derivatives + ! -------------------------------------------------------------------------------------- + + ! check if Jacobian is desired + comp_dflux = present(J_g) + + ! compute fluxes + call qsatexcess_diff(fuseStruct, comp_dflux) ! compute the saturated area and surface runoff + call evap_upper_diff(fuseStruct, comp_dflux) ! compute evaporation from the upper layer + call evap_lower_diff(fuseStruct, comp_dflux) ! compute evaporation from the lower layer + call qinterflow_diff(fuseStruct, comp_dflux) ! compute interflow from free water in the upper layer + call qpercolate_diff(fuseStruct, comp_dflux) ! compute percolation from the upper to lower soil layers + call q_baseflow_diff(fuseStruct, comp_dflux) ! compute baseflow from the lower soil layer + call q_misscell_diff(fuseStruct, comp_dflux) ! compute miscellaneous fluxes (NOTE: need sat area, evap, and perc) + + ! compute the time derivative (dx/dt) of all model states (x) + if(comp_dflux)then + call mstate_rhs_diff(fuseStruct, g_x, J_g) + else + call mstate_rhs_diff(fuseStruct, g_x) + endif + + END SUBROUTINE MOD_DERIVS_DIFF + +end module MOD_DERIVS_DIFF_module diff --git a/build/FUSE_SRC/physics/mstate_rhs_diff.f90 b/build/FUSE_SRC/physics/mstate_rhs_diff.f90 new file mode 100644 index 0000000..791cde9 --- /dev/null +++ b/build/FUSE_SRC/physics/mstate_rhs_diff.f90 @@ -0,0 +1,116 @@ +module MSTATE_RHS_DIFF_module + + use globaldata, only: isDebug ! print flag + + implicit none + + private + public :: MSTATE_RHS_DIFF + +contains + + SUBROUTINE MSTATE_RHS_DIFF(fuseStruct, g_x, J_g) + ! --------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark, 2007 + ! Modified by Martyn Clark to create a differentiable model, 12/25 + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! Computes time derivatives of all states for all model combinations + ! --------------------------------------------------------------------------------------- + USE nrtype ! variable types, etc. + USE work_types, only: fuse_work ! fuse work data type + USE model_defn ! model definition structure + USE model_defnames ! model names + use str_2_xtry_module ! puts FUSE state structure into state vector + ! input-output + type(fuse_work), intent(inout) :: fuseStruct ! fuse work structure + ! output + real(sp) , intent(out) :: g_x(:) ! dx/dt=g(x) + real(sp) , intent(out) , optional :: J_g(:,:) ! flux Jacobian matrix + ! internal + logical(lgt) :: comp_dflux ! flag to compute flux derivatives + ! ------------------------------------------------------------------------------------------------- + ! associate variables with elements of data structure + associate(& + M_FLUX => fuseStruct%step%flux , & ! fluxes + DX_DT => fuseStruct%step%dx_dt , & ! time derivative in states + df_dS => fuseStruct%adj%df_dS , & ! derivative in fluxes w.r.t. states + MPARAM => fuseStruct%par%param_adjust & ! adjustable model parameters + ) ! (associate) + ! ------------------------------------------------------------------------------------------------- + + ! check if Jacobian is desired + comp_dflux = present(J_g) + + ! --------------------------------------------------------------------------------------- + ! (1) UPPER LAYER + ! --------------------------------------------------------------------------------------- + + ! compute time derivatives + SELECT CASE(SMODL%iARCH1) + CASE(iopt_tension2_1) ! tension storage sub-divided into recharge and excess + DX_DT%TENS_1A = M_FLUX%EFF_PPT - M_FLUX%QSURF - M_FLUX%EVAP_1A - M_FLUX%RCHR2EXCS + DX_DT%TENS_1B = M_FLUX%RCHR2EXCS - M_FLUX%EVAP_1B - M_FLUX%TENS2FREE_1 + DX_DT%FREE_1 = M_FLUX%TENS2FREE_1 - M_FLUX%QPERC_12 - M_FLUX%QINTF_1 - M_FLUX%OFLOW_1 + CASE(iopt_tension1_1) ! upper layer broken up into tension and free storage + DX_DT%TENS_1 = M_FLUX%EFF_PPT - M_FLUX%QSURF - M_FLUX%EVAP_1 - M_FLUX%TENS2FREE_1 + DX_DT%FREE_1 = M_FLUX%TENS2FREE_1 - M_FLUX%QPERC_12 - M_FLUX%QINTF_1 - M_FLUX%OFLOW_1 + CASE(iopt_onestate_1) ! upper layer defined by a single state variable + DX_DT%WATR_1 = M_FLUX%EFF_PPT - M_FLUX%QSURF - M_FLUX%EVAP_1 - M_FLUX%QPERC_12 - M_FLUX%QINTF_1 & + - M_FLUX%OFLOW_1 + CASE DEFAULT + print *, "SMODL%iARCH1 must be iopt_tension2_1, iopt_tension1_1, or iopt_onestate_1" + STOP + END SELECT ! (upper layer architecture) + + ! compute Jacobian + if(comp_dflux)then + if(SMODL%iARCH1 /= iopt_onestate_1) stop "mstate_rhs: only iopt_onestate_1 currently implemented" + J_g(1,:) = -M_FLUX%EFF_PPT*df_dS%SATAREA - df_dS%EVAP_1 - df_dS%QPERC_12 + endif + + ! --------------------------------------------------------------------------------------- + ! (2) LOWER LAYER + ! --------------------------------------------------------------------------------------- + + ! compute time derivatives + SELECT CASE(SMODL%iARCH2) + CASE(iopt_tens2pll_2) ! tension reservoir plus two parallel tanks + DX_DT%TENS_2 = M_FLUX%QPERC_12*(1._SP-MPARAM%PERCFRAC) - M_FLUX%EVAP_2 - M_FLUX%TENS2FREE_2 + DX_DT%FREE_2A = M_FLUX%QPERC_12*(MPARAM%PERCFRAC/2._SP) + M_FLUX%TENS2FREE_2/2._SP - M_FLUX%QBASE_2A & + - M_FLUX%OFLOW_2A + DX_DT%FREE_2B = M_FLUX%QPERC_12*(MPARAM%PERCFRAC/2._SP) + M_FLUX%TENS2FREE_2/2._SP - M_FLUX%QBASE_2B & + - M_FLUX%OFLOW_2B + CASE(iopt_unlimfrc_2,iopt_unlimpow_2,iopt_topmdexp_2,iopt_fixedsiz_2) ! single state + ! (NOTE: M_FLUX%OFLOW_2=0 for 'unlimfrc_2','unlimpow_2','topmdexp_2') + DX_DT%WATR_2 = M_FLUX%QPERC_12 - M_FLUX%EVAP_2 - M_FLUX%QBASE_2 - M_FLUX%OFLOW_2 + CASE DEFAULT + print *, "SMODL%iARCH2 must be iopt_tens2pll_2, iopt_unlimfrc_2, iopt_unlimpow_2" + print *, " iopt_topmdexp_2, or iopt_fixedsiz_2" + STOP + END SELECT + + ! compute Jacobian + ! NOTE: assume M_FLUX%EVAP_2=0 and M_FLUX%OFLOW_2=0 + if(comp_dflux)then + if(SMODL%iARCH2 == iopt_tens2pll_2) stop "mstate_rhs: iopt_tens2pll_2 not currently implemented" + J_g(2,:) = df_dS%QPERC_12 - df_dS%QBASE_2 + endif + + ! --------------------------------------------------------------------------------------- + + ! --------------------------------------------------------------------------------------- + ! (3) FINALIZE + ! --------------------------------------------------------------------------------------- + + ! extract dx_dt from fuse structure + call STR_2_XTRY(dx_dt, g_x) + ! --------------------------------------------------------------------------------------- + + end associate ! end association with variables in the data structures + END SUBROUTINE MSTATE_RHS_DIFF + +end module MSTATE_RHS_DIFF_module diff --git a/build/FUSE_SRC/physics/q_baseflow_diff.f90 b/build/FUSE_SRC/physics/q_baseflow_diff.f90 new file mode 100644 index 0000000..5fca4be --- /dev/null +++ b/build/FUSE_SRC/physics/q_baseflow_diff.f90 @@ -0,0 +1,109 @@ +module Q_BASEFLOW_DIFF_module + + implicit none + + private + public :: Q_BASEFLOW_DIFF + +contains + + + SUBROUTINE Q_BASEFLOW_DIFF(fuseStruct, want_dflux) + ! --------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark, 2007 + ! Modified by Martyn Clark to create a differentiable model, 12/25 + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! Computes the baseflow from the lower soil layer + ! --------------------------------------------------------------------------------------- + USE nrtype ! variable types, etc. + USE work_types, only: fuse_work ! fuse work type + USE model_defn ! model definition structure + USE model_defnames + IMPLICIT NONE + ! input-output + type(fuse_work), intent(inout) :: fuseStruct ! fuse work structure + logical(lgt), intent(in), optional :: want_dflux ! if we want flux derivatives + ! derivatives + logical(lgt) :: comp_dflux ! flag to compute flux derivatives + integer(i4b) :: iState ! state index + real(sp) :: phi ! scaled water storage, phi=w/ws + real(sp) :: dqb_dw ! derivative in baseflow flux w.r.t. water store + ! ------------------------------------------------------------------------------------------------- + ! associate variables with elements of data structure + associate(& + TSTATE => fuseStruct%step%state1 , & ! trial state variables (end of step) + M_FLUX => fuseStruct%step%flux , & ! fluxes + dfx_dS => fuseStruct%adj%df_dS , & ! deriv in fluxes w.r.t. states + MPARAM => fuseStruct%par%param_adjust , & ! adjustable model parameters + DPARAM => fuseStruct%par%param_derive & ! derived model parameters + ) ! (associate) + + ! check the need to compute flux derivatives + comp_dflux = .false.; if(present(want_dflux)) comp_dflux = want_dflux + + ! --------------------------------------------------------------------------------------- + SELECT CASE(SMODL%iARCH2) + + ! -------------------------------------------------------------------------------------- + CASE(iopt_tens2pll_2) ! tension reservoir plus two parallel tanks + M_FLUX%QBASE_2A = MPARAM%QBRATE_2A * TSTATE%FREE_2A ! qbrate_2a is a fraction (T-1) + M_FLUX%QBASE_2B = MPARAM%QBRATE_2B * TSTATE%FREE_2B ! qbrate_2b is a fraction (T-1) + M_FLUX%QBASE_2 = M_FLUX%QBASE_2A + M_FLUX%QBASE_2B ! total baseflow + if(comp_dflux) stop "q_baseflow: derivative not implemented yet for iopt_tens2pll_2" + + ! -------------------------------------------------------------------------------------- + CASE(iopt_unlimfrc_2) ! baseflow resvr of unlimited size (0-HUGE), frac rate + M_FLUX%QBASE_2 = MPARAM%QB_PRMS * TSTATE%WATR_2 ! qb_prms is a fraction (T-1) + if(comp_dflux) stop "q_baseflow: derivative not implemented yet for iopt_unlimfrc_2" + + ! -------------------------------------------------------------------------------------- + CASE(iopt_unlimpow_2) ! baseflow resvr of unlimited size (0-HUGE), power recession + + associate(qbsat=>DPARAM%QBSAT, w=>TSTATE%WATR_2, ws=>MPARAM%MAXWATR_2, p=>MPARAM%QB_POWR) + + ! ----- compute flux ------------------------------------------------------------------ + phi = w/ws + M_FLUX%QBASE_2 = qbsat*phi**p + + ! ----- compute derivative ------------------------------------------------------------ + if(comp_dflux) dqb_dw = (qbsat*p/ws)*phi**(p - 1._sp) + + end associate + + ! -------------------------------------------------------------------------------------- + CASE(iopt_topmdexp_2) ! topmodel exponential reservoir (-HUGE to HUGE) + M_FLUX%QBASE_2 = DPARAM%QBSAT * EXP( -(1. - TSTATE%WATR_2/MPARAM%MAXWATR_2) ) + if(comp_dflux) stop "q_baseflow: derivative not implemented yet for iopt_topmdexp_2" + + ! -------------------------------------------------------------------------------------- + CASE(iopt_fixedsiz_2) ! baseflow reservoir of fixed size + M_FLUX%QBASE_2 = MPARAM%BASERTE * (TSTATE%WATR_2/MPARAM%MAXWATR_2)**MPARAM%QB_POWR + if(comp_dflux) stop "q_baseflow: derivative not implemented yet for iopt_fixedsiz_2" + + ! -------------------------------------------------------------------------------------- + CASE DEFAULT + print *, "SMODL%iARCH2 must be iopt_tens2pll_2, iopt_unlimfrc_2, iopt_unlimpow_2" + print *, " iopt_topmdexp_2, or iopt_fixedsiz_2" + STOP + ! -------------------------------------------------------------------------------------- + + END SELECT + ! --------------------------------------------------------------------------------------- + + ! populate derivative vector + if(comp_dflux)then + do iState=1,nState + select case(cState(iState)%iSNAME) + case (iopt_WATR_2); dfx_dS(iState)%QBASE_2 = dqb_dw ! exists if one state in the upper layer + end select ! no default needed + end do ! looping through states + endif + + end associate ! end association with variables in the data structures + END SUBROUTINE Q_BASEFLOW_DIFF + +end module Q_BASEFLOW_DIFF_module diff --git a/build/FUSE_SRC/physics/q_misscell_diff.f90 b/build/FUSE_SRC/physics/q_misscell_diff.f90 new file mode 100644 index 0000000..9b232ba --- /dev/null +++ b/build/FUSE_SRC/physics/q_misscell_diff.f90 @@ -0,0 +1,125 @@ +module Q_MISSCELL_DIFF_module + + implicit none + + private + public :: Q_MISSCELL_DIFF + +contains + + SUBROUTINE Q_MISSCELL_DIFF(fuseStruct, want_dflux) + ! --------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark, 2007 + ! Modified by Martyn Clark to create a differentiable model, 12/25 + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! Computes miscellaneous fluxes: + ! RCHR2EXCS = flow from recharge to excess (mm day-1) + ! TENS2FREE_1 = flow from tension storage to free storage in the upper layer (mm day-1) + ! TENS2FREE_2 = flow from tension storage to free storage in the lower layer (mm day-1) + ! OFLOW_1 = overflow from the upper soil layer (mm day-1) + ! OFLOW_2 = overflow from the lower soil layer (mm day-1) + ! --------------------------------------------------------------------------------------- + USE nrtype ! variable types, etc. + USE work_types, only: fuse_work ! fuse work type + USE model_defn ! model definition structure + USE model_defnames + USE smoothers, only: smoother ! smoothing function + IMPLICIT NONE + ! input-output + type(fuse_work), intent(inout) :: fuseStruct ! fuse work structure + logical(lgt), intent(in), optional :: want_dflux ! if we want flux derivatives + ! internal + logical(lgt) :: comp_dflux ! flag to compute flux derivatives + REAL(SP), PARAMETER :: PSMOOTH=0.05_SP ! smoothing parameter + REAL(SP) :: W_FUNC ! result from smoother + ! ------------------------------------------------------------------------------------------------- + ! associate variables with elements of data structure + associate(& + M_FLUX => fuseStruct%step%flux , & ! fluxes + TSTATE => fuseStruct%step%state1 , & ! trial state variables (end of step) + MPARAM => fuseStruct%par%param_adjust , & ! adjustable model parameters + DPARAM => fuseStruct%par%param_derive & ! derived model parameters + ) ! (associate) + ! --------------------------------------------------------------------------------------- + + ! check the need to compute flux derivatives + comp_dflux = .false.; if(present(want_dflux)) comp_dflux = want_dflux + + ! --------------------------------------------------------------------------------------- + SELECT CASE(SMODL%iARCH1) + CASE(iopt_tension2_1) ! tension storage sub-divided into recharge and excess + ! compute flow from recharge to excess (mm s-1) + W_FUNC = SMOOTHER(TSTATE%TENS_1A,DPARAM%MAXTENS_1A,PSMOOTH) + M_FLUX%RCHR2EXCS = W_FUNC * (M_FLUX%EFF_PPT - M_FLUX%QSURF) + ! compute flow from tension storage to free storage (mm s-1) + W_FUNC = SMOOTHER(TSTATE%TENS_1B,DPARAM%MAXTENS_1B,PSMOOTH) + M_FLUX%TENS2FREE_1 = W_FUNC * M_FLUX%RCHR2EXCS + ! compute over-flow of free water + W_FUNC = SMOOTHER(TSTATE%FREE_1,DPARAM%MAXFREE_1,PSMOOTH) + M_FLUX%OFLOW_1 = W_FUNC * M_FLUX%TENS2FREE_1 + CASE(iopt_tension1_1) ! upper layer broken up into tension and free storage + ! no separate recharge zone (flux should never be used) + M_FLUX%RCHR2EXCS = 0._SP + ! compute flow from tension storage to free storage (mm s-1) + W_FUNC = SMOOTHER(TSTATE%TENS_1,DPARAM%MAXTENS_1,PSMOOTH) + M_FLUX%TENS2FREE_1 = W_FUNC * (M_FLUX%EFF_PPT - M_FLUX%QSURF) + ! compute over-flow of free water + W_FUNC = SMOOTHER(TSTATE%FREE_1,DPARAM%MAXFREE_1,PSMOOTH) + M_FLUX%OFLOW_1 = W_FUNC * M_FLUX%TENS2FREE_1 + CASE(iopt_onestate_1) ! upper layer defined by a single state variable + ! no tension stores + M_FLUX%RCHR2EXCS = 0._SP + M_FLUX%TENS2FREE_1 = 0._SP + ! compute over-flow of free water + if(SMODL%iQSURF == iopt_arno_x_vic)then + M_FLUX%OFLOW_1 = 0._sp ! no need for overflow since the vic parmaeterization is smoothed now + else + W_FUNC = SMOOTHER(TSTATE%WATR_1,MPARAM%MAXWATR_1,PSMOOTH) + M_FLUX%OFLOW_1 = W_FUNC * (M_FLUX%EFF_PPT - M_FLUX%QSURF) + endif + CASE DEFAULT + print *, "SMODL%iARCH1 must be iopt_tension2_1, iopt_tension1_1, or iopt_onestate_1" + STOP + END SELECT + + ! --------------------------------------------------------------------------------------- + SELECT CASE(SMODL%iARCH2) + CASE(iopt_tens2pll_2) ! tension reservoir plus two parallel tanks + ! compute flow from tension storage to free storage (mm s-1) + W_FUNC = SMOOTHER(TSTATE%TENS_2,DPARAM%MAXTENS_2,PSMOOTH) + M_FLUX%TENS2FREE_2 = W_FUNC * M_FLUX%QPERC_12*(1._SP-MPARAM%PERCFRAC) + ! compute over-flow of free water in the primary reservoir + W_FUNC = SMOOTHER(TSTATE%FREE_2A,DPARAM%MAXFREE_2A,PSMOOTH) + M_FLUX%OFLOW_2A = W_FUNC * (M_FLUX%QPERC_12*(MPARAM%PERCFRAC/2._SP) + M_FLUX%TENS2FREE_2/2._SP) + ! compute over-flow of free water in the secondary reservoir + W_FUNC = SMOOTHER(TSTATE%FREE_2B,DPARAM%MAXFREE_2B,PSMOOTH) + M_FLUX%OFLOW_2B = W_FUNC * (M_FLUX%QPERC_12*(MPARAM%PERCFRAC/2._SP) + M_FLUX%TENS2FREE_2/2._SP) + ! compute total overflow + M_FLUX%OFLOW_2 = M_FLUX%OFLOW_2A + M_FLUX%OFLOW_2B + CASE(iopt_fixedsiz_2) + ! no tension store + M_FLUX%TENS2FREE_2 = 0._SP + M_FLUX%OFLOW_2A = 0._SP + M_FLUX%OFLOW_2B = 0._SP + ! compute over-flow of free water + W_FUNC = SMOOTHER(TSTATE%WATR_2,MPARAM%MAXWATR_2,PSMOOTH) + M_FLUX%OFLOW_2 = W_FUNC * M_FLUX%QPERC_12 + CASE(iopt_unlimfrc_2,iopt_unlimpow_2,iopt_topmdexp_2) ! unlimited size + M_FLUX%TENS2FREE_2 = 0._SP + M_FLUX%OFLOW_2 = 0._SP + M_FLUX%OFLOW_2A = 0._SP + M_FLUX%OFLOW_2B = 0._SP + CASE DEFAULT + print *, "SMODL%iARCH2 must be iopt_tens2pll_2, iopt_unlimfrc_2, iopt_unlimpow_2" + print *, " iopt_topmdexp_2, or iopt_fixedsiz_2" + STOP + END SELECT + + end associate ! end association with variables in the data structures + END SUBROUTINE Q_MISSCELL_DIFF + +end module Q_MISSCELL_DIFF_module diff --git a/build/FUSE_SRC/physics/qinterflow_diff.f90 b/build/FUSE_SRC/physics/qinterflow_diff.f90 new file mode 100644 index 0000000..4c99eb4 --- /dev/null +++ b/build/FUSE_SRC/physics/qinterflow_diff.f90 @@ -0,0 +1,59 @@ +module QINTERFLOW_DIFF_module + + implicit none + + private + public :: QINTERFLOW_DIFF + +contains + + SUBROUTINE QINTERFLOW_DIFF(fuseStruct, want_dflux) + ! --------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark, 2007 + ! Modified by Martyn Clark to create a differentiable model, 12/25 + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! Computes the interflow from free water in the upper soil layer + ! --------------------------------------------------------------------------------------- + USE nrtype ! variable types, etc. + USE work_types, only: fuse_work ! fuse work type + USE model_defn ! model definition structure + USE model_defnames + IMPLICIT NONE + ! input-output + type(fuse_work), intent(inout) :: fuseStruct ! fuse work structure + logical(lgt), intent(in), optional :: want_dflux ! if we want flux derivatives + ! internal + logical(lgt) :: comp_dflux ! flag to compute flux derivatives + ! ------------------------------------------------------------------------------------------------- + ! associate variables with elements of data structure + associate(& + M_FLUX => fuseStruct%step%flux , & ! fluxes + TSTATE => fuseStruct%step%state1 , & ! trial state variables (end of step) + MPARAM => fuseStruct%par%param_adjust , & ! adjustable model parameters + DPARAM => fuseStruct%par%param_derive & ! derived model parameters + ) ! (associate) + ! ------------------------------------------------------------------------------------------------- + + ! check the need to compute flux derivatives + comp_dflux = .false.; if(present(want_dflux)) comp_dflux = want_dflux + + ! --------------------------------------------------------------------------------------- + SELECT CASE(SMODL%iQINTF) + CASE(iopt_intflwsome) ! interflow + M_FLUX%QINTF_1 = MPARAM%IFLWRTE * (TSTATE%FREE_1/DPARAM%MAXFREE_1) + CASE(iopt_intflwnone) ! no interflow + M_FLUX%QINTF_1 = 0. + CASE DEFAULT ! check for errors + print *, "SMODL%iQINTF must be either iopt_intflwsome or iopt_intflwnone" + STOP + END SELECT + ! --------------------------------------------------------------------------------------- + + end associate ! end association with variables in the data structures + END SUBROUTINE QINTERFLOW_DIFF + +end module QINTERFLOW_DIFF_module diff --git a/build/FUSE_SRC/physics/qpercolate_diff.f90 b/build/FUSE_SRC/physics/qpercolate_diff.f90 new file mode 100644 index 0000000..9140a9f --- /dev/null +++ b/build/FUSE_SRC/physics/qpercolate_diff.f90 @@ -0,0 +1,117 @@ +module QPERCOLATE_DIFF_module + + implicit none + + private + public :: QPERCOLATE_DIFF + +contains + + SUBROUTINE QPERCOLATE_DIFF(fuseStruct, want_dflux) + ! --------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark, 2007 + ! Modified by Martyn Clark to create a differentiable model, 12/25 + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! Computes the percolation from the upper soil layer to the lower soil layer + ! --------------------------------------------------------------------------------------- + USE nrtype ! variable types, etc. + USE work_types, only: fuse_work ! fuse work type + USE model_defn ! model definition structure + USE model_defnames ! model definition names + use smoothers, only : sfrac, dsfrac ! smoothed fraction, derivative + IMPLICIT NONE + ! input-output + type(fuse_work), intent(inout) :: fuseStruct ! fuse work structure + logical(lgt), intent(in), optional :: want_dflux ! if we want flux derivatives + ! internal + logical(lgt) :: comp_dflux ! flag to compute flux derivatives + integer(i4b) :: iState ! state index + real(sp) :: phi ! smoothed fraction of free water + real(sp) :: dphi_dx ! derivative in smoothed fraction of free water + real(sp) :: df_dpsi ! derivative of flux w.r.t. fraction + real(sp) :: dqperc_dx ! derivative of percolation fux w.r.t. water state + REAL(SP) :: LZ_PD ! lower zone percolation demand + real(sp), parameter :: ms=1.e-4_sp ! smoothing in sfrac(smax) function + ! --------------------------------------------------------------------------------------- + ! associate variables with elements of data structure + associate(& + TSTATE => fuseStruct%step%state1 , & ! trial state variables (end of step) + M_FLUX => fuseStruct%step%flux , & ! fluxes + dfx_dS => fuseStruct%adj%df_dS , & ! deriv in fluxes w.r.t. states + MPARAM => fuseStruct%par%param_adjust , & ! adjustable model parameters + DPARAM => fuseStruct%par%param_derive & ! derived model parameters + ) ! (associate) + ! --------------------------------------------------------------------------------------- + + ! check the need to compute flux derivatives + comp_dflux = .false.; if(present(want_dflux)) comp_dflux = want_dflux + + ! --------------------------------------------------------------------------------------- + SELECT CASE(SMODL%iQPERC) + + ! -------------------------------------------------------------------------------------- + ! upper zone control + ! -------------------------------------------------------------------------------------- + CASE(iopt_perc_w2sat, iopt_perc_f2sat) + + ! short-cuts + associate(k=>MPARAM%PERCRTE, c=>MPARAM%PERCEXP) + + ! compute fractions + select case(SMODL%iQPERC) + case(iopt_perc_w2sat); phi = sfrac(TSTATE%WATR_1, MPARAM%MAXWATR_1, ms) + case(iopt_perc_f2sat); phi = sfrac(TSTATE%FREE_1, DPARAM%MAXFREE_1, ms) + end select ! no need for default since already in block + + ! ----- compute flux ---------------------------------------------------------------- + M_FLUX%QPERC_12 = k*phi**c + + ! ----- compute derivative ---------------------------------------------------------- + if(comp_dflux)then + + ! compute derivative in the fractions + select case(SMODL%iQPERC) + case(iopt_perc_w2sat); dphi_dx = dsfrac(TSTATE%WATR_1, MPARAM%MAXWATR_1, ms) + case(iopt_perc_f2sat); dphi_dx = dsfrac(TSTATE%FREE_1, DPARAM%MAXFREE_1, ms) + end select ! no need for default since already in block + + ! compute derivatives in the percolation flux + df_dpsi = k*c*phi**(c - 1._sp) ! derivative of flux w.r.t. fraction + dqperc_dx = df_dpsi*dphi_dx + + ! populate derivative vector + do iState=1,nState + select case(cState(iState)%iSNAME) + case (iopt_FREE_1); dfx_dS(iState)%QPERC_12 = dqperc_dx ! exists if separate free tank + case (iopt_WATR_1); dfx_dS(iState)%QPERC_12 = dqperc_dx ! exists if one state in the upper layer + end select ! no default needed + end do ! looping through states + + endif ! if computing derivatives + + end associate + + ! -------------------------------------------------------------------------------------- + ! lower zone control + ! -------------------------------------------------------------------------------------- + CASE(iopt_perc_lower) ! perc defined by moisture content in lower layer (SAC) + + ! ----- compute flux ---------------------------------------------------------------- + LZ_PD = 1._SP + MPARAM%SACPMLT*(1._SP - TSTATE%WATR_2/MPARAM%MAXWATR_2)**MPARAM%SACPEXP + M_FLUX%QPERC_12 = DPARAM%QBSAT*LZ_PD * (TSTATE%FREE_1/DPARAM%MAXFREE_1) + + ! ----- compute derivatives --------------------------------------------------------------------- + if(comp_dflux) stop "qpercolate: derivatives for iopt_perc_lower not implemented yet" + + CASE DEFAULT; stop "qpercolate: SMODL%iQPERC must be iopt_perc_f2sat, iopt_perc_w2sat, or iopt_perc_lower" + END SELECT + ! -------------------------------------------------------------------------------------- + + end associate ! end association with variables in the data structures + END SUBROUTINE QPERCOLATE_DIFF + +end module QPERCOLATE_DIFF_module diff --git a/build/FUSE_SRC/physics/qsatexcess_diff.f90 b/build/FUSE_SRC/physics/qsatexcess_diff.f90 new file mode 100644 index 0000000..3b8d699 --- /dev/null +++ b/build/FUSE_SRC/physics/qsatexcess_diff.f90 @@ -0,0 +1,163 @@ +module QSATEXCESS_DIFF_MODULE + + implicit none + + private + public :: QSATEXCESS_DIFF + +contains + + SUBROUTINE QSATEXCESS_DIFF(fuseStruct, want_dflux) + ! ------------------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark, 2007 + ! Modified by Martyn Clark to create a differentiable model, 12/25 + ! ------------------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! Computes the saturated area and surface runoff + ! ------------------------------------------------------------------------------------------------- + USE nrtype ! variable types, etc. + USE work_types, only: fuse_work ! fuse work type + USE model_defn ! model definition structure + USE model_defnames + USE nr, ONLY : gammp ! interface for the incomplete gamma function + USE smoothers, only : smax,dsmax ! smoothed max function, derivative + IMPLICIT NONE + ! input-output + type(fuse_work), intent(inout) :: fuseStruct ! fuse work structure + logical(lgt), intent(in), optional :: want_dflux ! if we want flux derivatives + ! internal variables -- vic + real(sp) :: u,xp ! temporary variables + real(sp) :: ds_dx ! derivative of saturated area w.r.t. x + real(sp) :: dx_du ! derivative of smooth max(u,0) w.r.t. u + real(sp) :: du_dw ! derivative of u w.r.t. w + real(sp) :: ds_dw ! derivative of saturated area w.r.t. w + ! internal variables -- topmodel + REAL(SP) :: TI_SAT ! topographic index where saturated + REAL(SP) :: TI_LOG ! critical value of topo index in log space + REAL(SP) :: TI_OFF ! offset in the Gamma distribution + REAL(SP) :: TI_SHP ! shape of the Gamma distribution + REAL(SP) :: TI_CHI ! CHI, see Sivapalan et al., 1987 + REAL(SP) :: TI_ARG ! argument of the Gamma function + REAL(SP) :: NO_ZERO=1.E-8 ! avoid divide by zero + ! derivatives + logical(lgt) :: comp_dflux ! flag to compute flux derivatives + integer(i4b) :: iState ! state index + real(sp), parameter :: ms=1.e-4_sp ! smoothing in smax function + + real(sp) :: w, wmax, b + + ! ------------------------------------------------------------------------------------------------- + ! associate variables with elements of data structure + associate(& + TSTATE => fuseStruct%step%state1 , & ! trial state variables (end of step) + M_FLUX => fuseStruct%step%flux , & ! fluxes + dfx_dS => fuseStruct%adj%df_dS , & ! deriv in fluxes w.r.t. states + MPARAM => fuseStruct%par%param_adjust , & ! adjustable model parameters + DPARAM => fuseStruct%par%param_derive & ! derived model parameters + ) ! (associate) + ! ------------------------------------------------------------------------------------------------- + + ! check the need to compute flux derivatives + comp_dflux = .false.; if(present(want_dflux)) comp_dflux = want_dflux + + ! saturated area method + SELECT CASE(SMODL%iQSURF) + + ! ------------------------------------------------------------------------------------------------ + ! ----- ARNO/Xzang/VIC parameterization (upper zone control) ------------------------------------- + ! ------------------------------------------------------------------------------------------------ + CASE(iopt_arno_x_vic) + + ! define variables + !associate(w=>TSTATE%WATR_1, wmax=>MPARAM%MAXWATR_1, b=>MPARAM%AXV_BEXP) + w = TSTATE%WATR_1 + wmax = MPARAM%MAXWATR_1 + b = MPARAM%AXV_BEXP + + ! ----- compute flux ---------------------------------------------------------------------------- + u = 1._sp - w/wmax + xp = smax(u, 0._sp, ms) ! smooth version of max(u,0) + M_FLUX%SATAREA = 1._sp - xp**b + + ! ----- compute derivatives --------------------------------------------------------------------- + if(comp_dflux)then + + ! compute derivative w.r.t. saturated area + ds_dx = -b*xp**(b - 1._sp) ! derivative of saturated area w.r.t. xp + dx_du = dsmax(u, 0._sp, ms) ! derivative of smooth max(u,0) w.r.t. u + du_dw = -1._sp/wmax ! derivative of u w.r.t. w + ds_dw = du_dw*dx_du*ds_dx ! derivative of saturated area w.r.t. w + + ! since WATR_1 is the sum of individual state variables (e.g., WATR_1=TENS_1+FREE_1) simply copy derivative + do iState=1,nState + select case(cState(iState)%iSNAME) + case (iopt_TENS1A); dfx_dS(iState)%SATAREA = ds_dw ! exists if two tension tanks + case (iopt_TENS1B); dfx_dS(iState)%SATAREA = ds_dw ! exists if two tension tanks + case (iopt_TENS_1); dfx_dS(iState)%SATAREA = ds_dw ! exists if one tension tank + case (iopt_FREE_1); dfx_dS(iState)%SATAREA = ds_dw ! exists if separate free storage + case (iopt_WATR_1); dfx_dS(iState)%SATAREA = ds_dw ! exists if one state in the upper layer + end select ! no default needed + end do ! looping through states + + endif ! if want derivatives + + !end associate + + ! ------------------------------------------------------------------------------------------------ + ! ----- PRMS variant (fraction of upper tension storage) ----------------------------------------- + ! ------------------------------------------------------------------------------------------------ + CASE(iopt_prms_varnt) + + ! ----- compute flux ---------------------------------------------------------------------------- + M_FLUX%SATAREA = MIN(TSTATE%TENS_1/DPARAM%MAXTENS_1, 1._sp) * MPARAM%SAREAMAX + + ! ----- compute derivatives --------------------------------------------------------------------- + if(comp_dflux) stop "qsatexcess: derivatives for iopt_prms_varnt not implemented yet" + + ! ------------------------------------------------------------------------------------------------ + ! ----- TOPMODEL parameterization (only valid for TOPMODEL qb) ----------------------------------- + ! ------------------------------------------------------------------------------------------------ + CASE(iopt_tmdl_param) + + ! ----- compute flux ---------------------------------------------------------------------------- + + ! compute the minimum value of the topographic index where the basin is saturated + ! (this is correct, as MPARAM%MAXWATR_2 is m*n -- units are meters**(1/n) + TI_SAT = DPARAM%POWLAMB / (TSTATE%WATR_2/MPARAM%MAXWATR_2 + NO_ZERO) + ! compute the saturated area + IF (TI_SAT.GT.DPARAM%MAXPOW) THEN + M_FLUX%SATAREA = 0. + ELSE + ! convert the topographic index to log space + TI_LOG = LOG( TI_SAT**MPARAM%QB_POWR ) + ! compute the saturated area (NOTE: critical value of the topographic index is in log space) + TI_OFF = 3._sp ! offset in the Gamma distribution (the "3rd" parameter) + TI_SHP = MPARAM%TISHAPE ! shape of the Gamma distribution (the "2nd" parameter) + TI_CHI = (MPARAM%LOGLAMB - TI_OFF) / MPARAM%TISHAPE ! Chi -- loglamb is the first parameter (mean) + TI_ARG = MAX(0._sp, TI_LOG - TI_OFF) / TI_CHI ! argument to the incomplete Gamma function + M_FLUX%SATAREA = 1._sp - GAMMP(TI_SHP, TI_ARG) ! GAMMP is the incomplete Gamma function + ENDIF + + ! ----- compute derivatives --------------------------------------------------------------------- + if(comp_dflux) stop "qsatexcess: derivatives for iopt_tmdl_param not implemented yet" + + ! ------------------------------------------------------------------------------------------------ + ! ------------------------------------------------------------------------------------------------ + ! check processed surface runoff selection + CASE DEFAULT + print *, "SMODL%iQSURF must be iopt_arno_x_vic, iopt_prms_varnt, or iopt_tmdl_param" + STOP + + END SELECT ! (different surface runoff options) + + ! ...and, compute surface runoff + ! ------------------------------ + M_FLUX%QSURF = M_FLUX%EFF_PPT * M_FLUX%SATAREA + + end associate ! end association with variables in the data structures + END SUBROUTINE QSATEXCESS_DIFF + +end module QSATEXCESS_DIFF_MODULE diff --git a/build/FUSE_SRC/physics/smoothers.f90 b/build/FUSE_SRC/physics/smoothers.f90 new file mode 100644 index 0000000..7ed972d --- /dev/null +++ b/build/FUSE_SRC/physics/smoothers.f90 @@ -0,0 +1,307 @@ +module smoothers + + implicit none + + private + public:: sigmoid,dsigmoid + public:: LOGISMOOTH + public:: smoother + public:: smax,dsmax + public:: smin,dsmin + public:: sfrac,dsfrac + public:: sclamp,dsclamp + +contains + + ! --------------------------------------------------------------------------------------- + ! --------------------------------------------------------------------------------------- + + PURE FUNCTION sfrac(x,xmax,ms) result(xf) + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! Use smoothed min function to compute smooth fraction + ! --------------------------------------------------------------------------------------- + USE nrtype + implicit none + real(sp), intent(in) :: x ! x value + real(sp), intent(in) :: xmax ! maximum value + real(sp), intent(in) :: ms ! smoothing parameter + real(sp) :: xp ! smooth min(x,xmax) + real(sp) :: xf ! smooth fraction x/xmax + xp = xmax - smax(xmax - x, 0._sp, ms) ! smooth version of min(x, xmax) + xf = max(0._sp, xp) / xmax ! use max(0._sp, xp) to account for small neg values at zero + end function sfrac + + ! --------------------------------------------------------------------------------------- + ! --------------------------------------------------------------------------------------- + + PURE FUNCTION dsfrac(x,xmax,ms) result(dxf_dx) + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! Get derivative of the smooth fraction + ! --------------------------------------------------------------------------------------- + USE nrtype + implicit none + real(sp), intent(in) :: x ! x value + real(sp), intent(in) :: xmax ! maximum value + real(sp), intent(in) :: ms ! smoothing parameter + real(sp) :: dxp_dx ! derivative of the max smoother + real(sp) :: dxf_dx ! derivative of the smoothed fraction + ! NOTE: ignore the hard clamp at zero (very small differences and not worth the extra expense) + dxp_dx = dsmax(xmax - x, 0._sp, ms) ! note signs cancel out + dxf_dx = dxp_dx / xmax + end function dsfrac + + ! --------------------------------------------------------------------------------------- + ! --------------------------------------------------------------------------------------- + + PURE FUNCTION smax(x,xmin,ms) result(xp) + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! Compute smoothed max function following Kavetski and Kuczera (2007) + ! + ! Kavetski, D. and Kuczera, G., 2007. Model smoothing strategies to remove microscale + ! discontinuities and spurious secondary optima in objective functions in hydrological + ! calibration. Water Resources Research, 43(3). + ! --------------------------------------------------------------------------------------- + USE nrtype + implicit none + real(sp), intent(in) :: x ! x value + real(sp), intent(in) :: xmin ! minimum value + real(sp), intent(in) :: ms ! smoothing parameter + real(sp) :: srt ! sqrt(x*x + ms) + real(sp) :: xp ! smooth max(x,xmin) + srt = sqrt((x-xmin)**2 + ms) + xp = 0.5_sp*(x + xmin + srt) ! smooth max(x,xmin) + end function smax + + ! --------------------------------------------------------------------------------------- + ! --------------------------------------------------------------------------------------- + + PURE FUNCTION dsmax(x,xmin,ms) result(dxp) + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! Compute derivative of smoothed max function of Kavetski and Kuczera (2007) + ! + ! Kavetski, D. and Kuczera, G., 2007. Model smoothing strategies to remove microscale + ! discontinuities and spurious secondary optima in objective functions in hydrological + ! calibration. Water Resources Research, 43(3). + ! --------------------------------------------------------------------------------------- + USE nrtype + implicit none + real(sp), intent(in) :: x ! x value + real(sp), intent(in) :: xmin ! minimum value + real(sp), intent(in) :: ms ! smoothing parameter + real(sp) :: u ! x-xmin + real(sp) :: srt ! sqrt(x*x + ms) + real(sp) :: dxp ! derivative of smooth max(x,xmin) + u = x-xmin + srt = sqrt(u*u + ms) + dxp = 0.5_sp*(1._sp + u/srt) ! derivative of smooth max(x,xmin) + end function dsmax + + ! --------------------------------------------------------------------------------------- + ! Extra helper functions + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! compute smin, sclamp, and derivatives + ! --------------------------------------------------------------------------------------- + + pure function smin(x, xmax, ms) result(xp) + use nrtype + implicit none + real(sp), intent(in) :: x, xmax, ms + real(sp) :: xp + xp = xmax - smax(xmax - x, 0._sp, ms) + end function smin + + pure function dsmin(x, xmax, ms) result(dxp) + use nrtype + implicit none + real(sp), intent(in) :: x, xmax, ms + real(sp) :: dxp + dxp = dsmax(xmax - x, 0._sp, ms) + end function dsmin + + pure function sclamp(x, xmin, xmax, ms) result(xp) + use nrtype + implicit none + real(sp), intent(in) :: x, xmin, xmax, ms + real(sp) :: xp + xp = smax( smin(x, xmax, ms), xmin, ms ) + end function sclamp + + pure function dsclamp(x, xmin, xmax, ms) result(dxp) + use nrtype + implicit none + real(sp), intent(in) :: x, xmin, xmax, ms + real(sp) :: v + real(sp) :: dxp + v = smin(x, xmax, ms) + dxp = dsmax(v, xmin, ms) * dsmin(x, xmax, ms) + end function dsclamp + + + ! --------------------------------------------------------------------------------------- + ! --------------------------------------------------------------------------------------- + + pure real(sp) function sigmoid(z, beta) result(s) + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! A simple sigmoid smoother centered on zero + ! --------------------------------------------------------------------------------------- + use nrtype + implicit none + real(sp), intent(in) :: z, beta + real(sp) :: zb + + zb = z/beta + + if (zb >= 0._sp) then + s = 1._sp / (1._sp + exp(-zb)) + else + s = exp(zb) / (1._sp + exp(zb)) + end if + + end function sigmoid + + ! --------------------------------------------------------------------------------------- + ! --------------------------------------------------------------------------------------- + + pure real(sp) function dsigmoid(s, beta) result(ds_dz) + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! Derivative in the sigmoid w.r.t. z given already have the sigmoid + ! --------------------------------------------------------------------------------------- + use nrtype + implicit none + real(sp), intent(in) :: s, beta + ds_dz = (s/beta) * (1._sp - s) + end function dsigmoid + + ! --------------------------------------------------------------------------------------- + ! --------------------------------------------------------------------------------------- + + + PURE FUNCTION smoother(STATE,STATE_MAX,PSMOOTH) result(w_func) + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! Provides the option of different smoothers + ! --------------------------------------------------------------------------------------- + USE nrtype + IMPLICIT NONE + REAL(SP), INTENT(IN) :: STATE ! model state + REAL(SP), INTENT(IN) :: STATE_MAX ! maximum model state + REAL(SP), INTENT(IN) :: PSMOOTH ! smoothing parameter (fraction of state) + real(sp) :: w_func ! smoothed threshold + real(sp) :: delta ! scale factor + + ! logistic smoothing (original) + w_func = LOGISMOOTH(STATE,STATE_MAX,PSMOOTH) + + ! qintic smoother (plays better with Newton) + !delta = MAX(PSMOOTH*STATE_MAX, 1.0e-6_SP*STATE_MAX) + !w_func = SMOOTHSTEP5_W(STATE,STATE_MAX,delta) + + end function smoother + + ! --------------------------------------------------------------------------------------- + ! --------------------------------------------------------------------------------------- + + PURE FUNCTION LOGISMOOTH(STATE,STATE_MAX,PSMOOTH) + ! --------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark, 2007 + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! Uses a logistic function to smooth the threshold at the top of a bucket + ! --------------------------------------------------------------------------------------- + USE nrtype + IMPLICIT NONE + REAL(SP), INTENT(IN) :: STATE ! model state + REAL(SP), INTENT(IN) :: STATE_MAX ! maximum model state + REAL(SP), INTENT(IN) :: PSMOOTH ! smoothing parameter (fraction of state) + real(sp) :: arg ! clamp argument + REAL(SP) :: ASMOOTH ! actual smoothing + REAL(SP) :: LOGISMOOTH ! FUNCTION name + ! --------------------------------------------------------------------------------------- + ASMOOTH = PSMOOTH*STATE_MAX ! actual smoothing + arg = -(STATE - (STATE_MAX - 5*ASMOOTH))/ASMOOTH ! argument + !arg = max(min(arg, 50._SP), -50._SP) ! clamp + LOGISMOOTH = 1._SP / ( 1._SP + EXP(arg) ) + ! --------------------------------------------------------------------------------------- + END FUNCTION LOGISMOOTH + + ! --------------------------------------------------------------------------------------- + ! --------------------------------------------------------------------------------------- + + PURE FUNCTION SMOOTHSTEP5_W(STATE, STATE_MAX, DELTA) RESULT(W) + ! --------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark, 2025 + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! Uses a qintic function to smooth the threshold at the top of a bucket + ! --------------------------------------------------------------------------------------- + USE nrtype + IMPLICIT NONE + REAL(SP), INTENT(IN) :: STATE, STATE_MAX, DELTA + REAL(SP) :: W, x + + x = (STATE - (STATE_MAX - DELTA)) / DELTA + IF (x <= 0._SP) THEN + W = 0._SP + ELSEIF (x >= 1._SP) THEN + W = 1._SP + ELSE + W = x*x*x*(10._SP + x*(-15._SP + 6._SP*x)) + END IF + END FUNCTION + + ! --------------------------------------------------------------------------------------- + ! --------------------------------------------------------------------------------------- + + PURE FUNCTION SMOOTHSTEP5_DWDS(STATE, STATE_MAX, DELTA) RESULT(DWDS) + ! --------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark, 2025 + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! Compute the derivative of the qintic function + ! --------------------------------------------------------------------------------------- + USE nrtype + IMPLICIT NONE + REAL(SP), INTENT(IN) :: STATE, STATE_MAX, DELTA + REAL(SP) :: DWDS, x + + IF (DELTA <= 0._SP) THEN + DWDS = 0._SP + RETURN + END IF + + x = (STATE - (STATE_MAX - DELTA)) / DELTA + IF (x <= 0._SP .OR. x >= 1._SP) THEN + DWDS = 0._SP + ELSE + DWDS = (30._SP * x*x * (1._SP - x)*(1._SP - x)) / DELTA + END IF + END FUNCTION + + ! --------------------------------------------------------------------------------------- + ! --------------------------------------------------------------------------------------- + +end module smoothers diff --git a/build/FUSE_SRC/physics/update_swe_diff.f90 b/build/FUSE_SRC/physics/update_swe_diff.f90 new file mode 100644 index 0000000..b0a6fd6 --- /dev/null +++ b/build/FUSE_SRC/physics/update_swe_diff.f90 @@ -0,0 +1,337 @@ +module update_swe_DIFF_MODULE + + USE model_defn ! model definition structure + USE model_defnames ! integer model definitions + USE globaldata, only : NA_VALUE_SP ! missing vale + + implicit none + + private + public :: update_swe_diff + +contains + + ! --------------------------------------------------------------------------------------- + pure logical function is_leap_year(y) + integer, intent(in) :: y + is_leap_year = (mod(y,4) == 0 .and. (mod(y,100) /= 0 .or. mod(y,400) == 0)) + end function is_leap_year + ! --------------------------------------------------------------------------------------- + + ! --------------------------------------------------------------------------------------- + ! --------------------------------------------------------------------------------------- + SUBROUTINE UPDATE_SWE_DIFF(fuseStruct, DT, want_dparam) + ! --------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Brian Henn, as part of FUSE snow model implementation, 6/2013 + ! Based on subroutines QSATEXCESS and UPDATSTATE, by Martyn Clark + ! + ! Modified by Nans Addor to enable distributed modeling, 9/2016 + ! + ! Modified by Martyn Clark to extend to a differentiable model, 12/2025 + ! + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! Computes the snow accumulation and melt from forcing data + ! Then updates the SWE band states based on the fluxes + ! --------------------------------------------------------------------------------------- + USE nrtype ! variable types, etc. (includes PI) + USE work_types, only: fuse_work ! fuse work type + use smoothers, only: smax, dsmax ! max smoothers + use smoothers, only: smin, dsmin ! min smoothers (based on smax, dsmax) + use smoothers, only: sigmoid, dsigmoid ! sigmoid smoothers + USE globaldata, only: NP => NPAR_SNOW ! number of snow parameters + USE globaldata, only: iMBASE, iMFMAX, iMFMIN, iPXTEMP, iOPG, iLAPSE, & ! indices in vectors + iPERR ! not a snow parameter but used in the snow model + USE multibands, only: N_BANDS ! number of elevation bands + IMPLICIT NONE + ! input + type(fuse_work) , intent(inout) :: fuseStruct ! fuse work structure + REAL(SP), INTENT(IN) :: DT ! length of the time step + logical(lgt), intent(in), optional :: want_dparam ! if we want parameter derivatives + ! ----- internal variables ----------------------------------------------------------------------------- + ! general + INTEGER(I4B) :: ISNW ! loop through snow model bands + REAL(SP) :: DZ ! vert. distance from forcing + real(sp) :: SWE_prev ! SWE at start of band update (mm) + ! melt factor + LOGICAL(LGT) :: LEAP ! leap year flag + REAL(SP) :: JDAY ! Julian day of year + integer(i4b) :: days_in_year ! number of days in year (365 or 366) + integer(i4b) :: phase_shift ! shift in sine curve in days (80 or 81) + real(sp) :: season01 ! seasonal cycle scaled to [0,1] + REAL(SP) :: MF ! melt factor (mm/deg.C-6hr) -- NOTE: check units + ! adjusted precipitation (after precipitation multiplier) + real(sp), parameter :: ms_mult=1.e-4_sp ! smoothing in smax function (additive precip error) + real(sp) :: precip_adj ! adjusted precipitation (after multiplicative/additive error) + ! temperature lapse (simple) + real(sp) :: xLapse ! scaled temperature lapse rate + REAL(SP) :: TEMP_Z ! band temperature at timestep + ! orographic precipitation multiplier (OPG) + real(sp) :: xOPG ! DZ * MPARAM%OPG/1000 -- scaled OPG (dimensionless) + real(sp) :: gate ! hard [0,1] gate on DZ + real(sp) :: fpos ! positive-side formula: 1 + x + real(sp) :: fneg ! megative-side formula: 1/(1-x) + real(sp) :: inv ! 1-x: demominator in negative-side formula: 1/(1-x) + real(sp) :: inv_safe ! safe denominator: max(1-x, eps_inv) + real(sp), parameter :: eps_inv=1.e-6_sp ! denominator floor: dimensionless + real(sp) :: OPG_mult ! final OPG multiplier + REAL(SP) :: PRECIP_Z ! band precipitation at timestep + ! partition rain from snow + real(sp) :: fsnow ! fraction of precip falling as snow (0–1) + real(sp) :: snow ! snowfall rate (mm/day) for this band + real(sp) :: rain ! rainfall rate (mm/day) for this band + real(sp), parameter :: beta_px=0.01_sp ! sigmoid width for snow/rain partition (degC) + ! snowmelt + real(sp), parameter :: ms_temp=1.e-4_sp ! smoothing in smax function (temperature) + real(sp) :: posTemp ! positive-part temperature term used for melt (degC), smoothed + real(sp) :: potMelt ! potential melt rate before capping (mm/day) + real(sp) :: meltCap ! maximum feasible melt rate from availability (mm/day) + real(sp) :: snowmelt ! final (capped) melt rate (mm/day) + real(sp) :: swe_eps=1.e-12_sp ! small value for the derivative switch in u_swe clamp + real(sp) :: u_swe ! pre-clamp SWE update + integer(i4b), parameter :: cumdays0(12) = [ & ! cumulative days before the start of each month + 0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334 ] + integer(i4b) :: cumdays(12) ! cumulative days adjust for leap year + ! internal variables: paraneter derivatives + logical(lgt) :: comp_dparam ! flag to compute parameter derivatives + real(sp) :: df_dz ! precip partitioning + real(sp) :: active, dfpos_dOPG, dinv_dOPG, dfneg_dOPG, dmult_dOPG ! OPG + real(sp) :: dMF(NP), dPadj(NP), dPrecZ(NP), dTempZ(NP) ! derivative vectors + real(sp) :: dfsnow(NP), dsnow(NP), drain(NP) ! derivative vectors + real(sp) :: g_pos, dposTemp(NP), dpotMelt(NP), dsnowmelt(NP) ! derivative vectors + real(sp) :: g_u, dSWE(NP), dSWE_new(NP) ! persist dSWE between timesteps for each band + ! --------------------------------------------------------------------------------------- + ! associate variables with elements of data structure + associate(& + TIMDAT => fuseStruct%step%time , & ! time information + MFORCE => fuseStruct%step%force , & ! forcing data + M_FLUX => fuseStruct%step%flux , & ! fluxes + MBANDS => fuseStruct%snow%sbands , & ! elevation band variables: MBANDS(i)%var, MBANDS(i)info + Z_FORC => fuseStruct%snow%z_forcing , & ! elevation of the forcing data + MPARAM => fuseStruct%par%param_adjust , & ! adjustable model parameters + DPARAM => fuseStruct%par%param_derive & ! derived model parameters + ) ! (associate) + ! --------------------------------------------------------------------------------------- + ! snow accumulation and melt calculations for each band + ! also calculates effective precipitation + ! --------------------------------------------------------------------------------------- + + ! check the need to compute flux derivatives + comp_dparam = .false.; if(present(want_dparam)) comp_dparam = want_dparam + + ! zero derivatives for fluxes constant over elevation bands + if(comp_dparam)then + dMF(:) = 0._sp; dPadj(:) = 0._sp + endif + + ! ----- compute the melt factor --------------------------------------------------------- + + ! adjust cumulative days for leap year + leap = is_leap_year(timDat%IY) + cumdays = cumdays0; if (leap) cumdays(3:12) = cumdays(3:12) + 1 + + ! calculate day of year for melt factor calculation + jday = cumdays(timDat%IM) + timDat%ID + + ! seasonal cycle scaled to [0,1] + days_in_year = merge(366, 365, leap) + phase_shift = merge(81, 80, leap) ! keeps peak timing aligned across leap/non-leap + season01 = 0.5_sp * ( sin( (real(jday - phase_shift, sp) * 2._sp * PI) / real(days_in_year, sp) ) + 1._sp ) + + ! melt factor calculations + mf = MPARAM%MFMIN + season01*(MPARAM%MFMAX - MPARAM%MFMIN) + + ! compute derivatives + if(comp_dparam)then + + ! NOTE: MF = (1−season01)*MFMIN + season01*MFMAX + + dMF(iMFMIN) = 1._sp - season01 + dMF(iMFMAX) = season01 + + endif ! computing derivatives + + ! ----- add error to the precipiation --------------------------------------------------- + + SELECT CASE(SMODL%iRFERR) + CASE(iopt_additive_e); precip_adj = smax(MFORCE%PPT + MPARAM%RFERR_ADD, 0._sp, ms_mult) ! additive error + CASE(iopt_multiplc_e); precip_adj = MFORCE%PPT*MPARAM%RFERR_MLT ! multiplicative error + CASE DEFAULT; stop "swe_update_diff: unable to identify precip error model" + END SELECT + + ! compute derivatives + if(comp_dparam)then + + ! NOTE: parameter vector interprets theta(iPERR) as either RFERR_ADD or RFERR_MLT depending on SMODL%iRFERR + + SELECT CASE(SMODL%iRFERR) + CASE(iopt_additive_e); dPadj(iPERR) = dsmax(MFORCE%PPT + MPARAM%RFERR_ADD, 0._sp, ms_mult) ! additive error + CASE(iopt_multiplc_e); dPadj(iPERR) = MFORCE%PPT ! multiplicative error + CASE DEFAULT; stop "swe_update_diff: unable to identify precip error model" + END SELECT + + endif ! computing derivatives + + ! ----- check OPG ----------------------------------------------------------------------- + + if (MPARAM%OPG < 0._sp) then + stop "swe_update_diff: OPG < 0 not allowed with hard-gate OPG scheme" + end if + + ! --------------------------------------------------------------------------------------- + ! --------------------------------------------------------------------------------------- + + ! initialize effective precip + M_FLUX%EFF_PPT = 0._sp + + ! check band rea fractions sum to 1 + if (abs(sum(MBANDS(:)%info%AF) - 1._sp) > 1.e-6_sp) stop "Band area fractions do not sum to 1" + + ! loop through model bands + DO ISNW=1,N_BANDS + + ! save SWE + SWE_prev = MBANDS(ISNW)%var%SWE + + ! zero derivatives for elevation band fluxes + if(comp_dparam)then + dPrecZ(:) = 0._sp; dTempZ(:) = 0._sp + dfsnow(:) = 0._sp; dsnow(:) = 0._sp; drain(:) = 0._sp + dposTemp(:)=0._sp; dpotMelt(:)=0._sp; dsnowmelt(:)=0._sp + endif + + ! copy the stored sensitivity of SWE from the previous timestep to propagate it forward + if (comp_dparam) dSWE(:) = MBANDS(ISNW)%var%dSWE_dparam(:) + + ! --- use the Orographic Precipitation Gradient (OPG) to adjust precip for elevation --- + + ! dimensionless OPG + DZ = MBANDS(ISNW)%info%Z_MID - Z_FORC + xOPG = DZ * MPARAM%OPG / 1000._sp + + ! hard [0,1] gate by DZ sign (no smoothing): preserves original code from Henn et al. + gate = merge(1._sp, 0._sp, DZ >= 0._sp) ! gate = 1 if DZ >= 0 + + ! positive-side formula: 1 + x + fpos = 1._sp + xOPG + + ! negative-side formula: 1/(1-x), but with hard floor on denominator + inv = 1._sp - xOPG + inv_safe = max(inv, eps_inv) ! hard floor + fneg = 1._sp / inv_safe + + ! blended multiplier and band precip + OPG_mult = gate * fpos + (1._sp - gate) * fneg + PRECIP_Z = precip_adj * OPG_mult + + ! compute derivatives + if(comp_dparam)then + + ! derivative of fpos wrt OPG + dfpos_dOPG = DZ / 1000._sp + + ! derivative of fneg wrt OPG + active = merge(1._sp, 0._sp, inv >= eps_inv) ! deriv is zero if inv is clamped at eps_inv + dinv_dOPG = -(DZ / 1000._sp) ! inv = 1 - xOPG, xOPG = DZ*OPG/1000 + dfneg_dOPG = -(1._sp/(inv_safe*inv_safe)) * (active * dinv_dOPG) + + ! derivative of OPG_mult (ignore derivative of the hard gate) + dmult_dOPG = gate*dfpos_dOPG + (1._sp-gate)*dfneg_dOPG + + ! final derivatives + dPrecZ(:) = dPadj(:) * OPG_mult + dPrecZ(iOPG) = dPrecZ(iOPG) + precip_adj*dmult_dOPG + + endif ! computing derivatives + + ! ----- use the temperature lapse rate to adjust temperature for elevation ------------- + + xLapse = MPARAM%LAPSE/1000._sp ! scaled temperature lapse rate + TEMP_Z = MFORCE%TEMP + DZ*xLapse ! adjust for elevation using lapse rate + + ! compute derivatives + if(comp_dparam) dTempZ(iLAPSE) = DZ/1000._sp + + ! ----- calculate the (smoothed) snow accumulation ------------------------------------- + + ! snowfall and rainfall fluxes + fsnow = sigmoid(MPARAM%PXTEMP - TEMP_Z, beta_px) ! beta_px is the width, set small because originally a step function + snow = PRECIP_Z*fsnow + rain = PRECIP_Z*(1._sp - fsnow) + + MBANDS(ISNW)%var%SNOWACCMLTN = snow + + ! compute derivatives + if(comp_dparam)then + + df_dz = dsigmoid(fsnow, beta_px) ! d(fsnow)/d(z), z=PXTEMP - TEMP_Z + + dfsnow(iPXTEMP) = df_dz + dfsnow(:) = dfsnow(:) - df_dz * dTempZ(:) ! minus because z depends on -TEMP_Z + + dsnow(:) = dPrecZ(:)*fsnow + PRECIP_Z*dfsnow(:) + drain(:) = dPrecZ(:)*(1._sp - fsnow) - PRECIP_Z*dfsnow(:) + + endif ! computing derivatives + + ! ----- calculate the (smoothed) snow melt --------------------------------------------- + + ! potenital melt + posTemp = smax(TEMP_Z - MPARAM%MBASE, 0._sp, ms_temp) ! smoothed max(TEMP_Z - MPARAM%MBASE, 0) + potMelt = MF*posTemp ! mm day-1 + + ! cap snowmelt + meltCap = SWE_prev/DT + snowmelt = min(potMelt, meltCap) ! hard clamp: allow a kink at SWE=0 to avoid "ghost snow" + MBANDS(ISNW)%var%SNOWMELT = snowmelt + + ! compute derivatives + if(comp_dparam)then + + ! positive temperature: smoothed max(TEMP_Z - MPARAM%MBASE, 0) + g_pos = dsmax(TEMP_Z - MPARAM%MBASE, 0._sp, ms_temp) + dposTemp(:) = g_pos * dTempZ(:) + dposTemp(iMBASE) = dposTemp(iMBASE) - g_pos + + ! potential melt + dpotMelt(:) = dMF(:)*posTemp + MF*dposTemp(:) + + ! melt cap + dsnowmelt(:) = merge(dpotMelt(:), dSWE(:)/DT, potMelt <= meltcap) + + endif ! computing derivatives + + ! ----- update SWE --------------------------------------------------------------------- + + u_swe = SWE_prev + DT*(snow - snowmelt) + MBANDS(ISNW)%var%SWE = max(u_swe, 0._sp) ! hard clamp just removes numerical noise + + if(comp_dparam)then + g_u = merge(1._sp, 0._sp, u_swe > swe_eps) ! sensitivities zero in snow free periods + dSWE_new(:) = g_u * ( dSWE(:) + DT*(dsnow(:) - dsnowmelt(:)) ) + MBANDS(ISNW)%var%dSWE_dparam(:) = dSWE_new(:) + endif + + ! ----- calculate effective precip (rain + melt) --------------------------------------- + + M_FLUX%EFF_PPT = M_FLUX%EFF_PPT + MBANDS(ISNW)%info%AF * (rain + snowmelt) + + if(comp_dparam)then + fuseStruct%adj%df_dPar(1:NP)%EFF_PPT = fuseStruct%adj%df_dPar(1:NP)%EFF_PPT + & + MBANDS(ISNW)%info%AF * (drain(:) + dsnowmelt(:)) + endif + + END DO ! looping through elevation bands + + end associate + + ! TEMPORARY: save the derivative as a "fake" loss function + fuseStruct%adj%dL_dPar(:) = NA_VALUE_SP + fuseStruct%adj%dL_dPar(1:NP) = fuseStruct%adj%df_dPar(1:NP)%EFF_PPT + + END SUBROUTINE UPDATE_SWE_DIFF + +end module update_swe_DIFF_MODULE diff --git a/build/FUSE_SRC/physics_orig/mstate_eqn.f90 b/build/FUSE_SRC/physics_orig/mstate_eqn.f90 index 45b371f..9733770 100644 --- a/build/FUSE_SRC/physics_orig/mstate_eqn.f90 +++ b/build/FUSE_SRC/physics_orig/mstate_eqn.f90 @@ -56,7 +56,7 @@ SUBROUTINE MSTATE_EQN() CASE(iopt_unlimfrc_2,iopt_unlimpow_2,iopt_topmdexp_2,iopt_fixedsiz_2) ! single state ! (NOTE: M_FLUX%OFLOW_2=0 for 'unlimfrc_2','unlimpow_2','topmdexp_2') DY_DT%WATR_2 = M_FLUX%QPERC_12 - M_FLUX%EVAP_2 - M_FLUX%QBASE_2 - M_FLUX%OFLOW_2 - !print *, 'in mstate_eqn, layer2 ', M_FLUX%EVAP_2, M_FLUX%QBASE_2, M_FLUX%OFLOW_2 + !print *, 'in mstate_eqn, layer2 ', DY_DT%WATR_2, M_FLUX%EVAP_2, M_FLUX%QBASE_2, M_FLUX%OFLOW_2 CASE DEFAULT print *, "SMODL%iARCH2 must be iopt_tens2pll_2, iopt_unlimfrc_2, iopt_unlimpow_2" print *, " iopt_topmdexp_2, or iopt_fixedsiz_2" diff --git a/build/FUSE_SRC/physics_orig/q_baseflow.f90 b/build/FUSE_SRC/physics_orig/q_baseflow.f90 index d13da29..2f74d70 100644 --- a/build/FUSE_SRC/physics_orig/q_baseflow.f90 +++ b/build/FUSE_SRC/physics_orig/q_baseflow.f90 @@ -34,7 +34,7 @@ SUBROUTINE Q_BASEFLOW() ! -------------------------------------------------------------------------------------- CASE(iopt_unlimpow_2) ! baseflow resvr of unlimited size (0-HUGE), power recession M_FLUX%QBASE_2 = DPARAM%QBSAT * (TSTATE%WATR_2/MPARAM%MAXWATR_2)**MPARAM%QB_POWR - ! -------------------------------------------------------------------------------------- + ! -------------------------------------------------------------------------------------- CASE(iopt_topmdexp_2) ! topmodel exponential reservoir (-HUGE to HUGE) M_FLUX%QBASE_2 = DPARAM%QBSAT * EXP( -(1. - TSTATE%WATR_2/MPARAM%MAXWATR_2) ) ! -------------------------------------------------------------------------------------- diff --git a/build/FUSE_SRC/physics_orig/qsatexcess.f90 b/build/FUSE_SRC/physics_orig/qsatexcess.f90 index 68eb47c..00ffea2 100644 --- a/build/FUSE_SRC/physics_orig/qsatexcess.f90 +++ b/build/FUSE_SRC/physics_orig/qsatexcess.f90 @@ -33,7 +33,7 @@ SUBROUTINE QSATEXCESS() ! saturated area method SELECT CASE(SMODL%iQSURF) CASE(iopt_arno_x_vic) ! ARNO/Xzang/VIC parameterization (upper zone control) - M_FLUX%SATAREA = 1._sp - ( 1._sp - MIN(TSTATE%WATR_1/MPARAM%MAXWATR_1, 1._sp) )**MPARAM%AXV_BEXP + M_FLUX%SATAREA = 1._sp - ( 1._sp - MIN(TSTATE%WATR_1/MPARAM%MAXWATR_1, 1._sp) )**MPARAM%AXV_BEXP CASE(iopt_prms_varnt) ! PRMS variant (fraction of upper tension storage) M_FLUX%SATAREA = MIN(TSTATE%TENS_1/DPARAM%MAXTENS_1, 1._sp) * MPARAM%SAREAMAX CASE(iopt_tmdl_param) ! TOPMODEL parameterization (only valid for TOPMODEL qb) diff --git a/build/FUSE_SRC/physics_orig/update_swe.f90 b/build/FUSE_SRC/physics_orig/update_swe.f90 index 646f73f..be5d69d 100644 --- a/build/FUSE_SRC/physics_orig/update_swe.f90 +++ b/build/FUSE_SRC/physics_orig/update_swe.f90 @@ -5,6 +5,7 @@ SUBROUTINE UPDATE_SWE(DT) ! Brian Henn, as part of FUSE snow model implementation, 6/2013 ! Based on subroutines QSATEXCESS and UPDATSTATE, by Martyn Clark ! Modified by Nans Addor to enable distributed modeling, 9/2016 +! Modified by Martyn Clark to enable the split info/var structure, 01/2026 ! --------------------------------------------------------------------------------------- ! Purpose: ! -------- @@ -59,60 +60,73 @@ SUBROUTINE UPDATE_SWE(DT) ! loop through model bands DO ISNW=1,N_BANDS - ! calculate forcing data for each band - DZ = MBANDS(ISNW)%Z_MID - Z_FORCING + ! --------------------------------------------------------------------------------------- + associate( & ! link to the info and var sub-structures in MBANDS (less invasive / more readable in code below) + z_mid => mbands(isnw)%info%z_mid, & + af => mbands(isnw)%info%af, & + swe => mbands(isnw)%var%swe, & + snowaccmltn => mbands(isnw)%var%snowaccmltn, & + snowmelt => mbands(isnw)%var%snowmelt, & + dswe_dt => mbands(isnw)%var%dswe_dt ) + + ! calculate forcing data for each band + DZ = Z_MID - Z_FORCING TEMP_Z = MFORCE%TEMP + DZ*MPARAM%LAPSE/1000._sp ! adjust for elevation using lapse rate IF (DZ.GT.0._sp) THEN ! adjust for elevation using OPG PRECIP_Z = MFORCE%PPT * (1._sp + DZ*MPARAM%OPG/1000._sp) ELSE PRECIP_Z = MFORCE%PPT / (1._sp - DZ*MPARAM%OPG/1000._sp) ENDIF - IF ((MBANDS(ISNW)%SWE.GT.0._sp).AND.(TEMP_Z.GT.MPARAM%MBASE)) THEN + IF ((SWE.GT.0._sp).AND.(TEMP_Z.GT.MPARAM%MBASE)) THEN ! calculate the initial snowmelt rate from the melt factor and the temperature - MBANDS(ISNW)%SNOWMELT = MF*(TEMP_Z - MPARAM%MBASE) ! MBANDS%SNOWMELT has units of mm day-1 + SNOWMELT = MF*(TEMP_Z - MPARAM%MBASE) ! MBANDS%SNOWMELT has units of mm day-1 ELSE - MBANDS(ISNW)%SNOWMELT = 0.0_sp + SNOWMELT = 0.0_sp ENDIF ! calculate the accumulation rate from the forcing data IF (TEMP_Z.LT.MPARAM%PXTEMP) THEN SELECT CASE(SMODL%iRFERR) CASE(iopt_additive_e) ! additive rainfall error - MBANDS(ISNW)%SNOWACCMLTN = MAX(0.0_sp, PRECIP_Z + MPARAM%RFERR_ADD) + SNOWACCMLTN = MAX(0.0_sp, PRECIP_Z + MPARAM%RFERR_ADD) CASE(iopt_multiplc_e) ! multiplicative rainfall error - MBANDS(ISNW)%SNOWACCMLTN = PRECIP_Z * MPARAM%RFERR_MLT + SNOWACCMLTN = PRECIP_Z * MPARAM%RFERR_MLT CASE DEFAULT ! check for errors print *, "SMODL%iRFERR must be either iopt_additive_e or iopt_multiplc_e" STOP END SELECT ELSE - MBANDS(ISNW)%SNOWACCMLTN = 0.0_sp + SNOWACCMLTN = 0.0_sp ENDIF ! update SWE, and check to ensure non-negative values - MBANDS(ISNW)%DSWE_DT = MBANDS(ISNW)%SNOWACCMLTN - MBANDS(ISNW)%SNOWMELT - IF ((MBANDS(ISNW)%SWE + MBANDS(ISNW)%DSWE_DT*DT).GE.0._sp) THEN - MBANDS(ISNW)%SWE = MBANDS(ISNW)%SWE + MBANDS(ISNW)%DSWE_DT*DT + DSWE_DT = SNOWACCMLTN - SNOWMELT + IF ((SWE + DSWE_DT*DT).GE.0._sp) THEN + SWE = SWE + DSWE_DT*DT ELSE ! reduce melt rate in case of negative SWE - MBANDS(ISNW)%SNOWMELT = MBANDS(ISNW)%SWE/DT + MBANDS(ISNW)%SNOWACCMLTN - MBANDS(ISNW)%SWE = 0.0_sp + SNOWMELT = SWE/DT + SNOWACCMLTN + SWE = 0.0_sp ENDIF ! calculate rainfall plus snowmelt IF (TEMP_Z.GT.MPARAM%PXTEMP) THEN SELECT CASE(SMODL%iRFERR) CASE(iopt_additive_e) ! additive rainfall error - M_FLUX%EFF_PPT = M_FLUX%EFF_PPT + MBANDS(ISNW)%AF * & - (MAX(0.0_sp, PRECIP_Z + MPARAM%RFERR_ADD) + MBANDS(ISNW)%SNOWMELT) + M_FLUX%EFF_PPT = M_FLUX%EFF_PPT + AF * & + (MAX(0.0_sp, PRECIP_Z + MPARAM%RFERR_ADD) + SNOWMELT) CASE(iopt_multiplc_e) ! multiplicative rainfall error - M_FLUX%EFF_PPT = M_FLUX%EFF_PPT + MBANDS(ISNW)%AF * & - (PRECIP_Z * MPARAM%RFERR_MLT + MBANDS(ISNW)%SNOWMELT) + M_FLUX%EFF_PPT = M_FLUX%EFF_PPT + AF * & + (PRECIP_Z * MPARAM%RFERR_MLT + SNOWMELT) CASE DEFAULT ! check for errors print *, "SMODL%iRFERR must be either iopt_additive_e or iopt_multiplc_e" STOP END SELECT ELSE - M_FLUX%EFF_PPT = M_FLUX%EFF_PPT + MBANDS(ISNW)%AF * MBANDS(ISNW)%SNOWMELT + M_FLUX%EFF_PPT = M_FLUX%EFF_PPT + AF * SNOWMELT ENDIF -END DO + + end associate + +END DO ! looping through bands + END SUBROUTINE UPDATE_SWE diff --git a/build/FUSE_SRC/prelim/assign_flx.f90 b/build/FUSE_SRC/prelim/assign_flx.f90 index 7b9f5f4..5f75894 100644 --- a/build/FUSE_SRC/prelim/assign_flx.f90 +++ b/build/FUSE_SRC/prelim/assign_flx.f90 @@ -1,83 +1,93 @@ -SUBROUTINE ASSIGN_FLX() -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2009 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Build an array of strings that list model fluxes used for the current model -! configuration -! --------------------------------------------------------------------------------------- -! Modules Modified: -! ----------------- -! Defines list and number of states in MODULE model_defn -! --------------------------------------------------------------------------------------- -USE model_defn ! model definition -USE model_defnames -IMPLICIT NONE -INTEGER(I4B) :: I_FLUX ! just used for testing -LOGICAL(LGT) :: L_TEST ! just used for testing -! --------------------------------------------------------------------------------------- -L_TEST=.FALSE. -N_FLUX=0 -C_FLUX(:)%FNAME = ' ' -! --------------------------------------------------------------------------------------- -! (1) DEFINE STATE VARIABLES IN THE UPPER LAYER -! --------------------------------------------------------------------------------------- -SELECT CASE(SMODL%iARCH1) - CASE(iopt_tension2_1) - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'EFF_PPT ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'EVAP_1A ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'EVAP_1B ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'RCHR2EXCS ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'TENS2FREE_1' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'QPERC_12 ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'QINTF_1 ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'OFLOW_1 ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'QSURF ' - CASE(iopt_tension1_1) - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'EFF_PPT ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'EVAP_1 ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'TENS2FREE_1' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'QPERC_12 ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'QINTF_1 ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'OFLOW_1 ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'QSURF ' - CASE(iopt_onestate_1) - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'EFF_PPT ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'EVAP_1 ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'QPERC_12 ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'QINTF_1 ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'OFLOW_1 ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'QSURF ' - CASE DEFAULT - print *, "MDEFN(IMOD)%iARCH1 must be iopt_tension2_1, iopt_tension1_1, or iopt_onestate_1" - STOP -END SELECT -! --------------------------------------------------------------------------------------- -! (2) DEFINE STATE VARIABLES IN THE LOWER LAYER -! --------------------------------------------------------------------------------------- -SELECT CASE(SMODL%iARCH2) - CASE(iopt_tens2pll_2) - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'EVAP_2 ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'TENS2FREE_2' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'QBASE_2A ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'QBASE_2B ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'QBASE_2 ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'OFLOW_2A ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'OFLOW_2B ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'OFLOW_2 ' - CASE(iopt_unlimfrc_2,iopt_unlimpow_2,iopt_topmdexp_2,iopt_fixedsiz_2) - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'EVAP_2 ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'QBASE_2 ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'OFLOW_2 ' - CASE DEFAULT - print *, "SMODL%iARCH2 must be iopt_tens2pll_2, iopt_unlimfrc_2, iopt_unlimpow_2" - print *, " iopt_topmdexp_2, or iopt_fixedsiz_2" - STOP -END SELECT -! --------------------------------------------------------------------------------------- -IF (L_TEST) THEN; DO I_FLUX=1,N_FLUX; WRITE(*,'(A20)') C_FLUX(I_FLUX)%FNAME; END DO; ENDIF -! --------------------------------------------------------------------------------------- -END SUBROUTINE ASSIGN_FLX +module ASSIGN_FLX_module + implicit none + private + public :: ASSIGN_FLX + +contains + + + SUBROUTINE ASSIGN_FLX() + ! --------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark, 2009 + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! Build an array of strings that list model fluxes used for the current model + ! configuration + ! --------------------------------------------------------------------------------------- + ! Modules Modified: + ! ----------------- + ! Defines list and number of states in MODULE model_defn + ! --------------------------------------------------------------------------------------- + USE model_defn ! model definition + USE model_defnames + IMPLICIT NONE + INTEGER(I4B) :: I_FLUX ! just used for testing + LOGICAL(LGT) :: L_TEST ! just used for testing + ! --------------------------------------------------------------------------------------- + L_TEST=.FALSE. + N_FLUX=0 + C_FLUX(:)%FNAME = ' ' + ! --------------------------------------------------------------------------------------- + ! (1) DEFINE STATE VARIABLES IN THE UPPER LAYER + ! --------------------------------------------------------------------------------------- + SELECT CASE(SMODL%iARCH1) + CASE(iopt_tension2_1) + N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'EFF_PPT ' + N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'EVAP_1A ' + N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'EVAP_1B ' + N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'RCHR2EXCS ' + N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'TENS2FREE_1' + N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'QPERC_12 ' + N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'QINTF_1 ' + N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'OFLOW_1 ' + N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'QSURF ' + CASE(iopt_tension1_1) + N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'EFF_PPT ' + N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'EVAP_1 ' + N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'TENS2FREE_1' + N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'QPERC_12 ' + N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'QINTF_1 ' + N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'OFLOW_1 ' + N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'QSURF ' + CASE(iopt_onestate_1) + N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'EFF_PPT ' + N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'EVAP_1 ' + N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'QPERC_12 ' + N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'QINTF_1 ' + N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'OFLOW_1 ' + N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'QSURF ' + CASE DEFAULT + print *, "MDEFN(IMOD)%iARCH1 must be iopt_tension2_1, iopt_tension1_1, or iopt_onestate_1" + STOP + END SELECT + ! --------------------------------------------------------------------------------------- + ! (2) DEFINE STATE VARIABLES IN THE LOWER LAYER + ! --------------------------------------------------------------------------------------- + SELECT CASE(SMODL%iARCH2) + CASE(iopt_tens2pll_2) + N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'EVAP_2 ' + N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'TENS2FREE_2' + N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'QBASE_2A ' + N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'QBASE_2B ' + N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'QBASE_2 ' + N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'OFLOW_2A ' + N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'OFLOW_2B ' + N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'OFLOW_2 ' + CASE(iopt_unlimfrc_2,iopt_unlimpow_2,iopt_topmdexp_2,iopt_fixedsiz_2) + N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'EVAP_2 ' + N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'QBASE_2 ' + N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'OFLOW_2 ' + CASE DEFAULT + print *, "SMODL%iARCH2 must be iopt_tens2pll_2, iopt_unlimfrc_2, iopt_unlimpow_2" + print *, " iopt_topmdexp_2, or iopt_fixedsiz_2" + STOP + END SELECT + ! --------------------------------------------------------------------------------------- + IF (L_TEST) THEN; DO I_FLUX=1,N_FLUX; WRITE(*,'(A20)') C_FLUX(I_FLUX)%FNAME; END DO; ENDIF + ! --------------------------------------------------------------------------------------- + END SUBROUTINE ASSIGN_FLX + +end module ASSIGN_FLX_module diff --git a/build/FUSE_SRC/prelim/assign_par.f90 b/build/FUSE_SRC/prelim/assign_par.f90 index 5558eae..07b880a 100644 --- a/build/FUSE_SRC/prelim/assign_par.f90 +++ b/build/FUSE_SRC/prelim/assign_par.f90 @@ -1,200 +1,209 @@ -SUBROUTINE ASSIGN_PAR() -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2007 -! Modified by Brian Henn to include snow model, 6/2013 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Gets a list of model parameters used for the unique model in the structure SMODL -! --------------------------------------------------------------------------------------- -! Modules Modified: -! ----------------- -! MODULE multi_flux -- list of model parameters is stored in MODULE multiparam -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -USE model_defn ! model definition structure -USE model_defnames -USE multiparam, ONLY : lparam, paratt, numpar ! model parameter structures -USE getpar_str_module ! access to SUBROUTINE get_par_str -IMPLICIT NONE -INTEGER(I4B) :: MPAR ! counter for number of parameters -TYPE(PARATT) :: PARAM_LEV1 ! parameter metadata (level 1) -TYPE(PARATT) :: PARAM_LEV2 ! parameter metadata (level 2) -! --------------------------------------------------------------------------------------- -MPAR = 0 ! initialize the number of model parameters -LPARAM(:)%PARNAME = 'PAR_NOUSE' -! --------------------------------------------------------------------------------------- -! (1) RAINFALL ERRORS -! --------------------------------------------------------------------------------------- +module ASSIGN_PAR_module + implicit none + private + public :: ASSIGN_PAR -SELECT CASE(SMODL%iRFERR) - CASE(iopt_additive_e) ! additive rainfall error - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'RFERR_ADD' ! additive rainfall error (mm day-1) - CASE(iopt_multiplc_e) ! multiplicative rainfall error - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'RFERR_MLT' ! multiplicative rainfall error (-) - ! check if RFERR_MLT has any prior/hyper-parameters, and, if so, save them - CALL GETPAR_STR('RFERR_MLT',PARAM_LEV1) - IF (PARAM_LEV1%NPRIOR.GT.0) THEN - ! process 1st child - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME=PARAM_LEV1%CHILD1(1:9) ! save 1st child - CALL GETPAR_STR(PARAM_LEV1%CHILD1,PARAM_LEV2) ! get metadata for 1st child - IF (PARAM_LEV2%NPRIOR.GT.0) THEN ! check if 1st child has prior/hyper-param - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME=PARAM_LEV2%CHILD1(1:9) ! save 1st grandchild (from 1st child) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME=PARAM_LEV2%CHILD2(1:9) ! save 2nd grandchild (from 1st child) - ENDIF - ! process 2nd child - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME=PARAM_LEV1%CHILD2(1:9) ! save 2nd child - CALL GETPAR_STR(PARAM_LEV1%CHILD2,PARAM_LEV2) ! get metadata for 1st child - IF (PARAM_LEV2%NPRIOR.GT.0) THEN ! check if 1st child has prior/hyper-param - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME=PARAM_LEV2%CHILD1(1:9) ! save 1st grandchild (from 2nd child) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME=PARAM_LEV2%CHILD2(1:9) ! save 2nd grandchild (from 2nd child) - ENDIF - ENDIF - CASE DEFAULT - print *, "SMODL%RFERR must be 'additive_e' or 'multiplc_e'" - STOP -END SELECT ! (different upper-layer architecture) -! --------------------------------------------------------------------------------------- -! (2) UPPER-LAYER ARCHITECTURE -! --------------------------------------------------------------------------------------- -SELECT CASE(SMODL%iARCH1) - CASE(iopt_tension2_1) ! tension storage sub-divided into recharge and excess - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'FRCHZNE ' ! PRMS: frac tension storage in recharge zone (-) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'FRACTEN ' ! frac total storage as tension storage (-) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'MAXWATR_1' ! maximum total storage in layer1 (mm) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'FRACLOWZ ' ! fraction of soil excess to lower zone (-) - CASE(iopt_tension1_1,iopt_onestate_1) ! (need to define tension and free storage -- even if one state) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'FRACTEN ' ! frac total storage as tension storage (-) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'MAXWATR_1' ! maximum total storage in layer1 (mm) - CASE DEFAULT - print *, "SMODL%iARCH1 must be iopt_tension2_1, iopt_tension1_1, or iopt_onestate_1" - STOP -END SELECT ! (different upper-layer architechure) -! --------------------------------------------------------------------------------------- -! (3) LOWER-LAYER ARCHITECTURE / BASEFLOW -! --------------------------------------------------------------------------------------- -SELECT CASE(SMODL%iARCH2) - CASE(iopt_tens2pll_2) ! tension reservoir plus two parallel tanks - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'PERCFRAC ' ! fraction of percolation to tension storage (-) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'FPRIMQB ' ! SAC: fraction of baseflow in primary resvr (-) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'MAXWATR_2' ! maximum total storage in layer2 (mm) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'QBRATE_2A ' ! baseflow depletion rate for primary resvr (day-1) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'QBRATE_2B ' ! baseflow depletion rate for secondary resvr (day-1) - CASE(iopt_unlimfrc_2) ! baseflow resvr of unlimited size (0-HUGE), frac rate - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'MAXWATR_2' ! maximum total storage in layer2 (mm) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'QB_PRMS ' ! baseflow depletion rate (day-1) - CASE(iopt_topmdexp_2,iopt_unlimpow_2) ! topmodel options - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'MAXWATR_2' ! maximum total storage in layer2 (mm) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'BASERTE ' ! baseflow rate (mm day-1) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'LOGLAMB ' ! mean value of the log-transformed topographic index (m) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'TISHAPE ' ! shape parameter for the topo index Gamma distribution (-) - ! (add extra paramater for the power-law transmissivity profile) - IF (SMODL%iARCH2.EQ.iopt_unlimpow_2) THEN ! (power-law transmissivity profile) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'QB_POWR ' ! baseflow exponent (-) - ENDIF - CASE(iopt_fixedsiz_2) ! power-law relation (no parameters needed for the topo index distribution) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'MAXWATR_2' ! maximum total storage in layer2 (mm) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'BASERTE ' ! baseflow rate (mm day-1) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'QB_POWR ' ! baseflow exponent (-) - CASE DEFAULT - print *, "SMODL%iARCH2 must be iopt_tens2pll_2, iopt_unlimfrc_2, iopt_unlimpow_2" - print *, " 'topmdexp_2', or 'fixedsiz_2'" - STOP -END SELECT ! different lower-layer architecture / baseflow parameterizations) -! --------------------------------------------------------------------------------------- -! (4) EVAPORATION -! --------------------------------------------------------------------------------------- -SELECT CASE(SMODL%iESOIL) - CASE(iopt_sequential) - ! (no additional parameters for the sequential scheme) - CASE(iopt_rootweight) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'RTFRAC1 ' ! fraction of roots in the upper layer (-) - CASE DEFAULT - print *, "SMODL%iESOIL must be either iopt_sequential or iopt_rootweight'" -END SELECT ! (different evaporation schemes) -! --------------------------------------------------------------------------------------- -! (5) PERCOLATION -! --------------------------------------------------------------------------------------- -SELECT CASE(SMODL%iQPERC) - CASE(iopt_perc_f2sat,iopt_perc_w2sat) ! standard equation k(theta)**c - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'PERCRTE ' ! percolation rate (mm day-1) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'PERCEXP ' ! percolation exponent (-) - CASE(iopt_perc_lower) ! perc defined by moisture content in lower layer (SAC) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'SACPMLT ' ! multiplier in the SAC model for dry lower layer (-) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'SACPEXP ' ! exponent in the SAC model for dry lower layer (-) - CASE DEFAULT ! check for errors - print *, "SMODL%iQPERC must be iopt_perc_f2sat, iopt_perc_w2sat, or iopt_perc_lower" - STOP -END SELECT ! (different percolation options) -! --------------------------------------------------------------------------------------- -! (6) INTERFLOW -! --------------------------------------------------------------------------------------- -SELECT CASE(SMODL%iQINTF) - CASE(iopt_intflwsome) ! interflow - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'IFLWRTE ' ! interflow rate (mm day-1) - CASE(iopt_intflwnone) ! no interflow - ! (no additional parameters for the case of no interflow) - CASE DEFAULT ! check for errors - print *, "SMODL%iQINTF must be either iopt_intflwsome' or iopt_intflwnone'" - STOP -END SELECT ! (different interflow options) -! --------------------------------------------------------------------------------------- -! (7) SURFACE RUNOFF -! --------------------------------------------------------------------------------------- -SELECT CASE(SMODL%iQSURF) - CASE(iopt_arno_x_vic) ! ARNO/Xzang/VIC parameterization (upper zone control) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'AXV_BEXP ' ! ARNO/VIC "b" exponent - CASE(iopt_prms_varnt) ! PRMS variant (fraction of upper tension storage) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'SAREAMAX ' ! maximum saturated area - CASE(iopt_tmdl_param) ! TOPMODEL parameterization - ! need the topographic index if we don't have it for baseflow - IF (SMODL%iARCH2.EQ.iopt_tens2pll_2 .OR. SMODL%iARCH2.EQ.iopt_unlimfrc_2 .OR. & - SMODL%iARCH2.EQ.iopt_fixedsiz_2) THEN - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'LOGLAMB ' ! mean value of the log-transformed topographic index (m) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'TISHAPE ' ! shape parameter for the topo index Gamma distribution (-) - ENDIF - ! need the topmodel power if we don't have it for baseflow - IF (SMODL%iARCH2.EQ.iopt_tens2pll_2 .OR. SMODL%iARCH2.EQ.iopt_unlimfrc_2 .OR. & - SMODL%iARCH2.EQ.iopt_topmdexp_2) THEN - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'QB_POWR ' ! baseflow exponent (-), used to modify the topographic index - ENDIF - CASE DEFAULT - print *, "SMODL%iQSURF must be iopt_arno_x_vic, iopt_prms_varnt, or iopt_tmdl_param" - STOP -END SELECT ! (different surface runoff options) -! --------------------------------------------------------------------------------------- -! (8) TIME DELAY IN RUNOFF -! --------------------------------------------------------------------------------------- -SELECT CASE(SMODL%iQ_TDH) - CASE(iopt_rout_gamma) ! use a Gamma distribution with shape parameter = 2.5 - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'TIMEDELAY' ! time delay in runoff - CASE(iopt_no_routing) ! no routing - ! (no additional parameters when there is no time delay in runoff) - CASE DEFAULT ! check for errors - print *, "SMODL%iQ_TDH must be either iopt_rout_gamma or iopt_no_routing" - STOP -END SELECT -! --------------------------------------------------------------------------------------- -! (9) SNOW MODEL -! --------------------------------------------------------------------------------------- -SELECT CASE(SMODL%iSNOWM) - CASE(iopt_temp_index) ! temperature index snow model - MPAR = MPAR + 1; LPARAM(MPAR)%PARNAME = 'MBASE ' ! snow base melting temperature - MPAR = MPAR + 1; LPARAM(MPAR)%PARNAME = 'MFMAX ' ! snow maximum melt factor - MPAR = MPAR + 1; LPARAM(MPAR)%PARNAME = 'MFMIN ' ! snow minimum melt factor - MPAR = MPAR + 1; LPARAM(MPAR)%PARNAME = 'PXTEMP ' ! rain snow partition temperature - MPAR = MPAR + 1; LPARAM(MPAR)%PARNAME = 'OPG ' ! precipitation gradient - MPAR = MPAR + 1; LPARAM(MPAR)%PARNAME = 'LAPSE ' ! temperature gradient - CASE(iopt_no_snowmod) ! if no snow model, no additional parameters - CASE DEFAULT - print *, "SMODL%SNOWM must be either 'temp_index' or 'no_snowmod'" - STOP -END SELECT -! --------------------------------------------------------------------------------------- -NUMPAR = MPAR ! save the number of model parameters used in a given model SMODL -! --------------------------------------------------------------------------------------- -!DO MPAR=1,NUMPAR; WRITE(*,'(A11,1X)') LPARAM(MPAR)%PARNAME; END DO -! --------------------------------------------------------------------------------------- -END SUBROUTINE ASSIGN_PAR +contains + + SUBROUTINE ASSIGN_PAR() + ! --------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark, 2007 + ! Modified by Brian Henn to include snow model, 6/2013 + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! Gets a list of model parameters used for the unique model in the structure SMODL + ! --------------------------------------------------------------------------------------- + ! Modules Modified: + ! ----------------- + ! MODULE multi_flux -- list of model parameters is stored in MODULE multiparam + ! --------------------------------------------------------------------------------------- + USE nrtype ! variable types, etc. + USE model_defn ! model definition structure + USE model_defnames + USE multiparam_types, only: PARATT ! parameter attribute structure + USE multiparam, ONLY : lparam, numpar ! model parameter structures + USE getpar_str_module ! access to SUBROUTINE get_par_str + IMPLICIT NONE + INTEGER(I4B) :: MPAR ! counter for number of parameters + TYPE(PARATT) :: PARAM_LEV1 ! parameter metadata (level 1) + TYPE(PARATT) :: PARAM_LEV2 ! parameter metadata (level 2) + ! --------------------------------------------------------------------------------------- + MPAR = 0 ! initialize the number of model parameters + LPARAM(:)%PARNAME = 'PAR_NOUSE' + ! --------------------------------------------------------------------------------------- + ! (1) PRECIPITATION ERRORS + ! --------------------------------------------------------------------------------------- + SELECT CASE(SMODL%iRFERR) + CASE(iopt_additive_e) ! additive rainfall error + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'RFERR_ADD' ! additive rainfall error (mm day-1) + CASE(iopt_multiplc_e) ! multiplicative rainfall error + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'RFERR_MLT' ! multiplicative rainfall error (-) + ! check if RFERR_MLT has any prior/hyper-parameters, and, if so, save them + CALL GETPAR_STR('RFERR_MLT',PARAM_LEV1) + IF (PARAM_LEV1%NPRIOR.GT.0) THEN + ! process 1st child + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME=PARAM_LEV1%CHILD1(1:9) ! save 1st child + CALL GETPAR_STR(PARAM_LEV1%CHILD1,PARAM_LEV2) ! get metadata for 1st child + IF (PARAM_LEV2%NPRIOR.GT.0) THEN ! check if 1st child has prior/hyper-param + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME=PARAM_LEV2%CHILD1(1:9) ! save 1st grandchild (from 1st child) + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME=PARAM_LEV2%CHILD2(1:9) ! save 2nd grandchild (from 1st child) + ENDIF + ! process 2nd child + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME=PARAM_LEV1%CHILD2(1:9) ! save 2nd child + CALL GETPAR_STR(PARAM_LEV1%CHILD2,PARAM_LEV2) ! get metadata for 1st child + IF (PARAM_LEV2%NPRIOR.GT.0) THEN ! check if 1st child has prior/hyper-param + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME=PARAM_LEV2%CHILD1(1:9) ! save 1st grandchild (from 2nd child) + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME=PARAM_LEV2%CHILD2(1:9) ! save 2nd grandchild (from 2nd child) + ENDIF + ENDIF + CASE DEFAULT + print *, "SMODL%RFERR must be 'additive_e' or 'multiplc_e'" + STOP + END SELECT ! (different upper-layer architecture) + ! --------------------------------------------------------------------------------------- + ! (2) SNOW MODEL + ! --------------------------------------------------------------------------------------- + SELECT CASE(SMODL%iSNOWM) + CASE(iopt_temp_index) ! temperature index snow model + MPAR = MPAR + 1; LPARAM(MPAR)%PARNAME = 'MBASE ' ! snow base melting temperature + MPAR = MPAR + 1; LPARAM(MPAR)%PARNAME = 'MFMAX ' ! snow maximum melt factor + MPAR = MPAR + 1; LPARAM(MPAR)%PARNAME = 'MFMIN ' ! snow minimum melt factor + MPAR = MPAR + 1; LPARAM(MPAR)%PARNAME = 'PXTEMP ' ! rain snow partition temperature + MPAR = MPAR + 1; LPARAM(MPAR)%PARNAME = 'OPG ' ! precipitation gradient + MPAR = MPAR + 1; LPARAM(MPAR)%PARNAME = 'LAPSE ' ! temperature gradient + CASE(iopt_no_snowmod) ! if no snow model, no additional parameters + CASE DEFAULT + print *, "SMODL%SNOWM must be either 'temp_index' or 'no_snowmod'" + STOP + END SELECT + ! --------------------------------------------------------------------------------------- + ! (3) UPPER-LAYER ARCHITECTURE + ! --------------------------------------------------------------------------------------- + SELECT CASE(SMODL%iARCH1) + CASE(iopt_tension2_1) ! tension storage sub-divided into recharge and excess + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'FRCHZNE ' ! PRMS: frac tension storage in recharge zone (-) + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'FRACTEN ' ! frac total storage as tension storage (-) + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'MAXWATR_1' ! maximum total storage in layer1 (mm) + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'FRACLOWZ ' ! fraction of soil excess to lower zone (-) + CASE(iopt_tension1_1,iopt_onestate_1) ! (need to define tension and free storage -- even if one state) + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'FRACTEN ' ! frac total storage as tension storage (-) + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'MAXWATR_1' ! maximum total storage in layer1 (mm) + CASE DEFAULT + print *, "SMODL%iARCH1 must be iopt_tension2_1, iopt_tension1_1, or iopt_onestate_1" + STOP + END SELECT ! (different upper-layer architechure) + ! --------------------------------------------------------------------------------------- + ! (4) LOWER-LAYER ARCHITECTURE / BASEFLOW + ! --------------------------------------------------------------------------------------- + SELECT CASE(SMODL%iARCH2) + CASE(iopt_tens2pll_2) ! tension reservoir plus two parallel tanks + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'PERCFRAC ' ! fraction of percolation to tension storage (-) + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'FPRIMQB ' ! SAC: fraction of baseflow in primary resvr (-) + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'MAXWATR_2' ! maximum total storage in layer2 (mm) + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'QBRATE_2A ' ! baseflow depletion rate for primary resvr (day-1) + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'QBRATE_2B ' ! baseflow depletion rate for secondary resvr (day-1) + CASE(iopt_unlimfrc_2) ! baseflow resvr of unlimited size (0-HUGE), frac rate + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'MAXWATR_2' ! maximum total storage in layer2 (mm) + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'QB_PRMS ' ! baseflow depletion rate (day-1) + CASE(iopt_topmdexp_2,iopt_unlimpow_2) ! topmodel options + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'MAXWATR_2' ! maximum total storage in layer2 (mm) + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'BASERTE ' ! baseflow rate (mm day-1) + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'LOGLAMB ' ! mean value of the log-transformed topographic index (m) + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'TISHAPE ' ! shape parameter for the topo index Gamma distribution (-) + ! (add extra paramater for the power-law transmissivity profile) + IF (SMODL%iARCH2.EQ.iopt_unlimpow_2) THEN ! (power-law transmissivity profile) + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'QB_POWR ' ! baseflow exponent (-) + ENDIF + CASE(iopt_fixedsiz_2) ! power-law relation (no parameters needed for the topo index distribution) + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'MAXWATR_2' ! maximum total storage in layer2 (mm) + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'BASERTE ' ! baseflow rate (mm day-1) + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'QB_POWR ' ! baseflow exponent (-) + CASE DEFAULT + print *, "SMODL%iARCH2 must be iopt_tens2pll_2, iopt_unlimfrc_2, iopt_unlimpow_2" + print *, " 'topmdexp_2', or 'fixedsiz_2'" + STOP + END SELECT ! different lower-layer architecture / baseflow parameterizations) + ! --------------------------------------------------------------------------------------- + ! (5) EVAPORATION + ! --------------------------------------------------------------------------------------- + SELECT CASE(SMODL%iESOIL) + CASE(iopt_sequential) + ! (no additional parameters for the sequential scheme) + CASE(iopt_rootweight) + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'RTFRAC1 ' ! fraction of roots in the upper layer (-) + CASE DEFAULT + print *, "SMODL%iESOIL must be either iopt_sequential or iopt_rootweight'" + END SELECT ! (different evaporation schemes) + ! --------------------------------------------------------------------------------------- + ! (6) PERCOLATION + ! --------------------------------------------------------------------------------------- + SELECT CASE(SMODL%iQPERC) + CASE(iopt_perc_f2sat,iopt_perc_w2sat) ! standard equation k(theta)**c + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'PERCRTE ' ! percolation rate (mm day-1) + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'PERCEXP ' ! percolation exponent (-) + CASE(iopt_perc_lower) ! perc defined by moisture content in lower layer (SAC) + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'SACPMLT ' ! multiplier in the SAC model for dry lower layer (-) + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'SACPEXP ' ! exponent in the SAC model for dry lower layer (-) + CASE DEFAULT ! check for errors + print *, "SMODL%iQPERC must be iopt_perc_f2sat, iopt_perc_w2sat, or iopt_perc_lower" + STOP + END SELECT ! (different percolation options) + ! --------------------------------------------------------------------------------------- + ! (7) INTERFLOW + ! --------------------------------------------------------------------------------------- + SELECT CASE(SMODL%iQINTF) + CASE(iopt_intflwsome) ! interflow + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'IFLWRTE ' ! interflow rate (mm day-1) + CASE(iopt_intflwnone) ! no interflow + ! (no additional parameters for the case of no interflow) + CASE DEFAULT ! check for errors + print *, "SMODL%iQINTF must be either iopt_intflwsome' or iopt_intflwnone'" + STOP + END SELECT ! (different interflow options) + ! --------------------------------------------------------------------------------------- + ! (8) SURFACE RUNOFF + ! --------------------------------------------------------------------------------------- + SELECT CASE(SMODL%iQSURF) + CASE(iopt_arno_x_vic) ! ARNO/Xzang/VIC parameterization (upper zone control) + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'AXV_BEXP ' ! ARNO/VIC "b" exponent + CASE(iopt_prms_varnt) ! PRMS variant (fraction of upper tension storage) + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'SAREAMAX ' ! maximum saturated area + CASE(iopt_tmdl_param) ! TOPMODEL parameterization + ! need the topographic index if we don't have it for baseflow + IF (SMODL%iARCH2.EQ.iopt_tens2pll_2 .OR. SMODL%iARCH2.EQ.iopt_unlimfrc_2 .OR. & + SMODL%iARCH2.EQ.iopt_fixedsiz_2) THEN + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'LOGLAMB ' ! mean value of the log-transformed topographic index (m) + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'TISHAPE ' ! shape parameter for the topo index Gamma distribution (-) + ENDIF + ! need the topmodel power if we don't have it for baseflow + IF (SMODL%iARCH2.EQ.iopt_tens2pll_2 .OR. SMODL%iARCH2.EQ.iopt_unlimfrc_2 .OR. & + SMODL%iARCH2.EQ.iopt_topmdexp_2) THEN + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'QB_POWR ' ! baseflow exponent (-), used to modify the topographic index + ENDIF + CASE DEFAULT + print *, "SMODL%iQSURF must be iopt_arno_x_vic, iopt_prms_varnt, or iopt_tmdl_param" + STOP + END SELECT ! (different surface runoff options) + ! --------------------------------------------------------------------------------------- + ! (9) TIME DELAY IN RUNOFF + ! --------------------------------------------------------------------------------------- + SELECT CASE(SMODL%iQ_TDH) + CASE(iopt_rout_gamma) ! use a Gamma distribution with shape parameter = 2.5 + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'TIMEDELAY' ! time delay in runoff + CASE(iopt_no_routing) ! no routing + ! (no additional parameters when there is no time delay in runoff) + CASE DEFAULT ! check for errors + print *, "SMODL%iQ_TDH must be either iopt_rout_gamma or iopt_no_routing" + STOP + END SELECT + ! --------------------------------------------------------------------------------------- + NUMPAR = MPAR ! save the number of model parameters used in a given model SMODL + ! --------------------------------------------------------------------------------------- + !DO MPAR=1,NUMPAR; WRITE(*,'(A11,1X)') LPARAM(MPAR)%PARNAME; END DO + ! --------------------------------------------------------------------------------------- + END SUBROUTINE ASSIGN_PAR + +end module ASSIGN_PAR_module diff --git a/build/FUSE_SRC/prelim/assign_stt.f90 b/build/FUSE_SRC/prelim/assign_stt.f90 index b500f22..218a047 100644 --- a/build/FUSE_SRC/prelim/assign_stt.f90 +++ b/build/FUSE_SRC/prelim/assign_stt.f90 @@ -1,60 +1,70 @@ -SUBROUTINE ASSIGN_STT() -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2007 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Build an array of strings that list model states used for the current model -! configuration -! --------------------------------------------------------------------------------------- -! Modules Modified: -! ----------------- -! Defines list and number of states in MODULE model_defn -! --------------------------------------------------------------------------------------- -USE model_defn ! model definition -USE model_defnames -IMPLICIT NONE -! --------------------------------------------------------------------------------------- -NSTATE=0 -!CSTATE(:)%SNAME(1:6) = 'NO_USE' -! --------------------------------------------------------------------------------------- -! (1) DEFINE STATE VARIABLES IN THE UPPER LAYER -! --------------------------------------------------------------------------------------- -SELECT CASE(SMODL%iARCH1) - CASE(iopt_tension2_1) - CSTATE(NSTATE+1)%iSNAME = iopt_TENS1A - CSTATE(NSTATE+2)%iSNAME = iopt_TENS1B - CSTATE(NSTATE+3)%iSNAME = iopt_FREE_1 - NSTATE = NSTATE+3 - CASE(iopt_tension1_1) - CSTATE(NSTATE+1)%iSNAME = iopt_TENS_1 - CSTATE(NSTATE+2)%iSNAME = iopt_FREE_1 - NSTATE = NSTATE+2 - CASE(iopt_onestate_1) - CSTATE(NSTATE+1)%iSNAME = iopt_WATR_1 - NSTATE = NSTATE+1 - CASE DEFAULT - print *, "MDEFN(IMOD)%iARCH1 must be iopt_tension2_1, iopt_tension1_1, or iopt_onestate_1" - STOP -END SELECT -! --------------------------------------------------------------------------------------- -! (2) DEFINE STATE VARIABLES IN THE LOWER LAYER -! --------------------------------------------------------------------------------------- -SELECT CASE(SMODL%iARCH2) - CASE(iopt_tens2pll_2) - CSTATE(NSTATE+1)%iSNAME = iopt_TENS_2 - CSTATE(NSTATE+2)%iSNAME = iopt_FREE2A - CSTATE(NSTATE+3)%iSNAME = iopt_FREE2B - NSTATE = NSTATE+3 - CASE(iopt_unlimfrc_2,iopt_unlimpow_2,iopt_topmdexp_2,iopt_fixedsiz_2) - CSTATE(NSTATE+1)%iSNAME = iopt_WATR_2 - NSTATE = NSTATE+1 - CASE DEFAULT - print *, "SMODL%iARCH2 must be iopt_tens2pll_2, iopt_unlimfrc_2, iopt_unlimpow_2" - print *, " iopt_topmdexp_2, or iopt_fixedsiz_2" - STOP -END SELECT -! --------------------------------------------------------------------------------------- -END SUBROUTINE ASSIGN_STT +module ASSIGN_STT_module + + implicit none + private + public :: ASSIGN_STT + +contains + + SUBROUTINE ASSIGN_STT() + ! --------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark, 2007 + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! Build an array of strings that list model states used for the current model + ! configuration + ! --------------------------------------------------------------------------------------- + ! Modules Modified: + ! ----------------- + ! Defines list and number of states in MODULE model_defn + ! --------------------------------------------------------------------------------------- + USE model_defn ! model definition + USE model_defnames + IMPLICIT NONE + ! --------------------------------------------------------------------------------------- + NSTATE=0 + !CSTATE(:)%SNAME(1:6) = 'NO_USE' + ! --------------------------------------------------------------------------------------- + ! (1) DEFINE STATE VARIABLES IN THE UPPER LAYER + ! --------------------------------------------------------------------------------------- + SELECT CASE(SMODL%iARCH1) + CASE(iopt_tension2_1) + CSTATE(NSTATE+1)%iSNAME = iopt_TENS1A + CSTATE(NSTATE+2)%iSNAME = iopt_TENS1B + CSTATE(NSTATE+3)%iSNAME = iopt_FREE_1 + NSTATE = NSTATE+3 + CASE(iopt_tension1_1) + CSTATE(NSTATE+1)%iSNAME = iopt_TENS_1 + CSTATE(NSTATE+2)%iSNAME = iopt_FREE_1 + NSTATE = NSTATE+2 + CASE(iopt_onestate_1) + CSTATE(NSTATE+1)%iSNAME = iopt_WATR_1 + NSTATE = NSTATE+1 + CASE DEFAULT + print *, "MDEFN(IMOD)%iARCH1 must be iopt_tension2_1, iopt_tension1_1, or iopt_onestate_1" + STOP + END SELECT + ! --------------------------------------------------------------------------------------- + ! (2) DEFINE STATE VARIABLES IN THE LOWER LAYER + ! --------------------------------------------------------------------------------------- + SELECT CASE(SMODL%iARCH2) + CASE(iopt_tens2pll_2) + CSTATE(NSTATE+1)%iSNAME = iopt_TENS_2 + CSTATE(NSTATE+2)%iSNAME = iopt_FREE2A + CSTATE(NSTATE+3)%iSNAME = iopt_FREE2B + NSTATE = NSTATE+3 + CASE(iopt_unlimfrc_2,iopt_unlimpow_2,iopt_topmdexp_2,iopt_fixedsiz_2) + CSTATE(NSTATE+1)%iSNAME = iopt_WATR_2 + NSTATE = NSTATE+1 + CASE DEFAULT + print *, "SMODL%iARCH2 must be iopt_tens2pll_2, iopt_unlimfrc_2, iopt_unlimpow_2" + print *, " iopt_topmdexp_2, or iopt_fixedsiz_2" + STOP + END SELECT + ! --------------------------------------------------------------------------------------- + END SUBROUTINE ASSIGN_STT + +end module ASSIGN_STT_module diff --git a/build/FUSE_SRC/prelim/bucketsize.f90 b/build/FUSE_SRC/prelim/bucketsize.f90 index cfcb526..0afbd0e 100644 --- a/build/FUSE_SRC/prelim/bucketsize.f90 +++ b/build/FUSE_SRC/prelim/bucketsize.f90 @@ -12,6 +12,7 @@ SUBROUTINE BUCKETSIZE() ! ----------------- ! MODULE multiparam -- bucket sizes stored in MODULE multiparam ! --------------------------------------------------------------------------------------- +USE nrtype USE multiparam ! model parameters IMPLICIT NONE ! --------------------------------------------------------------------------------------- diff --git a/build/FUSE_SRC/prelim/force_info.f90 b/build/FUSE_SRC/prelim/force_info.f90 deleted file mode 100644 index 02fcbcb..0000000 --- a/build/FUSE_SRC/prelim/force_info.f90 +++ /dev/null @@ -1,256 +0,0 @@ -module force_info_module -USE nrtype -USE netcdf -implicit none -private -public::force_info -contains - - SUBROUTINE force_info(fuse_mode,ierr,message) - ! --------------------------------------------------------------------------------------- - ! Creator: - ! -------- - ! Martyn Clark, 2012 - ! Modified by Nans Addor to add numtim_sub for distributed modeling, 2017 - ! --------------------------------------------------------------------------------------- - ! Purpose: - ! -------- - ! Read information describing the forcing data file - ! --------------------------------------------------------------------------------------- - ! Modules Modified: - ! ----------------- - ! MODULE multiforce -- populate variable names and time steps - ! --------------------------------------------------------------------------------------- - USE fuse_fileManager,only:SETNGS_PATH,FORCINGINFO,& ! defines data directory - INPUT_PATH - USE ascii_util_module,only:file_open ! open file (performs a few checks as well) - USE ascii_util_module,only:get_vlines ! get a list of character strings from non-comment lines - USE multiforce,only:vname_aprecip ! variable name: precipitation - USE multiforce,only:vname_airtemp ! variable name: temperature - USE multiforce,only:vname_spechum ! variable name: specific humidity - USE multiforce,only:vname_airpres ! variable name: surface pressure - USE multiforce,only:vname_swdown ! variable name: downward shortwave radiation - USE multiforce,only:vname_potevap ! variable name: potential ET - USE multiforce,only:vname_q ! variable name: runoff - USE multiforce,only:vname_iy,vname_im,vname_id ! names of time variables (day of year) - USE multiforce,only:vname_ih,vname_imin,vname_dsec ! names of time variables (time of day) - USE multiforce,only:vname_dtime ! name of time variable (time since reference time) - USE multiforce,only:deltim ! model timestep (days) - USE multiforce,only:istart,numtim_sim ! index for start of inference, and number steps in the reduced array - USE multiforce,only:amult_ppt,amult_pet,amult_q ! used to convert fluxes to mm/day - USE multiforce,only:numtim_sub ! number of time steps of subperiod (will be kept in memory) - - IMPLICIT NONE - ! input - CHARACTER(LEN=10) , intent(in) :: fuse_mode ! fuse execution mode (run_def, run_best, calib_sce) - ! output - integer(i4b), intent(out) :: ierr ! error code - character(*), intent(out) :: message ! error message - ! internal: general - integer(i4b),parameter :: strLen=1024 ! length of character strings - character(len=strLen) :: cmessage ! message of downwind routine - character(len=strLen),parameter :: cVersion='FORCINGINFO.VERSION.2.2' ! version of forcinginfo file - ! internal: read data from file - integer(i4b) :: iunit ! file unit - character(len=strLen) :: cfile ! name of control file - character(len=strLen),allocatable :: charlines(:) ! vector of character strings - ! internal: assign data - integer(i4b) :: iLine ! index of line in charlines - integer(i4b) :: ibeg_name ! start index of variable name in string charlines(iLine) - integer(i4b) :: iend_name ! end index of variable name in string charlines(iLine) - integer(i4b) :: iend_data ! end index of data in string charlines(iLine) - character(len=strLen) :: cName,cData ! name and data from charlines(iLine) - ! internal: named variables - integer(i4b),parameter :: maxinfo=22 ! maximum number of informational elements - logical(lgt),dimension(maxinfo) :: lCheck ! vector to check that we have the infomation we need - integer(i4b),parameter :: iVname_iy =1 ! named variable for element of lCheck - integer(i4b),parameter :: iVname_im =2 ! named variable for element of lCheck - integer(i4b),parameter :: iVname_id =3 ! named variable for element of lCheck - integer(i4b),parameter :: iVname_ih =4 ! named variable for element of lCheck - integer(i4b),parameter :: iVname_imin =5 ! named variable for element of lCheck - integer(i4b),parameter :: iVname_dsec =6 ! named variable for element of lCheck - integer(i4b),parameter :: iVname_dtime =7 ! named variable for element of lCheck - integer(i4b),parameter :: iVname_aprecip =8 ! named variable for element of lCheck - integer(i4b),parameter :: iVname_airtemp =9 ! named variable for element of lCheck - integer(i4b),parameter :: iVname_spechum =10 ! named variable for element of lCheck - integer(i4b),parameter :: iVname_airpres =11 ! named variable for element of lCheck - integer(i4b),parameter :: iVname_swdown =12 ! named variable for element of lCheck - integer(i4b),parameter :: iVname_potevap =13 ! named variable for element of lCheck - integer(i4b),parameter :: iVname_q =14 ! named variable for element of lCheck - integer(i4b),parameter :: iUnits_aprecip =15 ! named variable for element of lCheck - integer(i4b),parameter :: iUnits_airtemp =16 ! named variable for element of lCheck - integer(i4b),parameter :: iUnits_spechum =17 ! named variable for element of lCheck - integer(i4b),parameter :: iUnits_airpres =18 ! named variable for element of lCheck - integer(i4b),parameter :: iUnits_swdown =19 ! named variable for element of lCheck - integer(i4b),parameter :: iUnits_potevap =20 ! named variable for element of lCheck - integer(i4b),parameter :: iUnits_q =21 ! named variable for element of lCheck - integer(i4b),parameter :: iDeltim =22 ! named variable for element of lCheck - ! get units strings (used to define variable multipliers) - character(len=strLen) :: units_aprecip='undefined' ! unit string for precipitation - character(len=strLen) :: units_airtemp='undefined' ! unit string for air temperature - character(len=strLen) :: units_spechum='undefined' ! unit string for specific humidity - character(len=strLen) :: units_airpres='undefined' ! unit string for air pressure - character(len=strLen) :: units_swdown ='undefined' ! unit string for downward sw radiation - character(len=strLen) :: units_potevap='undefined' ! unit string for potential ET - character(len=strLen) :: units_q ='undefined' ! unit string for runoff - integer(i4b) :: iVar ! loop through variables - ! --------------------------------------------------------------------------------------- - ! initialize error control - ierr=0; message='force_info/' - ! --------------------------------------------------------------------------------------- - ! build filename - cfile = trim(SETNGS_PATH)//trim(FORCINGINFO) ! uses paths and filenames from MODULE fuse_fileManager - - print *, 'Reading forcing info from:' - print *, trim(cfile) - ! open file (also returns un-used file unit used to open the file) - call file_open(trim(cfile),iunit,ierr,cmessage) - if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif - ! get a list of character strings from non-comment lines - call get_vlines(iunit,charlines,ierr,cmessage) - if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif - ! close the file unit - close(iunit) - ! --------------------------------------------------------------------------------------- - ! initialize the check vector - lCheck(:)=.false. - ! loop through the non-comment lines in the input file - do iLine=1,size(charlines) - ! identify start and end of the name and the data - ibeg_name = index(charlines(iLine),'<'); if(ibeg_name==0) ierr=20 - iend_name = index(charlines(iLine),'>'); if(iend_name==0) ierr=20 - iend_data = index(charlines(iLine),'!'); if(iend_data==0) ierr=20 - if(ierr/=0)then; message=trim(message)//'problem disentangling charlines(iLine) [string='//trim(charlines(iLine))//']'; return; endif - ! extract name of the information, and the information itself - cName = adjustl(charlines(iLine)(ibeg_name:iend_name)) - cData = adjustl(charlines(iLine)(iend_name+1:iend_data-1)) - ! put the information in its correct place - select case(trim(cName)) - ! check version - case('') - if(trim(cData)/=cVersion)then - message=trim(message)//'version mis-match [version='//trim(cData)//'; expect "'//cVersion//'"]' - ierr=20; return - endif - ! put character strings in their correct place - case(''); vname_iy = trim(cData); lCheck(iVname_iy) = .true. - case(''); vname_im = trim(cData); lCheck(iVname_im) = .true. - case(''); vname_id = trim(cData); lCheck(iVname_id) = .true. - case(''); vname_ih = trim(cData); lCheck(iVname_ih) = .true. - case(''); vname_imin = trim(cData); lCheck(iVname_imin) = .true. - case(''); vname_dsec = trim(cData); lCheck(iVname_dsec) = .true. - case(''); vname_dtime = trim(cData); lCheck(iVname_dtime) = .true. - case(''); vname_aprecip = trim(cData); lCheck(iVname_aprecip) = .true. - case(''); vname_airtemp = trim(cData); lCheck(iVname_airtemp) = .true. - case(''); vname_spechum = trim(cData); lCheck(iVname_spechum) = .true. - case(''); vname_airpres = trim(cData); lCheck(iVname_airpres) = .true. - case(''); vname_swdown = trim(cData); lCheck(iVname_swdown) = .true. - case(''); vname_potevap = trim(cData); lCheck(iVname_potevap) = .true. - case(''); vname_q = trim(cData); lCheck(iVname_q) = .true. - case(''); units_aprecip = trim(cData); lCheck(iUnits_aprecip) = .true. - case(''); units_airtemp = trim(cData); lCheck(iUnits_airtemp) = .true. - case(''); units_spechum = trim(cData); lCheck(iUnits_spechum) = .true. - case(''); units_airpres = trim(cData); lCheck(iUnits_airpres) = .true. - case(''); units_swdown = trim(cData); lCheck(iUnits_swdown) = .true. - case(''); units_potevap = trim(cData); lCheck(iUnits_potevap) = .true. - case(''); units_q = trim(cData); lCheck(iUnits_q) = .true. - ! put real numbers and integers in their correct place - case(''); read(cData,*,iostat=ierr) deltim; lCheck(iDeltim) = .true. - ! check for an unexpected string - case default - ierr=20; message=trim(message)//'do not have a case for string ['//trim(cName)//']'; return - endselect - ! check if there were any errors in the internal read statements - if(ierr/=0)then - message=trim(message)//'problem reading data for variable '//trim(cName)//'[data='//trim(cData)//']' - ierr=50; return - endif - end do ! (looping through non-comment lines in the file - - ! deallocate space for the variable line vector - deallocate(charlines, stat=ierr) - if(ierr/=0)then; message=trim(message)//'problem deallocating space for the variable line vector'; return; endif - ! check that we got all desired variables - if(any(lCheck .eqv. .false.))then - ierr=20; message=trim(message)//'missing variable' - write(*,'(a,1x,a,1x,L1)') '', trim(vname_iy), lCheck(iVname_iy) - write(*,'(a,1x,a,1x,L1)') '', trim(vname_im), lCheck(iVname_im) - write(*,'(a,1x,a,1x,L1)') '', trim(vname_id), lCheck(iVname_id) - write(*,'(a,1x,a,1x,L1)') '', trim(vname_ih), lCheck(iVname_ih) - write(*,'(a,1x,a,1x,L1)') '', trim(vname_imin), lCheck(iVname_im) - write(*,'(a,1x,a,1x,L1)') '', trim(vname_dsec), lCheck(iVname_dsec) - write(*,'(a,1x,a,1x,L1)') '', trim(vname_dtime), lCheck(iVname_dtime) - write(*,'(a,1x,a,1x,L1)') '', trim(vname_aprecip), lCheck(iVname_aprecip) - write(*,'(a,1x,a,1x,L1)') '', trim(vname_airtemp), lCheck(iVname_airtemp) - write(*,'(a,1x,a,1x,L1)') '', trim(vname_spechum), lCheck(iVname_spechum) - write(*,'(a,1x,a,1x,L1)') '', trim(vname_airpres), lCheck(iVname_airpres) - write(*,'(a,1x,a,1x,L1)') '', trim(vname_swdown), lCheck(iVname_swdown) - write(*,'(a,1x,a,1x,L1)') '', trim(vname_potevap), lCheck(iVname_potevap) - write(*,'(a,1x,a,1x,L1)') '', trim(vname_q), lCheck(iVname_q) - write(*,'(a,1x,a,1x,L1)') '', trim(units_aprecip), lCheck(iUnits_aprecip) - write(*,'(a,1x,a,1x,L1)') '', trim(units_airtemp), lCheck(iUnits_airtemp) - write(*,'(a,1x,a,1x,L1)') '', trim(units_spechum), lCheck(iUnits_spechum) - write(*,'(a,1x,a,1x,L1)') '', trim(units_airpres), lCheck(iUnits_airpres) - write(*,'(a,1x,a,1x,L1)') '', trim(units_swdown), lCheck(iUnits_swdown) - write(*,'(a,1x,a,1x,L1)') '', trim(units_potevap), lCheck(iUnits_potevap) - write(*,'(a,1x,a,1x,L1)') '', trim(units_q), lCheck(iUnits_q) - write(*,'(a,1x,f9.6,1x,L1)') '', deltim, lCheck(iDeltim) - print*, lCheck, size(lcheck) - return - endif ! if we missed a variable - - ! get multipliers for each variable - do ivar=1,3 - if(ivar==1) call get_multiplier(units_aprecip, amult_ppt, ierr, cmessage) - if(ivar==2) call get_multiplier(units_potevap, amult_pet, ierr, cmessage) - if(ivar==3) call get_multiplier(units_q, amult_q, ierr, cmessage) - if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif - end do - - PRINT *, 'Done reading forcing info' - - end subroutine force_info - - ! ***** new subroutine: get multiplier for given flux variable (L/T) - subroutine get_multiplier(cunits, amult, ierr, message) - implicit none - ! define input - character(*),intent(in) :: cunits ! units - ! define output - real(sp),intent(out) :: amult ! multiplier - integer(i4b), intent(out) :: ierr ! error code - character(*), intent(out) :: message ! error message - ! define internal variables - integer(i4b),parameter :: strLen=32 ! length of sub-strings - integer(i4b) :: ipos ! position of the "/" character - character(strLen) :: cLength ! length unit - character(strLen) :: cTime ! time unit - real(sp),parameter :: secprday=86400._sp ! number of seconds per day - real(sp),parameter :: hrprday=24._sp ! number of hours per day - ! initialize error control - ierr=0; message='get_multiplier/' - ! if units are undefined, assume mm/day and have an early return - if(trim(cunits)=='undefined')then; amult=1._sp; return; endif - ! find the position of the "/" character - ipos = index(trim(cunits),'/') - ! check the "/" character exists - if(ipos==0)then - message=trim(message)//'expect the character "/" in the units string [units='//trim(cunits)//']' - ierr=20; return - endif - ! get the length units - cLength=cunits(1:ipos-1) - if(cLength/='mm')then; ierr=20; message=trim(message)//'expect the length units to be "mm" [units='//trim(cLength)//']'; return; endif - ! get the time units - cTime=cunits(ipos+1:len_trim(cunits)) - ! get the multiplier - select case(trim(cTime)) - case('d','day'); amult=1._sp - case('h','hour'); amult=hrprday - case('s','second'); amult=secprday - case default - ierr=20; message=trim(message)//'cannot identify the time units [time units = '//trim(cTime)//']'; return - end select - end subroutine get_multiplier - -end module force_info_module diff --git a/build/FUSE_SRC/prelim/getnumerix.f90 b/build/FUSE_SRC/prelim/getnumerix.f90 index 9a4d3c5..72c4589 100644 --- a/build/FUSE_SRC/prelim/getnumerix.f90 +++ b/build/FUSE_SRC/prelim/getnumerix.f90 @@ -1,4 +1,4 @@ -SUBROUTINE GETNUMERIX(err,message) +SUBROUTINE GETNUMERIX(err, message) ! --------------------------------------------------------------------------------------- ! Creator: ! -------- diff --git a/build/FUSE_SRC/prelim/getparmeta.f90 b/build/FUSE_SRC/prelim/getparmeta.f90 index 8c6313d..b1e388d 100644 --- a/build/FUSE_SRC/prelim/getparmeta.f90 +++ b/build/FUSE_SRC/prelim/getparmeta.f90 @@ -1,81 +1,92 @@ -SUBROUTINE GETPARMETA(err,message) -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2009 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Reads parameter metadata -! --------------------------------------------------------------------------------------- -! Modules Modified: -! ----------------- -! MODULE multiparam -- model parameters stored in MODULE multiparam -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -USE fuse_fileManager,only:SETNGS_PATH,CONSTRAINTS ! defines data directory -USE multiparam, ONLY: PARATT ! parameter attribute structure -USE putpar_str_module ! provide access to SUBROUTINE putpar_str -USE par_insert_module ! provide access to SUBROUTINE par_insert -IMPLICIT NONE -! dummies -integer(i4b),intent(out)::err -character(*),intent(out)::message -! locals -INTEGER(I4B) :: IUNIT ! file unit -INTEGER(I4B) :: IERR ! error code for read statement -CHARACTER(LEN=1024) :: CFILE ! name of constraints file -LOGICAL(LGT) :: LEXIST ! .TRUE. if file exists -CHARACTER(LEN=256) :: KEY ! format code -TYPE(PARATT) :: PARAM_META ! parameter metadata -INTEGER(I4B) :: IPOS,JPOS ! indices of string -INTEGER(I4B) :: ICH ! looping variable (do loop) -! --------------------------------------------------------------------------------------- -! read in control file -err=0 -IUNIT = 21 ! file unit -CFILE = TRIM(SETNGS_PATH) // TRIM(CONSTRAINTS) ! control file info shared in MODULE ddirectory -INQUIRE(FILE=CFILE,EXIST=LEXIST) ! check that control file exists -print *,'Parameter constraints file:', TRIM(CFILE) -IF (.not.LEXIST) THEN - message="f-GETPARMETA/parameter constraints file '"//trim(CFILE)//"' does not exist " - err=100; return -ENDIF -! initialize parameter strings -DO ICH=1,LEN(PARAM_META%P_NAME); PARAM_META%P_NAME(ICH:ICH)=' '; END DO -DO ICH=1,LEN(PARAM_META%CHILD1); PARAM_META%CHILD1(ICH:ICH)=' '; END DO -DO ICH=1,LEN(PARAM_META%CHILD2); PARAM_META%CHILD2(ICH:ICH)=' '; END DO -! open up parameter metadata file -OPEN(IUNIT,FILE=CFILE,STATUS='old') -! read format key (and strip out descriptive text) -READ(IUNIT,'(a256)') KEY -IPOS = INDEX(KEY,'!'); DO JPOS=IPOS,LEN(KEY); KEY(JPOS:JPOS)=' '; END DO -!PRINT *, TRIM(KEY), len_trim(key) -DO - ! read parameter constraints - READ(IUNIT,TRIM(KEY), IOSTAT=IERR) & - PARAM_META%PARFIT, & ! 'fit' (T/F) [T=parameter is fitted, F=parameter is fixed at the default value) - PARAM_META%PARSTK, & ! flag (0=deterministic, 1=stochastic) - PARAM_META%PARDEF, & ! default parameter set - PARAM_META%PARLOW, & ! lower limit of each parameter - PARAM_META%PARUPP, & ! upper limit of each parameter - PARAM_META%FRSEED, & ! fraction param space used as offset for "reasonable" bounds - PARAM_META%PARSCL, & ! typical scale of parameter - PARAM_META%PARVTN, & ! method used for variable transformation - PARAM_META%PARDIS, & ! parametric form of prob dist used for prior/hyper - PARAM_META%PARQTN, & ! transformation applied before use of prob dist - PARAM_META%PARLAT, & ! number of latent variables (0=onePerStep, -1=from data) - PARAM_META%PARMTH, & ! imeth for all variables ???what is this??? - PARAM_META%NPRIOR, & ! number of prior/hyper-parameters - PARAM_META%P_NAME, & ! parameter name - PARAM_META%CHILD1, & ! name of 1st parameter child - PARAM_META%CHILD2 ! name of 2nd parameter child - IF (IERR.NE.0) EXIT - !WRITE(*,TRIM(KEY)) PARAM_META - ! put parameters in data structures - CALL PUTPAR_STR(PARAM_META, PARAM_META%P_NAME) - ! populate the model parameter structure with default values - CALL PAR_INSERT(PARAM_META%PARDEF,PARAM_META%P_NAME) -END DO -CLOSE(IUNIT) -END SUBROUTINE GETPARMETA +module GETPARMETA_module + + implicit none + + private + public :: GETPARMETA + +contains + + SUBROUTINE GETPARMETA(err,message) + ! --------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark, 2009 + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! Reads parameter metadata from the parameter constraints file + ! --------------------------------------------------------------------------------------- + ! Modules Modified: + ! ----------------- + ! MODULE multiparam -- model parameters stored in MODULE multiparam + ! --------------------------------------------------------------------------------------- + USE nrtype ! variable types, etc. + USE fuse_fileManager,only:SETNGS_PATH,CONSTRAINTS ! defines data directory + USE multiparam_types, only: PARATT ! parameter attribute structure + USE putpar_str_module ! provide access to SUBROUTINE putpar_str + USE par_insert_module ! provide access to SUBROUTINE par_insert + IMPLICIT NONE + ! dummies + integer(i4b),intent(out)::err + character(*),intent(out)::message + ! locals + INTEGER(I4B) :: IUNIT ! file unit + INTEGER(I4B) :: IERR ! error code for read statement + CHARACTER(LEN=1024) :: CFILE ! name of constraints file + LOGICAL(LGT) :: LEXIST ! .TRUE. if file exists + CHARACTER(LEN=256) :: KEY ! format code + TYPE(PARATT) :: PARAM_META ! parameter metadata + INTEGER(I4B) :: IPOS,JPOS ! indices of string + INTEGER(I4B) :: ICH ! looping variable (do loop) + ! --------------------------------------------------------------------------------------- + ! read in control file + err=0 + IUNIT = 21 ! file unit + CFILE = TRIM(SETNGS_PATH) // TRIM(CONSTRAINTS) ! control file info shared in MODULE ddirectory + INQUIRE(FILE=CFILE,EXIST=LEXIST) ! check that control file exists + print *,'Parameter constraints file:', TRIM(CFILE) + IF (.not.LEXIST) THEN + message="f-GETPARMETA/parameter constraints file '"//trim(CFILE)//"' does not exist " + err=100; return + ENDIF + ! initialize parameter strings + DO ICH=1,LEN(PARAM_META%P_NAME); PARAM_META%P_NAME(ICH:ICH)=' '; END DO + DO ICH=1,LEN(PARAM_META%CHILD1); PARAM_META%CHILD1(ICH:ICH)=' '; END DO + DO ICH=1,LEN(PARAM_META%CHILD2); PARAM_META%CHILD2(ICH:ICH)=' '; END DO + ! open up parameter metadata file + OPEN(IUNIT,FILE=CFILE,STATUS='old') + ! read format key (and strip out descriptive text) + READ(IUNIT,'(a256)') KEY + IPOS = INDEX(KEY,'!'); DO JPOS=IPOS,LEN(KEY); KEY(JPOS:JPOS)=' '; END DO + !PRINT *, TRIM(KEY), len_trim(key) + DO + ! read parameter constraints + READ(IUNIT,TRIM(KEY), IOSTAT=IERR) & + PARAM_META%PARFIT, & ! 'fit' (T/F) [T=parameter is fitted, F=parameter is fixed at the default value) + PARAM_META%PARSTK, & ! flag (0=deterministic, 1=stochastic) + PARAM_META%PARDEF, & ! default parameter set + PARAM_META%PARLOW, & ! lower limit of each parameter + PARAM_META%PARUPP, & ! upper limit of each parameter + PARAM_META%FRSEED, & ! fraction param space used as offset for "reasonable" bounds + PARAM_META%PARSCL, & ! typical scale of parameter + PARAM_META%PARVTN, & ! method used for variable transformation + PARAM_META%PARDIS, & ! parametric form of prob dist used for prior/hyper + PARAM_META%PARQTN, & ! transformation applied before use of prob dist + PARAM_META%PARLAT, & ! number of latent variables (0=onePerStep, -1=from data) + PARAM_META%PARMTH, & ! imeth for all variables ???what is this??? + PARAM_META%NPRIOR, & ! number of prior/hyper-parameters + PARAM_META%P_NAME, & ! parameter name + PARAM_META%CHILD1, & ! name of 1st parameter child + PARAM_META%CHILD2 ! name of 2nd parameter child + IF (IERR.NE.0) EXIT + !WRITE(*,TRIM(KEY)) PARAM_META + ! put parameters in data structures + CALL PUTPAR_STR(PARAM_META, PARAM_META%P_NAME) + ! populate the model parameter structure with default values + CALL PAR_INSERT(PARAM_META%PARDEF,PARAM_META%P_NAME) + END DO + CLOSE(IUNIT) + END SUBROUTINE GETPARMETA + +end module GETPARMETA_module diff --git a/build/FUSE_SRC/prelim/init_state.f90 b/build/FUSE_SRC/prelim/init_state.f90 index ea88d82..1358d3c 100644 --- a/build/FUSE_SRC/prelim/init_state.f90 +++ b/build/FUSE_SRC/prelim/init_state.f90 @@ -13,6 +13,7 @@ SUBROUTINE INIT_STATE(FRAC) ! ----------------- ! Model states in MODULE multistate ! --------------------------------------------------------------------------------------- +USE nrtype USE multiparam ! model parameters USE multistate ! model states USE multibands ! model snow bands @@ -35,7 +36,7 @@ SUBROUTINE INIT_STATE(FRAC) FSTATE%WATR_2 = MPARAM%MAXWATR_2 * FRAC ! snow model, assume no snow at start DO ISNW=1,N_BANDS - MBANDS(ISNW)%SWE = 0.0_sp + MBANDS(ISNW)%VAR%SWE = 0.0_sp END DO ! (routed runoff) FUTURE = 0._sp diff --git a/build/FUSE_SRC/prelim/par_derive.f90 b/build/FUSE_SRC/prelim/par_derive.f90 index 8a1b699..e36e869 100644 --- a/build/FUSE_SRC/prelim/par_derive.f90 +++ b/build/FUSE_SRC/prelim/par_derive.f90 @@ -1,35 +1,44 @@ -SUBROUTINE PAR_DERIVE(err,message) -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2007 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Computes derived model parameters (bucket sizes, etc.) -! --------------------------------------------------------------------------------------- -! Modules Modified: -! ----------------- -! MODULE multiparam -- model parameters stored in MODULE multiparam -! --------------------------------------------------------------------------------------- -USE nrtype ! define data types -USE model_defn, ONLY: SMODL ! model definition structures -USE model_defnames -USE multiparam, ONLY: MPARAM,DPARAM ! model parameter structures -IMPLICIT NONE -! dummies -integer(i4b),intent(out)::err -character(*),intent(out)::message -! --------------------------------------------------------------------------------------- -err=0 -CALL BUCKETSIZE() ! compute bucket size -CALL MEAN_TIPOW() ! mean of the power-transformed topo index -CALL QBSATURATN() ! compute baseflow at saturation (used in the SAC percolation model) -CALL QTIMEDELAY(err,message) ! compute fraction of runoff in future time steps -if(err/=0)then - err=10; message="f-PAR_DERIVE/&"//trim(message); return -endif -! --------------------------------------------------------------------------------------- -IF (SMODL%iESOIL.EQ.iopt_rootweight) DPARAM%RTFRAC2 = 1._SP - MPARAM%RTFRAC1 -! --------------------------------------------------------------------------------------- -END SUBROUTINE PAR_DERIVE +module PAR_DERIVE_module + implicit none + private + public :: PAR_DERIVE + +contains + + SUBROUTINE PAR_DERIVE(err,message) + ! --------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark, 2007 + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! Computes derived model parameters (bucket sizes, etc.) + ! --------------------------------------------------------------------------------------- + ! Modules Modified: + ! ----------------- + ! MODULE multiparam -- model parameters stored in MODULE multiparam + ! --------------------------------------------------------------------------------------- + USE nrtype ! define data types + USE model_defn, ONLY: SMODL ! model definition structures + USE model_defnames + USE multiparam, ONLY: MPARAM,DPARAM ! model parameter structures + IMPLICIT NONE + ! dummies + integer(i4b),intent(out)::err + character(*),intent(out)::message + ! --------------------------------------------------------------------------------------- + err=0 + CALL BUCKETSIZE() ! compute bucket size + CALL MEAN_TIPOW() ! mean of the power-transformed topo index + CALL QBSATURATN() ! compute baseflow at saturation (used in the SAC percolation model) + CALL QTIMEDELAY(err,message) ! compute fraction of runoff in future time steps + if(err/=0)then + err=10; message="f-PAR_DERIVE/&"//trim(message); return + endif + ! --------------------------------------------------------------------------------------- + IF (SMODL%iESOIL.EQ.iopt_rootweight) DPARAM%RTFRAC2 = 1._SP - MPARAM%RTFRAC1 + ! --------------------------------------------------------------------------------------- + END SUBROUTINE PAR_DERIVE + +end module PAR_DERIVE_module diff --git a/build/FUSE_SRC/prelim/parse_command_args.f90 b/build/FUSE_SRC/prelim/parse_command_args.f90 new file mode 100644 index 0000000..be3a450 --- /dev/null +++ b/build/FUSE_SRC/prelim/parse_command_args.f90 @@ -0,0 +1,416 @@ +module parse_command_args_MODULE + + USE nrtype + USE info_types, only: cli_options + + implicit none + + private + public :: parse_command_args + +contains + + subroutine parse_command_args(opts, err, message) + implicit none + ! dummies + type(cli_options) , intent(out) :: opts ! command line interface options + integer(i4b) , intent(out) :: err ! error code + character(len=1024) , intent(out) :: message ! error message + ! internal + integer(i4b) :: i ! index of command line argument + character(len=:) , allocatable :: a, v ! command line arguments + character(len=:) , allocatable :: cIndex ! character index + character(len=:) , allocatable :: kv, pname, pval_str ! parameter strings + real(sp) :: pval ! parameter value + integer(i4b) :: nArg ! number of command line arguments + character(len=:) , allocatable :: cmessage + ! initialize error control + err=0; message='parse_command_args/' + + ! ----- parse command line arguments ------------------------------------------------------ + + ! ----------------------------------------------------------------------------------------- + ! CLI parsing for FUSE run modes + ! -c/--control (required unless --version) + ! -m/--runmode (required unless --version) + ! -d/--domid (required unless --version) + ! -s/--sets (required for idx,opt) + ! -i/--index (required for idx) + ! -r/--restart (optional) + ! -t/--tag (optional) + ! -p/--param (optional) + ! -v/--version (prints version info and exits) + ! -h/--help (prints help and exits) + ! ----------------------------------------------------------------------------------------- + + nArg = command_argument_count() + if (nArg < 1) call printCommandHelp() + + i = 1 + do while (i <= narg) + call get_arg(i,a) + + select case (trim(a)) + + case ('-h','--help') + opts%show_help = .true. + i = i + 1 + + case ('-v','--version') + opts%show_version = .true. + i = i + 1 + + case ('-t','--tag') + call require_next(i, narg, a, v, err, cmessage) + opts%tag = trim(v) + i = i + 2 + + case ('-c','--control') + call require_next(i, narg, a, v, err, cmessage) + opts%control_file = trim(v) + i = i + 2 + + case ('-m','--runmode') + call require_next(i, narg, a, v, err, cmessage) + opts%runmode = to_lower(trim(v)) + i = i + 2 + + case ('-d','--domid') + call require_next(i, narg, a, v, err, cmessage) + opts%domain_id = trim(v) + i = i + 2 + + case ('-p', '--param') + call require_next(i, narg, a, kv, err, cmessage) + i = i + 2 + + case ('-s','--sets','--param-sets') + call require_next(i, narg, a, v, err, cmessage) + opts%sets_file = trim(v) + i = i + 2 + + case ('-i','--index') + call require_next(i, narg, a, cIndex, err, cmessage) + i = i + 2 + + case ('-r','--restart') + call require_next(i, narg, a, v, err, cmessage) + opts%restart_freq = to_lower(trim(v)) + i = i + 2 + + case default + if (len_trim(a) > 0 .and. a(1:1) == '-') then + err = 1 + cmessage = "unknown option: "//trim(a)//"; type 'fuse.exe --help' for usage" + else + err = 1 + cmessage = "unexpected positional argument: "//trim(a)//"; type 'fuse.exe --help' for usage" + end if + end select + + ! process error code + if(err/=0)then + message=trim(message)//trim(cmessage) + err=20; return + endif + + ! process parameters -- needs to be in the do loop since multiple parameters + if(allocated(kv))then + + ! split name/value based on the equal sign + call split_param_kv(trim(kv), pname, pval_str, err, cmessage) + if(err /= 0)then; message=trim(message)//trim(cmessage); err=20; return; endif + + ! convert characters to real values + call parse_real_sp(pval_str, pval, err, cmessage) + if (err /= 0) then + message=trim(message)//"invalid --param value for "//trim(pname)//": "//trim(cmessage) + err=20; return + end if + + ! add to structure in opts + call push_param(opts%param_name, opts%param_value, pname, pval) + print*, opts%param_name + print*, opts%param_value + + endif ! if processing parameters + + end do ! looping through arguments + + ! Early exits + if (opts%show_help) then + call printCommandHelp() + stop 0 + end if + if (opts%show_version) then + call printVersionInfo() + stop 0 + end if + + ! Parse parameter index + if(allocated(cIndex))then + call parse_int(cIndex, opts%indx, err, cmessage) + if(err/=0)then + message=trim(message)//trim(cmessage) + err=20; return + endif + endif + + ! Validate required args + if (.not. allocated(opts%control_file)) then + err = 1; message = trim(message)//"missing required --control; type 'fuse.exe --help' for usage"; return + end if + if (.not. allocated(opts%domain_id)) then + err = 1; message = trim(message)//"missing required --domid; type 'fuse.exe --help' for usage"; return + end if + if (.not. allocated(opts%runmode)) then + err = 1; message = trim(message)//"missing required --runmode; type 'fuse.exe --help' for usage"; return + end if + + if (.not. is_valid_mode(opts%runmode)) then + err = 1; message = trim(message)//"invalid --runmode: "//trim(opts%runmode)//" (expect def|idx|opt|sce)"; return + end if + + ! Mode-dependent requirements + select case (trim(opts%runmode)) + case ('idx') + if (.not. allocated(opts%sets_file)) then + err = 1; message = trim(message)//"runmode idx requires --sets "; return + end if + if (opts%indx < 0) then + err = 1; message = trim(message)//"runmode idx requires --index "; return + end if + case ('opt') + if (.not. allocated(opts%sets_file)) then + err = 1; message = trim(message)//"runmode opt requires --sets "; return + end if + case ('def','sce') + ! no extra requirements + end select + + ! Validate frequencies if provided (optional) + if (allocated(opts%restart_freq)) then + if (.not. is_valid_restart(opts%restart_freq)) then + err = 1; message = trim(message)//"invalid --restart: "//trim(opts%restart_freq)//" (expect y|m|d|e|never)"; return + end if + end if + + end subroutine parse_command_args + + ! ----- list version ---------------------------------------------------------------------- + + subroutine printVersionInfo() + ! Assumes these are available, e.g. from: + ! include "fuseversion.inc" + ! somewhere in a used module (e.g., globaldata) OR add that include here. + use globaldata, only: FUSE_VERSION, FUSE_BUILDTIME, FUSE_GITBRANCH, FUSE_GITHASH + implicit none + print '(A)', repeat('-', 70) + print '(A)', 'FUSE' + print '(" ",A12," : ",A)', 'Version', trim(FUSE_VERSION) + print '(" ",A12," : ",A)', 'Build time', trim(FUSE_BUILDTIME) + print '(" ",A12," : ",A)', 'Git branch', trim(FUSE_GITBRANCH) + print '(" ",A12," : ",A)', 'Git hash', trim(FUSE_GITHASH) + print '(A)', repeat('-', 70) + end subroutine printVersionInfo + + ! ----- list command usage ---------------------------------------------------------------- + + subroutine printCommandHelp() + implicit none + print "(A)", "" + print "(A)", "Usage:" + print "(A)", " fuse.exe -d domain_id -c control_file -m {def|idx|opt|sce} [options]" + print "(A)", "" + + print "(A)", "Run modes:" + print "(A)", " def : run with default parameter sets" + print "(A)", " idx : run using a given index from a parameter sets file" + print "(A)", " opt : run using best simulation from a parameter sets file" + print "(A)", " sce : optimize (SCE)" + print "(A)", "" + + print "(A)", "Required:" + print "(A)", " -d, --domid Domain ID" + print "(A)", " -c, --control Control file" + print "(A)", " -m, --runmode def|idx|opt|sce" + print "(A)", "" + + print "(A)", "Conditional:" + print "(A)", " -s, --sets Parameter sets file (required for idx,opt)" + print "(A)", " -i, --index Index (required for idx)" + print "(A)", "" + + print "(A)", "Optional:" + print "(A)", " -r, --restart y|m|d|e|never" + print "(A)", " -t, --tag Add tag to output filename" + print "(A)", " -v, --version Print version info and exit" + print "(A)", " -h, --help Print this help and exit" + print "(A)", "" + + print "(A)", "Examples:" + print "(A)", " Default run (no parameter-set file):" + print "(A)", " fuse.exe -d camels-12345 -c ./control/FUSE_control.txt -m def" + print "(A)", "" + + print "(A)", " Default run and write restart file every day:" + print "(A)", " fuse.exe -d camels-12345 -c ./control/FUSE_control.txt -m def -r d" + print "(A)", "" + + print "(A)", " Run using parameter set index 17 from a sets file:" + print "(A)", " fuse.exe -d camels-12345 -c ./control/FUSE_control.txt -m idx -s ./params/sets.nc -i 17" + print "(A)", "" + + print "(A)", " Run using the best simulation from a sets file:" + print "(A)", " fuse.exe -d camels-12345 -c ./control/FUSE_control.txt -m opt -s ./params/sets.nc" + print "(A)", "" + + print "(A)", " Optimize using SCE:" + print "(A)", " fuse.exe -d camels-12345 -c ./control/FUSE_control.txt -m sce" + print "(A)", "" + + print "(A)", " Print version information:" + print "(A)", " fuse.exe --version" + print "(A)", "" + end subroutine printCommandHelp + + ! ----------------------------------------------------------------------------------------- + ! Helpers + ! ----------------------------------------------------------------------------------------- + + subroutine get_arg(i, out) + integer, intent(in) :: i + character(len=:), allocatable, intent(out) :: out + integer :: L + call get_command_argument(i, length=L) + allocate(character(len=L) :: out) + call get_command_argument(i, out) + end subroutine get_arg + + subroutine require_next(i, narg, opt, val, err, message) + integer, intent(in) :: i, narg + character(len=*), intent(in) :: opt + character(len=:), allocatable, intent(out) :: val + integer, intent(out) :: err + character(len=:), allocatable, intent(out) :: message + err = 0 + message = "" + if (i+1 > narg) then + err = 1 + message = "missing value after "//trim(opt)//"; type 'fuse.exe --help' for usage" + return + end if + call get_arg(i+1, val) + end subroutine require_next + + subroutine split_param_kv(kv, name, val, err, message) + character(len=*), intent(in) :: kv + character(len=:), allocatable, intent(out) :: name, val + integer(i4b), intent(out) :: err + character(len=:), allocatable, intent(out) :: message + integer(i4b) :: p + + err = 0; message = "" + p = index(kv, '=') + if (p <= 1 .or. p >= len_trim(kv)) then + err = 1 + message = "expected NAME=VALUE after --param, got: "//trim(kv) + return + end if + + name = adjustl(kv(1:p-1)) + val = adjustl(kv(p+1:)) + + if (len_trim(name) == 0 .or. len_trim(val) == 0) then + err = 1 + message = "expected NAME=VALUE after --param, got: "//trim(kv) + return + end if + end subroutine split_param_kv + + subroutine parse_real_sp(s, x, err, message) + character(len=*), intent(in) :: s + real(sp), intent(out) :: x + integer, intent(out) :: err + character(len=:), allocatable, intent(out) :: message + integer(i4b) :: ios + err = 0; message = "" + read(s, *, iostat=ios) x + if (ios /= 0) then + err = 1 + message = "invalid real: "//trim(s) + end if + end subroutine parse_real_sp + + subroutine parse_int(s, x, err, message) + character(len=*), intent(in) :: s + integer, intent(out) :: x + integer, intent(out) :: err + character(len=:), allocatable, intent(out) :: message + integer :: ios + err = 0 + message = "" + read(s, *, iostat=ios) x + if (ios /= 0) then + err = 1 + message = "invalid integer: "//trim(s) + end if + end subroutine parse_int + + pure function to_lower(s) result(t) + character(len=*), intent(in) :: s + character(len=len(s)) :: t + integer :: k, c + t = s + do k = 1, len(s) + c = iachar(t(k:k)) + if (c >= iachar('A') .and. c <= iachar('Z')) then + t(k:k) = achar(c + (iachar('a') - iachar('A'))) + end if + end do + end function to_lower + + subroutine push_param(pnames, pvals, name, val) + use nrtype + implicit none + character(len=:), allocatable, intent(inout) :: pnames(:) + real(sp), allocatable, intent(inout) :: pvals(:) + character(len=*), intent(in) :: name + real(sp), intent(in) :: val + + character(len=:), allocatable :: new_names(:) + real(sp), allocatable :: new_vals(:) + integer :: n + + n = 0 + if (allocated(pvals)) n = size(pvals) + + allocate(character(len=len_trim(name)) :: new_names(n+1)) + allocate(new_vals(n+1)) + + if (n > 0) then + new_names(1:n) = pnames + new_vals(1:n) = pvals + end if + + new_names(n+1) = trim(name) + new_vals(n+1) = val + + call move_alloc(new_names, pnames) + call move_alloc(new_vals, pvals) + end subroutine push_param + + pure logical function is_valid_mode(m) + character(len=*), intent(in) :: m + is_valid_mode = (trim(m) == 'def' .or. trim(m) == 'idx' .or. trim(m) == 'opt' .or. trim(m) == 'sce') + end function is_valid_mode + + pure logical function is_valid_restart(f) + character(len=*), intent(in) :: f + is_valid_restart = (trim(f) == 'y' .or. trim(f) == 'm' .or. trim(f) == 'd' .or. trim(f) == 'e' .or. trim(f) == 'never') + end function is_valid_restart + +end module parse_command_args_MODULE + + + diff --git a/build/FUSE_SRC/prelim/uniquemodl.f90 b/build/FUSE_SRC/prelim/uniquemodl.f90 index e9de2a7..a2ea619 100644 --- a/build/FUSE_SRC/prelim/uniquemodl.f90 +++ b/build/FUSE_SRC/prelim/uniquemodl.f90 @@ -1,139 +1,149 @@ -SUBROUTINE UNIQUEMODL(NMOD) -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2007; modified in 2008 to include rainfall errors -! Modified by Brian Henn to include snow model, 6/2013 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Creates an array of character strings that define different model combinations -! --------------------------------------------------------------------------------------- -! Modules Modified: -! ----------------- -! MODULE model_defn -! LIST_* = lists of options for * different model components -! AMODL%* = structure that holds all (NMOD) unique combinations -! --------------------------------------------------------------------------------------- -USE nrtype -USE model_defn -USE model_defnames -IMPLICIT NONE -! Output -INTEGER(I4B) :: NMOD ! number of model combinations -! Internal -INTEGER(I4B) :: ICOUNT ! loop through unique models -INTEGER(I4B) :: ISW_RFERR ! loop thru rainfall errors -INTEGER(I4B) :: ISW_ARCH1 ! loop thru upper layer architecture -INTEGER(I4B) :: ISW_ARCH2 ! loop thru lower layer architecture -INTEGER(I4B) :: ISW_QSURF ! loop thru surface runoff -INTEGER(I4B) :: ISW_QPERC ! loop thru percolation -INTEGER(I4B) :: ISW_ESOIL ! loop thru evaporation -INTEGER(I4B) :: ISW_QINTF ! loop thru interflow -INTEGER(I4B) :: ISW_Q_TDH ! loop thru time delay options -INTEGER(I4B) :: ISW_SNOWM ! loop thru snow model options -! Start procedure here -!err=0; message="UNIQUEMODL/ok" -! --------------------------------------------------------------------------------------- -! (1) POPULATE LISTS OF OPTIONS FOR THE DIFFERENT MODEL COMPONENTS -! --------------------------------------------------------------------------------------- -! rainfall error -LIST_RFERR(1)%MCOMPONENT = 'additive_e' ! additive rainfall error -LIST_RFERR(2)%MCOMPONENT = 'multiplc_e' ! multiplicative rainfall error -! upper-layer architecture -LIST_ARCH1(1)%MCOMPONENT = 'tension1_1' ! upper layer broken up into tension and free storage -LIST_ARCH1(2)%MCOMPONENT = 'tension2_1' ! tension storage sub-divided into recharge and excess -LIST_ARCH1(3)%MCOMPONENT = 'onestate_1' ! upper layer defined by a single state variable -! lower-layer architecture -- defines method for computing baseflow -LIST_ARCH2(1)%MCOMPONENT = 'tens2pll_2' ! tension reservoir plus two parallel tanks -LIST_ARCH2(2)%MCOMPONENT = 'unlimfrc_2' ! baseflow resvr of unlimited size (0-HUGE), frac rate -LIST_ARCH2(3)%MCOMPONENT = 'unlimpow_2' ! baseflow resvr of unlimited size (0-HUGE), power recession -LIST_ARCH2(4)%MCOMPONENT = 'fixedsiz_2' ! baseflow reservoir of fixed size -! surface runoff -LIST_QSURF(1)%MCOMPONENT = 'arno_x_vic' ! ARNO/Xzang/VIC parameterization (upper zone control) -LIST_QSURF(2)%MCOMPONENT = 'prms_varnt' ! PRMS variant (fraction of upper tension storage) -LIST_QSURF(3)%MCOMPONENT = 'tmdl_param' ! TOPMODEL parameterization (only valid for TOPMODEL qb) -! percolation -LIST_QPERC(1)%MCOMPONENT = 'perc_f2sat' ! water from (field cap to sat) avail for percolation -LIST_QPERC(2)%MCOMPONENT = 'perc_w2sat' ! water from (wilt pt to sat) avail for percolation -LIST_QPERC(3)%MCOMPONENT = 'perc_lower' ! perc defined by moisture content in lower layer (SAC) -! evaporation fluxes (lower layer evap = 0 for ['tension2_1','unlimfrc_2','unlimpow_2','topmdexp_2'] -LIST_ESOIL(1)%MCOMPONENT = 'sequential' ! sequential evaporation model -LIST_ESOIL(2)%MCOMPONENT = 'rootweight' ! root weighting -! interflow -LIST_QINTF(1)%MCOMPONENT = 'intflwnone' ! no interflow -LIST_QINTF(2)%MCOMPONENT = 'intflwsome' ! interflow -! time delay in runoff -LIST_Q_TDH(1)%MCOMPONENT = 'rout_gamma' ! use a Gamma distribution with shape parameter = 2.5 -LIST_Q_TDH(2)%MCOMPONENT = 'no_routing' ! no routing -! snow model switch -LIST_SNOWM(1)%MCOMPONENT = 'no_snowmod' ! no snow model -LIST_SNOWM(2)%MCOMPONENT = 'temp_index' ! temperature index snow model -! --------------------------------------------------------------------------------------- -! (2) LOOP THROUGH MODEL COMPONENTS AND DEFINE A SET OF UNIQUE MODELS -! --------------------------------------------------------------------------------------- -! sequence of model-building decisions -! a) define rainfall error -! b) define upper-layer architecture -! c) define lower-layer architecture -! d) define surface runoff method -! e) define percolation method -! f) define evaporation method -! g) define interflow method -! h) define time delay in runoff -ICOUNT = 0 ! initialize counter -! loop through snow model options -DO ISW_SNOWM=1,SIZE(LIST_SNOWM) -! (loop through time delay options) -DO ISW_Q_TDH=1,SIZE(LIST_Q_TDH) - ! (loop through interflow options) - DO ISW_QINTF=1,SIZE(LIST_QINTF) - ! (loop through evaporation options) - DO ISW_ESOIL=1,SIZE(LIST_ESOIL) - ! (loop through percolation options) - DO ISW_QPERC=1,SIZE(LIST_QPERC) - ! (loop through surface runoff options) - DO ISW_QSURF=1,SIZE(LIST_QSURF) - ! (loop through lower-layer architecture options) - DO ISW_ARCH2=1,SIZE(LIST_ARCH2) - ! (loop through upper-layer architecture options) - DO ISW_ARCH1=1,SIZE(LIST_ARCH1) - ! (loop through rainfall error options) - DO ISW_RFERR=1,SIZE(LIST_RFERR) - ! don't allow a lower tension tank when there are two upper ones - IF (LIST_ARCH1(ISW_ARCH1)%MCOMPONENT(1:10).EQ.'tension2_1'.AND. & - LIST_ARCH2(ISW_ARCH2)%MCOMPONENT(1:10).EQ.'tens2pll_2') CYCLE - ! don't allow percolation below field capacity if there are multiple upper tanks - IF (LIST_ARCH1(ISW_ARCH1)%MCOMPONENT(1:10).NE.'onestate_1'.AND. & - LIST_QPERC(ISW_QPERC)%MCOMPONENT(1:10).EQ.'perc_w2sat') CYCLE - ICOUNT = ICOUNT + 1 ! (increment counter) - IF (ICOUNT.LE.SIZE(AMODL)) THEN - ! save unique model combinations - AMODL(ICOUNT)%iRFERR = desc_str2int(LIST_RFERR(ISW_RFERR)%MCOMPONENT) - AMODL(ICOUNT)%iARCH1 = desc_str2int(LIST_ARCH1(ISW_ARCH1)%MCOMPONENT) - AMODL(ICOUNT)%iARCH2 = desc_str2int(LIST_ARCH2(ISW_ARCH2)%MCOMPONENT) - AMODL(ICOUNT)%iQSURF = desc_str2int(LIST_QSURF(ISW_QSURF)%MCOMPONENT) - AMODL(ICOUNT)%iQPERC = desc_str2int(LIST_QPERC(ISW_QPERC)%MCOMPONENT) - AMODL(ICOUNT)%iESOIL = desc_str2int(LIST_ESOIL(ISW_ESOIL)%MCOMPONENT) - AMODL(ICOUNT)%iQINTF = desc_str2int(LIST_QINTF(ISW_QINTF)%MCOMPONENT) - AMODL(ICOUNT)%iQ_TDH = desc_str2int(LIST_Q_TDH(ISW_Q_TDH)%MCOMPONENT) - AMODL(ICOUNT)%iSNOWM = desc_str2int(LIST_Q_TDH(ISW_SNOWM)%MCOMPONENT) - !write(*,'(i3,1x,7(a10,1x))') icount, amodl(icount) - ELSE - ! need to allocate more space - print *, 'insufficent space to hold model combinations' - stop - ENDIF - END DO ! RFERR - END DO ! ARCH1 - END DO ! ARCH2 - END DO ! QSURF - END DO ! QPERC - END DO ! ESOIL - END DO ! QINTF -END DO ! Q_TDH -END DO ! SNOWM -! --------------------------------------------------------------------------------------- -NMOD = ICOUNT -!pause -END SUBROUTINE UNIQUEMODL +module uniquemodl_module + implicit none + private + public :: uniquemodl + +contains + + + SUBROUTINE UNIQUEMODL(NMOD) + ! --------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark, 2007; modified in 2008 to include rainfall errors + ! Modified by Brian Henn to include snow model, 6/2013 + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! Creates an array of character strings that define different model combinations + ! --------------------------------------------------------------------------------------- + ! Modules Modified: + ! ----------------- + ! MODULE model_defn + ! LIST_* = lists of options for * different model components + ! AMODL%* = structure that holds all (NMOD) unique combinations + ! --------------------------------------------------------------------------------------- + USE nrtype + USE model_defn + USE model_defnames + IMPLICIT NONE + ! Output + INTEGER(I4B) , intent(out) :: NMOD ! number of model combinations + ! Internal + INTEGER(I4B) :: ICOUNT ! loop through unique models + INTEGER(I4B) :: ISW_RFERR ! loop thru rainfall errors + INTEGER(I4B) :: ISW_ARCH1 ! loop thru upper layer architecture + INTEGER(I4B) :: ISW_ARCH2 ! loop thru lower layer architecture + INTEGER(I4B) :: ISW_QSURF ! loop thru surface runoff + INTEGER(I4B) :: ISW_QPERC ! loop thru percolation + INTEGER(I4B) :: ISW_ESOIL ! loop thru evaporation + INTEGER(I4B) :: ISW_QINTF ! loop thru interflow + INTEGER(I4B) :: ISW_Q_TDH ! loop thru time delay options + INTEGER(I4B) :: ISW_SNOWM ! loop thru snow model options + ! Start procedure here + !err=0; message="UNIQUEMODL/ok" + ! --------------------------------------------------------------------------------------- + ! (1) POPULATE LISTS OF OPTIONS FOR THE DIFFERENT MODEL COMPONENTS + ! --------------------------------------------------------------------------------------- + ! rainfall error + LIST_RFERR(1)%MCOMPONENT = 'additive_e' ! additive rainfall error + LIST_RFERR(2)%MCOMPONENT = 'multiplc_e' ! multiplicative rainfall error + ! upper-layer architecture + LIST_ARCH1(1)%MCOMPONENT = 'tension1_1' ! upper layer broken up into tension and free storage + LIST_ARCH1(2)%MCOMPONENT = 'tension2_1' ! tension storage sub-divided into recharge and excess + LIST_ARCH1(3)%MCOMPONENT = 'onestate_1' ! upper layer defined by a single state variable + ! lower-layer architecture -- defines method for computing baseflow + LIST_ARCH2(1)%MCOMPONENT = 'tens2pll_2' ! tension reservoir plus two parallel tanks + LIST_ARCH2(2)%MCOMPONENT = 'unlimfrc_2' ! baseflow resvr of unlimited size (0-HUGE), frac rate + LIST_ARCH2(3)%MCOMPONENT = 'unlimpow_2' ! baseflow resvr of unlimited size (0-HUGE), power recession + LIST_ARCH2(4)%MCOMPONENT = 'fixedsiz_2' ! baseflow reservoir of fixed size + ! surface runoff + LIST_QSURF(1)%MCOMPONENT = 'arno_x_vic' ! ARNO/Xzang/VIC parameterization (upper zone control) + LIST_QSURF(2)%MCOMPONENT = 'prms_varnt' ! PRMS variant (fraction of upper tension storage) + LIST_QSURF(3)%MCOMPONENT = 'tmdl_param' ! TOPMODEL parameterization (only valid for TOPMODEL qb) + ! percolation + LIST_QPERC(1)%MCOMPONENT = 'perc_f2sat' ! water from (field cap to sat) avail for percolation + LIST_QPERC(2)%MCOMPONENT = 'perc_w2sat' ! water from (wilt pt to sat) avail for percolation + LIST_QPERC(3)%MCOMPONENT = 'perc_lower' ! perc defined by moisture content in lower layer (SAC) + ! evaporation fluxes (lower layer evap = 0 for ['tension2_1','unlimfrc_2','unlimpow_2','topmdexp_2'] + LIST_ESOIL(1)%MCOMPONENT = 'sequential' ! sequential evaporation model + LIST_ESOIL(2)%MCOMPONENT = 'rootweight' ! root weighting + ! interflow + LIST_QINTF(1)%MCOMPONENT = 'intflwnone' ! no interflow + LIST_QINTF(2)%MCOMPONENT = 'intflwsome' ! interflow + ! time delay in runoff + LIST_Q_TDH(1)%MCOMPONENT = 'rout_gamma' ! use a Gamma distribution with shape parameter = 2.5 + LIST_Q_TDH(2)%MCOMPONENT = 'no_routing' ! no routing + ! snow model switch + LIST_SNOWM(1)%MCOMPONENT = 'no_snowmod' ! no snow model + LIST_SNOWM(2)%MCOMPONENT = 'temp_index' ! temperature index snow model + ! --------------------------------------------------------------------------------------- + ! (2) LOOP THROUGH MODEL COMPONENTS AND DEFINE A SET OF UNIQUE MODELS + ! --------------------------------------------------------------------------------------- + ! sequence of model-building decisions + ! a) define rainfall error + ! b) define upper-layer architecture + ! c) define lower-layer architecture + ! d) define surface runoff method + ! e) define percolation method + ! f) define evaporation method + ! g) define interflow method + ! h) define time delay in runoff + ICOUNT = 0 ! initialize counter + ! loop through snow model options + DO ISW_SNOWM=1,SIZE(LIST_SNOWM) + ! (loop through time delay options) + DO ISW_Q_TDH=1,SIZE(LIST_Q_TDH) + ! (loop through interflow options) + DO ISW_QINTF=1,SIZE(LIST_QINTF) + ! (loop through evaporation options) + DO ISW_ESOIL=1,SIZE(LIST_ESOIL) + ! (loop through percolation options) + DO ISW_QPERC=1,SIZE(LIST_QPERC) + ! (loop through surface runoff options) + DO ISW_QSURF=1,SIZE(LIST_QSURF) + ! (loop through lower-layer architecture options) + DO ISW_ARCH2=1,SIZE(LIST_ARCH2) + ! (loop through upper-layer architecture options) + DO ISW_ARCH1=1,SIZE(LIST_ARCH1) + ! (loop through rainfall error options) + DO ISW_RFERR=1,SIZE(LIST_RFERR) + ! don't allow a lower tension tank when there are two upper ones + IF (LIST_ARCH1(ISW_ARCH1)%MCOMPONENT(1:10).EQ.'tension2_1'.AND. & + LIST_ARCH2(ISW_ARCH2)%MCOMPONENT(1:10).EQ.'tens2pll_2') CYCLE + ! don't allow percolation below field capacity if there are multiple upper tanks + IF (LIST_ARCH1(ISW_ARCH1)%MCOMPONENT(1:10).NE.'onestate_1'.AND. & + LIST_QPERC(ISW_QPERC)%MCOMPONENT(1:10).EQ.'perc_w2sat') CYCLE + ICOUNT = ICOUNT + 1 ! (increment counter) + IF (ICOUNT.LE.SIZE(AMODL)) THEN + ! save unique model combinations + AMODL(ICOUNT)%iRFERR = desc_str2int(LIST_RFERR(ISW_RFERR)%MCOMPONENT) + AMODL(ICOUNT)%iARCH1 = desc_str2int(LIST_ARCH1(ISW_ARCH1)%MCOMPONENT) + AMODL(ICOUNT)%iARCH2 = desc_str2int(LIST_ARCH2(ISW_ARCH2)%MCOMPONENT) + AMODL(ICOUNT)%iQSURF = desc_str2int(LIST_QSURF(ISW_QSURF)%MCOMPONENT) + AMODL(ICOUNT)%iQPERC = desc_str2int(LIST_QPERC(ISW_QPERC)%MCOMPONENT) + AMODL(ICOUNT)%iESOIL = desc_str2int(LIST_ESOIL(ISW_ESOIL)%MCOMPONENT) + AMODL(ICOUNT)%iQINTF = desc_str2int(LIST_QINTF(ISW_QINTF)%MCOMPONENT) + AMODL(ICOUNT)%iQ_TDH = desc_str2int(LIST_Q_TDH(ISW_Q_TDH)%MCOMPONENT) + AMODL(ICOUNT)%iSNOWM = desc_str2int(LIST_Q_TDH(ISW_SNOWM)%MCOMPONENT) + !write(*,'(i3,1x,7(a10,1x))') icount, amodl(icount) + ELSE + ! need to allocate more space + print *, 'insufficent space to hold model combinations' + stop + ENDIF + END DO ! RFERR + END DO ! ARCH1 + END DO ! ARCH2 + END DO ! QSURF + END DO ! QPERC + END DO ! ESOIL + END DO ! QINTF + END DO ! Q_TDH + END DO ! SNOWM + ! --------------------------------------------------------------------------------------- + NMOD = ICOUNT + !pause + END SUBROUTINE UNIQUEMODL + +end module uniquemodl_module diff --git a/build/FUSE_SRC/runtime/get_time_indices.f90 b/build/FUSE_SRC/runtime/get_time_indices.f90 deleted file mode 100644 index e71333e..0000000 --- a/build/FUSE_SRC/runtime/get_time_indices.f90 +++ /dev/null @@ -1,121 +0,0 @@ -MODULE GET_TIME_INDICES_MODULE - - USE nrtype - use time_io - implicit none - - contains - SUBROUTINE GET_TIME_INDICES - - ! EXTRACT DATES AND DETERMINE ASSOCIATED INDICES - - ! convert start and end date of the NetCDF input file to julian day (Julian day is the continuous - ! count of days since the beginning of the Julian Period around 4700 BC) - - USE multiforce, ONLY: timeUnits,time_steps,julian_day_input ! time data - USE multiforce, only: numtim_in, itim_in, istart ! length of input time series and associated index - USE multiforce, only: numtim_sim, itim_sim ! length of simulated time series and associated index - USE multiforce, only: numtim_sub, itim_sub ! length of subperiod time series and associated index - USE multiforce, only: sim_beg,sim_end ! timestep indices - USE multiforce, only: eval_beg,eval_end ! timestep indices - USE multiforce, only: SUB_PERIODS_FLAG ! .true. if subperiods are used to run FUSE - - USE fuse_fileManager,only:date_start_sim,date_end_sim,& - date_start_eval,date_end_eval,& - numtim_sub_str - - real(sp) :: jdate_ref_netcdf - INTEGER(I4B) :: ERR ! error code - CHARACTER(LEN=1024) :: MESSAGE ! error message - - ! dummies - integer(i4b) :: iy,im,id,ih,imin ! to temporarily store year, month, day, hour, min - real(sp) :: isec ! to temporarily store sec - real(sp) :: jdate ! to temporarily store a julian date - real(sp) :: jdate_start_sim ! date start simulation - real(sp) :: jdate_end_sim ! date end simulation - real(sp) :: jdate_start_eval ! date start evaluation period - real(sp) :: jdate_end_eval ! date end evaluation period - - ! --------------------------------------------------------------------------------------- - ! process time data from foring file - call date_extractor(trim(timeUnits),iy,im,id,ih) ! break down reference date of NetCDF file - call juldayss(iy,im,id,ih, & ! convert it to julian day - jdate_ref_netcdf,err,message) - - julian_day_input=jdate_ref_netcdf+time_steps ! julian day of each time step of the input file - - call caldatss(julian_day_input(1),iy,im,id,ih,imin,isec) - print *, 'Start date input file=',iy,im,id - - call caldatss(julian_day_input(numtim_in),iy,im,id,ih,imin,isec) - print *, 'End date input file= ',iy,im,id - - ! convert dates for simulation into julian day - call date_extractor(trim(date_start_sim),iy,im,id,ih) ! break down date - call juldayss(iy,im,id,ih,jdate_start_sim,err,message) ! convert it to julian day - if(jdate_start_sim.lt.minval(julian_day_input))then ! check forcing available - call caldatss(jdate_start_sim,iy,im,id,ih,imin,isec) - print *, 'Error: hydrologic simulation cannot start on ',iy,im,id,' because atmospheric forcing starts later (see above)';stop; - endif - sim_beg= minloc(abs(julian_day_input-jdate_start_sim),1) ! find correponding index - call caldatss(julian_day_input(sim_beg),iy,im,id,ih,imin,isec) - print *, 'Date start sim= ',iy,im,id - - call date_extractor(trim(date_end_sim),iy,im,id,ih) ! break down date - call juldayss(iy,im,id,ih,jdate_end_sim,err,message) ! convert it to julian day - if(jdate_end_sim.gt.maxval(julian_day_input))then ! check forcing available - call caldatss(jdate_end_sim,iy,im,id,ih,imin,isec) - print *, 'Error: hydrologic simulation cannot end on ',iy,im,id,' because atmospheric forcing ends earlier (see above)';stop; - endif - sim_end= minloc(abs(julian_day_input-jdate_end_sim),1) ! find correponding index - call caldatss(julian_day_input(sim_end),iy,im,id,ih,imin,isec) - print *, 'Date end sim= ',iy,im,id - - call date_extractor(trim(date_start_eval),iy,im,id,ih) ! break down date - call juldayss(iy,im,id,ih,jdate_start_eval,err,message) ! convert it to julian day - eval_beg= minloc(abs(julian_day_input-jdate_start_eval),1) ! find correponding index - call caldatss(julian_day_input(eval_beg),iy,im,id,ih,imin,isec) - print *, 'Date start eval= ',iy,im,id - - call date_extractor(trim(date_end_eval),iy,im,id,ih) ! break down date - call juldayss(iy,im,id,ih,jdate_end_eval,err,message) ! convert it to julian day - eval_end= minloc(abs(julian_day_input-jdate_end_eval),1) ! find correponding index - call caldatss(julian_day_input(eval_end),iy,im,id,ih,imin,isec) - print *, 'Date end eval= ',iy,im,id - - ! check start before end - if(jdate_start_sim.gt.jdate_end_sim)then; print *, 'Error: date_start_sim > date_end_sim '; stop; endif - if(jdate_start_eval.gt.jdate_end_eval)then; print *, 'Error: date_start_eval > date_end_eval '; stop; endif - - ! check input data available for desired runs - if(jdate_start_sim.lt.julian_day_input(1))then; print *, 'Error: date_start_sim is before the start if the input data'; stop; endif - if(jdate_end_sim.gt.julian_day_input(numtim_in))then; print *, 'Error: the date_stop_sim is after the end of the input data'; stop; endif - - ! check input data available for desired runs - if(jdate_start_eval.lt.jdate_start_sim)then; print *, 'Error: date_start_eval < date_start_sim'; stop; endif - if(jdate_end_eval.gt.jdate_end_sim)then; print *, 'Error: date_end_eval > date_end_sim'; stop; endif - - ! determine length of simulations - numtim_sim=sim_end-sim_beg+1 - istart=sim_beg - - ! determine length of subperiods - read(numtim_sub_str,*,iostat=err) numtim_sub ! convert string to integer - - if(numtim_sub.eq.-9999)then - - print *, 'numtim_sub = -9999, FUSE will be run in 1 chunk of ',numtim_sim, 'time steps' - SUB_PERIODS_FLAG=.FALSE. - - numtim_sub=numtim_sim ! no subperiods, run the whole time series - - else - - print *, 'FUSE will be run in chunks of ',numtim_sub, 'time steps' - SUB_PERIODS_FLAG=.TRUE. - - end if - - END SUBROUTINE GET_TIME_INDICES -END MODULE diff --git a/build/FUSE_SRC/runtime/get_time_windows.f90 b/build/FUSE_SRC/runtime/get_time_windows.f90 new file mode 100644 index 0000000..f3c52b6 --- /dev/null +++ b/build/FUSE_SRC/runtime/get_time_windows.f90 @@ -0,0 +1,345 @@ +module time_windows_module + + use nrtype + use info_types, only: fuse_info + use time_utils, only: date_extractor, juldayss + + implicit none + + private + public :: get_time_windows + public :: export_time_to_multiforce + + contains + + subroutine get_time_windows(ncid, info, ierr, message) + + integer(i4b), intent(in) :: ncid + type(fuse_info), intent(inout) :: info + integer(i4b), intent(out) :: ierr + character(*), intent(out) :: message + + integer(i4b) :: nt + character(len=1024) :: units_local + real(sp) :: scale_to_days, dt_native, dt_days + integer(i4b) :: ios + character(len=1024) :: cmessage + + ierr=0; message="get_time_windows/" + + ! ----- read forcing time axis ------------------------------------------------------ + + call read_time_axis(ncid, info%time%time_steps, units_local, nt, ierr, cmessage) + if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif + + info%time%nt_global = nt + info%time%units = trim(units_local) + + ! ----- build julian-day axis ------------------------------------------------------- + + call build_julian_axis(info%time%time_steps, trim(units_local), & + info%time%jdate_ref, info%time%jdate, info%time%deltim_days, ierr, cmessage) + if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif + + ! ----- compute indices for sim/eval windows ---------------------------------------- + + ! simulation indices + call map_dates_to_indices(info%time%jdate, info%config%date_start_sim, info%config%date_end_sim, & + info%time%sim_beg, info%time%sim_end, ierr, cmessage) + if (ierr/=0)then; message=trim(message)//trim(cmessage); return; endif + + ! evaluation indices + call map_dates_to_indices(info%time%jdate, info%config%date_start_eval, info%config%date_end_eval, & + info%time%eval_beg, info%time%eval_end, ierr, cmessage) + if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif + + ! ----- validate window consistency ------------------------------------------------- + + call validate_windows(info%time, ierr, cmessage) + if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif + + ! ----- derive simulation length ---------------------------------------------------- + + info%time%nt_sim = info%time%sim_end - info%time%sim_beg + 1 + + ! ----- configure sub-period windowing ---------------------------------------------- + + ! convert sub-period string to integer + read(info%config%numtim_sub_str,*,iostat=ios) info%time%nt_window + if(ios/=0) then + ierr=1; message=trim(message)//"cannot parse numtim_sub_str"; return + endif + + ! handle cases where sub-periods are undefined + if(info%time%nt_window == -9999) then + info%time%use_subperiods = .false. + info%time%nt_window = info%time%nt_sim + else + info%time%use_subperiods = .true. + ! keep nt_window as user-chosen chunk size + endif + + ! ----- export info to legacy data structures --------------------------------------- + + ! export info%time -> multiforce to keep legacy code working + call export_time_to_multiforce(info) + + end subroutine get_time_windows + + ! ------------------------------------------------------------------------------------- + ! ------------------------------------------------------------------------------------- + + ! ----- backwards compatibility: export to multiforce globals ------------------------- + + ! - New code stores all time-window metadata in info%time (source of truth). + ! - Legacy routines still read multiforce globals (sim_beg, sim_end, numtim_sub, ...). + + subroutine export_time_to_multiforce(info) + use multiforce, only: time_steps, timeUnits + use multiforce, only: sim_beg, sim_end, eval_beg, eval_end, numtim_sim, numtim_sub, & + SUB_PERIODS_FLAG, istart, deltim + implicit none + type(fuse_info), intent(in) :: info + + time_steps = info%time%time_steps + timeUnits = info%time%units + + sim_beg = info%time%sim_beg + sim_end = info%time%sim_end + eval_beg = info%time%eval_beg + eval_end = info%time%eval_end + + numtim_sim = info%time%nt_sim + numtim_sub = info%time%nt_window + SUB_PERIODS_FLAG = info%time%use_subperiods + + istart = sim_beg + + deltim = info%time%deltim_days + end subroutine + + ! ------------------------------------------------------------------------------------- + ! ------------------------------------------------------------------------------------- + ! ----- helper routines --------------------------------------------------------------- + ! ------------------------------------------------------------------------------------- + ! ------------------------------------------------------------------------------------- + + ! ----- helper: read time axis from NetCDF -------------------------------------------- + + subroutine read_time_axis(ncid, time_steps, units, nt, ierr, message) + + use netcdf + + implicit none + + integer(i4b), intent(in) :: ncid + real(sp), allocatable, intent(out) :: time_steps(:) + character(len=*), intent(out) :: units + integer(i4b), intent(out) :: nt, ierr + character(*), intent(out) :: message + + integer(i4b) :: varid, dimids(1) + + ierr=0; message="read_time_axis/" + + ierr = nf90_inq_varid(ncid, "time", varid) + if(ierr/=nf90_noerr) then + message=trim(message)//"cannot find time variable"; return + endif + + ierr = nf90_inquire_variable(ncid, varid, dimids=dimids) + if(ierr/=nf90_noerr) then + message=trim(message)//trim(nf90_strerror(ierr)); return + endif + + ierr = nf90_inquire_dimension(ncid, dimids(1), len=nt) + if(ierr/=nf90_noerr) then + message=trim(message)//trim(nf90_strerror(ierr)); return + endif + + allocate(time_steps(nt), stat=ierr) + if(ierr/=0) then + message=trim(message)//"allocate(time_steps) failed"; return + endif + + ierr = nf90_get_var(ncid, varid, time_steps) + if(ierr/=nf90_noerr) then + message=trim(message)//trim(nf90_strerror(ierr)); return + endif + + ierr = nf90_get_att(ncid, varid, "units", units) + if(ierr/=nf90_noerr) then + message=trim(message)//"cannot read time units attribute"; return + endif + + end subroutine read_time_axis + + ! ------------------------------------------------------------------------------------- + ! ------------------------------------------------------------------------------------- + + ! ----- helper: build julian axis ----------------------------------------------------- + + subroutine build_julian_axis(time_steps, units, jref, jdate, deltim_days, ierr, message) + + real(sp), intent(in) :: time_steps(:) + character(len=*), intent(in) :: units + real(sp), intent(out) :: jref + real(sp), allocatable, intent(out) :: jdate(:) + real(sp), intent(out) :: deltim_days + integer(i4b), intent(out) :: ierr + character(*), intent(out) :: message + + integer(i4b) :: iy,im,id,ih + character(len=1024) :: cmessage + real(sp) :: scale_to_days + + ierr=0; message="build_julian_axis/" + + ! extract reference date from the units string + call date_extractor(trim(units), iy, im, id, ih) + call juldayss(iy,im,id,ih, jref, ierr, cmessage) + if(ierr/=0) then; message=trim(message)//trim(cmessage); return; endif + + ! determine scaling factor to convert time_steps into days + scale_to_days = time_units_to_days(units, ierr, cmessage) + if(ierr/=0) then; message=trim(message)//trim(cmessage); return; endif + + ! build julian axis (units of days) + allocate(jdate(size(time_steps)), stat=ierr) + if(ierr/=0) then; message=trim(message)//"allocate(jdate) failed"; return; endif + jdate = jref + time_steps * scale_to_days + + ! define length of forcing time steps + deltim_days = jdate(2) - jdate(1) + + end subroutine build_julian_axis + + ! ------------------------------------------------------------------------------------- + ! ------------------------------------------------------------------------------------- + + ! ----- helper: determine scaling factor to convert time_steps into days -------------- + + real(sp) function time_units_to_days(units, ierr, message) + implicit none + character(len=*), intent(in) :: units + integer(i4b), intent(out) :: ierr + character(*), intent(out) :: message + + character(len=:), allocatable :: u + integer(i4b) :: p + + ierr=0; message="time_units_to_days/" + + ! lower-case copy (simple approach) + u = tolower_str( trim(adjustl(units)) ) + + ! Look at the first token before a space + p = index(u, " ") + if(p <= 1) then + ierr=1; message=trim(message)//"cannot parse units string: "//trim(units) + time_units_to_days = 0._sp + return + endif + + select case (trim(u(1:p-1))) + case ("days", "day") + time_units_to_days = 1._sp + case ("hours", "hour") + time_units_to_days = 1._sp / 24._sp + case ("minutes", "minute", "mins", "min") + time_units_to_days = 1._sp / 1440._sp + case ("seconds", "second", "secs", "sec") + time_units_to_days = 1._sp / 86400._sp + case default + ierr=1 + message=trim(message)//"unsupported time unit: "//trim(u(1:p-1)) + time_units_to_days = 0._sp + end select + + end function time_units_to_days + + pure function tolower_str(s) result(out) + character(len=*), intent(in) :: s + character(len=len(s)) :: out + integer :: i + do i=1,len(s) + select case(s(i:i)) + case("A":"Z"); out(i:i) = achar(iachar(s(i:i)) + 32) + case default; out(i:i) = s(i:i) + end select + end do + end function tolower_str + + ! ------------------------------------------------------------------------------------- + ! ------------------------------------------------------------------------------------- + + ! ----- helper: map start/end date strings to indices --------------------------------- + + subroutine map_dates_to_indices(jdate, date_start, date_end, i_beg, i_end, ierr, message) + + real(sp), intent(in) :: jdate(:) + character(len=*), intent(in) :: date_start, date_end + integer(i4b), intent(out) :: i_beg, i_end + integer(i4b), intent(out) :: ierr + character(*), intent(out) :: message + + integer(i4b) :: iy,im,id,ih + real(sp) :: j_start, j_end + character(len=1024) :: cmessage + + ierr=0; message="map_dates_to_indices/" + + ! start date + call date_extractor(trim(date_start), iy,im,id,ih) + call juldayss(iy,im,id,ih, j_start, ierr, cmessage) + if(ierr/=0) then; message=trim(message)//trim(cmessage); return; endif + + ! end date + call date_extractor(trim(date_end), iy,im,id,ih) + call juldayss(iy,im,id,ih, j_end, ierr, cmessage) + if(ierr/=0) then; message=trim(message)//trim(cmessage); return; endif + + ! validate + + if(j_start > j_end) then + ierr=1; message=trim(message)//"start date > end date"; return + endif + + if(j_start < minval(jdate) .or. j_end > maxval(jdate)) then + ierr=1; message=trim(message)//"requested window outside forcing range"; return + endif + + ! get indices in jdate vector + i_beg = minloc(abs(jdate - j_start), 1) + i_end = minloc(abs(jdate - j_end ), 1) + + end subroutine map_dates_to_indices + + + ! ------------------------------------------------------------------------------------- + ! ------------------------------------------------------------------------------------- + + ! ----- helper: validate sim/eval logic ----------------------------------------------- + + subroutine validate_windows(ti, ierr, message) + + use info_types, only: time_info + type(time_info), intent(in) :: ti + integer(i4b), intent(out) :: ierr + character(*), intent(out) :: message + + ierr=0; message="validate_windows/" + + if(ti%eval_beg < ti%sim_beg) then + ierr=1; message=trim(message)//"eval start < sim start"; return + endif + if(ti%eval_end > ti%sim_end) then + ierr=1; message=trim(message)//"eval end > sim end"; return + endif + + end subroutine validate_windows + + ! ------------------------------------------------------------------------------------- + ! ------------------------------------------------------------------------------------- + +end module time_windows_module diff --git a/build/FUSE_SRC/runtime/initfluxes.f90 b/build/FUSE_SRC/runtime/initfluxes.f90 index 230781d..dd41bab 100644 --- a/build/FUSE_SRC/runtime/initfluxes.f90 +++ b/build/FUSE_SRC/runtime/initfluxes.f90 @@ -42,8 +42,8 @@ SUBROUTINE INITFLUXES() M_FLUX%OFLOW_2B = 0._sp; W_FLUX%OFLOW_2B = 0._sp IF(SMODL%iSNOWM.EQ.iopt_temp_index) THEN !loop through snow model bands DO ISNW=1,N_BANDS - MBANDS(ISNW)%SNOWACCMLTN = 0._sp - MBANDS(ISNW)%SNOWMELT = 0._sp + MBANDS(ISNW)%var%SNOWACCMLTN = 0._sp + MBANDS(ISNW)%var%SNOWMELT = 0._sp END DO ENDIF M_FLUX%ERR_WATR_1 = 0._sp; W_FLUX%ERR_WATR_1 = 0._sp diff --git a/build/FUSE_SRC/runtime/mean_stats.f90 b/build/FUSE_SRC/runtime/mean_stats.f90 index e80b641..f8b26f8 100644 --- a/build/FUSE_SRC/runtime/mean_stats.f90 +++ b/build/FUSE_SRC/runtime/mean_stats.f90 @@ -17,6 +17,7 @@ SUBROUTINE MEAN_STATS() USE nrtype ! variable types, etc. USE metrics ! available metrics and transformations USE fuse_fileManager,only:METRIC, TRANSFO ! metric and transformation requested in the filemanager +USE globaldata, only: isPrint ! FUSE modules USE multiforce ! model forcing data (obs streamflow) USE multiroute ! routed runoff @@ -54,7 +55,6 @@ SUBROUTINE MEAN_STATS() ! --------------------------------------------------------------------------------------- ! define sample size NS = eval_end-eval_beg+1 -PRINT *, 'Number of time steps in evaluation period (EP) = ', NS ! allocate space for observed and simulated runoff ALLOCATE(QOBS(NS),QOBS_MASK(NS),QSIM(NS),STAT=IERR) @@ -67,9 +67,12 @@ SUBROUTINE MEAN_STATS() ! check for missing QOBS values QOBS_MASK = QOBS.ne.REAL(NA_VALUE, KIND(SP)) ! find the time steps for which QOBS is available -NUM_AVAIL = COUNT(QOBS_MASK) ! number of time steps for which QOBS is available +NUM_AVAIL = COUNT(QOBS_MASK) ! number of time steps for which QOBS is available -PRINT *, 'Number of time steps with observed streamflow in EP = ', NUM_AVAIL +if(isPrint)then + PRINT *, 'Number of time steps in evaluation period (EP) = ', NS + PRINT *, 'Number of time steps with observed streamflow in EP = ', NUM_AVAIL +endif IF (NUM_AVAIL.EQ.0) THEN @@ -85,13 +88,12 @@ SUBROUTINE MEAN_STATS() ALLOCATE(QOBS_AVAIL(NUM_AVAIL),QSIM_AVAIL(NUM_AVAIL),DOBS(NUM_AVAIL),DSIM(NUM_AVAIL),RAWD(NUM_AVAIL),LOGD(NUM_AVAIL),STAT=IERR) IF (IERR /= 0) STOP ' PROBLEM ALLOCATING SPACE FOR AVAILABLE DATA IN MEAN_STATS.F90 ' - QOBS_AVAIL=PACK(QOBS,QOBS_MASK,QOBS_AVAIL) ! moves QOBS time steps indicated by QOBS_MASK to QOBS_AVAIL, - ! if no values is missing (i.e. NS = NUM_AVAIL) then QOBS_AVAIL - ! should be a copy of QOBS + ! if no values is missing (i.e. NS = NUM_AVAIL) then QOBS_AVAIL + ! should be a copy of QOBS QSIM_AVAIL=PACK(QSIM,QOBS_MASK,QSIM_AVAIL) ! moves QSIM time steps indicated by QOBS_MASK to QSIM_AVAIL - ! if no values is missing (i.e. NS = NUM_AVAIL) then QSIM_AVAIL - ! should be a copy of QSIM + ! if no values is missing (i.e. NS = NUM_AVAIL) then QSIM_AVAIL + ! should be a copy of QSIM ! compute mean XB_OBS = SUM(QOBS_AVAIL(:)) / INT(NUM_AVAIL, KIND(SP)) @@ -149,7 +151,7 @@ SUBROUTINE MEAN_STATS() MSTATS%MAE = get_MAE(QOBS_AVAIL, QSIM_AVAIL, '1') ! No transformation ! Compute the metric chosen as objective function using the metrics module - + IF (METRIC == "KGE") THEN MSTATS%METRIC_VAL = get_KGE(QOBS_AVAIL, QSIM_AVAIL, TRANSFO) ELSE IF (METRIC == "KGEP") THEN @@ -169,13 +171,15 @@ SUBROUTINE MEAN_STATS() END IF -PRINT *, 'NSE = ', MSTATS%NASH_SUTT -PRINT *, 'KGE = ', MSTATS%KGE -PRINT *, 'KGEP = ', MSTATS%KGEP -PRINT *, 'MAE = ', MSTATS%MAE -PRINT *, 'RAW_RMSE = ', MSTATS%RAW_RMSE -PRINT *, 'LOG_RMSE = ', MSTATS%LOG_RMSE -PRINT *, 'METRIC_VAL [Metric:',METRIC,' / Transfo:',TRANSFO,'] =', MSTATS%METRIC_VAL +if(isPrint)then + PRINT *, 'NSE = ', MSTATS%NASH_SUTT + PRINT *, 'KGE = ', MSTATS%KGE + PRINT *, 'KGEP = ', MSTATS%KGEP + PRINT *, 'MAE = ', MSTATS%MAE + PRINT *, 'RAW_RMSE = ', MSTATS%RAW_RMSE + PRINT *, 'LOG_RMSE = ', MSTATS%LOG_RMSE + PRINT *, 'METRIC_VAL [Metric:',METRIC,' / Transfo:',TRANSFO,'] =', MSTATS%METRIC_VAL +endif ! --------------------------------------------------------------------------------------- ! (3§) COMPUTE STATISTICS ON NUMERICAL ACCURACY AND EFFICIENCY diff --git a/build/FUSE_SRC/runtime/set_all.f90 b/build/FUSE_SRC/runtime/set_all.f90 index ed3d0e7..071dc0e 100644 --- a/build/FUSE_SRC/runtime/set_all.f90 +++ b/build/FUSE_SRC/runtime/set_all.f90 @@ -39,7 +39,7 @@ SUBROUTINE SET_STATE(VAL) ! snow model DO ISNW=1,N_BANDS - MBANDS(ISNW)%SWE = VAL + MBANDS(ISNW)%var%SWE = VAL END DO FSTATE%SWE_TOT = VAL @@ -88,8 +88,8 @@ SUBROUTINE SET_FLUXES(VAL) M_FLUX%OFLOW_2B = VAL; W_FLUX%OFLOW_2B = VAL IF(SMODL%iSNOWM.EQ.iopt_temp_index) THEN !loop through snow model bands DO ISNW=1,N_BANDS - MBANDS(ISNW)%SNOWACCMLTN = VAL - MBANDS(ISNW)%SNOWMELT = VAL + MBANDS(ISNW)%var%SNOWACCMLTN = VAL + MBANDS(ISNW)%var%SNOWMELT = VAL END DO ENDIF M_FLUX%ERR_WATR_1 = VAL; W_FLUX%ERR_WATR_1 = VAL @@ -153,10 +153,10 @@ SUBROUTINE SET_SNOW(VAL) ! --------------------------------------------------------------------------------------- DO IBANDS=1,N_BANDS - MBANDS(IBANDS)%SWE=VAL ! band snowpack water equivalent (mm) - MBANDS(IBANDS)%SNOWACCMLTN=VAL ! new snow accumulation in band (mm day-1) - MBANDS(IBANDS)%SNOWMELT=VAL ! snowmelt in band (mm day-1) - MBANDS(IBANDS)%DSWE_DT=VAL ! rate of change of band SWE (mm day-1) + MBANDS(IBANDS)%var%SWE=VAL ! band snowpack water equivalent (mm) + MBANDS(IBANDS)%var%SNOWACCMLTN=VAL ! new snow accumulation in band (mm day-1) + MBANDS(IBANDS)%var%SNOWMELT=VAL ! snowmelt in band (mm day-1) + MBANDS(IBANDS)%var%DSWE_DT=VAL ! rate of change of band SWE (mm day-1) END DO ! --------------------------------------------------------------------------------------- diff --git a/build/FUSE_SRC/sce/sce_driver.f90 b/build/FUSE_SRC/sce/sce_driver.f90 deleted file mode 100644 index 1c11e82..0000000 --- a/build/FUSE_SRC/sce/sce_driver.f90 +++ /dev/null @@ -1,157 +0,0 @@ -PROGRAM sce_driver -! --------------------------------------------------------------------------------------- -! Creator: -! Martyn Clark, 2008 -! --------------------------------------------------------------------------------------- -! Purpose: -! Driver program for SCE -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -!USE ddirectory ! directory for data files - commented because couldn't be found -USE fuse_fileManager,only:fuse_SetDirsUndPhiles,& ! use fuse_fileManager instead - sets directories and filenames - OUTPUT_PATH,FORCINGINFO -! data modules -USE model_defn ! model definition structures -USE multiparam, ONLY: PARATT, LPARAM, NUMPAR ! parameter metadata structures -USE multistats ! model statistics structures -USE model_numerix ! model numerix structures -! informational modules -USE selectmodl_module ! reads model control file -USE getpar_str_module ! extracts parameter metadata -IMPLICIT NONE -! command-line arguments -CHARACTER(LEN=6) :: FMODEL_ID=' ' ! integer defining FUSE model -CHARACTER(LEN=6) :: NSOLUTION=' ' ! numerical solution (0=implicit, 1=explicit) -CHARACTER(LEN=6) :: FADAPTIVE=' ' ! identifier for adaptive sub-steps (0=fixed, 1=adaptive) -CHARACTER(LEN=6) :: TRUNC_ABS=' ' ! absolute temporal truncation error tolerance -CHARACTER(LEN=6) :: TRUNC_REL=' ' ! relative temporal truncation error tolerance -! forcing data -INTEGER(I4B) :: INFERN_START ! start of inference period -INTEGER(I4B) :: NTIM ! number of time steps -! model setup -INTEGER(I4B) :: FUSE_ID ! integer definining FUSE model -INTEGER(I4B) :: I,J,K ! looping -INTEGER(I4B) :: NMOD ! number of models -INTEGER(I4B) :: ERR ! error code -CHARACTER(LEN=256) :: MESSAGE ! error message -TYPE(PARATT) :: PARAM_META ! parameter metadata -! define output files -INTEGER(I4B) :: ONEMOD ! index for defining output file (one file per model) -! SCE variables -REAL(MSP), DIMENSION(16) :: A ! parameter set -REAL(MSP) :: AF ! objective function value -REAL(MSP), DIMENSION(16) :: BL ! lower bound of model parameters -REAL(MSP), DIMENSION(16) :: BU ! upper bound of model parameters -INTEGER(I4B) :: NOPT ! number of parameters to be optimized -INTEGER(I4B) :: MAXN ! maximum number of trials before optimization is terminated -INTEGER(I4B) :: KSTOP ! number of shuffling loops the value must change by PCENTO -REAL(MSP) :: PCENTO ! the percentage -INTEGER(I4B) :: ISEED ! starting seed for the random sequence -CHARACTER(LEN=3) :: CSEED ! starting seed converted to a character -INTEGER(I4B) :: NGS ! # complexes in the initial population -INTEGER(I4B) :: NPG ! # points in each complex -INTEGER(I4B) :: NPS ! # points in a sub-complex -INTEGER(I4B) :: NSPL ! # evolution steps allowed for each complex before shuffling -INTEGER(I4B) :: MINGS ! minimum number of complexes required -INTEGER(I4B) :: INIFLG ! 1 = include initial point in the population -INTEGER(I4B) :: IPRINT ! 0 = supress printing -INTEGER(I4B) :: ISCE ! unit number for SCE write -REAL(MSP) :: FUNCTN ! function name for the model run -! --------------------------------------------------------------------------------------- -! (1) GET COMMAND-LINE ARGUMENTS... -! --------------------------------------------------------------------------------------- -! read command-line arguments -CALL GETARG(1,FMODEL_ID) ! integer defining FUSE model -CALL GETARG(2,NSOLUTION) ! numerical solution (0=explicit, 1=implicit) -CALL GETARG(3,FADAPTIVE) ! identifier for adaptive sub-steps (0=fixed, 1=adaptive) -CALL GETARG(4,TRUNC_ABS) ! absolute temporal truncation error tolerance -CALL GETARG(5,TRUNC_REL) ! relative temporal truncation error tolerance -! check command-line arguments -IF (LEN_TRIM(FMODEL_ID).EQ.0) STOP '1st command-line argument is missing (FMODEL_ID)' -IF (LEN_TRIM(NSOLUTION).EQ.0) STOP '2nd command-line argument is missing (NSOLUTION)' -IF (LEN_TRIM(FADAPTIVE).EQ.0) STOP '3rd command-line argument is missing (FADAPTIVE)' -IF (LEN_TRIM(TRUNC_ABS).EQ.0) STOP '4th command-line argument is missing (TRUNC_ABS)' -IF (LEN_TRIM(TRUNC_REL).EQ.0) STOP '5th command-line argument is missing (TRUNC_REL)' -! read model numerix parameters -CALL GETNUMERIX() ! defines method/parameters used for numerical solution -! process command-line arguments -READ(FMODEL_ID,*) FUSE_ID ! integer definining FUSE model -READ(NSOLUTION,*) SOLUTION_METHOD ! numerical solution (0=implicit, 1=explicit) -READ(FADAPTIVE,*) TEMPORAL_ERROR_CONTROL ! identifier for adaptive sub-steps (0=fixed, 1=adaptive) -READ(TRUNC_ABS,*) ERR_TRUNC_ABS ! absolute temporal truncation error tolerance -READ(TRUNC_REL,*) ERR_TRUNC_REL ! relative temporal truncation error tolerance -! --------------------------------------------------------------------------------------- -! (2) GET MODEL SETUP -- MODEL DEFINITION, AND PARAMETER AND VARIABLE INFO FOR ALL MODELS -! --------------------------------------------------------------------------------------- -! Read data from the "BATEA-compliant" ASCII files -CALL GETFORCING(INFERN_START,NTIM) -! Define model attributes (valid for all models) -CALL UNIQUEMODL(NMOD) ! get nmod unique models -CALL GETPARMETA() ! parameter meta data (parameter bounds, etc.) -! Identify a single model -CALL SELECTMODL(FUSE_ID,ISTATUS=ERR,MESSAGE=MESSAGE) -IF (ERR.NE.0) THEN - PRINT *, TRIM(MESSAGE); STOP -ENDIF -! Define list of states and parameters for the current model -CALL ASSIGN_STT() ! state definitions are stored in module model_defn -CALL ASSIGN_FLX() ! flux definitions are stored in module model_defn -CALL ASSIGN_PAR() ! parameter defintions are stored in module multiparam -! Get parameter bounds and a default parameter set -IF (NUMPAR.GT.16) STOP ' NUMBER OF PARAMETERS MUST NOT EXCEED 16 IN SCE ' -DO I=1,NUMPAR - CALL GETPAR_STR(TRIM(LPARAM(I)%PARNAME),PARAM_META) - BL(I) = PARAM_META%PARLOW - BU(I) = PARAM_META%PARUPP - A(I) = PARAM_META%PARDEF -END DO -! -------------------------------------------------------------------------------------- -! -------------------------------------------------------------------------------------- -! -------------------------------------------------------------------------------------- -! loop through different starting seeds -DO ISEED=10,100,10 - ! get the seed as a character string - WRITE(CSEED,'(i3.3)') ISEED - ! -------------------------------------------------------------------------------------- - ! (3) DEFINE NETCDF OUTPUT FILES - ! -------------------------------------------------------------------------------------- - ! Define output file names - FNAME_NETCDF = TRIM(OUTPUT_PATH)//TRIM(SMODL%MNAME)//'__'//& - TRIM(NSOLUTION)//'-'//TRIM(FADAPTIVE)//'_SCE_'//CSEED//'.nc' ! shared in MODULE model_defn - FNAME_ASCII = TRIM(OUTPUT_PATH)//TRIM(SMODL%MNAME)//'__'//& - TRIM(NSOLUTION)//'-'//TRIM(FADAPTIVE)//'_SCE_'//CSEED//'.dat' ! shared in MODULE model_defn - ! Define NetCDF output files (only write parameters and summary statistics) - ONEMOD=1 ! one file per model (i.e., model dimension = 1) - PCOUNT=0 ! counter for parameter sets evaluated (shared in MODULE multistats) - CALL DEF_PARAMS(ONEMOD) ! define model parameters (initial CREATE) - !CALL DEF_OUTPUT(NTIM) ! define model output (REDEF) - CALL DEF_SSTATS() ! define summary statistics (REDEF) - ! -------------------------------------------------------------------------------------- - ! (4) SCE WRAPPER - ! -------------------------------------------------------------------------------------- - ! assign algorithmic control parameters for SCE - NOPT = NUMPAR ! number of parameters to be optimized (NUMPAR in module multiparam) - MAXN = 1000 ! maximum number of trials before optimization is terminated - KSTOP = 9 ! number of shuffling loops the value must change by PCENTO (MAX=9) - PCENTO = 0.001 ! the percentage - NGS = 10 ! number of complexes in the initial population - NPG = 2*NOPT + 1 ! number of points in each complex - NPS = NOPT + 1 ! number of points in a sub-complex - NSPL = 2*NOPT + 1 ! number of evolution steps allowed for each complex before shuffling - MINGS = NGS ! minimum number of complexes required - INIFLG = 1 ! 1 = include initial point in the population - IPRINT = 1 ! 0 = supress printing - ! open up ASCII output file - ISCE = 96; OPEN(ISCE,FILE=TRIM(FNAME_ASCII)) - ! optimize (returns A and AF) - CALL SCEUA(A,AF,BL,BU,NOPT,MAXN,KSTOP,PCENTO,ISEED,& - NGS,NPG,NPS,NSPL,MINGS,INIFLG,IPRINT,ISCE) - ! close ASCII output file - CLOSE(ISCE) - ! call the function again with the optimized parameter set (to ensure the last parameter set is the optimum( - AF = FUNCTN(NOPT,A) - ! -------------------------------------------------------------------------------------- -END DO ! looping through seeds -! --------------------------------------------------------------------------------------- -STOP -END diff --git a/build/FUSE_SRC/dshare/globaldata.f90 b/build/FUSE_SRC/share/globaldata.f90 similarity index 85% rename from build/FUSE_SRC/dshare/globaldata.f90 rename to build/FUSE_SRC/share/globaldata.f90 index 070d824..d0b66aa 100644 --- a/build/FUSE_SRC/dshare/globaldata.f90 +++ b/build/FUSE_SRC/share/globaldata.f90 @@ -25,7 +25,11 @@ MODULE globaldata logical(lgt), save :: isPrint=.true. logical(lgt), save :: isDebug=.false. - ! snow parameters + ! indices of forcing variables in vectors + integer(i4b), parameter :: NVAR_FORC=4 + integer(i4b), parameter :: iPRECIP=1, iTEMP=2, iPET=3, iQOBS=4 + + ! indices of snow parameters in vectors integer(i4b), parameter :: NPAR_SNOW=7 integer(i4b), parameter :: iMBASE=1, iMFMAX=2, iMFMIN=3, iPXTEMP=4, iOPG=5, iLAPSE=6 ! indices in vectors integer(i4b), parameter :: iPERR=7 ! not a snow parameter, but used here diff --git a/build/FUSE_SRC/share/model_defn_data.f90 b/build/FUSE_SRC/share/model_defn_data.f90 new file mode 100644 index 0000000..3b85981 --- /dev/null +++ b/build/FUSE_SRC/share/model_defn_data.f90 @@ -0,0 +1,56 @@ +MODULE model_defn + + ! --------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark + ! Modified by Brian Henn to include snow model, 6/2013 + ! Modified by Martyn Clark to separate type definitions from data storage, 01/2026 + ! --------------------------------------------------------------------------------------- + + USE nrtype + USE model_defn_types, only: DESC, UMODEL, SNAMES, FNAMES + + USE globaldata, only: FUSE_VERSION + + implicit none + private + + public :: NDEC, NTDH_MAX, NSTATE, N_FLUX + public :: LIST_RFERR, LIST_ARCH1, LIST_ARCH2, LIST_QSURF, LIST_QPERC, LIST_ESOIL, LIST_QINTF, LIST_Q_TDH, LIST_SNOWM + public :: FNAME_PREFIX, FNAME_TEMPRY, FNAME_ASCII + public :: FNAME_NETCDF_RUNS, FNAME_NETCDF_PARA, FNAME_NETCDF_PARA_SCE, FNAME_NETCDF_PARA_PRE + public :: AMODL, SMODL, CSTATE, C_FLUX + + ! list of combinations in each model component + INTEGER, PARAMETER :: NDEC = 9 ! number of model decisions + TYPE(DESC), DIMENSION(2) :: LIST_RFERR ! rainfall error + TYPE(DESC), DIMENSION(3) :: LIST_ARCH1 ! upper-layer architecture + TYPE(DESC), DIMENSION(4) :: LIST_ARCH2 ! lower-layer architecture + TYPE(DESC), DIMENSION(3) :: LIST_QSURF ! surface runoff + TYPE(DESC), DIMENSION(3) :: LIST_QPERC ! percolation + TYPE(DESC), DIMENSION(2) :: LIST_ESOIL ! evaporation + TYPE(DESC), DIMENSION(2) :: LIST_QINTF ! interflow + TYPE(DESC), DIMENSION(2) :: LIST_Q_TDH ! time delay in runoff + TYPE(DESC), DIMENSION(2) :: LIST_SNOWM ! snow model + + ! max steps in routing function + INTEGER(I4B),PARAMETER::NTDH_MAX=500 + + ! model definitions + CHARACTER(LEN=256) :: FNAME_NETCDF_RUNS ! NETCDF output filename for model runs + CHARACTER(LEN=256) :: FNAME_NETCDF_PARA ! NETCDF output filename for model parameters + CHARACTER(LEN=256) :: FNAME_NETCDF_PARA_SCE ! NETCDF output filename for model parameters produced by SCE + CHARACTER(LEN=256) :: FNAME_NETCDF_PARA_PRE ! NETCDF filename for pre-defined model parameters set + CHARACTER(LEN=256) :: FNAME_PREFIX ! prefix for desired output files + CHARACTER(LEN=256) :: FNAME_TEMPRY ! prefix for temporary output files + CHARACTER(LEN=256) :: FNAME_ASCII ! ASCII output filename + TYPE(UMODEL),DIMENSION(5000) :: AMODL ! (model definition -- all) + TYPE(UMODEL) :: SMODL ! (model definition -- single model) + TYPE(SNAMES),DIMENSION(7) :: CSTATE ! (list of model states for SMODL) + TYPE(FNAMES),DIMENSION(50) :: C_FLUX ! (list of model fluxes for SMODL) + INTEGER(I4B) :: NSTATE=0 ! number of model states + INTEGER(I4B) :: N_FLUX=0 ! number of model fluxes + ! -------------------------------------------------------------------------------------- + +END MODULE model_defn diff --git a/build/FUSE_SRC/dshare/model_defnames.f90 b/build/FUSE_SRC/share/model_defnames.f90 similarity index 100% rename from build/FUSE_SRC/dshare/model_defnames.f90 rename to build/FUSE_SRC/share/model_defnames.f90 diff --git a/build/FUSE_SRC/dshare/model_numerix.f90 b/build/FUSE_SRC/share/model_numerix.f90 similarity index 96% rename from build/FUSE_SRC/dshare/model_numerix.f90 rename to build/FUSE_SRC/share/model_numerix.f90 index 8aefa42..030073e 100644 --- a/build/FUSE_SRC/dshare/model_numerix.f90 +++ b/build/FUSE_SRC/share/model_numerix.f90 @@ -30,6 +30,9 @@ MODULE model_numerix ! 6. Method used to process the small interval at the end of a time step INTEGER(I4B), PARAMETER :: STEP_TRUNC=0, LOOK_AHEAD=1, STEP_ABSORB=2 INTEGER(I4B) :: SMALL_ENDSTEP +! 7. Flag for differentiable model +integer(i4b), parameter :: original=0, differentiable=1 +integer(i4b) :: diff_mode ! --------------------------------------------------------------------------------------- ! (B) PARAMETERS ! --------------------------------------------------------------------------------------- diff --git a/build/FUSE_SRC/share/multi_flux_data.f90 b/build/FUSE_SRC/share/multi_flux_data.f90 new file mode 100644 index 0000000..9673397 --- /dev/null +++ b/build/FUSE_SRC/share/multi_flux_data.f90 @@ -0,0 +1,22 @@ +MODULE multi_flux + + USE nrtype + + USE multi_flux_types, only: FLUXES + + implicit none + private + + public :: M_FLUX, FLUX_0, FLUX_1, FDFLUX, W_FLUX, W_FLUX_3d + public :: CURRENT_DT + + TYPE(FLUXES) :: M_FLUX ! model fluxes + TYPE(FLUXES) :: FLUX_0 ! model fluxes at start of step + TYPE(FLUXES) :: FLUX_1 ! model fluxes at end of step + TYPE(FLUXES), DIMENSION(:), POINTER :: FDFLUX=>NULL() ! finite difference fluxes + TYPE(FLUXES) :: W_FLUX ! weighted sum of model fluxes over a time step + TYPE(FLUXES), dimension(:,:,:), allocatable :: W_FLUX_3d ! weighted sum of model fluxes over a time step for several time steps + + REAL(SP) :: CURRENT_DT ! current time step (days) + +END MODULE multi_flux diff --git a/build/FUSE_SRC/share/multibands_data.f90 b/build/FUSE_SRC/share/multibands_data.f90 new file mode 100644 index 0000000..7fa4406 --- /dev/null +++ b/build/FUSE_SRC/share/multibands_data.f90 @@ -0,0 +1,30 @@ +MODULE multibands + + ! Created by Brian Henn to allow multi-band snow modeling, 6/2013 + ! Based on module MULTIFORCE by Martyn Clark + + ! Modified by Martyn Clark to separate type definitions from data storage, 01/2026 + + USE nrtype + + USE multibands_types, only: BANDS, BANDS_INFO, BANDS_VAR + + implicit none + private + + public :: N_BANDS + public :: MBANDS, MBANDS_INFO_3d, MBANDS_VAR_4d + public :: Z_FORCING, Z_FORCING_grid, elev_mask + + ! -------------------------------------------------------------------------------------- + TYPE(BANDS),DIMENSION(:),ALLOCATABLE :: MBANDS ! basin band information + type(BANDS_INFO),dimension(:,:,:),ALLOCATABLE :: MBANDS_INFO_3d ! basin band information in space + type(BANDS_VAR),dimension(:,:,:,:),ALLOCATABLE :: MBANDS_VAR_4d ! basin band information in space plus time + + INTEGER(I4B) :: N_BANDS=0 ! number of bands, initialize to zero + REAL(SP) :: Z_FORCING ! elevation of forcing data (m) + REAL(SP),DIMENSION(:,:),ALLOCATABLE :: Z_FORCING_grid ! elevation of forcing data (m) for the 2D domain + LOGICAL(LGT),DIMENSION(:,:),ALLOCATABLE :: elev_mask ! mask domain - TRUE means the cell must be masked, i.e. not run + ! -------------------------------------------------------------------------------------- + +END MODULE multibands diff --git a/build/FUSE_SRC/dshare/multiconst.f90 b/build/FUSE_SRC/share/multiconst.f90 similarity index 100% rename from build/FUSE_SRC/dshare/multiconst.f90 rename to build/FUSE_SRC/share/multiconst.f90 diff --git a/build/FUSE_SRC/share/multiforce_data.f90 b/build/FUSE_SRC/share/multiforce_data.f90 new file mode 100644 index 0000000..68207a5 --- /dev/null +++ b/build/FUSE_SRC/share/multiforce_data.f90 @@ -0,0 +1,181 @@ +MODULE multiforce + + ! --------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark + ! Modified by Brian Henn to include snow model, 6/2013 + ! Modified by Nans Addor to enable distributed modeling, 9/2016 + ! Modified by Cyril Thébault to allow different metrics as objective function, 2024 + ! Modified by Martyn Clark to separate type definitions from data storage, 01/2026 + ! --------------------------------------------------------------------------------------- + + USE nrtype + + USE multiforce_types, only: TDATA, VDATA, ADATA, FDATA + + implicit none + private + + public :: forcefile + + public :: ncid_forc, ncid_var + + public :: nForce, nInput + + public :: timDat, valDat, aValid + public :: AFORCE, CFORCE, MFORCE + public :: ancilF, ancilF_3d + public :: gForce, gForce_3d + + public :: date_start_input, date_end_input + public :: numtim_in, numtim_sim, numtim_sub + public :: sim_beg, sim_end, eval_beg, eval_end + public :: istart, jdayRef + public :: deltim + + public :: SUB_PERIODS_FLAG, GRID_FLAG + + public :: startSpat2, nSpat1, nSpat2 + public :: xlon, ylat, latitude, longitude + public :: latUnits, lonUnits, timeUnits + + public :: time_steps, julian_day_input + + public :: NUMPSET, name_psets + + public :: vname_iy, vname_im, vname_id, vname_ih, vname_imin, vname_dsec, vname_dtime + + public :: vname_aprecip, vname_potevap, vname_airtemp, vname_q, vname_spechum, vname_airpres, vname_swdown + public :: ilook_aprecip, ilook_potevap, ilook_airtemp, ilook_q, ilook_spechum, ilook_airpres, ilook_swdown + + public :: ivarid_iy, ivarid_im, ivarid_id, ivarid_ih, ivarid_imin, ivarid_dsec + public :: ivarid_ppt, ivarid_temp, ivarid_pet, ivarid_q + + public :: amult_ppt, amult_pet, amult_q + + public :: NA_VALUE, NA_VALUE_SP + + SAVE + + ! general + INTEGER(I4B),PARAMETER :: STRLEN=256 ! length of the character string + + ! time data structures + TYPE(tData) :: timDat ! model time structure + + ! response data structures + TYPE(vData) :: valDat ! validation structure + TYPE(vData), allocatable :: aValid(:,:,:) ! all model validation data + + ! forcing data structures + TYPE(FDATA), allocatable :: AFORCE(:) ! all model forcing data + TYPE(FDATA), allocatable :: CFORCE(:) ! COPY of model forcing data + TYPE(FDATA) :: MFORCE ! model forcing data for a single time step + + TYPE(aData), allocatable :: ancilF(:,:) ! ancillary forcing data for the 2-d grid + TYPE(fData), allocatable :: gForce(:,:) ! model forcing data for a 2-d grid + TYPE(fData), allocatable :: gForce_3d(:,:,:) ! model forcing data for a 3-d grid (time as 3rd dimension) + TYPE(aData), allocatable :: ancilF_3d(:,:,:) ! ancillary forcing data for the 3-d grid + + ! NetCDF + + CHARACTER(len=StrLen) :: forcefile = 'undefined' ! name of forcing file + + INTEGER(i4b), PARAMETER :: nForce = 7 ! number of forcing variables + INTEGER(i4b) :: nInput = 3 ! number of variable to retrieve from input file + + INTEGER(i4b) :: ncid_forc = -1 ! NetCDF forcing file ID + INTEGER(i4b), DIMENSION(nForce) :: ncid_var ! NetCDF forcing variable ID + + ! timing information - note that numtim_in >= numtim_sim >= numtim_sub + + CHARACTER(len=20) :: date_start_input ! date start input time series + CHARACTER(len=20) :: date_end_input ! date end input time series + + INTEGER(i4b) :: numtim_in = -1 ! number of time steps of input (atmospheric forcing) + INTEGER(i4b) :: numtim_sim = -1 ! number of time steps of FUSE simulations (including spin-up) + INTEGER(i4b) :: numtim_sub = -1 ! number of time steps of subperiod (will be kept in memory) + + INTEGER(i4b) :: sim_beg = -1 ! index for the start of the simulation in fuse_metric + INTEGER(i4b) :: sim_end = -1 ! index for the end of the simulation in fuse_metric + INTEGER(i4b) :: eval_beg = -1 ! index for the start of evaluation period + INTEGER(i4b) :: eval_end = -1 ! index for the end of the inference period + + INTEGER(i4b) :: istart = -1 ! index for start of inference period (in reduced array) + REAL(sp) :: jdayRef ! reference time (days) + REAL(sp) :: deltim = -1._dp ! length of time step (days) + + LOGICAL(LGT) :: SUB_PERIODS_FLAG ! .true. if subperiods are used to run FUSE + LOGICAL(LGT) :: GRID_FLAG ! spatial flag .true. if grid + + ! dimension information + + INTEGER(i4b) :: startSpat2 = -1 ! number of points in 1st spatial dimension + INTEGER(i4b) :: nSpat1 = -1 ! number of points in 1st spatial dimension + INTEGER(i4b) :: nSpat2 = -1 ! number of points in 2nd spatial dimension + REAL(sp) :: xlon ! longitude (degrees) for PET computation + REAL(sp) :: ylat ! latitude (degrees) for PET computation + REAL(sp),dimension(:),allocatable :: latitude ! latitude (degrees) + REAL(sp),dimension(:),allocatable :: longitude ! longitude (degrees) + CHARACTER(len=strLen) :: latUnits ! units string for latitude + CHARACTER(len=strLen) :: lonUnits ! units string for longitude + CHARACTER(len=strLen) :: timeUnits ! units string for time + + REAL(sp),dimension(:),allocatable :: time_steps ! time steps (days) + REAL(sp),dimension(:),allocatable :: julian_day_input ! time steps (julian days) + + INTEGER(I4B) :: NUMPSET ! number of parameter sets + CHARACTER(len=strLen),dimension(:),allocatable :: name_psets ! name of parameter sets + + ! name of time variables + CHARACTER(len=StrLen) :: vname_iy = 'undefined' ! name of variable for year + CHARACTER(len=StrLen) :: vname_im = 'undefined' ! name of variable for month + CHARACTER(len=StrLen) :: vname_id = 'undefined' ! name of variable for day + CHARACTER(len=StrLen) :: vname_ih = 'undefined' ! name of variable for hour + CHARACTER(len=StrLen) :: vname_imin = 'undefined' ! name of variable for minute + CHARACTER(len=StrLen) :: vname_dsec = 'undefined' ! name of variable for second + CHARACTER(len=StrLen) :: vname_dtime = 'undefined' ! name of variable for time + + ! forcing variable names + CHARACTER(len=StrLen) :: vname_aprecip = 'undefined' ! variable name: precipitation + CHARACTER(len=StrLen) :: vname_potevap = 'undefined' ! variable name: potential ET + CHARACTER(len=StrLen) :: vname_airtemp = 'undefined' ! variable name: temperature + CHARACTER(len=StrLen) :: vname_q = 'undefined' ! variable name: observed runoff + CHARACTER(len=StrLen) :: vname_spechum = 'undefined' ! variable name: specific humidity + CHARACTER(len=StrLen) :: vname_airpres = 'undefined' ! variable name: surface pressure + CHARACTER(len=StrLen) :: vname_swdown = 'undefined' ! variable name: downward shortwave radiation + + ! indices for forcing variables + INTEGER(i4b),PARAMETER :: ilook_aprecip = 1 ! named element in lCheck + INTEGER(i4b),PARAMETER :: ilook_potevap = 2 ! named element in lCheck + INTEGER(i4b),PARAMETER :: ilook_airtemp = 3 ! named element in lCheck + INTEGER(i4b),PARAMETER :: ilook_q = 4 ! named element in lCheck + INTEGER(i4b),PARAMETER :: ilook_spechum = 5 ! named element in lCheck + INTEGER(i4b),PARAMETER :: ilook_airpres = 6 ! named element in lCheck + INTEGER(i4b),PARAMETER :: ilook_swdown = 7 ! named element in lCheck + + ! indices for time data (only used in ASCII files) + INTEGER(i4b) :: ivarid_iy = -1 ! variable ID for year + INTEGER(i4b) :: ivarid_im = -1 ! variable ID for month + INTEGER(i4b) :: ivarid_id = -1 ! variable ID for day + INTEGER(i4b) :: ivarid_ih = -1 ! variable ID for hour + INTEGER(i4b) :: ivarid_imin = -1 ! variable ID for minute + INTEGER(i4b) :: ivarid_dsec = -1 ! variable ID for second + + ! indices for variables + INTEGER(i4b) :: ivarid_ppt = -1 ! variable ID for precipitation + INTEGER(i4b) :: ivarid_temp = -1 ! variable ID for temperature + INTEGER(i4b) :: ivarid_pet = -1 ! variable ID for potential ET + INTEGER(i4b) :: ivarid_q = -1 ! variable ID for runoff + + ! multipliers for variables to convert fluxes to mm/day + REAL(sp) :: amult_ppt = -1._dp ! convert precipitation to mm/day + REAL(sp) :: amult_pet = -1._dp ! convert potential ET to mm/day + REAL(sp) :: amult_q = -1._dp ! convert runoff to mm/day + + ! missing values + INTEGER(I4B),PARAMETER :: NA_VALUE = -9999 ! integer designating missing values - TODO: retrieve from NetCDF file + REAL(SP),PARAMETER :: NA_VALUE_SP = -9999._sp ! integer designating missing values - TODO: retrieve from NetCDF file + +END MODULE multiforce diff --git a/build/FUSE_SRC/share/multiparam_data.f90 b/build/FUSE_SRC/share/multiparam_data.f90 new file mode 100644 index 0000000..4de449a --- /dev/null +++ b/build/FUSE_SRC/share/multiparam_data.f90 @@ -0,0 +1,42 @@ +MODULE multiparam + + ! --------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark + ! Modified by Brian Henn to include snow model, 6/2013 + ! Modified by Martyn Clark to separate type definitions from data storage, 01/2026 + ! --------------------------------------------------------------------------------------- + + USE nrtype + USE multiparam_types, only: PARATT ! included for legacy for routines that USE multiparam + USE multiparam_types, only: PARADJ, PARDVD, PARINFO, PAR_ID + + implicit none + private + + public :: PARATT, PARADJ, PARDVD, PARINFO, PAR_ID + + public :: MAXPAR, NUMPAR + public :: APARAM, MPARAM, DPARAM + public :: PARMETA, LPARAM + public :: MAXN, KSTOP, PCENTO + public :: SOBOL_INDX + + INTEGER(I4B), PARAMETER :: MAXPAR=50 ! maximum number of parameters for a single model + INTEGER(I4B) :: NUMPAR ! number of model parameters for current model + + TYPE(PARADJ), DIMENSION(:), POINTER :: APARAM=>null() ! all model parameter sets; DK/2008/10/21: explicit null + TYPE(PARADJ) :: MPARAM ! single model parameter set + TYPE(PARDVD) :: DPARAM ! derived model parameters + + TYPE(PARINFO) :: PARMETA ! parameter metadata (all parameters) + TYPE(PAR_ID), DIMENSION(MAXPAR) :: LPARAM ! list of model parameter names (need to modify to 16 for SCE) + + integer(i4b) :: MAXN ! maximum number of trials before optimization is terminated + integer(i4b) :: KSTOP ! number of shuffling loops the value must change by PCENTO + REAL(MSP) :: PCENTO ! the percentage + + INTEGER(I4B) :: SOBOL_INDX ! code to re-assemble Sobol parameters + +END MODULE multiparam diff --git a/build/FUSE_SRC/share/multiroute_data.f90 b/build/FUSE_SRC/share/multiroute_data.f90 new file mode 100644 index 0000000..e1f3111 --- /dev/null +++ b/build/FUSE_SRC/share/multiroute_data.f90 @@ -0,0 +1,20 @@ +MODULE multiroute + + USE nrtype + USE model_defn,ONLY:NTDH_MAX + USE multiroute_types, only: RUNOFF + + implicit none + private + + public :: FUTURE + public :: AROUTE, AROUTE_3d + public :: MROUTE + + REAL(SP), DIMENSION(NTDH_MAX) :: FUTURE ! runoff placed in future time steps + + TYPE(RUNOFF), DIMENSION(:), POINTER :: AROUTE ! runoff for all time steps + TYPE(RUNOFF),dimension(:,:,:), allocatable :: AROUTE_3d ! runoff for all time steps on a grid + TYPE(RUNOFF) :: MROUTE ! runoff for one time step + +END MODULE multiroute diff --git a/build/FUSE_SRC/share/multistate_data.f90 b/build/FUSE_SRC/share/multistate_data.f90 new file mode 100644 index 0000000..ce1c1ec --- /dev/null +++ b/build/FUSE_SRC/share/multistate_data.f90 @@ -0,0 +1,44 @@ +MODULE multistate + + USE nrtype + USE multistate_types, only: STATEV, M_TIME + + implicit none + private + + public :: STATEV, M_TIME + + public :: gState, gState_3d + + public :: ASTATE, FSTATE, MSTATE, TSTATE, BSTATE, ESTATE, DSTATE + public :: DYDT_0, DYDT_1, DY_DT, DYDT_OLD + public :: HSTATE + + public :: ncid_out + public :: fracState0 + + ! variable definitions (grid) + type(statev),dimension(:,:),pointer :: gState ! (grid of model states) + type(statev),dimension(:,:,:),pointer :: gState_3d ! (grid of model states with a time dimension) + + ! variable definitions (one cell) + TYPE(STATEV) :: ASTATE ! (model states at the start of full timestep) + TYPE(STATEV) :: FSTATE ! (model states at start of sub-timestep) + TYPE(STATEV) :: MSTATE ! (model states at start/middle of sub-timestep) + TYPE(STATEV) :: TSTATE ! (temporary copy of model states) + TYPE(STATEV) :: BSTATE ! (temporary copy of model states) + TYPE(STATEV) :: ESTATE ! (temporary copy of model states) + TYPE(STATEV) :: DSTATE ! (default model states) + TYPE(STATEV) :: DYDT_0 ! (derivative of model states at start of sub-step) + TYPE(STATEV) :: DYDT_1 ! (derivative of model states at end of sub-step) + TYPE(STATEV) :: DY_DT ! (derivative of model states) + TYPE(STATEV) :: DYDT_OLD ! (derivative of model states for final solution) + TYPE(M_TIME) :: HSTATE ! (time interval to advance model states) + + ! NetCDF + integer(i4b) :: ncid_out = -1 ! NetCDF output file ID + + ! initial store fraction (initialization) + real(sp), parameter :: fracState0 = 0.25_sp + +END MODULE multistate diff --git a/build/FUSE_SRC/share/multistats_data.f90 b/build/FUSE_SRC/share/multistats_data.f90 new file mode 100644 index 0000000..4008e09 --- /dev/null +++ b/build/FUSE_SRC/share/multistats_data.f90 @@ -0,0 +1,16 @@ +MODULE multistats + + USE nrtype + USE multistats_types, only: SUMMARY + + implicit none + private + + public :: MSTATS, MOD_IX, PCOUNT, FCOUNT + + TYPE(SUMMARY) :: MSTATS ! (model summary statistics) + INTEGER(I4B) :: MOD_IX = 1 ! (model index) + INTEGER(I4B) :: PCOUNT ! (number of parameter sets in model output files) + INTEGER(I4B) :: FCOUNT ! (number of model simulations) + +END MODULE multistats diff --git a/build/FUSE_SRC/types/data_types.f90 b/build/FUSE_SRC/types/data_types.f90 new file mode 100644 index 0000000..9d2d239 --- /dev/null +++ b/build/FUSE_SRC/types/data_types.f90 @@ -0,0 +1,77 @@ +module data_types + + use nrtype + + use multiforce_types, only: ADATA, FDATA, VDATA + use multibands_types, only: BANDS_INFO, BANDS_VAR + use multistate_types, only: STATEV + use multi_flux_types, only: FLUXES + use multiroute_types, only: RUNOFF + + private + public :: coord_data, domain_data + + ! ------------------------------------------------------------------------------------- + + type :: coord_data + + logical(lgt) :: is_curvilinear = .false. ! true if lat/lon are 2D + logical(lgt) :: is_point_list = .false. ! true if nx=1 and lat/lon are 1D over ny + + ! 2D rectilinear OR point-list + real(sp), allocatable :: lon_1d(:) ! nx or ny depending on layout + real(sp), allocatable :: lat_1d(:) + + ! 2D curvilinear + real(sp), allocatable :: lon_2d(:,:) ! (nx_local, ny_local) + real(sp), allocatable :: lat_2d(:,:) + + ! optional IDs (int is usually safest) + integer(i4b), allocatable :: cell_id(:,:) ! always stored locally as (nx_local, ny_local) + + end type coord_data + + ! ------------------------------------------------------------------------------------- + + type :: domain_data + + ! coordinate information + type(coord_data) :: coords + + ! 2D ancillary forcing (optional, for PET etc.) + type(ADATA), allocatable :: ancil(:,:) ! (nx_local, ny_local) + + ! 3D forcing window + type(FDATA), allocatable :: force(:,:,:) ! gForce_3d (nx_local, ny_local, nt_window) + + ! 3D state window + type(STATEV), allocatable :: state(:,:,:) ! gState_3d (nx_local, ny_local, nt_window+1) + + ! 3D flux window + type(FLUXES), allocatable :: flux(:,:,:) ! w_flux_3d (nx_local, ny_local, nt_window) + + ! 3D routing window + type(RUNOFF), allocatable :: route(:,:,:) ! AROUTE_3d (nx_local, ny_local, nt_window) + + ! 2D elevation information + logical(lgt), allocatable :: elev_mask(:,:) ! elev_mask (nx_local, ny_local) + real(sp), allocatable :: z_forcing(:,:) ! Z_FORCING_grid (nx_local, ny_local) + + ! 3D snow-band information + type(BANDS_INFO), allocatable :: bands_info(:,:,:) ! MBANDS_INFO_3d (nx_local, ny_local, n_bands) + + ! 4D snow-band state window + type(BANDS_VAR), allocatable :: bands_var(:,:,:,:) ! MBANDS_VAR_4d (nx_local, ny_local, n_bands, nt_window+1) + + ! 3D observed discharge / validity (optional) + type(VDATA), allocatable :: valid(:,:,:) ! aValid (nx_local, ny_local, nt_window) + + ! basin-average time series for output convenience + type(FDATA), allocatable :: aForce(:) ! (nt_window) + type(RUNOFF), allocatable :: aRoute(:) ! (nt_window) + + end type domain_data + + ! ------------------------------------------------------------------------------------- + +end module data_types diff --git a/build/FUSE_SRC/types/info_types.f90 b/build/FUSE_SRC/types/info_types.f90 new file mode 100644 index 0000000..59787ec --- /dev/null +++ b/build/FUSE_SRC/types/info_types.f90 @@ -0,0 +1,218 @@ +module info_types + + use nrtype + + use multiparam_types, only: par_id + + private + public :: cli_options + public :: time_info + public :: space_info + public :: fuse_info + + ! -------------------------------------------------------------------------------------- + + type :: mpi_info + logical(lgt) :: enabled = .false. + integer(i4b) :: rank = 0 + integer(i4b) :: nproc = 1 + end type mpi_info + + ! ------------------------------------------------------------------------------------- + + ! options for the command-line interface + + type :: cli_options + character(len=:), allocatable :: tag ! string to add to output file + character(len=:), allocatable :: control_file + character(len=:), allocatable :: domain_id + character(len=:), allocatable :: runmode ! def/idx/opt/sce + character(len=:), allocatable :: sets_file ! for idx,opt + integer(i4b) :: indx = -1 ! for idx + character(len=:), allocatable :: restart_freq ! y/m/d/e/never + logical(lgt) :: show_version = .false. + logical(lgt) :: show_help = .false. + character(len=:), allocatable :: param_name(:) ! list of parameter names + real(sp), allocatable :: param_value(:) ! list of parameter values + end type cli_options + + ! ------------------------------------------------------------------------------------- + + type :: space_info + + ! global dimensions (full forcing file) + integer(i4b) :: nx_global = 1 + integer(i4b) :: ny_global = 1 + + ! local dimensions (after MPI split) + integer(i4b) :: nx_local = 1 + integer(i4b) :: ny_local = 1 + + ! decomposition along y dimension + integer(i4b) :: y_start_global = 1 + integer(i4b) :: y_end_global = 1 + + ! mode flag + logical(lgt) :: grid_flag = .false. + + end type space_info + + ! ------------------------------------------------------------------------------------- + + type :: time_info + + ! forcing axis (global) + integer(i4b) :: nt_global = 0 + + ! simulation & evaluation indices into forcing time axis + integer(i4b) :: sim_beg = 1 + integer(i4b) :: sim_end = 1 + integer(i4b) :: eval_beg = 1 + integer(i4b) :: eval_end = 1 + + ! derived lengths + integer(i4b) :: nt_sim = 0 + + ! subperiod / windowing + logical(lgt) :: use_subperiods = .false. + integer(i4b) :: nt_window = 0 ! (= numtim_sub) + integer(i4b) :: nt_window_cur = 0 ! runtime: current window length + + ! bookkeeping for time axis + character(len=:), allocatable :: units + real(sp) :: jdate_ref = 0._sp + real(sp), allocatable :: time_steps(:) ! time since reference time (transferred to output) + real(sp), allocatable :: jdate(:) ! julian day for each forcing record + + real(sp) :: deltim_days ! forcing time step in units of days + + end type time_info + + ! ------------------------------------------------------------------------------------- + + type :: snow_info + integer(i4b) :: n_bands = 0 + end type snow_info + + ! ------------------------------------------------------------------------------------- + + ! --- forcing_vars used in file_info + + type :: forcing_vars + character(len=64), allocatable :: name(:) ! NFORC + integer(i4b), allocatable :: varid(:) ! NFORC + end type + + ! --- + + type :: file_info + + ! directories + character(len=:), allocatable :: setngs_path + character(len=:), allocatable :: input_path + character(len=:), allocatable :: output_path + + ! settings filenames + character(len=:), allocatable :: forcinginfo + character(len=:), allocatable :: constraints + character(len=:), allocatable :: mod_numerix + character(len=:), allocatable :: m_decisions + + ! domain-derived input suffixes + character(len=:), allocatable :: suffix_forcing + character(len=:), allocatable :: suffix_elev_bands + + ! actual input filenames for this domain (derived once dom_id known) + character(len=512) :: forcing_file ! dom_id//suffix_forcing + character(len=512) :: elevbands_file ! dom_id//suffix_elev_bands + + ! output base name + concrete outputs + character(len=512) :: fname_tempry + character(len=512) :: fname_netcdf_forc + character(len=512) :: fname_netcdf_runs + character(len=512) :: fname_netcdf_para + + ! NetCDF forcing file info + integer(i4b) :: ncid_forc = -9999 ! NetCDF file ID for forcing data + + character(len=:), allocatable :: time_name ! name of coordinate variables + character(len=:), allocatable :: latitude_name ! name of coordinate variables + character(len=:), allocatable :: longitude_name ! name of coordinate variables + + character(len=:), allocatable :: precip_name ! name of forcing variables + character(len=:), allocatable :: temp_name ! name of forcing variables + character(len=:), allocatable :: pet_name ! name of forcing variables + character(len=:), allocatable :: qobs_name ! name of forcing variables + + type(forcing_vars) :: forc ! name/varid table + + end type file_info + + ! ------------------------------------------------------------------------------------- + + type :: run_config + + ! provenance + character(len=512) :: file_manager_file = "" + + ! CLI options + type(cli_options) :: cli_opts + + ! model selection + character(len=:), allocatable :: fmodel_id + + ! model information + integer(i4b) :: nState = -9999 + integer(i4b) :: nParam = -9999 + + ! number of input variables (3 = ppt, temp, pet; 4 = + obsq) + integer(i4b) :: nInput + + ! list of model parameters + type(par_id), allocatable :: listParam(:) + + ! run flags + logical(lgt) :: q_only = .false. + + ! requested time windows (strings as read from filemanager) + character(len=:), allocatable :: date_start_sim + character(len=:), allocatable :: date_end_sim + character(len=:), allocatable :: date_start_eval + character(len=:), allocatable :: date_end_eval + character(len=:), allocatable :: numtim_sub_str + + ! parsed / derived values (optional convenience) + integer(i4b) :: numtim_sub = -9999 ! parsed from numtim_sub_str + + ! output dimension for number of parameter sets + integer(i4b) :: nSets + + ! calibration metrics and metric transformations + character(len=:), allocatable :: metric + character(len=:), allocatable :: transfo + + ! SCE settings (store as numeric types) + integer(i4b) :: maxn = -9999 + integer(i4b) :: kstop = -9999 + real(sp) :: pcento = -9999._sp + + ! store raw strings too + character(len=20) :: maxn_str = "" + character(len=20) :: kstop_str = "" + character(len=20) :: pcento_str = "" + + end type run_config + + ! ------------------------------------------------------------------------------------- + ! ------------------------------------------------------------------------------------- + + type :: fuse_info + type(mpi_info) :: mpi + type(space_info) :: space + type(time_info) :: time + type(snow_info) :: snow + type(file_info) :: files + type(run_config) :: config + end type fuse_info + +end module info_types diff --git a/build/FUSE_SRC/types/model_defn_types.f90 b/build/FUSE_SRC/types/model_defn_types.f90 new file mode 100644 index 0000000..a22acf9 --- /dev/null +++ b/build/FUSE_SRC/types/model_defn_types.f90 @@ -0,0 +1,48 @@ +MODULE model_defn_types + + ! --------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark + ! Modified by Brian Henn to include snow model, 6/2013 + ! Modified by Martyn Clark to separate data tyoes from data store, 01/2026 + ! --------------------------------------------------------------------------------------- + + USE nrtype + + implicit none + private + + public :: DESC, UMODEL, SNAMES, FNAMES + + ! description of model component + TYPE DESC + CHARACTER(LEN=16) :: MCOMPONENT ! description of model component + END TYPE DESC + + ! structure that holds (x) unique combinations + TYPE UMODEL + INTEGER(I4B) :: MODIX ! model index + CHARACTER(LEN=256) :: MNAME ! model name + INTEGER(I4B) :: iRFERR + INTEGER(I4B) :: iARCH1 + INTEGER(I4B) :: iARCH2 + INTEGER(I4B) :: iQSURF + INTEGER(I4B) :: iQPERC + INTEGER(I4B) :: iESOIL + INTEGER(I4B) :: iQINTF + INTEGER(I4B) :: iQ_TDH + INTEGER(I4B) :: iSNOWM ! snow + END TYPE UMODEL + + ! structure to hold model state names + TYPE SNAMES + INTEGER(I4B) :: iSNAME ! integer value of state name + END TYPE SNAMES + + ! structure to hold model flux names + TYPE FNAMES + CHARACTER(LEN=16) :: FNAME ! state name + END TYPE FNAMES + +END MODULE model_defn_types diff --git a/build/FUSE_SRC/dshare/multi_flux.f90 b/build/FUSE_SRC/types/multi_flux_types.f90 similarity index 82% rename from build/FUSE_SRC/dshare/multi_flux.f90 rename to build/FUSE_SRC/types/multi_flux_types.f90 index b3c884f..c4411f4 100644 --- a/build/FUSE_SRC/dshare/multi_flux.f90 +++ b/build/FUSE_SRC/types/multi_flux_types.f90 @@ -1,5 +1,12 @@ -MODULE multi_flux +MODULE multi_flux_types + USE nrtype + + implicit none + private + + public :: FLUXES + TYPE FLUXES REAL(SP) :: EFF_PPT ! effective precipitation (mm day-1) REAL(SP) :: SATAREA ! saturated area (-) @@ -32,11 +39,5 @@ MODULE multi_flux REAL(SP) :: ERR_FREE_2B ! excessive extrapolation: storage in the secondary resvr (mm day-1) REAL(SP) :: CHK_TIME ! time elapsed during time step (days) ENDTYPE FLUXES - TYPE(FLUXES) :: M_FLUX ! model fluxes - TYPE(FLUXES) :: FLUX_0 ! model fluxes at start of step - TYPE(FLUXES) :: FLUX_1 ! model fluxes at end of step - TYPE(FLUXES), DIMENSION(:), POINTER :: FDFLUX=>NULL() ! finite difference fluxes - TYPE(FLUXES) :: W_FLUX ! weighted sum of model fluxes over a time step - TYPE(FLUXES), dimension(:,:,:), allocatable :: W_FLUX_3d ! weighted sum of model fluxes over a time step for several time steps - REAL(SP) :: CURRENT_DT ! current time step (days) -END MODULE multi_flux + +END MODULE multi_flux_types diff --git a/build/FUSE_SRC/types/multibands_types.f90 b/build/FUSE_SRC/types/multibands_types.f90 new file mode 100644 index 0000000..8691c67 --- /dev/null +++ b/build/FUSE_SRC/types/multibands_types.f90 @@ -0,0 +1,37 @@ +MODULE multibands_types + + ! Created by Brian Henn to allow multi-band snow modeling, 6/2013 + ! Based on module MULTIFORCE by Martyn Clark + + ! Modified by Martyn Clark to separate type definitions from data storage, 01/2026 + + USE nrtype + + implicit none + private + + public :: BANDS, BANDS_INFO, BANDS_VAR + + ! MBANDS is split between time-independent and time-dependent charactertistics + + TYPE BANDS_INFO ! invariant characteristics + INTEGER(I4B) :: NUM ! band number (-) + REAL(SP) :: Z_MID ! band mid-point elevation (m) + REAL(SP) :: AF ! fraction of basin area in band (-) + ENDTYPE BANDS_INFO + + TYPE BANDS_VAR ! time-dependent characteristics + REAL(SP) :: SWE ! band snowpack water equivalent (mm) + REAL(SP) :: SNOWACCMLTN ! new snow accumulation in band (mm day-1) + REAL(SP) :: SNOWMELT ! snowmelt in band (mm day-1) + REAL(SP) :: DSWE_DT ! rate of change of band SWE (mm day-1) + ENDTYPE BANDS_VAR + + ! Combined structure + + TYPE BANDS + type(BANDS_INFO) :: info + type(BANDS_VAR) :: var + ENDTYPE BANDS + +END MODULE multibands_types diff --git a/build/FUSE_SRC/types/multiforce_types.f90 b/build/FUSE_SRC/types/multiforce_types.f90 new file mode 100644 index 0000000..8a40f9b --- /dev/null +++ b/build/FUSE_SRC/types/multiforce_types.f90 @@ -0,0 +1,52 @@ +MODULE multiforce_types + + ! --------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark + ! Modified by Brian Henn to include snow model, 6/2013 + ! Modified by Nans Addor to enable distributed modeling, 9/2016 + ! Modified by Cyril Thébault to allow different metrics as objective function, 2024 + ! Modified by Martyn Clark to separate type definitions from data storage, 01/2026 + ! --------------------------------------------------------------------------------------- + + USE nrtype + + implicit none + private + + public :: TDATA, VDATA, ADATA, FDATA + + ! the time data structure (will have no spatial dimension) + TYPE TDATA + INTEGER(I4B) :: IY ! year + INTEGER(I4B) :: IM ! month + INTEGER(I4B) :: ID ! day + INTEGER(I4B) :: IH ! hour + INTEGER(I4B) :: IMIN ! minute + REAL(SP) :: DSEC ! second + REAL(SP) :: DTIME ! time in seconds since year dot + ENDTYPE TDATA + + ! the response structure (will not have a spatial dimension) + TYPE VDATA + REAL(SP) :: OBSQ ! observed runoff (mm day-1) + END TYPE VDATA + + ! ancillary forcing variables used to compute ET (will have a spatial dimension) + TYPE ADATA + REAL(SP) :: AIRTEMP ! air temperature (K) + REAL(SP) :: SPECHUM ! specific humidity (g/g) + REAL(SP) :: AIRPRES ! air pressure (Pa) + REAL(SP) :: SWDOWN ! downward sw radiation (W m-2) + REAL(SP) :: NETRAD ! net radiation (W m-2) + END TYPE ADATA + + ! the forcing data structure (will have a spatial dimension) + TYPE FDATA + REAL(SP) :: PPT ! water input: rain + melt (mm day-1) + REAL(SP) :: TEMP ! temperature for snow model (deg.C) + REAL(SP) :: PET ! energy input: potential ET (mm day-1) + ENDTYPE FDATA + +END MODULE multiforce_types diff --git a/build/FUSE_SRC/dshare/multiparam.f90 b/build/FUSE_SRC/types/multiparam_types.f90 similarity index 90% rename from build/FUSE_SRC/dshare/multiparam.f90 rename to build/FUSE_SRC/types/multiparam_types.f90 index dd1188e..6062732 100644 --- a/build/FUSE_SRC/dshare/multiparam.f90 +++ b/build/FUSE_SRC/types/multiparam_types.f90 @@ -1,12 +1,21 @@ -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark -! Modified by Brian Henn to include snow model, 6/2013 -! --------------------------------------------------------------------------------------- -MODULE multiparam +MODULE multiparam_types + + ! --------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark + ! Modified by Brian Henn to include snow model, 6/2013 + ! Modified by Martyn Clark to separate type definitions from data storage, 01/2026 + ! --------------------------------------------------------------------------------------- + USE nrtype - USE model_defn,ONLY:NTDH_MAX + USE model_defn, ONLY: NTDH_MAX + + implicit none + private + + public :: PARATT, PARINFO, PARADJ, PARDVD, PAR_ID + ! -------------------------------------------------------------------------------------- ! (1) PARAMETER METADATA ! -------------------------------------------------------------------------------------- @@ -29,6 +38,7 @@ MODULE multiparam CHARACTER(LEN=256) :: CHILD1 ! name of 1st parameter child CHARACTER(LEN=256) :: CHILD2 ! name of 2nd parameter child END TYPE PARATT + ! data structure to hold metadata for each parameter TYPE PARINFO ! rainfall error parameters (adjustable) @@ -78,6 +88,7 @@ MODULE multiparam TYPE(PARATT) :: OPG ! precipitation gradient (-) TYPE(PARATT) :: LAPSE ! temperature gradient (deg. C) ENDTYPE PARINFO + ! -------------------------------------------------------------------------------------- ! (2) ADJUSTABLE PARAMETERS ! -------------------------------------------------------------------------------------- @@ -129,6 +140,7 @@ MODULE multiparam REAL(SP) :: OPG ! precipitation gradient (-) REAL(SP) :: LAPSE ! temperature gradient (deg. C) END TYPE PARADJ + ! -------------------------------------------------------------------------------------- ! (3) DERIVED PARAMETERS ! -------------------------------------------------------------------------------------- @@ -153,22 +165,12 @@ MODULE multiparam REAL(SP), DIMENSION(NTDH_MAX) :: FRAC_FUTURE ! fraction of runoff in future time steps INTEGER(I4B) :: NTDH_NEED ! number of time-steps with non-zero routing contribution END TYPE PARDVD + ! -------------------------------------------------------------------------------------- ! (4) LIST OF PARAMETERS FOR A GIVEN MODEL ! -------------------------------------------------------------------------------------- TYPE PAR_ID CHARACTER(LEN=9) :: PARNAME ! list of parameter names ENDTYPE PAR_ID - ! -------------------------------------------------------------------------------------- - ! (5) FINAL DATA STRUCTURES - ! -------------------------------------------------------------------------------------- - INTEGER(I4B), PARAMETER :: MAXPAR=50 ! maximum number of parameters for a single model - TYPE(PARADJ), DIMENSION(:), POINTER :: APARAM=>null() ! all model parameter sets; DK/2008/10/21: explicit null - TYPE(PARADJ) :: MPARAM ! single model parameter set - TYPE(PARDVD) :: DPARAM ! derived model parameters - TYPE(PARINFO) :: PARMETA ! parameter metadata (all parameters) - TYPE(PAR_ID), DIMENSION(MAXPAR) :: LPARAM ! list of model parameter names (need to modify to 16 for SCE) - INTEGER(I4B) :: NUMPAR ! number of model parameters for current model - INTEGER(I4B) :: SOBOL_INDX ! code to re-assemble Sobol parameters - ! -------------------------------------------------------------------------------------- -END MODULE multiparam + +END MODULE multiparam_types diff --git a/build/FUSE_SRC/types/multiroute_types.f90 b/build/FUSE_SRC/types/multiroute_types.f90 new file mode 100644 index 0000000..3b98045 --- /dev/null +++ b/build/FUSE_SRC/types/multiroute_types.f90 @@ -0,0 +1,16 @@ +MODULE multiroute_types + + USE nrtype + + implicit none + private + + public :: RUNOFF + + TYPE RUNOFF + REAL(SP) :: Q_INSTNT ! instantaneous runoff + REAL(SP) :: Q_ROUTED ! routed runoff + REAL(SP) :: Q_ACCURATE ! "accurate" runoff estimate (mm day-1) + END TYPE RUNOFF + +END MODULE multiroute_types diff --git a/build/FUSE_SRC/types/multistate_types.f90 b/build/FUSE_SRC/types/multistate_types.f90 new file mode 100644 index 0000000..e40f59d --- /dev/null +++ b/build/FUSE_SRC/types/multistate_types.f90 @@ -0,0 +1,37 @@ +MODULE multistate_types + + USE nrtype + + implicit none + private + + public :: STATEV, M_TIME + + ! -------------------------------------------------------------------------------------- + ! model state structure + ! -------------------------------------------------------------------------------------- + TYPE STATEV + ! snow layer + REAL(SP) :: SWE_TOT ! total storage as snow (mm) + ! upper layer + REAL(SP) :: WATR_1 ! total storage in layer1 (mm) + REAL(SP) :: TENS_1 ! tension storage in layer1 (mm) + REAL(SP) :: FREE_1 ! free storage in layer 1 (mm) + REAL(SP) :: TENS_1A ! storage in the recharge zone (mm) + REAL(SP) :: TENS_1B ! storage in the lower zone (mm) + ! lower layer + REAL(SP) :: WATR_2 ! total storage in layer2 (mm) + REAL(SP) :: TENS_2 ! tension storage in layer2 (mm) + REAL(SP) :: FREE_2 ! free storage in layer2 (mm) + REAL(SP) :: FREE_2A ! storage in the primary resvr (mm) + REAL(SP) :: FREE_2B ! storage in the secondary resvr (mm) + END TYPE STATEV + + ! -------------------------------------------------------------------------------------- + ! model time structure + ! -------------------------------------------------------------------------------------- + TYPE M_TIME + REAL(SP) :: STEP ! (time interval to advance model states) + END TYPE M_TIME + +END MODULE multistate_types diff --git a/build/FUSE_SRC/dshare/multistats.f90 b/build/FUSE_SRC/types/multistats_types.f90 similarity index 85% rename from build/FUSE_SRC/dshare/multistats.f90 rename to build/FUSE_SRC/types/multistats_types.f90 index d950cd9..f3f4ffd 100644 --- a/build/FUSE_SRC/dshare/multistats.f90 +++ b/build/FUSE_SRC/types/multistats_types.f90 @@ -1,10 +1,21 @@ -MODULE multistats +MODULE multistats_types + USE nrtype + + implicit none + private + + public :: SUMMARY + + ! -------------------------------------------------------------------------------------- + TYPE SUMMARY - ! DMSL diagnostix + + ! DMSL diagnostix REAL(SP) :: VAR_RESIDUL ! variance of the model residuals REAL(SP) :: LOGP_SIMULN ! log density of the model simulation REAL(SP) :: JUMP_TAKEN ! defines a jump in the MCMC production run + ! comparisons between model output and observations REAL(SP) :: QOBS_MEAN ! mean observed runoff (mm day-1) REAL(SP) :: QSIM_MEAN ! mean simulated runoff (mm day-1) @@ -19,6 +30,7 @@ MODULE multistats REAL(SP) :: KGEP ! Kling-Gupta Efficiency' score REAL(SP) :: MAE ! Mean absolute error REAL(SP) :: METRIC_VAL ! value of the metric chosen as objective function + ! attributes of model output REAL(SP) :: NUM_RMSE ! error of the approximate solution REAL(SP) :: NUM_FUNCS ! number of function calls @@ -28,12 +40,10 @@ MODULE multistats REAL(SP) :: NUMSUB_NOCONV ! number of sub-steps tried that did not converge INTEGER(I4B) :: MAXNUM_ITERNS ! maximum number of iterations in implicit scheme REAL(SP), DIMENSION(20) :: NUMSUB_PROB ! probability distribution for number of sub-steps + ! error checking CHARACTER(LEN=1024) :: ERR_MESSAGE ! error message + ENDTYPE SUMMARY - ! final data structures - TYPE(SUMMARY) :: MSTATS ! (model summary statistics) - INTEGER(I4B) :: MOD_IX=1 ! (model index) - INTEGER(I4B) :: PCOUNT ! (number of parameter sets in model output files) - INTEGER(I4B) :: FCOUNT ! (number of model simulations) -END MODULE multistats + +END MODULE multistats_types diff --git a/build/FUSE_SRC/types/work_types.f90 b/build/FUSE_SRC/types/work_types.f90 new file mode 100644 index 0000000..fb435c1 --- /dev/null +++ b/build/FUSE_SRC/types/work_types.f90 @@ -0,0 +1,103 @@ +module work_types + + ! data types + + use nrtype + + use multiforce_types, only: TDATA, VDATA, ADATA, FDATA + use multibands_types, only: BANDS, BANDS_INFO, BANDS_VAR + use multiparam_types, only: PARATT, PARINFO, PARADJ, PARDVD, PAR_ID + use multistate_types, only: STATEV, M_TIME + use multi_flux_types, only: FLUXES + use multiroute_types, only: RUNOFF + + use multistats_types, only: SUMMARY + + private + + public :: bands_var_diff, ebands + public :: fuse_chunk + public :: fuse_work + + ! -------------------------------------------------------------------------------------- + + ! dSWE/dParam for each elevation band + + type, extends(bands_var) :: bands_var_diff + real(sp), allocatable :: dSWE_dParam(:) + end type bands_var_diff + + ! extended bands structure + type ebands + type(bands_info) :: info + type(bands_var_diff) :: var + end type ebands + + ! -------------------------------------------------------------------------------------- + ! structure bundles + + ! per-step structure + type fuse_step + type(tdata) :: time ! time data + type(fdata) :: force ! model forcing data + type(statev) :: state0 ! state variables (start of step) + type(statev) :: state1 ! state variables (end of step) + type(statev) :: tState ! state variables (trial) + type(statev) :: dx_dt ! time derivative in state variables + type(fluxes) :: flux ! fluxes + type(runoff) :: route ! hillslope routing + end type fuse_step + + ! snow structure + type fuse_snow + real(sp) :: z_forcing ! elevation of forcing data (m) + type(ebands) , allocatable :: sbands(:) ! info/variables for elevation bands (snow model) + end type fuse_snow + + ! parameter structure + type fuse_param + type(par_id) :: param_name ! parameter names + type(parinfo) :: param_meta ! metadata on model parameters + type(paradj) :: param_adjust ! adjustable model parametrs + type(pardvd) :: param_derive ! derived model parameters + end type fuse_param + + ! numerix structure (linear algebra, ...) + type fuse_numerix + real(sp) , allocatable :: x0(:) ! state variables (start of step) + real(sp) , allocatable :: x1(:) ! state variables (end of step) + end type fuse_numerix + + ! adjoint structure (differentiable fuse) + type fuse_adjoint + type(fluxes), allocatable :: df_dS(:) ! derivative in fluxes w.r.t. states + type(fluxes), allocatable :: df_dPar(:) ! derivative in fluxes w.r.t. parameters + real(sp), allocatable :: dL_dPar(:) ! derivative in loss function w.r.t. parameters + end type fuse_adjoint + + ! chunk buffers (allocate per chunk) + type fuse_chunk + type(fluxes), allocatable :: w_flux_3d(:,:,:) ! (nspat1,nspat2,chunk_len) + type(runoff), allocatable :: aroute_3d(:,:,:) ! (nspat1,nspat2,chunk_len) + end type fuse_chunk + + ! run-level / evaluation-level + type fuse_run + type(summary) :: stats + end type fuse_run + + ! -------------------------------------------------------------------------------------- + ! omnibus structure that bundles "everything" required to run fuse for a single cell + + type fuse_work + type(fuse_step) :: step ! per-step structure + type(fuse_snow) :: snow ! snow structure + type(fuse_param) :: par ! parameter structure + type(fuse_numerix) :: num ! numerix structure (linear algebra, ...) + type(fuse_adjoint) :: adj ! adjoint structure (differentiable fuse) + type(fuse_chunk) :: chunk ! chunk buffer + type(fuse_run) :: run ! run-level structure + logical(lgt) :: is_initialized = .false. + end type fuse_work + +end module work_types diff --git a/build/FUSE_SRC/util/alloc_domain.f90 b/build/FUSE_SRC/util/alloc_domain.f90 new file mode 100644 index 0000000..9c078af --- /dev/null +++ b/build/FUSE_SRC/util/alloc_domain.f90 @@ -0,0 +1,180 @@ +module alloc_domain_module + + USE nrtype + USE info_types, only: fuse_info + USE data_types, only: domain_data + + use globaldata, only: NVAR_FORC + + implicit none + private + public :: allocate_domain_data + public :: set_legacy_arrays + +CONTAINS + + subroutine allocate_domain_data(info, domain, ierr, message) + + implicit none + + type(fuse_info), intent(inout) :: info + type(domain_data), intent(inout) :: domain + integer(i4b), intent(out) :: ierr + character(*), intent(out) :: message + + integer(i4b) :: nx, ny, nt, nb + + ierr=0; message="allocate_domain_data/" + + ! define dimensions + nx = info%space%nx_local ! NOTE: local to rank (MPI parallelization) + ny = info%space%ny_local + nt = info%time%nt_window + nb = info%snow%n_bands + + ! allocate validity mask + allocate(domain%valid(nx,ny,nt), stat=ierr) + if(ierr/=0)then; message=trim(message)//"cannot allocate valid"; return; endif + + ! allocate ancillary forcing + allocate(domain%ancil(nx,ny), stat=ierr) + if(ierr/=0)then; message=trim(message)//"cannot allocate ancil"; return; endif + + ! allocate forcing window + allocate(domain%force(nx,ny,nt), stat=ierr) + if(ierr/=0)then; message=trim(message)//"cannot allocate force"; return; endif + + ! allocate state window + allocate(domain%state(nx,ny,nt+1), stat=ierr) + if(ierr/=0)then; message=trim(message)//"cannot allocate state"; return; endif + + ! allocate flux window + allocate(domain%flux(nx,ny,nt), stat=ierr) + if(ierr/=0)then; message=trim(message)//"cannot allocate flux"; return; endif + + ! allocate basin averages + allocate(domain%aForce(nt), domain%aRoute(nt), stat=ierr) + if(ierr/=0)then; message=trim(message)//"cannot allocate aForce/aRoute"; return; endif + + ! allocate routing if needed + allocate(domain%route(nx,ny,nt), stat=ierr) + if(ierr/=0)then; message=trim(message)//"cannot allocate route"; return; endif + + ! allocate elevation grid + allocate(domain%z_forcing(nx,ny), domain%elev_mask(nx,ny), stat=ierr) + if(ierr/=0)then; message=trim(message)//"cannot allocate elev grid"; return; endif + + ! allocate elevation bands (info) + allocate(domain%bands_info(nx,ny,nb), stat=ierr) + if(ierr/=0)then; message=trim(message)//"cannot allocate elev bands (info)"; return; endif + + ! allocate elevation bands (var) + allocate(domain%bands_var(nx,ny,nb,nt+1), stat=ierr) + if(ierr/=0)then; message=trim(message)//"cannot allocate elev bands (var)"; return; endif + + ! allocate forcing lookup table + allocate(info%files%forc%name(NVAR_FORC), info%files%forc%varid(NVAR_FORC), stat=ierr) + if(ierr/=0)then; message=trim(message)//"cannot allocate forcing lookup table"; return; endif + + end subroutine allocate_domain_data + + ! ------------------------------------------------------------------------------------- + ! ------------------------------------------------------------------------------------- + + ! ----- copy arrays in the domain structure to legacy arrays --------------------- + + subroutine set_legacy_arrays(info, domain, ierr, message) + + ! legacy modules + use multiforce, only: nSpat1, nSpat2, numtim_sub + USE multiforce, only: startSpat2 ! starting y index for data read + USE multiforce, only: ncid_forc + use multiforce, only: timeUnits + use multiforce, only: nInput + use multiForce, only: aForce, gForce_3d, ancilF, aValid + use multiState, only: gState_3d + use multiRoute, only: aRoute, AROUTE_3d + use multiBands, only: N_BANDS, MBANDS, MBANDS_INFO_3d, MBANDS_VAR_4d, Z_FORCING_grid, elev_mask + implicit none + + type(fuse_info), intent(in) :: info + type(domain_data), intent(inout) :: domain + integer(i4b), intent(out) :: ierr + character(*), intent(out) :: message + + integer(i4b) :: nx, ny, nt, nb + + ierr = 0 + message = 'set_legacy_arrays/' + + ! define dimensions + nx = info%space%nx_local ! NOTE: local to rank (MPI parallelization) + ny = info%space%ny_local + nt = info%time%nt_window + nb = info%snow%n_bands + + ! set variables in multiforce + nSpat1 = nx + nSpat2 = ny + numtim_sub = nt + startSpat2 = info%space%y_start_global + + ncid_forc = info%files%ncid_forc + + nInput = info%config%nInput + + ! set bands + N_BANDS = nb + + ! allocate validity mask + allocate(aValid(nx,ny,nt), stat=ierr) + if(ierr/=0)then; message=trim(message)//"cannot allocate valid"; return; endif + + ! allocate ancillary forcing + allocate(ancilF(nx,ny), stat=ierr) + if(ierr/=0)then; message=trim(message)//"cannot allocate ancil"; return; endif + + ! allocate forcing window + allocate(gForce_3d(nx,ny,nt), stat=ierr) + if(ierr/=0)then; message=trim(message)//"cannot allocate force"; return; endif + + ! allocate state window + allocate(gState_3d(nx,ny,nt+1), stat=ierr) + if(ierr/=0)then; message=trim(message)//"cannot allocate state"; return; endif + + ! allocate flux window + !allocate(w_flux_3d(nx,ny,nt), stat=ierr) + !if(ierr/=0)then; message=trim(message)//"cannot allocate flux"; return; endif + + ! allocate basin averages + allocate(aForce(nt), aRoute(nt), stat=ierr) + if(ierr/=0)then; message=trim(message)//"cannot allocate aForce/aRoute"; return; endif + + ! allocate routing if needed + allocate(AROUTE_3d(nx,ny,nt), stat=ierr) + if(ierr/=0)then; message=trim(message)//"cannot allocate route"; return; endif + + ! allocate elevation grid and mask + allocate(Z_FORCING_grid(nx,ny), elev_mask(nx, ny), stat=ierr) + if(ierr/=0)then; message=trim(message)//"cannot allocate elev grid"; return; endif + + ! allocate elevation bands + allocate(MBANDS(nb), MBANDS_INFO_3d(nx,ny,nb), MBANDS_VAR_4d(nx,ny,nb,nt+1), stat=ierr) + if(ierr/=0)then; message=trim(message)//"cannot allocate elev bands"; return; endif + + ! copy arrays in the domain structure to legacy arrays + aValid = domain%valid ! validity mask + ancilF = domain%ancil ! ancillary forcing + aForce = domain%aForce ! all model forcing data + gForce_3d = domain%force ! forcing data + gState_3d = domain%state ! state data + aRoute = domain%aRoute ! all routing data + AROUTE_3d = domain%route ! routing data + elev_mask = domain%elev_mask ! elevation mask + Z_FORCING_grid = domain%z_forcing ! elevation grid + MBANDS_INFO_3d = domain%bands_info ! elevation band info + MBANDS_VAR_4d = domain%bands_var ! elevation band vars + + end subroutine set_legacy_arrays + +end module alloc_domain_module diff --git a/build/FUSE_SRC/util/alloc_scratch.f90 b/build/FUSE_SRC/util/alloc_scratch.f90 new file mode 100644 index 0000000..a9e0ecb --- /dev/null +++ b/build/FUSE_SRC/util/alloc_scratch.f90 @@ -0,0 +1,210 @@ +module alloc_scratch_module + + + USE nrtype + use info_types, only: fuse_info + use work_types, only: fuse_work + + implicit none + private + public :: init_fuse_work + +CONTAINS + + subroutine init_fuse_work(info, work, ierr, message) + + use globaldata, only: NPAR_SNOW + implicit none + + type(fuse_info), intent(in) :: info + type(fuse_work), intent(inout) :: work + integer(i4b), intent(out) :: ierr + character(*), intent(out) :: message + + integer(i4b) :: ib + integer(i4b) :: nBands, nState, nPar + logical(lgt) :: redo + + ierr=0; message="init_fuse_work/" + + nBands = info%snow%n_bands + nState = info%config%nState + nPar = info%config%nParam + + ! check if there is a need to reallocate + redo = needs_realloc_work(work, nBands, nState, nPar, NPAR_SNOW) + if (.not. redo) return + + ! if need to reallocate, then need to free up space + if (work%is_initialized) then + call free_fuse_work(work, ierr, message) + if(ierr/=0) return + endif + + ! ---- allocate state vectors ---- + allocate(work%num%x0(nState), & + work%num%x1(nState), stat=ierr) + if(ierr/=0) then + message=trim(message)//"cannot allocate state vectors" + return + endif + + ! optional debug scratch + ! allocate(work%dSdt(nState), work%J(nState,nState), stat=ierr) + + ! ---- allocate differentiable parent derivatives ---- + allocate(work%adj%df_dS(nState), & + work%adj%df_dPar(nPar), & + work%adj%dL_dPar(nPar), stat=ierr) + if(ierr/=0) then + message=trim(message)//"cannot allocate derivatives" + return + endif + + ! ---- allocate elevation band containers ---- + allocate(work%snow%sbands(nBands), stat=ierr) + if(ierr/=0) then + message=trim(message)//"cannot allocate sbands" + return + endif + + ! ---- allocate per-band parameter derivative vectors ---- + do ib=1,nBands + allocate(work%snow%sbands(ib)%var%dSWE_dParam(nPar_snow), stat=ierr) + if(ierr/=0) then + message=trim(message)//"cannot allocate dSWE_dParam for band" + return + endif + work%snow%sbands(ib)%var%dSWE_dParam(:) = 0._sp + enddo + + ! ---- initialize the band snow vars once ---- + work%snow%sbands(:)%var%SWE = 0._sp + work%snow%sbands(:)%var%SNOWACCMLTN = 0._sp + work%snow%sbands(:)%var%SNOWMELT = 0._sp + work%snow%sbands(:)%var%DSWE_DT = 0._sp + + work%is_initialized = .true. + + end subroutine init_fuse_work + + ! ------------------------------------------------------------------------------------- + + subroutine free_fuse_work(work, ierr, message) + + implicit none + type(fuse_work), intent(inout) :: work + integer(i4b), intent(out) :: ierr + character(*), intent(out) :: message + + integer(i4b) :: ib, istat + + ierr = 0 + message = "free_fuse_work/" + + ! ---- state vectors ---- + if(allocated(work%num%x0)) then + deallocate(work%num%x0, stat=istat) + call note_fail("num%x0", istat) + endif + + if(allocated(work%num%x1)) then + deallocate(work%num%x1, stat=istat) + call note_fail("num%x1", istat) + endif + + ! ---- derivative arrays ---- + if (allocated(work%adj%df_dS)) then + deallocate(work%adj%df_dS, stat=istat) + call note_fail("adj%df_dS", istat) + endif + + if (allocated(work%adj%df_dPar)) then + deallocate(work%adj%df_dPar, stat=istat) + call note_fail("adj%df_dPar", istat) + endif + + if (allocated(work%adj%dL_dPar)) then + deallocate(work%adj%dL_dPar, stat=istat) + call note_fail("adj%dL_dPar", istat) + endif + + ! ---- elevation band structures ---- + if (allocated(work%snow%sbands)) then + + do ib = 1, size(work%snow%sbands) + if (allocated(work%snow%sbands(ib)%var%dSWE_dParam)) then + deallocate(work%snow%sbands(ib)%var%dSWE_dParam, stat=istat) + call note_fail("sbands%var%dSWE_dParam", istat) + endif + enddo + + deallocate(work%snow%sbands, stat=istat) + call note_fail("snow%sbands", istat) + + endif + + work%is_initialized = .false. + + contains + + subroutine note_fail(where, istat) + character(*), intent(in) :: where + integer(i4b), intent(in) :: istat + + if (istat /= 0) then + ! preserve the first nonzero stat as ierr + if (ierr == 0) ierr = istat + + ! append context (do not overwrite) + message = trim(message)//" dealloc_fail("//trim(where)//")" + endif + end subroutine note_fail + + end subroutine free_fuse_work + + ! ------------------------------------------------------------------------------------------------------------------- + ! ------------------------------------------------------------------------------------------------------------------- + + ! Private: decide if we need to free+reallocate work arrays + logical(lgt) function needs_realloc_work(work, nBands, nState, nPar, nParSnow) result(redo) + + type(fuse_work), intent(in) :: work + integer(i4b), intent(in) :: nBands, nState, nPar, nParSnow + + integer(i4b) :: ib + + redo = .false. + + ! Not initialized => must allocate + if (.not. work%is_initialized) then + redo = .true. + return + endif + + ! Must be allocated if we claim initialized + if (.not. allocated(work%adj%df_dS)) then; redo=.true.; return; endif + if (.not. allocated(work%adj%df_dPar)) then; redo=.true.; return; endif + if (.not. allocated(work%adj%dL_dPar)) then; redo=.true.; return; endif + if (.not. allocated(work%snow%sbands)) then; redo=.true.; return; endif + + ! Size checks + if (size(work%adj%df_dS) /= nState) then; redo=.true.; return; endif + if (size(work%adj%df_dPar) /= nPar) then; redo=.true.; return; endif + if (size(work%adj%dL_dPar) /= nPar) then; redo=.true.; return; endif + if (size(work%snow%sbands) /= nBands) then; redo=.true.; return; endif + + ! Per-band arrays + do ib = 1, nBands + if (.not. allocated(work%snow%sbands(ib)%var%dSWE_dParam)) then + redo = .true.; return + endif + if (size(work%snow%sbands(ib)%var%dSWE_dParam) /= nParSnow) then + redo = .true.; return + endif + enddo + + end function needs_realloc_work + + +end module alloc_scratch_module diff --git a/build/FUSE_SRC/util/fuse_fileManager.f90 b/build/FUSE_SRC/util/fuse_fileManager.f90 index 2352ec5..0709757 100644 --- a/build/FUSE_SRC/util/fuse_fileManager.f90 +++ b/build/FUSE_SRC/util/fuse_fileManager.f90 @@ -1,211 +1,322 @@ -!****************************************************************** -! (C) Copyright 2009-2010 --- Dmitri Kavetski and Martyn Clark --- All rights reserved -!****************************************************************** ! Edited by Brian Henn to include snow model, 7/2013 ! Edited by Nans Addor to set simulation and evaluation periods, 11/2017 -! Edited by Cyril Thébault to allow different metrics as objective function, 2024 +! Modified by Martyn Clark to populate domain structure, 12/2025 MODULE fuse_filemanager -use kinds_dmsl_kit_FUSE,only:mik,mlk - -implicit none -public -! FUSE-wide pathlength -integer(mik),parameter::fusePathLen=256 -! defines the path for data files -CHARACTER(LEN=fusePathLen) :: SETNGS_PATH -CHARACTER(LEN=fusePathLen) :: INPUT_PATH -CHARACTER(LEN=fusePathLen) :: OUTPUT_PATH -! content of input directory -CHARACTER(LEN=fusePathLen) :: suffix_forcing ! suffix for forcing file -CHARACTER(LEN=fusePathLen) :: suffix_elev_bands ! suffix for elevation band file -! content of settings directory -CHARACTER(LEN=fusePathLen) :: M_DECISIONS ! definition of model decisions -CHARACTER(LEN=fusePathLen) :: CONSTRAINTS ! definition of parameter constraints -CHARACTER(LEN=fusePathLen) :: MOD_NUMERIX ! definition of numerical solution technique -CHARACTER(LEN=fusePathLen) :: FORCINGINFO ! info on forcing data files -CHARACTER(LEN=fusePathLen) :: MBANDS_INFO ! info on basin band data files ! not needed anymore -CHARACTER(LEN=fusePathLen) :: MBANDS_NC ! netcdf file defining the elevation bands -CHARACTER(LEN=fusePathLen) :: BATEA_PARAM ! definition of BATEA parameters ! remove this -! content of output directory -CHARACTER(LEN=64) :: FMODEL_ID ! string defining FUSE model -CHARACTER(LEN=64) :: Q_ONLY_STR ! TRUE = restrict attention to simulated runoff -LOGICAL :: Q_ONLY ! .TRUE. = restrict attention to simulated runoff -! define simulation and evaluation periods -CHARACTER(len=20) :: date_start_sim ! date start simulation -CHARACTER(len=20) :: date_end_sim ! date end simulation -CHARACTER(len=20) :: date_start_eval ! date start evaluation period -CHARACTER(len=20) :: date_end_eval ! date end evaluation period -CHARACTER(len=20) :: numtim_sub_str ! number of time steps of subperiod (will be kept in memory) -! evaluation metrics and transformation -CHARACTER(len=20) :: METRIC ! metric chosen as objective function -CHARACTER(len=20) :: TRANSFO ! streamflow transformation -! SCE parameters -CHARACTER(len=20) :: KSTOP_str ! number of shuffling loops the value must change by PCENTO -CHARACTER(len=20) :: MAXN_str ! maximum number of trials before optimization is terminated -CHARACTER(len=20) :: PCENTO_str ! the percentage -!---------------------------------------------------- + use nrtype + use kinds_dmsl_kit_FUSE,only:mik,mlk + use info_types, only: cli_options + use info_types, only: fuse_info + + use globaldata, only: NVAR_FORC + use globaldata, only: iPRECIP, iTEMP, iPET, iQOBS + + implicit none + private + + public :: read_fuse_control_file + + ! ----- all of these legacy globals are stored in the "info" data structure --------------------- + + ! expose legacy globals + public :: SETNGS_PATH, INPUT_PATH, OUTPUT_PATH + public :: suffix_forcing, suffix_elev_bands + public :: M_DECISIONS, CONSTRAINTS, MOD_NUMERIX, FORCINGINFO, MBANDS_NC + public :: FMODEL_ID, Q_ONLY_STR, Q_ONLY + public :: date_start_sim, date_end_sim, date_start_eval, date_end_eval, numtim_sub_str + public :: METRIC, TRANSFO + public :: KSTOP_str, MAXN_str, PCENTO_str + + ! ------------------------------------------------------------------------------------------------ + + ! FUSE-wide pathlength + integer(i4b),parameter::fusePathLen=512 + + ! defines the path for data files + CHARACTER(LEN=fusePathLen) :: SETNGS_PATH + CHARACTER(LEN=fusePathLen) :: INPUT_PATH + CHARACTER(LEN=fusePathLen) :: OUTPUT_PATH + + ! content of input directory + CHARACTER(LEN=fusePathLen) :: suffix_forcing ! suffix for forcing file + CHARACTER(LEN=fusePathLen) :: suffix_elev_bands ! suffix for elevation band file + + ! content of settings directory + CHARACTER(LEN=fusePathLen) :: M_DECISIONS ! definition of model decisions + CHARACTER(LEN=fusePathLen) :: CONSTRAINTS ! definition of parameter constraints + CHARACTER(LEN=fusePathLen) :: MOD_NUMERIX ! definition of numerical solution technique + CHARACTER(LEN=fusePathLen) :: FORCINGINFO ! info on forcing data files + CHARACTER(LEN=fusePathLen) :: MBANDS_NC ! netcdf file defining the elevation bands + + ! content of output directory + CHARACTER(LEN=64) :: FMODEL_ID ! string defining FUSE model + CHARACTER(LEN=64) :: Q_ONLY_STR ! TRUE = restrict attention to simulated runoff + LOGICAL :: Q_ONLY ! .TRUE. = restrict attention to simulated runoff + + ! define simulation and evaluation periods + CHARACTER(len=20) :: date_start_sim ! date start simulation + CHARACTER(len=20) :: date_end_sim ! date end simulation + CHARACTER(len=20) :: date_start_eval ! date start evaluation period + CHARACTER(len=20) :: date_end_eval ! date end evaluation period + CHARACTER(len=20) :: numtim_sub_str ! number of time steps of subperiod (will be kept in memory) + + ! evaluation metrics and transformation + CHARACTER(len=20) :: METRIC ! metric chosen as objective function + CHARACTER(len=20) :: TRANSFO ! streamflow transformation + + ! SCE parameters + CHARACTER(len=20) :: KSTOP_str ! number of shuffling loops the value must change by PCENTO + CHARACTER(len=20) :: MAXN_str ! maximum number of trials before optimization is terminated + CHARACTER(len=20) :: PCENTO_str ! the percentage + contains -!---------------------------------------------------- -subroutine fuse_SetDirsUndPhiles(fuseMusterDirektorIn,fuseFileManagerIn,err,message) -! Purpose: Sets direcotries and philenames for FUSE. -! --- -! Programmer: Dmitri Kavetski -! History: -! Darby St, 18/10/2009 AD - leid out basik frammenverk -! Sonnental, 17/06/2012 AD - more general path handling -! --- -! Usage -! fuseMusterDirektorIn = master direktor file (path to filemanager) -! fuseFileManagerIn = global names/path file -! --- -! Comments: -! 1. If present will try to use fuseMasterIn, otherwise default file. -! if default not present in EXE path then uses default options -! --- -use utilities_dmsl_kit_FUSE,only:getSpareUnit -implicit none -! dummies -character(*),intent(in),optional::fuseMusterDirektorIn,fuseFileManagerIn -integer(mik),intent(out)::err -character(*),intent(out)::message -! registered settings -character(*),parameter::procnam="fuseSetDirsUndPhiles" -character(*),parameter::pathDelim="/\",defpathSymb="*",blank=" " -character(*),parameter::fuseMusterDirektorHeader="FUSE_MUSTERDIREKTOR_V1.0" -character(*),parameter::fuseFileManagerHeader="FUSE_FILEMANAGER_V1.5" -! locals -logical(mlk)::haveFMG,haveMUS -character(LEN=fusePathLen)::fuseMusterDirektor,fuseFileManager,defpath -character(LEN=100)::temp -integer(mik)::unt,i -! Start procedure here -err=0; message=procnam//"/ok"; defpath=blank -haveMUS=present(fuseMusterDirektorIn); haveFMG=present(fuseFileManagerIn) -if(haveMUS)haveMUS=len_trim(fuseMusterDirektorIn)>0 -if(haveFMG)haveFMG=len_trim(fuseFileManagerIn)>0 ! check for zero-string -if(haveMUS.and.haveFMG)then - message="f-"//procnam//"/mustSpecifyEither(notBoth)& - &[fuseMusterDirektor.or.fuseFileManager]" - err=10; return -elseif(haveFMG)then - fuseFileManager=fuseFileManagerIn - i=scan(fuseFileManager,pathDelim,back=.true.) - if(i>0)defpath=fuseFileManager(:i-1)//pathDelim(1:1) - print *, 'fuseFileManager:', TRIM(fuseFileManager) - -elseif(haveMUS)then - fuseMusterDirektor=fuseMusterDirektorIn - i=scan(fuseMusterDirektor,pathDelim,back=.true.) - if(i>0)defpath=fuseMusterDirektor(:i-1)//pathDelim(1:1) - print *, 'fuseMusterDirektor:', TRIM(fuseMusterDirektor) - -else - message="f-"//procnam//"/mustSpecifyEither& - &[fuseMusterDirektor.or.fuseFileManager]" - err=20; return -endif -call getSpareUnit(unt,err,message) ! make sure 'unt' is actually available -if(err/=0)then - message="f-"//procnam//"/weird/&"//message - err=100; return -endif -if(.not.haveFMG)then ! grab it from the muster-direktor - -! 2. Open muster-direktor and read it - open(unt,file=fuseMusterDirektor,status="old",action="read",iostat=err) - if(err/=0)then - message="f-"//procnam//"/musterDirektorFileOpenError['"//trim(fuseMusterDirektor)//"']" + + ! ------------------------------------------------------------------------------------- + ! ------------------------------------------------------------------------------------- + + subroutine read_fuse_control_file(fuseFileManagerIn, opts, info, err, message) + use tomlf_all, only: toml_table, toml_error, toml_key, toml_value ! data types + use tomlf_all, only: toml_load, get_value ! procedures + + ! Purpose: Reads FUSE control file (TOML version) AND populates info structure + ! + implicit none + + ! dummies + character(*), intent(in) :: fuseFileManagerIn + type(cli_options), intent(in) :: opts + type(fuse_info), intent(inout) :: info + integer(i4b), intent(out) :: err + character(*), intent(out) :: message + + ! TOML table + type(toml_table), allocatable :: tbl ! root TOML table + type(toml_table), pointer :: subtable ! sub-table for a given section + type(toml_key), allocatable :: sections(:) ! top-level sections + type(toml_key), allocatable :: keys(:) ! sub-table keys + type(toml_error), allocatable :: error + + ! locals + integer(i4b) :: istat + integer(i4b) :: n, i, j + character(len=256) :: lookup + + ! create file paths + character(len=256) :: dom_id, tag, run_mode + + err = 0 + message = "read_fuse_control_file/" + + ! ----- load the root TOML table ----- + call toml_load(tbl, trim(fuseFileManagerIn), error=error) + if (allocated(error)) then + message = "problem loading toml file['"//trim(fuseFileManagerIn)//"']: "//trim(error%message) err=10; return endif - read(unt,*)temp - if(temp/=fuseMusterDirektorHeader)then - message="f-"//procnam//"/unknownHeader&[file='"//trim(fuseMusterDirektor)//"']&& - &[header='"//trim(temp)//"']" - err=20; return + + ! ----- get the top-level sections ----- + call tbl%get_keys(sections) + if(.not.allocated(sections)) then + message = "problem loading toml sections['"//trim(fuseFileManagerIn)//"']" + err=10; return endif - read(unt,*)fuseFileManager - close(unt) -endif -! open file manager file -open(unt,file=fuseFileManager,status="old",action="read",iostat=err) -if(err/=0)then - message="f-"//procnam//"/fileManagerOpenError['"//trim(fuseFileManager)//"']" - err=10; return -endif -read(unt,*)temp -if(temp/=fuseFileManagerHeader)then - message="f-"//procnam//"/unknownHeader&[file='"//trim(fuseFileManager)//"']&& - &[header="//trim(temp)//"]" - - message='This version of FUSE requires the file manager to follow the following format: '//trim(fuseFileManagerHeader)//' not '//trim(temp) - - err=20; return -endif -read(unt,'(a)')temp -read(unt,*)SETNGS_PATH -read(unt,*)INPUT_PATH -read(unt,*)OUTPUT_PATH -read(unt,'(a)')temp -read(unt,*)suffix_forcing -read(unt,*)suffix_elev_bands -read(unt,'(a)')temp -read(unt,*)FORCINGINFO -read(unt,*)CONSTRAINTS -read(unt,*)MOD_NUMERIX -read(unt,*)M_DECISIONS -read(unt,'(a)')temp -read(unt,*)FMODEL_ID -read(unt,*)Q_ONLY_STR -read(unt,'(a)')temp -read(unt,*)date_start_sim -read(unt,*)date_end_sim -read(unt,*)date_start_eval -read(unt,*)date_end_eval -read(unt,*)numtim_sub_str -read(unt,'(a)')temp -read(unt,*)METRIC -read(unt,*)TRANSFO -read(unt,'(a)')temp -read(unt,*)MAXN_STR -read(unt,*)KSTOP_STR -read(unt,*)PCENTO_STR -close(unt) - -! Convert Q_ONLY to logical -if(Q_ONLY_STR=='TRUE')then - Q_ONLY = .TRUE. -elseif(Q_ONLY_STR=='FALSE')then - Q_ONLY = .FALSE. -else - message="Q_ONLY must be either TRUE or FALSE" - err=20; return -endif - -PRINT*, 'Q_ONLY', Q_ONLY - -! process paths a bit -if(SETNGS_PATH(1:1)==defpathSymb)SETNGS_PATH=trim(defpath)//SETNGS_PATH(2:) -if( INPUT_PATH(1:1)==defpathSymb) INPUT_PATH=trim(defpath)//INPUT_PATH (2:) -if(OUTPUT_PATH(1:1)==defpathSymb)OUTPUT_PATH=trim(defpath)//OUTPUT_PATH(2:) - -PRINT *, 'Paths defined in file manager:' -PRINT *, 'SETNGS_PATH:', TRIM(SETNGS_PATH) -PRINT *, 'INPUT_PATH:', TRIM(INPUT_PATH) -PRINT *, 'OUTPUT_PATH:', TRIM(OUTPUT_PATH) - -PRINT *, 'Dates defined in file manager:' -PRINT *, 'date_start_sim:', TRIM(date_start_sim) -PRINT *, 'date_end_sim:', TRIM(date_end_sim) -PRINT *, 'date_start_eval:', TRIM(date_start_eval) -PRINT *, 'date_end_eval:', TRIM(date_end_eval) -PRINT *, 'numtim_sub_str:', TRIM(numtim_sub_str) - -PRINT *, 'Metrics and transformations defined in file manager:' -PRINT *, 'METRIC:', TRIM(METRIC) -PRINT *, 'TRANSFO:', TRIM(TRANSFO) - -! End procedure here -endsubroutine fuse_SetDirsUndPhiles + + ! ----- loop through sections ----- + do i = 1, size(sections) + + ! ----- load the TOML sub-table for the current section ----- + call get_value(tbl, trim(sections(i)%key), subtable, requested=.false.) + if(.not.associated(subtable)) then + message = "problem loading toml sub-sections['"//trim(fuseFileManagerIn)//"']:"//trim(sections(i)%key) + err=10; return + endif + + ! ----- get keys for a given section (sub-table) ----- + call subtable%get_keys(keys) + + ! ----- loop through the sub-table ----- + do j = 1, size(keys) + + + ! --------------------------------------------------------------------------------------------------------------- + ! --------------------------------------------------------------------------------------------------------------- + + ! ----- control file assignment block --------------------------------------------------------------------------- + + lookup = trim(sections(i)%key)//'.'//trim(keys(j)%key) + + select case(lookup) + + ! ---- files: paths ---- + case ("filepaths.input_dir" ); call get_value(subtable, trim(keys(j)%key), info%files%input_path , stat=istat) + case ("filepaths.output_dir" ); call get_value(subtable, trim(keys(j)%key), info%files%output_path , stat=istat) + case ("filepaths.settings_dir" ); call get_value(subtable, trim(keys(j)%key), info%files%setngs_path , stat=istat) + + ! ---- files: suffixes ---- + case ("input.forcing_suffix" ); call get_value(subtable, trim(keys(j)%key), info%files%suffix_forcing , stat=istat) + case ("input.elevbands_suffix" ); call get_value(subtable, trim(keys(j)%key), info%files%suffix_elev_bands, stat=istat) + + ! ---- files: settings filenames ---- + case ("model.decisions_file" ); call get_value(subtable, trim(keys(j)%key), info%files%m_decisions , stat=istat) + case ("model.numerics_file" ); call get_value(subtable, trim(keys(j)%key), info%files%mod_numerix , stat=istat) + case ("model.constraints_file" ); call get_value(subtable, trim(keys(j)%key), info%files%constraints , stat=istat) + case ("model.forcinginfo_file" ); call get_value(subtable, trim(keys(j)%key), info%files%forcinginfo , stat=istat) + + ! ---- files: forcing coordinate names ---- + case ("forcing_coords.time" ); call get_value(subtable, trim(keys(j)%key), info%files%time_name , stat=istat) + case ("forcing_coords.latitude" ); call get_value(subtable, trim(keys(j)%key), info%files%latitude_name , stat=istat) + case ("forcing_coords.longitude" ); call get_value(subtable, trim(keys(j)%key), info%files%longitude_name , stat=istat) + + ! ---- files: forcing variable names ---- + case ("forcing_vars.precip" ); call get_value(subtable, trim(keys(j)%key), info%files%precip_name , stat=istat) + case ("forcing_vars.temp" ); call get_value(subtable, trim(keys(j)%key), info%files%temp_name , stat=istat) + case ("forcing_vars.pet" ); call get_value(subtable, trim(keys(j)%key), info%files%pet_name , stat=istat) + case ("forcing_vars.qobs" ); call get_value(subtable, trim(keys(j)%key), info%files%qobs_name , stat=istat) + + ! ---- config: runtime ---- + case ("output.model_id" ); call get_value(subtable, trim(keys(j)%key), info%config%fmodel_id , stat=istat) + case ("output.q_only" ); call get_value(subtable, trim(keys(j)%key), info%config%q_only , stat=istat) + + ! ---- config: periods ---- + case ("run_periods.date_start_sim" ); call get_value(subtable, trim(keys(j)%key), info%config%date_start_sim , stat=istat) + case ("run_periods.date_end_sim" ); call get_value(subtable, trim(keys(j)%key), info%config%date_end_sim , stat=istat) + case ("run_periods.date_start_eval"); call get_value(subtable, trim(keys(j)%key), info%config%date_start_eval , stat=istat) + case ("run_periods.date_end_eval" ); call get_value(subtable, trim(keys(j)%key), info%config%date_end_eval , stat=istat) + case ("run_periods.numtim_sub_str" ); call get_value(subtable, trim(keys(j)%key), info%config%numtim_sub_str , stat=istat) + + ! ---- config: calibration ---- + case ("calibration.metric" ); call get_value(subtable, trim(keys(j)%key), info%config%metric , stat=istat) + case ("calibration.transfo" ); call get_value(subtable, trim(keys(j)%key), info%config%transfo , stat=istat) + + ! ---- config: SCE (read numeric, then next populate legacy strings) ---- + case ("sce.maxn" ); call get_value(subtable, trim(keys(j)%key), info%config%maxn , stat=istat) + case ("sce.kstop" ); call get_value(subtable, trim(keys(j)%key), info%config%kstop , stat=istat) + case ("sce.pcento" ); call get_value(subtable, trim(keys(j)%key), info%config%pcento , stat=istat) + + ! ---- default case (something in the table that is not specified above) ----- + case default + message = trim(message)// "unexpected entry: section = "//trim(sections(i)%key)//"; sub-section = "//trim(keys(j)%key) + err=20; return + + end select ! (select key/value pair based on lookup) + + ! ---- error checking ----- + if(istat /= 0)then + message=trim(message)// "get_value error: section = "//trim(sections(i)%key)//"; sub-section = "//trim(keys(j)%key) + err=20; return + endif + + end do ! (looping through sub-sections) + end do ! (looping through sections) + + ! ---- populate legacy strings ---- + write(info%config%maxn_str, '(i0)' ) info%config%maxn + write(info%config%kstop_str, '(i0)' ) info%config%kstop + write(info%config%pcento_str,'(es20.10)') info%config%pcento + + ! ---- domain id, run mode and tag for output files ---- + dom_id = trim(opts%domain_id) + run_mode = trim(opts%runmode) + + tag = "" + if(allocated(opts%tag)) tag = trim(opts%tag) + + ! ---- derived input filenames ---- + info%files%forcing_file = trim(dom_id)//trim(info%files%suffix_forcing) + info%files%elevbands_file = trim(dom_id)//trim(info%files%suffix_elev_bands) + + ! ---- derived output base name ---- + info%files%fname_tempry = trim(info%files%output_path)// & + trim(dom_id)//'_'//trim(info%config%fmodel_id)//'_'//trim(tag) + + ! ---- final filenames ---- + info%files%fname_netcdf_forc = trim(info%files%input_path)//trim(info%files%forcing_file) + info%files%fname_netcdf_runs = trim(info%files%fname_tempry)//'_runs_'//trim(run_mode)//'.nc' + info%files%fname_netcdf_para = trim(info%files%fname_tempry)//'_para_'//trim(run_mode)//'.nc' + + ! ---- populate legacy modules ---- + call export_domain_to_legacy(info) + + end subroutine read_fuse_control_file + + ! ------------------------------------------------------------------------------------- + ! ------------------------------------------------------------------------------------- + + ! ----- export domain config variables to legacy modules ------------------------------ + + subroutine export_domain_to_legacy(info) + use model_defn, only: FNAME_TEMPRY, FNAME_NETCDF_RUNS, FNAME_NETCDF_PARA + use multiparam, only: MAXN, KSTOP, PCENTO + use multiforce, only: forcefile + + implicit none + + type(fuse_info), intent(in) :: info + + ! ---- populate legacy module globals ---- + + SETNGS_PATH = trim(info%files%setngs_path) + INPUT_PATH = trim(info%files%input_path) + OUTPUT_PATH = trim(info%files%output_path) + suffix_forcing = trim(info%files%suffix_forcing) + suffix_elev_bands = trim(info%files%suffix_elev_bands) + FORCINGINFO = trim(info%files%forcinginfo) + CONSTRAINTS = trim(info%files%constraints) + MOD_NUMERIX = trim(info%files%mod_numerix) + M_DECISIONS = trim(info%files%m_decisions) + + FMODEL_ID = trim(info%config%fmodel_id) + Q_ONLY = info%config%q_only + + date_start_sim = trim(info%config%date_start_sim) + date_end_sim = trim(info%config%date_end_sim) + date_start_eval = trim(info%config%date_start_eval) + date_end_eval = trim(info%config%date_end_eval) + numtim_sub_str = trim(info%config%numtim_sub_str) + + METRIC = trim(info%config%metric) + TRANSFO = trim(info%config%transfo) + + MAXN = info%config%maxn + KSTOP = info%config%kstop + PCENTO = info%config%pcento + + MAXN_str = trim(info%config%maxn_str) + KSTOP_str = trim(info%config%kstop_str) + PCENTO_str = trim(info%config%pcento_str) + + ! populate module model_defn + FNAME_TEMPRY = trim(info%files%fname_tempry) + FNAME_NETCDF_RUNS = trim(info%files%fname_netcdf_runs) + FNAME_NETCDF_PARA = trim(info%files%fname_netcdf_para) + + ! populate module multiforce + forcefile = trim(info%files%forcing_file) + + ! populate shared public variable in this module (fuse_filemanager) + MBANDS_NC = trim(info%files%elevbands_file) + + ! populate module multiparam + MAXN = info%config%maxn + KSTOP = info%config%kstop + PCENTO = info%config%pcento + + ! ---- logging ---- + print *, 'Paths defined in file manager:' + print *, 'SETNGS_PATH:', trim(info%files%setngs_path) + print *, 'INPUT_PATH:', trim(info%files%input_path) + print *, 'OUTPUT_PATH:', trim(info%files%output_path) + + print *, 'Dates defined in file manager:' + print *, 'date_start_sim:', trim(info%config%date_start_sim) + print *, 'date_end_sim:', trim(info%config%date_end_sim) + print *, 'date_start_eval:', trim(info%config%date_start_eval) + print *, 'date_end_eval:', trim(info%config%date_end_eval) + print *, 'numtim_sub_str:', trim(info%config%numtim_sub_str) + + print *, 'Q_ONLY', info%config%q_only + + end subroutine export_domain_to_legacy + !---------------------------------------------------- END MODULE fuse_filemanager diff --git a/build/FUSE_SRC/util/metaoutput.f90 b/build/FUSE_SRC/util/metaoutput.f90 index 66765a1..77801b0 100644 --- a/build/FUSE_SRC/util/metaoutput.f90 +++ b/build/FUSE_SRC/util/metaoutput.f90 @@ -1,113 +1,121 @@ MODULE metaoutput -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2007 -! Modified by Brian Henn to include snow model, 6/2013 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Describe all variables used in the model (used to define NetCDF output files, etc.) -! --------------------------------------------------------------------------------------- -! variable definitions -USE nrtype -USE multibands,ONLY:N_BANDS -USE model_defn,ONLY:SMODL -USE model_defnames -IMPLICIT NONE -CHARACTER(LEN=11), DIMENSION(200) :: VNAME ! variable names -CHARACTER(LEN=52), DIMENSION(200) :: LNAME ! variable long names (descrition of variable) -CHARACTER(LEN=13), DIMENSION(200) :: VUNIT ! variable units -INTEGER(I4B) :: I ! loop through variables -INTEGER(I4B) :: NOUTVAR ! number of output variables -INTEGER(I4B) :: ISNW ! loop through SWE states -CHARACTER(LEN=2) :: TXT_ISNW ! band index as a character -CONTAINS -! --------------------------------------------------------------------------------------- -SUBROUTINE VARDESCRIBE() -I=0 ! initialize counter -! model forcing -I=I+1; VNAME(I)='ppt '; LNAME(I)='precipitation rate '; VUNIT(I)='mm day-1 ' -I=I+1; VNAME(I)='pet '; LNAME(I)='potential evapotranspiration rate '; VUNIT(I)='mm day-1 ' -I=I+1; VNAME(I)='temp '; LNAME(I)='mean air temperature '; VUNIT(I)='deg.C ' -I=I+1; VNAME(I)='obsq '; LNAME(I)='observed runoff '; VUNIT(I)='mm timestep-1' -! model states -I=I+1; VNAME(I)='tens_1 '; LNAME(I)='tension storage in the upper layer '; VUNIT(I)='mm ' -I=I+1; VNAME(I)='tens_1a '; LNAME(I)='tension storage in the soil excess zone '; VUNIT(I)='mm ' -I=I+1; VNAME(I)='tens_1b '; LNAME(I)='tension storage in the soil recharge zone '; VUNIT(I)='mm ' -I=I+1; VNAME(I)='free_1 '; LNAME(I)='free storage in the upper layer '; VUNIT(I)='mm ' -I=I+1; VNAME(I)='watr_1 '; LNAME(I)='total storage in the upper layer '; VUNIT(I)='mm ' -I=I+1; VNAME(I)='tens_2 '; LNAME(I)='tension storage in the lower layer '; VUNIT(I)='mm ' -I=I+1; VNAME(I)='free_2 '; LNAME(I)='free storage in the lower layer '; VUNIT(I)='mm ' -I=I+1; VNAME(I)='free_2a '; LNAME(I)='free storage in the primary baseflow reservoir '; VUNIT(I)='mm ' -I=I+1; VNAME(I)='free_2b '; LNAME(I)='free storage in the secondary baseflow reservoir '; VUNIT(I)='mm ' -I=I+1; VNAME(I)='watr_2 '; LNAME(I)='total storage in the lower layer '; VUNIT(I)='mm ' -IF(SMODL%iSNOWM.EQ.iopt_temp_index) THEN !loop through snow model bands + ! --------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark, 2007 + ! Modified by Brian Henn to include snow model, 6/2013 + ! Modified by Martyn Clark to use an elevation band dimension, 12/2025 + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! Describe all variables used in the model (used to define NetCDF output files, etc.) + ! --------------------------------------------------------------------------------------- + ! variable definitions - print *, 'Creating variables for the snow model for ', N_BANDS ,'elevation bands' + USE nrtype - I=I+1; VNAME(I)='swe_tot '; LNAME(I)='total storage as snow '; VUNIT(I)='mm ' + IMPLICIT NONE - DO ISNW=1,N_BANDS ! output each for each snow model band - WRITE(TXT_ISNW,'(I2)') ISNW ! convert band no. to text - IF (ISNW.LT.10) TXT_ISNW(1:1) = '0' ! pad with zeros - I=I+1; VNAME(I)='swe_z'//TXT_ISNW//' '! first create SWE band series - LNAME(I)='elevation band snow water equivalent '; VUNIT(I)='mm ' - I=I+1; VNAME(I)='snwacml_z'//TXT_ISNW ! then the accumulation series - LNAME(I)='new band snowpack accumulation, in water equivalent'; VUNIT(I)='mm timestep-1' - I=I+1; VNAME(I)='snwmelt_z'//TXT_ISNW ! then the melt series - LNAME(I)='band snowpack melt, in water equivalent '; VUNIT(I)='mm timestep-1' - END DO + private + public :: VARDESCRIBE ! subroutine + public :: VNAME, LNAME, VUNIT ! metadata + public :: isBand, isFlux ! flags + public :: NOUTVAR -ENDIF + CHARACTER(LEN=11), DIMENSION(200) :: VNAME ! variable names + CHARACTER(LEN=52), DIMENSION(200) :: LNAME ! variable long names (descrition of variable) + CHARACTER(LEN=13), DIMENSION(200) :: VUNIT ! variable units + logical(lgt), DIMENSION(200) :: isBand ! flag to denote variable for elevation band + logical(lgt), DIMENSION(200) :: isFlux ! flag to denote variable for model fluxes + INTEGER(I4B) :: NOUTVAR ! number of output variables -! model fluxes -I=I+1; VNAME(I)='eff_ppt '; LNAME(I)='effective precipitation rate '; VUNIT(I)='mm timestep-1' -I=I+1; VNAME(I)='satarea '; LNAME(I)='saturated area '; VUNIT(I)='- ' -I=I+1; VNAME(I)='qsurf '; LNAME(I)='surface runoff '; VUNIT(I)='mm timestep-1' -I=I+1; VNAME(I)='evap_1a '; LNAME(I)='evaporation from soil excess zone '; VUNIT(I)='mm timestep-1' -I=I+1; VNAME(I)='evap_1b '; LNAME(I)='evaporation from soil recharge zone '; VUNIT(I)='mm timestep-1' -I=I+1; VNAME(I)='evap_1 '; LNAME(I)='evaporation from the upper soil layer '; VUNIT(I)='mm timestep-1' -I=I+1; VNAME(I)='evap_2 '; LNAME(I)='evaporation from the lower soil layer '; VUNIT(I)='mm timestep-1' -I=I+1; VNAME(I)='rchr2excs '; LNAME(I)='flow from recharge zone to excess zone '; VUNIT(I)='mm timestep-1' -I=I+1; VNAME(I)='tens2free_1'; LNAME(I)='flow from tension to free storage, lower layer '; VUNIT(I)='mm timestep-1' -I=I+1; VNAME(I)='oflow_1 '; LNAME(I)='bucket overflow from upper soil layer '; VUNIT(I)='mm timestep-1' -I=I+1; VNAME(I)='tens2free_2'; LNAME(I)='flow from tension to free storage, lower layer '; VUNIT(I)='mm timestep-1' -I=I+1; VNAME(I)='qintf_1 '; LNAME(I)='interflow '; VUNIT(I)='mm timestep-1' -I=I+1; VNAME(I)='qperc_12 '; LNAME(I)='percolation from upper to lower soil layer '; VUNIT(I)='mm timestep-1' -I=I+1; VNAME(I)='qbase_2 '; LNAME(I)='baseflow '; VUNIT(I)='mm timestep-1' -I=I+1; VNAME(I)='qbase_2a '; LNAME(I)='baseflow from primary baseflow reservoir '; VUNIT(I)='mm timestep-1' -I=I+1; VNAME(I)='qbase_2b '; LNAME(I)='baseflow from secondary baseflow reservoir '; VUNIT(I)='mm timestep-1' -I=I+1; VNAME(I)='oflow_2 '; LNAME(I)='bucket overflow from lower soil layer '; VUNIT(I)='mm timestep-1' -I=I+1; VNAME(I)='oflow_2a '; LNAME(I)='bucket overflow from primary baseflow reservoir '; VUNIT(I)='mm timestep-1' -I=I+1; VNAME(I)='oflow_2b '; LNAME(I)='bucket overflow from secondary baseflow reservoir '; VUNIT(I)='mm timestep-1' -! errors in model states (due to excessive extrapolation) -I=I+1; VNAME(I)='err_tens_1 '; LNAME(I)='excessive extrapolation: upper tension storage '; VUNIT(I)='mm day-1 ' -I=I+1; VNAME(I)='err_tens_1a'; LNAME(I)='excessive extrapolation: upper excs tension storage'; VUNIT(I)='mm day-1 ' -I=I+1; VNAME(I)='err_tens_1b'; LNAME(I)='excessive extrapolation: upper rech tension storage'; VUNIT(I)='mm day-1 ' -I=I+1; VNAME(I)='err_free_1 '; LNAME(I)='excessive extrapolation: upper free storage '; VUNIT(I)='mm day-1 ' -I=I+1; VNAME(I)='err_watr_1 '; LNAME(I)='excessive extrapolation: upper total storage '; VUNIT(I)='mm day-1 ' -I=I+1; VNAME(I)='err_tens_2 '; LNAME(I)='excessive extrapolation: lower tension storage '; VUNIT(I)='mm day-1 ' -I=I+1; VNAME(I)='err_free_2 '; LNAME(I)='excessive extrapolation: lower free storage '; VUNIT(I)='mm day-1 ' -I=I+1; VNAME(I)='err_free_2a'; LNAME(I)='excessive extrapolation: 1st baseflow reservoir '; VUNIT(I)='mm day-1 ' -I=I+1; VNAME(I)='err_free_2b'; LNAME(I)='excessive extrapolation: 2nd baseflow reservoir '; VUNIT(I)='mm day-1 ' -I=I+1; VNAME(I)='err_watr_2 '; LNAME(I)='excessive extrapolation: lower total storage '; VUNIT(I)='mm day-1 ' -! time check -I=I+1; VNAME(I)='chk_time '; LNAME(I)='length of time step included in weighted average '; VUNIT(I)='days ' -! model numerix -I=I+1; VNAME(I)='num_funcs '; LNAME(I)='number of function calls '; VUNIT(I)='- ' -I=I+1; VNAME(I)='numjacobian'; LNAME(I)='number of times the Jacobian is calculated '; VUNIT(I)='- ' -I=I+1; VNAME(I)='sub_accept' ; LNAME(I)='number of sub-steps accepted (taken) '; VUNIT(I)='- ' -I=I+1; VNAME(I)='sub_reject' ; LNAME(I)='number of sub-steps tried but rejected '; VUNIT(I)='- ' -I=I+1; VNAME(I)='sub_noconv' ; LNAME(I)='number of sub-steps tried that did not converge '; VUNIT(I)='- ' -I=I+1; VNAME(I)='max_iterns' ; LNAME(I)='maximum number of iterations in implicit euler '; VUNIT(I)='- ' -! model runoff (for BATEA, assumed to be last) -I=I+1; VNAME(I)='q_instnt '; LNAME(I)='instantaneous runoff '; VUNIT(I)='mm timestep-1' -I=I+1; VNAME(I)='q_routed '; LNAME(I)='routed runoff '; VUNIT(I)='mm timestep-1' + CONTAINS + ! --------------------------------------------------------------------------------------- -print *, 'Setting NOUTVAR (number of forcing, state and flux variables) to', I -NOUTVAR=I + SUBROUTINE VARDESCRIBE() + implicit none + INTEGER(I4B) :: I ! loop through variables + + I=0 ! initialize counter + + ! model forcing + I=I+1; VNAME(I)='ppt '; LNAME(I)='precipitation rate '; VUNIT(I)='mm day-1 '; isBand(i)=.false.; isFlux(i)=.false. + I=I+1; VNAME(I)='pet '; LNAME(I)='potential evapotranspiration rate '; VUNIT(I)='mm day-1 '; isBand(i)=.false.; isFlux(i)=.false. + I=I+1; VNAME(I)='temp '; LNAME(I)='mean air temperature '; VUNIT(I)='deg.C '; isBand(i)=.false.; isFlux(i)=.false. + I=I+1; VNAME(I)='obsq '; LNAME(I)='observed runoff '; VUNIT(I)='mm timestep-1'; isBand(i)=.false.; isFlux(i)=.false. + + ! model states + I=I+1; VNAME(I)='tens_1 '; LNAME(I)='tension storage in the upper layer '; VUNIT(I)='mm '; isBand(i)=.false.; isFlux(i)=.false. + I=I+1; VNAME(I)='tens_1a '; LNAME(I)='tension storage in the soil excess zone '; VUNIT(I)='mm '; isBand(i)=.false.; isFlux(i)=.false. + I=I+1; VNAME(I)='tens_1b '; LNAME(I)='tension storage in the soil recharge zone '; VUNIT(I)='mm '; isBand(i)=.false.; isFlux(i)=.false. + I=I+1; VNAME(I)='free_1 '; LNAME(I)='free storage in the upper layer '; VUNIT(I)='mm '; isBand(i)=.false.; isFlux(i)=.false. + I=I+1; VNAME(I)='watr_1 '; LNAME(I)='total storage in the upper layer '; VUNIT(I)='mm '; isBand(i)=.false.; isFlux(i)=.false. + I=I+1; VNAME(I)='tens_2 '; LNAME(I)='tension storage in the lower layer '; VUNIT(I)='mm '; isBand(i)=.false.; isFlux(i)=.false. + I=I+1; VNAME(I)='free_2 '; LNAME(I)='free storage in the lower layer '; VUNIT(I)='mm '; isBand(i)=.false.; isFlux(i)=.false. + I=I+1; VNAME(I)='free_2a '; LNAME(I)='free storage in the primary baseflow reservoir '; VUNIT(I)='mm '; isBand(i)=.false.; isFlux(i)=.false. + I=I+1; VNAME(I)='free_2b '; LNAME(I)='free storage in the secondary baseflow reservoir '; VUNIT(I)='mm '; isBand(i)=.false.; isFlux(i)=.false. + I=I+1; VNAME(I)='watr_2 '; LNAME(I)='total storage in the lower layer '; VUNIT(I)='mm '; isBand(i)=.false.; isFlux(i)=.false. + + ! snow states + I=I+1; VNAME(I)='swe_tot '; LNAME(I)='total storage as snow '; VUNIT(I)='mm '; isBand(i)=.false.; isFlux(i)=.false. + I=I+1; VNAME(I)='swe_z '; LNAME(I)='elevation band snow water equivalent '; VUNIT(I)='mm '; isBand(i)=.true. ; isFlux(i)=.false. + + ! snow fluxes + I=I+1; VNAME(I)='snwacml_z '; LNAME(I)='new band snowpack accumulation, in water equivalent'; VUNIT(I)='mm timestep-1'; isBand(i)=.true. ; isFlux(i)=.false. + I=I+1; VNAME(I)='snwmelt_z '; LNAME(I)='band snowpack melt, in water equivalent '; VUNIT(I)='mm timestep-1'; isBand(i)=.true. ; isFlux(i)=.false. + + ! model fluxes + I=I+1; VNAME(I)='eff_ppt '; LNAME(I)='effective precipitation rate '; VUNIT(I)='mm timestep-1'; isBand(i)=.false.; isFlux(i)=.true. + I=I+1; VNAME(I)='satarea '; LNAME(I)='saturated area '; VUNIT(I)='- '; isBand(i)=.false.; isFlux(i)=.true. + I=I+1; VNAME(I)='qsurf '; LNAME(I)='surface runoff '; VUNIT(I)='mm timestep-1'; isBand(i)=.false.; isFlux(i)=.true. + I=I+1; VNAME(I)='evap_1a '; LNAME(I)='evaporation from soil excess zone '; VUNIT(I)='mm timestep-1'; isBand(i)=.false.; isFlux(i)=.true. + I=I+1; VNAME(I)='evap_1b '; LNAME(I)='evaporation from soil recharge zone '; VUNIT(I)='mm timestep-1'; isBand(i)=.false.; isFlux(i)=.true. + I=I+1; VNAME(I)='evap_1 '; LNAME(I)='evaporation from the upper soil layer '; VUNIT(I)='mm timestep-1'; isBand(i)=.false.; isFlux(i)=.true. + I=I+1; VNAME(I)='evap_2 '; LNAME(I)='evaporation from the lower soil layer '; VUNIT(I)='mm timestep-1'; isBand(i)=.false.; isFlux(i)=.true. + I=I+1; VNAME(I)='rchr2excs '; LNAME(I)='flow from recharge zone to excess zone '; VUNIT(I)='mm timestep-1'; isBand(i)=.false.; isFlux(i)=.true. + I=I+1; VNAME(I)='tens2free_1'; LNAME(I)='flow from tension to free storage, lower layer '; VUNIT(I)='mm timestep-1'; isBand(i)=.false.; isFlux(i)=.true. + I=I+1; VNAME(I)='oflow_1 '; LNAME(I)='bucket overflow from upper soil layer '; VUNIT(I)='mm timestep-1'; isBand(i)=.false.; isFlux(i)=.true. + I=I+1; VNAME(I)='tens2free_2'; LNAME(I)='flow from tension to free storage, lower layer '; VUNIT(I)='mm timestep-1'; isBand(i)=.false.; isFlux(i)=.true. + I=I+1; VNAME(I)='qintf_1 '; LNAME(I)='interflow '; VUNIT(I)='mm timestep-1'; isBand(i)=.false.; isFlux(i)=.true. + I=I+1; VNAME(I)='qperc_12 '; LNAME(I)='percolation from upper to lower soil layer '; VUNIT(I)='mm timestep-1'; isBand(i)=.false.; isFlux(i)=.true. + I=I+1; VNAME(I)='qbase_2 '; LNAME(I)='baseflow '; VUNIT(I)='mm timestep-1'; isBand(i)=.false.; isFlux(i)=.true. + I=I+1; VNAME(I)='qbase_2a '; LNAME(I)='baseflow from primary baseflow reservoir '; VUNIT(I)='mm timestep-1'; isBand(i)=.false.; isFlux(i)=.true. + I=I+1; VNAME(I)='qbase_2b '; LNAME(I)='baseflow from secondary baseflow reservoir '; VUNIT(I)='mm timestep-1'; isBand(i)=.false.; isFlux(i)=.true. + I=I+1; VNAME(I)='oflow_2 '; LNAME(I)='bucket overflow from lower soil layer '; VUNIT(I)='mm timestep-1'; isBand(i)=.false.; isFlux(i)=.true. + I=I+1; VNAME(I)='oflow_2a '; LNAME(I)='bucket overflow from primary baseflow reservoir '; VUNIT(I)='mm timestep-1'; isBand(i)=.false.; isFlux(i)=.true. + I=I+1; VNAME(I)='oflow_2b '; LNAME(I)='bucket overflow from secondary baseflow reservoir '; VUNIT(I)='mm timestep-1'; isBand(i)=.false.; isFlux(i)=.true. + + ! errors in model states (due to excessive extrapolation) + I=I+1; VNAME(I)='err_tens_1 '; LNAME(I)='excessive extrapolation: upper tension storage '; VUNIT(I)='mm day-1 '; isBand(i)=.false.; isFlux(i)=.false. + I=I+1; VNAME(I)='err_tens_1a'; LNAME(I)='excessive extrapolation: upper excs tension storage'; VUNIT(I)='mm day-1 '; isBand(i)=.false.; isFlux(i)=.false. + I=I+1; VNAME(I)='err_tens_1b'; LNAME(I)='excessive extrapolation: upper rech tension storage'; VUNIT(I)='mm day-1 '; isBand(i)=.false.; isFlux(i)=.false. + I=I+1; VNAME(I)='err_free_1 '; LNAME(I)='excessive extrapolation: upper free storage '; VUNIT(I)='mm day-1 '; isBand(i)=.false.; isFlux(i)=.false. + I=I+1; VNAME(I)='err_watr_1 '; LNAME(I)='excessive extrapolation: upper total storage '; VUNIT(I)='mm day-1 '; isBand(i)=.false.; isFlux(i)=.false. + I=I+1; VNAME(I)='err_tens_2 '; LNAME(I)='excessive extrapolation: lower tension storage '; VUNIT(I)='mm day-1 '; isBand(i)=.false.; isFlux(i)=.false. + I=I+1; VNAME(I)='err_free_2 '; LNAME(I)='excessive extrapolation: lower free storage '; VUNIT(I)='mm day-1 '; isBand(i)=.false.; isFlux(i)=.false. + I=I+1; VNAME(I)='err_free_2a'; LNAME(I)='excessive extrapolation: 1st baseflow reservoir '; VUNIT(I)='mm day-1 '; isBand(i)=.false.; isFlux(i)=.false. + I=I+1; VNAME(I)='err_free_2b'; LNAME(I)='excessive extrapolation: 2nd baseflow reservoir '; VUNIT(I)='mm day-1 '; isBand(i)=.false.; isFlux(i)=.false. + I=I+1; VNAME(I)='err_watr_2 '; LNAME(I)='excessive extrapolation: lower total storage '; VUNIT(I)='mm day-1 '; isBand(i)=.false.; isFlux(i)=.false. + + ! time check + I=I+1; VNAME(I)='chk_time '; LNAME(I)='length of time step included in weighted average '; VUNIT(I)='days '; isBand(i)=.false.; isFlux(i)=.false. + + ! model numerix + I=I+1; VNAME(I)='num_funcs '; LNAME(I)='number of function calls '; VUNIT(I)='- '; isBand(i)=.false.; isFlux(i)=.false. + I=I+1; VNAME(I)='numjacobian'; LNAME(I)='number of times the Jacobian is calculated '; VUNIT(I)='- '; isBand(i)=.false.; isFlux(i)=.false. + I=I+1; VNAME(I)='sub_accept' ; LNAME(I)='number of sub-steps accepted (taken) '; VUNIT(I)='- '; isBand(i)=.false.; isFlux(i)=.false. + I=I+1; VNAME(I)='sub_reject' ; LNAME(I)='number of sub-steps tried but rejected '; VUNIT(I)='- '; isBand(i)=.false.; isFlux(i)=.false. + I=I+1; VNAME(I)='sub_noconv' ; LNAME(I)='number of sub-steps tried that did not converge '; VUNIT(I)='- '; isBand(i)=.false.; isFlux(i)=.false. + I=I+1; VNAME(I)='max_iterns' ; LNAME(I)='maximum number of iterations in implicit euler '; VUNIT(I)='- '; isBand(i)=.false.; isFlux(i)=.false. + + ! model runoff (for BATEA, assumed to be last) + I=I+1; VNAME(I)='q_instnt '; LNAME(I)='instantaneous runoff '; VUNIT(I)='mm timestep-1'; isBand(i)=.false.; isFlux(i)=.false. + I=I+1; VNAME(I)='q_routed '; LNAME(I)='routed runoff '; VUNIT(I)='mm timestep-1'; isBand(i)=.false.; isFlux(i)=.false. + + print *, 'Setting NOUTVAR (number of forcing, state and flux variables) to', I + NOUTVAR=I + + END SUBROUTINE VARDESCRIBE -END SUBROUTINE VARDESCRIBE END MODULE metaoutput diff --git a/build/FUSE_SRC/util/metaparams.f90 b/build/FUSE_SRC/util/metaparams.f90 index 34d313e..41cc6dd 100644 --- a/build/FUSE_SRC/util/metaparams.f90 +++ b/build/FUSE_SRC/util/metaparams.f90 @@ -1,108 +1,119 @@ MODULE metaparams -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2007 -! Modified by Brian Henn to include snow model, 6/2013 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Describe all parameters used in the model (used to define NetCDF output files, etc.) -! --------------------------------------------------------------------------------------- -! variable definitions -USE nrtype -USE multibands -USE model_defn,ONLY:SMODL -USE model_defnames -IMPLICIT NONE -CHARACTER(LEN=11), DIMENSION(200) :: PNAME ! parameter names -CHARACTER(LEN=52), DIMENSION(200) :: PDESC ! parameter long names (description of variable) -CHARACTER(LEN= 8), DIMENSION(200) :: PUNIT ! parameter units -INTEGER(I4B) :: I ! loop through parameter sets -INTEGER(I4B) :: IBAND ! loop through bands -CHARACTER(LEN=2) :: TXT_IBAND ! band index as a character -INTEGER(I4B) :: NOUTPAR ! number of model parameters for output -CONTAINS -! --------------------------------------------------------------------------------------- -SUBROUTINE PARDESCRIBE() -I=0 ! initialize counter -! adjustable model parameters -I=I+1; PNAME(I)='RFERR_ADD '; PDESC(I)='additive rainfall error '; PUNIT(I)='mm ' -I=I+1; PNAME(I)='RFERR_MLT '; PDESC(I)='multiplicative rainfall error '; PUNIT(I)='- ' -I=I+1; PNAME(I)='MAXWATR_1 '; PDESC(I)='maximum total storage in the upper layer '; PUNIT(I)='mm ' -I=I+1; PNAME(I)='MAXWATR_2 '; PDESC(I)='maximum total storage in the lower layer '; PUNIT(I)='mm ' -I=I+1; PNAME(I)='FRACTEN '; PDESC(I)='fraction total storage as tension storage '; PUNIT(I)='- ' -I=I+1; PNAME(I)='FRCHZNE '; PDESC(I)='fraction tension storage in recharge zone '; PUNIT(I)='- ' -I=I+1; PNAME(I)='FPRIMQB '; PDESC(I)='fraction of baseflow in primary reservoir '; PUNIT(I)='- ' -I=I+1; PNAME(I)='RTFRAC1 '; PDESC(I)='fraction of roots in the upper layer '; PUNIT(I)='- ' -I=I+1; PNAME(I)='PERCRTE '; PDESC(I)='percolation rate '; PUNIT(I)='mm day-1' -I=I+1; PNAME(I)='PERCEXP '; PDESC(I)='percolation exponent '; PUNIT(I)='- ' -I=I+1; PNAME(I)='SACPMLT '; PDESC(I)='percolation multiplier in the SAC model '; PUNIT(I)='- ' -I=I+1; PNAME(I)='SACPEXP '; PDESC(I)='percolation exponent in the SAC model '; PUNIT(I)='- ' -I=I+1; PNAME(I)='PERCFRAC '; PDESC(I)='fraction of percolation to tension storage '; PUNIT(I)='- ' -I=I+1; PNAME(I)='FRACLOWZ '; PDESC(I)='fraction of soil excess to lower zone '; PUNIT(I)='- ' -I=I+1; PNAME(I)='IFLWRTE '; PDESC(I)='interflow rate '; PUNIT(I)='mm day-1' -I=I+1; PNAME(I)='BASERTE '; PDESC(I)='baseflow rate '; PUNIT(I)='mm day-1' -I=I+1; PNAME(I)='QB_POWR '; PDESC(I)='baseflow exponent '; PUNIT(I)='- ' -I=I+1; PNAME(I)='QB_PRMS '; PDESC(I)='baseflow depletion rate '; PUNIT(I)='- ' -I=I+1; PNAME(I)='QBRATE_2A '; PDESC(I)='baseflow depletion rate for primary reservoir '; PUNIT(I)='day-1 ' -I=I+1; PNAME(I)='QBRATE_2B '; PDESC(I)='baseflow depletion rate for secondary reservoir '; PUNIT(I)='day-1 ' -I=I+1; PNAME(I)='SAREAMAX '; PDESC(I)='maximum saturated area '; PUNIT(I)='- ' -I=I+1; PNAME(I)='AXV_BEXP '; PDESC(I)='ARNO/VIC b exponent '; PUNIT(I)='- ' -I=I+1; PNAME(I)='LOGLAMB '; PDESC(I)='mean value of the log-transformed topographic index'; PUNIT(I)='log m ' -I=I+1; PNAME(I)='TISHAPE '; PDESC(I)='shape parameter for the topo index Gamma distribtn '; PUNIT(I)='- ' -I=I+1; PNAME(I)='TIMEDELAY '; PDESC(I)='time delay in runoff (routing) '; PUNIT(I)='day ' -I=I+1; PNAME(I)='MBASE '; PDESC(I)='snow model base melt temperature '; PUNIT(I)='deg.C ' -I=I+1; PNAME(I)='MFMAX '; PDESC(I)='snow model maximum melt factor '; PUNIT(I)='mm/(C-d)' -I=I+1; PNAME(I)='MFMIN '; PDESC(I)='snow model minimum melt factor '; PUNIT(I)='mm/(C-d)' -I=I+1; PNAME(I)='PXTEMP '; PDESC(I)='rain-snow partition temperature '; PUNIT(I)='deg.C ' -I=I+1; PNAME(I)='OPG '; PDESC(I)='maximum relative precip difference across the bands'; PUNIT(I)='- ' -I=I+1; PNAME(I)='LAPSE '; PDESC(I)='maximum temperature difference across the bands '; PUNIT(I)='deg.C ' -! derived model parameters -I=I+1; PNAME(I)='MAXTENS_1 '; PDESC(I)='maximum tension storage in the upper layer '; PUNIT(I)='mm ' -I=I+1; PNAME(I)='MAXTENS_1A '; PDESC(I)='maximum storage in the recharge zone '; PUNIT(I)='mm ' -I=I+1; PNAME(I)='MAXTENS_1B '; PDESC(I)='maximum storage in the lower zone '; PUNIT(I)='mm ' -I=I+1; PNAME(I)='MAXFREE_1 '; PDESC(I)='maximum free storage in the upper layer '; PUNIT(I)='mm ' -I=I+1; PNAME(I)='MAXTENS_2 '; PDESC(I)='maximum tension storage in the lower layer '; PUNIT(I)='mm ' -I=I+1; PNAME(I)='MAXFREE_2 '; PDESC(I)='maximum free storage in the lower layer '; PUNIT(I)='mm ' -I=I+1; PNAME(I)='MAXFREE_2A '; PDESC(I)='maximum storage in the primary baseflow reservoir '; PUNIT(I)='mm ' -I=I+1; PNAME(I)='MAXFREE_2B '; PDESC(I)='maximum storage in the secondary baseflow reservoir'; PUNIT(I)='mm ' -I=I+1; PNAME(I)='RTFRAC2 '; PDESC(I)='fraction of roots in the lower layer '; PUNIT(I)='- ' -I=I+1; PNAME(I)='QBSAT '; PDESC(I)='baseflow at saturation (derived parameter) '; PUNIT(I)='mm day-1' -I=I+1; PNAME(I)='POWLAMB '; PDESC(I)='mean value of power-transformed topographic index '; PUNIT(I)='m**(1/n)' -I=I+1; PNAME(I)='MAXPOW '; PDESC(I)='max value of power-transformed topographic index '; PUNIT(I)='m**(1/n)' -! model bands parameters -IF(SMODL%iSNOWM.EQ.iopt_temp_index) THEN !loop through snow model bands - I=I+1; PNAME(I)='N_BANDS '; PDESC(I)='number of basin bands in model '; PUNIT(I)='= ' - I=I+1; PNAME(I)='Z_FORCING '; PDESC(I)='elevation of model forcing data '; PUNIT(I)='m ' - DO IBAND=1,N_BANDS - WRITE(TXT_IBAND,'(I2)') IBAND ! convert band no. to text - IF (IBAND.LT.10) TXT_IBAND(1:1) = '0' ! pad with zeros - I=I+1; PNAME(I)='Z_MID'//TXT_IBAND//' '; PDESC(I)='basin band mid-point elevation '; PUNIT(I)='m ' - I=I+1; PNAME(I)='AF'//TXT_IBAND//' '; PDESC(I)='basin band area fraction '; PUNIT(I)='- ' - END DO -ENDIF -! numerical solution parameters -I=I+1; PNAME(I)='SOLUTION '; PDESC(I)='0=explicit euler; 1=implicit euler '; PUNIT(I)='- ' -I=I+1; PNAME(I)='TIMSTEP_TYP'; PDESC(I)='0=fixed time steps; 1=adaptive time steps '; PUNIT(I)='- ' -I=I+1; PNAME(I)='INITL_GUESS'; PDESC(I)='0=old state; 1=explicit half-step; 2=expl full-step'; PUNIT(I)='- ' -I=I+1; PNAME(I)='JAC_RECOMPT'; PDESC(I)='0=variable; 1=constant sub-step; 2=const full step '; PUNIT(I)='- ' -I=I+1; PNAME(I)='CK_OVRSHOOT'; PDESC(I)='0=always take full newton step; 1=line search '; PUNIT(I)='- ' -I=I+1; PNAME(I)='SMALL_ESTEP'; PDESC(I)='0=step truncation; 1=look-ahead; 2=step absorption '; PUNIT(I)='- ' -I=I+1; PNAME(I)='ERRTRUNCABS'; PDESC(I)='absolute temporal truncation error tolerance '; PUNIT(I)='mm ' -I=I+1; PNAME(I)='ERRTRUNCREL'; PDESC(I)='relative temporal truncation error tolerance '; PUNIT(I)='mm ' -I=I+1; PNAME(I)='ERRITERFUNC'; PDESC(I)='iteration convergence tolerance for function values'; PUNIT(I)='mm ' -I=I+1; PNAME(I)='ERR_ITER_DX'; PDESC(I)='iteration convergence tolerance for dx '; PUNIT(I)='- ' -I=I+1; PNAME(I)='THRESH_FRZE'; PDESC(I)='threshold for freezing the Jacobian '; PUNIT(I)='mm ' -I=I+1; PNAME(I)='FSTATE_MIN '; PDESC(I)='fractional minimum value of state '; PUNIT(I)='- ' -I=I+1; PNAME(I)='STEP_SAFETY'; PDESC(I)='safety factor in step-size equation '; PUNIT(I)='- ' -I=I+1; PNAME(I)='RMIN '; PDESC(I)='minimum step size multiplier '; PUNIT(I)='- ' -I=I+1; PNAME(I)='RMAX '; PDESC(I)='maximum step size multiplier '; PUNIT(I)='- ' -I=I+1; PNAME(I)='NITER_TOTAL'; PDESC(I)='maximum number of iterations in the implicit scheme'; PUNIT(I)='- ' -I=I+1; PNAME(I)='MIN_TSTEP '; PDESC(I)='minimum time step length '; PUNIT(I)='day ' -I=I+1; PNAME(I)='MAX_TSTEP '; PDESC(I)='maximum time step length '; PUNIT(I)='day ' -! parameter identifier -I=I+1; PNAME(I)='SOBOL_INDX '; PDESC(I)='indentifier for Sobol parameter set '; PUNIT(I)='- ' -NOUTPAR=I -END SUBROUTINE PARDESCRIBE + + ! --------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark, 2007 + ! Modified by Brian Henn to include snow model, 6/2013 + ! Modified by Martyn Clark to avoid per-band parameters, 12/2025 + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! Describe all parameters used in the model (used to define NetCDF output files, etc.) + ! --------------------------------------------------------------------------------------- + + ! variable definitions + USE nrtype + + IMPLICIT NONE + + private + public :: PARDESCRIBE ! make subroutine public + public :: PNAME, PDESC, PUNIT, isBand ! make metadata variables public + public :: NOUTPAR ! make number of output parameters public + + CHARACTER(LEN=11), DIMENSION(200) :: PNAME ! parameter names + CHARACTER(LEN=52), DIMENSION(200) :: PDESC ! parameter long names (description of variable) + CHARACTER(LEN= 8), DIMENSION(200) :: PUNIT ! parameter units + logical(lgt) , DIMENSION(200) :: isBand ! flag for the parameter dimension + INTEGER(I4B) :: NOUTPAR ! number of model parameters for output + + CONTAINS + ! --------------------------------------------------------------------------------------- + + SUBROUTINE PARDESCRIBE() + implicit none + INTEGER(I4B) :: I ! loop through parameter sets + + I=0 ! initialize counter + + ! adjustable model parameters + I=I+1; PNAME(I)='RFERR_ADD '; PDESC(I)='additive rainfall error '; PUNIT(I)='mm '; isBand(i)=.false. + I=I+1; PNAME(I)='RFERR_MLT '; PDESC(I)='multiplicative rainfall error '; PUNIT(I)='- '; isBand(i)=.false. + I=I+1; PNAME(I)='MAXWATR_1 '; PDESC(I)='maximum total storage in the upper layer '; PUNIT(I)='mm '; isBand(i)=.false. + I=I+1; PNAME(I)='MAXWATR_2 '; PDESC(I)='maximum total storage in the lower layer '; PUNIT(I)='mm '; isBand(i)=.false. + I=I+1; PNAME(I)='FRACTEN '; PDESC(I)='fraction total storage as tension storage '; PUNIT(I)='- '; isBand(i)=.false. + I=I+1; PNAME(I)='FRCHZNE '; PDESC(I)='fraction tension storage in recharge zone '; PUNIT(I)='- '; isBand(i)=.false. + I=I+1; PNAME(I)='FPRIMQB '; PDESC(I)='fraction of baseflow in primary reservoir '; PUNIT(I)='- '; isBand(i)=.false. + I=I+1; PNAME(I)='RTFRAC1 '; PDESC(I)='fraction of roots in the upper layer '; PUNIT(I)='- '; isBand(i)=.false. + I=I+1; PNAME(I)='PERCRTE '; PDESC(I)='percolation rate '; PUNIT(I)='mm day-1'; isBand(i)=.false. + I=I+1; PNAME(I)='PERCEXP '; PDESC(I)='percolation exponent '; PUNIT(I)='- '; isBand(i)=.false. + I=I+1; PNAME(I)='SACPMLT '; PDESC(I)='percolation multiplier in the SAC model '; PUNIT(I)='- '; isBand(i)=.false. + I=I+1; PNAME(I)='SACPEXP '; PDESC(I)='percolation exponent in the SAC model '; PUNIT(I)='- '; isBand(i)=.false. + I=I+1; PNAME(I)='PERCFRAC '; PDESC(I)='fraction of percolation to tension storage '; PUNIT(I)='- '; isBand(i)=.false. + I=I+1; PNAME(I)='FRACLOWZ '; PDESC(I)='fraction of soil excess to lower zone '; PUNIT(I)='- '; isBand(i)=.false. + I=I+1; PNAME(I)='IFLWRTE '; PDESC(I)='interflow rate '; PUNIT(I)='mm day-1'; isBand(i)=.false. + I=I+1; PNAME(I)='BASERTE '; PDESC(I)='baseflow rate '; PUNIT(I)='mm day-1'; isBand(i)=.false. + I=I+1; PNAME(I)='QB_POWR '; PDESC(I)='baseflow exponent '; PUNIT(I)='- '; isBand(i)=.false. + I=I+1; PNAME(I)='QB_PRMS '; PDESC(I)='baseflow depletion rate '; PUNIT(I)='- '; isBand(i)=.false. + I=I+1; PNAME(I)='QBRATE_2A '; PDESC(I)='baseflow depletion rate for primary reservoir '; PUNIT(I)='day-1 '; isBand(i)=.false. + I=I+1; PNAME(I)='QBRATE_2B '; PDESC(I)='baseflow depletion rate for secondary reservoir '; PUNIT(I)='day-1 '; isBand(i)=.false. + I=I+1; PNAME(I)='SAREAMAX '; PDESC(I)='maximum saturated area '; PUNIT(I)='- '; isBand(i)=.false. + I=I+1; PNAME(I)='AXV_BEXP '; PDESC(I)='ARNO/VIC b exponent '; PUNIT(I)='- '; isBand(i)=.false. + I=I+1; PNAME(I)='LOGLAMB '; PDESC(I)='mean value of the log-transformed topographic index'; PUNIT(I)='log m '; isBand(i)=.false. + I=I+1; PNAME(I)='TISHAPE '; PDESC(I)='shape parameter for the topo index Gamma distribtn '; PUNIT(I)='- '; isBand(i)=.false. + I=I+1; PNAME(I)='TIMEDELAY '; PDESC(I)='time delay in runoff (routing) '; PUNIT(I)='day '; isBand(i)=.false. + I=I+1; PNAME(I)='MBASE '; PDESC(I)='snow model base melt temperature '; PUNIT(I)='deg.C '; isBand(i)=.false. + I=I+1; PNAME(I)='MFMAX '; PDESC(I)='snow model maximum melt factor '; PUNIT(I)='mm/(C-d)'; isBand(i)=.false. + I=I+1; PNAME(I)='MFMIN '; PDESC(I)='snow model minimum melt factor '; PUNIT(I)='mm/(C-d)'; isBand(i)=.false. + I=I+1; PNAME(I)='PXTEMP '; PDESC(I)='rain-snow partition temperature '; PUNIT(I)='deg.C '; isBand(i)=.false. + I=I+1; PNAME(I)='OPG '; PDESC(I)='maximum relative precip difference across the bands'; PUNIT(I)='- '; isBand(i)=.false. + I=I+1; PNAME(I)='LAPSE '; PDESC(I)='maximum temperature difference across the bands '; PUNIT(I)='deg.C '; isBand(i)=.false. + + ! derived model parameters + I=I+1; PNAME(I)='MAXTENS_1 '; PDESC(I)='maximum tension storage in the upper layer '; PUNIT(I)='mm '; isBand(i)=.false. + I=I+1; PNAME(I)='MAXTENS_1A '; PDESC(I)='maximum storage in the recharge zone '; PUNIT(I)='mm '; isBand(i)=.false. + I=I+1; PNAME(I)='MAXTENS_1B '; PDESC(I)='maximum storage in the lower zone '; PUNIT(I)='mm '; isBand(i)=.false. + I=I+1; PNAME(I)='MAXFREE_1 '; PDESC(I)='maximum free storage in the upper layer '; PUNIT(I)='mm '; isBand(i)=.false. + I=I+1; PNAME(I)='MAXTENS_2 '; PDESC(I)='maximum tension storage in the lower layer '; PUNIT(I)='mm '; isBand(i)=.false. + I=I+1; PNAME(I)='MAXFREE_2 '; PDESC(I)='maximum free storage in the lower layer '; PUNIT(I)='mm '; isBand(i)=.false. + I=I+1; PNAME(I)='MAXFREE_2A '; PDESC(I)='maximum storage in the primary baseflow reservoir '; PUNIT(I)='mm '; isBand(i)=.false. + I=I+1; PNAME(I)='MAXFREE_2B '; PDESC(I)='maximum storage in the secondary baseflow reservoir'; PUNIT(I)='mm '; isBand(i)=.false. + I=I+1; PNAME(I)='RTFRAC2 '; PDESC(I)='fraction of roots in the lower layer '; PUNIT(I)='- '; isBand(i)=.false. + I=I+1; PNAME(I)='QBSAT '; PDESC(I)='baseflow at saturation (derived parameter) '; PUNIT(I)='mm day-1'; isBand(i)=.false. + I=I+1; PNAME(I)='POWLAMB '; PDESC(I)='mean value of power-transformed topographic index '; PUNIT(I)='m**(1/n)'; isBand(i)=.false. + I=I+1; PNAME(I)='MAXPOW '; PDESC(I)='max value of power-transformed topographic index '; PUNIT(I)='m**(1/n)'; isBand(i)=.false. + + ! model bands parameters + I=I+1; PNAME(I)='N_BANDS '; PDESC(I)='number of basin bands in model '; PUNIT(I)='= '; isBand(i)=.false. + I=I+1; PNAME(I)='Z_FORCING '; PDESC(I)='elevation of model forcing data '; PUNIT(I)='m '; isBand(i)=.false. + I=I+1; PNAME(I)='Z_MID '; PDESC(I)='basin band mid-point elevation (bands) '; PUNIT(I)='m '; isBand(i)=.true. + I=I+1; PNAME(I)='AF '; PDESC(I)='basin band area fraction (bands) '; PUNIT(I)='- '; isBand(i)=.true. + + ! numerical solution parameters + I=I+1; PNAME(I)='SOLUTION '; PDESC(I)='0=explicit euler; 1=implicit euler '; PUNIT(I)='- '; isBand(i)=.false. + I=I+1; PNAME(I)='TIMSTEP_TYP'; PDESC(I)='0=fixed time steps; 1=adaptive time steps '; PUNIT(I)='- '; isBand(i)=.false. + I=I+1; PNAME(I)='INITL_GUESS'; PDESC(I)='0=old state; 1=explicit half-step; 2=expl full-step'; PUNIT(I)='- '; isBand(i)=.false. + I=I+1; PNAME(I)='JAC_RECOMPT'; PDESC(I)='0=variable; 1=constant sub-step; 2=const full step '; PUNIT(I)='- '; isBand(i)=.false. + I=I+1; PNAME(I)='CK_OVRSHOOT'; PDESC(I)='0=always take full newton step; 1=line search '; PUNIT(I)='- '; isBand(i)=.false. + I=I+1; PNAME(I)='SMALL_ESTEP'; PDESC(I)='0=step truncation; 1=look-ahead; 2=step absorption '; PUNIT(I)='- '; isBand(i)=.false. + I=I+1; PNAME(I)='ERRTRUNCABS'; PDESC(I)='absolute temporal truncation error tolerance '; PUNIT(I)='mm '; isBand(i)=.false. + I=I+1; PNAME(I)='ERRTRUNCREL'; PDESC(I)='relative temporal truncation error tolerance '; PUNIT(I)='mm '; isBand(i)=.false. + I=I+1; PNAME(I)='ERRITERFUNC'; PDESC(I)='iteration convergence tolerance for function values'; PUNIT(I)='mm '; isBand(i)=.false. + I=I+1; PNAME(I)='ERR_ITER_DX'; PDESC(I)='iteration convergence tolerance for dx '; PUNIT(I)='- '; isBand(i)=.false. + I=I+1; PNAME(I)='THRESH_FRZE'; PDESC(I)='threshold for freezing the Jacobian '; PUNIT(I)='mm '; isBand(i)=.false. + I=I+1; PNAME(I)='FSTATE_MIN '; PDESC(I)='fractional minimum value of state '; PUNIT(I)='- '; isBand(i)=.false. + I=I+1; PNAME(I)='STEP_SAFETY'; PDESC(I)='safety factor in step-size equation '; PUNIT(I)='- '; isBand(i)=.false. + I=I+1; PNAME(I)='RMIN '; PDESC(I)='minimum step size multiplier '; PUNIT(I)='- '; isBand(i)=.false. + I=I+1; PNAME(I)='RMAX '; PDESC(I)='maximum step size multiplier '; PUNIT(I)='- '; isBand(i)=.false. + I=I+1; PNAME(I)='NITER_TOTAL'; PDESC(I)='maximum number of iterations in the implicit scheme'; PUNIT(I)='- '; isBand(i)=.false. + I=I+1; PNAME(I)='MIN_TSTEP '; PDESC(I)='minimum time step length '; PUNIT(I)='day '; isBand(i)=.false. + I=I+1; PNAME(I)='MAX_TSTEP '; PDESC(I)='maximum time step length '; PUNIT(I)='day '; isBand(i)=.false. + + ! parameter identifier + I=I+1; PNAME(I)='SOBOL_INDX '; PDESC(I)='indentifier for Sobol parameter set '; PUNIT(I)='- '; isBand(i)=.false. + + NOUTPAR=I + + END SUBROUTINE PARDESCRIBE END MODULE metaparams diff --git a/build/FUSE_SRC/util/parextract.f90 b/build/FUSE_SRC/util/parextract.f90 index e9499d6..7eba011 100644 --- a/build/FUSE_SRC/util/parextract.f90 +++ b/build/FUSE_SRC/util/parextract.f90 @@ -1,237 +1,129 @@ MODULE PAREXTRACT_MODULE -IMPLICIT NONE -CONTAINS -! --------------------------------------------------------------------------------------- -! --------------------------------------------------------------------------------------- -SUBROUTINE GET_PARSET(PARSET) -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2008 -! Modified by Brian Henn to include snow model, 6/2013 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Extracts an entire parameter set from a data structure, based on the list of parameters -! in LPARAM -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -USE multiparam ! model parameters -IMPLICIT NONE -! output -REAL(SP), INTENT(INOUT), DIMENSION(:) :: PARSET ! parameter set -! local -INTEGER(I4B) :: IPAR ! looping -! --------------------------------------------------------------------------------------- -DO IPAR=1,NUMPAR ! NUMPAR is stored in module multiparam - PARSET(IPAR) = PAREXTRACT(LPARAM(IPAR)%PARNAME) -END DO -! --------------------------------------------------------------------------------------- -END SUBROUTINE GET_PARSET -! --------------------------------------------------------------------------------------- -! --------------------------------------------------------------------------------------- -! --------------------------------------------------------------------------------------- -PURE FUNCTION PAREXTRACT(PARNAME) -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2007 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Extracts parameter from data structures -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -USE multiparam ! model parameters -USE model_numerix ! model numerix parameters -USE multibands ! model basin band data -IMPLICIT NONE -! input -CHARACTER(*), INTENT(IN) :: PARNAME ! parameter name -! internal -REAL(SP) :: XVAR ! variable -! output -REAL(SP) :: PAREXTRACT ! FUNCTION name -! --------------------------------------------------------------------------------------- -SELECT CASE (TRIM(PARNAME)) - ! model parameters - CASE ('RFERR_ADD') ; XVAR = MPARAM%RFERR_ADD - CASE ('RFERR_MLT') ; XVAR = MPARAM%RFERR_MLT - CASE ('RFH1_MEAN') ; XVAR = MPARAM%RFH1_MEAN - CASE ('RFH2_SDEV') ; XVAR = MPARAM%RFH2_SDEV - CASE ('RH1P_MEAN') ; XVAR = MPARAM%RH1P_MEAN - CASE ('RH1P_SDEV') ; XVAR = MPARAM%RH1P_SDEV - CASE ('RH2P_MEAN') ; XVAR = MPARAM%RH2P_MEAN - CASE ('RH2P_SDEV') ; XVAR = MPARAM%RH2P_SDEV - CASE ('MAXWATR_1') ; XVAR = MPARAM%MAXWATR_1 - CASE ('MAXWATR_2') ; XVAR = MPARAM%MAXWATR_2 - CASE ('FRACTEN') ; XVAR = MPARAM%FRACTEN - CASE ('FRCHZNE') ; XVAR = MPARAM%FRCHZNE - CASE ('FPRIMQB') ; XVAR = MPARAM%FPRIMQB - CASE ('RTFRAC1') ; XVAR = MPARAM%RTFRAC1 - CASE ('PERCRTE') ; XVAR = MPARAM%PERCRTE - CASE ('PERCEXP') ; XVAR = MPARAM%PERCEXP - CASE ('SACPMLT') ; XVAR = MPARAM%SACPMLT - CASE ('SACPEXP') ; XVAR = MPARAM%SACPEXP - CASE ('PERCFRAC') ; XVAR = MPARAM%PERCFRAC - CASE ('FRACLOWZ') ; XVAR = MPARAM%FRACLOWZ - CASE ('IFLWRTE') ; XVAR = MPARAM%IFLWRTE - CASE ('BASERTE') ; XVAR = MPARAM%BASERTE - CASE ('QB_POWR') ; XVAR = MPARAM%QB_POWR - CASE ('QB_PRMS') ; XVAR = MPARAM%QB_PRMS - CASE ('QBRATE_2A') ; XVAR = MPARAM%QBRATE_2A - CASE ('QBRATE_2B') ; XVAR = MPARAM%QBRATE_2B - CASE ('SAREAMAX') ; XVAR = MPARAM%SAREAMAX - CASE ('AXV_BEXP') ; XVAR = MPARAM%AXV_BEXP - CASE ('LOGLAMB') ; XVAR = MPARAM%LOGLAMB - CASE ('TISHAPE') ; XVAR = MPARAM%TISHAPE - CASE ('TIMEDELAY') ; XVAR = MPARAM%TIMEDELAY - CASE ('MBASE') ; XVAR = MPARAM%MBASE - CASE ('MFMAX') ; XVAR = MPARAM%MFMAX - CASE ('MFMIN') ; XVAR = MPARAM%MFMIN - CASE ('PXTEMP') ; XVAR = MPARAM%PXTEMP - CASE ('OPG') ; XVAR = MPARAM%OPG - CASE ('LAPSE') ; XVAR = MPARAM%LAPSE - ! derived parameters - CASE ('MAXTENS_1') ; XVAR = DPARAM%MAXTENS_1 - CASE ('MAXTENS_1A') ; XVAR = DPARAM%MAXTENS_1A - CASE ('MAXTENS_1B') ; XVAR = DPARAM%MAXTENS_1B - CASE ('MAXFREE_1') ; XVAR = DPARAM%MAXFREE_1 - CASE ('MAXTENS_2') ; XVAR = DPARAM%MAXTENS_2 - CASE ('MAXFREE_2') ; XVAR = DPARAM%MAXFREE_2 - CASE ('MAXFREE_2A') ; XVAR = DPARAM%MAXFREE_2A - CASE ('MAXFREE_2B') ; XVAR = DPARAM%MAXFREE_2B - CASE ('QBSAT') ; XVAR = DPARAM%QBSAT - CASE ('RTFRAC2') ; XVAR = DPARAM%RTFRAC2 - CASE ('POWLAMB') ; XVAR = DPARAM%POWLAMB - CASE ('MAXPOW') ; XVAR = DPARAM%MAXPOW - ! basin band data - CASE ('Z_MID01') ; XVAR = MBANDS(1)%Z_MID - CASE ('AF01') ; XVAR = MBANDS(1)%AF - CASE ('Z_MID02') ; XVAR = MBANDS(2)%Z_MID - CASE ('AF02') ; XVAR = MBANDS(2)%AF - CASE ('Z_MID03') ; XVAR = MBANDS(3)%Z_MID - CASE ('AF03') ; XVAR = MBANDS(3)%AF - CASE ('Z_MID04') ; XVAR = MBANDS(4)%Z_MID - CASE ('AF04') ; XVAR = MBANDS(4)%AF - CASE ('Z_MID05') ; XVAR = MBANDS(5)%Z_MID - CASE ('AF05') ; XVAR = MBANDS(5)%AF - CASE ('Z_MID06') ; XVAR = MBANDS(6)%Z_MID - CASE ('AF06') ; XVAR = MBANDS(6)%AF - CASE ('Z_MID07') ; XVAR = MBANDS(7)%Z_MID - CASE ('AF07') ; XVAR = MBANDS(7)%AF - CASE ('Z_MID08') ; XVAR = MBANDS(8)%Z_MID - CASE ('AF08') ; XVAR = MBANDS(8)%AF - CASE ('Z_MID09') ; XVAR = MBANDS(9)%Z_MID - CASE ('AF09') ; XVAR = MBANDS(9)%AF - CASE ('Z_MID10') ; XVAR = MBANDS(10)%Z_MID - CASE ('AF10') ; XVAR = MBANDS(10)%AF - CASE ('Z_MID11') ; XVAR = MBANDS(11)%Z_MID - CASE ('AF11') ; XVAR = MBANDS(11)%AF - CASE ('Z_MID12') ; XVAR = MBANDS(12)%Z_MID - CASE ('AF12') ; XVAR = MBANDS(12)%AF - CASE ('Z_MID13') ; XVAR = MBANDS(13)%Z_MID - CASE ('AF13') ; XVAR = MBANDS(13)%AF - CASE ('Z_MID14') ; XVAR = MBANDS(14)%Z_MID - CASE ('AF14') ; XVAR = MBANDS(14)%AF - CASE ('Z_MID15') ; XVAR = MBANDS(15)%Z_MID - CASE ('AF15') ; XVAR = MBANDS(15)%AF - CASE ('Z_MID16') ; XVAR = MBANDS(16)%Z_MID - CASE ('AF16') ; XVAR = MBANDS(16)%AF - CASE ('Z_MID17') ; XVAR = MBANDS(17)%Z_MID - CASE ('AF17') ; XVAR = MBANDS(17)%AF - CASE ('Z_MID18') ; XVAR = MBANDS(18)%Z_MID - CASE ('AF18') ; XVAR = MBANDS(18)%AF - CASE ('Z_MID19') ; XVAR = MBANDS(19)%Z_MID - CASE ('AF19') ; XVAR = MBANDS(19)%AF - CASE ('Z_MID20') ; XVAR = MBANDS(20)%Z_MID - CASE ('AF20') ; XVAR = MBANDS(20)%AF - CASE ('Z_MID21') ; XVAR = MBANDS(21)%Z_MID - CASE ('AF21') ; XVAR = MBANDS(21)%AF - CASE ('Z_MID22') ; XVAR = MBANDS(22)%Z_MID - CASE ('AF22') ; XVAR = MBANDS(22)%AF - CASE ('Z_MID23') ; XVAR = MBANDS(23)%Z_MID - CASE ('AF23') ; XVAR = MBANDS(23)%AF - CASE ('Z_MID24') ; XVAR = MBANDS(24)%Z_MID - CASE ('AF24') ; XVAR = MBANDS(24)%AF - CASE ('Z_MID25') ; XVAR = MBANDS(25)%Z_MID - CASE ('AF25') ; XVAR = MBANDS(25)%AF - CASE ('Z_MID26') ; XVAR = MBANDS(26)%Z_MID - CASE ('AF26') ; XVAR = MBANDS(26)%AF - CASE ('Z_MID27') ; XVAR = MBANDS(27)%Z_MID - CASE ('AF27') ; XVAR = MBANDS(27)%AF - CASE ('Z_MID28') ; XVAR = MBANDS(28)%Z_MID - CASE ('AF28') ; XVAR = MBANDS(28)%AF - CASE ('Z_MID29') ; XVAR = MBANDS(29)%Z_MID - CASE ('AF29') ; XVAR = MBANDS(29)%AF - CASE ('Z_MID30') ; XVAR = MBANDS(30)%Z_MID - CASE ('AF30') ; XVAR = MBANDS(30)%AF - CASE ('Z_MID31') ; XVAR = MBANDS(31)%Z_MID - CASE ('AF31') ; XVAR = MBANDS(31)%AF - CASE ('Z_MID32') ; XVAR = MBANDS(32)%Z_MID - CASE ('AF32') ; XVAR = MBANDS(32)%AF - CASE ('Z_MID33') ; XVAR = MBANDS(33)%Z_MID - CASE ('AF33') ; XVAR = MBANDS(33)%AF - CASE ('Z_MID34') ; XVAR = MBANDS(34)%Z_MID - CASE ('AF34') ; XVAR = MBANDS(34)%AF - CASE ('Z_MID35') ; XVAR = MBANDS(35)%Z_MID - CASE ('AF35') ; XVAR = MBANDS(35)%AF - CASE ('Z_MID36') ; XVAR = MBANDS(36)%Z_MID - CASE ('AF36') ; XVAR = MBANDS(36)%AF - CASE ('Z_MID37') ; XVAR = MBANDS(37)%Z_MID - CASE ('AF37') ; XVAR = MBANDS(37)%AF - CASE ('Z_MID38') ; XVAR = MBANDS(38)%Z_MID - CASE ('AF38') ; XVAR = MBANDS(38)%AF - CASE ('Z_MID39') ; XVAR = MBANDS(39)%Z_MID - CASE ('AF39') ; XVAR = MBANDS(39)%AF - CASE ('Z_MID40') ; XVAR = MBANDS(40)%Z_MID - CASE ('AF40') ; XVAR = MBANDS(40)%AF - CASE ('Z_MID41') ; XVAR = MBANDS(41)%Z_MID - CASE ('AF41') ; XVAR = MBANDS(41)%AF - CASE ('Z_MID42') ; XVAR = MBANDS(42)%Z_MID - CASE ('AF42') ; XVAR = MBANDS(42)%AF - CASE ('Z_MID43') ; XVAR = MBANDS(43)%Z_MID - CASE ('AF43') ; XVAR = MBANDS(43)%AF - CASE ('Z_MID44') ; XVAR = MBANDS(44)%Z_MID - CASE ('AF44') ; XVAR = MBANDS(44)%AF - CASE ('Z_MID45') ; XVAR = MBANDS(45)%Z_MID - CASE ('AF45') ; XVAR = MBANDS(45)%AF - CASE ('Z_MID46') ; XVAR = MBANDS(46)%Z_MID - CASE ('AF46') ; XVAR = MBANDS(46)%AF - CASE ('Z_MID47') ; XVAR = MBANDS(47)%Z_MID - CASE ('AF47') ; XVAR = MBANDS(47)%AF - CASE ('Z_MID48') ; XVAR = MBANDS(48)%Z_MID - CASE ('AF48') ; XVAR = MBANDS(48)%AF - CASE ('Z_MID49') ; XVAR = MBANDS(49)%Z_MID - CASE ('AF49') ; XVAR = MBANDS(49)%AF - CASE ('Z_MID50') ; XVAR = MBANDS(50)%Z_MID - CASE ('AF50') ; XVAR = MBANDS(50)%AF - CASE('N_BANDS') ; XVAR = N_BANDS - CASE('Z_FORCING') ; XVAR = Z_FORCING - ! numerical solution parameters - CASE ('SOLUTION') ; XVAR = REAL(SOLUTION_METHOD, KIND(SP)) - CASE ('TIMSTEP_TYP'); XVAR = REAL(TEMPORAL_ERROR_CONTROL, KIND(SP)) - CASE ('INITL_GUESS'); XVAR = REAL(INITIAL_NEWTON, KIND(SP)) - CASE ('JAC_RECOMPT'); XVAR = REAL(JAC_RECOMPUTE, KIND(SP)) - CASE ('CK_OVRSHOOT'); XVAR = REAL(CHECK_OVERSHOOT, KIND(SP)) - CASE ('SMALL_ESTEP'); XVAR = REAL(SMALL_ENDSTEP, KIND(SP)) - CASE ('ERRTRUNCABS'); XVAR = ERR_TRUNC_ABS - CASE ('ERRTRUNCREL'); XVAR = ERR_TRUNC_REL - CASE ('ERRITERFUNC'); XVAR = ERR_ITER_FUNC - CASE ('ERR_ITER_DX'); XVAR = ERR_ITER_DX - CASE ('THRESH_FRZE'); XVAR = THRESH_FRZE - CASE ('FSTATE_MIN') ; XVAR = FRACSTATE_MIN - CASE ('STEP_SAFETY'); XVAR = SAFETY - CASE ('RMIN') ; XVAR = RMIN - CASE ('RMAX') ; XVAR = RMAX - CASE ('NITER_TOTAL'); XVAR = REAL(NITER_TOTAL, KIND(SP)) - CASE ('MIN_TSTEP') ; XVAR = MIN_TSTEP - CASE ('MAX_TSTEP') ; XVAR = MAX_TSTEP - ! Sobol identifier - CASE ('SOBOL_INDX') ; XVAR = REAL(SOBOL_INDX, KIND(SP)) -END SELECT -! and, save the output -PAREXTRACT = XVAR -! --------------------------------------------------------------------------------------- -END FUNCTION PAREXTRACT + + USE nrtype ! variable types, etc. + + IMPLICIT NONE + + private + public :: PAREXTRACT ! make function public + + CONTAINS + + ! --------------------------------------------------------------------------------------- + ! --------------------------------------------------------------------------------------- + ! --------------------------------------------------------------------------------------- + PURE FUNCTION PAREXTRACT(PARNAME) + ! --------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark, 2007 + ! Modified by Martyn Clark to remove elevation band parameters (handled separately) + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! Extracts parameter from data structures + ! --------------------------------------------------------------------------------------- + USE model_numerix ! model numerix parameters + USE globaldata, only: NA_VALUE_SP ! missing value + USE multiparam, only: MPARAM, DPARAM, SOBOL_INDX ! model parameters + USE multibands, only: Z_FORCING ! scalar variables from elevation bands + IMPLICIT NONE + ! input + CHARACTER(*), INTENT(IN) :: PARNAME ! parameter name + ! internal + REAL(SP) :: XVAR ! variable + ! output + REAL(SP) :: PAREXTRACT ! FUNCTION name + ! --------------------------------------------------------------------------------------- + SELECT CASE (TRIM(PARNAME)) + + ! model parameters + CASE ('RFERR_ADD') ; XVAR = MPARAM%RFERR_ADD + CASE ('RFERR_MLT') ; XVAR = MPARAM%RFERR_MLT + CASE ('RFH1_MEAN') ; XVAR = MPARAM%RFH1_MEAN + CASE ('RFH2_SDEV') ; XVAR = MPARAM%RFH2_SDEV + CASE ('RH1P_MEAN') ; XVAR = MPARAM%RH1P_MEAN + CASE ('RH1P_SDEV') ; XVAR = MPARAM%RH1P_SDEV + CASE ('RH2P_MEAN') ; XVAR = MPARAM%RH2P_MEAN + CASE ('RH2P_SDEV') ; XVAR = MPARAM%RH2P_SDEV + CASE ('MAXWATR_1') ; XVAR = MPARAM%MAXWATR_1 + CASE ('MAXWATR_2') ; XVAR = MPARAM%MAXWATR_2 + CASE ('FRACTEN') ; XVAR = MPARAM%FRACTEN + CASE ('FRCHZNE') ; XVAR = MPARAM%FRCHZNE + CASE ('FPRIMQB') ; XVAR = MPARAM%FPRIMQB + CASE ('RTFRAC1') ; XVAR = MPARAM%RTFRAC1 + CASE ('PERCRTE') ; XVAR = MPARAM%PERCRTE + CASE ('PERCEXP') ; XVAR = MPARAM%PERCEXP + CASE ('SACPMLT') ; XVAR = MPARAM%SACPMLT + CASE ('SACPEXP') ; XVAR = MPARAM%SACPEXP + CASE ('PERCFRAC') ; XVAR = MPARAM%PERCFRAC + CASE ('FRACLOWZ') ; XVAR = MPARAM%FRACLOWZ + CASE ('IFLWRTE') ; XVAR = MPARAM%IFLWRTE + CASE ('BASERTE') ; XVAR = MPARAM%BASERTE + CASE ('QB_POWR') ; XVAR = MPARAM%QB_POWR + CASE ('QB_PRMS') ; XVAR = MPARAM%QB_PRMS + CASE ('QBRATE_2A') ; XVAR = MPARAM%QBRATE_2A + CASE ('QBRATE_2B') ; XVAR = MPARAM%QBRATE_2B + CASE ('SAREAMAX') ; XVAR = MPARAM%SAREAMAX + CASE ('AXV_BEXP') ; XVAR = MPARAM%AXV_BEXP + CASE ('LOGLAMB') ; XVAR = MPARAM%LOGLAMB + CASE ('TISHAPE') ; XVAR = MPARAM%TISHAPE + CASE ('TIMEDELAY') ; XVAR = MPARAM%TIMEDELAY + CASE ('MBASE') ; XVAR = MPARAM%MBASE + CASE ('MFMAX') ; XVAR = MPARAM%MFMAX + CASE ('MFMIN') ; XVAR = MPARAM%MFMIN + CASE ('PXTEMP') ; XVAR = MPARAM%PXTEMP + CASE ('OPG') ; XVAR = MPARAM%OPG + CASE ('LAPSE') ; XVAR = MPARAM%LAPSE + + ! derived parameters + CASE ('MAXTENS_1') ; XVAR = DPARAM%MAXTENS_1 + CASE ('MAXTENS_1A') ; XVAR = DPARAM%MAXTENS_1A + CASE ('MAXTENS_1B') ; XVAR = DPARAM%MAXTENS_1B + CASE ('MAXFREE_1') ; XVAR = DPARAM%MAXFREE_1 + CASE ('MAXTENS_2') ; XVAR = DPARAM%MAXTENS_2 + CASE ('MAXFREE_2') ; XVAR = DPARAM%MAXFREE_2 + CASE ('MAXFREE_2A') ; XVAR = DPARAM%MAXFREE_2A + CASE ('MAXFREE_2B') ; XVAR = DPARAM%MAXFREE_2B + CASE ('QBSAT') ; XVAR = DPARAM%QBSAT + CASE ('RTFRAC2') ; XVAR = DPARAM%RTFRAC2 + CASE ('POWLAMB') ; XVAR = DPARAM%POWLAMB + CASE ('MAXPOW') ; XVAR = DPARAM%MAXPOW + + ! scalar elevation bands information + CASE ('Z_FORCING') ; XVAR = Z_FORCING + + ! numerical solution parameters + CASE ('SOLUTION') ; XVAR = REAL(SOLUTION_METHOD, KIND(SP)) + CASE ('TIMSTEP_TYP'); XVAR = REAL(TEMPORAL_ERROR_CONTROL, KIND(SP)) + CASE ('INITL_GUESS'); XVAR = REAL(INITIAL_NEWTON, KIND(SP)) + CASE ('JAC_RECOMPT'); XVAR = REAL(JAC_RECOMPUTE, KIND(SP)) + CASE ('CK_OVRSHOOT'); XVAR = REAL(CHECK_OVERSHOOT, KIND(SP)) + CASE ('SMALL_ESTEP'); XVAR = REAL(SMALL_ENDSTEP, KIND(SP)) + CASE ('ERRTRUNCABS'); XVAR = ERR_TRUNC_ABS + CASE ('ERRTRUNCREL'); XVAR = ERR_TRUNC_REL + CASE ('ERRITERFUNC'); XVAR = ERR_ITER_FUNC + CASE ('ERR_ITER_DX'); XVAR = ERR_ITER_DX + CASE ('THRESH_FRZE'); XVAR = THRESH_FRZE + CASE ('FSTATE_MIN') ; XVAR = FRACSTATE_MIN + CASE ('STEP_SAFETY'); XVAR = SAFETY + CASE ('RMIN') ; XVAR = RMIN + CASE ('RMAX') ; XVAR = RMAX + CASE ('NITER_TOTAL'); XVAR = REAL(NITER_TOTAL, KIND(SP)) + CASE ('MIN_TSTEP') ; XVAR = MIN_TSTEP + CASE ('MAX_TSTEP') ; XVAR = MAX_TSTEP + + ! Sobol identifier + CASE ('SOBOL_INDX') ; XVAR = REAL(SOBOL_INDX, KIND(SP)) + + ! Set to missing if not found + case default; XVAR = NA_VALUE_SP + + END SELECT + + ! and, save the output + PAREXTRACT = XVAR + ! --------------------------------------------------------------------------------------- + END FUNCTION PAREXTRACT + END MODULE PAREXTRACT_MODULE diff --git a/build/FUSE_SRC/util/selectmodl.f90 b/build/FUSE_SRC/util/selectmodl.f90 index bb3269d..026603c 100644 --- a/build/FUSE_SRC/util/selectmodl.f90 +++ b/build/FUSE_SRC/util/selectmodl.f90 @@ -24,7 +24,7 @@ SUBROUTINE SELECTMODL(FUSE_ID,ERR,MESSAGE) IMPLICIT NONE ! Input !INTEGER(I4B), INTENT(IN), OPTIONAL :: FUSE_ID ! identifier for FUSE model -CHARACTER(LEN=6), INTENT(IN), OPTIONAL :: FUSE_ID ! identifier for FUSE model +CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: FUSE_ID ! identifier for FUSE model ! Output INTEGER(I4B), INTENT(OUT) :: ERR ! error code CHARACTER(LEN=*), INTENT(OUT) :: MESSAGE ! error message @@ -67,7 +67,6 @@ SUBROUTINE SELECTMODL(FUSE_ID,ERR,MESSAGE) ! --------------------------------------------------------------------------------------- ! (0) INITIALIZE ! --------------------------------------------------------------------------------------- - NAME_FMT=1 ! format for the naming convention ICOUNT =0 IX_MODEL=0 @@ -82,8 +81,7 @@ SUBROUTINE SELECTMODL(FUSE_ID,ERR,MESSAGE) !CFILE = TRIM(SETNGS_PATH)//M_DECISIONS ! control file info shared in MODULE ddirectory CFILE = TRIM(SETNGS_PATH)//'fuse_zDecisions_'//TRIM(FUSE_ID)//'.txt' ! control file info shared in MODULE ddirectory - -INQUIRE(FILE=CFILE,EXIST=LEXIST) ! check that control file exists +INQUIRE(FILE=trim(CFILE),EXIST=LEXIST) ! check that control file exists IF (.not.LEXIST) THEN message="f-SELECTMODL/decisions file '"//trim(CFILE)//"' does not exist" err=100; return diff --git a/build/FUSE_SRC/netcdf/time_io.f90 b/build/FUSE_SRC/util/time_utils.f90 similarity index 66% rename from build/FUSE_SRC/netcdf/time_io.f90 rename to build/FUSE_SRC/util/time_utils.f90 index 9345aac..ccf1623 100644 --- a/build/FUSE_SRC/netcdf/time_io.f90 +++ b/build/FUSE_SRC/util/time_utils.f90 @@ -1,73 +1,14 @@ -module time_io +module time_utils use nrtype - use netcdf implicit none - public::get_modtim + public :: date_extractor + public :: juldayss + public :: caldatss contains - SUBROUTINE get_modtim(itim,ncid,ierr,message) - ! --------------------------------------------------------------------------------------- - ! Creator: - ! -------- - ! Martyn Clark, 2012 - ! --------------------------------------------------------------------------------------- - ! Purpose: - ! -------- - ! Read NetCDF time variable for a given time step - ! --------------------------------------------------------------------------------------- - ! Modules Modified: - ! ----------------- - ! MODULE multiforce -- populate structure timDat%(*) - ! --------------------------------------------------------------------------------------- - USE fuse_fileManager,only:INPUT_PATH ! defines data directory - USE multiforce,only:forcefile ! name of forcing file - USE multiforce,only:vname_dtime ! variable name: time since reference time - USE multiforce,only:timDat ! time data strructure - USE multiforce,only:jdayRef ! reference time (days) - USE multiforce,only:latUnits,lonUnits,timeUnits ! units string for time - - IMPLICIT NONE - ! input - integer(i4b), intent(in) :: itim ! index of model time step - integer(i4b), intent(in) :: ncid ! NetCDF file ID - ! output - integer(i4b), intent(out) :: ierr ! error code - character(*), intent(out) :: message ! error message - ! internal - integer(i4b),parameter :: strLen=1024 ! length of character string - character(len=strLen) :: cmessage ! error message of downwind routine - integer(i4b) :: iVarID ! NetCDF variable ID - integer(i4b) :: iy,im,id ! time of year - integer(i4b) :: ih ! time of day - real(sp),dimension(1) :: atime ! time array - ! --------------------------------------------------------------------------------------- - ! initialize error control - ierr=0; message='get_modtim/' - - ! get variable ID for time - ierr = nf90_inq_varid(ncid, trim(vname_dtime), iVarID) - if(ierr/=0)then; message=trim(message)//trim(nf90_strerror(ierr))//'[variable='//trim(vname_dtime)//']'; return; endif - - ! identify reference time - call date_extractor(timeUnits,iy,im,id,ih) - call juldayss(iy,im,id,ih,jdayRef,ierr,cmessage) - if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif - - ! get the time - ierr = nf90_get_var(ncid, iVarID, aTime, start=(/iTim/), count=(/1/)) - if(ierr/=0)then; message=trim(message)//trim(nf90_strerror(ierr)); return; endif - - ! put the time into the structure - timDat%dtime = aTime(1) - - ! compute the year, month, day, hour, minute, second - call caldatss(jdayRef+timDat%dtime,timDat%iy,timDat%im,timDat%id,timDat%ih,timDat%imin,timDat%dsec) - - END SUBROUTINE get_modtim - subroutine date_extractor(refDate,iy,im,id,ih) ! used to extract the date from a units string ! (based on a routine written by David Rupp) @@ -218,4 +159,4 @@ SUBROUTINE caldatss(juliandd,iyyy,im,id,ih,imin,asec) if(julian.lt.0)iyyy=iyyy-100*(1-julian/36525) END SUBROUTINE caldatss -end module time_io +end module time_utils diff --git a/build/FUSE_SRC/util/varextract.f90 b/build/FUSE_SRC/util/varextract.f90 index f73f766..e643675 100644 --- a/build/FUSE_SRC/util/varextract.f90 +++ b/build/FUSE_SRC/util/varextract.f90 @@ -1,508 +1,116 @@ -MODULE VAREXTRACT_MODULE -IMPLICIT NONE -CONTAINS -! --------------------------------------------------------------------------------------- -PURE FUNCTION VAREXTRACT(VARNAME) -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2007 -! Modified by Brian Henn to include snow model, 6/2013 -! Modified by Nans Addor to enable distributed modeling, 9/2016 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Extracts variable "VARNAME" from relevant data structures -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -USE metaoutput ! metadata for all model variables -USE multiforce ! model forcing data -USE multistate ! model states -USE multi_flux ! model fluxes -USE multibands ! model snow bands -USE multiroute ! routed runoff -USE model_numerix ! model numerix parameters -IMPLICIT NONE -! input -CHARACTER(*), INTENT(IN) :: VARNAME ! variable name -! internal -REAL(SP) :: XVAR ! variable -! output -REAL(SP) :: VAREXTRACT ! FUNCTION name -! --------------------------------------------------------------------------------------- -! initialize XVAR -XVAR=-9999._sp -SELECT CASE (TRIM(VARNAME)) - ! extract forcing data - CASE ('ppt') ; XVAR = MFORCE%PPT - CASE ('temp') ; XVAR = MFORCE%TEMP - CASE ('pet') ; XVAR = MFORCE%PET - ! extract response data - CASE ('obsq') ; XVAR = valDat%OBSQ - ! extract model states - CASE ('tens_1') ; XVAR = FSTATE%TENS_1 - CASE ('tens_1a') ; XVAR = FSTATE%TENS_1A - CASE ('tens_1b') ; XVAR = FSTATE%TENS_1B - CASE ('free_1') ; XVAR = FSTATE%FREE_1 - CASE ('watr_1') ; XVAR = FSTATE%WATR_1 - CASE ('tens_2') ; XVAR = FSTATE%TENS_2 - CASE ('free_2') ; XVAR = FSTATE%FREE_2 - CASE ('free_2a') ; XVAR = FSTATE%FREE_2A - CASE ('free_2b') ; XVAR = FSTATE%FREE_2B - CASE ('watr_2') ; XVAR = FSTATE%WATR_2 - CASE ('swe_z01') ; XVAR = MBANDS(1)%SWE - CASE ('swe_z02') ; XVAR = MBANDS(2)%SWE - CASE ('swe_z03') ; XVAR = MBANDS(3)%SWE - CASE ('swe_z04') ; XVAR = MBANDS(4)%SWE - CASE ('swe_z05') ; XVAR = MBANDS(5)%SWE - CASE ('swe_z06') ; XVAR = MBANDS(6)%SWE - CASE ('swe_z07') ; XVAR = MBANDS(7)%SWE - CASE ('swe_z08') ; XVAR = MBANDS(8)%SWE - CASE ('swe_z09') ; XVAR = MBANDS(9)%SWE - CASE ('swe_z10') ; XVAR = MBANDS(10)%SWE - CASE ('swe_z11') ; XVAR = MBANDS(11)%SWE - CASE ('swe_z12') ; XVAR = MBANDS(12)%SWE - CASE ('swe_z13') ; XVAR = MBANDS(13)%SWE - CASE ('swe_z14') ; XVAR = MBANDS(14)%SWE - CASE ('swe_z15') ; XVAR = MBANDS(15)%SWE - CASE ('swe_z16') ; XVAR = MBANDS(16)%SWE - CASE ('swe_z17') ; XVAR = MBANDS(17)%SWE - CASE ('swe_z18') ; XVAR = MBANDS(18)%SWE - CASE ('swe_z19') ; XVAR = MBANDS(19)%SWE - CASE ('swe_z20') ; XVAR = MBANDS(20)%SWE - CASE ('swe_z21') ; XVAR = MBANDS(21)%SWE - CASE ('swe_z22') ; XVAR = MBANDS(22)%SWE - CASE ('swe_z23') ; XVAR = MBANDS(23)%SWE - CASE ('swe_z24') ; XVAR = MBANDS(24)%SWE - CASE ('swe_z25') ; XVAR = MBANDS(25)%SWE - CASE ('swe_z26') ; XVAR = MBANDS(26)%SWE - CASE ('swe_z27') ; XVAR = MBANDS(27)%SWE - CASE ('swe_z28') ; XVAR = MBANDS(28)%SWE - CASE ('swe_z29') ; XVAR = MBANDS(29)%SWE - CASE ('swe_z30') ; XVAR = MBANDS(30)%SWE - CASE ('swe_z31') ; XVAR = MBANDS(31)%SWE - CASE ('swe_z32') ; XVAR = MBANDS(32)%SWE - CASE ('swe_z33') ; XVAR = MBANDS(33)%SWE - CASE ('swe_z34') ; XVAR = MBANDS(34)%SWE - CASE ('swe_z35') ; XVAR = MBANDS(35)%SWE - CASE ('swe_z36') ; XVAR = MBANDS(36)%SWE - CASE ('swe_z37') ; XVAR = MBANDS(37)%SWE - CASE ('swe_z38') ; XVAR = MBANDS(38)%SWE - CASE ('swe_z39') ; XVAR = MBANDS(39)%SWE - CASE ('swe_z40') ; XVAR = MBANDS(40)%SWE - CASE ('swe_z41') ; XVAR = MBANDS(41)%SWE - CASE ('swe_z42') ; XVAR = MBANDS(42)%SWE - CASE ('swe_z43') ; XVAR = MBANDS(43)%SWE - CASE ('swe_z44') ; XVAR = MBANDS(44)%SWE - CASE ('swe_z45') ; XVAR = MBANDS(45)%SWE - CASE ('swe_z46') ; XVAR = MBANDS(46)%SWE - CASE ('swe_z47') ; XVAR = MBANDS(47)%SWE - CASE ('swe_z48') ; XVAR = MBANDS(48)%SWE - CASE ('swe_z49') ; XVAR = MBANDS(49)%SWE - CASE ('swe_z50') ; XVAR = MBANDS(50)%SWE - ! extract model fluxes - CASE ('eff_ppt') ; XVAR = W_FLUX%EFF_PPT - CASE ('satarea') ; XVAR = W_FLUX%SATAREA - CASE ('qsurf') ; XVAR = W_FLUX%QSURF - CASE ('evap_1a') ; XVAR = W_FLUX%EVAP_1A - CASE ('evap_1b') ; XVAR = W_FLUX%EVAP_1B - CASE ('evap_1') ; XVAR = W_FLUX%EVAP_1 - CASE ('evap_2') ; XVAR = W_FLUX%EVAP_2 - CASE ('rchr2excs') ; XVAR = W_FLUX%RCHR2EXCS - CASE ('tens2free_1'); XVAR = W_FLUX%TENS2FREE_1 - CASE ('oflow_1') ; XVAR = W_FLUX%OFLOW_1 - CASE ('tens2free_2'); XVAR = W_FLUX%TENS2FREE_2 - CASE ('qintf_1') ; XVAR = W_FLUX%QINTF_1 - CASE ('qperc_12') ; XVAR = W_FLUX%QPERC_12 - CASE ('qbase_2') ; XVAR = W_FLUX%QBASE_2 - CASE ('qbase_2a') ; XVAR = W_FLUX%QBASE_2A - CASE ('qbase_2b') ; XVAR = W_FLUX%QBASE_2B - CASE ('oflow_2') ; XVAR = W_FLUX%OFLOW_2 - CASE ('oflow_2a') ; XVAR = W_FLUX%OFLOW_2A - CASE ('oflow_2b') ; XVAR = W_FLUX%OFLOW_2B - CASE ('snwacml_z01'); XVAR = MBANDS(1)%SNOWACCMLTN - CASE ('snwacml_z02'); XVAR = MBANDS(2)%SNOWACCMLTN - CASE ('snwacml_z03'); XVAR = MBANDS(3)%SNOWACCMLTN - CASE ('snwacml_z04'); XVAR = MBANDS(4)%SNOWACCMLTN - CASE ('snwacml_z05'); XVAR = MBANDS(5)%SNOWACCMLTN - CASE ('snwacml_z06'); XVAR = MBANDS(6)%SNOWACCMLTN - CASE ('snwacml_z07'); XVAR = MBANDS(7)%SNOWACCMLTN - CASE ('snwacml_z08'); XVAR = MBANDS(8)%SNOWACCMLTN - CASE ('snwacml_z09'); XVAR = MBANDS(9)%SNOWACCMLTN - CASE ('snwacml_z10'); XVAR = MBANDS(10)%SNOWACCMLTN - CASE ('snwacml_z11'); XVAR = MBANDS(11)%SNOWACCMLTN - CASE ('snwacml_z12'); XVAR = MBANDS(12)%SNOWACCMLTN - CASE ('snwacml_z13'); XVAR = MBANDS(13)%SNOWACCMLTN - CASE ('snwacml_z14'); XVAR = MBANDS(14)%SNOWACCMLTN - CASE ('snwacml_z15'); XVAR = MBANDS(15)%SNOWACCMLTN - CASE ('snwacml_z16'); XVAR = MBANDS(16)%SNOWACCMLTN - CASE ('snwacml_z17'); XVAR = MBANDS(17)%SNOWACCMLTN - CASE ('snwacml_z18'); XVAR = MBANDS(18)%SNOWACCMLTN - CASE ('snwacml_z19'); XVAR = MBANDS(19)%SNOWACCMLTN - CASE ('snwacml_z20'); XVAR = MBANDS(20)%SNOWACCMLTN - CASE ('snwacml_z21'); XVAR = MBANDS(21)%SNOWACCMLTN - CASE ('snwacml_z22'); XVAR = MBANDS(22)%SNOWACCMLTN - CASE ('snwacml_z23'); XVAR = MBANDS(23)%SNOWACCMLTN - CASE ('snwacml_z24'); XVAR = MBANDS(24)%SNOWACCMLTN - CASE ('snwacml_z25'); XVAR = MBANDS(25)%SNOWACCMLTN - CASE ('snwacml_z26'); XVAR = MBANDS(26)%SNOWACCMLTN - CASE ('snwacml_z27'); XVAR = MBANDS(27)%SNOWACCMLTN - CASE ('snwacml_z28'); XVAR = MBANDS(28)%SNOWACCMLTN - CASE ('snwacml_z29'); XVAR = MBANDS(29)%SNOWACCMLTN - CASE ('snwacml_z30'); XVAR = MBANDS(30)%SNOWACCMLTN - CASE ('snwacml_z31'); XVAR = MBANDS(31)%SNOWACCMLTN - CASE ('snwacml_z32'); XVAR = MBANDS(32)%SNOWACCMLTN - CASE ('snwacml_z33'); XVAR = MBANDS(33)%SNOWACCMLTN - CASE ('snwacml_z34'); XVAR = MBANDS(34)%SNOWACCMLTN - CASE ('snwacml_z35'); XVAR = MBANDS(35)%SNOWACCMLTN - CASE ('snwacml_z36'); XVAR = MBANDS(36)%SNOWACCMLTN - CASE ('snwacml_z37'); XVAR = MBANDS(37)%SNOWACCMLTN - CASE ('snwacml_z38'); XVAR = MBANDS(38)%SNOWACCMLTN - CASE ('snwacml_z39'); XVAR = MBANDS(39)%SNOWACCMLTN - CASE ('snwacml_z40'); XVAR = MBANDS(40)%SNOWACCMLTN - CASE ('snwacml_z41'); XVAR = MBANDS(41)%SNOWACCMLTN - CASE ('snwacml_z42'); XVAR = MBANDS(42)%SNOWACCMLTN - CASE ('snwacml_z43'); XVAR = MBANDS(43)%SNOWACCMLTN - CASE ('snwacml_z44'); XVAR = MBANDS(44)%SNOWACCMLTN - CASE ('snwacml_z45'); XVAR = MBANDS(45)%SNOWACCMLTN - CASE ('snwacml_z46'); XVAR = MBANDS(46)%SNOWACCMLTN - CASE ('snwacml_z47'); XVAR = MBANDS(47)%SNOWACCMLTN - CASE ('snwacml_z48'); XVAR = MBANDS(48)%SNOWACCMLTN - CASE ('snwacml_z49'); XVAR = MBANDS(49)%SNOWACCMLTN - CASE ('snwacml_z50'); XVAR = MBANDS(50)%SNOWACCMLTN - CASE ('snwmelt_z01'); XVAR = MBANDS(1)%SNOWMELT - CASE ('snwmelt_z02'); XVAR = MBANDS(2)%SNOWMELT - CASE ('snwmelt_z03'); XVAR = MBANDS(3)%SNOWMELT - CASE ('snwmelt_z04'); XVAR = MBANDS(4)%SNOWMELT - CASE ('snwmelt_z05'); XVAR = MBANDS(5)%SNOWMELT - CASE ('snwmelt_z06'); XVAR = MBANDS(6)%SNOWMELT - CASE ('snwmelt_z07'); XVAR = MBANDS(7)%SNOWMELT - CASE ('snwmelt_z08'); XVAR = MBANDS(8)%SNOWMELT - CASE ('snwmelt_z09'); XVAR = MBANDS(9)%SNOWMELT - CASE ('snwmelt_z10'); XVAR = MBANDS(10)%SNOWMELT - CASE ('snwmelt_z11'); XVAR = MBANDS(11)%SNOWMELT - CASE ('snwmelt_z12'); XVAR = MBANDS(12)%SNOWMELT - CASE ('snwmelt_z13'); XVAR = MBANDS(13)%SNOWMELT - CASE ('snwmelt_z14'); XVAR = MBANDS(14)%SNOWMELT - CASE ('snwmelt_z15'); XVAR = MBANDS(15)%SNOWMELT - CASE ('snwmelt_z16'); XVAR = MBANDS(16)%SNOWMELT - CASE ('snwmelt_z17'); XVAR = MBANDS(17)%SNOWMELT - CASE ('snwmelt_z18'); XVAR = MBANDS(18)%SNOWMELT - CASE ('snwmelt_z19'); XVAR = MBANDS(19)%SNOWMELT - CASE ('snwmelt_z20'); XVAR = MBANDS(20)%SNOWMELT - CASE ('snwmelt_z21'); XVAR = MBANDS(21)%SNOWMELT - CASE ('snwmelt_z22'); XVAR = MBANDS(22)%SNOWMELT - CASE ('snwmelt_z23'); XVAR = MBANDS(23)%SNOWMELT - CASE ('snwmelt_z24'); XVAR = MBANDS(24)%SNOWMELT - CASE ('snwmelt_z25'); XVAR = MBANDS(25)%SNOWMELT - CASE ('snwmelt_z26'); XVAR = MBANDS(26)%SNOWMELT - CASE ('snwmelt_z27'); XVAR = MBANDS(27)%SNOWMELT - CASE ('snwmelt_z28'); XVAR = MBANDS(28)%SNOWMELT - CASE ('snwmelt_z29'); XVAR = MBANDS(29)%SNOWMELT - CASE ('snwmelt_z30'); XVAR = MBANDS(30)%SNOWMELT - CASE ('snwmelt_z31'); XVAR = MBANDS(31)%SNOWMELT - CASE ('snwmelt_z32'); XVAR = MBANDS(32)%SNOWMELT - CASE ('snwmelt_z33'); XVAR = MBANDS(33)%SNOWMELT - CASE ('snwmelt_z34'); XVAR = MBANDS(34)%SNOWMELT - CASE ('snwmelt_z35'); XVAR = MBANDS(35)%SNOWMELT - CASE ('snwmelt_z36'); XVAR = MBANDS(36)%SNOWMELT - CASE ('snwmelt_z37'); XVAR = MBANDS(37)%SNOWMELT - CASE ('snwmelt_z38'); XVAR = MBANDS(38)%SNOWMELT - CASE ('snwmelt_z39'); XVAR = MBANDS(39)%SNOWMELT - CASE ('snwmelt_z40'); XVAR = MBANDS(40)%SNOWMELT - CASE ('snwmelt_z41'); XVAR = MBANDS(41)%SNOWMELT - CASE ('snwmelt_z42'); XVAR = MBANDS(42)%SNOWMELT - CASE ('snwmelt_z43'); XVAR = MBANDS(43)%SNOWMELT - CASE ('snwmelt_z44'); XVAR = MBANDS(44)%SNOWMELT - CASE ('snwmelt_z45'); XVAR = MBANDS(45)%SNOWMELT - CASE ('snwmelt_z46'); XVAR = MBANDS(46)%SNOWMELT - CASE ('snwmelt_z47'); XVAR = MBANDS(47)%SNOWMELT - CASE ('snwmelt_z48'); XVAR = MBANDS(48)%SNOWMELT - CASE ('snwmelt_z49'); XVAR = MBANDS(49)%SNOWMELT - CASE ('snwmelt_z50'); XVAR = MBANDS(50)%SNOWMELT - ! extract extrapolation errors - CASE ('err_tens_1') ; XVAR = W_FLUX%ERR_TENS_1 - CASE ('err_tens_1a'); XVAR = W_FLUX%ERR_TENS_1A - CASE ('err_tens_1b'); XVAR = W_FLUX%ERR_TENS_1B - CASE ('err_free_1') ; XVAR = W_FLUX%ERR_FREE_1 - CASE ('err_watr_1') ; XVAR = W_FLUX%ERR_WATR_1 - CASE ('err_tens_2') ; XVAR = W_FLUX%ERR_TENS_2 - CASE ('err_free_2') ; XVAR = W_FLUX%ERR_FREE_2 - CASE ('err_free_2a'); XVAR = W_FLUX%ERR_FREE_2A - CASE ('err_free_2b'); XVAR = W_FLUX%ERR_FREE_2B - CASE ('err_watr_2') ; XVAR = W_FLUX%ERR_WATR_2 - ! time check - CASE ('chk_time') ; XVAR = W_FLUX%CHK_TIME - ! extract model runoff - CASE ('q_instnt') ; XVAR = MROUTE%Q_INSTNT - CASE ('q_routed') ; XVAR = MROUTE%Q_ROUTED - ! extract information on numerical solution (shared in MODULE model_numerix) - CASE ('num_funcs') ; XVAR = NUM_FUNCS - CASE ('numjacobian'); XVAR = NUM_JACOBIAN - CASE ('sub_accept') ; XVAR = NUMSUB_ACCEPT - CASE ('sub_reject') ; XVAR = NUMSUB_REJECT - CASE ('sub_noconv') ; XVAR = NUMSUB_NOCONV - CASE ('max_iterns') ; XVAR = MAXNUM_ITERNS -END SELECT -! and, save the output -VAREXTRACT = XVAR -! --------------------------------------------------------------------------------------- -END FUNCTION VAREXTRACT +module varextract_module -! --------------------------------------------------------------------------------------- -! --------------------------------------------------------------------------------------- -PURE FUNCTION VAREXTRACT_3d(VARNAME,numtim) -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Nans Addor, based on Martyn Clark's 2007 VAREXTRACT -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Extracts variable "VARNAME" from relevant data structures -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -USE metaoutput ! metadata for all model variables -USE multiforce ! model forcing data -USE multistate ! model states -USE multi_flux ! model fluxes -USE multibands ! model snow bands -USE multiroute ! routed runoff -USE model_numerix ! model numerix parameters -IMPLICIT NONE -! input -CHARACTER(*), INTENT(IN) :: VARNAME ! variable name -INTEGER(i4b), INTENT(IN) :: numtim ! number of time steps -! internal -real(sp),DIMENSION(nspat1,nspat2,numtim):: XVAR_3d ! variable -integer(i4b) :: ierr ! error code -CHARACTER(LEN=1024) :: MESSAGE ! error message -! output -real(sp), DIMENSION(nspat1,nspat2,numtim) :: VAREXTRACT_3d ! FUNCTION name + use nrtype + use iso_fortran_env, only: real32 + use work_types, only: fuse_chunk + use globaldata, only: NA_VALUE_SP -! --------------------------------------------------------------------------------------- -! the length of the temporal dimension of the state variables (gState_3d and MBANDS_VAR_4d) -! is greater by one time step, so only keeping first numtim time steps, i.e. not writing -! last value the output file + implicit none + private + public :: varextract_3d -SELECT CASE (TRIM(VARNAME)) - ! extract forcing data - CASE ('ppt') ; XVAR_3d = gForce_3d%PPT - CASE ('temp') ; XVAR_3d = gForce_3d%TEMP - CASE ('pet') ; XVAR_3d = gForce_3d%PET - ! extract response data - CASE ('obsq') ; XVAR_3d = aValid%OBSQ - ! extract model states - CASE ('tens_1') ; XVAR_3d = gState_3d(:,:,1:numtim)%TENS_1 - CASE ('tens_1a') ; XVAR_3d = gState_3d(:,:,1:numtim)%TENS_1A - CASE ('tens_1b') ; XVAR_3d = gState_3d(:,:,1:numtim)%TENS_1B - CASE ('free_1') ; XVAR_3d = gState_3d(:,:,1:numtim)%FREE_1 - CASE ('watr_1') ; XVAR_3d = gState_3d(:,:,1:numtim)%WATR_1 - CASE ('tens_2') ; XVAR_3d = gState_3d(:,:,1:numtim)%TENS_2 - CASE ('free_2') ; XVAR_3d = gState_3d(:,:,1:numtim)%FREE_2 - CASE ('free_2a') ; XVAR_3d = gState_3d(:,:,1:numtim)%FREE_2A - CASE ('free_2b') ; XVAR_3d = gState_3d(:,:,1:numtim)%FREE_2B - CASE ('watr_2') ; XVAR_3d = gState_3d(:,:,1:numtim)%WATR_2 - CASE ('swe_tot') ; XVAR_3d = gState_3d(:,:,1:numtim)%swe_tot - CASE ('swe_z01') ; XVAR_3d = MBANDS_VAR_4d(:,:,1,1:numtim)%SWE - CASE ('swe_z02') ; XVAR_3d = MBANDS_VAR_4d(:,:,2,1:numtim)%SWE - CASE ('swe_z03') ; XVAR_3d = MBANDS_VAR_4d(:,:,3,1:numtim)%SWE - CASE ('swe_z04') ; XVAR_3d = MBANDS_VAR_4d(:,:,4,1:numtim)%SWE - CASE ('swe_z05') ; XVAR_3d = MBANDS_VAR_4d(:,:,5,1:numtim)%SWE - CASE ('swe_z06') ; XVAR_3d = MBANDS_VAR_4d(:,:,6,1:numtim)%SWE - CASE ('swe_z07') ; XVAR_3d = MBANDS_VAR_4d(:,:,7,1:numtim)%SWE - CASE ('swe_z08') ; XVAR_3d = MBANDS_VAR_4d(:,:,8,1:numtim)%SWE - CASE ('swe_z09') ; XVAR_3d = MBANDS_VAR_4d(:,:,9,1:numtim)%SWE - CASE ('swe_z10') ; XVAR_3d = MBANDS_VAR_4d(:,:,10,1:numtim)%SWE - CASE ('swe_z11') ; XVAR_3d = MBANDS_VAR_4d(:,:,11,1:numtim)%SWE - CASE ('swe_z12') ; XVAR_3d = MBANDS_VAR_4d(:,:,12,1:numtim)%SWE - CASE ('swe_z13') ; XVAR_3d = MBANDS_VAR_4d(:,:,13,1:numtim)%SWE - CASE ('swe_z14') ; XVAR_3d = MBANDS_VAR_4d(:,:,14,1:numtim)%SWE - CASE ('swe_z15') ; XVAR_3d = MBANDS_VAR_4d(:,:,15,1:numtim)%SWE - CASE ('swe_z16') ; XVAR_3d = MBANDS_VAR_4d(:,:,16,1:numtim)%SWE - CASE ('swe_z17') ; XVAR_3d = MBANDS_VAR_4d(:,:,17,1:numtim)%SWE - CASE ('swe_z18') ; XVAR_3d = MBANDS_VAR_4d(:,:,18,1:numtim)%SWE - CASE ('swe_z19') ; XVAR_3d = MBANDS_VAR_4d(:,:,19,1:numtim)%SWE - CASE ('swe_z20') ; XVAR_3d = MBANDS_VAR_4d(:,:,20,1:numtim)%SWE - CASE ('swe_z21') ; XVAR_3d = MBANDS_VAR_4d(:,:,21,1:numtim)%SWE - CASE ('swe_z22') ; XVAR_3d = MBANDS_VAR_4d(:,:,22,1:numtim)%SWE - CASE ('swe_z23') ; XVAR_3d = MBANDS_VAR_4d(:,:,23,1:numtim)%SWE - CASE ('swe_z24') ; XVAR_3d = MBANDS_VAR_4d(:,:,24,1:numtim)%SWE - CASE ('swe_z25') ; XVAR_3d = MBANDS_VAR_4d(:,:,25,1:numtim)%SWE - CASE ('swe_z26') ; XVAR_3d = MBANDS_VAR_4d(:,:,26,1:numtim)%SWE - CASE ('swe_z27') ; XVAR_3d = MBANDS_VAR_4d(:,:,27,1:numtim)%SWE - CASE ('swe_z28') ; XVAR_3d = MBANDS_VAR_4d(:,:,28,1:numtim)%SWE - CASE ('swe_z29') ; XVAR_3d = MBANDS_VAR_4d(:,:,29,1:numtim)%SWE - CASE ('swe_z30') ; XVAR_3d = MBANDS_VAR_4d(:,:,30,1:numtim)%SWE - CASE ('swe_z31') ; XVAR_3d = MBANDS_VAR_4d(:,:,31,1:numtim)%SWE - CASE ('swe_z32') ; XVAR_3d = MBANDS_VAR_4d(:,:,32,1:numtim)%SWE - CASE ('swe_z33') ; XVAR_3d = MBANDS_VAR_4d(:,:,33,1:numtim)%SWE - CASE ('swe_z34') ; XVAR_3d = MBANDS_VAR_4d(:,:,34,1:numtim)%SWE - CASE ('swe_z35') ; XVAR_3d = MBANDS_VAR_4d(:,:,35,1:numtim)%SWE - CASE ('swe_z36') ; XVAR_3d = MBANDS_VAR_4d(:,:,36,1:numtim)%SWE - CASE ('swe_z37') ; XVAR_3d = MBANDS_VAR_4d(:,:,37,1:numtim)%SWE - CASE ('swe_z38') ; XVAR_3d = MBANDS_VAR_4d(:,:,38,1:numtim)%SWE - CASE ('swe_z39') ; XVAR_3d = MBANDS_VAR_4d(:,:,39,1:numtim)%SWE - CASE ('swe_z40') ; XVAR_3d = MBANDS_VAR_4d(:,:,40,1:numtim)%SWE - CASE ('swe_z41') ; XVAR_3d = MBANDS_VAR_4d(:,:,41,1:numtim)%SWE - CASE ('swe_z42') ; XVAR_3d = MBANDS_VAR_4d(:,:,42,1:numtim)%SWE - CASE ('swe_z43') ; XVAR_3d = MBANDS_VAR_4d(:,:,43,1:numtim)%SWE - CASE ('swe_z44') ; XVAR_3d = MBANDS_VAR_4d(:,:,44,1:numtim)%SWE - CASE ('swe_z45') ; XVAR_3d = MBANDS_VAR_4d(:,:,45,1:numtim)%SWE - CASE ('swe_z46') ; XVAR_3d = MBANDS_VAR_4d(:,:,46,1:numtim)%SWE - CASE ('swe_z47') ; XVAR_3d = MBANDS_VAR_4d(:,:,47,1:numtim)%SWE - CASE ('swe_z48') ; XVAR_3d = MBANDS_VAR_4d(:,:,48,1:numtim)%SWE - CASE ('swe_z49') ; XVAR_3d = MBANDS_VAR_4d(:,:,49,1:numtim)%SWE - CASE ('swe_z50') ; XVAR_3d = MBANDS_VAR_4d(:,:,50,1:numtim)%SWE - ! extract model fluxes - CASE ('eff_ppt') ; XVAR_3d = W_FLUX_3d%EFF_PPT - CASE ('satarea') ; XVAR_3d = W_FLUX_3d%SATAREA - CASE ('qsurf') ; XVAR_3d = W_FLUX_3d%QSURF - CASE ('evap_1a') ; XVAR_3d = W_FLUX_3d%EVAP_1A - CASE ('evap_1b') ; XVAR_3d = W_FLUX_3d%EVAP_1B - CASE ('evap_1') ; XVAR_3d = W_FLUX_3d%EVAP_1 - CASE ('evap_2') ; XVAR_3d = W_FLUX_3d%EVAP_2 - CASE ('rchr2excs') ; XVAR_3d = W_FLUX_3d%RCHR2EXCS - CASE ('tens2free_1'); XVAR_3d = W_FLUX_3d%TENS2FREE_1 - CASE ('oflow_1') ; XVAR_3d = W_FLUX_3d%OFLOW_1 - CASE ('tens2free_2'); XVAR_3d = W_FLUX_3d%TENS2FREE_2 - CASE ('qintf_1') ; XVAR_3d = W_FLUX_3d%QINTF_1 - CASE ('qperc_12') ; XVAR_3d = W_FLUX_3d%QPERC_12 - CASE ('qbase_2') ; XVAR_3d = W_FLUX_3d%QBASE_2 - CASE ('qbase_2a') ; XVAR_3d = W_FLUX_3d%QBASE_2A - CASE ('qbase_2b') ; XVAR_3d = W_FLUX_3d%QBASE_2B - CASE ('oflow_2') ; XVAR_3d = W_FLUX_3d%OFLOW_2 - CASE ('oflow_2a') ; XVAR_3d = W_FLUX_3d%OFLOW_2A - CASE ('oflow_2b') ; XVAR_3d = W_FLUX_3d%OFLOW_2B - CASE ('snwacml_z01'); XVAR_3d = MBANDS_VAR_4d(:,:,1,1:numtim)%SNOWACCMLTN - CASE ('snwacml_z02'); XVAR_3d = MBANDS_VAR_4d(:,:,2,1:numtim)%SNOWACCMLTN - CASE ('snwacml_z03'); XVAR_3d = MBANDS_VAR_4d(:,:,3,1:numtim)%SNOWACCMLTN - CASE ('snwacml_z04'); XVAR_3d = MBANDS_VAR_4d(:,:,4,1:numtim)%SNOWACCMLTN - CASE ('snwacml_z05'); XVAR_3d = MBANDS_VAR_4d(:,:,5,1:numtim)%SNOWACCMLTN - CASE ('snwacml_z06'); XVAR_3d = MBANDS_VAR_4d(:,:,6,1:numtim)%SNOWACCMLTN - CASE ('snwacml_z07'); XVAR_3d = MBANDS_VAR_4d(:,:,7,1:numtim)%SNOWACCMLTN - CASE ('snwacml_z08'); XVAR_3d = MBANDS_VAR_4d(:,:,8,1:numtim)%SNOWACCMLTN - CASE ('snwacml_z09'); XVAR_3d = MBANDS_VAR_4d(:,:,9,1:numtim)%SNOWACCMLTN - CASE ('snwacml_z10'); XVAR_3d = MBANDS_VAR_4d(:,:,10,1:numtim)%SNOWACCMLTN - CASE ('snwacml_z11'); XVAR_3d = MBANDS_VAR_4d(:,:,11,1:numtim)%SNOWACCMLTN - CASE ('snwacml_z12'); XVAR_3d = MBANDS_VAR_4d(:,:,12,1:numtim)%SNOWACCMLTN - CASE ('snwacml_z13'); XVAR_3d = MBANDS_VAR_4d(:,:,13,1:numtim)%SNOWACCMLTN - CASE ('snwacml_z14'); XVAR_3d = MBANDS_VAR_4d(:,:,14,1:numtim)%SNOWACCMLTN - CASE ('snwacml_z15'); XVAR_3d = MBANDS_VAR_4d(:,:,15,1:numtim)%SNOWACCMLTN - CASE ('snwacml_z16'); XVAR_3d = MBANDS_VAR_4d(:,:,16,1:numtim)%SNOWACCMLTN - CASE ('snwacml_z17'); XVAR_3d = MBANDS_VAR_4d(:,:,17,1:numtim)%SNOWACCMLTN - CASE ('snwacml_z18'); XVAR_3d = MBANDS_VAR_4d(:,:,18,1:numtim)%SNOWACCMLTN - CASE ('snwacml_z19'); XVAR_3d = MBANDS_VAR_4d(:,:,19,1:numtim)%SNOWACCMLTN - CASE ('snwacml_z20'); XVAR_3d = MBANDS_VAR_4d(:,:,20,1:numtim)%SNOWACCMLTN - CASE ('snwacml_z21'); XVAR_3d = MBANDS_VAR_4d(:,:,21,1:numtim)%SNOWACCMLTN - CASE ('snwacml_z22'); XVAR_3d = MBANDS_VAR_4d(:,:,22,1:numtim)%SNOWACCMLTN - CASE ('snwacml_z23'); XVAR_3d = MBANDS_VAR_4d(:,:,23,1:numtim)%SNOWACCMLTN - CASE ('snwacml_z24'); XVAR_3d = MBANDS_VAR_4d(:,:,24,1:numtim)%SNOWACCMLTN - CASE ('snwacml_z25'); XVAR_3d = MBANDS_VAR_4d(:,:,25,1:numtim)%SNOWACCMLTN - CASE ('snwacml_z26'); XVAR_3d = MBANDS_VAR_4d(:,:,26,1:numtim)%SNOWACCMLTN - CASE ('snwacml_z27'); XVAR_3d = MBANDS_VAR_4d(:,:,27,1:numtim)%SNOWACCMLTN - CASE ('snwacml_z28'); XVAR_3d = MBANDS_VAR_4d(:,:,28,1:numtim)%SNOWACCMLTN - CASE ('snwacml_z29'); XVAR_3d = MBANDS_VAR_4d(:,:,29,1:numtim)%SNOWACCMLTN - CASE ('snwacml_z30'); XVAR_3d = MBANDS_VAR_4d(:,:,30,1:numtim)%SNOWACCMLTN - CASE ('snwacml_z31'); XVAR_3d = MBANDS_VAR_4d(:,:,31,1:numtim)%SNOWACCMLTN - CASE ('snwacml_z32'); XVAR_3d = MBANDS_VAR_4d(:,:,32,1:numtim)%SNOWACCMLTN - CASE ('snwacml_z33'); XVAR_3d = MBANDS_VAR_4d(:,:,33,1:numtim)%SNOWACCMLTN - CASE ('snwacml_z34'); XVAR_3d = MBANDS_VAR_4d(:,:,34,1:numtim)%SNOWACCMLTN - CASE ('snwacml_z35'); XVAR_3d = MBANDS_VAR_4d(:,:,35,1:numtim)%SNOWACCMLTN - CASE ('snwacml_z36'); XVAR_3d = MBANDS_VAR_4d(:,:,36,1:numtim)%SNOWACCMLTN - CASE ('snwacml_z37'); XVAR_3d = MBANDS_VAR_4d(:,:,37,1:numtim)%SNOWACCMLTN - CASE ('snwacml_z38'); XVAR_3d = MBANDS_VAR_4d(:,:,38,1:numtim)%SNOWACCMLTN - CASE ('snwacml_z39'); XVAR_3d = MBANDS_VAR_4d(:,:,39,1:numtim)%SNOWACCMLTN - CASE ('snwacml_z40'); XVAR_3d = MBANDS_VAR_4d(:,:,40,1:numtim)%SNOWACCMLTN - CASE ('snwacml_z41'); XVAR_3d = MBANDS_VAR_4d(:,:,41,1:numtim)%SNOWACCMLTN - CASE ('snwacml_z42'); XVAR_3d = MBANDS_VAR_4d(:,:,42,1:numtim)%SNOWACCMLTN - CASE ('snwacml_z43'); XVAR_3d = MBANDS_VAR_4d(:,:,43,1:numtim)%SNOWACCMLTN - CASE ('snwacml_z44'); XVAR_3d = MBANDS_VAR_4d(:,:,44,1:numtim)%SNOWACCMLTN - CASE ('snwacml_z45'); XVAR_3d = MBANDS_VAR_4d(:,:,45,1:numtim)%SNOWACCMLTN - CASE ('snwacml_z46'); XVAR_3d = MBANDS_VAR_4d(:,:,46,1:numtim)%SNOWACCMLTN - CASE ('snwacml_z47'); XVAR_3d = MBANDS_VAR_4d(:,:,47,1:numtim)%SNOWACCMLTN - CASE ('snwacml_z48'); XVAR_3d = MBANDS_VAR_4d(:,:,48,1:numtim)%SNOWACCMLTN - CASE ('snwacml_z49'); XVAR_3d = MBANDS_VAR_4d(:,:,49,1:numtim)%SNOWACCMLTN - CASE ('snwacml_z50'); XVAR_3d = MBANDS_VAR_4d(:,:,50,1:numtim)%SNOWACCMLTN - CASE ('snwmelt_z01'); XVAR_3d = MBANDS_VAR_4d(:,:,1,1:numtim)%SNOWMELT - CASE ('snwmelt_z02'); XVAR_3d = MBANDS_VAR_4d(:,:,2,1:numtim)%SNOWMELT - CASE ('snwmelt_z03'); XVAR_3d = MBANDS_VAR_4d(:,:,3,1:numtim)%SNOWMELT - CASE ('snwmelt_z04'); XVAR_3d = MBANDS_VAR_4d(:,:,4,1:numtim)%SNOWMELT - CASE ('snwmelt_z05'); XVAR_3d = MBANDS_VAR_4d(:,:,5,1:numtim)%SNOWMELT - CASE ('snwmelt_z06'); XVAR_3d = MBANDS_VAR_4d(:,:,6,1:numtim)%SNOWMELT - CASE ('snwmelt_z07'); XVAR_3d = MBANDS_VAR_4d(:,:,7,1:numtim)%SNOWMELT - CASE ('snwmelt_z08'); XVAR_3d = MBANDS_VAR_4d(:,:,8,1:numtim)%SNOWMELT - CASE ('snwmelt_z09'); XVAR_3d = MBANDS_VAR_4d(:,:,9,1:numtim)%SNOWMELT - CASE ('snwmelt_z10'); XVAR_3d = MBANDS_VAR_4d(:,:,10,1:numtim)%SNOWMELT - CASE ('snwmelt_z11'); XVAR_3d = MBANDS_VAR_4d(:,:,11,1:numtim)%SNOWMELT - CASE ('snwmelt_z12'); XVAR_3d = MBANDS_VAR_4d(:,:,12,1:numtim)%SNOWMELT - CASE ('snwmelt_z13'); XVAR_3d = MBANDS_VAR_4d(:,:,13,1:numtim)%SNOWMELT - CASE ('snwmelt_z14'); XVAR_3d = MBANDS_VAR_4d(:,:,14,1:numtim)%SNOWMELT - CASE ('snwmelt_z15'); XVAR_3d = MBANDS_VAR_4d(:,:,15,1:numtim)%SNOWMELT - CASE ('snwmelt_z16'); XVAR_3d = MBANDS_VAR_4d(:,:,16,1:numtim)%SNOWMELT - CASE ('snwmelt_z17'); XVAR_3d = MBANDS_VAR_4d(:,:,17,1:numtim)%SNOWMELT - CASE ('snwmelt_z18'); XVAR_3d = MBANDS_VAR_4d(:,:,18,1:numtim)%SNOWMELT - CASE ('snwmelt_z19'); XVAR_3d = MBANDS_VAR_4d(:,:,19,1:numtim)%SNOWMELT - CASE ('snwmelt_z20'); XVAR_3d = MBANDS_VAR_4d(:,:,20,1:numtim)%SNOWMELT - CASE ('snwmelt_z21'); XVAR_3d = MBANDS_VAR_4d(:,:,21,1:numtim)%SNOWMELT - CASE ('snwmelt_z22'); XVAR_3d = MBANDS_VAR_4d(:,:,22,1:numtim)%SNOWMELT - CASE ('snwmelt_z23'); XVAR_3d = MBANDS_VAR_4d(:,:,23,1:numtim)%SNOWMELT - CASE ('snwmelt_z24'); XVAR_3d = MBANDS_VAR_4d(:,:,24,1:numtim)%SNOWMELT - CASE ('snwmelt_z25'); XVAR_3d = MBANDS_VAR_4d(:,:,25,1:numtim)%SNOWMELT - CASE ('snwmelt_z26'); XVAR_3d = MBANDS_VAR_4d(:,:,26,1:numtim)%SNOWMELT - CASE ('snwmelt_z27'); XVAR_3d = MBANDS_VAR_4d(:,:,27,1:numtim)%SNOWMELT - CASE ('snwmelt_z28'); XVAR_3d = MBANDS_VAR_4d(:,:,28,1:numtim)%SNOWMELT - CASE ('snwmelt_z29'); XVAR_3d = MBANDS_VAR_4d(:,:,29,1:numtim)%SNOWMELT - CASE ('snwmelt_z30'); XVAR_3d = MBANDS_VAR_4d(:,:,30,1:numtim)%SNOWMELT - CASE ('snwmelt_z31'); XVAR_3d = MBANDS_VAR_4d(:,:,31,1:numtim)%SNOWMELT - CASE ('snwmelt_z32'); XVAR_3d = MBANDS_VAR_4d(:,:,32,1:numtim)%SNOWMELT - CASE ('snwmelt_z33'); XVAR_3d = MBANDS_VAR_4d(:,:,33,1:numtim)%SNOWMELT - CASE ('snwmelt_z34'); XVAR_3d = MBANDS_VAR_4d(:,:,34,1:numtim)%SNOWMELT - CASE ('snwmelt_z35'); XVAR_3d = MBANDS_VAR_4d(:,:,35,1:numtim)%SNOWMELT - CASE ('snwmelt_z36'); XVAR_3d = MBANDS_VAR_4d(:,:,36,1:numtim)%SNOWMELT - CASE ('snwmelt_z37'); XVAR_3d = MBANDS_VAR_4d(:,:,37,1:numtim)%SNOWMELT - CASE ('snwmelt_z38'); XVAR_3d = MBANDS_VAR_4d(:,:,38,1:numtim)%SNOWMELT - CASE ('snwmelt_z39'); XVAR_3d = MBANDS_VAR_4d(:,:,39,1:numtim)%SNOWMELT - CASE ('snwmelt_z40'); XVAR_3d = MBANDS_VAR_4d(:,:,40,1:numtim)%SNOWMELT - CASE ('snwmelt_z41'); XVAR_3d = MBANDS_VAR_4d(:,:,41,1:numtim)%SNOWMELT - CASE ('snwmelt_z42'); XVAR_3d = MBANDS_VAR_4d(:,:,42,1:numtim)%SNOWMELT - CASE ('snwmelt_z43'); XVAR_3d = MBANDS_VAR_4d(:,:,43,1:numtim)%SNOWMELT - CASE ('snwmelt_z44'); XVAR_3d = MBANDS_VAR_4d(:,:,44,1:numtim)%SNOWMELT - CASE ('snwmelt_z45'); XVAR_3d = MBANDS_VAR_4d(:,:,45,1:numtim)%SNOWMELT - CASE ('snwmelt_z46'); XVAR_3d = MBANDS_VAR_4d(:,:,46,1:numtim)%SNOWMELT - CASE ('snwmelt_z47'); XVAR_3d = MBANDS_VAR_4d(:,:,47,1:numtim)%SNOWMELT - CASE ('snwmelt_z48'); XVAR_3d = MBANDS_VAR_4d(:,:,48,1:numtim)%SNOWMELT - CASE ('snwmelt_z49'); XVAR_3d = MBANDS_VAR_4d(:,:,49,1:numtim)%SNOWMELT - CASE ('snwmelt_z50'); XVAR_3d = MBANDS_VAR_4d(:,:,50,1:numtim)%SNOWMELT - ! extract extrapolation errors - CASE ('err_tens_1') ; XVAR_3d = W_FLUX_3d%ERR_TENS_1 - CASE ('err_tens_1a'); XVAR_3d = W_FLUX_3d%ERR_TENS_1A - CASE ('err_tens_1b'); XVAR_3d = W_FLUX_3d%ERR_TENS_1B - CASE ('err_free_1') ; XVAR_3d = W_FLUX_3d%ERR_FREE_1 - CASE ('err_watr_1') ; XVAR_3d = W_FLUX_3d%ERR_WATR_1 - CASE ('err_tens_2') ; XVAR_3d = W_FLUX_3d%ERR_TENS_2 - CASE ('err_free_2') ; XVAR_3d = W_FLUX_3d%ERR_FREE_2 - CASE ('err_free_2a'); XVAR_3d = W_FLUX_3d%ERR_FREE_2A - CASE ('err_free_2b'); XVAR_3d = W_FLUX_3d%ERR_FREE_2B - CASE ('err_watr_2') ; XVAR_3d = W_FLUX_3d%ERR_WATR_2 - ! time check - CASE ('chk_time') ; XVAR_3d = W_FLUX_3d%CHK_TIME - ! extract model runoff - CASE ('q_instnt') ; XVAR_3d = AROUTE_3d%Q_INSTNT - CASE ('q_routed') ; XVAR_3d = AROUTE_3d%Q_ROUTED - ! extract information on numerical solution (shared in MODULE model_numerix) - CASE ('num_funcs') ; XVAR_3d = NUM_FUNCS - CASE ('numjacobian'); XVAR_3d = NUM_JACOBIAN - CASE ('sub_accept') ; XVAR_3d = NUMSUB_ACCEPT - CASE ('sub_reject') ; XVAR_3d = NUMSUB_REJECT - CASE ('sub_noconv') ; XVAR_3d = NUMSUB_NOCONV - CASE ('max_iterns') ; XVAR_3d = MAXNUM_ITERNS -END SELECT +contains -! save the output -VAREXTRACT_3d = XVAR_3d + subroutine varextract_3d(chunk, varname, nspat1, nspat2, numtim, xout) + ! --------------------------------------------------------------------------------------- + USE model_numerix + USE multiforce, only: gForce_3d, aValid ! model forcing data + USE multistate, only: gState_3d ! model states + USE multi_flux, only: w_flux_3d ! model fluxes + USE multiroute, only: aroute_3d ! routed runoff + implicit none -! --------------------------------------------------------------------------------------- -END FUNCTION VAREXTRACT_3d + type(fuse_chunk), intent(in) :: chunk + character(*), intent(in) :: varname + integer(i4b), intent(in) :: nspat1, nspat2, numtim + + ! NetCDF output buffer (matches NF90_FLOAT) + real(real32), intent(out) :: xout(nspat1, nspat2, numtim) + + ! --------------------------------------------------------------------------------------- + ! the length of the temporal dimension of the state variables (gState_3d and MBANDS_VAR_4d) + ! is greater by one time step, so only keeping first numtim time steps, i.e. not writing + ! last value the output file + + SELECT CASE (TRIM(VARNAME)) + + ! extract forcing data + CASE ('ppt') ; xout = real(gForce_3d(:,:,1:numtim)%PPT , kind=real32) + CASE ('temp') ; xout = real(gForce_3d(:,:,1:numtim)%TEMP, kind=real32) + CASE ('pet') ; xout = real(gForce_3d(:,:,1:numtim)%PET , kind=real32) + + ! extract response data + ! TODO: Check this -- it is weird that obs q is 3d + CASE ('obsq') ; xout = real(aValid(:,:,1:numtim)%OBSQ, kind=real32) + + ! extract model states + CASE ('tens_1') ; xout = real(gState_3d(:,:,1:numtim)%TENS_1 , kind=real32) + CASE ('tens_1a') ; xout = real(gState_3d(:,:,1:numtim)%TENS_1A, kind=real32) + CASE ('tens_1b') ; xout = real(gState_3d(:,:,1:numtim)%TENS_1B, kind=real32) + CASE ('free_1') ; xout = real(gState_3d(:,:,1:numtim)%FREE_1 , kind=real32) + CASE ('watr_1') ; xout = real(gState_3d(:,:,1:numtim)%WATR_1 , kind=real32) + CASE ('tens_2') ; xout = real(gState_3d(:,:,1:numtim)%TENS_2 , kind=real32) + CASE ('free_2') ; xout = real(gState_3d(:,:,1:numtim)%FREE_2 , kind=real32) + CASE ('free_2a') ; xout = real(gState_3d(:,:,1:numtim)%FREE_2A, kind=real32) + CASE ('free_2b') ; xout = real(gState_3d(:,:,1:numtim)%FREE_2B, kind=real32) + CASE ('watr_2') ; xout = real(gState_3d(:,:,1:numtim)%WATR_2 , kind=real32) + CASE ('swe_tot') ; xout = real(gState_3d(:,:,1:numtim)%swe_tot, kind=real32) + + ! extract model fluxes + CASE ('eff_ppt') ; xout = real(W_FLUX_3d(:,:,1:numtim)%EFF_PPT , kind=real32) + CASE ('satarea') ; xout = real(W_FLUX_3d(:,:,1:numtim)%SATAREA , kind=real32) + CASE ('qsurf') ; xout = real(W_FLUX_3d(:,:,1:numtim)%QSURF , kind=real32) + CASE ('evap_1a') ; xout = real(W_FLUX_3d(:,:,1:numtim)%EVAP_1A , kind=real32) + CASE ('evap_1b') ; xout = real(W_FLUX_3d(:,:,1:numtim)%EVAP_1B , kind=real32) + CASE ('evap_1') ; xout = real(W_FLUX_3d(:,:,1:numtim)%EVAP_1 , kind=real32) + CASE ('evap_2') ; xout = real(W_FLUX_3d(:,:,1:numtim)%EVAP_2 , kind=real32) + CASE ('rchr2excs') ; xout = real(W_FLUX_3d(:,:,1:numtim)%RCHR2EXCS , kind=real32) + CASE ('tens2free_1'); xout = real(W_FLUX_3d(:,:,1:numtim)%TENS2FREE_1, kind=real32) + CASE ('oflow_1') ; xout = real(W_FLUX_3d(:,:,1:numtim)%OFLOW_1 , kind=real32) + CASE ('tens2free_2'); xout = real(W_FLUX_3d(:,:,1:numtim)%TENS2FREE_2, kind=real32) + CASE ('qintf_1') ; xout = real(W_FLUX_3d(:,:,1:numtim)%QINTF_1 , kind=real32) + CASE ('qperc_12') ; xout = real(W_FLUX_3d(:,:,1:numtim)%QPERC_12 , kind=real32) + CASE ('qbase_2') ; xout = real(W_FLUX_3d(:,:,1:numtim)%QBASE_2 , kind=real32) + CASE ('qbase_2a') ; xout = real(W_FLUX_3d(:,:,1:numtim)%QBASE_2A , kind=real32) + CASE ('qbase_2b') ; xout = real(W_FLUX_3d(:,:,1:numtim)%QBASE_2B , kind=real32) + CASE ('oflow_2') ; xout = real(W_FLUX_3d(:,:,1:numtim)%OFLOW_2 , kind=real32) + CASE ('oflow_2a') ; xout = real(W_FLUX_3d(:,:,1:numtim)%OFLOW_2A , kind=real32) + CASE ('oflow_2b') ; xout = real(W_FLUX_3d(:,:,1:numtim)%OFLOW_2B , kind=real32) + + ! extract extrapolation errors + CASE ('err_tens_1') ; xout = real(W_FLUX_3d(:,:,1:numtim)%ERR_TENS_1 , kind=real32) + CASE ('err_tens_1a'); xout = real(W_FLUX_3d(:,:,1:numtim)%ERR_TENS_1A, kind=real32) + CASE ('err_tens_1b'); xout = real(W_FLUX_3d(:,:,1:numtim)%ERR_TENS_1B, kind=real32) + CASE ('err_free_1') ; xout = real(W_FLUX_3d(:,:,1:numtim)%ERR_FREE_1 , kind=real32) + CASE ('err_watr_1') ; xout = real(W_FLUX_3d(:,:,1:numtim)%ERR_WATR_1 , kind=real32) + CASE ('err_tens_2') ; xout = real(W_FLUX_3d(:,:,1:numtim)%ERR_TENS_2 , kind=real32) + CASE ('err_free_2') ; xout = real(W_FLUX_3d(:,:,1:numtim)%ERR_FREE_2 , kind=real32) + CASE ('err_free_2a'); xout = real(W_FLUX_3d(:,:,1:numtim)%ERR_FREE_2A, kind=real32) + CASE ('err_free_2b'); xout = real(W_FLUX_3d(:,:,1:numtim)%ERR_FREE_2B, kind=real32) + CASE ('err_watr_2') ; xout = real(W_FLUX_3d(:,:,1:numtim)%ERR_WATR_2 , kind=real32) + + ! time check + CASE ('chk_time') ; xout = real(W_FLUX_3d(:,:,1:numtim)%CHK_TIME, kind=real32) + + ! extract model runoff + CASE ('q_instnt') ; xout = real(AROUTE_3d(:,:,1:numtim)%Q_INSTNT, kind=real32) + CASE ('q_routed') ; xout = real(AROUTE_3d(:,:,1:numtim)%Q_ROUTED, kind=real32) + + ! extract information on numerical solution (shared in MODULE model_numerix) + ! TODO: Check the need for this -- broadcasting scalars to the 3-d field + CASE ('num_funcs') ; xout = real(NUM_FUNCS , kind=real32) + CASE ('numjacobian'); xout = real(NUM_JACOBIAN , kind=real32) + CASE ('sub_accept') ; xout = real(NUMSUB_ACCEPT, kind=real32) + CASE ('sub_reject') ; xout = real(NUMSUB_REJECT, kind=real32) + CASE ('sub_noconv') ; xout = real(NUMSUB_NOCONV, kind=real32) + CASE ('max_iterns') ; xout = real(MAXNUM_ITERNS, kind=real32) + + ! default + case default; xout = NA_VALUE_SP + + END SELECT + + ! --------------------------------------------------------------------------------------- + END SUBROUTINE VAREXTRACT_3d END MODULE VAREXTRACT_MODULE diff --git a/build/Makefile b/build/Makefile index 5a41660..900ed93 100755 --- a/build/Makefile +++ b/build/Makefile @@ -48,14 +48,14 @@ $(VERSIONFILE): | $(GENINC) printf "character(len=FUSE_GITHASH_LEN), parameter :: FUSE_GITHASH = '%s'\n" "$(GITHASH)"; \ } > $@ -#======================================================================== -# Define the libraries, driver programs, and executables -#======================================================================== - # default Fortran compiler is set to `gfortran` # other options: ifort FC = gfortran +#======================================================================== +# Define the NetCDF libraries +#======================================================================== + # find HDF5 # Check if pkg-config is available for HDF5 # Check if all required environment variables are set @@ -112,6 +112,44 @@ endif INCLUDES += -I$(HDF5_INCLUDE_DIR) -I$(NETCDF_C_INCLUDE) -I$(NETCDF_F_INCLUDE) LIBS += -L$(HDF5_LIB_DIR) -lhdf5 -lhdf5_hl -L$(NETCDF_F_LIB) -lnetcdff -L$(NETCDF_C_LIB) -lnetcdf +#======================================================================== +# Define the TOML-f libraries +#======================================================================== + +# Optional user override: set TOMLF_PREFIX=/path/to/toml-f/prefix +# Otherwise prefer pkgconf, then Homebrew. +ifeq ($(strip $(TOMLF_PREFIX)),) + # No user override: try pkgconf first + ifneq ($(shell pkgconf --exists toml-f && echo yes),) + TOMLF_PREFIX := $(shell pkgconf --variable=prefix toml-f) + TOMLF_INCLUDE := $(shell pkgconf --variable=includedir toml-f)/toml-f + TOMLF_LIB := $(shell pkgconf --variable=libdir toml-f) + else + # Fallback to Homebrew + TOMLF_PREFIX := $(shell brew --prefix toml-f 2>/dev/null) + TOMLF_INCLUDE := $(TOMLF_PREFIX)/include/toml-f + TOMLF_LIB := $(TOMLF_PREFIX)/lib + endif +else + # User override provided + TOMLF_INCLUDE := $(TOMLF_PREFIX)/include/toml-f + TOMLF_LIB := $(TOMLF_PREFIX)/lib +endif + +# toml-f module directory (where *.mod live on Homebrew) +TOMLF_MODDIR := $(TOMLF_INCLUDE)/modules + +# RPATH (macOS: runtime search path for dylibs) +RPATHS += -Wl,-rpath,$(TOMLF_LIB) + +# add toml-f include+lib +INCLUDES += -I$(TOMLF_MODDIR) -I$(TOMLF_INCLUDE) +LIBS += -L$(TOMLF_LIB) -ltoml-f + +$(info TOMLF_PREFIX = $(TOMLF_PREFIX)) +$(info TOMLF_INCLUDE = $(TOMLF_INCLUDE)) +$(info TOMLF_MODDIR = $(TOMLF_MODDIR)) +$(info TOMLF_LIB = $(TOMLF_LIB)) $(info INCLUDES are $(INCLUDES)) $(info LIBS are $(LIBS)) @@ -124,7 +162,8 @@ NUMREC_DIR = $(FUSE_SOURCE_DIR)numrec HOOKUP_DIR = $(FUSE_SOURCE_DIR)hookup DRIVER_DIR = $(FUSE_SOURCE_DIR)driver NETCDF_DIR = $(FUSE_SOURCE_DIR)netcdf -DSHARE_DIR = $(FUSE_SOURCE_DIR)dshare +SHARE_DIR = $(FUSE_SOURCE_DIR)share +TYPES_DIR = $(FUSE_SOURCE_DIR)types PRELIM_DIR = $(FUSE_SOURCE_DIR)prelim RUNTIME_DIR = $(FUSE_SOURCE_DIR)runtime PHYSICS_DIR = $(FUSE_SOURCE_DIR)physics @@ -139,10 +178,11 @@ DRIVER_EX = fuse.exe # Define the driver program and associated subroutines FUSE_DRIVER = -#FUSE_DRIVER += setup_domain.f90 -#FUSE_DRIVER += setup_model_definition.f90 -FUSE_DRIVER += fuse_metric.f90 functn.f90 -#FUSE_DRIVER += sce_driver.f90 +FUSE_DRIVER += setup_domain.f90 +FUSE_DRIVER += setup_model_definition.f90 +FUSE_DRIVER += sce_callback_context.f90 +FUSE_DRIVER += fuse_evaluate.f90 functn.f90 +FUSE_DRIVER += sce_driver.f90 FUSE_DRIVER += fuse_driver.f90 DRIVER = $(patsubst %, $(DRIVER_DIR)/%, $(FUSE_DRIVER)) @@ -158,33 +198,52 @@ FUSE_NRUTIL += nrtype.f90 FUSE_NRUTIL += nr.f90 nrutil.f90 NRUTIL = $(patsubst %, $(NUMREC_DIR)/%, $(FUSE_NRUTIL)) -# Data modules -FUSE_DATAMS = -FUSE_DATAMS += model_defn.f90 -#FUSE_DATAMS += data_types.f90 -FUSE_DATAMS += model_defnames.f90 -FUSE_DATAMS += globaldata.f90 -FUSE_DATAMS += multiconst.f90 -FUSE_DATAMS += multiforce.f90 -FUSE_DATAMS += multibands.f90 -FUSE_DATAMS += multiparam.f90 -FUSE_DATAMS += multistate.f90 -FUSE_DATAMS += multi_flux.f90 -FUSE_DATAMS += multiroute.f90 -FUSE_DATAMS += multistats.f90 -FUSE_DATAMS += model_numerix.f90 -DATAMS = $(patsubst %, $(DSHARE_DIR)/%, $(FUSE_DATAMS)) - -# Time I/O modules -FUSE_TIMEMS = -FUSE_TIMEMS += time_io.f90 -TIMUTILS = $(patsubst %, $(TIME_DIR)/%, $(FUSE_TIMEMS)) +# Global data (needs to be defined before model_defn) +G_DATA = $(SHARE_DIR)/globaldata.f90 + +# Model definition +FUSE_MODDEF = +FUSE_MODDEF += $(TYPES_DIR)/model_defn_types.f90 +FUSE_MODDEF += $(SHARE_DIR)/model_defn_data.f90 +MODDEF = $(FUSE_MODDEF) # no pattern substitution needed + +# Data types +FUSE_TYPES = +FUSE_TYPES += multiforce_types.f90 +FUSE_TYPES += multibands_types.f90 +FUSE_TYPES += multiparam_types.f90 +FUSE_TYPES += multistate_types.f90 +FUSE_TYPES += multi_flux_types.f90 +FUSE_TYPES += multiroute_types.f90 +FUSE_TYPES += multistats_types.f90 +FUSE_TYPES += work_types.f90 +FUSE_TYPES += info_types.f90 +FUSE_TYPES += data_types.f90 +TYPES = $(patsubst %, $(TYPES_DIR)/%, $(FUSE_TYPES)) + +# combined type+data (mimic legacy code) +FUSE_SHARE = +FUSE_SHARE += multiconst.f90 +FUSE_SHARE += model_defnames.f90 +FUSE_SHARE += model_numerix.f90 +FUSE_SHARE += multiforce_data.f90 +FUSE_SHARE += multibands_data.f90 +FUSE_SHARE += multiparam_data.f90 +FUSE_SHARE += multistate_data.f90 +FUSE_SHARE += multi_flux_data.f90 +FUSE_SHARE += multiroute_data.f90 +FUSE_SHARE += multistats_data.f90 +SHARE = $(patsubst %, $(SHARE_DIR)/%, $(FUSE_SHARE)) + +# combine data modules together +DATAMS = $(G_DATA) $(MODDEF) $(TYPES) $(SHARE) # Utility modules FUSE_UTILMS = FUSE_UTILMS += fuse_fileManager.f90 -#FUSE_UTILMS += alloc_domain.f90 -#FUSE_UTILMS += alloc_scratch.f90 +FUSE_UTILMS += alloc_domain.f90 +FUSE_UTILMS += alloc_scratch.f90 +FUSE_UTILMS += time_utils.f90 FUSE_UTILMS += metaoutput.f90 FUSE_UTILMS += metaparams.f90 FUSE_UTILMS += meta_stats.f90 @@ -208,7 +267,7 @@ NR_SUB = $(patsubst %, $(NUMREC_DIR)/%, $(FUSE_NR_SUB)) # FUSE physics (differentiable model) FUSE_PHYSICS = FUSE_PHYSICS += smoothers.f90 -FUSE_PHYSICS += get_parent.f90 +FUSE_PHYSICS += get_bundle.f90 FUSE_PHYSICS += update_swe_diff.f90 FUSE_PHYSICS += qsatexcess_diff.f90 FUSE_PHYSICS += evap_upper_diff.f90 @@ -258,11 +317,10 @@ SOLVER = $(patsubst %, $(SOLVER_DIR)/%, $(FUSE_SOLVER)) # FUSE preliminaries FUSE_PRELIM = -#FUSE_PRELIM += parse_command_args.f90 +FUSE_PRELIM += parse_command_args.f90 FUSE_PRELIM += ascii_util.f90 FUSE_PRELIM += uniquemodl.f90 FUSE_PRELIM += getnumerix.f90 -FUSE_PRELIM += force_info.f90 FUSE_PRELIM += getparmeta.f90 FUSE_PRELIM += assign_stt.f90 FUSE_PRELIM += assign_flx.f90 @@ -283,8 +341,7 @@ FUSE_RUNTIME += metrics.f90 FUSE_RUNTIME += conv_funcs.f90 FUSE_RUNTIME += clrsky_rad.f90 FUSE_RUNTIME += getPETgrid.f90 -#FUSE_RUNTIME += get_time_windows.f90 -FUSE_RUNTIME += get_time_indices.f90 +FUSE_RUNTIME += get_time_windows.f90 FUSE_RUNTIME += initfluxes.f90 FUSE_RUNTIME += set_all.f90 FUSE_RUNTIME += ode_int.f90 @@ -297,9 +354,10 @@ RUNTIME = $(patsubst %, $(RUNTIME_DIR)/%, $(FUSE_RUNTIME)) FUSE_NETCDF = FUSE_NETCDF += handle_err.f90 FUSE_NETCDF += extractor.f90 juldayss.f90 caldatss.f90 -#FUSE_NETCDF += domain_decomp.f90 +FUSE_NETCDF += get_domain_dims.f90 +FUSE_NETCDF += read_elevbands.f90 +FUSE_NETCDF += domain_decomp.f90 FUSE_NETCDF += get_gforce.f90 -FUSE_NETCDF += get_mbands.f90 FUSE_NETCDF += get_smodel.f90 FUSE_NETCDF += get_fparam.f90 FUSE_NETCDF += def_params.f90 @@ -320,7 +378,7 @@ FUSE_ALL += $(DATAMS) FUSE_ALL += $(UTILMS) FUSE_ALL += $(TIMUTILS) FUSE_ALL += $(NR_SUB) -#FUSE_ALL += $(PHYSICS) +FUSE_ALL += $(PHYSICS) FUSE_ALL += $(MODGUT) FUSE_ALL += $(SOLVER) FUSE_ALL += $(PRELIM) @@ -341,7 +399,11 @@ endif ifeq ($(FC),gfortran) FFLAGS_NORMA = -O3 -ffree-line-length-none -fmax-errors=0 -cpp - FFLAGS_DEBUG = -g -Wall -ffree-line-length-none -fmax-errors=0 -fbacktrace -fcheck=bounds -cpp + FFLAGS_DEBUG = -O0 -g -fno-omit-frame-pointer \ + -Wall -Wextra -Wall -Wextra -Wno-unused-parameter -Wno-unused-variable \ + -ffree-line-length-none -fmax-errors=0 -cpp \ + -fbacktrace -fcheck=all -ffpe-trap=invalid,zero,overflow \ + -finit-real=snan -finit-integer=-999999 FFLAGS_FIXED = -O2 -c -ffixed-form endif @@ -394,7 +456,7 @@ all: compile install clean # compile target compile: sce_16plus.o $(VERSIONFILE) $(FC) $(FUSE_ALL) $(DRIVER) \ - $(FFLAGS) $(LIBS) $(INCLUDES) -o $(DRIVER_EX) + $(FFLAGS) $(LIBS) $(RPATHS) $(INCLUDES) -o $(DRIVER_EX) # Remove object files clean: diff --git a/build/generated/fuseversion.inc b/build/generated/fuseversion.inc index 7dadb42..466759f 100644 --- a/build/generated/fuseversion.inc +++ b/build/generated/fuseversion.inc @@ -4,6 +4,6 @@ integer, parameter :: FUSE_BUILDTIME_LEN = 32 integer, parameter :: FUSE_GITBRANCH_LEN = 64 integer, parameter :: FUSE_GITHASH_LEN = 64 character(len=FUSE_VERSION_LEN), parameter :: FUSE_VERSION = 'v2.0.0' -character(len=FUSE_BUILDTIME_LEN), parameter :: FUSE_BUILDTIME = '2026-01-03T18:48:22Z' -character(len=FUSE_GITBRANCH_LEN), parameter :: FUSE_GITBRANCH = 'refactor/baseline' -character(len=FUSE_GITHASH_LEN), parameter :: FUSE_GITHASH = '4bb2fc3879f4acb512fb464781d8422a92e35c89' +character(len=FUSE_BUILDTIME_LEN), parameter :: FUSE_BUILDTIME = '2026-02-24T02:06:14Z' +character(len=FUSE_GITBRANCH_LEN), parameter :: FUSE_GITBRANCH = 'refactor/new-data-structures' +character(len=FUSE_GITHASH_LEN), parameter :: FUSE_GITHASH = 'fb6624e5e77051c2e8468df6abaced0d4c05613e'