diff --git a/build/FUSE_SRC/driver/functn.f90 b/build/FUSE_SRC/driver/functn.f90 index fa5acf7..14be1ae 100644 --- a/build/FUSE_SRC/driver/functn.f90 +++ b/build/FUSE_SRC/driver/functn.f90 @@ -10,7 +10,7 @@ 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 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 @@ -41,7 +41,7 @@ FUNCTION FUNCTN(NOPT,A) 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 +CALL FUSE_evaluate(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 ' diff --git a/build/FUSE_SRC/driver/fuse_driver.f90 b/build/FUSE_SRC/driver/fuse_driver.f90 index 796b6e9..13e36e6 100644 --- a/build/FUSE_SRC/driver/fuse_driver.f90 +++ b/build/FUSE_SRC/driver/fuse_driver.f90 @@ -36,9 +36,9 @@ PROGRAM DISTRIBUTED_DRIVER 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: numtim_in ! length of input time series +USE multiforce, only: numtim_sim ! length of simulated time series +USE multiforce, only: numtim_sub ! length of subperiod time series 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 @@ -61,6 +61,7 @@ PROGRAM DISTRIBUTED_DRIVER 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 def_output_module,only:def_output ! define NetCDF output file 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 @@ -73,7 +74,7 @@ PROGRAM DISTRIBUTED_DRIVER 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 fuse_evaluate_module, only: fuse_evaluate ! run model and compute the metric chosen as objective function #ifdef __MPI__ use mpi @@ -364,9 +365,9 @@ PROGRAM DISTRIBUTED_DRIVER 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) +CALL DEF_PARAMS(NUMPSET) ! define model parameters (initial CREATE) +CALL DEF_SSTATS() ! define summary statistics (REDEF) +CALL DEF_OUTPUT(nSpat1,nSpat2,N_BANDS,NUMPAR) ! define model output time series (REDEF) ! --------------------------------------------------------------------------------------- ! RUN FUSE IN DESIRED MODE @@ -388,7 +389,7 @@ PROGRAM DISTRIBUTED_DRIVER OUTPUT_FLAG=.TRUE. print *, 'Running FUSE with default parameter values' - CALL FUSE_METRIC(APAR,GRID_FLAG,NCID_FORC,METRIC_VAL,OUTPUT_FLAG,NUMPSET) + CALL FUSE_evaluate(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 @@ -402,7 +403,7 @@ PROGRAM DISTRIBUTED_DRIVER 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 + CALL FUSE_evaluate(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 @@ -458,7 +459,7 @@ PROGRAM DISTRIBUTED_DRIVER 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) + CALL FUSE_evaluate(APAR,GRID_FLAG,NCID_FORC,METRIC_VAL,OUTPUT_FLAG,NUMPSET) print *, 'Done running FUSE with best SCE parameter set' ELSE diff --git a/build/FUSE_SRC/driver/fuse_evaluate.f90 b/build/FUSE_SRC/driver/fuse_evaluate.f90 new file mode 100644 index 0000000..2a54c1b --- /dev/null +++ b/build/FUSE_SRC/driver/fuse_evaluate.f90 @@ -0,0 +1,665 @@ +MODULE fuse_evaluate_module + + use nrtype + use multi_flux_types, only: fluxes + use work_types, only: fuse_work + + IMPLICIT NONE + + ! temporary type: run context + type :: run_ctx + + ! scratch state vectors + real(sp), allocatable :: state0(:), state1(:) + + ! differentiable work struct + type(fuse_work) :: fuseStruct + + end type run_ctx + + CONTAINS + + SUBROUTINE fuse_evaluate(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 + ! 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 + 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 ! metric + + ! run context + type(run_ctx) :: ctx ! container for allocatable structures + + ! error control + integer(i4b) :: err, ierr + character(len=1024) :: message + + ! timing + real(sp) :: t1, t2 + + ! --------------------------------------------------------------------------------------- + ! allocate run-time data structures + call allocate_run(ctx, NSTATE, NUMPAR, N_BANDS, NPAR_SNOW, nspat1, nspat2, numtim_sub, ierr) + if (ierr /= 0) stop "problem allocating run context in fuse_evaluate" + + ! 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(ctx, XPAR, GRID_FLAG, MPARAM_FLAG, 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(ctx, GRID_FLAG, NCID_FORC, 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 + IF(.NOT.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(isPrint) PRINT *, 'Writing model statistics...' + CALL PUT_SSTATS(PCOUNT) + + ! deallocate run context + call deallocate_run(ctx, n_bands, ierr) + if (ierr /= 0) stop "problem deallocating run context in fuse_evaluate" + + ! 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 allocate_run: allocate run-time variables ------------------------------------------------ + ! ------------------------------------------------------------------------------------------------------------------- + + subroutine allocate_run(ctx, nState, numpar, n_bands, npar_snow, nspat1, nspat2, numtim_sub, ierr) + implicit none + + type(run_ctx), intent(inout) :: ctx + integer(i4b), intent(in) :: nState, numpar, n_bands, npar_snow, nspat1, nspat2, numtim_sub + integer(i4b), intent(out) :: ierr + + integer(i4b) :: iBands + + ierr = 0 + + ! allocate state vectors + allocate(ctx%state0(nState), ctx%state1(nState), stat=ierr) + if (ierr /= 0) return + + ! allocate flux derivative vectors (inside fuseStruct) + allocate(ctx%fuseStruct%adj%df_dS(nState), ctx%fuseStruct%adj%df_dPar(numpar), ctx%fuseStruct%adj%dL_dPar(numpar), stat=ierr) + if (ierr /= 0) return + + ! allocate elevation bands + allocate(ctx%fuseStruct%snow%sbands(n_bands), stat=ierr) + if (ierr /= 0) return + + ! allocate parameter derivative for each elevation band + do iBands = 1, n_bands + + allocate(ctx%fuseStruct%snow%sbands(iBands)%var%dSWE_dParam(npar_snow), stat=ierr) + if (ierr /= 0) return + + ctx%fuseStruct%snow%sbands(iBands)%var%dSWE_dParam(:) = 0._sp + + end do + + end subroutine allocate_run + + ! ------------------------------------------------------------------------------------------------------------------- + ! ------------------------------------------------------------------------------------------------------------------- + + ! ------------------------------------------------------------------------------------------------------------------- + ! ----- private subroutine deallocate_run: deallocate run-time variables -------------------------------------------- + ! ------------------------------------------------------------------------------------------------------------------- + + subroutine deallocate_run(ctx, n_bands, ierr) + implicit none + + type(run_ctx), intent(inout) :: ctx + integer(i4b), intent(in) :: n_bands + integer(i4b), intent(out) :: ierr + integer(i4b) :: iBands + + ierr = 0 + + ! deallocate parameter derivative vectors + do iBands=1,n_bands + deallocate(ctx%fuseStruct%snow%sbands(iBands)%var%dSWE_dParam, stat=ierr) + if (ierr /= 0) return + end do + + ! deallocate state vectors + DEALLOCATE(ctx%STATE0,ctx%STATE1,STAT=IERR) + if (ierr /= 0) return + + ! deallocate flux derivative vectors + deallocate(ctx%fuseStruct%adj%df_dS, ctx%fuseStruct%adj%df_dPar, ctx%fuseStruct%adj%dL_dPar, stat=ierr) + if (ierr /= 0) return + + ! deallocate elevation bands + deallocate(ctx%fuseStruct%snow%sbands, stat=ierr) + if (ierr /= 0) return + + end subroutine deallocate_run + + ! ------------------------------------------------------------------------------------------------------------------- + ! ------------------------------------------------------------------------------------------------------------------- + + ! ------------------------------------------------------------------------------------------------------------------- + ! ----- private subroutine initialize_run: populate param sets and initialize states ------------------------------- + ! ------------------------------------------------------------------------------------------------------------------- + + subroutine initialize_run(ctx, xpar, grid_flag, mparam_flag, 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_insert_module + use str_2_xtry_module + use xtry_2_str_module + use put_params_module, only: put_params + implicit none + + type(run_ctx), intent(inout) :: ctx + real(sp), dimension(:), intent(in) :: xpar + logical(lgt), intent(in) :: grid_flag + logical(lgt), intent(in), optional :: mparam_flag + + integer(i4b), intent(out) :: err + character(len=*), intent(out) :: message + + integer(i4b) :: iSpat1, iSpat2, iBands + + err = 0 + message = "" + + ! increment parameter counter for model output + if (.not. present(mparam_flag)) then + PCOUNT = PCOUNT + 1 + else + if (mparam_flag) PCOUNT = PCOUNT + 1 + end if + + ! 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) + if (SMODL%iSNOWM == iopt_temp_index .and. .not. grid_flag) then + Z_FORCING = Z_FORCING_grid(1,1) + MBANDS(:)%info = MBANDS_INFO_3d(1,1,:) + end if + + 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, ctx%state0) + call xtry_2_str(ctx%state0, 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 + ctx%fuseStruct%snow%sbands(:)%var%SWE = 0._sp + ctx%fuseStruct%snow%sbands(:)%var%SNOWACCMLTN = 0._sp + ctx%fuseStruct%snow%sbands(:)%var%SNOWMELT = 0._sp + ctx%fuseStruct%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) = ctx%fuseStruct%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() + + print*, 'end of initialize' + + end subroutine initialize_run + + ! ------------------------------------------------------------------------------------------------------------------- + ! ------------------------------------------------------------------------------------------------------------------- + + ! ------------------------------------------------------------------------------------------------------------------- + ! ----- private subroutine run_time_loop: run fuse for the entire time series -------------------------------------- + ! ------------------------------------------------------------------------------------------------------------------- + + subroutine run_time_loop(ctx, grid_flag, ncid_forc, output_flag, ierr, message) + + use globaldata, only: isPrint + 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_io, only: get_modtim + use getPETgrid_module, only: getPETgrid + use get_gforce_module, only: get_gforce_3d + use put_output_module, only: put_output + + implicit none + + type(run_ctx), intent(inout) :: ctx + logical(lgt), intent(in) :: grid_flag + integer(i4b), intent(in) :: ncid_forc + 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 = "" + + ! 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(chunk_start_in,chunk_len,ncid_forc,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 get_modtim(in_idx,ncid_forc,ierr,message) + IF(ierr/=0) stop TRIM(message) + + ! 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(ctx, grid_flag, sub_idx, iSpat1, iSpat2, dt_sub, dt_full, ierr, message) + if (ierr /= 0) stop trim(message) + + END DO ! (looping thru 2nd spatial dimension) + END DO ! (looping thru 1st spatial dimension) + + end do ! looping through subperiod + + ! ----------------------------------------------------------------------------------------------------------------- + + ! ----------------------------------------------------------------------------------------------------------------- + ! ----- 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(ctx%fuseStruct, 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(ctx, grid_flag, 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(run_ctx), intent(inout) :: ctx + logical(lgt), intent(in) :: grid_flag + 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 = "" + 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, ctx%STATE0) + + ! 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(ctx%fuseStruct) + + ! ------------------------- + ! 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 + ctx%fuseStruct%snow%z_forcing = Z_FORCING + ctx%fuseStruct%snow%sbands(:)%info = MBANDS(:)%info + ctx%fuseStruct%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(ctx%fuseStruct, 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, ctx%STATE0, ctx%STATE1, dt_sub, dt_full, ierr, cmessage) + if (ierr /= 0) then + err=1; message=trim(cmessage); return + end if + + case(differentiable) + call implicit_solve(ctx%fuseStruct, ctx%state0, ctx%state1, nState, ierr, cmessage) + if (ierr /= 0) then + err=1; message=trim(cmessage); return + end if + W_FLUX = ctx%fuseStruct%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(ctx%STATE1, 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 = ctx%fuseStruct%snow%z_forcing + MBANDS(:)%info = ctx%fuseStruct%snow%sbands(:)%info + MBANDS(:)%var = ctx%fuseStruct%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 + if (grid_flag) then + 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) + end if + + ! 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/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..268f0f7 100644 --- a/build/FUSE_SRC/netcdf/def_output.f90 +++ b/build/FUSE_SRC/netcdf/def_output.f90 @@ -1,207 +1,141 @@ -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 + implicit none + private + public :: DEF_OUTPUT + +contains + + SUBROUTINE DEF_OUTPUT(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: latitude,longitude, timeUnits + USE globaldata, only: ncid_out + + implicit none + + 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_lon, dim_lat, 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(msp), dimension(nspat1) :: longitude_msp + real(msp), dimension(nspat2) :: latitude_msp + real(msp), parameter :: NA_VALUE_OUT = -9999._msp + + 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, "longitude", nSpat1, dim_lon); call handle_err(ierr) + ierr = nf90_def_dim(ncid_out, "latitude", nSpat2, dim_lat); call handle_err(ierr) + + dimids_3 = (/ dim_lon, dim_lat, dim_time /) + dimids_band = (/ dim_lon, dim_lat, dim_band, dim_time /) + dimids_par = (/ dim_lon, dim_lat, dim_par, dim_time /) + + ! Time-varying output vars + do ivar = 1, NOUTVAR + + print*, trim(VNAME(ivar)) + + 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 + + ! 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_lat/), varid_lat); call handle_err(ierr) + ierr = nf90_put_att(ncid_out, varid_lat, "units", "degreesN"); call handle_err(ierr) + ierr = nf90_put_att(ncid_out, varid_lat, "axis", "Y"); call handle_err(ierr) + + ierr = nf90_def_var(ncid_out, "longitude", NF90_FLOAT, (/dim_lon/), varid_lon); call handle_err(ierr) + ierr = nf90_put_att(ncid_out, varid_lon, "units", "degreesE"); call handle_err(ierr) + ierr = nf90_put_att(ncid_out, varid_lon, "axis", "X"); 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_msp = latitude + longitude_msp = longitude + + ierr = nf90_put_var(ncid_out, varid_lat, latitude_msp); call handle_err(ierr) + ierr = nf90_put_var(ncid_out, varid_lon, longitude_msp); 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) + + print *, 'NetCDF file for model runs defined with dimensions', nSpat1, nSpat2, n_bands, NUMPAR + + ierr = nf90_close(ncid_out); call handle_err(ierr) + + END SUBROUTINE DEF_OUTPUT + +END MODULE DEF_OUTPUT_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/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..1d7c9cf --- /dev/null +++ b/build/FUSE_SRC/physics/get_bundle.f90 @@ -0,0 +1,45 @@ +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..5bc7c7e --- /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..b575c31 --- /dev/null +++ b/build/FUSE_SRC/physics/qsatexcess_diff.f90 @@ -0,0 +1,157 @@ +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 + ! ------------------------------------------------------------------------------------------------- + ! 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) + + ! ----- 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/update_swe.f90 b/build/FUSE_SRC/physics_orig/update_swe.f90 index 646f73f..90e8751 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,72 @@ 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/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/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/runtime/get_time_indices.f90 b/build/FUSE_SRC/runtime/get_time_indices.f90 index e71333e..82c5fbe 100644 --- a/build/FUSE_SRC/runtime/get_time_indices.f90 +++ b/build/FUSE_SRC/runtime/get_time_indices.f90 @@ -12,13 +12,14 @@ SUBROUTINE GET_TIME_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 multiforce, ONLY: timeUnits,time_steps,julian_day_input ! time data + USE multiforce, only: numtim_in ! length of input time series + USE multiforce, only: numtim_sim ! length of simulated time series + USE multiforce, only: numtim_sub ! length of subperiod time series + USE multiforce, only: istart ! timestep indices (istart=sim_beg) + 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,& @@ -28,7 +29,7 @@ SUBROUTINE GET_TIME_INDICES INTEGER(I4B) :: ERR ! error code CHARACTER(LEN=1024) :: MESSAGE ! error message - ! dummies + ! local variables 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 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/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/dshare/globaldata.f90 b/build/FUSE_SRC/share/globaldata.f90 similarity index 100% rename from build/FUSE_SRC/dshare/globaldata.f90 rename to build/FUSE_SRC/share/globaldata.f90 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..95e42ca --- /dev/null +++ b/build/FUSE_SRC/share/multiforce_data.f90 @@ -0,0 +1,180 @@ +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), DIMENSION(:,:,:), POINTER :: aValid ! all model validation data + + ! forcing data structures + TYPE(FDATA), DIMENSION(:), POINTER :: AFORCE ! all model forcing data + TYPE(FDATA), DIMENSION(:), POINTER :: CFORCE ! COPY of model forcing data + TYPE(FDATA) :: MFORCE ! model forcing data for a single time step + TYPE(aData), DIMENSION(:,:), POINTER :: ancilF ! ancillary forcing data for the 2-d grid + TYPE(fData), DIMENSION(:,:), POINTER :: gForce ! model forcing data for a 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 + + ! 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..2fc8071 --- /dev/null +++ b/build/FUSE_SRC/share/multiparam_data.f90 @@ -0,0 +1,37 @@ +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 :: 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) :: 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..46771e4 --- /dev/null +++ b/build/FUSE_SRC/types/data_types.f90 @@ -0,0 +1,70 @@ +module data_types + + use nrtype + + use multiforce_types, only: ADATA, FDATA, VDATA + use multibands_types, only: 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 (nx_local, ny_local, numtim_sub) + type(FDATA), allocatable :: force(:,:,:) ! force_3d + + ! 3D state window (nx_local, ny_local, numtim_sub+1) + type(STATEV), allocatable :: state(:,:,:) ! state_3d + + ! 3D flux window (nx_local, ny_local, numtim_sub) + type(FLUXES), allocatable :: flux(:,:,:) ! flux_3d + + ! 3D routing window (nx_local, ny_local, numtim_sub) + type(RUNOFF), allocatable :: route(:,:,:) ! route_3d + + ! 4D snow-band state window (nx_local, ny_local, n_bands, numtim_sub+1) + type(BANDS_VAR), allocatable :: bands(:,:,:,:) ! bands_var_4d + + ! 3D observed discharge / validity (optional) + type(VDATA), allocatable :: valid(:,:,:) ! (nx_local, ny_local, numtim_sub) + + ! basin-average time series for output convenience + type(FDATA), allocatable :: aForce(:) ! (numtim_sub) + type(RUNOFF), allocatable :: aRoute(:) ! (numtim_sub) + + 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..8721942 --- /dev/null +++ b/build/FUSE_SRC/types/info_types.f90 @@ -0,0 +1,182 @@ +module info_types + + use nrtype + + use multiparam_types, only: par_id + + private + public :: cli_options + 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 :: jdate(:) ! julian day for each forcing record + + end type time_info + + ! ------------------------------------------------------------------------------------- + + type :: snow_info + integer(i4b) :: n_bands = 0 + end type snow_info + + ! ------------------------------------------------------------------------------------- + + type :: file_info + + ! directories + character(len=512) :: setngs_path = "" + character(len=512) :: input_path = "" + character(len=512) :: output_path = "" + + ! settings filenames (relative or absolute) + character(len=512) :: forcinginfo = "" + character(len=512) :: constraints = "" + character(len=512) :: mod_numerix = "" + character(len=512) :: m_decisions = "" + + ! domain-derived input suffixes + character(len=512) :: suffix_forcing = "" + character(len=512) :: 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_runs = "" + character(len=512) :: fname_netcdf_para = "" + + 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=64) :: fmodel_id = "" + + ! model information + integer(i4b) :: nState = -9999 + integer(i4b) :: nParam = -9999 + + ! 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=20) :: date_start_sim = "" + character(len=20) :: date_end_sim = "" + character(len=20) :: date_start_eval = "" + character(len=20) :: date_end_eval = "" + character(len=20) :: 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 + + ! SCE settings (store as numeric types) + integer(i4b) :: maxn = -9999 + integer(i4b) :: kstop = -9999 + real(sp) :: pcento = -9999._sp + + ! store raw strings too if you care about provenance + 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..cbe94c7 --- /dev/null +++ b/build/FUSE_SRC/types/work_types.f90 @@ -0,0 +1,95 @@ +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) :: 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 + + ! 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_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/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/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..2dd2586 100755 --- a/build/Makefile +++ b/build/Makefile @@ -124,7 +124,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 @@ -141,7 +142,7 @@ DRIVER_EX = fuse.exe FUSE_DRIVER = #FUSE_DRIVER += setup_domain.f90 #FUSE_DRIVER += setup_model_definition.f90 -FUSE_DRIVER += fuse_metric.f90 functn.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,22 +159,45 @@ 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)) +# 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) # Time I/O modules FUSE_TIMEMS = @@ -208,7 +232,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 @@ -320,7 +344,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 +365,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 diff --git a/build/generated/fuseversion.inc b/build/generated/fuseversion.inc index 7dadb42..766b59f 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-19T17:28:43Z' +character(len=FUSE_GITBRANCH_LEN), parameter :: FUSE_GITBRANCH = 'refactor/fuse-evaluate' +character(len=FUSE_GITHASH_LEN), parameter :: FUSE_GITHASH = 'b8f2947a48c6572ac6cd4d14a15a9adaedb1afbb'